[project @ 1996-12-19 09:10:02 by simonpj]

SLPJ new renamer and lots more

175 files changed, 10329 insertions, 12747 deletions

diff --git a/ghc/compiler/HsVersions.h b/ghc/compiler/HsVersions.h
index d64c74b06e..c630c8dcfa 100644
--- a/ghc/compiler/HsVersions.h
+++ b/ghc/compiler/HsVersions.h
@@ -110,6 +110,7 @@ you will screw up the layout where they are used in case expressions!
 #  define FAST_STRING	_PackedString
 #  define SLIT(x)	(_packCString (A# x#))
 #  define _CMP_STRING_	cmpPString
+	/* cmpPString defined in utils/Util.lhs */
 #  define _NULL_	_nullPS
 #  define _NIL_		_nilPS
 #  define _CONS_	_consPS
diff --git a/ghc/compiler/Makefile b/ghc/compiler/Makefile
index cafc24aed6..b59469cde4 100644
--- a/ghc/compiler/Makefile
+++ b/ghc/compiler/Makefile
@@ -1,5 +1,5 @@
 # -----------------------------------------------------------------------------
-# $Id: Makefile,v 1.4 1996/12/18 18:42:48 dnt Exp $
+# $Id: Makefile,v 1.5 1996/12/19 09:10:03 simonpj Exp $
 
 TOP = ../..
 FlexSuffixRules = YES
@@ -100,12 +100,26 @@ endif
 INCLUDEDIRS = $(foreach dir,$(DIRS),-i$(dir))
 SRCS = \
   $(foreach dir,$(DIRS),$(wildcard $(dir)/*.lhs)) \
-  $(UGNHS) rename/ParseIface.hs
+  $(UGNHS) rename/ParseIface.hs \
+  main/LoopHack.hc
+
+# LoopHack.lhc is an SLPJ addition to fix a profiling problem.  See comments
+# inside it.
+
 LOOPS = $(patsubst %.lhi, %.hi, $(wildcard */*.lhi))
 HCS = $(patsubst %.hs, %.hc, $(patsubst %.lhs, %.hc, $(SRCS)))
 OBJS = \
   $(patsubst %.hc, %.o, $(HCS)) rename/ParseIface.o \
-  parser/hsclink.o parser/hschooks.o libhsp.a
+  parser/hsclink.o parser/hschooks.o libhsp.a \
+  main/LoopHack.o
+
+main/LoopHack.hc : main/LoopHack.lhc
+	$(RM) $@
+	$(GHC_UNLIT) $<  $@ || ( $(RM) $@ && exit 1 )
+	@chmod 444 $@
+
+main/LoopHack.o : main/LoopHack.hc
+	$(HC) -v -c $(HC_OPTS) $<  
 
 # -----------------------------------------------------------------------------
 # options for the Haskell compiler
@@ -141,7 +155,9 @@ endif
 all :: hsc libhsp.a
 
 hsc : $(OBJS)
-	$(HC) $(HC_OPTS) -o $@ $^
+#	$(HC) -no-link-chk "-pgml time /projects/pacsoft/ghc/src/pureatria/purelink-1.2.2-solaris2/purelink gcc" $(HC_OPTS) -o $@ $^
+	$(HC) -no-link-chk "-pgml time gcc -B/projects/unsupported/gnu/sparc-sunos5/bin/g" $(HC_OPTS) -o $@ $^
+#	$(HC) -no-link-chk "-pgml time gcc" $(HC_OPTS) -o $@ $^
 
 parser/hschooks.o : parser/hschooks.c
 	@$(RM) $@
@@ -149,7 +165,7 @@ parser/hschooks.o : parser/hschooks.c
 
 rename/ParseIface.hs : rename/ParseIface.y
 	@$(RM) rename/ParseIface.hs rename/ParseIface.hinfo
-	happy -g rename/ParseIface.y
+	happy +RTS -K2m -RTS -g rename/ParseIface.y
 	@chmod 444 rename/ParseIface.hs
 
 # ----------------------------------------------------------------------------
diff --git a/ghc/compiler/absCSyn/AbsCSyn.lhs b/ghc/compiler/absCSyn/AbsCSyn.lhs
index 61d17ac70a..be099d0b14 100644
--- a/ghc/compiler/absCSyn/AbsCSyn.lhs
+++ b/ghc/compiler/absCSyn/AbsCSyn.lhs
@@ -37,7 +37,7 @@ module AbsCSyn {- (
 
 IMP_Ubiq(){-uitous-}
 
-import CgCompInfo   	( mAX_Vanilla_REG, mAX_Float_REG,
+import Constants   	( mAX_Vanilla_REG, mAX_Float_REG,
 			  mAX_Double_REG, lIVENESS_R1, lIVENESS_R2,
 			  lIVENESS_R3, lIVENESS_R4, lIVENESS_R5,
 			  lIVENESS_R6, lIVENESS_R7, lIVENESS_R8
diff --git a/ghc/compiler/absCSyn/CLabel.lhs b/ghc/compiler/absCSyn/CLabel.lhs
index 1ecd2e1036..98464fa3eb 100644
--- a/ghc/compiler/absCSyn/CLabel.lhs
+++ b/ghc/compiler/absCSyn/CLabel.lhs
@@ -290,22 +290,16 @@ isAsmTemp _ 	    	   = False
 \end{code}
 
 C ``static'' or not...
+From the point of view of the code generator, a name is
+externally visible if it should be given put in the .o file's 
+symbol table; that is, made static.
+
 \begin{code}
 externallyVisibleCLabel (TyConLabel tc _) = True
 externallyVisibleCLabel (CaseLabel _ _)	  = False
 externallyVisibleCLabel (AsmTempLabel _)  = False
 externallyVisibleCLabel (RtsLabel _)	  = True
-externallyVisibleCLabel (IdLabel (CLabelId id) _)
-  | isDataCon id 	  = True
-  | is_ConstMethodId id   = True  -- These are here to ensure splitting works
-  | isDictFunId id 	  = True  -- when these values have not been exported
-  | is_DefaultMethodId id = True
-  | is_SuperDictSelId id  = True
-  | otherwise    	  = externallyVisibleId id
-  where
-    is_ConstMethodId   id = maybeToBool (isConstMethodId_maybe   id)
-    is_DefaultMethodId id = maybeToBool (isDefaultMethodId_maybe id)
-    is_SuperDictSelId  id = maybeToBool (isSuperDictSelId_maybe  id)
+externallyVisibleCLabel (IdLabel (CLabelId id) _) = externallyVisibleId id
 \end{code}
 
 OLD?: These GRAN functions are needed for spitting out GRAN_FETCH() at the
diff --git a/ghc/compiler/absCSyn/CStrings.lhs b/ghc/compiler/absCSyn/CStrings.lhs
index 4697911f89..720e143fa9 100644
--- a/ghc/compiler/absCSyn/CStrings.lhs
+++ b/ghc/compiler/absCSyn/CStrings.lhs
@@ -126,7 +126,7 @@ identToC ps
     char_to_c '<'  = ppPStr SLIT("Zl")
     char_to_c '-'  = ppPStr SLIT("Zm")
     char_to_c '!'  = ppPStr SLIT("Zn")
-    char_to_c '.'  = ppPStr SLIT("Zo")
+    char_to_c '.'  = ppPStr SLIT("_")
     char_to_c '+'  = ppPStr SLIT("Zp")
     char_to_c '\'' = ppPStr SLIT("Zq")
     char_to_c '*'  = ppPStr SLIT("Zt")
diff --git a/ghc/compiler/absCSyn/PprAbsC.lhs b/ghc/compiler/absCSyn/PprAbsC.lhs
index 2f11f1acf6..e73bf1576f 100644
--- a/ghc/compiler/absCSyn/PprAbsC.lhs
+++ b/ghc/compiler/absCSyn/PprAbsC.lhs
@@ -29,7 +29,7 @@ import AbsCSyn
 import AbsCUtils	( getAmodeRep, nonemptyAbsC,
 			  mixedPtrLocn, mixedTypeLocn
 			)
-import CgCompInfo	( spARelToInt, spBRelToInt, mIN_UPD_SIZE )
+import Constants	( spARelToInt, spBRelToInt, mIN_UPD_SIZE )
 import CLabel		( externallyVisibleCLabel, mkErrorStdEntryLabel,
 			  isReadOnly, needsCDecl, pprCLabel,
 			  CLabel{-instance Ord-}
diff --git a/ghc/compiler/basicTypes/FieldLabel.lhs b/ghc/compiler/basicTypes/FieldLabel.lhs
index 7e3b67cd50..ea2ee94e31 100644
--- a/ghc/compiler/basicTypes/FieldLabel.lhs
+++ b/ghc/compiler/basicTypes/FieldLabel.lhs
@@ -10,7 +10,7 @@ module FieldLabel where
 
 IMP_Ubiq(){-uitous-}
 
-import Name		( Name{-instance Eq/Outputable-} )
+import Name		( Name{-instance Eq/Outputable-}, nameUnique )
 import Type		( SYN_IE(Type) )
 \end{code}
 
@@ -42,4 +42,7 @@ instance Outputable FieldLabel where
 
 instance NamedThing FieldLabel where
     getName (FieldLabel n _ _) = n
+
+instance Uniquable FieldLabel where
+    uniqueOf (FieldLabel n _ _) = nameUnique n
 \end{code}
diff --git a/ghc/compiler/basicTypes/Id.lhs b/ghc/compiler/basicTypes/Id.lhs
index 79313ba581..201c4ac5a3 100644
--- a/ghc/compiler/basicTypes/Id.lhs
+++ b/ghc/compiler/basicTypes/Id.lhs
@@ -31,9 +31,8 @@ module Id (
 	mkUserId,
 	mkUserLocal,
 	mkWorkerId,
-
-	-- MANGLING
-	unsafeGenId2Id,
+	mkPrimitiveId, 
+	setIdVisibility,
 
 	-- DESTRUCTION (excluding pragmatic info)
 	idPrimRep,
@@ -54,12 +53,14 @@ module Id (
 	recordSelectorFieldLabel,
 
 	-- PREDICATES
+	wantIdSigInIface,
 	cmpEqDataCon,
 	cmpId,
 	cmpId_withSpecDataCon,
 	externallyVisibleId,
 	idHasNoFreeTyVars,
 	idWantsToBeINLINEd,
+	idMustBeINLINEd,
 	isBottomingId,
 	isConstMethodId,
 	isConstMethodId_maybe,
@@ -68,12 +69,13 @@ module Id (
 	isDefaultMethodId_maybe,
 	isDictFunId,
 	isImportedId,
-	isMethodSelId,
+	isRecordSelector,
+	isMethodSelId_maybe,
 	isNullaryDataCon,
 	isSpecPragmaId,
 	isSuperDictSelId_maybe,
+	isPrimitiveId_maybe,
 	isSysLocalId,
-	isTopLevId,
 	isTupleCon,
 	isWorkerId,
 	isWrapperId,
@@ -96,6 +98,7 @@ module Id (
 	addIdSpecialisation,
 
 	-- UNFOLDING, ARITY, UPDATE, AND STRICTNESS STUFF (etc)
+	addIdUnfolding,
 	addIdArity,
 	addIdDemandInfo,
 	addIdStrictness,
@@ -149,19 +152,20 @@ import Bag
 import Class		( classOpString, SYN_IE(Class), GenClass, SYN_IE(ClassOp), GenClassOp )
 import IdInfo
 import Maybes		( maybeToBool )
-import Name		( appendRdr, nameUnique, mkLocalName, isLocalName,
-			  isLocallyDefinedName,
-			  mkTupleDataConName, mkCompoundName, mkCompoundName2,
-			  isLexSym, isLexSpecialSym,
-			  isLocallyDefined, changeUnique,
-			  getOccName, origName, moduleOf,
-			  isExported, ExportFlag(..),
-			  RdrName(..), Name
+import Name		( nameUnique, mkLocalName, mkSysLocalName, isLocalName,
+			  mkCompoundName, mkInstDeclName, mkWiredInIdName, mkGlobalName,
+			  isLocallyDefinedName, occNameString, modAndOcc,
+			  isLocallyDefined, changeUnique, isWiredInName,
+			  nameString, getOccString, setNameVisibility,
+			  isExported, ExportFlag(..), DefnInfo, Provenance,
+			  OccName(..), Name
 			)
+import PrelMods		( pREL_TUP, pREL_BASE )
+import Lex		( mkTupNameStr )
 import FieldLabel	( fieldLabelName, FieldLabel(..){-instances-} )
 import PragmaInfo	( PragmaInfo(..) )
 import PprEnv		-- ( SYN_IE(NmbrM), NmbrEnv(..) )
-import PprType		( getTypeString, typeMaybeString, specMaybeTysSuffix,
+import PprType		( getTypeString, specMaybeTysSuffix,
 			  nmbrType, nmbrTyVar,
 			  GenType, GenTyVar
 			)
@@ -169,20 +173,22 @@ import PprStyle
 import Pretty
 import MatchEnv		( MatchEnv )
 import SrcLoc		( mkBuiltinSrcLoc )
-import TyCon		( TyCon, mkTupleTyCon, tyConDataCons )
+import TysWiredIn	( tupleTyCon )
+import TyCon		( TyCon, tyConDataCons )
 import Type		( mkSigmaTy, mkTyVarTys, mkFunTys, mkDictTy,
 			  applyTyCon, instantiateTy, mkForAllTys,
 			  tyVarsOfType, applyTypeEnvToTy, typePrimRep,
 			  GenType, SYN_IE(ThetaType), SYN_IE(TauType), SYN_IE(Type)
 			)
 import TyVar		( alphaTyVars, isEmptyTyVarSet, SYN_IE(TyVarEnv) )
+import Usage		( SYN_IE(UVar) )
 import UniqFM
 import UniqSet		-- practically all of it
 import Unique		( getBuiltinUniques, pprUnique, showUnique,
-			  incrUnique,
+			  incrUnique, 
 			  Unique{-instance Ord3-}
 			)
-import Util		( mapAccumL, nOfThem, zipEqual,
+import Util		( mapAccumL, nOfThem, zipEqual, assoc,
 			  panic, panic#, pprPanic, assertPanic
 			)
 \end{code}
@@ -207,7 +213,7 @@ data GenId ty = Id
 			-- eg specialise-me, inline-me
 	IdInfo		-- Properties of this Id deduced by compiler
 				   
-type Id = GenId Type
+type Id	           = GenId Type
 
 data StrictnessMark = MarkedStrict | NotMarkedStrict
 
@@ -221,6 +227,8 @@ data IdDetails
   | SysLocalId	Bool	        -- Local name; made up by the compiler
 				-- as for LocalId
 
+  | PrimitiveId PrimOp		-- The Id for a primitive operation
+
   | SpecPragmaId 		-- Local name; introduced by the compiler
 		 (Maybe Id)	-- for explicit specid in pragma
 		 Bool		-- as for LocalId
@@ -229,12 +237,6 @@ data IdDetails
 
   | ImportedId			-- Global name (Imported or Implicit); Id imported from an interface
 
-  | 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
-	-- the monomorphism restriction applies.
-
   ---------------- Data constructors
 
   | DataConId	ConTag
@@ -281,7 +283,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.
-		Module		-- module where instance came from
 
 				-- see below
   | ConstMethodId		-- A method which depends only on the type of the
@@ -304,6 +305,8 @@ data IdDetails
 				-- we may specialise to a type w/ free tyvars
 				-- (i.e., in one of the "Maybe Type" dudes).
 
+-- Scheduled for deletion: SLPJ Nov 96
+-- Nobody seems to depend on knowing this.
   | WorkerId			-- A "worker" for some other Id
 		Id		-- Id for which this is a worker
 
@@ -402,24 +405,6 @@ the infinite family of tuples.
 their @IdInfo@).
 
 %----------------------------------------------------------------------
-\item[@TopLevId@:] These are values defined at the top-level in this
-module; i.e., those which {\em might} be exported (hence, a
-@Name@).  It does {\em not} include those which are moved to the
-top-level through program transformations.
-
-We also guarantee that @TopLevIds@ will {\em stay} at top-level.
-Theoretically, they could be floated inwards, but there's no known
-advantage in doing so.	This way, we can keep them with the same
-@Unique@ throughout (no cloning), and, in general, we don't have to be
-so paranoid about them.
-
-In particular, we had the following problem generating an interface:
-We have to ``stitch together'' info (1)~from the typechecker-produced
-global-values list (GVE) and (2)~from the STG code [which @Ids@ have
-what arities].	If the @Uniques@ on the @TopLevIds@ can {\em change}
-between (1) and (2), you're sunk!
-
-%----------------------------------------------------------------------
 \item[@MethodSelId@:] A selector from a dictionary; it may select either
 a method or a dictionary for one of the class's superclasses.
 
@@ -469,7 +454,7 @@ Further remarks:
 %----------------------------------------------------------------------
 \item
 
-@DataCons@ @TupleCons@, @Importeds@, @TopLevIds@, @SuperDictSelIds@,
+@DataCons@ @TupleCons@, @Importeds@, @SuperDictSelIds@,
 @MethodSelIds@, @DictFunIds@, and @DefaultMethodIds@ have the following
 properties:
 \begin{itemize}
@@ -492,22 +477,14 @@ properties, but they may not.
 %************************************************************************
 
 \begin{code}
-unsafeGenId2Id :: GenId ty -> Id
-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 other					   = False
+isDataCon (Id _ _ _ (DataConId _ _ _ _ _ _ _) _ _) = True
+isDataCon (Id _ _ _ (TupleConId _) _ _)		   = True
+isDataCon (Id _ _ _ (SpecId unspec _ _) _ _)	   = isDataCon unspec
+isDataCon other					   = False
 
-
-isTupleCon id = is_tuple (unsafeGenId2Id id)
- where
-  is_tuple (Id _ _ _ (TupleConId _) _ _)	 = True
-  is_tuple (Id _ _ _ (SpecId unspec _ _) _ _)	 = is_tuple unspec
-  is_tuple other				 = False
+isTupleCon (Id _ _ _ (TupleConId _) _ _)	 = True
+isTupleCon (Id _ _ _ (SpecId unspec _ _) _ _)	 = isTupleCon unspec
+isTupleCon other				 = False
 
 {-LATER:
 isSpecId_maybe (Id _ _ _ (SpecId unspec ty_maybes _) _ _)
@@ -540,11 +517,10 @@ toplevelishId (Id _ _ _ details _ _)
     chk (TupleConId _)    	    = True
     chk (RecordSelId _)   	    = True
     chk ImportedId	    	    = True
-    chk TopLevId	    	    = True	-- NB: see notes
     chk (SuperDictSelId _ _)	    = True
     chk (MethodSelId _ _)	    = True
     chk (DefaultMethodId _ _ _)     = True
-    chk (DictFunId     _ _ _)	    = True
+    chk (DictFunId     _ _)	    = True
     chk (ConstMethodId _ _ _ _)     = True
     chk (SpecId unspec _ _)	    = toplevelishId unspec
 				    -- depends what the unspecialised thing is
@@ -553,6 +529,7 @@ toplevelishId (Id _ _ _ details _ _)
     chk (LocalId      _)	    = False
     chk (SysLocalId   _)	    = False
     chk (SpecPragmaId _ _)	    = False
+    chk (PrimitiveId _)		    = True
 
 idHasNoFreeTyVars (Id _ _ _ details _ info)
   = chk details
@@ -561,11 +538,10 @@ idHasNoFreeTyVars (Id _ _ _ details _ info)
     chk (TupleConId _)    	  = True
     chk (RecordSelId _)   	  = True
     chk ImportedId	    	  = True
-    chk TopLevId	    	  = True
     chk (SuperDictSelId _ _)	  = True
     chk (MethodSelId _ _)	  = True
     chk (DefaultMethodId _ _ _)   = True
-    chk (DictFunId     _ _ _)	  = True
+    chk (DictFunId     _ _)	  = True
     chk (ConstMethodId _ _ _ _)   = True
     chk (WorkerId unwrkr)	  = idHasNoFreeTyVars unwrkr
     chk (SpecId _     _   no_free_tvs) = no_free_tvs
@@ -573,16 +549,53 @@ idHasNoFreeTyVars (Id _ _ _ details _ info)
     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 (PrimitiveId _)		    = True
+
+-- wantIdSigInIface decides whether to put an Id's type signature and
+-- IdInfo in an interface file
+wantIdSigInIface
+	:: Bool		-- True <=> the thing is mentioned somewhere else in the 
+			-- 	    interface file
+	-> Bool		-- True <=> omit anything that doesn't *have* to go
+	-> Id
+	-> Bool
+
+wantIdSigInIface mentioned_already omit_iface_prags (Id _ name _ details _ _)
+  = chk details
+  where
+    chk (LocalId _)	  = isExported name && 
+			    not (isWiredInName name)	-- User-declared thing!
+    chk ImportedId	  = False		-- Never put imports in interface file
+    chk (PrimitiveId _)	  = False		-- Ditto, for primitives
+
+	-- This group is Ids that are implied by their type or class decl;
+	-- remember that all type and class decls appear in the interface file
+    chk (DataConId _ _ _ _ _ _ _) = False
+    chk (TupleConId _)    	  = False	-- Ditto
+    chk (RecordSelId _)   	  = False	-- Ditto
+    chk (SuperDictSelId _ _)	  = False	-- Ditto
+    chk (MethodSelId _ _)	  = False	-- Ditto
+    chk (ConstMethodId _ _ _ _)   = False	-- Scheduled for nuking
+    chk (DefaultMethodId _ _ _)   = False			-- Hmm.  No, for now
+
+	-- DictFunIds are more interesting, they may have IdInfo we can't
+	-- get from the instance declaration.  We emit them if we're gung ho.
+	-- No need to check the export flag; instance decls are always exposed
+    chk (DictFunId     _ _)	  = not omit_iface_prags
+
+	-- This group are only called out by being mentioned somewhere else
+    chk (WorkerId unwrkr)	  = mentioned_already
+    chk (SpecId _ _ _)		  = mentioned_already
+    chk (InstId _)		  = mentioned_already
+    chk (SysLocalId _)		  = mentioned_already
+    chk (SpecPragmaId _ _)	  = mentioned_already
 \end{code}
 
 \begin{code}
-isTopLevId (Id _ _ _ TopLevId _ _) = True
-isTopLevId other		   = False
-
 isImportedId (Id _ _ _ ImportedId _ _) = True
 isImportedId other		       = False
 
-isBottomingId (Id _ _ _ _ _ info) = bottomIsGuaranteed (getInfo info)
+isBottomingId (Id _ _ _ _ _ info) = bottomIsGuaranteed (strictnessInfo info)
 
 isSysLocalId (Id _ _ _ (SysLocalId _) _ _) = True
 isSysLocalId other			   = False
@@ -590,8 +603,8 @@ isSysLocalId other			   = False
 isSpecPragmaId (Id _ _ _ (SpecPragmaId _ _) _ _) = True
 isSpecPragmaId other			         = False
 
-isMethodSelId (Id _ _ _ (MethodSelId _ _) _ _) = True
-isMethodSelId _				       = False
+isMethodSelId_maybe (Id _ _ _ (MethodSelId cls op) _ _) = Just (cls,op)
+isMethodSelId_maybe _				        = Nothing
 
 isDefaultMethodId (Id _ _ _ (DefaultMethodId _ _ _) _ _) = True
 isDefaultMethodId other				         = False
@@ -600,8 +613,8 @@ isDefaultMethodId_maybe (Id _ _ _ (DefaultMethodId cls clsop err) _ _)
   = Just (cls, clsop, err)
 isDefaultMethodId_maybe other = Nothing
 
-isDictFunId (Id _ _ _ (DictFunId _ _ _) _ _) = True
-isDictFunId other		    	     = False
+isDictFunId (Id _ _ _ (DictFunId _ _) _ _) = True
+isDictFunId other		    	   = False
 
 isConstMethodId (Id _ _ _ (ConstMethodId _ _ _ _) _ _) = True
 isConstMethodId other		    		       = False
@@ -617,157 +630,9 @@ isWorkerId (Id _ _ _ (WorkerId _) _ _) = True
 isWorkerId other		     = False
 
 isWrapperId id = workerExists (getIdStrictness id)
-\end{code}
-
-\begin{code}
-{-LATER:
-pprIdInUnfolding :: IdSet -> Id -> Pretty
-
-pprIdInUnfolding in_scopes v
-  = let
-	v_ty = idType v
-    in
-    -- local vars first:
-    if v `elementOfUniqSet` in_scopes then
-	pprUnique (idUnique v)
-
-    -- ubiquitous Ids with special syntax:
-    else if v == nilDataCon then
-	ppPStr SLIT("_NIL_")
-    else if isTupleCon v then
-	ppBeside (ppPStr SLIT("_TUP_")) (ppInt (dataConArity v))
-
-    -- ones to think about:
-    else
-	let
-	    (Id _ _ _ v_details _ _) = v
-	in
-    	case v_details of
-	    -- these ones must have been exported by their original module
-	  ImportedId   -> pp_full_name
-
-	    -- these ones' exportedness checked later...
-	  TopLevId  -> pp_full_name
-	  DataConId _ _ _ _ _ _ _ -> pp_full_name
-
-	  RecordSelId lbl -> ppr sty lbl
-
-	    -- class-ish things: class already recorded as "mentioned"
-	  SuperDictSelId c sc
-	    -> ppCat [ppPStr SLIT("_SDSEL_"), pp_class c, pp_class sc]
-	  MethodSelId c o
-	    -> ppCat [ppPStr SLIT("_METH_"), pp_class c, pp_class_op o]
-	  DefaultMethodId c o _
-	    -> ppCat [ppPStr SLIT("_DEFM_"), pp_class c, pp_class_op o]
-
-	    -- instance-ish things: should we try to figure out
-	    -- *exactly* which extra instances have to be exported? (ToDo)
-	  DictFunId  c t _
-	    -> ppCat [ppPStr SLIT("_DFUN_"), pp_class c, pp_type t]
-	  ConstMethodId c t o _
-	    -> ppCat [ppPStr SLIT("_CONSTM_"), pp_class c, pp_class_op o, pp_type t]
-
-	  -- specialisations and workers
-	  SpecId unspec ty_maybes _
-	    -> let
-		  pp = pprIdInUnfolding in_scopes unspec
-	       in
-	       ppCat [ppPStr SLIT("_SPEC_"), pp, ppLbrack,
-			ppIntersperse pp'SP{-'-} (map pp_ty_maybe ty_maybes),
-			ppRbrack]
-
-	  WorkerId unwrkr
-	    -> let
-		  pp = pprIdInUnfolding in_scopes unwrkr
-	       in
-	       ppBeside (ppPStr SLIT("_WRKR_ ")) pp
-
-	  -- anything else? we're nae interested
-	  other_id -> panic "pprIdInUnfolding:mystery Id"
-  where
-    ppr_Unfolding = PprUnfolding (panic "Id:ppr_Unfolding")
-
-    pp_full_name
-      = let
-	    (OrigName m_str n_str) = origName "Id:ppr_Unfolding" v
-
-	    pp_n =
-	      if isLexSym n_str && not (isLexSpecialSym n_str) then
-		  ppBesides [ppLparen, ppPStr n_str, ppRparen]
-	      else
-		  ppPStr n_str
-	in
-	if isPreludeDefined v then
-	    pp_n
-	else
-	    ppCat [ppPStr SLIT("_ORIG_"), ppPStr m_str, pp_n]
-
-    pp_class :: Class -> Pretty
-    pp_class_op :: ClassOp -> Pretty
-    pp_type :: Type -> Pretty
-    pp_ty_maybe :: Maybe Type -> Pretty
-
-    pp_class    clas = ppr ppr_Unfolding clas
-    pp_class_op op   = ppr ppr_Unfolding op
-
-    pp_type t = ppBesides [ppLparen, ppr ppr_Unfolding t, ppRparen]
 
-    pp_ty_maybe Nothing  = ppPStr SLIT("_N_")
-    pp_ty_maybe (Just t) = pp_type t
--}
-\end{code}
-
-@whatsMentionedInId@ ferrets out the types/classes/instances on which
-this @Id@ depends.  If this Id is to appear in an interface, then
-those entities had Jolly Well be in scope.  Someone else up the
-call-tree decides that.
-
-\begin{code}
-{-LATER:
-whatsMentionedInId
-	:: IdSet			    -- Ids known to be in scope
-	-> Id				    -- Id being processed
-	-> (Bag Id, Bag TyCon, Bag Class)   -- mentioned Ids/TyCons/etc.
-
-whatsMentionedInId in_scopes v
-  = let
-	v_ty = idType v
-
-    	(tycons, clss)
-	  = getMentionedTyConsAndClassesFromType v_ty
-
-	result0 id_bag = (id_bag, tycons, clss)
-
-	result1 ids tcs cs
-	  = (ids `unionBags` unitBag v,	-- we add v to "mentioned"...
-	     tcs `unionBags` tycons,
-	     cs  `unionBags` clss)
-    in
-    -- local vars first:
-    if v `elementOfUniqSet` in_scopes then
-	result0 emptyBag    -- v not added to "mentioned"
-
-    -- ones to think about:
-    else
-	let
-	    (Id _ _ _ v_details _ _) = v
-	in
-    	case v_details of
-	  -- specialisations and workers
-	  SpecId unspec ty_maybes _
-	    -> let
-		  (ids2, tcs2, cs2) = whatsMentionedInId in_scopes unspec
-	       in
-	       result1 ids2 tcs2 cs2
-
-	  WorkerId unwrkr
-	    -> let
-		  (ids2, tcs2, cs2) = whatsMentionedInId in_scopes unwrkr
-	       in
-	       result1 ids2 tcs2 cs2
-
-	  anything_else -> result0 (unitBag v) -- v is  added to "mentioned"
--}
+isPrimitiveId_maybe (Id _ _ _ (PrimitiveId primop) _ _) = Just primop
+isPrimitiveId_maybe other				= Nothing
 \end{code}
 
 Tell them who my wrapper function is.
@@ -790,105 +655,16 @@ unfoldingUnfriendlyId id = not (externallyVisibleId id)
 \end{code}
 
 @externallyVisibleId@: is it true that another module might be
-able to ``see'' this Id?
+able to ``see'' this Id in a code generation sense. That
+is, another .o file might refer to this Id.
 
-We need the @toplevelishId@ check as well as @isExported@ for when we
-compile instance declarations in the prelude.  @DictFunIds@ are
-``exported'' if either their class or tycon is exported, but, in
-compiling the prelude, the compiler may not recognise that as true.
+In tidyCorePgm (SimplCore.lhs) we carefully set each top level thing's
+local-ness precisely so that the test here would be easy
 
 \begin{code}
 externallyVisibleId :: Id -> Bool
-
-externallyVisibleId id@(Id _ _ _ details _ _)
-  = if isLocallyDefined id then
-	toplevelishId id && (isExported id || isDataCon id)
-	-- NB: the use of "isExported" is most dodgy;
-	-- We may eventually move to a situation where
-	-- every Id is "externallyVisible", even if the
-	-- module system's namespace control renders it
-	-- "not exported".
-    else
-	True
-	-- if visible here, it must be visible elsewhere, too.
-\end{code}
-
-\begin{code}
-idWantsToBeINLINEd :: Id -> Bool
-
-idWantsToBeINLINEd (Id _ _ _ _ IWantToBeINLINEd _) = True
-idWantsToBeINLINEd _				   = False
-
-addInlinePragma :: Id -> Id
-addInlinePragma (Id u sn ty details _ info)
-  = Id u sn ty details IWantToBeINLINEd info
-\end{code}
-
-For @unlocaliseId@: See the brief commentary in
-\tr{simplStg/SimplStg.lhs}.
-
-\begin{code}
-{-LATER:
-unlocaliseId :: FAST_STRING{-modulename-} -> Id -> Maybe Id
-
-unlocaliseId mod (Id u fn ty info TopLevId)
-  = Just (Id u (unlocaliseFullName fn) ty info TopLevId)
-
-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 full_name ty info TopLevId)
-
-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 full_name ty info TopLevId)
-
-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 n ty info (SpecId xx ty_maybes no_ftvs))
-
-unlocaliseId mod (Id u n ty info (WorkerId unwrkr))
-  = case unlocalise_parent mod u unwrkr of
-      Nothing -> Nothing
-      Just xx -> Just (Id u n ty info (WorkerId xx))
-
-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
-    name = nameOf (origName "Id.unlocaliseId" name)
-    full_name = mkFullName mod name InventedInThisModule ExportAll mkGeneratedSrcLoc
-
-unlocaliseId mod other_id = Nothing
-
---------------------
--- we have to be Very Careful for workers/specs of
--- local functions!
-
-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 full_name ty info TopLevId)
-
-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 full_name ty info TopLevId)
-
-unlocalise_parent mod uniq other_id = unlocaliseId mod other_id
-  -- we're OK otherwise
--}
+externallyVisibleId id@(Id _ name _ _ _ _) = not (isLocalName name)
+		     -- not local => global => externally visible
 \end{code}
 
 CLAIM (not ASSERTed) for @applyTypeEnvToId@ and @applySubstToId@:
@@ -1008,14 +784,6 @@ getMentionedTyConsAndClassesFromId id
 idPrimRep i = typePrimRep (idType i)
 \end{code}
 
-\begin{code}
-{-LATER:
-getInstIdModule (Id _ _ _ (DictFunId _ _ mod)) = mod
-getInstIdModule (Id _ _ _ (ConstMethodId _ _ _ mod)) = mod
-getInstIdModule other = panic "Id:getInstIdModule"
--}
-\end{code}
-
 %************************************************************************
 %*									*
 \subsection[Id-overloading]{Functions related to overloading}
@@ -1023,51 +791,50 @@ getInstIdModule other = panic "Id:getInstIdModule"
 %************************************************************************
 
 \begin{code}
-mkSuperDictSelId u c sc ty info
-  = mk_classy_id (SuperDictSelId c sc) SLIT("sdsel") (Left (origName "mkSuperDictSelId" sc)) u c ty info
-
-mkMethodSelId u rec_c op ty info
-  = mk_classy_id (MethodSelId rec_c op) SLIT("meth") (Right (classOpString op)) u rec_c ty info
-
-mkDefaultMethodId u rec_c op gen ty info
-  = mk_classy_id (DefaultMethodId rec_c op gen) SLIT("defm") (Right (classOpString op)) u rec_c ty info
-
-mk_classy_id details str op_str u rec_c ty info
-  = Id u n ty details NoPragmaInfo info
+mkSuperDictSelId u clas sc ty
+  = addStandardIdInfo $
+    Id u name ty details NoPragmaInfo noIdInfo
   where
-    cname = getName rec_c -- we get other info out of here
-    cname_orig = origName "mk_classy_id" cname
-    cmod = moduleOf cname_orig
-
-    n = mkCompoundName u cmod str [Left cname_orig, op_str] cname
-
-mkDictFunId u c ity full_ty from_here locn mod info
-  = Id u n full_ty (DictFunId c ity mod) NoPragmaInfo info
+    name    = mkCompoundName name_fn u (getName clas)
+    details = SuperDictSelId clas sc
+    name_fn clas_str = SLIT("scsel_") _APPEND_ clas_str _APPEND_ mod _APPEND_ occNameString occ
+    (mod,occ) = modAndOcc sc
+
+	-- For method selectors the clean thing to do is
+	-- to give the method selector the same name as the class op itself.
+mkMethodSelId op_name rec_c op ty
+  = addStandardIdInfo $
+    Id (uniqueOf op_name) op_name ty (MethodSelId rec_c op) NoPragmaInfo noIdInfo
+
+mkDefaultMethodId op_name uniq rec_c op gen ty
+  = Id uniq dm_name ty details NoPragmaInfo noIdInfo
   where
-    n = mkCompoundName2 u mod SLIT("dfun") (Left (origName "mkDictFunId" c) : renum_type_string full_ty ity) from_here locn
+    dm_name        = mkCompoundName name_fn uniq op_name
+    details        = DefaultMethodId rec_c op gen
+    name_fn op_str = SLIT("dm_") _APPEND_ op_str
 
-mkConstMethodId	u c op ity full_ty from_here locn mod info
-  = Id u n full_ty (ConstMethodId c ity op mod) NoPragmaInfo info
+mkDictFunId dfun_name full_ty clas ity
+  = Id (nameUnique dfun_name) dfun_name full_ty details NoPragmaInfo noIdInfo
   where
-    n = mkCompoundName2 u mod SLIT("const") (Left (origName "mkConstMethodId" c) : Right (classOpString op) : renum_type_string full_ty ity) from_here locn
+    details  = DictFunId clas ity
 
-renum_type_string full_ty ity
-  = initNmbr (
-	nmbrType full_ty    `thenNmbr` \ _ -> -- so all the tyvars get added to renumbering...
-	nmbrType ity	    `thenNmbr` \ rn_ity ->
-	returnNmbr (getTypeString rn_ity)
-    )
+mkConstMethodId	uniq clas op ity full_ty from_here locn mod info
+  = Id uniq name full_ty details NoPragmaInfo info
+  where
+    name     = mkInstDeclName uniq mod (VarOcc occ_name) locn from_here
+    details  = ConstMethodId clas ity op mod
+    occ_name = classOpString op _APPEND_ 
+	       SLIT("_cm_") _APPEND_ renum_type_string full_ty ity
 
 mkWorkerId u unwrkr ty info
-  = Id u n ty (WorkerId unwrkr) NoPragmaInfo info
+  = Id u name ty details NoPragmaInfo info
   where
-    unwrkr_name = getName unwrkr
-    unwrkr_orig = origName "mkWorkerId" unwrkr_name
-    umod = moduleOf unwrkr_orig
-
-    n = mkCompoundName u umod SLIT("wrk") [Left unwrkr_orig] unwrkr_name
+    name    = mkCompoundName name_fn u (getName unwrkr)
+    details = WorkerId unwrkr
+    name_fn wkr_str = wkr_str _APPEND_ SLIT("_wrk")
 
-mkInstId u ty name = Id u (changeUnique name u) ty (InstId (no_free_tvs ty)) NoPragmaInfo noIdInfo
+mkInstId u ty name 
+  = Id u (changeUnique name u) ty (InstId (no_free_tvs ty)) NoPragmaInfo noIdInfo
 
 {-LATER:
 getConstMethodId clas op ty
@@ -1086,6 +853,14 @@ getConstMethodId clas op ty
 	ppStr "The info above, however ugly, should indicate what else you need to import."
 	])
 -}
+
+
+renum_type_string full_ty ity
+  = initNmbr (
+	nmbrType full_ty    `thenNmbr` \ _ -> -- so all the tyvars get added to renumbering...
+	nmbrType ity	    `thenNmbr` \ rn_ity ->
+	returnNmbr (getTypeString rn_ity)
+    )
 \end{code}
 
 %************************************************************************
@@ -1097,10 +872,9 @@ getConstMethodId clas op ty
 \begin{code}
 mkImported  n ty info = Id (nameUnique n) n ty ImportedId NoPragmaInfo info
 
-{-LATER:
-updateIdType :: Id -> Type -> Id
-updateIdType (Id u n _ info details) ty = Id u n ty info details
--}
+mkPrimitiveId n ty primop 
+  = addStandardIdInfo $
+    Id (nameUnique n) n ty (PrimitiveId primop) NoPragmaInfo noIdInfo
 \end{code}
 
 \begin{code}
@@ -1111,23 +885,18 @@ no_free_tvs ty = isEmptyTyVarSet (tyVarsOfType ty)
 
 -- SysLocal: for an Id being created by the compiler out of thin air...
 -- UserLocal: an Id with a name the user might recognize...
-mkSysLocal, mkUserLocal :: FAST_STRING -> Unique -> MyTy a b -> SrcLoc -> MyId a b
+mkSysLocal  :: FAST_STRING -> Unique -> MyTy a b -> SrcLoc -> MyId a b
+mkUserLocal :: OccName     -> Unique -> MyTy a b -> SrcLoc -> MyId a b
 
 mkSysLocal str uniq ty loc
-  = Id uniq (mkLocalName uniq str True{-emph uniq-} loc) ty (SysLocalId (no_free_tvs ty)) NoPragmaInfo noIdInfo
+  = Id uniq (mkSysLocalName uniq str loc) ty (SysLocalId (no_free_tvs ty)) NoPragmaInfo noIdInfo
 
-mkUserLocal str uniq ty loc
-  = Id uniq (mkLocalName uniq str False{-emph name-} loc) ty (LocalId (no_free_tvs ty)) NoPragmaInfo noIdInfo
+mkUserLocal occ uniq ty loc
+  = Id uniq (mkLocalName uniq occ 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) name ty (LocalId (no_free_tvs ty)) pragma_info noIdInfo
-  | otherwise
-  = Id (nameUnique name) name ty 
-	(if isLocallyDefinedName name then TopLevId else ImportedId)
-	pragma_info noIdInfo
 \end{code}
 
 
@@ -1135,7 +904,7 @@ mkUserId name ty pragma_info
 {-LATER:
 
 -- for a SpecPragmaId being created by the compiler out of thin air...
-mkSpecPragmaId :: FAST_STRING -> Unique -> Type -> Maybe Id -> SrcLoc -> Id
+mkSpecPragmaId :: OccName -> Unique -> Type -> Maybe Id -> SrcLoc -> Id
 mkSpecPragmaId str uniq ty specid loc
   = Id uniq (mkShortName str loc) ty noIdInfo (SpecPragmaId specid (no_free_tvs ty))
 
@@ -1162,8 +931,12 @@ localiseId id@(Id u n ty info details)
     loc  = getSrcLoc id
 -}
 
-mkIdWithNewUniq :: Id -> Unique -> Id
+-- See notes with setNameVisibility (Name.lhs)
+setIdVisibility :: Module -> Id -> Id
+setIdVisibility mod (Id uniq name ty details prag info)
+  = Id uniq (setNameVisibility mod name) ty details prag info
 
+mkIdWithNewUniq :: Id -> Unique -> Id
 mkIdWithNewUniq (Id _ n ty details prag info) u
   = Id u (changeUnique n u) ty details prag info
 \end{code}
@@ -1194,7 +967,7 @@ replaceIdInfo (Id u n ty details pinfo _) info = Id u n ty details pinfo info
 selectIdInfoForSpecId :: Id -> IdInfo
 selectIdInfoForSpecId unspec
   = ASSERT(not (maybeToBool (isSpecId_maybe unspec)))
-    noIdInfo `addInfo_UF` getIdUnfolding unspec
+    noIdInfo `addUnfoldInfo` getIdUnfolding unspec
 -}
 \end{code}
 
@@ -1212,15 +985,15 @@ besides the code-generator need arity info!)
 getIdArity :: Id -> ArityInfo
 getIdArity id@(Id _ _ _ _ _ id_info)
   = --ASSERT( not (isDataCon id))
-    getInfo id_info
+    arityInfo id_info
 
 dataConArity, dataConNumFields :: DataCon -> Int
 
 dataConArity id@(Id _ _ _ _ _ id_info)
   = ASSERT(isDataCon id)
-    case (arityMaybe (getInfo id_info)) of
-      Just  i -> i
-      Nothing -> pprPanic "dataConArity:Nothing:" (pprId PprDebug id)
+    case arityInfo id_info of
+      ArityExactly a -> a
+      other	     -> pprPanic "dataConArity:Nothing:" (pprId PprDebug id)
 
 dataConNumFields id
   = ASSERT(isDataCon id)
@@ -1229,9 +1002,9 @@ dataConNumFields id
 
 isNullaryDataCon con = dataConNumFields con == 0 -- function of convenience
 
-addIdArity :: Id -> Int -> Id
+addIdArity :: Id -> ArityInfo -> Id
 addIdArity (Id u n ty details pinfo info) arity
-  = Id u n ty details pinfo (info `addInfo` (mkArityInfo arity))
+  = Id u n ty details pinfo (info `addArityInfo` arity)
 \end{code}
 
 %************************************************************************
@@ -1244,133 +1017,39 @@ addIdArity (Id u n ty details pinfo info) arity
 mkDataCon :: Name
 	  -> [StrictnessMark] -> [FieldLabel]
 	  -> [TyVar] -> ThetaType -> [TauType] -> TyCon
---ToDo:   -> SpecEnv
 	  -> Id
   -- can get the tag and all the pieces of the type from the Type
 
 mkDataCon n stricts fields tvs ctxt args_tys tycon
   = ASSERT(length stricts == length args_tys)
-    data_con
+    addStandardIdInfo data_con
   where
     -- NB: data_con self-recursion; should be OK as tags are not
     -- looked at until late in the game.
     data_con
       = Id (nameUnique n)
 	   n
-	   type_of_constructor
+	   data_con_ty
 	   (DataConId data_con_tag stricts fields tvs ctxt args_tys tycon)
 	   IWantToBeINLINEd	-- Always inline constructors if possible
-	   datacon_info
-
-    data_con_tag    = position_within fIRST_TAG data_con_family
+	   noIdInfo
 
+    data_con_tag    = assoc "mkDataCon" (data_con_family `zip` [fIRST_TAG..]) data_con
     data_con_family = tyConDataCons tycon
 
-    position_within :: Int -> [Id] -> Int
-
-    position_within acc (c:cs)
-      = if c == data_con then acc else position_within (acc+1) cs
-#ifdef DEBUG
-    position_within acc []
-      = panic "mkDataCon: con not found in family"
-#endif
-
-    type_of_constructor
+    data_con_ty
       = mkSigmaTy tvs ctxt
 	(mkFunTys args_tys (applyTyCon tycon (mkTyVarTys tvs)))
 
-    datacon_info = noIdInfo `addInfo_UF` unfolding
-			    `addInfo` mkArityInfo arity
---ToDo: 		    `addInfo` specenv
-
-    arity = length ctxt + length args_tys
-
-    unfolding
-      = noInfo_UF
-{- LATER:
-      = -- if arity == 0
-    	-- then noIdInfo
-	-- else -- do some business...
-	let
-	    (tyvars, dict_vars, vars) = mk_uf_bits tvs ctxt args_tys tycon
-	    tyvar_tys = mkTyVarTys tyvars
-	in
-	case (Con data_con tyvar_tys [VarArg v | v <- vars]) of { plain_Con ->
-
-	mkUnfolding EssentialUnfolding -- for data constructors
-		    (mkLam tyvars (dict_vars ++ vars) plain_Con)
-	}
 
-    mk_uf_bits tvs ctxt arg_tys tycon
-      = let
-	    (inst_env, tyvars, tyvar_tys)
-	      = instantiateTyVarTemplates tvs
-					  (map uniqueOf tvs)
-	in
-	    -- the "context" and "arg_tys" have TyVarTemplates in them, so
-	    -- we instantiate those types to have the right TyVars in them
-	    -- instead.
-	case (map (instantiateTauTy inst_env) (map ctxt_ty ctxt))
-						       	of { inst_dict_tys ->
-	case (map (instantiateTauTy inst_env) arg_tys) 	of { inst_arg_tys ->
-
-	    -- We can only have **ONE** call to mkTemplateLocals here;
-	    -- otherwise, we get two blobs of locals w/ mixed-up Uniques
-	    -- (Mega-Sigh) [ToDo]
-	case (mkTemplateLocals (inst_dict_tys ++ inst_arg_tys)) of { all_vars ->
-
-	case (splitAt (length ctxt) all_vars)	of { (dict_vars, vars) ->
-
-	(tyvars, dict_vars, vars)
-	}}}}
-      where
-	-- these are really dubious Types, but they are only to make the
-	-- binders for the lambdas for tossed-away dicts.
-	ctxt_ty (clas, ty) = mkDictTy clas ty
--}
-\end{code}
-
-\begin{code}
-mkTupleCon :: Arity -> Id
-
-mkTupleCon arity
-  = Id unique n ty (TupleConId arity) NoPragmaInfo tuplecon_info 
+mkTupleCon :: Arity -> Name -> Type -> Id
+mkTupleCon arity name ty 
+  = addStandardIdInfo tuple_id
   where
-    n		= mkTupleDataConName arity
-    unique      = uniqueOf n
-    ty 		= mkSigmaTy tyvars []
-		   (mkFunTys tyvar_tys (applyTyCon tycon tyvar_tys))
-    tycon	= mkTupleTyCon arity
-    tyvars	= take arity alphaTyVars
-    tyvar_tys	= mkTyVarTys tyvars
-
-    tuplecon_info
-      = noIdInfo `addInfo_UF` unfolding
-		 `addInfo` mkArityInfo arity
---LATER:?	 `addInfo` panic "Id:mkTupleCon:pcGenerateTupleSpecs arity ty"
-
-    unfolding
-      = noInfo_UF
-{- LATER:
-      = -- if arity == 0
-    	-- then noIdInfo
-	-- else -- do some business...
-	let
-	    (tyvars, dict_vars, vars) = mk_uf_bits arity
-	    tyvar_tys = mkTyVarTys tyvars
-	in
-	case (Con data_con tyvar_tys [VarArg v | v <- vars]) of { plain_Con ->
-	mkUnfolding
-	    EssentialUnfolding    -- data constructors
-	    (mkLam tyvars (dict_vars ++ vars) plain_Con) }
-
-    mk_uf_bits arity
-      = case (mkTemplateLocals tyvar_tys) of { vars ->
-	(tyvars, [], vars) }
-      where
-	tyvar_tmpls	= take arity alphaTyVars
-	(_, tyvars, tyvar_tys) = instantiateTyVarTemplates tyvar_tmpls (map uniqueOf tyvar_tmpls)
--}
+    tuple_id = Id (nameUnique name) name ty 
+	  	  (TupleConId arity) 
+		  IWantToBeINLINEd		-- Always inline constructors if possible
+	  	  noIdInfo
 
 fIRST_TAG :: ConTag
 fIRST_TAG =  1	-- Tags allocated from here for real constructors
@@ -1384,7 +1063,7 @@ 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 _ _ _ (TupleConId a) _ _)	          = tupleTyCon a
 
 dataConSig :: DataCon -> ([TyVar], ThetaType, [TauType], TyCon)
 					-- will panic if not a DataCon
@@ -1393,7 +1072,7 @@ dataConSig (Id _ _ _ (DataConId _ _ _ tyvars theta_ty arg_tys tycon) _ _)
   = (tyvars, theta_ty, arg_tys, tycon)
 
 dataConSig (Id _ _ _ (TupleConId arity) _ _)
-  = (tyvars, [], tyvar_tys, mkTupleTyCon arity)
+  = (tyvars, [], tyvar_tys, tupleTyCon arity)
   where
     tyvars	= take arity alphaTyVars
     tyvar_tys	= mkTyVarTys tyvars
@@ -1441,7 +1120,8 @@ dataConArgTys con_id inst_tys
 
 \begin{code}
 mkRecordSelId field_label selector_ty
-  = Id (nameUnique name)
+  = addStandardIdInfo $		-- Record selectors have a standard unfolding
+    Id (nameUnique name)
        name
        selector_ty
        (RecordSelId field_label)
@@ -1452,6 +1132,9 @@ mkRecordSelId field_label selector_ty
 
 recordSelectorFieldLabel :: Id -> FieldLabel
 recordSelectorFieldLabel (Id _ _ _ (RecordSelId lbl) _ _) = lbl
+
+isRecordSelector (Id _ _ _ (RecordSelId lbl) _ _) = True
+isRecordSelector other				  = False
 \end{code}
 
 
@@ -1473,50 +1156,39 @@ Notice the ``big lambdas'' and type arguments to @Con@---we are producing
 %*									*
 %************************************************************************
 
-@getIdUnfolding@ takes a @Id@ (we are discussing the @DataCon@ case)
-and generates an @Unfolding@.  The @Ids@ and @TyVars@ don't really
-have to be new, because we are only producing a template.
+\begin{code}
+getIdUnfolding :: Id -> Unfolding
 
-ToDo: what if @DataConId@'s type has a context (haven't thought about it
---WDP)?
+getIdUnfolding (Id _ _ _ _ _ info) = unfoldInfo info
 
-Note: @getDataConUnfolding@ is a ``poor man's'' version---it is NOT
-EXPORTED.  It just returns the binders (@TyVars@ and @Ids@) [in the
-example above: a, b, and x, y, z], which is enough (in the important
-\tr{DsExpr} case).  (The middle set of @Ids@ is binders for any
-dictionaries, in the even of an overloaded data-constructor---none at
-present.)
+addIdUnfolding :: Id -> Unfolding -> Id
+addIdUnfolding id@(Id u n ty details prag info) unfolding
+  = Id u n ty details prag (info `addUnfoldInfo` unfolding)
+\end{code}
+
+The inline pragma tells us to be very keen to inline this Id, but it's still
+OK not to if optimisation is switched off.
 
 \begin{code}
-getIdUnfolding :: Id -> Unfolding
+idWantsToBeINLINEd :: Id -> Bool
 
-getIdUnfolding (Id _ _ _ _ _ info) = getInfo_UF info
+idWantsToBeINLINEd (Id _ _ _ _ IWantToBeINLINEd _) = True
+idWantsToBeINLINEd _				   = False
 
-{-LATER:
-addIdUnfolding :: Id -> Unfolding -> Id
-addIdUnfolding id@(Id u n ty info details) unfold_details
-  = ASSERT(
-    	case (isLocallyDefined id, unfold_details) of
-	(_,     NoUnfolding) -> True
-	(True,  IWantToBeINLINEd _) -> True
-	(False, IWantToBeINLINEd _) -> False -- v bad
-	(False, _)  	    	    -> True
-	_   	    	    	    -> False -- v bad
-    )
-    Id u n ty (info `addInfo_UF` unfold_details) details
--}
+addInlinePragma :: Id -> Id
+addInlinePragma (Id u sn ty details _ info)
+  = Id u sn ty details IWantToBeINLINEd info
 \end{code}
 
-In generating selector functions (take a dictionary, give back one
-component...), we need to what out for the nothing-to-select cases (in
-which case the ``selector'' is just an identity function):
-\begin{verbatim}
-class Eq a => Foo a { }	    # the superdict selector for "Eq"
 
-class Foo a { op :: Complex b => c -> b -> a }
-			    # the method selector for "op";
-			    # note local polymorphism...
-\end{verbatim}
+The predicate @idMustBeINLINEd@ says that this Id absolutely must be inlined.
+It's only true for primitives, because we don't want to make a closure for each of them.
+
+\begin{code}
+idMustBeINLINEd (Id _ _ _ (PrimitiveId primop) _ _) = True
+idMustBeINLINEd other				    = False
+\end{code}
+
 
 %************************************************************************
 %*									*
@@ -1526,64 +1198,63 @@ class Foo a { op :: Complex b => c -> b -> a }
 
 \begin{code}
 getIdDemandInfo :: Id -> DemandInfo
-getIdDemandInfo (Id _ _ _ _ _ info) = getInfo info
+getIdDemandInfo (Id _ _ _ _ _ info) = demandInfo info
 
 addIdDemandInfo :: Id -> DemandInfo -> Id
 addIdDemandInfo (Id u n ty details prags info) demand_info
-  = Id u n ty details prags (info `addInfo` demand_info)
+  = Id u n ty details prags (info `addDemandInfo` demand_info)
 \end{code}
 
 \begin{code}
 getIdUpdateInfo :: Id -> UpdateInfo
-getIdUpdateInfo (Id _ _ _ _ _ info) = getInfo info
+getIdUpdateInfo (Id _ _ _ _ _ info) = updateInfo info
 
 addIdUpdateInfo :: Id -> UpdateInfo -> Id
 addIdUpdateInfo (Id u n ty details prags info) upd_info
-  = Id u n ty details prags (info `addInfo` upd_info)
+  = Id u n ty details prags (info `addUpdateInfo` upd_info)
 \end{code}
 
 \begin{code}
 {- LATER:
 getIdArgUsageInfo :: Id -> ArgUsageInfo
-getIdArgUsageInfo (Id u n ty info details) = getInfo info
+getIdArgUsageInfo (Id u n ty info details) = argUsageInfo info
 
 addIdArgUsageInfo :: Id -> ArgUsageInfo -> Id
 addIdArgUsageInfo (Id u n ty info details) au_info
-  = Id u n ty (info `addInfo` au_info) details
+  = Id u n ty (info `addArgusageInfo` au_info) details
 -}
 \end{code}
 
 \begin{code}
 {- LATER:
 getIdFBTypeInfo :: Id -> FBTypeInfo
-getIdFBTypeInfo (Id u n ty info details) = getInfo info
+getIdFBTypeInfo (Id u n ty info details) = fbTypeInfo info
 
 addIdFBTypeInfo :: Id -> FBTypeInfo -> Id
 addIdFBTypeInfo (Id u n ty info details) upd_info
-  = Id u n ty (info `addInfo` upd_info) details
+  = Id u n ty (info `addFBTypeInfo` upd_info) details
 -}
 \end{code}
 
 \begin{code}
 getIdSpecialisation :: Id -> SpecEnv
-getIdSpecialisation (Id _ _ _ _ _ info) = getInfo info
+getIdSpecialisation (Id _ _ _ _ _ info) = specInfo info
 
 addIdSpecialisation :: Id -> SpecEnv -> Id
 addIdSpecialisation (Id u n ty details prags info) spec_info
-  = Id u n ty details prags (info `addInfo` spec_info)
+  = Id u n ty details prags (info `addSpecInfo` spec_info)
 \end{code}
 
 Strictness: we snaffle the info out of the IdInfo.
 
 \begin{code}
-getIdStrictness :: Id -> StrictnessInfo
-
-getIdStrictness (Id _ _ _ _ _ info) = getInfo info
+getIdStrictness :: Id -> StrictnessInfo Id
 
-addIdStrictness :: Id -> StrictnessInfo -> Id
+getIdStrictness (Id _ _ _ _ _ info) = strictnessInfo info
 
+addIdStrictness :: Id -> StrictnessInfo Id -> Id
 addIdStrictness (Id u n ty details prags info) strict_info
-  = Id u n ty details prags (info `addInfo` strict_info)
+  = Id u n ty details prags (info `addStrictnessInfo` strict_info)
 \end{code}
 
 %************************************************************************
diff --git a/ghc/compiler/basicTypes/IdInfo.lhs b/ghc/compiler/basicTypes/IdInfo.lhs
index 4bfc2c864f..40b3c1ff7d 100644
--- a/ghc/compiler/basicTypes/IdInfo.lhs
+++ b/ghc/compiler/basicTypes/IdInfo.lhs
@@ -10,60 +10,43 @@ Haskell. [WDP 94/11])
 #include "HsVersions.h"
 
 module IdInfo (
-	IdInfo,		-- abstract
+	IdInfo,		-- Abstract
+
 	noIdInfo,
-	boringIdInfo,
 	ppIdInfo,
 	applySubstToIdInfo, apply_to_IdInfo,    -- not for general use, please
 
-	OptIdInfo(..),	-- class; for convenience only
-			-- all the *Infos herein are instances of it
-
-	-- component "id infos"; also abstract:
-	SrcLoc,
-	getSrcLocIdInfo,
-
-	ArityInfo,
-	mkArityInfo, unknownArity, arityMaybe,
+	ArityInfo(..),
+	exactArity, atLeastArity, unknownArity,
+	arityInfo, addArityInfo, ppArityInfo,
 
 	DemandInfo,
-	mkDemandInfo,
-	willBeDemanded,
-
-	StrictnessInfo(..), 	-- non-abstract
-	Demand(..),	    	-- non-abstract
+	noDemandInfo, mkDemandInfo, demandInfo, ppDemandInfo, addDemandInfo, willBeDemanded,
 
+	StrictnessInfo(..),				-- Non-abstract
+	Demand(..),	    				-- Non-abstract
 	wwLazy, wwStrict, wwUnpack, wwPrim, wwEnum,
-	indicatesWorker, nonAbsentArgs,
-	mkStrictnessInfo, mkBottomStrictnessInfo,
-	getWrapperArgTypeCategories,
-	getWorkerId,
+
+	getWorkerId_maybe,
 	workerExists,
-	bottomIsGuaranteed,
+	mkStrictnessInfo, mkBottomStrictnessInfo, noStrictnessInfo, bottomIsGuaranteed,
+	strictnessInfo, ppStrictnessInfo, addStrictnessInfo, 
 
-	mkUnfolding,
-	noInfo_UF, getInfo_UF, addInfo_UF, -- to avoid instance virus
+	unfoldInfo, addUnfoldInfo, 
 
-	UpdateInfo,
-	mkUpdateInfo,
-	SYN_IE(UpdateSpec),
-	updateInfoMaybe,
+	specInfo, addSpecInfo,
 
-	DeforestInfo(..),
+	UpdateInfo, SYN_IE(UpdateSpec),
+	mkUpdateInfo, updateInfo, updateInfoMaybe, ppUpdateInfo, addUpdateInfo,
 
-	ArgUsageInfo,
-	ArgUsage(..),
-	SYN_IE(ArgUsageType),
-	mkArgUsageInfo,
-	getArgUsage,
+	DeforestInfo(..),
+	deforestInfo, ppDeforestInfo, addDeforestInfo,
 
-	FBTypeInfo,
-	FBType(..),
-	FBConsum(..),
-	FBProd(..),
-	mkFBTypeInfo,
-	getFBType
+	ArgUsageInfo, ArgUsage(..), SYN_IE(ArgUsageType),
+	mkArgUsageInfo, argUsageInfo, addArgUsageInfo, getArgUsage,
 
+	FBTypeInfo, FBType(..), FBConsum(..), FBProd(..),
+	fbTypeInfo, ppFBTypeInfo, addFBTypeInfo, mkFBTypeInfo, getFBType
     ) where
 
 IMP_Ubiq()
@@ -74,13 +57,14 @@ IMPORT_DELOOPER(IdLoop)	-- IdInfo is a dependency-loop ranch, and
 			-- *not* importing much of anything else,
 			-- except from the very general "utils".
 
+import Type		( eqSimpleTy, splitFunTyExpandingDicts )
 import CmdLineOpts	( opt_OmitInterfacePragmas )
+
+import Demand
 import Maybes		( firstJust )
 import Outputable	( ifPprInterface, Outputable(..){-instances-} )
 import PprStyle		( PprStyle(..) )
 import Pretty
-import SrcLoc		( mkUnknownSrcLoc )
-import Type		( eqSimpleTy, splitFunTyExpandingDicts )
 import Unique		( pprUnique )
 import Util		( mapAccumL, panic, assertPanic, pprPanic )
 
@@ -90,9 +74,6 @@ ord = fromEnum :: Char -> Int
 
 applySubstToTy = panic "IdInfo.applySubstToTy"
 showTypeCategory = panic "IdInfo.showTypeCategory"
-mkFormSummary = panic "IdInfo.mkFormSummary"
-isWrapperFor = panic "IdInfo.isWrapperFor"
-pprCoreUnfolding = panic "IdInfo.pprCoreUnfolding"
 \end{code}
 
 An @IdInfo@ gives {\em optional} information about an @Id@.  If
@@ -115,12 +96,15 @@ data IdInfo
 	DemandInfo		-- Whether or not it is definitely
 				-- demanded
 
-	SpecEnv			-- Specialisations of this function which exist
+	SpecEnv
+				-- Specialisations of this function which exist
 
-	StrictnessInfo		-- Strictness properties, notably
+	(StrictnessInfo Id)
+				-- Strictness properties, notably
 				-- how to conjure up "worker" functions
 
-	Unfolding		-- Its unfolding; for locally-defined
+	Unfolding
+				-- Its unfolding; for locally-defined
 				-- things, this can *only* be NoUnfolding
 
 	UpdateInfo		-- Which args should be updated
@@ -131,47 +115,11 @@ data IdInfo
 	ArgUsageInfo		-- how this Id uses its arguments
 
 	FBTypeInfo		-- the Foldr/Build W/W property of this function.
-
-	SrcLoc			-- Source location of definition
-
-	-- ToDo: SrcLoc is in FullNames too (could rm?)  but it
-	-- is needed here too for things like ConstMethodIds and the
-	-- like, which don't have full-names of their own Mind you,
-	-- perhaps the Name for a constant method could give the
-	-- class/type involved?
 \end{code}
 
 \begin{code}
-noIdInfo = IdInfo noInfo noInfo noInfo noInfo noInfo_UF
-		  noInfo noInfo noInfo noInfo mkUnknownSrcLoc
-
--- "boring" means: nothing to put in interface
-boringIdInfo (IdInfo UnknownArity
-		     UnknownDemand
-		     specenv
-		     strictness
-		     unfolding
-		     NoUpdateInfo
-		     Don'tDeforest
-		     _ {- arg_usage: currently no interface effect -}
-		     _ {- no f/b w/w -}
-		     _ {- src_loc: no effect on interfaces-}
-	      )
-	      |  isNullSpecEnv specenv
-	      && boring_strictness strictness
-	      && boring_unfolding unfolding
-  = True
-  where
-    boring_strictness NoStrictnessInfo = True
-    boring_strictness BottomGuaranteed = False
-    boring_strictness (StrictnessInfo wrap_args _) = all_present_WwLazies wrap_args
-
-    boring_unfolding NoUnfolding = True
-    boring_unfolding _	    	 = False
-
-boringIdInfo _ = False
-
-pp_NONE = ppPStr SLIT("_N_")
+noIdInfo = IdInfo UnknownArity UnknownDemand nullSpecEnv NoStrictnessInfo noUnfolding
+		  NoUpdateInfo Don'tDeforest NoArgUsageInfo NoFBTypeInfo 
 \end{code}
 
 Simply turgid.  But BE CAREFUL: don't @apply_to_Id@ if that @Id@
@@ -179,7 +127,7 @@ will in turn @apply_to_IdInfo@ of the self-same @IdInfo@.  (A very
 nasty loop, friends...)
 \begin{code}
 apply_to_IdInfo ty_fn idinfo@(IdInfo arity demand spec strictness unfold
-			      update deforest arg_usage fb_ww srcloc)
+			      update deforest arg_usage fb_ww)
   | isNullSpecEnv spec
   = idinfo
   | otherwise
@@ -193,7 +141,7 @@ apply_to_IdInfo ty_fn idinfo@(IdInfo arity demand spec strictness unfold
 	--   apply_wrap wrap 		`thenLft` \ new_wrap ->
     in
     IdInfo arity demand new_spec strictness unfold
-	   update deforest arg_usage fb_ww srcloc
+	   update deforest arg_usage fb_ww
   where
     apply_spec (SpecEnv is)
       = SpecEnv (map do_one is)
@@ -222,11 +170,11 @@ apply_to_IdInfo ty_fn idinfo@(IdInfo arity demand spec strictness unfold
 Variant of the same thing for the typechecker.
 \begin{code}
 applySubstToIdInfo s0 (IdInfo arity demand spec strictness unfold
-			      update deforest arg_usage fb_ww srcloc)
+			      update deforest arg_usage fb_ww)
   = panic "IdInfo:applySubstToIdInfo"
 {- LATER:
     case (apply_spec s0 spec) of { (s1, new_spec) ->
-    (s1, IdInfo arity demand new_spec strictness unfold update deforest arg_usage fb_ww srcloc) }
+    (s1, IdInfo arity demand new_spec strictness unfold update deforest arg_usage fb_ww) }
   where
     apply_spec s0 (SpecEnv is)
       = case (mapAccumL do_one s0 is) of { (s1, new_is) ->
@@ -245,77 +193,29 @@ applySubstToIdInfo s0 (IdInfo arity demand spec strictness unfold
 
 \begin{code}
 ppIdInfo :: PprStyle
-	 -> Id		-- The Id for which we're printing this IdInfo
 	 -> Bool	-- True <=> print specialisations, please
-	 -> (Id -> Id)	-- to look up "better Ids" w/ better IdInfos;
-	 -> IdEnv Unfolding
-			-- inlining info for top-level fns in this module
-	 -> IdInfo	-- see MkIface notes
+	 -> IdInfo
 	 -> Pretty
 
-ppIdInfo sty for_this_id specs_please better_id_fn inline_env
-    i@(IdInfo arity demand specenv strictness unfold update deforest arg_usage fbtype srcloc)
-  | boringIdInfo i
-  = ppPStr SLIT("_NI_")
-
-  | otherwise
-  = let
-	stuff = ppCat [
+ppIdInfo sty specs_please
+    	 (IdInfo arity demand specenv strictness unfold update deforest arg_usage fbtype)
+  = ppCat [
 		    -- order is important!:
-		    ppInfo sty better_id_fn arity,
-		    ppInfo sty better_id_fn update,
-		    ppInfo sty better_id_fn deforest,
-
-		    pp_strictness sty (Just for_this_id)
-						  better_id_fn inline_env strictness,
+		    ppArityInfo sty arity,
+		    ppUpdateInfo sty update,
+		    ppDeforestInfo sty deforest,
 
-		    if bottomIsGuaranteed strictness
-		    then pp_NONE
-		    else pp_unfolding sty for_this_id inline_env unfold,
+		    ppStrictnessInfo sty strictness,
 
 		    if specs_please
-		    then pp_NONE -- ToDo -- sty (not (isDataCon for_this_id))
+		    then ppNil -- ToDo -- sty (not (isDataCon for_this_id))
 					 -- better_id_fn inline_env (mEnvToList specenv)
-		    else pp_NONE,
+		    else ppNil,
 
 		    -- DemandInfo needn't be printed since it has no effect on interfaces
-		    ppInfo sty better_id_fn demand,
-		    ppInfo sty better_id_fn fbtype
-		]
-    in
-    case sty of
-      PprInterface -> if opt_OmitInterfacePragmas
-		      then ppNil
-		      else stuff
-      _		   -> stuff
-\end{code}
-
-%************************************************************************
-%*									*
-\subsection[OptIdInfo-class]{The @OptIdInfo@ class (keeps things tidier)}
-%*									*
-%************************************************************************
-
-\begin{code}
-class OptIdInfo a where
-    noInfo	:: a
-    getInfo	:: IdInfo -> a
-    addInfo	:: IdInfo -> a -> IdInfo
-		-- By default, "addInfo" will not overwrite
-		-- "info" with "non-info"; look at any instance
-		-- to see an example.
-    ppInfo	:: PprStyle -> (Id -> Id) -> a -> Pretty
-\end{code}
-
-%************************************************************************
-%*									*
-\subsection[srcloc-IdInfo]{Source-location info in an @IdInfo@}
-%*									*
-%************************************************************************
-
-Not used much, but...
-\begin{code}
-getSrcLocIdInfo  (IdInfo _ _ _ _ _ _ _ _ _ src_loc) = src_loc
+		    ppDemandInfo sty demand,
+		    ppFBTypeInfo sty fbtype
+	]
 \end{code}
 
 %************************************************************************
@@ -326,31 +226,24 @@ getSrcLocIdInfo  (IdInfo _ _ _ _ _ _ _ _ _ src_loc) = src_loc
 
 \begin{code}
 data ArityInfo
-  = UnknownArity	-- no idea
-  | ArityExactly Int	-- arity is exactly this
+  = UnknownArity	-- No idea
+  | ArityExactly Int	-- Arity is exactly this
+  | ArityAtLeast Int	-- Arity is this or greater
 \end{code}
 
 \begin{code}
-mkArityInfo  = ArityExactly
+exactArity   = ArityExactly
+atLeastArity = ArityAtLeast
 unknownArity = UnknownArity
 
-arityMaybe :: ArityInfo -> Maybe Int
+arityInfo (IdInfo arity _ _ _ _ _ _ _ _) = arity
 
-arityMaybe UnknownArity	    = Nothing
-arityMaybe (ArityExactly i) = Just i
-\end{code}
+addArityInfo id_info			UnknownArity = id_info
+addArityInfo (IdInfo _ a c d e f g h i) arity	     = IdInfo arity a c d e f g h i
 
-\begin{code}
-instance OptIdInfo ArityInfo where
-    noInfo = UnknownArity
-
-    getInfo (IdInfo arity _ _ _ _ _ _ _ _ _) = arity
-
-    addInfo id_info UnknownArity = id_info
-    addInfo (IdInfo _ a c d e f g h i j) arity = IdInfo arity a c d e f g h i j
-
-    ppInfo sty _ UnknownArity	      = ifPprInterface sty pp_NONE
-    ppInfo sty _ (ArityExactly arity) = ppCat [ppPStr SLIT("_A_"), ppInt arity]
+ppArityInfo sty UnknownArity	     = ppNil
+ppArityInfo sty (ArityExactly arity) = ppCat [ppPStr SLIT("_A_"), ppInt arity]
+ppArityInfo sty (ArityAtLeast arity) = ppCat [ppPStr SLIT("_A>_"), ppInt arity]
 \end{code}
 
 %************************************************************************
@@ -373,6 +266,8 @@ data DemandInfo
 \end{code}
 
 \begin{code}
+noDemandInfo = UnknownDemand
+
 mkDemandInfo :: Demand -> DemandInfo
 mkDemandInfo demand = DemandedAsPer demand
 
@@ -382,22 +277,13 @@ willBeDemanded _		      = False
 \end{code}
 
 \begin{code}
-instance OptIdInfo DemandInfo where
-    noInfo = UnknownDemand
-
-    getInfo (IdInfo _ demand _ _ _ _ _ _ _ _) = demand
+demandInfo (IdInfo _ demand _ _ _ _ _ _ _) = demand
 
-{-	DELETED!  If this line is in, there is no way to
-	nuke a DemandInfo, and we have to be able to do that
-	when floating let-bindings around
-    addInfo id_info UnknownDemand = id_info
--}
-    addInfo (IdInfo a _ c d e f g h i j) demand = IdInfo a demand c d e f g h i j
+addDemandInfo (IdInfo a _ c d e f g h i) demand = IdInfo a demand c d e f g h i
 
-    ppInfo PprInterface _ _	      = ppNil
-    ppInfo sty _ UnknownDemand	      = ppStr "{-# L #-}"
-    ppInfo sty _ (DemandedAsPer info)
-      = ppCat [ppStr "{-#", ppStr (showList [info] ""), ppStr "#-}"]
+ppDemandInfo PprInterface _	      = ppNil
+ppDemandInfo sty UnknownDemand	      = ppStr "{-# L #-}"
+ppDemandInfo sty (DemandedAsPer info) = ppCat [ppStr "{-#", ppStr (showList [info] ""), ppStr "#-}"]
 \end{code}
 
 %************************************************************************
@@ -409,16 +295,10 @@ instance OptIdInfo DemandInfo where
 See SpecEnv.lhs
 
 \begin{code}
-instance OptIdInfo SpecEnv where
-    noInfo = nullSpecEnv
+specInfo (IdInfo _ _ spec _ _ _ _ _ _) = spec
 
-    getInfo (IdInfo _ _ spec _ _ _ _ _ _ _) = spec
-
-    addInfo id_info spec | isNullSpecEnv spec = id_info
-    addInfo (IdInfo a b _ d e f g h i j) spec = IdInfo a b spec d e f g h i j
-
-    ppInfo sty better_id_fn spec = panic "IdInfo:ppSpecs"
---      = ppSpecs sty True better_id_fn nullIdEnv (mEnvToList spec)
+addSpecInfo id_info spec | isNullSpecEnv spec = id_info
+addSpecInfo (IdInfo a b _ d e f g h i) spec   = IdInfo a b spec d e f g h i
 \end{code}
 
 %************************************************************************
@@ -438,7 +318,7 @@ version of the function; and (c)~the type signature of that worker (if
 it exists); i.e. its calling convention.
 
 \begin{code}
-data StrictnessInfo
+data StrictnessInfo bdee
   = NoStrictnessInfo
 
   | BottomGuaranteed	-- This Id guarantees never to return;
@@ -446,280 +326,55 @@ data StrictnessInfo
 			-- Useful for "error" and other disguised
 			-- variants thereof.
 
-  | StrictnessInfo	[Demand]	-- the main stuff; see below.
-			(Maybe Id)	-- worker's Id, if applicable.
-\end{code}
-
-This type is also actually used in the strictness analyser:
-\begin{code}
-data Demand
-  = WwLazy		-- Argument is lazy as far as we know
-	MaybeAbsent	-- (does not imply worker's existence [etc]).
-			-- If MaybeAbsent == True, then it is
-			-- *definitely* lazy.  (NB: Absence implies
-			-- a worker...)
-
-  | WwStrict		-- Argument is strict but that's all we know
-			-- (does not imply worker's existence or any
-			-- calling-convention magic)
-
-  | WwUnpack		-- Argument is strict & a single-constructor
-	[Demand]	-- type; its constituent parts (whose StrictInfos
-			-- are in the list) should be passed
-			-- as arguments to the worker.
-
-  | WwPrim		-- Argument is of primitive type, therefore
-			-- strict; doesn't imply existence of a worker;
-			-- argument should be passed as is to worker.
-
-  | WwEnum		-- Argument is strict & an enumeration type;
-			-- an Int# representing the tag (start counting
-			-- at zero) should be passed to the worker.
-  deriving (Eq, Ord)
-      -- we need Eq/Ord to cross-chk update infos in interfaces
-
-type MaybeAbsent = Bool -- True <=> not even used
-
--- versions that don't worry about Absence:
-wwLazy	    = WwLazy 	  False
-wwStrict    = WwStrict
-wwUnpack xs = WwUnpack xs
-wwPrim	    = WwPrim
-wwEnum	    = WwEnum
+  | StrictnessInfo	[Demand]	-- The main stuff; see below.
+			(Maybe bdee)	-- Worker's Id, if applicable.
+					-- (It may not be applicable because the strictness info
+					-- might say just "SSS" or something; so there's no w/w split.)
 \end{code}
 
 \begin{code}
-mkStrictnessInfo :: [Demand] -> Maybe Id -> StrictnessInfo
+mkStrictnessInfo :: [Demand] -> Maybe bdee -> StrictnessInfo bdee
 
-mkStrictnessInfo [] _    = NoStrictnessInfo
-mkStrictnessInfo xs wrkr = StrictnessInfo xs wrkr
+mkStrictnessInfo xs wrkr 
+  | all is_lazy xs	 = NoStrictnessInfo		-- Uninteresting
+  | otherwise		 = StrictnessInfo xs wrkr
+  where
+    is_lazy (WwLazy False) = True	-- NB "Absent" args do *not* count!
+    is_lazy _	           = False	-- (as they imply a worker)
 
+noStrictnessInfo       = NoStrictnessInfo
 mkBottomStrictnessInfo = BottomGuaranteed
 
 bottomIsGuaranteed BottomGuaranteed = True
 bottomIsGuaranteed other    	    = False
 
-getWrapperArgTypeCategories
-	:: Type		-- wrapper's type
-	-> StrictnessInfo	-- strictness info about its args
-	-> Maybe String
-
-getWrapperArgTypeCategories _ NoStrictnessInfo	    = Nothing
-getWrapperArgTypeCategories _ BottomGuaranteed
-  = trace "getWrapperArgTypeCategories:BottomGuaranteed!" Nothing  -- wrong
-getWrapperArgTypeCategories _ (StrictnessInfo [] _) = Nothing
-
-getWrapperArgTypeCategories ty (StrictnessInfo arg_info _)
-  = Just (mkWrapperArgTypeCategories ty arg_info)
-
-workerExists :: StrictnessInfo -> Bool
-workerExists (StrictnessInfo _ (Just worker_id)) = True
-workerExists other				 = False
-
-getWorkerId :: StrictnessInfo -> Id
-
-getWorkerId (StrictnessInfo _ (Just worker_id)) = worker_id
-#ifdef DEBUG
-getWorkerId junk = pprPanic "getWorkerId: " (ppInfo PprDebug (\x->x) junk)
-#endif
-\end{code}
-
-\begin{code}
-isStrict :: Demand -> Bool
+strictnessInfo (IdInfo _ _ _ strict _ _ _ _ _) = strict
 
-isStrict WwStrict	= True
-isStrict (WwUnpack _)	= True
-isStrict WwPrim		= True
-isStrict WwEnum		= True
-isStrict _		= False
+addStrictnessInfo id_info 		     NoStrictnessInfo = id_info
+addStrictnessInfo (IdInfo a b d _ e f g h i) strict	      = IdInfo a b d strict e f g h i
 
-nonAbsentArgs :: [Demand] -> Int
+ppStrictnessInfo sty NoStrictnessInfo = ppNil
+ppStrictnessInfo sty BottomGuaranteed = ppPStr SLIT("_S_ _!_")
 
-nonAbsentArgs cmpts
-  = foldr tick_non 0 cmpts
+ppStrictnessInfo sty (StrictnessInfo wrapper_args wrkr_maybe)
+  = ppCat [ppPStr SLIT("_S_"), ppStr (showList wrapper_args ""), pp_wrkr]
   where
-    tick_non (WwLazy True) acc = acc
-    tick_non other	   acc = acc + 1
-
-all_present_WwLazies :: [Demand] -> Bool
-all_present_WwLazies infos
-  = and (map is_L infos)
-  where
-    is_L (WwLazy False) = True	-- False <=> "Absent" args do *not* count!
-    is_L _	        = False	-- (as they imply a worker)
+    pp_wrkr = case wrkr_maybe of
+		 Nothing   -> ppNil
+		 Just wrkr -> ppr sty wrkr
 \end{code}
 
-WDP 95/04: It is no longer enough to look at a list of @Demands@ for
-an ``Unpack'' or an ``Absent'' and declare a worker.  We also have to
-check that @mAX_WORKER_ARGS@ hasn't been exceeded.  Therefore,
-@indicatesWorker@ mirrors the process used in @mk_ww_arg_processing@
-in \tr{WwLib.lhs}.  A worker is ``indicated'' when we hit an Unpack
-or an Absent {\em that we accept}.
-\begin{code}
-indicatesWorker :: [Demand] -> Bool
-
-indicatesWorker dems
-  = fake_mk_ww (mAX_WORKER_ARGS - nonAbsentArgs dems) dems
-  where
-    fake_mk_ww _ [] = False
-    fake_mk_ww _ (WwLazy True : _) = True -- we accepted an Absent
-    fake_mk_ww extra_args (WwUnpack cmpnts : dems)
-      | extra_args_now > 0 = True -- we accepted an Unpack
-      where
-	extra_args_now = extra_args + 1 - nonAbsentArgs cmpnts
-
-    fake_mk_ww extra_args (_ : dems)
-      = fake_mk_ww extra_args dems
-\end{code}
 
 \begin{code}
-mkWrapperArgTypeCategories
-	:: Type		-- wrapper's type
-	-> [Demand]	-- info about its arguments
-	-> String	-- a string saying lots about the args
-
-mkWrapperArgTypeCategories wrapper_ty wrap_info
-  = 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'
-    do_one (WwEnum, _) = 'E'
-    do_one (WwStrict, arg_ty_char) = arg_ty_char
-    do_one (WwUnpack _, arg_ty_char)
-      = if arg_ty_char `elem` "CIJFDTS"
-	then toLower arg_ty_char
-	else if arg_ty_char == '+' then 't'
-	else trace ("mkWrapp..:funny char:"++[arg_ty_char]) '-'
-    do_one (other_wrap_info, _) = '-'
-\end{code}
-
-Whether a worker exists depends on whether the worker has an
-absent argument, a @WwUnpack@ argument, (or @WwEnum@ ToDo???) arguments.
-
-If a @WwUnpack@ argument is for an {\em abstract} type (or one that
-will be abstract outside this module), which might happen for an
-imported function, then we can't (or don't want to...) unpack the arg
-as the worker requires.  Hence we have to give up altogether, and call
-the wrapper only; so under these circumstances we return \tr{False}.
-
-\begin{code}
-#ifdef REALLY_HASKELL_1_3
-instance Read Demand where
-#else
-instance Text Demand where
-#endif
-    readList str = read_em [{-acc-}] str
-      where
-	read_em acc []		= [(reverse acc, "")]
-	-- lower case indicates absence...
-	read_em acc ('L' : xs)	= read_em (WwLazy   False : acc) xs
-	read_em acc ('A' : xs)	= read_em (WwLazy   True  : acc) xs
-	read_em acc ('S' : xs)	= read_em (WwStrict : acc) xs
-	read_em acc ('P' : xs)	= read_em (WwPrim : acc) xs
-	read_em acc ('E' : xs)	= read_em (WwEnum : acc) xs
-
-	read_em acc (')' : xs)	= [(reverse acc, xs)]
-	read_em acc ( 'U'  : '(' : xs)
-	  = case (read_em [] xs) of
-	      [(stuff, rest)] -> read_em (WwUnpack stuff : acc) rest
-	      _ -> panic ("Text.Demand:"++str++"::"++xs)
-
-	read_em acc other = panic ("IdInfo.readem:"++other)
-
-#ifdef REALLY_HASKELL_1_3
-instance Show Demand where
-#endif
-    showList wrap_args rest = (concat (map show1 wrap_args)) ++ rest
-      where
-	show1 (WwLazy False) = "L"
-	show1 (WwLazy True)  = "A"
-	show1 WwStrict	     = "S"
-	show1 WwPrim	     = "P"
-	show1 WwEnum	     = "E"
-	show1 (WwUnpack args)= "U(" ++ (concat (map show1 args)) ++ ")"
-
-instance Outputable Demand where
-    ppr sty si = ppStr (showList [si] "")
-
-instance OptIdInfo StrictnessInfo where
-    noInfo = NoStrictnessInfo
-
-    getInfo (IdInfo _ _ _ strict _ _ _ _ _ _) = strict
-
-    addInfo id_info NoStrictnessInfo = id_info
-    addInfo (IdInfo a b d _ e f g h i j) strict = IdInfo a b d strict e f g h i j
+workerExists :: StrictnessInfo bdee -> Bool
+workerExists (StrictnessInfo _ (Just worker_id)) = True
+workerExists other				 = False
 
-    ppInfo sty better_id_fn strictness_info
-      = pp_strictness sty Nothing better_id_fn nullIdEnv strictness_info
+getWorkerId_maybe :: StrictnessInfo bdee -> Maybe bdee
+getWorkerId_maybe (StrictnessInfo _ maybe_worker_id) = maybe_worker_id
+getWorkerId_maybe other				     = Nothing
 \end{code}
 
-We'll omit the worker info if the thing has an explicit unfolding
-already.
-\begin{code}
-pp_strictness sty _ _ _ NoStrictnessInfo = ifPprInterface sty pp_NONE
-
-pp_strictness sty _ _ _ BottomGuaranteed = ppPStr SLIT("_S_ _!_")
-
-pp_strictness sty for_this_id_maybe better_id_fn inline_env
-    info@(StrictnessInfo wrapper_args wrkr_maybe)
-  = let
-	(have_wrkr, wrkr_id) = case wrkr_maybe of
-				 Nothing -> (False, panic "ppInfo(Strictness)")
-				 Just xx -> (True,  xx)
-
-	wrkr_to_print   = better_id_fn wrkr_id
-	wrkr_info	= getIdInfo   wrkr_to_print
-
-	-- if we aren't going to be able to *read* the strictness info
-	-- in TcPragmas, we need not even print it.
-	wrapper_args_to_use
-	  = if not (indicatesWorker wrapper_args) then
-		wrapper_args -- no worker/wrappering in any case
-	    else
-		case for_this_id_maybe of
-		  Nothing -> wrapper_args
-		  Just id -> if externallyVisibleId id
-			     && (unfoldingUnfriendlyId id || not have_wrkr) then
-				-- pprTrace "IdInfo: unworker-ising:" (ppCat [ppr PprDebug have_wrkr, ppr PprDebug id]) $
-				map un_workerise wrapper_args
-			     else
-				wrapper_args
-
-	id_is_worker
-	  = case for_this_id_maybe of
-	      Nothing -> False
-	      Just id -> isWorkerId id
-
-	am_printing_iface = case sty of { PprInterface -> True ; _ -> False }
-
-	pp_basic_info
-	  = ppBesides [ppStr "_S_ \"",
-		ppStr (showList wrapper_args_to_use ""), ppStr "\""]
-
-	pp_with_worker
-	  = ppBesides [ ppSP, ppChar '{',
-			ppIdInfo sty wrkr_to_print True{-wrkr specs, yes!-} better_id_fn inline_env wrkr_info,
-			ppChar '}' ]
-    in
-    if all_present_WwLazies wrapper_args_to_use then -- too boring
-	ifPprInterface sty pp_NONE
-
-    else if id_is_worker && am_printing_iface then
-    	pp_NONE -- we don't put worker strictness in interfaces
-		-- (it can be deduced)
-
-    else if not (indicatesWorker wrapper_args_to_use)
-	 || not have_wrkr
-	 || boringIdInfo wrkr_info then
-	ppBeside pp_basic_info ppNil
-    else
-	ppBeside pp_basic_info pp_with_worker
-  where
-    un_workerise (WwLazy   _) = WwLazy False -- avoid absence
-    un_workerise (WwUnpack _) = WwStrict
-    un_workerise other	      = other
-\end{code}
 
 %************************************************************************
 %*									*
@@ -728,41 +383,9 @@ pp_strictness sty for_this_id_maybe better_id_fn inline_env
 %************************************************************************
 
 \begin{code}
-mkUnfolding guide expr
-  = CoreUnfolding (SimpleUnfolding (mkFormSummary expr)
-				   guide
-				   (occurAnalyseGlobalExpr expr))
-\end{code}
-
-\begin{code}
-noInfo_UF = NoUnfolding
-
-getInfo_UF (IdInfo _ _ _ _ unfolding _ _ _ _ _) = unfolding
-
-addInfo_UF id_info@(IdInfo a b c d e f g h i j) NoUnfolding = id_info
-addInfo_UF (IdInfo a b d e _ f g h i j) uf = IdInfo a b d e uf f g h i j
-\end{code}
-
-\begin{code}
-pp_unfolding sty for_this_id inline_env uf_details
-  = case (lookupIdEnv inline_env for_this_id) of
-      Nothing -> pp uf_details
-      Just dt -> pp dt
-  where
-    pp NoUnfolding = pp_NONE
-
-    pp (MagicUnfolding tag _)
-      = ppCat [ppPStr SLIT("_MF_"), pprUnique tag]
-
-    pp (CoreUnfolding (SimpleUnfolding _ guide template))
-      = let
-	    untagged = unTagBinders template
-	in
-    	if untagged `isWrapperFor` for_this_id
-	then -- pprTrace "IdInfo:isWrapperFor:" (ppAbove (ppr PprDebug for_this_id) (ppr PprDebug untagged))
-	     pp_NONE
-	else ppCat [ppPStr SLIT("_F_"), ppr sty guide, pprCoreUnfolding untagged]
+unfoldInfo (IdInfo _ _ _ _ unfolding _ _ _ _) = unfolding
 
+addUnfoldInfo (IdInfo a b d e _ f g h i) uf = IdInfo a b d e uf f g h i
 \end{code}
 
 %************************************************************************
@@ -804,18 +427,14 @@ instance Text UpdateInfo where
 	ok_digit c | c >= '0' && c <= '2' = ord c - ord '0'
 		   | otherwise = panic "IdInfo: not a digit while reading update pragma"
 
-instance OptIdInfo UpdateInfo where
-    noInfo = NoUpdateInfo
-
-    getInfo (IdInfo _ _ _ _ _ update _ _ _ _) = update
+updateInfo (IdInfo _ _ _ _ _ update _ _ _) = update
 
-    addInfo id_info NoUpdateInfo = id_info
-    addInfo (IdInfo a b d e f _ g h i j) upd_info = IdInfo a b d e f upd_info g h i j
+addUpdateInfo id_info			 NoUpdateInfo = id_info
+addUpdateInfo (IdInfo a b d e f _ g h i) upd_info     = IdInfo a b d e f upd_info g h i
 
-    ppInfo sty better_id_fn NoUpdateInfo	= ifPprInterface sty pp_NONE
-    ppInfo sty better_id_fn (SomeUpdateInfo [])	= ifPprInterface sty pp_NONE
-    ppInfo sty better_id_fn (SomeUpdateInfo spec)
-      = ppBeside (ppPStr SLIT("_U_ ")) (ppBesides (map ppInt spec))
+ppUpdateInfo sty NoUpdateInfo	       = ppNil
+ppUpdateInfo sty (SomeUpdateInfo [])   = ppNil
+ppUpdateInfo sty (SomeUpdateInfo spec) = ppBeside (ppPStr SLIT("_U_ ")) (ppBesides (map ppInt spec))
 \end{code}
 
 %************************************************************************
@@ -836,19 +455,13 @@ data DeforestInfo
 \end{code}
 
 \begin{code}
-instance OptIdInfo DeforestInfo where
-    noInfo = Don'tDeforest
+deforestInfo (IdInfo _ _ _ _ _ _ deforest _ _) = deforest
 
-    getInfo (IdInfo _ _ _ _ _ _ deforest _ _ _) = deforest
+addDeforestInfo id_info 		   Don'tDeforest = id_info
+addDeforestInfo (IdInfo a b d e f g _ h i) deforest	 = IdInfo a b d e f g deforest h i
 
-    addInfo id_info Don'tDeforest = id_info
-    addInfo (IdInfo a b d e f g _ h i j) deforest =
-    	IdInfo a b d e f g deforest h i j
-
-    ppInfo sty better_id_fn Don'tDeforest
-      = ifPprInterface sty pp_NONE
-    ppInfo sty better_id_fn DoDeforest
-      = ppPStr SLIT("_DEFOREST_")
+ppDeforestInfo sty Don'tDeforest = ppNil
+ppDeforestInfo sty DoDeforest    = ppPStr SLIT("_DEFOREST_")
 \end{code}
 
 %************************************************************************
@@ -869,27 +482,22 @@ type ArgUsageType  = [ArgUsage]		-- c_1 -> ... -> BLOB
 \end{code}
 
 \begin{code}
-mkArgUsageInfo = SomeArgUsageInfo
+mkArgUsageInfo [] = NoArgUsageInfo
+mkArgUsageInfo au = SomeArgUsageInfo au
 
 getArgUsage :: ArgUsageInfo -> ArgUsageType
-getArgUsage NoArgUsageInfo	    = []
+getArgUsage NoArgUsageInfo	  = []
 getArgUsage (SomeArgUsageInfo u)  = u
 \end{code}
 
 \begin{code}
-instance OptIdInfo ArgUsageInfo where
-    noInfo = NoArgUsageInfo
-
-    getInfo (IdInfo _ _ _ _ _  _ _ au _ _) = au
+argUsageInfo (IdInfo _ _ _ _ _  _ _ au _) = au
 
-    addInfo id_info NoArgUsageInfo = id_info
-    addInfo (IdInfo a b d e f g h _ i j) au_info = IdInfo a b d e f g h au_info i j
-
-    ppInfo sty better_id_fn NoArgUsageInfo		= ifPprInterface sty pp_NONE
-    ppInfo sty better_id_fn (SomeArgUsageInfo [])	= ifPprInterface sty pp_NONE
-    ppInfo sty better_id_fn (SomeArgUsageInfo aut)
-      = ppBeside (ppPStr SLIT("_L_ ")) (ppArgUsageType aut)
+addArgUsageInfo id_info			   NoArgUsageInfo = id_info
+addArgUsageInfo (IdInfo a b d e f g h _ i) au_info	  = IdInfo a b d e f g h au_info i
 
+ppArgUsageInfo sty NoArgUsageInfo	  = ppNil
+ppArgUsageInfo sty (SomeArgUsageInfo aut) = ppBeside (ppPStr SLIT("_L_ ")) (ppArgUsageType aut)
 
 ppArgUsage (ArgUsage n)      = ppInt n
 ppArgUsage (UnknownArgUsage) = ppChar '-'
@@ -899,6 +507,7 @@ ppArgUsageType aut = ppBesides
 	  ppIntersperse ppComma (map ppArgUsage aut),
 	  ppChar '"' ]
 \end{code}
+
 %************************************************************************
 %*									*
 \subsection[FBType-IdInfo]{Type of an expression through Foldr/build's eyes}
@@ -909,7 +518,6 @@ ppArgUsageType aut = ppBesides
 data FBTypeInfo
   = NoFBTypeInfo
   | SomeFBTypeInfo FBType
-  -- ??? deriving (Eq, Ord)
 
 data FBType = FBType [FBConsum] FBProd deriving (Eq)
 
@@ -926,23 +534,15 @@ getFBType (SomeFBTypeInfo u)  = Just u
 \end{code}
 
 \begin{code}
-instance OptIdInfo FBTypeInfo where
-    noInfo = NoFBTypeInfo
-
-    getInfo (IdInfo _ _ _ _ _ _ _ _ fb _) = fb
+fbTypeInfo (IdInfo _ _ _ _ _ _ _ _ fb) = fb
 
-    addInfo id_info NoFBTypeInfo = id_info
-    addInfo (IdInfo a b d e f g h i _ j) fb_info = IdInfo a b d e f g h i fb_info j
+addFBTypeInfo id_info NoFBTypeInfo = id_info
+addFBTypeInfo (IdInfo a b d e f g h i _) fb_info = IdInfo a b d e f g h i fb_info
 
-    ppInfo PprInterface _ NoFBTypeInfo = ppNil
-    ppInfo sty 		_ NoFBTypeInfo = ifPprInterface sty pp_NONE
-    ppInfo sty 		_ (SomeFBTypeInfo (FBType cons prod))
+ppFBTypeInfo sty NoFBTypeInfo = ppNil
+ppFBTypeInfo sty (SomeFBTypeInfo (FBType cons prod))
       = ppBeside (ppPStr SLIT("_F_ ")) (ppFBType cons prod)
 
---ppFBType (FBType n)      = ppBesides [ppInt n]
---ppFBType (UnknownFBType) = ppBesides [ppStr "-"]
---
-
 ppFBType cons prod = ppBesides
 	([ ppChar '"' ] ++ map ppCons cons ++ [ ppChar '-', ppProd prod, ppChar '"' ])
   where
diff --git a/ghc/compiler/basicTypes/IdLoop.lhi b/ghc/compiler/basicTypes/IdLoop.lhi
index 3a766f072e..86680a8caa 100644
--- a/ghc/compiler/basicTypes/IdLoop.lhi
+++ b/ghc/compiler/basicTypes/IdLoop.lhi
@@ -9,7 +9,7 @@ import PreludeStdIO	( Maybe )
 import BinderInfo	( BinderInfo )
 import CoreSyn		( CoreExpr(..), GenCoreExpr, GenCoreArg )
 import CoreUnfold 	( Unfolding(..), UnfoldingGuidance(..), 
-			  SimpleUnfolding(..), FormSummary(..)  )
+			  SimpleUnfolding(..), FormSummary(..), noUnfolding  )
 import CoreUtils	( unTagBinders )
 import Id		( externallyVisibleId, isDataCon, isWorkerId, isWrapperId,
 			  unfoldingUnfriendlyId, getIdInfo, nmbrId,
@@ -34,11 +34,16 @@ import Unique		( Unique )
 import Usage		( GenUsage )
 import Util		( Ord3(..) )
 import WwLib		( mAX_WORKER_ARGS )
+import StdIdInfo	( addStandardIdInfo )	-- Used in Id, but StdIdInfo needs lots of stuff from Id
+
+addStandardIdInfo :: Id -> Id
 
 nullSpecEnv   :: SpecEnv
 isNullSpecEnv :: SpecEnv -> Bool
 
-occurAnalyseGlobalExpr  :: GenCoreExpr (GenId (GenType (GenTyVar (GenUsage Unique)) Unique)) (GenId (GenType (GenTyVar (GenUsage Unique)) Unique)) (GenTyVar (GenUsage Unique)) Unique -> GenCoreExpr (GenId (GenType (GenTyVar (GenUsage Unique)) Unique), BinderInfo) (GenId (GenType (GenTyVar (GenUsage Unique)) Unique)) (GenTyVar (GenUsage Unique)) Unique
+-- occurAnalyseGlobalExpr  :: GenCoreExpr (GenId (GenType (GenTyVar (GenUsage Unique)) Unique)) (GenId (GenType (GenTyVar (GenUsage Unique)) Unique)) (GenTyVar (GenUsage Unique)) Unique -> GenCoreExpr (GenId (GenType (GenTyVar (GenUsage Unique)) Unique), BinderInfo) (GenId (GenType (GenTyVar (GenUsage Unique)) Unique)) (GenTyVar (GenUsage Unique)) Unique
+-- unTagBinders :: GenCoreExpr (GenId (GenType (GenTyVar (GenUsage Unique)) Unique), a) b c d -> GenCoreExpr (GenId (GenType (GenTyVar (GenUsage Unique)) Unique)) b c d
+
 externallyVisibleId	:: Id	    -> Bool
 isDataCon		:: GenId ty -> Bool
 isWorkerId		:: GenId ty -> Bool
@@ -49,9 +54,7 @@ nullIdEnv		:: UniqFM a
 lookupIdEnv		:: UniqFM b -> GenId a -> Maybe b
 mAX_WORKER_ARGS		:: Int
 nmbrId			:: Id -> NmbrEnv -> (NmbrEnv, Id)
-pprParendGenType		:: (Eq a, Outputable a, Eq b, Outputable b) => PprStyle -> GenType a b -> Int -> Bool -> PrettyRep
-unTagBinders :: GenCoreExpr (GenId (GenType (GenTyVar (GenUsage Unique)) Unique), a) b c d -> GenCoreExpr (GenId (GenType (GenTyVar (GenUsage Unique)) Unique)) b c d
-
+pprParendGenType	:: (Eq a, Outputable a, Eq b, Outputable b) => PprStyle -> GenType a b -> Int -> Bool -> PrettyRep
 mkMagicUnfoldingFun	:: Unique -> MagicUnfoldingFun
 
 type IdEnv a = UniqFM a
@@ -73,13 +76,15 @@ data NmbrEnv
 data MagicUnfoldingFun
 data FormSummary = VarForm | ValueForm | BottomForm | OtherForm
 
-data Unfolding
-  = NoUnfolding
-  | CoreUnfolding SimpleUnfolding
-  | MagicUnfolding Unique MagicUnfoldingFun
+-- data Unfolding
+--  = NoUnfolding
+--  | CoreUnfolding SimpleUnfolding
+--  | MagicUnfolding Unique MagicUnfoldingFun
 
+data Unfolding
+noUnfolding :: Unfolding
 
-data SimpleUnfolding = SimpleUnfolding FormSummary UnfoldingGuidance (GenCoreExpr (GenId (GenType (GenTyVar (GenUsage Unique)) Unique), BinderInfo) (GenId (GenType (GenTyVar (GenUsage Unique)) Unique)) (GenTyVar (GenUsage Unique)) Unique) 
+-- data SimpleUnfolding = SimpleUnfolding FormSummary UnfoldingGuidance (GenCoreExpr (GenId (GenType (GenTyVar (GenUsage Unique)) Unique), BinderInfo) (GenId (GenType (GenTyVar (GenUsage Unique)) Unique)) (GenTyVar (GenUsage Unique)) Unique) 
 
 
 data UnfoldingGuidance
diff --git a/ghc/compiler/basicTypes/IdUtils.lhs b/ghc/compiler/basicTypes/IdUtils.lhs
index 94703c3fd5..a9ae81599b 100644
--- a/ghc/compiler/basicTypes/IdUtils.lhs
+++ b/ghc/compiler/basicTypes/IdUtils.lhs
@@ -6,21 +6,21 @@
 \begin{code}
 #include "HsVersions.h"
 
-module IdUtils ( primOpNameInfo, primOpId ) where
+module IdUtils ( primOpName ) where
 
 IMP_Ubiq()
 IMPORT_DELOOPER(PrelLoop)		-- here for paranoia checking
 IMPORT_DELOOPER(IdLoop) (SpecEnv)
 
 import CoreSyn
-import CoreUnfold	( UnfoldingGuidance(..), Unfolding )
-import Id		( mkImported, mkTemplateLocals )
+import CoreUnfold	( UnfoldingGuidance(..), Unfolding, mkUnfolding )
+import Id		( mkPrimitiveId, mkTemplateLocals )
 import IdInfo		-- quite a few things
-import Name		( mkPrimitiveName, OrigName(..) )
-import PrelMods		( gHC_BUILTINS )
+import StdIdInfo
+import Name		( mkWiredInIdName )
 import PrimOp		( primOpInfo, tagOf_PrimOp, primOp_str,
 			  PrimOpInfo(..), PrimOpResultInfo(..) )
-import RnHsSyn		( RnName(..) )
+import PrelMods		( gHC__ )
 import Type		( mkForAllTys, mkFunTy, mkFunTys, mkTyVarTy, applyTyCon )
 import TysWiredIn	( boolTy )
 import Unique		( mkPrimOpIdUnique )
@@ -28,66 +28,45 @@ import Util		( panic )
 \end{code}
 
 \begin{code}
-primOpNameInfo :: PrimOp -> (FAST_STRING, RnName)
-primOpId       :: PrimOp -> Id
-
-primOpNameInfo op = (primOp_str  op, WiredInId (primOpId op))
-
-primOpId op
+primOpName       :: PrimOp -> Name
+primOpName op
   = case (primOpInfo op) of
       Dyadic str ty ->
-	mk_prim_Id op str [] [ty,ty] (dyadic_fun_ty ty) 2
+	mk_prim_name op str [] [ty,ty] (dyadic_fun_ty ty) 2
 
       Monadic str ty ->
-	mk_prim_Id op str [] [ty] (monadic_fun_ty ty) 1
+	mk_prim_name op str [] [ty] (monadic_fun_ty ty) 1
 
       Compare str ty ->
-	mk_prim_Id op str [] [ty,ty] (compare_fun_ty ty) 2
+	mk_prim_name op str [] [ty,ty] (compare_fun_ty ty) 2
 
       Coercing str ty1 ty2 ->
-	mk_prim_Id op str [] [ty1] (ty1 `mkFunTy` ty2) 1
+	mk_prim_name op str [] [ty1] (ty1 `mkFunTy` ty2) 1
 
       PrimResult str tyvars arg_tys prim_tycon kind res_tys ->
-	mk_prim_Id op str
+	mk_prim_name op str
 	    tyvars
 	    arg_tys
 	    (mkForAllTys tyvars (mkFunTys arg_tys (applyTyCon prim_tycon res_tys)))
 	    (length arg_tys) -- arity
 
       AlgResult str tyvars arg_tys tycon res_tys ->
-	mk_prim_Id op str
+	mk_prim_name op str
 	    tyvars
 	    arg_tys
 	    (mkForAllTys tyvars (mkFunTys arg_tys (applyTyCon tycon res_tys)))
 	    (length arg_tys) -- arity
   where
-    mk_prim_Id prim_op name tyvar_tmpls arg_tys ty arity
-      = mkImported (mkPrimitiveName key (OrigName gHC_BUILTINS name)) ty
-	   (noIdInfo `addInfo` (mkArityInfo arity)
-	          `addInfo_UF` (mkUnfolding UnfoldAlways
-			         (mk_prim_unfold prim_op tyvar_tmpls arg_tys)))
+    mk_prim_name prim_op occ_name tyvar_tmpls arg_tys ty arity
+      = name
       where
-	key = mkPrimOpIdUnique (IBOX(tagOf_PrimOp prim_op))
+	key     = mkPrimOpIdUnique (IBOX(tagOf_PrimOp prim_op))
+	name    = mkWiredInIdName key gHC__ occ_name the_id
+	the_id  = mkPrimitiveId name ty prim_op
 \end{code}
 
-
 \begin{code}
 dyadic_fun_ty  ty = mkFunTys [ty, ty] ty
 monadic_fun_ty ty = ty `mkFunTy` ty
 compare_fun_ty ty = mkFunTys [ty, ty] boolTy
 \end{code}
-
-The functions to make common unfoldings are tedious.
-
-\begin{code}
-mk_prim_unfold :: PrimOp -> [TyVar] -> [Type] -> CoreExpr{-template-}
-
-mk_prim_unfold prim_op tyvars arg_tys
-  = let
-	vars = mkTemplateLocals arg_tys
-    in
-    mkLam tyvars vars $
-    Prim prim_op
-	([TyArg (mkTyVarTy tv) | tv <- tyvars] ++ [VarArg v | v <- vars])
-\end{code}
-
diff --git a/ghc/compiler/basicTypes/Name.lhs b/ghc/compiler/basicTypes/Name.lhs
index 3fdedfbd8c..d4b56e0722 100644
--- a/ghc/compiler/basicTypes/Name.lhs
+++ b/ghc/compiler/basicTypes/Name.lhs
@@ -7,327 +7,352 @@
 #include "HsVersions.h"
 
 module Name (
+	-- The Module type
 	SYN_IE(Module),
+	pprModule, moduleString,
 
-	OrigName(..), -- glorified pair
-	qualToOrigName, -- a Qual to an OrigName
-
-	RdrName(..),
-	preludeQual,
-	moduleNamePair,
-	isUnqual,
-	isQual,
-	isRdrLexCon, isRdrLexConOrSpecial,
-	appendRdr,
-	showRdr,
-	cmpRdr,
-
-	Name,
-	Provenance,
-	mkLocalName, isLocalName, 
-	mkTopLevName, mkImportedName, oddlyImportedName,
-	mkImplicitName,	isImplicitName,
-	mkPrimitiveName, mkWiredInName,
-	mkCompoundName, mkCompoundName2,
-
-	mkFunTyConName, mkTupleDataConName, mkTupleTyConName,
-	mkTupNameStr,
-
-	NamedThing(..), -- class
-	ExportFlag(..),
-	isExported{-overloaded-}, exportFlagOn{-not-},
-
-	nameUnique, changeUnique,
-	nameOccName,
---	nameOrigName, : not exported
-	nameExportFlag,
-	nameSrcLoc,
-	nameImpLocs,
-	nameImportFlag,
-	isLocallyDefinedName, isWiredInName,
-
-	origName, moduleOf, nameOf,
-	getOccName, getExportFlag,
-	getSrcLoc, getImpLocs,
-	isLocallyDefined,
-	getLocalName,
-
-	isSymLexeme, pprSym, pprNonSym,
-	isLexCon, isLexVar, isLexId, isLexSym, isLexSpecialSym,
-	isLexConId, isLexConSym, isLexVarId, isLexVarSym
-    ) where
+	-- The OccName type
+	OccName(..),
+	pprOccName, pprSymOcc, pprNonSymOcc, occNameString, occNameFlavour, isTvOcc, 
+	quoteInText, parenInCode,
 
-IMP_Ubiq()
-IMPORT_1_3(Char(isUpper,isLower))
+	-- The Name type
+	Name,					-- Abstract
+	mkLocalName, mkSysLocalName, 
 
-import CmdLineOpts	( maybe_CompilingGhcInternals )
-import CStrings		( identToC, modnameToC, cSEP )
-import Outputable	( Outputable(..) )
-import PprStyle		( PprStyle(..), codeStyle )
-import PrelMods		( pRELUDE )
-import Pretty
-import SrcLoc		( mkBuiltinSrcLoc, mkUnknownSrcLoc, SrcLoc )
-import Unique		( funTyConKey, mkTupleDataConUnique, mkTupleTyConUnique,
-			  pprUnique, Unique
-			)
-import Util		( thenCmp, _CMP_STRING_, nOfThem, panic, assertPanic{-, pprTrace ToDo:rm-} )
-
-#ifdef REALLY_HASKELL_1_3
-ord = fromEnum :: Char -> Int
-#endif
-\end{code}
+	mkCompoundName, mkGlobalName, mkInstDeclName,
 
-%************************************************************************
-%*									*
-\subsection[RdrName]{The @RdrName@ datatype; names read from files}
-%*									*
-%************************************************************************
-
-\begin{code}
-type Module = FAST_STRING
+	mkWiredInIdName,   mkWiredInTyConName,
+	maybeWiredInIdName, maybeWiredInTyConName,
+	isWiredInName,
 
-data OrigName = OrigName Module FAST_STRING
+	nameUnique, changeUnique, setNameProvenance, setNameVisibility,
+	nameOccName, nameString,
+	isExportedName,	nameSrcLoc,
+	isLocallyDefinedName,
 
-qualToOrigName (Qual m n) = OrigName m n
+	isLocalName, 
 
-data RdrName
-  = Unqual FAST_STRING
-  | Qual   Module FAST_STRING
+        pprNameProvenance,
 
-preludeQual n = Qual pRELUDE n
+	-- Sets of Names
+	NameSet(..),
+	emptyNameSet, unitNameSet, mkNameSet, unionNameSets, unionManyNameSets,
+	minusNameSet, elemNameSet, nameSetToList, addListToNameSet,
 
-moduleNamePair (Qual m n) = (m, n)  -- we make *no* claim whether this
-				    -- constitutes an original name or
-				    -- an occurrence name, or anything else
-
-isUnqual (Unqual _) = True
-isUnqual (Qual _ _) = False
+	-- Misc
+	DefnInfo(..),
+	Provenance(..), pprProvenance,
+	ExportFlag(..),
 
-isQual (Unqual _) = False
-isQual (Qual _ _) = True
+	-- Class NamedThing and overloaded friends
+	NamedThing(..),
+	modAndOcc, isExported, 
+	getSrcLoc, isLocallyDefined, getOccString,
 
-isRdrLexCon (Unqual n) = isLexCon n
-isRdrLexCon (Qual m n) = isLexCon n
+	pprSym, pprNonSym
+    ) where
 
-isRdrLexConOrSpecial (Unqual n) = isLexCon n || isLexSpecialSym n
-isRdrLexConOrSpecial (Qual m n) = isLexCon n || isLexSpecialSym n
+IMP_Ubiq()
+import TyLoop		( GenId, Id(..), TyCon )			-- Used inside Names
+import CStrings		( identToC, modnameToC, cSEP )
+import CmdLineOpts	( opt_OmitInterfacePragmas, opt_EnsureSplittableC )
 
-appendRdr (Unqual n) str = Unqual (n _APPEND_ str)
-appendRdr (Qual m n) str = Qual m (n _APPEND_ str)
+import Outputable	( Outputable(..) )
+import PprStyle		( PprStyle(..), codeStyle, ifaceStyle )
+import PrelMods		( gHC__ )
+import Pretty
+import Lex		( isLexSym, isLexConId )
+import SrcLoc		( noSrcLoc, SrcLoc )
+import Unique		( pprUnique, showUnique, Unique )
+import UniqSet		( UniqSet(..), emptyUniqSet, unitUniqSet, unionUniqSets, uniqSetToList,
+		 	  unionManyUniqSets, minusUniqSet, mkUniqSet, elementOfUniqSet, addListToUniqSet )
+import UniqFM		( UniqFM )
+import Util		( cmpPString, panic, assertPanic {-, pprTrace ToDo:rm-} )
+\end{code}
 
-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) = _CMP_STRING_ n1 n2 `thenCmp` _CMP_STRING_ m1 m2
-				   -- always compare module-names *second*
 
-cmpOrig (OrigName m1 n1) (OrigName m2 n2)
-  = _CMP_STRING_ n1 n2 `thenCmp` _CMP_STRING_ m1 m2 -- again; module-names *second*
+%************************************************************************
+%*									*
+\subsection[Name-pieces-datatypes]{The @Module@, @OccName@ datatypes}
+%*									*
+%************************************************************************
 
-instance Eq RdrName where
+\begin{code}
+type Module   = FAST_STRING
+
+data OccName  = VarOcc  FAST_STRING	-- Variables and data constructors
+	      | TvOcc	FAST_STRING	-- Type variables
+	      | TCOcc	FAST_STRING	-- Type constructors and classes
+
+moduleString :: Module -> String
+moduleString mod = _UNPK_ mod
+
+pprModule :: PprStyle -> Module -> Pretty
+pprModule sty m = ppPStr m
+
+pprOccName :: PprStyle -> OccName -> Pretty
+pprOccName PprDebug n = ppCat [ppPStr (occNameString n), ppBracket (ppStr (occNameFlavour n))]
+pprOccName sty      n = if codeStyle sty 
+			then identToC (occNameString n)
+			else ppPStr (occNameString n)
+
+occNameString :: OccName -> FAST_STRING
+occNameString (VarOcc s)  = s
+occNameString (TvOcc s)   = s
+occNameString (TCOcc s)   = s
+
+-- occNameFlavour is used only to generate good error messages, so it doesn't matter
+-- that the VarOcc case isn't mega-efficient.  We could have different Occ constructors for
+-- data constructors and values, but that makes everything else a bit more complicated.
+occNameFlavour :: OccName -> String
+occNameFlavour (VarOcc s) | isLexConId s = "data constructor"
+			  | otherwise    = "value"
+occNameFlavour (TvOcc s)  = "type variable"
+occNameFlavour (TCOcc s)  = "type constructor or class"
+
+isTvOcc :: OccName -> Bool
+isTvOcc (TvOcc s) = True
+isTvOcc other     = False
+
+instance Eq OccName where
     a == b = case (a `cmp` b) of { EQ_ -> True;  _ -> False }
     a /= b = case (a `cmp` b) of { EQ_ -> False; _ -> True }
 
-instance Ord RdrName where
+instance Ord OccName where
     a <= b = case (a `cmp` b) of { LT_ -> True;	 EQ_ -> True;  GT__ -> False }
     a <	 b = case (a `cmp` b) of { LT_ -> True;	 EQ_ -> False; GT__ -> False }
     a >= b = case (a `cmp` b) of { LT_ -> False; EQ_ -> True;  GT__ -> True  }
     a >	 b = case (a `cmp` b) of { LT_ -> False; EQ_ -> False; GT__ -> True  }
 
-instance Ord3 RdrName where
-    cmp = cmpRdr
-
-instance NamedThing RdrName where
-    -- We're sorta faking it here
-    getName (Unqual n)
-      = Local u n True locn
-      where
-	u    = panic "NamedThing.RdrName:Unique1"
-	locn = panic "NamedThing.RdrName:locn"
-
-    getName rdr_name@(Qual m n)
-      = Global u m (Left n) prov ex [rdr_name]
-      where
-	u    = panic "NamedThing.RdrName:Unique"
-	prov = panic "NamedThing.RdrName:Provenance"
-	ex   = panic "NamedThing.RdrName:ExportFlag"
-
-instance Outputable RdrName where
-    ppr sty (Unqual n) = pp_name sty n
-    ppr sty (Qual m n) = ppBeside (pp_mod sty m) (pp_name sty n)
-
-pp_mod sty m
-  = case sty of
-      PprForC		-> pp_code
-      PprForAsm False _ -> pp_code
-      PprForAsm True  _ -> ppBeside (ppPStr cSEP) pp_code
-      _			-> ppBeside (ppPStr m)    (ppChar '.')
-  where
-    pp_code = ppBeside (ppPStr (modnameToC m)) (ppPStr cSEP)
+instance Ord3 OccName where
+    cmp = cmpOcc
 
-pp_name sty n = (if codeStyle sty then identToC else ppPStr) n
+(VarOcc s1) `cmpOcc` (VarOcc s2) = s1 `_CMP_STRING_` s2
+(VarOcc s1) `cmpOcc` other2      = LT_
 
-pp_name2 sty pieces
-  = ppIntersperse sep (map pp_piece pieces)
-  where
-    sep = if codeStyle sty then ppPStr cSEP else ppChar '.'
+(TvOcc s1)  `cmpOcc` (VarOcc s2) = GT_
+(TvOcc s1)  `cmpOcc` (TvOcc s2)  = s1 `_CMP_STRING_` s2
+(TvOcc s1)  `cmpOcc` other	 = LT_
 
-    pp_piece (Left (OrigName m n)) = ppBeside (pp_mod sty m) (pp_name sty n)
-    pp_piece (Right n)		   = pp_name sty n
+(TCOcc s1) `cmpOcc` (TCOcc s2) = s1 `_CMP_STRING_` s2
+(TCOcc s1) `cmpOcc` other      = GT_
 
-showRdr sty rdr = ppShow 100 (ppr sty rdr)
+instance Outputable OccName where
+  ppr = pprOccName
+\end{code}
 
--------------------------
-instance Eq OrigName where
-    a == b = case (a `cmp` b) of { EQ_ -> True;  _ -> False }
-    a /= b = case (a `cmp` b) of { EQ_ -> False; _ -> True }
 
-instance Ord OrigName where
-    a <= b = case (a `cmp` b) of { LT_ -> True;	 EQ_ -> True;  GT__ -> False }
-    a <	 b = case (a `cmp` b) of { LT_ -> True;	 EQ_ -> False; GT__ -> False }
-    a >= b = case (a `cmp` b) of { LT_ -> False; EQ_ -> True;  GT__ -> True  }
-    a >	 b = case (a `cmp` b) of { LT_ -> False; EQ_ -> False; GT__ -> True  }
+\begin{code}
+parenInCode, quoteInText :: OccName -> Bool
+parenInCode occ = isLexSym (occNameString occ)
 
-instance Ord3 OrigName where
-    cmp = cmpOrig
+quoteInText occ = not (isLexSym (occNameString occ))
+
+-- print `vars`, (op) correctly
+pprSymOcc, pprNonSymOcc :: PprStyle -> OccName -> Pretty
 
-instance NamedThing OrigName where -- faking it
-    getName (OrigName m n) = getName (Qual m n)
+pprSymOcc sty var
+  = if quoteInText var
+    then ppQuote (pprOccName sty var)
+    else pprOccName sty var
 
-instance Outputable OrigName where -- ditto
-    ppr sty (OrigName m n) = ppr sty (Qual m n)
+pprNonSymOcc sty var
+  = if parenInCode var
+    then ppParens (pprOccName sty var)
+    else pprOccName sty var
 \end{code}
 
 %************************************************************************
 %*									*
-\subsection[Name-datatype]{The @Name@ datatype}
+\subsection[Name-datatype]{The @Name@ datatype, and name construction}
 %*									*
 %************************************************************************
-
+ 
 \begin{code}
 data Name
   = Local    Unique
-             FAST_STRING
-	     Bool	-- True <=> emphasize Unique when
-			-- printing; this is just an esthetic thing...
+             OccName
              SrcLoc
 
   | Global   Unique
-             Module	-- original name
-	     (Either
-		FAST_STRING -- just an ordinary M.n name... or...
-		([Either OrigName FAST_STRING]))
-			    -- "dot" these bits of name together...
-             Provenance -- where it came from
-             ExportFlag -- is it exported?
-             [RdrName]  -- ordered occurrence names (usually just one);
-			-- first may be *un*qual.
+	     Module		-- The defining module
+	     OccName		-- Its name in that module
+	     DefnInfo		-- How it is defined
+             Provenance		-- How it was brought into scope
+\end{code}
+
+Things with a @Global@ name are given C static labels, so they finally
+appear in the .o file's symbol table.  They appear in the symbol table
+in the form M.n.  If originally-local things have this property they
+must be made @Global@ first.
+
+\begin{code}
+data DefnInfo =	VanillaDefn 	
+	      | WiredInTyCon TyCon	-- There's a wired-in version
+	      | WiredInId    Id		-- ...ditto...
 
 data Provenance
-  = LocalDef SrcLoc     -- locally defined; give its source location
-			
-  | Imported ExportFlag	-- how it was imported
-	     SrcLoc     -- *original* source location
-             [SrcLoc]   -- any import source location(s)
-
-  | Implicit
-  | Primitive		-- really and truly primitive thing (not
-			-- definable in Haskell)
-  | WiredIn  Bool	-- something defined in Haskell; True <=>
-			-- definition is in the module in question;
-			-- this probably comes from the -fcompiling-prelude=...
-			-- flag.
+  = LocalDef ExportFlag SrcLoc	-- Locally defined
+  | Imported Module SrcLoc	-- Directly imported from M; gives locn of import statement
+  | Implicit			-- Implicitly imported
+\end{code}
+
+Something is "Exported" if it may be mentioned by another module without
+warning.  The crucial thing about Exported things is that they must
+never be dropped as dead code, even if they aren't used in this module.
+Furthermore, being Exported means that we can't see all call sites of the thing.
+
+Exported things include:
+	- explicitly exported Ids, including data constructors, class method selectors
+	- dfuns from instance decls
+
+Being Exported is *not* the same as finally appearing in the .o file's 
+symbol table.  For example, a local Id may be mentioned in an Exported
+Id's unfolding in the interface file, in which case the local Id goes
+out too.
+
+\begin{code}
+data ExportFlag = Exported  | NotExported
 \end{code}
 
 \begin{code}
+mkLocalName    :: Unique -> OccName -> SrcLoc -> Name
 mkLocalName = Local
 
-mkTopLevName   u (OrigName m n) locn exp occs = Global u m (Left n) (LocalDef locn) exp occs
-mkImportedName u (OrigName m n) imp locn imp_locs exp occs = Global u m (Left n) (Imported imp locn imp_locs) exp occs
+mkGlobalName :: Unique -> Module -> OccName -> DefnInfo -> Provenance -> Name
+mkGlobalName = Global
+
+mkSysLocalName :: Unique -> FAST_STRING -> SrcLoc -> Name
+mkSysLocalName uniq str loc = Local uniq (VarOcc str) loc
 
-mkImplicitName :: Unique -> OrigName -> Name
-mkImplicitName u (OrigName m n) = Global u m (Left n) Implicit NotExported []
+mkWiredInIdName :: Unique -> Module -> FAST_STRING -> Id -> Name
+mkWiredInIdName uniq mod occ id 
+  = Global uniq mod (VarOcc occ) (WiredInId id) Implicit
 
-mkPrimitiveName :: Unique -> OrigName -> Name
-mkPrimitiveName u (OrigName m n)  = Global u m (Left n) Primitive NotExported []
+mkWiredInTyConName :: Unique -> Module -> FAST_STRING -> TyCon -> Name
+mkWiredInTyConName uniq mod occ tycon
+  = Global uniq mod (TCOcc occ) (WiredInTyCon tycon) Implicit
 
-mkWiredInName :: Unique -> OrigName -> ExportFlag -> Name
-mkWiredInName u (OrigName m n) exp
-  = Global u m (Left n) (WiredIn from_here) exp []
+
+mkCompoundName :: (FAST_STRING -> FAST_STRING)	-- Occurrence-name modifier
+	       -> Unique			-- New unique
+	       -> Name				-- Base name (must be a Global)
+	       -> Name		-- Result is always a value name
+
+mkCompoundName str_fn uniq (Global _ mod occ defn prov)
+  = Global uniq mod new_occ defn prov
+  where    
+    new_occ = VarOcc (str_fn (occNameString occ))		-- Always a VarOcc
+
+mkCompoundName str_fn uniq (Local _ occ loc)
+  = Local uniq (VarOcc (str_fn (occNameString occ))) loc
+
+	-- Rather a wierd one that's used for names generated for instance decls
+mkInstDeclName :: Unique -> Module -> OccName -> SrcLoc -> Bool -> Name
+mkInstDeclName uniq mod occ loc from_here
+  = Global uniq mod occ VanillaDefn prov
   where
-    from_here
-      = case maybe_CompilingGhcInternals of
-          Nothing  -> False
-	  Just mod -> mod == _UNPK_ m
-
-mkCompoundName :: Unique
-	       -> Module
-	       -> FAST_STRING	-- indicates what kind of compound thing it is (e.g., "sdsel")
-	       -> [Either OrigName FAST_STRING]	-- "dot" these names together
-	       -> Name		-- from which we get provenance, etc....
-	       -> Name		-- result!
-
-mkCompoundName u m str ns (Local _ _ _ locn) -- these arise for workers...
-  = Local u str True{-emph uniq-} locn
-
-mkCompoundName u m str ns (Global _ _ _ prov exp _)
-  = Global u m (Right (Right str : ns)) prov exp []
-
-glue = glue1
-glue1 (Left (OrigName m n):ns) = m : _CONS_ '.' n : glue2 ns
-glue1 (Right n            :ns) = n 		  : glue2 ns
-glue2 []		       = []
-glue2 (Left (OrigName m n):ns) = _CONS_ '.' m : _CONS_ '.' n : glue2 ns
-glue2 (Right n            :ns) = _CONS_ '.' n		     : glue2 ns
-
--- this ugly one is used for instance-y things
-mkCompoundName2 :: Unique
-		-> Module
-		-> FAST_STRING	-- indicates what kind of compound thing it is
-		-> [Either OrigName FAST_STRING] -- "dot" these names together
-		-> Bool		-- True <=> defined in this module
-		-> SrcLoc	
-		-> Name		-- result!
-
-mkCompoundName2 u m str ns from_here locn
-  = Global u m (Right (Right str : ns))
-	     (if from_here then LocalDef locn else Imported ExportAll locn [])
-	     ExportAll{-instances-}
-	     []
-
-mkFunTyConName
-  = mkPrimitiveName funTyConKey		       (OrigName pRELUDE SLIT("->"))
-mkTupleDataConName arity
-  = mkWiredInName (mkTupleDataConUnique arity) (OrigName pRELUDE (mkTupNameStr arity)) ExportAll
-mkTupleTyConName   arity
-  = mkWiredInName (mkTupleTyConUnique   arity) (OrigName pRELUDE (mkTupNameStr arity)) ExportAll
-
-mkTupNameStr 0 = SLIT("()")
-mkTupNameStr 1 = panic "Name.mkTupNameStr: 1 ???"
-mkTupNameStr 2 = _PK_ "(,)"   -- not strictly necessary
-mkTupNameStr 3 = _PK_ "(,,)"  -- ditto
-mkTupNameStr 4 = _PK_ "(,,,)" -- ditto
-mkTupNameStr n
-  = _PK_ ("(" ++ nOfThem (n-1) ',' ++ ")")
-
-	-- ToDo: what about module ???
-	-- ToDo: exported when compiling builtin ???
-
-isLocalName (Local _ _ _ _) = True
-isLocalName _ 		    = False
-
--- things the compiler "knows about" are in some sense
+    prov | from_here = LocalDef Exported loc
+         | otherwise = Implicit
+
+
+setNameProvenance :: Name -> Provenance -> Name		-- Globals only
+setNameProvenance (Global uniq mod occ def _) prov = Global uniq mod occ def prov
+
+-- 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 (Global   _ mod occ def prov) u = Global u mod occ def prov
+
+setNameVisibility :: Module -> Name -> Name
+-- setNameVisibility is applied to top-level names in the final program
+-- The "visibility" here concerns whether the .o file's symbol table
+-- mentions the thing; if so, it needs a module name in its symbol,
+-- otherwise we just use its unique.  The Global things are "visible"
+-- and the local ones are not
+
+setNameVisibility _ (Global uniq mod occ def (LocalDef NotExported loc))
+  | not all_toplev_ids_visible
+  = Local uniq occ loc
+
+setNameVisibility mod (Local uniq occ loc)
+  | all_toplev_ids_visible
+  = Global uniq mod 
+	   (VarOcc (showUnique uniq)) 	-- It's local name must be unique!
+	   VanillaDefn (LocalDef NotExported loc)
+
+setNameVisibility mod name = name
+
+all_toplev_ids_visible = not opt_OmitInterfacePragmas ||  -- Pragmas can make them visible
+			 opt_EnsureSplittableC		  -- Splitting requires visiblilty
+\end{code}
+
+%************************************************************************
+%*									*
+\subsection{Predicates and selectors}
+%*									*
+%************************************************************************
+
+\begin{code}
+nameUnique		:: Name -> Unique
+nameModAndOcc		:: Name -> (Module, OccName)	-- Globals only
+nameOccName		:: Name -> OccName 
+nameString		:: Name -> FAST_STRING		-- A.b form
+nameSrcLoc		:: Name -> SrcLoc
+isLocallyDefinedName	:: Name -> Bool
+isExportedName		:: Name -> Bool
+isWiredInName		:: Name -> Bool
+isLocalName		:: Name -> Bool
+
+
+
+nameUnique (Local  u _ _)   = u
+nameUnique (Global u _ _ _ _) = u
+
+nameOccName (Local _ occ _)      = occ
+nameOccName (Global _ _ occ _ _) = occ
+
+nameModAndOcc (Global _ mod occ _ _) = (mod,occ)
+
+nameString (Local _ occ _)        = occNameString occ
+nameString (Global _ mod occ _ _) = mod _APPEND_ SLIT(".") _APPEND_ occNameString occ
+
+isExportedName (Global _ _ _ _ (LocalDef Exported _)) = True
+isExportedName other			 	      = False
+
+nameSrcLoc (Local _ _ loc)     = loc
+nameSrcLoc (Global _ _ _ _ (LocalDef _ loc)) = loc
+nameSrcLoc (Global _ _ _ _ (Imported _ loc)) = loc
+nameSrcLoc other			     = noSrcLoc
+  
+isLocallyDefinedName (Local  _ _ _)	     	     = True
+isLocallyDefinedName (Global _ _ _ _ (LocalDef _ _)) = True
+isLocallyDefinedName other		             = False
+
+-- Things the compiler "knows about" are in some sense
 -- "imported".  When we are compiling the module where
 -- the entities are defined, we need to be able to pick
 -- them out, often in combination with isLocallyDefined.
-oddlyImportedName (Global _ _ _ Primitive   _ _) = True
-oddlyImportedName (Global _ _ _ (WiredIn _) _ _) = True
-oddlyImportedName _				 = False
+isWiredInName (Global _ _ _ (WiredInTyCon _) _) = True
+isWiredInName (Global _ _ _ (WiredInId    _) _) = True
+isWiredInName _				          = False
+
+maybeWiredInIdName :: Name -> Maybe Id
+maybeWiredInIdName (Global _ _ _ (WiredInId id) _) = Just id
+maybeWiredInIdName other			   = Nothing
+
+maybeWiredInTyConName :: Name -> Maybe TyCon
+maybeWiredInTyConName (Global _ _ _ (WiredInTyCon tc) _) = Just tc
+maybeWiredInTyConName other			         = Nothing
 
-isImplicitName (Global _ _ _ Implicit _ _) = True
-isImplicitName _ 		           = False
+
+isLocalName (Local _ _ _) = True
+isLocalName _ 		  = False
 \end{code}
 
+
 %************************************************************************
 %*									*
 \subsection[Name-instances]{Instance declarations}
@@ -337,10 +362,10 @@ isImplicitName _ 		           = False
 \begin{code}
 cmpName n1 n2 = c n1 n2
   where
-    c (Local  u1 _ _ _)     (Local  u2 _ _ _)     = cmp u1 u2
-    c (Local   _ _ _ _)	    _			  = LT_
-    c (Global u1 _ _ _ _ _) (Global u2 _ _ _ _ _) = cmp u1 u2
-    c (Global  _ _ _ _ _ _) _			  = GT_
+    c (Local  u1 _ _)   (Local  u2 _ _)       = cmp u1 u2
+    c (Local   _ _ _)	  _		      = LT_
+    c (Global u1 _ _ _ _) (Global u2 _ _ _ _) = cmp u1 u2
+    c (Global  _ _ _ _ _)   _		      = GT_
 \end{code}
 
 \begin{code}
@@ -364,123 +389,74 @@ instance NamedThing Name where
     getName n = n
 \end{code}
 
-\begin{code}
-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 b l)    u = Local u n b l
-changeUnique (Global   _ m n p e os) u = Global u m n p e os
-
-nameOrigName msg (Global _ m (Left  n) _ _ _) = OrigName m n
-nameOrigName msg (Global _ m (Right n) _ _ _) = let str = _CONCAT_ (glue n) in
-						--pprTrace ("nameOrigName:"++msg) (ppPStr str) $
-						OrigName m str
-#ifdef DEBUG
-nameOrigName msg (Local  _ n _ _)     = panic ("nameOrigName:Local:"++msg++":"++ _UNPK_ n)
-#endif
-
-nameOccName (Local  _ n _ _)	     = Unqual n
-nameOccName (Global _ m (Left  n) _ _ []  )  = Qual m n
-nameOccName (Global _ m (Right n) _ _ []  )  =  let str = _CONCAT_ (glue n) in
-						--pprTrace "nameOccName:" (ppPStr str) $
-						Qual m str
-nameOccName (Global _ m (Left  _) _ _ (o:_)) = o
-nameOccName (Global _ m (Right _) _ _ (o:_)) = panic "nameOccName:compound name"
-
-nameExportFlag (Local  _ _ _ _)       = NotExported
-nameExportFlag (Global _ _ _ _ exp _) = exp
-
-nameSrcLoc (Local  _ _ _ loc)	                 = loc
-nameSrcLoc (Global _ _ _ (LocalDef loc)     _ _) = loc
-nameSrcLoc (Global _ _ _ (Imported _ loc _) _ _) = loc
-nameSrcLoc (Global _ _ _ Implicit           _ _) = mkUnknownSrcLoc
-nameSrcLoc (Global _ _ _ Primitive          _ _) = mkBuiltinSrcLoc
-nameSrcLoc (Global _ _ _ (WiredIn _)        _ _) = mkBuiltinSrcLoc
-  
-nameImpLocs (Global _ _ _ (Imported _ _ locs) _ _) = locs
-nameImpLocs _ 					   = []
-
-nameImportFlag (Local  _ _ _ _)                      = NotExported
-nameImportFlag (Global _ _ _ (LocalDef _)       _ _) = ExportAll
-nameImportFlag (Global _ _ _ (Imported exp _ _) _ _) = exp
-nameImportFlag (Global _ _ _ Implicit           _ _) = ExportAll
-nameImportFlag (Global _ _ _ Primitive          _ _) = ExportAll
-nameImportFlag (Global _ _ _ (WiredIn _)        _ _) = ExportAll
-
-isLocallyDefinedName (Local  _ _ _ _)	            	    = True
-isLocallyDefinedName (Global _ _ _ (LocalDef _)        _ _) = True
-isLocallyDefinedName (Global _ _ _ (Imported _ _ _)    _ _) = False
-isLocallyDefinedName (Global _ _ _ Implicit            _ _) = False
-isLocallyDefinedName (Global _ _ _ Primitive           _ _) = False
-isLocallyDefinedName (Global _ _ _ (WiredIn from_here) _ _) = from_here
-
-isWiredInName (Global _ _ _ (WiredIn _) _ _) = True
-isWiredInName _				     = False
-\end{code}
+
+%************************************************************************
+%*									*
+\subsection{Pretty printing}
+%*									*
+%************************************************************************
 
 \begin{code}
 instance Outputable Name where
-    ppr sty (Local u n emph_uniq _)
-      | codeStyle sty = pprUnique u
-      | emph_uniq     = ppBesides [pprUnique u, ppStr "{-", ppPStr n, ppStr "-}"]
-      | otherwise     = ppBesides [ppPStr n, ppStr "{-", pprUnique u, ppStr "-}"]
-
-    ppr PprDebug   (Global   u m (Left  n) _ _ _) = ppBesides [pp_mod PprDebug m, pp_name  PprDebug n, ppStr "{-", pprUnique u, ppStr "-}"]
-    ppr PprDebug   (Global   u m (Right n) _ _ _) = ppBesides [pp_mod PprDebug m, pp_name2 PprDebug n, ppStr "{-", pprUnique u, ppStr "-}"]
-
-    ppr PprForUser (Global   u m (Left  n) _ _ []  ) = ppBeside (pp_mod PprForUser m) (pp_name  PprForUser n)
-    ppr PprForUser (Global   u m (Right n) _ _ []  ) = ppBeside (pp_mod PprForUser m) (pp_name2 PprForUser n)
-    ppr PprForUser (Global   u m (Left  _) _ _ occs) = ppr PprForUser (head occs)
-
--- LATER:?
---  ppr PprShowAll (Global   u m n prov exp occs) = pp_all (Qual m n) prov exp occs
-
-    ppr sty (Global u m (Left  n) _ _ _) = ppBeside (pp_mod sty m) (pp_name  sty n)
-    ppr sty (Global u m (Right n) _ _ _) = ppBeside (pp_mod sty m) (pp_name2 sty n)
-
-pp_all orig prov exp occs
-  = ppBesides [ppr PprShowAll orig, ppr PprShowAll occs, pp_prov prov, pp_exp exp]
-
-pp_exp NotExported = ppNil
-pp_exp ExportAll   = ppPStr SLIT("/EXP(..)")
-pp_exp ExportAbs   = ppPStr SLIT("/EXP")
-
-pp_prov Implicit    = ppPStr SLIT("/IMPLICIT")
-pp_prov Primitive   = ppPStr SLIT("/PRIMITIVE")
-pp_prov (WiredIn _) = ppPStr SLIT("/WIREDIN")
-pp_prov _           = ppNil
+    ppr sty (Local u n _) | codeStyle sty ||
+			    ifaceStyle sty = pprUnique u
+			  | otherwise      = ppBesides [ppPStr (occNameString n), ppPStr SLIT("_"), pprUnique u]
+
+    ppr sty (Global u m n _ _) = ppBesides [pp_name, pp_uniq sty u]
+			       where
+				 pp_name | codeStyle sty = identToC qual_name
+				         | otherwise     = ppPStr qual_name
+				 qual_name = m _APPEND_ SLIT(".") _APPEND_ occNameString n
+
+pp_uniq PprDebug uniq = ppBesides [ppStr "{-", pprUnique uniq, ppStr "-}"]
+pp_uniq other    uniq = ppNil
+
+-- pprNameProvenance is used in error messages to say where a name came from
+pprNameProvenance :: PprStyle -> Name -> Pretty
+pprNameProvenance sty (Local _ _ loc)       = pprProvenance sty (LocalDef NotExported loc)
+pprNameProvenance sty (Global _ _ _ _ prov) = pprProvenance sty prov
+
+pprProvenance :: PprStyle -> Provenance -> Pretty
+pprProvenance sty (Imported mod loc)
+  = ppSep [ppStr "Imported from", pprModule sty mod, ppStr "at", ppr sty loc]
+pprProvenance sty (LocalDef _ loc) 
+  = ppSep [ppStr "Defined at", ppr sty loc]
+pprProvenance sty Implicit
+  = panic "pprNameProvenance: Implicit"
 \end{code}
 
+
 %************************************************************************
 %*									*
-\subsection[ExportFlag-datatype]{The @ExportFlag@ datatype}
+\subsection[Sets of names}
 %*									*
 %************************************************************************
 
-The export flag @ExportAll@ means `export all there is', so there are
-times when it is attached to a class or data type which has no
-ops/constructors (if the class/type was imported abstractly).  In
-fact, @ExportAll@ is attached to everything except to classes/types
-which are being {\em exported} abstractly, regardless of how they were
-imported.
-
 \begin{code}
-data ExportFlag
-  = ExportAll		-- export with all constructors/methods
-  | ExportAbs		-- export abstractly (tycons/classes only)
-  | NotExported
+type NameSet = UniqSet Name
+emptyNameSet	  :: NameSet
+unitNameSet	  :: Name -> NameSet
+addListToNameSet  :: NameSet -> [Name] -> NameSet
+mkNameSet         :: [Name] -> NameSet
+unionNameSets	  :: NameSet -> NameSet -> NameSet
+unionManyNameSets :: [NameSet] -> NameSet
+minusNameSet 	  :: NameSet -> NameSet -> NameSet
+elemNameSet	  :: Name -> NameSet -> Bool
+nameSetToList	  :: NameSet -> [Name]
+
+emptyNameSet	  = emptyUniqSet
+unitNameSet	  = unitUniqSet
+mkNameSet         = mkUniqSet
+addListToNameSet  = addListToUniqSet
+unionNameSets     = unionUniqSets
+unionManyNameSets = unionManyUniqSets
+minusNameSet	  = minusUniqSet
+elemNameSet       = elementOfUniqSet
+nameSetToList     = uniqSetToList
+\end{code}
 
-exportFlagOn NotExported = False
-exportFlagOn _		 = True
 
--- Be very wary about using "isExported"; perhaps you
--- really mean "externallyVisibleId"?
-
-isExported a = exportFlagOn (getExportFlag a)
-\end{code}
 
 %************************************************************************
 %*									*
@@ -490,140 +466,30 @@ isExported a = exportFlagOn (getExportFlag a)
 
 \begin{code}
 class NamedThing a where
-    getName :: a -> Name
+    getOccName :: a -> OccName		-- Even RdrNames can do this!
+    getName    :: a -> Name
+
+    getOccName n = nameOccName (getName n)	-- Default method
 \end{code}
 
 \begin{code}
-origName	    :: NamedThing a => String -> a -> OrigName
-moduleOf	    :: OrigName -> Module
-nameOf		    :: OrigName -> FAST_STRING
-
-getOccName	    :: NamedThing a => a -> RdrName
-getLocalName	    :: NamedThing a => a -> FAST_STRING
-getExportFlag	    :: NamedThing a => a -> ExportFlag
+modAndOcc	    :: NamedThing a => a -> (Module, OccName)
 getSrcLoc	    :: NamedThing a => a -> SrcLoc
-getImpLocs	    :: NamedThing a => a -> [SrcLoc]
 isLocallyDefined    :: NamedThing a => a -> Bool
+isExported	    :: NamedThing a => a -> Bool
+getOccString	    :: NamedThing a => a -> String
 
-origName str n	    = nameOrigName str (getName n)
-
-moduleOf (OrigName m n) = m
-nameOf   (OrigName m n) = n
-
-getLocalName n
-  = case (getName n) of
-      Local  _ n _ _	         -> n
-      Global _ m (Left  n) _ _ _ -> n
-      Global _ m (Right n) _ _ _ -> let str = _CONCAT_ (glue n) in
-				    -- pprTrace "getLocalName:" (ppPStr str) $
-				    str
-
-getOccName	    = nameOccName  	   . getName
-getExportFlag	    = nameExportFlag	   . getName
+modAndOcc	    = nameModAndOcc	   . getName
+isExported	    = isExportedName 	   . getName
 getSrcLoc	    = nameSrcLoc	   . getName
-getImpLocs	    = nameImpLocs	   . getName
 isLocallyDefined    = isLocallyDefinedName . getName
+pprSym sty	    = pprSymOcc sty        . getOccName
+pprNonSym sty	    = pprNonSymOcc sty     . getOccName
+getOccString x	    = _UNPK_ (occNameString (getOccName x))
 \end{code}
 
 \begin{code}
-{-# SPECIALIZE getLocalName
-	:: Name     -> FAST_STRING
-	 , OrigName -> FAST_STRING
-	 , RdrName  -> FAST_STRING
-	 , RnName   -> FAST_STRING
-  #-}
 {-# SPECIALIZE isLocallyDefined
 	:: Name	    -> Bool
-	 , RnName   -> Bool
-  #-}
-{-# SPECIALIZE origName
-	:: String -> Name     -> OrigName
-	 , String -> RdrName  -> OrigName
-	 , String -> RnName   -> OrigName
   #-}
 \end{code}
-
-These functions test strings to see if they fit the lexical categories
-defined in the Haskell report.  Normally applied as in e.g. @isCon
-(getLocalName foo)@.
-
-\begin{code}
-isLexCon, isLexVar, isLexId, isLexSym, isLexConId, isLexConSym,
- isLexVarId, isLexVarSym, isLexSpecialSym :: FAST_STRING -> Bool
-
-isLexCon cs = isLexConId  cs || isLexConSym cs
-isLexVar cs = isLexVarId  cs || isLexVarSym cs
-
-isLexId  cs = isLexConId  cs || isLexVarId  cs
-isLexSym cs = isLexConSym cs || isLexVarSym cs
-
--------------
-
-isLexConId cs
-  | _NULL_ cs	= False
-  | otherwise	= isUpper c || isUpperISO c
-  where					
-    c = _HEAD_ cs
-
-isLexVarId cs
-  | _NULL_ cs	 = False
-  | otherwise    = isLower c || isLowerISO c
-  where
-    c = _HEAD_ cs
-
-isLexConSym cs
-  | _NULL_ cs	= False
-  | otherwise	= c  == ':'
---	       || c  == '('	-- (), (,), (,,), ...
-	       || cs == SLIT("->")
---	       || cs == SLIT("[]")
-  where
-    c = _HEAD_ cs
-
-isLexVarSym cs
-  | _NULL_ cs = False
-  | otherwise = isSymbolASCII c
-	     || isSymbolISO c
---	     || c  == '('	-- (), (,), (,,), ...
---	     || cs == SLIT("[]")
-  where
-    c = _HEAD_ cs
-
-isLexSpecialSym cs
-  | _NULL_ cs = False
-  | otherwise = c  == '('	-- (), (,), (,,), ...
-	     || cs == SLIT("[]")
-  where
-    c = _HEAD_ cs
-
--------------
-isSymbolASCII c = c `elem` "!#$%&*+./<=>?@\\^|~-"
-isSymbolISO   c = ord c `elem` (0xd7 : 0xf7 : [0xa1 .. 0xbf])
-isUpperISO    c = 0xc0 <= oc && oc <= 0xde && oc /= 0xd7 where oc = ord c
-isLowerISO    c = 0xdf <= oc && oc <= 0xff && oc /= 0xf7 where oc = ord c
-\end{code}
-
-And one ``higher-level'' interface to those:
-
-\begin{code}
-isSymLexeme :: NamedThing a => a -> Bool
-
-isSymLexeme v
-  = let str = getLocalName v in isLexSym str
-
--- print `vars`, (op) correctly
-pprSym, pprNonSym :: (NamedThing name, Outputable name) => PprStyle -> name -> Pretty
-
-pprSym sty var
-  = let
-	str = getLocalName var
-    in
-    if isLexSym str && not (isLexSpecialSym str)
-    then ppr sty var
-    else ppBesides [ppChar '`', ppr sty var, ppChar '`']
-
-pprNonSym sty var
-  = if isSymLexeme var
-    then ppParens (ppr sty var)
-    else ppr sty var
-\end{code}
diff --git a/ghc/compiler/basicTypes/PprEnv.lhs b/ghc/compiler/basicTypes/PprEnv.lhs
index a2af9ac9b6..eee6ee9681 100644
--- a/ghc/compiler/basicTypes/PprEnv.lhs
+++ b/ghc/compiler/basicTypes/PprEnv.lhs
@@ -12,7 +12,7 @@ module PprEnv (
 	initPprEnv,
 
 	pCon, pLit, pMajBndr, pMinBndr, pOcc, pPrim, pSCC, pStyle,
-	pTy, pTyVar, pUVar, pUse,
+	pTy, pTyVarB, pTyVarO, pUVar, pUse,
 	
 	NmbrEnv(..),
 	SYN_IE(NmbrM), initNmbr,
@@ -45,7 +45,9 @@ data PprEnv tyvar uvar bndr occ
 	(PrimOp     -> Pretty)
 	(CostCentre -> Pretty)
 
-	(tyvar -> Pretty)	-- to print tyvars
+	(tyvar -> Pretty)	-- to print tyvar binders
+	(tyvar -> Pretty)	-- to print tyvar occurrences
+
 	(uvar -> Pretty)	-- to print usage vars
 
 	(bndr -> Pretty)	-- to print "major" val_bdrs
@@ -64,6 +66,7 @@ initPprEnv
 	-> Maybe (PrimOp  -> Pretty)
 	-> Maybe (CostCentre -> Pretty)
 	-> Maybe (tyvar -> Pretty)
+	-> Maybe (tyvar -> Pretty)
 	-> Maybe (uvar -> Pretty)
 	-> Maybe (bndr -> Pretty)
 	-> Maybe (bndr -> Pretty)
@@ -75,13 +78,14 @@ initPprEnv
 -- you can specify all the printers individually; if
 -- you don't specify one, you get bottom
 
-initPprEnv sty l d p c tv uv maj_bndr min_bndr occ ty use
+initPprEnv sty l d p c tvb tvo uv maj_bndr min_bndr occ ty use
   = PE sty
        (demaybe l)
        (demaybe d)
        (demaybe p)
        (demaybe c)
-       (demaybe tv)
+       (demaybe tvb)
+       (demaybe tvo)
        (demaybe uv)
        (demaybe maj_bndr)
        (demaybe min_bndr)
@@ -112,21 +116,22 @@ initPprEnv sty pmaj pmin pocc
 \end{code}
 
 \begin{code}
-pStyle	 (PE s  _  _  _  _  _  _  _  _  _  _  _) = s
-pLit	 (PE _ pp  _  _  _  _  _  _  _  _  _  _) = pp
-pCon	 (PE _	_ pp  _  _  _  _  _  _  _  _  _) = pp
-pPrim	 (PE _	_  _ pp  _  _  _  _  _  _  _  _) = pp
-pSCC	 (PE _	_  _  _ pp  _  _  _  _  _  _  _) = pp
-	     				       
-pTyVar	 (PE _	_  _  _  _ pp  _  _  _  _  _  _) = pp
-pUVar	 (PE _	_  _  _  _  _ pp  _  _  _  _  _) = pp
-      	     				       
-pMajBndr (PE _	_  _  _  _  _  _ pp  _  _  _  _) = pp
-pMinBndr (PE _	_  _  _  _  _  _  _ pp  _  _  _) = pp
-pOcc     (PE _	_  _  _  _  _  _  _  _ pp  _  _) = pp
-	     		       
-pTy      (PE _	_  _  _  _  _  _  _  _  _ pp  _) = pp
-pUse	 (PE _	_  _  _  _  _  _  _  _  _  _ pp) = pp
+pStyle	 (PE s  _  _  _  _  _  _  _  _  _  _  _  _) = s
+pLit	 (PE _ pp  _  _  _  _  _  _  _  _  _  _  _) = pp
+pCon	 (PE _	_ pp  _  _  _  _  _  _  _  _  _  _) = pp
+pPrim	 (PE _	_  _ pp  _  _  _  _  _  _  _  _  _) = pp
+pSCC	 (PE _	_  _  _ pp  _  _  _  _  _  _  _  _) = pp
+	     					 
+pTyVarB	 (PE _	_  _  _  _  pp _  _  _  _  _  _  _) = pp
+pTyVarO	 (PE _	_  _  _  _  _  pp _  _  _  _  _  _) = pp
+pUVar	 (PE _	_  _  _  _  _  _  pp _  _  _  _  _) = pp
+      	     					 
+pMajBndr (PE _	_  _  _  _  _  _  _ pp  _  _  _  _) = pp
+pMinBndr (PE _	_  _  _  _  _  _  _  _ pp  _  _  _) = pp
+pOcc     (PE _	_  _  _  _  _  _  _  _  _ pp  _  _) = pp
+	     		       	 
+pTy      (PE _	_  _  _  _  _  _  _  _  _  _ pp  _) = pp
+pUse	 (PE _	_  _  _  _  _  _  _  _  _  _  _ pp) = pp
 \end{code}
 
 We tend to {\em renumber} everything before printing, so that
diff --git a/ghc/compiler/basicTypes/SrcLoc.lhs b/ghc/compiler/basicTypes/SrcLoc.lhs
index e12b0db105..f4a3b2b388 100644
--- a/ghc/compiler/basicTypes/SrcLoc.lhs
+++ b/ghc/compiler/basicTypes/SrcLoc.lhs
@@ -11,15 +11,17 @@
 #include "HsVersions.h"
 
 module SrcLoc (
-	SrcLoc,			-- abstract
+	SrcLoc,			-- Abstract
+
+	mkSrcLoc,
+	noSrcLoc, isNoSrcLoc,	-- "I'm sorry, I haven't a clue"
 
-	mkSrcLoc, mkSrcLoc2,	-- the usual
-	mkUnknownSrcLoc,	-- "I'm sorry, I haven't a clue"
 	mkIfaceSrcLoc,		-- Unknown place in an interface
 				-- (this one can die eventually ToDo)
-	mkBuiltinSrcLoc,	-- something wired into the compiler
-	mkGeneratedSrcLoc,	-- code generated within the compiler
-	unpackSrcLoc
+
+	mkBuiltinSrcLoc,	-- Something wired into the compiler
+
+	mkGeneratedSrcLoc	-- Code generated within the compiler
     ) where
 
 IMP_Ubiq()
@@ -38,10 +40,12 @@ We keep information about the {\em definition} point for each entity;
 this is the obvious stuff:
 \begin{code}
 data SrcLoc
-  = SrcLoc	FAST_STRING	-- source file name
-		FAST_STRING	-- line number in source file
-  | SrcLoc2	FAST_STRING	-- same, but w/ an Int line#
+  = NoSrcLoc
+
+  | SrcLoc	FAST_STRING	-- A precise location
 		FAST_INT
+
+  | UnhelpfulSrcLoc FAST_STRING	-- Just a general indication
 \end{code}
 
 Note that an entity might be imported via more than one route, and
@@ -57,15 +61,15 @@ rare case.
 
 Things to make 'em:
 \begin{code}
-mkSrcLoc	    = SrcLoc
-mkSrcLoc2 x IBOX(y) = SrcLoc2 x y
-mkUnknownSrcLoc	    = SrcLoc SLIT("<unknown>") SLIT("<unknown>")
-mkIfaceSrcLoc	    = SrcLoc SLIT("<an interface file>") SLIT("<unknown>")
-mkBuiltinSrcLoc	    = SrcLoc SLIT("<built-into-the-compiler>") SLIT("<none>")
-mkGeneratedSrcLoc   = SrcLoc SLIT("<compiler-generated-code>") SLIT("<none>")
-
-unpackSrcLoc (SrcLoc  src_file src_line) = (src_file, src_line)
-unpackSrcLoc (SrcLoc2 src_file src_line) = (src_file, _PK_ (show IBOX(src_line)))
+noSrcLoc	    = NoSrcLoc
+mkSrcLoc x IBOX(y)  = SrcLoc x y
+
+mkIfaceSrcLoc	    = UnhelpfulSrcLoc SLIT("<an interface file>")
+mkBuiltinSrcLoc	    = UnhelpfulSrcLoc SLIT("<built-into-the-compiler>")
+mkGeneratedSrcLoc   = UnhelpfulSrcLoc SLIT("<compiler-generated-code>")
+
+isNoSrcLoc NoSrcLoc = True
+isNoSrcLoc other    = False
 \end{code}
 
 %************************************************************************
@@ -77,12 +81,13 @@ unpackSrcLoc (SrcLoc2 src_file src_line) = (src_file, _PK_ (show IBOX(src_line))
 \begin{code}
 instance Outputable SrcLoc where
     ppr PprForUser (SrcLoc src_file src_line)
-      = ppBesides [ ppChar '"', ppPStr src_file, ppStr "\", line ", ppPStr src_line ]
+      = ppBesides [ ppPStr src_file, ppStr ": ", ppStr (show IBOX(src_line)) ]
 
     ppr sty (SrcLoc src_file src_line)
-      = ppBesides [ppPStr SLIT("{-# LINE "), ppPStr src_line, ppSP,
+      = ppBesides [ppPStr SLIT("{-# LINE "), ppStr (show IBOX(src_line)), ppSP,
 		   ppChar '"', ppPStr src_file, ppPStr SLIT("\" #-}")]
 
-    ppr sty (SrcLoc2 src_file src_line)
-      = ppr sty (SrcLoc src_file (_PK_ (show IBOX(src_line))))
+    ppr sty (UnhelpfulSrcLoc s) = ppPStr s
+
+    ppr sty NoSrcLoc = ppStr "<NoSrcLoc>"
 \end{code}
diff --git a/ghc/compiler/basicTypes/UniqSupply.lhs b/ghc/compiler/basicTypes/UniqSupply.lhs
index 3cb2ca724e..564110750b 100644
--- a/ghc/compiler/basicTypes/UniqSupply.lhs
+++ b/ghc/compiler/basicTypes/UniqSupply.lhs
@@ -13,7 +13,7 @@ module UniqSupply (
 	getUnique, getUniques,	-- basic ops
 
 	SYN_IE(UniqSM),		-- type: unique supply monad
-	initUs, thenUs, returnUs,
+	initUs, thenUs, returnUs, fixUs,
 	mapUs, mapAndUnzipUs, mapAndUnzip3Us,
 	thenMaybeUs, mapAccumLUs,
 
@@ -147,6 +147,10 @@ initUs init_us m
 
 @thenUs@ is where we split the @UniqSupply@.
 \begin{code}
+fixUs :: (a -> UniqSM a) -> UniqSM a
+fixUs m us
+  = r  where  r = m r us
+
 thenUs :: UniqSM a -> (a -> UniqSM b) -> UniqSM b
 
 thenUs expr cont us
diff --git a/ghc/compiler/basicTypes/Unique.lhs b/ghc/compiler/basicTypes/Unique.lhs
index 104953adca..0d4fb49436 100644
--- a/ghc/compiler/basicTypes/Unique.lhs
+++ b/ghc/compiler/basicTypes/Unique.lhs
@@ -87,6 +87,7 @@ module Unique (
 	foreignObjTyConKey,
 	forkIdKey,
 	fractionalClassKey,
+	fromEnumClassOpKey,
 	fromIntClassOpKey,
 	fromIntegerClassOpKey,
 	fromRationalClassOpKey,
@@ -212,6 +213,7 @@ module Unique (
 	, parAtRelIdKey
 	, parGlobalIdKey
 	, parLocalIdKey
+	, unboundKey
     ) where
 
 import PreludeGlaST
@@ -664,4 +666,7 @@ eqClassOpKey		= mkPreludeMiscIdUnique 60
 geClassOpKey		= mkPreludeMiscIdUnique 61
 zeroClassOpKey		= mkPreludeMiscIdUnique 62
 thenMClassOpKey		= mkPreludeMiscIdUnique 63 -- (>>=)
+unboundKey		= mkPreludeMiscIdUnique 64	-- Just a place holder for unbound
+							-- variables produced by the renamer
+fromEnumClassOpKey	= mkPreludeMiscIdUnique 65
 \end{code}
diff --git a/ghc/compiler/codeGen/CgBindery.lhs b/ghc/compiler/codeGen/CgBindery.lhs
index 6e0c8bdf4a..684e2bc944 100644
--- a/ghc/compiler/codeGen/CgBindery.lhs
+++ b/ghc/compiler/codeGen/CgBindery.lhs
@@ -44,7 +44,7 @@ import Id		( idPrimRep, toplevelishId, isDataCon,
 			  GenId{-instance NamedThing-}
 			)
 import Maybes		( catMaybes )
-import Name		( isLocallyDefined, oddlyImportedName, Name{-instance NamedThing-} )
+import Name		( isLocallyDefined, isWiredInName, Name{-instance NamedThing-} )
 #ifdef DEBUG
 import PprAbsC		( pprAmode )
 #endif
@@ -195,8 +195,8 @@ I {\em think} all looking-up is done through @getCAddrMode(s)@.
 getCAddrModeAndInfo :: Id -> FCode (CAddrMode, LambdaFormInfo)
 
 getCAddrModeAndInfo id
-  | not (isLocallyDefined name) || oddlyImportedName name
-    {- Why the "oddlyImported"?
+  | not (isLocallyDefined name) || isWiredInName name
+    {- Why the "isWiredInName"?
 	Imagine you are compiling GHCbase.hs (a module that
 	supplies some of the wired-in values).  What can
 	happen is that the compiler will inject calls to
diff --git a/ghc/compiler/codeGen/CgClosure.lhs b/ghc/compiler/codeGen/CgClosure.lhs
index d0f9bf808c..5d06570679 100644
--- a/ghc/compiler/codeGen/CgClosure.lhs
+++ b/ghc/compiler/codeGen/CgClosure.lhs
@@ -26,7 +26,7 @@ import CgBindery	( getCAddrMode, getArgAmodes,
 			  bindNewToReg, bindArgsToRegs,
 			  stableAmodeIdInfo, heapIdInfo, CgIdInfo
 			)
-import CgCompInfo	( spARelToInt, spBRelToInt )
+import Constants	( spARelToInt, spBRelToInt )
 import CgUpdate		( pushUpdateFrame )
 import CgHeapery	( allocDynClosure, heapCheck
 			  , heapCheckOnly, fetchAndReschedule, yield  -- HWL
@@ -41,7 +41,7 @@ import CgUsages		( getVirtSps, setRealAndVirtualSps,
 			  getSpARelOffset, getSpBRelOffset,
 			  getHpRelOffset
 			)
-import CLabel		( mkClosureLabel, mkConUpdCodePtrVecLabel,
+import CLabel		( mkClosureLabel, mkConUpdCodePtrVecLabel, mkFastEntryLabel,
 			  mkStdUpdCodePtrVecLabel, mkStdUpdVecTblLabel,
 			  mkErrorStdEntryLabel, mkRednCountsLabel
 			)
@@ -313,7 +313,8 @@ cgVapInfoTable perhaps_bind_the_fun upd_flag fun args fun_in_payload fun_lf_info
 	-- If f is not top-level, then f is one of the free variables too,
 	-- hence "payload_ids" isn't the same as "arg_ids".
 	--
-	vap_entry_rhs = StgApp (StgVarArg fun) (map StgVarArg args) emptyIdSet
+	stg_args      = map StgVarArg args
+	vap_entry_rhs = StgApp (StgVarArg fun) stg_args emptyIdSet
 									-- Empty live vars
 
 	arg_ids_w_info = [(name,mkLFArgument) | name <- args]
@@ -323,8 +324,7 @@ cgVapInfoTable perhaps_bind_the_fun upd_flag fun args fun_in_payload fun_lf_info
 	payload_ids | fun_in_payload = fun : args		-- Sigh; needed for mkClosureLFInfo
 		    | otherwise	     = args
 
-	vap_lf_info   = mkClosureLFInfo False {-not top level-} payload_ids
-					upd_flag [] vap_entry_rhs
+	vap_lf_info   = mkVapLFInfo payload_ids upd_flag fun stg_args fun_in_payload
 		-- It's not top level, even if we're currently compiling a top-level
 		-- function, because any VAP *use* of this function will be for a
 		-- local thunk, thus
@@ -434,10 +434,6 @@ closureCodeBody binder_info closure_info cc all_args body
   = getEntryConvention id lf_info
 		       (map idPrimRep all_args)		`thenFC` \ entry_conv ->
     let
-	is_concurrent = opt_ForConcurrent
-
-	stg_arity = length all_args
-
 	-- Arg mapping for standard (slow) entry point; all args on stack
     	(spA_all_args, spB_all_args, all_bxd_w_offsets, all_ubxd_w_offsets)
 	   = mkVirtStkOffsets
@@ -510,8 +506,12 @@ closureCodeBody binder_info closure_info cc all_args body
 		    mkIntCLit spA_stk_args,	-- # passed on A stk
 		    mkIntCLit spB_stk_args,	-- B stk (rest in regs)
 		    CString (_PK_ (map (showTypeCategory . idType) all_args)),
-		    CString (_PK_ (show_wrapper_name wrapper_maybe)),
-		    CString (_PK_ (show_wrapper_arg_kinds wrapper_maybe))
+		    CString SLIT(""), CString SLIT("")
+
+-- Nuked for now; see comment at end of file
+--		    CString (_PK_ (show_wrapper_name wrapper_maybe)),
+--		    CString (_PK_ (show_wrapper_arg_kinds wrapper_maybe))
+
 		]			`thenC`
 
 		-- Bind args to regs/stack as appropriate, and
@@ -544,6 +544,8 @@ closureCodeBody binder_info closure_info cc all_args body
 	CCodeBlock fast_label fast_abs_c
     )
   where
+    is_concurrent = opt_ForConcurrent
+    stg_arity = length all_args
     lf_info = closureLFInfo closure_info
 
     cl_descr mod_name = closureDescription mod_name id all_args body
@@ -554,11 +556,10 @@ closureCodeBody binder_info closure_info cc all_args body
 
 	-- Manufacture labels
     id	       = closureId closure_info
+    fast_label = mkFastEntryLabel id stg_arity
+    stdUpd     = CLbl mkErrorStdEntryLabel CodePtrRep
 
-    fast_label = fastLabelFromCI closure_info
-
-    stdUpd = CLbl mkErrorStdEntryLabel CodePtrRep
-
+{- OLD... see note at end of file
     wrapper_maybe = get_ultimate_wrapper Nothing id
       where
     	get_ultimate_wrapper deflt x -- walk all the way up a "wrapper chain"
@@ -574,6 +575,7 @@ closureCodeBody binder_info closure_info cc all_args body
       = case (getWrapperArgTypeCategories (idType xx) (getIdStrictness xx)) of
 	  Nothing  -> ""
 	  Just str -> str
+-}
 \end{code}
 
 For lexically scoped profiling we have to load the cost centre from
@@ -943,3 +945,46 @@ chooseDynCostCentres cc args fvs body
     in
     (use_cc, blame_cc)
 \end{code}
+
+
+
+========================================================================
+OLD CODE THAT EMITTED INFORMATON FOR QUANTITATIVE ANALYSIS
+
+It's pretty wierd, so I've nuked it for now.  SLPJ Nov 96
+
+\begin{pseudocode}
+getWrapperArgTypeCategories
+	:: Type				-- wrapper's type
+	-> StrictnessInfo bdee		-- strictness info about its args
+	-> Maybe String
+
+getWrapperArgTypeCategories _ NoStrictnessInfo	    = Nothing
+getWrapperArgTypeCategories _ BottomGuaranteed
+  = trace "getWrapperArgTypeCategories:BottomGuaranteed!" Nothing  -- wrong
+getWrapperArgTypeCategories _ (StrictnessInfo [] _) = Nothing
+
+getWrapperArgTypeCategories ty (StrictnessInfo arg_info _)
+  = Just (mkWrapperArgTypeCategories ty arg_info)
+
+mkWrapperArgTypeCategories
+	:: Type		-- wrapper's type
+	-> [Demand]	-- info about its arguments
+	-> String	-- a string saying lots about the args
+
+mkWrapperArgTypeCategories wrapper_ty wrap_info
+  = 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'
+    do_one (WwEnum, _) = 'E'
+    do_one (WwStrict, arg_ty_char) = arg_ty_char
+    do_one (WwUnpack _, arg_ty_char)
+      = if arg_ty_char `elem` "CIJFDTS"
+	then toLower arg_ty_char
+	else if arg_ty_char == '+' then 't'
+	else trace ("mkWrapp..:funny char:"++[arg_ty_char]) '-'
+    do_one (other_wrap_info, _) = '-'
+\end{pseudocode}
+
diff --git a/ghc/compiler/codeGen/CgCompInfo.lhs b/ghc/compiler/codeGen/CgCompInfo.lhs
index 561f8bf477..a7e72a0970 100644
--- a/ghc/compiler/codeGen/CgCompInfo.lhs
+++ b/ghc/compiler/codeGen/CgCompInfo.lhs
@@ -11,9 +11,10 @@
 #include "HsVersions.h"
 
 module CgCompInfo (
-	uNFOLDING_USE_THRESHOLD,
-	uNFOLDING_CREATION_THRESHOLD,
-	uNFOLDING_OVERRIDE_THRESHOLD,
+--	uNFOLDING_USE_THRESHOLD,
+--	uNFOLDING_CREATION_THRESHOLD,
+--	uNFOLDING_OVERRIDE_THRESHOLD,
+	iNTERFACE_UNFOLD_THRESHOLD,
 	uNFOLDING_CHEAP_OP_COST,
 	uNFOLDING_DEAR_OP_COST,
 	uNFOLDING_NOREP_LIT_COST,
@@ -79,9 +80,11 @@ import Util
 
 All pretty arbitrary:
 \begin{code}
-uNFOLDING_USE_THRESHOLD	      = ( 3 :: Int)
-uNFOLDING_CREATION_THRESHOLD  = (30 :: Int)
-uNFOLDING_OVERRIDE_THRESHOLD  = ( 8 :: Int)
+-- uNFOLDING_USE_THRESHOLD	      = ( 3 :: Int)
+-- uNFOLDING_CREATION_THRESHOLD  = (30 :: Int)
+-- uNFOLDING_OVERRIDE_THRESHOLD  = ( 8 :: Int)
+
+iNTERFACE_UNFOLD_THRESHOLD    = (30 :: Int)
 uNFOLDING_CHEAP_OP_COST       = ( 1 :: Int)
 uNFOLDING_DEAR_OP_COST        = ( 4 :: Int)
 uNFOLDING_NOREP_LIT_COST      = ( 4 :: Int)
diff --git a/ghc/compiler/codeGen/CgCon.lhs b/ghc/compiler/codeGen/CgCon.lhs
index 21507e3e01..2ae485e84c 100644
--- a/ghc/compiler/codeGen/CgCon.lhs
+++ b/ghc/compiler/codeGen/CgCon.lhs
@@ -29,7 +29,7 @@ import CgBindery	( getArgAmodes, bindNewToNode,
 			  heapIdInfo, CgIdInfo
 			)
 import CgClosure	( cgTopRhsClosure )
-import CgCompInfo	( mAX_INTLIKE, mIN_INTLIKE )
+import Constants	( mAX_INTLIKE, mIN_INTLIKE )
 import CgHeapery	( allocDynClosure )
 import CgRetConv	( dataReturnConvAlg, DataReturnConvention(..) )
 import CgTailCall	( performReturn, mkStaticAlgReturnCode )
@@ -124,7 +124,7 @@ cgTopRhsCon name con args all_zero_size_args
   = cgTopRhsClosure name top_cc NoStgBinderInfo [] body lf_info
   where
     body = StgCon con args emptyIdSet{-emptyLiveVarSet-}
-    lf_info = mkClosureLFInfo True {- Top level -} [] ReEntrant [] body
+    lf_info = mkClosureLFInfo True {- Top level -} [] ReEntrant []
 \end{code}
 
 OK, so now we have the general case.
diff --git a/ghc/compiler/codeGen/CgConTbls.lhs b/ghc/compiler/codeGen/CgConTbls.lhs
index ea53371fbc..c970c9fc22 100644
--- a/ghc/compiler/codeGen/CgConTbls.lhs
+++ b/ghc/compiler/codeGen/CgConTbls.lhs
@@ -14,7 +14,7 @@ import AbsCSyn
 import CgMonad
 
 import AbsCUtils	( mkAbsCStmts, mkAbstractCs, magicIdPrimRep )
-import CgCompInfo	( uF_UPDATEE )
+import Constants	( uF_UPDATEE )
 import CgHeapery	( heapCheck, allocDynClosure )
 import CgRetConv	( dataReturnConvAlg, ctrlReturnConvAlg,
 			  CtrlReturnConvention(..),
@@ -39,7 +39,7 @@ import Id		( dataConTag, dataConRawArgTys,
 			  emptyIdSet,
 			  GenId{-instance NamedThing-}
 			)
-import Name		( nameOf, origName )
+import Name		( getOccString )
 import PrelInfo		( maybeIntLikeTyCon )
 import PrimRep		( getPrimRepSize, PrimRep(..) )
 import TyCon		( tyConDataCons, mkSpecTyCon )
@@ -208,7 +208,7 @@ genConInfo comp_info tycon data_con
 		      body_code))
 
     entry_addr = CLbl entry_label CodePtrRep
-    con_descr  = _UNPK_ (nameOf (origName "con_descr" data_con))
+    con_descr  = getOccString data_con
 
     closure_code        = CClosureInfoAndCode closure_info body Nothing
 					      stdUpd con_descr
@@ -335,7 +335,7 @@ genPhantomUpdInfo comp_info tycon data_con
 
 	    phantom_ci = layOutPhantomClosure data_con (mkConLFInfo data_con)
 
-	    con_descr = _UNPK_ (nameOf (origName "con_descr2" data_con))
+	    con_descr = getOccString data_con
 
 	    con_arity = dataConNumFields data_con
 
diff --git a/ghc/compiler/codeGen/CgExpr.lhs b/ghc/compiler/codeGen/CgExpr.lhs
index 05264e624b..c9a6dc7fc3 100644
--- a/ghc/compiler/codeGen/CgExpr.lhs
+++ b/ghc/compiler/codeGen/CgExpr.lhs
@@ -15,12 +15,13 @@ module CgExpr ( cgExpr, getPrimOpArgAmodes ) where
 IMP_Ubiq(){-uitous-}
 IMPORT_DELOOPER(CgLoop2)	-- here for paranoia-checking
 
+import Constants	( mAX_SPEC_SELECTEE_SIZE )
 import StgSyn
 import CgMonad
 import AbsCSyn
 
 import AbsCUtils	( mkAbsCStmts, mkAbstractCs )
-import CgBindery	( getArgAmodes, CgIdInfo )
+import CgBindery	( getArgAmodes, getCAddrModeAndInfo, CgIdInfo )
 import CgCase		( cgCase, saveVolatileVarsAndRegs )
 import CgClosure	( cgRhsClosure )
 import CgCon		( buildDynCon, cgReturnDataCon )
@@ -34,17 +35,23 @@ import CgTailCall	( cgTailCall, performReturn,
 			  mkDynamicAlgReturnCode, mkPrimReturnCode
 			)
 import CLabel		( mkPhantomInfoTableLabel, mkInfoTableVecTblLabel )
-import ClosureInfo	( mkClosureLFInfo )
+import ClosureInfo	( mkClosureLFInfo, mkSelectorLFInfo, mkVapLFInfo, lfArity_maybe,
+			  layOutDynCon )
 import CostCentre	( sccAbleCostCentre, isDictCC, isSccCountCostCentre )
-import HeapOffs		( SYN_IE(VirtualSpBOffset) )
-import Id		( mkIdSet, unionIdSets, GenId{-instance Outputable-} )
+import HeapOffs		( SYN_IE(VirtualSpBOffset), intOffsetIntoGoods )
+import Id		( dataConTyCon, idPrimRep, getIdArity, 
+			  mkIdSet, unionIdSets, GenId{-instance Outputable-}
+			)
+import IdInfo		( ArityInfo(..) )
+import Name		( isLocallyDefined )
 import PprStyle		( PprStyle(..) )
 import PrimOp		( primOpCanTriggerGC, primOpHeapReq, HeapRequirement(..),
 			  getPrimOpResultInfo, PrimOp(..), PrimOpResultInfo(..)
 			)
 import PrimRep		( getPrimRepSize, PrimRep(..) )
-import TyCon		( tyConDataCons )
-import Util		( panic, pprPanic, assertPanic )
+import TyCon		( tyConDataCons, maybeTyConSingleCon  )
+import Maybes		( assocMaybe, maybeToBool )
+import Util		( panic, isIn, pprPanic, assertPanic )
 \end{code}
 
 This module provides the support code for @StgToAbstractC@ to deal
@@ -289,9 +296,6 @@ ToDo: counting of dict sccs ...
 %********************************************************
 \subsection[non-top-level-bindings]{Converting non-top-level bindings}
 
-@cgBinding@ is only used for let/letrec, not for unboxed bindings.
-So the kind should always be @PtrRep@.
-
 We rely on the support code in @CgCon@ (to do constructors) and
 in @CgClosure@ (to do closures).
 
@@ -308,11 +312,125 @@ cgRhs name (StgRhsCon maybe_cc con args)
     zero_size atom = getPrimRepSize (getArgPrimRep atom) == 0
 
 cgRhs name (StgRhsClosure cc bi fvs upd_flag args body)
-  = cgRhsClosure name cc bi fvs args body lf_info
+  = mkRhsLFInfo fvs upd_flag args body 	`thenFC` \ lf_info ->
+    cgRhsClosure name cc bi fvs args body lf_info
+\end{code}
+
+mkRhsLFInfo looks for two special forms of the right-hand side:
+	a) selector thunks.
+	b) VAP thunks
+
+If neither happens, it just calls mkClosureLFInfo.  You might think
+that mkClosureLFInfo should do all this, but
+	(a) it seems wrong for the latter to look at the structure 
+		of an expression
+	(b) mkRhsLFInfo has to be in the monad since it looks up in
+		the environment, and it's very tiresome for mkClosureLFInfo to
+		be.  Apart from anything else it would make a loop between
+		CgBindery and ClosureInfo.
+
+Selectors
+~~~~~~~~~
+We look at the body of the closure to see if it's a selector---turgid,
+but nothing deep.  We are looking for a closure of {\em exactly} the
+form:
+\begin{verbatim}
+...  = [the_fv] \ u [] ->
+	 case the_fv of
+	   con a_1 ... a_n -> a_i
+\end{verbatim}
+
+\begin{code}
+mkRhsLFInfo	[the_fv]   		-- Just one free var
+		Updatable		-- Updatable thunk
+		[]			-- A thunk
+		(StgCase (StgApp (StgVarArg scrutinee) [{-no args-}] _)
+		      _ _ _   -- ignore live vars and uniq...
+		      (StgAlgAlts case_ty
+		  	 [(con, params, use_mask,
+			    (StgApp (StgVarArg selectee) [{-no args-}] _))]
+		  	 StgNoDefault))
+  |  the_fv == scrutinee			-- Scrutinee is the only free variable
+  && maybeToBool maybe_offset			-- Selectee is a component of the tuple
+  && maybeToBool offset_into_int_maybe
+  && offset_into_int <= mAX_SPEC_SELECTEE_SIZE	-- Offset is small enough
+  = -- ASSERT(is_single_constructor) 		-- Should be true, but causes error for SpecTyCon
+    returnFC (mkSelectorLFInfo scrutinee con offset_into_int)
   where
-    lf_info = mkClosureLFInfo False{-not top level-} fvs upd_flag args body
+    (_, params_w_offsets) = layOutDynCon con idPrimRep params
+    maybe_offset	  = assocMaybe params_w_offsets selectee
+    Just the_offset 	  = maybe_offset
+    offset_into_int_maybe = intOffsetIntoGoods the_offset
+    Just offset_into_int  = offset_into_int_maybe
+    is_single_constructor = maybeToBool (maybeTyConSingleCon tycon)
+    tycon		  = dataConTyCon con
 \end{code}
 
+
+Vap thunks
+~~~~~~~~~~
+Same kind of thing, looking for vector-apply thunks, of the form:
+
+	x = [...] \ .. [] -> f a1 .. an
+
+where f has arity n.  We rely on the arity info inside the Id being correct.
+
+\begin{code}
+mkRhsLFInfo 	fvs
+		upd_flag
+		[]			-- No args; a thunk
+		(StgApp (StgVarArg fun_id) args _)
+  | isLocallyDefined fun_id		-- Must be defined in this module
+  = 	-- Get the arity of the fun_id.  We could find out from the
+	-- looking in the Id, but it's more certain just to look in the code
+	-- generator's environment.
+
+----------------------------------------------
+-- Sadly, looking in the environment, as suggested above,
+-- causes a black hole (because cgRhsClosure depends on the LFInfo 
+-- returned here to determine its control flow.
+-- So I wimped out and went back to looking at the arity inside the Id.
+-- That means beefing up Core2Stg to propagate it.  Sigh.
+--     getCAddrModeAndInfo fun_id		`thenFC` \ (_, fun_lf_info) ->
+--     let arity_maybe = lfArity_maybe fun_lf_info
+----------------------------------------------
+
+     let
+	arity_maybe = case getIdArity fun_id of
+			ArityExactly n  -> Just n
+			other		-> Nothing
+     in
+     returnFC (case arity_maybe of
+		Just arity
+		    | arity > 0 &&			-- It'd better be a function!
+		      arity == length args		-- Saturated application
+		    -> 		-- Ha!  A VAP thunk
+			mkVapLFInfo fvs upd_flag fun_id args store_fun_in_vap
+
+		other -> mkClosureLFInfo False{-not top level-} fvs upd_flag []
+     )
+
+  where	
+	-- If the function is a free variable then it must be stored
+	-- in the thunk too; if it isn't a free variable it must be
+	-- because it's constant, so it doesn't need to be stored in the thunk
+    store_fun_in_vap = fun_id `is_elem` fvs
+    is_elem 	     = isIn "mkClosureLFInfo"
+\end{code}
+
+The default case
+~~~~~~~~~~~~~~~~
+\begin{code}
+mkRhsLFInfo fvs upd_flag args body
+  = returnFC (mkClosureLFInfo False{-not top level-} fvs upd_flag args)
+\end{code}
+
+
+%********************************************************
+%*							*
+%*		Let-no-escape bindings
+%*							*
+%********************************************************
 \begin{code}
 cgLetNoEscapeBindings live_in_rhss rhs_eob_info maybe_cc_slot (StgNonRec binder rhs)
   = cgLetNoEscapeRhs live_in_rhss rhs_eob_info maybe_cc_slot binder rhs
diff --git a/ghc/compiler/codeGen/CgRetConv.lhs b/ghc/compiler/codeGen/CgRetConv.lhs
index 5768b2df45..6b773f964b 100644
--- a/ghc/compiler/codeGen/CgRetConv.lhs
+++ b/ghc/compiler/codeGen/CgRetConv.lhs
@@ -29,7 +29,7 @@ import AbsCSyn		-- quite a few things
 import AbsCUtils	( mkAbstractCs, getAmodeRep,
 			  amodeCanSurviveGC
 			)
-import CgCompInfo	( mAX_FAMILY_SIZE_FOR_VEC_RETURNS,
+import Constants	( mAX_FAMILY_SIZE_FOR_VEC_RETURNS,
 			  mAX_Vanilla_REG, mAX_Float_REG,
 			  mAX_Double_REG
 			)
diff --git a/ghc/compiler/codeGen/CgUpdate.lhs b/ghc/compiler/codeGen/CgUpdate.lhs
index 70e344b7d9..5c0accd692 100644
--- a/ghc/compiler/codeGen/CgUpdate.lhs
+++ b/ghc/compiler/codeGen/CgUpdate.lhs
@@ -13,7 +13,7 @@ IMP_Ubiq(){-uitous-}
 import CgMonad
 import AbsCSyn
 
-import CgCompInfo	( sTD_UF_SIZE, sCC_STD_UF_SIZE )
+import Constants	( sTD_UF_SIZE, sCC_STD_UF_SIZE )
 import CgStackery	( allocUpdateFrame )
 import CmdLineOpts	( opt_SccProfilingOn )
 import Util		( assertPanic )
diff --git a/ghc/compiler/codeGen/ClosureInfo.lhs b/ghc/compiler/codeGen/ClosureInfo.lhs
index 73f9e6f4b7..186209fd85 100644
--- a/ghc/compiler/codeGen/ClosureInfo.lhs
+++ b/ghc/compiler/codeGen/ClosureInfo.lhs
@@ -15,7 +15,7 @@ module ClosureInfo (
 
 	EntryConvention(..),
 
-	mkClosureLFInfo, mkConLFInfo,
+	mkClosureLFInfo, mkConLFInfo, mkSelectorLFInfo, mkVapLFInfo,
 	mkLFImported, mkLFArgument, mkLFLetNoEscape,
 
 	closureSize, closureHdrSize,
@@ -28,15 +28,15 @@ module ClosureInfo (
 	mkVirtHeapOffsets,
 
 	nodeMustPointToIt, getEntryConvention,
-	blackHoleOnEntry,
+	blackHoleOnEntry, lfArity_maybe,
 
 	staticClosureRequired,
 	slowFunEntryCodeRequired, funInfoTableRequired,
 	stdVapRequired, noUpdVapRequired,
 
-	closureId, infoTableLabelFromCI,
+	closureId, infoTableLabelFromCI, fastLabelFromCI,
 	closureLabelFromCI,
-	entryLabelFromCI, fastLabelFromCI,
+	entryLabelFromCI, 
 	closureLFInfo, closureSMRep, closureUpdReqd,
 	closureSingleEntry, closureSemiTag, closureType,
 	closureReturnsUnboxedType, getStandardFormThunkInfo,
@@ -58,8 +58,7 @@ import AbsCSyn
 import StgSyn
 import CgMonad
 
-import CgCompInfo	( mAX_SPEC_SELECTEE_SIZE,
-			  mIN_UPD_SIZE, mIN_SIZE_NonUpdHeapObject,
+import Constants	( mIN_UPD_SIZE, mIN_SIZE_NonUpdHeapObject,
 			  mAX_SPEC_ALL_PTRS, mAX_SPEC_MIXED_FIELDS,
 			  mAX_SPEC_ALL_NONPTRS,
 			  oTHER_TAG
@@ -76,27 +75,26 @@ import CLabel		( mkStdEntryLabel, mkFastEntryLabel,
 			)
 import CmdLineOpts	( opt_SccProfilingOn, opt_ForConcurrent )
 import HeapOffs		( intOff, addOff, totHdrSize, varHdrSize,
-			  intOffsetIntoGoods,
 			  SYN_IE(VirtualHeapOffset)
 			)
-import Id		( idType, idPrimRep, getIdArity,
+import Id		( idType, getIdArity,
 			  externallyVisibleId,
 			  dataConTag, fIRST_TAG,
-			  isDataCon, isNullaryDataCon, dataConTyCon,
+			  isDataCon, isNullaryDataCon, dataConTyCon, dataConArity,
 			  isTupleCon, SYN_IE(DataCon),
 			  GenId{-instance Eq-}
 			)
-import IdInfo		( arityMaybe )
-import Maybes		( assocMaybe, maybeToBool )
-import Name		( isLocallyDefined, nameOf, origName )
+import IdInfo		( ArityInfo(..) )
+import Maybes		( maybeToBool )
+import Name		( getOccString )
 import PprStyle		( PprStyle(..) )
 import PprType		( getTyDescription, GenType{-instance Outputable-} )
---import Pretty--ToDo:rm
+import Pretty		--ToDo:rm
 import PrelInfo		( maybeCharLikeTyCon, maybeIntLikeTyCon )
 import PrimRep		( getPrimRepSize, separateByPtrFollowness )
 import SMRep		-- all of it
-import TyCon		( maybeTyConSingleCon, TyCon{-instance NamedThing-} )
-import Type		( isPrimType, splitForAllTy, splitFunTyExpandingDictsAndPeeking,
+import TyCon		( TyCon{-instance NamedThing-} )
+import Type		( isPrimType, expandTy, splitForAllTy, splitFunTyExpandingDictsAndPeeking,
 			  mkFunTys, maybeAppSpecDataTyConExpandingDicts
 			)
 import Util		( isIn, mapAccumL, panic, pprPanic, assertPanic )
@@ -361,11 +359,11 @@ mkLFLetNoEscape = LFLetNoEscape
 
 mkLFImported :: Id -> LambdaFormInfo
 mkLFImported id
-  = case arityMaybe (getIdArity id) of
-      Nothing  	-> LFImported
-      Just 0	-> LFThunk True{-top-lev-} True{-no fvs-}
-			True{-updatable-} NonStandardThunk
-      Just n	-> LFReEntrant True n True  -- n > 0
+  = case getIdArity id of
+      ArityExactly 0	-> LFThunk True{-top-lev-} True{-no fvs-}
+				   True{-updatable-} NonStandardThunk
+      ArityExactly n	-> LFReEntrant True n True  -- n > 0
+      other	   	-> LFImported	-- Not sure of exact arity
 \end{code}
 
 %************************************************************************
@@ -381,90 +379,15 @@ mkClosureLFInfo :: Bool 	-- True of top level
 		-> [Id]		-- Free vars
 		-> UpdateFlag 	-- Update flag
 		-> [Id] 	-- Args
-		-> StgExpr	-- Body of closure: passed so we
-				-- can look for selector thunks!
 		-> LambdaFormInfo
 
-mkClosureLFInfo top fvs upd_flag args@(_:_) body -- Non-empty args
+mkClosureLFInfo top fvs upd_flag args@(_:_)  -- Non-empty args
   = LFReEntrant top (length args) (null fvs)
 
-mkClosureLFInfo top fvs ReEntrant [] body
+mkClosureLFInfo top fvs ReEntrant []
   = LFReEntrant top 0 (null fvs)
-\end{code}
-
-OK, this is where we look at the body of the closure to see if it's a
-selector---turgid, but nothing deep.  We are looking for a closure of
-{\em exactly} the form:
-\begin{verbatim}
-...  = [the_fv] \ u [] ->
-	 case the_fv of
-	   con a_1 ... a_n -> a_i
-\end{verbatim}
-Here we go:
-\begin{code}
-mkClosureLFInfo False	    -- don't bother if at top-level
-		[the_fv]    -- just one...
-		Updatable
-		[]	    -- no args (a thunk)
-		(StgCase (StgApp (StgVarArg scrutinee) [{-no args-}] _)
-		  _ _ _   -- ignore live vars and uniq...
-		  (StgAlgAlts case_ty
-		     [(con, params, use_mask,
-			(StgApp (StgVarArg selectee) [{-no args-}] _))]
-		     StgNoDefault))
-  |  the_fv == scrutinee			-- Scrutinee is the only free variable
-  && maybeToBool maybe_offset			-- Selectee is a component of the tuple
-  && maybeToBool offset_into_int_maybe
-  && offset_into_int <= mAX_SPEC_SELECTEE_SIZE	-- Offset is small enough
-  =
-    -- ASSERT(is_single_constructor) 		-- Should be true, by causes error for SpecTyCon
-    LFThunk False False True (SelectorThunk scrutinee con offset_into_int)
-  where
-    (_, params_w_offsets) = layOutDynCon con idPrimRep params
-    maybe_offset	  = assocMaybe params_w_offsets selectee
-    Just the_offset 	  = maybe_offset
-    offset_into_int_maybe = intOffsetIntoGoods the_offset
-    Just offset_into_int  = offset_into_int_maybe
-    is_single_constructor = maybeToBool (maybeTyConSingleCon tycon)
-    tycon		  = dataConTyCon con
-\end{code}
-
-Same kind of thing, looking for vector-apply thunks, of the form:
 
-	x = [...] \ .. [] -> f a1 .. an
-
-where f has arity n.  We rely on the arity info inside the Id being correct.
-
-\begin{code}
-mkClosureLFInfo top_level
-		fvs
-		upd_flag
-		[]			-- No args; a thunk
-		(StgApp (StgVarArg fun_id) args _)
-  | not top_level			-- A top-level thunk would require a static
-					-- vap_info table, which we don't generate just
-					-- now; so top-level thunks are never standard
-					-- form.
-  && isLocallyDefined fun_id		-- Must be defined in this module
-  && maybeToBool arity_maybe		-- A known function with known arity
-  && fun_arity > 0			-- It'd better be a function!
-  && fun_arity == length args		-- Saturated application
-  = LFThunk top_level (null fvs) (isUpdatable upd_flag) (VapThunk fun_id args store_fun_in_vap)
-  where
-    arity_maybe      = arityMaybe (getIdArity fun_id)
-    Just fun_arity   = arity_maybe
-
-	-- If the function is a free variable then it must be stored
-	-- in the thunk too; if it isn't a free variable it must be
-	-- because it's constant, so it doesn't need to be stored in the thunk
-    store_fun_in_vap = fun_id `is_elem` fvs
-
-    is_elem = isIn "mkClosureLFInfo"
-\end{code}
-
-Finally, the general updatable-thing case:
-\begin{code}
-mkClosureLFInfo top fvs upd_flag [] body
+mkClosureLFInfo top fvs upd_flag []
   = LFThunk top (null fvs) (isUpdatable upd_flag) NonStandardThunk
 
 isUpdatable ReEntrant   = False
@@ -480,6 +403,12 @@ mkConLFInfo :: DataCon -> LambdaFormInfo
 mkConLFInfo con
   = -- the isNullaryDataCon will do this: ASSERT(isDataCon con)
     (if isTupleCon con then LFTuple else LFCon) con (isNullaryDataCon con)
+
+mkSelectorLFInfo scrutinee con offset
+  = LFThunk False False True (SelectorThunk scrutinee con offset)
+
+mkVapLFInfo fvs upd_flag fun_id args fun_in_vap
+  = LFThunk False (null fvs) (isUpdatable upd_flag) (VapThunk fun_id args fun_in_vap)
 \end{code}
 
 
@@ -1086,6 +1015,15 @@ noUpdVapRequired binder_info
       _					   -> False
 \end{code}
 
+@lfArity@ extracts the arity of a function from its LFInfo
+
+\begin{code}
+lfArity_maybe (LFReEntrant _ arity _) = Just arity
+lfArity_maybe (LFCon con _)	      = Just (dataConArity con)
+lfArity_maybe (LFTuple con _)	      = Just (dataConArity con)
+lfArity_maybe other		      = Nothing
+\end{code}
+
 %************************************************************************
 %*									*
 \subsection[ClosureInfo-misc-funs]{Misc functions about @ClosureInfo@, etc.}
@@ -1158,11 +1096,10 @@ closureReturnsUnboxedType other_closure = False
 -- ToDo: need anything like this in Type.lhs?
 fun_result_ty arity id
   = let
-	(_, de_foralld_ty) = splitForAllTy (idType id)
-	(arg_tys, res_ty)  = splitFunTyExpandingDictsAndPeeking de_foralld_ty
+	(arg_tys, res_ty)  = splitFunTyExpandingDictsAndPeeking (idType id)
     in
-    ASSERT(arity >= 0 && length arg_tys >= arity)
---    (if (arity >= 0 && length arg_tys >= arity) then (\x->x) else pprPanic "fun_result_ty:" (ppCat [ppInt arity, ppr PprShowAll id, ppr PprDebug (idType id)])) $
+--    ASSERT(arity >= 0 && length arg_tys >= arity)
+    (if (arity >= 0 && length arg_tys >= arity) then (\x->x) else pprPanic "fun_result_ty:" (ppCat [ppInt arity, ppr PprShowAll id, ppr PprDebug (idType id)])) $
     mkFunTys (drop arity arg_tys) res_ty
 \end{code}
 
@@ -1189,8 +1126,13 @@ isToplevClosure (MkClosureInfo _ lf_info _)
 Label generation.
 
 \begin{code}
-infoTableLabelFromCI :: ClosureInfo -> CLabel
+fastLabelFromCI :: ClosureInfo -> CLabel
+fastLabelFromCI (MkClosureInfo id lf_info _)
+  = case lfArity_maybe lf_info of
+	Just arity -> mkFastEntryLabel id arity
+	other	   -> pprPanic "fastLabelFromCI" (ppr PprDebug id)
 
+infoTableLabelFromCI :: ClosureInfo -> CLabel
 infoTableLabelFromCI (MkClosureInfo id lf_info rep)
   = case lf_info of
 	LFCon con _ 	-> mkConInfoPtr con rep
@@ -1254,14 +1196,6 @@ thunkEntryLabel thunk_id (VapThunk fun_id args _) is_updatable
   = mkVapEntryLabel fun_id is_updatable
 thunkEntryLabel thunk_id _ is_updatable
   = mkStdEntryLabel thunk_id
-
-fastLabelFromCI :: ClosureInfo -> CLabel
-fastLabelFromCI (MkClosureInfo id _ _) = mkFastEntryLabel id fun_arity
-  where
-    arity_maybe = arityMaybe (getIdArity id)
-    fun_arity	= case arity_maybe of
-		    Just x -> x
-		    _	   -> panic "fastLabelFromCI:no arity:" --(ppr PprShowAll id)
 \end{code}
 
 \begin{code}
@@ -1331,8 +1265,8 @@ closureKind (MkClosureInfo _ lf _)
 
 closureTypeDescr :: ClosureInfo -> String
 closureTypeDescr (MkClosureInfo id lf _)
-  = if (isDataCon id) then			     -- DataCon has function types
-	_UNPK_ (nameOf (origName "closureTypeDescr" (dataConTyCon id))) -- We want the TyCon not the ->
+  = if (isDataCon id) then			 -- DataCon has function types
+	getOccString (dataConTyCon id)		 -- We want the TyCon not the ->
     else
 	getTyDescription (idType id)
 \end{code}
diff --git a/ghc/compiler/codeGen/CodeGen.lhs b/ghc/compiler/codeGen/CodeGen.lhs
index 5879c0f877..a786145a4a 100644
--- a/ghc/compiler/codeGen/CodeGen.lhs
+++ b/ghc/compiler/codeGen/CodeGen.lhs
@@ -57,7 +57,7 @@ codeGen mod_name (local_CCs, extern_CCs) import_names gen_tycons tycon_specs stg
   = let
 	doing_profiling   = opt_SccProfilingOn
 	compiling_prelude = opt_CompilingGhcInternals
-	maybe_split       = if maybeToBool (opt_EnsureSplittableC)
+	maybe_split       = if opt_EnsureSplittableC
 			    then CSplitMarker
 			    else AbsCNop
 
@@ -167,5 +167,5 @@ cgTopRhs name (StgRhsClosure cc bi fvs upd_flag args body)
   = ASSERT(null fvs) -- There should be no free variables
     forkStatics (cgTopRhsClosure name cc bi args body lf_info)
   where
-    lf_info = mkClosureLFInfo True{-top level-} [{-no fvs-}] upd_flag args body
+    lf_info = mkClosureLFInfo True{-top level-} [{-no fvs-}] upd_flag args
 \end{code}
diff --git a/ghc/compiler/coreSyn/CoreLift.lhs b/ghc/compiler/coreSyn/CoreLift.lhs
index 59c655aca6..2310d0278e 100644
--- a/ghc/compiler/coreSyn/CoreLift.lhs
+++ b/ghc/compiler/coreSyn/CoreLift.lhs
@@ -24,7 +24,7 @@ import Id		( idType, mkSysLocal,
 			  nullIdEnv, growIdEnvList, lookupIdEnv, SYN_IE(IdEnv),
 			  GenId{-instances-}
 			)
-import Name		( isLocallyDefined, getSrcLoc )
+import Name		( isLocallyDefined, getSrcLoc, getOccString )
 import TyCon		( isBoxedTyCon, TyCon{-instance-} )
 import Type		( maybeAppDataTyConExpandingDicts, eqTy )
 import TysPrim		( statePrimTyCon )
@@ -213,8 +213,7 @@ liftDeflt (BindDefault binder rhs)
 type LiftM a
   = IdEnv (Id, Id)	-- lifted Ids are mapped to:
 			--   * lifted Id with the same Unique
-			--     (top-level bindings must keep their
-			--	unique (see TopLevId in Id.lhs))
+			--     (top-level bindings must keep their unique
 			--   * unlifted version with a new Unique
     -> UniqSupply	-- unique supply
     -> a		-- result
@@ -279,7 +278,7 @@ mkLiftedId id u
   = ASSERT (isUnboxedButNotState unlifted_ty)
     (lifted_id, unlifted_id)
   where
-    id_name     = panic "CoreLift.mkLiftedId:id_name" --LATER: getOccName id
+    id_name     = _PK_ (getOccString id)		-- yuk!
     lifted_id   = updateIdType id lifted_ty
     unlifted_id = mkSysLocal id_name u unlifted_ty (getSrcLoc id)
 
diff --git a/ghc/compiler/coreSyn/CoreSyn.lhs b/ghc/compiler/coreSyn/CoreSyn.lhs
index 42830e9008..4b25be3d90 100644
--- a/ghc/compiler/coreSyn/CoreSyn.lhs
+++ b/ghc/compiler/coreSyn/CoreSyn.lhs
@@ -133,6 +133,7 @@ desugarer sets up constructors as applications of global @Vars@s.
 
      | Prim	PrimOp [GenCoreArg val_occ tyvar uvar]
 		-- saturated primitive operation;
+
 		-- comment on Cons applies here, too.
 \end{code}
 
diff --git a/ghc/compiler/coreSyn/CoreUnfold.lhs b/ghc/compiler/coreSyn/CoreUnfold.lhs
index 247e969fde..386ef41fbc 100644
--- a/ghc/compiler/coreSyn/CoreUnfold.lhs
+++ b/ghc/compiler/coreSyn/CoreUnfold.lhs
@@ -17,15 +17,16 @@ find, unsurprisingly, a Core expression.
 
 module CoreUnfold (
 	SimpleUnfolding(..), Unfolding(..), UnfoldingGuidance(..), -- types
+	UfExpr,	RdrName, -- For closure (delete in 1.3)
 
 	FormSummary(..), mkFormSummary, whnfOrBottom, exprSmallEnoughToDup,
 
-	smallEnoughToInline, couldBeSmallEnoughToInline,
+	noUnfolding, mkMagicUnfolding, mkUnfolding, getUnfoldingTemplate,
 
-	mkSimpleUnfolding,
-	mkMagicUnfolding,
-	calcUnfoldingGuidance,
-	mentionedInUnfolding
+	smallEnoughToInline, couldBeSmallEnoughToInline, certainlySmallEnoughToInline,
+	okToInline,
+
+	calcUnfoldingGuidance
     ) where
 
 IMP_Ubiq()
@@ -34,17 +35,27 @@ IMPORT_DELOOPER(IdLoop)	 -- for paranoia checking;
 IMPORT_DELOOPER(PrelLoop)  -- for paranoia checking
 
 import Bag		( emptyBag, unitBag, unionBags, Bag )
-import CgCompInfo	( uNFOLDING_CHEAP_OP_COST,
+
+import CmdLineOpts	( opt_UnfoldingCreationThreshold,
+			  opt_UnfoldingUseThreshold,
+			  opt_UnfoldingConDiscount
+			)
+import Constants	( uNFOLDING_CHEAP_OP_COST,
 			  uNFOLDING_DEAR_OP_COST,
 			  uNFOLDING_NOREP_LIT_COST
 			)
+import BinderInfo	( BinderInfo(..), FunOrArg, DuplicationDanger, InsideSCC, isDupDanger )
 import CoreSyn
+import CoreUtils	( unTagBinders )
+import HsCore		( UfExpr )
+import RdrHsSyn		( RdrName )
+import OccurAnal	( occurAnalyseGlobalExpr )
 import CoreUtils	( coreExprType )
 import CostCentre	( ccMentionsId )
 import Id		( idType, getIdArity,  isBottomingId, 
 			  SYN_IE(IdSet), GenId{-instances-} )
 import PrimOp		( primOpCanTriggerGC, fragilePrimOp, PrimOp(..) )
-import IdInfo		( arityMaybe, bottomIsGuaranteed )
+import IdInfo		( ArityInfo(..), bottomIsGuaranteed )
 import Literal		( isNoRepLit, isLitLitLit )
 import Pretty
 import TyCon		( tyConFamilySize )
@@ -55,8 +66,6 @@ import UniqSet		( emptyUniqSet, unitUniqSet, mkUniqSet,
 import Usage		( SYN_IE(UVar) )
 import Util		( isIn, panic, assertPanic )
 
-whatsMentionedInId = panic "whatsMentionedInId (CoreUnfold)"
-getMentionedTyConsAndClassesFromType = panic "getMentionedTyConsAndClassesFromType (CoreUnfold)"
 \end{code}
 
 %************************************************************************
@@ -68,28 +77,37 @@ getMentionedTyConsAndClassesFromType = panic "getMentionedTyConsAndClassesFromTy
 \begin{code}
 data Unfolding
   = NoUnfolding
+
   | CoreUnfolding SimpleUnfolding
+
   | MagicUnfolding
-	Unique			-- of the Id whose magic unfolding this is
+	Unique				-- Unique of the Id whose magic unfolding this is
 	MagicUnfoldingFun
 
 
 data SimpleUnfolding
-  = SimpleUnfolding	FormSummary		-- Tells whether the template is a WHNF or bottom
-			UnfoldingGuidance	-- Tells about the *size* of the template.
-			TemplateOutExpr		-- The template
+  = SimpleUnfolding			-- An unfolding with redundant cached information
+		FormSummary		-- Tells whether the template is a WHNF or bottom
+		UnfoldingGuidance	-- Tells about the *size* of the template.
+		SimplifiableCoreExpr	-- Template
 
-type TemplateOutExpr = GenCoreExpr (Id, BinderInfo) Id TyVar UVar
-	-- An OutExpr with occurrence info attached.  This is used as
-	-- a template in GeneralForms.
 
+noUnfolding = NoUnfolding
 
-mkSimpleUnfolding form guidance    template 
-  = SimpleUnfolding form guidance template
+mkUnfolding inline_me expr
+  = CoreUnfolding (SimpleUnfolding
+			(mkFormSummary expr)
+			(calcUnfoldingGuidance inline_me opt_UnfoldingCreationThreshold expr)
+			(occurAnalyseGlobalExpr expr))
 
 mkMagicUnfolding :: Unique -> Unfolding
 mkMagicUnfolding tag  = MagicUnfolding tag (mkMagicUnfoldingFun tag)
 
+getUnfoldingTemplate :: Unfolding -> CoreExpr
+getUnfoldingTemplate (CoreUnfolding (SimpleUnfolding _ _ expr))
+  = unTagBinders expr
+getUnfoldingTemplate other = panic "getUnfoldingTemplate"
+
 
 data UnfoldingGuidance
   = UnfoldNever
@@ -162,8 +180,9 @@ mkFormSummary expr
 
     go n (Var f) | isBottomingId f = BottomForm
     go 0 (Var f)		   = VarForm
-    go n (Var f)		   = case (arityMaybe (getIdArity f)) of
-					  Just arity | n < arity -> ValueForm
+    go n (Var f)		   = case getIdArity f of
+					  ArityExactly a | n < a -> ValueForm
+					  ArityAtLeast a | n < a -> ValueForm
 					  other			 -> OtherForm
 
 whnfOrBottom :: GenCoreExpr bndr Id tyvar uvar -> Bool
@@ -209,16 +228,18 @@ enough?
 
 \begin{code}
 calcUnfoldingGuidance
-	:: Bool		    	-- True <=> OK if _scc_s appear in expr
+	:: Bool		    	-- True <=> there's an INLINE pragma on this thing
 	-> Int		    	-- bomb out if size gets bigger than this
 	-> CoreExpr    		-- expression to look at
 	-> UnfoldingGuidance
 
-calcUnfoldingGuidance scc_s_OK bOMB_OUT_SIZE expr
+calcUnfoldingGuidance True bOMB_OUT_SIZE expr = UnfoldAlways	-- Always inline if the INLINE pragma says so
+
+calcUnfoldingGuidance False bOMB_OUT_SIZE expr
   = let
     	(use_binders, ty_binders, val_binders, body) = collectBinders expr
     in
-    case (sizeExpr scc_s_OK bOMB_OUT_SIZE val_binders body) of
+    case (sizeExpr bOMB_OUT_SIZE val_binders body) of
 
       Nothing		     -> UnfoldNever
 
@@ -247,8 +268,7 @@ calcUnfoldingGuidance scc_s_OK bOMB_OUT_SIZE expr
 \end{code}
 
 \begin{code}
-sizeExpr :: Bool	    -- True <=> _scc_s OK
-	 -> Int 	    -- Bomb out if it gets bigger than this
+sizeExpr :: Int 	    -- Bomb out if it gets bigger than this
 	 -> [Id]	    -- Arguments; we're interested in which of these
 			    -- get case'd
 	 -> CoreExpr
@@ -256,19 +276,19 @@ sizeExpr :: Bool	    -- True <=> _scc_s OK
 		   [Id]	    -- Subset of args which are cased
 	    )
 
-sizeExpr scc_s_OK bOMB_OUT_SIZE args expr
+sizeExpr bOMB_OUT_SIZE args expr
   = size_up expr
   where
     size_up (Var v)        = sizeOne
     size_up (App fun arg)  = size_up fun `addSize` size_up_arg arg
     size_up (Lit lit)      = if isNoRepLit lit
-			       then sizeN uNFOLDING_NOREP_LIT_COST
-			       else sizeOne
+			     then sizeN uNFOLDING_NOREP_LIT_COST
+			     else sizeOne
 
-    size_up (SCC _ (Con _ _)) = Nothing -- **** HACK *****
-    size_up (SCC lbl body)
-      = if scc_s_OK then size_up body else Nothing
+-- I don't understand this hack so I'm removing it!  SLPJ Nov 96
+--    size_up (SCC _ (Con _ _)) = Nothing -- **** HACK *****
 
+    size_up (SCC lbl body)    = size_up body		-- SCCs cost nothing
     size_up (Coerce _ _ body) = size_up body		-- Coercions cost nothing
 
     size_up (Con con args) = -- 1 + # of val args
@@ -394,23 +414,27 @@ hands, we get a (again, semi-arbitrary) discount [proportion to the
 number of constructors in the type being scrutinized].
 
 \begin{code}
-smallEnoughToInline :: Int -> Int	-- Constructor discount and size threshold
-	      -> [Bool]			-- Evaluated-ness of value arguments
-	      -> UnfoldingGuidance
-	      -> Bool			-- True => unfold it
-
-smallEnoughToInline con_discount size_threshold _ UnfoldAlways = True
-smallEnoughToInline con_discount size_threshold _ UnfoldNever  = False
-smallEnoughToInline con_discount size_threshold arg_is_evald_s
-	      (UnfoldIfGoodArgs m_tys_wanted n_vals_wanted discount_vec size)
-  = n_vals_wanted <= length arg_is_evald_s &&
-    discounted_size <= size_threshold
+smallEnoughToInline :: [Bool]			-- Evaluated-ness of value arguments
+		    -> UnfoldingGuidance
+		    -> Bool			-- True => unfold it
 
+smallEnoughToInline _ UnfoldAlways = True
+smallEnoughToInline _ UnfoldNever  = False
+smallEnoughToInline arg_is_evald_s
+	      (UnfoldIfGoodArgs m_tys_wanted n_vals_wanted discount_vec size)
+  = enough_args n_vals_wanted arg_is_evald_s &&
+    discounted_size <= opt_UnfoldingUseThreshold
   where
+    enough_args 0 evals  = True
+    enough_args n []     = False
+    enough_args n (e:es) = enough_args (n-1) es
+	-- NB: don't take the length of arg_is_evald_s because when
+	-- called from couldBeSmallEnoughToInline it is infinite!
+
     discounted_size = size - sum (zipWith arg_discount discount_vec arg_is_evald_s)
 
     arg_discount no_of_constrs is_evald
-      | is_evald  = 1 + no_of_constrs * con_discount
+      | is_evald  = 1 + no_of_constrs * opt_UnfoldingConDiscount
       | otherwise = 1
 \end{code}
 
@@ -419,379 +443,48 @@ use'' on the other side.  Can be overridden w/ flaggery.
 Just the same as smallEnoughToInline, except that it has no actual arguments.
 
 \begin{code}
-couldBeSmallEnoughToInline :: Int -> Int	-- Constructor discount and size threshold
-	      	       	   -> UnfoldingGuidance
-		      	   -> Bool		-- True => unfold it
-
-couldBeSmallEnoughToInline con_discount size_threshold guidance
-  = smallEnoughToInline con_discount size_threshold (repeat True) guidance
-\end{code}
-
-%************************************************************************
-%*									*
-\subsection[unfoldings-for-ifaces]{Processing unfoldings for interfaces}
-%*									*
-%************************************************************************
-
-Of course, the main thing we do to unfoldings-for-interfaces is {\em
-print} them.  But, while we're at it, we collect info about
-``mentioned'' Ids, etc., etc.---we're going to need this stuff anyway.
-
-%************************************************************************
-%*									*
-\subsubsection{Monad stuff for the unfolding-generation game}
-%*									*
-%************************************************************************
-
-\begin{code}
-type UnfoldM bndr thing
-	=  IdSet	-- in-scope Ids (passed downwards only)
-	-> (bndr -> Id)	-- to extract an Id from a binder (down only)
-
-	-> (Bag Id,	-- mentioned global vars (ditto)
-	    Bag TyCon,	-- ditto, tycons
-	    Bag Class,	-- ditto, classes
-	    Bool)	-- True <=> mentions something litlit-ish
-
-	-> (thing, (Bag Id, Bag TyCon, Bag Class, Bool)) -- accumulated...
-\end{code}
-
-A little stuff for in-scopery:
-\begin{code}
-no_in_scopes :: IdSet
-add1	     :: IdSet -> Id   -> IdSet
-add_some     :: IdSet -> [Id] -> IdSet
-
-no_in_scopes		= emptyUniqSet
-in_scopes `add1`     x  = addOneToUniqSet in_scopes x
-in_scopes `add_some` xs = in_scopes `unionUniqSets` mkUniqSet xs
-\end{code}
-
-The can-see-inside-monad functions are the usual sorts of things.
-
-\begin{code}
-thenUf :: UnfoldM bndr a -> (a -> UnfoldM bndr b) -> UnfoldM bndr b
-thenUf m k in_scopes get_id mentioneds
-  = case m in_scopes get_id mentioneds of { (v, mentioneds1) ->
-    k v in_scopes get_id mentioneds1 }
-
-thenUf_ :: UnfoldM bndr a -> UnfoldM bndr b -> UnfoldM bndr b
-thenUf_ m k in_scopes get_id mentioneds
-  = case m in_scopes get_id mentioneds of { (_, mentioneds1) ->
-    k in_scopes get_id mentioneds1 }
-
-mapUf :: (a -> UnfoldM bndr b) -> [a] -> UnfoldM bndr [b]
-mapUf f []     = returnUf []
-mapUf f (x:xs)
-  = f x		`thenUf` \ r ->
-    mapUf f xs  `thenUf` \ rs ->
-    returnUf (r:rs)
-
-returnUf :: a -> UnfoldM bndr a
-returnUf v in_scopes get_id mentioneds = (v, mentioneds)
-
-addInScopesUf :: [Id] -> UnfoldM bndr a -> UnfoldM bndr a
-addInScopesUf more_in_scopes m in_scopes get_id mentioneds
-  = m (in_scopes `add_some` more_in_scopes) get_id mentioneds
-
-getInScopesUf :: UnfoldM bndr IdSet
-getInScopesUf in_scopes get_id mentioneds = (in_scopes, mentioneds)
-
-extractIdsUf :: [bndr] -> UnfoldM bndr [Id]
-extractIdsUf binders in_scopes get_id mentioneds
-  = (map get_id binders, mentioneds)
-
-consider_Id :: Id -> UnfoldM bndr ()
-consider_Id var in_scopes get_id (ids, tcs, clss, has_litlit)
-  = let
-	(ids2, tcs2, clss2) = whatsMentionedInId in_scopes var
-    in
-    ((), (ids `unionBags` ids2,
-	  tcs `unionBags` tcs2,
-	  clss `unionBags`clss2,
-	  has_litlit))
-\end{code}
-
-\begin{code}
-addToMentionedIdsUf 	:: Id -> UnfoldM bndr ()
-addToMentionedTyConsUf 	:: Bag TyCon -> UnfoldM bndr ()
-addToMentionedClassesUf	:: Bag Class -> UnfoldM bndr ()
-litlit_oops		:: UnfoldM bndr ()
-
-addToMentionedIdsUf add_me in_scopes get_id (ids, tcs, clss, has_litlit)
-  = ((), (ids `unionBags` unitBag add_me, tcs, clss, has_litlit))
-
-addToMentionedTyConsUf add_mes in_scopes get_id (ids, tcs, clss, has_litlit)
-  = ((), (ids, tcs `unionBags` add_mes, clss, has_litlit))
-
-addToMentionedClassesUf add_mes in_scopes get_id (ids, tcs, clss, has_litlit)
-  = ((), (ids, tcs, clss `unionBags` add_mes, has_litlit))
-
-litlit_oops in_scopes get_id (ids, tcs, clss, _)
-  = ((), (ids, tcs, clss, True))
-\end{code}
-
-
-%************************************************************************
-%*									*
-\subsubsection{Gathering up info for an interface-unfolding}
-%*									*
-%************************************************************************
-
-\begin{code}
-{-
-mentionedInUnfolding
-	:: (bndr -> Id)		-- so we can get Ids out of binders
-	-> GenCoreExpr bndr Id	-- input expression
-	-> (Bag Id, Bag TyCon, Bag Class,
-				-- what we found mentioned in the expr
-	    Bool		-- True <=> mentions a ``litlit''-ish thing
-				-- (the guy on the other side of an interface
-				-- may not be able to handle it)
-	   )
--}
-
-mentionedInUnfolding get_id expr
-  = case (ment_expr expr no_in_scopes get_id (emptyBag, emptyBag, emptyBag, False)) of
-      (_, (ids_bag, tcs_bag, clss_bag, has_litlit)) ->
-	(ids_bag, tcs_bag, clss_bag, has_litlit)
-\end{code}
-
-\begin{code}
---ment_expr :: GenCoreExpr bndr Id -> UnfoldM bndr ()
-
-ment_expr (Var v) = consider_Id  v
-ment_expr (Lit l) = consider_lit l
-
-ment_expr expr@(Lam _ _)
-  = let
-	(uvars, tyvars, args, body) = collectBinders expr
-    in
-    extractIdsUf args		`thenUf` \ bs_ids ->
-    addInScopesUf bs_ids (
-	-- this considering is just to extract any mentioned types/classes
-	mapUf consider_Id bs_ids   `thenUf_`
-	ment_expr body
-    )
-
-ment_expr (App fun arg)
-  = ment_expr fun	`thenUf_`
-    ment_arg  arg
-
-ment_expr (Con c as)
-  = consider_Id c	`thenUf_`
-    mapUf ment_arg as	`thenUf_`
-    returnUf ()
-
-ment_expr (Prim op as)
-  = ment_op op		`thenUf_`
-    mapUf ment_arg as	`thenUf_`
-    returnUf ()
-  where
-    ment_op (CCallOp str is_asm may_gc arg_tys res_ty)
-      = mapUf ment_ty arg_tys	`thenUf_`
-    	ment_ty res_ty
-    ment_op other_op = returnUf ()
-
-ment_expr (Case scrutinee alts)
-  = ment_expr scrutinee	`thenUf_`
-    ment_alts alts
-
-ment_expr (Let (NonRec bind rhs) body)
-  = ment_expr rhs	`thenUf_`
-    extractIdsUf [bind]	`thenUf` \ bi@[bind_id] ->
-    addInScopesUf bi	(
-    ment_expr body	`thenUf_`
-    consider_Id bind_id )
-
-ment_expr (Let (Rec pairs) body)
-  = let
-	binders = map fst pairs
-	rhss	= map snd pairs
-    in
-    extractIdsUf binders	`thenUf` \ binder_ids ->
-    addInScopesUf binder_ids (
-	mapUf ment_expr rhss	     `thenUf_`
-	mapUf consider_Id binder_ids `thenUf_`
-	ment_expr body )
-
-ment_expr (SCC cc expr)
-  = (case (ccMentionsId cc) of
-      Just id -> consider_Id id
-      Nothing -> returnUf ()
-    )
-    `thenUf_` ment_expr expr
-
-ment_expr (Coerce _ _ _) = panic "ment_expr:Coerce"
-
--------------
-ment_ty ty
-  = let
-	(tycons, clss) = getMentionedTyConsAndClassesFromType ty
-    in
-    addToMentionedTyConsUf  tycons  `thenUf_`
-    addToMentionedClassesUf clss
-
--------------
+couldBeSmallEnoughToInline :: UnfoldingGuidance -> Bool
+couldBeSmallEnoughToInline guidance = smallEnoughToInline (repeat True) guidance
 
-ment_alts alg_alts@(AlgAlts alts deflt)
-  = mapUf ment_alt alts   `thenUf_`
-    ment_deflt deflt
-  where
-    ment_alt alt@(con, params, rhs)
-      = consider_Id con		`thenUf_`
-	extractIdsUf params	`thenUf` \ param_ids ->
-	addInScopesUf param_ids (
-	  -- "consider" them so we can chk out their types...
-	  mapUf consider_Id param_ids `thenUf_`
-	  ment_expr rhs )
-
-ment_alts (PrimAlts alts deflt)
-  = mapUf ment_alt alts   `thenUf_`
-    ment_deflt deflt
-  where
-    ment_alt alt@(lit, rhs) = ment_expr rhs
-
-----------------
-ment_deflt NoDefault
-  = returnUf ()
-
-ment_deflt d@(BindDefault b rhs)
-  = extractIdsUf [b]		`thenUf` \ bi@[b_id] ->
-    addInScopesUf bi		(
-	consider_Id b_id `thenUf_`
-	ment_expr rhs )
-
------------
-ment_arg (VarArg   v)  = consider_Id  v
-ment_arg (LitArg   l)  = consider_lit l
-ment_arg (TyArg    ty) = ment_ty ty
-ment_arg (UsageArg _)  = returnUf ()
-
------------
-consider_lit lit
-  | isLitLitLit lit = litlit_oops `thenUf_` returnUf ()
-  | otherwise	    = returnUf ()
+certainlySmallEnoughToInline :: UnfoldingGuidance -> Bool
+certainlySmallEnoughToInline guidance = smallEnoughToInline (repeat False) guidance
 \end{code}
 
-%************************************************************************
-%*									*
-\subsubsection{Printing unfoldings in interfaces}
-%*									*
-%************************************************************************
-
-Printing Core-expression unfoldings is sufficiently delicate that we
-give it its own function.
-\begin{code}
-{- OLD:
-pprCoreUnfolding
-	:: CoreExpr
-	-> Pretty
-
-pprCoreUnfolding expr
-  = let
-	(_, renamed) = instCoreExpr uniqSupply_u expr
-	    -- We rename every unfolding with a "steady" unique supply,
-	    -- so that the names won't constantly change.
-	    -- One place we *MUST NOT* use a splittable UniqueSupply!
-    in
-    ppr_uf_Expr emptyUniqSet renamed
-
-ppr_Unfolding = PprUnfolding (panic "CoreUnfold:ppr_Unfolding")
-\end{code}
+Predicates
+~~~~~~~~~~
 
 \begin{code}
-ppr_uf_Expr in_scopes (Var v) = pprIdInUnfolding in_scopes v
-ppr_uf_Expr in_scopes (Lit l) = ppr ppr_Unfolding l
-
-ppr_uf_Expr in_scopes (Con c as)
-  = ppBesides [ppPStr SLIT("_!_ "), pprIdInUnfolding no_in_scopes c, ppSP,
-	   ppLbrack, ppIntersperse pp'SP{-'-} (map (pprParendUniType ppr_Unfolding) ts), ppRbrack,
-	   ppSP, ppLbrack, ppIntersperse pp'SP{-'-} (map (ppr_uf_Atom in_scopes) as), ppRbrack]
-ppr_uf_Expr in_scopes (Prim op as)
-  = ppBesides [ppPStr SLIT("_#_ "), ppr ppr_Unfolding op, ppSP,
-	   ppLbrack, ppIntersperse pp'SP{-'-} (map (pprParendUniType ppr_Unfolding) ts), ppRbrack,
-	   ppSP, ppLbrack, ppIntersperse pp'SP{-'-} (map (ppr_uf_Atom in_scopes) as), ppRbrack]
-
-ppr_uf_Expr in_scopes (Lam binder body)
-  = ppCat [ppChar '\\', ppr_uf_Binder binder,
-	   ppPStr SLIT("->"), ppr_uf_Expr (in_scopes `add1` binder) body]
-
-ppr_uf_Expr in_scopes (CoTyLam tyvar expr)
-  = ppCat [ppPStr SLIT("_/\\_"), interppSP ppr_Unfolding (tyvar:tyvars), ppStr "->",
-    	   ppr_uf_Expr in_scopes body]
-  where
-    (tyvars, body) = collect_tyvars expr
-
-    collect_tyvars (CoTyLam tyv e) = ( tyv:tyvs, e_after )
-      where (tyvs, e_after) = collect_tyvars e
-    collect_tyvars other_e	   = ( [], other_e )
-
-ppr_uf_Expr in_scopes expr@(App fun_expr atom)
-  = let
-	(fun, args) = collect_args expr []
-    in
-    ppCat [ppPStr SLIT("_APP_ "), ppr_uf_Expr in_scopes fun, ppLbrack,
-	   ppIntersperse pp'SP{-'-} (map (ppr_uf_Atom in_scopes) args), ppRbrack]
-  where
-    collect_args (App fun arg) args = collect_args fun (arg:args)
-    collect_args fun		 args = (fun, args)
-
-ppr_uf_Expr in_scopes (CoTyApp expr ty)
-  = ppCat [ppPStr SLIT("_TYAPP_ "), ppr_uf_Expr in_scopes expr,
-	ppChar '{', pprParendUniType ppr_Unfolding ty, ppChar '}']
-
-ppr_uf_Expr in_scopes (Case scrutinee alts)
-  = ppCat [ppPStr SLIT("case"), ppr_uf_Expr in_scopes scrutinee, ppStr "of {",
-	   pp_alts alts, ppChar '}']
-  where
-    pp_alts (AlgAlts  alts deflt)
-      = ppCat [ppPStr SLIT("_ALG_"),  ppCat (map pp_alg  alts), pp_deflt deflt]
-    pp_alts (PrimAlts alts deflt)
-      = ppCat [ppPStr SLIT("_PRIM_"), ppCat (map pp_prim alts), pp_deflt deflt]
-
-    pp_alg (con, params, rhs)
-      = ppBesides [pprIdInUnfolding no_in_scopes con, ppSP,
-		   ppIntersperse ppSP (map ppr_uf_Binder params),
-		   ppPStr SLIT(" -> "), ppr_uf_Expr (in_scopes `add_some` params) rhs, ppSemi]
-
-    pp_prim (lit, rhs)
-      = ppBesides [ppr ppr_Unfolding lit,
-		   ppPStr SLIT(" -> "), ppr_uf_Expr in_scopes rhs, ppSemi]
-
-    pp_deflt NoDefault = ppPStr SLIT("_NO_DEFLT_")
-    pp_deflt (BindDefault binder rhs)
-      = ppBesides [ppr_uf_Binder binder, ppPStr SLIT(" -> "),
-		   ppr_uf_Expr (in_scopes `add1` binder) rhs]
-
-ppr_uf_Expr in_scopes (Let (NonRec binder rhs) body)
-  = ppBesides [ppStr "let {", ppr_uf_Binder binder, ppPStr SLIT(" = "), ppr_uf_Expr in_scopes rhs,
-	ppStr "} in ", ppr_uf_Expr (in_scopes `add1` binder) body]
-
-ppr_uf_Expr in_scopes (Let (Rec pairs) body)
-  = ppBesides [ppStr "_LETREC_ {", ppIntersperse sep (map pp_pair pairs),
-	ppStr "} in ", ppr_uf_Expr new_in_scopes body]
-  where
-    sep = ppBeside ppSemi ppSP
-    new_in_scopes = in_scopes `add_some` map fst pairs
-
-    pp_pair (b, rhs) = ppCat [ppr_uf_Binder b, ppEquals, ppr_uf_Expr new_in_scopes rhs]
-
-ppr_uf_Expr in_scopes (SCC cc body)
-  = ASSERT(not (noCostCentreAttached cc))
-    ASSERT(not (currentOrSubsumedCosts cc))
-    ppBesides [ppStr "_scc_ { ", ppStr (showCostCentre ppr_Unfolding False{-not as string-} cc), ppStr " } ",  ppr_uf_Expr in_scopes body]
-
-ppr_uf_Expr in_scopes (Coerce _ _ _) = panic "ppr_uf_Expr:Coerce"
+okToInline
+	:: FormSummary	-- What the thing to be inlined is like
+	-> BinderInfo 	-- How the thing to be inlined occurs
+	-> Bool		-- True => it's small enough to inline
+	-> Bool		-- True => yes, inline it
+
+-- Always inline bottoms
+okToInline BottomForm occ_info small_enough
+  = True	-- Unless one of the type args is unboxed??
+		-- This used to be checked for, but I can't
+		-- see why so I've left it out.
+
+-- A WHNF can be inlined if it occurs once, or is small
+okToInline form occ_info small_enough
+ | is_whnf_form form
+ = small_enough || one_occ
+ where
+   one_occ = case occ_info of
+		OneOcc _ _ _ n_alts _ -> n_alts <= 1
+		other		      -> False
+   	
+   is_whnf_form VarForm   = True
+   is_whnf_form ValueForm = True
+   is_whnf_form other     = False
+    
+-- A non-WHNF can be inlined if it doesn't occur inside a lambda,
+-- and occurs exactly once or 
+--     occurs once in each branch of a case and is small
+okToInline OtherForm (OneOcc _ dup_danger _ n_alts _) small_enough 
+  = not (isDupDanger dup_danger) && (n_alts <= 1 || small_enough)
+
+okToInline form any_occ small_enough = False
 \end{code}
 
-\begin{code}
-ppr_uf_Binder :: Id -> Pretty
-ppr_uf_Binder v
-  = ppBesides [ppLparen, pprIdInUnfolding (unitUniqSet v) v, ppPStr SLIT(" :: "),
-	       ppr ppr_Unfolding (idType v), ppRparen]
-
-ppr_uf_Atom in_scopes (LitArg l) = ppr ppr_Unfolding l
-ppr_uf_Atom in_scopes (VarArg v) = pprIdInUnfolding in_scopes v
-END OLD -}
-\end{code}
diff --git a/ghc/compiler/coreSyn/CoreUtils.lhs b/ghc/compiler/coreSyn/CoreUtils.lhs
index de0d323b4b..f4cbb536de 100644
--- a/ghc/compiler/coreSyn/CoreUtils.lhs
+++ b/ghc/compiler/coreSyn/CoreUtils.lhs
@@ -18,11 +18,7 @@ module CoreUtils (
 	, maybeErrorApp
 	, nonErrorRHSs
 	, squashableDictishCcExpr
-{-	
-	coreExprArity,
-	isWrapperFor,
-
--}  ) where
+    ) where
 
 IMP_Ubiq()
 IMPORT_DELOOPER(IdLoop)	-- for pananoia-checking purposes
@@ -30,14 +26,13 @@ IMPORT_DELOOPER(IdLoop)	-- for pananoia-checking purposes
 import CoreSyn
 
 import CostCentre	( isDictCC, CostCentre, noCostCentre )
-import Id		( idType, mkSysLocal, getIdArity, isBottomingId,
+import Id		( idType, mkSysLocal, isBottomingId,
 			  toplevelishId, mkIdWithNewUniq, applyTypeEnvToId,
 			  dataConRepType,
 			  addOneToIdEnv, growIdEnvList, lookupIdEnv,
 			  isNullIdEnv, SYN_IE(IdEnv),
 			  GenId{-instances-}
 			)
-import IdInfo		( arityMaybe )
 import Literal		( literalType, isNoRepLit, Literal(..) )
 import Maybes		( catMaybes, maybeToBool )
 import PprCore
@@ -46,7 +41,7 @@ import PprType		( GenType{-instances-} )
 import Pretty		( ppAboves, ppStr )
 import PrelVals		( augmentId, buildId )
 import PrimOp		( primOpType, PrimOp(..) )
-import SrcLoc		( mkUnknownSrcLoc )
+import SrcLoc		( noSrcLoc )
 import TyVar		( cloneTyVar,
 			  isNullTyVarEnv, addOneToTyVarEnv, SYN_IE(TyVarEnv)
 			)
@@ -209,7 +204,7 @@ co_thing thing arg_exprs
 	in
 	getUnique `thenUs` \ uniq ->
 	let
-	    new_var  = mkSysLocal SLIT("a") uniq e_ty mkUnknownSrcLoc
+	    new_var  = mkSysLocal SLIT("a") uniq e_ty noSrcLoc
 	in
 	returnUs (VarArg new_var, Just (NonRec new_var other_expr))
 \end{code}
@@ -222,94 +217,6 @@ argToExpr (VarArg v)   = Var v
 argToExpr (LitArg lit) = Lit lit
 \end{code}
 
-\begin{code}
-{-LATER:
-coreExprArity
-	:: (Id -> Maybe (GenCoreExpr bndr Id))
-	-> GenCoreExpr bndr Id
-	-> Int
-coreExprArity f (Lam _ expr) = coreExprArity f expr + 1
-coreExprArity f (CoTyLam _ expr) = coreExprArity f expr
-coreExprArity f (App expr arg) = max (coreExprArity f expr - 1) 0
-coreExprArity f (CoTyApp expr _) = coreExprArity f expr
-coreExprArity f (Var v) = max further info
-   where
-	further
-	     = case f v of
-		Nothing -> 0
-		Just expr -> coreExprArity f expr
-	info = case (arityMaybe (getIdArity v)) of
-		Nothing    -> 0
-		Just arity -> arity
-coreExprArity f _ = 0
-\end{code}
-
-@isWrapperFor@: we want to see exactly:
-\begin{verbatim}
-/\ ... \ args -> case <arg> of ... -> case <arg> of ... -> wrkr <stuff>
-\end{verbatim}
-
-Probably a little too HACKY [WDP].
-
-\begin{code}
-isWrapperFor :: CoreExpr -> Id -> Bool
-
-expr `isWrapperFor` var
-  = case (collectBinders  expr) of { (_, _, args, body) -> -- lambdas off the front
-    unravel_casing args body
-    --NO, THANKS: && not (null args)
-    }
-  where
-    var's_worker = getWorkerId (getIdStrictness var)
-
-    is_elem = isIn "isWrapperFor"
-
-    --------------
-    unravel_casing case_ables (Case scrut alts)
-      = case (collectArgs scrut) of { (fun, _, _, vargs) ->
-	case fun of
-	  Var scrut_var -> let
-				answer =
-				     scrut_var /= var && all (doesn't_mention var) vargs
-				  && scrut_var `is_elem` case_ables
-				  && unravel_alts case_ables alts
-			     in
-			     answer
-
-	  _ -> False
-	}
-
-    unravel_casing case_ables other_expr
-      = case (collectArgs other_expr) of { (fun, _, _, vargs) ->
-	case fun of
-	  Var wrkr -> let
-			    answer =
-				-- DOESN'T WORK: wrkr == var's_worker
-				wrkr /= var
-			     && isWorkerId wrkr
-			     && all (doesn't_mention var)  vargs
-			     && all (only_from case_ables) vargs
-			in
-			answer
-
-	  _ -> False
-	}
-
-    --------------
-    unravel_alts case_ables (AlgAlts [(_,params,rhs)] NoDefault)
-      = unravel_casing (params ++ case_ables) rhs
-    unravel_alts case_ables other = False
-
-    -------------------------
-    doesn't_mention var (ValArg (VarArg v)) = v /= var
-    doesn't_mention var other = True
-
-    -------------------------
-    only_from case_ables (ValArg (VarArg v)) = v `is_elem` case_ables
-    only_from case_ables other = True
--}
-\end{code}
-
 All the following functions operate on binders, perform a uniform
 transformation on them; ie. the function @(\ x -> (x,False))@
 annotates all binders with False.
diff --git a/ghc/compiler/coreSyn/FreeVars.lhs b/ghc/compiler/coreSyn/FreeVars.lhs
index 979fd670f3..6a83c06717 100644
--- a/ghc/compiler/coreSyn/FreeVars.lhs
+++ b/ghc/compiler/coreSyn/FreeVars.lhs
@@ -10,7 +10,7 @@ module FreeVars (
 	freeVars,
 
 	-- cheap and cheerful variant...
-	addTopBindsFVs,
+	addTopBindsFVs, addExprFVs,
 
 	freeVarsOf, freeTyVarsOf,
 	SYN_IE(FVCoreExpr), SYN_IE(FVCoreBinding),
@@ -30,7 +30,7 @@ import Id		( idType, getIdArity, isBottomingId,
 			  elementOfIdSet, minusIdSet, unionManyIdSets,
 			  SYN_IE(IdSet)
 			)
-import IdInfo		( arityMaybe )
+import IdInfo		( ArityInfo(..) )
 import PrimOp		( PrimOp(..) )
 import Type		( tyVarsOfType )
 import TyVar		( emptyTyVarSet, unitTyVarSet, minusTyVarSet,
@@ -144,9 +144,10 @@ fvExpr id_cands tyvar_cands (Var v)
   where
     leakiness
       | isBottomingId v = lEAK_FREE_BIG	-- Hack
-      | otherwise       = case arityMaybe (getIdArity v) of
-			    Nothing    -> lEAK_FREE_0
-			    Just arity -> LeakFree arity
+      | otherwise       = case getIdArity v of
+			    UnknownArity       -> lEAK_FREE_0
+			    ArityAtLeast arity -> LeakFree arity
+			    ArityExactly arity -> LeakFree arity
 
 fvExpr id_cands tyvar_cands (Lit k)
   = (FVInfo noFreeIds noFreeTyVars lEAK_FREE_0, AnnLit k)
diff --git a/ghc/compiler/coreSyn/PprCore.lhs b/ghc/compiler/coreSyn/PprCore.lhs
index 57945cbc10..6c5ea90673 100644
--- a/ghc/compiler/coreSyn/PprCore.lhs
+++ b/ghc/compiler/coreSyn/PprCore.lhs
@@ -11,7 +11,7 @@
 #include "HsVersions.h"
 
 module PprCore (
-	pprCoreExpr,
+	pprCoreExpr, pprIfaceUnfolding, 
 	pprCoreBinding,
 	pprBigCoreBinder,
 	pprTypedCoreBinder
@@ -32,10 +32,10 @@ import Id		( idType, getIdInfo, getIdStrictness, isTupleCon,
 			)
 import IdInfo		( ppIdInfo, StrictnessInfo(..) )
 import Literal		( Literal{-instances-} )
-import Name		( isSymLexeme )
+import Name		( OccName, parenInCode )
 import Outputable	-- quite a few things
 import PprEnv
-import PprType		( pprParendGenType, GenType{-instances-}, GenTyVar{-instance-} )
+import PprType		( pprParendGenType, pprTyVarBndr, GenType{-instances-}, GenTyVar{-instance-} )
 import PprStyle		( PprStyle(..) )
 import Pretty
 import PrimOp		( PrimOp{-instances-} )
@@ -68,7 +68,7 @@ print something.
 pprCoreBinding :: PprStyle -> CoreBinding -> Pretty
 
 pprGenCoreBinding
-	:: (Eq tyvar, Outputable tyvar,
+	:: (Eq tyvar,  Outputable tyvar,
 	    Eq uvar,  Outputable uvar,
 	    Outputable bndr,
 	    Outputable occ)
@@ -80,15 +80,16 @@ pprGenCoreBinding
 	-> Pretty
 
 pprGenCoreBinding sty pbdr1 pbdr2 pocc bind
-  = ppr_bind (init_ppr_env sty pbdr1 pbdr2 pocc) bind
+  = ppr_bind (init_ppr_env sty (ppr sty) pbdr1 pbdr2 pocc) bind
 
-init_ppr_env sty pbdr1 pbdr2 pocc
+init_ppr_env sty tvbndr pbdr1 pbdr2 pocc
   = initPprEnv sty
 	(Just (ppr sty)) -- literals
 	(Just (ppr sty)) -- data cons
 	(Just (ppr sty)) -- primops
 	(Just (\ cc -> ppStr (showCostCentre sty True cc)))
-	(Just (ppr sty)) -- tyvars
+	(Just tvbndr)	 -- tyvar binders
+	(Just (ppr sty)) -- tyvar occs
 	(Just (ppr sty)) -- usage vars
 	(Just pbdr1) (Just pbdr2) (Just pocc) -- value vars
 	(Just (pprParendGenType sty)) -- types
@@ -120,7 +121,8 @@ pprCoreExpr
 pprCoreExpr = pprGenCoreExpr
 
 pprGenCoreExpr, pprParendCoreExpr
-	:: (Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar,
+	:: (Eq tyvar, Outputable tyvar,
+	    Eq uvar, Outputable uvar,
 	    Outputable bndr,
 	    Outputable occ)
 	=> PprStyle
@@ -131,7 +133,7 @@ pprGenCoreExpr, pprParendCoreExpr
 	-> Pretty
 
 pprGenCoreExpr sty pbdr1 pbdr2 pocc expr
-  = ppr_expr (init_ppr_env sty pbdr1 pbdr2 pocc) expr
+  = ppr_expr (init_ppr_env sty (ppr sty) pbdr1 pbdr2 pocc) expr
 
 pprParendCoreExpr sty pbdr1 pbdr2 pocc expr
   = let
@@ -143,14 +145,23 @@ pprParendCoreExpr sty pbdr1 pbdr2 pocc expr
     in
     parenify (pprGenCoreExpr sty pbdr1 pbdr2 pocc expr)
 
+-- Printer for unfoldings in interfaces
+pprIfaceUnfolding :: CoreExpr -> Pretty
+pprIfaceUnfolding = ppr_expr env 
+  where
+    env = init_ppr_env PprInterface (pprTyVarBndr PprInterface)
+				    (pprTypedCoreBinder PprInterface)
+				    (pprTypedCoreBinder PprInterface)
+				    (ppr PprInterface)
+
 ppr_core_arg sty pocc arg
-  = ppr_arg (init_ppr_env sty pocc pocc pocc) arg
+  = ppr_arg (init_ppr_env sty (ppr sty) pocc pocc pocc) arg
 
 ppr_core_alts sty pbdr1 pbdr2 pocc alts
-  = ppr_alts (init_ppr_env sty pbdr1 pbdr2 pocc) alts
+  = ppr_alts (init_ppr_env sty (ppr sty) pbdr1 pbdr2 pocc) alts
 
 ppr_core_default sty pbdr1 pbdr2 pocc deflt
-  = ppr_default (init_ppr_env sty pbdr1 pbdr2 pocc) deflt
+  = ppr_default (init_ppr_env sty (ppr sty) pbdr1 pbdr2 pocc) deflt
 \end{code}
 
 %************************************************************************
@@ -207,13 +218,11 @@ ppr_bind pe (NonRec val_bdr expr)
 	 4 (ppr_expr pe expr)
 
 ppr_bind pe (Rec binds)
-  = ppAboves [ ppStr "{- Rec -}",
-	       ppAboves (map ppr_pair binds),
-	       ppStr "{- end Rec -}" ]
+  = ppAboves (map ppr_pair binds)
   where
     ppr_pair (val_bdr, expr)
       = ppHang (ppCat [pMajBndr pe val_bdr, ppEquals])
-	     4 (ppr_expr pe expr)
+	     4 (ppr_expr pe expr `ppBeside` ppSemi)
 \end{code}
 
 \begin{code}
@@ -245,9 +254,9 @@ ppr_expr pe expr@(Lam _ _)
   = let
 	(uvars, tyvars, vars, body) = collectBinders expr
     in
-    ppHang (ppCat [pp_vars SLIT("_/u\\_") (pUVar    pe) uvars,
-		   pp_vars SLIT("_/\\_")  (pTyVar   pe) tyvars,
-		   pp_vars SLIT("\\")     (pMinBndr pe) vars])
+    ppHang (ppCat [pp_vars SLIT("/u\\") (pUVar    pe) uvars,
+		   pp_vars SLIT("/\\")  (pTyVarB  pe) tyvars,
+		   pp_vars SLIT("\\")   (pMinBndr pe) vars])
 	 4 (ppr_expr pe body)
   where
     pp_vars lam pp [] = ppNil
@@ -283,12 +292,12 @@ ppr_expr pe (Case expr alts)
 	ppr_rhs (PrimAlts ((_,expr):[]) NoDefault)  = ppr_expr pe expr
     in 
     ppSep
-    [ppSep [ppPStr SLIT("case"), ppNest 4 (ppr_parend_expr pe expr), ppStr "of {", ppr_alt alts],
-	 ppBeside (ppr_rhs alts) (ppStr "}")]
+    [ppSep [ppPStr SLIT("case"), ppNest 4 (ppr_expr pe expr), ppStr "of {", ppr_alt alts],
+	 ppBeside (ppr_rhs alts) (ppStr ";}")]
 
   | otherwise -- default "case" printing
   = ppSep
-    [ppSep [ppPStr SLIT("case"), ppNest 4 (ppr_parend_expr pe expr), ppStr "of {"],
+    [ppSep [ppPStr SLIT("case"), ppNest 4 (ppr_expr pe expr), ppStr "of {"],
      ppNest 2 (ppr_alts pe alts),
      ppStr "}"]
 
@@ -312,19 +321,22 @@ ppr_expr pe (Let bind@(NonRec val_bdr rhs) expr@(Let _ _))
 
 -- general case (recursive case, too)
 ppr_expr pe (Let bind expr)
-  = ppSep [ppHang (ppStr "let {") 2 (ppr_bind pe bind),
+  = ppSep [ppHang (ppStr keyword) 2 (ppr_bind pe bind),
 	   ppHang (ppStr "} in ") 2 (ppr_expr pe expr)]
+  where
+    keyword = case bind of
+		Rec _      -> "letrec {"
+		NonRec _ _ -> "let {"
 
 ppr_expr pe (SCC cc expr)
   = ppSep [ppCat [ppPStr SLIT("_scc_"), pSCC pe cc],
 	   ppr_parend_expr pe expr ]
 
 ppr_expr pe (Coerce c ty expr)
-  = ppSep [ppCat [ppPStr SLIT("_coerce_"), pp_coerce c],
-	   pTy pe ty, ppr_parend_expr pe expr ]
+  = ppSep [pp_coerce c, pTy pe ty, ppr_parend_expr pe expr ]
   where
-    pp_coerce (CoerceIn  v) = ppBeside (ppStr "{-in-}")  (ppr (pStyle pe) v)
-    pp_coerce (CoerceOut v) = ppBeside (ppStr "{-out-}") (ppr (pStyle pe) v)
+    pp_coerce (CoerceIn  v) = ppBeside (ppStr "_coerce_in_")  (ppr (pStyle pe) v)
+    pp_coerce (CoerceOut v) = ppBeside (ppStr "_coerce_out_") (ppr (pStyle pe) v)
 
 only_one_alt (AlgAlts []     (BindDefault _ _)) = True
 only_one_alt (AlgAlts (_:[])  NoDefault) 	= True
@@ -332,8 +344,7 @@ only_one_alt (PrimAlts []    (BindDefault _ _)) = True
 only_one_alt (PrimAlts (_:[]) NoDefault) 	= True
 only_one_alt _					= False 
 
-ppr_alt_con con pp_con
-  = if isSymLexeme con then ppParens pp_con else pp_con
+ppr_alt_con con pp_con = if parenInCode (getOccName con) then ppParens pp_con else pp_con
 \end{code}
 
 \begin{code}
@@ -349,14 +360,14 @@ ppr_alts pe (AlgAlts alts deflt)
 			   ppInterleave ppSP (map (pMinBndr pe) params),
 			   ppStr "->"]
 	       )
-	     4 (ppr_expr pe expr)
+	     4 (ppr_expr pe expr `ppBeside` ppSemi)
 
 ppr_alts pe (PrimAlts alts deflt)
   = ppAboves [ ppAboves (map ppr_alt alts), ppr_default pe deflt ]
   where
     ppr_alt (lit, expr)
       = ppHang (ppCat [pLit pe lit, ppStr "->"])
-	     4 (ppr_expr pe expr)
+	     4 (ppr_expr pe expr `ppBeside` ppSemi)
 \end{code}
 
 \begin{code}
@@ -364,7 +375,7 @@ ppr_default pe NoDefault = ppNil
 
 ppr_default pe (BindDefault val_bdr expr)
   = ppHang (ppCat [pMinBndr pe val_bdr, ppStr "->"])
-	 4 (ppr_expr pe expr)
+	 4 (ppr_expr pe expr `ppBeside` ppSemi)
 \end{code}
 
 \begin{code}
@@ -387,8 +398,7 @@ pprBigCoreBinder sty binder
 
     pragmas =
 	ifnotPprForUser sty
-	 (ppIdInfo sty binder False{-no specs, thanks-} id nullIdEnv
-	  (getIdInfo binder))
+	 (ppIdInfo sty False{-no specs, thanks-} (getIdInfo binder))
 
 pprBabyCoreBinder sty binder
   = ppCat [ppr sty binder, pp_strictness]
@@ -402,7 +412,5 @@ pprBabyCoreBinder sty binder
 		-- ppStr ("{- " ++ (showList xx "") ++ " -}")
 
 pprTypedCoreBinder sty binder
-  = ppBesides [ppLparen, ppCat [ppr sty binder,
-	ppStr "::", ppr sty (idType binder)],
-	ppRparen]
+  = ppBesides [ppr sty binder, ppStr "::", pprParendGenType sty (idType binder)]
 \end{code}
diff --git a/ghc/compiler/deSugar/DsBinds.lhs b/ghc/compiler/deSugar/DsBinds.lhs
index 0331a37983..657e2652f1 100644
--- a/ghc/compiler/deSugar/DsBinds.lhs
+++ b/ghc/compiler/deSugar/DsBinds.lhs
@@ -452,6 +452,10 @@ dsMonoBinds auto_scc is_rec tyvars dicts binder_subst (AndMonoBinds  binds_1 bin
 %==============================================
 
 \begin{code}
+dsMonoBinds auto_scc is_rec tyvars dicts binder_subst (CoreMonoBind var core_expr)
+  = doSccAuto auto_scc [var] core_expr	`thenDs` \ sccd_core_expr -> 
+    returnDs [(binder_subst var, mkLam tyvars dicts sccd_core_expr)]
+
 dsMonoBinds auto_scc is_rec tyvars dicts binder_subst (VarMonoBind var expr)
   = dsExpr expr		`thenDs` \ core_expr ->
     doSccAuto auto_scc [var] core_expr	`thenDs` \ sccd_core_expr -> 
diff --git a/ghc/compiler/deSugar/DsCCall.lhs b/ghc/compiler/deSugar/DsCCall.lhs
index c8644dc893..e8f20fa4de 100644
--- a/ghc/compiler/deSugar/DsCCall.lhs
+++ b/ghc/compiler/deSugar/DsCCall.lhs
@@ -16,17 +16,19 @@ import DsMonad
 import DsUtils
 
 import CoreUtils	( coreExprType )
-import Id		( dataConArgTys, mkTupleCon )
+import Id		( dataConArgTys )
 import Maybes		( maybeToBool )
 import PprStyle		( PprStyle(..) )
 import PprType		( GenType{-instances-} )
 import Pretty
 import PrelVals		( packStringForCId )
 import PrimOp		( PrimOp(..) )
-import Type		( isPrimType, maybeAppDataTyConExpandingDicts, eqTy, maybeBoxedPrimType )
-import TysPrim		( byteArrayPrimTy, realWorldTy,  realWorldStatePrimTy )
+import Type		( isPrimType, maybeAppDataTyConExpandingDicts, maybeAppTyCon,
+			  eqTy, maybeBoxedPrimType )
+import TysPrim		( byteArrayPrimTy, realWorldTy,  realWorldStatePrimTy,
+			  byteArrayPrimTyCon, mutableByteArrayPrimTyCon )
 import TysWiredIn	( getStatePairingConInfo,
-			  realWorldStateTy, stateDataCon,
+			  realWorldStateTy, stateDataCon, pairDataCon, unitDataCon,
 			  stringTy
 			)
 import Util		( pprPanic, pprError, panic )
@@ -121,15 +123,13 @@ unboxArg arg
     -- oops: we can't see the data constructors!!!
   = can't_see_datacons_error "argument" arg_ty
 
-  -- Byte-arrays, both mutable and otherwise
-  -- (HACKy method -- but we really don't want the TyCons wired-in...) [WDP 94/10]
+  -- Byte-arrays, both mutable and otherwise; hack warning
   | is_data_type &&
     length data_con_arg_tys == 2 &&
-    not (isPrimType data_con_arg_ty1) &&
-    isPrimType data_con_arg_ty2
+    maybeToBool maybe_arg2_tycon &&
+    (arg2_tycon ==  byteArrayPrimTyCon ||
+     arg2_tycon ==  mutableByteArrayPrimTyCon)
     -- and, of course, it is an instance of CCallable
---  ( tycon == byteArrayTyCon ||
---    tycon == mutableByteArrayTyCon )
   = newSysLocalsDs data_con_arg_tys		`thenDs` \ vars@[ixs_var, arr_cts_var] ->
     returnDs (Var arr_cts_var,
 	      \ body -> Case arg (AlgAlts [(the_data_con,vars,body)]
@@ -160,6 +160,9 @@ unboxArg arg
     data_con_arg_tys = dataConArgTys the_data_con tycon_arg_tys
     (data_con_arg_ty1 : data_con_arg_ty2 : _) = data_con_arg_tys
 
+    maybe_arg2_tycon = maybeAppTyCon data_con_arg_ty2
+    Just (arg2_tycon,_) = maybe_arg2_tycon
+
 can't_see_datacons_error thing ty
   = pprError "ERROR: Can't see the data constructor(s) for _ccall_/_casm_ "
 	     (ppBesides [ppStr thing, ppStr "; type: ", ppr PprForUser ty])
@@ -167,9 +170,6 @@ can't_see_datacons_error thing ty
 
 
 \begin{code}
-tuple_con_2 = mkTupleCon 2 -- out here to avoid CAF (sigh)
-covar_tuple_con_0 = Var (mkTupleCon 0) -- ditto
-
 boxResult :: Type				-- Type of desired result
 	  -> DsM (Type,			-- Type of the result of the ccall itself
 		  CoreExpr -> CoreExpr)	-- Wrapper for the ccall
@@ -191,7 +191,7 @@ boxResult result_ty
     mkConDs stateDataCon [TyArg realWorldTy, VarArg (Var prim_state_id)]  `thenDs` \ new_state ->
     mkConDs the_data_con (map TyArg tycon_arg_tys ++ [VarArg (Var prim_result_id)]) `thenDs` \ the_result ->
 
-    mkConDs tuple_con_2
+    mkConDs pairDataCon
 	    [TyArg result_ty, TyArg realWorldStateTy, VarArg the_result, VarArg new_state]
 							`thenDs` \ the_pair ->
     let
@@ -210,8 +210,8 @@ boxResult result_ty
 
     mkConDs stateDataCon [TyArg realWorldTy, VarArg (Var prim_state_id)]
 						`thenDs` \ new_state ->
-    mkConDs tuple_con_2
-	    [TyArg result_ty, TyArg realWorldStateTy, VarArg covar_tuple_con_0, VarArg new_state]
+    mkConDs pairDataCon
+	    [TyArg result_ty, TyArg realWorldStateTy, VarArg (Var unitDataCon), VarArg new_state]
 						`thenDs` \ the_pair ->
 
     let
diff --git a/ghc/compiler/deSugar/DsExpr.lhs b/ghc/compiler/deSugar/DsExpr.lhs
index cf1cf58d5c..169fd50d9c 100644
--- a/ghc/compiler/deSugar/DsExpr.lhs
+++ b/ghc/compiler/deSugar/DsExpr.lhs
@@ -13,7 +13,7 @@ IMPORT_DELOOPER(DsLoop)		-- partly to get dsBinds, partly to chk dsExpr
 
 import HsSyn		( failureFreePat,
 			  HsExpr(..), OutPat(..), HsLit(..), ArithSeqInfo(..),
-			  Stmt(..), Match(..), Qualifier, HsBinds, PolyType,
+			  Stmt(..), Match(..), Qualifier, HsBinds, HsType,
 			  GRHSsAndBinds
 			)
 import TcHsSyn		( SYN_IE(TypecheckedHsExpr), SYN_IE(TypecheckedHsBinds),
@@ -32,17 +32,15 @@ import DsUtils		( mkAppDs, mkConDs, mkPrimDs, dsExprToAtom,
 			)
 import Match		( matchWrapper )
 
-import CoreUnfold	( Unfolding )
 import CoreUtils	( coreExprType, substCoreExpr, argToExpr,
 			  mkCoreIfThenElse, unTagBinders )
 import CostCentre	( mkUserCC )
 import FieldLabel	( fieldLabelType, FieldLabel )
-import Id		( mkTupleCon, idType, nullIdEnv, addOneToIdEnv,
-			  getIdUnfolding, dataConArgTys, dataConFieldLabels,
+import Id		( idType, nullIdEnv, addOneToIdEnv,
+			  dataConArgTys, dataConFieldLabels,
 			  recordSelectorFieldLabel
 			)
 import Literal		( mkMachInt, Literal(..) )
-import MagicUFs		( MagicUnfoldingFun )
 import Name		( Name{--O only-} )
 import PprStyle		( PprStyle(..) )
 import PprType		( GenType )
@@ -54,7 +52,7 @@ import Type		( splitSigmaTy, splitFunTy, typePrimRep,
 			  maybeBoxedPrimType
 			)
 import TysPrim		( voidTy )
-import TysWiredIn	( mkTupleTy, nilDataCon, consDataCon,
+import TysWiredIn	( mkTupleTy, tupleCon, nilDataCon, consDataCon,
 			  charDataCon, charTy
 			)
 import TyVar		( nullTyVarEnv, addOneToTyVarEnv, GenTyVar{-instance Eq-} )
@@ -309,7 +307,7 @@ dsExpr (ExplicitListOut ty xs)
 
 dsExpr (ExplicitTuple expr_list)
   = mapDs dsExpr expr_list	  `thenDs` \ core_exprs  ->
-    mkConDs (mkTupleCon (length expr_list))
+    mkConDs (tupleCon (length expr_list))
 	    (map (TyArg . coreExprType) core_exprs ++ map VarArg core_exprs)
 
 -- Two cases, one for ordinary constructors and one for newtype constructors
@@ -505,7 +503,7 @@ dsExpr (Dictionary dicts methods)
       1 -> returnDs (head core_d_and_ms) -- just a single Id
 
       _ ->	    -- tuple 'em up
-	   mkConDs (mkTupleCon num_of_d_and_ms)
+	   mkConDs (tupleCon num_of_d_and_ms)
 		   (map (TyArg . coreExprType) core_d_and_ms ++ map VarArg core_d_and_ms)
     )
   where
@@ -533,8 +531,8 @@ dsExpr (ClassDictLam dicts methods expr)
   where
     num_of_d_and_ms	    = length dicts + length methods
     dicts_and_methods	    = dicts ++ methods
-    tuple_ty		    = mkTupleTy    num_of_d_and_ms (map idType dicts_and_methods)
-    tuple_con		    = mkTupleCon   num_of_d_and_ms
+    tuple_ty		    = mkTupleTy  num_of_d_and_ms (map idType dicts_and_methods)
+    tuple_con		    = tupleCon   num_of_d_and_ms
 
 #ifdef DEBUG
 -- HsSyn constructs that just shouldn't be here:
diff --git a/ghc/compiler/deSugar/DsHsSyn.lhs b/ghc/compiler/deSugar/DsHsSyn.lhs
index 08288bd97c..d7e54ef40a 100644
--- a/ghc/compiler/deSugar/DsHsSyn.lhs
+++ b/ghc/compiler/deSugar/DsHsSyn.lhs
@@ -62,6 +62,7 @@ collectTypedMonoBinders EmptyMonoBinds	      = []
 collectTypedMonoBinders (PatMonoBind pat _ _) = collectTypedPatBinders pat
 collectTypedMonoBinders (FunMonoBind f _ _ _) = [f]
 collectTypedMonoBinders (VarMonoBind v _)     = [v]
+collectTypedMonoBinders (CoreMonoBind v _)     = [v]
 collectTypedMonoBinders (AndMonoBinds bs1 bs2)
  = collectTypedMonoBinders bs1 ++ collectTypedMonoBinders bs2
 
diff --git a/ghc/compiler/deSugar/DsListComp.lhs b/ghc/compiler/deSugar/DsListComp.lhs
index 8be75c1253..6f51268640 100644
--- a/ghc/compiler/deSugar/DsListComp.lhs
+++ b/ghc/compiler/deSugar/DsListComp.lhs
@@ -129,8 +129,11 @@ deListComp expr (FilterQual filt : quals) list	-- rule B above
     deListComp expr quals list `thenDs` \ core_rest ->
     returnDs ( mkCoreIfThenElse core_filt core_rest list )
 
+-- [e | let B, qs] = let B in [e | qs]
 deListComp expr (LetQual binds : quals) list
-  = panic "deListComp:LetQual"
+  = dsBinds False binds		`thenDs` \ core_binds ->
+    deListComp expr quals list	`thenDs` \ core_rest ->
+    returnDs (mkCoLetsAny core_binds core_rest)
 
 deListComp expr ((GeneratorQual pat list1):quals) core_list2 -- rule A' above
   = dsExpr list1		    `thenDs` \ core_list1 ->
diff --git a/ghc/compiler/deSugar/DsMonad.lhs b/ghc/compiler/deSugar/DsMonad.lhs
index 3ea0bc2eb1..bf3f5f0878 100644
--- a/ghc/compiler/deSugar/DsMonad.lhs
+++ b/ghc/compiler/deSugar/DsMonad.lhs
@@ -37,7 +37,7 @@ import Id		( mkSysLocal, mkIdWithNewUniq,
 import PprType		( GenType, GenTyVar )
 import PprStyle		( PprStyle(..) )
 import Pretty
-import SrcLoc		( unpackSrcLoc, mkUnknownSrcLoc, SrcLoc )
+import SrcLoc		( noSrcLoc, SrcLoc )
 import TcHsSyn		( SYN_IE(TypecheckedPat) )
 import TyVar		( nullTyVarEnv, cloneTyVar, GenTyVar{-instance Eq-} )
 import Unique		( Unique{-instances-} )
@@ -75,7 +75,7 @@ initDs  :: UniqSupply
 	-> (a, DsWarnings)
 
 initDs init_us env mod_name action
-  = action init_us mkUnknownSrcLoc module_and_group env emptyBag
+  = action init_us noSrcLoc module_and_group env emptyBag
   where
     module_and_group = (mod_name, grp_name)
     grp_name  = case opt_SccGroup of
@@ -173,10 +173,9 @@ uniqSMtoDsM :: UniqSM a -> DsM a
 uniqSMtoDsM u_action us loc mod_and_grp env warns
   = (u_action us, warns)
 
-getSrcLocDs :: DsM (String, String)
+getSrcLocDs :: DsM SrcLoc
 getSrcLocDs us loc mod_and_grp env warns
-  = case (unpackSrcLoc loc) of { (x,y) ->
-    ((_UNPK_ x, _UNPK_ y), warns) }
+  = (loc, warns)
 
 putSrcLocDs :: SrcLoc -> DsM a -> DsM a
 putSrcLocDs new_loc expr us old_loc mod_and_grp env warns
diff --git a/ghc/compiler/deSugar/DsUtils.lhs b/ghc/compiler/deSugar/DsUtils.lhs
index 66472b77a1..3b767bb2a2 100644
--- a/ghc/compiler/deSugar/DsUtils.lhs
+++ b/ghc/compiler/deSugar/DsUtils.lhs
@@ -31,7 +31,7 @@ IMP_Ubiq()
 IMPORT_DELOOPER(DsLoop)		( match, matchSimply )
 
 import HsSyn		( HsExpr(..), OutPat(..), HsLit(..),
-			  Match, HsBinds, Stmt, Qualifier, PolyType, ArithSeqInfo )
+			  Match, HsBinds, Stmt, Qualifier, HsType, ArithSeqInfo )
 import TcHsSyn		( SYN_IE(TypecheckedPat) )
 import DsHsSyn		( outPatType )
 import CoreSyn
@@ -41,19 +41,21 @@ import DsMonad
 import CoreUtils	( coreExprType, mkCoreIfThenElse )
 import PprStyle		( PprStyle(..) )
 import PrelVals		( iRREFUT_PAT_ERROR_ID, voidId )
-import Pretty		( ppShow )
-import Id		( idType, dataConArgTys, mkTupleCon,
+import Pretty		( ppShow, ppBesides, ppStr )
+import Id		( idType, dataConArgTys, 
 --			  pprId{-ToDo:rm-},
 			  SYN_IE(DataCon), SYN_IE(DictVar), SYN_IE(Id), GenId )
 import Literal		( Literal(..) )
-import TyCon		( mkTupleTyCon, isNewTyCon, tyConDataCons )
+import TyCon		( isNewTyCon, tyConDataCons )
 import Type		( mkTyVarTys, mkRhoTy, mkForAllTys, mkFunTy,
 			  mkTheta, isUnboxedType, applyTyCon, getAppTyCon
 			)
 import TysPrim		( voidTy )
+import TysWiredIn	( tupleTyCon, unitDataCon, tupleCon )
 import UniqSet		( mkUniqSet, minusUniqSet, uniqSetToList, SYN_IE(UniqSet) )
 import Util		( panic, assertPanic{-, pprTrace ToDo:rm-} )
 import Usage		( SYN_IE(UVar) )
+import SrcLoc		( SrcLoc {- instance Outputable -} )
 --import PprCore{-ToDo:rm-}
 --import PprType--ToDo:rm
 --import Pretty--ToDo:rm
@@ -312,9 +314,9 @@ mkErrorAppDs :: Id 		-- The error function
 	     -> DsM CoreExpr
 
 mkErrorAppDs err_id ty msg
-  = getSrcLocDs			`thenDs` \ (file, line) ->
+  = getSrcLocDs			`thenDs` \ src_loc ->
     let
-	full_msg = file ++ "|" ++ line ++ "|" ++msg
+	full_msg = ppShow 80 (ppBesides [ppr PprForUser src_loc, ppStr ": ", ppStr msg])
 	msg_lit  = NoRepStr (_PK_ full_msg)
     in
     returnDs (mkApp (Var err_id) [] [ty] [LitArg msg_lit])
@@ -449,7 +451,7 @@ mkTupleBind tyvars dicts local_global_prs tuple_expr
     tuple_var_ty
       = mkForAllTys tyvars $
 	mkRhoTy theta	   $
-	applyTyCon (mkTupleTyCon no_of_binders)
+	applyTyCon (tupleTyCon no_of_binders)
 		   (map idType locals)
       where
 	theta = mkTheta (map idType dicts)
@@ -477,9 +479,9 @@ has only one element, it is the identity function.
 \begin{code}
 mkTupleExpr :: [Id] -> CoreExpr
 
-mkTupleExpr []	 = Con (mkTupleCon 0) []
+mkTupleExpr []	 = Con unitDataCon []
 mkTupleExpr [id] = Var id
-mkTupleExpr ids	 = mkCon (mkTupleCon (length ids))
+mkTupleExpr ids	 = mkCon (tupleCon (length ids))
 			 [{-usages-}]
 			 (map idType ids)
 			 [ VarArg i | i <- ids ]
@@ -508,7 +510,7 @@ mkTupleSelector expr [var] should_be_the_same_var
     expr
 
 mkTupleSelector expr vars the_var
- = Case expr (AlgAlts [(mkTupleCon arity, vars, Var the_var)]
+ = Case expr (AlgAlts [(tupleCon arity, vars, Var the_var)]
 			  NoDefault)
  where
    arity = length vars
diff --git a/ghc/compiler/deSugar/Match.lhs b/ghc/compiler/deSugar/Match.lhs
index 72a4b85edf..c822765110 100644
--- a/ghc/compiler/deSugar/Match.lhs
+++ b/ghc/compiler/deSugar/Match.lhs
@@ -26,7 +26,7 @@ import MatchCon		( matchConFamily )
 import MatchLit		( matchLiterals )
 
 import FieldLabel	( FieldLabel {- Eq instance -} )
-import Id		( idType, mkTupleCon, dataConFieldLabels,
+import Id		( idType, dataConFieldLabels,
 			  dataConArgTys, recordSelectorFieldLabel,
 			  GenId{-instance-}
 			)
@@ -43,7 +43,7 @@ import TysPrim		( intPrimTy, charPrimTy, floatPrimTy, doublePrimTy,
 			)
 import TysWiredIn	( nilDataCon, consDataCon, mkTupleTy, mkListTy,
 			  charTy, charDataCon, intTy, intDataCon,
-			  floatTy, floatDataCon, doubleTy,
+			  floatTy, floatDataCon, doubleTy, tupleCon,
 			  doubleDataCon, stringTy, addrTy,
 			  addrDataCon, wordTy, wordDataCon
 			)
@@ -363,7 +363,7 @@ tidy1 v (TuplePat pats) match_result
   where
     arity = length pats
     tuple_ConPat
-      = ConPat (mkTupleCon arity)
+      = ConPat (tupleCon arity)
 	       (mkTupleTy arity (map outPatType pats))
 	       pats
 
diff --git a/ghc/compiler/deSugar/MatchLit.lhs b/ghc/compiler/deSugar/MatchLit.lhs
index 26206ffb17..53ef74dff3 100644
--- a/ghc/compiler/deSugar/MatchLit.lhs
+++ b/ghc/compiler/deSugar/MatchLit.lhs
@@ -12,7 +12,7 @@ IMP_Ubiq()
 IMPORT_DELOOPER(DsLoop)		-- break match-ish and dsExpr-ish loops
 
 import HsSyn		( HsLit(..), OutPat(..), HsExpr(..),
-			  Match, HsBinds, Stmt, Qualifier, PolyType, ArithSeqInfo )
+			  Match, HsBinds, Stmt, Qualifier, HsType, ArithSeqInfo )
 import TcHsSyn		( SYN_IE(TypecheckedHsExpr), SYN_IE(TypecheckedHsBinds),
 			  SYN_IE(TypecheckedPat)
 			)
diff --git a/ghc/compiler/deforest/Cyclic.lhs b/ghc/compiler/deforest/Cyclic.lhs
index fa1fbcfa07..f3818df7c7 100644
--- a/ghc/compiler/deforest/Cyclic.lhs
+++ b/ghc/compiler/deforest/Cyclic.lhs
@@ -17,7 +17,7 @@
 >			  TyVarTemplate
 >			)
 > import Digraph	( dfs )
-> import Id		( idType, toplevelishId, updateIdType,
+> import Id		( idType, updateIdType,
 > 			  getIdInfo, replaceIdInfo, eqId, Id
 >			)
 > import IdInfo
@@ -145,7 +145,7 @@ type of the expression itself.
 >		newDefId type_of_f	`thenUs` \f' ->
 >		let
 > 		       f = replaceIdInfo f'
->		       		(addInfo (getIdInfo f') DoDeforest)
+>		       		(addDeforestInfo (getIdInfo f') DoDeforest)
 >		in
 >		loop ((f,e,val_args,ty_args):ls) e1
 >					`thenUs` \res@(ls',bs,bls,e') ->
diff --git a/ghc/compiler/deforest/DefExpr.lhs b/ghc/compiler/deforest/DefExpr.lhs
index 0c99fc4995..d5cd03c4ac 100644
--- a/ghc/compiler/deforest/DefExpr.lhs
+++ b/ghc/compiler/deforest/DefExpr.lhs
@@ -22,7 +22,7 @@
 > import CmdLineOpts	( SwitchResult, switchIsOn )
 > import CoreUnfold	( Unfolding(..) )
 > import CoreUtils	( mkValLam, unTagBinders, coreExprType )
-> import Id		( applyTypeEnvToId, getIdUnfolding, isTopLevId, Id,
+> import Id		( applyTypeEnvToId, getIdUnfolding, Id,
 > 			  isInstId_maybe
 >			)
 > import Inst		-- Inst(..)
diff --git a/ghc/compiler/deforest/DefUtils.lhs b/ghc/compiler/deforest/DefUtils.lhs
index 24570b9340..62ab8034cd 100644
--- a/ghc/compiler/deforest/DefUtils.lhs
+++ b/ghc/compiler/deforest/DefUtils.lhs
@@ -32,7 +32,7 @@
 > import Pretty
 > import PrimOp	( PrimOp )	-- for Eq PrimOp
 > import UniqSupply
-> import SrcLoc		( mkUnknownSrcLoc )
+> import SrcLoc		( noSrcLoc )
 > import Util
 
 -----------------------------------------------------------------------------
@@ -492,19 +492,19 @@ Grab a new Id and tag it as coming from the Deforester.
 > newDefId :: Type -> UniqSM Id
 > newDefId t =
 > 	getUnique	`thenUs` \u ->
->	returnUs (mkSysLocal SLIT("def") u t mkUnknownSrcLoc)
+>	returnUs (mkSysLocal SLIT("def") u t noSrcLoc)
 
 > newTmpId :: Type -> UniqSM Id
 > newTmpId t =
 > 	getUnique	`thenUs` \u ->
->	returnUs (mkSysLocal SLIT("tmp") u t mkUnknownSrcLoc)
+>	returnUs (mkSysLocal SLIT("tmp") u t noSrcLoc)
 
 -----------------------------------------------------------------------------
 Check whether an Id was given a `DEFOREST' annotation by the programmer.
 
 > deforestable :: Id -> Bool
 > deforestable id =
-> 	case getInfo (getIdInfo id) of
+> 	case getDeforestInfo (getIdInfo id) of
 >		DoDeforest -> True
 >		Don'tDeforest -> False
 
diff --git a/ghc/compiler/deforest/TreelessForm.lhs b/ghc/compiler/deforest/TreelessForm.lhs
index c690fe2106..bb01baae21 100644
--- a/ghc/compiler/deforest/TreelessForm.lhs
+++ b/ghc/compiler/deforest/TreelessForm.lhs
@@ -136,7 +136,7 @@ dictionary deconstruction.
 >	(vs,es) = unzip bs
 >	vs'  = map mkDeforestable vs
 >	s = zip vs (map (Var . DefArgVar) vs')
->	mkDeforestable v = replaceIdInfo v (addInfo (getIdInfo v) DoDeforest)
+>	mkDeforestable v = replaceIdInfo v (addDeforestInfo (getIdInfo v) DoDeforest)
 
 > convAtom :: DefAtom -> UniqSM DefAtom
 >
diff --git a/ghc/compiler/hsSyn/HsBinds.lhs b/ghc/compiler/hsSyn/HsBinds.lhs
index fce12aa08d..2c2a687d70 100644
--- a/ghc/compiler/hsSyn/HsBinds.lhs
+++ b/ghc/compiler/hsSyn/HsBinds.lhs
@@ -18,17 +18,22 @@ import HsMatches	( pprMatches, pprGRHSsAndBinds,
 			  Match, GRHSsAndBinds )
 import HsPat		( collectPatBinders, InPat )
 import HsPragmas	( GenPragmas, ClassOpPragmas )
-import HsTypes		( PolyType )
+import HsTypes		( HsType )
+import CoreSyn		( SYN_IE(CoreExpr) )
 
 --others:
 import Id		( SYN_IE(DictVar), SYN_IE(Id), GenId )
-import Name		( pprNonSym )
+import Name		( pprNonSym, getOccName, OccName )
 import Outputable	( interpp'SP, ifnotPprForUser,
 			  Outputable(..){-instance * (,)-}
 			)
+import PprCore		( GenCoreExpr {- instance Outputable -} )
+import PprType		( GenTyVar {- instance Outputable -} )
 import Pretty
+import Bag
 import SrcLoc		( SrcLoc{-instances-} )
---import TyVar		( GenTyVar{-instances-} )
+import TyVar		( GenTyVar{-instances-} )
+import Unique		( Unique {- instance Eq -} )
 \end{code}
 
 %************************************************************************
@@ -56,7 +61,7 @@ data HsBinds tyvar uvar id pat		-- binders and bindees
 
   | BindWith		-- Bind with a type signature.
 			-- These appear only on typechecker input
-			-- (PolyType [in Sigs] can't appear on output)
+			-- (HsType [in Sigs] can't appear on output)
 		(Bind tyvar uvar id pat)
 		[Sig id]
 
@@ -121,24 +126,22 @@ serves for both.
 \begin{code}
 data Sig name
   = Sig		name		-- a bog-std type signature
-		(PolyType name)
-		(GenPragmas name) -- only interface ones have pragmas
+		(HsType name)
 		SrcLoc
 
   | ClassOpSig	name		-- class-op sigs have different pragmas
-		(PolyType name)
+		(HsType name)
 		(ClassOpPragmas name)	-- only interface ones have pragmas
 		SrcLoc
 
   | SpecSig 	name		-- specialise a function or datatype ...
-		(PolyType name) -- ... to these types
+		(HsType name) -- ... to these types
 		(Maybe name)	-- ... maybe using this as the code for it
 		SrcLoc
 
   | InlineSig	name		  -- INLINE f
 		SrcLoc
 
-  -- ToDo: strictly speaking, could omit based on -DOMIT_DEFORESTER
   | DeforestSig name            -- Deforest using this function definition
 	      	SrcLoc
 
@@ -150,13 +153,12 @@ data Sig name
 
 \begin{code}
 instance (NamedThing name, Outputable name) => Outputable (Sig name) where
-    ppr sty (Sig var ty pragmas _)
+    ppr sty (Sig var ty _)
       = ppHang (ppCat [pprNonSym sty var, ppPStr SLIT("::")])
-	     4 (ppHang (ppr sty ty)
-		     4 (ifnotPprForUser sty (ppr sty pragmas)))
+	     4 (ppr sty ty)
 
     ppr sty (ClassOpSig var ty pragmas _)
-      = ppHang (ppCat [pprNonSym sty var, ppPStr SLIT("::")])
+      = ppHang (ppCat [ppr sty (getOccName var), ppPStr SLIT("::")])
 	     4 (ppHang (ppr sty ty)
 		     4 (ifnotPprForUser sty (ppr sty pragmas)))
 
@@ -240,8 +242,12 @@ data MonoBinds tyvar uvar id pat
 		    Bool			-- True => infix declaration
 		    [Match tyvar uvar id pat]	-- must have at least one Match
 		    SrcLoc
+
   | VarMonoBind	    id			-- TRANSLATION
 		    (HsExpr tyvar uvar id pat)
+
+  | CoreMonoBind    id			-- TRANSLATION
+		    CoreExpr		-- No zonking; this is a final CoreExpr with Ids and Types!
 \end{code}
 
 \begin{code}
@@ -269,6 +275,9 @@ instance (NamedThing id, Outputable id, Outputable pat,
 
     ppr sty (VarMonoBind name expr)
       = ppHang (ppCat [pprNonSym sty name, ppEquals]) 4 (ppr sty expr)
+
+    ppr sty (CoreMonoBind name expr)
+      = ppHang (ppCat [pprNonSym sty name, ppEquals]) 4 (ppr sty expr)
 \end{code}
 
 %************************************************************************
@@ -289,45 +298,24 @@ where
 it should return @[x, y, f, a, b]@ (remember, order important).
 
 \begin{code}
-collectTopLevelBinders :: HsBinds tyvar uvar name (InPat name) -> [name]
-collectTopLevelBinders EmptyBinds     = []
-collectTopLevelBinders (SingleBind b) = collectBinders b
-collectTopLevelBinders (BindWith b _) = collectBinders b
-collectTopLevelBinders (ThenBinds b1 b2)
- = collectTopLevelBinders b1 ++ collectTopLevelBinders b2
-
-collectBinders :: Bind tyvar uvar name (InPat name) -> [name]
-collectBinders EmptyBind 	      = []
+collectTopBinders :: HsBinds tyvar uvar name (InPat name) -> Bag (name,SrcLoc)
+collectTopBinders EmptyBinds     = emptyBag
+collectTopBinders (SingleBind b) = collectBinders b
+collectTopBinders (BindWith b _) = collectBinders b
+collectTopBinders (ThenBinds b1 b2)
+ = collectTopBinders b1 `unionBags` collectTopBinders b2
+
+collectBinders :: Bind tyvar uvar name (InPat name) -> Bag (name,SrcLoc)
+collectBinders EmptyBind 	      = emptyBag
 collectBinders (NonRecBind monobinds) = collectMonoBinders monobinds
 collectBinders (RecBind monobinds)    = collectMonoBinders monobinds
 
-collectMonoBinders :: MonoBinds tyvar uvar name (InPat name) -> [name]
-collectMonoBinders EmptyMonoBinds		     = []
-collectMonoBinders (PatMonoBind pat grhss_w_binds _) = collectPatBinders pat
-collectMonoBinders (FunMonoBind f _ matches _)	     = [f]
-collectMonoBinders (VarMonoBind v expr) 	     = error "collectMonoBinders"
+collectMonoBinders :: MonoBinds tyvar uvar name (InPat name) -> Bag (name,SrcLoc)
+collectMonoBinders EmptyMonoBinds		       = emptyBag
+collectMonoBinders (PatMonoBind pat grhss_w_binds loc) = listToBag (map (\v->(v,loc)) (collectPatBinders pat))
+collectMonoBinders (FunMonoBind f _ matches loc)       = unitBag (f,loc)
+collectMonoBinders (VarMonoBind v expr) 	       = error "collectMonoBinders"
+collectMonoBinders (CoreMonoBind v expr) 	       = error "collectMonoBinders"
 collectMonoBinders (AndMonoBinds bs1 bs2)
- = collectMonoBinders bs1 ++ collectMonoBinders bs2
-
--- We'd like the binders -- and where they came from --
--- so we can make new ones with equally-useful origin info.
-
-collectMonoBindersAndLocs
-	:: MonoBinds tyvar uvar name (InPat name) -> [(name, SrcLoc)]
-
-collectMonoBindersAndLocs EmptyMonoBinds = []
-
-collectMonoBindersAndLocs (AndMonoBinds bs1 bs2)
-  = collectMonoBindersAndLocs bs1 ++ collectMonoBindersAndLocs bs2
-
-collectMonoBindersAndLocs (PatMonoBind pat grhss_w_binds locn)
-  = collectPatBinders pat `zip` repeat locn
-
-collectMonoBindersAndLocs (FunMonoBind f _ matches locn) = [(f, locn)]
-
-#ifdef DEBUG
-collectMonoBindersAndLocs (VarMonoBind v expr)
-  = trace "collectMonoBindersAndLocs:VarMonoBind" []
-	-- ToDo: this is dubious, i.e., wrong, but harmless?
-#endif
+ = collectMonoBinders bs1 `unionBags` collectMonoBinders bs2
 \end{code}
diff --git a/ghc/compiler/hsSyn/HsCore.lhs b/ghc/compiler/hsSyn/HsCore.lhs
index f59bb89093..0154c84d6d 100644
--- a/ghc/compiler/hsSyn/HsCore.lhs
+++ b/ghc/compiler/hsSyn/HsCore.lhs
@@ -8,23 +8,24 @@
 %************************************************************************
 
 We could either use this, or parameterise @GenCoreExpr@ on @Types@ and
-@TyVars@ as well.  Currently trying the former.
+@TyVars@ as well.  Currently trying the former... MEGA SIGH.
 
 \begin{code}
 #include "HsVersions.h"
 
 module HsCore (
-	UnfoldingCoreExpr(..), UnfoldingCoreAlts(..),
-	UnfoldingCoreDefault(..), UnfoldingCoreBinding(..),
-	UnfoldingCoreAtom(..), UfId(..), SYN_IE(UnfoldingType),
-	UnfoldingPrimOp(..), UfCostCentre(..)
+	UfExpr(..), UfAlts(..), UfBinder(..), UfCoercion(..),
+	UfDefault(..), UfBinding(..),
+	UfArg(..), UfPrimOp(..)
     ) where
 
 IMP_Ubiq()
 
 -- friends:
-import HsTypes		( MonoType, PolyType )
+import HsTypes		( HsType, pprParendHsType )
 import PrimOp		( PrimOp, tagOf_PrimOp )
+import Kind		( Kind {- instance Outputable -} )
+import Type		( GenType {- instance Outputable -} )
 
 -- others:
 import Literal		( Literal )
@@ -40,89 +41,56 @@ import Util		( panic )
 %************************************************************************
 
 \begin{code}
-data UnfoldingCoreExpr name
-  = UfVar 	(UfId name)
+data UfExpr name
+  = UfVar 	name
   | UfLit	Literal
-  | UfCon 	name -- must be a "BoringUfId"...
-		[UnfoldingType name]
-		[UnfoldingCoreAtom name]
-  | UfPrim	(UnfoldingPrimOp name)
-		[UnfoldingType name]
-		[UnfoldingCoreAtom name]
-  | UfLam 	(UfBinder name)
-		(UnfoldingCoreExpr name)
-  | UfApp 	(UnfoldingCoreExpr name)
-		(UnfoldingCoreAtom name)
-  | UfCase	(UnfoldingCoreExpr name)
-		(UnfoldingCoreAlts name)
-  | UfLet	(UnfoldingCoreBinding name)
-		(UnfoldingCoreExpr name)
-  | UfSCC	(UfCostCentre name)
-		(UnfoldingCoreExpr name)
-
-data UnfoldingPrimOp name
+  | UfCon 	name [UfArg name]
+  | UfPrim	(UfPrimOp name) [UfArg name]
+  | UfLam 	(UfBinder name)	  (UfExpr name)
+  | UfApp 	(UfExpr name) (UfArg name)
+  | UfCase	(UfExpr name) (UfAlts name)
+  | UfLet	(UfBinding name)  (UfExpr name)
+  | UfSCC	CostCentre (UfExpr name)
+  | UfCoerce	(UfCoercion name) (HsType name) (UfExpr name)
+
+data UfPrimOp name
   = UfCCallOp	FAST_STRING	     -- callee
 		Bool		     -- True <=> casm, rather than ccall
 		Bool		     -- True <=> might cause GC
-		[UnfoldingType name] -- arg types, incl state token
+		[HsType name] -- arg types, incl state token
 				     -- (which will be first)
-		(UnfoldingType name) -- return type
-  | UfOtherOp	PrimOp
-
-data UnfoldingCoreAlts name
-  = UfCoAlgAlts	 [(name, [UfBinder name], UnfoldingCoreExpr name)]
-		 (UnfoldingCoreDefault name)
-  | UfCoPrimAlts [(Literal, UnfoldingCoreExpr name)]
-		 (UnfoldingCoreDefault name)
-
-data UnfoldingCoreDefault name
-  = UfCoNoDefault
-  | UfCoBindDefault (UfBinder name)
-		    (UnfoldingCoreExpr name)
-
-data UnfoldingCoreBinding name
-  = UfCoNonRec	(UfBinder name)
-		(UnfoldingCoreExpr name)
-  | UfCoRec 	[(UfBinder name, UnfoldingCoreExpr name)]
-
-data UnfoldingCoreAtom name
-  = UfCoVarAtom	(UfId name)
-  | UfCoLitAtom	Literal
-
-data UfCostCentre name
-  = UfPreludeDictsCC
-		Bool	-- True <=> is dupd
-  | UfAllDictsCC FAST_STRING	-- module and group
-		FAST_STRING
-		Bool	-- True <=> is dupd
-  | UfUserCC	FAST_STRING
-		FAST_STRING FAST_STRING -- module and group
-		Bool	-- True <=> is dupd
-		Bool	-- True <=> is CAF
-  | UfAutoCC	(UfId name)
-		FAST_STRING FAST_STRING -- module and group
-		Bool Bool -- as above
-  | UfDictCC	(UfId name)
-		FAST_STRING FAST_STRING -- module and group
-		Bool Bool -- as above
-
-type UfBinder name = (name, UnfoldingType name)
-
-data UfId name
-  = BoringUfId		name
-  | SuperDictSelUfId	name name	-- class and superclass
-  | ClassOpUfId		name name	-- class and class op
-  | DictFunUfId		name		-- class and type
-			(UnfoldingType name)
-  | ConstMethodUfId	name name	-- class, class op, and type
-			(UnfoldingType name)
-  | DefaultMethodUfId	name name	-- class and class op
-  | SpecUfId		(UfId name)	-- its unspecialised "parent"
-			[Maybe (MonoType name)]
-  | WorkerUfId		(UfId name)	-- its non-working "parent"
-  -- more to come?
-
-type UnfoldingType name = PolyType name
+		(HsType name) -- return type
+
+  | UfOtherOp	name
+
+data UfCoercion name = UfIn name | UfOut name
+
+data UfAlts name
+  = UfAlgAlts  [(name, [UfBinder name], UfExpr name)]
+		(UfDefault name)
+  | UfPrimAlts [(Literal, UfExpr name)]
+		(UfDefault name)
+
+data UfDefault name
+  = UfNoDefault
+  | UfBindDefault (UfBinder name)
+		  (UfExpr name)
+
+data UfBinding name
+  = UfNonRec	(UfBinder name)
+		(UfExpr name)
+  | UfRec 	[(UfBinder name, UfExpr name)]
+
+data UfBinder name
+  = UfValBinder	name (HsType name)
+  | UfTyBinder	name Kind
+  | UfUsageBinder name
+
+data UfArg name
+  = UfVarArg	name
+  | UfLitArg	Literal
+  | UfTyArg	(HsType name)
+  | UfUsageArg	name
 \end{code}
 
 %************************************************************************
@@ -132,39 +100,45 @@ type UnfoldingType name = PolyType name
 %************************************************************************
 
 \begin{code}
-instance Outputable name => Outputable (UnfoldingCoreExpr name) where
-    ppr sty (UfVar v) = pprUfId sty v
+instance Outputable name => Outputable (UfExpr name) where
+    ppr sty (UfVar v) = ppr sty v
     ppr sty (UfLit l) = ppr sty l
 
-    ppr sty (UfCon c tys as)
-      = ppCat [ppStr "(UfCon", ppr sty c, ppr sty tys, ppr sty as, ppStr ")"]
-    ppr sty (UfPrim o tys as)
-      = ppCat [ppStr "(UfPrim", ppr sty o, ppr sty tys, ppr sty as, ppStr ")"]
+    ppr sty (UfCon c as)
+      = ppCat [ppStr "(UfCon", ppr sty c, ppr sty as, ppStr ")"]
+    ppr sty (UfPrim o as)
+      = ppCat [ppStr "(UfPrim", ppr sty o, ppr sty as, ppStr ")"]
 
-    ppr sty (UfLam bs body)
-      = ppCat [ppChar '\\', ppr sty bs, ppStr "->", ppr sty body]
+    ppr sty (UfLam b body)
+      = ppCat [ppChar '\\', ppr sty b, ppStr "->", ppr sty body]
 
-    ppr sty (UfApp fun arg)
-      = ppCat [ppStr "(UfApp", ppr sty fun, ppr sty arg, ppStr ")"]
+    ppr sty (UfApp fun (UfTyArg ty))
+      = ppCat [ppr sty fun, ppStr "@", pprParendHsType sty ty]
+
+    ppr sty (UfApp fun (UfLitArg lit))
+      = ppCat [ppr sty fun, ppr sty lit]
+
+    ppr sty (UfApp fun (UfVarArg var))
+      = ppCat [ppr sty fun, ppr sty var]
 
     ppr sty (UfCase scrut alts)
       = ppCat [ppStr "case", ppr sty scrut, ppStr "of {", pp_alts alts, ppStr "}"]
       where
-    	pp_alts (UfCoAlgAlts alts deflt)
+    	pp_alts (UfAlgAlts alts deflt)
 	  = ppCat [ppInterleave ppSemi (map pp_alt alts), pp_deflt deflt]
 	  where
 	   pp_alt (c,bs,rhs) = ppCat [ppr sty c, ppr sty bs, ppStr "->", ppr sty rhs]
-    	pp_alts (UfCoPrimAlts alts deflt)
+    	pp_alts (UfPrimAlts alts deflt)
 	  = ppCat [ppInterleave ppSemi (map pp_alt alts), pp_deflt deflt]
 	  where
 	   pp_alt (l,rhs) = ppCat [ppr sty l, ppStr "->", ppr sty rhs]
 
-	pp_deflt UfCoNoDefault = ppNil
-	pp_deflt (UfCoBindDefault b rhs) = ppCat [ppr sty b, ppStr "->", ppr sty rhs]
+	pp_deflt UfNoDefault = ppNil
+	pp_deflt (UfBindDefault b rhs) = ppCat [ppr sty b, ppStr "->", ppr sty rhs]
 
-    ppr sty (UfLet (UfCoNonRec b rhs) body)
+    ppr sty (UfLet (UfNonRec b rhs) body)
       = ppCat [ppStr "let", ppr sty b, ppEquals, ppr sty rhs, ppStr "in", ppr sty body]
-    ppr sty (UfLet (UfCoRec pairs) body)
+    ppr sty (UfLet (UfRec pairs) body)
       = ppCat [ppStr "letrec {", ppInterleave ppSemi (map pp_pair pairs), ppStr "} in", ppr sty body]
       where
 	pp_pair (b,rhs) = ppCat [ppr sty b, ppEquals, ppr sty rhs]
@@ -172,41 +146,27 @@ instance Outputable name => Outputable (UnfoldingCoreExpr name) where
     ppr sty (UfSCC uf_cc body)
       = ppCat [ppStr "_scc_ <cost-centre[ToDo]>", ppr sty body]
 
-instance Outputable name => Outputable (UnfoldingPrimOp name) where
+instance Outputable name => Outputable (UfPrimOp name) where
     ppr sty (UfCCallOp str is_casm can_gc arg_tys result_ty)
       = let
 	    before = ppStr (if is_casm then "_casm_ ``" else "_ccall_ ")
 	    after  = if is_casm then ppStr "'' " else ppSP
 	in
 	ppBesides [before, ppPStr str, after,
-		ppLbrack, ppr sty arg_tys, ppRbrack, ppSP, ppr sty result_ty]
+		  ppLbrack, ppr sty arg_tys, ppRbrack, ppSP, ppr sty result_ty]
+
     ppr sty (UfOtherOp op)
       = ppr sty op
 
-instance Outputable name => Outputable (UnfoldingCoreAtom name) where
-    ppr sty (UfCoVarAtom v) = pprUfId sty v
-    ppr sty (UfCoLitAtom l)	    = ppr sty l
-
-pprUfId sty (BoringUfId v) = ppr sty v
-pprUfId sty (SuperDictSelUfId c sc)
-  = ppBesides [ppStr "({-superdict-}", ppr sty c, ppSP, ppr sty sc, ppStr ")"]
-pprUfId sty (ClassOpUfId c op)
-  = ppBesides [ppStr "({-method-}", ppr sty c, ppSP, ppr sty op, ppStr ")"]
-pprUfId sty (DictFunUfId c ty)
-  = ppBesides [ppStr "({-dfun-}", ppr sty c, ppSP, ppr sty ty, ppStr ")"]
-pprUfId sty (ConstMethodUfId c op ty)
-  = ppBesides [ppStr "({-constm-}", ppr sty c, ppSP, ppr sty op, ppSP, ppr sty ty, ppStr ")"]
-pprUfId sty (DefaultMethodUfId c ty)
-  = ppBesides [ppStr "({-defm-}", ppr sty c, ppSP, ppr sty ty, ppStr ")"]
-
-pprUfId sty (SpecUfId unspec ty_maybes)
-  = ppBesides [ppStr "({-spec-} ", pprUfId sty unspec,
-		ppInterleave ppSP (map pp_ty_maybe ty_maybes), ppStr ")"]
-  where
-    pp_ty_maybe Nothing  = ppStr "_N_"
-    pp_ty_maybe (Just t) = ppr sty t
-
-pprUfId sty (WorkerUfId unwrkr)
-  = ppBesides [ppStr "({-wrkr-}", pprUfId sty unwrkr, ppStr ")"]
+instance Outputable name => Outputable (UfArg name) where
+    ppr sty (UfVarArg v)	= ppr sty v
+    ppr sty (UfLitArg l)	= ppr sty l
+    ppr sty (UfTyArg ty)	= pprParendHsType sty ty
+    ppr sty (UfUsageArg name)	= ppr sty name
+
+instance Outputable name => Outputable (UfBinder name) where
+    ppr sty (UfValBinder name ty)  = ppCat [ppr sty name, ppStr "::", ppr sty ty]
+    ppr sty (UfTyBinder name kind) = ppCat [ppr sty name, ppStr "::", ppr sty kind]
+    ppr sty (UfUsageBinder name)   = ppr sty name
 \end{code}
 
diff --git a/ghc/compiler/hsSyn/HsDecls.lhs b/ghc/compiler/hsSyn/HsDecls.lhs
index 6341f66a26..1e1cc3e17c 100644
--- a/ghc/compiler/hsSyn/HsDecls.lhs
+++ b/ghc/compiler/hsSyn/HsDecls.lhs
@@ -14,22 +14,65 @@ module HsDecls where
 IMP_Ubiq()
 
 -- friends:
-IMPORT_DELOOPER(HsLoop)		( nullMonoBinds, MonoBinds, Sig )
+import HsBinds		( HsBinds, MonoBinds, Sig, nullMonoBinds )
 import HsPragmas	( DataPragmas, ClassPragmas,
 			  InstancePragmas, ClassOpPragmas
 			)
 import HsTypes
+import IdInfo
+import SpecEnv		( SpecEnv )
+import HsCore		( UfExpr )
 
 -- others:
-import Name		( pprSym, pprNonSym )
+import Name		( pprSym, pprNonSym, getOccName, OccName )
 import Outputable	( interppSP, interpp'SP,
 			  Outputable(..){-instance * []-}
 			)
 import Pretty
 import SrcLoc		( SrcLoc )
---import Util		( panic#{-ToDo:rm eventually-} )
+import PprStyle		( PprStyle(..) )
 \end{code}
 
+
+%************************************************************************
+%*									*
+\subsection[HsDecl]{Declarations}
+%*									*
+%************************************************************************
+
+\begin{code}
+data HsDecl tyvar uvar name pat
+  = TyD		(TyDecl name)
+  | ClD		(ClassDecl tyvar uvar name pat)
+  | InstD	(InstDecl  tyvar uvar name pat)
+  | DefD	(DefaultDecl name)
+  | ValD	(HsBinds tyvar uvar name pat)
+  | SigD	(IfaceSig name)
+\end{code}
+
+\begin{code}
+hsDeclName (TyD (TyData _ name _ _ _ _ _))    = name
+hsDeclName (TyD (TyNew  _ name _ _ _ _ _))    = name
+hsDeclName (TyD (TySynonym name _ _ _))       = name
+hsDeclName (ClD (ClassDecl _ name _ _ _ _ _)) = name
+hsDeclName (SigD (IfaceSig name _ _ _))	      = name
+-- Others don't make sense
+\end{code}
+
+\begin{code}
+instance (NamedThing name, Outputable name, Outputable pat,
+	  Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar)
+	=> Outputable (HsDecl tyvar uvar name pat) where
+
+    ppr sty (TyD td)     = ppr sty td
+    ppr sty (ClD cd)     = ppr sty cd
+    ppr sty (SigD sig)   = ppr sty sig
+    ppr sty (ValD binds) = ppr sty binds
+    ppr sty (DefD def)   = ppr sty def
+    ppr sty (InstD inst) = ppr sty inst
+\end{code}
+
+
 %************************************************************************
 %*									*
 \subsection[FixityDecl]{A fixity declaration}
@@ -37,23 +80,33 @@ import SrcLoc		( SrcLoc )
 %************************************************************************
 
 \begin{code}
-data FixityDecl name
-  = InfixL	name Int
-  | InfixR	name Int
-  | InfixN	name Int
+data FixityDecl name  = FixityDecl name Fixity SrcLoc
+
+instance Outputable name => Outputable (FixityDecl name) where
+  ppr sty (FixityDecl name fixity loc) = ppSep [ppr sty fixity, ppr sty name]
 \end{code}
 
+It's convenient to keep the source location in the @Fixity@; it makes error reporting
+in the renamer easier.
+
 \begin{code}
-instance (NamedThing name, Outputable name)
-     => Outputable (FixityDecl name) where
-    ppr sty (InfixL var prec)	= print_it sty "l" prec var
-    ppr sty (InfixR var prec)	= print_it sty "r" prec var
-    ppr sty (InfixN var prec)	= print_it sty ""  prec var
+data Fixity = Fixity Int FixityDirection
+data FixityDirection = InfixL | InfixR | InfixN 
+		     deriving(Eq)
 
-print_it sty suff prec var
-  = ppBesides [ppStr "infix", ppStr suff, ppSP, ppInt prec, ppSP, pprSym sty var]
+instance Outputable Fixity where
+    ppr sty (Fixity prec dir) = ppBesides [ppr sty dir, ppSP, ppInt prec]
+
+instance Outputable FixityDirection where
+    ppr sty InfixL = ppStr "infixl"
+    ppr sty InfixR = ppStr "infixr"
+    ppr sty InfixN = ppStr "infix"
+
+instance Eq Fixity where		-- Used to determine if two fixities conflict
+  (Fixity p1 dir1) == (Fixity p2 dir2) = p1==p2 && dir1 == dir2
 \end{code}
 
+
 %************************************************************************
 %*									*
 \subsection[TyDecl]{@data@, @newtype@ or @type@ (synonym) type declaration}
@@ -64,7 +117,7 @@ print_it sty suff prec var
 data TyDecl name
   = TyData	(Context name)	-- context
 		name		-- type constructor
-		[name]		-- type variables
+		[HsTyVar name]	-- type variables
 		[ConDecl name]	-- data constructors (empty if abstract)
 		(Maybe [name])	-- derivings; Nothing => not specified
 				-- (i.e., derive default); Just [] => derive
@@ -75,15 +128,15 @@ data TyDecl name
 
   | TyNew	(Context name)	-- context
 		name		-- type constructor
-		[name]		-- type variables
-		[ConDecl name]	-- data constructor (empty if abstract)
+		[HsTyVar name]	-- type variables
+		(ConDecl name)	-- data constructor
 		(Maybe [name])	-- derivings; as above
 		(DataPragmas name)
 		SrcLoc
 
   | TySynonym	name		-- type constructor
-		[name]		-- type variables
-		(MonoType name)	-- synonym expansion
+		[HsTyVar name]	-- type variables
+		(HsType name)	-- synonym expansion
 		SrcLoc
 
 \end{code}
@@ -94,35 +147,40 @@ instance (NamedThing name, Outputable name)
 
     ppr sty (TySynonym tycon tyvars mono_ty src_loc)
       = ppHang (pp_decl_head sty SLIT("type") ppNil tycon tyvars)
-	     4 (ppCat [ppEquals, ppr sty mono_ty])
+	     4 (ppr sty mono_ty)
 
     ppr sty (TyData context tycon tyvars condecls derivings pragmas src_loc)
       = pp_tydecl sty
-		  (pp_decl_head sty SLIT("data") (pprContext sty context) tycon tyvars)
+		  (pp_decl_head sty SLIT("data") (pp_context_and_arrow sty context) tycon tyvars)
 		  (pp_condecls sty condecls)
 		  derivings
 
     ppr sty (TyNew context tycon tyvars condecl derivings pragmas src_loc)
       = pp_tydecl sty
-		  (pp_decl_head sty SLIT("newtype") (pprContext sty context) tycon tyvars)
-		  (pp_condecls sty condecl)
+		  (pp_decl_head sty SLIT("newtype") (pp_context_and_arrow sty context) tycon tyvars)
+		  (ppr sty condecl)
 		  derivings
 
 pp_decl_head sty str pp_context tycon tyvars
-  = ppCat [ppPStr str, pp_context, ppr sty tycon, interppSP sty tyvars]
+  = ppCat [ppPStr str, pp_context, ppr sty (getOccName tycon), 
+	   interppSP sty tyvars, ppPStr SLIT("=")]
 
-pp_condecls sty [] = ppNil -- abstract datatype
+pp_condecls sty [] = ppNil		-- Curious!
 pp_condecls sty (c:cs)
-  = ppSep (ppBeside (ppStr "= ") (ppr sty c)
-	   : map (\ x -> ppBeside (ppStr "| ") (ppr sty x)) cs)
+  = ppSep (ppr sty c : map (\ c -> ppBeside (ppStr "| ") (ppr sty c)) cs)
 
 pp_tydecl sty pp_head pp_decl_rhs derivings
   = ppHang pp_head 4 (ppSep [
 	pp_decl_rhs,
-	case derivings of
-	  Nothing -> ppNil
-	  Just ds -> ppBeside (ppPStr SLIT("deriving "))
-			(ppParens (ppInterleave ppComma (map (ppr sty) ds)))])
+	case (derivings, sty) of
+	  (Nothing,_) 	   -> ppNil
+	  (_,PprInterface) -> ppNil	-- No derivings in interfaces
+	  (Just ds,_)	   -> ppCat [ppPStr SLIT("deriving"), ppParens (interpp'SP sty ds)]
+    ])
+
+pp_context_and_arrow :: Outputable name => PprStyle -> Context name -> Pretty
+pp_context_and_arrow sty [] = ppNil
+pp_context_and_arrow sty theta = ppCat [pprContext sty theta, ppPStr SLIT("=>")]
 \end{code}
 
 A type for recording what types a datatype should be specialised to.
@@ -132,7 +190,7 @@ for an datatype declaration.
 \begin{code}
 data SpecDataSig name
   = SpecDataSig name		-- tycon to specialise
-		(MonoType name)
+		(HsType name)
 		SrcLoc
 
 instance (NamedThing name, Outputable name)
@@ -164,31 +222,37 @@ data ConDecl name
 		SrcLoc
 
   | NewConDecl  name		-- newtype con decl
-		(MonoType name)
+		(HsType name)
 		SrcLoc
 
 data BangType name
-  = Banged   (PolyType name)	-- PolyType: to allow Haskell extensions
-  | Unbanged (PolyType name)	-- (MonoType only needed for straight Haskell)
+  = Banged   (HsType name)	-- HsType: to allow Haskell extensions
+  | Unbanged (HsType name)	-- (MonoType only needed for straight Haskell)
 \end{code}
 
 \begin{code}
 instance (NamedThing name, Outputable name) => Outputable (ConDecl name) where
 
     ppr sty (ConDecl con tys _)
-      = ppCat [pprNonSym sty con, ppInterleave ppNil (map (ppr_bang sty) tys)]
+      = ppCat [ppr sty (getOccName con), ppInterleave ppNil (map (ppr_bang sty) tys)]
+
+	-- We print ConOpDecls in prefix form in interface files
+    ppr PprInterface (ConOpDecl ty1 op ty2 _)
+      = ppCat [ppr PprInterface (getOccName op), ppr_bang PprInterface ty1, ppr_bang PprInterface ty2]
     ppr sty (ConOpDecl ty1 op ty2 _)
-      = ppCat [ppr_bang sty ty1, pprSym sty op, ppr_bang sty ty2]
+      = ppCat [ppr_bang sty ty1, ppr sty (getOccName op), ppr_bang sty ty2]
+
     ppr sty (NewConDecl con ty _)
-      = ppCat [pprNonSym sty con, pprParendMonoType sty ty]
+      = ppCat [ppr sty (getOccName con), pprParendHsType sty ty]
     ppr sty (RecConDecl con fields _)
-      = ppCat [pprNonSym sty con, ppChar '{',
-	       ppInterleave pp'SP (map pp_field fields), ppChar '}']
+      = ppCat [ppr sty (getOccName con),
+	       ppCurlies (ppInterleave pp'SP (map pp_field fields))
+	      ]
       where
 	pp_field (n, ty) = ppCat [ppr sty n, ppPStr SLIT("::"), ppr_bang sty ty]
 
-ppr_bang sty (Banged   ty) = ppBeside (ppChar '!') (pprParendPolyType sty ty)
-ppr_bang sty (Unbanged ty) = pprParendPolyType sty ty
+ppr_bang sty (Banged   ty) = ppBeside (ppChar '!') (pprParendHsType sty ty)
+ppr_bang sty (Unbanged ty) = pprParendHsType sty ty
 \end{code}
 
 %************************************************************************
@@ -201,7 +265,7 @@ ppr_bang sty (Unbanged ty) = pprParendPolyType sty ty
 data ClassDecl tyvar uvar name pat
   = ClassDecl	(Context name)	    		-- context...
 		name		    		-- name of the class
-		name		    		-- the class type variable
+		(HsTyVar name)	    		-- the class type variable
 		[Sig name]			-- methods' signatures
 		(MonoBinds tyvar uvar name pat)	-- default methods
 		(ClassPragmas name)
@@ -214,17 +278,23 @@ instance (NamedThing name, Outputable name, Outputable pat,
 		=> Outputable (ClassDecl tyvar uvar name pat) where
 
     ppr sty (ClassDecl context clas tyvar sigs methods pragmas src_loc)
-     = let 
-           top_matter = ppCat [ppStr "class", pprContext sty context,
-                               ppr sty clas, ppr sty tyvar]
-       in
-       if null sigs && nullMonoBinds methods then
-	   ppAbove top_matter (ppNest 4 (ppr sty pragmas))
-       else
-	   ppAboves [ppCat [top_matter, ppStr "where"],
-		     ppNest 4 (ppAboves (map (ppr sty) sigs)),
-		     ppNest 4 (ppr sty methods),
-		     ppNest 4 (ppr sty pragmas) ]
+      | null sigs	-- No "where" part
+      = top_matter
+
+      | iface_style	-- All on one line (for now at least)
+      = ppCat [top_matter, ppStr "where", 
+	       ppCurlies (ppInterleave (ppPStr SLIT("; ")) pp_sigs)]
+
+      | otherwise	-- Laid out
+      = ppSep [ppCat [top_matter, ppStr "where {"],
+	       ppNest 4 ((ppIntersperse ppSemi pp_sigs `ppAbove` pp_methods)
+			 `ppBeside` ppStr "}")]
+      where
+        top_matter = ppCat [ppStr "class", pp_context_and_arrow sty context,
+                            ppr sty (getOccName clas), ppr sty tyvar]
+	pp_sigs     = map (ppr sty) sigs 
+	pp_methods  = ppr sty methods
+	iface_style = case sty of {PprInterface -> True; other -> False}
 \end{code}
 
 %************************************************************************
@@ -235,23 +305,16 @@ instance (NamedThing name, Outputable name, Outputable pat,
 
 \begin{code}
 data InstDecl tyvar uvar name pat
-  = InstDecl	name		-- Class
-
-		(PolyType name)	-- Context => Instance-type
+  = InstDecl	(HsType name)	-- Context => Class Instance-type
 				-- Using a polytype means that the renamer conveniently
 				-- figures out the quantified type variables for us.
 
 		(MonoBinds tyvar uvar name pat)
 
-		Bool		-- True <=> This instance decl is from the
-				-- module being compiled; False <=> It is from
-				-- an imported interface.
+		[Sig name]		-- User-supplied pragmatic info
 
-		Module		-- The name of the module where the instance decl
-				-- originally came from
+		(Maybe name)		-- Name for the dictionary function
 
-		[Sig name]		-- actually user-supplied pragmatic info
-		(InstancePragmas name)	-- interface-supplied pragmatic info
 		SrcLoc
 \end{code}
 
@@ -260,23 +323,15 @@ instance (NamedThing name, Outputable name, Outputable pat,
 	  Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar)
 	      => Outputable (InstDecl tyvar uvar name pat) where
 
-    ppr sty (InstDecl clas ty binds from_here modname uprags pragmas src_loc)
-      = let
-	    (context, inst_ty)
-	      = case ty of
-		  HsPreForAllTy c t -> (c, t)
-		  HsForAllTy  _ c t -> (c, t)
-
-	    top_matter = ppCat [ppStr "instance", pprContext sty context,
-			        ppr sty clas, pprParendMonoType sty inst_ty]
-	in
-	if nullMonoBinds binds && null uprags then
-	    ppAbove top_matter (ppNest 4 (ppr sty pragmas))
-	else
-	    ppAboves [ppCat [top_matter, ppStr "where"],
-	              if null uprags then ppNil else ppNest 4 (ppr sty uprags),
-	              ppNest 4 (ppr sty binds),
-	              ppNest 4 (ppr sty pragmas) ]
+    ppr sty (InstDecl inst_ty binds uprags dfun_name src_loc)
+      | case sty of { PprInterface -> True; other -> False} ||
+	nullMonoBinds binds && null uprags
+      = ppCat [ppStr "instance", ppr sty inst_ty]
+
+      | otherwise
+      =	ppAboves [ppCat [ppStr "instance", ppr sty inst_ty, ppStr "where"],
+	          ppNest 4 (ppr sty uprags),
+	          ppNest 4 (ppr sty binds) ]
 \end{code}
 
 A type for recording what instances the user wants to specialise;
@@ -285,7 +340,7 @@ instance.
 \begin{code}
 data SpecInstSig name
   = SpecInstSig  name		    -- class
-		 (MonoType name)    -- type to specialise to
+		 (HsType name)    -- type to specialise to
 		 SrcLoc
 
 instance (NamedThing name, Outputable name)
@@ -307,7 +362,7 @@ syntax, and that restriction must be checked in the front end.
 
 \begin{code}
 data DefaultDecl name
-  = DefaultDecl	[MonoType name]
+  = DefaultDecl	[HsType name]
 		SrcLoc
 
 instance (NamedThing name, Outputable name)
@@ -316,3 +371,32 @@ instance (NamedThing name, Outputable name)
     ppr sty (DefaultDecl tys src_loc)
       = ppBeside (ppPStr SLIT("default ")) (ppParens (interpp'SP sty tys))
 \end{code}
+
+%************************************************************************
+%*									*
+\subsection{Signatures in interface files}
+%*									*
+%************************************************************************
+
+\begin{code}
+data IfaceSig name
+  = IfaceSig	name
+		(HsType name)
+		[HsIdInfo name]
+		SrcLoc
+
+instance (NamedThing name, Outputable name) => Outputable (IfaceSig name) where
+    ppr sty (IfaceSig var ty _ _)
+      = ppHang (ppCat [ppr sty (getOccName var), ppPStr SLIT("::")])
+	     4 (ppr sty ty)
+
+data HsIdInfo name
+  = HsArity		ArityInfo
+  | HsStrictness	(StrictnessInfo name)
+  | HsUnfold		(UfExpr name)
+  | HsUpdate		UpdateInfo
+  | HsDeforest		DeforestInfo
+  | HsArgUsage		ArgUsageInfo
+  | HsFBType		FBTypeInfo
+	-- ToDo: specialisations
+\end{code}
diff --git a/ghc/compiler/hsSyn/HsExpr.lhs b/ghc/compiler/hsSyn/HsExpr.lhs
index 56ad5d23f6..42fd9268d8 100644
--- a/ghc/compiler/hsSyn/HsExpr.lhs
+++ b/ghc/compiler/hsSyn/HsExpr.lhs
@@ -15,7 +15,7 @@ IMPORT_DELOOPER(HsLoop) -- for paranoia checking
 import HsBinds		( HsBinds )
 import HsLit		( HsLit )
 import HsMatches	( pprMatches, pprMatch, Match )
-import HsTypes		( PolyType )
+import HsTypes		( HsType )
 
 -- others:
 import Id		( SYN_IE(DictVar), GenId, SYN_IE(Id) )
@@ -119,7 +119,7 @@ data HsExpr tyvar uvar id pat
 
   | ExprWithTySig		-- signature binding
 		(HsExpr tyvar uvar id pat)
-		(PolyType id)
+		(HsType id)
   | ArithSeqIn			-- arithmetic sequence
 		(ArithSeqInfo tyvar uvar id pat)
   | ArithSeqOut
@@ -401,8 +401,8 @@ pp_rbinds :: (NamedThing id, Outputable id, Outputable pat,
 	      -> HsRecordBinds tyvar uvar id pat -> Pretty
 
 pp_rbinds sty thing rbinds
-  = ppHang thing 4
-	(ppBesides [ppChar '{', ppInterleave ppComma (map (pp_rbind sty) rbinds), ppChar '}'])
+  = ppHang thing 
+	 4 (ppCurlies (ppIntersperse pp'SP (map (pp_rbind sty) rbinds)))
   where
     pp_rbind PprForUser (v, _, True) = ppr PprForUser v
     pp_rbind sty        (v, e, _)    = ppCat [ppr sty v, ppStr "=", ppr sty e]
diff --git a/ghc/compiler/hsSyn/HsImpExp.lhs b/ghc/compiler/hsSyn/HsImpExp.lhs
index 7bdf830d74..0305911e60 100644
--- a/ghc/compiler/hsSyn/HsImpExp.lhs
+++ b/ghc/compiler/hsSyn/HsImpExp.lhs
@@ -57,6 +57,7 @@ instance (NamedThing name, Outputable name) => Outputable (ImportDecl name) wher
 \subsection{Imported and exported entities}
 %*									*
 %************************************************************************
+
 \begin{code}
 data IE name
   = IEVar		name
@@ -67,6 +68,14 @@ data IE name
 \end{code}
 
 \begin{code}
+ieName :: IE name -> name
+ieName (IEVar n) 	 = n
+ieName (IEThingAbs  n)   = n
+ieName (IEThingWith n _) = n
+ieName (IEThingAll  n)   = n
+\end{code}
+
+\begin{code}
 instance (NamedThing name, Outputable name) => Outputable (IE name) where
     ppr sty (IEVar	var)	= pprNonSym sty var
     ppr sty (IEThingAbs	thing)	= ppr sty thing
@@ -78,3 +87,4 @@ instance (NamedThing name, Outputable name) => Outputable (IE name) where
     ppr sty (IEModuleContents mod)
 	= ppBeside (ppPStr SLIT("module ")) (ppPStr mod)
 \end{code}
+
diff --git a/ghc/compiler/hsSyn/HsPat.lhs b/ghc/compiler/hsSyn/HsPat.lhs
index 5cb26fac2b..4f6e4577c0 100644
--- a/ghc/compiler/hsSyn/HsPat.lhs
+++ b/ghc/compiler/hsSyn/HsPat.lhs
@@ -152,22 +152,21 @@ pprInPat sty (TuplePatIn pats)
   = ppParens (interpp'SP sty pats)
 
 pprInPat sty (RecPatIn con rpats)
-  = ppBesides [ppr sty con, ppSP, ppChar '{', ppInterleave ppComma (map (pp_rpat sty) rpats), ppChar '}']
+  = ppCat [ppr sty con, ppCurlies (ppIntersperse pp'SP (map (pp_rpat sty) rpats))]
   where
     pp_rpat PprForUser (v, _, True) = ppr PprForUser v
     pp_rpat sty        (v, p, _)    = ppCat [ppr sty v, ppStr "=", ppr sty p]
 \end{code}
 
 \begin{code}
-instance (Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar,
-	  NamedThing id, Outputable id)
+instance (Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar, Outputable id)
        => Outputable (OutPat tyvar uvar id) where
     ppr = pprOutPat
 \end{code}
 
 \begin{code}
 pprOutPat sty (WildPat ty)	= ppChar '_'
-pprOutPat sty (VarPat var)	= pprNonSym sty var
+pprOutPat sty (VarPat var)	= ppr sty var
 pprOutPat sty (LazyPat pat)	= ppBesides [ppChar '~', ppr sty pat]
 pprOutPat sty (AsPat name pat)
   = ppBesides [ppLparen, ppr sty name, ppChar '@', ppr sty pat, ppRparen]
@@ -190,7 +189,7 @@ pprOutPat sty (TuplePat pats)
   = ppParens (interpp'SP sty pats)
 
 pprOutPat sty (RecPat con ty rpats)
-  = ppBesides [ppr sty con, ppChar '{', ppInterleave ppComma (map (pp_rpat sty) rpats), ppChar '}']
+  = ppBesides [ppr sty con, ppCurlies (ppIntersperse pp'SP (map (pp_rpat sty) rpats))]
   where
     pp_rpat PprForUser (v, _, True) = ppr PprForUser v
     pp_rpat sty (v, p, _)           = ppCat [ppr sty v, ppStr "=", ppr sty p]
diff --git a/ghc/compiler/hsSyn/HsPragmas.lhs b/ghc/compiler/hsSyn/HsPragmas.lhs
index fcbc6d9aa8..1337b4d83d 100644
--- a/ghc/compiler/hsSyn/HsPragmas.lhs
+++ b/ghc/compiler/hsSyn/HsPragmas.lhs
@@ -19,8 +19,7 @@ module HsPragmas where
 IMP_Ubiq()
 
 -- friends:
-import HsCore		( UnfoldingCoreExpr )
-import HsTypes		( MonoType )
+import HsTypes		( HsType )
 
 -- others:
 import IdInfo
@@ -29,6 +28,48 @@ import Outputable	( Outputable(..) )
 import Pretty
 \end{code}
 
+All the pragma stuff has changed.  Here are some placeholders!
+
+\begin{code}
+data GenPragmas name  = NoGenPragmas
+data DataPragmas name = NoDataPragmas
+data InstancePragmas name = NoInstancePragmas
+data ClassOpPragmas name  = NoClassOpPragmas
+data ClassPragmas name  = NoClassPragmas
+
+noClassPragmas = NoClassPragmas
+isNoClassPragmas NoClassPragmas = True
+
+noDataPragmas = NoDataPragmas
+isNoDataPragmas NoDataPragmas = True
+
+noGenPragmas = NoGenPragmas
+isNoGenPragmas NoGenPragmas = True
+
+noInstancePragmas = NoInstancePragmas
+isNoInstancePragmas NoInstancePragmas = True
+
+noClassOpPragmas = NoClassOpPragmas
+isNoClassOpPragmas NoClassOpPragmas = True
+
+instance Outputable name => Outputable (ClassPragmas name) where
+    ppr sty NoClassPragmas = ppNil
+
+instance Outputable name => Outputable (ClassOpPragmas name) where
+    ppr sty NoClassOpPragmas = ppNil
+
+instance Outputable name => Outputable (InstancePragmas name) where
+    ppr sty NoInstancePragmas = ppNil
+
+instance Outputable name => Outputable (GenPragmas name) where
+    ppr sty NoGenPragmas = ppNil
+\end{code}
+
+========================= OLD CODE SCEDULED FOR DELETION SLPJ Nov 96 ==============
+
+\begin{code}
+{-		COMMENTED OUT 
+
 Certain pragmas expect to be pinned onto certain constructs.
 
 Pragma types may be parameterised, just as with any other
@@ -38,12 +79,10 @@ For a @data@ declaration---indicates which specialisations exist.
 \begin{code}
 data DataPragmas name
   = NoDataPragmas
-  | DataPragmas	[[Maybe (MonoType name)]]  -- types to which specialised
+  | DataPragmas	[[Maybe (HsType name)]]  -- types to which specialised
 
 noDataPragmas = NoDataPragmas
-
 isNoDataPragmas NoDataPragmas = True
-isNoDataPragmas _             = False
 \end{code}
 
 These are {\em general} things you can know about any value:
@@ -55,7 +94,7 @@ data GenPragmas name
 		DeforestInfo		-- deforest info
 		(ImpStrictness name)	-- strictness, worker-wrapper
 		(ImpUnfolding name)	-- unfolding (maybe)
-		[([Maybe (MonoType name)], -- Specialisations: types to which spec'd;
+		[([Maybe (HsType name)], -- Specialisations: types to which spec'd;
 		  Int,			   -- # dicts to ignore
 		  GenPragmas name)] 	   -- Gen info about the spec'd version
 
@@ -119,7 +158,7 @@ data InstancePragmas name
 
   | SpecialisedInstancePragma
 	(GenPragmas name)	   -- for its "dfun"
-	[([Maybe (MonoType name)], -- specialised instance; type...
+	[([Maybe (HsType name)], -- specialised instance; type...
 	  Int,			   -- #dicts to ignore
 	  InstancePragmas name)]   -- (no SpecialisedInstancePragma please!)
 
@@ -175,7 +214,7 @@ instance Outputable name => Outputable (GenPragmas name) where
 	pp_arity (Just i) = ppBeside (ppStr "ARITY=") (ppInt i)
 
 	pp_upd Nothing  = ppNil
-	pp_upd (Just u) = ppInfo sty id u
+	pp_upd (Just u) = ppUpdateInfo sty u
 
 	pp_str NoImpStrictness = ppNil
 	pp_str (ImpStrictness is_bot demands wrkr_prags)
@@ -197,3 +236,8 @@ instance Outputable name => Outputable (GenPragmas name) where
 	    pp_MaB Nothing  = ppStr "_N_"
 	    pp_MaB (Just x) = ppr sty x
 \end{code}
+
+
+\begin{code}
+-}
+\end{code}
diff --git a/ghc/compiler/hsSyn/HsSyn.lhs b/ghc/compiler/hsSyn/HsSyn.lhs
index e165b3ca75..9e57b8d42d 100644
--- a/ghc/compiler/hsSyn/HsSyn.lhs
+++ b/ghc/compiler/hsSyn/HsSyn.lhs
@@ -30,7 +30,13 @@ IMP_Ubiq()
 
 -- friends:
 import HsBinds
-import HsDecls
+import HsDecls		( HsDecl(..), TyDecl(..), InstDecl(..), ClassDecl(..), 
+			  DefaultDecl(..), 
+			  FixityDecl(..), Fixity(..), FixityDirection(..), 
+			  ConDecl(..), BangType(..),
+			  IfaceSig(..), HsIdInfo,  SpecDataSig(..), SpecInstSig(..),
+			  hsDeclName
+			)
 import HsExpr
 import HsImpExp
 import HsLit
@@ -39,6 +45,8 @@ import HsPat
 import HsTypes
 import HsPragmas	( ClassPragmas, ClassOpPragmas,
 			  DataPragmas, GenPragmas, InstancePragmas )
+import HsCore
+
 -- others:
 import FiniteMap	( FiniteMap )
 import Outputable	( ifPprShowAll, ifnotPprForUser, interpp'SP, Outputable(..) )
@@ -69,14 +77,7 @@ data HsModule tyvar uvar name pat
 				-- info to TyDecls/etc; so this list is
 				-- often empty, downstream.
 	[FixityDecl name]
-	[TyDecl name]
-	[SpecDataSig name]		-- user pragmas that modify TyDecls
-	[ClassDecl tyvar uvar name pat]
-	[InstDecl  tyvar uvar name pat]
-	[SpecInstSig name] 		-- user pragmas that modify InstDecls
-	[DefaultDecl name]
-	(HsBinds tyvar uvar name pat)	-- the main stuff, includes source sigs
-	[Sig name]			-- interface sigs
+	[HsDecl tyvar uvar name pat]	-- Type, class, value, and interface signature decls
 	SrcLoc
 \end{code}
 
@@ -86,8 +87,7 @@ instance (NamedThing name, Outputable name, Outputable pat,
 	=> Outputable (HsModule tyvar uvar name pat) where
 
     ppr sty (HsModule name iface_version exports imports fixities
-		      typedecls typesigs classdecls instdecls instsigs
-		      defdecls binds sigs src_loc)
+		      decls src_loc)
       = ppAboves [
 	    ifPprShowAll sty (ppr sty src_loc),
 	    ifnotPprForUser sty (pp_iface_version iface_version),
@@ -100,14 +100,7 @@ instance (NamedThing name, Outputable name, Outputable pat,
 			  ],
 	    pp_nonnull imports,
 	    pp_nonnull fixities,
-	    pp_nonnull typedecls,
-	    pp_nonnull typesigs,
-	    pp_nonnull classdecls,
-	    pp_nonnull instdecls,
-	    pp_nonnull instsigs,
-	    pp_nonnull defdecls,
-	    ppr sty binds,
-	    pp_nonnull sigs
+	    pp_nonnull decls
 	]
       where
 	pp_nonnull [] = ppNil
diff --git a/ghc/compiler/hsSyn/HsTypes.lhs b/ghc/compiler/hsSyn/HsTypes.lhs
index 239a6277d0..e558d4dd46 100644
--- a/ghc/compiler/hsSyn/HsTypes.lhs
+++ b/ghc/compiler/hsSyn/HsTypes.lhs
@@ -11,33 +11,36 @@ you get part of GHC.
 #include "HsVersions.h"
 
 module HsTypes (
-	PolyType(..), MonoType(..),
+	HsType(..), HsTyVar(..),
 	SYN_IE(Context), SYN_IE(ClassAssertion)
 
-#ifdef COMPILING_GHC
-	, pprParendPolyType
-	, pprParendMonoType, pprContext
-	, extractMonoTyNames, extractCtxtTyNames
-	, cmpPolyType, cmpMonoType, cmpContext
-#endif
+	, mkHsForAllTy
+	, getTyVarName, replaceTyVarName
+	, pprParendHsType
+	, pprContext
+	, cmpHsType, cmpContext
     ) where
 
-#ifdef COMPILING_GHC
 IMP_Ubiq()
 
 import Outputable	( interppSP, ifnotPprForUser )
+import Kind		( Kind {- instance Outputable -} )
 import Pretty
 import Util		( thenCmp, cmpList, isIn, panic# )
-
-#endif {- COMPILING_GHC -}
 \end{code}
 
 This is the syntax for types as seen in type signatures.
 
 \begin{code}
-data PolyType name
+type Context name = [ClassAssertion name]
+
+type ClassAssertion name = (name, HsType name)
+	-- The type is usually a type variable, but it
+	-- doesn't have to be when reading interface files
+
+data HsType name
   = HsPreForAllTy	(Context name)
-			(MonoType name)
+			(HsType name)
 
 	-- The renamer turns HsPreForAllTys into HsForAllTys when they
 	-- occur in signatures, to make the binding of variables
@@ -45,90 +48,99 @@ data PolyType name
 	-- non-COMPILING_GHC code, because you probably want to do the
 	-- same thing.
 
-  | HsForAllTy		[name]
+  | HsForAllTy		[HsTyVar name]
 			(Context name)
-			(MonoType name)
+			(HsType name)
 
-type Context name = [ClassAssertion name]
-
-type ClassAssertion name = (name, name)
-
-data MonoType name
-  = MonoTyVar		name		-- Type variable
+  | MonoTyVar		name		-- Type variable
 
   | MonoTyApp		name		-- Type constructor or variable
-			[MonoType name]
+			[HsType name]
 
     -- We *could* have a "MonoTyCon name" equiv to "MonoTyApp name []"
     -- (for efficiency, what?)  WDP 96/02/18
 
-  | MonoFunTy		(MonoType name) -- function type
-			(MonoType name)
+  | MonoFunTy		(HsType name) -- function type
+			(HsType name)
 
-  | MonoListTy		(MonoType name) -- list type
-  | MonoTupleTy		[MonoType name] -- tuple type (length gives arity)
+  | MonoListTy		name		-- The list TyCon name
+			(HsType name)	-- Element type
+
+  | MonoTupleTy		name		-- The tuple TyCon name
+			[HsType name]	-- Element types (length gives arity)
 
-#ifdef COMPILING_GHC
   -- these next two are only used in unfoldings in interfaces
   | MonoDictTy		name	-- Class
-			(MonoType name)
+			(HsType name)
+
+mkHsForAllTy []  []   ty = ty
+mkHsForAllTy tvs ctxt ty = HsForAllTy tvs ctxt ty
 
-  | MonoForAllTy	[(name, Kind)]
-			(MonoType name)
+data HsTyVar name
+  = UserTyVar name
+  | IfaceTyVar name Kind
 	-- *** NOTA BENE *** A "monotype" in a pragma can have
 	-- for-alls in it, (mostly to do with dictionaries).  These
 	-- must be explicitly Kinded.
 
-#endif {- COMPILING_GHC -}
+getTyVarName (UserTyVar n)    = n
+getTyVarName (IfaceTyVar n _) = n
+
+replaceTyVarName :: HsTyVar name1 -> name2 -> HsTyVar name2
+replaceTyVarName (UserTyVar n)    n' = UserTyVar n'
+replaceTyVarName (IfaceTyVar n k) n' = IfaceTyVar n' k
 \end{code}
 
-This is used in various places:
+
+%************************************************************************
+%*									*
+\subsection{Pretty printing}
+%*									*
+%************************************************************************
+
 \begin{code}
-#ifdef COMPILING_GHC
-pprContext :: (Outputable name) => PprStyle -> (Context name) -> Pretty
 
-pprContext sty []	    = ppNil
-pprContext sty [(clas, ty)] = ppCat [ppr sty clas, ppr sty ty, ppStr "=>"]
+instance (Outputable name) => Outputable (HsType name) where
+    ppr = pprHsType
+
+instance (Outputable name) => Outputable (HsTyVar name) where
+    ppr sty (UserTyVar name) = ppr sty name
+    ppr sty (IfaceTyVar name kind) = ppCat [ppr sty name, ppStr "::", ppr sty kind]
+
+
+ppr_forall sty ctxt_prec [] [] ty
+   = ppr_mono_ty sty ctxt_prec ty
+ppr_forall sty ctxt_prec tvs ctxt ty
+   = ppSep [ppStr "_forall_", ppBracket (interppSP sty tvs),
+	    pprContext sty ctxt,  ppStr "=>",
+	    pprHsType sty ty]
+
+pprContext :: (Outputable name) => PprStyle -> (Context name) -> Pretty
+pprContext sty []	        = ppNil
 pprContext sty context
-  = ppBesides [ppLparen,
-	   ppInterleave ppComma (map pp_assert context),
-	   ppRparen, ppStr " =>"]
+  = ppCat [ppCurlies (ppIntersperse pp'SP (map ppr_assert context))]
   where
-    pp_assert (clas, ty)
-      = ppCat [ppr sty clas, ppr sty ty]
+    ppr_assert (clas, ty) = ppCat [ppr sty clas, ppr sty ty]
 \end{code}
 
 \begin{code}
-instance (Outputable name) => Outputable (PolyType name) where
-    ppr sty (HsPreForAllTy ctxt ty)
-      = print_it sty ppNil ctxt ty
-    ppr sty (HsForAllTy [] ctxt ty)
-      = print_it sty ppNil ctxt ty
-    ppr sty (HsForAllTy tvs ctxt ty)
-      = print_it sty
-	    (ppBesides [ppStr "_forall_ ", interppSP sty tvs, ppStr " => "])
-	    ctxt ty
-
-print_it sty pp_forall ctxt ty
-  = ppCat [ifnotPprForUser sty pp_forall, -- print foralls unless PprForUser
-	   pprContext sty ctxt, ppr sty ty]
-
-pprParendPolyType :: Outputable name => PprStyle -> PolyType name -> Pretty
-pprParendPolyType sty ty = ppr sty ty -- ToDo: more later
-
-instance (Outputable name) => Outputable (MonoType name) where
-    ppr = pprMonoType
-
 pREC_TOP = (0 :: Int)
 pREC_FUN = (1 :: Int)
 pREC_CON = (2 :: Int)
 
+maybeParen :: Bool -> Pretty -> Pretty
+maybeParen True  p = ppParens p
+maybeParen False p = p
+	
 -- printing works more-or-less as for Types
 
-pprMonoType, pprParendMonoType :: (Outputable name) => PprStyle -> MonoType name -> Pretty
+pprHsType, pprParendHsType :: (Outputable name) => PprStyle -> HsType name -> Pretty
 
-pprMonoType sty ty  	 = ppr_mono_ty sty pREC_TOP ty
-pprParendMonoType sty ty = ppr_mono_ty sty pREC_CON ty
+pprHsType sty ty       = ppr_mono_ty sty pREC_TOP ty
+pprParendHsType sty ty = ppr_mono_ty sty pREC_CON ty
+
+ppr_mono_ty sty ctxt_prec (HsPreForAllTy ctxt ty)     = ppr_forall sty ctxt_prec [] ctxt ty
+ppr_mono_ty sty ctxt_prec (HsForAllTy tvs ctxt ty)    = ppr_forall sty ctxt_prec tvs ctxt ty
 
 ppr_mono_ty sty ctxt_prec (MonoTyVar name) = ppr sty name
 
@@ -136,130 +148,98 @@ ppr_mono_ty sty ctxt_prec (MonoFunTy ty1 ty2)
   = let p1 = ppr_mono_ty sty pREC_FUN ty1
 	p2 = ppr_mono_ty sty pREC_TOP ty2
     in
-    if ctxt_prec < pREC_FUN then -- no parens needed
-	ppSep [p1, ppBeside (ppStr "-> ") p2]
-    else
-	ppSep [ppBeside ppLparen p1, ppBesides [ppStr "-> ", p2, ppRparen]]
+    maybeParen (ctxt_prec >= pREC_FUN)
+	       (ppSep [p1, ppBeside (ppStr "-> ") p2])
 
-ppr_mono_ty sty ctxt_prec (MonoTupleTy tys)
- = ppBesides [ppLparen, ppInterleave ppComma (map (ppr sty) tys), ppRparen]
+ppr_mono_ty sty ctxt_prec (MonoTupleTy _ tys)
+ = ppParens (ppInterleave ppComma (map (ppr sty) tys))
 
-ppr_mono_ty sty ctxt_prec (MonoListTy ty)
+ppr_mono_ty sty ctxt_prec (MonoListTy _ ty)
  = ppBesides [ppLbrack, ppr_mono_ty sty pREC_TOP ty, ppRbrack]
 
 ppr_mono_ty sty ctxt_prec (MonoTyApp tycon tys)
   = let pp_tycon = ppr sty tycon in
     if null tys then
 	pp_tycon
-    else if ctxt_prec < pREC_CON then -- no parens needed
-	ppCat [pp_tycon, ppInterleave ppNil (map (ppr_mono_ty sty pREC_CON) tys)]
-    else
-	ppBesides [ ppLparen, pp_tycon, ppSP,
-	       ppInterleave ppNil (map (ppr_mono_ty sty pREC_CON) tys), ppRparen ]
+    else 
+	maybeParen (ctxt_prec >= pREC_CON)
+		   (ppCat [pp_tycon, ppInterleave ppNil (map (ppr_mono_ty sty pREC_CON) tys)])
 
--- unfoldings only
 ppr_mono_ty sty ctxt_prec (MonoDictTy clas ty)
-  = ppBesides [ppStr "{{", ppr sty clas, ppSP, ppr_mono_ty sty ctxt_prec ty, ppStr "}}"]
-
-#endif {- COMPILING_GHC -}
+  = ppCurlies (ppCat [ppr sty clas, ppr_mono_ty sty pREC_CON ty])
+	-- Curlies are temporary
 \end{code}
 
-\begin{code}
-#ifdef COMPILING_GHC
-
-extractCtxtTyNames :: Eq name => Context  name -> [name]
-extractMonoTyNames :: Eq name => (name -> Bool) -> MonoType name -> [name]
-
-extractCtxtTyNames ctxt
-  = foldr get [] ctxt
-  where
-    get (clas, tv) acc
-      | tv `is_elem` acc = acc
-      | otherwise        = tv : acc
-
-    is_elem = isIn "extractCtxtTyNames"
 
-extractMonoTyNames is_tyvar_name ty
-  = get ty []
-  where
-    get (MonoTyApp con tys) acc = let
-				     rest = foldr get acc tys
-				  in
-				  if is_tyvar_name con && not (con `is_elem` rest)
-				  then con : rest
-				  else rest
-    get (MonoListTy ty)	    acc = get ty acc
-    get (MonoFunTy ty1 ty2) acc = get ty1 (get ty2 acc)
-    get (MonoDictTy _ ty)   acc = get ty acc
-    get (MonoTupleTy tys)   acc = foldr get acc tys
-    get (MonoTyVar tv)      acc
-      | tv `is_elem` acc	= acc
-      | otherwise		= tv : acc
-
-    is_elem = isIn "extractMonoTyNames"
-
-#endif {- COMPILING_GHC -}
-\end{code}
+%************************************************************************
+%*									*
+\subsection{Comparison}
+%*									*
+%************************************************************************
 
 We do define a specialised equality for these \tr{*Type} types; used
 in checking interfaces.  Most any other use is likely to be {\em
 wrong}, so be careful!
-\begin{code}
-#ifdef COMPILING_GHC
 
-cmpPolyType :: (a -> a -> TAG_) -> PolyType a -> PolyType a -> TAG_
-cmpMonoType :: (a -> a -> TAG_) -> MonoType a -> MonoType a -> TAG_
+\begin{code}
+cmpHsTyVar :: (a -> a -> TAG_) -> HsTyVar a -> HsTyVar a -> TAG_
+cmpHsType :: (a -> a -> TAG_) -> HsType a -> HsType a -> TAG_
 cmpContext  :: (a -> a -> TAG_) -> Context  a -> Context  a -> TAG_
 
+cmpHsTyVar cmp (UserTyVar v1)    (UserTyVar v2)    = v1 `cmp` v2
+cmpHsTyVar cmp (IfaceTyVar v1 _) (IfaceTyVar v2 _) = v1 `cmp` v2
+cmpHsTyVar cmp (UserTyVar _)	 other		   = LT_
+cmpHsTyVar cmp other1	 	 other2		   = GT_
+
+
 -- We assume that HsPreForAllTys have been smashed by now.
 # ifdef DEBUG
-cmpPolyType _ (HsPreForAllTy _ _) _ = panic# "cmpPolyType:HsPreForAllTy:1st arg"
-cmpPolyType _ _ (HsPreForAllTy _ _) = panic# "cmpPolyType:HsPreForAllTy:2nd arg"
+cmpHsType _ (HsPreForAllTy _ _) _ = panic# "cmpHsType:HsPreForAllTy:1st arg"
+cmpHsType _ _ (HsPreForAllTy _ _) = panic# "cmpHsType:HsPreForAllTy:2nd arg"
 # endif
 
-cmpPolyType cmp (HsForAllTy tvs1 c1 t1) (HsForAllTy tvs2 c2 t2)
-  = cmpList cmp tvs1 tvs2   `thenCmp`
-    cmpContext cmp c1 c2    `thenCmp`
-    cmpMonoType cmp t1 t2
+cmpHsType cmp (HsForAllTy tvs1 c1 t1) (HsForAllTy tvs2 c2 t2)
+  = cmpList (cmpHsTyVar cmp) tvs1 tvs2  `thenCmp`
+    cmpContext cmp c1 c2    		`thenCmp`
+    cmpHsType cmp t1 t2
 
------------
-cmpMonoType cmp (MonoTyVar n1) (MonoTyVar n2)
+cmpHsType cmp (MonoTyVar n1) (MonoTyVar n2)
   = cmp n1 n2
 
-cmpMonoType cmp (MonoTupleTy tys1) (MonoTupleTy tys2)
-  = cmpList (cmpMonoType cmp) tys1 tys2
-cmpMonoType cmp (MonoListTy ty1) (MonoListTy ty2)
-  = cmpMonoType cmp ty1 ty2
+cmpHsType cmp (MonoTupleTy _ tys1) (MonoTupleTy _ tys2)
+  = cmpList (cmpHsType cmp) tys1 tys2
+cmpHsType cmp (MonoListTy _ ty1) (MonoListTy _ ty2)
+  = cmpHsType cmp ty1 ty2
 
-cmpMonoType cmp (MonoTyApp tc1 tys1) (MonoTyApp tc2 tys2)
+cmpHsType cmp (MonoTyApp tc1 tys1) (MonoTyApp tc2 tys2)
   = cmp tc1 tc2 `thenCmp`
-    cmpList (cmpMonoType cmp) tys1 tys2
+    cmpList (cmpHsType cmp) tys1 tys2
 
-cmpMonoType cmp (MonoFunTy a1 b1) (MonoFunTy a2 b2)
-  = cmpMonoType cmp a1 a2 `thenCmp` cmpMonoType cmp b1 b2
+cmpHsType cmp (MonoFunTy a1 b1) (MonoFunTy a2 b2)
+  = cmpHsType cmp a1 a2 `thenCmp` cmpHsType cmp b1 b2
 
-cmpMonoType cmp (MonoDictTy c1 ty1)   (MonoDictTy c2 ty2)
-  = cmp c1 c2 `thenCmp` cmpMonoType cmp ty1 ty2
+cmpHsType cmp (MonoDictTy c1 ty1)   (MonoDictTy c2 ty2)
+  = cmp c1 c2 `thenCmp` cmpHsType cmp ty1 ty2
 
-cmpMonoType cmp ty1 ty2 -- tags must be different
+cmpHsType cmp ty1 ty2 -- tags must be different
   = let tag1 = tag ty1
 	tag2 = tag ty2
     in
     if tag1 _LT_ tag2 then LT_ else GT_
   where
     tag (MonoTyVar n1)		= (ILIT(1) :: FAST_INT)
-    tag (MonoTupleTy tys1)	= ILIT(2)
-    tag (MonoListTy ty1)	= ILIT(3)
+    tag (MonoTupleTy _ tys1)	= ILIT(2)
+    tag (MonoListTy _ ty1)	= ILIT(3)
     tag (MonoTyApp tc1 tys1)	= ILIT(4)
     tag (MonoFunTy a1 b1)	= ILIT(5)
     tag (MonoDictTy c1 ty1)	= ILIT(7)
+    tag (HsForAllTy _ _ _)	= ILIT(8)
+    tag (HsPreForAllTy _ _)	= ILIT(9)
 
 -------------------
 cmpContext cmp a b
   = cmpList cmp_ctxt a b
   where
-    cmp_ctxt (c1, tv1) (c2, tv2)
-      = cmp c1 c2 `thenCmp` cmp tv1 tv2
-
-#endif {- COMPILING_GHC -}
+    cmp_ctxt (c1, ty1) (c2, ty2)
+      = cmp c1 c2 `thenCmp` cmpHsType cmp ty1 ty2
 \end{code}
diff --git a/ghc/compiler/main/CmdLineOpts.lhs b/ghc/compiler/main/CmdLineOpts.lhs
index 13abecba27..001cd61b94 100644
--- a/ghc/compiler/main/CmdLineOpts.lhs
+++ b/ghc/compiler/main/CmdLineOpts.lhs
@@ -23,7 +23,6 @@ module CmdLineOpts (
 	opt_AutoSccsOnExportedToplevs,
 	opt_AutoSccsOnIndividualCafs,
 	opt_CompilingGhcInternals,
-	opt_UsingGhcInternals,
 	opt_D_dump_absC,
 	opt_D_dump_asm,
 	opt_D_dump_deforest,
@@ -40,6 +39,7 @@ module CmdLineOpts (
 	opt_D_dump_stranal,
 	opt_D_dump_tc,
 	opt_D_show_passes,
+	opt_D_show_rn_trace,
 	opt_D_simplifier_stats,
 	opt_D_source_stats,
 	opt_D_verbose_core2core,
@@ -59,7 +59,7 @@ module CmdLineOpts (
 	opt_IgnoreStrictnessPragmas,
 	opt_IrrefutableEverything,
 	opt_IrrefutableTuples,
-	opt_NoImplicitPrelude,
+	opt_LiberateCaseThreshold,
 	opt_NumbersStrict,
 	opt_OmitBlackHoling,
 	opt_OmitDefaultInstanceMethods,
@@ -77,15 +77,19 @@ module CmdLineOpts (
 	opt_ShowImportSpecs,
 	opt_ShowPragmaNameErrs,
 	opt_SigsRequired,
+	opt_SourceUnchanged,
 	opt_SpecialiseAll,
 	opt_SpecialiseImports,
 	opt_SpecialiseOverloaded,
 	opt_SpecialiseTrace,
 	opt_SpecialiseUnboxed,
 	opt_StgDoLetNoEscapes,
+
+	opt_InterfaceUnfoldThreshold,
 	opt_UnfoldingCreationThreshold,
-	opt_UnfoldingOverrideThreshold,
+	opt_UnfoldingConDiscount,
 	opt_UnfoldingUseThreshold,
+
 	opt_Verbose,
 	opt_WarnNameShadowing
     ) where
@@ -96,7 +100,7 @@ import Argv
 
 CHK_Ubiq() -- debugging consistency check
 
-import CgCompInfo	-- Default values for some flags
+import Constants	-- Default values for some flags
 
 import Maybes		( assocMaybe, firstJust, maybeToBool )
 import Util		( startsWith, panic, panic#, assertPanic )
@@ -194,10 +198,6 @@ data SimplifierSwitch
 
   | MaxSimplifierIterations Int
 
-  | SimplUnfoldingUseThreshold      Int -- per-simplification variants
-  | SimplUnfoldingConDiscount       Int
-  | SimplUnfoldingCreationThreshold Int
-
   | KeepSpecPragmaIds	    -- We normally *toss* Ids we can do without
   | KeepUnusedBindings
 
@@ -226,9 +226,10 @@ data SimplifierSwitch
 %************************************************************************
 
 \begin{code}
-lookUp	   :: FAST_STRING -> Bool
-lookup_int :: String -> Maybe Int
-lookup_str :: String -> Maybe String
+lookUp	       :: FAST_STRING -> Bool
+lookup_int     :: String -> Maybe Int
+lookup_def_int :: String -> Int -> Int
+lookup_str     :: String -> Maybe String
 
 lookUp     sw = maybeToBool (assoc_opts sw)
 	
@@ -238,6 +239,10 @@ lookup_int sw = case (lookup_str sw) of
 		  Nothing -> Nothing
 		  Just xx -> Just (read xx)
 
+lookup_def_int sw def = case (lookup_str sw) of
+			    Nothing -> def		-- Use default
+		  	    Just xx -> read xx
+
 assoc_opts    = assocMaybe [ (a, True) | a <- argv ]
 unpacked_opts = map _UNPK_ argv
 \end{code}
@@ -248,6 +253,8 @@ opt_AllStrict			= lookUp  SLIT("-fall-strict")
 opt_AutoSccsOnAllToplevs	= lookUp  SLIT("-fauto-sccs-on-all-toplevs")
 opt_AutoSccsOnExportedToplevs	= lookUp  SLIT("-fauto-sccs-on-exported-toplevs")
 opt_AutoSccsOnIndividualCafs	= lookUp  SLIT("-fauto-sccs-on-individual-cafs")
+opt_CompilingGhcInternals	= maybeToBool maybe_CompilingGhcInternals
+maybe_CompilingGhcInternals	= lookup_str "-fcompiling-ghc-internals="
 opt_D_dump_absC			= lookUp  SLIT("-ddump-absC")
 opt_D_dump_asm			= lookUp  SLIT("-ddump-asm")
 opt_D_dump_deforest		= lookUp  SLIT("-ddump-deforest")
@@ -264,6 +271,7 @@ opt_D_dump_stg			= lookUp  SLIT("-ddump-stg")
 opt_D_dump_stranal		= lookUp  SLIT("-ddump-stranal")
 opt_D_dump_tc			= lookUp  SLIT("-ddump-tc")
 opt_D_show_passes		= lookUp  SLIT("-dshow-passes")
+opt_D_show_rn_trace		= lookUp  SLIT("-dshow-rn-trace")
 opt_D_simplifier_stats		= lookUp  SLIT("-dsimplifier-stats")
 opt_D_source_stats		= lookUp  SLIT("-dsource-stats")
 opt_D_verbose_core2core		= lookUp  SLIT("-dverbose-simpl")
@@ -271,16 +279,18 @@ opt_D_verbose_stg2stg		= lookUp  SLIT("-dverbose-stg")
 opt_DoCoreLinting		= lookUp  SLIT("-dcore-lint")
 opt_DoSemiTagging		= lookUp  SLIT("-fsemi-tagging")
 opt_DoTickyProfiling		= lookUp  SLIT("-fticky-ticky")
+opt_EnsureSplittableC		= lookUp  SLIT("-fglobalise-toplev-names")
 opt_FoldrBuildOn		= lookUp  SLIT("-ffoldr-build-on")
 opt_FoldrBuildTrace		= lookUp  SLIT("-ffoldr-build-trace")
 opt_ForConcurrent		= lookUp  SLIT("-fconcurrent")
 opt_GranMacros			= lookUp  SLIT("-fgransim")
 opt_GlasgowExts			= lookUp  SLIT("-fglasgow-exts")
 opt_Haskell_1_3			= lookUp  SLIT("-fhaskell-1.3")
+opt_HiMap 			= lookup_str "-himap="  -- file saying where to look for .hi files
+opt_IgnoreIfacePragmas		= lookUp  SLIT("-fignore-interface-pragmas")
 opt_IgnoreStrictnessPragmas	= lookUp  SLIT("-fignore-strictness-pragmas")
 opt_IrrefutableEverything	= lookUp  SLIT("-firrefutable-everything")
 opt_IrrefutableTuples		= lookUp  SLIT("-firrefutable-tuples")
-opt_WarnNameShadowing		= lookUp  SLIT("-fwarn-name-shadowing")
 opt_NumbersStrict		= lookUp  SLIT("-fnumbers-strict")
 opt_OmitBlackHoling		= lookUp  SLIT("-dno-black-holing")
 opt_OmitDefaultInstanceMethods	= lookUp  SLIT("-fomit-default-instance-methods")
@@ -288,34 +298,35 @@ opt_OmitInterfacePragmas	= lookUp  SLIT("-fomit-interface-pragmas")
 opt_PprStyle_All		= lookUp  SLIT("-dppr-all")
 opt_PprStyle_Debug		= lookUp  SLIT("-dppr-debug")
 opt_PprStyle_User		= lookUp  SLIT("-dppr-user")
+opt_ProduceC  			= lookup_str "-C="
+opt_ProduceS  			= lookup_str "-S="
+opt_ProduceHi 			= lookup_str "-hifile=" -- the one to produce this time 
 opt_ReportWhyUnfoldingsDisallowed= lookUp SLIT("-freport-disallowed-unfoldings")
 opt_SccProfilingOn		= lookUp  SLIT("-fscc-profiling")
 opt_ShowImportSpecs		= lookUp  SLIT("-fshow-import-specs")
 opt_ShowPragmaNameErrs		= lookUp  SLIT("-fshow-pragma-name-errs")
 opt_SigsRequired		= lookUp  SLIT("-fsignatures-required")
+opt_SourceUnchanged		= lookUp  SLIT("-fsource-unchanged")
 opt_SpecialiseAll		= lookUp  SLIT("-fspecialise-all")
 opt_SpecialiseImports		= lookUp  SLIT("-fspecialise-imports")
 opt_SpecialiseOverloaded	= lookUp  SLIT("-fspecialise-overloaded")
 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_UsingGhcInternals		= lookUp  SLIT("-fusing-ghc-internals")
-opt_CompilingGhcInternals	= maybeToBool maybe_CompilingGhcInternals
-maybe_CompilingGhcInternals	= lookup_str "-fcompiling-ghc-internals="
-opt_SccGroup  			= lookup_str "-G="
-opt_ProduceC  			= lookup_str "-C="
-opt_ProduceS  			= lookup_str "-S="
-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"
-opt_UnfoldingOverrideThreshold	= lookup_int "-funfolding-override-threshold"
 opt_ReturnInRegsThreshold	= lookup_int "-freturn-in-regs-threshold"
+opt_SccGroup  			= lookup_str "-G="
+opt_Verbose			= lookUp  SLIT("-v")
 
-opt_NoImplicitPrelude		= lookUp  SLIT("-fno-implicit-prelude")
-opt_IgnoreIfacePragmas		= lookUp  SLIT("-fignore-interface-pragmas")
+opt_InterfaceUnfoldThreshold	= lookup_def_int "-funfolding-interface-threshold" iNTERFACE_UNFOLD_THRESHOLD
+opt_UnfoldingCreationThreshold	= lookup_def_int "-funfolding-creation-threshold"  uNFOLDING_CREATION_THRESHOLD
+opt_UnfoldingUseThreshold	= lookup_def_int "-funfolding-use-threshold"	   uNFOLDING_USE_THRESHOLD
+opt_UnfoldingConDiscount	= lookup_def_int "-funfolding-con-discount"	   uNFOLDING_CON_DISCOUNT_WEIGHT
+			
+opt_LiberateCaseThreshold	= lookup_def_int "-fliberate-case-threshold"	   lIBERATE_CASE_THRESHOLD
+opt_WarnNameShadowing		= lookUp  SLIT("-fwarn-name-shadowing")
+
+-- opt_UnfoldingUseThreshold	= lookup_int "-funfolding-use-threshold"
+-- opt_UnfoldingOverrideThreshold	= lookup_int "-funfolding-override-threshold"
 \end{code}
 
 \begin{code}
@@ -421,21 +432,9 @@ classifyOpts = sep argv [] [] -- accumulators...
 	  "-fno-let-from-strict-let"	    -> SIMPL_SW(SimplNoLetFromStrictLet)
 
 	  o | starts_with_msi  -> SIMPL_SW(MaxSimplifierIterations (read after_msi))
-	    | starts_with_suut -> SIMPL_SW(SimplUnfoldingUseThreshold (read after_suut))
-	    | starts_with_suct -> SIMPL_SW(SimplUnfoldingCreationThreshold (read after_suct))
-	    | starts_with_sucd -> SIMPL_SW(SimplUnfoldingConDiscount (read after_sucd))
 	   where
-	    maybe_suut		= startsWith "-fsimpl-uf-use-threshold"      o
-	    maybe_suct		= startsWith "-fsimpl-uf-creation-threshold" o
-	    maybe_sucd		= startsWith "-fsimpl-uf-con-discount" o
 	    maybe_msi		= startsWith "-fmax-simplifier-iterations"   o
-	    starts_with_suut	= maybeToBool maybe_suut
-	    starts_with_suct	= maybeToBool maybe_suct
-	    starts_with_sucd	= maybeToBool maybe_sucd
 	    starts_with_msi	= maybeToBool maybe_msi
-	    (Just after_suut)	= maybe_suut
-	    (Just after_suct)	= maybe_suct
-	    (Just after_sucd)	= maybe_sucd
 	    (Just after_msi)	= maybe_msi
 
 	  _ -> -- NB: the driver is really supposed to handle bad options
@@ -478,9 +477,6 @@ tagOf_SimplSwitch SimplDoEtaReduction		= ILIT(18)
 tagOf_SimplSwitch EssentialUnfoldingsOnly	= ILIT(19)
 tagOf_SimplSwitch ShowSimplifierProgress	= ILIT(20)
 tagOf_SimplSwitch (MaxSimplifierIterations _)	= ILIT(21)
-tagOf_SimplSwitch (SimplUnfoldingUseThreshold _)      = ILIT(22)
-tagOf_SimplSwitch (SimplUnfoldingConDiscount _)       = ILIT(23)
-tagOf_SimplSwitch (SimplUnfoldingCreationThreshold _) = ILIT(24)
 tagOf_SimplSwitch KeepSpecPragmaIds		= ILIT(25)
 tagOf_SimplSwitch KeepUnusedBindings		= ILIT(26)
 tagOf_SimplSwitch SimplNoLetFromCase		= ILIT(27)
@@ -540,9 +536,6 @@ isAmongSimpl on_switches		-- Switches mentioned later occur *earlier*
     }
   where
     mk_assoc_elem k@(MaxSimplifierIterations lvl)       = IBOX(tagOf_SimplSwitch k) SET_TO SwInt lvl
-    mk_assoc_elem k@(SimplUnfoldingUseThreshold      i) = IBOX(tagOf_SimplSwitch k) SET_TO SwInt i
-    mk_assoc_elem k@(SimplUnfoldingConDiscount       i) = IBOX(tagOf_SimplSwitch k) SET_TO SwInt i
-    mk_assoc_elem k@(SimplUnfoldingCreationThreshold i) = IBOX(tagOf_SimplSwitch k) SET_TO SwInt i
 
     mk_assoc_elem k = IBOX(tagOf_SimplSwitch k) SET_TO SwBool   True -- I'm here, Mom!
 
@@ -560,10 +553,7 @@ isAmongSimpl on_switches		-- Switches mentioned later occur *earlier*
 Default settings for simplifier switches
 
 \begin{code}
-defaultSimplSwitches = [SimplUnfoldingCreationThreshold uNFOLDING_CREATION_THRESHOLD,
-			SimplUnfoldingUseThreshold	uNFOLDING_USE_THRESHOLD,
-			SimplUnfoldingConDiscount	uNFOLDING_CON_DISCOUNT_WEIGHT,
-			MaxSimplifierIterations		1
+defaultSimplSwitches = [MaxSimplifierIterations		1
 		       ]
 \end{code}
 
diff --git a/ghc/compiler/main/ErrUtils.lhs b/ghc/compiler/main/ErrUtils.lhs
index c0d0e7108f..5918cf6cba 100644
--- a/ghc/compiler/main/ErrUtils.lhs
+++ b/ghc/compiler/main/ErrUtils.lhs
@@ -20,7 +20,7 @@ IMP_Ubiq(){-uitous-}
 import Bag		( bagToList )
 import PprStyle		( PprStyle(..) )
 import Pretty
-import SrcLoc		( mkUnknownSrcLoc, SrcLoc{-instance-} )
+import SrcLoc		( noSrcLoc, SrcLoc{-instance-} )
 \end{code}
 
 \begin{code}
diff --git a/ghc/compiler/main/Main.lhs b/ghc/compiler/main/Main.lhs
index 0db5364910..cb893f76dc 100644
--- a/ghc/compiler/main/Main.lhs
+++ b/ghc/compiler/main/Main.lhs
@@ -12,14 +12,18 @@ IMP_Ubiq(){-uitous-}
 IMPORT_1_3(IO(hGetContents,stdin,stderr,hPutStr,hClose,openFile,IOMode(..)))
 
 import HsSyn
+import RdrHsSyn		( RdrName )
 
 import ReadPrefix	( rdModule )
 import Rename		( renameModule )
+import RnMonad		( ExportEnv )
+
 import MkIface		-- several functions
 import TcModule		( typecheckModule )
 import Desugar		( deSugar, DsMatchContext, pprDsWarnings )
 import SimplCore	( core2core )
 import CoreToStg	( topCoreBindsToStg )
+import StgSyn		( collectFinalStgBinders )
 import SimplStg		( stg2stg )
 import CodeGen		( codeGen )
 #if ! OMIT_NATIVE_CODEGEN
@@ -33,7 +37,6 @@ import Bag		( emptyBag, isEmptyBag )
 import CmdLineOpts
 import ErrUtils		( pprBagOfErrors, ghcExit )
 import Maybes		( maybeToBool, MaybeErr(..) )
-import RdrHsSyn		( getRawExportees )
 import Specialise	( SpecialiseData(..) )
 import StgSyn		( pprPlainStgBinding, GenStgBinding )
 import TcInstUtil	( InstInfo )
@@ -46,9 +49,8 @@ import PprStyle		( PprStyle(..) )
 import Pretty
 
 import Id		( GenId )		-- instances
-import Name		( Name, RdrName )	-- instances
+import Name		( Name )		-- instances
 import PprType		( GenType, GenTyVar )	-- instances
-import RnHsSyn		( RnName )		-- instances
 import TyVar		( GenTyVar )		-- instances
 import Unique		( Unique )		-- instances
 \end{code}
@@ -66,7 +68,7 @@ main
 doIt :: ([CoreToDo], [StgToDo]) -> String -> IO ()
 
 doIt (core_cmds, stg_cmds) input_pgm
-  = doDump opt_Verbose "Glasgow Haskell Compiler, version 2.01, for Haskell 1.3" "" >>
+  = doDump opt_Verbose "Glasgow Haskell Compiler, version 2.02, for Haskell 1.3" "" >>
 
     -- ******* READER
     show_pass "Reader"	>>
@@ -94,25 +96,19 @@ doIt (core_cmds, stg_cmds) input_pgm
     _scc_     "Renamer"
 
     renameModule rn_uniqs rdr_module >>=
-	\ (rn_mod, rn_env, import_names,
-	   export_stuff, usage_stuff,
-	   rn_errs_bag, rn_warns_bag) ->
+	\ (maybe_rn_stuff, rn_errs_bag, rn_warns_bag) ->
 
-    if (not (isEmptyBag rn_errs_bag)) then
-	hPutStr stderr (ppShow pprCols (pprBagOfErrors pprErrorsStyle rn_errs_bag))
-	>> hPutStr stderr "\n" >>
-	hPutStr stderr (ppShow pprCols (pprBagOfErrors pprErrorsStyle rn_warns_bag))
-	>> hPutStr stderr "\n" >>
-	ghcExit 1
+    checkErrors rn_errs_bag rn_warns_bag	>>
+    case maybe_rn_stuff of {
+	Nothing -> 	-- Hurrah!  Renamer reckons that there's no need to
+			-- go any further
+			hPutStr stderr "No recompilation required!\n"	>>
+			ghcExit 0 ;
+
+		-- Oh well, we've got to recompile for real
+	Just (rn_mod, iface_file_stuff, rn_name_supply, imported_modules) ->
 
-    else -- No renaming errors ...
 
-    (if (isEmptyBag rn_warns_bag) then
-	return ()
-     else
-	hPutStr stderr (ppShow pprCols (pprBagOfErrors pprErrorsStyle rn_warns_bag))
-	>> hPutStr stderr "\n"
-    )   					>>
 
     doDump opt_D_dump_rn "Renamer:"
 	(pp_show (ppr pprStyle rn_mod))		>>
@@ -121,20 +117,14 @@ doIt (core_cmds, stg_cmds) input_pgm
     -- (the iface file is produced incrementally, as we have
     -- the information that we need...; we use "iface<blah>")
     -- "endIface" finishes the job.
-    let
-	(usages_map, version_info, instance_modules) = usage_stuff
-    in
-    startIface mod_name				    >>= \ if_handle ->
-    ifaceUsages		 if_handle usages_map	    >>
-    ifaceVersions	 if_handle version_info	    >>
-    ifaceExportList	 if_handle export_stuff rn_env >>
-    ifaceFixities	 if_handle rn_mod	    >>
-    ifaceInstanceModules if_handle instance_modules >>
+    startIface mod_name					>>= \ if_handle ->
+    ifaceMain if_handle iface_file_stuff		>>
+
 
     -- ******* TYPECHECKER
     show_pass "TypeCheck" 			>>
     _scc_     "TypeCheck"
-    case (case (typecheckModule tc_uniqs {-idinfo_fm-} rn_env rn_mod) of
+    case (case (typecheckModule tc_uniqs {-idinfo_fm-} rn_name_supply rn_mod) of
 	    Succeeded (stuff, warns)
 		-> (emptyBag, warns, stuff)
 	    Failed (errs, warns)
@@ -142,26 +132,12 @@ doIt (core_cmds, stg_cmds) input_pgm
 
     of { (tc_errs_bag, tc_warns_bag, tc_results) ->
 
-    if (not (isEmptyBag tc_errs_bag)) then
-	hPutStr stderr (ppShow pprCols (pprBagOfErrors pprErrorsStyle tc_errs_bag))
-	>> hPutStr stderr "\n" >>
-	hPutStr stderr (ppShow pprCols (pprBagOfErrors pprErrorsStyle tc_warns_bag))
-	>> hPutStr stderr "\n" >>
-	ghcExit 1
-
-    else ( -- No typechecking errors ...
-
-    (if (isEmptyBag tc_warns_bag) then
-	return ()
-     else
-	hPutStr stderr (ppShow pprCols (pprBagOfErrors pprErrorsStyle tc_warns_bag))
-	>> hPutStr stderr "\n"
-    )   					>>
+    checkErrors tc_errs_bag tc_warns_bag	>>
 
     case tc_results
     of {  (typechecked_quint@(recsel_binds, class_binds, inst_binds, val_binds, const_binds),
-	   interface_stuff@(_,local_tycons,_,_),
-	   pragma_tycon_specs, ddump_deriv) ->
+	   local_tycons, inst_info, pragma_tycon_specs,
+	   ddump_deriv) ->
 
     doDump opt_D_dump_tc "Typechecked:"
 	(pp_show (ppAboves [
@@ -174,12 +150,12 @@ doIt (core_cmds, stg_cmds) input_pgm
     doDump opt_D_dump_deriv "Derived instances:"
 	(pp_show (ddump_deriv pprStyle))	>>
 
-    -- OK, now do the interface stuff that relies on typechecker output:
-    ifaceDecls     if_handle interface_stuff	>>
-    ifaceInstances if_handle interface_stuff	>>
+	-- Now (and alas only now) we have the derived-instance information
+	-- so we can put instance information in the interface file
+    ifaceInstances if_handle inst_info			>>
 
     -- ******* DESUGARER
-    show_pass "DeSugar" 			>>
+    show_pass "DeSugar " 			>>
     _scc_     "DeSugar"
     let
 	(desugared,ds_warnings)
@@ -206,7 +182,7 @@ doIt (core_cmds, stg_cmds) input_pgm
 	      sm_uniqs local_data_tycons pragma_tycon_specs desugared
 						>>=
 
-	 \ (simplified, inlinings_env,
+	 \ (simplified,
 	    SpecData _ _ _ gen_tycons all_tycon_specs _ _ _) ->
 
     doDump opt_D_dump_simpl "Simplified:" (pp_show (ppAboves
@@ -231,19 +207,25 @@ doIt (core_cmds, stg_cmds) input_pgm
 	(pp_show (ppAboves (map (pprPlainStgBinding pprStyle) stg_binds2)))
 						>>
 
+	-- Dump type signatures into the interface file
+    let
+	final_ids = collectFinalStgBinders stg_binds2
+    in
+    ifaceDecls if_handle rn_mod final_ids simplified	>>
+    endIface if_handle					>>
     -- We are definitely done w/ interface-file stuff at this point:
     -- (See comments near call to "startIface".)
-    endIface if_handle				>>
+    
 
     -- ******* "ABSTRACT", THEN "FLAT", THEN *REAL* C!
     show_pass "CodeGen" 			>>
     _scc_     "CodeGen"
     let
-	abstractC      = codeGen mod_name     -- module name for CC labelling
+	abstractC      = codeGen mod_name		-- module name for CC labelling
 				 cost_centre_info
-				 import_names -- import names for CC registering
-				 gen_tycons	 -- type constructors generated locally
-				 all_tycon_specs -- tycon specialisations
+				 imported_modules	-- import names for CC registering
+				 gen_tycons		-- type constructors generated locally
+				 all_tycon_specs	-- tycon specialisations
 				 stg_binds2
 
     	flat_abstractC = flattenAbsC fl_uniqs abstractC
@@ -285,24 +267,11 @@ doIt (core_cmds, stg_cmds) input_pgm
     doOutput opt_ProduceC c_output_w 		>>
 
     ghcExit 0
-    } ) }
+    } } }
   where
     -------------------------------------------------------------
     -- ****** printing styles and column width:
 
-    pprCols = (80 :: Int) -- could make configurable
-
-    (pprStyle, pprErrorsStyle)
-      = if      opt_PprStyle_All   then
-		(PprShowAll, PprShowAll)
-	else if opt_PprStyle_Debug then
-		(PprDebug, PprDebug)
-	else if opt_PprStyle_User  then
-		(PprForUser, PprForUser)
-	else -- defaults...
-		(PprDebug, PprForUser)
-
-    pp_show p = ppShow {-WAS:pprCols-}10000{-random-} p
 
     -------------------------------------------------------------
     -- ****** help functions:
@@ -328,9 +297,32 @@ doIt (core_cmds, stg_cmds) input_pgm
 	else return ()
 
 
-ppSourceStats (HsModule name version exports imports fixities typedecls typesigs
-		      classdecls instdecls instsigs defdecls binds
-		      [{-no sigs-}] src_loc)
+pprCols = (80 :: Int) -- could make configurable
+
+(pprStyle, pprErrorsStyle)
+  | opt_PprStyle_All   = (PprShowAll, PprShowAll)
+  | opt_PprStyle_Debug = (PprDebug,   PprDebug)
+  | opt_PprStyle_User  = (PprForUser, PprForUser)
+  | otherwise	       = (PprDebug,   PprForUser)
+
+pp_show p = ppShow {-WAS:pprCols-}10000{-random-} p
+
+checkErrors errs_bag warns_bag
+  | not (isEmptyBag errs_bag)
+  = 	hPutStr stderr (ppShow pprCols (pprBagOfErrors pprErrorsStyle errs_bag))
+	>> hPutStr stderr "\n" >>
+	hPutStr stderr (ppShow pprCols (pprBagOfErrors pprErrorsStyle warns_bag))
+	>> hPutStr stderr "\n" >>
+	ghcExit 1
+
+  | not (isEmptyBag warns_bag)
+  = hPutStr stderr (ppShow pprCols (pprBagOfErrors pprErrorsStyle warns_bag))	>> 
+    hPutStr stderr "\n"
+ 
+  | otherwise = return ()
+
+
+ppSourceStats (HsModule name version exports imports fixities decls src_loc)
  = ppAboves (map pp_val
 	       [("ExportAll        ", export_all), -- 1 if no export list
 		("ExportDecls      ", export_ds),
@@ -342,7 +334,7 @@ ppSourceStats (HsModule name version exports imports fixities typedecls typesigs
 		("  ImpPartial     ", import_partial),
 		("  ImpHiding      ", import_hiding),
 		("FixityDecls      ", fixity_ds),
-		("DefaultDecls     ", defalut_ds),
+		("DefaultDecls     ", default_ds),
 	      	("TypeDecls        ", type_ds),
 	      	("DataDecls        ", data_ds),
 	      	("NewTypeDecls     ", newt_ds),
@@ -358,8 +350,8 @@ ppSourceStats (HsModule name version exports imports fixities typedecls typesigs
 	      	("FunBinds         ", fn_bind_ds),
 	      	("InlineMeths      ", method_inlines),
 		("InlineBinds      ", bind_inlines),
-	      	("SpecialisedData  ", data_specs),
-	      	("SpecialisedInsts ", inst_specs),
+--	      	("SpecialisedData  ", data_specs),
+--	      	("SpecialisedInsts ", inst_specs),
 	      	("SpecialisedMeths ", method_specs),
 	      	("SpecialisedBinds ", bind_specs)
 	       ])
@@ -367,37 +359,38 @@ ppSourceStats (HsModule name version exports imports fixities typedecls typesigs
     pp_val (str, 0) = ppNil
     pp_val (str, n) = ppBesides [ppStr str, ppInt n]
 
-    (export_decls, export_mods) = getRawExportees exports
-    type_decls = filter is_type_decl typedecls
-    data_decls = filter is_data_decl typedecls
-    newt_decls = filter is_newt_decl typedecls
-
-    export_ds  = length export_decls
-    export_ms  = length export_mods
-    export_all = if export_ds == 0 && export_ms == 0 then 1 else 0
-
-    fixity_ds  = length fixities
-    defalut_ds = length defdecls
-    type_ds    = length type_decls
-    data_ds    = length data_decls
-    newt_ds    = length newt_decls
-    class_ds   = length classdecls
-    inst_ds    = length instdecls
+    fixity_ds   = length fixities
+    type_decls 	= [d | TyD d@(TySynonym _ _ _ _)    <- decls]
+    data_decls 	= [d | TyD d@(TyData _ _ _ _ _ _ _) <- decls]
+    newt_decls 	= [d | TyD d@(TyNew  _ _ _ _ _ _ _) <- decls]
+    type_ds	= length type_decls
+    data_ds	= length data_decls
+    newt_ds	= length newt_decls
+    class_decls = [d | ClD d <- decls]
+    class_ds    = length class_decls
+    inst_decls  = [d | InstD d <- decls]
+    inst_ds     = length inst_decls
+    default_ds  = length [() | DefD _ <- decls]
+    val_decls   = [d | ValD d <- decls]
+
+    real_exports = case exports of { Nothing -> []; Just es -> es }
+    n_exports  	 = length real_exports
+    export_ms  	 = length [() | IEModuleContents _ <- real_exports]
+    export_ds  	 = n_exports - export_ms
+    export_all 	 = case exports of { Nothing -> 1; other -> 0 }
 
     (val_bind_ds, fn_bind_ds, bind_tys, bind_specs, bind_inlines)
-	= count_binds binds
+	= count_binds (foldr ThenBinds EmptyBinds val_decls)
 
     (import_no, import_qual, import_as, import_all, import_partial, import_hiding)
 	= foldr add6 (0,0,0,0,0,0) (map import_info imports)
     (data_constrs, data_derivs)
 	= foldr add2 (0,0) (map data_info (newt_decls ++ data_decls))
     (class_method_ds, default_method_ds)
-	= foldr add2 (0,0) (map class_info classdecls)
+	= foldr add2 (0,0) (map class_info class_decls)
     (inst_method_ds, method_specs, method_inlines)
-	= foldr add3 (0,0,0) (map inst_info instdecls)
+	= foldr add3 (0,0,0) (map inst_info inst_decls)
 
-    data_specs  = length typesigs
-    inst_specs  = length instsigs
 
     count_binds EmptyBinds        = (0,0,0,0,0)
     count_binds (ThenBinds b1 b2) = count_binds b1 `add5` count_binds b2
@@ -418,7 +411,7 @@ ppSourceStats (HsModule name version exports imports fixities typedecls typesigs
 
     count_sigs sigs = foldr add4 (0,0,0,0) (map sig_info sigs)
 
-    sig_info (Sig _ _ _ _)        = (1,0,0,0)
+    sig_info (Sig _ _ _)          = (1,0,0,0)
     sig_info (ClassOpSig _ _ _ _) = (0,1,0,0)
     sig_info (SpecSig _ _ _ _)    = (0,0,1,0)
     sig_info (InlineSig _ _)      = (0,0,0,1)
@@ -437,25 +430,18 @@ ppSourceStats (HsModule name version exports imports fixities typedecls typesigs
     data_info (TyData _ _ _ constrs derivs _ _)
 	= (length constrs, case derivs of {Nothing -> 0; Just ds -> length ds})
     data_info (TyNew _ _ _ constr derivs _ _)
-	= (length constr, case derivs of {Nothing -> 0; Just ds -> length ds})
+	= (1, case derivs of {Nothing -> 0; Just ds -> length ds})
 
     class_info (ClassDecl _ _ _ meth_sigs def_meths _ _)
 	= case count_sigs meth_sigs of
 	    (_,classops,_,_) ->
 	       (classops, addpr (count_monobinds def_meths))
 
-    inst_info (InstDecl _ _ inst_meths _ _ inst_sigs _ _)
+    inst_info (InstDecl _ inst_meths inst_sigs _ _)
 	= case count_sigs inst_sigs of
 	    (_,_,ss,is) ->
 	       (addpr (count_monobinds inst_meths), ss, is)
 
-    is_type_decl (TySynonym _ _ _ _)     = True
-    is_type_decl _		         = False
-    is_data_decl (TyData _ _ _ _ _ _ _)  = True
-    is_data_decl _		         = False
-    is_newt_decl (TyNew  _ _ _ _ _ _ _)  = True
-    is_newt_decl _		         = False
-
     addpr (x,y) = x+y
     add1 x1 y1  = x1+y1
     add2 (x1,x2) (y1,y2) = (x1+y1,x2+y2)
diff --git a/ghc/compiler/main/MkIface.lhs b/ghc/compiler/main/MkIface.lhs
index d8ead0bcaa..3129d80a6c 100644
--- a/ghc/compiler/main/MkIface.lhs
+++ b/ghc/compiler/main/MkIface.lhs
@@ -8,59 +8,61 @@
 
 module MkIface (
 	startIface, endIface,
-	ifaceUsages,
-	ifaceVersions,
-	ifaceExportList,
-	ifaceFixities,
-	ifaceInstanceModules,
-	ifaceDecls,
-	ifaceInstances,
-	ifacePragmas
+	ifaceMain, ifaceInstances,
+	ifaceDecls
     ) where
 
 IMP_Ubiq(){-uitous-}
 IMPORT_1_3(IO(Handle,hPutStr,openFile,hClose,IOMode(..)))
 
-import Bag		( bagToList )
-import Class		( GenClass(..){-instance NamedThing-}, GenClassOp(..) )
-import CmdLineOpts	( opt_ProduceHi )
-import FieldLabel	( FieldLabel{-instance NamedThing-} )
-import FiniteMap	( emptyFM, addToFM, lookupFM, fmToList, eltsFM, FiniteMap )
 import HsSyn
+import RdrHsSyn		( RdrName(..) )
+import RnHsSyn		( SYN_IE(RenamedHsModule) )
+import RnMonad
+
+import TcInstUtil	( InstInfo(..) )
+
+import CmdLineOpts
 import Id		( idType, dataConRawArgTys, dataConFieldLabels, isDataCon,
-			  dataConStrictMarks, StrictnessMark(..),
+			  getIdInfo, idWantsToBeINLINEd, wantIdSigInIface,
+			  dataConStrictMarks, StrictnessMark(..), 
+			  SYN_IE(IdSet), idSetToList, unionIdSets, unitIdSet, minusIdSet, 
+			  isEmptyIdSet, elementOfIdSet, emptyIdSet, mkIdSet,
 			  GenId{-instance NamedThing/Outputable-}
 			)
-import Maybes		( maybeToBool )
-import Name		( origName, nameOf, moduleOf,
-			  exportFlagOn, nameExportFlag, ExportFlag(..),
-			  isLexSym, isLexCon, isLocallyDefined, isWiredInName,
-			  RdrName(..){-instance Outputable-},
-			  OrigName(..){-instance Ord-},
-			  Name{-instance NamedThing-}
+import IdInfo		( StrictnessInfo, ArityInfo, Unfolding,
+			  arityInfo, ppArityInfo, strictnessInfo, ppStrictnessInfo, 
+			  getWorkerId_maybe, bottomIsGuaranteed 
 			)
-import ParseUtils	( UsagesMap(..), VersionsMap(..) )
+import CoreSyn		( SYN_IE(CoreExpr), SYN_IE(CoreBinding), GenCoreExpr, GenCoreBinding(..) )
+import CoreUnfold	( calcUnfoldingGuidance, UnfoldingGuidance(..) )
+import FreeVars		( addExprFVs )
+import Name		( isLocallyDefined, isWiredInName, modAndOcc, getName, pprOccName,
+			  OccName, occNameString, nameOccName, nameString, isExported, pprNonSym,
+			  Name {-instance NamedThing-}, Provenance
+			)
+import TyCon		( TyCon(..){-instance NamedThing-}, NewOrData(..) )
+import Class		( GenClass(..){-instance NamedThing-}, GenClassOp, classOpLocalType )
+import FieldLabel	( FieldLabel{-instance NamedThing-} )
+import Type		( mkSigmaTy, mkDictTy, getAppTyCon, splitForAllTy )
+import TyVar		( GenTyVar {- instance Eq -} )
+import Unique		( Unique {- instance Eq -} )
+
 import PprEnv		-- not sure how much...
 import PprStyle		( PprStyle(..) )
-import PprType		-- most of it (??)
---import PrelMods	( modulesWithBuiltins )
-import PrelInfo		( builtinValNamesMap, builtinTcNamesMap )
-import Pretty		( prettyToUn )
+import PprType
+import PprCore		( pprIfaceUnfolding )
+import Pretty
 import Unpretty		-- ditto
-import RnHsSyn		( isRnConstr, SYN_IE(RenamedHsModule), RnName(..) )
-import RnUtils		( SYN_IE(RnEnv) {-, pprRnEnv ToDo:rm-} )
-import TcModule		( SYN_IE(TcIfaceInfo) )
-import TcInstUtil	( InstInfo(..) )
-import TyCon		( TyCon(..){-instance NamedThing-}, NewOrData(..) )
-import Type		( mkSigmaTy, mkDictTy, getAppTyCon, splitForAllTy )
-import Util		( sortLt, removeDups, zipWithEqual, zipWith3Equal, assertPanic, panic{-ToDo:rm-}{-, pprTrace ToDo:rm-} )
 
-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
-  = case (origName "ppr_name" n) of { OrigName m s ->
-    uppBesides [uppPStr m, uppChar '.', uppPStr s] }
+
+import Bag		( bagToList )
+import Maybes		( catMaybes, maybeToBool )
+import FiniteMap	( emptyFM, addToFM, lookupFM, fmToList, eltsFM, FiniteMap )
+import UniqFM		( UniqFM, lookupUFM, listToUFM )
+import Util		( sortLt, zipWithEqual, zipWith3Equal, mapAccumL,
+			  assertPanic, panic{-ToDo:rm-}, pprTrace )
+
 \end{code}
 
 We have a function @startIface@ to open the output file and put
@@ -74,39 +76,20 @@ to the handle provided by @startIface@.
 \begin{code}
 startIface  :: Module
 	    -> IO (Maybe Handle) -- Nothing <=> don't do an interface
-endIface    :: Maybe Handle -> IO ()
-ifaceUsages
-	    :: Maybe Handle
-	    -> UsagesMap
-	    -> IO ()
-ifaceVersions
-	    :: Maybe Handle
-	    -> VersionsMap
-	    -> IO ()
-ifaceExportList
-	    :: Maybe Handle
-	    -> (Name -> ExportFlag, ([(Name,ExportFlag)], [(Name,ExportFlag)]))
-	    -> RnEnv
-	    -> IO ()
-ifaceFixities
-	    :: Maybe Handle
-	    -> RenamedHsModule
-	    -> IO ()
-ifaceInstanceModules
-	    :: Maybe Handle
-	    -> [Module]
-	    -> IO ()
-ifaceDecls  :: Maybe Handle
-	    -> TcIfaceInfo  -- info produced by typechecker, for interfaces
-	    -> IO ()
-ifaceInstances
-	    :: Maybe Handle
-	    -> TcIfaceInfo  -- as above
-	    -> IO ()
-ifacePragmas
-	    :: Maybe Handle
+
+ifaceMain   :: Maybe Handle
+	    -> InterfaceDetails
 	    -> IO ()
-ifacePragmas = panic "ifacePragmas" -- stub
+
+ifaceInstances :: Maybe Handle -> Bag InstInfo -> IO ()
+
+ifaceDecls :: Maybe Handle
+	   -> RenamedHsModule
+	   -> [Id]		-- Ids used at code-gen time; they have better pragma info!
+	   -> [CoreBinding]	-- In dependency order, later depend on earlier
+	   -> IO ()
+
+endIface    :: Maybe Handle -> IO ()
 \end{code}
 
 \begin{code}
@@ -115,370 +98,341 @@ startIface mod
       Nothing -> return Nothing -- not producing any .hi file
       Just fn ->
 	openFile fn WriteMode	>>= \ if_hdl ->
-	hPutStr if_hdl ("{-# GHC_PRAGMA INTERFACE VERSION 20 #-}\ninterface "++ _UNPK_ mod) >>
+	hPutStr if_hdl ("{-# GHC_PRAGMA INTERFACE VERSION 20 #-}\n_interface_ "++ _UNPK_ mod ++ "\n") >>
 	return (Just if_hdl)
 
 endIface Nothing	= return ()
 endIface (Just if_hdl)	= hPutStr if_hdl "\n" >> hClose if_hdl
 \end{code}
 
-\begin{code}
-ifaceUsages Nothing{-no iface handle-} _ = return ()
 
-ifaceUsages (Just if_hdl) usages
-  | null usages_list
-  = return ()
+\begin{code}
+ifaceMain Nothing iface_stuff = return ()
+ifaceMain (Just if_hdl)
+	  (import_usages, ExportEnv avails fixities, instance_modules)
+  =
+    ifaceInstanceModules	if_hdl instance_modules		>>
+    ifaceUsages			if_hdl import_usages		>>
+    ifaceExports		if_hdl avails			>>
+    ifaceFixities		if_hdl fixities			>>
+    return ()
+
+ifaceDecls Nothing rn_mod final_ids simplified = return ()
+ifaceDecls (Just hdl) 
+	   (HsModule _ _ _ _ _ decls _)
+	   final_ids binds
+  | null decls = return ()		 
+	--  You could have a module with just (re-)exports/instances in it
   | otherwise
-  = hPutStr if_hdl "\n__usages__\n"   >>
-    hPutStr if_hdl (uppShow 0 (uppAboves (map upp_uses usages_list)))
+  = hPutStr hdl "_declarations_\n"	>>
+    ifaceTCDecls hdl decls		>>
+    ifaceBinds hdl final_ids binds	>>
+    return ()
+\end{code}
+
+\begin{code}
+ifaceUsages if_hdl import_usages
+  = hPutStr if_hdl "_usages_\n"   >>
+    hPutCol if_hdl upp_uses (sortLt lt_imp_vers import_usages)
   where
-    usages_list = fmToList usages -- NO: filter has_no_builtins (...)
+    upp_uses (m, mv, versions)
+      = uppBesides [upp_module m, uppSP, uppInt mv, uppPStr SLIT(" :: "),
+		    upp_import_versions (sort_versions versions), uppSemi]
 
---  has_no_builtins (m, _)
---    = m `notElem` modulesWithBuiltins
---    -- Don't *have* to do this; save gratuitous spillage in
---    -- every interface.  Could be flag-controlled...
+	-- For imported versions we do print the version number
+    upp_import_versions nvs
+      = uppIntersperse uppSP [ uppCat [ppr_unqual_name n, uppInt v] | (n,v) <- nvs ]
 
-    upp_uses (m, (mv, versions))
-      = uppBesides [uppPStr m, uppSP, uppInt mv, uppPStr SLIT(" :: "),
-	       upp_versions (fmToList versions), uppSemi]
 
-    upp_versions nvs
-      = uppIntersperse uppSP [ uppCat [uppPStr n, uppInt v] | (n,v) <- nvs ]
-\end{code}
+ifaceInstanceModules if_hdl [] = return ()
+ifaceInstanceModules if_hdl imods
+  = hPutStr if_hdl "_instance_modules_\n" >>
+    hPutStr if_hdl (uppShow 0 (uppCat (map uppPStr imods))) >>
+    hPutStr if_hdl "\n"
 
-\begin{code}
-ifaceVersions Nothing{-no iface handle-} _ = return ()
+ifaceExports if_hdl [] = return ()
+ifaceExports if_hdl avails
+  = hPutStr if_hdl "_exports_\n"			>>
+    hPutCol if_hdl upp_avail (sortLt lt_avail avails)
 
-ifaceVersions (Just if_hdl) version_info
-  | null version_list
-  = return ()
-  | otherwise
-  = hPutStr if_hdl "\n__versions__\n"	>>
-    hPutStr if_hdl (uppShow 0 (upp_versions version_list))
-    -- NB: when compiling Prelude.hs, this will spew out
-    -- stuff for [], (), (,), etc. [i.e., builtins], which
-    -- we'd rather it didn't.  The version-mangling in
-    -- the driver will ignore them.
+ifaceFixities if_hdl [] = return ()
+ifaceFixities if_hdl fixities 
+  = hPutStr if_hdl "_fixities_\n"		>>
+    hPutCol if_hdl upp_fixity fixities
+
+ifaceTCDecls if_hdl decls
+  =  hPutCol if_hdl ppr_decl tc_decls_for_iface
   where
-    version_list = fmToList version_info
+    tc_decls_for_iface = sortLt lt_decl (filter for_iface decls)
+    for_iface decl@(ClD _) = for_iface_name (hsDeclName decl)
+    for_iface decl@(TyD _) = for_iface_name (hsDeclName decl)
+    for_iface other_decl   = False
 
-    upp_versions nvs
-      = uppAboves [ uppPStr n | (n,v) <- nvs ]
-\end{code}
+    for_iface_name name = isLocallyDefined name && 
+			  not (isWiredInName name)
 
-\begin{code}
-ifaceInstanceModules Nothing{-no iface handle-} _ = return ()
-ifaceInstanceModules (Just _)		       [] = return ()
+    lt_decl d1 d2 = hsDeclName d1 < hsDeclName d2
+\end{code}			 
+
+%************************************************************************
+%*				 					*
+\subsection{Instance declarations}
+%*				 					*
+%************************************************************************
 
-ifaceInstanceModules (Just if_hdl) imods
-  = hPutStr if_hdl "\n__instance_modules__\n" >>
-    hPutStr if_hdl (uppShow 0 (uppCat (map uppPStr imods)))
+
+\begin{code}			 
+ifaceInstances Nothing{-no iface handle-} _ = return ()
+				 
+ifaceInstances (Just if_hdl) inst_infos
+  | null togo_insts = return ()		 
+  | otherwise 	    = hPutStr if_hdl "_instances_\n" >>
+		      hPutCol if_hdl pp_inst (sortLt lt_inst togo_insts)
+  where				 
+    togo_insts	= filter is_togo_inst (bagToList inst_infos)
+    is_togo_inst (InstInfo _ _ _ _ _ dfun_id _ _ _) = isLocallyDefined dfun_id
+				 
+    -------			 
+    lt_inst (InstInfo _ _ _ _ _ dfun_id1 _ _ _)
+	    (InstInfo _ _ _ _ _ dfun_id2 _ _ _)
+      = getOccName dfun_id1 < getOccName dfun_id2
+	-- The dfuns are assigned names df1, df2, etc, in order of original textual
+	-- occurrence, and this makes as good a sort order as any
+
+    -------			 
+    pp_inst (InstInfo clas tvs ty theta _ dfun_id _ _ _)
+      = let			 
+	    forall_ty     = mkSigmaTy tvs theta (mkDictTy clas ty)
+	    renumbered_ty = renumber_ty forall_ty
+	in			 
+	uppBesides [uppPStr SLIT("instance "), ppr_ty renumbered_ty, 
+		    uppPStr SLIT(" = "), ppr_unqual_name dfun_id, uppSemi]
 \end{code}
 
-Export list: grab the Names of things that are marked Exported, sort
-(so the interface file doesn't ``wobble'' from one compilation to the
-next...), and print.  We work from the renamer's final ``RnEnv'',
-which has all the names we might possibly be interested in.
-(Note that the ``module X'' export items can cause a lot of grief.)
+
+%************************************************************************
+%*				 					*
+\subsection{Printing values}
+%*				 					*
+%************************************************************************
+
 \begin{code}
-ifaceExportList Nothing{-no iface handle-} _ _ = return ()
-
-ifaceExportList (Just if_hdl)
-		(export_fn, (dotdot_vals, dotdot_tcs))
-		rn_env@((qual, unqual, tc_qual, tc_unqual), _)
-  = let
-	name_flag_pairs :: FiniteMap OrigName ExportFlag
-	name_flag_pairs
-	  = foldr (from_wired  True{-val-ish-})
-	   (foldr (from_wired  False{-tycon-ish-})
-	   (foldr (from_dotdot True{-val-ish-})
-	   (foldr (from_dotdot False{-tycon-ish-})
-	   (foldr from_val
-	   (foldr from_val
-	   (foldr from_tc
-	   (foldr from_tc emptyFM{-init accum-}
-		  (eltsFM tc_unqual))
-		  (eltsFM tc_qual))
-		  (eltsFM unqual))
-		  (eltsFM qual))
-		  dotdot_tcs)
-		  dotdot_vals)
-		  (eltsFM builtinTcNamesMap))
-		  (eltsFM builtinValNamesMap)
-
-	sorted_pairs = sortLt lexical_lt (fmToList name_flag_pairs)
-
-    in
-    --pprTrace "Exporting:" (pprRnEnv PprDebug rn_env) $
-    hPutStr if_hdl "\n__exports__\n" >>
-    hPutStr if_hdl (uppShow 0 (uppAboves (map upp_pair sorted_pairs)))
+ifaceId :: (Id -> IdInfo)		-- This function "knows" the extra info added
+					-- by the STG passes.  Sigh
+
+	    -> IdSet			-- Set of Ids that are needed by earlier interface
+					-- file emissions.  If the Id isn't in this set, and isn't
+					-- exported, there's no need to emit anything
+	    -> Id
+	    -> CoreExpr			-- The Id's right hand side
+	    -> Maybe (Pretty, IdSet)	-- The emitted stuff, plus a possibly-augmented set of needed Ids
+
+ifaceId get_idinfo needed_ids id rhs
+  | not (wantIdSigInIface (id `elementOfIdSet` needed_ids) 
+			  opt_OmitInterfacePragmas
+			  id)
+  = Nothing 		-- Well, that was easy!
+
+ifaceId get_idinfo needed_ids id rhs
+  = Just (ppCat [sig_pretty, prag_pretty, ppSemi], new_needed_ids)
   where
-    from_val rn acc
-      | fun_looking rn && exportFlagOn ef = addToFM acc on ef
-      | otherwise			  = acc
-      where
-	ef = export_fn n -- NB: using the export fn!
-	n  = getName rn
-	on = origName "from_val" n
-
-    -- fun_looking: must avoid class ops and data constructors
-    -- and record fieldnames
-    fun_looking (RnName    _) = True
-    fun_looking (WiredInId i) = not (isDataCon i)
-    fun_looking _		  = False
-
-    from_tc rn acc
-      | exportFlagOn ef = addToFM acc on ef
-      | otherwise	= acc
-      where
-	ef = export_fn n -- NB: using the export fn!
-	n  = getName rn
-	on = origName "from_tc" n
-
-    from_dotdot is_valish (n,ef) acc
-      | is_valish && isLexCon str = acc
-      | exportFlagOn ef		  = addToFM acc on ef
-      | otherwise		  = acc
-      where
-	on = origName "from_dotdot" n
-	(OrigName _ str) = on
-
-    from_wired is_val_ish rn acc
-      | is_val_ish && not (fun_looking rn)
-			= acc -- these things don't cause export-ery
-      | exportFlagOn ef = addToFM acc on ef
-      | otherwise       = acc
-      where
-	n  = getName rn
-	ef = export_fn n
-	on = origName "from_wired" n
-
-    --------------
-    lexical_lt (n1,_) (n2,_) = n1 < n2
-
-    --------------
-    upp_pair (OrigName m n, ef)
-      = uppBesides [uppPStr m, uppSP, uppPStr n, uppSP, upp_export ef]
-      where
-	upp_export ExportAll = uppPStr SLIT("(..)")
-	upp_export ExportAbs = uppNil
+    idinfo     = get_idinfo id
+    ty_pretty  = pprType PprInterface (initNmbr (nmbrType (idType id)))
+    sig_pretty = ppBesides [ppr PprInterface (getOccName id), ppPStr SLIT(" :: "), ty_pretty]
+
+    prag_pretty | opt_OmitInterfacePragmas = ppNil
+		| otherwise		   = ppCat [arity_pretty, strict_pretty, unfold_pretty]
+
+    ------------  Arity  --------------
+    arity_pretty  = ppArityInfo PprInterface (arityInfo idinfo)
+
+    ------------  Strictness  --------------
+    strict_info   = strictnessInfo idinfo
+    maybe_worker  = getWorkerId_maybe strict_info
+    strict_pretty = ppStrictnessInfo PprInterface strict_info
+
+    ------------  Unfolding  --------------
+    unfold_pretty | show_unfold = ppCat [ppStr "_U_", pprIfaceUnfolding rhs]
+		  | otherwise   = ppNil
+
+    show_unfold = not (maybeToBool maybe_worker) &&		-- Unfolding is implicit
+		  not (bottomIsGuaranteed strict_info) &&	-- Ditto
+		  case guidance of 				-- Small enough to show
+			UnfoldNever -> False
+			other       -> True 
+
+    guidance    = calcUnfoldingGuidance (idWantsToBeINLINEd id) 
+					opt_InterfaceUnfoldThreshold
+					rhs
+
+    
+    ------------  Extra free Ids  --------------
+    new_needed_ids = (needed_ids `minusIdSet` unitIdSet id)	`unionIdSets` 
+		     extra_ids
+
+    extra_ids | opt_OmitInterfacePragmas = emptyIdSet
+	      | otherwise		 = worker_ids	`unionIdSets`
+					   unfold_ids
+
+    worker_ids = case maybe_worker of
+			Just wkr -> unitIdSet wkr
+			Nothing  -> emptyIdSet
+
+    unfold_ids | show_unfold = free_vars
+	       | otherwise   = emptyIdSet
+			     where
+			       (_,free_vars) = addExprFVs interesting emptyIdSet rhs
+			       interesting bound id = not (id `elementOfIdSet` bound) &&
+						      not (isDataCon id) &&
+						      not (isWiredInName (getName id)) &&
+						      isLocallyDefined id 
 \end{code}
 
 \begin{code}
-ifaceFixities Nothing{-no iface handle-} _ = return ()
-
-ifaceFixities (Just if_hdl) (HsModule _ _ _ _ fixities _ _ _ _ _ _ _ _ _)
-  = let
-	pp_fixities = foldr go [] fixities
-    in
-    if null pp_fixities then
-	return ()
-    else 
-	hPutStr if_hdl "\n__fixities__\n" >>
-	hPutStr if_hdl (uppShow 0 (uppAboves pp_fixities))
+ifaceBinds :: Handle
+	   -> [Id]		-- Ids used at code-gen time; they have better pragma info!
+	   -> [CoreBinding]	-- In dependency order, later depend on earlier
+	   -> IO ()
+
+ifaceBinds hdl final_ids binds
+  = hPutStr hdl (uppShow 0 (prettyToUn (ppAboves pretties)))	>>
+    hPutStr hdl "\n"
   where
-    go (InfixL v i) acc = (if isLocallyDefined v then (:) (print_fix "l" i v) else id) acc
-    go (InfixR v i) acc = (if isLocallyDefined v then (:) (print_fix "r" i v) else id) acc
-    go (InfixN v i) acc = (if isLocallyDefined v then (:) (print_fix ""  i v) else id) acc
-
-    print_fix suff prec var
-      = uppBesides [uppPStr SLIT("infix"), uppStr suff, uppSP, uppInt prec, uppSP, ppr_name var, uppSemi]
+    final_id_map  = listToUFM [(id,id) | id <- final_ids]
+    get_idinfo id = case lookupUFM final_id_map id of
+			Just id' -> getIdInfo id'
+			Nothing  -> pprTrace "ifaceBinds not found:" (ppr PprDebug id) $
+				    getIdInfo id
+
+    pretties = go emptyIdSet (reverse binds)	-- Reverse so that later things will 
+						-- provoke earlier ones to be emitted
+    go needed [] = if not (isEmptyIdSet needed) then
+			pprTrace "ifaceBinds: free vars:" 
+				  (ppSep (map (ppr PprDebug) (idSetToList needed))) $
+			[]
+		   else
+			[]
+
+    go needed (NonRec id rhs : binds)
+	= case ifaceId get_idinfo needed id rhs of
+		Nothing		       -> go needed binds
+		Just (pretty, needed') -> pretty : go needed' binds
+
+	-- Recursive groups are a bit more of a pain.  We may only need one to
+	-- start with, but it may call out the next one, and so on.  So we
+	-- have to look for a fixed point.
+    go needed (Rec pairs : binds)
+	= pretties ++ go needed'' binds
+	where
+	  (needed', pretties) = go_rec needed pairs
+	  needed'' = needed' `minusIdSet` mkIdSet (map fst pairs)
+		-- Later ones may spuriously cause earlier ones to be "needed" again
+
+    go_rec :: IdSet -> [(Id,CoreExpr)] -> (IdSet, [Pretty])
+    go_rec needed pairs
+	| null pretties = (needed, [])
+	| otherwise	= (final_needed, more_pretties ++ pretties)
+	where
+	  reduced_pairs		 	= [pair | (pair,Nothing) <- pairs `zip` maybes]
+	  pretties		 	= catMaybes maybes
+	  (needed', maybes)	 	= mapAccumL do_one needed pairs
+	  (final_needed, more_pretties) = go_rec needed' reduced_pairs
+
+	  do_one needed (id,rhs) = case ifaceId get_idinfo needed id rhs of
+					Nothing		       -> (needed,  Nothing)
+					Just (pretty, needed') -> (needed', Just pretty)
 \end{code}
 
-\begin{code}
-non_wired x = not (isWiredInName (getName x)) --ToDo:move?
-
-ifaceDecls Nothing{-no iface handle-} _ = return ()
-
-ifaceDecls (Just if_hdl) (vals, tycons, classes, _)
-  = ASSERT(all isLocallyDefined vals)
-    ASSERT(all isLocallyDefined tycons)
-    ASSERT(all isLocallyDefined classes)
-    let
-	nonwired_classes = filter non_wired classes
-	nonwired_tycons  = filter non_wired tycons
-	nonwired_vals    = filter non_wired vals
-
-	lt_lexical a b = origName "lt_lexical" a < origName "lt_lexical" b
-
-	sorted_classes = sortLt lt_lexical nonwired_classes
-	sorted_tycons  = sortLt lt_lexical nonwired_tycons
-	sorted_vals    = sortLt lt_lexical nonwired_vals
-    in
-    if (null sorted_classes && null sorted_tycons && null sorted_vals) then
-	--  You could have a module with just (re-)exports/instances in it
-	return ()
-    else
-    hPutStr if_hdl "\n__declarations__\n" >>
-    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}
 
+%************************************************************************
+%*				 					*
+\subsection{Random small things}
+%*				 					*
+%************************************************************************
+				 
 \begin{code}
-ifaceInstances Nothing{-no iface handle-} _ = return ()
+upp_avail NotAvailable    = uppNil
+upp_avail (Avail name ns) = uppBesides [upp_module mod, uppSP, 
+					upp_occname occ, uppSP, 
+					upp_export ns]
+			     where
+				(mod,occ) = modAndOcc name
 
-ifaceInstances (Just if_hdl) (_, _, _, insts)
-  = let
-	togo_insts	= filter is_togo_inst (bagToList insts)
-
-	sorted_insts	= sortLt lt_inst togo_insts
-    in
-    if null togo_insts then
-	return ()
-    else
-	hPutStr if_hdl "\n__instances__\n" >>
-	hPutStr if_hdl (uppShow 0 (uppAboves (map pp_inst sorted_insts)))
-  where
-    is_togo_inst (InstInfo clas _ ty _ _ _ _ _ from_here _ _ _)
-      = from_here -- && ...
-
-    -------
-    lt_inst (InstInfo clas1 _ ty1 _ _ _ _ _ _ _ _ _)
-	    (InstInfo clas2 _ ty2 _ _ _ _ _ _ _ _ _)
-      = let
-	    tycon1 = fst (getAppTyCon ty1)
-	    tycon2 = fst (getAppTyCon ty2)
-	in
-	case (origName "lt_inst" clas1 `cmp` origName "lt_inst" clas2) of
-	  LT_ -> True
-	  GT_ -> False
-	  EQ_ -> origName "lt_inst2" tycon1 < origName "lt_inst2" tycon2
-
-    -------
-    pp_inst (InstInfo clas tvs ty theta _ _ _ _ _ _ _ _)
-      = let
-	    forall_ty     = mkSigmaTy tvs theta (mkDictTy clas ty)
-	    renumbered_ty = initNmbr (nmbrType forall_ty)
-	in
-	case (splitForAllTy renumbered_ty) of { (rtvs, rrho_ty) ->
-	uppBesides [uppPStr SLIT("instance "), ppr_forall rtvs, ppr_ty rrho_ty, uppSemi] }
+upp_export []    = uppNil
+upp_export names = uppBesides [uppStr "(", 
+			       uppIntersperse uppSP (map (upp_occname . getOccName) names), 
+			       uppStr ")"]
+
+upp_fixity (occ, Fixity prec dir, prov) = uppBesides [upp_dir dir, uppSP, 
+						      uppInt prec, uppSP, 
+					       	      upp_occname occ, uppSemi]
+upp_dir InfixR = uppStr "infixr"				 
+upp_dir InfixL = uppStr "infixl"				 
+upp_dir InfixN = uppStr "infix"				 
+
+ppr_unqual_name :: NamedThing a => a -> Unpretty		-- Just its occurrence name
+ppr_unqual_name name = upp_occname (getOccName name)
+
+ppr_name :: NamedThing a => a -> Unpretty		-- Its full name
+ppr_name   n = uppPStr (nameString (getName n))
+
+upp_occname :: OccName -> Unpretty
+upp_occname occ = uppPStr (occNameString occ)
+
+upp_module :: Module -> Unpretty
+upp_module mod = uppPStr mod
+
+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_tyvar_bndr tv = prettyToUn (pprTyVarBndr PprInterface tv)
+
+ppr_decl decl = prettyToUn (ppr PprInterface decl) `uppBeside` uppSemi
+
+renumber_ty ty = initNmbr (nmbrType ty)
 \end{code}
 
+
 %************************************************************************
-%*									*
-\subsection{Printing tycons, classes, ...}
-%*									*
+%*				 					*
+\subsection{Comparisons
+%*				 					*
 %************************************************************************
+				 
 
-\begin{code}
-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 ->
-
-	uppCat [uppPStr SLIT("class"), ppr_context 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_context :: TyVar -> [Class] -> Unpretty
+The various sorts above simply prevent unnecessary "wobbling" when
+things change that don't have to.  We therefore compare lexically, not
+by unique
 
-    ppr_context tv []   = uppNil
---  ppr_context tv [sc] = uppBeside (ppr_assert tv sc) (uppPStr SLIT(" =>"))
-    ppr_context tv super_classes
-      = uppBesides [uppStr "{{",
-		    uppIntersperse upp'SP{-'-} (map (ppr_assert tv) super_classes),
-		    uppStr "}} =>"]
+\begin{code}
+lt_avail :: AvailInfo -> AvailInfo -> Bool
 
-    ppr_assert tv (Class _ n _ _ _ _ _ _ _ _) = uppCat [ppr_name n, ppr_tyvar tv]
+NotAvailable `lt_avail` (Avail _ _)  = True
+(Avail n1 _) `lt_avail` (Avail n2 _) = n1 `lt_name` n2
+any	     `lt_avail` NotAvailable = False
 
-    clas_mod = moduleOf (origName "ppr_class" c)
+lt_name :: Name -> Name -> Bool
+n1 `lt_name` n2 = modAndOcc n1 < modAndOcc n2
 
-    ppr_op (ClassOp o _ ty) = pp_sig (Qual clas_mod o) ty
-\end{code}
+lt_lexical :: NamedThing a => a -> a -> Bool
+lt_lexical a1 a2 = getName a1 `lt_name` getName a2
 
-\begin{code}
-ppr_val v ty -- renumber the type first!
-  = --pprTrace "ppr_val:" (ppr PprDebug v) $
-    pp_sig v (initNmbr (nmbrType ty))
+lt_imp_vers :: ImportVersion a -> ImportVersion a -> Bool
+lt_imp_vers (m1,_,_) (m2,_,_) = m1 < m2
 
-pp_sig op ty
-  = case (splitForAllTy ty) of { (tvs, rho_ty) ->
-    uppBesides [ppr_name op, uppPStr SLIT(" :: "), ppr_forall tvs, ppr_ty rho_ty, uppSemi] }
+sort_versions vs = sortLt lt_vers vs
 
-ppr_forall []  = uppNil
-ppr_forall tvs = uppBesides [ uppStr "__forall__ [", uppInterleave uppComma (map ppr_tyvar tvs), uppStr "] " ]
+lt_vers :: LocalVersion Name -> LocalVersion Name -> Bool
+lt_vers (n1,v1) (n2,v2) = n1 `lt_name` n2
 \end{code}
 
+
 \begin{code}
-ppr_tycon tycon
-  = --pprTrace "ppr_tycon:" (ppr PprDebug tycon) $
-    ppr_tc (initNmbr (nmbrTyCon tycon))
-
-------------------------
-ppr_tc (PrimTyCon _ n _ _)
-  = uppCat [ uppStr "{- data", ppr_name n, uppStr " *built-in* -}" ]
-
-ppr_tc FunTyCon
-  = uppCat [ uppStr "{- data", ppr_name FunTyCon, uppStr " *built-in* -}" ]
-
-ppr_tc (TupleTyCon _ n _)
-  = uppCat [ uppStr "{- ", ppr_name n, uppStr "-}" ]
-
-ppr_tc (SynTyCon _ n _ _ tvs expand)
-  = let
-	pp_tyvars   = map ppr_tyvar tvs
-    in
-    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)
-  = uppCat [pp_data_or_new,
-	   ppr_context ctxt,
-	   ppr_name n,
-	   uppIntersperse uppSP (map ppr_tyvar tvs),
-	   uppEquals, pp_condecls,
-	   uppSemi]
-	   -- NB: we do not print deriving info in interfaces
-  where
-    pp_data_or_new = case data_or_new of
-		      DataType -> uppPStr SLIT("data")
-		      NewType  -> uppPStr SLIT("newtype")
-
-    ppr_context []      = uppNil
---  ppr_context [(c,t)] = uppCat [ppr_name c, ppr_ty t, uppPStr SLIT("=>")]
-    ppr_context cs
-      = uppBesides[uppStr "{{",
-		   uppInterleave uppComma [uppCat [ppr_name c, ppr_ty t] | (c,t) <- cs],
-		   uppStr "}}", uppPStr SLIT(" =>")]
-
-    pp_condecls
-      = let
-	    (c:cs) = cons
-	in
-	uppCat ((ppr_con c) : (map ppr_next_con cs))
-
-    ppr_next_con con = uppCat [uppChar '|', ppr_con con]
-
-    ppr_con con
-      = let
-	    con_arg_tys  = dataConRawArgTys   con
-	    labels       = dataConFieldLabels con -- none if not a record
-	    strict_marks = dataConStrictMarks con
-	in
-	uppCat [ppr_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
-	    uppIntersperse uppSP (zipWithEqual  "ppr_fields" ppr_bang_ty strict_marks con_arg_tys)
-	else
-	    uppCat [ uppChar '{',
-	    uppInterleave uppComma (zipWith3Equal "ppr_field" ppr_field labels strict_marks con_arg_tys),
-	    uppChar '}' ]
-
-    ppr_bang_ty b t
-      = uppBeside (case b of { MarkedStrict -> uppChar '!'; _ -> uppNil })
-		  (prettyToUn (pprParendType PprInterface t))
-
-    ppr_field l b t
-      = uppBesides [ppr_name l, uppPStr SLIT(" :: "),
-		   case b of { MarkedStrict -> uppChar '!'; _ -> uppNil },
-		   ppr_ty t]
+hPutCol :: Handle 
+	-> (a -> Unpretty)
+	-> [a]
+	-> IO ()
+hPutCol hdl fmt xs = hPutStr hdl (uppShow 0 (uppAboves (map fmt xs))) >>
+		     hPutStr hdl "\n"
 \end{code}
diff --git a/ghc/compiler/nativeGen/AbsCStixGen.lhs b/ghc/compiler/nativeGen/AbsCStixGen.lhs
index 223b0157d6..864b2f3a2f 100644
--- a/ghc/compiler/nativeGen/AbsCStixGen.lhs
+++ b/ghc/compiler/nativeGen/AbsCStixGen.lhs
@@ -19,7 +19,7 @@ import MachRegs
 import AbsCUtils	( getAmodeRep, mixedTypeLocn,
 			  nonemptyAbsC, mkAbsCStmts, mkAbsCStmtList
 			)
-import CgCompInfo   	( mIN_UPD_SIZE )
+import Constants   	( mIN_UPD_SIZE )
 import ClosureInfo	( infoTableLabelFromCI, entryLabelFromCI,
 			  fastLabelFromCI, closureUpdReqd
 			)
diff --git a/ghc/compiler/nativeGen/StixInteger.lhs b/ghc/compiler/nativeGen/StixInteger.lhs
index ef901f0808..45e11d8349 100644
--- a/ghc/compiler/nativeGen/StixInteger.lhs
+++ b/ghc/compiler/nativeGen/StixInteger.lhs
@@ -18,7 +18,7 @@ import MachMisc
 import MachRegs
 
 import AbsCSyn		-- bits and bobs...
-import CgCompInfo	( mIN_MP_INT_SIZE )
+import Constants	( mIN_MP_INT_SIZE )
 import Literal		( Literal(..) )
 import OrdList		( OrdList )
 import PrimOp		( PrimOp(..) )
diff --git a/ghc/compiler/nativeGen/StixMacro.lhs b/ghc/compiler/nativeGen/StixMacro.lhs
index 419283c922..664b2df9fb 100644
--- a/ghc/compiler/nativeGen/StixMacro.lhs
+++ b/ghc/compiler/nativeGen/StixMacro.lhs
@@ -14,7 +14,7 @@ import MachMisc
 import MachRegs
 
 import AbsCSyn		( CStmtMacro(..), MagicId(..), mkIntCLit, CAddrMode )
-import CgCompInfo	( uF_RET, uF_SUA, uF_SUB, uF_UPDATEE,
+import Constants	( uF_RET, uF_SUA, uF_SUB, uF_UPDATEE,
 			  sTD_UF_SIZE
 			)
 import OrdList		( OrdList )
diff --git a/ghc/compiler/nativeGen/StixPrim.lhs b/ghc/compiler/nativeGen/StixPrim.lhs
index 845078e17a..14bc255828 100644
--- a/ghc/compiler/nativeGen/StixPrim.lhs
+++ b/ghc/compiler/nativeGen/StixPrim.lhs
@@ -15,7 +15,7 @@ import MachRegs
 
 import AbsCSyn
 import AbsCUtils	( getAmodeRep, mixedTypeLocn )
-import CgCompInfo	( spARelToInt, spBRelToInt )
+import Constants	( spARelToInt, spBRelToInt )
 import CostCentre	( noCostCentreAttached )
 import HeapOffs		( hpRelToInt, subOff )
 import Literal		( Literal(..) )
diff --git a/ghc/compiler/parser/UgenUtil.lhs b/ghc/compiler/parser/UgenUtil.lhs
index e112d0ccf9..4b4523f211 100644
--- a/ghc/compiler/parser/UgenUtil.lhs
+++ b/ghc/compiler/parser/UgenUtil.lhs
@@ -26,8 +26,8 @@ import PreludeGlaST
 # define PACK_BYTES _packCBytes
 #endif
 
-import Name		( RdrName(..) )
-import SrcLoc		( mkSrcLoc2, mkUnknownSrcLoc, SrcLoc )
+import RdrHsSyn		( RdrName(..) )
+import SrcLoc		( mkSrcLoc, noSrcLoc, SrcLoc )
 \end{code}
 
 \begin{code}
@@ -47,7 +47,7 @@ thenUgn x y stuff
 initUgn :: UgnM a -> IO a
 initUgn action
   = let
-	do_it = action (SLIT(""),SLIT(""),mkUnknownSrcLoc)
+	do_it = action (SLIT(""),SLIT(""),noSrcLoc)
     in
 #if __GLASGOW_HASKELL__ >= 200
     primIOToIO do_it
@@ -105,7 +105,7 @@ mkSrcLocUgn :: U_long -> (SrcLoc -> UgnM a) -> UgnM a
 mkSrcLocUgn ln action (file,mod,_)
   = action loc (file,mod,loc)
   where
-    loc = mkSrcLoc2 file ln
+    loc = mkSrcLoc file ln
 
 getSrcLocUgn :: UgnM SrcLoc
 getSrcLocUgn stuff@(file,mod,loc) = returnUgn loc stuff
diff --git a/ghc/compiler/parser/hslexer.flex b/ghc/compiler/parser/hslexer.flex
index a0033b16a3..efac20b4a8 100644
--- a/ghc/compiler/parser/hslexer.flex
+++ b/ghc/compiler/parser/hslexer.flex
@@ -461,8 +461,8 @@ NL  	    	    	[\n\r]
 %{
 /* These SHOULDNAE work in "Code" (sigh) */
 %}
-<Code,GlaExt,UserPragma>{Id}"#" { 
-			 if (! nonstandardFlag) {
+<GlaExt,UserPragma>{Id}"#" { 
+			if (! nonstandardFlag) {
 			    char errbuf[ERR_BUF_SIZE];
 			    sprintf(errbuf, "Non-standard identifier (trailing `#'): %s\n", yytext);
 			    hsperror(errbuf);
diff --git a/ghc/compiler/prelude/PrelInfo.lhs b/ghc/compiler/prelude/PrelInfo.lhs
index 04bd913e5f..ed2bec583c 100644
--- a/ghc/compiler/prelude/PrelInfo.lhs
+++ b/ghc/compiler/prelude/PrelInfo.lhs
@@ -7,20 +7,33 @@
 #include "HsVersions.h"
 
 module PrelInfo (
-
 	-- finite maps for built-in things (for the renamer and typechecker):
-	builtinNameInfo, builtinNameMaps,
-	builtinValNamesMap, builtinTcNamesMap,
-	builtinKeysMap,
+	builtinNames, builtinKeys, derivingOccurrences,
 	SYN_IE(BuiltinNames),
-	SYN_IE(BuiltinKeys), SYN_IE(BuiltinIdInfos),
 
-	maybeCharLikeTyCon, maybeIntLikeTyCon
+	maybeCharLikeTyCon, maybeIntLikeTyCon,
+
+	eq_RDR, ne_RDR, le_RDR, lt_RDR, ge_RDR, gt_RDR, max_RDR, min_RDR, compare_RDR, 
+	minBound_RDR, maxBound_RDR, enumFrom_RDR, enumFromTo_RDR, enumFromThen_RDR, 
+	enumFromThenTo_RDR, fromEnum_RDR,
+	range_RDR, index_RDR, inRange_RDR, readsPrec_RDR, readList_RDR, 
+	showsPrec_RDR, showList_RDR, plus_RDR, times_RDR, ltTag_RDR, eqTag_RDR, gtTag_RDR, 
+	eqH_Char_RDR, ltH_Char_RDR, eqH_Word_RDR, ltH_Word_RDR, eqH_Addr_RDR, ltH_Addr_RDR, 
+	eqH_Float_RDR, ltH_Float_RDR, eqH_Double_RDR, ltH_Double_RDR, eqH_Int_RDR, ltH_Int_RDR, 
+	geH_RDR, leH_RDR, minusH_RDR, false_RDR, true_RDR, and_RDR, not_RDR, append_RDR, 
+	map_RDR, compose_RDR, mkInt_RDR, error_RDR, showString_RDR, showParen_RDR, readParen_RDR, 
+	lex_RDR, showSpace_RDR, showList___RDR, readList___RDR, negate_RDR,
+
+	numClass_RDR, fractionalClass_RDR, eqClass_RDR, ccallableClass_RDR, creturnableClass_RDR,
+	monadZeroClass_RDR, enumClass_RDR, evalClass_RDR, ordClass_RDR,
+
+	needsDataDeclCtxtClassKeys, cCallishClassKeys, isNoDictClass,
+	isNumericClass, isStandardClass, isCcallishClass
     ) where
 
 IMP_Ubiq()
-IMPORT_DELOOPER(PrelLoop) ( primOpNameInfo )
-IMPORT_DELOOPER(IdLoop)	  ( SpecEnv )
+IMPORT_DELOOPER(PrelLoop) ( primOpName )
+-- IMPORT_DELOOPER(IdLoop)	  ( SpecEnv )
 
 -- friends:
 import PrelMods		-- Prelude module names
@@ -31,16 +44,18 @@ import TysPrim		-- TYPES
 import TysWiredIn
 
 -- others:
-import FiniteMap	( FiniteMap, emptyFM, listToFM )
-import Id		( mkTupleCon, GenId, SYN_IE(Id) )
-import Maybes		( catMaybes )
-import Name		( origName, OrigName(..), Name )
-import RnHsSyn		( RnName(..) )
-import TyCon		( tyConDataCons, mkFunTyCon, mkTupleTyCon, TyCon )
+import SpecEnv		( SpecEnv )
+import RdrHsSyn		( RdrName(..), varQual, tcQual, qual )
+import Id		( GenId, SYN_IE(Id) )
+import Name		( Name, OccName(..), DefnInfo(..), Provenance(..),
+			  getName, mkGlobalName, modAndOcc )
+import Class		( Class(..), GenClass, classKey )
+import TyCon		( tyConDataCons, mkFunTyCon, TyCon )
 import Type
-import UniqFM		( UniqFM, emptyUFM, listToUFM )
+import Bag
 import Unique		-- *Key stuff
-import Util		( nOfThem, panic )
+import UniqFM		( UniqFM, listToUFM ) 
+import Util		( isIn )
 \end{code}
 
 %************************************************************************
@@ -53,61 +68,29 @@ We have two ``builtin name funs,'' one to look up @TyCons@ and
 @Classes@, the other to look up values.
 
 \begin{code}
-builtinNameInfo :: ( BuiltinNames, BuiltinKeys, BuiltinIdInfos )
-
-type BuiltinNames   = (FiniteMap OrigName RnName, -- WiredIn Ids
-		       FiniteMap OrigName RnName) -- WiredIn TyCons
-			-- Two maps because "[]" is in both...
-
-type BuiltinKeys    = FiniteMap OrigName (Unique, Name -> RnName)
-						     -- Names with known uniques
-
-type BuiltinIdInfos = UniqFM IdInfo		     -- Info for known unique Ids
-
-builtinNameMaps    = case builtinNameInfo of { (x,_,_) -> x }
-builtinKeysMap	   = case builtinNameInfo of { (_,x,_) -> x }
-builtinValNamesMap = fst builtinNameMaps
-builtinTcNamesMap  = snd builtinNameMaps
-
-builtinNameInfo
-  = ( (listToFM assoc_val_wired, listToFM assoc_tc_wired)
-    , listToFM assoc_keys
-    , listToUFM assoc_id_infos
-    )
-  where
-    assoc_val_wired
-    	= concat [
-	    -- data constrs
-	    concat (map pcDataConWiredInInfo g_con_tycons),
-	    concat (map pcDataConWiredInInfo data_tycons),
-
-	    -- values
-	    map pcIdWiredInInfo wired_in_ids,
-	    primop_ids
-	  ]
-    assoc_tc_wired
-    	= concat [
-	    -- tycons
-	    map pcTyConWiredInInfo prim_tycons,
-	    map pcTyConWiredInInfo g_tycons,
-	    map pcTyConWiredInInfo data_tycons
-	  ]
-
-    assoc_keys
-	= concat
-	  [
-	    id_keys,
-	    tysyn_keys,
-	    class_keys,
-	    class_op_keys
-	  ]
-
-    id_keys = map id_key id_keys_infos
-    id_key (str_mod, uniq, info) = (str_mod, (uniq, RnImplicit))
-
-    assoc_id_infos = catMaybes (map assoc_info id_keys_infos)
-    assoc_info (str_mod, uniq, Just info) = Just (uniq, info)
-    assoc_info (str_mod, uniq, Nothing)   = Nothing
+type BuiltinNames = Bag Name
+
+builtinNames :: BuiltinNames
+builtinNames
+  = 	-- Wired in TyCons
+    unionManyBags (map getTyConNames wired_in_tycons)	`unionBags`
+
+	-- Wired in Ids
+    listToBag (map getName wired_in_ids)		`unionBags`
+
+	-- PrimOps
+    listToBag (map (getName.primOpName) allThePrimOps)	`unionBags`
+
+	-- Other names with magic keys
+    listToBag builtinKeys
+\end{code}
+
+
+\begin{code}
+getTyConNames :: TyCon -> Bag Name
+getTyConNames tycon
+    =  getName tycon `consBag` listToBag (map getName (tyConDataCons tycon))
+	-- Synonyms return empty list of constructors
 \end{code}
 
 
@@ -115,8 +98,18 @@ We let a lot of "non-standard" values be visible, so that we can make
 sense of them in interface pragmas. It's cool, though they all have
 "non-standard" names, so they won't get past the parser in user code.
 
-The WiredIn TyCons and DataCons ...
+%************************************************************************
+%*									*
+\subsection{Wired in TyCons}
+%*									*
+%************************************************************************
+
+
 \begin{code}
+wired_in_tycons = [mkFunTyCon] ++
+		  prim_tycons ++
+		  tuple_tycons ++
+		  data_tycons
 
 prim_tycons
   = [ addrPrimTyCon
@@ -136,27 +129,12 @@ prim_tycons
     , wordPrimTyCon
     ]
 
-g_tycons
-  = mkFunTyCon : g_con_tycons
-
-g_con_tycons
-  = listTyCon : mkTupleTyCon 0 : [mkTupleTyCon i | i <- [2..37] ]
-
-min_nonprim_tycon_list 	-- used w/ HideMostBuiltinNames
-  = [ boolTyCon
-    , charTyCon
-    , intTyCon
-    , floatTyCon
-    , doubleTyCon
-    , integerTyCon
-    , liftTyCon
-    , return2GMPsTyCon	-- ADR asked for these last two (WDP 94/11)
-    , returnIntAndGMPTyCon
-    ]
+tuple_tycons = unitTyCon : [tupleTyCon i | i <- [2..37] ]
 
 
 data_tycons
-  = [ addrTyCon
+  = [ listTyCon
+    , addrTyCon
     , boolTyCon
     , charTyCon
     , doubleTyCon
@@ -188,20 +166,37 @@ data_tycons
     , voidTyCon
     , wordTyCon
     ]
+
+min_nonprim_tycon_list 	-- used w/ HideMostBuiltinNames
+  = [ boolTyCon
+    , charTyCon
+    , intTyCon
+    , floatTyCon
+    , doubleTyCon
+    , integerTyCon
+    , liftTyCon
+    , return2GMPsTyCon	-- ADR asked for these last two (WDP 94/11)
+    , returnIntAndGMPTyCon
+    ]
 \end{code}
 
+%************************************************************************
+%*									*
+\subsection{Wired in Ids}
+%*									*
+%************************************************************************
+
 The WiredIn Ids ...
 ToDo: Some of these should be moved to id_keys_infos!
+
 \begin{code}
 wired_in_ids
   = [ aBSENT_ERROR_ID
     , augmentId
     , buildId
---  , copyableId
     , eRROR_ID
     , foldlId
     , foldrId
---  , forkId
     , iRREFUT_PAT_ERROR_ID
     , integerMinusOneId
     , integerPlusOneId
@@ -210,145 +205,288 @@ wired_in_ids
     , nON_EXHAUSTIVE_GUARDS_ERROR_ID
     , nO_DEFAULT_METHOD_ERROR_ID
     , nO_EXPLICIT_METHOD_ERROR_ID
---  , noFollowId
     , pAR_ERROR_ID
     , pAT_ERROR_ID
     , packStringForCId
---    , parAtAbsId
---    , parAtForNowId
---    , parAtId
---    , parAtRelId
---    , parGlobalId
---    , parId
---    , parLocalId
     , rEC_CON_ERROR_ID
     , rEC_UPD_ERROR_ID
     , realWorldPrimId
     , runSTId
---    , seqId
     , tRACE_ID
     , unpackCString2Id
     , unpackCStringAppendId
     , unpackCStringFoldrId
     , unpackCStringId
     , voidId
+
+--  , copyableId
+--  , forkId
+--  , noFollowId
+--    , parAtAbsId
+--    , parAtForNowId
+--    , parAtId
+--    , parAtRelId
+--    , parGlobalId
+--    , parId
+--    , parLocalId
+--    , seqId
     ]
+\end{code}
 
-pcTyConWiredInInfo :: TyCon -> (OrigName, RnName)
-pcTyConWiredInInfo tc = (origName "pcTyConWiredInInfo" tc, WiredInTyCon tc)
 
-pcDataConWiredInInfo :: TyCon -> [(OrigName, RnName)]
-pcDataConWiredInInfo tycon
-  = [ (origName "pcDataConWiredInInfo" con, WiredInId con) | con <- tyConDataCons tycon ]
+%************************************************************************
+%*									*
+\subsection{Built-in keys}
+%*									*
+%************************************************************************
 
-pcIdWiredInInfo :: Id -> (OrigName, RnName)
-pcIdWiredInInfo id = (origName "pcIdWiredInInfo" id, WiredInId id)
-\end{code}
+Ids, Synonyms, Classes and ClassOps with builtin keys. 
 
-WiredIn primitive numeric operations ...
 \begin{code}
-primop_ids
-  = map prim_fn allThePrimOps ++ map funny_fn funny_name_primops
-  where
-    prim_fn  op     = case (primOpNameInfo op) of (s,n) -> ((OrigName gHC_BUILTINS s),n)
-    funny_fn (op,s) = case (primOpNameInfo op) of (_,n) -> ((OrigName gHC_BUILTINS s),n)
-
-funny_name_primops
-  = [ (IntAddOp,      SLIT("+#"))
-    , (IntSubOp,      SLIT("-#"))
-    , (IntMulOp,      SLIT("*#"))
-    , (IntGtOp,       SLIT(">#"))
-    , (IntGeOp,       SLIT(">=#"))
-    , (IntEqOp,       SLIT("==#"))
-    , (IntNeOp,       SLIT("/=#"))
-    , (IntLtOp,       SLIT("<#"))
-    , (IntLeOp,       SLIT("<=#"))
-    , (DoubleAddOp,   SLIT("+##"))
-    , (DoubleSubOp,   SLIT("-##"))
-    , (DoubleMulOp,   SLIT("*##"))
-    , (DoubleDivOp,   SLIT("/##"))
-    , (DoublePowerOp, SLIT("**##"))
-    , (DoubleGtOp,    SLIT(">##"))
-    , (DoubleGeOp,    SLIT(">=##"))
-    , (DoubleEqOp,    SLIT("==##"))
-    , (DoubleNeOp,    SLIT("/=##"))
-    , (DoubleLtOp,    SLIT("<##"))
-    , (DoubleLeOp,    SLIT("<=##"))
+getKeyOrig :: (Module, OccName, Unique) -> Name
+getKeyOrig (mod, occ, uniq) = mkGlobalName uniq mod occ VanillaDefn Implicit
+
+builtinKeys :: [Name]
+builtinKeys
+  = map getKeyOrig
+    [
+	-- Type constructors (synonyms especially)
+      (iO_BASE,		TCOcc SLIT("IO"),       iOTyConKey)
+    , (pREL_BASE,	TCOcc SLIT("Ordering"), orderingTyConKey)
+    , (pREL_NUM,	TCOcc SLIT("Rational"), rationalTyConKey)
+    , (pREL_NUM,	TCOcc SLIT("Ratio"),    ratioTyConKey)
+
+
+	--  Classes.  *Must* include:
+	--  	classes that are grabbed by key (e.g., eqClassKey)
+	--  	classes in "Class.standardClassKeys" (quite a few)
+    , (pREL_BASE, TCOcc SLIT("Eq"),		eqClassKey)		-- mentioned, derivable
+    , (pREL_BASE, TCOcc SLIT("Eval"),		evalClassKey)		-- mentioned
+    , (pREL_BASE, TCOcc SLIT("Ord"),		ordClassKey)		-- derivable
+    , (pREL_BASE, TCOcc SLIT("Bounded"),	boundedClassKey)	-- derivable
+    , (pREL_BASE, TCOcc SLIT("Num"),		numClassKey)		-- mentioned, numeric
+    , (pREL_BASE, TCOcc SLIT("Enum"),		enumClassKey)		-- derivable
+    , (pREL_BASE, TCOcc SLIT("Monad"),		monadClassKey)
+    , (pREL_BASE, TCOcc SLIT("MonadZero"),		monadZeroClassKey)
+    , (pREL_BASE, TCOcc SLIT("MonadPlus"),		monadPlusClassKey)
+    , (pREL_BASE, TCOcc SLIT("Functor"),		functorClassKey)
+    , (pREL_BASE, TCOcc SLIT("Show"),		showClassKey)		-- derivable
+    , (pREL_NUM, TCOcc SLIT("Real"),		realClassKey)		-- numeric
+    , (pREL_NUM, TCOcc SLIT("Integral"),	integralClassKey)	-- numeric
+    , (pREL_NUM, TCOcc SLIT("Fractional"),	fractionalClassKey)	-- numeric
+    , (pREL_NUM, TCOcc SLIT("Floating"),	floatingClassKey)	-- numeric
+    , (pREL_NUM, TCOcc SLIT("RealFrac"),	realFracClassKey)	-- numeric
+    , (pREL_NUM, TCOcc SLIT("RealFloat"),	realFloatClassKey)	-- numeric
+    , (pREL_READ, TCOcc SLIT("Read"),		readClassKey)		-- derivable
+    , (iX,	TCOcc SLIT("Ix"),		ixClassKey)		-- derivable (but it isn't Prelude.Ix; hmmm)
+    , (fOREIGN,	TCOcc SLIT("CCallable"),	cCallableClassKey)	-- mentioned, ccallish
+    , (fOREIGN,   TCOcc SLIT("CReturnable"), 	cReturnableClassKey)	-- mentioned, ccallish
+
+
+	-- ClassOps 
+    , (pREL_BASE, VarOcc SLIT("fromInt"),	fromIntClassOpKey)
+    , (pREL_BASE, VarOcc SLIT("fromInteger"),	fromIntegerClassOpKey)
+    , (pREL_BASE, VarOcc SLIT("enumFrom"),	enumFromClassOpKey)
+    , (pREL_BASE, VarOcc SLIT("enumFromThen"),	enumFromThenClassOpKey)
+    , (pREL_BASE, VarOcc SLIT("enumFromTo"),	enumFromToClassOpKey)
+    , (pREL_BASE, VarOcc SLIT("enumFromThenTo"), enumFromThenToClassOpKey)
+    , (pREL_BASE, VarOcc SLIT("fromEnum"),	fromEnumClassOpKey)
+    , (pREL_BASE, VarOcc SLIT("=="),		eqClassOpKey)
+    , (pREL_BASE, VarOcc SLIT(">>="),		thenMClassOpKey)
+    , (pREL_BASE, VarOcc SLIT("zero"),		zeroClassOpKey)
+    , (pREL_NUM, VarOcc SLIT("fromRational"),	fromRationalClassOpKey)
     ]
 \end{code}
 
+ToDo: make it do the ``like'' part properly (as in 0.26 and before).
 
-Ids, Synonyms, Classes and ClassOps with builtin keys.
-For the Ids we may also have some builtin IdInfo.
 \begin{code}
-id_keys_infos :: [(OrigName, Unique, Maybe IdInfo)]
-id_keys_infos
-  = [ -- here because we use them in derived instances
-      (OrigName pRELUDE SLIT("&&"),		andandIdKey,	Nothing)
-    , (OrigName pRELUDE SLIT("."),		composeIdKey,	Nothing)
-    , (OrigName gHC__   SLIT("lex"),		lexIdKey,	Nothing)
-    , (OrigName pRELUDE SLIT("not"),		notIdKey,	Nothing)
-    , (OrigName pRELUDE SLIT("readParen"),	readParenIdKey,	Nothing)
-    , (OrigName pRELUDE SLIT("showParen"),	showParenIdKey,	Nothing)
-    , (OrigName pRELUDE SLIT("showString"),	showStringIdKey,Nothing)
-    , (OrigName gHC__   SLIT("readList__"),	ureadListIdKey,	Nothing)
-    , (OrigName gHC__   SLIT("showList__"),	ushowListIdKey,	Nothing)
-    , (OrigName gHC__   SLIT("showSpace"),	showSpaceIdKey,	Nothing)
-    ]
+maybeCharLikeTyCon tc = if (uniqueOf tc == charDataConKey) then Just charDataCon else Nothing
+maybeIntLikeTyCon  tc = if (uniqueOf tc == intDataConKey)  then Just intDataCon  else Nothing
+\end{code}
 
-tysyn_keys
-  = [ (OrigName gHC__   SLIT("IO"),       (iOTyConKey, RnImplicitTyCon))
-    , (OrigName pRELUDE SLIT("Ordering"), (orderingTyConKey, RnImplicitTyCon))
-    , (OrigName rATIO   SLIT("Rational"), (rationalTyConKey, RnImplicitTyCon))
-    , (OrigName rATIO   SLIT("Ratio"),    (ratioTyConKey, RnImplicitTyCon))
-    ]
+%************************************************************************
+%*									*
+\subsection{Commonly-used RdrNames}
+%*									*
+%************************************************************************
 
--- this "class_keys" list *must* include:
---  classes that are grabbed by key (e.g., eqClassKey)
---  classes in "Class.standardClassKeys" (quite a few)
-
-class_keys
-  = [ (str_mod, (k, RnImplicitClass)) | (str_mod,k) <-
-    [ (OrigName pRELUDE SLIT("Eq"),		eqClassKey)		-- mentioned, derivable
-    , (OrigName pRELUDE SLIT("Eval"),		evalClassKey)		-- mentioned
-    , (OrigName pRELUDE SLIT("Ord"),		ordClassKey)		-- derivable
-    , (OrigName pRELUDE SLIT("Num"),		numClassKey)		-- mentioned, numeric
-    , (OrigName pRELUDE SLIT("Real"),		realClassKey)		-- numeric
-    , (OrigName pRELUDE SLIT("Integral"),	integralClassKey)	-- numeric
-    , (OrigName pRELUDE SLIT("Fractional"),	fractionalClassKey)	-- numeric
-    , (OrigName pRELUDE SLIT("Floating"),	floatingClassKey)	-- numeric
-    , (OrigName pRELUDE SLIT("RealFrac"),	realFracClassKey)	-- numeric
-    , (OrigName pRELUDE SLIT("RealFloat"),	realFloatClassKey)	-- numeric
-    , (OrigName iX	SLIT("Ix"),		ixClassKey)		-- derivable (but it isn't Prelude.Ix; hmmm)
-    , (OrigName pRELUDE SLIT("Bounded"),	boundedClassKey)	-- derivable
-    , (OrigName pRELUDE SLIT("Enum"),		enumClassKey)		-- derivable
-    , (OrigName pRELUDE SLIT("Show"),		showClassKey)		-- derivable
-    , (OrigName pRELUDE SLIT("Read"),		readClassKey)		-- derivable
-    , (OrigName pRELUDE SLIT("Monad"),		monadClassKey)
-    , (OrigName pRELUDE SLIT("MonadZero"),	monadZeroClassKey)
-    , (OrigName pRELUDE SLIT("MonadPlus"),	monadPlusClassKey)
-    , (OrigName pRELUDE SLIT("Functor"),	functorClassKey)
-    , (OrigName gHC__	SLIT("CCallable"),	cCallableClassKey)	-- mentioned, ccallish
-    , (OrigName gHC__   SLIT("CReturnable"), 	cReturnableClassKey)	-- mentioned, ccallish
-    ]]
-
-class_op_keys
-  = [ (str_mod, (k, RnImplicit)) | (str_mod,k) <-
-    [ (OrigName pRELUDE SLIT("fromInt"),	fromIntClassOpKey)
-    , (OrigName pRELUDE SLIT("fromInteger"),	fromIntegerClassOpKey)
-    , (OrigName pRELUDE SLIT("fromRational"),	fromRationalClassOpKey)
-    , (OrigName pRELUDE SLIT("enumFrom"),	enumFromClassOpKey)
-    , (OrigName pRELUDE SLIT("enumFromThen"),	enumFromThenClassOpKey)
-    , (OrigName pRELUDE SLIT("enumFromTo"),	enumFromToClassOpKey)
-    , (OrigName pRELUDE SLIT("enumFromThenTo"),enumFromThenToClassOpKey)
-    , (OrigName pRELUDE SLIT("=="),		eqClassOpKey)
-    , (OrigName pRELUDE SLIT(">>="),		thenMClassOpKey)
-    , (OrigName pRELUDE SLIT("zero"),		zeroClassOpKey)
-    ]]
+These RdrNames are not really "built in", but some parts of the compiler
+(notably the deriving mechanism) need to mention their names, and it's convenient
+to write them all down in one place.
+
+\begin{code}
+prelude_primop op = qual (modAndOcc (primOpName op))
+
+eqClass_RDR		= tcQual (pREL_BASE, SLIT("Eq"))
+ordClass_RDR		= tcQual (pREL_BASE, SLIT("Ord"))
+evalClass_RDR 		= tcQual (pREL_BASE, SLIT("Eval"))
+monadZeroClass_RDR	= tcQual (pREL_BASE, SLIT("MonadZero"))
+enumClass_RDR 		= tcQual (pREL_BASE, SLIT("Enum"))
+numClass_RDR		= tcQual (pREL_BASE, SLIT("Num"))
+fractionalClass_RDR	= tcQual (pREL_NUM,  SLIT("Fractional"))
+ccallableClass_RDR	= tcQual (fOREIGN,   SLIT("CCallable"))
+creturnableClass_RDR	= tcQual (fOREIGN,   SLIT("CReturnable"))
+
+negate_RDR	   = varQual (pREL_BASE, SLIT("negate"))
+eq_RDR		   = varQual (pREL_BASE, SLIT("=="))
+ne_RDR		   = varQual (pREL_BASE, SLIT("/="))
+le_RDR		   = varQual (pREL_BASE, SLIT("<="))
+lt_RDR		   = varQual (pREL_BASE, SLIT("<"))
+ge_RDR		   = varQual (pREL_BASE, SLIT(">="))
+gt_RDR		   = varQual (pREL_BASE, SLIT(">"))
+ltTag_RDR	   = varQual (pREL_BASE,  SLIT("LT"))
+eqTag_RDR	   = varQual (pREL_BASE,  SLIT("EQ"))
+gtTag_RDR	   = varQual (pREL_BASE,  SLIT("GT"))
+max_RDR		   = varQual (pREL_BASE, SLIT("max"))
+min_RDR		   = varQual (pREL_BASE, SLIT("min"))
+compare_RDR	   = varQual (pREL_BASE, SLIT("compare"))
+minBound_RDR	   = varQual (pREL_BASE, SLIT("minBound"))
+maxBound_RDR	   = varQual (pREL_BASE, SLIT("maxBound"))
+false_RDR	   = varQual (pREL_BASE,  SLIT("False"))
+true_RDR	   = varQual (pREL_BASE,  SLIT("True"))
+and_RDR		   = varQual (pREL_BASE,  SLIT("&&"))
+not_RDR		   = varQual (pREL_BASE,  SLIT("not"))
+compose_RDR	   = varQual (pREL_BASE, SLIT("."))
+append_RDR	   = varQual (pREL_BASE, SLIT("++"))
+map_RDR		   = varQual (pREL_BASE, SLIT("map"))
+
+showList___RDR     = varQual (pREL_BASE,  SLIT("showList__"))
+showsPrec_RDR	   = varQual (pREL_BASE, SLIT("showsPrec"))
+showList_RDR	   = varQual (pREL_BASE, SLIT("showList"))
+showSpace_RDR	   = varQual (pREL_BASE,  SLIT("showSpace"))
+showString_RDR	   = varQual (pREL_BASE, SLIT("showString"))
+showParen_RDR	   = varQual (pREL_BASE, SLIT("showParen"))
+
+range_RDR	   = varQual (iX,   SLIT("range"))
+index_RDR	   = varQual (iX,   SLIT("index"))
+inRange_RDR	   = varQual (iX,   SLIT("inRange"))
+
+readsPrec_RDR	   = varQual (pREL_READ, SLIT("readsPrec"))
+readList_RDR	   = varQual (pREL_READ, SLIT("readList"))
+readParen_RDR	   = varQual (pREL_READ, SLIT("readParen"))
+lex_RDR		   = varQual (pREL_READ,  SLIT("lex"))
+readList___RDR     = varQual (pREL_READ,  SLIT("readList__"))
+
+fromEnum_RDR	   = varQual (pREL_BASE, SLIT("fromEnum"))
+enumFrom_RDR	   = varQual (pREL_BASE, SLIT("enumFrom"))
+enumFromTo_RDR	   = varQual (pREL_BASE, SLIT("enumFromTo"))
+enumFromThen_RDR   = varQual (pREL_BASE, SLIT("enumFromThen"))
+enumFromThenTo_RDR = varQual (pREL_BASE, SLIT("enumFromThenTo"))
+plus_RDR	   = varQual (pREL_BASE, SLIT("+"))
+times_RDR	   = varQual (pREL_BASE, SLIT("*"))
+mkInt_RDR	   = varQual (pREL_BASE, SLIT("I#"))
+
+error_RDR	   = varQual (iO_BASE, SLIT("error"))
+
+eqH_Char_RDR	= prelude_primop CharEqOp
+ltH_Char_RDR	= prelude_primop CharLtOp
+eqH_Word_RDR	= prelude_primop WordEqOp
+ltH_Word_RDR	= prelude_primop WordLtOp
+eqH_Addr_RDR	= prelude_primop AddrEqOp
+ltH_Addr_RDR	= prelude_primop AddrLtOp
+eqH_Float_RDR	= prelude_primop FloatEqOp
+ltH_Float_RDR	= prelude_primop FloatLtOp
+eqH_Double_RDR	= prelude_primop DoubleEqOp
+ltH_Double_RDR	= prelude_primop DoubleLtOp
+eqH_Int_RDR	= prelude_primop IntEqOp
+ltH_Int_RDR	= prelude_primop IntLtOp
+geH_RDR		= prelude_primop IntGeOp
+leH_RDR		= prelude_primop IntLeOp
+minusH_RDR	= prelude_primop IntSubOp
+
+intType_RDR = qual (modAndOcc intTyCon)
 \end{code}
 
-ToDo: make it do the ``like'' part properly (as in 0.26 and before).
+%************************************************************************
+%*									*
+\subsection[Class-std-groups]{Standard groups of Prelude classes}
+%*									*
+%************************************************************************
+
+@derivableClassKeys@ is also used in checking \tr{deriving} constructs
+(@TcDeriv@).
+
+@derivingOccurrences@ maps a class name to a list of the (qualified) occurrences
+that will be mentioned by  the derived code for the class when it is later generated.
+We don't need to put in things that are WiredIn (because they are already mapped to their
+correct name by the @NameSupply@.  The class itself, and all its class ops, is
+already flagged as an occurrence so we don't need to mention that either.
+
+@derivingOccurrences@ has an item for every derivable class, even if that item is empty,
+because we treat lookup failure as indicating that the class is illegal in a deriving clause.
+
 \begin{code}
-maybeCharLikeTyCon tc = if (uniqueOf tc == charDataConKey) then Just charDataCon else Nothing
-maybeIntLikeTyCon  tc = if (uniqueOf tc == intDataConKey)  then Just intDataCon  else Nothing
+derivingOccurrences :: UniqFM [RdrName]
+derivingOccurrences = listToUFM deriving_occ_info
+
+derivableClassKeys  = map fst deriving_occ_info
+
+deriving_occ_info
+  = [ (eqClassKey, 	[intType_RDR, and_RDR, not_RDR])
+    , (ordClassKey, 	[intType_RDR, compose_RDR])
+    , (enumClassKey, 	[intType_RDR, map_RDR])
+    , (evalClassKey,	[intType_RDR])
+    , (boundedClassKey,	[intType_RDR])
+    , (showClassKey,	[intType_RDR, numClass_RDR, ordClass_RDR, compose_RDR, showString_RDR, 
+			 showParen_RDR, showSpace_RDR, showList___RDR])
+    , (readClassKey,	[intType_RDR, numClass_RDR, ordClass_RDR, append_RDR, 
+			 lex_RDR, readParen_RDR, readList___RDR])
+    , (ixClassKey,	[intType_RDR, numClass_RDR, and_RDR, map_RDR])
+    ]
+	-- intType: Practically any deriving needs Int, either for index calculations, 
+	--		or for taggery.
+	-- ordClass: really it's the methods that are actually used.
+	-- numClass: for Int literals
+\end{code}
+
+
+NOTE: @Eq@ and @Text@ do need to appear in @standardClasses@
+even though every numeric class has these two as a superclass,
+because the list of ambiguous dictionaries hasn't been simplified.
+
+\begin{code}
+isCcallishClass, isNoDictClass, isNumericClass, isStandardClass :: Class -> Bool
+
+isNumericClass   clas = classKey clas `is_elem` numericClassKeys
+isStandardClass  clas = classKey clas `is_elem` standardClassKeys
+isCcallishClass	 clas = classKey clas `is_elem` cCallishClassKeys
+isNoDictClass    clas = classKey clas `is_elem` noDictClassKeys
+is_elem = isIn "is_X_Class"
+
+numericClassKeys
+  = [ numClassKey
+    , realClassKey
+    , integralClassKey
+    , fractionalClassKey
+    , floatingClassKey
+    , realFracClassKey
+    , realFloatClassKey
+    ]
+
+needsDataDeclCtxtClassKeys -- see comments in TcDeriv
+  = [ readClassKey
+    ]
+
+cCallishClassKeys = [ cCallableClassKey, cReturnableClassKey ]
+
+standardClassKeys
+  = derivableClassKeys ++ numericClassKeys ++ cCallishClassKeys
+    --
+    -- We have to have "CCallable" and "CReturnable" in the standard
+    -- classes, so that if you go...
+    --
+    --	    _ccall_ foo ... 93{-numeric literal-} ...
+    --
+    -- ... it can do The Right Thing on the 93.
+
+noDictClassKeys 	-- These classes are used only for type annotations;
+			-- they are not implemented by dictionaries, ever.
+  = cCallishClassKeys
+	-- I used to think that class Eval belonged in here, but
+	-- we really want functions with type (Eval a => ...) and that
+	-- means that we really want to pass a placeholder for an Eval
+	-- dictionary.  The unit tuple is what we'll get if we leave things
+	-- alone, and that'll do for now.  Could arrange to drop that parameter
+	-- in the end.
 \end{code}
diff --git a/ghc/compiler/prelude/PrelLoop.lhi b/ghc/compiler/prelude/PrelLoop.lhi
index acf9a4eae5..ba1320a13e 100644
--- a/ghc/compiler/prelude/PrelLoop.lhi
+++ b/ghc/compiler/prelude/PrelLoop.lhi
@@ -7,8 +7,8 @@ import PreludePS	( _PackedString )
 
 import Class		( GenClass )
 import CoreUnfold	( mkMagicUnfolding, Unfolding )
-import IdUtils		( primOpNameInfo )
-import Name		( Name, OrigName, mkPrimitiveName, mkWiredInName, ExportFlag )
+import IdUtils		( primOpName )
+import Name		( Name, ExportFlag )
 import PrimOp		( PrimOp )
 import RnHsSyn		( RnName )
 import Type		( mkSigmaTy, mkFunTy, mkFunTys, GenType )
@@ -17,11 +17,9 @@ import Unique		( Unique )
 import Usage		( GenUsage )
 
 mkMagicUnfolding :: Unique -> Unfolding
-mkPrimitiveName :: Unique -> OrigName -> Name
-mkWiredInName :: Unique -> OrigName -> ExportFlag -> Name
 mkSigmaTy :: [a] -> [(GenClass (GenTyVar (GenUsage Unique)) Unique, GenType a b)] -> GenType a b -> GenType a b
 mkFunTys :: [GenType a b] -> GenType a b -> GenType a b
 mkFunTy  :: GenType a b   -> GenType a b -> GenType a b
 
-primOpNameInfo	:: PrimOp -> (_PackedString, RnName)
+primOpName :: PrimOp -> Name
 \end{code}
diff --git a/ghc/compiler/prelude/PrelMods.lhs b/ghc/compiler/prelude/PrelMods.lhs
index 1d73db7908..8d9a5ad6e6 100644
--- a/ghc/compiler/prelude/PrelMods.lhs
+++ b/ghc/compiler/prelude/PrelMods.lhs
@@ -8,24 +8,32 @@ defined here so as to avod
 \begin{code}
 #include "HsVersions.h"
 
-module PrelMods (
-	gHC_BUILTINS, -- things that are really and truly primitive
-	pRELUDE, gHC__,
-	rATIO, iX,
-	modulesWithBuiltins
-  ) where
+module PrelMods where
 
 CHK_Ubiq() -- debugging consistency check
 \end{code}
 
 
 \begin{code}
+gHC__	     = SLIT("GHC")	   -- Primitive types and values
+
 pRELUDE	     = SLIT("Prelude")
-gHC_BUILTINS = SLIT("GHCbuiltins") -- the truly-primitive things
-gHC__	     = SLIT("GHCbase")	   -- all GHC basics, add-ons, extras, everything
-				   -- (which can be defined in Haskell)
+pREL_BASE    = SLIT("PrelBase")
+pREL_READ    = SLIT("PrelRead")
+pREL_NUM     = SLIT("PrelNum")
+pREL_LIST    = SLIT("PrelList")
+pREL_TUP     = SLIT("PrelTup")
+pACKED_STRING= SLIT("PackedString")
+cONC_BASE    = SLIT("ConcBase")
+iO_BASE	     = SLIT("IOBase")
+mONAD	     = SLIT("Monad")
 rATIO	     = SLIT("Ratio")
 iX	     = SLIT("Ix")
+sT_BASE	     = SLIT("STBase")
+aRR_BASE     = SLIT("ArrBase")
+fOREIGN	     = SLIT("Foreign")
 
-modulesWithBuiltins = [ gHC_BUILTINS, gHC__, pRELUDE, rATIO, iX ]
+mAIN	     = SLIT("Main")
+gHC_MAIN     = SLIT("GHCmain")
+gHC_ERR	     = SLIT("GHCerr")
 \end{code}
diff --git a/ghc/compiler/prelude/PrelVals.lhs b/ghc/compiler/prelude/PrelVals.lhs
index 84fd4d915a..c743362c54 100644
--- a/ghc/compiler/prelude/PrelVals.lhs
+++ b/ghc/compiler/prelude/PrelVals.lhs
@@ -10,7 +10,7 @@ module PrelVals where
 
 IMP_Ubiq()
 IMPORT_DELOOPER(IdLoop)		( UnfoldingGuidance(..), nullSpecEnv, SpecEnv )
-import Id		( SYN_IE(Id), GenId, mkImported, mkUserId, mkTemplateLocals )
+import Id		( SYN_IE(Id), GenId, mkImported, mkTemplateLocals )
 IMPORT_DELOOPER(PrelLoop)
 
 -- friends:
@@ -23,7 +23,7 @@ import CmdLineOpts	( maybe_CompilingGhcInternals )
 import CoreSyn		-- quite a bit
 import IdInfo		-- quite a bit
 import Literal		( mkMachInt )
-import Name		( ExportFlag(..) )
+import Name		( mkWiredInIdName )
 import PragmaInfo
 import PrimOp		( PrimOp(..) )
 import Type		( mkTyVarTy )
@@ -34,11 +34,11 @@ import Util		( panic )
 
 \begin{code}
 -- only used herein:
-pcMiscPrelId :: Unique{-IdKey-} -> FAST_STRING -> FAST_STRING -> Type -> IdInfo -> Id
+pcMiscPrelId :: Unique{-IdKey-} -> Module -> FAST_STRING -> Type -> IdInfo -> Id
 
-pcMiscPrelId key m n ty info
+pcMiscPrelId key mod occ ty info
   = let
-	name = mkWiredInName key (OrigName m n) ExportAll
+	name = mkWiredInIdName key mod occ imp
 	imp  = mkImported name ty info -- the usual case...
     in
     imp
@@ -73,14 +73,14 @@ templates, but we don't ever expect to generate code for it.
 pc_bottoming_Id key mod name ty
  = pcMiscPrelId key mod name ty bottoming_info
  where
-    bottoming_info = noIdInfo `addInfo` mkBottomStrictnessInfo
+    bottoming_info = noIdInfo `addStrictnessInfo` mkBottomStrictnessInfo
 	-- these "bottom" out, no matter what their arguments
 
 eRROR_ID
-  = pc_bottoming_Id errorIdKey pRELUDE SLIT("error") errorTy
+  = pc_bottoming_Id errorIdKey iO_BASE SLIT("error") errorTy
 
 generic_ERROR_ID u n
-  = pc_bottoming_Id u SLIT("GHCerr") n errorTy
+  = pc_bottoming_Id u gHC_ERR n errorTy
 
 pAT_ERROR_ID
   = generic_ERROR_ID patErrorIdKey SLIT("patError")
@@ -98,11 +98,11 @@ nO_EXPLICIT_METHOD_ERROR_ID
   = generic_ERROR_ID nonExplicitMethodErrorIdKey SLIT("noExplicitMethodError")
 
 aBSENT_ERROR_ID
-  = pc_bottoming_Id absentErrorIdKey SLIT("GHCerr") SLIT("absentErr")
+  = pc_bottoming_Id absentErrorIdKey gHC_ERR SLIT("absentErr")
 	(mkSigmaTy [openAlphaTyVar] [] openAlphaTy)
 
 pAR_ERROR_ID
-  = pcMiscPrelId parErrorIdKey SLIT("GHCerr") SLIT("parError")
+  = pcMiscPrelId parErrorIdKey gHC_ERR SLIT("parError")
     (mkSigmaTy [openAlphaTyVar] [] openAlphaTy) noIdInfo
 
 openAlphaTy = mkTyVarTy openAlphaTyVar
@@ -120,8 +120,8 @@ decide that the second argument is strict, evaluate that first (!!),
 and make a jolly old mess.
 \begin{code}
 tRACE_ID
-  = pcMiscPrelId traceIdKey gHC__ SLIT("trace") traceTy
-	(noIdInfo `addInfo` pcGenerateSpecs traceIdKey tRACE_ID noIdInfo traceTy)
+  = pcMiscPrelId traceIdKey iO_BASE SLIT("trace") traceTy
+	(noIdInfo `addSpecInfo` pcGenerateSpecs traceIdKey tRACE_ID noIdInfo traceTy)
   where
     traceTy = mkSigmaTy [alphaTyVar] [] (mkFunTys [mkListTy charTy, alphaTy] alphaTy)
 \end{code}
@@ -134,54 +134,55 @@ tRACE_ID
 
 \begin{code}
 packStringForCId
-  = pcMiscPrelId packCStringIdKey{-ToDo:rename-} gHC__ SLIT("packStringForC__")
+  = pcMiscPrelId packCStringIdKey{-ToDo:rename-} pACKED_STRING SLIT("packCString#")
 	(mkFunTys [stringTy] byteArrayPrimTy) noIdInfo
 
 --------------------------------------------------------------------
 
 unpackCStringId
-  = pcMiscPrelId unpackCStringIdKey gHC__ SLIT("unpackPS__")
+  = pcMiscPrelId unpackCStringIdKey pACKED_STRING SLIT("unpackCString#")
 		 (mkFunTys [addrPrimTy{-a char *-}] stringTy) noIdInfo
 -- Andy says:
---	(FunTy addrPrimTy{-a char *-} stringTy) (noIdInfo `addInfo` mkArityInfo 1)
+--	(FunTy addrPrimTy{-a char *-} stringTy) (noIdInfo `addInfo` exactArity 1)
 -- but I don't like wired-in IdInfos (WDP)
 
 unpackCString2Id -- for cases when a string has a NUL in it
-  = pcMiscPrelId unpackCString2IdKey gHC__ SLIT("unpackPS2__")
+  = pcMiscPrelId unpackCString2IdKey pACKED_STRING SLIT("unpackCString2#")
 		 (mkFunTys [addrPrimTy{-a char *-}, intPrimTy{-length-}] stringTy)
 		 noIdInfo
 
 --------------------------------------------------------------------
 unpackCStringAppendId
-  = pcMiscPrelId unpackCStringAppendIdKey gHC__ SLIT("unpackAppendPS__")
+  = pcMiscPrelId unpackCStringAppendIdKey pACKED_STRING SLIT("unpackAppendCString#")
 		(mkFunTys [addrPrimTy{-a "char *" pointer-},stringTy] stringTy)
 		((noIdInfo
-		 {-LATER:`addInfo_UF` mkMagicUnfolding unpackCStringAppendIdKey-})
-		 `addInfo` mkArityInfo 2)
+		 {-LATER:`addUnfoldInfo` mkMagicUnfolding unpackCStringAppendIdKey-})
+		 `addArityInfo` exactArity 2)
 
 unpackCStringFoldrId
-  = pcMiscPrelId unpackCStringFoldrIdKey gHC__ SLIT("unpackFoldrPS__")
+  = pcMiscPrelId unpackCStringFoldrIdKey pACKED_STRING SLIT("unpackFoldrCString#")
 		(mkSigmaTy [alphaTyVar] []
 		(mkFunTys [addrPrimTy{-a "char *" pointer-},
 			   mkFunTys [charTy, alphaTy] alphaTy,
 			   alphaTy]
 			  alphaTy))
 		((noIdInfo
-		 {-LATER:`addInfo_UF` mkMagicUnfolding unpackCStringFoldrIdKey-})
-		 `addInfo` mkArityInfo 3)
+		 {-LATER:`addUnfoldInfo` mkMagicUnfolding unpackCStringFoldrIdKey-})
+		 `addArityInfo` exactArity 3)
 \end{code}
 
 OK, this is Will's idea: we should have magic values for Integers 0,
 +1, +2, and -1 (go ahead, fire me):
+
 \begin{code}
 integerZeroId
-  = pcMiscPrelId integerZeroIdKey     gHC__ SLIT("integer_0")  integerTy noIdInfo
+  = pcMiscPrelId integerZeroIdKey     pREL_NUM SLIT("integer_0")  integerTy noIdInfo
 integerPlusOneId
-  = pcMiscPrelId integerPlusOneIdKey  gHC__ SLIT("integer_1")  integerTy noIdInfo
+  = pcMiscPrelId integerPlusOneIdKey  pREL_NUM SLIT("integer_1")  integerTy noIdInfo
 integerPlusTwoId
-  = pcMiscPrelId integerPlusTwoIdKey  gHC__ SLIT("integer_2")  integerTy noIdInfo
+  = pcMiscPrelId integerPlusTwoIdKey  pREL_NUM SLIT("integer_2")  integerTy noIdInfo
 integerMinusOneId
-  = pcMiscPrelId integerMinusOneIdKey gHC__ SLIT("integer_m1") integerTy noIdInfo
+  = pcMiscPrelId integerMinusOneIdKey pREL_NUM SLIT("integer_m1") integerTy noIdInfo
 \end{code}
 
 %************************************************************************
@@ -207,10 +208,10 @@ integerMinusOneId
 
 -}
 
-seqId = pcMiscPrelId seqIdKey gHC__ SLIT("seq")
+seqId = pcMiscPrelId seqIdKey pRELUDE SLIT("seq")
 		  (mkSigmaTy [alphaTyVar, betaTyVar] []
 		    (mkFunTys [alphaTy, betaTy] betaTy))
-		  (noIdInfo `addInfo_UF` (mkUnfolding EssentialUnfolding seq_template))
+		  (noIdInfo `addUnfoldInfo` (mkUnfolding True seq_template))
   where
     [x, y, z]
       = mkTemplateLocals [
@@ -242,10 +243,10 @@ seqId = pcMiscPrelId seqIdKey gHC__ SLIT("seq")
     par = /\ a b -> \ x::a y::b -> case par# x of { 0# -> parError#; _ -> y; }
 
 -}
-parId = pcMiscPrelId parIdKey gHC__ SLIT("par")
+parId = pcMiscPrelId parIdKey cONC_BASE SLIT("par")
 		  (mkSigmaTy [alphaTyVar, betaTyVar] []
 		    (mkFunTys [alphaTy, betaTy] betaTy))
-		  (noIdInfo `addInfo_UF` (mkUnfolding EssentialUnfolding par_template))
+		  (noIdInfo `addUnfoldInfo` (mkUnfolding True par_template))
   where
     [x, y, z]
       = mkTemplateLocals [
@@ -265,10 +266,10 @@ parId = pcMiscPrelId parIdKey gHC__ SLIT("par")
 {-
    _fork_ = /\ a b -> \ x::a y::b -> case fork# x of { 0# -> parError#; _ -> y; }
 -}
-forkId = pcMiscPrelId forkIdKey gHC__ SLIT("fork")
+forkId = pcMiscPrelId forkIdKey cONC_BASE SLIT("fork")
 		  (mkSigmaTy [alphaTyVar, betaTyVar] []
 		    (mkFunTys [alphaTy, betaTy] betaTy))
-		  (noIdInfo `addInfo_UF` (mkUnfolding EssentialUnfolding fork_template))
+		  (noIdInfo `addUnfoldInfo` (mkUnfolding True fork_template))
   where
     [x, y, z]
       = mkTemplateLocals [
@@ -289,10 +290,10 @@ forkId = pcMiscPrelId forkIdKey gHC__ SLIT("fork")
 GranSim ones:
 \begin{code}
 {- OUT:
-parLocalId = pcMiscPrelId parLocalIdKey gHC__ SLIT("parLocal")
+parLocalId = pcMiscPrelId parLocalIdKey cONC_BASE SLIT("parLocal")
 		  (mkSigmaTy [alphaTyVar, betaTyVar] []
 		    (mkFunTys [intPrimTy, intPrimTy, intPrimTy, intPrimTy, alphaTy, betaTy] betaTy))
-		  (noIdInfo `addInfo_UF` (mkUnfolding EssentialUnfolding parLocal_template))
+		  (noIdInfo `addUnfoldInfo` (mkUnfolding True parLocal_template))
   where
     -- Annotations: w: name, g: gran. info, s: size info, p: par info  -- HWL
     [w, g, s, p, x, y, z]
@@ -313,10 +314,10 @@ parLocalId = pcMiscPrelId parLocalIdKey gHC__ SLIT("parLocal")
 		    [(mkMachInt 0, mkTyApp (Var pAR_ERROR_ID) [betaTy])]
 		    (BindDefault z (Var y))))
 
-parGlobalId = pcMiscPrelId parGlobalIdKey gHC__ SLIT("parGlobal")
+parGlobalId = pcMiscPrelId parGlobalIdKey cONC_BASE SLIT("parGlobal")
 		  (mkSigmaTy [alphaTyVar, betaTyVar] []
 		    (mkFunTys [intPrimTy, intPrimTy, intPrimTy, intPrimTy, alphaTy, betaTy] betaTy))
-		  (noIdInfo `addInfo_UF` (mkUnfolding EssentialUnfolding parGlobal_template))
+		  (noIdInfo `addUnfoldInfo` (mkUnfolding True parGlobal_template))
   where
     -- Annotations: w: name, g: gran. info, s: size info, p: par info  -- HWL
     [w, g, s, p, x, y, z]
@@ -338,11 +339,11 @@ parGlobalId = pcMiscPrelId parGlobalIdKey gHC__ SLIT("parGlobal")
 		    (BindDefault z (Var y))))
 
 
-parAtId = pcMiscPrelId parAtIdKey gHC__ SLIT("parAt")
+parAtId = pcMiscPrelId parAtIdKey cONC_BASE SLIT("parAt")
 		  (mkSigmaTy [alphaTyVar, betaTyVar] []
 		    (mkFunTys [intPrimTy, intPrimTy, intPrimTy, intPrimTy,
 		               alphaTy, betaTy, gammaTy] gammaTy))
-		  (noIdInfo `addInfo_UF` (mkUnfolding EssentialUnfolding parAt_template))
+		  (noIdInfo `addUnfoldInfo` (mkUnfolding True parAt_template))
   where
     -- Annotations: w: name, g: gran. info, s: size info, p: par info  -- HWL
     [w, g, s, p, v, x, y, z]
@@ -364,10 +365,10 @@ parAtId = pcMiscPrelId parAtIdKey gHC__ SLIT("parAt")
 		    [(mkMachInt 0, mkTyApp (Var pAR_ERROR_ID) [gammaTy])]
 		    (BindDefault z (Var y))))
 
-parAtAbsId = pcMiscPrelId parAtAbsIdKey gHC__ SLIT("parAtAbs")
+parAtAbsId = pcMiscPrelId parAtAbsIdKey cONC_BASE SLIT("parAtAbs")
 		  (mkSigmaTy [alphaTyVar, betaTyVar] []
 		    (mkFunTys [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, alphaTy, betaTy] betaTy))
-		  (noIdInfo `addInfo_UF` (mkUnfolding EssentialUnfolding parAtAbs_template))
+		  (noIdInfo `addUnfoldInfo` (mkUnfolding True parAtAbs_template))
   where
     -- Annotations: w: name, g: gran. info, s: size info, p: par info  -- HWL
     [w, g, s, p, v, x, y, z]
@@ -389,10 +390,10 @@ parAtAbsId = pcMiscPrelId parAtAbsIdKey gHC__ SLIT("parAtAbs")
 		    [(mkMachInt 0, mkTyApp (Var pAR_ERROR_ID) [betaTy])]
 		    (BindDefault z (Var y))))
 
-parAtRelId = pcMiscPrelId parAtRelIdKey gHC__ SLIT("parAtRel")
+parAtRelId = pcMiscPrelId parAtRelIdKey cONC_BASE SLIT("parAtRel")
 		  (mkSigmaTy [alphaTyVar, betaTyVar] []
 		    (mkFunTys [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, alphaTy, betaTy] betaTy))
-		  (noIdInfo `addInfo_UF` (mkUnfolding EssentialUnfolding parAtRel_template))
+		  (noIdInfo `addUnfoldInfo` (mkUnfolding True parAtRel_template))
   where
     -- Annotations: w: name, g: gran. info, s: size info, p: par info  -- HWL
     [w, g, s, p, v, x, y, z]
@@ -414,11 +415,11 @@ parAtRelId = pcMiscPrelId parAtRelIdKey gHC__ SLIT("parAtRel")
 		    [(mkMachInt 0, mkTyApp (Var pAR_ERROR_ID) [betaTy])]
 		    (BindDefault z (Var y))))
 
-parAtForNowId = pcMiscPrelId parAtForNowIdKey gHC__ SLIT("parAtForNow")
+parAtForNowId = pcMiscPrelId parAtForNowIdKey cONC_BASE SLIT("parAtForNow")
 		  (mkSigmaTy [alphaTyVar, betaTyVar] []
 		    (mkFunTys [intPrimTy, intPrimTy, intPrimTy, intPrimTy,
 				alphaTy, betaTy, gammaTy] gammaTy))
-		  (noIdInfo `addInfo_UF` (mkUnfolding EssentialUnfolding parAtForNow_template))
+		  (noIdInfo `addUnfoldInfo` (mkUnfolding True parAtForNow_template))
   where
     -- Annotations: w: name, g: gran. info, s: size info, p: par info  -- HWL
     [w, g, s, p, v, x, y, z]
@@ -443,10 +444,10 @@ parAtForNowId = pcMiscPrelId parAtForNowIdKey gHC__ SLIT("parAtForNow")
 -- copyable and noFollow are currently merely hooks: they are translated into
 -- calls to the macros COPYABLE and NOFOLLOW                            -- HWL 
 
-copyableId = pcMiscPrelId copyableIdKey gHC__ SLIT("copyable")
+copyableId = pcMiscPrelId copyableIdKey cONC_BASE SLIT("copyable")
 		  (mkSigmaTy [alphaTyVar] []
 		    alphaTy)
-		  (noIdInfo `addInfo_UF` (mkUnfolding EssentialUnfolding copyable_template))
+		  (noIdInfo `addUnfoldInfo` (mkUnfolding True copyable_template))
   where
     -- Annotations: x: closure that's tagged to by copyable
     [x, z]
@@ -458,10 +459,10 @@ copyableId = pcMiscPrelId copyableIdKey gHC__ SLIT("copyable")
     copyable_template
       = mkLam [alphaTyVar] [x] ( Prim CopyableOp [TyArg alphaTy, VarArg x] )
 
-noFollowId = pcMiscPrelId noFollowIdKey gHC__ SLIT("noFollow")
+noFollowId = pcMiscPrelId noFollowIdKey cONC_BASE SLIT("noFollow")
 		  (mkSigmaTy [alphaTyVar] []
 		    alphaTy)
-		  (noIdInfo `addInfo_UF` (mkUnfolding EssentialUnfolding noFollow_template))
+		  (noIdInfo `addUnfoldInfo` (mkUnfolding True noFollow_template))
   where
     -- Annotations: x: closure that's tagged to not follow
     [x, z]
@@ -494,7 +495,7 @@ runST a m = case m _RealWorld (S# _RealWorld realWorld#) of
 We unfold always, just for simplicity:
 \begin{code}
 runSTId
-  = pcMiscPrelId runSTIdKey gHC__ SLIT("runST") run_ST_ty id_info
+  = pcMiscPrelId runSTIdKey sT_BASE SLIT("runST") run_ST_ty id_info
   where
     s_tv = betaTyVar
     s	 = betaTy
@@ -507,10 +508,10 @@ runSTId
 
     id_info
       = noIdInfo
-	`addInfo` mkArityInfo 1
-	`addInfo` mkStrictnessInfo [WwStrict] Nothing
-	`addInfo` mkArgUsageInfo [ArgUsage 1]
-	-- ABSOLUTELY NO UNFOLDING, e.g.: (mkUnfolding EssentialUnfolding run_ST_template)
+	`addArityInfo` exactArity 1
+	`addStrictnessInfo` mkStrictnessInfo [WwStrict] Nothing
+	`addArgUsageInfo` mkArgUsageInfo [ArgUsage 1]
+	-- ABSOLUTELY NO UNFOLDING, e.g.: (mkUnfolding True run_ST_template)
 	-- see example below
 {- OUT:
     [m, t, r, wild]
@@ -526,7 +527,7 @@ runSTId
 	    Let (NonRec t (Con stateDataCon [TyArg realWorldTy, VarArg realWorldPrimId])) (
 	      Case (App (mkTyApp (Var m) [realWorldTy]) (VarArg t)) (
 		AlgAlts
-		  [(mkTupleCon 2, [r, wild], Var r)]
+		  [(pairDataCon, [r, wild], Var r)]
 		  NoDefault)))
 -}
 \end{code}
@@ -564,13 +565,13 @@ All calls to @f@ will share a {\em single} array!  End SLPJ 95/04.
 nasty as-is, change it back to a literal (@Literal@).
 \begin{code}
 realWorldPrimId
-  = pcMiscPrelId realWorldPrimIdKey gHC_BUILTINS SLIT("realWorld#")
+  = pcMiscPrelId realWorldPrimIdKey gHC__ SLIT("realWorld#")
 	realWorldStatePrimTy
 	noIdInfo
 \end{code}
 
 \begin{code}
-voidId = pcMiscPrelId voidIdKey gHC_BUILTINS SLIT("void") voidTy noIdInfo
+voidId = pcMiscPrelId voidIdKey gHC__ SLIT("void") voidTy noIdInfo
 \end{code}
 
 %************************************************************************
@@ -581,12 +582,12 @@ voidId = pcMiscPrelId voidIdKey gHC_BUILTINS SLIT("void") voidTy noIdInfo
 
 \begin{code}
 buildId
-  = pcMiscPrelId buildIdKey SLIT("GHCerr") SLIT("build") buildTy
+  = pcMiscPrelId buildIdKey gHC_ERR SLIT("build") buildTy
 	((((noIdInfo
-		{-LATER:`addInfo_UF` mkMagicUnfolding buildIdKey-})
-		`addInfo` mkStrictnessInfo [WwStrict] Nothing)
-		`addInfo` mkArgUsageInfo [ArgUsage 2])
-		`addInfo` pcGenerateSpecs buildIdKey buildId noIdInfo{-ToDo-} buildTy)
+		{-LATER:`addUnfoldInfo` mkMagicUnfolding buildIdKey-})
+		`addStrictnessInfo` mkStrictnessInfo [WwStrict] Nothing)
+		`addArgUsageInfo` mkArgUsageInfo [ArgUsage 2])
+		`addSpecInfo` pcGenerateSpecs buildIdKey buildId noIdInfo{-ToDo-} buildTy)
 	-- cheating, but since _build never actually exists ...
   where
     -- The type of this strange object is:
@@ -626,11 +627,11 @@ mkBuild ty tv c n g expr
 
 \begin{code}
 augmentId
-  = pcMiscPrelId augmentIdKey SLIT("GHCerr") SLIT("augment") augmentTy
+  = pcMiscPrelId augmentIdKey gHC_ERR SLIT("augment") augmentTy
 	(((noIdInfo
-		{-LATER:`addInfo_UF` mkMagicUnfolding augmentIdKey-})
-		`addInfo` mkStrictnessInfo [WwStrict,WwLazy False] Nothing)
-		`addInfo` mkArgUsageInfo [ArgUsage 2,UnknownArgUsage])
+		{-LATER:`addUnfoldInfo` mkMagicUnfolding augmentIdKey-})
+		`addStrictnessInfo` mkStrictnessInfo [WwStrict,WwLazy False] Nothing)
+		`addArgUsageInfo` mkArgUsageInfo [ArgUsage 2,UnknownArgUsage])
 	-- cheating, but since _augment never actually exists ...
   where
     -- The type of this strange object is:
@@ -643,7 +644,7 @@ augmentId
 \end{code}
 
 \begin{code}
-foldrId = pcMiscPrelId foldrIdKey pRELUDE SLIT("foldr")
+foldrId = pcMiscPrelId foldrIdKey pREL_BASE SLIT("foldr")
 		 foldrTy idInfo
   where
 	foldrTy =
@@ -651,13 +652,13 @@ foldrId = pcMiscPrelId foldrIdKey pRELUDE SLIT("foldr")
 		(mkFunTys [mkFunTys [alphaTy, betaTy] betaTy, betaTy, mkListTy alphaTy] betaTy)
 
 	idInfo = (((((noIdInfo
-			{-LATER:`addInfo_UF` mkMagicUnfolding foldrIdKey-})
-			`addInfo` mkStrictnessInfo [WwLazy False,WwLazy False,WwStrict] Nothing)
-			`addInfo` mkArityInfo 3)
-			`addInfo` mkUpdateInfo [2,2,1])
-			`addInfo` pcGenerateSpecs foldrIdKey foldrId noIdInfo{-ToDo-} foldrTy)
+			{-LATER:`addUnfoldInfo` mkMagicUnfolding foldrIdKey-})
+			`addStrictnessInfo` mkStrictnessInfo [WwLazy False,WwLazy False,WwStrict] Nothing)
+			`addArityInfo` exactArity 3)
+			`addUpdateInfo` mkUpdateInfo [2,2,1])
+			`addSpecInfo` pcGenerateSpecs foldrIdKey foldrId noIdInfo{-ToDo-} foldrTy)
 
-foldlId = pcMiscPrelId foldlIdKey pRELUDE SLIT("foldl")
+foldlId = pcMiscPrelId foldlIdKey pREL_LIST SLIT("foldl")
 		 foldlTy idInfo
   where
 	foldlTy =
@@ -665,11 +666,11 @@ foldlId = pcMiscPrelId foldlIdKey pRELUDE SLIT("foldl")
 		(mkFunTys [mkFunTys [alphaTy, betaTy] alphaTy, alphaTy, mkListTy betaTy] alphaTy)
 
 	idInfo = (((((noIdInfo
-			{-LATER:`addInfo_UF` mkMagicUnfolding foldlIdKey-})
-			`addInfo` mkStrictnessInfo [WwLazy False,WwLazy False,WwStrict] Nothing)
-			`addInfo` mkArityInfo 3)
-			`addInfo` mkUpdateInfo [2,2,1])
-			`addInfo` pcGenerateSpecs foldlIdKey foldlId noIdInfo{-ToDo-} foldlTy)
+			{-LATER:`addUnfoldInfo` mkMagicUnfolding foldlIdKey-})
+			`addStrictnessInfo` mkStrictnessInfo [WwLazy False,WwLazy False,WwStrict] Nothing)
+			`addArityInfo` exactArity 3)
+			`addUpdateInfo` mkUpdateInfo [2,2,1])
+			`addSpecInfo` pcGenerateSpecs foldlIdKey foldlId noIdInfo{-ToDo-} foldlTy)
 
 -- A bit of magic goes no here. We translate appendId into ++,
 -- you have to be carefull when you actually compile append:
@@ -686,15 +687,15 @@ foldlId = pcMiscPrelId foldlIdKey pRELUDE SLIT("foldl")
 --
 {- OLD: doesn't apply with 1.3
 appendId
-  = pcMiscPrelId appendIdKey pRELUDE_LIST SLIT("++") appendTy idInfo
+  = pcMiscPrelId appendIdKey mONAD SLIT("++") appendTy idInfo
   where
     appendTy =
       (mkSigmaTy [alphaTyVar] []
 	    (mkFunTys [mkListTy alphaTy, mkListTy alphaTy] (mkListTy alphaTy)))
     idInfo = (((noIdInfo
-		`addInfo` mkStrictnessInfo [WwStrict,WwLazy False] Nothing)
-		`addInfo` mkArityInfo 2)
-		`addInfo` mkUpdateInfo [1,2])
+		`addStrictnessInfo` mkStrictnessInfo [WwStrict,WwLazy False] Nothing)
+		`addArityInfo` exactArity 2)
+		`addUpdateInfo` mkUpdateInfo [1,2])
 -}
 \end{code}
 
diff --git a/ghc/compiler/prelude/PrimOp.lhs b/ghc/compiler/prelude/PrimOp.lhs
index 1e62e9c326..0e522a4366 100644
--- a/ghc/compiler/prelude/PrimOp.lhs
+++ b/ghc/compiler/prelude/PrimOp.lhs
@@ -36,7 +36,7 @@ import TysPrim
 import TysWiredIn
 
 import CStrings		( identToC )
-import CgCompInfo   	( mIN_MP_INT_SIZE, mP_STRUCT_SIZE )
+import Constants   	( mIN_MP_INT_SIZE, mP_STRUCT_SIZE )
 import HeapOffs		( addOff, intOff, totHdrSize, HeapOffset )
 import PprStyle		( codeStyle{-, PprStyle(..) ToDo:rm-} )
 import PprType		( pprParendGenType, GenTyVar{-instance Outputable-} )
@@ -702,12 +702,12 @@ primOpInfo CharNeOp   = Compare SLIT("neChar#")   charPrimTy
 primOpInfo CharLtOp   = Compare SLIT("ltChar#")   charPrimTy
 primOpInfo CharLeOp   = Compare SLIT("leChar#")   charPrimTy
 
-primOpInfo IntGtOp    = Compare SLIT("gtInt#")	   intPrimTy
-primOpInfo IntGeOp    = Compare SLIT("geInt#")	   intPrimTy
-primOpInfo IntEqOp    = Compare SLIT("eqInt#")	   intPrimTy
-primOpInfo IntNeOp    = Compare SLIT("neInt#")	   intPrimTy
-primOpInfo IntLtOp    = Compare SLIT("ltInt#")	   intPrimTy
-primOpInfo IntLeOp    = Compare SLIT("leInt#")	   intPrimTy
+primOpInfo IntGtOp    = Compare SLIT(">#")	   intPrimTy
+primOpInfo IntGeOp    = Compare SLIT(">=#")	   intPrimTy
+primOpInfo IntEqOp    = Compare SLIT("==#")	   intPrimTy
+primOpInfo IntNeOp    = Compare SLIT("/=#")	   intPrimTy
+primOpInfo IntLtOp    = Compare SLIT("<#")	   intPrimTy
+primOpInfo IntLeOp    = Compare SLIT("<=#")	   intPrimTy
 
 primOpInfo WordGtOp   = Compare SLIT("gtWord#")   wordPrimTy
 primOpInfo WordGeOp   = Compare SLIT("geWord#")   wordPrimTy
@@ -730,12 +730,12 @@ primOpInfo FloatNeOp  = Compare SLIT("neFloat#")  floatPrimTy
 primOpInfo FloatLtOp  = Compare SLIT("ltFloat#")  floatPrimTy
 primOpInfo FloatLeOp  = Compare SLIT("leFloat#")  floatPrimTy
 
-primOpInfo DoubleGtOp = Compare SLIT("gtDouble#") doublePrimTy
-primOpInfo DoubleGeOp = Compare SLIT("geDouble#") doublePrimTy
-primOpInfo DoubleEqOp = Compare SLIT("eqDouble#") doublePrimTy
-primOpInfo DoubleNeOp = Compare SLIT("neDouble#") doublePrimTy
-primOpInfo DoubleLtOp = Compare SLIT("ltDouble#") doublePrimTy
-primOpInfo DoubleLeOp = Compare SLIT("leDouble#") doublePrimTy
+primOpInfo DoubleGtOp = Compare SLIT(">##") doublePrimTy
+primOpInfo DoubleGeOp = Compare SLIT(">=##") doublePrimTy
+primOpInfo DoubleEqOp = Compare SLIT("==##") doublePrimTy
+primOpInfo DoubleNeOp = Compare SLIT("/=##") doublePrimTy
+primOpInfo DoubleLtOp = Compare SLIT("<##") doublePrimTy
+primOpInfo DoubleLeOp = Compare SLIT("<=##") doublePrimTy
 \end{code}
 
 %************************************************************************
@@ -756,9 +756,9 @@ primOpInfo ChrOp = Coercing SLIT("chr#") intPrimTy charPrimTy
 %************************************************************************
 
 \begin{code}
-primOpInfo IntAddOp  = Dyadic SLIT("plusInt#")	 intPrimTy
-primOpInfo IntSubOp  = Dyadic SLIT("minusInt#") intPrimTy
-primOpInfo IntMulOp  = Dyadic SLIT("timesInt#") intPrimTy
+primOpInfo IntAddOp  = Dyadic SLIT("+#")	 intPrimTy
+primOpInfo IntSubOp  = Dyadic SLIT("-#") intPrimTy
+primOpInfo IntMulOp  = Dyadic SLIT("*#") intPrimTy
 primOpInfo IntQuotOp = Dyadic SLIT("quotInt#")	 intPrimTy
 primOpInfo IntRemOp  = Dyadic SLIT("remInt#")	 intPrimTy
 
@@ -851,10 +851,10 @@ primOpInfo FloatPowerOp	= Dyadic    SLIT("powerFloat#")   floatPrimTy
 similar).
 
 \begin{code}
-primOpInfo DoubleAddOp	= Dyadic    SLIT("plusDouble#")   doublePrimTy
-primOpInfo DoubleSubOp	= Dyadic    SLIT("minusDouble#")  doublePrimTy
-primOpInfo DoubleMulOp	= Dyadic    SLIT("timesDouble#")  doublePrimTy
-primOpInfo DoubleDivOp	= Dyadic    SLIT("divideDouble#") doublePrimTy
+primOpInfo DoubleAddOp	= Dyadic    SLIT("+##")   doublePrimTy
+primOpInfo DoubleSubOp	= Dyadic    SLIT("-##")  doublePrimTy
+primOpInfo DoubleMulOp	= Dyadic    SLIT("*##")  doublePrimTy
+primOpInfo DoubleDivOp	= Dyadic    SLIT("/##") doublePrimTy
 primOpInfo DoubleNegOp	= Monadic   SLIT("negateDouble#") doublePrimTy
 
 primOpInfo Double2IntOp	    = Coercing SLIT("double2Int#")   doublePrimTy intPrimTy
@@ -875,7 +875,7 @@ primOpInfo DoubleAtanOp	= Monadic   SLIT("atanDouble#")   doublePrimTy
 primOpInfo DoubleSinhOp	= Monadic   SLIT("sinhDouble#")   doublePrimTy
 primOpInfo DoubleCoshOp	= Monadic   SLIT("coshDouble#")   doublePrimTy
 primOpInfo DoubleTanhOp	= Monadic   SLIT("tanhDouble#")   doublePrimTy
-primOpInfo DoublePowerOp= Dyadic    SLIT("powerDouble#")  doublePrimTy
+primOpInfo DoublePowerOp= Dyadic    SLIT("**##")  doublePrimTy
 \end{code}
 
 %************************************************************************
diff --git a/ghc/compiler/prelude/TysPrim.lhs b/ghc/compiler/prelude/TysPrim.lhs
index 954659a017..17ee58e629 100644
--- a/ghc/compiler/prelude/TysPrim.lhs
+++ b/ghc/compiler/prelude/TysPrim.lhs
@@ -14,13 +14,13 @@ module TysPrim where
 IMP_Ubiq(){-uitous-}
 
 import Kind		( mkUnboxedTypeKind, mkBoxedTypeKind, mkTypeKind, mkArrowKind )
-import Name		( mkPrimitiveName )
-import PrelMods		( gHC_BUILTINS )
+import Name		( mkWiredInTyConName )
 import PrimRep		( PrimRep(..) )	-- getPrimRepInfo uses PrimRep repn
 import TyCon		( mkPrimTyCon, mkDataTyCon, NewOrData(..) )
 import Type		( applyTyCon, mkTyVarTys, mkTyConTy )
 import TyVar		( GenTyVar(..), alphaTyVars )
 import Usage		( usageOmega )
+import PrelMods		( gHC__ )
 import Unique
 \end{code}
 
@@ -40,10 +40,10 @@ alphaTys = mkTyVarTys alphaTyVars
 pcPrimTyCon :: Unique{-TyConKey-} -> FAST_STRING -> Int -> PrimRep -> TyCon
 
 pcPrimTyCon key str arity primrep
-  = mkPrimTyCon name (mk_kind arity) primrep
+  = the_tycon
   where
-    name = mkPrimitiveName key (OrigName gHC_BUILTINS str)
-
+    name      = mkWiredInTyConName key gHC__ str the_tycon
+    the_tycon = mkPrimTyCon name (mk_kind arity) primrep
     mk_kind 0 = mkUnboxedTypeKind
     mk_kind n = mkTypeKind `mkArrowKind` mk_kind (n-1)
 
@@ -111,17 +111,8 @@ We never manipulate values of type RealWorld; it's only used in the type
 system, to parameterise State#.
 
 \begin{code}
-realWorldTy = applyTyCon realWorldTyCon []
-realWorldTyCon
-  = mkDataTyCon name mkBoxedTypeKind 
-	[{-no tyvars-}]
-	[{-no context-}]
-	[{-no data cons!-}] -- we tell you *nothing* about this guy
-	[{-no derivings-}]
-	DataType
-  where
-    name = mkPrimitiveName realWorldTyConKey (OrigName gHC_BUILTINS SLIT("RealWorld"))
-
+realWorldTy	     = applyTyCon realWorldTyCon []
+realWorldTyCon	     = mk_no_constr_tycon realWorldTyConKey SLIT("RealWorld") 
 realWorldStatePrimTy = mkStatePrimTy realWorldTy
 \end{code}
 
@@ -137,17 +128,21 @@ defined in \tr{TysWiredIn.lhs}, not here.
 --
 -- ) It's boxed; there is only one value of this
 -- type, namely "void", whose semantics is just bottom.
-voidTy = mkTyConTy voidTyCon
-
-voidTyCon
-  = mkDataTyCon name mkBoxedTypeKind 
-	[{-no tyvars-}]
-	[{-no context-}]
-	[{-no data cons!-}]
-	[{-no derivings-}]
-	DataType
+voidTy    = mkTyConTy voidTyCon
+voidTyCon = mk_no_constr_tycon voidTyConKey SLIT("Void")
+\end{code}
+
+\begin{code}
+mk_no_constr_tycon key str
+  = the_tycon
   where
-    name = mkPrimitiveName voidTyConKey (OrigName gHC_BUILTINS SLIT("Void"))
+    name      = mkWiredInTyConName key gHC__ str the_tycon
+    the_tycon = mkDataTyCon name mkBoxedTypeKind 
+			[{-no tyvars-}]
+			[{-no context-}]
+			[{-no data cons!-}] -- we tell you *nothing* about this guy
+			[{-no derivings-}]
+			DataType
 \end{code}
 
 %************************************************************************
diff --git a/ghc/compiler/prelude/TysWiredIn.lhs b/ghc/compiler/prelude/TysWiredIn.lhs
index 5b1e3d0a0c..06c91a35fa 100644
--- a/ghc/compiler/prelude/TysWiredIn.lhs
+++ b/ghc/compiler/prelude/TysWiredIn.lhs
@@ -45,6 +45,7 @@ module TysWiredIn (
 	mkPrimIoTy,
 	mkStateTy,
 	mkStateTransformerTy,
+	tupleTyCon, tupleCon, unitTyCon, unitDataCon, pairTyCon, pairDataCon,
 	mkTupleTy,
 	nilDataCon,
 	primIoTyCon,
@@ -86,7 +87,7 @@ module TysWiredIn (
 --import Kind
 
 IMP_Ubiq()
-IMPORT_DELOOPER(TyLoop)	( mkDataCon, StrictnessMark(..) )
+IMPORT_DELOOPER(TyLoop)	( mkDataCon, mkTupleCon, StrictnessMark(..) )
 IMPORT_DELOOPER(IdLoop)	( SpecEnv )
 
 -- friends:
@@ -95,15 +96,15 @@ import TysPrim
 
 -- others:
 import Kind		( mkBoxedTypeKind, mkArrowKind )
-import Name		( mkWiredInName, ExportFlag(..) )
-import SrcLoc		( mkBuiltinSrcLoc )
+import Name		( mkWiredInTyConName, mkWiredInIdName, mkTupNameStr )
 import TyCon		( mkDataTyCon, mkTupleTyCon, mkSynTyCon,
 			  NewOrData(..), TyCon
 			)
-import Type		( mkTyConTy, applyTyCon, mkSigmaTy,
-			  mkFunTy, maybeAppTyCon,
+import Type		( mkTyConTy, applyTyCon, mkSigmaTy, mkTyVarTys, 
+			  mkFunTy, mkFunTys, maybeAppTyCon,
 			  GenType(..), SYN_IE(ThetaType), SYN_IE(TauType) )
-import TyVar		( tyVarKind, alphaTyVar, betaTyVar )
+import TyVar		( tyVarKind, alphaTyVars, alphaTyVar, betaTyVar )
+import Lex		( mkTupNameStr )
 import Unique
 import Util		( assoc, panic )
 
@@ -124,25 +125,30 @@ pcDataTyCon = pc_tycon DataType
 pcNewTyCon  = pc_tycon NewType
 
 pc_tycon new_or_data key mod str tyvars cons
-  = mkDataTyCon (mkWiredInName key (OrigName mod str) ExportAll) tycon_kind 
+  = tycon
+  where
+    tycon = mkDataTyCon name tycon_kind 
 		tyvars [{-no context-}] cons [{-no derivings-}]
 		new_or_data
-  where
+    name = mkWiredInTyConName key mod str tycon
     tycon_kind = foldr (mkArrowKind . tyVarKind) mkBoxedTypeKind tyvars
 
 pcSynTyCon key mod str kind arity tyvars expansion
-  = mkSynTyCon
-     (mkWiredInName key (OrigName mod str) ExportAll)
-     kind arity tyvars expansion
+  = tycon
+  where
+    tycon = mkSynTyCon name kind arity tyvars expansion
+    name  = mkWiredInTyConName key mod str tycon
 
 pcDataCon :: Unique{-DataConKey-} -> Module -> FAST_STRING
 	  -> [TyVar] -> ThetaType -> [TauType] -> TyCon -> SpecEnv -> Id
 pcDataCon key mod str tyvars context arg_tys tycon specenv
-  = mkDataCon (mkWiredInName key (OrigName mod str) ExportAll)
-	[ NotMarkedStrict | a <- arg_tys ]
-	[ {- no labelled fields -} ]
-	tyvars context arg_tys tycon
-	-- specenv
+  = data_con
+  where
+    data_con = mkDataCon name 
+		[ NotMarkedStrict | a <- arg_tys ]
+		[ {- no labelled fields -} ]
+		tyvars context arg_tys tycon
+    name = mkWiredInIdName key mod str data_con
 
 pcGenerateDataSpecs :: Type -> SpecEnv
 pcGenerateDataSpecs ty
@@ -153,6 +159,45 @@ pcGenerateDataSpecs ty
 
 %************************************************************************
 %*									*
+\subsection[TysWiredIn-tuples]{The tuple types}
+%*									*
+%************************************************************************
+
+\begin{code}
+tupleTyCon :: Arity -> TyCon
+tupleTyCon arity
+  = tycon
+  where
+    tycon = mkTupleTyCon uniq name arity
+    uniq  = mkTupleTyConUnique arity
+    name  = mkWiredInTyConName uniq mod_name (mkTupNameStr arity) tycon
+    mod_name | arity == 0 = pREL_BASE
+	     | otherwise  = pREL_TUP 
+
+tupleCon :: Arity -> Id
+tupleCon arity
+  = tuple_con
+  where
+    tuple_con = mkTupleCon arity name ty
+    uniq      = mkTupleDataConUnique arity
+    name      = mkWiredInIdName uniq mod_name (mkTupNameStr arity) tuple_con
+    mod_name  | arity == 0 = pREL_BASE
+	      | otherwise  = pREL_TUP
+    ty 		= mkSigmaTy tyvars [] (mkFunTys tyvar_tys (applyTyCon tycon tyvar_tys))
+    tyvars	= take arity alphaTyVars
+    tyvar_tys	= mkTyVarTys tyvars
+    tycon	= tupleTyCon arity
+
+unitTyCon = tupleTyCon 0
+pairTyCon = tupleTyCon 2
+
+unitDataCon = tupleCon 0
+pairDataCon = tupleCon 2
+\end{code}
+
+
+%************************************************************************
+%*									*
 \subsection[TysWiredIn-boxed-prim]{The ``boxed primitive'' types (@Char@, @Int@, etc)}
 %*									*
 %************************************************************************
@@ -160,8 +205,8 @@ pcGenerateDataSpecs ty
 \begin{code}
 charTy = mkTyConTy charTyCon
 
-charTyCon = pcDataTyCon charTyConKey  pRELUDE  SLIT("Char") [] [charDataCon]
-charDataCon = pcDataCon charDataConKey pRELUDE SLIT("C#") [] [] [charPrimTy] charTyCon nullSpecEnv
+charTyCon = pcDataTyCon charTyConKey  pREL_BASE  SLIT("Char") [] [charDataCon]
+charDataCon = pcDataCon charDataConKey pREL_BASE SLIT("C#") [] [] [charPrimTy] charTyCon nullSpecEnv
 
 stringTy = mkListTy charTy -- convenience only
 \end{code}
@@ -169,65 +214,65 @@ stringTy = mkListTy charTy -- convenience only
 \begin{code}
 intTy = mkTyConTy intTyCon 
 
-intTyCon = pcDataTyCon intTyConKey pRELUDE SLIT("Int") [] [intDataCon]
-intDataCon = pcDataCon intDataConKey pRELUDE SLIT("I#") [] [] [intPrimTy] intTyCon nullSpecEnv
+intTyCon = pcDataTyCon intTyConKey pREL_BASE SLIT("Int") [] [intDataCon]
+intDataCon = pcDataCon intDataConKey pREL_BASE SLIT("I#") [] [] [intPrimTy] intTyCon nullSpecEnv
 \end{code}
 
 \begin{code}
 wordTy = mkTyConTy wordTyCon
 
-wordTyCon = pcDataTyCon wordTyConKey gHC__ SLIT("Word") [] [wordDataCon]
+wordTyCon = pcDataTyCon wordTyConKey   fOREIGN SLIT("Word") [] [wordDataCon]
 wordDataCon = pcDataCon wordDataConKey gHC__ SLIT("W#") [] [] [wordPrimTy] wordTyCon nullSpecEnv
 \end{code}
 
 \begin{code}
 addrTy = mkTyConTy addrTyCon
 
-addrTyCon = pcDataTyCon addrTyConKey gHC__ SLIT("Addr") [] [addrDataCon]
+addrTyCon = pcDataTyCon addrTyConKey   fOREIGN SLIT("Addr") [] [addrDataCon]
 addrDataCon = pcDataCon addrDataConKey gHC__ SLIT("A#") [] [] [addrPrimTy] addrTyCon nullSpecEnv
 \end{code}
 
 \begin{code}
 floatTy	= mkTyConTy floatTyCon
 
-floatTyCon = pcDataTyCon floatTyConKey pRELUDE SLIT("Float") [] [floatDataCon]
-floatDataCon = pcDataCon floatDataConKey pRELUDE SLIT("F#") [] [] [floatPrimTy] floatTyCon nullSpecEnv
+floatTyCon = pcDataTyCon floatTyConKey pREL_BASE SLIT("Float") [] [floatDataCon]
+floatDataCon = pcDataCon floatDataConKey pREL_BASE SLIT("F#") [] [] [floatPrimTy] floatTyCon nullSpecEnv
 \end{code}
 
 \begin{code}
 doubleTy = mkTyConTy doubleTyCon
 
-doubleTyCon = pcDataTyCon doubleTyConKey pRELUDE SLIT("Double") [] [doubleDataCon]
-doubleDataCon = pcDataCon doubleDataConKey pRELUDE SLIT("D#") [] [] [doublePrimTy] doubleTyCon nullSpecEnv
+doubleTyCon = pcDataTyCon doubleTyConKey pREL_BASE SLIT("Double") [] [doubleDataCon]
+doubleDataCon = pcDataCon doubleDataConKey pREL_BASE SLIT("D#") [] [] [doublePrimTy] doubleTyCon nullSpecEnv
 \end{code}
 
 \begin{code}
 mkStateTy ty	 = applyTyCon stateTyCon [ty]
 realWorldStateTy = mkStateTy realWorldTy -- a common use
 
-stateTyCon = pcDataTyCon stateTyConKey gHC__ SLIT("State") alpha_tyvar [stateDataCon]
+stateTyCon = pcDataTyCon stateTyConKey sT_BASE SLIT("State") alpha_tyvar [stateDataCon]
 stateDataCon
-  = pcDataCon stateDataConKey gHC__ SLIT("S#")
+  = pcDataCon stateDataConKey sT_BASE SLIT("S#")
 	alpha_tyvar [] [mkStatePrimTy alphaTy] stateTyCon nullSpecEnv
 \end{code}
 
 \begin{code}
 stablePtrTyCon
-  = pcDataTyCon stablePtrTyConKey gHC__ SLIT("StablePtr")
+  = pcDataTyCon stablePtrTyConKey fOREIGN SLIT("StablePtr")
 	alpha_tyvar [stablePtrDataCon]
   where
     stablePtrDataCon
-      = pcDataCon stablePtrDataConKey gHC__ SLIT("StablePtr")
+      = pcDataCon stablePtrDataConKey fOREIGN SLIT("StablePtr")
 	    alpha_tyvar [] [mkStablePtrPrimTy alphaTy] stablePtrTyCon nullSpecEnv
 \end{code}
 
 \begin{code}
 foreignObjTyCon
-  = pcDataTyCon foreignObjTyConKey gHC__ SLIT("ForeignObj")
+  = pcDataTyCon foreignObjTyConKey fOREIGN SLIT("ForeignObj")
 	[] [foreignObjDataCon]
   where
     foreignObjDataCon
-      = pcDataCon foreignObjDataConKey gHC__ SLIT("ForeignObj")
+      = pcDataCon foreignObjDataConKey fOREIGN SLIT("ForeignObj")
 	    [] [] [foreignObjPrimTy] foreignObjTyCon nullSpecEnv
 \end{code}
 
@@ -242,27 +287,27 @@ foreignObjTyCon
 integerTy :: GenType t u
 integerTy    = mkTyConTy integerTyCon
 
-integerTyCon = pcDataTyCon integerTyConKey pRELUDE SLIT("Integer") [] [integerDataCon]
+integerTyCon = pcDataTyCon integerTyConKey pREL_BASE SLIT("Integer") [] [integerDataCon]
 
-integerDataCon = pcDataCon integerDataConKey pRELUDE SLIT("J#")
+integerDataCon = pcDataCon integerDataConKey pREL_BASE SLIT("J#")
 		[] [] [intPrimTy, intPrimTy, byteArrayPrimTy] integerTyCon nullSpecEnv
 \end{code}
 
 And the other pairing types:
 \begin{code}
 return2GMPsTyCon = pcDataTyCon return2GMPsTyConKey
-	gHC__ SLIT("Return2GMPs") [] [return2GMPsDataCon]
+	pREL_NUM SLIT("Return2GMPs") [] [return2GMPsDataCon]
 
 return2GMPsDataCon
-  = pcDataCon return2GMPsDataConKey gHC__ SLIT("Return2GMPs") [] []
+  = pcDataCon return2GMPsDataConKey pREL_NUM SLIT("Return2GMPs") [] []
 	[intPrimTy, intPrimTy, byteArrayPrimTy,
 	 intPrimTy, intPrimTy, byteArrayPrimTy] return2GMPsTyCon nullSpecEnv
 
 returnIntAndGMPTyCon = pcDataTyCon returnIntAndGMPTyConKey
-	gHC__ SLIT("ReturnIntAndGMP") [] [returnIntAndGMPDataCon]
+	pREL_NUM SLIT("ReturnIntAndGMP") [] [returnIntAndGMPDataCon]
 
 returnIntAndGMPDataCon
-  = pcDataCon returnIntAndGMPDataConKey gHC__ SLIT("ReturnIntAndGMP") [] []
+  = pcDataCon returnIntAndGMPDataConKey pREL_NUM SLIT("ReturnIntAndGMP") [] []
 	[intPrimTy, intPrimTy, intPrimTy, byteArrayPrimTy] returnIntAndGMPTyCon nullSpecEnv
 \end{code}
 
@@ -281,118 +326,118 @@ We fish one of these \tr{StateAnd<blah>#} things with
 
 \begin{code}
 stateAndPtrPrimTyCon
-  = pcDataTyCon stateAndPtrPrimTyConKey gHC__ SLIT("StateAndPtr#")
+  = pcDataTyCon stateAndPtrPrimTyConKey sT_BASE SLIT("StateAndPtr#")
 		alpha_beta_tyvars [stateAndPtrPrimDataCon]
 stateAndPtrPrimDataCon
-  = pcDataCon stateAndPtrPrimDataConKey gHC__ SLIT("StateAndPtr#")
+  = pcDataCon stateAndPtrPrimDataConKey sT_BASE SLIT("StateAndPtr#")
 		alpha_beta_tyvars [] [mkStatePrimTy alphaTy, betaTy]
 		stateAndPtrPrimTyCon nullSpecEnv
 
 stateAndCharPrimTyCon
-  = pcDataTyCon stateAndCharPrimTyConKey gHC__ SLIT("StateAndChar#")
+  = pcDataTyCon stateAndCharPrimTyConKey sT_BASE SLIT("StateAndChar#")
 		alpha_tyvar [stateAndCharPrimDataCon]
 stateAndCharPrimDataCon
-  = pcDataCon stateAndCharPrimDataConKey gHC__ SLIT("StateAndChar#")
+  = pcDataCon stateAndCharPrimDataConKey sT_BASE SLIT("StateAndChar#")
 		alpha_tyvar [] [mkStatePrimTy alphaTy, charPrimTy]
 		stateAndCharPrimTyCon nullSpecEnv
 
 stateAndIntPrimTyCon
-  = pcDataTyCon stateAndIntPrimTyConKey gHC__ SLIT("StateAndInt#")
+  = pcDataTyCon stateAndIntPrimTyConKey sT_BASE SLIT("StateAndInt#")
 		alpha_tyvar [stateAndIntPrimDataCon]
 stateAndIntPrimDataCon
-  = pcDataCon stateAndIntPrimDataConKey gHC__ SLIT("StateAndInt#")
+  = pcDataCon stateAndIntPrimDataConKey sT_BASE SLIT("StateAndInt#")
 		alpha_tyvar [] [mkStatePrimTy alphaTy, intPrimTy]
 		stateAndIntPrimTyCon nullSpecEnv
 
 stateAndWordPrimTyCon
-  = pcDataTyCon stateAndWordPrimTyConKey gHC__ SLIT("StateAndWord#")
+  = pcDataTyCon stateAndWordPrimTyConKey sT_BASE SLIT("StateAndWord#")
 		alpha_tyvar [stateAndWordPrimDataCon]
 stateAndWordPrimDataCon
-  = pcDataCon stateAndWordPrimDataConKey gHC__ SLIT("StateAndWord#")
+  = pcDataCon stateAndWordPrimDataConKey sT_BASE SLIT("StateAndWord#")
 		alpha_tyvar [] [mkStatePrimTy alphaTy, wordPrimTy]
 		stateAndWordPrimTyCon nullSpecEnv
 
 stateAndAddrPrimTyCon
-  = pcDataTyCon stateAndAddrPrimTyConKey gHC__ SLIT("StateAndAddr#")
+  = pcDataTyCon stateAndAddrPrimTyConKey sT_BASE SLIT("StateAndAddr#")
 		alpha_tyvar [stateAndAddrPrimDataCon]
 stateAndAddrPrimDataCon
-  = pcDataCon stateAndAddrPrimDataConKey gHC__ SLIT("StateAndAddr#")
+  = pcDataCon stateAndAddrPrimDataConKey sT_BASE SLIT("StateAndAddr#")
 		alpha_tyvar [] [mkStatePrimTy alphaTy, addrPrimTy]
 		stateAndAddrPrimTyCon nullSpecEnv
 
 stateAndStablePtrPrimTyCon
-  = pcDataTyCon stateAndStablePtrPrimTyConKey gHC__ SLIT("StateAndStablePtr#")
+  = pcDataTyCon stateAndStablePtrPrimTyConKey fOREIGN SLIT("StateAndStablePtr#")
 		alpha_beta_tyvars [stateAndStablePtrPrimDataCon]
 stateAndStablePtrPrimDataCon
-  = pcDataCon stateAndStablePtrPrimDataConKey gHC__ SLIT("StateAndStablePtr#")
+  = pcDataCon stateAndStablePtrPrimDataConKey fOREIGN SLIT("StateAndStablePtr#")
 		alpha_beta_tyvars []
 		[mkStatePrimTy alphaTy, applyTyCon stablePtrPrimTyCon [betaTy]]
 		stateAndStablePtrPrimTyCon nullSpecEnv
 
 stateAndForeignObjPrimTyCon
-  = pcDataTyCon stateAndForeignObjPrimTyConKey gHC__ SLIT("StateAndForeignObj#")
+  = pcDataTyCon stateAndForeignObjPrimTyConKey fOREIGN SLIT("StateAndForeignObj#")
 		alpha_tyvar [stateAndForeignObjPrimDataCon]
 stateAndForeignObjPrimDataCon
-  = pcDataCon stateAndForeignObjPrimDataConKey gHC__ SLIT("StateAndForeignObj#")
+  = pcDataCon stateAndForeignObjPrimDataConKey fOREIGN SLIT("StateAndForeignObj#")
 		alpha_tyvar []
 		[mkStatePrimTy alphaTy, applyTyCon foreignObjPrimTyCon []]
 		stateAndForeignObjPrimTyCon nullSpecEnv
 
 stateAndFloatPrimTyCon
-  = pcDataTyCon stateAndFloatPrimTyConKey gHC__ SLIT("StateAndFloat#")
+  = pcDataTyCon stateAndFloatPrimTyConKey sT_BASE SLIT("StateAndFloat#")
 		alpha_tyvar [stateAndFloatPrimDataCon]
 stateAndFloatPrimDataCon
-  = pcDataCon stateAndFloatPrimDataConKey gHC__ SLIT("StateAndFloat#")
+  = pcDataCon stateAndFloatPrimDataConKey sT_BASE SLIT("StateAndFloat#")
 		alpha_tyvar [] [mkStatePrimTy alphaTy, floatPrimTy]
 		stateAndFloatPrimTyCon nullSpecEnv
 
 stateAndDoublePrimTyCon
-  = pcDataTyCon stateAndDoublePrimTyConKey gHC__ SLIT("StateAndDouble#")
+  = pcDataTyCon stateAndDoublePrimTyConKey sT_BASE SLIT("StateAndDouble#")
 		alpha_tyvar [stateAndDoublePrimDataCon]
 stateAndDoublePrimDataCon
-  = pcDataCon stateAndDoublePrimDataConKey gHC__ SLIT("StateAndDouble#")
+  = pcDataCon stateAndDoublePrimDataConKey sT_BASE SLIT("StateAndDouble#")
 		alpha_tyvar [] [mkStatePrimTy alphaTy, doublePrimTy]
 		stateAndDoublePrimTyCon nullSpecEnv
 \end{code}
 
 \begin{code}
 stateAndArrayPrimTyCon
-  = pcDataTyCon stateAndArrayPrimTyConKey gHC__ SLIT("StateAndArray#")
+  = pcDataTyCon stateAndArrayPrimTyConKey aRR_BASE SLIT("StateAndArray#")
 		alpha_beta_tyvars [stateAndArrayPrimDataCon]
 stateAndArrayPrimDataCon
-  = pcDataCon stateAndArrayPrimDataConKey gHC__ SLIT("StateAndArray#")
+  = pcDataCon stateAndArrayPrimDataConKey aRR_BASE SLIT("StateAndArray#")
 		alpha_beta_tyvars [] [mkStatePrimTy alphaTy, mkArrayPrimTy betaTy]
 		stateAndArrayPrimTyCon nullSpecEnv
 
 stateAndMutableArrayPrimTyCon
-  = pcDataTyCon stateAndMutableArrayPrimTyConKey gHC__ SLIT("StateAndMutableArray#")
+  = pcDataTyCon stateAndMutableArrayPrimTyConKey aRR_BASE SLIT("StateAndMutableArray#")
 		alpha_beta_tyvars [stateAndMutableArrayPrimDataCon]
 stateAndMutableArrayPrimDataCon
-  = pcDataCon stateAndMutableArrayPrimDataConKey gHC__ SLIT("StateAndMutableArray#")
+  = pcDataCon stateAndMutableArrayPrimDataConKey aRR_BASE SLIT("StateAndMutableArray#")
 		alpha_beta_tyvars [] [mkStatePrimTy alphaTy, mkMutableArrayPrimTy alphaTy betaTy]
 		stateAndMutableArrayPrimTyCon nullSpecEnv
 
 stateAndByteArrayPrimTyCon
-  = pcDataTyCon stateAndByteArrayPrimTyConKey gHC__ SLIT("StateAndByteArray#")
+  = pcDataTyCon stateAndByteArrayPrimTyConKey aRR_BASE SLIT("StateAndByteArray#")
 		alpha_tyvar [stateAndByteArrayPrimDataCon]
 stateAndByteArrayPrimDataCon
-  = pcDataCon stateAndByteArrayPrimDataConKey gHC__ SLIT("StateAndByteArray#")
+  = pcDataCon stateAndByteArrayPrimDataConKey aRR_BASE SLIT("StateAndByteArray#")
 		alpha_tyvar [] [mkStatePrimTy alphaTy, byteArrayPrimTy]
 		stateAndByteArrayPrimTyCon nullSpecEnv
 
 stateAndMutableByteArrayPrimTyCon
-  = pcDataTyCon stateAndMutableByteArrayPrimTyConKey gHC__ SLIT("StateAndMutableByteArray#")
+  = pcDataTyCon stateAndMutableByteArrayPrimTyConKey aRR_BASE SLIT("StateAndMutableByteArray#")
 		alpha_tyvar [stateAndMutableByteArrayPrimDataCon]
 stateAndMutableByteArrayPrimDataCon
-  = pcDataCon stateAndMutableByteArrayPrimDataConKey gHC__ SLIT("StateAndMutableByteArray#")
+  = pcDataCon stateAndMutableByteArrayPrimDataConKey aRR_BASE SLIT("StateAndMutableByteArray#")
 		alpha_tyvar [] [mkStatePrimTy alphaTy, applyTyCon mutableByteArrayPrimTyCon alpha_ty]
 		stateAndMutableByteArrayPrimTyCon nullSpecEnv
 
 stateAndSynchVarPrimTyCon
-  = pcDataTyCon stateAndSynchVarPrimTyConKey gHC__ SLIT("StateAndSynchVar#")
+  = pcDataTyCon stateAndSynchVarPrimTyConKey cONC_BASE SLIT("StateAndSynchVar#")
 		alpha_beta_tyvars [stateAndSynchVarPrimDataCon]
 stateAndSynchVarPrimDataCon
-  = pcDataCon stateAndSynchVarPrimDataConKey gHC__ SLIT("StateAndSynchVar#")
+  = pcDataCon stateAndSynchVarPrimDataConKey cONC_BASE SLIT("StateAndSynchVar#")
 		alpha_beta_tyvars [] [mkStatePrimTy alphaTy, mkSynchVarPrimTy alphaTy betaTy]
 		stateAndSynchVarPrimTyCon nullSpecEnv
 \end{code}
@@ -446,9 +491,9 @@ This is really just an ordinary synonym, except it is ABSTRACT.
 \begin{code}
 mkStateTransformerTy s a = applyTyCon stTyCon [s, a]
 
-stTyCon = pcNewTyCon stTyConKey gHC__ SLIT("ST") alpha_beta_tyvars [stDataCon]
+stTyCon = pcNewTyCon stTyConKey sT_BASE SLIT("ST") alpha_beta_tyvars [stDataCon]
 
-stDataCon = pcDataCon stDataConKey gHC__ SLIT("ST")
+stDataCon = pcDataCon stDataConKey sT_BASE SLIT("ST")
 			alpha_beta_tyvars [] [ty] stTyCon nullSpecEnv
   where
     ty = mkFunTy (mkStateTy alphaTy) (mkTupleTy 2 [betaTy, mkStateTy alphaTy])
@@ -465,7 +510,7 @@ mkPrimIoTy a = mkStateTransformerTy realWorldTy a
 
 primIoTyCon
   = pcSynTyCon
-     primIoTyConKey gHC__ SLIT("PrimIO")
+     primIoTyConKey iO_BASE SLIT("PrimIO")
      (mkBoxedTypeKind `mkArrowKind` mkBoxedTypeKind)
      1 alpha_tyvar (mkPrimIoTy alphaTy)
 \end{code}
@@ -521,10 +566,10 @@ primitive counterpart.
 \begin{code}
 boolTy = mkTyConTy boolTyCon
 
-boolTyCon = pcDataTyCon boolTyConKey pRELUDE SLIT("Bool") [] [falseDataCon, trueDataCon]
+boolTyCon = pcDataTyCon boolTyConKey pREL_BASE SLIT("Bool") [] [falseDataCon, trueDataCon]
 
-falseDataCon = pcDataCon falseDataConKey pRELUDE SLIT("False") [] [] [] boolTyCon nullSpecEnv
-trueDataCon  = pcDataCon trueDataConKey	 pRELUDE SLIT("True")  [] [] [] boolTyCon nullSpecEnv
+falseDataCon = pcDataCon falseDataConKey pREL_BASE SLIT("False") [] [] [] boolTyCon nullSpecEnv
+trueDataCon  = pcDataCon trueDataConKey	 pREL_BASE SLIT("True")  [] [] [] boolTyCon nullSpecEnv
 \end{code}
 
 %************************************************************************
@@ -548,12 +593,12 @@ mkListTy ty = applyTyCon listTyCon [ty]
 
 alphaListTy = mkSigmaTy alpha_tyvar [] (applyTyCon listTyCon alpha_ty)
 
-listTyCon = pcDataTyCon listTyConKey pRELUDE SLIT("[]") 
+listTyCon = pcDataTyCon listTyConKey pREL_BASE SLIT("[]") 
 			alpha_tyvar [nilDataCon, consDataCon]
 
-nilDataCon  = pcDataCon nilDataConKey  pRELUDE SLIT("[]") alpha_tyvar [] [] listTyCon
+nilDataCon  = pcDataCon nilDataConKey  pREL_BASE SLIT("[]") alpha_tyvar [] [] listTyCon
 		(pcGenerateDataSpecs alphaListTy)
-consDataCon = pcDataCon consDataConKey pRELUDE SLIT(":")
+consDataCon = pcDataCon consDataConKey pREL_BASE SLIT(":")
 		alpha_tyvar [] [alphaTy, applyTyCon listTyCon alpha_ty] listTyCon
 		(pcGenerateDataSpecs alphaListTy)
 -- Interesting: polymorphic recursion would help here.
@@ -610,7 +655,7 @@ done by enumeration\srcloc{lib/prelude/InTup?.hs}.
 \begin{code}
 mkTupleTy :: Int -> [GenType t u] -> GenType t u
 
-mkTupleTy arity tys = applyTyCon (mkTupleTyCon arity) tys
+mkTupleTy arity tys = applyTyCon (tupleTyCon arity) tys
 
 unitTy    = mkTupleTy 0 []
 \end{code}
@@ -644,10 +689,10 @@ isLiftTy ty
 alphaLiftTy = mkSigmaTy alpha_tyvar [] (applyTyCon liftTyCon alpha_ty)
 
 liftTyCon
-  = pcDataTyCon liftTyConKey gHC__ SLIT("Lift") alpha_tyvar [liftDataCon]
+  = pcDataTyCon liftTyConKey pREL_BASE SLIT("Lift") alpha_tyvar [liftDataCon]
 
 liftDataCon
-  = pcDataCon liftDataConKey gHC__ SLIT("Lift")
+  = pcDataCon liftDataConKey pREL_BASE SLIT("Lift")
 		alpha_tyvar [] alpha_ty liftTyCon
 		((pcGenerateDataSpecs alphaLiftTy) `addOneToSpecEnv`
 		 (mkSpecInfo [Just realWorldStatePrimTy] 0 bottom))
diff --git a/ghc/compiler/profiling/CostCentre.lhs b/ghc/compiler/profiling/CostCentre.lhs
index 635e2459de..bb2ede0448 100644
--- a/ghc/compiler/profiling/CostCentre.lhs
+++ b/ghc/compiler/profiling/CostCentre.lhs
@@ -32,7 +32,7 @@ IMP_Ubiq(){-uitous-}
 
 import Id		( externallyVisibleId, GenId, SYN_IE(Id) )
 import CStrings		( identToC, stringToC )
-import Name		( showRdr, getOccName, RdrName )
+import Name		( OccName, getOccString, moduleString )
 import Pretty		( ppShow, prettyToUn )
 import PprStyle		( PprStyle(..) )
 import UniqSet
@@ -393,7 +393,7 @@ uppCostCentre sty print_as_string cc
 	    basic_kind = do_caf is_caf ++ do_kind kind
 	in
 	if friendly_sty then
-	    do_dupd is_dupd (basic_kind ++ ('/': _UNPK_ mod_name) ++ ('/': _UNPK_ grp_name))
+	    do_dupd is_dupd (basic_kind ++ ('/': moduleString mod_name) ++ ('/': _UNPK_ grp_name))
 	else
 	    basic_kind
       where
@@ -407,8 +407,8 @@ uppCostCentre sty print_as_string cc
 	do_id :: Id -> String
 	do_id id
 	  = if print_as_string
-	    then showRdr sty (getOccName id)	-- use occ name
-	    else showId sty id	      		-- we really do
+	    then  getOccString id		-- use occ name
+	    else showId sty id	 		-- we really do
 
     ---------------
     do_dupd ADupdCC str = if friendly_sty then str ++ "/DUPD" else str
diff --git a/ghc/compiler/profiling/SCCfinal.lhs b/ghc/compiler/profiling/SCCfinal.lhs
index 89c4062197..24e0fb3a31 100644
--- a/ghc/compiler/profiling/SCCfinal.lhs
+++ b/ghc/compiler/profiling/SCCfinal.lhs
@@ -38,7 +38,7 @@ import CostCentre	-- lots of things
 import Id		( idType, mkSysLocal, emptyIdSet )
 import Maybes		( maybeToBool )
 import PprStyle		-- ToDo: rm
-import SrcLoc		( mkUnknownSrcLoc )
+import SrcLoc		( noSrcLoc )
 import Type		( splitSigmaTy, getFunTy_maybe )
 import UniqSupply	( getUnique, splitUniqSupply )
 import Util		( removeDups, assertPanic )
@@ -301,7 +301,7 @@ boxHigherOrderArgs almost_expr args live_vars
 	    -- make a trivial let-binding for the top-level function
 	    getUniqueMM		`thenMM` \ uniq ->
 	    let
-		new_var = mkSysLocal SLIT("ho") uniq var_type mkUnknownSrcLoc
+		new_var = mkSysLocal SLIT("ho") uniq var_type noSrcLoc
 	    in
 	    returnMM ( (new_var, old_var) : bindings, StgVarAtom new_var )
 	else
diff --git a/ghc/compiler/reader/PrefixSyn.lhs b/ghc/compiler/reader/PrefixSyn.lhs
index cd4d1b8b93..fdf9b11fab 100644
--- a/ghc/compiler/reader/PrefixSyn.lhs
+++ b/ghc/compiler/reader/PrefixSyn.lhs
@@ -55,7 +55,7 @@ data RdrBinding
 			-- tell if its a Sig or a ClassOpSig,
 			-- so we just save the pieces:
   | RdrTySig		[RdrName]	    -- vars getting sigs
-			RdrNamePolyType     -- the type
+			RdrNameHsType     -- the type
 			SrcLoc
 
   -- user pragmas come in in a Sig-ish way/form...
diff --git a/ghc/compiler/reader/PrefixToHs.lhs b/ghc/compiler/reader/PrefixToHs.lhs
index 2f229553f8..61da9a225a 100644
--- a/ghc/compiler/reader/PrefixToHs.lhs
+++ b/ghc/compiler/reader/PrefixToHs.lhs
@@ -12,12 +12,11 @@ module PrefixToHs (
 	cvValSig,
 	cvClassOpSig,
 	cvInstDeclSig,
+
 	cvBinds,
+	cvMonoBindsAndSigs,
 	cvMatches,
-	cvMonoBinds,
-	cvSepdBinds,
-	sepDeclsForTopBinds,
-	sepDeclsIntoSigsAndBinds
+	cvOtherDecls
     ) where
 
 IMP_Ubiq(){-uitous-}
@@ -27,7 +26,7 @@ import HsSyn
 import RdrHsSyn
 import HsPragmas	( noGenPragmas, noClassOpPragmas )
 
-import SrcLoc		( mkSrcLoc2 )
+import SrcLoc		( mkSrcLoc )
 import Util		( mapAndUnzip, panic, assertPanic )
 \end{code}
 
@@ -43,7 +42,7 @@ these conversion functions:
 cvValSig, cvClassOpSig, cvInstDeclSig :: SigConverter
 
 cvValSig (RdrTySig vars poly_ty src_loc)
-  = [ Sig v poly_ty noGenPragmas src_loc | v <- vars ]
+  = [ Sig v poly_ty src_loc | v <- vars ]
 
 cvClassOpSig (RdrTySig vars poly_ty src_loc)
   = [ ClassOpSig v poly_ty noClassOpPragmas src_loc | v <- vars ]
@@ -66,36 +65,22 @@ analyser.
 
 \begin{code}
 cvBinds :: SrcFile -> SigConverter -> RdrBinding -> RdrNameHsBinds
-cvBinds sf sig_cvtr raw_binding
-  = cvSepdBinds sf sig_cvtr (sepDeclsForBinds raw_binding)
-
-cvSepdBinds :: SrcFile -> SigConverter -> [RdrBinding] -> RdrNameHsBinds
-cvSepdBinds sf sig_cvtr bindings
-  = case (mkMonoBindsAndSigs sf sig_cvtr bindings) of { (mbs, sigs) ->
+cvBinds sf sig_cvtr binding
+  = case (cvMonoBindsAndSigs sf sig_cvtr binding) of { (mbs, sigs) ->
     if (null sigs)
     then SingleBind (RecBind mbs)
     else BindWith   (RecBind mbs) sigs
     }
-
-cvMonoBinds :: SrcFile -> [RdrBinding] -> RdrNameMonoBinds
-cvMonoBinds sf bindings
-  = case (mkMonoBindsAndSigs sf bottom bindings) of { (mbs,sigs) ->
-    if (null sigs)
-    then mbs
-    else panic "cvMonoBinds: some sigs present"
-    }
-  where
-    bottom = panic "cvMonoBinds: sig converter!"
 \end{code}
 
 \begin{code}
-mkMonoBindsAndSigs :: SrcFile
+cvMonoBindsAndSigs :: SrcFile
 		   -> SigConverter
-		   -> [RdrBinding]
+		   -> RdrBinding
 		   -> (RdrNameMonoBinds, [RdrNameSig])
 
-mkMonoBindsAndSigs sf sig_cvtr fbs
-  = foldl mangle_bind (EmptyMonoBinds, []) fbs
+cvMonoBindsAndSigs sf sig_cvtr fb
+  = mangle_bind (EmptyMonoBinds, []) fb
   where
     -- If the function being bound has at least one argument, then the
     -- guarded right hand sides of each pattern binding are knitted
@@ -105,6 +90,9 @@ mkMonoBindsAndSigs sf sig_cvtr fbs
     -- function. Otherwise there is only one pattern, which is paired
     -- with a guarded right hand side.
 
+    mangle_bind acc (RdrAndBindings fb1 fb2)
+      = mangle_bind (mangle_bind acc fb1) fb2
+
     mangle_bind (b_acc, s_acc) sig@(RdrTySig _ _ _)
       = (b_acc, s_acc ++ sig_cvtr sig)
 
@@ -118,7 +106,7 @@ mkMonoBindsAndSigs sf sig_cvtr fbs
       -- WDP: the parser has trouble getting a good line-number on RdrPatternBindings.
       = case (cvPatMonoBind sf patbinding) of { (pat, grhss, binds) ->
 	let
-	    src_loc = mkSrcLoc2 sf good_srcline
+	    src_loc = mkSrcLoc sf good_srcline
 	in
 	(b_acc `AndMonoBinds`
 	 PatMonoBind pat (GRHSsAndBindsIn grhss binds) src_loc, s_acc)
@@ -136,15 +124,17 @@ mkMonoBindsAndSigs sf sig_cvtr fbs
 	    -- must be a function binding...
       = case (cvFunMonoBind sf patbindings) of { (var, inf, matches) ->
 	(b_acc `AndMonoBinds`
-	 FunMonoBind var inf matches (mkSrcLoc2 sf srcline), s_acc)
+	 FunMonoBind var inf matches (mkSrcLoc sf srcline), s_acc)
 	}
+
+    mangle_bind (b_acc, s_acc) other = (b_acc, s_acc)
 \end{code}
 
 \begin{code}
 cvPatMonoBind :: SrcFile -> RdrMatch -> (RdrNamePat, [RdrNameGRHS], RdrNameHsBinds)
 
 cvPatMonoBind sf (RdrMatch_NoGuard srcline srcfun pat expr binding)
-  = (pat, [OtherwiseGRHS expr (mkSrcLoc2 sf srcline)], cvBinds sf cvValSig binding)
+  = (pat, [OtherwiseGRHS expr (mkSrcLoc sf srcline)], cvBinds sf cvValSig binding)
 
 cvPatMonoBind sf (RdrMatch_Guards srcline srcfun pat guardedexprs binding)
   = (pat, map (cvGRHS sf srcline) guardedexprs, cvBinds sf cvValSig binding)
@@ -189,11 +179,11 @@ cvMatch sf is_case rdr_match
   where
     (pat, binding, guarded_exprs)
       = case rdr_match of
-	  RdrMatch_NoGuard ln b c expr    d -> (c,d, [OtherwiseGRHS expr (mkSrcLoc2 sf ln)])
+	  RdrMatch_NoGuard ln b c expr    d -> (c,d, [OtherwiseGRHS expr (mkSrcLoc sf ln)])
 	  RdrMatch_Guards  ln b c gd_exps d -> (c,d, map (cvGRHS sf ln) gd_exps)
 
 cvGRHS :: SrcFile -> SrcLine -> (RdrNameHsExpr, RdrNameHsExpr) -> RdrNameGRHS
-cvGRHS sf sl (g, e) = GRHS g e (mkSrcLoc2 sf sl)
+cvGRHS sf sl (g, e) = GRHS g e (mkSrcLoc sf sl)
 \end{code}
 
 %************************************************************************
@@ -203,117 +193,16 @@ cvGRHS sf sl (g, e) = GRHS g e (mkSrcLoc2 sf sl)
 %************************************************************************
 
 Separate declarations into all the various kinds:
-\begin{display}
-tys		RdrTyDecl
-ty "sigs" 	RdrSpecDataSig
-classes		RdrClassDecl
-insts		RdrInstDecl
-inst "sigs" 	RdrSpecInstSig
-defaults	RdrDefaultDecl
-binds		RdrFunctionBinding RdrPatternBinding RdrTySig
-		RdrSpecValSig RdrInlineValSig RdrDeforestSig
-		RdrMagicUnfoldingSig
-\end{display}
-
-This function isn't called directly; some other function calls it,
-then checks that what it got is appropriate for that situation.
-(Those functions follow...)
-
-\begin{code}
-sepDecls (RdrTyDecl a)
-	 tys tysigs classes insts instsigs defaults binds
- = (a:tys,tysigs,classes,insts,instsigs,defaults,binds)
-
-sepDecls a@(RdrFunctionBinding _ _)
-	 tys tysigs classes insts instsigs defaults binds
- = (tys,tysigs,classes,insts,instsigs,defaults,a:binds)
-
-sepDecls a@(RdrPatternBinding _ _)
-	 tys tysigs classes insts instsigs defaults binds
- = (tys,tysigs,classes,insts,instsigs,defaults,a:binds)
-
--- RdrAndBindings catered for below...
-
-sepDecls (RdrClassDecl a)
-	 tys tysigs classes insts instsigs defaults binds
-  = (tys,tysigs,a:classes,insts,instsigs,defaults,binds)
-
-sepDecls (RdrInstDecl a)
-	 tys tysigs classes insts instsigs defaults binds
-  = (tys,tysigs,classes,a:insts,instsigs,defaults,binds)
-
-sepDecls (RdrDefaultDecl a)
-	 tys tysigs classes insts instsigs defaults binds
-  = (tys,tysigs,classes,insts,instsigs,a:defaults,binds)
-
-sepDecls a@(RdrTySig _ _ _)
-	 tys tysigs classes insts instsigs defaults binds
-  = (tys,tysigs,classes,insts,instsigs,defaults,a:binds)
-
-sepDecls a@(RdrSpecValSig _)
-	 tys tysigs classes insts instsigs defaults binds
-  = (tys,tysigs,classes,insts,instsigs,defaults,a:binds)
-
-sepDecls a@(RdrInlineValSig _)
-	 tys tysigs classes insts instsigs defaults binds
-  = (tys,tysigs,classes,insts,instsigs,defaults,a:binds)
-
-sepDecls a@(RdrDeforestSig _)
-	 tys tysigs classes insts instsigs defaults binds
-  = (tys,tysigs,classes,insts,instsigs,defaults,a:binds)
-
-sepDecls a@(RdrMagicUnfoldingSig _)
-	 tys tysigs classes insts instsigs defaults binds
-  = (tys,tysigs,classes,insts,instsigs,defaults,a:binds)
-
-sepDecls (RdrSpecInstSig a)
-	 tys tysigs classes insts instsigs defaults binds
-  = (tys,tysigs,classes,insts,a:instsigs,defaults,binds)
-
-sepDecls (RdrSpecDataSig a)
-	 tys tysigs classes insts instsigs defaults binds
-  = (tys,a:tysigs,classes,insts,instsigs,defaults,binds)
-
-sepDecls RdrNullBind
-	 tys tysigs classes insts instsigs defaults binds
-  = (tys,tysigs,classes,insts,instsigs,defaults,binds)
-
-sepDecls (RdrAndBindings bs1 bs2)
-	 tys tysigs classes insts instsigs defaults binds
-  = case (sepDecls bs2 tys tysigs classes insts instsigs defaults binds) of {
-      (tys,tysigs,classes,insts,instsigs,defaults,binds) ->
-	  sepDecls bs1 tys tysigs classes insts instsigs defaults binds
-    }
-\end{code}
 
 \begin{code}
-sepDeclsForTopBinds binding
-  = sepDecls binding [] [] [] [] [] [] []
-
-sepDeclsForBinds binding
-  = case (sepDecls binding [] [] [] [] [] [] [])
-	of { (tys,tysigs,classes,insts,instsigs,defaults,binds) ->
-    ASSERT ((null tys)
-	 && (null tysigs)
-	 && (null classes)
-	 && (null insts)
-	 && (null instsigs)
-	 && (null defaults))
-    binds
-    }
-
-sepDeclsIntoSigsAndBinds binding
-  = case (sepDeclsForBinds binding) of { sigs_and_binds ->
-    foldr sep_stuff ([],[]) sigs_and_binds
-    }
+cvOtherDecls :: RdrBinding -> [RdrNameHsDecl]
+cvOtherDecls b 
+  = go [] b
   where
-    sep_stuff s@(RdrTySig _ _ _)         (sigs,defs) = (s:sigs,defs)
-    sep_stuff s@(RdrSpecValSig _)        (sigs,defs) = (s:sigs,defs)
-    sep_stuff s@(RdrInlineValSig _)      (sigs,defs) = (s:sigs,defs)
-    sep_stuff s@(RdrDeforestSig  _)      (sigs,defs) = (s:sigs,defs)
-    sep_stuff s@(RdrMagicUnfoldingSig _) (sigs,defs) = (s:sigs,defs)
-    sep_stuff d@(RdrFunctionBinding _ _) (sigs,defs) = (sigs,d:defs)
-    sep_stuff d@(RdrPatternBinding  _ _) (sigs,defs) = (sigs,d:defs)
-
-
+    go acc (RdrAndBindings b1 b2) = go (go acc b1) b2
+    go acc (RdrTyDecl d)	  = TyD d   : acc
+    go acc (RdrClassDecl d)	  = ClD d   : acc
+    go acc (RdrInstDecl d)	  = InstD d : acc 
+    go acc (RdrDefaultDecl d)     = DefD d  : acc
+    go acc other		  = acc
 \end{code}
diff --git a/ghc/compiler/reader/RdrHsSyn.lhs b/ghc/compiler/reader/RdrHsSyn.lhs
index 7b44b5986a..bd2f8e4a06 100644
--- a/ghc/compiler/reader/RdrHsSyn.lhs
+++ b/ghc/compiler/reader/RdrHsSyn.lhs
@@ -23,6 +23,7 @@ module RdrHsSyn (
 	SYN_IE(RdrNameGRHS),
 	SYN_IE(RdrNameGRHSsAndBinds),
 	SYN_IE(RdrNameHsBinds),
+	SYN_IE(RdrNameHsDecl),
 	SYN_IE(RdrNameHsExpr),
 	SYN_IE(RdrNameHsModule),
 	SYN_IE(RdrNameIE),
@@ -30,9 +31,8 @@ module RdrHsSyn (
 	SYN_IE(RdrNameInstDecl),
 	SYN_IE(RdrNameMatch),
 	SYN_IE(RdrNameMonoBinds),
-	SYN_IE(RdrNameMonoType),
 	SYN_IE(RdrNamePat),
-	SYN_IE(RdrNamePolyType),
+	SYN_IE(RdrNameHsType),
 	SYN_IE(RdrNameQual),
 	SYN_IE(RdrNameSig),
 	SYN_IE(RdrNameSpecInstSig),
@@ -45,15 +45,27 @@ module RdrHsSyn (
 	SYN_IE(RdrNameGenPragmas),
 	SYN_IE(RdrNameInstancePragmas),
 	SYN_IE(RdrNameCoreExpr),
+	extractHsTyVars,
+
+	RdrName(..),
+	qual, varQual, tcQual, varUnqual,
+	dummyRdrVarName, dummyRdrTcName,
+	isUnqual, isQual,
+	showRdr, rdrNameOcc,
+	cmpRdr
 
-	getRawImportees,
-	getRawExportees
     ) where
 
 IMP_Ubiq()
 
 import HsSyn
-import Name		( ExportFlag(..) )
+import Lex
+import PrelMods		( pRELUDE )
+import Name		( ExportFlag(..), Module(..), pprModule,
+			  OccName(..), pprOccName )
+import Pretty		
+import PprStyle		( PprStyle(..) )
+import Util		( cmpPString, panic, thenCmp )
 \end{code}
 
 \begin{code}
@@ -64,6 +76,7 @@ type RdrNameClassDecl		= ClassDecl		Fake Fake RdrName RdrNamePat
 type RdrNameClassOpSig		= Sig			RdrName
 type RdrNameConDecl		= ConDecl		RdrName
 type RdrNameContext		= Context 		RdrName
+type RdrNameHsDecl		= HsDecl		Fake Fake RdrName RdrNamePat
 type RdrNameSpecDataSig		= SpecDataSig		RdrName
 type RdrNameDefaultDecl		= DefaultDecl		RdrName
 type RdrNameFixityDecl		= FixityDecl		RdrName
@@ -77,9 +90,8 @@ type RdrNameImportDecl 		= ImportDecl		RdrName
 type RdrNameInstDecl		= InstDecl		Fake Fake RdrName RdrNamePat
 type RdrNameMatch		= Match			Fake Fake RdrName RdrNamePat
 type RdrNameMonoBinds		= MonoBinds		Fake Fake RdrName RdrNamePat
-type RdrNameMonoType		= MonoType		RdrName
 type RdrNamePat			= InPat			RdrName
-type RdrNamePolyType		= PolyType		RdrName
+type RdrNameHsType		= HsType		RdrName
 type RdrNameQual		= Qualifier		Fake Fake RdrName RdrNamePat
 type RdrNameSig			= Sig			RdrName
 type RdrNameSpecInstSig		= SpecInstSig 		RdrName
@@ -91,34 +103,101 @@ type RdrNameClassPragmas	= ClassPragmas		RdrName
 type RdrNameDataPragmas		= DataPragmas		RdrName
 type RdrNameGenPragmas		= GenPragmas		RdrName
 type RdrNameInstancePragmas	= InstancePragmas	RdrName
-type RdrNameCoreExpr		= UnfoldingCoreExpr	RdrName
+type RdrNameCoreExpr		= GenCoreExpr		RdrName RdrName RdrName RdrName 
+\end{code}
+
+@extractHsTyVars@ looks just for things that could be type variables.
+It's used when making the for-alls explicit.
+
+\begin{code}
+extractHsTyVars :: HsType RdrName -> [RdrName]
+extractHsTyVars ty
+  = get ty []
+  where
+    get (MonoTyApp con tys)	 acc = foldr get (insert con acc) tys
+    get (MonoListTy tc ty)	 acc = get ty acc
+    get (MonoTupleTy tc tys)	 acc = foldr get acc tys
+    get (MonoFunTy ty1 ty2)	 acc = get ty1 (get ty2 acc)
+    get (MonoDictTy cls ty)	 acc = get ty acc
+    get (MonoTyVar tv) 	         acc = insert tv acc
+    get (HsPreForAllTy ctxt ty)  acc = foldr (get . snd) (get ty acc) ctxt
+    get (HsForAllTy tvs ctxt ty) acc = filter (`notElem` locals) $
+				       foldr (get . snd) (get ty acc) ctxt
+				     where
+				       locals = map getTyVarName tvs
+
+    insert (Qual _ _)	      acc = acc
+    insert (Unqual (TCOcc _)) acc = acc
+    insert other 	      acc | other `elem` acc = acc
+				  | otherwise	     = other : acc
 \end{code}
 
+   
 %************************************************************************
 %*									*
-\subsection{Grabbing importees and exportees}
+\subsection[RdrName]{The @RdrName@ datatype; names read from files}
 %*									*
 %************************************************************************
 
 \begin{code}
-getRawImportees :: [RdrNameIE] ->  [RdrName]
-getRawExportees :: Maybe [RdrNameIE] -> ([(RdrName, ExportFlag)], [Module])
+data RdrName
+  = Unqual OccName
+  | Qual   Module OccName
 
-getRawImportees imps
-  = foldr do_imp [] imps
-  where
-    do_imp (IEVar n)	     acc = n:acc
-    do_imp (IEThingAbs  n)   acc = n:acc
-    do_imp (IEThingWith n _) acc = n:acc
-    do_imp (IEThingAll  n)   acc = n:acc
-
-getRawExportees Nothing     = ([], [])
-getRawExportees (Just exps)
-  = foldr do_exp ([],[]) exps
-  where
-    do_exp (IEVar n)		(prs, mods) = ((n, ExportAll):prs, mods)
-    do_exp (IEThingAbs n)	(prs, mods) = ((n, ExportAbs):prs, mods)
-    do_exp (IEThingAll n)	(prs, mods) = ((n, ExportAll):prs, mods)
-    do_exp (IEThingWith n _)	(prs, mods) = ((n, ExportAll):prs, mods)
-    do_exp (IEModuleContents n) (prs, mods) = (prs, n : mods)
+qual     (m,n) = Qual m n
+tcQual   (m,n) = Qual m (TCOcc n)
+varQual  (m,n) = Qual m (VarOcc n)
+
+	-- This guy is used by the reader when HsSyn has a slot for
+	-- an implicit name that's going to be filled in by
+	-- the renamer.  We can't just put "error..." because
+	-- we sometimes want to print out stuff after reading but
+	-- before renaming
+dummyRdrVarName = Unqual (VarOcc SLIT("V-DUMMY"))
+dummyRdrTcName = Unqual (VarOcc SLIT("TC-DUMMY"))
+
+varUnqual n = Unqual (VarOcc n)
+
+isUnqual (Unqual _) = True
+isUnqual (Qual _ _) = False
+
+isQual (Unqual _) = False
+isQual (Qual _ _) = True
+
+cmpRdr (Unqual  n1) (Unqual  n2) = n1 `cmp` n2
+cmpRdr (Unqual  n1) (Qual m2 n2) = LT_
+cmpRdr (Qual m1 n1) (Unqual  n2) = GT_
+cmpRdr (Qual m1 n1) (Qual m2 n2) = (n1 `cmp` n2) `thenCmp` (_CMP_STRING_ m1 m2)
+				   -- always compare module-names *second*
+
+rdrNameOcc :: RdrName -> OccName
+rdrNameOcc (Unqual occ) = occ
+rdrNameOcc (Qual _ occ) = occ
+
+instance Text RdrName where -- debugging
+    showsPrec _ rn = showString (ppShow 80 (ppr PprDebug rn))
+
+instance Eq RdrName where
+    a == b = case (a `cmp` b) of { EQ_ -> True;  _ -> False }
+    a /= b = case (a `cmp` b) of { EQ_ -> False; _ -> True }
+
+instance Ord RdrName where
+    a <= b = case (a `cmp` b) of { LT_ -> True;	 EQ_ -> True;  GT__ -> False }
+    a <	 b = case (a `cmp` b) of { LT_ -> True;	 EQ_ -> False; GT__ -> False }
+    a >= b = case (a `cmp` b) of { LT_ -> False; EQ_ -> True;  GT__ -> True  }
+    a >	 b = case (a `cmp` b) of { LT_ -> False; EQ_ -> False; GT__ -> True  }
+
+instance Ord3 RdrName where
+    cmp = cmpRdr
+
+instance Outputable RdrName where
+    ppr sty (Unqual n) = pprOccName sty n
+    ppr sty (Qual m n) = ppBesides [pprModule sty m, ppStr ".", pprOccName sty n]
+
+instance NamedThing RdrName where		-- Just so that pretty-printing of expressions works
+    getOccName = rdrNameOcc
+    getName = panic "no getName for RdrNames"
+
+showRdr sty rdr = ppShow 100 (ppr sty rdr)
 \end{code}
+
diff --git a/ghc/compiler/reader/ReadPrefix.lhs b/ghc/compiler/reader/ReadPrefix.lhs
index 90732706f1..2d10052b0b 100644
--- a/ghc/compiler/reader/ReadPrefix.lhs
+++ b/ghc/compiler/reader/ReadPrefix.lhs
@@ -15,17 +15,19 @@ IMPORT_1_3(GHCio(stThen))
 import UgenAll		-- all Yacc parser gumpff...
 import PrefixSyn	-- and various syntaxen.
 import HsSyn
+import HsTypes		( HsTyVar(..) )
 import HsPragmas	( noDataPragmas, noClassPragmas, noInstancePragmas, noGenPragmas )
 import RdrHsSyn
 import PrefixToHs
 
 import ErrUtils		( addErrLoc, ghcExit )
 import FiniteMap	( elemFM, FiniteMap )
-import Name		( RdrName(..), isRdrLexConOrSpecial, preludeQual )
+import Name		( RdrName(..), OccName(..) )
+import Lex		( isLexConId )
 import PprStyle		( PprStyle(..) )
-import PrelMods		( pRELUDE )
+import PrelMods
 import Pretty
-import SrcLoc		( mkBuiltinSrcLoc, SrcLoc )
+import SrcLoc		( mkGeneratedSrcLoc, noSrcLoc, SrcLoc )
 import Util		( nOfThem, pprError, panic )
 \end{code}
 
@@ -56,16 +58,26 @@ wlkMaybe wlk_it (U_just x)
 \end{code}
 
 \begin{code}
-rdQid   :: ParseTree -> UgnM RdrName
-rdQid pt = rdU_qid pt `thenUgn` \ qid -> wlkQid qid
-
-wlkQid	:: U_qid -> UgnM RdrName
-wlkQid (U_noqual name)
-  = returnUgn (Unqual name)
-wlkQid (U_aqual  mod name)
-  = returnUgn (Qual mod name)
-wlkQid (U_gid n name)
-  = returnUgn (preludeQual name)
+wlkTvId   = wlkQid TvOcc
+wlkTCId   = wlkQid TCOcc
+wlkVarId  = wlkQid VarOcc
+wlkDataId = wlkQid VarOcc
+wlkEntId = wlkQid (\occ -> if isLexConId occ
+			   then TCOcc occ
+			   else VarOcc occ)
+
+wlkQid	:: (FAST_STRING -> OccName) -> U_qid -> UgnM RdrName
+wlkQid mk_occ_name (U_noqual name)
+  = returnUgn (Unqual (mk_occ_name name))
+wlkQid mk_occ_name (U_aqual  mod name)
+  = returnUgn (Qual mod (mk_occ_name name))
+
+	-- I don't understand this one!  It is what shows up when we meet (), [], or (,,,).
+wlkQid mk_occ_name (U_gid n name)
+  = returnUgn (Unqual (mk_occ_name name))
+
+rdTCId  pt = rdU_qid pt `thenUgn` \ qid -> wlkTCId qid
+rdVarId pt = rdU_qid pt `thenUgn` \ qid -> wlkVarId qid
 
 cvFlag :: U_long -> Bool
 cvFlag 0 = False
@@ -108,36 +120,30 @@ rdModule
     wlkList  rdFixOp	hfixlist `thenUgn` \ fixities 	->
     wlkBinding		hmodlist `thenUgn` \ binding	->
 
-    case sepDeclsForTopBinds binding of
-    (tydecls, tysigs, classdecls, instdecls, instsigs, defaultdecls, binds) ->
-
-      returnUgn (modname,
-       		 HsModule modname
+    let
+	val_decl    = ValD (add_main_sig modname (cvBinds srcfile cvValSig binding))
+	other_decls = cvOtherDecls binding
+    in
+    returnUgn (modname,
+       	       HsModule modname
 	      		  (case srciface_version of { 0 -> Nothing; n -> Just n })
 	      		  exports
 	      		  imports
 	      		  fixities
-	      		  tydecls
-			  tysigs
-	      		  classdecls
-	      		  instdecls
-	      		  instsigs
-	      		  defaultdecls
-			  (add_main_sig modname (cvSepdBinds srcfile cvValSig binds))
-	      		  [{-no interface sigs yet-}]
+			  (val_decl: other_decls)
 	      		  src_loc
        		)
   where
     add_main_sig modname binds
-      = if modname == SLIT("Main") then
+      = if modname == mAIN then
 	    let
-	       s = Sig (Unqual SLIT("main")) (io_ty SLIT("IO")) noGenPragmas mkBuiltinSrcLoc
+	       s = Sig (varUnqual SLIT("main")) (io_ty SLIT("IO")) mkGeneratedSrcLoc
 	    in
 	    add_sig binds s
 
-	else if modname == SLIT("GHCmain") then
+	else if modname == gHC_MAIN then
 	    let
-	       s = Sig (Unqual SLIT("mainPrimIO")) (io_ty SLIT("PrimIO")) noGenPragmas mkBuiltinSrcLoc
+	       s = Sig (varUnqual SLIT("mainPrimIO")) (io_ty SLIT("PrimIO"))  mkGeneratedSrcLoc
 	    in
 	    add_sig binds s
 
@@ -148,7 +154,7 @@ rdModule
 	add_sig (BindWith b ss) s = BindWith b (s:ss)
 	add_sig _		_ = panic "rdModule:add_sig"
 
-	io_ty t = HsForAllTy [] [] (MonoTyApp (Unqual t) [MonoTupleTy []])
+	io_ty t = MonoTyApp (Unqual (TCOcc t)) [MonoTupleTy dummyRdrTcName []]
 \end{code}
 
 %************************************************************************
@@ -175,11 +181,11 @@ wlkExpr expr
 
       U_lsection lsexp lop -> -- left section
 	wlkExpr lsexp	`thenUgn` \ expr ->
-	wlkQid  lop	`thenUgn` \ op   ->
+	wlkVarId  lop	`thenUgn` \ op   ->
 	returnUgn (SectionL expr (HsVar op))
 
       U_rsection rop rsexp -> -- right section
-	wlkQid  rop	`thenUgn` \ op   ->
+	wlkVarId  rop	`thenUgn` \ op   ->
 	wlkExpr rsexp	`thenUgn` \ expr ->
 	returnUgn (SectionR (HsVar op) expr)
 
@@ -303,7 +309,7 @@ wlkExpr expr
 
       U_restr restre restrt -> 	-- expression with type signature
 	wlkExpr	    restre	`thenUgn` \ expr ->
-	wlkPolyType restrt	`thenUgn` \ ty	 ->
+	wlkHsType restrt	`thenUgn` \ ty	 ->
 	returnUgn (ExprWithTySig expr ty)
 
       --------------------------------------------------------------
@@ -317,7 +323,7 @@ wlkExpr expr
 	returnUgn (HsLit lit)
 
       U_ident n -> 			-- simple identifier
-	wlkQid n	`thenUgn` \ var ->
+	wlkVarId n	`thenUgn` \ var ->
 	returnUgn (HsVar var)
 
       U_ap fun arg -> 			-- application
@@ -326,18 +332,14 @@ wlkExpr expr
 	returnUgn (HsApp expr1 expr2)
 
       U_infixap fun arg1 arg2 ->	-- infix application
-	wlkQid  fun	`thenUgn` \ op    ->
+	wlkVarId  fun	`thenUgn` \ op    ->
 	wlkExpr arg1	`thenUgn` \ expr1 ->
 	wlkExpr arg2	`thenUgn` \ expr2 ->
 	returnUgn (OpApp expr1 (HsVar op) expr2)
 
       U_negate nexp ->	 		-- prefix negation
 	wlkExpr nexp	`thenUgn` \ expr ->
-	-- this is a hack
-	let
-	    rdr = preludeQual SLIT("negate")
-	in
-	returnUgn (NegApp expr (HsVar rdr))
+	returnUgn (NegApp expr (HsVar dummyRdrVarName))
 
       U_llist llist -> -- explicit list
 	wlkList rdExpr llist `thenUgn` \ exprs ->
@@ -348,7 +350,7 @@ wlkExpr expr
 	returnUgn (ExplicitTuple exprs)
 
       U_record con rbinds -> -- record construction
-	wlkQid  con		`thenUgn` \ rcon     ->
+	wlkDataId  con		`thenUgn` \ rcon     ->
 	wlkList rdRbind rbinds	`thenUgn` \ recbinds ->
 	returnUgn (RecordCon (HsVar rcon) recbinds)
 
@@ -373,7 +375,7 @@ wlkExpr expr
 
 rdRbind pt
   = rdU_tree pt		`thenUgn` \ (U_rbind var exp) ->
-    wlkQid   var	`thenUgn` \ rvar ->
+    wlkVarId   var	`thenUgn` \ rvar ->
     wlkMaybe rdExpr exp	`thenUgn` \ expr_maybe ->
     returnUgn (
       case expr_maybe of
@@ -398,7 +400,7 @@ wlkPat pat
 	)
 
       U_as avar as_pat -> 		-- "as" pattern
-	wlkQid avar	`thenUgn` \ var ->
+	wlkVarId avar	`thenUgn` \ var ->
 	wlkPat as_pat	`thenUgn` \ pat ->
 	returnUgn (AsPatIn var pat)
 
@@ -413,11 +415,11 @@ wlkPat pat
 	returnUgn (LitPatIn lit)
 
       U_ident nn ->			-- simple identifier
-	wlkQid nn	`thenUgn` \ n ->
+	wlkVarId nn	`thenUgn` \ n ->
 	returnUgn (
-	  if isRdrLexConOrSpecial n
-	  then ConPatIn n []
-	  else VarPatIn n
+	  case rdrNameOcc n of
+		VarOcc occ | isLexConId occ -> ConPatIn n []
+		other     		    -> VarPatIn n
 	)
 
       U_ap l r ->	-- "application": there's a list of patterns lurking here!
@@ -455,7 +457,7 @@ wlkPat pat
 		  returnUgn (pat,acc)
 
       U_infixap fun arg1 arg2 ->	-- infix pattern
-	wlkQid fun	`thenUgn` \ op   ->
+	wlkVarId fun	`thenUgn` \ op   ->
 	wlkPat arg1	`thenUgn` \ pat1 ->
 	wlkPat arg2	`thenUgn` \ pat2 ->
 	returnUgn (ConOpPatIn pat1 op pat2)
@@ -473,13 +475,13 @@ wlkPat pat
 	returnUgn (TuplePatIn pats)
 
       U_record con rpats -> 		-- record destruction
-	wlkQid  con		`thenUgn` \ rcon     ->
+	wlkDataId  con		`thenUgn` \ rcon     ->
 	wlkList rdRpat rpats	`thenUgn` \ recpats ->
 	returnUgn (RecPatIn rcon recpats)
 	where
 	  rdRpat pt
 	    = rdU_tree pt	 `thenUgn` \ (U_rbind var pat) ->
-    	      wlkQid   var	 `thenUgn` \ rvar ->
+    	      wlkVarId   var	 `thenUgn` \ rvar ->
     	      wlkMaybe rdPat pat `thenUgn` \ pat_maybe ->
 	      returnUgn (
 		case pat_maybe of
@@ -551,7 +553,7 @@ wlkBinding binding
 	mkSrcLocUgn	   srcline  	    $ \ src_loc	    ->
 	wlkContext	   ntctxt   `thenUgn` \ ctxt	    ->
 	wlkTyConAndTyVars  nttype   `thenUgn` \ (tycon, tyvars) ->
-	wlkList rdConDecl  ntcon    `thenUgn` \ con	    ->
+	wlkList rdConDecl  ntcon    `thenUgn` \ [con]	    ->
 	wlkDerivings	   ntderivs `thenUgn` \ derivings   ->
 	returnUgn (RdrTyDecl (TyNew ctxt tycon tyvars con derivings noDataPragmas src_loc))
 
@@ -582,10 +584,7 @@ wlkBinding binding
 	wlkBinding	 cbindw	 `thenUgn` \ binding	  ->
 	getSrcFileUgn		 `thenUgn` \ sf		  ->
 	let
-	    (class_sigs, class_methods) = sepDeclsIntoSigsAndBinds binding
-
-	    final_sigs    = concat (map cvClassOpSig class_sigs)
-	    final_methods = cvMonoBinds sf class_methods
+	    (final_methods, final_sigs) = cvMonoBindsAndSigs sf cvClassOpSig binding
 	in
 	returnUgn (RdrClassDecl
 	  (ClassDecl ctxt clas tyvar final_sigs final_methods noClassPragmas src_loc))
@@ -594,19 +593,17 @@ wlkBinding binding
       U_ibind ibindc iclas ibindi ibindw srcline ->
 	mkSrcLocUgn	srcline		$ \ src_loc ->
 	wlkContext	ibindc	`thenUgn` \ ctxt    ->
-	wlkQid		iclas	`thenUgn` \ clas    ->
-	wlkMonoType	ibindi	`thenUgn` \ inst_ty ->
+	wlkTCId		iclas	`thenUgn` \ clas    ->
+	wlkMonoType	ibindi	`thenUgn` \ at_ty ->
 	wlkBinding	ibindw	`thenUgn` \ binding ->
 	getSrcModUgn		`thenUgn` \ modname ->
 	getSrcFileUgn		`thenUgn` \ sf	    ->
 	let
-	    (ss, bs)  = sepDeclsIntoSigsAndBinds binding
-	    binds     = cvMonoBinds sf bs
-	    uprags    = concat (map cvInstDeclSig ss)
-	    ctxt_inst_ty = HsPreForAllTy ctxt inst_ty
+	    (binds,uprags) = cvMonoBindsAndSigs sf cvInstDeclSig binding
+	    inst_ty = HsPreForAllTy ctxt (MonoDictTy clas at_ty)
 	in
 	returnUgn (RdrInstDecl
-          (InstDecl clas ctxt_inst_ty binds True{-from here-} modname uprags noInstancePragmas src_loc))
+          (InstDecl inst_ty binds uprags Nothing {- No dfun id -} src_loc))
 
 	-- "default" declaration
       U_dbind dbindts srcline ->
@@ -625,7 +622,7 @@ wlkDerivings :: U_maybe -> UgnM (Maybe [RdrName])
 wlkDerivings (U_nothing) = returnUgn Nothing
 wlkDerivings (U_just pt)
   = rdU_list pt		 `thenUgn` \ ds	    ->
-    wlkList rdQid ds	 `thenUgn` \ derivs ->
+    wlkList rdTCId ds	 `thenUgn` \ derivs ->
     returnUgn (Just derivs)
 \end{code}
 
@@ -633,55 +630,55 @@ wlkDerivings (U_just pt)
 	-- type signature
 wlk_sig_thing (U_sbind sbindids sbindid srcline)
   = mkSrcLocUgn		srcline  	$ \ src_loc ->
-    wlkList rdQid	sbindids `thenUgn` \ vars    ->
-    wlkPolyType		sbindid  `thenUgn` \ poly_ty ->
+    wlkList rdVarId	sbindids `thenUgn` \ vars    ->
+    wlkHsType		sbindid  `thenUgn` \ poly_ty ->
     returnUgn (RdrTySig vars poly_ty src_loc)
 
 	-- value specialisation user-pragma
 wlk_sig_thing (U_vspec_uprag uvar vspec_tys srcline)
   = mkSrcLocUgn	srcline		    	    $ \ src_loc ->
-    wlkQid  uvar		    `thenUgn` \ var ->
+    wlkVarId  uvar		    `thenUgn` \ var ->
     wlkList rd_ty_and_id vspec_tys  `thenUgn` \ tys_and_ids ->
     returnUgn (RdrSpecValSig [SpecSig var ty using_id src_loc
 			     | (ty, using_id) <- tys_and_ids ])
   where
-    rd_ty_and_id :: ParseTree -> UgnM (RdrNamePolyType, Maybe RdrName)
+    rd_ty_and_id :: ParseTree -> UgnM (RdrNameHsType, Maybe RdrName)
     rd_ty_and_id pt
       = rdU_binding pt		`thenUgn` \ (U_vspec_ty_and_id vspec_ty vspec_id) ->
-	wlkPolyType vspec_ty	`thenUgn` \ ty	     ->
-	wlkMaybe rdQid vspec_id	`thenUgn` \ id_maybe ->
+	wlkHsType vspec_ty	`thenUgn` \ ty	     ->
+	wlkMaybe rdVarId vspec_id	`thenUgn` \ id_maybe ->
 	returnUgn(ty, id_maybe)
 
 	-- instance specialisation user-pragma
 wlk_sig_thing (U_ispec_uprag iclas ispec_ty srcline)
   = mkSrcLocUgn srcline			$ \ src_loc ->
-    wlkQid	iclas		`thenUgn` \ clas    ->
+    wlkTCId	iclas		`thenUgn` \ clas    ->
     wlkMonoType ispec_ty	`thenUgn` \ ty	    ->
     returnUgn (RdrSpecInstSig (SpecInstSig clas ty src_loc))
 
 	-- data specialisation user-pragma
 wlk_sig_thing (U_dspec_uprag itycon dspec_tys srcline)
   = mkSrcLocUgn srcline		 	 $ \ src_loc ->
-    wlkQid	itycon		 `thenUgn` \ tycon   ->
+    wlkTCId	itycon		 `thenUgn` \ tycon   ->
     wlkList rdMonoType dspec_tys `thenUgn` \ tys     ->
     returnUgn (RdrSpecDataSig (SpecDataSig tycon (MonoTyApp tycon tys) src_loc))
 
 	-- value inlining user-pragma
 wlk_sig_thing (U_inline_uprag ivar srcline)
   = mkSrcLocUgn	srcline      		$ \ src_loc ->
-    wlkQid	ivar		`thenUgn` \ var     ->
+    wlkVarId	ivar		`thenUgn` \ var     ->
     returnUgn (RdrInlineValSig (InlineSig var src_loc))
 
 	-- "deforest me" user-pragma
 wlk_sig_thing (U_deforest_uprag ivar srcline)
   = mkSrcLocUgn srcline			$ \ src_loc ->
-    wlkQid	ivar		`thenUgn` \ var     ->
+    wlkVarId	ivar		`thenUgn` \ var     ->
     returnUgn (RdrDeforestSig (DeforestSig var src_loc))
 
 	-- "magic" unfolding user-pragma
 wlk_sig_thing (U_magicuf_uprag ivar str srcline)
   = mkSrcLocUgn srcline			$ \ src_loc ->
-    wlkQid	ivar		`thenUgn` \ var     ->
+    wlkVarId	ivar		`thenUgn` \ var     ->
     returnUgn (RdrMagicUnfoldingSig (MagicUnfoldingSig var str src_loc))
 \end{code}
 
@@ -692,16 +689,16 @@ wlk_sig_thing (U_magicuf_uprag ivar str srcline)
 %************************************************************************
 
 \begin{code}
-rdPolyType :: ParseTree -> UgnM RdrNamePolyType
-rdMonoType :: ParseTree -> UgnM RdrNameMonoType
+rdHsType :: ParseTree -> UgnM RdrNameHsType
+rdMonoType :: ParseTree -> UgnM RdrNameHsType
 
-rdPolyType pt = rdU_ttype pt `thenUgn` \ ttype -> wlkPolyType ttype
+rdHsType pt = rdU_ttype pt `thenUgn` \ ttype -> wlkHsType ttype
 rdMonoType pt = rdU_ttype pt `thenUgn` \ ttype -> wlkMonoType ttype
 
-wlkPolyType :: U_ttype -> UgnM RdrNamePolyType
-wlkMonoType :: U_ttype -> UgnM RdrNameMonoType
+wlkHsType :: U_ttype -> UgnM RdrNameHsType
+wlkMonoType :: U_ttype -> UgnM RdrNameHsType
 
-wlkPolyType ttype
+wlkHsType ttype
   = case ttype of
       U_context tcontextl tcontextt -> -- context
 	wlkContext  tcontextl	`thenUgn` \ ctxt ->
@@ -715,11 +712,11 @@ wlkPolyType ttype
 wlkMonoType ttype
   = case ttype of
       U_namedtvar tv -> -- type variable
-	wlkQid tv	`thenUgn` \ tyvar ->
+	wlkTvId tv	`thenUgn` \ tyvar ->
 	returnUgn (MonoTyVar tyvar)
 
       U_tname tcon -> -- type constructor
-	wlkQid tcon	`thenUgn` \ tycon ->
+	wlkTCId tcon	`thenUgn` \ tycon ->
 	returnUgn (MonoTyApp tycon [])
 
       U_tapp t1 t2 ->
@@ -731,9 +728,9 @@ wlkMonoType ttype
 	  = case t of
 	      U_tapp t1 t2   -> wlkMonoType t2	`thenUgn` \ ty2 ->
 			        collect t1 (ty2:acc)
-	      U_tname tcon   -> wlkQid tcon	`thenUgn` \ tycon ->
+	      U_tname tcon   -> wlkTCId tcon	`thenUgn` \ tycon ->
 			        returnUgn (tycon, acc)
-	      U_namedtvar tv -> wlkQid tv	`thenUgn` \ tyvar ->
+	      U_namedtvar tv -> wlkTvId tv	`thenUgn` \ tyvar ->
 			        returnUgn (tyvar, acc)
 	      U_tllist _ -> panic "tlist"
 	      U_ttuple _ -> panic "ttuple"
@@ -744,11 +741,11 @@ wlkMonoType ttype
 	      
       U_tllist tlist -> -- list type
 	wlkMonoType tlist	`thenUgn` \ ty ->
-	returnUgn (MonoListTy ty)
+	returnUgn (MonoListTy dummyRdrTcName ty)
 
       U_ttuple ttuple ->
 	wlkList rdMonoType ttuple `thenUgn` \ tys ->
-	returnUgn (MonoTupleTy tys)
+	returnUgn (MonoTupleTy dummyRdrTcName tys)
 
       U_tfun tfun targ ->
 	wlkMonoType tfun	`thenUgn` \ ty1 ->
@@ -758,14 +755,14 @@ wlkMonoType ttype
 \end{code}
 
 \begin{code}
-wlkTyConAndTyVars :: U_ttype -> UgnM (RdrName, [RdrName])
+wlkTyConAndTyVars :: U_ttype -> UgnM (RdrName, [HsTyVar RdrName])
 wlkContext   	  :: U_list  -> UgnM RdrNameContext
-wlkClassAssertTy  :: U_ttype -> UgnM (RdrName, RdrName)
+wlkClassAssertTy  :: U_ttype -> UgnM (RdrName, HsTyVar RdrName)
 
 wlkTyConAndTyVars ttype
   = wlkMonoType ttype	`thenUgn` \ (MonoTyApp tycon ty_args) ->
     let
-	args = [ a | (MonoTyVar a) <- ty_args ]
+	args = [ UserTyVar a | (MonoTyVar a) <- ty_args ]
     in
     returnUgn (tycon, args)
 
@@ -775,11 +772,13 @@ wlkContext list
 
 wlkClassAssertTy xs
   = wlkMonoType xs   `thenUgn` \ mono_ty ->
-    returnUgn (mk_class_assertion mono_ty)
+    returnUgn (case mk_class_assertion mono_ty of
+		  (clas, MonoTyVar tyvar) -> (clas, UserTyVar tyvar)
+    )
 
-mk_class_assertion :: RdrNameMonoType -> (RdrName, RdrName)
+mk_class_assertion :: RdrNameHsType -> (RdrName, RdrNameHsType)
 
-mk_class_assertion (MonoTyApp name [(MonoTyVar tyname)]) = (name, tyname)
+mk_class_assertion (MonoTyApp name [ty@(MonoTyVar tyname)]) = (name, ty)
 mk_class_assertion other
   = pprError "ERROR: malformed type context: " (ppr PprForUser other)
     -- regrettably, the parser does let some junk past
@@ -796,33 +795,33 @@ wlkConDecl :: U_constr -> UgnM RdrNameConDecl
 
 wlkConDecl (U_constrpre ccon ctys srcline)
   = mkSrcLocUgn srcline			$ \ src_loc ->
-    wlkQid	ccon		`thenUgn` \ con	    ->
+    wlkDataId	ccon		`thenUgn` \ con	    ->
     wlkList     rdBangType ctys	`thenUgn` \ tys	    ->
     returnUgn (ConDecl con tys src_loc)
 
 wlkConDecl (U_constrinf cty1 cop cty2 srcline)
   = mkSrcLocUgn srcline			$ \ src_loc ->
     wlkBangType cty1		`thenUgn` \ ty1	    ->
-    wlkQid	cop		`thenUgn` \ op	    ->
+    wlkDataId	cop		`thenUgn` \ op	    ->
     wlkBangType cty2		`thenUgn` \ ty2	    ->
     returnUgn (ConOpDecl ty1 op ty2 src_loc)
 
 wlkConDecl (U_constrnew ccon cty srcline)
   = mkSrcLocUgn srcline			$ \ src_loc ->
-    wlkQid	ccon		`thenUgn` \ con	    ->
+    wlkDataId	ccon		`thenUgn` \ con	    ->
     wlkMonoType cty		`thenUgn` \ ty	    ->
     returnUgn (NewConDecl con ty src_loc)
 
 wlkConDecl (U_constrrec ccon cfields srcline)
   = mkSrcLocUgn srcline			$ \ src_loc      ->
-    wlkQid	ccon		`thenUgn` \ con		 ->
+    wlkDataId	ccon		`thenUgn` \ con		 ->
     wlkList rd_field cfields	`thenUgn` \ fields_lists ->
     returnUgn (RecConDecl con fields_lists src_loc)
   where
     rd_field :: ParseTree -> UgnM ([RdrName], BangType RdrName)
     rd_field pt
       = rdU_constr pt		`thenUgn` \ (U_field fvars fty) ->
-	wlkList rdQid	fvars	`thenUgn` \ vars ->
+	wlkList rdVarId	fvars	`thenUgn` \ vars ->
 	wlkBangType fty		`thenUgn` \ ty ->
 	returnUgn (vars, ty)
 
@@ -832,9 +831,9 @@ rdBangType pt = rdU_ttype pt `thenUgn` \ ty -> wlkBangType ty
 wlkBangType :: U_ttype -> UgnM (BangType RdrName)
 
 wlkBangType (U_tbang bty) = wlkMonoType bty `thenUgn` \ ty ->
-			    returnUgn (Banged   (HsPreForAllTy [] ty))
+			    returnUgn (Banged   ty)
 wlkBangType uty		  = wlkMonoType uty `thenUgn` \ ty ->
-			    returnUgn (Unbanged (HsPreForAllTy [] ty))
+			    returnUgn (Unbanged ty)
 \end{code}
 
 %************************************************************************
@@ -851,7 +850,7 @@ rdMatch pt
     mkSrcLocUgn srcline			$ \ src_loc      ->
     wlkPat	gpat		`thenUgn` \ pat     ->
     wlkBinding	gbind		`thenUgn` \ binding ->
-    wlkQid	gsrcfun		`thenUgn` \ srcfun  ->
+    wlkVarId	gsrcfun		`thenUgn` \ srcfun  ->
     let
 	wlk_guards (U_pnoguards exp)
 	  = wlkExpr exp `thenUgn` \ expr ->
@@ -881,12 +880,14 @@ rdFixOp :: ParseTree -> UgnM RdrNameFixityDecl
 rdFixOp pt 
   = rdU_tree pt `thenUgn` \ fix ->
     case fix of
-      U_fixop op (-1) prec -> wlkQid op `thenUgn` \ op ->
-				       returnUgn (InfixL op prec)
-      U_fixop op   0  prec -> wlkQid op `thenUgn` \ op ->
-				       returnUgn (InfixN op prec)
-      U_fixop op   1  prec -> wlkQid op `thenUgn` \ op ->
-				       returnUgn (InfixR op prec)
+      U_fixop op dir_n prec -> wlkVarId op `thenUgn` \ op ->
+				       returnUgn (FixityDecl op (Fixity prec dir) noSrcLoc)
+						-- ToDo: add SrcLoc!
+			    where
+			      dir = case dir_n of
+					(-1) -> InfixL
+					0    -> InfixN
+					1    -> InfixR
       _ -> error "ReadPrefix:rdFixOp"
 \end{code}
 
@@ -926,21 +927,21 @@ rdEntity pt
   = rdU_entidt pt `thenUgn` \ entity ->
     case entity of
       U_entid evar -> 		-- just a value
-	wlkQid	evar		`thenUgn` \ var ->
+	wlkEntId	evar		`thenUgn` \ var ->
 	returnUgn (IEVar var)
 
       U_enttype x -> 		-- abstract type constructor/class
-	wlkQid	x		`thenUgn` \ thing ->
+	wlkTCId	x		`thenUgn` \ thing ->
 	returnUgn (IEThingAbs thing)
 
       U_enttypeall x -> 	-- non-abstract type constructor/class
-	wlkQid	x		`thenUgn` \ thing ->
+	wlkTCId	x		`thenUgn` \ thing ->
 	returnUgn (IEThingAll thing)
 
       U_enttypenamed x ns -> 	-- non-abstract type constructor/class
 				-- with specified constrs/methods
-	wlkQid	x		`thenUgn` \ thing ->
-	wlkList rdQid ns	`thenUgn` \ names -> 
+	wlkTCId	x		`thenUgn` \ thing ->
+	wlkList rdVarId ns	`thenUgn` \ names -> 
 	returnUgn (IEThingWith thing names)
 
       U_entmod mod -> 		-- everything provided unqualified by a module
diff --git a/ghc/compiler/rename/ParseIface.y b/ghc/compiler/rename/ParseIface.y
index 30083ff093..1f6e8315a4 100644
--- a/ghc/compiler/rename/ParseIface.y
+++ b/ghc/compiler/rename/ParseIface.y
@@ -5,22 +5,29 @@ module ParseIface ( parseIface ) where
 
 IMP_Ubiq(){-uitous-}
 
-import ParseUtils
-
 import HsSyn		-- quite a bit of stuff
 import RdrHsSyn		-- oodles of synonyms
-import HsPragmas	( noGenPragmas )
+import HsDecls		( HsIdInfo(..) )
+import HsTypes		( mkHsForAllTy )
+import HsCore
+import Literal
+import HsPragmas	( noGenPragmas, noDataPragmas, noClassPragmas, noClassOpPragmas, noInstancePragmas )
+import IdInfo		( exactArity, mkStrictnessInfo, mkBottomStrictnessInfo,
+			  ArgUsageInfo, FBTypeInfo
+			)
+import Kind		( Kind, mkArrowKind, mkTypeKind )
+import Lex		
 
+import RnMonad		( SYN_IE(ImportVersion), SYN_IE(LocalVersion), ParsedIface(..),
+			  SYN_IE(RdrNamePragma), SYN_IE(ExportItem)
+			) 
 import Bag		( emptyBag, unitBag, snocBag )
 import FiniteMap	( emptyFM, unitFM, addToFM, plusFM, bagToFM, FiniteMap )
-import Name		( ExportFlag(..), mkTupNameStr, preludeQual,
-			  RdrName(..){-instance Outputable:ToDo:rm-}
-			)
---import Outputable	-- ToDo:rm
---import PprStyle		( PprStyle(..) ) -- ToDo: rm debugging
+import Name		( OccName(..), Provenance )
 import SrcLoc		( mkIfaceSrcLoc )
 import Util		( panic{-, pprPanic ToDo:rm-} )
 
+
 -----------------------------------------------------------------
 
 parseIface = parseIToks . lexIface
@@ -45,13 +52,13 @@ parseIface = parseIToks . lexIface
 	BANG		    { ITbang }
 	CBRACK		    { ITcbrack }
 	CCURLY		    { ITccurly }
-	DCCURLY		    { ITdccurly }
 	CLASS		    { ITclass }
 	COMMA		    { ITcomma }
 	CPAREN		    { ITcparen }
 	DARROW		    { ITdarrow }
 	DATA		    { ITdata }
 	DCOLON		    { ITdcolon }
+	DERIVING	    { ITderiving }
 	DOTDOT		    { ITdotdot }
 	EQUAL		    { ITequal }
 	FORALL		    { ITforall }
@@ -62,7 +69,6 @@ parseIface = parseIToks . lexIface
 	NEWTYPE		    { ITnewtype }
 	OBRACK		    { ITobrack }
 	OCURLY		    { ITocurly }
-	DOCURLY		    { ITdocurly }
 	OPAREN		    { IToparen }
 	RARROW		    { ITrarrow }
 	SEMI		    { ITsemi }
@@ -78,318 +84,410 @@ parseIface = parseIToks . lexIface
 	QCONID		    { ITqconid   $$ }
 	QVARSYM		    { ITqvarsym  $$ }
 	QCONSYM		    { ITqconsym  $$ }
+
+	ARITY_PART	{ ITarity }
+	STRICT_PART	{ ITstrict }
+	UNFOLD_PART	{ ITunfold }
+	DEMAND		{ ITdemand $$ }
+	BOTTOM		{ ITbottom }
+	LAM		{ ITlam }
+	BIGLAM		{ ITbiglam }
+	CASE		{ ITcase }
+	OF		{ ITof }
+	LET		{ ITlet }
+	LETREC		{ ITletrec }
+	IN		{ ITin }
+	COERCE_IN	{ ITcoerce_in }
+	COERCE_OUT	{ ITcoerce_out }
+	CHAR		{ ITchar $$ }
+	STRING		{ ITstring $$ }	
 %%
 
 iface		:: { ParsedIface }
 iface		: INTERFACE CONID INTEGER
-		  usages_part versions_part
-		  exports_part inst_modules_part
-		  fixities_part decls_part instances_part pragmas_part
-		  { case $9 of { (tm, vm) ->
-		    ParsedIface $2 (panic "merge modules") (fromInteger $3) Nothing{-src version-}
-			$4  -- usages
-			$5  -- local versions
-			$6  -- exports map
-			$7  -- instance modules
-			$8  -- fixities map
-			tm  -- decls maps
-			vm
-			$10  -- local instances
-			$11 -- pragmas map
+		  inst_modules_part 
+		  usages_part
+		  exports_part fixities_part
+		  instances_part
+		  decls_part
+		  { ParsedIface 
+			$2 			-- Module name
+			(fromInteger $3) 	-- Module version
+			$5  		        -- Usages
+			$6  		        -- Exports
+			$4  		        -- Instance modules
+			$7  		        -- Fixities
+			$9  		        -- Decls
+			$8 			-- Local instances
 		    }
+
+
+usages_part	    :: { [ImportVersion OccName] }
+usages_part	    :  USAGES_PART module_stuff_pairs		{ $2 }
+		    |						{ [] }
+
+module_stuff_pairs  :: { [ImportVersion OccName] }
+module_stuff_pairs  :  						{ [] }
+		    |  module_stuff_pair module_stuff_pairs	{ $1 : $2 }
+
+module_stuff_pair   ::  { ImportVersion OccName }
+module_stuff_pair   :  mod_name INTEGER DCOLON name_version_pairs SEMI
+			{ ($1, fromInteger $2, $4) }
+
+versions_part	    :: { [LocalVersion OccName] }
+versions_part	    :  VERSIONS_PART name_version_pairs		{ $2 }
+		    |						{ [] }
+
+name_version_pairs  ::	{ [LocalVersion OccName] }
+name_version_pairs  :  						{ [] }
+		    |  name_version_pair name_version_pairs	{ $1 : $2 }
+
+name_version_pair   ::	{ LocalVersion OccName }
+name_version_pair   :  entity_occ INTEGER			{ ($1, fromInteger $2)
 --------------------------------------------------------------------------
-		  }
-
-usages_part	    :: { UsagesMap }
-usages_part	    :  USAGES_PART module_stuff_pairs	{ bagToFM $2 }
-		    |					{ emptyFM }
-
-versions_part	    :: { VersionsMap }
-versions_part	    :  VERSIONS_PART name_version_pairs { bagToFM $2 }
-		    |					{ emptyFM }
-
-module_stuff_pairs  :: { Bag (Module, (Version, FiniteMap FAST_STRING Version)) }
-module_stuff_pairs  :  module_stuff_pair
-			{ unitBag $1 }
-		    |  module_stuff_pairs module_stuff_pair
-			{ $1 `snocBag` $2 }
-
-module_stuff_pair   ::  { (Module, (Version, FiniteMap FAST_STRING Version)) }
-module_stuff_pair   :  CONID INTEGER DCOLON name_version_pairs SEMI
-			{ ($1, (fromInteger $2, bagToFM $4)) }
-
-name_version_pairs  ::	{ Bag (FAST_STRING, Int) }
-name_version_pairs  :  name_version_pair
-			{ unitBag $1 }
-		    |  name_version_pairs name_version_pair
-			{ $1 `snocBag` $2 }
-
-name_version_pair   ::	{ (FAST_STRING, Int) }
-name_version_pair   :  name INTEGER
-			{ ($1, fromInteger $2)
---------------------------------------------------------------------------
-			}
+								}
 
-exports_part	:: { ExportsMap }
-exports_part	:  EXPORTS_PART export_items { bagToFM $2 }
-		|			     { emptyFM }
+exports_part	:: { [ExportItem] }
+exports_part	:  EXPORTS_PART export_items			{ $2 }
+		|			     			{ [] }
 
-export_items	:: { Bag (FAST_STRING, (OrigName, ExportFlag)) }
-export_items	:  export_item		    { unitBag $1 }
-		|  export_items export_item { $1 `snocBag` $2 }
+export_items	:: { [ExportItem] }
+export_items	:  			    			{ [] }
+		|  export_item export_items 			{ $1 : $2 }
 
-export_item	:: { (FAST_STRING, (OrigName, ExportFlag)) }
-export_item	:  CONID name maybe_dotdot { ($2, (OrigName $1 $2, $3)) }
+export_item	:: { ExportItem }
+export_item	:  mod_name entity_occ maybe_dotdot		{ ($1, $2, $3) }
 
-maybe_dotdot	:: { ExportFlag }
-maybe_dotdot	:  DOTDOT { ExportAll }
-		|	  { ExportAbs
+maybe_dotdot	:: { [OccName] }
+maybe_dotdot	:	     					{ [] }
+		|  OPAREN val_occs CPAREN			{ $2
 --------------------------------------------------------------------------
-			  }
+								}
 
-inst_modules_part :: { Bag Module }
-inst_modules_part :  INSTANCE_MODULES_PART mod_list { $2 }
-		  |				    { emptyBag }
+inst_modules_part :: { [Module] }
+inst_modules_part :				    		{ [] }
+		  |  INSTANCE_MODULES_PART mod_list 		{ $2 }
 
-mod_list	:: { Bag Module }
-mod_list	:  CONID	  { unitBag $1 }
-		|  mod_list CONID { $1 `snocBag` $2
+mod_list	:: { [Module] }
+mod_list	:  						{ [] }
+		|  mod_name mod_list				{ $1 : $2
 --------------------------------------------------------------------------
-				  }
+								  }
 
-fixities_part	:: { FixitiesMap }
-fixities_part	:  FIXITIES_PART fixes	{ $2 }
-		|			{ emptyFM }
+fixities_part	:: { [(OccName,Fixity)] }
+fixities_part	:						{ [] }
+		|  FIXITIES_PART fixes				{ $2 }
 
-fixes		:: { FixitiesMap }
-fixes		:  fix  	{ case $1 of (k,v) -> unitFM k v }
-		|  fixes fix	{ case $2 of (k,v) -> addToFM $1 k v }
+fixes		:: { [(OccName,Fixity)] }
+fixes		:  				  		{ []  }
+		|  fix fixes					{ $1 : $2 }
 
-fix		:: { (FAST_STRING, RdrNameFixityDecl) }
-fix		:  INFIXL INTEGER qname SEMI { (de_qual $3, InfixL $3 (fromInteger $2)) }
-		|  INFIXR INTEGER qname SEMI { (de_qual $3, InfixR $3 (fromInteger $2)) }
-		|  INFIX  INTEGER qname SEMI { (de_qual $3, InfixN $3 (fromInteger $2))
+fix		:: { (OccName, Fixity) }
+fix		:  INFIXL INTEGER val_occ SEMI { ($3, Fixity (fromInteger $2) InfixL) }
+		|  INFIXR INTEGER val_occ SEMI { ($3, Fixity (fromInteger $2) InfixR) }
+		|  INFIX  INTEGER val_occ SEMI { ($3, Fixity (fromInteger $2) InfixN)
 --------------------------------------------------------------------------
-				      }
-
-decls_part	:: { (LocalTyDefsMap, LocalValDefsMap) }
-decls_part	: DECLARATIONS_PART topdecls { $2 }
-		|			     { (emptyFM, emptyFM) }
-
-topdecls	:: { (LocalTyDefsMap, LocalValDefsMap) }
-topdecls	:  topdecl	    { $1 }
-		|  topdecls topdecl { case $1 of { (ts1, vs1) ->
-				      case $2 of { (ts2, vs2) ->
-				      (plusFM ts1 ts2, plusFM vs1 vs2)}}
-				     }
-
-topdecl		:: { (LocalTyDefsMap, LocalValDefsMap) }
-topdecl		:  typed  SEMI	{ ($1, emptyFM) }
-		|  datad  SEMI	{ $1 }
-		|  newtd  SEMI	{ $1 }
-		|  classd SEMI	{ $1 }
-		|  decl		{ case $1 of { (n, Sig qn ty _ loc) ->
-				  (emptyFM, unitFM n (ValSig qn loc ty)) }
-				}
-
-typed		:: { LocalTyDefsMap }
-typed		:  TYPE simple EQUAL type	{ mk_type $2 $4 }
-
-datad		:: { (LocalTyDefsMap, LocalValDefsMap) }
-datad		:  DATA		       simple EQUAL constrs { mk_data [] $2 $4 }
-		|  DATA context DARROW simple EQUAL constrs { mk_data $2 $4 $6 }
-
-newtd		:: { (LocalTyDefsMap, LocalValDefsMap) }
-newtd		:  NEWTYPE		  simple EQUAL constr1 { mk_new [] $2 $4 }
-		|  NEWTYPE context DARROW simple EQUAL constr1 { mk_new $2 $4 $6 }
-
-classd		:: { (LocalTyDefsMap, LocalValDefsMap) }
-classd		:  CLASS		class cbody { mk_class [] $2 $3 }
-		|  CLASS context DARROW class cbody { mk_class $2 $4 $5 }
-
-cbody		:: { [(FAST_STRING, RdrNameSig)] }
-cbody		:  WHERE OCURLY decls CCURLY { $3 }
-		|			     { [] }
-
-decls		:: { [(FAST_STRING, RdrNameSig)] }
-decls		: decl		{ [$1] }
-		| decls decl	{ $1 ++ [$2] }
-
-decl		:: { (FAST_STRING, RdrNameSig) }
-decl		:  var DCOLON ctype SEMI { (de_qual $1, Sig $1 $3 noGenPragmas mkIfaceSrcLoc) }
+										      }
+
+decls_part	:: { [(Version, RdrNameHsDecl)] }
+decls_part	: 		    		 	{ [] }
+		|	DECLARATIONS_PART topdecls	{ $2 }
+
+topdecls	:: { [(Version, RdrNameHsDecl)] }
+topdecls	:  		    			{ [] }
+		|  version topdecl topdecls		{ ($1,$2) : $3 }
+
+version		:: { Version }
+version		:  INTEGER				{ fromInteger $1 }
+
+topdecl		:: { RdrNameHsDecl }
+topdecl		:  TYPE  tc_name tv_bndrs EQUAL type SEMI
+			{ TyD (TySynonym $2 $3 $5 mkIfaceSrcLoc) }
+		|  DATA decl_context tc_name tv_bndrs EQUAL constrs deriving SEMI
+			{ TyD (TyData $2 $3 $4 $6 $7 noDataPragmas mkIfaceSrcLoc) }
+		|  NEWTYPE decl_context tc_name tv_bndrs EQUAL constr1 deriving SEMI
+			{ TyD (TyNew $2 $3 $4 $6 $7 noDataPragmas mkIfaceSrcLoc) }
+		|  CLASS decl_context tc_name tv_bndr csigs SEMI
+			{ ClD (ClassDecl $2 $3 $4 $5 EmptyMonoBinds noClassPragmas mkIfaceSrcLoc) }
+		|  var_name DCOLON ctype id_info SEMI
+			{ SigD (IfaceSig $1 $3 $4 mkIfaceSrcLoc) }
+
+decl_context	:: { RdrNameContext }
+decl_context	:  					{ [] }
+		| OCURLY context_list1 CCURLY DARROW	{ $2 }
+
+csigs		:: { [RdrNameSig] }
+csigs		:  				{ [] }
+		| WHERE OCURLY csigs1 CCURLY	{ $3 }
+
+csigs1		:: { [RdrNameSig] }
+csigs1		: csig				{ [$1] }
+		| csig SEMI csigs1		{ $1 : $3 }
+
+csig		:: { RdrNameSig }
+csig		:  var_name DCOLON ctype 	{ ClassOpSig $1 $3 noClassOpPragmas mkIfaceSrcLoc
+----------------------------------------------------------------
+			 			 }
+
+constrs		:: { [RdrNameConDecl] }
+constrs		:  constr		{ [$1] }
+		|  constr VBAR constrs	{ $1 : $3 }
+
+constr		:: { RdrNameConDecl }
+constr		:  data_name batypes			{ ConDecl $1 $2 mkIfaceSrcLoc }
+		|  data_name OCURLY fields1 CCURLY	{ RecConDecl $1 $3 mkIfaceSrcLoc }
+
+constr1		:: { RdrNameConDecl 	{- For a newtype -} }
+constr1		:  data_name atype			{ NewConDecl $1 $2 mkIfaceSrcLoc }
+
+deriving	:: { Maybe [RdrName] }
+		: 					{ Nothing }
+		| DERIVING OPAREN qtc_names1 CPAREN	{ Just $3 }
+
+batypes		:: { [RdrNameBangType] }
+batypes		:  					{ [] }
+		|  batype batypes			{ $1 : $2 }
+
+batype		:: { RdrNameBangType }
+batype		:  atype				{ Unbanged $1 }
+		|  BANG atype				{ Banged   $2 }
+
+fields1		:: { [([RdrName], RdrNameBangType)] }
+fields1		: field					{ [$1] }
+		| field COMMA fields1			{ $1 : $3 }
+
+field		:: { ([RdrName], RdrNameBangType) }
+field		:  var_name DCOLON ctype	   	{ ([$1], Unbanged $3) }
+		|  var_name DCOLON BANG ctype    	{ ([$1], Banged   $4)
+--------------------------------------------------------------------------
+						    	}
+
+forall		:: { [HsTyVar RdrName] }
+forall		: OBRACK tv_bndrs CBRACK		{ $2 }
 
 context		:: { RdrNameContext }
-context		:  DOCURLY context_list DCCURLY	{ reverse $2 }
-
-context_list	:: { RdrNameContext{-reversed-} }
-context_list	:  class			{ [$1] }
-		|  context_list COMMA class	{ $3 : $1 }
-
-class		:: { (RdrName, RdrName) }
-class		:  gtycon VARID			{ ($1, Unqual $2) }
-
-ctype		:: { RdrNamePolyType }
-ctype		: FORALL OBRACK tyvars CBRACK context DARROW type  { HsForAllTy (map Unqual $3) $5 $7 }
-		| FORALL OBRACK tyvars CBRACK type		   { HsForAllTy (map Unqual $3) [] $5 }
-		| type	{ HsForAllTy [] [] $1 }
-
-type		:: { RdrNameMonoType }
-type		:  btype		{ $1 }
-		|  btype RARROW type	{ MonoFunTy $1 $3 }
-
-types		:: { [RdrNameMonoType] }
-types		:  type			{ [$1] }
-		|  types COMMA type	{ $1 ++ [$3] }
-
-btype		:: { RdrNameMonoType }
-btype		:  gtyconapp		{ case $1 of (tc, tys) -> MonoTyApp tc tys }
-		|  ntyconapp		{ case $1 of { (ty1, tys) ->
-					  if null tys
-					  then ty1
-					  else
-					  case ty1 of {
-					    MonoTyVar tv    -> MonoTyApp tv tys;
-					    MonoTyApp tc ts -> MonoTyApp tc (ts++tys);
-					    MonoFunTy t1 t2 -> MonoTyApp (preludeQual SLIT("->")) (t1:t2:tys);
-					    MonoListTy ty   -> MonoTyApp (preludeQual SLIT("[]")) (ty:tys);
-					    MonoTupleTy ts  -> MonoTyApp (preludeQual (mkTupNameStr (length ts)))
-									 (ts++tys);
---					    _		    -> pprPanic "test:" (ppr PprDebug $1)
-					  }}
-					}
+context		:  					{ [] }
+		| OCURLY context_list1 CCURLY		{ $2 }
 
-ntyconapp	:: { (RdrNameMonoType, [RdrNameMonoType]) }
-ntyconapp	: ntycon		{ ($1, []) }
-		| ntyconapp atype	{ case $1 of (t1,tys) -> (t1, tys ++ [$2]) }
+context_list1	:: { RdrNameContext }
+context_list1	: class					{ [$1] }
+		| class COMMA context_list1 		{ $1 : $3 }
 
-gtyconapp	:: { (RdrName, [RdrNameMonoType]) }
-gtyconapp	: gtycon		{ ($1, []) }
-		| gtyconapp atype	{ case $1 of (tc,tys) -> (tc, tys ++ [$2]) }
+class		:: { (RdrName, RdrNameHsType) }
+class		:  qtc_name atype			{ ($1, $2) }
 
-atype		:: { RdrNameMonoType }
-atype		:  gtycon		{ MonoTyApp $1 [] }
-		|  ntycon		{ $1 }
+ctype		:: { RdrNameHsType }
+ctype		: FORALL forall context DARROW type	{ mkHsForAllTy $2 $3 $5 }
+		| type					{ $1 }
 
-atypes		:: { [RdrNameMonoType] }
-atypes		:  atype		{ [$1] }
-		|  atypes atype		{ $1 ++ [$2] }
+type		:: { RdrNameHsType }
+type		:  btype				{ $1 }
+		|  btype RARROW type			{ MonoFunTy $1 $3 }
 
-ntycon		:: { RdrNameMonoType }
-ntycon		:  VARID			  { MonoTyVar (Unqual $1) }
-		|  OPAREN type COMMA types CPAREN { MonoTupleTy ($2 : $4) }
-		|  OBRACK type CBRACK		  { MonoListTy $2 }
-		|  OPAREN type CPAREN		  { $2 }
+ctypes2		:: { [RdrNameHsType] 			{- Two or more -}  }	
+ctypes2		:  ctype COMMA ctype			{ [$1,$3] }
+		|  ctype COMMA ctypes2			{ $1 : $3 }
 
-gtycon		:: { RdrName }
-gtycon		:  QCONID		{ $1 }
-		|  OPAREN RARROW CPAREN	{ preludeQual SLIT("->") }
-		|  OBRACK CBRACK	{ preludeQual SLIT("[]") }
-		|  OPAREN CPAREN	{ preludeQual SLIT("()") }
-		|  OPAREN commas CPAREN	{ preludeQual (mkTupNameStr $2) }
+btype		:: { RdrNameHsType }
+btype		:  atype				{ $1 }
+		|  qtc_name atypes1			{ MonoTyApp $1 $2 }
+		|  tv_name  atypes1			{ MonoTyApp $1 $2 }
 
-commas		:: { Int }
-commas		:  COMMA		{ 2{-1 comma => arity 2-} }
-		|  commas COMMA		{ $1 + 1 }
+atype		:: { RdrNameHsType }
+atype		:  qtc_name 			  	{ MonoTyApp $1 [] }
+		|  tv_name			  	{ MonoTyVar $1 }
+		|  OPAREN ctypes2 CPAREN	  	{ MonoTupleTy dummyRdrTcName $2 }
+		|  OBRACK type CBRACK		  	{ MonoListTy  dummyRdrTcName $2 }
+		|  OCURLY qtc_name atype CCURLY		{ MonoDictTy $2 $3 }
+		|  OPAREN ctype CPAREN		  	{ $2 }
 
-simple		:: { (RdrName, [FAST_STRING]) }
-simple		:  gtycon	{ ($1, []) }
-		|  gtyconvars   { case $1 of (tc,tvs) -> (tc, reverse tvs) }
+atypes1		:: { [RdrNameHsType] 	{-  One or more -} }
+atypes1		:  atype				{ [$1] }
+		|  atype atypes1			{ $1 : $2
+---------------------------------------------------------------------
+					 		}
 
-gtyconvars	:: { (RdrName, [FAST_STRING] {-reversed-}) }
-gtyconvars	:  gtycon     VARID { ($1, [$2]) }
-		|  gtyconvars VARID { case $1 of (tc,tvs) -> (tc, $2 : tvs) }
+mod_name	:: { Module }
+		:  CONID		{ $1 }
 
-constrs		:: { [(RdrName, RdrNameConDecl)] }
-constrs		:  constr		{ [$1] }
-		|  constrs VBAR constr	{ $1 ++ [$3] }
+var_occ		:: { OccName }
+var_occ		: VARID			{ VarOcc $1 }
+		| VARSYM		{ VarOcc $1 }
+		| BANG  		{ VarOcc SLIT("!") {-sigh, double-sigh-} }
 
-constr		:: { (RdrName, RdrNameConDecl) }
-constr		:  btyconapp
-		   { case $1 of (con, tys) -> (con, ConDecl con tys mkIfaceSrcLoc) }
-		|  QCONSYM	   { ($1, ConDecl $1 [] mkIfaceSrcLoc) }
-		|  QCONSYM batypes { ($1, ConDecl $1 $2 mkIfaceSrcLoc) }
-		|  gtycon OCURLY fields CCURLY
-		   { ($1, RecConDecl $1 $3 mkIfaceSrcLoc) }
+entity_occ	:: { OccName }
+entity_occ	:  var_occ		{ $1 }
+		|  CONID		{ TCOcc $1 }
+		|  CONSYM		{ TCOcc $1 }
 
-btyconapp	:: { (RdrName, [RdrNameBangType]) }
-btyconapp	:  gtycon			{ ($1, []) }
-		|  btyconapp batype		{ case $1 of (tc,tys) -> (tc, tys ++ [$2]) }
+val_occ		:: { OccName }
+val_occ		:  var_occ 		{ $1 }
+		|  CONID		{ VarOcc $1 }
+		|  CONSYM		{ VarOcc $1 }
 
-batype		:: { RdrNameBangType }
-batype		:  atype			{ Unbanged (HsForAllTy [{-ToDo:tvs-}] [] $1) }
-		|  BANG atype			{ Banged   (HsForAllTy [{-ToDo:tvs-}] [] $2) }
+val_occs	:: { [OccName] }
+		:  	    		{ [] }
+		|  val_occ val_occs	{ $1 : $2 }
 
-batypes		:: { [RdrNameBangType] }
-batypes		:  batype			{ [$1] }
-		|  batypes batype		{ $1 ++ [$2] }
 
-fields		:: { [([RdrName], RdrNameBangType)] }
-fields		: field				{ [$1] }
-		| fields COMMA field		{ $1 ++ [$3] }
+qvar_name	:: { RdrName }
+		:  QVARID		{ varQual $1 }
+		|  QVARSYM		{ varQual $1 }
 
-field		:: { ([RdrName], RdrNameBangType) }
-field		:  var DCOLON type	    { ([$1], Unbanged (HsForAllTy [{-ToDo:tvs-}] [] $3)) }
-		|  var DCOLON BANG atype    { ([$1], Banged   (HsForAllTy [{-ToDo:tvs-}] [] $4)) }
-
-constr1		:: { (RdrName, RdrNameMonoType) }
-constr1		:  gtycon atype	{ ($1, $2) }
-
-var		:: { RdrName }
-var		:  QVARID		{ $1 }
-		|  QVARSYM		{ $1 }
-
-qname		:: { RdrName }
-qname		:  QVARID		{ $1 }
-		|  QCONID		{ $1 }
-		|  QVARSYM		{ $1 }
-		|  QCONSYM		{ $1 }
-
-name		:: { FAST_STRING }
-name		:  VARID		{ $1 }
-		|  CONID		{ $1 }
-		|  VARSYM		{ $1 }
-		|  BANG  		{ SLIT("!"){-sigh, double-sigh-} }
-		|  CONSYM		{ $1 }  
-		|  OBRACK CBRACK	{ SLIT("[]") }
-		|  OPAREN CPAREN	{ SLIT("()") }
-		|  OPAREN commas CPAREN	{ mkTupNameStr $2 }
-
-instances_part	:: { Bag RdrIfaceInst }
+var_name	:: { RdrName }
+var_name	:  var_occ		{ Unqual $1 }
+
+
+qdata_name	:: { RdrName }
+qdata_name	:  QCONID		{ varQual $1 }
+		|  QCONSYM		{ varQual $1 }
+
+data_name	:: { RdrName }
+data_name	:  CONID		{ Unqual (VarOcc $1) }
+		|  CONSYM		{ Unqual (VarOcc $1) }
+
+
+qtc_name	:: { RdrName }
+qtc_name	:  QCONID		{ tcQual $1 }
+
+qtc_names1	:: { [RdrName] }
+		: qtc_name			{ [$1] }
+		| qtc_name COMMA qtc_names1	{ $1 : $3 }
+
+tc_name		:: { RdrName }
+tc_name		: CONID			{ Unqual (TCOcc $1) }		
+
+
+tv_name		:: { RdrName }
+tv_name		:  VARID 		{ Unqual (TvOcc $1) }
+
+tv_names	:: { [RdrName] }
+		:  			{ [] }
+		| tv_name tv_names	{ $1 : $2 }
+
+tv_bndr		:: { HsTyVar RdrName }
+tv_bndr		:  tv_name DCOLON akind	{ IfaceTyVar $1 $3 }
+		|  tv_name		{ UserTyVar $1 }
+
+tv_bndrs	:: { [HsTyVar RdrName] }
+		:  			{ [] }
+		| tv_bndr tv_bndrs	{ $1 : $2 }
+
+kind		:: { Kind }
+		: akind			{ $1 }
+		| akind RARROW kind	{ mkArrowKind $1 $3 }
+
+akind		:: { Kind }
+		: VARSYM		{ mkTypeKind {- ToDo: check that it's "*" -} }
+		| OPAREN kind CPAREN	{ $2
+--------------------------------------------------------------------------
+					}
+
+
+instances_part	:: { [RdrNameInstDecl] }
 instances_part	:  INSTANCES_PART instdecls { $2 }
-		|			    { emptyBag }
-
-instdecls	:: { Bag RdrIfaceInst }
-instdecls	:  instd		    { unitBag $1 }
-		|  instdecls instd	    { $1 `snocBag` $2 }
-
-instd		:: { RdrIfaceInst }
-instd		:  INSTANCE FORALL OBRACK tyvars CBRACK context DARROW gtycon restrict_inst SEMI { mk_inst (map Unqual $4) $6 $8 $9 }
-		|  INSTANCE FORALL OBRACK tyvars CBRACK		       gtycon general_inst  SEMI { mk_inst (map Unqual $4) [] $6 $7 }
-		|  INSTANCE gtycon general_inst	SEMI { mk_inst [] [] $2 $3 }
-
-restrict_inst	:: { RdrNameMonoType }
-restrict_inst	:  gtycon				{ MonoTyApp $1 [] }
-		|  OPAREN gtyconvars CPAREN		{ case $2 of (tc,tvs) -> MonoTyApp tc (map en_mono (reverse tvs)) }
-		|  OPAREN VARID COMMA tyvars CPAREN	{ MonoTupleTy (map en_mono ($2:$4)) }
-		|  OBRACK VARID CBRACK			{ MonoListTy (en_mono $2) }
-		|  OPAREN VARID RARROW VARID CPAREN	{ MonoFunTy (en_mono $2) (en_mono $4) }
-
-general_inst	:: { RdrNameMonoType }
-general_inst	:  gtycon				{ MonoTyApp $1 [] }
-		|  OPAREN gtyconapp CPAREN		{ case $2 of (tc,tys) -> MonoTyApp tc tys }
-		|  OPAREN type COMMA types CPAREN	{ MonoTupleTy ($2:$4) }
-		|  OBRACK type CBRACK			{ MonoListTy $2 }
-		|  OPAREN btype RARROW type CPAREN	{ MonoFunTy $2 $4 }
-
-tyvars		:: { [FAST_STRING] }
-tyvars		:  VARID		    { [$1] }
-		|  tyvars COMMA VARID   { $1 ++ [$3]
+		|			    { [] }
+
+instdecls	:: { [RdrNameInstDecl] }
+instdecls	:  			    { [] }
+		|  instd instdecls	    { $1 : $2 }
+
+instd		:: { RdrNameInstDecl }
+instd		:  INSTANCE ctype EQUAL var_name SEMI 
+			{ InstDecl $2
+				   EmptyMonoBinds	{- No bindings -}
+				   []    		{- No user pragmas -}
+				   (Just $4)		{- Dfun id -}
+				   mkIfaceSrcLoc 
 --------------------------------------------------------------------------
-					    }
+		    }
+
+id_info		:: { [HsIdInfo RdrName] }
+id_info		: 	 					{ [] }
+		| ARITY_PART arity_info id_info			{ HsArity $2 :  $3 }
+		| STRICT_PART strict_info id_info		{ HsStrictness $2 : $3 }
+		| UNFOLD_PART core_expr id_info			{ HsUnfold $2 : $3 }
+
+arity_info	:: { ArityInfo }
+arity_info	: INTEGER					{ exactArity (fromInteger $1) }
+
+strict_info	:: { StrictnessInfo RdrName }
+strict_info	: DEMAND qvar_name				{ mkStrictnessInfo $1 (Just $2) }
+		| DEMAND 					{ mkStrictnessInfo $1 Nothing }
+		| BOTTOM					{ mkBottomStrictnessInfo }
+
+core_expr	:: { UfExpr RdrName }
+core_expr	: var_name					{ UfVar $1 }
+		| qvar_name					{ UfVar $1 }
+		| qdata_name					{ UfVar $1 }
+		| core_lit					{ UfLit $1 }
+		| core_expr core_arg				{ UfApp $1 $2 }
+		| LAM core_val_bndr RARROW core_expr		{ UfLam $2 $4 }
+		| BIGLAM core_tv_bndrs RARROW core_expr		{ foldr UfLam $4 $2 }
+
+		| CASE core_expr OF 
+		  OCURLY alg_alts core_default CCURLY		{ UfCase $2 (UfAlgAlts  $5 $6) }
+		| CASE BANG core_expr OF 
+		  OCURLY prim_alts core_default CCURLY		{ UfCase $3 (UfPrimAlts $6 $7) }
+
+		| LET OCURLY core_val_bndr EQUAL core_expr CCURLY
+		  IN core_expr					{ UfLet (UfNonRec $3 $5) $8 }
+		| LETREC OCURLY rec_binds CCURLY		
+		  IN core_expr					{ UfLet (UfRec $3) $6 }
+
+		| qdata_name BANG core_args			{ UfCon $1 $3 }
+		| qvar_name  BANG core_args			{ UfPrim (UfOtherOp $1) $3 }
+		| coerce atype core_expr			{ UfCoerce $1 $2 $3 }
+
+rec_binds	:: { [(UfBinder RdrName, UfExpr RdrName)] }
+		:						{ [] }
+		| core_val_bndr EQUAL core_expr SEMI rec_binds	{ ($1,$3) : $5 }
+
+coerce		:: { UfCoercion RdrName }
+coerce		: COERCE_IN  qdata_name				{ UfIn  $2 }
+		| COERCE_OUT qdata_name				{ UfOut $2 }
+		
+prim_alts	:: { [(Literal,UfExpr RdrName)] }
+		:						{ [] }
+		| core_lit RARROW core_expr SEMI prim_alts	{ ($1,$3) : $5 }
+
+alg_alts	:: { [(RdrName, [UfBinder RdrName], UfExpr RdrName)] }
+		: 						{ [] }
+		| qdata_name core_val_bndrs RARROW 
+			core_expr SEMI alg_alts			{ ($1,$2,$4) : $6 }
+
+core_default	:: { UfDefault RdrName }
+		: 						{ UfNoDefault }
+		| core_val_bndr RARROW core_expr		{ UfBindDefault $1 $3 }
+
+core_arg	:: { UfArg RdrName }
+		: var_name					{ UfVarArg $1 }
+		| qvar_name					{ UfVarArg $1 }
+		| qdata_name					{ UfVarArg $1 }
+		| core_lit					{ UfLitArg $1 }
+		| OBRACK atype CBRACK				{ UfTyArg  $2 }
+
+core_args	:: { [UfArg RdrName] }
+		:						{ [] }
+		| core_arg core_args				{ $1 : $2 }
+
+core_lit	:: { Literal }
+core_lit	: INTEGER					{ MachInt $1 True }
+		| CHAR						{ MachChar $1 }
+		| STRING					{ MachStr $1 }
+
+core_val_bndr 	:: { UfBinder RdrName }
+core_val_bndr	: var_name DCOLON atype				{ UfValBinder $1 $3 }
+
+core_val_bndrs 	:: { [UfBinder RdrName] }
+core_val_bndrs	: 						{ [] }
+		| core_val_bndr core_val_bndrs			{ $1 : $2 }
+
+core_tv_bndr	:: { UfBinder RdrName }
+core_tv_bndr	:  tv_name DCOLON akind				{ UfTyBinder $1 $3 }
+		|  tv_name					{ UfTyBinder $1 mkTypeKind }
+
+core_tv_bndrs	:: { [UfBinder RdrName] }
+core_tv_bndrs	: 						{ [] }
+		| core_tv_bndr core_tv_bndrs			{ $1 : $2 }
 
-pragmas_part	:: { LocalPragmasMap }
-pragmas_part	:  PRAGMAS_PART
-		   { emptyFM }
-		|  { emptyFM }
-{
-}
diff --git a/ghc/compiler/rename/ParseUtils.lhs b/ghc/compiler/rename/ParseUtils.lhs
deleted file mode 100644
index 4e28daf6c4..0000000000
--- a/ghc/compiler/rename/ParseUtils.lhs
+++ /dev/null
@@ -1,427 +0,0 @@
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
-%
-\section[ParseUtils]{Help the interface parser}
-
-\begin{code}
-#include "HsVersions.h"
-
-module ParseUtils where
-
-IMP_Ubiq(){-uitous-}
-
-IMPORT_1_3(Char(isDigit, isAlpha, isAlphanum, isUpper))
-IMPORT_1_3(List(partition))
-
-import HsSyn		-- quite a bit of stuff
-import RdrHsSyn		-- oodles of synonyms
-import HsPragmas	( noDataPragmas, noClassPragmas, noClassOpPragmas,
-			  noInstancePragmas
-			)
-
-import ErrUtils		( SYN_IE(Error) )
-import FiniteMap	( unitFM, listToFM, lookupFM, plusFM, FiniteMap )
-import Maybes		( maybeToBool, MaybeErr(..) )
-import Name		( isLexConId, isLexVarId, isLexConSym,
-			  mkTupNameStr, preludeQual, isRdrLexCon,
-			  RdrName(..) {-instance Outputable:ToDo:rm-}
-			)
-import PprStyle		( PprStyle(..) ) -- ToDo: rm debugging
-import PrelMods		( pRELUDE )
-import Pretty		( ppCat, ppPStr, ppInt, ppShow, ppStr )
-import SrcLoc		( mkIfaceSrcLoc )
-import Util		( startsWith, isIn, panic, assertPanic{-, pprTrace ToDo:rm-} )
-\end{code}
-
-\begin{code}
-type UsagesMap	      = FiniteMap Module (Version, VersionsMap)
-			-- module => its version, then to all its entities
-			-- and their versions; "instance" is a magic entity
-			-- representing all the instances def'd in that module
-type VersionsMap      = FiniteMap FAST_STRING Version
-			-- Versions for things def'd in this module
-type ExportsMap       = FiniteMap FAST_STRING (OrigName, ExportFlag)
-type FixitiesMap      = FiniteMap FAST_STRING RdrNameFixityDecl
-type LocalTyDefsMap   = FiniteMap FAST_STRING RdrIfaceDecl -- for TyCon/Class
-type LocalValDefsMap  = FiniteMap FAST_STRING RdrIfaceDecl -- for values incl DataCon
-type LocalPragmasMap  = FiniteMap FAST_STRING PragmaStuff
-
-type PragmaStuff = String
-
-data ParsedIface
-  = ParsedIface
-      Module		 -- Module name
-      (Bool, Bag Module) -- From a merging of these modules; True => merging occured
-      Version		 -- Module version number
-      (Maybe Version)	 -- Source version number
-      UsagesMap		 -- Used when compiling this module
-      VersionsMap	 -- Version numbers of things from this module
-      ExportsMap	 -- Exported names
-      (Bag Module)	 -- Special instance modules
-      FixitiesMap	 -- fixities of local things
-      LocalTyDefsMap	 -- Local TyCon/Class names defined
-      LocalValDefsMap	 -- Local value names defined
-      (Bag RdrIfaceInst) -- Local instance declarations
-      LocalPragmasMap	 -- Pragmas for local names
-
------------------------------------------------------------------
-
-data RdrIfaceDecl
-  = TypeSig    RdrName           	   SrcLoc RdrNameTyDecl
-  | NewTypeSig RdrName RdrName		   SrcLoc RdrNameTyDecl
-  | DataSig    RdrName [RdrName] [RdrName] SrcLoc RdrNameTyDecl
-  | ClassSig   RdrName [RdrName] 	   SrcLoc RdrNameClassDecl
-  | ValSig     RdrName           	   SrcLoc RdrNamePolyType
-				 
-data RdrIfaceInst		 
-  = InstSig    RdrName RdrName  SrcLoc (Module -> RdrNameInstDecl)
-	-- InstDecl minus a Module name
-\end{code}
-
-\begin{code}
------------------------------------------------------------------
-data IfaceToken
-  = ITinterface		-- keywords
-  | ITusages
-  | ITversions
-  | ITexports
-  | ITinstance_modules
-  | ITinstances
-  | ITfixities
-  | ITdeclarations
-  | ITpragmas
-  | ITdata
-  | ITtype
-  | ITnewtype
-  | ITclass
-  | ITwhere
-  | ITinstance
-  | ITinfixl
-  | ITinfixr
-  | ITinfix
-  | ITforall
-  | ITbang		-- magic symbols
-  | ITvbar
-  | ITdcolon
-  | ITcomma
-  | ITdarrow
-  | ITdotdot
-  | ITequal
-  | ITocurly
-  | ITdccurly
-  | ITdocurly
-  | ITobrack
-  | IToparen
-  | ITrarrow
-  | ITccurly
-  | ITcbrack
-  | ITcparen
-  | ITsemi
-  | ITinteger Integer	-- numbers and names
-  | ITvarid   FAST_STRING
-  | ITconid   FAST_STRING
-  | ITvarsym  FAST_STRING
-  | ITconsym  FAST_STRING
-  | ITqvarid  RdrName
-  | ITqconid  RdrName
-  | ITqvarsym RdrName
-  | ITqconsym RdrName
-  deriving Text -- debugging
-
-instance Text RdrName where -- debugging
-    showsPrec _ rn = showString (ppShow 80 (ppr PprDebug rn))
-
------------------------------------------------------------------
-de_qual (Unqual n) = n
-de_qual (Qual _ n) = n
-
-en_mono :: FAST_STRING -> RdrNameMonoType
-en_mono tv = MonoTyVar (Unqual tv)
-
-{-OLD:
-type2context (MonoTupleTy tys) = map type2class_assertion tys
-type2context other_ty	       = [ type2class_assertion other_ty ]
-
-type2class_assertion (MonoTyApp clas [MonoTyVar tyvar]) = (clas, tyvar)
-type2class_assertion _ = panic "type2class_assertion: bad format"
--}
-
------------------------------------------------------------------
-mk_type	:: (RdrName, [FAST_STRING])
-	-> RdrNameMonoType
-	-> LocalTyDefsMap
-
-mk_type (qtycon@(Qual mod tycon), tyvars) ty
-  = let
-	qtyvars = map Unqual tyvars
-    in
-    unitFM tycon (TypeSig qtycon mkIfaceSrcLoc $
-		  TySynonym qtycon qtyvars ty mkIfaceSrcLoc)
-
-mk_data	:: RdrNameContext
-	-> (RdrName, [FAST_STRING])
-	-> [(RdrName, RdrNameConDecl)]
-	-> (LocalTyDefsMap, LocalValDefsMap)
-
-mk_data ctxt (qtycon@(Qual mod tycon), tyvars) names_and_constrs
-  = let
-	(qthingnames, constrs) = unzip names_and_constrs
-	(qconnames, qfieldnames) = partition isRdrLexCon qthingnames
-	thingnames = [ t | (Qual _ t) <- qthingnames]
-	qtyvars    = map Unqual tyvars
-	
-	decl = DataSig qtycon qconnames qfieldnames mkIfaceSrcLoc $
-		TyData ctxt qtycon qtyvars constrs Nothing noDataPragmas mkIfaceSrcLoc
-    in
-    (unitFM tycon decl, listToFM [(t,decl) | t <- thingnames])
-
-mk_new	:: RdrNameContext
-	-> (RdrName, [FAST_STRING])
-	-> (RdrName, RdrNameMonoType)
-	-> (LocalTyDefsMap, LocalValDefsMap)
-
-mk_new ctxt (qtycon@(Qual mod1 tycon), tyvars) (qconname@(Qual mod2 conname), ty)
-  = ASSERT(mod1 == mod2)
-    let
-	qtyvars = map Unqual tyvars
-	constr  = NewConDecl qconname ty mkIfaceSrcLoc
-	
-	decl = NewTypeSig qtycon qconname mkIfaceSrcLoc $
-		TyNew ctxt qtycon qtyvars [constr] Nothing noDataPragmas mkIfaceSrcLoc
-    in
-    (unitFM tycon decl, unitFM conname decl)
-
-mk_class :: RdrNameContext
-	 -> (RdrName, RdrName)
-	 -> [(FAST_STRING, RdrNameSig)]
-	 -> (LocalTyDefsMap, LocalValDefsMap)
-
-mk_class ctxt (qclas@(Qual mod clas), tyvar) ops_and_sigs
-  = case (unzip ops_and_sigs) of { (opnames, sigs) ->
-    let
-	qopnames = map (Qual mod) opnames
-	op_sigs	 = map opify sigs
-
-	decl = ClassSig qclas qopnames mkIfaceSrcLoc $
-		ClassDecl ctxt qclas tyvar op_sigs EmptyMonoBinds noClassPragmas mkIfaceSrcLoc
-    in
-    (unitFM clas decl, listToFM [(o,decl) | o <- opnames]) }
-  where
-    opify (Sig f ty _ loc) = ClassOpSig f ty noClassOpPragmas loc
-
-mk_inst	:: [RdrName]
-	-> RdrNameContext
-	-> RdrName -- class
-	-> RdrNameMonoType  -- fish the tycon out yourself...
-	-> RdrIfaceInst
-
-mk_inst	tvs ctxt qclas@(Qual cmod cname) mono_ty
-  = let
-	ty = HsForAllTy tvs ctxt mono_ty
-    in
-    -- pprTrace "mk_inst:" (ppr PprDebug ty) $
-    InstSig qclas (tycon_name mono_ty) mkIfaceSrcLoc $ \ mod ->
-	InstDecl qclas ty
-	    EmptyMonoBinds False{-not from_here-} mod [{-sigs-}]
-	    noInstancePragmas mkIfaceSrcLoc
-  where
-    tycon_name (MonoTyApp tc _) = tc
-    tycon_name (MonoListTy   _) = preludeQual SLIT("[]")
-    tycon_name (MonoFunTy  _ _) = preludeQual SLIT("->")
-    tycon_name (MonoTupleTy ts) = preludeQual (mkTupNameStr (length ts))
-
------------------------------------------------------------------
-lexIface :: String -> [IfaceToken]
-
-lexIface input
-  = _scc_ "Lexer"
-    case input of
-      []    -> []
-
-      -- whitespace and comments
-      ' '	: cs -> lexIface cs
-      '\t'	: cs -> lexIface cs
-      '\n'	: cs -> lexIface cs
-      '-' : '-' : cs -> lex_comment cs
-      '{' : '-' : cs -> lex_nested_comment 1{-one seen-} cs
-
-      '(' : '.' : '.' : ')' : cs -> ITdotdot	: lexIface cs
-      '{' : '{' 	    : cs -> ITdocurly	: lexIface cs
-      '}' : '}' 	    : cs -> ITdccurly	: lexIface cs
-      '{'		    : cs -> ITocurly	: lexIface cs
-      '}'		    : cs -> ITccurly	: lexIface cs
-      '('		    : cs -> IToparen	: lexIface cs
-      ')'		    : cs -> ITcparen	: lexIface cs
-      '['		    : cs -> ITobrack	: lexIface cs
-      ']'		    : cs -> ITcbrack	: lexIface cs
-      ','		    : cs -> ITcomma	: lexIface cs
-      ';'		    : cs -> ITsemi	: lexIface cs
-      
-      '_' : '_' : cs -> lex_keyword cs
-
-      c : cs | isUpper c	 -> lex_word input -- don't know if "Module." on front or not
-	     | isDigit c 	 -> lex_num  input
-	     | isAlpha c	 -> lex_name Nothing is_var_sym input
-	     | is_sym_sym c	 -> lex_name Nothing is_sym_sym input
-	     
-      other -> error ("lexing:"++other)
-  where
-    lex_comment str
-      = case (span ((/=) '\n') str) of { (junk, rest) ->
-	lexIface rest }
-
-    ------------------
-    lex_nested_comment lvl [] = error "EOF in nested comment in interface"
-    lex_nested_comment lvl str
-      = case str of
-	  '{' : '-' : xs -> lex_nested_comment (lvl+1) xs
-	  '-' : '}' : xs -> if lvl == 1
-			    then lexIface xs
-			    else lex_nested_comment (lvl-1) xs
-	  _	    : xs -> lex_nested_comment lvl xs
-
-    -----------
-    lex_num str
-      = case (span isDigit str) of { (num, rest) ->
-	ITinteger (read num) : lexIface rest }
-
-    -----------
-    is_var_sym c    = isAlphanum c || c `elem` "_'#"
-	 -- the last few for for Glasgow-extended names
-
-    is_var_sym1 '\'' = False
-    is_var_sym1 '#'  = False
-    is_var_sym1 '_'  = False
-    is_var_sym1 c    = is_var_sym c
-
-    is_sym_sym c = c `elem` ":!#$%&*+./<=>?@\\^|-~" -- ToDo: add ISOgraphic
-
-    is_list_sym '[' = True
-    is_list_sym ']' = True
-    is_list_sym _   = False
-
-    is_tuple_sym '(' = True
-    is_tuple_sym ')' = True
-    is_tuple_sym ',' = True
-    is_tuple_sym _   = False
-
-    ------------
-    lex_word str@(c:cs) -- we know we have a capital letter to start
-      = -- we first try for "<module>." on the front...
-	case (module_dot str) of
-	  Nothing       -> lex_name Nothing  (in_the_club str)  str
-	  Just (m,rest) -> lex_name (Just m) (in_the_club rest) rest
-      where
-	in_the_club []    = panic "lex_word:in_the_club"
-	in_the_club (x:y) | isAlpha    x = is_var_sym
-			  | is_sym_sym x = is_sym_sym
-			  | x == '['	 = is_list_sym
-			  | x == '('	 = is_tuple_sym
-			  | otherwise    = panic ("lex_word:in_the_club="++(x:y))
-
-    module_dot (c:cs)
-      = if not (isUpper c) || c == '\'' then
-	   Nothing
-	else
-	   case (span is_var_sym cs) of { (word, rest) ->
-	   case rest of
-	     []		       -> Nothing
-	     (r:rs) | r == '.' -> Just (_PK_ (c:word), rs)
-	     _		       -> Nothing
-	   }
-
-    lex_keyword str
-      = case (span is_var_sym str)    of { (kw, rest) ->
-	case (lookupFM keywordsFM kw) of
-	  Nothing -> panic ("lex_keyword:"++str)
-	  Just xx -> xx : lexIface rest
-	}
-
-    lex_name module_dot in_the_club str
-      =	case (span in_the_club str)     of { (word, rest) ->
-	case (lookupFM keywordsFM word) of
-	  Just xx -> let
-			cont = xx : lexIface rest
-		     in
-		     case xx of
-		       ITbang -> case module_dot of
-				   Nothing -> cont
-				   Just  m -> ITqvarsym (Qual m SLIT("!"))
-					      : lexIface rest
-		       _ -> cont
-	  Nothing -> 
-	    (let
-		f = head word -- first char
-		n = _PK_ word
-	     in
-	     case module_dot of
-	       Nothing ->
-		 categ f n (ITconid  n) (ITvarid  n) (ITconsym  n) (ITvarsym  n)
-	       Just m ->
-		 let
-		     q = Qual m n
-		 in
-		 categ f n (ITqconid q) (ITqvarid q) (ITqconsym q) (ITqvarsym q)
-
-	     ) : lexIface rest ;
-	}
-    ------------
-    categ f n conid varid consym varsym
-      = if f == '[' || f == '(' then
-	   conid
-	else if isLexConId  n then conid
-	else if isLexVarId  n then varid
-	else if isLexConSym n then consym
-	else			   varsym
-
-    ------------
-    keywordsFM :: FiniteMap String IfaceToken
-    keywordsFM = listToFM [
-	("interface",	 ITinterface)
-
-       ,("usages__",		ITusages)
-       ,("versions__",		ITversions)
-       ,("exports__",		ITexports)
-       ,("instance_modules__",	ITinstance_modules)
-       ,("instances__",		ITinstances)
-       ,("fixities__",		ITfixities)
-       ,("declarations__",	ITdeclarations)
-       ,("pragmas__",		ITpragmas)
-       ,("forall__",		ITforall)
-
-       ,("data",		ITdata)
-       ,("type",		ITtype)
-       ,("newtype",		ITnewtype)
-       ,("class",		ITclass)
-       ,("where",		ITwhere)
-       ,("instance",		ITinstance)
-       ,("infixl",		ITinfixl)
-       ,("infixr",		ITinfixr)
-       ,("infix",		ITinfix)
-
-       ,("->",			ITrarrow)
-       ,("|",			ITvbar)
-       ,("!",			ITbang)
-       ,("::",			ITdcolon)
-       ,("=>",			ITdarrow)
-       ,("=",			ITequal)
-       ]
-
------------------------------------------------------------------
-type IfM a = MaybeErr a Error
-
-returnIf   :: a -> IfM a
-thenIf	   :: IfM a -> (a -> IfM b) -> IfM b
-happyError :: Int -> [IfaceToken] -> IfM a
-
-returnIf a = Succeeded a
-
-thenIf (Succeeded a) k = k a
-thenIf (Failed  err) _ = Failed err
-
-happyError ln toks = Failed (ifaceParseErr ln toks)
------------------------------------------------------------------
-
-ifaceParseErr ln toks sty
-  = ppCat [ppPStr SLIT("Interface-file parse error: line"), ppInt ln, ppStr "toks=", ppStr (show (take 10 toks))]
-\end{code}
diff --git a/ghc/compiler/rename/Rename.lhs b/ghc/compiler/rename/Rename.lhs
index 54348b99c8..cd531b8fc5 100644
--- a/ghc/compiler/rename/Rename.lhs
+++ b/ghc/compiler/rename/Rename.lhs
@@ -14,245 +14,187 @@ IMP_Ubiq()
 IMPORT_1_3(List(partition))
 
 import HsSyn
-import RdrHsSyn		( SYN_IE(RdrNameHsModule), SYN_IE(RdrNameImportDecl) )
-import RnHsSyn		( RnName(..){-.. is for Ix hack only-}, SYN_IE(RenamedHsModule), isRnTyConOrClass, isRnWired )
-
---ToDo:rm: all for debugging only
---import Maybes
---import Name
---import Outputable
---import RnIfaces
---import PprStyle
---import Pretty
---import FiniteMap
---import Util (pprPanic, pprTrace)
-
-import ParseUtils	( ParsedIface(..), RdrIfaceDecl(..), RdrIfaceInst(..),
-			  UsagesMap(..), VersionsMap(..)
-			)
-import RnMonad
-import RnNames		( getGlobalNames, SYN_IE(GlobalNameInfo) )
-import RnSource		( rnSource )
-import RnIfaces		( rnIfaces, initIfaceCache, IfaceCache )
-import RnUtils		( SYN_IE(RnEnv), extendGlobalRnEnv, emptyRnEnv )
+import RdrHsSyn		( RdrName, SYN_IE(RdrNameHsModule), SYN_IE(RdrNameImportDecl) )
+import RnHsSyn		( SYN_IE(RenamedHsModule), SYN_IE(RenamedHsDecl), extractHsTyNames )
 
-import Bag		( isEmptyBag, unionBags, unionManyBags, bagToList, listToBag )
-import CmdLineOpts	( opt_HiMap, opt_NoImplicitPrelude )
+import CmdLineOpts	( opt_HiMap )
+import RnMonad
+import RnNames		( getGlobalNames )
+import RnSource		( rnDecl )
+import RnIfaces		( getImportedInstDecls, getDecl, getImportVersions, getSpecialInstModules,
+			  mkSearchPath, getWiredInDecl
+			)
+import RnEnv		( availsToNameSet, addAvailToNameSet, addImplicitOccsRn )
+import Id		( GenId {- instance NamedThing -} )
+import Name		( Name, Provenance, ExportFlag(..), isLocallyDefined,
+			  NameSet(..), elemNameSet, mkNameSet, unionNameSets, nameSetToList,
+			  isWiredInName, modAndOcc
+			)
+import TysWiredIn	( unitTyCon, intTyCon, doubleTyCon )
+import TyCon		( TyCon )
 import ErrUtils		( SYN_IE(Error), SYN_IE(Warning) )
 import FiniteMap	( emptyFM, eltsFM, fmToList, addToFM, FiniteMap )
-import Maybes		( catMaybes )
-import Name		( isLocallyDefined, mkWiredInName, getLocalName, isLocalName,
-			  origName,
-			  Name, RdrName(..), ExportFlag(..)
-			)
---import PprStyle		-- ToDo:rm
-import PrelInfo		( builtinNameMaps, builtinKeysMap, SYN_IE(BuiltinNames), SYN_IE(BuiltinKeys) )
 import Pretty
-import Unique		( ixClassKey )
-import UniqFM		( emptyUFM, lookupUFM, addListToUFM_C, eltsUFM )
-import UniqSupply	( splitUniqSupply )
-import Util		( panic, assertPanic{-, pprTrace ToDo:rm-} )
+import PprStyle		( PprStyle(..) )
+import Util		( panic, assertPanic, pprTrace )
 \end{code}
 
+
+
 \begin{code}
 renameModule :: UniqSupply
 	     -> RdrNameHsModule
-
-	     -> IO (RenamedHsModule, 	-- output, after renaming
-		    RnEnv,		-- final env (for renaming derivings)
-		    [Module],	   	-- imported modules; for profiling
-
-		    (Name -> ExportFlag,	-- export info
-		     ([(Name,ExportFlag)],
-		      [(Name,ExportFlag)])),
-
-		    (UsagesMap,
-	            VersionsMap,      	-- version info; for usage
-		    [Module]),	   	-- instance modules; for iface
-
-		    Bag Error,
-		    Bag Warning)
+	     -> IO (Maybe 			-- Nothing <=> everything up to date;
+						-- no ned to recompile any further
+			  (RenamedHsModule, 	-- Output, after renaming
+			   InterfaceDetails,	-- Interface; for interface file generatino
+			   RnNameSupply,	-- Final env; for renaming derivings
+			   [Module]),	   	-- Imported modules; for profiling
+		    Bag Error, 
+		    Bag Warning
+		   )
 \end{code} 
 
-ToDo: May want to arrange to return old interface for this module!
-ToDo: Deal with instances (instance version, this module on instance list ???)
 
 \begin{code}
-renameModule us input@(HsModule modname _ _ imports _ _ _ _ _ _ _ _ _ _)
-
-  = {-
-    let
-	pp_pair (n,m) = ppBesides [ppPStr m,ppChar '.',ppPStr n]
-    in
-    pprTrace "builtins:\n" (case builtinNameMaps of { (builtin_ids, builtin_tcs) ->
-    			    ppAboves [ ppCat (map pp_pair (keysFM builtin_ids))
-    				     , ppCat (map pp_pair (keysFM builtin_tcs))
-    				     , ppCat (map pp_pair (keysFM builtinKeysMap))
-    				     ]}) $
-    -}
-    -- _scc_ "rnGlobalNames"
-    makeHiMap opt_HiMap	    >>=	         \ hi_files ->
---  pprTrace "HiMap:\n" (ppAboves [ ppCat [ppPStr m, ppStr p] | (m,p) <- fmToList hi_files])
-    initIfaceCache modname hi_files  >>= \ iface_cache ->
-
-    fixIO ( \ ~(_, _, _, _, rec_occ_fm, ~(rec_export_fn,_)) ->
+renameModule us this_mod@(HsModule mod_name vers exports imports fixities local_decls loc)
+  = 	-- INITIALISE THE RENAMER MONAD
+    initRn mod_name us (mkSearchPath opt_HiMap) loc $
+
+ 	-- FIND THE GLOBAL NAME ENVIRONMENT
+    getGlobalNames this_mod			`thenRn` \ global_name_info ->
+
+    case global_name_info of {
+	Nothing -> 	-- Everything is up to date; no need to recompile further
+			returnRn Nothing ;
+
+			-- Otherwise, just carry on
+	Just (export_env, rn_env, local_avails) ->
+
+	-- RENAME THE SOURCE
+	-- We also add occurrences for Int, Double, and (), because they
+	-- are the types to which ambigious type variables may be defaulted by
+	-- the type checker; so they won't every appear explicitly.
+	-- [The () one is a GHC extension for defaulting CCall results.]
+    initRnMS rn_env mod_name SourceMode (mapRn rnDecl local_decls)	`thenRn` \ rn_local_decls ->
+    addImplicitOccsRn [getName intTyCon, 
+		       getName doubleTyCon, 
+		       getName unitTyCon]		`thenRn_` 
+
+	-- SLURP IN ALL THE NEEDED DECLARATIONS
+	-- Notice that the rnEnv starts empty
+    closeDecls rn_local_decls (availsToNameSet local_avails) []
+       						`thenRn` \ (rn_all_decls, imported_avails) ->
+
+	-- SLURP IN ALL NEEDED INSTANCE DECLARATIONS
+	-- We keep the ones that only mention things (type constructors, classes) that are
+	-- already imported.  Ones which don't can't possibly be useful to us.
+    getImportedInstDecls 				`thenRn` \ imported_insts ->
     let
-	rec_occ_fn :: Name -> [RdrName]
-	rec_occ_fn n = case lookupUFM rec_occ_fm n of
-		         Nothing        -> []
-		         Just (rn,occs) -> occs
+	all_big_names = mkNameSet [name | Avail name _ <- local_avails]    `unionNameSets` 
+			mkNameSet [name | Avail name _ <- imported_avails]
 
-	global_name_info = (builtinNameMaps, builtinKeysMap, rec_export_fn, rec_occ_fn)
+	rn_needed_insts = [ initRnMS emptyRnEnv mod_name InterfaceMode (rnDecl (InstD inst_decl))
+			  | (inst_names, mod_name, inst_decl) <- imported_insts,
+			    all (`elemNameSet` all_big_names) inst_names
+			  ]
     in
-    getGlobalNames iface_cache global_name_info us1 input >>=
-	\ (occ_env, imp_mods, unqual_imps, imp_fixes, top_errs, top_warns) ->
+    sequenceRn rn_needed_insts				`thenRn` \ inst_decls ->
+	-- Maybe we need to do another close-decls?
 
-    if not (isEmptyBag top_errs) then
-	return (rn_panic, rn_panic, top_errs, top_warns, emptyUFM, rn_panic)
-    else
 
-    -- No top-level name errors so rename source ...
-    -- _scc_ "rnSource"
-    case initRn True modname occ_env us2
-		(rnSource imp_mods unqual_imps imp_fixes input) of {
-	((rn_module, export_fn, module_dotdots, src_occs), src_errs, src_warns) ->
+	-- GENERATE THE VERSION/USAGE INFO
+    getImportVersions imported_avails			`thenRn` \ import_versions ->
+    getNameSupplyRn					`thenRn` \ name_supply ->
 
-    --pprTrace "renameModule:" (ppCat (map (ppr PprDebug . fst) (bagToList src_occs))) $
-    let
-	occ_fm :: UniqFM (RnName, [RdrName])
 
-	occ_list = [ (rn,(rn,[occ])) | (rn,occ) <- bagToList src_occs]
-        occ_fm = addListToUFM_C insert_occ emptyUFM occ_list
-
-	insert_occ (rn,olds) (rn',[new]) = (rn, insert new olds)
-
-        insert new []         = [new]
-        insert new xxs@(x:xs) = case cmp new x of LT_  -> new : xxs
-			      			  EQ_  -> xxs
-			      			  GT__ -> x : insert new xs
-
-	occ_warns = map multipleOccWarn (filter multiple_occs (eltsUFM occ_fm))
-
-	multiple_occs (rn, (o1:o2:_)) = getLocalName o1 /= SLIT("negate")
-					-- the user is rarely responsible if
-					-- "negate" is mentioned in multiple ways
-	multiple_occs _               = False
+	-- GENERATE THE SPECIAL-INSTANCE MODULE LIST
+	-- The "special instance" modules are those modules that contain instance
+	-- declarations that contain no type constructor or class that was declared
+	-- in that module.
+    getSpecialInstModules				`thenRn` \ imported_special_inst_mods ->
+    let
+	special_inst_decls = [d | InstD d@(InstDecl inst_ty _ _ _ _) <- rn_local_decls,
+				  all (not.isLocallyDefined) (nameSetToList (extractHsTyNames inst_ty))
+			     ]
+	special_inst_mods | null special_inst_decls = imported_special_inst_mods
+			  | otherwise		    = mod_name : imported_special_inst_mods
     in
-    return (rn_module, imp_mods, 
-	    top_errs  `unionBags` src_errs,
-	    top_warns `unionBags` src_warns `unionBags` listToBag occ_warns,
-	    occ_fm, (export_fn, module_dotdots))
-
-    }) >>= \ (rn_module, imp_mods, errs_so_far, warns_so_far, occ_fm, export_stuff) ->
+		  
+    
 
-    if not (isEmptyBag errs_so_far) then
-	return (rn_panic, rn_panic, rn_panic, rn_panic, rn_panic, errs_so_far, warns_so_far)
-    else
-
-    -- No errors renaming source so rename the interfaces ...
-    -- _scc_ "preRnIfaces"
+	-- RETURN THE RENAMED MODULE
     let
-	-- split up all names that occurred in the source; between
-	-- those that are defined therein and those merely mentioned.
-	-- We also divide by tycon/class and value names (as usual).
-
-	occ_rns = [ rn | (rn,_) <- eltsUFM occ_fm ]
-		-- all occurrence names, from this module and imported
-
-	(defined_here, defined_elsewhere)
-	  = partition isLocallyDefined occ_rns
-
-	(_, imports_used)
-          = partition isRnWired defined_elsewhere
-
-	(def_tcs, def_vals) = partition isRnTyConOrClass defined_here
-	(occ_tcs, occ_vals) = partition isRnTyConOrClass occ_rns
-		-- the occ stuff includes *all* occurrences,
-		-- including those for which we have definitions
-
-	(orig_def_env, orig_def_dups)
-	  = extendGlobalRnEnv emptyRnEnv (map pairify_rn def_vals)
-					 (map pairify_rn def_tcs)
-	(orig_occ_env, orig_occ_dups)
-	  = extendGlobalRnEnv emptyRnEnv (map pairify_rn occ_vals)
-					 (map pairify_rn occ_tcs)
-
-	-- This stuff is pretty dodgy right now: I think original
-	-- names and occurrence names may be getting entangled
-	-- when they shouldn't be... WDP 96/06
-
-        pairify_rn rn -- ToDo: move to Name?
-	  = let
-		name = getName rn
-	    in
-	    (if isLocalName name
-	     then Unqual (getLocalName name)
-	     else case (origName "pairify_rn" name) of { OrigName m n ->
-		  Qual m n }
-	     , rn)
+	import_mods = [mod | ImportDecl mod _ _ _ _ <- imports]
+
+	renamed_module = HsModule mod_name vers 
+				  trashed_exports trashed_imports trashed_fixities
+				  (inst_decls ++ rn_all_decls)
+			          loc
     in
---  ASSERT (isEmptyBag orig_occ_dups)
---    (if (isEmptyBag orig_occ_dups) then \x->x
---     else pprTrace "orig_occ_dups:" (ppAboves [ ppCat [ppr PprDebug m, ppr PprDebug n, ppr PprDebug o] | (m,n,o) <- bagToList orig_occ_dups])) $
-    ASSERT (isEmptyBag orig_def_dups)
-
-    -- _scc_ "rnIfaces"
-    rnIfaces iface_cache imp_mods us3 orig_def_env orig_occ_env
-	     rn_module (initMustHaves ++ imports_used) >>=
-	\ (rn_module_with_imports, final_env,
-	   (implicit_val_fm, implicit_tc_fm),
-	   usage_stuff,
-	   (iface_errs, iface_warns)) ->
-
-    return (rn_module_with_imports,
-	    final_env,
-	    imp_mods,
-	    export_stuff,
-	    usage_stuff,
-	    errs_so_far  `unionBags` iface_errs,
-	    warns_so_far `unionBags` iface_warns)
+    returnRn (Just (renamed_module, 
+		    (import_versions, export_env, special_inst_mods),
+		     name_supply,
+		     import_mods))
+    }
   where
-    rn_panic = panic "renameModule: aborted with errors"
-
-    (us1, us') = splitUniqSupply us
-    (us2, us3) = splitUniqSupply us'
-
-initMustHaves :: [RnName]
-    -- things we *must* find declarations for, because the
-    -- compiler may eventually make reference to them (e.g.,
-    -- class Eq)
-initMustHaves
-  | opt_NoImplicitPrelude
-  = [{-no Prelude.hi, no point looking-}]
-  | otherwise
-  = [ name_fn (mkWiredInName u orig ExportAll)
-    | (orig@(OrigName mod str), (u, name_fn)) <- fmToList builtinKeysMap ]
+    trashed_exports  = {-trace "rnSource:trashed_exports"-} Nothing
+    trashed_imports  = {-trace "rnSource:trashed_imports"-} []
+    trashed_fixities = []
 \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)
+closeDecls :: [RenamedHsDecl]			-- Declarations got so far
+	   -> NameSet				-- Names bound by those declarations
+	   -> [AvailInfo]			-- Available stuff generated by closeDecls so far
+	   -> RnMG ([RenamedHsDecl],		-- The closed set
+		    [AvailInfo])		-- Available stuff generated by closeDecls
+	-- The monad includes a list of possibly-unresolved Names
+	-- This list is empty when closeDecls returns
+
+closeDecls decls decl_names import_avails
+  = popOccurrenceName		`thenRn` \ maybe_unresolved ->
+
+    case maybe_unresolved of
+
+	-- No more unresolved names; we're done
+	Nothing ->	returnRn (decls, import_avails)
+
+	-- An "unresolved" name that we've already dealt with
+	Just (name,_) | name `elemNameSet` decl_names 
+	  -> closeDecls decls decl_names import_avails
+	
+	-- An unresolved name that's wired in.  In this case there's no 
+	-- declaration to get, but we still want to record it as now available,
+	-- so that we remember to look for instance declarations involving it.
+	Just (name,_) | isWiredInName name
+	  -> getWiredInDecl name	`thenRn` \ decl_avail ->
+		     closeDecls decls 
+				(addAvailToNameSet decl_names decl_avail)
+				(decl_avail : import_avails)
+
+	-- Genuinely unresolved name
+	Just (name,necessity) | otherwise
+	  -> getDecl name		`thenRn` \ (decl_avail,new_decl) ->
+	     case decl_avail of
+
+		-- Can't find the declaration; check that it was optional
+		NotAvailable -> checkRn (case necessity of { Optional -> True; other -> False})
+					(getDeclErr name)	`thenRn_` 
+				closeDecls decls decl_names import_avails
+
+		-- Found it
+		other -> initRnMS emptyRnEnv mod_name InterfaceMode (
+				     rnDecl new_decl
+			 )				`thenRn` \ rn_decl ->
+			 closeDecls (rn_decl : decls)
+				    (addAvailToNameSet decl_names decl_avail)
+				    (decl_avail : import_avails)
+		     where
+		         (mod_name,_) = modAndOcc name
+
+getDeclErr name sty
+  = ppSep [ppStr "Failed to find interface decl for", ppr sty name]
 \end{code}
 
-Warning message used herein:
-\begin{code}
-multipleOccWarn (name, occs) sty
-  = ppBesides [ppStr "warning:multiple names used to refer to `", ppr sty name, ppStr "': ",
-	       ppInterleave ppComma (map (ppr sty) occs)]
-\end{code}
+
diff --git a/ghc/compiler/rename/RnBinds.lhs b/ghc/compiler/rename/RnBinds.lhs
index ced653a84e..0ff8016cb6 100644
--- a/ghc/compiler/rename/RnBinds.lhs
+++ b/ghc/compiler/rename/RnBinds.lhs
@@ -12,11 +12,9 @@ they may be affected by renaming (which isn't fully worked out yet).
 #include "HsVersions.h"
 
 module RnBinds (
-	rnTopBinds,
+	rnTopBinds, rnTopMonoBinds,
 	rnMethodBinds,
-	rnBinds,
-	SYN_IE(FreeVars),
-	SYN_IE(DefinedVars)
+	rnBinds, rnMonoBinds
    ) where
 
 IMP_Ubiq()
@@ -28,18 +26,25 @@ import RdrHsSyn
 import RnHsSyn
 import RnMonad
 import RnExpr		( rnMatch, rnGRHSsAndBinds, rnPat, checkPrecMatch )
+import RnEnv		( bindLocatedLocalsRn, lookupRn, lookupOccRn, isUnboundName )
 
 import CmdLineOpts	( opt_SigsRequired )
 import Digraph		( stronglyConnComp )
 import ErrUtils		( addErrLoc, addShortErrLocLine )
-import Name		( getLocalName, RdrName )
+import Name		( OccName(..), Provenance, 
+			  Name {- instance Eq -},
+			  NameSet(..), emptyNameSet, mkNameSet, unionNameSets, 
+		 	  minusNameSet, unionManyNameSets, elemNameSet, unitNameSet, nameSetToList
+			)
 import Maybes		( catMaybes )
 --import PprStyle--ToDo:rm
 import Pretty
-import UniqSet		( emptyUniqSet, unitUniqSet, mkUniqSet,
-			  unionUniqSets, unionManyUniqSets,
-			  elementOfUniqSet, uniqSetToList, SYN_IE(UniqSet) )
 import Util		( thenCmp, isIn, removeDups, panic, panic#, assertPanic )
+import UniqSet		( SYN_IE(UniqSet) )
+import ListSetOps	( minusList )
+import Bag		( bagToList )
+import UniqFM		( UniqFM )
+import ErrUtils		( SYN_IE(Error) )
 \end{code}
 
 -- ToDo: Put the annotations into the monad, so that they arrive in the proper
@@ -64,15 +69,6 @@ This is precisely what the function @rnBinds@ does.
 ToDo: deal with case where a single monobinds binds the same variable
 twice.
 
-Sets of variable names are represented as sets explicitly, rather than lists.
-
-\begin{code}
-type DefinedVars = UniqSet RnName
-type FreeVars    = UniqSet RnName
-\end{code}
-
-i.e., binders.
-
 The vertag tag is a unique @Int@; the tags only need to be unique
 within one @MonoBinds@, so that unique-Int plumbing is done explicitly
 (heavy monad machinery not needed).
@@ -88,6 +84,7 @@ type Edge	= (VertexTag, VertexTag)
 %* naming conventions							*
 %*									*
 %************************************************************************
+
 \subsection[name-conventions]{Name conventions}
 
 The basic algorithm involves walking over the tree and returning a tuple
@@ -114,6 +111,7 @@ a set of variables free in @Exp@ is written @fvExp@
 %* analysing polymorphic bindings (HsBinds, Bind, MonoBinds)		*
 %*									*
 %************************************************************************
+
 \subsubsection[dep-HsBinds]{Polymorphic bindings}
 
 Non-recursive expressions are reconstructed without any changes at top
@@ -154,52 +152,52 @@ instance declarations.	It expects only to see @FunMonoBind@s, and
 it expects the global environment to contain bindings for the binders
 (which are all class operations).
 
+%************************************************************************
+%*									*
+%* 		Top-level bindings
+%*									*
+%************************************************************************
+
+@rnTopBinds@ and @rnTopMonoBinds@ assume that the environment already
+contains bindings for the binders of this particular binding.
+
 \begin{code}
-rnTopBinds    :: RdrNameHsBinds -> RnM_Fixes s RenamedHsBinds
-rnMethodBinds :: RnName{-class-} -> RdrNameMonoBinds -> RnM_Fixes s RenamedMonoBinds
-rnBinds	      :: RdrNameHsBinds -> RnM_Fixes s (RenamedHsBinds, FreeVars, [RnName])
+rnTopBinds    :: RdrNameHsBinds -> RnMS s RenamedHsBinds
 
-rnTopBinds EmptyBinds		       	   = returnRn EmptyBinds
+rnTopBinds EmptyBinds		       	  = returnRn EmptyBinds
 rnTopBinds (SingleBind (RecBind bind))    = rnTopMonoBinds bind []
 rnTopBinds (BindWith (RecBind bind) sigs) = rnTopMonoBinds bind sigs
-  -- the parser doesn't produce other forms
-
--- ********************************************************************
-
-rnMethodBinds class_name EmptyMonoBinds = returnRn EmptyMonoBinds
-
-rnMethodBinds class_name (AndMonoBinds mb1 mb2)
-  = andRn AndMonoBinds (rnMethodBinds class_name mb1)
-		       (rnMethodBinds class_name mb2)
+  -- The parser doesn't produce other forms
 
-rnMethodBinds class_name (FunMonoBind occname inf matches locn)
-  = pushSrcLocRn locn				   $
-    lookupClassOp class_name occname  		   `thenRn` \ op_name ->
-    mapAndUnzipRn rnMatch matches		   `thenRn` \ (new_matches, _) ->
-    mapRn (checkPrecMatch inf op_name) new_matches `thenRn_`
-    returnRn (FunMonoBind op_name inf new_matches locn)
-
-rnMethodBinds class_name (PatMonoBind (VarPatIn occname) grhss_and_binds locn)
-  = pushSrcLocRn locn			$
-    lookupClassOp class_name occname	`thenRn` \ op_name ->
-    rnGRHSsAndBinds grhss_and_binds	`thenRn` \ (grhss_and_binds', _) ->
-    returnRn (PatMonoBind (VarPatIn op_name) grhss_and_binds' locn)
 
--- Can't handle method pattern-bindings which bind multiple methods.
-rnMethodBinds _ mbind@(PatMonoBind other_pat _ locn)
-  = failButContinueRn EmptyMonoBinds (methodBindErr mbind locn)
+rnTopMonoBinds :: RdrNameMonoBinds 
+	       -> [RdrNameSig] 
+	       -> RnMS s RenamedHsBinds
 
--- ********************************************************************
+rnTopMonoBinds EmptyMonoBinds sigs 
+  = returnRn EmptyBinds
 
-rnBinds EmptyBinds			= returnRn (EmptyBinds,emptyUniqSet,[])
-rnBinds (SingleBind (RecBind bind))	= rnNestedMonoBinds bind []
-rnBinds (BindWith (RecBind bind) sigs) = rnNestedMonoBinds bind sigs
-  -- the parser doesn't produce other forms
+rnTopMonoBinds mbinds sigs
+ =  mapRn lookupRn binder_rdr_names	`thenRn` \ binder_names ->
+    let
+	binder_set = mkNameSet binder_names
+    in
+    rn_mono_binds True {- top level -}
+		  binder_set mbinds sigs		`thenRn` \ (new_binds, fv_set) ->
+    returnRn new_binds
+  where
+    binder_rdr_names = map fst (bagToList (collectMonoBinders mbinds))
 \end{code}
 
-@rnNestedMonoBinds@
+%************************************************************************
+%*									*
+%* 		Nested binds
+%*									*
+%************************************************************************
+
+@rnMonoBinds@
 	- collects up the binders for this declaration group,
-	- checkes that they form a set
+	- checks that they form a set
 	- extends the environment to bind them to new local names
 	- calls @rnMonoBinds@ to do the real work
 
@@ -208,102 +206,78 @@ already done in pass3.	All it does is call @rnMonoBinds@ and discards
 the free var info.
 
 \begin{code}
-rnTopMonoBinds :: RdrNameMonoBinds -> [RdrNameSig] -> RnM_Fixes s RenamedHsBinds
+rnBinds	      :: RdrNameHsBinds 
+	      -> (RenamedHsBinds -> RnMS s (result, FreeVars))
+	      -> RnMS s (result, FreeVars)
 
-rnTopMonoBinds EmptyMonoBinds sigs = returnRn EmptyBinds
-
-rnTopMonoBinds mbs sigs
- = rnBindSigs True{-top-level-} (collectMonoBinders mbs) sigs `thenRn` \ siglist ->
-   rnMonoBinds mbs siglist `thenRn` \ (new_binds, fv_set) ->
-   returnRn new_binds
+rnBinds EmptyBinds		       thing_inside = thing_inside EmptyBinds
+rnBinds (SingleBind (RecBind bind))    thing_inside = rnMonoBinds bind []   thing_inside
+rnBinds (BindWith (RecBind bind) sigs) thing_inside = rnMonoBinds bind sigs thing_inside
+  -- the parser doesn't produce other forms
 
 
-rnNestedMonoBinds :: RdrNameMonoBinds -> [RdrNameSig]
-		  -> RnM_Fixes s (RenamedHsBinds, FreeVars, [RnName])
+rnMonoBinds :: RdrNameMonoBinds -> [RdrNameSig]
+	    -> (RenamedHsBinds -> RnMS s (result, FreeVars))
+	    -> RnMS s (result, FreeVars)
 
-rnNestedMonoBinds EmptyMonoBinds sigs
-  = returnRn (EmptyBinds, emptyUniqSet, [])
+rnMonoBinds EmptyMonoBinds sigs thing_inside = thing_inside EmptyBinds
 
-rnNestedMonoBinds mbinds sigs	-- Non-empty monobinds
-  =
-	-- Extract all the binders in this group,
+rnMonoBinds mbinds sigs	thing_inside -- Non-empty monobinds
+  =	-- Extract all the binders in this group,
 	-- and extend current scope, inventing new names for the new binders
 	-- This also checks that the names form a set
+    bindLocatedLocalsRn "binding group" mbinders_w_srclocs		$ \ new_mbinders ->
     let
-	mbinders_w_srclocs = collectMonoBindersAndLocs mbinds
-	mbinders    	   = map fst mbinders_w_srclocs
+	binder_set = mkNameSet new_mbinders
     in
-    newLocalNames "variable"
-		  mbinders_w_srclocs	`thenRn` \ new_mbinders ->
-
-    extendSS2 new_mbinders (
-	 rnBindSigs False{-not top- level-} mbinders sigs `thenRn` \ siglist ->
-	 rnMonoBinds mbinds  siglist
-    )					`thenRn` \ (new_binds, fv_set) ->
-    returnRn (new_binds, fv_set, new_mbinders)
+    rn_mono_binds False {- not top level -}
+		  binder_set mbinds sigs	`thenRn` \ (binds,bind_fvs) ->
+
+	-- Now do the "thing inside", and deal with the free-variable calculations
+    thing_inside binds					`thenRn` \ (result,result_fvs) ->
+    returnRn (result, (result_fvs `unionNameSets` bind_fvs) `minusNameSet` binder_set)
+  where
+    mbinders_w_srclocs = bagToList (collectMonoBinders mbinds)
 \end{code}
 
+
+%************************************************************************
+%*									*
+%* 		MonoBinds -- the main work is done here
+%*									*
+%************************************************************************
+
 @rnMonoBinds@ is used by *both* top-level and nested bindings.  It
 assumes that all variables bound in this group are already in scope.
-This is done *either* by pass 3 (for the top-level bindings),
-*or* by @rnNestedMonoBinds@ (for the nested ones).
+This is done *either* by pass 3 (for the top-level bindings), *or* by
+@rnNestedMonoBinds@ (for the nested ones).
 
 \begin{code}
-rnMonoBinds :: RdrNameMonoBinds
-	    -> [RenamedSig]	-- Signatures attached to this group
-	    -> RnM_Fixes s (RenamedHsBinds, FreeVars)
-
-rnMonoBinds mbinds siglist
+rn_mono_binds :: Bool			-- True <=> top level
+	      -> NameSet		-- Binders of this group
+	      -> RdrNameMonoBinds	
+	      -> [RdrNameSig]		-- Signatures attached to this group
+	      -> RnMS s (RenamedHsBinds, 	-- 
+		         FreeVars)	-- Free variables
+
+rn_mono_binds is_top_lev binders mbinds sigs
   =
 	 -- Rename the bindings, returning a MonoBindsInfo
 	 -- which is a list of indivisible vertices so far as
 	 -- the strongly-connected-components (SCC) analysis is concerned
+    rnBindSigs is_top_lev binders sigs	`thenRn` \ siglist ->
     flattenMonoBinds 0 siglist mbinds	`thenRn` \ (_, mbinds_info) ->
 
 	 -- Do the SCC analysis
-    let vertices = mkVertices mbinds_info
-	edges	= mkEdges     mbinds_info
-
-	scc_result = stronglyConnComp (==) edges vertices
+    let vertices    = mkVertices mbinds_info
+	edges	    = mkEdges     mbinds_info
+	scc_result  = stronglyConnComp (==) edges vertices
+	final_binds = foldr1 ThenBinds (map (reconstructCycle edges mbinds_info) scc_result)
 
 	 -- Deal with bound and free-var calculation
-	rhs_free_vars = foldr f emptyUniqSet mbinds_info
-
-	final_binds = reconstructRec scc_result edges mbinds_info
-
-	happy_answer = returnRn (final_binds, rhs_free_vars)
+	rhs_fvs = unionManyNameSets [fvs | (_,_,fvs,_,_) <- mbinds_info]
     in
-    case (inline_sigs_in_recursive_binds final_binds) of
-      Nothing -> happy_answer
-      Just names_n_locns ->
--- SLPJ: sometimes want recursive INLINE for worker wrapper style stuff
--- 	addErrRn (inlineInRecursiveBindsErr names_n_locns) `thenRn_`
-	{-not so-}happy_answer
-  where
-    f :: (a,b, FreeVars, c,d) -> FreeVars -> FreeVars
-
-    f (_, _, fvs_body, _, _) fvs_sofar = fvs_sofar `unionUniqSets` fvs_body
-
-    inline_sigs_in_recursive_binds (BindWith (RecBind _) sigs)
-      = case [(n, locn) | (InlineSig n locn) <- sigs ] of
-	  []   -> Nothing
-	  sigh ->
-#if OMIT_DEFORESTER
-		Just sigh
-#else
-    		-- Allow INLINEd recursive functions if they are
-		-- designated DEFORESTable too.
-		case [(n, locn) | (DeforestSig n locn) <- sigs ] of
-	  		[]   -> Just sigh
-	  		sigh -> Nothing
-#endif
-
-    inline_sigs_in_recursive_binds (ThenBinds b1 b2)
-      = case (inline_sigs_in_recursive_binds b1) of
-	  Nothing -> inline_sigs_in_recursive_binds b2
-	  Just  x -> Just x -- NB: won't report error(s) in b2
-
-    inline_sigs_in_recursive_binds anything_else = Nothing
+    returnRn (final_binds, rhs_fvs)
 \end{code}
 
 @flattenMonoBinds@ is ever-so-slightly magical in that it sticks
@@ -313,7 +287,7 @@ unique ``vertex tags'' on its output; minor plumbing required.
 flattenMonoBinds :: Int				-- Next free vertex tag
 		 -> [RenamedSig]		-- Signatures
 		 -> RdrNameMonoBinds
-		 -> RnM_Fixes s (Int, FlatMonoBindsInfo)
+		 -> RnMS s (Int, FlatMonoBindsInfo)
 
 flattenMonoBinds uniq sigs EmptyMonoBinds = returnRn (uniq, [])
 
@@ -329,64 +303,80 @@ flattenMonoBinds uniq sigs (PatMonoBind pat grhss_and_binds locn)
 
 	 -- Find which things are bound in this group
     let
-	names_bound_here = collectPatBinders pat'
-
-	sigs_etc_for_here = foldl (sig_for_here (\ n -> n `is_elem` names_bound_here))
-				  [] sigs
-
-	sigs_fvs = foldr sig_fv emptyUniqSet sigs_etc_for_here
-
-	is_elem = isIn "flattenMonoBinds"
+	names_bound_here = mkNameSet (collectPatBinders pat')
+	sigs_for_me      = filter ((`elemNameSet` names_bound_here) . sig_name) sigs
+	sigs_fvs         = foldr sig_fv emptyNameSet sigs_for_me
     in
     returnRn (
 	uniq + 1,
 	[(uniq,
-	  mkUniqSet names_bound_here,
-	   fvs `unionUniqSets` sigs_fvs,
-	   PatMonoBind pat' grhss_and_binds' locn,
-	   sigs_etc_for_here
+	  names_bound_here,
+	  fvs `unionNameSets` sigs_fvs,
+	  PatMonoBind pat' grhss_and_binds' locn,
+	  sigs_for_me
 	 )]
     )
 
 flattenMonoBinds uniq sigs (FunMonoBind name inf matches locn)
   = pushSrcLocRn locn				 $
-    lookupValue name				 `thenRn` \ name' ->
-    mapAndUnzipRn rnMatch matches		 `thenRn` \ (new_matches, fv_lists) ->
-    mapRn (checkPrecMatch inf name') new_matches `thenRn_`
+    mapRn (checkPrecMatch inf name) matches	`thenRn_`
+    lookupRn name				`thenRn` \ name' ->
+    mapAndUnzipRn rnMatch matches		`thenRn` \ (new_matches, fv_lists) ->
     let
-	fvs = unionManyUniqSets fv_lists
-
-	sigs_for_me = foldl (sig_for_here (\ n -> n == name')) [] sigs
-
-	sigs_fvs = foldr sig_fv emptyUniqSet sigs_for_me
+	fvs	    = unionManyNameSets fv_lists
+	sigs_for_me = filter ((name' ==) . sig_name) sigs
+	sigs_fvs    = foldr sig_fv emptyNameSet sigs_for_me
     in
     returnRn (
       uniq + 1,
       [(uniq,
-	unitUniqSet name',
-	fvs `unionUniqSets` sigs_fvs,
+	unitNameSet name',
+	fvs `unionNameSets` sigs_fvs,
 	FunMonoBind name' inf new_matches locn,
 	sigs_for_me
 	)]
     )
 \end{code}
 
-Grab type-signatures/user-pragmas of interest:
+
+@rnMethodBinds@ is used for the method bindings of an instance
+declaration.   like @rnMonoBinds@ but without dependency analysis.
+
 \begin{code}
-sig_for_here want_me acc s@(Sig n _ _ _)     | want_me n = s:acc
-sig_for_here want_me acc s@(InlineSig n _)   | want_me n = s:acc
-sig_for_here want_me acc s@(DeforestSig n _) | want_me n = s:acc
-sig_for_here want_me acc s@(SpecSig n _ _ _) | want_me n = s:acc
-sig_for_here want_me acc s@(MagicUnfoldingSig n _ _)
-					     | want_me n = s:acc
-sig_for_here want_me acc other_wise			 = acc
+rnMethodBinds :: RdrNameMonoBinds -> RnMS s RenamedMonoBinds
+
+rnMethodBinds EmptyMonoBinds = returnRn EmptyMonoBinds
+
+rnMethodBinds (AndMonoBinds mb1 mb2)
+  = andRn AndMonoBinds (rnMethodBinds mb1)
+		       (rnMethodBinds mb2)
+
+rnMethodBinds (FunMonoBind occname inf matches locn)
+  = pushSrcLocRn locn				   $
+    mapRn (checkPrecMatch inf occname) matches	`thenRn_`
+    lookupRn occname		  		`thenRn` \ op_name ->
+    mapAndUnzipRn rnMatch matches		`thenRn` \ (new_matches, _) ->
+    returnRn (FunMonoBind op_name inf new_matches locn)
+
+rnMethodBinds (PatMonoBind (VarPatIn occname) grhss_and_binds locn)
+  = pushSrcLocRn locn			$
+    lookupRn  occname			`thenRn` \ op_name ->
+    rnGRHSsAndBinds grhss_and_binds	`thenRn` \ (grhss_and_binds', _) ->
+    returnRn (PatMonoBind (VarPatIn op_name) grhss_and_binds' locn)
+
+-- Can't handle method pattern-bindings which bind multiple methods.
+rnMethodBinds mbind@(PatMonoBind other_pat _ locn)
+  = pushSrcLocRn locn	$
+    failWithRn EmptyMonoBinds (methodBindErr mbind)
+\end{code}
 
+\begin{code}
 -- If a SPECIALIZE pragma is of the "... = blah" form,
 -- then we'd better make sure "blah" is taken into
 -- acct in the dependency analysis (or we get an
 -- unexpected out-of-scope error)! WDP 95/07
 
-sig_fv (SpecSig _ _ (Just blah) _) acc = acc `unionUniqSets` unitUniqSet blah
+sig_fv (SpecSig _ _ (Just blah) _) acc = acc `unionNameSets` (unitNameSet blah)
 sig_fv _			   acc = acc
 \end{code}
 
@@ -400,55 +390,40 @@ This @MonoBinds@- and @ClassDecls@-specific code is segregated here,
 as the two cases are similar.
 
 \begin{code}
-reconstructRec	:: [Cycle]	-- Result of SCC analysis; at least one
-		-> [Edge]	-- Original edges
-		-> FlatMonoBindsInfo
-		-> RenamedHsBinds
+reconstructCycle :: [Edge]	-- Original edges
+		 -> FlatMonoBindsInfo
+	 	 -> Cycle
+		 -> RenamedHsBinds
 
-reconstructRec cycles edges mbi
-  = foldr1 ThenBinds (map (reconstructCycle mbi) cycles)
+reconstructCycle edges mbi cycle
+  = mk_binds this_gp_binds this_gp_sigs (isCyclic edges cycle)
   where
-    reconstructCycle :: FlatMonoBindsInfo -> Cycle -> RenamedHsBinds
-
-    reconstructCycle mbi2 cycle
-      = case [(binds,sigs) | (vertex, _, _, binds, sigs) <- mbi2, vertex `is_elem` cycle]
-		  of { relevant_binds_and_sigs ->
-
-	case (unzip relevant_binds_and_sigs) of { (binds, sig_lists) ->
-
-	case (foldr AndMonoBinds EmptyMonoBinds binds) of { this_gp_binds ->
-	let
-	    this_gp_sigs	= foldr1 (++) sig_lists
-	    have_sigs		= not (null sig_lists)
-		-- ToDo: this might not be the right
-		-- thing to call this predicate;
-		-- e.g. "have_sigs [[], [], []]" ???????????
-	in
-	mk_binds this_gp_binds this_gp_sigs (isCyclic edges cycle) have_sigs
-	}}}
-      where
-	is_elem = isIn "reconstructRec"
-
-	mk_binds :: RenamedMonoBinds -> [RenamedSig]
-		 -> Bool -> Bool -> RenamedHsBinds
-
-	mk_binds bs ss True  False		= SingleBind (RecBind    bs)
-	mk_binds bs ss True  True{-have sigs-}	= BindWith   (RecBind    bs) ss
-	mk_binds bs ss False False		= SingleBind (NonRecBind bs)
-	mk_binds bs ss False True{-have sigs-}	= BindWith   (NonRecBind bs) ss
-
-	-- moved from Digraph, as this is the only use here
-	-- (avoid overloading cost).  We have to use elem
-	-- (not FiniteMaps or whatever), because there may be
-	-- many edges out of one vertex.  We give it its own
-	-- "elem" just for speed.
-
-	isCyclic es []  = panic "isCyclic: empty component"
-	isCyclic es [v] = (v,v) `elem` es
-	isCyclic es vs  = True
-
-	elem _ []	= False
-	elem x (y:ys)	= x==y || elem x ys
+    relevant_binds_and_sigs = [(binds,sigs) | (vertex, _, _, binds, sigs) <- mbi,
+  					      vertex `is_elem` cycle]
+    (binds, sig_lists) = unzip relevant_binds_and_sigs
+    this_gp_binds      = foldr1 AndMonoBinds binds
+    this_gp_sigs       = foldr1 (++) sig_lists
+  
+    is_elem = isIn "reconstructRec"
+  
+    mk_binds :: RenamedMonoBinds -> [RenamedSig] -> Bool -> RenamedHsBinds
+    mk_binds bs [] True  = SingleBind (RecBind    bs)
+    mk_binds bs ss True  = BindWith   (RecBind    bs) ss
+    mk_binds bs [] False = SingleBind (NonRecBind bs)
+    mk_binds bs ss False = BindWith   (NonRecBind bs) ss
+  
+  	-- moved from Digraph, as this is the only use here
+  	-- (avoid overloading cost).  We have to use elem
+  	-- (not FiniteMaps or whatever), because there may be
+  	-- many edges out of one vertex.  We give it its own
+  	-- "elem" just for speed.
+  
+    isCyclic es []  = panic "isCyclic: empty component"
+    isCyclic es [v] = (v,v) `elem` es
+    isCyclic es vs  = True
+  
+    elem _ []	  = False
+    elem x (y:ys) = x==y || elem x ys
 \end{code}
 
 %************************************************************************
@@ -465,8 +440,8 @@ renamed.
 \begin{code}
 type FlatMonoBindsInfo
   = [(VertexTag,		-- Identifies the vertex
-      UniqSet RnName,		-- Set of names defined in this vertex
-      UniqSet RnName,		-- Set of names used in this vertex
+      NameSet,			-- Set of names defined in this vertex
+      NameSet,			-- Set of names used in this vertex
       RenamedMonoBinds,		-- Binding for this vertex (always just one binding, either fun or pat)
       [RenamedSig])		-- Signatures, if any, for this vertex
     ]
@@ -476,12 +451,10 @@ mkEdges    :: FlatMonoBindsInfo -> [Edge]
 
 mkVertices info = [ vertex | (vertex,_,_,_,_) <- info]
 
-mkEdges flat_info
- -- An edge (v,v') indicates that v depends on v'
-  = -- pprTrace "mkEdges:" (ppAboves [ppAboves[ppInt v, ppCat [ppr PprDebug d|d <- uniqSetToList defd], ppCat [ppr PprDebug u|u <- uniqSetToList used]] | (v,defd,used,_,_) <- flat_info]) $
-    [ (source_vertex, target_vertex)
+mkEdges flat_info	 -- An edge (v,v') indicates that v depends on v'
+  = [ (source_vertex, target_vertex)
     | (source_vertex, _, used_names, _, _) <- flat_info,
-      target_name   <- uniqSetToList used_names,
+      target_name   <- nameSetToList used_names,
       target_vertex <- vertices_defining target_name flat_info
     ]
     where
@@ -491,8 +464,8 @@ mkEdges flat_info
     -- error) needs more thought.
 
     vertices_defining name flat_info2
-     = [ vertex |  (vertex, names_defined, _, _, _) <- flat_info2,
-		 name `elementOfUniqSet` names_defined
+     = [ vertex | (vertex, names_defined, _, _, _) <- flat_info2,
+		  name `elemNameSet` names_defined
        ]
 \end{code}
 
@@ -509,139 +482,94 @@ flaggery, that all top-level things have type signatures.
 
 \begin{code}
 rnBindSigs :: Bool		    	-- True <=> top-level binders
-	    -> [RdrName]	    	-- Binders for this decl group
+	    -> NameSet			-- Set of names bound in this group
 	    -> [RdrNameSig]
-	    -> RnM_Fixes s [RenamedSig] -- List of Sig constructors
-
-rnBindSigs is_toplev binder_occnames sigs
-  =
-	 -- Rename the signatures
-	 -- Will complain about sigs for variables not in this group
-    mapRn rename_sig sigs   	`thenRn` \ sigs_maybe ->
-    let
-	sigs' = catMaybes sigs_maybe
+	    -> RnMS s [RenamedSig]		 -- List of Sig constructors
 
-	 -- Discard unbound ones we've already complained about, so we
-	 -- complain about duplicate ones.
+rnBindSigs is_toplev binders sigs
+  =	 -- Rename the signatures
+    mapRn renameSig sigs   	`thenRn` \ sigs' ->
 
-	(goodies, dups) = removeDups compare (filter (\ x -> not_unbound x && not_main x) sigs')
+	-- Check for (a) duplicate signatures
+	--	     (b) signatures for things not in this group
+	--	     (c) optionally, bindings with no signature
+    let
+	(goodies, dups) = removeDups cmp_sig (filter (not.isUnboundName.sig_name) sigs')
+	not_this_group  = filter (\sig -> not (sig_name sig `elemNameSet` binders)) goodies
+	type_sig_vars	= [n | Sig n _ _ <- goodies]
+	un_sigd_binders 
+	    | is_toplev && opt_SigsRequired = nameSetToList binders `minusList` type_sig_vars
+	    | otherwise			    = []
     in
-    mapRn (addErrRn . dupSigDeclErr) dups `thenRn_`
-
-    getSrcLocRn			`thenRn` \ locn ->
-
-    (if (is_toplev && opt_SigsRequired) then
-	let
-	    sig_frees = catMaybes (map (sig_free sigs) binder_occnames)
-	in
-	mapRn (addErrRn . missingSigErr locn) sig_frees
-     else
-	returnRn []
-    )				`thenRn_`
+    mapRn dupSigDeclErr dups 				`thenRn_`
+    mapRn unknownSigErr not_this_group			`thenRn_`
+    mapRn (addErrRn.missingSigErr) un_sigd_binders	`thenRn_`
 
     returnRn sigs' -- bad ones and all:
 		   -- we need bindings of *some* sort for every name
+
+
+renameSig (Sig v ty src_loc)
+  = pushSrcLocRn src_loc $
+    lookupRn v			`thenRn` \ new_v ->
+    rnHsType ty			`thenRn` \ new_ty ->
+    returnRn (Sig new_v new_ty src_loc)
+
+renameSig (SpecSig v ty using src_loc)
+  = pushSrcLocRn src_loc $
+    lookupRn v			`thenRn` \ new_v ->
+    rnHsType ty			`thenRn` \ new_ty ->
+    rn_using using		`thenRn` \ new_using ->
+    returnRn (SpecSig new_v new_ty new_using src_loc)
   where
-    rename_sig (Sig v ty pragmas src_loc)
-      = pushSrcLocRn src_loc $
-	if not (v `elem` binder_occnames) then
-	   addErrRn (unknownSigDeclErr "type signature" v src_loc) `thenRn_`
-	   returnRn Nothing
-	else
-	   lookupValue v			`thenRn` \ new_v ->
-	   rnPolyType nullTyVarNamesEnv ty	`thenRn` \ new_ty ->
-
-	   ASSERT(isNoGenPragmas pragmas)
-	   returnRn (Just (Sig new_v new_ty noGenPragmas src_loc))
-
-    -- and now, the various flavours of value-modifying user-pragmas:
-
-    rename_sig (SpecSig v ty using src_loc)
-      = pushSrcLocRn src_loc $
-	if not (v `elem` binder_occnames) then
-	   addErrRn (unknownSigDeclErr "SPECIALIZE pragma" v src_loc) `thenRn_`
-	   returnRn Nothing
-	else
-	   lookupValue v			`thenRn` \ new_v ->
-	   rnPolyType nullTyVarNamesEnv ty	`thenRn` \ new_ty ->
-	   rn_using using			`thenRn` \ new_using ->
-	   returnRn (Just (SpecSig new_v new_ty new_using src_loc))
-      where
-	rn_using Nothing  = returnRn Nothing
-	rn_using (Just x) = lookupValue x `thenRn` \ new_x ->
-			    returnRn (Just new_x)
-
-    rename_sig (InlineSig v src_loc)
-      = pushSrcLocRn src_loc $
-	if not (v `elem` binder_occnames) then
-	   addErrRn (unknownSigDeclErr "INLINE pragma" v src_loc) `thenRn_`
-	   returnRn Nothing
-	else
-	   lookupValue v	`thenRn` \ new_v ->
-	   returnRn (Just (InlineSig new_v src_loc))
-
-    rename_sig (DeforestSig v src_loc)
-      = pushSrcLocRn src_loc $
-	if not (v `elem` binder_occnames) then
-	   addErrRn (unknownSigDeclErr "DEFOREST pragma" v src_loc) `thenRn_`
-	   returnRn Nothing
-	else
-	   lookupValue v        `thenRn` \ new_v ->
-	   returnRn (Just (DeforestSig new_v src_loc))
-
-    rename_sig (MagicUnfoldingSig v str src_loc)
-      = pushSrcLocRn src_loc $
-	if not (v `elem` binder_occnames) then
-	   addErrRn (unknownSigDeclErr "MAGIC_UNFOLDING pragma" v src_loc) `thenRn_`
-	   returnRn Nothing
-	else
-	   lookupValue v	`thenRn` \ new_v ->
-	   returnRn (Just (MagicUnfoldingSig new_v str src_loc))
-
-    not_unbound, not_main :: RenamedSig -> Bool
-
-    not_unbound (Sig n _ _ _)		  = not (isRnUnbound n)
-    not_unbound (SpecSig n _ _ _)	  = not (isRnUnbound n)
-    not_unbound (InlineSig n _)		  = not (isRnUnbound n)
-    not_unbound (DeforestSig n _)	  = not (isRnUnbound n)
-    not_unbound (MagicUnfoldingSig n _ _) = not (isRnUnbound n)
-
-    not_main (Sig n _ _ _)  = let str = getLocalName n in
-			      not (str == SLIT("main") || str == SLIT("mainPrimIO"))
-    not_main _		    = True
-
-    -------------------------------------
-    sig_free :: [RdrNameSig] -> RdrName -> Maybe RdrName
-	-- Return "Just x" if "x" has no type signature in
-	-- sigs.  Nothing, otherwise.
-
-    sig_free [] ny = Just ny
-    sig_free (Sig nx _ _ _ : rest) ny
-      = if (nx == ny) then Nothing else sig_free rest ny
-    sig_free (_ : rest) ny = sig_free rest ny
-
-    -------------------------------------
-    compare :: RenamedSig -> RenamedSig -> TAG_
-    compare (Sig n1 _ _ _)	       (Sig n2 _ _ _)    	  = n1 `cmp` n2
-    compare (InlineSig n1 _)  	       (InlineSig n2 _) 	  = n1 `cmp` n2
-    compare (MagicUnfoldingSig n1 _ _) (MagicUnfoldingSig n2 _ _) = n1 `cmp` n2
-    compare (SpecSig n1 ty1 _ _)       (SpecSig n2 ty2 _ _)
-      = -- may have many specialisations for one value;
+    rn_using Nothing  = returnRn Nothing
+    rn_using (Just x) = lookupOccRn x `thenRn` \ new_x ->
+			returnRn (Just new_x)
+
+renameSig (InlineSig v src_loc)
+  = pushSrcLocRn src_loc $
+    lookupRn v		`thenRn` \ new_v ->
+    returnRn (InlineSig new_v src_loc)
+
+renameSig (DeforestSig v src_loc)
+  = pushSrcLocRn src_loc $
+    lookupRn v        `thenRn` \ new_v ->
+    returnRn (DeforestSig new_v src_loc)
+
+renameSig (MagicUnfoldingSig v str src_loc)
+  = pushSrcLocRn src_loc $
+    lookupRn v		`thenRn` \ new_v ->
+    returnRn (MagicUnfoldingSig new_v str src_loc)
+\end{code}
+
+Checking for distinct signatures; oh, so boring
+
+\begin{code}
+cmp_sig :: RenamedSig -> RenamedSig -> TAG_
+cmp_sig (Sig n1 _ _)	           (Sig n2 _ _)    	  = n1 `cmp` n2
+cmp_sig (InlineSig n1 _)  	   (InlineSig n2 _) 	  = n1 `cmp` n2
+cmp_sig (MagicUnfoldingSig n1 _ _) (MagicUnfoldingSig n2 _ _) = n1 `cmp` n2
+cmp_sig (SpecSig n1 ty1 _ _)       (SpecSig n2 ty2 _ _)
+  = -- may have many specialisations for one value;
 	-- but not ones that are exactly the same...
-	thenCmp (n1 `cmp` n2) (cmpPolyType cmp ty1 ty2)
-
-    compare other_1 other_2	-- tags *must* be different
-      = let tag1 = tag other_1
-	    tag2 = tag other_2
-	in
-	if tag1 _LT_ tag2 then LT_ else GT_
-
-    tag (Sig n1 _ _ _)    	   = (ILIT(1) :: FAST_INT)
-    tag (SpecSig n1 _ _ _)    	   = ILIT(2)
-    tag (InlineSig n1 _)  	   = ILIT(3)
-    tag (MagicUnfoldingSig n1 _ _) = ILIT(4)
-    tag (DeforestSig n1 _)         = ILIT(5)
-    tag _ = panic# "tag(RnBinds)"
+	thenCmp (n1 `cmp` n2) (cmpHsType cmp ty1 ty2)
+
+cmp_sig other_1 other_2					-- Tags *must* be different
+  | (sig_tag other_1) _LT_ (sig_tag other_2) = LT_ 
+  | otherwise				     = GT_
+
+sig_tag (Sig n1 _ _)    	   = (ILIT(1) :: FAST_INT)
+sig_tag (SpecSig n1 _ _ _)    	   = ILIT(2)
+sig_tag (InlineSig n1 _)  	   = ILIT(3)
+sig_tag (MagicUnfoldingSig n1 _ _) = ILIT(4)
+sig_tag (DeforestSig n1 _)         = ILIT(5)
+sig_tag _			   = panic# "tag(RnBinds)"
+
+sig_name (Sig        n _ _) 	   = n
+sig_name (ClassOpSig n _ _ _) 	   = n
+sig_name (SpecSig    n _ _ _) 	   = n
+sig_name (InlineSig  n     _) 	   = n  
+sig_name (MagicUnfoldingSig n _ _) = n
 \end{code}
 
 %************************************************************************
@@ -651,46 +579,31 @@ rnBindSigs is_toplev binder_occnames sigs
 %************************************************************************
 
 \begin{code}
-dupSigDeclErr sigs
-  = let
-	undup_sigs = fst (removeDups cmp_sig sigs)
-    in
-    addErrLoc locn1
-	("more than one "++what_it_is++"\n\thas been given for these variables") ( \ sty ->
-    ppAboves (map (ppr sty) undup_sigs) )
+dupSigDeclErr (sig:sigs)
+  = pushSrcLocRn loc $
+    addErrRn (\sty -> ppSep [ppStr "more than one", 
+		      	    ppStr what_it_is, ppStr "given for", 
+			    ppQuote (ppr sty (sig_name sig))])
   where
-    (what_it_is, locn1)
-      = case (head sigs) of
-	  Sig        _ _ _ loc -> ("type signature",loc)
-	  ClassOpSig _ _ _ loc -> ("class-method type signature", loc)
-	  SpecSig    _ _ _ loc -> ("SPECIALIZE pragma",loc)
-	  InlineSig  _     loc -> ("INLINE pragma",loc)
-	  MagicUnfoldingSig _ _ loc -> ("MAGIC_UNFOLDING pragma",loc)
-
-    cmp_sig a b = get_name a `cmp` get_name b
-
-    get_name (Sig        n _ _ _) = n
-    get_name (ClassOpSig n _ _ _) = n
-    get_name (SpecSig    n _ _ _) = n
-    get_name (InlineSig  n     _) = n
-    get_name (MagicUnfoldingSig n _ _) = n
-
-------------------------
-methodBindErr mbind locn
- = addErrLoc locn "Can't handle multiple methods defined by one pattern binding"
-	(\ sty -> ppr sty mbind)
-
---------------------------
-missingSigErr locn var
-  = addShortErrLocLine locn ( \ sty ->
-    ppBesides [ppStr "a definition but no type signature for `",
-	       ppr sty var,
-	       ppStr "'."])
-
---------------------------------
-unknownSigDeclErr flavor var locn
-  = addShortErrLocLine locn ( \ sty ->
-    ppBesides [ppStr flavor, ppStr " but no definition for `",
-	       ppr sty var,
-	       ppStr "'."])
+    (what_it_is, loc) = sig_doc sig
+
+unknownSigErr sig
+  = pushSrcLocRn loc $
+    addErrRn (\sty -> ppSep [ppStr flavour, ppStr "but no definition for",
+			     ppQuote (ppr sty (sig_name sig))])
+  where
+    (flavour, loc) = sig_doc sig
+
+sig_doc (Sig        _ _ loc) 	    = ("type signature",loc)
+sig_doc (ClassOpSig _ _ _ loc) 	    = ("class-method type signature", loc)
+sig_doc (SpecSig    _ _ _ loc) 	    = ("SPECIALIZE pragma",loc)
+sig_doc (InlineSig  _     loc) 	    = ("INLINE pragma",loc)
+sig_doc (MagicUnfoldingSig _ _ loc) = ("MAGIC_UNFOLDING pragma",loc)
+
+missingSigErr var sty
+  = ppSep [ppStr "a definition but no type signature for", ppQuote (ppr sty var)]
+
+methodBindErr mbind sty
+ =  ppHang (ppStr "Can't handle multiple methods defined by one pattern binding")
+	   4 (ppr sty mbind)
 \end{code}
diff --git a/ghc/compiler/rename/RnEnv.lhs b/ghc/compiler/rename/RnEnv.lhs
new file mode 100644
index 0000000000..fa90d3fd4f
--- /dev/null
+++ b/ghc/compiler/rename/RnEnv.lhs
@@ -0,0 +1,469 @@
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+%
+\section[RnEnv]{Environment manipulation for the renamer monad}
+
+\begin{code}
+#include "HsVersions.h"
+
+module RnEnv where		-- Export everything
+
+IMP_Ubiq()
+
+import CmdLineOpts	( opt_WarnNameShadowing, opt_IgnoreIfacePragmas )
+import HsSyn
+import RdrHsSyn		( RdrName(..), SYN_IE(RdrNameIE),
+			  rdrNameOcc, isQual, qual
+			)
+import HsTypes		( getTyVarName, replaceTyVarName )
+import RnMonad
+import Name		( Name, OccName(..), Provenance(..), DefnInfo(..), ExportFlag(..),
+			  occNameString, occNameFlavour,
+			  SYN_IE(NameSet), emptyNameSet, addListToNameSet,
+			  mkLocalName, mkGlobalName, modAndOcc,
+			  isLocalName, isWiredInName, nameOccName, setNameProvenance,
+			  pprProvenance, pprOccName, pprModule, pprNonSymOcc, pprNameProvenance
+			)
+import TyCon		( TyCon )
+import TysWiredIn	( tupleTyCon, listTyCon, charTyCon, intTyCon )
+import FiniteMap
+import Unique		( Unique, unboundKey )
+import Maybes		( maybeToBool )
+import UniqSupply
+import SrcLoc		( SrcLoc, noSrcLoc )
+import Pretty
+import PprStyle		( PprStyle(..) )
+import Util		( panic, removeDups, pprTrace, assertPanic )
+\end{code}
+
+
+
+%*********************************************************
+%*							*
+\subsection{Making new names}
+%*							*
+%*********************************************************
+
+\begin{code}
+newGlobalName :: Module -> OccName -> RnM s d Name
+newGlobalName mod occ
+  = 	-- First check the cache
+    getNameSupplyRn		`thenRn` \ (us, inst_ns, cache) ->
+    case lookupFM cache (mod,occ) of
+
+	-- A hit in the cache!  Return it, but change the src loc
+	-- of the thing we've found if this is a second definition site
+	-- (that is, if loc /= NoSrcLoc)
+	Just name ->  returnRn name
+
+	-- Miss in the cache, so build a new original name,
+	-- and put it in the cache
+	Nothing        -> 
+	    let
+		(us', us1) = splitUniqSupply us
+		uniq   	   = getUnique us1
+		name       = mkGlobalName uniq mod occ VanillaDefn Implicit
+		cache'     = addToFM cache (mod,occ) name
+	    in
+	    setNameSupplyRn (us', inst_ns, cache')		`thenRn_`
+	    returnRn name
+
+newLocallyDefinedGlobalName :: Module -> OccName 
+			    -> (Name -> ExportFlag) -> SrcLoc
+			    -> RnM s d Name
+newLocallyDefinedGlobalName mod occ rec_exp_fn loc
+  = 	-- First check the cache
+    getNameSupplyRn		`thenRn` \ (us, inst_ns, cache) ->
+
+	-- We are at the binding site for a locally-defined thing, so
+	-- you might think it can't be in the cache, but it can if it's a
+	-- wired in thing. In that case we need to use the correct unique etc...
+	-- so all we do is replace its provenance.  
+	-- If it's not in the cache we put it there with the correct provenance.
+	-- The idea is that, after all this, the cache
+	-- will contain a Name with the correct Provenance (i.e. Local)
+    let
+	provenance = LocalDef (rec_exp_fn new_name) loc
+	(us', us1) = splitUniqSupply us
+	uniq   	   = getUnique us1
+	new_name   = case lookupFM cache (mod,occ) of
+			Just name -> setNameProvenance name provenance
+			Nothing   -> mkGlobalName uniq mod occ VanillaDefn provenance
+	cache'     = addToFM cache (mod,occ) new_name
+    in
+    setNameSupplyRn (us', inst_ns, cache')		`thenRn_`
+    returnRn new_name
+
+-- newDfunName is used to allocate a name for the dictionary function for
+-- a local instance declaration.  No need to put it in the cache (I think!).
+newDfunName ::  SrcLoc -> RnMS s Name
+newDfunName src_loc
+  = getNameSupplyRn		`thenRn` \ (us, inst_ns, cache) ->
+    getModuleRn			`thenRn` \ mod_name ->
+    let
+	(us', us1) = splitUniqSupply us
+	uniq	   = getUnique us1
+	dfun_name  = mkGlobalName uniq mod_name (VarOcc (_PK_ ("df" ++ show inst_ns)))
+				  VanillaDefn (LocalDef Exported src_loc)
+   in
+   setNameSupplyRn (us', inst_ns+1, cache)	`thenRn_`
+   returnRn dfun_name
+
+
+newLocalNames :: [(RdrName,SrcLoc)] -> RnM s d [Name]
+newLocalNames rdr_names
+  = getNameSupplyRn		`thenRn` \ (us, inst_ns, cache) ->
+    let
+	n	   = length rdr_names
+	(us', us1) = splitUniqSupply us
+	uniqs	   = getUniques n us1
+	locals	   = [ mkLocalName uniq (rdrNameOcc rdr_name) loc
+		     | ((rdr_name,loc), uniq) <- rdr_names `zip` uniqs
+		     ]
+    in
+    setNameSupplyRn (us', inst_ns, cache)	`thenRn_`
+    returnRn locals
+
+-- mkUnboundName makes a place-holder Name; it shouldn't be looked at except possibly
+-- during compiler debugging.
+mkUnboundName :: RdrName -> Name
+mkUnboundName rdr_name = mkLocalName unboundKey (rdrNameOcc rdr_name) noSrcLoc
+
+isUnboundName :: Name -> Bool
+isUnboundName name = uniqueOf name == unboundKey
+\end{code}
+
+\begin{code}
+bindLocatedLocalsRn :: String		-- Documentation string for error message
+	   	    -> [(RdrName,SrcLoc)]
+	    	    -> ([Name] -> RnMS s a)
+	    	    -> RnMS s a
+bindLocatedLocalsRn doc_str rdr_names_w_loc enclosed_scope
+  = 	-- Check for use of qualified names
+    mapRn (qualNameErr doc_str) quals 	`thenRn_`
+	-- Check for dupicated names in a binding group
+    mapRn (dupNamesErr doc_str) dups  	`thenRn_`
+
+    getNameEnv			`thenRn` \ name_env ->
+    (if opt_WarnNameShadowing
+     then
+	mapRn (check_shadow name_env) rdr_names_w_loc
+     else
+	returnRn []
+    )					`thenRn_`
+	
+    newLocalNames rdr_names_w_loc	`thenRn` \ names ->
+    let
+	new_name_env = addListToFM name_env (map fst rdr_names_w_loc `zip` names)
+    in
+    setNameEnv new_name_env (enclosed_scope names)
+  where
+    quals	  = filter (isQual.fst) rdr_names_w_loc
+    (these, dups) = removeDups (\(n1,l1) (n2,l2) -> n1 `cmp` n2) rdr_names_w_loc
+    check_shadow name_env (rdr_name,loc)
+	= case lookupFM name_env rdr_name of
+		Nothing   -> returnRn ()
+		Just name -> pushSrcLocRn loc $
+			     addWarnRn (shadowedNameWarn rdr_name)
+
+bindLocalsRn doc_str rdr_names enclosed_scope
+  = getSrcLocRn		`thenRn` \ loc ->
+    bindLocatedLocalsRn doc_str (rdr_names `zip` repeat loc) enclosed_scope
+
+bindTyVarsRn doc_str tyvar_names enclosed_scope
+  = getSrcLocRn					`thenRn` \ loc ->
+    let
+	located_tyvars = [(getTyVarName tv, loc) | tv <- tyvar_names] 
+    in
+    bindLocatedLocalsRn doc_str located_tyvars	$ \ names ->
+    enclosed_scope (zipWith replaceTyVarName tyvar_names names)
+\end{code}
+
+
+%*********************************************************
+%*							*
+\subsection{Looking up names}
+%*							*
+%*********************************************************
+
+Looking up a name in the RnEnv.
+
+\begin{code}
+lookupRn :: RdrName -> RnMS s Name
+lookupRn rdr_name
+  = getNameEnv 		`thenRn` \ name_env ->
+    case lookupFM name_env rdr_name of
+
+	-- Found it!
+	Just name -> returnRn name
+
+	-- Not found
+	Nothing -> getModeRn	`thenRn` \ mode ->
+		   case mode of 
+			-- Not found when processing source code; so fail
+			SourceMode    -> failWithRn (mkUnboundName rdr_name)
+					            (unknownNameErr rdr_name)
+		
+			-- Not found when processing an imported declaration,
+			-- so we create a new name for the purpose
+			InterfaceMode -> 
+			    case rdr_name of
+
+				Qual mod_name occ -> newGlobalName mod_name occ
+
+				-- An Unqual is allowed; interface files contain 
+				-- unqualified names for locally-defined things, such as
+				-- constructors of a data type.
+				Unqual occ -> getModuleRn 	`thenRn ` \ mod_name ->
+					      newGlobalName mod_name occ
+
+
+-- Just like lookupRn except that we record the occurrence too
+-- Perhaps surprisingly, even wired-in names are recorded.
+-- Why?  So that we know which wired-in names are referred to when
+-- deciding which instance declarations to import.
+lookupOccRn :: RdrName -> RnMS s Name
+lookupOccRn rdr_name
+  = lookupRn rdr_name	`thenRn` \ name ->
+    if isLocalName name then
+	returnRn name
+    else
+	addOccurrenceName Compulsory name		`thenRn_`
+ 	returnRn name
+
+-- lookupOptionalOccRn is similar, but it's used in places where
+-- we don't *have* to find a definition for the thing.
+lookupOptionalOccRn :: RdrName -> RnMS s Name
+lookupOptionalOccRn rdr_name
+  = lookupRn rdr_name	`thenRn` \ name ->
+    if opt_IgnoreIfacePragmas || isLocalName name then
+    		-- Never look for optional things if we're
+		-- ignoring optional input interface information
+	returnRn name
+    else
+	addOccurrenceName Optional name		`thenRn_`
+ 	returnRn name
+
+-- lookupImplicitOccRn takes an RdrName representing an *original* name, and
+-- adds it to the occurrence pool so that it'll be loaded later.  This is
+-- used when language constructs (such as monad comprehensions, overloaded literals,
+-- or deriving clauses) require some stuff to be loaded that isn't explicitly
+-- mentioned in the code.
+--
+-- This doesn't apply in interface mode, where everything is explicit, but
+-- we don't check for this case: it does no harm to record an "extra" occurrence
+-- and lookupImplicitOccRn isn't used much in interface mode (it's only the
+-- Nothing clause of rnDerivs that calls it at all I think.
+--
+-- For List and Tuple types it's important to get the correct
+-- isLocallyDefined flag, which is used in turn when deciding
+-- whether there are any instance decls in this module are "special".
+-- The name cache should have the correct provenance, though.
+
+lookupImplicitOccRn :: RdrName -> RnMS s Name 
+lookupImplicitOccRn (Qual mod occ)
+ = newGlobalName mod occ		`thenRn` \ name ->
+   addOccurrenceName Compulsory name	`thenRn_`
+   returnRn name
+
+addImplicitOccRn :: Name -> RnM s d ()
+addImplicitOccRn name = addOccurrenceName Compulsory name
+
+addImplicitOccsRn :: [Name] -> RnM s d ()
+addImplicitOccsRn names = addOccurrenceNames Compulsory names
+
+intType_RDR	= qual (modAndOcc (getName intTyCon))
+listType_RDR	= qual (modAndOcc listType_name)
+tupleType_RDR n	= qual (modAndOcc (tupleType_name n))
+
+charType_name    = getName charTyCon
+listType_name    = getName listTyCon
+tupleType_name n = getName (tupleTyCon n)
+\end{code}
+
+\begin{code}
+lookupFixity :: RdrName -> RnMS s Fixity
+lookupFixity rdr_name
+  = getFixityEnv	`thenRn` \ fixity_env ->
+    returnRn (lookupFixityEnv fixity_env rdr_name)
+\end{code}
+
+
+
+%************************************************************************
+%*									*
+\subsection{Envt utility functions}
+%*									*
+%************************************************************************
+
+===============  RnEnv  ================
+\begin{code}
+plusRnEnv (RnEnv n1 f1) (RnEnv n2 f2) 
+  = plusNameEnvRn n1 n2		`thenRn` \ n ->
+    plusFixityEnvRn f1 f2	`thenRn` \ f -> 
+    returnRn (RnEnv n f)
+\end{code}
+
+===============  NameEnv  ================
+\begin{code}
+plusNameEnvRn :: NameEnv -> NameEnv -> RnM s d NameEnv
+plusNameEnvRn n1 n2
+  = mapRn (addErrRn.nameClashErr) (conflictsFM (/=) n1 n2)		`thenRn_`
+    returnRn (n1 `plusFM` n2)
+
+addOneToNameEnvRn :: NameEnv -> RdrName -> Name -> RnM s d NameEnv
+addOneToNameEnvRn env rdr_name name
+  = mapRn (addErrRn.nameClashErr) (conflictFM (/=) env rdr_name name)	`thenRn_`
+    returnRn (addToFM env rdr_name name)
+
+lookupNameEnv :: NameEnv -> RdrName -> Maybe Name
+lookupNameEnv = lookupFM
+\end{code}
+
+===============  FixityEnv  ================
+\begin{code}
+plusFixityEnvRn f1 f2
+  = mapRn (addErrRn.fixityClashErr) (conflictsFM bad_fix f1 f2)		`thenRn_`
+    returnRn (f1 `plusFM` f2)
+
+addOneToFixityEnvRn env rdr_name fixity
+  = mapRn (addErrRn.fixityClashErr) (conflictFM bad_fix env rdr_name fixity)	`thenRn_`
+    returnRn (addToFM env rdr_name fixity)
+
+lookupFixityEnv env rdr_name 
+  = case lookupFM env rdr_name of
+	Just (fixity,_) -> fixity
+	Nothing	        -> Fixity 9 InfixL 		-- Default case
+
+bad_fix :: (Fixity, Provenance) -> (Fixity, Provenance) -> Bool
+bad_fix (f1,_) (f2,_) = f1 /= f2
+
+pprFixityProvenance :: PprStyle -> (Fixity,Provenance) -> Pretty
+pprFixityProvenance sty (fixity, prov) = pprProvenance sty prov
+\end{code}
+
+
+
+===============  Avails  ================
+\begin{code}
+emptyModuleAvails :: ModuleAvails
+plusModuleAvails ::  ModuleAvails ->  ModuleAvails ->  ModuleAvails
+lookupModuleAvails :: ModuleAvails -> Module -> Maybe [AvailInfo]
+
+emptyModuleAvails = emptyFM
+plusModuleAvails  = plusFM_C (++)
+lookupModuleAvails = lookupFM
+\end{code}
+
+
+===============  AvailInfo  ================
+\begin{code}
+plusAvail (Avail n1 ns1) (Avail n2 ns2) = Avail n1 (nub (ns1 ++ ns2))
+plusAvail a NotAvailable = a
+plusAvail NotAvailable a = a
+
+addAvailToNameSet :: NameSet -> AvailInfo -> NameSet
+addAvailToNameSet names NotAvailable = names
+addAvailToNameSet names (Avail n ns) = addListToNameSet names (n:ns)
+
+availsToNameSet :: [AvailInfo] -> NameSet
+availsToNameSet avails = foldl addAvailToNameSet emptyNameSet avails
+
+availNames :: AvailInfo -> [Name]
+availNames NotAvailable      = []
+availNames (Avail n ns) = n:ns
+
+filterAvail :: RdrNameIE -> AvailInfo -> AvailInfo
+filterAvail (IEThingWith _ wanted) NotAvailable = NotAvailable
+filterAvail (IEThingWith _ wanted) (Avail n ns)
+  | sub_names_ok = Avail n (filter is_wanted ns)
+  | otherwise	 = NotAvailable
+  where
+    is_wanted name = nameOccName name `elem` wanted_occs
+    sub_names_ok   = all (`elem` avail_occs) wanted_occs
+    wanted_occs    = map rdrNameOcc wanted
+    avail_occs	   = map nameOccName ns
+
+
+filterAvail (IEThingAll _) avail        = avail
+filterAvail ie		   (Avail n ns) = Avail n []		-- IEThingAbs and IEVar
+
+-- pprAvail gets given the OccName of the "host" thing
+pprAvail sty NotAvailable = ppStr "NotAvailable"
+pprAvail sty (Avail n ns) = ppCat [pprOccName sty (nameOccName n),
+				   ppStr "(",
+				   ppInterleave ppComma (map (pprOccName sty.nameOccName) ns),
+				   ppStr ")"]
+\end{code}
+
+
+
+
+%************************************************************************
+%*									*
+\subsection{Finite map utilities}
+%*									*
+%************************************************************************
+
+
+Generally useful function on finite maps to check for overlap.
+
+\begin{code}
+conflictsFM :: Ord a 
+	    => (b->b->Bool)		-- False <=> no conflict; you can pick either
+	    -> FiniteMap a b -> FiniteMap a b
+	    -> [(a,(b,b))]
+conflictsFM bad fm1 fm2 
+  = filter (\(a,(b1,b2)) -> bad b1 b2)
+	   (fmToList (intersectFM_C (\b1 b2 -> (b1,b2)) fm1 fm2))
+
+conflictFM :: Ord a 
+	   => (b->b->Bool)
+	   -> FiniteMap a b -> a -> b
+	   -> [(a,(b,b))]
+conflictFM bad fm key elt
+  = case lookupFM fm key of
+	Just elt' | bad elt elt' -> [(key,(elt,elt'))]
+	other			 -> []
+\end{code}
+
+
+%************************************************************************
+%*									*
+\subsection{Envt utility functions}
+%*									*
+%************************************************************************
+
+
+\begin{code}
+nameClashErr (rdr_name, (name1,name2)) sty
+  = ppHang (ppCat [ppStr "Conflicting definitions for: ", ppr sty rdr_name])
+	4 (ppAboves [pprNameProvenance sty name1,
+		     pprNameProvenance sty name2])
+
+fixityClashErr (rdr_name, (fp1,fp2)) sty
+  = ppHang (ppCat [ppStr "Conflicting fixities for: ", ppr sty rdr_name])
+	4 (ppAboves [pprFixityProvenance sty fp1,
+		     pprFixityProvenance sty fp2])
+
+shadowedNameWarn shadow sty
+  = ppBesides [ppStr "More than one value with the same name (shadowing): ", ppr sty shadow]
+
+unknownNameErr name sty
+  = ppSep [ppStr flavour, ppStr "not in scope:", ppr sty name]
+  where
+    flavour = occNameFlavour (rdrNameOcc name)
+
+qualNameErr descriptor (name,loc)
+  = pushSrcLocRn loc $
+    addErrRn (\sty -> ppBesides [ppStr "invalid use of qualified ", 
+				 ppStr descriptor, ppStr ": ", 
+				 pprNonSymOcc sty (rdrNameOcc name) ])
+
+dupNamesErr descriptor ((name,loc) : dup_things)
+  = pushSrcLocRn loc $
+    addErrRn (\sty -> ppBesides [ppStr "duplicate bindings of `", 
+				 ppr sty name, ppStr "' in ", 
+				 ppStr descriptor])
+\end{code}
+
diff --git a/ghc/compiler/rename/RnExpr.lhs b/ghc/compiler/rename/RnExpr.lhs
index 08b176386e..613b37be92 100644
--- a/ghc/compiler/rename/RnExpr.lhs
+++ b/ghc/compiler/rename/RnExpr.lhs
@@ -24,9 +24,17 @@ import HsSyn
 import RdrHsSyn
 import RnHsSyn
 import RnMonad
-
+import RnEnv
+import PrelInfo		( numClass_RDR, fractionalClass_RDR, eqClass_RDR, ccallableClass_RDR,
+			  creturnableClass_RDR, monadZeroClass_RDR, enumClass_RDR,
+			  negate_RDR
+			)
+import TysPrim		( charPrimTyCon, addrPrimTyCon, intPrimTyCon, 
+			  floatPrimTyCon, doublePrimTyCon
+			)
+import TyCon		( TyCon )
 import ErrUtils		( addErrLoc, addShortErrLocLine )
-import Name		( isLocallyDefinedName, pprSym, Name, RdrName )
+import Name
 import Pretty
 import UniqFM		( lookupUFM{-, ufmToList ToDo:rm-} )
 import UniqSet		( emptyUniqSet, unitUniqSet,
@@ -44,15 +52,18 @@ import Util		( Ord3(..), removeDups, panic )
 *********************************************************
 
 \begin{code}
-rnPat :: RdrNamePat -> RnM_Fixes s RenamedPat
+rnPat :: RdrNamePat -> RnMS s RenamedPat
 
 rnPat WildPatIn = returnRn WildPatIn
 
 rnPat (VarPatIn name)
-  = lookupValue name	`thenRn` \ vname ->
+  = lookupRn name	`thenRn` \ vname ->
     returnRn (VarPatIn vname)
 
-rnPat (LitPatIn n) = returnRn (LitPatIn n)
+rnPat (LitPatIn lit) 
+  = litOccurrence lit			`thenRn_`
+    lookupImplicitOccRn eqClass_RDR	`thenRn_`	-- Needed to find equality on pattern
+    returnRn (LitPatIn lit)
 
 rnPat (LazyPatIn pat)
   = rnPat pat		`thenRn` \ pat' ->
@@ -60,23 +71,23 @@ rnPat (LazyPatIn pat)
 
 rnPat (AsPatIn name pat)
   = rnPat pat		`thenRn` \ pat' ->
-    lookupValue name	`thenRn` \ vname ->
+    lookupRn name	`thenRn` \ vname ->
     returnRn (AsPatIn vname pat')
 
 rnPat (ConPatIn con pats)
-  = lookupConstr con	`thenRn` \ con' ->
+  = lookupRn con	`thenRn` \ con' ->
     mapRn rnPat pats  	`thenRn` \ patslist ->
     returnRn (ConPatIn con' patslist)
 
 rnPat (ConOpPatIn pat1 con pat2)
-  = lookupConstr con	`thenRn` \ con' ->
-    rnPat pat1		`thenRn` \ pat1' ->
-    rnPat pat2		`thenRn` \ pat2' ->
-    precParsePat (ConOpPatIn pat1' con' pat2')
+  = rnOpPat pat1 con pat2
 
+-- Negated patters can only be literals, and they are dealt with
+-- by negating the literal at compile time, not by using the negation
+-- operation in Num.  So we don't need to make an implicit reference
+-- to negate_RDR.
 rnPat neg@(NegPatIn pat)
-  = getSrcLocRn		`thenRn` \ src_loc ->
-    addErrIfRn (not (valid_neg_pat pat)) (negPatErr neg src_loc)
+  = checkRn (valid_neg_pat pat) (negPatErr neg)
 			`thenRn_`
     rnPat pat		`thenRn` \ pat' ->
     returnRn (NegPatIn pat')
@@ -90,15 +101,17 @@ rnPat (ParPatIn pat)
     returnRn (ParPatIn pat')
 
 rnPat (ListPatIn pats)
-  = mapRn rnPat pats 	`thenRn` \ patslist ->
+  = addImplicitOccRn listType_name	`thenRn_` 
+    mapRn rnPat pats 			`thenRn` \ patslist ->
     returnRn (ListPatIn patslist)
 
 rnPat (TuplePatIn pats)
-  = mapRn rnPat pats 	`thenRn` \ patslist ->
+  = addImplicitOccRn (tupleType_name (length pats))	`thenRn_` 
+    mapRn rnPat pats 					`thenRn` \ patslist ->
     returnRn (TuplePatIn patslist)
 
 rnPat (RecPatIn con rpats)
-  = lookupConstr con 	`thenRn` \ con' ->
+  = lookupRn con 	`thenRn` \ con' ->
     rnRpats rpats	`thenRn` \ rpats' ->
     returnRn (RecPatIn con' rpats')
 \end{code}
@@ -110,28 +123,17 @@ rnPat (RecPatIn con rpats)
 ************************************************************************
 
 \begin{code}
-rnMatch :: RdrNameMatch -> RnM_Fixes s (RenamedMatch, FreeVars)
-
-rnMatch match
-  = getSrcLocRn			`thenRn` \ src_loc ->
-    newLocalNames "variable in pattern"
-	 (binders `zip` repeat src_loc)	`thenRn` \ new_binders ->
-    extendSS2 new_binders (rnMatch_aux match)
-  where
-    binders = collect_binders match
-
-    collect_binders :: RdrNameMatch -> [RdrName]
+rnMatch :: RdrNameMatch -> RnMS s (RenamedMatch, FreeVars)
 
-    collect_binders (GRHSMatch _) = []
-    collect_binders (PatMatch pat match)
-      = collectPatBinders pat ++ collect_binders match
-
-rnMatch_aux (PatMatch pat match)
-  = rnPat pat		`thenRn` \ pat' ->
-    rnMatch_aux match	`thenRn` \ (match', fvMatch) ->
-    returnRn (PatMatch pat' match', fvMatch)
+rnMatch (PatMatch pat match)
+  = bindLocalsRn "pattern" binders	$ \ new_binders ->
+    rnPat pat				`thenRn` \ pat' ->
+    rnMatch match			`thenRn` \ (match', fvMatch) ->
+    returnRn (PatMatch pat' match', fvMatch `minusNameSet` mkNameSet new_binders)
+ where
+    binders = collectPatBinders pat
 
-rnMatch_aux (GRHSMatch grhss_and_binds)
+rnMatch (GRHSMatch grhss_and_binds)
   = rnGRHSsAndBinds grhss_and_binds `thenRn` \ (grhss_and_binds', fvs) ->
     returnRn (GRHSMatch grhss_and_binds', fvs)
 \end{code}
@@ -143,25 +145,25 @@ rnMatch_aux (GRHSMatch grhss_and_binds)
 %************************************************************************
 
 \begin{code}
-rnGRHSsAndBinds :: RdrNameGRHSsAndBinds -> RnM_Fixes s (RenamedGRHSsAndBinds, FreeVars)
+rnGRHSsAndBinds :: RdrNameGRHSsAndBinds -> RnMS s (RenamedGRHSsAndBinds, FreeVars)
 
 rnGRHSsAndBinds (GRHSsAndBindsIn grhss binds)
-  = rnBinds binds			`thenRn` \ (binds', fvBinds, scope) ->
-    extendSS2 scope (rnGRHSs grhss)	`thenRn` \ (grhss', fvGRHS) ->
-    returnRn (GRHSsAndBindsIn grhss' binds', fvBinds `unionUniqSets` fvGRHS)
+  = rnBinds binds		$ \ binds' ->
+    rnGRHSs grhss		`thenRn` \ (grhss', fvGRHS) ->
+    returnRn (GRHSsAndBindsIn grhss' binds', fvGRHS)
   where
-    rnGRHSs [] = returnRn ([], emptyUniqSet)
+    rnGRHSs [] = returnRn ([], emptyNameSet)
 
     rnGRHSs (grhs:grhss)
       = rnGRHS  grhs   `thenRn` \ (grhs',  fvs) ->
 	rnGRHSs grhss  `thenRn` \ (grhss', fvss) ->
-	returnRn (grhs' : grhss', fvs `unionUniqSets` fvss)
+	returnRn (grhs' : grhss', fvs `unionNameSets` fvss)
 
     rnGRHS (GRHS guard expr locn)
       = pushSrcLocRn locn $		    
 	rnExpr guard	`thenRn` \ (guard', fvsg) ->
 	rnExpr expr	`thenRn` \ (expr',  fvse) ->
-	returnRn (GRHS guard' expr' locn, fvsg `unionUniqSets` fvse)
+	returnRn (GRHS guard' expr' locn, fvsg `unionNameSets` fvse)
 
     rnGRHS (OtherwiseGRHS expr locn)
       = pushSrcLocRn locn $
@@ -176,39 +178,35 @@ rnGRHSsAndBinds (GRHSsAndBindsIn grhss binds)
 %************************************************************************
 
 \begin{code}
-rnExprs :: [RdrNameHsExpr] -> RnM_Fixes s ([RenamedHsExpr], FreeVars)
+rnExprs :: [RdrNameHsExpr] -> RnMS s ([RenamedHsExpr], FreeVars)
 
-rnExprs [] = returnRn ([], emptyUniqSet)
+rnExprs [] = returnRn ([], emptyNameSet)
 
 rnExprs (expr:exprs)
   = rnExpr expr 	`thenRn` \ (expr', fvExpr) ->
     rnExprs exprs	`thenRn` \ (exprs', fvExprs) ->
-    returnRn (expr':exprs', fvExpr `unionUniqSets` fvExprs)
+    returnRn (expr':exprs', fvExpr `unionNameSets` fvExprs)
 \end{code}
 
 Variables. We look up the variable and return the resulting name.  The
 interesting question is what the free-variable set should be.  We
 don't want to return imported or prelude things as free vars.  So we
-look at the RnName returned from the lookup, and make it part of the
-free-var set iff if it's a LocallyDefined RnName.
-
-ToDo: what about RnClassOps ???
+look at the Name returned from the lookup, and make it part of the
+free-var set iff if it's a LocallyDefined Name.
 \end{itemize}
 
 \begin{code}
-fv_set vname@(RnName n) | isLocallyDefinedName n
-		        = unitUniqSet vname
-fv_set _		= emptyUniqSet
-
-
-rnExpr :: RdrNameHsExpr -> RnM_Fixes s (RenamedHsExpr, FreeVars)
+rnExpr :: RdrNameHsExpr -> RnMS s (RenamedHsExpr, FreeVars)
 
 rnExpr (HsVar v)
-  = lookupValue v	`thenRn` \ vname ->
-    returnRn (HsVar vname, fv_set vname)
+  = lookupOccRn v	`thenRn` \ vname ->
+    returnRn (HsVar vname, if isLocallyDefined vname
+			   then unitNameSet vname
+			   else emptyUniqSet)
 
-rnExpr (HsLit lit)
-  = returnRn (HsLit lit, emptyUniqSet)
+rnExpr (HsLit lit) 
+  = litOccurrence lit		`thenRn_`
+    returnRn (HsLit lit, emptyNameSet)
 
 rnExpr (HsLam match)
   = rnMatch match	`thenRn` \ (match', fvMatch) ->
@@ -217,19 +215,11 @@ rnExpr (HsLam match)
 rnExpr (HsApp fun arg)
   = rnExpr fun		`thenRn` \ (fun',fvFun) ->
     rnExpr arg		`thenRn` \ (arg',fvArg) ->
-    returnRn (HsApp fun' arg', fvFun `unionUniqSets` fvArg)
+    returnRn (HsApp fun' arg', fvFun `unionNameSets` fvArg)
 
-rnExpr (OpApp e1 op e2)
-  = rnExpr e1		`thenRn` \ (e1', fvs_e1) ->
-    rnExpr op		`thenRn` \ (op', fvs_op) ->
-    rnExpr e2		`thenRn` \ (e2', fvs_e2) ->
-    precParseExpr (OpApp e1' op' e2') `thenRn` \ exp ->
-    returnRn (exp, (fvs_op `unionUniqSets` fvs_e1) `unionUniqSets` fvs_e2)
+rnExpr (OpApp e1 (HsVar op) e2) = rnOpApp e1 op e2
 
-rnExpr (NegApp e n)
-  = rnExpr e 		`thenRn` \ (e', fvs_e) ->
-    rnExpr n		`thenRn` \ (n', fvs_n) ->
-    returnRn (NegApp e' n', fvs_e `unionUniqSets` fvs_n)
+rnExpr (NegApp e n) = completeNegApp (rnExpr e)
 
 rnExpr (HsPar e)
   = rnExpr e 		`thenRn` \ (e', fvs_e) ->
@@ -238,15 +228,17 @@ rnExpr (HsPar e)
 rnExpr (SectionL expr op)
   = rnExpr expr	 	`thenRn` \ (expr', fvs_expr) ->
     rnExpr op	 	`thenRn` \ (op', fvs_op) ->
-    returnRn (SectionL expr' op', fvs_op `unionUniqSets` fvs_expr)
+    returnRn (SectionL expr' op', fvs_op `unionNameSets` fvs_expr)
 
 rnExpr (SectionR op expr)
   = rnExpr op	 	`thenRn` \ (op',   fvs_op) ->
     rnExpr expr	 	`thenRn` \ (expr', fvs_expr) ->
-    returnRn (SectionR op' expr', fvs_op `unionUniqSets` fvs_expr)
+    returnRn (SectionR op' expr', fvs_op `unionNameSets` fvs_expr)
 
 rnExpr (CCall fun args may_gc is_casm fake_result_ty)
-  = rnExprs args	`thenRn` \ (args', fvs_args) ->
+  = lookupImplicitOccRn ccallableClass_RDR	`thenRn_`
+    lookupImplicitOccRn creturnableClass_RDR	`thenRn_`
+    rnExprs args				`thenRn` \ (args', fvs_args) ->
     returnRn (CCall fun args' may_gc is_casm fake_result_ty, fvs_args)
 
 rnExpr (HsSCC label expr)
@@ -257,44 +249,47 @@ rnExpr (HsCase expr ms src_loc)
   = pushSrcLocRn src_loc $
     rnExpr expr		 	`thenRn` \ (new_expr, e_fvs) ->
     mapAndUnzipRn rnMatch ms	`thenRn` \ (new_ms, ms_fvs) ->
-    returnRn (HsCase new_expr new_ms src_loc, unionManyUniqSets (e_fvs : ms_fvs))
+    returnRn (HsCase new_expr new_ms src_loc, unionManyNameSets (e_fvs : ms_fvs))
 
 rnExpr (HsLet binds expr)
-  = rnBinds binds		`thenRn` \ (binds', fvBinds, new_binders) ->
-    extendSS2 new_binders (rnExpr expr) `thenRn` \ (expr',fvExpr) ->
-    returnRn (HsLet binds' expr', fvBinds `unionUniqSets` fvExpr)
+  = rnBinds binds		$ \ binds' ->
+    rnExpr expr			 `thenRn` \ (expr',fvExpr) ->
+    returnRn (HsLet binds' expr', fvExpr)
 
 rnExpr (HsDo stmts src_loc)
   = pushSrcLocRn src_loc $
-    rnStmts stmts		`thenRn` \ (stmts', fvStmts) ->
+    lookupImplicitOccRn monadZeroClass_RDR	`thenRn_`	-- Forces Monad to come too
+    rnStmts stmts				`thenRn` \ (stmts', fvStmts) ->
     returnRn (HsDo stmts' src_loc, fvStmts)
 
 rnExpr (ListComp expr quals)
-  = rnQuals quals 		`thenRn` \ ((quals', qual_binders), fvQuals) ->
-    extendSS2 qual_binders (rnExpr expr) `thenRn` \ (expr', fvExpr) ->
-    returnRn (ListComp expr' quals', fvExpr `unionUniqSets` fvQuals)
+  = addImplicitOccRn listType_name	`thenRn_` 
+    rnQuals expr quals 			`thenRn` \ ((expr', quals'), fvs) ->
+    returnRn (ListComp expr' quals', fvs)
 
 rnExpr (ExplicitList exps)
-  = rnExprs exps	 	`thenRn` \ (exps', fvs) ->
+  = addImplicitOccRn listType_name	`thenRn_` 
+    rnExprs exps		 	`thenRn` \ (exps', fvs) ->
     returnRn  (ExplicitList exps', fvs)
 
 rnExpr (ExplicitTuple exps)
-  = rnExprs exps	 	`thenRn` \ (exps', fvExps) ->
+  = addImplicitOccRn (tupleType_name (length exps))	`thenRn_` 
+    rnExprs exps	 				`thenRn` \ (exps', fvExps) ->
     returnRn (ExplicitTuple exps', fvExps)
 
 rnExpr (RecordCon (HsVar con) rbinds)
-  = lookupConstr con 			`thenRn` \ conname ->
+  = lookupOccRn con 			`thenRn` \ conname ->
     rnRbinds "construction" rbinds	`thenRn` \ (rbinds', fvRbinds) ->
     returnRn (RecordCon (HsVar conname) rbinds', fvRbinds)
 
 rnExpr (RecordUpd expr rbinds)
   = rnExpr expr			`thenRn` \ (expr', fvExpr) ->
     rnRbinds "update" rbinds	`thenRn` \ (rbinds', fvRbinds) ->
-    returnRn (RecordUpd expr' rbinds', fvExpr `unionUniqSets` fvRbinds)
+    returnRn (RecordUpd expr' rbinds', fvExpr `unionNameSets` fvRbinds)
 
 rnExpr (ExprWithTySig expr pty)
   = rnExpr expr			 	`thenRn` \ (expr', fvExpr) ->
-    rnPolyType nullTyVarNamesEnv pty `thenRn` \ pty' ->
+    rnHsType pty			`thenRn` \ pty' ->
     returnRn (ExprWithTySig expr' pty', fvExpr)
 
 rnExpr (HsIf p b1 b2 src_loc)
@@ -302,10 +297,11 @@ rnExpr (HsIf p b1 b2 src_loc)
     rnExpr p		`thenRn` \ (p', fvP) ->
     rnExpr b1		`thenRn` \ (b1', fvB1) ->
     rnExpr b2		`thenRn` \ (b2', fvB2) ->
-    returnRn (HsIf p' b1' b2' src_loc, unionManyUniqSets [fvP, fvB1, fvB2])
+    returnRn (HsIf p' b1' b2' src_loc, unionManyNameSets [fvP, fvB1, fvB2])
 
 rnExpr (ArithSeqIn seq)
-  = rn_seq seq 		`thenRn` \ (new_seq, fvs) ->
+  = lookupImplicitOccRn enumClass_RDR	`thenRn_`
+    rn_seq seq	 			`thenRn` \ (new_seq, fvs) ->
     returnRn (ArithSeqIn new_seq, fvs)
   where
     rn_seq (From expr)
@@ -315,19 +311,19 @@ rnExpr (ArithSeqIn seq)
     rn_seq (FromThen expr1 expr2)
      = rnExpr expr1 	`thenRn` \ (expr1', fvExpr1) ->
        rnExpr expr2	`thenRn` \ (expr2', fvExpr2) ->
-       returnRn (FromThen expr1' expr2', fvExpr1 `unionUniqSets` fvExpr2)
+       returnRn (FromThen expr1' expr2', fvExpr1 `unionNameSets` fvExpr2)
 
     rn_seq (FromTo expr1 expr2)
      = rnExpr expr1	`thenRn` \ (expr1', fvExpr1) ->
        rnExpr expr2	`thenRn` \ (expr2', fvExpr2) ->
-       returnRn (FromTo expr1' expr2', fvExpr1 `unionUniqSets` fvExpr2)
+       returnRn (FromTo expr1' expr2', fvExpr1 `unionNameSets` fvExpr2)
 
     rn_seq (FromThenTo expr1 expr2 expr3)
      = rnExpr expr1	`thenRn` \ (expr1', fvExpr1) ->
        rnExpr expr2	`thenRn` \ (expr2', fvExpr2) ->
        rnExpr expr3	`thenRn` \ (expr3', fvExpr3) ->
        returnRn (FromThenTo expr1' expr2' expr3',
-		  unionManyUniqSets [fvExpr1, fvExpr2, fvExpr3])
+		  unionManyNameSets [fvExpr1, fvExpr2, fvExpr3])
 \end{code}
 
 %************************************************************************
@@ -340,15 +336,14 @@ rnExpr (ArithSeqIn seq)
 rnRbinds str rbinds 
   = mapRn field_dup_err dup_fields	`thenRn_`
     mapAndUnzipRn rn_rbind rbinds	`thenRn` \ (rbinds', fvRbind_s) ->
-    returnRn (rbinds', unionManyUniqSets fvRbind_s)
+    returnRn (rbinds', unionManyNameSets fvRbind_s)
   where
     (_, dup_fields) = removeDups cmp [ f | (f,_,_) <- rbinds ]
 
-    field_dup_err dups = getSrcLocRn `thenRn` \ src_loc ->
-		         addErrRn (dupFieldErr str src_loc dups)
+    field_dup_err dups = addErrRn (dupFieldErr str dups)
 
     rn_rbind (field, expr, pun)
-      = lookupField field	`thenRn` \ fieldname ->
+      = lookupOccRn field	`thenRn` \ fieldname ->
 	rnExpr expr		`thenRn` \ (expr', fvExpr) ->
 	returnRn ((fieldname, expr', pun), fvExpr)
 
@@ -358,11 +353,10 @@ rnRpats rpats
   where
     (_, dup_fields) = removeDups cmp [ f | (f,_,_) <- rpats ]
 
-    field_dup_err dups = getSrcLocRn `thenRn` \ src_loc ->
-		         addErrRn (dupFieldErr "pattern" src_loc dups)
+    field_dup_err dups = addErrRn (dupFieldErr "pattern" dups)
 
     rn_rpat (field, pat, pun)
-      = lookupField field	`thenRn` \ fieldname ->
+      = lookupOccRn field	`thenRn` \ fieldname ->
 	rnPat pat		`thenRn` \ pat' ->
 	returnRn (fieldname, pat', pun)
 \end{code}
@@ -382,42 +376,43 @@ be @{r}@, and the free var set for the entire Quals will be @{r}@. This
 Quals.
 
 \begin{code}
-rnQuals :: [RdrNameQual]
-	 -> RnM_Fixes s (([RenamedQual],	-- renamed qualifiers
-		         [RnName]),		-- qualifiers' binders
-		         FreeVars)		-- free variables
-
-rnQuals [qual] 				-- must be at least one qual
-  = rnQual qual `thenRn` \ ((new_qual, bs), fvs) ->
-    returnRn (([new_qual], bs), fvs)
-
-rnQuals (qual: quals)
-  = rnQual qual				`thenRn` \ ((qual',  bs1), fvQuals1) ->
-    extendSS2 bs1 (rnQuals quals)	`thenRn` \ ((quals', bs2), fvQuals2) ->
-    returnRn
-       ((qual' : quals', bs1 ++ bs2),	-- The ones on the right (bs2) shadow the
-					-- ones on the left (bs1)
-	fvQuals1 `unionUniqSets` fvQuals2)
-
-rnQual (GeneratorQual pat expr)
-  = rnExpr expr		 `thenRn` \ (expr', fvExpr) ->
-    let
-	binders = collectPatBinders pat
-    in
-    getSrcLocRn		 `thenRn` \ src_loc ->
-    newLocalNames "variable in list-comprehension-generator pattern"
-	 (binders `zip` repeat src_loc)	  `thenRn` \ new_binders ->
-    extendSS new_binders (rnPat pat) `thenRn` \ pat' ->
+rnQuals :: RdrNameHsExpr -> [RdrNameQual]
+	 -> RnMS s ((RenamedHsExpr, [RenamedQual]), FreeVars)
+
+rnQuals expr [qual] 				-- must be at least one qual
+  = rnQual qual 			$ \ new_qual ->
+    rnExpr expr				`thenRn` \ (expr', fvs) ->
+    returnRn ((expr', [new_qual]), fvs)
+
+rnQuals expr (qual: quals)
+  = rnQual qual			$ \ qual' ->
+    rnQuals expr quals		`thenRn` \ ((expr', quals'), fv_quals) ->
+    returnRn ((expr', qual' : quals'), fv_quals)
 
-    returnRn ((GeneratorQual pat' expr', new_binders), fvExpr)
 
-rnQual (FilterQual expr)
-  = rnExpr expr	 `thenRn` \ (expr', fvs) ->
-    returnRn ((FilterQual expr', []), fvs)
+-- rnQual :: RdrNameQual
+--        -> (RenamedQual -> RnMS s (a,FreeVars))
+--        -> RnMS s (a,FreeVars)
+-- Because of mutual recursion the actual type is a bit less general than this [Haskell 1.2]
 
-rnQual (LetQual binds)
-  = rnBinds binds	`thenRn` \ (binds', binds_fvs, new_binders) ->
-    returnRn ((LetQual binds', new_binders), binds_fvs)
+rnQual (GeneratorQual pat expr) thing_inside
+  = rnExpr expr		 					`thenRn` \ (expr', fv_expr) ->
+    bindLocalsRn "pattern in list comprehension" binders	$ \ new_binders ->
+    rnPat pat							`thenRn` \ pat' ->
+
+    thing_inside (GeneratorQual pat' expr')		`thenRn` \ (result, fvs) -> 	
+    returnRn (result, fv_expr `unionNameSets` (fvs `minusNameSet` mkNameSet new_binders))
+  where
+    binders = collectPatBinders pat
+
+rnQual (FilterQual expr) thing_inside
+  = rnExpr expr	 			`thenRn` \ (expr', fv_expr) ->
+    thing_inside (FilterQual expr')	`thenRn` \ (result, fvs) ->
+    returnRn (result, fv_expr `unionNameSets` fvs)
+
+rnQual (LetQual binds) thing_inside
+  = rnBinds binds			$ \ binds' ->
+    thing_inside (LetQual binds')
 \end{code}
 
 
@@ -428,39 +423,42 @@ rnQual (LetQual binds)
 %************************************************************************
 
 \begin{code}
-rnStmts :: [RdrNameStmt] -> RnM_Fixes s ([RenamedStmt], FreeVars)
+rnStmts :: [RdrNameStmt] -> RnMS s ([RenamedStmt], FreeVars)
 
-rnStmts [stmt@(ExprStmt _ _)]		-- last stmt must be ExprStmt
-  = rnStmt stmt				`thenRn` \ ((stmt',[]), fvStmt) ->
-    returnRn ([stmt'], fvStmt)
+rnStmts [stmt@(ExprStmt expr src_loc)]		-- last stmt must be ExprStmt
+  = pushSrcLocRn src_loc $
+    rnExpr expr				`thenRn` \ (expr', fv_expr) ->
+    returnRn ([ExprStmt expr' src_loc], fv_expr)
 
 rnStmts (stmt:stmts)
-  = rnStmt stmt				`thenRn` \ ((stmt',bs), fvStmt) ->
-    extendSS2 bs (rnStmts stmts)	`thenRn` \ (stmts',     fvStmts) ->
-    returnRn (stmt':stmts', fvStmt `unionUniqSets` fvStmts)
+  = rnStmt stmt				$ \ stmt' ->
+    rnStmts stmts			`thenRn` \ (stmts', fv_stmts) ->
+    returnRn (stmt':stmts', fv_stmts)
 
 
-rnStmt (BindStmt pat expr src_loc)
-  = pushSrcLocRn src_loc $
-    rnExpr expr		 		`thenRn` \ (expr', fvExpr) ->
-    let
-	binders = collectPatBinders pat
-    in
-    newLocalNames "variable in do binding"
-	 (binders `zip` repeat src_loc)	`thenRn` \ new_binders ->
-    extendSS new_binders (rnPat pat) 	`thenRn` \ pat' ->
+-- rnStmt :: RdrNameStmt -> (RenamedStmt -> RnMS s (a, FreeVars)) -> RnMS s (a, FreeVars)
+-- Because of mutual recursion the actual type is a bit less general than this [Haskell 1.2]
 
-    returnRn ((BindStmt pat' expr' src_loc, new_binders), fvExpr)
+rnStmt (BindStmt pat expr src_loc) thing_inside
+  = pushSrcLocRn src_loc $
+    rnExpr expr			 			`thenRn` \ (expr', fv_expr) ->
+    bindLocalsRn "pattern in do binding" binders	$ \ new_binders ->
+    rnPat pat					 	`thenRn` \ pat' ->
 
-rnStmt (ExprStmt expr src_loc)
-  = 
-    rnExpr expr	 			`thenRn` \ (expr', fvs) ->
-    returnRn ((ExprStmt expr' src_loc, []), fvs)
+    thing_inside (BindStmt pat' expr' src_loc)		`thenRn` \ (result, fvs) -> 
+    returnRn (result, fv_expr `unionNameSets` (fvs `minusNameSet` mkNameSet new_binders))
+  where
+    binders = collectPatBinders pat
 
-rnStmt (LetStmt binds)
-  = rnBinds binds	`thenRn` \ (binds', binds_fvs, new_binders) ->
-    returnRn ((LetStmt binds', new_binders), binds_fvs)
+rnStmt (ExprStmt expr src_loc) thing_inside
+  = pushSrcLocRn src_loc $
+    rnExpr expr	 				`thenRn` \ (expr', fv_expr) ->
+    thing_inside (ExprStmt expr' src_loc)	`thenRn` \ (result, fvs) ->
+    returnRn (result, fv_expr `unionNameSets` fvs)
 
+rnStmt (LetStmt binds) thing_inside
+  = rnBinds binds		$ \ binds' ->
+    thing_inside (LetStmt binds')
 \end{code}
 
 %************************************************************************
@@ -469,83 +467,89 @@ rnStmt (LetStmt binds)
 %*									*
 %************************************************************************
 
-\begin{code}
-precParseExpr :: RenamedHsExpr -> RnM_Fixes s RenamedHsExpr
-precParsePat  :: RenamedPat -> RnM_Fixes s RenamedPat
+@rnOpApp@ deals with operator applications.  It does some rearrangement of
+the expression so that the precedences are right.  This must be done on the
+expression *before* renaming, because fixity info applies to the things
+the programmer actually wrote.
 
-precParseExpr exp@(OpApp (NegApp e1 n) (HsVar op) e2)
-  = lookupFixity op		`thenRn` \ (op_fix, op_prec) ->
-    if 6 < op_prec then		
+\begin{code}
+rnOpApp (NegApp e11 n) op e2
+  = lookupFixity op		`thenRn` \ (Fixity op_prec op_dir) ->
+    if op_prec > 6 then		
 	-- negate precedence 6 wired in
 	-- (-x)*y  ==> -(x*y)
-	precParseExpr (OpApp e1 (HsVar op) e2) `thenRn` \ op_app ->
-	returnRn (NegApp op_app n)
+	completeNegApp (rnOpApp e11 op e2)
     else
-	returnRn exp
+	completeOpApp (completeNegApp (rnExpr e11)) op (rnExpr e2)
 
-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]) $
+rnOpApp (OpApp e11 (HsVar op1) e12) op e2
+  = lookupFixity op		 `thenRn` \ op_fix@(Fixity op_prec  op_dir) ->
+    lookupFixity op1		 `thenRn` \ op1_fix@(Fixity op1_prec op1_dir) ->
+    -- pprTrace "rnOpApp:" (ppCat [ppr PprDebug op, ppInt op_prec, ppr PprDebug op1, ppInt op1_prec]) $
     case (op1_prec `cmp` op_prec) of
       LT_  -> rearrange
-      EQ_  -> case (op1_fix, op_fix) of
-		(INFIXR, INFIXR) -> rearrange
-		(INFIXL, INFIXL) -> returnRn exp
-		_ -> getSrcLocRn `thenRn` \ src_loc ->
-		     failButContinueRn exp
-		     (precParseErr (op1,op1_fix,op1_prec) (op,op_fix,op_prec) src_loc)
-      GT__ -> returnRn exp
+      EQ_  -> case (op1_dir, op_dir) of
+		(InfixR, InfixR) -> rearrange
+		(InfixL, InfixL) -> dont_rearrange
+		_ -> addErrRn (precParseErr (op1,op1_fix) (op,op_fix))	`thenRn_`
+		     dont_rearrange
+      GT__ -> dont_rearrange
   where
-    rearrange = precParseExpr (OpApp e12 (HsVar op) e2) `thenRn` \ e2' ->
-	        returnRn (OpApp e11 (HsVar op1) e2')
+    rearrange      = rnOpApp e11 op1 (OpApp e12 (HsVar op) e2)
+    dont_rearrange = completeOpApp (rnOpApp e11 op1 e12) op (rnExpr e2)
+
+rnOpApp e1 op e2 = completeOpApp (rnExpr e1) op (rnExpr e2)
 
-precParseExpr exp = returnRn exp
+completeOpApp rn_e1 op rn_e2
+  = rn_e1		`thenRn` \ (e1', fvs1) ->
+    rn_e2		`thenRn` \ (e2', fvs2) ->
+    rnExpr (HsVar op)	`thenRn` \ (op', fvs3) ->
+    returnRn (OpApp e1' op' e2', fvs1 `unionNameSets` fvs2 `unionNameSets` fvs3)
 
+completeNegApp rn_expr
+  = rn_expr				`thenRn` \ (e', fvs_e) ->
+    lookupImplicitOccRn negate_RDR	`thenRn` \ neg ->
+    returnRn (NegApp e' (HsVar neg), fvs_e)
+\end{code}
 
-precParsePat pat@(ConOpPatIn (NegPatIn e1) op e2)
-  = lookupFixity op		`thenRn` \ (op_fix, op_prec) ->
-    if 6 < op_prec then	
+\begin{code}
+rnOpPat p1@(NegPatIn p11) op p2
+  = lookupFixity op		`thenRn` \ op_fix@(Fixity op_prec op_dir) ->
+    if op_prec > 6 then	
 	-- negate precedence 6 wired in
-	getSrcLocRn `thenRn` \ src_loc ->
-	failButContinueRn pat (precParseNegPatErr (op,op_fix,op_prec) src_loc)
+	addErrRn (precParseNegPatErr (op,op_fix))	`thenRn_`
+	rnOpPat p11 op p2				`thenRn` \ op_pat ->
+	returnRn (NegPatIn op_pat)
     else
-	returnRn pat
+	completeOpPat (rnPat p1) op (rnPat p2)
 
-precParsePat pat@(ConOpPatIn (ConOpPatIn p11 op1 p12) op p2)
-  = lookupFixity op		 `thenRn` \ (op_fix, op_prec) ->
-    lookupFixity op1		 `thenRn` \ (op1_fix, op1_prec) ->
+rnOpPat (ConOpPatIn p11 op1 p12) op p2
+  = lookupFixity op		 `thenRn` \  op_fix@(Fixity op_prec  op_dir) ->
+    lookupFixity op1		 `thenRn` \ op1_fix@(Fixity op1_prec op1_dir) ->
     case (op1_prec `cmp` op_prec) of
       LT_  -> rearrange
-      EQ_  -> case (op1_fix, op_fix) of
-		(INFIXR, INFIXR) -> rearrange
-		(INFIXL, INFIXL) -> returnRn pat
-		_ -> getSrcLocRn `thenRn` \ src_loc ->
-		     failButContinueRn pat
-		       (precParseErr (op1,op1_fix,op1_prec) (op,op_fix,op_prec) src_loc)
-      GT__ -> returnRn pat
+      EQ_  -> case (op1_dir, op_dir) of
+		(InfixR, InfixR) -> rearrange
+		(InfixL, InfixL) -> dont_rearrange
+		_ -> addErrRn (precParseErr (op1,op1_fix) (op,op_fix))	`thenRn_`
+		     dont_rearrange
+      GT__ -> dont_rearrange
   where
-    rearrange = precParsePat (ConOpPatIn p12 op p2) `thenRn` \ p2' ->
-	        returnRn (ConOpPatIn p11 op1 p2')
-
-precParsePat pat = returnRn pat
+    rearrange      = rnOpPat p11 op1 (ConOpPatIn p12 op p2)
+    dont_rearrange = completeOpPat (rnOpPat p11 op1 p12) op (rnPat p2)
 
 
-data INFIX = INFIXL | INFIXR | INFIXN deriving Eq
+rnOpPat p1 op p2 = completeOpPat (rnPat p1) op (rnPat p2)
 
-lookupFixity :: RnName -> RnM_Fixes s (INFIX, Int)
-lookupFixity op
-  = getExtraRn `thenRn` \ fixity_fm ->
-    -- pprTrace "lookupFixity:" (ppAboves [ppCat [pprUnique u, ppr PprDebug i_f] | (u,i_f) <- ufmToList fixity_fm]) $
-    case lookupUFM fixity_fm op of
-      Nothing           -> returnRn (INFIXL, 9)
-      Just (InfixL _ n) -> returnRn (INFIXL, n)
-      Just (InfixR _ n) -> returnRn (INFIXR, n)
-      Just (InfixN _ n) -> returnRn (INFIXN, n)
+completeOpPat rn_p1 op rn_p2
+  = rn_p1		`thenRn` \ p1' ->
+    rn_p2		`thenRn` \ p2' -> 
+    lookupRn op		`thenRn` \ op' ->
+    returnRn (ConOpPatIn p1' op' p2')
 \end{code}
 
 \begin{code}
-checkPrecMatch :: Bool -> RnName -> RenamedMatch -> RnM_Fixes s ()
+checkPrecMatch :: Bool -> RdrName -> RdrNameMatch -> RnMS s ()
 
 checkPrecMatch False fn match
   = returnRn ()
@@ -556,50 +560,95 @@ checkPrecMatch True op _
   = panic "checkPrecMatch"
 
 checkPrec op (ConOpPatIn _ op1 _) right
-  = lookupFixity op	`thenRn` \ (op_fix, op_prec) ->
-    lookupFixity op1	`thenRn` \ (op1_fix, op1_prec) ->
-    getSrcLocRn 	`thenRn` \ src_loc ->
+  = lookupFixity op	`thenRn` \  op_fix@(Fixity op_prec  op_dir) ->
+    lookupFixity op1	`thenRn` \ op1_fix@(Fixity op1_prec op1_dir) ->
     let
 	inf_ok = op1_prec > op_prec || 
 	         (op1_prec == op_prec &&
-		  (op1_fix == INFIXR && op_fix == INFIXR && right ||
-		   op1_fix == INFIXL && op_fix == INFIXL && not right))
+		  (op1_dir == InfixR && op_dir == InfixR && right ||
+		   op1_dir == InfixL && op_dir == InfixL && not right))
 
-	info  = (op,op_fix,op_prec)
-	info1 = (op1,op1_fix,op1_prec)
+	info  = (op,op_fix)
+	info1 = (op1,op1_fix)
 	(infol, infor) = if right then (info, info1) else (info1, info)
     in
-    addErrIfRn (not inf_ok) (precParseErr infol infor src_loc)
+    checkRn inf_ok (precParseErr infol infor)
 
 checkPrec op (NegPatIn _) right
-  = lookupFixity op	`thenRn` \ (op_fix, op_prec) ->
-    getSrcLocRn 	`thenRn` \ src_loc ->
-    addErrIfRn (6 < op_prec) (precParseNegPatErr (op,op_fix,op_prec) src_loc)
+  = lookupFixity op	`thenRn` \ op_fix@(Fixity op_prec op_dir) ->
+    checkRn (op_prec <= 6) (precParseNegPatErr (op,op_fix))
 
 checkPrec op pat right
   = returnRn ()
 \end{code}
 
+%************************************************************************
+%*									*
+\subsubsection{Literals}
+%*									*
+%************************************************************************
+
+When literals occur we have to make sure that the types and classes they involve
+are made available.
+
+\begin{code}
+litOccurrence (HsChar _)
+  = addImplicitOccRn charType_name
+
+litOccurrence (HsCharPrim _)
+  = addImplicitOccRn (getName charPrimTyCon)
+
+litOccurrence (HsString _)
+  = addImplicitOccRn listType_name	`thenRn_`
+    addImplicitOccRn charType_name
+
+litOccurrence (HsStringPrim _)
+  = addImplicitOccRn (getName addrPrimTyCon)
+
+litOccurrence (HsInt _)
+  = lookupImplicitOccRn numClass_RDR	`thenRn_`	-- Int and Integer are forced in by Num
+    returnRn ()
+
+litOccurrence (HsFrac _)
+  = lookupImplicitOccRn fractionalClass_RDR	`thenRn_`	-- ... similarly Rational
+    returnRn ()
+
+litOccurrence (HsIntPrim _)
+  = addImplicitOccRn (getName intPrimTyCon)
+
+litOccurrence (HsFloatPrim _)
+  = addImplicitOccRn (getName floatPrimTyCon)
+
+litOccurrence (HsDoublePrim _)
+  = addImplicitOccRn (getName doublePrimTyCon)
+
+litOccurrence (HsLitLit _)
+  = lookupImplicitOccRn ccallableClass_RDR	`thenRn_`
+    returnRn ()
+\end{code}
+
+
+%************************************************************************
+%*									*
+\subsubsection{Errors}
+%*									*
+%************************************************************************
+
 \begin{code}
-dupFieldErr str src_loc (dup:rest)
-  = addShortErrLocLine src_loc (\ sty ->
-    ppBesides [ppStr "duplicate field name `", ppr sty dup, ppStr "' in record ", ppStr str])
-
-negPatErr pat src_loc
-  = addShortErrLocLine src_loc (\ sty ->
-    ppSep [ppStr "prefix `-' not applied to literal in pattern", ppr sty pat])
-
-precParseNegPatErr op src_loc
-  = addErrLoc src_loc "precedence parsing error" (\ sty ->
-    ppBesides [ppStr "prefix `-' has lower precedence than ", pp_op sty op, ppStr " in pattern"])
-
-precParseErr op1 op2 src_loc
-  = addErrLoc src_loc "precedence parsing error" (\ sty -> 
-    ppBesides [ppStr "cannot mix ", pp_op sty op1, ppStr " and ", pp_op sty op2,
-	       ppStr " in the same infix expression"])
-
-pp_op sty (op, fix, prec) = ppBesides [pprSym sty op, ppLparen, pp_fix fix, ppSP, ppInt prec, ppRparen]
-pp_fix INFIXL = ppStr "infixl"
-pp_fix INFIXR = ppStr "infixr"
-pp_fix INFIXN = ppStr "infix"
+dupFieldErr str (dup:rest) sty
+  = ppBesides [ppStr "duplicate field name `", ppr sty dup, ppStr "' in record ", ppStr str]
+
+negPatErr pat  sty
+  = ppSep [ppStr "prefix `-' not applied to literal in pattern", ppr sty pat]
+
+precParseNegPatErr op sty 
+  = ppHang (ppStr "precedence parsing error")
+      4 (ppBesides [ppStr "prefix `-' has lower precedence than ", pp_op sty op, ppStr " in pattern"])
+
+precParseErr op1 op2  sty
+  = ppHang (ppStr "precedence parsing error")
+      4 (ppBesides [ppStr "cannot mix ", pp_op sty op1, ppStr " and ", pp_op sty op2,
+	 	    ppStr " in the same infix expression"])
+
+pp_op sty (op, fix) = ppBesides [pprSym sty op, ppLparen, ppr sty fix, ppRparen]
 \end{code}
diff --git a/ghc/compiler/rename/RnHsSyn.lhs b/ghc/compiler/rename/RnHsSyn.lhs
index db994b1561..db49db2daa 100644
--- a/ghc/compiler/rename/RnHsSyn.lhs
+++ b/ghc/compiler/rename/RnHsSyn.lhs
@@ -12,191 +12,78 @@ IMP_Ubiq()
 
 import HsSyn
 
-import Id		( isDataCon, GenId, SYN_IE(Id) )
-import Name		( isLocalName, nameUnique, Name, RdrName(..),
-			  mkLocalName
-			)
+import Id		( GenId, SYN_IE(Id) )
+import Name		( Name )
 import Outputable	( Outputable(..){-instance * []-} )
 import PprStyle		( PprStyle(..) )
 import PprType		( GenType, GenTyVar, TyCon )
 import Pretty
+import Name		( SYN_IE(NameSet), unitNameSet, mkNameSet, minusNameSet, unionNameSets, emptyNameSet )
 import TyCon		( TyCon )
 import TyVar		( GenTyVar )
-import Unique		( mkAlphaTyVarUnique, Unique )
+import Unique		( Unique )
 import Util		( panic, pprPanic{-, pprTrace ToDo:rm-} )
 \end{code}
 
-\begin{code}
-data RnName
-  = WiredInId       Id
-  | WiredInTyCon    TyCon
-  | RnName          Name        	-- functions/binders/tyvars
-  | RnSyn           Name        	-- type synonym
-  | RnData          Name [Name] [Name]	-- data type   (with constrs and fields)
-  | RnConstr        Name  Name		-- constructor (with data type)
-  | RnField	    Name  Name	  	-- field       (with data type)
-  | RnClass         Name [Name] 	-- class       (with class ops)
-  | RnClassOp       Name  Name  	-- class op    (with class)
-  | RnImplicit      Name      		-- implicitly imported
-  | RnImplicitTyCon Name      		-- implicitly imported
-  | RnImplicitClass Name      		-- implicitly imported
-  | RnUnbound	    RdrName    		-- place holder
-
-mkRnName          = RnName
-mkRnImplicit      = RnImplicit
-mkRnImplicitTyCon = RnImplicitTyCon
-mkRnImplicitClass = RnImplicitClass
-mkRnUnbound       = RnUnbound
-
-isRnWired (WiredInId _)    = True
-isRnWired (WiredInTyCon _) = True
-isRnWired _ 	           = False
-
-isRnLocal (RnName n) = isLocalName n
-isRnLocal _ 	     = False
-
-isRnTyCon (WiredInTyCon _)    = True
-isRnTyCon (RnSyn _)    	      = True
-isRnTyCon (RnData _ _ _)      = True
-isRnTyCon (RnImplicitTyCon _) = True
-isRnTyCon _            	      = False
-
-isRnClass (RnClass _ _)       = True
-isRnClass (RnImplicitClass _) = True
-isRnClass _                   = False
-
--- a common need: isRnTyCon || isRnClass:
-isRnTyConOrClass (WiredInTyCon _)    = True
-isRnTyConOrClass (RnSyn _)    	     = True
-isRnTyConOrClass (RnData _ _ _)	     = True
-isRnTyConOrClass (RnImplicitTyCon _) = True
-isRnTyConOrClass (RnClass _ _)       = True
-isRnTyConOrClass (RnImplicitClass _) = True
-isRnTyConOrClass _                   = False
-
-isRnConstr (RnConstr _ _) = True
-isRnConstr (WiredInId id) = isDataCon id
-isRnConstr  _		  = False
-
-isRnField  (RnField _ _)  = True
-isRnField  _		  = False
-
-isRnClassOp cls (RnClassOp _ op_cls) = eqUniqsNamed cls op_cls
-isRnClassOp cls n		     = True -- pprTrace "isRnClassOp:" (ppr PprShowAll n) $ True -- let it past anyway
-
-isRnImplicit (RnImplicit _)      = True
-isRnImplicit (RnImplicitTyCon _) = True
-isRnImplicit (RnImplicitClass _) = True
-isRnImplicit _			 = False
-
-isRnUnbound (RnUnbound _) = True
-isRnUnbound _		  = False
-
-isRnEntity (WiredInId _)       = True
-isRnEntity (WiredInTyCon _)    = True
-isRnEntity (RnName n)	       = not (isLocalName n)
-isRnEntity (RnSyn _)           = True
-isRnEntity (RnData _ _ _)      = True
-isRnEntity (RnClass _ _)       = True
-isRnEntity _                   = False
-
--- Very general NamedThing comparison, used when comparing
--- Uniquable things with different types
-
-eqUniqsNamed  n1 n2 = uniqueOf n1  ==   uniqueOf n2
-cmpUniqsNamed n1 n2 = uniqueOf n1 `cmp` uniqueOf n2
-
-instance Eq RnName where
-    a == b = eqUniqsNamed a b
-
-instance Ord3 RnName where
-    a `cmp` b = cmpUniqsNamed a b
-
-instance Uniquable RnName where
-    uniqueOf = nameUnique . getName
-
-instance NamedThing RnName where
-    getName (WiredInId id)      = getName id
-    getName (WiredInTyCon tc)   = getName tc
-    getName (RnName n)	        = n
-    getName (RnSyn n)	        = n
-    getName (RnData n _ _)      = n
-    getName (RnConstr n _)      = n
-    getName (RnField n _)       = n
-    getName (RnClass n _)       = n
-    getName (RnClassOp n _)     = n
-    getName (RnImplicit n)      = n
-    getName (RnImplicitTyCon n) = n
-    getName (RnImplicitClass n) = n
-    getName (RnUnbound occ)     = --pprTrace "getRnName:RnUnbound: " (ppr PprDebug occ)
-				  (case occ of
-				     Unqual n -> mkLocalName bottom n False bottom2
-				     Qual m n -> mkLocalName bottom n False bottom2)
-			        where bottom = mkAlphaTyVarUnique 0 -- anything; just something that will print
-				      bottom2 = panic "getRnName: srcloc"
-
-instance Outputable RnName where
-#ifdef DEBUG
-    ppr sty@PprShowAll (RnData n cs fs)  = ppBesides [ppr sty n, ppStr "{-", ppr sty cs, ppr sty fs, ppStr "-}"]
-    ppr sty@PprShowAll (RnConstr n d)    = ppBesides [ppr sty n, ppStr "{-", ppr sty d, ppStr "-}"]
-    ppr sty@PprShowAll (RnField  n d)    = ppBesides [ppr sty n, ppStr "{-", ppr sty d, ppStr "-}"]
-    ppr sty@PprShowAll (RnClass n ops)   = ppBesides [ppr sty n, ppStr "{-", ppr sty ops, ppStr "-}"]
-    ppr sty@PprShowAll (RnClassOp n c)   = ppBesides [ppr sty n, ppStr "{-", ppr sty c, ppStr "-}"]
-#endif
-    ppr sty (WiredInId id)      = ppr sty id
-    ppr sty (WiredInTyCon tycon)= ppr sty tycon
-    ppr sty (RnUnbound occ)	= ppBeside (ppr sty occ) (ppPStr SLIT("{-UNBOUND-}"))
-    ppr sty rn_name		= ppr sty (getName rn_name)
-\end{code}
 
 \begin{code}
-type RenamedArithSeqInfo	= ArithSeqInfo		Fake Fake RnName RenamedPat
-type RenamedBind		= Bind			Fake Fake RnName RenamedPat
-type RenamedClassDecl		= ClassDecl		Fake Fake RnName RenamedPat
-type RenamedClassOpSig		= Sig			RnName
-type RenamedConDecl		= ConDecl		RnName
-type RenamedContext		= Context 		RnName
-type RenamedSpecDataSig		= SpecDataSig		RnName
-type RenamedDefaultDecl		= DefaultDecl		RnName
-type RenamedFixityDecl		= FixityDecl		RnName
-type RenamedGRHS		= GRHS			Fake Fake RnName RenamedPat
-type RenamedGRHSsAndBinds	= GRHSsAndBinds		Fake Fake RnName RenamedPat
-type RenamedHsBinds		= HsBinds		Fake Fake RnName RenamedPat
-type RenamedHsExpr		= HsExpr		Fake Fake RnName RenamedPat
-type RenamedHsModule		= HsModule		Fake Fake RnName RenamedPat
-type RenamedInstDecl		= InstDecl		Fake Fake RnName RenamedPat
-type RenamedMatch		= Match			Fake Fake RnName RenamedPat
-type RenamedMonoBinds		= MonoBinds		Fake Fake RnName RenamedPat
-type RenamedMonoType		= MonoType		RnName
-type RenamedPat			= InPat			RnName
-type RenamedPolyType		= PolyType		RnName
-type RenamedRecordBinds		= HsRecordBinds		Fake Fake RnName RenamedPat
-type RenamedQual		= Qualifier		Fake Fake RnName RenamedPat
-type RenamedSig			= Sig			RnName
-type RenamedSpecInstSig		= SpecInstSig 		RnName
-type RenamedStmt		= Stmt			Fake Fake RnName RenamedPat
-type RenamedTyDecl		= TyDecl		RnName
-
-type RenamedClassOpPragmas	= ClassOpPragmas	RnName
-type RenamedClassPragmas	= ClassPragmas		RnName
-type RenamedDataPragmas		= DataPragmas		RnName
-type RenamedGenPragmas		= GenPragmas		RnName
-type RenamedInstancePragmas	= InstancePragmas	RnName
+type RenamedArithSeqInfo	= ArithSeqInfo		Fake Fake Name RenamedPat
+type RenamedBind		= Bind			Fake Fake Name RenamedPat
+type RenamedClassDecl		= ClassDecl		Fake Fake Name RenamedPat
+type RenamedClassOpSig		= Sig			Name
+type RenamedConDecl		= ConDecl		Name
+type RenamedContext		= Context 		Name
+type RenamedHsDecl		= HsDecl		Fake Fake Name RenamedPat
+type RenamedSpecDataSig		= SpecDataSig		Name
+type RenamedDefaultDecl		= DefaultDecl		Name
+type RenamedFixityDecl		= FixityDecl		Name
+type RenamedGRHS		= GRHS			Fake Fake Name RenamedPat
+type RenamedGRHSsAndBinds	= GRHSsAndBinds		Fake Fake Name RenamedPat
+type RenamedHsBinds		= HsBinds		Fake Fake Name RenamedPat
+type RenamedHsExpr		= HsExpr		Fake Fake Name RenamedPat
+type RenamedHsModule		= HsModule		Fake Fake Name RenamedPat
+type RenamedInstDecl		= InstDecl		Fake Fake Name RenamedPat
+type RenamedMatch		= Match			Fake Fake Name RenamedPat
+type RenamedMonoBinds		= MonoBinds		Fake Fake Name RenamedPat
+type RenamedPat			= InPat			Name
+type RenamedHsType		= HsType		Name
+type RenamedRecordBinds		= HsRecordBinds		Fake Fake Name RenamedPat
+type RenamedQual		= Qualifier		Fake Fake Name RenamedPat
+type RenamedSig			= Sig			Name
+type RenamedSpecInstSig		= SpecInstSig 		Name
+type RenamedStmt		= Stmt			Fake Fake Name RenamedPat
+type RenamedTyDecl		= TyDecl		Name
+
+type RenamedClassOpPragmas	= ClassOpPragmas	Name
+type RenamedClassPragmas	= ClassPragmas		Name
+type RenamedDataPragmas		= DataPragmas		Name
+type RenamedGenPragmas		= GenPragmas		Name
+type RenamedInstancePragmas	= InstancePragmas	Name
 \end{code}
 
+%************************************************************************
+%*									*
+\subsection{Free variables}
+%*									*
+%************************************************************************
+
 \begin{code}
-collectQualBinders :: [RenamedQual] -> [RnName]
+extractCtxtTyNames :: RenamedContext -> NameSet
+extractCtxtTyNames ctxt = foldr (unionNameSets . extractHsTyNames . snd) emptyNameSet ctxt
 
-collectQualBinders quals
-  = concat (map collect quals)
+extractHsTyNames   :: RenamedHsType  -> NameSet
+extractHsTyNames ty
+  = get ty
   where
-    collect (GeneratorQual pat _) = collectPatBinders pat
-    collect (FilterQual expr)	  = []
-    collect (LetQual    binds)	  = collectTopLevelBinders binds
+    get (MonoTyApp con tys)      = foldr (unionNameSets . get) (unitNameSet con) tys
+    get (MonoListTy tc ty)       = unitNameSet tc `unionNameSets` get ty
+    get (MonoTupleTy tc tys)     = foldr (unionNameSets . get) (unitNameSet tc) tys
+    get (MonoFunTy ty1 ty2)      = get ty1 `unionNameSets` get ty2
+    get (MonoDictTy cls ty)      = unitNameSet cls `unionNameSets` get ty
+    get (MonoTyVar tv)	         = unitNameSet tv
+    get (HsForAllTy tvs ctxt ty) = foldr (unionNameSets . get . snd) (get ty) ctxt
+					    `minusNameSet`
+				    mkNameSet (map getTyVarName tvs)
 
-fixDeclName :: FixityDecl name -> name
-fixDeclName (InfixL name i) = name
-fixDeclName (InfixR name i) = name
-fixDeclName (InfixN name i) = name
 \end{code}
 
diff --git a/ghc/compiler/rename/RnIfaces.lhs b/ghc/compiler/rename/RnIfaces.lhs
index 396f021ab0..649391dd4d 100644
--- a/ghc/compiler/rename/RnIfaces.lhs
+++ b/ghc/compiler/rename/RnIfaces.lhs
@@ -7,866 +7,565 @@
 #include "HsVersions.h"
 
 module RnIfaces (
-	cachedIface,
-	cachedDecl, CachingResult(..),
-	rnIfaces,
-	IfaceCache, initIfaceCache
+	getInterfaceExports,
+	getImportedInstDecls,
+	getSpecialInstModules,
+	getDecl, getWiredInDecl,
+	getImportVersions,
+
+	checkUpToDate,
+
+	getDeclBinders,
+	mkSearchPath
     ) where
 
 IMP_Ubiq()
 
-import PreludeGlaST	( thenPrimIO, newVar, readVar, writeVar, SYN_IE(MutableVar) )
-#if __GLASGOW_HASKELL__ >= 200
-# define ST_THEN `stThen`
-# define TRY_IO  tryIO
-IMPORT_1_3(GHCio(stThen,tryIO))
-#else
-# define ST_THEN `thenPrimIO`
-# define TRY_IO	 try
-#endif
-
-import HsSyn
-import HsPragmas	( noGenPragmas )
-import RdrHsSyn
-import RnHsSyn
 
+import HsSyn		( HsDecl(..), TyDecl(..), ClassDecl(..), HsTyVar, Bind, HsExpr, Sig(..), 
+			  HsBinds(..), MonoBinds, DefaultDecl, ConDecl(..), HsType, BangType, IfaceSig(..),
+			  FixityDecl(..), Fixity, Fake, InPat, InstDecl(..), SYN_IE(Version), HsIdInfo
+			)
+import HsPragmas	( noGenPragmas )
+import RdrHsSyn		( SYN_IE(RdrNameHsDecl), SYN_IE(RdrNameInstDecl), 
+			  RdrName, rdrNameOcc
+			)
+import RnEnv		( newGlobalName, lookupRn, addImplicitOccsRn, availNames )
+import RnSource		( rnHsType )
 import RnMonad
-import RnSource		( rnTyDecl, rnClassDecl, rnInstDecl, rnPolyType )
-import RnUtils		( SYN_IE(RnEnv), emptyRnEnv, lookupRnEnv, lookupTcRnEnv, extendGlobalRnEnv )
 import ParseIface	( parseIface )
-import ParseUtils	( ParsedIface(..), RdrIfaceDecl(..), RdrIfaceInst(..),
-			  VersionsMap(..), UsagesMap(..)
-			)
 
-import Bag		( emptyBag, unitBag, consBag, snocBag,
-			  unionBags, unionManyBags, isEmptyBag, bagToList )
 import ErrUtils		( SYN_IE(Error), SYN_IE(Warning) )
-import FiniteMap	( emptyFM, lookupFM, addToFM, addToFM_C, plusFM, eltsFM,
-			  fmToList, delListFromFM, sizeFM, foldFM, unitFM,
-			  plusFM_C, addListToFM{-, keysFM ToDo:rm-}, FiniteMap
-			)
-import Maybes		( maybeToBool, MaybeErr(..) )
-import Name		( origName, moduleOf, nameOf, qualToOrigName, OrigName(..),
-			  isLexCon, RdrName(..), Name{-instance NamedThing-} )
---import PprStyle		-- ToDo:rm
---import Outputable	-- ToDo:rm
-import PrelInfo		( builtinNameMaps, builtinKeysMap, builtinTcNamesMap, SYN_IE(BuiltinNames) )
+import FiniteMap	( FiniteMap, emptyFM, unitFM, lookupFM, addToFM, addListToFM, fmToList )
+import Name		( Name {-instance NamedThing-}, Provenance, OccName(..),
+			  modAndOcc, occNameString, moduleString, pprModule,
+			  NameSet(..), emptyNameSet, unionNameSets, nameSetToList,
+			  minusNameSet, mkNameSet,
+			  isWiredInName, maybeWiredInTyConName, maybeWiredInIdName
+			 )
+import Id		( GenId, Id(..), idType, dataConTyCon, isDataCon )
+import TyCon		( TyCon, tyConDataCons, isSynTyCon, getSynTyConDefn )
+import Type		( namesOfType )
+import TyVar		( GenTyVar )
+import SrcLoc		( mkIfaceSrcLoc )
+import PrelMods		( gHC__ )
+import Bag
+import Maybes		( MaybeErr(..), expectJust, maybeToBool )
+import ListSetOps	( unionLists )
 import Pretty
-import UniqFM		( emptyUFM )
-import UniqSupply	( splitUniqSupply )
-import Util		( sortLt, removeDups, cmpPString, startsWith,
-			  panic, pprPanic, assertPanic{-, pprTrace ToDo:rm-} )
-\end{code}
-
-\begin{code}
-type ModuleToIfaceContents = FiniteMap Module ParsedIface
-type ModuleToIfaceFilePath = FiniteMap Module FilePath
-
-#if __GLASGOW_HASKELL__ >= 200
-# define REAL_WORLD RealWorld
-#else
-# define REAL_WORLD _RealWorld
-#endif
-
-data IfaceCache
-  = IfaceCache
-	Module			 -- the name of the module being compiled
-	BuiltinNames		 -- so we can avoid going after things
-				 -- the compiler already knows about
-        (MutableVar REAL_WORLD
-	 (ModuleToIfaceContents, -- interfaces for individual interface files
-	  ModuleToIfaceContents, -- merged interfaces based on module name
-				 -- used for extracting info about original names
-	  ModuleToIfaceFilePath))
-
-initIfaceCache mod hi_files
-  = newVar (emptyFM,emptyFM,hi_files) ST_THEN \ iface_var ->
-    return (IfaceCache mod builtinNameMaps iface_var)
+import PprStyle		( PprStyle(..) )
+import Util		( pprPanic )
 \end{code}
 
-*********************************************************
-*							*
-\subsection{Reading interface files}
-*							*
-*********************************************************
-
-Return cached info about a Module's interface; otherwise,
-read the interface (using our @ModuleToIfaceFilePath@ map
-to decide where to look).
-
-Note: we have two notions of interface
- * the interface for a particular file name
- * the (combined) interface for a particular module name
 
-The idea is that two source files may declare a module
-with the same name with the declarations being merged.
-
-This allows us to have file PreludeList.hs producing
-PreludeList.hi but defining part of module Prelude.
-When PreludeList is imported its contents will be
-added to Prelude. In this way all the original names 
-for a particular module will be available the imported
-decls are renamed.
-
-ToDo: Check duplicate definitons are the same.
-ToDo: Check/Merge duplicate pragmas.
 
+%*********************************************************
+%*							*
+\subsection{Loading a new interface file}
+%*							*
+%*********************************************************
 
 \begin{code}
-cachedIface :: IfaceCache
-	    -> Bool		-- True  => want merged interface for original name
-				-- False => want file interface only
-	    -> FAST_STRING	-- item that prompted search (debugging only!)
-	    -> Module
-	    -> IO (MaybeErr ParsedIface Error)
-
-cachedIface (IfaceCache _ _ iface_var) want_orig_iface item modname
-  = readVar iface_var ST_THEN \ (iface_fm, orig_fm, file_fm) ->
-
-    case (lookupFM iface_fm modname) of
-      Just iface -> return (want_iface iface orig_fm)
-      Nothing    ->
-      	case (lookupFM file_fm modname) of
-	  Nothing   -> return (Failed (noIfaceErr modname))
-	  Just file ->
-	    readIface file modname item >>= \ read_iface ->
-	    case read_iface of
-	      Failed err      -> -- pprTrace "module-file map:\n" (ppAboves [ppCat [ppPStr m, ppStr f] | (m,f) <- fmToList file_fm]) $
-				 return (Failed err)
-	      Succeeded iface ->
-		let
-		    iface_fm' = addToFM iface_fm modname iface
-		    orig_fm'  = addToFM_C mergeIfaces orig_fm (iface_mod iface) iface
-		in
-		writeVar iface_var (iface_fm', orig_fm', file_fm) ST_THEN \ _ ->
-		return (want_iface iface orig_fm')
-  where
-    want_iface iface orig_fm 
-      | want_orig_iface
-      = case lookupFM orig_fm modname of
-	  Nothing         -> Failed (noOrigIfaceErr modname)
-          Just orig_iface -> Succeeded orig_iface
-      | otherwise
-      = Succeeded iface
-
-    iface_mod (ParsedIface mod _ _ _ _ _ _ _ _ _ _ _ _) = mod
-
-----------
-mergeIfaces (ParsedIface mod1 (_, files1) _ _ _ _ _ _ fixes1 tdefs1 vdefs1 idefs1 prags1)
-	    (ParsedIface mod2 (_, files2) _ _ _ _ _ _ fixes2 tdefs2 vdefs2 idefs2 prags2)
-  = --pprTrace "mergeIfaces:" (ppCat [ppStr "import", ppCat (map ppPStr (bagToList files2)),
-    --				    ppStr "merged with", ppPStr mod1]) $
-    ASSERT(mod1 == mod2)
-    ParsedIface mod1
-	(True, unionBags files2 files1)
-	(panic "mergeIface: module version numbers")
-	(panic "mergeIface: source version numbers")	-- Version numbers etc must be extracted from
-	(panic "mergeIface: usage version numbers")	-- the merged file interfaces named above
-	(panic "mergeIface: decl version numbers")
-	(panic "mergeIface: exports")
-	(panic "mergeIface: instance modules")
- 	(plusFM_C (dup_merge {-"fixity"      (ppr PprDebug . fixDeclName)-}) fixes1 fixes2)
-	(plusFM_C (dup_merge {-"tycon/class" (ppr PprDebug . idecl_nm)-})    tdefs1 tdefs2)
-	(plusFM_C (dup_merge {-"value"       (ppr PprDebug . idecl_nm)-})    vdefs1 vdefs2)
-	(unionBags idefs1 idefs2)
-	(plusFM_C (dup_merge {-"pragma"      ppStr-})			 prags1 prags2)
-  where
-    dup_merge {-str ppr_dup-} dup1 dup2
-      = --pprTrace "mergeIfaces:"
-	--   	 (ppCat [ppPStr mod1, ppPStr mod2, ppStr ": dup", ppStr str, ppStr "decl",
-	--		 ppr_dup dup1, ppr_dup dup2]) $
-        dup2
-
-    idecl_nm (TypeSig    n _ _)     = n
-    idecl_nm (NewTypeSig n _ _ _)   = n
-    idecl_nm (DataSig    n _ _ _ _) = n
-    idecl_nm (ClassSig   n _ _ _)   = n
-    idecl_nm (ValSig     n _ _)	    = n
-
-----------
-data CachingResult
-  = CachingFail	    Error	  -- tried to find a decl, something went wrong
-  | CachingHit	    RdrIfaceDecl  -- got it
-  | CachingAvoided  (Maybe (Either RnName RnName))
-				  -- didn't look in the interface
-				  -- file(s); Nothing => the thing
-				  -- *should* be in the source module;
-				  -- Just (Left ...) => builtin val name;
-				  -- Just (Right ..) => builtin tc name
-
-cachedDecl :: IfaceCache
-	   -> Bool	-- True <=> tycon or class name
-	   -> OrigName
-	   -> IO CachingResult
-
-cachedDecl iface_cache@(IfaceCache this_mod (b_val_names,b_tc_names) _)
-	   class_or_tycon name@(OrigName mod str)
-
-  = -- pprTrace "cachedDecl:" (ppr PprDebug name) $
-    if mod == this_mod then 	        -- some i/face has made a reference
-	return (CachingAvoided Nothing) -- to something from this module
-    else
+loadInterface :: Pretty -> Module -> RnMG Ifaces
+loadInterface doc_str load_mod 
+  = getIfacesRn 		`thenRn` \ ifaces ->
     let
-	b_env	    = if class_or_tycon then b_tc_names else b_val_names
+	Ifaces this_mod mod_vers_map export_env_map vers_map decls_map inst_map inst_mods = ifaces
     in
-    case (lookupFM b_env name) of
-      Just rn -> -- in builtins!
-	return (CachingAvoided (Just ((if class_or_tycon then Right else Left) rn)))
-
-      Nothing ->
-	cachedIface iface_cache True str mod >>= \ maybe_iface ->
-	case maybe_iface of
-	  Failed err -> --pprTrace "cachedDecl:fail:" (ppr PprDebug orig) $
-			return (CachingFail err)
-	  Succeeded (ParsedIface _ _ _ _ _ _ exps _ _ tdefs vdefs _ _) -> 
-	    case (lookupFM (if class_or_tycon then tdefs else vdefs) str) of
-	      Just decl -> return (CachingHit  decl)
-	      Nothing   -> return (CachingFail (noDeclInIfaceErr mod str))
-
-----------
-cachedDeclByType :: IfaceCache
-		 -> RnName{-NB: diff type than cachedDecl -}
-		 -> IO CachingResult
-
-cachedDeclByType iface_cache rn
-    -- the idea is: check that, e.g., if we're given an
-    -- RnClass, then we really get back a ClassDecl from
-    -- the cache (not an RnData, or something silly)
-  = cachedDecl iface_cache (isRnTyConOrClass rn) (origName "cachedDeclByType" rn)  >>= \ maybe_decl ->
+	-- CHECK WHETHER WE HAVE IT ALREADY
+    if maybeToBool (lookupFM export_env_map load_mod) 
+    then
+	returnRn ifaces		-- Already in the cache; don't re-read it
+    else
+
+	-- READ THE MODULE IN
+    findAndReadIface doc_str load_mod		`thenRn` \ read_result ->
+    case read_result of {
+	-- Check for not found
+	Nothing -> 	-- Not found, so add an empty export env to the Ifaces map
+			-- so that we don't look again
+		   let
+			new_export_env_map = addToFM export_env_map load_mod ([],[])
+			new_ifaces = Ifaces this_mod mod_vers_map 
+					    new_export_env_map 
+					    vers_map decls_map inst_map inst_mods
+		   in
+		   setIfacesRn new_ifaces		`thenRn_`
+		   failWithRn new_ifaces (noIfaceErr load_mod) ;
+
+	-- Found and parsed!
+	Just (ParsedIface _ mod_vers usages exports rd_inst_mods fixs decls insts) ->
+
+	-- LOAD IT INTO Ifaces
+    mapRn loadExport exports					`thenRn` \ avails ->
+    foldlRn (loadDecl load_mod) (decls_map,vers_map) decls	`thenRn` \ (new_decls_map, new_vers_map) ->
+    foldlRn (loadInstDecl load_mod) inst_map insts		`thenRn` \ new_insts_map ->
     let
-	return_maybe_decl = return maybe_decl
-	return_failed msg = return (CachingFail msg)
+	 export_env = (avails, fixs)
+
+			-- Exclude this module from the "special-inst" modules
+	 new_inst_mods = inst_mods `unionLists` (filter (/= this_mod) rd_inst_mods)
+
+	 new_ifaces = Ifaces this_mod
+			     (addToFM mod_vers_map load_mod mod_vers)
+			     (addToFM export_env_map load_mod export_env)
+			     new_vers_map
+			     new_decls_map
+			     new_insts_map
+			     new_inst_mods 
     in
-    case maybe_decl of
-      CachingAvoided _	  -> return_maybe_decl
-      CachingFail io_msg  -> return_failed (ifaceIoErr io_msg rn)
-      CachingHit  if_decl ->
-	case rn of
-	  WiredInId _       -> return_failed (ifaceLookupWiredErr "value" rn)
-	  WiredInTyCon _    -> return_failed (ifaceLookupWiredErr "type constructor" rn)
-	  RnUnbound _       -> panic "cachedDeclByType:" -- (ppr PprDebug rn)
-	  
-	  RnSyn _	    -> return_maybe_decl
-	  RnData _ _ _	    -> return_maybe_decl
-	  RnImplicitTyCon _ -> if is_tycon_decl if_decl
-			       then return_maybe_decl
-			       else return_failed (badIfaceLookupErr "type constructor" rn if_decl)
-	  
-	  RnClass _ _	    -> return_maybe_decl
-	  RnImplicitClass _ -> if is_class_decl if_decl
-			       then return_maybe_decl
-			       else return_failed (badIfaceLookupErr "class" rn if_decl)
-	  
-	  RnName _	    -> return_maybe_decl
-	  RnConstr _ _      -> return_maybe_decl
-	  RnField _ _ 	    -> return_maybe_decl
-	  RnClassOp _ _	    -> return_maybe_decl
-	  RnImplicit _	    -> if is_val_decl if_decl
-			       then return_maybe_decl
-			       else return_failed (badIfaceLookupErr "value" rn if_decl)
+    setIfacesRn new_ifaces		`thenRn_`
+    returnRn new_ifaces
+    }
+
+loadExport :: ExportItem -> RnMG AvailInfo
+loadExport (mod, occ, occs)
+  = new_name occ 		`thenRn` \ name ->
+    mapRn new_name occs 	`thenRn` \ names ->
+    returnRn (Avail name names)
+  where
+    new_name occ = newGlobalName mod occ
+
+loadVersion :: Module -> VersionMap -> (OccName,Version) -> RnMG VersionMap
+loadVersion mod vers_map (occ, version)
+  = newGlobalName mod occ 			`thenRn` \ name ->
+    returnRn (addToFM vers_map name version)
+
+
+loadDecl :: Module -> (DeclsMap, VersionMap)
+	 -> (Version, RdrNameHsDecl)
+	 -> RnMG (DeclsMap, VersionMap)
+loadDecl mod (decls_map, vers_map) (version, decl)
+  = getDeclBinders new_implicit_name decl	`thenRn` \ avail@(Avail name _) ->
+    returnRn (addListToFM decls_map
+			  [(name,(avail,decl)) | name <- availNames avail],
+	      addToFM vers_map name version
+    )
   where
-    is_tycon_decl (TypeSig _ _ _)	= True
-    is_tycon_decl (NewTypeSig _ _ _ _)	= True
-    is_tycon_decl (DataSig _ _ _ _ _)	= True
-    is_tycon_decl _			= False
-
-    is_class_decl (ClassSig _ _ _ _)	= True
-    is_class_decl _			= False
-
-    is_val_decl (ValSig _ _ _)		= True
-    is_val_decl (DataSig _ _ _ _ _)	= True	-- may be a constr or field
-    is_val_decl (NewTypeSig _ _ _ _)	= True  -- may be a constr
-    is_val_decl (ClassSig _ _ _ _)	= True	-- may be a method
-    is_val_decl _			= False
+    new_implicit_name rdr_name loc = newGlobalName mod (rdrNameOcc rdr_name)
+
+loadInstDecl :: Module -> Bag IfaceInst -> RdrNameInstDecl -> RnMG (Bag IfaceInst)
+loadInstDecl mod_name insts decl@(InstDecl inst_ty binds uprags dfun_name src_loc)
+  = initRnMS emptyRnEnv mod_name InterfaceMode $
+
+	-- Find out what type constructors and classes are mentioned in the
+	-- instance declaration.  We have to be a bit clever.
+	--
+	-- We want to rename the type so that we can find what
+	-- (free) type constructors are inside it.  But we must *not* thereby
+	-- put new occurrences into the global pool because otherwise we'll force
+	-- them all to be loaded.  We kill two birds with ones stone by renaming
+	-- with a fresh occurrence pool.
+    findOccurrencesRn (rnHsType inst_ty)	`thenRn` \ ty_names ->
+
+    returnRn ((ty_names, mod_name, decl) `consBag` insts)
 \end{code}
 
-\begin{code}
-readIface :: FilePath -> Module -> FAST_STRING -> IO (MaybeErr ParsedIface Error)
 
-readIface file modname item
-  = --hPutStr stderr ("  reading "++file++" ("++ _UNPK_ item ++")") >>
-    TRY_IO (readFile file)  >>= \ read_result ->
+%********************************************************
+%*							*
+\subsection{Loading usage information}
+%*							*
+%********************************************************
+
+\begin{code}
+checkUpToDate :: Module -> RnMG Bool		-- True <=> no need to recompile
+checkUpToDate mod_name
+  = findAndReadIface doc_str mod_name		`thenRn` \ read_result ->
     case read_result of
-      Left  err      -> return (Failed (cannaeReadErr file err))
-      Right contents -> --hPutStr stderr ".."   >>
-			let parsed = parseIface contents in
-			--hPutStr stderr "..\n" >>
-			return (
-			case parsed of
-			  Failed _    -> parsed
-			  Succeeded p -> Succeeded (init_merge modname p)
-			)
+	Nothing -> 	-- Old interface file not found, so we'd better bale out
+		    traceRn (ppSep [ppStr "Didnt find old iface", pprModule PprDebug mod_name])	`thenRn_`
+		    returnRn False
+
+	Just (ParsedIface _ _ usages _ _ _ _ _) 
+		-> 	-- Found it, so now check it
+		    checkModUsage usages
   where
-    init_merge this (ParsedIface mod _ v sv us vs exps insts fixes tdefs vdefs idefs prags)
-      =	ParsedIface mod (False, unitBag this) v sv us vs exps insts fixes tdefs vdefs idefs prags
-\end{code}
+	-- Only look in current directory, with suffix .hi
+    doc_str = ppSep [ppStr "Need usage info from", pprModule PprDebug mod_name]
 
 
-\begin{code}
-rnIfaces :: IfaceCache			-- iface cache (mutvar)
-	 -> [Module]			-- directly imported modules
-	 -> UniqSupply
-	 -> RnEnv			-- defined (in the source) name env
-	 -> RnEnv			-- mentioned (in the source) name env 
-	 -> RenamedHsModule		-- module to extend with iface decls
-	 -> [RnName]			-- imported names required (really the
-					-- same info as in mentioned name env)
-					-- Also, all the things we may look up
-					-- later by key (Unique).
-	 -> IO (RenamedHsModule,	-- extended module
-		RnEnv,			-- final env (for renaming derivings)
-		ImplicitEnv,		-- implicit names used (for usage info)
-		(UsagesMap,VersionsMap,[Module]),	-- usage info
-		(Bag Error, Bag Warning))
-
-rnIfaces iface_cache imp_mods us
-	 def_env@((dqual, dunqual, dtc_qual, dtc_unqual), dstack)
-	 occ_env@((qual, unqual, tc_qual, tc_unqual), stack)
-	 rn_module@(HsModule modname iface_version exports imports fixities
-		      typedecls typesigs classdecls instdecls instsigs
-		      defdecls binds sigs src_loc)
-	 todo
-  = {-
-    pprTrace "rnIfaces:going after:" (ppCat (map (ppr PprDebug) todo)) $
-    pprTrace "rnIfaces:qual:"      (ppCat [ppBesides[ppPStr m,ppChar '.',ppPStr n] | (n,m) <- keysFM qual]) $
-    pprTrace "rnIfaces:unqual:"    (ppCat (map ppPStr (keysFM unqual))) $
-    pprTrace "rnIfaces:tc_qual:"   (ppCat [ppBesides[ppPStr m,ppChar '.',ppPStr n] | (n,m) <- keysFM tc_qual]) $
-    pprTrace "rnIfaces:tc_unqual:" (ppCat (map ppPStr (keysFM tc_unqual))) $
-
-    pprTrace "rnIfaces:dqual:"     (ppCat [ppBesides[ppPStr m,ppChar '.',ppPStr n] | (n,m) <- keysFM dqual]) $
-    pprTrace "rnIfaces:dunqual:"   (ppCat (map ppPStr (keysFM dunqual))) $
-    pprTrace "rnIfaces:dtc_qual:"  (ppCat [ppBesides[ppPStr m,ppChar '.',ppPStr n] | (n,m) <- keysFM dtc_qual]) $
-    pprTrace "rnIfaces:dtc_unqual:"(ppCat (map ppPStr (keysFM dtc_unqual))) $
-    -}
-
-    -- do transitive closure to bring in all needed names/defns and insts:
-
-    decls_and_insts todo def_env occ_env empty_return us 
-	>>= \ (((if_typedecls, if_classdecls, if_instdecls, if_sigs),
-	        if_implicits,
-	        if_errs_warns),
-	       if_final_env) ->
-
-    -- finalize what we want to say we learned about the
-    -- things we used
-    finalIfaceInfo iface_cache modname if_final_env if_instdecls {-all_imports_used imp_mods-} >>=
-	\ usage_stuff@(usage_info, version_info, instance_mods) ->
-
-    return (HsModule modname iface_version exports imports fixities
-		 (typedecls ++ if_typedecls)
-		 typesigs
-		 (classdecls ++ if_classdecls)
-		 (instdecls  ++ if_instdecls)
-		 instsigs defdecls binds
-		 (sigs ++ if_sigs)
-		 src_loc,
-	    if_final_env,
-	    if_implicits,
-	    usage_stuff,
-	    if_errs_warns)
-  where
-    decls_and_insts todo def_env occ_env to_return us
-      =	let
-	    (us1,us2) = splitUniqSupply us
-	in
-	do_decls todo	     		 -- initial batch of names to process
-	 	 (def_env, occ_env, us1) -- init stuff down
-	 	 to_return		 -- acc results
-	   >>= \ (decls_return,
-		  decls_def_env,
-		  decls_occ_env) ->
-
-	cacheInstModules iface_cache imp_mods >>= \ errs ->
-
-	do_insts decls_def_env decls_occ_env emptyRnEnv emptyFM
-		 (add_errs errs decls_return) us2
-
-    --------
-    do_insts def_env occ_env prev_env done_insts to_return us
-      | size_tc_env occ_env == size_tc_env prev_env
-      = return (to_return, occ_env)
-
-      | otherwise
-      = rnIfaceInstStuff iface_cache modname us1 occ_env done_insts to_return
-	   >>= \ (insts_return,
-		  new_insts,
-		  insts_occ_env,
-		  new_unknowns) ->
-
-	do_decls new_unknowns	  		-- new batch of names to process
-	 	 (def_env, insts_occ_env, us2) 	-- init stuff down
-	 	 insts_return		 	-- acc results
-	   >>= \ (decls_return,
-		  decls_def_env,
-		  decls_occ_env) ->
-
-	do_insts decls_def_env decls_occ_env occ_env new_insts decls_return us3
-      where
-	(us1,us') = splitUniqSupply us
-	(us2,us3) = splitUniqSupply us'
-
-	size_tc_env ((_, _, qual, unqual), _)
-	  = sizeFM qual + sizeFM unqual
-
-
-    do_decls :: [RnName]	-- Names we're looking for; we keep adding/deleting
-			  	-- from this list; we're done when empty (nothing
-			  	-- more needs to be looked for)
-	     -> Go_Down	 	-- see defn below
-	     -> To_Return	-- accumulated result
-	     -> IO (To_Return,
-		    RnEnv,	-- extended decl env
-		    RnEnv)	-- extended occ env
-
-    do_decls to_find@[] down to_return
-      = return (to_return, defenv down, occenv down)
-
-    do_decls to_find@(n:ns) down to_return 
-      = case (lookup_defd down n) of
-	  Just  _ -> -- previous processing must've found the stuff for this name;
-		     -- continue with the rest:
-		     -- pprTrace "do_decls:done:" (ppr PprDebug n) $
-		     do_decls ns down to_return
-
-	  Nothing
-	   | moduleOf (origName "do_decls" n) == modname ->
-		     -- avoid looking in interface for the module being compiled
-		     --pprTrace "do_decls:this module error:" (ppr PprDebug n) $
-		     do_decls ns down (add_warn (thisModImplicitWarn modname n) to_return)
-
-	   | otherwise ->
-		     -- OK, see what the cache has for us...
-
-	     cachedDeclByType iface_cache n >>= \ maybe_ans ->
-	     case maybe_ans of
-	       CachingAvoided _ ->
-		 --pprTrace "do_decls:caching avoided:" (ppr PprDebug n) $
-		 do_decls ns down to_return
-
-	       CachingFail err -> -- add the error, but keep going:
-		 --pprTrace "do_decls:cache error:" (ppr PprDebug n) $
-		 do_decls ns down (add_err err to_return)
-
-	       CachingHit iface_decl -> -- something needing renaming!
-		 let
-		    (us1, us2) = splitUniqSupply (uniqsupply down)
-		 in
-		 case (initRn False{-iface-} modname (occenv down) us1 (
-			setExtraRn emptyUFM{-no fixities-} $
-			rnIfaceDecl iface_decl)) of {
-		  ((if_decl, if_defd, if_implicits), if_errs, if_warns) ->
-		    let
-			new_unknowns = eltsFM (fst if_implicits) ++ eltsFM (snd if_implicits)
-		    in
-		    {-
-		    pprTrace "do_decls:renamed:" (ppAboves [ppr PprDebug n
-			, ppCat [ppStr "new unknowns:", interpp'SP PprDebug new_unknowns]
-			, ppCat [ppStr "defd vals:", interpp'SP PprDebug [n | (_,n) <- fst if_defd] ]
-			, ppCat [ppStr "defd  tcs:", interpp'SP PprDebug [n | (_,n) <- snd if_defd] ]
-			]) $
-		    -}
-		    do_decls (new_unknowns ++ ns)
-			     (add_occs       if_defd if_implicits $
-			       new_uniqsupply us2 down)
-			     (add_decl	     if_decl		$
-			       add_implicits if_implicits	$
-			        add_errs     if_errs		$
-			         add_warns   if_warns to_return)
-	         }
-
------------
-type Go_Down   = (RnEnv,	-- stuff we already have defns for;
-				-- to check quickly if we've already
-				-- found something for the name under consideration,
-			  	-- due to previous processing.
-				-- It starts off just w/ the defns for
-				-- the things in this module.
-		  RnEnv,	-- occurrence env; this gets added to as
-				-- we process new iface decls.  It includes
-				-- entries for *all* occurrences, including those
-				-- for which we have definitions.
-		  UniqSupply	-- the obvious
-		 )
-
-lookup_defd (def_env, _, _) n
-  = (if isRnTyConOrClass n then lookupTcRnEnv else lookupRnEnv) def_env
-	(case (origName "lookup_defd" n) of { OrigName m s -> Qual m s })
-	-- this is hack because we are reusing the RnEnv technology
-
-defenv	   (def_env, _, _) = def_env
-occenv	   (_, occ_env, _) = occ_env
-uniqsupply (_, _,      us) = us
-
-new_uniqsupply us (def_env, occ_env, _) = (def_env, occ_env, us)
-
-add_occs (val_defds, tc_defds) (val_imps, tc_imps) (def_env, occ_env, us)
-  = case (extendGlobalRnEnv def_env val_defds tc_defds) of { (new_def_env, def_dups) ->
-    --(if isEmptyBag def_dups then \x->x else pprTrace "add_occs:" (ppCat [ppr PprDebug n | (n,_,_) <- bagToList def_dups])) $
---  ASSERT(isEmptyBag def_dups)
-    let
-	de_orig imps = [ (Qual m n, v) | (OrigName m n, v) <- fmToList imps ]
-	-- again, this hackery because we are reusing the RnEnv technology
+checkModUsage [] = returnRn True		-- Yes!  Everything is up to date!
 
-	val_occs = val_defds ++ de_orig val_imps
-	tc_occs  = tc_defds  ++ de_orig tc_imps
+checkModUsage ((mod, old_mod_vers, old_local_vers) : rest)
+  = loadInterface doc_str mod		`thenRn` \ ifaces ->
+    let
+	Ifaces _ mod_vers_map _ new_vers_map _ _ _ = ifaces
+	maybe_new_mod_vers = lookupFM mod_vers_map mod
+	Just new_mod_vers  = maybe_new_mod_vers
     in
-    case (extendGlobalRnEnv occ_env val_occs tc_occs)   of { (new_occ_env, occ_dups) ->
+	-- If we can't find a version number for the old module then
+	-- bale out saying things aren't up to date
+    if not (maybeToBool maybe_new_mod_vers) then
+	returnRn False
+    else
+
+	-- If the module version hasn't changed, just move on
+    if new_mod_vers == old_mod_vers then
+	traceRn (ppSep [ppStr "Module version unchanged:", pprModule PprDebug mod])	`thenRn_`
+	checkModUsage rest
+    else
+    traceRn (ppSep [ppStr "Module version has changed:", pprModule PprDebug mod])	`thenRn_`
 
---  ASSERT(isEmptyBag occ_dups)
---  False because we may get a dup on the name we just shoved in
+	-- New module version, so check entities inside
+    checkEntityUsage mod new_vers_map old_local_vers	`thenRn` \ up_to_date ->
+    if up_to_date then
+	traceRn (ppStr "...but the bits I use havn't.")	`thenRn_`
+	checkModUsage rest	-- This one's ok, so check the rest
+    else
+	returnRn False		-- This one failed, so just bail out now
+  where
+    doc_str = ppSep [ppStr "need version info for", pprModule PprDebug mod]
 
-    (new_def_env, new_occ_env, us) }}
 
-----------------
-type To_Return = (([RenamedTyDecl], [RenamedClassDecl], [RenamedInstDecl], [RenamedSig]),
-		  ImplicitEnv,	-- new names used implicitly
-		  (Bag Error, Bag Warning)
-		 )
-
-empty_return :: To_Return
-empty_return = (([],[],[],[]), emptyImplicitEnv, (emptyBag,emptyBag))
-
-add_decl decl ((tydecls, classdecls, instdecls, sigs), implicit, msgs)
-  = case decl of
-      AddedTy	 t -> ((t:tydecls, classdecls, instdecls, sigs), implicit, msgs)
-      AddedClass c -> ((tydecls, c:classdecls, instdecls, sigs), implicit, msgs)
-      AddedSig	 s -> ((tydecls, classdecls, instdecls, s:sigs), implicit, msgs)
-
-add_insts is ((tydecls, classdecls, instdecls, sigs), implicit, msgs)
-  = ((tydecls, classdecls, is ++ instdecls, sigs), implicit, msgs)
-
-add_implicits (val_imps, tc_imps) (decls, (val_fm, tc_fm), msgs)
-  = (decls, (val_fm `plusFM` val_imps, tc_fm `plusFM` tc_imps), msgs)
-
-add_err  err (decls,implicit,(errs,warns)) = (decls,implicit,(errs `snocBag`   err,warns))
-add_errs ers (decls,implicit,(errs,warns)) = (decls,implicit,(errs `unionBags` ers,warns))
-add_warn wrn (decls,implicit,(errs,warns)) = (decls,implicit,(errs, warns `snocBag` wrn))
-add_warns ws (decls,implicit,(errs,warns)) = (decls,implicit,(errs, warns `unionBags` ws))
+checkEntityUsage mod new_vers_map [] 
+  = returnRn True	-- Yes!  All up to date!
+
+checkEntityUsage mod new_vers_map ((occ_name,old_vers) : rest)
+  = newGlobalName mod occ_name		`thenRn` \ name ->
+    case lookupFM new_vers_map name of
+
+	Nothing       -> 	-- We used it before, but it ain't there now
+			  traceRn (ppSep [ppStr "...and this no longer exported:", ppr PprDebug name])	`thenRn_`
+			  returnRn False
+
+	Just new_vers -> 	-- It's there, but is it up to date?
+			  if new_vers == old_vers then
+				-- Up to date, so check the rest
+				checkEntityUsage mod new_vers_map rest
+			  else
+				traceRn (ppSep [ppStr "...and this is out of date:", ppr PprDebug name])  `thenRn_`
+			        returnRn False	-- Out of date, so bale out
 \end{code}
 
-\begin{code}
-data AddedDecl -- purely local
-  = AddedTy	RenamedTyDecl
-  | AddedClass	RenamedClassDecl
-  | AddedSig	RenamedSig
-
-rnIfaceDecl :: RdrIfaceDecl
-	    -> RnM_Fixes REAL_WORLD
-		   (AddedDecl,	-- the resulting decl to add to the pot
-		    ([(RdrName,RnName)], [(RdrName,RnName)]),
-				-- new val/tycon-class names that have
-				-- *been defined* while processing this decl
-		    ImplicitEnv -- new implicit val/tycon-class names that we
-				-- stumbled into
-		   )
-
-rnIfaceDecl (TypeSig tc _ decl)
-  = rnTyDecl    decl	`thenRn` \ rn_decl   ->
-    lookupTyCon tc	`thenRn` \ rn_tc     ->
-    getImplicitUpRn	`thenRn` \ mentioned ->
-    let
-	defds = ([], [(tc, rn_tc)])
-	implicits = mentioned `sub` defds
-    in
-    returnRn (AddedTy rn_decl, defds, implicits)
 
-rnIfaceDecl (NewTypeSig tc dc _ decl)
-  = rnTyDecl    decl	`thenRn` \ rn_decl   ->
-    lookupTyCon tc	`thenRn` \ rn_tc     ->
-    lookupValue dc	`thenRn` \ rn_dc     ->
-    getImplicitUpRn	`thenRn` \ mentioned ->
-    let
-	defds = ([(dc, rn_dc)], [(tc, rn_tc)])
-	implicits = mentioned `sub` defds
-    in
-    returnRn (AddedTy rn_decl, defds, implicits)
-
-rnIfaceDecl (DataSig tc dcs fcs _ decl)
-  = rnTyDecl    decl		`thenRn` \ rn_decl   ->
-    lookupTyCon tc		`thenRn` \ rn_tc     ->
-    mapRn lookupValue dcs	`thenRn` \ rn_dcs    ->
-    mapRn lookupValue fcs	`thenRn` \ rn_fcs    ->
-    getImplicitUpRn		`thenRn` \ mentioned ->
-    let
-	defds = (zip dcs rn_dcs ++ zip fcs rn_fcs , [(tc, rn_tc)])
-	implicits = mentioned `sub` defds
-    in
-    returnRn (AddedTy rn_decl, defds, implicits)
+%*********************************************************
+%*							*
+\subsection{Getting in a declaration}
+%*							*
+%*********************************************************
 
-rnIfaceDecl (ClassSig clas ops _ decl)
-  = rnClassDecl decl			`thenRn` \ rn_decl   ->
-    lookupClass clas			`thenRn` \ rn_clas   ->
-    mapRn (lookupClassOp rn_clas) ops	`thenRn` \ rn_ops    ->
-    getImplicitUpRn			`thenRn` \ mentioned ->
-    let
-	defds = (ops `zip` rn_ops, [(clas, rn_clas)])
-	implicits = mentioned `sub` defds
-    in
-    returnRn (AddedClass rn_decl, defds, implicits)
-
-rnIfaceDecl (ValSig f src_loc ty)
-    -- should rename_sig in RnBinds be used here? ToDo
-  = lookupValue f			`thenRn` \ rn_f  ->
-    -- pprTrace "rnIfaceDecl:ValSig:" (ppr PprDebug ty) $
-    rnPolyType nullTyVarNamesEnv ty	`thenRn` \ rn_ty ->
-    getImplicitUpRn			`thenRn` \ mentioned ->
-    let
-	defds = ([(f, rn_f)], [])
-	implicits = mentioned `sub` defds
-    in
-    returnRn (AddedSig (Sig rn_f rn_ty noGenPragmas src_loc), defds, implicits)
+\begin{code}
+getDecl :: Name -> RnMG (AvailInfo, RdrNameHsDecl)
+getDecl name
+  = traceRn doc_str 			`thenRn_`
+    loadInterface doc_str mod		`thenRn` \ (Ifaces _ _ _ _ decls_map _ _) ->
+    case lookupFM decls_map name of
 
-----
-sub :: ImplicitEnv -> ([(RdrName,RnName)], [(RdrName,RnName)]) -> ImplicitEnv
+      Just avail_w_decl -> returnRn avail_w_decl
 
-sub (val_ment, tc_ment) (val_defds, tc_defds)
-  = (delListFromFM val_ment (map (qualToOrigName . fst) val_defds),
-     delListFromFM tc_ment  (map (qualToOrigName . fst) tc_defds))
+      Nothing   	-> 	-- Can happen legitimately for "Optional" occurrences
+			   returnRn (NotAvailable, ValD EmptyBinds)
+  where
+     (mod,_) = modAndOcc name
+     doc_str = ppSep [ppStr "Need decl for", ppr PprDebug name]
 \end{code}
 
-% ------------------------------
+@getWiredInDecl@ maps a wired-in @Name@ to what it makes available.
+It behaves exactly as if the wired in decl were actually in an interface file.
+Specifically,
+  *	if the wired-in name is a data type constructor or a data constructor, 
+	it brings in the type constructor and all the data constructors; and
+	marks as "occurrences" any free vars of the data con.
 
-@cacheInstModules@: cache instance modules specified in imports
+  * 	similarly for synonum type constructor
 
-\begin{code}
-cacheInstModules :: IfaceCache -> [Module] -> IO (Bag Error)
+  * 	if the wired-in name is another wired-in Id, it marks as "occurrences"
+	the free vars of the Id's type.
 
-cacheInstModules iface_cache@(IfaceCache _ _ iface_var) imp_mods
-  = readVar iface_var		ST_THEN \ (iface_fm, _, _) ->
-    let
-	imp_ifaces      = [ iface | Just iface <- map (lookupFM iface_fm) imp_mods ]
-	(imp_imods, _)  = removeDups cmpPString (bagToList (unionManyBags (map get_ims imp_ifaces)))
-        get_ims (ParsedIface _ _ _ _ _ _ _ ims _ _ _ _ _) = ims
-    in
-    --pprTrace "cacheInstModules:" (ppCat (map ppPStr imp_imods)) $
-    accumulate (map (cachedIface iface_cache False SLIT("instance_modules")) imp_imods) >>= \ err_or_ifaces ->
+  *	it loads the interface file for the wired-in thing for the
+	sole purpose of making sure that its instance declarations are available
 
-    -- Sanity Check:
-    -- Assert that instance modules given by direct imports contains
-    -- instance modules extracted from all visited modules
+All this is necessary so that we know all types that are "in play", so
+that we know just what instances to bring into scope.
+	
+\begin{code}
+getWiredInDecl :: Name -> RnMG AvailInfo
+getWiredInDecl name
+  = 	-- Force in the home module in case it has instance decls for
+	-- the thing we are interested in
+    (if mod == gHC__ then
+	returnRn ()			-- Mini hack; GHC is guaranteed not to have
+					-- instance decls, so it's a waste of time
+					-- to read it
+    else
+	loadInterface doc_str mod	`thenRn_`
+	returnRn ()
+    )					 	`thenRn_`
+
+    if (maybeToBool maybe_wired_in_tycon) then
+	get_wired_tycon the_tycon
+    else				-- Must be a wired-in-Id
+    if (isDataCon the_id) then		-- ... a wired-in data constructor
+	get_wired_tycon (dataConTyCon the_id)
+    else				-- ... a wired-in non data-constructor
+   	get_wired_id the_id
+  where
+    doc_str = ppSep [ppStr "Need home module for wired in thing", ppr PprDebug name]
+    (mod,_) = modAndOcc name
+    maybe_wired_in_tycon = maybeWiredInTyConName name
+    maybe_wired_in_id    = maybeWiredInIdName    name
+    Just the_tycon	 = maybe_wired_in_tycon
+    Just the_id 	 = maybe_wired_in_id
+
+get_wired_id id
+  = addImplicitOccsRn (nameSetToList id_mentioned)	`thenRn_`
+    returnRn (Avail (getName id) [])
+  where
+    id_mentioned	 = namesOfType (idType id)
 
-    readVar iface_var		ST_THEN \ (all_iface_fm, _, _) ->
-    let
-	all_ifaces     = eltsFM all_iface_fm
-	(all_imods, _) = removeDups cmpPString (bagToList (unionManyBags (map get_ims (all_ifaces))))
-    in
-    ASSERT(sortLt (<) imp_imods == sortLt (<) all_imods)
+get_wired_tycon tycon 
+  | isSynTyCon tycon
+  = addImplicitOccsRn (nameSetToList mentioned)		`thenRn_`
+    returnRn (Avail (getName tycon) [])
+  where
+    (tyvars,ty) = getSynTyConDefn tycon
+    mentioned = namesOfType ty `minusNameSet` mkNameSet (map getName tyvars)
 
-    return (bag_errs err_or_ifaces)
+get_wired_tycon tycon 
+  | otherwise		-- data or newtype
+  = addImplicitOccsRn (nameSetToList mentioned)		`thenRn_`
+    returnRn (Avail (getName tycon) (map getName data_cons))
   where
-    bag_errs [] = emptyBag
-    bag_errs (Failed err :rest) = err `consBag` bag_errs rest
-    bag_errs (Succeeded _:rest) = bag_errs rest
+    data_cons = tyConDataCons tycon
+    mentioned = foldr (unionNameSets . namesOfType . idType) emptyNameSet data_cons
 \end{code}
 
 
-@rnIfaceInstStuff@: Deal with instance declarations from interface files.
+%*********************************************************
+%*							*
+\subsection{Getting other stuff}
+%*							*
+%*********************************************************
 
 \begin{code}
-type InstanceEnv = FiniteMap (OrigName, OrigName) Int
-
-rnIfaceInstStuff
-	:: IfaceCache		-- all about ifaces we've read
-	-> Module
-	-> UniqSupply
-	-> RnEnv		-- current occ env
-	-> InstanceEnv  	-- instances for these tycon/class pairs done
-	-> To_Return
-	-> IO (To_Return,
-	       InstanceEnv,	-- extended instance env
-	       RnEnv,		-- final occ env
-	       [RnName])	-- new unknown names
-
-rnIfaceInstStuff iface_cache@(IfaceCache _ _ iface_var) modname us occ_env done_inst_env to_return
-  = -- all the instance decls we might even want to consider
-    -- are in the ParsedIfaces that are in our cache
-
-    readVar iface_var	ST_THEN \ (_, orig_iface_fm, _) ->
-    let
-	all_ifaces	  = eltsFM orig_iface_fm
-	all_insts	  = concat (map get_insts all_ifaces)
-	interesting_insts = filter want_inst all_insts
+getInterfaceExports :: Module -> RnMG (Avails, [(OccName,Fixity)])
+getInterfaceExports mod
+  = loadInterface doc_str mod		`thenRn` \ (Ifaces _ _ export_envs _ _ _ _) ->
+    case lookupFM export_envs mod of
+	Nothing ->	-- Not there; it must be that the interface file wasn't found;
+			-- the error will have been reported already.
+			-- (Actually loadInterface should put the empty export env in there
+			--  anyway, but this does no harm.)
+		      returnRn ([],[])
+
+	Just stuff -> returnRn stuff
+  where
+    doc_str = ppSep [pprModule PprDebug mod, ppStr "is directly imported"]
 
-	-- Sanity Check:
-	-- Assert that there are no more instances for the done instances
 
-	claim_done       = filter is_done_inst all_insts
-	claim_done_env   = foldr add_done_inst emptyFM claim_done
+getImportedInstDecls :: RnMG [IfaceInst]
+getImportedInstDecls
+  = 	-- First load any special-instance modules that aren't aready loaded
+    getSpecialInstModules 			`thenRn` \ inst_mods ->
+    mapRn load_it inst_mods			`thenRn_`
 
-	has_val fm (k,i) = case lookupFM fm k of { Nothing -> False; Just v -> i == v }
+	-- Now we're ready to grab the instance declarations
+    getIfacesRn						`thenRn` \ ifaces ->
+    let
+	 Ifaces _ _ _ _ _ insts _ = ifaces
     in
-    {-
-      pprTrace "all_insts:\n"         (ppr_insts (bagToList all_insts)) $
-      pprTrace "interesting_insts:\n" (ppr_insts interesting_insts) $
-    -}
-    ASSERT(sizeFM done_inst_env == sizeFM claim_done_env)
-    ASSERT(all (has_val claim_done_env) (fmToList done_inst_env))
-
-    case (initRn False{-iface-} modname occ_env us (
-	    setExtraRn emptyUFM{-no fixities-}	$
-	    mapRn rnIfaceInst interesting_insts `thenRn` \ insts ->
-	    getImplicitUpRn			`thenRn` \ implicits ->
-	    returnRn (insts, implicits))) of {
-      ((if_insts, if_implicits), if_errs, if_warns) ->
-
-	return (add_insts      if_insts		$
-		 add_implicits if_implicits	$
-		  add_errs     if_errs		$
-		   add_warns   if_warns to_return,
-		foldr add_done_inst done_inst_env interesting_insts,
-		add_imp_occs if_implicits occ_env,
-		eltsFM (fst if_implicits) ++ eltsFM (snd if_implicits))
-    }
+    returnRn (bagToList insts) 
   where
-    get_insts (ParsedIface imod _ _ _ _ _ _ _ _ _ _ insts _) = [(imod, inst) | inst <- bagToList insts]
-
-    tycon_class clas tycon = (qualToOrigName clas, qualToOrigName tycon)
-
-    add_done_inst (_, InstSig clas tycon _ _) inst_env
-      = addToFM_C (+) inst_env (tycon_class clas tycon) 1
-
-    is_done_inst (_, InstSig clas tycon _ _)
-      = maybeToBool (lookupFM done_inst_env (tycon_class clas tycon))
-
-    add_imp_occs (val_imps, tc_imps) occ_env
-      = case (extendGlobalRnEnv occ_env (de_orig val_imps) (de_orig tc_imps)) of
-     	  (ext_occ_env, occ_dups) -> ASSERT(isEmptyBag occ_dups)
-				     ext_occ_env
-      where
-	de_orig imps = [ (Qual m n, v) | (OrigName m n, v) <- fmToList imps ]
-	-- again, this hackery because we are reusing the RnEnv technology
-
-    want_inst i@(imod, InstSig clas tycon _ _)
-      = -- it's a "good instance" (one to hang onto) if we have a
-	-- chance of referring to *both* the class and tycon later on ...
-	--pprTrace "want_inst:" (ppCat [ppr PprDebug clas, ppr PprDebug tycon, ppr PprDebug (mentionable tycon), ppr PprDebug (mentionable clas), ppr PprDebug(is_done_inst i)]) $
-	mentionable tycon && mentionable clas && not (is_done_inst i)
-      where
-	mentionable nm
-	  = case lookupTcRnEnv occ_env nm of
-	      Just  _ -> True
-	      Nothing -> -- maybe it's builtin
-		let orig = qualToOrigName nm in
-		case (lookupFM builtinTcNamesMap orig) of
-		  Just  _ -> True
-		  Nothing -> maybeToBool (lookupFM builtinKeysMap orig)
+    load_it mod = loadInterface (doc_str mod) mod
+    doc_str mod = ppSep [pprModule PprDebug mod, ppStr "is a special-instance module"]
+
+getSpecialInstModules :: RnMG [Module]
+getSpecialInstModules 
+  = getIfacesRn						`thenRn` \ ifaces ->
+    let
+	 Ifaces _ _ _ _ _ _ inst_mods = ifaces
+    in
+    returnRn inst_mods
 \end{code}
 
 \begin{code}
-rnIfaceInst :: (Module, RdrIfaceInst) -> RnM_Fixes REAL_WORLD RenamedInstDecl
+getImportVersions :: [AvailInfo]			-- Imported avails
+		  -> RnMG (VersionInfo Name)	-- Version info for these names
 
-rnIfaceInst (imod, InstSig _ _ _ inst_decl) = rnInstDecl (inst_decl imod)
+getImportVersions imported_avails	
+  = getIfacesRn					`thenRn` \ ifaces ->
+    let
+	 Ifaces _ mod_versions_map _ version_map _ _ _ = ifaces
+
+	 -- import_versions is harder: we have to group together all the things imported
+	 -- from a particular module.  We do this with yet another finite map
+
+	 mv_map :: FiniteMap Module [LocalVersion Name]
+	 mv_map		   = foldl add_mv emptyFM imported_avails
+	 add_mv mv_map (Avail name _) 
+	    | isWiredInName name = mv_map	-- Don't record versions for wired-in names
+	    | otherwise = case lookupFM mv_map mod of
+				Just versions -> addToFM mv_map mod ((name,version):versions)
+				Nothing       -> addToFM mv_map mod [(name,version)]
+	    where
+	     (mod,_) = modAndOcc name
+	     version = case lookupFM version_map name of
+			 Just v  -> v
+			 Nothing -> pprPanic "getVersionInfo:" (ppr PprDebug name)
+
+	 import_versions = [ (mod, expectJust "import_versions" (lookupFM mod_versions_map mod), local_versions)
+			   | (mod, local_versions) <- fmToList mv_map
+			   ]
+
+	 -- Question: should we filter the builtins out of import_versions?
+    in
+    returnRn import_versions
 \end{code}
 
+%*********************************************************
+%*							*
+\subsection{Getting binders out of a declaration}
+%*							*
+%*********************************************************
+
+@getDeclBinders@ returns the names for a @RdrNameHsDecl@.
+It's used for both source code (from @availsFromDecl@) and interface files
+(from @loadDecl@).
+
+It doesn't deal with source-code specific things: ValD, DefD.  They
+are handled by the sourc-code specific stuff in RnNames.
+
 \begin{code}
-type BigMaps = (FiniteMap Module Version, -- module-version map
-		FiniteMap (FAST_STRING,Module) Version) -- ordinary version map
-
-finalIfaceInfo ::
-	   IfaceCache			-- iface cache
-	-> Module			-- this module's name
-	-> RnEnv
-	-> [RenamedInstDecl]
---	-> [RnName]			-- all imported names required
---	-> [Module]			-- directly imported modules
-	-> IO (UsagesMap,
-	       VersionsMap,		-- info about version numbers
-	       [Module])		-- special instance modules
-
-finalIfaceInfo iface_cache@(IfaceCache _ _ iface_var) 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: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_unqual:" (ppCat (map ppPStr (keysFM tc_unqual))) $
-    readVar iface_var	ST_THEN \ (_, orig_iface_fm, _) ->
-    let
-	all_ifaces = eltsFM orig_iface_fm
-	-- all the interfaces we have looked at
+getDeclBinders :: (RdrName -> SrcLoc -> RnMG Name)		-- New-name function
+		-> RdrNameHsDecl
+		-> RnMG AvailInfo
 
-	big_maps
-	  -- combine all the version maps we have seen into maps to
-	  -- (a) lookup a module-version number, lookup an entity's
-	  -- individual version number
-	  = foldr mk_map (emptyFM,emptyFM) all_ifaces
+getDeclBinders new_name (TyD (TyData _ tycon _ condecls _ _ src_loc))
+  = new_name tycon src_loc			`thenRn` \ tycon_name ->
+    getConFieldNames new_name condecls		`thenRn` \ sub_names ->
+    returnRn (Avail tycon_name sub_names)
 
-	val_stuff@(val_usages, val_versions)
-	  = foldFM (process_item big_maps) (emptyFM, emptyFM){-init-} qual
+getDeclBinders new_name (TyD (TyNew _ tycon _ (NewConDecl con _ con_loc) _ _ src_loc))
+  = new_name tycon src_loc		`thenRn` \ tycon_name ->
+    new_name con src_loc		`thenRn` \ con_name ->
+    returnRn (Avail tycon_name [con_name])
 
-	(all_usages, all_versions)
-	  = foldFM (process_item big_maps) val_stuff{-keep going-} tc_qual
-    in
-    return (all_usages, all_versions, [])
+getDeclBinders new_name (TyD (TySynonym tycon _ _ src_loc))
+  = new_name tycon src_loc		`thenRn` \ tycon_name ->
+    returnRn (Avail tycon_name [])
+
+getDeclBinders new_name (ClD (ClassDecl _ cname _ sigs _ _ src_loc))
+  = new_name cname src_loc			`thenRn` \ class_name ->
+    mapRn (getClassOpNames new_name) sigs	`thenRn` \ sub_names ->
+    returnRn (Avail class_name sub_names)
+
+getDeclBinders new_name (SigD (IfaceSig var ty prags src_loc))
+  = new_name var src_loc			`thenRn` \ var_name ->
+    returnRn (Avail var_name [])
+
+getDeclBinders new_name (DefD _)  = returnRn NotAvailable
+getDeclBinders new_name (InstD _) = returnRn NotAvailable
+
+----------------
+getConFieldNames new_name (ConDecl con _ src_loc : rest)
+  = new_name con src_loc		`thenRn` \ n ->
+    getConFieldNames new_name rest	`thenRn` \ ns -> 
+    returnRn (n:ns)
+
+getConFieldNames new_name (NewConDecl con _ src_loc : rest)
+  = new_name con src_loc		`thenRn` \ n ->
+    getConFieldNames new_name rest	`thenRn` \ ns -> 
+    returnRn (n:ns)
+
+getConFieldNames new_name (ConOpDecl _ con _ src_loc : rest)
+  = new_name con src_loc		`thenRn` \ n ->
+    getConFieldNames new_name rest	`thenRn` \ ns -> 
+    returnRn (n:ns)
+
+getConFieldNames new_name (RecConDecl con fielddecls src_loc : rest)
+  = mapRn (\n -> new_name n src_loc) (con:fields)	`thenRn` \ cfs ->
+    getConFieldNames new_name rest			`thenRn` \ ns  -> 
+    returnRn (cfs ++ ns)
   where
-    mk_map (ParsedIface m _ mv _ _ vers _ _ _ _ _ _ _) (mv_map, ver_map)
-      = (addToFM     mv_map  m mv, -- add this module
-	 addListToFM ver_map [ ((n,m), v) | (n,v) <- fmToList vers ])
-
-    -----------------------
-    process_item :: BigMaps
-		 -> (FAST_STRING,Module) -> RnName -- RnEnv (QualNames) components
-		 -> (UsagesMap, VersionsMap)	   -- input
-		 -> (UsagesMap, VersionsMap)	   -- output
-
-    process_item (big_mv_map, big_version_map) key@(n,m) rn as_before@(usages, versions)
-      | irrelevant rn
-      = as_before
-      | m == modname -- this module => add to "versions"
-      =	(usages, addToFM versions n 1{-stub-})
-      | otherwise  -- from another module => add to "usages"
-      = case (add_to_usages usages key) of
-	  Nothing	  -> as_before
-	  Just new_usages -> (new_usages, versions)
-      where
-	add_to_usages usages key@(n,m)
-	  = case (lookupFM big_mv_map m) of
-	      Nothing -> Nothing
-	      Just mv ->
-	        case (lookupFM big_version_map key) of
-		  Nothing -> Nothing
-		  Just kv ->
-		    Just $ addToFM usages m (
-			case (lookupFM usages m) of
-			  Nothing -> -- nothing for this module yet...
-			    (mv, unitFM n kv)
-
-			  Just (mversion, mstuff) -> -- the "new" stuff will shadow the old
-			    ASSERT(mversion == mv)
-			    (mversion, addToFM mstuff n kv)
-		    )
-
-    irrelevant (RnConstr  _ _) = True	-- We don't report these in their
-    irrelevant (RnField   _ _) = True	-- own right in usages/etc.
-    irrelevant (RnClassOp _ _) = True
-    irrelevant (RnImplicit  n) = isLexCon (nameOf (origName "irrelevant" n)) -- really a RnConstr
-    irrelevant _	       = False
+    fields = concat (map fst fielddecls)
+
+getConFieldNames new_name [] = returnRn []
 
+getClassOpNames new_name (ClassOpSig op _ _ src_loc) = new_name op src_loc
 \end{code}
 
 
+%*********************************************************
+%*							*
+\subsection{Reading an interface file}
+%*							*
+%*********************************************************
+
 \begin{code}
-thisModImplicitWarn mod n sty
-  = ppBesides [ppPStr SLIT("An interface has an implicit need of "), ppr sty n, ppPStr SLIT("; assuming this module will provide it.")]
+findAndReadIface :: Pretty -> Module -> RnMG (Maybe ParsedIface)
+	-- Nothing <=> file not found, or unreadable, or illegible
+	-- Just x  <=> successfully found and parsed 
+findAndReadIface doc_str mod
+  = traceRn trace_msg			`thenRn_`
+    getSearchPathRn			`thenRn` \ dirs ->
+    try dirs dirs
+  where
+    trace_msg = ppHang (ppBesides [ppStr "Reading interface for ", 
+				   pprModule PprDebug mod, ppSemi])
+		     4 (ppBesides [ppStr "reason: ", doc_str])
+
+    try all_dirs [] = traceRn (ppStr "...failed")	`thenRn_`
+		      returnRn Nothing
+
+    try all_dirs (dir:dirs)
+	= readIface file_path	`thenRn` \ read_result ->
+	  case read_result of
+		Nothing    -> try all_dirs dirs
+		Just iface -> traceRn (ppStr "...done")	`thenRn_`
+			      returnRn (Just iface)
+	where
+	  file_path = dir ++ "/" ++ moduleString mod ++ ".hi"
+\end{code}
 
-noIfaceErr mod sty
-  = ppCat [ppPStr SLIT("Could not find interface for:"), ppPStr mod]
+@readIface@ trys just one file.
 
-noOrigIfaceErr mod sty
-  = ppCat [ppPStr SLIT("Could not find original interface for:"), ppPStr mod]
+\begin{code}
+readIface :: String -> RnMG (Maybe ParsedIface)	
+	-- Nothing <=> file not found, or unreadable, or illegible
+	-- Just x  <=> successfully found and parsed 
+readIface file_path
+  = ioToRnMG (readFile file_path)  	`thenRn` \ read_result ->
+    case read_result of
+	Right contents	  -> case parseIface contents of
+				Failed err      -> failWithRn Nothing err 
+				Succeeded iface -> returnRn (Just iface)
 
-noDeclInIfaceErr mod str sty
-  = ppBesides [ppPStr SLIT("Could not find interface declaration of: "),
-	       ppPStr mod, ppStr ".", ppPStr str]
+	Left  (NoSuchThing _) -> returnRn Nothing
 
-cannaeReadErr file err sty
-  = ppBesides [ppPStr SLIT("Failed in reading file: "), ppStr file, ppStr "; error=", ppStr (show err)]
+	Left  err	      -> failWithRn Nothing
+					    (cannaeReadFile file_path err)
+
+\end{code}
+
+mkSearchPath takes a string consisting of a colon-separated list of directories, and turns it into
+a list of directories.  For example:
+
+	mkSearchPath "foo:.:baz"  =  ["foo", ".", "baz"]
+
+\begin{code}
+mkSearchPath :: Maybe String -> SearchPath
+mkSearchPath Nothing = ["."]
+mkSearchPath (Just s)
+  = go s
+  where
+    go "" = []
+    go s  = first : go (drop 1 rest)
+	  where
+	    (first,rest) = span (/= ':') s
+\end{code}
 
-ifaceLookupWiredErr msg n sty
-  = ppBesides [ppPStr SLIT("Why am I looking up a wired-in "), ppStr msg, ppChar ':', ppr sty n]
+%*********************************************************
+%*							*
+\subsection{Errors}
+%*							*
+%*********************************************************
 
-badIfaceLookupErr msg name decl sty
-  = ppBesides [ppPStr SLIT("Expected a "), ppStr msg, ppStr " declaration, but got this: ???"]
+\begin{code}
+noIfaceErr mod sty
+  = ppBesides [ppStr "Could not find interface for ", ppQuote (pprModule sty mod)]
+--	, ppStr " in"]) 4 (ppAboves (map ppStr dirs))
 
-ifaceIoErr io_msg rn sty
-  = ppBesides [io_msg sty, ppStr "; looking for: ", ppr sty rn]
+cannaeReadFile file err sty
+  = ppBesides [ppPStr SLIT("Failed in reading file: "), ppStr file, ppStr "; error=", ppStr (show err)]
 \end{code}
diff --git a/ghc/compiler/rename/RnLoop.lhi b/ghc/compiler/rename/RnLoop.lhi
index f228aee0b9..8aa729dd5a 100644
--- a/ghc/compiler/rename/RnLoop.lhi
+++ b/ghc/compiler/rename/RnLoop.lhi
@@ -3,16 +3,18 @@ Breaks the RnSource/RnExpr/RnBinds loops.
 \begin{code}
 interface RnLoop where
 
-import RdrHsSyn		( RdrNameHsBinds(..), RdrNamePolyType(..) )
-import RnHsSyn		( RnName, RenamedHsBinds(..), RenamedPolyType(..) )
-import RnBinds		( rnBinds, FreeVars(..) )
-import RnMonad		( TyVarNamesEnv(..), RnM_Fixes(..) )
-import RnSource		( rnPolyType )
+import RdrHsSyn		( RdrNameHsBinds(..), RdrNameHsType(..) )
+import RnHsSyn		( RenamedHsBinds(..), RenamedHsType(..) )
+import RnBinds		( rnBinds )
+import RnMonad		( RnMS(..), FreeVars )
+import RnSource		( rnHsType )
 import UniqSet		( UniqSet(..) )
+import Name		( Name )
 
-rnBinds :: RdrNameHsBinds -> RnM_Fixes s (RenamedHsBinds, FreeVars, [RnName])
-rnPolyType :: TyVarNamesEnv
-	   -> RdrNamePolyType
-	   -> RnM_Fixes s RenamedPolyType
-type FreeVars = UniqSet RnName
+rnBinds :: RdrNameHsBinds 
+	-> (RenamedHsBinds -> RnMS s (result, FreeVars))
+	-> RnMS s (result, FreeVars)
+
+rnHsType :: RdrNameHsType
+	 -> RnMS s RenamedHsType
 \end{code}
diff --git a/ghc/compiler/rename/RnMonad.lhs b/ghc/compiler/rename/RnMonad.lhs
index 22cb653f79..f1fd8477c5 100644
--- a/ghc/compiler/rename/RnMonad.lhs
+++ b/ghc/compiler/rename/RnMonad.lhs
@@ -6,166 +6,337 @@
 \begin{code}
 #include "HsVersions.h"
 
-module RnMonad (
-	SYN_IE(RnMonad), SYN_IE(RnM), SYN_IE(RnM_Fixes), RnDown, SST_R,
-	initRn, thenRn, thenRn_, andRn, returnRn,
-	mapRn, mapAndUnzipRn, mapAndUnzip3Rn,
-
-	addErrRn, addErrIfRn, addWarnRn, addWarnIfRn,
-	failButContinueRn, warnAndContinueRn,
-	setExtraRn, getExtraRn, getRnEnv,
-	getModuleRn, pushSrcLocRn, getSrcLocRn,
-	getSourceRn, getOccurrenceUpRn,
-	getImplicitUpRn, SYN_IE(ImplicitEnv), emptyImplicitEnv,
-	rnGetUnique, rnGetUniques,
-
-	newLocalNames,
-	lookupValue, lookupConstr, lookupField, lookupClassOp,
-	lookupTyCon, lookupClass, lookupTyConOrClass,
-	extendSS2, extendSS,
-
-	SYN_IE(TyVarNamesEnv), mkTyVarNamesEnv, domTyVarNamesEnv,
-	lookupTyVarName, nullTyVarNamesEnv, catTyVarNamesEnvs,
-
-	fixIO
+module RnMonad(
+	RnMonad..,
+	SST_R
     ) where
 
 IMP_Ubiq(){-uitous-}
-IMPORT_1_3(GHCbase(fixIO))
 
 import SST
+import PreludeGlaST	( SYN_IE(ST), thenST, returnST )
 
-import HsSyn		( FixityDecl )
-import RnHsSyn		( RnName, mkRnName, mkRnUnbound, mkRnImplicit,
-			  mkRnImplicitTyCon, mkRnImplicitClass, 
-			  isRnLocal, isRnWired, isRnTyCon, isRnClass,
-			  isRnTyConOrClass, isRnConstr, isRnField,
-			  isRnClassOp, RenamedFixityDecl(..) )
-import RnUtils		( SYN_IE(RnEnv), extendLocalRnEnv,
-			  lookupRnEnv, lookupGlobalRnEnv, lookupTcRnEnv,
-			  qualNameErr, dupNamesErr
-			)
-
-import Bag		( Bag, emptyBag, isEmptyBag, snocBag )
-import CmdLineOpts	( opt_WarnNameShadowing )
+import HsSyn		
+import RdrHsSyn
 import ErrUtils		( addErrLoc, addShortErrLocLine, addShortWarnLocLine,
-			  SYN_IE(Error), SYN_IE(Warning)
+			  pprBagOfErrors, SYN_IE(Error), SYN_IE(Warning)
 			)
-import FiniteMap	( FiniteMap, emptyFM, lookupFM, addToFM{-, fmToList ToDo:rm-} )
-import Maybes		( assocMaybe )
-import Name		( SYN_IE(Module), RdrName(..), isQual,
-			  OrigName(..), Name, mkLocalName, mkImplicitName,
-			  getOccName, pprNonSym
+import Name		( SYN_IE(Module), Name, OccName, Provenance, SYN_IE(NameSet),
+			  modAndOcc, NamedThing(..)
 			)
-import PrelInfo		( builtinNameMaps, builtinKeysMap, SYN_IE(BuiltinNames), SYN_IE(BuiltinKeys) )
-import PrelMods		( pRELUDE )
---import PprStyle{-ToDo:rm-}
---import Outputable{-ToDo:rm-}
+import CmdLineOpts	( opt_D_show_rn_trace )
+import PrelInfo		( builtinNames )
+import TyCon		( TyCon {- instance NamedThing -} )
+import TysWiredIn	( boolTyCon )
 import Pretty
-import SrcLoc		( SrcLoc, mkUnknownSrcLoc )
-import UniqFM		( UniqFM, emptyUFM )
-import UniqSet		( SYN_IE(UniqSet), mkUniqSet, minusUniqSet )
-import UniqSupply	( UniqSupply, getUnique, getUniques, splitUniqSupply )
+import PprStyle		( PprStyle(..) )
+import SrcLoc		( SrcLoc, mkGeneratedSrcLoc )
 import Unique		( Unique )
+import FiniteMap	( FiniteMap, emptyFM, bagToFM )
+import Bag		( Bag, mapBag, emptyBag, isEmptyBag, snocBag )
+import UniqSet
 import Util
 
 infixr 9 `thenRn`, `thenRn_`
 \end{code}
 
+
+%************************************************************************
+%*									*
+\subsection{Somewhat magical interface to other monads}
+%*									*
+%************************************************************************
+
 \begin{code}
-type RnM s r       = RnMonad () s r
-type RnM_Fixes s r = RnMonad (UniqFM RenamedFixityDecl) s r
-
-type RnMonad x s r = RnDown x s -> SST s r
-
-data RnDown x s
-  = RnDown
-	x
-	Module				-- Module name
-	SrcLoc				-- Source location
-	(RnMode s)			-- Source or Iface
-	RnEnv				-- Renaming environment
-	(MutableVar s UniqSupply)	-- Unique supply
-	(MutableVar s (Bag Warning, 	-- Warnings and Errors
-		       Bag Error))
-
-data RnMode s
- = RnSource (MutableVar s (Bag (RnName, RdrName)))
-	-- Renaming source; returning occurences
-
- | RnIface  BuiltinNames BuiltinKeys
-	    (MutableVar s ImplicitEnv)
-	-- Renaming interface; creating and returning implicit names
-	-- ImplicitEnv: one map for Values and one for TyCons/Classes.
-
-type ImplicitEnv = (FiniteMap OrigName RnName, FiniteMap OrigName RnName)
-emptyImplicitEnv :: ImplicitEnv
-emptyImplicitEnv = (emptyFM, emptyFM)
-
--- With a builtin polymorphic type for runSST the type for
--- initTc should use  RnM s r  instead of  RnM RealWorld r 
 #if __GLASGOW_HASKELL__ >= 200
-# define REAL_WORLD GHCbuiltins.RealWorld
+# define REAL_WORLD RealWorld
 #else
 # define REAL_WORLD _RealWorld
 #endif
+\end{code}
+
+\begin{code}
+sstToIO :: SST REAL_WORLD r -> IO r
+sstToIO sst 
+  = sstToST sst 	`thenST` \ r -> 
+    returnST (Right r)
+
+ioToRnMG :: IO r -> RnMG (Either IOError13 r)
+ioToRnMG io rn_down g_down = stToSST io
+
+traceRn :: Pretty -> RnMG ()
+traceRn msg | opt_D_show_rn_trace = ioToRnMG (hPutStr stderr (ppShow 80 msg) >> 
+					      hPutStr stderr "\n")	`thenRn_`
+				    returnRn ()
+	    | otherwise		  = returnRn ()
+\end{code}
 
-initRn :: Bool		-- True => Source; False => Iface
-       -> Module
-       -> RnEnv
-       -> UniqSupply
-       -> RnM REAL_WORLD r
-       -> (r, Bag Error, Bag Warning)
 
-initRn source mod env us do_rn
-  = runSST (
-	newMutVarSST emptyBag			`thenSST` \ occ_var ->
-	newMutVarSST emptyImplicitEnv		`thenSST` \ imp_var ->
-	newMutVarSST us 			`thenSST` \ us_var ->
-      	newMutVarSST (emptyBag,emptyBag)	`thenSST` \ errs_var ->
-	let
-	    mode = if source then
-		       RnSource occ_var
-	           else
-		       RnIface builtinNameMaps builtinKeysMap imp_var
-
-	    rn_down = RnDown () mod mkUnknownSrcLoc mode env us_var errs_var
-	in
+%************************************************************************
+%*									*
+\subsection{Data types}
+%*									*
+%************************************************************************
+
+===================================================
+		MONAD TYPES
+===================================================
+
+\begin{code}
+type RnM s d r = RnDown s -> d -> SST s r
+type RnMS s r   = RnM s          (SDown s) r		-- Renaming source
+type RnMG r     = RnM REAL_WORLD GDown     r		-- Getting global names etc
+type MutVar a  = MutableVar REAL_WORLD a		-- ToDo: there ought to be a standard defn of this
+
+	-- Common part
+data RnDown s = RnDown
+		  SrcLoc
+		  (MutableVar s RnNameSupply)
+		  (MutableVar s (Bag Warning, Bag Error))
+		  (MutableVar s [(Name,Necessity)])		-- Occurrences
+
+data Necessity = Compulsory | Optional		-- We *must* find definitions for
+						-- compulsory occurrences; we *may* find them
+						-- for optional ones.
+
+	-- For getting global names
+data GDown = GDown
+		SearchPath
+		(MutVar Ifaces)
+
+	-- For renaming source code
+data SDown s = SDown
+		  RnEnv	
+		  Module
+		  RnSMode
+
+
+data RnSMode	= SourceMode
+		| InterfaceMode
+
+type SearchPath = [String]		-- List of directories to seach for interface files
+type FreeVars	= NameSet
+\end{code}
+
+===================================================
+		ENVIRONMENTS
+===================================================
+
+\begin{code}
+type RnNameSupply = (UniqSupply, Int, FiniteMap (Module,OccName) Name)
+	-- Ensures that one (m,n) pair gets one unique
+	-- The Int is used to give a number to each instance declaration;
+	-- it's really a separate name supply.
+
+data RnEnv     	= RnEnv NameEnv FixityEnv
+emptyRnEnv	= RnEnv emptyNameEnv emptyFixityEnv
+
+type NameEnv	= FiniteMap RdrName Name
+emptyNameEnv	= emptyFM
+
+type FixityEnv		= FiniteMap RdrName (Fixity, Provenance)
+emptyFixityEnv	        = emptyFM
+	-- It's possible to have a different fixity for B.op than for op:
+	--
+	--	module A( op ) where		module B where
+	--	import qualified B( op )	infixr 2 op
+	--	infixl 9 `op`			op = ...
+	--	op a b = a `B.op` b
+
+data ExportEnv		= ExportEnv Avails Fixities
+type Avails		= [AvailInfo]
+type Fixities		= [(OccName, Fixity, Provenance)]
+	-- Can contain duplicates, if one module defines the same fixity,
+	-- or the same type/class/id, more than once.   Hence a boring old list.
+	-- This allows us to report duplicates in just one place, namely plusRnEnv.
+	
+type ModuleAvails	= FiniteMap Module Avails
+
+data AvailInfo		= NotAvailable | Avail Name [Name]
+\end{code}
+
+===================================================
+		INTERFACE FILE STUFF
+===================================================
+
+\begin{code}
+type ExportItem		 = (Module, OccName, [OccName])
+type VersionInfo name    = [ImportVersion name]
+type ImportVersion name  = (Module, Version, [LocalVersion name])
+type LocalVersion name   = (name, Version)
+
+data ParsedIface
+  = ParsedIface
+      Module		 	-- Module name
+      Version		 	-- Module version number
+      [ImportVersion OccName]		-- Usages
+      [ExportItem]			-- Exports
+      [Module]				-- Special instance modules
+      [(OccName,Fixity)]		-- Fixities
+      [(Version, RdrNameHsDecl)]	-- Local definitions
+      [RdrNameInstDecl]			-- Local instance declarations
+
+type InterfaceDetails = (VersionInfo Name,	-- Version information
+			 ExportEnv, 		-- What this module exports
+			 [Module])		-- Instance modules
+
+type RdrNamePragma = ()				-- Fudge for now
+-------------------
+
+data Ifaces = Ifaces
+		Module							-- Name of this module
+		(FiniteMap Module Version)
+		(FiniteMap Module (Avails, [(OccName,Fixity)]))		-- Exports
+		VersionMap
+		DeclsMap
+		(Bag IfaceInst)
+		[Module]		-- Set of modules with "special" instance declarations
+					-- Excludes this module
+
+type DeclsMap    = FiniteMap Name (AvailInfo, RdrNameHsDecl)
+type VersionMap  = FiniteMap Name Version
+type IfaceInst   = ([Name], Module, RdrNameInstDecl)	-- The Names are those tycons and
+							-- classes mentioned by the instance type
+\end{code}
+
+
+%************************************************************************
+%*									*
+\subsection{Main monad code}
+%*									*
+%************************************************************************
+
+\begin{code}
+initRn :: Module -> UniqSupply -> SearchPath -> SrcLoc
+       -> RnMG r
+       -> IO (r, Bag Error, Bag Warning)
+
+initRn mod us dirs loc do_rn
+  = sstToIO $
+    newMutVarSST (us, 1, builtins)	`thenSST` \ names_var ->
+    newMutVarSST (emptyBag,emptyBag)	`thenSST` \ errs_var ->
+    newMutVarSST (emptyIfaces mod)	`thenSST` \ iface_var -> 
+    newMutVarSST initOccs		`thenSST` \ occs_var ->
+    let
+	rn_down = RnDown loc names_var errs_var occs_var
+	g_down  = GDown dirs iface_var
+    in
 	-- do the buisness
-    	do_rn rn_down 				`thenSST` \ res ->
+    do_rn rn_down g_down		`thenSST` \ res ->
 
 	-- grab errors and return
-	readMutVarSST errs_var 			`thenSST` \ (warns,errs) ->
-	returnSST (res, errs, warns)
+    readMutVarSST errs_var			`thenSST` \ (warns,errs) ->
+    returnSST (res, errs, warns)
+
+
+initRnMS :: RnEnv -> Module -> RnSMode -> RnMS REAL_WORLD r -> RnMG r
+initRnMS env mod_name mode m rn_down g_down
+  = let
+	s_down = SDown env mod_name mode
+    in
+    m rn_down s_down
+
+
+emptyIfaces :: Module -> Ifaces
+emptyIfaces mod = Ifaces mod emptyFM emptyFM emptyFM emptyFM emptyBag []
+
+builtins :: FiniteMap (Module,OccName) Name
+builtins = bagToFM (mapBag (\ name -> (modAndOcc name, name)) builtinNames)
+
+	-- Initial value for the occurrence pool.
+initOccs :: [(Name,Necessity)]
+initOccs = [(getName boolTyCon, Compulsory)]
+	-- Booleans occur implicitly a lot, so it's tiresome to keep recording the fact, and
+	-- rather implausible that not one will be used in the module.
+	-- We could add some other common types, notably lists, but the general idea is
+	-- to do as much as possible explicitly.
+\end{code}
+
+\end{code}
+
+
+@renameSourceCode@ is used to rename stuff "out-of-line"; that is, not as part of
+the main renamer.  Examples: pragmas (which we don't want to rename unless
+we actually explore them); and derived definitions, which are only generated
+in the type checker.
+
+The @RnNameSupply@ includes a @UniqueSupply@, so if you call it more than
+once you must either split it, or install a fresh unique supply.
+
+\begin{code}
+renameSourceCode :: Module 
+		 -> RnNameSupply 
+	         -> RnMS REAL_WORLD r
+	         -> r
+
+-- Alas, we can't use the real runST, with the desired signature:
+--	renameSourceCode :: RnNameSupply -> RnMS s r -> r
+-- because we can't manufacture "new versions of runST".
+
+renameSourceCode mod_name name_supply m
+  = runSST (
+	newMutVarSST name_supply		`thenSST` \ names_var ->
+	newMutVarSST (emptyBag,emptyBag)	`thenSST` \ errs_var ->
+	newMutVarSST []				`thenSST` \ occs_var ->
+    	let
+	    rn_down = RnDown mkGeneratedSrcLoc names_var errs_var occs_var
+	    s_down = SDown emptyRnEnv mod_name InterfaceMode
+	in
+	m rn_down s_down			`thenSST` \ result ->
+	
+	readMutVarSST errs_var			`thenSST` \ (warns,errs) ->
+
+	(if not (isEmptyBag errs) then
+		trace ("Urk! renameSourceCode found errors" ++ display errs) 
+	 else if not (isEmptyBag warns) then
+		trace ("Urk! renameSourceCode found warnings" ++ display warns)
+	 else
+		id) $
+
+	returnSST result
     )
+  where
+    display errs = ppShow 80 (pprBagOfErrors PprDebug errs)
 
 {-# INLINE thenRn #-}
 {-# INLINE thenRn_ #-}
 {-# INLINE returnRn #-}
 {-# INLINE andRn #-}
 
-returnRn :: a -> RnMonad x s a
-thenRn   :: RnMonad x s a -> (a -> RnMonad x s b) -> RnMonad x s b
-thenRn_  :: RnMonad x s a -> RnMonad x s b -> RnMonad x s b
-andRn    :: (a -> a -> a) -> RnMonad x s a -> RnMonad x s a -> RnMonad x s a
-mapRn    :: (a -> RnMonad x s b) -> [a] -> RnMonad x s [b]
-mapAndUnzipRn :: (a -> RnMonad x s (b,c)) -> [a] -> RnMonad x s ([b],[c])
-
-returnRn v down  = returnSST v
-thenRn m k down  = m down `thenSST` \ r -> k r down
-thenRn_ m k down = m down `thenSST_` k down
-
-andRn combiner m1 m2 down
-  = m1 down `thenSST` \ res1 ->
-    m2 down `thenSST` \ res2 ->
+returnRn :: a -> RnM s d a
+thenRn   :: RnM s d a -> (a -> RnM s d b) -> RnM s d b
+thenRn_  :: RnM s d a -> RnM s d b -> RnM s d b
+andRn    :: (a -> a -> a) -> RnM s d a -> RnM s d a -> RnM s d a
+mapRn    :: (a -> RnM s d b) -> [a] -> RnM s d [b]
+sequenceRn :: [RnM s d a] -> RnM s d [a]
+foldlRn :: (b  -> a -> RnM s d b) -> b -> [a] -> RnM s d b
+mapAndUnzipRn :: (a -> RnM s d (b,c)) -> [a] -> RnM s d ([b],[c])
+fixRn    :: (a -> RnM s d a) -> RnM s d a
+
+returnRn v gdown ldown  = returnSST v
+thenRn m k gdown ldown  = m gdown ldown `thenSST` \ r -> k r gdown ldown
+thenRn_ m k gdown ldown = m gdown ldown `thenSST_` k gdown ldown
+fixRn m gdown ldown = fixSST (\r -> m r gdown ldown)
+andRn combiner m1 m2 gdown ldown
+  = m1 gdown ldown `thenSST` \ res1 ->
+    m2 gdown ldown `thenSST` \ res2 ->
     returnSST (combiner res1 res2)
 
+sequenceRn []     = returnRn []
+sequenceRn (m:ms) =  m			`thenRn` \ r ->
+		     sequenceRn ms 	`thenRn` \ rs ->
+		     returnRn (r:rs)
+
 mapRn f []     = returnRn []
 mapRn f (x:xs)
   = f x		`thenRn` \ r ->
     mapRn f xs 	`thenRn` \ rs ->
     returnRn (r:rs)
 
+foldlRn k z [] = returnRn z
+foldlRn k z (x:xs) = k z x	`thenRn` \ z' ->
+		     foldlRn k z' xs
+
 mapAndUnzipRn f [] = returnRn ([],[])
 mapAndUnzipRn f (x:xs)
   = f x		    	`thenRn` \ (r1,  r2)  ->
@@ -179,403 +350,168 @@ mapAndUnzip3Rn f (x:xs)
     returnRn (r1:rs1, r2:rs2, r3:rs3)
 \end{code}
 
-For errors and warnings ...
-\begin{code}
-failButContinueRn :: a -> Error -> RnMonad x s a
-failButContinueRn res err (RnDown _ _ _ _ _ _ errs_var)
-  = readMutVarSST  errs_var  				`thenSST`  \ (warns,errs) ->
-    writeMutVarSST errs_var (warns, errs `snocBag` err)	`thenSST_` 
-    returnSST res
-
-warnAndContinueRn :: a -> Warning -> RnMonad x s a
-warnAndContinueRn res warn (RnDown _ _ _ _ _ _ errs_var)
-  = readMutVarSST  errs_var  				 `thenSST`  \ (warns,errs) ->
-    writeMutVarSST errs_var (warns `snocBag` warn, errs) `thenSST_` 
-    returnSST res
-
-addErrRn :: Error -> RnMonad x s ()
-addErrRn err = failButContinueRn () err
-
-addErrIfRn :: Bool -> Error -> RnMonad x s ()
-addErrIfRn True err  = addErrRn err
-addErrIfRn False err = returnRn ()
-
-addWarnRn :: Warning -> RnMonad x s ()
-addWarnRn warn = warnAndContinueRn () warn
-
-addWarnIfRn :: Bool -> Warning -> RnMonad x s ()
-addWarnIfRn True warn  = addWarnRn warn
-addWarnIfRn False warn = returnRn ()
-\end{code}
-
 
-\begin{code}
-getRnEnv :: RnMonad x s RnEnv
-getRnEnv (RnDown _ _ _ _ env _ _)
-  = returnSST env
-
-setExtraRn :: x -> RnMonad x s r -> RnMonad y s r
-setExtraRn x m (RnDown _ mod locn mode env us errs)
-  = m (RnDown x mod locn mode env us errs)
-
-getExtraRn :: RnMonad x s x
-getExtraRn (RnDown x _ _ _ _ _ _)
-  = returnSST x
-
-getModuleRn :: RnMonad x s Module
-getModuleRn (RnDown _ mod _ _ _ _ _)
-  = returnSST mod
-
-pushSrcLocRn :: SrcLoc -> RnMonad x s a -> RnMonad x s a
-pushSrcLocRn locn m (RnDown x mod _ mode env us errs)
-  = m (RnDown x mod locn mode env us errs)
-
-getSrcLocRn :: RnMonad x s SrcLoc
-getSrcLocRn (RnDown _ _ locn _ _ _ _)
-  = returnSST locn
-
-getSourceRn :: RnMonad x s Bool
-getSourceRn (RnDown _ _ _ (RnSource _)    _ _ _) = returnSST True
-getSourceRn (RnDown _ _ _ (RnIface _ _ _) _ _ _) = returnSST False
-
-getOccurrenceUpRn :: RnMonad x s (Bag (RnName, RdrName))
-getOccurrenceUpRn (RnDown _ _ _ (RnSource occ_var) _ _ _)
-  = readMutVarSST occ_var
-getOccurrenceUpRn (RnDown _ _ _ (RnIface _ _ _) _ _ _)
-  = panic "getOccurrenceUpRn:RnIface"
-
-getImplicitUpRn :: RnMonad x s ImplicitEnv
-getImplicitUpRn (RnDown _ _ _ (RnIface _ _ imp_var) _ _ _)
-  = readMutVarSST imp_var
-getImplicitUpRn (RnDown _ _ _(RnSource _) _ _ _)
-  = panic "getImplicitUpRn:RnIface"
-\end{code}
 
-\begin{code}
-rnGetUnique :: RnMonad x s Unique
-rnGetUnique (RnDown _ _ _ _ _ us_var _)
-  = get_unique us_var
+%************************************************************************
+%*									*
+\subsection{Boring plumbing for common part}
+%*									*
+%************************************************************************
 
-rnGetUniques :: Int -> RnMonad x s [Unique]
-rnGetUniques n (RnDown _ _ _ _ _ us_var _)
-  = get_uniques n us_var
 
-
-get_unique us_var
-  = readMutVarSST us_var			`thenSST` \ uniq_supply ->
-    let
-      (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply
-      uniq			= getUnique uniq_s
-    in
-    writeMutVarSST us_var new_uniq_supply	`thenSST_`
-    returnSST uniq
-
-get_uniques n us_var
-  = readMutVarSST us_var			`thenSST` \ uniq_supply ->
-    let
-      (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply
-      uniqs			= getUniques n uniq_s
-    in
-    writeMutVarSST us_var new_uniq_supply	`thenSST_`
-    returnSST uniqs
-
-snoc_bag_var add bag_var
-  = readMutVarSST bag_var	`thenSST` \ bag ->
-    writeMutVarSST bag_var (bag `snocBag` add)
-
-\end{code}
-
-*********************************************************
-*							*
-\subsection{Making new names}
-*							*
-*********************************************************
-
-@newLocalNames@ takes a bunch of RdrNames, which are defined together
-in a group (eg a pattern or set of bindings), checks they are
-unqualified and distinct, and creates new Names for them.
+================  Errors and warnings =====================
 
 \begin{code}
-newLocalNames :: String 		-- Documentation string
-	      -> [(RdrName, SrcLoc)]
-	      -> RnMonad x s [RnName]
-
-newLocalNames str names_w_loc
-  = mapRn (addErrRn . qualNameErr str) quals 	`thenRn_`
-    mapRn (addErrRn . dupNamesErr str) dups  	`thenRn_`
-    mkLocalNames these
+failWithRn :: a -> Error -> RnM s d a
+failWithRn res msg (RnDown loc names_var errs_var occs_var) l_down
+  = readMutVarSST  errs_var  					`thenSST`  \ (warns,errs) ->
+    writeMutVarSST errs_var (warns, errs `snocBag` err)		`thenSST_` 
+    returnSST res
   where
-    quals = filter (isQual.fst) names_w_loc
-    (these, dups) = removeDups cmp_fst names_w_loc
-    cmp_fst (a,_) (b,_) = cmp a b
-\end{code}
+    err = addShortErrLocLine loc msg
 
-\begin{code}
-mkLocalNames :: [(RdrName, SrcLoc)] -> RnMonad x s [RnName]
-mkLocalNames names_w_locs
-  = rnGetUniques (length names_w_locs) 	`thenRn` \ uniqs ->
-    returnRn (zipWithEqual "mkLocalNames" new_local uniqs names_w_locs)
+warnWithRn :: a -> Warning -> RnM s d a
+warnWithRn res msg (RnDown loc names_var errs_var occs_var) l_down
+  = readMutVarSST  errs_var  				 	`thenSST`  \ (warns,errs) ->
+    writeMutVarSST errs_var (warns `snocBag` warn, errs)	`thenSST_` 
+    returnSST res
   where
-    new_local uniq (Unqual str, srcloc)
-      = mkRnName (mkLocalName uniq str False{-emph names-} srcloc)
-\end{code}
+    warn = addShortWarnLocLine loc msg
 
+addErrRn :: Error -> RnM s d ()
+addErrRn err = failWithRn () err
 
-*********************************************************
-*							*
-\subsection{Looking up values}
-*							*
-*********************************************************
+checkRn :: Bool -> Error -> RnM s d ()	-- Check that a condition is true
+checkRn False err  = addErrRn err
+checkRn True err = returnRn ()
 
-Action to look up a value depends on the RnMode.
-\begin{description}
-\item[RnSource:]
-Lookup value in RnEnv, recording occurrence for non-local values found.
-If not found report error and return Unbound name.
-\item[RnIface:]
-Lookup value in RnEnv. If not found lookup in implicit name env.
-If not found create new implicit name, adding it to the implicit env.
-\end{description}
+addWarnRn :: Warning -> RnM s d ()
+addWarnRn warn = warnWithRn () warn
 
-\begin{code}
-lookupValue      :: RdrName -> RnMonad x s RnName
-lookupConstr     :: RdrName -> RnMonad x s RnName
-lookupField      :: RdrName -> RnMonad x s RnName
-lookupClassOp    :: RnName  -> RdrName -> RnMonad x s RnName
-
-lookupValue rdr
-  = lookup_val rdr lookupRnEnv (\ rn -> True) (unknownNameErr "value")
-
-lookupConstr rdr
-  = lookup_val rdr lookupGlobalRnEnv isRnConstr (unknownNameErr "constructor")
-
-lookupField rdr
-  = lookup_val rdr lookupGlobalRnEnv isRnField (unknownNameErr "field")
+checkErrsRn :: RnM s d Bool		-- True <=> no errors so far
+checkErrsRn  (RnDown loc names_var errs_var occs_var) l_down
+  = readMutVarSST  errs_var  				 	`thenSST`  \ (warns,errs) ->
+    returnSST (isEmptyBag errs)
+\end{code}
 
-lookupClassOp cls rdr
-  = lookup_val rdr lookupGlobalRnEnv (\ rn -> isRnClassOp cls rn) (badClassOpErr cls)
 
--- Note: the lookup checks are only performed when renaming source
+================  Source location =====================
 
-lookup_val rdr lookup check do_err down@(RnDown _ _ locn (RnSource occ_var) env _ _)
-  = case lookup env rdr of
-	Just name | check name -> succ name
-		  | otherwise  -> fail
-	Nothing                -> fail
+\begin{code}
+pushSrcLocRn :: SrcLoc -> RnM s d a -> RnM s d a
+pushSrcLocRn loc' m (RnDown loc names_var errs_var occs_var) l_down
+  = m (RnDown loc' names_var errs_var occs_var) l_down
 
-  where
-    succ name = if isRnLocal name || isRnWired name then
-		    returnSST name
-		else
-		    snoc_bag_var (name,rdr) occ_var `thenSST_`
-		    returnSST name
-    fail = failButContinueRn (mkRnUnbound rdr) (do_err rdr locn) down
-
-lookup_val rdr lookup check do_err down@(RnDown _ _ locn (RnIface b_names b_key imp_var) env us_var _)
-  = case lookup env rdr of
-      Just name -> returnSST name
-      Nothing   -> case rdr of
-		     Unqual n -> panic ("lookup_val:"++ _UNPK_ n)
-		     Qual m n ->
-		       lookup_nonexisting_val b_names b_key imp_var us_var (OrigName m n)
-
-lookup_nonexisting_val (b_names,_) b_key imp_var us_var orig
-  = case (lookupFM b_names orig) of
-      Just xx -> returnSST xx
-      Nothing -> lookup_or_create_implicit_val b_key imp_var us_var orig
-
-lookup_or_create_implicit_val b_key imp_var us_var orig
-  = readMutVarSST imp_var `thenSST` \ (implicit_val_fm, implicit_tc_fm) ->
-    case (lookupFM implicit_val_fm orig) of
-	Just implicit -> returnSST implicit
-	Nothing ->
-	  (case (lookupFM b_key orig) of
-		Just (u,_) -> returnSST u
-		_          -> get_unique us_var
-	  )							`thenSST` \ uniq -> 
-	  let
-	      implicit   = mkRnImplicit (mkImplicitName uniq orig)
-	      new_val_fm = addToFM implicit_val_fm orig implicit
-	  in
-	  writeMutVarSST imp_var (new_val_fm, implicit_tc_fm) 	`thenSST_`
-	  returnSST implicit
+getSrcLocRn :: RnM s d SrcLoc
+getSrcLocRn (RnDown loc names_var errs_var occs_var) l_down
+  = returnSST loc
 \end{code}
 
+================  Name supply =====================
 
 \begin{code}
-lookupTyCon   :: RdrName -> RnMonad x s RnName
-lookupClass   :: RdrName -> RnMonad x s RnName
+getNameSupplyRn :: RnM s d RnNameSupply
+getNameSupplyRn (RnDown loc names_var errs_var occs_var) l_down
+  = readMutVarSST names_var
 
-lookupTyCon rdr
-  = lookup_tc rdr isRnTyCon mkRnImplicitTyCon "type constructor"
-
-lookupClass rdr
-  = lookup_tc rdr isRnClass mkRnImplicitClass "class"
-
-lookupTyConOrClass rdr
-  = lookup_tc rdr isRnTyConOrClass
-	      (panic "lookupTC:mk_implicit") "class or type constructor"
-
-lookup_tc rdr check mk_implicit err_str down@(RnDown _ _ locn (RnSource occ_var) env _ _)
-  = case lookupTcRnEnv env rdr of
-       Just name | check name -> succ name
-	         | otherwise  -> fail
-       Nothing                -> fail
-  where
-    succ name = snoc_bag_var (name,rdr) occ_var `thenSST_`
-		returnSST name
-    fail = failButContinueRn (mkRnUnbound rdr) (unknownNameErr err_str rdr locn) down
-
-lookup_tc rdr@(Qual m n) check mk_implicit err_str down@(RnDown _ _ locn (RnIface b_names b_key imp_var) env us_var _)
-  = case lookupTcRnEnv env rdr of
-	Just name | check name -> returnSST name
-		  | otherwise  -> fail
-	Nothing -> lookup_nonexisting_tc check mk_implicit fail b_names b_key imp_var us_var (OrigName m n)
-  where
-    fail = failButContinueRn (mkRnUnbound rdr) (unknownNameErr err_str rdr locn) down
-
-lookup_nonexisting_tc check mk_implicit fail (_,b_names) b_key imp_var us_var orig--@(OrigName m n)
-  = --pprTrace "lookup:" (ppAboves [case str_mod of {(n,m)->ppCat [ppPStr n, ppPStr m]}, ppAboves [ ppCat [ppPStr n, ppPStr m] | ((n,m), _) <- fmToList b_names]]) $
-    case (lookupFM b_names orig) of
-      Just xx -> returnSST xx
-      Nothing -> lookup_or_create_implicit_tc check mk_implicit fail b_key imp_var us_var orig
-
-lookup_or_create_implicit_tc check mk_implicit fail b_key imp_var us_var orig
-  = readMutVarSST imp_var `thenSST` \ (implicit_val_fm, implicit_tc_fm) ->
-    case (lookupFM implicit_tc_fm orig) of
-	Just implicit | check implicit -> returnSST implicit
-		      | otherwise      -> fail
-	Nothing ->
-	  (case (lookupFM b_key orig) of
-		Just (u,_) -> returnSST u
-		_          -> get_unique us_var
-	  )							`thenSST` \ uniq -> 
-	  let
-	      implicit  = mk_implicit (mkImplicitName uniq orig)
-	      new_tc_fm = addToFM implicit_tc_fm orig implicit
-	  in
-	  writeMutVarSST imp_var (implicit_val_fm, new_tc_fm) 	`thenSST_`
-	  returnSST implicit
+setNameSupplyRn :: RnNameSupply -> RnM s d ()
+setNameSupplyRn names' (RnDown loc names_var errs_var occs_var) l_down
+  = writeMutVarSST names_var names'
 \end{code}
 
-
-@extendSS@ extends the scope; @extendSS2@ also removes the newly bound
-free vars from the result.
+================  Occurrences =====================
 
 \begin{code}
-extendSS :: [RnName] 				-- Newly bound names
-	 -> RnMonad x s a
-	 -> RnMonad x s a
-
-extendSS binders m down@(RnDown x mod locn mode env us errs)
-  = (mapRn (addErrRn . shadowedNameWarn locn) dups `thenRn_`
-     m) (RnDown x mod locn mode new_env us errs)
-  where
-    (new_env,dups) = extendLocalRnEnv opt_WarnNameShadowing env binders
-
-extendSS2 :: [RnName] 				-- Newly bound names
-	  -> RnMonad x s (a, UniqSet RnName)
-	  -> RnMonad x s (a, UniqSet RnName)
-
-extendSS2 binders m
-  = extendSS binders m `thenRn` \ (r, fvs) ->
-    returnRn (r, fvs `minusUniqSet` (mkUniqSet binders))
+addOccurrenceName :: Necessity -> Name -> RnM s d ()
+addOccurrenceName necessity name (RnDown loc names_var errs_var occs_var) l_down
+  = readMutVarSST occs_var			`thenSST` \ occs ->
+    writeMutVarSST occs_var ((name,necessity) : occs)
+
+addOccurrenceNames :: Necessity -> [Name] -> RnM s d ()
+addOccurrenceNames necessity names (RnDown loc names_var errs_var occs_var) l_down
+  = readMutVarSST occs_var			`thenSST` \ occs ->
+    writeMutVarSST occs_var ([(name,necessity) | name <- names] ++ occs)
+
+popOccurrenceName :: RnM s d (Maybe (Name,Necessity))
+popOccurrenceName (RnDown loc names_var errs_var occs_var) l_down
+  = readMutVarSST occs_var			`thenSST` \ occs ->
+    case occs of
+	[] 	   -> returnSST Nothing
+	(occ:occs) -> writeMutVarSST occs_var occs	`thenSST_`
+		      returnSST (Just occ)
+
+-- findOccurrencesRn does the enclosed thing with a *fresh* occurrences
+-- variable, and returns the list of occurrences thus found.  It's useful
+-- when loading instance decls and specialisation signatures, when we want to
+-- know the names of the things in the types, but we don't want to treat them
+-- as occurrences.
+
+findOccurrencesRn :: RnM s d a -> RnM s d [Name]
+findOccurrencesRn enclosed_thing (RnDown loc names_var errs_var occs_var) l_down
+  = newMutVarSST []							`thenSST` \ new_occs_var ->
+    enclosed_thing (RnDown loc names_var errs_var new_occs_var) l_down	`thenSST_`
+    readMutVarSST new_occs_var						`thenSST` \ occs ->
+    returnSST (map fst occs)
 \end{code}
 
-The free var set returned by @(extendSS binders m)@ is that returned
-by @m@, {\em minus} binders.
 
+%************************************************************************
+%*									*
+\subsection{Plumbing for rename-source part}
+%*									*
+%************************************************************************
 
-*********************************************************
-*							*
-\subsection{TyVarNamesEnv}
-*							*
-*********************************************************
+================  RnEnv  =====================
 
 \begin{code}
-type TyVarNamesEnv = [(RdrName, RnName)]
+getNameEnv :: RnMS s NameEnv
+getNameEnv rn_down (SDown (RnEnv name_env fixity_env) mod_name mode)
+  = returnSST name_env
 
-nullTyVarNamesEnv :: TyVarNamesEnv
-nullTyVarNamesEnv = []
+setNameEnv :: NameEnv -> RnMS s a -> RnMS s a
+setNameEnv name_env' m rn_down (SDown (RnEnv name_env fixity_env) mod_name mode)
+  = m rn_down (SDown (RnEnv name_env' fixity_env) mod_name mode)
 
-catTyVarNamesEnvs :: TyVarNamesEnv -> TyVarNamesEnv -> TyVarNamesEnv
-catTyVarNamesEnvs e1 e2 = e1 ++ e2
+getFixityEnv :: RnMS s FixityEnv
+getFixityEnv rn_down (SDown (RnEnv name_env fixity_env) mod_name mode)
+  = returnSST fixity_env
 
-domTyVarNamesEnv :: TyVarNamesEnv -> [RdrName]
-domTyVarNamesEnv env = map fst env
+setRnEnv :: RnEnv -> RnMS s a -> RnMS s a 
+setRnEnv rn_env' m rn_down (SDown rn_env mod_name mode)
+  = m rn_down (SDown rn_env' mod_name mode)
 \end{code}
 
-@mkTyVarNamesEnv@ checks for duplicates, and complains if so.
+================  Module and Mode =====================
 
 \begin{code}
-mkTyVarNamesEnv
-	:: SrcLoc
-	-> [RdrName]				-- The type variables
-	-> RnMonad x s (TyVarNamesEnv,[RnName])	-- Environment and renamed tyvars
-
-mkTyVarNamesEnv src_loc tyvars
-  = newLocalNames "type variable"
-	 (tyvars `zip` repeat src_loc) `thenRn`  \ rn_tyvars ->
-
-	 -- rn_tyvars may not be in the same order as tyvars, so we need some
-	 -- jiggery pokery to build the right tyvar env, and return the
-	 -- renamed tyvars in the original order.
-    let tv_occ_name_pairs 	= map tv_occ_name_pair rn_tyvars
-    	tv_env	    	    	= map (lookup_occ_name tv_occ_name_pairs) tyvars
-	rn_tyvars_in_orig_order	= map snd tv_env
-    in
-    returnRn (tv_env, rn_tyvars_in_orig_order)
-  where
-    tv_occ_name_pair :: RnName -> (RdrName, RnName)
-    tv_occ_name_pair rn_name = (getOccName rn_name, rn_name)
-
-    lookup_occ_name :: [(RdrName, RnName)] -> RdrName -> (RdrName, RnName)
-    lookup_occ_name pairs tyvar_occ
-      = (tyvar_occ, assoc "mkTyVarNamesEnv" pairs tyvar_occ)
+getModuleRn :: RnMS s Module
+getModuleRn rn_down (SDown rn_env mod_name mode)
+  = returnSST mod_name
 \end{code}
 
 \begin{code}
-lookupTyVarName :: TyVarNamesEnv -> RdrName -> RnMonad x s RnName
-lookupTyVarName env occ
-  = case (assocMaybe env occ) of
-      Just name -> returnRn name
-      Nothing   -> getSrcLocRn	`thenRn` \ loc ->
-		   failButContinueRn (mkRnUnbound occ)
-		       (unknownNameErr "type variable" occ loc)
+getModeRn :: RnMS s RnSMode
+getModeRn rn_down (SDown rn_env mod_name mode)
+  = returnSST mode
 \end{code}
 
 
-\begin{code}
-#if __GLASGOW_HASKELL__ >= 200
-    -- can get it from GHCbase
-#else
-fixIO :: (a -> IO a) -> IO a
+%************************************************************************
+%*									*
+\subsection{Plumbing for rename-globals part}
+%*									*
+%************************************************************************
 
-fixIO k s = let
-		result          = k loop s
-		(Right loop, _) = result
-	    in
-	    result
-#endif
-\end{code}
+\begin{code}
+getIfacesRn :: RnMG Ifaces
+getIfacesRn rn_down (GDown dirs iface_var)
+  = readMutVarSST iface_var
 
-*********************************************************
-*							*
-\subsection{Errors used in RnMonad}
-*							*
-*********************************************************
+setIfacesRn :: Ifaces -> RnMG ()
+setIfacesRn ifaces rn_down (GDown dirs iface_var)
+  = writeMutVarSST iface_var ifaces
 
-\begin{code}
-unknownNameErr descriptor name locn
-  = addShortErrLocLine locn $ \ sty ->
-    ppBesides [ppStr "undefined ", ppStr descriptor, ppStr ": ", pprNonSym sty name]
-
-badClassOpErr clas op locn
-  = addErrLoc locn "" $ \ sty ->
-    ppBesides [ppChar '`', pprNonSym sty op, ppStr "' is not an operation of class `",
-	      ppr sty clas, ppStr "'"]
-
-shadowedNameWarn locn shadow
-  = addShortWarnLocLine locn $ \ sty ->
-    ppBesides [ppStr "more than one value with the same name (shadowing): ", ppr sty shadow]
+getSearchPathRn :: RnMG SearchPath
+getSearchPathRn rn_down (GDown dirs iface_var)
+  = returnSST dirs
 \end{code}
diff --git a/ghc/compiler/rename/RnNames.lhs b/ghc/compiler/rename/RnNames.lhs
index 28cd29aeaf..069d7100d2 100644
--- a/ghc/compiler/rename/RnNames.lhs
+++ b/ghc/compiler/rename/RnNames.lhs
@@ -7,1057 +7,460 @@
 #include "HsVersions.h"
 
 module RnNames (
-	getGlobalNames,
-	SYN_IE(GlobalNameInfo)
+	getGlobalNames
     ) where
 
-import PreludeGlaST	( SYN_IE(MutableVar) )
-
 IMP_Ubiq()
 
-import HsSyn
-import RdrHsSyn
-import RnHsSyn
-
+import CmdLineOpts	( opt_SourceUnchanged )
+import HsSyn	( HsModule(..), HsDecl(..), FixityDecl(..), Fixity, Fake, InPat, IE(..), HsTyVar,
+		  TyDecl, ClassDecl, InstDecl, DefaultDecl, ImportDecl(..), HsBinds, IfaceSig
+		)
+import HsBinds	( collectTopBinders )
+import HsImpExp	( ieName )
+import RdrHsSyn	( RdrNameHsDecl(..), RdrName(..), RdrNameIE(..), SYN_IE(RdrNameImportDecl),
+		  SYN_IE(RdrNameHsModule), SYN_IE(RdrNameFixityDecl),
+		  rdrNameOcc
+		)
+import RnHsSyn	( RenamedHsModule(..), RenamedFixityDecl(..) )
+import RnIfaces	( getInterfaceExports, getDeclBinders, checkUpToDate )
+import RnEnv
 import RnMonad
-import RnIfaces		( IfaceCache, cachedIface, cachedDecl, CachingResult(..) )
-import RnUtils		( SYN_IE(RnEnv), emptyRnEnv, initRnEnv, extendGlobalRnEnv,
-			  lubExportFlag, qualNameErr, dupNamesErr, pprRnEnv
-			)
-import ParseUtils	( ParsedIface(..), RdrIfaceDecl(..), ExportsMap(..), RdrIfaceInst )
-
-
-import Bag		( emptyBag, unitBag, consBag, snocBag, unionBags,
-			  unionManyBags, mapBag, foldBag, filterBag, listToBag, bagToList )
-import CmdLineOpts	( opt_NoImplicitPrelude, opt_CompilingGhcInternals )
-import ErrUtils		( SYN_IE(Error), SYN_IE(Warning), addErrLoc, addShortErrLocLine, addShortWarnLocLine )
-import FiniteMap	( emptyFM, addToFM, addListToFM, lookupFM, fmToList, eltsFM, delListFromFM, FiniteMap )
-import Id		( GenId )
-import Maybes		( maybeToBool, catMaybes, MaybeErr(..) )
-import Name		( RdrName(..), Name, isQual, mkTopLevName, mkWiredInName, origName,
-			  nameOf, qualToOrigName, mkImportedName,
-			  nameExportFlag, nameImportFlag,
-			  getLocalName, getSrcLoc, getImpLocs,
-			  moduleNamePair, pprNonSym,
-			  isLexCon, isLexSpecialSym, ExportFlag(..), OrigName(..)
-			)
-import PrelInfo		( SYN_IE(BuiltinNames), SYN_IE(BuiltinKeys) )
-import PrelMods		( pRELUDE, gHC_BUILTINS, modulesWithBuiltins )
+import FiniteMap
+import PrelMods
+import UniqFM	( UniqFM, emptyUFM, addListToUFM_C, lookupUFM )
+import Bag	( Bag, bagToList )
+import Maybes	( maybeToBool, expectJust )
+import Name
 import Pretty
-import SrcLoc		( SrcLoc, mkBuiltinSrcLoc )
-import TyCon		( tyConDataCons )
-import UniqFM		( emptyUFM, addListToUFM_C, lookupUFM )
-import UniqSupply	( splitUniqSupply )
-import Util		( isIn, assoc, cmpPString, sortLt, removeDups,
-			  equivClasses, panic, assertPanic
-			)
---import PprStyle --ToDo:rm 
+import PprStyle	( PprStyle(..) )
+import Util	( panic, pprTrace )
 \end{code}
 
-\begin{code}
-type GlobalNameInfo = (BuiltinNames,
-		       BuiltinKeys,
-		       Name -> ExportFlag,	-- export flag
-		       Name -> [RdrName])	-- occurrence names
-		       -- NB: both of the functions are in a *knot* and
-		       -- must be tugged on oh-so-gently...
-
-type RnM_Info s r = RnMonad GlobalNameInfo s r
-
-getGlobalNames ::
-	   IfaceCache		
-	-> GlobalNameInfo	
-	-> UniqSupply
-	-> RdrNameHsModule
-	-> IO (RnEnv,
-	       [Module],		-- directly imported modules
-	       Bag (Module,RnName),	-- unqualified imports from module
-	       Bag RenamedFixityDecl,	-- imported fixity decls
-	       Bag Error,
-	       Bag Warning)
-
-getGlobalNames iface_cache info us
-	       (HsModule mod _ _ imports _ ty_decls _ cls_decls _ _ _ binds _ _)
-  = let
-	(us1, us2) = splitUniqSupply us
-    in
-    case initRn True mod emptyRnEnv us1 
-		(setExtraRn info $
-		 getSourceNames ty_decls cls_decls binds)
-    of { ((src_vals, src_tcs), src_errs, src_warns) ->
 
-    doImportDecls iface_cache info us2 imports	>>=
-	\ (imp_vals, imp_tcs, imp_mods, unqual_imps, imp_fixes, imp_errs, imp_warns) ->
 
-    let
-        unqual_vals = map (\rn -> (Unqual (getLocalName rn), rn)) (bagToList src_vals)
-        unqual_tcs  = map (\rn -> (Unqual (getLocalName rn), rn)) (bagToList src_tcs)
+%************************************************************************
+%*									*
+\subsection{Get global names}
+%*									*
+%************************************************************************
 
-        (src_env, src_dups) = extendGlobalRnEnv initRnEnv unqual_vals unqual_tcs
-	(all_env, imp_dups) = extendGlobalRnEnv src_env (bagToList imp_vals) (bagToList imp_tcs)
+\begin{code}
+getGlobalNames :: RdrNameHsModule
+	       -> RnMG (Maybe (ExportEnv, RnEnv, [AvailInfo]))
+			-- Nothing <=> no need to recompile
+
+getGlobalNames m@(HsModule this_mod _ exports imports _ _ mod_loc)
+  = fixRn (\ ~(rec_exp_fn, _) ->
+
+	-- PROCESS LOCAL DECLS
+	-- Do these *first* so that the correct provenance gets
+	-- into the global name cache.
+      importsFromLocalDecls rec_exp_fn m	`thenRn` \ (local_rn_env, local_mod_avails) ->
+
+	-- PROCESS IMPORT DECLS
+      mapAndUnzipRn importsFromImportDecl all_imports
+						`thenRn` \ (imp_rn_envs, imp_avails_s) ->
+
+	-- CHECK FOR EARLY EXIT
+      checkEarlyExit this_mod			`thenRn` \ early_exit ->
+      if early_exit then
+		returnRn (junk_exp_fn, Nothing)
+      else
+
+	-- COMBINE RESULTS
+	-- We put the local env first, so that a local provenance
+	-- "wins", even if a module imports itself.
+      foldlRn plusRnEnv emptyRnEnv imp_rn_envs		`thenRn` \ imp_rn_env ->
+      plusRnEnv local_rn_env imp_rn_env	 		`thenRn` \ rn_env ->
+      let
+	 all_avails :: ModuleAvails
+	 all_avails = foldr plusModuleAvails local_mod_avails imp_avails_s
+	 local_avails = expectJust "getGlobalNames" (lookupModuleAvails local_mod_avails this_mod)
+      in
+  
+	-- PROCESS EXPORT LISTS
+      exportsFromAvail this_mod exports all_avails rn_env	
+							`thenRn` \ (export_fn, export_env) ->
+
+      returnRn (export_fn, Just (export_env, rn_env, local_avails))
+    )							`thenRn` \ (_, result) ->
+    returnRn result
+  where
+    junk_exp_fn = error "RnNames:export_fn"
 
-	-- remove dups of the same imported thing
-	diff_imp_dups = filterBag diff_orig imp_dups
-	diff_orig (_,rn1,rn2) = origName "diff_orig" rn1 /= origName "diff_orig" rn2
+    all_imports = prel_imports ++ imports
 
-	all_dups = bagToList (src_dups `unionBags` diff_imp_dups)
-	dup_errs = map dup_err (equivClasses cmp_rdr all_dups)
-	cmp_rdr (rdr1,_,_) (rdr2,_,_) = cmp rdr1 rdr2
-	dup_err ((rdr,rn1,rn2):rest) = globalDupNamesErr rdr (rn1:rn2: [rn|(_,_,rn)<-rest])
+    prel_imports | this_mod == pRELUDE ||
+		   explicit_prelude_import = []
 
-	all_errs  = src_errs  `unionBags` imp_errs `unionBags` listToBag dup_errs
-	all_warns = src_warns `unionBags` imp_warns
-    in
---    pprTrace "initRnEnv:" (pprRnEnv PprDebug initRnEnv) $
---    pprTrace "src_env:"   (pprRnEnv PprDebug src_env) $
---    pprTrace "all_env:"   (pprRnEnv PprDebug all_env) $
-    return (all_env, imp_mods, unqual_imps, imp_fixes, all_errs, all_warns) }
+		 | otherwise		   = [ImportDecl pRELUDE 
+							 False		{- Not qualified -}
+							 Nothing	{- No "as" -}
+							 Nothing	{- No import list -}
+							 mod_loc]
+    
+    explicit_prelude_import
+      = not (null [ () | (ImportDecl mod qual _ _ _) <- imports, mod == pRELUDE ])
 \end{code}
-
-*********************************************************
-*							*
-\subsection{Top-level source names}
-*							*
-*********************************************************
+	
+\begin{code}
+checkEarlyExit mod
+  = if not opt_SourceUnchanged then
+	-- Source code changed; look no further
+	returnRn False
+    else
+	-- Unchanged source; look further
+	-- We check for 
+	-- 	(a) errors so far.  These can arise if a module imports
+	--	    something that's no longer exported by the imported module
+	--	(b) usage information up to date
+	checkErrsRn				`thenRn` \ no_errs_so_far ->
+	checkUpToDate mod			`thenRn` \ up_to_date ->
+	returnRn (no_errs_so_far && up_to_date)
+\end{code}
+	
 
 \begin{code}
-getSourceNames ::			-- Collects global *binders* (not uses)
-	   [RdrNameTyDecl]
-	-> [RdrNameClassDecl]
-	-> RdrNameHsBinds
-	-> RnM_Info s (Bag RnName,	-- values
-		       Bag RnName)	-- tycons/classes
-
-getSourceNames ty_decls cls_decls binds
-  = mapAndUnzip3Rn getTyDeclNames ty_decls	`thenRn` \ (tycon_s, constrs_s, fields_s) ->
-    mapAndUnzipRn  getClassNames cls_decls	`thenRn` \ (cls_s, cls_ops_s) ->
-    getTopBindsNames binds			`thenRn` \ bind_names ->
-    returnRn (unionManyBags constrs_s `unionBags`
-	      unionManyBags fields_s  `unionBags`
-	      unionManyBags cls_ops_s `unionBags` bind_names,
-	      listToBag tycon_s `unionBags` listToBag cls_s)
-
---------------
-getTyDeclNames :: RdrNameTyDecl
-	       -> RnM_Info s (RnName, Bag RnName, Bag RnName)	-- tycon, constrs and fields
-
-getTyDeclNames (TyData _ tycon _ condecls _ _ src_loc)
-  = --getExtraRn		`thenRn` \ ((b_val_names,b_tc_names),b_keys,rec_exp_fn,rec_occ_fn) ->
-    --pprTrace "getTyDeclNames:" (ppr PprDebug tycon) $
-    --pprTrace "getTDN1:" (ppAboves [ ppCat [ppPStr m, ppPStr n] | ((OrigName m n), _) <- fmToList b_tc_names]) $
-
-    newGlobalName src_loc Nothing False{-not val-} tycon `thenRn` \ tycon_name ->
-    getConFieldNames (Just (nameExportFlag tycon_name)) emptyBag emptyBag emptyFM
-		     condecls 		`thenRn` \ (con_names, field_names) ->
-    let
-	rn_tycon   = RnData tycon_name con_names field_names
-        rn_constrs = [ RnConstr name tycon_name | name <- con_names]
-        rn_fields  = [ RnField name tycon_name | name <- field_names]
-    in
-    returnRn (rn_tycon, listToBag rn_constrs, listToBag rn_fields)
-
-getTyDeclNames (TyNew _ tycon _ [NewConDecl con _ con_loc] _ _ src_loc)
-  = newGlobalName src_loc Nothing False{-not val-} tycon	`thenRn` \ tycon_name ->
-    newGlobalName con_loc (Just (nameExportFlag tycon_name)) True{-val-} con
-					`thenRn` \ con_name ->
-    returnRn (RnData tycon_name [con_name] [],
-	      unitBag (RnConstr con_name tycon_name),
-	      emptyBag)
-
-getTyDeclNames (TySynonym tycon _ _ src_loc)
-  = newGlobalName src_loc Nothing False{-not val-} tycon	`thenRn` \ tycon_name ->
-    returnRn (RnSyn tycon_name, emptyBag, emptyBag)
-
-----------------
-getConFieldNames :: Maybe ExportFlag
-		 -> Bag Name -> Bag Name
-		 -> FiniteMap RdrName ()
-		 -> [RdrNameConDecl]
-		 -> RnM_Info s ([Name], [Name])
-
-getConFieldNames exp constrs fields have []
-  = returnRn (bagToList constrs, bagToList fields)
-
-getConFieldNames exp constrs fields have (ConDecl con _ src_loc : rest)
-  = newGlobalName src_loc exp True{-val-} con	`thenRn` \ con_name ->
-    getConFieldNames exp (constrs `snocBag` con_name) fields have rest
-
-getConFieldNames exp constrs fields have (ConOpDecl _ con _ src_loc : rest)
-  = newGlobalName src_loc exp True{-val-} con	`thenRn` \ con_name ->
-    getConFieldNames exp (constrs `snocBag` con_name) fields have rest
-
-getConFieldNames exp constrs fields have (RecConDecl con fielddecls src_loc : rest)
-  = mapRn (addErrRn . dupFieldErr con src_loc) dups	`thenRn_`
-    newGlobalName src_loc exp True{-val-} con		`thenRn` \ con_name ->
-    mapRn (newGlobalName src_loc exp True{-val-}) new_fields 	`thenRn` \ field_names ->
+importsFromImportDecl :: RdrNameImportDecl
+		      -> RnMG (RnEnv, ModuleAvails)
+
+	-- Check for "import M ()", and then don't even look at M.
+	-- This makes sense, and is actually rather useful for the Prelude.
+importsFromImportDecl (ImportDecl mod qual as_mod (Just (False,[])) loc)
+  = returnRn (emptyRnEnv, emptyModuleAvails)
+
+importsFromImportDecl (ImportDecl mod qual as_mod import_spec loc)
+  = pushSrcLocRn loc $
+    getInterfaceExports mod			`thenRn` \ (avails, fixities) ->
+    filterImports mod import_spec avails	`thenRn` \ filtered_avails ->
     let
-	all_constrs = constrs `snocBag` con_name
-	all_fields  = fields  `unionBags` listToBag field_names
+	filtered_avails' = [ Avail (set_name_prov n) (map set_name_prov ns)
+			   | Avail n ns <- filtered_avails
+			   ]
+	fixities'        = [ (occ,fixity,provenance) | (occ,fixity) <- fixities ]
     in
-    getConFieldNames exp all_constrs all_fields new_have rest
+    qualifyImports mod qual as_mod (ExportEnv filtered_avails' fixities')
   where
-    (uniq_fields, dups) = removeDups cmp (concat (map fst fielddecls))
-    new_fields = filter (not . maybeToBool . lookupFM have) uniq_fields
-    new_have   = addListToFM have (zip new_fields (repeat ()))
-
--------------
-getClassNames :: RdrNameClassDecl
-	      -> RnM_Info s (RnName, Bag RnName)	-- class and class ops
-
-getClassNames (ClassDecl _ cname _ sigs _ _ src_loc)
-  = newGlobalName src_loc Nothing False{-notval-} cname	`thenRn` \ class_name ->
-    getClassOpNames (Just (nameExportFlag class_name))
-				  sigs	`thenRn` \ op_names ->
-    returnRn (RnClass class_name op_names,
-	      listToBag (map (\ n -> RnClassOp n class_name) op_names))
-
----------------
-getClassOpNames :: Maybe ExportFlag
-		-> [RdrNameSig]
-		-> RnM_Info s [Name]
-
-getClassOpNames exp [] = returnRn []
-
-getClassOpNames exp (ClassOpSig op _ _ src_loc : sigs)
-  = newGlobalName src_loc exp True{-val-} op `thenRn` \ op_name ->
-    getClassOpNames exp sigs	 `thenRn` \ op_names ->
-    returnRn (op_name : op_names)
-getClassOpNames exp (_ : sigs)
-  = getClassOpNames exp sigs
+    set_name_prov name = setNameProvenance name provenance
+    provenance = Imported mod loc
 \end{code}
 
-*********************************************************
-*							*
-\subsection{Bindings}
-*							*
-*********************************************************
 
 \begin{code}
-getTopBindsNames :: RdrNameHsBinds
-		 -> RnM_Info s (Bag RnName)
-
-getTopBindsNames binds = doBinds binds
-
-doBinds EmptyBinds           = returnRn emptyBag
-doBinds (SingleBind bind)    = doBind bind
-doBinds (BindWith bind sigs) = doBind bind
-doBinds (ThenBinds binds1 binds2)
-  = andRn unionBags (doBinds binds1) (doBinds binds2)
-
-doBind EmptyBind          = returnRn emptyBag
-doBind (NonRecBind mbind) = doMBinds mbind
-doBind (RecBind mbind)    = doMBinds mbind
-
-doMBinds EmptyMonoBinds 			= returnRn emptyBag
-doMBinds (PatMonoBind pat grhss_and_binds locn) = doPat locn pat
-doMBinds (FunMonoBind p_name _ _ locn) 	        = doName locn p_name
-doMBinds (AndMonoBinds mbinds1 mbinds2)
-  = andRn unionBags (doMBinds mbinds1) (doMBinds mbinds2)
-
-doPats locn pats
-  = mapRn (doPat locn) pats	`thenRn` \ pats_s ->
-    returnRn (unionManyBags pats_s)
-
-doPat locn WildPatIn             = returnRn emptyBag
-doPat locn (LitPatIn _) 	 = returnRn emptyBag
-doPat locn (LazyPatIn pat)       = doPat locn pat
-doPat locn (VarPatIn var) 	 = doName locn var
-doPat locn (NegPatIn pat)	 = doPat locn pat
-doPat locn (ParPatIn pat)	 = doPat locn pat
-doPat locn (ListPatIn pats)      = doPats locn pats
-doPat locn (TuplePatIn pats)     = doPats locn pats
-doPat locn (ConPatIn name pats)  = doPats locn pats
-doPat locn (ConOpPatIn p1 op p2)
-  = andRn unionBags (doPat locn p1) (doPat locn p2)
-doPat locn (AsPatIn as_name pat)
-  = andRn unionBags (doName locn as_name) (doPat locn pat)
-doPat locn (RecPatIn name fields)
-  = mapRn (doField locn) fields `thenRn` \ fields_s ->
-    returnRn (unionManyBags fields_s)
-
-doField locn (_, pat, _) = doPat locn pat
-
-doName locn rdr
-  = newGlobalName locn Nothing True{-val-} rdr `thenRn` \ name ->
-    returnRn (unitBag (RnName name))
+importsFromLocalDecls rec_exp_fn (HsModule mod _ _ _ fix_decls decls _)
+  = foldlRn getLocalDeclBinders [] decls		`thenRn` \ avails ->
+    mapRn fixityFromFixDecl fix_decls			`thenRn` \ fixities ->
+    qualifyImports mod 
+		   False	-- Not qualified
+		   Nothing	-- No "as M" part
+		   (ExportEnv avails fixities)
+  where
+    newLocalName rdr_name loc
+      = newLocallyDefinedGlobalName mod (rdrNameOcc rdr_name) rec_exp_fn loc
+
+    getLocalDeclBinders avails (ValD binds)
+      = mapRn do_one (bagToList (collectTopBinders binds))	`thenRn` \ val_avails ->
+	returnRn (val_avails ++ avails)
+
+    getLocalDeclBinders avails decl
+      = getDeclBinders newLocalName decl	`thenRn` \ avail ->
+	returnRn (avail : avails)
+
+    do_one (rdr_name, loc)
+      = newLocalName rdr_name loc 	`thenRn` \ name ->
+        returnRn (Avail name [])
 \end{code}
 
-*********************************************************
-*							*
-\subsection{Creating a new global name}
-*							*
-*********************************************************
+%************************************************************************
+%*									*
+\subsection{Filtering imports}
+%*									*
+%************************************************************************
 
-\begin{code}
-newGlobalName :: SrcLoc
-	      -> Maybe ExportFlag
-	      -> Bool{-True<=>value name,False<=>tycon/class-}
-	      -> RdrName
-	      -> RnM_Info s Name
-
-newGlobalName locn maybe_exp is_val_name (Unqual name)
-  = getExtraRn		`thenRn` \ ((b_val_names,b_tc_names),b_keys,rec_exp_fn,rec_occ_fn) ->
-    getModuleRn  	`thenRn` \ mod ->
-    rnGetUnique 	`thenRn` \ u ->
-    let
-	orig = OrigName mod name
-
-	(uniq, is_toplev)
-	  = case (lookupFM b_keys orig) of
-	      Just (key,_) -> (key, True)
-	      Nothing	   -> if not opt_CompilingGhcInternals then (u,True) else -- really here just to save gratuitous lookup
-			      case (lookupFM (if is_val_name then b_val_names else b_tc_names) orig) of
-			        Nothing -> (u, True)
-				Just xx -> (uniqueOf xx, False{-builtin!-})
-
-	exp = case maybe_exp of
-	       Just flag -> flag
-	       Nothing   -> rec_exp_fn n
-
-	n = if is_toplev
-	    then mkTopLevName  uniq orig locn exp (rec_occ_fn n) -- NB: two "n"s
-	    else mkWiredInName uniq orig exp
-    in
-    returnRn n    
+@filterImports@ takes the @ExportEnv@ telling what the imported module makes
+available, and filters it through the import spec (if any).
 
-newGlobalName locn maybe_exp is_val_name rdr@(Qual mod name)
-  | opt_CompilingGhcInternals
-  -- we are actually defining something that compiler knows about (e.g., Bool)
+\begin{code}
+filterImports :: Module
+	      -> Maybe (Bool, [RdrNameIE])		-- Import spec; True => hidin
+	      -> [AvailInfo]				-- What's available
+	      -> RnMG [AvailInfo]			-- What's actually imported
+	-- Complains if import spec mentions things the
+	-- module doesn't export
 
-  = getExtraRn		`thenRn` \ ((b_val_names,b_tc_names),b_keys,rec_exp_fn,rec_occ_fn) ->
-    let
-	orig = OrigName mod name
-
-	(uniq, is_toplev)
-	  = case (lookupFM b_keys orig) of
-	      Just (key,_) -> (key, True)
-	      Nothing	   -> case (lookupFM (if is_val_name then b_val_names else b_tc_names) orig) of
-			        Nothing -> (panic "newGlobalName:Qual:uniq", True)
-				Just xx -> (uniqueOf xx, False{-builtin!-})
-
-	exp = case maybe_exp of
-	       Just flag -> flag
-	       Nothing   -> rec_exp_fn n
-
-	n = if is_toplev
-	    then mkTopLevName  uniq orig locn exp (rec_occ_fn n) -- NB: two "n"s
-	    else mkWiredInName uniq orig exp
-    in
-    returnRn n    
+filterImports mod Nothing imports
+  = returnRn imports
 
-  | otherwise
-  = addErrRn (qualNameErr "name in definition" (rdr, locn)) `thenRn_`
-    returnRn (panic "newGlobalName:Qual")
-\end{code}
+filterImports mod (Just (want_hiding, import_items)) avails
+  = 	-- Check that each import item mentions things that are actually available
+    mapRn check_import_item import_items	`thenRn_`
 
-*********************************************************
-*							*
-\subsection{Imported names}
-*							*
-*********************************************************
+	-- Return filtered environment; no need to filter fixities
+    returnRn (map new_avail avails)
 
-\begin{code}
-type ImportNameInfo
-  = (GlobalNameInfo,
-     FiniteMap OrigName RnName,		-- values imported so far
-     FiniteMap OrigName RnName,		-- tycons/classes imported so far
-     Name -> (ExportFlag, [SrcLoc]))	-- import flag and src locns;
-					-- NB: this last field is in a knot
-					-- and mustn't be tugged on!
-
-type RnM_IInfo s r = RnMonad ImportNameInfo s r
-
-------------------------------------------------------------------
-doImportDecls ::
-	   IfaceCache
-	-> GlobalNameInfo		-- builtin and knot name info
-	-> UniqSupply
-	-> [RdrNameImportDecl]		-- import declarations
-	-> IO (Bag (RdrName,RnName),	-- imported values in scope
-	       Bag (RdrName,RnName),	-- imported tycons/classes in scope
-	       [Module],		-- directly imported modules
-	       Bag (Module,RnName),	-- unqualified import from module
-	       Bag RenamedFixityDecl,	-- fixity info for imported names
-	       Bag Error,
-	       Bag Warning)
-
-doImportDecls iface_cache g_info us src_imps
-  = fixIO ( \ ~(_, _, _, _, _, _, rec_imp_stuff) ->
-	let
-	    rec_imp_fm = addListToUFM_C add_stuff emptyUFM (bagToList rec_imp_stuff)
-	    add_stuff (imp1,locns1) (imp2,locns2) = (lubExportFlag imp1 imp2, locns1 `unionBags` locns2)
-
-    	    rec_imp_fn :: Name -> (ExportFlag, [SrcLoc])
-	    rec_imp_fn n = case lookupUFM rec_imp_fm n of
-		             Nothing            -> (NotExported,[mkBuiltinSrcLoc])
-						   -- panic "RnNames:rec_imp_fn"
-						   -- but the panic can show up
-						   -- in error messages
-		             Just (flag, locns) -> (flag, bagToList locns)
-
-	    i_info = (g_info, emptyFM, emptyFM, rec_imp_fn)
-	in
-	-- cache the imported modules
-	-- this ensures that all directly imported modules
-	-- will have their original name iface in scope
-	-- pprTrace "doImportDecls:" (ppCat (map ppPStr imp_mods)) $
-	accumulate (map (cachedIface iface_cache False SLIT("doImportDecls")) imp_mods) >>
-
-	-- process the imports
-	doImports iface_cache i_info us all_imps
-
-    ) >>= \ (vals, tcs, unquals, fixes, errs, warns, _) ->
-
-    return (vals, tcs, imp_mods, unquals, fixes,
-	    imp_errs `unionBags` errs,
-	    imp_warns `unionBags` warns)
   where
-    all_imps = implicit_prel  ++ src_imps
---  all_imps = implicit_qprel ++ the_imps
+    import_fm :: FiniteMap OccName RdrNameIE
+    import_fm = listToFM [(ieOcc ie, ie) | ie <- import_items]
+
+    avail_fm :: FiniteMap OccName AvailInfo
+    avail_fm = listToFM [(nameOccName name, avail) | avail@(Avail name ns) <- avails]
+
+    new_avail NotAvailable = NotAvailable
+    new_avail avail@(Avail name _)
+	| not in_import_items && want_hiding     = avail
+	| not in_import_items && not want_hiding = NotAvailable
+	| in_import_items     && want_hiding     = NotAvailable
+	| in_import_items     && not want_hiding = filtered_avail
+	where
+	  maybe_import_item = lookupFM import_fm (nameOccName name)
+	  in_import_items   = maybeToBool maybe_import_item
+	  Just import_item  = maybe_import_item
+	  filtered_avail    = filterAvail import_item avail
+
+    check_import_item  :: RdrNameIE -> RnMG ()
+    check_import_item item
+      = checkRn (maybeToBool maybe_matching_avail && sub_names_ok item avail)
+	        (badImportItemErr mod item)
+     where
+       item_name            = ieOcc item
+       maybe_matching_avail = lookupFM avail_fm item_name
+       Just avail	    = maybe_matching_avail
+
+    sub_names_ok (IEVar _)  		_	      = True
+    sub_names_ok (IEThingAbs _)		_	      = True
+    sub_names_ok (IEThingAll _)		_	      = True
+    sub_names_ok (IEThingWith _ wanted) (Avail _ has) = all ((`elem` has_list) . rdrNameOcc) wanted
+						      where
+						        has_list = map nameOccName has
+    sub_names_ok other1			other2	      = False
+\end{code}
 
-    explicit_prelude_imp
-      = not (null [ () | (ImportDecl mod qual _ _ _) <- src_imps, mod == pRELUDE ])
 
-    implicit_prel | opt_NoImplicitPrelude = []
-		  | explicit_prelude_imp  = [ImportDecl pRELUDE True  Nothing Nothing prel_loc]
-		  | otherwise		  = [ImportDecl pRELUDE False Nothing Nothing prel_loc]
 
-    prel_loc = mkBuiltinSrcLoc
+%************************************************************************
+%*									*
+\subsection{Qualifiying imports}
+%*									*
+%************************************************************************
 
-    (uniq_imps, imp_dups) = removeDups cmp_mod all_imps
-    cmp_mod (ImportDecl m1 _ _ _ _) (ImportDecl m2 _ _ _ _) = cmpPString m1 m2
+@qualifyImports@ takes the @ExportEnv@ after filtering through the import spec
+of an import decl, and deals with producing an @RnEnv@ with the 
+right qaulified names.  It also turns the @Names@ in the @ExportEnv@ into
+fully fledged @Names@.
 
-    qprel_imps = [ imp | imp@(ImportDecl mod True Nothing _ _) <- src_imps,
-		 	 mod == pRELUDE ]
+\begin{code}
+qualifyImports :: Module				-- Improrted module
+	       -> Bool					-- True <=> qualified import
+	       -> Maybe Module				-- Optional "as M" part 
+	       -> ExportEnv				-- What's imported
+	       -> RnMG (RnEnv, ModuleAvails)
+
+qualifyImports this_mod qual as_mod (ExportEnv avails fixities)
+  = 	-- Make the qualified-name environments, checking of course for clashes
+    foldlRn add_name emptyNameEnv avails			`thenRn` \ name_env ->
+    foldlRn (add_fixity name_env) emptyFixityEnv fixities	`thenRn` \ fixity_env ->
+
+	-- Deal with the "qualified" part; if not qualifies then add unqualfied bindings
+    if qual then
+	returnRn (RnEnv name_env fixity_env, mod_avail_env)
+    else
+	returnRn (RnEnv (unQualify name_env) (unQualify fixity_env), mod_avail_env)
 
-    qual_mods = [ (qual_name mod as_mod, imp) | imp@(ImportDecl mod True as_mod _ _) <- src_imps ]
-    qual_name mod (Just as_mod) = as_mod
-    qual_name mod Nothing       = mod
+  where
+    mod_avail_env  = unitFM this_mod avails
+
+    add_name name_env NotAvailable = returnRn name_env
+    add_name name_env (Avail n ns) = foldlRn add_one name_env (n : ns)
+
+    add_one :: NameEnv -> Name -> RnMG NameEnv
+    add_one env name = addOneToNameEnvRn env (Qual this_mod occ_name) name
+		     where
+			occ_name = nameOccName name
+
+    add_fixity name_env fixity_env (occ_name, fixity, provenance)
+	| maybeToBool (lookupFM name_env qual_name)	-- The name is imported
+	= addOneToFixityEnvRn fixity_env qual_name (fixity,provenance)
+	| otherwise				-- It ain't imported
+	= returnRn fixity_env
+	where
+	  qual_name = Qual this_mod occ_name
+\end{code}
 
-    (_, qual_dups) = removeDups cmp_qual qual_mods
-    bad_qual_dups = filter (not . all_same_mod) qual_dups
+unQualify adds an Unqual binding for every existing Qual binding.
 
-    cmp_qual (q1,_) (q2,_) = cmpPString q1 q2
-    all_same_mod ((q,ImportDecl mod _ _ _ _):rest)
-      = all has_same_mod rest
-      where
-	has_same_mod (_,ImportDecl mod2 _ _ _ _) = mod == mod2
+\begin{code}
+unQualify :: FiniteMap RdrName elt -> FiniteMap RdrName elt
+unQualify fm = addListToFM fm [(Unqual occ, elt) | (Qual _ occ, elt) <- fmToList fm]
+\end{code}
 
-    imp_mods  = [ mod | ImportDecl mod _ _ _ _ <- uniq_imps ]
+%************************************************************************
+%*									*
+\subsection{Local declarations}
+%*									*
+%************************************************************************
 
-    imp_warns = listToBag (map dupImportWarn imp_dups)
-    		`unionBags`
-		listToBag (map qualPreludeImportWarn qprel_imps)
 
-    imp_errs  = listToBag (map dupQualImportErr bad_qual_dups)
+\begin{code}
+fixityFromFixDecl :: RdrNameFixityDecl -> RnMG (OccName, Fixity, Provenance)
 
------------------------
-doImports :: IfaceCache
-	  -> ImportNameInfo
-	  -> UniqSupply
-	  -> [RdrNameImportDecl]	-- import declarations
-	  -> IO (Bag (RdrName,RnName),	-- imported values in scope
-		 Bag (RdrName,RnName),	-- imported tycons/classes in scope
-		 Bag (Module, RnName),	-- unqualified import from module
-		 Bag RenamedFixityDecl,	-- fixity info for imported names
-		 Bag Error,
-		 Bag Warning,
-		Bag (RnName,(ExportFlag,Bag SrcLoc))) -- import flags and src locs
+fixityFromFixDecl (FixityDecl rdr_name fixity loc)
+  = returnRn (rdrNameOcc rdr_name, fixity, LocalDef (panic "export-flag") loc)
+\end{code}
 
-doImports iface_cache i_info us []
-  = return (emptyBag, emptyBag, emptyBag, emptyBag, emptyBag, emptyBag, emptyBag)
 
-doImports iface_cache i_info@(g_info,done_vals,done_tcs,rec_imp_fn) us (imp:imps)
-  = let
-	(us1, us2) = splitUniqSupply us
-    in
-    doImport iface_cache i_info us1 imp
-	>>= \ (vals1, tcs1, unquals1, fixes1, errs1, warns1, imps1) ->
-    let
-	ext_vals = foldl add_new_one done_vals (bagToList vals1)
-	ext_tcs  = foldl add_new_one done_tcs  (bagToList tcs1) 
-    in
-    doImports iface_cache (g_info,ext_vals,ext_tcs,rec_imp_fn) us2 imps
-	>>= \ (vals2, tcs2, unquals2, fixes2, errs2, warns2, imps2) ->
-    return (vals1    `unionBags` vals2,
-	    tcs1     `unionBags` tcs2,
-	    unquals1 `unionBags` unquals2,
-	    fixes1   `unionBags` fixes2,
-	    errs1    `unionBags` errs2,
-	    warns1   `unionBags` warns2,
-	    imps1    `unionBags` imps2)
-  where
-    add_new_one :: FiniteMap OrigName RnName -- ones done so far
-		-> (dont_care, RnName)
-		-> FiniteMap OrigName RnName -- extended
-
-    add_new_one fm (_, rn)
-      = let
-	    orig = origName "add_new_one" rn
-	in
-	case (lookupFM fm orig) of
-	  Just  _ -> fm -- already there: no change
-	  Nothing -> addToFM fm orig rn
-
-----------------------
-doImport :: IfaceCache
-	 -> ImportNameInfo
-	 -> UniqSupply
-	 -> RdrNameImportDecl
-	 -> IO (Bag (RdrName,RnName),			-- values
-		Bag (RdrName,RnName),			-- tycons/classes
-		Bag (Module,RnName),			-- unqual imports
-		Bag RenamedFixityDecl,
-                Bag Error,
-		Bag Warning,
-		Bag (RnName,(ExportFlag,Bag SrcLoc)))	-- import flags and src locs
-
-doImport iface_cache info us (ImportDecl mod qual maybe_as maybe_spec src_loc)
-  = --let
-    --	(b_vals, b_tcs, maybe_spec')
-    --	   = (emptyBag, emptyBag, maybe_spec)
-    --in
-    --pprTrace "doImport:" (ppPStr mod) $
-    cachedIface iface_cache False SLIT("doImport") mod >>= \ maybe_iface ->
-    return (maybe_iface, \ iface -> getOrigIEs iface maybe_spec)
-	    >>= \ (maybe_iface, do_ies) ->
-
-    case maybe_iface of
-      Failed err ->
-	return (emptyBag, emptyBag, emptyBag, emptyBag,
-		unitBag err, emptyBag, emptyBag)
-      Succeeded iface -> 
-        let
-	    (ies, chk_ies, get_errs) = do_ies iface
-	in
-	doOrigIEs iface_cache info mod src_loc us ies 
-		>>= \ (ie_vals, ie_tcs, imp_flags, errs, warns) ->
-	accumulate (map (checkOrigIE iface_cache) chk_ies)
-		>>= \ chk_errs_warns ->
-	let
-	    fold_ies   = foldBag unionBags pair_occ emptyBag
-
-	    final_vals = {-OLD:mapBag fst_occ b_vals `unionBags`-} fold_ies ie_vals
-	    final_tcs  = {-OLD:mapBag fst_occ b_tcs  `unionBags`-} fold_ies ie_tcs
-	    final_vals_list = bagToList final_vals
-	in
-	accumulate (map (getFixityDecl iface_cache . snd) final_vals_list)
-			>>= \ fix_maybes_errs ->
-	let
-	    (chk_errs, chk_warns)  = unzip chk_errs_warns
-	    (fix_maybes, fix_errs) = unzip fix_maybes_errs
-
-	    unquals    = if qual{-ified import-}
-			 then emptyBag
-		         else mapBag pair_as (ie_vals `unionBags` ie_tcs)
-
-	    final_fixes = listToBag (catMaybes fix_maybes)
-
-	    final_errs  = mapBag (\ err -> err mod src_loc) (unionManyBags (get_errs:chk_errs))
-		          `unionBags` errs `unionBags` unionManyBags fix_errs
-	    final_warns = mapBag (\ warn -> warn mod src_loc) (unionManyBags chk_warns)
-		          `unionBags` warns
-	    imp_stuff   = mapBag (\ (n,imp) -> (n,(imp,unitBag src_loc))) imp_flags
-        in
-	return (final_vals, final_tcs, unquals, final_fixes,
-		final_errs, final_warns, imp_stuff)
-  where
-    as_mod :: Module
-    as_mod = case maybe_as of {Nothing -> mod; Just as_this -> as_this}
-
-    mk_occ :: FAST_STRING -> RdrName
-    mk_occ str = if qual then Qual as_mod str else Unqual str
-
-    fst_occ :: (FAST_STRING, RnName) -> (RdrName, RnName)
-    fst_occ (str, rn) = (mk_occ str, rn)
-
-    pair_occ :: RnName -> Bag (RdrName, RnName)
-    pair_occ rn
-      = let
-	    str      = getLocalName rn
-	    qual_bag = unitBag (Qual as_mod str, rn)
-	in
-	if qual
-	then qual_bag
-	else qual_bag -- the qualified name is *also* visible
-	    `snocBag` (Unqual str, rn)
-	    
-
-    pair_as :: RnName -> (Module, RnName)
-    pair_as  rn = (as_mod, rn)
-
------------------------------
-{-
-getBuiltins :: ImportNameInfo
-	    -> Module
-	    -> Maybe (Bool, [RdrNameIE])
-	    -> (Bag (FAST_STRING, RnName),
-		Bag (FAST_STRING, RnName),
-		Maybe (Bool, [RdrNameIE])  -- return IEs that had no effect
-	       )
-
-getBuiltins _ modname maybe_spec
--- | modname `notElem` modulesWithBuiltins
-  = (emptyBag, emptyBag, maybe_spec)
-
-getBuiltins (((b_val_names,b_tc_names),_,_,_),_,_,_) modname maybe_spec
-  = case maybe_spec of 
-      Nothing           -> (all_vals, all_tcs, Nothing)
-
-      Just (True, ies)  -> -- hiding does not work for builtin names
-			   trace "NOTE: `import Prelude hiding ...' does not hide built-in names" $
-			   (all_vals, all_tcs, maybe_spec)
-
-      Just (False, ies) -> let 
-			      (vals,tcs,ies_left) = do_builtin ies
-			   in
-		  	   (vals, tcs, Just (False, ies_left))
-  where
-    all_vals = do_all_builtin (fmToList b_val_names)
-    all_tcs  = do_all_builtin (fmToList b_tc_names)
-
-    do_all_builtin [] = emptyBag
-    do_all_builtin (((OrigName mod str),rn):rest)
-      = --pprTrace "do_all_builtin:" (ppCat [ppPStr modname, ppPStr mod, ppPStr str]) $
-	(if mod == modname then consBag (str, rn) else id) (do_all_builtin rest)
-
-    do_builtin [] = (emptyBag,emptyBag,[]) 
-    do_builtin (ie:ies)
-      = let
-	    (str, orig)
-	      = case (ie_name ie) of
-		  Unqual s -> (s, OrigName modname s)
-		  Qual m s -> --pprTrace "do_builtin:surprising qual!" (ppCat [ppPStr m, ppPStr s]) $
-			      (s, OrigName modname s)
-	in
-	case (lookupFM b_tc_names orig) of 	-- NB: we favour the tycon/class FM...
-	  Just rn -> case (ie,rn) of
-	     (IEThingAbs _, WiredInTyCon tc)
-		-> (vals, (str, rn) `consBag` tcs, ies_left)
-	     (IEThingAll _, WiredInTyCon tc)
-		-> (listToBag (map (\ id -> (getLocalName id, WiredInId id)) 
-				   (tyConDataCons tc))
-		    `unionBags` vals,
-		    (str,rn) `consBag` tcs, ies_left)
-	     (IEThingWith _ _, WiredInTyCon tc)	-- No checking of With...
-		-> (listToBag (map (\ id -> (nameOf (origName "IEThingWith" id), WiredInId id)) 
-				   (tyConDataCons tc))
-		    `unionBags` vals,
-		    (str,rn) `consBag` tcs, ies_left)
-	     _ -> panic "importing builtin names (1)"
-
-	  Nothing ->
-	    case (lookupFM b_val_names orig) of
-	      Nothing -> (vals, tcs, ie:ies_left)
-	      Just rn -> case (ie,rn) of
-		 (IEVar _, WiredInId _)        
-		    -> ((str, rn) `consBag` vals, tcs, ies_left)
-		 _ -> panic "importing builtin names (2)"
-      where
-        (vals, tcs, ies_left) = do_builtin ies
--}
-
--------------------------
-getOrigIEs :: ParsedIface
-	   -> Maybe (Bool, [RdrNameIE]) -- "hiding" or not, blah, blah, blah
-	   -> ([IE OrigName],
-	       [(IE OrigName, ExportFlag)],
-	       Bag (Module -> SrcLoc -> Error))
-
-getOrigIEs (ParsedIface _ _ _ _ _ _ exps _ _ _ _ _ _) Nothing			-- import all
-  = (map mkAllIE (eltsFM exps), [], emptyBag)
-
-getOrigIEs (ParsedIface _ _ _ _ _ _ exps _ _ _ _ _ _) (Just (True, ies))	-- import hiding
-  = (map mkAllIE (eltsFM exps_left), found_ies, errs)
-  where
-    (found_ies, errs) = lookupIEs exps ies
-    exps_left = delListFromFM exps (map (getLocalName.ie_name.fst) found_ies)
+%************************************************************************
+%*									*
+\subsection{Export list processing
+%*									*
+%************************************************************************
 
-getOrigIEs (ParsedIface _ _ _ _ _ _ exps _ _ _ _ _ _) (Just (False, ies))	-- import these
-  = (map fst found_ies, found_ies, errs)
-  where
-    (found_ies, errs) = lookupIEs exps ies
-
-------------------------------------------------
-mkAllIE :: (OrigName, ExportFlag) -> IE OrigName
-
-mkAllIE (orig,ExportAbs)
-  = --ASSERT(isLexCon (nameOf orig))
-    -- the ASSERT is correct, but it is too easy to
-    -- trigger when writing .hi files by hand (e.g.
-    -- when hackily breaking a module loop)
-    IEThingAbs orig
-mkAllIE (orig, ExportAll)
-  | isLexCon name_orig || isLexSpecialSym name_orig
-  = IEThingAll orig
-  | otherwise
-  = IEVar orig
-  where
-    name_orig = nameOf orig
+The @AvailEnv@ type is just used internally in @exportsFromAvail@.
+When exporting we need to combine the availabilities for a particular
+exported thing, and we also need to check for name clashes -- that
+is: two exported things must have different @OccNames@.
 
-------------
-lookupIEs :: ExportsMap
-	  -> [RdrNameIE]
-	  -> ([(IE OrigName, ExportFlag)], -- IEs we found, orig-ified
-	      Bag (Module -> SrcLoc -> Error))
+\begin{code}
+type AvailEnv = FiniteMap OccName (RdrNameIE, AvailInfo)
+	-- The FM maps each OccName to the RdrNameIE that gave rise to it,
+	-- for error reporting, as well as to its AvailInfo
 
-lookupIEs exps ies
-  = foldr go ([], emptyBag) ies
-  where
-    go ie (already, errs)
-      = let
-	    str = case (ie_name ie) of
-		    Unqual s -> s
-		    Qual m s -> s
-	in
-	case (lookupFM exps str) of
-	  Nothing ->
-	    (already, unknownImpSpecErr ie `consBag` errs)
-	  Just (orig, flag) ->
-	    ((orig_ie orig ie, flag) : already,
-	     adderr_if (seen_ie orig already) (duplicateImpSpecErr ie) errs)
-
-    orig_ie orig (IEVar n)          = IEVar       orig
-    orig_ie orig (IEThingAbs n)     = IEThingAbs  orig
-    orig_ie orig (IEThingAll n)     = IEThingAll  orig
-    orig_ie orig (IEThingWith n ns) = IEThingWith orig (map re_orig ns)
-      where
-	(OrigName mod _) = orig
-	re_orig (Unqual s) = OrigName mod s
-
-    seen_ie orig seen_ies = any (\ (ie,_) -> orig == ie_name ie) seen_ies
-
---------------------------------------------
-doOrigIEs iface_cache info mod src_loc us []
-  = return (emptyBag,emptyBag,emptyBag,emptyBag,emptyBag)
-
-doOrigIEs iface_cache info mod src_loc us (ie:ies)
-  = let
-	(us1, us2) = splitUniqSupply us
-    in
-    doOrigIE iface_cache info mod src_loc us1 ie 
-	>>= \ (vals1, tcs1, imps1, errs1, warns1) ->
-    doOrigIEs iface_cache info mod src_loc us2 ies
-	>>= \ (vals2, tcs2, imps2, errs2, warns2) ->
-    return (vals1    `unionBags` vals2,
-	    tcs1     `unionBags` tcs2,
-	    imps1    `unionBags` imps2,
-	    errs1    `unionBags` errs2,
-	    warns1   `unionBags` warns2)
-
-----------------------
-doOrigIE :: IfaceCache
-	 -> ImportNameInfo
-	 -> Module
-	 -> SrcLoc
-	 -> UniqSupply
-	 -> IE OrigName
-	 -> IO (Bag RnName,			-- values
-		Bag RnName,			-- tycons/classes
-		Bag (RnName,ExportFlag),	-- import flags
-		Bag Error,
-		Bag Warning)
-
-doOrigIE iface_cache info mod src_loc us ie
-  = with_decl iface_cache (ie_name ie)
-	avoided_fn
-	(\ err  -> (emptyBag, emptyBag, emptyBag, unitBag err, emptyBag))
-	(\ decl -> case initRn True mod emptyRnEnv us
-		    	       (setExtraRn info $
-		     	    	pushSrcLocRn src_loc $
-		     		getIfaceDeclNames ie decl)
-		   of
-		   ((vals, tcs, imps), errs, warns) -> (vals, tcs, imps, errs, warns))
-  where
-    avoided_fn Nothing -- the thing should be in the source
-      = (emptyBag, emptyBag, emptyBag, emptyBag, emptyBag)
-    avoided_fn (Just (Left  rn@(WiredInId _))) -- a builtin value brought into scope
-      = (unitBag rn, emptyBag, emptyBag, emptyBag, emptyBag)
-    avoided_fn (Just (Right rn@(WiredInTyCon tc)))
-	-- a builtin tc brought into scope; we also must bring its
-	-- data constructors into scope
-      = --pprTrace "avoided:Right:" (ppr PprDebug rn) $
-	(listToBag [WiredInId dc | dc <- tyConDataCons tc], unitBag rn, emptyBag, emptyBag, emptyBag)
-
--------------------------
-checkOrigIE :: IfaceCache
-	    -> (IE OrigName, ExportFlag)
-	    -> IO (Bag (Module -> SrcLoc -> Error), Bag (Module -> SrcLoc -> Warning))
-
-checkOrigIE iface_cache (IEThingAll n, ExportAbs)
-  = with_decl iface_cache n
-	(\ _    -> (emptyBag, emptyBag))
-	(\ err  -> (unitBag (\ mod locn -> err), emptyBag))
-	(\ decl -> case decl of
-		TypeSig _ _ _ -> (emptyBag, unitBag (allWhenSynImpSpecWarn n))
-		other	      -> (unitBag (allWhenAbsImpSpecErr n), emptyBag))
-
-checkOrigIE iface_cache (IEThingWith n ns, ExportAbs)
-  = return (unitBag (withWhenAbsImpSpecErr n), emptyBag)
-
-checkOrigIE iface_cache (IEThingWith n ns, ExportAll)
-  = with_decl iface_cache n
-	(\ _    -> (emptyBag, emptyBag))
-	(\ err  -> (unitBag (\ mod locn -> err), emptyBag))
-	(\ decl -> case decl of
-	     	NewTypeSig _ con _ _         -> (check_with "constructors" [con] ns, emptyBag)
-	     	DataSig    _ cons fields _ _ -> (check_with "constructors (and fields)" (cons++fields) ns, emptyBag)
-             	ClassSig   _ ops _ _         -> (check_with "class ops"   ops   ns, emptyBag))
-  where
-    check_with str has origs
-      | sortLt (<) (map getLocalName has) == sortLt (<) (map nameOf origs)
-      = emptyBag
-      | otherwise
-      = unitBag (withImpSpecErr str n has origs)
-
-checkOrigIE iface_cache other
-  = return (emptyBag, emptyBag)
-
------------------------
-with_decl :: IfaceCache
-	  -> OrigName
-	  -> (Maybe (Either RnName RnName) -> something) -- if avoided..
-	  -> (Error        -> something)		 -- if an error...
-	  -> (RdrIfaceDecl -> something)		 -- if OK...
-	  -> IO something
-
-with_decl iface_cache n do_avoid do_err do_decl
-  = cachedDecl iface_cache (isLexCon n_name || isLexSpecialSym n_name) n   >>= \ maybe_decl ->
-    case maybe_decl of
-      CachingAvoided info -> return (do_avoid info)
-      CachingFail    err  -> return (do_err   err)
-      CachingHit     decl -> return (do_decl  decl)
-  where
-    n_name = nameOf n
+emptyAvailEnv = emptyFM
 
--------------
-getFixityDecl :: IfaceCache
-	      -> RnName
-	      -> IO (Maybe RenamedFixityDecl, Bag Error)
+unitAvailEnv :: RdrNameIE -> AvailInfo -> AvailEnv
+unitAvailEnv ie NotAvailable
+  = emptyFM
+unitAvailEnv ie avail@(Avail n ns)
+  = unitFM (nameOccName n) (ie,avail)
 
-getFixityDecl iface_cache rn
-  = let
-	(OrigName mod str) = origName "getFixityDecl" rn
+plusAvailEnv a1 a2
+  = mapRn (addErrRn.availClashErr) (conflictsFM bad_avail a1 a2)	`thenRn_`
+    returnRn (plusFM_C plus_avail a1 a2)
 
-	succeeded infx i = return (Just (infx rn i), emptyBag)
-    in
-    cachedIface iface_cache True str mod >>= \ maybe_iface ->
-    case maybe_iface of
-      Failed err ->
-	return (Nothing, unitBag err)
-      Succeeded (ParsedIface _ _ _ _ _ _ _ _ fixes _ _ _ _) ->
-	case lookupFM fixes str of
-	  Nothing 	    -> return (Nothing, emptyBag)
-	  Just (InfixL _ i) -> succeeded InfixL i
-	  Just (InfixR _ i) -> succeeded InfixR i
-	  Just (InfixN _ i) -> succeeded InfixN i
-
-ie_name (IEVar n)         = n
-ie_name (IEThingAbs n)    = n
-ie_name (IEThingAll n)    = n
-ie_name (IEThingWith n _) = n
-
-adderr_if True  err errs = err `consBag` errs
-adderr_if False err errs = errs
+listToAvailEnv :: RdrNameIE -> [AvailInfo] -> RnM s d AvailEnv
+listToAvailEnv ie items
+  = foldlRn plusAvailEnv emptyAvailEnv (map (unitAvailEnv ie) items)
+
+bad_avail  (ie1,Avail n1 _) (ie2,Avail n2 _) = n1 /= n2	-- Same OccName, different Name
+plus_avail (ie1,a1) (ie2,a2) = (ie1, a1 `plusAvail` a2)
 \end{code}
 
-*********************************************************
-*							*
-\subsection{Actually creating the imported names}
-*							*
-*********************************************************
 
 \begin{code}
-getIfaceDeclNames :: IE OrigName -> RdrIfaceDecl
-		  -> RnM_IInfo s (Bag RnName,			-- values
-				  Bag RnName,			-- tycons/classes
-			 	  Bag (RnName,ExportFlag))	-- import flags
-
-getIfaceDeclNames ie (ValSig val src_loc _)
-  = newImportedName False src_loc Nothing Nothing val 	`thenRn` \ val_name ->
-    returnRn (unitBag (RnName val_name),
-	      emptyBag,
-	      unitBag (RnName val_name, ExportAll))
-
-getIfaceDeclNames ie (TypeSig tycon src_loc _)
-  = newImportedName True src_loc Nothing Nothing tycon  `thenRn` \ tycon_name ->
-    returnRn (emptyBag,
-	      unitBag (RnSyn tycon_name),
-	      unitBag (RnSyn tycon_name, ExportAll))
-
-getIfaceDeclNames ie (NewTypeSig tycon con src_loc _)
-  = newImportedName True src_loc Nothing Nothing tycon  `thenRn` \ tycon_name ->
-    newImportedName False src_loc (Just (nameExportFlag tycon_name))
-				  (Just (nameImportFlag tycon_name))
-			       	  con 			`thenRn` \ con_name ->
-    returnRn (if imp_all (imp_flag ie) then
-		  unitBag (RnConstr con_name tycon_name)
-	      else
-		  emptyBag,
-	      unitBag (RnData tycon_name [con_name] []),
-	      unitBag (RnData tycon_name [con_name] [], imp_flag ie))
-
-getIfaceDeclNames ie (DataSig tycon cons fields src_loc _)
-  = newImportedName True src_loc Nothing Nothing tycon `thenRn` \ tycon_name ->
-    let
-	map_me = mapRn (newImportedName False src_loc
-				(Just (nameExportFlag tycon_name))
-				(Just (nameImportFlag tycon_name)))
-    in
-    map_me cons	    `thenRn` \ con_names ->
-    map_me fields   `thenRn` \ field_names ->
+exportsFromAvail :: Module
+		 -> Maybe [RdrNameIE]	-- Export spec
+		 -> ModuleAvails
+		 -> RnEnv
+		 -> RnMG (Name -> ExportFlag, ExportEnv)
+	-- Complains if two distinct exports have same OccName
+	-- Complains about exports items not in scope
+exportsFromAvail this_mod Nothing all_avails rn_env
+  = exportsFromAvail this_mod (Just [IEModuleContents this_mod]) all_avails rn_env
+
+exportsFromAvail this_mod (Just export_items) all_avails (RnEnv name_env fixity_env)
+  = mapRn exports_from_item export_items 		`thenRn` \ avail_envs ->
+    foldlRn plusAvailEnv emptyAvailEnv avail_envs	`thenRn` \ export_avail_env -> 
     let
-	rn_tycon   = RnData tycon_name con_names field_names
-        rn_constrs = [ RnConstr name tycon_name | name <- con_names ]
-	rn_fields  = [ RnField name tycon_name | name <- field_names ]
+	export_avails   = map snd (eltsFM export_avail_env)
+	export_fixities = mk_exported_fixities (availsToNameSet export_avails)
+	export_fn	= mk_export_fn export_avails
     in
-    returnRn (if imp_all (imp_flag ie) then
-		  listToBag rn_constrs `unionBags` listToBag rn_fields
-	      else
-		  emptyBag,
-	      unitBag rn_tycon,
-	      unitBag (rn_tycon, imp_flag ie))
-
-getIfaceDeclNames ie (ClassSig cls ops src_loc _)
-  = newImportedName True src_loc Nothing Nothing cls `thenRn` \ cls_name ->
-    mapRn (newImportedName False src_loc (Just (nameExportFlag cls_name))
-				         (Just (nameImportFlag cls_name)))
-			         	    ops `thenRn` \ op_names ->
-    returnRn (if imp_all (imp_flag ie) then
-		  listToBag (map (\ n -> RnClassOp n cls_name) op_names)
-	      else
-		  emptyBag,
-	      unitBag (RnClass cls_name op_names),
-	      unitBag (RnClass cls_name op_names, imp_flag ie))
-
-
-imp_all ExportAll = True
-imp_all _         = False
-
-imp_flag (IEThingAbs _)    = ExportAbs
-imp_flag (IEThingAll _)    = ExportAll
-imp_flag (IEThingWith _ _) = ExportAll
-\end{code}
+    returnRn (export_fn, ExportEnv export_avails export_fixities)
 
-*********************************************************
-*							*
-\subsection{Creating a new imported name}
-*							*
-*********************************************************
+  where
+    full_avail_env :: UniqFM AvailInfo
+    full_avail_env = addListToUFM_C plusAvail emptyUFM
+			   [(name,avail) | avail@(Avail name _) <- concat (eltsFM all_avails)]
+	-- NB: full_avail_env won't contain bindings for data constructors and class ops,
+	-- which is right and proper; attempts to export them on their own will provoke an error
+
+    exports_from_item :: RdrNameIE -> RnMG AvailEnv
+    exports_from_item ie@(IEModuleContents mod)
+	= case lookupFM all_avails mod of
+		Nothing	    -> failWithRn emptyAvailEnv (modExportErr mod)
+		Just avails -> addOccurrenceNames Compulsory [n | Avail n _ <- avails]	`thenRn_`
+			       listToAvailEnv ie avails
+
+    exports_from_item ie
+	| not (maybeToBool maybe_in_scope) 
+	= failWithRn emptyAvailEnv (unknownNameErr (ieName ie))
+
+#ifdef DEBUG
+	-- I can't see why this should ever happen; if the thing is in scope
+	-- at all it ought to have some availability
+	| not (maybeToBool maybe_avail)
+	= pprTrace "exportsFromAvail: curious Nothing:" (ppr PprDebug name)
+	  returnRn emptyAvailEnv
+#endif
+
+	| not enough_avail
+	= failWithRn emptyAvailEnv (exportItemErr ie export_avail)
+
+	| otherwise	-- Phew!  It's OK!
+	= addOccurrenceName Compulsory name	`thenRn_`
+	  returnRn (unitAvailEnv ie export_avail)
+       where
+          maybe_in_scope  = lookupNameEnv name_env (ieName ie)
+	  Just name	  = maybe_in_scope
+	  maybe_avail     = lookupUFM full_avail_env name
+	  Just avail      = maybe_avail
+ 	  export_avail    = filterAvail ie avail
+	  enough_avail	  = case export_avail of {NotAvailable -> False; other -> True}
+
+	-- We export a fixity iff we export a thing with the same (qualified) RdrName
+    mk_exported_fixities :: NameSet -> [(OccName, Fixity, Provenance)]
+    mk_exported_fixities exports
+	= [ (rdrNameOcc rdr_name, fixity, prov)
+	  | (rdr_name, (fixity, prov)) <- fmToList fixity_env,
+	     export_fixity name_env exports rdr_name
+ 	  ]
+
+mk_export_fn :: [AvailInfo] -> (Name -> ExportFlag)
+mk_export_fn avails
+  = \name -> if name `elemNameSet` exported_names
+	     then Exported
+	     else NotExported
+  where
+    exported_names :: NameSet
+    exported_names = availsToNameSet avails
+
+export_fixity :: NameEnv -> NameSet -> RdrName -> Bool
+export_fixity name_env exports (Unqual _)
+  = False	-- The qualified fixity is always there as well
+export_fixity name_env exports rdr_name@(Qual _ occ)
+  = case lookupFM name_env rdr_name of
+	Just fixity_name -> fixity_name `elemNameSet` exports
+				-- Check whether the exported thing is
+				-- the one to which the fixity attaches
+	other   -> False	-- Not even in scope
+\end{code}				  
+
+
+%************************************************************************
+%*									*
+\subsection{Errors}
+%*									*
+%************************************************************************
 
 \begin{code}
-newImportedName :: Bool			-- True => tycon or class
-		-> SrcLoc
-		-> Maybe ExportFlag	-- maybe export flag
-		-> Maybe ExportFlag	-- maybe import flag
-	        -> RdrName		-- orig name
-		-> RnM_IInfo s Name
-
-newImportedName tycon_or_class locn maybe_exp maybe_imp rdr
-  = let
-	orig = qualToOrigName rdr
-    in
-    getExtraRn `thenRn` \ ((_,b_keys,rec_exp_fn,rec_occ_fn),done_vals,done_tcs,rec_imp_fn) ->
-    case ((if tycon_or_class
-	   then lookupFM done_tcs
-	   else lookupFM done_vals) orig) of
-
-      Just rn -> returnRn (getName rn)
-      Nothing -> 
-	rnGetUnique	`thenRn` \ u ->
-	let 
-	    uniq = case lookupFM b_keys orig of
-		     Nothing	  -> u
-		     Just (key,_) -> key
-
-	    exp  = case maybe_exp of
-	    	     Just xx -> xx
-	       	     Nothing -> rec_exp_fn n
-
-	    imp  = case maybe_imp of
-	    	     Just xx -> xx
-	       	     Nothing -> imp_flag
-
-	    (imp_flag, imp_locs) = rec_imp_fn n
-
-	    n = mkImportedName uniq orig imp locn imp_locs exp (rec_occ_fn n) -- NB: two "n"s
-	in
-	returnRn n
-\end{code}
+ieOcc ie = rdrNameOcc (ieName ie)
 
-\begin{code}
-globalDupNamesErr rdr rns sty
-  = ppAboves (message : map pp_dup rns)
-  where
-    message   = ppBesides [ppStr "multiple declarations of `", pprNonSym sty rdr, ppStr "'"]
-
-    pp_dup rn = addShortErrLocLine (get_loc 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 "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 = addShortWarnLocLine locn1 (\ sty ->
-	    ppCat [ppStr "multiple imports from module", ppPStr m1]) sty
+badImportItemErr mod ie sty
+  = ppSep [ppStr "Module", pprModule sty mod, ppStr "does not export", ppr sty ie]
 
-    dup_item (ImportDecl m _ _ _ locn)
-          = addShortWarnLocLine locn (\ sty ->
-            ppCat [ppStr "here was another import from module", ppPStr m]) sty
+modExportErr mod sty
+  = ppCat [ ppStr "Unknown module in export list: module", ppPStr mod]
 
-qualPreludeImportWarn (ImportDecl m _ _ _ locn)
-  = addShortWarnLocLine locn (\ sty ->
-    ppCat [ppStr "qualified import of prelude module", ppPStr m])
+exportItemErr export_item NotAvailable sty
+  = ppSep [ ppStr "Export item not in scope:", ppr sty export_item ]
 
-dupQualImportErr ((q1,ImportDecl _ _ _ _ locn1):dup_quals) sty
-  = ppAboves (item1 : map dup_item dup_quals)
-  where
-    item1 = addShortErrLocLine locn1 (\ sty ->
-	    ppCat [ppStr "multiple imports (from different modules) with same qualified name", ppPStr q1]) sty
-
-    dup_item (q,ImportDecl _ _ _ _ locn)
-          = addShortErrLocLine locn (\ sty ->
-            ppCat [ppStr "here was another import with qualified name", ppPStr q]) sty
-
-unknownImpSpecErr ie imp_mod locn
-  = addShortErrLocLine locn (\ sty ->
-    ppBesides [ppStr "module ", ppPStr imp_mod, ppStr " does not export `", ppr sty (ie_name ie), ppStr "'"])
-
-duplicateImpSpecErr ie imp_mod locn
-  = addShortErrLocLine locn (\ sty ->
-    ppBesides [ppStr "`", ppr sty (ie_name ie), ppStr "' already seen in import list"])
-
-allWhenSynImpSpecWarn n imp_mod locn
-  = addShortWarnLocLine locn (\ sty ->
-    ppBesides [ppStr "type synonym `", ppr sty n, ppStr "' should not be imported with (..)"])
-
-allWhenAbsImpSpecErr n imp_mod locn
-  = addShortErrLocLine locn (\ sty ->
-    ppBesides [ppStr "module ", ppPStr imp_mod, ppStr " only exports `", ppr sty n, ppStr "' abstractly"])
-
-withWhenAbsImpSpecErr n imp_mod locn
-  = addShortErrLocLine locn (\ sty ->
-    ppBesides [ppStr "module ", ppPStr imp_mod, ppStr " only exports `", ppr sty n, ppStr "' abstractly"])
-
-withImpSpecErr str n has ns imp_mod locn
-  = addErrLoc locn "" (\ sty ->
-    ppAboves [ ppBesides [ppStr "inconsistent list of", ppStr str, ppStr "in import list for `", ppr sty n, ppStr "'"],
-	       ppCat [ppStr "    expected:", ppInterleave ppComma (map (ppr sty) has)],
-	       ppCat [ppStr "    found:   ", ppInterleave ppComma (map (ppr sty) ns)] ])
-
-dupFieldErr con locn (dup:rest)
-  = addShortErrLocLine locn (\ sty ->
-    ppBesides [ppStr "record field `", ppr sty dup, ppStr "declared multiple times in `", ppr sty con, ppStr "'"])
+exportItemErr export_item avail sty
+  = ppHang (ppStr "Export item not fully in scope:")
+	   4 (ppAboves [ppCat [ppStr "Wanted:    ", ppr sty export_item],
+			ppCat [ppStr "Available: ", ppr sty (ieOcc export_item), pprAvail sty avail]])
+
+availClashErr (occ_name, ((ie1,avail1), (ie2,avail2))) sty
+  = ppHang (ppCat [ppStr "Conflicting exports for local name: ", ppr sty occ_name])
+	4 (ppAboves [ppr sty ie1, ppr sty ie2])
 \end{code}
+
diff --git a/ghc/compiler/rename/RnSource.lhs b/ghc/compiler/rename/RnSource.lhs
index d650c01154..e726eb3151 100644
--- a/ghc/compiler/rename/RnSource.lhs
+++ b/ghc/compiler/rename/RnSource.lhs
@@ -6,43 +6,54 @@
 \begin{code}
 #include "HsVersions.h"
 
-module RnSource ( rnSource, rnTyDecl, rnClassDecl, rnInstDecl, rnPolyType ) where
+module RnSource ( rnDecl, rnHsType ) where
 
 IMP_Ubiq()
 IMPORT_DELOOPER(RnLoop)		-- *check* the RnPass/RnExpr/RnBinds loop-breaking
-IMPORT_1_3(List(partition))
 
 import HsSyn
+import HsDecls		( HsIdInfo(..) )
 import HsPragmas
+import HsTypes		( getTyVarName )
 import RdrHsSyn
 import RnHsSyn
-import RnMonad
+import HsCore
+
 import RnBinds		( rnTopBinds, rnMethodBinds )
-import RnUtils		( getLocalsFromRnEnv, lookupGlobalRnEnv, lubExportFlag )
+import RnEnv		( bindTyVarsRn, lookupRn, lookupOccRn, lookupImplicitOccRn, bindLocalsRn,
+			  lookupOptionalOccRn, newDfunName, 
+			  listType_RDR, tupleType_RDR )
+import RnMonad
 
-import Bag		( emptyBag, unitBag, consBag, unionManyBags, unionBags, listToBag, bagToList )
-import Class		( derivableClassKeys )
-import CmdLineOpts	( opt_CompilingGhcInternals )
+import Name		( Name, isLocallyDefined, isTvOcc, pprNonSym,
+			  Provenance,
+			  SYN_IE(NameSet), unionNameSets, emptyNameSet, mkNameSet, unitNameSet,
+			  elemNameSet
+			)
 import ErrUtils		( addErrLoc, addShortErrLocLine, addShortWarnLocLine )
 import FiniteMap	( emptyFM, lookupFM, addListToFM_C )
-import Id		( isDataCon, GenId{-instance NamedThing-} )
+import Id		( GenId{-instance NamedThing-} )
+import IdInfo		( IdInfo, StrictnessInfo(..), FBTypeInfo, DemandInfo, ArgUsageInfo )
+import SpecEnv		( SpecEnv )
+import CoreUnfold	( Unfolding(..), SimpleUnfolding )
+import MagicUFs		( MagicUnfoldingFun )
+import PrelInfo		( derivingOccurrences, evalClass_RDR, numClass_RDR )
 import ListSetOps	( unionLists, minusList )
 import Maybes		( maybeToBool, catMaybes )
-import Name		( isLocallyDefined, isLexVarId, getLocalName, ExportFlag(..), 
-			  nameImportFlag, RdrName, pprNonSym, Name )
+import Bag		( emptyBag, unitBag, consBag, unionManyBags, unionBags, listToBag, bagToList )
 import Outputable	( Outputable(..){-instances-} )
 --import PprStyle 	-- ToDo:rm 
 import Pretty
 import SrcLoc		( SrcLoc )
-import TyCon		( tyConDataCons, TyCon{-instance NamedThing-} )
+-- import TyCon		( TyCon{-instance NamedThing-} )
 import Unique		( Unique )
-import UniqFM		( emptyUFM, addListToUFM_C, listToUFM, plusUFM, lookupUFM, eltsUFM )
 import UniqSet		( SYN_IE(UniqSet) )
-import Util		( isIn, isn'tIn, thenCmp, sortLt, removeDups, mapAndUnzip3, cmpPString,
+import UniqFM		( UniqFM, lookupUFM )
+import Util		( isIn, isn'tIn, thenCmp, removeDups, cmpPString,
 			  panic, assertPanic{- , pprTrace ToDo:rm-} )
 \end{code}
 
-rnSource `renames' the source module and export list.
+rnDecl `renames' declarations.
 It simultaneously performs dependency analysis and precedence parsing.
 It also does the following error checks:
 \begin{enumerate}
@@ -56,277 +67,25 @@ Checks the (..) etc constraints in the export list.
 \end{enumerate}
 
 
-\begin{code}
-rnSource :: [Module]			-- imported modules
-	 -> Bag (Module,RnName)		-- unqualified imports from module
-	 -> Bag RenamedFixityDecl	-- fixity info for imported names
-	 -> RdrNameHsModule
-	 -> RnM s (RenamedHsModule,
-		   Name -> ExportFlag,		-- export info
-		   ([(Name, ExportFlag)], 	-- export module X stuff
-		    [(Name, ExportFlag)]),
-		   Bag (RnName, RdrName))	-- occurrence info
-
-rnSource imp_mods unqual_imps imp_fixes
-	(HsModule mod version exports _ fixes
-	   ty_decls specdata_sigs class_decls
-	   inst_decls specinst_sigs defaults
-	   binds _ src_loc)
-
-  = pushSrcLocRn src_loc $
-
-    rnExports (mod:imp_mods) unqual_imps exports	`thenRn` \ (exported_fn, module_dotdots) ->
-    rnFixes fixes					`thenRn` \ src_fixes ->
-    let
-	all_fixes     = src_fixes ++ bagToList imp_fixes
-	all_fixes_fm  = listToUFM (map pair_name all_fixes)
-
-	pair_name inf = (fixDeclName inf, inf)
-    in
-    setExtraRn all_fixes_fm $
-
-    mapRn rnTyDecl	ty_decls	`thenRn` \ new_ty_decls ->
-    mapRn rnSpecDataSig specdata_sigs	`thenRn` \ new_specdata_sigs ->
-    mapRn rnClassDecl	class_decls	`thenRn` \ new_class_decls ->
-    mapRn rnInstDecl	inst_decls	`thenRn` \ new_inst_decls ->
-    mapRn rnSpecInstSig specinst_sigs   `thenRn` \ new_specinst_sigs ->
-    rnDefaultDecl	defaults	`thenRn` \ new_defaults ->
-    rnTopBinds binds			`thenRn` \ new_binds ->
-
-    getOccurrenceUpRn			`thenRn` \ occ_info ->
-
-    returnRn (
-	      HsModule mod version
-		trashed_exports trashed_imports	all_fixes
-		new_ty_decls new_specdata_sigs new_class_decls
-		new_inst_decls new_specinst_sigs new_defaults
-		new_binds [] src_loc,
-	      exported_fn, module_dotdots,
-	      occ_info
-	     )
-  where
-    trashed_exports = {-trace "rnSource:trashed_exports"-} Nothing
-    trashed_imports = {-trace "rnSource:trashed_imports"-} []
-\end{code}
-
-
 %*********************************************************
 %*							*
-\subsection{Export list}
+\subsection{Value declarations}
 %*							*
 %*********************************************************
 
 \begin{code}
-rnExports :: [Module]
-	  -> Bag (Module,RnName)
-	  -> Maybe [RdrNameIE]
-	  -> RnM s (Name -> ExportFlag,    -- main export-flag fun
-		    ([(Name,ExportFlag)],  -- info about "module X" exports
-		     [(Name,ExportFlag)])
-		   )
-
-rnExports mods unqual_imps Nothing
-  = returnRn (\n -> if isLocallyDefined n then ExportAll else NotExported
-	     , ([], [])
-	     )
-
-rnExports mods unqual_imps (Just exps)
-  = getModuleRn			   `thenRn` \ this_mod ->
-    getRnEnv			   `thenRn` \ rn_env ->
-    mapAndUnzipRn (rnIE mods) exps `thenRn` \ (mod_maybes, exp_bags) ->
-    let 
-	(tc_bags, val_bags) = unzip exp_bags
-	tc_names  = bagToList (unionManyBags tc_bags)
-        val_names = bagToList (unionManyBags val_bags)
-        exp_mods  = catMaybes mod_maybes
-
-	-- Warn for duplicate names and modules
-	(_, dup_tc_names)  = removeDups cmp_fst tc_names
-	(_, dup_val_names) = removeDups cmp_fst val_names
-	cmp_fst (x,_) (y,_) = x `cmp` y
-
-	(uniq_mods, dup_mods) = removeDups cmpPString exp_mods
-	(expmods_this, expmods_imps) = partition (== this_mod) uniq_mods
-
-	-- Get names for "module This_Mod" export
-	(this_tcs, this_vals)
-	  = if null expmods_this 
-	    then ([], [])
-	    else getLocalsFromRnEnv rn_env
-
-	-- Get names for exported imported modules
-	(mod_tcs, mod_vals, empty_mods)
-	  = case mapAndUnzip3 get_mod_names expmods_imps of
-	      (tcs, vals, emptys) -> (concat tcs, concat vals, catMaybes emptys)
-		
-	(unqual_tcs, unqual_vals) = partition (isRnTyConOrClass.snd) (bagToList unqual_imps)
-
-        get_mod_names mod
-	  = --pprTrace "get_mod_names" (ppAboves [ppPStr mod, interpp'SP PprDebug (map fst tcs), interpp'SP PprDebug (map fst vals)]) $
-	    (tcs, vals, empty_mod)
-          where
-            tcs  = [(getName rn, nameImportFlag (getName rn))
-		   | (mod',rn) <- unqual_tcs, mod == mod']
-            vals = [(getName rn, nameImportFlag (getName rn))
-		   | (mod',rn) <- unqual_vals, mod == mod', fun_looking rn]
-	    empty_mod = if null tcs && null vals
-			then Just mod
-			else Nothing
-							    
-	    -- fun_looking: must avoid class ops and data constructors
-	    -- and record fieldnames
-	    fun_looking (RnName    _) = True
-	    fun_looking (WiredInId i) = not (isDataCon i)
-	    fun_looking _	      = False
-
-	-- Build finite map of exported names to export flag
-	tc_map0  = addListToUFM_C lub_expflag emptyUFM (map pair_fst tc_names)
-	tc_map1  = addListToUFM_C lub_expflag tc_map0  (map pair_fst mod_tcs)
-	tc_map   = addListToUFM_C lub_expflag tc_map1  (map (pair_fst.exp_all) this_tcs)
-	
-        val_map0 = addListToUFM_C lub_expflag emptyUFM (map pair_fst val_names)
-        val_map1 = addListToUFM_C lub_expflag val_map0 (map pair_fst mod_vals)
-        val_map  = addListToUFM_C lub_expflag val_map1 (map (pair_fst.exp_all) this_vals)
-
-	pair_fst pr@(n,_) = (n,pr)
-	exp_all rn = (getName rn, ExportAll)
-	lub_expflag (n, flag1) (_, flag2) = (n, lubExportFlag flag1 flag2)
-
-	-- Check for exporting of duplicate local names
-	tc_locals  = [(getLocalName n, n) | (n,_) <- eltsUFM tc_map]
-	val_locals = [(getLocalName n, n) | (n,_) <- eltsUFM val_map]
-	(_, dup_tc_locals)  = removeDups cmp_local tc_locals
-	(_, dup_val_locals) = removeDups cmp_local val_locals
-	cmp_local (x,_) (y,_) = x `cmpPString` y
-
-	-- Build export flag function
-	final_exp_map = plusUFM tc_map val_map
-	exp_fn n = case lookupUFM final_exp_map n of
-		      Nothing       -> NotExported
-		      Just (_,flag) -> flag
-    in
-    getSrcLocRn 							`thenRn` \ src_loc ->
-    mapRn (addWarnRn . dupNameExportWarn  src_loc) dup_tc_names 	`thenRn_`
-    mapRn (addWarnRn . dupNameExportWarn  src_loc) dup_val_names 	`thenRn_`
-    mapRn (addWarnRn . dupModExportWarn   src_loc) dup_mods 		`thenRn_`
-    mapRn (addWarnRn . emptyModExportWarn src_loc) empty_mods 		`thenRn_`
-    mapRn (addErrRn  . dupLocalsExportErr src_loc) dup_tc_locals	`thenRn_`
-    mapRn (addErrRn  . dupLocalsExportErr src_loc) dup_val_locals	`thenRn_`
-    returnRn (exp_fn, (mod_vals, mod_tcs))
-
-------------------------------------
--- rename an "IE" in the export list
-
-rnIE ::	[Module]    -- this module and all the (directly?) imported modules
-     -> RdrNameIE
-     -> RnM s (
-	    Maybe Module,		-- Just m => a "module X" export item
-	    (Bag (Name, ExportFlag),	-- Exported tycons/classes
-	     Bag (Name, ExportFlag)))	-- Exported values
-
-rnIE mods (IEVar name)
-  = lookupValue name	`thenRn` \ rn ->
-    checkIEVar rn	`thenRn` \ exps ->
-    returnRn (Nothing, exps)
-  where
-    checkIEVar (RnName    n)      = returnRn (emptyBag, unitBag (n,ExportAll))
-    checkIEVar (WiredInId i)	  = returnRn (emptyBag, unitBag (getName i, ExportAll))
-    checkIEVar rn@(RnClassOp _ _) = getSrcLocRn `thenRn` \ src_loc ->
-			            failButContinueRn (emptyBag, emptyBag) (classOpExportErr rn src_loc)
-    checkIEVar rn@(RnField _ _)	  = getSrcLocRn `thenRn` \ src_loc ->
-			            failButContinueRn (emptyBag, emptyBag) (fieldExportErr rn src_loc)
-    checkIEVar rn		  = --pprTrace "rnIE:IEVar:panic? ToDo?:" (ppr PprDebug rn) $
-				    returnRn (emptyBag, emptyBag)
-
-rnIE mods (IEThingAbs name)
-  = lookupTyConOrClass name	`thenRn` \ rn ->
-    checkIEAbs rn		`thenRn` \ exps ->
-    returnRn (Nothing, exps)
-  where
-    checkIEAbs (RnSyn n)      	= returnRn (unitBag (n,ExportAbs), emptyBag)
-    checkIEAbs (RnData n _ _) 	= returnRn (unitBag (n,ExportAbs), emptyBag)
-    checkIEAbs (RnClass n _)  	= returnRn (unitBag (n,ExportAbs), emptyBag)
-    checkIEAbs (WiredInTyCon t) = returnRn (unitBag (getName t,ExportAbs), emptyBag)
-    checkIEAbs rn               = --pprTrace "rnIE:IEAbs:panic? ToDo?:" (ppr PprDebug rn) $
-				  returnRn (emptyBag, emptyBag)
-
-rnIE mods (IEThingAll name)
-  = lookupTyConOrClass name	`thenRn` \ rn ->
-    checkIEAll rn		`thenRn` \ exps ->
-    checkImportAll rn           `thenRn_`
-    returnRn (Nothing, exps)
-  where
-    checkIEAll (RnData n cons fields)
-      = returnRn (unitBag (exp_all n),
-	    listToBag (map exp_all cons) `unionBags` listToBag (map exp_all fields))
-
-    checkIEAll (WiredInTyCon t)
-      = returnRn (unitBag (exp_all (getName t)), listToBag (map exp_all cons))
-      where
-	cons   = map getName (tyConDataCons t)
-
-    checkIEAll (RnClass n ops)
-      = returnRn (unitBag (exp_all n), listToBag (map exp_all ops))
-    checkIEAll rn@(RnSyn n)
-      = getSrcLocRn `thenRn` \ src_loc ->
-	warnAndContinueRn (unitBag (n, ExportAbs), emptyBag)
-			  (synAllExportErr False{-warning-} rn src_loc)
-
-    checkIEAll rn = --pprTrace "rnIE:IEAll:panic? ToDo?:" (ppr PprDebug rn) $
-		    returnRn (emptyBag, emptyBag)
-
-    exp_all n = (n, ExportAll)
-
-rnIE mods (IEThingWith name names)
-  = lookupTyConOrClass name	`thenRn` \ rn ->
-    mapRn lookupValue names	`thenRn` \ rns ->
-    checkIEWith rn rns		`thenRn` \ exps ->
-    checkImportAll rn    	`thenRn_`
-    returnRn (Nothing, exps)
-  where
-    checkIEWith rn@(RnData n cons fields) rns
-	| same_names (cons++fields) rns
-	= returnRn (unitBag (exp_all n), listToBag (map exp_all cons)
-					   `unionBags`
-					 listToBag (map exp_all fields))
-	| otherwise
-	= rnWithErr "constructors (and fields)" rn (cons++fields) rns 
-    checkIEWith rn@(RnClass n ops) rns
-	| same_names ops rns
-	= returnRn (unitBag (exp_all n), listToBag (map exp_all ops))
-	| otherwise
-	= rnWithErr "class ops" rn ops rns
-    checkIEWith rn@(RnSyn _) rns
-	= getSrcLocRn `thenRn` \ src_loc ->
-	  failButContinueRn (emptyBag, emptyBag) (synAllExportErr True{-error-} rn src_loc)
-    checkIEWith (WiredInTyCon _) rns = panic "RnSource.rnIE:checkIEWith:WiredInTyCon:ToDo (boring)"
-    checkIEWith rn rns
-	= --pprTrace "rnIE:IEWith:panic? ToDo?:" (ppr PprDebug rn) $
-	  returnRn (emptyBag, emptyBag)
-
-    exp_all n = (n, ExportAll)
-
-    same_names has rns
-      = all (not.isRnUnbound) rns &&
-	sortLt (<) (map uniqueOf has) == sortLt (<) (map uniqueOf rns)
-
-    rnWithErr str rn has rns
-      = getSrcLocRn `thenRn` \ src_loc ->
-	failButContinueRn (emptyBag, emptyBag) (withExportErr str rn has rns src_loc)
-
-rnIE mods (IEModuleContents mod)
-  | isIn "rnIE:IEModule" mod mods
-  = returnRn (Just mod, (emptyBag, emptyBag))
-  | otherwise
-  = getSrcLocRn `thenRn` \ src_loc ->
-    failButContinueRn (Nothing, (emptyBag, emptyBag)) (badModExportErr mod src_loc)
-
-
-checkImportAll rn 
-  = case nameImportFlag (getName rn) of
-      ExportAll -> returnRn ()
-      exp	-> getSrcLocRn `thenRn` \ src_loc ->
-		   addErrRn (importAllErr rn src_loc)
+rnDecl :: RdrNameHsDecl -> RnMS s RenamedHsDecl
+
+rnDecl (ValD binds) = rnTopBinds binds	`thenRn` \ new_binds ->
+		      returnRn (ValD new_binds)
+
+
+rnDecl (SigD (IfaceSig name ty id_infos loc))
+  = pushSrcLocRn loc $
+    lookupRn name		`thenRn` \ name' ->
+    rnHsType ty			`thenRn` \ ty' ->
+    mapRn rnIdInfo id_infos	`thenRn` \ id_infos' -> 
+    returnRn (SigD (IfaceSig name' ty' id_infos' loc))
 \end{code}
 
 %*********************************************************
@@ -348,126 +107,32 @@ it again to rename the tyvars! However, we can also do some scoping
 checks at the same time.
 
 \begin{code}
-rnTyDecl :: RdrNameTyDecl -> RnM_Fixes s RenamedTyDecl
-
-rnTyDecl (TyData context tycon tyvars condecls derivings pragmas src_loc)
+rnDecl (TyD (TyData context tycon tyvars condecls derivings pragmas src_loc))
   = pushSrcLocRn src_loc $
-    lookupTyCon tycon		       `thenRn` \ tycon' ->
-    mkTyVarNamesEnv src_loc tyvars     `thenRn` \ (tv_env, tyvars') ->
-    rnContext tv_env src_loc context   `thenRn` \ context' ->
-    rnConDecls tv_env condecls	       `thenRn` \ condecls' ->
-    rn_derivs tycon' src_loc derivings `thenRn` \ derivings' ->
+    lookupRn tycon		    		`thenRn` \ tycon' ->
+    bindTyVarsRn "data declaration" tyvars	$ \ tyvars' ->
+    rnContext context   			`thenRn` \ context' ->
+    mapRn rnConDecl condecls			`thenRn` \ condecls' ->
+    rnDerivs derivings				`thenRn` \ derivings' ->
     ASSERT(isNoDataPragmas pragmas)
-    returnRn (TyData context' tycon' tyvars' condecls' derivings' noDataPragmas src_loc)
+    returnRn (TyD (TyData context' tycon' tyvars' condecls' derivings' noDataPragmas src_loc))
 
-rnTyDecl (TyNew context tycon tyvars condecl derivings pragmas src_loc)
+rnDecl (TyD (TyNew context tycon tyvars condecl derivings pragmas src_loc))
   = pushSrcLocRn src_loc $
-    lookupTyCon tycon		      `thenRn` \ tycon' ->
-    mkTyVarNamesEnv src_loc tyvars    `thenRn` \ (tv_env, tyvars') ->
-    rnContext tv_env src_loc context  `thenRn` \ context' ->
-    rnConDecls tv_env condecl	      `thenRn` \ condecl' ->
-    rn_derivs tycon' src_loc derivings `thenRn` \ derivings' ->
+    lookupRn tycon				`thenRn` \ tycon' ->
+    bindTyVarsRn "newtype declaration" tyvars 	$ \ tyvars' ->
+    rnContext context				`thenRn` \ context' ->
+    rnConDecl condecl				`thenRn` \ condecl' ->
+    rnDerivs derivings				`thenRn` \ derivings' ->
     ASSERT(isNoDataPragmas pragmas)
-    returnRn (TyNew context' tycon' tyvars' condecl' derivings' noDataPragmas src_loc)
+    returnRn (TyD (TyNew context' tycon' tyvars' condecl' derivings' noDataPragmas src_loc))
 
-rnTyDecl (TySynonym name tyvars ty src_loc)
+rnDecl (TyD (TySynonym name tyvars ty src_loc))
   = pushSrcLocRn src_loc $
-    lookupTyCon name		    `thenRn` \ name' ->
-    mkTyVarNamesEnv src_loc tyvars  `thenRn` \ (tv_env, tyvars') ->
-    rnMonoType tv_env ty	    `thenRn` \ ty' ->
-    returnRn (TySynonym name' tyvars' ty' src_loc)
-
-rn_derivs tycon2 locn Nothing -- derivs not specified
-  = returnRn Nothing
-
-rn_derivs tycon2 locn (Just ds)
-  = mapRn (rn_deriv tycon2 locn) ds `thenRn` \ derivs ->
-    returnRn (Just derivs)
-  where
-    rn_deriv tycon2 locn clas
-      = lookupClass clas	    `thenRn` \ clas_name ->
-	addErrIfRn (uniqueOf clas_name `not_elem` derivableClassKeys)
-		   (derivingNonStdClassErr clas_name locn)
-				    `thenRn_`
-	returnRn clas_name
-      where
-	not_elem = isn'tIn "rn_deriv"
-\end{code}
-
-@rnConDecls@ uses the `global name function' to create a new
-constructor in which local names have been replaced by their original
-names, reporting any unknown names.
-
-\begin{code}
-rnConDecls :: TyVarNamesEnv
-	   -> [RdrNameConDecl]
-	   -> RnM_Fixes s [RenamedConDecl]
-
-rnConDecls tv_env con_decls
-  = mapRn rn_decl con_decls
-  where
-    rn_decl (ConDecl name tys src_loc)
-      = pushSrcLocRn src_loc $
-	lookupConstr name	`thenRn` \ new_name ->
-	mapRn rn_bang_ty tys	`thenRn` \ new_tys  ->
-	returnRn (ConDecl new_name new_tys src_loc)
-
-    rn_decl (ConOpDecl ty1 op ty2 src_loc)
-      = pushSrcLocRn src_loc $
-	lookupConstr op		`thenRn` \ new_op  ->
-	rn_bang_ty ty1  	`thenRn` \ new_ty1 ->
-	rn_bang_ty ty2  	`thenRn` \ new_ty2 ->
-	returnRn (ConOpDecl new_ty1 new_op new_ty2 src_loc)
-
-    rn_decl (NewConDecl name ty src_loc)
-      = pushSrcLocRn src_loc $
-	lookupConstr name	`thenRn` \ new_name ->
-	rn_mono_ty ty		`thenRn` \ new_ty  ->
-	returnRn (NewConDecl new_name new_ty src_loc)
-
-    rn_decl (RecConDecl name fields src_loc)
-      = pushSrcLocRn src_loc $
-	lookupConstr name	`thenRn` \ new_name ->
-	mapRn rn_field fields	`thenRn` \ new_fields ->
-	returnRn (RecConDecl new_name new_fields src_loc)
-
-    rn_field (names, ty)
-      = mapRn lookupField names `thenRn` \ new_names ->
-	rn_bang_ty ty		`thenRn` \ new_ty ->
-	returnRn (new_names, new_ty) 
-
-    rn_mono_ty = rnMonoType tv_env
-    rn_poly_ty = rnPolyType tv_env
-
-    rn_bang_ty (Banged ty)
-      = rn_poly_ty ty `thenRn` \ new_ty ->
-	returnRn (Banged new_ty)
-    rn_bang_ty (Unbanged ty)
-      = rn_poly_ty ty `thenRn` \ new_ty ->
-	returnRn (Unbanged new_ty)
-\end{code}
-
-%*********************************************************
-%*							 *
-\subsection{SPECIALIZE data pragmas}
-%*							 *
-%*********************************************************
-
-\begin{code}
-rnSpecDataSig :: RdrNameSpecDataSig
-	      -> RnM_Fixes s RenamedSpecDataSig
-
-rnSpecDataSig (SpecDataSig tycon ty src_loc)
-  = pushSrcLocRn src_loc $
-    let
-	tyvars = extractMonoTyNames is_tyvar_name ty
-    in
-    mkTyVarNamesEnv src_loc tyvars     	`thenRn` \ (tv_env,_) ->
-    lookupTyCon tycon			`thenRn` \ tycon' ->
-    rnMonoType tv_env ty		`thenRn` \ ty' ->
-    returnRn (SpecDataSig tycon' ty' src_loc)
-
-is_tyvar_name n = isLexVarId (getLocalName n)
+    lookupRn name				`thenRn` \ name' ->
+    bindTyVarsRn "type declaration" tyvars 	$ \ tyvars' ->
+    rnHsType ty	    				`thenRn` \ ty' ->
+    returnRn (TyD (TySynonym name' tyvars' ty' src_loc))
 \end{code}
 
 %*********************************************************
@@ -481,38 +146,37 @@ class declaration in which local names have been replaced by their
 original names, reporting any unknown names.
 
 \begin{code}
-rnClassDecl :: RdrNameClassDecl -> RnM_Fixes s RenamedClassDecl
-
-rnClassDecl (ClassDecl context cname tyvar sigs mbinds pragmas src_loc)
+rnDecl (ClD (ClassDecl context cname tyvar sigs mbinds pragmas src_loc))
   = pushSrcLocRn src_loc $
-    mkTyVarNamesEnv src_loc [tyvar]	    `thenRn` \ (tv_env, [tyvar']) ->
-    rnContext tv_env src_loc context	    `thenRn` \ context' ->
-    lookupClass cname			    `thenRn` \ cname' ->
-    mapRn (rn_op cname' tyvar' tv_env) sigs `thenRn` \ sigs' ->
-    rnMethodBinds cname' mbinds		    `thenRn` \ mbinds' ->
+    bindTyVarsRn "class declaration" [tyvar]		$ \ [tyvar'] ->
+    rnContext context	    				`thenRn` \ context' ->
+    lookupRn cname					`thenRn` \ cname' ->
+    mapRn (rn_op cname' (getTyVarName tyvar')) sigs	`thenRn` \ sigs' ->
+    rnMethodBinds mbinds				`thenRn` \ mbinds' ->
     ASSERT(isNoClassPragmas pragmas)
-    returnRn (ClassDecl context' cname' tyvar' sigs' mbinds' NoClassPragmas src_loc)
+    returnRn (ClD (ClassDecl context' cname' tyvar' sigs' mbinds' NoClassPragmas src_loc))
   where
-    rn_op clas clas_tyvar tv_env sig@(ClassOpSig op ty pragmas locn)
+    rn_op clas clas_tyvar sig@(ClassOpSig op ty pragmas locn)
       = pushSrcLocRn locn $
-	lookupClassOp clas op		`thenRn` \ op_name ->
-	rnPolyType tv_env ty		`thenRn` \ new_ty  ->
+	lookupRn op			`thenRn` \ op_name ->
+	rnHsType ty			`thenRn` \ new_ty  ->
 	let
-	    (HsForAllTy tvs ctxt op_ty) = new_ty
-	    ctxt_tvs = extractCtxtTyNames ctxt
-	    op_tvs   = extractMonoTyNames is_tyvar_name op_ty
+	    (ctxt, op_ty) = case new_ty of
+				HsForAllTy tvs ctxt op_ty -> (ctxt, op_ty)
+				other			  -> ([], new_ty)
+	    ctxt_fvs  = extractCtxtTyNames ctxt
+	    op_ty_fvs = extractHsTyNames op_ty		-- Includes tycons/classes but we
+							-- don't care about that
 	in
 	-- check that class tyvar appears in op_ty
-        ( if isIn "rn_op" clas_tyvar op_tvs
-	  then returnRn ()
-	  else addErrRn (classTyVarNotInOpTyErr clas_tyvar sig locn)
-	) `thenRn_`
+        checkRn (clas_tyvar `elemNameSet` op_ty_fvs)
+	        (classTyVarNotInOpTyErr clas_tyvar sig)
+							 `thenRn_`
 
 	-- check that class tyvar *doesn't* appear in the sig's context
-        ( if isIn "rn_op(2)" clas_tyvar ctxt_tvs
-	  then addErrRn (classTyVarInOpCtxtErr clas_tyvar sig locn)
-	  else returnRn ()
-	) `thenRn_`
+        checkRn (not (clas_tyvar `elemNameSet` ctxt_fvs))
+		(classTyVarInOpCtxtErr clas_tyvar sig)
+							 `thenRn_`
 
 	ASSERT(isNoClassOpPragmas pragmas)
 	returnRn (ClassOpSig op_name new_ty noClassOpPragmas locn)
@@ -525,138 +189,137 @@ rnClassDecl (ClassDecl context cname tyvar sigs mbinds pragmas src_loc)
 %*							*
 %*********************************************************
 
-
-@rnInstDecl@ uses the `global name function' to create a new of
-instance declaration in which local names have been replaced by their
-original names, reporting any unknown names.
-
 \begin{code}
-rnInstDecl :: RdrNameInstDecl -> RnM_Fixes s RenamedInstDecl
-
-rnInstDecl (InstDecl cname ty mbinds from_here modname uprags pragmas src_loc)
+rnDecl (InstD (InstDecl inst_ty mbinds uprags maybe_dfun_name src_loc))
   = pushSrcLocRn src_loc $
-    lookupClass cname 		     	`thenRn` \ cname' ->
-
-    rnPolyType [] ty			`thenRn` \ ty' ->
-	-- [] tv_env ensures that tyvars will be foralled
+    rnHsType inst_ty			`thenRn` \ inst_ty' ->
+    rnMethodBinds mbinds		`thenRn` \ mbinds' ->
+    mapRn rn_uprag uprags		`thenRn` \ new_uprags ->
+    rn_dfun maybe_dfun_name		`thenRn` \ dfun_name' ->
 
-    rnMethodBinds cname' mbinds		`thenRn` \ mbinds' ->
-    mapRn (rn_uprag cname') uprags	`thenRn` \ new_uprags ->
-
-    ASSERT(isNoInstancePragmas pragmas)
-    returnRn (InstDecl cname' ty' mbinds'
-		       from_here modname new_uprags noInstancePragmas src_loc)
+    returnRn (InstD (InstDecl inst_ty' mbinds' new_uprags dfun_name' src_loc))
   where
-    rn_uprag class_name (SpecSig op ty using locn)
+    rn_dfun Nothing  = newDfunName src_loc	`thenRn` \ n' ->
+		       returnRn (Just n')
+    rn_dfun (Just n) = lookupOptionalOccRn n	`thenRn` \ n' ->
+		       returnRn (Just n')
+
+    rn_uprag (SpecSig op ty using locn)
       = pushSrcLocRn src_loc $
-	lookupClassOp class_name op	`thenRn` \ op_name ->
-	rnPolyType nullTyVarNamesEnv ty	`thenRn` \ new_ty ->
+	lookupRn op			`thenRn` \ op_name ->
+	rnHsType ty			`thenRn` \ new_ty ->
 	rn_using using			`thenRn` \ new_using ->
 	returnRn (SpecSig op_name new_ty new_using locn)
 
-    rn_uprag class_name (InlineSig op locn)
+    rn_uprag (InlineSig op locn)
       = pushSrcLocRn locn $
-	lookupClassOp class_name op	`thenRn` \ op_name ->
+	lookupRn op			`thenRn` \ op_name ->
 	returnRn (InlineSig op_name locn)
 
-    rn_uprag class_name (DeforestSig op locn)
+    rn_uprag (DeforestSig op locn)
       = pushSrcLocRn locn $
-	lookupClassOp class_name op	`thenRn` \ op_name ->
+	lookupRn op			`thenRn` \ op_name ->
 	returnRn (DeforestSig op_name locn)
 
-    rn_uprag class_name (MagicUnfoldingSig op str locn)
+    rn_uprag (MagicUnfoldingSig op str locn)
       = pushSrcLocRn locn $
-	lookupClassOp class_name op	`thenRn` \ op_name ->
+	lookupRn op			`thenRn` \ op_name ->
 	returnRn (MagicUnfoldingSig op_name str locn)
 
-    rn_using Nothing 
-      = returnRn Nothing
-    rn_using (Just v)
-      = lookupValue v	`thenRn` \ new_v ->
-	returnRn (Just new_v)
+    rn_using Nothing  = returnRn Nothing
+    rn_using (Just v) = lookupOccRn v	`thenRn` \ new_v ->
+			returnRn (Just new_v)
 \end{code}
 
 %*********************************************************
 %*							*
-\subsection{@SPECIALIZE instance@ user-pragmas}
+\subsection{Default declarations}
 %*							*
 %*********************************************************
 
 \begin{code}
-rnSpecInstSig :: RdrNameSpecInstSig
-	      -> RnM_Fixes s RenamedSpecInstSig
-
-rnSpecInstSig (SpecInstSig clas ty src_loc)
+rnDecl (DefD (DefaultDecl tys src_loc))
   = pushSrcLocRn src_loc $
-    let
-	tyvars = extractMonoTyNames is_tyvar_name ty
-    in
-    mkTyVarNamesEnv src_loc tyvars     	`thenRn` \ (tv_env,_) ->
-    lookupClass clas			`thenRn` \ new_clas ->
-    rnMonoType tv_env ty		`thenRn` \ new_ty ->
-    returnRn (SpecInstSig new_clas new_ty src_loc)
+    mapRn rnHsType tys 			`thenRn` \ tys' ->
+    lookupImplicitOccRn numClass_RDR	`thenRn_` 
+    returnRn (DefD (DefaultDecl tys' src_loc))
 \end{code}
 
 %*********************************************************
 %*							*
-\subsection{Default declarations}
+\subsection{Support code for type/data declarations}
 %*							*
 %*********************************************************
 
-@rnDefaultDecl@ uses the `global name function' to create a new set
-of default declarations in which local names have been replaced by
-their original names, reporting any unknown names.
+\begin{code}
+rnDerivs :: Maybe [RdrName] -> RnMS s (Maybe [Name])
+
+rnDerivs Nothing -- derivs not specified
+  = lookupImplicitOccRn evalClass_RDR		`thenRn_`
+    returnRn Nothing
+
+rnDerivs (Just ds)
+  = lookupImplicitOccRn evalClass_RDR		`thenRn_`
+    mapRn rn_deriv ds `thenRn` \ derivs ->
+    returnRn (Just derivs)
+  where
+    rn_deriv clas
+      = lookupOccRn clas	    `thenRn` \ clas_name ->
+
+		-- Now add extra "occurrences" for things that
+		-- the deriving mechanism will later need in order to
+		-- generate code for this class.
+	case lookupUFM derivingOccurrences clas_name of
+		Nothing -> addErrRn (derivingNonStdClassErr clas_name)	`thenRn_`
+			   returnRn clas_name
+
+		Just occs -> mapRn lookupImplicitOccRn occs	`thenRn_`
+			     returnRn clas_name
+\end{code}
 
 \begin{code}
-rnDefaultDecl :: [RdrNameDefaultDecl] -> RnM_Fixes s [RenamedDefaultDecl]
+rnConDecl :: RdrNameConDecl -> RnMS s RenamedConDecl
 
-rnDefaultDecl [] = returnRn []
-rnDefaultDecl [DefaultDecl tys src_loc]
+rnConDecl (ConDecl name tys src_loc)
   = pushSrcLocRn src_loc $
-    mapRn (rnMonoType nullTyVarNamesEnv) tys `thenRn` \ tys' ->
-    returnRn [DefaultDecl tys' src_loc]
-rnDefaultDecl defs@(d:ds)
-  = addErrRn (dupDefaultDeclErr defs) `thenRn_`
-    rnDefaultDecl [d]
-\end{code}
+    lookupRn name		`thenRn` \ new_name ->
+    mapRn rnBangTy tys		`thenRn` \ new_tys  ->
+    returnRn (ConDecl new_name new_tys src_loc)
 
-%*************************************************************************
-%*									*
-\subsection{Fixity declarations}
-%*									*
-%*************************************************************************
+rnConDecl (ConOpDecl ty1 op ty2 src_loc)
+  = pushSrcLocRn src_loc $
+    lookupRn op			`thenRn` \ new_op  ->
+    rnBangTy ty1  		`thenRn` \ new_ty1 ->
+    rnBangTy ty2  		`thenRn` \ new_ty2 ->
+    returnRn (ConOpDecl new_ty1 new_op new_ty2 src_loc)
 
-\begin{code}
-rnFixes :: [RdrNameFixityDecl]  -> RnM s [RenamedFixityDecl]
+rnConDecl (NewConDecl name ty src_loc)
+  = pushSrcLocRn src_loc $
+    lookupRn name		`thenRn` \ new_name ->
+    rnHsType ty			`thenRn` \ new_ty  ->
+    returnRn (NewConDecl new_name new_ty src_loc)
 
-rnFixes fixities
-  = getSrcLocRn	`thenRn` \ src_loc ->
-    let
-        (_, dup_fixes) = removeDups cmp_fix fixities
-	cmp_fix fix1 fix2 = fixDeclName fix1 `cmp` fixDeclName fix2
-
-        rn_fixity fix@(InfixL name i)
-      	  = rn_fixity_pieces InfixL name i fix
-    	rn_fixity fix@(InfixR name i)
-      	  = rn_fixity_pieces InfixR name i fix
-    	rn_fixity fix@(InfixN name i)
-      	  = rn_fixity_pieces InfixN name i fix
-
-    	rn_fixity_pieces mk_fixity name i fix
-      	  = getRnEnv `thenRn` \ env ->
-	      case lookupGlobalRnEnv env name of
-	  	Just res | isLocallyDefined res -- || opt_CompilingGhcInternals
-		  -- the opt_CompilingGhcInternals thing is a *HACK* to get (:)'s
-		  -- fixity decl to go through.  It has a builtin name, which
-		  -- doesn't respond to isLocallyDefined...  sigh.
-	  	  -> returnRn (Just (mk_fixity res i))
-	  	_ -> failButContinueRn Nothing (undefinedFixityDeclErr src_loc fix)
-    in
-    mapRn (addErrRn . dupFixityDeclErr src_loc) dup_fixes `thenRn_`
-    mapRn rn_fixity fixities				  `thenRn` \ fixes_maybe ->
-    returnRn (catMaybes fixes_maybe)
+rnConDecl (RecConDecl name fields src_loc)
+  = pushSrcLocRn src_loc $
+    lookupRn name		`thenRn` \ new_name ->
+    mapRn rnField fields	`thenRn` \ new_fields ->
+    returnRn (RecConDecl new_name new_fields src_loc)
+
+rnField (names, ty)
+  = mapRn lookupRn names	`thenRn` \ new_names ->
+    rnBangTy ty			`thenRn` \ new_ty ->
+    returnRn (new_names, new_ty) 
+
+rnBangTy (Banged ty)
+  = rnHsType ty `thenRn` \ new_ty ->
+    returnRn (Banged new_ty)
+
+rnBangTy (Unbanged ty)
+  = rnHsType ty `thenRn` \ new_ty ->
+    returnRn (Unbanged new_ty)
 \end{code}
 
+
 %*********************************************************
 %*							*
 \subsection{Support code to rename types}
@@ -664,180 +327,307 @@ rnFixes fixities
 %*********************************************************
 
 \begin{code}
-rnPolyType :: TyVarNamesEnv
-	   -> RdrNamePolyType
-	   -> RnM_Fixes s RenamedPolyType
+rnHsType :: RdrNameHsType -> RnMS s RenamedHsType
 
-rnPolyType tv_env (HsForAllTy tvs ctxt ty)
-  = rn_poly_help tv_env tvs ctxt ty
+rnHsType (HsForAllTy tvs ctxt ty)
+  = rn_poly_help tvs ctxt ty
 
-rnPolyType tv_env (HsPreForAllTy ctxt ty)
-  = rn_poly_help tv_env forall_tyvars ctxt ty
-  where
-    mentioned_tyvars = extractCtxtTyNames ctxt `unionLists` extractMonoTyNames is_tyvar_name ty
-    forall_tyvars    = {-
-		       pprTrace "mentioned:" (ppCat (map (ppr PprShowAll) mentioned_tyvars)) $
-		       pprTrace "from_ty:" (ppCat (map (ppr PprShowAll) (extractMonoTyNames is_tyvar_name ty))) $
-		       -}
-		       mentioned_tyvars `minusList` domTyVarNamesEnv tv_env
-
-------------
-rn_poly_help :: TyVarNamesEnv
-	     -> [RdrName]
-	     -> RdrNameContext
-	     -> RdrNameMonoType
-	     -> RnM_Fixes s RenamedPolyType
-
-rn_poly_help tv_env tyvars ctxt ty
-  = {-
-    pprTrace "rnPolyType:"
- 	(ppCat [ppCat (map (ppr PprShowAll . snd) tv_env),
-    		ppStr ";tvs=", ppCat (map (ppr PprShowAll) tyvars),
-    		ppStr ";ctxt=", ppCat (map (ppr PprShowAll) ctxt),
-    		ppStr ";ty=", ppr PprShowAll ty]) $
-    -}
-    getSrcLocRn 			`thenRn` \ src_loc ->
-    mkTyVarNamesEnv src_loc tyvars	`thenRn` \ (tv_env1, new_tyvars) ->
+rnHsType full_ty@(HsPreForAllTy ctxt ty)
+  = getNameEnv		`thenRn` \ name_env ->
     let
-	tv_env2 = catTyVarNamesEnvs tv_env1 tv_env
+	mentioned_tyvars = extractHsTyVars full_ty
+	forall_tyvars    = filter not_in_scope mentioned_tyvars
+	not_in_scope tv  = case lookupFM name_env tv of
+				    Nothing -> True
+				    Just _  -> False
     in
-    rnContext tv_env2 src_loc ctxt	`thenRn` \ new_ctxt ->
-    rnMonoType tv_env2 ty		`thenRn` \ new_ty ->
-    returnRn (HsForAllTy new_tyvars new_ctxt new_ty)
-\end{code}
-
-\begin{code}
-rnMonoType :: TyVarNamesEnv
-	   -> RdrNameMonoType
-	   -> RnM_Fixes s RenamedMonoType
+    rn_poly_help (map UserTyVar forall_tyvars) ctxt ty
 
-rnMonoType tv_env (MonoTyVar tyvar)
-  = lookupTyVarName tv_env tyvar 	`thenRn` \ tyvar' ->
+rnHsType (MonoTyVar tyvar)
+  = lookupOccRn tyvar 		`thenRn` \ tyvar' ->
     returnRn (MonoTyVar tyvar')
 
-rnMonoType tv_env (MonoListTy ty)
-  = rnMonoType tv_env ty	`thenRn` \ ty' ->
-    returnRn (MonoListTy ty')
+rnHsType (MonoFunTy ty1 ty2)
+  = andRn MonoFunTy (rnHsType ty1) (rnHsType ty2)
 
-rnMonoType tv_env (MonoFunTy ty1 ty2)
-  = andRn MonoFunTy (rnMonoType tv_env ty1)
-		    (rnMonoType tv_env ty2)
+rnHsType (MonoListTy _ ty)
+  = lookupImplicitOccRn listType_RDR		`thenRn` \ tycon_name ->
+    rnHsType ty					`thenRn` \ ty' ->
+    returnRn (MonoListTy tycon_name ty')
 
-rnMonoType  tv_env (MonoTupleTy tys)
-  = mapRn (rnMonoType tv_env) tys `thenRn` \ tys' ->
-    returnRn (MonoTupleTy tys')
+rnHsType (MonoTupleTy _ tys)
+  = lookupImplicitOccRn (tupleType_RDR (length tys))	`thenRn` \ tycon_name ->
+    mapRn rnHsType tys					`thenRn` \ tys' ->
+    returnRn (MonoTupleTy tycon_name tys')
 
-rnMonoType tv_env (MonoTyApp name tys)
-  = let
-	lookup_fn = if isLexVarId (getLocalName name) 
-		    then lookupTyVarName tv_env
-  	            else lookupTyCon
-    in
-    lookup_fn name			`thenRn` \ name' ->
-    mapRn (rnMonoType tv_env) tys	`thenRn` \ tys' ->
+rnHsType (MonoTyApp name tys)
+  = lookupOccRn name		`thenRn` \ name' ->
+    mapRn rnHsType tys		`thenRn` \ tys' ->
     returnRn (MonoTyApp name' tys')
+
+rnHsType (MonoDictTy clas ty)
+  = lookupOccRn clas		`thenRn` \ clas' ->
+    rnHsType ty			`thenRn` \ ty' ->
+    returnRn (MonoDictTy clas' ty')
+
+
+rn_poly_help :: [HsTyVar RdrName]		-- Universally quantified tyvars
+	     -> RdrNameContext
+	     -> RdrNameHsType
+	     -> RnMS s RenamedHsType
+
+rn_poly_help tyvars ctxt ty
+  = bindTyVarsRn "type signature" tyvars		$ \ new_tyvars ->
+    rnContext ctxt					`thenRn` \ new_ctxt ->
+    rnHsType ty						`thenRn` \ new_ty ->
+    returnRn (HsForAllTy new_tyvars new_ctxt new_ty)
 \end{code}
 
+
 \begin{code}
-rnContext :: TyVarNamesEnv -> SrcLoc -> RdrNameContext -> RnM_Fixes s RenamedContext
+rnContext :: RdrNameContext -> RnMS s RenamedContext
 
-rnContext tv_env locn ctxt
+rnContext  ctxt
   = mapRn rn_ctxt ctxt	`thenRn` \ result ->
     let
 	(_, dup_asserts) = removeDups cmp_assert result
     in
     -- If this isn't an error, then it ought to be:
-    mapRn (addWarnRn . dupClassAssertWarn result locn) dup_asserts `thenRn_`
+    mapRn (addWarnRn . dupClassAssertWarn result) dup_asserts `thenRn_`
     returnRn result
   where
-    rn_ctxt (clas, tyvar)
-      = lookupClass clas	     `thenRn` \ clas_name ->
-	lookupTyVarName tv_env tyvar `thenRn` \ tyvar_name ->
-	returnRn (clas_name, tyvar_name)
+    rn_ctxt (clas, ty)
+      = lookupOccRn clas	`thenRn` \ clas_name ->
+	rnHsType ty		`thenRn` \ ty' ->
+	returnRn (clas_name, ty')
 
-    cmp_assert (c1,tv1) (c2,tv2)
-      = (c1 `cmp` c2) `thenCmp` (tv1 `cmp` tv2)
+    cmp_assert (c1,ty1) (c2,ty2)
+      = (c1 `cmp` c2) `thenCmp` (cmpHsType cmp ty1 ty2)
 \end{code}
 
 
+%*********************************************************
+%*							*
+\subsection{IdInfo}
+%*							*
+%*********************************************************
+
 \begin{code}
-dupNameExportWarn locn names@((n,_):_)
-  = addShortWarnLocLine locn $ \ sty ->
-    ppCat [pprNonSym sty n, ppStr "exported", ppInt (length names), ppStr "times"]
-
-dupLocalsExportErr locn locals@((str,_):_)
-  = addErrLoc locn "exported names have same local name" $ \ sty ->
-    ppInterleave ppSP (map (pprNonSym sty . snd) locals)
-
-classOpExportErr op locn
-  = addShortErrLocLine locn $ \ sty ->
-    ppBesides [ppStr "class operation `", ppr sty op, ppStr "' can only be exported with its class"]
-
-fieldExportErr op locn
-  = addShortErrLocLine locn $ \ sty ->
-    ppBesides [ppStr "field name `", ppr sty op, ppStr "' can only be exported with its data type"]
-
-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 "'"],
-	       ppCat [ppStr "    expected:", ppInterleave ppComma (map (ppr sty) has)],
-	       ppCat [ppStr "    found:   ", ppInterleave ppComma (map (ppr sty) rns)] ]
-
-importAllErr rn locn
-  = addShortErrLocLine locn $ \ sty ->
-    ppBesides [ ppStr "`", pprNonSym sty rn, ppStr "' has been exported with (..), but is only imported abstractly"]
-
-badModExportErr mod locn
-  = addShortErrLocLine locn $ \ sty ->
-    ppCat [ ppStr "unknown module in export list: module", ppPStr mod]
-
-emptyModExportWarn locn mod
-  = addShortWarnLocLine locn $ \ sty ->
-    ppCat [ppStr "module", ppPStr mod, ppStr "has no unqualified imports to export"]
-
-dupModExportWarn locn mods@(mod:_)
-  = addShortWarnLocLine locn $ \ sty ->
-    ppCat [ppStr "module", ppPStr mod, ppStr "appears", ppInt (length mods), ppStr "times in export list"]
-
-derivingNonStdClassErr clas locn
-  = addShortErrLocLine locn $ \ sty ->
-    ppCat [ppStr "non-standard class in deriving:", ppr sty clas]
-
-dupDefaultDeclErr (DefaultDecl _ locn1 : dup_things) sty
-  = ppAboves (item1 : map dup_item dup_things)
+rnIdInfo (HsStrictness strict)
+  = rnStrict strict	`thenRn` \ strict' ->
+    returnRn (HsStrictness strict')
+
+rnIdInfo (HsUnfold expr)	= rnCoreExpr expr	`thenRn` \ expr' ->
+				  returnRn (HsUnfold expr')
+rnIdInfo (HsArity arity)	= returnRn (HsArity arity)
+rnIdInfo (HsUpdate update)	= returnRn (HsUpdate update)
+rnIdInfo (HsFBType fb)		= returnRn (HsFBType fb)
+rnIdInfo (HsArgUsage au)	= returnRn (HsArgUsage au)
+rnIdInfo (HsDeforest df)	= returnRn (HsDeforest df)
+
+rnStrict (StrictnessInfo demands (Just worker))
+  = lookupOptionalOccRn worker		`thenRn` \ worker' ->
+    returnRn (StrictnessInfo demands (Just worker'))
+
+-- Boring, but necessary for the type checker.
+rnStrict (StrictnessInfo demands Nothing) = returnRn (StrictnessInfo demands Nothing)
+rnStrict BottomGuaranteed		  = returnRn BottomGuaranteed
+rnStrict NoStrictnessInfo		  = returnRn NoStrictnessInfo
+\end{code}
+
+UfCore expressions.
+
+\begin{code}
+rnCoreExpr (UfVar v)
+  = lookupOptionalOccRn v 	`thenRn` \ v' ->
+    returnRn (UfVar v')
+
+rnCoreExpr (UfLit lit) = returnRn (UfLit lit)
+
+rnCoreExpr (UfCon con args) 
+  = lookupOptionalOccRn con		`thenRn` \ con' ->
+    mapRn rnCoreArg args	`thenRn` \ args' ->
+    returnRn (UfCon con' args')
+
+rnCoreExpr (UfPrim prim args) 
+  = rnCorePrim prim		`thenRn` \ prim' ->
+    mapRn rnCoreArg args	`thenRn` \ args' ->
+    returnRn (UfPrim prim' args')
+
+rnCoreExpr (UfApp fun arg)
+  = rnCoreExpr fun		`thenRn` \ fun' ->
+    rnCoreArg arg		`thenRn` \ arg' ->
+    returnRn (UfApp fun' arg')
+
+rnCoreExpr (UfCase scrut alts) 
+  = rnCoreExpr scrut		`thenRn` \ scrut' ->
+    rnCoreAlts alts		`thenRn` \ alts' ->
+    returnRn (UfCase scrut' alts')
+
+rnCoreExpr (UfSCC cc expr) 
+  = rnCoreExpr expr		`thenRn` \ expr' ->
+    returnRn  (UfSCC cc expr') 
+
+rnCoreExpr(UfCoerce coercion ty body)
+  = rnCoercion coercion		`thenRn` \ coercion' ->
+    rnHsType ty			`thenRn` \ ty' ->
+    rnCoreExpr body		`thenRn` \ body' ->
+    returnRn (UfCoerce coercion' ty' body')
+
+rnCoreExpr (UfLam bndr body)
+  = rnCoreBndr bndr 		$ \ bndr' ->
+    rnCoreExpr body		`thenRn` \ body' ->
+    returnRn (UfLam bndr' body')
+
+rnCoreExpr (UfLet (UfNonRec bndr rhs) body)
+  = rnCoreExpr rhs		`thenRn` \ rhs' ->
+    rnCoreBndr bndr 		$ \ bndr' ->
+    rnCoreExpr body		`thenRn` \ body' ->
+    returnRn (UfLet (UfNonRec bndr' rhs') body')
+
+rnCoreExpr (UfLet (UfRec pairs) body)
+  = rnCoreBndrs bndrs		$ \ bndrs' ->
+    mapRn rnCoreExpr rhss	`thenRn` \ rhss' ->
+    rnCoreExpr body		`thenRn` \ body' ->
+    returnRn (UfLet (UfRec (bndrs' `zip` rhss')) body')
   where
-    item1
-      = addShortErrLocLine locn1 (\ sty ->
-	ppStr "multiple default declarations") sty
+    (bndrs, rhss) = unzip pairs
+\end{code}
+
+\begin{code}
+rnCoreBndr (UfValBinder name ty) thing_inside
+  = rnHsType ty			`thenRn` \ ty' ->
+    bindLocalsRn "unfolding value" [name] $ \ [name'] ->
+    thing_inside (UfValBinder name' ty')
+    
+rnCoreBndr (UfTyBinder name kind) thing_inside
+  = bindLocalsRn "unfolding tyvar" [name] $ \ [name'] ->
+    thing_inside (UfTyBinder name' kind)
+    
+rnCoreBndr (UfUsageBinder name) thing_inside
+  = bindLocalsRn "unfolding usage" [name] $ \ [name'] ->
+    thing_inside (UfUsageBinder name')
+
+rnCoreBndrs bndrs thing_inside		-- Expect them all to be ValBinders
+  = mapRn rnHsType tys			`thenRn` \ tys' ->
+    bindLocalsRn "unfolding value" names $ \ names' ->
+    thing_inside (zipWith UfValBinder names' tys')
+  where
+    names = map (\ (UfValBinder name _) -> name) bndrs
+    tys   = map (\ (UfValBinder _   ty) -> ty)   bndrs
+\end{code}    
+
+\begin{code}
+rnCoreArg (UfVarArg v)	 = lookupOptionalOccRn v	`thenRn` \ v' -> returnRn (UfVarArg v')
+rnCoreArg (UfUsageArg u) = lookupOptionalOccRn u	`thenRn` \ u' -> returnRn (UfUsageArg u')
+rnCoreArg (UfTyArg ty)	 = rnHsType ty			`thenRn` \ ty' -> returnRn (UfTyArg ty')
+rnCoreArg (UfLitArg lit) = returnRn (UfLitArg lit)
+
+rnCoreAlts (UfAlgAlts alts deflt)
+  = mapRn rn_alt alts		`thenRn` \ alts' ->
+    rnCoreDefault deflt		`thenRn` \ deflt' ->
+    returnRn (UfAlgAlts alts' deflt')
+  where
+    rn_alt (con, bndrs, rhs) =	lookupOptionalOccRn con	`thenRn` \ con' ->
+				rnCoreBndrs bndrs	$ \ bndrs' ->
+				rnCoreExpr rhs		`thenRn` \ rhs' ->
+				returnRn (con', bndrs', rhs')
+
+rnCoreAlts (UfPrimAlts alts deflt)
+  = mapRn rn_alt alts		`thenRn` \ alts' ->
+    rnCoreDefault deflt		`thenRn` \ deflt' ->
+    returnRn (UfPrimAlts alts' deflt')
+  where
+    rn_alt (lit, rhs) =	rnCoreExpr rhs		`thenRn` \ rhs' ->
+			returnRn (lit, rhs')
+
+rnCoreDefault UfNoDefault = returnRn UfNoDefault
+rnCoreDefault (UfBindDefault bndr rhs) = rnCoreBndr bndr	$ \ bndr' ->
+					 rnCoreExpr rhs		`thenRn` \ rhs' ->
+				  	 returnRn (UfBindDefault bndr' rhs')
+
+rnCoercion (UfIn  n) = lookupOptionalOccRn n `thenRn` \ n' -> returnRn (UfIn  n')
+rnCoercion (UfOut n) = lookupOptionalOccRn n `thenRn` \ n' -> returnRn (UfOut n')
+
+rnCorePrim (UfOtherOp op) 
+  = lookupOptionalOccRn op	`thenRn` \ op' ->
+    returnRn (UfOtherOp op')
 
-    dup_item (DefaultDecl _ locn)
-      = addShortErrLocLine locn (\ sty ->
-	ppStr "here was another default declaration") sty
+rnCorePrim (UfCCallOp str casm gc arg_tys res_ty)
+  = mapRn rnHsType arg_tys	`thenRn` \ arg_tys' ->
+    rnHsType res_ty		`thenRn` \ res_ty' ->
+    returnRn (UfCCallOp str casm gc arg_tys' res_ty')
+\end{code}
 
-undefinedFixityDeclErr locn decl
-  = addErrLoc locn "fixity declaration for unknown operator" $ \ sty ->
-    ppr sty decl
+%*********************************************************
+%*							*
+\subsection{Errors}
+%*							*
+%*********************************************************
 
-dupFixityDeclErr locn dups
-  = addErrLoc locn "multiple fixity declarations for same operator" $ \ sty ->
-    ppAboves (map (ppr sty) dups)
+\begin{code}
+derivingNonStdClassErr clas sty
+  = ppCat [ppStr "non-standard class in deriving:", ppr sty clas]
 
-classTyVarNotInOpTyErr clas_tyvar sig locn
-  = addShortErrLocLine locn $ \ sty ->
-    ppHang (ppBesides [ppStr "Class type variable `", ppr sty clas_tyvar, ppStr "' does not appear in method signature:"])
+classTyVarNotInOpTyErr clas_tyvar sig sty
+  = ppHang (ppBesides [ppStr "Class type variable `", ppr sty clas_tyvar, ppStr "' does not appear in method signature:"])
 	 4 (ppr sty sig)
 
-classTyVarInOpCtxtErr clas_tyvar sig locn
-  = addShortErrLocLine locn $ \ sty ->
-    ppHang (ppBesides [ppStr "Class type variable `", ppr sty clas_tyvar, ppStr "' present in method's local overloading context:"])
+classTyVarInOpCtxtErr clas_tyvar sig sty
+  = ppHang (ppBesides [ ppStr "Class type variable `", ppr sty clas_tyvar, 
+			ppStr "' present in method's local overloading context:"])
 	 4 (ppr sty sig)
 
-dupClassAssertWarn ctxt locn dups
-  = addShortWarnLocLine locn $ \ sty ->
-    ppHang (ppBesides [ppStr "Duplicate class assertion `", ppr sty dups, ppStr "' in context:"])
+dupClassAssertWarn ctxt dups sty
+  = ppHang (ppBesides [ppStr "Duplicate class assertion `", ppr sty dups, ppStr "' in context:"])
 	 4 (ppr sty ctxt)
 \end{code}
+
+
+
+
+
+===================	OLD STUFF    ======================
+
+%*********************************************************
+%*							 *
+\subsection{SPECIALIZE data pragmas}
+%*							 *
+%*********************************************************
+
+\begin{pseudocode}
+rnSpecDataSig :: RdrNameSpecDataSig
+	      -> RnMS s RenamedSpecDataSig
+
+rnSpecDataSig (SpecDataSig tycon ty src_loc)
+  = pushSrcLocRn src_loc $
+    let
+	tyvars = filter extractHsTyNames ty
+    in
+    mkTyVarNamesEnv src_loc tyvars     	`thenRn` \ (tv_env,_) ->
+    lookupOccRn tycon			`thenRn` \ tycon' ->
+    rnHsType tv_env ty		`thenRn` \ ty' ->
+    returnRn (SpecDataSig tycon' ty' src_loc)
+
+\end{pseudocode}
+
+%*********************************************************
+%*							*
+\subsection{@SPECIALIZE instance@ user-pragmas}
+%*							*
+%*********************************************************
+
+\begin{pseudocode}
+rnSpecInstSig :: RdrNameSpecInstSig
+	      -> RnMS s RenamedSpecInstSig
+
+rnSpecInstSig (SpecInstSig clas ty src_loc)
+  = pushSrcLocRn src_loc $
+    let
+	tyvars = extractHsTyNames is_tyvar_name ty
+    in
+    mkTyVarNamesEnv src_loc tyvars     	`thenRn` \ (tv_env,_) ->
+    lookupOccRn clas			`thenRn` \ new_clas ->
+    rnHsType tv_env ty		`thenRn` \ new_ty ->
+    returnRn (SpecInstSig new_clas new_ty src_loc)
+\end{pseudocode}
diff --git a/ghc/compiler/rename/RnUtils.lhs b/ghc/compiler/rename/RnUtils.lhs
deleted file mode 100644
index acf64f71ac..0000000000
--- a/ghc/compiler/rename/RnUtils.lhs
+++ /dev/null
@@ -1,236 +0,0 @@
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
-%
-\section[RnUtils]{Functions used by both renaming passes}
-
-\begin{code}
-#include "HsVersions.h"
-
-module RnUtils (
-	SYN_IE(RnEnv), SYN_IE(QualNames),
-	SYN_IE(UnqualNames), SYN_IE(ScopeStack),
-	emptyRnEnv, initRnEnv, extendGlobalRnEnv, extendLocalRnEnv,
-	lookupRnEnv, lookupGlobalRnEnv, lookupTcRnEnv,
-	getLocalsFromRnEnv,
-
-	lubExportFlag,
-
-	qualNameErr,
-	dupNamesErr,
-	pprRnEnv -- debugging only
-    ) where
-
-IMP_Ubiq(){-uitous-}
-IMPORT_1_3(List(partition))
-
-import Bag		( Bag, emptyBag, snocBag, unionBags )
-import CmdLineOpts	( opt_GlasgowExts )
-import ErrUtils		( addShortErrLocLine )
-import FiniteMap	( emptyFM, isEmptyFM, fmToList, listToFM, keysFM,
-			  lookupFM, addListToFM, addToFM, eltsFM, FiniteMap )
-import Maybes		( maybeToBool )
-import Name		( RdrName(..),  ExportFlag(..),
-			  isQual, pprNonSym, getLocalName, isLocallyDefined )
-import PprStyle		( PprStyle(..) )
-import PrelInfo		( builtinValNamesMap, builtinTcNamesMap )
-import PrelMods		( gHC_BUILTINS )
-import Pretty
-import RnHsSyn		( RnName )
-import Util		( assertPanic )
-\end{code}
-
-*********************************************************
-*							*
-\subsection{RnEnv: renaming environment}
-*							*
-*********************************************************
-
-Separate FiniteMaps are kept for lookup up Qual names,
-Unqual names and Local names.
-
-\begin{code}
-type RnEnv = ((QualNames, UnqualNames, QualNames, UnqualNames), ScopeStack)
-
-type QualNames    = FiniteMap (FAST_STRING,Module) RnName
-type UnqualNames  = FiniteMap FAST_STRING RnName
-type ScopeStack   = FiniteMap FAST_STRING RnName
-
-emptyRnEnv  	  :: RnEnv
-initRnEnv  	  :: RnEnv
-extendGlobalRnEnv :: RnEnv -> [(RdrName,RnName)] -> [(RdrName,RnName)]
-		  -> (RnEnv, Bag (RdrName, RnName, RnName))
-extendLocalRnEnv  :: Bool -> RnEnv -> [RnName] -> (RnEnv, [RnName])
-lookupRnEnv 	  :: RnEnv -> RdrName -> Maybe RnName
-lookupGlobalRnEnv :: RnEnv -> RdrName -> Maybe RnName
-lookupTcRnEnv 	  :: RnEnv -> RdrName -> Maybe RnName
-
-getLocalsFromRnEnv :: RnEnv -> ([RnName], [RnName])
-	-- grabs the locally defined names from the unqual envs
-\end{code}
-
-If the @RdrName@ is a @Qual@, @lookupValue@ looks it up in the global
-value QualNames.  If it is @Unqual@, it looks it up first in the
-ScopeStack, and if it isn't found there, then in the global
-vaule Unqual Names.
-
-@lookupTcRnEnv@ looks up tycons/classes in the alternative global
-name space.
-
-@extendGlobalRnEnv@ adds global names to the RnEnv. It takes separate
-value and tycon/class name lists. It returns any duplicate names
-seperately.
-
-@extendRnEnv@ adds new local names to the ScopeStack in an RnEnv.
-It optionally reports any shadowed names.
-
-\begin{code}
-emptyRnEnv = ((emptyFM, emptyFM, emptyFM, emptyFM), emptyFM)
-
-    -- an emptyRnEnv is empty; the initRnEnv may have
-    -- primitive names already in it (both unqual and qual),
-    -- and quals for all the other wired-in dudes.
-
-initRnEnv
-  = if (not opt_GlasgowExts) then
-	emptyRnEnv
-    else
-	((listToFM qual, listToFM unqual, listToFM tc_qual, listToFM tc_unqual), emptyFM)
-  where
-    qual      = [ ((n,m), rn) | (OrigName m n, rn) <- fmToList builtinValNamesMap ]
-    tc_qual   = [ ((n,m), rn) | (OrigName m n, rn) <- fmToList builtinTcNamesMap  ]
-
-    builtin_qual    = filter (\ ((_,m),_) -> m == gHC_BUILTINS) qual
-    builtin_tc_qual = filter (\ ((_,m),_) -> m == gHC_BUILTINS) tc_qual
-
-    unqual    = map (\ ((n,_),rn) -> (n,rn)) builtin_qual
-    tc_unqual = map (\ ((n,_),rn) -> (n,rn)) builtin_tc_qual
-
------------------
-
-extendGlobalRnEnv ((qual, unqual, tc_qual, tc_unqual), stack) val_list tc_list
-  = ASSERT(isEmptyFM stack)
-    (((qual', unqual', tc_qual', tc_unqual'), stack), tc_dups `unionBags` dups)
-  where
-    (qual', unqual', dups)          = extend_global qual unqual val_list
-    (tc_qual', tc_unqual', tc_dups) = extend_global tc_qual tc_unqual tc_list
-
-    extend_global qual unqual rdr_list = (qual', unqual', dups)
-      where
-	(qual_list, unqual_list) = partition (isQual.fst) rdr_list
-	qual_in   = map mk_qual qual_list
-	unqual_in = map mk_unqual unqual_list
-	mk_qual   (Qual m s, rn) = ((s,m), rn)
-	mk_unqual (Unqual s, rn) = (s, rn)
-
-	(qual', qual_dups)     = do_dups qual_in qual emptyBag (\ (s,m) -> Qual m s)
-	(unqual', unqual_dups) = do_dups unqual_in unqual emptyBag Unqual
-
-	dups = unqual_dups `unionBags` qual_dups
-
-	do_dups [] fm dups to_rdr = (fm, dups)
-	do_dups ((k,v):rest) fm dups to_rdr
-          = case lookupFM fm k of
-	      Nothing  -> do_dups rest (addToFM fm k v) dups to_rdr
-	      Just cur -> do_dups rest fm (dups `snocBag` (to_rdr k, cur, v)) to_rdr
-
-
-extendLocalRnEnv report_shadows (global, stack) new_local
-  = ((global, new_stack), dups)
-  where
-    (new_stack, dups) = extend new_local stack
-
-    extend names stack
-      = if report_shadows then
-	    do_shadows names stack []
-	else
-	    (addListToFM stack [ (getLocalName n, n) | n <- names], []) 
-
-    do_shadows [] stack dups = (stack, dups)
-    do_shadows (name:names) stack dups
-      = do_shadows names (addToFM stack str name) ext_dups
-      where
-	str = getLocalName name
-	ext_dups = if maybeToBool (lookupFM stack str)
-		   then name:dups
-		   else dups
-\end{code}
-
-\begin{code}
-lookupRnEnv ((qual, unqual, _, _), stack) rdr
-  = case rdr of 
-      Unqual str   -> lookup stack str (lookupFM unqual str)
-      Qual mod str -> lookupFM qual (str,mod)
-  where
-    lookup fm thing do_on_fail
-      = case lookupFM fm thing of
-	    found@(Just name) -> found
-	    Nothing   	      -> do_on_fail
-
-lookupGlobalRnEnv ((qual, unqual, _, _), _) rdr
-  = case rdr of 
-      Unqual str   -> lookupFM unqual str
-      Qual mod str -> lookupFM qual (str,mod)
-
-lookupTcRnEnv ((_, _, tc_qual, tc_unqual), _) rdr
-  = case rdr of 
-      Unqual str   -> lookupFM tc_unqual str
-      Qual mod str -> lookupFM tc_qual (str,mod)
-
-getLocalsFromRnEnv ((_, vals, _, tcs), _)
-  = (filter isLocallyDefined (eltsFM vals),
-     filter isLocallyDefined (eltsFM tcs))
-\end{code}
-
-*********************************************************
-*							*
-\subsection{Export Flag Functions}
-*							*
-*********************************************************
-
-\begin{code}
-lubExportFlag ExportAll ExportAll = ExportAll
-lubExportFlag ExportAll ExportAbs = ExportAll
-lubExportFlag ExportAbs ExportAll = ExportAll
-lubExportFlag ExportAbs ExportAbs = ExportAbs
-\end{code}
-
-*********************************************************
-*							*
-\subsection{Errors used *more than once* in the renamer}
-*							*
-*********************************************************
-
-\begin{code}
-qualNameErr descriptor (name,locn)
-  = addShortErrLocLine locn ( \ sty ->
-    ppBesides [ppStr "invalid use of qualified ", ppStr descriptor, ppStr ": ", pprNonSym sty name ] )
-
-dupNamesErr descriptor ((name1,locn1) : dup_things) sty
-  = ppAboves (item1 : map dup_item dup_things)
-  where
-    item1
-      = addShortErrLocLine locn1 (\ sty ->
-	ppBesides [ppStr "multiple declarations of a ", ppStr descriptor, ppStr " `", 
-		   pprNonSym sty name1, ppStr "'" ]) sty
-
-    dup_item (name, locn)
-      = addShortErrLocLine locn (\ sty ->
-	ppBesides [ppStr "here was another declaration of `",
-		   pprNonSym sty name, ppStr "'" ]) sty
-
------------------
-pprRnEnv :: PprStyle -> RnEnv -> Pretty
-
-pprRnEnv sty ((qual, unqual, tc_qual, tc_unqual), stack)
-  = ppAboves [ ppStr "Stack:"
-	     , ppCat (map ppPStr (keysFM stack))
-	     , ppStr "Val qual:"
-	     , ppAboves [ppBesides [ppPStr m, ppChar '.', ppPStr n] | (n,m) <- keysFM qual]
-	     , ppStr "Val unqual:"
-	     , ppCat (map ppPStr (keysFM unqual))
-	     , ppStr "Tc qual:"
-	     , ppAboves [ppBesides [ppPStr m, ppChar '.', ppPStr n] | (n,m) <- keysFM tc_qual]
-	     , ppStr "Tc unqual:"
-	     , ppCat (map ppPStr (keysFM tc_unqual))
-	     ]
-\end{code}
diff --git a/ghc/compiler/simplCore/BinderInfo.lhs b/ghc/compiler/simplCore/BinderInfo.lhs
index 9b44d2ee41..f668ecfa43 100644
--- a/ghc/compiler/simplCore/BinderInfo.lhs
+++ b/ghc/compiler/simplCore/BinderInfo.lhs
@@ -14,8 +14,6 @@ module BinderInfo (
 	BinderInfo(..),
 	FunOrArg, DuplicationDanger, InsideSCC,  -- NB: all abstract (yay!)
 
-	inlineUnconditionally, okToInline,
-
 	addBinderInfo, orBinderInfo, andBinderInfo,
 
 	argOccurrence, funOccurrence, dangerousArgOcc, noBinderInfo,
@@ -28,7 +26,6 @@ module BinderInfo (
 
 IMP_Ubiq(){-uitous-}
 
-import CoreUnfold	( FormSummary(..) )
 import Pretty
 import Util		( panic )
 \end{code}
@@ -101,48 +98,23 @@ noBinderInfo = ManyOcc 0	-- A non-committal value
 \end{code}
 
 
-Predicates
-~~~~~~~~~~
 
 \begin{code}
-okToInline
-	:: FormSummary	-- What the thing to be inlined is like
-	-> BinderInfo 	-- How the thing to be inlined occurs
-	-> Bool		-- True => it's small enough to inline
-	-> Bool		-- True => yes, inline it
-
--- Always inline bottoms
-okToInline BottomForm occ_info small_enough
-  = True	-- Unless one of the type args is unboxed??
-		-- This used to be checked for, but I can't
-		-- see why so I've left it out.
-
--- A WHNF can be inlined if it occurs once, or is small
-okToInline form occ_info small_enough
- | is_whnf_form form
- = small_enough || one_occ
- where
-   one_occ = case occ_info of
-		OneOcc _ _ _ n_alts _ -> n_alts <= 1
-		other		      -> False
-   	
-   is_whnf_form VarForm   = True
-   is_whnf_form ValueForm = True
-   is_whnf_form other     = False
-    
--- A non-WHNF can be inlined if it doesn't occur inside a lambda,
--- and occurs exactly once or 
---     occurs once in each branch of a case and is small
-okToInline OtherForm (OneOcc _ NoDupDanger _ n_alts _) small_enough 
-  = n_alts <= 1 || small_enough
-
-okToInline form any_occ small_enough = False
+isFun :: FunOrArg -> Bool
+isFun FunOcc = True
+isFun _ = False
+
+isDupDanger :: DuplicationDanger -> Bool
+isDupDanger DupDanger = True
+isDupDanger _ = False
 \end{code}
 
 @inlineUnconditionally@ decides whether a let-bound thing can
 definitely be inlined.
 
 \begin{code}
+{-	NOT USED
+
 inlineUnconditionally :: Bool -> BinderInfo -> Bool
 
 --inlineUnconditionally ok_to_dup DeadCode = True
@@ -153,16 +125,7 @@ inlineUnconditionally ok_to_dup (OneOcc FunOcc NoDupDanger NotInsideSCC n_alt_oc
 	    -- damage, e.g., limit to M alternatives.
 
 inlineUnconditionally _ _ = False
-\end{code}
-
-\begin{code}
-isFun :: FunOrArg -> Bool
-isFun FunOcc = True
-isFun _ = False
-
-isDupDanger :: DuplicationDanger -> Bool
-isDupDanger DupDanger = True
-isDupDanger _ = False
+-}
 \end{code}
 
 
diff --git a/ghc/compiler/simplCore/ConFold.lhs b/ghc/compiler/simplCore/ConFold.lhs
index 43692600cf..59765ec6df 100644
--- a/ghc/compiler/simplCore/ConFold.lhs
+++ b/ghc/compiler/simplCore/ConFold.lhs
@@ -15,10 +15,10 @@ module ConFold	( completePrim ) where
 IMP_Ubiq(){-uitous-}
 
 import CoreSyn
-import CoreUnfold	( Unfolding(..), SimpleUnfolding )
+import CoreUnfold	( Unfolding, SimpleUnfolding )
 import Id		( idType )
 import Literal		( mkMachInt, mkMachWord, Literal(..) )
-import MagicUFs		( MagicUnfoldingFun )
+-- import MagicUFs		( MagicUnfoldingFun )
 import PrimOp		( PrimOp(..) )
 import SimplEnv
 import SimplMonad
diff --git a/ghc/compiler/simplCore/FoldrBuildWW.lhs b/ghc/compiler/simplCore/FoldrBuildWW.lhs
index 19ec58c8f9..f7fc933906 100644
--- a/ghc/compiler/simplCore/FoldrBuildWW.lhs
+++ b/ghc/compiler/simplCore/FoldrBuildWW.lhs
@@ -30,7 +30,7 @@ import Util		( panic{-ToDo:rm?-} )
 --			)
 --import IdInfo
 --import Maybes
---import SrcLoc		( mkUnknownSrcLoc, SrcLoc )
+--import SrcLoc		( noSrcLoc, SrcLoc )
 --import Util
 \end{code}
 
@@ -156,8 +156,8 @@ try_split_bind id expr =
 		-- right function to use ..
 	-- Now the bodies
 
-	c_id = mkSysLocal SLIT("fbww") c_new_uq c_ty mkUnknownSrcLoc
-	n_id = mkSysLocal SLIT("fbww") n_new_uq n_ty mkUnknownSrcLoc
+	c_id = mkSysLocal SLIT("fbww") c_new_uq c_ty noSrcLoc
+	n_id = mkSysLocal SLIT("fbww") n_new_uq n_ty noSrcLoc
 	worker_rhs
 	  = mkTyLam [] (big_args ++ [alphaTyVar]) (args++[c_id,n_id]) worker_body
 			
diff --git a/ghc/compiler/simplCore/LiberateCase.lhs b/ghc/compiler/simplCore/LiberateCase.lhs
index a67c6a6f55..3f3c76f186 100644
--- a/ghc/compiler/simplCore/LiberateCase.lhs
+++ b/ghc/compiler/simplCore/LiberateCase.lhs
@@ -17,7 +17,7 @@ liberateCase = panic "LiberateCase.liberateCase: ToDo"
 
 {- LATER: to end of file:
 import CoreUnfold	( UnfoldingGuidance(..) )
-import Id		( localiseId, toplevelishId{-debugging-} )
+import Id		( localiseId )
 import Maybes
 import Outputable
 import Pretty
@@ -169,7 +169,7 @@ libCaseBind env (Rec pairs)
 
 	-- Why "localiseId" above?  Because we're creating a new local
 	-- copy of the original binding.  In particular, the original
-	-- binding might have been for a TopLevId, and this copy clearly
+	-- binding might have been for a top-level, and this copy clearly
 	-- will not be top-level!
 
 	-- It is enough to change just the binder, because subsequent
@@ -180,12 +180,11 @@ libCaseBind env (Rec pairs)
 	-- to think that something is top-level when it isn't.
 
     rhs_small_enough rhs
-      = case (calcUnfoldingGuidance True{-sccs OK-} lIBERATE_BOMB_SIZE cON_DISCOUNT rhs) of
+      = case (calcUnfoldingGuidance True{-sccs OK-} lIBERATE_BOMB_SIZE rhs) of
 	  UnfoldNever -> False
 	  _ 	      -> True	-- we didn't BOMB, so it must be OK
 
     lIBERATE_BOMB_SIZE = bombOutSize env
-    cON_DISCOUNT = error "libCaseBind"
 \end{code}
 
 
@@ -307,8 +306,7 @@ addScrutedVar env@(LibCaseEnv bomb lvl lvl_env rec_env scruts) scrut_var
     scruts'  = (scrut_var, lvl) : scruts
     bind_lvl = case lookupIdEnv lvl_env scrut_var of
 		 Just lvl -> lvl
-		 Nothing  -> --false: ASSERT(toplevelishId scrut_var)
-			     topLevel
+		 Nothing  -> topLevel
 
 lookupRecId :: LibCaseEnv -> Id -> Maybe CoreBinding
 lookupRecId (LibCaseEnv bomb lvl lvl_env rec_env scruts) id
@@ -317,16 +315,14 @@ lookupRecId (LibCaseEnv bomb lvl lvl_env rec_env scruts) id
 #else
   = case (lookupIdEnv rec_env id) of
       xxx@(Just _) -> xxx
-      xxx	   -> --false: ASSERT(toplevelishId id)
-		      xxx
+      xxx	   -> xxx
 #endif
 
 lookupLevel :: LibCaseEnv -> Id -> LibCaseLevel
 lookupLevel (LibCaseEnv bomb lvl lvl_env rec_env scruts) id
   = case lookupIdEnv lvl_env id of
       Just lvl -> lvl
-      Nothing  -> ASSERT(toplevelishId id)
-		  topLevel
+      Nothing  -> topLevel
 
 freeScruts :: LibCaseEnv
 	   -> LibCaseLevel 	-- Level of the recursive Id
diff --git a/ghc/compiler/simplCore/OccurAnal.lhs b/ghc/compiler/simplCore/OccurAnal.lhs
index 4453c103c6..3ed4f73c0a 100644
--- a/ghc/compiler/simplCore/OccurAnal.lhs
+++ b/ghc/compiler/simplCore/OccurAnal.lhs
@@ -25,7 +25,6 @@ import CmdLineOpts	( opt_D_dump_occur_anal, SimplifierSwitch(..) )
 import CoreSyn
 import Digraph		( stronglyConnComp )
 import Id		( idWantsToBeINLINEd, isConstMethodId,
-			  externallyVisibleId,
 			  emptyIdSet, unionIdSets, mkIdSet,
 			  unitIdSet, elementOfIdSet,
 			  addOneToIdSet, SYN_IE(IdSet),
@@ -34,6 +33,7 @@ import Id		( idWantsToBeINLINEd, isConstMethodId,
 			  mapIdEnv, lookupIdEnv, SYN_IE(IdEnv),
 			  GenId{-instance Eq-}
 			)
+import Name		( isExported )
 import Maybes		( maybeToBool )
 import Outputable	( Outputable(..){-instance * (,) -} )
 import PprCore
@@ -138,7 +138,7 @@ tagBinder usage binder
     )
 
 usage_of usage binder
-  | externallyVisibleId binder = ManyOcc 0 -- Visible-elsewhere things count as many
+  | isExported binder = ManyOcc 0 -- Visible-elsewhere things count as many
   | otherwise
   = case (lookupIdEnv usage binder) of
       Nothing   -> DeadCode
diff --git a/ghc/compiler/simplCore/SATMonad.lhs b/ghc/compiler/simplCore/SATMonad.lhs
index e37a9fd975..36295dfcd8 100644
--- a/ghc/compiler/simplCore/SATMonad.lhs
+++ b/ghc/compiler/simplCore/SATMonad.lhs
@@ -37,7 +37,7 @@ import Type		( mkTyVarTy, mkSigmaTy, TyVarTemplate,
 			  InstTyEnv(..)
 			)
 import Id		( mkSysLocal, idType )
-import SrcLoc		( SrcLoc, mkUnknownSrcLoc )
+import SrcLoc		( SrcLoc, noSrcLoc )
 import UniqSupply
 import Util
 
@@ -138,9 +138,9 @@ getSATInfo var us env
 newSATName :: Id -> Type -> SatM Id
 newSATName id ty us env
   = case (getUnique us) of { unique ->
-    (mkSysLocal new_str unique ty mkUnknownSrcLoc, env) }
+    (mkSysLocal new_str unique ty noSrcLoc, env) }
   where
-    new_str = panic "SATMonad.newSATName (ToDo)" -- getOccName id _APPEND_ SLIT("_sat")
+    new_str = getOccName id _APPEND_ SLIT("_sat")
 
 getArgLists :: CoreExpr -> ([Arg Type],[Arg Id])
 getArgLists expr
@@ -218,7 +218,7 @@ saTransform binder rhs
 			    (getOccName binder _APPEND_ SLIT("_fsat"))
 			    (uniqueOf binder)
 			    (idType binder)
-			    mkUnknownSrcLoc
+			    noSrcLoc
 	    rec_body = mkValLam non_static_args
 			       ( Let (NonRec fake_binder nonrec_rhs)
 				 {-in-} (dropArgs rhs))
diff --git a/ghc/compiler/simplCore/SetLevels.lhs b/ghc/compiler/simplCore/SetLevels.lhs
index ca79733201..2b61266f63 100644
--- a/ghc/compiler/simplCore/SetLevels.lhs
+++ b/ghc/compiler/simplCore/SetLevels.lhs
@@ -29,14 +29,14 @@ import CoreSyn
 import CoreUtils	( coreExprType )
 import CoreUnfold	( whnfOrBottom )
 import FreeVars		-- all of it
-import Id		( idType, mkSysLocal, toplevelishId,
+import Id		( idType, mkSysLocal, 
 			  nullIdEnv, addOneToIdEnv, growIdEnvList,
 			  unionManyIdSets, minusIdSet, mkIdSet,
 			  idSetToList,
 			  lookupIdEnv, SYN_IE(IdEnv)
 			)
 import Pretty		( ppStr, ppBesides, ppChar, ppInt )
-import SrcLoc		( mkUnknownSrcLoc )
+import SrcLoc		( noSrcLoc )
 import Type		( isPrimType, mkTyVarTys, mkForAllTys )
 import TyVar		( nullTyVarEnv, addOneToTyVarEnv,
 			  growTyVarEnvList, lookupTyVarEnv,
@@ -269,19 +269,31 @@ lvlExpr ctxt_lvl envs (_, AnnCoerce c ty expr)
   = lvlExpr ctxt_lvl envs expr 		`thenLvl` \ expr' ->
     returnLvl (Coerce c ty expr')
 
+-- We don't split adjacent lambdas.  That is, given
+--	\x y -> (x+1,y)
+-- we don't float to give 
+--	\x -> let v = x+y in \y -> (v,y)
+-- Why not?  Because partial applications are fairly rare, and splitting
+-- lambdas makes them more expensive.
+
 lvlExpr ctxt_lvl envs@(venv, tenv) (_, AnnLam (ValBinder arg) rhs)
-  = lvlMFE incd_lvl (new_venv, tenv) rhs `thenLvl` \ rhs' ->
-    returnLvl (Lam (ValBinder (arg,incd_lvl)) rhs')
+  = lvlMFE incd_lvl (new_venv, tenv) body `thenLvl` \ body' ->
+    returnLvl (foldr (Lam . ValBinder) body' lvld_args)
   where
-    incd_lvl = incMajorLvl ctxt_lvl
-    new_venv = growIdEnvList venv [(arg,incd_lvl)]
+    incd_lvl     = incMajorLvl ctxt_lvl
+    (args, body) = annCollectValBinders rhs
+    lvld_args    = [(a,incd_lvl) | a <- (arg:args)]
+    new_venv     = growIdEnvList venv lvld_args
+
+-- We don't need to play such tricks for type lambdas, because
+-- they don't get annotated
 
-lvlExpr ctxt_lvl (venv, tenv) (_, AnnLam (TyBinder tyvar) e)
-  = lvlExpr incd_lvl (venv, new_tenv) e	`thenLvl` \ e' ->
-    returnLvl (Lam (TyBinder tyvar) e')
+lvlExpr ctxt_lvl (venv, tenv) (_, AnnLam (TyBinder tyvar) body)
+  = lvlExpr incd_lvl (venv, new_tenv) body	`thenLvl` \ body' ->
+    returnLvl (Lam (TyBinder tyvar) body')
   where
-    incd_lvl   = incMinorLvl ctxt_lvl
-    new_tenv   = addOneToTyVarEnv tenv tyvar incd_lvl
+    incd_lvl = incMinorLvl ctxt_lvl
+    new_tenv = addOneToTyVarEnv tenv tyvar incd_lvl
 
 lvlExpr ctxt_lvl (venv, tenv) (_, AnnLam (UsageBinder u) e)
   = panic "SetLevels.lvlExpr:AnnLam UsageBinder"
@@ -707,8 +719,7 @@ idLevel :: IdEnv Level -> Id -> Level
 idLevel venv v
   = case lookupIdEnv venv v of
       Just level -> level
-      Nothing    -> ASSERT(toplevelishId v)
-		    tOP_LEVEL
+      Nothing    -> tOP_LEVEL
 
 tyvarLevel :: TyVarEnv Level -> TyVar -> Level
 tyvarLevel tenv tyvar
@@ -717,6 +728,16 @@ tyvarLevel tenv tyvar
       Nothing    -> tOP_LEVEL
 \end{code}
 
+\begin{code}
+annCollectValBinders (_, (AnnLam (ValBinder arg) rhs))
+  = (arg:args, body) 
+  where
+    (args, body) = annCollectValBinders rhs
+
+annCollectValBinders body
+  = ([], body)
+\end{code}
+
 %************************************************************************
 %*									*
 \subsection{Free-To-Level Monad}
@@ -740,5 +761,5 @@ applications, to give them a fighting chance of being floated.
 newLvlVar :: Type -> LvlM Id
 
 newLvlVar ty us
-  = mkSysLocal SLIT("lvl") (getUnique us) ty mkUnknownSrcLoc
+  = mkSysLocal SLIT("lvl") (getUnique us) ty noSrcLoc
 \end{code}
diff --git a/ghc/compiler/simplCore/SimplCase.lhs b/ghc/compiler/simplCore/SimplCase.lhs
index 4318ec56ca..4a57044521 100644
--- a/ghc/compiler/simplCore/SimplCase.lhs
+++ b/ghc/compiler/simplCore/SimplCase.lhs
@@ -16,9 +16,7 @@ IMPORT_DELOOPER(SmplLoop)		( simplBind, simplExpr, MagicUnfoldingFun )
 import BinderInfo	-- too boring to try to select things...
 import CmdLineOpts	( SimplifierSwitch(..) )
 import CoreSyn
-import CoreUnfold	( Unfolding(..), UnfoldingGuidance(..),
-			  SimpleUnfolding, FormSummary
-			)
+import CoreUnfold	( Unfolding, SimpleUnfolding )
 import CoreUtils	( coreAltsType, nonErrorRHSs, maybeErrorApp,
 			  unTagBindersAlts
 			)
diff --git a/ghc/compiler/simplCore/SimplCore.lhs b/ghc/compiler/simplCore/SimplCore.lhs
index 1de8ab9daa..80d9bb3c48 100644
--- a/ghc/compiler/simplCore/SimplCore.lhs
+++ b/ghc/compiler/simplCore/SimplCore.lhs
@@ -14,11 +14,6 @@ IMPORT_1_3(IO(hPutStr,stderr))
 import AnalFBWW		( analFBWW )
 import Bag		( isEmptyBag, foldBag )
 import BinderInfo	( BinderInfo{-instance Outputable-} )
-import CgCompInfo	( uNFOLDING_CREATION_THRESHOLD,
-			  uNFOLDING_USE_THRESHOLD,
-			  uNFOLDING_OVERRIDE_THRESHOLD,
-			  uNFOLDING_CON_DISCOUNT_WEIGHT
-			)
 import CmdLineOpts	( CoreToDo(..), SimplifierSwitch(..), switchIsOn,
 			  opt_D_show_passes,
 			  opt_D_simplifier_stats,
@@ -27,29 +22,34 @@ import CmdLineOpts	( CoreToDo(..), SimplifierSwitch(..), switchIsOn,
 			  opt_FoldrBuildOn,
 			  opt_ReportWhyUnfoldingsDisallowed,
 			  opt_ShowImportSpecs,
-			  opt_UnfoldingCreationThreshold,
-			  opt_UnfoldingOverrideThreshold,
-			  opt_UnfoldingUseThreshold
+			  opt_LiberateCaseThreshold
 			)
 import CoreLint		( lintCoreBindings )
 import CoreSyn
+import CoreUtils	( coreExprType )
 import CoreUnfold
-import CoreUtils	( substCoreBindings )
+import Literal		( Literal(..), literalType, mkMachInt )
 import ErrUtils		( ghcExit )
 import FiniteMap	( FiniteMap )
 import FloatIn		( floatInwards )
 import FloatOut		( floatOutwards )
 import FoldrBuildWW	( mkFoldrBuildWW )
-import Id		( idType, toplevelishId, idWantsToBeINLINEd,
-			  unfoldingUnfriendlyId, isWrapperId,
+import Id		( mkSysLocal, setIdVisibility,
 			  nullIdEnv, addOneToIdEnv, delOneFromIdEnv,
-			  lookupIdEnv, SYN_IE(IdEnv),
+ 			  lookupIdEnv, SYN_IE(IdEnv),
 			  GenId{-instance Outputable-}
 			)
-import IdInfo		( mkUnfolding )
+import Name		( isExported, isLocallyDefined )
+import TyCon		( TyCon )
+import PrimOp		( PrimOp(..) )
+import PrelVals		( unpackCStringId, unpackCString2Id,
+			  integerZeroId, integerPlusOneId,
+			  integerPlusTwoId, integerMinusOneId
+			)
+import Type		( maybeAppDataTyCon, getAppDataTyConExpandingDicts, maybeAppSpecDataTyConExpandingDicts )
+import TysWiredIn	( stringTy )
 import LiberateCase	( liberateCase )
 import MagicUFs		( MagicUnfoldingFun )
-import Maybes		( maybeToBool )
 import Outputable	( Outputable(..){-instance * (,) -} )
 import PprCore
 import PprStyle		( PprStyle(..) )
@@ -62,16 +62,20 @@ import Specialise
 import SpecUtils	( pprSpecErrs )
 import StrictAnal	( saWwTopBinds )
 import TyVar		( nullTyVarEnv, GenTyVar{-instance Eq-} )
-import Unique		( Unique{-instance Eq-} )
-import UniqSupply	( splitUniqSupply )
-import Util		( panic{-ToDo:rm-} )
+import Unique		( integerTyConKey, ratioTyConKey, Unique{-instance Eq-} )
+import UniqSupply	( splitUniqSupply, getUnique )
+import Util		( mapAccumL, assertPanic, panic{-ToDo:rm-}, pprTrace, pprPanic )
+import SrcLoc		( noSrcLoc )
+import Constants	( tARGET_MIN_INT, tARGET_MAX_INT )
+import Bag
+import Maybes
+
 
 #ifndef OMIT_DEFORESTER
 import Deforest		( deforestProgram )
 import DefUtils		( deforestable )
 #endif
 
-isWrapperFor = panic "SimplCore.isWrapperFor (ToDo)"
 \end{code}
 
 \begin{code}
@@ -83,57 +87,46 @@ core2core :: [CoreToDo]			-- spec of what core-to-core passes to do
 	  -> FiniteMap TyCon [(Bool, [Maybe Type])]
 	  -> [CoreBinding]		-- input...
 	  -> IO
-	      ([CoreBinding],	-- results: program, plus...
-	       IdEnv Unfolding,	--  unfoldings to be exported from here
+	      ([CoreBinding],		-- results: program, plus...
 	      SpecialiseData)		--  specialisation data
 
 core2core core_todos module_name ppr_style us local_tycons tycon_specs binds
-  = if null core_todos then -- very rare, I suspect...
-	-- well, we still must do some renumbering
-	return (
-	(substCoreBindings nullIdEnv nullTyVarEnv binds us,
-	 nullIdEnv,
-	 init_specdata)
-	)
-    else
-	(if do_verbose_core2core then
+  = 	-- Print heading
+     (if opt_D_verbose_core2core then
 	    hPutStr stderr "VERBOSE CORE-TO-CORE:\n"
-	 else return ()) >>
+      else return ())					 >>
 
-	-- better do the main business
-	foldl_mn do_core_pass
-		(binds, us, nullIdEnv, init_specdata, zeroSimplCount)
+	-- Do the main business
+     foldl_mn do_core_pass
+		(binds, us1, init_specdata, zeroSimplCount)
 		core_todos
-		>>= \ (processed_binds, _, inline_env, spec_data, simpl_stats) ->
-
-	(if  opt_D_simplifier_stats
-	 then hPutStr stderr ("\nSimplifier Stats:\n")
-		>>
-	      hPutStr stderr (showSimplCount simpl_stats)
-		>>
-	      hPutStr stderr "\n"
-	 else return ()
-	) >>
-
-	return (processed_binds, inline_env, spec_data)
+		>>= \ (processed_binds, _, spec_data, simpl_stats) ->
+
+	-- Do the final tidy-up
+     let
+	final_binds = tidyCorePgm module_name us2 processed_binds
+     in
+
+	-- Report statistics
+     (if  opt_D_simplifier_stats then
+	 hPutStr stderr ("\nSimplifier Stats:\n")	>>
+	 hPutStr stderr (showSimplCount simpl_stats)	>>
+	 hPutStr stderr "\n"
+      else return ())						>>
+
+	-- 
+    return (final_binds, spec_data)
   where
+    (us1, us2) = splitUniqSupply us
     init_specdata = initSpecData local_tycons tycon_specs
 
-    do_verbose_core2core = opt_D_verbose_core2core
-
-    lib_case_threshold	-- ToDo: HACK HACK HACK : FIX ME FIX ME FIX ME
-			-- Use 4x a known threshold
-      = case opt_UnfoldingOverrideThreshold of
-	  Nothing -> 4 * uNFOLDING_USE_THRESHOLD
-	  Just xx -> 4 * xx
-
     -------------
     core_linter = if opt_DoCoreLinting
 		  then lintCoreBindings ppr_style
 		  else ( \ whodunnit spec_done binds -> binds )
 
     --------------
-    do_core_pass info@(binds, us, inline_env, spec_data, simpl_stats) to_do
+    do_core_pass info@(binds, us, spec_data, simpl_stats) to_do
       = let
 	    (us1, us2) = splitUniqSupply us
     	in
@@ -144,7 +137,7 @@ core2core core_todos module_name ppr_style us local_tycons tycon_specs binds
 					 then " (foldr/build)" else "") >>
 	       case (simplifyPgm binds simpl_sw_chkr simpl_stats us1) of
 		 (p, it_cnt, simpl_stats2)
-		   -> end_pass False us2 p inline_env spec_data simpl_stats2
+		   -> end_pass False us2 p spec_data simpl_stats2
 			       ("Simplify (" ++ show it_cnt ++ ")"
 				 ++ if switchIsOn simpl_sw_chkr SimplDoFoldrBuild
 				    then " foldr/build" else "")
@@ -153,49 +146,37 @@ core2core core_todos module_name ppr_style us local_tycons tycon_specs binds
 	    -> _scc_ "CoreDoFoldrBuildWorkerWrapper"
 	       begin_pass "FBWW" >>
 	       case (mkFoldrBuildWW us1 binds) of { binds2 ->
-	       end_pass False us2 binds2 inline_env spec_data simpl_stats "FBWW" }
+	       end_pass False us2 binds2 spec_data simpl_stats "FBWW" }
 
 	  CoreDoFoldrBuildWWAnal
 	    -> _scc_ "CoreDoFoldrBuildWWAnal"
 	       begin_pass "AnalFBWW" >>
 	       case (analFBWW binds) of { binds2 ->
-	       end_pass False us2 binds2 inline_env spec_data simpl_stats "AnalFBWW" }
+	       end_pass False us2 binds2 spec_data simpl_stats "AnalFBWW" }
 
 	  CoreLiberateCase
 	    -> _scc_ "LiberateCase"
 	       begin_pass "LiberateCase" >>
-	       case (liberateCase lib_case_threshold binds) of { binds2 ->
-	       end_pass False us2 binds2 inline_env spec_data simpl_stats "LiberateCase" }
-
-	  CoreDoCalcInlinings1	-- avoid inlinings w/ cost-centres
-	    -> _scc_ "CoreInlinings1"
-	       begin_pass "CalcInlinings" >>
-	       case (calcInlinings False inline_env binds) of { inline_env2 ->
-	       end_pass False us2 binds inline_env2 spec_data simpl_stats "CalcInlinings" }
-
-	  CoreDoCalcInlinings2  -- allow inlinings w/ cost-centres
-	    -> _scc_ "CoreInlinings2"
-	       begin_pass "CalcInlinings" >>
-	       case (calcInlinings True inline_env binds) of { inline_env2 ->
-	       end_pass False us2 binds inline_env2 spec_data simpl_stats "CalcInlinings" }
+	       case (liberateCase opt_LiberateCaseThreshold binds) of { binds2 ->
+	       end_pass False us2 binds2 spec_data simpl_stats "LiberateCase" }
 
 	  CoreDoFloatInwards
 	    -> _scc_ "FloatInwards"
 	       begin_pass "FloatIn" >>
 	       case (floatInwards binds) of { binds2 ->
-	       end_pass False us2 binds2 inline_env spec_data simpl_stats "FloatIn" }
+	       end_pass False us2 binds2 spec_data simpl_stats "FloatIn" }
 
 	  CoreDoFullLaziness
 	    -> _scc_ "CoreFloating"
 	       begin_pass "FloatOut" >>
 	       case (floatOutwards us1 binds) of { binds2 ->
-	       end_pass False us2 binds2 inline_env spec_data simpl_stats "FloatOut" }
+	       end_pass False us2 binds2 spec_data simpl_stats "FloatOut" }
 
 	  CoreDoStaticArgs
 	    -> _scc_ "CoreStaticArgs"
 	       begin_pass "StaticArgs" >>
 	       case (doStaticArgs binds us1) of { binds2 ->
-	       end_pass False us2 binds2 inline_env spec_data simpl_stats "StaticArgs" }
+	       end_pass False us2 binds2 spec_data simpl_stats "StaticArgs" }
 		-- Binds really should be dependency-analysed for static-
 		-- arg transformation... Not to worry, they probably are.
 		-- (I don't think it *dies* if they aren't [WDP 94/04/15])
@@ -204,7 +185,7 @@ core2core core_todos module_name ppr_style us local_tycons tycon_specs binds
 	    -> _scc_ "CoreStranal"
 	       begin_pass "StrAnal" >>
 	       case (saWwTopBinds us1 binds) of { binds2 ->
-	       end_pass False us2 binds2 inline_env spec_data simpl_stats "StrAnal" }
+	       end_pass False us2 binds2 spec_data simpl_stats "StrAnal" }
 
 	  CoreDoSpecialising
 	    -> _scc_ "Specialise"
@@ -227,7 +208,7 @@ core2core core_todos module_name ppr_style us local_tycons tycon_specs binds
 		   else
 			return ()) >>
 
-		   end_pass False us2 p inline_env spec_data2 simpl_stats "Specialise"
+		   end_pass False us2 p spec_data2 simpl_stats "Specialise"
 	       }
 
 	  CoreDoDeforest
@@ -237,11 +218,11 @@ core2core core_todos module_name ppr_style us local_tycons tycon_specs binds
 	    -> _scc_ "Deforestation"
 	       begin_pass "Deforestation" >>
 	       case (deforestProgram binds us1) of { binds2 ->
-	       end_pass False us2 binds2 inline_env spec_data simpl_stats "Deforestation" }
+	       end_pass False us2 binds2 spec_data simpl_stats "Deforestation" }
 #endif
 
 	  CoreDoPrintCore	-- print result of last pass
-	    -> end_pass True us2 binds inline_env spec_data simpl_stats "Print"
+	    -> end_pass True us2 binds spec_data simpl_stats "Print"
 
     -------------------------------------------------
 
@@ -250,12 +231,12 @@ core2core core_todos module_name ppr_style us local_tycons tycon_specs binds
 	then \ what -> hPutStr stderr ("*** Core2Core: "++what++"\n")
 	else \ what -> return ()
 
-    end_pass print us2 binds2 inline_env2
+    end_pass print us2 binds2
 	     spec_data2@(SpecData spec_done _ _ _ _ _ _ _)
 	     simpl_stats2 what
       = -- report verbosely, if required
-	(if (do_verbose_core2core && not print) ||
-	    (print && not do_verbose_core2core)
+	(if (opt_D_verbose_core2core && not print) ||
+	    (print && not opt_D_verbose_core2core)
 	 then
 	    hPutStr stderr ("\n*** "++what++":\n")
 		>>
@@ -271,7 +252,6 @@ core2core core_todos module_name ppr_style us local_tycons tycon_specs binds
 	return
 	(linted_binds,	-- processed binds, possibly run thru CoreLint
 	 us2,		-- UniqueSupply for the next guy
-	 inline_env2,	-- possibly-updated inline env
 	 spec_data2,	-- possibly-updated specialisation info
 	 simpl_stats2	-- accumulated simplifier stats
 	)
@@ -279,265 +259,433 @@ core2core core_todos module_name ppr_style us local_tycons tycon_specs binds
 -- here so it can be inlined...
 foldl_mn f z []     = return z
 foldl_mn f z (x:xs) = f z x	>>= \ zz ->
-		     foldl_mn f zz xs
+		      foldl_mn f zz xs
 \end{code}
 
---- ToDo: maybe move elsewhere ---
 
-For top-level, exported binders that either (a)~have been INLINEd by
-the programmer or (b)~are sufficiently ``simple'' that they should be
-inlined, we want to record this info in a suitable IdEnv.
 
-But: if something has a ``wrapper unfolding,'' we do NOT automatically
-give it a regular unfolding (exception below).  We usually assume its
-worker will get a ``regular'' unfolding.  We can then treat these two
-levels of unfolding separately (we tend to be very friendly towards
-wrapper unfoldings, for example), giving more fine-tuned control.
+%************************************************************************
+%*									*
+\subsection[SimplCore-indirections]{Eliminating indirections in Core code, and globalising}
+%*									*
+%************************************************************************
+
+Several tasks are done by @tidyCorePgm@
+
+1.  Eliminate indirections.  The point here is to transform
+	x_local = E
+	x_exported = x_local
+    ==>
+	x_exported = E
+
+2.  Make certain top-level bindings into Globals. The point is that 
+    Global things get externally-visible labels at code generation
+    time
+
+3.  Make the representation of NoRep literals explicit, and
+    float their bindings to the top level
+
+4.  Convert
+	case x of {...; x' -> ...x'...}
+    ==>
+	case x of {...; _  -> ...x... }
+    See notes in SimplCase.lhs, near simplDefault for the reasoning here.
+
+5.  *Mangle* cases involving fork# and par# in the discriminant.  The
+    original templates for these primops (see @PrelVals.lhs@) constructed
+    case expressions with boolean results solely to fool the strictness
+    analyzer, the simplifier, and anyone else who might want to fool with
+    the evaluation order.  At this point in the compiler our evaluation
+    order is safe.  Therefore, we convert expressions of the form:
+
+    	case par# e of
+    	  True -> rhs
+    	  False -> parError#
+    ==>
+    	case par# e of
+    	  _ -> rhs
+
+6.	Eliminate polymorphic case expressions.  We can't generate code for them yet.
+
+Eliminate indirections
+~~~~~~~~~~~~~~~~~~~~~~
+In @elimIndirections@, we look for things at the top-level of the form...
+\begin{verbatim}
+	x_local = ....
+	x_exported = x_local
+\end{verbatim}
+In cases we find like this, we go {\em backwards} and replace
+\tr{x_local} with \tr{x_exported}.  This save a gratuitous jump
+(from \tr{x_exported} to \tr{x_local}), and makes strictness
+information propagate better.
+
+We rely on prior eta reduction to simplify things like
+\begin{verbatim}
+	x_exported = /\ tyvars -> x_local tyvars
+==>
+	x_exported = x_local
+\end{verbatim}
+
+If more than one exported thing is equal to a local thing (i.e., the
+local thing really is shared), then we do one only:
+\begin{verbatim}
+	x_local = ....
+	x_exported1 = x_local
+	x_exported2 = x_local
+==>
+	x_exported1 = ....
+
+	x_exported2 = x_exported1
+\end{verbatim}
+
+There's a possibility of leaving unchanged something like this:
+\begin{verbatim}
+	x_local = ....
+	x_exported1 = x_local Int
+\end{verbatim}
+By the time we've thrown away the types in STG land this 
+could be eliminated.  But I don't think it's very common
+and it's dangerous to do this fiddling in STG land 
+because we might elminate a binding that's mentioned in the
+unfolding for something.
+
+General Strategy: first collect the info; then make a \tr{Id -> Id} mapping.
+Then blast the whole program (LHSs as well as RHSs) with it.
 
-The exception is: If the ``regular unfolding'' mentions no other
-global Ids (i.e., it's all PrimOps and cases and local Ids) then we
-assume it must be really good and we take it anyway.
 
-We also need to check that everything in the RHS (values and types)
-will be visible on the other side of an interface, too.
 
 \begin{code}
-calcInlinings :: Bool	-- True => inlinings with _scc_s are OK
-	      -> IdEnv Unfolding
-	      -> [CoreBinding]
-	      -> IdEnv Unfolding
-
-calcInlinings scc_s_OK inline_env_so_far top_binds
-  = let
-	result = foldl calci inline_env_so_far top_binds
-    in
-    --pprTrace "inline env:\n" (ppAboves (map pp_item (getIdEnvMapping result)))
-    result
+tidyCorePgm :: Module -> UniqSupply -> [CoreBinding] -> [CoreBinding]
+
+tidyCorePgm mod us binds_in
+  = initTM mod indirection_env us $
+    tidyTopBindings (catMaybes reduced_binds)	`thenTM` \ binds ->
+    returnTM (bagToList binds)
   where
-    pp_item (binder, details)
-      = ppCat [ppr PprDebug binder, ppStr "=>", pp_det details]
-      where
-    	pp_det NoUnfolding   = ppStr "_N_"
---LATER:	pp_det (IWantToBeINLINEd _) = ppStr "INLINE"
-    	pp_det (CoreUnfolding (SimpleUnfolding _ guide expr))
-    	  = ppAbove (ppr PprDebug guide) (ppr PprDebug expr)
-    	pp_det other	    	    = ppStr "???"
-
-    ------------
-    my_trace =  if opt_ReportWhyUnfoldingsDisallowed
-		then trace
-		else \ msg stuff -> stuff
-
-    (unfolding_creation_threshold, explicit_creation_threshold)
-      = case opt_UnfoldingCreationThreshold of
-    	  Nothing -> (uNFOLDING_CREATION_THRESHOLD, False)
-	  Just xx -> (xx, True)
-
-    unfold_use_threshold
-      = case opt_UnfoldingUseThreshold of
-	  Nothing -> uNFOLDING_USE_THRESHOLD
-	  Just xx -> xx
-
-    unfold_override_threshold
-      = case opt_UnfoldingOverrideThreshold of
-	  Nothing -> uNFOLDING_OVERRIDE_THRESHOLD
-	  Just xx -> xx
-
-    con_discount_weight = uNFOLDING_CON_DISCOUNT_WEIGHT
-
-    calci inline_env (Rec pairs)
-      = foldl (calc True{-recursive-}) inline_env pairs
-
-    calci inline_env bind@(NonRec binder rhs)
-      = calc False{-not recursive-} inline_env (binder, rhs)
-
-    ---------------------------------------
-
-    calc is_recursive inline_env (binder, rhs)
-      | not (toplevelishId binder)
-      = --pprTrace "giving up on not top-level:" (ppr PprDebug binder)
-	ignominious_defeat
-
-      | rhs_mentions_an_unmentionable
-      || (not explicit_INLINE_requested
-	  && (rhs_looks_like_a_caf || guidance_size_too_big))
-      = let
-	    my_my_trace
-	      = if explicit_INLINE_requested
-		&& not (isWrapperId binder) -- these always claim to be INLINEd
-		&& not have_inlining_already
-		then trace  		    -- we'd better have a look...
-		else my_trace
-
-	    which = if scc_s_OK then " (late):" else " (early):"
-    	in
-	my_my_trace ("unfolding disallowed for"++which++(ppShow 80 (ppr PprDebug binder))) (
-	ignominious_defeat
-	)
+    (indirection_env, reduced_binds) = mapAccumL try_bind nullIdEnv binds_in
+
+    try_bind :: IdEnv Id -> CoreBinding -> (IdEnv Id, Maybe CoreBinding)
+    try_bind env_so_far
+	     (NonRec exported_binder (Var local_id))
+	| isExported exported_binder &&		-- Only if this is exported
+	  isLocallyDefined local_id &&		-- Only if this one is defined in this
+	  not (isExported local_id) &&		-- 	module, so that we *can* change its
+					  	-- 	binding to be the exported thing!
+	  not (maybeToBool (lookupIdEnv env_so_far local_id))
+						-- Only if not already substituted for
+	= (addOneToIdEnv env_so_far local_id exported_binder, Nothing)
+
+    try_bind env_so_far bind
+	= (env_so_far, Just bind)
+\end{code}
+
+Top level bindings
+~~~~~~~~~~~~~~~~~~
+\begin{code}
+tidyTopBindings [] = returnTM emptyBag
+tidyTopBindings (b:bs)
+  = tidyTopBinding  b		$
+    tidyTopBindings bs
+
+tidyTopBinding :: CoreBinding
+	       -> TidyM (Bag CoreBinding)
+	       -> TidyM (Bag CoreBinding)
+
+tidyTopBinding (NonRec bndr rhs) thing_inside
+  = getFloats (tidyCoreExpr rhs)		`thenTM` \ (rhs',floats) ->
+    mungeTopBinder bndr				$ \ bndr' ->
+    thing_inside 				`thenTM` \ binds ->
+    returnTM ((floats `snocBag` NonRec bndr' rhs') `unionBags` binds)
+
+tidyTopBinding (Rec pairs) thing_inside
+  = mungeTopBinders binders			$ \ binders' ->
+    getFloats (mapTM tidyCoreExpr rhss)		`thenTM` \ (rhss', floats) ->
+    thing_inside				`thenTM` \ binds_inside ->
+    returnTM ((floats `snocBag` Rec (binders' `zip` rhss')) `unionBags` binds_inside)
+  where
+    (binders, rhss) = unzip pairs
+\end{code}
+
+
+Local Bindings
+~~~~~~~~~~~~~~
+\begin{code}
+tidyCoreBinding (NonRec bndr rhs)
+  = tidyCoreExpr rhs		`thenTM` \ rhs' ->
+    returnTM (NonRec bndr rhs')
+
+tidyCoreBinding (Rec pairs)
+  = mapTM do_one pairs	`thenTM` \ pairs' ->
+    returnTM (Rec pairs')
+  where
+    do_one (bndr,rhs) = tidyCoreExpr rhs	`thenTM` \ rhs' ->
+			returnTM (bndr, rhs')
+
+\end{code}
 
-      | rhs `isWrapperFor` binder
-	-- Don't add an explicit "unfolding"; let the worker/wrapper
-	-- stuff do its thing.  INLINE things don't get w/w'd, so
-	-- they will be OK.
-      = ignominious_defeat
-
-#if ! OMIT_DEFORESTER
-	-- For the deforester: bypass the barbed wire for recursive
-	-- functions that want to be inlined and are tagged deforestable
-	-- by the user, allowing these things to be communicated
-	-- across module boundaries.
-
-      | is_recursive &&
-	explicit_INLINE_requested &&
-	deforestable binder &&
-	scc_s_OK			-- hack, only get them in
-					-- calc_inlinings2
-      = glorious_success UnfoldAlways
-#endif
 
-      | is_recursive && not rhs_looks_like_a_data_val
-	-- The only recursive defns we are prepared to tolerate at the
-	-- moment is top-level very-obviously-a-data-value ones.
-	-- We *need* these for dictionaries to be exported!
-      = --pprTrace "giving up on rec:" (ppr PprDebug binder)
-    	ignominious_defeat
-
-	-- Not really interested unless it's exported, but doing it
-	-- this way (not worrying about export-ness) gets us all the
-	-- workers/specs, etc., too; which we will need for generating
-	-- interfaces.  We are also not interested if this binder is
-	-- in the environment we already have (perhaps from a previous
-	-- run of calcInlinings -- "earlier" is presumed to mean
-	-- "better").
-
-      | explicit_INLINE_requested
-      = glorious_success UnfoldAlways
-
-      | otherwise
-      = glorious_success guidance
-
-      where
-	guidance
-	  = calcUnfoldingGuidance scc_s_OK max_out_threshold rhs
-	  where
-    	    max_out_threshold = if explicit_INLINE_requested
-				then 100000 -- you asked for it, you got it
-				else unfolding_creation_threshold
-
-	guidance_size
-	  = case guidance of
-	      UnfoldAlways  	    	  -> 0 -- *extremely* small
-	      UnfoldIfGoodArgs _ _ _ size -> size
-
-	guidance_size_too_big
-	    -- Does the guidance suggest that this unfolding will
-	    -- be of no use *no matter* the arguments given to it?
-	    -- Could be more sophisticated...
-	  = not (couldBeSmallEnoughToInline con_discount_weight unfold_use_threshold guidance)
-
-
-	rhs_looks_like_a_caf = not (whnfOrBottom rhs)
-
-	rhs_looks_like_a_data_val
-	  = case (collectBinders rhs) of
-	      (_, _, [], Con _ _) -> True
-	      other		  -> False
-
-	rhs_arg_tys
-	  = case (collectBinders rhs) of
-	      (_, _, val_binders, _) -> map idType val_binders
-
-	(mentioned_ids, _, _, mentions_litlit)
-	  = mentionedInUnfolding (\x -> x) rhs
-
-	rhs_mentions_an_unmentionable
-	  = foldBag (||) unfoldingUnfriendlyId False mentioned_ids
-	    || mentions_litlit
-	    -- ToDo: probably need to chk tycons/classes...
-
-	mentions_no_other_ids = isEmptyBag mentioned_ids
-
-	explicit_INLINE_requested
-	    -- did it come from a user {-# INLINE ... #-}?
-	    -- (Warning: must avoid including wrappers.)
-	  = idWantsToBeINLINEd binder
-	    && not (rhs `isWrapperFor` binder)
-
-	have_inlining_already = maybeToBool (lookupIdEnv inline_env binder)
-
-	ignominious_defeat = inline_env  -- just give back what we got
-
-	{-
-	    "glorious_success" is ours if we've found a suitable unfolding.
-
-	    But we check for a couple of fine points.
-
-	    (1) If this Id already has an inlining in the inline_env,
-		we don't automatically take it -- the earlier one is
-		"likely" to be better.
-
-		But if the new one doesn't mention any other global
-		Ids, and it's pretty small (< UnfoldingOverrideThreshold),
-		then we take the chance that the new one *is* better.
-
-	    (2) If we have an Id w/ a worker/wrapper split (with
-		an unfolding for the wrapper), we tend to want to keep
-		it -- and *nuke* any inlining that we conjured up
-		earlier.
-
-		But, again, if this unfolding doesn't mention any
-		other global Ids (and small enough), then it is
-		probably better than the worker/wrappery, so we take
-		it.
-	-}
-	glorious_success guidance
-	  = let
-		new_env = addOneToIdEnv inline_env binder (mkUnfolding guidance rhs)
-
-		foldr_building = opt_FoldrBuildOn
-	    in
-	    if (not have_inlining_already) then
-		-- Not in env: we take it no matter what
-		-- NB: we could check for worker/wrapper-ness,
-		-- but the truth is we probably haven't run
-		-- the strictness analyser yet.
-		new_env
-
-	    else if explicit_INLINE_requested then
-		-- If it was a user INLINE, then we know it's already
-		-- in the inline_env; we stick with what we already
-		-- have.
-		--pprTrace "giving up on INLINE:" (ppr PprDebug binder)
-		ignominious_defeat
-
-	    else if isWrapperId binder then
-		-- It's in the env, but we have since worker-wrapperised;
-		-- we either take this new one (because it's so good),
-		-- or we *undo* the one in the inline_env, so the
-		-- wrapper-inlining will take over.
-
-		if mentions_no_other_ids {- *** && size <= unfold_override_threshold -} then
-		    new_env
-		else
-		    delOneFromIdEnv inline_env binder
-
-	    else
-		-- It's in the env, nothing to do w/ worker wrapper;
-		-- we'll take it if it is better.
-
-		if not foldr_building	-- ANDY hates us... (see below)
-		&& mentions_no_other_ids
-		&& guidance_size <= unfold_override_threshold then
-		    new_env
-		else
-		    --pprTrace "giving up on final hurdle:" (ppCat [ppr PprDebug binder, ppInt guidance_size, ppInt unfold_override_threshold])
-		    ignominious_defeat -- and at the last hurdle, too!
+Expressions
+~~~~~~~~~~~
+\begin{code}
+tidyCoreExpr (Var v) = lookupTM v	`thenTM` \ v' ->
+		       returnTM (Var v')
+
+tidyCoreExpr (Lit lit)
+  = litToRep lit	`thenTM` \ (_, lit_expr) ->
+    returnTM lit_expr
+
+tidyCoreExpr (App fun arg)
+  = tidyCoreExpr fun	`thenTM` \ fun' ->
+    tidyCoreArg arg	`thenTM` \ arg' ->
+    returnTM (App fun' arg')
+
+tidyCoreExpr (Con con args)
+  = mapTM tidyCoreArg args	`thenTM` \ args' ->
+    returnTM (Con con args')
+
+tidyCoreExpr (Prim prim args)
+  = mapTM tidyCoreArg args	`thenTM` \ args' ->
+    returnTM (Prim prim args')
+
+tidyCoreExpr (Lam bndr body)
+  = tidyCoreExpr body		`thenTM` \ body' ->
+    returnTM (Lam bndr body')
+
+tidyCoreExpr (Let bind body)
+  = tidyCoreBinding bind	`thenTM` \ bind' ->
+    tidyCoreExpr body		`thenTM` \ body' ->
+    returnTM (Let bind' body')
+
+tidyCoreExpr (SCC cc body)
+  = tidyCoreExpr body		`thenTM` \ body' ->
+    returnTM (SCC cc body')
+
+tidyCoreExpr (Coerce coercion ty body)
+  = tidyCoreExpr body		`thenTM` \ body' ->
+    returnTM (Coerce coercion ty body')
+
+-- Wierd case for par, seq, fork etc. See notes above.
+tidyCoreExpr (Case scrut@(Prim op args) (PrimAlts _ (BindDefault binder rhs)))
+  | funnyParallelOp op
+  = tidyCoreExpr scrut			`thenTM` \ scrut' ->
+    tidyCoreExpr rhs			`thenTM` \ rhs' ->
+    returnTM (Case scrut' (PrimAlts [] (BindDefault binder rhs')))
+
+-- Eliminate polymorphic case, for which we can't generate code just yet
+tidyCoreExpr (Case scrut (AlgAlts [] (BindDefault deflt_bndr rhs)))
+  | not (maybeToBool (maybeAppSpecDataTyConExpandingDicts (coreExprType scrut)))
+  = pprTrace "Warning: discarding polymophic case:" (ppr PprDebug scrut) $
+    case scrut of
+	Var v -> extendEnvTM deflt_bndr v (tidyCoreExpr rhs)
+	other -> tidyCoreExpr (Let (NonRec deflt_bndr scrut) rhs)
+  
+tidyCoreExpr (Case scrut alts)
+  = tidyCoreExpr scrut			`thenTM` \ scrut' ->
+    tidy_alts alts			`thenTM` \ alts' ->
+    returnTM (Case scrut' alts')
+  where
+    tidy_alts (AlgAlts alts deflt)
+	= mapTM tidy_alg_alt alts	`thenTM` \ alts' ->
+	  tidy_deflt deflt		`thenTM` \ deflt' ->
+	  returnTM (AlgAlts alts' deflt')
+
+    tidy_alts (PrimAlts alts deflt)
+	= mapTM tidy_prim_alt alts	`thenTM` \ alts' ->
+	  tidy_deflt deflt		`thenTM` \ deflt' ->
+	  returnTM (PrimAlts alts' deflt')
+
+    tidy_alg_alt (con,bndrs,rhs) = tidyCoreExpr rhs	`thenTM` \ rhs' ->
+				   returnTM (con,bndrs,rhs')
+
+    tidy_prim_alt (lit,rhs) = tidyCoreExpr rhs	`thenTM` \ rhs' ->
+			      returnTM (lit,rhs')
+
+	-- We convert	case x of {...; x' -> ...x'...}
+	--	to
+	--		case x of {...; _  -> ...x... }
+	--
+	-- See notes in SimplCase.lhs, near simplDefault for the reasoning.
+	-- It's quite easily done: simply extend the environment to bind the
+	-- default binder to the scrutinee.
+
+    tidy_deflt NoDefault = returnTM NoDefault
+    tidy_deflt (BindDefault bndr rhs)
+	= extend_env (tidyCoreExpr rhs)	`thenTM` \ rhs' ->
+	  returnTM (BindDefault bndr rhs')
+	where
+ 	  extend_env = case scrut of
+			    Var v -> extendEnvTM bndr v
+			    other -> \x -> x
 \end{code}
 
-ANDY, on the hatred of the check above; why obliterate it?  Consider
+Arguments
+~~~~~~~~~
+\begin{code}
+tidyCoreArg :: CoreArg -> TidyM CoreArg
+
+tidyCoreArg (VarArg v)
+  = lookupTM v	`thenTM` \ v' ->
+    returnTM (VarArg v')
+
+tidyCoreArg (LitArg lit)
+  = litToRep lit		`thenTM` \ (lit_ty, lit_expr) ->
+    case lit_expr of
+	Var v -> returnTM (VarArg v)
+	Lit l -> returnTM (LitArg l)
+	other -> addTopFloat lit_ty lit_expr	`thenTM` \ v ->
+		 returnTM (VarArg v)
+
+tidyCoreArg (TyArg ty)   = returnTM (TyArg ty)
+tidyCoreArg (UsageArg u) = returnTM (UsageArg u)
+\end{code}
+
+
+%************************************************************************
+%*									*
+\subsection[coreToStg-lits]{Converting literals}
+%*									*
+%************************************************************************
+
+Literals: the NoRep kind need to be de-no-rep'd.
+We always replace them with a simple variable, and float a suitable
+binding out to the top level.
+
+\begin{code}
+		     
+litToRep :: Literal -> TidyM (Type, CoreExpr)
+
+litToRep (NoRepStr s)
+  = returnTM (stringTy, rhs)
+  where
+    rhs = if (any is_NUL (_UNPK_ s))
+
+	  then	 -- Must cater for NULs in literal string
+		mkGenApp (Var unpackCString2Id)
+			 [LitArg (MachStr s),
+		      	  LitArg (mkMachInt (toInteger (_LENGTH_ s)))]
+
+	  else	-- No NULs in the string
+		App (Var unpackCStringId) (LitArg (MachStr s))
+
+    is_NUL c = c == '\0'
+\end{code}
+
+If an Integer is small enough (Haskell implementations must support
+Ints in the range $[-2^29+1, 2^29-1]$), wrap it up in @int2Integer@;
+otherwise, wrap with @litString2Integer@.
+
+\begin{code}
+litToRep (NoRepInteger i integer_ty)
+  = returnTM (integer_ty, rhs)
+  where
+    rhs | i == 0    = Var integerZeroId	  -- Extremely convenient to look out for
+  	| i == 1    = Var integerPlusOneId  -- a few very common Integer literals!
+  	| i == 2    = Var integerPlusTwoId
+  	| i == (-1) = Var integerMinusOneId
+  
+  	| i > tARGET_MIN_INT &&		-- Small enough, so start from an Int
+	  i < tARGET_MAX_INT
+	= Prim Int2IntegerOp [LitArg (mkMachInt i)]
+  
+  	| otherwise 			-- Big, so start from a string
+	= Prim Addr2IntegerOp [LitArg (MachStr (_PK_ (show i)))]
+
+
+litToRep (NoRepRational r rational_ty)
+  = tidyCoreArg (LitArg (NoRepInteger (numerator   r) integer_ty))	`thenTM` \ num_arg ->
+    tidyCoreArg (LitArg (NoRepInteger (denominator r) integer_ty))	`thenTM` \ denom_arg ->
+    returnTM (rational_ty, Con ratio_data_con [num_arg, denom_arg])
+  where
+    (ratio_data_con, integer_ty)
+      = case (maybeAppDataTyCon rational_ty) of
+	  Just (tycon, [i_ty], [con])
+	    -> ASSERT(is_integer_ty i_ty && uniqueOf tycon == ratioTyConKey)
+	       (con, i_ty)
+
+	  _ -> (panic "ratio_data_con", panic "integer_ty")
+
+    is_integer_ty ty
+      = case (maybeAppDataTyCon ty) of
+	  Just (tycon, [], _) -> uniqueOf tycon == integerTyConKey
+	  _		      -> False
+
+litToRep other_lit = returnTM (literalType other_lit, Lit other_lit)
+\end{code}
+
+\begin{code}
+funnyParallelOp SeqOp  = True
+funnyParallelOp ParOp  = True
+funnyParallelOp ForkOp = True
+funnyParallelOp _      = False
+\end{code}  
+
+
+%************************************************************************
+%*									*
+\subsection{The monad}
+%*									*
+%************************************************************************
+
+\begin{code}
+type TidyM a =  Module
+	     -> IdEnv Id
+	     -> (UniqSupply, Bag CoreBinding)
+	     -> (a, (UniqSupply, Bag CoreBinding))
+
+initTM mod env us m
+  = case m mod env (us,emptyBag) of
+	(result, (us',floats)) -> result
+
+returnTM v mod env usf = (v, usf)
+thenTM m k mod env usf = case m mod env usf of
+			   (r, usf') -> k r mod env usf'
+
+mapTM f []     = returnTM []
+mapTM f (x:xs) = f x	`thenTM` \ r ->
+		 mapTM f xs	`thenTM` \ rs ->
+		 returnTM (r:rs)
+\end{code}
+
+
+\begin{code}
+getFloats :: TidyM a -> TidyM (a, Bag CoreBinding)
+getFloats m mod env (us,floats)
+  = case m mod env (us,emptyBag) of
+	(r, (us',floats')) -> ((r, floats'), (us',floats))
+
+
+-- Need to extend the environment when we munge a binder, so that occurrences
+-- of the binder will print the correct way (i.e. as a global not a local)
+mungeTopBinder :: Id -> (Id -> TidyM a) -> TidyM a
+mungeTopBinder id thing_inside mod env usf
+  = case lookupIdEnv env id of
+	Just global -> thing_inside global mod env usf
+	Nothing     -> thing_inside new_global mod new_env usf
+		    where
+		       new_env    = addOneToIdEnv env id new_global
+		       new_global = setIdVisibility mod id
+
+mungeTopBinders []     k = k []
+mungeTopBinders (b:bs) k = mungeTopBinder b	$ \ b' ->
+			   mungeTopBinders bs	$ \ bs' ->
+			   k (b' : bs')
+
+addTopFloat :: Type -> CoreExpr -> TidyM Id
+addTopFloat lit_ty lit_rhs mod env (us, floats)
+  = (lit_id, (us', floats `snocBag` NonRec lit_id lit_rhs))
+  where
+    lit_local = mkSysLocal SLIT("nrlit") uniq lit_ty noSrcLoc
+    lit_id = setIdVisibility mod lit_local
+    (us', us1) = splitUniqSupply us
+    uniq = getUnique us1
+
+lookupTM v mod env usf
+  = case lookupIdEnv env v of
+	Nothing -> (v, usf)
+	Just v' -> (v', usf)
+
+extendEnvTM v v' m mod env usf
+  = m mod (addOneToIdEnv env v v') usf
+\end{code}
 
- head xs = foldr (\ x _ -> x) (_|_) xs
 
-This then is exported via a pragma. However,
-*if* you include the extra code above, you will
-export the non-foldr/build version.
diff --git a/ghc/compiler/simplCore/SimplEnv.lhs b/ghc/compiler/simplCore/SimplEnv.lhs
index b2be6a1510..26d6029ae2 100644
--- a/ghc/compiler/simplCore/SimplEnv.lhs
+++ b/ghc/compiler/simplCore/SimplEnv.lhs
@@ -50,12 +50,13 @@ IMPORT_DELOOPER(SmplLoop)		-- breaks the MagicUFs / SimplEnv loop
 import BinderInfo	( orBinderInfo, andBinderInfo, noBinderInfo,
 			  BinderInfo(..){-instances, too-}, FunOrArg, DuplicationDanger, InsideSCC
 			)
-import CgCompInfo	( uNFOLDING_CREATION_THRESHOLD )
-import CmdLineOpts	( switchIsOn, intSwitchSet, SimplifierSwitch(..), SwitchResult(..) )
+import CmdLineOpts	( switchIsOn, intSwitchSet, opt_UnfoldingCreationThreshold,
+			  SimplifierSwitch(..), SwitchResult(..)
+			)
 import CoreSyn
 import CoreUnfold	( mkFormSummary, exprSmallEnoughToDup, 
-			  Unfolding(..), SimpleUnfolding(..), FormSummary(..),
-			  mkSimpleUnfolding,
+			  Unfolding(..), UfExpr, RdrName,
+			  SimpleUnfolding(..), FormSummary(..),
 			  calcUnfoldingGuidance, UnfoldingGuidance(..)
 			)
 import CoreUtils	( coreExprCc, unTagBinders )
@@ -66,7 +67,6 @@ import Id		( idType, getIdUnfolding, getIdStrictness, idWantsToBeINLINEd,
 			  nullIdEnv, growIdEnvList, rngIdEnv, lookupIdEnv,
 			  addOneToIdEnv, modifyIdEnv, mkIdSet, modifyIdEnv_Directly,
 			  SYN_IE(IdEnv), SYN_IE(IdSet), GenId )
-import IdInfo		( bottomIsGuaranteed, StrictnessInfo )
 import Literal		( isNoRepLit, Literal{-instances-} )
 import Maybes		( maybeToBool, expectJust )
 import Name		( isLocallyDefined )
@@ -472,13 +472,37 @@ inline t everywhere.  But if we do *both* these reasonable things we get
 	in
 	...t...
 
-(The t in the body doesn't get inlined because by the time the recursive
-group is done we see that t's RHS isn't an atom.)
+Bad news!  (f x) is duplicated!  (The t in the body doesn't get
+inlined because by the time the recursive group is done we see that
+t's RHS isn't an atom.)
+
+Our solution is this: 
+	(a) we inline un-simplified RHSs, and then simplify
+	    them in a clone-only environment.  
+	(b) we inline only variables and values
+This means taht
+
+
+	r = f x 	==>  r = f x
+	t = r		==>  t = r
+	x = ...t...	==>  x = ...r...
+     in			   in
+	t		     r
 
-Bad news!  (f x) is duplicated!  Our solution is to only be prepared to
-inline RHSs in their own RHSs if they are *values* (lambda or constructor).
+Now t is dead, and we're home.
 
-This means that silly x=y  bindings in recursive group will never go away. Sigh.  ToDo!
+Most silly x=y  bindings in recursive group will go away.  But not all:
+
+	let y = 1:x
+	    x = y
+
+Here, we can't inline x because it's in an argument position. so we'll just replace
+with a clone of y.  Instead we'll probably inline y (a small value) to give
+
+	let y = 1:x
+	    x = 1:y
+	
+which is OK if not clever.
 -}
 
 extendEnvForRecBinding env@(SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps)
@@ -486,9 +510,10 @@ extendEnvForRecBinding env@(SimplEnv chkr encl_cc ty_env in_id_env out_id_env co
   = SimplEnv chkr encl_cc ty_env in_id_env new_out_id_env con_apps
   where
     new_out_id_env = case (form_summary, guidance) of
-			(ValueForm, UnfoldNever) -> out_id_env		-- No new stuff to put in
-			(ValueForm, _)		 -> out_id_env_with_unfolding
-		        other	    		 -> out_id_env		-- Not a value
+			(_, UnfoldNever)	-> out_id_env		-- No new stuff to put in
+			(ValueForm, _)		-> out_id_env_with_unfolding
+			(VarForm, _)		-> out_id_env_with_unfolding
+		        other	    		-> out_id_env		-- Not a value or variable
 
 	-- If there is an unfolding, we add rhs-info for out_id,
 	-- No need to modify occ info because RHS is pre-simplification
@@ -496,19 +521,18 @@ extendEnvForRecBinding env@(SimplEnv chkr encl_cc ty_env in_id_env out_id_env co
 			        (out_id, occ_info, rhs_info)
 
 	-- Compute unfolding details
+	-- Note that we use the "old" environment, that just has clones of the rec-bound vars,
+	-- in the InUnfolding.  So if we ever use the InUnfolding we'll just inline once.
+	-- Only if the thing is still small enough next time round will we inline again.
     rhs_info     = InUnfolding env (SimpleUnfolding form_summary guidance old_rhs)
     form_summary = mkFormSummary old_rhs
     guidance     = mkSimplUnfoldingGuidance chkr out_id (unTagBinders old_rhs)
 
 
 mkSimplUnfoldingGuidance chkr out_id rhs
-  | not (switchIsOn chkr IgnoreINLINEPragma) && idWantsToBeINLINEd out_id
-  = UnfoldAlways
-
-  | otherwise
-  = calcUnfoldingGuidance True{-sccs OK-} bOMB_OUT_SIZE rhs
+  = calcUnfoldingGuidance inline_prag opt_UnfoldingCreationThreshold rhs
   where
-    bOMB_OUT_SIZE = getSimplIntSwitch chkr SimplUnfoldingCreationThreshold
+    inline_prag = not (switchIsOn chkr IgnoreINLINEPragma) && idWantsToBeINLINEd out_id
 
 extendEnvGivenRhsInfo :: SimplEnv -> OutId -> BinderInfo -> RhsInfo -> SimplEnv
 extendEnvGivenRhsInfo env@(SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps)
diff --git a/ghc/compiler/simplCore/SimplMonad.lhs b/ghc/compiler/simplCore/SimplMonad.lhs
index 20662f8921..879bd2c9da 100644
--- a/ghc/compiler/simplCore/SimplMonad.lhs
+++ b/ghc/compiler/simplCore/SimplMonad.lhs
@@ -28,7 +28,7 @@ IMPORT_DELOOPER(SmplLoop)		-- well, cheating sort of
 import Id		( mkSysLocal, mkIdWithNewUniq )
 import CoreUnfold	( SimpleUnfolding )
 import SimplEnv
-import SrcLoc		( mkUnknownSrcLoc )
+import SrcLoc		( noSrcLoc )
 import TyVar		( cloneTyVar )
 import UniqSupply	( getUnique, getUniques, splitUniqSupply,
 			  UniqSupply
@@ -312,7 +312,7 @@ combineSimplCounts (SimplCount n1 stuff1) (SimplCount n2 stuff2)
 \begin{code}
 newId :: Type -> SmplM Id
 newId ty us sc
-  = (mkSysLocal SLIT("s") uniq ty mkUnknownSrcLoc, sc)
+  = (mkSysLocal SLIT("s") uniq ty noSrcLoc, sc)
   where
     uniq = getUnique us
 
@@ -321,7 +321,7 @@ newIds tys us sc
   = (zipWithEqual "newIds" mk_id tys uniqs, sc)
   where
     uniqs  = getUniques (length tys) us
-    mk_id ty uniq = mkSysLocal SLIT("s") uniq ty mkUnknownSrcLoc
+    mk_id ty uniq = mkSysLocal SLIT("s") uniq ty noSrcLoc
 
 cloneTyVarSmpl :: TyVar -> SmplM TyVar
 
diff --git a/ghc/compiler/simplCore/SimplPgm.lhs b/ghc/compiler/simplCore/SimplPgm.lhs
index a2d2797cb4..edfe71a173 100644
--- a/ghc/compiler/simplCore/SimplPgm.lhs
+++ b/ghc/compiler/simplCore/SimplPgm.lhs
@@ -16,8 +16,7 @@ import CmdLineOpts	( opt_D_verbose_core2core,
 import CoreSyn
 import CoreUnfold	( SimpleUnfolding )
 import CoreUtils	( substCoreExpr )
-import Id		( externallyVisibleId,
-			  mkIdEnv, lookupIdEnv, SYN_IE(IdEnv),
+import Id		( mkIdEnv, lookupIdEnv, SYN_IE(IdEnv),
 			  GenId{-instance Ord3-}
 			)
 import Maybes		( catMaybes )
@@ -44,8 +43,7 @@ simplifyPgm :: [CoreBinding]	-- input
 simplifyPgm binds s_sw_chkr simpl_stats us
   = case (splitUniqSupply us)		     of { (s1, s2) ->
     case (initSmpl s1 (simpl_pgm 0 1 binds)) of { ((pgm2, it_count, simpl_stats2), _) ->
-    case (tidy_top pgm2 s2) 	    	     of { pgm3 ->
-    (pgm3, it_count, combineSimplCounts simpl_stats simpl_stats2) }}}
+    (pgm2, it_count, combineSimplCounts simpl_stats simpl_stats2) }}
   where
     simpl_switch_is_on  = switchIsOn s_sw_chkr
 
@@ -99,104 +97,3 @@ simplifyPgm binds s_sw_chkr simpl_stats us
 	)
 \end{code}
 
-In @tidy_top@, we look for things at the top-level of the form...
-\begin{verbatim}
-x_local = ....
-
-x_exported = x_local	-- or perhaps...
-
-x_exported = /\ tyvars -> x_local tyvars -- where this is eta-reducible
-\end{verbatim}
-In cases we find like this, we go {\em backwards} and replace
-\tr{x_local} with \tr{x_exported}.  This save a gratuitous jump
-(from \tr{x_exported} to \tr{x_local}), and makes strictness
-information propagate better.
-
-If more than one exported thing is equal to a local thing (i.e., the
-local thing really is shared), then obviously we give up.
-
-Strategy: first collect the info; then make a \tr{Id -> Id} mapping.
-Then blast the whole program (LHSs as well as RHSs) with it.
-
-\begin{code}
-type BlastEnv = IdEnv Id  -- domain is local Ids; range is exported Ids
-
-not_elem = isn'tIn "undup"
-
-tidy_top :: [CoreBinding] -> UniqSM [CoreBinding]
-
-tidy_top binds_in
-  = if null blast_alist then
-	returnUs binds_in    -- no joy there
-    else
-	mapUs blast binds_in	`thenUs` \ binds_maybe ->
-	returnUs (catMaybes binds_maybe)
-  where
-    blast_alist  = undup (foldl find_cand [] binds_in)
-    blast_id_env = mkIdEnv blast_alist
-    blast_val_env= mkIdEnv [ (l, Var e) | (l,e) <- blast_alist ]
-    blast_all_exps = map snd blast_alist
-
-    ---------
-    find_cand blast_list (Rec _) = blast_list	-- recursively paranoid, as usual
-
-    find_cand blast_list (NonRec binder rhs)
-      = if not (externallyVisibleId binder) then
-	   blast_list
-    	else
-	   case rhs_equiv_to_local_var rhs of
-	     Nothing    -> blast_list
-	     Just local -> (local, binder) : blast_list -- tag it on
-
-    ------------------------------------------
-    -- if an Id appears >1 time in the domain,
-    -- *all* occurrences must be expunged.
-    undup :: [(Id, Id)] -> [(Id, Id)]
-
-    undup blast_list
-      = let
-	    (singles, dups) = removeDups compare blast_list
-	    list_of_dups    = concat dups
-	in
-	[ s | s <- singles, s `not_elem` list_of_dups ]
-      where
-	compare (x,_) (y,_) = x `cmp` y
-
-    ------------------------------------------
-    rhs_equiv_to_local_var (Var x)
-      = if externallyVisibleId x then Nothing else Just x
-
-    rhs_equiv_to_local_var expr = Nothing
-
-    ------------------------------------------
-    -- "blast" does the substitution:
-    -- returns Nothing  if a binding goes away
-    -- returns "Just b" to give back a fixed-up binding
-
-    blast :: CoreBinding -> UniqSM (Maybe CoreBinding)
-
-    blast (Rec pairs)
-      = mapUs blast_pr pairs `thenUs` \ blasted_pairs ->
-	returnUs (Just (Rec blasted_pairs))
-      where
-	blast_pr (binder, rhs)
-	  = substCoreExpr blast_val_env nullTyVarEnv rhs `thenUs` \ new_rhs ->
-	    returnUs (
-	    case (lookupIdEnv blast_id_env binder) of
-	      Just exportee -> (exportee, new_rhs)
-	      Nothing	    -> (binder,   new_rhs)
-	    )
-
-    blast (NonRec binder rhs)
-      = if binder `is_elem` blast_all_exps then
-	   returnUs Nothing -- this binding dies!
-    	else
-	   substCoreExpr blast_val_env nullTyVarEnv rhs `thenUs` \ new_rhs ->
-	   returnUs (Just (
-	   case (lookupIdEnv blast_id_env binder) of
-	     Just exportee -> NonRec exportee new_rhs
-	     Nothing	   -> NonRec binder   new_rhs
-	   ))
-      where
-	is_elem = isIn "blast"
-\end{code}
diff --git a/ghc/compiler/simplCore/SimplUtils.lhs b/ghc/compiler/simplCore/SimplUtils.lhs
index fa14e39a33..0017880516 100644
--- a/ghc/compiler/simplCore/SimplUtils.lhs
+++ b/ghc/compiler/simplCore/SimplUtils.lhs
@@ -31,7 +31,7 @@ import CoreUnfold	( SimpleUnfolding, mkFormSummary, FormSummary(..) )
 import Id		( idType, isBottomingId, idWantsToBeINLINEd, dataConArgTys,
 			  getIdArity, GenId{-instance Eq-}
 			)
-import IdInfo		( arityMaybe )
+import IdInfo		( ArityInfo(..) )
 import Maybes		( maybeToBool )
 import PrelVals		( augmentId, buildId )
 import PrimOp		( primOpIsCheap )
@@ -218,12 +218,7 @@ eta_fun expr@(Var v)
   | isBottomingId v		-- Bottoming ids have "infinite arity"
   = 10000			-- Blargh.  Infinite enough!
 
-eta_fun expr@(Var v)
-  | maybeToBool arity_maybe	-- We know the arity
-  = arity
-  where
-    arity_maybe = arityMaybe (getIdArity v)
-    arity 	= case arity_maybe of { Just arity -> arity }
+eta_fun expr@(Var v) = idMinArity v
 
 eta_fun other = 0		-- Give up
 \end{code}
@@ -280,12 +275,11 @@ manifestlyCheap other_expr   -- look for manifest partial application
 	       num_val_args == 0 ||	-- Just a type application of
 					-- a variable (f t1 t2 t3)
 					-- counts as WHNF
-	       case (arityMaybe (getIdArity f)) of
-		 Nothing     -> False
-		 Just arity  -> num_val_args < arity
+	       num_val_args < idMinArity f
 
       _ -> False
     }
+
 \end{code}
 
 Eta reduction on type lambdas
@@ -407,6 +401,11 @@ simplIdWantsToBeINLINEd id env
     then False
     else idWantsToBeINLINEd id
 
+idMinArity id = case getIdArity id of
+			UnknownArity   -> 0
+			ArityAtLeast n -> n
+			ArityExactly n -> n
+
 type_ok_for_let_to_case :: Type -> Bool
 
 type_ok_for_let_to_case ty
diff --git a/ghc/compiler/simplCore/SimplVar.lhs b/ghc/compiler/simplCore/SimplVar.lhs
index 2a6499e4c9..80951af6db 100644
--- a/ghc/compiler/simplCore/SimplVar.lhs
+++ b/ghc/compiler/simplCore/SimplVar.lhs
@@ -13,19 +13,19 @@ module SimplVar (
 IMP_Ubiq(){-uitous-}
 IMPORT_DELOOPER(SmplLoop)		( simplExpr )
 
-import CgCompInfo	( uNFOLDING_USE_THRESHOLD,
+import Constants	( uNFOLDING_USE_THRESHOLD,
 			  uNFOLDING_CON_DISCOUNT_WEIGHT
 			)
 import CmdLineOpts	( switchIsOn, SimplifierSwitch(..) )
 import CoreSyn
-import CoreUnfold	( Unfolding(..), UnfoldingGuidance(..), SimpleUnfolding(..),
+import CoreUnfold	( Unfolding(..), UfExpr, RdrName, UnfoldingGuidance(..), SimpleUnfolding(..),
 			  FormSummary,
-			  smallEnoughToInline )
-import BinderInfo	( BinderInfo, noBinderInfo, okToInline )
+			  okToInline, smallEnoughToInline )
+import BinderInfo	( BinderInfo, noBinderInfo )
 
 import CostCentre	( CostCentre, noCostCentreAttached )
 import Id		( idType, getIdInfo, getIdUnfolding, getIdSpecialisation,
-			  GenId{-instance Outputable-}
+			  idMustBeINLINEd, GenId{-instance Outputable-}
 			)
 import SpecEnv		( SpecEnv, lookupSpecEnv )
 import IdInfo		( DeforestInfo(..) )
@@ -58,7 +58,15 @@ completeVar env var args
 
   | not do_deforest &&
     maybeToBool maybe_unfolding_info &&
-    (always_inline || (ok_to_inline && not essential_unfoldings_only)) && 
+    (not essential_unfoldings_only || idMustBeINLINEd var) && 
+    ok_to_inline &&
+	-- If "essential_unfolds_only" is true we do no inlinings at all,
+	-- EXCEPT for things that absolutely have to be done
+	-- (see comments with idMustBeINLINEd)
+	--
+	-- Need to be careful: the RHS of INLINE functions is protected against inlining
+	-- by essential_unfoldings_only being set true; we must not inline workers back into
+	-- wrappers, even thouth the former have an unfold-always guidance.
     costCentreOk (getEnclosingCC env) (getEnclosingCC unfold_env)
   = tick UnfoldingDone	`thenSmpl_`
     simplExpr unfold_env unf_template args
@@ -110,19 +118,16 @@ completeVar env var args
     ok_to_inline	      = okToInline form 
 			      		   occ_info
 			      		   small_enough
-    small_enough = smallEnoughToInline con_disc unf_thresh arg_evals guidance
+    small_enough = smallEnoughToInline arg_evals guidance
     arg_evals = [is_evald arg | arg <- args, isValArg arg]
   
     is_evald (VarArg v) = isEvaluated (lookupRhsInfo env v)
     is_evald (LitArg l) = True
 
-    con_disc   = getSimplIntSwitch sw_chkr SimplUnfoldingConDiscount
-    unf_thresh = getSimplIntSwitch sw_chkr SimplUnfoldingUseThreshold
-
 #if OMIT_DEFORESTER
     do_deforest = False
 #else
-    do_deforest = case (getInfo (getIdInfo var)) of { DoDeforest -> True; _ -> False }
+    do_deforest = case (getDeforestInfo (getIdInfo var)) of { DoDeforest -> True; _ -> False }
 #endif
 
 
diff --git a/ghc/compiler/simplCore/Simplify.lhs b/ghc/compiler/simplCore/Simplify.lhs
index 2141e078cd..9d44435afc 100644
--- a/ghc/compiler/simplCore/Simplify.lhs
+++ b/ghc/compiler/simplCore/Simplify.lhs
@@ -21,12 +21,13 @@ import CoreSyn
 import CoreUtils	( coreExprType, nonErrorRHSs, maybeErrorApp,
 			  unTagBinders, squashableDictishCcExpr
 			)
-import Id		( idType, idWantsToBeINLINEd,
-			  externallyVisibleId,
+import Id		( idType, idWantsToBeINLINEd, addIdArity, 
 			  getIdDemandInfo, addIdDemandInfo,
 			  GenId{-instance NamedThing-}
 			)
-import IdInfo		( willBeDemanded, DemandInfo )
+import Name		( isExported )
+import IdInfo		( willBeDemanded, noDemandInfo, DemandInfo, ArityInfo(..),
+			  atLeastArity, unknownArity )
 import Literal		( isNoRepLit )
 import Maybes		( maybeToBool )
 --import Name		( isExported )
@@ -43,7 +44,7 @@ import Type		( mkTyVarTy, mkTyVarTys, mkAppTy,
 			  splitFunTy, getFunTy_maybe, eqTy
 			)
 import TysWiredIn	( realWorldStateTy )
-import Util		( isSingleton, zipEqual, panic, pprPanic, assertPanic )
+import Util		( isSingleton, zipEqual, zipWithEqual, panic, pprPanic, assertPanic )
 \end{code}
 
 The controlling flags, and what they do
@@ -194,8 +195,8 @@ simplTopBinds env [] = returnSmpl []
 simplTopBinds env (NonRec binder@(in_id,occ_info) rhs : binds)
   = 	-- No cloning necessary at top level
  	-- Process the binding
-    simplRhsExpr env binder rhs 		`thenSmpl` \ rhs' ->
-    completeNonRec env binder in_id rhs'	`thenSmpl` \ (new_env, binds1') ->
+    simplRhsExpr env binder rhs 				`thenSmpl` \ (rhs',arity) ->
+    completeNonRec env binder (in_id `withArity` arity) rhs'	`thenSmpl` \ (new_env, binds1') ->
 
 	-- Process the other bindings
     simplTopBinds new_env binds	`thenSmpl` \ binds2' ->
@@ -379,6 +380,8 @@ simplExpr env expr@(Lam (ValBinder binder) body) orig_args
 	    new_env = markDangerousOccs env (take n orig_args)
         in
         simplValLam new_env expr 0 {- Guaranteed applied to at least 0 args! -}
+				`thenSmpl` \ (expr', arity) ->
+	returnSmpl expr'
 
     go n env non_val_lam_expr args     	-- The lambda had enough arguments
       = simplExpr env non_val_lam_expr args
@@ -487,11 +490,12 @@ simplRhsExpr
 	:: SimplEnv
 	-> InBinder
 	-> InExpr
-	-> SmplM OutExpr
+	-> SmplM (OutExpr, ArityInfo)
 
 simplRhsExpr env binder@(id,occ_info) rhs
   | dont_eta_expand rhs
-  = simplExpr rhs_env rhs []
+  = simplExpr rhs_env rhs []	`thenSmpl` \ rhs' ->
+    returnSmpl (rhs', unknownArity)
 
   | otherwise	-- Have a go at eta expansion
   = 	-- Deal with the big lambda part
@@ -504,17 +508,20 @@ simplRhsExpr env binder@(id,occ_info) rhs
 	-- Deal with the little lambda part
 	-- Note that we call simplLam even if there are no binders,
 	-- in case it can do arity expansion.
-    simplValLam lam_env body (getBinderInfoArity occ_info)	`thenSmpl` \ lambda' ->
+    simplValLam lam_env body (getBinderInfoArity occ_info)	`thenSmpl` \ (lambda', arity) ->
 
 	-- Put it back together
     returnSmpl (
        (if switchIsSet env SimplDoEtaReduction
        then mkTyLamTryingEta
-       else mkTyLam) tyvars' lambda'
+       else mkTyLam) tyvars' lambda',
+      arity
     )
   where
 
-    rhs_env | not (switchIsSet env IgnoreINLINEPragma) &&
+    rhs_env | 	-- not (switchIsSet env IgnoreINLINEPragma) &&
+		-- No!  Don't ever inline in a INLINE thing's rhs, because
+		-- doing so will inline a worker straight back into its wrapper!
 	      idWantsToBeINLINEd id
 	    = switchOffInlining env
 	    | otherwise	
@@ -579,7 +586,10 @@ the abstraction will always be applied to at least min_no_of_args.
 \begin{code}
 simplValLam env expr min_no_of_args
   | not (switchIsSet env SimplDoLambdaEtaExpansion) ||	-- Bale out if eta expansion off
-    null binders				    ||  -- or it's a thunk
+
+-- We used to disable eta expansion for thunks, but I don't see why.
+--    null binders				    ||  -- or it's a thunk
+
     null potential_extra_binder_tys		    ||	-- or ain't a function
     no_of_extra_binders <= 0				-- or no extra binders needed
   = cloneIds env binders		`thenSmpl` \ binders' ->
@@ -590,7 +600,8 @@ simplValLam env expr min_no_of_args
     returnSmpl (
       (if switchIsSet new_env SimplDoEtaReduction
        then mkValLamTryingEta
-       else mkValLam) binders' body'
+       else mkValLam) binders' body',
+      atLeastArity no_of_binders
     )
 
   | otherwise				-- Eta expansion possible
@@ -604,11 +615,13 @@ simplValLam env expr min_no_of_args
     returnSmpl (
       (if switchIsSet new_env SimplDoEtaReduction
        then mkValLamTryingEta
-       else mkValLam) (binders' ++ extra_binders') body'
+       else mkValLam) (binders' ++ extra_binders') body',
+      atLeastArity (no_of_binders + no_of_extra_binders)
     )
 
   where
     (binders,body) = collectValBinders expr
+    no_of_binders  = length binders
     (potential_extra_binder_tys, res_ty)
 	= splitFunTy (simplTy env (coreExprType (unTagBinders body)))
 	-- Note: it's possible that simplValLam will be applied to something
@@ -620,8 +633,14 @@ simplValLam env expr min_no_of_args
     extra_binder_tys = take no_of_extra_binders potential_extra_binder_tys
 
     no_of_extra_binders =	-- First, use the info about how many args it's
-				-- always applied to in its scope
-			   (min_no_of_args - length binders)
+				-- always applied to in its scope; but ignore this
+				-- if it's a thunk!  To see why we ignore it for thunks,
+				-- consider  	let f = lookup env key in (f 1, f 2)
+				-- We'd better not eta expand f just because it is 
+				-- always applied!
+			   (if null binders
+			    then 0 
+			    else min_no_of_args - no_of_binders)
 
 				-- Next, try seeing if there's a lambda hidden inside
 				-- something cheap
@@ -635,7 +654,6 @@ simplValLam env expr min_no_of_args
 			   case potential_extra_binder_tys of
 				[ty] | ty `eqTy` realWorldStateTy -> 1
 				other				  -> 0
-
 \end{code}
 
 
@@ -728,6 +746,10 @@ ToDo: check this is OK with andy
 -- Dead code is now discarded by the occurrence analyser,
 
 simplBind env (NonRec binder@(id,occ_info) rhs) body_c body_ty
+  | idWantsToBeINLINEd id
+  = complete_bind env rhs	-- Don't messa bout with floating or let-to-case on
+				-- INLINE things
+  | otherwise
   = simpl_bind env rhs
   where
     -- Try let-to-case; see notes below about let-to-case
@@ -774,9 +796,10 @@ simplBind env (NonRec binder@(id,occ_info) rhs) body_c body_ty
     simpl_bind env rhs = complete_bind env rhs
  
     complete_bind env rhs
-      = simplRhsExpr env binder rhs 		`thenSmpl` \ rhs' ->
+      = simplRhsExpr env binder rhs 		`thenSmpl` \ (rhs',arity) ->
 	cloneId env binder			`thenSmpl` \ new_id ->
-	completeNonRec env binder new_id rhs'	`thenSmpl` \ (new_env, binds) ->
+	completeNonRec env binder 
+		(new_id `withArity` arity) rhs'	`thenSmpl` \ (new_env, binds) ->
         body_c new_env				`thenSmpl` \ body' ->
         returnSmpl (mkCoLetsAny binds body')
 
@@ -997,6 +1020,9 @@ simplBind env (Rec pairs) body_c body_ty
 					      (pairs', body') = do_float body
     do_float other			    = ([], other)
 
+
+-- The env passed to simplRecursiveGroup already has 
+-- bindings that clone the variables of the group.
 simplRecursiveGroup env new_ids pairs 
   = 	-- Add unfoldings to the new_ids corresponding to their RHS
     let
@@ -1007,17 +1033,33 @@ simplRecursiveGroup env new_ids pairs
 		               env new_ids_w_pairs
     in
 
-    mapSmpl (\(binder,rhs) -> simplRhsExpr rhs_env binder rhs) pairs	`thenSmpl` \ new_rhss ->
+    mapSmpl (\(binder,rhs) -> simplRhsExpr rhs_env binder rhs) pairs	`thenSmpl` \ new_rhss_w_arities ->
 
     let
-       new_pairs	= zipEqual "simplRecGp" new_ids new_rhss
+       new_pairs = zipWithEqual "simplRecGp" mk_new_pair new_ids new_rhss_w_arities
+       mk_new_pair id (rhs,arity) = (id `withArity` arity, rhs)
+		-- NB: the new arity isn't used when processing its own
+		-- right hand sides, nor in the subsequent code
+		-- The latter is something of a pity, and not hard to fix; but
+		-- the info will percolate on the next iteration anyway
+
+{-	THE NEXT FEW LINES ARE PLAIN WRONG
        occs_w_new_pairs = zipEqual "simplRecGp" occs new_pairs
        new_env      	= foldl add_binding env occs_w_new_pairs
 
        add_binding env (occ_info,(new_id,new_rhs)) 
 	  = extendEnvGivenBinding env occ_info new_id new_rhs
+
+Here's why it's wrong: consider
+	let f x = ...f x'...
+	in
+	f 3
+
+If the RHS is small we'll inline f in the body of the let, then
+again, then again...URK
+-}
     in
-    returnSmpl (Rec new_pairs, new_env)
+    returnSmpl (Rec new_pairs, rhs_env)
 \end{code}
 
 
@@ -1105,9 +1147,9 @@ completeNonRec env binder new_id rhs@(Lit lit)
 completeNonRec env binder new_id rhs@(Con con con_args)
   | switchIsSet env SimplReuseCon && 
     maybeToBool maybe_existing_con &&
-    not (externallyVisibleId new_id)		-- Don't bother for exported things
-						-- because we won't be able to drop
-						-- its binding.
+    not (isExported new_id)		-- Don't bother for exported things
+					-- because we won't be able to drop
+					-- its binding.
   = tick ConReused		`thenSmpl_`
     returnSmpl (extendIdEnvWithAtom env binder (VarArg it), [NonRec new_id rhs])
   where
@@ -1153,7 +1195,7 @@ fix_up_demandedness False {- May not be demanded -} (NonRec binder rhs)
 fix_up_demandedness False {- May not be demanded -} (Rec pairs)
    = Rec [(un_demandify binder, rhs) | (binder,rhs) <- pairs]
 
-un_demandify (id, occ_info) = (id `addIdDemandInfo` noInfo, occ_info)
+un_demandify (id, occ_info) = (id `addIdDemandInfo` noDemandInfo, occ_info)
 
 is_cheap_prim_app (Prim op _) = primOpOkForSpeculation op
 is_cheap_prim_app other	      = False
@@ -1170,5 +1212,8 @@ computeResultType env expr args
     go ty (a:args) | isValArg a = case (getFunTy_maybe ty) of
 				    Just (_, res_ty) -> go res_ty args
 				    Nothing	     -> panic "computeResultType"
+
+var `withArity` UnknownArity = var
+var `withArity` arity	     = var `addIdArity` arity
 \end{code}
 
diff --git a/ghc/compiler/simplStg/LambdaLift.lhs b/ghc/compiler/simplStg/LambdaLift.lhs
index 5f14b609f2..29ed3952b6 100644
--- a/ghc/compiler/simplStg/LambdaLift.lhs
+++ b/ghc/compiler/simplStg/LambdaLift.lhs
@@ -13,12 +13,13 @@ IMP_Ubiq(){-uitous-}
 import StgSyn
 
 import Bag		( emptyBag, unionBags, unitBag, snocBag, bagToList )
-import Id		( idType, mkSysLocal, addIdArity,
+import Id		( idType, mkSysLocal, addIdArity, 
 			  mkIdSet, unitIdSet, minusIdSet,
 			  unionManyIdSets, idSetToList, SYN_IE(IdSet),
 			  nullIdEnv, growIdEnvList, lookupIdEnv, SYN_IE(IdEnv)
 			)
-import SrcLoc		( mkUnknownSrcLoc )
+import IdInfo		( ArityInfo, exactArity )
+import SrcLoc		( noSrcLoc )
 import Type		( splitForAllTy, mkForAllTys, mkFunTys )
 import UniqSupply	( getUnique, splitUniqSupply )
 import Util		( zipEqual, panic, assertPanic )
@@ -441,8 +442,8 @@ newSupercombinator :: Type
 		   -> LiftM Id
 
 newSupercombinator ty arity ci us idenv
-  = (mkSysLocal SLIT("sc") uniq ty mkUnknownSrcLoc)	-- ToDo: improve location
-    `addIdArity` arity
+  = (mkSysLocal SLIT("sc") uniq ty noSrcLoc)	-- ToDo: improve location
+    `addIdArity` exactArity arity
 	-- ToDo: rm the addIdArity?  Just let subsequent stg-saturation pass do it?
   where
     uniq = getUnique us
diff --git a/ghc/compiler/simplStg/SatStgRhs.lhs b/ghc/compiler/simplStg/SatStgRhs.lhs
index 725bf48e65..a61c2c3017 100644
--- a/ghc/compiler/simplStg/SatStgRhs.lhs
+++ b/ghc/compiler/simplStg/SatStgRhs.lhs
@@ -69,8 +69,7 @@ import Id		( idType, getIdArity, addIdArity, mkSysLocal,
 			  nullIdEnv, addOneToIdEnv, growIdEnvList,
 			  lookupIdEnv, SYN_IE(IdEnv)
 			)
-import IdInfo		( arityMaybe )
-import SrcLoc		( mkUnknownSrcLoc )
+import SrcLoc		( noSrcLoc )
 import Type		( splitSigmaTy, splitForAllTy, splitFunTyExpandingDicts )
 import UniqSupply	( returnUs, thenUs, mapUs, getUnique, SYN_IE(UniqSM) )
 import Util		( panic, assertPanic )
@@ -99,6 +98,10 @@ This pass
 
 \begin{code}
 satStgRhs :: [StgBinding] -> UniqSM [StgBinding]
+satStgRhs = panic "satStgRhs"
+
+{- 		NUKED FOR NOW  SLPJ Dec 96
+
 
 satStgRhs p = satProgram nullIdEnv p
 
@@ -305,5 +308,7 @@ lookupVar env v = case lookupIdEnv env v of
 newName :: Type -> UniqSM Id
 newName ut
   = getUnique	`thenUs` \ uniq ->
-    returnUs (mkSysLocal SLIT("sat") uniq ut mkUnknownSrcLoc)
+    returnUs (mkSysLocal SLIT("sat") uniq ut noSrcLoc)
+
+-}
 \end{code}
diff --git a/ghc/compiler/simplStg/SimplStg.lhs b/ghc/compiler/simplStg/SimplStg.lhs
index 1f45f077a0..2718501e6a 100644
--- a/ghc/compiler/simplStg/SimplStg.lhs
+++ b/ghc/compiler/simplStg/SimplStg.lhs
@@ -19,7 +19,6 @@ import Name		( isLocallyDefined )
 import SCCfinal		( stgMassageForProfiling )
 import SatStgRhs	( satStgRhs )
 import StgLint		( lintStgBindings )
-import StgSAT		( doStaticArgs )
 import StgStats	        ( showStgStats )
 import StgVarInfo	( setStgVarInfo )
 import UpdAnal		( updateAnalyse )
@@ -28,8 +27,7 @@ import CmdLineOpts	( opt_EnsureSplittableC, opt_SccGroup,
 			  opt_StgDoLetNoEscapes, opt_D_verbose_stg2stg,
 			  StgToDo(..)
 			)
-import Id		( externallyVisibleId,
-			  nullIdEnv, lookupIdEnv, addOneToIdEnv,
+import Id		( nullIdEnv, lookupIdEnv, addOneToIdEnv,
 			  growIdEnvList, isNullIdEnv, SYN_IE(IdEnv),
 			  GenId{-instance Eq/Outputable -}
 			)
@@ -39,7 +37,6 @@ import Pretty		( ppShow, ppAbove, ppAboves, ppStr )
 import UniqSupply	( splitUniqSupply )
 import Util		( mapAccumL, panic, assertPanic )
 
-unlocaliseId = panic "SimplStg.unlocaliseId (ToDo)"
 \end{code}
 
 \begin{code}
@@ -67,24 +64,23 @@ stg2stg stg_todos module_name ppr_style us binds
 	-- Do the main business!
     foldl_mn do_stg_pass (binds, us4now, ([],[])) stg_todos
 		>>= \ (processed_binds, _, cost_centres) ->
-	-- Do essential wind-up: part (a) is SatStgRhs
 
-	-- Not optional, because correct arity information is used by
-	-- the code generator.  Afterwards do setStgVarInfo; it gives
-	-- the wrong answers if arities are subsequently changed,
-	-- which stgSatRhs might do.  Furthermore, setStgVarInfo
-	-- decides about let-no-escape things, which in turn do a
-	-- better job if arities are correct, which is done by
-	-- satStgRhs.
+	-- 	Do essential wind-up
 
-    case (satStgRhs processed_binds us4later) of { saturated_binds ->
-
-	-- Essential wind-up: part (b), eliminate indirections
-
-    let no_ind_binds = elimIndirections saturated_binds in
+{- Nuked for now	SLPJ Dec 96
+	-- Essential wind-up: part (a), saturate RHSs
+	-- This must occur *after* elimIndirections, because elimIndirections
+	-- can change things' arities.  Consider:
+	--	x_local = f x
+	--	x_global = \a -> x_local a
+	-- Then elimIndirections will change the program to
+	--	x_global = f x
+	-- and lo and behold x_global's arity has changed!
 
+    case (satStgRhs processed_binds us4later) of { saturated_binds ->
+-}
 
-	-- Essential wind-up: part (c), do setStgVarInfo. It has to
+	-- Essential wind-up: part (b), do setStgVarInfo. It has to
 	-- happen regardless, because the code generator uses its
 	-- decorations.
 	--
@@ -94,24 +90,23 @@ stg2stg stg_todos module_name ppr_style us binds
 	-- things, which in turn do a better job if arities are
 	-- correct, which is done by satStgRhs.
 	--
+
+{-	Done in Core now.  Nuke soon. SLPJ Nov 96
     let
 		-- ToDo: provide proper flag control!
 	binds_to_mangle
 	  = if not do_unlocalising
-	    then no_ind_binds
+	    then saturated_binds
 	    else snd (unlocaliseStgBinds unlocal_tag nullIdEnv no_ind_binds)
     in
-    return (setStgVarInfo do_let_no_escapes binds_to_mangle, cost_centres)
-    }}
+-}
+
+    return (setStgVarInfo do_let_no_escapes processed_binds, cost_centres)
+   }
   where
     do_let_no_escapes  = opt_StgDoLetNoEscapes
     do_verbose_stg2stg = opt_D_verbose_stg2stg
 
-    (do_unlocalising, unlocal_tag)
-      = case (opt_EnsureSplittableC) of
-	      Nothing  -> (False, panic "tag")
-	      Just tag -> (True,  _PK_ tag)
-
     grp_name  = case (opt_SccGroup) of
 		  Just xx -> _PK_ xx
 		  Nothing -> module_name -- default: module name
@@ -127,13 +122,7 @@ stg2stg stg_todos module_name ppr_style us binds
 	    (us1, us2) = splitUniqSupply us
 	in
 	case to_do of
-	  StgDoStaticArgs ->
-	     ASSERT(null (fst ccs) && null (snd ccs))
-	     _scc_ "StgStaticArgs"
-	     let
-		 binds3 = doStaticArgs binds us1
-	     in
-	     end_pass us2 "StgStaticArgs" ccs binds3
+	  StgDoStaticArgs ->  panic "STG static argument transformation deleted"
 
 	  StgDoUpdateAnalysis ->
 	     ASSERT(null (fst ccs) && null (snd ccs))
@@ -186,166 +175,4 @@ foldl_mn f z (x:xs) = f z x	>>= \ zz ->
 		     foldl_mn f zz xs
 \end{code}
 
-%************************************************************************
-%*									*
-\subsection[SimplStg-unlocalise]{Unlocalisation in STG code}
-%*									*
-%************************************************************************
-
-The idea of all this ``unlocalise'' stuff is that in certain (prelude
-only) modules we split up the .hc file into lots of separate little
-files, which are separately compiled by the C compiler.  That gives
-lots of little .o files.  The idea is that if you happen to mention
-one of them you don't necessarily pull them all in.  (Pulling in a
-piece you don't need can be v bad, because it may mention other pieces
-you don't need either, and so on.)
-
-Sadly, splitting up .hc files means that local names (like s234) are
-now globally visible, which can lead to clashes between two .hc
-files. So unlocaliseWhatnot goes through making all the local things
-into global things, essentially by giving them full names so when they
-are printed they'll have their module name too.  Pretty revolting
-really.
 
-\begin{code}
-type UnlocalEnv = IdEnv Id
-
-lookup_uenv :: UnlocalEnv -> Id -> Id
-lookup_uenv env id =  case lookupIdEnv env id of
-			Nothing     -> id
-			Just new_id -> new_id
-
-unlocaliseStgBinds :: FAST_STRING -> UnlocalEnv -> [StgBinding] -> (UnlocalEnv, [StgBinding])
-
-unlocaliseStgBinds mod uenv [] = (uenv, [])
-
-unlocaliseStgBinds mod uenv (b : bs)
-  = case (unlocal_top_bind mod uenv b)	      of { (new_uenv, new_b) ->
-    case (unlocaliseStgBinds mod new_uenv bs) of { (uenv3, new_bs) ->
-    (uenv3, new_b : new_bs) }}
-
-------------------
-
-unlocal_top_bind :: FAST_STRING -> UnlocalEnv -> StgBinding -> (UnlocalEnv, StgBinding)
-
-unlocal_top_bind mod uenv bind@(StgNonRec binder _)
-  = let new_uenv = case unlocaliseId mod binder of
-			Nothing		-> uenv
-			Just new_binder -> addOneToIdEnv uenv binder new_binder
-    in
-    (new_uenv, renameTopStgBind (lookup_uenv new_uenv) bind)
-
-unlocal_top_bind mod uenv bind@(StgRec pairs)
-  = let maybe_unlocaliseds  = [ (b, unlocaliseId mod b) | (b, _) <- pairs ]
-	new_uenv	    = growIdEnvList uenv [ (b,new_b)
-						 | (b, Just new_b) <- maybe_unlocaliseds]
-    in
-    (new_uenv, renameTopStgBind (lookup_uenv new_uenv) bind)
-\end{code}
-
-%************************************************************************
-%*									*
-\subsection[SimplStg-indirections]{Eliminating indirections in STG code}
-%*									*
-%************************************************************************
-
-In @elimIndirections@, we look for things at the top-level of the form...
-\begin{verbatim}
-    x_local = ....rhs...
-    ...
-    x_exported = x_local
-    ...
-\end{verbatim}
-In cases we find like this, we go {\em backwards} and replace
-\tr{x_local} with \tr{...rhs...}, to produce
-\begin{verbatim}
-    x_exported = ...rhs...
-    ...
-    ...
-\end{verbatim}
-This saves a gratuitous jump
-(from \tr{x_exported} to \tr{x_local}), and makes strictness
-information propagate better.
-
-If more than one exported thing is equal to a local thing (i.e., the
-local thing really is shared), then we eliminate only the first one.  Thus:
-\begin{verbatim}
-    x_local = ....rhs...
-    ...
-    x_exported1 = x_local
-    ...
-    x_exported2 = x_local
-    ...
-\end{verbatim}
-becomes
-\begin{verbatim}
-    x_exported1 = ....rhs...
-    ...
-    ...
-    x_exported2 = x_exported1
-    ...
-\end{verbatim}
-
-We also have to watch out for
-
-	f = \xyz -> g x y z
-
-This can arise post lambda lifting; the original might have been
-
-	f = \xyz -> letrec g = [xy] \ [k] -> e
-		    in
-		    g z
-
-Strategy: first collect the info; then make a \tr{Id -> Id} mapping.
-Then blast the whole program (LHSs as well as RHSs) with it.
-
-\begin{code}
-elimIndirections :: [StgBinding] -> [StgBinding]
-
-elimIndirections binds_in
-  = if isNullIdEnv blast_env then
-	binds_in	    -- Nothing to do
-    else
-	[renameTopStgBind lookup_fn bind | Just bind <- reduced_binds]
-  where
-    lookup_fn id = case lookupIdEnv blast_env id of
-			Just new_id -> new_id
-			Nothing     -> id
-
-    (blast_env, reduced_binds) = mapAccumL try_bind nullIdEnv binds_in
-
-    try_bind :: IdEnv Id -> StgBinding -> (IdEnv Id, Maybe StgBinding)
-    try_bind env_so_far
-	     (StgNonRec exported_binder
-		       (StgRhsClosure _ _ _ _
-				lambda_args
-				(StgApp (StgVarArg local_binder) fun_args _)
-	     ))
-	| externallyVisibleId exported_binder && -- Only if this is exported
-	  not (externallyVisibleId local_binder) && -- Only if this one is defined in this
-	  isLocallyDefined local_binder &&  -- module, so that we *can* change its
-					    -- binding to be the exported thing!
-	  not (in_dom env_so_far local_binder) && -- Only if we havn't seen it before
-	  args_match lambda_args fun_args   -- Just an eta-expansion
-
-	= (addOneToIdEnv env_so_far local_binder exported_binder,
-	   Nothing)
-	where
-	  args_match [] [] = True
-	  args_match (la:las) (StgVarArg fa:fas) = la == fa && args_match las fas
-	  args_match _  _  = False
-
-    try_bind env_so_far bind
-	= (env_so_far, Just bind)
-
-    in_dom env id = maybeToBool (lookupIdEnv env id)
-\end{code}
-
-@renameTopStgBind@ renames top level binders and all occurrences thereof.
-
-\begin{code}
-renameTopStgBind :: (Id -> Id) -> StgBinding -> StgBinding
-
-renameTopStgBind fn (StgNonRec b rhs) = StgNonRec (fn b) (mapStgBindeesRhs fn rhs)
-renameTopStgBind fn (StgRec pairs)    = StgRec [ (fn b, mapStgBindeesRhs fn r) | (b, r) <- pairs ]
-\end{code}
diff --git a/ghc/compiler/simplStg/StgSAT.lhs b/ghc/compiler/simplStg/StgSAT.lhs
deleted file mode 100644
index 9e356f0b87..0000000000
--- a/ghc/compiler/simplStg/StgSAT.lhs
+++ /dev/null
@@ -1,178 +0,0 @@
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
-%
-%************************************************************************
-%*									*
-\section[SAT]{Static Argument Transformation pass}
-%*									*
-%************************************************************************
-
-May be seen as removing invariants from loops:
-Arguments of recursive functions that do not change in recursive
-calls are removed from the recursion, which is done locally
-and only passes the arguments which effectively change.
-
-Example:
-map = /\ ab -> \f -> \xs -> case xs of
-			     []	   -> []
-			     (a:b) -> f a : map f b
-
-as map is recursively called with the same argument f (unmodified)
-we transform it to
-
-map = /\ ab -> \f -> \xs -> let map' ys = case ys of
-					   []	 -> []
-					   (a:b) -> f a : map' b
-			    in map' xs
-
-Notice that for a compiler that uses lambda lifting this is
-useless as map' will be transformed back to what map was.
-
-\begin{code}
-#include "HsVersions.h"
-
-module StgSAT (	doStaticArgs ) where
-
-IMP_Ubiq(){-uitous-}
-
-import StgSyn
-import UniqSupply	( SYN_IE(UniqSM) )
-import Util		( panic )
-\end{code}
-
-\begin{code}
-doStaticArgs :: [StgBinding] -> UniqSupply -> [StgBinding]
-
-doStaticArgs = panic "StgSAT.doStaticArgs"
-
-{- LATER: to end of file:
-doStaticArgs binds
-  = initSAT (mapSAT sat_bind binds)
-  where
-    sat_bind (StgNonRec binder expr)
-      = emptyEnvSAT  `thenSAT_`
-	satRhs expr `thenSAT` (\ expr' ->
-	returnSAT (StgNonRec binder expr'))
-    sat_bind (StgRec [(binder,rhs)])
-      = emptyEnvSAT			  `thenSAT_`
-	insSAEnv binder (getArgLists rhs) `thenSAT_`
-	satRhs rhs			  `thenSAT` (\ rhs' ->
-	saTransform binder rhs')
-    sat_bind (StgRec pairs)
-      = emptyEnvSAT		`thenSAT_`
-	mapSAT satRhs rhss	`thenSAT` \ rhss' ->
-	returnSAT (StgRec (binders `zip` rhss'))
-      where
-	(binders, rhss)	= unzip pairs
-\end{code}
-
-\begin{code}
-satAtom (StgVarArg v)
-  = updSAEnv (Just (v,([],[]))) `thenSAT_`
-    returnSAT ()
-
-satAtom _ = returnSAT ()
-\end{code}
-
-\begin{code}
-satExpr :: StgExpr -> SatM StgExpr
-
-satExpr e@(StgCon con args lvs)
-  = mapSAT satAtom args	    `thenSAT_`
-    returnSAT e
-
-satExpr e@(StgPrim op args lvs)
-  = mapSAT satAtom args	    `thenSAT_`
-    returnSAT e
-
-satExpr e@(StgApp (StgLitArg _) _ _)
-  = returnSAT e
-
-satExpr e@(StgApp (StgVarArg v) args _)
-  = updSAEnv (Just (v,([],map tagArg args)))	`thenSAT_`
-    mapSAT satAtom args				`thenSAT_`
-    returnSAT e
-  where
-    tagArg (StgVarArg v) = Static v
-    tagArg _              = NotStatic
-
-satExpr (StgCase expr lv1 lv2 uniq alts)
-  = satExpr expr	`thenSAT` \ expr' ->
-    sat_alts alts	`thenSAT` \ alts' ->
-    returnSAT (StgCase expr' lv1 lv2 uniq alts')
-  where
-    sat_alts (StgAlgAlts ty alts deflt)
-      = mapSAT satAlgAlt alts	    `thenSAT` \ alts' ->
-	sat_default deflt	    `thenSAT` \ deflt' ->
-	returnSAT (StgAlgAlts ty alts' deflt')
-      where
-	satAlgAlt (con, params, use_mask, rhs)
-	  = satExpr rhs		 `thenSAT` \ rhs' ->
-	    returnSAT (con, params, use_mask, rhs')
-
-    sat_alts (StgPrimAlts ty alts deflt)
-      = mapSAT satPrimAlt alts	    `thenSAT` \ alts' ->
-	sat_default deflt	    `thenSAT` \ deflt' ->
-	returnSAT (StgPrimAlts ty alts' deflt')
-      where
-	satPrimAlt (lit, rhs)
-	  = satExpr rhs `thenSAT` \ rhs' ->
-	    returnSAT (lit, rhs')
-
-    sat_default StgNoDefault
-      = returnSAT StgNoDefault
-    sat_default (StgBindDefault binder used rhs)
-      = satExpr rhs		     `thenSAT` \ rhs' ->
-	returnSAT (StgBindDefault binder used rhs')
-
-satExpr (StgLetNoEscape lv1 lv2 (StgNonRec binder rhs) body)
-  = satExpr body		`thenSAT` \ body' ->
-    satRhs rhs			`thenSAT` \ rhs' ->
-    returnSAT (StgLetNoEscape lv1 lv2 (StgNonRec binder rhs') body')
-
-satExpr (StgLetNoEscape lv1 lv2 (StgRec [(binder,rhs)]) body)
-  = satExpr body		      `thenSAT` \ body' ->
-    insSAEnv binder (getArgLists rhs) `thenSAT_`
-    satRhs rhs			      `thenSAT` \ rhs' ->
-    saTransform binder rhs'	      `thenSAT` \ binding ->
-    returnSAT (StgLetNoEscape lv1 lv2 binding body')
-
-satExpr (StgLetNoEscape lv1 lv2 (StgRec binds) body)
-  = let (binders, rhss) = unzip binds
-    in
-    satExpr body		    `thenSAT` \ body' ->
-    mapSAT satRhs rhss		    `thenSAT` \ rhss' ->
-    returnSAT (StgLetNoEscape lv1 lv2 (StgRec (binders `zip` rhss')) body')
-
-satExpr (StgLet (StgNonRec binder rhs) body)
-  = satExpr body		`thenSAT` \ body' ->
-    satRhs rhs			`thenSAT` \ rhs' ->
-    returnSAT (StgLet (StgNonRec binder rhs') body')
-
-satExpr (StgLet (StgRec [(binder,rhs)]) body)
-  = satExpr body		      `thenSAT` \ body' ->
-    insSAEnv binder (getArgLists rhs) `thenSAT_`
-    satRhs rhs			      `thenSAT` \ rhs' ->
-    saTransform binder rhs'	      `thenSAT` \ binding ->
-    returnSAT (StgLet binding body')
-
-satExpr (StgLet (StgRec binds) body)
-  = let (binders, rhss) = unzip binds
-    in
-    satExpr body		    `thenSAT` \ body' ->
-    mapSAT satRhs rhss		    `thenSAT` \ rhss' ->
-    returnSAT (StgLet (StgRec (binders `zip` rhss')) body')
-
-satExpr (StgSCC ty cc expr)
-  = satExpr expr		    `thenSAT` \ expr' ->
-    returnSAT (StgSCC ty cc expr')
-\end{code}
-
-\begin{code}
-satRhs rhs@(StgRhsCon cc v args) = returnSAT rhs
-
-satRhs (StgRhsClosure cc bi fvs upd args body)
-  = satExpr body		`thenSAT` \ body' ->
-    returnSAT (StgRhsClosure cc bi fvs upd args body')
--}
-\end{code}
diff --git a/ghc/compiler/simplStg/StgSATMonad.lhs b/ghc/compiler/simplStg/StgSATMonad.lhs
deleted file mode 100644
index 66e138ee60..0000000000
--- a/ghc/compiler/simplStg/StgSATMonad.lhs
+++ /dev/null
@@ -1,167 +0,0 @@
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
-%
-%************************************************************************
-%*									*
-\section[SATMonad]{The Static Argument Transformation pass Monad}
-%*									*
-%************************************************************************
-
-\begin{code}
-#include "HsVersions.h"
-
-module StgSATMonad ( getArgLists, saTransform ) where
-
-IMP_Ubiq(){-uitous-}
-
-import Util		( panic )
-
-getArgLists = panic "StgSATMonad.getArgLists"
-saTransform = panic "StgSATMonad.saTransform"
-\end{code}
-
-%************************************************************************
-%*									*
-\subsection{Utility Functions}
-%*									*
-%************************************************************************
-
-\begin{code}
-{- LATER: to end of file:
-
-newSATNames :: [Id] -> SatM [Id]
-newSATNames [] = returnSAT []
-newSATNames (id:ids) = newSATName id (idType id)	`thenSAT` \ id' ->
-		       newSATNames ids			`thenSAT` \ ids' ->
-		       returnSAT (id:ids)
-
-getArgLists :: StgRhs -> ([Arg Type],[Arg Id])
-getArgLists (StgRhsCon _ _ _)
-  = ([],[])
-getArgLists (StgRhsClosure _ _ _ _ args _)
-  = ([], [Static v | v <- args])
-
-\end{code}
-
-\begin{code}
-saTransform :: Id -> StgRhs -> SatM StgBinding
-saTransform binder rhs
-  = getSATInfo binder `thenSAT` \ r ->
-    case r of
-      Just (_,args) | any isStatic args
-      -- [Andre] test: do it only if we have more than one static argument.
-      --Just (_,args) | length (filter isStatic args) > 1
-	-> newSATName binder (new_ty args)	`thenSAT` \ binder' ->
-	   let non_static_args = get_nsa args (snd (getArgLists rhs))
-	   in
-	   newSATNames non_static_args		`thenSAT` \ non_static_args' ->
-	   mkNewRhs binder binder' args rhs non_static_args' non_static_args
-						`thenSAT` \ new_rhs ->
-	   trace ("SAT(STG) "++ show (length (filter isStatic args))) (
-	   returnSAT (StgNonRec binder new_rhs)
-	   )
-      _ -> returnSAT (StgRec [(binder, rhs)])
-
-  where
-    get_nsa :: [Arg a] -> [Arg a] -> [a]
-    get_nsa []			_		= []
-    get_nsa _			[]		= []
-    get_nsa (NotStatic:args)	(Static v:as)	= v:get_nsa args as
-    get_nsa (_:args)		(_:as)		=   get_nsa args as
-
-    mkNewRhs binder binder' args rhs@(StgRhsClosure cc bi fvs upd rhsargs body) non_static_args' non_static_args
-      = let
-	  local_body = StgApp (StgVarArg binder')
-			 [StgVarArg a | a <- non_static_args] emptyUniqSet
-
-	  rec_body = StgRhsClosure cc bi fvs upd non_static_args'
-		       (doStgSubst binder args subst_env body)
-
-	  subst_env = mkIdEnv
-			((binder,binder'):zip non_static_args non_static_args')
-	in
-	returnSAT (
-	    StgRhsClosure cc bi fvs upd rhsargs
-	      (StgLet (StgRec [(binder',rec_body)]) {-in-} local_body)
-	)
-
-    new_ty args
-      = instantiateTy [] (mkSigmaTy [] dict_tys' tau_ty')
-      where
-	-- get type info for the local function:
-	(tv_tmpl, dict_tys, tau_ty) = (splitSigmaTy . idType) binder
-	(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
-	l   	     = length dict_tys
-	dict_tys'    = dropStatics (take l args) dict_tys
-	reg_arg_tys' = dropStatics (drop l args) reg_arg_tys
-	tau_ty'	     = glueTyArgs reg_arg_tys' res_type
-\end{code}
-
-NOTE: This does not keep live variable/free variable information!!
-
-\begin{code}
-doStgSubst binder orig_args subst_env body
-  = substExpr body
-  where
-    substExpr (StgCon con args lvs)
-      = StgCon con (map substAtom args) emptyUniqSet
-    substExpr (StgPrim op args lvs)
-      = StgPrim op (map substAtom args) emptyUniqSet
-    substExpr expr@(StgApp (StgLitArg _) [] _)
-      = expr
-    substExpr (StgApp atom@(StgVarArg v)  args lvs)
-      | v `eqId` binder
-      = StgApp (StgVarArg (lookupNoFailIdEnv subst_env v))
-	       (remove_static_args orig_args args) emptyUniqSet
-      | otherwise
-      = StgApp (substAtom atom) (map substAtom args) lvs
-    substExpr (StgCase scrut lv1 lv2 uniq alts)
-      = StgCase (substExpr scrut) emptyUniqSet emptyUniqSet uniq (subst_alts alts)
-      where
-	subst_alts (StgAlgAlts ty alg_alts deflt)
-	  = StgAlgAlts ty (map subst_alg_alt alg_alts) (subst_deflt deflt)
-	subst_alts (StgPrimAlts ty prim_alts deflt)
-	  = StgPrimAlts ty (map subst_prim_alt prim_alts) (subst_deflt deflt)
-	subst_alg_alt (con, args, use_mask, rhs)
-	  = (con, args, use_mask, substExpr rhs)
-	subst_prim_alt (lit, rhs)
-	  = (lit, substExpr rhs)
-	subst_deflt StgNoDefault
-	  = StgNoDefault
-	subst_deflt (StgBindDefault var used rhs)
-	  = StgBindDefault var used (substExpr rhs)
-    substExpr (StgLetNoEscape fv1 fv2 b body)
-      = StgLetNoEscape emptyUniqSet emptyUniqSet (substBinding b) (substExpr body)
-    substExpr (StgLet b body)
-      = StgLet (substBinding b) (substExpr body)
-    substExpr (StgSCC ty cc expr)
-      = StgSCC ty cc (substExpr expr)
-    substRhs (StgRhsCon cc v args)
-      = StgRhsCon cc v (map substAtom args)
-    substRhs (StgRhsClosure cc bi fvs upd args body)
-      = StgRhsClosure cc bi [] upd args (substExpr body)
-
-    substBinding (StgNonRec binder rhs)
-      = StgNonRec binder (substRhs rhs)
-    substBinding (StgRec pairs)
-      = StgRec (zip binders (map substRhs rhss))
-      where
-	(binders,rhss) = unzip pairs
-
-    substAtom atom@(StgLitArg lit) = atom
-    substAtom atom@(StgVarArg v)
-      = case lookupIdEnv subst_env v of
-	  Just v' -> StgVarArg v'
-	  Nothing -> atom
-
-    remove_static_args _ []
-      = []
-    remove_static_args (Static _:origs) (_:as)
-      = remove_static_args origs as
-    remove_static_args (NotStatic:origs) (a:as)
-      = substAtom a:remove_static_args origs as
--}
-\end{code}
diff --git a/ghc/compiler/simplStg/UpdAnal.lhs b/ghc/compiler/simplStg/UpdAnal.lhs
index 5a98a3e8d7..2b75497728 100644
--- a/ghc/compiler/simplStg/UpdAnal.lhs
+++ b/ghc/compiler/simplStg/UpdAnal.lhs
@@ -27,7 +27,7 @@
 > --import Id
 > --import IdInfo
 > --import Pretty
-> --import SrcLoc 	( mkUnknownSrcLoc )
+> --import SrcLoc 	( noSrcLoc )
 > --import StgSyn
 > --import UniqSet
 > --import Unique 	( getBuiltinUniques )
@@ -479,7 +479,7 @@ Convert a Closure into a representation that can be placed in a .hi file.
 >	    where
 >		(c,b,_)     = foldl doApp f ids
 >	      	ids         = map mkid (getBuiltinUniques arity)
->	      	mkid u      = mkSysLocal SLIT("upd") u noType mkUnknownSrcLoc
+>	      	mkid u      = mkSysLocal SLIT("upd") u noType noSrcLoc
 >	      	countUses u = if u `elemRefs` b then 2 else min (lookupc c u) 2
 >	      	noType      = panic "UpdAnal: no type!"
 >
diff --git a/ghc/compiler/specialise/SpecUtils.lhs b/ghc/compiler/specialise/SpecUtils.lhs
index bd7ec63d06..beb30cdae9 100644
--- a/ghc/compiler/specialise/SpecUtils.lhs
+++ b/ghc/compiler/specialise/SpecUtils.lhs
@@ -24,7 +24,7 @@ module SpecUtils (
 IMP_Ubiq(){-uitous-}
 
 import Bag		( isEmptyBag, bagToList )
-import Class		( classOpString, GenClass{-instance NamedThing-} )
+import Class		( GenClass{-instance NamedThing-}, GenClassOp {- instance NamedThing -} )
 import FiniteMap	( emptyFM, addListToFM_C, plusFM_C, keysFM,
 			  lookupWithDefaultFM
 			)
@@ -33,7 +33,7 @@ import Id		( idType, isDictFunId, isConstMethodId_maybe,
 			  GenId {-instance NamedThing -}
 			)
 import Maybes		( maybeToBool, catMaybes, firstJust )
-import Name		( origName, isLexVarSym, isLexSpecialSym, pprNonSym )
+import Name		( OccName, pprNonSym, pprOccName, modAndOcc )
 import PprStyle		( PprStyle(..) )
 import PprType		( pprGenType, pprParendGenType, pprMaybeTy,
 			  TyCon{-ditto-}, GenType{-ditto-}, GenTyVar
@@ -228,7 +228,10 @@ pprSpecErrs this_mod spec_errs spec_warn spec_tyerrs
       where
 	(mod_name, id_name) = get_id_name id
 
+
     get_id_name id
+
+{- Don't understand this -- and looks TURGID.  SLPJ 4 Nov 96 
       | maybeToBool (isDefaultMethodId_maybe id)
       = (this_mod, _NIL_)
 
@@ -238,12 +241,13 @@ pprSpecErrs this_mod spec_errs spec_warn spec_tyerrs
 	in (use_mod, _NIL_)
 
       | otherwise
-      = case (origName "get_id_name" id) of { OrigName m n -> (m, n) }
+-}
+      = modAndOcc id
 
     get_ty_data (ty, tys)
       = (mod_name, [(ty_name, ty, tys)])
       where
-	(OrigName mod_name ty_name) = origName "get_ty_data" ty
+	(mod_name, ty_name) = modAndOcc ty
 
     module_names    = concat [keysFM idspecs_fm, keysFM tyspecs_fm]
     mods            = map head (equivClasses _CMP_STRING_ module_names)
@@ -280,7 +284,7 @@ pprSpecErrs this_mod spec_errs spec_warn spec_tyerrs
 pp_module mod
   = ppBesides [ppPStr mod, ppStr ":"]
 
-pp_tyspec :: PprStyle -> Pretty -> (FAST_STRING, TyCon, [Maybe Type]) -> Pretty
+pp_tyspec :: PprStyle -> Pretty -> (OccName, TyCon, [Maybe Type]) -> Pretty
 
 pp_tyspec sty pp_mod (_, tycon, tys)
   = ppCat [pp_mod,
@@ -296,7 +300,7 @@ pp_tyspec sty pp_mod (_, tycon, tys)
     choose_ty (tv, Nothing) = (mkTyVarTy tv, Just tv)
     choose_ty (tv, Just ty) = (ty, Nothing)
 
-pp_idspec :: PprStyle -> Pretty -> (FAST_STRING, Id, [Maybe Type], Bool) -> Pretty
+pp_idspec :: PprStyle -> Pretty -> (OccName, Id, [Maybe Type], Bool) -> Pretty
 
 pp_idspec sty pp_mod (_, id, tys, is_err)
   | isDictFunId id
@@ -309,28 +313,24 @@ pp_idspec sty pp_mod (_, id, tys, is_err)
   | is_const_method_id
   = let
 	Just (cls, clsty, clsop) = const_method_maybe
-    	(OrigName _ cls_str) = origName "pp_idspec" cls
-	clsop_str    = classOpString clsop
     in
     ppCat [pp_mod,
 	   ppStr "{-# SPECIALIZE",
-	   pp_clsop clsop_str, ppStr "::",
+	   pprNonSym sty clsop, ppStr "::",
 	   pprGenType sty spec_ty,
 	   ppStr "#-} {- IN instance",
-	   ppPStr cls_str, pprParendGenType sty clsty,
+	   pprOccName sty (getOccName cls), pprParendGenType sty clsty,
 	   ppStr "-}", pp_essential ]
 
   | is_default_method_id
   = let
 	Just (cls, clsop, _) = default_method_maybe
-    	(OrigName _ cls_str) = origName "pp_idspec2" cls
-	clsop_str    = classOpString clsop
     in
     ppCat [pp_mod,
 	   ppStr "{- instance",
-	   ppPStr cls_str,
+	   pprOccName sty (getOccName cls),
 	   ppStr "EXPLICIT METHOD REQUIRED",
-	   pp_clsop clsop_str, ppStr "::",
+	   pprNonSym sty clsop, ppStr "::",
 	   pprGenType sty spec_ty,
 	   ppStr "-}", pp_essential ]
 
@@ -349,10 +349,4 @@ pp_idspec sty pp_mod (_, id, tys, is_err)
 
     default_method_maybe = isDefaultMethodId_maybe id
     is_default_method_id = maybeToBool default_method_maybe
-
-    pp_clsop str | isLexVarSym str && not (isLexSpecialSym str)
-    	         = ppParens (ppPStr str)
-    	         | otherwise
-		 = ppPStr str
-
 \end{code}
diff --git a/ghc/compiler/specialise/Specialise.lhs b/ghc/compiler/specialise/Specialise.lhs
index 8164e0ce05..f76ed75b14 100644
--- a/ghc/compiler/specialise/Specialise.lhs
+++ b/ghc/compiler/specialise/Specialise.lhs
@@ -2472,7 +2472,7 @@ cloneLetBinders top_lev is_rec old_ids tvenv idenv us
 
 	 -- Don't clone if it is a top-level thing. Why not?
 	 -- (a) we don't want to change the uniques
-	 --     on such things (see TopLevId in Id.lhs)
+	 --     on such things
 	 -- (b) we don't have to be paranoid about name capture
 	 -- (c) the thing is polymorphic so no need to subst
 
diff --git a/ghc/compiler/stgSyn/CoreToStg.lhs b/ghc/compiler/stgSyn/CoreToStg.lhs
index 114131aeac..a6385c1558 100644
--- a/ghc/compiler/stgSyn/CoreToStg.lhs
+++ b/ghc/compiler/stgSyn/CoreToStg.lhs
@@ -23,11 +23,12 @@ import StgSyn		-- output
 import Bag		( emptyBag, unitBag, unionBags, unionManyBags, bagToList )
 import CoreUtils	( coreExprType )
 import CostCentre	( noCostCentre )
-import Id		( mkSysLocal, idType, isBottomingId,
+import Id		( mkSysLocal, idType, isBottomingId, addIdArity,
 			  externallyVisibleId,
-			  nullIdEnv, addOneToIdEnv, lookupIdEnv,
+			  nullIdEnv, addOneToIdEnv, lookupIdEnv, growIdEnvList,
 			  SYN_IE(IdEnv), GenId{-instance NamedThing-}
 			)
+import IdInfo		( ArityInfo, exactArity )
 import Literal		( mkMachInt, Literal(..) )
 import PrelVals		( unpackCStringId, unpackCString2Id,
 			  integerZeroId, integerPlusOneId,
@@ -35,13 +36,13 @@ import PrelVals		( unpackCStringId, unpackCString2Id,
 			)
 import PrimOp		( PrimOp(..) )
 import SpecUtils	( mkSpecialisedCon )
-import SrcLoc		( mkUnknownSrcLoc )
+import SrcLoc		( noSrcLoc )
 import TyCon		( TyCon{-instance Uniquable-} )
 import Type		( maybeAppDataTyCon, getAppDataTyConExpandingDicts )
 import TysWiredIn	( stringTy )
 import Unique		( integerTyConKey, ratioTyConKey, Unique{-instance Eq-} )
 import UniqSupply	-- all of it, really
-import Util		( panic, assertPanic{-, pprTrace ToDo:rm-} )
+import Util		( zipLazy, panic, assertPanic{-, pprTrace ToDo:rm-} )
 --import Pretty--ToDo:rm
 --import PprStyle--ToDo:rm
 --import PprType  --ToDo:rm
@@ -62,17 +63,18 @@ The business of this pass is to convert Core to Stg.  On the way:
 	x = y t1 t2
   where t1, t2 are types
 
-* We make the representation of NoRep literals explicit, and
-  float their bindings to the top level
+* We pin correct arities on each let(rec)-bound binder, and propagate them
+  to their uses.  This is used
+	a) when emitting arity info into interface files
+	b) in the code generator, when deciding if a right-hand side
+		 is a saturated application so we can generate a VAP closure.
+  (b) is rather untidy, but the easiest compromise was to propagate arities here.
 
 * We do *not* pin on the correct free/live var info; that's done later.
   Instead we use bOGUS_LVS and _FVS as a placeholder.
 
-* We convert	case x of {...; x' -> ...x'...}
-	to
-		case x of {...; _  -> ...x... }
-
-  See notes in SimplCase.lhs, near simplDefault for the reasoning here.
+[Quite a bit of stuff that used to be here has moved 
+ to tidyCorePgm (SimplCore.lhs) SLPJ Nov 96]
 
 
 %************************************************************************
@@ -108,75 +110,16 @@ topCoreBindsToStg :: UniqSupply	-- name supply
 		  -> [StgBinding]	-- output
 
 topCoreBindsToStg us core_binds
-  = case (initUs us (binds_to_stg nullIdEnv core_binds)) of
+  = case (initUs us (coreBindsToStg nullIdEnv core_binds)) of
       (_, stuff) -> stuff
   where
-    binds_to_stg :: StgEnv -> [CoreBinding] -> UniqSM [StgBinding]
-
-    binds_to_stg env [] = returnUs []
-    binds_to_stg env (b:bs)
-      = do_top_bind  env     b  `thenUs` \ (new_b, new_env, float_binds) ->
-    	binds_to_stg new_env bs `thenUs` \ new_bs ->
-    	returnUs (bagToList float_binds ++ 	-- Literals
-		  new_b ++
-		  new_bs)
-
-    do_top_bind env bind@(Rec pairs)
-      = coreBindToStg env bind
-
-    do_top_bind env bind@(NonRec var rhs)
-      = coreBindToStg env bind		`thenUs` \ (stg_binds, new_env, float_binds) ->
-{- TESTING:
-	let
-	    ppr_blah xs = ppInterleave ppComma (map pp_x xs)
-	    pp_x (u,x) = ppBesides [pprUnique u, ppStr ": ", ppr PprDebug x]
-	in
-	pprTrace "do_top_bind:" (ppAbove (ppr PprDebug stg_binds) (ppr_blah (ufmToList new_env))) $
--}
- 	case stg_binds of
-	   [StgNonRec var (StgRhsClosure cc bi fvs u [] rhs_body)] ->
-		-- Mega-special case; there's still a binding there
-		-- no fvs (of course), *no args*, "let" rhs
-		let
-		  (extra_float_binds, rhs_body') = seek_liftable [] rhs_body
-		in
-		returnUs (extra_float_binds ++
-			  [StgNonRec var (StgRhsClosure cc bi fvs u [] rhs_body')],
-			  new_env,
-			  float_binds)
-
-	   other -> returnUs (stg_binds, new_env, float_binds)
-
-    --------------------
-    -- HACK: look for very simple, obviously-liftable bindings
-    -- that can come up to the top level; those that couldn't
-    -- 'cause they were big-lambda constrained in the Core world.
-
-    seek_liftable :: [StgBinding] 	-- accumulator...
-		  -> StgExpr	-- look for top-lev liftables
-		  -> ([StgBinding], StgExpr)	-- result
-
-    seek_liftable acc expr@(StgLet inner_bind body)
-      | is_liftable inner_bind
-      =	seek_liftable (inner_bind : acc) body
-
-    seek_liftable acc other_expr = (reverse acc, other_expr) -- Finished
-
-    --------------------
-    is_liftable (StgNonRec binder (StgRhsClosure _ _ _ _ args body))
-      = not (null args) -- it's manifestly a function...
-	|| isLeakFreeType [] (idType binder)
-	|| is_whnf body
-	-- ToDo: use a decent manifestlyWHNF function for STG?
-      where
-	is_whnf (StgCon _ _ _) 	    = True
-	is_whnf (StgApp (StgVarArg v) _ _) = isBottomingId v
-	is_whnf other 			    = False
-
-    is_liftable (StgRec [(_, StgRhsClosure _ _ _ _ args body)])
-      = not (null args) -- it's manifestly a (recursive) function...
+    coreBindsToStg :: StgEnv -> [CoreBinding] -> UniqSM [StgBinding]
 
-    is_liftable anything_else = False
+    coreBindsToStg env [] = returnUs []
+    coreBindsToStg env (b:bs)
+      = coreBindToStg  env b		`thenUs` \ (new_b, new_env) ->
+    	coreBindsToStg new_env bs 	`thenUs` \ new_bs ->
+    	returnUs (new_b ++ new_bs)
 \end{code}
 
 %************************************************************************
@@ -189,36 +132,34 @@ topCoreBindsToStg us core_binds
 coreBindToStg :: StgEnv
 	      -> CoreBinding
 	      -> UniqSM ([StgBinding],	-- Empty or singleton
-		    	 StgEnv,		-- New envt
-			 Bag StgBinding)	-- Floats
+		    	 StgEnv)	-- Floats
 
 coreBindToStg env (NonRec binder rhs)
-  = coreRhsToStg env rhs	`thenUs` \ (stg_rhs, rhs_binds) ->
-
+  = coreRhsToStg env rhs	`thenUs` \ stg_rhs ->
     let
 	-- Binds to return if RHS is trivial
-	triv_binds = if externallyVisibleId binder then
-			-- pprTrace "coreBindToStg:keeping:" (ppCat [ppr PprDebug binder, ppr PprDebug (externallyVisibleId binder)]) $
-			[StgNonRec binder stg_rhs]	-- Retain it
-		     else
-			-- pprTrace "coreBindToStg:tossing:" (ppCat [ppr PprDebug binder, ppr PprDebug (externallyVisibleId binder)]) $
-			[]				-- Discard it
+	triv_binds | externallyVisibleId binder = [StgNonRec binder stg_rhs]	-- Retain it
+		   | otherwise	      	        = []				-- Discard it
     in
     case stg_rhs of
       StgRhsClosure cc bi fvs upd [] (StgApp atom [] lvs) ->
 		-- Trivial RHS, so augment envt, and ditch the binding
-		returnUs (triv_binds, new_env, rhs_binds)
+		returnUs (triv_binds, new_env)
 	   where
 		new_env = addOneToIdEnv env binder atom
 
       StgRhsCon cc con_id [] ->
 		-- Trivial RHS, so augment envt, and ditch the binding
-		returnUs (triv_binds, new_env, rhs_binds)
+		returnUs (triv_binds, new_env)
 	   where
 		new_env = addOneToIdEnv env binder (StgVarArg con_id)
 
       other -> 	-- Non-trivial RHS, so don't augment envt
-		returnUs ([StgNonRec binder stg_rhs], env, rhs_binds)
+		returnUs ([StgNonRec binder_w_arity stg_rhs], new_env)
+	   where
+		binder_w_arity = binder `addIdArity` (rhsArity stg_rhs)
+		new_env = addOneToIdEnv env binder (StgVarArg binder_w_arity)
+		-- new_env propagates the arity
 
 coreBindToStg env (Rec pairs)
   = -- NB: *** WE DO NOT CHECK FOR TRIV_BINDS in REC BIND ****
@@ -226,8 +167,15 @@ coreBindToStg env (Rec pairs)
     let
 	(binders, rhss) = unzip pairs
     in
-    mapAndUnzipUs (coreRhsToStg env) rhss `thenUs` \ (stg_rhss, rhs_binds) ->
-    returnUs ([StgRec (binders `zip` stg_rhss)], env, unionManyBags rhs_binds)
+    mapUs (coreRhsToStg env) rhss `thenUs` \ stg_rhss ->
+    let	
+	    binders_w_arities = [ b `addIdArity` rhsArity rhs 
+				| (b,rhs) <- binders `zip` stg_rhss]
+    in
+    returnUs ([StgRec (binders_w_arities `zip` stg_rhss)], env)
+
+rhsArity (StgRhsClosure _ _ _ _ args _) = exactArity (length args)
+rhsArity (StgRhsCon _ _ _)		= exactArity 0
 \end{code}
 
 
@@ -238,17 +186,18 @@ coreBindToStg env (Rec pairs)
 %************************************************************************
 
 \begin{code}
-coreRhsToStg :: StgEnv -> CoreExpr -> UniqSM (StgRhs, Bag StgBinding)
+coreRhsToStg :: StgEnv -> CoreExpr -> UniqSM StgRhs
 
 coreRhsToStg env core_rhs
-  = coreExprToStg env core_rhs 	`thenUs` \ (stg_expr, stg_binds) ->
+  = coreExprToStg env core_rhs 	`thenUs` \ stg_expr ->
 
     let stg_rhs = case stg_expr of
 		    StgLet (StgNonRec var1 rhs) (StgApp (StgVarArg var2) [] _)
 			| var1 == var2 -> rhs
 			-- This curious stuff is to unravel what a lambda turns into
 			-- We have to do it this way, rather than spot a lambda in the
-			-- incoming rhs
+			-- incoming rhs.  Why?  Because trivial bindings might conceal
+			-- what the rhs is actually like.
 
 		    StgCon con args _ -> StgRhsCon noCostCentre con args
 
@@ -259,117 +208,7 @@ coreRhsToStg env core_rhs
 					   []
 					   stg_expr
     in
-    returnUs (stg_rhs, stg_binds)
-\end{code}
-
-
-%************************************************************************
-%*									*
-\subsection[coreToStg-lits]{Converting literals}
-%*									*
-%************************************************************************
-
-Literals: the NoRep kind need to be de-no-rep'd.
-We always replace them with a simple variable, and float a suitable
-binding out to the top level.
-
-If an Integer is small enough (Haskell implementations must support
-Ints in the range $[-2^29+1, 2^29-1]$), wrap it up in @int2Integer@;
-otherwise, wrap with @litString2Integer@.
-
-\begin{code}
-tARGET_MIN_INT, tARGET_MAX_INT :: Integer
-tARGET_MIN_INT = -536870912
-tARGET_MAX_INT =  536870912
-
-litToStgArg :: Literal -> UniqSM (StgArg, Bag StgBinding)
-
-litToStgArg (NoRepStr s)
-  = newStgVar stringTy 		`thenUs` \ var ->
-    let
-	rhs = StgRhsClosure noCostCentre -- No cost centre (ToDo?)
-			    stgArgOcc	 -- safe
-			    bOGUS_FVs
-			    Updatable	 -- WAS: ReEntrant (see note below)
-			    []		 -- No arguments
-			    val
-
--- We used not to update strings, so that they wouldn't clog up the heap,
--- but instead be unpacked each time.  But on some programs that costs a lot
--- [eg hpg], so now we update them.
-
-	val = if (any is_NUL (_UNPK_ s)) then -- must cater for NULs in literal string
-		StgApp (StgVarArg unpackCString2Id)
-		     [StgLitArg (MachStr s),
-		      StgLitArg (mkMachInt (toInteger (_LENGTH_ s)))]
-		     bOGUS_LVs
-	      else
-		StgApp (StgVarArg unpackCStringId)
-		     [StgLitArg (MachStr s)]
-		     bOGUS_LVs
-    in
-    returnUs (StgVarArg var, unitBag (StgNonRec var rhs))
-  where
-    is_NUL c = c == '\0'
-
-litToStgArg (NoRepInteger i integer_ty)
-  -- extremely convenient to look out for a few very common
-  -- Integer literals!
-  | i == 0    = returnUs (StgVarArg integerZeroId,     emptyBag)
-  | i == 1    = returnUs (StgVarArg integerPlusOneId,  emptyBag)
-  | i == 2    = returnUs (StgVarArg integerPlusTwoId,  emptyBag)
-  | i == (-1) = returnUs (StgVarArg integerMinusOneId, emptyBag)
-
-  | otherwise
-  = newStgVar integer_ty	`thenUs` \ var ->
-    let
-	rhs = StgRhsClosure noCostCentre -- No cost centre (ToDo?)
-			    stgArgOcc	 -- safe
-			    bOGUS_FVs
-			    Updatable	 -- Update an integer
-			    []		 -- No arguments
-			    val
-
-	val
-	  | i > tARGET_MIN_INT && i < tARGET_MAX_INT
-	  =	-- Start from an Int
-	    StgPrim Int2IntegerOp [StgLitArg (mkMachInt i)] bOGUS_LVs
-
-	  | otherwise
-	  = 	-- Start from a string
-	    StgPrim Addr2IntegerOp [StgLitArg (MachStr (_PK_ (show i)))] bOGUS_LVs
-    in
-    returnUs (StgVarArg var, unitBag (StgNonRec var rhs))
-
-litToStgArg (NoRepRational r rational_ty)
-  = --ASSERT(is_rational_ty)
-    --(if is_rational_ty then \x->x else pprTrace "litToStgArg:not rational?" (pprType PprDebug rational_ty)) $
-    litToStgArg (NoRepInteger (numerator   r) integer_ty) `thenUs` \ (num_atom,   binds1) ->
-    litToStgArg (NoRepInteger (denominator r) integer_ty) `thenUs` \ (denom_atom, binds2) ->
-    newStgVar rational_ty			`thenUs` \ var ->
-    let
-	 rhs = StgRhsCon noCostCentre	-- No cost centre (ToDo?)
-			 ratio_data_con	-- Constructor
-			 [num_atom, denom_atom]
-    in
-    returnUs (StgVarArg var, binds1 `unionBags`
-			    binds2 `unionBags`
-			    unitBag (StgNonRec var rhs))
-  where
-    (is_rational_ty, ratio_data_con, integer_ty)
-      = case (maybeAppDataTyCon rational_ty) of
-	  Just (tycon, [i_ty], [con])
-	    -> ASSERT(is_integer_ty i_ty)
-	       (uniqueOf tycon == ratioTyConKey, con, i_ty)
-
-	  _ -> (False, panic "ratio_data_con", panic "integer_ty")
-
-    is_integer_ty ty
-      = case (maybeAppDataTyCon ty) of
-	  Just (tycon, [], _) -> uniqueOf tycon == integerTyConKey
-	  _ -> False
-
-litToStgArg other_lit = returnUs (StgLitArg other_lit, emptyBag)
+    returnUs stg_rhs
 \end{code}
 
 
@@ -380,31 +219,19 @@ litToStgArg other_lit = returnUs (StgLitArg other_lit, emptyBag)
 %************************************************************************
 
 \begin{code}
-coreArgsToStg :: StgEnv -> [CoreArg] -> UniqSM ([Type], [StgArg], Bag StgBinding)
+coreArgsToStg :: StgEnv -> [CoreArg] -> ([Type], [StgArg])
 
-coreArgsToStg env [] = returnUs ([], [], emptyBag)
+coreArgsToStg env [] = ([], [])
 coreArgsToStg env (a:as)
-  = coreArgsToStg env as    `thenUs` \ (tys, args, binds) ->
-    do_arg a tys args binds
+  = case a of
+	TyArg    t -> (t:trest, vrest)
+	UsageArg u -> (trest,   vrest)
+	VarArg   v -> (trest,   stgLookup env v : vrest)
+	LitArg   l -> (trest,   StgLitArg l     : vrest)
   where
-    do_arg a trest vrest binds
-      = case a of
-	  TyArg    t -> returnUs (t:trest, vrest, binds)
-	  UsageArg u -> returnUs (trest, vrest, binds)
-	  VarArg   v -> returnUs (trest, stgLookup env v : vrest, binds)
-	  LitArg   i -> litToStgArg i `thenUs` \ (v, bs) ->
-			returnUs (trest, v:vrest, bs `unionBags` binds)
+    (trest,vrest) = coreArgsToStg env as
 \end{code}
 
-There's not anything interesting we can ASSERT about \tr{var} if it
-isn't in the StgEnv. (WDP 94/06)
-\begin{code}
-stgLookup :: StgEnv -> Id -> StgArg
-
-stgLookup env var = case (lookupIdEnv env var) of
-		      Nothing   -> StgVarArg var
-		      Just atom -> atom
-\end{code}
 
 %************************************************************************
 %*									*
@@ -413,30 +240,26 @@ stgLookup env var = case (lookupIdEnv env var) of
 %************************************************************************
 
 \begin{code}
-coreExprToStg :: StgEnv
-	      -> CoreExpr
-	      -> UniqSM (StgExpr,		-- Result
-			 Bag StgBinding)	-- Float these to top level
-\end{code}
+coreExprToStg :: StgEnv -> CoreExpr -> UniqSM StgExpr
 
-\begin{code}
 coreExprToStg env (Lit lit)
-  = litToStgArg lit	`thenUs` \ (atom, binds) ->
-    returnUs (StgApp atom [] bOGUS_LVs, binds)
+  = returnUs (StgApp (StgLitArg lit) [] bOGUS_LVs)
 
 coreExprToStg env (Var var)
-  = returnUs (StgApp (stgLookup env var) [] bOGUS_LVs, emptyBag)
+  = returnUs (StgApp (stgLookup env var) [] bOGUS_LVs)
 
 coreExprToStg env (Con con args)
-  = coreArgsToStg env args  `thenUs` \ (types, stg_atoms, stg_binds) ->
-    let
+  = let
+	(types, stg_atoms) = coreArgsToStg env args
 	spec_con = mkSpecialisedCon con types
     in
-    returnUs (StgCon spec_con stg_atoms bOGUS_LVs, stg_binds)
+    returnUs (StgCon spec_con stg_atoms bOGUS_LVs)
 
 coreExprToStg env (Prim op args)
-  = coreArgsToStg env args  `thenUs` \ (_, stg_atoms, stg_binds) ->
-    returnUs (StgPrim op stg_atoms bOGUS_LVs, stg_binds)
+  = let
+	(types, stg_atoms) = coreArgsToStg env args
+    in
+    returnUs (StgPrim op stg_atoms bOGUS_LVs)
 \end{code}
 
 %************************************************************************
@@ -450,21 +273,21 @@ coreExprToStg env expr@(Lam _ _)
   = let
 	(_,_, binders, body) = collectBinders expr
     in
-    coreExprToStg env body		`thenUs` \ stuff@(stg_body, binds) ->
+    coreExprToStg env body		`thenUs` \ stg_body ->
 
     if null binders then -- it was all type/usage binders; tossed
-	returnUs stuff
+	returnUs stg_body
     else
 	newStgVar (coreExprType expr)	`thenUs` \ var ->
 	returnUs
-	  (StgLet (StgNonRec var (StgRhsClosure noCostCentre
+	  (StgLet (StgNonRec (var `addIdArity` exactArity (length binders))
+				  (StgRhsClosure noCostCentre
 				  stgArgOcc
 				  bOGUS_FVs
 				  ReEntrant 	-- binders is non-empty
 				  binders
 				  stg_body))
-	   (StgApp (StgVarArg var) [] bOGUS_LVs),
-	   binds)
+	   (StgApp (StgVarArg var) [] bOGUS_LVs))
 \end{code}
 
 %************************************************************************
@@ -476,23 +299,21 @@ coreExprToStg env expr@(Lam _ _)
 \begin{code}
 coreExprToStg env expr@(App _ _)
   = let
-	(fun,args) = collect_args expr []
+	(fun,args)    = collect_args expr []
+	(_, stg_args) = coreArgsToStg env args
     in
-	-- Deal with the arguments
-    coreArgsToStg env args `thenUs` \ (_, stg_args, arg_binds) ->
-
 	-- Now deal with the function
     case (fun, args) of
       (Var fun_id, _) -> 	-- A function Id, so do an StgApp; it's ok if
 				-- there are no arguments.
-			    returnUs (StgApp (stgLookup env fun_id) stg_args bOGUS_LVs, arg_binds)
+			    returnUs (StgApp (stgLookup env fun_id) stg_args bOGUS_LVs)
 
       (non_var_fun, []) -> 	-- No value args, so recurse into the function
 			    coreExprToStg env non_var_fun
 
       other ->	-- A non-variable applied to things; better let-bind it.
 		newStgVar (coreExprType fun)	`thenUs` \ fun_id ->
-		coreExprToStg env fun		`thenUs` \ (stg_fun, fun_binds) ->
+		coreExprToStg env fun		`thenUs` \ (stg_fun) ->
 		let
 		   fun_rhs = StgRhsClosure noCostCentre	-- No cost centre (ToDo?)
 					   stgArgOcc
@@ -502,8 +323,7 @@ coreExprToStg env expr@(App _ _)
 					   stg_fun
 		in
 		returnUs (StgLet (StgNonRec fun_id fun_rhs)
-			   	  (StgApp (StgVarArg fun_id) stg_args bOGUS_LVs),
-			   arg_binds `unionBags` fun_binds)
+			   	 (StgApp (StgVarArg fun_id) stg_args bOGUS_LVs))
   where
 	-- Collect arguments, discarding type/usage applications
     collect_args (App e   (TyArg _))    args = collect_args e   args
@@ -518,115 +338,48 @@ coreExprToStg env expr@(App _ _)
 %*									*
 %************************************************************************
 
-At this point, we *mangle* cases involving fork# and par# in the
-discriminant.  The original templates for these primops (see
-@PrelVals.lhs@) constructed case expressions with boolean results
-solely to fool the strictness analyzer, the simplifier, and anyone
-else who might want to fool with the evaluation order.  Now, we
-believe that once the translation to STG code is performed, our
-evaluation order is safe.  Therefore, we convert expressions of the
-form:
-
-    case par# e of
-      True -> rhs
-      False -> parError#
-
-to
-
-    case par# e of
-      _ -> rhs
-
 \begin{code}
-
-coreExprToStg env (Case discrim@(Prim op _) alts)
-  | funnyParallelOp op
-  = getUnique			`thenUs` \ uniq ->
-    coreExprToStg env discrim	`thenUs` \ (stg_discrim, discrim_binds) ->
-    alts_to_stg alts		`thenUs` \ (stg_alts, alts_binds) ->
-    returnUs (
-	StgCase stg_discrim
-		bOGUS_LVs
-		bOGUS_LVs
-		uniq
-		stg_alts,
-	discrim_binds `unionBags` alts_binds
-    )
-  where
-    funnyParallelOp SeqOp  = True
-    funnyParallelOp ParOp  = True
-    funnyParallelOp ForkOp = True
-    funnyParallelOp _      = False
-
-    discrim_ty = coreExprType discrim
-
-    alts_to_stg (PrimAlts _ (BindDefault binder rhs))
-      =	coreExprToStg env rhs  `thenUs` \ (stg_rhs, rhs_binds) ->
-	let
-	    stg_deflt = StgBindDefault binder False stg_rhs
-	in
-	    returnUs (StgPrimAlts discrim_ty [] stg_deflt, rhs_binds)
-
--- OK, back to real life...
-
 coreExprToStg env (Case discrim alts)
-  = coreExprToStg env discrim		`thenUs` \ (stg_discrim, discrim_binds) ->
-    alts_to_stg discrim alts	`thenUs` \ (stg_alts, alts_binds) ->
+  = coreExprToStg env discrim		`thenUs` \ stg_discrim ->
+    alts_to_stg discrim alts		`thenUs` \ stg_alts ->
     getUnique				`thenUs` \ uniq ->
     returnUs (
 	StgCase stg_discrim
 		bOGUS_LVs
 		bOGUS_LVs
 		uniq
-		stg_alts,
-	discrim_binds `unionBags` alts_binds
+		stg_alts
     )
   where
     discrim_ty		    = coreExprType discrim
     (_, discrim_ty_args, _) = getAppDataTyConExpandingDicts discrim_ty
 
     alts_to_stg discrim (AlgAlts alts deflt)
-      = default_to_stg discrim deflt		`thenUs` \ (stg_deflt, deflt_binds) ->
-	mapAndUnzipUs boxed_alt_to_stg alts	`thenUs` \ (stg_alts, alts_binds)  ->
-	returnUs (StgAlgAlts discrim_ty stg_alts stg_deflt,
-		  deflt_binds `unionBags` unionManyBags alts_binds)
+      = default_to_stg discrim deflt		`thenUs` \ stg_deflt ->
+	mapUs boxed_alt_to_stg alts		`thenUs` \ stg_alts  ->
+	returnUs (StgAlgAlts discrim_ty stg_alts stg_deflt)
       where
 	boxed_alt_to_stg (con, bs, rhs)
-	  = coreExprToStg env rhs    `thenUs` \ (stg_rhs, rhs_binds) ->
-	    returnUs ((spec_con, bs, [ True | b <- bs ]{-bogus use mask-}, stg_rhs),
-		       rhs_binds)
+	  = coreExprToStg env rhs    `thenUs` \ stg_rhs ->
+	    returnUs (spec_con, bs, [ True | b <- bs ]{-bogus use mask-}, stg_rhs)
 	  where
 	    spec_con = mkSpecialisedCon con discrim_ty_args
 
     alts_to_stg discrim (PrimAlts alts deflt)
-      = default_to_stg discrim deflt		`thenUs` \ (stg_deflt,deflt_binds) ->
-	mapAndUnzipUs unboxed_alt_to_stg alts	`thenUs` \ (stg_alts, alts_binds)  ->
-	returnUs (StgPrimAlts discrim_ty stg_alts stg_deflt,
-		  deflt_binds `unionBags` unionManyBags alts_binds)
+      = default_to_stg discrim deflt		`thenUs` \ stg_deflt ->
+	mapUs unboxed_alt_to_stg alts		`thenUs` \ stg_alts  ->
+	returnUs (StgPrimAlts discrim_ty stg_alts stg_deflt)
       where
 	unboxed_alt_to_stg (lit, rhs)
-	  = coreExprToStg env rhs    `thenUs` \ (stg_rhs, rhs_binds) ->
-	    returnUs ((lit, stg_rhs), rhs_binds)
+	  = coreExprToStg env rhs    `thenUs` \ stg_rhs ->
+	    returnUs (lit, stg_rhs)
 
     default_to_stg discrim NoDefault
-      = returnUs (StgNoDefault, emptyBag)
+      = returnUs StgNoDefault
 
     default_to_stg discrim (BindDefault binder rhs)
-      = coreExprToStg new_env rhs    `thenUs` \ (stg_rhs, rhs_binds) ->
-	returnUs (StgBindDefault binder True{-used? no it is lying-} stg_rhs,
-		  rhs_binds)
-      where
-	--
-	-- We convert	case x of {...; x' -> ...x'...}
-	--	to
-	--		case x of {...; _  -> ...x... }
-	--
-	-- See notes in SimplCase.lhs, near simplDefault for the reasoning.
-	-- It's quite easily done: simply extend the environment to bind the
-	-- default binder to the scrutinee.
-	--
-	new_env = case discrim of
-		    Var v -> addOneToIdEnv env binder (stgLookup env v)
-		    other   -> env
+      = coreExprToStg env rhs    `thenUs` \ stg_rhs ->
+	returnUs (StgBindDefault binder True{-used? no it is lying-} stg_rhs)
 \end{code}
 
 %************************************************************************
@@ -637,9 +390,9 @@ coreExprToStg env (Case discrim alts)
 
 \begin{code}
 coreExprToStg env (Let bind body)
-  = coreBindToStg env     bind   `thenUs` \ (stg_binds, new_env, float_binds1) ->
-    coreExprToStg new_env body   `thenUs` \ (stg_body, float_binds2) ->
-    returnUs (mkStgLets stg_binds stg_body, float_binds1 `unionBags` float_binds2)
+  = coreBindToStg env     bind   `thenUs` \ (stg_binds, new_env) ->
+    coreExprToStg new_env body   `thenUs` \ stg_body ->
+    returnUs (mkStgLets stg_binds stg_body)
 \end{code}
 
 
@@ -652,8 +405,8 @@ coreExprToStg env (Let bind body)
 Covert core @scc@ expression directly to STG @scc@ expression.
 \begin{code}
 coreExprToStg env (SCC cc expr)
-  = coreExprToStg env expr   `thenUs` \ (stg_expr, binds) ->
-    returnUs (StgSCC (coreExprType expr) cc stg_expr, binds)
+  = coreExprToStg env expr   `thenUs` \ stg_expr ->
+    returnUs (StgSCC (coreExprType expr) cc stg_expr)
 \end{code}
 
 \begin{code}
@@ -667,14 +420,22 @@ coreExprToStg env (Coerce c ty expr) = coreExprToStg env expr
 %*									*
 %************************************************************************
 
-Utilities.
+There's not anything interesting we can ASSERT about \tr{var} if it
+isn't in the StgEnv. (WDP 94/06)
+
+\begin{code}
+stgLookup :: StgEnv -> Id -> StgArg
+stgLookup env var = case (lookupIdEnv env var) of
+		      Nothing   -> StgVarArg var
+		      Just atom -> atom
+\end{code}
 
 Invent a fresh @Id@:
 \begin{code}
 newStgVar :: Type -> UniqSM Id
 newStgVar ty
  = getUnique			`thenUs` \ uniq ->
-   returnUs (mkSysLocal SLIT("stg") uniq ty mkUnknownSrcLoc)
+   returnUs (mkSysLocal SLIT("stg") uniq ty noSrcLoc)
 \end{code}
 
 \begin{code}
diff --git a/ghc/compiler/stgSyn/StgSyn.lhs b/ghc/compiler/stgSyn/StgSyn.lhs
index bac7e8a57c..6de6376cfc 100644
--- a/ghc/compiler/stgSyn/StgSyn.lhs
+++ b/ghc/compiler/stgSyn/StgSyn.lhs
@@ -40,9 +40,9 @@ module StgSyn (
 IMP_Ubiq(){-uitous-}
 
 import CostCentre	( showCostCentre )
-import Id		( externallyVisibleId, idPrimRep, GenId{-instance NamedThing-} )
+import Id		( idPrimRep, GenId{-instance NamedThing-} )
 import Literal		( literalPrimRep, isLitLitLit, Literal{-instance Outputable-} )
-import Name		( isSymLexeme )
+import Name		( pprNonSym )
 import Outputable	( ifPprDebug, interppSP, interpp'SP,
 			  Outputable(..){-instance * Bool-}
 			)
@@ -478,24 +478,11 @@ latest/greatest pragma info.
 \begin{code}
 collectFinalStgBinders
 	:: [StgBinding]	-- input program
-	-> [Id]		-- final externally-visible top-level Ids
+	-> [Id]
 
-collectFinalStgBinders binds
-  = ex [] binds
-  where
-    ex es [] = es
-
-    ex es ((StgNonRec b _) : binds)
-      = if not (externallyVisibleId b) then
-	    ex es binds
-	else
-	    ex (b:es) binds
-
-    ex es ((StgRec []) : binds) = ex es binds
-
-    ex es ((StgRec ((b, rhs) : pairs)) : binds)
-      = ex es (StgNonRec b rhs : (StgRec pairs : binds))
-	    -- OK, a total hack; laziness rules
+collectFinalStgBinders [] = []
+collectFinalStgBinders (StgNonRec b _ : binds) = b : collectFinalStgBinders binds
+collectFinalStgBinders (StgRec bs     : binds) = map fst bs ++ collectFinalStgBinders binds
 \end{code}
 
 %************************************************************************
@@ -643,6 +630,12 @@ pprStgExpr sty (StgCase expr lvs_whole lvs_rhss uniq alts)
 	   ppNest 2 (ppr_alts sty alts),
 	   ppStr "}"]
   where
+    ppr_default sty StgNoDefault = ppNil
+    ppr_default sty (StgBindDefault bndr used expr)
+      = ppHang (ppCat [pp_binder, ppStr "->"]) 4 (ppr sty expr)
+      where
+    	pp_binder = if used then ppr sty bndr else ppChar '_'
+
     pp_ty (StgAlgAlts  ty _ _) = ppr sty ty
     pp_ty (StgPrimAlts ty _ _) = ppr sty ty
 
@@ -651,13 +644,8 @@ pprStgExpr sty (StgCase expr lvs_whole lvs_rhss uniq alts)
 		   ppr_default sty deflt ]
       where
 	ppr_bxd_alt sty (con, params, use_mask, expr)
-	  = ppHang (ppCat [ppr_con sty con, interppSP sty params, ppStr "->"])
+	  = ppHang (ppCat [pprNonSym sty con, interppSP sty params, ppStr "->"])
 		   4 (ppBeside (ppr sty expr) ppSemi)
-	  where
-	    ppr_con sty con
-	      = if isSymLexeme con
-		then ppBesides [ppLparen, ppr sty con, ppRparen]
-		else ppr sty con
 
     ppr_alts sty (StgPrimAlts ty alts deflt)
       = ppAboves [ ppAboves (map (ppr_ubxd_alt sty) alts),
@@ -666,12 +654,6 @@ pprStgExpr sty (StgCase expr lvs_whole lvs_rhss uniq alts)
 	ppr_ubxd_alt sty (lit, expr)
 	  = ppHang (ppCat [ppr sty lit, ppStr "->"])
 		 4 (ppBeside (ppr sty expr) ppSemi)
-
-    ppr_default sty StgNoDefault = ppNil
-    ppr_default sty (StgBindDefault bndr used expr)
-      = ppHang (ppCat [pp_binder, ppStr "->"]) 4 (ppr sty expr)
-      where
-    	pp_binder = if used then ppr sty bndr else ppChar '_'
 \end{code}
 
 \begin{code}
diff --git a/ghc/compiler/stgSyn/StgUtils.lhs b/ghc/compiler/stgSyn/StgUtils.lhs
index d586d8e458..2448e1284f 100644
--- a/ghc/compiler/stgSyn/StgUtils.lhs
+++ b/ghc/compiler/stgSyn/StgUtils.lhs
@@ -6,7 +6,10 @@ x%
 \begin{code}
 #include "HsVersions.h"
 
-module StgUtils ( mapStgBindeesRhs ) where
+module StgUtils
+	-- 	( mapStgBindeesRhs )		Dead code SLPJ Nov 96
+   where
+{-		DEAD CODE	SLPJ Nov 96
 
 IMP_Ubiq(){-uitous-}
 
@@ -19,6 +22,7 @@ This utility function simply applies the given function to every
 bindee in the program.
 
 \begin{code}
+
 mapStgBindeesBind :: (Id -> Id) -> StgBinding -> StgBinding
 
 mapStgBindeesBind fn (StgNonRec b rhs) = StgNonRec b (mapStgBindeesRhs fn rhs)
@@ -87,4 +91,6 @@ mapStgBindeesArg :: (Id -> Id) -> StgArg -> StgArg
 
 mapStgBindeesArg fn a@(StgLitArg _)	= a
 mapStgBindeesArg fn a@(StgVarArg id)  = StgVarArg (fn id)
+
+-}
 \end{code}
diff --git a/ghc/compiler/stranal/SaAbsInt.lhs b/ghc/compiler/stranal/SaAbsInt.lhs
index cb9509a06a..fff2a5d29c 100644
--- a/ghc/compiler/stranal/SaAbsInt.lhs
+++ b/ghc/compiler/stranal/SaAbsInt.lhs
@@ -18,14 +18,15 @@ module SaAbsInt (
 IMP_Ubiq(){-uitous-}
 
 import CoreSyn
-import CoreUnfold	( Unfolding(..), SimpleUnfolding(..), FormSummary )
+import CoreUnfold	( Unfolding(..), UfExpr, RdrName, SimpleUnfolding(..), FormSummary )
 import CoreUtils	( unTagBinders )
 import Id		( idType, getIdStrictness, getIdUnfolding,
 			  dataConTyCon, dataConArgTys
 			)
-import IdInfo		( StrictnessInfo(..), Demand(..),
+import IdInfo		( StrictnessInfo(..),
 			  wwPrim, wwStrict, wwEnum, wwUnpack
 			)
+import Demand		( Demand(..) )
 import MagicUFs		( MagicUnfoldingFun )
 import Maybes		( maybeToBool )
 import Outputable	( Outputable(..){-instance * []-} )
@@ -393,7 +394,7 @@ absId anal var env
 	(Just abs_val, _, _) ->
 			abs_val	-- Bound in the environment
 
-	(Nothing, NoStrictnessInfo, CoreUnfolding (SimpleUnfolding _ _ unfolding)) ->
+	(Nothing, noStrictnessInfo, CoreUnfolding (SimpleUnfolding _ _ unfolding)) ->
 			-- We have an unfolding for the expr
 			-- Assume the unfolding has no free variables since it
 			-- came from inside the Id
diff --git a/ghc/compiler/stranal/SaLib.lhs b/ghc/compiler/stranal/SaLib.lhs
index 20501314da..e3fd7abc05 100644
--- a/ghc/compiler/stranal/SaLib.lhs
+++ b/ghc/compiler/stranal/SaLib.lhs
@@ -25,7 +25,8 @@ import Id		( nullIdEnv, addOneToIdEnv, growIdEnvList,
 			  lookupIdEnv, SYN_IE(IdEnv),
 			  GenId{-instance Outputable-}
 			)
-import IdInfo		( StrictnessInfo(..), Demand{-instance Outputable-} )
+import IdInfo		( StrictnessInfo(..) )
+import Demand		( Demand{-instance Outputable-} )
 import Outputable	( Outputable(..){-instance * []-} )
 import PprType		( GenType{-instance Outputable-} )
 import Pretty		( ppStr, ppCat )
@@ -116,7 +117,7 @@ getStrAnalFlags (AbsValEnv flags _) = flags
 \end{code}
 
 \begin{code}
-absValFromStrictness :: AnalysisKind -> StrictnessInfo -> AbsVal
+absValFromStrictness :: AnalysisKind -> StrictnessInfo bdee -> AbsVal
 
 absValFromStrictness anal NoStrictnessInfo 	       = AbsTop
 
diff --git a/ghc/compiler/stranal/StrictAnal.lhs b/ghc/compiler/stranal/StrictAnal.lhs
index b0c21b4525..9f38eadd09 100644
--- a/ghc/compiler/stranal/StrictAnal.lhs
+++ b/ghc/compiler/stranal/StrictAnal.lhs
@@ -404,13 +404,6 @@ addStrictnessInfoToId
 
 addStrictnessInfoToId strflags str_val abs_val binder body
 
-{-		SCHEDULED FOR NUKING 
-  | isWrapperId binder
-  = binder	-- Avoid clobbering existing strictness info
-		-- (and, more importantly, worker info).
-		-- Deeply suspicious (SLPJ)
--}
-
   | isBot str_val
   = binder `addIdStrictness` mkBottomStrictnessInfo
 
diff --git a/ghc/compiler/stranal/WorkWrap.lhs b/ghc/compiler/stranal/WorkWrap.lhs
index 251b7b2027..457cab22de 100644
--- a/ghc/compiler/stranal/WorkWrap.lhs
+++ b/ghc/compiler/stranal/WorkWrap.lhs
@@ -11,16 +11,16 @@ module WorkWrap ( workersAndWrappers ) where
 IMP_Ubiq(){-uitous-}
 
 import CoreSyn
-import CoreUnfold	( Unfolding(..), UnfoldingGuidance(..), SimpleUnfolding )
-import MagicUFs		( MagicUnfoldingFun )
+import CoreUnfold	( Unfolding, certainlySmallEnoughToInline, calcUnfoldingGuidance )
+import CmdLineOpts	( opt_UnfoldingCreationThreshold )
 
 import CoreUtils	( coreExprType )
 import Id		( idWantsToBeINLINEd, getIdStrictness, mkWorkerId,
 			  addIdStrictness, addInlinePragma,
 			  GenId
 			)
-import IdInfo		( noIdInfo, addInfo_UF, indicatesWorker,
-			  mkStrictnessInfo, StrictnessInfo(..)
+import IdInfo		( noIdInfo, addUnfoldInfo,  
+			  mkStrictnessInfo, addStrictnessInfo, StrictnessInfo(..)
 			)
 import SaLib
 import UniqSupply	( returnUs, thenUs, mapUs, getUnique, SYN_IE(UniqSM) )
@@ -184,7 +184,10 @@ tryWW	:: Id				-- the fn binder
 					-- if two, then a worker and a
 					-- wrapper.
 tryWW fn_id rhs
-  | idWantsToBeINLINEd fn_id
+  | certainlySmallEnoughToInline $
+    calcUnfoldingGuidance (idWantsToBeINLINEd fn_id) 
+			  opt_UnfoldingCreationThreshold
+			  rhs
     -- No point in worker/wrappering something that is going to be
     -- INLINEd wholesale anyway.  If the strictness analyser is run
     -- twice, this test also prevents wrappers (which are INLINEd)
@@ -196,14 +199,8 @@ tryWW fn_id rhs
 
       NoStrictnessInfo    -> do_nothing
       BottomGuaranteed    -> do_nothing
-      StrictnessInfo [] _ -> do_nothing -- V weird (but possible?)
 
       StrictnessInfo args_info _ ->
-	if not (indicatesWorker args_info) then
-	    do_nothing
-	else
-
-	-- OK, it looks as if a worker is worth a try
 	let
 	     (uvars, tyvars, args, body) = collectBinders rhs
 	     body_ty			 = coreExprType body
@@ -211,12 +208,9 @@ tryWW fn_id rhs
 	mkWwBodies body_ty tyvars args args_info `thenUs` \ result ->
 	case result of
 
-	  Nothing -> 	-- Very peculiar. This can only happen if we hit an
-			-- abstract type, which we shouldn't have since we've
-			-- constructed the args_info in this module!
-
-			-- False. We might hit the all-args-absent-and-the-
-			-- body-is-unboxed case.  A Nothing is legit. (WDP 94/10)
+	  Nothing -> 	-- We've hit the all-args-absent-and-the-body-is-unboxed case,
+			-- or there are too many args for a w/w split,
+			-- or there's no benefit from w/w (e.g. SSS)
 			do_nothing
 
 	  Just (wrapper_w_hole, worker_w_hole, worker_strictness, worker_ty_w_hole) ->
@@ -227,7 +221,7 @@ tryWW fn_id rhs
 		worker_ty   = worker_ty_w_hole body_ty
 
 		worker_id   = mkWorkerId worker_uniq fn_id worker_ty
-				(noIdInfo `addInfo` worker_strictness)
+				(noIdInfo `addStrictnessInfo` worker_strictness)
 
 		wrapper_rhs = wrapper_w_hole worker_id
 		worker_rhs  = worker_w_hole body
diff --git a/ghc/compiler/stranal/WwLib.lhs b/ghc/compiler/stranal/WwLib.lhs
index f2762b7a5b..82227725db 100644
--- a/ghc/compiler/stranal/WwLib.lhs
+++ b/ghc/compiler/stranal/WwLib.lhs
@@ -18,7 +18,7 @@ import CoreSyn
 import Id		( idType, mkSysLocal, dataConArgTys )
 import IdInfo		( mkStrictnessInfo, nonAbsentArgs, Demand(..) )
 import PrelVals		( aBSENT_ERROR_ID )
-import SrcLoc		( mkUnknownSrcLoc )
+import SrcLoc		( noSrcLoc )
 import Type		( isPrimType, mkTyVarTys, mkForAllTys, mkFunTys,
 			  maybeAppDataTyConExpandingDicts
 			)
@@ -193,7 +193,7 @@ mkWwBodies
 							--   hole for worker id
 		      CoreExpr -> CoreExpr,	-- Worker expr w/ hole
 	   						--   for original fn body
-		      StrictnessInfo,			-- Worker strictness info
+		      StrictnessInfo Id,		-- Worker strictness info
 		      Type -> Type)		-- Worker type w/ hole
 	   )						--   for type of original fn body
 
@@ -205,7 +205,9 @@ mkWwBodies body_ty tyvars args arg_infos
     then returnUs Nothing
 
     else -- the rest...
-    mk_ww_arg_processing args arg_infos (mAX_WORKER_ARGS - nonAbsentArgs arg_infos)
+    mk_ww_arg_processing args arg_infos 
+			 False 		-- Initialise the "useful-split" flag
+			 (mAX_WORKER_ARGS - nonAbsentArgs arg_infos)
 		`thenMaybeUs` \ (wrap_frag, work_args_info, work_frag) ->
     let
 	(work_args, wrkr_demands) = unzip work_args_info
@@ -261,11 +263,19 @@ mk_ww_arg_processing
 	-> [Demand]		-- Strictness info for those args
 				--   must be at least as long as args
 
+	-> Bool			-- False <=> we've done nothing useful in an enclosing call
+				-- If this is False when we hit the end of the arg list, we
+				-- don't want to do a w/w split... the wrapper would be the identity fn!
+				-- So we return Nothing
+
 	-> Int			-- Number of extra args we are prepared to add.
 				-- This prevents over-eager unpacking, leading
 				-- to huge-arity functions.
 
 	-> UniqSM (Maybe 	-- Nothing iff any unpack on abstract type
+				-- or if the wrapper would be the identity fn (can happen if we unpack
+				-- a huge structure, and decide not to do it)
+
 		     (CoreExpr -> CoreExpr,	-- Wrapper expr w/
 							--   hole for worker id
 							--   applied to types
@@ -274,17 +284,20 @@ mk_ww_arg_processing
 		      CoreExpr -> CoreExpr)	-- Worker body expr w/ hole
 	   )						--   for original fn body
 
-mk_ww_arg_processing [] _ _ = returnUs (Just (id, [], id))
+mk_ww_arg_processing [] _ useful_split _ = if useful_split then
+						returnUs (Just (id, [], id))
+					   else
+						returnUs Nothing
 
-mk_ww_arg_processing (arg : args) (WwLazy True : infos) max_extra_args
+mk_ww_arg_processing (arg : args) (WwLazy True : infos) useful_split max_extra_args
   =  	-- Absent argument
 	-- So, finish args to the right...
     --pprTrace "Absent; num_wrkr_args=" (ppInt num_wrkr_args) (
     let
 	arg_ty = idType arg
     in
-    mk_ww_arg_processing args infos max_extra_args
-				    -- we've already discounted for absent args,
+    mk_ww_arg_processing args infos True {- useful split -} max_extra_args
+				    -- We've already discounted for absent args,
 				    -- so we don't change max_extra_args
 		   `thenMaybeUs` \ (wrap_rest, work_args_info, work_rest) ->
 
@@ -306,7 +319,7 @@ mk_ww_arg_processing (arg : args) (WwLazy True : infos) max_extra_args
 	    panic "WwLib: haven't done mk_absent_let for primitives yet"
 
 
-mk_ww_arg_processing (arg : args) (WwUnpack cmpnt_infos : infos) max_extra_args
+mk_ww_arg_processing (arg : args) (WwUnpack cmpnt_infos : infos) useful_split 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)]) $
@@ -319,6 +332,7 @@ mk_ww_arg_processing (arg : args) (WwUnpack cmpnt_infos : infos) max_extra_args
 	  Just (_, _, []) ->	   -- An abstract type
 				   -- We have to give up on the whole idea
 				   returnUs Nothing
+
 	  Just (_, _, (_:_:_)) ->  -- Two or more constructors; that's odd
 				   panic "mk_ww_arg_processing: multi-constr"
 
@@ -332,12 +346,12 @@ mk_ww_arg_processing (arg : args) (WwUnpack cmpnt_infos : infos) max_extra_args
 
 	    let
 		unpk_args = zipWithEqual "mk_ww_arg_processing"
-			     (\ u t -> mkSysLocal SLIT("upk") u t mkUnknownSrcLoc)
+			     (\ u t -> mkSysLocal SLIT("upk") u t noSrcLoc)
 			     uniqs inst_con_arg_tys
 	    in
 		-- In processing the rest, push the sub-component args
 		-- and infos on the front of the current bunch
-	    mk_ww_arg_processing (unpk_args ++ args) (cmpnt_infos ++ infos) new_max_extra_args
+	    mk_ww_arg_processing (unpk_args ++ args) (cmpnt_infos ++ infos) True {- useful split -} new_max_extra_args
 			`thenMaybeUs` \ (wrap_rest, work_args_info, work_rest) ->
 
 	    returnUs (Just (
@@ -370,14 +384,14 @@ mk_ww_arg_processing (arg : args) (WwUnpack cmpnt_infos : infos) max_extra_args
 			    (map TyArg con_tys ++ map VarArg unpk_args)))
 	      body
 
-mk_ww_arg_processing (arg : args) (arg_demand : infos) max_extra_args
+mk_ww_arg_processing (arg : args) (arg_demand : infos) useful_split max_extra_args
   | otherwise
   = 	-- For all others at the moment, we just
 	-- pass them to the worker unchanged.
     --pprTrace "Other; num_wrkr_args=" (ppCat [ppInt num_wrkr_args, ppStr ";arg=", ppr PprDebug arg, ppr PprDebug arg_demand]) (
 
 	-- Finish args to the right...
-    mk_ww_arg_processing args infos max_extra_args
+    mk_ww_arg_processing args infos useful_split max_extra_args
 			`thenMaybeUs` \ (wrap_rest, work_args_info, work_rest) ->
 
     returnUs (Just (
@@ -389,4 +403,7 @@ mk_ww_arg_processing (arg : args) (arg_demand : infos) max_extra_args
 	      \ hole -> work_rest hole
     ))
     --)
+
+nonAbsentArgs :: [Demand] -> Int
+nonAbsentArgs cmpts = length [() | WwLazy True <- cmpts]
 \end{code}
diff --git a/ghc/compiler/typecheck/GenSpecEtc.lhs b/ghc/compiler/typecheck/GenSpecEtc.lhs
index e3d6267121..08e8367ed5 100644
--- a/ghc/compiler/typecheck/GenSpecEtc.lhs
+++ b/ghc/compiler/typecheck/GenSpecEtc.lhs
@@ -14,7 +14,7 @@ module GenSpecEtc (
 
 IMP_Ubiq()
 
-import TcMonad		hiding ( rnMtoTcM )
+import TcMonad
 import Inst		( Inst, InstOrigin(..), SYN_IE(LIE), plusLIE, 
 			  newDicts, tyVarsOfInst, instToId )
 import TcEnv		( tcGetGlobalTyVars, tcExtendGlobalTyVars )
@@ -34,7 +34,7 @@ import TcHsSyn		( TcIdOcc(..), SYN_IE(TcIdBndr), SYN_IE(TcHsBinds), SYN_IE(TcBin
 import Bag		( Bag, foldBag, bagToList, listToBag, isEmptyBag )
 import Class		( GenClass )
 import Id		( GenId, SYN_IE(Id), mkUserId, idType )
-import Kind		( isUnboxedKind, isTypeKind, mkBoxedTypeKind )
+import Kind		( isUnboxedTypeKind, isTypeKind, mkBoxedTypeKind )
 import ListSetOps	( minusList, unionLists, intersectLists )
 import Maybes		( allMaybes )
 import Name		( Name{--O only-} )
@@ -163,7 +163,7 @@ genBinds binder_names mono_ids bind lie sig_infos prag_info_fn
     let
 	tyvars = tyVarSetToList reduced_tyvars_to_gen	-- Commit to a particular order
 
-        unboxed_kind_tyvars    = filter (isUnboxedKind . tyVarKind) tyvars
+        unboxed_kind_tyvars    = filter (isUnboxedTypeKind . tyVarKind) tyvars
 	unresolved_kind_tyvars = filter (isTypeKind    . tyVarKind) tyvars
 
 	box_it tyvar = newTyVarTy mkBoxedTypeKind	`thenNF_Tc` \ boxed_ty ->
diff --git a/ghc/compiler/typecheck/Inst.lhs b/ghc/compiler/typecheck/Inst.lhs
index 6b8a7afbe2..fa9dba3344 100644
--- a/ghc/compiler/typecheck/Inst.lhs
+++ b/ghc/compiler/typecheck/Inst.lhs
@@ -33,32 +33,31 @@ IMPORT_1_3(Ratio(Rational))
 
 import HsSyn	( HsLit(..), HsExpr(..), HsBinds, 
 		  InPat, OutPat, Stmt, Qualifier, Match,
-		  ArithSeqInfo, PolyType, Fake )
-import RnHsSyn	( SYN_IE(RenamedArithSeqInfo), SYN_IE(RenamedHsExpr),
-		  RnName{-instance NamedThing-}
-		)
+		  ArithSeqInfo, HsType, Fake )
+import RnHsSyn	( SYN_IE(RenamedArithSeqInfo), SYN_IE(RenamedHsExpr) )
 import TcHsSyn	( TcIdOcc(..), SYN_IE(TcExpr), SYN_IE(TcIdBndr),
 		  mkHsTyApp, mkHsDictApp, tcIdTyVars )
 
-import TcMonad	hiding ( rnMtoTcM )
+import TcMonad
 import TcEnv	( tcLookupGlobalValueByKey, tcLookupTyConByKey )
 import TcType	( SYN_IE(TcType), SYN_IE(TcRhoType), TcMaybe, SYN_IE(TcTyVarSet),
 		  tcInstType, zonkTcType )
 
 import Bag	( emptyBag, unitBag, unionBags, unionManyBags, listToBag, consBag )
-import Class	( isCcallishClass, isNoDictClass, classInstEnv,
+import Class	( classInstEnv,
 		  SYN_IE(Class), GenClass, SYN_IE(ClassInstEnv), SYN_IE(ClassOp)
 		)
 import ErrUtils ( addErrLoc, SYN_IE(Error) )
 import Id	( GenId, idType, mkInstId )
+import PrelInfo	( isCcallishClass, isNoDictClass )
 import MatchEnv	( lookupMEnv, insertMEnv )
-import Name	( mkLocalName, getLocalName, Name )
+import Name	( OccName(..), Name, mkLocalName, mkSysLocalName, occNameString )
 import Outputable
 import PprType	( GenClass, TyCon, GenType, GenTyVar, pprParendGenType )	
 import PprStyle	( PprStyle(..) )
 import Pretty
 import SpecEnv	( SpecEnv )
-import SrcLoc	( SrcLoc, mkUnknownSrcLoc )
+import SrcLoc	( SrcLoc, noSrcLoc )
 import Type	( GenType, eqSimpleTy, instantiateTy,
 		  isTyVarTy, mkDictTy, splitForAllTy, splitSigmaTy,
 		  splitRhoTy, matchTy, tyVarsOfType, tyVarsOfTypes,
@@ -236,17 +235,18 @@ 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 str False{-emph name-} loc))
+  = TcId (mkInstId u (mkDictTy clas ty) (mkLocalName u str loc))
   where
-    str = SLIT("d.") _APPEND_ (getLocalName clas)
+    str = VarOcc (SLIT("d.") _APPEND_ (occNameString (getOccName clas)))
+
 instToId (Method u id tys rho_ty orig loc)
-  = TcId (mkInstId u tau_ty (mkLocalName u str False{-emph name-} 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)
+    str = VarOcc (SLIT("m.") _APPEND_ (occNameString (getOccName id)))
 
 instToId (LitInst u list ty orig loc)
-  = TcId (mkInstId u ty (mkLocalName u SLIT("lit") True{-emph uniq-} loc))
+  = TcId (mkInstId u ty (mkSysLocalName u SLIT("lit") loc))
 \end{code}
 
 \begin{code}
diff --git a/ghc/compiler/typecheck/TcBinds.lhs b/ghc/compiler/typecheck/TcBinds.lhs
index 7d5b01c006..3ce5967cea 100644
--- a/ghc/compiler/typecheck/TcBinds.lhs
+++ b/ghc/compiler/typecheck/TcBinds.lhs
@@ -11,39 +11,40 @@ module TcBinds ( tcBindsAndThen, tcPragmaSigs ) where
 IMP_Ubiq()
 
 import HsSyn		( HsBinds(..), Bind(..), Sig(..), MonoBinds(..), 
-			  HsExpr, Match, PolyType, InPat, OutPat(..),
+			  HsExpr, Match, HsType, InPat, OutPat(..),
 			  GRHSsAndBinds, ArithSeqInfo, HsLit, Fake,
 			  collectBinders )
 import RnHsSyn		( SYN_IE(RenamedHsBinds), SYN_IE(RenamedBind), RenamedSig(..), 
-			  SYN_IE(RenamedMonoBinds), RnName(..) 
+			  SYN_IE(RenamedMonoBinds)
 			)
 import TcHsSyn		( SYN_IE(TcHsBinds), SYN_IE(TcBind), SYN_IE(TcMonoBinds),
 			  TcIdOcc(..), SYN_IE(TcIdBndr) )
 
-import TcMonad		hiding ( rnMtoTcM )	
+import TcMonad
 import GenSpecEtc	( checkSigTyVars, genBinds, TcSigInfo(..) )
 import Inst		( Inst, SYN_IE(LIE), emptyLIE, plusLIE, InstOrigin(..) )
 import TcEnv		( tcExtendLocalValEnv, tcLookupLocalValueOK, newMonoIds )
 import SpecEnv		( SpecEnv )
 IMPORT_DELOOPER(TcLoop)		( tcGRHSsAndBinds )
 import TcMatches	( tcMatchesFun )
-import TcMonoType	( tcPolyType )
+import TcMonoType	( tcHsType )
 import TcPat		( tcPat )
 import TcSimplify	( bindInstsOfLocalFuns )
-import TcType		( newTcTyVar, tcInstSigType )
+import TcType		( newTcTyVar, tcInstSigType, newTyVarTys )
 import Unify		( unifyTauTy )
 
 import Kind		( mkBoxedTypeKind, mkTypeKind )
-import Id		( GenId, idType, mkUserId )
+import Id		( GenId, idType, mkUserLocal, mkUserId )
 import IdInfo		( noIdInfo )
 import Maybes		( assocMaybe, catMaybes )
-import Name		( pprNonSym, Name )
+import Name		( pprNonSym, getOccName, getSrcLoc, Name )
 import PragmaInfo	( PragmaInfo(..) )
 import Pretty
 import Type		( mkTyVarTy, mkTyVarTys, isTyVarTy,
 			  mkSigmaTy, splitSigmaTy,
 			  splitRhoTy, mkForAllTy, splitForAllTy )
-import Util		( isIn, zipEqual, panic )
+import Bag		( bagToList )
+import Util		( isIn, zipEqual, zipWith3Equal, panic )
 \end{code}
 
 %************************************************************************
@@ -175,15 +176,11 @@ tcBindAndThen combiner bind sigs do_next
     )					`thenTc` \ (_, result) ->
     returnTc result
   where
-    binder_names = collectBinders bind
+    binder_names = map fst (bagToList (collectBinders bind))
 
 
-tcBindAndSigs binder_rn_names bind sigs prag_info_fn
-  = let
-	binder_names = map de_rn binder_rn_names
-	de_rn (RnName n) = n
-    in
-    recoverTc (
+tcBindAndSigs binder_names bind sigs prag_info_fn
+  = recoverTc (
 	-- If typechecking the binds fails, then return with each
 	-- binder given type (forall a.a), to minimise subsequent
 	-- error messages
@@ -197,17 +194,24 @@ tcBindAndSigs binder_rn_names bind sigs prag_info_fn
     ) $
 
 	-- Create a new identifier for each binder, with each being given
-	-- a type-variable type.
-    newMonoIds binder_rn_names kind (\ mono_ids ->
+	-- a fresh unique, and a type-variable type.
+    tcGetUniques no_of_binders			`thenNF_Tc` \ uniqs ->
+    newTyVarTys no_of_binders kind		`thenNF_Tc` \ tys ->
+    let
+	mono_ids           = zipWith3Equal "tcBindAndSigs" mk_id binder_names uniqs tys
+	mk_id name uniq ty = mkUserLocal (getOccName name) uniq ty (getSrcLoc name)
+    in
+    tcExtendLocalValEnv binder_names mono_ids (
 	    tcTySigs sigs		`thenTc` \ sig_info ->
 	    tc_bind bind		`thenTc` \ (bind', lie) ->
-	    returnTc (mono_ids, bind', lie, sig_info)
+	    returnTc (bind', lie, sig_info)
     )
-	    `thenTc` \ (mono_ids, bind', lie, sig_info) ->
+	    `thenTc` \ (bind', lie, sig_info) ->
 
 	    -- Notice that genBinds gets the old (non-extended) environment
     genBinds binder_names mono_ids bind' lie sig_info prag_info_fn
   where
+    no_of_binders = length binder_names
     kind = case bind of
 	  	NonRecBind _ -> mkTypeKind	-- Recursive, so no unboxed types
 		RecBind _    -> mkBoxedTypeKind	-- Non-recursive, so we permit unboxed types
@@ -219,7 +223,7 @@ tcBindAndSigs binder_rn_names bind sigs prag_info_fn
 {-
 
 data SigInfo
-  = SigInfo	RnName
+  = SigInfo	Name
 		(TcIdBndr s)		-- Polymorpic version
 		(TcIdBndr s)		-- Monomorphic verstion
 		[TcType s] [TcIdOcc s] 	-- Instance information for the monomorphic version
@@ -238,7 +242,7 @@ data SigInfo
 
 	-- Typecheck the binding group
     tcExtendLocalEnv poly_sigs		(
-    newMonoIds nosig_binders kind	(\ nosig_local_ids ->
+    newLocalIds nosig_binders kind	(\ nosig_local_ids ->
 	    tcMonoBinds mono_sigs mono_binds	`thenTc` \ binds_w_lies ->
 	    returnTc (nosig_local_ids, binds_w_lies)
     ))					`thenTc` \ (nosig_local_ids, binds_w_lies) ->
@@ -448,9 +452,9 @@ split up, and have fresh type variables installed.  All non-type-signature
 \begin{code}
 tcTySigs :: [RenamedSig] -> TcM s [TcSigInfo s]
 
-tcTySigs (Sig v ty _ src_loc : other_sigs)
+tcTySigs (Sig v ty src_loc : other_sigs)
  = tcAddSrcLoc src_loc (
-	tcPolyType ty			`thenTc` \ sigma_ty ->
+	tcHsType ty			`thenTc` \ sigma_ty ->
 	tcInstSigType sigma_ty		`thenNF_Tc` \ sigma_ty' ->
 	let
 	    (tyvars', theta', tau') = splitSigmaTy sigma_ty'
@@ -506,11 +510,11 @@ Here are the easy cases for tcPragmaSigs
 
 \begin{code}
 tcPragmaSig (DeforestSig name loc)
-  = returnTc ((name, addInfo DoDeforest),EmptyBinds,emptyLIE)
+  = returnTc ((name, addDeforestInfo DoDeforest),EmptyBinds,emptyLIE)
 tcPragmaSig (InlineSig name loc)
-  = returnTc ((name, addInfo_UF (iWantToBeINLINEd UnfoldAlways)), EmptyBinds, emptyLIE)
+  = returnTc ((name, addUnfoldInfo (iWantToBeINLINEd UnfoldAlways)), EmptyBinds, emptyLIE)
 tcPragmaSig (MagicUnfoldingSig name string loc)
-  = returnTc ((name, addInfo_UF (mkMagicUnfolding string)), EmptyBinds, emptyLIE)
+  = returnTc ((name, addUnfoldInfo (mkMagicUnfolding string)), EmptyBinds, emptyLIE)
 \end{code}
 
 The interesting case is for SPECIALISE pragmas.  There are two forms.
@@ -567,7 +571,7 @@ tcPragmaSig (SpecSig name poly_ty maybe_spec_name src_loc)
     tcAddErrCtxt (valSpecSigCtxt name spec_ty)	$
 
 	-- Get and instantiate its alleged specialised type
-    tcPolyType poly_ty				`thenTc` \ sig_sigma ->
+    tcHsType poly_ty				`thenTc` \ sig_sigma ->
     tcInstSigType  sig_sigma			`thenNF_Tc` \ sig_ty ->
     let
 	(sig_tyvars, sig_theta, sig_tau) = splitSigmaTy sig_ty
@@ -642,7 +646,7 @@ tcPragmaSig (SpecSig name poly_ty maybe_spec_name src_loc)
 	   		 VarMonoBind spec_pragma_id (HsVar (TcId local_spec_id))
 	    spec_info  = SpecInfo spec_tys (length main_theta) local_spec_id
 	in
-	returnTc ((name, addInfo spec_info), spec_binds, spec_lie)
+	returnTc ((name, addSpecInfo spec_info), spec_binds, spec_lie)
 -}
 \end{code}
 
@@ -656,6 +660,8 @@ tcPragmaSig (SpecSig name poly_ty maybe_spec_name src_loc)
 Not exported:
 
 \begin{code}
+{-	 In GenSpec at the moment
+
 isUnRestrictedGroup :: [TcIdBndr s]		-- Signatures given for these
 		    -> TcBind s
 		    -> Bool
@@ -673,6 +679,7 @@ isUnResMono sigs (FunMonoBind _ _ _ _)			= True
 isUnResMono sigs (AndMonoBinds mb1 mb2)			= isUnResMono sigs mb1 &&
 							  isUnResMono sigs mb2
 isUnResMono sigs EmptyMonoBinds				= True
+-}
 \end{code}
 
 
diff --git a/ghc/compiler/typecheck/TcClassDcl.lhs b/ghc/compiler/typecheck/TcClassDcl.lhs
index fea81a43da..48af28e0e0 100644
--- a/ghc/compiler/typecheck/TcClassDcl.lhs
+++ b/ghc/compiler/typecheck/TcClassDcl.lhs
@@ -10,15 +10,16 @@ module TcClassDcl ( tcClassDecl1, tcClassDecls2 ) where
 
 IMP_Ubiq()
 
-import HsSyn		( ClassDecl(..), HsBinds(..), Bind(..), MonoBinds(..),
-			  Match(..), GRHSsAndBinds(..), GRHS(..), HsExpr(..),
-			  HsLit(..), OutPat(..), Sig(..), PolyType(..), MonoType, 
+import HsSyn		( HsDecl(..), ClassDecl(..), HsBinds(..), Bind(..), MonoBinds(..),
+			  Match(..), GRHSsAndBinds(..), GRHS(..), HsExpr(..), 
+			  DefaultDecl, TyDecl, InstDecl, IfaceSig,
+			  HsLit(..), OutPat(..), Sig(..), HsType(..), HsTyVar,
 			  Stmt, Qualifier, ArithSeqInfo, InPat, Fake )
+import HsTypes		( getTyVarName )
 import HsPragmas	( ClassPragmas(..) )
 import RnHsSyn		( RenamedClassDecl(..), RenamedClassPragmas(..),
 			  RenamedClassOpSig(..), SYN_IE(RenamedMonoBinds),
-			  RenamedGenPragmas(..), RenamedContext(..),
-			  RnName{-instance Uniquable-}
+			  RenamedGenPragmas(..), RenamedContext(..), SYN_IE(RenamedHsDecl)
 			)
 import TcHsSyn		( TcIdOcc(..), SYN_IE(TcHsBinds), SYN_IE(TcMonoBinds), SYN_IE(TcExpr),
 			  mkHsTyApp, mkHsTyLam, mkHsDictApp, mkHsDictLam, tcIdType )
@@ -27,20 +28,21 @@ import Inst		( Inst, InstOrigin(..), SYN_IE(LIE), emptyLIE, plusLIE, newDicts, n
 import TcEnv		( tcLookupClass, tcLookupTyVar, tcLookupTyCon, newLocalIds, tcExtendGlobalTyVars )
 import TcInstDcls	( processInstBinds )
 import TcKind		( unifyKind, TcKind )
-import TcMonad		hiding ( rnMtoTcM )
-import TcMonoType	( tcPolyType, tcMonoType, tcContext )
+import TcMonad
+import TcMonoType	( tcHsType, tcContext )
 import TcSimplify	( tcSimplifyAndCheck )
 import TcType		( SYN_IE(TcType), SYN_IE(TcTyVar), tcInstType, tcInstSigTyVars, tcInstSigType )
 
 import Bag		( foldBag, unionManyBags )
-import Class		( GenClass, mkClass, mkClassOp, classBigSig, 
+import Class		( GenClass, GenClassOp, mkClass, mkClassOp, classBigSig, 
 			  classOps, classOpString, classOpLocalType,
-			  classOpTagByString, SYN_IE(ClassOp)
+			  classOpTagByOccName, SYN_IE(ClassOp)
 			)
-import Id		( mkSuperDictSelId, mkMethodSelId, mkDefaultMethodId,
+import Id		( GenId, mkSuperDictSelId, mkMethodSelId, mkDefaultMethodId, getIdUnfolding,
 			  idType )
+import CoreUnfold	( getUnfoldingTemplate )
 import IdInfo
-import Name		( isLocallyDefined, origName, getLocalName )
+import Name		( Name, isLocallyDefined, moduleString, modAndOcc, nameString )
 import PrelVals		( nO_DEFAULT_METHOD_ERROR_ID )
 import PprStyle
 import Pretty
@@ -57,7 +59,7 @@ import Util
 
 -- import TcPragmas	( tcGenPragmas, tcClassOpPragmas )
 tcGenPragmas ty id ps = returnNF_Tc noIdInfo
-tcClassOpPragmas ty sel def spec ps = returnNF_Tc (noIdInfo `addInfo` spec, 
+tcClassOpPragmas ty sel def spec ps = returnNF_Tc (noIdInfo `addSpecInfo` spec, 
 						   noIdInfo)
 \end{code}
 
@@ -104,8 +106,8 @@ tcClassDecl1 rec_inst_mapper
     tcAddErrCtxt (classDeclCtxt class_name) $
 
 	-- LOOK THINGS UP IN THE ENVIRONMENT
-    tcLookupClass class_name	`thenNF_Tc` \ (class_kind, rec_class) ->
-    tcLookupTyVar tyvar_name	`thenNF_Tc` \ (tyvar_kind, rec_tyvar) ->
+    tcLookupClass class_name			`thenTc` \ (class_kind, rec_class) ->
+    tcLookupTyVar (getTyVarName tyvar_name)	`thenNF_Tc` \ (tyvar_kind, rec_tyvar) ->
     let
 	(rec_class_inst_env, rec_class_op_inst_fn) = rec_inst_mapper rec_class
     in
@@ -175,41 +177,22 @@ tcClassContext rec_class rec_tyvar context pragmas
     in
 
 	-- Make super-class selector ids
-    mapTc (mk_super_id rec_class) 
-	  (super_classes `zip` maybe_pragmas) `thenTc` \ sc_sel_ids ->
-	  -- NB: we worry about matching list lengths below
+    mapTc (mk_super_id rec_class) super_classes	`thenTc` \ sc_sel_ids ->
 
 	-- Done
     returnTc (super_classes, sc_sel_ids)
 
   where
-    mk_super_id rec_class (super_class, maybe_pragma)
-        = fixTc ( \ rec_super_id ->
-	    tcGetUnique			`thenNF_Tc` \ uniq ->
-
-		-- GET THE PRAGMA INFO FOR THE SUPERCLASS
-	    (case maybe_pragma of
-		Nothing   -> returnNF_Tc noIdInfo
-		Just prag -> tcGenPragmas Nothing{-ty unknown-} rec_super_id prag
-	    )				`thenNF_Tc` \ id_info ->
-	    let
-		rec_tyvar_ty = mkTyVarTy rec_tyvar
+    rec_tyvar_ty = mkTyVarTy rec_tyvar
+
+    mk_super_id rec_class super_class
+        = tcGetUnique			`thenNF_Tc` \ uniq ->
+	  let
 		ty = mkForAllTy rec_tyvar $
 		     mkFunTy (mkDictTy rec_class   rec_tyvar_ty)
 			     (mkDictTy super_class rec_tyvar_ty)
-	    in
-		-- BUILD THE SUPERCLASS ID
-	    returnTc (mkSuperDictSelId uniq rec_class super_class ty id_info)
-	  )
-
-    maybe_pragmas :: [Maybe RenamedGenPragmas]
-    maybe_pragmas = case pragmas of
-			NoClassPragmas	       -> repeat Nothing
-			SuperDictPragmas prags -> ASSERT(length prags == length context)
-						  map Just prags
-			-- If there are any pragmas there should
-			-- be one for each superclass
-
+	  in
+	  returnTc (mkSuperDictSelId uniq rec_class super_class ty)
 
 
 tcClassSig :: Class	    		-- Knot tying only!
@@ -232,30 +215,22 @@ tcClassSig rec_clas rec_clas_tyvar rec_classop_spec_fn
 
     -- NB: Renamer checks that the class type variable is mentioned in local_ty,
     -- and that it is not constrained by theta
-    tcPolyType op_ty				`thenTc` \ local_ty ->
+    tcHsType op_ty				`thenTc` \ local_ty ->
     let
 	global_ty   = mkSigmaTy [rec_clas_tyvar] 
 			        [(rec_clas, mkTyVarTy rec_clas_tyvar)]
 			        local_ty
-	class_op_nm = getLocalName op_name
+	class_op_nm = getOccName op_name
 	class_op    = mkClassOp class_op_nm
-				(classOpTagByString rec_clas{-yeeps!-} class_op_nm)
+				(classOpTagByOccName rec_clas{-yeeps!-} class_op_nm)
 				local_ty
     in
 
-	-- Munch the pragmas
-    tcClassOpPragmas
-		global_ty
-		rec_sel_id rec_defm_id
-		(rec_classop_spec_fn class_op)
-		pragmas				`thenNF_Tc` \ (op_info, defm_info) ->
-
 	-- Build the selector id and default method id
     tcGetUnique					`thenNF_Tc` \ d_uniq ->
     let
-	op_uniq = uniqueOf op_name
-	sel_id  = mkMethodSelId     op_uniq rec_clas class_op global_ty op_info
-	defm_id = mkDefaultMethodId d_uniq  rec_clas class_op False global_ty defm_info
+	sel_id  = mkMethodSelId     op_name        rec_clas class_op       global_ty
+	defm_id = mkDefaultMethodId op_name d_uniq rec_clas class_op False global_ty
 			-- ToDo: improve the "False"
     in
     returnTc (class_op, sel_id, defm_id)
@@ -286,14 +261,13 @@ The function @tcClassDecls2@ just arranges to apply @tcClassDecl2@ to
 each local class decl.
 
 \begin{code}
-tcClassDecls2 :: Bag RenamedClassDecl
+tcClassDecls2 :: [RenamedHsDecl]
 	      -> NF_TcM s (LIE s, TcHsBinds s)
 
 tcClassDecls2 decls
-  = foldBag combine
-	    tcClassDecl2
-	    (returnNF_Tc (emptyLIE, EmptyBinds))
-	    decls
+  = foldr combine
+	  (returnNF_Tc (emptyLIE, EmptyBinds))
+	  [tcClassDecl2 cls_decl | ClD cls_decl <- decls]
   where
     combine tc1 tc2 = tc1 `thenNF_Tc` \ (lie1, binds1) ->
 		      tc2 `thenNF_Tc` \ (lie2, binds2) ->
@@ -318,17 +292,20 @@ tcClassDecl2 (ClassDecl context class_name
     tcAddSrcLoc src_loc		     		      $
 
 	-- Get the relevant class
-    tcLookupClass class_name		`thenNF_Tc` \ (_, clas) ->
+    tcLookupClass class_name		`thenTc` \ (_, clas) ->
     let
 	(tyvar, scs, sc_sel_ids, ops, op_sel_ids, defm_ids)
 	  = classBigSig clas
+
+	-- The selector binds are already in the selector Id's unfoldings
+    	sel_binds = SingleBind $ NonRecBind $ foldr AndMonoBinds EmptyMonoBinds $
+		    [ CoreMonoBind (RealId sel_id) (getUnfoldingTemplate (getIdUnfolding sel_id))
+		    | sel_id <- sc_sel_ids ++ op_sel_ids, 
+		      isLocallyDefined sel_id
+		    ]
     in
+	-- Generate bindings for the default methods
     tcInstSigTyVars [tyvar]		`thenNF_Tc` \ ([clas_tyvar], _, _) ->
-
-	-- Generate bindings for the selector functions
-    buildSelectors clas tyvar clas_tyvar scs sc_sel_ids ops op_sel_ids
-					`thenNF_Tc` \ sel_binds ->
-	-- Ditto for the methods
     buildDefaultMethodBinds clas clas_tyvar defm_ids default_binds
 					`thenTc` \ (const_insts, meth_binds) ->
 
@@ -337,134 +314,6 @@ tcClassDecl2 (ClassDecl context class_name
 
 %************************************************************************
 %*									*
-\subsection[ClassDcl-bld-sels]{Building the selector functions for methods and superclasses}
-%*									*
-%************************************************************************
-
-\begin{code}
-buildSelectors :: Class			-- The class object
-	       -> TyVar			-- Class type variable
-	       -> TcTyVar s		-- Instantiated class type variable (TyVarTy)
-	       -> [Class] -> [Id]	-- Superclasses and selectors
-	       -> [ClassOp] -> [Id]	-- Class ops and selectors
-	       -> NF_TcM s (TcHsBinds s)
-
-buildSelectors clas clas_tyvar clas_tc_tyvar scs sc_sel_ids ops op_sel_ids
-  =
-	-- Make new Ids for the components of the dictionary
-    let
-	clas_tyvar_ty = mkTyVarTy clas_tc_tyvar
-	mk_op_ty = tcInstType [(clas_tyvar, clas_tyvar_ty)] . classOpLocalType 
-    in
-    mapNF_Tc mk_op_ty ops  				`thenNF_Tc` \ op_tys ->
-    newLocalIds (map classOpString ops) op_tys	`thenNF_Tc` \ method_ids ->
-
-    newDicts ClassDeclOrigin 
-	     [ (super_clas, clas_tyvar_ty)
-	     | super_clas <- scs ]			`thenNF_Tc` \ (_,dict_ids) ->
-
-    newDicts ClassDeclOrigin 
-	     [ (clas, clas_tyvar_ty) ]			`thenNF_Tc` \ (_,[clas_dict]) ->
-
-	 -- Make suitable bindings for the selectors
-    let
-	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_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 (
-		 foldr AndMonoBinds
-		       (foldr AndMonoBinds EmptyMonoBinds op_sel_binds)
-		       sc_sel_binds
-		 )))
-\end{code}
-
-%************************************************************************
-%*									*
-\subsection[ClassDcl-misc]{Miscellaneous}
-%*									*
-%************************************************************************
-
-Make a selector expression for @sel_id@ from a dictionary @clas_dict@
-consisting of @dicts@ and @methods@.
-
-======================	OLD ============================
-We have to do a bit of jiggery pokery to get the type variables right.
-Suppose we have the class decl:
-\begin{verbatim}
-	class Foo a where
-		op1 :: Ord b => a -> b -> a
-		op2 :: ...
-\end{verbatim}
-Then the method selector for \tr{op1} is like this:
-\begin{verbatim}
-	op1_sel = /\a b -> \dFoo dOrd -> case dFoo of
-					 (op1_method,op2_method) -> op1_method b dOrd
-\end{verbatim}
-Note that the type variable for \tr{b} and the (Ord b) dictionary
-are lifted to the top lambda, and
-\tr{op1_method} is applied to them.  This is preferable to the alternative:
-\begin{verbatim}
-	op1_sel' = /\a -> \dFoo -> case dFoo of
-					(op1_method,op2_method) -> op1_method
-\end{verbatim}
-because \tr{op1_sel'} then has the rather strange type
-\begin{verbatim}
-	op1_sel' :: forall a. Foo a -> forall b. Ord b -> a -> b -> a
-\end{verbatim}
-whereas \tr{op1_sel} (the one we use) has the decent type
-\begin{verbatim}
-	op1_sel :: forall a b. Foo a -> Ord b -> a -> b -> a
-\end{verbatim}
-========================= END OF OLD ===========================
-
-NEW COMMENT: instead we now go for op1_sel' above.  Seems tidier and
-the rest of the compiler darn well ought to cope.
-
-
-
-NOTE that we return a TcMonoBinds (which is later zonked) even though
-there's no real back-substitution to do. It's just simpler this way!
-
-NOTE ALSO that the selector has no free type variables, so we
-don't bother to instantiate the class-op's local type; instead
-we just use the variables inside it.
-
-\begin{code}
-mkSelBind :: Id 			-- the selector id
-	  -> TcTyVar s -> TcIdOcc s	-- class tyvar and dict
-	  -> [TcIdOcc s] -> [TcIdOcc s] -- superclasses and methods in class dict
-	  -> TcIdOcc s 			-- the superclass/method being slected
-	  -> NF_TcM s (TcMonoBinds s)
-
-mkSelBind sel_id clas_tyvar clas_dict dicts methods method_or_dict@(TcId op)
-  = 
-	-- sel_id = /\ clas_tyvar -> \ clas_dict ->
-	--	    case clas_dict of 
-	--		 <dicts..methods> -> method_or_dict
-
-    returnNF_Tc (VarMonoBind (RealId sel_id)  (
-		 TyLam [clas_tyvar] (
-		 DictLam [clas_dict] (
-		 HsCase
-		   (HsVar clas_dict)
-                   ([PatMatch  (DictPat dicts methods) (
-		     GRHSMatch (GRHSsAndBindsOut
-			[OtherwiseGRHS
-			   (HsVar method_or_dict)
-		  	   mkGeneratedSrcLoc]
-			EmptyBinds
-			(idType op)))])
-		    mkGeneratedSrcLoc
-		 ))))
-\end{code}
-
-
-%************************************************************************
-%*									*
 \subsection[Default methods]{Default methods}
 %*									*
 %************************************************************************
@@ -601,28 +450,15 @@ makeClassDeclDefaultMethodRhs clas method_ids tag
     returnNF_Tc (HsApp (mkHsTyApp (HsVar (RealId nO_DEFAULT_METHOD_ERROR_ID)) [tcIdType method_id])
 		       (HsLitOut (HsString (_PK_ error_msg)) stringTy))
 
-{-	OLD AND COMPLICATED
-    tcInstSigType () 	`thenNF_Tc` \ method_ty ->
-    let 
-	(tyvars, theta, tau) = splitSigmaTy method_ty 
-    in	
-    newDicts ClassDeclOrigin theta	`thenNF_Tc` \ (lie, dict_ids) ->
-
-    returnNF_Tc (mkHsTyLam tyvars (
-		 mkHsDictLam dict_ids (
-		 HsApp (mkHsTyApp (HsVar (RealId nO_DEFAULT_METHOD_ERROR_ID)) [tau])
-		     (HsLitOut (HsString (_PK_ error_msg)) stringTy))))
--}
-
   where
-    (OrigName clas_mod clas_name) = origName "makeClassDeclDefaultMethodRhs" clas
+    (clas_mod, clas_name) = modAndOcc clas
 
     method_id = method_ids  !! (tag-1)
     class_op  = (classOps clas) !! (tag-1)
 
-    error_msg = _UNPK_ clas_mod ++ "." ++ _UNPK_ clas_name ++ "."
+    error_msg =  _UNPK_ (nameString (getName clas))
 		 ++ (ppShow 80 (ppr PprForUser class_op))
-		 ++ "\""
+--		 ++ "\""		Don't know what this trailing quote is for!
 \end{code}
 
 
diff --git a/ghc/compiler/typecheck/TcDefaults.lhs b/ghc/compiler/typecheck/TcDefaults.lhs
index 066f90e625..bb0557d4b6 100644
--- a/ghc/compiler/typecheck/TcDefaults.lhs
+++ b/ghc/compiler/typecheck/TcDefaults.lhs
@@ -10,35 +10,40 @@ module TcDefaults ( tcDefaults ) where
 
 IMP_Ubiq()
 
-import HsSyn		( DefaultDecl(..), MonoType,
+import HsSyn		( HsDecl(..), TyDecl, ClassDecl, InstDecl, HsBinds,
+			  DefaultDecl(..), HsType, IfaceSig,
 			  HsExpr, HsLit, ArithSeqInfo, Fake, InPat)
-import RnHsSyn		( RenamedDefaultDecl(..) )
+import RnHsSyn		( RenamedHsDecl(..), RenamedDefaultDecl(..) )
 import TcHsSyn		( TcIdOcc )
 
-import TcMonad		hiding ( rnMtoTcM )
+import TcMonad
 import Inst		( InstOrigin(..) )
 import TcEnv		( tcLookupClassByKey )
 import SpecEnv		( SpecEnv )
-import TcMonoType	( tcMonoType )
+import TcMonoType	( tcHsType )
 import TcSimplify	( tcSimplifyCheckThetas )
 
 import TysWiredIn	( intTy, doubleTy, unitTy )
 import Unique		( numClassKey )
+import Pretty		( ppStr, ppAboves )
+import ErrUtils		( addShortErrLocLine )
 import Util
 \end{code}
 
 \begin{code}
-tcDefaults :: [RenamedDefaultDecl]
+default_default = [intTy, doubleTy] 	    -- language-specified default `default'
+
+tcDefaults :: [RenamedHsDecl]
 	   -> TcM s [Type] 	    -- defaulting types to heave
 				    -- into Tc monad for later use
 				    -- in Disambig.
+tcDefaults decls = tc_defaults [default_decl | DefD default_decl <- decls]
 
-tcDefaults []
-  = returnTc [intTy, doubleTy] 	    -- language-specified default `default'
+tc_defaults [] = returnTc default_default
 
-tcDefaults [DefaultDecl mono_tys locn]
+tc_defaults [DefaultDecl mono_tys locn]
   = tcAddSrcLoc locn $
-    mapTc tcMonoType mono_tys	`thenTc` \ tau_tys ->
+    mapTc tcHsType mono_tys	`thenTc` \ tau_tys ->
 
     case tau_tys of
       [] -> returnTc []		-- no defaults
@@ -53,4 +58,19 @@ tcDefaults [DefaultDecl mono_tys locn]
 
 	returnTc tau_tys
 
+tc_defaults decls
+  = failTc (dupDefaultDeclErr decls)
+
+
+dupDefaultDeclErr (DefaultDecl _ locn1 : dup_things) sty
+  = ppAboves (item1 : map dup_item dup_things)
+  where
+    item1
+      = addShortErrLocLine locn1 (\ sty ->
+	ppStr "multiple default declarations") sty
+
+    dup_item (DefaultDecl _ locn)
+      = addShortErrLocLine locn (\ sty ->
+	ppStr "here was another default declaration") sty
+
 \end{code}
diff --git a/ghc/compiler/typecheck/TcDeriv.lhs b/ghc/compiler/typecheck/TcDeriv.lhs
index c937957070..fee38f4a5b 100644
--- a/ghc/compiler/typecheck/TcDeriv.lhs
+++ b/ghc/compiler/typecheck/TcDeriv.lhs
@@ -12,11 +12,14 @@ module TcDeriv ( tcDeriving ) where
 
 IMP_Ubiq()
 
-import HsSyn		( FixityDecl, Sig, HsBinds(..), Bind(..), MonoBinds(..),
+import HsSyn		( HsDecl, FixityDecl, Fixity, InstDecl, 
+			  Sig, HsBinds(..), Bind(..), MonoBinds(..),
 			  GRHSsAndBinds, Match, HsExpr, HsLit, InPat,
-			  ArithSeqInfo, Fake, MonoType )
+			  ArithSeqInfo, Fake, HsType
+			)
 import HsPragmas	( InstancePragmas(..) )
-import RnHsSyn		( mkRnName, RnName(..), SYN_IE(RenamedHsBinds), RenamedFixityDecl(..) )
+import RdrHsSyn		( RdrName, SYN_IE(RdrNameMonoBinds) )
+import RnHsSyn		( SYN_IE(RenamedHsBinds), SYN_IE(RenamedMonoBinds), SYN_IE(RenamedFixityDecl) )
 import TcHsSyn		( TcIdOcc )
 
 import TcMonad
@@ -28,18 +31,19 @@ import TcGenDeriv	-- Deriv stuff
 import TcInstUtil	( InstInfo(..), mkInstanceRelatedIds, buildInstanceEnvs )
 import TcSimplify	( tcSimplifyThetas )
 
-import RnMonad
-import RnUtils		( SYN_IE(RnEnv), extendGlobalRnEnv )
-import RnBinds		( rnMethodBinds, rnTopBinds )
+import RnBinds		( rnMethodBinds, rnTopMonoBinds )
+import RnEnv		( newDfunName )
+import RnMonad		( SYN_IE(RnM), RnDown, GDown, SDown, RnNameSupply(..), 
+			  setNameSupplyRn, renameSourceCode, thenRn, mapRn, returnRn )
 
 import Bag		( Bag, isEmptyBag, unionBags, listToBag )
-import Class		( classKey, needsDataDeclCtxtClassKeys, GenClass )
+import Class		( classKey, GenClass )
 import ErrUtils		( pprBagOfErrors, addErrLoc, SYN_IE(Error) )
 import Id		( dataConArgTys, isNullaryDataCon, mkDictFunId )
+import PrelInfo		( needsDataDeclCtxtClassKeys )
 import Maybes		( maybeToBool )
-import Name		( isLocallyDefined, getSrcLoc,
-			  mkTopLevName, origName, mkImplicitName, ExportFlag(..),
-			  RdrName(..), Name{--O only-}
+import Name		( isLocallyDefined, getSrcLoc, ExportFlag(..), Provenance, 
+			  Name{--O only-}
 			)
 import Outputable	( Outputable(..){-instances e.g., (,)-} )
 import PprType		( GenType, GenTyVar, GenClass, TyCon )
@@ -194,24 +198,22 @@ context to the instance decl.  The "offending classes" are
 
 \begin{code}
 tcDeriving  :: Module			-- name of module under scrutiny
-	    -> RnEnv			-- for "renaming" bits of generated code
+	    -> RnNameSupply		-- for "renaming" bits of generated code
 	    -> Bag InstInfo		-- What we already know about instances
-	    -> [RenamedFixityDecl]	-- Fixity info; used by Read and Show
 	    -> TcM s (Bag InstInfo,	-- The generated "instance decls".
 		      RenamedHsBinds,	-- Extra generated bindings
 		      PprStyle -> Pretty)  -- Printable derived instance decls;
 				     	   -- for debugging via -ddump-derivings.
 
-tcDeriving modname rn_env inst_decl_infos_in fixities
+tcDeriving modname rn_name_supply inst_decl_infos_in
   =	-- Fish the "deriving"-related information out of the TcEnv
 	-- and make the necessary "equations".
-    makeDerivEqns	    	`thenTc` \ eqns ->
+    makeDerivEqns			    	`thenTc` \ eqns ->
 
 	-- Take the equation list and solve it, to deliver a list of
 	-- solutions, a.k.a. the contexts for the instance decls
 	-- required for the corresponding equations.
-    solveDerivEqns inst_decl_infos_in eqns
-			    	`thenTc` \ new_inst_infos ->
+    solveDerivEqns inst_decl_infos_in eqns    	`thenTc` \ new_inst_infos ->
 
 	-- Now augment the InstInfos, adding in the rather boring
 	-- actual-code-to-do-the-methods binds.  We may also need to
@@ -219,19 +221,37 @@ tcDeriving modname rn_env inst_decl_infos_in fixities
 	-- "con2tag" and/or "tag2con" functions.  We do these
 	-- separately.
 
-    gen_taggery_Names new_inst_infos	`thenTc` \ nm_alist_etc ->
-    gen_tag_n_con_binds rn_env nm_alist_etc
-				`thenTc` \ (extra_binds, deriver_rn_env) ->
+    gen_taggery_Names new_inst_infos		`thenTc` \ nm_alist_etc ->
+
+
+    let
+	extra_mbind_list = map gen_tag_n_con_monobind nm_alist_etc
+	extra_mbinds     = foldr AndMonoBinds EmptyMonoBinds extra_mbind_list
+	method_binds_s   = map gen_bind new_inst_infos
+	
+	-- Rename to get RenamedBinds.
+	-- The only tricky bit is that the extra_binds must scope over the
+	-- method bindings for the instances.
+	(dfun_names_w_method_binds, rn_extra_binds)
+		= renameSourceCode modname rn_name_supply (
+			rnTopMonoBinds extra_mbinds []		`thenRn` \ rn_extra_binds ->
+			mapRn rn_one method_binds_s		`thenRn` \ dfun_names_w_method_binds ->
+			returnRn (dfun_names_w_method_binds, rn_extra_binds)
+		  )
+	rn_one meth_binds = newDfunName mkGeneratedSrcLoc	`thenRn` \ dfun_name ->
+			    rnMethodBinds meth_binds		`thenRn` \ rn_meth_binds ->
+			    returnRn (dfun_name, rn_meth_binds)
+    in
 
-    mapTc (gen_inst_info modname fixities deriver_rn_env) new_inst_infos
-				`thenTc` \ really_new_inst_infos ->
+    mapTc (gen_inst_info modname)
+	  (new_inst_infos `zip` dfun_names_w_method_binds)	`thenTc` \ really_new_inst_infos ->
     let
-	ddump_deriv = ddump_deriving really_new_inst_infos extra_binds
+	ddump_deriv = ddump_deriving really_new_inst_infos rn_extra_binds
     in
     --pprTrace "derived:\n" (ddump_deriv PprDebug) $
 
     returnTc (listToBag really_new_inst_infos,
-	      extra_binds,
+	      rn_extra_binds,
 	      ddump_deriv)
   where
     ddump_deriving :: [InstInfo] -> RenamedHsBinds -> (PprStyle -> Pretty)
@@ -239,7 +259,7 @@ tcDeriving modname rn_env inst_decl_infos_in fixities
     ddump_deriving inst_infos extra_binds sty
       = ppAboves ((map pp_info inst_infos) ++ [ppr sty extra_binds])
       where
-	pp_info (InstInfo clas tvs ty inst_decl_theta _ _ _ mbinds _ _ _ _)
+	pp_info (InstInfo clas tvs ty inst_decl_theta _ _ mbinds _ _)
 	  = ppAbove (ppr sty (mkSigmaTy tvs inst_decl_theta (mkDictTy clas ty)))
 		    (ppr sty mbinds)
 \end{code}
@@ -271,17 +291,22 @@ makeDerivEqns :: TcM s [DerivEqn]
 
 makeDerivEqns
   = tcGetEnv			    `thenNF_Tc` \ env ->
-    tcLookupClassByKey evalClassKey `thenNF_Tc` \ eval_clas ->
     let
-	tycons = filter isDataTyCon (getEnv_TyCons env)
+	local_data_tycons = filter (\tc -> isLocallyDefined tc && isDataTyCon tc)
+				   (getEnv_TyCons env)
 	-- ToDo: what about newtypes???
-	think_about_deriving = need_deriving eval_clas tycons
     in
-    mapTc chk_out think_about_deriving `thenTc_`
+    if null local_data_tycons then
+	-- Bale out now; evalClass may not be loaded if there aren't any
+	returnTc []
+    else
+    tcLookupClassByKey evalClassKey `thenNF_Tc` \ eval_clas ->
     let
-	(derive_these, _) = removeDups cmp_deriv think_about_deriving
-	eqns = map mk_eqn derive_these
+	think_about_deriving = need_deriving eval_clas local_data_tycons
+	(derive_these, _)    = removeDups cmp_deriv think_about_deriving
+	eqns		     = map mk_eqn derive_these
     in
+    mapTc chk_out think_about_deriving `thenTc_`
     returnTc eqns
   where
     ------------------------------------------------------------------
@@ -467,14 +492,11 @@ add_solns inst_infos_in eqns solns
 
 		 dummy_dfun_id
 
-		 (my_panic "const_meth_ids")
-		 (my_panic "binds")   (my_panic "from_here")
-		 (my_panic "modname") mkGeneratedSrcLoc
+		 (my_panic "binds") (getSrcLoc tycon)
 		 (my_panic "upragmas")
       where
 	dummy_dfun_id
-	  = mkDictFunId bottom bottom bottom dummy_dfun_ty
-			bottom bottom bottom bottom
+	  = mkDictFunId bottom dummy_dfun_ty bottom bottom
 	  where
 	    bottom = panic "dummy_dfun_id"
 
@@ -556,144 +578,66 @@ the renamer.  What a great hack!
 \end{itemize}
 
 \begin{code}
-gen_inst_info :: Module			-- Module name
-	      -> [RenamedFixityDecl]	-- all known fixities;
-					-- may be needed for Text
-	      -> RnEnv			-- lookup stuff for names we may use
-	      -> InstInfo		-- the main stuff to work on
-	      -> TcM s InstInfo		-- the gen'd (filled-in) "instance decl"
-
-gen_inst_info modname fixities deriver_rn_env
-    (InstInfo clas tyvars ty inst_decl_theta _ _ _ _ _ _ locn _)
+-- Generate the method bindings for the required instance
+gen_bind :: InstInfo -> RdrNameMonoBinds
+gen_bind (InstInfo clas _ ty _ _ _ _ _ _)
+  | not from_here 
+  = EmptyMonoBinds
+  | otherwise
+  = assoc "gen_inst_info:bad derived class"
+	  [(eqClassKey,	     gen_Eq_binds)
+	  ,(ordClassKey,     gen_Ord_binds)
+	  ,(enumClassKey,    gen_Enum_binds)
+	  ,(evalClassKey,    gen_Eval_binds)
+	  ,(boundedClassKey, gen_Bounded_binds)
+	  ,(showClassKey,    gen_Show_binds)
+	  ,(readClassKey,    gen_Read_binds)
+	  ,(ixClassKey,	     gen_Ix_binds)
+	  ]
+	  (classKey clas) 
+	  tycon
+  where
+      from_here   = isLocallyDefined tycon
+      (tycon,_,_) = getAppDataTyCon ty	
+	    
+
+gen_inst_info :: Module					-- Module name
+	      -> (InstInfo, (Name, RenamedMonoBinds))		-- the main stuff to work on
+	      -> TcM s InstInfo				-- the gen'd (filled-in) "instance decl"
+
+gen_inst_info modname
+    (InstInfo clas tyvars ty inst_decl_theta _ _ _ locn _, (dfun_name, meth_binds))
   =
 	-- Generate the various instance-related Ids
     mkInstanceRelatedIds
-		True {-from_here-} locn modname
-		NoInstancePragmas
+		dfun_name
 		clas tyvars ty
 		inst_decl_theta
-		[{-no user pragmas-}]
-			`thenTc` \ (dfun_id, dfun_theta, const_meth_ids) ->
+					`thenNF_Tc` \ (dfun_id, dfun_theta) ->
 
-	-- Generate the bindings for the new instance declaration,
-	-- rename it, and check for errors
-    let
-	(tycon,_,_)  = --pprTrace "gen_inst_info:ty" (ppCat[ppr PprDebug clas, ppr PprDebug ty]) $
-		       getAppDataTyCon ty
-
-	proto_mbinds
-	  = assoc "gen_inst_info:bad derived class"
-		[(eqClassKey,	   gen_Eq_binds)
-		,(ordClassKey,	   gen_Ord_binds)
-		,(enumClassKey,	   gen_Enum_binds)
-		,(evalClassKey,	   gen_Eval_binds)
-		,(boundedClassKey, gen_Bounded_binds)
-		,(showClassKey,	   gen_Show_binds fixities)
-		,(readClassKey,	   gen_Read_binds fixities)
-		,(ixClassKey,	   gen_Ix_binds)
-		]
-		clas_key $ tycon
-    in
-{-
-    let
-	((qual, unqual, tc_qual, tc_unqual), stack) = deriver_rn_env
-    in
-    pprTrace "gen_inst:qual:"      (ppCat [ppBesides[ppPStr m,ppChar '.',ppPStr n] | (n,m) <- keysFM qual]) $
-    pprTrace "gen_inst:unqual:"    (ppCat (map ppPStr (keysFM unqual))) $
-    pprTrace "gen_inst:tc_qual:"   (ppCat [ppBesides[ppPStr m,ppChar '.',ppPStr n] | (n,m) <- keysFM tc_qual]) $
-    pprTrace "gen_inst:tc_unqual:" (ppCat (map ppPStr (keysFM tc_unqual))) $
--}
-    -- pprTrace "derived binds:" (ppr PprDebug proto_mbinds) $
-
-    rnMtoTcM deriver_rn_env (
-	setExtraRn emptyUFM{-no fixities-} $
-	rnMethodBinds clas_Name proto_mbinds
-    )			`thenNF_Tc` \ (mbinds, errs) ->
-
-    if not (isEmptyBag errs) then
-	panic "gen_inst_info:renamer errs!\n"
---	pprPanic "gen_inst_info:renamer errs!\n"
---		 (ppAbove (pprBagOfErrors PprDebug errs) (ppr PprDebug proto_mbinds))
-    else
-	-- All done
-    let
-	from_here = isLocallyDefined tycon	-- If so, then from here
-    in
     returnTc (InstInfo clas tyvars ty inst_decl_theta
-		       dfun_theta dfun_id const_meth_ids
-		       (if from_here then mbinds else EmptyMonoBinds)
-		       from_here modname locn [])
+		       dfun_theta dfun_id
+		       meth_binds
+		       locn [])
   where
-    clas_key  = classKey clas
-    clas_Name = RnImplicitClass (mkImplicitName clas_key (origName "gen_inst_info" clas))
+    from_here = isLocallyDefined tycon
+    (tycon,_,_) = getAppDataTyCon ty
 \end{code}
 
+
 %************************************************************************
 %*									*
-\subsection[TcGenDeriv-con2tag-tag2con]{Generating extra binds (@con2tag@ and @tag2con@)}
+\subsection[TcDeriv-taggery-Names]{What con2tag/tag2con functions are available?}
 %*									*
 %************************************************************************
 
+
 data Foo ... = ...
 
 con2tag_Foo :: Foo ... -> Int#
 tag2con_Foo :: Int -> Foo ...	-- easier if Int, not Int#
 maxtag_Foo  :: Int		-- ditto (NB: not unboxed)
 
-\begin{code}
-gen_tag_n_con_binds :: RnEnv
-		    -> [(RdrName, TyCon, TagThingWanted)]
-		    -> TcM s (RenamedHsBinds,
-			      RnEnv) -- input one with any new names added
-
-gen_tag_n_con_binds rn_env nm_alist_etc
-  = 
-    let
-	-- We have the renamer's final "name funs" in our hands
-	-- (they were passed in).  So we can handle ProtoNames
-	-- that refer to anything "out there".  But our generated
-	-- code may also mention "con2tag" (etc.).  So we need
-	-- to augment to "name funs" to include those.
-
-	names_to_add = [ pn | (pn,_,_) <- nm_alist_etc ]
-    in
-    tcGetUniques (length names_to_add)	`thenNF_Tc` \ uniqs ->
-    let
-	pairs_to_add = [ case pn of { Qual pnm pnn ->
-			 (pn, mkRnName (mkTopLevName u (OrigName pnm pnn) mkGeneratedSrcLoc ExportAll [])) }
-		       | (pn,u) <- zipEqual "gen_tag..." names_to_add uniqs ]
-
-	deriver_rn_env
-	  = if null names_to_add
-	    then rn_env else added_rn_env
-
-	(added_rn_env, errs_bag)
-	  = extendGlobalRnEnv rn_env pairs_to_add [{-no tycons-}]
-
-	----------------
-	proto_mbind_list = map gen_tag_n_con_monobind nm_alist_etc
-	proto_mbinds     = foldr AndMonoBinds EmptyMonoBinds proto_mbind_list
-    in
-    ASSERT(isEmptyBag errs_bag)
-
-    rnMtoTcM deriver_rn_env (
-	setExtraRn emptyUFM{-no fixities-} $
-	rnTopBinds (SingleBind (RecBind proto_mbinds))
-    )			`thenNF_Tc` \ (binds, errs) ->
-
-    if not (isEmptyBag errs) then
-	panic "gen_tag_n_con_binds:renamer errs!\n"
---	pprPanic "gen_tag_n_con_binds:renamer errs!\n"
---		 (ppAbove (pprBagOfErrors PprDebug errs) (ppr PprDebug binds))
-    else
-	returnTc (binds, deriver_rn_env)
-\end{code}
-
-%************************************************************************
-%*									*
-\subsection[TcDeriv-taggery-Names]{What con2tag/tag2con functions are available?}
-%*									*
-%************************************************************************
 
 We have a @con2tag@ function for a tycon if:
 \begin{itemize}
@@ -724,7 +668,7 @@ gen_taggery_Names inst_infos
     foldlTc do_con2tag []           tycons_of_interest `thenTc` \ names_so_far ->
     foldlTc do_tag2con names_so_far tycons_of_interest
   where
-    all_CTs = [ mk_CT c ty | (InstInfo c _ ty _ _ _ _ _ _ _ _ _) <- inst_infos ]
+    all_CTs = [ mk_CT c ty | (InstInfo c _ ty _ _ _ _ _ _) <- inst_infos ]
 		    
     mk_CT c ty = (c, fst (getAppTyCon ty))
 
@@ -739,7 +683,7 @@ gen_taggery_Names inst_infos
 	|| (we_are_deriving enumClassKey tycon)
 	|| (we_are_deriving ixClassKey   tycon)
 	then
-	  returnTc ((con2tag_PN tycon, tycon, GenCon2Tag)
+	  returnTc ((con2tag_RDR tycon, tycon, GenCon2Tag)
 		   : acc_Names)
 	else
 	  returnTc acc_Names
@@ -748,8 +692,8 @@ gen_taggery_Names inst_infos
       = if (we_are_deriving enumClassKey tycon)
 	|| (we_are_deriving ixClassKey   tycon)
 	then
-	  returnTc ( (tag2con_PN tycon, tycon, GenTag2Con)
-		   : (maxtag_PN  tycon, tycon, GenMaxTag)
+	  returnTc ( (tag2con_RDR tycon, tycon, GenTag2Con)
+		   : (maxtag_RDR  tycon, tycon, GenMaxTag)
 		   : acc_Names)
 	else
 	  returnTc acc_Names
diff --git a/ghc/compiler/typecheck/TcEnv.lhs b/ghc/compiler/typecheck/TcEnv.lhs
index bda4f4a81b..a13c8aa3c6 100644
--- a/ghc/compiler/typecheck/TcEnv.lhs
+++ b/ghc/compiler/typecheck/TcEnv.lhs
@@ -6,7 +6,7 @@ module TcEnv(
 
 	initEnv, getEnv_LocalIds, getEnv_TyCons, getEnv_Classes,
 	
-	tcTyVarScope, tcTyVarScopeGivenKinds, tcLookupTyVar, 
+	tcExtendTyVarEnv, tcLookupTyVar, 
 
 	tcExtendTyConEnv, tcLookupTyCon, tcLookupTyConByKey, 
 	tcExtendClassEnv, tcLookupClass, tcLookupClassByKey,
@@ -14,7 +14,7 @@ module TcEnv(
 
 	tcExtendGlobalValEnv, tcExtendLocalValEnv,
 	tcLookupLocalValue, tcLookupLocalValueOK, tcLookupLocalValueByKey, 
-	tcLookupGlobalValue, tcLookupGlobalValueByKey,
+	tcLookupGlobalValue, tcLookupGlobalValueByKey, tcLookupGlobalValueMaybe,
 
 	newMonoIds, newLocalIds, newLocalId,
 	tcGetGlobalTyVars, tcExtendGlobalTyVars
@@ -24,23 +24,26 @@ module TcEnv(
 IMP_Ubiq()
 IMPORT_DELOOPER(TcMLoop)  -- for paranoia checking
 
-import Id	( SYN_IE(Id), GenId, idType, mkUserLocal )
+import HsTypes	( HsTyVar(..) )
+import Id	( SYN_IE(Id), GenId, idType, mkUserLocal, mkUserId )
+import PragmaInfo ( PragmaInfo(..) )
 import TcHsSyn	( SYN_IE(TcIdBndr), TcIdOcc(..) )
-import TcKind	( TcKind, newKindVars, tcDefaultKind, kindToTcKind )
+import TcKind	( TcKind, newKindVars, newKindVar, tcDefaultKind, kindToTcKind )
 import TcType	( SYN_IE(TcType), TcMaybe, SYN_IE(TcTyVar), SYN_IE(TcTyVarSet),
 		  newTyVarTys, tcInstTyVars, zonkTcTyVars
 		)
-import TyVar	( mkTyVar, tyVarKind, unionTyVarSets, emptyTyVarSet )
+import TyVar	( unionTyVarSets, emptyTyVarSet )
 import Type	( tyVarsOfTypes, splitForAllTy )
 import TyCon	( TyCon, tyConKind, synTyConArity )
 import Class	( SYN_IE(Class), GenClass, classSig )
 
-import TcMonad		hiding ( rnMtoTcM )
+import TcMonad
 
-import Name		( getOccName, getSrcLoc, Name{-instance NamedThing-} )
+import Name		( Name, OccName(..), getSrcLoc, occNameString,
+			  maybeWiredInTyConName, maybeWiredInIdName, pprSym
+			)
 import PprStyle
 import Pretty
-import RnHsSyn		( RnName(..) )
 import Unique		( pprUnique10{-, pprUnique ToDo:rm-} )
 import UniqFM	     
 import Util		( zipEqual, zipWithEqual, zipWith3Equal, zipLazy,
@@ -74,43 +77,18 @@ getEnv_TyCons   (TcEnv _ ts _ _ _ _) = [tycon | (_, _, tycon) <- eltsUFM ts]
 getEnv_Classes  (TcEnv _ _ cs _ _ _) = [clas  | (_, clas)     <- eltsUFM cs]
 \end{code}
 
-Making new TcTyVars, with knot tying!
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Type variable env
+~~~~~~~~~~~~~~~~~
 \begin{code}
-tcTyVarScopeGivenKinds 
-	:: [Name]		-- Names of some type variables
-	-> [TcKind s]
-	-> ([TyVar] -> TcM s a)	-- Thing to type check in their scope
-	-> TcM s a		-- Result
-
-tcTyVarScopeGivenKinds names kinds thing_inside
-  = fixTc (\ ~(rec_tyvars, _) ->
-		-- Ok to look at names, kinds, but not tyvars!
-
-	tcGetEnv				`thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
-	let
-	    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 ->
- 
-		-- Get the tyvar's Kinds from their TcKinds
-	mapNF_Tc tcDefaultKind kinds		`thenNF_Tc` \ kinds' ->
-
-		-- Construct the real TyVars
-	let
-	  tyvars = zipWithEqual "tcTyVarScopeGivenKinds" mkTyVar names kinds'
-	in
-	returnTc (tyvars, result)
-    )					`thenTc` \ (_,result) ->
-    returnTc result
-
-tcTyVarScope names thing_inside
-  = newKindVars (length names) 	`thenNF_Tc` \ kinds ->
-    tcTyVarScopeGivenKinds names kinds thing_inside
+tcExtendTyVarEnv :: [Name] -> [(TcKind s, TyVar)] -> TcM s r -> TcM s r
+tcExtendTyVarEnv names kinds_w_types scope
+  = tcGetEnv					`thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
+    let
+	tve' = addListToUFM tve (zipEqual "tcTyVarScope" names kinds_w_types)
+    in
+    tcSetEnv (TcEnv tve' tce ce gve lve gtvs) scope
 \end{code}
 
-
 The Kind, TyVar, Class and TyCon envs
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 
@@ -118,7 +96,7 @@ Extending the environments.  Notice the uses of @zipLazy@, which makes sure
 that the knot-tied TyVars, TyCons and Classes aren't looked at too early.
 
 \begin{code}
-tcExtendTyConEnv :: [(RnName,Maybe Arity)] -> [TyCon] -> TcM s r -> TcM s r
+tcExtendTyConEnv :: [(Name,Maybe Arity)] -> [TyCon] -> TcM s r -> TcM s r
 
 tcExtendTyConEnv names_w_arities tycons scope
   = newKindVars (length names_w_arities)	`thenNF_Tc` \ kinds ->
@@ -134,7 +112,7 @@ tcExtendTyConEnv names_w_arities tycons scope
     returnTc result 
 
 
-tcExtendClassEnv :: [RnName] -> [Class] -> TcM s r -> TcM s r
+tcExtendClassEnv :: [Name] -> [Class] -> TcM s r -> TcM s r
 tcExtendClassEnv names classes scope
   = newKindVars (length names)	`thenNF_Tc` \ kinds ->
     tcGetEnv			`thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
@@ -155,12 +133,16 @@ tcLookupTyVar name
     returnNF_Tc (lookupWithDefaultUFM tve (pprPanic "tcLookupTyVar:" (ppr PprShowAll name)) name)
 
 
-tcLookupTyCon (WiredInTyCon tc)		-- wired in tycons
-  = returnNF_Tc (kindToTcKind (tyConKind tc), synTyConArity tc, tc)
-
 tcLookupTyCon name
-  = tcGetEnv		`thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
-    returnNF_Tc (lookupWithDefaultUFM tce (pprPanic "tcLookupTyCon:" (ppr PprShowAll name)) name)
+  = case maybeWiredInTyConName name of
+	Just tc -> returnTc (kindToTcKind (tyConKind tc), synTyConArity tc, tc)
+	Nothing -> tcGetEnv		`thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
+		   case lookupUFM tce name of
+			Just stuff -> returnTc stuff
+			Nothing    -> 	-- Could be that he's using a class name as a type constructor
+				      case lookupUFM ce name of
+					Just _  -> failTc (classAsTyConErr name)
+					Nothing -> pprPanic "tcLookupTyCon:" (ppr PprDebug name)
 
 tcLookupTyConByKey uniq
   = tcGetEnv		`thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
@@ -175,7 +157,12 @@ tcLookupClass name
   = tcGetEnv		`thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
 --  pprTrace "tcLookupClass:" (ppCat [ppStr "Uniq:", pprUnique10 (uniqueOf name), ppStr "; avail:", ppCat (map (pprUnique10 . fst) (ufmToList ce))]) $
 --  pprTrace "tcLookupClass:" (ppCat [ppStr "Uniq:", pprUnique (uniqueOf name), ppStr "; avail:", ppCat (map (pprUnique . fst) (ufmToList ce))]) $
-    returnNF_Tc (lookupWithDefaultUFM ce (pprPanic "tcLookupClass:" (ppr PprShowAll name)) name)
+    case lookupUFM ce name of
+	Just stuff -> returnTc stuff
+	Nothing	   -> 	-- Could be that he's using a type constructor as a class
+			case lookupUFM tce name of
+			  Just _ ->  failTc (tyConAsClassErr name)
+			  Nothing -> pprPanic "tcLookupClass:" (ppr PprShowAll name)
 
 tcLookupClassByKey uniq
   = tcGetEnv		`thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
@@ -242,7 +229,7 @@ tcExtendGlobalTyVars extra_global_tvs scope
 \end{code}
 
 \begin{code}
-tcLookupLocalValue :: RnName -> NF_TcM s (Maybe (TcIdBndr s))
+tcLookupLocalValue :: Name -> NF_TcM s (Maybe (TcIdBndr s))
 tcLookupLocalValue name
   = tcGetEnv 		`thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
     returnNF_Tc (lookupUFM lve name)
@@ -252,26 +239,30 @@ tcLookupLocalValueByKey uniq
   = tcGetEnv 		`thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
     returnNF_Tc (lookupUFM_Directly lve uniq)
 
-tcLookupLocalValueOK :: String -> RnName -> NF_TcM s (TcIdBndr s)
+tcLookupLocalValueOK :: String -> Name -> NF_TcM s (TcIdBndr s)
 tcLookupLocalValueOK err name
   = tcGetEnv 		`thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
     returnNF_Tc (lookupWithDefaultUFM lve (panic err) name)
 
 
-tcLookupGlobalValue :: RnName -> NF_TcM s Id
-
-tcLookupGlobalValue (WiredInId id)	-- wired in ids
-  = returnNF_Tc id
+tcLookupGlobalValue :: Name -> NF_TcM s Id
 
 tcLookupGlobalValue name
-  = tcGetEnv 		`thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
-    returnNF_Tc (lookupWithDefaultUFM gve def name)
+  = case maybeWiredInIdName name of
+	Just id -> returnNF_Tc id
+	Nothing -> tcGetEnv 		`thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
+		   returnNF_Tc (lookupWithDefaultUFM gve def name)
   where
-#ifdef DEBUG
     def = pprPanic "tcLookupGlobalValue:" (ppr PprDebug name)
-#else
-    def = panic "tcLookupGlobalValue"
-#endif
+
+tcLookupGlobalValueMaybe :: Name -> NF_TcM s (Maybe Id)
+
+tcLookupGlobalValueMaybe name
+  = case maybeWiredInIdName name of
+	Just id -> returnNF_Tc (Just id)
+	Nothing -> tcGetEnv 		`thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
+		   returnNF_Tc (lookupUFM gve name)
+
 
 tcLookupGlobalValueByKey :: Unique -> NF_TcM s Id
 tcLookupGlobalValueByKey uniq
@@ -291,39 +282,40 @@ Constructing new Ids
 ~~~~~~~~~~~~~~~~~~~~
 
 \begin{code}
-newMonoIds :: [RnName] -> Kind -> ([TcIdBndr s] -> TcM s a) -> TcM s a
+-- Uses the Name as the Name of the Id
+newMonoIds :: [Name] -> Kind -> ([TcIdBndr s] -> TcM s a) -> TcM s a
 
 newMonoIds names kind m
   = newTyVarTys no_of_names kind	`thenNF_Tc` \ tys ->
-    tcGetUniques no_of_names		`thenNF_Tc` \ uniqs ->
     let
-	new_ids = zipWith3Equal "newMonoIds" mk_id names uniqs tys
-
-	mk_id name uniq ty
-	  = let
-		name_str = case (getOccName name) of { Unqual n -> n; Qual m n -> n }
-	    in
-	    mkUserLocal name_str uniq ty (getSrcLoc name)
+	new_ids       = zipWithEqual "newMonoIds" mk_id names tys
+	mk_id name ty = mkUserId name ty NoPragmaInfo
     in
     tcExtendLocalValEnv names new_ids (m new_ids)
   where
     no_of_names = length names
 
-newLocalId :: FAST_STRING -> TcType s -> NF_TcM s (TcIdOcc s)
+newLocalId :: OccName -> TcType s -> NF_TcM s (TcIdBndr s)
 newLocalId name ty
   = tcGetSrcLoc		`thenNF_Tc` \ loc ->
     tcGetUnique		`thenNF_Tc` \ uniq ->
-    returnNF_Tc (TcId (mkUserLocal name uniq ty loc))
+    returnNF_Tc (mkUserLocal name uniq ty loc)
 
-newLocalIds :: [FAST_STRING] -> [TcType s] -> NF_TcM s [TcIdOcc s]
+newLocalIds :: [OccName] -> [TcType s] -> NF_TcM s [TcIdBndr s]
 newLocalIds names tys
   = tcGetSrcLoc			`thenNF_Tc` \ loc ->
     tcGetUniques (length names) `thenNF_Tc` \ uniqs ->
     let
 	new_ids            = zipWith3Equal "newLocalIds" mk_id names uniqs tys
-	mk_id name uniq ty = TcId (mkUserLocal name uniq ty loc)
+	mk_id name uniq ty = mkUserLocal name uniq ty loc
     in
     returnNF_Tc new_ids
 \end{code}
 
+\begin{code}
+classAsTyConErr name sty
+  = ppBesides [ppStr "Class used as a type constructor: ", pprSym sty name]
 
+tyConAsClassErr name sty
+  = ppBesides [ppStr "Type constructor used as a class: ", pprSym sty name]
+\end{code}
diff --git a/ghc/compiler/typecheck/TcExpr.lhs b/ghc/compiler/typecheck/TcExpr.lhs
index 9c59b43d74..3215394f4d 100644
--- a/ghc/compiler/typecheck/TcExpr.lhs
+++ b/ghc/compiler/typecheck/TcExpr.lhs
@@ -13,18 +13,17 @@ IMP_Ubiq()
 import HsSyn		( HsExpr(..), Qualifier(..), Stmt(..),
 			  HsBinds(..), Bind(..), MonoBinds(..), 
 			  ArithSeqInfo(..), HsLit(..), Sig, GRHSsAndBinds,
-			  Match, Fake, InPat, OutPat, PolyType,
+			  Match, Fake, InPat, OutPat, HsType,
 			  failureFreePat, collectPatBinders )
 import RnHsSyn		( SYN_IE(RenamedHsExpr), SYN_IE(RenamedQual),
-			  SYN_IE(RenamedStmt), SYN_IE(RenamedRecordBinds),
-			  RnName{-instance Outputable-}
+			  SYN_IE(RenamedStmt), SYN_IE(RenamedRecordBinds)
 			)
 import TcHsSyn		( SYN_IE(TcExpr), SYN_IE(TcQual), SYN_IE(TcStmt),
 			  TcIdOcc(..), SYN_IE(TcRecordBinds),
 			  mkHsTyApp
 			)
 
-import TcMonad		hiding ( rnMtoTcM )
+import TcMonad
 import Inst		( Inst, InstOrigin(..), OverloadedLit(..),
 			  SYN_IE(LIE), emptyLIE, plusLIE, plusLIEs, newOverloadedLit,
 			  newMethod, newMethodWithGivenTy, newDicts )
@@ -35,7 +34,7 @@ import TcEnv		( tcLookupLocalValue, tcLookupGlobalValue, tcLookupClassByKey,
 			)
 import SpecEnv		( SpecEnv )
 import TcMatches	( tcMatchesCase, tcMatch )
-import TcMonoType	( tcPolyType )
+import TcMonoType	( tcHsType )
 import TcPat		( tcPat )
 import TcSimplify	( tcSimplifyAndCheck, tcSimplifyRank2 )
 import TcType		( SYN_IE(TcType), TcMaybe(..),
@@ -463,7 +462,7 @@ tcExpr in_expr@(ArithSeqIn seq@(FromThenTo expr1 expr2 expr3))
 \begin{code}
 tcExpr in_expr@(ExprWithTySig expr poly_ty)
  = tcExpr expr			`thenTc` \ (texpr, lie, tau_ty) ->
-   tcPolyType  poly_ty		`thenTc` \ sigma_sig ->
+   tcHsType  poly_ty		`thenTc` \ sigma_sig ->
 
 	-- Check the tau-type part
    tcSetErrCtxt (exprSigCtxt in_expr)	$
@@ -627,7 +626,7 @@ tcArg expected_arg_ty arg
 %************************************************************************
 
 \begin{code}
-tcId :: RnName -> NF_TcM s (TcExpr s, LIE s, TcType s)
+tcId :: Name -> NF_TcM s (TcExpr s, LIE s, TcType s)
 
 tcId name
   = 	-- Look up the Id and instantiate its type
diff --git a/ghc/compiler/typecheck/TcGRHSs.lhs b/ghc/compiler/typecheck/TcGRHSs.lhs
index 309149e6af..7072a552ff 100644
--- a/ghc/compiler/typecheck/TcGRHSs.lhs
+++ b/ghc/compiler/typecheck/TcGRHSs.lhs
@@ -16,7 +16,7 @@ import HsSyn		( GRHSsAndBinds(..), GRHS(..),
 import RnHsSyn		( SYN_IE(RenamedGRHSsAndBinds), SYN_IE(RenamedGRHS) )
 import TcHsSyn		( SYN_IE(TcGRHSsAndBinds), SYN_IE(TcGRHS), TcIdOcc(..) )
 
-import TcMonad		hiding ( rnMtoTcM )
+import TcMonad
 import Inst		( Inst, SYN_IE(LIE), plusLIE )
 import TcBinds		( tcBindsAndThen )
 import TcExpr		( tcExpr )
diff --git a/ghc/compiler/typecheck/TcGenDeriv.lhs b/ghc/compiler/typecheck/TcGenDeriv.lhs
index f449cca053..3bc2b6953e 100644
--- a/ghc/compiler/typecheck/TcGenDeriv.lhs
+++ b/ghc/compiler/typecheck/TcGenDeriv.lhs
@@ -12,30 +12,6 @@ This is where we do all the grimy bindings' generation.
 #include "HsVersions.h"
 
 module TcGenDeriv (
-	a_Expr,
-	a_PN,
-	a_Pat,
-	ah_PN,
-	b_Expr,
-	b_PN,
-	b_Pat,
-	bh_PN,
-	c_Expr,
-	c_PN,
-	c_Pat,
-	ch_PN,
-	cmp_eq_PN,
-	d_Expr,
-	d_PN,
-	d_Pat,
-	dh_PN,
-	eqH_Int_PN,
-	eqTag_Expr,
-	eq_PN,
-	error_PN,
-	false_Expr,
-	false_PN,
-	geH_PN,
 	gen_Bounded_binds,
 	gen_Enum_binds,
 	gen_Eval_binds,
@@ -45,19 +21,8 @@ module TcGenDeriv (
 	gen_Read_binds,
 	gen_Show_binds,
 	gen_tag_n_con_monobind,
-	gtTag_Expr,
-	gt_PN,
-	leH_PN,
-	ltH_Int_PN,
-	ltTag_Expr,
-	lt_PN,
-	minusH_PN,
-	mkInt_PN,
-	rangeSize_PN,
-	true_Expr,
-	true_PN,
-
-	con2tag_PN, tag2con_PN, maxtag_PN,
+
+	con2tag_RDR, tag2con_RDR, maxtag_RDR,
 
 	TagThingWanted(..)
     ) where
@@ -67,29 +32,26 @@ IMPORT_1_3(List(partition))
 
 import HsSyn		( HsBinds(..), Bind(..), MonoBinds(..), Match(..), GRHSsAndBinds(..),
 			  GRHS(..), HsExpr(..), HsLit(..), InPat(..), Qualifier(..), Stmt,
-			  ArithSeqInfo, Sig, PolyType, FixityDecl, Fake )
-import RdrHsSyn		( SYN_IE(RdrNameMonoBinds), SYN_IE(RdrNameHsExpr), SYN_IE(RdrNamePat) )
-import RnHsSyn		( RenamedFixityDecl(..) )
---import RnUtils
+			  ArithSeqInfo, Sig, HsType, FixityDecl, Fake )
+import RdrHsSyn		( RdrName(..), varQual, varUnqual,
+			  SYN_IE(RdrNameMonoBinds), SYN_IE(RdrNameHsExpr), SYN_IE(RdrNamePat)
+			)
+-- import RnHsSyn		( RenamedFixityDecl(..) )
 
 import Id		( GenId, dataConNumFields, isNullaryDataCon, dataConTag,
 			  dataConRawArgTys, fIRST_TAG,
 			  isDataCon, SYN_IE(DataCon), SYN_IE(ConTag) )
-import IdUtils		( primOpId )
 import Maybes		( maybeToBool )
-import Name		( origName, preludeQual, nameOf, RdrName(..), OrigName(..) )
-import PrelMods		( pRELUDE, gHC__, iX )
-import PrelVals		( eRROR_ID )
+import Name		( getOccString, getSrcLoc, occNameString, modAndOcc, OccName, Name )
 
 import PrimOp		( PrimOp(..) )
+import PrelInfo		-- Lots of RdrNames
 import SrcLoc		( mkGeneratedSrcLoc )
 import TyCon		( TyCon, tyConDataCons, isEnumerationTyCon, maybeTyConSingleCon )
 import Type		( eqTy, isPrimType )
 import TysPrim		( charPrimTy, intPrimTy, wordPrimTy, addrPrimTy,
 			  floatPrimTy, doublePrimTy
 			)
-import TysWiredIn	( falseDataCon, trueDataCon, intDataCon )
---import Unique
 import Util		( mapAccumL, zipEqual, zipWith3Equal, nOfThem, panic, assertPanic )
 \end{code}
 
@@ -177,6 +139,7 @@ gen_Eq_binds :: TyCon -> RdrNameMonoBinds
 
 gen_Eq_binds tycon
   = let
+	tycon_loc = getSrcLoc tycon
 	(nullary_cons, nonnullary_cons)
 	  = partition isNullaryDataCon (tyConDataCons tycon)
 
@@ -188,22 +151,24 @@ gen_Eq_binds tycon
 		     [([a_Pat, b_Pat], false_Expr)]
 	    else -- calc. and compare the tags
 		 [([a_Pat, b_Pat],
-		    untag_Expr tycon [(a_PN,ah_PN), (b_PN,bh_PN)]
-		      (cmp_tags_Expr eqH_Int_PN ah_PN bh_PN true_Expr false_Expr))]
+		    untag_Expr tycon [(a_RDR,ah_RDR), (b_RDR,bh_RDR)]
+		      (cmp_tags_Expr eqH_Int_RDR ah_RDR bh_RDR true_Expr false_Expr))]
     in
-    mk_FunMonoBind eq_PN ((map pats_etc nonnullary_cons) ++ rest)
-    `AndMonoBinds` boring_ne_method
+    mk_FunMonoBind tycon_loc eq_RDR ((map pats_etc nonnullary_cons) ++ rest)
+	    `AndMonoBinds`
+    mk_easy_FunMonoBind tycon_loc ne_RDR [a_Pat, b_Pat] [] (
+	HsApp (HsVar not_RDR) (HsPar (mk_easy_App eq_RDR [a_RDR, b_RDR])))
   where
     ------------------------------------------------------------------
     pats_etc data_con
       = let
-	    con1_pat = ConPatIn data_con_PN (map VarPatIn as_needed)
-	    con2_pat = ConPatIn data_con_PN (map VarPatIn bs_needed)
+	    con1_pat = ConPatIn data_con_RDR (map VarPatIn as_needed)
+	    con2_pat = ConPatIn data_con_RDR (map VarPatIn bs_needed)
 
-	    data_con_PN = qual_orig_name data_con
+	    data_con_RDR = qual_orig_name data_con
 	    con_arity   = length tys_needed
-	    as_needed   = take con_arity as_PNs
-	    bs_needed   = take con_arity bs_PNs
+	    as_needed   = take con_arity as_RDRs
+	    bs_needed   = take con_arity bs_RDRs
 	    tys_needed  = dataConRawArgTys data_con
 	in
 	([con1_pat, con2_pat], nested_eq_expr tys_needed as_needed bs_needed)
@@ -213,10 +178,6 @@ gen_Eq_binds tycon
 	  = foldr1 and_Expr (zipWith3Equal "nested_eq" nested_eq tys as bs)
 	  where
 	    nested_eq ty a b = HsPar (eq_Expr ty (HsVar a) (HsVar b))
-
-boring_ne_method
-  = mk_easy_FunMonoBind ne_PN [a_Pat, b_Pat] [] $
-	HsApp (HsVar not_PN) (HsPar (mk_easy_App eq_PN [a_PN, b_PN]))
 \end{code}
 
 %************************************************************************
@@ -317,15 +278,16 @@ gen_Ord_binds :: TyCon -> RdrNameMonoBinds
 gen_Ord_binds tycon
   = defaulted `AndMonoBinds` compare
   where
+    tycon_loc = getSrcLoc tycon
     --------------------------------------------------------------------
-    compare = mk_easy_FunMonoBind compare_PN
+    compare = mk_easy_FunMonoBind tycon_loc compare_RDR
 		[a_Pat, b_Pat]
 		[cmp_eq]
 	    (if maybeToBool (maybeTyConSingleCon tycon) then
 		cmp_eq_Expr ltTag_Expr eqTag_Expr gtTag_Expr a_Expr b_Expr
 	     else
-		untag_Expr tycon [(a_PN, ah_PN), (b_PN, bh_PN)]
-		  (cmp_tags_Expr eqH_Int_PN ah_PN bh_PN
+		untag_Expr tycon [(a_RDR, ah_RDR), (b_RDR, bh_RDR)]
+		  (cmp_tags_Expr eqH_Int_RDR ah_RDR bh_RDR
 			-- True case; they are equal
 			-- If an enumeration type we are done; else
 			-- recursively compare their components
@@ -336,25 +298,25 @@ gen_Ord_binds tycon
 		    )
 			-- False case; they aren't equal
 			-- So we need to do a less-than comparison on the tags
-		    (cmp_tags_Expr ltH_Int_PN ah_PN bh_PN ltTag_Expr gtTag_Expr)))
+		    (cmp_tags_Expr ltH_Int_RDR ah_RDR bh_RDR ltTag_Expr gtTag_Expr)))
 
     (nullary_cons, nonnullary_cons)
       = partition isNullaryDataCon (tyConDataCons tycon)
 
     cmp_eq
-      = mk_FunMonoBind cmp_eq_PN (map pats_etc nonnullary_cons ++ deflt_pats_etc)
+      = mk_FunMonoBind tycon_loc cmp_eq_RDR (map pats_etc nonnullary_cons ++ deflt_pats_etc)
       where
 	pats_etc data_con
 	  = ([con1_pat, con2_pat],
 	     nested_compare_expr tys_needed as_needed bs_needed)
 	  where
-	    con1_pat = ConPatIn data_con_PN (map VarPatIn as_needed)
-	    con2_pat = ConPatIn data_con_PN (map VarPatIn bs_needed)
+	    con1_pat = ConPatIn data_con_RDR (map VarPatIn as_needed)
+	    con2_pat = ConPatIn data_con_RDR (map VarPatIn bs_needed)
 
-	    data_con_PN = qual_orig_name data_con
+	    data_con_RDR = qual_orig_name data_con
 	    con_arity   = length tys_needed
-	    as_needed   = take con_arity as_PNs
-	    bs_needed   = take con_arity bs_PNs
+	    as_needed   = take con_arity as_RDRs
+	    bs_needed   = take con_arity bs_RDRs
 	    tys_needed  = dataConRawArgTys data_con
 
 	    nested_compare_expr [ty] [a] [b]
@@ -372,18 +334,18 @@ gen_Ord_binds tycon
 
 defaulted = foldr1 AndMonoBinds [lt, le, ge, gt, max_, min_]
 
-lt = mk_easy_FunMonoBind lt_PN [a_Pat, b_Pat] [] (
+lt = mk_easy_FunMonoBind mkGeneratedSrcLoc lt_RDR [a_Pat, b_Pat] [] (
 	    compare_Case true_Expr  false_Expr false_Expr a_Expr b_Expr)
-le = mk_easy_FunMonoBind le_PN [a_Pat, b_Pat] [] (
+le = mk_easy_FunMonoBind mkGeneratedSrcLoc le_RDR [a_Pat, b_Pat] [] (
 	    compare_Case true_Expr  true_Expr  false_Expr a_Expr b_Expr)
-ge = mk_easy_FunMonoBind ge_PN [a_Pat, b_Pat] [] (
+ge = mk_easy_FunMonoBind mkGeneratedSrcLoc ge_RDR [a_Pat, b_Pat] [] (
 	    compare_Case false_Expr true_Expr  true_Expr  a_Expr b_Expr)
-gt = mk_easy_FunMonoBind gt_PN [a_Pat, b_Pat] [] (
+gt = mk_easy_FunMonoBind mkGeneratedSrcLoc gt_RDR [a_Pat, b_Pat] [] (
 	    compare_Case false_Expr false_Expr true_Expr  a_Expr b_Expr)
 
-max_ = mk_easy_FunMonoBind max_PN [a_Pat, b_Pat] [] (
+max_ = mk_easy_FunMonoBind mkGeneratedSrcLoc max_RDR [a_Pat, b_Pat] [] (
 	    compare_Case b_Expr a_Expr a_Expr a_Expr b_Expr)
-min_ = mk_easy_FunMonoBind min_PN [a_Pat, b_Pat] [] (
+min_ = mk_easy_FunMonoBind mkGeneratedSrcLoc min_RDR [a_Pat, b_Pat] [] (
 	    compare_Case a_Expr b_Expr b_Expr a_Expr b_Expr)
 \end{code}
 
@@ -427,24 +389,32 @@ For @enumFromTo@ and @enumFromThenTo@, we use the default methods.
 gen_Enum_binds :: TyCon -> RdrNameMonoBinds
 
 gen_Enum_binds tycon
-  = enum_from `AndMonoBinds` enum_from_then
+  = enum_from		`AndMonoBinds`
+    enum_from_then	`AndMonoBinds`
+    from_enum
   where
+    tycon_loc = getSrcLoc tycon
     enum_from
-      = mk_easy_FunMonoBind enumFrom_PN [a_Pat] [] $
-	  untag_Expr tycon [(a_PN, ah_PN)] $
-	  HsApp (mk_easy_App map_PN [tag2con_PN tycon]) $
+      = mk_easy_FunMonoBind tycon_loc enumFrom_RDR [a_Pat] [] $
+	  untag_Expr tycon [(a_RDR, ah_RDR)] $
+	  HsApp (mk_easy_App map_RDR [tag2con_RDR tycon]) $
 	    HsPar (enum_from_to_Expr
-		    (mk_easy_App mkInt_PN [ah_PN])
-		    (HsVar (maxtag_PN tycon)))
+		    (mk_easy_App mkInt_RDR [ah_RDR])
+		    (HsVar (maxtag_RDR tycon)))
 
     enum_from_then
-      = mk_easy_FunMonoBind enumFromThen_PN [a_Pat, b_Pat] [] $
-	  untag_Expr tycon [(a_PN, ah_PN), (b_PN, bh_PN)] $
-	  HsApp (mk_easy_App map_PN [tag2con_PN tycon]) $
+      = mk_easy_FunMonoBind tycon_loc enumFromThen_RDR [a_Pat, b_Pat] [] $
+	  untag_Expr tycon [(a_RDR, ah_RDR), (b_RDR, bh_RDR)] $
+	  HsApp (mk_easy_App map_RDR [tag2con_RDR tycon]) $
 	    HsPar (enum_from_then_to_Expr
-		    (mk_easy_App mkInt_PN [ah_PN])
-		    (mk_easy_App mkInt_PN [bh_PN])
-		    (HsVar (maxtag_PN tycon)))
+		    (mk_easy_App mkInt_RDR [ah_RDR])
+		    (mk_easy_App mkInt_RDR [bh_RDR])
+		    (HsVar (maxtag_RDR tycon)))
+
+    from_enum
+      = mk_easy_FunMonoBind tycon_loc fromEnum_RDR [a_Pat] [] $
+	  untag_Expr tycon [(a_RDR, ah_RDR)] $
+	  (mk_easy_App mkInt_RDR [ah_RDR])
 \end{code}
 
 %************************************************************************
@@ -471,24 +441,25 @@ gen_Bounded_binds tycon
 	ASSERT(length data_cons == 1)
 	min_bound_1con `AndMonoBinds` max_bound_1con
   where
-    data_cons     = tyConDataCons tycon
+    data_cons = tyConDataCons tycon
+    tycon_loc = getSrcLoc tycon
 
     ----- enum-flavored: ---------------------------
-    min_bound_enum = mk_easy_FunMonoBind minBound_PN [] [] (HsVar data_con_1_PN)
-    max_bound_enum = mk_easy_FunMonoBind maxBound_PN [] [] (HsVar data_con_N_PN)
+    min_bound_enum = mk_easy_FunMonoBind tycon_loc minBound_RDR [] [] (HsVar data_con_1_RDR)
+    max_bound_enum = mk_easy_FunMonoBind tycon_loc maxBound_RDR [] [] (HsVar data_con_N_RDR)
 
     data_con_1	  = head data_cons
     data_con_N	  = last data_cons
-    data_con_1_PN = qual_orig_name data_con_1
-    data_con_N_PN = qual_orig_name data_con_N
+    data_con_1_RDR = qual_orig_name data_con_1
+    data_con_N_RDR = qual_orig_name data_con_N
 
     ----- single-constructor-flavored: -------------
     arity	   = dataConNumFields data_con_1
 
-    min_bound_1con = mk_easy_FunMonoBind minBound_PN [] [] $
-		     mk_easy_App data_con_1_PN (nOfThem arity minBound_PN)
-    max_bound_1con = mk_easy_FunMonoBind maxBound_PN [] [] $
-		     mk_easy_App data_con_1_PN (nOfThem arity maxBound_PN)
+    min_bound_1con = mk_easy_FunMonoBind tycon_loc minBound_RDR [] [] $
+		     mk_easy_App data_con_1_RDR (nOfThem arity minBound_RDR)
+    max_bound_1con = mk_easy_FunMonoBind tycon_loc maxBound_RDR [] [] $
+		     mk_easy_App data_con_1_RDR (nOfThem arity maxBound_RDR)
 \end{code}
 
 %************************************************************************
@@ -557,50 +528,51 @@ gen_Ix_binds tycon
     then enum_ixes
     else single_con_ixes
   where
-    tycon_str = _UNPK_ (nameOf (origName "gen_Ix_binds" tycon))
+    tycon_str = getOccString tycon
+    tycon_loc = getSrcLoc tycon
 
     --------------------------------------------------------------
     enum_ixes = enum_range `AndMonoBinds`
     	    	enum_index `AndMonoBinds` enum_inRange
 
     enum_range
-      = mk_easy_FunMonoBind range_PN [TuplePatIn [a_Pat, b_Pat]] [] $
-	  untag_Expr tycon [(a_PN, ah_PN)] $
-	  untag_Expr tycon [(b_PN, bh_PN)] $
-	  HsApp (mk_easy_App map_PN [tag2con_PN tycon]) $
+      = mk_easy_FunMonoBind tycon_loc range_RDR [TuplePatIn [a_Pat, b_Pat]] [] $
+	  untag_Expr tycon [(a_RDR, ah_RDR)] $
+	  untag_Expr tycon [(b_RDR, bh_RDR)] $
+	  HsApp (mk_easy_App map_RDR [tag2con_RDR tycon]) $
 	      HsPar (enum_from_to_Expr
-			(mk_easy_App mkInt_PN [ah_PN])
-			(mk_easy_App mkInt_PN [bh_PN]))
+			(mk_easy_App mkInt_RDR [ah_RDR])
+			(mk_easy_App mkInt_RDR [bh_RDR]))
 
     enum_index
-      = mk_easy_FunMonoBind index_PN [AsPatIn c_PN (TuplePatIn [a_Pat, b_Pat]), d_Pat] [] (
-	HsIf (HsPar (mk_easy_App inRange_PN [c_PN, d_PN])) (
-	   untag_Expr tycon [(a_PN, ah_PN)] (
-	   untag_Expr tycon [(d_PN, dh_PN)] (
+      = mk_easy_FunMonoBind tycon_loc index_RDR [AsPatIn c_RDR (TuplePatIn [a_Pat, b_Pat]), d_Pat] [] (
+	HsIf (HsPar (mk_easy_App inRange_RDR [c_RDR, d_RDR])) (
+	   untag_Expr tycon [(a_RDR, ah_RDR)] (
+	   untag_Expr tycon [(d_RDR, dh_RDR)] (
 	   let
-		grhs = [OtherwiseGRHS (mk_easy_App mkInt_PN [c_PN]) mkGeneratedSrcLoc]
+		grhs = [OtherwiseGRHS (mk_easy_App mkInt_RDR [c_RDR]) tycon_loc]
 	   in
 	   HsCase
-	     (HsPar (OpApp (HsVar dh_PN) (HsVar minusH_PN) (HsVar ah_PN)))
-	     [PatMatch (VarPatIn c_PN)
+	     (HsPar (OpApp (HsVar dh_RDR) (HsVar minusH_RDR) (HsVar ah_RDR)))
+	     [PatMatch (VarPatIn c_RDR)
 				(GRHSMatch (GRHSsAndBindsIn grhs EmptyBinds))]
-	     mkGeneratedSrcLoc
+	     tycon_loc
 	   ))
 	) {-else-} (
-	   HsApp (HsVar error_PN) (HsLit (HsString (_PK_ ("Ix."++tycon_str++".index: out of range\n"))))
+	   HsApp (HsVar error_RDR) (HsLit (HsString (_PK_ ("Ix."++tycon_str++".index: out of range\n"))))
 	)
-	mkGeneratedSrcLoc)
+	tycon_loc)
 
     enum_inRange
-      = mk_easy_FunMonoBind inRange_PN [TuplePatIn [a_Pat, b_Pat], c_Pat] [] (
-	  untag_Expr tycon [(a_PN, ah_PN)] (
-	  untag_Expr tycon [(b_PN, bh_PN)] (
-	  untag_Expr tycon [(c_PN, ch_PN)] (
-	  HsIf (HsPar (OpApp (HsVar ch_PN) (HsVar geH_PN) (HsVar ah_PN))) (
-	     (OpApp (HsVar ch_PN) (HsVar leH_PN) (HsVar bh_PN))
+      = mk_easy_FunMonoBind tycon_loc inRange_RDR [TuplePatIn [a_Pat, b_Pat], c_Pat] [] (
+	  untag_Expr tycon [(a_RDR, ah_RDR)] (
+	  untag_Expr tycon [(b_RDR, bh_RDR)] (
+	  untag_Expr tycon [(c_RDR, ch_RDR)] (
+	  HsIf (HsPar (OpApp (HsVar ch_RDR) (HsVar geH_RDR) (HsVar ah_RDR))) (
+	     (OpApp (HsVar ch_RDR) (HsVar leH_RDR) (HsVar bh_RDR))
 	  ) {-else-} (
 	     false_Expr
-	  ) mkGeneratedSrcLoc))))
+	  ) tycon_loc))))
 
     --------------------------------------------------------------
     single_con_ixes = single_con_range `AndMonoBinds`
@@ -615,49 +587,51 @@ gen_Ix_binds tycon
 			 dc
 
     con_arity   = dataConNumFields data_con
-    data_con_PN = qual_orig_name data_con
-    con_pat  xs = ConPatIn data_con_PN (map VarPatIn xs)
-    con_expr xs = mk_easy_App data_con_PN xs
+    data_con_RDR = qual_orig_name data_con
+    con_pat  xs = ConPatIn data_con_RDR (map VarPatIn xs)
+    con_expr xs = mk_easy_App data_con_RDR xs
 
-    as_needed = take con_arity as_PNs
-    bs_needed = take con_arity bs_PNs
-    cs_needed = take con_arity cs_PNs
+    as_needed = take con_arity as_RDRs
+    bs_needed = take con_arity bs_RDRs
+    cs_needed = take con_arity cs_RDRs
 
     --------------------------------------------------------------
     single_con_range
-      = mk_easy_FunMonoBind range_PN [TuplePatIn [con_pat as_needed, con_pat bs_needed]] [] (
+      = mk_easy_FunMonoBind tycon_loc range_RDR [TuplePatIn [con_pat as_needed, con_pat bs_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)
-			    (HsApp (HsVar range_PN) (ExplicitTuple [HsVar a, HsVar b]))
+			    (HsApp (HsVar range_RDR) (ExplicitTuple [HsVar a, HsVar b]))
 
     ----------------
     single_con_index
-      = mk_easy_FunMonoBind index_PN [TuplePatIn [con_pat as_needed, con_pat bs_needed], con_pat cs_needed] [range_size] (
+      = mk_easy_FunMonoBind tycon_loc index_RDR [TuplePatIn [con_pat as_needed, con_pat bs_needed], con_pat cs_needed] [range_size] (
 	foldl mk_index (HsLit (HsInt 0)) (zip3 as_needed bs_needed cs_needed))
       where
 	mk_index multiply_by (l, u, i)
 	  =OpApp (
-		(HsApp (HsApp (HsVar index_PN) (ExplicitTuple [HsVar l, HsVar u])) (HsVar i))
-	   ) (HsVar plus_PN) (
+		(HsApp (HsApp (HsVar index_RDR) (ExplicitTuple [HsVar l, HsVar u])) (HsVar i))
+	   ) (HsVar plus_RDR) (
 		OpApp (
-		    (HsApp (HsVar rangeSize_PN) (ExplicitTuple [HsVar l, HsVar u]))
-		) (HsVar times_PN) multiply_by
+		    (HsApp (HsVar rangeSize_RDR) (ExplicitTuple [HsVar l, HsVar u]))
+		) (HsVar times_RDR) multiply_by
 	   )
 
 	range_size
-	  = mk_easy_FunMonoBind rangeSize_PN [TuplePatIn [a_Pat, b_Pat]] [] (
+	  = mk_easy_FunMonoBind tycon_loc rangeSize_RDR [TuplePatIn [a_Pat, b_Pat]] [] (
 		OpApp (
-		    (HsApp (HsApp (HsVar index_PN) (ExplicitTuple [a_Expr, b_Expr])) b_Expr)
-		) (HsVar plus_PN) (HsLit (HsInt 1)))
+		    (HsApp (HsApp (HsVar index_RDR) (ExplicitTuple [a_Expr, b_Expr])) b_Expr)
+		) (HsVar plus_RDR) (HsLit (HsInt 1)))
 
     ------------------
     single_con_inRange
-      = mk_easy_FunMonoBind inRange_PN [TuplePatIn [con_pat as_needed, con_pat bs_needed], con_pat cs_needed] [] (
+      = mk_easy_FunMonoBind tycon_loc inRange_RDR 
+			   [TuplePatIn [con_pat as_needed, con_pat bs_needed], con_pat cs_needed]
+			   [] (
 	  foldl1 and_Expr (zipWith3Equal "single_con_inRange" in_range as_needed bs_needed cs_needed))
       where
-    	in_range a b c = HsApp (HsApp (HsVar inRange_PN) (ExplicitTuple [HsVar a, HsVar b])) (HsVar c)
+    	in_range a b c = HsApp (HsApp (HsVar inRange_RDR) (ExplicitTuple [HsVar a, HsVar b])) (HsVar c)
 \end{code}
 
 %************************************************************************
@@ -669,38 +643,39 @@ gen_Ix_binds tycon
 Ignoring all the infix-ery mumbo jumbo (ToDo)
 
 \begin{code}
-gen_Read_binds :: [RenamedFixityDecl] -> TyCon -> RdrNameMonoBinds
+gen_Read_binds :: TyCon -> RdrNameMonoBinds
 
-gen_Read_binds fixities tycon
+gen_Read_binds tycon
   = reads_prec `AndMonoBinds` read_list
   where
+    tycon_loc = getSrcLoc tycon
     -----------------------------------------------------------------------
-    read_list = mk_easy_FunMonoBind readList_PN [] []
-		  (HsApp (HsVar readList___PN) (HsPar (HsApp (HsVar readsPrec_PN) (HsLit (HsInt 0)))))
+    read_list = mk_easy_FunMonoBind tycon_loc readList_RDR [] []
+		  (HsApp (HsVar readList___RDR) (HsPar (HsApp (HsVar readsPrec_RDR) (HsLit (HsInt 0)))))
     -----------------------------------------------------------------------
     reads_prec
       = let
 	    read_con_comprehensions
 	      = map read_con (tyConDataCons tycon)
 	in
-	mk_easy_FunMonoBind readsPrec_PN [a_Pat, b_Pat] [] (
+	mk_easy_FunMonoBind tycon_loc readsPrec_RDR [a_Pat, b_Pat] [] (
 	      foldl1 append_Expr read_con_comprehensions
 	)
       where
 	read_con data_con   -- note: "b" is the string being "read"
 	  = let
-		data_con_PN = qual_orig_name data_con
-		data_con_str= nameOf (origName "gen_Read_binds" data_con)
+		data_con_RDR = qual_orig_name data_con
+		data_con_str= occNameString (getOccName data_con)
 		con_arity   = dataConNumFields data_con
-		as_needed   = take con_arity as_PNs
-		bs_needed   = take con_arity bs_PNs
-		con_expr    = mk_easy_App data_con_PN as_needed
+		as_needed   = take con_arity as_RDRs
+		bs_needed   = take con_arity bs_RDRs
+		con_expr    = mk_easy_App data_con_RDR as_needed
 		nullary_con = isNullaryDataCon data_con
 
 		con_qual
 		  = GeneratorQual
 		      (TuplePatIn [LitPatIn (HsString data_con_str), d_Pat])
-		      (HsApp (HsVar lex_PN) c_Expr)
+		      (HsApp (HsVar lex_RDR) c_Expr)
 
 		field_quals = snd (mapAccumL mk_qual d_Expr (zipEqual "as_needed" as_needed bs_needed))
 
@@ -708,21 +683,21 @@ gen_Read_binds fixities tycon
 		  = if nullary_con then -- must be False (parens are surely optional)
 		       false_Expr
 		    else -- parens depend on precedence...
-		       HsPar (OpApp a_Expr (HsVar gt_PN) (HsLit (HsInt 9)))
+		       HsPar (OpApp a_Expr (HsVar gt_RDR) (HsLit (HsInt 9)))
 	    in
 	    HsApp (
 	      readParen_Expr read_paren_arg $ HsPar $
-		 HsLam (mk_easy_Match [c_Pat] []  (
+		 HsLam (mk_easy_Match tycon_loc [c_Pat] []  (
 		   ListComp (ExplicitTuple [con_expr,
 			    if null bs_needed then d_Expr else HsVar (last bs_needed)])
 		    (con_qual : field_quals)))
-	      ) (HsVar b_PN)
+	      ) (HsVar b_RDR)
 	  where
 	    mk_qual draw_from (con_field, str_left)
 	      = (HsVar str_left,	-- what to draw from down the line...
 		 GeneratorQual
 		  (TuplePatIn [VarPatIn con_field, VarPatIn str_left])
-		  (HsApp (HsApp (HsVar readsPrec_PN) (HsLit (HsInt 10))) draw_from))
+		  (HsApp (HsApp (HsVar readsPrec_RDR) (HsLit (HsInt 10))) draw_from))
 \end{code}
 
 %************************************************************************
@@ -734,36 +709,37 @@ gen_Read_binds fixities tycon
 Ignoring all the infix-ery mumbo jumbo (ToDo)
 
 \begin{code}
-gen_Show_binds :: [RenamedFixityDecl] -> TyCon -> RdrNameMonoBinds
+gen_Show_binds :: TyCon -> RdrNameMonoBinds
 
-gen_Show_binds fixities tycon
+gen_Show_binds tycon
   = shows_prec `AndMonoBinds` show_list
   where
+    tycon_loc = getSrcLoc tycon
     -----------------------------------------------------------------------
-    show_list = mk_easy_FunMonoBind showList_PN [] []
-		  (HsApp (HsVar showList___PN) (HsPar (HsApp (HsVar showsPrec_PN) (HsLit (HsInt 0)))))
+    show_list = mk_easy_FunMonoBind tycon_loc showList_RDR [] []
+		  (HsApp (HsVar showList___RDR) (HsPar (HsApp (HsVar showsPrec_RDR) (HsLit (HsInt 0)))))
     -----------------------------------------------------------------------
     shows_prec
-      = mk_FunMonoBind showsPrec_PN (map pats_etc (tyConDataCons tycon))
+      = mk_FunMonoBind tycon_loc showsPrec_RDR (map pats_etc (tyConDataCons tycon))
       where
 	pats_etc data_con
 	  = let
-		data_con_PN = qual_orig_name data_con
+		data_con_RDR = qual_orig_name data_con
 		con_arity   = dataConNumFields data_con
-		bs_needed   = take con_arity bs_PNs
-		con_pat     = ConPatIn data_con_PN (map VarPatIn bs_needed)
+		bs_needed   = take con_arity bs_RDRs
+		con_pat     = ConPatIn data_con_RDR (map VarPatIn bs_needed)
 		nullary_con = isNullaryDataCon data_con
 
 		show_con
-		  = let (OrigName mod nm) = origName "gen_Show_binds" data_con
+		  = let nm = occNameString (getOccName data_con)
 			space_maybe = if nullary_con then _NIL_ else SLIT(" ")
 		    in
-			HsApp (HsVar showString_PN) (HsLit (HsString (nm _APPEND_ space_maybe)))
+			HsApp (HsVar showString_RDR) (HsLit (HsString (nm _APPEND_ space_maybe)))
 
 		show_thingies = show_con : (spacified real_show_thingies)
 
 		real_show_thingies
-		  = [ HsApp (HsApp (HsVar showsPrec_PN) (HsLit (HsInt 10))) (HsVar b)
+		  = [ HsApp (HsApp (HsVar showsPrec_RDR) (HsLit (HsInt 10))) (HsVar b)
 		  | b <- bs_needed ]
 	    in
 	    if nullary_con then  -- skip the showParen junk...
@@ -771,12 +747,12 @@ gen_Show_binds fixities tycon
 		([a_Pat, con_pat], show_con)
 	    else
 		([a_Pat, con_pat],
-		    showParen_Expr (HsPar (OpApp a_Expr (HsVar ge_PN) (HsLit (HsInt 10))))
+		    showParen_Expr (HsPar (OpApp a_Expr (HsVar ge_RDR) (HsLit (HsInt 10))))
 				   (HsPar (nested_compose_Expr show_thingies)))
 	  where
 	    spacified []     = []
 	    spacified [x]    = [x]
-	    spacified (x:xs) = (x : (HsVar showSpace_PN) : spacified xs)
+	    spacified (x:xs) = (x : (HsVar showSpace_RDR) : spacified xs)
 \end{code}
 
 %************************************************************************
@@ -806,8 +782,8 @@ gen_tag_n_con_monobind
 	TagThingWanted)
     -> RdrNameMonoBinds
 
-gen_tag_n_con_monobind (pn, tycon, GenCon2Tag)
-  = mk_FunMonoBind pn (map mk_stuff (tyConDataCons tycon))
+gen_tag_n_con_monobind (rdr_name, tycon, GenCon2Tag)
+  = mk_FunMonoBind (getSrcLoc tycon) rdr_name (map mk_stuff (tyConDataCons tycon))
   where
     mk_stuff :: DataCon -> ([RdrNamePat], RdrNameHsExpr)
 
@@ -815,23 +791,24 @@ gen_tag_n_con_monobind (pn, tycon, GenCon2Tag)
       = ASSERT(isDataCon var)
 	([pat], HsLit (HsIntPrim (toInteger ((dataConTag var) - fIRST_TAG))))
       where
-	pat    = ConPatIn var_PN (nOfThem (dataConNumFields var) WildPatIn)
-	var_PN = qual_orig_name var
+	pat    = ConPatIn var_RDR (nOfThem (dataConNumFields var) WildPatIn)
+	var_RDR = qual_orig_name var
 
-gen_tag_n_con_monobind (pn, tycon, GenTag2Con)
-  = mk_FunMonoBind pn (map mk_stuff (tyConDataCons tycon))
+gen_tag_n_con_monobind (rdr_name, tycon, GenTag2Con)
+  = mk_FunMonoBind (getSrcLoc tycon) rdr_name (map mk_stuff (tyConDataCons tycon))
   where
     mk_stuff :: DataCon -> ([RdrNamePat], RdrNameHsExpr)
 
     mk_stuff var
       = ASSERT(isDataCon var)
-	([lit_pat], HsVar var_PN)
+	([lit_pat], HsVar var_RDR)
       where
-	lit_pat = ConPatIn mkInt_PN [LitPatIn (HsIntPrim (toInteger ((dataConTag var) - fIRST_TAG)))]
-	var_PN  = qual_orig_name var
+	lit_pat = ConPatIn mkInt_RDR [LitPatIn (HsIntPrim (toInteger ((dataConTag var) - fIRST_TAG)))]
+	var_RDR  = qual_orig_name var
 
-gen_tag_n_con_monobind (pn, tycon, GenMaxTag)
-  = mk_easy_FunMonoBind pn [] [] (HsApp (HsVar mkInt_PN) (HsLit (HsIntPrim max_tag)))
+gen_tag_n_con_monobind (rdr_name, tycon, GenMaxTag)
+  = mk_easy_FunMonoBind (getSrcLoc tycon) 
+		rdr_name [] [] (HsApp (HsVar mkInt_RDR) (HsLit (HsIntPrim max_tag)))
   where
     max_tag =  case (tyConDataCons tycon) of
 		 data_cons -> toInteger ((length data_cons) - fIRST_TAG)
@@ -858,15 +835,15 @@ multi-clause definitions; it generates:
 \end{verbatim}
 
 \begin{code}
-mk_easy_FunMonoBind :: RdrName -> [RdrNamePat]
+mk_easy_FunMonoBind :: SrcLoc -> RdrName -> [RdrNamePat]
 		    -> [RdrNameMonoBinds] -> RdrNameHsExpr
 		    -> RdrNameMonoBinds
 
-mk_easy_FunMonoBind fun pats binds expr
-  = FunMonoBind fun False{-not infix-} [mk_easy_Match pats binds expr] mkGeneratedSrcLoc
+mk_easy_FunMonoBind loc fun pats binds expr
+  = FunMonoBind fun False{-not infix-} [mk_easy_Match loc pats binds expr] loc
 
-mk_easy_Match pats binds expr
-  = mk_match pats expr (mkbind binds)
+mk_easy_Match loc pats binds expr
+  = mk_match loc pats expr (mkbind binds)
   where
     mkbind [] = EmptyBinds
     mkbind bs = SingleBind (RecBind (foldr1 AndMonoBinds bs))
@@ -874,19 +851,19 @@ mk_easy_Match pats binds expr
 	-- "recursive" MonoBinds, and it is its job to sort things out
 	-- from there.
 
-mk_FunMonoBind	:: RdrName
+mk_FunMonoBind	:: SrcLoc -> RdrName
 		-> [([RdrNamePat], RdrNameHsExpr)]
 		-> RdrNameMonoBinds
 
-mk_FunMonoBind fun [] = panic "TcGenDeriv:mk_FunMonoBind"
-mk_FunMonoBind fun pats_and_exprs
+mk_FunMonoBind loc fun [] = panic "TcGenDeriv:mk_FunMonoBind"
+mk_FunMonoBind loc fun pats_and_exprs
   = FunMonoBind fun False{-not infix-}
-		[ mk_match p e EmptyBinds | (p,e) <-pats_and_exprs ]
-		mkGeneratedSrcLoc
+		[ mk_match loc p e EmptyBinds | (p,e) <-pats_and_exprs ]
+		loc
 
-mk_match pats expr binds
+mk_match loc pats expr binds
   = foldr PatMatch
-	  (GRHSMatch (GRHSsAndBindsIn [OtherwiseGRHS expr mkGeneratedSrcLoc] binds))
+	  (GRHSMatch (GRHSsAndBindsIn [OtherwiseGRHS expr loc] binds))
 	  (map paren pats)
   where
     paren p@(VarPatIn _) = p
@@ -897,6 +874,8 @@ mk_match pats expr binds
 mk_easy_App f xs = foldl HsApp (HsVar f) (map HsVar xs)
 \end{code}
 
+ToDo: Better SrcLocs.
+
 \begin{code}
 compare_Case, cmp_eq_Expr ::
 	  RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
@@ -913,24 +892,24 @@ careful_compare_Case :: -- checks for primitive types...
 	  -> RdrNameHsExpr -> RdrNameHsExpr
 	  -> RdrNameHsExpr
 
-compare_Case = compare_gen_Case compare_PN
-cmp_eq_Expr = compare_gen_Case cmp_eq_PN
+compare_Case = compare_gen_Case compare_RDR
+cmp_eq_Expr = compare_gen_Case cmp_eq_RDR
 
 compare_gen_Case fun lt eq gt a b
   = HsCase (HsPar (HsApp (HsApp (HsVar fun) a) b)) {-of-}
-      [PatMatch (ConPatIn ltTag_PN [])
+      [PatMatch (ConPatIn ltTag_RDR [])
 	  (GRHSMatch (GRHSsAndBindsIn [OtherwiseGRHS lt mkGeneratedSrcLoc] EmptyBinds)),
 
-       PatMatch (ConPatIn eqTag_PN [])
+       PatMatch (ConPatIn eqTag_RDR [])
 	  (GRHSMatch (GRHSsAndBindsIn [OtherwiseGRHS eq mkGeneratedSrcLoc] EmptyBinds)),
 
-       PatMatch (ConPatIn gtTag_PN [])
+       PatMatch (ConPatIn gtTag_RDR [])
 	  (GRHSMatch (GRHSsAndBindsIn [OtherwiseGRHS gt mkGeneratedSrcLoc] EmptyBinds))]
        mkGeneratedSrcLoc
 
 careful_compare_Case ty lt eq gt a b
   = if not (isPrimType ty) then
-       compare_gen_Case compare_PN lt eq gt a b
+       compare_gen_Case compare_RDR lt eq gt a b
 
     else -- we have to do something special for primitive things...
        HsIf (HsPar (OpApp a (HsVar relevant_eq_op) b))
@@ -948,36 +927,36 @@ assoc_ty_id tyids ty
     res = [id | (ty',id) <- tyids, eqTy ty ty']
 
 eq_op_tbl =
-    [(charPrimTy,	eqH_Char_PN)
-    ,(intPrimTy,	eqH_Int_PN)
-    ,(wordPrimTy,	eqH_Word_PN)
-    ,(addrPrimTy,	eqH_Addr_PN)
-    ,(floatPrimTy,	eqH_Float_PN)
-    ,(doublePrimTy,	eqH_Double_PN)
+    [(charPrimTy,	eqH_Char_RDR)
+    ,(intPrimTy,	eqH_Int_RDR)
+    ,(wordPrimTy,	eqH_Word_RDR)
+    ,(addrPrimTy,	eqH_Addr_RDR)
+    ,(floatPrimTy,	eqH_Float_RDR)
+    ,(doublePrimTy,	eqH_Double_RDR)
     ]
 
 lt_op_tbl =
-    [(charPrimTy,	ltH_Char_PN)
-    ,(intPrimTy,	ltH_Int_PN)
-    ,(wordPrimTy,	ltH_Word_PN)
-    ,(addrPrimTy,	ltH_Addr_PN)
-    ,(floatPrimTy,	ltH_Float_PN)
-    ,(doublePrimTy,	ltH_Double_PN)
+    [(charPrimTy,	ltH_Char_RDR)
+    ,(intPrimTy,	ltH_Int_RDR)
+    ,(wordPrimTy,	ltH_Word_RDR)
+    ,(addrPrimTy,	ltH_Addr_RDR)
+    ,(floatPrimTy,	ltH_Float_RDR)
+    ,(doublePrimTy,	ltH_Double_RDR)
     ]
 
 -----------------------------------------------------------------------
 
 and_Expr, append_Expr :: RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
 
-and_Expr    a b = OpApp a (HsVar and_PN)    b
-append_Expr a b = OpApp a (HsVar append_PN) b
+and_Expr    a b = OpApp a (HsVar and_RDR)    b
+append_Expr a b = OpApp a (HsVar append_RDR) b
 
 -----------------------------------------------------------------------
 
 eq_Expr :: Type -> RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
 eq_Expr ty a b
   = if not (isPrimType ty) then
-       OpApp a (HsVar eq_PN)  b
+       OpApp a (HsVar eq_RDR)  b
     else -- we have to do something special for primitive things...
        OpApp a (HsVar relevant_eq_op) b
   where
@@ -1011,141 +990,78 @@ enum_from_then_to_Expr
 	:: RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
 	-> RdrNameHsExpr
 
-enum_from_to_Expr      f   t2 = HsApp (HsApp (HsVar enumFromTo_PN) f) t2
-enum_from_then_to_Expr f t t2 = HsApp (HsApp (HsApp (HsVar enumFromThenTo_PN) f) t) t2
+enum_from_to_Expr      f   t2 = HsApp (HsApp (HsVar enumFromTo_RDR) f) t2
+enum_from_then_to_Expr f t t2 = HsApp (HsApp (HsApp (HsVar enumFromThenTo_RDR) f) t) t2
 
 showParen_Expr, readParen_Expr
 	:: RdrNameHsExpr -> RdrNameHsExpr
 	-> RdrNameHsExpr
 
-showParen_Expr e1 e2 = HsApp (HsApp (HsVar showParen_PN) e1) e2
-readParen_Expr e1 e2 = HsApp (HsApp (HsVar readParen_PN) e1) e2
+showParen_Expr e1 e2 = HsApp (HsApp (HsVar showParen_RDR) e1) e2
+readParen_Expr e1 e2 = HsApp (HsApp (HsVar readParen_RDR) e1) e2
 
 nested_compose_Expr :: [RdrNameHsExpr] -> RdrNameHsExpr
 
 nested_compose_Expr [e] = parenify e
 nested_compose_Expr (e:es)
-  = HsApp (HsApp (HsVar compose_PN) (parenify e)) (nested_compose_Expr es)
+  = HsApp (HsApp (HsVar compose_RDR) (parenify e)) (nested_compose_Expr es)
 
 parenify e@(HsVar _) = e
 parenify e	     = HsPar e
 \end{code}
 
 \begin{code}
-qual_orig_name n = case (origName "qual_orig_name" n) of { OrigName m n -> Qual m n }
-
-a_PN		= Unqual SLIT("a")
-b_PN		= Unqual SLIT("b")
-c_PN		= Unqual SLIT("c")
-d_PN		= Unqual SLIT("d")
-ah_PN		= Unqual SLIT("a#")
-bh_PN		= Unqual SLIT("b#")
-ch_PN		= Unqual SLIT("c#")
-dh_PN		= Unqual SLIT("d#")
-cmp_eq_PN	= Unqual SLIT("cmp_eq")
-rangeSize_PN	= Qual iX SLIT("rangeSize")
-
-as_PNs		= [ Unqual (_PK_ ("a"++show i)) | i <- [(1::Int) .. ] ]
-bs_PNs		= [ Unqual (_PK_ ("b"++show i)) | i <- [(1::Int) .. ] ]
-cs_PNs		= [ Unqual (_PK_ ("c"++show i)) | i <- [(1::Int) .. ] ]
-
-eq_PN		 = preludeQual {-SLIT("Eq")-}  SLIT("==")
-ne_PN		 = preludeQual {-SLIT("Eq")-}  SLIT("/=")
-le_PN		 = preludeQual {-SLIT("Ord")-} SLIT("<=")
-lt_PN		 = preludeQual {-SLIT("Ord")-} SLIT("<")
-ge_PN		 = preludeQual {-SLIT("Ord")-} SLIT(">=")
-gt_PN		 = preludeQual {-SLIT("Ord")-} SLIT(">")
-max_PN		 = preludeQual {-SLIT("Ord")-} SLIT("max")
-min_PN		 = preludeQual {-SLIT("Ord")-} SLIT("min")
-compare_PN	 = preludeQual {-SLIT("Ord")-} SLIT("compare")
-minBound_PN	 = preludeQual {-SLIT("Bounded")-} SLIT("minBound")
-maxBound_PN	 = preludeQual {-SLIT("Bounded")-} SLIT("maxBound")
-enumFrom_PN	 = preludeQual {-SLIT("Enum")-} SLIT("enumFrom")
-enumFromTo_PN	 = preludeQual {-SLIT("Enum")-} SLIT("enumFromTo")
-enumFromThen_PN	 = preludeQual {-SLIT("Enum")-} SLIT("enumFromThen")
-enumFromThenTo_PN= preludeQual {-SLIT("Enum")-} SLIT("enumFromThenTo")
-range_PN	 = Qual iX   SLIT("range")
-index_PN	 = Qual iX   SLIT("index")
-inRange_PN	 = Qual iX   SLIT("inRange")
-readsPrec_PN	 = preludeQual {-SLIT("Read")-} SLIT("readsPrec")
-readList_PN	 = preludeQual {-SLIT("Read")-} SLIT("readList")
-showsPrec_PN	 = preludeQual {-SLIT("Show")-} SLIT("showsPrec")
-showList_PN	 = preludeQual {-SLIT("Show")-} SLIT("showList")
-plus_PN		 = preludeQual {-SLIT("Num")-}  SLIT("+")
-times_PN	 = preludeQual {-SLIT("Num")-}  SLIT("*")
-ltTag_PN	 = preludeQual SLIT("LT")
-eqTag_PN	 = preludeQual SLIT("EQ")
-gtTag_PN	 = preludeQual SLIT("GT")
-
-eqH_Char_PN	= prelude_primop CharEqOp
-ltH_Char_PN	= prelude_primop CharLtOp
-eqH_Word_PN	= prelude_primop WordEqOp
-ltH_Word_PN	= prelude_primop WordLtOp
-eqH_Addr_PN	= prelude_primop AddrEqOp
-ltH_Addr_PN	= prelude_primop AddrLtOp
-eqH_Float_PN	= prelude_primop FloatEqOp
-ltH_Float_PN	= prelude_primop FloatLtOp
-eqH_Double_PN	= prelude_primop DoubleEqOp
-ltH_Double_PN	= prelude_primop DoubleLtOp
-eqH_Int_PN	= prelude_primop IntEqOp
-ltH_Int_PN	= prelude_primop IntLtOp
-geH_PN		= prelude_primop IntGeOp
-leH_PN		= prelude_primop IntLeOp
-minusH_PN	= prelude_primop IntSubOp
-
-prelude_primop   o = case (origName "prelude_primop" (primOpId o)) of { OrigName m n -> Qual m n }
-
-false_PN	= preludeQual SLIT("False")
-true_PN		= preludeQual SLIT("True")
-and_PN		= preludeQual SLIT("&&")
-not_PN		= preludeQual SLIT("not")
-append_PN	= preludeQual SLIT("++")
-map_PN		= preludeQual SLIT("map")
-compose_PN	= preludeQual SLIT(".")
-mkInt_PN	= preludeQual SLIT("I#")
-error_PN	= preludeQual SLIT("error")
-showString_PN	= preludeQual SLIT("showString")
-showParen_PN	= preludeQual SLIT("showParen")
-readParen_PN	= preludeQual SLIT("readParen")
-lex_PN		= Qual gHC__  SLIT("lex")
-showSpace_PN	= Qual gHC__  SLIT("showSpace")
-showList___PN   = Qual gHC__  SLIT("showList__")
-readList___PN   = Qual gHC__  SLIT("readList__")
-
-a_Expr		= HsVar a_PN
-b_Expr		= HsVar b_PN
-c_Expr		= HsVar c_PN
-d_Expr		= HsVar d_PN
-ltTag_Expr	= HsVar ltTag_PN
-eqTag_Expr	= HsVar eqTag_PN
-gtTag_Expr	= HsVar gtTag_PN
-false_Expr	= HsVar false_PN
-true_Expr	= HsVar true_PN
-
-con2tag_Expr tycon = HsVar (con2tag_PN tycon)
-
-a_Pat		= VarPatIn a_PN
-b_Pat		= VarPatIn b_PN
-c_Pat		= VarPatIn c_PN
-d_Pat		= VarPatIn d_PN
-
-con2tag_PN, tag2con_PN, maxtag_PN :: TyCon -> RdrName
-
-con2tag_PN tycon
-  = let	(OrigName mod nm) = origName "con2tag_PN" tycon
-	con2tag	  = SLIT("con2tag_") _APPEND_ nm _APPEND_ SLIT("#")
+qual_orig_name n = case modAndOcc n of { (m,n) -> Qual m n }
+
+a_RDR		= varUnqual SLIT("a")
+b_RDR		= varUnqual SLIT("b")
+c_RDR		= varUnqual SLIT("c")
+d_RDR		= varUnqual SLIT("d")
+ah_RDR		= varUnqual SLIT("a#")
+bh_RDR		= varUnqual SLIT("b#")
+ch_RDR		= varUnqual SLIT("c#")
+dh_RDR		= varUnqual SLIT("d#")
+cmp_eq_RDR	= varUnqual SLIT("cmp_eq")
+rangeSize_RDR	= varUnqual SLIT("rangeSize")
+
+as_RDRs		= [ varUnqual (_PK_ ("a"++show i)) | i <- [(1::Int) .. ] ]
+bs_RDRs		= [ varUnqual (_PK_ ("b"++show i)) | i <- [(1::Int) .. ] ]
+cs_RDRs		= [ varUnqual (_PK_ ("c"++show i)) | i <- [(1::Int) .. ] ]
+
+a_Expr		= HsVar a_RDR
+b_Expr		= HsVar b_RDR
+c_Expr		= HsVar c_RDR
+d_Expr		= HsVar d_RDR
+ltTag_Expr	= HsVar ltTag_RDR
+eqTag_Expr	= HsVar eqTag_RDR
+gtTag_Expr	= HsVar gtTag_RDR
+false_Expr	= HsVar false_RDR
+true_Expr	= HsVar true_RDR
+
+con2tag_Expr tycon = HsVar (con2tag_RDR tycon)
+
+a_Pat		= VarPatIn a_RDR
+b_Pat		= VarPatIn b_RDR
+c_Pat		= VarPatIn c_RDR
+d_Pat		= VarPatIn d_RDR
+
+con2tag_RDR, tag2con_RDR, maxtag_RDR :: TyCon -> RdrName
+
+con2tag_RDR tycon
+  = let	(mod, nm) = modAndOcc tycon
+	con2tag	  = SLIT("con2tag_") _APPEND_ occNameString nm _APPEND_ SLIT("#")
     in
-    Qual mod con2tag
+    varQual (mod, con2tag)
 
-tag2con_PN tycon
-  = let	(OrigName mod nm) = origName "tag2con_PN" tycon
-	tag2con	  = SLIT("tag2con_") _APPEND_ nm _APPEND_ SLIT("#")
+tag2con_RDR tycon
+  = let	(mod, nm) = modAndOcc tycon
+	tag2con	  = SLIT("tag2con_") _APPEND_ occNameString nm _APPEND_ SLIT("#")
     in
-    Qual mod tag2con
+    varQual (mod, tag2con)
 
-maxtag_PN tycon
-  = let	(OrigName mod nm) = origName "maxtag_PN" tycon
-	maxtag	  = SLIT("maxtag_") _APPEND_ nm _APPEND_ SLIT("#")
+maxtag_RDR tycon
+  = let	(mod, nm) = modAndOcc tycon
+	maxtag	  = SLIT("maxtag_") _APPEND_ occNameString nm _APPEND_ SLIT("#")
     in
-    Qual mod maxtag
+    varQual (mod, maxtag)
 \end{code}
diff --git a/ghc/compiler/typecheck/TcHsSyn.lhs b/ghc/compiler/typecheck/TcHsSyn.lhs
index 00eb7544e7..9b0be49aa4 100644
--- a/ghc/compiler/typecheck/TcHsSyn.lhs
+++ b/ghc/compiler/typecheck/TcHsSyn.lhs
@@ -15,7 +15,7 @@ module TcHsSyn (
 	SYN_IE(TcMonoBinds), SYN_IE(TcHsBinds), SYN_IE(TcBind), SYN_IE(TcPat),
 	SYN_IE(TcExpr), SYN_IE(TcGRHSsAndBinds), SYN_IE(TcGRHS), SYN_IE(TcMatch),
 	SYN_IE(TcQual), SYN_IE(TcStmt), SYN_IE(TcArithSeqInfo), SYN_IE(TcRecordBinds),
-	SYN_IE(TcHsModule),
+	SYN_IE(TcHsModule), SYN_IE(TcCoreExpr),
 	
 	SYN_IE(TypecheckedHsBinds), SYN_IE(TypecheckedBind),
 	SYN_IE(TypecheckedMonoBinds), SYN_IE(TypecheckedPat),
@@ -44,7 +44,7 @@ import Id	( GenId(..), IdDetails,	-- Can meddle modestly with Ids
 
 -- others:
 import Name	( Name{--O only-} )
-import TcMonad	hiding ( rnMtoTcM )
+import TcMonad
 import TcType	( SYN_IE(TcType), TcMaybe, SYN_IE(TcTyVar),
 		  zonkTcTypeToType, zonkTcTyVarToTyVar
 		)
@@ -56,6 +56,7 @@ import Type	( mkTyVarTy, tyVarsOfType )
 import TyVar	( GenTyVar {- instances -},
 		  SYN_IE(TyVarEnv), growTyVarEnvList, emptyTyVarSet )
 import TysPrim	( voidTy )
+import CoreSyn  ( GenCoreExpr )
 import Unique	( Unique )		-- instances
 import UniqFM
 import PprStyle
@@ -92,6 +93,8 @@ type TcArithSeqInfo s	= ArithSeqInfo (TcTyVar s) UVar (TcIdOcc s) (TcPat s)
 type TcRecordBinds s	= HsRecordBinds (TcTyVar s) UVar (TcIdOcc s) (TcPat s)
 type TcHsModule s	= HsModule (TcTyVar s) UVar (TcIdOcc s) (TcPat s)
 
+type TcCoreExpr s	= GenCoreExpr (TcIdOcc s) (TcIdOcc s) (TcTyVar s) UVar
+
 type TypecheckedPat		= OutPat	TyVar UVar Id
 type TypecheckedMonoBinds 	= MonoBinds	TyVar UVar Id TypecheckedPat
 type TypecheckedHsBinds		= HsBinds	TyVar UVar Id TypecheckedPat
@@ -284,6 +287,10 @@ zonkMonoBinds te ve (VarMonoBind var expr)
     zonkExpr te ve expr		`thenNF_Tc` \ new_expr ->
     returnNF_Tc (VarMonoBind new_var new_expr, [new_var])
 
+zonkMonoBinds te ve (CoreMonoBind var core_expr)
+  = zonkIdBndr te var    	`thenNF_Tc` \ new_var ->
+    returnNF_Tc (CoreMonoBind new_var core_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 ->
diff --git a/ghc/compiler/typecheck/TcIfaceSig.lhs b/ghc/compiler/typecheck/TcIfaceSig.lhs
index b8e1b1ad7b..656a1e29b2 100644
--- a/ghc/compiler/typecheck/TcIfaceSig.lhs
+++ b/ghc/compiler/typecheck/TcIfaceSig.lhs
@@ -10,24 +10,32 @@ module TcIfaceSig ( tcInterfaceSigs ) where
 
 IMP_Ubiq()
 
-import TcMonad		hiding ( rnMtoTcM )
-import TcMonoType	( tcPolyType )
+import TcMonad
+import TcMonoType	( tcHsType )
+import TcEnv		( tcLookupGlobalValue, tcExtendTyVarEnv, tcExtendGlobalValEnv )
+import TcKind		( TcKind, kindToTcKind )
 
-import HsSyn		( Sig(..), PolyType )
-import RnHsSyn		( RenamedSig(..), RnName(..) )
+import HsSyn		( IfaceSig(..), HsDecl(..), TyDecl, ClassDecl, InstDecl, DefaultDecl, HsBinds,
+			  Fake, InPat, HsType )
+import RnHsSyn		( RenamedHsDecl(..) )
+import HsCore
+import HsDecls		( HsIdInfo(..) )
+import CoreSyn
+import CoreUnfold
+import MagicUFs		( MagicUnfoldingFun )
+import SpecEnv		( SpecEnv )
+import PrimOp		( PrimOp(..) )
 
-import CmdLineOpts	( opt_CompilingGhcInternals )
-import Id		( mkImported )
---import Name		( Name(..) )
+import Id		( GenId, mkImported, mkUserId, isPrimitiveId_maybe )
+import TyVar		( mkTyVar )
+import Name		( Name )
+import PragmaInfo	( PragmaInfo(..) )
 import Maybes		( maybeToBool )
 import Pretty
-import Util		( panic )
-
-
---import TcPragmas	( tcGenPragmas )
-import IdInfo		( noIdInfo )
-tcGenPragmas ty id ps = returnNF_Tc noIdInfo
+import PprStyle		( PprStyle(..) )
+import Util		( zipWithEqual, panic, pprTrace, pprPanic )
 
+import IdInfo
 \end{code}
 
 Ultimately, type signatures in interfaces will have pragmatic
@@ -38,37 +46,221 @@ As always, we do not have to worry about user-pragmas in interface
 signatures.
 
 \begin{code}
-tcInterfaceSigs :: [RenamedSig] -> TcM s [Id]
+tcInterfaceSigs :: [RenamedHsDecl] -> TcM s [Id]
+		   -- Ignore non-sig-decls in these decls
+
+tcInterfaceSigs (SigD (IfaceSig name ty id_infos src_loc) : rest)
+  = tcAddSrcLoc src_loc $
+    tcHsType ty				`thenTc` \ sigma_ty ->
+    tcIdInfo name noIdInfo id_infos	`thenTc` \ id_info' ->
+    let
+	sig_id = mkImported name sigma_ty id_info'
+    in
+    tcInterfaceSigs rest		`thenTc` \ sig_ids ->
+    returnTc (sig_id : sig_ids)
+
+tcInterfaceSigs (other_decl : rest) = tcInterfaceSigs rest
 
 tcInterfaceSigs [] = returnTc []
+\end{code}
+
+Inside here we use only the Global environment, even for locally bound variables.
+Why? Because we know all the types and want to bind them to real Ids.
+
+\begin{code}
+tcIdInfo name info [] = returnTc info
+
+tcIdInfo name info (HsArity arity : rest)
+  = tcIdInfo name (info `addArityInfo` arity) rest
+
+tcIdInfo name info (HsUpdate upd : rest)
+  = tcIdInfo name (info `addUpdateInfo` upd) rest
+
+tcIdInfo name info (HsFBType fb : rest)
+  = tcIdInfo name (info `addFBTypeInfo` fb) rest
+
+tcIdInfo name info (HsArgUsage au : rest)
+  = tcIdInfo name (info `addArgUsageInfo` au) rest
+
+tcIdInfo name info (HsDeforest df : rest)
+  = tcIdInfo name (info `addDeforestInfo` df) rest
+
+tcIdInfo name info (HsUnfold expr : rest)
+  = tcUnfolding name expr 	`thenNF_Tc` \ unfold_info ->
+    tcIdInfo name (info `addUnfoldInfo` unfold_info) rest
+
+tcIdInfo name info (HsStrictness strict : rest)
+  = tcStrictness strict 	`thenTc` \ strict_info ->
+    tcIdInfo name (info `addStrictnessInfo` strict_info) rest
+\end{code}
+
+\begin{code}
+tcStrictness (StrictnessInfo demands (Just worker))
+  = tcLookupGlobalValue worker		`thenNF_Tc` \ worker_id ->
+    returnTc (StrictnessInfo demands (Just worker_id))
+
+-- Boring to write these out, but the result type differe from the arg type...
+tcStrictness (StrictnessInfo demands Nothing) = returnTc (StrictnessInfo demands Nothing)
+tcStrictness NoStrictnessInfo		      = returnTc NoStrictnessInfo
+tcStrictness BottomGuaranteed		      = returnTc BottomGuaranteed
+\end{code}
+
+For unfoldings we try to do the job lazily, so that we never type check
+an unfolding that isn't going to be looked at.
+
+\begin{code}
+tcUnfolding name core_expr
+  = forkNF_Tc (
+	recoverNF_Tc (returnNF_Tc no_unfolding) (
+		tcCoreExpr core_expr	`thenTc` \ core_expr' ->
+		returnTc (mkUnfolding False core_expr')
+    ))			
+  where
+    no_unfolding = pprTrace "tcUnfolding failed:" (ppr PprDebug name) NoUnfolding
+\end{code}
+
+UfCore expressions.
+
+\begin{code}
+tcCoreExpr :: UfExpr Name -> TcM s CoreExpr
+
+tcCoreExpr (UfVar name)
+  = tcLookupGlobalValue name 	`thenNF_Tc` \ id ->
+    returnTc (Var id)
+
+tcCoreExpr (UfLit lit) = returnTc (Lit lit)
+
+tcCoreExpr (UfCon con args) 
+  = tcLookupGlobalValue con	`thenNF_Tc` \ con_id ->
+    mapTc tcCoreArg args	`thenTc` \ args' ->
+    returnTc (Con con_id args')
+
+tcCoreExpr (UfPrim prim args) 
+  = tcCorePrim prim		`thenTc` \ primop ->
+    mapTc tcCoreArg args	`thenTc` \ args' ->
+    returnTc (Prim primop args')
+
+tcCoreExpr (UfApp fun arg)
+  = tcCoreExpr fun		`thenTc` \ fun' ->
+    tcCoreArg arg		`thenTc` \ arg' ->
+    returnTc (App fun' arg')
+
+tcCoreExpr (UfCase scrut alts) 
+  = tcCoreExpr scrut		`thenTc` \ scrut' ->
+    tcCoreAlts alts		`thenTc` \ alts' ->
+    returnTc (Case scrut' alts')
 
-tcInterfaceSigs (Sig name ty pragmas src_loc : sigs)
-  | has_full_name
-  = tcAddSrcLoc src_loc		(
-    tcPolyType ty		`thenTc` \ sigma_ty ->
-    fixTc ( \ rec_id ->
-	tcGenPragmas (Just sigma_ty) rec_id pragmas
-				`thenNF_Tc` \ id_info ->
-        returnTc (mkImported full_name sigma_ty id_info)
-    ))				`thenTc` \ id ->
-    tcInterfaceSigs sigs	`thenTc` \ sigs' ->
-    returnTc (id:sigs')
-
-  | otherwise -- odd name...
-  = case name of
-      WiredInId _ | opt_CompilingGhcInternals
-        -> tcInterfaceSigs sigs
-      _ -> tcAddSrcLoc src_loc	$
-	   failTc (ifaceSigNameErr name)
+tcCoreExpr (UfSCC cc expr) 
+  = tcCoreExpr expr		`thenTc` \ expr' ->
+    returnTc  (SCC cc expr') 
+
+tcCoreExpr(UfCoerce coercion ty body)
+  = tcCoercion coercion		`thenTc` \ coercion' ->
+    tcHsType ty			`thenTc` \ ty' ->
+    tcCoreExpr body		`thenTc` \ body' ->
+    returnTc (Coerce coercion' ty' body')
+
+tcCoreExpr (UfLam bndr body)
+  = tcCoreLamBndr bndr 		$ \ bndr' ->
+    tcCoreExpr body		`thenTc` \ body' ->
+    returnTc (Lam bndr' body')
+
+tcCoreExpr (UfLet (UfNonRec bndr rhs) body)
+  = tcCoreExpr rhs		`thenTc` \ rhs' ->
+    tcCoreValBndr bndr 		$ \ bndr' ->
+    tcCoreExpr body		`thenTc` \ body' ->
+    returnTc (Let (NonRec bndr' rhs') body')
+
+tcCoreExpr (UfLet (UfRec pairs) body)
+  = tcCoreValBndrs bndrs	$ \ bndrs' ->
+    mapTc tcCoreExpr rhss	`thenTc` \ rhss' ->
+    tcCoreExpr body		`thenTc` \ body' ->
+    returnTc (Let (Rec (bndrs' `zip` rhss')) body')
   where
-    has_full_name    = maybeToBool full_name_maybe
-    (Just full_name) = full_name_maybe
-    full_name_maybe  = case name of
-			 RnName     fn	-> Just fn
-			 RnImplicit fn	-> Just fn
-			 _		-> Nothing
-
-ifaceSigNameErr name sty
-  = ppHang (ppStr "Bad name in an interface type signature (a Prelude name?)")
-	 4 (ppr sty name)
+    (bndrs, rhss) = unzip pairs
 \end{code}
+
+\begin{code}
+tcCoreLamBndr (UfValBinder name ty) thing_inside
+  = tcHsType ty			`thenTc` \ ty' ->
+    let
+	id = mkUserId name ty' NoPragmaInfo
+    in
+    tcExtendGlobalValEnv [id] $
+    thing_inside (ValBinder id)
+    
+tcCoreLamBndr (UfTyBinder name kind) thing_inside
+  = let
+	tyvar = mkTyVar name kind
+    in
+    tcExtendTyVarEnv [name] [(kindToTcKind kind, tyvar)] $
+    thing_inside (TyBinder tyvar)
+    
+tcCoreLamBndr (UfUsageBinder name) thing_inside
+  = error "tcCoreLamBndr: usage"
+
+tcCoreValBndr (UfValBinder name ty) thing_inside
+  = tcHsType ty			`thenTc` \ ty' ->
+    let
+	id = mkUserId name ty' NoPragmaInfo
+    in
+    tcExtendGlobalValEnv [id] $
+    thing_inside id
+    
+tcCoreValBndrs bndrs thing_inside		-- Expect them all to be ValBinders
+  = mapTc tcHsType tys			`thenTc` \ tys' ->
+    let
+	ids = zipWithEqual "tcCoreValBndr" mk_id names tys'
+	mk_id name ty' = mkUserId name ty' NoPragmaInfo
+    in
+    tcExtendGlobalValEnv ids $
+    thing_inside ids
+  where
+    names = map (\ (UfValBinder name _) -> name) bndrs
+    tys   = map (\ (UfValBinder _   ty) -> ty)   bndrs
+\end{code}    
+
+\begin{code}
+tcCoreArg (UfVarArg v)	 = tcLookupGlobalValue v  `thenNF_Tc` \ v' -> returnTc (VarArg v')
+tcCoreArg (UfTyArg ty)	 = tcHsType ty		  `thenTc` \ ty' -> returnTc (TyArg ty')
+tcCoreArg (UfLitArg lit) = returnTc (LitArg lit)
+tcCoreArg (UfUsageArg u) = error "tcCoreArg: usage"
+
+tcCoreAlts (UfAlgAlts alts deflt)
+  = mapTc tc_alt alts		`thenTc` \ alts' ->
+    tcCoreDefault deflt		`thenTc` \ deflt' ->
+    returnTc (AlgAlts alts' deflt')
+  where
+    tc_alt (con, bndrs, rhs) =	tcLookupGlobalValue con		`thenNF_Tc` \ con' ->
+				tcCoreValBndrs bndrs		$ \ bndrs' ->
+				tcCoreExpr rhs			`thenTc` \ rhs' ->
+				returnTc (con', bndrs', rhs')
+
+tcCoreAlts (UfPrimAlts alts deflt)
+  = mapTc tc_alt alts		`thenTc` \ alts' ->
+    tcCoreDefault deflt		`thenTc` \ deflt' ->
+    returnTc (PrimAlts alts' deflt')
+  where
+    tc_alt (lit, rhs) =	tcCoreExpr rhs		`thenTc` \ rhs' ->
+			returnTc (lit, rhs')
+
+tcCoreDefault UfNoDefault = returnTc NoDefault
+tcCoreDefault (UfBindDefault bndr rhs) = tcCoreValBndr bndr	$ \ bndr' ->
+					 tcCoreExpr rhs		`thenTc` \ rhs' ->
+				  	 returnTc (BindDefault bndr' rhs')
+
+tcCoercion (UfIn  n) = tcLookupGlobalValue n `thenNF_Tc` \ n' -> returnTc (CoerceIn  n')
+tcCoercion (UfOut n) = tcLookupGlobalValue n `thenNF_Tc` \ n' -> returnTc (CoerceOut n')
+
+tcCorePrim (UfOtherOp op) 
+  = tcLookupGlobalValue op	`thenNF_Tc` \ op_id ->
+    case isPrimitiveId_maybe op_id of
+	Just prim_op -> returnTc prim_op
+	Nothing	     -> pprPanic "tcCorePrim" (ppr PprDebug op_id)
+
+tcCorePrim (UfCCallOp str casm gc arg_tys res_ty)
+  = mapTc tcHsType arg_tys	`thenTc` \ arg_tys' ->
+    tcHsType res_ty		`thenTc` \ res_ty' ->
+    returnTc (CCallOp str casm gc arg_tys' res_ty')
+\end{code}
+
diff --git a/ghc/compiler/typecheck/TcInstDcls.lhs b/ghc/compiler/typecheck/TcInstDcls.lhs
index 5194f9ec7d..030ab8079b 100644
--- a/ghc/compiler/typecheck/TcInstDcls.lhs
+++ b/ghc/compiler/typecheck/TcInstDcls.lhs
@@ -15,16 +15,16 @@ module TcInstDcls (
 
 IMP_Ubiq()
 
-import HsSyn		( InstDecl(..), FixityDecl, Sig(..),
+import HsSyn		( HsDecl(..), InstDecl(..), TyDecl, ClassDecl, DefaultDecl,
+			  FixityDecl, IfaceSig, Sig(..),
 			  SpecInstSig(..), HsBinds(..), Bind(..),
 			  MonoBinds(..), GRHSsAndBinds, Match, 
 			  InPat(..), OutPat(..), HsExpr(..), HsLit(..),
 			  Stmt, Qualifier, ArithSeqInfo, Fake,
-			  PolyType(..), MonoType )
+			  HsType(..), HsTyVar )
 import RnHsSyn		( SYN_IE(RenamedHsBinds), SYN_IE(RenamedMonoBinds),
-			  RenamedInstDecl(..), RenamedFixityDecl(..),
-			  RenamedSig(..), RenamedSpecInstSig(..),
-			  RnName(..){-incl instance Outputable-}
+			  SYN_IE(RenamedInstDecl), SYN_IE(RenamedFixityDecl),
+			  SYN_IE(RenamedSig), SYN_IE(RenamedSpecInstSig), SYN_IE(RenamedHsDecl)
 			)
 import TcHsSyn		( TcIdOcc(..), SYN_IE(TcHsBinds),
 			  SYN_IE(TcMonoBinds), SYN_IE(TcExpr), tcIdType,
@@ -32,19 +32,20 @@ import TcHsSyn		( TcIdOcc(..), SYN_IE(TcHsBinds),
 			  mkHsDictLam, mkHsDictApp )
 
 
-import TcMonad		hiding ( rnMtoTcM )
+import TcMonad
+import RnMonad		( SYN_IE(RnNameSupply) )
 import GenSpecEtc	( checkSigTyVars )
 import Inst		( Inst, InstOrigin(..), SYN_IE(InstanceMapper),
 			  newDicts, newMethod, SYN_IE(LIE), emptyLIE, plusLIE )
 import TcBinds		( tcPragmaSigs )
 import TcDeriv		( tcDeriving )
-import TcEnv		( tcLookupClass, tcTyVarScope, newLocalId, tcExtendGlobalTyVars )
+import TcEnv		( tcLookupClass, newLocalId, tcExtendGlobalTyVars )
 import SpecEnv		( SpecEnv )
 import TcGRHSs		( tcGRHSsAndBinds )
 import TcInstUtil	( InstInfo(..), mkInstanceRelatedIds, buildInstanceEnvs )
 import TcKind		( TcKind, unifyKind )
 import TcMatches	( tcMatchesFun )
-import TcMonoType	( tcContext, tcMonoTypeKind )
+import TcMonoType	( tcTyVarScope, tcContext, tcHsTypeKind )
 import TcSimplify	( tcSimplifyAndCheck )
 import TcType		( SYN_IE(TcType), SYN_IE(TcTyVar), SYN_IE(TcTyVarSet), 
 			  tcInstSigTyVars, tcInstType, tcInstTheta, tcInstTcType
@@ -59,31 +60,32 @@ import CmdLineOpts	( opt_GlasgowExts, opt_CompilingGhcInternals,
 			  opt_SpecialiseOverloaded
 			)
 import Class		( GenClass, GenClassOp, 
-			  isCcallishClass, classBigSig,
-			  classOps, classOpLocalType,
-			  classOpTagByString_maybe
+			  classBigSig, classOps, classOpLocalType,
+			  classOpTagByOccName_maybe
 			  )
-import Id		( GenId, idType, isDefaultMethodId_maybe )
+import Id		( GenId, idType, isDefaultMethodId_maybe, isNullaryDataCon, dataConArgTys )
+import PrelInfo		( isCcallishClass )
 import ListSetOps	( minusList )
 import Maybes 		( maybeToBool, expectJust )
-import Name		( getLocalName, origName, nameOf, Name{--O only-} )
+import Name		( getOccString, occNameString, moduleString, isLocallyDefined, OccName, Name{--O only-} )
 import PrelVals		( nO_EXPLICIT_METHOD_ERROR_ID )
-import PrelMods		( pRELUDE )
 import PprType		( GenType, GenTyVar, GenClass, GenClassOp, TyCon,
 			  pprParendGenType
 			)
 import PprStyle
+import SrcLoc		( SrcLoc )
 import Pretty
-import RnUtils		( SYN_IE(RnEnv) )
 import TyCon		( isSynTyCon, derivedFor )
 import Type		( GenType(..), SYN_IE(ThetaType), mkTyVarTys,
 			  splitSigmaTy, splitAppTy, isTyVarTy, matchTy, mkSigmaTy,
-			  getTyCon_maybe, maybeBoxedPrimType, splitRhoTy, eqTy
+			  getTyCon_maybe, maybeAppTyCon,
+			  maybeBoxedPrimType, maybeAppDataTyCon, splitRhoTy, eqTy
 			)
 import TyVar		( GenTyVar, SYN_IE(GenTyVarSet), mkTyVarSet, unionTyVarSets )
+import TysPrim		( byteArrayPrimTyCon, mutableByteArrayPrimTyCon )
 import TysWiredIn	( stringTy )
-import Unique		( Unique )
-import Util		( zipEqual, panic )
+import Unique		( Unique, cCallableClassKey, cReturnableClassKey )
+import Util		( zipEqual, panic, pprPanic, pprTrace )
 \end{code}
 
 Typechecking instance declarations is done in two passes. The first
@@ -160,98 +162,70 @@ and $dbinds_super$ bind the superclass dictionaries sd1 \ldots sdm.
 \end{enumerate}
 
 \begin{code}
-tcInstDecls1 :: Bag RenamedInstDecl
-	     -> [RenamedSpecInstSig]
+tcInstDecls1 :: [RenamedHsDecl]
 	     -> Module			-- module name for deriving
-	     -> RnEnv			-- for renaming derivings
-	     -> [RenamedFixityDecl]	-- fixities for deriving
+	     -> RnNameSupply			-- for renaming derivings
 	     -> TcM s (Bag InstInfo,
 		       RenamedHsBinds,
 		       PprStyle -> Pretty)
 
-tcInstDecls1 inst_decls specinst_sigs mod_name rn_env fixities
+tcInstDecls1 decls mod_name rn_name_supply
   = 	-- Do the ordinary instance declarations
-    mapBagNF_Tc (tcInstDecl1 mod_name) inst_decls
-			`thenNF_Tc` \ inst_info_bags ->
+    mapNF_Tc (tcInstDecl1 mod_name) 
+	     [inst_decl | InstD inst_decl <- decls]	`thenNF_Tc` \ inst_info_bags ->
     let
-	decl_inst_info = concatBag inst_info_bags
+	decl_inst_info = unionManyBags inst_info_bags
     in
 	-- Handle "derived" instances; note that we only do derivings
 	-- for things in this module; we ignore deriving decls from
 	-- interfaces! We pass fixities, because they may be used
 	-- in deriving Read and Show.
-    tcDeriving mod_name rn_env decl_inst_info fixities
+    tcDeriving mod_name rn_name_supply decl_inst_info
 		    	`thenTc` \ (deriv_inst_info, deriv_binds, ddump_deriv) ->
 
     let
-	inst_info = deriv_inst_info `unionBags` decl_inst_info
-    in
-{- LATER
-	-- Handle specialise instance pragmas
-    tcSpecInstSigs inst_info specinst_sigs
-			`thenTc` \ spec_inst_info ->
--}
-    let
-	spec_inst_info = emptyBag	-- For now
-
-	full_inst_info = inst_info `unionBags` spec_inst_info
+	full_inst_info = deriv_inst_info `unionBags` decl_inst_info
     in
     returnTc (full_inst_info, deriv_binds, ddump_deriv)
 
 
-tcInstDecl1 :: FAST_STRING -> RenamedInstDecl -> NF_TcM s (Bag InstInfo)
+tcInstDecl1 :: Module -> RenamedInstDecl -> NF_TcM s (Bag InstInfo)
 
-tcInstDecl1 mod_name
-	    (InstDecl class_name
-		      poly_ty@(HsForAllTy tyvar_names context inst_ty)
-		      binds
-		      from_here inst_mod uprags pragmas src_loc)
+tcInstDecl1 mod_name (InstDecl poly_ty binds uprags (Just dfun_name) src_loc)
   = 	-- Prime error recovery, set source location
     recoverNF_Tc (returnNF_Tc emptyBag)	$
     tcAddSrcLoc src_loc			$
 
 	-- Look things up
-    tcLookupClass class_name		`thenNF_Tc` \ (clas_kind, clas) ->
+    tcLookupClass class_name		`thenTc` \ (clas_kind, clas) ->
 
-    let
-	de_rn (RnName n) = n
-    in
 	-- Typecheck the context and instance type
-    tcTyVarScope (map de_rn tyvar_names) (\ tyvars ->
+    tcTyVarScope tyvar_names (\ tyvars ->
 	tcContext context		`thenTc` \ theta ->
-	tcMonoTypeKind inst_ty		`thenTc` \ (tau_kind, tau) ->
+	tcHsTypeKind inst_ty		`thenTc` \ (tau_kind, tau) ->
 	unifyKind clas_kind tau_kind	`thenTc_`
 	returnTc (tyvars, theta, tau)
     )					`thenTc` \ (inst_tyvars, inst_theta, inst_tau) ->
 
 	-- Check for respectable instance type
-    scrutiniseInstanceType from_here clas inst_tau
+    scrutiniseInstanceType dfun_name clas inst_tau
 					`thenTc` \ (inst_tycon,arg_tys) ->
 
-	-- Deal with the case where we are deriving
-	-- and importing the same instance
-    if (not from_here && (clas `derivedFor` inst_tycon)
-	              && all isTyVarTy arg_tys)
-    then
-	if mod_name == inst_mod
- 	then
-		-- Imported instance came from this module;
-		-- discard and derive fresh instance
-	    returnTc emptyBag		
-	else
-		-- Imported instance declared in another module;
-		-- report duplicate instance error
-	    failTc (derivingWhenInstanceImportedErr inst_mod clas inst_tycon)
-    else
-
 	-- Make the dfun id and constant-method ids
-    mkInstanceRelatedIds from_here src_loc inst_mod pragmas
-		         clas inst_tyvars inst_tau inst_theta uprags
-					`thenTc` \ (dfun_id, dfun_theta, const_meth_ids) ->
+    mkInstanceRelatedIds dfun_name
+		         clas inst_tyvars inst_tau inst_theta
+					`thenNF_Tc` \ (dfun_id, dfun_theta) ->
 
     returnTc (unitBag (InstInfo clas inst_tyvars inst_tau inst_theta	
-				dfun_theta dfun_id const_meth_ids
-			     	binds from_here inst_mod src_loc uprags))
+				dfun_theta dfun_id
+			     	binds src_loc uprags))
+  where
+    (tyvar_names, context, dict_ty) = case poly_ty of
+					HsForAllTy tvs cxt dict_ty -> (tvs, cxt, dict_ty)
+					other			   -> ([],  [],  poly_ty)
+    (class_name, inst_ty) = case dict_ty of
+				MonoDictTy cls ty -> (cls,ty)
+				other -> pprPanic "Malformed intance decl" (ppr PprDebug poly_ty)
 \end{code}
 
 
@@ -345,13 +319,14 @@ First comes the easy case of a non-local instance decl.
 tcInstDecl2 :: InstInfo
 	    -> NF_TcM s (LIE s, TcHsBinds s)
 
-tcInstDecl2 (InstInfo _ _ _ _ _ _ _ _ False{-import-} _ _ _)
-  = returnNF_Tc (emptyLIE, EmptyBinds)
-
 tcInstDecl2 (InstInfo clas inst_tyvars inst_ty
 		      inst_decl_theta dfun_theta
-		      dfun_id const_meth_ids monobinds
-		      True{-here-} inst_mod locn uprags)
+		      dfun_id monobinds
+		      locn uprags)
+  | not (isLocallyDefined dfun_id)
+  = returnNF_Tc (emptyLIE, EmptyBinds)
+
+  | otherwise
   =	 -- Prime error recovery
     recoverNF_Tc (returnNF_Tc (emptyLIE, EmptyBinds)) 	$
     tcAddSrcLoc locn					$
@@ -388,10 +363,7 @@ tcInstDecl2 (InstInfo clas inst_tyvars inst_ty
 	  = unionManyBags (this_dict : dfun_arg_dicts : meth_insts_s) 
 
 	mk_method_expr
-	  = if opt_OmitDefaultInstanceMethods then
-		makeInstanceDeclNoDefaultExpr     origin meth_ids defm_ids inst_ty' clas inst_mod
-	    else
-		makeInstanceDeclDefaultMethodExpr origin meth_ids defm_ids inst_ty' this_dict_id 
+	  = makeInstanceDeclDefaultMethodExpr locn clas meth_ids defm_ids inst_ty' this_dict_id 
     in
     tcExtendGlobalTyVars inst_tyvars_set' (
 	processInstBinds clas mk_method_expr avail_insts meth_ids monobinds
@@ -437,9 +409,7 @@ tcInstDecl2 (InstInfo clas inst_tyvars inst_ty
 	  = AbsBinds
 		 inst_tyvars'
 		 dfun_arg_dicts_ids
-		 ((this_dict_id, RealId dfun_id) 
-		  : (meth_ids `zip` map RealId const_meth_ids))
-			-- NB: const_meth_ids will often be empty
+		 [(this_dict_id, RealId dfun_id)] 
 		 super_binds
 		 (RecBind dict_and_method_binds)
 
@@ -457,7 +427,8 @@ See the notes under default decls in TcClassDcl.lhs.
 
 \begin{code}
 makeInstanceDeclDefaultMethodExpr
-	:: InstOrigin s
+	:: SrcLoc
+	-> Class
 	-> [TcIdOcc s]
 	-> [Id]
 	-> TcType s
@@ -465,50 +436,33 @@ makeInstanceDeclDefaultMethodExpr
 	-> Int
 	-> NF_TcM s (TcExpr s)
 
-makeInstanceDeclDefaultMethodExpr origin meth_ids defm_ids inst_ty this_dict tag
-  =
-	-- def_op_id = defm_id inst_ty this_dict
+makeInstanceDeclDefaultMethodExpr src_loc clas meth_ids defm_ids inst_ty this_dict tag
+  | not defm_is_err		-- Not sure that the default method is just error message
+  = 	-- def_op_id = defm_id inst_ty this_dict
     returnNF_Tc (mkHsDictApp (mkHsTyApp (HsVar (RealId defm_id)) [inst_ty]) [this_dict])
- where
-    idx	    = tag - 1
-    meth_id = meth_ids !! idx
-    defm_id = defm_ids  !! idx
-
-makeInstanceDeclNoDefaultExpr
-	:: InstOrigin s
-	-> [TcIdOcc s]
-	-> [Id]
-	-> TcType s
-	-> Class
-	-> Module
-	-> Int
-	-> NF_TcM s (TcExpr s)
 
-makeInstanceDeclNoDefaultExpr origin meth_ids defm_ids inst_ty clas inst_mod tag
-  = 
-	-- Produce a warning if the default instance method
-	-- has been omitted when one exists in the class
-    warnTc (not err_defm_ok)
-	   (omitDefaultMethodWarn clas_op clas_name inst_ty)
+  | otherwise		-- There's definitely no default decl in the class,
+			-- so we produce a warning, and a better run=time error message too
+  = warnTc True (omitDefaultMethodWarn clas_op clas_name inst_ty)
 					`thenNF_Tc_`
+
     returnNF_Tc (HsApp (mkHsTyApp (HsVar (RealId nO_EXPLICIT_METHOD_ERROR_ID)) [tcIdType meth_id])
 		       (HsLitOut (HsString (_PK_ error_msg)) stringTy))
   where
     idx	    = tag - 1
-    meth_id = meth_ids  !! idx
-    clas_op = (classOps clas) !! idx
+    meth_id = meth_ids !! idx
     defm_id = defm_ids  !! idx
 
-    Just (_, _, err_defm_ok) = isDefaultMethodId_maybe defm_id
+    Just (_, _, defm_is_err) = isDefaultMethodId_maybe defm_id
 
-    error_msg = _UNPK_ inst_mod ++ "." ++ _UNPK_ clas_name ++ "."
-	     	++ (ppShow 80 (ppr PprForUser inst_ty)) ++ "."
-	     	++ (ppShow 80 (ppr PprForUser clas_op))	++ "\""
+    error_msg = ppShow 80 (ppSep [ppr PprForUser clas_op, ppStr "at", ppr PprForUser src_loc])
 
-    clas_name = nameOf (origName "makeInstanceDeclNoDefaultExpr" clas)
+    clas_op = (classOps clas) !! idx
+    clas_name = getOccString clas
 \end{code}
 
 
+
 %************************************************************************
 %*									*
 \subsection{Processing each method}
@@ -595,14 +549,14 @@ processInstBinds1 clas avail_insts method_ids mbind
 		      FunMonoBind op _ _ locn	       -> (op, locn)
 		      PatMonoBind (VarPatIn op) _ locn -> (op, locn)
 
-        occ    = getLocalName op
-	origin = InstanceDeclOrigin
+        occ     = getOccName op
+	origin  = InstanceDeclOrigin
     in
     tcAddSrcLoc locn			 $
 
     -- Make a method id for the method
     let
-	maybe_tag  = classOpTagByString_maybe clas occ
+	maybe_tag  = classOpTagByOccName_maybe clas occ
 	(Just tag) = maybe_tag
 	method_id  = method_ids !! (tag-1)
 	method_ty  = tcIdType method_id
@@ -640,10 +594,12 @@ processInstBinds1 clas avail_insts method_ids mbind
 	newLocalId occ method_tau		`thenNF_Tc` \ local_id ->
 	newLocalId occ method_ty		`thenNF_Tc` \ copy_id ->
 	let
+	    tc_local_id = TcId local_id
+	    tc_copy_id  = TcId copy_id
 	    sig_tyvar_set = mkTyVarSet sig_tyvars
 	in
 		-- Typecheck the method
-	tcMethodBind local_id method_tau mbind `thenTc` \ (mbind', lieIop) ->
+	tcMethodBind tc_local_id method_tau mbind `thenTc` \ (mbind', lieIop) ->
 
 		-- Check the overloading part of the signature.
 
@@ -680,10 +636,10 @@ processInstBinds1 clas avail_insts method_ids mbind
 			     (AbsBinds
 				method_tyvars
 				method_dict_ids
-				[(local_id, copy_id)]
+				[(tc_local_id, tc_copy_id)]
 				dict_binds
 				(NonRecBind mbind'))
-			     (HsVar copy_id)))
+			     (HsVar tc_copy_id)))
 \end{code}
 
 \begin{code}
@@ -744,7 +700,7 @@ tcSpecInstSig e ce tce inst_infos inst_mapper (SpecInstSig class_name ty src_loc
 	clas = lookupCE ce class_name -- Renamer ensures this can't fail
 
 	-- Make some new type variables, named as in the specialised instance type
-	ty_names 			  = extractMonoTyNames ???is_tyvarish_name??? ty
+	ty_names 			  = extractHsTyNames ???is_tyvarish_name??? ty
 	(tmpl_e,inst_tmpls,inst_tmpl_tys) = mkTVE ty_names
     in
     babyTcMtoTcM (tcInstanceType ce tce tmpl_e True src_loc ty)
@@ -764,7 +720,7 @@ tcSpecInstSig e ce tce inst_infos inst_mapper (SpecInstSig class_name ty src_loc
     copyTyVars inst_tmpls	`thenNF_Tc` \ (tv_e, inst_tvs, inst_tv_tys) ->
     let
 	Just (InstInfo _ unspec_tyvars unspec_inst_ty unspec_theta
-		       _ _ _ binds True{-from here-} mod _ uprag) = maybe_unspec_inst
+		       _ _ binds _ uprag) = maybe_unspec_inst
 
     	subst = case matchTy unspec_inst_ty inst_ty of
 		     Just subst -> subst
@@ -787,9 +743,9 @@ tcSpecInstSig e ce tce inst_infos inst_mapper (SpecInstSig class_name ty src_loc
 	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-} src_loc mod NoInstancePragmas 
+    mkInstanceRelatedIds 
 			 clas inst_tmpls inst_ty simpl_theta uprag
-				`thenTc` \ (dfun_id, dfun_theta, const_meth_ids) ->
+				`thenNF_Tc` \ (dfun_id, dfun_theta, const_meth_ids) ->
 
     getSwitchCheckerTc		`thenNF_Tc` \ sw_chkr ->
     (if sw_chkr SpecialiseTrace then
@@ -806,8 +762,8 @@ tcSpecInstSig e ce tce inst_infos inst_mapper (SpecInstSig class_name ty src_loc
     else id) (
 
     returnTc (unitBag (InstInfo clas inst_tmpls inst_ty simpl_theta
-				dfun_theta dfun_id const_meth_ids
-				binds True{-from here-} mod src_loc uprag))
+				dfun_theta dfun_id
+				binds src_loc uprag))
     )))
 
 
@@ -853,13 +809,13 @@ compiled elsewhere). In these cases, we let them go through anyway.
 We can also have instances for functions: @instance Foo (a -> b) ...@.
 
 \begin{code}
-scrutiniseInstanceType from_here clas inst_tau
+scrutiniseInstanceType dfun_name clas inst_tau
 	-- TYCON CHECK
   | not (maybeToBool inst_tycon_maybe) || isSynTyCon inst_tycon
   = failTc (instTypeErr inst_tau)
 
   	-- IMPORTED INSTANCES ARE OK (but see tcInstDecl1)
-  | not from_here
+  | not (isLocallyDefined dfun_name)
   = returnTc (inst_tycon,arg_tys)
 
 	-- TYVARS CHECK
@@ -879,10 +835,8 @@ scrutiniseInstanceType from_here clas inst_tau
   |	-- CCALL CHECK
 	-- A user declaration of a CCallable/CReturnable instance
 	-- must be for a "boxed primitive" type.
-    isCcallishClass clas
-    && not (maybeToBool (maybeBoxedPrimType inst_tau)
-	    || opt_CompilingGhcInternals) -- this lets us get up to mischief;
-				     -- e.g., instance CCallable ()
+    (uniqueOf clas == cCallableClassKey   && not (ccallable_type   inst_tau)) ||
+    (uniqueOf clas == cReturnableClassKey && not (creturnable_type inst_tau))
   = failTc (nonBoxedPrimCCallErr clas inst_tau)
 
   | otherwise
@@ -892,6 +846,38 @@ scrutiniseInstanceType from_here clas inst_tau
     (possible_tycon, arg_tys) = splitAppTy inst_tau
     inst_tycon_maybe	      = getTyCon_maybe possible_tycon
     inst_tycon 		      = expectJust "tcInstDecls1:inst_tycon" inst_tycon_maybe
+
+-- These conditions come directly from what the DsCCall is capable of.
+-- Totally grotesque.  Green card should solve this.
+
+ccallable_type   ty = maybeToBool (maybeBoxedPrimType ty) ||
+		      ty `eqTy` stringTy ||
+		      byte_arr_thing
+  where
+    byte_arr_thing = case maybeAppDataTyCon ty of
+			Just (tycon, ty_args, [data_con]) -> 
+--			 	pprTrace "cc1" (ppSep [ppr PprDebug tycon, ppr PprDebug data_con,
+--						       ppSep (map (ppr PprDebug) data_con_arg_tys)])(
+		     		length data_con_arg_tys == 2 &&
+				maybeToBool maybe_arg2_tycon &&
+--			 	pprTrace "cc2" (ppSep [ppr PprDebug arg2_tycon]) (
+				(arg2_tycon == byteArrayPrimTyCon ||
+				 arg2_tycon == mutableByteArrayPrimTyCon)
+--				))
+			     where
+				data_con_arg_tys = dataConArgTys data_con ty_args
+				(data_con_arg_ty1 : data_con_arg_ty2 : _) = data_con_arg_tys
+				maybe_arg2_tycon = maybeAppTyCon data_con_arg_ty2
+				Just (arg2_tycon,_) = maybe_arg2_tycon
+
+			other -> False
+
+creturnable_type ty = maybeToBool (maybeBoxedPrimType ty) ||
+			-- Or, a data type with a single nullary constructor
+		      case (maybeAppDataTyCon ty) of
+			Just (tycon, tys_applied, [data_con])
+				-> isNullaryDataCon data_con
+			other -> False
 \end{code}
 
 \begin{code}
@@ -915,19 +901,19 @@ derivingWhenInstanceImportedErr inst_mod clas tycon sty
     pp_mod = ppBesides [ppStr "module `", ppPStr inst_mod, ppStr "'"]
 
 nonBoxedPrimCCallErr clas inst_ty sty
-  = ppHang (ppStr "Instance isn't for a `boxed-primitive' type")
+  = ppHang (ppStr "Unacceptable instance type for ccall-ish class")
 	 4 (ppBesides [ ppStr "class `", ppr sty clas, ppStr "' type `",
     		        ppr sty inst_ty, ppStr "'"])
 
 omitDefaultMethodWarn clas_op clas_name inst_ty sty
   = ppCat [ppStr "Warning: Omitted default method for",
 	   ppr sty clas_op, ppStr "in instance",
-	   ppPStr clas_name, pprParendGenType sty inst_ty]
+	   ppStr clas_name, pprParendGenType sty inst_ty]
 
 instMethodNotInClassErr occ clas sty
   = ppHang (ppStr "Instance mentions a method not in the class")
 	 4 (ppBesides [ppStr "class `", ppr sty clas, ppStr "' method `",
-    		       ppPStr occ, ppStr "'"])
+    		       ppr sty occ, ppStr "'"])
 
 patMonoBindsCtxt pbind sty
   = ppHang (ppStr "In a pattern binding:")
diff --git a/ghc/compiler/typecheck/TcInstUtil.lhs b/ghc/compiler/typecheck/TcInstUtil.lhs
index 9af279fc42..f43b4cd530 100644
--- a/ghc/compiler/typecheck/TcInstUtil.lhs
+++ b/ghc/compiler/typecheck/TcInstUtil.lhs
@@ -20,7 +20,8 @@ import HsSyn		( MonoBinds, Fake, InPat, Sig )
 import RnHsSyn		( SYN_IE(RenamedMonoBinds), RenamedSig(..), 
 			  RenamedInstancePragmas(..) )
 
-import TcMonad		hiding ( rnMtoTcM )
+import TcEnv		( tcLookupGlobalValueMaybe )
+import TcMonad
 import Inst		( SYN_IE(InstanceMapper) )
 
 import Bag		( bagToList )
@@ -29,7 +30,7 @@ import Class		( GenClass, GenClassOp, SYN_IE(ClassInstEnv),
 			  SYN_IE(ClassOp)
 			)
 import CoreSyn		( GenCoreExpr(..), mkValLam, mkTyApp )
-import Id		( GenId, mkDictFunId, mkConstMethodId, mkSysLocal )
+import Id		( GenId, mkDictFunId, mkConstMethodId, mkSysLocal, replaceIdInfo, getIdInfo )
 import MatchEnv		( nullMEnv, insertMEnv )
 import Maybes		( MaybeErr(..), mkLookupFunDef )
 import Name		( getSrcLoc, Name{--O only-} )
@@ -63,10 +64,7 @@ data InstInfo
 			--   element for each superclass; the "Mark
 			--   Jones optimisation"
       Id		-- The dfun id
-      [Id]		-- Constant methods (either all or none)
       RenamedMonoBinds	-- Bindings, b
-      Bool		-- True <=> local instance decl
-      Module		-- Name of module where this instance defined
       SrcLoc		-- Source location assoc'd with this instance's defn
       [RenamedSig]	-- User pragmas recorded for generating specialised instances
 \end{code}
@@ -78,22 +76,30 @@ data InstInfo
 %************************************************************************
 
 \begin{code}
-mkInstanceRelatedIds :: Bool
-		     -> SrcLoc
-		     -> Module
-                     -> RenamedInstancePragmas
+mkInstanceRelatedIds :: Name		-- Name to use for the dict fun;
 		     -> Class 
 		     -> [TyVar]
 		     -> Type
 		     -> ThetaType
-		     -> [RenamedSig]
-		     -> TcM s (Id, ThetaType, [Id])
+		     -> NF_TcM s (Id, ThetaType)
 
-mkInstanceRelatedIds from_here src_loc inst_mod inst_pragmas
-		     clas inst_tyvars inst_ty inst_decl_theta uprags
-  = 	-- MAKE THE DFUN ID
+mkInstanceRelatedIds dfun_name clas inst_tyvars inst_ty inst_decl_theta
+  = tcLookupGlobalValueMaybe dfun_name	`thenNF_Tc` \ maybe_id ->
     let
-	dfun_theta = case inst_decl_theta of
+	-- Extract the dfun's IdInfo from the interface file,
+	-- provided it's imported.
+	-- We have to be lazy here; people look at the dfun Id itself
+	dfun_info = case maybe_id of
+			Nothing		      -> noIdInfo
+			Just imported_dfun_id -> getIdInfo imported_dfun_id
+    in
+    returnNF_Tc (new_dfun_id `replaceIdInfo` dfun_info, dfun_theta)
+
+  where
+    (_, super_classes, _, _, _, _) = classBigSig clas
+    super_class_theta = super_classes `zip` repeat inst_ty
+
+    dfun_theta = case inst_decl_theta of
 			[]    -> []	-- If inst_decl_theta is empty, then we don't
 					-- want to have any dict arguments, so that we can
 					-- expose the constant methods.
@@ -102,73 +108,9 @@ mkInstanceRelatedIds from_here src_loc inst_mod inst_pragmas
 					-- Otherwise we pass the superclass dictionaries to
 					-- the dictionary function; the Mark Jones optimisation.
 
-	dfun_ty = mkSigmaTy inst_tyvars dfun_theta (mkDictTy clas inst_ty)
-    in
-    tcGetUnique 			`thenNF_Tc` \ dfun_uniq ->
-    fixTc ( \ rec_dfun_id ->
-
-{- LATER
-	tcDictFunPragmas dfun_ty rec_dfun_id inst_pragmas
-					`thenNF_Tc` \ dfun_pragma_info ->
-	let
-	    dfun_specenv = mkInstSpecEnv clas inst_ty inst_tyvars dfun_theta
-	    dfun_id_info = dfun_pragma_info `addInfo` dfun_specenv
-	in
--}
-	let dfun_id_info = noIdInfo in	-- For now
-
-	returnTc (mkDictFunId dfun_uniq clas inst_ty dfun_ty from_here src_loc inst_mod dfun_id_info)
-    ) `thenTc` \ dfun_id ->
-
---  pprTrace "DFUN: " (ppr PprDebug dfun_id) $
-
-	-- MAKE THE CONSTANT-METHOD IDS
-	-- if there are no type variables involved
-    (if (null inst_decl_theta)
-     then
-	mapTc mk_const_meth_id class_ops
-     else
-	returnTc []
-    )					`thenTc` \ const_meth_ids ->
-
-    returnTc (dfun_id, dfun_theta, const_meth_ids)
-  where
-    (class_tyvar, super_classes, _, class_ops, _, _) = classBigSig clas
-    tenv = [(class_tyvar, inst_ty)]
-  
-    super_class_theta = super_classes `zip` repeat inst_ty
+    dfun_ty = mkSigmaTy inst_tyvars dfun_theta (mkDictTy clas inst_ty)
 
-    mk_const_meth_id op
-	= tcGetUnique		`thenNF_Tc` \ uniq ->
-	  fixTc (\ rec_const_meth_id ->
-
-{- LATER
-		-- Figure out the IdInfo from the pragmas
-	     (case assocMaybe opname_prag_pairs (getName op) of
-		Nothing   -> returnTc inline_info
-		Just prag -> tcGenPragmas (Just meth_ty) rec_const_meth_id prag
-	     )			`thenNF_Tc` \ id_info ->
--}
-	     let id_info = noIdInfo 	-- For now
-	     in
-	     returnTc (mkConstMethodId uniq clas op inst_ty meth_ty
-				       from_here src_loc inst_mod id_info)
-	  )
-	where
-	  op_ty       = classOpLocalType op
-	  meth_ty     = mkForAllTys inst_tyvars (instantiateTy tenv op_ty)
-{- LATER
-	  inline_me   = isIn "mkInstanceRelatedIds" op ops_to_inline
-	  inline_info = if inline_me
-			then noIdInfo `addInfo_UF` (iWantToBeINLINEd UnfoldAlways)
-			else noIdInfo
-
-    opname_prag_pairs = case inst_pragmas of
-			   ConstantInstancePragma _ name_prag_pairs -> name_prag_pairs
-			   other_inst_pragmas			    -> []
-
-    ops_to_inline = [op | (InlineSig op _) <- uprags]
--}
+    new_dfun_id = mkDictFunId dfun_name dfun_ty clas inst_ty
 \end{code}
 
 
@@ -185,7 +127,7 @@ buildInstanceEnvs :: Bag InstInfo
 buildInstanceEnvs info
   = let
     	icmp :: InstInfo -> InstInfo -> TAG_
-    	(InstInfo c1 _ _ _ _ _ _ _ _ _ _ _) `icmp` (InstInfo c2 _ _ _ _ _ _ _ _ _ _ _)
+    	(InstInfo c1 _ _ _ _ _ _ _ _) `icmp` (InstInfo c2 _ _ _ _ _ _ _ _)
 	  = c1 `cmp` c2
 
 	info_by_class = equivClasses icmp (bagToList info)
@@ -202,7 +144,7 @@ buildInstanceEnvs info
 buildInstanceEnv :: [InstInfo]		-- Non-empty, and all for same class
 		 -> TcM s (Class, (ClassInstEnv, (ClassOp -> SpecEnv)))
 
-buildInstanceEnv inst_infos@((InstInfo clas _ _ _ _ _ _ _ _ _ _ _) : _)
+buildInstanceEnv inst_infos@((InstInfo clas _ _ _ _ _ _ _ _) : _)
   = foldlTc addClassInstance
 	    (nullMEnv, [(op, nullSpecEnv) | op <- classOps clas])
 	    inst_infos
@@ -223,9 +165,9 @@ addClassInstance
     -> TcM s (ClassInstEnv, [(ClassOp,SpecEnv)])
 
 addClassInstance
-    (class_inst_env, op_spec_envs)
+    input_stuff@(class_inst_env, op_spec_envs)
     (InstInfo clas inst_tyvars inst_ty _ _ 
-	      dfun_id const_meth_ids _ _ _ src_loc _)
+	      dfun_id _ src_loc _)
   = 
 
 -- We only add specialised/overlapped instances
@@ -240,10 +182,15 @@ 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')    -> dupInstFailure clas (inst_ty, src_loc) 
+	Failed (ty', dfun_id')    -> recoverTc (returnTc input_stuff) $
+				     dupInstFailure clas (inst_ty, src_loc) 
 							 (ty', getSrcLoc dfun_id');
 	Succeeded class_inst_env' -> 
 
+	    returnTc (class_inst_env', op_spec_envs)
+
+{- 		OLD STUFF FOR CONSTANT METHODS 
+
 	-- If there are any constant methods, then add them to 
 	-- the SpecEnv of each class op (ie selector)
 	--
@@ -283,6 +230,8 @@ addClassInstance
 	  rhs = mkValLam [dict] (mkTyApp (Var meth_id) (mkTyVarTys inst_tyvars))
     in
     returnTc (class_inst_env', op_spec_envs')
+		END OF OLD STUFF -}
+
     }
 \end{code}
 
diff --git a/ghc/compiler/typecheck/TcKind.lhs b/ghc/compiler/typecheck/TcKind.lhs
index 5f669078ad..f284526f93 100644
--- a/ghc/compiler/typecheck/TcKind.lhs
+++ b/ghc/compiler/typecheck/TcKind.lhs
@@ -19,7 +19,7 @@ module TcKind (
 IMP_Ubiq(){-uitous-}
 
 import Kind
-import TcMonad	hiding ( rnMtoTcM )
+import TcMonad
 
 import Unique	( Unique, pprUnique10 )
 import Pretty
diff --git a/ghc/compiler/typecheck/TcLoop.lhi b/ghc/compiler/typecheck/TcLoop.lhi
index 452dc7af8a..bdf0d5df6b 100644
--- a/ghc/compiler/typecheck/TcLoop.lhi
+++ b/ghc/compiler/typecheck/TcLoop.lhi
@@ -9,10 +9,10 @@ import HsMatches(GRHSsAndBinds)
 import HsPat(InPat, OutPat)
 import HsSyn(Fake)
 import TcHsSyn(TcIdOcc)
-import RnHsSyn(RnName)
 import TcType(TcMaybe)
 import SST(FSST_R)
 import Unique(Unique)
+import Name(Name)
 import TyVar(GenTyVar)
 import TcEnv(TcEnv)
 import TcMonad(TcDown)
@@ -21,7 +21,7 @@ import Bag(Bag)
 import Type(GenType)
 import Inst(Inst)
 
-tcGRHSsAndBinds :: GRHSsAndBinds Fake Fake RnName (InPat RnName) 
+tcGRHSsAndBinds :: GRHSsAndBinds Fake Fake Name (InPat Name) 
 	        -> TcDown a 
 		-> TcEnv a 
 		-> State# a 
diff --git a/ghc/compiler/typecheck/TcMatches.lhs b/ghc/compiler/typecheck/TcMatches.lhs
index 1eba8210bd..8a7d52053e 100644
--- a/ghc/compiler/typecheck/TcMatches.lhs
+++ b/ghc/compiler/typecheck/TcMatches.lhs
@@ -13,16 +13,17 @@ IMP_Ubiq()
 import HsSyn		( Match(..), GRHSsAndBinds(..), GRHS(..), InPat,
 			  HsExpr, HsBinds, OutPat, Fake,
 			  collectPatBinders, pprMatch )
-import RnHsSyn		( SYN_IE(RenamedMatch), RnName{-instance Outputable-} )
+import RnHsSyn		( SYN_IE(RenamedMatch) )
 import TcHsSyn		( TcIdOcc(..), SYN_IE(TcMatch) )
 
-import TcMonad		hiding ( rnMtoTcM )
+import TcMonad
 import Inst		( Inst, SYN_IE(LIE), plusLIE )
 import TcEnv		( newMonoIds )
 IMPORT_DELOOPER(TcLoop)		( tcGRHSsAndBinds )
 import TcPat		( tcPat )
 import TcType		( SYN_IE(TcType), TcMaybe, zonkTcType )
 import Unify		( unifyTauTy, unifyTauTyList )
+import Name		( Name {- instance Outputable -} )
 
 import Kind		( Kind, mkTypeKind )
 import Pretty
@@ -36,7 +37,7 @@ is used in error messages.  It checks that all the equations have the
 same number of arguments before using @tcMatches@ to do the work.
 
 \begin{code}
-tcMatchesFun :: RnName
+tcMatchesFun :: Name
 	     -> TcType s 		-- Expected type
 	     -> [RenamedMatch]
 	     -> TcM s ([TcMatch s], LIE s)
@@ -80,7 +81,7 @@ tcMatchesCase expected_ty matches = tcMatchesExpected expected_ty MCase matches
 
 
 \begin{code}
-data FunOrCase = MCase | MFun RnName	-- Records whether doing  fun or case rhss;
+data FunOrCase = MCase | MFun Name	-- Records whether doing  fun or case rhss;
 					-- used to produced better error messages
 
 tcMatchesExpected :: TcType s
diff --git a/ghc/compiler/typecheck/TcModule.lhs b/ghc/compiler/typecheck/TcModule.lhs
index 113c82e0fd..09140f1698 100644
--- a/ghc/compiler/typecheck/TcModule.lhs
+++ b/ghc/compiler/typecheck/TcModule.lhs
@@ -10,15 +10,14 @@ module TcModule (
 	typecheckModule,
 	SYN_IE(TcResults),
 	SYN_IE(TcResultBinds),
-	SYN_IE(TcIfaceInfo),
 	SYN_IE(TcSpecialiseRequests),
 	SYN_IE(TcDDumpDeriv)
     ) where
 
 IMP_Ubiq(){-uitous-}
 
-import HsSyn		( HsModule(..), HsBinds(..), Bind, HsExpr,
-			  TyDecl, SpecDataSig, ClassDecl, InstDecl,
+import HsSyn		( HsDecl(..), HsModule(..), HsBinds(..), Bind, HsExpr,
+			  TyDecl, SpecDataSig, ClassDecl, InstDecl, IfaceSig,
 			  SpecInstSig, DefaultDecl, Sig, Fake, InPat,
  			  FixityDecl, IE, ImportDecl
 			)
@@ -26,7 +25,7 @@ import RnHsSyn		( SYN_IE(RenamedHsModule), RenamedFixityDecl(..) )
 import TcHsSyn		( SYN_IE(TypecheckedHsBinds), SYN_IE(TypecheckedHsExpr),
 			  TcIdOcc(..), zonkBinds, zonkDictBinds )
 
-import TcMonad		hiding ( rnMtoTcM )
+import TcMonad
 import Inst		( Inst, plusLIE )
 import TcBinds		( tcBindsAndThen )
 import TcClassDcl	( tcClassDecls2 )
@@ -42,14 +41,14 @@ import TcSimplify	( tcSimplifyTop )
 import TcTyClsDecls	( tcTyAndClassDecls1 )
 import TcTyDecls	( mkDataBinds )
 
+import RnMonad		( RnNameSupply(..) )
 import Bag		( listToBag )
 import Class		( GenClass, classSelIds )
 import ErrUtils		( SYN_IE(Warning), SYN_IE(Error) )
-import Id		( idType, isMethodSelId, isTopLevId, GenId, SYN_IE(IdEnv), nullIdEnv )
+import Id		( idType, GenId, SYN_IE(IdEnv), nullIdEnv )
 import Maybes		( catMaybes )
 import Name		( isLocallyDefined )
 import Pretty
-import RnUtils		( SYN_IE(RnEnv) )
 import TyCon		( TyCon )
 import Type		( applyTyCon )
 import TysWiredIn	( unitTy, mkPrimIoTy )
@@ -69,7 +68,8 @@ Outside-world interface:
 -- Convenient type synonyms first:
 type TcResults
   = (TcResultBinds,
-     TcIfaceInfo,
+     [TyCon], 
+     Bag InstInfo,		-- Instance declaration information
      TcSpecialiseRequests,
      TcDDumpDeriv)
 
@@ -83,9 +83,6 @@ type TcResultBinds
 
      [(Id, TypecheckedHsExpr)]) -- constant instance binds
 
-type TcIfaceInfo -- things for the interface generator
-  = ([Id], [TyCon], [Class], Bag InstInfo)
-
 type TcSpecialiseRequests
   = FiniteMap TyCon [(Bool, [Maybe Type])]
     -- source tycon specialisation requests
@@ -96,7 +93,7 @@ type TcDDumpDeriv
 ---------------
 typecheckModule
 	:: UniqSupply
-	-> RnEnv		-- for renaming derivings
+	-> RnNameSupply
 	-> RenamedHsModule
 	-> MaybeErr
 	    (TcResults,		-- if all goes well...
@@ -104,24 +101,19 @@ typecheckModule
 	    (Bag Error,		-- if we had errors...
 	     Bag Warning)
 
-typecheckModule us rn_env mod
-  = initTc us (tcModule rn_env mod)
+typecheckModule us rn_name_supply mod
+  = initTc us (tcModule rn_name_supply mod)
 \end{code}
 
 The internal monster:
 \begin{code}
-tcModule :: RnEnv		-- for renaming derivings
+tcModule :: RnNameSupply	-- for renaming derivings
 	 -> RenamedHsModule	-- input
 	 -> TcM s TcResults	-- output
 
-tcModule rn_env
-	(HsModule mod_name verion exports imports fixities
-		  ty_decls specdata_sigs cls_decls inst_decls specinst_sigs
-		  default_decls val_decls sigs src_loc)
-
-  = ASSERT(null imports)
-
-    tcAddSrcLoc src_loc $	-- record where we're starting
+tcModule rn_name_supply
+	(HsModule mod_name verion exports imports fixities decls src_loc)
+  = tcAddSrcLoc src_loc $	-- record where we're starting
 
 	-- Tie the knot for inteface-file value declaration signatures
 	-- This info is only used inside the knot for type-checking the
@@ -140,30 +132,28 @@ tcModule rn_env
 	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 ->
+	    -- trace "tcTyAndClassDecls:"	$
+	    tcTyAndClassDecls1 rec_inst_mapper decls	`thenTc` \ env ->
 
-	    --trace "tc3" $
+	    -- trace "tc3" $
 		-- Typecheck the instance decls, includes deriving
 	    tcSetEnv env (
-	    --trace "tcInstDecls:"	$
-	    tcInstDecls1 inst_decls_bag specinst_sigs
-			 mod_name rn_env fixities 
-	    )				`thenTc` \ (inst_info, deriv_binds, ddump_deriv) ->
+	    -- trace "tcInstDecls:"	$
+	    tcInstDecls1 decls mod_name rn_name_supply
+	    )					`thenTc` \ (inst_info, deriv_binds, ddump_deriv) ->
 
-	    --trace "tc4" $
+	    -- trace "tc4" $
 	    buildInstanceEnvs inst_info	`thenTc` \ inst_mapper ->
 
 	    returnTc (inst_mapper, env, inst_info, deriv_binds, ddump_deriv)
 
 	) `thenTc` \ (_, env, inst_info, deriv_binds, ddump_deriv) ->
 
-	--trace "tc5" $
+	-- trace "tc5" $
 	tcSetEnv env (
 
 	    -- Default declarations
-	tcDefaults default_decls	`thenTc` \ defaulting_tys ->
+	tcDefaults decls		`thenTc` \ defaulting_tys ->
 	tcSetDefaultTys defaulting_tys 	( -- for the iface sigs...
 
 	-- Create any necessary record selector Ids and their bindings
@@ -187,29 +177,29 @@ tcModule rn_env
 	    -- What we rely on is that pragmas are typechecked lazily; if
 	    --   any type errors are found (ie there's an inconsistency)
 	    --   we silently discard the pragma
-	tcInterfaceSigs sigs		`thenTc` \ sig_ids ->
+	tcInterfaceSigs decls		`thenTc` \ sig_ids ->
 	tcGetEnv			`thenNF_Tc` \ env ->
-	--trace "tc6" $
+	-- trace "tc6" $
 
 	returnTc (env, inst_info, data_binds, deriv_binds, ddump_deriv, defaulting_tys, sig_ids)
 
     )))) `thenTc` \ (env, inst_info, data_binds, deriv_binds, ddump_deriv, defaulting_tys, _) ->
 
-    --trace "tc7" $
+    -- trace "tc7" $
     tcSetEnv env (				-- to the end...
     tcSetDefaultTys defaulting_tys (		-- ditto
 
 	-- Value declarations next.
 	-- We also typecheck any extra binds that came out of the "deriving" process
-    --trace "tcBinds:"			$
+    -- trace "tcBinds:"			$
     tcBindsAndThen
 	(\ binds1 (binds2, thing) -> (binds1 `ThenBinds` binds2, thing))
-	(val_decls `ThenBinds` deriv_binds)
+	(get_val_decls decls `ThenBinds` deriv_binds)
 	(	-- Second pass over instance declarations,
 		-- to compile the bindings themselves.
-	    --trace "tc8" $
+	    -- trace "tc8" $
 	    tcInstDecls2  inst_info	`thenNF_Tc` \ (lie_instdecls, inst_binds) ->
-	    tcClassDecls2 cls_decls_bag	`thenNF_Tc` \ (lie_clasdecls, cls_binds) ->
+	    tcClassDecls2 decls		`thenNF_Tc` \ (lie_clasdecls, cls_binds) ->
 	    tcGetEnv			`thenNF_Tc` \ env ->
 	    returnTc ( (EmptyBinds, (inst_binds, cls_binds, env)),
 		       lie_instdecls `plusLIE` lie_clasdecls,
@@ -223,7 +213,7 @@ tcModule rn_env
 	-- restriction, and no subsequent decl instantiates its
 	-- type.  (Usually, ambiguous type variables are resolved
 	-- during the generalisation step.)
-    --trace "tc9" $
+    -- trace "tc9" $
     tcSimplifyTop lie_alldecls			`thenTc` \ const_insts ->
 
 	-- Backsubstitution.  Monomorphic top-level decls may have
@@ -252,22 +242,15 @@ tcModule rn_env
 
 	local_tycons  = filter isLocallyDefined tycons
 	local_classes = filter isLocallyDefined classes
-	local_vals    = [ v | v <- eltsUFM ve2, isLocallyDefined v && isTopLevId v ]
-			-- the isTopLevId is doubtful...
     in
 	-- FINISHED AT LAST
     returnTc (
 	(data_binds', cls_binds', inst_binds', val_binds', const_insts'),
 
-	     -- the next collection is just for mkInterface
-	(local_vals, local_tycons, local_classes, inst_info),
-
-	tycon_specs,
+	local_tycons, inst_info, tycon_specs,
 
 	ddump_deriv
     )))
-  where
-    ty_decls_bag   = listToBag ty_decls
-    cls_decls_bag  = listToBag cls_decls
-    inst_decls_bag = listToBag inst_decls
+
+get_val_decls decls = foldr ThenBinds EmptyBinds [binds | ValD binds <- decls]
 \end{code}
diff --git a/ghc/compiler/typecheck/TcMonad.lhs b/ghc/compiler/typecheck/TcMonad.lhs
index e595a839e4..5bd270cc3e 100644
--- a/ghc/compiler/typecheck/TcMonad.lhs
+++ b/ghc/compiler/typecheck/TcMonad.lhs
@@ -10,7 +10,8 @@ module TcMonad(
 	foldrTc, foldlTc, mapAndUnzipTc, mapAndUnzip3Tc,
 	mapBagTc, fixTc, tryTc,
 
-	returnNF_Tc, thenNF_Tc, thenNF_Tc_, mapNF_Tc, fixNF_Tc,
+	returnNF_Tc, thenNF_Tc, thenNF_Tc_, mapNF_Tc, fixNF_Tc, forkNF_Tc,
+
 	listNF_Tc, mapAndUnzipNF_Tc, mapBagNF_Tc,
 
 	checkTc, checkTcM, checkMaybeTc, checkMaybeTcM, 
@@ -26,8 +27,6 @@ module TcMonad(
 
 	tcNewMutVar, tcReadMutVar, tcWriteMutVar,
 
-	rnMtoTcM,
-
 	SYN_IE(TcError), SYN_IE(TcWarning),
 	mkTcErr, arityErr,
 
@@ -50,18 +49,11 @@ import Usage		( SYN_IE(Usage), GenUsage )
 import ErrUtils		( SYN_IE(Error), SYN_IE(Message), SYN_IE(Warning) )
 
 import SST
-import RnMonad		( SYN_IE(RnM), RnDown, initRn, setExtraRn,
-			  returnRn, thenRn, getImplicitUpRn
-			)
-import RnUtils		( SYN_IE(RnEnv) )
-
 import Bag		( Bag, emptyBag, isEmptyBag,
 			  foldBag, unitBag, unionBags, snocBag )
 import FiniteMap	( FiniteMap, emptyFM, isEmptyFM{-, keysFM ToDo:rm-} )
---import Outputable	( Outputable(..), NamedThing(..), ExportFlag )
 import Maybes		( MaybeErr(..) )
---import Name		( Name )
-import SrcLoc		( SrcLoc, mkUnknownSrcLoc )
+import SrcLoc		( SrcLoc, noSrcLoc )
 import UniqFM		( UniqFM, emptyUFM )
 import UniqSupply	( UniqSupply, getUnique, getUniques, splitUniqSupply )
 import Unique		( Unique )
@@ -103,7 +95,7 @@ initTc us do_this
       newMutVarSST emptyUFM		`thenSST` \ tvs_var ->
       let
           init_down = TcDown [] us_var
-			     mkUnknownSrcLoc
+			     noSrcLoc
 			     [] errs_var
 	  init_env  = initEnv tvs_var
       in
@@ -229,12 +221,20 @@ fixTc :: (a -> TcM s a) -> TcM s a
 fixTc m env down = fixFSST (\ loop -> m loop env down)
 \end{code}
 
-@forkNF_Tc@ runs a sub-typecheck action in a separate state thread.
-This elegantly ensures that it can't zap any type variables that
-belong to the main thread.  We throw away any error messages!
+@forkNF_Tc@ runs a sub-typecheck action *lazily* in a separate state
+thread.  Ideally, this elegantly ensures that it can't zap any type
+variables that belong to the main thread.  But alas, the environment
+contains TyCon and Class environments that include (TcKind s) stuff,
+which is a Royal Pain.  By the time this fork stuff is used they'll
+have been unified down so there won't be any kind variables, but we
+can't express that in the current typechecker framework.
+
+So we compromise and use unsafeInterleaveSST.
 
-\begin{pseudocode}
-forkNF_Tc :: NF_TcM s' r -> NF_TcM s r
+We throw away any error messages!
+
+\begin{code}
+forkNF_Tc :: NF_TcM s r -> NF_TcM s r
 forkNF_Tc m (TcDown deflts u_var src_loc err_cxt err_var) env
   = 	-- Get a fresh unique supply
     readMutVarSST u_var		`thenSST` \ us ->
@@ -242,39 +242,18 @@ forkNF_Tc m (TcDown deflts u_var src_loc err_cxt err_var) env
 	(us1, us2) = splitUniqSupply us
     in
     writeMutVarSST u_var us1	`thenSST_`
-    returnSST ( runSST (
-	newMutVarSST us2 			`thenSST` \ u_var'   ->
+    
+    unsafeInterleaveSST (
+	newMutVarSST us2 			`thenSST` \ us_var'   ->
       	newMutVarSST (emptyBag,emptyBag)	`thenSST` \ err_var' ->
       	newMutVarSST emptyUFM			`thenSST` \ tv_var'  ->
 	let
-            down' = TcDown deflts us_var src_loc err_cxt err_var'
-	    env'  = forkEnv env tv_var'
+            down' = TcDown deflts us_var' src_loc err_cxt err_var'
 	in
-	m down' env'
-
+	m down' env
 	-- ToDo: optionally dump any error messages
-    ))
-\end{pseudocode}
-
-@forkTcDown@ makes a new "down" blob for a lazily-computed fork
-of the type checker.
-
-\begin{pseudocode}
-forkTcDown (TcDown deflts u_var src_loc err_cxt err_var)
-  = 	-- Get a fresh unique supply
-    readMutVarSST u_var		`thenSST` \ us ->
-    let
-	(us1, us2) = splitUniqSupply us
-    in
-    writeMutVarSST u_var us1	`thenSST_`
-
-	-- Make fresh MutVars for the unique supply and errors
-    newMutVarSST us2			`thenSST` \ u_var' ->
-    newMutVarSST (emptyBag, emptyBag)	`thenSST` \ err_var' ->
-
-	-- Done
-    returnSST (TcDown deflts u_var' src_loc err_cxt err_var')
-\end{pseudocode}
+    )
+\end{code}
 
 
 Error handling
@@ -470,39 +449,6 @@ getErrCtxt (TcDown def us loc ctxt errs)     = ctxt
 \end{code}
 
 
-\section{rn4MtoTcM}
-%~~~~~~~~~~~~~~~~~~
-
-\begin{code}
-rnMtoTcM :: RnEnv -> RnM REAL_WORLD a -> NF_TcM s (a, Bag Error)
-
-rnMtoTcM rn_env rn_action down env
-  = readMutVarSST u_var				`thenSST` \ uniq_supply ->
-    let
-      (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply
-    in
-    writeMutVarSST u_var new_uniq_supply	`thenSST_`
-    let
-	(rn_result, rn_errs, rn_warns)
-	  = initRn False{-*interface* mode! so we can see the builtins-}
-		   (panic "rnMtoTcM:module")
-		   rn_env uniq_s (
-		rn_action	`thenRn` \ result ->
-
-		-- Though we are in "interface mode", we must
-		-- not have added anything to the ImplicitEnv!
-		getImplicitUpRn	`thenRn` \ implicit_env@(v_env,tc_env) ->
-		if (isEmptyFM v_env && isEmptyFM tc_env)
-		then returnRn result
-		else panic "rnMtoTcM: non-empty ImplicitEnv!"
---			(ppAboves ([ ppCat [ppPStr m, ppPStr n] | (OrigName m n) <- keysFM v_env]
---				++ [ ppCat [ppPStr m, ppPStr n] | (OrigName m n) <- keysFM tc_env]))
-	    )
-    in
-    returnSST (rn_result, rn_errs)
-  where
-    u_var = getUniqSupplyVar down
-\end{code}
 
 
 TypeChecking Errors
diff --git a/ghc/compiler/typecheck/TcMonoType.lhs b/ghc/compiler/typecheck/TcMonoType.lhs
index d933c2f85b..f426434d28 100644
--- a/ghc/compiler/typecheck/TcMonoType.lhs
+++ b/ghc/compiler/typecheck/TcMonoType.lhs
@@ -6,107 +6,94 @@
 \begin{code}
 #include "HsVersions.h"
 
-module TcMonoType ( tcPolyType, tcMonoType, tcMonoTypeKind, tcContext ) where
+module TcMonoType ( tcHsType, tcHsTypeKind, tcContext, tcTyVarScope ) where
 
 IMP_Ubiq(){-uitous-}
 
-import HsSyn		( PolyType(..), MonoType(..), Fake )
-import RnHsSyn		( RenamedPolyType(..), RenamedMonoType(..), 
-			  RenamedContext(..), RnName(..),
-			  isRnLocal, isRnClass, isRnTyCon
-			)
+import HsSyn		( HsType(..), HsTyVar(..), Fake )
+import RnHsSyn		( RenamedHsType(..), RenamedContext(..) )
 
-import TcMonad		hiding ( rnMtoTcM )
-import TcEnv		( tcLookupTyVar, tcLookupClass, tcLookupTyCon, 
-			  tcTyVarScope, tcTyVarScopeGivenKinds
-			)
+import TcMonad
+import TcEnv		( tcLookupTyVar, tcLookupClass, tcLookupTyCon, tcExtendTyVarEnv	)
 import TcKind		( TcKind, mkTcTypeKind, mkBoxedTypeKind,
 			  mkTcArrowKind, unifyKind, newKindVar,
-			  kindToTcKind
+			  kindToTcKind, tcDefaultKind
 			)
 import Type		( GenType, SYN_IE(Type), SYN_IE(ThetaType), 
 			  mkTyVarTy, mkTyConTy, mkFunTy, mkAppTy, mkSynTy,
 			  mkSigmaTy, mkDictTy
 			)
-import TyVar		( GenTyVar, SYN_IE(TyVar) )
-import Class		( cCallishClassKeys )
+import TyVar		( GenTyVar, SYN_IE(TyVar), mkTyVar )
+import PrelInfo		( cCallishClassKeys )
 import TyCon		( TyCon )
+import Name		( Name, OccName, isTvOcc )
 import TysWiredIn	( mkListTy, mkTupleTy )
 import Unique		( Unique )
 import PprStyle
 import Pretty
-import Util		( zipWithEqual, panic{-, pprPanic ToDo:rm-} )
+import Util		( zipWithEqual, zipLazy, panic{-, pprPanic ToDo:rm-} )
 \end{code}
 
 
-tcMonoType and tcMonoTypeKind
+tcHsType and tcHsTypeKind
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 
-tcMonoType checks that the type really is of kind Type!
+tcHsType checks that the type really is of kind Type!
 
 \begin{code}
-tcMonoType :: RenamedMonoType -> TcM s Type
+tcHsType :: RenamedHsType -> TcM s Type
 
-tcMonoType ty
-  = tcMonoTypeKind ty			`thenTc` \ (kind,ty) ->
+tcHsType ty
+  = tcHsTypeKind ty			`thenTc` \ (kind,ty) ->
     unifyKind kind mkTcTypeKind		`thenTc_`
     returnTc ty
 \end{code}
 
-tcMonoTypeKind does the real work.  It returns a kind and a type.
+tcHsTypeKind does the real work.  It returns a kind and a type.
 
 \begin{code}
-tcMonoTypeKind :: RenamedMonoType -> TcM s (TcKind s, Type)
+tcHsTypeKind :: RenamedHsType -> TcM s (TcKind s, Type)
 
-tcMonoTypeKind (MonoTyVar name)
+tcHsTypeKind (MonoTyVar name)
   = tcLookupTyVar name	`thenNF_Tc` \ (kind,tyvar) ->
     returnTc (kind, mkTyVarTy tyvar)
     
 
-tcMonoTypeKind (MonoListTy ty)
-  = tcMonoType ty	`thenTc` \ tau_ty ->
+tcHsTypeKind (MonoListTy _ ty)
+  = tcHsType ty	`thenTc` \ tau_ty ->
     returnTc (mkTcTypeKind, mkListTy tau_ty)
 
-tcMonoTypeKind (MonoTupleTy tys)
-  = mapTc tcMonoType  tys	`thenTc` \ tau_tys ->
+tcHsTypeKind (MonoTupleTy _ tys)
+  = mapTc tcHsType  tys	`thenTc` \ tau_tys ->
     returnTc (mkTcTypeKind, mkTupleTy (length tys) tau_tys)
 
-tcMonoTypeKind (MonoFunTy ty1 ty2)
-  = tcMonoType ty1	`thenTc` \ tau_ty1 ->
-    tcMonoType ty2	`thenTc` \ tau_ty2 ->
+tcHsTypeKind (MonoFunTy ty1 ty2)
+  = tcHsType ty1	`thenTc` \ tau_ty1 ->
+    tcHsType ty2	`thenTc` \ tau_ty2 ->
     returnTc (mkTcTypeKind, mkFunTy tau_ty1 tau_ty2)
 
-tcMonoTypeKind (MonoTyApp name tys)
-  | isRnLocal name	-- Must be a type variable
+tcHsTypeKind (MonoTyApp name tys)
+  | isTvOcc (getOccName name)	-- Must be a type variable
   = tcLookupTyVar name			`thenNF_Tc` \ (kind,tyvar) ->
     tcMonoTyApp kind (mkTyVarTy tyvar) tys
 
-  | otherwise {-isRnTyCon name-} 	-- Must be a type constructor
-  = tcLookupTyCon name			`thenNF_Tc` \ (kind,maybe_arity,tycon) ->
+  | otherwise		 	-- Must be a type constructor
+  = tcLookupTyCon name			`thenTc` \ (kind,maybe_arity,tycon) ->
     case maybe_arity of
 	Just arity -> tcSynApp name kind arity tycon tys	-- synonum
 	Nothing	   -> tcMonoTyApp kind (mkTyConTy tycon) tys	-- newtype or data
 
---  | otherwise
---  = pprPanic "tcMonoTypeKind:" (ppr PprDebug name)
-	
--- for unfoldings only:
-tcMonoTypeKind (MonoForAllTy tyvars_w_kinds ty)
-  = tcTyVarScopeGivenKinds names tc_kinds (\ tyvars ->
-	tcMonoTypeKind ty		`thenTc` \ (kind, ty') ->
-	unifyKind kind mkTcTypeKind	`thenTc_`
-	returnTc (mkTcTypeKind, ty')
-    )
-  where
-    (rn_names, kinds) = unzip tyvars_w_kinds
-    names    = map de_rn rn_names
-    tc_kinds = map kindToTcKind kinds
-    de_rn (RnName n) = n
+tcHsTypeKind (HsForAllTy tv_names context ty)
+  = tcTyVarScope tv_names		 	$ \ tyvars ->
+	tcContext context			`thenTc` \ theta ->
+	tcHsType ty				`thenTc` \ tau ->
+		-- For-all's are of kind type!
+	returnTc (mkTcTypeKind, mkSigmaTy tyvars theta tau)
 
 -- for unfoldings only:
-tcMonoTypeKind (MonoDictTy class_name ty)
-  = tcMonoTypeKind ty			`thenTc` \ (arg_kind, arg_ty) ->
-    tcLookupClass class_name		`thenNF_Tc` \ (class_kind, clas) ->
+tcHsTypeKind (MonoDictTy class_name ty)
+  = tcHsTypeKind ty			`thenTc` \ (arg_kind, arg_ty) ->
+    tcLookupClass class_name		`thenTc` \ (class_kind, clas) ->
     unifyKind class_kind arg_kind	`thenTc_`
     returnTc (mkTcTypeKind, mkDictTy clas arg_ty)
 \end{code}
@@ -115,13 +102,13 @@ Help functions for type applications
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 \begin{code}
 tcMonoTyApp fun_kind fun_ty tys
-  = mapAndUnzipTc tcMonoTypeKind tys	`thenTc`    \ (arg_kinds, arg_tys) ->
+  = mapAndUnzipTc tcHsTypeKind tys	`thenTc`    \ (arg_kinds, arg_tys) ->
     newKindVar				`thenNF_Tc` \ result_kind ->
     unifyKind fun_kind (foldr mkTcArrowKind result_kind arg_kinds)	`thenTc_`
     returnTc (result_kind, foldl mkAppTy fun_ty arg_tys)
 
 tcSynApp name syn_kind arity tycon tys
-  = mapAndUnzipTc tcMonoTypeKind tys	`thenTc`    \ (arg_kinds, arg_tys) ->
+  = mapAndUnzipTc tcHsTypeKind tys	`thenTc`    \ (arg_kinds, arg_tys) ->
     newKindVar				`thenNF_Tc` \ result_kind ->
     unifyKind syn_kind (foldr mkTcArrowKind result_kind arg_kinds)	`thenTc_`
 
@@ -141,16 +128,16 @@ Contexts
 tcContext :: RenamedContext -> TcM s ThetaType
 tcContext context = mapTc tcClassAssertion context
 
-tcClassAssertion (class_name, tyvar_name)
+tcClassAssertion (class_name, ty)
   = checkTc (canBeUsedInContext class_name)
 	    (naughtyCCallContextErr class_name)	`thenTc_`
 
-    tcLookupClass class_name		`thenNF_Tc` \ (class_kind, clas) ->
-    tcLookupTyVar tyvar_name		`thenNF_Tc` \ (tyvar_kind, tyvar) ->
+    tcLookupClass class_name		`thenTc` \ (class_kind, clas) ->
+    tcHsTypeKind ty			`thenTc` \ (ty_kind, ty) ->
 
-    unifyKind class_kind tyvar_kind	`thenTc_`
+    unifyKind class_kind ty_kind	`thenTc_`
 
-    returnTc (clas, mkTyVarTy tyvar)
+    returnTc (clas, ty)
 \end{code}
 
 HACK warning: Someone discovered that @CCallable@ and @CReturnable@
@@ -163,24 +150,43 @@ Doing this utterly wrecks the whole point of introducing these
 classes so we specifically check that this isn't being done.
 
 \begin{code}
-canBeUsedInContext :: RnName -> Bool
-canBeUsedInContext n
-  = isRnClass n && not (uniqueOf n `elem` cCallishClassKeys)
+canBeUsedInContext :: Name -> Bool
+canBeUsedInContext n = not (uniqueOf n `elem` cCallishClassKeys)
 \end{code}
 
-Polytypes
-~~~~~~~~~
+Type variables, with knot tying!
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 \begin{code}
-tcPolyType :: RenamedPolyType -> TcM s Type
-tcPolyType (HsForAllTy tyvar_names context ty)
-  = tcTyVarScope names (\ tyvars ->
-	tcContext context	`thenTc` \ theta ->
-	tcMonoType ty		`thenTc` \ tau ->
-	returnTc (mkSigmaTy tyvars theta tau)
-    )
-  where
-    names = map de_rn tyvar_names
-    de_rn (RnName n) = n
+tcTyVarScope
+	:: [HsTyVar Name]		-- Names of some type variables
+	-> ([TyVar] -> TcM s a)		-- Thing to type check in their scope
+	-> TcM s a			-- Result
+
+tcTyVarScope tyvar_names thing_inside
+  = mapAndUnzipNF_Tc tcHsTyVar tyvar_names	`thenNF_Tc` \ (names, kinds) ->
+
+    fixTc (\ ~(rec_tyvars, _) ->
+		-- Ok to look at names, kinds, but not tyvars!
+
+	tcExtendTyVarEnv names (kinds `zipLazy` rec_tyvars)
+			 (thing_inside rec_tyvars)		`thenTc` \ result ->
+ 
+		-- Get the tyvar's Kinds from their TcKinds
+	mapNF_Tc tcDefaultKind kinds				`thenNF_Tc` \ kinds' ->
+
+		-- Construct the real TyVars
+	let
+	  tyvars = zipWithEqual "tcTyVarScope" mkTyVar names kinds'
+	in
+	returnTc (tyvars, result)
+    )					`thenTc` \ (_,result) ->
+    returnTc result
+
+tcHsTyVar (UserTyVar name)
+  = newKindVar		`thenNF_Tc` \ tc_kind ->
+    returnNF_Tc (name, tc_kind)
+tcHsTyVar (IfaceTyVar name kind)
+  = returnNF_Tc (name, kindToTcKind kind)
 \end{code}
 
 Errors and contexts
diff --git a/ghc/compiler/typecheck/TcPat.lhs b/ghc/compiler/typecheck/TcPat.lhs
index becc2d6104..1a5f05514f 100644
--- a/ghc/compiler/typecheck/TcPat.lhs
+++ b/ghc/compiler/typecheck/TcPat.lhs
@@ -11,16 +11,17 @@ module TcPat ( tcPat ) where
 IMP_Ubiq(){-uitous-}
 
 import HsSyn		( InPat(..), OutPat(..), HsExpr(..), HsLit(..),
-			  Match, HsBinds, Qualifier, PolyType,
+			  Match, HsBinds, Qualifier, HsType,
 			  ArithSeqInfo, Stmt, Fake )
-import RnHsSyn		( SYN_IE(RenamedPat), RnName{-instance Outputable-} )
+import RnHsSyn		( SYN_IE(RenamedPat) )
 import TcHsSyn		( SYN_IE(TcPat), TcIdOcc(..) )
 
-import TcMonad		hiding ( rnMtoTcM )
+import TcMonad
 import Inst		( Inst, OverloadedLit(..), InstOrigin(..),
 			  emptyLIE, plusLIE, plusLIEs, SYN_IE(LIE),
 			  newMethod, newOverloadedLit
 			)
+import Name		( Name {- instance Outputable -} )
 import TcEnv		( tcLookupGlobalValue, tcLookupGlobalValueByKey, 
 			  tcLookupLocalValueOK )
 import SpecEnv		( SpecEnv )
@@ -326,7 +327,7 @@ tcPats (pat:pats)
 unifies the actual args against the expected ones.
 
 \begin{code}
-matchConArgTys :: RnName -> [TcType s] -> TcM s (Id, TcType s)
+matchConArgTys :: Name -> [TcType s] -> TcM s (Id, TcType s)
 
 matchConArgTys con arg_tys
   = tcLookupGlobalValue con		`thenNF_Tc` \ con_id ->
diff --git a/ghc/compiler/typecheck/TcSimplify.lhs b/ghc/compiler/typecheck/TcSimplify.lhs
index 061dc653ca..93f04cd545 100644
--- a/ghc/compiler/typecheck/TcSimplify.lhs
+++ b/ghc/compiler/typecheck/TcSimplify.lhs
@@ -15,11 +15,11 @@ module TcSimplify (
 IMP_Ubiq()
 
 import HsSyn		( MonoBinds(..), HsExpr(..), InPat, OutPat, HsLit, 
-			  Match, HsBinds, Qualifier, PolyType, ArithSeqInfo,
+			  Match, HsBinds, Qualifier, HsType, ArithSeqInfo,
 			  GRHSsAndBinds, Stmt, Fake )
 import TcHsSyn		( TcIdOcc(..), SYN_IE(TcIdBndr), SYN_IE(TcExpr), SYN_IE(TcMonoBinds) )
 
-import TcMonad		hiding ( rnMtoTcM )
+import TcMonad
 import Inst		( lookupInst, lookupSimpleInst,
 			  tyVarsOfInst, isTyVarDict, isDict,
 			  matchesInst, instToId, instBindingRequired,
@@ -36,19 +36,20 @@ import Unify		( unifyTauTy )
 import Bag		( Bag, unitBag, listToBag, foldBag, filterBag, emptyBag, bagToList, 
 			  snocBag, consBag, unionBags, isEmptyBag )
 import Class		( GenClass, SYN_IE(Class), SYN_IE(ClassInstEnv),
-			  isNumericClass, isStandardClass, isCcallishClass,
 			  isSuperClassOf, classSuperDictSelId, classInstEnv
 			)
 import Id		( GenId )
+import PrelInfo		( isNumericClass, isStandardClass, isCcallishClass )
+
 import Maybes		( expectJust, firstJust, catMaybes, seqMaybe, maybeToBool )
 import Outputable	( Outputable(..){-instance * []-} )
 --import PprStyle--ToDo:rm
 import PprType		( GenType, GenTyVar )
 import Pretty
-import SrcLoc		( mkUnknownSrcLoc )
+import SrcLoc		( noSrcLoc )
 import Type		( GenType, SYN_IE(Type), SYN_IE(TauType), mkTyVarTy, getTyVar, eqSimpleTy,
 			  getTyVar_maybe )
-import TysWiredIn	( intTy )
+import TysWiredIn	( intTy, unitTy )
 import TyVar		( GenTyVar, SYN_IE(GenTyVarSet), 
 			  elementOfTyVarSet, emptyTyVarSet, unionTyVarSets,
 			  isEmptyTyVarSet, tyVarSetToList )
@@ -660,10 +661,7 @@ Since we're not using the result of @foo@, the result if (presumably)
 disambigOne :: [SimpleDictInfo s] -> TcM s ()
 
 disambigOne dict_infos
-  | not (isStandardNumericDefaultable classes)
-  = failTc (ambigErr dicts) -- no default
-
-  | otherwise -- isStandardNumericDefaultable dict_infos
+  |  any isNumericClass classes && all isStandardClass classes
   = 	-- THE DICTS OBEY THE DEFAULTABLE CONSTRAINT
 	-- SO, TRY DEFAULT TYPES IN ORDER
 
@@ -674,7 +672,7 @@ disambigOne dict_infos
     tcGetDefaultTys			`thenNF_Tc` \ default_tys ->
     let
       try_default [] 	-- No defaults work, so fail
-	= failTc (defaultErr dicts default_tys) 
+	= failTc (ambigErr dicts) 
 
       try_default (default_ty : default_tys)
 	= tryTc (try_default default_tys) $	-- If default_ty fails, we try
@@ -689,6 +687,14 @@ disambigOne dict_infos
     tcInstType [] chosen_default_ty	`thenNF_Tc` \ chosen_default_tc_ty ->	-- Tiresome!
     unifyTauTy chosen_default_tc_ty (mkTyVarTy tyvar)
 
+  | all isCcallishClass classes
+  = 	-- Default CCall stuff to (); we don't even both to check that () is an 
+	-- instance of CCallable/CReturnable, because we know it is.
+    unifyTauTy (mkTyVarTy tyvar) unitTy    
+    
+  | otherwise -- No defaults
+  = failTc (ambigErr dicts)
+
   where
     (_,_,tyvar) = head dict_infos		-- Should be non-empty
     dicts   = [dict | (dict,_,_) <- dict_infos]
@@ -696,19 +702,6 @@ disambigOne dict_infos
 
 \end{code}
 
-@isStandardNumericDefaultable@ sees whether the dicts have the
-property required for defaulting; namely at least one is numeric, and
-all are standard; or all are CcallIsh.
-
-\begin{code}
-isStandardNumericDefaultable :: [Class] -> Bool
-
-isStandardNumericDefaultable classes
-  = --pprTrace "isStdNumeric:\n" (ppAboves [ppCat (map (ppr PprDebug) classes), ppCat (map (ppr PprDebug . isNumericClass) classes), ppCat (map (ppr PprDebug . isStandardClass) classes), ppCat (map (ppr PprDebug . isCcallishClass) classes)]) $
-     (any isNumericClass classes && all isStandardClass classes)
-  || (all isCcallishClass classes)
-\end{code}
-
 
 
 Errors and contexts
@@ -737,14 +730,4 @@ reduceErr insts sty
 	          (bagToList insts))
 \end{code}
 
-\begin{code}
-defaultErr dicts defaulting_tys sty
-  = ppHang (ppStr "Ambiguously-overloaded types could not be resolved:")
-	 4 (ppAboves [
-	     ppHang (ppStr "Conflicting:")
-		  4 (ppInterleave ppSemi (map (pprInst sty ""{-???-}) dicts)),
-	     ppHang (ppStr "Defaulting types :")
-		  4 (ppr sty defaulting_tys),
-	     ppStr "([Int, Double] is the default list of defaulting types.)" ])
-\end{code}
 
diff --git a/ghc/compiler/typecheck/TcTyClsDecls.lhs b/ghc/compiler/typecheck/TcTyClsDecls.lhs
index d4d3c25c47..afaf13efdc 100644
--- a/ghc/compiler/typecheck/TcTyClsDecls.lhs
+++ b/ghc/compiler/typecheck/TcTyClsDecls.lhs
@@ -12,27 +12,28 @@ module TcTyClsDecls (
 
 IMP_Ubiq(){-uitous-}
 
-import HsSyn		( TyDecl(..),  ConDecl(..), BangType(..),
-			  ClassDecl(..), MonoType(..), PolyType(..),
-			  Sig(..), MonoBinds, Fake, InPat, HsBinds(..), Bind, HsExpr )
-import RnHsSyn		( isRnTyCon, RenamedTyDecl(..), RenamedClassDecl(..),
-			  RnName(..){-instance Uniquable-}
+import HsSyn		( HsDecl(..), TyDecl(..),  ConDecl(..), BangType(..),
+			  ClassDecl(..), HsType(..), HsTyVar, DefaultDecl, InstDecl,
+			  IfaceSig, Sig(..), MonoBinds, Fake, InPat, HsBinds(..), Bind, HsExpr,
+			  hsDeclName
+			)
+import RnHsSyn		( RenamedTyDecl(..), RenamedClassDecl(..), SYN_IE(RenamedHsDecl)
 			)
 import TcHsSyn		( SYN_IE(TcHsBinds), TcIdOcc(..) )
 
-import TcMonad		hiding ( rnMtoTcM )
+import TcMonad
 import Inst		( SYN_IE(InstanceMapper) )
 import TcClassDcl	( tcClassDecl1 )
-import TcEnv		( tcExtendTyConEnv, tcExtendClassEnv,
-			  tcTyVarScope )
+import TcEnv		( tcExtendTyConEnv, tcExtendClassEnv )
 import SpecEnv		( SpecEnv )
 import TcKind		( TcKind, newKindVars )
 import TcTyDecls	( tcTyDecl, mkDataBinds )
+import TcMonoType	( tcTyVarScope )
 
 import Bag	
 import Class		( SYN_IE(Class), classSelIds )
 import Digraph		( findSCCs, SCC(..) )
-import Name		( getSrcLoc )
+import Name		( Name, getSrcLoc, isTvOcc, nameOccName )
 import PprStyle
 import Pretty
 import UniqSet		( SYN_IE(UniqSet), emptyUniqSet,
@@ -48,23 +49,13 @@ import Util		( panic{-, pprTrace-} )
 The main function
 ~~~~~~~~~~~~~~~~~
 \begin{code}
-data Decl = TyD RenamedTyDecl | ClD RenamedClassDecl
-
 tcTyAndClassDecls1 :: InstanceMapper
-		   -> Bag RenamedTyDecl -> Bag RenamedClassDecl
+		   -> [RenamedHsDecl]
 		   -> TcM s (TcEnv s)
 
-tcTyAndClassDecls1 inst_mapper rnty_decls rncls_decls
-  = sortByDependency syn_decls cls_decls decls `thenTc` \ groups ->
+tcTyAndClassDecls1 inst_mapper decls
+  = sortByDependency decls 		`thenTc` \ groups ->
     tcGroups inst_mapper groups
-  where
-    cls_decls = mapBag ClD rncls_decls
-    ty_decls  = mapBag TyD rnty_decls
-    syn_decls = filterBag is_syn_decl ty_decls
-    decls     = ty_decls `unionBags` cls_decls
-
-    is_syn_decl (TyD (TySynonym _ _ _ _)) = True
-    is_syn_decl _		          = False
 
 tcGroups inst_mapper []
   = tcGetEnv	`thenNF_Tc` \ env ->
@@ -83,7 +74,7 @@ tcGroups inst_mapper (group:groups)
 Dealing with a group
 ~~~~~~~~~~~~~~~~~~~~
 \begin{code}
-tcGroup :: InstanceMapper -> Bag Decl -> TcM s (TcEnv s)
+tcGroup :: InstanceMapper -> Bag RenamedHsDecl -> TcM s (TcEnv s)
 tcGroup inst_mapper decls
   = -- pprTrace "tcGroup: " (ppCat (map (fst.fmt_decl) (bagToList decls))) $
 
@@ -119,10 +110,7 @@ tcGroup inst_mapper decls
     returnTc final_env
 
   where
-    (tyvar_rn_names, tycon_names_w_arities, class_names) = get_binders decls
-
-    tyvar_names = map de_rn tyvar_rn_names
-    de_rn (RnName n) = n
+    (tyvar_names, tycon_names_w_arities, class_names) = get_binders decls
 
     combine do_a do_b
       = do_a `thenTc` \ (a1,a2) ->
@@ -134,7 +122,7 @@ Dealing with one decl
 ~~~~~~~~~~~~~~~~~~~~~
 \begin{code}
 tcDecl  :: InstanceMapper
-	-> Decl
+	-> RenamedHsDecl
 	-> TcM s (Bag TyCon, Bag Class)
 
 tcDecl inst_mapper (TyD decl)
@@ -149,54 +137,73 @@ tcDecl inst_mapper (ClD decl)
 Dependency analysis
 ~~~~~~~~~~~~~~~~~~~
 \begin{code}
-sortByDependency :: Bag Decl -> Bag Decl -> Bag Decl -> TcM s [Bag Decl]
-sortByDependency syn_decls cls_decls decls
+sortByDependency :: [RenamedHsDecl] -> TcM s [Bag RenamedHsDecl]
+sortByDependency decls
   = let		-- CHECK FOR SYNONYM CYCLES
 	syn_sccs   = findSCCs mk_edges syn_decls
-	syn_cycles = [map fmt_decl (bagToList decls)
-	                | CyclicSCC decls <- syn_sccs]
+	syn_cycles = [ map fmt_decl (bagToList decls)
+	             | CyclicSCC decls <- syn_sccs]
 
     in
     checkTc (null syn_cycles) (typeCycleErr syn_cycles)		`thenTc_`
 
     let		-- CHECK FOR CLASS CYCLES
 	cls_sccs   = findSCCs mk_edges cls_decls
-	cls_cycles = [map fmt_decl (bagToList decls)
-		        | CyclicSCC decls <- cls_sccs]
+	cls_cycles = [ map fmt_decl (bagToList decls)
+		     | CyclicSCC decls <- cls_sccs]
 
     in
     checkTc (null cls_cycles) (classCycleErr cls_cycles)	`thenTc_`
 
 		-- DO THE MAIN DEPENDENCY ANALYSIS
     let
-	decl_sccs  = findSCCs mk_edges decls
+	decl_sccs  = findSCCs mk_edges ty_cls_decls
 	scc_bags   = map bag_acyclic decl_sccs
     in
     returnTc (scc_bags)
-    
+
   where
-   bag_acyclic (AcyclicSCC scc) = unitBag scc
-   bag_acyclic (CyclicSCC sccs) = sccs
+    syn_decls    = listToBag (filter is_syn_decl decls)
+    ty_cls_decls = listToBag (filter is_ty_cls_decl decls)
+    cls_decls    = listToBag (filter is_cls_decl decls)	
+
+    
+
+bag_acyclic (AcyclicSCC scc) = unitBag scc
+bag_acyclic (CyclicSCC sccs) = sccs
+
+is_syn_decl (TyD (TySynonym _ _ _ _)) = True
+is_syn_decl _		          = False
+
+is_ty_cls_decl (TyD _) = True
+is_ty_cls_decl (ClD _) = True
+is_ty_cls_decl other   = False
+
+is_cls_decl (ClD _) = True
+is_cls_decl other   = False
 
 fmt_decl decl
   = (ppr PprForUser name, getSrcLoc name)
   where
-    name = get_name decl
-    get_name (TyD (TyData _ name _ _ _ _ _))    = name
-    get_name (TyD (TyNew  _ name _ _ _ _ _))    = name
-    get_name (TyD (TySynonym name _ _ _))       = name
-    get_name (ClD (ClassDecl _ name _ _ _ _ _)) = name
+    name = hsDeclName decl
 \end{code}
 
 Edges in Type/Class decls
 ~~~~~~~~~~~~~~~~~~~~~~~~~
 \begin{code}
 mk_edges (TyD (TyData ctxt name _ condecls derivs _ _))
-  = (uniqueOf name, set_to_bag (get_ctxt ctxt `unionUniqSets` get_cons condecls `unionUniqSets` get_deriv 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))
+  = (uniqueOf name, set_to_bag (get_ctxt ctxt `unionUniqSets` 
+				get_con 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 _ _ _))
   = (uniqueOf name, set_to_bag (get_ctxt ctxt `unionUniqSets` get_sigs sigs))
 
@@ -208,35 +215,33 @@ get_deriv (Just clss) = unionManyUniqSets (map set_name clss)
 
 get_cons cons
   = unionManyUniqSets (map get_con cons)
-  where
-    get_con (ConDecl _ btys _)
-      = unionManyUniqSets (map get_bty btys)
-    get_con (ConOpDecl bty1 _ bty2 _)
-      = unionUniqSets (get_bty bty1) (get_bty bty2)
-    get_con (NewConDecl _ ty _)
-      = get_ty ty
-    get_con (RecConDecl _ nbtys _)
-      = unionManyUniqSets (map (get_bty.snd) nbtys)
-
-    get_bty (Banged ty)   = get_pty ty
-    get_bty (Unbanged ty) = get_pty ty
+
+get_con (ConDecl _ btys _)
+  = unionManyUniqSets (map get_bty btys)
+get_con (ConOpDecl bty1 _ bty2 _)
+  = unionUniqSets (get_bty bty1) (get_bty bty2)
+get_con (NewConDecl _ ty _)
+  = get_ty ty
+get_con (RecConDecl _ nbtys _)
+  = unionManyUniqSets (map (get_bty.snd) nbtys)
+
+get_bty (Banged ty)   = get_ty ty
+get_bty (Unbanged ty) = get_ty ty
 
 get_ty (MonoTyVar tv)
   = emptyUniqSet
 get_ty (MonoTyApp name tys)
-  = (if isRnTyCon name then set_name name else emptyUniqSet)
+  = (if isTvOcc (nameOccName name) then emptyUniqSet else set_name name)
     `unionUniqSets` get_tys tys
 get_ty (MonoFunTy ty1 ty2)	
   = unionUniqSets (get_ty ty1) (get_ty ty2)
-get_ty (MonoListTy ty)
-  = get_ty ty			-- careful when defining [] (,,) etc as
-get_ty (MonoTupleTy tys)	-- [ty] (ty,ty,ty) will not give edges!
-  = get_tys tys
-get_ty other = panic "TcTyClsDecls:get_ty"
-
-get_pty (HsForAllTy _ ctxt mty)
+get_ty (MonoListTy tc ty)
+  = set_name tc `unionUniqSets` get_ty ty
+get_ty (MonoTupleTy tc tys)
+  = set_name tc `unionUniqSets` get_tys tys
+get_ty (HsForAllTy _ ctxt mty)
   = get_ctxt ctxt `unionUniqSets` get_ty mty
-get_pty other = panic "TcTyClsDecls:get_pty"
+get_ty other = panic "TcTyClsDecls:get_ty"
 
 get_tys tys
   = unionManyUniqSets (map get_ty tys)
@@ -244,7 +249,7 @@ get_tys tys
 get_sigs sigs
   = unionManyUniqSets (map get_sig sigs)
   where 
-    get_sig (ClassOpSig _ ty _ _) = get_pty ty
+    get_sig (ClassOpSig _ ty _ _) = get_ty ty
     get_sig other = panic "TcTyClsDecls:get_sig"
 
 set_name name = unitUniqSet (uniqueOf name)
@@ -276,10 +281,10 @@ Monad c in bop's type signature means that D must have kind Type->Type.
 
 
 \begin{code}
-get_binders :: Bag Decl
-	    -> ([RnName],		-- TyVars;  no dups
-		[(RnName, Maybe Arity)],-- Tycons;  no dups; arities for synonyms
-		[RnName])		-- Classes; no dups
+get_binders :: Bag RenamedHsDecl
+	    -> ([HsTyVar Name],		-- TyVars;  no dups
+		[(Name, Maybe Arity)],	-- Tycons;  no dups; arities for synonyms
+		[Name])			-- Classes; no dups
 
 get_binders decls = (bagToList tyvars, bagToList tycons, bagToList classes)
   where
@@ -304,6 +309,7 @@ sigs_tvs sigs = unionManyBags (map sig_tvs sigs)
   where 
     sig_tvs (ClassOpSig _ ty  _ _) = pty_tvs ty
     pty_tvs (HsForAllTy tvs _ _)   = listToBag tvs 	-- tvs doesn't include the class tyvar
+    pty_tvs other		   = emptyBag
 \end{code}
 
 
diff --git a/ghc/compiler/typecheck/TcTyDecls.lhs b/ghc/compiler/typecheck/TcTyDecls.lhs
index b684d2e81e..960e2e5482 100644
--- a/ghc/compiler/typecheck/TcTyDecls.lhs
+++ b/ghc/compiler/typecheck/TcTyDecls.lhs
@@ -17,39 +17,39 @@ IMP_Ubiq(){-uitous-}
 import HsSyn		( TyDecl(..), ConDecl(..), BangType(..), HsExpr(..), 
 			  Match(..), GRHSsAndBinds(..), GRHS(..), OutPat(..), 
 			  HsBinds(..), HsLit, Stmt, Qualifier, ArithSeqInfo,
-			  PolyType, Fake, InPat,
-			  Bind(..), MonoBinds(..), Sig, 
-			  MonoType )
-import RnHsSyn		( RenamedTyDecl(..), RenamedConDecl(..),
-			  RnName{-instance Outputable-}
+			  HsType, Fake, InPat, HsTyVar,
+			  Bind(..), MonoBinds(..), Sig 
 			)
+import HsTypes		( getTyVarName )
+import RnHsSyn		( RenamedTyDecl(..), RenamedConDecl(..)	)
 import TcHsSyn		( mkHsTyLam, mkHsDictLam, tcIdType,
 			  SYN_IE(TcHsBinds), TcIdOcc(..)
 			)
 import Inst		( newDicts, InstOrigin(..), Inst )
-import TcMonoType	( tcMonoTypeKind, tcMonoType, tcPolyType, tcContext )
+import TcMonoType	( tcHsTypeKind, tcHsType, tcContext )
 import TcSimplify	( tcSimplifyThetas )
 import TcType		( tcInstTyVars, tcInstType, tcInstId )
 import TcEnv		( tcLookupTyCon, tcLookupTyVar, tcLookupClass,
 			  newLocalId, newLocalIds, tcLookupClassByKey
 			)
-import TcMonad		hiding ( rnMtoTcM )
+import TcMonad
 import TcKind		( TcKind, unifyKind, mkTcArrowKind, mkTcTypeKind )
 
 import PprType		( GenClass, GenType{-instance Outputable-},
 			  GenTyVar{-instance Outputable-}{-ToDo:possibly rm-}
 			)
+import CoreUnfold	( getUnfoldingTemplate )
 import Class		( GenClass{-instance Eq-}, classInstEnv )
 import Id		( mkDataCon, dataConSig, mkRecordSelId, idType,
 			  dataConFieldLabels, dataConStrictMarks,
-			  StrictnessMark(..),
+			  StrictnessMark(..), getIdUnfolding,
 			  GenId{-instance NamedThing-}
 			)
 import FieldLabel
 import Kind		( Kind, mkArrowKind, mkBoxedTypeKind )
 import SpecEnv		( SpecEnv, nullSpecEnv )
-import Name		( nameSrcLoc, isLocallyDefinedName, getSrcLoc,
-			  Name{-instance Ord3-}
+import Name		( nameSrcLoc, isLocallyDefined, getSrcLoc,
+			  OccName(..), Name{-instance Ord3-}
 			)
 import Outputable	( Outputable(..), interpp'SP )
 import Pretty
@@ -80,11 +80,12 @@ tcTyDecl (TySynonym tycon_name tyvar_names rhs src_loc)
     tcAddErrCtxt (tySynCtxt tycon_name) $
 
 	-- Look up the pieces
-    tcLookupTyCon tycon_name			`thenNF_Tc` \ (tycon_kind,  _, rec_tycon) ->
-    mapAndUnzipNF_Tc tcLookupTyVar tyvar_names	`thenNF_Tc` \ (tyvar_kinds, rec_tyvars) ->
+    tcLookupTyCon tycon_name			`thenTc` \ (tycon_kind,  _, rec_tycon) ->
+    mapAndUnzipNF_Tc (tcLookupTyVar.getTyVarName) tyvar_names
+						`thenNF_Tc` \ (tyvar_kinds, rec_tyvars) ->
 
 	-- Look at the rhs
-    tcMonoTypeKind rhs				`thenTc` \ (rhs_kind, rhs_ty) ->
+    tcHsTypeKind rhs				`thenTc` \ (rhs_kind, rhs_ty) ->
 
 	-- Unify tycon kind with (k1->...->kn->rhs)
     unifyKind tycon_kind
@@ -118,7 +119,7 @@ tcTyDecl (TyData context tycon_name tyvar_names con_decls derivings pragmas src_
   = tcTyDataOrNew DataType context tycon_name tyvar_names con_decls derivings pragmas src_loc
 
 tcTyDecl (TyNew context tycon_name tyvar_names con_decl derivings pragmas src_loc)
-  = tcTyDataOrNew NewType  context tycon_name tyvar_names con_decl  derivings pragmas src_loc
+  = tcTyDataOrNew NewType  context tycon_name tyvar_names [con_decl] derivings pragmas src_loc
 
 
 tcTyDataOrNew data_or_new context tycon_name tyvar_names con_decls derivings pragmas src_loc
@@ -126,9 +127,10 @@ tcTyDataOrNew data_or_new context tycon_name tyvar_names con_decls derivings pra
     tcAddErrCtxt (tyDataCtxt tycon_name) $
 
 	-- Lookup the pieces
-    tcLookupTyCon tycon_name			`thenNF_Tc` \ (tycon_kind, _, rec_tycon) ->
-    mapAndUnzipNF_Tc tcLookupTyVar tyvar_names	`thenNF_Tc` \ (tyvar_kinds, rec_tyvars) ->
-    tc_derivs derivings				`thenNF_Tc` \ derived_classes ->
+    tcLookupTyCon tycon_name			`thenTc` \ (tycon_kind, _, rec_tycon) ->
+    mapAndUnzipNF_Tc (tcLookupTyVar.getTyVarName)
+				 tyvar_names	`thenNF_Tc` \ (tyvar_kinds, rec_tyvars) ->
+    tc_derivs derivings				`thenTc` \ derived_classes ->
 
 	-- Typecheck the context
     tcContext context				`thenTc` \ ctxt ->
@@ -156,12 +158,12 @@ tcTyDataOrNew data_or_new context tycon_name tyvar_names con_decls derivings pra
     in
     returnTc tycon
 
-tc_derivs Nothing   = returnNF_Tc []
-tc_derivs (Just ds) = mapNF_Tc tc_deriv ds
+tc_derivs Nothing   = returnTc []
+tc_derivs (Just ds) = mapTc tc_deriv ds
 
 tc_deriv name
-  = tcLookupClass name `thenNF_Tc` \ (_, clas) ->
-    returnNF_Tc clas
+  = tcLookupClass name `thenTc` \ (_, clas) ->
+    returnTc clas
 \end{code}
 
 Generating constructor/selector bindings for data declarations
@@ -178,14 +180,20 @@ mkDataBinds (tycon : tycons)
 
 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) ->
-    returnTc (con_ids ++ sel_ids, 
-	      SingleBind $ NonRecBind $
-	      foldr AndMonoBinds 
-		    (foldr AndMonoBinds EmptyMonoBinds sel_binds)
-		    con_binds
-    )
+    mapTc checkConstructorContext data_cons	`thenTc_` 
+    mapTc (mkRecordSelector tycon) groups	`thenTc` \ sel_ids ->
+    let
+	data_ids = data_cons ++ sel_ids
+
+	-- For the locally-defined things
+	-- we need to turn the unfoldings inside the Ids into bindings,
+	binds = [ CoreMonoBind (RealId data_id) (getUnfoldingTemplate (getIdUnfolding data_id))
+		| data_id <- data_ids, isLocallyDefined data_id
+		]
+    in	
+    returnTc (data_ids,
+	      SingleBind (NonRecBind (foldr AndMonoBinds EmptyMonoBinds binds))
+	     )
   where
     data_cons = tyConDataCons tycon
     fields = [ (con, field) | con   <- data_cons,
@@ -198,153 +206,56 @@ mkDataBinds_one tycon
 	= fieldLabelName field1 `cmp` fieldLabelName field2
 \end{code}
 
-We're going to build a constructor that looks like:
-
-	data (Data a, C b) =>  T a b = T1 !a !Int b
-
-	T1 = /\ a b -> 
-	     \d1::Data a, d2::C b ->
-	     \p q r -> case p of { p ->
-		       case q of { q ->
-		       HsCon T1 [a,b] [p,q,r]}}
-
-Notice that
-
-* d2 is thrown away --- a context in a data decl is used to make sure
-  one *could* construct dictionaries at the site the constructor
-  is used, but the dictionary isn't actually used.
-
-* We have to check that we can construct Data dictionaries for
-  the types a and Int.  Once we've done that we can throw d1 away too.
-
-* We use (case p of ...) to evaluate p, rather than "seq" because
-  all that matters is that the arguments are evaluated.  "seq" is 
-  very careful to preserve evaluation order, which we don't need
-  to be here.
+-- Check that all the types of all the strict arguments are in Eval
 
 \begin{code}
-mkConstructor con_id
-  | not (isLocallyDefinedName (getName con_id))
-  = returnTc (con_id, EmptyMonoBinds)
+checkConstructorContext con_id
+  | not (isLocallyDefined con_id)
+  = returnTc ()
 
   | otherwise	-- It is locally defined
-  = tcInstId con_id			`thenNF_Tc` \ (tc_tyvars, tc_theta, tc_tau) ->
-    newDicts DataDeclOrigin tc_theta	`thenNF_Tc` \ (_, dicts) ->
+  = tcLookupClassByKey evalClassKey	`thenNF_Tc` \ eval_clas ->
     let
-	(tc_arg_tys, tc_result_ty) = splitFunTy tc_tau
-	n_args = length tc_arg_tys
-    in
-    newLocalIds (nOfThem n_args SLIT("con")) tc_arg_tys	`thenNF_Tc` \ args ->
+	strict_marks         = dataConStrictMarks con_id
+	(tyvars,theta,tau)   = splitSigmaTy (idType con_id)
+	(arg_tys, result_ty) = splitFunTy tau
 
-	-- Check that all the types of all the strict arguments are in Eval
-    tcLookupClassByKey evalClassKey	`thenNF_Tc` \ eval_clas ->
-    let
-	(_,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" 
+	eval_theta = [ (eval_clas,arg_ty) 
+		     | (arg_ty, MarkedStrict) <- zipEqual "strict_args" 
 							arg_tys strict_marks
-			]
+		     ]
     in
     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 tc_tyvars $
-		  mkHsDictLam dicts $
-		  mk_pat_match 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_case [] body = body
-	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
-
-    returnTc (con_id, VarMonoBind (RealId con_id) con_rhs)		 
+	    (missingEvalErr con_id eval_theta')
 \end{code}
 
-We're going to build a record selector that looks like this:
-
-	data T a b c = T1 { op :: a, ...}
-		     | T2 { op :: a, ...}
-		     | T3
-
-	sel :: forall a b c. T a b c -> a
-	sel = /\ a b c -> \ T1 { sel = x } -> x
-			    T2 { sel = 2 } -> x
-
-Note that the selector Id itself is used as the field
-label; it has to be an Id, you see!
-
 \begin{code}
 mkRecordSelector tycon fields@((first_con, first_field_label) : other_fields)
 		-- These fields all have the same name, but are from
 		-- different constructors in the data type
-  = let
-	field_ty   = fieldLabelType first_field_label
-	field_name = fieldLabelName first_field_label
-	other_tys  = [fieldLabelType fl | (_, fl) <- other_fields]
-	(tyvars, _, _, _) = dataConSig first_con
-        data_ty  = applyTyCon tycon (mkTyVarTys tyvars)
-	-- tyvars of first_con may be free in field_ty
-    in
-   
 	-- Check that all the fields in the group have the same type
 	-- This check assumes that all the constructors of a given
 	-- data type use the same type variables
-    checkTc (all (eqTy field_ty) other_tys)
+  = checkTc (all (eqTy field_ty) other_tys)
 	    (fieldTypeMisMatch field_name)	`thenTc_`
-    
-	-- Create an Id for the field itself
-    tcInstTyVars tyvars			`thenNF_Tc` \ (tyvars', tyvar_tys, tenv) ->
-    tcInstType tenv field_ty		`thenNF_Tc` \ field_ty' ->
-    let
-      data_ty' = applyTyCon tycon tyvar_tys
-    in
-    newLocalId SLIT("x") field_ty'	`thenNF_Tc` \ field_id ->
-    newLocalId SLIT("r") data_ty'	`thenNF_Tc` \ record_id ->
-
-	-- Now build the selector
-    let
-      selector_ty :: Type
-      selector_ty  = mkForAllTys tyvars $	
-		     mkFunTy data_ty $
-		     field_ty
+    returnTc selector_id
+  where
+    field_ty   = fieldLabelType first_field_label
+    field_name = fieldLabelName first_field_label
+    other_tys  = [fieldLabelType fl | (_, fl) <- other_fields]
+    (tyvars, _, _, _) = dataConSig first_con
+    data_ty  = applyTyCon tycon (mkTyVarTys tyvars)
+    -- tyvars of first_con may be free in field_ty
+    -- Now build the selector
+
+    selector_ty :: Type
+    selector_ty  = mkForAllTys tyvars $	
+		   mkFunTy data_ty $
+		   field_ty
       
-      selector_id :: Id
-      selector_id = mkRecordSelId first_field_label selector_ty
-
-	-- HsSyn is dreadfully verbose for defining the selector!
-      selector_rhs = mkHsTyLam tyvars' $
-		     HsLam $
-		     PatMatch (VarPat record_id) $
-		     SimpleMatch $
-		     selector_body
-
-      selector_body = HsCase (HsVar record_id) (map mk_match fields) (getSrcLoc tycon)
-
-      mk_match (con_id, field_label) 
-    	= PatMatch (RecPat con_id data_ty' [(selector_id, VarPat field_id, False)]) $
-	  SimpleMatch $
-    	  HsVar field_id
-    in
-    returnTc (selector_id, if isLocallyDefinedName (getName tycon)
-			   then VarMonoBind (RealId selector_id) selector_rhs
-			   else EmptyMonoBinds)
+    selector_id :: Id
+    selector_id = mkRecordSelId first_field_label selector_ty
 \end{code}
 
 Constructors
@@ -360,7 +271,7 @@ tcConDecl tycon tyvars ctxt (ConOpDecl bty1 op bty2 src_loc)
 
 tcConDecl tycon tyvars ctxt (NewConDecl name ty src_loc)
   = tcAddSrcLoc src_loc	$
-    tcMonoType ty `thenTc` \ arg_ty ->
+    tcHsType ty `thenTc` \ arg_ty ->
     let
       data_con = mkDataCon (getName name)
 			   [NotMarkedStrict]
@@ -396,7 +307,7 @@ tcConDecl tycon tyvars ctxt (RecConDecl name fields src_loc)
     returnTc data_con
 
 tcField (field_label_names, bty)
-  = tcPolyType (get_pty bty)	`thenTc` \ field_ty ->
+  = tcHsType (get_pty bty)	`thenTc` \ field_ty ->
     returnTc [(name, field_ty, get_strictness bty) | name <- field_label_names]
 
 tcDataCon tycon tyvars ctxt name btys src_loc
@@ -405,7 +316,7 @@ tcDataCon tycon tyvars ctxt name btys src_loc
 	stricts = map get_strictness btys
 	tys	= map get_pty btys
     in
-    mapTc tcPolyType tys `thenTc` \ arg_tys ->
+    mapTc tcHsType tys `thenTc` \ arg_tys ->
     let
       data_con = mkDataCon (getName name)
 			   stricts
diff --git a/ghc/compiler/typecheck/TcType.lhs b/ghc/compiler/typecheck/TcType.lhs
index eff458dc8b..a340107abe 100644
--- a/ghc/compiler/typecheck/TcType.lhs
+++ b/ghc/compiler/typecheck/TcType.lhs
@@ -52,7 +52,7 @@ import Class	( GenClass )
 import Id	( idType )
 import Kind	( Kind )
 import TcKind	( TcKind )
-import TcMonad	hiding ( rnMtoTcM )
+import TcMonad
 import Usage	( SYN_IE(Usage), GenUsage, SYN_IE(UVar), duffUsage )
 
 import TysPrim		( voidTy )
diff --git a/ghc/compiler/typecheck/Unify.lhs b/ghc/compiler/typecheck/Unify.lhs
index 9fba979300..57b4a09d48 100644
--- a/ghc/compiler/typecheck/Unify.lhs
+++ b/ghc/compiler/typecheck/Unify.lhs
@@ -14,7 +14,7 @@ module Unify ( unifyTauTy, unifyTauTyList, unifyTauTyLists, unifyFunTy ) where
 IMP_Ubiq()
 
 -- friends: 
-import TcMonad	hiding ( rnMtoTcM )
+import TcMonad
 import Type	( GenType(..), typeKind, mkFunTy, getFunTy_maybe )
 import TyCon	( TyCon, mkFunTyCon )
 import TyVar	( GenTyVar(..), SYN_IE(TyVar), tyVarKind )
diff --git a/ghc/compiler/types/Class.lhs b/ghc/compiler/types/Class.lhs
index e7630b0539..ee57c76473 100644
--- a/ghc/compiler/types/Class.lhs
+++ b/ghc/compiler/types/Class.lhs
@@ -14,11 +14,7 @@ module Class (
 	classSuperDictSelId, classOpId, classDefaultMethodId,
 	classSig, classBigSig, classInstEnv,
 	isSuperClassOf,
-	classOpTagByString, classOpTagByString_maybe,
-
-	derivableClassKeys, needsDataDeclCtxtClassKeys,
-	cCallishClassKeys, isNoDictClass,
-	isNumericClass, isStandardClass, isCcallishClass,
+	classOpTagByOccName, classOpTagByOccName_maybe,
 
 	GenClassOp(..), SYN_IE(ClassOp),
 	mkClassOp,
@@ -38,10 +34,10 @@ import Usage		( GenUsage, SYN_IE(Usage), SYN_IE(UVar) )
 
 import MatchEnv		( MatchEnv )
 import Maybes		( assocMaybe )
-import Name		( changeUnique, Name )
+import Name		( changeUnique, Name, OccName, occNameString )
 import Unique		-- Keys for built-in classes
 import Pretty		( SYN_IE(Pretty), ppCat, ppPStr )
---import PprStyle		( PprStyle )
+import PprStyle		( PprStyle(..) )
 import SrcLoc		( SrcLoc )
 import Util
 \end{code}
@@ -59,7 +55,7 @@ get appropriately general instances of Ord3 for GenType.
 
 \begin{code}
 data GenClassOp ty
-  = ClassOp	FAST_STRING -- The operation name
+  = ClassOp	OccName	-- The operation name
 
 		Int	-- Unique within a class; starts at 1
 
@@ -175,77 +171,6 @@ clas `isSuperClassOf` (Class _ _ _ _ _ _ _ _ _ links) = assocMaybe links clas
 
 %************************************************************************
 %*									*
-\subsection[Class-std-groups]{Standard groups of Prelude classes}
-%*									*
-%************************************************************************
-
-@derivableClassKeys@ is also used in checking \tr{deriving} constructs
-(@TcDeriv@).
-
-NOTE: @Eq@ and @Text@ do need to appear in @standardClasses@
-even though every numeric class has these two as a superclass,
-because the list of ambiguous dictionaries hasn't been simplified.
-
-\begin{code}
-isNumericClass, isStandardClass :: Class -> Bool
-
-isNumericClass   (Class key _ _ _ _ _ _ _ _ _) = --pprTrace "isNum:" (ppCat (map pprUnique (key : numericClassKeys ))) $
-						 key `is_elem` numericClassKeys
-isStandardClass  (Class key _ _ _ _ _ _ _ _ _) = key `is_elem` standardClassKeys
-isCcallishClass	 (Class key _ _ _ _ _ _ _ _ _) = key `is_elem` cCallishClassKeys
-isNoDictClass    (Class key _ _ _ _ _ _ _ _ _) = key `is_elem` noDictClassKeys
-is_elem = isIn "is_X_Class"
-
-numericClassKeys
-  = [ numClassKey
-    , realClassKey
-    , integralClassKey
-    , fractionalClassKey
-    , floatingClassKey
-    , realFracClassKey
-    , realFloatClassKey
-    ]
-
-derivableClassKeys
-  = [ eqClassKey
-    , ordClassKey
-    , enumClassKey
-    , evalClassKey
-    , boundedClassKey
-    , showClassKey
-    , readClassKey
-    , ixClassKey
-    ]
-
-needsDataDeclCtxtClassKeys -- see comments in TcDeriv
-  = [ readClassKey
-    ]
-
-cCallishClassKeys = [ cCallableClassKey, cReturnableClassKey ]
-
-standardClassKeys
-  = derivableClassKeys ++ numericClassKeys ++ cCallishClassKeys
-    --
-    -- We have to have "CCallable" and "CReturnable" in the standard
-    -- classes, so that if you go...
-    --
-    --	    _ccall_ foo ... 93{-numeric literal-} ...
-    --
-    -- ... it can do The Right Thing on the 93.
-
-noDictClassKeys 	-- These classes are used only for type annotations;
-			-- they are not implemented by dictionaries, ever.
-  = cCallishClassKeys
-	-- I used to think that class Eval belonged in here, but
-	-- we really want functions with type (Eval a => ...) and that
-	-- means that we really want to pass a placeholder for an Eval
-	-- dictionary.  The unit tuple is what we'll get if we leave things
-	-- alone, and that'll do for now.  Could arrange to drop that parameter
-	-- in the end.
-\end{code}
-
-%************************************************************************
-%*									*
 \subsection[Class-instances]{Instance declarations for @Class@}
 %*									*
 %************************************************************************
@@ -274,6 +199,9 @@ instance Uniquable (GenClass tyvar uvar) where
 
 instance NamedThing (GenClass tyvar uvar) where
     getName (Class _ n _ _ _ _ _ _ _ _) = n
+
+instance NamedThing (GenClassOp ty) where
+    getOccName (ClassOp occ _ _) = occ
 \end{code}
 
 
@@ -316,14 +244,14 @@ object).  Of course, the type of @op@ recorded in the GVE will be its
 ******************************************************************
 
 \begin{code}
-mkClassOp :: FAST_STRING -> Int -> ty -> GenClassOp ty
+mkClassOp :: OccName -> Int -> ty -> GenClassOp ty
 mkClassOp name tag ty = ClassOp name tag ty
 
 classOpTag :: GenClassOp ty -> Int
 classOpTag    (ClassOp _ tag _) = tag
 
 classOpString :: GenClassOp ty -> FAST_STRING
-classOpString (ClassOp str _ _) = str
+classOpString (ClassOp occ _ _) = occNameString occ
 
 classOpLocalType :: GenClassOp ty -> ty {-SigmaType-}
 classOpLocalType (ClassOp _ _ ty) = ty
@@ -331,23 +259,23 @@ classOpLocalType (ClassOp _ _ ty) = ty
 
 Rather unsavoury ways of getting ClassOp tags:
 \begin{code}
-classOpTagByString_maybe :: Class -> FAST_STRING -> Maybe Int
-classOpTagByString       :: Class -> FAST_STRING -> Int
+classOpTagByOccName_maybe :: Class -> OccName -> Maybe Int
+classOpTagByOccName       :: Class -> OccName -> Int
 
-classOpTagByString clas op
-  = case (classOpTagByString_maybe clas op) of
+classOpTagByOccName clas op
+  = case (classOpTagByOccName_maybe clas op) of
       Just tag -> tag
 #ifdef DEBUG
-      Nothing  -> pprPanic "classOpTagByString:" (ppCat (ppPStr op : map (ppPStr . classOpString) (classOps clas)))
+      Nothing  -> pprPanic "classOpTagByOccName:" (ppCat (ppr PprDebug op : map (ppPStr . classOpString) (classOps clas)))
 #endif
 
-classOpTagByString_maybe clas op
-  = go (map classOpString (classOps clas)) 1
+classOpTagByOccName_maybe clas op
+  = go (classOps clas) 1
   where
-    go []     _   = Nothing
-    go (n:ns) tag = if n == op
-		    then Just tag
-		    else go ns (tag+1)
+    go []     		      _   = Nothing
+    go (ClassOp occ _ _ : ns) tag = if occ == op
+				    then Just tag
+				    else go ns (tag+1)
 \end{code}
 
 %************************************************************************
diff --git a/ghc/compiler/types/Kind.lhs b/ghc/compiler/types/Kind.lhs
index ab77d19805..cb29e48cce 100644
--- a/ghc/compiler/types/Kind.lhs
+++ b/ghc/compiler/types/Kind.lhs
@@ -17,7 +17,9 @@ module Kind (
 	hasMoreBoxityInfo,
 	resultKind, argKind,
 
-	isUnboxedKind, isTypeKind,
+	pprKind, pprParendKind,
+
+	isUnboxedTypeKind, isTypeKind, isBoxedTypeKind,
 	notArrowKind
     ) where
 
@@ -45,9 +47,13 @@ isTypeKind :: Kind -> Bool
 isTypeKind TypeKind = True
 isTypeKind other    = False
 
-isUnboxedKind :: Kind -> Bool
-isUnboxedKind UnboxedTypeKind 	= True
-isUnboxedKind other		= False
+isBoxedTypeKind :: Kind -> Bool
+isBoxedTypeKind BoxedTypeKind = True
+isBoxedTypeKind other         = False
+
+isUnboxedTypeKind :: Kind -> Bool
+isUnboxedTypeKind UnboxedTypeKind = True
+isUnboxedTypeKind other	 	  = False
 
 hasMoreBoxityInfo :: Kind -> Kind -> Bool
 
@@ -85,11 +91,11 @@ Printing
 instance Outputable Kind where
   ppr sty kind = pprKind kind
 
-pprKind TypeKind        = ppStr "*"
-pprKind BoxedTypeKind   = ppStr "*b"
-pprKind UnboxedTypeKind = ppStr "*u"
-pprKind (ArrowKind k1 k2) = ppSep [pprKind_parend k1, ppStr "->", pprKind k2]
+pprKind TypeKind        = ppStr "**"	-- Can be boxed or unboxed
+pprKind BoxedTypeKind   = ppStr "*"
+pprKind UnboxedTypeKind = ppStr "*#"	-- Unboxed
+pprKind (ArrowKind k1 k2) = ppSep [pprParendKind k1, ppStr "->", pprKind k2]
 
-pprKind_parend k@(ArrowKind _ _) = ppBesides [ppLparen, pprKind k, ppRparen]
-pprKind_parend k		 = pprKind k
+pprParendKind k@(ArrowKind _ _) = ppBesides [ppLparen, pprKind k, ppRparen]
+pprParendKind k		 	= pprKind k
 \end{code}
diff --git a/ghc/compiler/types/PprType.lhs b/ghc/compiler/types/PprType.lhs
index 1a7cfe35b6..7bb3928d63 100644
--- a/ghc/compiler/types/PprType.lhs
+++ b/ghc/compiler/types/PprType.lhs
@@ -7,14 +7,13 @@
 #include "HsVersions.h"
 
 module PprType(
-	GenTyVar, pprGenTyVar,
+	GenTyVar, pprGenTyVar, pprTyVarBndr,
 	TyCon, pprTyCon, showTyCon,
 	GenType,
 	pprGenType, pprParendGenType,
 	pprType, pprParendType,
 	pprMaybeTy,
 	getTypeString,
-	typeMaybeString,
 	specMaybeTysSuffix,
 	getTyDescription,
 	GenClass, 
@@ -37,15 +36,15 @@ import TyVar		( GenTyVar(..) )
 import TyCon		( TyCon(..), NewOrData )
 import Class		( SYN_IE(Class), GenClass(..),
 			  SYN_IE(ClassOp), GenClassOp(..) )
-import Kind		( Kind(..) )
+import Kind		( Kind(..), isBoxedTypeKind, pprParendKind )
 import Usage		( pprUVar, GenUsage(..), SYN_IE(Usage), SYN_IE(UVar) )
 
 -- others:
 import CStrings		( identToC )
 import CmdLineOpts	( opt_OmitInterfacePragmas )
 import Maybes		( maybeToBool )
-import Name		( isLexVarSym, isLexSpecialSym, origName, moduleOf,
-			  getLocalName, Name{-instance Outputable-}
+import Name		(  nameString, Name{-instance Outputable-}, 
+			   OccName, pprOccName, getOccString, pprNonSymOcc
 			)
 import Outputable	( ifPprShowAll, interpp'SP )
 import PprEnv
@@ -97,11 +96,12 @@ works just by setting the initial context precedence very high.
 pprGenType, pprParendGenType :: (Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar)
 		       => PprStyle -> GenType tyvar uvar -> Pretty
 
-pprGenType       sty ty = ppr_ty sty (init_ppr_env sty) tOP_PREC   ty
-pprParendGenType sty ty = ppr_ty sty (init_ppr_env sty) tYCON_PREC ty
+pprGenType       sty ty = ppr_ty (init_ppr_env sty) tOP_PREC   ty
+pprParendGenType sty ty = ppr_ty (init_ppr_env sty) tYCON_PREC ty
 
-pprType       	 sty ty = ppr_ty sty (init_ppr_env sty) tOP_PREC   (ty :: Type)
-pprParendType 	 sty ty = ppr_ty sty (init_ppr_env sty) tYCON_PREC (ty :: Type)
+pprType, pprParendType :: PprStyle -> Type -> Pretty
+pprType       	 sty ty = ppr_ty (init_ppr_env_type sty) tOP_PREC   ty
+pprParendType 	 sty ty = ppr_ty (init_ppr_env_type sty) tYCON_PREC ty
 
 pprMaybeTy :: (Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar)
            => PprStyle -> Maybe (GenType tyvar uvar) -> Pretty
@@ -110,132 +110,132 @@ pprMaybeTy sty (Just ty) = pprParendGenType sty ty
 \end{code}
 
 \begin{code}
-ppr_ty :: (Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar)
-       => PprStyle -> PprEnv tyvar uvar bndr occ -> Int
+ppr_ty :: PprEnv tyvar uvar bndr occ -> Int
        -> GenType tyvar uvar
        -> Pretty
 
-ppr_ty sty env ctxt_prec (TyVarTy tyvar)
-  = ppr_tyvar env tyvar
+ppr_ty env ctxt_prec (TyVarTy tyvar)
+  = pTyVarO env tyvar
 
-ppr_ty sty env ctxt_prec (TyConTy tycon usage)
-  = ppr sty tycon
+ppr_ty env ctxt_prec (TyConTy tycon usage)
+  = ppr_tycon env tycon
 
-ppr_ty sty env ctxt_prec ty@(ForAllTy _ _)
-  | showUserishTypes sty = ppr_ty sty env' ctxt_prec body_ty
-
-  | otherwise = ppSep [ ppPStr SLIT("_forall_"), 
-		        ppIntersperse pp'SP pp_tyvars,
-			ppPStr SLIT("=>"),
-			ppr_ty sty env' ctxt_prec body_ty
-		      ]
+ppr_ty env ctxt_prec ty@(ForAllTy _ _)
+  | show_forall = ppSep [ ppPStr SLIT("_forall_"), pp_tyvars, 
+			  pp_theta, ppPStr SLIT("=>"), pp_body
+		        ]
+  | null theta = pp_body
+  | otherwise  = ppSep [pp_theta, ppPStr SLIT("=>"), pp_body]
   where
-    (tyvars, body_ty) = splitForAllTy ty
-    env' 	      = foldl add_tyvar env tyvars
-    pp_tyvars	      = map (ppr_tyvar env') tyvars
-
-ppr_ty sty env ctxt_prec (ForAllUsageTy uv uvs ty)
+    (tyvars, rho_ty) = splitForAllTy ty
+    (theta, body_ty) | show_context = splitRhoTy rho_ty
+		     | otherwise    = ([], rho_ty)
+
+    pp_tyvars = ppBracket (ppIntersperse ppSP (map (pTyVarB env) tyvars))
+    pp_theta  | null theta = ppNil
+	      | otherwise  = ppCurlies (ppInterleave ppComma (map (ppr_dict env tOP_PREC) theta))
+    pp_body   = ppr_ty env ctxt_prec body_ty
+
+    sty = pStyle env
+    show_forall = case sty of
+			PprForUser -> False
+			other      -> True
+
+    show_context = case sty of
+			PprInterface -> True
+			PprForUser   -> True
+			other	     -> False
+
+ppr_ty env ctxt_prec (ForAllUsageTy uv uvs ty)
   = panic "ppr_ty:ForAllUsageTy"
 
-ppr_ty sty env ctxt_prec ty@(FunTy (DictTy _ _ _) _ _)
-  | showUserishTypes sty
-    -- Print a nice looking context  (Eq a, Text b) => ...
-  = ppSep [ppBeside (ppr_theta theta) (ppPStr SLIT(" =>")),
-	   ppr_ty sty env ctxt_prec body_ty
-    ]
-  where
-    (theta, body_ty) = splitRhoTy ty
-
-    ppr_theta = case sty of { PprInterface -> ppr_theta_2 ; _ -> ppr_theta_1 }
-
-    ppr_theta_1 [ct] = ppr_dict sty env tOP_PREC ct
-    ppr_theta_1 cts  = ppParens (ppInterleave ppComma (map (ppr_dict sty env tOP_PREC) cts))
-
-    ppr_theta_2 cts  = ppBesides [ppStr "{{", ppInterleave ppComma (map (ppr_dict sty env tOP_PREC) cts), ppStr "}}"]
-
-ppr_ty sty env ctxt_prec (FunTy ty1 ty2 usage)
+ppr_ty env ctxt_prec (FunTy ty1 ty2 usage)
     -- We fiddle the precedences passed to left/right branches,
     -- so that right associativity comes out nicely...
   = maybeParen ctxt_prec fUN_PREC
-	(ppCat [ppr_ty sty env fUN_PREC ty1,
+	(ppCat [ppr_ty env fUN_PREC ty1,
 		ppPStr SLIT("->"),
-		ppr_ty sty env tOP_PREC ty2])
+		ppr_ty env tOP_PREC ty2])
 
-ppr_ty sty env ctxt_prec ty@(AppTy _ _)
-  = ppr_corner sty env ctxt_prec fun_ty arg_tys
+ppr_ty env ctxt_prec ty@(AppTy _ _)
+  = ppr_corner env ctxt_prec fun_ty arg_tys
   where
     (fun_ty, arg_tys) = splitAppTy ty
 
-ppr_ty sty env ctxt_prec (SynTy tycon tys expansion)
-  | codeStyle sty
+ppr_ty env ctxt_prec (SynTy tycon tys expansion)
+  | codeStyle (pStyle env)
 	-- always expand types that squeak into C-variable names
-  = ppr_ty sty env ctxt_prec expansion
+  = ppr_ty env ctxt_prec expansion
 
   | otherwise
   = ppBeside
-     (ppr_app sty env ctxt_prec (ppr sty tycon) tys)
-     (ifPprShowAll sty (ppCat [ppStr " {- expansion:",
-			       ppr_ty sty env tOP_PREC expansion,
-			       ppStr "-}"]))
+     (ppr_app env ctxt_prec (ppr_tycon env tycon) tys)
+     (ifPprShowAll (pStyle env) (ppCat [ppStr " {- expansion:",
+			       		ppr_ty env tOP_PREC expansion,
+				        ppStr "-}"]))
+
+ppr_ty env ctxt_prec (DictTy clas ty usage)
+  = ppCurlies (ppr_dict env tOP_PREC (clas, ty))
+	-- Curlies are temporary
 
-ppr_ty sty env ctxt_prec (DictTy clas ty usage)
-  = ppr_dict sty env ctxt_prec (clas, ty)
 
 -- Some help functions
-ppr_corner sty env ctxt_prec (TyConTy FunTyCon usage) arg_tys
+ppr_corner env ctxt_prec (TyConTy FunTyCon usage) arg_tys
   | length arg_tys == 2
-  = ppr_ty sty env ctxt_prec (FunTy ty1 ty2 usage)
+  = ppr_ty env ctxt_prec (FunTy ty1 ty2 usage)
   where
     (ty1:ty2:_) = arg_tys
 
-ppr_corner sty env ctxt_prec (TyConTy (TupleTyCon _ _ a) usage) arg_tys
-  | not (codeStyle sty) -- no magic in that case
+ppr_corner env ctxt_prec (TyConTy (TupleTyCon _ _ a) usage) arg_tys
+  | not (codeStyle (pStyle env)) -- no magic in that case
   = --ASSERT(length arg_tys == a)
     --(if (length arg_tys /= a) then pprTrace "ppr_corner:" (ppCat [ppInt a, ppInterleave ppComma (map (pprGenType PprDebug) arg_tys)]) else id) $
     ppBesides [ppLparen, arg_tys_w_commas, ppRparen]
   where
-    arg_tys_w_commas = ppIntersperse pp'SP (map (ppr_ty sty env tOP_PREC) arg_tys)
+    arg_tys_w_commas = ppIntersperse pp'SP (map (ppr_ty env tOP_PREC) arg_tys)
 
-ppr_corner sty env ctxt_prec (TyConTy tycon usage) arg_tys
-  | not (codeStyle sty) && uniqueOf tycon == listTyConKey
+ppr_corner env ctxt_prec (TyConTy tycon usage) arg_tys
+  | not (codeStyle (pStyle env)) && uniqueOf tycon == listTyConKey
   = ASSERT(length arg_tys == 1)
-    ppBesides [ppLbrack, ppr_ty sty env tOP_PREC ty1, ppRbrack]		    
+    ppBesides [ppLbrack, ppr_ty env tOP_PREC ty1, ppRbrack]		    
   where
     (ty1:_) = arg_tys
 
-ppr_corner sty env ctxt_prec (TyConTy tycon usage) arg_tys
-  = ppr_app sty env ctxt_prec (ppr sty tycon) arg_tys
+ppr_corner env ctxt_prec (TyConTy tycon usage) arg_tys
+  = ppr_app env ctxt_prec (ppr_tycon env tycon) arg_tys
 		      
-ppr_corner sty env ctxt_prec (TyVarTy tyvar) arg_tys
-  = ppr_app sty env ctxt_prec (ppr_tyvar env tyvar) arg_tys
+ppr_corner env ctxt_prec (TyVarTy tyvar) arg_tys
+  = ppr_app env ctxt_prec (pTyVarO env tyvar) arg_tys
   
 
-ppr_app sty env ctxt_prec pp_fun []      
+ppr_app env ctxt_prec pp_fun []      
   = pp_fun
-ppr_app sty env ctxt_prec pp_fun arg_tys 
+ppr_app env ctxt_prec pp_fun arg_tys 
   = maybeParen ctxt_prec tYCON_PREC (ppCat [pp_fun, arg_tys_w_spaces])
   where
-    arg_tys_w_spaces = ppIntersperse ppSP (map (ppr_ty sty env tYCON_PREC) arg_tys)
+    arg_tys_w_spaces = ppIntersperse ppSP (map (ppr_ty env tYCON_PREC) arg_tys)
 
 
-ppr_dict sty env ctxt_prec (clas, ty)
+ppr_dict env ctxt_prec (clas, ty)
   = maybeParen ctxt_prec tYCON_PREC
-	(ppCat [ppr sty clas, ppr_ty sty env tYCON_PREC ty]) 
+	(ppCat [ppr_class env clas, ppr_ty env tYCON_PREC ty]) 
 \end{code}
 
-This stuff is effectively stubbed out for the time being
-(WDP 960425):
 \begin{code}
+	-- This one uses only "ppr"
 init_ppr_env sty
-  = initPprEnv sty b b b b b b b b b b b
+  = initPprEnv sty b b b b (Just (ppr sty)) (Just (ppr sty)) (Just (ppr sty)) b b b b b
   where
     b = panic "PprType:init_ppr_env"
 
-ppr_tyvar env tyvar = ppr (pStyle env) tyvar
-ppr_uvar  env uvar  = ppr (pStyle env) uvar
+	-- This one uses pprTyVarBndr, and thus is specific to GenTyVar's types
+init_ppr_env_type sty
+  = initPprEnv sty b b b b (Just (pprTyVarBndr sty)) (Just (ppr sty)) (Just (ppr sty)) b b b b b
+  where
+    b = panic "PprType:init_ppr_env"
 
-add_tyvar env tyvar = env
-add_uvar  env  uvar = env
+ppr_tycon  env tycon = ppr (pStyle env) tycon
+ppr_class  env clas  = ppr (pStyle env) clas
 \end{code}
 
 @ppr_ty@ takes an @Int@ that is the precedence of the context.
@@ -274,7 +274,7 @@ pprGenTyVar sty (TyVar uniq kind name usage)
   where
     pp_u    = pprUnique uniq
     pp_name = case name of
-		Just n  -> ppPStr (getLocalName n)
+		Just n  -> pprOccName sty (getOccName n)
 		Nothing -> case kind of
 				TypeKind        -> ppChar 'o'
 				BoxedTypeKind   -> ppChar 't'
@@ -282,6 +282,16 @@ pprGenTyVar sty (TyVar uniq kind name usage)
 				ArrowKind _ _   -> ppChar 'a'
 \end{code}
 
+We print type-variable binders with their kinds in interface files.
+
+\begin{code}
+pprTyVarBndr sty@PprInterface tyvar@(TyVar uniq kind name usage)
+  | not (isBoxedTypeKind kind)
+  = ppBesides [pprGenTyVar sty tyvar, ppStr "::", pprParendKind kind]
+
+pprTyVarBndr sty tyvar = pprGenTyVar sty tyvar
+\end{code}
+
 %************************************************************************
 %*									*
 \subsection[TyCon]{@TyCon@}
@@ -309,6 +319,14 @@ maybe_code sty x
     mangle '>' = ppPStr SLIT("Zg")
 
 pprTyCon :: PprStyle -> TyCon -> Pretty
+pprTyCon sty tycon = ppr sty (getName tycon)
+
+{-	This old code looks suspicious to me.  
+	Just printing the name should do the job; apart from the extra junk 
+	on SynTyCons etc. 
+
+	Let's try and live without all this...
+	Delete in due course.				SLPJ Nov 96
 
 pprTyCon sty (PrimTyCon _ name _ _) = ppr sty name
 
@@ -322,9 +340,6 @@ pprTyCon sty (TupleTyCon _ _ arity) = case arity of
 					n -> maybe_code sty ( "(" ++ nOfThem (n-1) ',' ++ ")" )
 
 pprTyCon sty tycon@(DataTyCon uniq name kind tyvars ctxt cons derivings nd)
-  | uniq == listTyConKey
-  = maybe_code sty "[]"
-  | otherwise
   = ppr sty name
 
 pprTyCon sty (SpecTyCon tc ty_maybes)
@@ -341,6 +356,7 @@ pprTyCon sty (SynTyCon uniq name kind arity tyvars expansion)
 			 interpp'SP sty tyvars,
 			 pprParendGenType sty expansion,
 			 ppStr "-}"]))
+-}
 \end{code}
 
 
@@ -363,10 +379,8 @@ ppr_class_op sty tyvars (ClassOp op_name i ty)
       PprShowAll    -> pp_sigd
       _		    -> pp_user
   where
-    pp_C    = ppPStr op_name
-    pp_user = if isLexVarSym op_name && not (isLexSpecialSym op_name)
-	      then ppParens pp_C
-	      else pp_C
+    pp_C    = ppr sty op_name
+    pp_user = pprNonSymOcc sty op_name
     pp_sigd = ppCat [pp_user, ppPStr SLIT("::"), ppr sty ty]
 \end{code}
 
@@ -383,50 +397,28 @@ ppr_class_op sty tyvars (ClassOp op_name i ty)
     -- Produces things like what we have in mkCompoundName,
     -- which can be "dot"ted together...
 
-getTypeString :: Type -> [Either OrigName FAST_STRING]
+getTypeString :: Type -> FAST_STRING
 
 getTypeString ty
   = case (splitAppTy ty) of { (tc, args) ->
-    do_tc tc : map do_arg_ty args }
+    _CONCAT_ (do_tc tc : map do_arg_ty args) }
   where
-    do_tc (TyConTy tc _) = Left (origName "do_tc" tc)
+    do_tc (TyConTy tc _) = nameString (getName tc)
     do_tc (SynTy _ _ ty) = do_tc ty
     do_tc other = --pprTrace "getTypeString:do_tc:" (pprType PprDebug other) $
-		  Right (_PK_ (ppShow 1000 (pprType PprForC other)))
+		  (_PK_ (ppShow 1000 (pprType PprForC other)))
 
-    do_arg_ty (TyConTy tc _) = Left (origName "do_arg_ty" tc)
-    do_arg_ty (TyVarTy tv)   = Right (_PK_ (ppShow 80 (ppr PprForC tv)))
+    do_arg_ty (TyConTy tc _) = nameString (getName tc)
+    do_arg_ty (TyVarTy tv)   = _PK_ (ppShow 80 (ppr PprForC tv))
     do_arg_ty (SynTy _ _ ty) = do_arg_ty ty
     do_arg_ty other	     = --pprTrace "getTypeString:do_arg_ty:" (pprType PprDebug other) $
-			       Right (_PK_ (ppShow 1000 (pprType PprForC other)))
+			       _PK_ (ppShow 1000 (pprType PprForC other))
 
 	-- PprForC expands type synonyms as it goes;
 	-- it also forces consistent naming of tycons
 	-- (e.g., can't have both "(,) a b" and "(a,b)":
 	-- must be consistent!
 
-    --------------------------------------------------
-    -- tidy: very ad-hoc
-    tidy [] = [] -- done
-
-    tidy (' ' : more)
-      = case more of
-	  ' ' : _	 -> tidy more
-	  '-' : '>' : xs -> '-' : '>' : tidy (no_leading_sps xs)
-	  other	    	 -> ' ' : tidy more
-
-    tidy (',' : more) = ',' : tidy (no_leading_sps more)
-
-    tidy (x : xs) = x : tidy xs  -- catch all
-
-    no_leading_sps [] = []
-    no_leading_sps (' ':xs) = no_leading_sps xs
-    no_leading_sps other = other
-
-typeMaybeString :: Maybe Type -> [Either OrigName FAST_STRING]
-typeMaybeString Nothing  = [Right SLIT("!")]
-typeMaybeString (Just t) = getTypeString t
-
 specMaybeTysSuffix :: [Maybe Type] -> FAST_STRING
 specMaybeTysSuffix ty_maybes
   = panic "PprType.specMaybeTysSuffix"
@@ -450,8 +442,8 @@ getTyDescription ty
       TyVarTy _	      -> "*"
       AppTy fun _     -> getTyDescription fun
       FunTy _ res _   -> '-' : '>' : fun_result res
-      TyConTy tycon _ -> _UNPK_ (getLocalName tycon)
-      SynTy tycon _ _ -> _UNPK_ (getLocalName tycon)
+      TyConTy tycon _ -> getOccString tycon
+      SynTy tycon _ _ -> getOccString tycon
       DictTy _ _ _    -> "dict"
       ForAllTy _ ty   -> getTyDescription ty
       _		      -> pprPanic "getTyDescription: other" (pprType PprDebug tau_ty)
diff --git a/ghc/compiler/types/TyCon.lhs b/ghc/compiler/types/TyCon.lhs
index e38da87182..d473ea48d7 100644
--- a/ghc/compiler/types/TyCon.lhs
+++ b/ghc/compiler/types/TyCon.lhs
@@ -44,7 +44,7 @@ IMPORT_DELOOPER(TyLoop)	( SYN_IE(Type), GenType,
 			  SYN_IE(Class), GenClass,
 			  SYN_IE(Id), GenId,
 			  splitSigmaTy, splitFunTy,
-			  mkTupleCon, isNullaryDataCon, idType
+			  tupleCon, isNullaryDataCon, idType
 			  --LATER: specMaybeTysSuffix
 			)
 
@@ -53,12 +53,12 @@ import Usage		( GenUsage, SYN_IE(Usage) )
 import Kind		( Kind, mkBoxedTypeKind, mkArrowKind, resultKind, argKind )
 
 import Maybes
-import Name		( Name, RdrName(..), appendRdr, nameUnique,
-			  mkTupleTyConName, mkFunTyConName
-			)
-import Unique		( Unique, funTyConKey, mkTupleTyConUnique )
+import Name		( Name, nameUnique, mkWiredInTyConName )
+import Unique		( Unique, funTyConKey )
 import Pretty		( SYN_IE(Pretty), PrettyRep )
 import PrimRep		( PrimRep(..) )
+import PrelMods		( gHC__, pREL_TUP, pREL_BASE )
+import Lex		( mkTupNameStr )
 import SrcLoc		( SrcLoc, mkBuiltinSrcLoc )
 import Util		( nOfThem, isIn, Ord3(..), panic, panic#, assertPanic )
 --import {-hide me-}
@@ -124,14 +124,11 @@ data NewOrData
 \end{code}
 
 \begin{code}
-mkFunTyCon   = FunTyCon
-mkSpecTyCon  = SpecTyCon
+mkFunTyCon     = FunTyCon
+mkFunTyConName = mkWiredInTyConName funTyConKey gHC__ SLIT("->") FunTyCon
 
-mkTupleTyCon arity
-  = TupleTyCon u n arity 
-  where
-    n = mkTupleTyConName arity
-    u = uniqueOf n
+mkSpecTyCon  = SpecTyCon
+mkTupleTyCon = TupleTyCon
 
 mkDataTyCon name = DataTyCon (nameUnique name) name
 mkPrimTyCon name = PrimTyCon (nameUnique name) name
@@ -229,7 +226,7 @@ tyConDataCons :: TyCon -> [Id]
 tyConFamilySize  :: TyCon -> Int
 
 tyConDataCons (DataTyCon _ _ _ _ _ data_cons _ _) = data_cons
-tyConDataCons (TupleTyCon _ _ a)		  = [mkTupleCon a]
+tyConDataCons (TupleTyCon _ _ a)		  = [tupleCon a]
 tyConDataCons other				  = []
 	-- You may think this last equation should fail,
 	-- but it's quite convenient to return no constructors for
@@ -267,7 +264,7 @@ getSynTyConDefn (SynTyCon _ _ _ _ tyvars ty) = (tyvars,ty)
 \begin{code}
 maybeTyConSingleCon :: TyCon -> Maybe Id
 
-maybeTyConSingleCon (TupleTyCon _ _ arity)        = Just (mkTupleCon arity)
+maybeTyConSingleCon (TupleTyCon _ _ arity)        = Just (tupleCon arity)
 maybeTyConSingleCon (DataTyCon _ _ _ _ _ [c] _ _) = Just c
 maybeTyConSingleCon (DataTyCon _ _ _ _ _ _   _ _) = Nothing
 maybeTyConSingleCon (PrimTyCon _ _ _ _)	          = Nothing
@@ -344,4 +341,5 @@ instance NamedThing TyCon where
     getName	other_tc           = moduleNamePair (expectJust "tycon1" (getName other_tc))
     getName other			     = Nothing
 -}
+
 \end{code}
diff --git a/ghc/compiler/types/TyLoop.lhi b/ghc/compiler/types/TyLoop.lhi
index 31e348c7b7..1086dec90e 100644
--- a/ghc/compiler/types/TyLoop.lhi
+++ b/ghc/compiler/types/TyLoop.lhi
@@ -8,8 +8,9 @@ import PreludeStdIO ( Maybe )
 import Unique ( Unique )
 
 import FieldLabel ( FieldLabel )
-import Id      ( Id, GenId, StrictnessMark, mkTupleCon, mkDataCon,
+import Id      ( Id, GenId, StrictnessMark, mkDataCon, mkTupleCon,
 		 isNullaryDataCon, dataConArgTys, idType )
+import TysWiredIn ( tupleCon, tupleTyCon )
 import PprType ( specMaybeTysSuffix )
 import Name    ( Name )
 import TyCon   ( TyCon )
@@ -31,7 +32,7 @@ type Class = GenClass (GenTyVar (GenUsage Unique)) Unique
 type Id	   = GenId (GenType (GenTyVar (GenUsage Unique)) Unique)
 
 -- Needed in TyCon
-mkTupleCon :: Int -> Id
+tupleCon :: Int -> Id
 isNullaryDataCon :: Id -> Bool
 specMaybeTysSuffix :: [Maybe Type] -> _PackedString
 idType :: Id -> Type
@@ -40,6 +41,7 @@ splitFunTy   :: GenType t u -> ([GenType t u], GenType t u)
 instance Eq (GenClass a b)
 
 -- Needed in Type
+tupleTyCon :: Int -> TyCon
 dataConArgTys :: Id -> [Type] -> [Type]
 voidTy :: Type
 
@@ -48,4 +50,5 @@ data StrictnessMark = MarkedStrict | NotMarkedStrict
 mkDataCon :: Name -> [StrictnessMark] -> [FieldLabel]
 	  -> [TyVar] -> [(Class,Type)] -> [Type] -> TyCon
 	  -> Id
+mkTupleCon ::  Int -> Name -> Type -> Id
 \end{code}
diff --git a/ghc/compiler/types/TyVar.lhs b/ghc/compiler/types/TyVar.lhs
index b7fc8b7d58..fd59f96ef6 100644
--- a/ghc/compiler/types/TyVar.lhs
+++ b/ghc/compiler/types/TyVar.lhs
@@ -35,11 +35,11 @@ import UniqSet		-- nearly all of it
 import UniqFM		( emptyUFM, listToUFM, addToUFM, lookupUFM,
 			  plusUFM, sizeUFM, delFromUFM, UniqFM
 			)
-import Name		( mkLocalName, changeUnique, Name, RdrName(..) )
+import Name		( mkSysLocalName, changeUnique, Name )
 import Pretty		( SYN_IE(Pretty), PrettyRep, ppBeside, ppPStr )
 import PprStyle		( PprStyle )
 --import Outputable	( Outputable(..), NamedThing(..), ExportFlag(..) )
-import SrcLoc		( mkUnknownSrcLoc, SrcLoc )
+import SrcLoc		( noSrcLoc, SrcLoc )
 import Unique		( showUnique, mkAlphaTyVarUnique, Unique )
 import Util		( panic, Ord3(..) )
 \end{code}
@@ -162,5 +162,5 @@ instance Uniquable (GenTyVar a) where
 
 instance NamedThing (GenTyVar a) where
     getName (TyVar _ _ (Just n) _) = n
-    getName (TyVar u _ _        _) = mkLocalName u (showUnique u) True{-emph uniq-} mkUnknownSrcLoc
+    getName (TyVar u _ _        _) = mkSysLocalName u SLIT("t") noSrcLoc
 \end{code}
diff --git a/ghc/compiler/types/Type.lhs b/ghc/compiler/types/Type.lhs
index d63cecc64d..daee1722ff 100644
--- a/ghc/compiler/types/Type.lhs
+++ b/ghc/compiler/types/Type.lhs
@@ -37,7 +37,7 @@ module Type (
 
 	isTauTy,
 
-	tyVarsOfType, tyVarsOfTypes, typeKind
+	tyVarsOfType, tyVarsOfTypes, namesOfType, typeKind
     ) where
 
 IMP_Ubiq()
@@ -48,7 +48,7 @@ IMPORT_DELOOPER(TyLoop)
 -- friends:
 import Class	( classSig, classOpLocalType, GenClass{-instances-} )
 import Kind	( mkBoxedTypeKind, resultKind, notArrowKind, Kind )
-import TyCon	( mkFunTyCon, mkTupleTyCon, isFunTyCon,
+import TyCon	( mkFunTyCon, isFunTyCon,
 		  isPrimTyCon, isDataTyCon, isSynTyCon, maybeNewTyCon, isNewTyCon,
 		  tyConKind, tyConDataCons, getSynTyConDefn, TyCon )
 import TyVar	( tyVarKind, GenTyVar{-instances-}, SYN_IE(GenTyVarSet),
@@ -59,6 +59,10 @@ import Usage	( usageOmega, GenUsage, SYN_IE(Usage), SYN_IE(UVar), SYN_IE(UVarEnv
 		  nullUVarEnv, addOneToUVarEnv, lookupUVarEnv, eqUVar,
 		  eqUsage )
 
+import Name	( NamedThing(..), 
+		  NameSet(..), unionNameSets, emptyNameSet, unitNameSet, minusNameSet
+		)
+
 -- others
 import Maybes	( maybeToBool, assocMaybe )
 import PrimRep	( PrimRep(..) )
@@ -159,7 +163,7 @@ expandTy (DictTy clas ty u)
 		-- no methods!
 
 	other -> ASSERT(not (null all_arg_tys))
-	    	foldl AppTy (TyConTy (mkTupleTyCon (length all_arg_tys)) u) all_arg_tys
+	    	foldl AppTy (TyConTy (tupleTyCon (length all_arg_tys)) u) all_arg_tys
 
 		-- A tuple of 'em
 		-- Note: length of all_arg_tys can be 0 if the class is
@@ -245,6 +249,10 @@ getFunTyExpandingDicts_maybe peek
 	(AppTy (AppTy (TyConTy tycon _) arg) res) | isFunTyCon tycon = Just (arg, res)
 getFunTyExpandingDicts_maybe peek (SynTy _ _ t)	    = getFunTyExpandingDicts_maybe peek t
 getFunTyExpandingDicts_maybe peek ty@(DictTy _ _ _) = getFunTyExpandingDicts_maybe peek (expandTy ty)
+
+getFunTyExpandingDicts_maybe True (ForAllTy _ ty)   = getFunTyExpandingDicts_maybe True ty
+	-- Ignore for-alls when peeking.  See note with defn of getFunTyExpandingDictsAndPeeking
+
 getFunTyExpandingDicts_maybe peek other
   | not peek = Nothing -- that was easy
   | otherwise
@@ -266,6 +274,12 @@ splitFunTyExpandingDictsAndPeeking :: Type	  -> ([Type], Type)
 splitFunTy		           t = split_fun_ty getFunTy_maybe			 t
 splitFunTyExpandingDicts           t = split_fun_ty (getFunTyExpandingDicts_maybe False) t
 splitFunTyExpandingDictsAndPeeking t = split_fun_ty (getFunTyExpandingDicts_maybe True)  t
+	-- This "peeking" stuff is used only by the code generator.
+	-- It's interested in the representation type of things, ignoring:
+	--	newtype
+	--	foralls
+	-- 	expanding dictionary reps
+	--	synonyms, of course
 
 split_fun_ty get t = go t []
   where
@@ -534,6 +548,19 @@ tyVarsOfType (ForAllUsageTy _ _ ty)	= tyVarsOfType ty
 
 tyVarsOfTypes :: [GenType (GenTyVar flexi) uvar] -> GenTyVarSet flexi
 tyVarsOfTypes tys = foldr (unionTyVarSets.tyVarsOfType) emptyTyVarSet tys
+
+-- Find the free names of a type, including the type constructors and classes it mentions
+namesOfType :: GenType (GenTyVar flexi) uvar -> NameSet
+namesOfType (TyVarTy tv)		= unitNameSet (getName tv)
+namesOfType (TyConTy tycon usage)	= unitNameSet (getName tycon)
+namesOfType (SynTy tycon tys ty)	= unitNameSet (getName tycon) `unionNameSets`
+					  namesOfType ty
+namesOfType (FunTy arg res _)		= namesOfType arg `unionNameSets` namesOfType res
+namesOfType (AppTy fun arg)		= namesOfType fun `unionNameSets` namesOfType arg
+namesOfType (DictTy clas ty _)		= unitNameSet (getName clas) `unionNameSets`
+					  namesOfType ty
+namesOfType (ForAllTy tyvar ty)		= namesOfType ty `minusNameSet` unitNameSet (getName tyvar)
+namesOfType (ForAllUsageTy _ _ ty)	= panic "forall usage"
 \end{code}
 
 
diff --git a/ghc/compiler/utils/FiniteMap.lhs b/ghc/compiler/utils/FiniteMap.lhs
index d8c59893f5..f28185638f 100644
--- a/ghc/compiler/utils/FiniteMap.lhs
+++ b/ghc/compiler/utils/FiniteMap.lhs
@@ -54,9 +54,9 @@ module FiniteMap (
 	minusFM,
 	foldFM,
 
-	IF_NOT_GHC(intersectFM COMMA)
-	IF_NOT_GHC(intersectFM_C COMMA)
-	IF_NOT_GHC(mapFM COMMA filterFM COMMA)
+	intersectFM,
+	intersectFM_C,
+	mapFM, filterFM,
 
 	sizeFM, isEmptyFM, elemFM, lookupFM, lookupWithDefaultFM,
 
@@ -69,14 +69,17 @@ module FiniteMap (
 #endif
     ) where
 
+IMPORT_DELOOPER(SpecLoop)
 import Maybes
+import Bag	  ( Bag, foldBag )
+import Outputable ( Outputable(..) )
 
-#ifdef COMPILING_GHC
-IMP_Ubiq(){-uitous-}
 # ifdef DEBUG
-import Pretty
+import PprStyle	( PprStyle )
+import Pretty	( SYN_IE(Pretty), PrettyRep )
 # endif
-import Bag	( foldBag )
+
+#ifdef COMPILING_GHC
 
 # if ! OMIT_NATIVE_CODEGEN
 #  define IF_NCG(a) a
@@ -144,8 +147,8 @@ minusFM		:: (Ord key OUTPUTABLE_key) => FiniteMap key elt -> FiniteMap key elt -
 		   -- (minusFM a1 a2) deletes from a1 any bindings which are bound in a2
 
 intersectFM	:: (Ord key OUTPUTABLE_key) => FiniteMap key elt -> FiniteMap key elt -> FiniteMap key elt
-intersectFM_C	:: (Ord key OUTPUTABLE_key) => (elt -> elt -> elt)
-			   -> FiniteMap key elt -> FiniteMap key elt -> FiniteMap key elt
+intersectFM_C	:: (Ord key OUTPUTABLE_key) => (elt -> elt -> elt2)
+			   -> FiniteMap key elt -> FiniteMap key elt -> FiniteMap key elt2
 
 --	MAPPING, FOLDING, FILTERING
 foldFM		:: (key -> elt -> a -> a) -> a -> FiniteMap key elt -> a
diff --git a/ghc/compiler/utils/Maybes.lhs b/ghc/compiler/utils/Maybes.lhs
index 1f17679019..a3834fd1a2 100644
--- a/ghc/compiler/utils/Maybes.lhs
+++ b/ghc/compiler/utils/Maybes.lhs
@@ -38,9 +38,10 @@ module Maybes (
 
 #if defined(COMPILING_GHC)
 
-CHK_Ubiq() -- debugging consistency check
+CHK_Ubiq()			-- debugging consistency check
 
-import Unique (Unique) -- only for specialising
+IMPORT_DELOOPER( SpecLoop )	-- Specialisation
+import Unique  (Unique)		-- only for specialising
 
 #else
 import Maybe -- renamer will tell us if there are any conflicts
@@ -140,7 +141,6 @@ assocMaybe alist key
 	:: [(FAST_STRING,   b)] -> FAST_STRING -> Maybe b
 	 , [(Int,           b)] -> Int         -> Maybe b
 	 , [(Unique,        b)] -> Unique      -> Maybe b
-	 , [(RdrName,       b)] -> RdrName     -> Maybe b
   #-}
 #endif
 \end{code}
diff --git a/ghc/compiler/utils/PprStyle.lhs b/ghc/compiler/utils/PprStyle.lhs
index b8ee2ed8ea..dfb4ec27ad 100644
--- a/ghc/compiler/utils/PprStyle.lhs
+++ b/ghc/compiler/utils/PprStyle.lhs
@@ -8,7 +8,7 @@
 
 module PprStyle (
 	PprStyle(..),
-	codeStyle,
+	codeStyle, ifaceStyle,
 	showUserishTypes
     ) where
 
@@ -39,19 +39,22 @@ style).  The most likely ones are variations on how much type info is
 shown.
 
 The following test decides whether or not we are actually generating
-code (either C or assembly).
+code (either C or assembly), or generating interface files.
 \begin{code}
 codeStyle :: PprStyle -> Bool
 
 codeStyle PprForC	  = True
 codeStyle (PprForAsm _ _) = True
 codeStyle _		  = False
+
+ifaceStyle :: PprStyle -> Bool
+ifaceStyle PprInterface	  = True
+ifaceStyle other	  = False
 \end{code}
 
 \begin{code}
 -- True means types like   (Eq a, Text b) => a -> b
 -- False means types like  _forall_ a b => Eq a -> Text b -> a -> b
 showUserishTypes PprForUser   = True	
-showUserishTypes PprInterface = True
 showUserishTypes other	      = False
 \end{code}
diff --git a/ghc/compiler/utils/Pretty.lhs b/ghc/compiler/utils/Pretty.lhs
index ad2a76fb9d..8bfd952b36 100644
--- a/ghc/compiler/utils/Pretty.lhs
+++ b/ghc/compiler/utils/Pretty.lhs
@@ -27,7 +27,7 @@ module Pretty (
 #endif
 	ppSP, pp'SP, ppLbrack, ppRbrack, ppLparen, ppRparen,
 	ppSemi, ppComma, ppEquals,
-	ppBracket, ppParens, ppQuote,
+	ppBracket, ppParens, ppQuote, ppCurlies,
 
 	ppCat, ppBeside, ppBesides, ppAbove, ppAboves,
 	ppNest, ppSep, ppHang, ppInterleave, ppIntersperse,
@@ -168,6 +168,7 @@ ppEquals  = ppChar '='
 
 ppBracket p = ppBeside ppLbrack (ppBeside p ppRbrack)
 ppParens  p = ppBeside ppLparen (ppBeside p ppRparen)
+ppCurlies p = ppBeside (ppChar '{') (ppBeside p (ppChar '}'))
 ppQuote   p = ppBeside (ppChar '`') (ppBeside p (ppChar '\''))
 
 ppInterleave sep ps = ppSep (pi ps)
diff --git a/ghc/compiler/utils/SST.lhs b/ghc/compiler/utils/SST.lhs
index 4c4cbb4996..e574a842e6 100644
--- a/ghc/compiler/utils/SST.lhs
+++ b/ghc/compiler/utils/SST.lhs
@@ -11,6 +11,7 @@ module SST(
 	thenSST, thenSST_, returnSST, fixSST,
 	thenFSST, thenFSST_, returnFSST, failFSST,
 	recoverFSST, recoverSST, fixFSST,
+	unsafeInterleaveSST, 
 
 	newMutVarSST, readMutVarSST, writeMutVarSST
 #if __GLASGOW_HASKELL__ >= 200
@@ -70,6 +71,11 @@ stToSST st s
 runSST :: SST REAL_WORLD r  -> r
 runSST m = case m realWorld# of SST_R r s -> r
 
+unsafeInterleaveSST :: SST s r -> SST s r
+unsafeInterleaveSST m s = SST_R r s		-- Duplicates the state!
+			where
+			  SST_R r _ = m s
+
 returnSST :: r -> SST s r
 thenSST   :: SST s r -> (r -> State# s -> b) -> State# s -> b
 thenSST_  :: SST s r -> (State# s -> b) -> State# s -> b
diff --git a/ghc/compiler/utils/Ubiq.lhi b/ghc/compiler/utils/Ubiq.lhi
index 0ffea8b5f4..aaf4be1c20 100644
--- a/ghc/compiler/utils/Ubiq.lhi
+++ b/ghc/compiler/utils/Ubiq.lhi
@@ -21,24 +21,23 @@ import CostCentre	( CostCentre )
 import FieldLabel	( FieldLabel )
 import FiniteMap	( FiniteMap )
 import HeapOffs		( HeapOffset )
-import HsCore		( UnfoldingCoreExpr )
 import HsPat		( OutPat )
 import HsPragmas	( ClassOpPragmas, ClassPragmas, DataPragmas, GenPragmas, InstancePragmas )
 import Id		( StrictnessMark, GenId, Id(..) )
-import IdInfo		( IdInfo, OptIdInfo(..), ArityInfo, DeforestInfo, Demand, StrictnessInfo, UpdateInfo )
+import IdInfo		( IdInfo, ArityInfo, DeforestInfo, StrictnessInfo, UpdateInfo )
+import Demand		( Demand )
 import Kind		( Kind )
 import Literal		( Literal )
 import MachRegs		( Reg )
 import Maybes		( MaybeErr )
 import MatchEnv 	( MatchEnv )
-import Name		( Module(..), OrigName, RdrName, Name, ExportFlag, NamedThing(..) )
+import Name		( Module(..), OccName, Name, ExportFlag, NamedThing(..) )
 import Outputable	( Outputable(..) )
 import PprStyle		( PprStyle )
 import PragmaInfo	( PragmaInfo )
 import Pretty		( PrettyRep )
 import PrimOp		( PrimOp )
 import PrimRep		( PrimRep )
-import RnHsSyn		( RnName )
 import SMRep		( SMRep )
 import SrcLoc		( SrcLoc )
 import TcType		( TcMaybe )
@@ -55,12 +54,9 @@ import Util		( Ord3(..) )
 -- to try to contain their visibility.
 
 class NamedThing a where
-	getName :: a -> Name
-class OptIdInfo a where
-	noInfo	:: a
-	getInfo	:: IdInfo -> a
-	addInfo	:: IdInfo -> a -> IdInfo
-	ppInfo	:: PprStyle -> (Id -> Id) -> a -> Int -> Bool -> PrettyRep
+	getOccName :: a -> OccName
+	getName    :: a -> Name
+
 class Ord3 a where
 	cmp :: a -> a -> Int#
 class Outputable a where
@@ -111,8 +107,7 @@ data Literal
 data MaybeErr a b
 data MatchEnv a b
 data Name
-data OrigName = OrigName _PackedString _PackedString
-data RdrName = Unqual _PackedString | Qual _PackedString _PackedString
+data OccName
 data Reg
 data OutPat a b c
 data PprStyle
@@ -120,16 +115,14 @@ data PragmaInfo
 data PrettyRep
 data PrimOp
 data PrimRep	-- NB: an enumeration
-data RnName
 data SimplifierSwitch
 data SMRep
 data SrcLoc
-data StrictnessInfo
+data StrictnessInfo bdee
 data StrictnessMark
 data SwitchResult
 data TcMaybe s
 data TyCon
-data UnfoldingCoreExpr a
 data UniqFM a
 data UpdateInfo
 data UniqSupply
@@ -150,19 +143,13 @@ type Usage = GenUsage Unique
 
 -- These are here only for SPECIALIZing in FiniteMap (ToDo:move?)
 instance Ord Reg
-instance Ord OrigName
-instance Ord RdrName
 instance Ord CLabel
 instance Ord TyCon
 instance Eq Reg
-instance Eq OrigName
-instance Eq RdrName
 instance Eq CLabel
 instance Eq TyCon
 -- specializing in UniqFM, UniqSet
 instance Uniquable Unique
-instance Uniquable RnName
 instance Uniquable Name
 -- specializing in Name
-instance NamedThing RnName
 \end{code}
diff --git a/ghc/compiler/utils/UniqFM.lhs b/ghc/compiler/utils/UniqFM.lhs
index 6374705f25..8f9e9f907a 100644
--- a/ghc/compiler/utils/UniqFM.lhs
+++ b/ghc/compiler/utils/UniqFM.lhs
@@ -52,12 +52,13 @@ module UniqFM (
     ) where
 
 #if defined(COMPILING_GHC)
-IMP_Ubiq(){-uitous-}
+IMPORT_DELOOPER( SpecLoop )
 #endif
 
 import Unique		( Unique, u2i, mkUniqueGrimily )
 import Util
 import Pretty		( SYN_IE(Pretty), PrettyRep )
+import Outputable	( Outputable(..) )
 import PprStyle		( PprStyle )
 import SrcLoc		( SrcLoc )
 
@@ -141,27 +142,20 @@ ufmToList	:: UniqFM elt -> [(Unique, elt)]
 
 {-# SPECIALIZE
     addListToUFM :: UniqFM elt -> [(Name,   elt)] -> UniqFM elt
-		  , UniqFM elt -> [(RnName, elt)] -> UniqFM elt
   #-}
 {-# SPECIALIZE
     addListToUFM_C :: (elt -> elt -> elt) -> UniqFM elt -> [(Name,  elt)] -> UniqFM elt
-		    , (elt -> elt -> elt) -> UniqFM elt -> [(RnName,elt)] -> UniqFM elt
   #-}
 {-# SPECIALIZE
     addToUFM	:: UniqFM elt -> Unique -> elt  -> UniqFM elt
   #-}
 {-# SPECIALIZE
     listToUFM	:: [(Unique, elt)]     -> UniqFM elt
-		 , [(RnName, elt)]     -> UniqFM elt
   #-}
 {-# SPECIALIZE
     lookupUFM	:: UniqFM elt -> Name   -> Maybe elt
-		 , UniqFM elt -> RnName -> Maybe elt
 		 , UniqFM elt -> Unique -> Maybe elt
   #-}
-{-# SPECIALIZE
-    lookupWithDefaultUFM :: UniqFM elt -> elt -> RnName -> elt
-  #-}
 
 #endif {- __GLASGOW_HASKELL__ -}
 \end{code}
diff --git a/ghc/compiler/utils/UniqSet.lhs b/ghc/compiler/utils/UniqSet.lhs
index 5d892fb2e8..122e71da83 100644
--- a/ghc/compiler/utils/UniqSet.lhs
+++ b/ghc/compiler/utils/UniqSet.lhs
@@ -14,18 +14,19 @@ module UniqSet (
 	SYN_IE(UniqSet),    -- abstract type: NOT
 
 	mkUniqSet, uniqSetToList, emptyUniqSet, unitUniqSet,
-	addOneToUniqSet,
+	addOneToUniqSet, addListToUniqSet,
 	unionUniqSets, unionManyUniqSets, minusUniqSet,
 	elementOfUniqSet, mapUniqSet, intersectUniqSets,
-	isEmptyUniqSet
+	isEmptyUniqSet, filterUniqSet, sizeUniqSet
     ) where
 
-IMP_Ubiq(){-uitous-}
+IMPORT_DELOOPER( SpecLoop )
 
 import Maybes		( maybeToBool )
 import UniqFM
 import Unique		( Unique )
 import SrcLoc		( SrcLoc )
+import Outputable	( Outputable(..) )
 import Pretty		( SYN_IE(Pretty), PrettyRep )
 import PprStyle		( PprStyle )
 import Util		( Ord3(..) )
@@ -65,7 +66,10 @@ mkUniqSet :: Uniquable a => [a]  -> UniqSet a
 mkUniqSet xs = MkUniqSet (listToUFM [ (x, x) | x <- xs])
 
 addOneToUniqSet :: Uniquable a => UniqSet a -> a -> UniqSet a
-addOneToUniqSet set x = set `unionUniqSets` unitUniqSet x
+addOneToUniqSet (MkUniqSet set) x = MkUniqSet (addToUFM set x x)
+
+addListToUniqSet :: Uniquable a => UniqSet a -> [a] -> UniqSet a
+addListToUniqSet (MkUniqSet set) xs = MkUniqSet (addListToUFM set [(x,x) | x<-xs])
 
 unionUniqSets :: UniqSet a -> UniqSet a -> UniqSet a
 unionUniqSets (MkUniqSet set1) (MkUniqSet set2) = MkUniqSet (plusUFM set1 set2)
@@ -79,12 +83,18 @@ unionManyUniqSets (s:ss) = s `unionUniqSets` unionManyUniqSets ss
 minusUniqSet  :: UniqSet a -> UniqSet a -> UniqSet a
 minusUniqSet (MkUniqSet set1) (MkUniqSet set2) = MkUniqSet (minusUFM set1 set2)
 
+filterUniqSet :: (a -> Bool) -> UniqSet a -> UniqSet a
+filterUniqSet pred (MkUniqSet set) = MkUniqSet (filterUFM pred set)
+
 intersectUniqSets :: UniqSet a -> UniqSet a -> UniqSet a
 intersectUniqSets (MkUniqSet set1) (MkUniqSet set2) = MkUniqSet (intersectUFM set1 set2)
 
 elementOfUniqSet :: Uniquable a => a -> UniqSet a -> Bool
 elementOfUniqSet x (MkUniqSet set) = maybeToBool (lookupUFM set x)
 
+sizeUniqSet :: UniqSet a -> Int
+sizeUniqSet (MkUniqSet set) = sizeUFM set
+
 isEmptyUniqSet :: UniqSet a -> Bool
 isEmptyUniqSet (MkUniqSet set) = isNullUFM set {-SLOW: sizeUFM set == 0-}
 
@@ -103,15 +113,15 @@ mapUniqSet f (MkUniqSet set)
     addOneToUniqSet :: UniqSet Unique -> Unique -> UniqSet Unique
     #-}
 {-# SPECIALIZE
-    elementOfUniqSet :: RnName -> UniqSet RnName -> Bool
+    elementOfUniqSet :: Name -> UniqSet Name -> Bool
 		      , Unique -> UniqSet Unique -> Bool
     #-}
 {-# SPECIALIZE
-    mkUniqSet :: [RnName] -> UniqSet RnName
+    mkUniqSet :: [Name] -> UniqSet Name
     #-}
 
 {-# SPECIALIZE
-    unitUniqSet :: RnName -> UniqSet RnName
+    unitUniqSet :: Name -> UniqSet Name
 		 , Unique -> UniqSet Unique
     #-}
 #endif
diff --git a/ghc/docs/state_interface/state-interface.verb b/ghc/docs/state_interface/state-interface.verb
index 291d5f0109..56a7df884f 100644
--- a/ghc/docs/state_interface/state-interface.verb
+++ b/ghc/docs/state_interface/state-interface.verb
@@ -8,23 +8,112 @@
 
 \begin{document}
 
-\title{GHC prelude: types and operations}
-\author{Simon L Peyton Jones \and John Launchbury \and Will Partain}
+\title{The GHC Prelude and Libraries}
+\author{Simon L Peyton Jones \and Will Partain}
 
 \maketitle
 \tableofcontents
 
-This ``state interface document'' corresponds to Glasgow Haskell
-version~2.01.
+\section{Introduction}
 
-\section{Really primitive stuff}
+This document describes GHC's prelude and libraries.  The basic story is that of
+the Haskell 1.3 Report and Libraries document (which we do not reproduce here),
+but this document describes in addition:
+\begin{itemize}
+\item	GHC's additional non-standard libraries and types, such as state transformers,
+	packed strings, foreign objects, stable pointers, and so on.
+
+\item	GHC's primitive types and operations.  The standard Haskell functions are implemented
+	on top of these, and it is sometimes useful to use them directly.
+
+\item	The organsiation of these libraries into directories.
+\end{itemize}
+
+\section{Overview}
+
+The libraries are organised into the following three groups, each of which
+is kept in a separate sub-directory of GHC's installed @lib/@ directory:
+\begin{description}
+\item[@lib/required/@]  These are the libraries {\em required} by the Haskell
+definition.  All are defined by the Haskell Report, or by the Haskell Libraries Report.
+They currently comprise:
+\begin{itemize}
+\item @Prelude@.
+\item @List@: more functions on lists.
+\item @Char@: more functions on characters.
+\item @Maybe@: more functions on @Maybe@ types.
+\item @Complex@: functions on complex numbers.
+\item @Ratio@: functions on rational numbers.
+\item @Monad@: functions on characters.
+\item @Ix@: the @Ix@ class of indexing operations.
+\item @Array@: monolithic arrays.
+\item @IO@: basic input/output functions.
+\item @Directory@: basic functions for accessing the file system.
+\item @System@: basic operating-system interface functions.
+\end{itemize}
+
+\item[@lib/glaExts@]  GHC extension libraries, currently comprising:
+\begin{itemize}
+\item @PackedString@: functions that manipulate strings packed efficiently, one character per byte.
+\item @ST@: the state transformer monad.
+\item @Foreign@: types and operations for GHC's foreign-language interface.
+\end{itemize}
+
+\item[@lib/concurrent@] GHC extension libraries to support Concurrent Haskell, currently comprising:
+\begin{itemize}
+\item @Concurrent.hs@: main library.
+\item @Parallel.hs@: stuff for multi-processor parallelism.
+\item @Channel.hs@
+\item @ChannelVar.hs@
+\item @Merge.hs@
+\item @SampleVar.hs@
+\item @Semaphore.hs@
+\end{itemize}
+
+\item[@lib/ghc@] These libraries are the pieces on which all the others are built.
+They aren't typically imported by Joe Programmer, but there's nothing to stop you
+doing so if you want.  In general, the modules prefixed by @Prel@ are pieces that go
+towards building @Prelude@.
+
+\begin{itemize}
+\item @GHC@: this ``library'' brings into scope all the primitive types and operations, such as
+@Int#@, @+#@,  @encodeFloat#@, etc etc.  It is unique in that there is no Haskell
+source code for it.  Details in Section \ref{sect:ghc}.
+
+\item @PrelBase@: defines the basic types and classes without which very few Haskell programs can work.
+The classes are: @Eq@, @Ord@, @Enum@, @Bounded@, @Num@, @Show@, @Eval@, @Monad@, @MonadZero@, @MonadPlus@.
+The types are: list, @Bool@, @Char@, @Ordering@, @String@, @Int@, @Integer@, @Maybe@, @Either@.
+
+\item @PrelTup@: defines tuples and their instances.
+\item @PrelList@: defines most of the list operations required by @Prelude@.  (A few are in @PrelBase@.
+
+\item @PrelNum@ defines: the numeric classes beyond @Num@ (namely @Real@, @Integral@, 
+@Fractional@, @Floating@, @RealFrac@, @RealFloat@; instances for appropriate classes 
+for @Int@ and @Integer@; the types @Float@, @Double@, and @Ratio@ and their instances.
+
+\item @PrelRead@: the @Read@ class and all its instances.  It's kept separate because many programs
+don't use @Read@ at all, so we don't even want to link in its code.
+
+\item @ConcBase@: substrate stuff for Concurrent Haskell.
+
+\item @IOBase@: substrate stuff for the main I/O libraries.
+\item @IOHandle@: large blob of code for doing I/O on handles.
+\item @PrelIO@: the remaining small pieces to produce the I/O stuff needed by @Prelude@.
+\item @GHCerr@: error reporting code, called from code that the compiler plants in compiled programs.
+\item @GHCmain@: the definition of @mainPrimIO@, which is what {\em really} gets
+	called by the runtime system.  @mainPrimIO@ in turn calls @main@.
+\end{itemize}
+\end{description}
+
+\section{The module @GHC@: really primitive stuff}
+\label{sect:ghc}
 
 This section defines all the types which are primitive in Glasgow Haskell, and the
 operations provided for them.
 
-A primitive type is one which cannot be defined in Haskell, and which is 
-therefore built into the language and compiler.
-Primitive types are always unboxed; that is, a value of primitive type cannot be 
+A primitive type is one which cannot be defined in Haskell, and which
+is therefore built into the language and compiler.  Primitive types
+are always unboxed; that is, a value of primitive type cannot be
 bottom.
 
 Primitive values are often represented by a simple bit-pattern, such as @Int#@, 
diff --git a/ghc/driver/ghc-iface.lprl b/ghc/driver/ghc-iface.lprl
index f97cbd93a8..36c100da8c 100644
--- a/ghc/driver/ghc-iface.lprl
+++ b/ghc/driver/ghc-iface.lprl
@@ -5,6 +5,15 @@
 %************************************************************************
 
 \begin{code}
+%OldVersion = ();
+%Decl	 = (); # details about individual definitions
+%Stuff	 = (); # where we glom things together
+%HiExists      = ('old',-1,  'new',-1); # 1 <=> definitely exists; 0 <=> doesn't
+%HiHasBeenRead = ('old', 0,  'new', 0);
+%ModuleVersion = ('old', 0,  'new', 0);
+
+
+
 sub postprocessHiFile {
     local($hsc_hi,		# The iface info produced by hsc.
 	  $hifile_target,	# The name both of the .hi file we
@@ -14,7 +23,7 @@ sub postprocessHiFile {
 
     local($new_hi) = "$Tmp_prefix.hi-new";
 
-#   print STDERR `$Cat $hsc_hi`;
+#    print STDERR `$Cat $hsc_hi`;
 
     &constructNewHiFile($hsc_hi, $hifile_target, $new_hi);
 
@@ -53,16 +62,16 @@ sub deUsagifyHi {
     open(OLDHIF, "< $ifile") || &tidy_up_and_die(1,"Can't open $ifile (read)\n");
     open(NEWHIF, "> $ofile") || &tidy_up_and_die(1,"Can't open $ofile (write)\n");
 
-    # read up to __usages__ line
+    # read up to _usages_ line
     $_ = <OLDHIF>;
-    while ($_ ne '' && ! /^__usages__/) {
-	print NEWHIF $_ unless /^(interface |\{-# GHC_PRAGMA)/;
+    while ($_ ne '' && ! /^_usages_/) {
+	print NEWHIF $_ unless /^(_interface_ |\{-# GHC_PRAGMA)/;
 	$_ = <OLDHIF>;
     }
     if ( $_ ne '' ) {
-	# skip to next __<anything> line
+	# skip to next _<anything> line
 	$_ = <OLDHIF>;
-	while ($_ ne '' && ! /^__/) { $_ = <OLDHIF>; }
+	while ($_ ne '' && ! /^_/) { $_ = <OLDHIF>; }
 
 	# print the rest
 	while ($_ ne '') {
@@ -87,67 +96,48 @@ sub constructNewHiFile {
 
     open(NEWHI, "> $new_hi") || &tidy_up_and_die(1,"Can't open $new_hi (write)\n");
 
-    local($new_module_version) = &calcNewModuleVersion();
-    print NEWHI "interface ", $ModuleName{'new'}, " $new_module_version\n";
-
-    print NEWHI "__usages__\n", $Stuff{'new:usages'} unless $Stuff{'new:usages'} eq '';
-
-    local(@version_keys) = sort (keys %Version);
-    local($num_ver_things) = 0;
-    foreach $v (@version_keys) {
-	next unless $v =~ /^new:(.*$)/;
-	last if $num_ver_things >= 1;
-	$num_ver_things++;
-    }
-
-    print NEWHI "__versions__\n" unless $num_ver_things < 1;
-    foreach $v (@version_keys) {
+    local(@decl_names) = ();	# Entities in _declarations_ section of new module
+    foreach $v (sort (keys %Decl)) {
 	next unless $v =~ /^new:(.*$)/;
-	$v = $1;
-
-	&printNewItemVersion($v, $new_module_version), "\n";
+	push(@decl_names,$1);
     }
 
-    print NEWHI "__exports__\n";
-    print NEWHI $Stuff{'new:exports'};
+    local($new_module_version) = &calcNewModuleVersion(@decl_names);
+    print NEWHI "_interface_ ", $ModuleName{'new'}, " $new_module_version\n";
 
     if ( $Stuff{'new:instance_modules'} ) {
-	print NEWHI "__instance_modules__\n";
+	print NEWHI "_instance_modules_\n";
 	print NEWHI $Stuff{'new:instance_modules'};
     }
 
+    print NEWHI "_usages_\n", $Stuff{'new:usages'} unless $Stuff{'new:usages'} eq '';
+
+    print NEWHI "_exports_\n";
+    print NEWHI $Stuff{'new:exports'};
+
     if ( $Stuff{'new:fixities'} ) {
-	print NEWHI "__fixities__\n";
+	print NEWHI "_fixities_\n";
 	print NEWHI $Stuff{'new:fixities'};
     }
 
-    if ( $Stuff{'new:declarations'} ) {
-	print NEWHI "__declarations__\n";
-	print NEWHI $Stuff{'new:declarations'};
-    }
-
     if ( $Stuff{'new:instances'} ) {
-	print NEWHI "__instances__\n";
+	print NEWHI "_instances_\n";
 	print NEWHI $Stuff{'new:instances'};
     }
 
-    if ( $Stuff{'new:pragmas'} ) {
-	print NEWHI "__pragmas__\n";
-	print NEWHI $Stuff{'new:pragmas'};
+    print NEWHI "_declarations_\n";
+    foreach $v (@decl_names) {
+	&printNewItemVersion(NEWHI, $v, $new_module_version);		# Print new version number
+	print NEWHI $Decl{"new:$v"};		# Print the new decl itself
     }
 
+    
+
     close(NEWHI) || &tidy_up_and_die(1,"Failed writing to $new_hi\n");
 }
 \end{code}
 
 \begin{code}
-%Version = ();
-%Decl	 = (); # details about individual definitions
-%Stuff	 = (); # where we glom things together
-%HiExists      = ('old',-1,  'new',-1); # 1 <=> definitely exists; 0 <=> doesn't
-%HiHasBeenRead = ('old', 0,  'new', 0);
-%ModuleVersion = ('old', 0,  'new', 0);
-
 sub readHiFile {
     local($mod,		    # module to read; can be special tag 'old'
 			    # (old .hi file for module being compiled) or
@@ -158,13 +148,12 @@ sub readHiFile {
     $HiExists{$mod}      = -1; # 1 <=> definitely exists; 0 <=> doesn't
     $HiHasBeenRead{$mod} = 0;
     $ModuleVersion{$mod} = 0;
+    $Stuff{"$mod:instance_modules"} = '';
     $Stuff{"$mod:usages"}	    = ''; # stuff glommed together
     $Stuff{"$mod:exports"}	    = '';
-    $Stuff{"$mod:instance_modules"} = '';
-    $Stuff{"$mod:instances"}	    = '';
     $Stuff{"$mod:fixities"}	    = '';
+    $Stuff{"$mod:instances"}	    = '';
     $Stuff{"$mod:declarations"}	    = '';
-    $Stuff{"$mod:pragmas"}	    = '';
 
     if (! -f $hifile) { # no pre-existing .hi file
 	$HiExists{$mod} = 0;
@@ -185,52 +174,65 @@ sub readHiFile {
 	    last hi_line;
 	}
 
-	if ( /^interface ([A-Z]\S*) (\d+)/ ) {
+	if ( /^_interface_ ([A-Z]\S*) (\d+)/ ) {
 	    $ModuleName{$mod}	 = $1; # not sure this is used much...
 	    $ModuleVersion{$mod} = $2;
 
-	} elsif ( /^interface ([A-Z]\S*)/ && $mod eq 'new' ) { # special case: no version
+	} elsif ( /^_interface_ ([A-Z]\S*)/ && $mod eq 'new' ) { # special case: no version
 	    $ModuleName{'new'} = $1;
 
-	} elsif ( /^__([a-z]+)__$/ ) {
+	} elsif ( /^_([a-z_]+)_$/ ) {
 	    $now_in = $1;
 
 	} elsif ( $now_in eq 'usages' && /^(\S+)\s+(\d+)\s+:: (.*)/ ) {
 	    $Stuff{"$mod:usages"} .= $_; # save the whole thing
 
-	} elsif ( $now_in eq 'versions' && /^(\S+) (\d+)/ ) {
-	    local($item) = $1;
-	    local($n)    = $2;
-#print STDERR "version read:item=$item, n=$n, line=$_";
-	    $Version{"$mod:$item"} = $n;
 
-	} elsif ( $now_in eq 'versions' && /^(\S+)/ && $mod eq 'new') { # doesn't have versions
-	    local($item) = $1;
-#print STDERR "new version read:item=$item, line=$_";
-	    $Version{"$mod:$item"} = 'y'; # stub value...
-
-	} elsif ( $now_in =~ /^(exports|instance_modules|instances|fixities|pragmas)$/ ) {
+	} elsif ( $now_in =~ /^(exports|instance_modules|instances|fixities)$/ ) {
 	    $Stuff{"$mod:$1"} .= $_; # just save it up
 
 	} elsif ( $now_in eq 'declarations' ) { # relatively special treatment needed...
-	    $Stuff{"$mod:declarations"} .= $_; # just save it up
-
-	    if ( /^[A-Z][A-Za-z0-9_']*\.(\S+)\s+::\s+/ ) {
-		$Decl{"$mod:$1"} = $_;
-
-	    } elsif ( /^type\s+[A-Z][A-Za-z0-9_']*\.(\S+)/ ) {
-		$Decl{"$mod:$1"} = $_;
-
-	    } elsif ( /^(newtype|data)\s+(.*\s+=>\s+)?[A-Z][A-Za-z0-9_']*\.(\S+)\s+/ ) {
-		$Decl{"$mod:$3"} = $_;
-
-	    } elsif ( /class\s+(.*\s+=>\s+)?[A-Z][A-Za-z0-9_']*\.(\S+)\s+.*where\s+\{.*\};/ ) {
-		$Decl{"$mod:$2"} = $_; # must be wary of => bit matching after "where"...
-	    } elsif ( /class\s+(.*\s+=>\s+)?[A-Z][A-Za-z0-9_']*\.(\S+)\s+/ ) {
-		$Decl{"$mod:$2"} = $_;
-
-	    } else { # oh, well...
-		print STDERR "$Pgm: decl line didn't match?\n$_";
+	# We're in a declaration
+
+	# Strip off the initial version number, if any
+	   if ( /^([0-9]+) (.*\n)/ ) {
+		# The "\n" is because we need to keep the newline at the end, so that
+		# it looks the same as if there's no version number and this if statement
+		# doesn't fire.
+
+		# So there's an initial version number
+		$version = $1;
+		$_ = $2;
+	   }
+	
+	    if ( /^(\S+)\s+::\s+/ ) {
+		$current_name = $1;
+		$Decl{"$mod:$current_name"} = $_;
+	        if ($mod eq "old") { $OldVersion{$current_name} = $version; }
+
+	    } elsif ( /^type\s+(\S+)/ ) {
+		$current_name = $1;
+		$Decl{"$mod:$current_name"} = $_;
+	        if ($mod eq "old") { $OldVersion{$current_name} = $version; }
+
+	    } elsif ( /^(newtype|data)\s+(.*\s+=>\s+)?(\S+)\s+/ ) {
+		$current_name = $3;
+		$Decl{"$mod:$current_name"} = $_;
+	        if ($mod eq "old") { $OldVersion{$current_name} = $version; }
+
+	    } elsif ( /class\s+(.*\s+=>\s+)?(\S+)\s+.*where\s+\{.*\};/ ) {
+		# must be wary of => bit matching after "where"...
+		$current_name = $2;
+		$Decl{"$mod:$current_name"} = $_;
+	        if ($mod eq "old") { $OldVersion{$current_name} = $version; }
+
+	    } elsif ( /class\s+(.*\s+=>\s+)?(\S+)\s+/ ) {
+		$current_name = $2;
+		$Decl{"$mod:$current_name"} = $_;
+	        if ($mod eq "old") { $OldVersion{$current_name} = $version; }
+
+	    } else { # Continuation line
+		$Decl{"$mod:$current_name"} .= $_
 	    }
 
 	} else {
@@ -249,6 +251,7 @@ sub readHiFile {
 
 \begin{code}
 sub calcNewModuleVersion {
+    local (@decl_names) = @_;
 
     return(&mv_change(1,'no old .hi file')) if $HiExists{'old'} == 0;
 	# could use "time()" as initial version; if a module existed, then was deleted,
@@ -259,43 +262,49 @@ sub calcNewModuleVersion {
     local($unchanged_version) = $ModuleVersion{'old'}; # will return one of these two
     local($changed_version)   = $unchanged_version + 1;
 
-    return(&mv_change($changed_version,'usages changed')) if $Stuff{'old:usages'} ne $Stuff{'new:usages'};
+# This statement is curious; it is subsumed by the foreach!
+#    return(&mv_change($changed_version,'usages changed')) if $Stuff{'old:usages'} ne $Stuff{'new:usages'};
 
-    foreach $t ( 'exports', 'instance_modules', 'instances', 'fixities', 'declarations', 'pragmas' ) {
+    foreach $t ( 'usages' , 'exports', 'instance_modules', 'instances', 'fixities' ) {
 	return(&mv_change($changed_version,"$t changed")) if $Stuff{"old:$t"} ne $Stuff{"new:$t"};
     }
 
+# Decl need separate treatment; they aren't in $Stuff
+    foreach $v (@decl_names) {
+	return(&mv_change($changed_version,"$v changed")) if $Decl{"old:$v"} ne $Decl{"new:$v"};
+    }
+    
+    print STDERR "Module version unchanged at $unchanged_version\n";
     return($unchanged_version);
 }
 
 sub mv_change {
     local($mv, $str) = @_;
 
-#print STDERR "$Pgm: module version changed to $mv; reason: $str\n";
+    print STDERR "$Pgm: module version changed to $mv; reason: $str\n";
     return($mv);
 }
 
 sub printNewItemVersion {
-    local($item, $mod_version) = @_;
+    local($hifile, $item, $mod_version) = @_;
+    local($idecl) = $Decl{"new:$item"};
 
-    if (! defined($Decl{"new:$item"}) ) {
-# it's OK, because the thing is almost-certainly wired-in
-#	print STDERR "$item: no decl?! (nothing into __versions__)\n";
-	return;
-    }
+    if (! defined($Decl{"old:$item"})) {	# Old decl doesn't exist
+	print STDERR "new: $item\n";
+	print $hifile  "$mod_version ";		# Use module version
 
-    local($idecl) = $Decl{"new:$item"};
+    } elsif ($idecl ne $Decl{"old:$item"})  {	# Old decl differs from new decl
+	local($odecl) = $Decl{"old:$item"};
+#	print STDERR "changed: $item\nOld: $odecl\nNew: $idecl\n";
+	print $hifile  "$mod_version ";		# Use module version
 
-    if (! defined($Decl{"old:$item"})) {
-#print STDERR "new: $item\n";
-	print NEWHI  "$item $mod_version\n";
-    } elsif ($idecl ne $Decl{"old:$item"})  {
-#print STDERR "changed: $item\n";
-	print NEWHI  "$item $mod_version\n";
-    } elsif (! defined($Version{"old:$item"}) ) {
-#print STDERR "$item: no old version?!\n" 
-    } else {
-	print NEWHI  "$item ", $Version{"old:$item"}, "\n";
+    } elsif (! defined($OldVersion{"$item"}) ) {
+	print STDERR "$item: no old version?!\n";
+	print $hifile  "$mod_version ";			# Use module version
+
+    } else {					# Identical decls, so use old version number
+	print STDERR "$item: unchanged\n";
+	print $hifile  $OldVersion{"$item"}, " ";
     }
     return;
 }
diff --git a/ghc/driver/ghc.lprl b/ghc/driver/ghc.lprl
index 653e54620e..a6d5f13d84 100644
--- a/ghc/driver/ghc.lprl
+++ b/ghc/driver/ghc.lprl
@@ -410,10 +410,14 @@ require special handling.
 
 @SysImport_dir	= ( $(INSTALLING) )
 		    ? ( "$InstDataDirGhc/imports" )
-		    : ( "$TopPwd/$(CURRENT_DIR)/$(GHC_LIBSRC)/prelude"
+		    : ( "$TopPwd/$(CURRENT_DIR)/$(GHC_LIBSRC)/ghc"
+		      , "$TopPwd/$(CURRENT_DIR)/$(GHC_LIBSRC)/glaExts"
 		      , "$TopPwd/$(CURRENT_DIR)/$(GHC_LIBSRC)/required"
 		      , "$TopPwd/$(CURRENT_DIR)/$(GHC_LIBSRC)/concurrent" );
 
+# We need to look in ghc/ and glaExts/ when searching for implicitly needed .hi files, but 
+# we should really *not* look there for explicitly imported modules.
+
 $GhcVersionInfo  = int ($(PROJECTVERSION) * 100);
 $Haskell1Version = 3; # i.e., Haskell 1.3
 @Cpp_define	 = ();
@@ -899,10 +903,7 @@ arg: while($_ = $ARGV[0]) {
     /^-user-prelude-force/	&& do { # ignore if not -user-prelude
 				        next arg; };
 
-    /^-split-objs(.*)/	&& do {
-			local($sname) = &grab_arg_arg('-split-objs', $1);
-			$sname =~ s/ //g; # no spaces
-
+    /^-split-objs/	&& do {
 			if ( $TargetPlatform !~ /^(alpha|hppa1\.1|i386|m68k|mips|powerpc|sparc)-/ ) {
 			    $SplitObjFiles = 0;
 			    print STDERR "WARNING: don't know how to split objects on this platform: $TargetPlatform\n`-split-objs' option ignored\n";
@@ -910,7 +911,7 @@ arg: while($_ = $ARGV[0]) {
 			    $SplitObjFiles = 1;
     			    $HscOut = '-C=';
 
-			    push(@HsC_flags, "-fglobalise-toplev-names=$sname"); 
+			    push(@HsC_flags, "-fglobalise-toplev-names"); 
 			    push(@CcBoth_flags, '-DUSE_SPLIT_MARKERS');
 
 			    require('ghc-split.prl')
@@ -1031,6 +1032,7 @@ arg: while($_ = $ARGV[0]) {
     /^-d(dump|ppr)-/         && do { push(@HsC_flags, $_); next arg; };
     /^-dverbose-(simpl|stg)/ && do { push(@HsC_flags, $_); next arg; };
     /^-dshow-passes/	     && do { push(@HsC_flags, $_); next arg; };
+    /^-dshow-rn-trace/	     && do { push(@HsC_flags, $_); next arg; };
     /^-dsource-stats/        && do { push(@HsC_flags, $_); next arg; };
     /^-dsimplifier-stats/    && do { push(@HsC_flags, $_); next arg; };
     /^-dstg-stats/	     && do { $Oopt_StgStats = $_; next arg; };
@@ -1400,7 +1402,7 @@ It really really wants to be the last STG-to-STG pass that is run.
 	    '-fdo-case-elim',
 	    '-fcase-merge',
 	    '-fdo-eta-reduction',
-	    '-fdo-lambda-eta-expansion',
+	    '-fdo-lambda-eta-expansion',	# After full laziness
 	    '-freuse-con',
 	    $Oopt_PedanticBottoms,
 	    $Oopt_MonadEtaExpansion,
@@ -1490,7 +1492,7 @@ It really really wants to be the last STG-to-STG pass that is run.
 #LATER:	'-fcalc-inlinings2', -- pointless for 2.01
 
       # stg2stg passes
-#LATER:	'-fupdate-analysis',
+	'-fupdate-analysis',
 	'-flambda-lift',
 	$Oopt_FinalStgProfilingMassage,
 	$Oopt_StgStats,
@@ -1706,14 +1708,15 @@ $Under = (   $TargetPlatform =~ /^alpha-/
 unshift(@Ld_flags,
       (($Ld_main) ? (
         '-u', "${Under}Main_" . $Ld_main . '_closure',
-       ) : (),
-       '-u', "${Under}GHCbase_unsafePerformPrimIO_fast1",
-       '-u', "${Under}Prelude_Z91Z93_closure", # i.e., []
-       '-u', "${Under}Prelude_IZh_static_info",
-       '-u', "${Under}Prelude_False_inregs_info",
-       '-u', "${Under}Prelude_True_inregs_info",
-       '-u', "${Under}Prelude_CZh_static_info",
-       '-u', "${Under}DEBUG_REGS"))
+       ) : ()
+#       , '-u', "${Under}STbase_unsafePerformPrimIO_fast1"
+#       , '-u', "${Under}Prelude_Z91Z93_closure"	 # i.e., []
+#       , '-u', "${Under}Prelude_IZh_static_info"
+#       , '-u', "${Under}Prelude_False_inregs_info"
+#       , '-u', "${Under}Prelude_True_inregs_info"
+#       , '-u', "${Under}Prelude_CZh_static_info"
+#       , '-u', "${Under}DEBUG_REGS"
+	))
        ; # just for fun, now...
 \end{code}
 
@@ -2084,57 +2087,13 @@ phase) to @"$ifile_root.<suffix>"@.
 
 \end{code}
 
-Check if hsc needs to be run at all.
-
-\begin{code}
-    local($more_processing_required) = 1;
-
-    if ( $Do_recomp_chkr  && $do_hsc && ! $going_interactive ) {
-	# recompilation-checking is important enough to live off by itself
-	require('ghc-recomp.prl')
-	    || &tidy_up_and_die(1,"$Pgm: panic: can't load ghc-recomp.prl!\n");
-
-	$more_processing_required
-	    = &runRecompChkr($ifile, $hscpp_hsc, $ifile_root, $ofile_target, $hifile_target);
 
-	if ( ! $more_processing_required ) {
-	    print STDERR "$Pgm:recompile: NOT NEEDED!\n"; # Yay!
-	    # propagate dependency:
-	    &run_something("touch $ofile_target", "Touch $ofile_target, to propagate dependencies");
-	}
-    }
-
-    $do_hsc = 0, $do_cc = 0, $do_as = 0 if ! $more_processing_required;
-\end{code}
+Now the Haskell compiler, C compiler, and assembler
 
 \begin{code}
-    if ( $do_hsc ) {
-
-	&runHsc($ifile_root, $hsc_out, $hsc_hi, $going_interactive);
-
-	# interface-handling is important enough to live off by itself
-	require('ghc-iface.prl')
-	    || &tidy_up_and_die(1,"$Pgm: panic: can't load ghc-iface.prl!\n");
-
-	&postprocessHiFile($hsc_hi, $hifile_target, $going_interactive);
-
-	# save a copy of the .hc file, even if we are carrying on...
-	if ($HscOut eq '-C=' && $do_cc && $Keep_hc_file_too) {
-	    local($to_do) = "$Rm $ifile_root.hc; $Cp $hsc_out $ifile_root.hc";
-	    &run_something($to_do, 'Saving copy of .hc file');
-	}
-
-	# save a copy of the .s file, even if we are carrying on...
-	if ($HscOut eq '-S=' && $do_as && $Keep_s_file_too) {
-	    local($to_do) = "$Rm $ifile_root.s; $Cp $hsc_out $ifile_root.s";
-	    &run_something($to_do, 'Saving copy of .s file');
-	}
-
-	# if we're going to split up object files,
-	# we inject split markers into the .hc file now
-	if ( $HscOut eq '-C=' && $SplitObjFiles ) {
-	    &inject_split_markers ( $hsc_out );
-	}
+   if ($do_hsc) {
+	&runHscAndProcessInterfaces( $ifile, $hscpp_hsc, $ifile_root, 
+				     $ofile_target, $hifile_target);
     }
 
     if ($do_cc) {
@@ -2205,6 +2164,117 @@ sub runHscpp {
 \end{code}
 
 \begin{code}
+sub runHscAndProcessInterfaces {
+    local($ifile, $hscpp_hsc, $ifiel_root, $ofile_target, $hifile_target) = @_;
+
+	# $ifile 		is the original input file
+	# $hscpp_hsc		post-unlit, post-cpp, etc., input file
+	# $ifile_root		input filename minus suffix
+	# $ofile_target		the output file that we ultimately hope to produce
+	# $hifile_target	the .hi file ... (ditto)
+	
+    local($source_unchanged) = 1;
+
+# Check if the source file is up to date relative to the target; in
+#  that case we say "source is unchanged" and let the compiler bale out
+# early if the import usage information allows it.
+
+    ($i_dev,$i_ino,$i_mode,$i_nlink,$i_uid,$i_gid,$i_rdev,$i_size,
+     $i_atime,$i_mtime,$i_ctime,$i_blksize,$i_blocks) = stat($ifile);
+
+    if ( ! -f $ofile_target ) {
+	print STDERR "$Pgm:compile:Output file $ofile_target doesn't exist\n";
+	$source_unchanged = 0;
+    }
+
+    ($o_dev,$o_ino,$o_mode,$o_nlink,$o_uid,$o_gid,$o_rdev,$o_size,
+     $o_atime,$o_mtime,$o_ctime,$o_blksize,$o_blocks) = stat(_); # stat info from -f test
+
+    if ( ! -f $hifile_target ) {
+	print STDERR "$Pgm:compile:Interface file $hifile_target doesn't exist\n";
+	$source_unchanged = 0;
+    }
+
+    ($hi_dev,$hi_ino,$hi_mode,$hi_nlink,$hi_uid,$hi_gid,$hi_rdev,$hi_size,
+     $hi_atime,$hi_mtime,$hi_ctime,$hi_blksize,$hi_blocks) = stat(_); # stat info from -f test
+
+    if ($i_mtime > $o_mtime) {
+	print STDERR "$Pgm:recompile:Input file $ifile newer than $ofile_target\n";
+	$source_unchanged = 0;
+    }
+
+    # So if source_unchanged is still "1", we pass on the good news to the compiler
+    # The -recomp flag can disable this, forcing recompilation
+    if ($Do_recomp_chkr && $source_unchanged) {
+	push(@HsC_flags, '-fsource-unchanged');	
+    }	
+
+# Run the compiler
+
+    &runHsc($ifile_root, $hsc_out, $hsc_hi, $going_interactive);
+
+# See if it baled out early, saying nothing needed doing.  
+# We work this out by seeing if it created an output .hi file
+
+    if ( ! -f $hsc_hi ) {
+	# Doesn't exist, so we baled out early.
+	# Tell the C compiler and assembler not to run
+	$do_cc = 0; $do_as = 0;
+
+	# Update dependency info
+	&run_something("touch $ofile_target", "Touch $ofile_target, to propagate dependencies");
+
+    } else {	
+
+# Didn't bale out early (new .hi file) so we thunder on
+    
+    	# If non-interactive, heave in the consistency info at the end
+    	# NB: pretty hackish (depends on how $output is set)
+    	if ( ! $going_interactive ) {
+	    if ( $HscOut eq '-C=' ) {
+	    $to_do = "echo 'static char ghc_hsc_ID[] = \"\@(#)hsc $ifile\t$HsC_major_version.$HsC_minor_version,$HsC_consist_options\";' >> $hsc_out";
+    
+	    } elsif ( $HscOut eq '-S=' ) {
+		local($consist) = "hsc.$ifile.$HsC_major_version.$HsC_minor_version.$HsC_consist_options";
+		$consist =~ s/,/./g;
+		$consist =~ s/\//./g;
+		$consist =~ s/-/_/g;
+		$consist =~ s/[^A-Za-z0-9_.]/ZZ/g; # ToDo: properly?
+		$to_do = "echo '\n\t.text\n$consist:' >> $hsc_out";
+	    }
+	    &run_something($to_do, 'Pin on Haskell consistency info');	
+    	}   
+
+
+	# Interface-handling is important enough to live off by itself
+	require('ghc-iface.prl')
+	    || &tidy_up_and_die(1,"$Pgm: panic: can't load ghc-iface.prl!\n");
+	
+	&postprocessHiFile($hsc_hi, $hifile_target, $going_interactive);
+	
+	# save a copy of the .hc file, even if we are carrying on...
+	if ($HscOut eq '-C=' && $do_cc && $Keep_hc_file_too) {
+	    local($to_do) = "$Rm $ifile_root.hc; $Cp $hsc_out $ifile_root.hc";
+	    &run_something($to_do, 'Saving copy of .hc file');
+	}
+	
+	# save a copy of the .s file, even if we are carrying on...
+	if ($HscOut eq '-S=' && $do_as && $Keep_s_file_too) {
+	    local($to_do) = "$Rm $ifile_root.s; $Cp $hsc_out $ifile_root.s";
+	    &run_something($to_do, 'Saving copy of .s file');
+	}
+	
+	# if we're going to split up object files,
+	# we inject split markers into the .hc file now
+	if ( $HscOut eq '-C=' && $SplitObjFiles ) {
+	    &inject_split_markers ( $hsc_out );
+        }
+    }
+}
+\end{code}
+
+
+\begin{code}
 sub runHsc {
     local($ifile_root, $hsc_out, $hsc_hi, $going_interactive) = @_;
 
@@ -2212,7 +2282,9 @@ sub runHsc {
     foreach $a ( @HsP_flags ) { $a = ",$a" unless $a =~ /^,/; }
 
     &makeHiMap() unless $HiMapDone;
-    push(@HsC_flags, "-himap=$HiMapFile");
+#    print STDERR "HiIncludes: $HiIncludeString\n";
+    push(@HsC_flags, "-himap=$HiIncludeString");
+#    push(@HsC_flags, "-himap=$HiMapFile");
 
     # here, we may produce .hc/.s and/or .hi files
     local($output) = '';
@@ -2254,23 +2326,6 @@ sub runHsc {
 
     # finish business w/ nofibbish time/bytes-alloc stats
     &process_ghc_timings() if $CollectGhcTimings;
-
-    # if non-interactive, heave in the consistency info at the end
-    # NB: pretty hackish (depends on how $output is set)
-    if ( ! $going_interactive ) {
-	if ( $HscOut eq '-C=' ) {
-	$to_do = "echo 'static char ghc_hsc_ID[] = \"\@(#)hsc $ifile\t$HsC_major_version.$HsC_minor_version,$HsC_consist_options\";' >> $hsc_out";
-
-	} elsif ( $HscOut eq '-S=' ) {
-	    local($consist) = "hsc.$ifile.$HsC_major_version.$HsC_minor_version.$HsC_consist_options";
-	    $consist =~ s/,/./g;
-	    $consist =~ s/\//./g;
-	    $consist =~ s/-/_/g;
-	    $consist =~ s/[^A-Za-z0-9_.]/ZZ/g; # ToDo: properly?
-	    $to_do = "echo '\n\t.text\n$consist:' >> $hsc_out";
-	}
-	&run_something($to_do, 'Pin on Haskell consistency info');	
-    }
 }
 \end{code}
 
@@ -2280,6 +2335,7 @@ of (module-name, pathname) pairs, one per line, separated by a space.
 %HiMap     = ();
 $HiMapDone = 0;
 $HiMapFile = '';
+$HiIncludeString = ();		# dir1:dir2:dir3, to pass to GHC
 
 sub makeHiMap {
 
@@ -2288,6 +2344,9 @@ sub makeHiMap {
     local($mod, $path, $d, $e);
     
     foreach $d ( @Import_dir ) {
+	if ($HiIncludeString) { $HiIncludeString = "$HiIncludeString:$d";
+	} else { $HiIncludeString = $d; }
+
 	opendir(DIR, $d) || &tidy_up_and_die(1,"$Pgm: error when reading directory: $d\n");
 	local(@entry) = readdir(DIR);
 	foreach $e ( @entry ) {
@@ -2306,6 +2365,9 @@ sub makeHiMap {
     }
 
     foreach $d ( @SysImport_dir ) {
+	if ($HiIncludeString) { $HiIncludeString = "$HiIncludeString:$d";
+	} else { $HiIncludeString = $d; }
+
 	opendir(DIR, $d) || &tidy_up_and_die(1,"$Pgm: error when reading directory: $d\n");
 	local(@entry) = readdir(DIR);
 	foreach $e ( @entry ) {
diff --git a/ghc/includes/CostCentre.lh b/ghc/includes/CostCentre.lh
index 3993b29965..4444090c9d 100644
--- a/ghc/includes/CostCentre.lh
+++ b/ghc/includes/CostCentre.lh
@@ -394,6 +394,15 @@ extern F_ *register_stack;
 	} while(0);							\
 	FUNEND; }
 
+#else	/* PROFILING */
+
+/* When things are working these shouldn't be emitted when not profiling,
+   but it was convenient at one point to have them expand to nothing 
+    when not profiling.  SLPJ Dec 96 */
+
+#define START_REGISTER_CCS(reg_mod_name)
+#define END_REGISTER_CCS()
+
 #endif  /* PROFILING */
 \end{code}
 
diff --git a/ghc/includes/SMInfoTables.lh b/ghc/includes/SMInfoTables.lh
index 071bce332e..674444da87 100644
--- a/ghc/includes/SMInfoTables.lh
+++ b/ghc/includes/SMInfoTables.lh
@@ -476,6 +476,10 @@ to identify the closure type.
 #define INFO_BF_TYPE		(MAKE_BASE_INFO_TYPE(21L) | _NS | _MU | _BH)
 #define INFO_INTERNAL_TYPE	(MAKE_BASE_INFO_TYPE(22L))
 
+/* S = single-entry thunk
+   U = updatable thunk
+   N = head normal form */
+
 #define INFO_SPEC_N_TYPE	(INFO_SPEC_TYPE | _NF | _NS)
 #define INFO_SPEC_S_TYPE	(INFO_SPEC_TYPE | _TH)
 #define INFO_SPEC_U_TYPE	(INFO_SPEC_TYPE | _UP | _TH)
@@ -1742,7 +1746,7 @@ during a return.
 
 /* Declare the phantom info table vectors (just Bool at the moment) */
 #ifndef COMPILING_GHC
-EXTDATA_RO(Prelude_Bool_itblvtbl);
+EXTDATA_RO(PrelBase_Bool_itblvtbl);
 #endif
 
 \end{code}
diff --git a/ghc/includes/StgMacros.lh b/ghc/includes/StgMacros.lh
index 7b8bb69e5d..f7b21b65ae 100644
--- a/ghc/includes/StgMacros.lh
+++ b/ghc/includes/StgMacros.lh
@@ -390,12 +390,13 @@ even for 8-bit chars).
 #define ltCharZh(r,a,b)	r=(I_)((a)< (b))
 #define leCharZh(r,a,b)	r=(I_)((a)<=(b))
 
-#define gtIntZh(r,a,b)	r=(I_)((a) >(b))
-#define geIntZh(r,a,b)	r=(I_)((a)>=(b))
-#define eqIntZh(r,a,b)	r=(I_)((a)==(b))
-#define neIntZh(r,a,b)	r=(I_)((a)!=(b))
-#define ltIntZh(r,a,b)	r=(I_)((a) <(b))
-#define leIntZh(r,a,b)	r=(I_)((a)<=(b))
+/* Int comparisons: >#, >=# etc */
+#define ZgZh(r,a,b)	r=(I_)((a) >(b))
+#define ZgZeZh(r,a,b)	r=(I_)((a)>=(b))
+#define ZeZeZh(r,a,b)	r=(I_)((a)==(b))
+#define ZdZeZh(r,a,b)	r=(I_)((a)!=(b))
+#define ZlZh(r,a,b)	r=(I_)((a) <(b))
+#define ZlZeZh(r,a,b)	r=(I_)((a)<=(b))
 
 #define gtWordZh(r,a,b)	r=(I_)((a) >(b))
 #define geWordZh(r,a,b)	r=(I_)((a)>=(b))
@@ -418,12 +419,13 @@ even for 8-bit chars).
 #define ltFloatZh(r,a,b)  r=(I_)((a)< (b))
 #define leFloatZh(r,a,b)  r=(I_)((a)<=(b))
 
-#define gtDoubleZh(r,a,b) r=(I_)((a)> (b))
-#define geDoubleZh(r,a,b) r=(I_)((a)>=(b))
-#define eqDoubleZh(r,a,b) r=(I_)((a)==(b))
-#define neDoubleZh(r,a,b) r=(I_)((a)!=(b))
-#define ltDoubleZh(r,a,b) r=(I_)((a)< (b))
-#define leDoubleZh(r,a,b) r=(I_)((a)<=(b))
+/* Double comparisons: >##, >=#@ etc */
+#define ZgZhZh(r,a,b)	r=(I_)((a) >(b))
+#define ZgZeZhZh(r,a,b)	r=(I_)((a)>=(b))
+#define ZeZeZhZh(r,a,b)	r=(I_)((a)==(b))
+#define ZdZeZhZh(r,a,b)	r=(I_)((a)!=(b))
+#define ZlZhZh(r,a,b)	r=(I_)((a) <(b))
+#define ZlZeZhZh(r,a,b)	r=(I_)((a)<=(b))
 \end{code}
 
 %************************************************************************
@@ -448,11 +450,11 @@ even for 8-bit chars).
 \begin{code}
 I_ stg_div PROTO((I_ a, I_ b));
 
-#define plusIntZh(r,a,b)	r=(a)+(b)
-#define minusIntZh(r,a,b)	r=(a)-(b)
-#define timesIntZh(r,a,b)	r=(a)*(b)
+#define ZpZh(r,a,b)		r=(a)+(b)
+#define ZmZh(r,a,b)		r=(a)-(b)
+#define ZtZh(r,a,b)		r=(a)*(b)
 #define quotIntZh(r,a,b)	r=(a)/(b)
-#define divIntZh(r,a,b)		r=ULTRASAFESTGCALL2(I_,(void *, I_, I_),stg_div,(a),(b))
+#define ZdZh(r,a,b)		r=ULTRASAFESTGCALL2(I_,(void *, I_, I_),stg_div,(a),(b))
 #define remIntZh(r,a,b)		r=(a)%(b)
 #define negateIntZh(r,a)	r=-(a)
 \end{code}
@@ -530,10 +532,10 @@ I_ stg_div PROTO((I_ a, I_ b));
 %************************************************************************
 
 \begin{code}
-#define plusDoubleZh(r,a,b)	r=(a)+(b)
-#define minusDoubleZh(r,a,b)	r=(a)-(b)
-#define timesDoubleZh(r,a,b)	r=(a)*(b)
-#define divideDoubleZh(r,a,b)	r=(a)/(b)
+#define ZpZhZh(r,a,b)		r=(a)+(b)
+#define ZmZhZh(r,a,b)		r=(a)-(b)
+#define ZtZhZh(r,a,b)		r=(a)*(b)
+#define ZdZhZh(r,a,b)		r=(a)/(b)
 #define negateDoubleZh(r,a)	r=-(a)
 
 #define int2DoubleZh(r,a)	r=(StgDouble)(a)
@@ -554,7 +556,8 @@ I_ stg_div PROTO((I_ a, I_ b));
 #define sinhDoubleZh(r,a)	r=(StgDouble) SAFESTGCALL1(StgDouble,(void *, StgDouble),sinh,a)
 #define coshDoubleZh(r,a)	r=(StgDouble) SAFESTGCALL1(StgDouble,(void *, StgDouble),cosh,a)
 #define tanhDoubleZh(r,a)	r=(StgDouble) SAFESTGCALL1(StgDouble,(void *, StgDouble),tanh,a)
-#define powerDoubleZh(r,a,b)	r=(StgDouble) SAFESTGCALL2(StgDouble,(void *, StgDouble,StgDouble),pow,a,b)
+/* Power: **## */
+#define ZtZtZhZh(r,a,b)	r=(StgDouble) SAFESTGCALL2(StgDouble,(void *, StgDouble,StgDouble),pow,a,b)
 \end{code}
 
 %************************************************************************
diff --git a/ghc/lib/.depend b/ghc/lib/.depend
index 832f3bb7ca..9af0540232 100644
--- a/ghc/lib/.depend
+++ b/ghc/lib/.depend
@@ -1,77 +1,701 @@
 # DO NOT DELETE: Beginning of Haskell dependencies
-prelude/GHCbase.o : prelude/GHCbase.hs
-prelude/GHCbase.o : required/Array.hi
-prelude/GHCbase.o : required/Char.hi
-prelude/GHCbase.o : required/Ix.hi
-prelude/GHCbase.o : required/Ratio.hi
-prelude/GHCbase.o : prelude/GHCerr.hi
-prelude/GHCerr.o : prelude/GHCerr.hs
-prelude/GHCerr.o : prelude/GHCbase.hi
-prelude/GHCio.o : prelude/GHCio.hs
-prelude/GHCio.o : ../../ghc/includes/error.h
-prelude/GHCio.o : prelude/GHCbase.hi
-prelude/GHCio.o : required/Ix.hi
-prelude/GHCmain.o : prelude/GHCmain.hs
-prelude/GHCmain.o : prelude/GHCbase.hi
-prelude/GHCps.o : prelude/GHCps.hs
-prelude/GHCps.o : required/Ix.hi
-prelude/GHCps.o : required/Char.hi
-prelude/GHCps.o : prelude/GHCbase.hi
-prelude/Prelude.o : prelude/Prelude.hs
-prelude/Prelude.o : ./../includes/ieee-flpt.h
-prelude/Prelude.o : prelude/GHCbase.hi
-prelude/Prelude.o : prelude/GHCio.hi
-prelude/Prelude.o : required/Ratio.hi
-prelude/Prelude.o : required/Char.hi
-prelude/Prelude.o : required/IO.hi
-prelude/PreludeGlaST.o : prelude/PreludeGlaST.hs
-prelude/PreludeGlaST.o : prelude/GHCbase.hi
-required/Array.o : required/Array.hs
+ghc/ArrBase.o : ghc/ArrBase.lhs
+ghc/ArrBase.mc.o : ghc/ArrBase.lhs
+ghc/ArrBase.norm.o : ghc/ArrBase.lhs
+ghc/ArrBase.p.o : ghc/ArrBase.lhs
+ghc/ArrBase.mc.o : ghc/IOBase.mc.hi
+ghc/ArrBase.norm.o : ghc/IOBase.norm.hi
+ghc/ArrBase.p.o : ghc/IOBase.p.hi
+ghc/ArrBase.o : required/Ix.hi
+ghc/ArrBase.mc.o : required/Ix.mc.hi
+ghc/ArrBase.norm.o : required/Ix.norm.hi
+ghc/ArrBase.p.o : required/Ix.p.hi
+ghc/ArrBase.o : ghc/PrelList.hi
+ghc/ArrBase.mc.o : ghc/PrelList.mc.hi
+ghc/ArrBase.norm.o : ghc/PrelList.norm.hi
+ghc/ArrBase.p.o : ghc/PrelList.p.hi
+ghc/ArrBase.o : ghc/PrelNum.hi
+ghc/ArrBase.mc.o : ghc/PrelNum.mc.hi
+ghc/ArrBase.norm.o : ghc/PrelNum.norm.hi
+ghc/ArrBase.p.o : ghc/PrelNum.p.hi
+ghc/ArrBase.o : ghc/STBase.hi
+ghc/ArrBase.mc.o : ghc/STBase.mc.hi
+ghc/ArrBase.norm.o : ghc/STBase.norm.hi
+ghc/ArrBase.p.o : ghc/STBase.p.hi
+ghc/ArrBase.o : ghc/PrelBase.hi
+ghc/ArrBase.mc.o : ghc/PrelBase.mc.hi
+ghc/ArrBase.norm.o : ghc/PrelBase.norm.hi
+ghc/ArrBase.p.o : ghc/PrelBase.p.hi
+ghc/ArrBase.o : ghc/PrelTup.hi
+ghc/ArrBase.mc.o : ghc/PrelTup.mc.hi
+ghc/ArrBase.norm.o : ghc/PrelTup.norm.hi
+ghc/ArrBase.p.o : ghc/PrelTup.p.hi
+ghc/ArrBase.o : ghc/GHC.hi
+ghc/ArrBase.mc.o : ghc/GHC.mc.hi
+ghc/ArrBase.norm.o : ghc/GHC.norm.hi
+ghc/ArrBase.p.o : ghc/GHC.p.hi
+ghc/ConcBase.o : ghc/ConcBase.lhs
+ghc/ConcBase.mc.o : ghc/ConcBase.lhs
+ghc/ConcBase.norm.o : ghc/ConcBase.lhs
+ghc/ConcBase.p.o : ghc/ConcBase.lhs
+ghc/ConcBase.o : required/Prelude.hi
+ghc/ConcBase.o : ghc/STBase.hi
+ghc/ConcBase.o : ghc/GHCerr.hi
+ghc/ConcBase.mc.o : ghc/STBase.mc.hi
+ghc/ConcBase.norm.o : ghc/STBase.norm.hi
+ghc/ConcBase.p.o : ghc/STBase.p.hi
+ghc/GHCerr.o : ghc/GHCerr.lhs
+ghc/GHCerr.mc.o : ghc/GHCerr.lhs
+ghc/GHCerr.norm.o : ghc/GHCerr.lhs
+ghc/GHCerr.p.o : ghc/GHCerr.lhs
+ghc/GHCerr.o : ghc/IOBase.hi
+ghc/GHCerr.mc.o : ghc/IOBase.mc.hi
+ghc/GHCerr.norm.o : ghc/IOBase.norm.hi
+ghc/GHCerr.p.o : ghc/IOBase.p.hi
+ghc/GHCmain.o : ghc/GHCmain.lhs
+ghc/GHCmain.mc.o : ghc/GHCmain.lhs
+ghc/GHCmain.norm.o : ghc/GHCmain.lhs
+ghc/GHCmain.p.o : ghc/GHCmain.lhs
+ghc/GHCmain.mc.o : required/Prelude.mc.hi
+ghc/GHCmain.norm.o : required/Prelude.norm.hi
+ghc/GHCmain.p.o : required/Prelude.p.hi
+ghc/GHCmain.o : ghc/IOBase.hi
+ghc/GHCmain.mc.o : ghc/IOBase.mc.hi
+ghc/GHCmain.norm.o : ghc/IOBase.norm.hi
+ghc/GHCmain.p.o : ghc/IOBase.p.hi
+ghc/GHCmain.o : ghc/STBase.hi
+ghc/GHCmain.mc.o : ghc/STBase.mc.hi
+ghc/GHCmain.norm.o : ghc/STBase.norm.hi
+ghc/GHCmain.p.o : ghc/STBase.p.hi
+ghc/IOBase.o : ghc/IOBase.lhs
+ghc/IOBase.mc.o : ghc/IOBase.lhs
+ghc/IOBase.norm.o : ghc/IOBase.lhs
+ghc/IOBase.p.o : ghc/IOBase.lhs
+ghc/IOBase.o : ../../ghc/includes/error.h
+ghc/IOBase.mc.o : ../../ghc/includes/error.h
+ghc/IOBase.norm.o : ../../ghc/includes/error.h
+ghc/IOBase.p.o : ../../ghc/includes/error.h
+ghc/IOBase.mc.o : required/Prelude.mc.hi
+ghc/IOBase.norm.o : required/Prelude.norm.hi
+ghc/IOBase.p.o : required/Prelude.p.hi
+ghc/IOBase.o : ghc/STBase.hi
+ghc/IOBase.mc.o : ghc/STBase.mc.hi
+ghc/IOBase.norm.o : ghc/STBase.norm.hi
+ghc/IOBase.p.o : ghc/STBase.p.hi
+ghc/IOBase.o : ghc/PrelTup.hi
+ghc/IOBase.mc.o : ghc/PrelTup.mc.hi
+ghc/IOBase.norm.o : ghc/PrelTup.norm.hi
+ghc/IOBase.p.o : ghc/PrelTup.p.hi
+ghc/IOBase.o : glaExts/Foreign.hi
+ghc/IOBase.mc.o : glaExts/Foreign.mc.hi
+ghc/IOBase.norm.o : glaExts/Foreign.norm.hi
+ghc/IOBase.p.o : glaExts/Foreign.p.hi
+ghc/IOBase.o : glaExts/PackedString.hi
+ghc/IOBase.mc.o : glaExts/PackedString.mc.hi
+ghc/IOBase.norm.o : glaExts/PackedString.norm.hi
+ghc/IOBase.p.o : glaExts/PackedString.p.hi
+ghc/IOBase.o : ghc/PrelBase.hi
+ghc/IOBase.mc.o : ghc/PrelBase.mc.hi
+ghc/IOBase.norm.o : ghc/PrelBase.norm.hi
+ghc/IOBase.p.o : ghc/PrelBase.p.hi
+ghc/IOBase.o : ghc/GHC.hi
+ghc/IOBase.mc.o : ghc/GHC.mc.hi
+ghc/IOBase.norm.o : ghc/GHC.norm.hi
+ghc/IOBase.p.o : ghc/GHC.p.hi
+ghc/IOHandle.o : ghc/IOHandle.lhs
+ghc/IOHandle.mc.o : ghc/IOHandle.lhs
+ghc/IOHandle.norm.o : ghc/IOHandle.lhs
+ghc/IOHandle.p.o : ghc/IOHandle.lhs
+ghc/IOHandle.o : ../../ghc/includes/error.h
+ghc/IOHandle.mc.o : ../../ghc/includes/error.h
+ghc/IOHandle.norm.o : ../../ghc/includes/error.h
+ghc/IOHandle.p.o : ../../ghc/includes/error.h
+ghc/IOHandle.mc.o : required/Prelude.mc.hi
+ghc/IOHandle.norm.o : required/Prelude.norm.hi
+ghc/IOHandle.p.o : required/Prelude.p.hi
+ghc/IOHandle.o : glaExts/ST.hi
+ghc/IOHandle.mc.o : glaExts/ST.mc.hi
+ghc/IOHandle.norm.o : glaExts/ST.norm.hi
+ghc/IOHandle.p.o : glaExts/ST.p.hi
+ghc/IOHandle.o : ghc/STBase.hi
+ghc/IOHandle.mc.o : ghc/STBase.mc.hi
+ghc/IOHandle.norm.o : ghc/STBase.norm.hi
+ghc/IOHandle.p.o : ghc/STBase.p.hi
+ghc/IOHandle.o : ghc/ArrBase.hi
+ghc/IOHandle.mc.o : ghc/ArrBase.mc.hi
+ghc/IOHandle.norm.o : ghc/ArrBase.norm.hi
+ghc/IOHandle.p.o : ghc/ArrBase.p.hi
+ghc/IOHandle.o : ghc/PrelRead.hi
+ghc/IOHandle.mc.o : ghc/PrelRead.mc.hi
+ghc/IOHandle.norm.o : ghc/PrelRead.norm.hi
+ghc/IOHandle.p.o : ghc/PrelRead.p.hi
+ghc/IOHandle.o : required/Ix.hi
+ghc/IOHandle.mc.o : required/Ix.mc.hi
+ghc/IOHandle.norm.o : required/Ix.norm.hi
+ghc/IOHandle.p.o : required/Ix.p.hi
+ghc/IOHandle.o : ghc/IOBase.hi
+ghc/IOHandle.mc.o : ghc/IOBase.mc.hi
+ghc/IOHandle.norm.o : ghc/IOBase.norm.hi
+ghc/IOHandle.p.o : ghc/IOBase.p.hi
+ghc/IOHandle.o : ghc/PrelTup.hi
+ghc/IOHandle.mc.o : ghc/PrelTup.mc.hi
+ghc/IOHandle.norm.o : ghc/PrelTup.norm.hi
+ghc/IOHandle.p.o : ghc/PrelTup.p.hi
+ghc/IOHandle.o : ghc/PrelBase.hi
+ghc/IOHandle.mc.o : ghc/PrelBase.mc.hi
+ghc/IOHandle.norm.o : ghc/PrelBase.norm.hi
+ghc/IOHandle.p.o : ghc/PrelBase.p.hi
+ghc/IOHandle.o : ghc/GHC.hi
+ghc/IOHandle.mc.o : ghc/GHC.mc.hi
+ghc/IOHandle.norm.o : ghc/GHC.norm.hi
+ghc/IOHandle.p.o : ghc/GHC.p.hi
+ghc/PrelBase.o : ghc/PrelBase.lhs
+ghc/PrelBase.mc.o : ghc/PrelBase.lhs
+ghc/PrelBase.norm.o : ghc/PrelBase.lhs
+ghc/PrelBase.p.o : ghc/PrelBase.lhs
+ghc/PrelBase.mc.o : required/Prelude.mc.hi
+ghc/PrelBase.norm.o : required/Prelude.norm.hi
+ghc/PrelBase.p.o : required/Prelude.p.hi
+ghc/PrelBase.mc.o : ghc/IOBase.mc.hi
+ghc/PrelBase.norm.o : ghc/IOBase.norm.hi
+ghc/PrelBase.p.o : ghc/IOBase.p.hi
+ghc/PrelBase.o : ghc/GHC.hi
+ghc/PrelBase.mc.o : ghc/GHC.mc.hi
+ghc/PrelBase.norm.o : ghc/GHC.norm.hi
+ghc/PrelBase.p.o : ghc/GHC.p.hi
+ghc/PrelIO.o : ghc/PrelIO.lhs
+ghc/PrelIO.mc.o : ghc/PrelIO.lhs
+ghc/PrelIO.norm.o : ghc/PrelIO.lhs
+ghc/PrelIO.p.o : ghc/PrelIO.lhs
+ghc/PrelIO.mc.o : required/Prelude.mc.hi
+ghc/PrelIO.norm.o : required/Prelude.norm.hi
+ghc/PrelIO.p.o : required/Prelude.p.hi
+ghc/PrelIO.o : required/IO.hi
+ghc/PrelIO.mc.o : required/IO.mc.hi
+ghc/PrelIO.norm.o : required/IO.norm.hi
+ghc/PrelIO.p.o : required/IO.p.hi
+ghc/PrelIO.o : ghc/IOHandle.hi
+ghc/PrelIO.mc.o : ghc/IOHandle.mc.hi
+ghc/PrelIO.norm.o : ghc/IOHandle.norm.hi
+ghc/PrelIO.p.o : ghc/IOHandle.p.hi
+ghc/PrelIO.o : ghc/IOBase.hi
+ghc/PrelIO.mc.o : ghc/IOBase.mc.hi
+ghc/PrelIO.norm.o : ghc/IOBase.norm.hi
+ghc/PrelIO.p.o : ghc/IOBase.p.hi
+ghc/PrelIO.o : ghc/PrelBase.hi
+ghc/PrelIO.mc.o : ghc/PrelBase.mc.hi
+ghc/PrelIO.norm.o : ghc/PrelBase.norm.hi
+ghc/PrelIO.p.o : ghc/PrelBase.p.hi
+ghc/PrelIO.o : ghc/PrelRead.hi
+ghc/PrelIO.mc.o : ghc/PrelRead.mc.hi
+ghc/PrelIO.norm.o : ghc/PrelRead.norm.hi
+ghc/PrelIO.p.o : ghc/PrelRead.p.hi
+ghc/PrelList.o : ghc/PrelList.lhs
+ghc/PrelList.mc.o : ghc/PrelList.lhs
+ghc/PrelList.norm.o : ghc/PrelList.lhs
+ghc/PrelList.p.o : ghc/PrelList.lhs
+ghc/PrelList.mc.o : required/Prelude.mc.hi
+ghc/PrelList.norm.o : required/Prelude.norm.hi
+ghc/PrelList.p.o : required/Prelude.p.hi
+ghc/PrelList.mc.o : ghc/IOBase.mc.hi
+ghc/PrelList.norm.o : ghc/IOBase.norm.hi
+ghc/PrelList.p.o : ghc/IOBase.p.hi
+ghc/PrelList.o : ghc/PrelTup.hi
+ghc/PrelList.mc.o : ghc/PrelTup.mc.hi
+ghc/PrelList.norm.o : ghc/PrelTup.norm.hi
+ghc/PrelList.p.o : ghc/PrelTup.p.hi
+ghc/PrelList.o : ghc/PrelBase.hi
+ghc/PrelList.mc.o : ghc/PrelBase.mc.hi
+ghc/PrelList.norm.o : ghc/PrelBase.norm.hi
+ghc/PrelList.p.o : ghc/PrelBase.p.hi
+ghc/PrelNum.o : ghc/PrelNum.lhs
+ghc/PrelNum.mc.o : ghc/PrelNum.lhs
+ghc/PrelNum.norm.o : ghc/PrelNum.lhs
+ghc/PrelNum.p.o : ghc/PrelNum.lhs
+ghc/PrelNum.o : ./../includes/ieee-flpt.h
+ghc/PrelNum.mc.o : ./../includes/ieee-flpt.h
+ghc/PrelNum.norm.o : ./../includes/ieee-flpt.h
+ghc/PrelNum.p.o : ./../includes/ieee-flpt.h
+ghc/PrelNum.mc.o : required/Prelude.mc.hi
+ghc/PrelNum.norm.o : required/Prelude.norm.hi
+ghc/PrelNum.p.o : required/Prelude.p.hi
+ghc/PrelNum.mc.o : ghc/IOBase.mc.hi
+ghc/PrelNum.norm.o : ghc/IOBase.norm.hi
+ghc/PrelNum.p.o : ghc/IOBase.p.hi
+ghc/PrelNum.o : ghc/PrelList.hi
+ghc/PrelNum.mc.o : ghc/PrelList.mc.hi
+ghc/PrelNum.norm.o : ghc/PrelList.norm.hi
+ghc/PrelNum.p.o : ghc/PrelList.p.hi
+ghc/PrelNum.o : ghc/PrelBase.hi
+ghc/PrelNum.mc.o : ghc/PrelBase.mc.hi
+ghc/PrelNum.norm.o : ghc/PrelBase.norm.hi
+ghc/PrelNum.p.o : ghc/PrelBase.p.hi
+ghc/PrelNum.o : ghc/GHC.hi
+ghc/PrelNum.mc.o : ghc/GHC.mc.hi
+ghc/PrelNum.norm.o : ghc/GHC.norm.hi
+ghc/PrelNum.p.o : ghc/GHC.p.hi
+ghc/PrelRead.o : ghc/PrelRead.lhs
+ghc/PrelRead.mc.o : ghc/PrelRead.lhs
+ghc/PrelRead.norm.o : ghc/PrelRead.lhs
+ghc/PrelRead.p.o : ghc/PrelRead.lhs
+ghc/PrelRead.mc.o : required/Prelude.mc.hi
+ghc/PrelRead.norm.o : required/Prelude.norm.hi
+ghc/PrelRead.p.o : required/Prelude.p.hi
+ghc/PrelRead.mc.o : ghc/IOBase.mc.hi
+ghc/PrelRead.norm.o : ghc/IOBase.norm.hi
+ghc/PrelRead.p.o : ghc/IOBase.p.hi
+ghc/PrelRead.o : ghc/PrelNum.hi
+ghc/PrelRead.mc.o : ghc/PrelNum.mc.hi
+ghc/PrelRead.norm.o : ghc/PrelNum.norm.hi
+ghc/PrelRead.p.o : ghc/PrelNum.p.hi
+ghc/PrelRead.o : ghc/PrelList.hi
+ghc/PrelRead.mc.o : ghc/PrelList.mc.hi
+ghc/PrelRead.norm.o : ghc/PrelList.norm.hi
+ghc/PrelRead.p.o : ghc/PrelList.p.hi
+ghc/PrelRead.o : ghc/PrelTup.hi
+ghc/PrelRead.mc.o : ghc/PrelTup.mc.hi
+ghc/PrelRead.norm.o : ghc/PrelTup.norm.hi
+ghc/PrelRead.p.o : ghc/PrelTup.p.hi
+ghc/PrelRead.o : ghc/PrelBase.hi
+ghc/PrelRead.mc.o : ghc/PrelBase.mc.hi
+ghc/PrelRead.norm.o : ghc/PrelBase.norm.hi
+ghc/PrelRead.p.o : ghc/PrelBase.p.hi
+ghc/PrelTup.o : ghc/PrelTup.lhs
+ghc/PrelTup.mc.o : ghc/PrelTup.lhs
+ghc/PrelTup.norm.o : ghc/PrelTup.lhs
+ghc/PrelTup.p.o : ghc/PrelTup.lhs
+ghc/PrelTup.mc.o : required/Prelude.mc.hi
+ghc/PrelTup.norm.o : required/Prelude.norm.hi
+ghc/PrelTup.p.o : required/Prelude.p.hi
+ghc/PrelTup.mc.o : ghc/IOBase.mc.hi
+ghc/PrelTup.norm.o : ghc/IOBase.norm.hi
+ghc/PrelTup.p.o : ghc/IOBase.p.hi
+ghc/PrelTup.o : ghc/PrelBase.hi
+ghc/PrelTup.mc.o : ghc/PrelBase.mc.hi
+ghc/PrelTup.norm.o : ghc/PrelBase.norm.hi
+ghc/PrelTup.p.o : ghc/PrelBase.p.hi
+ghc/STBase.o : ghc/STBase.lhs
+ghc/STBase.mc.o : ghc/STBase.lhs
+ghc/STBase.norm.o : ghc/STBase.lhs
+ghc/STBase.p.o : ghc/STBase.lhs
+ghc/STBase.mc.o : required/Prelude.mc.hi
+ghc/STBase.norm.o : required/Prelude.norm.hi
+ghc/STBase.p.o : required/Prelude.p.hi
+ghc/STBase.o : required/Ix.hi
+ghc/STBase.mc.o : required/Ix.mc.hi
+ghc/STBase.norm.o : required/Ix.norm.hi
+ghc/STBase.p.o : required/Ix.p.hi
+ghc/STBase.o : required/Monad.hi
+ghc/STBase.mc.o : required/Monad.mc.hi
+ghc/STBase.norm.o : required/Monad.norm.hi
+ghc/STBase.p.o : required/Monad.p.hi
+ghc/STBase.o : ghc/PrelTup.hi
+ghc/STBase.mc.o : ghc/PrelTup.mc.hi
+ghc/STBase.norm.o : ghc/PrelTup.norm.hi
+ghc/STBase.p.o : ghc/PrelTup.p.hi
+ghc/STBase.o : ghc/PrelBase.hi
+ghc/STBase.mc.o : ghc/PrelBase.mc.hi
+ghc/STBase.norm.o : ghc/PrelBase.norm.hi
+ghc/STBase.p.o : ghc/PrelBase.p.hi
+ghc/STBase.o : ghc/GHC.hi
+ghc/STBase.mc.o : ghc/GHC.mc.hi
+ghc/STBase.norm.o : ghc/GHC.norm.hi
+ghc/STBase.p.o : ghc/GHC.p.hi
+required/Array.o : required/Array.lhs
+required/Array.mc.o : required/Array.lhs
+required/Array.norm.o : required/Array.lhs
+required/Array.p.o : required/Array.lhs
+required/Array.mc.o : required/Prelude.mc.hi
+required/Array.norm.o : required/Prelude.norm.hi
+required/Array.p.o : required/Prelude.p.hi
 required/Array.o : required/Ix.hi
-required/Array.o : required/List.hi
-required/Array.o : prelude/GHCbase.hi
-required/Char.o : required/Char.hs
-required/Complex.o : required/Complex.hs
-required/Directory.o : required/Directory.hs
-required/Directory.o : prelude/GHCio.hi
-required/Directory.o : prelude/PreludeGlaST.hi
-required/Directory.o : prelude/GHCps.hi
-required/IO.o : required/IO.hs
+required/Array.mc.o : required/Ix.mc.hi
+required/Array.norm.o : required/Ix.norm.hi
+required/Array.p.o : required/Ix.p.hi
+required/Array.o : ghc/PrelList.hi
+required/Array.mc.o : ghc/PrelList.mc.hi
+required/Array.norm.o : ghc/PrelList.norm.hi
+required/Array.p.o : ghc/PrelList.p.hi
+required/Array.o : ghc/PrelRead.hi
+required/Array.mc.o : ghc/PrelRead.mc.hi
+required/Array.norm.o : ghc/PrelRead.norm.hi
+required/Array.p.o : ghc/PrelRead.p.hi
+required/Array.o : ghc/ArrBase.hi
+required/Array.mc.o : ghc/ArrBase.mc.hi
+required/Array.norm.o : ghc/ArrBase.norm.hi
+required/Array.p.o : ghc/ArrBase.p.hi
+required/Array.o : ghc/PrelBase.hi
+required/Array.mc.o : ghc/PrelBase.mc.hi
+required/Array.norm.o : ghc/PrelBase.norm.hi
+required/Array.p.o : ghc/PrelBase.p.hi
+required/Char.o : required/Char.lhs
+required/Char.mc.o : required/Char.lhs
+required/Char.norm.o : required/Char.lhs
+required/Char.p.o : required/Char.lhs
+required/Char.mc.o : required/Prelude.mc.hi
+required/Char.norm.o : required/Prelude.norm.hi
+required/Char.p.o : required/Prelude.p.hi
+required/Char.o : ghc/PrelBase.hi
+required/Char.mc.o : ghc/PrelBase.mc.hi
+required/Char.norm.o : ghc/PrelBase.norm.hi
+required/Char.p.o : ghc/PrelBase.p.hi
+required/Complex.o : required/Complex.lhs
+required/Complex.mc.o : required/Complex.lhs
+required/Complex.norm.o : required/Complex.lhs
+required/Complex.p.o : required/Complex.lhs
+required/Directory.o : required/Directory.lhs
+required/Directory.mc.o : required/Directory.lhs
+required/Directory.norm.o : required/Directory.lhs
+required/Directory.p.o : required/Directory.lhs
+required/Directory.o : glaExts/Foreign.hi
+required/Directory.mc.o : glaExts/Foreign.mc.hi
+required/Directory.norm.o : glaExts/Foreign.norm.hi
+required/Directory.p.o : glaExts/Foreign.p.hi
+required/Directory.o : ghc/IOBase.hi
+required/Directory.mc.o : ghc/IOBase.mc.hi
+required/Directory.norm.o : ghc/IOBase.norm.hi
+required/Directory.p.o : ghc/IOBase.p.hi
+required/Directory.o : ghc/STBase.hi
+required/Directory.mc.o : ghc/STBase.mc.hi
+required/Directory.norm.o : ghc/STBase.norm.hi
+required/Directory.p.o : ghc/STBase.p.hi
+required/Directory.o : glaExts/PackedString.hi
+required/Directory.mc.o : glaExts/PackedString.mc.hi
+required/Directory.norm.o : glaExts/PackedString.norm.hi
+required/Directory.p.o : glaExts/PackedString.p.hi
+required/IO.o : required/IO.lhs
+required/IO.mc.o : required/IO.lhs
+required/IO.norm.o : required/IO.lhs
+required/IO.p.o : required/IO.lhs
+required/IO.mc.o : required/Prelude.mc.hi
+required/IO.norm.o : required/Prelude.norm.hi
+required/IO.p.o : required/Prelude.p.hi
 required/IO.o : required/Ix.hi
-required/IO.o : prelude/GHCio.hi
-required/IO.o : prelude/GHCbase.hi
-required/IO.o : prelude/GHCps.hi
-required/Ix.o : required/Ix.hs
-required/List.o : required/List.hs
-required/Maybe.o : required/Maybe.hs
-required/Monad.o : required/Monad.hs
-required/Ratio.o : required/Ratio.hs
-required/System.o : required/System.hs
-required/System.o : prelude/GHCio.hi
-required/System.o : prelude/GHCps.hi
-required/System.o : prelude/GHCbase.hi
-concurrent/Channel.o : concurrent/Channel.hs
-concurrent/Channel.o : prelude/GHCbase.hi
-concurrent/ChannelVar.o : concurrent/ChannelVar.hs
-concurrent/ChannelVar.o : prelude/GHCbase.hi
-concurrent/Concurrent.o : concurrent/Concurrent.hs
+required/IO.mc.o : required/Ix.mc.hi
+required/IO.norm.o : required/Ix.norm.hi
+required/IO.p.o : required/Ix.p.hi
+required/IO.o : ghc/STBase.hi
+required/IO.mc.o : ghc/STBase.mc.hi
+required/IO.norm.o : ghc/STBase.norm.hi
+required/IO.p.o : ghc/STBase.p.hi
+required/IO.o : ghc/IOBase.hi
+required/IO.mc.o : ghc/IOBase.mc.hi
+required/IO.norm.o : ghc/IOBase.norm.hi
+required/IO.p.o : ghc/IOBase.p.hi
+required/IO.o : ghc/ArrBase.hi
+required/IO.mc.o : ghc/ArrBase.mc.hi
+required/IO.norm.o : ghc/ArrBase.norm.hi
+required/IO.p.o : ghc/ArrBase.p.hi
+required/IO.o : ghc/IOHandle.hi
+required/IO.mc.o : ghc/IOHandle.mc.hi
+required/IO.norm.o : ghc/IOHandle.norm.hi
+required/IO.p.o : ghc/IOHandle.p.hi
+required/IO.o : glaExts/PackedString.hi
+required/IO.mc.o : glaExts/PackedString.mc.hi
+required/IO.norm.o : glaExts/PackedString.norm.hi
+required/IO.p.o : glaExts/PackedString.p.hi
+required/IO.o : ghc/PrelBase.hi
+required/IO.mc.o : ghc/PrelBase.mc.hi
+required/IO.norm.o : ghc/PrelBase.norm.hi
+required/IO.p.o : ghc/PrelBase.p.hi
+required/IO.o : ghc/GHC.hi
+required/IO.mc.o : ghc/GHC.mc.hi
+required/IO.norm.o : ghc/GHC.norm.hi
+required/IO.p.o : ghc/GHC.p.hi
+required/Ix.o : required/Ix.lhs
+required/Ix.mc.o : required/Ix.lhs
+required/Ix.norm.o : required/Ix.lhs
+required/Ix.p.o : required/Ix.lhs
+required/Ix.mc.o : required/Prelude.mc.hi
+required/Ix.norm.o : required/Prelude.norm.hi
+required/Ix.p.o : required/Prelude.p.hi
+required/Ix.mc.o : ghc/IOBase.mc.hi
+required/Ix.norm.o : ghc/IOBase.norm.hi
+required/Ix.p.o : ghc/IOBase.p.hi
+required/Ix.o : ghc/PrelNum.hi
+required/Ix.mc.o : ghc/PrelNum.mc.hi
+required/Ix.norm.o : ghc/PrelNum.norm.hi
+required/Ix.p.o : ghc/PrelNum.p.hi
+required/Ix.o : ghc/PrelTup.hi
+required/Ix.mc.o : ghc/PrelTup.mc.hi
+required/Ix.norm.o : ghc/PrelTup.norm.hi
+required/Ix.p.o : ghc/PrelTup.p.hi
+required/Ix.o : ghc/PrelBase.hi
+required/Ix.mc.o : ghc/PrelBase.mc.hi
+required/Ix.norm.o : ghc/PrelBase.norm.hi
+required/Ix.p.o : ghc/PrelBase.p.hi
+required/List.o : required/List.lhs
+required/List.mc.o : required/List.lhs
+required/List.norm.o : required/List.lhs
+required/List.p.o : required/List.lhs
+required/List.mc.o : required/Prelude.mc.hi
+required/List.norm.o : required/Prelude.norm.hi
+required/List.p.o : required/Prelude.p.hi
+required/Maybe.o : required/Maybe.lhs
+required/Maybe.mc.o : required/Maybe.lhs
+required/Maybe.norm.o : required/Maybe.lhs
+required/Maybe.p.o : required/Maybe.lhs
+required/Maybe.mc.o : required/Prelude.mc.hi
+required/Maybe.norm.o : required/Prelude.norm.hi
+required/Maybe.p.o : required/Prelude.p.hi
+required/Maybe.mc.o : ghc/IOBase.mc.hi
+required/Maybe.norm.o : ghc/IOBase.norm.hi
+required/Maybe.p.o : ghc/IOBase.p.hi
+required/Maybe.o : required/Monad.hi
+required/Maybe.mc.o : required/Monad.mc.hi
+required/Maybe.norm.o : required/Monad.norm.hi
+required/Maybe.p.o : required/Monad.p.hi
+required/Maybe.o : ghc/PrelList.hi
+required/Maybe.mc.o : ghc/PrelList.mc.hi
+required/Maybe.norm.o : ghc/PrelList.norm.hi
+required/Maybe.p.o : ghc/PrelList.p.hi
+required/Maybe.o : ghc/PrelBase.hi
+required/Maybe.mc.o : ghc/PrelBase.mc.hi
+required/Maybe.norm.o : ghc/PrelBase.norm.hi
+required/Maybe.p.o : ghc/PrelBase.p.hi
+required/Monad.o : required/Monad.lhs
+required/Monad.mc.o : required/Monad.lhs
+required/Monad.norm.o : required/Monad.lhs
+required/Monad.p.o : required/Monad.lhs
+required/Monad.mc.o : required/Prelude.mc.hi
+required/Monad.norm.o : required/Prelude.norm.hi
+required/Monad.p.o : required/Prelude.p.hi
+required/Monad.o : ghc/PrelList.hi
+required/Monad.mc.o : ghc/PrelList.mc.hi
+required/Monad.norm.o : ghc/PrelList.norm.hi
+required/Monad.p.o : ghc/PrelList.p.hi
+required/Monad.o : ghc/PrelTup.hi
+required/Monad.mc.o : ghc/PrelTup.mc.hi
+required/Monad.norm.o : ghc/PrelTup.norm.hi
+required/Monad.p.o : ghc/PrelTup.p.hi
+required/Monad.o : ghc/PrelBase.hi
+required/Monad.mc.o : ghc/PrelBase.mc.hi
+required/Monad.norm.o : ghc/PrelBase.norm.hi
+required/Monad.p.o : ghc/PrelBase.p.hi
+required/Prelude.o : required/Prelude.lhs
+required/Prelude.mc.o : required/Prelude.lhs
+required/Prelude.norm.o : required/Prelude.lhs
+required/Prelude.p.o : required/Prelude.lhs
+required/Prelude.o : ghc/PrelBase.hi
+required/Prelude.mc.o : ghc/PrelBase.mc.hi
+required/Prelude.norm.o : ghc/PrelBase.norm.hi
+required/Prelude.p.o : ghc/PrelBase.p.hi
+required/Prelude.o : ghc/PrelList.hi
+required/Prelude.mc.o : ghc/PrelList.mc.hi
+required/Prelude.norm.o : ghc/PrelList.norm.hi
+required/Prelude.p.o : ghc/PrelList.p.hi
+required/Prelude.o : ghc/PrelIO.hi
+required/Prelude.mc.o : ghc/PrelIO.mc.hi
+required/Prelude.norm.o : ghc/PrelIO.norm.hi
+required/Prelude.p.o : ghc/PrelIO.p.hi
+required/Prelude.o : ghc/PrelRead.hi
+required/Prelude.mc.o : ghc/PrelRead.mc.hi
+required/Prelude.norm.o : ghc/PrelRead.norm.hi
+required/Prelude.p.o : ghc/PrelRead.p.hi
+required/Prelude.o : ghc/PrelNum.hi
+required/Prelude.mc.o : ghc/PrelNum.mc.hi
+required/Prelude.norm.o : ghc/PrelNum.norm.hi
+required/Prelude.p.o : ghc/PrelNum.p.hi
+required/Prelude.o : ghc/PrelTup.hi
+required/Prelude.mc.o : ghc/PrelTup.mc.hi
+required/Prelude.norm.o : ghc/PrelTup.norm.hi
+required/Prelude.p.o : ghc/PrelTup.p.hi
+required/Prelude.o : required/Monad.hi
+required/Prelude.mc.o : required/Monad.mc.hi
+required/Prelude.norm.o : required/Monad.norm.hi
+required/Prelude.p.o : required/Monad.p.hi
+required/Prelude.o : required/Maybe.hi
+required/Prelude.mc.o : required/Maybe.mc.hi
+required/Prelude.norm.o : required/Maybe.norm.hi
+required/Prelude.p.o : required/Maybe.p.hi
+required/Prelude.o : ghc/IOBase.hi
+required/Prelude.mc.o : ghc/IOBase.mc.hi
+required/Prelude.norm.o : ghc/IOBase.norm.hi
+required/Prelude.p.o : ghc/IOBase.p.hi
+required/Ratio.o : required/Ratio.lhs
+required/Ratio.mc.o : required/Ratio.lhs
+required/Ratio.norm.o : required/Ratio.lhs
+required/Ratio.p.o : required/Ratio.lhs
+required/Ratio.mc.o : required/Prelude.mc.hi
+required/Ratio.norm.o : required/Prelude.norm.hi
+required/Ratio.p.o : required/Prelude.p.hi
+required/Ratio.o : ghc/PrelNum.hi
+required/Ratio.mc.o : ghc/PrelNum.mc.hi
+required/Ratio.norm.o : ghc/PrelNum.norm.hi
+required/Ratio.p.o : ghc/PrelNum.p.hi
+required/System.o : required/System.lhs
+required/System.mc.o : required/System.lhs
+required/System.norm.o : required/System.lhs
+required/System.p.o : required/System.lhs
+required/System.o : glaExts/Foreign.hi
+required/System.mc.o : glaExts/Foreign.mc.hi
+required/System.norm.o : glaExts/Foreign.norm.hi
+required/System.p.o : glaExts/Foreign.p.hi
+required/System.o : ghc/IOBase.hi
+required/System.mc.o : ghc/IOBase.mc.hi
+required/System.norm.o : ghc/IOBase.norm.hi
+required/System.p.o : ghc/IOBase.p.hi
+required/System.o : ghc/ArrBase.hi
+required/System.mc.o : ghc/ArrBase.mc.hi
+required/System.norm.o : ghc/ArrBase.norm.hi
+required/System.p.o : ghc/ArrBase.p.hi
+required/System.o : glaExts/PackedString.hi
+required/System.mc.o : glaExts/PackedString.mc.hi
+required/System.norm.o : glaExts/PackedString.norm.hi
+required/System.p.o : glaExts/PackedString.p.hi
+glaExts/Foreign.o : glaExts/Foreign.lhs
+glaExts/Foreign.mc.o : glaExts/Foreign.lhs
+glaExts/Foreign.norm.o : glaExts/Foreign.lhs
+glaExts/Foreign.p.o : glaExts/Foreign.lhs
+glaExts/Foreign.mc.o : required/Prelude.mc.hi
+glaExts/Foreign.norm.o : required/Prelude.norm.hi
+glaExts/Foreign.p.o : required/Prelude.p.hi
+glaExts/Foreign.o : ghc/STBase.hi
+glaExts/Foreign.mc.o : ghc/STBase.mc.hi
+glaExts/Foreign.norm.o : ghc/STBase.norm.hi
+glaExts/Foreign.p.o : ghc/STBase.p.hi
+glaExts/Foreign.o : ghc/ArrBase.hi
+glaExts/Foreign.mc.o : ghc/ArrBase.mc.hi
+glaExts/Foreign.norm.o : ghc/ArrBase.norm.hi
+glaExts/Foreign.p.o : ghc/ArrBase.p.hi
+glaExts/Foreign.o : ghc/PrelNum.hi
+glaExts/Foreign.mc.o : ghc/PrelNum.mc.hi
+glaExts/Foreign.norm.o : ghc/PrelNum.norm.hi
+glaExts/Foreign.p.o : ghc/PrelNum.p.hi
+glaExts/Foreign.o : ghc/PrelBase.hi
+glaExts/Foreign.mc.o : ghc/PrelBase.mc.hi
+glaExts/Foreign.norm.o : ghc/PrelBase.norm.hi
+glaExts/Foreign.p.o : ghc/PrelBase.p.hi
+glaExts/Foreign.o : ghc/GHC.hi
+glaExts/Foreign.mc.o : ghc/GHC.mc.hi
+glaExts/Foreign.norm.o : ghc/GHC.norm.hi
+glaExts/Foreign.p.o : ghc/GHC.p.hi
+glaExts/PackedString.o : glaExts/PackedString.lhs
+glaExts/PackedString.mc.o : glaExts/PackedString.lhs
+glaExts/PackedString.norm.o : glaExts/PackedString.lhs
+glaExts/PackedString.p.o : glaExts/PackedString.lhs
+glaExts/PackedString.mc.o : required/Prelude.mc.hi
+glaExts/PackedString.norm.o : required/Prelude.norm.hi
+glaExts/PackedString.p.o : required/Prelude.p.hi
+glaExts/PackedString.mc.o : ghc/IOBase.mc.hi
+glaExts/PackedString.norm.o : ghc/IOBase.norm.hi
+glaExts/PackedString.p.o : ghc/IOBase.p.hi
+glaExts/PackedString.o : required/Ix.hi
+glaExts/PackedString.mc.o : required/Ix.mc.hi
+glaExts/PackedString.norm.o : required/Ix.norm.hi
+glaExts/PackedString.p.o : required/Ix.p.hi
+glaExts/PackedString.o : ghc/PrelList.hi
+glaExts/PackedString.mc.o : ghc/PrelList.mc.hi
+glaExts/PackedString.norm.o : ghc/PrelList.norm.hi
+glaExts/PackedString.p.o : ghc/PrelList.p.hi
+glaExts/PackedString.o : ghc/STBase.hi
+glaExts/PackedString.mc.o : ghc/STBase.mc.hi
+glaExts/PackedString.norm.o : ghc/STBase.norm.hi
+glaExts/PackedString.p.o : ghc/STBase.p.hi
+glaExts/PackedString.o : ghc/ArrBase.hi
+glaExts/PackedString.mc.o : ghc/ArrBase.mc.hi
+glaExts/PackedString.norm.o : ghc/ArrBase.norm.hi
+glaExts/PackedString.p.o : ghc/ArrBase.p.hi
+glaExts/PackedString.o : ghc/PrelBase.hi
+glaExts/PackedString.mc.o : ghc/PrelBase.mc.hi
+glaExts/PackedString.norm.o : ghc/PrelBase.norm.hi
+glaExts/PackedString.p.o : ghc/PrelBase.p.hi
+glaExts/PackedString.o : ghc/GHC.hi
+glaExts/PackedString.mc.o : ghc/GHC.mc.hi
+glaExts/PackedString.norm.o : ghc/GHC.norm.hi
+glaExts/PackedString.p.o : ghc/GHC.p.hi
+glaExts/ST.o : glaExts/ST.lhs
+glaExts/ST.mc.o : glaExts/ST.lhs
+glaExts/ST.norm.o : glaExts/ST.lhs
+glaExts/ST.p.o : glaExts/ST.lhs
+glaExts/ST.mc.o : required/Prelude.mc.hi
+glaExts/ST.norm.o : required/Prelude.norm.hi
+glaExts/ST.p.o : required/Prelude.p.hi
+glaExts/ST.mc.o : ghc/IOBase.mc.hi
+glaExts/ST.norm.o : ghc/IOBase.norm.hi
+glaExts/ST.p.o : ghc/IOBase.p.hi
+glaExts/ST.o : ghc/ArrBase.hi
+glaExts/ST.mc.o : ghc/ArrBase.mc.hi
+glaExts/ST.norm.o : ghc/ArrBase.norm.hi
+glaExts/ST.p.o : ghc/ArrBase.p.hi
+glaExts/ST.o : ghc/STBase.hi
+glaExts/ST.mc.o : ghc/STBase.mc.hi
+glaExts/ST.norm.o : ghc/STBase.norm.hi
+glaExts/ST.p.o : ghc/STBase.p.hi
+glaExts/ST.o : ghc/PrelBase.hi
+glaExts/ST.mc.o : ghc/PrelBase.mc.hi
+glaExts/ST.norm.o : ghc/PrelBase.norm.hi
+glaExts/ST.p.o : ghc/PrelBase.p.hi
+glaExts/ST.o : ghc/GHC.hi
+glaExts/ST.mc.o : ghc/GHC.mc.hi
+glaExts/ST.norm.o : ghc/GHC.norm.hi
+glaExts/ST.p.o : ghc/GHC.p.hi
+concurrent/Channel.o : concurrent/Channel.lhs
+concurrent/Channel.mc.o : concurrent/Channel.lhs
+concurrent/Channel.norm.o : concurrent/Channel.lhs
+concurrent/Channel.p.o : concurrent/Channel.lhs
+concurrent/ChannelVar.o : concurrent/ChannelVar.lhs
+concurrent/ChannelVar.mc.o : concurrent/ChannelVar.lhs
+concurrent/ChannelVar.norm.o : concurrent/ChannelVar.lhs
+concurrent/ChannelVar.p.o : concurrent/ChannelVar.lhs
+concurrent/Concurrent.o : concurrent/Concurrent.lhs
+concurrent/Concurrent.mc.o : concurrent/Concurrent.lhs
+concurrent/Concurrent.norm.o : concurrent/Concurrent.lhs
+concurrent/Concurrent.p.o : concurrent/Concurrent.lhs
+concurrent/Concurrent.o : required/IO.hi
+concurrent/Concurrent.mc.o : required/IO.mc.hi
+concurrent/Concurrent.norm.o : required/IO.norm.hi
+concurrent/Concurrent.p.o : required/IO.p.hi
 concurrent/Concurrent.o : concurrent/Parallel.hi
+concurrent/Concurrent.mc.o : concurrent/Parallel.mc.hi
+concurrent/Concurrent.norm.o : concurrent/Parallel.norm.hi
+concurrent/Concurrent.p.o : concurrent/Parallel.p.hi
 concurrent/Concurrent.o : concurrent/ChannelVar.hi
+concurrent/Concurrent.mc.o : concurrent/ChannelVar.mc.hi
+concurrent/Concurrent.norm.o : concurrent/ChannelVar.norm.hi
+concurrent/Concurrent.p.o : concurrent/ChannelVar.p.hi
 concurrent/Concurrent.o : concurrent/Channel.hi
+concurrent/Concurrent.mc.o : concurrent/Channel.mc.hi
+concurrent/Concurrent.norm.o : concurrent/Channel.norm.hi
+concurrent/Concurrent.p.o : concurrent/Channel.p.hi
 concurrent/Concurrent.o : concurrent/Semaphore.hi
+concurrent/Concurrent.mc.o : concurrent/Semaphore.mc.hi
+concurrent/Concurrent.norm.o : concurrent/Semaphore.norm.hi
+concurrent/Concurrent.p.o : concurrent/Semaphore.p.hi
 concurrent/Concurrent.o : concurrent/Merge.hi
+concurrent/Concurrent.mc.o : concurrent/Merge.mc.hi
+concurrent/Concurrent.norm.o : concurrent/Merge.norm.hi
+concurrent/Concurrent.p.o : concurrent/Merge.p.hi
 concurrent/Concurrent.o : concurrent/SampleVar.hi
-concurrent/Concurrent.o : prelude/GHCbase.hi
-concurrent/Merge.o : concurrent/Merge.hs
+concurrent/Concurrent.mc.o : concurrent/SampleVar.mc.hi
+concurrent/Concurrent.norm.o : concurrent/SampleVar.norm.hi
+concurrent/Concurrent.p.o : concurrent/SampleVar.p.hi
+concurrent/Concurrent.o : ghc/ConcBase.hi
+concurrent/Concurrent.mc.o : ghc/ConcBase.mc.hi
+concurrent/Concurrent.norm.o : ghc/ConcBase.norm.hi
+concurrent/Concurrent.p.o : ghc/ConcBase.p.hi
+concurrent/Merge.o : concurrent/Merge.lhs
+concurrent/Merge.mc.o : concurrent/Merge.lhs
+concurrent/Merge.norm.o : concurrent/Merge.lhs
+concurrent/Merge.p.o : concurrent/Merge.lhs
 concurrent/Merge.o : concurrent/Semaphore.hi
-concurrent/Merge.o : prelude/GHCbase.hi
-concurrent/Merge.o : prelude/GHCio.hi
-concurrent/Merge.o : concurrent/Concurrent.hi
-concurrent/Parallel.o : concurrent/Parallel.hs
-concurrent/Parallel.o : prelude/GHCbase.hi
-concurrent/Parallel.o : prelude/GHCerr.hi
-concurrent/SampleVar.o : concurrent/SampleVar.hs
-concurrent/SampleVar.o : prelude/GHCbase.hi
-concurrent/Semaphore.o : concurrent/Semaphore.hs
-concurrent/Semaphore.o : prelude/GHCbase.hi
+concurrent/Merge.mc.o : concurrent/Semaphore.mc.hi
+concurrent/Merge.norm.o : concurrent/Semaphore.norm.hi
+concurrent/Merge.p.o : concurrent/Semaphore.p.hi
+concurrent/Parallel.o : concurrent/Parallel.lhs
+concurrent/Parallel.mc.o : concurrent/Parallel.lhs
+concurrent/Parallel.norm.o : concurrent/Parallel.lhs
+concurrent/Parallel.p.o : concurrent/Parallel.lhs
+concurrent/SampelVar.o : concurrent/SampelVar.lhs
+concurrent/SampelVar.mc.o : concurrent/SampelVar.lhs
+concurrent/SampelVar.norm.o : concurrent/SampelVar.lhs
+concurrent/SampelVar.p.o : concurrent/SampelVar.lhs
+concurrent/SampleVar.o : concurrent/SampleVar.lhs
+concurrent/SampleVar.mc.o : concurrent/SampleVar.lhs
+concurrent/SampleVar.norm.o : concurrent/SampleVar.lhs
+concurrent/SampleVar.p.o : concurrent/SampleVar.lhs
+concurrent/Semaphore.o : concurrent/Semaphore.lhs
+concurrent/Semaphore.mc.o : concurrent/Semaphore.lhs
+concurrent/Semaphore.norm.o : concurrent/Semaphore.lhs
+concurrent/Semaphore.p.o : concurrent/Semaphore.lhs
 # DO NOT DELETE: End of Haskell dependencies
diff --git a/ghc/lib/Jmakefile b/ghc/lib/Jmakefile
new file mode 100644
index 0000000000..d7a1adf221
--- /dev/null
+++ b/ghc/lib/Jmakefile
@@ -0,0 +1,269 @@
+/* This is the Jmakefile for the library stuff.
+   This stuff is all written in (Glasgow-extended) Haskell.
+
+Everything here *must* be compiled w/ the Glasgow Haskell compiler.
+(Hence the use of $(GHC), rather than $(HC) [the latter is your "standard"
+Haskell compiler -- whatever you've configured]).
+
+If you use EXTRA_HC_OPTS on the command line (which you shouldn't,
+strictly speaking), it will probably work -- it is pinned onto
+GHC_OPTS, just for fun.
+*/
+
+/****************************************************************
+*								*
+* Jmakefile preamble-y things					*
+*								*
+****************************************************************/
+
+#define IHaveSubdirs
+
+#if IncludeTestDirsInBuild == YES
+#define __ghc_lib_tests_dir tests
+#else
+#define __ghc_lib_tests_dir /* nothing */
+#endif
+
+SUBDIRS = cbits __ghc_lib_tests_dir
+
+#define NoDocsTargetForSubdirs
+#define NoInstallDocsTargetForSubdirs
+#define NoDependTargetForSubdirs
+
+GhcDriverNeededHere(depend all)
+EtagsNeededHere(tags)
+
+/****************************************************************
+*								*
+* options used for compiling/etc. things			*
+*								*
+****************************************************************/
+
+/* The driver will give warnings if -split-objs, but that's cool... */
+GHC_OPTS=-recomp -cpp 		\
+	 -dcore-lint 		\
+	 -irequired:glaExts:ghc	\
+	 HcMaxHeapFlag $(EXTRA_HC_OPTS)
+
+EXTRA_MKDEPENDHS_OPTS = -irequired:prelude:ghc:hbc:glaExts:concurrent
+
+PREL_OPTS=
+
+/* per-build options: shared with RTS */
+#define rts_or_lib(r,l) l
+#include "../mkworld/GHC_OPTS"
+
+/* this is just friendliness to "hstags" */
+HSTAGS_OPTS=-fglasgow-exts
+
+/***************************************************************/
+
+/****************************************************************
+*								*
+* what it is we are compiling;					*
+*   these are long and tedious lists, but c'est la guerre	*
+*								*
+****************************************************************/
+
+BASIC_HS =		\
+required/Prelude.lhs	\
+required/Array.lhs		\
+required/Char.lhs		\
+required/Complex.lhs		\
+required/Directory.lhs		\
+required/IO.lhs			\
+required/Ix.lhs			\
+required/List.lhs		\
+required/Maybe.lhs		\
+required/Monad.lhs		\
+required/Ratio.lhs		\
+required/System.lhs		\
+\
+ghc/PrelBase.lhs	\
+ghc/GHCerr.lhs          \
+ghc/PrelIO.lhs		\
+ghc/IOHandle.lhs	\
+ghc/IOBase.lhs		\
+ghc/STBase.lhs		\
+ghc/ArrBase.lhs		\
+ghc/PrelRead.lhs	\
+ghc/GHCmain.lhs		\
+ghc/PrelList.lhs	\
+ghc/PrelNum.lhs		\
+ghc/PrelTup.lhs		\
+\
+glaExts/ST.lhs		\
+glaExts/Foreign.lhs	\
+glaExts/PackedString.lhs	\
+
+# Leave out concurrency for now
+# \
+ghc/ConcBase.lhs        \
+# concurrent/Channel.lhs		\
+# concurrent/ChannelVar.lhs	\
+# concurrent/Merge.lhs		\
+# concurrent/Parallel.lhs		\
+# concurrent/SampleVar.lhs	\
+# concurrent/Semaphore.lhs	\
+# concurrent/Concurrent.lhs
+
+BASIC_HIs = $(BASIC_HS:.lhs=.hi)
+
+BASIC_OBJS_DIRS	= $(BASIC_HS:.lhs=)
+
+/* easy way to make many many Make variables: */
+WayThingVars(BASIC)
+
+/************************************************************************
+*									*
+* Macros for creating and installing libHS<x>.a (in its many flavors).	*
+*									*
+*************************************************************************/
+
+/****************************************************************
+*								*
+* Creating and installing...					*
+*	libHS_<tag>.a		standard Prelude library	*
+*								*
+****************************************************************/
+
+/* make sure install's target dir is there */
+#if DoInstallGHCSystem == YES
+MakeDirectories(install, $(INSTLIBDIR_GHC) $(INSTDATADIR_GHC)/imports)
+
+InstallDataTarget(MODULES,$(INSTDATADIR_GHC)/imports)
+#endif /* installing */
+
+BasicEverything(libHS, $(INSTLIBDIR_GHC), $(INSTDATADIR_GHC))
+
+/****************************************************************
+*								*
+* Creating the individual .hc files: 				*
+*								*
+*   For the just-vary-the-GC-thanks flavors, we only need to	*
+*   compile .hs->.hc once; then re-use the .hc file each time.	*
+*								*
+*   For the profiling one (_p) and all the user-specified	*
+*   ones, we recompile the Haskell each time.			*
+*								*
+*  NB: old (WDP 95/06)						*
+****************************************************************/
+
+/* some "helpful" internal macros first... */
+
+#if GhcWithHscBuiltViaC == YES && HaskellCompilerType == HC_USE_HC_FILES
+#define CompileWayishly__(hc,file,isuf,way,flags)	@@\
+clean  ::						@@\
+	$(RM) CAT3(file,way,.hc)
+#endif
+
+/* now use the macro: */
+
+/* NB: the -Onots are only because -O would not go through on
+   a reasonably-sized machine (i.e., one I have)
+*/
+
+
+CompileWayishly(GHC,required/Prelude,lhs,	/*-split-objs Prelude*/		-fglasgow-exts)
+CompileWayishly(GHC,required/Array,lhs,		/*-split-objs Array*/		-fglasgow-exts)
+CompileWayishly(GHC,required/Char,lhs,  	/*-split-objs Char*/)
+CompileWayishly(GHC,required/Complex,lhs,	/*-split-objs Complex*/)
+CompileWayishly(GHC,required/Ix,lhs,		/*-split-objs Ix*/		-fglasgow-exts)
+CompileWayishly(GHC,required/List,lhs,		/*-split-objs List*/)
+CompileWayishly(GHC,required/Maybe,lhs,		/*-split-objs Maybe*/)
+CompileWayishly(GHC,required/Monad,lhs,		/*-split-objs Monad*/)
+CompileWayishly(GHC,required/Ratio,lhs,		/*-split-objs Ratio*/)
+
+CompileWayishly(GHC,required/Directory,lhs,	/*-split-objs Directory*/	-fglasgow-exts \
+						'-#include"cbits/stgio.h"' -monly-3-regs)
+CompileWayishly(GHC,required/IO,lhs,		/*-split-objs IO*/		-fglasgow-exts \
+						'-#include"cbits/stgio.h"')
+CompileWayishly(GHC,required/System,lhs,	/*-split-objs System*/		-fglasgow-exts \
+						 '-#include"cbits/stgio.h"')
+
+
+CompileWayishly(GHC,ghc/ConcBase,lhs,		/*-split-objs ConcBase*/	-fglasgow-exts)
+CompileWayishly(GHC,ghc/PrelBase,lhs,		/*-split-objs PrelBase*/	-fglasgow-exts)
+CompileWayishly(GHC,ghc/STBase,lhs,		/*-split-objs STBase*/ 		-fglasgow-exts)
+CompileWayishly(GHC,ghc/IOBase,lhs,		/*-split-objs IOBase*/ 		-fglasgow-exts)
+CompileWayishly(GHC,ghc/ArrBase,lhs,		/*-split-objs ArrBase*/		-fglasgow-exts)
+CompileWayishly(GHC,ghc/PrelRead,lhs,		/*-split-objs PrelRead*/ 	-fglasgow-exts)
+CompileWayishly(GHC,ghc/PrelList,lhs,		/*-split-objs PrelList*/)
+CompileWayishly(GHC,ghc/PrelNum,lhs,		/*-split-objs PrelNum*/ 	-fglasgow-exts)
+CompileWayishly(GHC,ghc/PrelTup,lhs,		/*-split-objs PrelTup*/)
+CompileWayishly(GHC,ghc/PrelIO,lhs,		/*-split-objs PrelIO*/ 		-fglasgow-exts)
+CompileWayishly(GHC,ghc/IOHandle,lhs,		/*-split-objs IOHandle*/	-fglasgow-exts)
+CompileWayishly(GHC,ghc/GHCerr,lhs,		/*-split-objs GHCerr*/ 		-fglasgow-exts)
+CompileWayishly(GHC,ghc/GHCmain,lhs,		/*-split-objs GHCmain*/ 	-fglasgow-exts)
+
+CompileWayishly(GHC,glaExts/Foreign,lhs,	/*-split-objs Foreign*/ 	-fglasgow-exts)
+CompileWayishly(GHC,glaExts/ST,lhs,		/*-split-objs ST*/ 		-fglasgow-exts)
+CompileWayishly(GHC,glaExts/PackedString,lhs,	/*-split-objs PackedString*/ 	-fglasgow-exts)
+
+
+CompileWayishly(GHC,concurrent/Channel,lhs,)
+CompileWayishly(GHC,concurrent/ChannelVar,lhs,)
+CompileWayishly(GHC,concurrent/Merge,lhs,-iconcurrent)
+CompileWayishly(GHC,concurrent/Parallel,lhs,-fglasgow-exts)
+CompileWayishly(GHC,concurrent/SampleVar,lhs,)
+CompileWayishly(GHC,concurrent/Semaphore,lhs,)
+CompileWayishly(GHC,concurrent/Concurrent,lhs,-iconcurrent)
+
+/****************************************************************
+*								*
+* misc "make" targets -- depend, clean, tags			*
+*								*
+****************************************************************/
+
+hc-files : $(BASIC_HS:.lhs=.hc)
+
+/* this is a BAD idea!
+ExtraStuffToClean( $(SRCS_C) )
+   without the .hc files, the distrib cannot boot itself
+*/
+ExtraStuffToBeVeryClean( $(SRCS_C) )
+ExtraStuffToBeVeryClean( $(STD_VERY_CLEAN) )
+
+ClearTagsFile()
+/* Ugly but OK? [WDP 94/09] */
+HsTagsTarget( */[A-Z]*.*hs )
+HSTAGS_OPTS=-cpp -fglasgow-exts
+
+/* should be *LAST* */
+#if HaskellCompilerType != HC_USE_HC_FILES
+    /* otherwise, the dependencies jeopardize our .hc files --
+	which are all we have! */
+MAIN_INCLUDE_DIR = $(TOP_PWD)/$(CURRENT_DIR)/$(GHC_INCLUDES)
+
+MKDEPENDHS_OPTS= \
+IfBuild_mc(-s mc) \
+IfBuild_mr(-s mr) \
+IfBuild_mt(-s mt) \
+IfBuild_mp(-s mp) \
+IfBuild_mg(-s mg) \
+IfBuild_2s(-s 2s) \
+IfBuild_1s(-s 1s) \
+IfBuild_du(-s du) \
+IfBuild_p(-s p) \
+IfBuild_t(-s t) \
+IfBuild_a(-s a) \
+IfBuild_b(-s b) \
+IfBuild_c(-s c) \
+IfBuild_d(-s d) \
+IfBuild_e(-s e) \
+IfBuild_f(-s f) \
+IfBuild_g(-s g) \
+IfBuild_h(-s h) \
+IfBuild_i(-s i) \
+IfBuild_j(-s j) \
+IfBuild_k(-s k) \
+IfBuild_l(-s l) \
+IfBuild_m(-s m) \
+IfBuild_n(-s n) \
+IfBuild_o(-s o) \
+IfBuild_A(-s A) \
+IfBuild_B(-s B) \
+-o hc -I$(MAIN_INCLUDE_DIR) 
+
+HaskellDependTarget( $(BASIC_HS) )
+#endif
diff --git a/ghc/lib/Makefile b/ghc/lib/Makefile
index 2f90b3af60..006c382749 100644
--- a/ghc/lib/Makefile
+++ b/ghc/lib/Makefile
@@ -1,5 +1,5 @@
 #-----------------------------------------------------------------------------
-# $Id: Makefile,v 1.2 1996/11/21 16:47:41 simonm Exp $
+# $Id: Makefile,v 1.3 1996/12/19 09:13:55 simonpj Exp $
 
 TOP = ../..
 include $(TOP)/ghc/mk/ghc.mk
@@ -25,6 +25,10 @@ all ::
 		$(MAKE) -f Makefile.libHS suffix=$$i; \
 	done
 
+# Shortcut for typical case when testing: just make the "normal" version
+libHS.a ::
+	$(MAKE)  -f Makefile.libHS suffix=norm
+
 install ::
 	@for i in $(WAY_SUFFIXES); do \
 		$(MAKE) -f Makefile.libHS suffix=$$i install; \
diff --git a/ghc/lib/Makefile.libHS b/ghc/lib/Makefile.libHS
index 6e03d3fc13..453eb2f4c1 100644
--- a/ghc/lib/Makefile.libHS
+++ b/ghc/lib/Makefile.libHS
@@ -1,5 +1,5 @@
 #-----------------------------------------------------------------------------
-# $Id: Makefile.libHS,v 1.2 1996/11/21 16:47:42 simonm Exp $
+# $Id: Makefile.libHS,v 1.3 1996/12/19 09:13:56 simonpj Exp $
 
 TOP = ../..
 include $(TOP)/ghc/mk/ghc.mk
@@ -7,16 +7,30 @@ include $(TOP)/ghc/mk/ghc.mk
 # per-build options: shared with runtime system
 include ../mk/buildflags.mk
 
+#	============= ADDED BY SIMON =============
+ifeq ($(GhcWithHscBuiltViaC),YES)
+  HC = $(GHC)
+  SuffixRule_hc_o = YES
+else
+  HaskellSuffixRules = YES
+endif
+include $(TOP)/mk/rules.mk
+#	===========================================
+
 # Everything here *must* be compiled with the Glasgow Haskell compiler.
 # (Hence the use of $(GHC), rather than $(HC).)
 # The driver will give warnings if -split-objs, but that's cool...
 
 GHC_OPTS = \
-  -recomp -cpp -dcore-lint -irequired -fusing-ghc-internals -fvia-C \
+  -recomp -cpp -dcore-lint -fglasgow-exts -fvia-C \
   $(HcMaxHeapFlag) $(EXTRA_HC_OPTS)
 
-SRCS = $(wildcard prelude/*.hs required/*.hs concurrent/*.hs)
-OBJS = $(SRCS:.hs=.$(suffix)_o)
+SRCS = $(wildcard ghc/*.lhs required/*.lhs glaExts/*.lhs concurrent/*.lhs)
+ifeq ($(suffix), norm)
+OBJS = $(SRCS:.lhs=.o)
+else
+OBJS = $(SRCS:.lhs=.$(suffix)_o)
+endif
 
 #-----------------------------------------------------------------------------
 # Rules for building various types of objects from HS files
@@ -31,10 +45,10 @@ LIB_GHC = $(GHC) $(GHCFLAGS) -o $@ -c
 endif
 
 ifneq ($(GhcWithHscBuiltViaC),YES)
-%.o : %.hs
-	$(LIB_GHC) $($*_flags) $*.hs
+%.o : %.lhs
+	$(LIB_GHC) $($*_flags) $*.lhs
 
-%.$(suffix)_o : %.hs
+%.$(suffix)_o : %.lhs
 	$(LIB_GHC) $(GHC_OPTS_$(suffix)) $($*_flags) $*.hs
 
 else # $(GhcWithHscBuiltViaC) == YES
@@ -75,27 +89,9 @@ veryclean ::
 # The -Onots are only because -O would not go through on
 # a reasonably-sized machine (i.e., one I have)
 
-prelude/Prelude_flags = \
-   -iprelude -fglasgow-exts -fcompiling-ghc-internals Prelude \
-   -fno-implicit-prelude '-\#include"cbits/stgio.h"' -H18m -Onot
-prelude/GHCbase_flags = \
-  -iprelude -fglasgow-exts -fcompiling-ghc-internals GHCbase \
-  '-\#include"cbits/stgio.h"' -H20m -monly-2-regs -Onot
-prelude/GHCerr_flags = \
-  -iprelude -fglasgow-exts -fcompiling-ghc-internals GHCerr -H12m -Onot
-prelude/GHCps_flags = \
-  -iprelude -fglasgow-exts '-\#include"cbits/stgio.h"' -monly-3-regs -Onot
-prelude/GHCio_flags = \
-  -iprelude -fglasgow-exts '-\#include"cbits/stgio.h"' -Onot
-prelude/GHCmain_flags = -iprelude -fglasgow-exts
-prelude/PreludeGlaST_flags = -iprelude -fglasgow-exts
-
-required/Array_flags = -fglasgow-exts -iprelude -Onot
-required/Directory_flags = \
-  -fglasgow-exts '-\#include"cbits/stgio.h"' -monly-3-regs
-required/IO_flags = -fglasgow-exts '-\#include"cbits/stgio.h"'
-required/Ix_flags = -fglasgow-exts
-required/System_flags = -fglasgow-exts '-\#include"cbits/stgio.h"'
+ghc/PackedString_flags	 = '-\#include"cbits/stgio.h"' -monly-3-regs
+required/Directory_flags = '-\#include"cbits/stgio.h"' -monly-3-regs
+required/System_flags 	 = '-\#include"cbits/stgio.h"'
 
 concurrent/Merge_flags = -iconcurrent
 concurrent/Parallel_flags = -fglasgow-exts
@@ -105,7 +101,7 @@ concurrent/Concurrent_flags = -iconcurrent
 # Depend and install stuff
 
 MKDEPENDHS_OPTS += -I$(GHC_INCLUDES)
-MKDEPENDHS_OPTS += -irequired:prelude:ghc:hbc:glaExts:concurrent
+MKDEPENDHS_OPTS += -irequired:ghc:hbc:glaExts:concurrent
 MKDEPENDHS_OPTS += $(foreach way,$(WAY_SUFFIXES),-s .$(way))
 
 # Todo: make this a generic include of hsdepend.mk or something.
diff --git a/ghc/runtime/main/StgStartup.lhc b/ghc/runtime/main/StgStartup.lhc
index 086f755a08..b41500dd6b 100644
--- a/ghc/runtime/main/StgStartup.lhc
+++ b/ghc/runtime/main/StgStartup.lhc
@@ -198,9 +198,9 @@ SET_STATIC_HDR(EmptySPTable_closure,EmptyStablePointerTable_info,CC_SUBSUMED,,ED
 /* Question: this is just an amusing hex code isn't it
    -- or does it mean something? ADR */
 P_ realWorldZh_closure = (P_) 0xbadbadbaL;
-P_ GHCbuiltins_void_closure = (P_) 0xbadbadbaL;
+P_ GHC_void_closure = (P_) 0xbadbadbaL;
 
-SET_STATIC_HDR(WorldStateToken_closure,GHCbase_SZh_static_info,CC_SUBSUMED/*harmless*/,,ED_RO_)
+SET_STATIC_HDR(WorldStateToken_closure,STBase_SZh_static_info,CC_SUBSUMED/*harmless*/,,ED_RO_)
 , (W_) 0xbadbadbaL
 };
 
diff --git a/ghc/runtime/prims/PrimMisc.lc b/ghc/runtime/prims/PrimMisc.lc
index 142bab6339..dc29069f71 100644
--- a/ghc/runtime/prims/PrimMisc.lc
+++ b/ghc/runtime/prims/PrimMisc.lc
@@ -86,11 +86,11 @@ Phantom info table vectors for multiple constructor primitive types that
 might have to perform a DynamicReturn (just Bool at the moment).
 
 \begin{code}
-ED_RO_(Prelude_False_inregs_info);
-ED_RO_(Prelude_True_inregs_info);
+ED_RO_(PrelBase_False_inregs_info);
+ED_RO_(PrelBase_True_inregs_info);
 
-const W_ Prelude_Bool_itblvtbl[] = {
-    (W_) Prelude_False_inregs_info,
-    (W_) Prelude_True_inregs_info
+const W_ PrelBase_Bool_itblvtbl[] = {
+    (W_) PrelBase_False_inregs_info,
+    (W_) PrelBase_True_inregs_info
 };
 \end{code}
diff --git a/ghc/runtime/storage/SMstatic.lc b/ghc/runtime/storage/SMstatic.lc
index 96400afd53..861b67f4a5 100644
--- a/ghc/runtime/storage/SMstatic.lc
+++ b/ghc/runtime/storage/SMstatic.lc
@@ -11,15 +11,15 @@ are built by the compiler from {\tr uTys.hs}.
 #define NULL_REG_MAP
 #include "SMinternal.h"
 
-EXTDATA_RO(Prelude_CZh_static_info);
-EXTDATA_RO(Prelude_IZh_static_info);
+EXTDATA_RO(PrelBase_CZh_static_info);
+EXTDATA_RO(PrelBase_IZh_static_info);
 
 #define __CHARLIKE_CLOSURE(n) (CHARLIKE_closures+((n)*(CHARLIKE_HS+1)))
 #define __INTLIKE_CLOSURE(n)  (INTLIKE_closures_def+(((n)-MIN_INTLIKE)*(INTLIKE_HS+1)))
 
-#define CHARLIKE_HDR(n)	    SET_STATIC_FIXED_HDR(__CHARLIKE_CLOSURE(n),Prelude_CZh_static_info,CC_DONTZuCARE), (W_) n
+#define CHARLIKE_HDR(n)	    SET_STATIC_FIXED_HDR(__CHARLIKE_CLOSURE(n),PrelBase_CZh_static_info,CC_DONTZuCARE), (W_) n
 
-#define INTLIKE_HDR(n)	    SET_STATIC_FIXED_HDR(__INTLIKE_CLOSURE(n),Prelude_IZh_static_info,CC_DONTZuCARE), (W_) n
+#define INTLIKE_HDR(n)	    SET_STATIC_FIXED_HDR(__INTLIKE_CLOSURE(n),PrelBase_IZh_static_info,CC_DONTZuCARE), (W_) n
 
 const W_ CHARLIKE_closures[] = {
     CHARLIKE_HDR(0),