From 6c381e873e222417d9a67aeec77b9555eca7b7a8 Mon Sep 17 00:00:00 2001
From: partain <unknown>
Date: Tue, 19 Mar 1996 09:11:07 +0000
Subject: [project @ 1996-03-19 08:58:34 by partain] simonpj/sansom/partain/dnt
 1.3 compiler stuff through 96/03/18

---
 ghc/compiler/HsVersions.h               |    2 +
 ghc/compiler/Jmakefile                  | 1275 ++++++-----------
 ghc/compiler/absCSyn/AbsCFuns.hi        |   30 -
 ghc/compiler/absCSyn/AbsCFuns.lhs       |  864 ------------
 ghc/compiler/absCSyn/AbsCSyn.hi         |  149 --
 ghc/compiler/absCSyn/AbsCSyn.lhs        |  208 +--
 ghc/compiler/absCSyn/AbsCUtils.lhs      |  772 +++++++++++
 ghc/compiler/absCSyn/CLabel.lhs         |  402 ++++++
 ghc/compiler/absCSyn/CStrings.lhs       |  153 ++
 ghc/compiler/absCSyn/Costs.hi           |   12 -
 ghc/compiler/absCSyn/Costs.lhs          |  418 +++---
 ghc/compiler/absCSyn/HeapOffs.hi        |   28 -
 ghc/compiler/absCSyn/HeapOffs.lhs       |   46 +-
 ghc/compiler/absCSyn/PprAbsC.hi         |   26 -
 ghc/compiler/absCSyn/PprAbsC.lhs        |  376 +++--
 ghc/compiler/basicTypes/BasicLit.hi     |   22 -
 ghc/compiler/basicTypes/BasicLit.lhs    |  197 ---
 ghc/compiler/basicTypes/CLabelInfo.hi   |   48 -
 ghc/compiler/basicTypes/CLabelInfo.lhs  |  661 ---------
 ghc/compiler/basicTypes/Id.hi           |  153 --
 ghc/compiler/basicTypes/Id.lhs          | 1464 +++++++++-----------
 ghc/compiler/basicTypes/IdInfo.hi       |  142 --
 ghc/compiler/basicTypes/IdInfo.lhs      |  439 ++----
 ghc/compiler/basicTypes/IdLoop.lhi      |   76 +
 ghc/compiler/basicTypes/IdUtils.lhs     |   98 ++
 ghc/compiler/basicTypes/Inst.hi         |   68 -
 ghc/compiler/basicTypes/Inst.lhs        |  391 ------
 ghc/compiler/basicTypes/Literal.lhs     |  191 +++
 ghc/compiler/basicTypes/Name.lhs        |  295 ++++
 ghc/compiler/basicTypes/NameLoop.lhi    |   20 +
 ghc/compiler/basicTypes/NameTypes.hi    |   25 -
 ghc/compiler/basicTypes/NameTypes.lhs   |   62 +-
 ghc/compiler/basicTypes/OrdList.hi      |    9 -
 ghc/compiler/basicTypes/OrdList.lhs     |  236 ----
 ghc/compiler/basicTypes/PragmaInfo.lhs  |   18 +
 ghc/compiler/basicTypes/ProtoName.hi    |   20 -
 ghc/compiler/basicTypes/ProtoName.lhs   |   59 +-
 ghc/compiler/basicTypes/SplitUniq.hi    |   18 -
 ghc/compiler/basicTypes/SplitUniq.lhs   |  305 ----
 ghc/compiler/basicTypes/SrcLoc.hi       |   13 -
 ghc/compiler/basicTypes/SrcLoc.lhs      |    5 +-
 ghc/compiler/basicTypes/UniqSupply.lhs  |  190 +++
 ghc/compiler/basicTypes/Unique.hi       |  175 ---
 ghc/compiler/basicTypes/Unique.lhs      |  773 ++++-------
 ghc/compiler/codeGen/CgBindery.hi       |   63 -
 ghc/compiler/codeGen/CgBindery.lhs      |   81 +-
 ghc/compiler/codeGen/CgCase.hi          |   22 -
 ghc/compiler/codeGen/CgCase.lhs         |  223 ++-
 ghc/compiler/codeGen/CgClosure.hi       |   29 -
 ghc/compiler/codeGen/CgClosure.lhs      |  254 ++--
 ghc/compiler/codeGen/CgCompInfo.hi      |   50 -
 ghc/compiler/codeGen/CgCompInfo.lhs     |   30 +-
 ghc/compiler/codeGen/CgCon.hi           |   28 -
 ghc/compiler/codeGen/CgCon.lhs          |  156 +--
 ghc/compiler/codeGen/CgConTbls.hi       |   23 -
 ghc/compiler/codeGen/CgConTbls.lhs      |  151 +-
 ghc/compiler/codeGen/CgExpr.hi          |   20 -
 ghc/compiler/codeGen/CgExpr.lhs         |   89 +-
 ghc/compiler/codeGen/CgHeapery.hi       |   27 -
 ghc/compiler/codeGen/CgHeapery.lhs      |  138 +-
 ghc/compiler/codeGen/CgLetNoEscape.hi   |   11 -
 ghc/compiler/codeGen/CgLetNoEscape.lhs  |   34 +-
 ghc/compiler/codeGen/CgMonad.hi         |  108 --
 ghc/compiler/codeGen/CgMonad.lhs        |  160 +--
 ghc/compiler/codeGen/CgRetConv.hi       |   26 -
 ghc/compiler/codeGen/CgRetConv.lhs      |   99 +-
 ghc/compiler/codeGen/CgStackery.hi      |   28 -
 ghc/compiler/codeGen/CgStackery.lhs     |   21 +-
 ghc/compiler/codeGen/CgTailCall.hi      |   33 -
 ghc/compiler/codeGen/CgTailCall.lhs     |  112 +-
 ghc/compiler/codeGen/CgUpdate.hi        |    6 -
 ghc/compiler/codeGen/CgUpdate.lhs       |   79 +-
 ghc/compiler/codeGen/CgUsages.hi        |   29 -
 ghc/compiler/codeGen/CgUsages.lhs       |   20 +-
 ghc/compiler/codeGen/ClosureInfo.hi     |  106 --
 ghc/compiler/codeGen/ClosureInfo.lhs    |  185 ++-
 ghc/compiler/codeGen/CodeGen.hi         |   24 -
 ghc/compiler/codeGen/CodeGen.lhs        |   67 +-
 ghc/compiler/codeGen/SMRep.hi           |   15 -
 ghc/compiler/codeGen/SMRep.lhs          |   22 +-
 ghc/compiler/coreSyn/AnnCoreSyn.hi      |   43 -
 ghc/compiler/coreSyn/AnnCoreSyn.lhs     |  126 +-
 ghc/compiler/coreSyn/CoreFuns.hi        |   62 -
 ghc/compiler/coreSyn/CoreFuns.lhs       | 1309 ------------------
 ghc/compiler/coreSyn/CoreLift.hi        |   26 -
 ghc/compiler/coreSyn/CoreLift.lhs       |  263 ++--
 ghc/compiler/coreSyn/CoreLint.hi        |   16 -
 ghc/compiler/coreSyn/CoreLint.lhs       |  725 +++++-----
 ghc/compiler/coreSyn/CoreSyn.hi         |   46 -
 ghc/compiler/coreSyn/CoreSyn.lhs        |  625 +++++----
 ghc/compiler/coreSyn/CoreUnfold.hi      |   12 -
 ghc/compiler/coreSyn/CoreUnfold.lhs     |  433 ++++--
 ghc/compiler/coreSyn/CoreUtils.lhs      |  802 +++++++++++
 ghc/compiler/coreSyn/FreeVars.hi        |   33 -
 ghc/compiler/coreSyn/FreeVars.lhs       |  238 ++--
 ghc/compiler/coreSyn/Jmakefile          |   11 -
 ghc/compiler/coreSyn/PlainCore.hi       |  167 ---
 ghc/compiler/coreSyn/PlainCore.lhs      |  185 ---
 ghc/compiler/coreSyn/PprCore.lhs        |  457 ++++++
 ghc/compiler/coreSyn/TaggedCore.hi      |   81 --
 ghc/compiler/coreSyn/TaggedCore.lhs     |   93 --
 ghc/compiler/deSugar/Desugar.hi         |   32 -
 ghc/compiler/deSugar/Desugar.lhs        |   71 +-
 ghc/compiler/deSugar/DsBinds.hi         |   19 -
 ghc/compiler/deSugar/DsBinds.lhs        |  261 ++--
 ghc/compiler/deSugar/DsCCall.hi         |   14 -
 ghc/compiler/deSugar/DsCCall.lhs        |  150 +-
 ghc/compiler/deSugar/DsExpr.hi          |   15 -
 ghc/compiler/deSugar/DsExpr.lhs         |  351 +++--
 ghc/compiler/deSugar/DsGRHSs.hi         |   18 -
 ghc/compiler/deSugar/DsGRHSs.lhs        |   43 +-
 ghc/compiler/deSugar/DsHsSyn.lhs        |   75 +
 ghc/compiler/deSugar/DsListComp.hi      |   15 -
 ghc/compiler/deSugar/DsListComp.lhs     |  148 +-
 ghc/compiler/deSugar/DsLoop.lhi         |   31 +
 ghc/compiler/deSugar/DsMonad.hi         |   68 -
 ghc/compiler/deSugar/DsMonad.lhs        |  188 ++-
 ghc/compiler/deSugar/DsParZF.lhs        |  233 ----
 ghc/compiler/deSugar/DsUtils.hi         |   35 -
 ghc/compiler/deSugar/DsUtils.lhs        |  296 ++--
 ghc/compiler/deSugar/Match.hi           |   19 -
 ghc/compiler/deSugar/Match.lhs          |  237 ++--
 ghc/compiler/deSugar/MatchCon.hi        |   14 -
 ghc/compiler/deSugar/MatchCon.lhs       |   80 +-
 ghc/compiler/deSugar/MatchLit.hi        |   14 -
 ghc/compiler/deSugar/MatchLit.lhs       |  157 +--
 ghc/compiler/deSugar/MatchProc.lhs      |   98 --
 ghc/compiler/deforest/Core2Def.hi       |   17 -
 ghc/compiler/deforest/Core2Def.lhs      |  124 +-
 ghc/compiler/deforest/Cyclic.hi         |    9 -
 ghc/compiler/deforest/Cyclic.lhs        |  244 ++--
 ghc/compiler/deforest/Def2Core.hi       |   17 -
 ghc/compiler/deforest/Def2Core.lhs      |  231 ++--
 ghc/compiler/deforest/DefExpr.hi        |   11 -
 ghc/compiler/deforest/DefExpr.lhs       |  560 ++++----
 ghc/compiler/deforest/DefSyn.hi         |   14 -
 ghc/compiler/deforest/DefSyn.lhs        |   30 +-
 ghc/compiler/deforest/DefUtils.hi       |   27 -
 ghc/compiler/deforest/DefUtils.lhs      |  648 +++++----
 ghc/compiler/deforest/Deforest.hi       |    8 -
 ghc/compiler/deforest/Deforest.lhs      |   98 +-
 ghc/compiler/deforest/TreelessForm.hi   |    9 -
 ghc/compiler/deforest/TreelessForm.lhs  |  249 ++--
 ghc/compiler/envs/CE.hi                 |   32 -
 ghc/compiler/envs/CE.lhs                |   90 --
 ghc/compiler/envs/E.hi                  |   44 -
 ghc/compiler/envs/E.lhs                 |  268 ----
 ghc/compiler/envs/IdEnv.hi              |   27 -
 ghc/compiler/envs/IdEnv.lhs             |  113 --
 ghc/compiler/envs/InstEnv.hi            |   54 -
 ghc/compiler/envs/InstEnv.lhs           |  593 --------
 ghc/compiler/envs/LIE.hi                |   11 -
 ghc/compiler/envs/LIE.lhs               |   44 -
 ghc/compiler/envs/TCE.hi                |   30 -
 ghc/compiler/envs/TCE.lhs               |  110 --
 ghc/compiler/envs/TVE.hi                |   25 -
 ghc/compiler/envs/TVE.lhs               |   74 -
 ghc/compiler/envs/TyVarEnv.hi           |   20 -
 ghc/compiler/envs/TyVarEnv.lhs          |   71 -
 ghc/compiler/hsSyn/HsBinds.lhs          |  331 +++++
 ghc/compiler/hsSyn/HsCore.lhs           |  342 +++++
 ghc/compiler/hsSyn/HsDecls.lhs          |  339 +++++
 ghc/compiler/hsSyn/HsExpr.lhs           |  453 ++++++
 ghc/compiler/hsSyn/HsImpExp.lhs         |  144 ++
 ghc/compiler/hsSyn/HsLit.lhs            |   60 +
 ghc/compiler/hsSyn/HsLoop.lhi           |   41 +
 ghc/compiler/hsSyn/HsMatches.lhs        |  150 ++
 ghc/compiler/hsSyn/HsPat.lhs            |  286 ++++
 ghc/compiler/hsSyn/HsPragmas.lhs        |  178 +++
 ghc/compiler/hsSyn/HsSyn.lhs            |  113 ++
 ghc/compiler/hsSyn/HsTypes.lhs          |  265 ++++
 ghc/compiler/main/CmdLineOpts.hi        |   22 -
 ghc/compiler/main/CmdLineOpts.lhs       |  882 +++---------
 ghc/compiler/main/ErrUtils.hi           |   11 -
 ghc/compiler/main/ErrUtils.lhs          |   72 +-
 ghc/compiler/main/Errors.hi             |  124 --
 ghc/compiler/main/Errors.lhs            |  124 --
 ghc/compiler/main/ErrsRn.hi             |   26 -
 ghc/compiler/main/ErrsRn.lhs            |  194 ---
 ghc/compiler/main/ErrsTc.hi             |   53 -
 ghc/compiler/main/ErrsTc.lhs            |  981 -------------
 ghc/compiler/main/Main.hi               |    4 -
 ghc/compiler/main/Main.lhs              |  660 ++++-----
 ghc/compiler/main/MainMonad.hi          |   25 -
 ghc/compiler/main/MainMonad.lhs         |  198 +--
 ghc/compiler/main/MkIface.hi            |   40 -
 ghc/compiler/main/MkIface.lhs           |  220 ++-
 ghc/compiler/nativeGen/AbsCStixGen.hi   |   25 -
 ghc/compiler/nativeGen/AbsCStixGen.lhs  |  305 ++--
 ghc/compiler/nativeGen/AlphaCode.hi     |   57 -
 ghc/compiler/nativeGen/AlphaCode.lhs    |   55 +-
 ghc/compiler/nativeGen/AlphaDesc.hi     |   24 -
 ghc/compiler/nativeGen/AlphaDesc.lhs    |   70 +-
 ghc/compiler/nativeGen/AlphaGen.hi      |   17 -
 ghc/compiler/nativeGen/AlphaGen.lhs     |  642 +++++----
 ghc/compiler/nativeGen/AsmCodeGen.hi    |   14 -
 ghc/compiler/nativeGen/AsmCodeGen.lhs   |  150 +-
 ghc/compiler/nativeGen/AsmRegAlloc.hi   |   44 -
 ghc/compiler/nativeGen/AsmRegAlloc.lhs  |   39 +-
 ghc/compiler/nativeGen/I386Code.hi      |   99 --
 ghc/compiler/nativeGen/I386Code.lhs     |  283 ++--
 ghc/compiler/nativeGen/I386Desc.hi      |   25 -
 ghc/compiler/nativeGen/I386Desc.lhs     |   64 +-
 ghc/compiler/nativeGen/I386Gen.hi       |   18 -
 ghc/compiler/nativeGen/I386Gen.lhs      | 1190 ++++++++--------
 ghc/compiler/nativeGen/MachDesc.hi      |   64 -
 ghc/compiler/nativeGen/MachDesc.lhs     |   89 +-
 ghc/compiler/nativeGen/SparcCode.hi     |   56 -
 ghc/compiler/nativeGen/SparcCode.lhs    |  112 +-
 ghc/compiler/nativeGen/SparcDesc.hi     |   24 -
 ghc/compiler/nativeGen/SparcDesc.lhs    |   62 +-
 ghc/compiler/nativeGen/SparcGen.hi      |   17 -
 ghc/compiler/nativeGen/SparcGen.lhs     |  722 +++++-----
 ghc/compiler/nativeGen/Stix.hi          |   41 -
 ghc/compiler/nativeGen/Stix.lhs         |   42 +-
 ghc/compiler/nativeGen/StixInfo.hi      |    8 -
 ghc/compiler/nativeGen/StixInfo.lhs     |   51 +-
 ghc/compiler/nativeGen/StixInteger.hi   |   18 -
 ghc/compiler/nativeGen/StixInteger.lhs  |  331 +++--
 ghc/compiler/nativeGen/StixMacro.hi     |   27 -
 ghc/compiler/nativeGen/StixMacro.lhs    |  235 ++--
 ghc/compiler/nativeGen/StixPrim.hi      |   27 -
 ghc/compiler/nativeGen/StixPrim.lhs     |  278 ++--
 ghc/compiler/parser/MAIL.byacc          |  146 ++
 ghc/compiler/parser/README.debug        |   12 +
 ghc/compiler/parser/UgenAll.lhs         |   50 +
 ghc/compiler/parser/UgenUtil.lhs        |  100 ++
 ghc/compiler/parser/binding.ugn         |  103 ++
 ghc/compiler/parser/constants.h         |   48 +
 ghc/compiler/parser/constr.ugn          |   38 +
 ghc/compiler/parser/coresyn.ugn         |  121 ++
 ghc/compiler/parser/either.ugn          |   13 +
 ghc/compiler/parser/entidt.ugn          |   19 +
 ghc/compiler/parser/hpragma.ugn         |   63 +
 ghc/compiler/parser/hschooks.c          |   66 +
 ghc/compiler/parser/hsclink.c           |   62 +
 ghc/compiler/parser/hslexer.flex        | 1383 ++++++++++++++++++
 ghc/compiler/parser/hsparser.y          | 2309 +++++++++++++++++++++++++++++++
 ghc/compiler/parser/hspincl.h           |   62 +
 ghc/compiler/parser/id.c                |  362 +++++
 ghc/compiler/parser/id.h                |   15 +
 ghc/compiler/parser/import_dirlist.c    |  223 +++
 ghc/compiler/parser/infix.c             |  200 +++
 ghc/compiler/parser/list.ugn            |   13 +
 ghc/compiler/parser/literal.ugn         |   25 +
 ghc/compiler/parser/main.c              |   54 +
 ghc/compiler/parser/maybe.ugn           |   12 +
 ghc/compiler/parser/pbinding.ugn        |   31 +
 ghc/compiler/parser/printtree.c         |  934 +++++++++++++
 ghc/compiler/parser/qid.ugn             |   16 +
 ghc/compiler/parser/syntax.c            |  720 ++++++++++
 ghc/compiler/parser/tree.ugn            |  106 ++
 ghc/compiler/parser/ttype.ugn           |   31 +
 ghc/compiler/parser/type2context.c      |  126 ++
 ghc/compiler/parser/util.c              |  252 ++++
 ghc/compiler/parser/utils.h             |  136 ++
 ghc/compiler/prelude/AbsPrel.hi         |  170 ---
 ghc/compiler/prelude/AbsPrel.lhs        |  622 ---------
 ghc/compiler/prelude/PrelFuns.hi        |  153 --
 ghc/compiler/prelude/PrelFuns.lhs       |  260 ----
 ghc/compiler/prelude/PrelInfo.lhs       |  405 ++++++
 ghc/compiler/prelude/PrelLoop.lhi       |   25 +
 ghc/compiler/prelude/PrelMods.lhs       |   36 +
 ghc/compiler/prelude/PrelVals.hi        |   40 -
 ghc/compiler/prelude/PrelVals.lhs       |  547 +++-----
 ghc/compiler/prelude/PrimKind.hi        |   23 -
 ghc/compiler/prelude/PrimKind.lhs       |  279 ----
 ghc/compiler/prelude/PrimOp.lhs         | 1681 ++++++++++++++++++++++
 ghc/compiler/prelude/PrimOps.hi         |   44 -
 ghc/compiler/prelude/PrimOps.lhs        | 1663 ----------------------
 ghc/compiler/prelude/PrimRep.lhs        |  205 +++
 ghc/compiler/prelude/TyPod.lhs          |  159 ---
 ghc/compiler/prelude/TyProcs.lhs        |   26 -
 ghc/compiler/prelude/TysPrim.hi         |   36 -
 ghc/compiler/prelude/TysPrim.lhs        |   91 +-
 ghc/compiler/prelude/TysWiredIn.hi      |   77 --
 ghc/compiler/prelude/TysWiredIn.lhs     |  337 ++---
 ghc/compiler/profiling/CostCentre.hi    |   45 -
 ghc/compiler/profiling/CostCentre.lhs   |   33 +-
 ghc/compiler/profiling/SCCauto.hi       |    8 -
 ghc/compiler/profiling/SCCauto.lhs      |   61 +-
 ghc/compiler/profiling/SCCfinal.hi      |   10 -
 ghc/compiler/profiling/SCCfinal.lhs     |   94 +-
 ghc/compiler/reader/PrefixSyn.hi        |   22 -
 ghc/compiler/reader/PrefixSyn.lhs       |   43 +-
 ghc/compiler/reader/PrefixToHs.hi       |   22 -
 ghc/compiler/reader/PrefixToHs.lhs      |  201 ++-
 ghc/compiler/reader/RdrHsSyn.lhs        |  395 ++++++
 ghc/compiler/reader/RdrLoop.lhi         |   25 +
 ghc/compiler/reader/ReadPragmas.hi      |   46 -
 ghc/compiler/reader/ReadPragmas.lhs     |  959 +++++++------
 ghc/compiler/reader/ReadPragmas2.hi     |   16 -
 ghc/compiler/reader/ReadPragmas2.lhs    |  569 --------
 ghc/compiler/reader/ReadPrefix.hi       |   23 -
 ghc/compiler/reader/ReadPrefix.lhs      | 1670 +++++++++++-----------
 ghc/compiler/reader/ReadPrefix2.hi      |   15 -
 ghc/compiler/reader/ReadPrefix2.lhs     |  856 ------------
 ghc/compiler/rename/Rename.hi           |   43 -
 ghc/compiler/rename/Rename.lhs          |  117 +-
 ghc/compiler/rename/Rename1.hi          |   36 -
 ghc/compiler/rename/Rename1.lhs         |  901 ------------
 ghc/compiler/rename/Rename2.hi          |   26 -
 ghc/compiler/rename/Rename2.lhs         |  832 -----------
 ghc/compiler/rename/Rename3.hi          |   42 -
 ghc/compiler/rename/Rename3.lhs         |  559 --------
 ghc/compiler/rename/Rename4.hi          |   51 -
 ghc/compiler/rename/Rename4.lhs         |  836 -----------
 ghc/compiler/rename/RenameAuxFuns.hi    |   17 -
 ghc/compiler/rename/RenameAuxFuns.lhs   |  132 --
 ghc/compiler/rename/RenameBinds4.hi     |   50 -
 ghc/compiler/rename/RenameBinds4.lhs    |  653 ---------
 ghc/compiler/rename/RenameExpr4.hi      |   43 -
 ghc/compiler/rename/RenameExpr4.lhs     |  431 ------
 ghc/compiler/rename/RenameMonad12.hi    |   23 -
 ghc/compiler/rename/RenameMonad12.lhs   |   98 --
 ghc/compiler/rename/RenameMonad3.hi     |   31 -
 ghc/compiler/rename/RenameMonad3.lhs    |  200 ---
 ghc/compiler/rename/RenameMonad4.hi     |   79 --
 ghc/compiler/rename/RenameMonad4.lhs    |  490 -------
 ghc/compiler/rename/RnBinds4.lhs        |  711 ++++++++++
 ghc/compiler/rename/RnExpr4.lhs         |  407 ++++++
 ghc/compiler/rename/RnHsSyn.lhs         |   60 +
 ghc/compiler/rename/RnLoop.lhi          |   22 +
 ghc/compiler/rename/RnMonad12.lhs       |   97 ++
 ghc/compiler/rename/RnMonad3.lhs        |  209 +++
 ghc/compiler/rename/RnMonad4.lhs        |  501 +++++++
 ghc/compiler/rename/RnPass1.lhs         |  861 ++++++++++++
 ghc/compiler/rename/RnPass2.lhs         |  845 +++++++++++
 ghc/compiler/rename/RnPass3.lhs         |  620 +++++++++
 ghc/compiler/rename/RnPass4.lhs         |  877 ++++++++++++
 ghc/compiler/rename/RnUtils.lhs         |  138 ++
 ghc/compiler/simplCore/AnalFBWW.hi      |    7 -
 ghc/compiler/simplCore/AnalFBWW.lhs     |  142 +-
 ghc/compiler/simplCore/BinderInfo.hi    |   23 -
 ghc/compiler/simplCore/BinderInfo.lhs   |   21 +-
 ghc/compiler/simplCore/ConFold.hi       |   11 -
 ghc/compiler/simplCore/ConFold.lhs      |  116 +-
 ghc/compiler/simplCore/FloatIn.hi       |   17 -
 ghc/compiler/simplCore/FloatIn.lhs      |  126 +-
 ghc/compiler/simplCore/FloatOut.hi      |    8 -
 ghc/compiler/simplCore/FloatOut.lhs     |  166 ++-
 ghc/compiler/simplCore/FoldrBuildWW.hi  |    8 -
 ghc/compiler/simplCore/FoldrBuildWW.lhs |  229 ++-
 ghc/compiler/simplCore/LiberateCase.hi  |    6 -
 ghc/compiler/simplCore/LiberateCase.lhs |  114 +-
 ghc/compiler/simplCore/MagicUFs.hi      |   33 -
 ghc/compiler/simplCore/MagicUFs.lhs     |  546 ++++----
 ghc/compiler/simplCore/NewOccurAnal.hi  |   26 -
 ghc/compiler/simplCore/NewOccurAnal.lhs |  721 ----------
 ghc/compiler/simplCore/OccurAnal.hi     |   27 -
 ghc/compiler/simplCore/OccurAnal.lhs    |  232 ++--
 ghc/compiler/simplCore/SAT.hi           |   17 -
 ghc/compiler/simplCore/SAT.lhs          |   90 +-
 ghc/compiler/simplCore/SATMonad.hi      |   35 -
 ghc/compiler/simplCore/SATMonad.lhs     |  102 +-
 ghc/compiler/simplCore/SetLevels.hi     |   16 -
 ghc/compiler/simplCore/SetLevels.lhs    |  289 ++--
 ghc/compiler/simplCore/SimplCase.hi     |   12 -
 ghc/compiler/simplCore/SimplCase.lhs    |  376 +++--
 ghc/compiler/simplCore/SimplCore.hi     |   29 -
 ghc/compiler/simplCore/SimplCore.lhs    |  126 +-
 ghc/compiler/simplCore/SimplEnv.hi      |  106 --
 ghc/compiler/simplCore/SimplEnv.lhs     |  540 +++-----
 ghc/compiler/simplCore/SimplHaskell.lhs |  249 ----
 ghc/compiler/simplCore/SimplMonad.hi    |   47 -
 ghc/compiler/simplCore/SimplMonad.lhs   |   86 +-
 ghc/compiler/simplCore/SimplPgm.hi      |    9 -
 ghc/compiler/simplCore/SimplPgm.lhs     |  105 +-
 ghc/compiler/simplCore/SimplUtils.hi    |   18 -
 ghc/compiler/simplCore/SimplUtils.lhs   |  194 +--
 ghc/compiler/simplCore/SimplVar.hi      |   11 -
 ghc/compiler/simplCore/SimplVar.lhs     |   56 +-
 ghc/compiler/simplCore/Simplify.hi      |   13 -
 ghc/compiler/simplCore/Simplify.lhs     |  310 +++--
 ghc/compiler/simplCore/SmplLoop.lhi     |   10 +
 ghc/compiler/simplStg/LambdaLift.hi     |    7 -
 ghc/compiler/simplStg/LambdaLift.lhs    |  159 ++-
 ghc/compiler/simplStg/SatStgRhs.hi      |    7 -
 ghc/compiler/simplStg/SatStgRhs.lhs     |  156 ++-
 ghc/compiler/simplStg/SimplStg.hi       |   11 -
 ghc/compiler/simplStg/SimplStg.lhs      |   44 +-
 ghc/compiler/simplStg/StgSAT.hi         |   16 -
 ghc/compiler/simplStg/StgSAT.lhs        |   42 +-
 ghc/compiler/simplStg/StgSATMonad.hi    |   15 -
 ghc/compiler/simplStg/StgSATMonad.lhs   |  122 +-
 ghc/compiler/simplStg/StgStats.hi       |    6 -
 ghc/compiler/simplStg/StgStats.lhs      |   32 +-
 ghc/compiler/simplStg/StgVarInfo.hi     |    6 -
 ghc/compiler/simplStg/StgVarInfo.lhs    |  174 ++-
 ghc/compiler/simplStg/UpdAnal.hi        |    6 -
 ghc/compiler/simplStg/UpdAnal.lhs       |  107 +-
 ghc/compiler/specialise/SpecEnv.lhs     |  253 ++++
 ghc/compiler/specialise/SpecTyFuns.hi   |   24 -
 ghc/compiler/specialise/SpecTyFuns.lhs  |  346 -----
 ghc/compiler/specialise/SpecUtils.lhs   |  344 +++++
 ghc/compiler/specialise/Specialise.hi   |   17 -
 ghc/compiler/specialise/Specialise.lhs  |  682 +++++----
 ghc/compiler/stgSyn/CoreToStg.hi        |   20 -
 ghc/compiler/stgSyn/CoreToStg.lhs       |  438 +++---
 ghc/compiler/stgSyn/StgFuns.hi          |    6 -
 ghc/compiler/stgSyn/StgFuns.lhs         |   93 --
 ghc/compiler/stgSyn/StgLint.hi          |   12 -
 ghc/compiler/stgSyn/StgLint.lhs         |  148 +-
 ghc/compiler/stgSyn/StgSyn.hi           |  165 ---
 ghc/compiler/stgSyn/StgSyn.lhs          |  428 ++----
 ghc/compiler/stgSyn/StgUtils.lhs        |   90 ++
 ghc/compiler/stranal/SaAbsInt.hi        |   14 -
 ghc/compiler/stranal/SaAbsInt.lhs       |  195 ++-
 ghc/compiler/stranal/SaLib.hi           |   38 -
 ghc/compiler/stranal/SaLib.lhs          |   14 +-
 ghc/compiler/stranal/StrictAnal.hi      |    9 -
 ghc/compiler/stranal/StrictAnal.lhs     |  146 +-
 ghc/compiler/stranal/WorkWrap.hi        |    8 -
 ghc/compiler/stranal/WorkWrap.lhs       |   75 +-
 ghc/compiler/stranal/WwLib.hi           |   39 -
 ghc/compiler/stranal/WwLib.lhs          |  144 +-
 ghc/compiler/typecheck/BackSubst.hi     |   24 -
 ghc/compiler/typecheck/BackSubst.lhs    |  451 ------
 ghc/compiler/typecheck/Disambig.hi      |   27 -
 ghc/compiler/typecheck/Disambig.lhs     |  162 ---
 ghc/compiler/typecheck/GenSpecEtc.hi    |   53 -
 ghc/compiler/typecheck/GenSpecEtc.lhs   |  517 ++++---
 ghc/compiler/typecheck/Inst.lhs         |  649 +++++++++
 ghc/compiler/typecheck/Spec.hi          |   18 -
 ghc/compiler/typecheck/Spec.lhs         |  158 ---
 ghc/compiler/typecheck/Subst.hi         |   25 -
 ghc/compiler/typecheck/Subst.lhs        |  827 -----------
 ghc/compiler/typecheck/TcBinds.hi       |   22 -
 ghc/compiler/typecheck/TcBinds.lhs      |  761 +++++-----
 ghc/compiler/typecheck/TcClassDcl.hi    |   25 -
 ghc/compiler/typecheck/TcClassDcl.lhs   |  600 ++++----
 ghc/compiler/typecheck/TcClassSig.hi    |   19 -
 ghc/compiler/typecheck/TcClassSig.lhs   |   29 +-
 ghc/compiler/typecheck/TcConDecls.hi    |   18 -
 ghc/compiler/typecheck/TcConDecls.lhs   |   55 -
 ghc/compiler/typecheck/TcContext.hi     |   15 -
 ghc/compiler/typecheck/TcContext.lhs    |   55 -
 ghc/compiler/typecheck/TcDefaults.hi    |   15 -
 ghc/compiler/typecheck/TcDefaults.lhs   |   64 +-
 ghc/compiler/typecheck/TcDeriv.hi       |   29 -
 ghc/compiler/typecheck/TcDeriv.lhs      |  431 +++---
 ghc/compiler/typecheck/TcEnv.lhs        |  289 ++++
 ghc/compiler/typecheck/TcExpr.hi        |   18 -
 ghc/compiler/typecheck/TcExpr.lhs       | 1106 ++++++++-------
 ghc/compiler/typecheck/TcGRHSs.hi       |   18 -
 ghc/compiler/typecheck/TcGRHSs.lhs      |   81 +-
 ghc/compiler/typecheck/TcGenDeriv.hi    |   53 -
 ghc/compiler/typecheck/TcGenDeriv.lhs   |  639 ++++-----
 ghc/compiler/typecheck/TcHsSyn.lhs      |  525 +++++++
 ghc/compiler/typecheck/TcIfaceSig.hi    |   14 -
 ghc/compiler/typecheck/TcIfaceSig.lhs   |   99 +-
 ghc/compiler/typecheck/TcInstDcls.hi    |   35 -
 ghc/compiler/typecheck/TcInstDcls.lhs   | 1256 +++++++----------
 ghc/compiler/typecheck/TcInstUtil.lhs   |  294 ++++
 ghc/compiler/typecheck/TcKind.lhs       |  205 +++
 ghc/compiler/typecheck/TcLoop.lhi       |   38 +
 ghc/compiler/typecheck/TcLoop.lhs       |    7 +
 ghc/compiler/typecheck/TcMLoop.lhi      |   13 +
 ghc/compiler/typecheck/TcMatches.hi     |   20 -
 ghc/compiler/typecheck/TcMatches.lhs    |  201 ++-
 ghc/compiler/typecheck/TcModule.hi      |   65 -
 ghc/compiler/typecheck/TcModule.lhs     |  404 +++---
 ghc/compiler/typecheck/TcMonad.hi       |  137 --
 ghc/compiler/typecheck/TcMonad.lhs      | 1017 +++++---------
 ghc/compiler/typecheck/TcMonadFns.hi    |   73 -
 ghc/compiler/typecheck/TcMonadFns.lhs   |  244 ----
 ghc/compiler/typecheck/TcMonoBnds.hi    |   18 -
 ghc/compiler/typecheck/TcMonoBnds.lhs   |  130 --
 ghc/compiler/typecheck/TcMonoType.hi    |   17 -
 ghc/compiler/typecheck/TcMonoType.lhs   |  329 ++---
 ghc/compiler/typecheck/TcParQuals.lhs   |   97 --
 ghc/compiler/typecheck/TcPat.hi         |   16 -
 ghc/compiler/typecheck/TcPat.lhs        |  385 ++----
 ghc/compiler/typecheck/TcPolyType.hi    |   16 -
 ghc/compiler/typecheck/TcPolyType.lhs   |  110 --
 ghc/compiler/typecheck/TcPragmas.hi     |   25 -
 ghc/compiler/typecheck/TcPragmas.lhs    |  181 +--
 ghc/compiler/typecheck/TcQuals.hi       |   18 -
 ghc/compiler/typecheck/TcQuals.lhs      |   55 -
 ghc/compiler/typecheck/TcSimplify.hi    |   27 -
 ghc/compiler/typecheck/TcSimplify.lhs   |  793 ++++++-----
 ghc/compiler/typecheck/TcTyClsDecls.lhs |  308 +++++
 ghc/compiler/typecheck/TcTyDecls.hi     |   19 -
 ghc/compiler/typecheck/TcTyDecls.lhs    |  427 +++---
 ghc/compiler/typecheck/TcType.lhs       |  322 +++++
 ghc/compiler/typecheck/Typecheck.hi     |   60 -
 ghc/compiler/typecheck/Typecheck.lhs    |  103 +-
 ghc/compiler/typecheck/Unify.hi         |   15 -
 ghc/compiler/typecheck/Unify.lhs        |  395 +++---
 ghc/compiler/types/Class.lhs            |  338 +++++
 ghc/compiler/types/Kind.lhs             |   50 +
 ghc/compiler/types/PprType.lhs          |  595 ++++++++
 ghc/compiler/types/TyCon.lhs            |  324 +++++
 ghc/compiler/types/TyLoop.lhi           |   45 +
 ghc/compiler/types/TyLoop.lhs           |   23 +
 ghc/compiler/types/TyVar.lhs            |  153 ++
 ghc/compiler/types/Type.lhs             |  637 +++++++++
 ghc/compiler/types/Usage.lhs            |  109 ++
 ghc/compiler/utils/Argv.lhs             |   29 +
 ghc/compiler/utils/Bag.hi               |   16 -
 ghc/compiler/utils/Bag.lhs              |  101 +-
 ghc/compiler/utils/BitSet.hi            |   10 -
 ghc/compiler/utils/BitSet.lhs           |   34 +-
 ghc/compiler/utils/CharSeq.hi           |   16 -
 ghc/compiler/utils/CharSeq.lhs          |   87 +-
 ghc/compiler/utils/Digraph.hi           |    8 -
 ghc/compiler/utils/Digraph.lhs          |  103 +-
 ghc/compiler/utils/FiniteMap.hi         |   33 -
 ghc/compiler/utils/FiniteMap.lhs        |  103 +-
 ghc/compiler/utils/LiftMonad.hi         |    4 -
 ghc/compiler/utils/LiftMonad.lhs        |   39 -
 ghc/compiler/utils/ListSetOps.hi        |    6 -
 ghc/compiler/utils/ListSetOps.lhs       |    2 +-
 ghc/compiler/utils/MatchEnv.lhs         |  112 ++
 ghc/compiler/utils/Maybes.hi            |   18 -
 ghc/compiler/utils/Maybes.lhs           |  101 +-
 ghc/compiler/utils/OrdList.lhs          |   59 +
 ghc/compiler/utils/Outputable.hi        |   52 -
 ghc/compiler/utils/Outputable.lhs       |   92 +-
 ghc/compiler/utils/PprStyle.lhs         |   49 +
 ghc/compiler/utils/Pretty.hi            |   48 -
 ghc/compiler/utils/Pretty.lhs           |  125 +-
 ghc/compiler/utils/SST.lhs              |  135 ++
 ghc/compiler/utils/Ubiq.lhi             |  138 ++
 ghc/compiler/utils/UniqFM.hi            |   33 -
 ghc/compiler/utils/UniqFM.lhs           |  138 +-
 ghc/compiler/utils/UniqSet.hi           |   32 -
 ghc/compiler/utils/UniqSet.lhs          |   79 +-
 ghc/compiler/utils/Unpretty.hi          |   37 -
 ghc/compiler/utils/Unpretty.lhs         |   44 +-
 ghc/compiler/utils/Util.hi              |   33 -
 ghc/compiler/utils/Util.lhs             |  507 ++-----
 532 files changed, 47364 insertions(+), 51566 deletions(-)
 delete mode 100644 ghc/compiler/absCSyn/AbsCFuns.hi
 delete mode 100644 ghc/compiler/absCSyn/AbsCFuns.lhs
 delete mode 100644 ghc/compiler/absCSyn/AbsCSyn.hi
 create mode 100644 ghc/compiler/absCSyn/AbsCUtils.lhs
 create mode 100644 ghc/compiler/absCSyn/CLabel.lhs
 create mode 100644 ghc/compiler/absCSyn/CStrings.lhs
 delete mode 100644 ghc/compiler/absCSyn/Costs.hi
 delete mode 100644 ghc/compiler/absCSyn/HeapOffs.hi
 delete mode 100644 ghc/compiler/absCSyn/PprAbsC.hi
 delete mode 100644 ghc/compiler/basicTypes/BasicLit.hi
 delete mode 100644 ghc/compiler/basicTypes/BasicLit.lhs
 delete mode 100644 ghc/compiler/basicTypes/CLabelInfo.hi
 delete mode 100644 ghc/compiler/basicTypes/CLabelInfo.lhs
 delete mode 100644 ghc/compiler/basicTypes/Id.hi
 delete mode 100644 ghc/compiler/basicTypes/IdInfo.hi
 create mode 100644 ghc/compiler/basicTypes/IdLoop.lhi
 create mode 100644 ghc/compiler/basicTypes/IdUtils.lhs
 delete mode 100644 ghc/compiler/basicTypes/Inst.hi
 delete mode 100644 ghc/compiler/basicTypes/Inst.lhs
 create mode 100644 ghc/compiler/basicTypes/Literal.lhs
 create mode 100644 ghc/compiler/basicTypes/Name.lhs
 create mode 100644 ghc/compiler/basicTypes/NameLoop.lhi
 delete mode 100644 ghc/compiler/basicTypes/NameTypes.hi
 delete mode 100644 ghc/compiler/basicTypes/OrdList.hi
 delete mode 100644 ghc/compiler/basicTypes/OrdList.lhs
 create mode 100644 ghc/compiler/basicTypes/PragmaInfo.lhs
 delete mode 100644 ghc/compiler/basicTypes/ProtoName.hi
 delete mode 100644 ghc/compiler/basicTypes/SplitUniq.hi
 delete mode 100644 ghc/compiler/basicTypes/SplitUniq.lhs
 delete mode 100644 ghc/compiler/basicTypes/SrcLoc.hi
 create mode 100644 ghc/compiler/basicTypes/UniqSupply.lhs
 delete mode 100644 ghc/compiler/basicTypes/Unique.hi
 delete mode 100644 ghc/compiler/codeGen/CgBindery.hi
 delete mode 100644 ghc/compiler/codeGen/CgCase.hi
 delete mode 100644 ghc/compiler/codeGen/CgClosure.hi
 delete mode 100644 ghc/compiler/codeGen/CgCompInfo.hi
 delete mode 100644 ghc/compiler/codeGen/CgCon.hi
 delete mode 100644 ghc/compiler/codeGen/CgConTbls.hi
 delete mode 100644 ghc/compiler/codeGen/CgExpr.hi
 delete mode 100644 ghc/compiler/codeGen/CgHeapery.hi
 delete mode 100644 ghc/compiler/codeGen/CgLetNoEscape.hi
 delete mode 100644 ghc/compiler/codeGen/CgMonad.hi
 delete mode 100644 ghc/compiler/codeGen/CgRetConv.hi
 delete mode 100644 ghc/compiler/codeGen/CgStackery.hi
 delete mode 100644 ghc/compiler/codeGen/CgTailCall.hi
 delete mode 100644 ghc/compiler/codeGen/CgUpdate.hi
 delete mode 100644 ghc/compiler/codeGen/CgUsages.hi
 delete mode 100644 ghc/compiler/codeGen/ClosureInfo.hi
 delete mode 100644 ghc/compiler/codeGen/CodeGen.hi
 delete mode 100644 ghc/compiler/codeGen/SMRep.hi
 delete mode 100644 ghc/compiler/coreSyn/AnnCoreSyn.hi
 delete mode 100644 ghc/compiler/coreSyn/CoreFuns.hi
 delete mode 100644 ghc/compiler/coreSyn/CoreFuns.lhs
 delete mode 100644 ghc/compiler/coreSyn/CoreLift.hi
 delete mode 100644 ghc/compiler/coreSyn/CoreLint.hi
 delete mode 100644 ghc/compiler/coreSyn/CoreSyn.hi
 delete mode 100644 ghc/compiler/coreSyn/CoreUnfold.hi
 create mode 100644 ghc/compiler/coreSyn/CoreUtils.lhs
 delete mode 100644 ghc/compiler/coreSyn/FreeVars.hi
 delete mode 100644 ghc/compiler/coreSyn/Jmakefile
 delete mode 100644 ghc/compiler/coreSyn/PlainCore.hi
 delete mode 100644 ghc/compiler/coreSyn/PlainCore.lhs
 create mode 100644 ghc/compiler/coreSyn/PprCore.lhs
 delete mode 100644 ghc/compiler/coreSyn/TaggedCore.hi
 delete mode 100644 ghc/compiler/coreSyn/TaggedCore.lhs
 delete mode 100644 ghc/compiler/deSugar/Desugar.hi
 delete mode 100644 ghc/compiler/deSugar/DsBinds.hi
 delete mode 100644 ghc/compiler/deSugar/DsCCall.hi
 delete mode 100644 ghc/compiler/deSugar/DsExpr.hi
 delete mode 100644 ghc/compiler/deSugar/DsGRHSs.hi
 create mode 100644 ghc/compiler/deSugar/DsHsSyn.lhs
 delete mode 100644 ghc/compiler/deSugar/DsListComp.hi
 create mode 100644 ghc/compiler/deSugar/DsLoop.lhi
 delete mode 100644 ghc/compiler/deSugar/DsMonad.hi
 delete mode 100644 ghc/compiler/deSugar/DsParZF.lhs
 delete mode 100644 ghc/compiler/deSugar/DsUtils.hi
 delete mode 100644 ghc/compiler/deSugar/Match.hi
 delete mode 100644 ghc/compiler/deSugar/MatchCon.hi
 delete mode 100644 ghc/compiler/deSugar/MatchLit.hi
 delete mode 100644 ghc/compiler/deSugar/MatchProc.lhs
 delete mode 100644 ghc/compiler/deforest/Core2Def.hi
 delete mode 100644 ghc/compiler/deforest/Cyclic.hi
 delete mode 100644 ghc/compiler/deforest/Def2Core.hi
 delete mode 100644 ghc/compiler/deforest/DefExpr.hi
 delete mode 100644 ghc/compiler/deforest/DefSyn.hi
 delete mode 100644 ghc/compiler/deforest/DefUtils.hi
 delete mode 100644 ghc/compiler/deforest/Deforest.hi
 delete mode 100644 ghc/compiler/deforest/TreelessForm.hi
 delete mode 100644 ghc/compiler/envs/CE.hi
 delete mode 100644 ghc/compiler/envs/CE.lhs
 delete mode 100644 ghc/compiler/envs/E.hi
 delete mode 100644 ghc/compiler/envs/E.lhs
 delete mode 100644 ghc/compiler/envs/IdEnv.hi
 delete mode 100644 ghc/compiler/envs/IdEnv.lhs
 delete mode 100644 ghc/compiler/envs/InstEnv.hi
 delete mode 100644 ghc/compiler/envs/InstEnv.lhs
 delete mode 100644 ghc/compiler/envs/LIE.hi
 delete mode 100644 ghc/compiler/envs/LIE.lhs
 delete mode 100644 ghc/compiler/envs/TCE.hi
 delete mode 100644 ghc/compiler/envs/TCE.lhs
 delete mode 100644 ghc/compiler/envs/TVE.hi
 delete mode 100644 ghc/compiler/envs/TVE.lhs
 delete mode 100644 ghc/compiler/envs/TyVarEnv.hi
 delete mode 100644 ghc/compiler/envs/TyVarEnv.lhs
 create mode 100644 ghc/compiler/hsSyn/HsBinds.lhs
 create mode 100644 ghc/compiler/hsSyn/HsCore.lhs
 create mode 100644 ghc/compiler/hsSyn/HsDecls.lhs
 create mode 100644 ghc/compiler/hsSyn/HsExpr.lhs
 create mode 100644 ghc/compiler/hsSyn/HsImpExp.lhs
 create mode 100644 ghc/compiler/hsSyn/HsLit.lhs
 create mode 100644 ghc/compiler/hsSyn/HsLoop.lhi
 create mode 100644 ghc/compiler/hsSyn/HsMatches.lhs
 create mode 100644 ghc/compiler/hsSyn/HsPat.lhs
 create mode 100644 ghc/compiler/hsSyn/HsPragmas.lhs
 create mode 100644 ghc/compiler/hsSyn/HsSyn.lhs
 create mode 100644 ghc/compiler/hsSyn/HsTypes.lhs
 delete mode 100644 ghc/compiler/main/CmdLineOpts.hi
 delete mode 100644 ghc/compiler/main/ErrUtils.hi
 delete mode 100644 ghc/compiler/main/Errors.hi
 delete mode 100644 ghc/compiler/main/Errors.lhs
 delete mode 100644 ghc/compiler/main/ErrsRn.hi
 delete mode 100644 ghc/compiler/main/ErrsRn.lhs
 delete mode 100644 ghc/compiler/main/ErrsTc.hi
 delete mode 100644 ghc/compiler/main/ErrsTc.lhs
 delete mode 100644 ghc/compiler/main/Main.hi
 delete mode 100644 ghc/compiler/main/MainMonad.hi
 delete mode 100644 ghc/compiler/main/MkIface.hi
 delete mode 100644 ghc/compiler/nativeGen/AbsCStixGen.hi
 delete mode 100644 ghc/compiler/nativeGen/AlphaCode.hi
 delete mode 100644 ghc/compiler/nativeGen/AlphaDesc.hi
 delete mode 100644 ghc/compiler/nativeGen/AlphaGen.hi
 delete mode 100644 ghc/compiler/nativeGen/AsmCodeGen.hi
 delete mode 100644 ghc/compiler/nativeGen/AsmRegAlloc.hi
 delete mode 100644 ghc/compiler/nativeGen/I386Code.hi
 delete mode 100644 ghc/compiler/nativeGen/I386Desc.hi
 delete mode 100644 ghc/compiler/nativeGen/I386Gen.hi
 delete mode 100644 ghc/compiler/nativeGen/MachDesc.hi
 delete mode 100644 ghc/compiler/nativeGen/SparcCode.hi
 delete mode 100644 ghc/compiler/nativeGen/SparcDesc.hi
 delete mode 100644 ghc/compiler/nativeGen/SparcGen.hi
 delete mode 100644 ghc/compiler/nativeGen/Stix.hi
 delete mode 100644 ghc/compiler/nativeGen/StixInfo.hi
 delete mode 100644 ghc/compiler/nativeGen/StixInteger.hi
 delete mode 100644 ghc/compiler/nativeGen/StixMacro.hi
 delete mode 100644 ghc/compiler/nativeGen/StixPrim.hi
 create mode 100644 ghc/compiler/parser/MAIL.byacc
 create mode 100644 ghc/compiler/parser/README.debug
 create mode 100644 ghc/compiler/parser/UgenAll.lhs
 create mode 100644 ghc/compiler/parser/UgenUtil.lhs
 create mode 100644 ghc/compiler/parser/binding.ugn
 create mode 100644 ghc/compiler/parser/constants.h
 create mode 100644 ghc/compiler/parser/constr.ugn
 create mode 100644 ghc/compiler/parser/coresyn.ugn
 create mode 100644 ghc/compiler/parser/either.ugn
 create mode 100644 ghc/compiler/parser/entidt.ugn
 create mode 100644 ghc/compiler/parser/hpragma.ugn
 create mode 100644 ghc/compiler/parser/hschooks.c
 create mode 100644 ghc/compiler/parser/hsclink.c
 create mode 100644 ghc/compiler/parser/hslexer.flex
 create mode 100644 ghc/compiler/parser/hsparser.y
 create mode 100644 ghc/compiler/parser/hspincl.h
 create mode 100644 ghc/compiler/parser/id.c
 create mode 100644 ghc/compiler/parser/id.h
 create mode 100644 ghc/compiler/parser/import_dirlist.c
 create mode 100644 ghc/compiler/parser/infix.c
 create mode 100644 ghc/compiler/parser/list.ugn
 create mode 100644 ghc/compiler/parser/literal.ugn
 create mode 100644 ghc/compiler/parser/main.c
 create mode 100644 ghc/compiler/parser/maybe.ugn
 create mode 100644 ghc/compiler/parser/pbinding.ugn
 create mode 100644 ghc/compiler/parser/printtree.c
 create mode 100644 ghc/compiler/parser/qid.ugn
 create mode 100644 ghc/compiler/parser/syntax.c
 create mode 100644 ghc/compiler/parser/tree.ugn
 create mode 100644 ghc/compiler/parser/ttype.ugn
 create mode 100644 ghc/compiler/parser/type2context.c
 create mode 100644 ghc/compiler/parser/util.c
 create mode 100644 ghc/compiler/parser/utils.h
 delete mode 100644 ghc/compiler/prelude/AbsPrel.hi
 delete mode 100644 ghc/compiler/prelude/AbsPrel.lhs
 delete mode 100644 ghc/compiler/prelude/PrelFuns.hi
 delete mode 100644 ghc/compiler/prelude/PrelFuns.lhs
 create mode 100644 ghc/compiler/prelude/PrelInfo.lhs
 create mode 100644 ghc/compiler/prelude/PrelLoop.lhi
 create mode 100644 ghc/compiler/prelude/PrelMods.lhs
 delete mode 100644 ghc/compiler/prelude/PrelVals.hi
 delete mode 100644 ghc/compiler/prelude/PrimKind.hi
 delete mode 100644 ghc/compiler/prelude/PrimKind.lhs
 create mode 100644 ghc/compiler/prelude/PrimOp.lhs
 delete mode 100644 ghc/compiler/prelude/PrimOps.hi
 delete mode 100644 ghc/compiler/prelude/PrimOps.lhs
 create mode 100644 ghc/compiler/prelude/PrimRep.lhs
 delete mode 100644 ghc/compiler/prelude/TyPod.lhs
 delete mode 100644 ghc/compiler/prelude/TyProcs.lhs
 delete mode 100644 ghc/compiler/prelude/TysPrim.hi
 delete mode 100644 ghc/compiler/prelude/TysWiredIn.hi
 delete mode 100644 ghc/compiler/profiling/CostCentre.hi
 delete mode 100644 ghc/compiler/profiling/SCCauto.hi
 delete mode 100644 ghc/compiler/profiling/SCCfinal.hi
 delete mode 100644 ghc/compiler/reader/PrefixSyn.hi
 delete mode 100644 ghc/compiler/reader/PrefixToHs.hi
 create mode 100644 ghc/compiler/reader/RdrHsSyn.lhs
 create mode 100644 ghc/compiler/reader/RdrLoop.lhi
 delete mode 100644 ghc/compiler/reader/ReadPragmas.hi
 delete mode 100644 ghc/compiler/reader/ReadPragmas2.hi
 delete mode 100644 ghc/compiler/reader/ReadPragmas2.lhs
 delete mode 100644 ghc/compiler/reader/ReadPrefix.hi
 delete mode 100644 ghc/compiler/reader/ReadPrefix2.hi
 delete mode 100644 ghc/compiler/reader/ReadPrefix2.lhs
 delete mode 100644 ghc/compiler/rename/Rename.hi
 delete mode 100644 ghc/compiler/rename/Rename1.hi
 delete mode 100644 ghc/compiler/rename/Rename1.lhs
 delete mode 100644 ghc/compiler/rename/Rename2.hi
 delete mode 100644 ghc/compiler/rename/Rename2.lhs
 delete mode 100644 ghc/compiler/rename/Rename3.hi
 delete mode 100644 ghc/compiler/rename/Rename3.lhs
 delete mode 100644 ghc/compiler/rename/Rename4.hi
 delete mode 100644 ghc/compiler/rename/Rename4.lhs
 delete mode 100644 ghc/compiler/rename/RenameAuxFuns.hi
 delete mode 100644 ghc/compiler/rename/RenameAuxFuns.lhs
 delete mode 100644 ghc/compiler/rename/RenameBinds4.hi
 delete mode 100644 ghc/compiler/rename/RenameBinds4.lhs
 delete mode 100644 ghc/compiler/rename/RenameExpr4.hi
 delete mode 100644 ghc/compiler/rename/RenameExpr4.lhs
 delete mode 100644 ghc/compiler/rename/RenameMonad12.hi
 delete mode 100644 ghc/compiler/rename/RenameMonad12.lhs
 delete mode 100644 ghc/compiler/rename/RenameMonad3.hi
 delete mode 100644 ghc/compiler/rename/RenameMonad3.lhs
 delete mode 100644 ghc/compiler/rename/RenameMonad4.hi
 delete mode 100644 ghc/compiler/rename/RenameMonad4.lhs
 create mode 100644 ghc/compiler/rename/RnBinds4.lhs
 create mode 100644 ghc/compiler/rename/RnExpr4.lhs
 create mode 100644 ghc/compiler/rename/RnHsSyn.lhs
 create mode 100644 ghc/compiler/rename/RnLoop.lhi
 create mode 100644 ghc/compiler/rename/RnMonad12.lhs
 create mode 100644 ghc/compiler/rename/RnMonad3.lhs
 create mode 100644 ghc/compiler/rename/RnMonad4.lhs
 create mode 100644 ghc/compiler/rename/RnPass1.lhs
 create mode 100644 ghc/compiler/rename/RnPass2.lhs
 create mode 100644 ghc/compiler/rename/RnPass3.lhs
 create mode 100644 ghc/compiler/rename/RnPass4.lhs
 create mode 100644 ghc/compiler/rename/RnUtils.lhs
 delete mode 100644 ghc/compiler/simplCore/AnalFBWW.hi
 delete mode 100644 ghc/compiler/simplCore/BinderInfo.hi
 delete mode 100644 ghc/compiler/simplCore/ConFold.hi
 delete mode 100644 ghc/compiler/simplCore/FloatIn.hi
 delete mode 100644 ghc/compiler/simplCore/FloatOut.hi
 delete mode 100644 ghc/compiler/simplCore/FoldrBuildWW.hi
 delete mode 100644 ghc/compiler/simplCore/LiberateCase.hi
 delete mode 100644 ghc/compiler/simplCore/MagicUFs.hi
 delete mode 100644 ghc/compiler/simplCore/NewOccurAnal.hi
 delete mode 100644 ghc/compiler/simplCore/NewOccurAnal.lhs
 delete mode 100644 ghc/compiler/simplCore/OccurAnal.hi
 delete mode 100644 ghc/compiler/simplCore/SAT.hi
 delete mode 100644 ghc/compiler/simplCore/SATMonad.hi
 delete mode 100644 ghc/compiler/simplCore/SetLevels.hi
 delete mode 100644 ghc/compiler/simplCore/SimplCase.hi
 delete mode 100644 ghc/compiler/simplCore/SimplCore.hi
 delete mode 100644 ghc/compiler/simplCore/SimplEnv.hi
 delete mode 100644 ghc/compiler/simplCore/SimplHaskell.lhs
 delete mode 100644 ghc/compiler/simplCore/SimplMonad.hi
 delete mode 100644 ghc/compiler/simplCore/SimplPgm.hi
 delete mode 100644 ghc/compiler/simplCore/SimplUtils.hi
 delete mode 100644 ghc/compiler/simplCore/SimplVar.hi
 delete mode 100644 ghc/compiler/simplCore/Simplify.hi
 create mode 100644 ghc/compiler/simplCore/SmplLoop.lhi
 delete mode 100644 ghc/compiler/simplStg/LambdaLift.hi
 delete mode 100644 ghc/compiler/simplStg/SatStgRhs.hi
 delete mode 100644 ghc/compiler/simplStg/SimplStg.hi
 delete mode 100644 ghc/compiler/simplStg/StgSAT.hi
 delete mode 100644 ghc/compiler/simplStg/StgSATMonad.hi
 delete mode 100644 ghc/compiler/simplStg/StgStats.hi
 delete mode 100644 ghc/compiler/simplStg/StgVarInfo.hi
 delete mode 100644 ghc/compiler/simplStg/UpdAnal.hi
 create mode 100644 ghc/compiler/specialise/SpecEnv.lhs
 delete mode 100644 ghc/compiler/specialise/SpecTyFuns.hi
 delete mode 100644 ghc/compiler/specialise/SpecTyFuns.lhs
 create mode 100644 ghc/compiler/specialise/SpecUtils.lhs
 delete mode 100644 ghc/compiler/specialise/Specialise.hi
 delete mode 100644 ghc/compiler/stgSyn/CoreToStg.hi
 delete mode 100644 ghc/compiler/stgSyn/StgFuns.hi
 delete mode 100644 ghc/compiler/stgSyn/StgFuns.lhs
 delete mode 100644 ghc/compiler/stgSyn/StgLint.hi
 delete mode 100644 ghc/compiler/stgSyn/StgSyn.hi
 create mode 100644 ghc/compiler/stgSyn/StgUtils.lhs
 delete mode 100644 ghc/compiler/stranal/SaAbsInt.hi
 delete mode 100644 ghc/compiler/stranal/SaLib.hi
 delete mode 100644 ghc/compiler/stranal/StrictAnal.hi
 delete mode 100644 ghc/compiler/stranal/WorkWrap.hi
 delete mode 100644 ghc/compiler/stranal/WwLib.hi
 delete mode 100644 ghc/compiler/typecheck/BackSubst.hi
 delete mode 100644 ghc/compiler/typecheck/BackSubst.lhs
 delete mode 100644 ghc/compiler/typecheck/Disambig.hi
 delete mode 100644 ghc/compiler/typecheck/Disambig.lhs
 delete mode 100644 ghc/compiler/typecheck/GenSpecEtc.hi
 create mode 100644 ghc/compiler/typecheck/Inst.lhs
 delete mode 100644 ghc/compiler/typecheck/Spec.hi
 delete mode 100644 ghc/compiler/typecheck/Spec.lhs
 delete mode 100644 ghc/compiler/typecheck/Subst.hi
 delete mode 100644 ghc/compiler/typecheck/Subst.lhs
 delete mode 100644 ghc/compiler/typecheck/TcBinds.hi
 delete mode 100644 ghc/compiler/typecheck/TcClassDcl.hi
 delete mode 100644 ghc/compiler/typecheck/TcClassSig.hi
 delete mode 100644 ghc/compiler/typecheck/TcConDecls.hi
 delete mode 100644 ghc/compiler/typecheck/TcConDecls.lhs
 delete mode 100644 ghc/compiler/typecheck/TcContext.hi
 delete mode 100644 ghc/compiler/typecheck/TcContext.lhs
 delete mode 100644 ghc/compiler/typecheck/TcDefaults.hi
 delete mode 100644 ghc/compiler/typecheck/TcDeriv.hi
 create mode 100644 ghc/compiler/typecheck/TcEnv.lhs
 delete mode 100644 ghc/compiler/typecheck/TcExpr.hi
 delete mode 100644 ghc/compiler/typecheck/TcGRHSs.hi
 delete mode 100644 ghc/compiler/typecheck/TcGenDeriv.hi
 create mode 100644 ghc/compiler/typecheck/TcHsSyn.lhs
 delete mode 100644 ghc/compiler/typecheck/TcIfaceSig.hi
 delete mode 100644 ghc/compiler/typecheck/TcInstDcls.hi
 create mode 100644 ghc/compiler/typecheck/TcInstUtil.lhs
 create mode 100644 ghc/compiler/typecheck/TcKind.lhs
 create mode 100644 ghc/compiler/typecheck/TcLoop.lhi
 create mode 100644 ghc/compiler/typecheck/TcLoop.lhs
 create mode 100644 ghc/compiler/typecheck/TcMLoop.lhi
 delete mode 100644 ghc/compiler/typecheck/TcMatches.hi
 delete mode 100644 ghc/compiler/typecheck/TcModule.hi
 delete mode 100644 ghc/compiler/typecheck/TcMonad.hi
 delete mode 100644 ghc/compiler/typecheck/TcMonadFns.hi
 delete mode 100644 ghc/compiler/typecheck/TcMonadFns.lhs
 delete mode 100644 ghc/compiler/typecheck/TcMonoBnds.hi
 delete mode 100644 ghc/compiler/typecheck/TcMonoBnds.lhs
 delete mode 100644 ghc/compiler/typecheck/TcMonoType.hi
 delete mode 100644 ghc/compiler/typecheck/TcParQuals.lhs
 delete mode 100644 ghc/compiler/typecheck/TcPat.hi
 delete mode 100644 ghc/compiler/typecheck/TcPolyType.hi
 delete mode 100644 ghc/compiler/typecheck/TcPolyType.lhs
 delete mode 100644 ghc/compiler/typecheck/TcPragmas.hi
 delete mode 100644 ghc/compiler/typecheck/TcQuals.hi
 delete mode 100644 ghc/compiler/typecheck/TcQuals.lhs
 delete mode 100644 ghc/compiler/typecheck/TcSimplify.hi
 create mode 100644 ghc/compiler/typecheck/TcTyClsDecls.lhs
 delete mode 100644 ghc/compiler/typecheck/TcTyDecls.hi
 create mode 100644 ghc/compiler/typecheck/TcType.lhs
 delete mode 100644 ghc/compiler/typecheck/Typecheck.hi
 delete mode 100644 ghc/compiler/typecheck/Unify.hi
 create mode 100644 ghc/compiler/types/Class.lhs
 create mode 100644 ghc/compiler/types/Kind.lhs
 create mode 100644 ghc/compiler/types/PprType.lhs
 create mode 100644 ghc/compiler/types/TyCon.lhs
 create mode 100644 ghc/compiler/types/TyLoop.lhi
 create mode 100644 ghc/compiler/types/TyLoop.lhs
 create mode 100644 ghc/compiler/types/TyVar.lhs
 create mode 100644 ghc/compiler/types/Type.lhs
 create mode 100644 ghc/compiler/types/Usage.lhs
 create mode 100644 ghc/compiler/utils/Argv.lhs
 delete mode 100644 ghc/compiler/utils/Bag.hi
 delete mode 100644 ghc/compiler/utils/BitSet.hi
 delete mode 100644 ghc/compiler/utils/CharSeq.hi
 delete mode 100644 ghc/compiler/utils/Digraph.hi
 delete mode 100644 ghc/compiler/utils/FiniteMap.hi
 delete mode 100644 ghc/compiler/utils/LiftMonad.hi
 delete mode 100644 ghc/compiler/utils/LiftMonad.lhs
 delete mode 100644 ghc/compiler/utils/ListSetOps.hi
 create mode 100644 ghc/compiler/utils/MatchEnv.lhs
 delete mode 100644 ghc/compiler/utils/Maybes.hi
 create mode 100644 ghc/compiler/utils/OrdList.lhs
 delete mode 100644 ghc/compiler/utils/Outputable.hi
 create mode 100644 ghc/compiler/utils/PprStyle.lhs
 delete mode 100644 ghc/compiler/utils/Pretty.hi
 create mode 100644 ghc/compiler/utils/SST.lhs
 create mode 100644 ghc/compiler/utils/Ubiq.lhi
 delete mode 100644 ghc/compiler/utils/UniqFM.hi
 delete mode 100644 ghc/compiler/utils/UniqSet.hi
 delete mode 100644 ghc/compiler/utils/Unpretty.hi
 delete mode 100644 ghc/compiler/utils/Util.hi

(limited to 'ghc')

diff --git a/ghc/compiler/HsVersions.h b/ghc/compiler/HsVersions.h
index ef14e63289..c5b68ef0b4 100644
--- a/ghc/compiler/HsVersions.h
+++ b/ghc/compiler/HsVersions.h
@@ -53,8 +53,10 @@ you will screw up the layout where they are used in case expressions!
 
 #ifdef DEBUG
 #define ASSERT(e) if (not (e)) then (assertPanic __FILE__ __LINE__) else
+#define CHK_Ubiq() import Ubiq
 #else
 #define ASSERT(e)
+#define CHK_Ubiq()
 #endif
 
 -- ToDo: ghci needs to load far too many bits of the backend because
diff --git a/ghc/compiler/Jmakefile b/ghc/compiler/Jmakefile
index d2346c51e7..1d167587b4 100644
--- a/ghc/compiler/Jmakefile
+++ b/ghc/compiler/Jmakefile
@@ -11,17 +11,12 @@
 #endif
 SUBDIRS = __ghc_compiler_tests_dir
 #undef __ghc_compiler_tests_dir
-/* ?????? ToDo: something about test dirs underneath yaccParser ????? */
-
-#if BuildDataParallelHaskell != YES
-    /* DPH likes to play around in subdirs */
-# define NoAllTargetForSubdirs
-# define NoDocsTargetForSubdirs
-# define NoInstallDocsTargetForSubdirs
-# define NoDependTargetForSubdirs
-#endif
-    /* these always apply */
-# define NoInstallTargetForSubdirs
+
+#define NoAllTargetForSubdirs
+#define NoDocsTargetForSubdirs
+#define NoInstallDocsTargetForSubdirs
+#define NoDependTargetForSubdirs
+#define NoInstallTargetForSubdirs
 #define NoTagTargetForSubdirs
 
 /* Suffix rules: we do not use them much at all in GHC.
@@ -37,10 +32,7 @@ LitSuffixRule(.lprl,.prl) /* for makeSymbolList.prl */
 */
 
 SUBDIR_LIST = \ /* here they are, colon separated (for mkdependHS) */
-utils:basicTypes:uniType:abstractSyn:prelude:envs:rename:typecheck:deSugar:coreSyn:specialise:simplCore:stranal:stgSyn:simplStg:codeGen:nativeGen:absCSyn:main:reader:profiling:deforest:podizeCore:yaccParser:nhcParser:interpreter
-
-DASH_I_SUBDIR_LIST = \ /* same thing, in -I<dir> format */
--Iutils -IbasicTypes -IuniType -IabstractSyn -Iprelude -Ienvs -Irename -Itypecheck -IdeSugar -IcoreSyn -Ispecialise -IsimplCore -Istranal -IstgSyn -IsimplStg -IcodeGen -InativeGen -IabsCSyn -Imain -Ireader -Iprofiling -Ideforest -IpodizeCore -IyaccParser -InhcParser -Iinterpreter
+utils:basicTypes:types:hsSyn:prelude:envs:rename:typecheck:deSugar:coreSyn:specialise:simplCore:stranal:stgSyn:simplStg:codeGen:nativeGen:absCSyn:main:reader:profiling:deforest:parser
 
 #ifdef MainIncludeDir
 MAIN_INCLUDE_DIR=MainIncludeDir
@@ -63,149 +55,116 @@ NATIVEGEN_DIR=$(TOP_PWD)/$(CURRENT_DIR)/nativeGen
 
 /* in order-of-passes order, utility modules at the end */
 
-#if GhcBuilderVersion >= 23 && GhcBuildeeVersion >= 23
-# define USE_NEW_READER YES
-# define __new_reader_flag -DUSE_NEW_READER=1
-#else
-# define __new_reader_flag /*none*/
-#endif
-#if USE_NEW_READER == YES
-# define READERSRCS_HS	\
-yaccParser/U_atype.hs	\
-yaccParser/U_binding.hs	\
-yaccParser/U_coresyn.hs	\
-yaccParser/U_entidt.hs	\
-yaccParser/U_finfot.hs	\
-yaccParser/U_hpragma.hs	\
-yaccParser/U_list.hs	\
-yaccParser/U_literal.hs	\
-yaccParser/U_pbinding.hs \
-yaccParser/U_treeHACK.hs \
-yaccParser/U_ttype.hs
-#define READERSRCS_LHS	\
-yaccParser/UgenUtil.lhs	\
-yaccParser/UgenAll.lhs	\
-reader/ReadPrefix2.lhs	\
-reader/ReadPragmas2.lhs
+#define READERSRCS_HS	\
+parser/U_constr.hs	\
+parser/U_binding.hs	\
+parser/U_pbinding.hs	\
+parser/U_coresyn.hs	\
+parser/U_entidt.hs	\
+parser/U_hpragma.hs	\
+parser/U_list.hs	\
+parser/U_literal.hs	\
+parser/U_maybe.hs	\
+parser/U_either.hs	\
+parser/U_qid.hs		\
+parser/U_tree.hs 	\
+parser/U_ttype.hs
+
 #define hsp_library libhsp.a
-#else
-#define READERSRCS_HS	/* none */
+
 #define READERSRCS_LHS	\
+parser/UgenUtil.lhs	\
+parser/UgenAll.lhs	\
 reader/ReadPrefix.lhs	\
-reader/ReadPragmas.lhs
-#define hsp_library /*none*/
-#endif
-
-#define FRONTSRCS_LHS	\
+reader/ReadPragmas.lhs	\
+\
 reader/PrefixSyn.lhs	\
 reader/PrefixToHs.lhs	\
+reader/RdrHsSyn.lhs	\
 \
-basicTypes/Unique.lhs	\
-basicTypes/SplitUniq.lhs \
-basicTypes/ProtoName.lhs \
-basicTypes/NameTypes.lhs \
-basicTypes/SrcLoc.lhs	\
-basicTypes/Id.lhs	\
-basicTypes/IdInfo.lhs	\
-basicTypes/Inst.lhs	\
-basicTypes/BasicLit.lhs	\
-basicTypes/CLabelInfo.lhs \
-basicTypes/OrdList.lhs \
-\
-uniType/TyVar.lhs	\
-uniType/TyCon.lhs	\
-uniType/Class.lhs	\
-uniType/UniType.lhs	\
-uniType/UniTyFuns.lhs	\
-uniType/AbsUniType.lhs	\
+hsSyn/HsBinds.lhs  /* abstract Haskell syntax */ \
+hsSyn/HsCore.lhs \
+hsSyn/HsDecls.lhs \
+hsSyn/HsExpr.lhs \
+hsSyn/HsImpExp.lhs \
+hsSyn/HsLit.lhs \
+hsSyn/HsMatches.lhs \
+hsSyn/HsPat.lhs \
+hsSyn/HsPragmas.lhs \
+hsSyn/HsTypes.lhs \
+hsSyn/HsSyn.lhs
+
+#define NOT_SO_BASICSRCS_LHS 	\
+basicTypes/Unique.lhs		\
+basicTypes/UniqSupply.lhs 	\
+basicTypes/ProtoName.lhs 	\
+basicTypes/Name.lhs 		\
+basicTypes/NameTypes.lhs 	\
+basicTypes/SrcLoc.lhs		\
+basicTypes/Id.lhs		\
+basicTypes/IdInfo.lhs		\
+basicTypes/IdUtils.lhs		\
+basicTypes/PragmaInfo.lhs	\
+basicTypes/Literal.lhs		\
 \
-abstractSyn/Name.lhs /* abstract Haskell syntax */ \
-abstractSyn/HsCore.lhs \
-abstractSyn/HsPragmas.lhs \
-abstractSyn/HsImpExp.lhs \
-abstractSyn/HsDecls.lhs \
-abstractSyn/HsBinds.lhs \
-abstractSyn/HsMatches.lhs \
-abstractSyn/HsLit.lhs \
-abstractSyn/HsExpr.lhs \
-abstractSyn/HsPat.lhs \
-abstractSyn/HsTypes.lhs \
-abstractSyn/AbsSyn.lhs \
-abstractSyn/AbsSynFuns.lhs \
+types/Class.lhs			\
+types/Kind.lhs			\
+types/PprType.lhs		\
+types/TyCon.lhs			\
+types/TyVar.lhs			\
+types/Usage.lhs			\
+types/Type.lhs			\
 \
-rename/Rename.lhs \
-rename/Rename1.lhs \
-rename/Rename2.lhs \
-rename/Rename3.lhs \
-rename/Rename4.lhs \
-rename/RenameAuxFuns.lhs \
-rename/RenameMonad12.lhs \
-rename/RenameMonad3.lhs \
-rename/RenameMonad4.lhs \
-rename/RenameBinds4.lhs \
-rename/RenameExpr4.lhs
+specialise/SpecEnv.lhs
+
+
+#define RENAMERSRCS_LHS \
+rename/RnPass1.lhs \
+rename/RnPass2.lhs \
+rename/RnPass3.lhs \
+rename/RnPass4.lhs \
+rename/RnHsSyn.lhs \
+rename/RnUtils.lhs \
+rename/RnMonad12.lhs \
+rename/RnMonad3.lhs \
+rename/RnMonad4.lhs \
+rename/RnBinds4.lhs \
+rename/RnExpr4.lhs \
+rename/Rename.lhs
 
 #define TCSRCS_LHS \
-prelude/PrelFuns.lhs \
-prelude/PrimKind.lhs \
-prelude/PrimOps.lhs \
-prelude/TysPrim.lhs \
-prelude/TysWiredIn.lhs \
-prelude/PrelVals.lhs \
-prelude/AbsPrel.lhs \
-\
-envs/IdEnv.lhs \
-envs/TyVarEnv.lhs \
-envs/LIE.lhs \
-envs/CE.lhs \
-envs/E.lhs \
-envs/InstEnv.lhs \
-envs/TCE.lhs \
-envs/TVE.lhs \
-\
-typecheck/BackSubst.lhs \
-typecheck/Disambig.lhs \
+typecheck/TcHsSyn.lhs \
 typecheck/GenSpecEtc.lhs \
-typecheck/Spec.lhs \
-typecheck/Subst.lhs	\
+typecheck/Inst.lhs	\
 typecheck/TcBinds.lhs \
 typecheck/TcClassDcl.lhs \
-typecheck/TcClassSig.lhs \
-typecheck/TcConDecls.lhs \
-typecheck/TcContext.lhs \
 typecheck/TcDefaults.lhs \
 typecheck/TcDeriv.lhs \
 typecheck/TcExpr.lhs \
-typecheck/TcGRHSs.lhs \
 typecheck/TcGenDeriv.lhs \
+typecheck/TcGRHSs.lhs \
 typecheck/TcIfaceSig.lhs \
 typecheck/TcInstDcls.lhs \
+typecheck/TcInstUtil.lhs \
 typecheck/TcMatches.lhs \
 typecheck/TcModule.lhs \
 typecheck/TcMonad.lhs \
-typecheck/TcMonadFns.lhs \
-typecheck/TcMonoBnds.lhs \
+typecheck/TcEnv.lhs \
+typecheck/TcKind.lhs \
+typecheck/TcType.lhs \
 typecheck/TcMonoType.lhs \
 typecheck/TcPat.lhs \
-typecheck/TcPolyType.lhs \
-typecheck/TcPragmas.lhs \
-typecheck/TcQuals.lhs \
 typecheck/TcSimplify.lhs \
+typecheck/TcTyClsDecls.lhs \
 typecheck/TcTyDecls.lhs \
 typecheck/Typecheck.lhs \
 typecheck/Unify.lhs
 
+/*
+typecheck/TcPragmas.lhs \
+*/
+
 #define DSSRCS_LHS \
-coreSyn/AnnCoreSyn.lhs \
-coreSyn/CoreSyn.lhs \
-coreSyn/PlainCore.lhs \
-coreSyn/TaggedCore.lhs \
-coreSyn/CoreFuns.lhs \
-coreSyn/CoreUnfold.lhs \
-coreSyn/FreeVars.lhs \
-coreSyn/CoreLift.lhs \
-coreSyn/CoreLint.lhs \
-\
 deSugar/Desugar.lhs \
 deSugar/Match.lhs \
 deSugar/MatchCon.lhs \
@@ -214,12 +173,20 @@ deSugar/DsBinds.lhs \
 deSugar/DsCCall.lhs \
 deSugar/DsExpr.lhs \
 deSugar/DsGRHSs.lhs \
+deSugar/DsHsSyn.lhs \
 deSugar/DsListComp.lhs \
 deSugar/DsMonad.lhs \
 deSugar/DsUtils.lhs \
 \
+coreSyn/CoreLift.lhs \
+coreSyn/CoreLint.lhs
+
+#define SIMPL_SRCS_LHS \
+coreSyn/AnnCoreSyn.lhs \
+coreSyn/FreeVars.lhs \
+\
 specialise/Specialise.lhs \
-specialise/SpecTyFuns.lhs \
+specialise/SpecUtils.lhs \
 \
 simplCore/SimplCase.lhs \
 simplCore/SimplEnv.lhs \
@@ -231,17 +198,14 @@ simplCore/Simplify.lhs \
 \
 simplCore/LiberateCase.lhs \
 \
-simplCore/BinderInfo.lhs \
 simplCore/ConFold.lhs \
 simplCore/FloatIn.lhs \
 simplCore/FloatOut.lhs \
-simplCore/MagicUFs.lhs \
 simplCore/SAT.lhs \
 simplCore/SATMonad.lhs \
 simplCore/SetLevels.lhs \
 simplCore/SimplCore.lhs \
 simplCore/OccurAnal.lhs \
-simplCore/NewOccurAnal.lhs \
 simplCore/FoldrBuildWW.lhs \
 simplCore/AnalFBWW.lhs \
 \
@@ -255,37 +219,6 @@ profiling/SCCauto.lhs \
 profiling/SCCfinal.lhs \
 profiling/CostCentre.lhs
 
-#if UseSemantiqueStrictnessAnalyser != YES
-#define SEM_STRANAL_SRCS_LHS /* omit */
-#else
-#define SEM_STRANAL_SRCS_LHS \
-stranal-sem/AFE.lhs \
-stranal-sem/AbsVal.lhs \
-stranal-sem/AssocPair.lhs \
-stranal-sem/BuildAFE.lhs \
-stranal-sem/ConstrEnv.lhs \
-stranal-sem/Cycles.lhs \
-stranal-sem/FG.lhs \
-stranal-sem/FourProj.lhs \
-stranal-sem/OAL.lhs \
-stranal-sem/OAT.lhs \
-stranal-sem/OL.lhs \
-stranal-sem/ProgEnv.lhs \
-stranal-sem/ProjBasic.lhs \
-stranal-sem/ProjFactor.lhs  \
-stranal-sem/ProjFolds.lhs  \
-stranal-sem/ProjGets.lhs  \
-stranal-sem/ProjLubAnd.lhs \
-stranal-sem/REL.lhs \
-stranal-sem/StrAnal.lhs \
-stranal-sem/StrAnn.lhs \
-stranal-sem/StrAnnCore.lhs \
-stranal-sem/StrAnnUtil.lhs \
-stranal-sem/StrTypeEnv.lhs \
-stranal-sem/Transformer.lhs \
-stranal-sem/Tree.lhs
-#endif /* UseSemantiqueStrictnessAnalyser */
-
 #if GhcWithDeforester != YES
 #define __omit_deforester_flag -DOMIT_DEFORESTER=1
 #define DEFORESTER_SRCS_LHS /*none*/
@@ -302,97 +235,10 @@ deforest/Cyclic.lhs \
 deforest/TreelessForm.lhs
 #endif /* GhcWithDeforester */
 
-#if BuildGHCI != YES
-#define __build_ghci_flag /*nope*/
-#define NHCSRCS_LHS /* omit */
-#define GHCISRCS_LHS /* omit */
-#else
-#define __build_ghci_flag -DBUILD_GHCI=1
-#define NHCSRCS_LHS \
-nhcParser/Parse.lhs      \
-nhcParser/ParseCore.lhs  \
-nhcParser/ParseLib.lhs   \
-nhcParser/ParseLex.lhs   \
-nhcParser/PPSyntax.lhs   \
-nhcParser/PPLib.lhs      \
-nhcParser/Lexical.lhs    \
-nhcParser/Lex.lhs        \
-nhcParser/LexPre.lhs     \
-nhcParser/LexStr.lhs     \
-nhcParser/HS.lhs         \
-nhcParser/MkSyntax.lhs   \
-nhcParser/SyntaxPos.lhs  \
-nhcParser/Syntax.lhs     \
-nhcParser/Extra.lhs      \
-nhcParser/ScopeLib.lhs   \
-nhcParser/Import.lhs     \
-nhcParser/AttrLib.lhs    \
-nhcParser/Attr.lhs       \
-nhcParser/NHCName.lhs    \
-nhcParser/NameLow.lhs    \
-nhcParser/ParseI.lhs     \
-nhcParser/Tree234.lhs    \
-nhcParser/MergeSort.lhs  \
-nhcParser/StrName.lhs    \
-nhcParser/NameLib.lhs    \
-nhcParser/OsOnly.lhs     \
-nhcParser/Flags.lhs      \
-nhcParser/Fixity.lhs     \
-nhcParser/StrSyntax.lhs  \
-nhcParser/Either.lhs     \
-nhcParser/ListUtil.lhs   \
-nhcParser/NHCPackedString.lhs \
-nhcParser/HbcOnly.lhs    \
-nhcParser/LexLow.lhs     
-
-/* Bits we don't need after all.  ToDo: delete their source...
-nhcParser/IName.lhs      \
-nhcParser/IExtract.lhs   \
-nhcParser/Error.lhs      \
-nhcParser/BindLib.lhs    \
-nhcParser/BindI.lhs      
-*/
-
-#define GHCISRCS_LHS \
-interpreter/ToPrefix.lhs   \
-interpreter/UnsafeCoerce.lhs \
-interpreter/Dynamic.lhs \
-interpreter/Interpreter.lhs \
-interpreter/MkInterface.lhs \
-interpreter/GHCIMonad.lhs  \
-interpreter/FullEnv.lhs  \
-interpreter/Command.lhs    \
-interpreter/GHCIFlags.lhs	 \
-interpreter/GHCInterface.lhs \
-interpreter/GHCI.lhs \
-interpreter/GHCICore.lhs \
-interpreter/Dld.lhs
-
-/* ToDo: mkworld-ify */
-DLD_DIR 	= ./dld
-DLD_LIB 	= $(DLD_DIR)/libdld.a
-DLD_INCLUDE 	= $(DLD_DIR)/dld.h
-
-DLD_OBJS_O =			\
-	dld/dld.o		\
-	dld/find_exec.o		\
-	dld/define.o		\
-	dld/get_func.o		\
-	dld/get_symbol.o	\
-	dld/list_undef.o	\
-	dld/mk_dummy.o		\
-	dld/ref.o		\
-	dld/ul_file.o		\
-	dld/ul_symbol.o		\
-	dld/remove.o		\
-	dld/error.o
-
-#endif /* BuildGHCI */
-
 #define BACKSRCS_LHS \
 stgSyn/CoreToStg.lhs \
 stgSyn/StgSyn.lhs \
-stgSyn/StgFuns.lhs \
+stgSyn/StgUtils.lhs \
 stgSyn/StgLint.lhs \
 \
 simplStg/SatStgRhs.lhs \
@@ -404,17 +250,17 @@ simplStg/StgSATMonad.lhs \
 simplStg/StgSAT.lhs \
 simplStg/SimplStg.lhs \
 \
+absCSyn/AbsCUtils.lhs \
 absCSyn/AbsCSyn.lhs \
+absCSyn/CLabel.lhs \
 absCSyn/Costs.lhs \
 absCSyn/HeapOffs.lhs \
-absCSyn/AbsCFuns.lhs \
 absCSyn/PprAbsC.lhs \
 \
 codeGen/CodeGen.lhs \
 codeGen/ClosureInfo.lhs \
 codeGen/SMRep.lhs \
 codeGen/CgConTbls.lhs \
-codeGen/CgCompInfo.lhs \
 codeGen/CgMonad.lhs \
 codeGen/CgUsages.lhs \
 codeGen/CgHeapery.lhs \
@@ -434,36 +280,30 @@ codeGen/CgUpdate.lhs
        distributed C files, which do not have a native-code
        generator in them
     */
-#define __omit_ncg_maybe -DOMIT_NATIVE_CODEGEN=1
-#define NATIVEGEN_SRCS_LHS /*none*/
+# define __omit_ncg_maybe -DOMIT_NATIVE_CODEGEN=1
+# define NATIVEGEN_SRCS_LHS /*none*/
 #else
-#define __omit_ncg_maybe /*none*/
-#if i386_TARGET_ARCH
-#define __machdep_nativegen_lhs \
+# define __omit_ncg_maybe /*none*/
+# if i386_TARGET_ARCH
+# define __machdep_nativegen_lhs \
 nativeGen/I386Desc.lhs \
 nativeGen/I386Code.lhs \
 nativeGen/I386Gen.lhs
-#define __ghci_machdep_nativegen_lhs \
-nativeGen/I386Code.lhs
-#endif
-#if sparc_TARGET_ARCH
-#define __machdep_nativegen_lhs \
+# endif
+# if sparc_TARGET_ARCH
+# define __machdep_nativegen_lhs \
 nativeGen/SparcDesc.lhs \
 nativeGen/SparcCode.lhs \
 nativeGen/SparcGen.lhs
-#define __ghci_machdep_nativegen_lhs \
-nativeGen/SparcCode.lhs
-#endif
-#if alpha_TARGET_ARCH
-#define __machdep_nativegen_lhs \
+# endif
+# if alpha_TARGET_ARCH
+# define __machdep_nativegen_lhs \
 nativeGen/AlphaDesc.lhs \
 nativeGen/AlphaCode.lhs \
 nativeGen/AlphaGen.lhs
-#define __ghci_machdep_nativegen_lhs \
-nativeGen/AlphaCode.lhs
-#endif
+# endif
 
-#define NATIVEGEN_SRCS_LHS \
+# define NATIVEGEN_SRCS_LHS \
 nativeGen/AbsCStixGen.lhs \
 nativeGen/AsmCodeGen.lhs \
 nativeGen/AsmRegAlloc.lhs \
@@ -477,127 +317,81 @@ __machdep_nativegen_lhs /*arch-specific ones */
 #endif
 
 #define UTILSRCS_LHS \
-utils/CharSeq.lhs \
+utils/Argv.lhs \
 utils/Bag.lhs \
-utils/Pretty.lhs \
-utils/Unpretty.lhs \
-utils/Maybes.lhs \
-utils/Digraph.lhs \
 utils/BitSet.lhs \
-utils/LiftMonad.lhs \
+utils/CharSeq.lhs \
+utils/Digraph.lhs \
+utils/FiniteMap.lhs \
 utils/ListSetOps.lhs \
+utils/MatchEnv.lhs \
+utils/Maybes.lhs \
+utils/OrdList.lhs \
 utils/Outputable.lhs \
-utils/FiniteMap.lhs \
+utils/PprStyle.lhs \
+utils/Pretty.lhs \
+utils/SST.lhs \
 utils/UniqFM.lhs \
 utils/UniqSet.lhs \
+utils/Unpretty.lhs \
 utils/Util.lhs
 
-#if BuildDataParallelHaskell != YES
-#define DPH_SRCS_LHS /*none*/
-#else
-#define DPH_SRCS_LHS \
-\
-typecheck/TcParQuals.lhs \
-deSugar/DsParZF.lhs \
-deSugar/MatchProc.lhs \
-prelude/ClsPid.lhs \
-prelude/ClsProc.lhs \
-prelude/TyPod.lhs \
-prelude/TyProcs.lhs \
-\
-podizeCore/PodInfoTree.lhs \
-podizeCore/PodInfoMonad.lhs \
-podizeCore/PodInfo1.lhs \
-podizeCore/PodInfo2.lhs \
-podizeCore/PodizeMonad.lhs \
-podizeCore/PodizePass0.lhs \
-podizeCore/PodizePass1.lhs \
-podizeCore/PodizePass2.lhs \
-podizeCore/PodizeCore.lhs
-#endif /* DPH */
-
 #define MAIN_SRCS_LHS \
-main/MkIface.lhs \
-main/ErrUtils.lhs \
-main/ErrsRn.lhs \
-main/ErrsTc.lhs \
-main/Errors.lhs \
 main/MainMonad.lhs \
 main/CmdLineOpts.lhs \
+main/ErrUtils.lhs \
 main/Main.lhs
 
+/* 
+main/MkIface.lhs \
+*/
+
+#define VBASICSRCS_LHS \
+prelude/PrelMods.lhs \
+prelude/PrimRep.lhs \
+prelude/PrimOp.lhs \
+prelude/TysPrim.lhs \
+prelude/TysWiredIn.lhs \
+prelude/PrelVals.lhs \
+prelude/PrelInfo.lhs \
+\
+absCSyn/CStrings.lhs \
+codeGen/CgCompInfo.lhs \
+coreSyn/CoreSyn.lhs \
+coreSyn/CoreUnfold.lhs \
+coreSyn/CoreUtils.lhs \
+coreSyn/PprCore.lhs \
+profiling/CostCentre.lhs \
+simplCore/BinderInfo.lhs \
+simplCore/MagicUFs.lhs
+
 ALLSRCS_HS = READERSRCS_HS
 ALLSRCS_LHS = /* all pieces of the compiler */ \
-READERSRCS_LHS \
-FRONTSRCS_LHS \
-TCSRCS_LHS \
-DSSRCS_LHS \
-BACKSRCS_LHS \
+VBASICSRCS_LHS \
+NOT_SO_BASICSRCS_LHS \
+UTILSRCS_LHS \
 MAIN_SRCS_LHS \
-UTILSRCS_LHS NATIVEGEN_SRCS_LHS DEFORESTER_SRCS_LHS SEM_STRANAL_SRCS_LHS DPH_SRCS_LHS NHCSRCS_LHS GHCISRCS_LHS
-/* NB: all the ones that may be empty (e.g., DPH_SRCS_LHS)
-	need to be on the last line.
-*/
-
-HSCSRCS_HS = READERSRCS_HS
-HSCSRCS_LHS = /* all pieces of the compiler */ \
 READERSRCS_LHS \
-FRONTSRCS_LHS \
+RENAMERSRCS_LHS \
 TCSRCS_LHS \
-DSSRCS_LHS \
-BACKSRCS_LHS \
-MAIN_SRCS_LHS \
-UTILSRCS_LHS NATIVEGEN_SRCS_LHS DEFORESTER_SRCS_LHS SEM_STRANAL_SRCS_LHS DPH_SRCS_LHS
-
-/* 
-As well as the obvious inclusions, there are a few non-obvious ones
-obtained from the transitive closure:
-
-* main/Errors.lhs andmain/CmdLineOpts.lhs are actually used.
-
-* most of the rest trickles in through the prelude.
-
-ToDo: hack around in the prelude to avoid all this...
+DSSRCS_LHS
 
+/*
+SIMPL_SRCS_LHS
+BACKSRCS_LHS
 */
 
-GHCISRCS = /* all pieces of the interpreter */ \
-FRONTSRCS_LHS \
-TCSRCS_LHS \
-DSSRCS_LHS \
-main/Errors.lhs \
-main/ErrUtils.lhs \
-main/ErrsRn.lhs \
-main/ErrsTc.lhs \
-main/CmdLineOpts.lhs \
-main/MainMonad.lhs \
-absCSyn/HeapOffs.lhs \
-codeGen/SMRep.lhs \
-codeGen/CgCompInfo.lhs \
-codeGen/ClosureInfo.lhs \
-codeGen/CgRetConv.lhs \
-absCSyn/AbsCSyn.lhs \
-codeGen/CgMonad.lhs \
-absCSyn/AbsCFuns.lhs \
-codeGen/CgBindery.lhs \
-codeGen/CgUsages.lhs \
-absCSyn/Costs.lhs \
-absCSyn/PprAbsC.lhs \
-stgSyn/StgSyn.lhs \
-nativeGen/AsmRegAlloc.lhs __ghci_machdep_nativegen_lhs \
-UTILSRCS_LHS SEM_STRANAL_SRCS_LHS DEFORESTER_SRCS_LHS NHCSRCS_LHS GHCISRCS_LHS
-
+/* 
+NATIVEGEN_SRCS_LHS DEFORESTER_SRCS_LHS */
+/* NB: all the ones that may be empty (e.g., NATIVEGEN_SRCS_LHS)
+	need to be on the last line.
+*/
 
 /* should't use these fancy `make' things, really */
+ALLHCS =$(ALLSRCS_LHS:.lhs=.hc) $(ALLSRCS_HS:.hs=.hc)
 ALLOBJS=$(ALLSRCS_LHS:.lhs=.o)  $(ALLSRCS_HS:.hs=.o)
 ALLINTS=$(ALLSRCS_LHS:.lhs=.hi) $(ALLSRCS_HS:.hs=.hi)
 
-HSCOBJS=$(HSCSRCS_LHS:.lhs=.o)  $(HSCSRCS_HS:.hs=.o)
-HSCINTS=$(HSCSRCS_LHS:.lhs=.hi) $(HSCSRCS_HS:.hs=.hi)
-
-GHCIOBJS=$(GHCISRCS:.lhs=.o) interpreter/DldHacks.o interpreter/DldC.o interpreter/prelude.o interpreter/runtime.o
-GHCIINTS=$(GHCISRCS:.lhs=.hi) interpreter/Dldhacks.hi
-
 .PRECIOUS: $(ALLINTS)
 
 #if GhcWithHscDebug == YES
@@ -606,14 +400,6 @@ GHCIINTS=$(GHCISRCS:.lhs=.hi) interpreter/Dldhacks.hi
 # define use_DDEBUG /*nothing*/
 #endif
 
-#if HaskellCompilerType == HC_CHALMERS_HBC
-
-HC_OPTS = -D__HASKELL1__=2 -M -H12m -DCOMPILING_GHC use_DDEBUG -I. -i$(SUBDIR_LIST)
-
-/* ToDo: else something for Niklas Rojemo's NHC (not yet) */
-
-#else /* assume we either have GlasgowHaskell or are booting from .hc C files */
-
 #if GhcWithHscOptimised == YES
 #define __version_sensitive_flags -DUSE_ATTACK_PRAGMAS -fshow-pragma-name-errs -fomit-reexported-instances -fshow-import-specs
 #else
@@ -631,72 +417,36 @@ HC_OPTS = -D__HASKELL1__=2 -M -H12m -DCOMPILING_GHC use_DDEBUG -I. -i$(SUBDIR_LI
 #undef  AllProjectsHcOpts
 #define AllProjectsHcOpts /**/
 
-HC_OPTS = -cpp -H12m HcMaxHeapFlag -fglasgow-exts -DCOMPILING_GHC \
+HC_OPTS = -cpp HcMaxHeapFlag -fhaskell-1.3 -fglasgow-exts -DCOMPILING_GHC \
 	-fomit-derived-read \
 	-I. -i$(SUBDIR_LIST) \
-	use_DDEBUG __version_sensitive_flags __unreg_opts_maybe __omit_ncg_maybe __new_reader_flag __build_ghci_flag __omit_deforester_flag
+	use_DDEBUG __version_sensitive_flags __unreg_opts_maybe __omit_ncg_maybe
 
 #undef __version_sensitive_flags
 #undef __unreg_opts_maybe
 #undef __omit_ncg_maybe
-#undef __new_reader_flag
-#undef __build_ghci_flag
 #undef __omit_deforester_flag
 
 #if GhcWithHscBuiltViaC == YES /* not using a Haskell compiler */
 
-HSCHCS=$(HSCSRCS_LHS:.lhs=.hc) $(HSCSRCS_HS:.hs=.hc)
-hcs:: $(HSCHCS)
+hcs:: $(ALLHCS)
 
-#if HaskellCompilerType == HC_USE_HC_FILES
+# if HaskellCompilerType == HC_USE_HC_FILES
 HC = $(GHC) /* uses the driver herein */
-#endif
+# endif
 
 #endif /* using .hc files */
-#endif /* not using HBC */
 
 /*
     -DCOMPILING_GHC
-	we're compiling the compiler with itself; clear enough?
-	Only used at present to ask for SPECIALIZEd functions
-	in modules that are allegedly "generic" (e.g., FiniteMap).
-
-    -DUSE_SEMANTIQUE_STRANAL
-	to include the Semantique strictness analyser into the compiler
-	[probably quite moth-eaten by now 94/05 (WDP)]
-
-    -DDPH	compiling Jon Hill's "data parallel Haskell"
-
-    (there are more, as yet unlisted WDP 94/12)
+	Used when compiling GHC.  Some GHC utility modules are
+	*also* part of the GHC library.  There are a few bits
+	of those modules that only apply to GHC itself and
+	should not be in the library stuff.  We use this
+	CPP thing to isolate those bits.
 */
-#if UseSemantiqueStrictnessAnalyser == YES
-STRANAL_SEM_P = -DUSE_SEMANTIQUE_STRANAL
-#endif
-
-#if BuildDataParallelHaskell == YES
-DPH_P = -DDPH
-#endif
 
-#if GhcUseSplittableUniqueSupply == YES
-/* ToDo: delete? */
-SPLIT_P = -DUSE_SPLITTABLE_UNIQUESUPPLY
-#endif
-
-GHC_EXTRA_DEFINES = $(STRANAL_SEM_P) $(DPH_P) $(SPLIT_P)
-
-#if USE_NEW_READER == YES
-BuildPgmFromHaskellModules(hsc,$(HSCOBJS) yaccParser/hsclink.o yaccParser/hschooks.o,,libhsp.a)
-#else
-BuildPgmFromHaskellModules(hsc,$(HSCOBJS),,)
-#endif
-
-/* ghci::	hsc */
-/* Hack to let me bootstrap (needed for error handlers) */
-/* Comment out if building boot copy of hsc */
-/*HC = ../driver/ghc*/
-#if BuildGHCI == YES
-BuildPgmFromHaskellModules(ghci,$(GHCIOBJS),,$(DLD_LIB))
-#endif
+BuildPgmFromHaskellModules(hsc,$(ALLOBJS) parser/hsclink.o parser/hschooks.o,,libhsp.a)
 
 #if DoInstallGHCSystem == YES
 MakeDirectories(install, $(INSTLIBDIR_GHC))
@@ -744,143 +494,152 @@ HaskellCompileWithExtraFlags_Recursive(module,isuf,o,-c,extra_flags)
 
 #endif /* ! booting from C */
 
-#if HaskellCompilerType == HC_CHALMERS_HBC
-# define if_ghc(x)   /*nothing*/
-# define if_ghc26(x) /*nothing*/
-#else /* hope for GHC-ish */
-# define if_ghc(x) x
-# if GhcBuilderVersion >= 26
+#define if_ghc(x) x
+#if GhcBuilderVersion >= 26
 #  define if_ghc26(x) x
-# else
+#else
 #  define if_ghc26(x) /*nothing*/
-# endif
 #endif
 
 /* OK, here we go: */
 
-compile(absCSyn/AbsCFuns,lhs,)
-compile_rec(absCSyn/AbsCSyn,lhs,if_ghc(-fno-omit-reexported-instances))
-compile(absCSyn/Costs,lhs,)              /* HWL */
-compile_rec(absCSyn/HeapOffs,lhs,)
-compile(absCSyn/PprAbsC,lhs,-H20m)
-
-compile_rec(abstractSyn/AbsSyn,lhs,if_ghc(-fno-omit-reexported-instances))
-compile_rec(abstractSyn/AbsSynFuns,lhs,)
-compile_rec(abstractSyn/HsBinds,lhs,)
-compile_rec(abstractSyn/HsCore,lhs,)
-compile(abstractSyn/HsDecls,lhs,)
-compile_rec(abstractSyn/HsExpr,lhs,-H14m)
-compile(abstractSyn/HsImpExp,lhs,)
-compile(abstractSyn/HsLit,lhs,)
-compile(abstractSyn/HsMatches,lhs,)
-compile(abstractSyn/HsPat,lhs,)
-compile_rec(abstractSyn/HsPragmas,lhs,)
-compile(abstractSyn/HsTypes,lhs,)
-compile_rec(abstractSyn/Name,lhs,)
-
-compile(basicTypes/BasicLit,lhs,)
-compile(basicTypes/OrdList,lhs,)
-compile_rec(basicTypes/CLabelInfo,lhs,)
-compile_rec(basicTypes/Id,lhs,-H20m)
-compile_rec(basicTypes/IdInfo,lhs,-H20m -K2m)
-compile(basicTypes/Inst,lhs,)
+utils/Ubiq.hi : utils/Ubiq.lhi
+	$(GHC_UNLIT) utils/Ubiq.lhi utils/Ubiq.hi
+
+basicTypes/IdLoop.hi : basicTypes/IdLoop.lhi
+	$(GHC_UNLIT) basicTypes/IdLoop.lhi basicTypes/IdLoop.hi
+basicTypes/NameLoop.hi : basicTypes/NameLoop.lhi
+	$(GHC_UNLIT) basicTypes/NameLoop.lhi basicTypes/NameLoop.hi
+deSugar/DsLoop.hi : deSugar/DsLoop.lhi
+	$(GHC_UNLIT) deSugar/DsLoop.lhi deSugar/DsLoop.hi
+hsSyn/HsLoop.hi : hsSyn/HsLoop.lhi
+	$(GHC_UNLIT) hsSyn/HsLoop.lhi hsSyn/HsLoop.hi
+prelude/PrelLoop.hi : prelude/PrelLoop.lhi
+	$(GHC_UNLIT) prelude/PrelLoop.lhi prelude/PrelLoop.hi
+reader/RdrLoop.hi : reader/RdrLoop.lhi
+	$(GHC_UNLIT) reader/RdrLoop.lhi reader/RdrLoop.hi
+rename/RnLoop.hi : rename/RnLoop.lhi
+	$(GHC_UNLIT) rename/RnLoop.lhi rename/RnLoop.hi
+simplCore/SmplLoop.hi : simplCore/SmplLoop.lhi
+	$(GHC_UNLIT) simplCore/SmplLoop.lhi simplCore/SmplLoop.hi
+typecheck/TcMLoop.hi : typecheck/TcMLoop.lhi
+	$(GHC_UNLIT) typecheck/TcMLoop.lhi typecheck/TcMLoop.hi
+typecheck/TcLoop.hi : typecheck/TcLoop.lhi
+	$(GHC_UNLIT) typecheck/TcLoop.lhi typecheck/TcLoop.hi
+types/TyLoop.hi : types/TyLoop.lhi
+	$(GHC_UNLIT) types/TyLoop.lhi types/TyLoop.hi
+
+compile(absCSyn/AbsCUtils,lhs,)
+compile(absCSyn/CStrings,lhs,)
+compile(absCSyn/CLabel,lhs,)
+compile(absCSyn/Costs,lhs,)
+compile(absCSyn/HeapOffs,lhs,)
+compile(absCSyn/PprAbsC,lhs,)
+compile(absCSyn/AbsCSyn,lhs,if_ghc(-fno-omit-reexported-instances))
+
+compile(hsSyn/HsBinds,lhs,)
+compile(hsSyn/HsCore,lhs,)
+compile(hsSyn/HsDecls,lhs,)
+compile(hsSyn/HsExpr,lhs,)
+compile(hsSyn/HsImpExp,lhs,)
+compile(hsSyn/HsLit,lhs,)
+compile(hsSyn/HsMatches,lhs,)
+compile(hsSyn/HsPat,lhs,)
+compile(hsSyn/HsPragmas,lhs,)
+compile(hsSyn/HsTypes,lhs,)
+compile(hsSyn/HsSyn,lhs,if_ghc(-fno-omit-reexported-instances))
+
+compile(basicTypes/Id,lhs,)
+compile(basicTypes/IdInfo,lhs,-K2m)
+compile(basicTypes/IdUtils,lhs,)
+compile(basicTypes/Literal,lhs,)
+compile(basicTypes/Name,lhs,)
 compile(basicTypes/NameTypes,lhs,)
+compile(basicTypes/PragmaInfo,lhs,)
 compile(basicTypes/ProtoName,lhs,)
 compile(basicTypes/SrcLoc,lhs,)
+compile(basicTypes/UniqSupply,lhs,)
 compile(basicTypes/Unique,lhs,)
-compile_rec(basicTypes/SplitUniq,lhs,)
 
 compile(codeGen/CgBindery,lhs,)
-compile(codeGen/CgCase,lhs,-H16m)
-compile(codeGen/CgClosure,lhs,-H16m)
-compile_rec(codeGen/CgCompInfo,lhs,-I$(COMPINFO_DIR))
+compile(codeGen/CgCase,lhs,)
+compile(codeGen/CgClosure,lhs,)
+compile(codeGen/CgCompInfo,lhs,-I$(COMPINFO_DIR))
 compile(codeGen/CgCon,lhs,)
 compile(codeGen/CgConTbls,lhs,)
-compile_rec(codeGen/CgExpr,lhs,)
+compile(codeGen/CgExpr,lhs,)
 compile(codeGen/CgHeapery,lhs,)
 compile(codeGen/CgLetNoEscape,lhs,)
-compile_rec(codeGen/CgMonad,lhs,if_ghc(-fno-omit-reexported-instances))
-compile_rec(codeGen/CgRetConv,lhs,)
+compile(codeGen/CgMonad,lhs,)
+compile(codeGen/CgRetConv,lhs,)
 compile(codeGen/CgStackery,lhs,)
 compile(codeGen/CgTailCall,lhs,)
 compile(codeGen/CgUpdate,lhs,)
 compile(codeGen/CgUsages,lhs,)
-compile_rec(codeGen/ClosureInfo,lhs,)
+compile(codeGen/ClosureInfo,lhs,)
 compile(codeGen/CodeGen,lhs,)
 compile(codeGen/SMRep,lhs,)
 
 compile(coreSyn/AnnCoreSyn,lhs,if_ghc(-fno-omit-reexported-instances))
-compile(coreSyn/CoreFuns,lhs,-H16m)
+compile(coreSyn/CoreUtils,lhs,)
 compile(coreSyn/CoreLift,lhs,)
 compile(coreSyn/CoreLint,lhs,)
 compile(coreSyn/CoreSyn,lhs,)
+compile(coreSyn/PprCore,lhs,)
 compile(coreSyn/CoreUnfold,lhs,)
 compile(coreSyn/FreeVars,lhs,)
-compile_rec(coreSyn/PlainCore,lhs,if_ghc(-fno-omit-reexported-instances))
-compile(coreSyn/TaggedCore,lhs,if_ghc(-fno-omit-reexported-instances))
 
 compile(deSugar/Desugar,lhs,)
-compile_rec(deSugar/DsBinds,lhs,-H16m)
+compile(deSugar/DsBinds,lhs,)
 compile(deSugar/DsCCall,lhs,)
-compile_rec(deSugar/DsExpr,lhs,-H16m)
+compile(deSugar/DsExpr,lhs,)
 compile(deSugar/DsGRHSs,lhs,)
+compile(deSugar/DsHsSyn,lhs,)
 compile(deSugar/DsListComp,lhs,)
 compile(deSugar/DsMonad,lhs,)
-compile_rec(deSugar/DsUtils,lhs,)
-compile_rec(deSugar/Match,lhs,)
+compile(deSugar/DsUtils,lhs,)
+compile(deSugar/Match,lhs,)
 compile(deSugar/MatchCon,lhs,)
 compile(deSugar/MatchLit,lhs,)
 
-compile(envs/CE,lhs,)
-compile(envs/E,lhs,)
-compile(envs/IdEnv,lhs,)
-compile_rec(envs/InstEnv,lhs,)
-compile(envs/LIE,lhs,)
-compile(envs/TCE,lhs,)
-compile(envs/TVE,lhs,)
-compile_rec(envs/TyVarEnv,lhs,)
-
-compile(main/CmdLineOpts,lhs,-K2m if_ghc(-fvia-C))
-compile_rec(main/Errors,lhs,)
-compile_rec(main/ErrsTc,lhs,-H20m if_ghc26(-monly-4-regs))
-compile_rec(main/ErrsRn,lhs,)
-compile_rec(main/ErrUtils,lhs,)
-compile(main/Main,lhs,-H16m if_ghc(-fvia-C -fno-update-analysis)) /* ToDo: update */
-compile(main/MainMonad,lhs,if_ghc(-fno-omit-reexported-instances))
+compile(main/CmdLineOpts,lhs,if_ghc(-fvia-C))
+compile(main/ErrUtils,lhs,)
+compile(main/Main,lhs,if_ghc(-fvia-C))
+compile(main/MainMonad,lhs,)
 compile(main/MkIface,lhs,)
 
 #if GhcWithNativeCodeGen == YES
 compile(nativeGen/AbsCStixGen,lhs,)
 compile(nativeGen/AsmCodeGen,lhs,-I$(COMPINFO_DIR))
-compile_rec(nativeGen/AsmRegAlloc,lhs,-I$(COMPINFO_DIR) -H20m)
+compile(nativeGen/AsmRegAlloc,lhs,-I$(COMPINFO_DIR))
 compile(nativeGen/MachDesc,lhs,)
 compile(nativeGen/Stix,lhs,)
 compile(nativeGen/StixInfo,lhs,-I$(NATIVEGEN_DIR))
-compile(nativeGen/StixInteger,lhs,-H20m)
+compile(nativeGen/StixInteger,lhs,)
 compile(nativeGen/StixMacro,lhs,-I$(NATIVEGEN_DIR))
-compile(nativeGen/StixPrim,lhs,-H16m)
+compile(nativeGen/StixPrim,lhs,)
 # if i386_TARGET_ARCH
-compile_rec(nativeGen/I386Desc,lhs,)
-compile(nativeGen/I386Code,lhs,-H20m -I$(NATIVEGEN_DIR) if_ghc(-monly-4-regs))
-compile(nativeGen/I386Gen,lhs,-H20m)
+compile(nativeGen/I386Desc,lhs,)
+compile(nativeGen/I386Code,lhs,-I$(NATIVEGEN_DIR) if_ghc(-monly-4-regs))
+compile(nativeGen/I386Gen,lhs,)
 # endif
 # if sparc_TARGET_ARCH
-compile_rec(nativeGen/SparcDesc,lhs,)
-compile(nativeGen/SparcCode,lhs,-H20m -I$(NATIVEGEN_DIR))
-compile(nativeGen/SparcGen,lhs,-H20m)
+compile(nativeGen/SparcDesc,lhs,)
+compile(nativeGen/SparcCode,lhs,-I$(NATIVEGEN_DIR))
+compile(nativeGen/SparcGen,lhs,)
 # endif
 # if alpha_TARGET_ARCH
-compile_rec(nativeGen/AlphaDesc,lhs,)
-compile(nativeGen/AlphaCode,lhs,-H24m -K2m -I$(NATIVEGEN_DIR))
-compile(nativeGen/AlphaGen,lhs,-H24m -K2m)
+compile(nativeGen/AlphaDesc,lhs,)
+compile(nativeGen/AlphaCode,lhs,-I$(NATIVEGEN_DIR))
+compile(nativeGen/AlphaGen,lhs,)
 # endif
 #endif
 
-compile_rec(prelude/AbsPrel,lhs,-H16m -K2m if_ghc(-fno-omit-reexported-instances -fno-update-analysis))
-compile_rec(prelude/PrelFuns,lhs,)
+compile(prelude/PrelInfo,lhs,)
+compile(prelude/PrelMods,lhs,)
 compile(prelude/PrelVals,lhs,)
-compile_rec(prelude/PrimKind,lhs,-I$(COMPINFO_DIR))
-compile_rec(prelude/PrimOps,lhs,-H16m -K3m)
+compile(prelude/PrimRep,lhs,-I$(COMPINFO_DIR))
+compile(prelude/PrimOp,lhs,-K3m -H10m)
 compile(prelude/TysPrim,lhs,)
 compile(prelude/TysWiredIn,lhs,)
 
@@ -889,23 +648,23 @@ compile(profiling/SCCfinal,lhs,)
 compile(profiling/CostCentre,lhs,)
 
 compile(reader/PrefixSyn,lhs,)
-compile(reader/PrefixToHs,lhs,-H16m)
+compile(reader/PrefixToHs,lhs,)
+compile(reader/ReadPrefix,lhs,if_ghc(-fvia-C -I$(COMPINFO_DIR) -Iparser '-#include"hspincl.h"'))
 compile(reader/ReadPragmas,lhs,)
-compile_rec(reader/ReadPrefix,lhs,)
-compile_rec(reader/ReadPrefix2,lhs,-H20m if_ghc(-fvia-C -I$(COMPINFO_DIR) -IyaccParser '-#include"hspincl.h"'))
-compile(reader/ReadPragmas2,lhs,-H20m)
+compile(reader/RdrHsSyn,lhs,)
 
 compile(rename/Rename,lhs,)
-compile(rename/Rename1,lhs,)
-compile(rename/Rename2,lhs,)
-compile(rename/Rename3,lhs,)
-compile(rename/Rename4,lhs,-H20m)
-compile(rename/RenameAuxFuns,lhs,)
-compile_rec(rename/RenameBinds4,lhs,)
-compile_rec(rename/RenameExpr4,lhs,)
-compile(rename/RenameMonad12,lhs,)
-compile(rename/RenameMonad3,lhs,)
-compile(rename/RenameMonad4,lhs,)
+compile(rename/RnPass1,lhs,)
+compile(rename/RnPass2,lhs,)
+compile(rename/RnPass3,lhs,)
+compile(rename/RnPass4,lhs,)
+compile(rename/RnUtils,lhs,)
+compile(rename/RnHsSyn,lhs,)
+compile(rename/RnBinds4,lhs,)
+compile(rename/RnExpr4,lhs,)
+compile(rename/RnMonad12,lhs,)
+compile(rename/RnMonad3,lhs,)
+compile(rename/RnMonad4,lhs,)
 
 compile(simplCore/BinderInfo,lhs,)
 compile(simplCore/ConFold,lhs,)
@@ -915,21 +674,19 @@ compile(simplCore/LiberateCase,lhs,)
 compile(simplCore/MagicUFs,lhs,)
 compile(simplCore/OccurAnal,lhs,)
 
-compile(simplCore/NewOccurAnal,lhs,)
 compile(simplCore/AnalFBWW,lhs,)
 compile(simplCore/FoldrBuildWW,lhs,)
-/* ANDY: compile(simplCore/SimplHaskell,lhs,) */
 
 compile(simplCore/SAT,lhs,)
 compile(simplCore/SATMonad,lhs,)
 compile(simplCore/SetLevels,lhs,)
-compile_rec(simplCore/SimplCase,lhs,-H20m)
+compile(simplCore/SimplCase,lhs,)
 compile(simplCore/SimplCore,lhs,)
-compile_rec(simplCore/SimplEnv,lhs,)
+compile(simplCore/SimplEnv,lhs,)
 compile(simplCore/SimplMonad,lhs,)
 compile(simplCore/SimplPgm,lhs,)
 compile(simplCore/SimplUtils,lhs,)
-compile_rec(simplCore/SimplVar,lhs,)
+compile(simplCore/SimplVar,lhs,)
 compile(simplCore/Simplify,lhs,)
 
 compile(simplStg/SatStgRhs,lhs,)
@@ -944,21 +701,22 @@ compile(simplStg/SimplStg,lhs,)
 #if GhcWithDeforester == YES
 compile(deforest/Core2Def,lhs,)
 compile(deforest/Cyclic,lhs,)
-compile_rec(deforest/Def2Core,lhs,)
-compile(deforest/DefExpr,lhs,-H20m)
+compile(deforest/Def2Core,lhs,)
+compile(deforest/DefExpr,lhs,)
 compile(deforest/DefSyn,lhs,)
-compile(deforest/DefUtils,lhs,-H16m)
+compile(deforest/DefUtils,lhs,)
 compile(deforest/Deforest,lhs,)
 compile(deforest/TreelessForm,lhs,)
 #endif
 
-compile(specialise/Specialise,lhs,-H32m) /* sigh */
-compile(specialise/SpecTyFuns,lhs,)
+compile(specialise/Specialise,lhs,)
+compile(specialise/SpecEnv,lhs,)
+compile(specialise/SpecUtils,lhs,)
 
 compile(stgSyn/CoreToStg,lhs,)
-compile(stgSyn/StgFuns,lhs,)
+compile(stgSyn/StgUtils,lhs,)
 compile(stgSyn/StgLint,lhs,)
-compile(stgSyn/StgSyn,lhs,if_ghc(-fno-omit-reexported-instances) -H16m)
+compile(stgSyn/StgSyn,lhs,if_ghc(-fno-omit-reexported-instances))
 
 compile(stranal/SaAbsInt,lhs,)
 compile(stranal/SaLib,lhs,)
@@ -966,164 +724,60 @@ compile(stranal/StrictAnal,lhs,)
 compile(stranal/WorkWrap,lhs,)
 compile(stranal/WwLib,lhs,)
 
-compile(typecheck/BackSubst,lhs,)
-compile_rec(typecheck/Disambig,lhs,)
 compile(typecheck/GenSpecEtc,lhs,)
-compile(typecheck/Spec,lhs,)
-compile(typecheck/Subst,lhs,if_ghc(-fvia-C) if_ghc26(-monly-4-regs))
+compile(typecheck/Inst,lhs,)
+compile(typecheck/TcHsSyn,lhs,)
 compile(typecheck/TcBinds,lhs,)
-compile(typecheck/TcClassDcl,lhs,-H14m)
-compile(typecheck/TcClassSig,lhs,)
-compile(typecheck/TcConDecls,lhs,)
-compile(typecheck/TcContext,lhs,)
+compile(typecheck/TcClassDcl,lhs,)
 compile(typecheck/TcDefaults,lhs,)
-compile_rec(typecheck/TcDeriv,lhs,-H20m)
-compile_rec(typecheck/TcExpr,lhs,-H20m)
-compile_rec(typecheck/TcGRHSs,lhs,)
-compile(typecheck/TcGenDeriv,lhs,-H20m)
+compile(typecheck/TcDeriv,lhs,)
+compile(typecheck/TcExpr,lhs,)
+compile(typecheck/TcGRHSs,lhs,)
+compile(typecheck/TcGenDeriv,lhs,)
 compile(typecheck/TcIfaceSig,lhs,)
-compile(typecheck/TcInstDcls,lhs,-H20m)
+compile(typecheck/TcInstDcls,lhs,)
+compile(typecheck/TcInstUtil,lhs,)
 compile(typecheck/TcMatches,lhs,)
 compile(typecheck/TcModule,lhs,)
-compile_rec(typecheck/TcMonad,lhs,)
-compile(typecheck/TcMonadFns,lhs,)
-compile(typecheck/TcMonoBnds,lhs,)
+compile(typecheck/TcMonad,lhs,)
+compile(typecheck/TcKind,lhs,)
+compile(typecheck/TcType,lhs,)
+compile(typecheck/TcEnv,lhs,)
 compile(typecheck/TcMonoType,lhs,)
-compile(typecheck/TcPat,lhs,-H14m)
-compile_rec(typecheck/TcPolyType,lhs,)
-compile(typecheck/TcPragmas,lhs,-H20m)
-compile(typecheck/TcQuals,lhs,)
+compile(typecheck/TcPat,lhs,)
+compile(typecheck/TcPragmas,lhs,)
 compile(typecheck/TcSimplify,lhs,)
+compile(typecheck/TcTyClsDecls,lhs,)
 compile(typecheck/TcTyDecls,lhs,)
 compile(typecheck/Typecheck,lhs,)
 compile(typecheck/Unify,lhs,)
 
-compile_rec(uniType/AbsUniType,lhs,if_ghc(-fno-omit-reexported-instances))
-compile_rec(uniType/Class,lhs,)
-compile_rec(uniType/TyCon,lhs,)
-compile_rec(uniType/TyVar,lhs,)
-compile(uniType/UniTyFuns,lhs,-H20m)
-compile_rec(uniType/UniType,lhs,)
+compile(types/Class,lhs,)
+compile(types/Kind,lhs,)
+compile(types/PprType,lhs,)
+compile(types/TyCon,lhs,)
+compile(types/TyVar,lhs,)
+compile(types/Usage,lhs,)
+compile(types/Type,lhs,)
 
+compile(utils/Argv,lhs,if_ghc(-fvia-C))
 compile(utils/Bag,lhs,)
+compile(utils/BitSet,lhs,if_ghc26(-monly-4-regs))
 compile(utils/CharSeq,lhs,if_ghc(-fvia-C)) /* uses stg_putc */
 compile(utils/Digraph,lhs,)
-compile(utils/FiniteMap,lhs,-H20m)
-compile(utils/LiftMonad,lhs,)
+compile(utils/FiniteMap,lhs,)
 compile(utils/ListSetOps,lhs,)
 compile(utils/Maybes,lhs,)
-compile_rec(utils/Outputable,lhs,)
-compile_rec(utils/Pretty,lhs,)
-compile(utils/BitSet,lhs,if_ghc26(-monly-4-regs))
-compile_rec(utils/UniqFM,lhs,)
+compile(utils/OrdList,lhs,)
+compile(utils/Outputable,lhs,)
+compile(utils/PprStyle,lhs,)
+compile(utils/Pretty,lhs,)
+compile(utils/SST,lhs,if_ghc(-fvia-C))
+compile(utils/UniqFM,lhs,)
 compile(utils/UniqSet,lhs,)
 compile(utils/Unpretty,lhs,)
-compile_rec(utils/Util,lhs,)
-
-/* Some of these sizes have been boosted a little to fit the alpha */
-#if BuildGHCI == YES
-compile(nhcParser/Attr,lhs,)
-compile(nhcParser/AttrLib,lhs,if_ghc(-fhaskell-1.3))
-compile(nhcParser/Either,lhs,if_ghc(-fhaskell-1.3))
-compile(nhcParser/Extra,lhs,if_ghc(-fhaskell-1.3))
-compile(nhcParser/Fixity,lhs,if_ghc(-fhaskell-1.3))
-compile(nhcParser/Flags,lhs,if_ghc(-fhaskell-1.3))
-compile(nhcParser/HS,lhs,if_ghc(-fhaskell-1.3))
-compile(nhcParser/HbcOnly,lhs,if_ghc(-fhaskell-1.3))
-compile(nhcParser/Import,lhs,)
-compile(nhcParser/Lex,lhs,)
-compile(nhcParser/LexLow,lhs,)
-compile(nhcParser/LexPre,lhs,)
-compile(nhcParser/LexStr,lhs,)
-compile(nhcParser/Lexical,lhs,if_ghc(-fhaskell-1.3))
-compile(nhcParser/ListUtil,lhs,)
-compile(nhcParser/MergeSort,lhs,)
-compile(nhcParser/MkSyntax,lhs,if_ghc(-fhaskell-1.3))
-compile(nhcParser/NHCName,lhs,)
-compile(nhcParser/NHCPackedString,lhs,)
-compile(nhcParser/NameLib,lhs,if_ghc(-fhaskell-1.3))
-compile(nhcParser/NameLow,lhs,if_ghc(-fhaskell-1.3))
-compile(nhcParser/OsOnly,lhs,)
-compile(nhcParser/PPLib,lhs,)
-compile(nhcParser/PPSyntax,lhs,)
-compile(nhcParser/Parse,lhs,-H30m if_ghc(-fhaskell-1.3))
-compile(nhcParser/ParseCore,lhs,if_ghc(-fhaskell-1.3))
-compile(nhcParser/ParseI,lhs,if_ghc(-fhaskell-1.3))
-compile(nhcParser/ParseLex,lhs,if_ghc(-fhaskell-1.3))
-compile(nhcParser/ParseLib,lhs,if_ghc(-fhaskell-1.3))
-compile(nhcParser/ScopeLib,lhs,)
-compile(nhcParser/StrName,lhs,)
-compile(nhcParser/StrSyntax,lhs,)
-compile(nhcParser/Syntax,lhs,)
-compile(nhcParser/SyntaxPos,lhs,)
-compile(nhcParser/Tree234,lhs,)
-
-compile(interpreter/ToPrefix,lhs,if_ghc(-fhaskell-1.3))
-compile(interpreter/UnsafeCoerce,lhs,if_ghc(-nohi)) /* NB: no interface file, please! */
-compile(interpreter/Dynamic,lhs,)
-compile(interpreter/Interpreter,lhs,if_ghc(-fvia-C -fhaskell-1.3))
-compile(interpreter/MkInterface,lhs,)
-compile(interpreter/GHCIMonad,lhs,if_ghc(-fvia-C -fhaskell-1.3))
-compile(interpreter/FullEnv,lhs,if_ghc(-fhaskell-1.3))
-compile(interpreter/Command,lhs,)
-compile(interpreter/GHCIFlags,lhs,)
-compile(interpreter/GHCInterface,lhs,-H40m if_ghc(-fhaskell-1.3))
-compile(interpreter/GHCI,lhs,if_ghc(-fhaskell-1.3))
-compile(interpreter/GHCICore,lhs,if_ghc(-fhaskell-1.3))
-
-# Just using standard macro doesn't use the #include then compiling the
-# .hc file.
-
-HaskellCompileWithExtraFlags(interpreter/Dld,lhs,hc,-fvia-C -C -fhaskell-1.3,)
-HaskellCompileWithExtraFlags_Recursive(interpreter/Dld,hc,o,-c,'-#include"$(DLD_INCLUDE)"')
-
-# (There's gotta be a cleaner way of doing this but only one person in
-#  the entire world understands Jmakefiles well enough to use them
-#  effectively.)
-
-# some c-as-asm level hacks
-# also needs a hand-hacked interface file
-interpreter/DldHacks.o:	interpreter/DldHacks.lhc
-	$(RM) interpreter/DldHacks.hc interpreter/DldHacks.o
-	lit2pgm interpreter/DldHacks.lhc
-	$(GHC) -c $(GHC_FLAGS) interpreter/DldHacks.hc
-
-interpreter/DldC.o:	interpreter/DldC.lc
-	$(RM) interpreter/DldC.c interpreter/DldC.o
-	lit2pgm interpreter/DldC.lc
- 	$(GHC) -c $(GHC_FLAGS) interpreter/DldC.c -I$(DLD_DIR) -optcO-DNON_POSIX_SOURCE
-
-/* Does not work for a subdir ... (Sigh) 
-NormalLibraryTarget($(DLD_DIR)/libdld,$(DLD_OBJS_O))
-*/
-all :: dld/libdld.a
-clean ::
-        $(RM) dld/libdld.a
-dld/libdld.a :: $(DLD_OBJS_O)
-        $(RM) $@
-        $(AR) $@ $(DLD_OBJS_O)
-        $(RANLIB) $@
-
-# To improve loading speed, we generate some C programs which contain
-# references to all symbols in the libraries we link with.
-
-# ToDo: remove the appel dependency.
-
-MY_TOP = ..
-MY_LIB = $(MY_TOP)/lib
-MY_RTS = $(MY_TOP)/runtime
-
-interpreter/prelude.o: $(MY_LIB)/libHS.a makeSymbolList.prl
-	$(RM) interpreter/prelude.c interpreter/prelude.o
-	nm -p $(MY_LIB)/libHS.a | perl makeSymbolList.prl > interpreter/prelude.c
-	$(GHC) -c $(GHC_FLAGS) interpreter/prelude.c
-
-interpreter/runtime.o: $(MY_RTS)/libHSrts.a $(MY_RTS)/libHSclib.a makeSymbolList.prl
-	$(RM) interpreter/runtime.c interpreter/runtime.o
-	nm -p $(MY_RTS)/libHSrts.a $(MY_RTS)/libHSclib.a | perl makeSymbolList.prl > interpreter/runtime.c
-	$(GHC) -c $(GHC_FLAGS) interpreter/runtime.c
-
-#endif /* GHCI */
+compile(utils/MatchEnv,lhs,)
+compile(utils/Util,lhs,)
 
 /* for convenience in cross-compiling */
 objs:: $(ALLOBJS)
@@ -1131,121 +785,69 @@ objs:: $(ALLOBJS)
 /* *** parser ************************************************* */
 
 YACC_OPTS = -d
-CC_OPTS = -IyaccParser -I. -I$(COMPINFO_DIR)
+CC_OPTS = -Iparser -I. -I$(COMPINFO_DIR) -DUGEN_DEBUG=1 /*-DHSP_DEBUG=1*/ -g
 
 /* add to these on the command line with, e.g., EXTRA_YACC_OPTS=-v */
 
-#if BuildDataParallelHaskell == YES
-D_DPH = -DDPH
-#endif
-
 XCOMM D_DEBUG = -DDEBUG
 
-CPP_DEFINES = $(D_DEBUG) $(D_DPH)
-
-HSP_SRCS_C = /* yaccParser/main.c */ 		\
-		yaccParser/atype.c		\
-		yaccParser/binding.c		\
-		yaccParser/coresyn.c		\
-		yaccParser/entidt.c		\
-		yaccParser/finfot.c		\
-		yaccParser/hpragma.c		\
-		yaccParser/hslexer.c		\
-		yaccParser/hsparser.tab.c	\
-		yaccParser/id.c			\
-		yaccParser/import_dirlist.c	\
-		yaccParser/infix.c		\
-		yaccParser/list.c		\
-		yaccParser/literal.c		\
-		yaccParser/pbinding.c		\
-		/* yaccParser/printtree.c */	\
-		yaccParser/syntax.c		\
-		yaccParser/tree.c		\
-		yaccParser/ttype.c		\
-		yaccParser/type2context.c	\
-		yaccParser/util.c
-
-HSP_OBJS_O = /* yaccParser/main.o */ 		\
-		yaccParser/atype.o		\
-		yaccParser/binding.o		\
-		yaccParser/coresyn.o		\
-		yaccParser/entidt.o		\
-		yaccParser/finfot.o		\
-		yaccParser/hpragma.o		\
-		yaccParser/hslexer.o		\
-		yaccParser/hsparser.tab.o	\
-		yaccParser/id.o			\
-		yaccParser/import_dirlist.o	\
-		yaccParser/infix.o		\
-		yaccParser/list.o		\
-		yaccParser/literal.o		\
-		yaccParser/pbinding.o		\
-		/* yaccParser/printtree.o */	\
-		yaccParser/syntax.o		\
-		yaccParser/tree.o		\
-		yaccParser/ttype.o		\
-		yaccParser/type2context.o	\
-		yaccParser/util.o
-
-/* DPH uses some tweaked files; here are the lists again... */
-
-#if BuildDataParallelHaskell == YES
-DPH_HSP_SRCS_C = yaccParser/atype.c		\
-		yaccParser/binding.c		\
-		yaccParser/coresyn.c		\
-		yaccParser/entidt.c		\
-		yaccParser/finfot.c		\
-		yaccParser/hpragma.c		\
-		yaccParser/hslexer-DPH.c	\
-		yaccParser/hsparser-DPH.tab.c	\
-		yaccParser/id.c			\
-		yaccParser/import_dirlist.c	\
-		yaccParser/infix.c		\
-		yaccParser/list.c		\
-		yaccParser/literal.c		\
-		yaccParser/main.c		\
-		yaccParser/pbinding.c		\
-		yaccParser/printtree.c		\
-		yaccParser/syntax.c		\
-		yaccParser/tree-DPH.c		\
-		yaccParser/ttype-DPH.c		\
-		yaccParser/type2context.c	\
-		yaccParser/util.c
-
-DPH_HSP_OBJS_O = yaccParser/atype.o		\
-		yaccParser/binding.o		\
-		yaccParser/coresyn.o		\
-		yaccParser/entidt.o		\
-		yaccParser/finfot.o		\
-		yaccParser/hpragma.o		\
-		yaccParser/hslexer-DPH.o	\
-		yaccParser/hsparser-DPH.tab.o	\
-		yaccParser/id.o			\
-		yaccParser/import_dirlist.o	\
-		yaccParser/infix.o		\
-		yaccParser/list.o		\
-		yaccParser/literal.o		\
-		yaccParser/main.o		\
-		yaccParser/pbinding.o		\
-		yaccParser/printtree.o		\
-		yaccParser/syntax.o		\
-		yaccParser/tree-DPH.o		\
-		yaccParser/ttype-DPH.o		\
-		yaccParser/type2context.o	\
-		yaccParser/util.o
-#endif
+CPP_DEFINES = $(D_DEBUG)
+
+HSP_SRCS_C =    parser/constr.c		\
+		parser/binding.c	\
+		parser/pbinding.c	\
+		parser/coresyn.c	\
+		parser/entidt.c		\
+		parser/hpragma.c	\
+		parser/hslexer.c	\
+		parser/hsparser.tab.c	\
+		parser/id.c		\
+		parser/import_dirlist.c	\
+		parser/infix.c		\
+		parser/list.c		\
+		parser/literal.c	\
+		parser/maybe.c		\
+		parser/either.c		\
+		parser/qid.c		\
+		parser/syntax.c		\
+		parser/tree.c		\
+		parser/ttype.c		\
+		parser/type2context.c	\
+		parser/util.c
+
+HSP_OBJS_O =    parser/constr.o		\
+		parser/binding.o	\
+		parser/pbinding.o	\
+		parser/coresyn.o	\
+		parser/entidt.o		\
+		parser/hpragma.o	\
+		parser/hslexer.o	\
+		parser/hsparser.tab.o	\
+		parser/id.o		\
+		parser/import_dirlist.o	\
+		parser/infix.o		\
+		parser/list.o		\
+		parser/literal.o	\
+		parser/maybe.o		\
+		parser/either.o		\
+		parser/qid.o		\
+		parser/syntax.o		\
+		parser/tree.o		\
+		parser/ttype.o		\
+		parser/type2context.o	\
+		parser/util.o
 
 /* this is for etags */
-REAL_HSP_SRCS_C = yaccParser/main.c 		\
-		yaccParser/hschooks.c		\
-		yaccParser/hsclink.c		\
-		yaccParser/id.c 		\
-		yaccParser/util.c 		\
-		yaccParser/syntax.c 		\
-		yaccParser/type2context.c 	\
-		yaccParser/import_dirlist.c 	\
-		yaccParser/infix.c 		\
-		yaccParser/printtree.c 
+REAL_HSP_SRCS_C = parser/main.c 	\
+		parser/hschooks.c	\
+		parser/hsclink.c	\
+		parser/id.c 		\
+		parser/util.c 		\
+		parser/syntax.c 	\
+		parser/type2context.c 	\
+		parser/import_dirlist.c \
+		parser/infix.c 		\
+		parser/printtree.c
 
 UgenNeededHere(all depend)
 
@@ -1256,65 +858,64 @@ UgenNeededHere(all depend)
 NormalLibraryTarget(hsp,$(HSP_OBJS_O))
 
 /* We need the hsp program for hstags to work! */
-BuildPgmFromCFiles(hsp,yaccParser/printtree.o yaccParser/main.o,,libhsp.a)
-#if BuildDataParallelHaskell == YES
-BuildPgmFromCFiles(dphsp,$(DPH_HSP_OBJS_O),,)
-#endif
+BuildPgmFromCFiles(hsp,parser/printtree.o parser/main.o,,libhsp.a)
 
 #if DoInstallGHCSystem == YES
 MakeDirectories(install, $(INSTLIBDIR_GHC))
 InstallBinaryTarget(hsp,$(INSTLIBDIR_GHC))
-# if BuildDataParallelHaskell == YES
-InstallBinaryTarget(dphsp,$(INSTLIBDIR_GHC))
-# endif
 #endif /* DoInstall... */
 
-YaccRunWithExpectMsg(yaccParser/hsparser,12,2)
-
-UgenTarget(yaccParser/atype)
-UgenTarget(yaccParser/binding)
-UgenTarget(yaccParser/coresyn)
-UgenTarget(yaccParser/entidt)
-UgenTarget(yaccParser/finfot)
-UgenTarget(yaccParser/literal)
-UgenTarget(yaccParser/list)
-UgenTarget(yaccParser/pbinding)
-UgenTarget(yaccParser/hpragma)
-UgenTarget(yaccParser/tree)
-UgenTarget(yaccParser/ttype)
-
-#if BuildDataParallelHaskell == YES
-YaccRunWithExpectMsg(yaccParser/hsparser-DPH,12,4)
-UgenTarget(yaccParser/tree-DPH)
-UgenTarget(yaccParser/ttype-DPH)
-#endif
-
-UGENS_C = yaccParser/atype.c	\
-	yaccParser/binding.c	\
-	yaccParser/coresyn.c	\
-	yaccParser/entidt.c	\
-	yaccParser/finfot.c	\
-	yaccParser/literal.c	\
-	yaccParser/list.c	\
-	yaccParser/pbinding.c	\
-	yaccParser/hpragma.c	\
-	yaccParser/tree.c	\
-	yaccParser/ttype.c
-
-compile(yaccParser/UgenAll,lhs,if_ghc(-fvia-C))
-compile(yaccParser/UgenUtil,lhs,if_ghc(-fvia-C -I$(COMPINFO_DIR) -IyaccParser '-#include"hspincl.h"'))
-compile(yaccParser/U_atype,hs,if_ghc(-fvia-C -I$(COMPINFO_DIR) -IyaccParser '-#include"hspincl.h"'))
-compile(yaccParser/U_binding,hs,-H20m if_ghc(-fvia-C -I$(COMPINFO_DIR) -IyaccParser '-#include"hspincl.h"'))
-compile(yaccParser/U_coresyn,hs,-H20m if_ghc(-fvia-C -I$(COMPINFO_DIR) -IyaccParser '-#include"hspincl.h"'))
-compile(yaccParser/U_entidt,hs,if_ghc(-fvia-C -I$(COMPINFO_DIR) -IyaccParser '-#include"hspincl.h"'))
-compile(yaccParser/U_finfot,hs,if_ghc(-fvia-C -I$(COMPINFO_DIR) -IyaccParser '-#include"hspincl.h"'))
-compile(yaccParser/U_hpragma,hs,if_ghc(-fvia-C -I$(COMPINFO_DIR) -IyaccParser '-#include"hspincl.h"'))
-compile(yaccParser/U_list,hs,if_ghc(-fvia-C -I$(COMPINFO_DIR) -IyaccParser '-#include"hspincl.h"'))
-compile(yaccParser/U_literal,hs,if_ghc(-fvia-C -I$(COMPINFO_DIR) -IyaccParser '-#include"hspincl.h"'))
-compile(yaccParser/U_pbinding,hs,if_ghc(-fvia-C -I$(COMPINFO_DIR) -IyaccParser '-#include"hspincl.h"'))
-compile(yaccParser/U_tree,hs,if_ghc(-fvia-C -I$(COMPINFO_DIR) -IyaccParser '-#include"hspincl.h"'))
-compile(yaccParser/U_treeHACK,hs,if_ghc(-fvia-C -I$(COMPINFO_DIR) -IyaccParser '-#include"hspincl.h"'))
-compile(yaccParser/U_ttype,hs,if_ghc(-fvia-C -I$(COMPINFO_DIR) -IyaccParser '-#include"hspincl.h"'))
+YaccRunWithExpectMsg(parser/hsparser,16,0)
+
+UgenTarget(parser/constr)
+UgenTarget(parser/binding)
+UgenTarget(parser/pbinding)
+UgenTarget(parser/coresyn)
+UgenTarget(parser/entidt)
+UgenTarget(parser/hpragma)
+UgenTarget(parser/list)
+UgenTarget(parser/literal)
+UgenTarget(parser/maybe)
+UgenTarget(parser/either)
+UgenTarget(parser/qid)
+UgenTarget(parser/tree)
+UgenTarget(parser/ttype)
+
+UGENS_C = parser/constr.c	\
+	parser/binding.c	\
+	parser/pbinding.c	\
+	parser/coresyn.c	\
+	parser/entidt.c		\
+	parser/literal.c	\
+	parser/list.c		\
+	parser/maybe.c		\
+	parser/either.c		\
+	parser/qid.c		\
+	parser/hpragma.c	\
+	parser/tree.c		\
+	parser/ttype.c
+
+/* Putting the -#include"hspincl.h" option into the
+   PARSER_HS_OPTS line really does not work (it depends
+   on the 'make' that you use).
+*/
+PARSER_HS_OPTS = if_ghc(-fvia-C -I$(COMPINFO_DIR) -Iparser)
+
+compile(parser/UgenAll,lhs,if_ghc(-fvia-C))
+compile(parser/UgenUtil,lhs,$(PARSER_HS_OPTS) '-#include"hspincl.h"')
+compile(parser/U_constr,hs,$(PARSER_HS_OPTS) '-#include"hspincl.h"')
+compile(parser/U_binding,hs,$(PARSER_HS_OPTS) '-#include"hspincl.h"')
+compile(parser/U_pbinding,hs,$(PARSER_HS_OPTS) '-#include"hspincl.h"')
+compile(parser/U_coresyn,hs,$(PARSER_HS_OPTS) '-#include"hspincl.h"')
+compile(parser/U_entidt,hs,$(PARSER_HS_OPTS) '-#include"hspincl.h"')
+compile(parser/U_hpragma,hs,$(PARSER_HS_OPTS) '-#include"hspincl.h"')
+compile(parser/U_list,hs,$(PARSER_HS_OPTS) '-#include"hspincl.h"')
+compile(parser/U_literal,hs,$(PARSER_HS_OPTS) '-#include"hspincl.h"')
+compile(parser/U_maybe,hs,$(PARSER_HS_OPTS) '-#include"hspincl.h"')
+compile(parser/U_either,hs,$(PARSER_HS_OPTS) '-#include"hspincl.h"')
+compile(parser/U_qid,hs,$(PARSER_HS_OPTS) '-#include"hspincl.h"')
+compile(parser/U_tree,hs,$(PARSER_HS_OPTS) '-#include"hspincl.h"')
+compile(parser/U_ttype,hs,$(PARSER_HS_OPTS) '-#include"hspincl.h"')
 
 /* finished with local macros */
 #undef compile
@@ -1323,22 +924,12 @@ compile(yaccParser/U_ttype,hs,if_ghc(-fvia-C -I$(COMPINFO_DIR) -IyaccParser '-#i
 
 /* *** misc *************************************************** */
 
-/* ?????????? ToDo: need parser depend/clean/etc in here ????? */
-
-/* omit for now:
-LitDocRootTargetWithNamedOutput(root,lit,root-standalone)
-*/
-/* LitDependTarget(root,lit): built-in to the above */
+DEPSRCS = $(ALLSRCS_LHS) $(ALLSRCS_HS)
 
-/* mkdependHS has to have the -i.../-I... subdirectory lists even if "ghc" does not
-*/
 #if GhcWithHscBuiltViaC == NO
-DEPSRCS	       = $(ALLSRCS_LHS) $(ALLSRCS_HS)
-MKDEPENDHS_OPTS= $(DASH_I_SUBDIR_LIST) -i$(SUBDIR_LIST) -I$(MAIN_INCLUDE_DIR) 
-
-#else /* booting from .hc (no ghci) */
-DEPSRCS	       = $(HSCSRCS_LHS) $(HSCSRCS_HS)
-MKDEPENDHS_OPTS= -o .hc $(DASH_I_SUBDIR_LIST) -i$(SUBDIR_LIST) -I$(MAIN_INCLUDE_DIR) 
+MKDEPENDHS_OPTS= -I$(MAIN_INCLUDE_DIR) -I$(COMPINFO_DIR) -x HsVersions.h
+#else /* booting from .hc */
+MKDEPENDHS_OPTS= -o .hc -I$(MAIN_INCLUDE_DIR) -I$(COMPINFO_DIR)  -x HsVersions.h
 #endif /* booting from .hc files */
 
 #if HaskellCompilerType != HC_USE_HC_FILES
diff --git a/ghc/compiler/absCSyn/AbsCFuns.hi b/ghc/compiler/absCSyn/AbsCFuns.hi
deleted file mode 100644
index 35a044e96f..0000000000
--- a/ghc/compiler/absCSyn/AbsCFuns.hi
+++ /dev/null
@@ -1,30 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface AbsCFuns where
-import AbsCSyn(AbstractC, CAddrMode, CExprMacro, CStmtMacro, MagicId, RegRelative, ReturnInfo)
-import BasicLit(BasicLit)
-import CLabelInfo(CLabel)
-import ClosureInfo(ClosureInfo)
-import CostCentre(CostCentre)
-import HeapOffs(HeapOffset)
-import Maybes(Labda)
-import PreludePS(_PackedString)
-import PrimKind(PrimKind)
-import PrimOps(PrimOp)
-import SplitUniq(SplitUniqSupply)
-import Unique(Unique)
-data AbstractC 
-data CAddrMode 
-data PrimKind 
-data SplitUniqSupply 
-amodeCanSurviveGC :: CAddrMode -> Bool
-flattenAbsC :: SplitUniqSupply -> AbstractC -> AbstractC
-getAmodeKind :: CAddrMode -> PrimKind
-kindFromMagicId :: MagicId -> PrimKind
-mixedPtrLocn :: CAddrMode -> Bool
-mixedTypeLocn :: CAddrMode -> Bool
-mkAbsCStmtList :: AbstractC -> [AbstractC]
-mkAbsCStmts :: AbstractC -> AbstractC -> AbstractC
-mkAbstractCs :: [AbstractC] -> AbstractC
-mkAlgAltsCSwitch :: CAddrMode -> [(Int, AbstractC)] -> AbstractC -> AbstractC
-nonemptyAbsC :: AbstractC -> Labda AbstractC
-
diff --git a/ghc/compiler/absCSyn/AbsCFuns.lhs b/ghc/compiler/absCSyn/AbsCFuns.lhs
deleted file mode 100644
index 2f551346da..0000000000
--- a/ghc/compiler/absCSyn/AbsCFuns.lhs
+++ /dev/null
@@ -1,864 +0,0 @@
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1993-1995
-%
-\section[AbsCFuns]{Help functions for Abstract~C datatype}
-
-\begin{code}
-#include "HsVersions.h"
-
-module AbsCFuns (
-	nonemptyAbsC,
-	mkAbstractCs, mkAbsCStmts,
-	mkAlgAltsCSwitch,
-	kindFromMagicId,
-	getAmodeKind, amodeCanSurviveGC,
-	mixedTypeLocn, mixedPtrLocn,
-	flattenAbsC,
---UNUSED:	getDestinationRegs,
-        mkAbsCStmtList,
-
-	-- printing/forcing stuff comes from PprAbsC
-
-	-- and for interface self-sufficiency...
-	AbstractC, CAddrMode, PrimKind, SplitUniqSupply
-    ) where
-
-import AbsCSyn
-
-import AbsPrel		( PrimOp(..)
-			  IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
-			  IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
-			)
-import AbsUniType	( kindFromType, splitTyArgs, TauType(..),
-			  TyVar, TyCon, Arity(..), Class, UniType
-			  IF_ATTACK_PRAGMAS(COMMA cmpTyCon COMMA cmpClass)
-			  IF_ATTACK_PRAGMAS(COMMA cmpTyVar)
-			  IF_ATTACK_PRAGMAS(COMMA cmpUniType)
-			)
-
-#ifndef DPH
-import CLabelInfo	( CLabel, mkReturnPtLabel, mkVecTblLabel )
-#else
-import CLabelInfo	( CLabel, mkReturnPtLabel, 
-		          isNestableBlockLabel, isSlowFastLabelPair  )
-#endif {- Data Parallel Haskell -}
-
-import BasicLit		( kindOfBasicLit )
-import Digraph		( stronglyConnComp )
-import Id		( fIRST_TAG, ConTag(..), DataCon(..), Id )
-import Maybes		( Maybe(..) )
-import PrimKind		( getKindSize, retKindSize, PrimKind(..) )
-import SplitUniq
-import StgSyn		( StgAtom )
-import Unique		-- UniqueSupply primitives used in flattening monad
-import Util
-
-infixr 9 `thenFlt`
-\end{code}
-
-Check if there is any real code in some Abstract~C.  If so, return it
-(@Just ...@); otherwise, return @Nothing@.  Don't be too strict!
-
-It returns the "reduced" code in the Just part so that the work of
-discarding AbsCNops isn't lost, and so that if the caller uses
-the reduced version there's less danger of a big tree of AbsCNops getting
-materialised and causing a space leak.
-
-\begin{code}
-nonemptyAbsC :: AbstractC -> Maybe AbstractC
-nonemptyAbsC  AbsCNop		= Nothing
---UNUSED:nonemptyAbsC (CComment _)	= Nothing
-nonemptyAbsC (AbsCStmts s1 s2)	= case (nonemptyAbsC s1) of
-				    Nothing -> nonemptyAbsC s2
-				    Just x  -> Just (AbsCStmts x s2)
-nonemptyAbsC s@(CSimultaneous c) = case (nonemptyAbsC c) of
-				    Nothing -> Nothing
-				    Just x  -> Just s
-nonemptyAbsC other		= Just other
-\end{code}
-
-\begin{code}
-mkAbstractCs :: [AbstractC] -> AbstractC
-mkAbstractCs [] = AbsCNop
-mkAbstractCs cs = foldr1 mkAbsCStmts cs
-
--- for fiddling around w/ killing off AbsCNops ... (ToDo)
-mkAbsCStmts :: AbstractC -> AbstractC -> AbstractC
-mkAbsCStmts = AbsCStmts
-
-{- Discarded SLPJ June 95; it calls nonemptyAbsC too much!
-  = BIND (case (nonemptyAbsC abc2) of
-	    Nothing -> AbsCNop
-	    Just d2 -> d2)	_TO_ abc2b ->
-
-    case (nonemptyAbsC abc1) of {
-      Nothing -> abc2b;
-      Just d1 -> AbsCStmts d1 abc2b
-    } BEND
--}
-{-
-  = case (nonemptyAbsC abc1) of
-      Nothing -> abc2
-      Just d1 -> AbsCStmts d1 abc2
--}
-{- old2:
-  = case (nonemptyAbsC abc1) of
-      Nothing -> case (nonemptyAbsC abc2) of
-		   Nothing -> AbsCNop
-		   Just d2 -> d2
-      Just d1 -> AbsCStmts d1 abc2
--}
-{- old:
-    if abc1_empty then
-	if abc2_empty
-	then AbsCNop
-	else abc2
-    else if {- abc1 not empty but -} abc2_empty then
-	abc1
-    else {- neither empty -}
-	AbsCStmts abc1 abc2
-  where
-    abc1_empty = noAbsCcode abc1
-    abc2_empty = noAbsCcode abc2
--}
-\end{code}
-
-Get the sho' 'nuff statements out of an @AbstractC@.
-\begin{code}
-{-
-mkAbsCStmtList :: AbstractC -> [AbstractC]
-
-mkAbsCStmtList  AbsCNop		 = []
---UNUSED:mkAbsCStmtList (CComment _)	 = []
-mkAbsCStmtList (AbsCStmts s1 s2) = mkAbsCStmtList s1 ++ mkAbsCStmtList s2
-mkAbsCStmtList s@(CSimultaneous c) = if null (mkAbsCStmtList c)
-				     then []
-				     else [s]
-mkAbsCStmtList other		 = [other]
--}
-
-mkAbsCStmtList :: AbstractC -> [AbstractC]
-mkAbsCStmtList  absC = mkAbsCStmtList' absC []
-  
--- Optimised a la foldr/build!
-
-mkAbsCStmtList'  AbsCNop          r = r
---UNUSED:mkAbsCStmtList' (CComment _)      r = r
-mkAbsCStmtList' (AbsCStmts s1 s2) r = 
-      mkAbsCStmtList' s1 (mkAbsCStmtList' s2 r)
-mkAbsCStmtList' s@(CSimultaneous c) r = 
-      if null (mkAbsCStmtList c) then r else s : r
-mkAbsCStmtList' other             r = other : r
-
-\end{code}
-
-\begin{code}
-mkAlgAltsCSwitch :: CAddrMode -> [(ConTag, AbstractC)] -> AbstractC -> AbstractC
-
-mkAlgAltsCSwitch scrutinee tagged_alts deflt_absc
- = CSwitch scrutinee (adjust tagged_alts) deflt_absc
- where
-   -- Adjust the tags in the switch to start at zero.
-   -- This is the convention used by primitive ops which return algebraic
-   -- data types.  Why?	 Because for two-constructor types, zero is faster
-   -- to create and distinguish from 1 than are 1 and 2.
-
-   -- We also need to convert to BasicLits to keep the CSwitch happy
-   adjust tagged_alts
-     = [ (MachInt (toInteger (tag - fIRST_TAG)) False{-unsigned-}, abs_c)
-       | (tag, abs_c) <- tagged_alts ]
-\end{code}
-
-%************************************************************************
-%*									*
-\subsubsection[AbsCFuns-kinds-from-MagicIds]{Kinds from MagicIds}
-%*									*
-%************************************************************************
-
-\begin{code}
-kindFromMagicId BaseReg		    = PtrKind
-kindFromMagicId StkOReg		    = PtrKind
-kindFromMagicId (VanillaReg kind _) = kind
-kindFromMagicId (FloatReg _)	    = FloatKind
-kindFromMagicId (DoubleReg _)	    = DoubleKind
-kindFromMagicId TagReg		    = IntKind
-kindFromMagicId RetReg		    = RetKind
-kindFromMagicId SpA		    = PtrKind
-kindFromMagicId SuA		    = PtrKind
-kindFromMagicId SpB		    = PtrKind
-kindFromMagicId SuB		    = PtrKind
-kindFromMagicId Hp		    = PtrKind
-kindFromMagicId HpLim		    = PtrKind
-kindFromMagicId LivenessReg	    = IntKind
---kindFromMagicId ActivityReg	    = IntKind -- UNUSED
-kindFromMagicId StdUpdRetVecReg	    = PtrKind
-kindFromMagicId StkStubReg	    = PtrKind
-kindFromMagicId CurCostCentre	    = CostCentreKind
-kindFromMagicId VoidReg		    = VoidKind
-#ifdef DPH
-kindFromMagicId (DataReg _ n)	    = kind
-#endif {- Data Parallel Haskell -}
-\end{code}
-
-%************************************************************************
-%*									*
-\subsection[AbsCFuns-amode-kinds]{Finding @PrimitiveKinds@ of amodes}
-%*									*
-%************************************************************************
-
-See also the return conventions for unboxed things; currently living
-in @CgCon@ (next to the constructor return conventions).
-
-ToDo: tiny tweaking may be in order
-\begin{code}
-getAmodeKind :: CAddrMode -> PrimKind
-
-getAmodeKind (CVal _ kind)	    	    = kind
-getAmodeKind (CAddr _)		    	    = PtrKind
-getAmodeKind (CReg magic_id)	    	    = kindFromMagicId magic_id
-getAmodeKind (CTemp uniq kind)	    	    = kind
-getAmodeKind (CLbl label kind)	    	    = kind
-getAmodeKind (CUnVecLbl _ _)	    	    = PtrKind
-getAmodeKind (CCharLike _)	    	    = PtrKind
-getAmodeKind (CIntLike _)	    	    = PtrKind
-getAmodeKind (CString _)	    	    = PtrKind
-getAmodeKind (CLit lit)		    	    = kindOfBasicLit lit
-getAmodeKind (CLitLit _ kind)	    	    = kind
-getAmodeKind (COffset _)	    	    = IntKind
-getAmodeKind (CCode abs_C)		    = CodePtrKind
-getAmodeKind (CLabelledCode label abs_C)    = CodePtrKind
-getAmodeKind (CJoinPoint _ _)	    	    = panic "getAmodeKind:CJoinPoint"
-getAmodeKind (CTableEntry _ _ kind)    	    = kind
-getAmodeKind (CMacroExpr kind _ _)    	    = kind
-getAmodeKind (CCostCentre _ _)		    = panic "getAmodeKind:CCostCentre"
-\end{code}
-
-@amodeCanSurviveGC@ tells, well, whether or not the amode is invariant
-across a garbage collection.  Used only for PrimOp arguments (not that
-it matters).
-
-\begin{code}
-amodeCanSurviveGC :: CAddrMode -> Bool
-
-amodeCanSurviveGC (CTableEntry base offset _)
-  = amodeCanSurviveGC base && amodeCanSurviveGC offset
-    -- "Fixed table, so it's OK" (JSM); code is slightly paranoid
-
-amodeCanSurviveGC (CLbl _ _)		= True
-amodeCanSurviveGC (CUnVecLbl _ _)	= True
-amodeCanSurviveGC (CCharLike arg)	= amodeCanSurviveGC arg
-amodeCanSurviveGC (CIntLike arg)	= amodeCanSurviveGC arg
-amodeCanSurviveGC (CString _)		= True
-amodeCanSurviveGC (CLit _)		= True
-amodeCanSurviveGC (CLitLit _ _)		= True
-amodeCanSurviveGC (COffset _)		= True
-amodeCanSurviveGC (CMacroExpr _ _ args)	= all amodeCanSurviveGC args
-
-amodeCanSurviveGC _ = False
-    -- there are some amodes that "cannot occur" as args
-    -- to a PrimOp, but it is safe to return False (rather than panic)
-\end{code}
-
-@mixedTypeLocn@ tells whether an amode identifies an ``StgWord''
-location; that is, one which can contain values of various types.
-
-\begin{code}
-mixedTypeLocn :: CAddrMode -> Bool
-
-mixedTypeLocn (CVal (NodeRel _)   _)	= True
-mixedTypeLocn (CVal (SpBRel _ _)  _)	= True
-mixedTypeLocn (CVal (HpRel _ _)	  _)	= True
-mixedTypeLocn other			= False	-- All the rest
-\end{code}
-
-@mixedPtrLocn@ tells whether an amode identifies a
-location which can contain values of various pointer types.
-
-\begin{code}
-mixedPtrLocn :: CAddrMode -> Bool
-
-mixedPtrLocn (CVal (SpARel _ _)  _)	= True
-mixedPtrLocn other			= False	-- All the rest
-\end{code}
-
-%************************************************************************
-%*									*
-\subsection[AbsCFuns-flattening]{Flatten Abstract~C}
-%*									*
-%************************************************************************
-
-The following bits take ``raw'' Abstract~C, which may have all sorts of
-nesting, and flattens it into one long @AbsCStmtList@.  Mainly,
-@CClosureInfos@ and code for switches are pulled out to the top level.
-
-The various functions herein tend to produce 
-\begin{enumerate}
-\item
-A {\em flattened} \tr{<something>} of interest for ``here'', and 
-\item
-Some {\em unflattened} Abstract~C statements to be carried up to the
-top-level.  The only real reason (now) that it is unflattened is
-because it means the recursive flattening can be done in just one
-place rather than having to remember lots of places.
-\end{enumerate}
-
-Care is taken to reduce the occurrence of forward references, while still
-keeping laziness a much as possible.  Essentially, this means that:
-\begin{itemize}
-\item
-{\em All} the top-level C statements resulting from flattening a
-particular AbsC statement (whether the latter is nested or not) appear
-before {\em any} of the code for a subsequent AbsC statement;
-\item
-but stuff nested within any AbsC statement comes
-out before the code for the statement itself.
-\end{itemize}
-
-The ``stuff to be carried up'' always includes a label: a
-@CStaticClosure@, @CClosureUpdInfo@, @CRetUnVector@, @CFlatRetVector@, or
-@CCodeBlock@.  The latter turns into a C function, and is never
-actually produced by the code generator.  Rather it always starts life
-as a @CLabelledCode@ addressing mode; when such an addr mode is
-flattened, the ``tops'' stuff is a @CCodeBlock@.
-
-\begin{code}
-flattenAbsC :: SplitUniqSupply -> AbstractC -> AbstractC
-
-flattenAbsC us abs_C
-  = case (initFlt us (flatAbsC abs_C)) of { (here, tops) ->
-    here `mkAbsCStmts` tops }
-\end{code}
-
-%************************************************************************
-%*									*
-\subsubsection{Flattening monadery}
-%*									*
-%************************************************************************
-
-The flattener is monadised.  It's just a @UniqueSupply@, along with a
-``come-back-to-here'' label to pin on heap and stack checks.
-
-\begin{code}
-type FlatM result
-     = CLabel
-    -> SplitUniqSupply
-    -> result
-
-initFlt :: SplitUniqSupply -> FlatM a -> a
-
-initFlt init_us m = m (panic "initFlt:CLabel") init_us
-
-#ifdef __GLASGOW_HASKELL__
-{-# INLINE thenFlt #-}
-{-# INLINE returnFlt #-}
-#endif
-
-thenFlt :: FlatM a -> (a -> FlatM b) -> FlatM b
-
-thenFlt expr cont label us
-  = case (splitUniqSupply us)   of { (s1, s2) ->
-    case (expr label s1)    	of { result ->
-    cont result label s2 }}
-
-returnFlt :: a -> FlatM a
-returnFlt result label us = result
-
-mapFlt :: (a -> FlatM b) -> [a] -> FlatM [b]
-
-mapFlt f []     = returnFlt []
-mapFlt f (x:xs)
-  = f x         `thenFlt` \ r  ->
-    mapFlt f xs `thenFlt` \ rs ->
-    returnFlt (r:rs)
-
-mapAndUnzipFlt  :: (a -> FlatM (b,c))   -> [a] -> FlatM ([b],[c])
-
-mapAndUnzipFlt f [] = returnFlt ([],[])
-mapAndUnzipFlt f (x:xs)
-  = f x		    	`thenFlt` \ (r1,  r2)  ->
-    mapAndUnzipFlt f xs	`thenFlt` \ (rs1, rs2) ->
-    returnFlt (r1:rs1, r2:rs2)
-
-getUniqFlt :: FlatM Unique
-getUniqFlt label us = getSUnique us
-
-getUniqsFlt :: Int -> FlatM [Unique]
-getUniqsFlt i label us = getSUniques i us
-
-setLabelFlt :: CLabel -> FlatM a -> FlatM a
-setLabelFlt new_label cont label us = cont new_label us
-
-getLabelFlt :: FlatM CLabel
-getLabelFlt label us = label
-\end{code}
-
-%************************************************************************
-%*									*
-\subsubsection{Flattening the top level}
-%*									*
-%************************************************************************
-
-\begin{code}
-flatAbsC :: AbstractC
-	 -> FlatM (AbstractC,		-- Stuff to put inline		[Both are fully
-		   AbstractC)		-- Stuff to put at top level	 flattened]
-
-flatAbsC AbsCNop = returnFlt (AbsCNop, AbsCNop)
-
-flatAbsC (AbsCStmts s1 s2)
-  = flatAbsC s1	`thenFlt` \ (inline_s1, top_s1) ->
-    flatAbsC s2	`thenFlt` \ (inline_s2, top_s2) ->
-    returnFlt (mkAbsCStmts inline_s1 inline_s2,
-	       mkAbsCStmts top_s1    top_s2)
-
-flatAbsC (CClosureInfoAndCode cl_info slow maybe_fast upd descr liveness)
-  = flatAbsC slow		`thenFlt` \ (slow_heres, slow_tops) ->
-    flat_maybe maybe_fast	`thenFlt` \ (fast_heres, fast_tops) ->
-    flatAmode upd               `thenFlt` \ (upd_lbl,    upd_tops) ->
-    returnFlt (AbsCNop, mkAbstractCs [slow_tops, fast_tops, upd_tops,
-       CClosureInfoAndCode cl_info slow_heres fast_heres upd_lbl descr liveness]
-    )
-  where
-    flat_maybe :: Maybe AbstractC -> FlatM (Maybe AbstractC, AbstractC)
-    flat_maybe Nothing      = returnFlt (Nothing, AbsCNop)
-    flat_maybe (Just abs_c) = flatAbsC abs_c `thenFlt` \ (heres, tops) ->
-			      returnFlt (Just heres, tops)
-
-flatAbsC (CCodeBlock label abs_C)
-  = flatAbsC abs_C	    `thenFlt` \ (absC_heres, absC_tops) ->
-    returnFlt (AbsCNop, absC_tops `mkAbsCStmts` CCodeBlock label absC_heres)
-
-flatAbsC (CClosureUpdInfo info) = flatAbsC info
-
-flatAbsC (CStaticClosure closure_lbl closure_info cost_centre amodes)
-  = flatAmodes (cost_centre:amodes)	`thenFlt` \ (new_cc:new_amodes, tops) ->
-    returnFlt (AbsCNop, tops `mkAbsCStmts` 
-		        CStaticClosure closure_lbl closure_info new_cc new_amodes)
-
-flatAbsC (CRetVector tbl_label stuff deflt)
-  = do_deflt deflt				`thenFlt` \ (deflt_amode, deflt_tops) ->
-    mapAndUnzipFlt (do_alt deflt_amode) stuff	`thenFlt` \ (alt_amodes, alt_tops) ->
-    returnFlt (AbsCNop, mkAbstractCs [deflt_tops, 
-				      mkAbstractCs alt_tops, 
-				      CFlatRetVector tbl_label alt_amodes])
-
-  where
-    do_deflt deflt = case nonemptyAbsC deflt of
-			Nothing     -> returnFlt (bogus_default_label, AbsCNop)
-			Just deflt' -> flatAmode (CCode deflt)	-- Deals correctly with the 
-								-- CJump (CLabelledCode ...) case
-
-    do_alt deflt_amode Nothing    = returnFlt (deflt_amode, AbsCNop)
-    do_alt deflt_amode (Just alt) = flatAmode alt
-
-    bogus_default_label = panic "flatAbsC: CRetVector: default needed and not available"
-
-
-flatAbsC (CRetUnVector label amode)
-  = flatAmode amode	`thenFlt` \ (new_amode, tops) ->
-    returnFlt (AbsCNop, tops `mkAbsCStmts` CRetUnVector label new_amode)
-
-flatAbsC (CFlatRetVector label amodes)
-  = flatAmodes amodes	`thenFlt` \ (new_amodes, tops) ->
-    returnFlt (AbsCNop, tops `mkAbsCStmts` CFlatRetVector label new_amodes)
-
-flatAbsC cc@(CCostCentreDecl _ _)  -- at top, already flat
-  = returnFlt (AbsCNop, cc)
-
--- now the real stmts:
-
-flatAbsC (CAssign dest source)
-  = flatAmode dest    `thenFlt` \ (dest_amode, dest_tops) ->
-    flatAmode source  `thenFlt` \ (src_amode,  src_tops)  ->
-    returnFlt ( CAssign dest_amode src_amode, mkAbsCStmts dest_tops src_tops )
-
--- special case: jump to some anonymous code
-flatAbsC (CJump (CCode abs_C)) = flatAbsC abs_C
-
-flatAbsC (CJump target)
-  = flatAmode target `thenFlt` \ (targ_amode, targ_tops) ->
-    returnFlt ( CJump targ_amode, targ_tops )
-
-flatAbsC (CFallThrough target)
-  = flatAmode target `thenFlt` \ (targ_amode, targ_tops) ->
-    returnFlt ( CFallThrough targ_amode, targ_tops )
-
-flatAbsC (CReturn target return_info)
-  = flatAmode target `thenFlt` \ (targ_amode, targ_tops) ->
-    returnFlt ( CReturn targ_amode return_info, targ_tops )
-
-flatAbsC (CSwitch discrim alts deflt)
-  = flatAmode discrim		 `thenFlt` \ (discrim_amode, discrim_tops) ->
-    mapAndUnzipFlt flat_alt alts `thenFlt` \ (flat_alts, flat_alts_tops) ->
-    flatAbsC deflt		 `thenFlt` \ (flat_def_alt, def_tops) ->
-    returnFlt (
-      CSwitch discrim_amode flat_alts flat_def_alt,
-      mkAbstractCs (discrim_tops : def_tops : flat_alts_tops)
-    )
-  where
-    flat_alt (tag, absC)
-      = flatAbsC absC	`thenFlt` \ (alt_heres, alt_tops) ->
-	returnFlt ( (tag, alt_heres), alt_tops )
-
-flatAbsC stmt@(CInitHdr a b cc u)
-  = flatAmode cc	`thenFlt` \ (new_cc, tops) ->
-    returnFlt (CInitHdr a b new_cc u, tops)
-
-flatAbsC stmt@(COpStmt results op args liveness_mask vol_regs)
-  = flatAmodes results		`thenFlt` \ (results_here, tops1) ->
-    flatAmodes args		`thenFlt` \ (args_here,    tops2) ->
-    returnFlt (COpStmt results_here op args_here liveness_mask vol_regs,
-		mkAbsCStmts tops1 tops2)
-
-flatAbsC stmt@(CSimultaneous abs_c)
-  = flatAbsC abs_c		`thenFlt` \ (stmts_here, tops) ->
-    doSimultaneously stmts_here	`thenFlt` \ new_stmts_here ->
-    returnFlt (new_stmts_here, tops)
-
-flatAbsC stmt@(CMacroStmt macro amodes)
-  = flatAmodes amodes		`thenFlt` \ (amodes_here, tops) ->
-    returnFlt (CMacroStmt macro amodes_here, tops)
-
-flatAbsC stmt@(CCallProfCtrMacro str amodes)
-  = flatAmodes amodes		`thenFlt` \ (amodes_here, tops) ->
-    returnFlt (CCallProfCtrMacro str amodes_here, tops)
-
-flatAbsC stmt@(CCallProfCCMacro str amodes)
-  = flatAmodes amodes		`thenFlt` \ (amodes_here, tops) ->
-    returnFlt (CCallProfCCMacro str amodes_here, tops)
-
---UNUSED:flatAbsC comment_stmt@(CComment comment) = returnFlt (AbsCNop, AbsCNop)
-
-flatAbsC stmt@(CSplitMarker) = returnFlt (AbsCNop, stmt)
-
-#ifdef DPH
-    -- Hack since 0.16 because Direct entry code blocks can be nested
-    -- within other Direct entry blocks...
-    flatAbsC (CNativeInfoTableAndCode cinfo descr 
-                     (CCodeBlock slow_label 
-		        (AbsCStmts slow_abs_c
-		           (CCodeBlock fast_label fast_abs_c))))
-      | isSlowFastLabelPair slow_label fast_label
-      = flatAbsC slow_abs_c	    `thenFlt` \ (slow_here, slow_top) ->
-        flatAbsC fast_abs_c	    `thenFlt` \ (fast_here, fast_top) ->
-        returnFlt (CNativeInfoTableAndCode cinfo descr 	
-		     (CCodeBlock slow_label
-		       (AbsCStmts slow_here
-		          (CCodeBlock fast_label fast_here))), 
-		     mkAbsCStmts slow_top fast_top)
-
-    flatAbsC (CNativeInfoTableAndCode cinfo descr abs_C)
-      = flatAbsC abs_C	    `thenFlt` \ (heres, tops) ->
-        returnFlt (CNativeInfoTableAndCode cinfo descr heres, tops)
-#endif {- Data Parallel Haskell -}
-
---flatAbsC stmt = panic ("flatAbsC: funny statement " ++ printRealC (\x->False) stmt)
-\end{code}
-
-%************************************************************************
-%*									*
-\subsection[flat-amodes]{Flattening addressing modes}
-%*									*
-%************************************************************************
-
-\begin{code}
-flatAmode :: CAddrMode -> FlatM (CAddrMode, AbstractC)
-
--- easy ones first
-flatAmode amode@(CVal _ _)	= returnFlt (amode, AbsCNop)
-
-flatAmode amode@(CAddr _)	= returnFlt (amode, AbsCNop)
-flatAmode amode@(CReg _)	= returnFlt (amode, AbsCNop)
-flatAmode amode@(CTemp _ _)	= returnFlt (amode, AbsCNop)
-flatAmode amode@(CLbl _ _)	= returnFlt (amode, AbsCNop)
-flatAmode amode@(CUnVecLbl _ _)	= returnFlt (amode, AbsCNop)
-flatAmode amode@(CString _)	= returnFlt (amode, AbsCNop)
-flatAmode amode@(CLit _)	= returnFlt (amode, AbsCNop)
-flatAmode amode@(CLitLit _ _)	= returnFlt (amode, AbsCNop)
-flatAmode amode@(COffset _)	= returnFlt (amode, AbsCNop)
-
--- CIntLike must be a literal -- no flattening
-flatAmode amode@(CIntLike int)  = returnFlt(amode, AbsCNop)
-
--- CCharLike may be arbitrary value -- have to flatten
-flatAmode amode@(CCharLike char)
-  = flatAmode char	`thenFlt` \ (flat_char, tops) ->
-    returnFlt(CCharLike flat_char, tops)
-
-flatAmode (CJoinPoint _ _) = panic "flatAmode:CJoinPoint"
-
-flatAmode (CLabelledCode label abs_C)
-  -- Push the code (with this label) to the top level
-  = flatAbsC abs_C	`thenFlt` \ (body_code, tops) ->
-    returnFlt (CLbl label CodePtrKind,	
-	       tops `mkAbsCStmts` CCodeBlock label body_code)
-
-flatAmode (CCode abs_C)
-  = case mkAbsCStmtList abs_C of
-      [CJump amode] -> flatAmode amode	-- Elide redundant labels
-      _ ->
-	-- de-anonymous-ise the code and push it (labelled) to the top level
-        getUniqFlt 		`thenFlt` \ new_uniq ->
-	BIND (mkReturnPtLabel new_uniq)    _TO_ return_pt_label ->
-	flatAbsC abs_C	`thenFlt` \ (body_code, tops) ->
-	returnFlt (
-	    CLbl return_pt_label CodePtrKind,
-	    tops `mkAbsCStmts` CCodeBlock return_pt_label body_code
-	    -- DO NOT TOUCH the stuff sent to the top...
-	)
-	BEND
-  
-flatAmode (CTableEntry base index kind)
-  = flatAmode base    	`thenFlt` \ (base_amode, base_tops) ->
-    flatAmode index 	`thenFlt` \ (ix_amode,  ix_tops)  ->
-    returnFlt ( CTableEntry base_amode ix_amode kind, mkAbsCStmts base_tops ix_tops )
-
-flatAmode (CMacroExpr pk macro amodes)
-  = flatAmodes amodes    	`thenFlt` \ (amodes_here, tops) ->
-    returnFlt ( CMacroExpr pk macro amodes_here, tops )
-
-flatAmode amode@(CCostCentre _ _) = returnFlt (amode, AbsCNop)
-\end{code}
-
-And a convenient way to do a whole bunch of 'em.
-\begin{code}
-flatAmodes :: [CAddrMode] -> FlatM ([CAddrMode], AbstractC)
-
-flatAmodes [] = returnFlt ([], AbsCNop)
-
-flatAmodes amodes
-  = mapAndUnzipFlt flatAmode amodes `thenFlt` \ (amodes_here, tops) ->
-    returnFlt (amodes_here, mkAbstractCs tops)
-\end{code}
-
-%************************************************************************
-%*									*
-\subsection[flat-simultaneous]{Doing things simultaneously}
-%*									*
-%************************************************************************
-
-\begin{code}
-doSimultaneously :: AbstractC -> FlatM AbstractC
-\end{code}
-
-Generate code to perform the @CAssign@s and @COpStmt@s in the
-input simultaneously, using temporary variables when necessary.
-
-We use the strongly-connected component algorithm, in which
-	* the vertices are the statements
-	* an edge goes from s1 to s2 iff 
-		s1 assigns to something s2 uses
-	  that is, if s1 should *follow* s2 in the final order
-
-ADR Comment
-
-Wow - fancy stuff.  But are we ever going to do anything other than
-assignments in parallel?  If not, wouldn't it be simpler to generate
-the following:
-
- x1, x2, x3 = e1, e2, e3
-
-    |
-    |
-    V
- { int t1 = e1;
-   int t2 = e2;
-   int t3 = e3;
-   x1 = t1;
-   x2 = t2;
-   x3 = t3;
- }
-
-and leave it to the C compiler to figure out whether it needs al
-those variables.
-
-(Likewise, why not let the C compiler delete silly code like
-
-    x = x
-
-for us?)
-
-tnemmoC RDA
-
-\begin{code}
-type CVertex = (Int, AbstractC)  -- Give each vertex a unique number,
-				 -- for fast comparison
-
-type CEdge = (CVertex, CVertex)
-
-doSimultaneously abs_c
-  = let
-	enlisted = en_list abs_c
-    in
-    case enlisted of -- it's often just one stmt
-      []  -> returnFlt AbsCNop
-      [x] -> returnFlt x
-      _   -> doSimultaneously1 (zip [(1::Int)..] enlisted)
-
--- en_list puts all the assignments in a list, filtering out Nops and
--- assignments which do nothing
-en_list AbsCNop				      = []
-en_list (AbsCStmts a1 a2)		      = en_list a1 ++ en_list a2
-en_list (CAssign am1 am2) | sameAmode am1 am2 = []
-en_list other				      = [other]
-
-sameAmode :: CAddrMode -> CAddrMode -> Bool
--- ToDo: Move this function, or make CAddrMode an instance of Eq
--- At the moment we put in just enough to catch the cases we want:
--- 	the second (destination) argument is always a CVal.
-sameAmode (CReg r1)		     (CReg r2)		     = r1 == r2
-sameAmode (CVal (SpARel r1 v1) _) (CVal (SpARel r2 v2) _) = r1 == r2 && v1 == v2
-sameAmode (CVal (SpBRel r1 v1) _) (CVal (SpBRel r2 v2) _) = r1 == r2 && v1 == v2
-sameAmode other1		     other2		     = False
-
-doSimultaneously1 :: [CVertex] -> FlatM AbstractC
-doSimultaneously1 vertices
-  = let
-	edges :: [CEdge]
-	edges = concat (map edges_from vertices)
-
-	edges_from :: CVertex -> [CEdge]
-	edges_from v1 = [(v1,v2) | v2 <- vertices, v1 `should_follow` v2]
-
-	should_follow :: CVertex -> CVertex -> Bool
-	(n1, CAssign dest1 _) `should_follow` (n2, CAssign _ src2)
-	  = dest1 `conflictsWith` src2
-	(n1, COpStmt dests1 _ _ _ _) `should_follow` (n2, CAssign _ src2)
-	  = or [dest1 `conflictsWith` src2 | dest1 <- dests1]
-	(n1, CAssign dest1 _)`should_follow` (n2, COpStmt _ _ srcs2 _ _)
-	  = or [dest1 `conflictsWith` src2 | src2 <- srcs2]
-	(n1, COpStmt dests1 _ _ _ _) `should_follow` (n2, COpStmt _ _ srcs2 _ _)
-	  = or [dest1 `conflictsWith` src2 | dest1 <- dests1, src2 <- srcs2]
-
---	(_, COpStmt _ _ _ _ _) `should_follow` (_, CCallProfCtrMacro _ _) = False
---	(_, CCallProfCtrMacro _ _) `should_follow` (_, COpStmt _ _ _ _ _) = False
-
-	eq_vertex :: CVertex -> CVertex -> Bool
-	(n1, _) `eq_vertex` (n2, _) = n1 == n2
-
-	components = stronglyConnComp eq_vertex edges vertices
-
-	-- do_components deal with one strongly-connected component
-	do_component :: [CVertex] -> FlatM AbstractC
-
-	-- A singleton?  Then just do it.
-	do_component [(n,abs_c)] = returnFlt abs_c
-
-	-- Two or more?  Then go via temporaries.
-	do_component ((n,first_stmt):rest)
-	  = doSimultaneously1 rest	`thenFlt` \ abs_cs ->
-	    go_via_temps first_stmt	`thenFlt` \ (to_temps, from_temps) ->
-	    returnFlt (mkAbstractCs [to_temps, abs_cs, from_temps])
-
-	go_via_temps (CAssign dest src)
-	  = getUniqFlt 			`thenFlt` \ uniq ->
-	    let  the_temp = CTemp uniq (getAmodeKind dest)  in
-	    returnFlt (CAssign the_temp src, CAssign dest the_temp)
-
-	go_via_temps (COpStmt dests op srcs liveness_mask vol_regs)
-	  = getUniqsFlt (length dests)	`thenFlt` \ uniqs ->
-	    let the_temps = zipWith (\ u d -> CTemp u (getAmodeKind d)) uniqs dests
-	    in
-	    returnFlt (COpStmt the_temps op srcs liveness_mask vol_regs,
-		       mkAbstractCs (zipWith CAssign dests the_temps))
-    in
-    mapFlt do_component components `thenFlt` \ abs_cs ->
-    returnFlt (mkAbstractCs abs_cs)
-\end{code}
-
-
-@conflictsWith@ tells whether an assignment to its first argument will
-screw up an access to its second.
-
-\begin{code}
-conflictsWith :: CAddrMode -> CAddrMode -> Bool
-(CReg reg1)	   `conflictsWith` (CReg reg2)		= reg1 == reg2
-(CReg reg)	   `conflictsWith` (CVal reg_rel _)	= reg `regConflictsWithRR` reg_rel
-(CReg reg)	   `conflictsWith` (CAddr reg_rel)	= reg `regConflictsWithRR` reg_rel
-(CTemp u1 _)	   `conflictsWith` (CTemp u2 _)		= u1 == u2
-(CVal reg_rel1 k1) `conflictsWith` (CVal reg_rel2 k2)
-  = rrConflictsWithRR (getKindSize k1) (getKindSize k2) reg_rel1 reg_rel2
-
-other1		  `conflictsWith` other2		= False
--- CAddr and literals are impossible on the LHS of an assignment
-
-regConflictsWithRR :: MagicId -> RegRelative -> Bool
-
-regConflictsWithRR (VanillaReg k ILIT(1)) (NodeRel _)	= True
-
-regConflictsWithRR SpA	(SpARel _ _)	= True
-regConflictsWithRR SpB	(SpBRel _ _)	= True
-regConflictsWithRR Hp	(HpRel _ _)	= True
-regConflictsWithRR _	_		= False
-
-rrConflictsWithRR :: Int -> Int			-- Sizes of two things
-		  -> RegRelative -> RegRelative -- The two amodes
-		  -> Bool
-
-rrConflictsWithRR s1 s2 rr1 rr2 = rr rr1 rr2
-  where
-    rr (SpARel p1 o1)    (SpARel p2 o2) 
-	| s1 == 0 || s2 == 0 = False	-- No conflict if either is size zero
-	| s1 == 1 && s2 == 1 = b1 == b2
-	| otherwise	     = (b1+s1) >= b2  &&
-			       (b2+s2) >= b1
-	where
-	  b1 = p1-o1
-	  b2 = p2-o2
-
-    rr (SpBRel p1 o1)    (SpBRel p2 o2)
-	| s1 == 0 || s2 == 0 = False	-- No conflict if either is size zero
-	| s1 == 1 && s2 == 1 = b1 == b2
-	| otherwise	     = (b1+s1) >= b2  &&
-			       (b2+s2) >= b1
-	where
-	  b1 = p1-o1
-	  b2 = p2-o2
-
-    rr (NodeRel o1)	 (NodeRel o2)
-	| s1 == 0 || s2 == 0 = False	-- No conflict if either is size zero
-	| s1 == 1 && s2 == 1 = o1 `possiblyEqualHeapOffset` o2
-	| otherwise	     = True		-- Give up
-
-    rr (HpRel _ _)	 (HpRel _ _)    = True	-- Give up
-
-    rr other1	         other2	        = False
-\end{code}
-
-%************************************************************************
-%*									*
-\subsection[gaze-into-simultaneous]{Registers live in a @CSimultaneous@?}
-%*									*
-%************************************************************************
-
-Hidden in a blob of ``simultaneous assignments'' is the info of how
-many pointer (``followable'') registers are live (i.e., assigned
-into).  What we do here is merely fish out the destination registers.
-
-\begin{code}
-{- UNUSED:
-getDestinationRegs :: AbstractC -> [MagicId]
-
-getDestinationRegs abs_c
-  = foldr gather [{-acc-}] (en_list abs_c)
-  where
-    gather :: AbstractC -> [MagicId] -> [MagicId]
-
-	-- only CAssigns and COpStmts now possible...
-
-    gather (CAssign (CReg magic_id) _) acc | magic_id `not_elem` acc
-      = magic_id : acc
-      where
-	not_elem = isn'tIn "getDestinationRegs"
-
-    gather (COpStmt dests _ _ _ _) acc
-      = foldr gather2 acc dests
-      where
-    	gather2 (CReg magic_id) acc | magic_id `not_elem` acc = magic_id : acc
-	gather2 _   	    	acc 			      = acc
-
-	not_elem = isn'tIn "getDestinationRegs2"
-
-    gather _ acc = acc
--}
-\end{code}
diff --git a/ghc/compiler/absCSyn/AbsCSyn.hi b/ghc/compiler/absCSyn/AbsCSyn.hi
deleted file mode 100644
index 8fb00be52d..0000000000
--- a/ghc/compiler/absCSyn/AbsCSyn.hi
+++ /dev/null
@@ -1,149 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface AbsCSyn where
-import AbsCFuns(amodeCanSurviveGC, flattenAbsC, getAmodeKind, kindFromMagicId, mixedPtrLocn, mixedTypeLocn, mkAbsCStmtList, mkAbsCStmts, mkAbstractCs, mkAlgAltsCSwitch, nonemptyAbsC)
-import BasicLit(BasicLit(..), mkMachInt, mkMachWord)
-import CLabelInfo(CLabel)
-import CharSeq(CSeq)
-import ClosureInfo(ClosureInfo, LambdaFormInfo)
-import CmdLineOpts(GlobalSwitch, SimplifierSwitch)
-import CostCentre(CostCentre)
-import HeapOffs(HeapOffset, HpRelOffset(..), SpARelOffset(..), SpBRelOffset(..), VirtualHeapOffset(..), VirtualSpAOffset(..), VirtualSpBOffset(..), addOff, fixedHdrSize, intOff, intOffsetIntoGoods, isZeroOff, maxOff, possiblyEqualHeapOffset, pprHeapOffset, subOff, totHdrSize, varHdrSize, zeroOff)
-import Id(ConTag(..), Id)
-import Maybes(Labda)
-import Outputable(ExportFlag, NamedThing(..), Outputable(..))
-import PprAbsC(dumpRealC, writeRealC)
-import PreludePS(_PackedString)
-import PreludeRatio(Ratio(..))
-import Pretty(PprStyle, Pretty(..), PrettyRep)
-import PrimKind(PrimKind(..))
-import PrimOps(PrimOp)
-import SMRep(SMRep)
-import SplitUniq(SplitUniqSupply)
-import SrcLoc(SrcLoc)
-import Stdio(_FILE)
-import StgSyn(StgAtom, StgExpr, UpdateFlag)
-import TyCon(TyCon)
-import UniType(UniType)
-import UniqFM(UniqFM)
-import UniqSet(UniqSet(..))
-import Unique(Unique)
-import Unpretty(Unpretty(..))
-class NamedThing a where
-	getExportFlag :: a -> ExportFlag
-	isLocallyDefined :: a -> Bool
-	getOrigName :: a -> (_PackedString, _PackedString)
-	getOccurrenceName :: a -> _PackedString
-	getInformingModules :: a -> [_PackedString]
-	getSrcLoc :: a -> SrcLoc
-	getTheUnique :: a -> Unique
-	hasType :: a -> Bool
-	getType :: a -> UniType
-	fromPreludeCore :: a -> Bool
-class Outputable a where
-	ppr :: PprStyle -> a -> Int -> Bool -> PrettyRep
-data AbstractC   = AbsCNop | AbsCStmts AbstractC AbstractC | CAssign CAddrMode CAddrMode | CJump CAddrMode | CFallThrough CAddrMode | CReturn CAddrMode ReturnInfo | CSwitch CAddrMode [(BasicLit, AbstractC)] AbstractC | CCodeBlock CLabel AbstractC | CInitHdr ClosureInfo RegRelative CAddrMode Bool | COpStmt [CAddrMode] PrimOp [CAddrMode] Int [MagicId] | CSimultaneous AbstractC | CMacroStmt CStmtMacro [CAddrMode] | CCallProfCtrMacro _PackedString [CAddrMode] | CCallProfCCMacro _PackedString [CAddrMode] | CStaticClosure CLabel ClosureInfo CAddrMode [CAddrMode] | CClosureInfoAndCode ClosureInfo AbstractC (Labda AbstractC) CAddrMode [Char] Int | CRetVector CLabel [Labda CAddrMode] AbstractC | CRetUnVector CLabel CAddrMode | CFlatRetVector CLabel [CAddrMode] | CCostCentreDecl Bool CostCentre | CClosureUpdInfo AbstractC | CSplitMarker
-data BasicLit   = MachChar Char | MachStr _PackedString | MachAddr Integer | MachInt Integer Bool | MachFloat (Ratio Integer) | MachDouble (Ratio Integer) | MachLitLit _PackedString PrimKind | NoRepStr _PackedString | NoRepInteger Integer | NoRepRational (Ratio Integer)
-data CAddrMode   = CVal RegRelative PrimKind | CAddr RegRelative | CReg MagicId | CTableEntry CAddrMode CAddrMode PrimKind | CTemp Unique PrimKind | CLbl CLabel PrimKind | CUnVecLbl CLabel CLabel | CCharLike CAddrMode | CIntLike CAddrMode | CString _PackedString | CLit BasicLit | CLitLit _PackedString PrimKind | COffset HeapOffset | CCode AbstractC | CLabelledCode CLabel AbstractC | CJoinPoint Int Int | CMacroExpr PrimKind CExprMacro [CAddrMode] | CCostCentre CostCentre Bool
-data CExprMacro   = INFO_PTR | ENTRY_CODE | INFO_TAG | EVAL_TAG
-data CLabel 
-data CSeq 
-data CStmtMacro   = ARGS_CHK_A_LOAD_NODE | ARGS_CHK_A | ARGS_CHK_B_LOAD_NODE | ARGS_CHK_B | HEAP_CHK | STK_CHK | UPD_CAF | UPD_IND | UPD_INPLACE_NOPTRS | UPD_INPLACE_PTRS | UPD_BH_UPDATABLE | UPD_BH_SINGLE_ENTRY | PUSH_STD_UPD_FRAME | POP_STD_UPD_FRAME | SET_ARITY | CHK_ARITY | SET_TAG
-data ClosureInfo 
-data LambdaFormInfo 
-data GlobalSwitch 
-data SimplifierSwitch 
-data CostCentre 
-data HeapOffset 
-type HpRelOffset = HeapOffset
-data MagicId   = BaseReg | StkOReg | VanillaReg PrimKind Int# | FloatReg Int# | DoubleReg Int# | TagReg | RetReg | SpA | SuA | SpB | SuB | Hp | HpLim | LivenessReg | ActivityReg | StdUpdRetVecReg | StkStubReg | CurCostCentre | VoidReg
-data RegRelative   = HpRel HeapOffset HeapOffset | SpARel Int Int | SpBRel Int Int | NodeRel HeapOffset
-data ReturnInfo   = DirectReturn | StaticVectoredReturn Int | DynamicVectoredReturn CAddrMode
-type SpARelOffset = Int
-type SpBRelOffset = Int
-type VirtualHeapOffset = HeapOffset
-type VirtualSpAOffset = Int
-type VirtualSpBOffset = Int
-type ConTag = Int
-data Id 
-data Labda a 
-data ExportFlag 
-data PprStyle 
-type Pretty = Int -> Bool -> PrettyRep
-data PrettyRep 
-data PrimKind   = PtrKind | CodePtrKind | DataPtrKind | RetKind | InfoPtrKind | CostCentreKind | CharKind | IntKind | WordKind | AddrKind | FloatKind | DoubleKind | MallocPtrKind | StablePtrKind | ArrayKind | ByteArrayKind | VoidKind
-data PrimOp 
-data SMRep 
-data SplitUniqSupply 
-data SrcLoc 
-data StgAtom a 
-data StgExpr a b 
-data UpdateFlag 
-data TyCon 
-data UniType 
-data UniqFM a 
-type UniqSet a = UniqFM a
-data Unique 
-type Unpretty = CSeq
-amodeCanSurviveGC :: CAddrMode -> Bool
-flattenAbsC :: SplitUniqSupply -> AbstractC -> AbstractC
-getAmodeKind :: CAddrMode -> PrimKind
-kindFromMagicId :: MagicId -> PrimKind
-mixedPtrLocn :: CAddrMode -> Bool
-mixedTypeLocn :: CAddrMode -> Bool
-mkAbsCStmtList :: AbstractC -> [AbstractC]
-mkAbsCStmts :: AbstractC -> AbstractC -> AbstractC
-mkAbstractCs :: [AbstractC] -> AbstractC
-mkAlgAltsCSwitch :: CAddrMode -> [(Int, AbstractC)] -> AbstractC -> AbstractC
-nonemptyAbsC :: AbstractC -> Labda AbstractC
-mkMachInt :: Integer -> BasicLit
-mkMachWord :: Integer -> BasicLit
-addOff :: HeapOffset -> HeapOffset -> HeapOffset
-fixedHdrSize :: HeapOffset
-dumpRealC :: (GlobalSwitch -> Bool) -> AbstractC -> [Char]
-infoptr :: MagicId
-intOff :: Int -> HeapOffset
-intOffsetIntoGoods :: HeapOffset -> Labda Int
-isVolatileReg :: MagicId -> Bool
-isZeroOff :: HeapOffset -> Bool
-maxOff :: HeapOffset -> HeapOffset -> HeapOffset
-mkCCostCentre :: CostCentre -> CAddrMode
-mkIntCLit :: Int -> CAddrMode
-node :: MagicId
-possiblyEqualHeapOffset :: HeapOffset -> HeapOffset -> Bool
-pprHeapOffset :: PprStyle -> HeapOffset -> CSeq
-subOff :: HeapOffset -> HeapOffset -> HeapOffset
-totHdrSize :: SMRep -> HeapOffset
-varHdrSize :: SMRep -> HeapOffset
-zeroOff :: HeapOffset
-writeRealC :: (GlobalSwitch -> Bool) -> _FILE -> AbstractC -> _State _RealWorld -> ((), _State _RealWorld)
-instance Eq MagicId
-instance Eq BasicLit
-instance Eq CLabel
-instance Eq GlobalSwitch
-instance Eq SimplifierSwitch
-instance Eq Id
-instance Eq PrimKind
-instance Eq PrimOp
-instance Eq Unique
-instance Ord BasicLit
-instance Ord CLabel
-instance Ord GlobalSwitch
-instance Ord SimplifierSwitch
-instance Ord Id
-instance Ord PrimKind
-instance Ord Unique
-instance NamedThing Id
-instance (Outputable a, Outputable b) => Outputable (a, b)
-instance (Outputable a, Outputable b, Outputable c) => Outputable (a, b, c)
-instance Outputable BasicLit
-instance Outputable Bool
-instance Outputable Id
-instance Outputable PrimKind
-instance Outputable PrimOp
-instance Outputable a => Outputable (StgAtom a)
-instance (Outputable a, Outputable b, Ord b) => Outputable (StgExpr a b)
-instance Outputable a => Outputable [a]
-instance Text CExprMacro
-instance Text CStmtMacro
-instance Text Unique
-
diff --git a/ghc/compiler/absCSyn/AbsCSyn.lhs b/ghc/compiler/absCSyn/AbsCSyn.lhs
index 23e7220213..f23614d5aa 100644
--- a/ghc/compiler/absCSyn/AbsCSyn.lhs
+++ b/ghc/compiler/absCSyn/AbsCSyn.lhs
@@ -1,5 +1,5 @@
 %
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
 %
 \section[AbstractC]{Abstract C: the last stop before machine code}
 
@@ -22,7 +22,7 @@ module AbsCSyn (
 	CAddrMode(..),
 	ReturnInfo(..),
 	mkAbstractCs, mkAbsCStmts, mkAlgAltsCSwitch,
-	mkIntCLit, 
+	mkIntCLit,
 	mkAbsCStmtList,
 	mkCCostCentre,
 
@@ -46,64 +46,43 @@ module AbsCSyn (
 	-- closure info
 	ClosureInfo, LambdaFormInfo, UpdateFlag, SMRep,
 
-	-- stuff from AbsCFuns and PprAbsC...
-	nonemptyAbsC, flattenAbsC, getAmodeKind,
+	-- stuff from AbsCUtils and PprAbsC...
+	nonemptyAbsC, flattenAbsC, getAmodeRep,
 	mixedTypeLocn, mixedPtrLocn,
-#ifdef __GLASGOW_HASKELL__
 	writeRealC,
-#endif
 	dumpRealC,
-	kindFromMagicId, -- UNUSED: getDestinationRegs,
-	amodeCanSurviveGC,
+	kindFromMagicId,
+	amodeCanSurviveGC
 
 #ifdef GRAN
-	CostRes(Cost),
+	, CostRes(Cost)
 #endif
 
 	-- and stuff to make the interface self-sufficient
-	Outputable(..), NamedThing(..),
-	PrettyRep, ExportFlag, SrcLoc, Unique,
-	CSeq, PprStyle, Pretty(..), Unpretty(..),
-	-- blargh...
-	UniType,
-
-	PrimKind(..), -- re-exported NON-ABSTRACTLY
-	BasicLit(..), mkMachInt, mkMachWord,   -- re-exported NON-ABSTRACTLY
-	Id, ConTag(..), Maybe, PrimOp, SplitUniqSupply, TyCon,
-	CLabel, GlobalSwitch, CostCentre,
-	SimplifierSwitch, UniqSet(..), UniqFM, StgExpr, StgAtom
     ) where
 
-import AbsCFuns		-- used, and re-exported
+import AbsCUtils	-- used, and re-exported
 import ClosureInfo	-- ditto
 import Costs
 import PprAbsC		-- ditto
 import HeapOffs		hiding ( hpRelToInt )
 
-import AbsPrel		( PrimOp
+import PrelInfo		( PrimOp
 			  IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
 			  IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
 			)
-import CLabelInfo
-import CmdLineOpts	( GlobalSwitch(..), SimplifierSwitch )
-import BasicLit		( mkMachInt, mkMachWord, BasicLit(..) )
+import Literal		( mkMachInt, mkMachWord, Literal(..) )
+import CLabel
+import CgCompInfo   	( mAX_Vanilla_REG, mAX_Float_REG, mAX_Double_REG )
+import CostCentre	-- for CostCentre type
 import Id		( Id, ConTag(..), DataCon(..) )
 import Maybes		( Maybe )
 import Outputable
-import Unpretty		-- ********** NOTE **********
-import PrimKind		( PrimKind(..) )
-import CostCentre	-- for CostCentre type
-import StgSyn		( StgExpr, StgAtom, StgBinderInfo )
+import PrimRep		( PrimRep(..) )
+import StgSyn		( GenStgExpr, GenStgArg, StgBinderInfo )
 import UniqSet		( UniqSet(..), UniqFM )
-import Unique		( Unique )
+import Unpretty		-- ********** NOTE **********
 import Util
-
-#ifndef DPH
-import CgCompInfo   	( mAX_Vanilla_REG, mAX_Float_REG, mAX_Double_REG )
-#else
-import CgCompInfo	( spARelToInt, spBRelToInt )
-import DapInfo		( virtualHeapOffsetToInt   )
-#endif {- Data Parallel Haskell -}
 \end{code}
 
 @AbstractC@ is a list of Abstract~C statements, but the data structure
@@ -120,7 +99,7 @@ A note on @CAssign@: In general, the type associated with an assignment
 is the type of the lhs.  However, when the lhs is a pointer to mixed
 types (e.g. SpB relative), the type of the assignment is the type of
 the rhs for float types, or the generic StgWord for all other types.
-(In particular, a CharKind on the rhs is promoted to IntKind when
+(In particular, a CharRep on the rhs is promoted to IntRep when
 stored in a mixed type location.)
 
 \begin{code}
@@ -130,7 +109,7 @@ stored in a mixed type location.)
 
   | CJump
 	CAddrMode	-- Put this in the program counter
-			-- eg `CJump (CReg (VanillaReg PtrKind 1))' puts Ret1 in PC
+			-- eg `CJump (CReg (VanillaReg PtrRep 1))' puts Ret1 in PC
 			-- Enter can be done by:
 			--	  CJump (CVal NodeRel zeroOff)
 
@@ -144,7 +123,7 @@ stored in a mixed type location.)
     	ReturnInfo  	-- How to get the return address from the base address
 
   | CSwitch CAddrMode
-	[(BasicLit, AbstractC)]	-- alternatives
+	[(Literal, AbstractC)]	-- alternatives
 	AbstractC		-- default; if there is no real Abstract C in here
 				-- (e.g., all comments; see function "nonemptyAbsC"),
 				-- then that means the default _cannot_ occur.
@@ -178,12 +157,12 @@ stored in a mixed type location.)
 	-- INVARIANT: When a PrimOp which can cause GC is used, the
 	-- only live data is tidily on the STG stacks or in the STG
 	-- registers (the code generator ensures this).
-	-- 
+	--
 	-- Why this?  Because if the arguments were arbitrary
 	-- addressing modes, they might be things like (Hp+6) which
 	-- will get utterly spongled by GC.
 
-  | CSimultaneous	-- Perform simultaneously all the statements 
+  | CSimultaneous	-- Perform simultaneously all the statements
 	AbstractC	-- in the nested AbstractC.  They are only
 			-- allowed to be CAssigns, COpStmts and AbsCNops, so the
 			-- "simultaneous" part just concerns making
@@ -200,8 +179,8 @@ stored in a mixed type location.)
 
   | CStaticClosure
 	CLabel	-- The (full, not base) label to use for labelling the closure.
-	ClosureInfo	
-	CAddrMode	-- cost centre identifier to place in closure	
+	ClosureInfo
+	CAddrMode	-- cost centre identifier to place in closure
 	[CAddrMode]	-- free vars; ptrs, then non-ptrs
 
 
@@ -239,30 +218,12 @@ stored in a mixed type location.)
 			-- False <=> extern; just say so
 	CostCentre
 
-{-UNUSED:
-  | CComment		-- to insert a comment into the output
-	FAST_STRING
--}
-
   | CClosureUpdInfo
     	AbstractC 	-- InRegs Info Table (CClosureInfoTable)
 			--                    ^^^^^^^^^^^^^^^^^
 			--                                out of date -- HWL
 
   | CSplitMarker	-- Split into separate object modules here
-
-#ifdef DPH
-  | CNativeInfoTableAndCode
-	ClosureInfo	-- Explains placement and layout of closure
-	String		-- closure description
-	AbstractC	-- We want to apply the trick outlined in the STG 
-			-- paper of putting the info table before the normal 
-			-- entry point to a function (well a very similar 
-			-- trick, see nativeDap/NOTES.static). By putting the 
-			-- abstractC here we stop the info table 
-			-- wandering off :-) (No post mangler hacking going
-			-- on here Will :-)
-#endif {- Data Parallel Haskell -}
 \end{code}
 
 About @CMacroStmt@, etc.: notionally, they all just call some
@@ -291,17 +252,16 @@ data CStmtMacro
   | UPD_BH_SINGLE_ENTRY
   | PUSH_STD_UPD_FRAME
   | POP_STD_UPD_FRAME
---UNUSED:  | PUSH_CON_UPD_FRAME 
   | SET_ARITY
   | CHK_ARITY
   | SET_TAG
 #ifdef GRAN
-  | GRAN_FETCH	    		-- for GrAnSim only  -- HWL 
-  | GRAN_RESCHEDULE   		-- for GrAnSim only  -- HWL 
-  | GRAN_FETCH_AND_RESCHEDULE	-- for GrAnSim only  -- HWL 
-  | THREAD_CONTEXT_SWITCH   	-- for GrAnSim only  -- HWL 
+  | GRAN_FETCH	    		-- for GrAnSim only  -- HWL
+  | GRAN_RESCHEDULE   		-- for GrAnSim only  -- HWL
+  | GRAN_FETCH_AND_RESCHEDULE	-- for GrAnSim only  -- HWL
+  | THREAD_CONTEXT_SWITCH   	-- for GrAnSim only  -- HWL
 #endif
-  deriving Text 
+  deriving Text
 
 \end{code}
 
@@ -357,7 +317,7 @@ to the code to be resumed. (ToDo: update)
 Addressing modes: these have @PrimitiveKinds@ pinned on them.
 \begin{code}
 data CAddrMode
-  = CVal  RegRelative PrimKind
+  = CVal  RegRelative PrimRep
 			-- On RHS of assign: Contents of Magic[n]
 			-- On LHS of assign: location Magic[n]
 			-- (ie at addr Magic+n)
@@ -375,23 +335,21 @@ data CAddrMode
   | CTableEntry     	    -- CVal should be generalized to allow this
     	    	CAddrMode   -- Base
     	        CAddrMode   -- Offset
-    	    	PrimKind    -- For casting
+    	    	PrimRep    -- For casting
 
-  | CTemp Unique PrimKind	-- Temporary locations
+  | CTemp Unique PrimRep	-- Temporary locations
 	-- ``Temporaries'' correspond to local variables in C, and registers in
 	-- native code.
-	-- OLD: The kind (that used to be there) is redundant, but it's REALLY helpful for
-	-- generating C declarations
 
   | CLbl    CLabel	-- Labels in the runtime system, etc.
 			-- See comment under CLabelledData about (String,Name)
-	    PrimKind	-- the kind is so we can generate accurate C decls
+	    PrimRep	-- the kind is so we can generate accurate C decls
 
   | CUnVecLbl 	    	-- A choice of labels left up to the back end
     	      CLabel	-- direct
     	      CLabel	-- vectored
 
-  | CCharLike CAddrMode	-- The address of a static char-like closure for 
+  | CCharLike CAddrMode	-- The address of a static char-like closure for
 			-- the specified character.  It is guaranteed to be in
 			-- the range 0..255.
 
@@ -400,10 +358,10 @@ data CAddrMode
 			-- range mIN_INTLIKE..mAX_INTLIKE
 
   | CString FAST_STRING	-- The address of the null-terminated string
-  | CLit    BasicLit
+  | CLit    Literal
   | CLitLit FAST_STRING	-- completely literal literal: just spit this String
 			-- into the C output
-	    PrimKind
+	    PrimRep
 
   | COffset HeapOffset	-- A literal constant, not an offset *from* anything!
 			-- ToDo: this should really be CLitOffset
@@ -423,9 +381,9 @@ data CAddrMode
 				-- then the code for this thing will be entered
 
   | CMacroExpr
-    	PrimKind    	-- the kind of the result
+    	PrimRep    	-- the kind of the result
     	CExprMacro    	-- the macro to generate a value
-        [CAddrMode]   	-- and its arguments
+	[CAddrMode]   	-- and its arguments
 
   | CCostCentre		-- If Bool is True ==> it to be printed as a String,
 	CostCentre	-- (*not* as a C identifier or some such).
@@ -514,7 +472,7 @@ data MagicId
 
   -- Argument and return registers
   | VanillaReg		-- pointers, unboxed ints and chars
-	PrimKind	-- PtrKind, IntKind, CharKind, StablePtrKind or MallocPtrKind
+	PrimRep	-- PtrRep, IntRep, CharRep, StablePtrRep or MallocPtrRep
 			--	(in case we need to distinguish)
 	FAST_INT	-- its number (1 .. mAX_Vanilla_REG)
 
@@ -545,7 +503,6 @@ data MagicId
   | LivenessReg	-- (parallel only) used when we need to record explicitly
 		-- what registers are live
 
-  | ActivityReg	    	-- mentioned only in nativeGen (UNUSED)
   | StdUpdRetVecReg 	-- mentioned only in nativeGen
   | StkStubReg	    	-- register holding STK_STUB_closure (for stubbing dead stack slots)
 
@@ -553,33 +510,15 @@ data MagicId
 
   | VoidReg -- see "VoidPrim" type; just a placeholder; no actual register
 
-#ifdef DPH
--- In DPH we use:  
---	(VanillaReg X)  for pointers, ints, chars floats 
---	(DataReg X)     for ints chars or floats
---	(DoubleReg X)   first 32 bits of double in register X, second 32 in
---		        register X+1; DoubleReg is a synonymn for 
---			DataReg X; DataReg X+1
-
-  | DataReg
-	PrimKind
-	Int
-#endif {- Data Parallel Haskell -}
-
-node 	= VanillaReg PtrKind     ILIT(1) -- A convenient alias for Node
-infoptr = VanillaReg DataPtrKind ILIT(2) -- An alias for InfoPtr
+node 	= VanillaReg PtrRep     ILIT(1) -- A convenient alias for Node
+infoptr = VanillaReg DataPtrRep ILIT(2) -- An alias for InfoPtr
 \end{code}
 
 We need magical @Eq@ because @VanillaReg@s come in multiple flavors.
 
 \begin{code}
 instance Eq MagicId where
-#ifdef DPH
-    (FloatReg  f1) == (FloatReg  f2) = f1 == f2
-    (DoubleReg d1) == (DoubleReg d2) = d1 == d2
-    (DataReg _ d1) == (DataReg _ d2) = d1 == d2
-#endif {- Data Parallel Haskell -}
-    reg1	   == reg2	     = tagOf_MagicId reg1 _EQ_ tagOf_MagicId reg2
+    reg1 == reg2 = tagOf_MagicId reg1 _EQ_ tagOf_MagicId reg2
 
 tagOf_MagicId BaseReg		= (ILIT(0) :: FAST_INT)
 tagOf_MagicId StkOReg		= ILIT(1)
@@ -592,7 +531,6 @@ tagOf_MagicId SuB		= ILIT(7)
 tagOf_MagicId Hp		= ILIT(8)
 tagOf_MagicId HpLim		= ILIT(9)
 tagOf_MagicId LivenessReg	= ILIT(10)
---tagOf_MagicId ActivityReg	= ILIT(11) -- UNUSED
 tagOf_MagicId StdUpdRetVecReg	= ILIT(12)
 tagOf_MagicId StkStubReg	= ILIT(13)
 tagOf_MagicId CurCostCentre	= ILIT(14)
@@ -600,7 +538,6 @@ tagOf_MagicId VoidReg		= ILIT(15)
 
 tagOf_MagicId (VanillaReg _ i) = ILIT(15) _ADD_ i
 
-#ifndef DPH
 tagOf_MagicId (FloatReg i) = ILIT(15) _ADD_ maxv _ADD_ i
   where
     maxv = case mAX_Vanilla_REG of { IBOX(x) -> x }
@@ -609,11 +546,6 @@ tagOf_MagicId (DoubleReg i) = ILIT(15) _ADD_ maxv _ADD_ maxf _ADD_ i
   where
     maxv = case mAX_Vanilla_REG of { IBOX(x) -> x }
     maxf = case mAX_Float_REG   of { IBOX(x) -> x }
-
-#else
-tagOf_MagicId (DoubleReg i)	    = ILIT(1066) _ADD_ i -- Hacky, but we want disjoint
-tagOf_MagicId (DataReg _ IBOX(i))   = ILIT(1066) _ADD_ i -- range with Vanillas
-#endif {- Data Parallel Haskell -}
 \end{code}
 
 Returns True for any register that {\em potentially} dies across
@@ -622,7 +554,7 @@ let the (machine-specific) registering macros sort things out...
 \begin{code}
 isVolatileReg :: MagicId -> Bool
 
-isVolatileReg any	= True
+isVolatileReg any = True
 --isVolatileReg (FloatReg _)	= True
 --isVolatileReg (DoubleReg _)	= True
 \end{code}
@@ -634,59 +566,3 @@ isVolatileReg any	= True
 %************************************************************************
 
 It's in \tr{PprAbsC.lhs}.
-
-%************************************************************************
-%*									*
-\subsection[EqInstances]{Eq instance for RegRelative & CAddrMode}
-%*									*
-%************************************************************************
-
-DPH requires CAddrMode to be in class Eq for its register allocation
-algorithm. The code for equality is rather conservative --- it doesnt
-matter if two things are determined to be not equal (even if they really are,
-i.e with CVal's), we just generate less efficient code.
-
-NOTE(07/04/93) It does matter, its doing really bad with the reg relative
- 	       stuff.
-
-\begin{code}
-#ifdef DPH
-instance Eq CAddrMode where
-  (CVal r _)          == (CVal r' _)        = r `eqRRel` r'	
-  (CAddr r)           == (CAddr r')         = r `eqRRel` r'
-  (CReg reg)          == (CReg reg')        = reg == reg'
-  (CTemp u _)         == (CTemp u' _)       = u == u'
-  (CLbl l _)          == (CLbl l' _)        = l == l'
-  (CUnVecLbl d v)     == (CUnVecLbl d' v')  = d == d' && v == v'
-  (CCharLike c)       == (CCharLike c')     = c == c'
-  (CIntLike c)        == (CIntLike c')      = c == c'
-  (CString str)       == (CString str')     = str == str'
-  (CLit lit)          == (CLit lit')        = lit == lit'
-  (COffset off)       == (COffset off')     = possiblyEqualHeapOffset off off'
-  (CCode _)           == (CCode _)          = panic "(==) Code in CAddrMode"
-  (CLabelledCode _ _) == (CLabelledCode _ _)= panic "(==) LabCode in CAddrMode"
-  _                   == _                  = False
-
-
-eqRRel :: RegRelative -> RegRelative -> Bool
-eqRRel (NodeRel x) (NodeRel y)	  
-  = virtualHeapOffsetToInt x == virtualHeapOffsetToInt y
-
-eqRRel l@(SpARel _ _) r@(SpARel _ _)    
-  = spARelToInt l == spARelToInt r
-
-eqRRel l@(SpBRel _ _) r@(SpBRel _ _)    
-  = spBRelToInt l == spBRelToInt r
-
-eqRRel (HpRel hp off) (HpRel hp' off')  
-  = (virtualHeapOffsetToInt (hp  `subOff` off)) == 
-    (virtualHeapOffsetToInt (hp' `subOff` off'))
-
-eqRRel _ _ = False
-
-eqRetInfo:: ReturnInfo -> ReturnInfo -> Bool
-eqRetInfo DirectReturn	    	    DirectReturn    	      = True
-eqRetInfo (StaticVectoredReturn x)  (StaticVectoredReturn x') = x == x'
-eqRetInfo _ 	    	    	    _ 			      = False
-#endif {- Data Parallel Haskell -}
-\end{code}
diff --git a/ghc/compiler/absCSyn/AbsCUtils.lhs b/ghc/compiler/absCSyn/AbsCUtils.lhs
new file mode 100644
index 0000000000..a9789c8b96
--- /dev/null
+++ b/ghc/compiler/absCSyn/AbsCUtils.lhs
@@ -0,0 +1,772 @@
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1993-1996
+%
+\section[AbsCUtils]{Help functions for Abstract~C datatype}
+
+\begin{code}
+#include "HsVersions.h"
+
+module AbsCUtils (
+	nonemptyAbsC,
+	mkAbstractCs, mkAbsCStmts,
+	mkAlgAltsCSwitch,
+	kindFromMagicId,
+	getAmodeRep, amodeCanSurviveGC,
+	mixedTypeLocn, mixedPtrLocn,
+	flattenAbsC,
+	mkAbsCStmtList
+
+	-- printing/forcing stuff comes from PprAbsC
+
+	-- and for interface self-sufficiency...
+    ) where
+
+import AbsCSyn
+
+import PrelInfo		( PrimOp(..)
+			  IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
+			  IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
+			)
+import Literal		( literalPrimRep )
+import CLabel	( CLabel, mkReturnPtLabel, mkVecTblLabel )
+import Digraph		( stronglyConnComp )
+import Id		( fIRST_TAG, ConTag(..), DataCon(..), Id )
+import Maybes		( Maybe(..) )
+import PrimRep		( getPrimRepSize, retPrimRepSize, PrimRep(..) )
+import UniqSupply
+import StgSyn		( GenStgArg )
+
+infixr 9 `thenFlt`
+\end{code}
+
+Check if there is any real code in some Abstract~C.  If so, return it
+(@Just ...@); otherwise, return @Nothing@.  Don't be too strict!
+
+It returns the "reduced" code in the Just part so that the work of
+discarding AbsCNops isn't lost, and so that if the caller uses
+the reduced version there's less danger of a big tree of AbsCNops getting
+materialised and causing a space leak.
+
+\begin{code}
+nonemptyAbsC :: AbstractC -> Maybe AbstractC
+nonemptyAbsC  AbsCNop		= Nothing
+nonemptyAbsC (AbsCStmts s1 s2)	= case (nonemptyAbsC s1) of
+				    Nothing -> nonemptyAbsC s2
+				    Just x  -> Just (AbsCStmts x s2)
+nonemptyAbsC s@(CSimultaneous c) = case (nonemptyAbsC c) of
+				    Nothing -> Nothing
+				    Just x  -> Just s
+nonemptyAbsC other		= Just other
+\end{code}
+
+\begin{code}
+mkAbstractCs :: [AbstractC] -> AbstractC
+mkAbstractCs [] = AbsCNop
+mkAbstractCs cs = foldr1 mkAbsCStmts cs
+
+-- for fiddling around w/ killing off AbsCNops ... (ToDo)
+mkAbsCStmts :: AbstractC -> AbstractC -> AbstractC
+mkAbsCStmts = AbsCStmts
+
+{- Discarded SLPJ June 95; it calls nonemptyAbsC too much!
+  = BIND (case (nonemptyAbsC abc2) of
+	    Nothing -> AbsCNop
+	    Just d2 -> d2)	_TO_ abc2b ->
+
+    case (nonemptyAbsC abc1) of {
+      Nothing -> abc2b;
+      Just d1 -> AbsCStmts d1 abc2b
+    } BEND
+-}
+{-
+  = case (nonemptyAbsC abc1) of
+      Nothing -> abc2
+      Just d1 -> AbsCStmts d1 abc2
+-}
+{- old2:
+  = case (nonemptyAbsC abc1) of
+      Nothing -> case (nonemptyAbsC abc2) of
+		   Nothing -> AbsCNop
+		   Just d2 -> d2
+      Just d1 -> AbsCStmts d1 abc2
+-}
+{- old:
+    if abc1_empty then
+	if abc2_empty
+	then AbsCNop
+	else abc2
+    else if {- abc1 not empty but -} abc2_empty then
+	abc1
+    else {- neither empty -}
+	AbsCStmts abc1 abc2
+  where
+    abc1_empty = noAbsCcode abc1
+    abc2_empty = noAbsCcode abc2
+-}
+\end{code}
+
+Get the sho' 'nuff statements out of an @AbstractC@.
+\begin{code}
+mkAbsCStmtList :: AbstractC -> [AbstractC]
+
+mkAbsCStmtList absC = mkAbsCStmtList' absC []
+
+-- Optimised a la foldr/build!
+
+mkAbsCStmtList'  AbsCNop r = r
+
+mkAbsCStmtList' (AbsCStmts s1 s2) r
+  = mkAbsCStmtList' s1 (mkAbsCStmtList' s2 r)
+
+mkAbsCStmtList' s@(CSimultaneous c) r
+  = if null (mkAbsCStmtList c) then r else s : r
+
+mkAbsCStmtList' other r = other : r
+\end{code}
+
+\begin{code}
+mkAlgAltsCSwitch :: CAddrMode -> [(ConTag, AbstractC)] -> AbstractC -> AbstractC
+
+mkAlgAltsCSwitch scrutinee tagged_alts deflt_absc
+ = CSwitch scrutinee (adjust tagged_alts) deflt_absc
+ where
+   -- Adjust the tags in the switch to start at zero.
+   -- This is the convention used by primitive ops which return algebraic
+   -- data types.  Why?	 Because for two-constructor types, zero is faster
+   -- to create and distinguish from 1 than are 1 and 2.
+
+   -- We also need to convert to Literals to keep the CSwitch happy
+   adjust tagged_alts
+     = [ (MachInt (toInteger (tag - fIRST_TAG)) False{-unsigned-}, abs_c)
+       | (tag, abs_c) <- tagged_alts ]
+\end{code}
+
+%************************************************************************
+%*									*
+\subsubsection[AbsCUtils-kinds-from-MagicIds]{Kinds from MagicIds}
+%*									*
+%************************************************************************
+
+\begin{code}
+kindFromMagicId BaseReg		    = PtrRep
+kindFromMagicId StkOReg		    = PtrRep
+kindFromMagicId (VanillaReg kind _) = kind
+kindFromMagicId (FloatReg _)	    = FloatRep
+kindFromMagicId (DoubleReg _)	    = DoubleRep
+kindFromMagicId TagReg		    = IntRep
+kindFromMagicId RetReg		    = RetRep
+kindFromMagicId SpA		    = PtrRep
+kindFromMagicId SuA		    = PtrRep
+kindFromMagicId SpB		    = PtrRep
+kindFromMagicId SuB		    = PtrRep
+kindFromMagicId Hp		    = PtrRep
+kindFromMagicId HpLim		    = PtrRep
+kindFromMagicId LivenessReg	    = IntRep
+kindFromMagicId StdUpdRetVecReg	    = PtrRep
+kindFromMagicId StkStubReg	    = PtrRep
+kindFromMagicId CurCostCentre	    = CostCentreRep
+kindFromMagicId VoidReg		    = VoidRep
+\end{code}
+
+%************************************************************************
+%*									*
+\subsection[AbsCUtils-amode-kinds]{Finding @PrimitiveKinds@ of amodes}
+%*									*
+%************************************************************************
+
+See also the return conventions for unboxed things; currently living
+in @CgCon@ (next to the constructor return conventions).
+
+ToDo: tiny tweaking may be in order
+\begin{code}
+getAmodeRep :: CAddrMode -> PrimRep
+
+getAmodeRep (CVal _ kind)	    	    = kind
+getAmodeRep (CAddr _)		    	    = PtrRep
+getAmodeRep (CReg magic_id)	    	    = kindFromMagicId magic_id
+getAmodeRep (CTemp uniq kind)	    	    = kind
+getAmodeRep (CLbl label kind)	    	    = kind
+getAmodeRep (CUnVecLbl _ _)	    	    = PtrRep
+getAmodeRep (CCharLike _)	    	    = PtrRep
+getAmodeRep (CIntLike _)	    	    = PtrRep
+getAmodeRep (CString _)	    	    = PtrRep
+getAmodeRep (CLit lit)		    	    = literalPrimRep lit
+getAmodeRep (CLitLit _ kind)	    	    = kind
+getAmodeRep (COffset _)	    	    = IntRep
+getAmodeRep (CCode abs_C)		    = CodePtrRep
+getAmodeRep (CLabelledCode label abs_C)    = CodePtrRep
+getAmodeRep (CTableEntry _ _ kind)    	    = kind
+getAmodeRep (CMacroExpr kind _ _)    	    = kind
+#ifdef DEBUG
+getAmodeRep (CJoinPoint _ _)	    	    = panic "getAmodeRep:CJoinPoint"
+getAmodeRep (CCostCentre _ _)		    = panic "getAmodeRep:CCostCentre"
+#endif
+\end{code}
+
+@amodeCanSurviveGC@ tells, well, whether or not the amode is invariant
+across a garbage collection.  Used only for PrimOp arguments (not that
+it matters).
+
+\begin{code}
+amodeCanSurviveGC :: CAddrMode -> Bool
+
+amodeCanSurviveGC (CTableEntry base offset _)
+  = amodeCanSurviveGC base && amodeCanSurviveGC offset
+    -- "Fixed table, so it's OK" (JSM); code is slightly paranoid
+
+amodeCanSurviveGC (CLbl _ _)		= True
+amodeCanSurviveGC (CUnVecLbl _ _)	= True
+amodeCanSurviveGC (CCharLike arg)	= amodeCanSurviveGC arg
+amodeCanSurviveGC (CIntLike arg)	= amodeCanSurviveGC arg
+amodeCanSurviveGC (CString _)		= True
+amodeCanSurviveGC (CLit _)		= True
+amodeCanSurviveGC (CLitLit _ _)		= True
+amodeCanSurviveGC (COffset _)		= True
+amodeCanSurviveGC (CMacroExpr _ _ args)	= all amodeCanSurviveGC args
+
+amodeCanSurviveGC _ = False
+    -- there are some amodes that "cannot occur" as args
+    -- to a PrimOp, but it is safe to return False (rather than panic)
+\end{code}
+
+@mixedTypeLocn@ tells whether an amode identifies an ``StgWord''
+location; that is, one which can contain values of various types.
+
+\begin{code}
+mixedTypeLocn :: CAddrMode -> Bool
+
+mixedTypeLocn (CVal (NodeRel _)   _)	= True
+mixedTypeLocn (CVal (SpBRel _ _)  _)	= True
+mixedTypeLocn (CVal (HpRel _ _)	  _)	= True
+mixedTypeLocn other			= False	-- All the rest
+\end{code}
+
+@mixedPtrLocn@ tells whether an amode identifies a
+location which can contain values of various pointer types.
+
+\begin{code}
+mixedPtrLocn :: CAddrMode -> Bool
+
+mixedPtrLocn (CVal (SpARel _ _)  _)	= True
+mixedPtrLocn other			= False	-- All the rest
+\end{code}
+
+%************************************************************************
+%*									*
+\subsection[AbsCUtils-flattening]{Flatten Abstract~C}
+%*									*
+%************************************************************************
+
+The following bits take ``raw'' Abstract~C, which may have all sorts of
+nesting, and flattens it into one long @AbsCStmtList@.  Mainly,
+@CClosureInfos@ and code for switches are pulled out to the top level.
+
+The various functions herein tend to produce
+\begin{enumerate}
+\item
+A {\em flattened} \tr{<something>} of interest for ``here'', and
+\item
+Some {\em unflattened} Abstract~C statements to be carried up to the
+top-level.  The only real reason (now) that it is unflattened is
+because it means the recursive flattening can be done in just one
+place rather than having to remember lots of places.
+\end{enumerate}
+
+Care is taken to reduce the occurrence of forward references, while still
+keeping laziness a much as possible.  Essentially, this means that:
+\begin{itemize}
+\item
+{\em All} the top-level C statements resulting from flattening a
+particular AbsC statement (whether the latter is nested or not) appear
+before {\em any} of the code for a subsequent AbsC statement;
+\item
+but stuff nested within any AbsC statement comes
+out before the code for the statement itself.
+\end{itemize}
+
+The ``stuff to be carried up'' always includes a label: a
+@CStaticClosure@, @CClosureUpdInfo@, @CRetUnVector@, @CFlatRetVector@, or
+@CCodeBlock@.  The latter turns into a C function, and is never
+actually produced by the code generator.  Rather it always starts life
+as a @CLabelledCode@ addressing mode; when such an addr mode is
+flattened, the ``tops'' stuff is a @CCodeBlock@.
+
+\begin{code}
+flattenAbsC :: UniqSupply -> AbstractC -> AbstractC
+
+flattenAbsC us abs_C
+  = case (initFlt us (flatAbsC abs_C)) of { (here, tops) ->
+    here `mkAbsCStmts` tops }
+\end{code}
+
+%************************************************************************
+%*									*
+\subsubsection{Flattening monadery}
+%*									*
+%************************************************************************
+
+The flattener is monadised.  It's just a @UniqueSupply@, along with a
+``come-back-to-here'' label to pin on heap and stack checks.
+
+\begin{code}
+type FlatM result
+     = CLabel
+    -> UniqSupply
+    -> result
+
+initFlt :: UniqSupply -> FlatM a -> a
+
+initFlt init_us m = m (panic "initFlt:CLabel") init_us
+
+{-# INLINE thenFlt #-}
+{-# INLINE returnFlt #-}
+
+thenFlt :: FlatM a -> (a -> FlatM b) -> FlatM b
+
+thenFlt expr cont label us
+  = case (splitUniqSupply us)   of { (s1, s2) ->
+    case (expr label s1)    	of { result ->
+    cont result label s2 }}
+
+returnFlt :: a -> FlatM a
+returnFlt result label us = result
+
+mapFlt :: (a -> FlatM b) -> [a] -> FlatM [b]
+
+mapFlt f []     = returnFlt []
+mapFlt f (x:xs)
+  = f x         `thenFlt` \ r  ->
+    mapFlt f xs `thenFlt` \ rs ->
+    returnFlt (r:rs)
+
+mapAndUnzipFlt  :: (a -> FlatM (b,c))   -> [a] -> FlatM ([b],[c])
+
+mapAndUnzipFlt f [] = returnFlt ([],[])
+mapAndUnzipFlt f (x:xs)
+  = f x		    	`thenFlt` \ (r1,  r2)  ->
+    mapAndUnzipFlt f xs	`thenFlt` \ (rs1, rs2) ->
+    returnFlt (r1:rs1, r2:rs2)
+
+getUniqFlt :: FlatM Unique
+getUniqFlt label us = getUnique us
+
+getUniqsFlt :: Int -> FlatM [Unique]
+getUniqsFlt i label us = getUniques i us
+
+setLabelFlt :: CLabel -> FlatM a -> FlatM a
+setLabelFlt new_label cont label us = cont new_label us
+
+getLabelFlt :: FlatM CLabel
+getLabelFlt label us = label
+\end{code}
+
+%************************************************************************
+%*									*
+\subsubsection{Flattening the top level}
+%*									*
+%************************************************************************
+
+\begin{code}
+flatAbsC :: AbstractC
+	 -> FlatM (AbstractC,		-- Stuff to put inline		[Both are fully
+		   AbstractC)		-- Stuff to put at top level	 flattened]
+
+flatAbsC AbsCNop = returnFlt (AbsCNop, AbsCNop)
+
+flatAbsC (AbsCStmts s1 s2)
+  = flatAbsC s1	`thenFlt` \ (inline_s1, top_s1) ->
+    flatAbsC s2	`thenFlt` \ (inline_s2, top_s2) ->
+    returnFlt (mkAbsCStmts inline_s1 inline_s2,
+	       mkAbsCStmts top_s1    top_s2)
+
+flatAbsC (CClosureInfoAndCode cl_info slow maybe_fast upd descr liveness)
+  = flatAbsC slow		`thenFlt` \ (slow_heres, slow_tops) ->
+    flat_maybe maybe_fast	`thenFlt` \ (fast_heres, fast_tops) ->
+    flatAmode upd               `thenFlt` \ (upd_lbl,    upd_tops) ->
+    returnFlt (AbsCNop, mkAbstractCs [slow_tops, fast_tops, upd_tops,
+       CClosureInfoAndCode cl_info slow_heres fast_heres upd_lbl descr liveness]
+    )
+  where
+    flat_maybe :: Maybe AbstractC -> FlatM (Maybe AbstractC, AbstractC)
+    flat_maybe Nothing      = returnFlt (Nothing, AbsCNop)
+    flat_maybe (Just abs_c) = flatAbsC abs_c `thenFlt` \ (heres, tops) ->
+			      returnFlt (Just heres, tops)
+
+flatAbsC (CCodeBlock label abs_C)
+  = flatAbsC abs_C	    `thenFlt` \ (absC_heres, absC_tops) ->
+    returnFlt (AbsCNop, absC_tops `mkAbsCStmts` CCodeBlock label absC_heres)
+
+flatAbsC (CClosureUpdInfo info) = flatAbsC info
+
+flatAbsC (CStaticClosure closure_lbl closure_info cost_centre amodes)
+  = flatAmodes (cost_centre:amodes)	`thenFlt` \ (new_cc:new_amodes, tops) ->
+    returnFlt (AbsCNop, tops `mkAbsCStmts`
+			CStaticClosure closure_lbl closure_info new_cc new_amodes)
+
+flatAbsC (CRetVector tbl_label stuff deflt)
+  = do_deflt deflt				`thenFlt` \ (deflt_amode, deflt_tops) ->
+    mapAndUnzipFlt (do_alt deflt_amode) stuff	`thenFlt` \ (alt_amodes, alt_tops) ->
+    returnFlt (AbsCNop, mkAbstractCs [deflt_tops,
+				      mkAbstractCs alt_tops,
+				      CFlatRetVector tbl_label alt_amodes])
+
+  where
+    do_deflt deflt = case nonemptyAbsC deflt of
+			Nothing     -> returnFlt (bogus_default_label, AbsCNop)
+			Just deflt' -> flatAmode (CCode deflt)	-- Deals correctly with the
+								-- CJump (CLabelledCode ...) case
+
+    do_alt deflt_amode Nothing    = returnFlt (deflt_amode, AbsCNop)
+    do_alt deflt_amode (Just alt) = flatAmode alt
+
+    bogus_default_label = panic "flatAbsC: CRetVector: default needed and not available"
+
+
+flatAbsC (CRetUnVector label amode)
+  = flatAmode amode	`thenFlt` \ (new_amode, tops) ->
+    returnFlt (AbsCNop, tops `mkAbsCStmts` CRetUnVector label new_amode)
+
+flatAbsC (CFlatRetVector label amodes)
+  = flatAmodes amodes	`thenFlt` \ (new_amodes, tops) ->
+    returnFlt (AbsCNop, tops `mkAbsCStmts` CFlatRetVector label new_amodes)
+
+flatAbsC cc@(CCostCentreDecl _ _)  -- at top, already flat
+  = returnFlt (AbsCNop, cc)
+
+-- now the real stmts:
+
+flatAbsC (CAssign dest source)
+  = flatAmode dest    `thenFlt` \ (dest_amode, dest_tops) ->
+    flatAmode source  `thenFlt` \ (src_amode,  src_tops)  ->
+    returnFlt ( CAssign dest_amode src_amode, mkAbsCStmts dest_tops src_tops )
+
+-- special case: jump to some anonymous code
+flatAbsC (CJump (CCode abs_C)) = flatAbsC abs_C
+
+flatAbsC (CJump target)
+  = flatAmode target `thenFlt` \ (targ_amode, targ_tops) ->
+    returnFlt ( CJump targ_amode, targ_tops )
+
+flatAbsC (CFallThrough target)
+  = flatAmode target `thenFlt` \ (targ_amode, targ_tops) ->
+    returnFlt ( CFallThrough targ_amode, targ_tops )
+
+flatAbsC (CReturn target return_info)
+  = flatAmode target `thenFlt` \ (targ_amode, targ_tops) ->
+    returnFlt ( CReturn targ_amode return_info, targ_tops )
+
+flatAbsC (CSwitch discrim alts deflt)
+  = flatAmode discrim		 `thenFlt` \ (discrim_amode, discrim_tops) ->
+    mapAndUnzipFlt flat_alt alts `thenFlt` \ (flat_alts, flat_alts_tops) ->
+    flatAbsC deflt		 `thenFlt` \ (flat_def_alt, def_tops) ->
+    returnFlt (
+      CSwitch discrim_amode flat_alts flat_def_alt,
+      mkAbstractCs (discrim_tops : def_tops : flat_alts_tops)
+    )
+  where
+    flat_alt (tag, absC)
+      = flatAbsC absC	`thenFlt` \ (alt_heres, alt_tops) ->
+	returnFlt ( (tag, alt_heres), alt_tops )
+
+flatAbsC stmt@(CInitHdr a b cc u)
+  = flatAmode cc	`thenFlt` \ (new_cc, tops) ->
+    returnFlt (CInitHdr a b new_cc u, tops)
+
+flatAbsC stmt@(COpStmt results op args liveness_mask vol_regs)
+  = flatAmodes results		`thenFlt` \ (results_here, tops1) ->
+    flatAmodes args		`thenFlt` \ (args_here,    tops2) ->
+    returnFlt (COpStmt results_here op args_here liveness_mask vol_regs,
+		mkAbsCStmts tops1 tops2)
+
+flatAbsC stmt@(CSimultaneous abs_c)
+  = flatAbsC abs_c		`thenFlt` \ (stmts_here, tops) ->
+    doSimultaneously stmts_here	`thenFlt` \ new_stmts_here ->
+    returnFlt (new_stmts_here, tops)
+
+flatAbsC stmt@(CMacroStmt macro amodes)
+  = flatAmodes amodes		`thenFlt` \ (amodes_here, tops) ->
+    returnFlt (CMacroStmt macro amodes_here, tops)
+
+flatAbsC stmt@(CCallProfCtrMacro str amodes)
+  = flatAmodes amodes		`thenFlt` \ (amodes_here, tops) ->
+    returnFlt (CCallProfCtrMacro str amodes_here, tops)
+
+flatAbsC stmt@(CCallProfCCMacro str amodes)
+  = flatAmodes amodes		`thenFlt` \ (amodes_here, tops) ->
+    returnFlt (CCallProfCCMacro str amodes_here, tops)
+
+flatAbsC stmt@(CSplitMarker) = returnFlt (AbsCNop, stmt)
+\end{code}
+
+%************************************************************************
+%*									*
+\subsection[flat-amodes]{Flattening addressing modes}
+%*									*
+%************************************************************************
+
+\begin{code}
+flatAmode :: CAddrMode -> FlatM (CAddrMode, AbstractC)
+
+-- easy ones first
+flatAmode amode@(CVal _ _)	= returnFlt (amode, AbsCNop)
+
+flatAmode amode@(CAddr _)	= returnFlt (amode, AbsCNop)
+flatAmode amode@(CReg _)	= returnFlt (amode, AbsCNop)
+flatAmode amode@(CTemp _ _)	= returnFlt (amode, AbsCNop)
+flatAmode amode@(CLbl _ _)	= returnFlt (amode, AbsCNop)
+flatAmode amode@(CUnVecLbl _ _)	= returnFlt (amode, AbsCNop)
+flatAmode amode@(CString _)	= returnFlt (amode, AbsCNop)
+flatAmode amode@(CLit _)	= returnFlt (amode, AbsCNop)
+flatAmode amode@(CLitLit _ _)	= returnFlt (amode, AbsCNop)
+flatAmode amode@(COffset _)	= returnFlt (amode, AbsCNop)
+
+-- CIntLike must be a literal -- no flattening
+flatAmode amode@(CIntLike int)  = returnFlt(amode, AbsCNop)
+
+-- CCharLike may be arbitrary value -- have to flatten
+flatAmode amode@(CCharLike char)
+  = flatAmode char	`thenFlt` \ (flat_char, tops) ->
+    returnFlt(CCharLike flat_char, tops)
+
+flatAmode (CJoinPoint _ _) = panic "flatAmode:CJoinPoint"
+
+flatAmode (CLabelledCode label abs_C)
+  -- Push the code (with this label) to the top level
+  = flatAbsC abs_C	`thenFlt` \ (body_code, tops) ->
+    returnFlt (CLbl label CodePtrRep,
+	       tops `mkAbsCStmts` CCodeBlock label body_code)
+
+flatAmode (CCode abs_C)
+  = case mkAbsCStmtList abs_C of
+      [CJump amode] -> flatAmode amode	-- Elide redundant labels
+      _ ->
+	-- de-anonymous-ise the code and push it (labelled) to the top level
+	getUniqFlt 		`thenFlt` \ new_uniq ->
+	BIND (mkReturnPtLabel new_uniq)    _TO_ return_pt_label ->
+	flatAbsC abs_C	`thenFlt` \ (body_code, tops) ->
+	returnFlt (
+	    CLbl return_pt_label CodePtrRep,
+	    tops `mkAbsCStmts` CCodeBlock return_pt_label body_code
+	    -- DO NOT TOUCH the stuff sent to the top...
+	)
+	BEND
+
+flatAmode (CTableEntry base index kind)
+  = flatAmode base    	`thenFlt` \ (base_amode, base_tops) ->
+    flatAmode index 	`thenFlt` \ (ix_amode,  ix_tops)  ->
+    returnFlt ( CTableEntry base_amode ix_amode kind, mkAbsCStmts base_tops ix_tops )
+
+flatAmode (CMacroExpr pk macro amodes)
+  = flatAmodes amodes    	`thenFlt` \ (amodes_here, tops) ->
+    returnFlt ( CMacroExpr pk macro amodes_here, tops )
+
+flatAmode amode@(CCostCentre _ _) = returnFlt (amode, AbsCNop)
+\end{code}
+
+And a convenient way to do a whole bunch of 'em.
+\begin{code}
+flatAmodes :: [CAddrMode] -> FlatM ([CAddrMode], AbstractC)
+
+flatAmodes [] = returnFlt ([], AbsCNop)
+
+flatAmodes amodes
+  = mapAndUnzipFlt flatAmode amodes `thenFlt` \ (amodes_here, tops) ->
+    returnFlt (amodes_here, mkAbstractCs tops)
+\end{code}
+
+%************************************************************************
+%*									*
+\subsection[flat-simultaneous]{Doing things simultaneously}
+%*									*
+%************************************************************************
+
+\begin{code}
+doSimultaneously :: AbstractC -> FlatM AbstractC
+\end{code}
+
+Generate code to perform the @CAssign@s and @COpStmt@s in the
+input simultaneously, using temporary variables when necessary.
+
+We use the strongly-connected component algorithm, in which
+	* the vertices are the statements
+	* an edge goes from s1 to s2 iff
+		s1 assigns to something s2 uses
+	  that is, if s1 should *follow* s2 in the final order
+
+ADR Comment
+
+Wow - fancy stuff.  But are we ever going to do anything other than
+assignments in parallel?  If not, wouldn't it be simpler to generate
+the following:
+
+ x1, x2, x3 = e1, e2, e3
+
+    |
+    |
+    V
+ { int t1 = e1;
+   int t2 = e2;
+   int t3 = e3;
+   x1 = t1;
+   x2 = t2;
+   x3 = t3;
+ }
+
+and leave it to the C compiler to figure out whether it needs al
+those variables.
+
+(Likewise, why not let the C compiler delete silly code like
+
+    x = x
+
+for us?)
+
+tnemmoC RDA
+
+\begin{code}
+type CVertex = (Int, AbstractC)  -- Give each vertex a unique number,
+				 -- for fast comparison
+
+type CEdge = (CVertex, CVertex)
+
+doSimultaneously abs_c
+  = let
+	enlisted = en_list abs_c
+    in
+    case enlisted of -- it's often just one stmt
+      []  -> returnFlt AbsCNop
+      [x] -> returnFlt x
+      _   -> doSimultaneously1 (zip [(1::Int)..] enlisted)
+
+-- en_list puts all the assignments in a list, filtering out Nops and
+-- assignments which do nothing
+en_list AbsCNop				      = []
+en_list (AbsCStmts a1 a2)		      = en_list a1 ++ en_list a2
+en_list (CAssign am1 am2) | sameAmode am1 am2 = []
+en_list other				      = [other]
+
+sameAmode :: CAddrMode -> CAddrMode -> Bool
+-- ToDo: Move this function, or make CAddrMode an instance of Eq
+-- At the moment we put in just enough to catch the cases we want:
+-- 	the second (destination) argument is always a CVal.
+sameAmode (CReg r1)		     (CReg r2)		     = r1 == r2
+sameAmode (CVal (SpARel r1 v1) _) (CVal (SpARel r2 v2) _) = r1 == r2 && v1 == v2
+sameAmode (CVal (SpBRel r1 v1) _) (CVal (SpBRel r2 v2) _) = r1 == r2 && v1 == v2
+sameAmode other1		     other2		     = False
+
+doSimultaneously1 :: [CVertex] -> FlatM AbstractC
+doSimultaneously1 vertices
+  = let
+	edges :: [CEdge]
+	edges = concat (map edges_from vertices)
+
+	edges_from :: CVertex -> [CEdge]
+	edges_from v1 = [(v1,v2) | v2 <- vertices, v1 `should_follow` v2]
+
+	should_follow :: CVertex -> CVertex -> Bool
+	(n1, CAssign dest1 _) `should_follow` (n2, CAssign _ src2)
+	  = dest1 `conflictsWith` src2
+	(n1, COpStmt dests1 _ _ _ _) `should_follow` (n2, CAssign _ src2)
+	  = or [dest1 `conflictsWith` src2 | dest1 <- dests1]
+	(n1, CAssign dest1 _)`should_follow` (n2, COpStmt _ _ srcs2 _ _)
+	  = or [dest1 `conflictsWith` src2 | src2 <- srcs2]
+	(n1, COpStmt dests1 _ _ _ _) `should_follow` (n2, COpStmt _ _ srcs2 _ _)
+	  = or [dest1 `conflictsWith` src2 | dest1 <- dests1, src2 <- srcs2]
+
+--	(_, COpStmt _ _ _ _ _) `should_follow` (_, CCallProfCtrMacro _ _) = False
+--	(_, CCallProfCtrMacro _ _) `should_follow` (_, COpStmt _ _ _ _ _) = False
+
+	eq_vertex :: CVertex -> CVertex -> Bool
+	(n1, _) `eq_vertex` (n2, _) = n1 == n2
+
+	components = stronglyConnComp eq_vertex edges vertices
+
+	-- do_components deal with one strongly-connected component
+	do_component :: [CVertex] -> FlatM AbstractC
+
+	-- A singleton?  Then just do it.
+	do_component [(n,abs_c)] = returnFlt abs_c
+
+	-- Two or more?  Then go via temporaries.
+	do_component ((n,first_stmt):rest)
+	  = doSimultaneously1 rest	`thenFlt` \ abs_cs ->
+	    go_via_temps first_stmt	`thenFlt` \ (to_temps, from_temps) ->
+	    returnFlt (mkAbstractCs [to_temps, abs_cs, from_temps])
+
+	go_via_temps (CAssign dest src)
+	  = getUniqFlt 			`thenFlt` \ uniq ->
+	    let
+		the_temp = CTemp uniq (getAmodeRep dest)
+	    in
+	    returnFlt (CAssign the_temp src, CAssign dest the_temp)
+
+	go_via_temps (COpStmt dests op srcs liveness_mask vol_regs)
+	  = getUniqsFlt (length dests)	`thenFlt` \ uniqs ->
+	    let
+		the_temps = zipWith (\ u d -> CTemp u (getAmodeRep d)) uniqs dests
+	    in
+	    returnFlt (COpStmt the_temps op srcs liveness_mask vol_regs,
+		       mkAbstractCs (zipWith CAssign dests the_temps))
+    in
+    mapFlt do_component components `thenFlt` \ abs_cs ->
+    returnFlt (mkAbstractCs abs_cs)
+\end{code}
+
+
+@conflictsWith@ tells whether an assignment to its first argument will
+screw up an access to its second.
+
+\begin{code}
+conflictsWith :: CAddrMode -> CAddrMode -> Bool
+(CReg reg1)	   `conflictsWith` (CReg reg2)		= reg1 == reg2
+(CReg reg)	   `conflictsWith` (CVal reg_rel _)	= reg `regConflictsWithRR` reg_rel
+(CReg reg)	   `conflictsWith` (CAddr reg_rel)	= reg `regConflictsWithRR` reg_rel
+(CTemp u1 _)	   `conflictsWith` (CTemp u2 _)		= u1 == u2
+(CVal reg_rel1 k1) `conflictsWith` (CVal reg_rel2 k2)
+  = rrConflictsWithRR (getPrimRepSize k1) (getPrimRepSize k2) reg_rel1 reg_rel2
+
+other1		  `conflictsWith` other2		= False
+-- CAddr and literals are impossible on the LHS of an assignment
+
+regConflictsWithRR :: MagicId -> RegRelative -> Bool
+
+regConflictsWithRR (VanillaReg k ILIT(1)) (NodeRel _)	= True
+
+regConflictsWithRR SpA	(SpARel _ _)	= True
+regConflictsWithRR SpB	(SpBRel _ _)	= True
+regConflictsWithRR Hp	(HpRel _ _)	= True
+regConflictsWithRR _	_		= False
+
+rrConflictsWithRR :: Int -> Int			-- Sizes of two things
+		  -> RegRelative -> RegRelative -- The two amodes
+		  -> Bool
+
+rrConflictsWithRR s1 s2 rr1 rr2 = rr rr1 rr2
+  where
+    rr (SpARel p1 o1)    (SpARel p2 o2)
+	| s1 == 0 || s2 == 0 = False	-- No conflict if either is size zero
+	| s1 == 1 && s2 == 1 = b1 == b2
+	| otherwise	     = (b1+s1) >= b2  &&
+			       (b2+s2) >= b1
+	where
+	  b1 = p1-o1
+	  b2 = p2-o2
+
+    rr (SpBRel p1 o1)    (SpBRel p2 o2)
+	| s1 == 0 || s2 == 0 = False	-- No conflict if either is size zero
+	| s1 == 1 && s2 == 1 = b1 == b2
+	| otherwise	     = (b1+s1) >= b2  &&
+			       (b2+s2) >= b1
+	where
+	  b1 = p1-o1
+	  b2 = p2-o2
+
+    rr (NodeRel o1)	 (NodeRel o2)
+	| s1 == 0 || s2 == 0 = False	-- No conflict if either is size zero
+	| s1 == 1 && s2 == 1 = o1 `possiblyEqualHeapOffset` o2
+	| otherwise	     = True		-- Give up
+
+    rr (HpRel _ _)	 (HpRel _ _)    = True	-- Give up
+
+    rr other1	         other2	        = False
+\end{code}
diff --git a/ghc/compiler/absCSyn/CLabel.lhs b/ghc/compiler/absCSyn/CLabel.lhs
new file mode 100644
index 0000000000..2ecbd17348
--- /dev/null
+++ b/ghc/compiler/absCSyn/CLabel.lhs
@@ -0,0 +1,402 @@
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+%
+\section[CLabel]{@CLabel@: Information to make C Labels}
+
+\begin{code}
+#include "HsVersions.h"
+
+module CLabel (
+	CLabel,	-- abstract type
+
+	mkClosureLabel,
+	mkInfoTableLabel,
+	mkStdEntryLabel,
+	mkFastEntryLabel,
+	mkConEntryLabel,
+	mkStaticConEntryLabel,
+	mkRednCountsLabel,
+	mkPhantomInfoTableLabel,
+	mkStaticInfoTableLabel,
+	mkVapEntryLabel,
+	mkVapInfoTableLabel,
+
+	mkConUpdCodePtrVecLabel,
+	mkStdUpdCodePtrVecLabel,
+
+	mkInfoTableVecTblLabel,
+	mkStdUpdVecTblLabel,
+
+	mkReturnPtLabel,
+	mkVecTblLabel,
+	mkAltLabel,
+	mkDefaultLabel,
+
+	mkAsmTempLabel,
+
+	mkErrorStdEntryLabel,
+	mkBlackHoleInfoTableLabel,
+
+	needsCDecl, isReadOnly, isAsmTemp, externallyVisibleCLabel,
+
+	pprCLabel
+
+#ifdef GRAN
+	, isSlowEntryCCodeBlock
+#endif
+
+	-- and to make the interface self-sufficient...
+    ) where
+
+import Ubiq{-uitous-}
+
+import Id		( externallyVisibleId, cmpId_withSpecDataCon,
+			  isDataCon, isDictFunId,
+			  isConstMethodId_maybe, isClassOpId,
+			  isDefaultMethodId_maybe,
+			  isSuperDictSelId_maybe, fIRST_TAG,
+			  DataCon(..), ConTag(..), Id
+			)
+import Maybes		( maybeToBool )
+import Unpretty		-- NOTE!! ********************
+{-
+import Outputable
+import Pretty		( ppNil, ppChar, ppStr, ppPStr, ppDouble, ppInt,
+			  ppInteger, ppBeside, ppIntersperse, prettyToUn
+			)
+#ifdef USE_ATTACK_PRAGMAS
+import CharSeq
+#endif
+import Unique		( pprUnique, showUnique, Unique )
+import Util
+
+-- Sigh...  Shouldn't this file (CLabel) live in codeGen?
+import CgRetConv    	( CtrlReturnConvention(..), ctrlReturnConvAlg )
+-}
+\end{code}
+
+things we want to find out:
+
+* should the labelled things be declared "static" (visible only in this file)?
+
+* should it be declared "const" (read-only text space)?
+
+* does it need declarations at all? (v common Prelude things are pre-declared)
+
+\begin{code}
+data CLabel
+  = IdLabel	    		-- A family of labels related to the
+	CLabelId		-- definition of a particular Id
+	IdLabelInfo		-- Includes DataCon
+
+  | TyConLabel			-- A family of labels related to the
+	TyCon			-- definition of a data type
+	TyConLabelInfo
+
+  | CaseLabel			-- A family of labels related to a particular case expression
+	Unique			-- Unique says which case expression
+	CaseLabelInfo
+
+  | AsmTempLabel    Unique
+
+  | RtsLabel	    RtsLabelInfo
+
+  deriving (Eq, Ord)
+\end{code}
+
+The CLabelId is simply so we can declare alternative Eq and Ord
+instances which use cmpId_SpecDataCon (instead of cmpId). This avoids
+comparing the Uniques of two specialised data constructors (which have
+the same as the uniques their respective unspecialised data
+constructors). Instead, the specialising types and the uniques of the
+unspecialised constructors are compared.
+
+\begin{code}
+data CLabelId = CLabelId Id
+
+instance Eq CLabelId where
+    CLabelId a == CLabelId b = case cmpId_withSpecDataCon a b of { EQ_ -> True;  _ -> False }
+    CLabelId a /= CLabelId b = case cmpId_withSpecDataCon a b of { EQ_ -> False; _ -> True  }
+
+instance Ord CLabelId where
+    CLabelId a <= CLabelId b = case cmpId_withSpecDataCon a b
+	 of { LT_ -> True;  EQ_ -> True;  GT__ -> False }
+    CLabelId a <  CLabelId b = case cmpId_withSpecDataCon a b
+	 of { LT_ -> True;  EQ_ -> False; GT__ -> False }
+    CLabelId a >= CLabelId b = case cmpId_withSpecDataCon a b
+	 of { LT_ -> False; EQ_ -> True;  GT__ -> True  }
+    CLabelId a >  CLabelId b = case cmpId_withSpecDataCon a b
+	 of { LT_ -> False; EQ_ -> False; GT__ -> True  }
+    _tagCmp (CLabelId a) (CLabelId b) = case cmpId_withSpecDataCon a b
+	 of { LT_ -> _LT; EQ_ -> _EQ; GT__ -> _GT }
+\end{code}
+
+\begin{code}
+data IdLabelInfo
+  = Closure		-- Label for (static???) closure
+
+  | InfoTbl		-- Info table for a closure; always read-only
+
+  | EntryStd		-- Thunk, or "slow", code entry point (requires arg satis check)
+  | EntryFast Int	-- entry pt when no arg satisfaction chk needed;
+			-- Int is the arity of the function (to be
+			-- encoded into the name)
+
+  | ConEntry		-- the only kind of entry pt for constructors
+  | StaticConEntry  	-- static constructor entry point
+
+  | StaticInfoTbl   	-- corresponding info table
+
+  | PhantomInfoTbl  	-- for phantom constructors that only exist in regs
+
+  | VapInfoTbl Bool	-- True <=> the update-reqd version; False <=> the no-update-reqd version
+  | VapEntry Bool
+
+	-- Ticky-ticky counting
+  | RednCounts		-- Label of place to keep reduction-count info for this Id
+  deriving (Eq, Ord)
+
+
+data TyConLabelInfo
+  = UnvecConUpdCode	 -- Update code for the data type if it's unvectored
+
+  | VecConUpdCode ConTag -- One for each constructor which returns in
+		    	 -- regs; this code actually performs an update
+
+  | StdUpdCode ConTag	 -- Update code for all constructors which return
+    	    	    	 -- in heap.  There are a small number of variants,
+    	    	    	 -- so that the update code returns (vectored/n or
+			 -- unvectored) in the right way.
+			 -- ToDo: maybe replace TyCon/Int with return conv.
+
+  | InfoTblVecTbl	 -- For tables of info tables
+
+  | StdUpdVecTbl	 -- Labels the update code, or table of update codes,
+			 -- for a particular type.
+  deriving (Eq, Ord)
+
+data CaseLabelInfo
+  = CaseReturnPt
+  | CaseVecTbl
+  | CaseAlt ConTag
+  | CaseDefault
+  deriving (Eq, Ord)
+
+data RtsLabelInfo
+  = RtsShouldNeverHappenCode
+
+  | RtsBlackHoleInfoTbl
+
+  | RtsSelectorInfoTbl	-- Selectors
+	Bool		-- True <=> the update-reqd version;
+			-- False <=> the no-update-reqd version
+	Int		-- 0-indexed Offset from the "goods"
+
+  | RtsSelectorEntry	-- Ditto entry code
+	Bool
+	Int
+  deriving (Eq, Ord)
+\end{code}
+
+\begin{code}
+mkClosureLabel	      	id 		= IdLabel (CLabelId id) Closure
+mkInfoTableLabel      	id 		= IdLabel (CLabelId id) InfoTbl
+mkStdEntryLabel	      	id 		= IdLabel (CLabelId id) EntryStd
+mkFastEntryLabel      	id arity	= ASSERT(arity > 0)
+					  IdLabel (CLabelId id) (EntryFast arity)
+mkConEntryLabel	      	id		= IdLabel (CLabelId id) ConEntry
+mkStaticConEntryLabel 	id		= IdLabel (CLabelId id) StaticConEntry
+mkRednCountsLabel     	id		= IdLabel (CLabelId id) RednCounts
+mkPhantomInfoTableLabel id		= IdLabel (CLabelId id) PhantomInfoTbl
+mkStaticInfoTableLabel  id		= IdLabel (CLabelId id) StaticInfoTbl
+mkVapEntryLabel		id upd_flag	= IdLabel (CLabelId id) (VapEntry upd_flag)
+mkVapInfoTableLabel	id upd_flag	= IdLabel (CLabelId id) (VapInfoTbl upd_flag)
+
+mkConUpdCodePtrVecLabel   tycon tag = TyConLabel tycon (VecConUpdCode tag)
+mkStdUpdCodePtrVecLabel   tycon tag = TyConLabel tycon (StdUpdCode tag)
+
+mkInfoTableVecTblLabel	  tycon     = TyConLabel tycon InfoTblVecTbl
+mkStdUpdVecTblLabel	  tycon     = TyConLabel tycon StdUpdVecTbl
+
+mkReturnPtLabel uniq		= CaseLabel uniq CaseReturnPt
+mkVecTblLabel   uniq		= CaseLabel uniq CaseVecTbl
+mkAltLabel      uniq tag	= CaseLabel uniq (CaseAlt tag)
+mkDefaultLabel  uniq 		= CaseLabel uniq CaseDefault
+
+mkAsmTempLabel 			= AsmTempLabel
+
+	-- Some fixed runtime system labels
+
+mkErrorStdEntryLabel		= RtsLabel RtsShouldNeverHappenCode
+mkBlackHoleInfoTableLabel	= RtsLabel RtsBlackHoleInfoTbl
+\end{code}
+
+\begin{code}
+needsCDecl :: CLabel -> Bool	-- False <=> it's pre-declared; don't bother
+isReadOnly :: CLabel -> Bool	-- lives in C "text space"
+isAsmTemp  :: CLabel -> Bool    -- is a local temporary for native code generation
+externallyVisibleCLabel :: CLabel -> Bool -- not C "static"
+\end{code}
+
+@needsCDecl@ is @True@ unless the thing is a deeply-@PreludeCore@-ish
+object.  {\em Also:} No need to spit out labels for things generated
+by the flattener (in @AbsCUtils@)---it is careful to ensure references
+to them are always backwards.  These are return-point and vector-table
+labels.
+
+Declarations for (non-prelude) @Id@-based things are needed because of
+mutual recursion.
+\begin{code}
+needsCDecl (IdLabel _ _)	       = True
+needsCDecl (CaseLabel _ _)	       = False
+
+needsCDecl (TyConLabel _ (StdUpdCode _)) = False
+needsCDecl (TyConLabel _ InfoTblVecTbl)  = False
+needsCDecl (TyConLabel _ other)          = True
+
+needsCDecl (AsmTempLabel _)            = False
+needsCDecl (RtsLabel _)                = False
+
+needsCDecl other		       = True
+\end{code}
+
+Whether the labelled thing can be put in C "text space":
+\begin{code}
+isReadOnly (IdLabel _ InfoTbl)	       = True  -- info-tables: yes
+isReadOnly (IdLabel _ StaticInfoTbl)   = True  -- and so on, for other
+isReadOnly (IdLabel _ PhantomInfoTbl)  = True
+isReadOnly (IdLabel _ (VapInfoTbl _))  = True
+isReadOnly (IdLabel _ other)	       = False -- others: pessimistically, no
+
+isReadOnly (TyConLabel _ _)    = True
+isReadOnly (CaseLabel _ _)     = True
+isReadOnly (AsmTempLabel _)    = True
+isReadOnly (RtsLabel _)        = True
+\end{code}
+
+Whether the label is an assembler temporary:
+\begin{code}
+isAsmTemp (AsmTempLabel _) = True
+isAsmTemp _ 	    	   = False
+\end{code}
+
+C ``static'' or not...
+\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
+  | isClassOpId id	  = True
+  | 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)
+\end{code}
+
+These GRAN functions are needed for spitting out GRAN_FETCH() at the
+right places. It is used to detect when the abstractC statement of an
+CCodeBlock actually contains the code for a slow entry point.  -- HWL
+
+\begin{code}
+#ifdef GRAN
+
+isSlowEntryCCodeBlock :: CLabel -> Bool
+isSlowEntryCCodeBlock _ = False
+-- Worth keeping?  ToDo (WDP)
+
+#endif {-GRAN-}
+\end{code}
+
+We need at least @Eq@ for @CLabels@, because we want to avoid
+duplicate declarations in generating C (see @labelSeenTE@ in
+@PprAbsC@).
+
+\begin{code}
+pprCLabel :: PprStyle -> CLabel -> Unpretty
+
+pprCLabel (PprForAsm _ _ fmtAsmLbl) (AsmTempLabel u)
+  = uppStr (fmtAsmLbl (_UNPK_ (showUnique u)))
+
+pprCLabel (PprForAsm sw_chker prepend_cSEP _) lbl
+  = if prepend_cSEP
+    then uppBeside pp_cSEP prLbl
+    else prLbl
+  where
+    prLbl = pprCLabel (PprForC sw_chker) lbl
+
+pprCLabel sty (TyConLabel tc UnvecConUpdCode)
+  = uppBesides [uppPStr SLIT("ret"), pp_cSEP, uppStr (showTyCon sty tc),
+	       pp_cSEP, uppPStr SLIT("upd")]
+
+pprCLabel sty (TyConLabel tc (VecConUpdCode tag))
+  = uppBesides [uppPStr SLIT("ret"), pp_cSEP, uppStr (showTyCon sty tc), pp_cSEP,
+		     uppInt tag, pp_cSEP, uppPStr SLIT("upd")]
+
+pprCLabel sty (TyConLabel tc (StdUpdCode tag))
+  = case (ctrlReturnConvAlg tc) of
+	UnvectoredReturn _ -> uppPStr SLIT("IndUpdRetDir")
+    	VectoredReturn _ -> uppBeside (uppPStr SLIT("IndUpdRetV")) (uppInt (tag - fIRST_TAG))
+
+pprCLabel sty (TyConLabel tc InfoTblVecTbl)
+  = uppBesides [uppStr (showTyCon sty tc), pp_cSEP, uppPStr SLIT("itblvtbl")]
+
+pprCLabel sty (TyConLabel tc StdUpdVecTbl)
+  = uppBesides [uppPStr SLIT("vtbl"), pp_cSEP, uppStr (showTyCon sty tc),
+    	       pp_cSEP, uppPStr SLIT("upd")]
+
+pprCLabel sty (CaseLabel u CaseReturnPt)
+  = uppBesides [uppPStr SLIT("ret"), pp_cSEP, ppr_u u]
+pprCLabel sty (CaseLabel u CaseVecTbl)
+  = uppBesides [uppPStr SLIT("vtbl"), pp_cSEP, ppr_u u]
+pprCLabel sty (CaseLabel u (CaseAlt tag))
+  = uppBesides [uppPStr SLIT("djn"), pp_cSEP, ppr_u u, pp_cSEP, uppInt tag]
+pprCLabel sty (CaseLabel u CaseDefault)
+  = uppBesides [uppPStr SLIT("djn"), pp_cSEP, ppr_u u]
+
+pprCLabel sty (RtsLabel RtsShouldNeverHappenCode) = uppPStr SLIT("StdErrorCode")
+
+pprCLabel sty (RtsLabel RtsBlackHoleInfoTbl) = uppPStr SLIT("BH_UPD_info")
+
+pprCLabel sty (RtsLabel (RtsSelectorInfoTbl upd_reqd offset))
+  = uppBesides [uppPStr SLIT("__sel_info_"), uppStr (show offset),
+		uppStr (if upd_reqd then "upd" else "noupd"),
+		uppPStr SLIT("__")]
+
+pprCLabel sty (RtsLabel (RtsSelectorEntry upd_reqd offset))
+  = uppBesides [uppPStr SLIT("__sel_entry_"), uppStr (show offset),
+		uppStr (if upd_reqd then "upd" else "noupd"),
+		uppPStr SLIT("__")]
+
+pprCLabel sty (IdLabel (CLabelId id) flavor)
+  = uppBeside (prettyToUn (ppr sty id)) (ppFlavor flavor)
+
+ppr_u u = prettyToUn (pprUnique u)
+
+ppFlavor :: IdLabelInfo -> Unpretty
+
+ppFlavor x = uppBeside pp_cSEP
+	     	      (case x of
+		       Closure	    	-> uppPStr SLIT("closure")
+		       InfoTbl	    	-> uppPStr SLIT("info")
+		       EntryStd	    	-> uppPStr SLIT("entry")
+		       EntryFast arity	-> --false:ASSERT (arity > 0)
+					   uppBeside (uppPStr SLIT("fast")) (uppInt arity)
+		       ConEntry	    	-> uppPStr SLIT("entry")
+		       StaticConEntry  	-> uppPStr SLIT("static_entry")
+		       StaticInfoTbl 	-> uppPStr SLIT("static_info")
+		       PhantomInfoTbl 	-> uppPStr SLIT("inregs_info")
+		       VapInfoTbl True  -> uppPStr SLIT("vap_info")
+		       VapInfoTbl False -> uppPStr SLIT("vap_noupd_info")
+		       VapEntry True    -> uppPStr SLIT("vap_entry")
+		       VapEntry False   -> uppPStr SLIT("vap_noupd_entry")
+		       RednCounts	-> uppPStr SLIT("ct")
+		      )
+\end{code}
+
diff --git a/ghc/compiler/absCSyn/CStrings.lhs b/ghc/compiler/absCSyn/CStrings.lhs
new file mode 100644
index 0000000000..aaf04bcfdc
--- /dev/null
+++ b/ghc/compiler/absCSyn/CStrings.lhs
@@ -0,0 +1,153 @@
+This module deals with printing (a) C string literals and (b) C labels.
+
+\begin{code}
+#include "HsVersions.h"
+
+module CStrings(
+
+	cSEP,
+	pp_cSEP,
+
+	identToC, modnameToC,
+	stringToC, charToC,
+	charToEasyHaskell
+
+  ) where
+
+CHK_Ubiq() -- debugging consistency check
+
+import Pretty
+import Unpretty( uppChar )
+\end{code}
+
+
+\begin{verbatim}
+_ is the main separator
+
+orig		becomes
+****		*******
+_		Zu
+'		Zq (etc for ops ??)
+<funny char>	Z[hex-digit][hex-digit]
+Prelude<x>	ZP<x>
+<std class>	ZC<?>
+<std tycon>	ZT<?>
+\end{verbatim}
+
+\begin{code}
+cSEP    = SLIT("_")	-- official C separator
+pp_cSEP = uppChar '_'
+
+identToC    :: FAST_STRING -> Pretty
+modnameToC  :: FAST_STRING -> FAST_STRING
+stringToC   :: String -> String
+charToC, charToEasyHaskell :: Char -> String
+
+-- stringToC: the hassle is what to do w/ strings like "ESC 0"...
+
+stringToC ""  = ""
+stringToC [c] = charToC c
+stringToC (c:cs)
+    -- if we have something "octifiable" in "c", we'd better "octify"
+    -- the rest of the string, too.
+  = if (c < ' ' || c > '~')
+    then (charToC c) ++ (concat (map char_to_C cs))
+    else (charToC c) ++ (stringToC cs)
+  where
+    char_to_C c | c == '\n' = "\\n"	-- use C escapes when we can
+		| c == '\a' = "\\a"
+		| c == '\b' = "\\b"	-- ToDo: chk some of these...
+		| c == '\r' = "\\r"
+		| c == '\t' = "\\t"
+		| c == '\f' = "\\f"
+		| c == '\v' = "\\v"
+		| otherwise = '\\' : (octify (ord c))
+
+charToC c = if (c >= ' ' && c <= '~')	-- non-portable...
+	    then case c of
+		  '\'' -> "\\'"
+		  '\\' -> "\\\\"
+		  '"'  -> "\\\""
+		  '\n' -> "\\n"
+		  '\a' -> "\\a"
+		  '\b' -> "\\b"
+		  '\r' -> "\\r"
+		  '\t' -> "\\t"
+		  '\f' -> "\\f"
+		  '\v' -> "\\v"
+		  _    -> [c]
+	    else '\\' : (octify (ord c))
+
+-- really: charToSimpleHaskell
+
+charToEasyHaskell c
+  = if (c >= 'a' && c <= 'z')
+    || (c >= 'A' && c <= 'Z')
+    || (c >= '0' && c <= '9')
+    then [c]
+    else case c of
+	  _    -> '\\' : 'o' : (octify (ord c))
+
+octify :: Int -> String
+octify n
+  = if n < 8 then
+	[chr (n + ord '0')]
+    else
+	octify (n `quot` 8) ++ [chr (n `rem` 8 + ord '0')]
+
+identToC ps
+  = let
+	str = _UNPK_ ps
+    in
+    ppBeside
+	(case str of
+	   's':'t':'d':_ -> -- avoid "stdin", "stdout", and "stderr"...
+			    ppChar 'Z'
+	   _	         -> ppNil)
+
+	(if (all isAlphanum str) -- we gamble that this test will succeed...
+	 then ppPStr ps
+	 else ppIntersperse ppNil (map char_to_c str))
+  where
+    char_to_c 'Z'  = ppPStr SLIT("ZZ")
+    char_to_c '&'  = ppPStr SLIT("Za")
+    char_to_c '|'  = ppPStr SLIT("Zb")
+    char_to_c ':'  = ppPStr SLIT("Zc")
+    char_to_c '/'  = ppPStr SLIT("Zd")
+    char_to_c '='  = ppPStr SLIT("Ze")
+    char_to_c '>'  = ppPStr SLIT("Zg")
+    char_to_c '#'  = ppPStr SLIT("Zh")
+    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("Zp")
+    char_to_c '\'' = ppPStr SLIT("Zq")
+    char_to_c '*'  = ppPStr SLIT("Zt")
+    char_to_c '_'  = ppPStr SLIT("Zu")
+
+    char_to_c c    = if isAlphanum c
+		     then ppChar c
+		     else ppBeside (ppChar 'Z') (ppInt (ord c))
+\end{code}
+
+For \tr{modnameToC}, we really only have to worry about \tr{'}s (quote
+chars) in the name.  Rare.
+\begin{code}
+modnameToC ps
+  = let
+	str = _UNPK_ ps
+    in
+    if not (any quote_here str) then
+	ps
+    else
+	_PK_ (concat (map char_to_c str))
+  where
+    quote_here '\'' = True
+    quote_here _    = False
+
+    char_to_c c
+      = if isAlphanum c then [c] else 'Z' : (show (ord c))
+\end{code}
+
+
diff --git a/ghc/compiler/absCSyn/Costs.hi b/ghc/compiler/absCSyn/Costs.hi
deleted file mode 100644
index 9d50cf1ef3..0000000000
--- a/ghc/compiler/absCSyn/Costs.hi
+++ /dev/null
@@ -1,12 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface Costs where
-import AbsCSyn(AbstractC, CAddrMode)
-data CostRes   = Cost (Int, Int, Int, Int, Int)
-data Side   = Lhs | Rhs
-addrModeCosts :: CAddrMode -> Side -> CostRes
-costs :: AbstractC -> CostRes
-nullCosts :: CostRes
-instance Eq CostRes
-instance Num CostRes
-instance Text CostRes
-
diff --git a/ghc/compiler/absCSyn/Costs.lhs b/ghc/compiler/absCSyn/Costs.lhs
index 7b486b4b5a..7a2d9dca84 100644
--- a/ghc/compiler/absCSyn/Costs.lhs
+++ b/ghc/compiler/absCSyn/Costs.lhs
@@ -10,7 +10,7 @@ This module   provides all necessary  functions for   computing for a given
 abstract~C Program the costs of executing that program. This is done by the
 exported function:
 
-\begin{quote} 
+\begin{quote}
  {\verb type CostRes = (Int, Int, Int, Int, Int)}
  {\verb costs :: AbstractC -> CostRes }
 \end{quote}
@@ -25,9 +25,9 @@ The meaning of the result tuple is:
  \item The fourth component ({\tt s}) counts the number of store
    instructions.
  \item The fifth component ({\tt f}) counts the number of floating point
-   instructions. 
+   instructions.
 \end{itemize}
- 
+
 This function is needed in GrAnSim for parallelism.
 
 These are first suggestions for scaling the costs. But, this scaling should be done in the RTS rather than the compiler (this really should be tunable!):
@@ -39,28 +39,28 @@ These are first suggestions for scaling the costs. But, this scaling should be d
 #define INT_ARITHM_COSTS	1
 #define GMP_ARITHM_COSTS	3 {- any clue for GMP costs ? -}
 #define FLOAT_ARITHM_COSTS	3 {- any clue for float costs ? -}
-#define BRANCH_COSTS 		2
+#define BRANCH_COSTS		2
 
 \end{pseudocode}
 
 \begin{code}
 #include "HsVersions.h"
 
-#define ACCUM_COSTS(i,b,l,s,f)  (i+b+l+s+f)
+#define ACCUM_COSTS(i,b,l,s,f)	(i+b+l+s+f)
 
-#define NUM_REGS		10 {- PprAbsCSyn.lhs -}       {- runtime/c-as-asm/CallWrap_C.lc -}
+#define NUM_REGS		10 {- PprAbsCSyn.lhs -}	      {- runtime/c-as-asm/CallWrap_C.lc -}
 #define RESTORE_COSTS		(Cost (0, 0, NUM_REGS, 0, 0)  :: CostRes)
 #define SAVE_COSTS		(Cost (0, 0, 0, NUM_REGS, 0)  :: CostRes)
-#define CCALL_COSTS_GUESS	(Cost (50, 0, 0, 0, 0)        :: CostRes)
+#define CCALL_COSTS_GUESS	(Cost (50, 0, 0, 0, 0)	      :: CostRes)
 
 module Costs( costs,
-              addrModeCosts, CostRes(Cost), nullCosts, Side(..)
+	      addrModeCosts, CostRes(Cost), nullCosts, Side(..)
     ) where
 
-import AbsCFuns
+import AbsCUtils
 import AbsCSyn
-import AbsPrel
-import PrimOps
+import PrelInfo
+import PrimOp
 import TyCon
 import Util
 
@@ -68,7 +68,7 @@ import Util
 #ifndef GRAN
 -- a module of "stubs" that don't do anything
 data CostRes = Cost (Int, Int, Int, Int, Int)
-data Side = Lhs | Rhs 
+data Side = Lhs | Rhs
 
 nullCosts    = Cost (0, 0, 0, 0, 0) :: CostRes
 
@@ -90,21 +90,21 @@ data CostRes = Cost (Int, Int, Int, Int, Int)
 
 nullCosts    = Cost (0, 0, 0, 0, 0) :: CostRes
 initHdrCosts = Cost (2, 0, 0, 1, 0) :: CostRes
-errorCosts   = Cost (-1, -1, -1, -1, -1)  -- just for debugging 
+errorCosts   = Cost (-1, -1, -1, -1, -1)  -- just for debugging
 
 oneArithm = Cost (1, 0, 0, 0, 0) :: CostRes
 
 instance Eq CostRes where
  (==) t1 t2 = i && b && l && s && f
-             where (i,b,l,s,f) = binOp' (==) t1 t2
+	     where (i,b,l,s,f) = binOp' (==) t1 t2
 
 instance Num CostRes where
  (+) = binOp (+)
  (-) = binOp (-)
  (*) = binOp (*)
- negate  = mapOp negate
- abs     = mapOp abs
- signum  = mapOp signum
+ negate	 = mapOp negate
+ abs	 = mapOp abs
+ signum	 = mapOp signum
 
 mapOp :: (Int -> Int) -> CostRes -> CostRes
 mapOp g ( Cost (i, b, l, s, f) )  = Cost (g i, g b, g l, g s, g f)
@@ -113,144 +113,144 @@ foldrOp :: (Int -> a -> a) -> a -> CostRes -> a
 foldrOp o x  ( Cost (i1, b1, l1, s1, f1) )   =
 	i1 `o` ( b1 `o` ( l1 `o` ( s1 `o` ( f1 `o` x))))
 
-binOp :: (Int -> Int -> Int) -> CostRes -> CostRes -> CostRes 
+binOp :: (Int -> Int -> Int) -> CostRes -> CostRes -> CostRes
 binOp o ( Cost (i1, b1, l1, s1, f1) ) ( Cost  (i2, b2, l2, s2, f2) )  =
-        ( Cost (i1 `o` i2, b1 `o` b2, l1 `o` l2, s1 `o` s2, f1 `o` f2) )
+	( Cost (i1 `o` i2, b1 `o` b2, l1 `o` l2, s1 `o` s2, f1 `o` f2) )
 
-binOp' :: (Int -> Int -> a) -> CostRes -> CostRes -> (a,a,a,a,a) 
+binOp' :: (Int -> Int -> a) -> CostRes -> CostRes -> (a,a,a,a,a)
 binOp' o ( Cost (i1, b1, l1, s1, f1) ) ( Cost  (i2, b2, l2, s2, f2) )  =
-         (i1 `o` i2, b1 `o` b2, l1 `o` l2, s1 `o` s2, f1 `o` f2) 
+	 (i1 `o` i2, b1 `o` b2, l1 `o` l2, s1 `o` s2, f1 `o` f2)
 
 -- --------------------------------------------------------------------------
 
-data Side = Lhs | Rhs 
+data Side = Lhs | Rhs
 	    deriving (Eq)
 
 -- --------------------------------------------------------------------------
 
 costs :: AbstractC -> CostRes
 
-costs absC = 
+costs absC =
   case absC of
-   AbsCNop               	->  nullCosts
+   AbsCNop			->  nullCosts
 
-   AbsCStmts absC1 absC2 	-> costs absC1 + costs absC2
+   AbsCStmts absC1 absC2	-> costs absC1 + costs absC2
 
-   CAssign (CReg _) (CReg _)  	-> Cost (1,0,0,0,0)   -- typ.: mov %reg1,%reg2
+   CAssign (CReg _) (CReg _)	-> Cost (1,0,0,0,0)   -- typ.: mov %reg1,%reg2
 
-   CAssign (CReg _) (CTemp _ _) -> Cost (1,0,0,0,0)  
+   CAssign (CReg _) (CTemp _ _) -> Cost (1,0,0,0,0)
 
-   CAssign (CReg _) (CAddr _)   -> Cost (1,0,0,0,0)  -- typ.: add %reg1,<adr>,%reg2
+   CAssign (CReg _) (CAddr _)	-> Cost (1,0,0,0,0)  -- typ.: add %reg1,<adr>,%reg2
 
-   CAssign target_m source_m  	-> addrModeCosts target_m Lhs +
-                                   addrModeCosts source_m Rhs 
+   CAssign target_m source_m	-> addrModeCosts target_m Lhs +
+				   addrModeCosts source_m Rhs
 
-   CJump (CLbl _  _)	      	-> Cost (0,1,0,0,0)  -- no ld for call necessary
+   CJump (CLbl _  _)		-> Cost (0,1,0,0,0)  -- no ld for call necessary
 
-   CJump mode                 	-> addrModeCosts mode Rhs +
+   CJump mode			-> addrModeCosts mode Rhs +
 				   Cost (0,1,0,0,0)
 
-   CFallThrough mode  -> addrModeCosts mode Rhs +               -- chu' 0.24
-		  	 Cost (0,1,0,0,0)
-	
+   CFallThrough mode  -> addrModeCosts mode Rhs +		-- chu' 0.24
+			 Cost (0,1,0,0,0)
+
    CReturn mode info  -> case info of
-    	                  DirectReturn -> addrModeCosts mode Rhs +
-                                          Cost (0,1,0,0,0)
+			  DirectReturn -> addrModeCosts mode Rhs +
+					  Cost (0,1,0,0,0)
 
-		     	    -- i.e. ld address to reg and call reg 
+			    -- i.e. ld address to reg and call reg
 
-	                  DynamicVectoredReturn mode' -> 
-					addrModeCosts mode Rhs + 
+			  DynamicVectoredReturn mode' ->
+					addrModeCosts mode Rhs +
 					addrModeCosts mode' Rhs +
-                                        Cost (0,1,1,0,0)
-				
+					Cost (0,1,1,0,0)
+
 			    {- generates code like this:
 				JMP_(<mode>)[RVREL(<mode'>)];
-			       i.e. 1 possb ld for mode' 
-		     		    1 ld for RVREL
+			       i.e. 1 possb ld for mode'
+				    1 ld for RVREL
 				    1 possb ld for mode
 				    1 call				-}
 
-	                  StaticVectoredReturn _ -> addrModeCosts mode Rhs +
-                                                  Cost (0,1,1,0,0)
+			  StaticVectoredReturn _ -> addrModeCosts mode Rhs +
+						  Cost (0,1,1,0,0)
 
 			    -- as above with mode' fixed to CLit
-		            -- typically 2 ld + 1 call; 1st ld due
-		            -- to CVal as mode
+			    -- typically 2 ld + 1 call; 1st ld due
+			    -- to CVal as mode
 
    CSwitch mode alts absC     -> nullCosts
 				 {- for handling costs of all branches of
 				    a CSwitch see PprAbsC.
-				    Basically: 
-				     Costs for branch = 
-					Costs before CSwitch + 
+				    Basically:
+				     Costs for branch =
+					Costs before CSwitch +
 					addrModeCosts of head +
 					Costs for 1 cond branch +
 					Costs for body of branch
 				 -}
 
-   CCodeBlock _ absC          -> costs absC
+   CCodeBlock _ absC	      -> costs absC
 
    CInitHdr cl_info reg_rel cost_centre inplace_upd -> initHdrCosts
 
 			{- This is more fancy but superflous: The addr modes
 			   are fixed and so the costs are const!
 
-                        argCosts + initHdrCosts
+			argCosts + initHdrCosts
 			where argCosts = addrModeCosts (CAddr reg_rel) Rhs +
 					 addrModeCosts base_lbl +    -- CLbl!
-					 3*addrModeCosts (mkIntCLit 1{- any val -}) 
+					 3*addrModeCosts (mkIntCLit 1{- any val -})
 			-}
 			{- this extends to something like
 			    SET_SPEC_HDR(...)
-		           For costing the args of this macro
+			   For costing the args of this macro
 			   see PprAbsC.lhs where args are inserted -}
 
    COpStmt modes_res primOp modes_args _ _ ->
-	{- 
-           let
-		n = length modes_res 
-	   in 
+	{-
+	   let
+		n = length modes_res
+	   in
 		(0, 0, n, n, 0) +
-                primOpCosts primOp +
-                if primOpNeedsWrapper primOp then SAVE_COSTS + RESTORE_COSTS
-                                             else nullCosts
+		primOpCosts primOp +
+		if primOpNeedsWrapper primOp then SAVE_COSTS + RESTORE_COSTS
+					     else nullCosts
 	   -- ^^HWL
 	-}
-        foldl (+) nullCosts [addrModeCosts mode Lhs | mode <- modes_res]  +
-        foldl (+) nullCosts [addrModeCosts mode Rhs | mode <- modes_args]  +
-        primOpCosts primOp +
-        if primOpNeedsWrapper primOp then SAVE_COSTS + RESTORE_COSTS
-                                     else nullCosts
-                
-   CSimultaneous absC        -> costs absC
+	foldl (+) nullCosts [addrModeCosts mode Lhs | mode <- modes_res]  +
+	foldl (+) nullCosts [addrModeCosts mode Rhs | mode <- modes_args]  +
+	primOpCosts primOp +
+	if primOpNeedsWrapper primOp then SAVE_COSTS + RESTORE_COSTS
+				     else nullCosts
 
-   CMacroStmt   macro modes  -> stmtMacroCosts macro modes
+   CSimultaneous absC	     -> costs absC
 
-   CCallProfCtrMacro   _ _   -> nullCosts  
+   CMacroStmt	macro modes  -> stmtMacroCosts macro modes
+
+   CCallProfCtrMacro   _ _   -> nullCosts
 				  {- we don't count profiling in GrAnSim -}
 
-   CCallProfCCMacro    _ _   -> nullCosts  
+   CCallProfCCMacro    _ _   -> nullCosts
 				  {- we don't count profiling in GrAnSim -}
 
   -- *** the next three [or so...] are DATA (those above are CODE) ***
-  -- as they are data rather than code they all have nullCosts         -- HWL
+  -- as they are data rather than code they all have nullCosts	       -- HWL
 
    CStaticClosure _ _ _ _    -> nullCosts
-			     
+
    CClosureInfoAndCode _ _ _ _ _ _ -> nullCosts
-			     
-   CRetVector _ _ _          -> nullCosts
-			     
-   CRetUnVector _ _          -> nullCosts
-			     
-   CFlatRetVector _ _        -> nullCosts
-			     
-   CCostCentreDecl _ _       -> nullCosts
-			     
-   CClosureUpdInfo _         -> nullCosts
-
-   CSplitMarker              -> nullCosts
+
+   CRetVector _ _ _	     -> nullCosts
+
+   CRetUnVector _ _	     -> nullCosts
+
+   CFlatRetVector _ _	     -> nullCosts
+
+   CCostCentreDecl _ _	     -> nullCosts
+
+   CClosureUpdInfo _	     -> nullCosts
+
+   CSplitMarker		     -> nullCosts
 
 -- ---------------------------------------------------------------------------
 
@@ -261,65 +261,65 @@ addrModeCosts :: CAddrMode -> Side -> CostRes
 addrModeCosts addr_mode side =
   let
     lhs = side == Lhs
-  in 
+  in
   case addr_mode of
     CVal _ _ -> if lhs then Cost (0, 0, 0, 1, 0)
-                       else Cost (0, 0, 1, 0, 0)
+		       else Cost (0, 0, 1, 0, 0)
 
     CAddr _  -> if lhs then Cost (0, 0, 0, 1, 0)  -- ??unchecked
-                       else Cost (0, 0, 1, 0, 0)
+		       else Cost (0, 0, 1, 0, 0)
 
-    CReg _   -> nullCosts        {- loading from, storing to reg is free ! -}
+    CReg _   -> nullCosts	 {- loading from, storing to reg is free ! -}
 				 {- for costing CReg->Creg ops see special -}
-				 {- case in costs fct -}					
+				 {- case in costs fct -}
     CTableEntry base_mode offset_mode kind ->
-                addrModeCosts base_mode side + 
+		addrModeCosts base_mode side +
 		addrModeCosts offset_mode side +
 		Cost (1,0,1,0,0)
 
     CTemp _ _  -> nullCosts	{- if lhs then Cost (0, 0, 0, 1, 0)
-		                          else Cost (0, 0, 1, 0, 0)  -}
+					  else Cost (0, 0, 1, 0, 0)  -}
 	-- ``Temporaries'' correspond to local variables in C, and registers in
 	-- native code.
 	-- I assume they can be somewhat optimized by gcc -- HWL
 
     CLbl _ _   -> if lhs then Cost (0, 0, 0, 1, 0)
-                         else Cost (2, 0, 0, 0, 0)
+			 else Cost (2, 0, 0, 0, 0)
 		  -- Rhs: typically: sethi %hi(lbl),%tmp_reg
-		  --	     	     or    %tmp_reg,%lo(lbl),%target_reg
+		  --		     or	   %tmp_reg,%lo(lbl),%target_reg
 
     CUnVecLbl _ _ -> if lhs then Cost (0, 0, 0, 1, 0)
-                            else Cost (2, 0, 0, 0, 0)
+			    else Cost (2, 0, 0, 0, 0)
 		     -- same as CLbl
 
-    --  Check the following 3 (checked form CLit on)
+    --	Check the following 3 (checked form CLit on)
 
     CCharLike mode -> if lhs then Cost (0, 0, 0, 1, 0)
-                             else Cost (0, 0, 1, 0, 0)
+			     else Cost (0, 0, 1, 0, 0)
 
     CIntLike mode  -> if lhs then Cost (0, 0, 0, 1, 0)
-                             else Cost (0, 0, 1, 0, 0)
+			     else Cost (0, 0, 1, 0, 0)
 
-    CString _      -> if lhs then Cost (0, 0, 0, 1, 0)
-                             else Cost (0, 0, 1, 0, 0)
+    CString _	   -> if lhs then Cost (0, 0, 0, 1, 0)
+			     else Cost (0, 0, 1, 0, 0)
 
-    CLit    _      -> if lhs then nullCosts            -- should never occur
-                             else Cost (1, 0, 0, 0, 0) -- typ.: mov lit,%reg
+    CLit    _	   -> if lhs then nullCosts	       -- should never occur
+			     else Cost (1, 0, 0, 0, 0) -- typ.: mov lit,%reg
 
-    CLitLit _  _   -> if lhs then nullCosts       
-                             else Cost (1, 0, 0, 0, 0) 
+    CLitLit _  _   -> if lhs then nullCosts
+			     else Cost (1, 0, 0, 0, 0)
 		      -- same es CLit
 
-    COffset _      -> if lhs then nullCosts       
-                             else Cost (1, 0, 0, 0, 0) 
+    COffset _	   -> if lhs then nullCosts
+			     else Cost (1, 0, 0, 0, 0)
 		      -- same es CLit
 
-    CCode absC     -> costs absC
+    CCode absC	   -> costs absC
 
     CLabelledCode _ absC  ->  costs absC
 
-    CJoinPoint _ _        -> if lhs then Cost (0, 0, 0, 1, 0)
-                                    else Cost (0, 0, 1, 0, 0)
+    CJoinPoint _ _	  -> if lhs then Cost (0, 0, 0, 1, 0)
+				    else Cost (0, 0, 1, 0, 0)
 
     CMacroExpr _ macro mode_list -> exprMacroCosts side macro mode_list
 
@@ -329,20 +329,20 @@ addrModeCosts addr_mode side =
 
 exprMacroCosts :: Side -> CExprMacro -> [CAddrMode] -> CostRes
 
-exprMacroCosts side macro mode_list = 
+exprMacroCosts side macro mode_list =
   let
-    arg_costs = foldl (+) nullCosts 
+    arg_costs = foldl (+) nullCosts
 		      (map (\ x -> addrModeCosts x Rhs) mode_list)
   in
   arg_costs +
   case macro of
     INFO_PTR   -> if side == Lhs then Cost (0, 0, 0, 1, 0)
-                                 else Cost (0, 0, 1, 0, 0)
-    ENTRY_CODE -> nullCosts                   
+				 else Cost (0, 0, 1, 0, 0)
+    ENTRY_CODE -> nullCosts
     INFO_TAG   -> if side == Lhs then Cost (0, 0, 0, 1, 0)
-                                 else Cost (0, 0, 1, 0, 0)
+				 else Cost (0, 0, 1, 0, 0)
     EVAL_TAG   -> if side == Lhs then Cost (1, 0, 0, 1, 0)
-                                 else Cost (1, 0, 1, 0, 0)
+				 else Cost (1, 0, 1, 0, 0)
 		  -- costs of INFO_TAG + (1,0,0,0,0)
 
 -- ---------------------------------------------------------------------------
@@ -350,59 +350,59 @@ exprMacroCosts side macro mode_list =
 stmtMacroCosts :: CStmtMacro -> [CAddrMode] -> CostRes
 
 stmtMacroCosts macro modes =
-  let 
-    arg_costs =   foldl (+) nullCosts 
-			[addrModeCosts mode Rhs | mode <- modes] 
+  let
+    arg_costs =	  foldl (+) nullCosts
+			[addrModeCosts mode Rhs | mode <- modes]
   in
   case macro of
-    ARGS_CHK_A_LOAD_NODE  ->  Cost (2, 1, 0, 0, 0)       {- StgMacros.lh  -}
+    ARGS_CHK_A_LOAD_NODE  ->  Cost (2, 1, 0, 0, 0)	 {- StgMacros.lh  -}
 		-- p=probability of PAP (instead of AP): + p*(3,1,0,0,0)
-    ARGS_CHK_A            ->  Cost (2, 1, 0, 0, 0)       {- StgMacros.lh  -}
+    ARGS_CHK_A		  ->  Cost (2, 1, 0, 0, 0)	 {- StgMacros.lh  -}
 		-- p=probability of PAP (instead of AP): + p*(0,1,0,0,0)
-    ARGS_CHK_B_LOAD_NODE  ->  Cost (2, 1, 0, 0, 0)       {- StgMacros.lh  -}
-    ARGS_CHK_B            ->  Cost (2, 1, 0, 0, 0)       {- StgMacros.lh  -}
-    HEAP_CHK              ->  Cost (2, 1, 0, 0, 0)       {- StgMacros.lh  -}
-    -- STK_CHK               ->  (2, 1, 0, 0, 0)       {- StgMacros.lh  -}
-    STK_CHK               ->  Cost (0, 0, 0, 0, 0)       {- StgMacros.lh  -}
-    UPD_CAF               ->  Cost (7, 0, 1, 3, 0)       {- SMupdate.lh  -}
-    UPD_IND               ->  Cost (8, 2, 2, 0, 0)       {- SMupdate.lh  
+    ARGS_CHK_B_LOAD_NODE  ->  Cost (2, 1, 0, 0, 0)	 {- StgMacros.lh  -}
+    ARGS_CHK_B		  ->  Cost (2, 1, 0, 0, 0)	 {- StgMacros.lh  -}
+    HEAP_CHK		  ->  Cost (2, 1, 0, 0, 0)	 {- StgMacros.lh  -}
+    -- STK_CHK		     ->	 (2, 1, 0, 0, 0)       {- StgMacros.lh	-}
+    STK_CHK		  ->  Cost (0, 0, 0, 0, 0)	 {- StgMacros.lh  -}
+    UPD_CAF		  ->  Cost (7, 0, 1, 3, 0)	 {- SMupdate.lh	 -}
+    UPD_IND		  ->  Cost (8, 2, 2, 0, 0)	 {- SMupdate.lh
 				updatee in old-gen: Cost (4, 1, 1, 0, 0)
 				updatee in new-gen: Cost (4, 1, 1, 0, 0)
-                                NB: we include costs fo checking if there is
+				NB: we include costs fo checking if there is
 				    a BQ, but we omit costs for awakening BQ
 				    (these probably differ between old-gen and
-				    new gen) -} 
-    UPD_INPLACE_NOPTRS    ->  Cost (13, 3, 3, 2, 0)       {- SMupdate.lh  
+				    new gen) -}
+    UPD_INPLACE_NOPTRS	  ->  Cost (13, 3, 3, 2, 0)	  {- SMupdate.lh
 				common for both:    Cost (4, 1, 1, 0, 0)
-  				updatee in old-gen: Cost (14, 3, 2, 4, 0) 
+				updatee in old-gen: Cost (14, 3, 2, 4, 0)
 				updatee in new-gen: Cost (4, 1, 1, 0, 0)   -}
-    UPD_INPLACE_PTRS      ->  Cost (13, 3, 3, 2, 0)       {- SMupdate.lh  
+    UPD_INPLACE_PTRS	  ->  Cost (13, 3, 3, 2, 0)	  {- SMupdate.lh
 				common for both:    Cost (4, 1, 1, 0, 0)
-  				updatee in old-gen: Cost (14, 3, 2, 4, 0) 
+				updatee in old-gen: Cost (14, 3, 2, 4, 0)
 				updatee in new-gen: Cost (4, 1, 1, 0, 0)   -}
 
-    UPD_BH_UPDATABLE      ->  Cost (3, 0, 0, 1, 0)       {- SMupdate.lh  -}
-    UPD_BH_SINGLE_ENTRY   ->  Cost (3, 0, 0, 1, 0)       {- SMupdate.lh  -}
-    PUSH_STD_UPD_FRAME    ->  Cost (3, 0, 0, 4, 0)       {- SMupdate.lh  -}
-    POP_STD_UPD_FRAME     ->  Cost (1, 0, 3, 0, 0)       {- SMupdate.lh  -}
-    SET_ARITY             ->  nullCosts             {- StgMacros.lh  -}
-    CHK_ARITY             ->  nullCosts             {- StgMacros.lh  -}
-    SET_TAG               ->  nullCosts             {- COptRegs.lh -}
-    GRAN_FETCH            	->  nullCosts     {- GrAnSim bookkeeping -}
-    GRAN_RESCHEDULE   		->  nullCosts     {- GrAnSim bookkeeping -}
-    GRAN_FETCH_AND_RESCHEDULE	->  nullCosts     {- GrAnSim bookkeeping -}
-    THREAD_CONTEXT_SWITCH   	->  nullCosts     {- GrAnSim bookkeeping -}
+    UPD_BH_UPDATABLE	  ->  Cost (3, 0, 0, 1, 0)	 {- SMupdate.lh	 -}
+    UPD_BH_SINGLE_ENTRY	  ->  Cost (3, 0, 0, 1, 0)	 {- SMupdate.lh	 -}
+    PUSH_STD_UPD_FRAME	  ->  Cost (3, 0, 0, 4, 0)	 {- SMupdate.lh	 -}
+    POP_STD_UPD_FRAME	  ->  Cost (1, 0, 3, 0, 0)	 {- SMupdate.lh	 -}
+    SET_ARITY		  ->  nullCosts		    {- StgMacros.lh  -}
+    CHK_ARITY		  ->  nullCosts		    {- StgMacros.lh  -}
+    SET_TAG		  ->  nullCosts		    {- COptRegs.lh -}
+    GRAN_FETCH			->  nullCosts	  {- GrAnSim bookkeeping -}
+    GRAN_RESCHEDULE		->  nullCosts	  {- GrAnSim bookkeeping -}
+    GRAN_FETCH_AND_RESCHEDULE	->  nullCosts	  {- GrAnSim bookkeeping -}
+    THREAD_CONTEXT_SWITCH	->  nullCosts	  {- GrAnSim bookkeeping -}
 
 -- ---------------------------------------------------------------------------
 
-floatOps :: [PrimOp] 
+floatOps :: [PrimOp]
 floatOps =
-  [   FloatGtOp  , FloatGeOp  , FloatEqOp  , FloatNeOp  , FloatLtOp  , FloatLeOp
+  [   FloatGtOp	 , FloatGeOp  , FloatEqOp  , FloatNeOp	, FloatLtOp  , FloatLeOp
     , DoubleGtOp , DoubleGeOp , DoubleEqOp , DoubleNeOp , DoubleLtOp , DoubleLeOp
     , FloatAddOp , FloatSubOp , FloatMulOp , FloatDivOp , FloatNegOp
     , Float2IntOp , Int2FloatOp
-    , FloatExpOp   , FloatLogOp   , FloatSqrtOp
-    , FloatSinOp   , FloatCosOp   , FloatTanOp
+    , FloatExpOp   , FloatLogOp	  , FloatSqrtOp
+    , FloatSinOp   , FloatCosOp	  , FloatTanOp
     , FloatAsinOp  , FloatAcosOp  , FloatAtanOp
     , FloatSinhOp  , FloatCoshOp  , FloatTanhOp
     , FloatPowerOp
@@ -418,32 +418,32 @@ floatOps =
     , DoubleEncodeOp , DoubleDecodeOp
   ]
 
-gmpOps :: [PrimOp] 
-gmpOps  =
+gmpOps :: [PrimOp]
+gmpOps	=
   [   IntegerAddOp , IntegerSubOp , IntegerMulOp
     , IntegerQuotRemOp , IntegerDivModOp , IntegerNegOp
     , IntegerCmpOp
     , Integer2IntOp  , Int2IntegerOp
-    , Addr2IntegerOp 
+    , Addr2IntegerOp
   ]
 
 
 -- Haven't found the .umul .div .rem macros yet
 -- If they are not Haskell cde, they are not costed, yet
 
-abs_costs = nullCosts  -- NB:  This is normal STG code with costs already 
+abs_costs = nullCosts  -- NB:  This is normal STG code with costs already
 			--	included; no need to add costs again.
 
-umul_costs = Cost (21,4,0,0,0)     -- due to spy counts
-rem_costs =  Cost (30,15,0,0,0)    -- due to spy counts
-div_costs =  Cost (30,15,0,0,0)    -- due to spy counts
+umul_costs = Cost (21,4,0,0,0)	   -- due to spy counts
+rem_costs =  Cost (30,15,0,0,0)	   -- due to spy counts
+div_costs =  Cost (30,15,0,0,0)	   -- due to spy counts
 
 primOpCosts :: PrimOp -> CostRes
 
 -- Special cases
 
-primOpCosts (CCallOp _ _ _ _ _) = SAVE_COSTS + CCALL_COSTS_GUESS + 
-				  RESTORE_COSTS  	-- GUESS; check it
+primOpCosts (CCallOp _ _ _ _ _) = SAVE_COSTS + CCALL_COSTS_GUESS +
+				  RESTORE_COSTS		-- GUESS; check it
 
 -- Usually 3 mov instructions are needed to get args and res in right place.
 
@@ -463,53 +463,53 @@ primOpCosts DoubleGtOp = Cost (2, 0, 0, 0, 2) -- expensive f-comp
 primOpCosts DoubleGeOp = Cost (2, 0, 0, 0, 2) -- expensive f-comp
 primOpCosts DoubleEqOp = Cost (0, 0, 0, 0, 2) -- cheap f-comp
 primOpCosts DoubleNeOp = Cost (0, 0, 0, 0, 2) -- cheap f-comp
-primOpCosts DoubleLtOp = Cost (2, 0, 0, 0, 2) -- expensive f-comp 
+primOpCosts DoubleLtOp = Cost (2, 0, 0, 0, 2) -- expensive f-comp
 primOpCosts DoubleLeOp = Cost (2, 0, 0, 0, 2) -- expensive f-comp
 
-primOpCosts FloatExpOp    = Cost (2, 1, 4, 4, 3)   
-primOpCosts FloatLogOp    = Cost (2, 1, 4, 4, 3)   
-primOpCosts FloatSqrtOp   = Cost (2, 1, 4, 4, 3)   
-primOpCosts FloatSinOp    = Cost (2, 1, 4, 4, 3)   
-primOpCosts FloatCosOp    = Cost (2, 1, 4, 4, 3)   
-primOpCosts FloatTanOp    = Cost (2, 1, 4, 4, 3)   
-primOpCosts FloatAsinOp   = Cost (2, 1, 4, 4, 3)   
-primOpCosts FloatAcosOp   = Cost (2, 1, 4, 4, 3)   
-primOpCosts FloatAtanOp   = Cost (2, 1, 4, 4, 3)   
-primOpCosts FloatSinhOp   = Cost (2, 1, 4, 4, 3)   
-primOpCosts FloatCoshOp   = Cost (2, 1, 4, 4, 3)   
-primOpCosts FloatTanhOp   = Cost (2, 1, 4, 4, 3)   
---primOpCosts FloatAsinhOp  = Cost (2, 1, 4, 4, 3)   
---primOpCosts FloatAcoshOp  = Cost (2, 1, 4, 4, 3)   
---primOpCosts FloatAtanhOp  = Cost (2, 1, 4, 4, 3)   
-primOpCosts FloatPowerOp  = Cost (2, 1, 4, 4, 3)   
+primOpCosts FloatExpOp	  = Cost (2, 1, 4, 4, 3)
+primOpCosts FloatLogOp	  = Cost (2, 1, 4, 4, 3)
+primOpCosts FloatSqrtOp	  = Cost (2, 1, 4, 4, 3)
+primOpCosts FloatSinOp	  = Cost (2, 1, 4, 4, 3)
+primOpCosts FloatCosOp	  = Cost (2, 1, 4, 4, 3)
+primOpCosts FloatTanOp	  = Cost (2, 1, 4, 4, 3)
+primOpCosts FloatAsinOp	  = Cost (2, 1, 4, 4, 3)
+primOpCosts FloatAcosOp	  = Cost (2, 1, 4, 4, 3)
+primOpCosts FloatAtanOp	  = Cost (2, 1, 4, 4, 3)
+primOpCosts FloatSinhOp	  = Cost (2, 1, 4, 4, 3)
+primOpCosts FloatCoshOp	  = Cost (2, 1, 4, 4, 3)
+primOpCosts FloatTanhOp	  = Cost (2, 1, 4, 4, 3)
+--primOpCosts FloatAsinhOp  = Cost (2, 1, 4, 4, 3)
+--primOpCosts FloatAcoshOp  = Cost (2, 1, 4, 4, 3)
+--primOpCosts FloatAtanhOp  = Cost (2, 1, 4, 4, 3)
+primOpCosts FloatPowerOp  = Cost (2, 1, 4, 4, 3)
 
 {- There should be special handling of the Array PrimOps in here   HWL -}
 
-primOpCosts primOp 
+primOpCosts primOp
   | primOp `elem` floatOps = Cost (0, 0, 0, 0, 1)  :: CostRes
-  | primOp `elem` gmpOps   = Cost (50, 5, 10, 10, 0) :: CostRes  -- GUESS; check it
-  | otherwise              = Cost (1, 0, 0, 0, 0)
+  | primOp `elem` gmpOps   = Cost (50, 5, 10, 10, 0) :: CostRes	 -- GUESS; check it
+  | otherwise		   = Cost (1, 0, 0, 0, 0)
 
 -- ---------------------------------------------------------------------------
 {- HWL: currently unused
 
-costsByKind :: PrimKind -> Side -> CostRes
+costsByKind :: PrimRep -> Side -> CostRes
 
 -- The following PrimKinds say that the data is already in a reg
 
-costsByKind CharKind    _ = nullCosts
-costsByKind IntKind     _ = nullCosts
-costsByKind WordKind    _ = nullCosts
-costsByKind AddrKind    _ = nullCosts
-costsByKind FloatKind   _ = nullCosts
-costsByKind DoubleKind	_ = nullCosts
+costsByKind CharRep	_ = nullCosts
+costsByKind IntRep	_ = nullCosts
+costsByKind WordRep	_ = nullCosts
+costsByKind AddrRep	_ = nullCosts
+costsByKind FloatRep	_ = nullCosts
+costsByKind DoubleRep	_ = nullCosts
 -}
 -- ---------------------------------------------------------------------------
 
 #endif {-GRAN-}
 \end{code}
 
-This is the data structure of {\tt PrimOp} copied from prelude/PrimOps.lhs.
+This is the data structure of {\tt PrimOp} copied from prelude/PrimOp.lhs.
 I include here some comments about the estimated costs for these @PrimOps@.
 Compare with the @primOpCosts@ fct above.  -- HWL
 
@@ -518,22 +518,22 @@ data PrimOp
     -- I assume all these basic comparisons take just one ALU instruction
     -- Checked that for Char, Int; Word, Addr should be the same as Int.
 
-    = CharGtOp   | CharGeOp   | CharEqOp   | CharNeOp   | CharLtOp   | CharLeOp
-    | IntGtOp    | IntGeOp    | IntEqOp    | IntNeOp    | IntLtOp    | IntLeOp
-    | WordGtOp   | WordGeOp   | WordEqOp   | WordNeOp   | WordLtOp   | WordLeOp
-    | AddrGtOp   | AddrGeOp   | AddrEqOp   | AddrNeOp   | AddrLtOp   | AddrLeOp
+    = CharGtOp	 | CharGeOp   | CharEqOp   | CharNeOp	| CharLtOp   | CharLeOp
+    | IntGtOp	 | IntGeOp    | IntEqOp	   | IntNeOp	| IntLtOp    | IntLeOp
+    | WordGtOp	 | WordGeOp   | WordEqOp   | WordNeOp	| WordLtOp   | WordLeOp
+    | AddrGtOp	 | AddrGeOp   | AddrEqOp   | AddrNeOp	| AddrLtOp   | AddrLeOp
 
     -- Analogously, these take one FP unit instruction
     -- Haven't checked that, yet.
 
-    | FloatGtOp  | FloatGeOp  | FloatEqOp  | FloatNeOp  | FloatLtOp  | FloatLeOp
+    | FloatGtOp	 | FloatGeOp  | FloatEqOp  | FloatNeOp	| FloatLtOp  | FloatLeOp
     | DoubleGtOp | DoubleGeOp | DoubleEqOp | DoubleNeOp | DoubleLtOp | DoubleLeOp
 
     -- 1 ALU op; unchecked
     | OrdOp | ChrOp
 
     -- these just take 1 ALU op; checked
-    | IntAddOp | IntSubOp 
+    | IntAddOp | IntSubOp
 
     -- but these take more than that; see special cases in primOpCosts
     -- I counted the generated ass. instructions for these -> checked
@@ -553,8 +553,8 @@ data PrimOp
     | FloatAddOp | FloatSubOp | FloatMulOp | FloatDivOp | FloatNegOp
     | Float2IntOp | Int2FloatOp
 
-    | FloatExpOp   | FloatLogOp   | FloatSqrtOp
-    | FloatSinOp   | FloatCosOp   | FloatTanOp
+    | FloatExpOp   | FloatLogOp	  | FloatSqrtOp
+    | FloatSinOp   | FloatCosOp	  | FloatTanOp
     | FloatAsinOp  | FloatAcosOp  | FloatAtanOp
     | FloatSinhOp  | FloatCoshOp  | FloatTanhOp
     -- not all machines have these available conveniently:
@@ -591,21 +591,21 @@ data PrimOp
     -- primitive ops for primitive arrays
 
     | NewArrayOp
-    | NewByteArrayOp PrimKind
+    | NewByteArrayOp PrimRep
 
     | SameMutableArrayOp
     | SameMutableByteArrayOp
 
     | ReadArrayOp | WriteArrayOp | IndexArrayOp -- for arrays of Haskell ptrs
 
-    | ReadByteArrayOp   PrimKind
-    | WriteByteArrayOp  PrimKind
-    | IndexByteArrayOp  PrimKind
-    | IndexOffAddrOp    PrimKind
-        -- PrimKind can be one of {Char,Int,Addr,Float,Double}Kind.
-        -- This is just a cheesy encoding of a bunch of ops.
-        -- Note that MallocPtrKind is not included -- the only way of
-        -- creating a MallocPtr is with a ccall or casm.
+    | ReadByteArrayOp	PrimRep
+    | WriteByteArrayOp	PrimRep
+    | IndexByteArrayOp	PrimRep
+    | IndexOffAddrOp	PrimRep
+	-- PrimRep can be one of {Char,Int,Addr,Float,Double}Kind.
+	-- This is just a cheesy encoding of a bunch of ops.
+	-- Note that MallocPtrRep is not included -- the only way of
+	-- creating a MallocPtr is with a ccall or casm.
 
     | UnsafeFreezeArrayOp | UnsafeFreezeByteArrayOp
 
@@ -616,12 +616,12 @@ A special ``trap-door'' to use in making calls direct to C functions:
 Note: From GrAn point of view, CCall is probably very expensive -- HWL
 
 \begin{pseudocode}
-    | CCallOp   String          -- An "unboxed" ccall# to this named function
-                Bool            -- True <=> really a "casm"
-                Bool            -- True <=> might invoke Haskell GC
-                [UniType]       -- Unboxed argument; the state-token
-                                -- argument will have been put *first*
-                UniType         -- Return type; one of the "StateAnd<blah>#" types
+    | CCallOp	String	-- An "unboxed" ccall# to this named function
+		Bool	-- True <=> really a "casm"
+		Bool	-- True <=> might invoke Haskell GC
+		[Type]	-- Unboxed argument; the state-token
+			-- argument will have been put *first*
+		Type	-- Return type; one of the "StateAnd<blah>#" types
 
     -- (... to be continued ... )
 \end{pseudocode}
diff --git a/ghc/compiler/absCSyn/HeapOffs.hi b/ghc/compiler/absCSyn/HeapOffs.hi
deleted file mode 100644
index 3506ac8e72..0000000000
--- a/ghc/compiler/absCSyn/HeapOffs.hi
+++ /dev/null
@@ -1,28 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface HeapOffs where
-import CharSeq(CSeq)
-import MachDesc(Target)
-import Maybes(Labda)
-import Pretty(PprStyle)
-import SMRep(SMRep)
-data HeapOffset 
-type HpRelOffset = HeapOffset
-type SpARelOffset = Int
-type SpBRelOffset = Int
-type VirtualHeapOffset = HeapOffset
-type VirtualSpAOffset = Int
-type VirtualSpBOffset = Int
-addOff :: HeapOffset -> HeapOffset -> HeapOffset
-fixedHdrSize :: HeapOffset
-hpRelToInt :: Target -> HeapOffset -> Int
-intOff :: Int -> HeapOffset
-intOffsetIntoGoods :: HeapOffset -> Labda Int
-isZeroOff :: HeapOffset -> Bool
-maxOff :: HeapOffset -> HeapOffset -> HeapOffset
-possiblyEqualHeapOffset :: HeapOffset -> HeapOffset -> Bool
-pprHeapOffset :: PprStyle -> HeapOffset -> CSeq
-subOff :: HeapOffset -> HeapOffset -> HeapOffset
-totHdrSize :: SMRep -> HeapOffset
-varHdrSize :: SMRep -> HeapOffset
-zeroOff :: HeapOffset
-
diff --git a/ghc/compiler/absCSyn/HeapOffs.lhs b/ghc/compiler/absCSyn/HeapOffs.lhs
index 79000d9043..d27645ed78 100644
--- a/ghc/compiler/absCSyn/HeapOffs.lhs
+++ b/ghc/compiler/absCSyn/HeapOffs.lhs
@@ -1,5 +1,5 @@
 %
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
 %
 \section[HeapOffs]{Abstract C: heap offsets}
 
@@ -12,11 +12,7 @@ INTERNAL MODULE: should be accessed via @AbsCSyn.hi@.
 #include "HsVersions.h"
 
 module HeapOffs (
-#ifndef DPH
 	HeapOffset,
-#else
-	HeapOffset(..),	-- DPH needs to do a little peaking inside this thing.
-#endif {- Data Parallel Haskell -}
 
 	zeroOff, intOff, fixedHdrSize, totHdrSize, varHdrSize,
 	maxOff, addOff, subOff,
@@ -26,24 +22,27 @@ module HeapOffs (
 
 	intOffsetIntoGoods,
 
+#if 0
 #if ! OMIT_NATIVE_CODEGEN
-	hpRelToInt, 
+	hpRelToInt,
+#endif
 #endif
 
 	VirtualHeapOffset(..), HpRelOffset(..),
 	VirtualSpAOffset(..), VirtualSpBOffset(..),
 	SpARelOffset(..), SpBRelOffset(..)
-    ) where 
+    ) where
+
+import Ubiq{-uitous-}
 
-import ClosureInfo	-- esp. about SMReps
-import SMRep		
+import ClosureInfo	( isSpecRep )
+import Maybes		( catMaybes )
+import SMRep
+import Unpretty		-- ********** NOTE **********
+import Util		( panic )
 #if ! OMIT_NATIVE_CODEGEN
-import MachDesc
+--import MachDesc		( Target )
 #endif
-import Maybes		( catMaybes, Maybe(..) )
-import Outputable
-import Unpretty		-- ********** NOTE **********
-import Util
 \end{code}
 
 %************************************************************************
@@ -63,7 +62,7 @@ import Util
     * Node, the ptr to the closure, pts at its info-ptr field
 -}
 data HeapOffset
-  = MkHeapOffset	
+  = MkHeapOffset
 
 	FAST_INT	-- this many words...
 
@@ -88,13 +87,8 @@ data HeapOffset
 
   deriving () -- but: see `eqOff` below
 
-#if defined(__GLASGOW_HASKELL__)
 data SMRep__Int = SMRI_ SMRep Int#
 #define SMRI(a,b) (SMRI_ a b)
-#else
-type SMRep__Int = (SMRep, Int)
-#define SMRI(a,b) (a, b)
-#endif
 
 type VirtualHeapOffset	= HeapOffset
 type VirtualSpAOffset	= Int
@@ -113,7 +107,7 @@ intOff IBOX(n) = MkHeapOffset n ILIT(0) [] []
 
 fixedHdrSize = MkHeapOffset ILIT(0) ILIT(1) [] []
 
-totHdrSize sm_rep 
+totHdrSize sm_rep
   = if isSpecRep sm_rep -- Tot hdr size for a spec rep is just FixedHdrSize
     then MkHeapOffset ILIT(0) ILIT(1) [] []
     else MkHeapOffset ILIT(0) ILIT(0) [] [SMRI(sm_rep, ILIT(1))]
@@ -150,7 +144,7 @@ maxOff off1@(MkHeapOffset int_offs1 fixhdr_offs1 varhdr_offs1 tothdr_offs1)
     else
 	 MaxHeapOffset off1 off2
   where
-    -- Normalise, by realising that each tot-hdr is really a 
+    -- Normalise, by realising that each tot-hdr is really a
     -- var-hdr plus a fixed-hdr
     n_tothdr1    = total_of tothdr_offs1
     real_fixed1  = fixhdr_offs1 _ADD_ n_tothdr1
@@ -215,7 +209,7 @@ add_HdrSizes offs1 [] = offs1
 add_HdrSizes as@(off1@(SMRI(rep1,n1)) : offs1) bs@(off2@(SMRI(rep2,n2)) : offs2)
   = if rep1 `ltSMRepHdr` rep2 then
 	     off1 : (add_HdrSizes offs1 bs)
-    else 
+    else
     if rep2 `ltSMRepHdr` rep1 then
 	     off2 : (add_HdrSizes as offs2)
     else
@@ -293,7 +287,7 @@ pprHeapOffset sty (MkHeapOffset int_offs fxdhdr_offs varhdr_offs tothdr_offs)
 \end{code}
 
 \begin{code}
-pprHeapOffsetPieces :: PprStyle 
+pprHeapOffsetPieces :: PprStyle
 		    -> FAST_INT		-- Words
 		    -> FAST_INT		-- Fixed hdrs
 		    -> [SMRep__Int]	-- Var hdrs
@@ -336,7 +330,7 @@ pprHeapOffsetPieces sty int_offs fxdhdr_offs varhdr_offs tothdr_offs
     pp_hdr pp_str (SMRI(rep, n))
       = if n _EQ_ ILIT(1) then
 	  uppBeside (uppStr (show rep)) pp_str
-        else
+	else
 	  uppBesides [uppInt IBOX(n), uppChar '*', uppStr (show rep), pp_str]
 \end{code}
 
@@ -366,6 +360,7 @@ intOffsetIntoGoods anything_else = Nothing
 \end{code}
 
 \begin{code}
+#if 0
 #if ! OMIT_NATIVE_CODEGEN
 
 hpRelToInt :: Target -> HeapOffset -> Int
@@ -399,4 +394,5 @@ hpRelToInt target (MkHeapOffset base fhs vhs ths)
     vhs_size r = (varHeaderSize target r) :: Int
 
 #endif
+#endif {-0-}
 \end{code}
diff --git a/ghc/compiler/absCSyn/PprAbsC.hi b/ghc/compiler/absCSyn/PprAbsC.hi
deleted file mode 100644
index 92aab864ed..0000000000
--- a/ghc/compiler/absCSyn/PprAbsC.hi
+++ /dev/null
@@ -1,26 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface PprAbsC where
-import AbsCSyn(AbstractC, CAddrMode, CExprMacro, CStmtMacro, MagicId, RegRelative, ReturnInfo)
-import BasicLit(BasicLit)
-import CLabelInfo(CLabel)
-import CharSeq(CSeq)
-import ClosureInfo(ClosureInfo)
-import CmdLineOpts(GlobalSwitch)
-import CostCentre(CostCentre)
-import HeapOffs(HeapOffset)
-import Maybes(Labda)
-import PreludePS(_PackedString)
-import Pretty(PprStyle)
-import PrimKind(PrimKind)
-import PrimOps(PrimOp)
-import Stdio(_FILE)
-import Unique(Unique)
-data AbstractC 
-data CAddrMode 
-data MagicId 
-data CSeq 
-data PprStyle 
-dumpRealC :: (GlobalSwitch -> Bool) -> AbstractC -> [Char]
-pprAmode :: PprStyle -> CAddrMode -> CSeq
-writeRealC :: (GlobalSwitch -> Bool) -> _FILE -> AbstractC -> _State _RealWorld -> ((), _State _RealWorld)
-
diff --git a/ghc/compiler/absCSyn/PprAbsC.lhs b/ghc/compiler/absCSyn/PprAbsC.lhs
index 876f291d26..4b5dc298f9 100644
--- a/ghc/compiler/absCSyn/PprAbsC.lhs
+++ b/ghc/compiler/absCSyn/PprAbsC.lhs
@@ -11,17 +11,11 @@
 #include "HsVersions.h"
 
 module PprAbsC (
-#ifdef __GLASGOW_HASKELL__
 	writeRealC,
-#endif
 	dumpRealC,
-#if defined(DEBUG) || defined(DPH)
+#if defined(DEBUG)
 	pprAmode, -- otherwise, not exported
 #endif
-#ifdef DPH
-	pprAbsC, 
-    	pprMagicId,
-#endif
 
 	-- and for interface self-sufficiency...
 	AbstractC, CAddrMode, MagicId,
@@ -32,26 +26,23 @@ IMPORT_Trace		-- ToDo: rm (debugging only)
 
 import AbsCSyn
 
-import AbsPrel		( pprPrimOp, primOpNeedsWrapper, PrimOp(..)
+import PrelInfo		( pprPrimOp, primOpNeedsWrapper, PrimOp(..)
 			  IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
 			)
-import BasicLit		( kindOfBasicLit, showBasicLit )
-import CLabelInfo	-- lots of things
+import Literal		( literalPrimRep, showLiteral )
+import CLabel	-- lots of things
 import CgCompInfo	( spARelToInt, spBRelToInt, mIN_UPD_SIZE )
 import CgRetConv 	( noLiveRegsMask )
 import ClosureInfo	-- quite a few things
-import CmdLineOpts	( GlobalSwitch(..) )
 import Costs		-- for GrAnSim; cost counting function -- HWL
 import CostCentre
 import FiniteMap
 import Maybes		( catMaybes, maybeToBool, Maybe(..) )
 import Outputable
 import Pretty	    	( codeStyle, prettyToUn )
-import PrimKind		( showPrimKind, isFloatingKind, PrimKind(..) )
-import SplitUniq
+import PrimRep		( showPrimRep, isFloatingRep, PrimRep(..) )
 import StgSyn
 import UniqFM
-import Unique		-- UniqueSupply monadery used in flattening
 import Unpretty		-- ********** NOTE **********
 import Util
 
@@ -64,19 +55,14 @@ call to a cost evaluation function @GRAN_EXEC@. For that,
 @pprAbsC@ has a new ``costs'' argument.  %% HWL
 
 \begin{code}
-#ifdef __GLASGOW_HASKELL__
-# if __GLASGOW_HASKELL__ < 23
-# define _FILE _Addr
-# endif
-writeRealC :: (GlobalSwitch -> Bool) -> _FILE -> AbstractC -> PrimIO ()
+writeRealC :: _FILE -> AbstractC -> PrimIO ()
 
 writeRealC sw_chker file absC
   = uppAppendFile file 80 (
       uppAbove (pprAbsC (PprForC sw_chker) absC (costs absC)) (uppChar '\n')
     )
-#endif
 
-dumpRealC :: (GlobalSwitch -> Bool) -> AbstractC -> String
+dumpRealC :: AbstractC -> String
 
 dumpRealC sw_chker absC
   = uppShow 80 (
@@ -104,7 +90,7 @@ emitMacro (Cost (i,b,l,s,f))
 pp_paren_semi = uppStr ");"
 
 -- ---------------------------------------------------------------------------
--- New type: Now pprAbsC also takes the costs for evaluating the Abstract C 
+-- New type: Now pprAbsC also takes the costs for evaluating the Abstract C
 -- code as an argument (that's needed when spitting out the GRAN_EXEC macro
 -- which must be done before the return i.e. inside absC code)   HWL
 -- ---------------------------------------------------------------------------
@@ -117,33 +103,28 @@ pprAbsC sty (AbsCStmts s1 s2) c = uppAbove (pprAbsC sty s1 c) (pprAbsC sty s2 c)
 pprAbsC sty (CClosureUpdInfo info) c
   = pprAbsC sty info c
 
-pprAbsC sty (CAssign dest src) _ = pprAssign sty (getAmodeKind dest) dest src
+pprAbsC sty (CAssign dest src) _ = pprAssign sty (getAmodeRep dest) dest src
 
 pprAbsC sty (CJump target) c
-  = uppAbove (uppBesides [emitMacro c {-WDP:, uppStr "/* <--++  CJump */"-} ]) 
-             (uppBesides [ uppStr "JMP_(", pprAmode sty target, pp_paren_semi ])
+  = uppAbove (uppBesides [emitMacro c {-WDP:, uppStr "/* <--++  CJump */"-} ])
+	     (uppBesides [ uppStr "JMP_(", pprAmode sty target, pp_paren_semi ])
 
 pprAbsC sty (CFallThrough target) c
-  = uppAbove (uppBesides [emitMacro c {-WDP:, uppStr "/* <--++  CFallThrough */"-} ]) 
-             (uppBesides [ uppStr "JMP_(", pprAmode sty target, pp_paren_semi ])
+  = uppAbove (uppBesides [emitMacro c {-WDP:, uppStr "/* <--++  CFallThrough */"-} ])
+	     (uppBesides [ uppStr "JMP_(", pprAmode sty target, pp_paren_semi ])
 
 -- --------------------------------------------------------------------------
--- Spit out GRAN_EXEC macro immediately before the return                 HWL 
+-- Spit out GRAN_EXEC macro immediately before the return                 HWL
 
 pprAbsC sty (CReturn am return_info)  c
-  = uppAbove (uppBesides [emitMacro c {-WDP:, uppStr "/* <----  CReturn */"-} ]) 
-             (uppBesides [uppStr "JMP_(", target, pp_paren_semi ])
+  = uppAbove (uppBesides [emitMacro c {-WDP:, uppStr "/* <----  CReturn */"-} ])
+	     (uppBesides [uppStr "JMP_(", target, pp_paren_semi ])
   where
    target = case return_info of
     	DirectReturn -> uppBesides [uppStr "DIRECT(", pprAmode sty am, uppRparen]
 	DynamicVectoredReturn am' -> mk_vector (pprAmode sty am')
 	StaticVectoredReturn n -> mk_vector (uppInt n)	-- Always positive
    mk_vector x = uppBesides [uppLparen, pprAmode sty am, uppStr ")[RVREL(", x, uppStr ")]"]
-    	    	    	
-{-UNUSED:
-pprAbsC sty (CComment s) _
-  = uppNil -- ifPprShowAll sty (uppCat [uppStr "/*", uppStr s, uppStr "*/"])
--}
 
 pprAbsC sty (CSplitMarker) _ = uppPStr SLIT("/* SPLIT */")
 
@@ -154,7 +135,7 @@ pprAbsC sty (CSplitMarker) _ = uppPStr SLIT("/* SPLIT */")
 --         costs function yields nullCosts for whole switch
 --         ==> inherited costs c are those of basic block up to switch
 --         ==> inherit c + costs for the corresponding branch
---                                                                       HWL  
+--                                                                       HWL
 -- --------------------------------------------------------------------------
 
 pprAbsC sty (CSwitch discrim [] deflt) c
@@ -181,7 +162,7 @@ pprAbsC sty (CSwitch discrim [(tag1@(MachInt i1 _), alt_code1),
     empty_deflt = not (maybeToBool (nonemptyAbsC deflt))
 
 pprAbsC sty (CSwitch discrim alts deflt) c -- general case
-  | isFloatingKind (getAmodeKind discrim)
+  | isFloatingRep (getAmodeRep discrim)
     = pprAbsC sty (foldr ( \ a -> CSwitch discrim [a]) deflt alts) c
   | otherwise
     = uppAboves [
@@ -190,10 +171,10 @@ pprAbsC sty (CSwitch discrim alts deflt) c -- general case
 	(case (nonemptyAbsC deflt) of
 	   Nothing -> uppNil
 	   Just dc ->
-	    uppNest 2 (uppAboves [uppPStr SLIT("default:"), 
-                                  pprAbsC sty dc (c + switch_head_cost 
-						    + costs dc), 
-                                  uppPStr SLIT("break;")])),
+	    uppNest 2 (uppAboves [uppPStr SLIT("default:"),
+				  pprAbsC sty dc (c + switch_head_cost
+						    + costs dc),
+				  uppPStr SLIT("break;")])),
 	uppChar '}' ]
   where
     pp_discrim
@@ -201,8 +182,8 @@ pprAbsC sty (CSwitch discrim alts deflt) c -- general case
 
     ppr_alt sty (lit, absC)
       = uppAboves [ uppBesides [uppPStr SLIT("case "), pprBasicLit sty lit, uppChar ':'],
-		   uppNest 2 (uppAbove (pprAbsC sty absC (c + switch_head_cost + costs absC)) 
-                                       (uppPStr SLIT("break;"))) ]
+		   uppNest 2 (uppAbove (pprAbsC sty absC (c + switch_head_cost + costs absC))
+				       (uppPStr SLIT("break;"))) ]
 
     -- Costs for addressing header of switch and cond. branching        -- HWL
     switch_head_cost = addrModeCosts discrim Rhs + (Cost (0, 1, 0, 0, 0))
@@ -213,7 +194,7 @@ pprAbsC sty stmt@(COpStmt results op@(CCallOp _ _ _ _ _) args liveness_mask vol_
 pprAbsC sty stmt@(COpStmt results op args liveness_mask vol_regs) _
   = let
 	non_void_args = grab_non_void_amodes args
-        non_void_results = grab_non_void_amodes results
+	non_void_results = grab_non_void_amodes results
 	-- if just one result, we print in the obvious "assignment" style;
 	-- if 0 or many results, we emit a macro call, w/ the results
 	-- followed by the arguments.  The macro presumably knows which
@@ -224,7 +205,7 @@ pprAbsC sty stmt@(COpStmt results op args liveness_mask vol_regs) _
     in
     BIND (ppr_vol_regs sty vol_regs) _TO_ (pp_saves, pp_restores) ->
     if primOpNeedsWrapper op then
-    	uppAboves [  pp_saves, 
+    	uppAboves [  pp_saves,
     	    	    the_op,
     	    	    pp_restores
     	    	 ]
@@ -298,10 +279,10 @@ pprAbsC sty stmt@(CStaticClosure closure_lbl cl_info cost_centre amodes) _
 	  _ -> uppNil,
 	uppBesides [
 		uppStr "SET_STATIC_HDR(",
-		pprCLabel sty closure_lbl,			uppComma, 
+		pprCLabel sty closure_lbl,			uppComma,
 		pprCLabel sty info_lbl,				uppComma,
-		if_profiling sty (pprAmode sty cost_centre),	uppComma, 
-		ppLocalness closure_lbl,			uppComma, 
+		if_profiling sty (pprAmode sty cost_centre),	uppComma,
+		ppLocalness closure_lbl,			uppComma,
 		ppLocalnessMacro False{-for data-} info_lbl,
 		uppChar ')'
 		],
@@ -313,7 +294,7 @@ pprAbsC sty stmt@(CStaticClosure closure_lbl cl_info cost_centre amodes) _
     info_lbl = infoTableLabelFromCI cl_info
 
     ppr_item sty item
-      = if getAmodeKind item == VoidKind
+      = if getAmodeRep item == VoidRep
 	then uppStr ", (W_) 0" -- might not even need this...
 	else uppBeside (uppStr ", (W_)") (ppr_amode sty item)
 
@@ -325,7 +306,7 @@ pprAbsC sty stmt@(CStaticClosure closure_lbl cl_info cost_centre amodes) _
 	    nOfThem still_needed (mkIntCLit 0) -- a bunch of 0s
 	    BEND
 
-{- 
+{-
    STATIC_INIT_HDR(c,i,localness) blows into:
 	localness W_ c_closure [] = { i_info, extra_fixed_wd<1..n>
 
@@ -339,12 +320,12 @@ pprAbsC sty stmt@(CStaticClosure closure_lbl cl_info cost_centre amodes) _
 
 pprAbsC sty stmt@(CClosureInfoAndCode cl_info slow maybe_fast upd cl_descr liveness) _
   = uppAboves [
-        uppBesides [
+	uppBesides [
 	    pp_info_rep,
 	    uppStr "_ITBL(",
 	    pprCLabel sty info_lbl,			uppComma,
 
-		-- CONST_ITBL needs an extra label for 
+		-- CONST_ITBL needs an extra label for
 		-- the static version of the object.
 	    if isConstantRep sm_rep
 	    then uppBeside (pprCLabel sty (closureLabelFromCI cl_info)) uppComma
@@ -352,7 +333,7 @@ pprAbsC sty stmt@(CClosureInfoAndCode cl_info slow maybe_fast upd cl_descr liven
 
 	    pprCLabel sty slow_lbl,	uppComma,
     	    pprAmode sty upd,		uppComma,
-            uppInt liveness,		uppComma,
+	    uppInt liveness,		uppComma,
 
 	    pp_tag,			uppComma,
 	    pp_size, 			uppComma,
@@ -368,12 +349,12 @@ pprAbsC sty stmt@(CClosureInfoAndCode cl_info slow maybe_fast upd cl_descr liven
 	    if_profiling sty pp_kind, uppComma,
 	    if_profiling sty pp_descr, uppComma,
 	    if_profiling sty pp_type,
-	    uppStr ");" 
-        ],
-        pp_slow,
+	    uppStr ");"
+	],
+	pp_slow,
 	case maybe_fast of
-            Nothing -> uppNil
-            Just fast -> let stuff = CCodeBlock fast_lbl fast in
+	    Nothing -> uppNil
+	    Just fast -> let stuff = CCodeBlock fast_lbl fast in
 			 pprAbsC sty stuff (costs stuff)
     ]
   where
@@ -400,12 +381,12 @@ pprAbsC sty stmt@(CClosureInfoAndCode cl_info slow maybe_fast upd cl_descr liven
     is_phantom = isPhantomRep sm_rep
 
     pp_size = if isSpecRep sm_rep then	-- exploiting: SPEC_VHS == 0 (always)
-	         uppInt (closureNonHdrSize cl_info)
+		 uppInt (closureNonHdrSize cl_info)
 
 	      else if is_phantom then	-- do not have sizes for these
-	         uppNil
+		 uppNil
 	      else
-	         pprHeapOffset sty (closureSizeWithoutFixedHdr cl_info)
+		 pprHeapOffset sty (closureSizeWithoutFixedHdr cl_info)
 
     pp_ptr_wds	= if is_phantom then
 		     uppNil
@@ -446,13 +427,6 @@ pprAbsC sty stmt@(CFlatRetVector label amodes) _
     ppr_item sty item = uppBeside (uppStr "(W_) ") (ppr_amode sty item)
 
 pprAbsC sty (CCostCentreDecl is_local cc) _ = uppCostCentreDecl sty is_local cc
-
-#ifdef DPH
--- Only used for debugging (i.e output abstractC instead of APAL)
-pprAbsC sty (CNativeInfoTableAndCode _ _ absC)
-  = uppAboves [uppStr "CNativeInfoTableAndCode (DPH)",
-	      pprAbsC sty absC] 
-#endif {- Data Parallel Haskell -}     
 \end{code}
 
 \begin{code}
@@ -476,8 +450,8 @@ grab_non_void_amodes amodes
   = filter non_void amodes
 
 non_void amode
-  = case (getAmodeKind amode) of
-      VoidKind -> False
+  = case (getAmodeRep amode) of
+      VoidRep -> False
       k	-> True
 \end{code}
 
@@ -490,7 +464,7 @@ ppr_vol_regs sty (r:rs)
   = let pp_reg = case r of
     	    	    VanillaReg pk n -> pprVanillaReg n
     	    	    _ -> pprMagicId sty r
-        (more_saves, more_restores) = ppr_vol_regs sty rs
+	(more_saves, more_restores) = ppr_vol_regs sty rs
     in
     (uppAbove (uppBeside (uppPStr SLIT("CALLER_SAVE_"))    pp_reg) more_saves,
      uppAbove (uppBeside (uppPStr SLIT("CALLER_RESTORE_")) pp_reg) more_restores)
@@ -539,39 +513,39 @@ if_profiling sty pretty
 -- ---------------------------------------------------------------------------
 -- Changes for GrAnSim:
 --  draw costs for computation in head of if into both branches;
---  as no abstractC data structure is given for the head, one is constructed 
---  guessing unknown values and fed into the costs function 
+--  as no abstractC data structure is given for the head, one is constructed
+--  guessing unknown values and fed into the costs function
 -- ---------------------------------------------------------------------------
 
 do_if_stmt sty discrim tag alt_code deflt c
   = case tag of
       -- This special case happens when testing the result of a comparison.
       -- We can just avoid some redundant clutter in the output.
-      MachInt n _ | n==0 -> ppr_if_stmt sty (pprAmode sty discrim) 
+      MachInt n _ | n==0 -> ppr_if_stmt sty (pprAmode sty discrim)
 				      deflt alt_code
-                                      (addrModeCosts discrim Rhs) c
+				      (addrModeCosts discrim Rhs) c
       other              -> let
 			       cond = uppBesides [ pprAmode sty discrim,
 					  uppPStr SLIT(" == "),
 					  pprAmode sty (CLit tag) ]
 			    in
-			    ppr_if_stmt sty cond 
+			    ppr_if_stmt sty cond
 					 alt_code deflt
 					 (addrModeCosts discrim Rhs) c
 
 ppr_if_stmt sty pp_pred then_part else_part discrim_costs c
   = uppAboves [
       uppBesides [uppStr "if (", pp_pred, uppStr ") {"],
-      uppNest 8 (pprAbsC sty then_part 	(c + discrim_costs + 
-				       	(Cost (0, 2, 0, 0, 0)) + 
+      uppNest 8 (pprAbsC sty then_part 	(c + discrim_costs +
+				       	(Cost (0, 2, 0, 0, 0)) +
 					costs then_part)),
       (case nonemptyAbsC else_part of Nothing -> uppNil; Just _ -> uppStr "} else {"),
-      uppNest 8 (pprAbsC sty else_part  (c + discrim_costs + 
-				        (Cost (0, 1, 0, 0, 0)) + 
+      uppNest 8 (pprAbsC sty else_part  (c + discrim_costs +
+					(Cost (0, 1, 0, 0, 0)) +
 					costs else_part)),
       uppChar '}' ]
     {- Total costs = inherited costs (before if) + costs for accessing discrim
-		     + costs for cond branch ( = (0, 1, 0, 0, 0) ) 
+		     + costs for cond branch ( = (0, 1, 0, 0, 0) )
 		     + costs for that alternative
     -}
 \end{code}
@@ -584,7 +558,7 @@ bit. ADR
 Some rough notes on generating code for @CCallOp@:
 
 1) Evaluate all arguments and stuff them into registers. (done elsewhere)
-2) Save any essential registers (heap, stack, etc).  
+2) Save any essential registers (heap, stack, etc).
 
    ToDo: If stable pointers are in use, these must be saved in a place
    where the runtime system can get at them so that the Stg world can
@@ -627,7 +601,7 @@ Amendment to the above: if we can GC, we have to:
 * make sure we save all our registers away where the garbage collector
   can get at them.
 * be sure that there are no live registers or we're in trouble.
-  (This can cause problems if you try something foolish like passing 
+  (This can cause problems if you try something foolish like passing
    an array or mallocptr to a _ccall_GC_ thing.)
 * increment/decrement the @inCCallGC@ counter before/after the call so
   that the runtime check that PerformGC is being used sensibly will work.
@@ -653,19 +627,19 @@ pprCCall sty op@(CCallOp op_str is_asm may_gc _ _) args results liveness_mask vo
     (pp_saves, pp_restores) = ppr_vol_regs sty vol_regs
     (pp_save_context, pp_restore_context) =
 	if may_gc
-	then (	uppStr "extern StgInt inCCallGC; SaveAllStgRegs(); inCCallGC++;", 
+	then (	uppStr "extern StgInt inCCallGC; SaveAllStgRegs(); inCCallGC++;",
 		uppStr "inCCallGC--; RestoreAllStgRegs();")
-	else (	pp_basic_saves `uppAbove` pp_saves, 
+	else (	pp_basic_saves `uppAbove` pp_saves,
 		pp_basic_restores `uppAbove` pp_restores)
 
-    non_void_args = 
-	let nvas = tail args 
+    non_void_args =
+	let nvas = tail args
 	in ASSERT (all non_void nvas) nvas
-    -- the first argument will be the "I/O world" token (a VoidKind)
+    -- the first argument will be the "I/O world" token (a VoidRep)
     -- all others should be non-void
 
-    non_void_results = 
-	let nvrs = grab_non_void_amodes results 
+    non_void_results =
+	let nvrs = grab_non_void_amodes results
 	in ASSERT (length nvrs <= 1) nvrs
     -- there will usually be two results: a (void) state which we
     -- should ignore and a (possibly void) result.
@@ -683,11 +657,11 @@ pprCCall sty op@(CCallOp op_str is_asm may_gc _ _) args results liveness_mask vo
     -- Remainder only used for ccall
 
     ccall_str = uppShow 80
-	(uppBesides [ 
-		if null non_void_results 
+	(uppBesides [
+		if null non_void_results
 		  then uppNil
 		  else uppPStr SLIT("%r = "),
-		uppLparen, uppPStr op_str, uppLparen, 
+		uppLparen, uppPStr op_str, uppLparen,
 		  uppIntersperse uppComma ccall_args,
 		uppStr "));"
 	])
@@ -705,7 +679,7 @@ ppr_casm_arg :: PprStyle -> CAddrMode -> Int -> (Unpretty, Unpretty)
 
 ppr_casm_arg sty amode a_num
   = let
-	a_kind	 = getAmodeKind amode
+	a_kind	 = getAmodeRep amode
 	pp_amode = pprAmode sty amode
 	pp_kind  = pprPrimKind sty a_kind
 
@@ -716,13 +690,13 @@ ppr_casm_arg sty amode a_num
 
 	      -- for array arguments, pass a pointer to the body of the array
 	      -- (PTRS_ARR_CTS skips over all the header nonsense)
-	      ArrayKind	    -> (pp_kind,
+	      ArrayRep	    -> (pp_kind,
 				uppBesides [uppStr "PTRS_ARR_CTS(", pp_amode, uppRparen])
-	      ByteArrayKind -> (pp_kind,
+	      ByteArrayRep -> (pp_kind,
 				uppBesides [uppStr "BYTE_ARR_CTS(", pp_amode, uppRparen])
 
 	      -- for Malloc Pointers, use MALLOC_PTR_DATA to fish out the contents.
-	      MallocPtrKind -> (uppPStr SLIT("StgMallocPtr"),
+	      MallocPtrRep -> (uppPStr SLIT("StgMallocPtr"),
 				uppBesides [uppStr "MallocPtr_CLOSURE_DATA(", pp_amode, uppStr")"])
 	      other	    -> (pp_kind, pp_amode)
 
@@ -747,39 +721,39 @@ ppr_casm_results ::
 	PprStyle	-- style
 	-> [CAddrMode]	-- list of results (length <= 1)
 	-> Unpretty	-- liveness mask
-	-> 		
+	->
 	( Unpretty,	-- declaration of any local vars
 	  [Unpretty],	-- list of result vars (same length as results)
 	  Unpretty )	-- assignment (if any) of results in local var to registers
 
-ppr_casm_results sty [] liveness  
+ppr_casm_results sty [] liveness
   = (uppNil, [], uppNil) 	-- no results
 
 ppr_casm_results sty [r] liveness
   = let
 	result_reg = ppr_amode sty r
-	r_kind	   = getAmodeKind r
+	r_kind	   = getAmodeRep r
 
 	local_var  = uppPStr SLIT("_ccall_result")
 
 	(result_type, assign_result)
 	  = case r_kind of
-	      MallocPtrKind -> 
+	      MallocPtrRep ->
 		(uppPStr SLIT("StgMallocPtr"),
-		 uppBesides [ uppStr "constructMallocPtr(", 
+		 uppBesides [ uppStr "constructMallocPtr(",
 				liveness, uppComma,
-				result_reg, uppComma, 
-				local_var, 
+				result_reg, uppComma,
+				local_var,
 			     pp_paren_semi ])
-	      _ -> 
+	      _ ->
 		(pprPrimKind sty r_kind,
 		 uppBesides [ result_reg, uppEquals, local_var, uppSemi ])
 
 	declare_local_var = uppBesides [ result_type, uppSP, local_var, uppSemi ]
-    in 	
+    in
     (declare_local_var, [local_var], assign_result)
 
-ppr_casm_results sty rs liveness  
+ppr_casm_results sty rs liveness
   = panic "ppr_casm_results: ccall/casm with many results"
 \end{code}
 
@@ -787,7 +761,7 @@ ppr_casm_results sty rs liveness
 Note the sneaky way _the_ result is represented by a list so that we
 can complain if it's used twice.
 
-ToDo: Any chance of giving line numbers when process-casm fails? 
+ToDo: Any chance of giving line numbers when process-casm fails?
       Or maybe we should do a check _much earlier_ in compiler. ADR
 
 \begin{code}
@@ -795,23 +769,23 @@ process_casm ::
 	[Unpretty]		-- results (length <= 1)
 	-> [Unpretty]		-- arguments
 	-> String		-- format string (with embedded %'s)
-	-> 
+	->
 	Unpretty			-- code being generated
 
 process_casm results args string = process results args string
  where
   process []    _ "" = uppNil
-  process (_:_) _ "" = error ("process_casm: non-void result not assigned while processing _casm_ \"" ++ string ++ "\"\n(Try changing result type to PrimIO ()\n") 
+  process (_:_) _ "" = error ("process_casm: non-void result not assigned while processing _casm_ \"" ++ string ++ "\"\n(Try changing result type to PrimIO ()\n")
 
   process ress args ('%':cs)
     = case cs of
-	[] -> 
+	[] ->
 	    error ("process_casm: lonely % while processing _casm_ \"" ++ string ++ "\".\n")
 
-	('%':css) -> 
+	('%':css) ->
 	    uppBeside (uppChar '%') (process ress args css)
 
-	('r':css)  -> 
+	('r':css)  ->
 	  case ress of
 	    []  -> error ("process_casm: no result to match %r while processing _casm_ \"" ++ string ++ "\".\nTry deleting %r or changing result type from PrimIO ()\n")
 	    [r] -> uppBeside r (process [] args css)
@@ -819,7 +793,7 @@ process_casm results args string = process results args string
 
 	other ->
 	  case readDec other of
-	    [(num,css)] -> 
+	    [(num,css)] ->
 		  if 0 <= num && num < length args
 		  then uppBesides [uppLparen, args !! num, uppRparen,
 				    process ress args css]
@@ -841,71 +815,71 @@ Printing assignments is a little tricky because of type coercion.
 First of all, the kind of the thing being assigned can be gotten from
 the destination addressing mode.  (It should be the same as the kind
 of the source addressing mode.)  If the kind of the assignment is of
-@VoidKind@, then don't generate any code at all.
+@VoidRep@, then don't generate any code at all.
 
 \begin{code}
-pprAssign :: PprStyle -> PrimKind -> CAddrMode -> CAddrMode -> Unpretty
+pprAssign :: PprStyle -> PrimRep -> CAddrMode -> CAddrMode -> Unpretty
 
-pprAssign sty VoidKind dest src = uppNil
+pprAssign sty VoidRep dest src = uppNil
 
 #if 0
 pprAssign sty kind dest src
- | (kind /= getAmodeKind dest) || (kind /= getAmodeKind src)
+ | (kind /= getAmodeRep dest) || (kind /= getAmodeRep src)
  = uppCat [uppStr "Bad kind:", pprPrimKind sty kind,
-	pprPrimKind sty (getAmodeKind dest), pprAmode sty dest,
-	pprPrimKind sty (getAmodeKind src),  pprAmode sty src]
+	pprPrimKind sty (getAmodeRep dest), pprAmode sty dest,
+	pprPrimKind sty (getAmodeRep src),  pprAmode sty src]
 #endif
 \end{code}
 
 Special treatment for floats and doubles, to avoid unwanted conversions.
 
 \begin{code}
-pprAssign sty FloatKind dest@(CVal reg_rel _) src
+pprAssign sty FloatRep dest@(CVal reg_rel _) src
   = uppBesides [ uppStr "ASSIGN_FLT(", ppr_amode sty (CAddr reg_rel), uppComma, pprAmode sty src, pp_paren_semi ]
 
-pprAssign sty DoubleKind dest@(CVal reg_rel _) src
+pprAssign sty DoubleRep dest@(CVal reg_rel _) src
   = uppBesides [ uppStr "ASSIGN_DBL(", ppr_amode sty (CAddr reg_rel), uppComma, pprAmode sty src, pp_paren_semi ]
 \end{code}
 
 Lastly, the question is: will the C compiler think the types of the
-two sides of the assignment match?  
+two sides of the assignment match?
 
 	We assume that the types will match
 	if neither side is a @CVal@ addressing mode for any register
 	which can point into the heap or B stack.
 
 Why?  Because the heap and B stack are used to store miscellaneous things,
-whereas the A stack, temporaries, registers, etc., are only used for things 
+whereas the A stack, temporaries, registers, etc., are only used for things
 of fixed type.
 
 \begin{code}
 pprAssign sty kind (CReg (VanillaReg _ dest)) (CReg (VanillaReg _ src))
-  = uppBesides [ pprVanillaReg dest, uppEquals, 
-                pprVanillaReg src, uppSemi ]
+  = uppBesides [ pprVanillaReg dest, uppEquals,
+		pprVanillaReg src, uppSemi ]
 
 pprAssign sty kind dest src
   | mixedTypeLocn dest
     -- Add in a cast to StgWord (a.k.a. W_) iff the destination is mixed
-  = uppBesides [ ppr_amode sty dest, uppEquals, 
+  = uppBesides [ ppr_amode sty dest, uppEquals,
 		uppStr "(W_)(",	-- Here is the cast
 		ppr_amode sty src, pp_paren_semi ]
 
 pprAssign sty kind dest src
-  | mixedPtrLocn dest && getAmodeKind src /= PtrKind
+  | mixedPtrLocn dest && getAmodeRep src /= PtrRep
     -- Add in a cast to StgPtr (a.k.a. P_) iff the destination is mixed
-  = uppBesides [ ppr_amode sty dest, uppEquals, 
+  = uppBesides [ ppr_amode sty dest, uppEquals,
 		uppStr "(P_)(",	-- Here is the cast
 		ppr_amode sty src, pp_paren_semi ]
 
-pprAssign sty ByteArrayKind dest src
+pprAssign sty ByteArrayRep dest src
   | mixedPtrLocn src
     -- Add in a cast to StgPtr (a.k.a. B_) iff the source is mixed
-  = uppBesides [ ppr_amode sty dest, uppEquals, 
+  = uppBesides [ ppr_amode sty dest, uppEquals,
 		uppStr "(B_)(",	-- Here is the cast
 		ppr_amode sty src, pp_paren_semi ]
-    
+
 pprAssign sty kind other_dest src
-  = uppBesides [ ppr_amode sty other_dest, uppEquals, 
+  = uppBesides [ ppr_amode sty other_dest, uppEquals,
 		pprAmode  sty src, uppSemi ]
 \end{code}
 
@@ -932,19 +906,19 @@ similar to those in @pprAssign@:
 question.)
 
 \begin{code}
-pprAmode sty (CVal reg_rel FloatKind) 
+pprAmode sty (CVal reg_rel FloatRep)
   = uppBesides [ uppStr "PK_FLT(", ppr_amode sty (CAddr reg_rel), uppRparen ]
-pprAmode sty (CVal reg_rel DoubleKind)
+pprAmode sty (CVal reg_rel DoubleRep)
   = uppBesides [ uppStr "PK_DBL(", ppr_amode sty (CAddr reg_rel), uppRparen ]
 \end{code}
 
-Next comes the case where there is some other cast need, and the 
+Next comes the case where there is some other cast need, and the
 no-cast case:
 
 \begin{code}
 pprAmode sty amode
   | mixedTypeLocn amode
-  = uppBesides [ uppLparen, pprPrimKind sty (getAmodeKind amode), uppStr ")(",
+  = uppBesides [ uppLparen, pprPrimKind sty (getAmodeRep amode), uppStr ")(",
 		ppr_amode sty amode, uppRparen]
   | otherwise	-- No cast needed
   = ppr_amode sty amode
@@ -958,7 +932,7 @@ ppr_amode sty (CVal reg_rel _)
 	(pp_reg, Nothing)     -> uppBeside  (uppChar '*') pp_reg
 	(pp_reg, Just offset) -> uppBesides [ pp_reg, uppLbrack, offset, uppRbrack ]
 
-ppr_amode sty (CAddr reg_rel) 
+ppr_amode sty (CAddr reg_rel)
   = case (pprRegRelative sty True{-sign wanted-} reg_rel) of
 	(pp_reg, Nothing)     -> pp_reg
 	(pp_reg, Just offset) -> uppBeside pp_reg offset
@@ -969,13 +943,13 @@ ppr_amode sty (CTemp uniq kind) = prettyToUn (pprUnique uniq)
 
 ppr_amode sty (CLbl label kind) = pprCLabel sty label
 
-ppr_amode sty (CUnVecLbl direct vectored) 
-  = uppBesides [uppStr "(StgRetAddr) UNVEC(", pprCLabel sty direct, uppComma, 
-               pprCLabel sty vectored, uppRparen]
+ppr_amode sty (CUnVecLbl direct vectored)
+  = uppBesides [uppStr "(StgRetAddr) UNVEC(", pprCLabel sty direct, uppComma,
+	       pprCLabel sty vectored, uppRparen]
 
-ppr_amode sty (CCharLike char) 
+ppr_amode sty (CCharLike char)
   = uppBesides [uppStr "CHARLIKE_CLOSURE(", pprAmode sty char, uppRparen ]
-ppr_amode sty (CIntLike int)   
+ppr_amode sty (CIntLike int)
   = uppBesides [uppStr "INTLIKE_CLOSURE(", pprAmode sty int, uppRparen ]
 
 ppr_amode sty (CString str) = uppBesides [uppChar '"', uppStr (stringToC (_UNPK_ str)), uppChar '"']
@@ -999,12 +973,12 @@ ppr_amode sty (CJoinPoint _ _)
 
 ppr_amode sty (CTableEntry base index kind)
   = uppBesides [uppStr "((", pprPrimKind sty kind, uppStr " *)(",
-               ppr_amode sty base, uppStr "))[(I_)(", ppr_amode sty index, 
+	       ppr_amode sty base, uppStr "))[(I_)(", ppr_amode sty index,
     	       uppStr ")]"]
 
 ppr_amode sty (CMacroExpr pk macro as)
-  = uppBesides [uppLparen, pprPrimKind sty pk, uppStr ")(", uppStr (show macro), uppLparen, 
-               uppIntersperse uppComma (map (pprAmode sty) as), uppStr "))"]
+  = uppBesides [uppLparen, pprPrimKind sty pk, uppStr ")(", uppStr (show macro), uppLparen,
+	       uppIntersperse uppComma (map (pprAmode sty) as), uppStr "))"]
 
 ppr_amode sty (CCostCentre cc print_as_string)
   = uppCostCentre sty print_as_string cc
@@ -1027,20 +1001,20 @@ addPlusSign True  p = uppBeside (uppChar '+') p
 
 pprSignedInt :: Bool -> Int -> Maybe Unpretty	-- Nothing => 0
 pprSignedInt sign_wanted n
- = if n == 0 then Nothing else 
+ = if n == 0 then Nothing else
    if n > 0  then Just (addPlusSign sign_wanted (uppInt n))
    else 	  Just (uppInt n)
 
-pprRegRelative :: PprStyle 
+pprRegRelative :: PprStyle
 	       -> Bool		-- True <=> Print leading plus sign (if +ve)
-	       -> RegRelative 
+	       -> RegRelative
 	       -> (Unpretty, Maybe Unpretty)
 
-pprRegRelative sty sign_wanted r@(SpARel spA off)
-  = (pprMagicId sty SpA, pprSignedInt sign_wanted (spARelToInt r))
+pprRegRelative sty sign_wanted (SpARel spA off)
+  = (pprMagicId sty SpA, pprSignedInt sign_wanted (spARelToInt spA off))
 
-pprRegRelative sty sign_wanted r@(SpBRel spB off)
-  = (pprMagicId sty SpB, pprSignedInt sign_wanted (spBRelToInt r))
+pprRegRelative sty sign_wanted (SpBRel spB off)
+  = (pprMagicId sty SpB, pprSignedInt sign_wanted (spBRelToInt spB off))
 
 pprRegRelative sty sign_wanted r@(HpRel hp off)
   = let to_print = hp `subOff` off
@@ -1064,7 +1038,7 @@ pprRegRelative sty sign_wanted (NodeRel off)
 \end{code}
 
 @pprMagicId@ just prints the register name.  @VanillaReg@ registers are
-represented by a discriminated union (@StgUnion@), so we use the @PrimKind@
+represented by a discriminated union (@StgUnion@), so we use the @PrimRep@
 to select the union tag.
 
 \begin{code}
@@ -1073,8 +1047,8 @@ pprMagicId :: PprStyle -> MagicId -> Unpretty
 pprMagicId sty BaseReg	    	    = uppPStr SLIT("BaseReg")
 pprMagicId sty StkOReg		    = uppPStr SLIT("StkOReg")
 pprMagicId sty (VanillaReg pk n)
-                                    = uppBesides [ pprVanillaReg n, uppChar '.', 
-                                                  pprUnionTag pk ]
+				    = uppBesides [ pprVanillaReg n, uppChar '.',
+						  pprUnionTag pk ]
 pprMagicId sty (FloatReg  n)        = uppBeside (uppPStr SLIT("FltReg")) (uppInt IBOX(n))
 pprMagicId sty (DoubleReg n)	    = uppBeside (uppPStr SLIT("DblReg")) (uppInt IBOX(n))
 pprMagicId sty TagReg		    = uppPStr SLIT("TagReg")
@@ -1086,43 +1060,37 @@ pprMagicId sty SuB		    = uppPStr SLIT("SuB")
 pprMagicId sty Hp		    = uppPStr SLIT("Hp")
 pprMagicId sty HpLim		    = uppPStr SLIT("HpLim")
 pprMagicId sty LivenessReg	    = uppPStr SLIT("LivenessReg")
---UNUSED pprMagicId sty ActivityReg	    = uppPStr SLIT("ActivityReg")
 pprMagicId sty StdUpdRetVecReg      = uppPStr SLIT("StdUpdRetVecReg")
 pprMagicId sty StkStubReg	    = uppPStr SLIT("StkStubReg")
 pprMagicId sty CurCostCentre	    = uppPStr SLIT("CCC")
-pprMagicId sty VoidReg		    = {-uppStr "RetVoid!"-} panic "pprMagicId:VoidReg!"
-#ifdef DPH
-pprMagicId sty (DataReg _ n)	    = uppBeside (uppPStr SLIT("RD")) (uppInt n)
-#endif {- Data Parallel Haskell -}
+pprMagicId sty VoidReg		    = panic "pprMagicId:VoidReg!"
 
 pprVanillaReg :: FAST_INT -> Unpretty
 
 pprVanillaReg n = uppBeside (uppChar 'R') (uppInt IBOX(n))
 
-pprUnionTag :: PrimKind -> Unpretty 
+pprUnionTag :: PrimRep -> Unpretty
 
-pprUnionTag PtrKind		= uppChar 'p'
-pprUnionTag CodePtrKind	    	= uppPStr SLIT("fp")
-pprUnionTag DataPtrKind	    	= uppChar 'd'
-pprUnionTag RetKind 	    	= uppChar 'r'
-pprUnionTag InfoPtrKind	    	= uppChar 'd'
-pprUnionTag CostCentreKind	= panic "pprUnionTag:CostCentre?"
+pprUnionTag PtrRep		= uppChar 'p'
+pprUnionTag CodePtrRep	    	= uppPStr SLIT("fp")
+pprUnionTag DataPtrRep	    	= uppChar 'd'
+pprUnionTag RetRep 	    	= uppChar 'r'
+pprUnionTag CostCentreRep	= panic "pprUnionTag:CostCentre?"
 
-pprUnionTag CharKind		= uppChar 'c'
-pprUnionTag IntKind		= uppChar 'i'
-pprUnionTag WordKind		= uppChar 'w'
-pprUnionTag AddrKind		= uppChar 'v'
-pprUnionTag FloatKind		= uppChar 'f'
-pprUnionTag DoubleKind		= panic "pprUnionTag:Double?"
+pprUnionTag CharRep		= uppChar 'c'
+pprUnionTag IntRep		= uppChar 'i'
+pprUnionTag WordRep		= uppChar 'w'
+pprUnionTag AddrRep		= uppChar 'v'
+pprUnionTag FloatRep		= uppChar 'f'
+pprUnionTag DoubleRep		= panic "pprUnionTag:Double?"
 
-pprUnionTag StablePtrKind	= uppChar 'i'
-pprUnionTag MallocPtrKind	= uppChar 'p'
+pprUnionTag StablePtrRep	= uppChar 'i'
+pprUnionTag MallocPtrRep	= uppChar 'p'
 
-pprUnionTag ArrayKind		= uppChar 'p'
-pprUnionTag ByteArrayKind	= uppChar 'b'
+pprUnionTag ArrayRep		= uppChar 'p'
+pprUnionTag ByteArrayRep	= uppChar 'b'
 
 pprUnionTag _                   = panic "pprUnionTag:Odd kind"
-
 \end{code}
 
 
@@ -1153,11 +1121,11 @@ pprTempAndExternDecls other_stmt
 		  Just pp -> pp )
 	   )
 
-pprBasicLit :: PprStyle -> BasicLit 	-> Unpretty
-pprPrimKind :: PprStyle -> PrimKind -> Unpretty
+pprBasicLit :: PprStyle -> Literal -> Unpretty
+pprPrimKind :: PprStyle -> PrimRep -> Unpretty
 
-pprBasicLit  sty lit = uppStr (showBasicLit  sty lit)
-pprPrimKind  sty k   = uppStr (showPrimKind k)
+pprBasicLit  sty lit = uppStr (showLiteral  sty lit)
+pprPrimKind  sty k   = uppStr (showPrimRep k)
 \end{code}
 
 
@@ -1196,10 +1164,8 @@ initTE sa
   = case sa (emptyUniqueSet, emptyCLabelSet) of { (_, result) ->
     result }
 
-#ifdef __GLASGOW_HASKELL__
 {-# INLINE thenTE #-}
 {-# INLINE returnTE #-}
-#endif
 
 thenTE :: TeM a -> (a -> TeM b) -> TeM b
 thenTE a b u
@@ -1238,13 +1204,13 @@ labelSeenTE label env@(seen_uniqs, seen_labels)
 \end{code}
 
 \begin{code}
-pprTempDecl :: Unique -> PrimKind -> Unpretty
+pprTempDecl :: Unique -> PrimRep -> Unpretty
 pprTempDecl uniq kind
   = uppBesides [ pprPrimKind PprDebug kind, uppSP, prettyToUn (pprUnique uniq), uppSemi ]
 
 ppr_for_C = PprForC ( \ x -> False ) -- pretend no special cmd-line flags
 
-pprExternDecl :: CLabel -> PrimKind -> Unpretty
+pprExternDecl :: CLabel -> PrimRep -> Unpretty
 
 pprExternDecl clabel kind
   = if not (needsCDecl clabel) then
@@ -1252,7 +1218,7 @@ pprExternDecl clabel kind
     else
 	BIND (
 	    case kind of
-	      CodePtrKind -> ppLocalnessMacro True{-function-} clabel
+	      CodePtrRep -> ppLocalnessMacro True{-function-} clabel
 	      _		  -> ppLocalnessMacro False{-data-}    clabel
 	) _TO_ pp_macro_str ->
 
@@ -1273,8 +1239,6 @@ ppr_decls_AbsC (AbsCStmts stmts_1 stmts_2)
 ppr_decls_AbsC (CClosureUpdInfo info)
   = ppr_decls_AbsC info
 
---UNUSED: ppr_decls_AbsC (CComment comment) = returnTE (Nothing, Nothing)
-
 ppr_decls_AbsC (CSplitMarker) = returnTE (Nothing, Nothing)
 
 ppr_decls_AbsC (CAssign dest source)
@@ -1306,7 +1270,7 @@ ppr_decls_AbsC (CInitHdr cl_info reg_rel cost_centre inplace_upd)
 	      if label_seen then
 		  Nothing
 	      else
-		  Just (pprExternDecl info_lbl PtrKind))
+		  Just (pprExternDecl info_lbl PtrRep))
   where
     info_lbl = infoTableLabelFromCI cl_info
 
@@ -1329,11 +1293,11 @@ ppr_decls_AbsC (CClosureInfoAndCode cl_info slow maybe_fast upd_lbl _ _)
   = ppr_decls_Amodes [entry_lbl, upd_lbl]	`thenTE` \ p1 ->
     ppr_decls_AbsC slow				`thenTE` \ p2 ->
     (case maybe_fast of
-        Nothing   -> returnTE (Nothing, Nothing)
-        Just fast -> ppr_decls_AbsC fast)	`thenTE` \ p3 ->
+	Nothing   -> returnTE (Nothing, Nothing)
+	Just fast -> ppr_decls_AbsC fast)	`thenTE` \ p3 ->
     returnTE (maybe_uppAboves [p1, p2, p3])
   where
-    entry_lbl = CLbl slow_lbl CodePtrKind
+    entry_lbl = CLbl slow_lbl CodePtrRep
     slow_lbl    = case (nonemptyAbsC slow) of
 		    Nothing -> mkErrorStdEntryLabel
 		    Just _  -> entryLabelFromCI cl_info
@@ -1343,16 +1307,8 @@ ppr_decls_AbsC (CRetVector label maybe_amodes absC)
     ppr_decls_AbsC   absC			`thenTE` \ p2 ->
     returnTE (maybe_uppAboves [p1, p2])
 
-ppr_decls_AbsC (CRetUnVector label amode)
-  = ppr_decls_Amode amode
-
-ppr_decls_AbsC (CFlatRetVector label amodes)
-  = ppr_decls_Amodes amodes
-
-#ifdef DPH
-ppr_decls_AbsC (CNativeInfoTableAndCode _ _ absC)
-  = ppr_decls_AbsC absC
-#endif {- Data Parallel Haskell -}
+ppr_decls_AbsC (CRetUnVector   _ amode)  = ppr_decls_Amode amode
+ppr_decls_AbsC (CFlatRetVector _ amodes) = ppr_decls_Amodes amodes
 \end{code}
 
 \begin{code}
@@ -1375,13 +1331,13 @@ ppr_decls_Amode (CCharLike char)
 -- now, the only place where we actually print temps/externs...
 ppr_decls_Amode (CTemp uniq kind)
   = case kind of
-      VoidKind -> returnTE (Nothing, Nothing)
+      VoidRep -> returnTE (Nothing, Nothing)
       other ->
 	tempSeenTE uniq `thenTE` \ temp_seen ->
 	returnTE
 	  (if temp_seen then Nothing else Just (pprTempDecl uniq kind), Nothing)
 
-ppr_decls_Amode (CLbl label VoidKind)
+ppr_decls_Amode (CLbl label VoidRep)
   = returnTE (Nothing, Nothing)
 
 ppr_decls_Amode (CLbl label kind)
@@ -1394,8 +1350,8 @@ ppr_decls_Amode (CUnVecLbl direct vectored)
   = labelSeenTE direct   `thenTE` \ dlbl_seen ->
     labelSeenTE vectored `thenTE` \ vlbl_seen ->
     let
-        ddcl = if dlbl_seen then uppNil else pprExternDecl direct CodePtrKind
-        vdcl = if vlbl_seen then uppNil else pprExternDecl vectored DataPtrKind
+	ddcl = if dlbl_seen then uppNil else pprExternDecl direct CodePtrRep
+	vdcl = if vlbl_seen then uppNil else pprExternDecl vectored DataPtrRep
     in
     returnTE (Nothing,
     	    	if (dlbl_seen || not (needsCDecl direct)) &&
@@ -1410,8 +1366,8 @@ ppr_decls_Amode (CUnVecLbl direct vectored)
     --labelSeenTE direct   `thenTE` \ dlbl_seen ->
     --labelSeenTE vectored `thenTE` \ vlbl_seen ->
     let
-        ddcl = {-if dlbl_seen then uppNil else-} pprExternDecl direct CodePtrKind
-        vdcl = {-if vlbl_seen then uppNil else-} pprExternDecl vectored DataPtrKind
+	ddcl = {-if dlbl_seen then uppNil else-} pprExternDecl direct CodePtrRep
+	vdcl = {-if vlbl_seen then uppNil else-} pprExternDecl vectored DataPtrRep
     in
     returnTE (Nothing,
     	    	if ({-dlbl_seen ||-} not (needsCDecl direct)) &&
diff --git a/ghc/compiler/basicTypes/BasicLit.hi b/ghc/compiler/basicTypes/BasicLit.hi
deleted file mode 100644
index 4152591665..0000000000
--- a/ghc/compiler/basicTypes/BasicLit.hi
+++ /dev/null
@@ -1,22 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface BasicLit where
-import Outputable(Outputable)
-import PreludePS(_PackedString)
-import PreludeRatio(Ratio(..))
-import Pretty(PprStyle)
-import PrimKind(PrimKind)
-import UniType(UniType)
-data BasicLit   = MachChar Char | MachStr _PackedString | MachAddr Integer | MachInt Integer Bool | MachFloat (Ratio Integer) | MachDouble (Ratio Integer) | MachLitLit _PackedString PrimKind | NoRepStr _PackedString | NoRepInteger Integer | NoRepRational (Ratio Integer)
-data PrimKind 
-data UniType 
-isLitLitLit :: BasicLit -> Bool
-isNoRepLit :: BasicLit -> Bool
-kindOfBasicLit :: BasicLit -> PrimKind
-mkMachInt :: Integer -> BasicLit
-mkMachWord :: Integer -> BasicLit
-showBasicLit :: PprStyle -> BasicLit -> [Char]
-typeOfBasicLit :: BasicLit -> UniType
-instance Eq BasicLit
-instance Ord BasicLit
-instance Outputable BasicLit
-
diff --git a/ghc/compiler/basicTypes/BasicLit.lhs b/ghc/compiler/basicTypes/BasicLit.lhs
deleted file mode 100644
index d3dbb89600..0000000000
--- a/ghc/compiler/basicTypes/BasicLit.lhs
+++ /dev/null
@@ -1,197 +0,0 @@
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
-%
-\section[BasicLit]{@BasicLit@: Machine literals (unboxed, of course)}
-
-\begin{code}
-#include "HsVersions.h"
-
-module BasicLit (
-	BasicLit(..),
-	mkMachInt, mkMachWord,
-	typeOfBasicLit, kindOfBasicLit,
-	showBasicLit,
-	isNoRepLit, isLitLitLit,
-
-	-- and to make the interface self-sufficient....
-	UniType, PrimKind
-    ) where
-
-import AbsPrel		( addrPrimTy, intPrimTy, floatPrimTy, doublePrimTy,
-			  charPrimTy, wordPrimTy,
-			  integerTy, rationalTy, stringTy, UniType,
-			  TauType(..)
-			  IF_ATTACK_PRAGMAS(COMMA mkListTy COMMA charTy)
-			  IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
-			  IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
-			)
-import AbsUniType	( TyCon IF_ATTACK_PRAGMAS(COMMA cmpTyCon) )
-import PrimKind		( getKindInfo ) -- ToDo: *** HACK import ****
-import CLabelInfo	( stringToC, charToC, charToEasyHaskell )
-import Outputable	-- class for printing, forcing
-import Pretty		-- pretty-printing stuff
-import PrimKind		( PrimKind(..) )
-import Util
-\end{code}
-
-So-called @BasicLits@ are {\em either}:
-\begin{itemize}
-\item
-An unboxed (``machine'') literal (type: @IntPrim@, @FloatPrim@, etc.),
-which is presumed to be surrounded by appropriate constructors
-(@mKINT@, etc.), so that the overall thing makes sense.
-\item
-An Integer, Rational, or String literal whose representation we are
-{\em uncommitted} about; i.e., the surrounding with constructors,
-function applications, etc., etc., has not yet been done.
-\end{itemize}
-
-\begin{code}
-data BasicLit
-  = MachChar	Char
-  | MachStr	FAST_STRING
-  | MachAddr	Integer	-- whatever this machine thinks is a "pointer"
-  | MachInt	Integer	-- for the numeric types, these are
-		Bool	-- True <=> signed (Int#); False <=> unsigned (Word#) 
-  | MachFloat	Rational
-  | MachDouble	Rational
-  | MachLitLit  FAST_STRING
-		PrimKind
-
-  | NoRepStr	    FAST_STRING	-- the uncommitted ones
-  | NoRepInteger    Integer
-  | NoRepRational   Rational
-
-  deriving (Eq, Ord)
-  -- The Ord is needed for the FiniteMap used in the lookForConstructor
-  -- in SimplEnv.  If you declared that lookForConstructor *ignores*
-  -- constructor-applications with CoLitAtom args, then you could get
-  -- rid of this Ord.
-
-mkMachInt, mkMachWord :: Integer -> BasicLit
-
-mkMachInt  x = MachInt x True{-signed-}
-mkMachWord x = MachInt x False{-unsigned-}
-\end{code}
-
-\begin{code}
-isNoRepLit (NoRepStr _)     	= True -- these are not primitive typed!
-isNoRepLit (NoRepInteger _) 	= True
-isNoRepLit (NoRepRational _)	= True
-isNoRepLit _			= False
-
-isLitLitLit (MachLitLit _ _) = True
-isLitLitLit _	    	     = False
-\end{code}
-
-\begin{code}
-typeOfBasicLit :: BasicLit -> UniType
-
-typeOfBasicLit (MachChar _)	= charPrimTy
-typeOfBasicLit (MachStr  _)	= addrPrimTy
-typeOfBasicLit (MachAddr _)	= addrPrimTy
-typeOfBasicLit (MachInt  _ signed) = if signed then intPrimTy else wordPrimTy
-typeOfBasicLit (MachFloat _)	= floatPrimTy
-typeOfBasicLit (MachDouble _)	= doublePrimTy
-typeOfBasicLit (MachLitLit _ k)	= case (getKindInfo k) of { (_,t,_) -> t }
-typeOfBasicLit (NoRepInteger _)	= integerTy
-typeOfBasicLit (NoRepRational _)= rationalTy
-typeOfBasicLit (NoRepStr _)	= stringTy
-\end{code}
-
-\begin{code}
-kindOfBasicLit :: BasicLit -> PrimKind
-
-kindOfBasicLit (MachChar _)	= CharKind
-kindOfBasicLit (MachStr _)	= AddrKind  -- specifically: "char *"
-kindOfBasicLit (MachAddr  _)	= AddrKind
-kindOfBasicLit (MachInt _ signed) = if signed then IntKind else WordKind
-kindOfBasicLit (MachFloat _)	= FloatKind
-kindOfBasicLit (MachDouble _)	= DoubleKind
-kindOfBasicLit (MachLitLit _ k)	= k
-kindOfBasicLit (NoRepInteger _)	= panic "kindOfBasicLit:NoRepInteger"
-kindOfBasicLit (NoRepRational _)= panic "kindOfBasicLit:NoRepRational"
-kindOfBasicLit (NoRepStr _)	= panic "kindOfBasicLit:NoRepString"
-\end{code}
-
-The boring old output stuff:
-\begin{code}
-ppCast :: PprStyle -> FAST_STRING -> Pretty
-ppCast (PprForC _) cast = ppPStr cast
-ppCast _           _    = ppNil
-
-instance Outputable BasicLit where
-    ppr sty (MachChar ch)
-      = let
-	    char_encoding
-	      = case sty of
-		  PprForC _ 	 -> charToC ch
-		  PprForAsm _ _ _ -> charToC ch
-		  PprUnfolding _ -> charToEasyHaskell ch
-		  _ 	    	 -> [ch]
-	in
-	ppBeside (ppBesides [ppCast sty SLIT("(C_)"), ppChar '\'', ppStr char_encoding, ppChar '\''])
-		 (if_ubxd sty)
-
-    ppr sty (MachStr s)
-      = ppBeside (if codeStyle sty
-		  then ppBesides [ppChar '"', ppStr (stringToC (_UNPK_ s)), ppChar '"']
-		  else ppStr (show (_UNPK_ s)))
-		 (if_ubxd sty)
-
-    ppr sty (MachAddr p) = ppBesides [ppCast sty SLIT("(void*)"), ppInteger p, if_ubxd sty]
-    ppr sty (MachInt i signed)
-      | codeStyle sty
-      && ((signed     && (i >= toInteger minInt && i <= toInteger maxInt))
-       || (not signed && (i >= toInteger 0      && i <= toInteger maxInt)))
-      -- ToDo: Think about these ranges!
-      = ppBesides [ppInteger i, if_ubxd sty]
-
-      | not (codeStyle sty) -- we'd prefer the code to the error message
-      = ppBesides [ppInteger i, if_ubxd sty]
-
-      | otherwise
-      = error ("ERROR: Int " ++ show i ++ " out of range [" ++
-		show range_min ++ " .. " ++ show maxInt ++ "]\n")
-      where
-	range_min = if signed then minInt else 0
-
-    ppr sty (MachFloat f)  = ppBesides [ppCast sty SLIT("(StgFloat)"), ppRational f, if_ubxd sty]
-    ppr sty (MachDouble d) = ppBesides [ppRational d, if_ubxd sty, if_ubxd sty]
-
-#ifdef DPH
-    -- I know that this thing shouldnt pop out of the compiler, but the
-    -- native code generator tries to generate code to initilialise a closure
-    -- with this value... (in glaExts/PreludeGlaInOut.lhs)
-    ppr sty MachVoid		= ppStr "0 ! {- void# -}"
-#endif {- Data Parallel Haskell -}
-    
-    ppr sty (NoRepInteger i)
-      | codeStyle sty  = ppInteger i
-      | ufStyle sty    = ppCat [ppStr "_NOREP_I_", ppInteger i]
-      | otherwise      = ppBesides [ppInteger i, ppChar 'I']
-
-    ppr sty (NoRepRational r)
-      | ufStyle sty    = ppCat [ppStr "_NOREP_R_", ppInteger (numerator r), ppInteger (denominator r)]
-      | codeStyle sty = panic "ppr.ForC.NoRepRational"
-      | otherwise     = ppBesides [ppRational r,  ppChar 'R']
-
-    ppr sty (NoRepStr s)
-      | codeStyle sty = ppBesides [ppStr (show (_UNPK_ s))]
-      | ufStyle   sty = ppCat [ppStr "_NOREP_S_", ppStr (show (_UNPK_ s))]
-      | otherwise     = ppBesides [ppStr (show (_UNPK_ s)), ppChar 'S']
-
-    ppr sty (MachLitLit s k)
-      | codeStyle sty = ppPStr s
-      | ufStyle   sty = ppBesides [ppStr "``", ppPStr s, ppStr "'' _K_ ", ppr sty k]
-      | otherwise     = ppBesides [ppStr "``", ppPStr s, ppStr "''"]
-
-ufStyle (PprUnfolding _) = True
-ufStyle _   	    	 = False
-
-if_ubxd sty = if codeStyle sty then ppNil else ppChar '#'
-
-showBasicLit :: PprStyle -> BasicLit -> String
-
-showBasicLit sty lit = ppShow 80 (ppr sty lit)
-\end{code}
diff --git a/ghc/compiler/basicTypes/CLabelInfo.hi b/ghc/compiler/basicTypes/CLabelInfo.hi
deleted file mode 100644
index 0a37bc40a2..0000000000
--- a/ghc/compiler/basicTypes/CLabelInfo.hi
+++ /dev/null
@@ -1,48 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface CLabelInfo where
-import CharSeq(CSeq)
-import Id(Id)
-import PreludePS(_PackedString)
-import Pretty(PprStyle, PrettyRep)
-import TyCon(TyCon)
-import Unique(Unique)
-data CLabel 
-data Id 
-data TyCon 
-data Unique 
-cSEP :: _PackedString
-charToC :: Char -> [Char]
-charToEasyHaskell :: Char -> [Char]
-externallyVisibleCLabel :: CLabel -> Bool
-identToC :: _PackedString -> Int -> Bool -> PrettyRep
-isAsmTemp :: CLabel -> Bool
-isReadOnly :: CLabel -> Bool
-mkAltLabel :: Unique -> Int -> CLabel
-mkAsmTempLabel :: Unique -> CLabel
-mkBlackHoleInfoTableLabel :: CLabel
-mkClosureLabel :: Id -> CLabel
-mkConEntryLabel :: Id -> CLabel
-mkConUpdCodePtrVecLabel :: TyCon -> Int -> CLabel
-mkDefaultLabel :: Unique -> CLabel
-mkErrorStdEntryLabel :: CLabel
-mkFastEntryLabel :: Id -> Int -> CLabel
-mkInfoTableLabel :: Id -> CLabel
-mkInfoTableVecTblLabel :: TyCon -> CLabel
-mkPhantomInfoTableLabel :: Id -> CLabel
-mkRednCountsLabel :: Id -> CLabel
-mkReturnPtLabel :: Unique -> CLabel
-mkStaticConEntryLabel :: Id -> CLabel
-mkStaticInfoTableLabel :: Id -> CLabel
-mkStdEntryLabel :: Id -> CLabel
-mkStdUpdCodePtrVecLabel :: TyCon -> Int -> CLabel
-mkStdUpdVecTblLabel :: TyCon -> CLabel
-mkVapEntryLabel :: Id -> Bool -> CLabel
-mkVapInfoTableLabel :: Id -> Bool -> CLabel
-mkVecTblLabel :: Unique -> CLabel
-modnameToC :: _PackedString -> _PackedString
-needsCDecl :: CLabel -> Bool
-pprCLabel :: PprStyle -> CLabel -> CSeq
-stringToC :: [Char] -> [Char]
-instance Eq CLabel
-instance Ord CLabel
-
diff --git a/ghc/compiler/basicTypes/CLabelInfo.lhs b/ghc/compiler/basicTypes/CLabelInfo.lhs
deleted file mode 100644
index 5455a6f0ed..0000000000
--- a/ghc/compiler/basicTypes/CLabelInfo.lhs
+++ /dev/null
@@ -1,661 +0,0 @@
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
-%
-\section[CLabelInfo]{@CLabelInfo@: Information to make C Labels}
-
-\begin{code}
-#include "HsVersions.h"
-
-module CLabelInfo (
-	CLabel,	-- abstract type
-
-	mkClosureLabel,
-	mkInfoTableLabel,
-	mkStdEntryLabel,
-	mkFastEntryLabel,
-	mkConEntryLabel,
-	mkStaticConEntryLabel,
-	mkRednCountsLabel,
-	mkPhantomInfoTableLabel,
-	mkStaticInfoTableLabel,
-	mkVapEntryLabel,
-	mkVapInfoTableLabel,
-
---UNUSED: mkConUpdCodePtrUnvecLabel,
-	mkConUpdCodePtrVecLabel,
-	mkStdUpdCodePtrVecLabel,
-
-	mkInfoTableVecTblLabel,
-	mkStdUpdVecTblLabel,
-
-	mkReturnPtLabel,
-	mkVecTblLabel,
-	mkAltLabel,
-	mkDefaultLabel,
-
-	mkAsmTempLabel,
-
-	mkErrorStdEntryLabel,
-	mkBlackHoleInfoTableLabel,
---UNUSED: mkSelectorInfoTableLabel,
---UNUSED: mkSelectorEntryLabel,
-
-#ifdef DPH
-	mkLocalLabel, isLocalLabel, isNestableBlockLabel,
-	isGlobalDataLabel, isDataLabel, 
-	needsApalDecl, isVectorTableLabel, isSlowFastLabelPair,
-#endif {- Data Parallel Haskell -}
-
-	needsCDecl, isReadOnly, isAsmTemp, externallyVisibleCLabel,
-
-	cSEP, identToC, modnameToC, stringToC, charToC, charToEasyHaskell,
-	pprCLabel,
-
-#ifdef GRAN
-	isSlowEntryCCodeBlock,
-#endif
-
-	-- and to make the interface self-sufficient...
-	Id, TyCon, Unique
-    ) where
-
-import AbsUniType	( showTyCon, cmpTyCon, isBigTupleTyCon,
-			  TyCon, Unique
-			)
-import Id		( externallyVisibleId, cmpId_withSpecDataCon,
-			  isDataCon, isDictFunId, isConstMethodId_maybe,
-			  isClassOpId, isDefaultMethodId_maybe, isSuperDictSelId_maybe,
-			  Id, Class, ClassOp, DataCon(..), ConTag(..), fIRST_TAG
-#ifdef DPH
-			 ,isInventedTopLevId
-#endif {- Data Parallel Haskell -}
-			)
-import Maybes
-import Outputable
-import Pretty		( ppNil, ppChar, ppStr, ppPStr, ppDouble, ppInt,
-			  ppInteger, ppBeside, ppIntersperse, prettyToUn
-			)
-#ifdef USE_ATTACK_PRAGMAS
-import CharSeq
-#endif
-import Unpretty		-- NOTE!! ********************
-import Unique		( cmpUnique, showUnique, pprUnique, Unique )
-import Util
-
-#ifdef DPH
-import AbsCSyn		( MagicId )
-import PprAbsC		( pprMagicId )
-#endif {- Data Parallel Haskell -}
-
--- Sigh...  Shouldn't this file (CLabelInfo) live in codeGen?
-import CgRetConv    	( CtrlReturnConvention(..), ctrlReturnConvAlg )
-
-\end{code}
-
-things we want to find out:
-
-* should the labelled things be declared "static" (visible only in this file)?
-
-* should it be declared "const" (read-only text space)?
-
-* does it need declarations at all? (v common Prelude things are pre-declared)
-
-\begin{code}
-data CLabel
-  = IdLabel	    		-- A family of labels related to the 
-	CLabelId		-- definition of a particular Id
-	IdLabelInfo		-- Includes DataCon
-
-  | TyConLabel			-- A family of labels related to the
-	TyCon			-- definition of a data type
-	TyConLabelInfo
-
-  | CaseLabel			-- A family of labels related to a particular case expression
-	Unique			-- Unique says which case expression
-	CaseLabelInfo
-
-  | AsmTempLabel    Unique
-
-  | RtsLabel	    RtsLabelInfo
-
-#ifdef DPH
-  | ALocalLabel     Unique	-- Label within a code block.
-		    String
-#endif {- Data Parallel Haskell -}
-  deriving (Eq, Ord)
-\end{code}
-
-The CLabelId is simply so we can declare alternative Eq and Ord
-instances which use cmpId_SpecDataCon (instead of cmpId). This avoids
-comparing the Uniques of two specialised data constructors (which have
-the same as the uniques their respective unspecialised data
-constructors). Instead, the specialising types and the uniques of the
-unspecialised constructors are compared.
-
-\begin{code}
-data CLabelId = CLabelId Id
-
-instance Eq CLabelId where
-    CLabelId a == CLabelId b = case cmpId_withSpecDataCon a b of { EQ_ -> True;  _ -> False }
-    CLabelId a /= CLabelId b = case cmpId_withSpecDataCon a b of { EQ_ -> False; _ -> True  }
-
-instance Ord CLabelId where
-    CLabelId a <= CLabelId b = case cmpId_withSpecDataCon a b
-	 of { LT_ -> True;  EQ_ -> True;  GT__ -> False }
-    CLabelId a <  CLabelId b = case cmpId_withSpecDataCon a b
-	 of { LT_ -> True;  EQ_ -> False; GT__ -> False }
-    CLabelId a >= CLabelId b = case cmpId_withSpecDataCon a b
-	 of { LT_ -> False; EQ_ -> True;  GT__ -> True  }
-    CLabelId a >  CLabelId b = case cmpId_withSpecDataCon a b
-	 of { LT_ -> False; EQ_ -> False; GT__ -> True  }
-#ifdef __GLASGOW_HASKELL__
-    _tagCmp (CLabelId a) (CLabelId b) = case cmpId_withSpecDataCon a b
-	 of { LT_ -> _LT; EQ_ -> _EQ; GT__ -> _GT }
-#endif
-\end{code}
-
-\begin{code}
-data IdLabelInfo
-  = Closure		-- Label for (static???) closure
-
-  | InfoTbl		-- Info table for a closure; always read-only
-
-  | EntryStd		-- Thunk, or "slow", code entry point (requires arg satis check)
-  | EntryFast Int	-- entry pt when no arg satisfaction chk needed;
-			-- Int is the arity of the function (to be
-			-- encoded into the name)
-
-  | ConEntry		-- the only kind of entry pt for constructors
-  | StaticConEntry  	-- static constructor entry point
-
-  | StaticInfoTbl   	-- corresponding info table
-
-  | PhantomInfoTbl  	-- for phantom constructors that only exist in regs
-
-  | VapInfoTbl Bool	-- True <=> the update-reqd version; False <=> the no-update-reqd version
-  | VapEntry Bool
-
-	-- Ticky-ticky counting
-  | RednCounts		-- Label of place to keep reduction-count info for this Id
-  deriving (Eq, Ord)
-
-
-data TyConLabelInfo
-  = UnvecConUpdCode	 -- Update code for the data type if it's unvectored
-			 
-  | VecConUpdCode ConTag -- One for each constructor which returns in
-		    	 -- regs; this code actually performs an update
-			 
-  | StdUpdCode ConTag	 -- Update code for all constructors which return
-    	    	    	 -- in heap.  There are a small number of variants,
-    	    	    	 -- so that the update code returns (vectored/n or
-			 -- unvectored) in the right way.
-			 -- ToDo: maybe replace TyCon/Int with return conv.
-			 
-  | InfoTblVecTbl	 -- For tables of info tables
-			 
-  | StdUpdVecTbl	 -- Labels the update code, or table of update codes,
-			 -- for a particular type.
-  deriving (Eq, Ord)
-
-data CaseLabelInfo  
-  = CaseReturnPt
-  | CaseVecTbl
-  | CaseAlt ConTag
-  | CaseDefault
-  deriving (Eq, Ord)
-
-data RtsLabelInfo
-  = RtsShouldNeverHappenCode
-
-  | RtsBlackHoleInfoTbl
-
-  | RtsSelectorInfoTbl	-- Selectors
-	Bool		-- True <=> the update-reqd version;
-			-- False <=> the no-update-reqd version
-	Int		-- 0-indexed Offset from the "goods"
-
-  | RtsSelectorEntry	-- Ditto entry code
-	Bool
-	Int
-  deriving (Eq, Ord)
-\end{code}
-
-\begin{code}
-mkClosureLabel	      	id 		= IdLabel (CLabelId id) Closure
-mkInfoTableLabel      	id 		= IdLabel (CLabelId id) InfoTbl
-mkStdEntryLabel	      	id 		= IdLabel (CLabelId id) EntryStd
-mkFastEntryLabel      	id arity	= ASSERT(arity > 0)
-					  IdLabel (CLabelId id) (EntryFast arity)
-mkConEntryLabel	      	id		= IdLabel (CLabelId id) ConEntry
-mkStaticConEntryLabel 	id		= IdLabel (CLabelId id) StaticConEntry
-mkRednCountsLabel     	id		= IdLabel (CLabelId id) RednCounts
-mkPhantomInfoTableLabel id		= IdLabel (CLabelId id) PhantomInfoTbl
-mkStaticInfoTableLabel  id		= IdLabel (CLabelId id) StaticInfoTbl
-mkVapEntryLabel		id upd_flag	= IdLabel (CLabelId id) (VapEntry upd_flag)
-mkVapInfoTableLabel	id upd_flag	= IdLabel (CLabelId id) (VapInfoTbl upd_flag)
-
---UNUSED:mkConUpdCodePtrUnvecLabel tycon     = TyConLabel tycon UnvecConUpdCode
-mkConUpdCodePtrVecLabel   tycon tag = TyConLabel tycon (VecConUpdCode tag)
-mkStdUpdCodePtrVecLabel   tycon tag = TyConLabel tycon (StdUpdCode tag)
-
-mkInfoTableVecTblLabel	  tycon     = TyConLabel tycon InfoTblVecTbl
-mkStdUpdVecTblLabel	  tycon     = TyConLabel tycon StdUpdVecTbl
-
-mkReturnPtLabel uniq		= CaseLabel uniq CaseReturnPt
-mkVecTblLabel   uniq		= CaseLabel uniq CaseVecTbl
-mkAltLabel      uniq tag	= CaseLabel uniq (CaseAlt tag)
-mkDefaultLabel  uniq 		= CaseLabel uniq CaseDefault
-
-mkAsmTempLabel 			= AsmTempLabel
-
-	-- Some fixed runtime system labels
-
-mkErrorStdEntryLabel		= RtsLabel RtsShouldNeverHappenCode
-mkBlackHoleInfoTableLabel	= RtsLabel RtsBlackHoleInfoTbl
---UNUSED:mkSelectorInfoTableLabel upd_reqd offset = RtsLabel (RtsSelectorInfoTbl upd_reqd offset)
---UNUSED: mkSelectorEntryLabel upd_reqd offset     = RtsLabel (RtsSelectorEntry upd_reqd offset)
-
-#ifdef DPH
-mkLocalLabel = ALocalLabel
-#endif {- Data Parallel Haskell -}
-\end{code}
-
-\begin{code}
-needsCDecl :: CLabel -> Bool	-- False <=> it's pre-declared; don't bother
-isReadOnly :: CLabel -> Bool	-- lives in C "text space"
-isAsmTemp  :: CLabel -> Bool    -- is a local temporary for native code generation
-externallyVisibleCLabel :: CLabel -> Bool -- not C "static"
-\end{code}
-
-@needsCDecl@ is @True@ unless the thing is a deeply-@PreludeCore@-ish
-object.  {\em Also:} No need to spit out labels for things generated
-by the flattener (in @AbsCFuns@)---it is careful to ensure references
-to them are always backwards.  These are return-point and vector-table
-labels.
-
-Declarations for (non-prelude) @Id@-based things are needed because of
-mutual recursion.
-\begin{code}
-needsCDecl (IdLabel _ _)	       = True -- OLD: not (fromPreludeCore id)
-needsCDecl (CaseLabel _ _)	       = False
-
-needsCDecl (TyConLabel _ (StdUpdCode _)) = False
-needsCDecl (TyConLabel _ InfoTblVecTbl)  = False
-needsCDecl (TyConLabel _ other)          = True
-
-needsCDecl (AsmTempLabel _)            = False
-needsCDecl (RtsLabel _)                = False
-
-#ifdef DPH
-needsCDecl (ALocalLabel _ _)           = panic "needsCDecl: Shouldn't call"
-#endif {- Data Parallel Haskell -}
-
-needsCDecl other		       = True
-\end{code}
-
-Whether the labelled thing can be put in C "text space":
-\begin{code}
-isReadOnly (IdLabel _ InfoTbl)	       = True  -- info-tables: yes
-isReadOnly (IdLabel _ StaticInfoTbl)   = True  -- and so on, for other
-isReadOnly (IdLabel _ PhantomInfoTbl)  = True
-isReadOnly (IdLabel _ (VapInfoTbl _))  = True
-isReadOnly (IdLabel _ other)	       = False -- others: pessimistically, no
-
-isReadOnly (TyConLabel _ _)    = True
-isReadOnly (CaseLabel _ _)     = True
-isReadOnly (AsmTempLabel _)    = True
-isReadOnly (RtsLabel _)        = True
-
-#ifdef DPH
-isReadOnly (ALocalLabel _ _)   = panic "isReadOnly: Shouldn't call"
-#endif {- Data Parallel Haskell -}
-\end{code}
-
-Whether the label is an assembler temporary:
-\begin{code}
-isAsmTemp (AsmTempLabel _) = True
-isAsmTemp _ 	    	   = False
-\end{code}
-
-C ``static'' or not...
-\begin{code}
-externallyVisibleCLabel (TyConLabel tc _) = True
-externallyVisibleCLabel (CaseLabel _ _)	  = False
-externallyVisibleCLabel (AsmTempLabel _)  = False
-externallyVisibleCLabel (RtsLabel _)	  = True
-
-#ifndef DPH
-
-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
-  | isClassOpId id	  = True
-  | 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)
-#else
--- DPH pays a big price for exported identifiers. For example with
--- a statically allocated closure, if it is local to a file it will
--- only take up 1 word of storage; exported closures have to go
--- in a data section of their own, which gets padded out to a plane size---
--- on the DAP510 this is 32 words, DAP610 128 words, DAP710 512 words :-(
--- NOTE:16/07/93 Used isInvented (these worker things are globally visible).
--- Local labels (i.e ones within a code block) are not visible outside
--- a file.
-
-externallyVisibleCLabel (IdLabel (CLabelId id) _) = isInventedTopLevId id || isExported id
-externallyVisibleCLabel (ALocalLabel _ _)	  = False
-#endif {- Data Parallel Haskell -}
-\end{code}
-
-@isLocalLabel@ determines if a label is local to a block---a different
-machine code jump is generated.
-
-Note(hack after 0.16): Blocks with direct entry points can appear
-		       within blocks labelled with a direct entry
-		       point --- something todo with let-no-escape.
-		       Fast entry blocks arent nestable, however we
-		       special case fall through.
-\begin{code}
-#ifdef DPH
-isLocalLabel::CLabel -> Bool
-isLocalLabel (ALocalLabel _ _) = True
-isLocalLabel _		       = False
-
-isNestableBlockLabel (ALocalLabel _ _)          = True
-isNestableBlockLabel (IdLabel _ EntryStd)       = True
-isNestableBlockLabel (IdLabel _ ConEntry)       = True
-isNestableBlockLabel (IdLabel _ StaticConEntry) = True
-isNestableBlockLabel _                          = False
-
-isSlowFastLabelPair :: CLabel -> CLabel -> Bool
-isSlowFastLabelPair (IdLabel clid EntryStd) (IdLabel clid' (EntryFast _)) = clid == clid'
-isSlowFastLabelPair _                       _			          = False
-#endif {- Data Parallel Haskell -}
-\end{code}
-
-We need to determine if a label represents a code entity, an ordinary 
-data entity, or a special global data entity (placed at an absolute
-address by the runtime system that ensures fast loading of variable
-contents---global ``registers'' such as SuA are placed here as well)
-(different instructions are used in the DAP machine code). 
-\begin{code}
-#ifdef DPH
-isGlobalDataLabel _ = False
-
-isDataLabel :: CLabel -> Bool
-isDataLabel (IdLabel _ Closure) = True
-isDataLabel _			= False
-
-isVectorTableLabel :: CLabel -> Bool
-isVectorTableLabel (VecTblCLabel _)   = True
-isVectorTableLabel _                  = False
-#endif {- Data Parallel Haskell -}
-\end{code}
-
-Sort of like the needsCDecl, we need to stop the assembler from complaining
-about various data sections :-)
-\begin{code}
-#ifdef DPH
-needsApalDecl :: CLabel -> Bool
-needsApalDecl (IdLabel (CLabelId id) Closure)  = not (isLocallyDefined id)
-needsApalDecl _		                       = False
-#endif {- Data Parallel Haskell -}
-\end{code}
-
-These GRAN functions are needed for spitting out GRAN_FETCH() at the
-right places. It is used to detect when the abstractC statement of an
-CCodeBlock actually contains the code for a slow entry point.  -- HWL
-
-\begin{code}
-#ifdef GRAN
-
-isSlowEntryCCodeBlock :: CLabel -> Bool
-isSlowEntryCCodeBlock _ = False
--- Worth keeping?  ToDo (WDP)
-
-#endif {-GRAN-}
-\end{code}
-
-We need at least @Eq@ for @CLabels@, because we want to avoid
-duplicate declarations in generating C (see @labelSeenTE@ in
-@PprAbsC@).
-
-\begin{code}
-pprCLabel :: PprStyle -> CLabel -> Unpretty
-
-pprCLabel (PprForAsm _ _ fmtAsmLbl) (AsmTempLabel u) 
-  = uppStr (fmtAsmLbl (_UNPK_ (showUnique u)))
-
-pprCLabel (PprForAsm sw_chker prepend_cSEP _) lbl
-  = if prepend_cSEP
-    then uppBeside pp_cSEP prLbl
-    else prLbl
-  where
-    prLbl = pprCLabel (PprForC sw_chker) lbl
-
-pprCLabel sty (TyConLabel tc UnvecConUpdCode)
-  = uppBesides [uppPStr SLIT("ret"), pp_cSEP, uppStr (showTyCon sty tc), 
-               pp_cSEP, uppPStr SLIT("upd")]
-
-pprCLabel sty (TyConLabel tc (VecConUpdCode tag))
-  = uppBesides [uppPStr SLIT("ret"), pp_cSEP, uppStr (showTyCon sty tc), pp_cSEP,
-		     uppInt tag, pp_cSEP, uppPStr SLIT("upd")]
-
-pprCLabel sty (TyConLabel tc (StdUpdCode tag))
-  = case (ctrlReturnConvAlg tc) of
-        UnvectoredReturn _ -> uppPStr SLIT("IndUpdRetDir")
-    	VectoredReturn _ -> uppBeside (uppPStr SLIT("IndUpdRetV")) (uppInt (tag - fIRST_TAG))
-
-pprCLabel sty (TyConLabel tc InfoTblVecTbl)
-  = uppBesides [uppStr (showTyCon sty tc), pp_cSEP, uppPStr SLIT("itblvtbl")]
-
-pprCLabel sty (TyConLabel tc StdUpdVecTbl)
-  = uppBesides [uppPStr SLIT("vtbl"), pp_cSEP, uppStr (showTyCon sty tc), 
-    	       pp_cSEP, uppPStr SLIT("upd")]
-
-pprCLabel sty (CaseLabel u CaseReturnPt)
-  = uppBesides [uppPStr SLIT("ret"), pp_cSEP, ppr_u u]
-pprCLabel sty (CaseLabel u CaseVecTbl)	
-  = uppBesides [uppPStr SLIT("vtbl"), pp_cSEP, ppr_u u]
-pprCLabel sty (CaseLabel u (CaseAlt tag))
-  = uppBesides [uppPStr SLIT("djn"), pp_cSEP, ppr_u u, pp_cSEP, uppInt tag]
-pprCLabel sty (CaseLabel u CaseDefault)	
-  = uppBesides [uppPStr SLIT("djn"), pp_cSEP, ppr_u u]
-
-pprCLabel sty (RtsLabel RtsShouldNeverHappenCode) = uppPStr SLIT("StdErrorCode")
-
-pprCLabel sty (RtsLabel RtsBlackHoleInfoTbl) = uppPStr SLIT("BH_UPD_info")
-
-pprCLabel sty (RtsLabel (RtsSelectorInfoTbl upd_reqd offset)) 
-  = uppBesides [uppPStr SLIT("__sel_info_"), uppStr (show offset), 
-		uppStr (if upd_reqd then "upd" else "noupd"),
-		uppPStr SLIT("__")]
-
-pprCLabel sty (RtsLabel (RtsSelectorEntry upd_reqd offset)) 
-  = uppBesides [uppPStr SLIT("__sel_entry_"), uppStr (show offset), 
-		uppStr (if upd_reqd then "upd" else "noupd"),
-		uppPStr SLIT("__")]
-
-pprCLabel sty (IdLabel (CLabelId id) flavor)
-  = uppBeside (prettyToUn (ppr sty id)) (ppFlavor flavor)
-
-#ifdef DPH
-pprCLabel sty (ALocalLabel u str) = uppBeside (uppStr str) (ppr_u u)
-#endif {- Data Parallel Haskell -}
-
-ppr_u u = prettyToUn (pprUnique u)
-
-ppFlavor :: IdLabelInfo -> Unpretty
-#ifndef DPH
-ppFlavor x = uppBeside pp_cSEP
-             	      (case x of
-		       Closure	    	-> uppPStr SLIT("closure")
-		       InfoTbl	    	-> uppPStr SLIT("info")
-		       EntryStd	    	-> uppPStr SLIT("entry")
-		       EntryFast arity	-> --false:ASSERT (arity > 0)
-					   uppBeside (uppPStr SLIT("fast")) (uppInt arity)
-		       ConEntry	    	-> uppPStr SLIT("entry")
-		       StaticConEntry  	-> uppPStr SLIT("static_entry")
-		       StaticInfoTbl 	-> uppPStr SLIT("static_info")
-		       PhantomInfoTbl 	-> uppPStr SLIT("inregs_info")
-		       VapInfoTbl True  -> uppPStr SLIT("vap_info")
-		       VapInfoTbl False -> uppPStr SLIT("vap_noupd_info")
-		       VapEntry True    -> uppPStr SLIT("vap_entry")
-		       VapEntry False   -> uppPStr SLIT("vap_noupd_entry")
-		       RednCounts	-> uppPStr SLIT("ct")
-		      )
-#else
-ppFlavor x = uppStr (case x of
-		       Closure		-> "_clos"
-		       InfoTbl		-> "_info"
-		       EntryStd		-> "_entry"
-		       EntryFast arity  -> "_fast" ++ show arity
-		       ConEntry		-> "_entry"
-		       StaticConEntry  	-> "_statentr"
-		       StaticInfoTbl 	-> "_statinfo"
-		       PhantomInfoTbl 	-> "_irinfo"
-		       -- ToDo: add more
-		    )
-#endif {- Data Parallel Haskell -}
-
-\end{code}
-
-ToDo:
-use Z as escape char
-\begin{verbatim}
-_	main separator
-
-orig		becomes
-****		*******
-_		Zu
-'		Zq (etc for ops ??)
-<funny char>	Z[hex-digit][hex-digit]
-Prelude<x>	ZP<x>
-<std class>	ZC<?>
-<std tycon>	ZT<?>
-\end{verbatim}
-
-\begin{code}
-cSEP = SLIT("_")	-- official C separator
-pp_cSEP = uppChar '_'
-
-identToC    :: FAST_STRING -> Pretty
-modnameToC  :: FAST_STRING -> FAST_STRING
-stringToC   :: String -> String
-charToC, charToEasyHaskell :: Char -> String
-
--- stringToC: the hassle is what to do w/ strings like "ESC 0"...
-
-stringToC ""  = "" 
-stringToC [c] = charToC c
-stringToC (c:cs)
-    -- if we have something "octifiable" in "c", we'd better "octify"
-    -- the rest of the string, too.
-  = if (c < ' ' || c > '~')
-    then (charToC c) ++ (concat (map char_to_C cs))
-    else (charToC c) ++ (stringToC cs)
-  where
-    char_to_C c | c == '\n' = "\\n"	-- use C escapes when we can
-		| c == '\a' = "\\a"
-		| c == '\b' = "\\b"	-- ToDo: chk some of these...
-		| c == '\r' = "\\r"
-		| c == '\t' = "\\t"
-		| c == '\f' = "\\f"
-		| c == '\v' = "\\v"
-		| otherwise = '\\' : (octify (ord c))
-
--- OLD?: stringToC str = concat (map charToC str)
-
-charToC c = if (c >= ' ' && c <= '~')	-- non-portable...
-	    then case c of
-		  '\'' -> "\\'"
-		  '\\' -> "\\\\"
-		  '"'  -> "\\\""
-		  '\n' -> "\\n"
-		  '\a' -> "\\a"
-		  '\b' -> "\\b"
-		  '\r' -> "\\r"
-		  '\t' -> "\\t"
-		  '\f' -> "\\f"
-		  '\v' -> "\\v"
-		  _    -> [c]
-	    else '\\' : (octify (ord c))
-
--- really: charToSimpleHaskell
-
-charToEasyHaskell c
-  = if (c >= 'a' && c <= 'z')
-    || (c >= 'A' && c <= 'Z')
-    || (c >= '0' && c <= '9')
-    then [c]
-    else case c of
-	  _    -> '\\' : 'o' : (octify (ord c))
-
-octify :: Int -> String
-octify n
-  = if n < 8 then
-	[chr (n + ord '0')]
-    else 
-	octify (n `quot` 8) ++ [chr (n `rem` 8 + ord '0')]
-
-identToC ps
-  = let
-	str = _UNPK_ ps
-    in
-    ppBeside
-	(case str of
-	   's':'t':'d':_ -> -- avoid "stdin", "stdout", and "stderr"...
-			    ppChar 'Z'
-	   _	         -> ppNil)
-
-	(if (all isAlphanum str) -- we gamble that this test will succeed...
-	 then ppPStr ps
-	 else ppIntersperse ppNil (map char_to_c str))
-  where
-    char_to_c 'Z'  = ppPStr SLIT("ZZ")
-    char_to_c '&'  = ppPStr SLIT("Za")
-    char_to_c '|'  = ppPStr SLIT("Zb")
-    char_to_c ':'  = ppPStr SLIT("Zc")
-    char_to_c '/'  = ppPStr SLIT("Zd")
-    char_to_c '='  = ppPStr SLIT("Ze")
-    char_to_c '>'  = ppPStr SLIT("Zg")
-    char_to_c '#'  = ppPStr SLIT("Zh")
-    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("Zp")
-    char_to_c '\'' = ppPStr SLIT("Zq")
-    char_to_c '*'  = ppPStr SLIT("Zt")
-    char_to_c '_'  = ppPStr SLIT("Zu")
-
-    char_to_c c    = if isAlphanum c
-		     then ppChar c
-		     else ppBeside (ppChar 'Z') (ppInt (ord c))
-\end{code}
-
-For \tr{modnameToC}, we really only have to worry about \tr{'}s (quote
-chars) in the name.  Rare.
-\begin{code}
-modnameToC ps
-  = let
-	str = _UNPK_ ps
-    in
-    if not (any quote_here str) then
-	ps
-    else
-	_PK_ (concat (map char_to_c str))
-  where
-    quote_here '\'' = True
-    quote_here _    = False
-
-    char_to_c c
-      = if isAlphanum c then [c] else 'Z' : (show (ord c))
-\end{code}
diff --git a/ghc/compiler/basicTypes/Id.hi b/ghc/compiler/basicTypes/Id.hi
deleted file mode 100644
index 773598caf8..0000000000
--- a/ghc/compiler/basicTypes/Id.hi
+++ /dev/null
@@ -1,153 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface Id where
-import Bag(Bag)
-import BasicLit(BasicLit)
-import BinderInfo(BinderInfo)
-import CharSeq(CSeq)
-import Class(Class, ClassOp)
-import CmdLineOpts(GlobalSwitch)
-import CoreSyn(CoreAtom, CoreExpr)
-import IdInfo(ArgUsageInfo, ArityInfo, DemandInfo, FBTypeInfo, IdInfo, SpecEnv, SpecInfo, StrictnessInfo, UpdateInfo, nullSpecEnv)
-import Inst(Inst, InstOrigin, OverloadedLit)
-import InstEnv(InstTemplate)
-import MagicUFs(MagicUnfoldingFun)
-import Maybes(Labda)
-import Name(Name)
-import NameTypes(FullName, ShortName)
-import Outputable(NamedThing, Outputable)
-import PreludePS(_PackedString)
-import Pretty(Delay, PprStyle, Pretty(..), PrettyRep)
-import PrimKind(PrimKind)
-import SimplEnv(FormSummary, UnfoldingDetails, UnfoldingGuidance)
-import SrcLoc(SrcLoc)
-import Subst(Subst)
-import TyCon(Arity(..), TyCon)
-import TyVar(TyVar, TyVarTemplate)
-import TyVarEnv(TypeEnv(..))
-import UniType(TauType(..), ThetaType(..), UniType)
-import UniqFM(UniqFM)
-import Unique(Unique, UniqueSupply)
-data Bag a 
-data Class 
-data ClassOp 
-type ConTag = Int
-type DataCon = Id
-type DictFun = Id
-type DictVar = Id
-data GlobalSwitch 
-data IdInfo 
-data SpecEnv 
-data SpecInfo 
-data Inst 
-data InstTemplate 
-data Labda a 
-data Name 
-data FullName 
-data Id 
-data IdDetails 
-data PprStyle 
-type Pretty = Int -> Bool -> PrettyRep
-data PrettyRep 
-data PrimKind 
-data UnfoldingDetails 
-data SrcLoc 
-data Subst 
-type Arity = Int
-data TyCon 
-data TyVar 
-data TyVarTemplate 
-type TypeEnv = UniqFM UniType
-type TauType = UniType
-type ThetaType = [(Class, UniType)]
-data UniType 
-data UniqFM a 
-data Unique 
-data UniqueSupply 
-addIdArgUsageInfo :: Id -> ArgUsageInfo -> Id
-addIdArity :: Id -> Int -> Id
-addIdDemandInfo :: Id -> DemandInfo -> Id
-addIdFBTypeInfo :: Id -> FBTypeInfo -> Id
-addIdSpecialisation :: Id -> SpecEnv -> Id
-addIdStrictness :: Id -> StrictnessInfo -> Id
-addIdUnfolding :: Id -> UnfoldingDetails -> Id
-addIdUpdateInfo :: Id -> UpdateInfo -> Id
-applySubstToId :: Subst -> Id -> (Subst, Id)
-applyTypeEnvToId :: UniqFM UniType -> Id -> Id
-cmpId :: Id -> Id -> Int#
-cmpId_withSpecDataCon :: Id -> Id -> Int#
-eqId :: Id -> Id -> Bool
-externallyVisibleId :: Id -> Bool
-fIRST_TAG :: Int
-getDataConArity :: Id -> Int
-getDataConSig :: Id -> ([TyVarTemplate], [(Class, UniType)], [UniType], TyCon)
-getDataConTag :: Id -> Int
-getDataConTyCon :: Id -> TyCon
-getIdArgUsageInfo :: Id -> ArgUsageInfo
-getIdArity :: Id -> ArityInfo
-getIdDemandInfo :: Id -> DemandInfo
-getIdFBTypeInfo :: Id -> FBTypeInfo
-getIdInfo :: Id -> IdInfo
-getIdKind :: Id -> PrimKind
-getIdSpecialisation :: Id -> SpecEnv
-getIdStrictness :: Id -> StrictnessInfo
-getIdUnfolding :: Id -> UnfoldingDetails
-getIdUniType :: Id -> UniType
-getIdUpdateInfo :: Id -> UpdateInfo
-getInstIdModule :: Id -> _PackedString
-getInstNamePieces :: Bool -> Inst -> [_PackedString]
-getInstantiatedDataConSig :: Id -> [UniType] -> ([UniType], [UniType], UniType)
-getMentionedTyConsAndClassesFromId :: Id -> (Bag TyCon, Bag Class)
-idWantsToBeINLINEd :: Id -> Bool
-isBottomingId :: Id -> Bool
-isClassOpId :: Id -> Bool
-isConstMethodId_maybe :: Id -> Labda (Class, UniType, ClassOp)
-isDataCon :: Id -> Bool
-isDefaultMethodId_maybe :: Id -> Labda (Class, ClassOp, Bool)
-isDictFunId :: Id -> Bool
-isImportedId :: Id -> Bool
-isInstId_maybe :: Id -> Labda Inst
-isNullaryDataCon :: Id -> Bool
-isSpecId_maybe :: Id -> Labda (Id, [Labda UniType])
-isSpecPragmaId_maybe :: Id -> Labda (Labda SpecInfo)
-isSuperDictSelId_maybe :: Id -> Labda (Class, Class)
-isSysLocalId :: Id -> Bool
-isTopLevId :: Id -> Bool
-isTupleCon :: Id -> Bool
-isWorkerId :: Id -> Bool
-isWrapperId :: Id -> Bool
-localiseId :: Id -> Id
-mkClassOpId :: Unique -> Class -> ClassOp -> UniType -> IdInfo -> Id
-mkConstMethodId :: Unique -> Class -> ClassOp -> UniType -> UniType -> Bool -> _PackedString -> IdInfo -> Id
-mkDataCon :: Unique -> FullName -> [TyVarTemplate] -> [(Class, UniType)] -> [UniType] -> TyCon -> SpecEnv -> Id
-mkDefaultMethodId :: Unique -> Class -> ClassOp -> Bool -> UniType -> IdInfo -> Id
-mkDictFunId :: Unique -> Class -> UniType -> UniType -> Bool -> _PackedString -> IdInfo -> Id
-mkId :: Name -> UniType -> IdInfo -> Id
-mkIdWithNewUniq :: Id -> Unique -> Id
-mkImported :: Unique -> FullName -> UniType -> IdInfo -> Id
-mkInstId :: Inst -> Id
-mkPreludeId :: Unique -> FullName -> UniType -> IdInfo -> Id
-mkSameSpecCon :: [Labda UniType] -> Id -> Id
-mkSpecId :: Unique -> Id -> [Labda UniType] -> UniType -> IdInfo -> Id
-mkSpecPragmaId :: _PackedString -> Unique -> UniType -> Labda SpecInfo -> SrcLoc -> Id
-mkSuperDictSelId :: Unique -> Class -> Class -> UniType -> IdInfo -> Id
-mkSysLocal :: _PackedString -> Unique -> UniType -> SrcLoc -> Id
-mkTemplateLocals :: [UniType] -> [Id]
-mkTupleCon :: Int -> Id
-mkUserLocal :: _PackedString -> Unique -> UniType -> SrcLoc -> Id
-mkWorkerId :: Unique -> Id -> UniType -> IdInfo -> Id
-myWrapperMaybe :: Id -> Labda Id
-nullSpecEnv :: SpecEnv
-pprIdInUnfolding :: UniqFM Id -> Id -> Int -> Bool -> PrettyRep
-replaceIdInfo :: Id -> IdInfo -> Id
-selectIdInfoForSpecId :: Id -> IdInfo
-showId :: PprStyle -> Id -> [Char]
-toplevelishId :: Id -> Bool
-unfoldingUnfriendlyId :: Id -> Bool
-unlocaliseId :: _PackedString -> Id -> Labda Id
-updateIdType :: Id -> UniType -> Id
-whatsMentionedInId :: UniqFM Id -> Id -> (Bag Id, Bag TyCon, Bag Class)
-instance Eq Id
-instance Ord Id
-instance NamedThing Id
-instance Outputable Id
-
diff --git a/ghc/compiler/basicTypes/Id.lhs b/ghc/compiler/basicTypes/Id.lhs
index 971855ff2d..ff7deabd8c 100644
--- a/ghc/compiler/basicTypes/Id.lhs
+++ b/ghc/compiler/basicTypes/Id.lhs
@@ -1,14 +1,14 @@
 %
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
 %
 \section[Id]{@Ids@: Value and constructor identifiers}
 
 \begin{code}
 #include "HsVersions.h"
 
-module Id (
-	Id, -- abstract
-	IdInfo,	-- re-exporting
+module Id {- (
+	GenId, Id(..),		-- Abstract
+	StrictnessMark(..),	-- An enumaration
 	ConTag(..), DictVar(..), DictFun(..), DataCon(..),
 
 	-- CONSTRUCTION
@@ -20,44 +20,36 @@ module Id (
 	mkImported, mkPreludeId,
 	mkDataCon, mkTupleCon,
 	mkIdWithNewUniq,
-	mkClassOpId, mkSuperDictSelId, mkDefaultMethodId,
-	mkConstMethodId, mkInstId,
-#ifdef DPH
-	mkProcessorCon,
-	mkPodId,
-#endif {- Data Parallel Haskell -}
+	mkMethodSelId, mkSuperDictSelId, mkDefaultMethodId,
+	mkConstMethodId, getConstMethodId,
 
 	updateIdType,
-	mkId, mkDictFunId,
+	mkId, mkDictFunId, mkInstId,
 	mkWorkerId,
 	localiseId,
 
 	-- DESTRUCTION
-	getIdUniType,
-	getInstNamePieces, getIdInfo, replaceIdInfo,
-	getIdKind, getInstIdModule,
+	idType,
+	getIdInfo, replaceIdInfo,
+	getPragmaInfo,
+	getIdPrimRep, getInstIdModule,
 	getMentionedTyConsAndClassesFromId,
 	getDataConTag,
 	getDataConSig, getInstantiatedDataConSig,
-	getDataConTyCon, -- UNUSED: getDataConFamily,
-#ifdef USE_SEMANTIQUE_STRANAL
-	getDataConDeps,
-#endif
+
+	getDataConTyCon,
 
 	-- PREDICATES
-	isDataCon, isTupleCon, isNullaryDataCon,
+	isDataCon, isTupleCon,
 	isSpecId_maybe, isSpecPragmaId_maybe,
 	toplevelishId, externallyVisibleId,
 	isTopLevId, isWorkerId, isWrapperId,
 	isImportedId, isSysLocalId,
 	isBottomingId,
-	isClassOpId, isDefaultMethodId_maybe, isSuperDictSelId_maybe,
-	isDictFunId, isInstId_maybe, isConstMethodId_maybe, 
-#ifdef DPH
-	isInventedTopLevId,
-	isProcessorCon,
-#endif {- Data Parallel Haskell -}
-	eqId, cmpId,
+	isMethodSelId, isDefaultMethodId_maybe, isSuperDictSelId_maybe,
+	isDictFunId,
+--???	isInstId_maybe,
+	isConstMethodId_maybe,
 	cmpId_withSpecDataCon,
 	myWrapperMaybe,
 	whatsMentionedInId,
@@ -74,7 +66,7 @@ module Id (
 	getIdDemandInfo, addIdDemandInfo,
 	getIdSpecialisation, addIdSpecialisation,
 	getIdStrictness, addIdStrictness,
-	getIdUnfolding, addIdUnfolding, -- UNUSED? clearIdUnfolding,
+	getIdUnfolding, addIdUnfolding,
 	getIdUpdateInfo, addIdUpdateInfo,
 	getIdArgUsageInfo, addIdArgUsageInfo,
 	getIdFBTypeInfo, addIdFBTypeInfo,
@@ -86,78 +78,70 @@ module Id (
 	showId,
 	pprIdInUnfolding,
 
-	-- and to make the interface self-sufficient...
-	Class, ClassOp, GlobalSwitch, Inst, Maybe, Name,
-	FullName, PprStyle, PrettyRep,
-	PrimKind, SrcLoc, Pretty(..), Subst, UnfoldingDetails,
-	TyCon, TyVar, TyVarTemplate, TauType(..), UniType, Unique,
-	UniqueSupply, Arity(..), ThetaType(..),
-	TypeEnv(..), UniqFM, InstTemplate, Bag,
-	SpecEnv, nullSpecEnv, SpecInfo,
-
-	-- and to make sure pragmas work...
-	IdDetails  -- from this module, abstract
-	IF_ATTACK_PRAGMAS(COMMA getMentionedTyConsAndClassesFromUniType)
-	IF_ATTACK_PRAGMAS(COMMA bottomIsGuaranteed)
-	IF_ATTACK_PRAGMAS(COMMA getInfo_UF)
-
-#ifndef __GLASGOW_HASKELL__
-	, TAG_
-#endif
-    ) where
+	-- "Environments" keyed off of Ids, and sets of Ids
+	IdEnv(..),
+	lookupIdEnv, lookupNoFailIdEnv, nullIdEnv, unitIdEnv, mkIdEnv,
+	growIdEnv, growIdEnvList, isNullIdEnv, addOneToIdEnv,
+	delOneFromIdEnv, delManyFromIdEnv, modifyIdEnv, combineIdEnvs,
+	rngIdEnv, mapIdEnv,
 
-IMPORT_Trace		-- ToDo: rm (debugging only)
+	-- and to make the interface self-sufficient...
+	GenIdSet(..), IdSet(..)
+    )-} where
 
-import AbsPrel		( PrimOp, PrimKind, mkFunTy, nilDataCon, pRELUDE_BUILTIN
-			  IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
-			  IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
-#ifdef DPH
-			  , mkPodNTy, mkPodizedPodNTy
-#endif {- Data Parallel Haskell -}
-			)
+import Ubiq
+import IdLoop   -- for paranoia checking
+import TyLoop   -- for paranoia checking
+import NameLoop -- for paranoia checking
 
-import AbsUniType
 import Bag
-import CLabelInfo	( identToC, cSEP )
-import CmdLineOpts	( GlobalSwitch(..) )
-import IdEnv		-- ( nullIdEnv, IdEnv )
-import IdInfo		-- piles of it
-import Inst		-- lots of things
-import Maybes		( maybeToBool, Maybe(..) )
+import Class		( getClassOpString, Class(..), GenClass, ClassOp(..), GenClassOp )
+import IdInfo
+import Maybes		( maybeToBool )
+import NameTypes	( mkShortName, fromPrelude, FullName, ShortName )
 import Name		( Name(..) )
-import NameTypes
-import Outputable
-import Pretty		-- for pretty-printing
-import SrcLoc
-import Subst		( applySubstToTy )       -- PRETTY GRIMY TO LOOK IN HERE
-import PlainCore
-import PrelFuns		( pcGenerateTupleSpecs ) -- PRETTY GRIMY TO LOOK IN HERE
+import Outputable	( isAvarop, isAconop, getLocalName,
+			  isExported, ExportFlag(..) )
+import PragmaInfo	( PragmaInfo(..) )
+import PrelMods		( pRELUDE_BUILTIN )
+import PprType		( GenType, GenTyVar,
+			  getTypeString, typeMaybeString, specMaybeTysSuffix )
+import PprStyle
+import Pretty
+import SrcLoc		( mkBuiltinSrcLoc )
+import TyCon		( TyCon, mkTupleTyCon, getTyConDataCons )
+import Type		( mkSigmaTy, mkTyVarTy, mkFunTys, mkDictTy,
+			  applyTyCon, isPrimType, instantiateTy, 
+			  GenType, ThetaType(..), TauType(..), Type(..) )
+import TyVar		( GenTyVar, alphaTyVars )
 import UniqFM
-import UniqSet
-import Unique
-import Util
-#ifdef DPH
-IMPORT_Trace
-import PodizeCore	( podizeTemplateExpr )
-import PodInfoTree	( infoTypeNumToMask )
-#endif {- Data Parallel Haskell -}
+import UniqSet		( UniqSet(..) )
+import Unique		( Unique, mkTupleDataConUnique, pprUnique, showUnique )
+import Util		( mapAccumL, nOfThem, panic, pprPanic, assertPanic )
 \end{code}
 
 Here are the @Id@ and @IdDetails@ datatypes; also see the notes that
 follow.
 
 Every @Id@ has a @Unique@, to uniquify it and for fast comparison, a
-@UniType@, and an @IdInfo@ (non-essential info about it, e.g.,
+@Type@, and an @IdInfo@ (non-essential info about it, e.g.,
 strictness).  The essential info about different kinds of @Ids@ is
 in its @IdDetails@.
 
 ToDo: possibly cache other stuff in the single-constructor @Id@ type.
 
 \begin{code}
-data Id = Id	Unique		-- key for fast comparison
-		UniType		-- Id's type; used all the time;
-		IdInfo		-- non-essential info about this Id;
-		IdDetails	-- stuff about individual kinds of Ids.
+data GenId ty = Id
+	Unique		-- Key for fast comparison
+	ty		-- Id's type; used all the time;
+	IdDetails	-- Stuff about individual kinds of Ids.
+	PragmaInfo	-- Properties of this Id requested by programmer
+			-- eg specialise-me, inline-me
+	IdInfo		-- Properties of this Id deduced by compiler
+				   
+type Id = GenId Type
+
+data StrictnessMark = MarkedStrict | NotMarkedStrict
 
 data IdDetails
 
@@ -170,8 +154,8 @@ data IdDetails
 		Bool		-- as for LocalId
 
   | SpecPragmaId ShortName	-- introduced by the compiler
-		(Maybe SpecInfo)-- for explicit specid in pragma 
-		Bool		-- as for LocalId
+		 (Maybe Id)	-- for explicit specid in pragma
+		 Bool		-- as for LocalId
 
   ---------------- Global values
 
@@ -189,47 +173,81 @@ data IdDetails
 
   | DataConId	FullName
 		ConTag
-		-- cached pieces of the type:
-		[TyVarTemplate] [(Class,UniType)] [UniType] TyCon
-		-- the type is:
-		-- forall tyvars . theta_ty =>
-		--    unitype_1 -> ... -> unitype_n -> tycon tyvars
-		--
-		-- "type ThetaType  = [(Class, UniType)]"
+		[StrictnessMark] -- Strict args; length = arity
 
-		-- The [TyVarTemplate] is in the same order as the args of the
-		-- TyCon for the constructor
+		[TyVar] [(Class,Type)] [Type] TyCon
+				-- the type is:
+				-- forall tyvars . theta_ty =>
+				--    unitype_1 -> ... -> unitype_n -> tycon tyvars
 
   | TupleConId	Int		-- Its arity
 
-#ifdef DPH
-  | ProcessorCon Int		-- Its arity
-#endif {- Data Parallel Haskell -}
-
   ---------------- Things to do with overloading
 
   | SuperDictSelId		-- Selector for superclass dictionary
 		Class		-- The class (input dict)
 		Class		-- The superclass (result dict)
 
-  | ClassOpId	Class		-- An overloaded class operation, with
+  | MethodSelId	Class		-- An overloaded class operation, with
 				-- a fully polymorphic type.  Its code
 				-- just selects a method from the
 				-- dictionary.  The class.
 		ClassOp		-- The operation
 
-	-- NB: The IdInfo for a ClassOpId has all the info about its
+	-- NB: The IdInfo for a MethodSelId has all the info about its
 	-- related "constant method Ids", which are just
 	-- specialisations of this general one.
 
   | DefaultMethodId		-- Default method for a particular class op
-		Class		-- same class, <blah-blah> info as ClassOpId
+		Class		-- same class, <blah-blah> info as MethodSelId
 		ClassOp		-- (surprise, surprise)
 		Bool		-- True <=> I *know* this default method Id
 				-- is a generated one that just says
 				-- `error "No default method for <op>"'.
+
+				-- see below
+  | DictFunId	Class		-- A DictFun is uniquely identified
+		Type		-- by its class and type; this type has free type vars,
+				-- whose identity is irrelevant.  Eg Class = Eq
+				--				     Type  = Tree a
+				-- The "a" is irrelevant.  As it is too painful to
+				-- actually do comparisons that way, we kindly supply
+				-- a Unique for that purpose.
+		Bool		-- True <=> from an instance decl in this mod
+		FAST_STRING	-- module where instance came from
+
+				-- see below
+  | ConstMethodId		-- A method which depends only on the type of the
+				-- instance, and not on any further dictionaries etc.
+		Class		-- Uniquely identified by:
+		Type		-- (class, type, classop) triple
+		ClassOp
+		Bool		-- True <=> from an instance decl in this mod
+		FAST_STRING	-- module where instance came from
+
+  | InstId	ShortName	-- An instance of a dictionary, class operation,
+				-- or overloaded value
+
+  | SpecId			-- A specialisation of another Id
+		Id		-- Id of which this is a specialisation
+		[Maybe Type]	-- Types at which it is specialised;
+				-- A "Nothing" says this type ain't relevant.
+		Bool		-- True <=> no free type vars; it's not enough
+				-- to know about the unspec version, because
+				-- we may specialise to a type w/ free tyvars
+				-- (i.e., in one of the "Maybe Type" dudes).
+
+  | WorkerId			-- A "worker" for some other Id
+		Id		-- Id for which this is a worker
+
+
+type ConTag	= Int
+type DictVar	= Id
+type DictFun	= Id
+type DataCon	= Id
 \end{code}
 
+
 DictFunIds are generated from instance decls.
 \begin{verbatim}
 	class Foo a where
@@ -251,21 +269,10 @@ automatically generated specialisations of the instance decl:
 \end{verbatim}
 generates
 \begin{verbatim}
-	dfun.Foo.[Int] = ...	
+	dfun.Foo.[Int] = ...
 \end{verbatim}
 The type variables in the name are irrelevant; we print them as stars.
 
-\begin{code}
-  | DictFunId	Class		-- A DictFun is uniquely identified
-		UniType		-- by its class and type; this type has free type vars,
-				-- whose identity is irrelevant.  Eg Class = Eq
-				--				     Type  = Tree a
-				-- The "a" is irrelevant.  As it is too painful to
-				-- actually do comparisons that way, we kindly supply
-				-- a Unique for that purpose.
-		Bool		-- True <=> from an instance decl in this mod
-		FAST_STRING	-- module where instance came from
-\end{code}
 
 Constant method ids are generated from instance decls where
 there is no context; that is, no dictionaries are needed to
@@ -293,48 +300,12 @@ We get the constant method
 So a constant method is identified by a class/op/type triple.
 The type variables in the type are irrelevant.
 
-\begin{code}
-  | ConstMethodId		-- A method which depends only on the type of the
-				-- instance, and not on any further dictionaries etc.
-		Class		-- Uniquely identified by:
-		UniType		-- (class, type, classop) triple
-		ClassOp
-		Bool		-- True <=> from an instance decl in this mod
-		FAST_STRING	-- module where instance came from
-
-  | InstId	Inst		-- An instance of a dictionary, class operation,
-				-- or overloaded value
-
-  | SpecId			-- A specialisation of another Id
-		Id		-- Id of which this is a specialisation
-		[Maybe UniType]	-- Types at which it is specialised;
-				-- A "Nothing" says this type ain't relevant.
-		Bool		-- True <=> no free type vars; it's not enough
-				-- to know about the unspec version, because
-				-- we may specialise to a type w/ free tyvars
-				-- (i.e., in one of the "Maybe UniType" dudes).
-
-  | WorkerId			-- A "worker" for some other Id
-		Id		-- Id for which this is a worker
-
-#ifdef DPH
-  | PodId	Int		-- The dimension of the PODs context
-		Int		-- Which specialisation of InfoType is
-				-- bind. ToDo(hilly): Int is a little messy
-				-- and has a restricted range---change.
-		Id		-- One of the aboves Ids.
-#endif {- Data Parallel Haskell -}
-
-type ConTag	= Int
-type DictVar	= Id
-type DictFun	= Id
-type DataCon	= Id
-\end{code}
 
 For Ids whose names must be known/deducible in other modules, we have
 to conjure up their worker's names (and their worker's worker's
 names... etc) in a known systematic way.
 
+
 %************************************************************************
 %*									*
 \subsection[Id-documentation]{Documentation}
@@ -344,7 +315,7 @@ names... etc) in a known systematic way.
 [A BIT DATED [WDP]]
 
 The @Id@ datatype describes {\em values}.  The basic things we want to
-know: (1)~a value's {\em type} (@getIdUniType@ is a very common
+know: (1)~a value's {\em type} (@idType@ is a very common
 operation in the compiler); and (2)~what ``flavour'' of value it might
 be---for example, it can be terribly useful to know that a value is a
 class method.
@@ -353,7 +324,7 @@ class method.
 %----------------------------------------------------------------------
 \item[@DataConId@:] For the data constructors declared by a @data@
 declaration.  Their type is kept in {\em two} forms---as a regular
-@UniType@ (in the usual place), and also in its constituent pieces (in
+@Type@ (in the usual place), and also in its constituent pieces (in
 the ``details''). We are frequently interested in those pieces.
 
 %----------------------------------------------------------------------
@@ -387,7 +358,7 @@ what arities].	If the @Uniques@ on the @TopLevIds@ can {\em change}
 between (1) and (2), you're sunk!
 
 %----------------------------------------------------------------------
-\item[@ClassOpId@:] A selector from a dictionary; it may select either
+\item[@MethodSelId@:] A selector from a dictionary; it may select either
 a method or a dictionary for one of the class's superclasses.
 
 %----------------------------------------------------------------------
@@ -437,7 +408,7 @@ Further remarks:
 \item
 
 @DataCons@ @TupleCons@, @Importeds@, @TopLevIds@, @SuperDictSelIds@,
-@ClassOpIds@, @DictFunIds@, and @DefaultMethodIds@ have the following
+@MethodSelIds@, @DictFunIds@, and @DefaultMethodIds@ have the following
 properties:
 \begin{itemize}
 \item
@@ -452,7 +423,6 @@ Note that @InstIds@, @Locals@ and @SysLocals@ {\em may} have the above
 properties, but they may not.
 \end{enumerate}
 
-
 %************************************************************************
 %*									*
 \subsection[Id-general-funs]{General @Id@-related functions}
@@ -460,44 +430,35 @@ properties, but they may not.
 %************************************************************************
 
 \begin{code}
-isDataCon (Id _ _ _ (DataConId _ _ _ _ _ _)) = True
-isDataCon (Id _ _ _ (TupleConId _))	     = True
-isDataCon (Id _ _ _ (SpecId unspec _ _))     = isDataCon unspec
-#ifdef DPH
-isDataCon (ProcessorCon _ _)	      = True
-isDataCon (PodId _ _ id )	      = isDataCon id
-#endif {- Data Parallel Haskell -}
-isDataCon other			      = False
-
-isTupleCon (Id _ _ _ (TupleConId _))	    = True
-isTupleCon (Id _ _ _ (SpecId unspec _ _))   = isTupleCon unspec
-#ifdef DPH
-isTupleCon (PodId _ _ id)	= isTupleCon id
-#endif {- Data Parallel Haskell -}
-isTupleCon other		= False
-
-isNullaryDataCon data_con
-  =  isDataCon data_con
-  && (case arityMaybe (getIdArity data_con) of
-	Just a -> a == 0
-	_      -> panic "isNullaryDataCon")
-
-isSpecId_maybe (Id _ _ _ (SpecId unspec ty_maybes _))
+unsafeGenId2Id :: GenId ty -> Id
+unsafeGenId2Id (Id u ty d p i) = Id u (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
+
+
+isTupleCon id = is_tuple (unsafeGenId2Id id)
+ where
+  is_tuple (Id _ _ (TupleConId _) _ _)		 = True
+  is_tuple (Id _ _ (SpecId unspec _ _) _ _)	 = is_tuple unspec
+  is_tuple other				 = False
+
+{-LATER:
+isSpecId_maybe (Id _ _ (SpecId unspec ty_maybes _) _ _)
   = ASSERT(not (maybeToBool (isSpecId_maybe unspec)))
     Just (unspec, ty_maybes)
 isSpecId_maybe other_id
   = Nothing
 
-isSpecPragmaId_maybe (Id _ _ _ (SpecPragmaId _ specinfo _))
-  = Just specinfo
+isSpecPragmaId_maybe (Id _ _ (SpecPragmaId _ specid _) _ _)
+  = Just specid
 isSpecPragmaId_maybe other_id
   = Nothing
-
-#ifdef DPH
-isProcessorCon (ProcessorCon _ _) = True
-isProcessorCon (PodId _ _ id)	  = isProcessorCon id
-isProcessorCon other		  = False
-#endif {- Data Parallel Haskell -}
+-}
 \end{code}
 
 @toplevelishId@ tells whether an @Id@ {\em may} be defined in a
@@ -510,154 +471,106 @@ about something if it returns @True@!
 toplevelishId	    :: Id -> Bool
 idHasNoFreeTyVars   :: Id -> Bool
 
-toplevelishId (Id _ _ _ details)
+toplevelishId (Id _ _ details _ _)
   = chk details
   where
-    chk (DataConId _ _ _ _ _ _) = True
-    chk (TupleConId _)	    	= True
-    chk (ImportedId _)	    	= True
-    chk (PreludeId  _)	    	= True
-    chk (TopLevId   _)	    	= True	-- NB: see notes
-    chk (SuperDictSelId _ _)	= True
-    chk (ClassOpId _ _)		= True
-    chk (DefaultMethodId _ _ _) = True
-    chk (DictFunId     _ _ _ _)	= True
+    chk (DataConId _ _ _ _ _ _ _) = True
+    chk (TupleConId _)	    	  = True
+    chk (ImportedId _)	    	  = True
+    chk (PreludeId  _)	    	  = True
+    chk (TopLevId   _)	    	  = True	-- NB: see notes
+    chk (SuperDictSelId _ _)	  = True
+    chk (MethodSelId _ _)		  = True
+    chk (DefaultMethodId _ _ _)   = True
+    chk (DictFunId     _ _ _ _)	  = True
     chk (ConstMethodId _ _ _ _ _) = True
-    chk (SpecId unspec _ _)	= toplevelishId unspec
+    chk (SpecId unspec _ _)	  = toplevelishId unspec
 				  -- depends what the unspecialised thing is
-    chk (WorkerId unwrkr)	= toplevelishId unwrkr
-    chk (InstId _)		= False	-- these are local
-    chk (LocalId      _ _)	= False
-    chk (SysLocalId   _ _)	= False
-    chk (SpecPragmaId _ _ _)	= False
-#ifdef DPH
-    chk (ProcessorCon _ _)	= True
-    chk (PodId _ _ id)		= toplevelishId id
-#endif {- Data Parallel Haskell -}
-
-idHasNoFreeTyVars (Id _ _ info details)
+    chk (WorkerId unwrkr)	  = toplevelishId unwrkr
+    chk (InstId _)		  = False	-- these are local
+    chk (LocalId      _ _)	  = False
+    chk (SysLocalId   _ _)	  = False
+    chk (SpecPragmaId _ _ _)	  = False
+
+idHasNoFreeTyVars (Id _ _ details _ info)
   = chk details
   where
-    chk (DataConId _ _ _ _ _ _) = True
-    chk (TupleConId _)	    	= True
-    chk (ImportedId _)	    	= True
-    chk (PreludeId  _)	    	= True
-    chk (TopLevId   _)	    	= True
-    chk (SuperDictSelId _ _)	= True
-    chk (ClassOpId _ _)		= True
-    chk (DefaultMethodId _ _ _) = True
-    chk (DictFunId     _ _ _ _)	= True
+    chk (DataConId _ _ _ _ _ _ _) = True
+    chk (TupleConId _)	    	  = True
+    chk (ImportedId _)	    	  = True
+    chk (PreludeId  _)	    	  = True
+    chk (TopLevId   _)	    	  = True
+    chk (SuperDictSelId _ _)	  = True
+    chk (MethodSelId _ _)		  = True
+    chk (DefaultMethodId _ _ _)   = True
+    chk (DictFunId     _ _ _ _)	  = True
     chk (ConstMethodId _ _ _ _ _) = True
-    chk (WorkerId unwrkr)	= idHasNoFreeTyVars unwrkr
-    chk (InstId _)		      = False	-- these are local
+    chk (WorkerId unwrkr)	  = idHasNoFreeTyVars unwrkr
+    chk (InstId _)		  = False	-- these are local
     chk (SpecId _     _   no_free_tvs) = no_free_tvs
     chk (LocalId      _   no_free_tvs) = no_free_tvs
     chk (SysLocalId   _   no_free_tvs) = no_free_tvs
     chk (SpecPragmaId _ _ no_free_tvs) = no_free_tvs
-#ifdef DPH
-    chk (ProcessorCon _ _)	= True
-    chk (PodId _ _ id)		= idHasNoFreeTyVars id
-#endif {- Data Parallel Haskell -}
 \end{code}
 
 \begin{code}
-isTopLevId (Id _ _ _ (TopLevId _)) = True
-#ifdef DPH
-isTopLevId (PodId _ _ id)	= isTopLevId id
-#endif {- Data Parallel Haskell -}
-isTopLevId other		= False
-
--- an "invented" one is a top-level Id, must be globally visible, etc.,
--- but it's slightly different in that it was "conjured up".
--- This handles workers fine, but may need refinement for other
--- conjured-up things (e.g., specializations)
--- NB: Only used in DPH now (93/08/20)
-
-#ifdef DPH
-ToDo: DPH
-isInventedTopLevId (TopLevId _ n _ _)	= isInventedFullName n
-isInventedTopLevId (SpecId _ _ _)	= True
-isInventedTopLevId (WorkerId _)		= True
-isInventedTopLevId (PodId _ _ id)	= isInventedTopLevId id
-isInventedTopLevId other		= False
-#endif {- Data Parallel Haskell -}
-
-isImportedId (Id _ _ _ (ImportedId _))   = True
-#ifdef DPH
-isImportedId (PodId _ _ id)	  = isImportedId id
-#endif {- Data Parallel Haskell -}
-isImportedId other		  = False
-
-isBottomingId (Id _ _ info _) = bottomIsGuaranteed (getInfo info)
-#ifdef DPH
-isBottomingId (PodId _ _ id)	  = isBottomingId id
-#endif {- Data Parallel Haskell -}
---isBottomingId other		  = False
-
-isSysLocalId (Id _ _ _ (SysLocalId _ _)) = True
-#ifdef DPH
-isSysLocalId (PodId _ _ id)	= isSysLocalId id
-#endif {- Data Parallel Haskell -}
-isSysLocalId other		= False
-
-isSpecPragmaId (Id _ _ _ (SpecPragmaId _ _ _)) = True
-#ifdef DPH
-isSpecPragmaId (PodId _ _ id)	= isSpecPragmaId id
-#endif {- Data Parallel Haskell -}
-isSpecPragmaId other		= False
-
-isClassOpId (Id _ _ _ (ClassOpId _ _)) = True
-isClassOpId _ = False
-
-isDefaultMethodId_maybe (Id _ _ _ (DefaultMethodId cls clsop err)) = Just (cls, clsop, err)
-#ifdef DPH
-isDefaultMethodId_maybe (PodId _ _ id)	= isDefaultMethodId_maybe id
-#endif {- Data Parallel Haskell -}
-isDefaultMethodId_maybe other		= Nothing
-
-isDictFunId (Id _ _ _ (DictFunId _ _ _ _)) = True
-#ifdef DPH
-isDictFunId (PodId _ _ id)	    	= isDictFunId id
-#endif {- Data Parallel Haskell -}
-isDictFunId other		    	= False
-
-isConstMethodId_maybe (Id _ _ _ (ConstMethodId cls ty clsop _ _)) = Just (cls, ty, clsop)
-#ifdef DPH
-isConstMethodId_maybe (PodId _ _ id)	= isConstMethodId_maybe id
-#endif {- Data Parallel Haskell -}
-isConstMethodId_maybe other		= Nothing
-
-isInstId_maybe (Id _ _ _ (InstId inst)) = Just inst
-#ifdef DPH
-isInstId_maybe (PodId _ _ id)	        = isInstId_maybe id
-#endif {- Data Parallel Haskell -}
-isInstId_maybe other_id			= Nothing
-
-isSuperDictSelId_maybe (Id _ _ _ (SuperDictSelId c sc)) = Just (c, sc)
-#ifdef DPH
-isSuperDictSelId_maybe (PodId _ _ id)	= isSuperDictSelId_maybe id
-#endif {- Data Parallel Haskell -}
-isSuperDictSelId_maybe other_id		= Nothing
-
-isWorkerId (Id _ _ _ (WorkerId _)) = True
-#ifdef DPH
-isWorkerId (PodId _ _ id)	    = isWorkerId id
-#endif {- Data Parallel Haskell -}
-isWorkerId other		    = False
+isTopLevId (Id _ _ (TopLevId _) _ _) = True
+isTopLevId other		     = False
+
+isImportedId (Id _ _ (ImportedId _) _ _) = True
+isImportedId other		  	 = False
 
+isBottomingId (Id _ _ _ _ info) = panic "isBottomingId not implemented"
+			-- LATER: bottomIsGuaranteed (getInfo info)
+
+isSysLocalId (Id _ _ (SysLocalId _ _) _ _) = True
+isSysLocalId other			   = False
+
+isSpecPragmaId (Id _ _ (SpecPragmaId _ _ _) _ _) = True
+isSpecPragmaId other			         = False
+
+isMethodSelId (Id _ _ (MethodSelId _ _) _ _) = True
+isMethodSelId _				 = False
+
+isDefaultMethodId (Id _ _ (DefaultMethodId _ _ _) _ _) = True
+isDefaultMethodId other				       = False
+
+isDefaultMethodId_maybe (Id _ _ (DefaultMethodId cls clsop err) _ _)
+  = Just (cls, clsop, err)
+isDefaultMethodId_maybe other = Nothing
+
+isDictFunId (Id _ _ (DictFunId _ _ _ _) _ _) = True
+isDictFunId other		    	     = False
+
+isConstMethodId (Id _ _ (ConstMethodId _ _ _ _ _) _ _) = True
+isConstMethodId other		    		       = False
+
+isConstMethodId_maybe (Id _ _ (ConstMethodId cls ty clsop _ _) _ _)
+  = Just (cls, ty, clsop)
+isConstMethodId_maybe other = Nothing
+
+isSuperDictSelId_maybe (Id _ _ (SuperDictSelId c sc) _ _) = Just (c, sc)
+isSuperDictSelId_maybe other_id				  = Nothing
+
+isWorkerId (Id _ _ (WorkerId _) _ _) = True
+isWorkerId other		     = False
+
+{-LATER:
 isWrapperId id = workerExists (getIdStrictness id)
+-}
 \end{code}
 
 \begin{code}
+{-LATER:
 pprIdInUnfolding :: IdSet -> Id -> Pretty
 
 pprIdInUnfolding in_scopes v
   = let
-	v_ty = getIdUniType v
+	v_ty = idType v
     in
     -- local vars first:
     if v `elementOfUniqSet` in_scopes then
-	pprUnique (getTheUnique v)
+	pprUnique (getItsUnique v)
 
     -- ubiquitous Ids with special syntax:
     else if v == nilDataCon then
@@ -668,7 +581,7 @@ pprIdInUnfolding in_scopes v
     -- ones to think about:
     else
 	let
-	    (Id _ _ _ v_details) = v
+	    (Id _ _ v_details _ _) = v
 	in
     	case v_details of
 	    -- these ones must have been exported by their original module
@@ -677,12 +590,12 @@ pprIdInUnfolding in_scopes v
 
 	    -- these ones' exportedness checked later...
 	  TopLevId  _ -> pp_full_name
-	  DataConId _ _ _ _ _ _ -> pp_full_name
+	  DataConId _ _ _ _ _ _ _ -> pp_full_name
 
 	    -- class-ish things: class already recorded as "mentioned"
 	  SuperDictSelId c sc
 	    -> ppCat [ppPStr SLIT("_SDSEL_"), pp_class c, pp_class sc]
-	  ClassOpId c o
+	  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]
@@ -731,8 +644,8 @@ pprIdInUnfolding in_scopes v
 
     pp_class :: Class -> Pretty
     pp_class_op :: ClassOp -> Pretty
-    pp_type :: UniType -> Pretty
-    pp_ty_maybe :: Maybe UniType -> 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
@@ -741,6 +654,7 @@ pprIdInUnfolding in_scopes v
 
     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
@@ -749,6 +663,7 @@ 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
@@ -756,10 +671,10 @@ whatsMentionedInId
 
 whatsMentionedInId in_scopes v
   = let
-	v_ty = getIdUniType v
+	v_ty = idType v
 
     	(tycons, clss)
-	  = getMentionedTyConsAndClassesFromUniType v_ty
+	  = getMentionedTyConsAndClassesFromType v_ty
 
 	result0 id_bag = (id_bag, tycons, clss)
 
@@ -775,7 +690,7 @@ whatsMentionedInId in_scopes v
     -- ones to think about:
     else
 	let
-	    (Id _ _ _ v_details) = v
+	    (Id _ _ v_details _ _) = v
 	in
     	case v_details of
 	  -- specialisations and workers
@@ -792,14 +707,17 @@ whatsMentionedInId in_scopes v
 	       result1 ids2 tcs2 cs2
 
 	  anything_else -> result0 (unitBag v) -- v is  added to "mentioned"
+-}
 \end{code}
 
 Tell them who my wrapper function is.
 \begin{code}
+{-LATER:
 myWrapperMaybe :: Id -> Maybe Id
 
-myWrapperMaybe (Id _ _ _ (WorkerId my_wrapper)) = Just my_wrapper
-myWrapperMaybe other_id			    	= Nothing
+myWrapperMaybe (Id _ _ (WorkerId my_wrapper) _ _) = Just my_wrapper
+myWrapperMaybe other_id			    	  = Nothing
+-}
 \end{code}
 
 \begin{code}
@@ -808,11 +726,14 @@ unfoldingUnfriendlyId	-- return True iff it is definitely a bad
 	-> Bool		-- mentions this Id.  Reason: it cannot
 			-- possibly be seen in another module.
 
+unfoldingUnfriendlyId id = panic "Id.unfoldingUnfriendlyId"
+{-LATER:
+
 unfoldingUnfriendlyId id
   | not (externallyVisibleId id) -- that settles that...
   = True
 
-unfoldingUnfriendlyId (Id _ _ _ (WorkerId wrapper))
+unfoldingUnfriendlyId (Id _ _ (WorkerId wrapper) _ _)
   = class_thing wrapper
   where
     -- "class thing": If we're going to use this worker Id in
@@ -821,12 +742,12 @@ unfoldingUnfriendlyId (Id _ _ _ (WorkerId wrapper))
     -- is not always possible: in precisely those cases where
     -- we pass tcGenPragmas a "Nothing" for its "ty_maybe".
 
-    class_thing (Id _ _ _ (SuperDictSelId _ _))    = True
-    class_thing (Id _ _ _ (ClassOpId _ _))  	   = True
-    class_thing (Id _ _ _ (DefaultMethodId _ _ _)) = True
+    class_thing (Id _ _ (SuperDictSelId _ _) _ _)    = True
+    class_thing (Id _ _ (MethodSelId _ _) _ _)  	   = True
+    class_thing (Id _ _ (DefaultMethodId _ _ _) _ _) = True
     class_thing other				   = False
 
-unfoldingUnfriendlyId (Id _ _ _ (SpecId d@(Id _ _ _ dfun@(DictFunId _ t _ _)) _ _))
+unfoldingUnfriendlyId (Id _ _ (SpecId d@(Id _ _ _ dfun@(DictFunId _ t _ _)) _ _) _ _)
     -- a SPEC of a DictFunId can end up w/ gratuitous
     -- TyVar(Templates) in the i/face; only a problem
     -- if -fshow-pragma-name-errs; but we can do without the pain.
@@ -835,7 +756,7 @@ unfoldingUnfriendlyId (Id _ _ _ (SpecId d@(Id _ _ _ dfun@(DictFunId _ t _ _)) _
     naughty_DictFunId dfun
     --)
 
-unfoldingUnfriendlyId d@(Id _ _ _ dfun@(DictFunId _ t _ _))
+unfoldingUnfriendlyId d@(Id _ _ dfun@(DictFunId _ t _ _) _ _)
   = --pprTrace "unfriendly2:" (ppCat [ppr PprDebug d, ppr PprDebug t]) (
     naughty_DictFunId dfun -- similar deal...
     --)
@@ -848,6 +769,7 @@ naughty_DictFunId :: IdDetails -> Bool
 naughty_DictFunId (DictFunId _ _ False _) = False -- came from outside; must be OK
 naughty_DictFunId (DictFunId _ ty _ _)
   = not (isGroundTy ty)
+-}
 \end{code}
 
 @externallyVisibleId@: is it true that another module might be
@@ -861,7 +783,10 @@ compiling the prelude, the compiler may not recognise that as true.
 \begin{code}
 externallyVisibleId :: Id -> Bool
 
-externallyVisibleId id@(Id _ _ _ details)
+externallyVisibleId id = panic "Id.externallyVisibleId"
+{-LATER:
+
+externallyVisibleId id@(Id _ _ details _ _)
   = if isLocallyDefined id then
 	toplevelishId id && isExported id && not (weird_datacon details)
     else
@@ -878,28 +803,32 @@ externallyVisibleId id@(Id _ _ _ details)
     -- of WeirdLocalType; but we need to know this when asked if
     -- "Mumble" is externally visible...
 
-    weird_datacon (DataConId _ _ _ _ _ tycon)
+    weird_datacon (DataConId _ _ _ _ _ _ tycon)
       = maybeToBool (maybePurelyLocalTyCon tycon)
     weird_datacon not_a_datacon_therefore_not_weird = False
 
     weird_tuplecon (TupleConId arity)
       = arity > 32 -- sigh || isBigTupleTyCon tycon -- generated *purely* for local use
     weird_tuplecon _ = False
+-}
 \end{code}
 
 \begin{code}
+{-LATER:
 idWantsToBeINLINEd :: Id -> Bool
 
 idWantsToBeINLINEd id
   = case (getIdUnfolding id) of
       IWantToBeINLINEd _ -> True
       _ -> False
+-}
 \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 ty info (TopLevId fn))
@@ -929,22 +858,13 @@ unlocaliseId mod (Id u ty info (WorkerId unwrkr))
       Nothing -> Nothing
       Just xx -> Just (Id u ty info (WorkerId xx))
 
-unlocaliseId mod (Id u ty info (InstId inst))
+unlocaliseId mod (Id u ty info (InstId name))
   = Just (Id u ty info (TopLevId full_name))
 	-- type might be wrong, but it hardly matters
 	-- at this stage (just before printing C)  ToDo
   where
-    name = let	(bit1:bits) = getInstNamePieces True inst  in
-	   _CONCAT_ (bit1 : [ _CONS_ '.'  b | b <- bits ])
-
-    full_name = mkFullName mod (mod _APPEND_ name) InventedInThisModule ExportAll mkGeneratedSrcLoc
-
-#ifdef DPH
-unlocaliseId mod (PodId dim ity id)
-  = case (unlocaliseId mod id) of
-      Just id' -> Just (PodId dim ity id')
-      Nothing  -> Nothing
-#endif {- Data Parallel Haskell -}
+    name = getLocalName name
+    full_name = mkFullName mod name InventedInThisModule ExportAll mkGeneratedSrcLoc
 
 unlocaliseId mod other_id = Nothing
 
@@ -968,6 +888,7 @@ unlocalise_parent mod uniq (Id _ ty info (SysLocalId sn no_ftvs))
 
 unlocalise_parent mod uniq other_id = unlocaliseId mod other_id
   -- we're OK otherwise
+-}
 \end{code}
 
 CLAIM (not ASSERTed) for @applyTypeEnvToId@ and @applySubstToId@:
@@ -978,6 +899,7 @@ The special casing is in @applyTypeEnvToId@, not @apply_to_Id@, as the
 former ``should be'' the usual crunch point.
 
 \begin{code}
+{-LATER:
 applyTypeEnvToId :: TypeEnv -> Id -> Id
 
 applyTypeEnvToId type_env id@(Id u ty info details)
@@ -987,10 +909,12 @@ applyTypeEnvToId type_env id@(Id u ty info details)
   = apply_to_Id ( \ ty ->
 	applyTypeEnvToTy type_env ty
     ) id
+-}
 \end{code}
 
 \begin{code}
-apply_to_Id :: (UniType -> UniType)
+{-LATER:
+apply_to_Id :: (Type -> Type)
 	    -> Id
 	    -> Id
 
@@ -1020,12 +944,8 @@ apply_to_Id ty_fn (Id u ty info details)
 	in
 	WorkerId new_unwrkr
 
-#ifdef DPH
-    apply_to_details (PodId d ity id )
-      = PodId d ity (apply_to_Id ty_fn id)
-#endif {- Data Parallel Haskell -}
-
     apply_to_details other = other
+-}
 \end{code}
 
 Sadly, I don't think the one using the magic typechecker substitution
@@ -1035,6 +955,7 @@ Strictness is very important here.  We can't leave behind thunks
 with pointers to the substitution: it {\em must} be single-threaded.
 
 \begin{code}
+{-LATER:
 applySubstToId :: Subst -> Id -> (Subst, Id)
 
 applySubstToId subst id@(Id u ty info details)
@@ -1052,7 +973,7 @@ applySubstToId subst id@(Id u ty info details)
 
     apply_to_details subst new_ty (SpecId unspec ty_maybes _)
       = case (applySubstToId subst unspec)  	     of { (s2, new_unspec) ->
-        case (mapAccumL apply_to_maybe s2 ty_maybes) of { (s3, new_maybes) ->
+	case (mapAccumL apply_to_maybe s2 ty_maybes) of { (s3, new_maybes) ->
 	(s3, SpecId new_unspec new_maybes (no_free_tvs new_ty)) }}
 	-- NB: recalc no_ftvs (I think it's necessary (?) WDP 95/04)
       where
@@ -1063,30 +984,29 @@ applySubstToId subst id@(Id u ty info details)
 
     apply_to_details subst _ (WorkerId unwrkr)
       = case (applySubstToId subst unwrkr) of { (s2, new_unwrkr) ->
-        (s2, WorkerId new_unwrkr) }
+	(s2, WorkerId new_unwrkr) }
 
     apply_to_details subst _ other = (subst, other)
-
-#ifdef DPH
-applySubstToId (PodId d ity id )
-  = ???? ToDo:DPH; not sure what! returnLft (PodId d ity (applySubstToId id))
-#endif {- Data Parallel Haskell -}
+-}
 \end{code}
 
 \begin{code}
-getIdNamePieces :: Bool {-show Uniques-} -> Id -> [FAST_STRING]
-
-getIdNamePieces show_uniqs (Id u ty info details)
-  = case details of
-      DataConId n _ _ _ _ _ ->
+getIdNamePieces :: Bool {-show Uniques-} -> GenId ty -> [FAST_STRING]
+getIdNamePieces show_uniqs id
+  = get (unsafeGenId2Id id)
+  where
+  get (Id u _ details _ _)
+    = case details of
+      DataConId n _ _ _ _ _ _ ->
 	case (getOrigName n) of { (mod, name) ->
 	if fromPrelude mod then [name] else [mod, name] }
 
-      TupleConId a -> [SLIT("Tup") _APPEND_ (_PK_ (show a))]
+      TupleConId 0 -> [SLIT("()")]
+      TupleConId a -> [_PK_ ( "(" ++ nOfThem (a-1) ',' ++ ")" )]
 
-      ImportedId  n -> get_fullname_pieces n
-      PreludeId   n -> get_fullname_pieces n
-      TopLevId    n -> get_fullname_pieces n
+      ImportedId n -> get_fullname_pieces n
+      PreludeId  n -> get_fullname_pieces n
+      TopLevId   n -> get_fullname_pieces n
 
       SuperDictSelId c sc ->
 	case (getOrigName c)	of { (c_mod, c_name) ->
@@ -1102,7 +1022,7 @@ getIdNamePieces show_uniqs (Id u ty info details)
 	in
 	[SLIT("sdsel")] ++ c_bits ++ sc_bits  }}
 
-      ClassOpId clas op ->
+      MethodSelId clas op ->
 	case (getOrigName clas)	of { (c_mod, c_name) ->
 	case (getClassOpString op)	of { op_name ->
 	if fromPreludeCore clas then [op_name] else [c_mod, c_name, op_name]
@@ -1121,7 +1041,7 @@ getIdNamePieces show_uniqs (Id u ty info details)
 	    c_bits = if fromPreludeCore c
 		     then [c_name]
 		     else [c_mod, c_name]
-	
+
 	    ty_bits = getTypeString ty
 	in
 	[SLIT("dfun")] ++ c_bits ++ ty_bits }
@@ -1141,31 +1061,21 @@ getIdNamePieces show_uniqs (Id u ty info details)
       -- names of the types to which specialised...
 
       SpecId unspec ty_maybes _ ->
-	getIdNamePieces show_uniqs unspec ++ (
-	if not (toplevelishId unspec)
-	then [showUnique u]
-	else concat (map typeMaybeString ty_maybes)
-	)
+	get unspec ++ (if not (toplevelishId unspec)
+		       then [showUnique u]
+		       else concat (map typeMaybeString ty_maybes))
 
       WorkerId unwrkr ->
-	getIdNamePieces show_uniqs unwrkr ++ (
-	if not (toplevelishId unwrkr)
-	then [showUnique u]
-	else [SLIT("wrk")]    -- show u
-	)
+	get unwrkr ++ (if not (toplevelishId unwrkr)
+		       then [showUnique u]
+		       else [SLIT("wrk")])
 
-      InstId    inst     -> getInstNamePieces show_uniqs inst
       LocalId      n _   -> let local = getLocalName n in
-		            if show_uniqs then [local, showUnique u] else [local]
+			    if show_uniqs then [local, showUnique u] else [local]
+      InstId       n     -> [getLocalName n, showUnique u]
       SysLocalId   n _   -> [getLocalName n, showUnique u]
       SpecPragmaId n _ _ -> [getLocalName n, showUnique u]
 
-#ifdef DPH
-      ProcessorCon a _ -> ["MkProcessor" ++ (show a)]
-      PodId n ity id   -> getIdNamePieces show_uniqs id ++
-			   ["mapped", "POD" ++ (show n), show ity]
-#endif {- Data Parallel Haskell -}
-
 get_fullname_pieces :: FullName -> [FAST_STRING]
 get_fullname_pieces n
   = BIND (getOrigName n) _TO_ (mod, name) ->
@@ -1175,23 +1085,6 @@ get_fullname_pieces n
     BEND
 \end{code}
 
-Really Inst-ish, but only used in this module...
-\begin{code}
-getInstNamePieces :: Bool -> Inst -> [FAST_STRING]
-
-getInstNamePieces show_uniqs (Dict   u clas ty _)
-  = let  (mod, nm) = getOrigName clas  in
-    if fromPreludeCore clas
-    then [SLIT("d"), nm, showUnique u]
-    else [SLIT("d"), mod, nm, showUnique u]
-    
-getInstNamePieces show_uniqs (Method u id tys  _)
-  = let local = getIdNamePieces show_uniqs id in
-    if show_uniqs then local ++ [showUnique u] else local
-
-getInstNamePieces show_uniqs (LitInst u _ _ _) = [SLIT("lit"), showUnique u]
-\end{code}
-
 %************************************************************************
 %*									*
 \subsection[Id-type-funs]{Type-related @Id@ functions}
@@ -1199,63 +1092,29 @@ getInstNamePieces show_uniqs (LitInst u _ _ _) = [SLIT("lit"), showUnique u]
 %************************************************************************
 
 \begin{code}
-getIdUniType :: Id -> UniType
-
-getIdUniType (Id _ ty _ _) = ty
-
-#ifdef DPH
--- ToDo: DPH
-getIdUniType (ProcessorCon _ ty)	= ty
-getIdUniType (PodId d ity id)
-  = let (foralls,rho) = splitForalls (getIdUniType id)		in
-    let tys	      = get_args rho				in
-    let itys_mask     = infoTypeNumToMask ity			in
-    let tys'	      = zipWith convert tys itys_mask		in
-    mkForallTy foralls (foldr1 mkFunTy tys')
-  where	-- ToDo(hilly) change to use getSourceType etc...
-
-    get_args ty = case (maybeUnpackFunTy ty) of
-		    Nothing	   -> [ty]
-		    Just (arg,res) -> arg:get_args res
-
-    convert ty cond = if cond
-		      then ty
-		      else (coerce ty)
-
-    coerce ty = case (maybeUnpackFunTy ty) of
-		  Nothing	 ->mkPodizedPodNTy d ty
-		  Just (arg,res) ->mkFunTy (coerce arg) (coerce res)
-#endif {- Data Parallel Haskell -}
+idType :: GenId ty -> ty
+
+idType (Id _ ty _ _ _) = ty
 \end{code}
 
 \begin{code}
+{-LATER:
 getMentionedTyConsAndClassesFromId :: Id -> (Bag TyCon, Bag Class)
 
 getMentionedTyConsAndClassesFromId id
- = getMentionedTyConsAndClassesFromUniType (getIdUniType id)
+ = getMentionedTyConsAndClassesFromType (idType id)
+-}
 \end{code}
 
 \begin{code}
-getIdKind i = kindFromType (getIdUniType i)
+--getIdPrimRep i = primRepFromType (idType i)
 \end{code}
 
 \begin{code}
+{-LATER:
 getInstIdModule (Id _ _ _ (DictFunId _ _ _ mod)) = mod
 getInstIdModule (Id _ _ _ (ConstMethodId _ _ _ _ mod)) = mod
 getInstIdModule other = panic "Id:getInstIdModule"
-\end{code}
-
-
-\begin{code}
-{- NOT USED 
-getIdTauType :: Id -> TauType
-getIdTauType i = expandTySyn (getTauType (getIdUniType i))
-
-getIdSourceTypes :: Id -> [TauType]
-getIdSourceTypes i = map expandTySyn (sourceTypes (getTauType (getIdUniType i)))
-
-getIdTargetType :: Id -> TauType
-getIdTargetType i = expandTySyn (targetType (getTauType (getIdUniType i)))
 -}
 \end{code}
 
@@ -1266,29 +1125,37 @@ getIdTargetType i = expandTySyn (targetType (getTauType (getIdUniType i)))
 %************************************************************************
 
 \begin{code}
-mkSuperDictSelId  u c sc     ty info = Id u ty info (SuperDictSelId c sc)
-mkClassOpId       u c op     ty info = Id u ty info (ClassOpId c op)
-mkDefaultMethodId u c op gen ty info = Id u ty info (DefaultMethodId c op gen)
+mkSuperDictSelId  u c sc     ty info = Id u ty (SuperDictSelId c sc) NoPragmaInfo info
+mkMethodSelId       u c op     ty info = Id u ty (MethodSelId c op) NoPragmaInfo info
+mkDefaultMethodId u c op gen ty info = Id u ty (DefaultMethodId c op gen) NoPragmaInfo info
 
 mkDictFunId u c ity full_ty from_here modname info
-  = Id u full_ty info (DictFunId c ity from_here modname)
+  = Id u full_ty (DictFunId c ity from_here modname) NoPragmaInfo info
 
 mkConstMethodId	u c op ity full_ty from_here modname info
-  = Id u full_ty info (ConstMethodId c ity op from_here modname)
+  = Id u full_ty (ConstMethodId c ity op from_here modname) NoPragmaInfo info
 
-mkWorkerId u unwrkr ty info = Id u ty info (WorkerId unwrkr)
+mkWorkerId u unwrkr ty info = Id u ty (WorkerId unwrkr) NoPragmaInfo info
 
-mkInstId inst
-  = Id u (getInstUniType inst) noIdInfo (InstId inst)
-  where
-    u = case inst of
-	  Dict	  u c t o   -> u
-	  Method  u i ts o  -> u
-	  LitInst u l ty o  -> u
-
-{- UNUSED:
-getSuperDictSelIdSig (Id _ _ _ (SuperDictSelId input_class result_class))
-  = (input_class, result_class)
+mkInstId uniq ty name = Id uniq ty (InstId name) NoPragmaInfo noIdInfo
+
+{-LATER:
+getConstMethodId clas op ty
+  = -- constant-method info is hidden in the IdInfo of
+    -- the class-op id (as mentioned up above).
+    let
+	sel_id = getMethodSelId clas op
+    in
+    case (lookupConstMethodId (getIdSpecialisation sel_id) ty) of
+      Just xx -> xx
+      Nothing -> error (ppShow 80 (ppAboves [
+	ppCat [ppStr "ERROR: getConstMethodId:", ppr PprDebug op,
+	       ppr PprDebug ty, ppr PprDebug ops, ppr PprDebug op_ids,
+	       ppr PprDebug sel_id],
+	ppStr "(This can arise if an interface pragma refers to an instance",
+	ppStr "but there is no imported interface which *defines* that instance.",
+	ppStr "The info above, however ugly, should indicate what else you need to import."
+	]))
 -}
 \end{code}
 
@@ -1299,36 +1166,48 @@ getSuperDictSelIdSig (Id _ _ _ (SuperDictSelId input_class result_class))
 %************************************************************************
 
 \begin{code}
-mkImported    u n ty info = Id u ty info (ImportedId   n)
-mkPreludeId   u n ty info = Id u ty info (PreludeId    n)
-
-#ifdef DPH
-mkPodId d i = PodId d i
-#endif
+mkImported    u n ty info = Id u ty (ImportedId n) NoPragmaInfo info
+mkPreludeId   u n ty info = Id u ty (PreludeId  n) NoPragmaInfo info
 
-updateIdType :: Id -> UniType -> Id
+{-LATER:
+updateIdType :: Id -> Type -> Id
 updateIdType (Id u _ info details) ty = Id u ty info details
+-}
 \end{code}
 
 \begin{code}
-no_free_tvs ty = null (extractTyVarsFromTy ty)
+no_free_tvs ty = panic "Id:no_free_tvs" -- null (extractTyVarsFromTy 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 -> UniType -> SrcLoc -> Id
+mkSysLocal, mkUserLocal :: FAST_STRING -> Unique -> ty -> SrcLoc -> GenId ty
 
 mkSysLocal str uniq ty loc
-  = Id uniq ty noIdInfo (SysLocalId (mkShortName str loc) (no_free_tvs ty))
+  = Id uniq ty (SysLocalId (mkShortName str loc) (no_free_tvs ty)) NoPragmaInfo noIdInfo
 
 mkUserLocal str uniq ty loc
-  = Id uniq ty noIdInfo (LocalId (mkShortName str loc) (no_free_tvs ty))
+  = Id uniq ty (LocalId (mkShortName str loc) (no_free_tvs ty)) NoPragmaInfo noIdInfo
+
+-- mkUserId builds a local or top-level Id, depending on the name given
+mkUserId :: Name -> ty -> PragmaInfo -> GenId ty
+mkUserId (Short uniq short) ty pragma_info
+  = Id uniq ty (LocalId short (no_free_tvs ty)) pragma_info noIdInfo
+mkUserId (ValName uniq full) ty pragma_info
+  = Id uniq ty 
+	(if isLocallyDefined full then TopLevId full else ImportedId full)
+	pragma_info noIdInfo
+\end{code}
+
+
+\begin{code}
+{-LATER:
 
 -- for a SpecPragmaId being created by the compiler out of thin air...
-mkSpecPragmaId :: FAST_STRING -> Unique -> UniType -> Maybe SpecInfo -> SrcLoc -> Id
-mkSpecPragmaId str uniq ty specinfo loc
-  = Id uniq ty noIdInfo (SpecPragmaId (mkShortName str loc) specinfo (no_free_tvs ty))
+mkSpecPragmaId :: FAST_STRING -> Unique -> Type -> Maybe Id -> SrcLoc -> Id
+mkSpecPragmaId str uniq ty specid loc
+  = Id uniq ty noIdInfo (SpecPragmaId (mkShortName str loc) specid (no_free_tvs ty))
 
--- for new SpecId 
+-- for new SpecId
 mkSpecId u unspec ty_maybes ty info
   = ASSERT(not (maybeToBool (isSpecId_maybe unspec)))
     Id u ty info (SpecId unspec ty_maybes (no_free_tvs ty))
@@ -1346,13 +1225,6 @@ mkSameSpecCon ty_maybes unspec@(Id u ty info details)
     -- pprTrace "SameSpecCon:Unique:"
     --	        (ppSep (ppr PprDebug unspec: [pprMaybeTy PprDebug ty | ty <- ty_maybes]))
 
--- mkId builds a local or top-level Id, depending on the name given
-mkId :: Name -> UniType -> IdInfo -> Id
-mkId (Short uniq short) ty info	= Id uniq ty info (LocalId short (no_free_tvs ty))
-mkId (OtherTopId uniq full) ty info
-  = Id uniq ty info
-	(if isLocallyDefined full then TopLevId full else ImportedId full)
-
 localiseId :: Id -> Id
 localiseId id@(Id u ty info details)
   = Id u ty info (LocalId (mkShortName name loc) (no_free_tvs ty))
@@ -1365,53 +1237,40 @@ localiseId id@(Id u ty info details)
 mkIdWithNewUniq :: Id -> Unique -> Id
 
 mkIdWithNewUniq (Id _ ty info details) uniq
-  = let
-	new_details
-	  = case details of
-	      InstId (Dict _ c t o)	-> InstId (Dict uniq c t o)
-	      InstId (Method _ i ts o)  -> InstId (Method uniq i ts o)
-	      InstId (LitInst _ l ty o) -> InstId (LitInst uniq l ty o)
-	      old_details		-> old_details
-    in
-    Id uniq ty info new_details
-
-#ifdef DPH
-mkIdWithNewUniq (PodId d t id) uniq = PodId d t (mkIdWithNewUniq id uniq)
-#endif {- Data Parallel Haskell -}
+  = Id uniq ty info new_details
+-}
 \end{code}
 
 Make some local @Ids@ for a template @CoreExpr@.  These have bogus
 @Uniques@, but that's OK because the templates are supposed to be
 instantiated before use.
 \begin{code}
-mkTemplateLocals :: [UniType] -> [Id]
+{-LATER:
+mkTemplateLocals :: [Type] -> [Id]
 mkTemplateLocals tys
   = zipWith (\ u -> \ ty -> mkSysLocal SLIT("tpl") u ty mkUnknownSrcLoc)
 	    (getBuiltinUniques (length tys))
 	    tys
+-}
 \end{code}
 
 \begin{code}
-getIdInfo :: Id -> IdInfo
-
-getIdInfo (Id _ _ info _) = info
+getIdInfo     :: GenId ty -> IdInfo
+getPragmaInfo :: GenId ty -> PragmaInfo
 
-#ifdef DPH
-getIdInfo (PodId _ _ id)		= getIdInfo id
-#endif {- Data Parallel Haskell -}
+getIdInfo     (Id _ _ _ _ info) = info
+getPragmaInfo (Id _ _ _ info _) = info
 
+{-LATER:
 replaceIdInfo :: Id -> IdInfo -> Id
 
 replaceIdInfo (Id u ty _ details) info = Id u ty info details
 
-#ifdef DPH
-replaceIdInfo (PodId dim ity id) info = PodId dim ity (replaceIdInfo id info)
-#endif {- Data Parallel Haskell -}
-
 selectIdInfoForSpecId :: Id -> IdInfo
 selectIdInfoForSpecId unspec
   = ASSERT(not (maybeToBool (isSpecId_maybe unspec)))
     noIdInfo `addInfo_UF` getIdUnfolding unspec
+-}
 \end{code}
 
 %************************************************************************
@@ -1425,25 +1284,19 @@ of their arities; so it should not be asking...	 (but other things
 besides the code-generator need arity info!)
 
 \begin{code}
-getIdArity  	:: Id -> ArityInfo
-getDataConArity :: DataCon -> Int -- a simpler i/face; they always have arities
-
-#ifdef DPH
-getIdArity (ProcessorCon n _)		= mkArityInfo n
-getIdArity (PodId _ _ id)		= getIdArity id
-#endif {- Data Parallel Haskell -}
-
-getIdArity (Id _ _ id_info _)  = getInfo id_info
+getIdArity :: Id -> ArityInfo
+getIdArity (Id _ _ _ _ id_info)  = getInfo id_info
 
-getDataConArity id@(Id _ _ id_info _)
+getDataConArity :: DataCon -> Int
+getDataConArity id@(Id _ _ _ _ id_info)
   = ASSERT(isDataCon id)
     case (arityMaybe (getInfo id_info)) of
       Nothing -> pprPanic "getDataConArity:Nothing:" (ppr PprDebug id)
       Just  i -> i
 
 addIdArity :: Id -> Int -> Id
-addIdArity (Id u ty info details) arity
-  = Id u ty (info `addInfo` (mkArityInfo arity)) details
+addIdArity (Id u ty details pinfo info) arity
+  = Id u ty details pinfo (info `addInfo` (mkArityInfo arity))
 \end{code}
 
 %************************************************************************
@@ -1453,66 +1306,76 @@ addIdArity (Id u ty info details) arity
 %************************************************************************
 
 \begin{code}
-mkDataCon :: Unique{-DataConKey-} -> FullName -> [TyVarTemplate] -> ThetaType -> [TauType] -> TyCon -> SpecEnv -> Id
-  -- can get the tag and all the pieces of the type from the UniType
-
-mkDataCon k n tyvar_tmpls context args_tys tycon specenv = data_con
+mkDataCon :: Unique{-DataConKey-}
+	  -> FullName
+	  -> [StrictnessMark]
+	  -> [TyVar] -> ThetaType -> [TauType] -> TyCon
+--ToDo:   -> SpecEnv
+	  -> Id
+  -- can get the tag and all the pieces of the type from the Type
+
+mkDataCon k n stricts tvs ctxt args_tys tycon
+  = ASSERT(length stricts == length args_tys)
+    data_con
   where
-    data_con  = Id k type_of_constructor datacon_info
-		    (DataConId n
-			(position_within fIRST_TAG data_con_family data_con)
-			tyvar_tmpls context args_tys tycon)
+    -- NB: data_con self-recursion; should be OK as tags are not
+    -- looked at until late in the game.
+    data_con
+      = Id k
+	   type_of_constructor
+	   (DataConId n data_con_tag stricts tvs ctxt args_tys tycon)
+	   NoPragmaInfo
+	   datacon_info
 
-    -- Note data_con self-recursion;
-    -- should be OK as tags are not looked at until
-    -- late in the game.
+    data_con_tag    = position_within fIRST_TAG data_con_family
 
-    data_con_family		= getTyConDataCons tycon
+    data_con_family = getTyConDataCons tycon
 
-    position_within :: Int -> [Id] -> Id -> Int
-    position_within acc [] con
-      = panic "mkDataCon: con not found in family"
+    position_within :: Int -> [Id] -> Int
 
-    position_within acc (c:cs) con
-      = if c `eqId` con then acc else position_within (acc+(1::Int)) cs con
+    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 = mkSigmaTy tyvar_tmpls context
-				(glueTyArgs
-					args_tys
-					(applyTyCon tycon (map mkTyVarTemplateTy tyvar_tmpls)))
+    type_of_constructor
+      = mkSigmaTy tvs ctxt
+	(mkFunTys args_tys (applyTyCon tycon (map mkTyVarTy tvs)))
 
     datacon_info = noIdInfo `addInfo_UF` unfolding
 			    `addInfo` mkArityInfo arity
-			    `addInfo` specenv
+--ToDo: 		    `addInfo` specenv
 
     arity = length args_tys
 
     unfolding
+      = noInfo_UF
+{- LATER:
       = -- if arity == 0
     	-- then noIdInfo
 	-- else -- do some business...
 	let
-	    (tyvars, dict_vars, vars) = mk_uf_bits tyvar_tmpls context args_tys tycon
+	    (tyvars, dict_vars, vars) = mk_uf_bits tvs ctxt args_tys tycon
 	    tyvar_tys = map mkTyVarTy tyvars
 	in
-	BIND (CoCon data_con tyvar_tys [CoVarAtom v | v <- vars]) _TO_ plain_CoCon ->
-
-	BIND (mkCoLam (dict_vars ++ vars) plain_CoCon) _TO_ lambdized_CoCon ->
+	BIND (Con data_con tyvar_tys [VarArg v | v <- vars]) _TO_ plain_Con ->
 
 	mkUnfolding EssentialUnfolding -- for data constructors
-		    (foldr CoTyLam lambdized_CoCon tyvars)
-	BEND BEND
+		    (mkLam tyvars (dict_vars ++ vars) plain_Con)
+	BEND
 
-    mk_uf_bits tyvar_tmpls context arg_tys tycon
+    mk_uf_bits tvs ctxt arg_tys tycon
       = let
 	    (inst_env, tyvars, tyvar_tys)
-	      = instantiateTyVarTemplates tyvar_tmpls 
-					  (map getTheUnique tyvar_tmpls)
+	      = instantiateTyVarTemplates tvs
+					  (map getItsUnique tvs)
 	in
 	    -- the "context" and "arg_tys" have TyVarTemplates in them, so
 	    -- we instantiate those types to have the right TyVars in them
 	    -- instead.
-	BIND (map (instantiateTauTy inst_env) (map ctxt_ty context))
+	BIND (map (instantiateTauTy inst_env) (map ctxt_ty ctxt))
 						       	_TO_ inst_dict_tys ->
 	BIND (map (instantiateTauTy inst_env) arg_tys) 	_TO_ inst_arg_tys ->
 
@@ -1521,34 +1384,38 @@ mkDataCon k n tyvar_tmpls context args_tys tycon specenv = data_con
 	    -- (Mega-Sigh) [ToDo]
 	BIND (mkTemplateLocals (inst_dict_tys ++ inst_arg_tys)) _TO_ all_vars ->
 
-	BIND (splitAt (length context) all_vars)	_TO_ (dict_vars, vars) ->
+	BIND (splitAt (length ctxt) all_vars)	_TO_ (dict_vars, vars) ->
 
 	(tyvars, dict_vars, vars)
 	BEND BEND BEND BEND
       where
-	-- these are really dubious UniTypes, but they are only to make the
+	-- 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 = data_con
+mkTupleCon arity
+  = Id unique ty (TupleConId arity) NoPragmaInfo tuplecon_info 
   where
-    data_con	= Id unique ty tuplecon_info (TupleConId arity)
     unique      = mkTupleDataConUnique arity
-    ty 		= mkSigmaTy tyvars [] (glueTyArgs tyvar_tys (applyTyCon tycon tyvar_tys))
+    ty 		= mkSigmaTy tyvars []
+		   (mkFunTys tyvar_tys (applyTyCon tycon tyvar_tys))
     tycon	= mkTupleTyCon arity
     tyvars	= take arity alphaTyVars
-    tyvar_tys	= map mkTyVarTemplateTy tyvars
+    tyvar_tys	= map mkTyVarTy tyvars
 
     tuplecon_info
       = noIdInfo `addInfo_UF` unfolding
 		 `addInfo` mkArityInfo arity
-		 `addInfo` pcGenerateTupleSpecs arity ty
+--LATER:?	 `addInfo` panic "Id:mkTupleCon:pcGenerateTupleSpecs arity ty"
 
     unfolding
+      = noInfo_UF
+{- LATER:
       = -- if arity == 0
     	-- then noIdInfo
 	-- else -- do some business...
@@ -1556,14 +1423,12 @@ mkTupleCon arity = data_con
 	    (tyvars, dict_vars, vars) = mk_uf_bits arity
 	    tyvar_tys = map mkTyVarTy tyvars
 	in
-	BIND (CoCon data_con tyvar_tys [CoVarAtom v | v <- vars]) _TO_ plain_CoCon ->
-
-	BIND (mkCoLam (dict_vars ++ vars) plain_CoCon) _TO_ lambdized_CoCon ->
+	BIND (Con data_con tyvar_tys [VarArg v | v <- vars]) _TO_ plain_Con ->
 
 	mkUnfolding
 	    EssentialUnfolding    -- data constructors
-	    (foldr CoTyLam lambdized_CoCon tyvars)
-	BEND BEND
+	    (mkLam tyvars (dict_vars ++ vars) plain_Con)
+	BEND
 
     mk_uf_bits arity
       = BIND (mkTemplateLocals tyvar_tys)		 _TO_ vars ->
@@ -1571,65 +1436,39 @@ mkTupleCon arity = data_con
 	BEND
       where
 	tyvar_tmpls	= take arity alphaTyVars
-	(_, tyvars, tyvar_tys) = instantiateTyVarTemplates tyvar_tmpls (map getTheUnique tyvar_tmpls)
-
-
-#ifdef DPH
-mkProcessorCon :: Arity -> Id
-mkProcessorCon arity
-  = ProcessorCon arity ty
-  where
-    ty = mkSigmaTy tyvars [] (glueTyArgs tyvar_tys (applyTyCon tycon tyvar_tys))
-    tycon	= mkProcessorTyCon arity
-    tyvars	= take arity alphaTyVars
-    tyvar_tys	= map mkTyVarTemplateTy tyvars
-#endif {- Data Parallel Haskell -}
+	(_, tyvars, tyvar_tys) = instantiateTyVarTemplates tyvar_tmpls (map getItsUnique tyvar_tmpls)
+-}
 
 fIRST_TAG :: ConTag
 fIRST_TAG =  1	-- Tags allocated from here for real constructors
-
--- given one data constructor in a family, return a list
--- of all the data constructors in that family.
-
-#ifdef DPH
-getDataConFamily :: DataCon -> [DataCon]
-
-getDataConFamily data_con
-  = ASSERT(isDataCon data_con)
-    getTyConDataCons (getDataConTyCon data_con)
-#endif
 \end{code}
 
 \begin{code}
 getDataConTag :: DataCon -> ConTag	-- will panic if not a DataCon
-
-getDataConTag	(Id _ _ _ (DataConId _ tag _ _ _ _)) = tag
-getDataConTag	(Id _ _ _ (TupleConId _))	     = fIRST_TAG
-getDataConTag	(Id _ _ _ (SpecId unspec _ _))	     = getDataConTag unspec
-#ifdef DPH
-getDataConTag	(ProcessorCon _ _) = fIRST_TAG
-#endif {- Data Parallel Haskell -}
+getDataConTag	(Id _ _ (DataConId _ tag _ _ _ _ _) _ _) = tag
+getDataConTag	(Id _ _ (TupleConId _) _ _)	         = fIRST_TAG
+getDataConTag	(Id _ _ (SpecId unspec _ _) _ _)	 = getDataConTag unspec
 
 getDataConTyCon :: DataCon -> TyCon	-- will panic if not a DataCon
+getDataConTyCon (Id _ _ (DataConId _ _ _ _ _ _ tycon) _ _) = tycon
+getDataConTyCon (Id _ _ (TupleConId a) _ _)	           = mkTupleTyCon a
 
-getDataConTyCon (Id _ _ _ (DataConId _ _ _ _ _ tycon)) = tycon
-getDataConTyCon (Id _ _ _ (TupleConId a))	       = mkTupleTyCon a
-getDataConTyCon	(Id _ _ _ (SpecId unspec tys _))       = mkSpecTyCon (getDataConTyCon unspec) tys
-#ifdef DPH
-getDataConTyCon (ProcessorCon a _) = mkProcessorTyCon a
-#endif {- Data Parallel Haskell -}
-
-getDataConSig :: DataCon -> ([TyVarTemplate], ThetaType, [TauType], TyCon)
+getDataConSig :: DataCon -> ([TyVar], ThetaType, [TauType], TyCon)
 					-- will panic if not a DataCon
 
-getDataConSig (Id _ _ _ (DataConId _ _ tyvars theta_ty arg_tys tycon))
+getDataConSig (Id _ _ (DataConId _ _ _ tyvars theta_ty arg_tys tycon) _ _)
   = (tyvars, theta_ty, arg_tys, tycon)
 
-getDataConSig (Id _ _ _ (TupleConId arity))
+getDataConSig (Id _ _ (TupleConId arity) _ _)
   = (tyvars, [], tyvar_tys, mkTupleTyCon arity)
   where
     tyvars	= take arity alphaTyVars
-    tyvar_tys	= map mkTyVarTemplateTy tyvars
+    tyvar_tys	= map mkTyVarTy tyvars
+\end{code}
+
+{- LATER
+getDataConTyCon	(Id _ _ _ (SpecId unspec tys _))
+  = mkSpecTyCon (getDataConTyCon unspec) tys
 
 getDataConSig (Id _ _ _ (SpecId unspec ty_maybes _))
   = (spec_tyvars, spec_theta_ty, spec_arg_tys, spec_tycon)
@@ -1650,21 +1489,15 @@ getDataConSig (Id _ _ _ (SpecId unspec ty_maybes _))
     spec_theta_ty = if null theta_ty then []
 		    else panic "getDataConSig:ThetaTy:SpecDataCon"
     spec_tycon    = mkSpecTyCon tycon ty_maybes
-
-#ifdef DPH
-getDataConSig (ProcessorCon arity _)
-  = (tyvars, [], tyvar_tys, mkProcessorTyCon arity)
-  where
-    tyvars	= take arity alphaTyVars
-    tyvar_tys	= map mkTyVarTemplateTy tyvars
-#endif {- Data Parallel Haskell -}
+-}
 \end{code}
 
+\begin{pseudocode}
 @getInstantiatedDataConSig@ takes a constructor and some types to which
 it is applied; it returns its signature instantiated to these types.
 
 \begin{code}
-getInstantiatedDataConSig :: 
+getInstantiatedDataConSig ::
 	   DataCon	-- The data constructor
 			--   Not a specialised data constructor
 	-> [TauType]	-- Types to which applied
@@ -1674,77 +1507,20 @@ getInstantiatedDataConSig ::
 	    TauType	-- Type of result
 	   )
 
-getInstantiatedDataConSig data_con tycon_arg_tys
+getInstantiatedDataConSig data_con inst_tys
   = ASSERT(isDataCon data_con)
-    --false?? WDP 95/06: ASSERT(not (maybeToBool (isSpecId_maybe data_con)))
     let
-	(tv_tmpls, theta, cmpnt_ty_tmpls, tycon) = getDataConSig data_con
+	(tvs, theta, arg_tys, tycon) = getDataConSig data_con
 
-	inst_env = --ASSERT(length tv_tmpls == length tycon_arg_tys)
-{-		   if (length tv_tmpls /= length tycon_arg_tys) then
-			pprPanic "Id:1666:" (ppCat [ppr PprShowAll data_con, ppr PprDebug tycon_arg_tys])
-		   else
--}		   tv_tmpls `zip` tycon_arg_tys
+	inst_env = ASSERT(length tvs == length inst_tys)
+		   tvs `zip` inst_tys
 
-	theta_tys = [ instantiateTauTy inst_env (mkDictTy c t) | (c,t) <- theta ]
-	cmpnt_tys = map (instantiateTauTy inst_env) cmpnt_ty_tmpls
-	result_ty = instantiateTauTy inst_env (applyTyCon tycon tycon_arg_tys)
+	theta_tys = [ instantiateTy inst_env (mkDictTy c t) | (c,t) <- theta ]
+	cmpnt_tys = [ instantiateTy inst_env arg_ty | arg_ty <- arg_tys ]
+	result_ty = instantiateTy inst_env (applyTyCon tycon inst_tys)
     in
     -- Are the first/third results ever used?
     (theta_tys, cmpnt_tys, result_ty)
-
-{- UNUSED: allows a specilaised constructor to be instantiated
-	   (with all argument types of the unspecialsied tycon)
-
-getInstantiatedDataConSig data_con tycon_arg_tys
-  = ASSERT(isDataCon data_con)
-    if is_speccon && arg_tys_match_error then
-	pprPanic "getInstantiatedDataConSig:SpecId:"
-		 (ppHang (ppr PprDebug data_con) 4 pp_match_error)
-    else
-	(theta_tys, cmpnt_tys, result_ty)  -- Are the first/third results ever used?
-  where
-    is_speccon       = maybeToBool is_speccon_maybe
-    is_speccon_maybe = isSpecId_maybe data_con
-    Just (unspec_con, spec_tys) = is_speccon_maybe
-
-    arg_tys_match_error = maybeToBool match_error_maybe
-    match_error_maybe   = ASSERT(length spec_tys == length tycon_arg_tys)
-			  argTysMatchSpecTys spec_tys tycon_arg_tys
-    (Just pp_match_error) = match_error_maybe
-
-    (tv_tmpls, theta, cmpnt_ty_tmpls, tycon)
-      = if is_speccon 
-	then getDataConSig unspec_con
-	else getDataConSig data_con
-
-    inst_env = ASSERT(length tv_tmpls == length tycon_arg_tys)
-	       tv_tmpls `zip` tycon_arg_tys
-
-    theta_tys = [ instantiateTauTy inst_env (mkDictTy c t) | (c,t) <- theta ]
-    cmpnt_tys = map (instantiateTauTy inst_env) cmpnt_ty_tmpls
-    result_ty = instantiateTauTy inst_env (applyTyCon tycon tycon_arg_tys)
--}
-\end{code}
-
-The function @getDataConDeps@ is passed an @Id@ representing a data
-constructor of some type. We look at the source types of the
-constructor and create the set of all @TyCons@ referred to directly
-from the source types.
-
-\begin{code}
-#ifdef USE_SEMANTIQUE_STRANAL
-getDataConDeps :: Id -> [TyCon]
-
-getDataConDeps (Id _ _ _ (DataConId _ _ _ _ arg_tys _))
-  = concat (map getReferredToTyCons arg_tys)
-getDataConDeps (Id _ _ _ (TupleConId _)) = []
-getDataConDeps (Id _ _ _ (SpecId unspec ty_maybes _))
-  = getDataConDeps unspec ++ concat (map getReferredToTyCons (catMaybes ty_maybes))
-#ifdef DPH
-getDataConDeps (ProcessorCon _ _) = []
-#endif {- Data Parallel Haskell -}
-#endif {- Semantique strictness analyser -}
 \end{code}
 
 Data type declarations are of the form:
@@ -1754,9 +1530,9 @@ data Foo a b = C1 ... | C2 ... | ... | Cn ...
 For each constructor @Ci@, we want to generate a curried function; so, e.g., for
 @C1 x y z@, we want a function binding:
 \begin{verbatim}
-fun_C1 = /\ a -> /\ b -> \ [x, y, z] -> CoCon C1 [a, b] [x, y, z]
+fun_C1 = /\ a -> /\ b -> \ [x, y, z] -> Con C1 [a, b] [x, y, z]
 \end{verbatim}
-Notice the ``big lambdas'' and type arguments to @CoCon@---we are producing
+Notice the ``big lambdas'' and type arguments to @Con@---we are producing
 2nd-order polymorphic lambda calculus with explicit types.
 
 %************************************************************************
@@ -1781,34 +1557,11 @@ dictionaries, in the even of an overloaded data-constructor---none at
 present.)
 
 \begin{code}
-getIdUnfolding	    :: Id -> UnfoldingDetails
+getIdUnfolding :: Id -> UnfoldingDetails
 
-#ifdef DPH
-getIdUnfolding dcon@(ProcessorCon arity _)
-  = let
-	(tyvars, dict_vars, vars) = getDataConUnfolding dcon
-	tyvar_tys = map mkTyVarTy tyvars
-    in
-    BIND (CoCon dcon tyvar_tys [CoVarAtom v | v <- vars]) _TO_ plain_CoCon ->
-    BIND (mkCoLam vars plain_CoCon)		 _TO_ lambdized_CoCon ->
-    mkUnfoldTemplate (\x->False){-ToDo-} EssentialUnfolding{-ToDo???DPH-} (foldr CoTyLam lambdized_CoCon tyvars)
-    BEND BEND
-
--- If we have a PodId whose ``id'' has an unfolding, then we need to
--- parallelize the unfolded expression for the d^th dimension.
-{-
-getIdUnfolding (PodId d _ id)
-   = case (unfoldingMaybe (getIdUnfolding id)) of
-	Nothing	  -> noInfo
-	Just expr -> trace ("getIdUnfolding ("++
-			    ppShow 80 (ppr PprDebug id) ++
-			    ") for " ++ show d ++ "D pod")
-			   (podizeTemplateExpr d expr)
--}
-#endif {- Data Parallel Haskell -}
-
-getIdUnfolding (Id _ _ id_info _) = getInfo_UF id_info
+getIdUnfolding (Id _ _ _ _ info) = getInfo_UF info
 
+{-LATER:
 addIdUnfolding :: Id -> UnfoldingDetails -> Id
 addIdUnfolding id@(Id u ty info details) unfold_details
   = ASSERT(
@@ -1820,10 +1573,6 @@ addIdUnfolding id@(Id u ty info details) unfold_details
 	_   	    	    	    -> False -- v bad
     )
     Id u ty (info `addInfo_UF` unfold_details) details
-
-{- UNUSED:
-clearIdUnfolding :: Id -> Id
-clearIdUnfolding (Id u ty info details) = Id u ty (clearInfo_UF info) details
 -}
 \end{code}
 
@@ -1838,25 +1587,6 @@ class Foo a { op :: Complex b => c -> b -> a }
 			    # note local polymorphism...
 \end{verbatim}
 
-For data constructors, we make an unfolding which has a bunch of
-lambdas to bind the arguments, with a (saturated) @CoCon@ inside.  In
-the case of overloaded constructors, the dictionaries are just thrown
-away; they were only required in the first place to ensure that the
-type was indeed an instance of the required class.
-\begin{code}
-#ifdef DPH
-getDataConUnfolding :: Id -> ([TyVar], [Id], [Id])
-
-getDataConUnfolding dcon@(ProcessorCon arity _)
-  = BIND (mkTemplateLocals tyvar_tys)		 _TO_ vars ->
-    (tyvars, [], vars)
-    BEND
-  where
-    tyvar_tmpls = take arity alphaTyVars
-    (_, tyvars, tyvar_tys) = instantiateTyVarTemplates tyvar_tmpls (map getTheUnique tyvar_tmpls)
-#endif {- Data Parallel Haskell -}
-\end{code}
-
 %************************************************************************
 %*									*
 \subsection[IdInfo-funs]{Functions related to @Ids@' @IdInfos@}
@@ -1865,47 +1595,53 @@ getDataConUnfolding dcon@(ProcessorCon arity _)
 
 \begin{code}
 getIdDemandInfo :: Id -> DemandInfo
-getIdDemandInfo (Id _ _ info _) = getInfo info
+getIdDemandInfo (Id _ _ _ _ info) = getInfo info
 
 addIdDemandInfo :: Id -> DemandInfo -> Id
-addIdDemandInfo (Id u ty info details) demand_info
-  = Id u ty (info `addInfo` demand_info) details
+addIdDemandInfo (Id u ty details prags info) demand_info
+  = Id u ty details prags (info `addInfo` demand_info)
 \end{code}
 
 \begin{code}
 getIdUpdateInfo :: Id -> UpdateInfo
-getIdUpdateInfo (Id u ty info details) = getInfo info
+getIdUpdateInfo (Id _ _ _ _ info) = getInfo info
 
 addIdUpdateInfo :: Id -> UpdateInfo -> Id
-addIdUpdateInfo (Id u ty info details) upd_info
-  = Id u ty (info `addInfo` upd_info) details
+addIdUpdateInfo (Id u ty details prags info) upd_info
+  = Id u ty details prags (info `addInfo` upd_info)
 \end{code}
 
 \begin{code}
+{- LATER:
 getIdArgUsageInfo :: Id -> ArgUsageInfo
 getIdArgUsageInfo (Id u ty info details) = getInfo info
 
 addIdArgUsageInfo :: Id -> ArgUsageInfo -> Id
 addIdArgUsageInfo (Id u ty info details) au_info
   = Id u ty (info `addInfo` au_info) details
+-}
 \end{code}
 
 \begin{code}
+{- LATER:
 getIdFBTypeInfo :: Id -> FBTypeInfo
 getIdFBTypeInfo (Id u ty info details) = getInfo info
 
 addIdFBTypeInfo :: Id -> FBTypeInfo -> Id
 addIdFBTypeInfo (Id u ty info details) upd_info
   = Id u ty (info `addInfo` upd_info) details
+-}
 \end{code}
 
 \begin{code}
+{- LATER:
 getIdSpecialisation :: Id -> SpecEnv
-getIdSpecialisation (Id _ _ info _) = getInfo info
+getIdSpecialisation (Id _ _ _ _ info) = getInfo info
 
 addIdSpecialisation :: Id -> SpecEnv -> Id
-addIdSpecialisation (Id u ty info details) spec_info
-  = Id u ty (info `addInfo` spec_info) details
+addIdSpecialisation (Id u ty details prags info) spec_info
+  = Id u ty details prags (info `addInfo` spec_info)
+-}
 \end{code}
 
 Strictness: we snaffle the info out of the IdInfo.
@@ -1913,12 +1649,12 @@ Strictness: we snaffle the info out of the IdInfo.
 \begin{code}
 getIdStrictness :: Id -> StrictnessInfo
 
-getIdStrictness (Id _ _ id_info _) = getInfo id_info
+getIdStrictness (Id _ _ _ _ info) = getInfo info
 
 addIdStrictness :: Id -> StrictnessInfo -> Id
 
-addIdStrictness (Id u ty info details) strict_info
-  = Id u ty (info `addInfo` strict_info) details
+addIdStrictness (Id u ty details prags info) strict_info
+  = Id u ty details prags (info `addInfo` strict_info)
 \end{code}
 
 %************************************************************************
@@ -1930,35 +1666,33 @@ addIdStrictness (Id u ty info details) strict_info
 Comparison: equality and ordering---this stuff gets {\em hammered}.
 
 \begin{code}
-cmpId (Id u1 _ _ _) (Id u2 _ _ _) = cmpUnique u1 u2
+cmpId (Id u1 _ _ _ _) (Id u2 _ _ _ _) = cmp u1 u2
 -- short and very sweet
 \end{code}
 
 \begin{code}
-eqId :: Id -> Id -> Bool
+instance Ord3 (GenId ty) where
+    cmp = cmpId
 
-eqId a b = case cmpId a b of { EQ_ -> True;  _   -> False }
-
-instance Eq Id where
+instance Eq (GenId ty) where
     a == b = case cmpId a b of { EQ_ -> True;  _ -> False }
     a /= b = case cmpId a b of { EQ_ -> False; _ -> True  }
 
-instance Ord Id where
+instance Ord (GenId ty) where
     a <= b = case cmpId a b of { LT_ -> True;  EQ_ -> True;  GT__ -> False }
     a <	 b = case cmpId a b of { LT_ -> True;  EQ_ -> False; GT__ -> False }
     a >= b = case cmpId a b of { LT_ -> False; EQ_ -> True;  GT__ -> True  }
     a >	 b = case cmpId a b of { LT_ -> False; EQ_ -> False; GT__ -> True  }
-#ifdef __GLASGOW_HASKELL__
     _tagCmp a b = case cmpId a b of { LT_ -> _LT; EQ_ -> _EQ; GT__ -> _GT }
-#endif
 \end{code}
 
 @cmpId_withSpecDataCon@ ensures that any spectys are taken into
 account when comparing two data constructors. We need to do this
-because a specialsied data constructor has the same unique as its
-unspeciailsed counterpart.
+because a specialised data constructor has the same Unique as its
+unspecialised counterpart.
 
 \begin{code}
+{-LATER:
 cmpId_withSpecDataCon :: Id -> Id -> TAG_
 
 cmpId_withSpecDataCon id1 id2
@@ -1982,7 +1716,7 @@ cmpEqDataCon (Id _ _ _ (SpecId _ _ _)) unspec2
 
 cmpEqDataCon unspec1 unspec2
   = EQ_
-
+-}
 \end{code}
 
 %************************************************************************
@@ -1992,7 +1726,7 @@ cmpEqDataCon unspec1 unspec2
 %************************************************************************
 
 \begin{code}
-instance Outputable Id where
+instance Outputable ty => Outputable (GenId ty) where
     ppr sty id = pprId sty id
 
 showId :: PprStyle -> Id -> String
@@ -2005,90 +1739,102 @@ showId sty id = ppShow 80 (pprId sty id)
 -- class and tycon are from PreludeCore [non-std, but convenient]
 -- *and* the thing was defined in this module.
 
-instance_export_flag :: Class -> UniType -> Bool -> ExportFlag
+instance_export_flag :: Class -> Type -> Bool -> ExportFlag
 
 instance_export_flag clas inst_ty from_here
+  = panic "Id:instance_export_flag"
+{-LATER
   = if instanceIsExported clas inst_ty from_here
     then ExportAll
     else NotExported
+-}
 \end{code}
 
 Do we consider an ``instance type'' (as on a @DictFunId@) to be ``from
 PreludeCore''?  True if the outermost TyCon is fromPreludeCore.
 \begin{code}
-is_prelude_core_ty :: UniType -> Bool
+is_prelude_core_ty :: Type -> Bool
 
 is_prelude_core_ty inst_ty
-  = case getUniDataTyCon_maybe inst_ty of
+  = panic "Id.is_prelude_core_ty"
+{- LATER
+  = case maybeDataTyCon inst_ty of
       Just (tycon,_,_) -> fromPreludeCore tycon
       Nothing 	       -> panic "Id: is_prelude_core_ty"
+-}
 \end{code}
 
 Default printing code (not used for interfaces):
 \begin{code}
-pprId :: PprStyle -> Id -> Pretty
+pprId :: Outputable ty => PprStyle -> GenId ty -> Pretty
 
 pprId other_sty id
   = let
 	pieces = getIdNamePieces (case other_sty of {PprForUser -> False; _ -> True}) id
 
-	for_code
-	  = let
+	for_code = panic "pprId: for code"
+	{-  = let
 		pieces_to_print -- maybe use Unique only
 		  = if isSysLocalId id then tail pieces else pieces
 	    in
 	    ppIntersperse (ppPStr cSEP) (map identToC pieces_to_print)
+	-}
     in
     case other_sty of
-      PprForC _	      -> for_code
-      PprForAsm _ _ _ -> for_code
-      PprInterface _  -> ppPStr occur_name
+      PprForC	      -> for_code
+      PprForAsm _ _   -> for_code
+      PprInterface    -> ppPStr occur_name
       PprForUser      -> ppPStr occur_name
-      PprUnfolding _  -> qualified_name pieces
+      PprUnfolding    -> qualified_name pieces
       PprDebug	      -> qualified_name pieces
       PprShowAll      -> ppBesides [qualified_name pieces,
 			    (ppCat [pp_uniq id,
 				    ppPStr SLIT("{-"),
-				    ppr other_sty (getIdUniType id),
-				    ppIdInfo other_sty id True (\x->x) nullIdEnv (getIdInfo id),
+				    ppr other_sty (idType id),
+				    ppIdInfo other_sty (unsafeGenId2Id id) True
+					     (\x->x) nullIdEnv (getIdInfo id),
 				    ppPStr SLIT("-}") ])]
   where
     occur_name = getOccurrenceName id _APPEND_
 		 ( _PK_ (if not (isSysLocalId id)
 			 then ""
-			 else "." ++ (_UNPK_ (showUnique (getTheUnique id)))))
+			 else "." ++ (_UNPK_ (showUnique (getItsUnique id)))))
 
     qualified_name pieces
       = ppBeside (pp_ubxd (ppIntersperse (ppChar '.') (map ppPStr pieces))) (pp_uniq id)
 
-    pp_uniq (Id _ _ _ (PreludeId _)) 	= ppNil -- No uniq to add
-    pp_uniq (Id _ _ _ (DataConId _ _ _ _ _ _)) = ppNil	-- No uniq to add
-    pp_uniq (Id _ _ _ (TupleConId _)) 	    = ppNil -- No uniq to add
-    pp_uniq (Id _ _ _ (LocalId      _ _))   = ppNil -- uniq printed elsewhere
-    pp_uniq (Id _ _ _ (SysLocalId   _ _))   = ppNil -- ditto
-    pp_uniq (Id _ _ _ (SpecPragmaId _ _ _)) = ppNil -- ditto
-    pp_uniq (Id _ _ _ (InstId _))   	    = ppNil -- ditto
-    pp_uniq other_id = ppBesides [ppPStr SLIT("{-"), pprUnique (getTheUnique other_id),  ppPStr SLIT("-}")]
-
-    -- For Robin Popplestone: print PprDebug Ids with # afterwards
-    -- if they are of primitive type.
-    pp_ubxd pretty = if isPrimType (getIdUniType id)
+    pp_uniq (Id _ _ (PreludeId _) _ _) 	    	   = ppNil -- no uniq to add
+    pp_uniq (Id _ _ (DataConId _ _ _ _ _ _ _) _ _) = ppNil
+    pp_uniq (Id _ _ (TupleConId _) _ _) 	   = ppNil
+    pp_uniq (Id _ _ (LocalId _ _) _ _)   	   = ppNil -- uniq printed elsewhere
+    pp_uniq (Id _ _ (SysLocalId _ _) _ _)   	   = ppNil
+    pp_uniq (Id _ _ (SpecPragmaId _ _ _) _ _) 	   = ppNil
+    pp_uniq (Id _ _ (InstId _) _ _)   	   	   = ppNil
+    pp_uniq other_id = ppBesides [ppPStr SLIT("{-"), pprUnique (getItsUnique other_id), ppPStr SLIT("-}")]
+
+    -- print PprDebug Ids with # afterwards if they are of primitive type.
+    pp_ubxd pretty = pretty
+
+{- LATER: applying isPrimType restricts type
+    pp_ubxd pretty = if isPrimType (idType id)
 		     then ppBeside pretty (ppChar '#')
 		     else pretty
+-}
+
 \end{code}
 
 \begin{code}
-instance NamedThing Id where
-    getExportFlag (Id _ _ _ details)
+instance NamedThing (GenId ty) where
+    getExportFlag (Id _ _ details _ _)
       = get details
       where
-	get (DataConId _ _ _ _ _ tc)= getExportFlag tc -- NB: don't use the FullName
+	get (DataConId _ _ _ _ _ _ tc)= getExportFlag tc -- NB: don't use the FullName
 	get (TupleConId _)	    = NotExported
 	get (ImportedId  n)         = getExportFlag n
 	get (PreludeId   n)         = getExportFlag n
 	get (TopLevId    n)         = getExportFlag n
 	get (SuperDictSelId c _)    = getExportFlag c
-	get (ClassOpId  c _)	    = getExportFlag c
+	get (MethodSelId  c _)	    = getExportFlag c
 	get (DefaultMethodId c _ _) = getExportFlag c
 	get (DictFunId  c ty from_here _) = instance_export_flag c ty from_here
 	get (ConstMethodId c ty _ from_here _) = instance_export_flag c ty from_here
@@ -2098,21 +1844,17 @@ instance NamedThing Id where
 	get (LocalId      _ _)	    = NotExported
 	get (SysLocalId   _ _)	    = NotExported
 	get (SpecPragmaId _ _ _)    = NotExported
-#ifdef DPH
-	get (ProcessorCon _ _)	    = NotExported
-	get (PodId _ _ i)	    = getExportFlag i
-#endif {- Data Parallel Haskell -}
 
-    isLocallyDefined this_id@(Id _ _ _ details)
+    isLocallyDefined this_id@(Id _ _ details _ _)
       = get details
       where
-	get (DataConId _ _ _ _ _ tc)= isLocallyDefined tc -- NB: don't use the FullName
+	get (DataConId _ _ _ _ _ _ tc)= isLocallyDefined tc -- NB: don't use the FullName
 	get (TupleConId _)	    = False
 	get (ImportedId	_)    	    = False
 	get (PreludeId  _)    	    = False
 	get (TopLevId	n)	    = isLocallyDefined n
 	get (SuperDictSelId c _)    = isLocallyDefined c
-	get (ClassOpId c _) 	    = isLocallyDefined c
+	get (MethodSelId c _) 	    = isLocallyDefined c
 	get (DefaultMethodId c _ _) = isLocallyDefined c
 	get (DictFunId c tyc from_here _) = from_here
 	    -- For DictFunId and ConstMethodId things, you really have to
@@ -2126,23 +1868,21 @@ instance NamedThing Id where
 	get (LocalId      _ _)	    = True
 	get (SysLocalId   _ _)	    = True
 	get (SpecPragmaId _ _ _)    = True
-#ifdef DPH
-	get (ProcessorCon _ _)	    = False
-	get (PodId _ _ i)	    = isLocallyDefined i
-#endif {- Data Parallel Haskell -}
 
-    getOrigName this_id@(Id u _ _ details)
+    getOrigName this_id@(Id u _ details _ _)
       = get details
       where
-	get (DataConId n _ _ _ _ _) = getOrigName n
-	get (TupleConId a)	    = (pRELUDE_BUILTIN, SLIT("Tup") _APPEND_ _PK_ (show a))
-	get (ImportedId   n)	    = getOrigName n
-	get (PreludeId    n)	    = getOrigName n
-	get (TopLevId     n)	    = getOrigName n
+	get (DataConId n _ _ _ _ _ _) =	 getOrigName n
+	get (TupleConId 0)	= (pRELUDE_BUILTIN, SLIT("()"))
+	get (TupleConId a)	= (pRELUDE_BUILTIN, _PK_ ( "(" ++ nOfThem (a-1) ',' ++ ")" ))
+	get (ImportedId   n)	= getOrigName n
+	get (PreludeId    n)	= getOrigName n
+	get (TopLevId     n)	= getOrigName n
 
-	get (ClassOpId c op)	    = case (getOrigName c) of -- ToDo; better ???
-					(mod, _) -> (mod, getClassOpString op)
+	get (MethodSelId c op)	= case (getOrigName c) of -- ToDo; better ???
+				    (mod, _) -> (mod, getClassOpString op)
 
+{- LATER:
 	get (SpecId unspec ty_maybes _)
 	  = BIND getOrigName unspec	      _TO_ (mod, unspec_nm) ->
 	    BIND specMaybeTysSuffix ty_maybes _TO_ tys_suffix ->
@@ -2163,29 +1903,16 @@ instance NamedThing Id where
 		 else SLIT(".wrk"))
 	    )
 	    BEND
+-}
 
-	get (InstId inst)
-	  = (panic "NamedThing.Id.getOrigName (InstId)",
-	     BIND (getInstNamePieces True inst)   _TO_ (piece1:pieces) ->
-	     BIND [ _CONS_ '.' p | p <- pieces ]  _TO_ dotted_pieces ->
-	     _CONCAT_ (piece1 : dotted_pieces)
-	     BEND BEND )
-
-	get (LocalId      n _) = (panic "NamedThing.Id.getOrigName (LocalId)",
-				  getLocalName n)
-	get (SysLocalId   n _) = (panic "NamedThing.Id.getOrigName (SysLocal)",
-				  getLocalName n)
-	get (SpecPragmaId n _ _)=(panic "NamedThing.Id.getOrigName (SpecPragmaId)",
-				  getLocalName n)
-#ifdef DPH
-	get (ProcessorCon a _)	    = ("PreludeBuiltin",
-						   "MkProcessor" ++ (show a))
-	get (PodId d ity id)
-	  = BIND (getOrigName id) _TO_ (m,n) ->
-	    (m,n ++ ".mapped.POD"++ show d ++ "." ++ show ity)
-	    BEND
-    -- ToDo(hilly): should the above be using getIdNamePieces???
-#endif {- Data Parallel Haskell -}
+	get (InstId       n)    = (panic "NamedThing.Id.getOrigName (LocalId)",
+				   getLocalName n)
+	get (LocalId      n _)  = (panic "NamedThing.Id.getOrigName (LocalId)",
+				   getLocalName n)
+	get (SysLocalId   n _)  = (panic "NamedThing.Id.getOrigName (SysLocal)",
+				   getLocalName n)
+	get (SpecPragmaId n _ _)= (panic "NamedThing.Id.getOrigName (SpecPragmaId)",
+				   getLocalName n)
 
 	get other_details
 	    -- the remaining internally-generated flavours of
@@ -2197,77 +1924,122 @@ instance NamedThing Id where
 	    (_NIL_, _CONCAT_ (piece1 : dotted_pieces))
 	    BEND BEND
 
-    getOccurrenceName this_id@(Id _ _ _ details)
+    getOccurrenceName this_id@(Id _ _ details _ _)
       = get details
       where
-	get (DataConId  n _ _ _ _ _) = getOccurrenceName n
-	get (TupleConId a)	= SLIT("Tup") _APPEND_ (_PK_ (show a))
+	get (DataConId  n _ _ _ _ _ _) = getOccurrenceName n
+	get (TupleConId 0)	= SLIT("()")
+	get (TupleConId a)	= _PK_ ( "(" ++ nOfThem (a-1) ',' ++ ")" )
 	get (ImportedId	 n)	= getOccurrenceName n
 	get (PreludeId   n)	= getOccurrenceName n
 	get (TopLevId	 n)	= getOccurrenceName n
-	get (ClassOpId _ op)	= getClassOpString op
-#ifdef DPH
-	get (ProcessorCon a _)	= "MkProcessor" ++ (show a)
-	get (PodId _ _ id)	= getOccurrenceName id
-#endif {- Data Parallel Haskell -}
+	get (MethodSelId _ op)	= getClassOpString op
 	get _			= snd (getOrigName this_id)
 
     getInformingModules id = panic "getInformingModule:Id"
 
-    getSrcLoc (Id _ _ id_info details)
+    getSrcLoc (Id _ _ details _ id_info)
       = get details
       where
-	get (DataConId  n _ _ _ _ _) = getSrcLoc n
+	get (DataConId  n _ _ _ _ _ _) = getSrcLoc n
 	get (TupleConId _)	= mkBuiltinSrcLoc
 	get (ImportedId	 n)	= getSrcLoc n
 	get (PreludeId   n)	= getSrcLoc n
 	get (TopLevId	 n)	= getSrcLoc n
 	get (SuperDictSelId c _)= getSrcLoc c
-	get (ClassOpId c _)	= getSrcLoc c
+	get (MethodSelId c _)	= getSrcLoc c
 	get (SpecId unspec _ _)	= getSrcLoc unspec
 	get (WorkerId unwrkr)	= getSrcLoc unwrkr
-	get (InstId	i)	= let (loc,_) = getInstOrigin i
-				  in  loc
+	get (InstId	  n)	= getSrcLoc n
 	get (LocalId      n _)	= getSrcLoc n
 	get (SysLocalId   n _)	= getSrcLoc n
 	get (SpecPragmaId n _ _)= getSrcLoc n
-#ifdef DPH
-	get (ProcessorCon _ _)	= mkBuiltinSrcLoc
-	get (PodId _ _ n)		= getSrcLoc n
-#endif {- Data Parallel Haskell -}
 	-- well, try the IdInfo
 	get something_else = getSrcLocIdInfo id_info
 
-    getTheUnique (Id u _ _ _) = u
+    getItsUnique (Id u _ _ _ _) = u
 
-    fromPreludeCore (Id _ _ _ details)
+    fromPreludeCore (Id _ _ details _ _)
       = get details
       where
-	get (DataConId _ _ _ _ _ tc)= fromPreludeCore tc -- NB: not from the FullName
+	get (DataConId _ _ _ _ _ _ tc)= fromPreludeCore tc -- NB: not from the FullName
 	get (TupleConId _)	    = True
 	get (ImportedId  n)	    = fromPreludeCore n
 	get (PreludeId   n)	    = fromPreludeCore n
 	get (TopLevId    n)	    = fromPreludeCore n
 	get (SuperDictSelId c _)    = fromPreludeCore c
-	get (ClassOpId c _)	    = fromPreludeCore c
+	get (MethodSelId c _)	    = fromPreludeCore c
 	get (DefaultMethodId c _ _) = fromPreludeCore c
 	get (DictFunId	c t _ _)    = fromPreludeCore c && is_prelude_core_ty t
 	get (ConstMethodId c t _ _ _) = fromPreludeCore c && is_prelude_core_ty t
 	get (SpecId unspec _ _)	    = fromPreludeCore unspec
 	get (WorkerId unwrkr)	    = fromPreludeCore unwrkr
-	get (InstId   _)	    = False
+	get (InstId       _)	    = False
 	get (LocalId      _ _)	    = False
 	get (SysLocalId   _ _)	    = False
 	get (SpecPragmaId _ _ _)    = False
-#ifdef DPH			     
-	get (ProcessorCon _ _)	    = True
-	get (PodId _ _ id)	    = fromPreludeCore id
-#endif {- Data Parallel Haskell -}
-
-    hasType id	= True
-    getType id	= getIdUniType id
 \end{code}
 
-Reason for @getTheUnique@: The code generator doesn't carry a
+Reason for @getItsUnique@: The code generator doesn't carry a
 @UniqueSupply@, so it wants to use the @Uniques@ out of local @Ids@
 given to it.
+
+%************************************************************************
+%*									*
+\subsection{@IdEnv@s and @IdSet@s}
+%*									*
+%************************************************************************
+
+\begin{code}
+type IdEnv elt = UniqFM elt
+
+nullIdEnv	  :: IdEnv a
+		  
+mkIdEnv		  :: [(GenId ty, a)] -> IdEnv a
+unitIdEnv	  :: GenId ty -> a -> IdEnv a
+addOneToIdEnv	  :: IdEnv a -> GenId ty -> a -> IdEnv a
+growIdEnv	  :: IdEnv a -> IdEnv a -> IdEnv a
+growIdEnvList	  :: IdEnv a -> [(GenId ty, a)] -> IdEnv a
+		  
+delManyFromIdEnv  :: IdEnv a -> [GenId ty] -> IdEnv a
+delOneFromIdEnv	  :: IdEnv a -> GenId ty -> IdEnv a
+combineIdEnvs	  :: (a -> a -> a) -> IdEnv a -> IdEnv a -> IdEnv a
+mapIdEnv	  :: (a -> b) -> IdEnv a -> IdEnv b
+modifyIdEnv	  :: IdEnv a -> (a -> a) -> GenId ty -> IdEnv a
+rngIdEnv	  :: IdEnv a -> [a]
+		  
+isNullIdEnv	  :: IdEnv a -> Bool
+lookupIdEnv	  :: IdEnv a -> GenId ty -> Maybe a
+lookupNoFailIdEnv :: IdEnv a -> GenId ty -> a
+\end{code}
+
+\begin{code}
+addOneToIdEnv	 = addToUFM
+combineIdEnvs	 = plusUFM_C
+delManyFromIdEnv = delListFromUFM
+delOneFromIdEnv	 = delFromUFM
+growIdEnv	 = plusUFM
+lookupIdEnv	 = lookupUFM
+mapIdEnv	 = mapUFM
+mkIdEnv		 = listToUFM
+nullIdEnv	 = emptyUFM
+rngIdEnv	 = eltsUFM
+unitIdEnv	 = singletonUFM
+
+growIdEnvList	  env pairs = plusUFM env (listToUFM pairs)
+isNullIdEnv	  env	    = sizeUFM env == 0
+lookupNoFailIdEnv env id    = case (lookupIdEnv env id) of { Just xx -> xx }
+
+-- modifyIdEnv: Look up a thing in the IdEnv, then mash it with the
+-- modify function, and put it back.
+
+modifyIdEnv env mangle_fn key
+  = case (lookupIdEnv env key) of
+      Nothing -> env
+      Just xx -> addOneToIdEnv env key (mangle_fn xx)
+\end{code}
+
+\begin{code}
+type GenIdSet ty = UniqSet (GenId ty)
+type IdSet 	 = UniqSet (GenId Type)
+\end{code}
diff --git a/ghc/compiler/basicTypes/IdInfo.hi b/ghc/compiler/basicTypes/IdInfo.hi
deleted file mode 100644
index 55ca664dde..0000000000
--- a/ghc/compiler/basicTypes/IdInfo.hi
+++ /dev/null
@@ -1,142 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface IdInfo where
-import Bag(Bag)
-import BasicLit(BasicLit)
-import BinderInfo(BinderInfo, DuplicationDanger, FunOrArg, InsideSCC)
-import CharSeq(CSeq)
-import CmdLineOpts(GlobalSwitch)
-import CoreSyn(CoreAtom, CoreBinding, CoreCaseAlternatives, CoreExpr)
-import CostCentre(CostCentre)
-import Id(Id)
-import IdEnv(IdEnv(..))
-import InstEnv(InstTemplate)
-import MagicUFs(MagicUnfoldingFun)
-import Maybes(Labda)
-import Outputable(Outputable)
-import PlainCore(PlainCoreAtom(..), PlainCoreExpr(..))
-import PreludePS(_PackedString)
-import Pretty(Delay, PprStyle, Pretty(..), PrettyRep)
-import PrimOps(PrimOp)
-import SimplEnv(FormSummary, IdVal, InExpr(..), OutAtom(..), OutExpr(..), OutId(..), UnfoldingDetails(..), UnfoldingGuidance(..))
-import SrcLoc(SrcLoc)
-import Subst(Subst)
-import TaggedCore(SimplifiableBinder(..), SimplifiableCoreExpr(..))
-import TyVar(TyVar)
-import UniType(UniType)
-import UniqFM(UniqFM)
-import Unique(UniqSM(..), Unique, UniqueSupply)
-class OptIdInfo a where
-	noInfo :: a
-	getInfo :: IdInfo -> a
-	addInfo :: IdInfo -> a -> IdInfo
-	ppInfo :: PprStyle -> (Id -> Id) -> a -> Int -> Bool -> PrettyRep
-data ArgUsage   = ArgUsage Int | UnknownArgUsage
-data ArgUsageInfo 
-type ArgUsageType = [ArgUsage]
-data ArityInfo 
-data Bag a 
-data BasicLit 
-data BinderInfo 
-data CoreAtom a 
-data CoreExpr a b 
-data DeforestInfo   = Don'tDeforest | DoDeforest
-data Demand   = WwLazy Bool | WwStrict | WwUnpack [Demand] | WwPrim | WwEnum
-data DemandInfo 
-data FBConsum   = FBGoodConsum | FBBadConsum
-data FBProd   = FBGoodProd | FBBadProd
-data FBType   = FBType [FBConsum] FBProd
-data FBTypeInfo 
-data Id 
-type IdEnv a = UniqFM a
-data IdInfo 
-data InstTemplate 
-data MagicUnfoldingFun 
-data Labda a 
-type PlainCoreAtom = CoreAtom Id
-type PlainCoreExpr = CoreExpr Id Id
-data PprStyle 
-type Pretty = Int -> Bool -> PrettyRep
-data PrettyRep 
-data FormSummary 
-data IdVal 
-type InExpr = CoreExpr (Id, BinderInfo) Id
-type OutAtom = CoreAtom Id
-type OutExpr = CoreExpr Id Id
-type OutId = Id
-data UnfoldingDetails   = NoUnfoldingDetails | LiteralForm BasicLit | OtherLiteralForm [BasicLit] | ConstructorForm Id [UniType] [CoreAtom Id] | OtherConstructorForm [Id] | GeneralForm Bool FormSummary (CoreExpr (Id, BinderInfo) Id) UnfoldingGuidance | MagicForm _PackedString MagicUnfoldingFun | IWantToBeINLINEd UnfoldingGuidance
-data UnfoldingGuidance   = UnfoldNever | UnfoldAlways | EssentialUnfolding | UnfoldIfGoodArgs Int Int [Bool] Int | BadUnfolding
-data SrcLoc 
-data Subst 
-type SimplifiableBinder = (Id, BinderInfo)
-type SimplifiableCoreExpr = CoreExpr (Id, BinderInfo) Id
-data SpecEnv 
-data SpecInfo   = SpecInfo [Labda UniType] Int Id
-data StrictnessInfo   = NoStrictnessInfo | BottomGuaranteed | StrictnessInfo [Demand] (Labda Id)
-data UniType 
-data UniqFM a 
-type UniqSM a = UniqueSupply -> (UniqueSupply, a)
-data Unique 
-data UniqueSupply 
-data UpdateInfo 
-type UpdateSpec = [Int]
-addInfo_UF :: IdInfo -> UnfoldingDetails -> IdInfo
-addOneToSpecEnv :: SpecEnv -> SpecInfo -> SpecEnv
-applySubstToIdInfo :: Subst -> IdInfo -> (Subst, IdInfo)
-apply_to_IdInfo :: (UniType -> UniType) -> IdInfo -> IdInfo
-arityMaybe :: ArityInfo -> Labda Int
-boringIdInfo :: IdInfo -> Bool
-bottomIsGuaranteed :: StrictnessInfo -> Bool
-getArgUsage :: ArgUsageInfo -> [ArgUsage]
-getFBType :: FBTypeInfo -> Labda FBType
-getInfo_UF :: IdInfo -> UnfoldingDetails
-getSrcLocIdInfo :: IdInfo -> SrcLoc
-getWorkerId :: StrictnessInfo -> Id
-getWrapperArgTypeCategories :: UniType -> StrictnessInfo -> Labda [Char]
-iWantToBeINLINEd :: UnfoldingGuidance -> UnfoldingDetails
-indicatesWorker :: [Demand] -> Bool
-lookupConstMethodId :: Id -> UniType -> Labda Id
-lookupSpecEnv :: SpecEnv -> [UniType] -> Labda (Id, [UniType], Int)
-lookupSpecId :: Id -> [Labda UniType] -> Id
-mkArgUsageInfo :: [ArgUsage] -> ArgUsageInfo
-mkArityInfo :: Int -> ArityInfo
-mkBottomStrictnessInfo :: StrictnessInfo
-mkDemandInfo :: Demand -> DemandInfo
-mkFBTypeInfo :: FBType -> FBTypeInfo
-mkMagicUnfolding :: _PackedString -> UnfoldingDetails
-mkSpecEnv :: [SpecInfo] -> SpecEnv
-mkStrictnessInfo :: [Demand] -> Labda Id -> StrictnessInfo
-mkUnfolding :: UnfoldingGuidance -> CoreExpr Id Id -> UnfoldingDetails
-mkUpdateInfo :: [Int] -> UpdateInfo
-noIdInfo :: IdInfo
-noInfo_UF :: UnfoldingDetails
-nonAbsentArgs :: [Demand] -> Int
-nullSpecEnv :: SpecEnv
-ppIdInfo :: PprStyle -> Id -> Bool -> (Id -> Id) -> UniqFM UnfoldingDetails -> IdInfo -> Int -> Bool -> PrettyRep
-unknownArity :: ArityInfo
-updateInfoMaybe :: UpdateInfo -> Labda [Int]
-willBeDemanded :: DemandInfo -> Bool
-workerExists :: StrictnessInfo -> Bool
-wwEnum :: Demand
-wwLazy :: Demand
-wwPrim :: Demand
-wwStrict :: Demand
-wwUnpack :: [Demand] -> Demand
-instance Eq Demand
-instance Eq FBConsum
-instance Eq FBProd
-instance Eq FBType
-instance Eq UpdateInfo
-instance OptIdInfo ArgUsageInfo
-instance OptIdInfo ArityInfo
-instance OptIdInfo DeforestInfo
-instance OptIdInfo DemandInfo
-instance OptIdInfo FBTypeInfo
-instance OptIdInfo SpecEnv
-instance OptIdInfo StrictnessInfo
-instance OptIdInfo UpdateInfo
-instance Ord Demand
-instance Ord UpdateInfo
-instance Outputable Demand
-instance Text Demand
-instance Text UpdateInfo
-
diff --git a/ghc/compiler/basicTypes/IdInfo.lhs b/ghc/compiler/basicTypes/IdInfo.lhs
index de8ef28571..b2594b3939 100644
--- a/ghc/compiler/basicTypes/IdInfo.lhs
+++ b/ghc/compiler/basicTypes/IdInfo.lhs
@@ -1,5 +1,5 @@
 %
-% (c) The GRASP/AQUA Project, Glasgow University, 1993-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1993-1996
 %
 \section[IdInfo]{@IdInfos@: Non-essential information about @Ids@}
 
@@ -16,10 +16,13 @@ module IdInfo (
 	ppIdInfo,
 	applySubstToIdInfo, apply_to_IdInfo,    -- not for general use, please
 
-	OptIdInfo(..),	-- class; for convenience only, really
-	-- all the *Infos herein are instances of it
+	OptIdInfo(..),	-- class; for convenience only
+			-- all the *Infos herein are instances of it
 
 	-- component "id infos"; also abstract:
+	SrcLoc,
+	getSrcLocIdInfo,
+
 	ArityInfo,
 	mkArityInfo, unknownArity, arityMaybe,
 
@@ -27,17 +30,11 @@ module IdInfo (
 	mkDemandInfo,
 	willBeDemanded,
 
-	SpecEnv, SpecInfo(..),
-	nullSpecEnv, mkSpecEnv, addOneToSpecEnv,
-	lookupSpecId, lookupSpecEnv, lookupConstMethodId,
+	MatchEnv,		-- the SpecEnv
+	StrictnessInfo(..), 	-- non-abstract
+	Demand(..),	    	-- non-abstract
 
-	SrcLoc,
-	getSrcLocIdInfo,
-
-	StrictnessInfo(..), -- non-abstract
-	Demand(..),	    -- non-abstract
 	wwLazy, wwStrict, wwUnpack, wwPrim, wwEnum,
---UNUSED: isStrict, absentArg,
 	indicatesWorker, nonAbsentArgs,
 	mkStrictnessInfo, mkBottomStrictnessInfo,
 	getWrapperArgTypeCategories,
@@ -45,10 +42,7 @@ module IdInfo (
 	workerExists,
 	bottomIsGuaranteed,
 
-	UnfoldingDetails(..),	-- non-abstract! re-exported
-	UnfoldingGuidance(..),	-- non-abstract; ditto
 	mkUnfolding,
-	iWantToBeINLINEd, mkMagicUnfolding,
 	noInfo_UF, getInfo_UF, addInfo_UF, -- to avoid instance virus
 
 	UpdateInfo,
@@ -58,7 +52,7 @@ module IdInfo (
 
 	DeforestInfo(..),
 
-	ArgUsageInfo,	
+	ArgUsageInfo,
 	ArgUsage(..),
 	ArgUsageType(..),
 	mkArgUsageInfo,
@@ -69,53 +63,35 @@ module IdInfo (
 	FBConsum(..),
 	FBProd(..),
 	mkFBTypeInfo,
-	getFBType,
-
-	-- and to make the interface self-sufficient...
-	Bag, BasicLit, BinderInfo, CoreAtom, CoreExpr, Id,
-	IdEnv(..), UniqFM, Unique, IdVal, FormSummary,
-	InstTemplate, MagicUnfoldingFun, Maybe, UniType, UniqSM(..),
-	SimplifiableBinder(..), SimplifiableCoreExpr(..),
-	PlainCoreExpr(..), PlainCoreAtom(..), PprStyle, Pretty(..),
-	PrettyRep, UniqueSupply, InExpr(..), OutAtom(..), OutExpr(..),
-	OutId(..), Subst
-
-	-- and to make sure pragmas work...
-	IF_ATTACK_PRAGMAS(COMMA mkUnknownSrcLoc)
+	getFBType
+
     ) where
 
-IMPORT_Trace		-- ToDo: rm (debugging)
-
-import AbsPrel		( mkFunTy, nilDataCon{-HACK-}
-			  IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
-			  IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
-			)
-import AbsUniType
-import Bag		( emptyBag, Bag )
-import CmdLineOpts	( GlobalSwitch(..) )
-import Id		( getIdUniType, getIdInfo,
-			  getDataConSig, getInstantiatedDataConSig,
-			  externallyVisibleId, isDataCon,
-			  unfoldingUnfriendlyId, isWorkerId,
-			  isWrapperId, DataCon(..)
-			  IF_ATTACK_PRAGMAS(COMMA applyTypeEnvToId)
-			  IF_ATTACK_PRAGMAS(COMMA getIdStrictness) -- profiling
-			)
-import IdEnv		-- ( nullIdEnv, lookupIdEnv )
-import Inst		( apply_to_Inst, applySubstToInst, Inst )
-import MagicUFs
-import Maybes
-import Outputable
-import PlainCore
+import Ubiq
+
+import IdLoop		-- IdInfo is a dependency-loop ranch, and
+			-- we break those loops by using IdLoop and
+			-- *not* importing much of anything else,
+			-- except from the very general "utils".
+
+import CmdLineOpts	( opt_OmitInterfacePragmas )
+import Maybes		( firstJust )
+import MatchEnv		( nullMEnv, mEnvToList )
+import Outputable	( ifPprInterface, Outputable(..){-instances-} )
+import PprStyle		( PprStyle(..) )
 import Pretty
-import SimplEnv		-- UnfoldingDetails(..), UnfoldingGuidance(..)
-import SrcLoc
-import Subst		( applySubstToTy, Subst )
-import OccurAnal	( occurAnalyseGlobalExpr )
-import TaggedCore	-- SimplifiableCore* ...
-import Unique
-import Util
-import WwLib		( mAX_WORKER_ARGS )
+import SrcLoc		( mkUnknownSrcLoc )
+import Type		( eqSimpleTy )
+import Util		( mapAccumL, panic, assertPanic, pprPanic )
+
+applySubstToTy = panic "IdInfo.applySubstToTy"
+isUnboxedDataType = panic "IdInfo.isUnboxedDataType"
+splitTypeWithDictsAsArgs = panic "IdInfo.splitTypeWithDictsAsArgs"
+showTypeCategory = panic "IdInfo.showTypeCategory"
+mkFormSummary = panic "IdInfo.mkFormSummary"
+occurAnalyseGlobalExpr = panic "IdInfo.occurAnalyseGlobalExpr"
+isWrapperFor = panic "IdInfo.isWrapperFor"
+pprCoreUnfolding = panic "IdInfo.pprCoreUnfolding"
 \end{code}
 
 An @IdInfo@ gives {\em optional} information about an @Id@.  If
@@ -138,19 +114,21 @@ data IdInfo
 	DemandInfo		-- Whether or not it is definitely
 				-- demanded
 
-	SpecEnv			-- Specialisations of this function which exist
+	(MatchEnv [Type] CoreExpr)
+				-- Specialisations of this function which exist
+				-- This corresponds to a SpecEnv which we do
+				-- not import directly to avoid loop
 
 	StrictnessInfo		-- Strictness properties, notably
 				-- how to conjure up "worker" functions
 
 	UnfoldingDetails	-- Its unfolding; for locally-defined
 				-- things, this can *only* be NoUnfoldingDetails
-				-- or IWantToBeINLINEd (i.e., INLINE pragma).
 
 	UpdateInfo		-- Which args should be updated
 
-        DeforestInfo            -- Whether its definition should be
-                                -- unfolded during deforestation
+	DeforestInfo            -- Whether its definition should be
+				-- unfolded during deforestation
 
 	ArgUsageInfo		-- how this Id uses its arguments
 
@@ -169,19 +147,21 @@ data IdInfo
 noIdInfo = IdInfo noInfo noInfo noInfo noInfo noInfo_UF
 		  noInfo noInfo noInfo noInfo mkUnknownSrcLoc
 
--- "boring" means: nothing to put an interface
+-- "boring" means: nothing to put in interface
 boringIdInfo (IdInfo UnknownArity
 		     UnknownDemand
-		     nullSpecEnv
+		     specenv
 		     strictness
 		     unfolding
 		     NoUpdateInfo
 		     Don'tDeforest
 		     _ {- arg_usage: currently no interface effect -}
 		     _ {- no f/b w/w -}
-		     _ {- src_loc: no effect on interfaces-})
-		     |  boring_strictness strictness
-		     && boring_unfolding unfolding
+		     _ {- src_loc: no effect on interfaces-}
+	      )
+	      |  null (mEnvToList specenv)
+	      && boring_strictness strictness
+	      && boring_unfolding unfolding
   = True
   where
     boring_strictness NoStrictnessInfo = True
@@ -200,17 +180,18 @@ Simply turgid.  But BE CAREFUL: don't @apply_to_Id@ if that @Id@
 will in turn @apply_to_IdInfo@ of the self-same @IdInfo@.  (A very
 nasty loop, friends...)
 \begin{code}
-apply_to_IdInfo ty_fn
-    (IdInfo arity demand spec strictness unfold update deforest arg_usage fb_ww srcloc)
-  = let
+apply_to_IdInfo ty_fn (IdInfo arity demand spec strictness unfold
+			      update deforest arg_usage fb_ww srcloc)
+  = panic "IdInfo:apply_to_IdInfo"
+{- LATER:
+    let
 	new_spec = apply_spec spec
 
-	-- NOT a good idea: 
+	-- NOT a good idea:
 	--   apply_strict strictness 	`thenLft` \ new_strict ->
 	--   apply_wrap wrap 		`thenLft` \ new_wrap ->
     in
-    IdInfo arity demand
-	   new_spec strictness unfold
+    IdInfo arity demand new_spec strictness unfold
 	   update deforest arg_usage fb_ww srcloc
   where
     apply_spec (SpecEnv is)
@@ -222,6 +203,7 @@ apply_to_IdInfo ty_fn
 	  where
 	    apply_to_maybe Nothing   = Nothing
 	    apply_to_maybe (Just ty) = Just (ty_fn ty)
+-}
 
 {- NOT a good idea;
     apply_strict info@NoStrictnessInfo = returnLft info
@@ -232,20 +214,22 @@ apply_to_IdInfo ty_fn
 	   Just xx -> applySubstToId subst xx `thenLft` \ new_xx ->
 		      returnLft (Just new_xx)
 	) `thenLft` \ new_id_maybe ->
-        returnLft (StrictnessInfo wrap_arg_info new_id_maybe)
+	returnLft (StrictnessInfo wrap_arg_info new_id_maybe)
 -}
 \end{code}
 
 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)
-  = case (apply_spec s0 spec) of { (s1, new_spec) ->
+applySubstToIdInfo s0 (IdInfo arity demand spec strictness unfold
+			      update deforest arg_usage fb_ww srcloc)
+  = 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) }
   where
     apply_spec s0 (SpecEnv is)
       = case (mapAccumL do_one s0 is) of { (s1, new_is) ->
-        (s1, SpecEnv new_is) }
+	(s1, SpecEnv new_is) }
       where
     	do_one s0 (SpecInfo ty_maybes ds spec_id)
 	  = case (mapAccumL apply_to_maybe s0 ty_maybes) of { (s1, new_maybes) ->
@@ -255,6 +239,7 @@ applySubstToIdInfo s0
 	    apply_to_maybe s0 (Just ty)
 	      = case (applySubstToTy s0 ty) of { (s1, new_ty) ->
 		(s1, Just new_ty) }
+-}
 \end{code}
 
 \begin{code}
@@ -268,7 +253,7 @@ ppIdInfo :: PprStyle
 	 -> Pretty
 
 ppIdInfo sty for_this_id specs_please better_id_fn inline_env
-    i@(IdInfo arity demand specialise strictness unfold update deforest arg_usage fbtype srcloc)
+    i@(IdInfo arity demand specenv strictness unfold update deforest arg_usage fbtype srcloc)
   | boringIdInfo i
   = ppPStr SLIT("_NI_")
 
@@ -281,15 +266,15 @@ ppIdInfo sty for_this_id specs_please better_id_fn inline_env
 		    ppInfo sty better_id_fn deforest,
 
 		    pp_strictness sty (Just for_this_id)
-				  better_id_fn inline_env strictness,
+						  better_id_fn inline_env strictness,
 
 		    if bottomIsGuaranteed strictness
 		    then pp_NONE
 		    else pp_unfolding sty for_this_id inline_env unfold,
 
 		    if specs_please
-		    then pp_specs sty (not (isDataCon for_this_id))
-			          better_id_fn inline_env specialise
+		    then ppSpecs sty (not (isDataCon for_this_id))
+				 better_id_fn inline_env (mEnvToList specenv)
 		    else pp_NONE,
 
 		    -- DemandInfo needn't be printed since it has no effect on interfaces
@@ -298,21 +283,10 @@ ppIdInfo sty for_this_id specs_please better_id_fn inline_env
 		]
     in
     case sty of
-      PprInterface sw_chker ->	if sw_chker OmitInterfacePragmas
-				then ppNil
-				else stuff
-      _			    ->	stuff
-\end{code}
-
-\begin{code}
-{- OLD:
-pp_info_op :: String -> Pretty -- like pprNonOp
-
-pp_info_op name
-  = if isAvarop name || isAconop name
-    then ppBesides [ppLparen, ppStr name, ppRparen]
-    else ppStr name
--}
+      PprInterface -> if opt_OmitInterfacePragmas
+		      then ppNil
+		      else stuff
+      _		   -> stuff
 \end{code}
 
 %************************************************************************
@@ -402,7 +376,7 @@ mkDemandInfo :: Demand -> DemandInfo
 mkDemandInfo demand = DemandedAsPer demand
 
 willBeDemanded :: DemandInfo -> Bool
-willBeDemanded (DemandedAsPer demand) = isStrict demand 
+willBeDemanded (DemandedAsPer demand) = isStrict demand
 willBeDemanded _		      = False
 \end{code}
 
@@ -414,12 +388,12 @@ instance OptIdInfo DemandInfo where
 
 {-	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 
+	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
 
-    ppInfo (PprInterface _) _ _	      = ppNil
+    ppInfo PprInterface _ _	      = ppNil
     ppInfo sty _ UnknownDemand	      = ppStr "{-# L #-}"
     ppInfo sty _ (DemandedAsPer info)
       = ppCat [ppStr "{-#", ppStr (showList [info] ""), ppStr "#-}"]
@@ -431,192 +405,22 @@ instance OptIdInfo DemandInfo where
 %*									*
 %************************************************************************
 
-The details of one specialisation, held in an @Id@'s
-@SpecEnv@ are as follows:
-\begin{code}
-data SpecInfo
-  = SpecInfo	[Maybe UniType] -- Instance types; no free type variables in here
-	    	Int		-- No. of dictionaries to eat
-		Id		-- Specialised version
-\end{code}
-
-For example, if \tr{f} has this @SpecInfo@:
-\begin{verbatim}
-	SpecInfo [Just t1, Nothing, Just t3] 2 f'
-\end{verbatim}
-then
-\begin{verbatim}
-	f t1 t2 t3 d1 d2  ===>  f t2
-\end{verbatim}
-The \tr{Nothings} identify type arguments in which the specialised
-version is polymorphic.
+See SpecEnv.lhs
 
 \begin{code}
-data SpecEnv = SpecEnv [SpecInfo]
-
-mkSpecEnv = SpecEnv
-nullSpecEnv = SpecEnv []
-addOneToSpecEnv (SpecEnv xs) x = SpecEnv (x : xs)
-
-lookupConstMethodId :: Id -> UniType -> Maybe Id
-    -- slight variant on "lookupSpecEnv" below
-
-lookupConstMethodId sel_id spec_ty
-  = case (getInfo (getIdInfo sel_id)) of
-      SpecEnv spec_infos -> firstJust (map try spec_infos)
-  where
-    try (SpecInfo (Just ty:nothings) _ const_meth_id)
-      = ASSERT(all nothing_is_nothing nothings)
-	case (cmpUniType True{-properly-} ty spec_ty) of
-	  EQ_ -> Just const_meth_id
-	  _   -> Nothing
-
-    nothing_is_nothing Nothing = True  -- debugging only
-    nothing_is_nothing _       = panic "nothing_is_nothing!"
-
-lookupSpecId :: Id		-- *un*specialised Id
-	     -> [Maybe UniType]	-- types to which it is to be specialised
-	     -> Id		-- specialised Id
-
-lookupSpecId unspec_id ty_maybes
-  = case (getInfo (getIdInfo unspec_id)) of { SpecEnv spec_infos ->
-
-    case (firstJust (map try spec_infos)) of
-      Just id -> id
-      Nothing -> error ("ERROR: There is some confusion about a value specialised to a type;\ndetails follow (and more info in the User's Guide):\n\t"++(ppShow 80 (ppr PprDebug unspec_id)))
-    }
-  where
-    try (SpecInfo template_maybes _ id) 
-	| and (zipWith same template_maybes ty_maybes)
-	&& length template_maybes == length ty_maybes = Just id
-	| otherwise 				      = Nothing
-
-    same Nothing    Nothing    = True
-    same (Just ty1) (Just ty2) = ty1 == ty2
-    same _	    _	       = False
-
-lookupSpecEnv :: SpecEnv
-	      -> [UniType]
-	      -> Maybe (Id,
-			[UniType],
-			Int)
-
-lookupSpecEnv (SpecEnv []) _ = Nothing 	-- rather common case
-
-lookupSpecEnv spec_env [] = Nothing	-- another common case
- 
-	-- This can happen even if there is a non-empty spec_env, because
-	-- of eta reduction.  For example, we might have a defn
-	--
-	--	f = /\a -> \d -> g a d
-	-- which gets transformed to
-	--	f = g
-	--
-	-- Now g isn't applied to any arguments
-
-lookupSpecEnv se@(SpecEnv spec_infos) spec_tys
-  = select_match spec_infos
-  where
-    select_match []		-- no matching spec_infos
-      = Nothing
-    select_match (SpecInfo ty_maybes toss spec_id : rest)
-      = case (match ty_maybes spec_tys) of
-	  Nothing       -> select_match rest
-	  Just tys_left -> select_next [(spec_id,tys_left,toss)] (length tys_left) toss rest
-
-	-- Ambiguity can only arise as a result of specialisations with
-	-- an explicit spec_id. The best match is deemed to be the match
-	-- with least polymorphism i.e. has the least number of tys left.
-	-- This is a non-critical approximation. The only type arguments
-	-- where there may be some discretion is for non-overloaded boxed
-	-- types. Unboxed types must be matched and we insist that we
-	-- always specialise on overloaded types (and discard all the dicts).
-
-    select_next best _ toss []
-      =	case best of
-	    [match] -> Just match	-- Unique best match 
-	    ambig   -> pprPanic "Ambiguous Specialisation:\n"
-				(ppAboves [ppStr "(check specialisations with explicit spec ids)",
-					   ppCat (ppStr "between spec ids:" : 
-						  map (ppr PprDebug) [id | (id, _, _) <- ambig]),
-					   pp_stuff])
-
-    select_next best tnum dnum (SpecInfo ty_maybes toss spec_id : rest)
-      = ASSERT(dnum == toss)
-	case (match ty_maybes spec_tys) of
-	  Nothing       -> select_next best tnum dnum rest
-	  Just tys_left ->
-	     let tys_len = length tys_left in
-	     case _tagCmp tnum tys_len of
-	       _LT -> select_next [(spec_id,tys_left,toss)] tys_len dnum rest	-- better match
-	       _EQ -> select_next ((spec_id,tys_left,toss):best) tnum dnum rest	-- equivalent match
-	       _GT -> select_next best tnum dnum rest				-- worse match
-
-
-    match [{-out of templates-}] [] = Just []
-
-    match (Nothing:ty_maybes) (spec_ty:spec_tys)
-      = case (isUnboxedDataType spec_ty) of
-	  True  -> Nothing	-- Can only match boxed type against
-				-- type argument which has not been
-				-- specialised on
-	  False -> case match ty_maybes spec_tys of
-	             Nothing  -> Nothing
-	             Just tys -> Just (spec_ty:tys)
-
-    match (Just ty:ty_maybes) (spec_ty:spec_tys)
-      = case (cmpUniType True{-properly-} ty spec_ty) of
-	  EQ_   -> match ty_maybes spec_tys
-	  other -> Nothing
-
-    match [] _ = pprPanic "lookupSpecEnv1\n" pp_stuff
-		 -- This is a Real Problem
-
-    match _ [] = pprPanic "lookupSpecEnv2\n" pp_stuff
-		 -- Partial eta abstraction might make this happen;
-		 -- meanwhile let's leave in the check
-
-    pp_stuff = ppAbove (pp_specs PprDebug True (\x->x) nullIdEnv se) (ppr PprDebug spec_tys)
-\end{code}
-
-
-\begin{code}
-instance OptIdInfo SpecEnv where
-    noInfo = nullSpecEnv
+instance OptIdInfo (MatchEnv [Type] CoreExpr) where
+    noInfo = nullMEnv
 
     getInfo (IdInfo _ _ spec _ _ _ _ _ _ _) = spec
 
-    addInfo (IdInfo a b (SpecEnv old_spec) d e f g h i j) (SpecEnv new_spec)
-	= IdInfo a b (SpecEnv (new_spec ++ old_spec)) d e f g h i j
-	-- We *add* the new specialisation info rather than just replacing it
-	-- so that we don't lose old specialisation details.
-
-    ppInfo sty better_id_fn spec_env
-      = pp_specs sty True better_id_fn nullIdEnv spec_env
-
-pp_specs sty _ _ _ (SpecEnv [])  = pp_NONE
-pp_specs sty print_spec_ids better_id_fn inline_env (SpecEnv specs)
-  = ppBeside (ppPStr SLIT("_SPECIALISE_ ")) (pp_the_list [
-       ppCat [ppLbrack, ppIntersperse pp'SP{-'-} (map pp_maybe ty_maybes), ppRbrack,
-	      ppInt numds,
-	      let
-		 better_spec_id = better_id_fn spec_id
-		 spec_id_info = getIdInfo better_spec_id
-	      in
-	      if not print_spec_ids || boringIdInfo spec_id_info then
-		 ppNil
-	      else
-		 ppCat [ppChar '{',
-			ppIdInfo sty better_spec_id True{-wrkr specs too!-} better_id_fn inline_env spec_id_info,
-			ppChar '}']
-	     ]
-       | (SpecInfo ty_maybes numds spec_id) <- specs ])
-  where
-    pp_the_list [p]    = p
-    pp_the_list (p:ps) = ppBesides [p, pp'SP{-'-}, pp_the_list ps]
+    addInfo id_info spec | null (mEnvToList 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
 
-    pp_maybe Nothing  = ifPprInterface sty pp_NONE
-    pp_maybe (Just t) = pprParendUniType sty t
+    ppInfo sty better_id_fn spec
+      = ppSpecs sty True better_id_fn nullIdEnv (mEnvToList spec)
+
+ppSpecs sty print_spec_id_info better_id_fn inline_env spec_env
+  = panic "IdInfo:ppSpecs"
 \end{code}
 
 %************************************************************************
@@ -698,7 +502,7 @@ bottomIsGuaranteed BottomGuaranteed = True
 bottomIsGuaranteed other    	    = False
 
 getWrapperArgTypeCategories
-	:: UniType		-- wrapper's type
+	:: Type		-- wrapper's type
 	-> StrictnessInfo	-- strictness info about its args
 	-> Maybe String
 
@@ -731,13 +535,6 @@ isStrict WwPrim		= True
 isStrict WwEnum		= True
 isStrict _		= False
 
-{- UNUSED:
-absentArg :: Demand -> Bool
-
-absentArg (WwLazy absentp) = absentp
-absentArg other		   = False
--}
-
 nonAbsentArgs :: [Demand] -> Int
 
 nonAbsentArgs cmpts
@@ -748,7 +545,7 @@ nonAbsentArgs cmpts
 
 all_present_WwLazies :: [Demand] -> Bool
 all_present_WwLazies infos
-  = and (map is_L 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)
@@ -764,7 +561,7 @@ or an Absent {\em that we accept}.
 indicatesWorker :: [Demand] -> Bool
 
 indicatesWorker dems
-  = fake_mk_ww (mAX_WORKER_ARGS - nonAbsentArgs dems) dems
+  = fake_mk_ww (_trace "mAX_WORKER_ARGS" 6 - nonAbsentArgs dems) dems
   where
     fake_mk_ww _ [] = False
     fake_mk_ww _ (WwLazy True : _) = True -- we accepted an Absent
@@ -779,9 +576,9 @@ indicatesWorker dems
 
 \begin{code}
 mkWrapperArgTypeCategories
-	:: UniType		-- wrapper's type
+	:: Type		-- wrapper's type
 	-> [Demand]	-- info about its arguments
-	-> String		-- a string saying lots about the args
+	-> String	-- a string saying lots about the args
 
 mkWrapperArgTypeCategories wrapper_ty wrap_info
   = case (splitTypeWithDictsAsArgs wrapper_ty) of { (_,arg_tys,_) ->
@@ -880,9 +677,8 @@ pp_strictness sty for_this_id_maybe better_id_fn inline_env
 		  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]) (
+				-- pprTrace "IdInfo: unworker-ising:" (ppCat [ppr PprDebug have_wrkr, ppr PprDebug id]) $
 				map un_workerise wrapper_args
-				-- )
 			     else
 				wrapper_args
 
@@ -891,10 +687,7 @@ pp_strictness sty for_this_id_maybe better_id_fn inline_env
 	      Nothing -> False
 	      Just id -> isWorkerId id
 
-	am_printing_iface
-	  = case sty of
-	      PprInterface _ -> True
-	      _ -> False
+	am_printing_iface = case sty of { PprInterface -> True ; _ -> False }
 
 	pp_basic_info
 	  = ppBesides [ppStr "_S_ \"",
@@ -931,39 +724,26 @@ pp_strictness sty for_this_id_maybe better_id_fn inline_env
 %************************************************************************
 
 \begin{code}
-mkUnfolding	 :: UnfoldingGuidance -> PlainCoreExpr -> UnfoldingDetails
-iWantToBeINLINEd :: UnfoldingGuidance -> UnfoldingDetails
-mkMagicUnfolding :: FAST_STRING -> UnfoldingDetails
-
 mkUnfolding guide expr
-  = GeneralForm False (mkFormSummary NoStrictnessInfo expr) 
+  = GenForm False (mkFormSummary NoStrictnessInfo expr)
 	(BSCC("OccurExpr") occurAnalyseGlobalExpr expr ESCC)
 	guide
 \end{code}
 
-\begin{code}
-iWantToBeINLINEd guide = IWantToBeINLINEd guide
-
-mkMagicUnfolding tag  = MagicForm tag (mkMagicUnfoldingFun tag)
-
-\end{code}
-
 \begin{code}
 noInfo_UF = NoUnfoldingDetails
 
 getInfo_UF (IdInfo _ _ _ _ unfolding _ _ _ _ _)
   = case unfolding of
-      NoUnfoldingDetails 	     -> NoUnfoldingDetails
-      GeneralForm _ _ _ BadUnfolding -> NoUnfoldingDetails
-      unfold_ok 		     -> unfold_ok
+      GenForm _ _ _ BadUnfolding -> NoUnfoldingDetails
+      unfolding_as_was 		     -> unfolding_as_was
 
 -- getInfo_UF ensures that any BadUnfoldings are never returned
 -- We had to delay the test required in TcPragmas until now due
 -- to strictness constraints in TcPragmas
 
 addInfo_UF id_info@(IdInfo a b c d e f g h i j) NoUnfoldingDetails = id_info
-addInfo_UF (IdInfo a b d e xxx f g h i j) uf = IdInfo a b d e uf f g h i j
-
+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}
@@ -974,17 +754,12 @@ pp_unfolding sty for_this_id inline_env uf_details
   where
     pp NoUnfoldingDetails = pp_NONE
 
-    pp (IWantToBeINLINEd guide) -- not in interfaces
-      = if isWrapperId for_this_id
-        then pp_NONE -- wrapper: don't complain or mutter
-	else ppCat [ppStr "{-IWantToBeINLINEd", ppr sty guide, ppStr "-}", pp_NONE]
-
     pp (MagicForm tag _)
       = ppCat [ppPStr SLIT("_MF_"), ppPStr tag]
 
-    pp (GeneralForm _ _ _ BadUnfolding) = pp_NONE
+    pp (GenForm _ _ _ BadUnfolding) = pp_NONE
 
-    pp (GeneralForm _ _ template guide)
+    pp (GenForm _ _ template guide)
       = let
 	    untagged = unTagBinders template
 	in
@@ -1068,7 +843,7 @@ instance OptIdInfo DeforestInfo where
     getInfo (IdInfo _ _ _ _ _ _ deforest _ _ _) = deforest
 
     addInfo id_info Don'tDeforest = id_info
-    addInfo (IdInfo a b d e f g _ h i j) deforest = 
+    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
@@ -1111,8 +886,8 @@ instance OptIdInfo ArgUsageInfo where
     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 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)
 
@@ -1120,7 +895,7 @@ instance OptIdInfo ArgUsageInfo where
 ppArgUsage (ArgUsage n)      = ppInt n
 ppArgUsage (UnknownArgUsage) = ppChar '-'
 
-ppArgUsageType aut = ppBesides 
+ppArgUsageType aut = ppBesides
 	[ ppChar '"' ,
 	  ppIntersperse ppComma (map ppArgUsage aut),
 	  ppChar '"' ]
@@ -1160,16 +935,16 @@ instance OptIdInfo FBTypeInfo where
     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
 
-    ppInfo (PprInterface _) better_id_fn NoFBTypeInfo = ppNil
-    ppInfo sty better_id_fn NoFBTypeInfo	= ifPprInterface sty pp_NONE
-    ppInfo sty better_id_fn (SomeFBTypeInfo (FBType cons prod))
+    ppInfo PprInterface _ NoFBTypeInfo = ppNil
+    ppInfo sty 		_ NoFBTypeInfo = ifPprInterface sty pp_NONE
+    ppInfo 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 
+ppFBType cons prod = ppBesides
 	([ ppChar '"' ] ++ map ppCons cons ++ [ ppChar '-', ppProd prod, ppChar '"' ])
   where
 	ppCons FBGoodConsum = ppChar 'G'
diff --git a/ghc/compiler/basicTypes/IdLoop.lhi b/ghc/compiler/basicTypes/IdLoop.lhi
new file mode 100644
index 0000000000..7cc2c6368c
--- /dev/null
+++ b/ghc/compiler/basicTypes/IdLoop.lhi
@@ -0,0 +1,76 @@
+Breaks the IdInfo/<everything> loops.
+
+\begin{code}
+interface IdLoop where
+
+import PreludePS	( _PackedString )
+import PreludeStdIO	( Maybe )
+
+import BinderInfo	( BinderInfo )
+import CoreSyn		( CoreExpr(..), GenCoreExpr, GenCoreArg )
+import CoreUnfold 	( FormSummary(..), UnfoldingDetails(..), UnfoldingGuidance(..) )
+import CoreUtils	( unTagBinders )
+import Id		( externallyVisibleId, isDataCon, isWorkerId, isWrapperId,
+			  unfoldingUnfriendlyId, getIdInfo,
+			  nullIdEnv, lookupIdEnv, IdEnv(..),
+			  Id(..), GenId
+			)
+import IdInfo		( IdInfo )
+import Literal		( Literal )
+import MagicUFs		( MagicUnfoldingFun )
+import Outputable	( Outputable(..) )
+import PprStyle		( PprStyle )
+import PprType		( pprParendType )
+import Pretty		( PrettyRep )
+import Type		( GenType )
+import TyVar		( GenTyVar )
+import UniqFM		( UniqFM )
+import Unique		( Unique )
+import Usage		( GenUsage )
+import Util		( Ord3(..) )
+import WwLib		( mAX_WORKER_ARGS )
+
+externallyVisibleId	:: Id	    -> Bool
+isDataCon		:: GenId ty -> Bool
+isWorkerId		:: GenId ty -> Bool
+isWrapperId		:: Id	    -> Bool
+unfoldingUnfriendlyId	:: Id	    -> Bool
+getIdInfo		:: Id	    -> IdInfo
+nullIdEnv		:: UniqFM a
+lookupIdEnv		:: UniqFM b -> GenId a -> Maybe b
+mAX_WORKER_ARGS		:: Int
+pprParendType		:: (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
+
+type IdEnv a = UniqFM a
+type CoreExpr = GenCoreExpr (GenId (GenType (GenTyVar (GenUsage Unique)) Unique))
+			    (GenId (GenType (GenTyVar (GenUsage Unique)) Unique))
+			    (GenTyVar (GenUsage Unique)) Unique
+
+instance Outputable UnfoldingGuidance
+instance Eq	    Unique
+instance Outputable Unique
+instance Eq	    (GenTyVar a)
+instance Ord3	    (GenTyVar a)
+instance Outputable (GenTyVar a)
+instance (Outputable a) => Outputable (GenId a)
+instance (Eq a, Outputable a, Eq b, Outputable b) => Outputable (GenType a b)
+
+data MagicUnfoldingFun
+data FormSummary   = WhnfForm | BottomForm | OtherForm
+data UnfoldingDetails
+  = NoUnfoldingDetails
+  | LitForm Literal
+  | OtherLitForm [Literal]
+  | ConForm (GenId (GenType (GenTyVar (GenUsage Unique)) Unique)) [GenCoreArg (GenId (GenType (GenTyVar (GenUsage Unique)) Unique)) (GenTyVar (GenUsage Unique)) Unique]
+  | OtherConForm [GenId (GenType (GenTyVar (GenUsage Unique)) Unique)]
+  | GenForm Bool FormSummary (GenCoreExpr (GenId (GenType (GenTyVar (GenUsage Unique)) Unique), BinderInfo) (GenId (GenType (GenTyVar (GenUsage Unique)) Unique)) (GenTyVar (GenUsage Unique)) Unique) UnfoldingGuidance
+  | MagicForm _PackedString MagicUnfoldingFun
+
+data UnfoldingGuidance
+  = UnfoldNever
+  | UnfoldAlways
+  | EssentialUnfolding
+  | UnfoldIfGoodArgs Int Int [Bool] Int
+  | BadUnfolding
+\end{code}
diff --git a/ghc/compiler/basicTypes/IdUtils.lhs b/ghc/compiler/basicTypes/IdUtils.lhs
new file mode 100644
index 0000000000..d5071b0858
--- /dev/null
+++ b/ghc/compiler/basicTypes/IdUtils.lhs
@@ -0,0 +1,98 @@
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+%
+\section[IdUtils]{Constructing PrimOp Ids}
+
+\begin{code}
+#include "HsVersions.h"
+
+module IdUtils ( primOpNameInfo, primOpId ) where
+
+import Ubiq
+import PrelLoop		-- here for paranoia checking
+
+import CoreSyn
+import CoreUnfold	( UnfoldingGuidance(..) )
+import Id		( mkPreludeId )
+import IdInfo		-- quite a few things
+import Name		( Name(..) )
+import NameTypes	( mkPreludeCoreName )
+import PrelMods		( pRELUDE_BUILTIN )
+import PrimOp		( primOpInfo, tagOf_PrimOp, primOp_str,
+			  PrimOpInfo(..), PrimOpResultInfo(..)
+			)
+import Type		( mkForAllTys, mkFunTys, applyTyCon )
+import TysWiredIn	( boolTy )
+import Unique		( mkPrimOpIdUnique )
+import Util		( panic )
+\end{code}
+
+\begin{code}
+primOpNameInfo :: PrimOp -> (FAST_STRING, Name)
+primOpId       :: PrimOp -> Id
+
+primOpNameInfo op = (primOp_str  op, WiredInVal (primOpId op))
+
+primOpId op
+  = case (primOpInfo op) of
+      Dyadic str ty ->
+	mk_prim_Id op pRELUDE_BUILTIN str [] [ty,ty] (dyadic_fun_ty ty) 2
+
+      Monadic str ty ->
+	mk_prim_Id op pRELUDE_BUILTIN str [] [ty] (monadic_fun_ty ty) 1
+
+      Compare str ty ->
+	mk_prim_Id op pRELUDE_BUILTIN str [] [ty,ty] (compare_fun_ty ty) 2
+
+      Coerce str ty1 ty2 ->
+	mk_prim_Id op pRELUDE_BUILTIN str [] [ty1] (mkFunTys [ty1] ty2) 1
+
+      PrimResult str tyvars arg_tys prim_tycon kind res_tys ->
+	mk_prim_Id op pRELUDE_BUILTIN 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 pRELUDE_BUILTIN str
+	    tyvars
+	    arg_tys
+	    (mkForAllTys tyvars (mkFunTys arg_tys (applyTyCon tycon res_tys)))
+	    (length arg_tys) -- arity
+  where
+    mk_prim_Id prim_op mod name tyvar_tmpls arg_tys ty arity
+      = mkPreludeId
+	    (mkPrimOpIdUnique (IBOX(tagOf_PrimOp prim_op)))
+	    (mkPreludeCoreName mod name)
+	    ty
+	    (noIdInfo
+		`addInfo` (mkArityInfo arity)
+		`addInfo_UF` (mkUnfolding EssentialUnfolding
+				(mk_prim_unfold prim_op tyvar_tmpls arg_tys)))
+\end{code}
+
+
+\begin{code}
+dyadic_fun_ty  ty = mkFunTys [ty, ty] ty
+monadic_fun_ty ty = mkFunTys [ty] 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 tvs arg_tys
+  = panic "IdUtils.mk_prim_unfold"
+{-
+  = let
+	(inst_env, tyvars, tyvar_tys) = instantiateTyVars tvs (map getItsUnique tvs)
+	inst_arg_tys		      = map (instantiateTauTy inst_env) arg_tys
+	vars	    		      = mkTemplateLocals inst_arg_tys
+    in
+    mkLam tyvars vars (Prim prim_op tyvar_tys [VarArg v | v <- vars])
+-}
+\end{code}
+
diff --git a/ghc/compiler/basicTypes/Inst.hi b/ghc/compiler/basicTypes/Inst.hi
deleted file mode 100644
index b7968b20b4..0000000000
--- a/ghc/compiler/basicTypes/Inst.hi
+++ /dev/null
@@ -1,68 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface Inst where
-import Class(Class, ClassOp)
-import HsBinds(Binds)
-import HsExpr(ArithSeqInfo, Expr, Qual, RenamedArithSeqInfo(..), RenamedExpr(..))
-import HsLit(Literal)
-import HsMatches(Match)
-import HsPat(InPat, RenamedPat(..))
-import HsTypes(PolyType)
-import Id(Id)
-import IdInfo(SpecEnv)
-import InstEnv(ClassInstEnv(..), InstTemplate, InstanceMapper(..), MatchEnv(..))
-import Maybes(Labda)
-import Name(Name)
-import NameTypes(FullName, ShortName)
-import Outputable(Outputable)
-import PreludePS(_PackedString)
-import PreludeRatio(Ratio(..))
-import Pretty(PprStyle, PrettyRep)
-import PrimKind(PrimKind)
-import SrcLoc(SrcLoc)
-import Subst(Subst)
-import TyCon(TyCon)
-import TyVar(TyVar, TyVarTemplate)
-import UniType(UniType)
-import Unique(Unique)
-data Class 
-data ClassOp 
-data ArithSeqInfo a b 
-data Expr a b 
-data Inst   = Dict Unique Class UniType InstOrigin | Method Unique Id [UniType] InstOrigin | LitInst Unique OverloadedLit UniType InstOrigin
-data InstOrigin   = OccurrenceOf Id SrcLoc | InstanceDeclOrigin SrcLoc | LiteralOrigin Literal SrcLoc | ArithSeqOrigin (ArithSeqInfo Name (InPat Name)) SrcLoc | SignatureOrigin | ClassDeclOrigin SrcLoc | DerivingOrigin (Class -> ([(UniType, InstTemplate)], ClassOp -> SpecEnv)) Class Bool TyCon SrcLoc | InstanceSpecOrigin (Class -> ([(UniType, InstTemplate)], ClassOp -> SpecEnv)) Class UniType SrcLoc | DefaultDeclOrigin SrcLoc | ValSpecOrigin Name SrcLoc | CCallOrigin SrcLoc [Char] (Labda (Expr Name (InPat Name))) | LitLitOrigin SrcLoc [Char] | UnknownOrigin
-data OverloadedLit   = OverloadedIntegral Integer Id Id | OverloadedFractional (Ratio Integer) Id
-type RenamedArithSeqInfo = ArithSeqInfo Name (InPat Name)
-type RenamedExpr = Expr Name (InPat Name)
-data Literal 
-data InPat a 
-type RenamedPat = InPat Name
-data Id 
-type ClassInstEnv = [(UniType, InstTemplate)]
-data InstTemplate 
-type InstanceMapper = Class -> ([(UniType, InstTemplate)], ClassOp -> SpecEnv)
-type MatchEnv a b = [(a, b)]
-data Name 
-data PrimKind 
-data SrcLoc 
-data Subst 
-data TyCon 
-data TyVar 
-data TyVarTemplate 
-data UniType 
-data Unique 
-applySubstToInst :: Subst -> Inst -> (Subst, Inst)
-apply_to_Inst :: (UniType -> UniType) -> Inst -> Inst
-extractConstrainedTyVarsFromInst :: Inst -> [TyVar]
-extractTyVarsFromInst :: Inst -> [TyVar]
-getDictClassAndType :: Inst -> (Class, UniType)
-getInstOrigin :: Inst -> (SrcLoc, PprStyle -> Int -> Bool -> PrettyRep)
-getInstUniType :: Inst -> UniType
-instBindingRequired :: Inst -> Bool
-instCanBeGeneralised :: Inst -> Bool
-isTyVarDict :: Inst -> Bool
-matchesInst :: Inst -> Inst -> Bool
-mkDict :: Unique -> Class -> UniType -> InstOrigin -> Inst
-mkLitInst :: Unique -> OverloadedLit -> UniType -> InstOrigin -> Inst
-mkMethod :: Unique -> Id -> [UniType] -> InstOrigin -> Inst
-instance Outputable Inst
-
diff --git a/ghc/compiler/basicTypes/Inst.lhs b/ghc/compiler/basicTypes/Inst.lhs
deleted file mode 100644
index 82c1b9c20a..0000000000
--- a/ghc/compiler/basicTypes/Inst.lhs
+++ /dev/null
@@ -1,391 +0,0 @@
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
-%
-\section[Inst]{The @Inst@ type: dictionaries or method instances}
-
-\begin{code}
-#include "HsVersions.h"
-
-module Inst (
-	Inst(..), InstOrigin(..), OverloadedLit(..),
-
-	mkDict, mkMethod, mkLitInst,
-	getInstUniType,
---UNUSED:	getInstLocalName,
-	getInstOrigin, getDictClassAndType,
---UNUSED:	instantiateInst,
-	applySubstToInst,
-	apply_to_Inst,	-- not for general use, please
-	extractTyVarsFromInst, extractConstrainedTyVarsFromInst,
-	matchesInst,
-	isTyVarDict,
---UNUSED: isNullaryTyConDict,
-	instBindingRequired, instCanBeGeneralised,
-	
-	-- and to make the interface self-sufficient...
-	Class, ClassOp, ArithSeqInfo, RenamedArithSeqInfo(..),
-	Literal, InPat, RenamedPat(..), Expr, RenamedExpr(..),
-	Id, Name, SrcLoc, Subst, PrimKind,
-	TyVar, TyVarTemplate, TyCon, UniType, Unique, InstTemplate,
-	InstanceMapper(..), ClassInstEnv(..), MatchEnv(..)
-	
-	IF_ATTACK_PRAGMAS(COMMA isTyVarTy)
-    ) where
-
-import AbsSyn
-import AbsUniType
-import Id		( eqId, applySubstToId,
-			  getInstNamePieces, getIdUniType,
-			  Id
-			)
-import InstEnv
-import ListSetOps
-import Maybes		( Maybe(..) )
-import Outputable
-import Pretty
-import SrcLoc		( mkUnknownSrcLoc, SrcLoc )
-import Subst		( applySubstToTy, Subst )
-import Util
-\end{code}
-
-
-%************************************************************************
-%*									*
-\subsection[Inst-types]{@Inst@ types}
-%*									*
-%************************************************************************
-
-An @Inst@ is either a dictionary, an instance of an overloaded
-literal, or an instance of an overloaded value.  We call the latter a
-``method'' even though it may not correspond to a class operation.
-For example, we might have an instance of the @double@ function at
-type Int, represented by
-
-	Method 34 doubleId [Int] origin
-
-\begin{code}
-data Inst	
-  = Dict
-	Unique
-	Class		-- The type of the dict is (c t), where
-	UniType		-- c is the class and t the unitype;
-	InstOrigin
-
-  | Method
-	Unique
-	Id		-- (I expect) be a global, local, or ClassOpId.
-			-- Inside instance decls (only) it can also be an InstId!
-			-- The id needn't be completely polymorphic,
-	[UniType]	-- The types to which its polymorphic tyvars
-			--	should be instantiated
-			--	These types may not saturate the Id's foralls.
-	InstOrigin
-
-  | LitInst
-	Unique
-	OverloadedLit
-	UniType		-- the type at which the literal is used
-	InstOrigin	-- always a literal; but more convenient to carry this around
-
-mkDict	 = Dict
-mkMethod = Method
-mkLitInst= LitInst
-
-data OverloadedLit
-  = OverloadedIntegral	 Integer	-- the number
-			 Id Id		-- cached fromInt, fromInteger
-  | OverloadedFractional Rational	-- the number
-			 Id		-- cached fromRational
-
-{- UNUSED:
-getInstLocalName (Dict _ clas _ _) = getLocalName clas
-getInstLocalName (Method _ id _ _) = getLocalName id
--}
-
--- this is used for error messages
-getDictClassAndType :: Inst -> (Class, UniType)
-getDictClassAndType (Dict _ clas ty _)  = (clas, ty)
-
-getInstUniType :: Inst -> UniType
-getInstUniType (Dict _ clas ty _)  = mkDictTy clas ty
-getInstUniType (LitInst _ _ ty _)  = ty
-getInstUniType (Method _ id tys _)
-  = instantiateTauTy (tyvars `zip` tys) tau_ty 
-  where
-    (tyvars, theta, tau_ty) = splitType (getIdUniType id)
-	-- Note that we ignore the overloading; this is
-	-- an INSTANCE of an overloaded operation
-\end{code}
-
-@applySubstToInst@ doesn't make any assumptions, but @instantiateInst@
-assumes that the @Id@ in a @Method@ is fully polymorphic (ie has no free
-tyvars)
-
-\begin{code}
-{- UNUSED:
-instantiateInst :: [(TyVarTemplate, UniType)] -> Inst -> Inst
-
-instantiateInst tenv (Dict uniq clas ty orig)  
-  = Dict uniq clas (instantiateTy tenv ty) orig
-
-instantiateInst tenv (Method uniq id tys orig) 
-  = --False:ASSERT(idHasNoFreeTyVars id)
-    Method uniq id (map (instantiateTy tenv) tys) orig
-
-instantiateInst tenv (LitInst u lit ty orig)
-  = LitInst u lit (instantiateTy tenv ty) orig
--}
-
------------------------------------------------------------------
--- too bad we can't use apply_to_Inst
-
-applySubstToInst subst (Dict uniq clas ty orig) 
-  = case (applySubstToTy subst ty) of { (s2, new_ty) ->
-    (s2, Dict uniq clas new_ty orig) }
-
-applySubstToInst subst (Method uniq id tys orig) 
-  -- NB: *must* zap "id" in the typechecker
-  = case (applySubstToId subst id)  	    of { (s2, new_id)  ->
-    case (mapAccumL applySubstToTy s2 tys)  of { (s3, new_tys) ->
-    (s3, Method uniq new_id new_tys orig) }}
-
-applySubstToInst subst (LitInst u lit ty orig)
-  = case (applySubstToTy subst ty) of { (s2, new_ty) ->
-    (s2, LitInst u lit new_ty orig) }
-
------------------------------------------------------------------
-apply_to_Inst :: (UniType -> UniType) -> Inst -> Inst
-
-apply_to_Inst ty_fn (Dict uniq clas ty orig) 
-  = Dict uniq clas (ty_fn ty) orig
-
-apply_to_Inst ty_fn (Method uniq id tys orig) 
-  = --FALSE: ASSERT(idHasNoFreeTyVars id)
-    Method uniq id (map ty_fn tys) orig
-
-apply_to_Inst ty_fn (LitInst u lit ty orig)
-  = LitInst u lit (ty_fn ty) orig
-\end{code}
-
-\begin{code}
-extractTyVarsFromInst, extractConstrainedTyVarsFromInst :: Inst -> [TyVar]
-
-extractTyVarsFromInst (Dict _ _ ty _)    = extractTyVarsFromTy  ty
-extractTyVarsFromInst (Method _ _ tys _) = extractTyVarsFromTys tys
-extractTyVarsFromInst (LitInst _ _ ty _) = extractTyVarsFromTy  ty
-
-extractConstrainedTyVarsFromInst (Dict _ _ ty _)    = extractTyVarsFromTy  ty
-extractConstrainedTyVarsFromInst (LitInst _ _ ty _) = extractTyVarsFromTy  ty
-
--- `Method' is different!
-extractConstrainedTyVarsFromInst (Method _ m tys _)
-  = foldr unionLists [] (zipWith xxx tvs tys)
-  where
-    (tvs,theta,tau_ty) = splitType (getIdUniType m)
-
-    constrained_tvs
-      = foldr unionLists [] [extractTyVarTemplatesFromTy t | (_,t) <- theta ]
-
-    xxx tv ty | tv `elem` constrained_tvs = extractTyVarsFromTy ty
-	      | otherwise	          = []
-\end{code}
-
-@matchesInst@ checks when two @Inst@s are instances of the same
-thing at the same type, even if their uniques differ.
-
-\begin{code}
-matchesInst :: Inst -> Inst -> Bool
-matchesInst (Dict _ clas1 ty1 _) (Dict _ clas2 ty2 _)
-  = clas1 == clas2 && ty1 == ty2
-matchesInst (Method _ id1 tys1 _) (Method _ id2 tys2 _)
-  = id1 `eqId` id2 && tys1 == tys2
-matchesInst (LitInst _ lit1 ty1 _) (LitInst _ lit2 ty2 _)
-  = lit1 `eq` lit2 && ty1 == ty2
-  where
-    (OverloadedIntegral   i1 _ _) `eq` (OverloadedIntegral   i2 _ _) = i1 == i2
-    (OverloadedFractional f1 _)   `eq` (OverloadedFractional f2 _)   = f1 == f2
-    _			          `eq` _			     = False
-    
-matchesInst other1 other2 = False
-\end{code}
-
-
-\begin{code}
-isTyVarDict :: Inst -> Bool
-isTyVarDict (Dict _ _ ty _) = isTyVarTy ty
-isTyVarDict other 	    = False
-
-{- UNUSED:
-isNullaryTyConDict :: Inst -> Bool
-isNullaryTyConDict (Dict _ _ ty _)
-  = case (getUniDataTyCon_maybe ty) of
-      Just (tycon, [], _)   -> True		-- NB null args to tycon
-      other 		    -> False
--}
-\end{code}
-
-Two predicates which deal with the case where 
-class constraints don't necessarily result in bindings.
-The first tells whether an @Inst@ must be witnessed by an
-actual binding; the second tells whether an @Inst@ can be
-generalised over.
-
-\begin{code}
-instBindingRequired :: Inst -> Bool
-instBindingRequired inst
-  = case get_origin_really inst of
-	CCallOrigin _ _ _ -> False	-- No binding required
-	LitLitOrigin  _ _ -> False
-	other             -> True
-
-instCanBeGeneralised :: Inst -> Bool
-instCanBeGeneralised inst
-  = case get_origin_really inst of
-	CCallOrigin _ _ _ -> False	-- Can't be generalised
-	LitLitOrigin  _ _ -> False	-- Can't be generalised
-	other             -> True
-\end{code}
-
-ToDo: improve these pretty-printing things.  The ``origin'' is really only
-relevant in error messages.
-
-\begin{code}
--- ToDo: this instance might be nukable (maybe not: used for error msgs)
-
-instance Outputable Inst where
-    ppr PprForUser (LitInst _ lit _ _)
-      = case lit of
-	  OverloadedIntegral   i _ _ -> ppInteger i
-#if __GLASGOW_HASKELL__ <= 22
-	  OverloadedFractional f _   -> ppDouble (fromRational f) -- ToDo: better
-#else
-	  OverloadedFractional f _   -> ppRational f
-#endif
-
-    ppr sty inst
-      = ppIntersperse (ppChar '.') (map ppPStr (getInstNamePieces True inst))
-\end{code}
-  
-
-%************************************************************************
-%*									*
-\subsection[Inst-origin]{The @InstOrigin@ type}
-%*									*
-%************************************************************************
-
-The @InstOrigin@ type gives information about where a dictionary came from.
-This is important for decent error message reporting because dictionaries
-don't appear in the original source code.  Doubtless this type will evolve...
-
-\begin{code}
-data InstOrigin
-  = OccurrenceOf	Id	-- Occurrence of an overloaded identifier
-			SrcLoc
-
-  | InstanceDeclOrigin	SrcLoc	-- Typechecking an instance decl
-
-  | LiteralOrigin	Literal	-- Occurrence of a literal
-			SrcLoc	-- (now redundant? ToDo)
-
-  | ArithSeqOrigin	RenamedArithSeqInfo -- [x..], [x..y] etc
-			SrcLoc
-
-  | SignatureOrigin		-- A dict created from a type signature
-				-- I don't expect this ever to appear in 
-				-- an error message so I can't be bothered
-				-- to give it a source location...
-
-  | ClassDeclOrigin	SrcLoc	-- Manufactured during a class decl
-
-  | DerivingOrigin	InstanceMapper
-			Class
-			Bool	-- True <=> deriving for *functions*;
-				-- do *not* look at the TyCon! [WDP 94/09]
-			TyCon
-			SrcLoc
-
-	-- During "deriving" operations we have an ever changing
-	-- mapping of classes to instances, so we record it inside the
-	-- origin information.  This is a bit of a hack, but it works
-	-- fine.  (Simon is to blame [WDP].)
-
-  | InstanceSpecOrigin	InstanceMapper
-			Class	-- in a SPECIALIZE instance pragma
-			UniType
-			SrcLoc
-
-	-- When specialising instances the instance info attached to
-	-- each class is not yet ready, so we record it inside the
-	-- origin information.  This is a bit of a hack, but it works
-	-- fine.  (Patrick is to blame [WDP].)
-  
-  | DefaultDeclOrigin	SrcLoc	-- Related to a `default' declaration
-
-  | ValSpecOrigin	Name	-- in a SPECIALIZE pragma for a value
-			SrcLoc
-
-	-- Argument or result of a ccall
-	-- Dictionaries with this origin aren't actually mentioned in the
-	-- translated term, and so need not be bound.  Nor should they
-	-- be abstracted over.
-  | CCallOrigin		SrcLoc
-			String			-- CCall label
-			(Maybe RenamedExpr)	-- Nothing if it's the result
-						-- Just arg, for an argument
-
-  | LitLitOrigin	SrcLoc
-			String	-- the litlit
-
-  | UnknownOrigin	-- Help! I give up...
-\end{code}
-
-\begin{code}
-get_origin_really (Dict   u clas ty origin) = origin
-get_origin_really (Method u clas ty origin) = origin
-get_origin_really (LitInst u lit ty origin) = origin
-
-getInstOrigin inst
-  = let origin = get_origin_really inst
-    in  get_orig origin
-  where
-    get_orig :: InstOrigin -> (SrcLoc, PprStyle -> Pretty)
-
-    get_orig (OccurrenceOf id loc)
-      = (loc, \ sty -> ppBesides [ppPStr SLIT("at a use of an overloaded identifier: `"),
-				  ppr sty id, ppChar '\''])
-    get_orig (InstanceDeclOrigin loc)
-      = (loc, \ sty -> ppStr "in an instance declaration")
-    get_orig (LiteralOrigin lit loc) 
-      = (loc, \ sty -> ppCat [ppStr "at an overloaded literal:", ppr sty lit])
-    get_orig (ArithSeqOrigin seq loc)
-      = (loc, \ sty -> ppCat [ppStr "at an arithmetic sequence:", ppr sty seq])
-    get_orig SignatureOrigin
-      = (mkUnknownSrcLoc, \ sty -> ppStr "in a type signature")
-    get_orig (ClassDeclOrigin loc)
-      = (loc, \ sty -> ppStr "in a class declaration")
-    get_orig (DerivingOrigin _ clas is_function tycon loc)
-      = (loc, \ sty -> ppBesides [ppStr "in a `deriving' clause; class \"",
-				  ppr sty clas,
-				  if is_function
-				  then ppStr "\"; type: functions"
-				  else ppBeside (ppStr "\"; offending type \"") (ppr sty tycon),
-				  ppStr "\""])
-    get_orig (InstanceSpecOrigin _ clas ty loc)
-      = (loc, \ sty -> ppBesides [ppStr "in a SPECIALIZE instance pragma; class \"",
-				  ppr sty clas, ppStr "\" type: ", ppr sty ty])
-    get_orig (DefaultDeclOrigin loc)
-      = (loc, \ sty -> ppStr "in a `default' declaration")
-    get_orig (ValSpecOrigin name loc)
-      = (loc, \ sty -> ppBesides [ppStr "in a SPECIALIZE user-pragma for `",
-				  ppr sty name, ppStr "'"])
-    get_orig (CCallOrigin loc clabel Nothing{-ccall result-})
-      = (loc, \ sty -> ppBesides [ppStr "in the result of the _ccall_ to `",
-			ppStr clabel, ppStr "'"])
-    get_orig (CCallOrigin loc clabel (Just arg_expr))
-      = (loc, \ sty -> ppBesides [ppStr "in an argument in the _ccall_ to `",
-			ppStr clabel, ppStr "', namely: ", ppr sty arg_expr])
-    get_orig (LitLitOrigin loc s)
-      = (loc, \ sty -> ppBesides [ppStr "in this ``literal-literal'': ", ppStr s])
-    get_orig UnknownOrigin
-      = (mkUnknownSrcLoc, \ sty -> ppStr "in... oops -- I don't know where the overloading came from!")
-\end{code}
diff --git a/ghc/compiler/basicTypes/Literal.lhs b/ghc/compiler/basicTypes/Literal.lhs
new file mode 100644
index 0000000000..8fb477ee0b
--- /dev/null
+++ b/ghc/compiler/basicTypes/Literal.lhs
@@ -0,0 +1,191 @@
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+%
+\section[Literal]{@Literal@: Machine literals (unboxed, of course)}
+
+\begin{code}
+#include "HsVersions.h"
+
+module Literal (
+	Literal(..),
+
+	mkMachInt, mkMachWord,
+	literalType, literalPrimRep,
+	showLiteral,
+	isNoRepLit, isLitLitLit
+
+	-- and to make the interface self-sufficient....
+    ) where
+
+import Ubiq{-uitous-}
+
+-- friends:
+import PrimRep		( PrimRep(..) ) -- non-abstract
+import TysPrim		( getPrimRepInfo, 
+			  addrPrimTy, intPrimTy, floatPrimTy,
+			  doublePrimTy, charPrimTy, wordPrimTy )
+
+-- others:
+import CStrings		( stringToC, charToC, charToEasyHaskell )
+import TysWiredIn	( integerTy, rationalTy, stringTy )
+import Pretty		-- pretty-printing stuff
+import PprStyle		( PprStyle(..), codeStyle )
+import Util		( panic )
+\end{code}
+
+So-called @Literals@ are {\em either}:
+\begin{itemize}
+\item
+An unboxed (``machine'') literal (type: @IntPrim@, @FloatPrim@, etc.),
+which is presumed to be surrounded by appropriate constructors
+(@mKINT@, etc.), so that the overall thing makes sense.
+\item
+An Integer, Rational, or String literal whose representation we are
+{\em uncommitted} about; i.e., the surrounding with constructors,
+function applications, etc., etc., has not yet been done.
+\end{itemize}
+
+\begin{code}
+data Literal
+  = MachChar	Char
+  | MachStr	FAST_STRING
+  | MachAddr	Integer	-- whatever this machine thinks is a "pointer"
+  | MachInt	Integer	-- for the numeric types, these are
+		Bool	-- True <=> signed (Int#); False <=> unsigned (Word#)
+  | MachFloat	Rational
+  | MachDouble	Rational
+  | MachLitLit  FAST_STRING
+		PrimRep
+
+  | NoRepStr	    FAST_STRING	-- the uncommitted ones
+  | NoRepInteger    Integer
+  | NoRepRational   Rational
+
+  deriving (Eq, Ord)
+  -- The Ord is needed for the FiniteMap used in the lookForConstructor
+  -- in SimplEnv.  If you declared that lookForConstructor *ignores*
+  -- constructor-applications with LitArg args, then you could get
+  -- rid of this Ord.
+
+mkMachInt, mkMachWord :: Integer -> Literal
+
+mkMachInt  x = MachInt x True{-signed-}
+mkMachWord x = MachInt x False{-unsigned-}
+\end{code}
+
+\begin{code}
+isNoRepLit (NoRepStr _)     	= True -- these are not primitive typed!
+isNoRepLit (NoRepInteger _) 	= True
+isNoRepLit (NoRepRational _)	= True
+isNoRepLit _			= False
+
+isLitLitLit (MachLitLit _ _) = True
+isLitLitLit _	    	     = False
+\end{code}
+
+\begin{code}
+literalType :: Literal -> Type
+
+literalType (MachChar _)	= charPrimTy
+literalType (MachStr  _)	= addrPrimTy
+literalType (MachAddr _)	= addrPrimTy
+literalType (MachInt  _ signed) = if signed then intPrimTy else wordPrimTy
+literalType (MachFloat _)	= floatPrimTy
+literalType (MachDouble _)	= doublePrimTy
+literalType (MachLitLit _ k)	= case (getPrimRepInfo k) of { (_,t,_) -> t }
+literalType (NoRepInteger _)	= integerTy
+literalType (NoRepRational _)= rationalTy
+literalType (NoRepStr _)	= stringTy
+\end{code}
+
+\begin{code}
+literalPrimRep :: Literal -> PrimRep
+
+literalPrimRep (MachChar _)	= CharRep
+literalPrimRep (MachStr _)	= AddrRep  -- specifically: "char *"
+literalPrimRep (MachAddr  _)	= AddrRep
+literalPrimRep (MachInt _ signed) = if signed then IntRep else WordRep
+literalPrimRep (MachFloat _)	= FloatRep
+literalPrimRep (MachDouble _)	= DoubleRep
+literalPrimRep (MachLitLit _ k)	= k
+#ifdef DEBUG
+literalPrimRep (NoRepInteger _)	= panic "literalPrimRep:NoRepInteger"
+literalPrimRep (NoRepRational _)= panic "literalPrimRep:NoRepRational"
+literalPrimRep (NoRepStr _)	= panic "literalPrimRep:NoRepString"
+#endif
+\end{code}
+
+The boring old output stuff:
+\begin{code}
+ppCast :: PprStyle -> FAST_STRING -> Pretty
+ppCast PprForC cast = ppPStr cast
+ppCast _       _    = ppNil
+
+instance Outputable Literal where
+    ppr sty (MachChar ch)
+      = let
+	    char_encoding
+	      = case sty of
+		  PprForC  	-> charToC ch
+		  PprForAsm _ _ -> charToC ch
+		  PprUnfolding	-> charToEasyHaskell ch
+		  _		-> [ch]
+	in
+	ppBeside (ppBesides [ppCast sty SLIT("(C_)"), ppChar '\'', ppStr char_encoding, ppChar '\''])
+		 (if_ubxd sty)
+
+    ppr sty (MachStr s)
+      = ppBeside (if codeStyle sty
+		  then ppBesides [ppChar '"', ppStr (stringToC (_UNPK_ s)), ppChar '"']
+		  else ppStr (show (_UNPK_ s)))
+		 (if_ubxd sty)
+
+    ppr sty (MachAddr p) = ppBesides [ppCast sty SLIT("(void*)"), ppInteger p, if_ubxd sty]
+    ppr sty (MachInt i signed)
+      | codeStyle sty
+      && ((signed     && (i >= toInteger minInt && i <= toInteger maxInt))
+       || (not signed && (i >= toInteger 0      && i <= toInteger maxInt)))
+      -- ToDo: Think about these ranges!
+      = ppBesides [ppInteger i, if_ubxd sty]
+
+      | not (codeStyle sty) -- we'd prefer the code to the error message
+      = ppBesides [ppInteger i, if_ubxd sty]
+
+      | otherwise
+      = error ("ERROR: Int " ++ show i ++ " out of range [" ++
+		show range_min ++ " .. " ++ show maxInt ++ "]\n")
+      where
+	range_min = if signed then minInt else 0
+
+    ppr sty (MachFloat f)  = ppBesides [ppCast sty SLIT("(StgFloat)"), ppRational f, if_ubxd sty]
+    ppr sty (MachDouble d) = ppBesides [ppRational d, if_ubxd sty, if_ubxd sty]
+
+    ppr sty (NoRepInteger i)
+      | codeStyle sty  = ppInteger i
+      | ufStyle sty    = ppCat [ppStr "_NOREP_I_", ppInteger i]
+      | otherwise      = ppBesides [ppInteger i, ppChar 'I']
+
+    ppr sty (NoRepRational r)
+      | ufStyle sty    = ppCat [ppStr "_NOREP_R_", ppInteger (numerator r), ppInteger (denominator r)]
+      | codeStyle sty = panic "ppr.ForC.NoRepRational"
+      | otherwise     = ppBesides [ppRational r,  ppChar 'R']
+
+    ppr sty (NoRepStr s)
+      | codeStyle sty = ppBesides [ppStr (show (_UNPK_ s))]
+      | ufStyle   sty = ppCat [ppStr "_NOREP_S_", ppStr (show (_UNPK_ s))]
+      | otherwise     = ppBesides [ppStr (show (_UNPK_ s)), ppChar 'S']
+
+    ppr sty (MachLitLit s k)
+      | codeStyle sty = ppPStr s
+      | ufStyle   sty = ppBesides [ppStr "``", ppPStr s, ppStr "'' _K_ ", ppr sty k]
+      | otherwise     = ppBesides [ppStr "``", ppPStr s, ppStr "''"]
+
+ufStyle PprUnfolding = True
+ufStyle _   	     = False
+
+if_ubxd sty = if codeStyle sty then ppNil else ppChar '#'
+
+showLiteral :: PprStyle -> Literal -> String
+
+showLiteral sty lit = ppShow 80 (ppr sty lit)
+\end{code}
diff --git a/ghc/compiler/basicTypes/Name.lhs b/ghc/compiler/basicTypes/Name.lhs
new file mode 100644
index 0000000000..00fcbab71a
--- /dev/null
+++ b/ghc/compiler/basicTypes/Name.lhs
@@ -0,0 +1,295 @@
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+%
+\section[Name]{@Name@: to transmit name info from renamer to typechecker}
+
+\begin{code}
+#include "HsVersions.h"
+
+module Name (
+	-- things for the Name NON-abstract type
+	Name(..),
+
+	isTyConName, isClassName, isClassOpName,
+	isUnboundName, invisibleName,
+
+	getTagFromClassOpName, getSynNameArity,
+
+	getNameShortName, getNameFullName
+
+    ) where
+
+import Ubiq{-uitous-}
+
+import NameLoop		-- break Name/Id loop, Name/PprType/Id loop
+
+import NameTypes
+import Outputable	( ExportFlag(..) )
+import Pretty
+import PprStyle		( PprStyle(..) )
+import SrcLoc		( mkBuiltinSrcLoc, mkUnknownSrcLoc )
+import TyCon		( TyCon, getSynTyConArity )
+import TyVar		( GenTyVar )
+import Unique		( pprUnique, Unique )
+import Util		( panic, panic#, pprPanic )
+\end{code}
+
+%************************************************************************
+%*									*
+\subsection[Name-datatype]{The @Name@ datatype}
+%*									*
+%************************************************************************
+
+\begin{code}
+data Name
+  = Short	    Unique	-- Local ids and type variables
+		    ShortName
+
+	-- Nano-prelude things; truly wired in.
+	-- Includes all type constructors and their associated data constructors
+  | WiredInTyCon    TyCon
+  | WiredInVal	    Id
+
+  | TyConName	    Unique	-- TyCons other than Prelude ones; need to
+		    FullName	-- separate these because we want to pin on
+		    Arity	-- their arity.
+		    Bool        -- False <=> `type',
+				-- True <=> `data' or `newtype'
+		    [Name]	-- List of user-visible data constructors;
+				-- NB: for `data' types only.
+				-- Used in checking import/export lists.
+
+  | ClassName	    Unique
+		    FullName
+		    [Name]	-- List of class methods; used for checking
+				-- import/export lists.
+
+  | ValName	    Unique	-- Top level id
+		    FullName
+
+  | ClassOpName	    Unique
+		    Name	-- Name associated w/ the defined class
+				-- (can get unique and export info, etc., from this)
+		    FAST_STRING	-- The class operation
+		    Int		-- Unique tag within the class
+
+	-- Miscellaneous
+  | Unbound	    FAST_STRING	-- Placeholder for a name which isn't in scope
+				-- Used only so that the renamer can carry on after
+				-- finding an unbound identifier.
+				-- The string is grabbed from the unbound name, for
+				-- debugging information only.
+\end{code}
+
+These @is..@ functions are used in the renamer to check that (eg) a tycon
+is seen in a context which demands one.
+
+\begin{code}
+isTyConName, isClassName, isUnboundName :: Name -> Bool
+
+isTyConName (TyConName _ _ _ _ _) = True
+isTyConName (WiredInTyCon _)	  = True
+isTyConName other		  = False
+
+isClassName (ClassName _ _ _) = True
+isClassName other	      = False
+
+isUnboundName (Unbound _) = True
+isUnboundName other	  = False
+\end{code}
+
+@isClassOpName@ is a little cleverer: it checks to see whether the
+class op comes from the correct class.
+
+\begin{code}
+isClassOpName :: Name	-- The name of the class expected for this op
+	      -> Name	-- The name of the thing which should be a class op
+	      -> Bool
+
+isClassOpName (ClassName uniq1 _ _) (ClassOpName _ (ClassName uniq2 _ _) _ _)
+  = uniq1 == uniq2
+isClassOpName other_class other_op = False
+\end{code}
+
+A Name is ``invisible'' if the user has no business seeing it; e.g., a
+data-constructor for an abstract data type (but whose constructors are
+known because of a pragma).
+\begin{code}
+invisibleName :: Name -> Bool
+
+invisibleName (TyConName _ n _ _ _) = invisibleFullName n
+invisibleName (ClassName _ n _)     = invisibleFullName n
+invisibleName (ValName   _ n)	    = invisibleFullName n
+invisibleName _			    = False
+\end{code}
+
+\begin{code}
+getTagFromClassOpName :: Name -> Int
+getTagFromClassOpName (ClassOpName _ _ _ tag)  = tag
+
+getSynNameArity :: Name -> Maybe Arity
+getSynNameArity (TyConName _ _ arity False{-syn-} _) = Just arity
+getSynNameArity (WiredInTyCon tycon)	             = getSynTyConArity tycon
+getSynNameArity other_name			     = Nothing
+
+getNameShortName :: Name -> ShortName
+getNameShortName (Short _ sn) = sn
+
+getNameFullName :: Name -> FullName
+getNameFullName n = get_nm "getNameFullName" n
+\end{code}
+
+
+%************************************************************************
+%*									*
+\subsection[Name-instances]{Instance declarations}
+%*									*
+%************************************************************************
+
+\begin{code}
+cmpName n1 n2 = c n1 n2
+  where
+    c (Short u1 _)	     (Short u2 _)		= cmp u1 u2
+			      
+    c (WiredInTyCon tc1)     (WiredInTyCon tc2)		= cmp tc1 tc2
+    c (WiredInVal   id1)     (WiredInVal   id2)		= cmp id1 id2
+			      
+    c (TyConName u1 _ _ _ _) (TyConName u2 _ _ _ _) 	= cmp u1 u2
+    c (ClassName u1 _ _)     (ClassName u2 _ _)		= cmp u1 u2
+    c (ValName   u1 _)	     (ValName   u2 _)		= cmp u1 u2
+			      
+    c (ClassOpName u1 _ _ _) (ClassOpName u2 _ _ _)	= cmp u1 u2
+    c (Unbound a)	     (Unbound b)		= panic# "Eq.Name.Unbound"
+
+    c other_1 other_2		-- the tags *must* be different
+      = let tag1 = tag_Name n1
+	    tag2 = tag_Name n2
+	in
+	if tag1 _LT_ tag2 then LT_ else GT_
+
+    tag_Name (Short _ _)		= (ILIT(1) :: FAST_INT)
+    tag_Name (WiredInTyCon _)		= ILIT(2)
+    tag_Name (WiredInVal _)		= ILIT(3)
+    tag_Name (TyConName _ _ _ _ _)	= ILIT(7)
+    tag_Name (ClassName _ _ _)		= ILIT(8)
+    tag_Name (ValName _ _)		= ILIT(9)
+    tag_Name (ClassOpName _ _ _ _)	= ILIT(10)
+    tag_Name (Unbound _)		= ILIT(11)
+\end{code}
+
+\begin{code}
+instance Eq Name where
+    a == b = case (a `cmp` b) of { EQ_ -> True;  _ -> False }
+    a /= b = case (a `cmp` b) of { EQ_ -> False; _ -> True }
+
+instance Ord Name 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 Name where
+    cmp = cmpName
+\end{code}
+
+\begin{code}
+instance NamedThing Name where
+    getExportFlag (Short _ _)		= NotExported
+    getExportFlag (WiredInTyCon _)	= NotExported -- compiler always know about these
+    getExportFlag (WiredInVal _)	= NotExported
+    getExportFlag (ClassOpName _ c _ _) = getExportFlag c
+    getExportFlag other			= getExportFlag (get_nm "getExportFlag" other)
+
+    isLocallyDefined (Short _ _)	   = True
+    isLocallyDefined (WiredInTyCon _)	   = False
+    isLocallyDefined (WiredInVal _)	   = False
+    isLocallyDefined (ClassOpName _ c _ _) = isLocallyDefined c
+    isLocallyDefined other		   = isLocallyDefined (get_nm "isLocallyDefined" other)
+
+    getOrigName (Short _ sn)		= getOrigName sn
+    getOrigName (WiredInTyCon tc)	= getOrigName tc
+    getOrigName (WiredInVal id)		= getOrigName id
+    getOrigName (ClassOpName _ c op _)	= (fst (getOrigName c), op)
+    getOrigName other			= getOrigName (get_nm "getOrigName" other)
+
+    getOccurrenceName (Short _ sn)	   = getOccurrenceName sn
+    getOccurrenceName (WiredInTyCon tc)    = getOccurrenceName tc
+    getOccurrenceName (WiredInVal id)	   = getOccurrenceName id
+    getOccurrenceName (ClassOpName _ _ op _) = op
+    getOccurrenceName (Unbound s)	   =  s _APPEND_ SLIT("<unbound>")
+    getOccurrenceName other		   = getOccurrenceName (get_nm "getOccurrenceName" other)
+
+    getInformingModules thing = panic "getInformingModule:Name"
+
+    getSrcLoc (Short _ sn)	   = getSrcLoc sn
+    getSrcLoc (WiredInTyCon tc)    = mkBuiltinSrcLoc
+    getSrcLoc (WiredInVal id)	   = mkBuiltinSrcLoc
+    getSrcLoc (ClassOpName _ c _ _)  = getSrcLoc c
+    getSrcLoc (Unbound _)	   = mkUnknownSrcLoc
+    getSrcLoc other		   = getSrcLoc (get_nm "getSrcLoc" other)
+
+    getItsUnique (Short		u _)	   = u
+    getItsUnique (WiredInTyCon	t)	   = getItsUnique t
+    getItsUnique (WiredInVal	i)	   = getItsUnique i
+    getItsUnique (TyConName 	u _ _ _ _) = u
+    getItsUnique (ClassName 	u _ _)	   = u
+    getItsUnique (ValName 	u _)	   = u
+    getItsUnique (ClassOpName 	u _ _ _)   = u
+
+    fromPreludeCore (WiredInTyCon _)	   = True
+    fromPreludeCore (WiredInVal _)	   = True
+    fromPreludeCore (ClassOpName _ c _ _)  = fromPreludeCore c
+    fromPreludeCore other		   = False
+\end{code}
+
+A useful utility; most emphatically not for export! (but see
+@getNameFullName@...):
+\begin{code}
+get_nm :: String -> Name -> FullName
+
+get_nm msg (TyConName _ n _ _ _) = n
+get_nm msg (ClassName _ n _)	 = n
+get_nm msg (ValName   _ n)	 = n
+#ifdef DEBUG
+get_nm msg other = pprPanic ("get_nm:"++msg) (ppr PprShowAll other)
+-- If match failure, probably on a ClassOpName or Unbound :-(
+#endif
+\end{code}
+
+\begin{code}
+instance Outputable Name where
+#ifdef DEBUG
+    ppr PprDebug (Short u s)	    = pp_debug u s
+
+    ppr PprDebug (TyConName u n _ _ _) = pp_debug u n
+    ppr PprDebug (ClassName u n _)     = pp_debug u n
+    ppr PprDebug (ValName u n)         = pp_debug u n
+#endif
+    ppr sty (Short u s)		  = ppr sty s
+
+    ppr sty (WiredInTyCon tc)	  = ppr sty tc
+    ppr sty (WiredInVal   id)	  = ppr sty id
+
+    ppr sty (TyConName u n a b c) = ppr sty n
+    ppr sty (ClassName u n c)	  = ppr sty n
+    ppr sty (ValName   u n)	  = ppr sty n
+
+    ppr sty (ClassOpName u c s i)
+      = let
+	    ps = ppPStr s
+	in
+	case sty of
+	  PprForUser   -> ps
+	  PprInterface -> ps
+	  PprDebug     -> ps
+	  other	       -> ppBesides [ps, ppChar '{',
+				       ppSep [pprUnique u,
+					      ppStr "op", ppInt i,
+					      ppStr "cls", ppr sty c],
+				       ppChar '}']
+
+    ppr sty (Unbound s) = ppStr ("*UNBOUND*"++ _UNPK_ s)
+
+pp_debug uniq thing
+  = ppBesides [ppr PprDebug thing, ppStr "{-", pprUnique uniq, ppStr "-}" ]
+\end{code}
diff --git a/ghc/compiler/basicTypes/NameLoop.lhi b/ghc/compiler/basicTypes/NameLoop.lhi
new file mode 100644
index 0000000000..70ed981867
--- /dev/null
+++ b/ghc/compiler/basicTypes/NameLoop.lhi
@@ -0,0 +1,20 @@
+Breaks the Name/Id loop, and the Name/Id/PprType loop.
+
+\begin{code}
+interface NameLoop where
+
+import Id		( GenId )
+import Outputable	( NamedThing, Outputable )
+import TyCon		( TyCon )
+import Type		( GenType )
+import TyVar		( GenTyVar )
+import Util		( Ord3(..) )
+
+instance NamedThing 	(GenId a)
+instance Ord3 		(GenId a)
+instance (Outputable a) => Outputable (GenId a)
+
+instance (Eq a, Outputable a, Eq b, Outputable b) => Outputable (GenType a b)
+instance Outputable 	(GenTyVar a)
+instance Outputable 	TyCon
+\end{code}
diff --git a/ghc/compiler/basicTypes/NameTypes.hi b/ghc/compiler/basicTypes/NameTypes.hi
deleted file mode 100644
index 40c55ae559..0000000000
--- a/ghc/compiler/basicTypes/NameTypes.hi
+++ /dev/null
@@ -1,25 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface NameTypes where
-import Outputable(ExportFlag, NamedThing, Outputable)
-import PreludePS(_PackedString)
-import SrcLoc(SrcLoc)
-import Unique(Unique)
-data ExportFlag 
-data FullName 
-data Provenance   = ThisModule | InventedInThisModule | ExportedByPreludeCore | OtherPrelude _PackedString | OtherModule _PackedString [_PackedString] | HereInPreludeCore | OtherInstance _PackedString [_PackedString]
-data ShortName 
-data SrcLoc 
-data Unique 
-fromPrelude :: _PackedString -> Bool
-invisibleFullName :: FullName -> Bool
-mkFullName :: _PackedString -> _PackedString -> Provenance -> ExportFlag -> SrcLoc -> FullName
-mkPreludeCoreName :: _PackedString -> _PackedString -> FullName
-mkPrivateFullName :: _PackedString -> _PackedString -> Provenance -> ExportFlag -> SrcLoc -> FullName
-mkShortName :: _PackedString -> SrcLoc -> ShortName
-unlocaliseFullName :: FullName -> FullName
-unlocaliseShortName :: _PackedString -> Unique -> ShortName -> FullName
-instance NamedThing FullName
-instance NamedThing ShortName
-instance Outputable FullName
-instance Outputable ShortName
-
diff --git a/ghc/compiler/basicTypes/NameTypes.lhs b/ghc/compiler/basicTypes/NameTypes.lhs
index 6b8ce705d7..b82c0fa5af 100644
--- a/ghc/compiler/basicTypes/NameTypes.lhs
+++ b/ghc/compiler/basicTypes/NameTypes.lhs
@@ -1,5 +1,5 @@
 %
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1994
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
 %
 %************************************************************************
 %*									*
@@ -24,18 +24,20 @@ module NameTypes (
 
 	unlocaliseFullName, unlocaliseShortName,
 
-#ifdef DPH
-	isInventedFullName,
-#endif {- Data Parallel Haskell -}
-
 	-- and to make the interface self-sufficient....
 	ExportFlag, Unique, SrcLoc
     ) where
 
-import CLabelInfo	( identToC, cSEP )
+CHK_Ubiq()	 -- debugging consistency check
+import PrelLoop  -- for paranoia checking
+
+import PrelMods		( pRELUDE, pRELUDE_CORE ) -- NB: naughty import
+
+import CStrings		( identToC, cSEP )
 import Outputable
-import PrelFuns		( pRELUDE, pRELUDE_CORE ) -- NB: naughty import
 import Pretty
+import PprStyle		( PprStyle(..), codeStyle )
+
 import SrcLoc		( SrcLoc, mkBuiltinSrcLoc )
 import Unique		( showUnique, Unique )
 import Util
@@ -151,16 +153,6 @@ mkPreludeCoreName mod name
     -- deciding it would be a good idea...)
 \end{code}
 
-\begin{code}
-#ifdef DPH
-isInventedFullName (FullName _ _ p _ _ _)
-  = case p of
-      InventedInThisModule -> True
-      _			   -> False
-
-#endif {- Data Parallel Haskell -}
-\end{code}
-
 \begin{code}
 unlocaliseShortName :: FAST_STRING -> Unique -> ShortName -> FullName
 
@@ -207,10 +199,8 @@ instance NamedThing ShortName where
     getSrcLoc	(ShortName s l)       = l
     fromPreludeCore _		      = False
 #ifdef DEBUG
-    getTheUnique (ShortName s l)      = panic "NamedThing.ShortName.getTheUnique" 
+    getItsUnique (ShortName s l)      = panic "NamedThing.ShortName.getItsUnique"
     getInformingModules a	      = panic "NamedThing.ShortName.getInformingModule"
-    hasType a			      = panic "NamedThing.ShortName.hasType"
-    getType a			      = panic "NamedThing.ShortName.getType"
 #endif
 \end{code}
 
@@ -251,9 +241,7 @@ instance NamedThing FullName where
 	  OtherPrelude _	-> [pRELUDE]
 
 #ifdef DEBUG
-    getTheUnique = panic "NamedThing.FullName.getTheUnique"
-    hasType = panic "NamedThing.FullName.hasType"
-    getType = panic "NamedThing.FullName.getType"
+    getItsUnique = panic "NamedThing.FullName.getItsUnique"
 #endif
 \end{code}
 
@@ -279,26 +267,26 @@ instance Outputable FullName where
 			else case sty of
 			      PprForUser     -> ppNil
 			      PprDebug	     -> ppNil
-			      PprInterface _ -> ppNil
-			      PprUnfolding _ -> ppNil	-- ToDo: something diff later?
-			      PprForC _ -> ppBeside (identToC m) (ppPStr cSEP)
-			      PprForAsm _ False _ -> ppBeside (identToC m) (ppPStr cSEP)
-			      PprForAsm _ True _ -> ppBesides [ppPStr cSEP, identToC m, ppPStr cSEP]
+			      PprInterface   -> ppNil
+			      PprUnfolding   -> ppNil	-- ToDo: something diff later?
+			      PprForC 	     -> ppBeside (identToC m) (ppPStr cSEP)
+			      PprForAsm False _ -> ppBeside (identToC m) (ppPStr cSEP)
+			      PprForAsm True  _ -> ppBesides [ppPStr cSEP, identToC m, ppPStr cSEP]
 			      _	        -> ppBeside (ppPStr m) (ppChar '.'))
 		       (if codeStyle sty
-		        then identToC s
+			then identToC s
 			else case sty of
-			       PprInterface _ -> pp_local_name s p
-			       PprForUser     -> pp_local_name s p
-			       _	      -> ppPStr s)
+			       PprInterface -> pp_local_name s p
+			       PprForUser   -> pp_local_name s p
+			       _	    -> ppPStr s)
 
 	    pp_debug = ppBeside pp_name (pp_occur_name s p)
 	in
-        case sty of
-	  PprShowAll 	 -> ppBesides [pp_debug, pp_exp e] -- (ppr sty loc)
-	  PprDebug   	 -> pp_debug
-	  PprUnfolding _ -> pp_debug
-	  _	     	 -> pp_name
+	case sty of
+	  PprShowAll   -> ppBesides [pp_debug, pp_exp e] -- (ppr sty loc)
+	  PprDebug     -> pp_debug
+	  PprUnfolding -> pp_debug
+	  _	       -> pp_name
       where
 	pp_exp NotExported = ppNil
 	pp_exp ExportAll   = ppPStr SLIT("/EXP(..)")
diff --git a/ghc/compiler/basicTypes/OrdList.hi b/ghc/compiler/basicTypes/OrdList.hi
deleted file mode 100644
index 5eef3902cb..0000000000
--- a/ghc/compiler/basicTypes/OrdList.hi
+++ /dev/null
@@ -1,9 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface OrdList where
-data OrdList a 
-flattenOrdList :: OrdList a -> [a]
-mkEmptyList :: OrdList a
-mkParList :: OrdList a -> OrdList a -> OrdList a
-mkSeqList :: OrdList a -> OrdList a -> OrdList a
-mkUnitList :: a -> OrdList a
-
diff --git a/ghc/compiler/basicTypes/OrdList.lhs b/ghc/compiler/basicTypes/OrdList.lhs
deleted file mode 100644
index a97bb80892..0000000000
--- a/ghc/compiler/basicTypes/OrdList.lhs
+++ /dev/null
@@ -1,236 +0,0 @@
-%
-% (c) The AQUA Project, Glasgow University, 1993-1994
-%
-
-%
-% This is useful, general stuff for the Native Code Generator.
-%
-
-\begin{code}
-
-module OrdList (
-	OrdList, 
-
-    	mkParList, mkSeqList, mkEmptyList, mkUnitList,
-	
-    	flattenOrdList
--- UNUSED:
---	concatOrdList, fnOrdList, foldOrdList,
---	mapAccumBOrdList, mapAccumLOrdList, mapAccumROrdList,
---	mapOrdList, reverseOrdList, simplOrdList
-    ) where
-
-import Util	( mapAccumB, mapAccumL, mapAccumR )
-
-\end{code}
-
-This section provides an ordering list that allows fine grain
-parallelism to be expressed.  This is used (ultimately) for scheduling
-of assembly language instructions.
-
-\begin{code}
-
-data OrdList a = SeqList (OrdList a) (OrdList a) 
-	       | ParList (OrdList a) (OrdList a) 
-	       | OrdObj a
-	       | NoObj 
-	       deriving ()
-
-mkSeqList a b = SeqList a b
-mkParList a b = ParList a b
-mkEmptyList   = NoObj
-mkUnitList    = OrdObj
-
-\end{code}
-
-%------------------------------------------------------------------------
-
-This simplifies an ordering list, using correctness preserving transformations.
-Notice the duality between @Seq@ and @Par@.
-
-\begin{code}
-{- UNUSED:
-simplOrdList :: OrdList a -> OrdList a
-simplOrdList (SeqList vs)  = 
-      case (concat [ 
-	      (case simplOrdList v of
-		 SeqList xs	-> xs
-		 OrdObj a	-> [OrdObj a]
-		 NoObj		-> []
-		 xs		-> [xs]) | v <- vs]) of
-	[]  -> NoObj
-	[x] -> x
-	v   -> SeqList v
-simplOrdList (ParList vs)  = 
-      case (concat [ 
-	      (case simplOrdList v of
-		 ParList xs	-> xs
-		 OrdObj a	-> [OrdObj a]
-		 NoObj		-> []
-		 xs		-> [xs]) | v <- vs]) of
-	[]  -> NoObj
-	[x] -> x
-	v   -> ParList v
-simplOrdList v = v
--}
-\end{code}
-
-%------------------------------------------------------------------------
-
-First the foldr !
-
-\begin{code}
-{- UNUSED:
-
-foldOrdList 
-      :: ([b] -> b) 
-      -> ([b] -> b)
-      -> (a -> b)
-      -> b 
-      -> (b -> b -> b)
-      -> OrdList a
-      -> b
-foldOrdList s p o n c (SeqList vs)   = s (map (foldOrdList s p o n c) vs)
-foldOrdList s p o n c (ParList vs)   = p (map (foldOrdList s p o n c) vs)
-foldOrdList s p o n c (OrdObj a)     = o a
-foldOrdList s p o n c  NoObj	     = n
-
-fnOrdList :: (a -> OrdList b) -> OrdList a -> OrdList b
-fnOrdList f (SeqList vs)   = SeqList (map (fnOrdList f) vs)
-fnOrdList f (ParList vs)   = ParList (map (fnOrdList f) vs)
-fnOrdList f (OrdObj a)	   = f a
-fnOrdList f  NoObj	   = NoObj
--}
-\end{code}
-
-This does a concat on an ordering list of ordering lists.
-
-\begin{code}
-{- UNUSED:
-concatOrdList :: OrdList (OrdList a) -> OrdList a
-concatOrdList = fnOrdList id
--}
-\end{code}
-
-This performs a map over an ordering list.
-
-\begin{code}
-{- UNUSED:
-mapOrdList :: (a -> b) -> OrdList a -> OrdList b
-mapOrdList f = fnOrdList (OrdObj.f)
--}
-\end{code}
-
-Here is the reverse over the OrdList.
-
-\begin{code}
-{- UNUSED:
-reverseOrdList :: OrdList a -> OrdList a
-reverseOrdList NoObj	    = NoObj
-reverseOrdList (OrdObj a)   = OrdObj a
-reverseOrdList (ParList vs) = ParList (reverse (map reverseOrdList vs))
-reverseOrdList (SeqList vs) = SeqList (reverse (map reverseOrdList vs))
--}
-\end{code}
-
-Notice this this throws away all potential expression of parrallism.
-
-\begin{code}
-flattenOrdList :: OrdList a -> [a]
-
-flattenOrdList ol
-  = -- trace (shows ol "\n") (
-    flat ol []
-    -- )
-  where
-    flat :: OrdList a -> [a] -> [a]
-    flat NoObj         rest = rest
-    flat (OrdObj x)    rest = x:rest
-    flat (ParList a b) rest = flat a (flat b rest)
-    flat (SeqList a b) rest = flat a (flat b rest)
-
-{- DEBUGGING ONLY:
-instance Text (OrdList a) where
-    showsPrec _ NoObj	= showString "_N_"
-    showsPrec _ (OrdObj _) = showString "_O_"
-    showsPrec _ (ParList a b) = showString "(PAR " . shows a . showChar ')'
-    showsPrec _ (SeqList a b) = showString "(SEQ " . shows a . showChar ')'
--}
-\end{code}
-
-This is like mapAccumR, but over OrdList's.
-
-\begin{code}
-{- UNUSED:
-mapAccumROrdList :: (s -> a -> (s,b)) -> s -> OrdList a -> (s,OrdList b)
-mapAccumROrdList f s NoObj	  = (s,NoObj)
-mapAccumROrdList f s (OrdObj a)	  = 
-   case f s a of
-      (s',b) -> (s',OrdObj b)
-mapAccumROrdList f s (SeqList vs) =
-   case mapAccumR (mapAccumROrdList f) s vs of
-      (s',b) -> (s',SeqList b)
-mapAccumROrdList f s (ParList vs) =
-   case mapAccumR (mapAccumROrdList f) s vs of
-      (s',b) -> (s',ParList b)
-
-mapAccumLOrdList :: (s -> a -> (s,b)) -> s -> OrdList a -> (s,OrdList b)
-mapAccumLOrdList f s NoObj	  = (s,NoObj)
-mapAccumLOrdList f s (OrdObj a)	  = 
-   case f s a of
-      (s',b) -> (s',OrdObj b)
-mapAccumLOrdList f s (SeqList vs) =
-   case mapAccumL (mapAccumLOrdList f) s vs of
-      (s',b) -> (s',SeqList b)
-mapAccumLOrdList f s (ParList vs) =
-   case mapAccumL (mapAccumLOrdList f) s vs of
-      (s',b) -> (s',ParList b)
-
-mapAccumBOrdList :: (accl -> accr -> x -> (accl, accr, y))
-	  -> accl -> accr -> OrdList x -> (accl, accr, OrdList y)
-
-mapAccumBOrdList f a b NoObj  = (a,b,NoObj)
-mapAccumBOrdList f a b (OrdObj x) = 
-   case f a b x of
-      (a',b',y) -> (a',b',OrdObj y)
-mapAccumBOrdList f a b (SeqList xs) = 
-   case mapAccumB (mapAccumBOrdList f) a b xs of
-      (a',b',ys) -> (a',b',SeqList ys)
-mapAccumBOrdList f a b (ParList xs) = 
-   case mapAccumB (mapAccumBOrdList f) a b xs of
-      (a',b',ys) -> (a',b',ParList ys)
--}
-\end{code}
-
-%------------------------------------------------------------------------
-
-In our printing schema, we use @||@ for parallel operations,
-and @;@ for sequential ones.
-
-\begin{code}
-
-#ifdef _GOFER_
-
-instance (Text a) => Text (OrdList a) where
-      showsPrec _ (ParList [a]) = shows a
-      showsPrec _ (ParList as ) = showString "( " .
-				      showOurList as " || " . 
-				  showString " )"
-      showsPrec _ (SeqList [a]) = shows a
-      showsPrec _ (SeqList as ) = showString "( " .
-				      showOurList as " ; " . 
-				  showString " )"
-      showsPrec _ (OrdObj a)	= shows a
-      showsPrec _ (NoObj)	= showString "$"
-
-showOurList :: (Text a) => [a] -> String -> ShowS
-showOurList []	   s = showString ""
-showOurList [a]	   s = shows a
-showOurList (a:as) s = shows a .
-		       showString s .
-		       showOurList as s
-
-#endif
-
-\end{code}
-
diff --git a/ghc/compiler/basicTypes/PragmaInfo.lhs b/ghc/compiler/basicTypes/PragmaInfo.lhs
new file mode 100644
index 0000000000..fb02b0adb2
--- /dev/null
+++ b/ghc/compiler/basicTypes/PragmaInfo.lhs
@@ -0,0 +1,18 @@
+%
+% (c) The AQUA Project, Glasgow University, 1996
+%
+\section[PragmaInfo]{@PragmaInfos@: The user's pragma requests}
+
+\begin{code}
+#include "HsVersions.h"
+
+module PragmaInfo where
+
+import Ubiq
+\end{code}
+
+\begin{code}
+data PragmaInfo
+  = NoPragmaInfo
+  | IWantToBeINLINEd
+\end{code}
diff --git a/ghc/compiler/basicTypes/ProtoName.hi b/ghc/compiler/basicTypes/ProtoName.hi
deleted file mode 100644
index b295e28e88..0000000000
--- a/ghc/compiler/basicTypes/ProtoName.hi
+++ /dev/null
@@ -1,20 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface ProtoName where
-import Maybes(Labda)
-import Name(Name)
-import Outputable(NamedThing, Outputable)
-import PreludePS(_PackedString)
-data Labda a 
-data Name 
-data ProtoName   = Unk _PackedString | Imp _PackedString _PackedString [_PackedString] _PackedString | Prel Name
-cmpByLocalName :: ProtoName -> ProtoName -> Int#
-cmpProtoName :: ProtoName -> ProtoName -> Int#
-elemByLocalNames :: ProtoName -> [ProtoName] -> Bool
-elemProtoNames :: ProtoName -> [ProtoName] -> Bool
-eqByLocalName :: ProtoName -> ProtoName -> Bool
-eqProtoName :: ProtoName -> ProtoName -> Bool
-isConopPN :: ProtoName -> Bool
-mkPreludeProtoName :: Name -> ProtoName
-instance NamedThing ProtoName
-instance Outputable ProtoName
-
diff --git a/ghc/compiler/basicTypes/ProtoName.lhs b/ghc/compiler/basicTypes/ProtoName.lhs
index e7f6bb85b7..d8e3601262 100644
--- a/ghc/compiler/basicTypes/ProtoName.lhs
+++ b/ghc/compiler/basicTypes/ProtoName.lhs
@@ -1,8 +1,7 @@
-%************************************************************************
-%*									*
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+%
 \section[ProtoName]{@ProtoName@: name type used early in the compiler}
-%*									*
-%************************************************************************
 
 \begin{code}
 #include "HsVersions.h"
@@ -14,22 +13,16 @@ module ProtoName (
 
 	cmpProtoName, eqProtoName, elemProtoNames,
 	cmpByLocalName, eqByLocalName, elemByLocalNames,
-	
-	isConopPN,
+
+	isConopPN
 
 	-- and to make the module self-sufficient...
-	Name, Maybe
-#ifndef __GLASGOW_HASKELL__
-	,TAG_
-#endif
     ) where
 
-IMPORT_Trace		-- ToDo: rm (debugging)
+import Ubiq{-uitous-}
 
-import Name		( cmpName, Name
-			  IF_ATTACK_PRAGMAS(COMMA eqName)
-			)
-import Outputable
+import Name		( Name )
+import Outputable	( ifPprShowAll, isConop )
 import Pretty
 import Util
 \end{code}
@@ -44,18 +37,15 @@ import Util
 data ProtoName
   = Unk		FAST_STRING	-- local name in module
 
-  | Imp		FAST_STRING	-- name of defining module 
+  | Qunk	FAST_STRING	-- qualified name
+		FAST_STRING
+
+  | Imp		FAST_STRING	-- name of defining module
 		FAST_STRING	-- name used in defining name
 		[FAST_STRING]	-- name of the module whose interfaces
 				-- told me about this thing
-		FAST_STRING	-- occurrence name; Nothing => same as field 2
+		FAST_STRING	-- occurrence name;
   | Prel	Name
-{- LATER:
-  | Unk2	FAST_INT	-- same as Unk but this FAST_INT is
-				-- the index into hash table (makes for
-				-- superbly great equality comparisons!)
-		FAST_STRING
--}
 \end{code}
 
 %************************************************************************
@@ -90,16 +80,16 @@ things.
 (Later the same night...: but, oh yes, you do:
 
 Given two instance decls
-    
+
 \begin{verbatim}
 instance Eq  {-PreludeCore-}	Foo
 instance Bar {-user-defined-} 	Foo
 \end{verbatim}
 
-you will get a comparison of "Eq" (a Prel) with "Bar" (an {Unk,Imp})) 
+you will get a comparison of "Eq" (a Prel) with "Bar" (an {Unk,Imp}))
 
 @cmp_name@ compares either by ``local name'' (the string by which
-the entity is known in this module, renaming and all) or by original
+the entity is known in this module) or by original
 name, in which case the module name is also taken into account.
 (Just watch what happens on @Imps@...)
 
@@ -112,7 +102,7 @@ cmp_name by_local (Unk n1) (Prel nm)
   =  let  (_, n2) = getOrigName nm  in
      _CMP_STRING_ n1 n2
 
-cmp_name by_local (Prel n1) (Prel n2) = cmpName n1 n2
+cmp_name by_local (Prel n1) (Prel n2) = cmp n1 n2
 
 -- in ordering these things, it's *most* important to have "names" (vs "modules")
 -- as the primary comparison key; otherwise, a list of ProtoNames like...
@@ -194,8 +184,9 @@ elemByLocalNames x (y:ys)
       GT__ -> elemByLocalNames x ys
 
 isConopPN :: ProtoName -> Bool
-isConopPN (Unk s)	= isConop s
-isConopPN (Imp _ n _ _) = isConop n -- ToDo: should use occurrence name???
+isConopPN (Unk    s)	 = isConop s
+isConopPN (Qunk _ s)	 = isConop s
+isConopPN (Imp  _ n _ _) = isConop n -- ToDo: should use occurrence name???
 \end{code}
 
 %************************************************************************
@@ -204,8 +195,6 @@ isConopPN (Imp _ n _ _) = isConop n -- ToDo: should use occurrence name???
 %*									*
 %************************************************************************
 
-********** REMOVE THESE WHEN WE FIX THE SET-ery IN RenameBinds4 *********
-
 \begin{code}
 {- THESE INSTANCES ARE TOO DELICATE TO BE USED!
 Use eqByLocalName, ...., etc. instead
@@ -223,29 +212,29 @@ instance Ord ProtoName where
 instance NamedThing ProtoName where
 
     getOrigName (Unk _)		= panic "NamedThing.ProtoName.getOrigName (Unk)"
+    getOrigName (Qunk _ _)	= panic "NamedThing.ProtoName.getOrigName (Qunk)"
     getOrigName (Imp m s _ _)	= (m, s)
     getOrigName (Prel name)	= getOrigName name
 
     getOccurrenceName (Unk s)	    = s
+    getOccurrenceName (Qunk _ s)    = s
     getOccurrenceName (Imp m s _ o) = o
     getOccurrenceName (Prel name)   = getOccurrenceName name
 
-    hasType pn			= False
-
 #ifdef DEBUG
     getSrcLoc pn		= panic "NamedThing.ProtoName.getSrcLoc"
     getInformingModules pn	= panic "NamedThing.ProtoName.getInformingModule"
-    getTheUnique pn		= panic "NamedThing.ProtoName.getUnique"
+    getItsUnique pn		= panic "NamedThing.ProtoName.getItsUnique"
     fromPreludeCore pn		= panic "NamedThing.ProtoName.fromPreludeCore"
     getExportFlag pn		= panic "NamedThing.ProtoName.getExportFlag"
     isLocallyDefined pn		= panic "NamedThing.ProtoName.isLocallyDefined"
-    getType pn			= panic "NamedThing.ProtoName.getType"
 #endif
 \end{code}
 
 \begin{code}
 instance Outputable ProtoName where
     ppr sty (Unk s)     = ppPStr s
+    ppr sty (Qunk m s)  = ppBesides [ppPStr m, ppChar '.', ppPStr s]
     ppr sty (Prel name) = ppBeside (ppr sty name) (ifPprShowAll sty (ppPStr SLIT("/PREL")))
     ppr sty (Imp mod dec imod loc)
       = ppBesides [ppPStr mod, ppChar '.', ppPStr dec, pp_occur_name dec loc ]
diff --git a/ghc/compiler/basicTypes/SplitUniq.hi b/ghc/compiler/basicTypes/SplitUniq.hi
deleted file mode 100644
index a02cad8c2d..0000000000
--- a/ghc/compiler/basicTypes/SplitUniq.hi
+++ /dev/null
@@ -1,18 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface SplitUniq where
-import Unique(Unique)
-type SUniqSM a = SplitUniqSupply -> a
-data SplitUniqSupply 
-data Unique 
-getSUnique :: SplitUniqSupply -> Unique
-getSUniqueAndDepleted :: SplitUniqSupply -> (Unique, SplitUniqSupply)
-getSUniques :: Int -> SplitUniqSupply -> [Unique]
-getSUniquesAndDepleted :: Int -> SplitUniqSupply -> ([Unique], SplitUniqSupply)
-initSUs :: SplitUniqSupply -> (SplitUniqSupply -> a) -> (SplitUniqSupply, a)
-mapAndUnzipSUs :: (a -> SplitUniqSupply -> (b, c)) -> [a] -> SplitUniqSupply -> ([b], [c])
-mapSUs :: (a -> SplitUniqSupply -> b) -> [a] -> SplitUniqSupply -> [b]
-mkSplitUniqSupply :: Char -> _State _RealWorld -> (SplitUniqSupply, _State _RealWorld)
-returnSUs :: a -> SplitUniqSupply -> a
-splitUniqSupply :: SplitUniqSupply -> (SplitUniqSupply, SplitUniqSupply)
-thenSUs :: (SplitUniqSupply -> a) -> (a -> SplitUniqSupply -> b) -> SplitUniqSupply -> b
-
diff --git a/ghc/compiler/basicTypes/SplitUniq.lhs b/ghc/compiler/basicTypes/SplitUniq.lhs
deleted file mode 100644
index 3d408c95e2..0000000000
--- a/ghc/compiler/basicTypes/SplitUniq.lhs
+++ /dev/null
@@ -1,305 +0,0 @@
-%
-% (c) The AQUA Project, Glasgow University, 1994-1995
-%
-\section[Unique]{The @SplitUniqSupply@ data type (``splittable Unique supply'')}
-
-\begin{code}
-#include "HsVersions.h"
-
-module SplitUniq (
-	SplitUniqSupply,		-- abstract types
-
-	getSUnique, getSUniques,	-- basic ops
-	getSUniqueAndDepleted, getSUniquesAndDepleted,	-- DEPRECATED!
-
-	SUniqSM(..),		-- type: unique supply monad
-	initSUs, thenSUs, returnSUs,
-	mapSUs, mapAndUnzipSUs,
-
-	mkSplitUniqSupply,
-	splitUniqSupply,
-
-	-- to make interface self-sufficient
-	Unique
-	IF_ATTACK_PRAGMAS(COMMA mkUniqueGrimily)
-
-#ifndef __GLASGOW_HASKELL__
-	,TAG_
-#endif
-    ) where
-
-import Outputable	-- class for printing, forcing
-import Pretty		-- pretty-printing utilities
-import PrimOps		-- ** DIRECTLY **
-import Unique
-import Util
-
-#if defined(__HBC__)
-{-hide import from mkdependHS-}
-import
-	Word
-import
-	NameSupply	renaming ( Name to HBC_Name )
-#endif
-#ifdef __GLASGOW_HASKELL__
-# if __GLASGOW_HASKELL__ >= 26
-import PreludeGlaST
-# else
-import PreludePrimIO
-import PreludeGlaST	( unsafeInterleaveST
-			  IF_ATTACK_PRAGMAS(COMMA fixST)
-			)
-# endif
-#endif
-
-infixr 9 `thenUs`
-
-#ifdef __GLASGOW_HASKELL__
-w2i x = word2Int# x
-i2w x = int2Word# x
-i2w_s x = (x :: Int#)
-#endif
-\end{code}
-
-%************************************************************************
-%*									*
-\subsection[SplitUniqSupply-type]{@SplitUniqSupply@ type and operations}
-%*									*
-%************************************************************************
-
-A value of type @SplitUniqSupply@ is unique, and it can
-supply {\em one} distinct @Unique@.  Also, from the supply, one can
-also manufacture an arbitrary number of further @UniqueSupplies@,
-which will be distinct from the first and from all others.
-
-Common type signatures
-\begin{code}
--- mkSplitUniqSupply :: differs by implementation!
-
-splitUniqSupply :: SplitUniqSupply -> (SplitUniqSupply, SplitUniqSupply)
-getSUnique :: SplitUniqSupply -> Unique
-getSUniques :: Int -> SplitUniqSupply -> [Unique]
-getSUniqueAndDepleted :: SplitUniqSupply -> (Unique, SplitUniqSupply)
-getSUniquesAndDepleted :: Int -> SplitUniqSupply -> ([Unique], SplitUniqSupply)
-\end{code}
-
-%************************************************************************
-%*									*
-\subsubsection{Chalmers implementation of @SplitUniqSupply@}
-%*									*
-%************************************************************************
-
-\begin{code}
-#if defined(__HBC__)
-
-data SplitUniqSupply = MkSplit NameSupply
-
-mkSplitUniqSupply :: Char -> SplitUniqSupply -- NB: not the same type
-
-mkSplitUniqSupply _ = MkSplit initialNameSupply
-
-splitUniqSupply (MkSplit us)
-  = case (splitNameSupply us) of { (s1, s2) ->
-    (MkSplit s1, MkSplit s2) }
-
-getSUnique supply = error "getSUnique" -- mkUniqueGrimily (getName supply)
-
-getSUniques i supply
-  = error "getSUniques" -- [ mkUniqueGrimily (getName s) | s <- take i (listNameSupply supply) ]
-
-getSUniqueAndDepleted supply
-  = error "getSUniqueAndDepleted"
-{-
-    let
-	u = mkUniqueGrimily (getName supply)
-	(s1, _) = splitNameSupply supply
-    in
-    (u, s1)
--}
-
-getSUniquesAndDepleted i supply
-  = error "getSUniquesAndDepleted"
-{-
-  = let
-	supplies = take (i+1) (listNameSupply supply)
-	uniqs	 = [ mkUniqueGrimily (getName s) | s <- take i supplies ]
-	last_supply = drop i supplies
-    in
-    (uniqs, last_supply)
--}
-
-#endif {- end of Chalmers implementation -}
-\end{code}
-
-%************************************************************************
-%*									*
-\subsubsection{Glasgow implementation of @SplitUniqSupply@}
-%*									*
-%************************************************************************
-
-Glasgow Haskell implementation:
-\begin{code}
-#ifdef __GLASGOW_HASKELL__
-
-# ifdef IGNORE_REFERENTIAL_TRANSPARENCY
-
-data SplitUniqSupply = MkSplitUniqSupply {-does nothing-}
-
-mkSplitUniqSupply :: Char -> PrimIO SplitUniqSupply
-mkSplitUniqSupply (MkChar c#) = returnPrimIO MkSplitUniqSupply
-
-splitUniqSupply _ = (MkSplitUniqSupply, MkSplitUniqSupply)
-
-getSUnique s = unsafe_mk_unique s
-
-getSUniques i@(MkInt i#) supply = get_from i# supply
-  where
-    get_from 0# s = []
-    get_from n# s
-      = unsafe_mk_unique s : get_from (n# `minusInt#` 1#) s
-
-getSUniqueAndDepleted s = (unsafe_mk_unique s, MkSplitUniqSupply)
-
-getSUniquesAndDepleted i@(MkInt i#) s = get_from [] i# s
-  where
-    get_from acc 0# s = (acc, MkSplitUniqSupply)
-    get_from acc n# s
-      = get_from (unsafe_mk_unique s : acc) (n# `minusInt#` 1#) s
-
-unsafe_mk_unique supply -- this is the TOTALLY unacceptable bit
-  = unsafePerformPrimIO (
-    _ccall_ genSymZh junk	`thenPrimIO` \ (W# u#) ->
-    returnPrimIO (mkUniqueGrimily (w2i (mask# `or#` u#)))
-    )
-  where
-    mask# = (i2w (ord# 'x'#)) `shiftL#` (i2w_s 24#)
-    junk  = case supply of { MkSplitUniqSupply -> (1::Int) }
-
-# else {- slight attention to referential transparency -}
-
-data SplitUniqSupply
-  = MkSplitUniqSupply Int	-- make the Unique with this
-		   SplitUniqSupply SplitUniqSupply
-				-- when split => these two supplies
-\end{code}
-
-@mkSplitUniqSupply@ is used to get a @SplitUniqSupply@ started.
-\begin{code}
-
-mkSplitUniqSupply :: Char -> PrimIO SplitUniqSupply
-
--- ToDo: 64-bit bugs here!!???
-
-mkSplitUniqSupply (MkChar c#)
-  = let
-	mask# = (i2w (ord# c#)) `shiftL#` (i2w_s 24#)
-
-	-- here comes THE MAGIC:
-
-	mk_supply#
-{- OLD:
-	  = unsafe_interleave mk_unique	 `thenPrimIO` \ uniq ->
-	    unsafe_interleave mk_supply# `thenPrimIO` \ s1 ->
-	    unsafe_interleave mk_supply# `thenPrimIO` \ s2 ->
-	    returnPrimIO (MkSplitUniqSupply uniq s1 s2)
--}
-	  = unsafe_interleave (
-		mk_unique   `thenPrimIO` \ uniq ->
-		mk_supply#  `thenPrimIO` \ s1 ->
-		mk_supply#  `thenPrimIO` \ s2 ->
-		returnPrimIO (MkSplitUniqSupply uniq s1 s2)
-	    )
-	  where
-	    -- inlined copy of unsafeInterleavePrimIO;
-	    -- this is the single-most-hammered bit of code
-	    -- in the compiler....
-	    unsafe_interleave m s
-	      = let
-		    (r, new_s) = m s
-		in
-		(r, s)
-
-        mk_unique = _ccall_ genSymZh		`thenPrimIO` \ (W# u#) ->
-		    returnPrimIO (MkInt (w2i (mask# `or#` u#)))
-    in
-    mk_supply#
-
-splitUniqSupply (MkSplitUniqSupply _ s1 s2) = (s1, s2)
-\end{code}
-
-\begin{code}
-getSUnique (MkSplitUniqSupply (MkInt n) _ _) = mkUniqueGrimily n
-
-getSUniques i@(MkInt i#) supply = i# `get_from` supply
-  where
-    get_from 0# _ = []
-    get_from n# (MkSplitUniqSupply (MkInt u#) _ s2)
-      = mkUniqueGrimily u# : get_from (n# `minusInt#` 1#) s2
-
-getSUniqueAndDepleted (MkSplitUniqSupply (MkInt n) s1 _) = (mkUniqueGrimily n, s1)
-
-getSUniquesAndDepleted i@(MkInt i#) supply = get_from [] i# supply
-  where
-    get_from acc 0# s = (acc, s)
-    get_from acc n# (MkSplitUniqSupply (MkInt u#) _ s2)
-      = get_from (mkUniqueGrimily u# : acc) (n# `minusInt#` 1#) s2
-
-# endif {- slight attention to referential transparency -}
-
-#endif  {- end of Glasgow implementation -}
-\end{code}
-
-%************************************************************************
-%*									*
-\subsection[SplitUniq-monad]{Splittable Unique-supply monad}
-%*									*
-%************************************************************************
-
-\begin{code}
-type SUniqSM result = SplitUniqSupply -> result
-
--- the initUs function also returns the final SplitUniqSupply
-
-initSUs :: SplitUniqSupply -> SUniqSM a -> (SplitUniqSupply, a)
-
-initSUs init_us m
-  = case (splitUniqSupply init_us) of { (s1, s2) ->
-    (s2, m s1) }
-
-#ifdef __GLASGOW_HASKELL__
-{-# INLINE thenSUs #-}
-{-# INLINE returnSUs #-}
-{-# INLINE splitUniqSupply #-}
-#endif
-\end{code}
-
-@thenSUs@ is where we split the @SplitUniqSupply@.
-\begin{code}
-thenSUs :: SUniqSM a -> (a -> SUniqSM b) -> SUniqSM b
-
-thenSUs expr cont us
-  = case (splitUniqSupply us) of { (s1, s2) ->
-    case (expr s1)	      of { result ->
-    cont result s2 }}
-\end{code}
-
-\begin{code}
-returnSUs :: a -> SUniqSM a
-returnSUs result us = result
-
-mapSUs :: (a -> SUniqSM b) -> [a] -> SUniqSM [b]
-
-mapSUs f []     = returnSUs []
-mapSUs f (x:xs)
-  = f x         `thenSUs` \ r  ->
-    mapSUs f xs  `thenSUs` \ rs ->
-    returnSUs (r:rs)
-
-mapAndUnzipSUs  :: (a -> SUniqSM (b,c))   -> [a] -> SUniqSM ([b],[c])
-
-mapAndUnzipSUs f [] = returnSUs ([],[])
-mapAndUnzipSUs f (x:xs)
-  = f x		    	`thenSUs` \ (r1,  r2)  ->
-    mapAndUnzipSUs f xs	`thenSUs` \ (rs1, rs2) ->
-    returnSUs (r1:rs1, r2:rs2)
-\end{code}
diff --git a/ghc/compiler/basicTypes/SrcLoc.hi b/ghc/compiler/basicTypes/SrcLoc.hi
deleted file mode 100644
index 7ed3938c17..0000000000
--- a/ghc/compiler/basicTypes/SrcLoc.hi
+++ /dev/null
@@ -1,13 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface SrcLoc where
-import Outputable(Outputable)
-import PreludePS(_PackedString)
-data SrcLoc 
-mkBuiltinSrcLoc :: SrcLoc
-mkGeneratedSrcLoc :: SrcLoc
-mkSrcLoc :: _PackedString -> _PackedString -> SrcLoc
-mkSrcLoc2 :: _PackedString -> Int -> SrcLoc
-mkUnknownSrcLoc :: SrcLoc
-unpackSrcLoc :: SrcLoc -> (_PackedString, _PackedString)
-instance Outputable SrcLoc
-
diff --git a/ghc/compiler/basicTypes/SrcLoc.lhs b/ghc/compiler/basicTypes/SrcLoc.lhs
index 423b4b32e0..f27a6f06dc 100644
--- a/ghc/compiler/basicTypes/SrcLoc.lhs
+++ b/ghc/compiler/basicTypes/SrcLoc.lhs
@@ -20,9 +20,10 @@ module SrcLoc (
 	unpackSrcLoc
     ) where
 
-import Outputable
+import Ubiq
+
+import PprStyle		( PprStyle(..) )
 import Pretty
-import Util
 \end{code}
 
 %************************************************************************
diff --git a/ghc/compiler/basicTypes/UniqSupply.lhs b/ghc/compiler/basicTypes/UniqSupply.lhs
new file mode 100644
index 0000000000..425e0459e1
--- /dev/null
+++ b/ghc/compiler/basicTypes/UniqSupply.lhs
@@ -0,0 +1,190 @@
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+%
+\section[UniqSupply]{The @UniqueSupply@ data type and a (monadic) supply thereof}
+
+\begin{code}
+#include "HsVersions.h"
+
+module UniqSupply (
+
+	UniqSupply,		-- Abstractly
+
+	getUnique, getUniques,	-- basic ops
+
+	UniqSM(..),		-- type: unique supply monad
+	initUs, thenUs, returnUs,
+	mapUs, mapAndUnzipUs,
+
+	mkSplitUniqSupply,
+	splitUniqSupply,
+
+	-- and the access functions for the `builtin' UniqueSupply
+	getBuiltinUniques, mkBuiltinUnique,
+	mkPseudoUnique1, mkPseudoUnique2, mkPseudoUnique3
+  ) where
+
+import Ubiq{-uitous-}
+
+import Unique
+import Util
+
+import PreludeGlaST
+
+w2i x = word2Int# x
+i2w x = int2Word# x
+i2w_s x = (x :: Int#)
+\end{code}
+
+
+%************************************************************************
+%*									*
+\subsection{Splittable Unique supply: @UniqSupply@}
+%*									*
+%************************************************************************
+
+%************************************************************************
+%*									*
+\subsubsection[UniqSupply-type]{@UniqSupply@ type and operations}
+%*									*
+%************************************************************************
+
+A value of type @UniqSupply@ is unique, and it can
+supply {\em one} distinct @Unique@.  Also, from the supply, one can
+also manufacture an arbitrary number of further @UniqueSupplies@,
+which will be distinct from the first and from all others.
+
+\begin{code}
+data UniqSupply
+  = MkSplitUniqSupply Int	-- make the Unique with this
+		   UniqSupply UniqSupply
+				-- when split => these two supplies
+\end{code}
+
+\begin{code}
+mkSplitUniqSupply :: Char -> PrimIO UniqSupply
+
+splitUniqSupply :: UniqSupply -> (UniqSupply, UniqSupply)
+getUnique :: UniqSupply -> Unique
+getUniques :: Int -> UniqSupply -> [Unique]
+\end{code}
+
+\begin{code}
+mkSplitUniqSupply (MkChar c#)
+  = let
+	mask# = (i2w (ord# c#)) `shiftL#` (i2w_s 24#)
+
+	-- here comes THE MAGIC:
+
+	mk_supply#
+	  = unsafe_interleave (
+		mk_unique   `thenPrimIO` \ uniq ->
+		mk_supply#  `thenPrimIO` \ s1 ->
+		mk_supply#  `thenPrimIO` \ s2 ->
+		returnPrimIO (MkSplitUniqSupply uniq s1 s2)
+	    )
+	  where
+	    -- inlined copy of unsafeInterleavePrimIO;
+	    -- this is the single-most-hammered bit of code
+	    -- in the compiler....
+	    unsafe_interleave m s
+	      = let
+		    (r, new_s) = m s
+		in
+		(r, s)
+
+	mk_unique = _ccall_ genSymZh		`thenPrimIO` \ (W# u#) ->
+		    returnPrimIO (MkInt (w2i (mask# `or#` u#)))
+    in
+    mk_supply#
+
+splitUniqSupply (MkSplitUniqSupply _ s1 s2) = (s1, s2)
+\end{code}
+
+\begin{code}
+getUnique (MkSplitUniqSupply (MkInt n) _ _) = mkUniqueGrimily n
+
+getUniques i@(MkInt i#) supply = i# `get_from` supply
+  where
+    get_from 0# _ = []
+    get_from n# (MkSplitUniqSupply (MkInt u#) _ s2)
+      = mkUniqueGrimily u# : get_from (n# `minusInt#` 1#) s2
+\end{code}
+
+%************************************************************************
+%*									*
+\subsubsection[UniqSupply-monad]{@UniqSupply@ monad: @UniqSM@}
+%*									*
+%************************************************************************
+
+\begin{code}
+type UniqSM result = UniqSupply -> result
+
+-- the initUs function also returns the final UniqSupply
+
+initUs :: UniqSupply -> UniqSM a -> (UniqSupply, a)
+
+initUs init_us m
+  = case (splitUniqSupply init_us) of { (s1, s2) ->
+    (s2, m s1) }
+
+{-# INLINE thenUs #-}
+{-# INLINE returnUs #-}
+{-# INLINE splitUniqSupply #-}
+\end{code}
+
+@thenUs@ is where we split the @UniqSupply@.
+\begin{code}
+thenUs :: UniqSM a -> (a -> UniqSM b) -> UniqSM b
+
+thenUs expr cont us
+  = case (splitUniqSupply us) of { (s1, s2) ->
+    case (expr s1)	      of { result ->
+    cont result s2 }}
+\end{code}
+
+\begin{code}
+returnUs :: a -> UniqSM a
+returnUs result us = result
+
+mapUs :: (a -> UniqSM b) -> [a] -> UniqSM [b]
+
+mapUs f []     = returnUs []
+mapUs f (x:xs)
+  = f x         `thenUs` \ r  ->
+    mapUs f xs  `thenUs` \ rs ->
+    returnUs (r:rs)
+
+mapAndUnzipUs  :: (a -> UniqSM (b,c))   -> [a] -> UniqSM ([b],[c])
+
+mapAndUnzipUs f [] = returnUs ([],[])
+mapAndUnzipUs f (x:xs)
+  = f x		    	`thenUs` \ (r1,  r2)  ->
+    mapAndUnzipUs f xs	`thenUs` \ (rs1, rs2) ->
+    returnUs (r1:rs1, r2:rs2)
+\end{code}
+
+%************************************************************************
+%*									*
+\subsubsection[UniqueSupplies-compiler]{@UniqueSupplies@ specific to the compiler}
+%*									*
+%************************************************************************
+
+\begin{code}
+mkPseudoUnique1, mkPseudoUnique2, mkPseudoUnique3,
+ mkBuiltinUnique :: Int -> Unique
+
+mkBuiltinUnique i = mkUnique 'B' i
+mkPseudoUnique1 i = mkUnique 'C' i -- used for getItsUnique on Regs
+mkPseudoUnique2 i = mkUnique 'D' i -- ditto
+mkPseudoUnique3 i = mkUnique 'E' i -- ditto
+
+getBuiltinUniques :: Int -> [Unique]
+getBuiltinUniques n = map (mkUnique 'B') [1 .. n]
+\end{code}
+
+The following runs a uniq monad expression, using builtin uniq values:
+\begin{code}
+--runBuiltinUs :: UniqSM a -> a
+--runBuiltinUs m = snd (initUs uniqSupply_B m)
+\end{code}
diff --git a/ghc/compiler/basicTypes/Unique.hi b/ghc/compiler/basicTypes/Unique.hi
deleted file mode 100644
index 06c2e096f5..0000000000
--- a/ghc/compiler/basicTypes/Unique.hi
+++ /dev/null
@@ -1,175 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface Unique where
-import CharSeq(CSeq)
-import PreludePS(_PackedString)
-import Pretty(PrettyRep)
-import PrimKind(PrimKind)
-import PrimOps(PrimOp)
-import SplitUniq(SplitUniqSupply)
-import UniType(UniType)
-infixr 9 `thenUs`
-data CSeq 
-data PrimOp 
-data SplitUniqSupply 
-type UniqSM a = UniqueSupply -> (UniqueSupply, a)
-data Unique 
-data UniqueSupply 
-absentErrorIdKey :: Unique
-addrDataConKey :: Unique
-addrPrimTyConKey :: Unique
-addrTyConKey :: Unique
-appendIdKey :: Unique
-arrayPrimTyConKey :: Unique
-augmentIdKey :: Unique
-binaryClassKey :: Unique
-boolTyConKey :: Unique
-buildDataConKey :: Unique
-buildIdKey :: Unique
-byteArrayPrimTyConKey :: Unique
-cCallableClassKey :: Unique
-cReturnableClassKey :: Unique
-charDataConKey :: Unique
-charPrimTyConKey :: Unique
-charTyConKey :: Unique
-cmpTagTyConKey :: Unique
-cmpUnique :: Unique -> Unique -> Int#
-consDataConKey :: Unique
-dialogueTyConKey :: Unique
-doubleDataConKey :: Unique
-doublePrimTyConKey :: Unique
-doubleTyConKey :: Unique
-enumClassKey :: Unique
-eqClassKey :: Unique
-eqTagDataConKey :: Unique
-eqUnique :: Unique -> Unique -> Bool
-errorIdKey :: Unique
-falseDataConKey :: Unique
-floatDataConKey :: Unique
-floatPrimTyConKey :: Unique
-floatTyConKey :: Unique
-floatingClassKey :: Unique
-foldlIdKey :: Unique
-foldrIdKey :: Unique
-forkIdKey :: Unique
-fractionalClassKey :: Unique
-getBuiltinUniques :: Int -> [Unique]
-getUnique :: UniqueSupply -> (UniqueSupply, Unique)
-getUniques :: Int -> UniqueSupply -> (UniqueSupply, [Unique])
-gtTagDataConKey :: Unique
-iOTyConKey :: Unique
-initUs :: UniqueSupply -> (UniqueSupply -> (UniqueSupply, a)) -> (UniqueSupply, a)
-intDataConKey :: Unique
-intPrimTyConKey :: Unique
-intTyConKey :: Unique
-integerDataConKey :: Unique
-integerMinusOneIdKey :: Unique
-integerPlusOneIdKey :: Unique
-integerPlusTwoIdKey :: Unique
-integerTyConKey :: Unique
-integerZeroIdKey :: Unique
-integralClassKey :: Unique
-ixClassKey :: Unique
-liftDataConKey :: Unique
-liftTyConKey :: Unique
-listTyConKey :: Unique
-ltTagDataConKey :: Unique
-mallocPtrDataConKey :: Unique
-mallocPtrPrimTyConKey :: Unique
-mallocPtrTyConKey :: Unique
-mapAndUnzipUs :: (a -> UniqueSupply -> (UniqueSupply, (b, c))) -> [a] -> UniqueSupply -> (UniqueSupply, ([b], [c]))
-mapUs :: (a -> UniqueSupply -> (UniqueSupply, b)) -> [a] -> UniqueSupply -> (UniqueSupply, [b])
-mkBuiltinUnique :: Int -> Unique
-mkPrimOpIdUnique :: PrimOp -> Unique
-mkPseudoUnique1 :: Int -> Unique
-mkPseudoUnique2 :: Int -> Unique
-mkPseudoUnique3 :: Int -> Unique
-mkTupleDataConUnique :: Int -> Unique
-mkUnifiableTyVarUnique :: Int -> Unique
-mkUniqueGrimily :: Int# -> Unique
-mkUniqueSupplyGrimily :: SplitUniqSupply -> UniqueSupply
-mutableArrayPrimTyConKey :: Unique
-mutableByteArrayPrimTyConKey :: Unique
-nilDataConKey :: Unique
-numClassKey :: Unique
-ordClassKey :: Unique
-packCStringIdKey :: Unique
-parErrorIdKey :: Unique
-parIdKey :: Unique
-patErrorIdKey :: Unique
-pprUnique :: Unique -> Int -> Bool -> PrettyRep
-pprUnique10 :: Unique -> Int -> Bool -> PrettyRep
-primIoTyConKey :: Unique
-ratioDataConKey :: Unique
-ratioTyConKey :: Unique
-rationalTyConKey :: Unique
-realClassKey :: Unique
-realFloatClassKey :: Unique
-realFracClassKey :: Unique
-realWorldPrimIdKey :: Unique
-realWorldTyConKey :: Unique
-return2GMPsDataConKey :: Unique
-return2GMPsTyConKey :: Unique
-returnIntAndGMPDataConKey :: Unique
-returnIntAndGMPTyConKey :: Unique
-returnUs :: a -> UniqueSupply -> (UniqueSupply, a)
-runBuiltinUs :: (UniqueSupply -> (UniqueSupply, a)) -> a
-runSTIdKey :: Unique
-seqIdKey :: Unique
-showUnique :: Unique -> _PackedString
-stTyConKey :: Unique
-stablePtrDataConKey :: Unique
-stablePtrPrimTyConKey :: Unique
-stablePtrTyConKey :: Unique
-stateAndAddrPrimDataConKey :: Unique
-stateAndAddrPrimTyConKey :: Unique
-stateAndArrayPrimDataConKey :: Unique
-stateAndArrayPrimTyConKey :: Unique
-stateAndByteArrayPrimDataConKey :: Unique
-stateAndByteArrayPrimTyConKey :: Unique
-stateAndCharPrimDataConKey :: Unique
-stateAndCharPrimTyConKey :: Unique
-stateAndDoublePrimDataConKey :: Unique
-stateAndDoublePrimTyConKey :: Unique
-stateAndFloatPrimDataConKey :: Unique
-stateAndFloatPrimTyConKey :: Unique
-stateAndIntPrimDataConKey :: Unique
-stateAndIntPrimTyConKey :: Unique
-stateAndMallocPtrPrimDataConKey :: Unique
-stateAndMallocPtrPrimTyConKey :: Unique
-stateAndMutableArrayPrimDataConKey :: Unique
-stateAndMutableArrayPrimTyConKey :: Unique
-stateAndMutableByteArrayPrimDataConKey :: Unique
-stateAndMutableByteArrayPrimTyConKey :: Unique
-stateAndPtrPrimDataConKey :: Unique
-stateAndPtrPrimTyConKey :: Unique
-stateAndStablePtrPrimDataConKey :: Unique
-stateAndStablePtrPrimTyConKey :: Unique
-stateAndSynchVarPrimDataConKey :: Unique
-stateAndSynchVarPrimTyConKey :: Unique
-stateAndWordPrimDataConKey :: Unique
-stateAndWordPrimTyConKey :: Unique
-stateDataConKey :: Unique
-statePrimTyConKey :: Unique
-stateTyConKey :: Unique
-stringTyConKey :: Unique
-synchVarPrimTyConKey :: Unique
-textClassKey :: Unique
-thenUs :: (UniqueSupply -> (UniqueSupply, a)) -> (a -> UniqueSupply -> (UniqueSupply, b)) -> UniqueSupply -> (UniqueSupply, b)
-traceIdKey :: Unique
-trueDataConKey :: Unique
-u2i :: Unique -> Int#
-uniqSupply_u :: UniqueSupply
-unpackCString2IdKey :: Unique
-unpackCStringAppendIdKey :: Unique
-unpackCStringFoldrIdKey :: Unique
-unpackCStringIdKey :: Unique
-unpkUnifiableTyVarUnique :: Unique -> Int
-voidPrimIdKey :: Unique
-voidPrimTyConKey :: Unique
-wordDataConKey :: Unique
-wordPrimTyConKey :: Unique
-wordTyConKey :: Unique
-instance Eq Unique
-instance Ord Unique
-instance Text Unique
-
diff --git a/ghc/compiler/basicTypes/Unique.lhs b/ghc/compiler/basicTypes/Unique.lhs
index ac9d7fb891..e097564781 100644
--- a/ghc/compiler/basicTypes/Unique.lhs
+++ b/ghc/compiler/basicTypes/Unique.lhs
@@ -1,7 +1,7 @@
 %
 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
 %
-\section[Unique]{The @Unique@ data type and a (monadic) supply thereof}
+\section[Unique]{The @Unique@ data type}
 
 @Uniques@ are used to distinguish entities in the compiler (@Ids@,
 @Classes@, etc.) from each other.  Thus, @Uniques@ are the basic
@@ -18,177 +18,183 @@ Haskell).
 \begin{code}
 #include "HsVersions.h"
 
+--<mkdependHS:friends> UniqSupply
+
 module Unique (
 	Unique,
-	UniqueSupply,			-- abstract types
 	u2i,				-- hack: used in UniqFM
-	getUnique, getUniques,		-- basic ops
-	eqUnique, cmpUnique,		-- comparison is everything!
-
---not exported:	mkUnique, unpkUnique,
-	mkUniqueGrimily,		-- use in SplitUniq only!
-	mkUniqueSupplyGrimily,		-- ditto! (but FALSE: WDP 95/01)
-	mkUnifiableTyVarUnique,
-	unpkUnifiableTyVarUnique,
-	showUnique, pprUnique, pprUnique10,
-
-	UniqSM(..),		-- type: unique supply monad
-	initUs, thenUs, returnUs,
-	mapUs, mapAndUnzipUs,
-
-	-- the pre-defined unique supplies:
-{- NOT exported:
-	uniqSupply_r, uniqSupply_t, uniqSupply_d,
-	uniqSupply_s, uniqSupply_c, uniqSupply_T,
-	uniqSupply_f,
-	uniqSupply_P,
--}
-	uniqSupply_u,
-#ifdef DPH
-	-- otherwise, not exported
-	uniqSupply_p, uniqSupply_S, uniqSupply_L,
-#endif
 
-	-- and the access functions for the `builtin' UniqueSupply
-	getBuiltinUniques, mkBuiltinUnique, runBuiltinUs,
-	mkPseudoUnique1, mkPseudoUnique2, mkPseudoUnique3,
+	pprUnique, pprUnique10, showUnique,
+
+	mkUnique,			-- Used in UniqSupply
+	mkUniqueGrimily,		-- Used in UniqSupply only!
 
 	-- now all the built-in Uniques (and functions to make them)
 	-- [the Oh-So-Wonderful Haskell module system wins again...]
+	mkAlphaTyVarUnique,
 	mkPrimOpIdUnique,
 	mkTupleDataConUnique,
+	mkTupleTyConUnique,
 
-	absentErrorIdKey,
-	runSTIdKey, realWorldPrimIdKey,
+	absentErrorIdKey,	-- alphabetical...
+	addrDataConKey,
+	addrPrimTyConKey,
+	addrTyConKey,
+	appendIdKey,
 	arrayPrimTyConKey,
-	byteArrayPrimTyConKey, --UNUSED: byteArrayDataConKey, byteArrayTyConKey,
+	augmentIdKey,
 	binaryClassKey,
-	boolTyConKey, buildDataConKey, buildIdKey, charDataConKey,
-	charPrimTyConKey, charTyConKey, cmpTagTyConKey,
+	boolTyConKey,
+	buildDataConKey,
+	buildIdKey,
+	byteArrayPrimTyConKey,
+	cCallableClassKey,
+	cReturnableClassKey,
+	charDataConKey,
+	charPrimTyConKey,
+	charTyConKey,
 	consDataConKey,
-	dialogueTyConKey,
 	doubleDataConKey,
 	doublePrimTyConKey,
 	doubleTyConKey,
-	enumClassKey, eqClassKey,
-	eqTagDataConKey, errorIdKey,
-	falseDataConKey, floatDataConKey,
-	floatPrimTyConKey, floatTyConKey, floatingClassKey,
-	foldlIdKey, foldrIdKey,
+	enumClassKey,
+	enumFromClassOpKey,
+	enumFromThenClassOpKey,
+	enumFromThenToClassOpKey,
+	enumFromToClassOpKey,
+	eqClassKey,
+	eqClassOpKey,
+	eqDataConKey,
+	errorIdKey,
+	falseDataConKey,
+	floatDataConKey,
+	floatPrimTyConKey,
+	floatTyConKey,
+	floatingClassKey,
+	foldlIdKey,
+	foldrIdKey,
 	forkIdKey,
 	fractionalClassKey,
-	gtTagDataConKey, --UNUSED: iOErrorTyConKey,
---UNUSED:	iOIntPrimTyConKey, -- UNUSED: int2IntegerIdKey,
+	fromIntClassOpKey,
+	fromIntegerClassOpKey,
+	fromRationalClassOpKey,
+	funTyConKey,
+	geClassOpKey,
+	gtDataConKey,
 	iOTyConKey,
 	intDataConKey,
-	wordPrimTyConKey, wordTyConKey, wordDataConKey,
-	addrPrimTyConKey, addrTyConKey, addrDataConKey,
-	intPrimTyConKey, intTyConKey,
-	integerDataConKey, integerTyConKey, integralClassKey,
+	intPrimTyConKey,
+	intTyConKey,
+	integerDataConKey,
+	integerMinusOneIdKey,
+	integerPlusOneIdKey,
+	integerPlusTwoIdKey,
+	integerTyConKey,
+	integerZeroIdKey,
+	integralClassKey,
 	ixClassKey,
---UNUSED:	lexIdKey,
-	liftDataConKey, liftTyConKey, listTyConKey,
-	ltTagDataConKey,
-	mutableArrayPrimTyConKey, -- UNUSED: mutableArrayDataConKey, mutableArrayTyConKey,
-	mutableByteArrayPrimTyConKey, -- UNUSED: mutableByteArrayDataConKey,
---UNUSED:	mutableByteArrayTyConKey,
-	synchVarPrimTyConKey,
-	nilDataConKey, numClassKey, ordClassKey,
-	parIdKey, parErrorIdKey,
-#ifdef GRAN
-	parGlobalIdKey, parLocalIdKey, copyableIdKey, noFollowIdKey,
-#endif
+	liftDataConKey,
+	liftTyConKey,
+	listTyConKey,
+	ltDataConKey,
+	mainIdKey,
+	mainPrimIOIdKey,
+	mallocPtrDataConKey,
+	mallocPtrPrimTyConKey,
+	mallocPtrTyConKey,
+	monadClassKey,
+	monadZeroClassKey,
+	mutableArrayPrimTyConKey,
+	mutableByteArrayPrimTyConKey,
+	negateClassOpKey,
+	nilDataConKey,
+	numClassKey,
+	ordClassKey,
+	orderingTyConKey,
+	packCStringIdKey,
+	parErrorIdKey,
+	parIdKey,
 	patErrorIdKey,
-	ratioDataConKey, ratioTyConKey,
+	primIoTyConKey,
+	ratioDataConKey,
+	ratioTyConKey,
 	rationalTyConKey,
---UNUSED:	readParenIdKey,
-	realClassKey, realFloatClassKey,
+	readClassKey,
+	realClassKey,
+	realFloatClassKey,
 	realFracClassKey,
---UNUSED:	requestTyConKey, responseTyConKey,
-	return2GMPsDataConKey, return2GMPsTyConKey,
-	returnIntAndGMPDataConKey, returnIntAndGMPTyConKey,
-	seqIdKey, -- UNUSED: seqIntPrimTyConKey,
---UNUSED:	seqTyConKey,
---UNUSED:	showParenIdKey,
---UNUSED:	showSpaceIdKey,
-	statePrimTyConKey, stateTyConKey, stateDataConKey,
-	voidPrimTyConKey,
+	realWorldPrimIdKey,
 	realWorldTyConKey,
-	stablePtrPrimTyConKey, stablePtrTyConKey, stablePtrDataConKey,
-	mallocPtrPrimTyConKey, mallocPtrTyConKey, mallocPtrDataConKey,
-	stateAndPtrPrimTyConKey,
-	stateAndPtrPrimDataConKey,
-	stateAndCharPrimTyConKey,
+	return2GMPsDataConKey,
+	return2GMPsTyConKey,
+	returnIntAndGMPDataConKey,
+	returnIntAndGMPTyConKey,
+	runSTIdKey,
+	seqIdKey,
+	showClassKey,
+	stTyConKey,
+	stablePtrDataConKey,
+	stablePtrPrimTyConKey,
+	stablePtrTyConKey,
+	stateAndAddrPrimDataConKey,
+	stateAndAddrPrimTyConKey,
+	stateAndArrayPrimDataConKey,
+	stateAndArrayPrimTyConKey,
+	stateAndByteArrayPrimDataConKey,
+	stateAndByteArrayPrimTyConKey,
 	stateAndCharPrimDataConKey,
-	stateAndIntPrimTyConKey,
+	stateAndCharPrimTyConKey,
+	stateAndDoublePrimDataConKey,
+	stateAndDoublePrimTyConKey,
+	stateAndFloatPrimDataConKey,
+	stateAndFloatPrimTyConKey,
 	stateAndIntPrimDataConKey,
-	stateAndWordPrimTyConKey,
-	stateAndWordPrimDataConKey,
-	stateAndAddrPrimTyConKey,
-	stateAndAddrPrimDataConKey,
-	stateAndStablePtrPrimTyConKey,
-	stateAndStablePtrPrimDataConKey,
-	stateAndMallocPtrPrimTyConKey,
+	stateAndIntPrimTyConKey,
 	stateAndMallocPtrPrimDataConKey,
-	stateAndFloatPrimTyConKey,
-	stateAndFloatPrimDataConKey,
-	stateAndDoublePrimTyConKey,
-	stateAndDoublePrimDataConKey,
-	stateAndArrayPrimTyConKey,
-	stateAndArrayPrimDataConKey,
-	stateAndMutableArrayPrimTyConKey,
+	stateAndMallocPtrPrimTyConKey,
 	stateAndMutableArrayPrimDataConKey,
-	stateAndByteArrayPrimTyConKey,
-	stateAndByteArrayPrimDataConKey,
-	stateAndMutableByteArrayPrimTyConKey,
+	stateAndMutableArrayPrimTyConKey,
 	stateAndMutableByteArrayPrimDataConKey,
-	stateAndSynchVarPrimTyConKey,
+	stateAndMutableByteArrayPrimTyConKey,
+	stateAndPtrPrimDataConKey,
+	stateAndPtrPrimTyConKey,
+	stateAndStablePtrPrimDataConKey,
+	stateAndStablePtrPrimTyConKey,
 	stateAndSynchVarPrimDataConKey,
+	stateAndSynchVarPrimTyConKey,
+	stateAndWordPrimDataConKey,
+	stateAndWordPrimTyConKey,
+	stateDataConKey,
+	statePrimTyConKey,
+	stateTyConKey,
 	stringTyConKey,
-	stTyConKey, primIoTyConKey,
---UNUSED:	ioResultTyConKey,
-	textClassKey,
+	synchVarPrimTyConKey,
 	traceIdKey,
 	trueDataConKey,
 	unpackCString2IdKey,
 	unpackCStringAppendIdKey,
 	unpackCStringFoldrIdKey,
 	unpackCStringIdKey,
-	augmentIdKey,
-	appendIdKey,
---NO:	rangeComplaintIdKey,
-	packCStringIdKey,
-	integerZeroIdKey, integerPlusOneIdKey,
-	integerPlusTwoIdKey, integerMinusOneIdKey,
 	voidPrimIdKey,
-	cCallableClassKey,
-	cReturnableClassKey,
---UNUSED:	packedStringTyConKey, psDataConKey, cpsDataConKey,
-
-	-- to make interface self-sufficient
-	PrimOp, SplitUniqSupply, CSeq
-
-#ifndef __GLASGOW_HASKELL__
-	, TAG_
+	voidPrimTyConKey,
+	wordDataConKey,
+	wordPrimTyConKey,
+	wordTyConKey
+#ifdef GRAN
+	, copyableIdKey
+	, noFollowIdKey
+	, parGlobalIdKey
+	, parLocalIdKey
 #endif
+	-- to make interface self-sufficient
     ) where
 
-import Outputable	-- class for printing, forcing
-import Pretty
-import PrimOps		-- ** DIRECTLY **
-import SplitUniq
-import Util
-
-#ifndef __GLASGOW_HASKELL__
-{-hide import from mkdependHS-}
-import
-	Word
-#endif
-#ifdef __GLASGOW_HASKELL__
 import PreludeGlaST
-#endif
 
-infixr 9 `thenUs`
+import Ubiq{-uitous-}
+
+import Pretty
+import Util
 \end{code}
 
 %************************************************************************
@@ -203,17 +209,8 @@ Fast comparison is everything on @Uniques@:
 \begin{code}
 u2i :: Unique -> FAST_INT
 
-#ifdef __GLASGOW_HASKELL__
-
 data Unique = MkUnique Int#
 u2i (MkUnique i) = i
-
-#else
-
-data Unique = MkUnique Word{-#STRICT#-}
-u2i (MkUnique w) = wordToInt w
-
-#endif
 \end{code}
 
 Now come the functions which construct uniques from their pieces, and vice versa.
@@ -226,20 +223,12 @@ unpkUnique		 :: Unique -> (Char, Int)	-- The reverse
 mkUnifiableTyVarUnique	 :: Int -> Unique	-- Injects a subst-array index into the Unique type
 unpkUnifiableTyVarUnique :: Unique -> Int	-- The reverse process
 
-#ifdef __GLASGOW_HASKELL__
-mkUniqueGrimily :: Int# -> Unique		-- A trap-door for SplitUniq
-#else
-mkUniqueGrimily :: Int -> Unique
-#endif
+mkUniqueGrimily :: Int# -> Unique		-- A trap-door for UniqSupply
 \end{code}
 
 
 \begin{code}
-#ifdef __GLASGOW_HASKELL__
 mkUniqueGrimily x = MkUnique x
-#else
-mkUniqueGrimily x = MkUnique (fromInteger (toInteger x))
-#endif
 
 mkUnifiableTyVarUnique i = mkUnique '_'{-MAGIC CHAR-} i
 
@@ -250,8 +239,6 @@ unpkUnifiableTyVarUnique uniq
 
 -- pop the Char in the top 8 bits of the Unique(Supply)
 
-#ifdef __GLASGOW_HASKELL__
-
 -- No 64-bit bugs here, as long as we have at least 32 bits. --JSM
 
 w2i x = word2Int# x
@@ -267,26 +254,8 @@ unpkUnique (MkUnique u)
 	i   = MkInt  (w2i ((i2w u) `and#` (i2w 16777215#){-``0x00ffffff''-}))
     in
     (tag, i)
-# if __GLASGOW_HASKELL__ >= 23
   where
     shiftr x y = shiftRA# x y
-# else
-    shiftr x y = shiftR#  x y
-# endif
-
-#else {-probably HBC-}
-
-mkUnique c i
-  = MkUnique (((fromInt (ord c)) `bitLsh` 24) `bitOr` (fromInt i))
-
-unpkUnique (MkUnique u)
-  = let
-	tag = chr (wordToInt (u `bitRsh` 24))
-	i   = wordToInt (u `bitAnd` 16777215 {-0x00ffffff-})
-    in
-    (tag, i)
-
-#endif	{-probably HBC-}
 \end{code}
 
 %************************************************************************
@@ -300,11 +269,6 @@ use `deriving' because we want {\em precise} control of ordering
 (equality on @Uniques@ is v common).
 
 \begin{code}
-#ifdef __GLASGOW_HASKELL__
-
-{-# INLINE eqUnique  #-} -- this is Hammered City here...
-{-# INLINE cmpUnique #-}
-
 eqUnique (MkUnique u1) (MkUnique u2) = u1 ==# u2
 ltUnique (MkUnique u1) (MkUnique u2) = u1 <#  u2
 leUnique (MkUnique u1) (MkUnique u2) = u1 <=# u2
@@ -312,15 +276,6 @@ leUnique (MkUnique u1) (MkUnique u2) = u1 <=# u2
 cmpUnique (MkUnique u1) (MkUnique u2)
   = if u1 ==# u2 then EQ_ else if u1 <# u2 then LT_ else GT_
 
-#else
-eqUnique (MkUnique u1) (MkUnique u2) = u1 == u2
-ltUnique (MkUnique u1) (MkUnique u2) = u1 <  u2
-leUnique (MkUnique u1) (MkUnique u2) = u1 <= u2
-
-cmpUnique (MkUnique u1) (MkUnique u2)
-  = if u1 == u2 then EQ_ else if u1 < u2 then LT_ else GT_
-#endif
-
 instance Eq Unique where
     a == b = eqUnique a b
     a /= b = not (eqUnique a b)
@@ -330,19 +285,11 @@ instance Ord Unique where
     a <= b = leUnique a b
     a  > b = not (leUnique a b)
     a >= b = not (ltUnique a b)
-#ifdef __GLASGOW_HASKELL__
     _tagCmp a b = case cmpUnique a b of { LT_ -> _LT; EQ_ -> _EQ; GT__ -> _GT }
-#endif
-\end{code}
 
-And for output:
-\begin{code}
-{- OLD:
-instance Outputable Unique where
-   ppr any_style uniq
-     = case unpkUnique uniq of
-	 (tag, u) -> ppStr (tag : iToBase62 u)
--}
+instance Ord3 Unique where
+    cmp = cmpUnique
+
 \end{code}
 
 We do sometimes make strings with @Uniques@ in them:
@@ -360,9 +307,15 @@ pprUnique10 uniq	-- in base-10, dudes
 showUnique :: Unique -> FAST_STRING
 showUnique uniq = _PK_ (ppShow 80 (pprUnique uniq))
 
+instance Outputable Unique where
+    ppr sty u = pprUnique u
+
 instance Text Unique where
     showsPrec p uniq rest = _UNPK_ (showUnique uniq)
     readsPrec p = panic "no readsPrec for Unique"
+
+instance NamedThing Unique where
+    getItsUnique u = u
 \end{code}
 
 %************************************************************************
@@ -377,13 +330,12 @@ Code stolen from Lennart.
 \begin{code}
 iToBase62 :: Int -> Pretty
 
-#ifdef __GLASGOW_HASKELL__
 iToBase62 n@(I# n#)
   = ASSERT(n >= 0)
     let
 	bytes = case chars62 of { _ByteArray bounds_who_needs_'em bytes -> bytes }
     in
-    if n# <# 62# then 
+    if n# <# 62# then
 	case (indexCharArray# bytes n#) of { c ->
 	ppChar (C# c) }
     else
@@ -407,21 +359,6 @@ chars62
       | otherwise
       = writeCharArray ch_array i (str !! i)	`seqStrictlyST`
 	fill_in ch_array (i+1) lim str
-
-#else {- not GHC -}
-iToBase62 n
-  = ASSERT(n >= 0)
-    if n < 62 then 
-	ppChar (chars62 ! n)
-    else
-	case (quotRem n 62) of { (q, r) ->
-	ppBeside (iToBase62 q) (ppChar (chars62 ! r)) }
-
--- keep this at top level! (bug on 94/10/24 WDP)
-chars62 :: Array Int Char
-chars62
-  = array (0,61) (zipWith (:=) [0..] "0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ")
-#endif {- not GHC -}
 \end{code}
 
 %************************************************************************
@@ -430,13 +367,25 @@ chars62
 %*									*
 %************************************************************************
 
+Allocation of unique supply characters:
+	a-z: lower case chars for unique supplies (see Main.lhs)
+	B:   builtin		(see UniqSupply.lhs)
+	C-E: pseudo uniques	(see UniqSupply.lhs)
+	_:   unifiable tyvars   (above)
+	1-8: prelude things below
+
 \begin{code}
-mkPreludeClassUnique i		= mkUnique '1' i
-mkPreludeTyConUnique i		= mkUnique '2' i
-mkPreludeDataConUnique i	= mkUnique 'Y' i -- must be alphabetic
-mkTupleDataConUnique i		= mkUnique 'Z' i -- ditto (*may* be used in C labels)
--- mkPrimOpIdUnique op: see below (uses '5')
-mkPreludeMiscIdUnique i		= mkUnique '7' i
+mkAlphaTyVarUnique i		= mkUnique '1' i
+
+mkPreludeClassUnique i		= mkUnique '2' i
+mkPreludeTyConUnique i		= mkUnique '3' i
+mkTupleTyConUnique a		= mkUnique '4' a
+
+mkPreludeDataConUnique i	= mkUnique '5' i 	-- must be alphabetic
+mkTupleDataConUnique a		= mkUnique '6' a	-- ditto (*may* be used in C labels)
+
+mkPrimOpIdUnique op		= mkUnique '7' op
+mkPreludeMiscIdUnique i		= mkUnique '8' i
 \end{code}
 
 %************************************************************************
@@ -457,14 +406,13 @@ realFracClassKey	= mkPreludeClassUnique 8
 realFloatClassKey	= mkPreludeClassUnique 9
 ixClassKey		= mkPreludeClassUnique 10
 enumClassKey		= mkPreludeClassUnique 11
-textClassKey		= mkPreludeClassUnique 12
-binaryClassKey		= mkPreludeClassUnique 13
-cCallableClassKey	= mkPreludeClassUnique 14
-cReturnableClassKey	= mkPreludeClassUnique 15
-#ifdef DPH
-pidClassKey		= mkPreludeClassUnique 16
-processorClassKey	= mkPreludeClassUnique 17
-#endif {- Data Parallel Haskell -}
+showClassKey		= mkPreludeClassUnique 12
+readClassKey		= mkPreludeClassUnique 13
+monadClassKey		= mkPreludeClassUnique 14
+monadZeroClassKey	= mkPreludeClassUnique 15
+binaryClassKey		= mkPreludeClassUnique 16
+cCallableClassKey	= mkPreludeClassUnique 17	
+cReturnableClassKey	= mkPreludeClassUnique 18
 \end{code}
 
 %************************************************************************
@@ -479,72 +427,54 @@ addrTyConKey				= mkPreludeTyConUnique	2
 arrayPrimTyConKey			= mkPreludeTyConUnique	3
 boolTyConKey				= mkPreludeTyConUnique	4
 byteArrayPrimTyConKey			= mkPreludeTyConUnique	5
---UNUSED:byteArrayTyConKey			= mkPreludeTyConUnique	6
 charPrimTyConKey			= mkPreludeTyConUnique	7
 charTyConKey				= mkPreludeTyConUnique  8
-cmpTagTyConKey				= mkPreludeTyConUnique  9
-dialogueTyConKey			= mkPreludeTyConUnique 10
-doublePrimTyConKey			= mkPreludeTyConUnique 11
-doubleTyConKey				= mkPreludeTyConUnique 12
-floatPrimTyConKey			= mkPreludeTyConUnique 13
-floatTyConKey				= mkPreludeTyConUnique 14
---UNUSED:iOErrorTyConKey				= mkPreludeTyConUnique 14
---UNUSED:iOIntPrimTyConKey			= mkPreludeTyConUnique 15
-iOTyConKey				= mkPreludeTyConUnique 16
-intPrimTyConKey				= mkPreludeTyConUnique 17
-intTyConKey				= mkPreludeTyConUnique 18
-integerTyConKey				= mkPreludeTyConUnique 19
-liftTyConKey				= mkPreludeTyConUnique 20
-listTyConKey				= mkPreludeTyConUnique 21
-mallocPtrPrimTyConKey			= mkPreludeTyConUnique 22
-mallocPtrTyConKey			= mkPreludeTyConUnique 23
-mutableArrayPrimTyConKey		= mkPreludeTyConUnique 24
---UNUSED:mutableArrayTyConKey			= mkPreludeTyConUnique 25
-mutableByteArrayPrimTyConKey		= mkPreludeTyConUnique 26
---UNUSED:mutableByteArrayTyConKey		= mkPreludeTyConUnique 27
---UNUSED:packedStringTyConKey			= mkPreludeTyConUnique 28
-synchVarPrimTyConKey		    	= mkPreludeTyConUnique 29
-ratioTyConKey				= mkPreludeTyConUnique 30
-rationalTyConKey			= mkPreludeTyConUnique 31
-realWorldTyConKey			= mkPreludeTyConUnique 32
---UNUSED:requestTyConKey				= mkPreludeTyConUnique 33
---UNUSED:responseTyConKey			= mkPreludeTyConUnique 34
-return2GMPsTyConKey			= mkPreludeTyConUnique 35
-returnIntAndGMPTyConKey			= mkPreludeTyConUnique 36
---UNUSED:seqIntPrimTyConKey			= mkPreludeTyConUnique 37
---UNUSED:seqTyConKey				= mkPreludeTyConUnique 38
-stablePtrPrimTyConKey			= mkPreludeTyConUnique 39
-stablePtrTyConKey			= mkPreludeTyConUnique 40
-stateAndAddrPrimTyConKey		= mkPreludeTyConUnique 41
-stateAndArrayPrimTyConKey		= mkPreludeTyConUnique 42
-stateAndByteArrayPrimTyConKey		= mkPreludeTyConUnique 43
-stateAndCharPrimTyConKey		= mkPreludeTyConUnique 44
-stateAndDoublePrimTyConKey		= mkPreludeTyConUnique 45
-stateAndFloatPrimTyConKey		= mkPreludeTyConUnique 46
-stateAndIntPrimTyConKey			= mkPreludeTyConUnique 47
-stateAndMallocPtrPrimTyConKey		= mkPreludeTyConUnique 48
-stateAndMutableArrayPrimTyConKey	= mkPreludeTyConUnique 49
-stateAndMutableByteArrayPrimTyConKey	= mkPreludeTyConUnique 50
-stateAndSynchVarPrimTyConKey	    	= mkPreludeTyConUnique 51
-stateAndPtrPrimTyConKey			= mkPreludeTyConUnique 52
-stateAndStablePtrPrimTyConKey		= mkPreludeTyConUnique 53
-stateAndWordPrimTyConKey		= mkPreludeTyConUnique 54
-statePrimTyConKey			= mkPreludeTyConUnique 55
-stateTyConKey				= mkPreludeTyConUnique 56
-stringTyConKey				= mkPreludeTyConUnique 57
-stTyConKey				= mkPreludeTyConUnique 58
-primIoTyConKey				= mkPreludeTyConUnique 59
---UNUSED:ioResultTyConKey			= mkPreludeTyConUnique 60
-voidPrimTyConKey			= mkPreludeTyConUnique 61
-wordPrimTyConKey			= mkPreludeTyConUnique 62 
-wordTyConKey				= mkPreludeTyConUnique 63
-							       
-#ifdef DPH
-podTyConKey				= mkPreludeTyConUnique 64
-interfacePodTyConKey			= mkPreludeTyConUnique 65
-
-podizedPodTyConKey _ = panic "ToDo:DPH:podizedPodTyConKey"
-#endif {- Data Parallel Haskell -}
+doublePrimTyConKey			= mkPreludeTyConUnique  9
+doubleTyConKey				= mkPreludeTyConUnique 10 
+floatPrimTyConKey			= mkPreludeTyConUnique 11
+floatTyConKey				= mkPreludeTyConUnique 12
+funTyConKey				= mkPreludeTyConUnique 13
+iOTyConKey				= mkPreludeTyConUnique 14
+intPrimTyConKey				= mkPreludeTyConUnique 15
+intTyConKey				= mkPreludeTyConUnique 16
+integerTyConKey				= mkPreludeTyConUnique 17
+liftTyConKey				= mkPreludeTyConUnique 18
+listTyConKey				= mkPreludeTyConUnique 19
+mallocPtrPrimTyConKey			= mkPreludeTyConUnique 20
+mallocPtrTyConKey			= mkPreludeTyConUnique 21
+mutableArrayPrimTyConKey		= mkPreludeTyConUnique 22
+mutableByteArrayPrimTyConKey		= mkPreludeTyConUnique 23
+orderingTyConKey			= mkPreludeTyConUnique 24
+synchVarPrimTyConKey		    	= mkPreludeTyConUnique 25
+ratioTyConKey				= mkPreludeTyConUnique 26
+rationalTyConKey			= mkPreludeTyConUnique 27
+realWorldTyConKey			= mkPreludeTyConUnique 28
+return2GMPsTyConKey			= mkPreludeTyConUnique 29
+returnIntAndGMPTyConKey			= mkPreludeTyConUnique 30
+stablePtrPrimTyConKey			= mkPreludeTyConUnique 31
+stablePtrTyConKey			= mkPreludeTyConUnique 32
+stateAndAddrPrimTyConKey		= mkPreludeTyConUnique 33
+stateAndArrayPrimTyConKey		= mkPreludeTyConUnique 34
+stateAndByteArrayPrimTyConKey		= mkPreludeTyConUnique 35
+stateAndCharPrimTyConKey		= mkPreludeTyConUnique 36
+stateAndDoublePrimTyConKey		= mkPreludeTyConUnique 37
+stateAndFloatPrimTyConKey		= mkPreludeTyConUnique 38
+stateAndIntPrimTyConKey			= mkPreludeTyConUnique 39
+stateAndMallocPtrPrimTyConKey		= mkPreludeTyConUnique 40
+stateAndMutableArrayPrimTyConKey	= mkPreludeTyConUnique 41
+stateAndMutableByteArrayPrimTyConKey	= mkPreludeTyConUnique 42
+stateAndSynchVarPrimTyConKey	    	= mkPreludeTyConUnique 43
+stateAndPtrPrimTyConKey			= mkPreludeTyConUnique 44
+stateAndStablePtrPrimTyConKey		= mkPreludeTyConUnique 45
+stateAndWordPrimTyConKey		= mkPreludeTyConUnique 46
+statePrimTyConKey			= mkPreludeTyConUnique 47
+stateTyConKey				= mkPreludeTyConUnique 48
+stringTyConKey				= mkPreludeTyConUnique 49
+stTyConKey				= mkPreludeTyConUnique 50
+primIoTyConKey				= mkPreludeTyConUnique 51
+voidPrimTyConKey			= mkPreludeTyConUnique 52
+wordPrimTyConKey			= mkPreludeTyConUnique 53
+wordTyConKey				= mkPreludeTyConUnique 54
 \end{code}
 
 %************************************************************************
@@ -556,24 +486,19 @@ podizedPodTyConKey _ = panic "ToDo:DPH:podizedPodTyConKey"
 \begin{code}
 addrDataConKey				= mkPreludeDataConUnique  1
 buildDataConKey				= mkPreludeDataConUnique  2
---UNUSED:byteArrayDataConKey			= mkPreludeDataConUnique  3
 charDataConKey				= mkPreludeDataConUnique  4
 consDataConKey				= mkPreludeDataConUnique  5
 doubleDataConKey			= mkPreludeDataConUnique  6
-eqTagDataConKey				= mkPreludeDataConUnique  7
+eqDataConKey				= mkPreludeDataConUnique  7
 falseDataConKey				= mkPreludeDataConUnique  8
 floatDataConKey				= mkPreludeDataConUnique  9
-gtTagDataConKey				= mkPreludeDataConUnique 10
+gtDataConKey				= mkPreludeDataConUnique 10
 intDataConKey				= mkPreludeDataConUnique 11
 integerDataConKey			= mkPreludeDataConUnique 12
 liftDataConKey				= mkPreludeDataConUnique 13
-ltTagDataConKey				= mkPreludeDataConUnique 14
+ltDataConKey				= mkPreludeDataConUnique 14
 mallocPtrDataConKey			= mkPreludeDataConUnique 15
---UNUSED:mutableArrayDataConKey			= mkPreludeDataConUnique 16
---UNUSED:mutableByteArrayDataConKey		= mkPreludeDataConUnique 17
 nilDataConKey				= mkPreludeDataConUnique 18
---UNUSED:psDataConKey				= mkPreludeDataConUnique 19
---UNUSED:cpsDataConKey				= mkPreludeDataConUnique 20
 ratioDataConKey				= mkPreludeDataConUnique 21
 return2GMPsDataConKey			= mkPreludeDataConUnique 22
 returnIntAndGMPDataConKey		= mkPreludeDataConUnique 23
@@ -595,10 +520,6 @@ stateAndWordPrimDataConKey		= mkPreludeDataConUnique 38
 stateDataConKey				= mkPreludeDataConUnique 39
 trueDataConKey				= mkPreludeDataConUnique 40
 wordDataConKey				= mkPreludeDataConUnique 41
-
-#ifdef DPH
-interfacePodDataConKey			= mkPreludeDataConUnique 42
-#endif {- Data Parallel Haskell -}
 \end{code}
 
 %************************************************************************
@@ -607,23 +528,15 @@ interfacePodDataConKey			= mkPreludeDataConUnique 42
 %*									*
 %************************************************************************
 
-First, for raw @PrimOps@ and their boxed versions:
-\begin{code}
-mkPrimOpIdUnique :: PrimOp -> Unique
-
-mkPrimOpIdUnique op = mkUnique '5' IBOX((tagOf_PrimOp op))
-\end{code}
-
-Now for other non-@DataCon@ @Ids@:
 \begin{code}
 absentErrorIdKey	= mkPreludeMiscIdUnique	 1
 appendIdKey 		= mkPreludeMiscIdUnique  2
-augmentIdKey		= mkPreludeMiscIdUnique	 3  
+augmentIdKey		= mkPreludeMiscIdUnique	 3
 buildIdKey		= mkPreludeMiscIdUnique	 4
 errorIdKey		= mkPreludeMiscIdUnique	 5
 foldlIdKey		= mkPreludeMiscIdUnique	 6
 foldrIdKey		= mkPreludeMiscIdUnique	 7
-forkIdKey   	    	= mkPreludeMiscIdUnique  8 
+forkIdKey   	    	= mkPreludeMiscIdUnique  8
 int2IntegerIdKey	= mkPreludeMiscIdUnique	 9
 integerMinusOneIdKey	= mkPreludeMiscIdUnique	10
 integerPlusOneIdKey	= mkPreludeMiscIdUnique	11
@@ -632,8 +545,7 @@ integerZeroIdKey	= mkPreludeMiscIdUnique	13
 packCStringIdKey	= mkPreludeMiscIdUnique	14
 parErrorIdKey		= mkPreludeMiscIdUnique	15
 parIdKey		= mkPreludeMiscIdUnique	16
-patErrorIdKey		= mkPreludeMiscIdUnique	25
---NO:rangeComplaintIdKey	= mkPreludeMiscIdUnique	17
+patErrorIdKey		= mkPreludeMiscIdUnique	17
 realWorldPrimIdKey	= mkPreludeMiscIdUnique 18
 runSTIdKey		= mkPreludeMiscIdUnique 19
 seqIdKey		= mkPreludeMiscIdUnique 20
@@ -643,234 +555,33 @@ unpackCStringAppendIdKey= mkPreludeMiscIdUnique	23
 unpackCStringFoldrIdKey	= mkPreludeMiscIdUnique 24
 unpackCStringIdKey	= mkPreludeMiscIdUnique	25
 voidPrimIdKey		= mkPreludeMiscIdUnique	26
+mainIdKey		= mkPreludeMiscIdUnique	27
+mainPrimIOIdKey		= mkPreludeMiscIdUnique	28
 
 #ifdef GRAN
-parLocalIdKey		= mkPreludeMiscIdUnique 27
-parGlobalIdKey		= mkPreludeMiscIdUnique 28
-noFollowIdKey		= mkPreludeMiscIdUnique 29
-copyableIdKey		= mkPreludeMiscIdUnique 30
-#endif
-
-#ifdef DPH
-podSelectorIdKey	= mkPreludeMiscIdUnique 31
-#endif {- Data Parallel Haskell -}
-\end{code}
-
-%************************************************************************
-%*									*
-\subsection[UniqueSupply-type]{@UniqueSupply@ type and operations}
-%*									*
-%************************************************************************
-
-\begin{code}
-#ifdef __GLASGOW_HASKELL__
-data UniqueSupply
-  = MkUniqueSupply  Int#
-  | MkNewSupply	    SplitUniqSupply
-
-#else
-data UniqueSupply
-  = MkUniqueSupply  Word{-#STRICT#-}
-  | MkNewSupply	    SplitUniqSupply
-#endif
-\end{code}
-
-@mkUniqueSupply@ is used to get a @UniqueSupply@ started.
-\begin{code}
-mkUniqueSupply :: Char -> UniqueSupply
-
-#ifdef __GLASGOW_HASKELL__
-
-mkUniqueSupply (MkChar c#)
-  = MkUniqueSupply (w2i ((i2w (ord# c#)) `shiftL#` (i2w_s 24#)))
-
-#else
-
-mkUniqueSupply c
-  = MkUniqueSupply ((fromInt (ord c)) `bitLsh` 24)
-
-#endif
-
-mkUniqueSupplyGrimily s = MkNewSupply s
-\end{code}
-
-The basic operation on a @UniqueSupply@ is to get a @Unique@ (or a
-few).  It's just plain different when splittable vs.~not...
-\begin{code}
-getUnique :: UniqueSupply -> (UniqueSupply, Unique)
-
-getUnique (MkUniqueSupply n)
-#ifdef __GLASGOW_HASKELL__
-  = (MkUniqueSupply (n +# 1#), MkUnique n)
-#else
-  = (MkUniqueSupply (n + 1), MkUnique n)
-#endif
-getUnique (MkNewSupply s)
-  = let
-	(u, s1) = getSUniqueAndDepleted s
-    in
-    (MkNewSupply s1, u)
-
-getUniques :: Int		-- how many you want
-	   -> UniqueSupply
-	   -> (UniqueSupply, [Unique])
-
-#ifdef __GLASGOW_HASKELL__
-getUniques i@(MkInt i#) (MkUniqueSupply n)
-  = (MkUniqueSupply (n +# i#),
-     [ case x of { MkInt x# ->
-	 MkUnique (n +# x#) } | x <- [0 .. i-1] ])
-#else
-getUniques i (MkUniqueSupply n)
-  = (MkUniqueSupply (n + fromInt i), [ MkUnique (n + fromInt x) | x <- [0 .. i-1] ])
-#endif
-getUniques i (MkNewSupply s)
-  = let
-	(us, s1) = getSUniquesAndDepleted i s
-    in
-    (MkNewSupply s1, us)
-\end{code}
-
-[OLD-ish NOTE] Simon says: The last line is preferable over @(n+i,
-<mumble> [n .. (n+i-1)])@, because it is a little lazier.  If n=bot
-you get ([bot, bot, bot], bot) back instead of (bot,bot).  This is
-sometimes important for knot-tying.
-
-Alternatively, if you hate the inefficiency:
-\begin{pseudocode}
-(range 0, n+i)	where range m | m=i = []
-		      range m	    = n+m : range (m+1)
-\end{pseudocode}
-
-%************************************************************************
-%*									*
-\subsection[UniqueSupplies-compiler]{@UniqueSupplies@ specific to the compiler}
-%*									*
-%************************************************************************
-
-Different parts of the compiler have their own @UniqueSupplies@, each
-identified by their ``tag letter:''
-\begin{verbatim}
-    B		builtin; for when the compiler conjures @Uniques@ out of
-		thin air
-    b		a second builtin; we need two in mkWrapperUnfolding (False)
-    r		renamer
-    t		typechecker
-    d		desugarer
-    p		``podizer'' (DPH only)
-    s		core-to-core simplifier
-    S		``pod'' simplifier (DPH only)
-    c		core-to-stg
-    T		stg-to-stg simplifier
-    f		flattener (of abstract~C)
-    L		Assembly labels (for native-code generators)
-    u		Printing out unfoldings (so don't have constant renaming)
-    P		profiling (finalCCstg)
-
-    v		used in specialised TyVarUniques (see TyVar.lhs)
-
-    1-9		used for ``prelude Uniques'' (wired-in things; see below)
-		1 = classes
-		2 = tycons
-		3 = data cons
-		4 = tuple datacons
-		5 = unboxed-primop ids
-		6 = boxed-primop ids
-		7 = misc ids
-\end{verbatim}
-
-\begin{code}
-uniqSupply_r = mkUniqueSupply 'r'
-uniqSupply_t = mkUniqueSupply 't'
-uniqSupply_d = mkUniqueSupply 'd'
-uniqSupply_p = mkUniqueSupply 'p'
-uniqSupply_s = mkUniqueSupply 's'
-uniqSupply_S = mkUniqueSupply 'S'
-uniqSupply_c = mkUniqueSupply 'c'
-uniqSupply_T = mkUniqueSupply 'T'
-uniqSupply_f = mkUniqueSupply 'f'
-uniqSupply_L = mkUniqueSupply 'L'
-uniqSupply_u = mkUniqueSupply 'u'
-uniqSupply_P = mkUniqueSupply 'P'
-\end{code}
-
-The ``builtin UniqueSupplies'' are more magical.  You don't use the
-supply, you ask for @Uniques@ directly from it.	 (They probably aren't
-unique, but you know that!)
-
-\begin{code}
-uniqSupply_B = mkUniqueSupply 'B' -- not exported!
-uniqSupply_b = mkUniqueSupply 'b' -- not exported!
-\end{code}
-
-\begin{code}
-mkPseudoUnique1, mkPseudoUnique2, mkPseudoUnique3,
- mkBuiltinUnique :: Int -> Unique
-
-mkBuiltinUnique i = mkUnique 'B' i
-mkPseudoUnique1 i = mkUnique 'C' i -- used for getTheUnique on Regs
-mkPseudoUnique2 i = mkUnique 'D' i -- ditto
-mkPseudoUnique3 i = mkUnique 'E' i -- ditto
-
-getBuiltinUniques :: Int -> [Unique]
-getBuiltinUniques n = map (mkUnique 'B') [1 .. n]
-\end{code}
-
-The following runs a uniq monad expression, using builtin uniq values:
-\begin{code}
-runBuiltinUs :: UniqSM a -> a
-runBuiltinUs m = snd (initUs uniqSupply_B m)
-\end{code}
-
-%************************************************************************
-%*									*
-\subsection[Unique-monad]{Unique supply monad}
-%*									*
-%************************************************************************
-
-A very plain unique-supply monad.
-
-\begin{code}
-type UniqSM result = UniqueSupply -> (UniqueSupply, result)
-
--- the initUs function also returns the final UniqueSupply
-
-initUs :: UniqueSupply -> UniqSM a -> (UniqueSupply, a)
-
-initUs init_us m = m init_us
-
-#ifdef __GLASGOW_HASKELL__
-{-# INLINE thenUs #-}
-{-# INLINE returnUs #-}
+parLocalIdKey		= mkPreludeMiscIdUnique 29
+parGlobalIdKey		= mkPreludeMiscIdUnique 30
+noFollowIdKey		= mkPreludeMiscIdUnique 31
+copyableIdKey		= mkPreludeMiscIdUnique 32
 #endif
 \end{code}
 
-@thenUs@ is are where we split the @UniqueSupply@.
-\begin{code}
-thenUs :: UniqSM a -> (a -> UniqSM b) -> UniqSM b
-
-thenUs expr cont us
-  = case (expr us) of
-      (us1, result) -> cont result us1
+Certain class operations from Prelude classes.  They get
+their own uniques so we can look them up easily when we want
+to conjure them up during type checking.        
+\begin{code}					  
+fromIntClassOpKey	= mkPreludeMiscIdUnique 33
+fromIntegerClassOpKey	= mkPreludeMiscIdUnique 34
+fromRationalClassOpKey	= mkPreludeMiscIdUnique 35
+enumFromClassOpKey	= mkPreludeMiscIdUnique 36
+enumFromThenClassOpKey	= mkPreludeMiscIdUnique 37
+enumFromToClassOpKey	= mkPreludeMiscIdUnique 38
+enumFromThenToClassOpKey= mkPreludeMiscIdUnique 39
+eqClassOpKey		= mkPreludeMiscIdUnique 40
+geClassOpKey		= mkPreludeMiscIdUnique 41
+negateClassOpKey	= mkPreludeMiscIdUnique 42
 \end{code}
 
-\begin{code}
-returnUs :: a -> UniqSM a
-returnUs result us = (us, result)
-
-mapUs :: (a -> UniqSM b) -> [a] -> UniqSM [b]
 
-mapUs f []     = returnUs []
-mapUs f (x:xs)
-  = f x		`thenUs` \ r  ->
-    mapUs f xs	`thenUs` \ rs ->
-    returnUs (r:rs)
 
-mapAndUnzipUs  :: (a -> UniqSM (b,c))	-> [a] -> UniqSM ([b],[c])
 
-mapAndUnzipUs f [] = returnUs ([],[])
-mapAndUnzipUs f (x:xs)
-  = f x			`thenUs` \ (r1,	 r2)  ->
-    mapAndUnzipUs f xs	`thenUs` \ (rs1, rs2) ->
-    returnUs (r1:rs1, r2:rs2)
-\end{code}
diff --git a/ghc/compiler/codeGen/CgBindery.hi b/ghc/compiler/codeGen/CgBindery.hi
deleted file mode 100644
index 4d4fa91ca1..0000000000
--- a/ghc/compiler/codeGen/CgBindery.hi
+++ /dev/null
@@ -1,63 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface CgBindery where
-import AbsCSyn(AbstractC, CAddrMode, CExprMacro, CStmtMacro, MagicId, RegRelative, ReturnInfo)
-import BasicLit(BasicLit)
-import CLabelInfo(CLabel)
-import CgMonad(CgInfoDownwards, CgState, StubFlag)
-import ClosureInfo(ClosureInfo, LambdaFormInfo)
-import CostCentre(CostCentre)
-import HeapOffs(HeapOffset)
-import Id(Id)
-import IdEnv(IdEnv(..))
-import Maybes(Labda)
-import PreludePS(_PackedString)
-import PreludeRatio(Ratio(..))
-import PrimKind(PrimKind)
-import PrimOps(PrimOp)
-import StgSyn(StgAtom)
-import UniqFM(UniqFM)
-import UniqSet(UniqSet(..))
-import Unique(Unique)
-data AbstractC 
-data CAddrMode 
-data MagicId 
-data BasicLit 
-data CLabel 
-type CgBindings = UniqFM CgIdInfo
-data CgIdInfo   = MkCgIdInfo Id VolatileLoc StableLoc LambdaFormInfo
-data CgState 
-data LambdaFormInfo 
-data HeapOffset 
-data Id 
-type IdEnv a = UniqFM a
-data Labda a 
-data StableLoc 
-data StgAtom a 
-data UniqFM a 
-type UniqSet a = UniqFM a
-data Unique 
-data VolatileLoc 
-bindArgsToRegs :: [Id] -> [MagicId] -> CgInfoDownwards -> CgState -> CgState
-bindNewPrimToAmode :: Id -> CAddrMode -> CgInfoDownwards -> CgState -> CgState
-bindNewToAStack :: (Id, Int) -> CgInfoDownwards -> CgState -> CgState
-bindNewToBStack :: (Id, Int) -> CgInfoDownwards -> CgState -> CgState
-bindNewToNode :: Id -> HeapOffset -> LambdaFormInfo -> CgInfoDownwards -> CgState -> CgState
-bindNewToReg :: Id -> MagicId -> LambdaFormInfo -> CgInfoDownwards -> CgState -> CgState
-bindNewToTemp :: Id -> CgInfoDownwards -> CgState -> (CAddrMode, CgState)
-getAtomAmode :: StgAtom Id -> CgInfoDownwards -> CgState -> (CAddrMode, CgState)
-getAtomAmodes :: [StgAtom Id] -> CgInfoDownwards -> CgState -> ([CAddrMode], CgState)
-getCAddrMode :: Id -> CgInfoDownwards -> CgState -> (CAddrMode, CgState)
-getCAddrModeAndInfo :: Id -> CgInfoDownwards -> CgState -> ((CAddrMode, LambdaFormInfo), CgState)
-getCAddrModeIfVolatile :: Id -> CgInfoDownwards -> CgState -> (Labda CAddrMode, CgState)
-getVolatileRegs :: UniqFM Id -> CgInfoDownwards -> CgState -> ([MagicId], CgState)
-heapIdInfo :: Id -> HeapOffset -> LambdaFormInfo -> CgIdInfo
-idInfoToAmode :: PrimKind -> CgIdInfo -> CgInfoDownwards -> CgState -> (CAddrMode, CgState)
-letNoEscapeIdInfo :: Id -> Int -> Int -> LambdaFormInfo -> CgIdInfo
-maybeAStkLoc :: StableLoc -> Labda Int
-maybeBStkLoc :: StableLoc -> Labda Int
-newTempAmodeAndIdInfo :: Id -> LambdaFormInfo -> (CAddrMode, CgIdInfo)
-nukeVolatileBinds :: UniqFM CgIdInfo -> UniqFM CgIdInfo
-rebindToAStack :: Id -> Int -> CgInfoDownwards -> CgState -> CgState
-rebindToBStack :: Id -> Int -> CgInfoDownwards -> CgState -> CgState
-stableAmodeIdInfo :: Id -> CAddrMode -> LambdaFormInfo -> CgIdInfo
-
diff --git a/ghc/compiler/codeGen/CgBindery.lhs b/ghc/compiler/codeGen/CgBindery.lhs
index fbc2fc9e21..84fd88487a 100644
--- a/ghc/compiler/codeGen/CgBindery.lhs
+++ b/ghc/compiler/codeGen/CgBindery.lhs
@@ -19,33 +19,22 @@ module CgBindery (
 
 	bindNewToAStack, bindNewToBStack,
 	bindNewToNode, bindNewToReg, bindArgsToRegs,
---UNUSED: bindNewToSameAsOther,
 	bindNewToTemp, bindNewPrimToAmode,
 	getAtomAmode, getAtomAmodes,
 	getCAddrModeAndInfo, getCAddrMode,
 	getCAddrModeIfVolatile, getVolatileRegs,
-	rebindToAStack, rebindToBStack,
---UNUSED:	rebindToTemp,
+	rebindToAStack, rebindToBStack
 
 	-- and to make a self-sufficient interface...
-	AbstractC, CAddrMode, HeapOffset, MagicId, CLabel, CgState,
-	BasicLit, IdEnv(..), UniqFM,
-	Id, Maybe, Unique, StgAtom, UniqSet(..)
     ) where
 
-IMPORT_Trace		-- ToDo: rm (debugging only)
-import Outputable
-import Unpretty
-import PprAbsC
-
 import AbsCSyn
 import CgMonad
 
 import CgUsages		( getHpRelOffset, getSpARelOffset, getSpBRelOffset )
-import CLabelInfo	( mkClosureLabel, CLabel )
+import CLabel	( mkClosureLabel, CLabel )
 import ClosureInfo
-import Id		( getIdKind, toplevelishId, isDataCon, Id )
-import IdEnv		-- used to build CgBindings
+import Id		( getIdPrimRep, toplevelishId, isDataCon, Id )
 import Maybes		( catMaybes, Maybe(..) )
 import UniqSet		-- ( setToList )
 import StgSyn
@@ -92,7 +81,7 @@ data StableLoc
   = NoStableLoc
   | VirAStkLoc		VirtualSpAOffset
   | VirBStkLoc		VirtualSpBOffset
-  | LitLoc		BasicLit
+  | LitLoc		Literal
   | StableAmodeLoc	CAddrMode
 
 -- these are so StableLoc can be abstract:
@@ -123,8 +112,8 @@ newTempAmodeAndIdInfo :: Id -> LambdaFormInfo -> (CAddrMode, CgIdInfo)
 newTempAmodeAndIdInfo name lf_info
   = (temp_amode, temp_idinfo)
   where
-    uniq       	= getTheUnique name
-    temp_amode	= CTemp uniq (getIdKind name)
+    uniq       	= getItsUnique name
+    temp_amode	= CTemp uniq (getIdPrimRep name)
     temp_idinfo = tempIdInfo name uniq lf_info
 
 idInfoToAmode :: PrimKind -> CgIdInfo -> FCode CAddrMode
@@ -156,7 +145,9 @@ idInfoPiecesToAmode kind NoVolatileLoc (VirBStkLoc i)
   = getSpBRelOffset i `thenFC` \ rel_spB ->
     returnFC (CVal rel_spB kind)
 
+#ifdef DEBUG
 idInfoPiecesToAmode kind NoVolatileLoc NoStableLoc = panic "idInfoPiecesToAmode: no loc"
+#endif
 \end{code}
 
 %************************************************************************
@@ -204,7 +195,7 @@ getCAddrModeAndInfo name
     returnFC (amode, lf_info)
   where
     global_amode = CLbl (mkClosureLabel name) kind
-    kind = getIdKind name
+    kind = getIdPrimRep name
 
 getCAddrMode :: Id -> FCode CAddrMode
 getCAddrMode name
@@ -220,7 +211,7 @@ getCAddrModeIfVolatile name
   = lookupBindC name `thenFC` \ ~(MkCgIdInfo _ volatile_loc stable_loc lf_info) ->
     case stable_loc of
 	NoStableLoc ->	-- Aha!  So it is volatile!
-	    idInfoPiecesToAmode (getIdKind name) volatile_loc NoStableLoc `thenFC` \ amode ->
+	    idInfoPiecesToAmode (getIdPrimRep name) volatile_loc NoStableLoc `thenFC` \ amode ->
 	    returnFC (Just amode)
 
 	a_stable_loc -> returnFC Nothing
@@ -234,7 +225,7 @@ stable one (notably, on the stack), we modify the current bindings to
 forget the volatile one.
 
 \begin{code}
-getVolatileRegs :: PlainStgLiveVars -> FCode [MagicId]
+getVolatileRegs :: StgLiveVars -> FCode [MagicId]
 
 getVolatileRegs vars
   = mapFCs snaffle_it (uniqSetToList vars) `thenFC` \ stuff ->
@@ -245,7 +236,7 @@ getVolatileRegs vars
 	let
 	    -- commoned-up code...
 	    consider_reg reg
-	      =	if not (isVolatileReg reg) then 
+	      =	if not (isVolatileReg reg) then
 			-- Potentially dies across C calls
 			-- For now, that's everything; we leave
 			-- it to the save-macros to decide which
@@ -254,7 +245,7 @@ getVolatileRegs vars
 		else
 		    case stable_loc of
 		      NoStableLoc -> returnFC (Just reg) -- got one!
-		      is_a_stable_loc -> 
+		      is_a_stable_loc ->
 			-- has both volatile & stable locations;
 			-- force it to rely on the stable location
 			modifyBindC var nuke_vol_bind `thenC`
@@ -271,17 +262,17 @@ getVolatileRegs vars
 \end{code}
 
 \begin{code}
-getAtomAmodes :: [PlainStgAtom] -> FCode [CAddrMode]
+getAtomAmodes :: [StgArg] -> FCode [CAddrMode]
 getAtomAmodes [] = returnFC []
 getAtomAmodes (atom:atoms)
   = getAtomAmode  atom  `thenFC` \ amode ->
     getAtomAmodes atoms `thenFC` \ amodes ->
     returnFC ( amode : amodes )
 
-getAtomAmode :: PlainStgAtom -> FCode CAddrMode
+getAtomAmode :: StgArg -> FCode CAddrMode
 
-getAtomAmode (StgVarAtom var) = getCAddrMode var
-getAtomAmode (StgLitAtom lit) = returnFC (CLit lit)
+getAtomAmode (StgVarArg var) = getCAddrMode var
+getAtomAmode (StgLitArg lit) = returnFC (CLit lit)
 \end{code}
 
 %************************************************************************
@@ -336,25 +327,9 @@ bindNewToLit name lit
 
 bindArgsToRegs :: [Id] -> [MagicId] -> Code
 bindArgsToRegs args regs
- = listCs (zipWith bind args regs)
- where
-   arg `bind` reg = bindNewToReg arg reg mkLFArgument
-
-{- UNUSED:
-bindNewToSameAsOther :: Id -> PlainStgAtom -> Code
-bindNewToSameAsOther name (StgVarAtom old_name)
-#ifdef DEBUG
-  | toplevelishId old_name = panic "bindNewToSameAsOther: global old name"
-  | otherwise
-#endif
-  = lookupBindC old_name	`thenFC` \ old_stuff ->
-    addBindC name old_stuff
-
-bindNewToSameAsOther name (StgLitAtom lit)
-  = addBindC name info
+  = listCs (zipWithEqual bind args regs)
   where
-    info = MkCgIdInfo name NoVolatileLoc (LitLoc lit) (panic "bindNewToSameAsOther")
--}
+    arg `bind` reg = bindNewToReg arg reg mkLFArgument
 \end{code}
 
 @bindNewPrimToAmode@ works only for certain addressing modes, because
@@ -371,10 +346,10 @@ bindNewPrimToAmode name (CTemp uniq kind)
 
 bindNewPrimToAmode name (CLit lit) = bindNewToLit name lit
 
-bindNewPrimToAmode name (CVal (SpBRel _ offset) _) 
+bindNewPrimToAmode name (CVal (SpBRel _ offset) _)
   = bindNewToBStack (name, offset)
 
-bindNewPrimToAmode name (CVal (NodeRel offset) _) 
+bindNewPrimToAmode name (CVal (NodeRel offset) _)
   = bindNewToNode name offset (panic "bindNewPrimToAmode node")
   -- See comment on idInfoPiecesToAmode for VirNodeLoc
 
@@ -398,19 +373,5 @@ rebindToBStack name offset
   where
     replace_stable_fn (MkCgIdInfo i vol stab einfo)
       = MkCgIdInfo i vol (VirBStkLoc offset) einfo
-
-{- UNUSED:
-rebindToTemp :: Id -> FCode CAddrMode
-rebindToTemp name
-  = let
-	(temp_amode, MkCgIdInfo _ new_vol _ _ {-LF info discarded-})
-	  = newTempAmodeAndIdInfo name (panic "rebindToTemp")
-    in
-    modifyBindC name (replace_volatile_fn new_vol) `thenC`
-    returnFC temp_amode
-  where
-    replace_volatile_fn new_vol (MkCgIdInfo i vol stab einfo)
-      = MkCgIdInfo i new_vol stab einfo
--}
 \end{code}
 
diff --git a/ghc/compiler/codeGen/CgCase.hi b/ghc/compiler/codeGen/CgCase.hi
deleted file mode 100644
index e0c05ba1f1..0000000000
--- a/ghc/compiler/codeGen/CgCase.hi
+++ /dev/null
@@ -1,22 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface CgCase where
-import AbsCSyn(AbstractC)
-import BasicLit(BasicLit)
-import CgBindery(CgIdInfo)
-import CgMonad(CgInfoDownwards, CgState, EndOfBlockInfo, StubFlag)
-import CostCentre(CostCentre)
-import HeapOffs(HeapOffset)
-import Id(Id)
-import Maybes(Labda)
-import PrimOps(PrimOp)
-import StgSyn(StgAtom, StgBinding, StgCaseAlternatives, StgCaseDefault, StgExpr)
-import UniType(UniType)
-import UniqFM(UniqFM)
-import Unique(Unique)
-data CgState 
-data Id 
-data StgCaseAlternatives a b 
-data StgExpr a b 
-cgCase :: StgExpr Id Id -> UniqFM Id -> UniqFM Id -> Unique -> StgCaseAlternatives Id Id -> CgInfoDownwards -> CgState -> CgState
-saveVolatileVarsAndRegs :: UniqFM Id -> CgInfoDownwards -> CgState -> ((AbstractC, EndOfBlockInfo, Labda Int), CgState)
-
diff --git a/ghc/compiler/codeGen/CgCase.lhs b/ghc/compiler/codeGen/CgCase.lhs
index 17be925b3b..45b21c1105 100644
--- a/ghc/compiler/codeGen/CgCase.lhs
+++ b/ghc/compiler/codeGen/CgCase.lhs
@@ -12,28 +12,23 @@
 
 module CgCase (
 	cgCase,
-    	saveVolatileVarsAndRegs,
+    	saveVolatileVarsAndRegs
 
 	-- and to make the interface self-sufficient...
-	StgExpr, Id, StgCaseAlternatives, CgState
     ) where
 
-IMPORT_Trace		-- ToDo: rm (debugging)
-import Outputable
-import Pretty
-
 import StgSyn
 import CgMonad
 import AbsCSyn
 
-import AbsPrel		( PrimOp(..), primOpCanTriggerGC
+import PrelInfo		( PrimOp(..), primOpCanTriggerGC
 			  IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
 			  IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
 			)
-import AbsUniType	( kindFromType, getTyConDataCons,
+import Type		( primRepFromType, getTyConDataCons,
 			  getUniDataSpecTyCon, getUniDataSpecTyCon_maybe,
 			  isEnumerationTyCon,
-			  UniType
+			  Type
 			)
 import CgBindery	-- all of it
 import CgCon		( buildDynCon, bindConArgs )
@@ -43,19 +38,18 @@ import CgRetConv	-- lots of stuff
 import CgStackery	-- plenty
 import CgTailCall	( tailCallBusiness, performReturn )
 import CgUsages		-- and even more
-import CLabelInfo	-- bunches of things...
+import CLabel	-- bunches of things...
 import ClosureInfo	{-( blackHoleClosureInfo, mkConLFInfo, mkLFArgument,
 			  layOutDynCon
 			)-}
-import CmdLineOpts	( GlobalSwitch(..) )
 import CostCentre	( useCurrentCostCentre, CostCentre )
-import BasicLit		( kindOfBasicLit )
-import Id		( getDataConTag, getIdKind, fIRST_TAG, isDataCon,
+import Literal		( literalPrimRep )
+import Id		( getDataConTag, getIdPrimRep, fIRST_TAG, isDataCon,
 			  toplevelishId, getInstantiatedDataConSig,
 			  ConTag(..), DataCon(..)
 			)
 import Maybes		( catMaybes, Maybe(..) )
-import PrimKind		( getKindSize, isFollowableKind, retKindSize, PrimKind(..) )
+import PrimRep		( getPrimRepSize, isFollowableRep, retPrimRepSize, PrimRep(..) )
 import UniqSet		-- ( uniqSetToList, UniqSet(..) )
 import Util
 \end{code}
@@ -73,7 +67,7 @@ data GCFlag
 It is quite interesting to decide whether to put a heap-check
 at the start of each alternative.  Of course we certainly have
 to do so if the case forces an evaluation, or if there is a primitive
-op which can trigger GC.  
+op which can trigger GC.
 
 A more interesting situation is this:
 
@@ -93,7 +87,7 @@ In favour of omitting \tr{!B!}, \tr{!C!}:
 
 \begin{itemize}
 \item
-{\em May} save a heap overflow test, 
+{\em May} save a heap overflow test,
 	if ...A... allocates anything.  The other advantage
 	of this is that we can use relative addressing
 	from a single Hp to get at all the closures so allocated.
@@ -102,7 +96,7 @@ In favour of omitting \tr{!B!}, \tr{!C!}:
 \end{itemize}
 
 Against:
-	
+
 \begin{itemize}
 \item
    May do more allocation than reqd.  This sometimes bites us
@@ -122,11 +116,11 @@ If these things are done, then the heap checks can be done at \tr{!B!} and
 \tr{!C!} without a full save-volatile-vars sequence.
 
 \begin{code}
-cgCase	:: PlainStgExpr
-	-> PlainStgLiveVars
-	-> PlainStgLiveVars
+cgCase	:: StgExpr
+	-> StgLiveVars
+	-> StgLiveVars
 	-> Unique
-	-> PlainStgCaseAlternatives
+	-> StgCaseAlts
 	-> Code
 \end{code}
 
@@ -158,7 +152,7 @@ we just bomb out at the moment. It never happens in practice.
 **** END OF TO DO TO DO
 
 \begin{code}
-cgCase scrut@(StgPrimApp op args _) live_in_whole_case live_in_alts uniq 
+cgCase scrut@(StgPrim op args _) live_in_whole_case live_in_alts uniq
        (StgAlgAlts _ alts (StgBindDefault id _ deflt_rhs))
   = if not (null alts) then
     	panic "cgCase: case on PrimOp with default *and* alts\n"
@@ -172,17 +166,17 @@ cgCase scrut@(StgPrimApp op args _) live_in_whole_case live_in_alts uniq
   where
     scrut_rhs       = StgRhsClosure useCurrentCostCentre stgArgOcc{-safe-} scrut_free_vars
 				Updatable [] scrut
-    scrut_free_vars = [ fv | StgVarAtom fv <- args, not (toplevelishId fv) ]
+    scrut_free_vars = [ fv | StgVarArg fv <- args, not (toplevelishId fv) ]
 			-- Hack, hack
 \end{code}
 
 
 \begin{code}
-cgCase (StgPrimApp op args _) live_in_whole_case live_in_alts uniq alts
+cgCase (StgPrim op args _) live_in_whole_case live_in_alts uniq alts
   | not (primOpCanTriggerGC op)
   =
 	-- Get amodes for the arguments and results
-    getPrimOpArgAmodes op args			`thenFC` \ arg_amodes -> 
+    getPrimOpArgAmodes op args			`thenFC` \ arg_amodes ->
     let
 	result_amodes = getPrimAppResultAmodes uniq alts
 	liveness_mask = panic "cgCase: liveness of non-GC-ing primop touched\n"
@@ -209,7 +203,7 @@ cgCase (StgPrimApp op args _) live_in_whole_case live_in_alts uniq alts
 
     	op_result_amodes = map CReg op_result_regs
 
-	(op_arg_amodes, liveness_mask, arg_assts) 
+	(op_arg_amodes, liveness_mask, arg_assts)
 	  = makePrimOpArgsRobust {-NO:isw_chkr-} op arg_amodes
 
 	liveness_arg  = mkIntCLit liveness_mask
@@ -224,33 +218,33 @@ cgCase (StgPrimApp op args _) live_in_whole_case live_in_alts uniq alts
     saveVolatileVars live_in_alts	`thenFC` \ volatile_var_save_assts ->
 
     getEndOfBlockInfo                 	`thenFC` \ eob_info ->
-    forkEval eob_info nopC 
+    forkEval eob_info nopC
 	     (getAbsC (cgInlineAlts GCMayHappen uniq alts) `thenFC` \ abs_c ->
-              absC (CRetUnVector vtbl_label (CLabelledCode return_label abs_c))
+	      absC (CRetUnVector vtbl_label (CLabelledCode return_label abs_c))
     	    	    	    	    	`thenC`
-	      returnFC (CaseAlts (CUnVecLbl return_label vtbl_label) 
-                                 Nothing{-no semi-tagging-}))
+	      returnFC (CaseAlts (CUnVecLbl return_label vtbl_label)
+				 Nothing{-no semi-tagging-}))
 	    `thenFC` \ new_eob_info ->
 
 	-- Record the continuation info
     setEndOfBlockInfo new_eob_info (
 
-	-- Now "return" to the inline alternatives; this will get 
+	-- Now "return" to the inline alternatives; this will get
 	-- compiled to a fall-through.
     let
 	simultaneous_assts = arg_assts `mkAbsCStmts` volatile_var_save_assts
-	
+
 	-- do_op_and_continue will be passed an amode for the continuation
 	do_op_and_continue sequel
-          = absC (COpStmt op_result_amodes
+	  = absC (COpStmt op_result_amodes
 			  op
 			  (pin_liveness op liveness_arg op_arg_amodes)
 			  liveness_mask
 			  [{-no vol_regs-}])
     	    	    	    	    	`thenC`
 
-            sequelToAmode sequel        `thenFC` \ dest_amode ->
-            absC (CReturn dest_amode DirectReturn)
+	    sequelToAmode sequel        `thenFC` \ dest_amode ->
+	    absC (CReturn dest_amode DirectReturn)
 
 		-- Note: we CJump even for algebraic data types,
 		-- because cgInlineAlts always generates code, never a
@@ -290,15 +284,15 @@ This can be done a little better than the general case, because
 we can reuse/trim the stack slot holding the variable (if it is in one).
 
 \begin{code}
-cgCase (StgApp (StgVarAtom fun) args _ {-lvs must be same as live_in_alts-}) 
-        live_in_whole_case live_in_alts uniq alts@(StgAlgAlts _ _ _)
+cgCase (StgApp (StgVarArg fun) args _ {-lvs must be same as live_in_alts-})
+	live_in_whole_case live_in_alts uniq alts@(StgAlgAlts _ _ _)
   =
     getCAddrModeAndInfo fun		`thenFC` \ (fun_amode, lf_info) ->
     getAtomAmodes args			`thenFC` \ arg_amodes ->
 
 	-- Squish the environment
     nukeDeadBindings live_in_alts	`thenC`
-    saveVolatileVarsAndRegs live_in_alts 
+    saveVolatileVarsAndRegs live_in_alts
     	    	    	`thenFC` \ (save_assts, alts_eob_info, maybe_cc_slot) ->
 
     forkEval alts_eob_info
@@ -318,10 +312,10 @@ cgCase expr live_in_whole_case live_in_alts uniq alts
     saveVolatileVarsAndRegs live_in_alts
     	    	    	`thenFC` \ (save_assts, alts_eob_info, maybe_cc_slot) ->
 
-	-- Save those variables right now!	
+	-- Save those variables right now!
     absC save_assts 	    	    	`thenC`
 
-    forkEval alts_eob_info 
+    forkEval alts_eob_info
     	(nukeDeadBindings live_in_alts)
 	(cgEvalAlts maybe_cc_slot uniq alts) `thenFC` \ scrut_eob_info ->
 
@@ -347,7 +341,7 @@ invented by CgAlgAlts.
 \begin{code}
 getPrimAppResultAmodes
 	:: Unique
-	-> PlainStgCaseAlternatives
+	-> StgCaseAlts
 	-> [CAddrMode]
 \end{code}
 
@@ -373,7 +367,7 @@ getPrimAppResultAmodes uniq (StgAlgAlts ty alts (StgBindDefault _ True {- used -
   where
     -- A temporary variable to hold the tag; this is unaffected by GC because
     -- the heap-checks in the branches occur after the switch
-    tag_amode     = CTemp uniq IntKind
+    tag_amode     = CTemp uniq IntRep
     (spec_tycon, _, _) = getUniDataSpecTyCon ty
 
 getPrimAppResultAmodes uniq (StgAlgAlts ty alts other_default)
@@ -384,7 +378,7 @@ getPrimAppResultAmodes uniq (StgAlgAlts ty alts other_default)
   where
     -- A temporary variable to hold the tag; this is unaffected by GC because
     -- the heap-checks in the branches occur after the switch
-    tag_amode = CTemp uniq IntKind
+    tag_amode = CTemp uniq IntRep
 
     -- Sort alternatives into canonical order; there must be a complete
     -- set because there's no default case.
@@ -396,7 +390,7 @@ getPrimAppResultAmodes uniq (StgAlgAlts ty alts other_default)
     -- Turn them into amodes
     arg_amodes = concat (map mk_amodes sorted_alts)
     mk_amodes (con, args, use_mask, rhs)
-      = [ CTemp (getTheUnique arg) (getIdKind arg) | arg <- args ]
+      = [ CTemp (getItsUnique arg) (getIdPrimRep arg) | arg <- args ]
 \end{code}
 
 The situation is simpler for primitive
@@ -406,7 +400,7 @@ results, because there is only one!
 getPrimAppResultAmodes uniq (StgPrimAlts ty _ _)
   = [CTemp uniq kind]
   where
-    kind = kindFromType ty
+    kind = primRepFromType ty
 \end{code}
 
 
@@ -423,7 +417,7 @@ is some evaluation to be done.
 \begin{code}
 cgEvalAlts :: Maybe VirtualSpBOffset	-- Offset of cost-centre to be restored, if any
 	   -> Unique
-	   -> PlainStgCaseAlternatives
+	   -> StgCaseAlts
 	   -> FCode Sequel		-- Any addr modes inside are guaranteed to be a label
 					-- so that we can duplicate it without risk of
 					-- duplicating code
@@ -445,7 +439,7 @@ cgEvalAlts cc_slot uniq (StgAlgAlts ty alts deflt)
     let
 	(spec_tycon, _, _) = getUniDataSpecTyCon ty
 
-	use_labelled_alts 
+	use_labelled_alts
 	  = case ctrlReturnConvAlg spec_tycon of
 	      VectoredReturn _ -> True
 	      _	    	       -> False
@@ -471,8 +465,8 @@ cgEvalAlts cc_slot uniq (StgPrimAlts ty alts deflt)
     getAbsC (cgPrimAlts GCMayHappen uniq ty alts deflt)  `thenFC` \ abs_c ->
 
 	-- Generate the labelled block, starting with restore-cost-centre
-    absC (CRetUnVector vtbl_label 
-         (CLabelledCode return_label (cc_restore `mkAbsCStmts` abs_c)))
+    absC (CRetUnVector vtbl_label
+	 (CLabelledCode return_label (cc_restore `mkAbsCStmts` abs_c)))
     	    	    	    	    	    	    	 `thenC`
 	-- Return an amode for the block
     returnFC (CaseAlts (CUnVecLbl return_label vtbl_label) Nothing{-no semi-tagging-})
@@ -484,7 +478,7 @@ cgEvalAlts cc_slot uniq (StgPrimAlts ty alts deflt)
 
 \begin{code}
 cgInlineAlts :: GCFlag -> Unique
-    	     -> PlainStgCaseAlternatives
+    	     -> StgCaseAlts
     	     -> Code
 \end{code}
 
@@ -511,22 +505,7 @@ cgInlineAlts gc_flag uniq (StgAlgAlts ty alts deflt)
  where
     -- A temporary variable to hold the tag; this is unaffected by GC because
     -- the heap-checks in the branches occur after the switch
-    tag_amode = CTemp uniq IntKind
-\end{code}
-
-=========== OLD: we *can* now handle this case ================
-
-Next, a case we can't deal with: an algebraic case with no evaluation
-required (so it is in-line), and a default case as well.  In this case
-we require all the alternatives written out, so that we can invent
-suitable binders to pass to the PrimOp. A default case defeats this.
-Could be fixed, but probably isn't worth it.
-
-\begin{code}
-{- ============= OLD
-cgInlineAlts gc_flag uniq (StgAlgAlts ty alts other_default)
-  = panic "cgInlineAlts: alg alts with default"
-================= END OF OLD -}
+    tag_amode = CTemp uniq IntRep
 \end{code}
 
 Third (real) case: primitive result type.
@@ -551,9 +530,9 @@ cgAlgAlts :: GCFlag
 	  -> Unique
 	  -> AbstractC				-- Restore-cost-centre instruction
 	  -> Bool				-- True <=> branches must be labelled
-	  -> UniType	    	    	    	-- From the case statement
-	  -> [(Id, [Id], [Bool], PlainStgExpr)]	-- The alternatives
-	  -> PlainStgCaseDefault		-- The default
+	  -> Type	    	    	    	-- From the case statement
+	  -> [(Id, [Id], [Bool], StgExpr)]	-- The alternatives
+	  -> StgCaseDefault		-- The default
 	  -> FCode ([(ConTag, AbstractC)],	-- The branches
 		    AbstractC			-- The default case
 	     )
@@ -566,7 +545,7 @@ them explicitly in the heap, and jump to a join point for the default
 case.
 
 OLD:  All of this only works if a heap-check is required anyway, because
-otherwise it isn't safe to allocate. 
+otherwise it isn't safe to allocate.
 
 NEW (July 94): now false!  It should work regardless of gc_flag,
 because of the extra_branches argument now added to forkAlts.
@@ -594,7 +573,7 @@ cgAlgAlts gc_flag uniq restore_cc semi_tagging
   where
 
     default_join_lbl = mkDefaultLabel uniq
-    jump_instruction = CJump (CLbl default_join_lbl CodePtrKind)
+    jump_instruction = CJump (CLbl default_join_lbl CodePtrRep)
 
     (spec_tycon, _, spec_cons)
       = -- trace ("cgCase:tycon:"++(ppShow 80 (ppAboves [
@@ -608,7 +587,7 @@ cgAlgAlts gc_flag uniq restore_cc semi_tagging
     alt_cons = [ con | (con,_,_,_) <- alts ]
 
     default_cons  = [ spec_con | spec_con <- spec_cons,	-- In this type
-			         spec_con `not_elem` alt_cons ]	-- Not handled explicitly
+				 spec_con `not_elem` alt_cons ]	-- Not handled explicitly
 	where
 	  not_elem = isn'tIn "cgAlgAlts"
 
@@ -640,19 +619,19 @@ cgAlgAlts gc_flag uniq restore_cc semi_tagging
 		buildDynCon binder useCurrentCostCentre con
 				(map CReg regs) (all zero_size regs)
 						`thenFC` \ idinfo ->
-		idInfoToAmode PtrKind idinfo	`thenFC` \ amode ->
+		idInfoToAmode PtrRep idinfo	`thenFC` \ amode ->
 
 		absC (CAssign (CReg node) amode) `thenC`
 		absC jump_instruction
 	    )
 	  where
-	    zero_size reg = getKindSize (kindFromMagicId reg) == 0
+	    zero_size reg = getPrimRepSize (kindFromMagicId reg) == 0
 \end{code}
 
 Now comes the general case
 
 \begin{code}
-cgAlgAlts gc_flag uniq restore_cc must_label_branches ty alts deflt 
+cgAlgAlts gc_flag uniq restore_cc must_label_branches ty alts deflt
 	{- The deflt is either StgNoDefault or a BindDefault which doesn't use the binder -}
   = forkAlts (map (cgAlgAlt gc_flag uniq restore_cc must_label_branches) alts)
 	     [{- No "extra branches" -}]
@@ -662,7 +641,7 @@ cgAlgAlts gc_flag uniq restore_cc must_label_branches ty alts deflt
 \begin{code}
 cgAlgDefault :: GCFlag
 	     -> Unique -> AbstractC -> Bool -- turgid state...
-	     -> PlainStgCaseDefault	    -- input
+	     -> StgCaseDefault	    -- input
 	     -> FCode AbstractC		    -- output
 
 cgAlgDefault gc_flag uniq restore_cc must_label_branch
@@ -707,12 +686,12 @@ cgAlgDefault gc_flag uniq restore_cc must_label_branch
 
 cgAlgAlt :: GCFlag
 	 -> Unique -> AbstractC -> Bool		-- turgid state
-	 -> (Id, [Id], [Bool], PlainStgExpr)
+	 -> (Id, [Id], [Bool], StgExpr)
 	 -> FCode (ConTag, AbstractC)
 
 cgAlgAlt gc_flag uniq restore_cc must_label_branch (con, args, use_mask, rhs)
   = getAbsC (absC restore_cc `thenC`
-	     cgAlgAltRhs gc_flag con args use_mask rhs) `thenFC` \ abs_c -> 
+	     cgAlgAltRhs gc_flag con args use_mask rhs) `thenFC` \ abs_c ->
     let
 	final_abs_c | must_label_branch = CJump (CLabelledCode lbl abs_c)
 		    | otherwise	        = abs_c
@@ -722,7 +701,7 @@ cgAlgAlt gc_flag uniq restore_cc must_label_branch (con, args, use_mask, rhs)
     tag	= getDataConTag con
     lbl = mkAltLabel uniq tag
 
-cgAlgAltRhs :: GCFlag -> Id -> [Id] -> [Bool] -> PlainStgExpr -> Code
+cgAlgAltRhs :: GCFlag -> Id -> [Id] -> [Bool] -> StgExpr -> Code
 
 cgAlgAltRhs gc_flag con args use_mask rhs
   = getIntSwitchChkrC	`thenFC` \ isw_chkr ->
@@ -738,11 +717,11 @@ cgAlgAltRhs gc_flag con args use_mask rhs
     in
     possibleHeapCheck gc_flag live_regs node_reqd (
     (case gc_flag of
-        NoGC   	    -> mapFCs bindNewToTemp args `thenFC` \ _ ->
+	NoGC   	    -> mapFCs bindNewToTemp args `thenFC` \ _ ->
 		       nopC
     	GCMayHappen -> bindConArgs con args
     )	`thenC`
-    cgExpr rhs 
+    cgExpr rhs
     )
 \end{code}
 
@@ -758,8 +737,8 @@ algebraic case alternatives for semi-tagging.
 \begin{code}
 cgSemiTaggedAlts :: IntSwitchChecker
 		 -> Unique
-		 -> [(Id, [Id], [Bool], PlainStgExpr)]
-		 -> StgCaseDefault Id Id
+		 -> [(Id, [Id], [Bool], StgExpr)]
+		 -> GenStgCaseDefault Id Id
 		 -> SemiTaggingStuff
 
 cgSemiTaggedAlts isw_chkr uniq alts deflt
@@ -792,7 +771,7 @@ cgSemiTaggedAlts isw_chkr uniq alts deflt
 
 		used_regs = selectByMask use_mask regs
 
-		used_regs_w_offsets = [ ro | ro@(reg,offset) <- regs_w_offsets, 
+		used_regs_w_offsets = [ ro | ro@(reg,offset) <- regs_w_offsets,
 					     reg `is_elem` used_regs]
 
 		is_elem = isIn "cgSemiTaggedAlts"
@@ -829,9 +808,9 @@ As usual, no binders in the alternatives are yet bound.
 \begin{code}
 cgPrimAlts :: GCFlag
 	   -> Unique
-    	   -> UniType	
-	   -> [(BasicLit, PlainStgExpr)]	-- Alternatives
-	   -> PlainStgCaseDefault		-- Default
+    	   -> Type
+	   -> [(Literal, StgExpr)]	-- Alternatives
+	   -> StgCaseDefault		-- Default
 	   -> Code
 
 cgPrimAlts gc_flag uniq ty alts deflt
@@ -842,7 +821,7 @@ cgPrimAlts gc_flag uniq ty alts deflt
 		     NoGC	 -> CTemp uniq kind
 		     GCMayHappen -> CReg (dataReturnConvPrim kind)
 
-    kind = kindFromType ty
+    kind = primRepFromType ty
 
 
 cgPrimAltsGivenScrutinee gc_flag scrutinee alts deflt
@@ -854,8 +833,8 @@ cgPrimAltsGivenScrutinee gc_flag scrutinee alts deflt
 
 
 cgPrimAlt :: GCFlag
-	  -> (BasicLit, PlainStgExpr)    -- The alternative
-	  -> FCode (BasicLit, AbstractC) -- Its compiled form
+	  -> (Literal, StgExpr)    -- The alternative
+	  -> FCode (Literal, AbstractC) -- Its compiled form
 
 cgPrimAlt gc_flag (lit, rhs)
   = getAbsC rhs_code	 `thenFC` \ absC ->
@@ -865,7 +844,7 @@ cgPrimAlt gc_flag (lit, rhs)
 
 cgPrimDefault :: GCFlag
 	      -> CAddrMode		-- Scrutinee
-	      -> PlainStgCaseDefault
+	      -> StgCaseDefault
 	      -> FCode AbstractC
 
 cgPrimDefault gc_flag scrutinee StgNoDefault
@@ -877,7 +856,7 @@ cgPrimDefault gc_flag scrutinee (StgBindDefault _ False{-binder not used-} rhs)
 cgPrimDefault gc_flag scrutinee (StgBindDefault binder True{-used-} rhs)
   = getAbsC (possibleHeapCheck gc_flag regs False rhs_code)
   where
-    regs = if isFollowableKind (getAmodeKind scrutinee) then
+    regs = if isFollowableRep (getAmodeRep scrutinee) then
 	      [node] else []
 
     rhs_code = bindNewPrimToAmode binder scrutinee `thenC`
@@ -893,10 +872,10 @@ cgPrimDefault gc_flag scrutinee (StgBindDefault binder True{-used-} rhs)
 
 \begin{code}
 saveVolatileVarsAndRegs
-    :: PlainStgLiveVars               -- Vars which should be made safe
+    :: StgLiveVars               -- Vars which should be made safe
     -> FCode (AbstractC,              -- Assignments to do the saves
        EndOfBlockInfo,                -- New sequel, recording where the return
-                                      -- address now is
+				      -- address now is
        Maybe VirtualSpBOffset)        -- Slot for current cost centre
 
 
@@ -905,11 +884,11 @@ saveVolatileVarsAndRegs vars
     saveCurrentCostCentre     `thenFC` \ (maybe_cc_slot, cc_save) ->
     saveReturnAddress         `thenFC` \ (new_eob_info, ret_save) ->
     returnFC (mkAbstractCs [var_saves, cc_save, ret_save],
-              new_eob_info,
-              maybe_cc_slot)
+	      new_eob_info,
+	      maybe_cc_slot)
 
 
-saveVolatileVars :: PlainStgLiveVars	-- Vars which should be made safe
+saveVolatileVars :: StgLiveVars	-- Vars which should be made safe
 		 -> FCode AbstractC	-- Assignments to to the saves
 
 saveVolatileVars vars
@@ -921,7 +900,7 @@ saveVolatileVars vars
       = getCAddrModeIfVolatile var `thenFC` \ v ->
 	case v of
 	    Nothing	    -> save_em vars -- Non-volatile, so carry on
-			       
+
 
 	    Just vol_amode  ->	-- Aha! It's volatile
 			       save_var var vol_amode 	`thenFC` \ abs_c ->
@@ -929,31 +908,31 @@ saveVolatileVars vars
 			       returnFC (abs_c `mkAbsCStmts` abs_cs)
 
     save_var var vol_amode
-      | isFollowableKind kind
+      | isFollowableRep kind
       = allocAStack 			`thenFC` \ a_slot ->
 	rebindToAStack var a_slot 	`thenC`
 	getSpARelOffset a_slot		`thenFC` \ spa_rel ->
 	returnFC (CAssign (CVal spa_rel kind) vol_amode)
       | otherwise
-      = allocBStack (getKindSize kind) 	`thenFC` \ b_slot ->
+      = allocBStack (getPrimRepSize kind) 	`thenFC` \ b_slot ->
 	rebindToBStack var b_slot 	`thenC`
 	getSpBRelOffset b_slot		`thenFC` \ spb_rel ->
 	returnFC (CAssign (CVal spb_rel kind) vol_amode)
       where
-        kind = getAmodeKind vol_amode
+	kind = getAmodeRep vol_amode
 
 saveReturnAddress :: FCode (EndOfBlockInfo, AbstractC)
-saveReturnAddress 
+saveReturnAddress
   = getEndOfBlockInfo                `thenFC` \ eob_info@(EndOfBlockInfo vA vB sequel) ->
 
       -- See if it is volatile
     case sequel of
       InRetReg ->     -- Yes, it's volatile
-                   allocBStack retKindSize    `thenFC` \ b_slot ->
-                   getSpBRelOffset b_slot      `thenFC` \ spb_rel ->
+		   allocBStack retPrimRepSize    `thenFC` \ b_slot ->
+		   getSpBRelOffset b_slot      `thenFC` \ spb_rel ->
 
-                   returnFC (EndOfBlockInfo vA vB (OnStack b_slot),
-                             CAssign (CVal spb_rel RetKind) (CReg RetReg))
+		   returnFC (EndOfBlockInfo vA vB (OnStack b_slot),
+			     CAssign (CVal spb_rel RetRep) (CReg RetReg))
 
       UpdateCode _ ->   -- It's non-volatile all right, but we still need
 			-- to allocate a B-stack slot for it, *solely* to make
@@ -961,11 +940,11 @@ saveReturnAddress
 			-- appear adjacent on the B stack. This makes sure
 			-- that B-stack squeezing works ok.
 			-- See note below
-                   allocBStack retKindSize    `thenFC` \ b_slot ->
-	           returnFC (eob_info, AbsCNop)
+		   allocBStack retPrimRepSize    `thenFC` \ b_slot ->
+		   returnFC (eob_info, AbsCNop)
 
       other ->     	 -- No, it's non-volatile, so do nothing
-                   returnFC (eob_info, AbsCNop)
+		   returnFC (eob_info, AbsCNop)
 \end{code}
 
 Note about B-stack squeezing.  Consider the following:`
@@ -992,7 +971,7 @@ virtual offset of the location, to pass on to the alternatives, and
 (b)~the assignment to do the save (just as for @saveVolatileVars@).
 
 \begin{code}
-saveCurrentCostCentre :: 
+saveCurrentCostCentre ::
 	FCode (Maybe VirtualSpBOffset,	-- Where we decide to store it
 					--   Nothing if not lexical CCs
 	       AbstractC)		-- Assignment to save it
@@ -1003,19 +982,19 @@ saveCurrentCostCentre
     if not doing_profiling then
 	returnFC (Nothing, AbsCNop)
     else
-	allocBStack (getKindSize CostCentreKind) `thenFC` \ b_slot ->
+	allocBStack (getPrimRepSize CostCentreRep) `thenFC` \ b_slot ->
 	getSpBRelOffset b_slot		     	 `thenFC` \ spb_rel ->
 	returnFC (Just b_slot,
-		  CAssign (CVal spb_rel CostCentreKind) (CReg CurCostCentre))
+		  CAssign (CVal spb_rel CostCentreRep) (CReg CurCostCentre))
 
 restoreCurrentCostCentre :: Maybe VirtualSpBOffset -> FCode AbstractC
 
-restoreCurrentCostCentre Nothing 
+restoreCurrentCostCentre Nothing
  = returnFC AbsCNop
-restoreCurrentCostCentre (Just b_slot) 
+restoreCurrentCostCentre (Just b_slot)
  = getSpBRelOffset b_slot			 `thenFC` \ spb_rel ->
    freeBStkSlot b_slot				 `thenC`
-   returnFC (CCallProfCCMacro SLIT("RESTORE_CCC") [CVal spb_rel CostCentreKind])
+   returnFC (CCallProfCCMacro SLIT("RESTORE_CCC") [CVal spb_rel CostCentreRep])
     -- we use the RESTORE_CCC macro, rather than just
     -- assigning into CurCostCentre, in case RESTORE_CCC
     -- has some sanity-checking in it.
@@ -1033,7 +1012,7 @@ mode for it.
 
 \begin{code}
 mkReturnVector :: Unique
-	       -> UniType
+	       -> Type
 	       -> [(ConTag, AbstractC)] -- Branch codes
 	       -> AbstractC		-- Default case
 	       -> FCode CAddrMode
@@ -1045,15 +1024,15 @@ mkReturnVector uniq ty tagged_alt_absCs deflt_absC
       UnvectoredReturn _ ->
     	(CUnVecLbl ret_label vtbl_label,
 	 absC (CRetUnVector vtbl_label
-	                    (CLabelledCode ret_label
-    	    	    	    	    	   (mkAlgAltsCSwitch (CReg TagReg) 
-    	    	    	    	    	    	    	     tagged_alt_absCs 
-                                                             deflt_absC))));
+			    (CLabelledCode ret_label
+    	    	    	    	    	   (mkAlgAltsCSwitch (CReg TagReg)
+    	    	    	    	    	    	    	     tagged_alt_absCs
+							     deflt_absC))));
       VectoredReturn table_size ->
-    	(CLbl vtbl_label DataPtrKind,
+    	(CLbl vtbl_label DataPtrRep,
 	 absC (CRetVector vtbl_label
 			-- must restore cc before each alt, if required
-	                  (map mk_vector_entry [fIRST_TAG .. (table_size+fIRST_TAG-1)])
+			  (map mk_vector_entry [fIRST_TAG .. (table_size+fIRST_TAG-1)])
 			  deflt_absC))
 
 -- Leave nops and comments in for now; they are eliminated
diff --git a/ghc/compiler/codeGen/CgClosure.hi b/ghc/compiler/codeGen/CgClosure.hi
deleted file mode 100644
index 36957ad7bd..0000000000
--- a/ghc/compiler/codeGen/CgClosure.hi
+++ /dev/null
@@ -1,29 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface CgClosure where
-import AbsCSyn(AbstractC)
-import CgBindery(CgIdInfo)
-import CgMonad(CgInfoDownwards, CgState, CompilationInfo, EndOfBlockInfo, StubFlag)
-import ClosureInfo(LambdaFormInfo)
-import CmdLineOpts(GlobalSwitch)
-import CostCentre(CostCentre)
-import HeapOffs(HeapOffset)
-import Id(Id)
-import Maybes(Labda)
-import PreludePS(_PackedString)
-import PrimOps(PrimOp)
-import StgSyn(StgAtom, StgBinderInfo, StgBinding, StgCaseAlternatives, StgExpr, UpdateFlag)
-import UniType(UniType)
-import UniqFM(UniqFM)
-import Unique(Unique)
-data CgIdInfo 
-data CgInfoDownwards 
-data CgState 
-data CompilationInfo 
-data HeapOffset 
-data Id 
-data Labda a 
-data StgExpr a b 
-data UpdateFlag 
-cgRhsClosure :: Id -> CostCentre -> StgBinderInfo -> [Id] -> [Id] -> StgExpr Id Id -> LambdaFormInfo -> CgInfoDownwards -> CgState -> ((Id, CgIdInfo), CgState)
-cgTopRhsClosure :: Id -> CostCentre -> StgBinderInfo -> [Id] -> StgExpr Id Id -> LambdaFormInfo -> CgInfoDownwards -> CgState -> ((Id, CgIdInfo), CgState)
-
diff --git a/ghc/compiler/codeGen/CgClosure.lhs b/ghc/compiler/codeGen/CgClosure.lhs
index 677cf2f421..af318428cb 100644
--- a/ghc/compiler/codeGen/CgClosure.lhs
+++ b/ghc/compiler/codeGen/CgClosure.lhs
@@ -10,31 +10,18 @@ with {\em closures} on the RHSs of let(rec)s.  See also
 \begin{code}
 #include "HsVersions.h"
 
-module CgClosure (
-	cgTopRhsClosure, cgRhsClosure,
-
-	-- and to make the interface self-sufficient...
-	StgExpr, Id, CgState, Maybe, HeapOffset,
-	CgInfoDownwards, CgIdInfo, CompilationInfo,
-	UpdateFlag
-    ) where
-
-IMPORT_Trace		-- ToDo: rm (debugging)
-import Outputable
-import Pretty	-- NB: see below
+module CgClosure ( cgTopRhsClosure, cgRhsClosure ) where
 
 import StgSyn
 import CgMonad
 import AbsCSyn
 
-import AbsPrel		( PrimOp(..), primOpNameInfo, Name
+import PrelInfo		( PrimOp(..), Name
 			  IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
 			  IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
 			)
-import AbsUniType	( isPrimType, isPrimTyCon,
+import Type		( isPrimType, isPrimTyCon,
 			  getTauType, showTypeCategory, getTyConDataCons
-			  IF_ATTACK_PRAGMAS(COMMA splitType)
-			  IF_ATTACK_PRAGMAS(COMMA splitTyArgs)
 			)
 import CgBindery	( getCAddrMode, getAtomAmodes,
 			  getCAddrModeAndInfo,
@@ -48,7 +35,7 @@ import CgHeapery	( allocDynClosure, heapCheck
 #ifdef GRAN
 			  , heapCheckOnly, fetchAndReschedule  -- HWL
 #endif  {- GRAN -}
-	                )
+			)
 import CgRetConv	( ctrlReturnConvAlg, dataReturnConvAlg, mkLiveRegsBitMask,
 			  CtrlReturnConvention(..), DataReturnConvention(..)
 			)
@@ -59,18 +46,17 @@ import CgUsages		( getVirtSps, setRealAndVirtualSps,
 			  getSpARelOffset, getSpBRelOffset,
 			  getHpRelOffset
 			)
-import CLabelInfo
+import CLabel
 import ClosureInfo	-- lots and lots of stuff
-import CmdLineOpts	( GlobalSwitch(..) )
 import CostCentre
-import Id		( getIdUniType, getIdKind, isSysLocalId, myWrapperMaybe,
+import Id		( idType, getIdPrimRep, isSysLocalId, myWrapperMaybe,
 			  showId, getIdInfo, getIdStrictness,
     	    	    	  getDataConTag
 			)
 import IdInfo
 import ListSetOps	( minusList )
 import Maybes		( Maybe(..), maybeToBool )
-import PrimKind		( isFollowableKind )
+import PrimRep		( isFollowableRep )
 import UniqSet
 import Unpretty
 import Util
@@ -90,50 +76,18 @@ cgTopRhsClosure :: Id
 		-> CostCentre	-- Optional cost centre annotation
 		-> StgBinderInfo
 		-> [Id]		-- Args
-		-> PlainStgExpr
+		-> StgExpr
 		-> LambdaFormInfo
 		-> FCode (Id, CgIdInfo)
-\end{code}
 
-\begin{code}
-{- NOT USED:
-cgTopRhsClosure name cc binder_info args body lf_info
-  | maybeToBool maybe_std_thunk		-- AHA!  A STANDARD-FORM THUNK
-  = (	
-	-- LAY OUT THE OBJECT
-    getAtomAmodes std_thunk_payload		`thenFC` \ amodes ->
-    let
-	(closure_info, amodes_w_offsets) = layOutStaticClosure name getAmodeKind amodes lf_info
-    in
-     
-	-- BUILD THE OBJECT
-    chooseStaticCostCentre cc lf_info		`thenFC` \ cost_centre ->
-    absC (CStaticClosure 
-		closure_label			-- Labelled with the name on lhs of defn
-		closure_info
-	    	cost_centre 
-		(map fst amodes_w_offsets))	-- They are in the correct order
-    ) `thenC`
-
-    returnFC (name, stableAmodeIdInfo name (CLbl closure_label PtrKind) lf_info)
-  where
-    maybe_std_thunk        = getStandardFormThunkInfo lf_info
-    Just std_thunk_payload = maybe_std_thunk
-
-    closure_label = mkClosureLabel name
--}
-\end{code}
-
-The general case:
-\begin{code}
 cgTopRhsClosure name cc binder_info args body lf_info
   = 	-- LAY OUT THE OBJECT
     let
 	closure_info = layOutStaticNoFVClosure name lf_info
     in
-     
+
 	-- GENERATE THE INFO TABLE (IF NECESSARY)
-    forkClosureBody (closureCodeBody binder_info closure_info 
+    forkClosureBody (closureCodeBody binder_info closure_info
 					 cc args body)
     							`thenC`
 
@@ -146,7 +100,7 @@ cgTopRhsClosure name cc binder_info args body lf_info
     else
 	let
 	    bind_the_fun = addBindC name cg_id_info	-- It's global!
-        in
+	in
 	cgVapInfoTables True {- Top level -} bind_the_fun binder_info name args lf_info
     ) `thenC`
 
@@ -156,10 +110,10 @@ cgTopRhsClosure name cc binder_info args body lf_info
 	let
 	    cost_centre = mkCCostCentre cc
 	in
-	absC (CStaticClosure 
+	absC (CStaticClosure
 		closure_label	-- Labelled with the name on lhs of defn
 		closure_info
-	    	cost_centre 
+	    	cost_centre
 		[])		-- No fields
      else
 	nopC
@@ -168,7 +122,7 @@ cgTopRhsClosure name cc binder_info args body lf_info
     returnFC (name, cg_id_info)
   where
     closure_label = mkClosureLabel name
-    cg_id_info    = stableAmodeIdInfo name (CLbl closure_label PtrKind) lf_info
+    cg_id_info    = stableAmodeIdInfo name (CLbl closure_label PtrRep) lf_info
 \end{code}
 
 %********************************************************
@@ -184,7 +138,7 @@ For closures with free vars, allocate in heap.
 -- Closures which (a) have no fvs and (b) have some args (i.e.
 -- combinator functions), are allocated statically, just as if they
 -- were top-level closures.  We can't get a space leak that way
--- (because they are HNFs) and it saves allocation. 
+-- (because they are HNFs) and it saves allocation.
 
 -- Lexical Scoping: Problem
 -- These top level function closures will be inherited, possibly
@@ -208,7 +162,7 @@ cgRhsClosure	:: Id
 		-> StgBinderInfo
 		-> [Id]		-- Free vars
 		-> [Id]		-- Args
-		-> PlainStgExpr
+		-> StgExpr
 		-> LambdaFormInfo
 		-> FCode (Id, CgIdInfo)
 
@@ -220,13 +174,13 @@ cgRhsClosure binder cc binder_info fvs args body lf_info
     getAtomAmodes std_thunk_payload		`thenFC` \ amodes ->
     let
 	(closure_info, amodes_w_offsets)
-	  = layOutDynClosure binder getAmodeKind amodes lf_info
+	  = layOutDynClosure binder getAmodeRep amodes lf_info
 
 	(use_cc, blame_cc) = chooseDynCostCentres cc args fvs body
     in
 	-- BUILD THE OBJECT
     allocDynClosure closure_info use_cc blame_cc amodes_w_offsets
-    )		
+    )
 		`thenFC` \ heap_offset ->
 
 	-- RETURN
@@ -253,10 +207,10 @@ cgRhsClosure binder cc binder_info fvs args body lf_info
     let
 	is_elem	       = isIn "cgRhsClosure"
 
-	binder_is_a_fv = binder `is_elem` fvs 
-        reduced_fvs    = if binder_is_a_fv 
-		         then fvs `minusList` [binder]
-		         else fvs
+	binder_is_a_fv = binder `is_elem` fvs
+	reduced_fvs    = if binder_is_a_fv
+			 then fvs `minusList` [binder]
+			 else fvs
     in
     mapFCs getCAddrModeAndInfo reduced_fvs	`thenFC` \ amodes_and_info ->
     let
@@ -272,7 +226,7 @@ cgRhsClosure binder cc binder_info fvs args body lf_info
 
 	amodes_w_offsets = [(amode,offset) | ((_, (amode,_)), offset) <- bind_details]
 
-	get_kind (id, amode_and_info) = getIdKind id
+	get_kind (id, amode_and_info) = getIdPrimRep id
     in
 	-- BUILD ITS INFO TABLE AND CODE
     forkClosureBody (
@@ -347,33 +301,33 @@ 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 (StgVarAtom fun) (map StgVarAtom args) emptyUniqSet	
+	--
+	vap_entry_rhs = StgApp (StgVarArg fun) (map StgVarArg args) emptyUniqSet
 									-- Empty live vars
 
 	arg_ids_w_info = [(name,mkLFArgument) | name <- args]
 	payload_ids_w_info | fun_in_payload = (fun,fun_lf_info) : arg_ids_w_info
-		           | otherwise	    = arg_ids_w_info
+			   | otherwise	    = arg_ids_w_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
+					upd_flag [] vap_entry_rhs
 		-- 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 
+		-- function, because any VAP *use* of this function will be for a
 		-- local thunk, thus
 		--		let x = f p q	-- x isn't top level!
 		--		in ...
 
-	get_kind (id, info) = getIdKind id
+	get_kind (id, info) = getIdPrimRep id
 
 	payload_bind_details :: [((Id, LambdaFormInfo), VirtualHeapOffset)]
-	(closure_info, payload_bind_details) = layOutDynClosure 
-							fun 
-							get_kind payload_ids_w_info 
+	(closure_info, payload_bind_details) = layOutDynClosure
+							fun
+							get_kind payload_ids_w_info
 							vap_lf_info
-		-- The dodgy thing is that we use the "fun" as the 
+		-- The dodgy thing is that we use the "fun" as the
 		-- Id to give to layOutDynClosure.  This Id gets embedded in
 		-- the closure_info it returns.  But of course, the function doesn't
 		-- have the right type to match the Vap closure.  Never mind,
@@ -410,7 +364,7 @@ closureCodeBody :: StgBinderInfo
 		-> ClosureInfo	-- Lots of information about this closure
 		-> CostCentre	-- Optional cost centre attached to closure
 		-> [Id]
-		-> PlainStgExpr
+		-> StgExpr
 		-> Code
 \end{code}
 
@@ -444,12 +398,12 @@ closureCodeBody binder_info closure_info cc [] body
   where
     cl_descr mod_name = closureDescription mod_name (closureId closure_info) [] body
 
-    body_addr   = CLbl (entryLabelFromCI closure_info) CodePtrKind
+    body_addr   = CLbl (entryLabelFromCI closure_info) CodePtrRep
     body_code   = profCtrC SLIT("ENT_THK") [] 			`thenC`
 		  enterCostCentreCode closure_info cc IsThunk	`thenC`
 		  thunkWrapper closure_info (cgSccExpr body)
 
-    stdUpd      = CLbl mkErrorStdEntryLabel CodePtrKind
+    stdUpd      = CLbl mkErrorStdEntryLabel CodePtrRep
 \end{code}
 
 If there is {\em at least one argument}, then this closure is in
@@ -464,7 +418,7 @@ Node points to closure is available. -- HWL
 \begin{code}
 closureCodeBody binder_info closure_info cc all_args body
   = getEntryConvention id lf_info
-		       (map getIdKind all_args)		`thenFC` \ entry_conv ->
+		       (map getIdPrimRep all_args)		`thenFC` \ entry_conv ->
 
     isSwitchSetC EmitArityChecks			`thenFC` \ do_arity_chks ->
 
@@ -477,12 +431,12 @@ closureCodeBody binder_info closure_info cc all_args body
 
 	-- 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 
+	   = mkVirtStkOffsets
 		0 0 		-- Initial virtual SpA, SpB
-		getIdKind 
+		getIdPrimRep
 		all_args
 
-	-- Arg mapping for the fast entry point; as many args as poss in 
+	-- Arg mapping for the fast entry point; as many args as poss in
 	-- registers; the rest on the stack
     	-- 	arg_regs are the registers used for arg passing
 	-- 	stk_args are the args which are passed on the stack
@@ -494,21 +448,21 @@ closureCodeBody binder_info closure_info cc all_args body
 
     	stk_args = drop (length arg_regs) all_args
     	(spA_stk_args, spB_stk_args, stk_bxd_w_offsets, stk_ubxd_w_offsets)
-	  = mkVirtStkOffsets 
+	  = mkVirtStkOffsets
 		0 0 		-- Initial virtual SpA, SpB
-		getIdKind 
+		getIdPrimRep
 		stk_args
 
 	-- HWL; Note: empty list of live regs in slow entry code
 	-- Old version (reschedule combined with heap check);
 	-- see argSatisfactionCheck for new version
 	--slow_entry_code = forceHeapCheck [node] True slow_entry_code'
-	--		  where node = VanillaReg PtrKind 1
+	--		  where node = VanillaReg PtrRep 1
 	--slow_entry_code = forceHeapCheck [] True slow_entry_code'
 
     	slow_entry_code
       	  = profCtrC SLIT("ENT_FUN_STD") []		    `thenC`
-	
+
 		-- Bind args, and record expected position of stk ptrs
 	    mapCs bindNewToAStack all_bxd_w_offsets	    `thenC`
 	    mapCs bindNewToBStack all_ubxd_w_offsets	    `thenC`
@@ -516,9 +470,11 @@ closureCodeBody binder_info closure_info cc all_args body
 
 	    argSatisfactionCheck closure_info all_args	    `thenC`
 
-	    -- OK, so there are enough args.  Now we need to stuff as 
-	    -- many of them in registers as the fast-entry code expects
-	    -- Note that the zipWith will give up when it hits the end of arg_regs
+	    -- OK, so there are enough args.  Now we need to stuff as
+	    -- many of them in registers as the fast-entry code
+	    -- expects Note that the zipWith will give up when it hits
+	    -- the end of arg_regs.
+
 	    mapFCs getCAddrMode all_args		    `thenFC` \ stk_amodes ->
 	    absC (mkAbstractCs (zipWith assign_to_reg arg_regs stk_amodes)) `thenC`
 
@@ -531,13 +487,7 @@ closureCodeBody binder_info closure_info cc all_args body
 		then CMacroStmt SET_ARITY [mkIntCLit stg_arity]
 		else AbsCNop
 	    )							`thenC`
-
-#ifndef DPH
-    	    absC (CFallThrough (CLbl fast_label CodePtrKind))
-#else
-	    -- Fall through to the fast entry point
-	    absC (AbsCNop)
-#endif {- Data Parallel Haskell -}
+    	    absC (CFallThrough (CLbl fast_label CodePtrRep))
 
 	assign_to_reg reg_id amode = CAssign (CReg reg_id) amode
 
@@ -546,14 +496,14 @@ closureCodeBody binder_info closure_info cc all_args body
 	-- see argSatisfactionCheck for new version
 	-- fast_entry_code = forceHeapCheck [] True fast_entry_code'
 
-        fast_entry_code	
-          = profCtrC SLIT("ENT_FUN_DIRECT") [
-		    CLbl (mkRednCountsLabel id) PtrKind,
+	fast_entry_code
+	  = profCtrC SLIT("ENT_FUN_DIRECT") [
+		    CLbl (mkRednCountsLabel id) PtrRep,
 		    CString (_PK_ (showId PprDebug id)),
 		    mkIntCLit stg_arity,	-- total # of args
 		    mkIntCLit spA_stk_args,	-- # passed on A stk
 		    mkIntCLit spB_stk_args,	-- B stk (rest in regs)
-		    CString (_PK_ (map (showTypeCategory . getIdUniType) all_args)),
+		    CString (_PK_ (map (showTypeCategory . idType) all_args)),
 		    CString (_PK_ (show_wrapper_name wrapper_maybe)),
 		    CString (_PK_ (show_wrapper_arg_kinds wrapper_maybe))
 		]			`thenC`
@@ -577,20 +527,20 @@ closureCodeBody binder_info closure_info cc all_args body
 	    funWrapper closure_info arg_regs (cgExpr body)
     in
  	-- Make a labelled code-block for the slow and fast entry code
-    forkAbsC (if slow_code_needed then slow_entry_code else absC AbsCNop)  		
+    forkAbsC (if slow_code_needed then slow_entry_code else absC AbsCNop)
 				`thenFC` \ slow_abs_c ->
     forkAbsC fast_entry_code	`thenFC` \ fast_abs_c ->
     moduleName			`thenFC` \ mod_name ->
     getIntSwitchChkrC		`thenFC` \ isw_chkr ->
-    
+
 	-- Now either construct the info table, or put the fast code in alone
 	-- (We never have slow code without an info table)
     absC (
       if info_table_needed then
-        CClosureInfoAndCode closure_info slow_abs_c (Just fast_abs_c)
+	CClosureInfoAndCode closure_info slow_abs_c (Just fast_abs_c)
 			stdUpd (cl_descr mod_name)
 			(dataConLiveness isw_chkr closure_info)
-      else 
+      else
 	CCodeBlock fast_label fast_abs_c
     )
   where
@@ -604,10 +554,10 @@ closureCodeBody binder_info closure_info cc all_args body
 
 	-- Manufacture labels
     id	       = closureId closure_info
-				
+
     fast_label = fastLabelFromCI closure_info
 
-    stdUpd = CLbl mkErrorStdEntryLabel CodePtrKind
+    stdUpd = CLbl mkErrorStdEntryLabel CodePtrRep
 
     wrapper_maybe = get_ultimate_wrapper Nothing id
       where
@@ -621,7 +571,7 @@ closureCodeBody binder_info closure_info cc all_args body
 
     show_wrapper_arg_kinds Nothing   = ""
     show_wrapper_arg_kinds (Just xx)
-      = case (getWrapperArgTypeCategories (getIdUniType xx) (getIdStrictness xx)) of
+      = case (getWrapperArgTypeCategories (idType xx) (getIdStrictness xx)) of
 	  Nothing  -> ""
 	  Just str -> str
 \end{code}
@@ -653,7 +603,7 @@ enterCostCentreCode closure_info cc is_thunk
 				      -- NB: chk defn of "is_current_CC"
 				      -- if you go to change this! (WDP 94/12)
 	    costCentresC
-		(case is_thunk of 
+		(case is_thunk of
 		   IsThunk    -> SLIT("ENTER_CC_TCL")
 		   IsFunction -> SLIT("ENTER_CC_FCL"))
 		[CReg node]
@@ -665,14 +615,14 @@ enterCostCentreCode closure_info cc is_thunk
 
 	else -- we've got a "real" cost centre right here in our hands...
 	    costCentresC
-		(case is_thunk of 
+		(case is_thunk of
 		   IsThunk    -> SLIT("ENTER_CC_T")
 		   IsFunction -> SLIT("ENTER_CC_F"))
 		[mkCCostCentre cc]
   where
     is_current_CC cc
       = currentOrSubsumedCosts cc
-        -- but we've already ruled out "subsumed", so it must be "current"!
+	-- but we've already ruled out "subsumed", so it must be "current"!
 \end{code}
 
 %************************************************************************
@@ -697,8 +647,8 @@ argSatisfactionCheck closure_info [] = nopC
 argSatisfactionCheck closure_info args
   = -- safest way to determine which stack last arg will be on:
     -- look up CAddrMode that last arg is bound to;
-    -- getAmodeKind;
-    -- check isFollowableKind.
+    -- getAmodeRep;
+    -- check isFollowableRep.
 
     nodeMustPointToIt (closureLFInfo closure_info) 	`thenFC` \ node_points ->
 
@@ -706,20 +656,20 @@ argSatisfactionCheck closure_info args
     -- HWL:
     -- absC (CMacroStmt GRAN_FETCH []) 			`thenC`
     -- forceHeapCheck [] node_points (absC AbsCNop)	`thenC`
-    (if node_points 
+    (if node_points
 	then fetchAndReschedule  [] node_points
 	else absC AbsCNop)				`thenC`
 #endif  {- GRAN -}
 
     getCAddrMode (last args) 				`thenFC` \ last_amode ->
 
-    if (isFollowableKind (getAmodeKind last_amode)) then
-	getSpARelOffset 0 	`thenFC` \ a_rel_offset ->
+    if (isFollowableRep (getAmodeRep last_amode)) then
+	getSpARelOffset 0 	`thenFC` \ (SpARel spA off) ->
 	if node_points then
-	    absC (CMacroStmt ARGS_CHK_A [mkIntCLit (spARelToInt a_rel_offset)])
+	    absC (CMacroStmt ARGS_CHK_A [mkIntCLit (spARelToInt spA off)])
 	else
 	    absC (CMacroStmt ARGS_CHK_A_LOAD_NODE
-				[mkIntCLit (spARelToInt a_rel_offset), set_Node_to_this])
+				[mkIntCLit (spARelToInt spA off), set_Node_to_this])
     else
 	getSpBRelOffset 0 	`thenFC` \ b_rel_offset ->
 	if node_points then
@@ -732,7 +682,7 @@ argSatisfactionCheck closure_info args
     -- the closure or not.  If it isn't so pointing, then we give to
     -- the macro the (static) address of the closure.
 
-    set_Node_to_this = CLbl (closureLabelFromCI closure_info) PtrKind
+    set_Node_to_this = CLbl (closureLabelFromCI closure_info) PtrRep
 \end{code}
 
 %************************************************************************
@@ -749,8 +699,8 @@ thunkWrapper closure_info thunk_code
 
 #ifdef GRAN
     -- HWL insert macros for GrAnSim if node is live here
-    (if node_points 
-       then fetchAndReschedule [] node_points 
+    (if node_points
+       then fetchAndReschedule [] node_points
        else absC AbsCNop)              			`thenC`
 #endif  {- GRAN -}
 
@@ -768,17 +718,7 @@ thunkWrapper closure_info thunk_code
 
 	-- Push update frame if necessary
     setupUpdate closure_info (		-- setupUpdate *encloses* the rest
-
-	-- Evaluation scoping -- load current cost centre from closure
-	-- Must be done after the update frame is pushed
-	-- Node is guaranteed to point to it, if profiling
--- OLD:
---  (if isStaticClosure closure_info
---   then evalCostCentreC "SET_CAFCC_CL" [CReg node]
---   else evalCostCentreC "ENTER_CC_TCL"  [CReg node])	`thenC`
-
-	-- Finally, do the business
-    thunk_code
+	thunk_code
     )))
 
 funWrapper :: ClosureInfo 	-- Closure whose code body this is
@@ -808,15 +748,15 @@ funWrapper closure_info arg_regs fun_body
 Assumption: virtual and real stack pointers are currently exactly aligned.
 
 \begin{code}
-stackCheck :: ClosureInfo 
+stackCheck :: ClosureInfo
 	   -> [MagicId] 		-- Live registers
 	   -> Bool 			-- Node required to point after check?
-	   -> Code 
+	   -> Code
 	   -> Code
 
 stackCheck closure_info regs node_reqd code
   = getFinalStackHW (\ aHw -> \ bHw ->	-- Both virtual stack offsets
-    
+
     getVirtSps		`thenFC` \ (vSpA, vSpB) ->
 
     let a_headroom_reqd = aHw - vSpA	-- Virtual offsets are positive integers
@@ -829,7 +769,7 @@ stackCheck closure_info regs node_reqd code
 		CMacroStmt STK_CHK [mkIntCLit liveness_mask,
 				    mkIntCLit a_headroom_reqd,
 				    mkIntCLit b_headroom_reqd,
-				    mkIntCLit vSpA, 
+				    mkIntCLit vSpA,
 				    mkIntCLit vSpB,
 				    mkIntCLit (if returns_prim_type then 1 else 0),
 				    mkIntCLit (if node_reqd         then 1 else 0)]
@@ -880,14 +820,8 @@ setupUpdate closure_info code
 	getIntSwitchChkrC	`thenFC` \ isw_chkr ->
     	pushUpdateFrame update_closure (vector isw_chkr) code
    else
-	-- Non-updatable thunks still need a resume-cost-centre "update"
-	-- frame to be pushed if we are doing evaluation profiling.
-
---OLD:	evalPushRCCFrame False {-never primitive-} (
-	profCtrC SLIT("UPDF_OMITTED") []
-						`thenC`
+	profCtrC SLIT("UPDF_OMITTED") [] `thenC`
 	code
---	)
  where
    link_caf_if_needed :: FCode CAddrMode	-- Returns amode for closure to be updated
    link_caf_if_needed
@@ -901,12 +835,12 @@ setupUpdate closure_info code
 		-- Alloc black hole specifying CC_HDR(Node) as the cost centre
 		--   Hack Warning: Using a CLitLit to get CAddrMode !
 	  let
-	      use_cc   = CLitLit SLIT("CC_HDR(R1.p)") PtrKind
+	      use_cc   = CLitLit SLIT("CC_HDR(R1.p)") PtrRep
 	      blame_cc = use_cc
 	  in
 	  allocDynClosure (blackHoleClosureInfo closure_info) use_cc blame_cc []
 							`thenFC` \ heap_offset ->
-	  getHpRelOffset heap_offset			`thenFC` \ hp_rel -> 
+	  getHpRelOffset heap_offset			`thenFC` \ hp_rel ->
 	  let  amode = CAddr hp_rel
 	  in
 	  absC (CMacroStmt UPD_CAF [CReg node, amode])
@@ -920,10 +854,10 @@ setupUpdate closure_info code
     	Nothing -> CReg StdUpdRetVecReg
     	Just (spec_tycon, _, spec_datacons) ->
 	    case (ctrlReturnConvAlg spec_tycon) of
-    	      UnvectoredReturn 1 -> 
+    	      UnvectoredReturn 1 ->
        	    	let
 		    spec_data_con = head spec_datacons
-                    only_tag = getDataConTag spec_data_con
+		    only_tag = getDataConTag spec_data_con
 
     	    	    direct = case (dataReturnConvAlg isw_chkr spec_data_con) of
     	    	        ReturnInRegs _ -> mkConUpdCodePtrVecLabel spec_tycon only_tag
@@ -934,7 +868,7 @@ setupUpdate closure_info code
     	    	    CUnVecLbl direct vectored
 
 	      UnvectoredReturn _ -> CReg StdUpdRetVecReg
-	      VectoredReturn _   -> CLbl (mkStdUpdVecTblLabel spec_tycon) DataPtrKind
+	      VectoredReturn _   -> CLbl (mkStdUpdVecTblLabel spec_tycon) DataPtrRep
 \end{code}
 
 %************************************************************************
@@ -953,7 +887,7 @@ binding information.
 closureDescription :: FAST_STRING	-- Module
 		   -> Id		-- Id of closure binding
 		   -> [Id]		-- Args
-		   -> PlainStgExpr	-- Body
+		   -> StgExpr	-- Body
 		   -> String
 
 	-- Not called for StgRhsCon which have global info tables built in
@@ -961,11 +895,11 @@ closureDescription :: FAST_STRING	-- Module
 
 closureDescription mod_name name args body =
     uppShow 0 (prettyToUn (
-	ppBesides [ppChar '<', 
-                   ppPStr mod_name, 
-                   ppChar '.', 
-                   ppr PprDebug name, 
-                   ppChar '>']))
+	ppBesides [ppChar '<',
+		   ppPStr mod_name,
+		   ppChar '.',
+		   ppr PprDebug name,
+		   ppChar '>']))
 \end{code}
 
 \begin{code}
@@ -978,9 +912,9 @@ chooseDynCostCentres cc args fvs body
 
 	blame_cc -- cost-centre on whom we blame the allocation
 	  = case (args, fvs, body) of
-	      ([], [just1], StgApp (StgVarAtom fun) [{-no args-}] _)
-	        | just1 == fun
-	        -> mkCCostCentre overheadCostCentre
+	      ([], [just1], StgApp (StgVarArg fun) [{-no args-}] _)
+		| just1 == fun
+		-> mkCCostCentre overheadCostCentre
 	      _ -> use_cc
 	    -- if it's an utterly trivial RHS, then it must be
 	    -- one introduced by boxHigherOrderArgs for profiling,
diff --git a/ghc/compiler/codeGen/CgCompInfo.hi b/ghc/compiler/codeGen/CgCompInfo.hi
deleted file mode 100644
index 9a75ed2346..0000000000
--- a/ghc/compiler/codeGen/CgCompInfo.hi
+++ /dev/null
@@ -1,50 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface CgCompInfo where
-import AbsCSyn(RegRelative)
-import HeapOffs(HeapOffset)
-data RegRelative 
-cON_UF_SIZE :: Int
-iND_TAG :: Integer
-lIVENESS_R1 :: Int
-lIVENESS_R2 :: Int
-lIVENESS_R3 :: Int
-lIVENESS_R4 :: Int
-lIVENESS_R5 :: Int
-lIVENESS_R6 :: Int
-lIVENESS_R7 :: Int
-lIVENESS_R8 :: Int
-mAX_Double_REG :: Int
-mAX_FAMILY_SIZE_FOR_VEC_RETURNS :: Int
-mAX_Float_REG :: Int
-mAX_INTLIKE :: Integer
-mAX_SPEC_ALL_NONPTRS :: Int
-mAX_SPEC_ALL_PTRS :: Int
-mAX_SPEC_MIXED_FIELDS :: Int
-mAX_SPEC_SELECTEE_SIZE :: Int
-mAX_Vanilla_REG :: Int
-mIN_BIG_TUPLE_SIZE :: Int
-mIN_INTLIKE :: Integer
-mIN_MP_INT_SIZE :: Int
-mIN_SIZE_NonUpdHeapObject :: Int
-mIN_SIZE_NonUpdStaticHeapObject :: Int
-mIN_UPD_SIZE :: Int
-mP_STRUCT_SIZE :: Int
-oTHER_TAG :: Integer
-sCC_CON_UF_SIZE :: Int
-sCC_STD_UF_SIZE :: Int
-sTD_UF_SIZE :: Int
-spARelToInt :: RegRelative -> Int
-spBRelToInt :: RegRelative -> Int
-uF_COST_CENTRE :: Int
-uF_RET :: Int
-uF_SUA :: Int
-uF_SUB :: Int
-uF_UPDATEE :: Int
-uNFOLDING_CHEAP_OP_COST :: Int
-uNFOLDING_CON_DISCOUNT_WEIGHT :: Int
-uNFOLDING_CREATION_THRESHOLD :: Int
-uNFOLDING_DEAR_OP_COST :: Int
-uNFOLDING_NOREP_LIT_COST :: Int
-uNFOLDING_OVERRIDE_THRESHOLD :: Int
-uNFOLDING_USE_THRESHOLD :: Int
-
diff --git a/ghc/compiler/codeGen/CgCompInfo.lhs b/ghc/compiler/codeGen/CgCompInfo.lhs
index 56ab5989f6..4b52bf0b6a 100644
--- a/ghc/compiler/codeGen/CgCompInfo.lhs
+++ b/ghc/compiler/codeGen/CgCompInfo.lhs
@@ -39,17 +39,13 @@ module CgCompInfo (
 	uF_COST_CENTRE,
 
 	mAX_Vanilla_REG,
-#ifndef DPH
 	mAX_Float_REG,
 	mAX_Double_REG,
-#else
-	mAX_Data_REG,
-#endif {- Data Parallel Haskell -}
 
 	mIN_BIG_TUPLE_SIZE,
 
     	mIN_MP_INT_SIZE,
-        mP_STRUCT_SIZE,
+	mP_STRUCT_SIZE,
 
 	oTHER_TAG, iND_TAG,	-- semi-tagging stuff
 
@@ -66,10 +62,10 @@ module CgCompInfo (
 
 
 	spARelToInt,
-	spBRelToInt,
+	spBRelToInt
 
 	-- and to make the interface self-sufficient...
-	RegRelative
+--	RegRelative
     ) where
 
 -- This magical #include brings in all the everybody-knows-these magic
@@ -77,13 +73,10 @@ module CgCompInfo (
 -- we want; if we just hope a -I... will get the right one, we could
 -- be in trouble.
 
-#ifndef DPH
 #include "../../includes/GhcConstants.h"
-#else
-#include "../dphsystem/imports/DphConstants.h"
-#endif {- Data Parallel Haskell -}
 
-import AbsCSyn
+CHK_Ubiq() -- debugging consistency check
+
 import Util
 \end{code}
 
@@ -148,8 +141,8 @@ mAX_INTLIKE = MAX_INTLIKE
 
 \begin{code}
 -- THESE ARE DIRECTION SENSITIVE!
-spARelToInt (SpARel spA off) = spA - off -- equiv to: AREL(spA - off)
-spBRelToInt (SpBRel spB off) = off - spB -- equiv to: BREL(spB - off)
+spARelToInt spA off = spA - off -- equiv to: AREL(spA - off)
+spBRelToInt spB off = off - spB -- equiv to: BREL(spB - off)
 \end{code}
 
 A section of code-generator-related MAGIC CONSTANTS.
@@ -174,16 +167,7 @@ uF_COST_CENTRE = (UF_COST_CENTRE::Int)
 \end{code}
 
 \begin{code}
-#ifndef DPH
 mAX_Vanilla_REG	= (MAX_VANILLA_REG :: Int)
 mAX_Float_REG	= (MAX_FLOAT_REG :: Int)
 mAX_Double_REG	= (MAX_DOUBLE_REG :: Int)
-#else
--- The DAP has only got 14 registers :-( After various heap and stack 
--- pointers we dont have that many left over..
-mAX_Vanilla_REG	= (4 :: Int)	-- Ptr, Int, Char, Float	
-mAX_Data_REG    = (4 :: Int)	--      Int, Char, Float, Double
-mAX_Float_REG	= error "mAX_Float_REG : not used in DPH"
-mAX_Double_REG	= error "mAX_Double_REG: not used in DPH"
-#endif {- Data Parallel Haskell -}
 \end{code}
diff --git a/ghc/compiler/codeGen/CgCon.hi b/ghc/compiler/codeGen/CgCon.hi
deleted file mode 100644
index 57c0983534..0000000000
--- a/ghc/compiler/codeGen/CgCon.hi
+++ /dev/null
@@ -1,28 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface CgCon where
-import AbsCSyn(AbstractC, CAddrMode, CExprMacro, MagicId, RegRelative)
-import BasicLit(BasicLit)
-import CLabelInfo(CLabel)
-import CgBindery(CgIdInfo)
-import CgMonad(CgInfoDownwards, CgState, StubFlag)
-import CostCentre(CostCentre)
-import HeapOffs(HeapOffset)
-import Id(Id)
-import PreludePS(_PackedString)
-import PrimKind(PrimKind)
-import PrimOps(PrimOp)
-import StgSyn(StgAtom)
-import UniqFM(UniqFM)
-import Unique(Unique)
-data CAddrMode 
-data MagicId 
-data CgState 
-data Id 
-data PrimKind 
-data PrimOp 
-data StgAtom a 
-bindConArgs :: Id -> [Id] -> CgInfoDownwards -> CgState -> CgState
-buildDynCon :: Id -> CostCentre -> Id -> [CAddrMode] -> Bool -> CgInfoDownwards -> CgState -> (CgIdInfo, CgState)
-cgReturnDataCon :: Id -> [CAddrMode] -> Bool -> UniqFM Id -> CgInfoDownwards -> CgState -> CgState
-cgTopRhsCon :: Id -> Id -> [StgAtom Id] -> Bool -> CgInfoDownwards -> CgState -> ((Id, CgIdInfo), CgState)
-
diff --git a/ghc/compiler/codeGen/CgCon.lhs b/ghc/compiler/codeGen/CgCon.lhs
index 938582741d..8201335699 100644
--- a/ghc/compiler/codeGen/CgCon.lhs
+++ b/ghc/compiler/codeGen/CgCon.lhs
@@ -14,23 +14,17 @@ module CgCon (
 	-- it's all exported, actually...
 	cgTopRhsCon, buildDynCon,
 	bindConArgs,
-	cgReturnDataCon,
+	cgReturnDataCon
 
 	-- and to make the interface self-sufficient...
-	Id, StgAtom, CgState, CAddrMode,
-	PrimKind, PrimOp, MagicId
     ) where
 
-IMPORT_Trace		-- ToDo: rm (debugging)
-import Outputable
-import Pretty
-
 import StgSyn
 import CgMonad
 import AbsCSyn
 
-import AbsUniType	( maybeCharLikeTyCon, maybeIntLikeTyCon, TyVar,
-			  TyCon, Class, UniType
+import Type		( maybeCharLikeTyCon, maybeIntLikeTyCon, TyVar,
+			  TyCon, Class, Type
 			)
 import CgBindery	( getAtomAmode, getAtomAmodes, bindNewToNode,
 			  bindArgsToRegs, newTempAmodeAndIdInfo, idInfoToAmode
@@ -48,8 +42,8 @@ import CgRetConv	( dataReturnConvAlg, mkLiveRegsBitMask,
 			)
 import CgTailCall	( performReturn, mkStaticAlgReturnCode )
 import CgUsages		( getHpRelOffset )
-import CLabelInfo	( CLabel, mkClosureLabel, mkInfoTableLabel,
-                          mkPhantomInfoTableLabel,
+import CLabel	( CLabel, mkClosureLabel, mkInfoTableLabel,
+			  mkPhantomInfoTableLabel,
 			  mkConEntryLabel, mkStdEntryLabel
 			)
 import ClosureInfo	-- hiding ( auxInfoTableLabelFromCI ) -- I hate pragmas
@@ -58,12 +52,11 @@ import ClosureInfo	-- hiding ( auxInfoTableLabelFromCI ) -- I hate pragmas
 			  layOutStaticClosure, UpdateFlag(..),
 			  mkClosureLFInfo, layOutStaticNoFVClosure
 			)-}
-import Id		( getIdKind, getDataConTag, getDataConTyCon,
+import Id		( getIdPrimRep, getDataConTag, getDataConTyCon,
 			  isDataCon, fIRST_TAG, DataCon(..), ConTag(..)
 			)
-import CmdLineOpts	( GlobalSwitch(..) )
 import Maybes		( maybeToBool, Maybe(..) )
-import PrimKind		( PrimKind(..), isFloatingKind, getKindSize )
+import PrimRep		( PrimRep(..), isFloatingRep, getPrimRepSize )
 import CostCentre
 import UniqSet		-- ( emptyUniqSet, UniqSet(..) )
 import Util
@@ -78,12 +71,12 @@ import Util
 \begin{code}
 cgTopRhsCon :: Id		-- Name of thing bound to this RHS
 	    -> DataCon		-- Id
-	    -> [PlainStgAtom]	-- Args
+	    -> [StgArg]	-- Args
 	    -> Bool		-- All zero-size args (see buildDynCon)
 	    -> FCode (Id, CgIdInfo)
 \end{code}
 
-Special Case: 
+Special Case:
 Constructors some of whose arguments are of \tr{Float#} or
 \tr{Double#} type, {\em or} which are ``lit lits'' (which are given
 \tr{Addr#} type).
@@ -106,7 +99,7 @@ Thus, for \tr{x = 2.0} (defaults to Double), we get:
     STATIC_INFO_TABLE(Main_x,Main_x_entry,,,,EXTFUN,???,":MkDouble","Double");
 -- with its *own* entry code:
     STGFUN(Main_x_entry) {
-        P_ u1701;
+	P_ u1701;
 	RetDouble1=2.0;
 	u1701=(P_)*SpB;
 	SpB=SpB-1;
@@ -133,11 +126,11 @@ top_cc  = dontCareCostCentre -- out here to avoid a cgTopRhsCon CAF (sigh)
 top_ccc = mkCCostCentre dontCareCostCentre -- because it's static data
 
 cgTopRhsCon name con args all_zero_size_args
-  |  any (isFloatingKind . getAtomKind) args
-  || any isLitLitStgAtom args
+  |  any (isFloatingRep . getArgPrimRep) args
+  || any isLitLitArg args
   = cgTopRhsClosure name top_cc NoStgBinderInfo [] body lf_info
   where
-    body = StgConApp con args emptyUniqSet{-emptyLiveVarSet-}
+    body = StgCon con args emptyUniqSet{-emptyLiveVarSet-}
     lf_info = mkClosureLFInfo True {- Top level -} [] ReEntrant [] body
 \end{code}
 
@@ -153,7 +146,7 @@ cgTopRhsCon name con args all_zero_size_args
 
     let
 	(closure_info, amodes_w_offsets)
-	  = layOutStaticClosure name getAmodeKind amodes lf_info
+	  = layOutStaticClosure name getAmodeRep amodes lf_info
     in
 	-- HWL: In 0.22 there was a heap check in here that had to be changed.
 	--      CHECK if having no heap check is ok for GrAnSim here!!!
@@ -168,7 +161,7 @@ cgTopRhsCon name con args all_zero_size_args
     ) `thenC`
 
 	-- RETURN
-    returnFC (name, stableAmodeIdInfo name (CLbl closure_label PtrKind) lf_info)
+    returnFC (name, stableAmodeIdInfo name (CLbl closure_label PtrRep) lf_info)
   where
     con_tycon	    = getDataConTyCon con
     lf_info	    = mkConLFInfo con
@@ -207,8 +200,6 @@ regular \tr{MkFoo} info-table and entry code.  (2)~However: the
 will not have set it.  Therefore, the whole point of \tr{x_entry} is
 to set node (and then call the shared \tr{MkFoo} entry code).
 
-
-
 Special Case:
 For top-level Int/Char constants. We get entry-code fragments of the form:
 
@@ -252,62 +243,10 @@ STG syntax:
     }
 \end{verbatim}
 
-This blob used to be in cgTopRhsCon, but I don't see how we can
-jump direct to the named code for a constructor; any external entries
-will be via Node.  Generating all this extra code is a real waste 
-for big static data structures.  So I've nuked it.  SLPJ Sept 94
-
-
-Further discourse on these entry-code fragments (NB this isn't done
-yet [ToDo]): They're really pretty pointless, except for {\em
-exported} top-level constants (the rare case).  Consider:
-\begin{verbatim}
-y = p : ps	-- y is not exported
-f a b = y
-g c = (y, c)
-\end{verbatim}
-Why have a \tr{y_entry} fragment at all?  The code generator should
-``know enough'' about \tr{y} not to need it.  For the first case
-above, with \tr{y} in ``head position,'' it should generate code just
-as for an \tr{StgRhsCon} (possibly because the STG simplification
-actually did the unfolding to make it so).  At the least, it should
-load up \tr{Node} and call \tr{Cons}'s entry code---not some special
-\tr{y_entry} code.
-
-\begin{pseudocode}
-	-- WE NEED AN ENTRY PT, IN CASE SOMEONE JUMPS DIRECT TO name
-	-- FROM OUTSIDE.  NB: this CCodeBlock precedes the
-	-- CStaticClosure for the same reason (fewer forward refs) as
-	-- we did in CgClosure.
-
-	-- we either have ``in-line'' returning code (special case)
-	-- or we set Node and jump to the constructor's entry code
-
-    (if maybeToBool (maybeCharLikeTyCon con_tycon)
-     || maybeToBool (maybeIntLikeTyCon con_tycon)
-     then -- special case
-	getAbsC (-- OLD: No, we don't fiddle cost-centres on
-		 -- entry to data values any more (WDP 94/06)
-		 -- lexCostCentreC "ENTER_CC_D" [top_ccc]
-		 --  `thenC`
-		 cgReturnDataCon con amodes all_zero_size_args emptyUniqSet{-no live vars-})
-     else -- boring case
-    	returnFC (
-	    mkAbstractCs [
-	      -- Node := this_closure
-	      CAssign (CReg node) (CLbl closure_label PtrKind),
-    	      -- InfoPtr := info table for this_closure
-    	      CAssign (CReg infoptr) (CLbl info_label DataPtrKind),
-	      -- Jump to std code for this constructor
-	      CJump (CLbl con_entry_label CodePtrKind)
-	    ])
-    )				    	   `thenFC` \ ret_absC ->
-
-    absC (CCodeBlock entry_label ret_absC) `thenC`
-\end{pseudocode}
-
-=========================== END OF OLD STUFF ==============================
-
+This blob used to be in cgTopRhsCon, but I don't see how we can jump
+direct to the named code for a constructor; any external entries will
+be via Node.  Generating all this extra code is a real waste for big
+static data structures.  So I've nuked it.  SLPJ Sept 94
 
 %************************************************************************
 %*									*
@@ -324,7 +263,7 @@ buildDynCon :: Id		-- Name of the thing to which this constr will
 	    -> DataCon		-- The data constructor
 	    -> [CAddrMode]	-- Its args
 	    -> Bool		-- True <=> all args (if any) are
-				-- of "zero size" (i.e., VoidKind);
+				-- of "zero size" (i.e., VoidRep);
 				-- The reason we don't just look at the
 				-- args is that we may be in a "knot", and
 				-- premature looking at the args will cause
@@ -333,32 +272,33 @@ buildDynCon :: Id		-- Name of the thing to which this constr will
 \end{code}
 
 First we deal with the case of zero-arity constructors.  Now, they
-will probably be unfolded, so we don't expect to see this case
-much, if at all, but it does no harm, and sets the scene for characters.
+will probably be unfolded, so we don't expect to see this case much,
+if at all, but it does no harm, and sets the scene for characters.
 
-In the case of zero-arity constructors, or, more accurately,
-those which have exclusively size-zero (VoidKind) args,
-we generate no code at all.
+In the case of zero-arity constructors, or, more accurately, those
+which have exclusively size-zero (VoidRep) args, we generate no code
+at all.
 
 \begin{code}
 buildDynCon binder cc con args all_zero_size_args@True
   = ASSERT(isDataCon con)
     returnFC (stableAmodeIdInfo binder
-				(CLbl (mkClosureLabel con) PtrKind) 
+				(CLbl (mkClosureLabel con) PtrRep)
     				(mkConLFInfo con))
 \end{code}
 
 Now for @Char@-like closures.  We generate an assignment of the
 address of the closure to a temporary.  It would be possible simply to
-generate no code, and record the addressing mode in the environment, but
-we'd have to be careful if the argument wasn't a constant --- so for simplicity
-we just always asssign to a temporary.
+generate no code, and record the addressing mode in the environment,
+but we'd have to be careful if the argument wasn't a constant --- so
+for simplicity we just always asssign to a temporary.
 
-Last special case: @Int@-like closures.  We only special-case the situation
-in which the argument is a literal in the range @mIN_INTLIKE@..@mAX_INTLILKE@.
-NB: for @Char@-like closures we can work with any old argument, but
-for @Int@-like ones the argument has to be a literal.  Reason: @Char@ like
-closures have an argument type which is guaranteed in range.
+Last special case: @Int@-like closures.  We only special-case the
+situation in which the argument is a literal in the range
+@mIN_INTLIKE@..@mAX_INTLILKE@.  NB: for @Char@-like closures we can
+work with any old argument, but for @Int@-like ones the argument has
+to be a literal.  Reason: @Char@ like closures have an argument type
+which is guaranteed in range.
 
 Because of this, we use can safely return an addressing mode.
 
@@ -378,7 +318,7 @@ buildDynCon binder cc con [arg_amode] all_zero_size_args@False
     (temp_amode, temp_id_info) = newTempAmodeAndIdInfo binder (mkConLFInfo con)
 
     in_range_int_lit (CLit (MachInt val _)) = (val <= mAX_INTLIKE) && (val >= mIN_INTLIKE)
-    in_range_int_lit other_amode	    = False   
+    in_range_int_lit other_amode	    = False
 \end{code}
 
 Now the general case.
@@ -390,7 +330,7 @@ buildDynCon binder cc con args all_zero_size_args@False
     returnFC (heapIdInfo binder hp_off (mkConLFInfo con))
   where
     (closure_info, amodes_w_offsets)
-      = layOutDynClosure binder getAmodeKind args (mkConLFInfo con)
+      = layOutDynClosure binder getAmodeRep args (mkConLFInfo con)
 
     use_cc	-- cost-centre to stick in the object
       = if currentOrSubsumedCosts cc
@@ -423,7 +363,7 @@ bindConArgs con args
       ReturnInRegs rs  -> bindArgsToRegs args rs
       ReturnInHeap     ->
 	  let
-	      (_, args_w_offsets) = layOutDynCon con getIdKind args
+	      (_, args_w_offsets) = layOutDynCon con getIdPrimRep args
 	  in
 	  mapCs bind_arg args_w_offsets
    where
@@ -441,7 +381,7 @@ bindConArgs con args
 Note: it's the responsibility of the @cgReturnDataCon@ caller to be
 sure the @amodes@ passed don't conflict with each other.
 \begin{code}
-cgReturnDataCon :: DataCon -> [CAddrMode] -> Bool -> PlainStgLiveVars -> Code
+cgReturnDataCon :: DataCon -> [CAddrMode] -> Bool -> StgLiveVars -> Code
 
 cgReturnDataCon con amodes all_zero_size_args live_vars
   = ASSERT(isDataCon con)
@@ -452,7 +392,7 @@ cgReturnDataCon con amodes all_zero_size_args live_vars
 
       CaseAlts _ (Just (alts, Just (maybe_deflt_binder, (_,deflt_lbl))))
 	| not (getDataConTag con `is_elem` map fst alts)
-	->	
+	->
 		-- Special case!  We're returning a constructor to the default case
 		-- of an enclosing case.  For example:
 		--
@@ -460,7 +400,7 @@ cgReturnDataCon con amodes all_zero_size_args live_vars
 		--	  D x -> ...
 		--	  y   -> ...<returning here!>...
 		--
-		-- In this case, 
+		-- In this case,
 		--	if the default is a non-bind-default (ie does not use y),
 		--	then we should simply jump to the default join point;
 		--
@@ -469,17 +409,17 @@ cgReturnDataCon con amodes all_zero_size_args live_vars
 		--	**regardless** of the return convention of the constructor C.
 
 		case maybe_deflt_binder of
-		  Just binder -> 
+		  Just binder ->
 			buildDynCon binder useCurrentCostCentre con amodes all_zero_size_args
 								`thenFC` \ idinfo ->
-			idInfoToAmode PtrKind idinfo		`thenFC` \ amode ->
+			idInfoToAmode PtrRep idinfo		`thenFC` \ amode ->
 			performReturn (move_to_reg amode node)  jump_to_join_point live_vars
 
 		  Nothing ->
 			performReturn AbsCNop {- No reg assts -} jump_to_join_point live_vars
 	where
 	  is_elem = isIn "cgReturnDataCon"
-	  jump_to_join_point sequel = absC (CJump (CLbl deflt_lbl CodePtrKind))
+	  jump_to_join_point sequel = absC (CJump (CLbl deflt_lbl CodePtrRep))
 		-- Ignore the sequel: we've already looked at it above
 
       other_sequel ->	-- The usual case
@@ -492,8 +432,8 @@ cgReturnDataCon con amodes all_zero_size_args live_vars
 			-- affects profiling (ToDo?)
 		  buildDynCon con useCurrentCostCentre con amodes all_zero_size_args
 							`thenFC` \ idinfo ->
-		  idInfoToAmode PtrKind idinfo		`thenFC` \ amode ->
-		
+		  idInfoToAmode PtrRep idinfo		`thenFC` \ amode ->
+
 			-- MAKE NODE POINT TO IT
 		  let reg_assts = move_to_reg amode node
 		      info_lbl  = mkInfoTableLabel con
@@ -506,9 +446,9 @@ cgReturnDataCon con amodes all_zero_size_args live_vars
 
 	      ReturnInRegs regs  ->
 	    	  let
-		      reg_assts = mkAbstractCs (zipWith move_to_reg amodes regs)
+		      reg_assts = mkAbstractCs (zipWithEqual move_to_reg amodes regs)
 		      info_lbl  = mkPhantomInfoTableLabel con
-	          in
+		  in
 		  profCtrC SLIT("RET_NEW_IN_REGS") [mkIntCLit (length amodes)] `thenC`
 
 	    	  performReturn reg_assts (mkStaticAlgReturnCode con (Just info_lbl)) live_vars
diff --git a/ghc/compiler/codeGen/CgConTbls.hi b/ghc/compiler/codeGen/CgConTbls.hi
deleted file mode 100644
index 705355b47f..0000000000
--- a/ghc/compiler/codeGen/CgConTbls.hi
+++ /dev/null
@@ -1,23 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface CgConTbls where
-import AbsCSyn(AbstractC, CAddrMode, CStmtMacro, MagicId, RegRelative, ReturnInfo)
-import BasicLit(BasicLit)
-import CLabelInfo(CLabel)
-import CgMonad(CompilationInfo)
-import ClosureInfo(ClosureInfo)
-import CmdLineOpts(GlobalSwitch)
-import CostCentre(CostCentre)
-import FiniteMap(FiniteMap)
-import Maybes(Labda)
-import PreludePS(_PackedString)
-import PrimOps(PrimOp)
-import TCE(TCE(..))
-import TyCon(TyCon)
-import UniType(UniType)
-import UniqFM(UniqFM)
-data AbstractC 
-data CompilationInfo 
-type TCE = UniqFM TyCon
-data UniqFM a 
-genStaticConBits :: CompilationInfo -> [TyCon] -> FiniteMap TyCon [(Bool, [Labda UniType])] -> AbstractC
-
diff --git a/ghc/compiler/codeGen/CgConTbls.lhs b/ghc/compiler/codeGen/CgConTbls.lhs
index 61a75017d3..79dd48e6ea 100644
--- a/ghc/compiler/codeGen/CgConTbls.lhs
+++ b/ghc/compiler/codeGen/CgConTbls.lhs
@@ -19,12 +19,10 @@ import Outputable
 import AbsCSyn
 import CgMonad
 
-import AbsUniType	( getTyConDataCons, kindFromType,
+import Type		( getTyConDataCons, primRepFromType,
     	    	    	  maybeIntLikeTyCon, mkSpecTyCon,
 			  TyVarTemplate, TyCon, Class,
-			  TauType(..), UniType, ThetaType(..)
-			  IF_ATTACK_PRAGMAS(COMMA cmpTyCon COMMA cmpClass)
-			  IF_ATTACK_PRAGMAS(COMMA cmpUniType)
+			  TauType(..), Type, ThetaType(..)
 			)
 import CgHeapery	( heapCheck, allocDynClosure )
 import CgRetConv	( dataReturnConvAlg, ctrlReturnConvAlg,
@@ -34,10 +32,9 @@ import CgRetConv	( dataReturnConvAlg, ctrlReturnConvAlg,
 			)
 import CgTailCall	( performReturn, mkStaticAlgReturnCode )
 import CgUsages		( getHpRelOffset )
-import CLabelInfo	( mkConEntryLabel, mkStaticConEntryLabel, 
-    	    	    	  --UNUSED: mkInfoTableLabel,
-			  mkClosureLabel, --UNUSED: mkConUpdCodePtrUnvecLabel,
-			  mkConUpdCodePtrVecLabel, mkStdUpdCodePtrVecLabel, 
+import CLabel	( mkConEntryLabel, mkStaticConEntryLabel,
+			  mkClosureLabel,
+			  mkConUpdCodePtrVecLabel, mkStdUpdCodePtrVecLabel,
     	    	    	  mkStdUpdVecTblLabel, CLabel
 			)
 import ClosureInfo	( layOutStaticClosure, layOutDynCon,
@@ -45,7 +42,6 @@ import ClosureInfo	( layOutStaticClosure, layOutDynCon,
 			  fitsMinUpdSize, mkConLFInfo, layOutPhantomClosure,
 			  infoTableLabelFromCI, dataConLiveness
 			)
-import CmdLineOpts	( GlobalSwitch(..) )
 import FiniteMap
 import Id		( getDataConTag, getDataConSig, getDataConTyCon,
 			  mkSameSpecCon,
@@ -54,17 +50,16 @@ import Id		( getDataConTag, getDataConSig, getDataConTyCon,
 			)
 import CgCompInfo	( uF_UPDATEE )
 import Maybes		( maybeToBool, Maybe(..) )
-import PrimKind		( getKindSize, retKindSize )
+import PrimRep		( getPrimRepSize, retPrimRepSize )
 import CostCentre
 import UniqSet		-- ( emptyUniqSet, UniqSet(..) )
-import TCE		( rngTCE, TCE(..), UniqFM )
 import Util
 \end{code}
 
 For every constructor we generate the following info tables:
-	A static info table, for static instances of the constructor, 
+	A static info table, for static instances of the constructor,
 
-	For constructors which return in registers (and only them), 
+	For constructors which return in registers (and only them),
 		an "inregs" info table.  This info table is rather emaciated;
 		it only contains update code and tag.
 
@@ -90,7 +85,7 @@ which are int-like, char-like or nullary, when GC occurs,
 the closure tries to get rid of itself.
 
 \item[@con_inregs_info@:]
-Used when returning a new constructor in registers.  
+Used when returning a new constructor in registers.
 Only for return-in-regs constructors.
 Macro: @INREGS_INFO_TABLE@.
 
@@ -112,7 +107,7 @@ closures predeclared.
 \begin{code}
 genStaticConBits :: CompilationInfo 	-- global info about the compilation
 		 -> [TyCon]		-- tycons to generate
-	  	 -> FiniteMap TyCon [(Bool, [Maybe UniType])]
+	  	 -> FiniteMap TyCon [(Bool, [Maybe Type])]
 					-- tycon specialisation info
 		 -> AbstractC		-- output
 
@@ -131,12 +126,12 @@ genStaticConBits comp_info gen_tycons tycon_specs
 
     mkAbstractCs [ gen_for_tycon tc | tc <- gen_tycons ]
       `mkAbsCStmts`
-    mkAbstractCs [ mkAbstractCs [ gen_for_spec_tycon tc spec 
-		                | (imported_spec, spec) <- specs,
-			          -- no code generated if spec is imported
-			          not imported_spec 
-			        ]		     
-	         | (tc, specs) <- fmToList tycon_specs ]
+    mkAbstractCs [ mkAbstractCs [ gen_for_spec_tycon tc spec
+				| (imported_spec, spec) <- specs,
+				  -- no code generated if spec is imported
+				  not imported_spec
+				]
+		 | (tc, specs) <- fmToList tycon_specs ]
   where
     gen_for_tycon :: TyCon -> AbstractC
     gen_for_tycon tycon
@@ -155,12 +150,12 @@ genStaticConBits comp_info gen_tycons tycon_specs
     	    VectoredReturn   _ -> CFlatRetVector tycon_upd_label
     	    	    	    	    	(map (mk_upd_label tycon) data_cons)
     ------------------
-    gen_for_spec_tycon :: TyCon -> [Maybe UniType] -> AbstractC
+    gen_for_spec_tycon :: TyCon -> [Maybe Type] -> AbstractC
 
     gen_for_spec_tycon tycon ty_maybes
       = mkAbstractCs (map (genConInfo comp_info spec_tycon) spec_data_cons)
 	  `mkAbsCStmts`
-        maybe_spec_tycon_vtbl 
+	maybe_spec_tycon_vtbl
       where
 	data_cons      = getTyConDataCons tycon
 
@@ -179,10 +174,10 @@ genStaticConBits comp_info gen_tycons tycon_specs
     ------------------
     mk_upd_label tycon con
       = CLbl
-        (case (dataReturnConvAlg isw_chkr con) of
+	(case (dataReturnConvAlg isw_chkr con) of
 	  ReturnInRegs _ -> mkConUpdCodePtrVecLabel tycon tag
 	  ReturnInHeap   -> mkStdUpdCodePtrVecLabel tycon tag)
-	CodePtrKind
+	CodePtrRep
       where
 	tag = getDataConTag con
 
@@ -216,13 +211,13 @@ genConInfo comp_info@(MkCompInfo _ isw_chkr _) tycon data_con
     -- To allow the debuggers, interpreters, etc to cope with static
     -- data structures (ie those built at compile time), we take care that
     -- info-table contains the information we need.
-    (static_ci,_) = layOutStaticClosure data_con kindFromType arg_tys (mkConLFInfo data_con)
+    (static_ci,_) = layOutStaticClosure data_con primRepFromType arg_tys (mkConLFInfo data_con)
 
     body       = (initC comp_info (
 	    	      profCtrC SLIT("ENT_CON") [CReg node] `thenC`
 		      body_code))
 
-    entry_addr = CLbl entry_label CodePtrKind
+    entry_addr = CLbl entry_label CodePtrRep
     con_descr  = _UNPK_ (getOccurrenceName data_con)
 
     closure_code        = CClosureInfoAndCode closure_info body Nothing
@@ -234,26 +229,25 @@ genConInfo comp_info@(MkCompInfo _ isw_chkr _) tycon data_con
 
     inregs_upd_maybe    = genPhantomUpdInfo comp_info tycon data_con
 
-    stdUpd  	    	= CLbl (mkStdUpdCodePtrVecLabel tycon tag) CodePtrKind
+    stdUpd  	    	= CLbl (mkStdUpdCodePtrVecLabel tycon tag) CodePtrRep
 
     tag	    	    	= getDataConTag data_con
 
     cost_centre = mkCCostCentre dontCareCostCentre -- not worried about static data costs
 
     -- For zero-arity data constructors, or, more accurately,
-    -- 	 those which only have VoidKind args (or none):
+    -- 	 those which only have VoidRep args (or none):
     -- 	We make the closure too (not just info tbl), so that we can share
     --  one copy throughout.
-    closure_maybe = -- OLD: if con_arity /= 0 then
-		    if not (all zero_size arg_tys) then
+    closure_maybe = if not (all zero_size arg_tys) then
 		    	AbsCNop
-	            else
+		    else
 		    	CStaticClosure  closure_label		-- Label for closure
 					static_ci		-- Info table
 					cost_centre
-					[{-No args!  A slight lie for constrs with VoidKind args-}]
+					[{-No args!  A slight lie for constrs with VoidRep args-}]
 
-    zero_size arg_ty = getKindSize (kindFromType arg_ty) == 0
+    zero_size arg_ty = getPrimRepSize (primRepFromType arg_ty) == 0
 
     (_,_,arg_tys,_) = getDataConSig   data_con
     con_arity	    = getDataConArity data_con
@@ -279,25 +273,24 @@ mkConCodeAndInfo isw_chkr con
 
 		performReturn (mkAbstractCs (map move_to_reg regs_w_offsets))
 			      (mkStaticAlgReturnCode con Nothing {- Info-ptr already loaded-})
-			      emptyUniqSet{-no live vars-} 
+			      emptyUniqSet{-no live vars-}
 	in
 	(closure_info, body_code)
-	
+
     ReturnInHeap ->
 	let
 	    (_, _, arg_tys, _) = getDataConSig con
 
 	    (closure_info, arg_things)
-		= layOutDynCon con kindFromType arg_tys
+		= layOutDynCon con primRepFromType arg_tys
 
 	    body_code
-		= -- OLD: We don't set CC when entering data any more (WDP 94/06)
-		  -- lexCostCentreC "ENTER_CC_DCL" [CReg node]		`thenC`
+		= -- NB: We don't set CC when entering data (WDP 94/06)
 		  profCtrC SLIT("RET_OLD_IN_HEAP") [mkIntCLit (length arg_things)] `thenC`
 
 		  performReturn AbsCNop	-- Ptr to thing already in Node
-			        (mkStaticAlgReturnCode con Nothing {- Info-ptr already loaded-})
-				emptyUniqSet{-no live vars-} 
+				(mkStaticAlgReturnCode con Nothing {- Info-ptr already loaded-})
+				emptyUniqSet{-no live vars-}
 	in
 	(closure_info, body_code)
 
@@ -305,7 +298,7 @@ mkConCodeAndInfo isw_chkr con
     move_to_reg :: (MagicId, VirtualHeapOffset {-from Node-}) -> AbstractC
     move_to_reg (reg, offset)
       = CAssign (CReg reg) (CVal (NodeRel offset) (kindFromMagicId reg))
-\end{code}	
+\end{code}
 
 %************************************************************************
 %*									*
@@ -319,50 +312,46 @@ Generate the "phantom" info table and update code, iff the constructor returns i
 
 genPhantomUpdInfo :: CompilationInfo -> TyCon -> Id{-data con-} -> AbstractC
 
-genPhantomUpdInfo comp_info@(MkCompInfo _ isw_chkr _) tycon data_con 
+genPhantomUpdInfo comp_info@(MkCompInfo _ isw_chkr _) tycon data_con
   = case (dataReturnConvAlg isw_chkr data_con) of
 
-      ReturnInHeap -> --OLD: pprTrace "NoPhantom: " (ppr PprDebug data_con) $
-		      AbsCNop	-- No need for a phantom update
+      ReturnInHeap -> AbsCNop	-- No need for a phantom update
 
-      ReturnInRegs regs -> 
-	--OLD: pprTrace "YesPhantom! " (ppr PprDebug data_con) $
-	let 
-            phantom_itbl = CClosureInfoAndCode phantom_ci AbsCNop Nothing
+      ReturnInRegs regs ->
+	let
+	    phantom_itbl = CClosureInfoAndCode phantom_ci AbsCNop Nothing
 				upd_code con_descr
 				(dataConLiveness isw_chkr phantom_ci)
 
-            phantom_ci = layOutPhantomClosure data_con (mkConLFInfo data_con)
-      
-            con_descr = _UNPK_ (getOccurrenceName data_con)
+	    phantom_ci = layOutPhantomClosure data_con (mkConLFInfo data_con)
+
+	    con_descr = _UNPK_ (getOccurrenceName data_con)
 
-            con_arity = getDataConArity data_con
+	    con_arity = getDataConArity data_con
 
-            upd_code = CLabelledCode upd_label (mkAbsCStmts build_closure perform_return)
+	    upd_code = CLabelledCode upd_label (mkAbsCStmts build_closure perform_return)
     	    upd_label = mkConUpdCodePtrVecLabel tycon tag
-            tag = getDataConTag data_con
+	    tag = getDataConTag data_con
 
-            updatee = CVal (SpBRel 0 (-uF_UPDATEE)) PtrKind
+	    updatee = CVal (SpBRel 0 (-uF_UPDATEE)) PtrRep
 
-            perform_return = mkAbstractCs
-              [
-                CMacroStmt POP_STD_UPD_FRAME [],
-                CReturn (CReg RetReg) return_info    
-              ]
+	    perform_return = mkAbstractCs
+	      [
+		CMacroStmt POP_STD_UPD_FRAME [],
+		CReturn (CReg RetReg) return_info
+	      ]
 
-            return_info =
-	      -- OLD: pprTrace "ctrlReturn6:" (ppr PprDebug tycon) (
+	    return_info =
     	      case (ctrlReturnConvAlg tycon) of
 		UnvectoredReturn _ -> DirectReturn
-		VectoredReturn _ -> StaticVectoredReturn (tag - fIRST_TAG)
-	      -- )
+		VectoredReturn   _ -> StaticVectoredReturn (tag - fIRST_TAG)
 
     	    -- Determine cost centre for the updated closures CC (and allocation)
     	    -- CCC for lexical (now your only choice)
     	    use_cc = CReg CurCostCentre -- what to put in the closure
 	    blame_cc = use_cc -- who to blame for allocation
 
-            do_move (reg, virt_offset) =
+	    do_move (reg, virt_offset) =
     	    	CAssign (CVal (NodeRel virt_offset) (kindFromMagicId reg)) (CReg reg)
 
 
@@ -370,8 +359,8 @@ genPhantomUpdInfo comp_info@(MkCompInfo _ isw_chkr _) tycon data_con
        	    overwrite_code
 	      = profCtrC SLIT("UPD_CON_IN_PLACE")
 			 [mkIntCLit (length regs_w_offsets)]	`thenC`
-	    	absC (mkAbstractCs 
-            	  [
+	    	absC (mkAbstractCs
+	    	  [
     	            CAssign (CReg node) updatee,
 
 		    -- Tell the storage mgr that we intend to update in place
@@ -384,12 +373,12 @@ genPhantomUpdInfo comp_info@(MkCompInfo _ isw_chkr _) tycon data_con
 	    	    CInitHdr closure_info (NodeRel zeroOff) use_cc True,
 	    	    mkAbstractCs (map do_move regs_w_offsets),
     	    	    if con_arity /= 0 then
-    	    	        CAssign (CReg infoptr) (CLbl info_label DataPtrKind)
-                    else
+    	    	        CAssign (CReg infoptr) (CLbl info_label DataPtrRep)
+		    else
     	    	        AbsCNop
 	    	  ])
 
-    	    upd_inplace_macro = if closurePtrsSize closure_info == 0 
+    	    upd_inplace_macro = if closurePtrsSize closure_info == 0
     	    	    	    	then UPD_INPLACE_NOPTRS
     	    	    	    	else UPD_INPLACE_PTRS
 
@@ -401,29 +390,29 @@ genPhantomUpdInfo comp_info@(MkCompInfo _ isw_chkr _) tycon data_con
 		    -- Allocate and build closure specifying upd_new_w_regs
 	    	    allocDynClosure closure_info use_cc blame_cc amodes_w_offsets
 						    	`thenFC` \ hp_offset ->
-	    	    getHpRelOffset hp_offset		`thenFC` \ hp_rel -> 
+	    	    getHpRelOffset hp_offset		`thenFC` \ hp_rel ->
 	    	    let
 			amode = CAddr hp_rel
     	    	    in
 		    profCtrC SLIT("UPD_CON_IN_NEW")
 			     [mkIntCLit (length amodes_w_offsets)] `thenC`
-		    absC (mkAbstractCs 
+		    absC (mkAbstractCs
 		      [ CMacroStmt UPD_IND [updatee, amode],
 			CAssign (CReg node) amode,
-			CAssign (CReg infoptr) (CLbl info_label DataPtrKind)
+			CAssign (CReg infoptr) (CLbl info_label DataPtrRep)
 		      ])
 
-            (closure_info, regs_w_offsets) = layOutDynCon data_con kindFromMagicId regs
-            info_label = infoTableLabelFromCI closure_info
-            liveness_mask = mkIntCLit (mkLiveRegsBitMask (node:regs))
+	    (closure_info, regs_w_offsets) = layOutDynCon data_con kindFromMagicId regs
+	    info_label = infoTableLabelFromCI closure_info
+	    liveness_mask = mkIntCLit (mkLiveRegsBitMask (node:regs))
 
-            build_closure =
+	    build_closure =
 	      if fitsMinUpdSize closure_info then
-	        initC comp_info overwrite_code
+		initC comp_info overwrite_code
 	      else
-	        initC comp_info (heapCheck regs False alloc_code)
+		initC comp_info (heapCheck regs False alloc_code)
 
-        in CClosureUpdInfo phantom_itbl
+	in CClosureUpdInfo phantom_itbl
 
 \end{code}
 
diff --git a/ghc/compiler/codeGen/CgExpr.hi b/ghc/compiler/codeGen/CgExpr.hi
deleted file mode 100644
index 1167fd33fa..0000000000
--- a/ghc/compiler/codeGen/CgExpr.hi
+++ /dev/null
@@ -1,20 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface CgExpr where
-import AbsCSyn(AbstractC, CAddrMode)
-import CgBindery(CgIdInfo)
-import CgMonad(CgInfoDownwards, CgState, StubFlag)
-import CostCentre(CostCentre)
-import HeapOffs(HeapOffset)
-import Id(Id)
-import PrimOps(PrimOp)
-import StgSyn(StgAtom, StgBinding, StgCaseAlternatives, StgExpr)
-import UniType(UniType)
-import UniqFM(UniqFM)
-import Unique(Unique)
-data CgState 
-data Id 
-data StgExpr a b 
-cgExpr :: StgExpr Id Id -> CgInfoDownwards -> CgState -> CgState
-cgSccExpr :: StgExpr Id Id -> CgInfoDownwards -> CgState -> CgState
-getPrimOpArgAmodes :: PrimOp -> [StgAtom Id] -> CgInfoDownwards -> CgState -> ([CAddrMode], CgState)
-
diff --git a/ghc/compiler/codeGen/CgExpr.lhs b/ghc/compiler/codeGen/CgExpr.lhs
index a8dbbfe5aa..4713767f5a 100644
--- a/ghc/compiler/codeGen/CgExpr.lhs
+++ b/ghc/compiler/codeGen/CgExpr.lhs
@@ -11,28 +11,23 @@
 #include "HsVersions.h"
 
 module CgExpr (
-	cgExpr, cgSccExpr, getPrimOpArgAmodes,
+	cgExpr, cgSccExpr, getPrimOpArgAmodes
 
 	-- and to make the interface self-sufficient...
-	StgExpr, Id, CgState
     ) where
 
-IMPORT_Trace		-- NB: not just for debugging
-import Outputable	-- ToDo: rm (just for debugging)
-import Pretty		-- ToDo: rm (just for debugging)
-
 import StgSyn
 import CgMonad
 import AbsCSyn
 
-import AbsPrel		( PrimOp(..), PrimOpResultInfo(..), HeapRequirement(..), 
-    	    	    	  primOpHeapReq, getPrimOpResultInfo, PrimKind, 
+import PrelInfo		( PrimOp(..), PrimOpResultInfo(..), HeapRequirement(..),
+    	    	    	  primOpHeapReq, getPrimOpResultInfo, PrimRep,
     	    	    	  primOpCanTriggerGC
 			  IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
 			  IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
 			)
-import AbsUniType	( isPrimType, getTyConDataCons )
-import CLabelInfo	( CLabel, mkPhantomInfoTableLabel, mkInfoTableVecTblLabel )
+import Type		( isPrimType, getTyConDataCons )
+import CLabel	( CLabel, mkPhantomInfoTableLabel, mkInfoTableVecTblLabel )
 import ClosureInfo	( LambdaFormInfo, mkClosureLFInfo )
 import CgBindery	( getAtomAmodes )
 import CgCase		( cgCase, saveVolatileVarsAndRegs )
@@ -42,11 +37,11 @@ import CgHeapery	( allocHeap )
 import CgLetNoEscape	( cgLetNoEscapeClosure )
 import CgRetConv	-- various things...
 import CgTailCall	( cgTailCall, performReturn, mkDynamicAlgReturnCode,
-                          mkPrimReturnCode
-                        )
+			  mkPrimReturnCode
+			)
 import CostCentre	( setToAbleCostCentre, isDupdCC, CostCentre )
 import Maybes		( Maybe(..) )
-import PrimKind		( getKindSize )
+import PrimRep		( getPrimRepSize )
 import UniqSet
 import Util
 \end{code}
@@ -56,7 +51,7 @@ with STG {\em expressions}.  See also @CgClosure@, which deals
 with closures, and @CgCon@, which deals with constructors.
 
 \begin{code}
-cgExpr	:: PlainStgExpr		-- input
+cgExpr	:: StgExpr		-- input
 	-> Code			-- output
 \end{code}
 
@@ -68,7 +63,7 @@ cgExpr	:: PlainStgExpr		-- input
 
 ``Applications'' mean {\em tail calls}, a service provided by module
 @CgTailCall@.  This includes literals, which show up as
-@(STGApp (StgLitAtom 42) [])@.
+@(STGApp (StgLitArg 42) [])@.
 
 \begin{code}
 cgExpr (StgApp fun args live_vars) = cgTailCall fun args live_vars
@@ -81,11 +76,11 @@ cgExpr (StgApp fun args live_vars) = cgTailCall fun args live_vars
 %********************************************************
 
 \begin{code}
-cgExpr (StgConApp con args live_vars)
+cgExpr (StgCon con args live_vars)
   = getAtomAmodes args `thenFC` \ amodes ->
     cgReturnDataCon con amodes (all zero_size args) live_vars
   where
-    zero_size atom = getKindSize (getAtomKind atom) == 0
+    zero_size atom = getPrimRepSize (getArgPrimRep atom) == 0
 \end{code}
 
 %********************************************************
@@ -97,7 +92,7 @@ cgExpr (StgConApp con args live_vars)
 Here is where we insert real live machine instructions.
 
 \begin{code}
-cgExpr x@(StgPrimApp op args live_vars)
+cgExpr x@(StgPrim op args live_vars)
   = getIntSwitchChkrC		`thenFC` \ isw_chkr ->
     getPrimOpArgAmodes op args	`thenFC` \ arg_amodes ->
     let
@@ -112,7 +107,7 @@ cgExpr x@(StgPrimApp op args live_vars)
 	-- Use registers for args, and assign args to the regs
 	-- (Can-trigger-gc primops guarantee to have their args in regs)
 	let
-	    (arg_robust_amodes, liveness_mask, arg_assts) 
+	    (arg_robust_amodes, liveness_mask, arg_assts)
 	      = makePrimOpArgsRobust {-NO:isw_chkr-} op arg_amodes
 
 	    liveness_arg = mkIntCLit liveness_mask
@@ -140,7 +135,7 @@ cgExpr x@(StgPrimApp op args live_vars)
 
 	ReturnsPrim kind ->
 	    performReturn do_before_stack_cleanup
-    	    	    	  (\ sequel -> robustifySequel may_gc sequel	
+    	    	    	  (\ sequel -> robustifySequel may_gc sequel
 							`thenFC` \ (ret_asst, sequel') ->
 			   absC (ret_asst `mkAbsCStmts` do_just_before_jump)
 							`thenC`
@@ -148,14 +143,13 @@ cgExpr x@(StgPrimApp op args live_vars)
 			  live_vars
 
 	ReturnsAlg tycon ->
---OLD:	    evalCostCentreC "SET_RetCC" [CReg CurCostCentre]	`thenC`	
 	    profCtrC SLIT("RET_NEW_IN_REGS") [num_of_fields]	`thenC`
 
 	    performReturn do_before_stack_cleanup
 			  (\ sequel -> robustifySequel may_gc sequel
 						    	`thenFC` \ (ret_asst, sequel') ->
-			   absC (mkAbstractCs [ret_asst, 
-                                               do_just_before_jump, 
+			   absC (mkAbstractCs [ret_asst,
+					       do_just_before_jump,
 					       info_ptr_assign])
 			-- Must load info ptr here, not in do_just_before_stack_cleanup,
 			-- because the info-ptr reg clashes with argument registers
@@ -171,22 +165,19 @@ cgExpr x@(StgPrimApp op args live_vars)
 		info_ptr_assign = CAssign (CReg infoptr) info_lbl
 
 		info_lbl
-		  = -- OLD: pprTrace "ctrlReturn7:" (ppr PprDebug tycon) (
-		    case (ctrlReturnConvAlg tycon) of
-		      VectoredReturn _   -> vec_lbl
+		  = case (ctrlReturnConvAlg tycon) of
+		      VectoredReturn   _ -> vec_lbl
 		      UnvectoredReturn _ -> dir_lbl
-		    -- )
 
-	        vec_lbl  = CTableEntry (CLbl (mkInfoTableVecTblLabel tycon) DataPtrKind) 
-    	    	    	        dyn_tag DataPtrKind
+		vec_lbl  = CTableEntry (CLbl (mkInfoTableVecTblLabel tycon) DataPtrRep)
+    	    	    	        dyn_tag DataPtrRep
 
 		data_con = head (getTyConDataCons tycon)
 
 		(dir_lbl, num_of_fields)
 		  = case (dataReturnConvAlg fake_isw_chkr data_con) of
 		      ReturnInRegs rs
-			-> (CLbl (mkPhantomInfoTableLabel data_con) DataPtrKind,
---OLD:			    pprTrace "CgExpr:prim datacon:" (ppr PprDebug data_con) $
+			-> (CLbl (mkPhantomInfoTableLabel data_con) DataPtrRep,
 			    mkIntCLit (length rs)) -- for ticky-ticky only
 
     	    	      ReturnInHeap
@@ -208,7 +199,7 @@ cgExpr x@(StgPrimApp op args live_vars)
     -- sequel is OnStack.  If that's the case, arrange to pull the
     -- sequel out into RetReg before performing the primOp.
 
-    robustifySequel True sequel@(OnStack _) = 
+    robustifySequel True sequel@(OnStack _) =
 	sequelToAmode sequel			`thenFC` \ amode ->
 	returnFC (CAssign (CReg RetReg) amode, InRetReg)
     robustifySequel _ sequel = returnFC (AbsCNop, sequel)
@@ -254,12 +245,12 @@ cgExpr (StgLet (StgRec pairs) expr)
 cgExpr (StgLetNoEscape live_in_whole_let live_in_rhss bindings body)
   =    	-- Figure out what volatile variables to save
     nukeDeadBindings live_in_whole_let	`thenC`
-    saveVolatileVarsAndRegs live_in_rhss 
+    saveVolatileVarsAndRegs live_in_rhss
     	    `thenFC` \ (save_assts, rhs_eob_info, maybe_cc_slot) ->
 
 	-- ToDo: cost centre???
 
-	-- Save those variables right now!	
+	-- Save those variables right now!
     absC save_assts				`thenC`
 
 	-- Produce code for the rhss
@@ -286,9 +277,7 @@ For evaluation scoping we also need to save the cost centre in an
 nested SCCs.
 
 \begin{code}
-cgExpr scc_expr@(StgSCC ty cc expr)
---OLD:WDP:94/06  = evalPushRCCFrame (isPrimType ty) (cgSccExpr scc_expr)
-  = cgSccExpr scc_expr
+cgExpr scc_expr@(StgSCC ty cc expr) = cgSccExpr scc_expr
 \end{code}
 
 @cgSccExpr@ (also used in \tr{CgClosure}):
@@ -315,13 +304,13 @@ cgSccExpr other
 \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 @PtrKind@.
+So the kind should always be @PtrRep@.
 
 We rely on the support code in @CgCon@ (to do constructors) and
 in @CgClosure@ (to do closures).
 
 \begin{code}
-cgRhs :: Id -> PlainStgRhs -> FCode (Id, CgIdInfo)
+cgRhs :: Id -> StgRhs -> FCode (Id, CgIdInfo)
 	-- the Id is passed along so a binding can be set up
 
 cgRhs name (StgRhsCon maybe_cc con args)
@@ -330,7 +319,7 @@ cgRhs name (StgRhsCon maybe_cc con args)
 				`thenFC` \ idinfo ->
     returnFC (name, idinfo)
   where
-    zero_size atom = getKindSize (getAtomKind atom) == 0
+    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
@@ -340,15 +329,15 @@ cgRhs name (StgRhsClosure cc bi fvs upd_flag args body)
 
 \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	
+  = cgLetNoEscapeRhs live_in_rhss rhs_eob_info maybe_cc_slot binder rhs
     	    	    	    	`thenFC` \ (binder, info) ->
     addBindC binder info
 
 cgLetNoEscapeBindings live_in_rhss rhs_eob_info maybe_cc_slot (StgRec pairs)
   = fixC (\ new_bindings ->
 		addBindsC new_bindings 	`thenC`
-		listFCs [ cgLetNoEscapeRhs full_live_in_rhss rhs_eob_info 
-                          maybe_cc_slot b e | (b,e) <- pairs ]
+		listFCs [ cgLetNoEscapeRhs full_live_in_rhss rhs_eob_info
+			  maybe_cc_slot b e | (b,e) <- pairs ]
     ) `thenFC` \ new_bindings ->
 
     addBindsC new_bindings
@@ -357,12 +346,12 @@ cgLetNoEscapeBindings live_in_rhss rhs_eob_info maybe_cc_slot (StgRec pairs)
     -- delete the bindings for the binder from the environment!
     full_live_in_rhss = live_in_rhss `unionUniqSets` (mkUniqSet [b | (b,r) <- pairs])
 
-cgLetNoEscapeRhs 
-    :: PlainStgLiveVars	-- Live in rhss
-    -> EndOfBlockInfo 
+cgLetNoEscapeRhs
+    :: StgLiveVars	-- Live in rhss
+    -> EndOfBlockInfo
     -> Maybe VirtualSpBOffset
     -> Id
-    -> PlainStgRhs
+    -> StgRhs
     -> FCode (Id, CgIdInfo)
 
 cgLetNoEscapeRhs full_live_in_rhss rhs_eob_info maybe_cc_slot binder
@@ -374,14 +363,14 @@ cgLetNoEscapeRhs full_live_in_rhss rhs_eob_info maybe_cc_slot binder
     --     other     -> cgLetNoEscapeClosure binder cc bi live_in_whole_let live_in_rhss args body
     cgLetNoEscapeClosure binder cc bi full_live_in_rhss rhs_eob_info maybe_cc_slot args body
 
--- For a constructor RHS we want to generate a single chunk of code which 
+-- For a constructor RHS we want to generate a single chunk of code which
 -- can be jumped to from many places, which will return the constructor.
 -- It's easy; just behave as if it was an StgRhsClosure with a ConApp inside!
 cgLetNoEscapeRhs full_live_in_rhss rhs_eob_info maybe_cc_slot binder
     	    	 (StgRhsCon cc con args)
   = cgLetNoEscapeClosure binder cc stgArgOcc{-safe-} full_live_in_rhss rhs_eob_info maybe_cc_slot
 	[] 	--No args; the binder is data structure, not a function
-	(StgConApp con args full_live_in_rhss)
+	(StgCon con args full_live_in_rhss)
 \end{code}
 
 Some PrimOps require a {\em fixed} amount of heap allocation.  Rather
@@ -404,7 +393,7 @@ getPrimOpArgAmodes op args
 	FixedHeapRequired size -> allocHeap size `thenFC` \ amode ->
      	    	    	    	  returnFC (amode : arg_amodes)
 
-	_   	    	       -> returnFC arg_amodes    
+	_   	    	       -> returnFC arg_amodes
 \end{code}
 
 
diff --git a/ghc/compiler/codeGen/CgHeapery.hi b/ghc/compiler/codeGen/CgHeapery.hi
deleted file mode 100644
index 5098bba2d8..0000000000
--- a/ghc/compiler/codeGen/CgHeapery.hi
+++ /dev/null
@@ -1,27 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface CgHeapery where
-import AbsCSyn(AbstractC, CAddrMode, CExprMacro, CStmtMacro, MagicId, RegRelative, ReturnInfo)
-import BasicLit(BasicLit)
-import CLabelInfo(CLabel)
-import CgBindery(CgIdInfo)
-import CgMonad(CgInfoDownwards, CgState, StubFlag)
-import ClosureInfo(ClosureInfo)
-import CostCentre(CostCentre)
-import HeapOffs(HeapOffset)
-import Id(Id)
-import Maybes(Labda)
-import PreludePS(_PackedString)
-import PrimKind(PrimKind)
-import PrimOps(PrimOp)
-import UniqFM(UniqFM)
-import Unique(Unique)
-data AbstractC 
-data CAddrMode 
-data CgState 
-data ClosureInfo 
-data HeapOffset 
-data Id 
-allocDynClosure :: ClosureInfo -> CAddrMode -> CAddrMode -> [(CAddrMode, HeapOffset)] -> CgInfoDownwards -> CgState -> (HeapOffset, CgState)
-allocHeap :: HeapOffset -> CgInfoDownwards -> CgState -> (CAddrMode, CgState)
-heapCheck :: [MagicId] -> Bool -> (CgInfoDownwards -> CgState -> CgState) -> CgInfoDownwards -> CgState -> CgState
-
diff --git a/ghc/compiler/codeGen/CgHeapery.lhs b/ghc/compiler/codeGen/CgHeapery.lhs
index 226ff6b72a..98aed044e4 100644
--- a/ghc/compiler/codeGen/CgHeapery.lhs
+++ b/ghc/compiler/codeGen/CgHeapery.lhs
@@ -11,7 +11,7 @@ module CgHeapery (
 	allocHeap, allocDynClosure,
 
 #ifdef GRAN
-        -- new for GrAnSim    HWL
+	-- new for GrAnSim    HWL
 	heapCheckOnly, fetchAndReschedule,
 #endif  {- GRAN -}
 
@@ -46,8 +46,8 @@ This is std code we replaced by the bits below for GrAnSim. -- HWL
 #ifndef GRAN
 
 heapCheck :: [MagicId] 		-- Live registers
-          -> Bool 		-- Node reqd after GC?
-	  -> Code 
+	  -> Bool 		-- Node reqd after GC?
+	  -> Code
 	  -> Code
 
 heapCheck regs node_reqd code
@@ -91,26 +91,26 @@ is not local) then an automatic context switch is done.
 #ifdef GRAN
 
 heapCheck :: [MagicId]          -- Live registers
-          -> Bool               -- Node reqd after GC?
-          -> Code 
-          -> Code
+	  -> Bool               -- Node reqd after GC?
+	  -> Code
+	  -> Code
 
 heapCheck = heapCheck' False
 
 heapCheckOnly :: [MagicId]          -- Live registers
-                 -> Bool               -- Node reqd after GC?
-                 -> Code 
-                 -> Code
+		 -> Bool               -- Node reqd after GC?
+		 -> Code
+		 -> Code
 
 heapCheckOnly = heapCheck' False
 
--- May be emit context switch and emit heap check macro 
+-- May be emit context switch and emit heap check macro
 
 heapCheck' ::   Bool                    -- context switch here?
-                -> [MagicId]            -- Live registers
-                -> Bool                 -- Node reqd after GC?
-                -> Code 
-                -> Code
+		-> [MagicId]            -- Live registers
+		-> Bool                 -- Node reqd after GC?
+		-> Code
+		-> Code
 
 heapCheck' do_context_switch regs node_reqd code
   = initHeapUsage (\ hHw -> do_heap_chk hHw `thenC` code)
@@ -118,74 +118,74 @@ heapCheck' do_context_switch regs node_reqd code
 
     do_heap_chk :: HeapOffset -> Code
     do_heap_chk words_required
-      =         
-        -- HWL:: absC (CComment "Forced heap check --- HWL")  `thenC`
-        --absC  (if do_context_switch 
-        --         then context_switch_code
-        --         else AbsCNop)                                 `thenC`
-
-        absC (if do_context_switch && not (isZeroOff words_required)
-                then context_switch_code
-                else AbsCNop)                                   `thenC`
-        absC (if isZeroOff(words_required)
-                then  AbsCNop 
-                else  checking_code)  `thenC`
-
-        -- HWL was here:
-        --  For GrAnSim we want heap checks even if no heap is allocated in 
-        --  the basic block to make context switches possible.
-        --  So, the if construct has been replaced by its else branch.
-
-            -- The test is *inside* the absC, to avoid black holes!
-
-        -- Now we have set up the real heap pointer and checked there is
-        -- enough space. It remains only to reflect this in the environment
-        
-        setRealHp words_required
-
-            -- The "word_required" here is a fudge.
-            -- *** IT DEPENDS ON THE DIRECTION ***, and on
-            -- whether the Hp is moved the whole way all
-            -- at once or not.
+      =
+	-- HWL:: absC (CComment "Forced heap check --- HWL")  `thenC`
+	--absC  (if do_context_switch
+	--         then context_switch_code
+	--         else AbsCNop)                                 `thenC`
+
+	absC (if do_context_switch && not (isZeroOff words_required)
+		then context_switch_code
+		else AbsCNop)                                   `thenC`
+	absC (if isZeroOff(words_required)
+		then  AbsCNop
+		else  checking_code)  `thenC`
+
+	-- HWL was here:
+	--  For GrAnSim we want heap checks even if no heap is allocated in
+	--  the basic block to make context switches possible.
+	--  So, the if construct has been replaced by its else branch.
+
+	    -- The test is *inside* the absC, to avoid black holes!
+
+	-- Now we have set up the real heap pointer and checked there is
+	-- enough space. It remains only to reflect this in the environment
+
+	setRealHp words_required
+
+	    -- The "word_required" here is a fudge.
+	    -- *** IT DEPENDS ON THE DIRECTION ***, and on
+	    -- whether the Hp is moved the whole way all
+	    -- at once or not.
       where
-        all_regs = if node_reqd then node:regs else regs
-        liveness_mask = mkLiveRegsBitMask all_regs
+	all_regs = if node_reqd then node:regs else regs
+	liveness_mask = mkLiveRegsBitMask all_regs
 
-        maybe_context_switch = if do_context_switch
-                                then context_switch_code
-                                else AbsCNop
+	maybe_context_switch = if do_context_switch
+				then context_switch_code
+				else AbsCNop
 
-        context_switch_code = CMacroStmt THREAD_CONTEXT_SWITCH [
-                              mkIntCLit liveness_mask,
-                              mkIntCLit (if node_reqd then 1 else 0)]
+	context_switch_code = CMacroStmt THREAD_CONTEXT_SWITCH [
+			      mkIntCLit liveness_mask,
+			      mkIntCLit (if node_reqd then 1 else 0)]
 
-        -- Good old heap check (excluding context switch)
-        checking_code = CMacroStmt HEAP_CHK [
-                        mkIntCLit liveness_mask,
-                        COffset words_required,
-                        mkIntCLit (if node_reqd then 1 else 0)]
+	-- Good old heap check (excluding context switch)
+	checking_code = CMacroStmt HEAP_CHK [
+			mkIntCLit liveness_mask,
+			COffset words_required,
+			mkIntCLit (if node_reqd then 1 else 0)]
 
 -- Emit macro for simulating a fetch and then reschedule
 
 fetchAndReschedule ::   [MagicId]               -- Live registers
-                        -> Bool                 -- Node reqd
-                        -> Code 
+			-> Bool                 -- Node reqd
+			-> Code
 
 fetchAndReschedule regs node_reqd =
       if (node `elem` regs || node_reqd)
 	then fetch_code `thenC` reschedule_code
 	else absC AbsCNop
       where
-        all_regs = if node_reqd then node:regs else regs
-        liveness_mask = mkLiveRegsBitMask all_regs
+	all_regs = if node_reqd then node:regs else regs
+	liveness_mask = mkLiveRegsBitMask all_regs
 
-        reschedule_code = absC  (CMacroStmt GRAN_RESCHEDULE [
-                                 mkIntCLit liveness_mask,
-                                 mkIntCLit (if node_reqd then 1 else 0)])
+	reschedule_code = absC  (CMacroStmt GRAN_RESCHEDULE [
+				 mkIntCLit liveness_mask,
+				 mkIntCLit (if node_reqd then 1 else 0)])
 
-         --HWL: generate GRAN_FETCH macro for GrAnSim 
-         --     currently GRAN_FETCH and GRAN_FETCH_AND_RESCHEDULE are miai
-        fetch_code = absC (CMacroStmt GRAN_FETCH [])
+	 --HWL: generate GRAN_FETCH macro for GrAnSim
+	 --     currently GRAN_FETCH and GRAN_FETCH_AND_RESCHEDULE are miai
+	fetch_code = absC (CMacroStmt GRAN_FETCH [])
 
 #endif  {- GRAN -}
 \end{code}
@@ -219,10 +219,10 @@ allocDynClosure closure_info use_cc blame_cc amodes_with_offsets
     let  info_offset = addOff virtHp (intOff 1)
 
 	-- do_move IS THE ASSIGNMENT FUNCTION
-         do_move (amode, offset_from_start)
+	 do_move (amode, offset_from_start)
 	   = CAssign (CVal (HpRel realHp
 				  (info_offset `addOff` offset_from_start))
-			   (getAmodeKind amode))
+			   (getAmodeRep amode))
 		     amode
     in
 	-- SAY WHAT WE ARE ABOUT TO DO
@@ -240,7 +240,7 @@ allocDynClosure closure_info use_cc blame_cc amodes_with_offsets
 	-- GENERATE CC PROFILING MESSAGES
     costCentresC SLIT("CC_ALLOC") [blame_cc,
 			     COffset closure_size,
-			     CLitLit (_PK_ (closureKind closure_info)) IntKind]
+			     CLitLit (_PK_ (closureKind closure_info)) IntRep]
 					 		`thenC`
 
 	-- BUMP THE VIRTUAL HEAP POINTER
diff --git a/ghc/compiler/codeGen/CgLetNoEscape.hi b/ghc/compiler/codeGen/CgLetNoEscape.hi
deleted file mode 100644
index 0da1a6fb75..0000000000
--- a/ghc/compiler/codeGen/CgLetNoEscape.hi
+++ /dev/null
@@ -1,11 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface CgLetNoEscape where
-import CgBindery(CgIdInfo)
-import CgMonad(CgInfoDownwards, CgState, EndOfBlockInfo)
-import CostCentre(CostCentre)
-import Id(Id)
-import Maybes(Labda)
-import StgSyn(StgBinderInfo, StgExpr)
-import UniqFM(UniqFM)
-cgLetNoEscapeClosure :: Id -> CostCentre -> StgBinderInfo -> UniqFM Id -> EndOfBlockInfo -> Labda Int -> [Id] -> StgExpr Id Id -> CgInfoDownwards -> CgState -> ((Id, CgIdInfo), CgState)
-
diff --git a/ghc/compiler/codeGen/CgLetNoEscape.lhs b/ghc/compiler/codeGen/CgLetNoEscape.lhs
index be887aec5f..5480e93497 100644
--- a/ghc/compiler/codeGen/CgLetNoEscape.lhs
+++ b/ghc/compiler/codeGen/CgLetNoEscape.lhs
@@ -22,9 +22,9 @@ import CgHeapery	( heapCheck )
 import CgRetConv	( assignRegs )
 import CgStackery	( mkVirtStkOffsets )
 import CgUsages		( setRealAndVirtualSps, getVirtSps )
-import CLabelInfo	( mkStdEntryLabel )
+import CLabel	( mkStdEntryLabel )
 import ClosureInfo	( mkLFLetNoEscape )
-import Id		( getIdKind )
+import Id		( getIdPrimRep )
 import Util
 \end{code}
 
@@ -39,8 +39,8 @@ import Util
 Consider:
 \begin{verbatim}
 	let x = fvs \ args -> e
-	in 
-	 	if ... then x else 
+	in
+	 	if ... then x else
 		if ... then x else ...
 \end{verbatim}
 @x@ is used twice (so we probably can't unfold it), but when it is
@@ -93,7 +93,7 @@ non-escaping.
 @x@ can even be recursive!  Eg:
 \begin{verbatim}
 	letrec x = [y] \ [v] -> if v then x True else ...
-	in 
+	in
 		...(x b)...
 \end{verbatim}
 
@@ -130,12 +130,12 @@ cgLetNoEscapeClosure
 	:: Id			-- binder
 	-> CostCentre 	   	-- NB: *** NOT USED *** ToDo (WDP 94/06)
 	-> StgBinderInfo	-- NB: ditto
-	-> PlainStgLiveVars	-- variables live in RHS, including the binders
+	-> StgLiveVars	-- variables live in RHS, including the binders
 				-- themselves in the case of a recursive group
-        -> EndOfBlockInfo       -- where are we going to?
-        -> Maybe VirtualSpBOffset -- Slot for current cost centre
+	-> EndOfBlockInfo       -- where are we going to?
+	-> Maybe VirtualSpBOffset -- Slot for current cost centre
 	-> [Id]			-- args (as in \ args -> body)
-    	-> PlainStgExpr		-- body (as in above)
+    	-> StgExpr		-- body (as in above)
 	-> FCode (Id, CgIdInfo)
 
 -- ToDo: deal with the cost-centre issues
@@ -145,37 +145,37 @@ cgLetNoEscapeClosure binder cc bi full_live_in_rhss rhs_eob_info maybe_cc_slot a
 	arity   = length args
 	lf_info = mkLFLetNoEscape arity full_live_in_rhss{-used???-}
     in
-    forkEvalHelp 
-        rhs_eob_info
+    forkEvalHelp
+	rhs_eob_info
 	(nukeDeadBindings full_live_in_rhss)
-	(forkAbsC (cgLetNoEscapeBody args body)) 
+	(forkAbsC (cgLetNoEscapeBody args body))
 	    	    	    	     	`thenFC` \ (vA, vB, code) ->
     let
 	label = mkStdEntryLabel binder -- arity
     in
-    absC (CCodeBlock label code) `thenC` 
+    absC (CCodeBlock label code) `thenC`
     returnFC (binder, letNoEscapeIdInfo binder vA vB lf_info)
 \end{code}
 
 \begin{code}
 cgLetNoEscapeBody :: [Id]		-- Args
-		  -> PlainStgExpr	-- Body
+		  -> StgExpr	-- Body
 		  -> Code
 
 cgLetNoEscapeBody all_args rhs
   = getVirtSps		`thenFC` \ (vA, vB) ->
     getIntSwitchChkrC	`thenFC` \ isw_chkr ->
     let
-	arg_kinds	= map getIdKind all_args
+	arg_kinds	= map getIdPrimRep all_args
 	(arg_regs, _)	= assignRegs isw_chkr [{-nothing live-}] arg_kinds
     	stk_args	= drop (length arg_regs) all_args
 
     	-- stk_args is the args which are passed on the stack at the fast-entry point
     	-- Using them, we define the stack layout
     	(spA_stk_args, spB_stk_args, stk_bxd_w_offsets, stk_ubxd_w_offsets)
-	  = mkVirtStkOffsets 
+	  = mkVirtStkOffsets
 		vA vB 		-- Initial virtual SpA, SpB
-		getIdKind 
+		getIdPrimRep
 		stk_args
     in
 
diff --git a/ghc/compiler/codeGen/CgMonad.hi b/ghc/compiler/codeGen/CgMonad.hi
deleted file mode 100644
index e6fd6fde77..0000000000
--- a/ghc/compiler/codeGen/CgMonad.hi
+++ /dev/null
@@ -1,108 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface CgMonad where
-import AbsCSyn(AbstractC, CAddrMode, CExprMacro, CStmtMacro, MagicId, RegRelative, ReturnInfo)
-import BasicLit(BasicLit)
-import CLabelInfo(CLabel)
-import CgBindery(CgBindings(..), CgIdInfo, StableLoc, VolatileLoc, heapIdInfo, stableAmodeIdInfo)
-import ClosureInfo(ClosureInfo, LambdaFormInfo)
-import CmdLineOpts(GlobalSwitch)
-import CostCentre(CostCentre, IsCafCC)
-import HeapOffs(HeapOffset, VirtualHeapOffset(..), VirtualSpAOffset(..), VirtualSpBOffset(..))
-import Id(DataCon(..), Id)
-import IdEnv(IdEnv(..))
-import Maybes(Labda)
-import Outputable(NamedThing, Outputable)
-import PreludePS(_PackedString)
-import PrimKind(PrimKind)
-import PrimOps(PrimOp)
-import StgSyn(PlainStgLiveVars(..))
-import UniqFM(UniqFM)
-import UniqSet(UniqSet(..))
-import Unique(Unique)
-infixr 9 `thenC`
-infixr 9 `thenFC`
-type AStackUsage = (Int, [(Int, StubFlag)], Int, Int)
-data AbstractC 
-type BStackUsage = (Int, [Int], Int, Int)
-data CAddrMode 
-data CLabel 
-type CgBindings = UniqFM CgIdInfo
-data CgIdInfo 
-data CgInfoDownwards   = MkCgInfoDown CompilationInfo (UniqFM CgIdInfo) EndOfBlockInfo
-data CgState   = MkCgState AbstractC (UniqFM CgIdInfo) ((Int, [(Int, StubFlag)], Int, Int), (Int, [Int], Int, Int), (HeapOffset, HeapOffset))
-type Code = CgInfoDownwards -> CgState -> CgState
-data CompilationInfo   = MkCompInfo (GlobalSwitch -> Bool) ((Int -> GlobalSwitch) -> Labda Int) _PackedString
-data CostCentre 
-data EndOfBlockInfo   = EndOfBlockInfo Int Int Sequel
-type FCode a = CgInfoDownwards -> CgState -> (a, CgState)
-data GlobalSwitch 
-data HeapOffset 
-type HeapUsage = (HeapOffset, HeapOffset)
-type IntSwitchChecker = (Int -> GlobalSwitch) -> Labda Int
-data LambdaFormInfo 
-data IsCafCC 
-type SemiTaggingStuff = Labda ([(Int, (AbstractC, CLabel))], Labda (Labda Id, (AbstractC, CLabel)))
-data Sequel   = InRetReg | OnStack Int | UpdateCode CAddrMode | CaseAlts CAddrMode (Labda ([(Int, (AbstractC, CLabel))], Labda (Labda Id, (AbstractC, CLabel))))
-data StubFlag 
-type VirtualHeapOffset = HeapOffset
-type VirtualSpAOffset = Int
-type VirtualSpBOffset = Int
-type DataCon = Id
-data Id 
-type IdEnv a = UniqFM a
-data Labda a 
-type PlainStgLiveVars = UniqFM Id
-data UniqFM a 
-type UniqSet a = UniqFM a
-data Unique 
-absC :: AbstractC -> CgInfoDownwards -> CgState -> CgState
-addBindC :: Id -> CgIdInfo -> CgInfoDownwards -> CgState -> CgState
-addBindsC :: [(Id, CgIdInfo)] -> CgInfoDownwards -> CgState -> CgState
-addFreeBSlots :: [Int] -> [Int] -> [Int]
-costCentresC :: _PackedString -> [CAddrMode] -> CgInfoDownwards -> CgState -> CgState
-costCentresFlag :: CgInfoDownwards -> CgState -> (Bool, CgState)
-fixC :: (a -> CgInfoDownwards -> CgState -> (a, CgState)) -> CgInfoDownwards -> CgState -> (a, CgState)
-forkAbsC :: (CgInfoDownwards -> CgState -> CgState) -> CgInfoDownwards -> CgState -> (AbstractC, CgState)
-forkAlts :: [CgInfoDownwards -> CgState -> (a, CgState)] -> [CgInfoDownwards -> CgState -> (a, CgState)] -> (CgInfoDownwards -> CgState -> (b, CgState)) -> CgInfoDownwards -> CgState -> (([a], b), CgState)
-forkClosureBody :: (CgInfoDownwards -> CgState -> CgState) -> CgInfoDownwards -> CgState -> CgState
-forkEval :: EndOfBlockInfo -> (CgInfoDownwards -> CgState -> CgState) -> (CgInfoDownwards -> CgState -> (Sequel, CgState)) -> CgInfoDownwards -> CgState -> (EndOfBlockInfo, CgState)
-forkEvalHelp :: EndOfBlockInfo -> (CgInfoDownwards -> CgState -> CgState) -> (CgInfoDownwards -> CgState -> (a, CgState)) -> CgInfoDownwards -> CgState -> ((Int, Int, a), CgState)
-forkStatics :: (CgInfoDownwards -> CgState -> (a, CgState)) -> CgInfoDownwards -> CgState -> (a, CgState)
-getAbsC :: (CgInfoDownwards -> CgState -> CgState) -> CgInfoDownwards -> CgState -> (AbstractC, CgState)
-getEndOfBlockInfo :: CgInfoDownwards -> CgState -> (EndOfBlockInfo, CgState)
-getIntSwitchChkrC :: CgInfoDownwards -> CgState -> ((Int -> GlobalSwitch) -> Labda Int, CgState)
-getUnstubbedAStackSlots :: Int -> CgInfoDownwards -> CgState -> ([Int], CgState)
-heapIdInfo :: Id -> HeapOffset -> LambdaFormInfo -> CgIdInfo
-initC :: CompilationInfo -> (CgInfoDownwards -> CgState -> CgState) -> AbstractC
-isStringSwitchSetC :: ([Char] -> GlobalSwitch) -> CgInfoDownwards -> CgState -> (Bool, CgState)
-isStubbed :: StubFlag -> Bool
-isSwitchSetC :: GlobalSwitch -> CgInfoDownwards -> CgState -> (Bool, CgState)
-listCs :: [CgInfoDownwards -> CgState -> CgState] -> CgInfoDownwards -> CgState -> CgState
-listFCs :: [CgInfoDownwards -> CgState -> (a, CgState)] -> CgInfoDownwards -> CgState -> ([a], CgState)
-lookupBindC :: Id -> CgInfoDownwards -> CgState -> (CgIdInfo, CgState)
-mapCs :: (a -> CgInfoDownwards -> CgState -> CgState) -> [a] -> CgInfoDownwards -> CgState -> CgState
-mapFCs :: (a -> CgInfoDownwards -> CgState -> (b, CgState)) -> [a] -> CgInfoDownwards -> CgState -> ([b], CgState)
-modifyBindC :: Id -> (CgIdInfo -> CgIdInfo) -> CgInfoDownwards -> CgState -> CgState
-moduleName :: CgInfoDownwards -> CgState -> (_PackedString, CgState)
-noBlackHolingFlag :: CgInfoDownwards -> CgState -> (Bool, CgState)
-nopC :: CgInfoDownwards -> CgState -> CgState
-nukeDeadBindings :: UniqFM Id -> CgInfoDownwards -> CgState -> CgState
-profCtrC :: _PackedString -> [CAddrMode] -> CgInfoDownwards -> CgState -> CgState
-returnFC :: a -> CgInfoDownwards -> CgState -> (a, CgState)
-sequelToAmode :: Sequel -> CgInfoDownwards -> CgState -> (CAddrMode, CgState)
-setEndOfBlockInfo :: EndOfBlockInfo -> (CgInfoDownwards -> CgState -> CgState) -> CgInfoDownwards -> CgState -> CgState
-stableAmodeIdInfo :: Id -> CAddrMode -> LambdaFormInfo -> CgIdInfo
-thenC :: (CgInfoDownwards -> CgState -> CgState) -> (CgInfoDownwards -> CgState -> a) -> CgInfoDownwards -> CgState -> a
-thenFC :: (CgInfoDownwards -> CgState -> (a, CgState)) -> (a -> CgInfoDownwards -> CgState -> b) -> CgInfoDownwards -> CgState -> b
-instance Eq CLabel
-instance Eq GlobalSwitch
-instance Eq Id
-instance Eq Unique
-instance Ord CLabel
-instance Ord GlobalSwitch
-instance Ord Id
-instance Ord Unique
-instance NamedThing Id
-instance Outputable Id
-instance Text Unique
-
diff --git a/ghc/compiler/codeGen/CgMonad.lhs b/ghc/compiler/codeGen/CgMonad.lhs
index 209078743d..65c4217917 100644
--- a/ghc/compiler/codeGen/CgMonad.lhs
+++ b/ghc/compiler/codeGen/CgMonad.lhs
@@ -21,7 +21,6 @@ module CgMonad (
 	SemiTaggingStuff(..),
 
 	addBindC, addBindsC, modifyBindC, lookupBindC,
---UNUSED:	grabBindsC,
 
 	EndOfBlockInfo(..),
 	setEndOfBlockInfo, getEndOfBlockInfo,
@@ -29,7 +28,6 @@ module CgMonad (
 	AStackUsage(..), BStackUsage(..), HeapUsage(..),
 	StubFlag,
 	isStubbed,
---UNUSED:	grabStackSizeC,
 
 	nukeDeadBindings, getUnstubbedAStackSlots,
 
@@ -39,7 +37,7 @@ module CgMonad (
 	isSwitchSetC, isStringSwitchSetC, getIntSwitchChkrC,
 
 	noBlackHolingFlag,
-	profCtrC, --UNUSED: concurrentC,
+	profCtrC,
 
 	costCentresC, costCentresFlag, moduleName,
 
@@ -51,35 +49,26 @@ module CgMonad (
 	CgInfoDownwards(..), CgState(..),	-- non-abstract
 	CgIdInfo, -- abstract
 	CompilationInfo(..), IntSwitchChecker(..),
-	GlobalSwitch, -- abstract
 
-	stableAmodeIdInfo, heapIdInfo,
+	stableAmodeIdInfo, heapIdInfo
 
 	-- and to make the interface self-sufficient...
-	AbstractC, CAddrMode, CLabel, LambdaFormInfo, IdEnv(..),
-	Unique, HeapOffset, CostCentre, IsCafCC,
-	Id, UniqSet(..), UniqFM,
-	VirtualSpAOffset(..), VirtualSpBOffset(..),
-	VirtualHeapOffset(..), DataCon(..), PlainStgLiveVars(..),
-	Maybe
     ) where
 
 import AbsCSyn
-import AbsUniType	( kindFromType, UniType
+import Type		( primRepFromType, Type
 			  IF_ATTACK_PRAGMAS(COMMA cmpUniType)
 			)
 import CgBindery
 import CgUsages         ( getSpBRelOffset )
 import CmdLineOpts	( GlobalSwitch(..) )
-import Id		( getIdUniType, ConTag(..), DataCon(..) )
-import IdEnv		-- ops on CgBindings use these
+import Id		( idType, ConTag(..), DataCon(..) )
 import Maybes		( catMaybes, maybeToBool, Maybe(..) )
 import Pretty		-- debugging only?
-import PrimKind		( getKindSize, retKindSize )
+import PrimRep		( getPrimRepSize, retPrimRepSize )
 import UniqSet		-- ( elementOfUniqSet, UniqSet(..) )
 import CostCentre	-- profiling stuff
-import StgSyn		( PlainStgAtom(..), PlainStgLiveVars(..) )
-import Unique		( UniqueSupply )
+import StgSyn		( StgArg(..), StgLiveVars(..) )
 import Util
 
 infixr 9 `thenC`	-- Right-associative!
@@ -109,14 +98,8 @@ data CgInfoDownwards	-- information only passed *downwards* by the monad
 
 data CompilationInfo
   = MkCompInfo
-	(GlobalSwitch -> Bool)
-			-- use it to look up whatever we like in command-line flags
-	IntSwitchChecker-- similar; for flags that have an Int assoc.
-			-- with them, notably number of regs available.
 	FAST_STRING	-- the module name
 
-type IntSwitchChecker = (Int -> GlobalSwitch) -> Maybe Int
-
 data CgState
   = MkCgState
 	AbstractC	-- code accumulated so far
@@ -135,10 +118,10 @@ data EndOfBlockInfo
 				-- push arguments starting just above this point on
 				-- a tail call.
 
-				-- This is therefore the A-stk ptr as seen 
+				-- This is therefore the A-stk ptr as seen
 				-- by a case alternative.
 
-				-- Args SpA is used when we want to stub any 
+				-- Args SpA is used when we want to stub any
 				-- currently-unstubbed dead A-stack (ptr) slots;
 				-- we want to know what SpA in the continuation is
 				-- so that we don't stub any slots which are off the
@@ -147,7 +130,7 @@ data EndOfBlockInfo
 	VirtualSpBOffset	-- Args SpB: Very similar to Args SpA.
 
 				-- Two main differences:
-				--  1.  If Sequel isn't OnStack, then Args SpB points 
+				--  1.  If Sequel isn't OnStack, then Args SpB points
 				-- 	just below the slot in which the return address
 				--	should be put.  In effect, the Sequel is
 				--	a pending argument.  If it is OnStack, Args SpB
@@ -155,7 +138,7 @@ data EndOfBlockInfo
 				--
 				--  2.  It ain't used for stubbing because there are
 				--	no ptrs on B stk.
-				
+
 	Sequel
 
 
@@ -170,19 +153,16 @@ block.
 
 \begin{code}
 data Sequel
-        = InRetReg              -- The continuation is in RetReg
-
-        | OnStack VirtualSpBOffset
-                                -- Continuation is on the stack, at the
-                                -- specified location
-
+	= InRetReg              -- The continuation is in RetReg
 
---UNUSED:	| RestoreCostCentre
+	| OnStack VirtualSpBOffset
+				-- Continuation is on the stack, at the
+				-- specified location
 
 	| UpdateCode CAddrMode	-- May be standard update code, or might be
 				-- the data-type-specific one.
 
-	| CaseAlts 
+	| CaseAlts
 		CAddrMode   -- Jump to this; if the continuation is for a vectored
 			    -- case this might be the label of a return vector
 			    -- Guaranteed to be a non-volatile addressing mode (I think)
@@ -200,7 +180,7 @@ type SemiTaggingStuff
      )
 
 type JoinDetails
-  = (AbstractC, CLabel)		-- Code to load regs from heap object + profiling macros, 
+  = (AbstractC, CLabel)		-- Code to load regs from heap object + profiling macros,
 				-- and join point label
 -- The abstract C is executed only from a successful
 -- semitagging venture, when a case has looked at a variable, found
@@ -209,7 +189,7 @@ type JoinDetails
 
 
 -- DIRE WARNING.
--- The OnStack case of sequelToAmode delivers an Amode which is only valid 
+-- The OnStack case of sequelToAmode delivers an Amode which is only valid
 -- just before the final control transfer, because it assumes that
 -- SpB is pointing to the top word of the return address.
 -- This seems unclean but there you go.
@@ -218,17 +198,13 @@ sequelToAmode :: Sequel -> FCode CAddrMode
 
 sequelToAmode (OnStack virt_spb_offset)
   = getSpBRelOffset virt_spb_offset `thenFC` \ spb_rel ->
-    returnFC (CVal spb_rel RetKind)
+    returnFC (CVal spb_rel RetRep)
 
 sequelToAmode InRetReg		 = returnFC (CReg RetReg)
---UNUSED:sequelToAmode RestoreCostCentre  = returnFC mkRestoreCostCentreLbl
 --Andy/Simon's patch:
 --WAS: sequelToAmode (UpdateCode amode) = returnFC amode
 sequelToAmode (UpdateCode amode) = returnFC (CReg StdUpdRetVecReg)
 sequelToAmode (CaseAlts amode _) = returnFC amode
-
--- ToDo: move/do something
---UNUSED:mkRestoreCostCentreLbl = panic "mkRestoreCostCentreLbl"
 \end{code}
 
 See the NOTES about the details of stack/heap usage tracking.
@@ -302,7 +278,7 @@ stateIncUsage :: CgState -> CgState -> CgState
 stateIncUsage (MkCgState abs_c bs ((vA,fA,rA,hA1),(vB,fB,rB,hB1),(vH1,rH1)))
 	      (MkCgState _     _  (( _, _, _,hA2),( _, _, _,hB2),(vH2, _)))
      = MkCgState abs_c
-		 bs 
+		 bs
 		 ((vA,fA,rA,hA1 `max` hA2),
 		  (vB,fB,rB,hB1 `max` hB2),
 		  (vH1 `maxOff` vH2, rH1))
@@ -318,11 +294,9 @@ stateIncUsage (MkCgState abs_c bs ((vA,fA,rA,hA1),(vB,fB,rB,hB1),(vH1,rH1)))
 type FCode a = CgInfoDownwards -> CgState -> (a, CgState)
 type Code    = CgInfoDownwards -> CgState -> CgState
 
-#ifdef __GLASGOW_HASKELL__
 {-# INLINE thenC #-}
 {-# INLINE thenFC #-}
 {-# INLINE returnFC #-}
-#endif
 \end{code}
 The Abstract~C is not in the environment so as to improve strictness.
 
@@ -428,8 +402,8 @@ bindings and usage information is otherwise unchanged.
 \begin{code}
 forkClosureBody :: Code -> Code
 
-forkClosureBody code 
-	(MkCgInfoDown cg_info statics _) 
+forkClosureBody code
+	(MkCgInfoDown cg_info statics _)
 	(MkCgState absC_in binds un_usage)
   = MkCgState (AbsCStmts absC_in absC_fork) binds un_usage
   where
@@ -452,7 +426,7 @@ forkAbsC :: Code -> FCode AbstractC
 forkAbsC code info_down (MkCgState absC1 bs usage)
   = (absC2, new_state)
   where
-    MkCgState absC2 _ ((_, _, _,hA2),(_, _, _,hB2), _) = 
+    MkCgState absC2 _ ((_, _, _,hA2),(_, _, _,hB2), _) =
 	code info_down (MkCgState AbsCNop bs usage)
     ((vA, fA, rA, hA1), (vB, fB, rB, hB1), heap_usage) = usage
 
@@ -473,13 +447,13 @@ The "extra branches" arise from handling the default case:
 	  C1 a b -> e1
 	  z     -> e2
 
-Here we in effect expand to 
+Here we in effect expand to
 
-	case f x of 
+	case f x of
 	  C1 a b -> e1
 	  C2 c -> let z = C2 c in JUMP(default)
 	  C3 d e f -> let z = C2 d e f in JUMP(default)
-	  
+
 	  default: e2
 
 The stuff for C2 and C3 are the extra branches.  They are
@@ -527,18 +501,18 @@ forkEval :: EndOfBlockInfo              -- For the body
 	 -> FCode Sequel		-- Semi-tagging info to store
 	 -> FCode EndOfBlockInfo	-- The new end of block info
 
-forkEval body_eob_info env_code body_code 
+forkEval body_eob_info env_code body_code
   = forkEvalHelp body_eob_info env_code body_code `thenFC` \ (vA, vB, sequel) ->
     returnFC (EndOfBlockInfo vA vB sequel)
 
-forkEvalHelp :: EndOfBlockInfo  -- For the body 
+forkEvalHelp :: EndOfBlockInfo  -- For the body
     	     -> Code		-- Code to set environment
 	     -> FCode a		-- The code to do after the eval
 	     -> FCode (Int,	-- SpA
 		       Int,	-- SpB
 		       a)	-- Result of the FCode
 
-forkEvalHelp body_eob_info env_code body_code 
+forkEvalHelp body_eob_info env_code body_code
 	 info_down@(MkCgInfoDown cg_info statics _) state
   = ((vA,vB,value_returned), state `stateIncUsageEval` state_at_end_return)
   where
@@ -555,7 +529,7 @@ forkEvalHelp body_eob_info env_code body_code
 
     state_for_body = MkCgState AbsCNop
 	 		     (nukeVolatileBinds binds)
-			     ((vA,stubbed_fA,vA,vA),	-- Set real and hwms 
+			     ((vA,stubbed_fA,vA,vA),	-- Set real and hwms
 			      (vB,fB,vB,vB),		-- to virtual ones
 			      (initVirtHp, initRealHp))
 
@@ -566,10 +540,10 @@ forkEvalHelp body_eob_info env_code body_code
 stateIncUsageEval :: CgState -> CgState -> CgState
 stateIncUsageEval (MkCgState absC1 bs ((vA,fA,rA,hA1),(vB,fB,rB,hB1),heap_usage))
 		  (MkCgState absC2 _  (( _, _, _,hA2),( _, _, _,hB2),	     _))
-     = MkCgState (absC1 `AbsCStmts` absC2) 
+     = MkCgState (absC1 `AbsCStmts` absC2)
 		 -- The AbsC coming back should consist only of nested declarations,
 		 -- notably of the return vector!
-		 bs 
+		 bs
 		 ((vA,fA,rA,hA1 `max` hA2),
 		  (vB,fB,rB,hB1 `max` hB2),
 		  heap_usage)
@@ -600,21 +574,6 @@ info (whether SCC profiling or profiling-ctrs going) and possibly emit
 nothing.
 
 \begin{code}
-isSwitchSetC :: GlobalSwitch -> FCode Bool
-
-isSwitchSetC switch (MkCgInfoDown (MkCompInfo sw_chkr _ _) _ _) state
-  = (sw_chkr switch, state)
-
-isStringSwitchSetC :: (String -> GlobalSwitch) -> FCode Bool
-
-isStringSwitchSetC switch (MkCgInfoDown (MkCompInfo sw_chkr _ _) _ _) state
-  = (sw_chkr (switch (panic "isStringSwitchSetC")), state)
-
-getIntSwitchChkrC :: FCode IntSwitchChecker
-
-getIntSwitchChkrC (MkCgInfoDown (MkCompInfo _ isw_chkr _) _ _) state
-  = (isw_chkr, state)
-
 costCentresC :: FAST_STRING -> [CAddrMode] -> Code
 
 costCentresC macro args (MkCgInfoDown (MkCompInfo sw_chkr _ _) _ _)
@@ -631,23 +590,11 @@ profCtrC macro args (MkCgInfoDown (MkCompInfo sw_chkr _ _) _ _)
     then state
     else MkCgState (mkAbsCStmts absC (CCallProfCtrMacro macro args)) binds usage
 
-{- Try to avoid adding too many special compilation strategies here.  
-   It's better to modify the header files as necessary for particular targets, 
-   so that we can get away with as few variants of .hc files as possible.
-   'ForConcurrent' is somewhat special anyway, as it changes entry conventions
-   pretty significantly.
--}
-
--- if compiling for concurrency...
-  
-{- UNUSED, as it happens:
-concurrentC :: AbstractC -> Code
-
-concurrentC more_absC (MkCgInfoDown (MkCompInfo sw_chkr _ _) _ _)
-			state@(MkCgState absC binds usage)
-  = if not (sw_chkr ForConcurrent)
-    then state
-    else MkCgState (mkAbsCStmts absC more_absC) binds usage
+{- Try to avoid adding too many special compilation strategies here.
+   It's better to modify the header files as necessary for particular
+   targets, so that we can get away with as few variants of .hc files
+   as possible.  'ForConcurrent' is somewhat special anyway, as it
+   changes entry conventions pretty significantly.
 -}
 \end{code}
 
@@ -732,7 +679,7 @@ modifyBindC name mangle_fn info_down (MkCgState absC binds usage)
 Lookup is expected to find a binding for the @Id@.
 \begin{code}
 lookupBindC :: Id -> FCode CgIdInfo
-lookupBindC name info_down@(MkCgInfoDown _ static_binds _) 
+lookupBindC name info_down@(MkCgInfoDown _ static_binds _)
 		 state@(MkCgState absC local_binds usage)
   = (val, state)
   where
@@ -754,28 +701,6 @@ lookupBindC name info_down@(MkCgInfoDown _ static_binds _)
 			 ])
 \end{code}
 
-For dumping debug information, we also have the ability to grab the
-local bindings environment.
-
-ToDo: Maybe do the pretty-printing here to restrict what people do
-with the environment.
-
-\begin{code}
-{- UNUSED:
-grabBindsC :: FCode CgBindings
-grabBindsC info_down state@(MkCgState absC binds usage)
-  = (binds, state)
--}
-\end{code}
-
-\begin{code}
-{- UNUSED:
-grabStackSizeC :: FCode (Int, Int)
-grabStackSizeC info_down state -- @(MkCgState absC binds ((vA,_,_,_), (vB,_,_,_), _))
-  = panic "grabStackSizeC" -- (vA, vB)
--}
-\end{code}
-
 %************************************************************************
 %*									*
 \subsection[CgStackery-deadslots]{Finding dead stack slots}
@@ -804,7 +729,7 @@ set, so that no stack-stubbing will take place.
 Probably *naughty* to look inside monad...
 
 \begin{code}
-nukeDeadBindings :: PlainStgLiveVars  -- All the *live* variables
+nukeDeadBindings :: StgLiveVars  -- All the *live* variables
 		 -> Code
 nukeDeadBindings
 	live_vars
@@ -819,10 +744,9 @@ nukeDeadBindings
 		 heap_usage)
 
     (dead_a_slots, dead_b_slots, bs')
-      = dead_slots live_vars 
-		   [] [] [] 
+      = dead_slots live_vars
+		   [] [] []
 		   [ (i, b) | b@(MkCgIdInfo i _ _ _) <- rngIdEnv binds ]
-		   --OLD: (getIdEnvMapping binds)
 
     extra_free_a = (sortLt (<)  dead_a_slots) `zip` (repeat NotStubbed)
     extra_free_b = sortLt (<) dead_b_slots
@@ -842,7 +766,7 @@ getUnstubbedAStackSlots tail_spa
 Several boring auxiliary functions to do the dirty work.
 
 \begin{code}
-dead_slots :: PlainStgLiveVars
+dead_slots :: StgLiveVars
 	   -> [(Id,CgIdInfo)] -> [VirtualSpAOffset] -> [VirtualSpBOffset]
 	   -> [(Id,CgIdInfo)]
 	   -> ([VirtualSpAOffset], [VirtualSpBOffset], [(Id,CgIdInfo)])
@@ -878,7 +802,7 @@ dead_slots live_vars fbs das dbs ((v,i):bs)
 	_ -> dead_slots live_vars fbs das dbs bs
   where
     size :: Int
-    size = (getKindSize . kindFromType . getIdUniType) v
+    size = (getPrimRepSize . primRepFromType . idType) v
 
 -- addFreeSlots expects *both* args to be in increasing order
 addFreeASlots :: [(Int,StubFlag)] -> [(Int,StubFlag)] -> [(Int,StubFlag)]
diff --git a/ghc/compiler/codeGen/CgRetConv.hi b/ghc/compiler/codeGen/CgRetConv.hi
deleted file mode 100644
index dd4b59ded3..0000000000
--- a/ghc/compiler/codeGen/CgRetConv.hi
+++ /dev/null
@@ -1,26 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface CgRetConv where
-import AbsCSyn(AbstractC, CAddrMode, MagicId)
-import CLabelInfo(CLabel)
-import CmdLineOpts(GlobalSwitch)
-import Id(Id)
-import Maybes(Labda)
-import PrimKind(PrimKind)
-import PrimOps(PrimOp)
-import TyCon(TyCon)
-data MagicId 
-data CLabel 
-data CtrlReturnConvention   = VectoredReturn Int | UnvectoredReturn Int
-data DataReturnConvention   = ReturnInHeap | ReturnInRegs [MagicId]
-data Id 
-data PrimKind 
-data TyCon 
-assignPrimOpResultRegs :: PrimOp -> [MagicId]
-assignRegs :: ((Int -> GlobalSwitch) -> Labda Int) -> [MagicId] -> [PrimKind] -> ([MagicId], [PrimKind])
-ctrlReturnConvAlg :: TyCon -> CtrlReturnConvention
-dataReturnConvAlg :: ((Int -> GlobalSwitch) -> Labda Int) -> Id -> DataReturnConvention
-dataReturnConvPrim :: PrimKind -> MagicId
-makePrimOpArgsRobust :: PrimOp -> [CAddrMode] -> ([CAddrMode], Int, AbstractC)
-mkLiveRegsBitMask :: [MagicId] -> Int
-noLiveRegsMask :: Int
-
diff --git a/ghc/compiler/codeGen/CgRetConv.lhs b/ghc/compiler/codeGen/CgRetConv.lhs
index 679b7c07df..5881fb1f1e 100644
--- a/ghc/compiler/codeGen/CgRetConv.lhs
+++ b/ghc/compiler/codeGen/CgRetConv.lhs
@@ -21,24 +21,21 @@ module CgRetConv (
 
 	assignPrimOpResultRegs,
 	makePrimOpArgsRobust,
-	assignRegs,
+	assignRegs
 
 	-- and to make the interface self-sufficient...
-	MagicId, PrimKind, Id, CLabel, TyCon
     ) where
 
 import AbsCSyn
 
-import AbsPrel		( PrimOp(..), PrimOpResultInfo(..), primOpCanTriggerGC,
-			  getPrimOpResultInfo, integerDataCon, PrimKind
+import PrelInfo		( PrimOp(..), PrimOpResultInfo(..), primOpCanTriggerGC,
+			  getPrimOpResultInfo, integerDataCon
 			  IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
 			  IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
 			)
-import AbsUniType	( getTyConFamilySize, kindFromType, getTyConDataCons,
+import Type		( getTyConFamilySize, primRepFromType, getTyConDataCons,
 			  TyVarTemplate, TyCon, Class,
-			  TauType(..), ThetaType(..), UniType
-			  IF_ATTACK_PRAGMAS(COMMA cmpTyCon COMMA cmpClass)
-			  IF_ATTACK_PRAGMAS(COMMA cmpUniType)
+			  TauType(..), ThetaType(..), Type
 			)
 import CgCompInfo	-- various things
 import CgMonad		( IntSwitchChecker(..) )
@@ -47,7 +44,7 @@ import Id		( Id, getDataConSig, fIRST_TAG, isDataCon,
 			  DataCon(..), ConTag(..)
 			)
 import Maybes		( catMaybes, Maybe(..) )
-import PrimKind
+import PrimRep
 import Util
 import Pretty
 \end{code}
@@ -70,7 +67,7 @@ data-constructor is returned.
 \begin{code}
 data DataReturnConvention
   = ReturnInHeap
-  | ReturnInRegs	[MagicId]	
+  | ReturnInRegs	[MagicId]
 \end{code}
 The register assignment given by a @ReturnInRegs@ obeys three rules:
 \begin{itemize}
@@ -126,14 +123,10 @@ dataReturnConvAlg isw_chkr data_con
     (reg_assignment, leftover_kinds)
       = assignRegs isw_chkr_to_use
 		   [node, infoptr] -- taken...
-		   (map kindFromType arg_tys)
- 
+		   (map primRepFromType arg_tys)
+
     isw_chkr_to_use = isw_chkr
-{-OLD:
-      = if is_prim_result_ty {-and therefore *ignore* any return-in-regs threshold-}
-	then \ x -> Nothing
-	else isw_chkr
--}
+
     is_prim_result_ty = data_con == integerDataCon -- ***HACK***! (WDP 95/11)
 \end{code}
 
@@ -149,7 +142,7 @@ mkLiveRegsBitMask regs
   = foldl do_reg noLiveRegsMask regs
   where
     do_reg acc (VanillaReg kind reg_no)
-      | isFollowableKind kind
+      | isFollowableRep kind
       = acc + (reg_tbl !! IBOX(reg_no _SUB_ ILIT(1)))
 
     do_reg acc anything_else = acc
@@ -166,10 +159,10 @@ mkLiveRegsBitMask regs
   = foldl (+) noLiveRegsMask (map liveness_bit regs)
   where
     liveness_bit (VanillaReg kind reg_no)
-      | isFollowableKind kind
+      | isFollowableRep kind
       = reg_tbl !! (reg_no - 1)
 
-    liveness_bit anything_else 
+    liveness_bit anything_else
       = noLiveRegsBitMask
 
     reg_tbl
@@ -189,35 +182,29 @@ WARNING! If you add a return convention which can return a pointer,
 make sure you alter CgCase (cgPrimDefault) to generate the right sort
 of heap check!
 \begin{code}
-dataReturnConvPrim :: PrimKind -> MagicId
+dataReturnConvPrim :: PrimRep -> MagicId
 
-#ifndef DPH
-dataReturnConvPrim IntKind	= VanillaReg IntKind  ILIT(1)
-dataReturnConvPrim WordKind	= VanillaReg WordKind ILIT(1)
-dataReturnConvPrim AddrKind	= VanillaReg AddrKind ILIT(1)
-dataReturnConvPrim CharKind	= VanillaReg CharKind ILIT(1)
-dataReturnConvPrim FloatKind	= FloatReg  ILIT(1)
-dataReturnConvPrim DoubleKind	= DoubleReg ILIT(1)
-dataReturnConvPrim VoidKind	= VoidReg
+dataReturnConvPrim IntRep	= VanillaReg IntRep  ILIT(1)
+dataReturnConvPrim WordRep	= VanillaReg WordRep ILIT(1)
+dataReturnConvPrim AddrRep	= VanillaReg AddrRep ILIT(1)
+dataReturnConvPrim CharRep	= VanillaReg CharRep ILIT(1)
+dataReturnConvPrim FloatRep	= FloatReg  ILIT(1)
+dataReturnConvPrim DoubleRep	= DoubleReg ILIT(1)
+dataReturnConvPrim VoidRep	= VoidReg
 
 -- Return a primitive-array pointer in the usual register:
-dataReturnConvPrim ArrayKind     = VanillaReg ArrayKind ILIT(1)
-dataReturnConvPrim ByteArrayKind = VanillaReg ByteArrayKind ILIT(1)
+dataReturnConvPrim ArrayRep     = VanillaReg ArrayRep ILIT(1)
+dataReturnConvPrim ByteArrayRep = VanillaReg ByteArrayRep ILIT(1)
 
-dataReturnConvPrim StablePtrKind = VanillaReg StablePtrKind ILIT(1)
-dataReturnConvPrim MallocPtrKind = VanillaReg MallocPtrKind ILIT(1)
+dataReturnConvPrim StablePtrRep = VanillaReg StablePtrRep ILIT(1)
+dataReturnConvPrim MallocPtrRep = VanillaReg MallocPtrRep ILIT(1)
 
-dataReturnConvPrim PtrKind	= panic "dataReturnConvPrim: PtrKind"
+#ifdef DEBUG
+dataReturnConvPrim PtrRep	= panic "dataReturnConvPrim: PtrRep"
 dataReturnConvPrim _		= panic "dataReturnConvPrim: other"
-
-#else
-dataReturnConvPrim VoidKind	= VoidReg
-dataReturnConvPrim PtrKind	= panic "dataReturnConvPrim: PtrKind"
-dataReturnConvPrim kind         = DataReg kind 2 -- Don't Hog a Modifier reg.
-#endif {- Data Parallel Haskell -}
+#endif
 \end{code}
 
-
 %********************************************************
 %*							*
 \subsection[primop-stuff]{Argument and return conventions for Prim Ops}
@@ -243,7 +230,7 @@ assignPrimOpResultRegs op
 	     -- As R1 is dead, it can hold the tag if necessary
 	     case cons of
 		[_]   -> result_regs
-		other -> (VanillaReg IntKind ILIT(1)) : result_regs
+		other -> (VanillaReg IntRep ILIT(1)) : result_regs
   where
     get_return_regs con
       = case (dataReturnConvAlg fake_isw_chkr con) of
@@ -279,7 +266,7 @@ makePrimOpArgsRobust op arg_amodes
   = ASSERT (primOpCanTriggerGC op)
     let
 	non_robust_amodes = filter (not . amodeCanSurviveGC) arg_amodes
-    	arg_kinds = map getAmodeKind non_robust_amodes
+    	arg_kinds = map getAmodeRep non_robust_amodes
 
 	(arg_regs, extra_args)
 	  = assignRegs fake_isw_chkr [{-nothing live-}] arg_kinds
@@ -289,11 +276,13 @@ makePrimOpArgsRobust op arg_amodes
 			   []    -> arg_regs
 			   other -> error ("Cannot allocate enough registers for primop (try rearranging code or reducing number of arguments?) " ++ ppShow 80 (ppr PprDebug op))
 
-	arg_assts = mkAbstractCs (zipWith assign_to_reg final_arg_regs non_robust_amodes)
+	arg_assts
+	  = mkAbstractCs (zipWithEqual assign_to_reg final_arg_regs non_robust_amodes)
+
 	assign_to_reg reg_id amode = CAssign (CReg reg_id) amode
 
-    	safe_arg regs arg 
-		| amodeCanSurviveGC arg = (regs, arg) 
+    	safe_arg regs arg
+		| amodeCanSurviveGC arg = (regs, arg)
     		| otherwise    		= (tail regs, CReg (head regs))
     	safe_amodes = snd (mapAccumL safe_arg final_arg_regs arg_amodes)
 
@@ -321,32 +310,32 @@ register); we just return immediately with the left-overs specified.
 \begin{code}
 assignRegs  :: IntSwitchChecker
 	    -> [MagicId]	-- Unavailable registers
-	    -> [PrimKind]	-- Arg or result kinds to assign
+	    -> [PrimRep]	-- Arg or result kinds to assign
 	    -> ([MagicId],	-- Register assignment in same order
 				-- for *initial segment of* input list
-		[PrimKind])-- leftover kinds
+		[PrimRep])-- leftover kinds
 
 assignRegs isw_chkr regs_in_use kinds
  = assign_reg kinds [] (mkRegTbl isw_chkr regs_in_use)
  where
 
-    assign_reg	:: [PrimKind]  -- arg kinds being scrutinized
+    assign_reg	:: [PrimRep]  -- arg kinds being scrutinized
 		-> [MagicId]	    -- accum. regs assigned so far (reversed)
 		-> ([Int], [Int], [Int])
 			-- regs still avail: Vanilla, Float, Double
-		-> ([MagicId], [PrimKind])
+		-> ([MagicId], [PrimRep])
 
-    assign_reg (VoidKind:ks) acc supply
+    assign_reg (VoidRep:ks) acc supply
 	= assign_reg ks (VoidReg:acc) supply -- one VoidReg is enough for everybody!
 
-    assign_reg (FloatKind:ks) acc (vanilla_rs, IBOX(f):float_rs, double_rs)
+    assign_reg (FloatRep:ks) acc (vanilla_rs, IBOX(f):float_rs, double_rs)
 	= assign_reg ks (FloatReg f:acc) (vanilla_rs, float_rs, double_rs)
 
-    assign_reg (DoubleKind:ks) acc (vanilla_rs, float_rs, IBOX(d):double_rs)
+    assign_reg (DoubleRep:ks) acc (vanilla_rs, float_rs, IBOX(d):double_rs)
 	= assign_reg ks (DoubleReg d:acc) (vanilla_rs, float_rs, double_rs)
 
     assign_reg (k:ks) acc (IBOX(v):vanilla_rs, float_rs, double_rs)
-	| not (isFloatingKind k)
+	| not (isFloatingRep k)
 	= assign_reg ks (VanillaReg k v:acc) (vanilla_rs, float_rs, double_rs)
 
     -- The catch-all.  It can happen because either
@@ -376,7 +365,7 @@ mkRegTbl :: IntSwitchChecker -> [MagicId] -> ([Int], [Int], [Int])
 mkRegTbl isw_chkr regs_in_use
   = (ok_vanilla, ok_float, ok_double)
   where
-    ok_vanilla = catMaybes (map (select (VanillaReg VoidKind)) (taker vanillaRegNos))
+    ok_vanilla = catMaybes (map (select (VanillaReg VoidRep)) (taker vanillaRegNos))
     ok_float   = catMaybes (map (select FloatReg)	       floatRegNos)
     ok_double  = catMaybes (map (select DoubleReg)	       doubleRegNos)
 
diff --git a/ghc/compiler/codeGen/CgStackery.hi b/ghc/compiler/codeGen/CgStackery.hi
deleted file mode 100644
index e9f79db665..0000000000
--- a/ghc/compiler/codeGen/CgStackery.hi
+++ /dev/null
@@ -1,28 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface CgStackery where
-import AbsCSyn(AbstractC, CAddrMode, CExprMacro, CStmtMacro, MagicId, RegRelative, ReturnInfo)
-import BasicLit(BasicLit)
-import CLabelInfo(CLabel)
-import CgBindery(CgIdInfo)
-import CgMonad(CgInfoDownwards, CgState, StubFlag)
-import ClosureInfo(ClosureInfo)
-import CostCentre(CostCentre)
-import HeapOffs(HeapOffset)
-import Maybes(Labda)
-import PreludePS(_PackedString)
-import PrimKind(PrimKind)
-import PrimOps(PrimOp)
-import UniqFM(UniqFM)
-import Unique(Unique)
-data AbstractC 
-data CAddrMode 
-data CgState 
-data PrimKind 
-adjustRealSps :: Int -> Int -> CgInfoDownwards -> CgState -> CgState
-allocAStack :: CgInfoDownwards -> CgState -> (Int, CgState)
-allocBStack :: Int -> CgInfoDownwards -> CgState -> (Int, CgState)
-allocUpdateFrame :: Int -> CAddrMode -> ((Int, Int, Int) -> CgInfoDownwards -> CgState -> CgState) -> CgInfoDownwards -> CgState -> CgState
-getFinalStackHW :: (Int -> Int -> CgInfoDownwards -> CgState -> CgState) -> CgInfoDownwards -> CgState -> CgState
-mkStkAmodes :: Int -> Int -> [CAddrMode] -> CgInfoDownwards -> CgState -> ((Int, Int, AbstractC), CgState)
-mkVirtStkOffsets :: Int -> Int -> (a -> PrimKind) -> [a] -> (Int, Int, [(a, Int)], [(a, Int)])
-
diff --git a/ghc/compiler/codeGen/CgStackery.lhs b/ghc/compiler/codeGen/CgStackery.lhs
index cb1a4ece2a..3759aa41e4 100644
--- a/ghc/compiler/codeGen/CgStackery.lhs
+++ b/ghc/compiler/codeGen/CgStackery.lhs
@@ -12,10 +12,9 @@ Stack-twiddling operations, which are pretty low-down and grimy.
 module CgStackery (
 	allocAStack, allocBStack, allocUpdateFrame,
 	adjustRealSps, getFinalStackHW,
-	mkVirtStkOffsets, mkStkAmodes,
+	mkVirtStkOffsets, mkStkAmodes
 
 	-- and to make the interface self-sufficient...
-	AbstractC, CAddrMode, CgState, PrimKind
     ) where
 
 import StgSyn
@@ -24,7 +23,7 @@ import AbsCSyn
 
 import CgUsages		( getSpBRelOffset )
 import Maybes		( Maybe(..) )
-import PrimKind		( getKindSize, retKindSize, separateByPtrFollowness )
+import PrimRep		( getPrimRepSize, retPrimRepSize, separateByPtrFollowness )
 import Util
 \end{code}
 
@@ -41,7 +40,7 @@ increase towards the top of stack).
 \begin{code}
 mkVirtStkOffsets :: VirtualSpAOffset 	-- Offset of the last allocated thing
 	  -> VirtualSpBOffset		-- ditto
-	  -> (a -> PrimKind)	-- to be able to grab kinds
+	  -> (a -> PrimRep)	-- to be able to grab kinds
 	  -> [a]			-- things to make offsets for
 	  -> (VirtualSpAOffset,		-- OUTPUTS: Topmost allocated word
 	      VirtualSpBOffset,		-- ditto
@@ -59,7 +58,7 @@ mkVirtStkOffsets init_SpA_offset init_SpB_offset kind_fun things
 	(last_SpA_offset, last_SpB_offset, boxd_w_offsets, ubxd_w_offsets)
   where
     computeOffset offset thing
-      = (offset + (getKindSize . kind_fun) thing, (thing, offset+(1::Int)))
+      = (offset + (getPrimRepSize . kind_fun) thing, (thing, offset+(1::Int)))
 \end{code}
 
 @mkStackAmodes@ is a higher-level version of @mkStackOffsets@.
@@ -75,7 +74,7 @@ mkStkAmodes :: VirtualSpAOffset	    	    -- Tail call positions
 	    -> [CAddrMode]		    -- things to make offsets for
 	    -> FCode (VirtualSpAOffset,	    -- OUTPUTS: Topmost allocated word
 		      VirtualSpBOffset,	    -- ditto
-	              AbstractC)	    -- Assignments to appropriate stk slots
+		      AbstractC)	    -- Assignments to appropriate stk slots
 
 mkStkAmodes tail_spa tail_spb things
 	    info_down (MkCgState absC binds usage)
@@ -84,14 +83,14 @@ mkStkAmodes tail_spa tail_spb things
     result = (last_SpA_offset, last_SpB_offset, mkAbstractCs abs_cs)
 
     (last_SpA_offset, last_SpB_offset, ptrs_w_offsets, non_ptrs_w_offsets)
-    	= mkVirtStkOffsets tail_spa tail_spb getAmodeKind things
+    	= mkVirtStkOffsets tail_spa tail_spb getAmodeRep things
 
     abs_cs
-	= [ CAssign (CVal (SpARel realSpA offset) PtrKind) thing
+	= [ CAssign (CVal (SpARel realSpA offset) PtrRep) thing
 	  | (thing, offset) <- ptrs_w_offsets
 	  ]
 	  ++
-	  [ CAssign (CVal (SpBRel realSpB offset) (getAmodeKind thing)) thing
+	  [ CAssign (CVal (SpBRel realSpB offset) (getAmodeRep thing)) thing
 	  | (thing, offset) <- non_ptrs_w_offsets
 	  ]
 
@@ -178,7 +177,7 @@ This is all a bit disgusting.
 allocUpdateFrame :: Int			-- Size of frame
 		 -> CAddrMode		-- Return address which is to be the
 					-- top word of frame
-		 -> ((VirtualSpAOffset, VirtualSpBOffset, VirtualSpBOffset) -> Code) 	
+		 -> ((VirtualSpAOffset, VirtualSpBOffset, VirtualSpBOffset) -> Code)
 						-- Scope of update
 		 -> Code
 
@@ -249,7 +248,7 @@ adjustRealSpB newRealSpB info_down (MkCgState absC binds
   = MkCgState (mkAbsCStmts absC move_instrB) binds new_usage
     where
     move_instrB = if (newRealSpB == realSpB) then AbsCNop
-		 else (CAssign {-PtrKind-}
+		 else (CAssign {-PtrRep-}
 			    (CReg SpB)
 			    (CAddr (SpBRel realSpB newRealSpB)))
     new_usage = (a_usage,
diff --git a/ghc/compiler/codeGen/CgTailCall.hi b/ghc/compiler/codeGen/CgTailCall.hi
deleted file mode 100644
index 9cd0eecabc..0000000000
--- a/ghc/compiler/codeGen/CgTailCall.hi
+++ /dev/null
@@ -1,33 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface CgTailCall where
-import AbsCSyn(AbstractC, CAddrMode, CExprMacro, MagicId, RegRelative)
-import BasicLit(BasicLit)
-import CLabelInfo(CLabel)
-import CgBindery(CgIdInfo)
-import CgMonad(CgInfoDownwards, CgState, CompilationInfo, EndOfBlockInfo, Sequel, StubFlag)
-import ClosureInfo(LambdaFormInfo)
-import CostCentre(CostCentre)
-import HeapOffs(HeapOffset)
-import Id(Id)
-import Maybes(Labda)
-import PreludePS(_PackedString)
-import PrimKind(PrimKind)
-import StgSyn(StgAtom)
-import TyCon(TyCon)
-import UniqFM(UniqFM)
-import Unique(Unique)
-data CAddrMode 
-data CgInfoDownwards 
-data CgState 
-data HeapOffset 
-data Id 
-data Labda a 
-data StgAtom a 
-data TyCon 
-cgTailCall :: StgAtom Id -> [StgAtom Id] -> UniqFM Id -> CgInfoDownwards -> CgState -> CgState
-mkDynamicAlgReturnCode :: TyCon -> CAddrMode -> Sequel -> CgInfoDownwards -> CgState -> CgState
-mkPrimReturnCode :: Sequel -> CgInfoDownwards -> CgState -> CgState
-mkStaticAlgReturnCode :: Id -> Labda CLabel -> Sequel -> CgInfoDownwards -> CgState -> CgState
-performReturn :: AbstractC -> (Sequel -> CgInfoDownwards -> CgState -> CgState) -> UniqFM Id -> CgInfoDownwards -> CgState -> CgState
-tailCallBusiness :: Id -> CAddrMode -> LambdaFormInfo -> [CAddrMode] -> UniqFM Id -> AbstractC -> CgInfoDownwards -> CgState -> CgState
-
diff --git a/ghc/compiler/codeGen/CgTailCall.lhs b/ghc/compiler/codeGen/CgTailCall.lhs
index c2ece1ee2c..a22ca46a2a 100644
--- a/ghc/compiler/codeGen/CgTailCall.lhs
+++ b/ghc/compiler/codeGen/CgTailCall.lhs
@@ -15,12 +15,10 @@ module CgTailCall (
 	performReturn,
 	mkStaticAlgReturnCode, mkDynamicAlgReturnCode,
 	mkPrimReturnCode,
-	
-	tailCallBusiness,
+
+	tailCallBusiness
 
 	-- and to make the interface self-sufficient...
-	StgAtom, Id, CgState, CAddrMode, TyCon,
-	CgInfoDownwards, HeapOffset, Maybe
     ) where
 
 IMPORT_Trace
@@ -31,7 +29,7 @@ import StgSyn
 import CgMonad
 import AbsCSyn
 
-import AbsUniType	( isPrimType, UniType )
+import Type		( isPrimType, Type )
 import CgBindery	( getAtomAmodes, getCAddrMode, getCAddrModeAndInfo )
 import CgCompInfo	( oTHER_TAG, iND_TAG )
 import CgRetConv	( dataReturnConvPrim, ctrlReturnConvAlg, dataReturnConvAlg,
@@ -40,15 +38,15 @@ import CgRetConv	( dataReturnConvPrim, ctrlReturnConvAlg, dataReturnConvAlg,
 			)
 import CgStackery	( adjustRealSps, mkStkAmodes )
 import CgUsages		( getSpARelOffset, getSpBRelOffset )
-import CLabelInfo	( CLabel, mkStdUpdCodePtrVecLabel, mkConUpdCodePtrVecLabel )
+import CLabel	( CLabel, mkStdUpdCodePtrVecLabel, mkConUpdCodePtrVecLabel )
 import ClosureInfo	( nodeMustPointToIt, getEntryConvention, EntryConvention(..) )
 import CmdLineOpts	( GlobalSwitch(..) )
 import Id		( getDataConTyCon, getDataConTag,
-			  getIdUniType, getIdKind, fIRST_TAG, Id,
+			  idType, getIdPrimRep, fIRST_TAG, Id,
 			  ConTag(..)
 			)
 import Maybes		( assocMaybe, maybeToBool, Maybe(..) )
-import PrimKind		( retKindSize )
+import PrimRep		( retPrimRepSize )
 import Util
 \end{code}
 
@@ -59,7 +57,7 @@ import Util
 %************************************************************************
 
 \begin{code}
-cgTailCall :: PlainStgAtom -> [PlainStgAtom] -> PlainStgLiveVars -> Code
+cgTailCall :: StgArg -> [StgArg] -> StgLiveVars -> Code
 \end{code}
 
 Here's the code we generate for a tail call.  (NB there may be no
@@ -87,7 +85,7 @@ themselves in an appropriate register and returning to the address on
 top of the B stack.
 
 \begin{code}
-cgTailCall (StgLitAtom lit) [] live_vars
+cgTailCall (StgLitArg lit) [] live_vars
   = performPrimReturn (CLit lit) live_vars
 \end{code}
 
@@ -96,15 +94,15 @@ mode for the local instead of (CLit lit) in the assignment.
 
 Case for unboxed @Ids@ first:
 \begin{code}
-cgTailCall atom@(StgVarAtom fun) [] live_vars
-  | isPrimType (getIdUniType fun)
+cgTailCall atom@(StgVarArg fun) [] live_vars
+  | isPrimType (idType fun)
   = getCAddrMode fun `thenFC` \ amode ->
     performPrimReturn amode live_vars
 \end{code}
 
 The general case (@fun@ is boxed):
 \begin{code}
-cgTailCall (StgVarAtom fun) args live_vars = performTailCall fun args live_vars
+cgTailCall (StgVarArg fun) args live_vars = performTailCall fun args live_vars
 \end{code}
 
 %************************************************************************
@@ -134,26 +132,25 @@ KCAH-RDA
 
 \begin{code}
 performPrimReturn :: CAddrMode	-- The thing to return
-		  -> PlainStgLiveVars
+		  -> StgLiveVars
 		  -> Code
 
 performPrimReturn amode live_vars
   = let
-	kind = getAmodeKind amode
+	kind = getAmodeRep amode
 	ret_reg = dataReturnConvPrim kind
 
 	assign_possibly = case kind of
-	  VoidKind -> AbsCNop
+	  VoidRep -> AbsCNop
 	  kind -> (CAssign (CReg ret_reg) amode)
     in
     performReturn assign_possibly mkPrimReturnCode live_vars
 
 mkPrimReturnCode :: Sequel -> Code
---UNUSED:mkPrimReturnCode RestoreCostCentre  = panic "mkPrimReturnCode: RCC"
-mkPrimReturnCode (UpdateCode _)	    = panic "mkPrimReturnCode: Upd"
-mkPrimReturnCode sequel		    = sequelToAmode sequel	`thenFC` \ dest_amode ->
-				      absC (CReturn dest_amode DirectReturn)
-				      -- Direct, no vectoring
+mkPrimReturnCode (UpdateCode _)	= panic "mkPrimReturnCode: Upd"
+mkPrimReturnCode sequel		= sequelToAmode sequel	`thenFC` \ dest_amode ->
+				  absC (CReturn dest_amode DirectReturn)
+				  -- Direct, no vectoring
 
 -- All constructor arguments in registers; Node and InfoPtr are set.
 -- All that remains is
@@ -195,7 +192,7 @@ mkStaticAlgReturnCode con maybe_info_lbl sequel
 				-- Set the info pointer, and jump
 			set_info_ptr		`thenC`
 			getIntSwitchChkrC	`thenFC` \ isw_chkr ->
-    			absC (CJump (CLbl (update_label isw_chkr) CodePtrKind))
+    			absC (CJump (CLbl (update_label isw_chkr) CodePtrRep))
 
 	CaseAlts _ (Just (alts, _)) ->	-- Ho! We know the constructor so
 					-- we can go right to the alternative
@@ -206,7 +203,7 @@ mkStaticAlgReturnCode con maybe_info_lbl sequel
 			-- is going to handle.
 
 			case assocMaybe alts tag of
-			   Just (alt_absC, join_lbl) -> absC (CJump (CLbl join_lbl CodePtrKind))
+			   Just (alt_absC, join_lbl) -> absC (CJump (CLbl join_lbl CodePtrRep))
 			   Nothing		     -> panic "mkStaticAlgReturnCode: default"
 				-- The Nothing case should never happen; it's the subject
 				-- of a wad of special-case code in cgReturnCon
@@ -223,7 +220,7 @@ mkStaticAlgReturnCode con maybe_info_lbl sequel
     tycon	      = getDataConTyCon con
     return_convention = ctrlReturnConvAlg tycon
     zero_indexed_tag  = tag - fIRST_TAG	      -- Adjust tag to be zero-indexed
-					      -- cf AbsCFuns.mkAlgAltsCSwitch
+					      -- cf AbsCUtils.mkAlgAltsCSwitch
 
     update_label isw_chkr
       = case (dataReturnConvAlg isw_chkr con) of
@@ -236,7 +233,7 @@ mkStaticAlgReturnCode con maybe_info_lbl sequel
 
     set_info_ptr = case maybe_info_lbl of
 			Nothing	      -> nopC
-			Just info_lbl -> absC (CAssign (CReg infoptr) (CLbl info_lbl DataPtrKind))
+			Just info_lbl -> absC (CAssign (CReg infoptr) (CLbl info_lbl DataPtrRep))
 
 
 mkDynamicAlgReturnCode :: TyCon -> CAddrMode -> Sequel -> Code
@@ -246,7 +243,7 @@ mkDynamicAlgReturnCode tycon dyn_tag sequel
 	VectoredReturn sz ->
 
 		profCtrC SLIT("VEC_RETURN") [mkIntCLit sz] `thenC`
-		sequelToAmode sequel		`thenFC` \ ret_addr ->	
+		sequelToAmode sequel		`thenFC` \ ret_addr ->
 		absC (CReturn ret_addr (DynamicVectoredReturn dyn_tag))
 
 	UnvectoredReturn no_of_constrs ->
@@ -272,14 +269,14 @@ performReturn :: AbstractC	    -- Simultaneous assignments to perform
 	      -> (Sequel -> Code)   -- The code to execute to actually do
 				    -- the return, given an addressing mode
 				    -- for the return address
-	      -> PlainStgLiveVars
+	      -> StgLiveVars
 	      -> Code
 
 performReturn sim_assts finish_code live_vars
   = getEndOfBlockInfo	`thenFC` \ (EndOfBlockInfo args_spa args_spb sequel) ->
 
 	-- Do the simultaneous assignments,
-    doSimAssts args_spa live_vars {-UNUSED:live_regs-} sim_assts	`thenC`
+    doSimAssts args_spa live_vars sim_assts	`thenC`
 
 	-- Adjust stack pointers
     adjustRealSps args_spa args_spb	`thenC`
@@ -287,16 +284,12 @@ performReturn sim_assts finish_code live_vars
 	-- Do the return
     finish_code sequel		-- "sequel" is `robust' in that it doesn't
 				-- depend on stk-ptr values
--- where
---UNUSED:    live_regs = getDestinationRegs sim_assts
-	  -- ToDo: this is a *really* boring way to compute the
-	  -- live-reg set!
 \end{code}
 
 \begin{code}
 performTailCall :: Id			-- Function
-		-> [PlainStgAtom]	-- Args
-		-> PlainStgLiveVars
+		-> [StgArg]	-- Args
+		-> StgLiveVars
 		-> Code
 
 performTailCall fun args live_vars
@@ -313,7 +306,7 @@ performTailCall fun args live_vars
 tailCallBusiness :: Id -> CAddrMode	-- Function and its amode
 		 -> LambdaFormInfo	-- Info about the function
 		 -> [CAddrMode]		-- Arguments
-		 -> PlainStgLiveVars	-- Live in continuation
+		 -> StgLiveVars	-- Live in continuation
 
 		 -> AbstractC		-- Pending simultaneous assignments
 					-- *** GUARANTEED to contain only stack assignments.
@@ -327,7 +320,7 @@ tailCallBusiness fun fun_amode lf_info arg_amodes live_vars pending_assts
 
     nodeMustPointToIt lf_info			`thenFC` \ node_points ->
     getEntryConvention fun lf_info
-	(map getAmodeKind arg_amodes)		`thenFC` \ entry_conv ->
+	(map getAmodeRep arg_amodes)		`thenFC` \ entry_conv ->
 
     getEndOfBlockInfo	`thenFC` \ (EndOfBlockInfo args_spa args_spb sequel) ->
 
@@ -346,33 +339,27 @@ tailCallBusiness fun fun_amode lf_info arg_amodes live_vars pending_assts
 			CCallProfCtrMacro SLIT("ENT_VIA_NODE") [],
 			CAssign (CReg infoptr)
 
-				(CMacroExpr DataPtrKind INFO_PTR [CReg node]),
-			CJump (CMacroExpr CodePtrKind ENTRY_CODE [CReg infoptr])
+				(CMacroExpr DataPtrRep INFO_PTR [CReg node]),
+			CJump (CMacroExpr CodePtrRep ENTRY_CODE [CReg infoptr])
 		     ])
-	      StdEntry lbl Nothing	  -> ([], CJump (CLbl lbl CodePtrKind))
-	      StdEntry lbl (Just itbl)	  -> ([], CAssign (CReg infoptr) (CLbl itbl DataPtrKind)
+	      StdEntry lbl Nothing	  -> ([], CJump (CLbl lbl CodePtrRep))
+	      StdEntry lbl (Just itbl)	  -> ([], CAssign (CReg infoptr) (CLbl itbl DataPtrRep)
 						     `mkAbsCStmts`
-						  CJump (CLbl lbl CodePtrKind))
+						  CJump (CLbl lbl CodePtrRep))
 	      DirectEntry lbl arity regs  ->
 		(regs,	 (if do_arity_chks
 			  then CMacroStmt SET_ARITY [mkIntCLit arity]
 			  else AbsCNop)
-			 `mkAbsCStmts` CJump (CLbl lbl CodePtrKind))
+			 `mkAbsCStmts` CJump (CLbl lbl CodePtrRep))
 
 	no_of_args = length arg_amodes
 
-{- UNUSED:	live_regs = if node_points then
-			node : arg_regs
-		    else
-			arg_regs
--}
 	(reg_arg_assts, stk_arg_amodes)
-	    = (mkAbstractCs (zipWith assign_to_reg arg_regs arg_amodes),
+	    = (mkAbstractCs (zipWithEqual assign_to_reg arg_regs arg_amodes),
 			drop (length arg_regs) arg_amodes) -- No regs, or
 							   -- args beyond arity
 
 	assign_to_reg reg_id amode = CAssign (CReg reg_id) amode
-
     in
     case fun_amode of
       CJoinPoint join_spa join_spb ->  -- Ha!  A let-no-escape thingy
@@ -388,7 +375,7 @@ tailCallBusiness fun fun_amode lf_info arg_amodes live_vars pending_assts
 		      `thenFC` \ (final_spa, final_spb, stk_arg_assts) ->
 
 		-- Do the simultaneous assignments,
-	  doSimAssts join_spa live_vars {-UNUSED: live_regs-}
+	  doSimAssts join_spa live_vars
 		(mkAbstractCs [pending_assts, reg_arg_assts, stk_arg_assts])
 			`thenC`
 
@@ -402,7 +389,7 @@ tailCallBusiness fun fun_amode lf_info arg_amodes live_vars pending_assts
 
 		-- Make instruction to save return address
 	    loadRetAddrIntoRetReg sequel	`thenFC` \ ret_asst ->
-		
+
 	    mkStkAmodes args_spa args_spb stk_arg_amodes
 						`thenFC`
 			    \ (final_spa, final_spb, stk_arg_assts) ->
@@ -411,7 +398,7 @@ tailCallBusiness fun fun_amode lf_info arg_amodes live_vars pending_assts
 		-- on top, is recorded in final_spb.
 
 		-- Do the simultaneous assignments,
-	    doSimAssts args_spa live_vars {-UNUSED: live_regs-}
+	    doSimAssts args_spa live_vars
 		(mkAbstractCs [pending_assts, node_asst, ret_asst,
 			       reg_arg_assts, stk_arg_assts])
 						`thenC`
@@ -449,7 +436,7 @@ tailCallBusiness fun fun_amode lf_info arg_amodes live_vars pending_assts
 		let
 		    join_details_to_code (load_regs_and_profiling_code, join_lbl)
 			= load_regs_and_profiling_code		`mkAbsCStmts`
-			  CJump (CLbl join_lbl CodePtrKind)
+			  CJump (CLbl join_lbl CodePtrRep)
 
 		    semi_tagged_alts = [ (mkMachInt (toInteger (tag - fIRST_TAG)),
 					  join_details_to_code join_details)
@@ -460,24 +447,24 @@ tailCallBusiness fun fun_amode lf_info arg_amodes live_vars pending_assts
 		      -- Enter Node (we know infoptr will have the info ptr in it)!
 		      = mkAbstractCs [
 			CCallProfCtrMacro SLIT("RET_SEMI_FAILED")
-					[CMacroExpr IntKind INFO_TAG [CReg infoptr]],
-			CJump (CMacroExpr CodePtrKind ENTRY_CODE [CReg infoptr]) ]
+					[CMacroExpr IntRep INFO_TAG [CReg infoptr]],
+			CJump (CMacroExpr CodePtrRep ENTRY_CODE [CReg infoptr]) ]
 		in
 			-- Final switch
 		absC (mkAbstractCs [
 			    CAssign (CReg infoptr)
-				    (CVal (NodeRel zeroOff) DataPtrKind),
+				    (CVal (NodeRel zeroOff) DataPtrRep),
 
 			    case maybe_deflt_join_details of
 				Nothing ->
-				    CSwitch (CMacroExpr IntKind INFO_TAG [CReg infoptr])
+				    CSwitch (CMacroExpr IntRep INFO_TAG [CReg infoptr])
 					(semi_tagged_alts)
 					(enter_jump)
 				Just (_, details) ->
-				    CSwitch (CMacroExpr IntKind EVAL_TAG [CReg infoptr])
+				    CSwitch (CMacroExpr IntRep EVAL_TAG [CReg infoptr])
 				     [(mkMachInt 0, enter_jump)]
 				     (CSwitch
-					 (CMacroExpr IntKind INFO_TAG [CReg infoptr])
+					 (CMacroExpr IntRep INFO_TAG [CReg infoptr])
 					 (semi_tagged_alts)
 					 (join_details_to_code details))
 		])
@@ -511,12 +498,11 @@ They are separate because we sometimes do some jiggery-pokery in between.
 
 \begin{code}
 doSimAssts :: VirtualSpAOffset	-- tail_spa: SpA as seen by continuation
-	   -> PlainStgLiveVars	-- Live in continuation
---UNUSED:  -> [MagicId]		-- Live regs (ptrs and non-ptrs)
+	   -> StgLiveVars	-- Live in continuation
 	   -> AbstractC
 	   -> Code
 
-doSimAssts tail_spa live_vars {-UNUSED: live_regs-} sim_assts
+doSimAssts tail_spa live_vars sim_assts
   =	-- Do the simultaneous assignments
     absC (CSimultaneous sim_assts)	`thenC`
 
@@ -540,6 +526,6 @@ doSimAssts tail_spa live_vars {-UNUSED: live_regs-} sim_assts
   where
     stub_A_slot :: VirtualSpAOffset -> Code
     stub_A_slot offset = getSpARelOffset offset		`thenFC` \ spa_rel ->
-			 absC (CAssign	(CVal spa_rel PtrKind)
+			 absC (CAssign	(CVal spa_rel PtrRep)
 					(CReg StkStubReg))
 \end{code}
diff --git a/ghc/compiler/codeGen/CgUpdate.hi b/ghc/compiler/codeGen/CgUpdate.hi
deleted file mode 100644
index 6762d3ef89..0000000000
--- a/ghc/compiler/codeGen/CgUpdate.hi
+++ /dev/null
@@ -1,6 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface CgUpdate where
-import AbsCSyn(CAddrMode)
-import CgMonad(CgInfoDownwards, CgState)
-pushUpdateFrame :: CAddrMode -> CAddrMode -> (CgInfoDownwards -> CgState -> CgState) -> CgInfoDownwards -> CgState -> CgState
-
diff --git a/ghc/compiler/codeGen/CgUpdate.lhs b/ghc/compiler/codeGen/CgUpdate.lhs
index 40daf3714c..92ceaa474c 100644
--- a/ghc/compiler/codeGen/CgUpdate.lhs
+++ b/ghc/compiler/codeGen/CgUpdate.lhs
@@ -6,9 +6,7 @@
 \begin{code}
 #include "HsVersions.h"
 
-module CgUpdate (
-	pushUpdateFrame -- OLD: , evalPushRCCFrame
-    ) where
+module CgUpdate ( pushUpdateFrame ) where
 
 import StgSyn
 import CgMonad
@@ -45,7 +43,7 @@ pushUpdateFrame :: CAddrMode -> CAddrMode -> Code -> Code
 pushUpdateFrame updatee vector code
   = isSwitchSetC SccProfilingOn		`thenFC` \ profiling_on ->
     let
-	-- frame_size *includes* the return address 
+	-- frame_size *includes* the return address
 	frame_size = if profiling_on
 		     then sCC_STD_UF_SIZE
 		     else sTD_UF_SIZE
@@ -72,7 +70,7 @@ int_CLit0 = mkIntCLit 0 -- out here to avoid pushUpdateFrame CAF (sigh)
     pushOnBStack (CReg SuA)				`thenFC` \ _ ->
     pushOnBStack (CReg SuB)				`thenFC` \ _ ->
     pushOnBStack updatee				`thenFC` \ _ ->
-    pushOnBStack (CLabel sTD_UPD_RET_VEC_LABEL CodePtrKind) `thenFC` \ _ ->
+    pushOnBStack (CLabel sTD_UPD_RET_VEC_LABEL CodePtrRep) `thenFC` \ _ ->
 
 	-- MAKE SuA, SuB POINT TO TOP OF A,B STACKS
 	-- Remember, SpB hasn't yet been incremented to account for the
@@ -82,74 +80,3 @@ int_CLit0 = mkIntCLit 0 -- out here to avoid pushUpdateFrame CAF (sigh)
 		    (CAssign (CReg SuB) (CAddr (SpBRel 0 4))))
 -------------------------- -}
 \end{code}
-
-@evalPushRCCFrame@ pushes a frame to restore the cost centre, and
-deallocates stuff from the A and B stack if evaluation profiling. No
-actual update is required so no closure to update is passed.
-@evalPushRCCFrame@ is called for an @scc@ expression and on entry to a
-single-entry thunk: no update reqd but cost centre manipulation is.
-
-\begin{code}
-{- OLD: WDP: 94/06
-
-evalPushRCCFrame :: Bool -> Code -> Code
-
-evalPushRCCFrame prim code
-  = isSwitchSetC SccProfiling_Eval	`thenFC` \ eval_profiling ->
-
-    if (not eval_profiling) then 
-	code
-    else
-
-    	-- Find out how many words of stack must will be
-	--   deallocated at the end of the basic block
-	-- As we push stuff onto the B stack we must make the
-	-- RCC frame dealocate the B stack words
-
-    	-- We dont actually push things onto the A stack so we
-	--   can treat the A stack as if these words were not there
-	--   i.e. we subtract them from the A stack offset
-	-- They will be popped by the current block of code
-
- 	-- Tell downstream code about the update frame on the B stack
-    allocUpdateFrame 
-		sCC_RCC_UF_SIZE 
-		(panic "pushEvalRCCFrame: mkRestoreCostCentreLbl")
-		(\ (old_args_spa, old_args_spb, upd_frame_offset) ->
-
-    getSpARelOffset old_args_spa	`thenFC` \ old_args_spa_rel ->
-    getSpBRelOffset upd_frame_offset	`thenFC` \ upd_frame_rel ->
-
-    let b_wds_to_pop = upd_frame_offset - old_args_spb
-    in
-
-	-- Allocate enough space on the B stack for the frame
-
-    evalCostCentreC
-	     (if prim then 
-		     "PUSH_RCC_FRAME_RETURN"
-		 else
-		     "PUSH_RCC_FRAME_VECTOR")
-	     [
-		mkIntCLit (spARelToInt old_args_spa_rel),
-			{- Place on A stack to ``draw the line'' -}
-		mkIntCLit (spBRelToInt upd_frame_rel),
-			{- Ditto B stk.  The update frame is pushed starting 
-			   just above here -}
-		mkIntCLit 0,
-			{- Number of words of A below the line, which must be
-			   popped to get to the tail-call position -}
-		mkIntCLit b_wds_to_pop
-			{- Ditto B stk -}
-	     ]				`thenC`
-
-    code
-
-
-	-- If we actually pushed things onto the A stack we have
-	--   to arrange for the RCC frame to pop these as well
-  	-- Would need to tell downstream code about the update frame
-	--   both the A and B stacks
-    )
--}
-\end{code}
diff --git a/ghc/compiler/codeGen/CgUsages.hi b/ghc/compiler/codeGen/CgUsages.hi
deleted file mode 100644
index b41e473609..0000000000
--- a/ghc/compiler/codeGen/CgUsages.hi
+++ /dev/null
@@ -1,29 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface CgUsages where
-import AbsCSyn(AbstractC, CAddrMode, CStmtMacro, MagicId, RegRelative, ReturnInfo)
-import BasicLit(BasicLit)
-import CLabelInfo(CLabel)
-import CgBindery(CgIdInfo)
-import CgMonad(CgInfoDownwards, CgState, StubFlag)
-import ClosureInfo(ClosureInfo)
-import CostCentre(CostCentre)
-import HeapOffs(HeapOffset)
-import Maybes(Labda)
-import PreludePS(_PackedString)
-import PrimOps(PrimOp)
-import UniqFM(UniqFM)
-data AbstractC 
-data RegRelative 
-data CgState 
-data HeapOffset 
-freeBStkSlot :: Int -> CgInfoDownwards -> CgState -> CgState
-getHpRelOffset :: HeapOffset -> CgInfoDownwards -> CgState -> (RegRelative, CgState)
-getSpARelOffset :: Int -> CgInfoDownwards -> CgState -> (RegRelative, CgState)
-getSpBRelOffset :: Int -> CgInfoDownwards -> CgState -> (RegRelative, CgState)
-getVirtAndRealHp :: CgInfoDownwards -> CgState -> ((HeapOffset, HeapOffset), CgState)
-getVirtSps :: CgInfoDownwards -> CgState -> ((Int, Int), CgState)
-initHeapUsage :: (HeapOffset -> CgInfoDownwards -> CgState -> CgState) -> CgInfoDownwards -> CgState -> CgState
-setRealAndVirtualSps :: Int -> Int -> CgInfoDownwards -> CgState -> CgState
-setRealHp :: HeapOffset -> CgInfoDownwards -> CgState -> CgState
-setVirtHp :: HeapOffset -> CgInfoDownwards -> CgState -> CgState
-
diff --git a/ghc/compiler/codeGen/CgUsages.lhs b/ghc/compiler/codeGen/CgUsages.lhs
index 41ebe84c6c..2e3fec3c06 100644
--- a/ghc/compiler/codeGen/CgUsages.lhs
+++ b/ghc/compiler/codeGen/CgUsages.lhs
@@ -9,12 +9,11 @@ modify (\tr{set*} functions) the stacks and heap usage information.
 \begin{code}
 module CgUsages (
 	initHeapUsage, setVirtHp, getVirtAndRealHp, setRealHp,
-	setRealAndVirtualSps, 
+	setRealAndVirtualSps,
 
 	getVirtSps,
 
 	getHpRelOffset,	getSpARelOffset, getSpBRelOffset,
---UNUSED: getVirtSpRelOffsets,
 
 	freeBStkSlot,
 
@@ -131,22 +130,11 @@ getSpBRelOffset virtual_offset info_down state@(MkCgState _ _ (_,(_,_,realSpB,_)
   = (SpBRel realSpB virtual_offset, state)
 \end{code}
 
-
-\begin{code}
-{- UNUSED:
-getVirtSpRelOffsets :: FCode (RegRelative, RegRelative)
-getVirtSpRelOffsets info_down
-	state@(MkCgState absC binds ((virtSpA,_,realSpA,_), (virtSpB,_,realSpB,_), _))
-  = ((SpARel realSpA virtSpA, SpBRel realSpB virtSpB), state)
--}
-\end{code}
-
 \begin{code}
 freeBStkSlot :: VirtualSpBOffset -> Code
 freeBStkSlot b_slot info_down
 	state@(MkCgState absC binds (spa_usage, (virtSpB,free_b,realSpB,hwSpB), heap_usage))
- = MkCgState absC binds (spa_usage, (virtSpB,new_free_b,realSpB,hwSpB), heap_usage)
- where
- new_free_b = addFreeBSlots free_b [b_slot]
-
+  = MkCgState absC binds (spa_usage, (virtSpB,new_free_b,realSpB,hwSpB), heap_usage)
+  where
+    new_free_b = addFreeBSlots free_b [b_slot]
 \end{code}
diff --git a/ghc/compiler/codeGen/ClosureInfo.hi b/ghc/compiler/codeGen/ClosureInfo.hi
deleted file mode 100644
index 95addbc841..0000000000
--- a/ghc/compiler/codeGen/ClosureInfo.hi
+++ /dev/null
@@ -1,106 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface ClosureInfo where
-import AbsCSyn(AbstractC, CAddrMode, CExprMacro, CStmtMacro, MagicId, RegRelative, ReturnInfo)
-import BasicLit(BasicLit)
-import CLabelInfo(CLabel)
-import CgBindery(CgIdInfo)
-import CgMonad(CgInfoDownwards, CgState, CompilationInfo, EndOfBlockInfo, FCode(..), StubFlag)
-import CmdLineOpts(GlobalSwitch)
-import CostCentre(CostCentre)
-import HeapOffs(HeapOffset)
-import Id(DataCon(..), Id)
-import Maybes(Labda)
-import PreludePS(_PackedString)
-import PrimKind(PrimKind)
-import PrimOps(PrimOp)
-import SMRep(SMRep, SMSpecRepKind, SMUpdateKind, getSMInfoStr, getSMInitHdrStr, getSMUpdInplaceHdrStr, ltSMRepHdr)
-import StgSyn(PlainStgAtom(..), PlainStgExpr(..), PlainStgLiveVars(..), StgAtom, StgBinderInfo, StgBinding, StgCaseAlternatives, StgExpr, UpdateFlag(..))
-import TyCon(TyCon)
-import UniType(UniType)
-import UniqFM(UniqFM)
-import UniqSet(UniqSet(..))
-import Unique(Unique)
-data AbstractC 
-data CAddrMode 
-data MagicId 
-data CLabel 
-data CgIdInfo 
-data CgInfoDownwards 
-data CgState 
-data ClosureInfo 
-data CompilationInfo 
-data EntryConvention   = ViaNode | StdEntry CLabel (Labda CLabel) | DirectEntry CLabel Int [MagicId]
-type FCode a = CgInfoDownwards -> CgState -> (a, CgState)
-data HeapOffset 
-type DataCon = Id
-data Id 
-data Labda a 
-data LambdaFormInfo 
-data PrimKind 
-data SMRep 
-type PlainStgAtom = StgAtom Id
-type PlainStgExpr = StgExpr Id Id
-type PlainStgLiveVars = UniqFM Id
-data StandardFormInfo 
-data StgAtom a 
-data StgBinderInfo 
-data StgExpr a b 
-data UpdateFlag   = ReEntrant | Updatable | SingleEntry
-data TyCon 
-data UniqFM a 
-type UniqSet a = UniqFM a
-allocProfilingMsg :: ClosureInfo -> _PackedString
-blackHoleClosureInfo :: ClosureInfo -> ClosureInfo
-blackHoleOnEntry :: Bool -> ClosureInfo -> Bool
-closureGoodStuffSize :: ClosureInfo -> Int
-closureHdrSize :: ClosureInfo -> HeapOffset
-closureId :: ClosureInfo -> Id
-closureKind :: ClosureInfo -> [Char]
-closureLFInfo :: ClosureInfo -> LambdaFormInfo
-closureLabelFromCI :: ClosureInfo -> CLabel
-closureNonHdrSize :: ClosureInfo -> Int
-closurePtrsSize :: ClosureInfo -> Int
-closureReturnsUnboxedType :: ClosureInfo -> Bool
-closureSMRep :: ClosureInfo -> SMRep
-closureSemiTag :: ClosureInfo -> Int
-closureSingleEntry :: ClosureInfo -> Bool
-closureSize :: ClosureInfo -> HeapOffset
-closureSizeWithoutFixedHdr :: ClosureInfo -> HeapOffset
-closureType :: ClosureInfo -> Labda (TyCon, [UniType], [Id])
-closureTypeDescr :: ClosureInfo -> [Char]
-closureUpdReqd :: ClosureInfo -> Bool
-dataConLiveness :: ((Int -> GlobalSwitch) -> Labda Int) -> ClosureInfo -> Int
-entryLabelFromCI :: ClosureInfo -> CLabel
-fastLabelFromCI :: ClosureInfo -> CLabel
-fitsMinUpdSize :: ClosureInfo -> Bool
-funInfoTableRequired :: Id -> StgBinderInfo -> LambdaFormInfo -> Bool
-getEntryConvention :: Id -> LambdaFormInfo -> [PrimKind] -> CgInfoDownwards -> CgState -> (EntryConvention, CgState)
-getSMInfoStr :: SMRep -> [Char]
-getSMInitHdrStr :: SMRep -> [Char]
-getSMUpdInplaceHdrStr :: SMRep -> [Char]
-getStandardFormThunkInfo :: LambdaFormInfo -> Labda [StgAtom Id]
-infoTableLabelFromCI :: ClosureInfo -> CLabel
-isConstantRep :: SMRep -> Bool
-isPhantomRep :: SMRep -> Bool
-isSpecRep :: SMRep -> Bool
-isStaticClosure :: ClosureInfo -> Bool
-layOutDynClosure :: Id -> (a -> PrimKind) -> [a] -> LambdaFormInfo -> (ClosureInfo, [(a, HeapOffset)])
-layOutDynCon :: Id -> (a -> PrimKind) -> [a] -> (ClosureInfo, [(a, HeapOffset)])
-layOutPhantomClosure :: Id -> LambdaFormInfo -> ClosureInfo
-layOutStaticClosure :: Id -> (a -> PrimKind) -> [a] -> LambdaFormInfo -> (ClosureInfo, [(a, HeapOffset)])
-layOutStaticNoFVClosure :: Id -> LambdaFormInfo -> ClosureInfo
-ltSMRepHdr :: SMRep -> SMRep -> Bool
-maybeSelectorInfo :: ClosureInfo -> Labda (Id, Int)
-mkClosureLFInfo :: Bool -> [Id] -> UpdateFlag -> [Id] -> StgExpr Id Id -> LambdaFormInfo
-mkConLFInfo :: Id -> LambdaFormInfo
-mkLFArgument :: LambdaFormInfo
-mkLFImported :: Id -> LambdaFormInfo
-mkLFLetNoEscape :: Int -> UniqFM Id -> LambdaFormInfo
-mkVirtHeapOffsets :: SMRep -> (a -> PrimKind) -> [a] -> (Int, Int, [(a, HeapOffset)])
-noUpdVapRequired :: StgBinderInfo -> Bool
-nodeMustPointToIt :: LambdaFormInfo -> CgInfoDownwards -> CgState -> (Bool, CgState)
-slopSize :: ClosureInfo -> Int
-slowFunEntryCodeRequired :: Id -> StgBinderInfo -> Bool
-staticClosureRequired :: Id -> StgBinderInfo -> LambdaFormInfo -> Bool
-stdVapRequired :: StgBinderInfo -> Bool
-
diff --git a/ghc/compiler/codeGen/ClosureInfo.lhs b/ghc/compiler/codeGen/ClosureInfo.lhs
index 8f54a130ca..dddeddf471 100644
--- a/ghc/compiler/codeGen/ClosureInfo.lhs
+++ b/ghc/compiler/codeGen/ClosureInfo.lhs
@@ -20,17 +20,17 @@ module ClosureInfo (
 
 	closureSize, closureHdrSize,
 	closureNonHdrSize, closureSizeWithoutFixedHdr,
-	closureGoodStuffSize, closurePtrsSize, -- UNUSED: closureNonPtrsSize,
+	closureGoodStuffSize, closurePtrsSize,
 	slopSize, fitsMinUpdSize,
 
 	layOutDynClosure, layOutDynCon, layOutStaticClosure,
 	layOutStaticNoFVClosure, layOutPhantomClosure,
-        mkVirtHeapOffsets, -- for GHCI
+	mkVirtHeapOffsets, -- for GHCI
 
 	nodeMustPointToIt, getEntryConvention,
 	blackHoleOnEntry,
 
-	staticClosureRequired, 
+	staticClosureRequired,
 	slowFunEntryCodeRequired, funInfoTableRequired,
 	stdVapRequired, noUpdVapRequired,
 
@@ -41,30 +41,18 @@ module ClosureInfo (
 	closureSingleEntry, closureSemiTag, closureType,
 	closureReturnsUnboxedType, getStandardFormThunkInfo,
 
---OLD 	auxInfoTableLabelFromCI, isIntLikeRep,  -- go away in 0.23
- 
 	closureKind, closureTypeDescr,		-- profiling
 
 	isConstantRep, isSpecRep, isPhantomRep, -- ToDo: Should be in SMRep, perhaps?
 	isStaticClosure, allocProfilingMsg,
 	blackHoleClosureInfo,
 	getSMInfoStr, getSMInitHdrStr, getSMUpdInplaceHdrStr,
-	ltSMRepHdr, --UNUSED: equivSMRepHdr,
+	ltSMRepHdr,
 	maybeSelectorInfo,
 
-    	dataConLiveness,    	    	    	-- concurrency
+    	dataConLiveness				-- concurrency
 
 	-- and to make the interface self-sufficient...
-	AbstractC, CAddrMode, HeapOffset, MagicId,
-	CgInfoDownwards, CgState, CgIdInfo, CompilationInfo,
-	CLabel, Id, Maybe, PrimKind, FCode(..), TyCon, StgExpr,
-	StgAtom, StgBinderInfo,
-	DataCon(..), PlainStgExpr(..), PlainStgLiveVars(..),
-	PlainStgAtom(..),
-	UniqSet(..), UniqFM, UpdateFlag(..) -- not abstract
-
-	IF_ATTACK_PRAGMAS(COMMA mkClosureLabel)
-	IF_ATTACK_PRAGMAS(COMMA getUniDataSpecTyCon_maybe)
     ) where
 
 import AbsCSyn
@@ -72,17 +60,17 @@ import CgMonad
 import SMRep
 import StgSyn
 
-import AbsUniType
+import Type
 import CgCompInfo	-- some magic constants
 import CgRetConv
-import CLabelInfo	-- Lots of label-making things
+import CLabel	-- Lots of label-making things
 import CmdLineOpts	( GlobalSwitch(..) )
 import Id
 import IdInfo		-- SIGH
 import Maybes		( maybeToBool, assocMaybe, Maybe(..) )
 import Outputable	-- needed for INCLUDE_FRC_METHOD
 import Pretty		-- ( ppStr, Pretty(..) )
-import PrimKind		( PrimKind, getKindSize, separateByPtrFollowness )
+import PrimRep		( PrimRep, getPrimRepSize, separateByPtrFollowness )
 import Util
 \end{code}
 
@@ -269,7 +257,7 @@ data LambdaFormInfo
   | LFTuple		-- Tuples
 	DataCon		-- The tuple constructor (may be specialised)
 	Bool		-- True <=> zero arity
-	
+
   | LFThunk		-- Thunk (zero arity)
 	Bool		-- True <=> top level
 	Bool		-- True <=> no free vars
@@ -288,7 +276,7 @@ data LambdaFormInfo
   | LFLetNoEscape	-- See LetNoEscape module for precise description of
 			-- these "lets".
 	Int		-- arity;
-	PlainStgLiveVars-- list of variables live in the RHS of the let.
+	StgLiveVars-- list of variables live in the RHS of the let.
 			-- (ToDo: maybe not used)
 
   | LFBlackHole		-- Used for the closures allocated to hold the result
@@ -304,41 +292,41 @@ data StandardFormInfo	-- Tells whether this thunk has one of a small number
 
   = NonStandardThunk	-- No, it isn't
 
- | SelectorThunk       			
+ | SelectorThunk
        Id              	-- Scrutinee
        DataCon         	-- Constructor
        Int             	-- 0-origin offset of ak within the "goods" of constructor
 			-- (Recall that the a1,...,an may be laid out in the heap
 			--  in a non-obvious order.)
-                                                      
+
 {- A SelectorThunk is of form
 
-     case x of                                       
-       con a1,..,an -> ak                            
-                                                     
-   and the constructor is from a single-constr type.    
+     case x of
+       con a1,..,an -> ak
+
+   and the constructor is from a single-constr type.
    If we can't convert the heap-offset of the selectee into an Int, e.g.,
    it's "GEN_VHS+i", we just give up.
 -}
-	  		
+
   | VapThunk
 	Id			-- Function
-	[PlainStgAtom]		-- Args
-	Bool			-- True <=> the function is not top-level, so 
+	[StgArg]		-- Args
+	Bool			-- True <=> the function is not top-level, so
 				-- must be stored in the thunk too
-			
+
 {- A VapThunk is of form
 
-        f a1 ... an                                             
+	f a1 ... an
 
-   where f is a known function, with arity n                    
-   So for this thunk we can use the label for f's heap-entry    
-   info table (generated when f's defn was dealt with),         
-   rather than generating a one-off info table and entry code   
-   for this one thunk.                                          
+   where f is a known function, with arity n
+   So for this thunk we can use the label for f's heap-entry
+   info table (generated when f's defn was dealt with),
+   rather than generating a one-off info table and entry code
+   for this one thunk.
 -}
 
-			
+
 mkLFArgument	= LFArgument
 mkLFBlackHole	= LFBlackHole
 mkLFLetNoEscape = LFLetNoEscape
@@ -365,7 +353,7 @@ mkClosureLFInfo :: Bool 	-- True of top level
 		-> [Id]		-- Free vars
 		-> UpdateFlag 	-- Update flag
 		-> [Id] 	-- Args
-		-> PlainStgExpr	-- Body of closure: passed so we
+		-> StgExpr	-- Body of closure: passed so we
 				-- can look for selector thunks!
 		-> LambdaFormInfo
 
@@ -390,24 +378,24 @@ mkClosureLFInfo False	    -- don't bother if at top-level
 		[the_fv]    -- just one...
 		Updatable
 		[]	    -- no args (a thunk)
-		(StgCase (StgApp (StgVarAtom scrutinee) [{-no args-}] _)
+		(StgCase (StgApp (StgVarArg scrutinee) [{-no args-}] _)
 		  _ _ _   -- ignore live vars and uniq...
 		  (StgAlgAlts case_ty
 		     [(con, params, use_mask,
-			(StgApp (StgVarAtom selectee) [{-no args-}] _))]
+			(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 getIdKind params
+    (_, params_w_offsets) = layOutDynCon con getIdPrimRep params
     maybe_offset	  = assocMaybe params_w_offsets selectee
     Just the_offset 	  = maybe_offset
-    offset_into_int_maybe = intOffsetIntoGoods the_offset 
+    offset_into_int_maybe = intOffsetIntoGoods the_offset
     Just offset_into_int  = offset_into_int_maybe
     is_single_constructor = maybeToBool (maybeSingleConstructorTyCon tycon)
     (_,_,_, tycon)	  = getDataConSig con
@@ -424,8 +412,8 @@ mkClosureLFInfo top_level
 		fvs
 		upd_flag
 		[]			-- No args; a thunk
-		(StgApp (StgVarAtom fun_id) args _)
-  | not top_level			-- A top-level thunk would require a static 
+		(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.
@@ -561,7 +549,7 @@ THEREFORE: @mIN_SIZE_NonUpdHeapObject = 1@
 	@ConstantRep@ and @CharLikeRep@ closures always use the address of
 	a static closure. They are never allocated or
 	collected (eg hold forwarding pointer) hence never any slop.
-	
+
 	\item
 	@IntLikeRep@ are never updatable.
 	May need slop to be collected (as they will be size 1 or more
@@ -614,7 +602,7 @@ computeSlopSize tot_wds other_rep _			-- Any other rep
 \begin{code}
 layOutDynClosure, layOutStaticClosure
 	:: Id			    -- STG identifier w/ which this closure assoc'd
-	-> (a -> PrimKind)    	    -- function w/ which to be able to get a PrimKind
+	-> (a -> PrimRep)    	    -- function w/ which to be able to get a PrimRep
 	-> [a]			    -- the "things" being layed out
 	-> LambdaFormInfo	    -- what sort of closure it is
 	-> (ClosureInfo,	    -- info about the closure
@@ -656,11 +644,11 @@ layOutPhantomClosure name lf_info = MkClosureInfo name lf_info PhantomRep
 A wrapper for when used with data constructors:
 \begin{code}
 layOutDynCon :: DataCon
-	     -> (a -> PrimKind)
+	     -> (a -> PrimRep)
 	     -> [a]
 	     -> (ClosureInfo, [(a,VirtualHeapOffset)])
 
-layOutDynCon con kind_fn args 
+layOutDynCon con kind_fn args
   = ASSERT(isDataCon con)
     layOutDynClosure con kind_fn args (mkConLFInfo con)
 \end{code}
@@ -725,7 +713,7 @@ the result list
 
 \begin{code}
 mkVirtHeapOffsets :: SMRep		-- Representation to be used by storage manager
-	  -> (a -> PrimKind)	-- To be able to grab kinds;
+	  -> (a -> PrimRep)	-- To be able to grab kinds;
 					--  	w/ a kind, we can find boxedness
 	  -> [a]			-- Things to make offsets for
 	  -> (Int,			-- *Total* number of words allocated
@@ -744,7 +732,7 @@ mkVirtHeapOffsets sm_rep kind_fun things
   where
     offset_of_first_word = totHdrSize sm_rep
     computeOffset wds_so_far thing
-      = (wds_so_far + (getKindSize . kind_fun) thing,
+      = (wds_so_far + (getPrimRepSize . kind_fun) thing,
 	 (thing, (offset_of_first_word `addOff` (intOff wds_so_far)))
 	)
 \end{code}
@@ -771,10 +759,6 @@ nodeMustPointToIt lf_info
 		    --   is not top level as special case cgRhsClosure
 		    --   has been dissabled in favour of let floating
 
---OLD:	||  (arity == 0 && do_profiling)
---		-- Access to cost centre required for 0 arity if profiling
---		-- Simon: WHY?  (94/12)
-
 		-- For lex_profiling we also access the cost centre for a
 		-- non-inherited function i.e. not top level
 		-- the  not top  case above ensures this is ok.
@@ -837,7 +821,7 @@ Known fun ($\ge$ 1 arg), fvs	& yes & yes & registers & node \\
 0 arg, fvs @\u@ 		& yes & yes & n/a 	& node\\
 \end{tabular}
 
-When black-holing, single-entry closures could also be entered via node 
+When black-holing, single-entry closures could also be entered via node
 (rather than directly) to catch double-entry.
 
 \begin{code}
@@ -845,7 +829,7 @@ data EntryConvention
   = ViaNode				-- The "normal" convention
 
   | StdEntry CLabel			-- Jump to this code, with args on stack
-             (Maybe CLabel) 	    	-- possibly setting infoptr to this
+	     (Maybe CLabel) 	    	-- possibly setting infoptr to this
 
   | DirectEntry 			-- Jump directly to code, with args in regs
 	CLabel 				--   The code label
@@ -854,12 +838,12 @@ data EntryConvention
 
 getEntryConvention :: Id			-- Function being applied
 		   -> LambdaFormInfo		-- Its info
-		   -> [PrimKind]		-- Available arguments
+		   -> [PrimRep]		-- Available arguments
 		   -> FCode EntryConvention
 
 getEntryConvention id lf_info arg_kinds
  =  nodeMustPointToIt lf_info	`thenFC` \ node_points ->
-    isSwitchSetC ForConcurrent	`thenFC` \ is_concurrent -> 
+    isSwitchSetC ForConcurrent	`thenFC` \ is_concurrent ->
     getIntSwitchChkrC		`thenFC` \ isw_chkr ->
     returnFC (
 
@@ -867,23 +851,23 @@ getEntryConvention id lf_info arg_kinds
 
     case lf_info of
 
-        LFReEntrant _ arity _ -> 
-	    if arity == 0 || (length arg_kinds) < arity then 
+	LFReEntrant _ arity _ ->
+	    if arity == 0 || (length arg_kinds) < arity then
 		StdEntry (mkStdEntryLabel id) Nothing
-	    else 
+	    else
 		DirectEntry (mkFastEntryLabel id arity) arity arg_regs
 	  where
 	    (arg_regs, _) = assignRegs isw_chkr live_regs (take arity arg_kinds)
     	    live_regs = if node_points then [node] else []
 
-        LFCon con zero_arity  
-                          -> let itbl = if zero_arity then
+	LFCon con zero_arity
+			  -> let itbl = if zero_arity then
     	    	    	    	        mkPhantomInfoTableLabel con
     	    	    	    	    	else
     	    	    	    	    	mkInfoTableLabel con
     	    	    	     in StdEntry (mkStdEntryLabel con) (Just itbl)
 				-- Should have no args
-        LFTuple tup zero_arity
+	LFTuple tup zero_arity
 			 -> StdEntry (mkStdEntryLabel tup)
 				     (Just (mkInfoTableLabel tup))
 				-- Should have no args
@@ -893,9 +877,9 @@ getEntryConvention id lf_info arg_kinds
 	     then ViaNode
 	     else StdEntry (thunkEntryLabel id std_form_info updatable) Nothing
 
-        LFArgument  -> ViaNode
-        LFImported  -> ViaNode
-        LFBlackHole -> ViaNode	-- Presumably the black hole has by now
+	LFArgument  -> ViaNode
+	LFImported  -> ViaNode
+	LFBlackHole -> ViaNode	-- Presumably the black hole has by now
 				-- been updated, but we don't know with
 				-- what, so we enter via Node
 
@@ -924,22 +908,22 @@ blackHoleOnEntry no_black_holing (MkClosureInfo _ lf_info _)
 	  -> if updatable
 	     then not no_black_holing
 	     else not no_fvs
-	other			  -> panic "blackHoleOnEntry"	-- Should never happen
+	other -> panic "blackHoleOnEntry"	-- Should never happen
 
-getStandardFormThunkInfo 
-	:: LambdaFormInfo 
-	-> Maybe [PlainStgAtom]		-- Nothing    => not a standard-form thunk
+getStandardFormThunkInfo
+	:: LambdaFormInfo
+	-> Maybe [StgArg]		-- Nothing    => not a standard-form thunk
 					-- Just atoms => a standard-form thunk with payload atoms
 
 getStandardFormThunkInfo (LFThunk _ _ _ (SelectorThunk scrutinee _ _))
   = --trace "Selector thunk: missed opportunity to save info table + code"
     Nothing
-	-- Just [StgVarAtom scrutinee]
+	-- Just [StgVarArg scrutinee]
 	-- We can't save the info tbl + code until we have a way to generate
 	-- a fixed family thereof.
 
 getStandardFormThunkInfo (LFThunk _ _ _ (VapThunk fun_id args fun_in_payload))
-  | fun_in_payload = Just (StgVarAtom fun_id : args)
+  | fun_in_payload = Just (StgVarArg fun_id : args)
   | otherwise	   = Just args
 
 getStandardFormThunkInfo other_lf_info = Nothing
@@ -973,12 +957,12 @@ have closure, info table, and entry code.]
 	OR	   (b) the function is passed as an arg
 	OR	   (c) if the function has free vars (ie not top level)
 
-  Why case (a) here?  Because if the arg-satis check fails, 
+  Why case (a) here?  Because if the arg-satis check fails,
   UpdatePAP stuffs a pointer to the function closure in the PAP.
   [Could be changed; UpdatePAP could stuff in a code ptr instead,
    but doesn't seem worth it.]
 
-  [NB: these conditions imply that we might need the closure 
+  [NB: these conditions imply that we might need the closure
   without the slow-entry code.  Here's how.
 
 	f x y = let g w = ...x..y..w...
@@ -994,7 +978,7 @@ have closure, info table, and entry code.]
 	Needed iff (a) we have any un-saturated calls to the function
 	OR	   (b) the function is passed as an arg
 	OR 	   (c) the function has free vars (ie not top level)
- 
+
 	NB.  In the sequential world, (c) is only required so that the function closure has
 	an info table to point to, to keep the storage manager happy.
 	If (c) alone is true we could fake up an info table by choosing
@@ -1015,17 +999,17 @@ have closure, info table, and entry code.]
 
 * Single-update vap-entry code
   Single-update vap-entry info table
-	Needed iff we have any non-updatable thunks of the 
+	Needed iff we have any non-updatable thunks of the
 	standard vap-entry shape.
-	
+
 
 \begin{code}
 staticClosureRequired
 	:: Id
-	-> StgBinderInfo 
+	-> StgBinderInfo
 	-> LambdaFormInfo
 	-> Bool
-staticClosureRequired binder (StgBinderInfo arg_occ unsat_occ _ _ _) 
+staticClosureRequired binder (StgBinderInfo arg_occ unsat_occ _ _ _)
 		      (LFReEntrant top_level _ _)	-- It's a function
   = ASSERT( top_level )		 	-- Assumption: it's a top-level, no-free-var binding
     arg_occ 		-- There's an argument occurrence
@@ -1052,7 +1036,7 @@ funInfoTableRequired
 	-> LambdaFormInfo
 	-> Bool
 funInfoTableRequired  binder (StgBinderInfo arg_occ unsat_occ _ _ _)
-                     (LFReEntrant top_level _ _)
+		     (LFReEntrant top_level _ _)
   = not top_level
     || arg_occ 		-- There's an argument occurrence
     || unsat_occ	-- There's an unsaturated call
@@ -1060,8 +1044,8 @@ funInfoTableRequired  binder (StgBinderInfo arg_occ unsat_occ _ _ _)
 
 funInfoTableRequired other_binder_info binder other_lf_info = True
 
--- We need the vector-apply entry points for a function if 
--- there's a vector-apply occurrence in this module 
+-- We need the vector-apply entry points for a function if
+-- there's a vector-apply occurrence in this module
 
 stdVapRequired, noUpdVapRequired :: StgBinderInfo -> Bool
 
@@ -1128,7 +1112,7 @@ closureSingleEntry other_closure			   = False
 Note: @closureType@ returns appropriately specialised tycon and
 datacons.
 \begin{code}
-closureType :: ClosureInfo -> Maybe (TyCon, [UniType], [Id])
+closureType :: ClosureInfo -> Maybe (TyCon, [Type], [Id])
 
 -- First, a turgid special case.  When we are generating the
 -- standard code and info-table for Vaps (which is done when the function
@@ -1139,9 +1123,9 @@ closureType :: ClosureInfo -> Maybe (TyCon, [UniType], [Id])
 closureType (MkClosureInfo id (LFThunk _ _ _ (VapThunk fun_id args _)) _)
   = getUniDataSpecTyCon_maybe (funResultTy de_foralld_ty (length args))
   where
-    (_, de_foralld_ty) = splitForalls (getIdUniType fun_id)
+    (_, de_foralld_ty) = splitForalls (idType fun_id)
 
-closureType (MkClosureInfo id lf _) = getUniDataSpecTyCon_maybe (getIdUniType id)
+closureType (MkClosureInfo id lf _) = getUniDataSpecTyCon_maybe (idType id)
 \end{code}
 
 @closureReturnsUnboxedType@ is used to check whether a closure, {\em
@@ -1158,7 +1142,7 @@ closureReturnsUnboxedType :: ClosureInfo -> Bool
 closureReturnsUnboxedType (MkClosureInfo fun_id (LFReEntrant _ arity _) _)
   = isPrimType (funResultTy de_foralld_ty arity)
   where
-    (_, de_foralld_ty) = splitForalls (getIdUniType fun_id)
+    (_, de_foralld_ty) = splitForalls (idType fun_id)
 
 closureReturnsUnboxedType other_closure = False
 	-- All non-function closures aren't functions,
@@ -1172,7 +1156,6 @@ closureSemiTag (MkClosureInfo _ lf_info _)
   = case lf_info of
       LFCon data_con _ -> getDataConTag data_con - fIRST_TAG
       LFTuple _ _      -> 0
-      --UNUSED: LFIndirection  -> fromInteger iND_TAG
       _	    	       -> fromInteger oTHER_TAG
 \end{code}
 
@@ -1189,7 +1172,7 @@ infoTableLabelFromCI (MkClosureInfo id lf_info rep)
 	LFBlackHole     -> mkBlackHoleInfoTableLabel
 
 	LFThunk _ _ upd_flag (VapThunk fun_id args _) -> mkVapInfoTableLabel fun_id upd_flag
-					-- Use the standard vap info table 
+					-- Use the standard vap info table
 					-- for the function, rather than a one-off one
 					-- for this particular closure
 
@@ -1210,15 +1193,15 @@ infoTableLabelFromCI (MkClosureInfo id lf_info rep)
 		 else -} mkInfoTableLabel id
 
 mkConInfoPtr :: Id -> SMRep -> CLabel
-mkConInfoPtr id rep = 
-  case rep of 
+mkConInfoPtr id rep =
+  case rep of
     PhantomRep	    -> mkPhantomInfoTableLabel id
     StaticRep _ _   -> mkStaticInfoTableLabel  id
     _		    -> mkInfoTableLabel	       id
 
 mkConEntryPtr :: Id -> SMRep -> CLabel
-mkConEntryPtr id rep = 
-  case rep of 
+mkConEntryPtr id rep =
+  case rep of
     StaticRep _ _   -> mkStaticConEntryLabel id
     _		    -> mkConEntryLabel id
 
@@ -1238,11 +1221,11 @@ entryLabelFromCI (MkClosureInfo id lf_info rep)
 -- I don't think it needs to deal with the SelectorThunk case
 -- Well, it's falling over now, so I've made it deal with it.  (JSM)
 
-thunkEntryLabel thunk_id (VapThunk fun_id args _) is_updatable 
+thunkEntryLabel thunk_id (VapThunk fun_id args _) is_updatable
   = mkVapEntryLabel fun_id is_updatable
-thunkEntryLabel thunk_id _ is_updatable 
+thunkEntryLabel thunk_id _ is_updatable
   = mkStdEntryLabel thunk_id
-		
+
 fastLabelFromCI :: ClosureInfo -> CLabel
 fastLabelFromCI (MkClosureInfo id _ _) = mkFastEntryLabel id fun_arity
   where
@@ -1262,7 +1245,6 @@ allocProfilingMsg (MkClosureInfo _ lf_info _)
       LFTuple _ _		-> SLIT("ALLOC_CON")
       LFThunk _ _ _ _ 		-> SLIT("ALLOC_THK")
       LFBlackHole		-> SLIT("ALLOC_BH")
-      --UNUSED: LFIndirection	-> panic "ALLOC_IND"
       LFImported		-> panic "ALLOC_IMP"
 \end{code}
 
@@ -1316,7 +1298,6 @@ closureKind (MkClosureInfo _ lf _)
       LFTuple _ _		-> "CON_K"
       LFThunk _ _ _ _ 		-> "THK_K"
       LFBlackHole		-> "THK_K" -- consider BHs as thunks for the moment... (ToDo?)
-      --UNUSED: LFIndirection	-> panic "IND_KIND"
       LFImported		-> panic "IMP_KIND"
 
 closureTypeDescr :: ClosureInfo -> String
@@ -1324,6 +1305,6 @@ closureTypeDescr (MkClosureInfo id lf _)
   = if (isDataCon id) then			-- DataCon has function types
 	_UNPK_ (getOccurrenceName (getDataConTyCon id))	-- We want the TyCon not the ->
     else
-	getUniTyDescription (getIdUniType id)
+	getUniTyDescription (idType id)
 \end{code}
 
diff --git a/ghc/compiler/codeGen/CodeGen.hi b/ghc/compiler/codeGen/CodeGen.hi
deleted file mode 100644
index c749965d15..0000000000
--- a/ghc/compiler/codeGen/CodeGen.hi
+++ /dev/null
@@ -1,24 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface CodeGen where
-import AbsCSyn(AbstractC, CAddrMode, CStmtMacro, MagicId, RegRelative, ReturnInfo)
-import BasicLit(BasicLit)
-import CLabelInfo(CLabel)
-import ClosureInfo(ClosureInfo)
-import CmdLineOpts(GlobalSwitch, SwitchResult)
-import CostCentre(CostCentre)
-import FiniteMap(FiniteMap)
-import Id(Id)
-import Maybes(Labda)
-import PreludePS(_PackedString)
-import PrimOps(PrimOp)
-import StgSyn(StgBinding, StgRhs)
-import TyCon(TyCon)
-import UniType(UniType)
-import UniqFM(UniqFM)
-data AbstractC 
-data FiniteMap a b 
-data Id 
-data StgBinding a b 
-data UniqFM a 
-codeGen :: _PackedString -> ([CostCentre], [CostCentre]) -> [_PackedString] -> (GlobalSwitch -> SwitchResult) -> [TyCon] -> FiniteMap TyCon [(Bool, [Labda UniType])] -> [StgBinding Id Id] -> AbstractC
-
diff --git a/ghc/compiler/codeGen/CodeGen.lhs b/ghc/compiler/codeGen/CodeGen.lhs
index 89d4baa5c8..d8112a8bd2 100644
--- a/ghc/compiler/codeGen/CodeGen.lhs
+++ b/ghc/compiler/codeGen/CodeGen.lhs
@@ -17,19 +17,13 @@ functions drive the mangling of top-level bindings.
 \begin{code}
 #include "HsVersions.h"
 
-module CodeGen (
-	codeGen,
-
-	-- and to make the interface self-sufficient...
-	UniqFM, AbstractC, StgBinding, Id, FiniteMap
-    ) where
-
+module CodeGen ( codeGen ) where
 
 import StgSyn
 import CgMonad
 import AbsCSyn
 
-import CLabelInfo	( modnameToC )
+import CLabel	( modnameToC )
 import CgClosure	( cgTopRhsClosure )
 import CgCon		( cgTopRhsCon )
 import CgConTbls	( genStaticConBits, TCE(..), UniqFM )
@@ -38,7 +32,7 @@ import CmdLineOpts
 import FiniteMap	( FiniteMap )
 import Maybes		( Maybe(..) )
 import Pretty		-- debugging only
-import PrimKind		( getKindSize )
+import PrimRep		( getPrimRepSize )
 import Util
 \end{code}
 
@@ -47,47 +41,22 @@ codeGen :: FAST_STRING		-- module name
 	-> ([CostCentre],	-- local cost-centres needing declaring/registering
 	    [CostCentre])	-- "extern" cost-centres needing declaring
 	-> [FAST_STRING]	-- import names
-	-> (GlobalSwitch -> SwitchResult)
-				-- global switch lookup function
 	-> [TyCon]		-- tycons with data constructors to convert
-	-> FiniteMap TyCon [(Bool, [Maybe UniType])]
+	-> FiniteMap TyCon [(Bool, [Maybe Type])]
 				-- tycon specialisation info
-	-> PlainStgProgram	-- bindings to convert
+	-> [StgBinding]	-- bindings to convert
 	-> AbstractC		-- output
 
-codeGen mod_name (local_CCs, extern_CCs) import_names sw_lookup_fn gen_tycons tycon_specs stg_pgm
+codeGen mod_name (local_CCs, extern_CCs) import_names gen_tycons tycon_specs stg_pgm
   = let
-	switch_is_on	  = switchIsOn   sw_lookup_fn
-	int_switch_set	  = intSwitchSet sw_lookup_fn
-	doing_profiling   = switch_is_on SccProfilingOn
-	compiling_prelude = switch_is_on CompilingPrelude
+	doing_profiling   = opt_SccProfilingOn
+	compiling_prelude = opt_CompilingPrelude
 	maybe_split       = if (switch_is_on (EnsureSplittableC (panic "codeGen:esc")))
 			    then CSplitMarker
 			    else AbsCNop
 
 	cinfo = MkCompInfo switch_is_on int_switch_set mod_name
     in
-
-{- OLD:
-    pprTrace "codeGen:" (ppCat [
-    (case (switch_is_on StgDoLetNoEscapes) of
-	False -> ppStr "False?"
-	True  -> ppStr "True?"
-    ),
-    (case (int_switch_set ReturnInRegsThreshold) of
-	Nothing -> ppStr "Nothing!"
-	Just  n -> ppCat [ppStr "Just", ppInt n]
-    ),
-    (case (int_switch_set UnfoldingUseThreshold) of
-	Nothing -> ppStr "Nothing!"
-	Just  n -> ppCat [ppStr "Just", ppInt n]
-    ),
-    (case (int_switch_set UnfoldingCreationThreshold) of
-	Nothing -> ppStr "Nothing!"
-	Just  n -> ppCat [ppStr "Just", ppInt n]
-    )
-    ]) $
--}
     if not doing_profiling then
 	mkAbstractCs [
 	    genStaticConBits cinfo gen_tycons tycon_specs,
@@ -122,12 +91,12 @@ codeGen mod_name (local_CCs, extern_CCs) import_names sw_lookup_fn gen_tycons ty
 
     -----------------
     mkCcRegister ccs import_names
-      = let 
+      = let
 	    register_ccs     = mkAbstractCs (map mk_register ccs)
 	    register_imports = mkAbstractCs (map mk_import_register import_names)
 	in
 	mkAbstractCs [
-	    CCallProfCCMacro SLIT("START_REGISTER_CCS") [CLitLit (modnameToC (SLIT("_reg") _APPEND_ mod_name)) AddrKind],
+	    CCallProfCCMacro SLIT("START_REGISTER_CCS") [CLitLit (modnameToC (SLIT("_reg") _APPEND_ mod_name)) AddrRep],
 	    register_ccs,
 	    register_imports,
 	    CCallProfCCMacro SLIT("END_REGISTER_CCS") []
@@ -137,7 +106,7 @@ codeGen mod_name (local_CCs, extern_CCs) import_names sw_lookup_fn gen_tycons ty
 	  = CCallProfCCMacro SLIT("REGISTER_CC") [mkCCostCentre cc]
 
 	mk_import_register import_name
-	  = CCallProfCCMacro SLIT("REGISTER_IMPORT") [CLitLit (modnameToC (SLIT("_reg") _APPEND_ import_name)) AddrKind]
+	  = CCallProfCCMacro SLIT("REGISTER_IMPORT") [CLitLit (modnameToC (SLIT("_reg") _APPEND_ import_name)) AddrRep]
 \end{code}
 
 %************************************************************************
@@ -157,18 +126,18 @@ style, with the increasing static environment being plumbed as a state
 variable.
 
 \begin{code}
-cgTopBindings :: AbstractC -> PlainStgProgram -> Code
+cgTopBindings :: AbstractC -> [StgBinding] -> Code
 
 cgTopBindings split bindings = mapCs (cgTopBinding split) bindings
-  
-cgTopBinding :: AbstractC -> PlainStgBinding -> Code
 
-cgTopBinding split (StgNonRec name rhs) 
+cgTopBinding :: AbstractC -> StgBinding -> Code
+
+cgTopBinding split (StgNonRec name rhs)
   = absC split		`thenC`
     cgTopRhs name rhs	`thenFC` \ (name, info) ->
     addBindC name info
 
-cgTopBinding split (StgRec pairs) 
+cgTopBinding split (StgRec pairs)
   = absC split		`thenC`
     fixC (\ new_binds -> addBindsC new_binds	`thenC`
 			 mapFCs ( \ (b,e) -> cgTopRhs b e ) pairs
@@ -179,13 +148,13 @@ cgTopBinding split (StgRec pairs)
 -- to enclose the listFCs in cgTopBinding, but that tickled the
 -- statics "error" call in initC.  I DON'T UNDERSTAND WHY!
 
-cgTopRhs :: Id -> PlainStgRhs -> FCode (Id, CgIdInfo)
+cgTopRhs :: Id -> StgRhs -> FCode (Id, CgIdInfo)
 	-- the Id is passed along for setting up a binding...
 
 cgTopRhs name (StgRhsCon cc con args)
   = forkStatics (cgTopRhsCon name con args (all zero_size args))
   where
-    zero_size atom = getKindSize (getAtomKind atom) == 0
+    zero_size atom = getPrimRepSize (getArgPrimRep atom) == 0
 
 cgTopRhs name (StgRhsClosure cc bi fvs upd_flag args body)
   = ASSERT(null fvs) -- There should be no free variables
diff --git a/ghc/compiler/codeGen/SMRep.hi b/ghc/compiler/codeGen/SMRep.hi
deleted file mode 100644
index e8d86a346a..0000000000
--- a/ghc/compiler/codeGen/SMRep.hi
+++ /dev/null
@@ -1,15 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface SMRep where
-import Outputable(Outputable)
-data SMRep   = StaticRep Int Int | SpecialisedRep SMSpecRepKind Int Int SMUpdateKind | GenericRep Int Int SMUpdateKind | BigTupleRep Int | DataRep Int | DynamicRep | BlackHoleRep | PhantomRep | MuTupleRep Int
-data SMSpecRepKind   = SpecRep | ConstantRep | CharLikeRep | IntLikeRep
-data SMUpdateKind   = SMNormalForm | SMSingleEntry | SMUpdatable
-getSMInfoStr :: SMRep -> [Char]
-getSMInitHdrStr :: SMRep -> [Char]
-getSMUpdInplaceHdrStr :: SMRep -> [Char]
-ltSMRepHdr :: SMRep -> SMRep -> Bool
-instance Eq SMRep
-instance Ord SMRep
-instance Outputable SMRep
-instance Text SMRep
-
diff --git a/ghc/compiler/codeGen/SMRep.lhs b/ghc/compiler/codeGen/SMRep.lhs
index c7656af03e..4adcfd7f13 100644
--- a/ghc/compiler/codeGen/SMRep.lhs
+++ b/ghc/compiler/codeGen/SMRep.lhs
@@ -1,5 +1,5 @@
 %
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
 %
 \section[SMRep]{Storage manager representations of closure}
 
@@ -12,12 +12,13 @@ Other modules should access this info through ClosureInfo.
 module SMRep (
 	SMRep(..), SMSpecRepKind(..), SMUpdateKind(..),
 	getSMInfoStr, getSMInitHdrStr, getSMUpdInplaceHdrStr,
-	ltSMRepHdr -- UNUSED, equivSMRepHdr
+	ltSMRepHdr
     ) where
 
-import Outputable
-import Pretty
-import Util
+import Ubiq{-uitous-}
+
+import Pretty		( ppStr )
+import Util		( panic )
 \end{code}
 
 %************************************************************************
@@ -57,12 +58,12 @@ data SMRep
 	SMSpecRepKind	-- Which kind of specialised representation
 	Int		-- # ptr words
 	Int		-- # non-ptr words
-        SMUpdateKind   	-- Updatable?
+	SMUpdateKind   	-- Updatable?
 
   | GenericRep		-- GC routines consult sizes in info tbl
 	Int		-- # ptr words
 	Int		-- # non-ptr words
-        SMUpdateKind	-- Updatable?
+	SMUpdateKind	-- Updatable?
 
   | BigTupleRep		-- All ptrs, size in var-hdr field
 			-- Used for big tuples
@@ -96,7 +97,7 @@ BigTupleRep == TUPLE
     Never generated by the compiler, and only used in the RTS when
     mutuples don't require special attention at GC time (e.g. 2s)
     When it is used, it is a primitive object (never entered).
-    May be mutable...probably should never be used in the parallel 
+    May be mutable...probably should never be used in the parallel
     system, since we need to distinguish mutables from immutables when
     deciding whether to copy or move closures across processors.
 
@@ -138,11 +139,6 @@ instance Eq SMRep where
     (DataRep a1)	      == (DataRep a2)		   = a1 == a2
     a			      == b			   = (tagOf_SMRep a) _EQ_ (tagOf_SMRep b)
 
-{- UNUSED:
-equivSMRepHdr :: SMRep -> SMRep -> Bool
-a `equivSMRepHdr` b = (tagOf_SMRep a) _EQ_ (tagOf_SMRep b)
--}
-
 ltSMRepHdr :: SMRep -> SMRep -> Bool
 a `ltSMRepHdr` b = (tagOf_SMRep a) _LT_ (tagOf_SMRep b)
 
diff --git a/ghc/compiler/coreSyn/AnnCoreSyn.hi b/ghc/compiler/coreSyn/AnnCoreSyn.hi
deleted file mode 100644
index 663fad9330..0000000000
--- a/ghc/compiler/coreSyn/AnnCoreSyn.hi
+++ /dev/null
@@ -1,43 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface AnnCoreSyn where
-import BasicLit(BasicLit)
-import CoreSyn(CoreAtom, CoreExpr)
-import CostCentre(CostCentre)
-import Id(Id)
-import Outputable(NamedThing, Outputable)
-import PreludePS(_PackedString)
-import PreludeRatio(Ratio(..))
-import PrimKind(PrimKind)
-import PrimOps(PrimOp)
-import TyCon(TyCon)
-import TyVar(TyVar)
-import UniType(UniType)
-data AnnCoreBinding a b c   = AnnCoNonRec a (c, AnnCoreExpr' a b c) | AnnCoRec [(a, (c, AnnCoreExpr' a b c))]
-data AnnCoreCaseAlternatives a b c   = AnnCoAlgAlts [(Id, [a], (c, AnnCoreExpr' a b c))] (AnnCoreCaseDefault a b c) | AnnCoPrimAlts [(BasicLit, (c, AnnCoreExpr' a b c))] (AnnCoreCaseDefault a b c)
-data AnnCoreCaseDefault a b c   = AnnCoNoDefault | AnnCoBindDefault a (c, AnnCoreExpr' a b c)
-type AnnCoreExpr a b c = (c, AnnCoreExpr' a b c)
-data AnnCoreExpr' a b c   = AnnCoVar b | AnnCoLit BasicLit | AnnCoCon Id [UniType] [CoreAtom b] | AnnCoPrim PrimOp [UniType] [CoreAtom b] | AnnCoLam [a] (c, AnnCoreExpr' a b c) | AnnCoTyLam TyVar (c, AnnCoreExpr' a b c) | AnnCoApp (c, AnnCoreExpr' a b c) (CoreAtom b) | AnnCoTyApp (c, AnnCoreExpr' a b c) UniType | AnnCoCase (c, AnnCoreExpr' a b c) (AnnCoreCaseAlternatives a b c) | AnnCoLet (AnnCoreBinding a b c) (c, AnnCoreExpr' a b c) | AnnCoSCC CostCentre (c, AnnCoreExpr' a b c)
-data BasicLit 
-data CostCentre 
-data Id 
-data PrimOp 
-data TyCon 
-data TyVar 
-data UniType 
-deAnnotate :: (a, AnnCoreExpr' b c a) -> CoreExpr b c
-instance Eq BasicLit
-instance Eq PrimOp
-instance Eq TyCon
-instance Eq TyVar
-instance Eq UniType
-instance Ord BasicLit
-instance Ord TyCon
-instance Ord TyVar
-instance NamedThing TyCon
-instance NamedThing TyVar
-instance Outputable BasicLit
-instance Outputable PrimOp
-instance Outputable TyCon
-instance Outputable TyVar
-instance Outputable UniType
-
diff --git a/ghc/compiler/coreSyn/AnnCoreSyn.lhs b/ghc/compiler/coreSyn/AnnCoreSyn.lhs
index 25ba46c6c9..af16b22c52 100644
--- a/ghc/compiler/coreSyn/AnnCoreSyn.lhs
+++ b/ghc/compiler/coreSyn/AnnCoreSyn.lhs
@@ -13,29 +13,18 @@ really is} just like @CoreSyntax@.)
 module AnnCoreSyn (
 	AnnCoreBinding(..), AnnCoreExpr(..),
 	AnnCoreExpr'(..),	-- v sad that this must be exported
-	AnnCoreCaseAlternatives(..), AnnCoreCaseDefault(..),
-#ifdef DPH
-	AnnCoreParQuals(..),
-        AnnCoreParCommunicate(..),
-#endif {- Data Parallel Haskell -}
+	AnnCoreCaseAlts(..), AnnCoreCaseDefault(..),
 
-	deAnnotate, -- we may eventually export some of the other deAnners
+	deAnnotate -- we may eventually export some of the other deAnners
 
 	-- and to make the interface self-sufficient
-	BasicLit, Id, PrimOp, TyCon, TyVar, UniType, CostCentre
-	IF_ATTACK_PRAGMAS(COMMA cmpTyCon COMMA cmpTyVar)
-	IF_ATTACK_PRAGMAS(COMMA cmpUniType)
     ) where
 
-import AbsPrel		( PrimOp(..), PrimKind
+import PrelInfo		( PrimOp(..), PrimRep
 			  IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
 			  IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
 			)
-import AbsUniType	( Id, TyVar, TyCon, UniType
-			  IF_ATTACK_PRAGMAS(COMMA cmpTyCon COMMA cmpTyVar)
-			  IF_ATTACK_PRAGMAS(COMMA cmpUniType)
-			)
-import BasicLit		( BasicLit )
+import Literal		( Literal )
 import CoreSyn
 import Outputable
 import CostCentre	( CostCentre )
@@ -55,84 +44,41 @@ type AnnCoreExpr binder bindee annot = (annot, AnnCoreExpr' binder bindee annot)
 
 data AnnCoreExpr' binder bindee annot
   = AnnCoVar	 bindee
-  | AnnCoLit BasicLit
+  | AnnCoLit Literal
 
-  | AnnCoCon	 Id [UniType] [CoreAtom bindee]
+  | AnnCoCon	 Id [Type] [GenCoreAtom bindee]
 
-  | AnnCoPrim    PrimOp [UniType] [CoreAtom bindee]
+  | AnnCoPrim    PrimOp [Type] [GenCoreAtom bindee]
 
-  | AnnCoLam	 [binder]
+  | AnnCoLam	 binder
 		 (AnnCoreExpr binder bindee annot)
   | AnnCoTyLam   TyVar
 		 (AnnCoreExpr binder bindee annot)
 
   | AnnCoApp	 (AnnCoreExpr binder bindee annot)
-		 (CoreAtom    bindee)
+		 (GenCoreAtom    bindee)
   | AnnCoTyApp   (AnnCoreExpr binder bindee annot)
-		 UniType
+		 Type
 
   | AnnCoCase    (AnnCoreExpr binder bindee annot)
-		 (AnnCoreCaseAlternatives binder bindee annot)
+		 (AnnCoreCaseAlts binder bindee annot)
 
   | AnnCoLet	 (AnnCoreBinding binder bindee annot)
 		 (AnnCoreExpr binder bindee annot)
 
   | AnnCoSCC	 CostCentre
 		 (AnnCoreExpr binder bindee annot)
-#ifdef DPH
-  | AnnCoZfExpr  (AnnCoreExpr binder bindee annot) 
-	         (AnnCoreParQuals binder bindee annot)
-
-  | AnnCoParCon	 Id Int [UniType] [AnnCoreExpr binder bindee annot]
-
-  | AnnCoParComm
- 		     Int
-		    (AnnCoreExpr binder bindee annot)
-		    (AnnCoreParCommunicate binder bindee annot)
-  | AnnCoParZipWith
-		     Int 
-		     (AnnCoreExpr binder bindee annot)
-		     [AnnCoreExpr binder bindee annot]
-#endif {- Data Parallel Haskell -}
-\end{code}
-
-\begin{code}
-#ifdef DPH
-data AnnCoreParQuals binder bindee annot
-   = AnnCoAndQuals  (AnnCoreParQuals binder bindee annot)
-		    (AnnCoreParQuals binder bindee annot)
-   | AnnCoParFilter (AnnCoreExpr binder bindee annot)
-   | AnnCoDrawnGen  [binder]
-		    (binder)
-		    (AnnCoreExpr binder bindee annot)	
-   | AnnCoIndexGen  [AnnCoreExpr binder bindee annot]
-   		    (binder)
-		    (AnnCoreExpr binder bindee annot)	
-#endif {- Data Parallel Haskell -}
 \end{code}
 
 \begin{code}
-data AnnCoreCaseAlternatives binder bindee annot
+data AnnCoreCaseAlts binder bindee annot
   = AnnCoAlgAlts	[(Id,
 		  	 [binder],
 		  	 AnnCoreExpr binder bindee annot)]
 			(AnnCoreCaseDefault binder bindee annot)
-  | AnnCoPrimAlts	[(BasicLit,
+  | AnnCoPrimAlts	[(Literal,
 			  AnnCoreExpr binder bindee annot)]
 			(AnnCoreCaseDefault binder bindee annot)
-#ifdef DPH
-  | AnnCoParAlgAlts	TyCon	
-		        Int
-			[binder]
-			[(Id,
-		  	 AnnCoreExpr binder bindee annot)]
-			(AnnCoreCaseDefault binder bindee annot)
-  | AnnCoParPrimAlts	TyCon	
-			Int
-			[(BasicLit,
-			  AnnCoreExpr binder bindee annot)]
-			(AnnCoreCaseDefault binder bindee annot)
-#endif {- Data Parallel Haskell -}
 
 data AnnCoreCaseDefault binder bindee annot
   = AnnCoNoDefault
@@ -141,45 +87,35 @@ data AnnCoreCaseDefault binder bindee annot
 \end{code}
 
 \begin{code}
-#ifdef DPH
-data AnnCoreParCommunicate binder bindee annot
-  = AnnCoParSend	[AnnCoreExpr binder bindee annot]     
-  | AnnCoParFetch  	[AnnCoreExpr binder bindee annot]     
-  | AnnCoToPodized
-  | AnnCoFromPodized
-#endif {- Data Parallel Haskell -}
-\end{code}
-
-\begin{code}
-deAnnotate :: AnnCoreExpr bndr bdee ann -> CoreExpr bndr bdee
+deAnnotate :: AnnCoreExpr bndr bdee ann -> GenCoreExpr bndr bdee
 
-deAnnotate (_, AnnCoVar v)            = CoVar v
-deAnnotate (_, AnnCoLit lit)      = CoLit lit
-deAnnotate (_, AnnCoCon	con tys args) = CoCon con tys args
-deAnnotate (_, AnnCoPrim op tys args) = CoPrim op tys args
-deAnnotate (_, AnnCoLam	binders body) = CoLam binders (deAnnotate body)
+deAnnotate (_, AnnCoVar v)            = Var v
+deAnnotate (_, AnnCoLit lit)      = Lit lit
+deAnnotate (_, AnnCoCon	con tys args) = Con con tys args
+deAnnotate (_, AnnCoPrim op tys args) = Prim op tys args
+deAnnotate (_, AnnCoLam	binder body)  = Lam binder (deAnnotate body)
 deAnnotate (_, AnnCoTyLam tyvar body) = CoTyLam tyvar (deAnnotate body)
-deAnnotate (_, AnnCoApp	fun arg)      = CoApp (deAnnotate fun) arg
+deAnnotate (_, AnnCoApp	fun arg)      = App (deAnnotate fun) arg
 deAnnotate (_, AnnCoTyApp fun ty)     = CoTyApp (deAnnotate fun) ty
-deAnnotate (_, AnnCoSCC	lbl body)     = CoSCC lbl (deAnnotate body) 
+deAnnotate (_, AnnCoSCC	lbl body)     = SCC lbl (deAnnotate body)
 
 deAnnotate (_, AnnCoLet	bind body)
-  = CoLet (deAnnBind bind) (deAnnotate body)
+  = Let (deAnnBind bind) (deAnnotate body)
   where
-    deAnnBind (AnnCoNonRec var rhs) = CoNonRec var (deAnnotate rhs)
-    deAnnBind (AnnCoRec pairs) = CoRec [(v,deAnnotate rhs) | (v,rhs) <- pairs]
+    deAnnBind (AnnCoNonRec var rhs) = NonRec var (deAnnotate rhs)
+    deAnnBind (AnnCoRec pairs) = Rec [(v,deAnnotate rhs) | (v,rhs) <- pairs]
 
 deAnnotate (_, AnnCoCase scrut alts)
-  = CoCase (deAnnotate scrut) (deAnnAlts alts)
+  = Case (deAnnotate scrut) (deAnnAlts alts)
   where
-    deAnnAlts (AnnCoAlgAlts alts deflt)  
-      = CoAlgAlts [(con,args,deAnnotate rhs) | (con,args,rhs) <- alts]
+    deAnnAlts (AnnCoAlgAlts alts deflt)
+      = AlgAlts [(con,args,deAnnotate rhs) | (con,args,rhs) <- alts]
 		 (deAnnDeflt deflt)
 
-    deAnnAlts (AnnCoPrimAlts alts deflt) 
-      = CoPrimAlts [(lit,deAnnotate rhs) | (lit,rhs) <- alts]
+    deAnnAlts (AnnCoPrimAlts alts deflt)
+      = PrimAlts [(lit,deAnnotate rhs) | (lit,rhs) <- alts]
 		   (deAnnDeflt deflt)
 
-    deAnnDeflt AnnCoNoDefault 	      = CoNoDefault
-    deAnnDeflt (AnnCoBindDefault var rhs) = CoBindDefault var (deAnnotate rhs)
+    deAnnDeflt AnnCoNoDefault 	      = NoDefault
+    deAnnDeflt (AnnCoBindDefault var rhs) = BindDefault var (deAnnotate rhs)
 \end{code}
diff --git a/ghc/compiler/coreSyn/CoreFuns.hi b/ghc/compiler/coreSyn/CoreFuns.hi
deleted file mode 100644
index 2abb196c65..0000000000
--- a/ghc/compiler/coreSyn/CoreFuns.hi
+++ /dev/null
@@ -1,62 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface CoreFuns where
-import BasicLit(BasicLit)
-import CoreSyn(CoreAtom, CoreBinding, CoreCaseAlternatives, CoreExpr)
-import CostCentre(CostCentre)
-import Id(Id)
-import IdEnv(IdEnv(..))
-import Maybes(Labda)
-import PrimOps(PrimOp)
-import TyVar(TyVar)
-import TyVarEnv(TyVarEnv(..))
-import UniType(UniType)
-import UniqFM(UniqFM)
-import Unique(UniqSM(..), Unique, UniqueSupply)
-data CoreAtom a 
-data CoreExpr a b 
-data Id 
-type IdEnv a = UniqFM a
-data Labda a 
-type TyVarEnv a = UniqFM a
-data UniType 
-data UniqFM a 
-type UniqSM a = UniqueSupply -> (UniqueSupply, a)
-data Unique 
-data UniqueSupply 
-atomToExpr :: CoreAtom b -> CoreExpr a b
-bindersOf :: CoreBinding b a -> [b]
-coreExprArity :: (Id -> Labda (CoreExpr a Id)) -> CoreExpr a Id -> Int
-digForLambdas :: CoreExpr a b -> ([TyVar], [a], CoreExpr a b)
-escErrorMsg :: [Char] -> [Char]
-exprSmallEnoughToDup :: CoreExpr a Id -> Bool
-instCoreBindings :: UniqueSupply -> [CoreBinding Id Id] -> (UniqueSupply, [CoreBinding Id Id])
-instCoreExpr :: UniqueSupply -> CoreExpr Id Id -> (UniqueSupply, CoreExpr Id Id)
-isWrapperFor :: CoreExpr Id Id -> Id -> Bool
-manifestlyBottom :: CoreExpr a Id -> Bool
-manifestlyWHNF :: CoreExpr a Id -> Bool
-maybeErrorApp :: CoreExpr a Id -> Labda UniType -> Labda (CoreExpr a Id)
-mkCoApps :: CoreExpr Id Id -> [CoreExpr Id Id] -> UniqueSupply -> (UniqueSupply, CoreExpr Id Id)
-mkCoLam :: [a] -> CoreExpr a b -> CoreExpr a b
-mkCoLetAny :: CoreBinding Id Id -> CoreExpr Id Id -> CoreExpr Id Id
-mkCoLetNoUnboxed :: CoreBinding Id Id -> CoreExpr Id Id -> CoreExpr Id Id
-mkCoLetUnboxedToCase :: CoreBinding Id Id -> CoreExpr Id Id -> CoreExpr Id Id
-mkCoLetrecAny :: [(Id, CoreExpr Id Id)] -> CoreExpr Id Id -> CoreExpr Id Id
-mkCoLetrecNoUnboxed :: [(Id, CoreExpr Id Id)] -> CoreExpr Id Id -> CoreExpr Id Id
-mkCoLetsAny :: [CoreBinding Id Id] -> CoreExpr Id Id -> CoreExpr Id Id
-mkCoLetsNoUnboxed :: [CoreBinding Id Id] -> CoreExpr Id Id -> CoreExpr Id Id
-mkCoLetsUnboxedToCase :: [CoreBinding Id Id] -> CoreExpr Id Id -> CoreExpr Id Id
-mkCoTyApps :: CoreExpr a b -> [UniType] -> CoreExpr a b
-mkCoTyLam :: [TyVar] -> CoreExpr a b -> CoreExpr a b
-mkCoreIfThenElse :: CoreExpr a Id -> CoreExpr a Id -> CoreExpr a Id -> CoreExpr a Id
-mkErrorCoApp :: UniType -> Id -> [Char] -> CoreExpr Id Id
-mkFunction :: [TyVar] -> [a] -> CoreExpr a b -> CoreExpr a b
-nonErrorRHSs :: CoreCaseAlternatives a Id -> [CoreExpr a Id]
-pairsFromCoreBinds :: [CoreBinding a b] -> [(a, CoreExpr a b)]
-squashableDictishCcExpr :: CostCentre -> CoreExpr a b -> Bool
-substCoreExpr :: UniqueSupply -> UniqFM (CoreExpr Id Id) -> UniqFM UniType -> CoreExpr Id Id -> (UniqueSupply, CoreExpr Id Id)
-substCoreExprUS :: UniqFM (CoreExpr Id Id) -> UniqFM UniType -> CoreExpr Id Id -> UniqueSupply -> (UniqueSupply, CoreExpr Id Id)
-typeOfCoreAlts :: CoreCaseAlternatives Id Id -> UniType
-typeOfCoreExpr :: CoreExpr Id Id -> UniType
-unTagBinders :: CoreExpr (Id, a) b -> CoreExpr Id b
-unTagBindersAlts :: CoreCaseAlternatives (Id, a) b -> CoreCaseAlternatives Id b
-
diff --git a/ghc/compiler/coreSyn/CoreFuns.lhs b/ghc/compiler/coreSyn/CoreFuns.lhs
deleted file mode 100644
index 9fcd186758..0000000000
--- a/ghc/compiler/coreSyn/CoreFuns.lhs
+++ /dev/null
@@ -1,1309 +0,0 @@
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
-%
-\section[CoreUtils]{Utility functions}
-
-These functions are re-exported by the various parameterisations of
-@CoreSyn@.
-
-\begin{code}
-#include "HsVersions.h"
-
-module CoreFuns (
-	typeOfCoreExpr, typeOfCoreAlts,
-
-	instCoreExpr,   substCoreExpr,   -- UNUSED: cloneCoreExpr,
-	substCoreExprUS, -- UNUSED: instCoreExprUS, cloneCoreExprUS,
-
-	instCoreBindings,
-
-	bindersOf,
-
-	mkCoLetAny, mkCoLetNoUnboxed, mkCoLetUnboxedToCase,
-	mkCoLetsAny, mkCoLetsNoUnboxed, mkCoLetsUnboxedToCase,
-	mkCoLetrecAny, mkCoLetrecNoUnboxed,
-	mkCoLam, mkCoreIfThenElse,
---	mkCoApp, mkCoCon, mkCoPrim, -- no need to export
-	mkCoApps,
-	mkCoTyLam, mkCoTyApps,
-	mkErrorCoApp, escErrorMsg,
-	pairsFromCoreBinds,
-	mkFunction, atomToExpr,
-	digForLambdas,
-	exprSmallEnoughToDup,
-	manifestlyWHNF, manifestlyBottom, --UNUSED: manifestWHNFArgs,
-	coreExprArity,
-	isWrapperFor,
-	maybeErrorApp,
---UNUSED: boilsDownToConApp,
-	nonErrorRHSs,
-	squashableDictishCcExpr,
-
-	unTagBinders, unTagBindersAlts,
-
-#ifdef DPH
-	mkNonRecBinds,
-	isParCoreCaseAlternative,
-#endif {- Data Parallel Haskell -}
-
-	-- to make the interface self-sufficient...
-	CoreAtom, CoreExpr, Id, UniType, UniqueSupply, UniqSM(..),
-	IdEnv(..), UniqFM, Unique, TyVarEnv(..), Maybe
-    ) where
-
---IMPORT_Trace		-- ToDo: debugging only
-import Pretty
-
-import AbsPrel		( mkFunTy, trueDataCon, falseDataCon,
-			  eRROR_ID, pAT_ERROR_ID, aBSENT_ERROR_ID,
-			  buildId, augmentId,
-			  boolTyCon, fragilePrimOp,
-			  PrimOp(..), typeOfPrimOp,
-			  PrimKind
-			  IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
-			  IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
-#ifdef DPH
-			  , mkPodTy, mkPodizedPodNTy
-#endif {- Data Parallel Haskell -}
-			)
-import AbsUniType
-import BasicLit		( isNoRepLit, typeOfBasicLit, BasicLit(..)
-			  IF_ATTACK_PRAGMAS(COMMA isLitLitLit)
-			)
-import CostCentre	( isDictCC, CostCentre )
-import Id
-import IdEnv
-import IdInfo
-import Maybes		( catMaybes, maybeToBool, Maybe(..) )
-import Outputable
-import CoreSyn
-import PlainCore	-- the main stuff we're defining functions for
-import SrcLoc		( SrcLoc, mkUnknownSrcLoc )
-#ifdef DPH
-import TyCon 		( getPodizedPodDimension )
-#endif {- Data Parallel Haskell -}
-import TyVarEnv
-import SplitUniq
-import Unique		-- UniqueSupply monadery used here
-import Util
-\end{code}
-
-%************************************************************************
-%*									*
-\subsection[bindersOf]{Small but useful}
-%*									*
-%************************************************************************
-
-
-\begin{code}
-bindersOf :: CoreBinding bder bdee -> [bder]
-bindersOf (CoNonRec binder _) = [binder]
-bindersOf (CoRec pairs)       = [binder | (binder,_) <- pairs]
-\end{code}
-
-
-%************************************************************************
-%*									*
-\subsection[typeOfCore]{Find the type of a Core atom/expression}
-%*									*
-%************************************************************************
-
-\begin{code}
-typeOfCoreExpr :: PlainCoreExpr -> UniType
-typeOfCoreExpr (CoVar var)		= getIdUniType var
-typeOfCoreExpr (CoLit lit)		= typeOfBasicLit lit
-typeOfCoreExpr (CoLet binds body)	= typeOfCoreExpr body
-typeOfCoreExpr (CoSCC label expr)	= typeOfCoreExpr expr
-
--- a CoCon is a fully-saturated application of a data constructor
-typeOfCoreExpr (CoCon con tys _)
-  = applyTyCon (getDataConTyCon con) tys
-
--- and, analogously, ...
-typeOfCoreExpr expr@(CoPrim op tys args)
-  -- Note: CoPrims may be polymorphic, so we do de-forall'ing.
-  = let
-	op_ty	  = typeOfPrimOp op
-	op_tau_ty = foldl applyTy op_ty tys
-    in
-    funResultTy op_tau_ty (length args)
-
-typeOfCoreExpr (CoCase _ alts)	= typeOfCoreAlts alts
-  -- Q: What if the one you happen to grab is an "error"?
-  -- A: NO problem.  The type application of error to its type will give you
-  -- 	the answer.
-
-typeOfCoreExpr (CoLam binders expr)
-  = foldr (mkFunTy . getIdUniType) (typeOfCoreExpr expr) binders
-
-typeOfCoreExpr (CoTyLam tyvar expr)
-  = case (quantifyTy [tyvar] (typeOfCoreExpr expr)) of
-      (_, ty) -> ty	-- not worried about the TyVarTemplates that come back
-
-typeOfCoreExpr expr@(CoApp _ _)   = typeOfCoreApp expr
-typeOfCoreExpr expr@(CoTyApp _ _) = typeOfCoreApp expr
-
-#ifdef DPH
-typeOfCoreExpr (CoParCon con ctxt tys args)
-  = mkPodizedPodNTy ctxt (applyTyCon (getDataConTyCon con) tys)
-
-typeOfCoreExpr (CoZfExpr expr quals)
-  = mkPodTy (typeOfCoreExpr expr)
-
-typeOfCoreExpr (CoParComm _ expr _)
-  = typeOfCoreExpr expr
-#endif {- Data Parallel Haskell -}
-\end{code}
-
-\begin{code}
-typeOfCoreApp application
-  = case (collectArgs application) of { (fun, args) ->
-    apply_args (typeOfCoreExpr fun) args
-    }
-  where
-    apply_args expr_ty [] = expr_ty
-
-    apply_args fun_ty (TypeArg ty_arg : args)
-      = apply_args (applyTy fun_ty ty_arg) args
-
-    apply_args fun_ty (ValArg val_arg : args)
-      = case (maybeUnpackFunTy fun_ty) of
-	  Just (_, result_ty) -> apply_args result_ty args
-
-	  Nothing -> pprPanic "typeOfCoreApp:\n" 
-		(ppAboves
-			[ppr PprDebug val_arg,
-			 ppr PprDebug fun_ty,
-			 ppr PprShowAll application])
-\end{code}
-
-\begin{code}
-typeOfCoreAlts :: PlainCoreCaseAlternatives -> UniType
-typeOfCoreAlts (CoAlgAlts [] deflt)         = typeOfDefault deflt
-typeOfCoreAlts (CoAlgAlts ((_,_,rhs1):_) _) = typeOfCoreExpr rhs1
-
-typeOfCoreAlts (CoPrimAlts [] deflt)       = typeOfDefault deflt
-typeOfCoreAlts (CoPrimAlts ((_,rhs1):_) _) = typeOfCoreExpr rhs1
-#ifdef DPH
-typeOfCoreAlts (CoParAlgAlts _ _ _ [] deflt)       = typeOfDefault deflt
-typeOfCoreAlts (CoParAlgAlts _ _ _ ((_,rhs1):_) _) = typeOfCoreExpr rhs1
-
-typeOfCoreAlts (CoParPrimAlts _ _ [] deflt)       = typeOfDefault deflt
-typeOfCoreAlts (CoParPrimAlts _ _ ((_,rhs1):_) _) = typeOfCoreExpr rhs1
-#endif {- Data Parallel Haskell -}
-
-typeOfDefault CoNoDefault           = panic "typeOfCoreExpr:CoCase:typeOfDefault"
-typeOfDefault (CoBindDefault _ rhs) = typeOfCoreExpr rhs
-\end{code}
-
-%************************************************************************
-%*									*
-\subsection[CoreFuns-instantiate]{Instantiating core expressions: interfaces}
-%*									*
-%************************************************************************
-
-These subst/inst functions {\em must not} use splittable
-UniqueSupplies! (yet)
-
-All of the desired functions are done by one piece of code, which
-carries around a little (monadised) state (a @UniqueSupply@).
-Meanwhile, here is what the outside world sees (NB: @UniqueSupply@
-passed in and out):
-\begin{code}
-{- UNUSED:
-cloneCoreExpr	:: UniqueSupply
-		-> PlainCoreExpr -- template
-		-> (UniqueSupply, PlainCoreExpr)
-
-cloneCoreExpr us expr = instCoreExpr us expr
--}
-
---------------------
-
-instCoreExpr	:: UniqueSupply
-		-> PlainCoreExpr
-		-> (UniqueSupply, PlainCoreExpr)
-
-instCoreExpr us expr
-  = initUs us (do_CoreExpr nullIdEnv nullTyVarEnv expr)
-
-instCoreBindings :: UniqueSupply
-		 -> [PlainCoreBinding]
-		 -> (UniqueSupply, [PlainCoreBinding])
-
-instCoreBindings us binds
-  = initUs us (do_CoreBindings nullIdEnv nullTyVarEnv binds)
-
---------------------
-
-substCoreExpr	:: UniqueSupply
-		-> ValEnv
-		-> TypeEnv  -- TyVar=>UniType
-		-> PlainCoreExpr
-		-> (UniqueSupply, PlainCoreExpr)
-
-substCoreExpr us venv tenv expr
-  = initUs us (substCoreExprUS venv tenv expr)
-
--- we are often already in a UniqSM world, so here are the interfaces
--- for that:
-{- UNUSED:
-cloneCoreExprUS	:: PlainCoreExpr{-template-} -> UniqSM PlainCoreExpr
-
-cloneCoreExprUS = instCoreExprUS
-
-instCoreExprUS	:: PlainCoreExpr -> UniqSM PlainCoreExpr
-
-instCoreExprUS expr = do_CoreExpr nullIdEnv nullTyVarEnv expr
--}
-
---------------------
-
-substCoreExprUS	:: ValEnv
-		-> TypeEnv -- TyVar=>UniType
-		-> PlainCoreExpr
-		-> UniqSM PlainCoreExpr
-
-substCoreExprUS venv tenv expr
-  -- if the envs are empty, then avoid doing anything
-  = if (isNullIdEnv venv && isNullTyVarEnv tenv) then
-       returnUs expr
-    else
-       do_CoreExpr venv tenv expr
-\end{code}
-
-%************************************************************************
-%*									*
-\subsection[CoreFuns-inst-exprs]{Actual expression-instantiating code}
-%*									*
-%************************************************************************
-
-The equiv code for @UniTypes@ is in @UniTyFuns@.
-
-Because binders aren't necessarily unique: we don't do @plusEnvs@
-(which check for duplicates); rather, we use the shadowing version,
-@growIdEnv@ (and shorthand @addOneToIdEnv@).
-
-\begin{code}
-type ValEnv  = IdEnv PlainCoreExpr
-
-do_CoreBinding :: ValEnv
-	       -> TypeEnv
-	       -> PlainCoreBinding
-	       -> UniqSM (PlainCoreBinding, ValEnv)
-
-do_CoreBinding venv tenv (CoNonRec binder rhs)
-  = do_CoreExpr venv tenv rhs	`thenUs` \ new_rhs ->
-
-    dup_binder tenv binder	`thenUs` \ (new_binder, (old, new)) ->
-    -- now plug new bindings into envs
-    let  new_venv = addOneToIdEnv venv old new  in
-
-    returnUs (CoNonRec new_binder new_rhs, new_venv)
-
-do_CoreBinding venv tenv (CoRec binds)
-  = -- for letrec, we plug in new bindings BEFORE cloning rhss
-    mapAndUnzipUs (dup_binder tenv) binders `thenUs` \ (new_binders, new_maps) ->
-    let  new_venv = growIdEnvList venv new_maps in
-
-    mapUs (do_CoreExpr new_venv tenv) rhss `thenUs` \ new_rhss ->
-    returnUs (CoRec (new_binders `zip` new_rhss), new_venv)
-  where
-    binders	= map fst binds
-    rhss	= map snd binds
-\end{code}
-
-@do_CoreBindings@ takes into account the semantics of a list of
-@CoreBindings@---things defined early in the list are visible later in
-the list, but not vice versa.
-
-\begin{code}
-do_CoreBindings :: ValEnv
-	        -> TypeEnv
-	        -> [PlainCoreBinding]
-	        -> UniqSM [PlainCoreBinding]
-
-do_CoreBindings venv tenv [] = returnUs []
-do_CoreBindings venv tenv (b:bs)
-  = do_CoreBinding  venv     tenv b	`thenUs` \ (new_b,  new_venv) ->
-    do_CoreBindings new_venv tenv bs	`thenUs` \  new_bs ->
-    returnUs (new_b : new_bs)
-\end{code}
-
-\begin{code}
-do_CoreAtom :: ValEnv
-	    -> TypeEnv
-	    -> PlainCoreAtom
-	    -> UniqSM PlainCoreExpr
-
-do_CoreAtom venv tenv a@(CoLitAtom lit)   = returnUs (CoLit lit)
-
-do_CoreAtom venv tenv orig_a@(CoVarAtom v)
-  = returnUs (
-      case (lookupIdEnv venv v) of
-        Nothing   -> --false:ASSERT(toplevelishId v)
-		     CoVar v
-        Just expr -> expr
-    )
-\end{code}
-
-\begin{code}
-do_CoreExpr :: ValEnv
-	    -> TypeEnv
-	    -> PlainCoreExpr
-	    -> UniqSM PlainCoreExpr
-
-do_CoreExpr venv tenv orig_expr@(CoVar var)
-  = returnUs (
-      case (lookupIdEnv venv var) of
-	Nothing	    -> --false:ASSERT(toplevelishId var) (SIGH)
-		       orig_expr
-	Just expr   -> expr
-    )
-
-do_CoreExpr venv tenv e@(CoLit _) = returnUs e
-
-do_CoreExpr venv tenv (CoCon  con ts as)
-  = let
-	new_ts = map (applyTypeEnvToTy tenv) ts
-    in
-    mapUs  (do_CoreAtom venv tenv) as `thenUs`  \ new_as ->
-    mkCoCon con new_ts new_as
-
-do_CoreExpr venv tenv (CoPrim op tys as)
-  = let
-	new_tys = map (applyTypeEnvToTy tenv) tys
-    in
-    mapUs  (do_CoreAtom venv tenv) as 	`thenUs`  \ new_as ->
-    do_PrimOp op			`thenUs`  \ new_op ->
-    mkCoPrim new_op new_tys new_as
-  where
-    do_PrimOp (CCallOp label is_asm may_gc arg_tys result_ty)
-      = let
-	    new_arg_tys   = map (applyTypeEnvToTy tenv) arg_tys
-	    new_result_ty = applyTypeEnvToTy tenv result_ty
-	in
-	returnUs (CCallOp label is_asm may_gc new_arg_tys new_result_ty)
-
-    do_PrimOp other_op = returnUs other_op
-
-do_CoreExpr venv tenv (CoLam binders expr)
-  = mapAndUnzipUs (dup_binder tenv) binders `thenUs` \ (new_binders, new_maps) ->
-    let  new_venv = growIdEnvList venv new_maps  in
-    do_CoreExpr new_venv tenv expr  `thenUs` \ new_expr ->
-    returnUs (CoLam new_binders new_expr)
-
-do_CoreExpr venv tenv (CoTyLam tyvar expr)
-  = dup_tyvar tyvar		    `thenUs` \ (new_tyvar, (old, new)) ->
-    let
-	new_tenv = addOneToTyVarEnv tenv old new
-    in
-    do_CoreExpr venv new_tenv expr  `thenUs` \ new_expr ->
-    returnUs (CoTyLam new_tyvar new_expr)
-
-do_CoreExpr venv tenv (CoApp expr atom)
-  = do_CoreExpr venv tenv expr	`thenUs` \ new_expr ->
-    do_CoreAtom venv tenv atom  `thenUs` \ new_atom ->
-    mkCoApp new_expr new_atom
-
-do_CoreExpr venv tenv (CoTyApp expr ty)
-  = do_CoreExpr venv tenv expr	    `thenUs`  \ new_expr ->
-    let
-	new_ty = applyTypeEnvToTy tenv ty
-    in
-    returnUs (CoTyApp new_expr new_ty)
-
-do_CoreExpr venv tenv (CoCase expr alts)
-  = do_CoreExpr venv tenv expr	    `thenUs` \ new_expr ->
-    do_alts venv tenv alts	    `thenUs` \ new_alts ->
-    returnUs (CoCase new_expr new_alts)
-  where
-    do_alts venv tenv (CoAlgAlts alts deflt)
-      = mapUs (do_boxed_alt venv tenv) alts `thenUs` \ new_alts ->
-    	do_default venv tenv deflt	    `thenUs` \ new_deflt ->
-	returnUs (CoAlgAlts new_alts new_deflt)
-      where
-	do_boxed_alt venv tenv (con, binders, expr)
-	  = mapAndUnzipUs (dup_binder tenv) binders `thenUs` \ (new_binders, new_vmaps) ->
-	    let  new_venv = growIdEnvList venv new_vmaps  in
-	    do_CoreExpr new_venv tenv expr  `thenUs` \ new_expr ->
-	    returnUs (con, new_binders, new_expr)
-
-
-    do_alts venv tenv (CoPrimAlts alts deflt)
-      = mapUs (do_unboxed_alt venv tenv) alts `thenUs` \ new_alts ->
-    	do_default venv tenv deflt	      `thenUs` \ new_deflt ->
-	returnUs (CoPrimAlts new_alts new_deflt)
-      where
-	do_unboxed_alt venv tenv (lit, expr)
-	  = do_CoreExpr venv tenv expr	`thenUs` \ new_expr ->
-	    returnUs (lit, new_expr)
-#ifdef DPH
-    do_alts venv tenv (CoParAlgAlts tycon dim params alts deflt)
-      = mapAndUnzipUs (dup_binder tenv) params `thenUs` \ (new_params,new_vmaps) ->
-	let  new_venv = growIdEnvList venv new_vmaps  in
-	mapUs (do_boxed_alt new_venv tenv) alts
-					 `thenUs` \ new_alts ->
-    	do_default venv tenv deflt	 `thenUs` \ new_deflt ->
-	returnUs (CoParAlgAlts tycon dim new_params new_alts new_deflt)
-      where
-	do_boxed_alt venv tenv (con, expr)
-	  = do_CoreExpr venv tenv expr  `thenUs` \ new_expr ->
-	    returnUs (con,  new_expr)
-
-    do_alts venv tenv (CoParPrimAlts tycon dim alts deflt)
-      = mapUs (do_unboxed_alt venv tenv) alts `thenUs` \ new_alts ->
-    	do_default venv tenv deflt	      `thenUs` \ new_deflt ->
-	returnUs (CoParPrimAlts tycon dim new_alts new_deflt)
-      where
-	do_unboxed_alt venv tenv (lit, expr)
-	  = do_CoreExpr venv tenv expr	`thenUs` \ new_expr ->
-	    returnUs (lit, new_expr)
-#endif {- Data Parallel Haskell -}
-
-    do_default venv tenv CoNoDefault = returnUs CoNoDefault
-
-    do_default venv tenv (CoBindDefault binder expr)
-      =	dup_binder tenv binder		`thenUs` \ (new_binder, (old, new)) ->
-	let  new_venv = addOneToIdEnv venv old new  in
-        do_CoreExpr new_venv tenv expr	`thenUs` \ new_expr ->
-	returnUs (CoBindDefault new_binder new_expr)
-
-do_CoreExpr venv tenv (CoLet core_bind expr)
-  = do_CoreBinding venv tenv core_bind	`thenUs` \ (new_bind, new_venv) ->
-    -- and do the body of the let
-    do_CoreExpr new_venv tenv expr  	`thenUs` \ new_expr ->
-    returnUs (CoLet new_bind new_expr)
-
-do_CoreExpr venv tenv (CoSCC label expr)
-  = do_CoreExpr venv tenv expr	    	`thenUs` \ new_expr ->
-    returnUs (CoSCC label new_expr)
-
-#ifdef DPH
-do_CoreExpr venv tenv (CoParCon  con ctxt ts es)
-  = let
-	new_ts = map (applyTypeEnvToTy tenv) ts
-    in
-    mapUs  (do_CoreExpr venv tenv) es) `thenUs`  \ new_es ->
-    returnUs (CoParCon con ctxt new_ts new_es)
-
-do_CoreExpr venv tenv (CoZfExpr expr quals)
-  = do_CoreParQuals  venv  tenv quals	`thenUs` \ (quals',venv') ->
-    do_CoreExpr      venv' tenv expr	`thenUs` \ expr'  ->
-    returnUs (CoZfExpr expr' quals')
-
-do_CoreExpr venv tenv (CoParComm dim expr comm)
-  = do_CoreExpr venv tenv expr		`thenUs` \ expr' ->
-    do_ParComm  comm			`thenUs` \ comm' ->
-    returnUs (CoParComm dim expr' comm')
-  where
-     do_ParComm (CoParSend exprs)
-       = mapUs (do_CoreExpr venv tenv) exprs `thenUs` \ exprs' ->
-         returnUs (CoParSend exprs')
-     do_ParComm (CoParFetch exprs)
-       = mapUs (do_CoreExpr venv tenv) exprs `thenUs` \ exprs' ->
-         returnUs (CoParFetch exprs')
-     do_ParComm (CoToPodized)
-       = returnUs (CoToPodized)
-     do_ParComm (CoFromPodized)
-       = returnUs (CoFromPodized)
-#endif {- Data Parallel Haskell -}
-\end{code}
-
-\begin{code}
-#ifdef DPH
-do_CoreParQuals :: ValEnv
-	    -> TypeEnv
-	    -> PlainCoreParQuals
-	    -> UniqSM (PlainCoreParQuals, ValEnv)
-
-do_CoreParQuals venv tenv (CoAndQuals l r) 
-   = do_CoreParQuals venv       tenv r	`thenUs` \ (r',right_venv) ->
-     do_CoreParQuals right_venv tenv l	`thenUs` \ (l',left_env) ->
-     returnUs (CoAndQuals l' r',left_env)
-
-do_CoreParQuals venv tenv (CoParFilter expr)
-   = do_CoreExpr venv tenv expr		`thenUs` \ expr' ->
-     returnUs (CoParFilter expr',venv))
-
-do_CoreParQuals venv tenv (CoDrawnGen binders binder expr) 
-   = mapAndUnzipUs (dup_binder tenv) binders `thenUs` 	\ (newBs,newMs) ->
-     let  new_venv = growIdEnvList venv newMs  in
-     dup_binder tenv binder		`thenUs` 	\ (newB,(old,new)) ->
-     let  new_venv' = addOneToIdEnv new_venv old new in
-     do_CoreExpr new_venv' tenv expr	`thenUs`	\ new_expr ->
-     returnUs (CoDrawnGen newBs newB new_expr,new_venv')
-
-do_CoreParQuals venv tenv (CoIndexGen exprs binder expr) 
-   = mapUs (do_CoreExpr venv tenv) exprs `thenUs`	\ new_exprs ->
-     dup_binder tenv binder		 `thenUs` 	\ (newB,(old,new)) ->
-     let  new_venv = addOneToIdEnv venv old new  in
-     do_CoreExpr new_venv tenv expr	`thenUs`	\ new_expr ->
-     returnUs (CoIndexGen new_exprs newB new_expr,new_venv)
-#endif {- Data Parallel Haskell -}
-\end{code}
-
-\begin{code}
-dup_tyvar :: TyVar -> UniqSM (TyVar, (TyVar, UniType))
-dup_tyvar tyvar
-  = getUnique			`thenUs` \ uniq ->
-    let  new_tyvar = cloneTyVar tyvar uniq  in
-    returnUs (new_tyvar, (tyvar, mkTyVarTy new_tyvar))
-
--- same thing all over again --------------------
-
-dup_binder :: TypeEnv -> Id -> UniqSM (Id, (Id, PlainCoreExpr))
-dup_binder tenv b
-  = if (toplevelishId b) then
-	-- binder is "top-level-ish"; -- it should *NOT* be renamed
-	-- ToDo: it's unsavoury that we return something to heave in env
-	returnUs (b, (b, CoVar b))
-
-    else -- otherwise, the full business
-	getUnique			    `thenUs`  \ uniq ->
-	let
-	    new_b1 = mkIdWithNewUniq b uniq
-	    new_b2 = applyTypeEnvToId tenv new_b1
-	in
-	returnUs (new_b2, (b, CoVar new_b2))
-\end{code}
-
-%************************************************************************
-%*									*
-\subsection[mk_CoreExpr_bits]{Routines to manufacture bits of @CoreExpr@}
-%*									*
-%************************************************************************
-
-When making @CoLets@, we may want to take evasive action if the thing
-being bound has unboxed type. We have different variants ...
-
-@mkCoLet(s|rec)Any@ 		let-binds any binding, regardless of type
-@mkCoLet(s|rec)NoUnboxed@ 	prohibits unboxed bindings
-@mkCoLet(s)UnboxedToCase@ 	converts an unboxed binding to a case
-				(unboxed bindings in a letrec are still prohibited)
-
-\begin{code}
-mkCoLetAny :: PlainCoreBinding -> PlainCoreExpr -> PlainCoreExpr
-
-mkCoLetAny bind@(CoRec binds) body
-  = mkCoLetrecAny binds body
-mkCoLetAny bind@(CoNonRec binder rhs) body
-  = case body of
-      CoVar binder2 | binder `eqId` binder2
-	 -> rhs   -- hey, I have the rhs
-      other
-	 -> CoLet bind body
-
-mkCoLetsAny []    expr = expr
-mkCoLetsAny binds expr = foldr mkCoLetAny expr binds
-
-mkCoLetrecAny :: [(Id, PlainCoreExpr)]	-- bindings
-  	      -> PlainCoreExpr		-- body
-	      -> PlainCoreExpr 		-- result
-
-mkCoLetrecAny []    body = body
-mkCoLetrecAny binds body
-  = CoLet (CoRec binds) body
-\end{code}
-
-\begin{code}
-mkCoLetNoUnboxed :: PlainCoreBinding -> PlainCoreExpr -> PlainCoreExpr
-
-mkCoLetNoUnboxed bind@(CoRec binds) body
-  = mkCoLetrecNoUnboxed binds body
-mkCoLetNoUnboxed bind@(CoNonRec binder rhs) body
-  = ASSERT (not (isUnboxedDataType (getIdUniType binder)))
-    case body of
-      CoVar binder2 | binder `eqId` binder2
-	 -> rhs   -- hey, I have the rhs
-      other
-	 -> CoLet bind body
-
-mkCoLetsNoUnboxed []    expr = expr
-mkCoLetsNoUnboxed binds expr = foldr mkCoLetNoUnboxed expr binds
-
-mkCoLetrecNoUnboxed :: [(Id, PlainCoreExpr)]	-- bindings
-  	            -> PlainCoreExpr		-- body
-	            -> PlainCoreExpr 		-- result
-
-mkCoLetrecNoUnboxed []    body = body
-mkCoLetrecNoUnboxed binds body
-  = ASSERT (all is_boxed_bind binds)
-    CoLet (CoRec binds) body
-  where
-    is_boxed_bind (binder, rhs)
-      = (not . isUnboxedDataType . getIdUniType) binder
-\end{code}
-
-\begin{code}
-mkCoLetUnboxedToCase :: PlainCoreBinding -> PlainCoreExpr -> PlainCoreExpr
-
-mkCoLetUnboxedToCase bind@(CoRec binds) body
-  = mkCoLetrecNoUnboxed binds body
-mkCoLetUnboxedToCase bind@(CoNonRec binder rhs) body
-  = case body of
-      CoVar binder2 | binder `eqId` binder2
-	 -> rhs   -- hey, I have the rhs
-      other
-	 -> if (not (isUnboxedDataType (getIdUniType binder))) then
-		CoLet bind body		 -- boxed...
-	    else
-#ifdef DPH
-		let  (tycon,_,_) = getUniDataTyCon (getIdUniType binder) in
-		if isPodizedPodTyCon tycon
-		then CoCase rhs
-		       (CoParPrimAlts tycon (getPodizedPodDimension tycon) []
-		          (CoBindDefault binder body))
-	        else
-#endif {- DPH -}
-		CoCase rhs		  -- unboxed...
-	    	  (CoPrimAlts []
-		    (CoBindDefault binder body))
-
-mkCoLetsUnboxedToCase []    expr = expr
-mkCoLetsUnboxedToCase binds expr = foldr mkCoLetUnboxedToCase expr binds
-\end{code}
-
-Clump CoLams together if possible; friendlier to the code generator.
-
-\begin{code}
-mkCoLam :: [binder] -> CoreExpr binder bindee -> CoreExpr binder bindee
-mkCoLam []      body = body
-mkCoLam binders body
-  = case (digForLambdas body) of { (tyvars, body_binders, body_expr) ->
-    if not (null tyvars) then
-	pprTrace "Inner /\\'s:" (ppr PprDebug tyvars)
-	  (CoLam binders (mkCoTyLam tyvars (mkCoLam body_binders body_expr)))
-    else
-	CoLam (binders ++ body_binders) body_expr
-    }
-
-mkCoTyLam :: [TyVar] -> CoreExpr binder bindee -> CoreExpr binder bindee
-mkCoTyLam tvs body = foldr CoTyLam body tvs
-
-mkCoTyApps :: CoreExpr binder bindee -> [UniType] -> CoreExpr binder bindee
-mkCoTyApps expr tys = foldl mkCoTyApp expr tys
-\end{code}
-
-\begin{code}
-mkCoreIfThenElse (CoVar bool) then_expr else_expr
-    | bool `eqId` trueDataCon	= then_expr
-    | bool `eqId` falseDataCon	= else_expr
-
-mkCoreIfThenElse guard then_expr else_expr
-  = CoCase guard
-      (CoAlgAlts [ (trueDataCon,  [], then_expr),
-		   (falseDataCon, [], else_expr) ]
-		 CoNoDefault )
-\end{code}
-
-\begin{code}
-mkErrorCoApp :: UniType -> Id -> String -> PlainCoreExpr
-
-mkErrorCoApp ty str_var error_msg
---OLD:  | not (isPrimType ty)
-  = CoLet (CoNonRec str_var (CoLit (NoRepStr (_PK_ error_msg)))) (
-    CoApp (CoTyApp (CoVar pAT_ERROR_ID) ty) (CoVarAtom str_var))
-{- TOO PARANOID: removed 95/02 WDP
-  | otherwise
-    -- for now, force the user to write their own suitably-typed error msg
-  = error (ppShow 80 (ppAboves [
-	ppStr "ERROR: can't generate a pattern-matching error message",
-	ppStr " when a primitive type is involved.",
-	ppCat [ppStr "Type:", ppr PprDebug ty],
-	ppCat [ppStr "Var :", ppr PprDebug str_var],
-	ppCat [ppStr "Msg :", ppStr error_msg]
-    ]))
--}
-
-escErrorMsg [] = []
-escErrorMsg ('%':xs) = '%' : '%' : escErrorMsg xs
-escErrorMsg (x:xs)   = x : escErrorMsg xs
-\end{code}
-
-For making @CoApps@ and @CoLets@, we must take appropriate evasive
-action if the thing being bound has unboxed type.  @mkCoApp@ requires
-a name supply to do its work.  Other-monad code will call @mkCoApp@
-through its own interface function (e.g., the desugarer uses
-@mkCoAppDs@).
-
-@mkCoApp@, @mkCoCon@ and @mkCoPrim@ also handle the
-arguments-must-be-atoms constraint.
-
-\begin{code}
-mkCoApp :: PlainCoreExpr -> PlainCoreExpr -> UniqSM PlainCoreExpr
-
-mkCoApp e1 (CoVar v) = returnUs (CoApp e1 (CoVarAtom v))
-mkCoApp e1 (CoLit l) = returnUs (CoApp e1 (CoLitAtom l))
-mkCoApp e1 e2
-  = let
-	e2_ty = typeOfCoreExpr e2
-    in
-    getUnique	`thenUs` \ uniq ->
-    let
-	new_var = mkSysLocal SLIT("a") uniq e2_ty mkUnknownSrcLoc
-    in
-    returnUs (
-    	mkCoLetUnboxedToCase (CoNonRec new_var e2)
-		             (CoApp e1 (CoVarAtom new_var))
-    )
-\end{code}
-
-\begin{code}
-mkCoCon  :: Id     -> [UniType] -> [PlainCoreExpr] -> UniqSM PlainCoreExpr
-mkCoPrim :: PrimOp -> [UniType] -> [PlainCoreExpr] -> UniqSM PlainCoreExpr
-
-mkCoCon con tys args = mkCoThing (CoCon con) tys args
-mkCoPrim op tys args = mkCoThing (CoPrim op) tys args
-
-mkCoThing thing tys args
-  = mapAndUnzipUs expr_to_atom args `thenUs` \ (atoms, maybe_binds) ->
-    returnUs (mkCoLetsUnboxedToCase (catMaybes maybe_binds) (thing tys atoms))
-  where
-    expr_to_atom :: PlainCoreExpr
-	       -> UniqSM (PlainCoreAtom, Maybe PlainCoreBinding)
-
-    expr_to_atom (CoVar v) = returnUs (CoVarAtom v, Nothing)
-    expr_to_atom (CoLit l) = returnUs (CoLitAtom l, Nothing)
-    expr_to_atom other_expr
-      = let
-	    e_ty = typeOfCoreExpr other_expr
-	in
-	getUnique	`thenUs` \ uniq ->
-	let
-	    new_var  = mkSysLocal SLIT("a") uniq e_ty mkUnknownSrcLoc
-	    new_atom = CoVarAtom new_var
-	in
-	returnUs (new_atom, Just (CoNonRec new_var other_expr))
-\end{code}
-
-\begin{code}
-atomToExpr :: CoreAtom bindee -> CoreExpr binder bindee
-
-atomToExpr (CoVarAtom v)   = CoVar v
-atomToExpr (CoLitAtom lit) = CoLit lit
-\end{code}
-
-\begin{code}
-pairsFromCoreBinds :: [CoreBinding a b] -> [(a, CoreExpr a b)]
-
-pairsFromCoreBinds []			 = []
-pairsFromCoreBinds ((CoNonRec b e) : bs) = (b,e) :  (pairsFromCoreBinds bs)
-pairsFromCoreBinds ((CoRec  pairs) : bs) = pairs ++ (pairsFromCoreBinds bs)
-\end{code}
-
-\begin{code}
-#ifdef DPH
-mkNonRecBinds :: [(a, CoreExpr a b)] -> [CoreBinding a b]
-mkNonRecBinds xs = [ CoNonRec b e | (b,e) <- xs ]
-
-isParCoreCaseAlternative :: CoreCaseAlternatives a b -> Bool
-{-
-isParCoreCaseAlternative (CoParAlgAlts _ _ _ _ _) = True
-isParCoreCaseAlternative (CoParPrimAlts _ _ _ _)  = True
--}
-isParCoreCaseAlternative  _			  = False
-#endif {- Data Parallel Haskell -}
-\end{code}
-
-\begin{code}
-mkFunction tys args e
-  = foldr CoTyLam (mkCoLam args e) tys
-
-mkCoApps :: PlainCoreExpr -> [PlainCoreExpr] -> UniqSM PlainCoreExpr
-
-mkCoApps fun []  = returnUs fun
-mkCoApps fun (arg:args)
-  = mkCoApp fun arg `thenUs` \ new_fun ->
-    mkCoApps new_fun args
-\end{code}
-
-We often want to strip off leading \tr{/\}-bound @TyVars@ and
-\tr{\}-bound binders, before we get down to business.  @digForLambdas@
-is your friend.
-
-\begin{code}
-digForLambdas :: CoreExpr bndr bdee -> ([TyVar], [bndr], CoreExpr bndr bdee)
-
-digForLambdas (CoTyLam tyvar body)
-  = let
-	(tyvars, args, final_body) = digForLambdas body
-    in
-    (tyvar:tyvars, args, final_body)
-
-digForLambdas other
-  = let
-	(args, body) = dig_in_lambdas other
-    in
-    ([], args, body)
-  where
-    dig_in_lambdas (CoLam args_here body)
-      = let
-	    (args, final_body) = dig_in_lambdas body
-	in
-	(args_here ++ args, final_body)
-
-#ifdef DEBUG
-    dig_in_lambdas body@(CoTyLam ty expr) 
-      =	trace "Inner /\\'s when digging" ([],body)
-#endif
-
-    dig_in_lambdas body
-      = ([], body)
-\end{code}
-
-\begin{code}
-exprSmallEnoughToDup :: CoreExpr binder Id -> Bool
-
-exprSmallEnoughToDup (CoCon _ _ _)   = True	-- Could check # of args
-exprSmallEnoughToDup (CoPrim op _ _) = not (fragilePrimOp op)	-- Could check # of args
-exprSmallEnoughToDup (CoLit lit) = not (isNoRepLit lit)
-
-exprSmallEnoughToDup expr  -- for now, just: <var> applied to <args>
-  = case (collectArgs expr) of { (fun, args) ->
-    case fun of
-      CoVar v -> v /= buildId 
-		 && v /= augmentId
-		 && length args <= 6 -- or 10 or 1 or 4 or anything smallish.
-      _       -> False
-    }
-\end{code}
-Question (ADR): What is the above used for?  Is a _ccall_ really small
-enough?
-
-@manifestlyWHNF@ looks at a Core expression and returns \tr{True} if
-it is obviously in weak head normal form.  It isn't a disaster if it
-errs on the conservative side (returning \tr{False})---I've probably
-left something out... [WDP]
-
-\begin{code}
-manifestlyWHNF :: CoreExpr bndr Id -> Bool
-
-manifestlyWHNF (CoVar _)     = True
-manifestlyWHNF (CoLit _)     = True
-manifestlyWHNF (CoCon _ _ _) = True  -- ToDo: anything for CoPrim?
-manifestlyWHNF (CoLam _ _)   = True
-manifestlyWHNF (CoTyLam _ e) = manifestlyWHNF e
-manifestlyWHNF (CoSCC _ e)   = manifestlyWHNF e
-manifestlyWHNF (CoLet _ e)   = False
-manifestlyWHNF (CoCase _ _)  = False
-
-manifestlyWHNF other_expr   -- look for manifest partial application
-  = case (collectArgs other_expr) of { (fun, args) ->
-    case fun of
-      CoVar f -> let
-		    num_val_args = length [ a | (ValArg a) <- args ]
-		 in 
-		 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
-
-      _ -> False
-    }
-\end{code}
-
-@manifestlyBottom@ looks at a Core expression and returns \tr{True} if
-it is obviously bottom, that is, it will certainly return bottom at
-some point.  It isn't a disaster if it errs on the conservative side
-(returning \tr{False}).
-
-\begin{code}
-manifestlyBottom :: CoreExpr bndr Id -> Bool
-
-manifestlyBottom (CoVar v)     = isBottomingId v
-manifestlyBottom (CoLit _)     = False
-manifestlyBottom (CoCon _ _ _) = False
-manifestlyBottom (CoPrim _ _ _)= False
-manifestlyBottom (CoLam _ _)   = False  -- we do not assume \x.bottom == bottom. should we? ToDo
-manifestlyBottom (CoTyLam _ e) = manifestlyBottom e
-manifestlyBottom (CoSCC _ e)   = manifestlyBottom e
-manifestlyBottom (CoLet _ e)   = manifestlyBottom e
-
-manifestlyBottom (CoCase e a)
-  = manifestlyBottom e
-  || (case a of
-	CoAlgAlts  alts def -> all mbalg  alts && mbdef def
-	CoPrimAlts alts def -> all mbprim alts && mbdef def
-     )
-  where
-    mbalg  (_,_,e') = manifestlyBottom e'
-
-    mbprim (_,e')   = manifestlyBottom e'
-
-    mbdef CoNoDefault          = True
-    mbdef (CoBindDefault _ e') = manifestlyBottom e'
-
-manifestlyBottom other_expr   -- look for manifest partial application
-  = case (collectArgs other_expr) of { (fun, args) ->
-    case fun of
-      CoVar f | isBottomingId f -> True		-- Application of a function which
-						-- always gives bottom; we treat this as
-						-- a WHNF, because it certainly doesn't
-						-- need to be shared!
-      _ -> False
-    }
-\end{code}
-
-UNUSED: @manifestWHNFArgs@ guarantees that an expression can absorb n args
-before it ceases to be a manifest WHNF.  E.g.,
-\begin{verbatim}
-  (\x->x)   	 gives 1
-  (\x -> +Int x) gives 2
-\end{verbatim} 
-
-The function guarantees to err on the side of conservatism: the
-conservative result is (Just 0).
-
-An applications of @error@ are special, because it can absorb as many
-arguments as you care to give it.  For this special case we return Nothing.
-
-\begin{code}
-{- UNUSED:
-manifestWHNFArgs :: CoreExpr bndr Id 
-	         -> Maybe Int		-- Nothing indicates applicn of "error"
-
-manifestWHNFArgs expr 
-  = my_trace (man expr)
-  where
-    man (CoLit _)	= Just 0
-    man (CoCon _ _ _)	= Just 0
-    man (CoLam bs e)	= man e `plus_args`  length bs
-    man (CoApp e _)	= man e `minus_args` 1
-    man (CoTyLam _ e)	= man e
-    man (CoSCC _ e)	= man e
-    man (CoLet _ e)	= man e
-
-    man (CoVar f)
-      | isBottomingId f = Nothing
-      | otherwise       = case (arityMaybe (getIdArity f)) of
-			    Nothing    -> Just 0
-			    Just arity -> Just arity
-
-    man other 		= Just 0 -- Give up on case
-
-    plus_args, minus_args :: Maybe Int -> Int -> Maybe Int
-
-    plus_args Nothing m = Nothing
-    plus_args (Just n) m = Just (n+m)
-
-    minus_args Nothing m = Nothing 
-    minus_args (Just n) m = Just (n-m)
-
-    my_trace n = n 
-    -- if n == 0 then n 
-    -- else pprTrace "manifest:" (ppCat [ppr PprDebug fun, 
-    --		           	  ppr PprDebug args, ppStr "=>", ppInt n]) 
-    --			     	  n
--}
-\end{code}
-
-\begin{code}
-coreExprArity 
-	:: (Id -> Maybe (CoreExpr bndr Id))
-	-> CoreExpr bndr Id 
-	-> Int
-coreExprArity f (CoLam bnds expr) = coreExprArity f expr + length (bnds)
-coreExprArity f (CoTyLam _ expr) = coreExprArity f expr
-coreExprArity f (CoApp expr arg) = max (coreExprArity f expr - 1) 0
-coreExprArity f (CoTyApp expr _) = coreExprArity f expr
-coreExprArity f (CoVar 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 :: PlainCoreExpr -> Id -> Bool
-
-expr `isWrapperFor` var
-  = case (digForLambdas  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 (CoCase scrut alts)
-      = case (collectArgs scrut) of { (fun, args) ->
-	case fun of
-	  CoVar scrut_var -> let
-				answer =
-				     scrut_var /= var && all (doesn't_mention var) args
-				  && 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, args) ->
-	case fun of
-	  CoVar wrkr -> let
-			    answer =
-				-- DOESN'T WORK: wrkr == var's_worker
-				wrkr /= var
-			     && isWorkerId wrkr
-			     && all (doesn't_mention var)  args
-			     && all (only_from case_ables) args
-			in
-			answer
-
-	  _ -> False
-	}
-
-    --------------
-    unravel_alts case_ables (CoAlgAlts [(_,params,rhs)] CoNoDefault)
-      = unravel_casing (params ++ case_ables) rhs
-    unravel_alts case_ables other = False
-
-    -------------------------
-    doesn't_mention var (ValArg (CoVarAtom v)) = v /= var
-    doesn't_mention var other = True
-
-    -------------------------
-    only_from case_ables (ValArg (CoVarAtom 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.
-
-\begin{code}
-unTagBinders :: CoreExpr (Id,tag) bdee -> CoreExpr Id bdee
-unTagBinders e 	      = bop_expr fst e
-
-unTagBindersAlts :: CoreCaseAlternatives (Id,tag) bdee -> CoreCaseAlternatives Id bdee
-unTagBindersAlts alts = bop_alts fst alts
-\end{code}
-
-\begin{code}
-bop_expr  :: (a -> b) -> (CoreExpr a c) -> CoreExpr b c
-
-bop_expr f (CoVar b)		= CoVar b
-bop_expr f (CoLit lit)		= CoLit lit
-bop_expr f (CoCon id u atoms)	= CoCon id u atoms
-bop_expr f (CoPrim op tys atoms)= CoPrim op tys atoms
-bop_expr f (CoLam binders expr)	= CoLam [ f x | x <- binders ] (bop_expr f expr)
-bop_expr f (CoTyLam ty expr)	= CoTyLam ty (bop_expr f expr)
-bop_expr f (CoApp expr atom)	= CoApp (bop_expr f expr) atom
-bop_expr f (CoTyApp expr ty)	= CoTyApp (bop_expr f expr) ty
-bop_expr f (CoSCC label expr)	= CoSCC label (bop_expr f expr)
-bop_expr f (CoLet bind expr)	= CoLet (bop_bind f bind) (bop_expr f expr)
-bop_expr f (CoCase expr alts)
-  = CoCase (bop_expr f expr) (bop_alts f alts)
-
-bop_bind f (CoNonRec b e)	= CoNonRec (f b) (bop_expr f e)
-bop_bind f (CoRec pairs)	= CoRec [(f b, bop_expr f e) | (b, e) <- pairs]
-
-bop_alts f (CoAlgAlts alts deflt)
-  = CoAlgAlts [ (con, [f b | b <- binders], bop_expr f e)
-    	  | (con, binders, e) <- alts ]
-    	  (bop_deflt f deflt)
-
-bop_alts f (CoPrimAlts alts deflt)
-  = CoPrimAlts [ (lit, bop_expr f e) | (lit, e) <- alts ]
-    	   (bop_deflt f deflt)
-
-bop_deflt f (CoNoDefault)		= CoNoDefault
-bop_deflt f (CoBindDefault b expr)	= CoBindDefault (f b) (bop_expr f expr)
-
-#ifdef DPH
-bop_expr f (CoZfExpr expr quals)
-  = CoZfExpr (bop_expr f expr) (bop_quals quals)
-  where
-    bop_quals (CoAndQuals l r)    = CoAndQuals (bop_quals l) (bop_quals r)
-    bop_quals (CoParFilter e)     = CoParFilter (bop_expr f e)
-    bop_quals (CoDrawnGen bs b e) = CoDrawnGen (map f bs) (f b) (bop_expr f e)
-    bop_quals (CoIndexGen es b e) = CoIndexGen (map (bop_expr f) es) (f b)
-					       (bop_expr f e)
-
-bop_expr f (CoParCon con ctxt tys args)
-  = CoParCon con ctxt tys (map (bop_expr f) args)
-
-bop_expr f (CoParComm ctxt e comm)
-  = CoParComm ctxt (bop_expr f e) (bop_comm comm)
-  where
-    bop_comm (CoParSend es)  = CoParSend  (map (bop_expr f) es)
-    bop_comm (CoParFetch es) = CoParFetch (map (bop_expr f) es)
-    bop_comm (CoToPodized)   = CoToPodized
-    bop_comm (CoFromPodized) = CoFromPodized
-#endif {- DPH -}
-\end{code}
-
-OLD (but left here because of the nice example): @singleAlt@ checks
-whether a bunch of case alternatives is actually just one alternative.
-It specifically {\em ignores} alternatives which consist of just a
-call to @error@, because they won't result in any code duplication.
-
-Example: 
-\begin{verbatim}
-	case (case <something> of
-		True  -> <rhs>
-		False -> error "Foo") of
-	<alts>
-
-===> 
-
-	case <something> of
-	   True ->  case <rhs> of
-		    <alts>
-	   False -> case error "Foo" of
-		    <alts>
-
-===>
-
-	case <something> of
-	   True ->  case <rhs> of
-		    <alts>
-	   False -> error "Foo"
-\end{verbatim}
-Notice that the \tr{<alts>} don't get duplicated.
-
-\begin{code}
-{- UNUSED:
-boilsDownToConApp :: CoreExpr bndr bdee -> Bool	-- Looks through lets
-  -- ToDo: could add something for NoRep literals...
-
-boilsDownToConApp (CoCon _ _ _) = True
-boilsDownToConApp (CoTyLam _ e) = boilsDownToConApp e
-boilsDownToConApp (CoTyApp e _) = boilsDownToConApp e
-boilsDownToConApp (CoLet _ e)	= boilsDownToConApp e
-boilsDownToConApp other         = False
--}
-\end{code}
-
-\begin{code}
-nonErrorRHSs :: CoreCaseAlternatives binder Id -> [CoreExpr binder Id]
-
-nonErrorRHSs alts = filter not_error_app (find_rhss alts)
-  where
-    find_rhss (CoAlgAlts  alts deflt) = [rhs | (_,_,rhs) <- alts] ++ deflt_rhs deflt
-    find_rhss (CoPrimAlts alts deflt) = [rhs | (_,rhs)   <- alts] ++ deflt_rhs deflt
-
-    deflt_rhs CoNoDefault           = []
-    deflt_rhs (CoBindDefault _ rhs) = [rhs]
-
-    not_error_app rhs = case maybeErrorApp rhs Nothing of
-			 Just _  -> False
-			 Nothing -> True
-\end{code}
-
-maybeErrorApp checkes whether an expression is of the form
-
-	error ty args
-
-If so, it returns 
-
-	Just (error ty' args)
-
-where ty' is supplied as an argument to maybeErrorApp.
-
-Here's where it is useful:
-
-		case (error ty "Foo" e1 e2) of <alts>
- ===>
-		error ty' "Foo"
-
-where ty' is the type of any of the alternatives.
-You might think this never occurs, but see the comments on
-the definition of @singleAlt@.
-
-Note: we *avoid* the case where ty' might end up as a
-primitive type: this is very uncool (totally wrong).
-
-NOTICE: in the example above we threw away e1 and e2, but
-not the string "Foo".  How did we know to do that?
-
-Answer: for now anyway, we only handle the case of a function
-whose type is of form
-
-	bottomingFn :: forall a. t1 -> ... -> tn -> a
-	    	    	      ^---------------------^ NB!
-
-Furthermore, we only count a bottomingApp if the function is
-applied to more than n args.  If so, we transform:
-
-	bottomingFn ty e1 ... en en+1 ... em
-to
-	bottomingFn ty' e1 ... en
-
-That is, we discard en+1 .. em
-
-\begin{code}
-maybeErrorApp :: CoreExpr bndr Id   -- Expr to look at
-	      -> Maybe UniType	    -- Just ty => a result type *already cloned*; 
-				    -- Nothing => don't know result ty; we
-				    -- *pretend* that the result ty won't be
-				    -- primitive -- somebody later must
-				    -- ensure this.
-	       -> Maybe (CoreExpr bndr Id)
-
-maybeErrorApp expr result_ty_maybe
-  = case collectArgs expr of
-      (CoVar fun, (TypeArg ty : other_args))
-	| isBottomingId fun
-	&& maybeToBool result_ty_maybe -- we *know* the result type
-				       -- (otherwise: live a fairy-tale existence...)
-	&& not (isPrimType result_ty) ->
-	case splitType (getIdUniType fun) of
-	  ([tyvar_tmpl], [], tau_ty) -> 
-	      case (splitTyArgs tau_ty) of { (arg_tys, res_ty) ->
-	      let			
-		  n_args_to_keep = length arg_tys
-		  args_to_keep   = take n_args_to_keep other_args
-	      in
-	      if  res_ty == mkTyVarTemplateTy tyvar_tmpl &&
-		  n_args_to_keep <= length other_args
-	      then
-		    -- Phew!  We're in business
-		  Just (applyToArgs (CoVar fun) 
-				    (TypeArg result_ty : args_to_keep))
-	      else
-		  Nothing
-	      }
-
-	  other -> 	-- Function type wrong shape
-		    Nothing
-      other -> Nothing
-  where
-    Just result_ty = result_ty_maybe
-\end{code}
-
-\begin{code}
-squashableDictishCcExpr :: CostCentre -> CoreExpr a b -> Bool
-
-squashableDictishCcExpr cc expr
-  = if not (isDictCC cc) then
-	False -- that was easy...
-    else
-	squashable expr -- note: quite like the "atomic_rhs" stuff in simplifier
-  where
-    squashable (CoVar _)      = True
-    squashable (CoTyApp f _)  = squashable f
-    squashable (CoCon _ _ _)  = True -- I think so... WDP 94/09
-    squashable (CoPrim _ _ _) = True -- ditto
-    squashable other	      = False
-\end{code}
-
diff --git a/ghc/compiler/coreSyn/CoreLift.hi b/ghc/compiler/coreSyn/CoreLift.hi
deleted file mode 100644
index 03bd24fadb..0000000000
--- a/ghc/compiler/coreSyn/CoreLift.hi
+++ /dev/null
@@ -1,26 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface CoreLift where
-import BasicLit(BasicLit)
-import CoreSyn(CoreAtom, CoreBinding, CoreCaseAlternatives, CoreExpr)
-import CostCentre(CostCentre)
-import Id(Id)
-import PlainCore(PlainCoreBinding(..), PlainCoreExpr(..))
-import PrimOps(PrimOp)
-import SplitUniq(SplitUniqSupply)
-import TyVar(TyVar)
-import UniType(UniType)
-import Unique(Unique)
-data CoreBinding a b 
-data CoreExpr a b 
-data Id 
-type PlainCoreBinding = CoreBinding Id Id
-type PlainCoreExpr = CoreExpr Id Id
-data SplitUniqSupply 
-data Unique 
-applyBindUnlifts :: [CoreExpr Id Id -> CoreExpr Id Id] -> CoreExpr Id Id -> CoreExpr Id Id
-bindUnlift :: Id -> Id -> CoreExpr Id Id -> CoreExpr Id Id
-isUnboxedButNotState :: UniType -> Bool
-liftCoreBindings :: SplitUniqSupply -> [CoreBinding Id Id] -> [CoreBinding Id Id]
-liftExpr :: Id -> CoreExpr Id Id -> CoreExpr Id Id
-mkLiftedId :: Id -> Unique -> (Id, Id)
-
diff --git a/ghc/compiler/coreSyn/CoreLift.lhs b/ghc/compiler/coreSyn/CoreLift.lhs
index cb8e6f8dbe..90f76565a5 100644
--- a/ghc/compiler/coreSyn/CoreLift.lhs
+++ b/ghc/compiler/coreSyn/CoreLift.lhs
@@ -1,5 +1,5 @@
 %
-% (c) The GRASP/AQUA Project, Glasgow University, 1993-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1993-1996
 %
 \section[CoreLift]{Lifts unboxed bindings and any references to them}
 
@@ -13,28 +13,28 @@ module CoreLift (
 	liftExpr,
 	bindUnlift,
 	applyBindUnlifts,
-	isUnboxedButNotState,
-	
-	CoreBinding, PlainCoreBinding(..),
-	CoreExpr, PlainCoreExpr(..),
-	Id, SplitUniqSupply, Unique
+	isUnboxedButNotState
+
     ) where
 
-IMPORT_Trace
-import Pretty
+import Ubiq{-uitous-}
 
-import AbsPrel		( liftDataCon, mkLiftTy )
-import TysPrim		( statePrimTyCon ) -- ToDo: get from AbsPrel
-import AbsUniType
-import Id		( getIdUniType, updateIdType, mkSysLocal, isLocallyDefined )
-import IdEnv
-import Outputable
-import PlainCore
-import SplitUniq
-import Util
+import CoreSyn
+import CoreUtils	( coreExprType )
+import Id		( idType, mkSysLocal,
+			  nullIdEnv, growIdEnvList, lookupIdEnv, IdEnv(..),
+			  GenId{-instances-}
+			)
+import PrelInfo		( liftDataCon, mkLiftTy, statePrimTyCon )
+import TyCon		( TyCon{-instance-} )
+import Type		( maybeAppDataTyCon, eqTy )
+import UniqSupply	( getUnique, getUniques, splitUniqSupply, UniqSupply )
+import Util		( zipEqual, zipWithEqual, assertPanic, panic )
 
 infixr 9 `thenL`
 
+updateIdType = panic "CoreLift.updateIdType"
+isBoxedTyCon = panic "CoreLift.isBoxedTyCon"
 \end{code}
 
 %************************************************************************
@@ -46,27 +46,28 @@ infixr 9 `thenL`
 @liftCoreBindings@ is the top-level interface function.
 
 \begin{code}
-liftCoreBindings :: SplitUniqSupply	-- unique supply
-		 -> [PlainCoreBinding]	-- unlifted bindings
-		 -> [PlainCoreBinding]	-- lifted bindings
+liftCoreBindings :: UniqSupply	-- unique supply
+		 -> [CoreBinding]	-- unlifted bindings
+		 -> [CoreBinding]	-- lifted bindings
 
 liftCoreBindings us binds
   = initL (lift_top_binds binds) us
   where
+    lift_top_binds [] = returnL []
+
     lift_top_binds (b:bs)
       = liftBindAndScope True b (
-          lift_top_binds bs `thenL` \ bs ->
+	  lift_top_binds bs `thenL` \ bs ->
 	  returnL (ItsABinds bs)
-        ) 			`thenL` \ (b, ItsABinds bs) ->
+	) 			`thenL` \ (b, ItsABinds bs) ->
 	returnL (b:bs)
 
-    lift_top_binds []
-      = returnL []
-    
-liftBindAndScope :: Bool			-- top level ?
-		 -> PlainCoreBinding		-- As yet unprocessed
-		 -> LiftM BindsOrExpr		-- Do the scope of the bindings
-		 -> LiftM (PlainCoreBinding,	-- Processed
+
+-----------------------
+liftBindAndScope :: Bool		-- top level ?
+		 -> CoreBinding		-- As yet unprocessed
+		 -> LiftM BindsOrExpr	-- Do the scope of the bindings
+		 -> LiftM (CoreBinding,	-- Processed
 		 	   BindsOrExpr)
 
 liftBindAndScope top_lev bind scopeM
@@ -76,31 +77,33 @@ liftBindAndScope top_lev bind scopeM
       returnL (bind, bindsorexpr)
     )
 
+-----------------------
+liftCoreArg :: CoreArg -> LiftM (CoreArg, CoreExpr -> CoreExpr)
 
-liftCoreAtom :: PlainCoreAtom -> LiftM (PlainCoreAtom, PlainCoreExpr -> PlainCoreExpr)
-
-liftCoreAtom (CoLitAtom lit)
- = returnL (CoLitAtom lit, id)
-
-liftCoreAtom (CoVarAtom v)
+liftCoreArg arg@(TyArg     _) = returnL (arg, id)
+liftCoreArg arg@(UsageArg  _) = returnL (arg, id)
+liftCoreArg arg@(LitArg    _) = returnL (arg, id)
+liftCoreArg arg@(VarArg v)
  = isLiftedId v			`thenL` \ lifted ->
     case lifted of
+	Nothing -> returnL (arg, id)
+
 	Just (lifted, unlifted) ->
-	    returnL (CoVarAtom unlifted, bindUnlift lifted unlifted)
-	Nothing ->
-            returnL (CoVarAtom v, id)
+	    returnL (VarArg unlifted, bindUnlift lifted unlifted)
 
 
-liftCoreBind :: PlainCoreBinding -> LiftM PlainCoreBinding
+-----------------------
+liftCoreBind :: CoreBinding -> LiftM CoreBinding
 
-liftCoreBind (CoNonRec b rhs)
+liftCoreBind (NonRec b rhs)
   = liftOneBind (b,rhs)		`thenL` \ (b,rhs) ->
-    returnL (CoNonRec b rhs)
+    returnL (NonRec b rhs)
 
-liftCoreBind (CoRec pairs) 
-  = mapL liftOneBind pairs	`thenL` \ pairs -> 
-    returnL (CoRec pairs)
+liftCoreBind (Rec pairs)
+  = mapL liftOneBind pairs	`thenL` \ pairs ->
+    returnL (Rec pairs)
 
+-----------------------
 liftOneBind (binder,rhs)
   = liftCoreExpr rhs    	`thenL` \ rhs ->
     isLiftedId binder		`thenL` \ lifted ->
@@ -108,100 +111,92 @@ liftOneBind (binder,rhs)
 	Just (lifted, unlifted) ->
 	    returnL (lifted, liftExpr unlifted rhs)
 	Nothing ->
-            returnL (binder, rhs)
+	    returnL (binder, rhs)
 
-liftCoreExpr :: PlainCoreExpr -> LiftM PlainCoreExpr
+-----------------------
+liftCoreExpr :: CoreExpr -> LiftM CoreExpr
 
-liftCoreExpr (CoVar var)
+liftCoreExpr expr@(Var var)
   = isLiftedId var		`thenL` \ lifted ->
     case lifted of
+	Nothing -> returnL expr
 	Just (lifted, unlifted) ->
-	    returnL (bindUnlift lifted unlifted (CoVar unlifted))
-	Nothing ->
-            returnL (CoVar var)
+	    returnL (bindUnlift lifted unlifted (Var unlifted))
 
-liftCoreExpr (CoLit lit)
-  = returnL (CoLit lit)
+liftCoreExpr expr@(Lit lit) = returnL expr
 
-liftCoreExpr (CoSCC label expr)
+liftCoreExpr (SCC label expr)
   = liftCoreExpr expr		`thenL` \ expr ->
-    returnL (CoSCC label expr)
+    returnL (SCC label expr)
 
-liftCoreExpr (CoLet (CoNonRec binder rhs) body)		-- special case: no lifting
+liftCoreExpr (Let (NonRec binder rhs) body) -- special case: no lifting
   = liftCoreExpr rhs	`thenL` \ rhs ->
     liftCoreExpr body	`thenL` \ body ->
-    returnL (mkCoLetUnboxedToCase (CoNonRec binder rhs) body)
+    returnL (mkCoLetUnboxedToCase (NonRec binder rhs) body)
 
-liftCoreExpr (CoLet bind body)	-- general case
+liftCoreExpr (Let bind body)	-- general case
   = liftBindAndScope False bind (
       liftCoreExpr body	`thenL` \ body ->
       returnL (ItsAnExpr body)
     )				`thenL` \ (bind, ItsAnExpr body) ->
-    returnL (CoLet bind body)
+    returnL (Let bind body)
 
-liftCoreExpr (CoCon con tys args)
-  = mapAndUnzipL liftCoreAtom args	`thenL` \ (args, unlifts) ->
-    returnL (applyBindUnlifts unlifts (CoCon con tys args))
+liftCoreExpr (Con con args)
+  = mapAndUnzipL liftCoreArg args	`thenL` \ (args, unlifts) ->
+    returnL (applyBindUnlifts unlifts (Con con args))
 
-liftCoreExpr (CoPrim op tys args)
-  = mapAndUnzipL liftCoreAtom args	`thenL` \ (args, unlifts) ->
-    returnL (applyBindUnlifts unlifts (CoPrim op tys args))
+liftCoreExpr (Prim op args)
+  = mapAndUnzipL liftCoreArg args	`thenL` \ (args, unlifts) ->
+    returnL (applyBindUnlifts unlifts (Prim op args))
 
-liftCoreExpr (CoApp fun arg)
+liftCoreExpr (App fun arg)
   = lift_app fun [arg]
   where
-    lift_app (CoApp fun arg) args
+    lift_app (App fun arg) args
       = lift_app fun (arg:args)
     lift_app other_fun args
       = liftCoreExpr other_fun		`thenL` \ other_fun ->
-        mapAndUnzipL liftCoreAtom args	`thenL` \ (args, unlifts) ->
-        returnL (applyBindUnlifts unlifts (foldl CoApp other_fun args))
+	mapAndUnzipL liftCoreArg args	`thenL` \ (args, unlifts) ->
+	returnL (applyBindUnlifts unlifts (mkGenApp other_fun args))
 
-liftCoreExpr (CoTyApp fun ty_arg)
-  = liftCoreExpr fun		`thenL` \ fun ->
-    returnL (CoTyApp fun ty_arg)
-
-liftCoreExpr (CoLam binders expr)
-  = liftCoreExpr expr		`thenL` \ expr ->
-    returnL (CoLam binders expr)
-
-liftCoreExpr (CoTyLam tyvar expr)
+liftCoreExpr (Lam binder expr)
   = liftCoreExpr expr		`thenL` \ expr ->
-    returnL (CoTyLam tyvar expr)
+    returnL (Lam binder expr)
 
-liftCoreExpr (CoCase scrut alts)
+liftCoreExpr (Case scrut alts)
  = liftCoreExpr scrut		`thenL` \ scrut ->
    liftCoreAlts alts		`thenL` \ alts ->
-   returnL (CoCase scrut alts)
-
+   returnL (Case scrut alts)
 
-liftCoreAlts :: PlainCoreCaseAlternatives -> LiftM PlainCoreCaseAlternatives
+------------
+liftCoreAlts :: CoreCaseAlts -> LiftM CoreCaseAlts
 
-liftCoreAlts (CoAlgAlts alg_alts deflt)
+liftCoreAlts (AlgAlts alg_alts deflt)
  = mapL liftAlgAlt alg_alts	`thenL` \ alg_alts ->
    liftDeflt deflt		`thenL` \ deflt ->
-   returnL (CoAlgAlts alg_alts deflt)
+   returnL (AlgAlts alg_alts deflt)
 
-liftCoreAlts (CoPrimAlts prim_alts deflt)
+liftCoreAlts (PrimAlts prim_alts deflt)
  = mapL liftPrimAlt prim_alts	`thenL` \ prim_alts ->
    liftDeflt deflt		`thenL` \ deflt ->
-   returnL (CoPrimAlts prim_alts deflt)
-
+   returnL (PrimAlts prim_alts deflt)
 
+------------
 liftAlgAlt (con,args,rhs)
   = liftCoreExpr rhs		`thenL` \ rhs ->
     returnL (con,args,rhs)
 
+------------
 liftPrimAlt (lit,rhs)
   = liftCoreExpr rhs		`thenL` \ rhs ->
     returnL (lit,rhs)
-   
-liftDeflt CoNoDefault
-  = returnL CoNoDefault
-liftDeflt (CoBindDefault binder rhs)
-  = liftCoreExpr rhs		`thenL` \ rhs ->
-    returnL (CoBindDefault binder rhs)
 
+------------
+liftDeflt NoDefault
+  = returnL NoDefault
+liftDeflt (BindDefault binder rhs)
+  = liftCoreExpr rhs		`thenL` \ rhs ->
+    returnL (BindDefault binder rhs)
 \end{code}
 
 %************************************************************************
@@ -211,28 +206,28 @@ liftDeflt (CoBindDefault binder rhs)
 %************************************************************************
 
 \begin{code}
-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))
-				--   * unlifted version with a new Unique
-            -> SplitUniqSupply	-- unique supply
-	    -> a		-- result
+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))
+			--   * unlifted version with a new Unique
+    -> UniqSupply	-- unique supply
+    -> a		-- result
 
-data BindsOrExpr = ItsABinds [PlainCoreBinding]
-		 | ItsAnExpr PlainCoreExpr
+data BindsOrExpr
+  = ItsABinds [CoreBinding]
+  | ItsAnExpr CoreExpr
 
-initL m us
-  = m nullIdEnv us
+initL m us = m nullIdEnv us
 
 returnL :: a -> LiftM a
-returnL r idenv us
-  = r
+returnL r idenv us = r
 
 thenL :: LiftM a -> (a -> LiftM b) -> LiftM b
 thenL m k idenv s0
-  = case splitUniqSupply s0	   of { (s1, s2) ->
-    case (m idenv s1) of { r ->
+  = case (splitUniqSupply s0)	of { (s1, s2) ->
+    case (m idenv s1)		of { r ->
     k r idenv s2 }}
 
 
@@ -251,28 +246,28 @@ mapAndUnzipL f (x:xs)
     returnL ((r1:rs1),(r2:rs2))
 
 -- liftBinders is only called for top-level or recusive case
-liftBinders :: Bool -> PlainCoreBinding -> LiftM thing -> LiftM thing
+liftBinders :: Bool -> CoreBinding -> LiftM thing -> LiftM thing
 
-liftBinders False (CoNonRec _ _) liftM idenv s0
-  = error "CoreLift:liftBinders"	-- should be caught by special case above
+liftBinders False (NonRec _ _) liftM idenv s0
+  = panic "CoreLift:liftBinders"	-- should be caught by special case above
 
 liftBinders top_lev bind liftM idenv s0
-  = liftM (growIdEnvList idenv lift_map) s1
+  = liftM (growIdEnvList idenv lift_map) s2
   where
-    lift_ids = [ id | id <- bindersOf bind, isUnboxedButNotState (getIdUniType id) ]
-    (lift_uniqs, s1) = getSUniquesAndDepleted (length lift_ids) s0
-    lift_map = zip lift_ids (zipWith mkLiftedId lift_ids lift_uniqs)
+    (s1, s2)   = splitUniqSupply s0
+    lift_ids   = [ id | id <- bindersOf bind, isUnboxedButNotState (idType id) ]
+    lift_uniqs = getUniques (length lift_ids) s1
+    lift_map   = zipEqual lift_ids (zipWithEqual mkLiftedId lift_ids lift_uniqs)
 
     -- ToDo: Give warning for recursive bindings involving unboxed values ???
 
-
 isLiftedId :: Id -> LiftM (Maybe (Id, Id))
 isLiftedId id idenv us
-  | isLocallyDefined id 
+  | isLocallyDefined id
      = lookupIdEnv idenv id
   | otherwise	-- ensure all imported ids are lifted
-     = if isUnboxedButNotState (getIdUniType id)
-       then Just (mkLiftedId id (getSUnique us))
+     = if isUnboxedButNotState (idType id)
+       then Just (mkLiftedId id (getUnique us))
        else Nothing
 
 mkLiftedId :: Id -> Unique -> (Id,Id)
@@ -284,36 +279,36 @@ mkLiftedId id u
     lifted_id   = updateIdType id lifted_ty
     unlifted_id = mkSysLocal id_name u unlifted_ty (getSrcLoc id)
 
-    unlifted_ty = getIdUniType id
+    unlifted_ty = idType id
     lifted_ty   = mkLiftTy unlifted_ty
 
-bindUnlift :: Id -> Id -> PlainCoreExpr -> PlainCoreExpr
+bindUnlift :: Id -> Id -> CoreExpr -> CoreExpr
 bindUnlift vlift vunlift expr
   = ASSERT (isUnboxedButNotState unlift_ty)
-    ASSERT (lift_ty == mkLiftTy unlift_ty)
-    CoCase (CoVar vlift)
-	   (CoAlgAlts [(liftDataCon, [vunlift], expr)] CoNoDefault)
+    ASSERT (lift_ty `eqTy` mkLiftTy unlift_ty)
+    Case (Var vlift)
+	   (AlgAlts [(liftDataCon, [vunlift], expr)] NoDefault)
   where
-    lift_ty   = getIdUniType vlift
-    unlift_ty = getIdUniType vunlift
+    lift_ty   = idType vlift
+    unlift_ty = idType vunlift
 
-liftExpr :: Id -> PlainCoreExpr -> PlainCoreExpr
+liftExpr :: Id -> CoreExpr -> CoreExpr
 liftExpr vunlift rhs
   = ASSERT (isUnboxedButNotState unlift_ty)
-    ASSERT (rhs_ty == unlift_ty)
-    CoCase rhs (CoPrimAlts [] (CoBindDefault vunlift 
-			      (CoCon liftDataCon [unlift_ty] [CoVarAtom vunlift])))
+    ASSERT (rhs_ty `eqTy` unlift_ty)
+    Case rhs (PrimAlts []
+	(BindDefault vunlift (mkCon liftDataCon [] [unlift_ty] [VarArg vunlift])))
   where
-    rhs_ty    = typeOfCoreExpr rhs
-    unlift_ty = getIdUniType vunlift
+    rhs_ty    = coreExprType rhs
+    unlift_ty = idType vunlift
 
 
-applyBindUnlifts :: [PlainCoreExpr -> PlainCoreExpr] -> PlainCoreExpr -> PlainCoreExpr
+applyBindUnlifts :: [CoreExpr -> CoreExpr] -> CoreExpr -> CoreExpr
 applyBindUnlifts []     expr = expr
 applyBindUnlifts (f:fs) expr = f (applyBindUnlifts fs expr)
 
 isUnboxedButNotState ty
-  = case (getUniDataTyCon_maybe ty) of
+  = case (maybeAppDataTyCon ty) of
       Nothing -> False
       Just (tycon, _, _) ->
 	not (isBoxedTyCon tycon) && not (tycon == statePrimTyCon)
diff --git a/ghc/compiler/coreSyn/CoreLint.hi b/ghc/compiler/coreSyn/CoreLint.hi
deleted file mode 100644
index fd1228c655..0000000000
--- a/ghc/compiler/coreSyn/CoreLint.hi
+++ /dev/null
@@ -1,16 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface CoreLint where
-import CmdLineOpts(GlobalSwitch)
-import CoreSyn(CoreBinding, CoreExpr)
-import Id(Id)
-import Maybes(Labda)
-import PlainCore(PlainCoreBinding(..))
-import Pretty(PprStyle)
-import SrcLoc(SrcLoc)
-data CoreBinding a b 
-data Id 
-type PlainCoreBinding = CoreBinding Id Id
-data PprStyle 
-lintCoreBindings :: PprStyle -> [Char] -> Bool -> [CoreBinding Id Id] -> [CoreBinding Id Id]
-lintUnfolding :: SrcLoc -> CoreExpr Id Id -> Labda (CoreExpr Id Id)
-
diff --git a/ghc/compiler/coreSyn/CoreLint.lhs b/ghc/compiler/coreSyn/CoreLint.lhs
index c2864dc914..a08c45f13e 100644
--- a/ghc/compiler/coreSyn/CoreLint.lhs
+++ b/ghc/compiler/coreSyn/CoreLint.lhs
@@ -8,299 +8,352 @@
 
 module CoreLint (
 	lintCoreBindings,
-	lintUnfolding,
-	
-	PprStyle, CoreBinding, PlainCoreBinding(..), Id
+	lintUnfolding
     ) where
 
-IMPORT_Trace
+import Ubiq
+
+import CoreSyn
 
-import AbsPrel		( typeOfPrimOp, mkFunTy, PrimOp(..), PrimKind
-			  IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
-			  IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
-			)
-import AbsUniType
 import Bag
-import BasicLit		( typeOfBasicLit, BasicLit )
-import CoreSyn		( pprCoreBinding ) -- ToDo: correctly
-import Id		( getIdUniType, isNullaryDataCon, isBottomingId,
-			  getInstantiatedDataConSig, Id
-			  IF_ATTACK_PRAGMAS(COMMA bottomIsGuaranteed)
+import Kind		( Kind{-instance-} )
+import Literal		( literalType, Literal{-instance-} )
+import Id		( idType, isBottomingId,
+			  getInstantiatedDataConSig, GenId{-instances-}
 			)
-import Maybes
-import Outputable
-import PlainCore
+import Outputable	( Outputable(..) )
+import PprCore
+import PprStyle		( PprStyle(..) )
+import PprType		( GenType, GenTyVar, TyCon )
 import Pretty
+import PrimOp		( primOpType, PrimOp(..) )
+import PrimRep		( PrimRep(..) )
 import SrcLoc		( SrcLoc )
-import UniqSet
-import Util
-
-infixr 9 `thenL`, `thenL_`, `thenMaybeL`, `thenMaybeL_`
+import Type		( mkFunTy,getFunTy_maybe,mkForAllTy,getForAllTy_maybe,
+			  isPrimType,getTypeKind,instantiateTy,
+			  mkForAllUsageTy,getForAllUsageTy,instantiateUsage,
+			  maybeAppDataTyCon, eqTy )
+import TyCon		( isPrimTyCon,isVisibleDataTyCon )
+import TyVar		( getTyVarKind, GenTyVar{-instances-} )
+import UniqSet		( emptyUniqSet, mkUniqSet, intersectUniqSets,
+			  unionUniqSets, elementOfUniqSet, UniqSet(..) )
+import Unique		( Unique )
+import Usage		( GenUsage )
+import Util		( zipEqual, pprTrace, pprPanic, assertPanic, panic )
+
+infixr 9 `thenL`, `seqL`, `thenMaybeL`, `seqMaybeL`
 \end{code}
 
-Checks for 
-	(a) type errors
-	(b) locally-defined variables used but not defined
-
-Doesn't check for out-of-scope type variables, because they can
-legitimately arise.  Eg
-\begin{verbatim}
-	k = /\a b -> \x::a y::b -> x
-	f = /\c -> \z::c -> k c w z (error w "foo")
-\end{verbatim}
-Here \tr{w} is just a free type variable.
-
 %************************************************************************
 %*									*
-\subsection{``lint'' for various constructs}
+\subsection[lintCoreBindings]{@lintCoreBindings@: Top-level interface}
 %*									*
 %************************************************************************
 
-@lintCoreBindings@ is the top-level interface function.
+Checks that a set of core bindings is well-formed.  The PprStyle and String
+just control what we print in the event of an error.  The Bool value
+indicates whether we have done any specialisation yet (in which case we do
+some extra checks).
+
+We check for
+	(a) type errors
+	(b) Out-of-scope type variables
+	(c) Out-of-scope local variables
+	(d) Ill-kinded types
+
+If we have done specialisation the we check that there are
+	(a) No top-level bindings of primitive (unboxed type)
+
+Outstanding issues:
+
+    --
+    -- Things are *not* OK if:
+    --
+    -- * Unsaturated type app before specialisation has been done;
+    --
+    -- * Oversaturated type app after specialisation (eta reduction
+    --   may well be happening...);
+    --
+    -- Note: checkTyApp is usually followed by a call to checkSpecTyApp.
+    --
 
 \begin{code}
-lintCoreBindings :: PprStyle -> String -> Bool -> [PlainCoreBinding] -> [PlainCoreBinding]
+lintCoreBindings
+	:: PprStyle -> String -> Bool -> [CoreBinding] -> [CoreBinding]
 
-lintCoreBindings sty whodunnit spec_done binds
-  = BSCC("CoreLint")
-    case (initL (lint_binds binds) spec_done) of
+lintCoreBindings sty whoDunnit spec_done binds
+  = case (initL (lint_binds binds) spec_done) of
       Nothing  -> binds
-      Just msg -> pprPanic "" (ppAboves [
-			ppStr ("*** Core Lint Errors: in "++whodunnit++" ***"),
-			msg sty,
-			ppStr "*** Offending Program ***",
-			ppAboves (map (pprCoreBinding sty pprBigCoreBinder pprTypedCoreBinder ppr) binds),
-			ppStr "*** End of Offense ***"])
-    ESCC
+      Just msg ->
+	pprPanic "" (ppAboves [
+	  ppStr ("*** Core Lint Errors: in " ++ whoDunnit ++ " ***"),
+	  msg sty,
+	  ppStr "*** Offending Program ***",
+	  ppAboves
+	   (map (pprCoreBinding sty (pprBigCoreBinder sty) (pprTypedCoreBinder sty) (ppr sty))
+	    binds),
+	  ppStr "*** End of Offense ***"
+	])
   where
-    lint_binds :: [PlainCoreBinding] -> LintM ()
-
     lint_binds [] = returnL ()
-    lint_binds (bind:binds) 
-      = lintCoreBinds bind 		`thenL` \ binders ->
-	addInScopeVars binders (
-	    lint_binds binds
-	)
+    lint_binds (bind:binds)
+      = lintCoreBinding bind `thenL` \binders ->
+	addInScopeVars binders (lint_binds binds)
 \end{code}
 
+%************************************************************************
+%*									*
+\subsection[lintUnfolding]{lintUnfolding}
+%*									*
+%************************************************************************
+
 We use this to check all unfoldings that come in from interfaces
 (it is very painful to catch errors otherwise):
+
 \begin{code}
-lintUnfolding :: SrcLoc -> PlainCoreExpr -> Maybe PlainCoreExpr
+lintUnfolding :: SrcLoc -> CoreExpr -> Maybe CoreExpr
 
 lintUnfolding locn expr
-  = case (initL (addLoc (ImportedUnfolding locn) (lintCoreExpr expr)) True{-pretend spec done-}) of
+  = case
+      (initL (addLoc (ImportedUnfolding locn) (lintCoreExpr expr))
+       True{-pretend spec done-})
+    of
       Nothing  -> Just expr
-      Just msg -> pprTrace "WARNING: Discarded bad unfolding from interface:\n"
-			   (ppAboves [msg PprForUser,
-				      ppStr "*** Bad unfolding ***",
-				      ppr PprDebug expr,
-				      ppStr "*** End unfolding ***"])
-		  Nothing
+      Just msg ->
+        pprTrace "WARNING: Discarded bad unfolding from interface:\n"
+	(ppAboves [msg PprForUser,
+		   ppStr "*** Bad unfolding ***",
+		   ppr PprDebug expr,
+		   ppStr "*** End unfolding ***"])
+	Nothing
 \end{code}
 
-\begin{code}
-lintCoreAtom :: PlainCoreAtom -> LintM (Maybe UniType)
+%************************************************************************
+%*									*
+\subsection[lintCoreBinding]{lintCoreBinding}
+%*									*
+%************************************************************************
 
-lintCoreAtom (CoLitAtom lit)       = returnL (Just (typeOfBasicLit lit))
-lintCoreAtom a@(CoVarAtom v)
-  = checkInScope v	`thenL_`
-    returnL (Just (getIdUniType v))
-\end{code}
+Check a core binding, returning the list of variables bound.
 
 \begin{code}
-lintCoreBinds :: PlainCoreBinding -> LintM [Id]		-- Returns the binders
-lintCoreBinds (CoNonRec binder rhs)
-  = lint_binds_help (binder,rhs) 	`thenL_`
-    returnL [binder]
+lintCoreBinding :: CoreBinding -> LintM [Id]
+
+lintCoreBinding (NonRec binder rhs)
+  = lintSingleBinding (binder,rhs) `seqL` returnL [binder]
 
-lintCoreBinds (CoRec pairs) 
+lintCoreBinding (Rec pairs)
   = addInScopeVars binders (
-	mapL lint_binds_help pairs `thenL_`
-	returnL binders
+      mapL lintSingleBinding pairs `seqL` returnL binders
     )
   where
     binders = [b | (b,_) <- pairs]
 
-lint_binds_help (binder,rhs)
+lintSingleBinding (binder,rhs)
   = addLoc (RhsOf binder) (
 	-- Check the rhs
-	lintCoreExpr rhs    	`thenL` \ maybe_rhs_ty ->
+	lintCoreExpr rhs
 
+	`thenL` \maybe_ty ->
 	-- Check match to RHS type
-	(case maybe_rhs_ty of
-	  Nothing     -> returnL ()
-	  Just rhs_ty -> checkTys (getIdUniType binder) 
-				   rhs_ty 
-				   (mkRhsMsg binder rhs_ty)
-	)			`thenL_` 
-
-	-- Check not isPrimType
-	checkIfSpecDoneL (not (isPrimType (getIdUniType binder)))
-	       		 (mkRhsPrimMsg binder rhs)
-				`thenL_`
-
-	-- Check unfolding, if any
-	-- Blegh. This is tricky, because the unfolding is a SimplifiableCoreExpr
-	-- Give up for now
-
-	returnL ()
+	(case maybe_ty of
+	  Nothing -> returnL ()
+	  Just ty -> checkTys (idType binder) ty (mkRhsMsg binder ty))
+
+	`seqL`
+	-- Check (not isPrimType)
+	checkIfSpecDoneL (not (isPrimType (idType binder)))
+	  (mkRhsPrimMsg binder rhs)
+
+	-- We should check the unfolding, if any, but this is tricky because
+	-- the unfolding is a SimplifiableCoreExpr. Give up for now.
     )
 \end{code}
 
+%************************************************************************
+%*									*
+\subsection[lintCoreExpr]{lintCoreExpr}
+%*									*
+%************************************************************************
+
 \begin{code}
-lintCoreExpr :: PlainCoreExpr -> LintM (Maybe UniType)	-- Nothing if error found
+lintCoreExpr :: CoreExpr -> LintM (Maybe Type)	-- Nothing if error found
 
-lintCoreExpr (CoVar var)
-  = checkInScope var	`thenL_`
-    returnL (Just ty)
-{-
-    case (splitForalls ty) of { (tyvars, _) ->
-    if null tyvars then
-	returnL (Just ty)
+lintCoreExpr (Var var) = checkInScope var `seqL` returnL (Just (idType var))
+lintCoreExpr (Lit lit) = returnL (Just (literalType lit))
+lintCoreExpr (SCC _ expr) = lintCoreExpr expr
+
+lintCoreExpr (Let binds body)
+  = lintCoreBinding binds `thenL` \binders ->
+    if (null binders) then
+	lintCoreExpr body  -- Can't add a new source location
     else
-	addErrL (mkUnappTyMsg var ty)	`thenL_`
-	returnL Nothing
-    }
--}
-  where
-    ty = getIdUniType var
-
-lintCoreExpr (CoLit lit)	= returnL (Just (typeOfBasicLit lit))
-lintCoreExpr (CoSCC label expr)	= lintCoreExpr expr
-
-lintCoreExpr (CoLet binds body)	
-  = lintCoreBinds binds		`thenL` \ binders ->
-    ASSERT(not (null binders))
-    addLoc (BodyOfLetRec binders) (
-    addInScopeVars binders (
-	lintCoreExpr body
-    ))
-
-lintCoreExpr e@(CoCon con tys args)
-  = checkTyApp con_ty tys (mkTyAppMsg e)    	`thenMaybeL` \ con_tau_ty ->
-    -- Note: no call to checkSpecTyApp for constructor type args
-    mapMaybeL lintCoreAtom args			`thenL` \ maybe_arg_tys ->
-    case maybe_arg_tys of
-      Nothing 	    -> returnL Nothing
-      Just arg_tys  -> checkFunApp con_tau_ty arg_tys (mkFunAppMsg con_tau_ty arg_tys e)
-  where
-    con_ty = getIdUniType con
-
-lintCoreExpr e@(CoPrim op tys args)
-  = checkTyApp op_ty tys (mkTyAppMsg e)		`thenMaybeL` \ op_tau_ty ->
-    -- ToDo: checkSpecTyApp e tys (mkSpecTyAppMsg e)	`thenMaybeL_`
-    mapMaybeL lintCoreAtom args			`thenL` \ maybe_arg_tys ->
-    case maybe_arg_tys of
-      Nothing -> returnL Nothing
-      Just arg_tys -> checkFunApp op_tau_ty arg_tys (mkFunAppMsg op_tau_ty arg_tys e)
-  where
-    op_ty = typeOfPrimOp op
+      addLoc (BodyOfLetRec binders)
+	(addInScopeVars binders (lintCoreExpr body))
+
+lintCoreExpr e@(Con con args)
+  = lintCoreArgs False e (idType con) args
+    -- Note: we don't check for primitive types in these arguments
+
+lintCoreExpr e@(Prim op args)
+  = lintCoreArgs True e (primOpType op) args
+    -- Note: we do check for primitive types in these arguments
+
+lintCoreExpr e@(App fun@(Var v) arg) | isBottomingId v
+  = lintCoreExpr fun `thenMaybeL` \ ty -> lintCoreArg False e ty arg
+    -- Note: we don't check for primitive types in argument to 'error'
+
+lintCoreExpr e@(App fun arg)
+  = lintCoreExpr fun `thenMaybeL` \ty -> lintCoreArg True e ty arg
+    -- Note: we do check for primitive types in this argument
+
+lintCoreExpr (Lam (ValBinder var) expr)
+  = addLoc (LambdaBodyOf var)
+      (addInScopeVars [var]
+	(lintCoreExpr expr `thenMaybeL` \ty ->
+	 returnL (Just (mkFunTy (idType var) ty))))
+
+lintCoreExpr (Lam (TyBinder tyvar) expr)
+  = lintCoreExpr expr `thenMaybeL` \ty ->
+    returnL (Just(mkForAllTy tyvar ty))
+    -- TODO: Should add in-scope type variable at this point
+
+lintCoreExpr e@(Case scrut alts)
+ = lintCoreExpr scrut `thenMaybeL` \ty ->
+   -- Check that it is a data type
+   case maybeAppDataTyCon ty of
+     Nothing -> addErrL (mkCaseDataConMsg e) `seqL` returnL Nothing
+     Just(tycon, _, _) -> lintCoreAlts alts ty tycon
+\end{code}
 
-lintCoreExpr e@(CoApp fun arg)
-  = lce e []
-  where
-    lce (CoApp fun arg) arg_tys = lintCoreAtom arg	`thenMaybeL` \ arg_ty ->
-			          lce fun (arg_ty:arg_tys)
+%************************************************************************
+%*									*
+\subsection[lintCoreArgs]{lintCoreArgs}
+%*									*
+%************************************************************************
 
-    lce other_fun arg_tys = lintCoreExpr other_fun	`thenMaybeL` \ fun_ty ->
-			    checkFunApp fun_ty arg_tys (mkFunAppMsg fun_ty arg_tys e)
+The boolean argument indicates whether we should flag type
+applications to primitive types as being errors.
 
-lintCoreExpr e@(CoTyApp fun ty_arg)
-  = lce e []
-  where
-    lce (CoTyApp fun ty_arg) ty_args = lce fun (ty_arg:ty_args)
-
-    lce other_fun ty_args = lintCoreExpr other_fun	`thenMaybeL` \ fun_ty ->
-			    checkTyApp fun_ty ty_args (mkTyAppMsg e)
-							`thenMaybeL` \ res_ty ->
-			    checkSpecTyApp other_fun ty_args (mkSpecTyAppMsg e)
-							`thenMaybeL_`
-			    returnL (Just res_ty)
-
-lintCoreExpr (CoLam binders expr)
-  = ASSERT (not (null binders))
-    addLoc (LambdaBodyOf binders) (
-    addInScopeVars binders (
-	lintCoreExpr expr   `thenMaybeL` \ body_ty ->
-	returnL (Just (foldr (mkFunTy . getIdUniType) body_ty binders))
-    ))
-
-lintCoreExpr (CoTyLam tyvar expr)
-  = lintCoreExpr expr		`thenMaybeL` \ body_ty ->
-    case quantifyTy [tyvar] body_ty of
-      (_, ty) -> returnL (Just ty) -- not worried about the TyVarTemplates that come back
-
-lintCoreExpr e@(CoCase scrut alts)
- = lintCoreExpr scrut		`thenMaybeL` \ scrut_ty ->
-
-	-- Check that it is a data type
-   case getUniDataTyCon_maybe scrut_ty of
-	Nothing -> addErrL (mkCaseDataConMsg e)	`thenL_`
-		   returnL Nothing
-	Just (tycon, _, _)
-		-> lintCoreAlts alts scrut_ty tycon
-
-lintCoreAlts :: PlainCoreCaseAlternatives
-	     -> UniType 		-- Type of scrutinee
+\begin{code}
+lintCoreArgs :: Bool -> CoreExpr -> Type -> [CoreArg] -> LintM (Maybe Type)
+
+lintCoreArgs _          _ ty [] = returnL (Just ty)
+lintCoreArgs checkTyApp e ty (a : args)
+  = lintCoreArg  checkTyApp e ty  a `thenMaybeL` \ res ->
+    lintCoreArgs checkTyApp e res args
+\end{code}
+
+%************************************************************************
+%*									*
+\subsection[lintCoreArg]{lintCoreArg}
+%*									*
+%************************************************************************
+
+\begin{code}
+lintCoreArg :: Bool -> CoreExpr -> Type -> CoreArg -> LintM (Maybe Type)
+
+lintCoreArg _ e ty (LitArg lit)
+  = -- Make sure function type matches argument
+    case (getFunTy_maybe ty) of
+      Just (arg,res) | (literalType lit `eqTy` arg) -> returnL(Just res)
+      _ -> addErrL (mkAppMsg ty (literalType lit) e) `seqL` returnL Nothing
+
+lintCoreArg _ e ty (VarArg v)
+  = -- Make sure variable is bound
+    checkInScope v `seqL`
+    -- Make sure function type matches argument
+    case (getFunTy_maybe ty) of
+      Just (arg,res) | (idType v `eqTy` arg) -> returnL(Just res)
+      _ -> addErrL (mkAppMsg ty (idType v) e) `seqL` returnL Nothing
+
+lintCoreArg checkTyApp e ty a@(TyArg arg_ty)
+  = -- TODO: Check that ty is well-kinded and has no unbound tyvars
+    checkIfSpecDoneL (not (isPrimType arg_ty)) (mkSpecTyAppMsg a)
+    `seqL`
+    case (getForAllTy_maybe ty) of
+      Just (tyvar,body) | (getTyVarKind tyvar == getTypeKind arg_ty) ->
+	returnL(Just(instantiateTy [(tyvar,arg_ty)] body))
+      _ -> addErrL (mkTyAppMsg ty arg_ty e) `seqL` returnL Nothing
+	
+lintCoreArg _ e ty (UsageArg u)
+  = -- TODO: Check that usage has no unbound usage variables
+    case (getForAllUsageTy ty) of
+      Just (uvar,bounds,body) ->
+        -- TODO Check argument satisfies bounds
+        returnL(Just(panic "lintCoreArg:instantiateUsage uvar u body"))
+      _ -> addErrL (mkUsageAppMsg ty u e) `seqL` returnL Nothing
+\end{code}
+
+%************************************************************************
+%*									*
+\subsection[lintCoreAlts]{lintCoreAlts}
+%*									*
+%************************************************************************
+
+\begin{code}
+lintCoreAlts :: CoreCaseAlts
+	     -> Type  			-- Type of scrutinee
 	     -> TyCon			-- TyCon pinned on the case
-	     -> LintM (Maybe UniType)	-- Type of alternatives
-
-lintCoreAlts alts scrut_ty case_tycon
-  = (case alts of
-	 CoAlgAlts alg_alts deflt ->  
-	   chk_prim_type False case_tycon	`thenL_`
-	   chk_non_abstract_type case_tycon	`thenL_`
-	   mapL (lintAlgAlt scrut_ty) alg_alts 	`thenL` \ maybe_alt_tys ->
-	   lintDeflt deflt scrut_ty		`thenL` \ maybe_deflt_ty ->
-	   returnL (maybe_deflt_ty : maybe_alt_tys)
-
-	 CoPrimAlts prim_alts deflt -> 
-	   chk_prim_type True case_tycon	 `thenL_`
-	   mapL (lintPrimAlt scrut_ty) prim_alts `thenL` \ maybe_alt_tys ->
-	   lintDeflt deflt scrut_ty		 `thenL` \ maybe_deflt_ty ->
-	   returnL (maybe_deflt_ty : maybe_alt_tys)
-    )						 `thenL` \ maybe_result_tys ->
-	 -- Check the result types
+	     -> LintM (Maybe Type)	-- Type of alternatives
+
+lintCoreAlts (AlgAlts alts deflt) ty tycon
+  = panic "CoreLint.lintCoreAlts"
+{- LATER:
+  WDP: can't tell what type DNT wants here
+  = -- Check tycon is not a primitive tycon
+    addErrIfL (isPrimTyCon tycon) (mkCasePrimMsg tycon)
+    `seqL`
+    -- Check we have a non-abstract data tycon
+    addErrIfL (not (isVisibleDataTyCon tycon)) (mkCaseAbstractMsg tycon)
+    `seqL`
+    lintDeflt deflt ty
+    `thenL` \maybe_deflt_ty ->
+    mapL (lintAlgAlt ty tycon) alts
+    `thenL` \maybe_alt_tys ->
+    returnL (maybe_deflt_ty : maybe_alt_tys)
+
+lintCoreAlts (PrimAlts alts deflt) ty tycon
+  = -- Check tycon is a primitive tycon
+    addErrIfL (not (isPrimTyCon tycon)) (mkCaseNotPrimMsg tycon)
+    `seqL`
+    mapL (lintPrimAlt ty) alts
+    `thenL` \maybe_alt_tys ->
+    lintDeflt deflt ty
+    `thenL` \maybe_deflt_ty ->
+    returnL (maybe_deflt_ty : maybe_alt_tys)
+    -- Check the result types
+-}
+{-
+    `thenL` \ maybe_result_tys ->
     case catMaybes (maybe_result_tys) of
       []	     -> returnL Nothing
 
-      (first_ty:tys) -> mapL check tys	`thenL_`
+      (first_ty:tys) -> mapL check tys	`seqL`
 			returnL (Just first_ty)
 	where
 	  check ty = checkTys first_ty ty (mkCaseAltMsg alts)
-  where
-    chk_prim_type prim_required tycon
-      = if (isPrimTyCon tycon == prim_required) then
-	    returnL ()
-	else
-	    addErrL (mkCasePrimMsg prim_required tycon)
-
-    chk_non_abstract_type tycon
-      = case (getTyConFamilySize tycon) of
-	  Nothing -> addErrL (mkCaseAbstractMsg tycon)
-	  Just  _ -> returnL ()
-
+-}
 
 lintAlgAlt scrut_ty (con,args,rhs)
-  = (case getUniDataTyCon_maybe scrut_ty of
-      Nothing -> 
+  = (case maybeAppDataTyCon scrut_ty of
+      Nothing ->
 	 addErrL (mkAlgAltMsg1 scrut_ty)
       Just (tycon, tys_applied, cons) ->
 	 let
 	   (_, arg_tys, _) = getInstantiatedDataConSig con tys_applied
 	 in
-	 checkL (con `elem` cons) (mkAlgAltMsg2 scrut_ty con) `thenL_`
-	 checkL (length arg_tys == length args) (mkAlgAltMsg3 con args)	
-								 `thenL_`
-	 mapL check (arg_tys `zipEqual` args)			 `thenL_`
+	 checkL (con `elem` cons) (mkAlgAltMsg2 scrut_ty con) `seqL`
+	 checkL (length arg_tys == length args) (mkAlgAltMsg3 con args)
+								 `seqL`
+	 mapL check (arg_tys `zipEqual` args)			 `seqL`
 	 returnL ()
-    )								 `thenL_`
+    )								 `seqL`
     addInScopeVars args 	(
 	 lintCoreExpr rhs
     )
   where
-    check (ty, arg) = checkTys ty (getIdUniType arg) (mkAlgAltMsg4 ty arg)
+    check (ty, arg) = checkTys ty (idType arg) (mkAlgAltMsg4 ty arg)
 
     -- elem: yes, the elem-list here can sometimes be long-ish,
     -- but as it's use-once, probably not worth doing anything different
@@ -308,18 +361,15 @@ lintAlgAlt scrut_ty (con,args,rhs)
     elem _ []	    = False
     elem x (y:ys)   = x==y || elem x ys
 
-lintPrimAlt scrut_ty alt@(lit,rhs)
- = checkTys (typeOfBasicLit lit) scrut_ty (mkPrimAltMsg alt)	`thenL_`
+lintPrimAlt ty alt@(lit,rhs)
+ = checkTys (literalType lit) ty (mkPrimAltMsg alt) `seqL`
    lintCoreExpr rhs
-   
-lintDeflt CoNoDefault scrut_ty = returnL Nothing
-lintDeflt deflt@(CoBindDefault binder rhs) scrut_ty 
-  = checkTys (getIdUniType binder) scrut_ty (mkDefltMsg deflt)	`thenL_`
-    addInScopeVars [binder] (
-	lintCoreExpr rhs
-    )
-\end{code}
 
+lintDeflt NoDefault _ = returnL Nothing
+lintDeflt deflt@(BindDefault binder rhs) ty
+  = checkTys (idType binder) ty (mkDefltMsg deflt) `seqL`
+    addInScopeVars [binder] (lintCoreExpr rhs)
+\end{code}
 
 %************************************************************************
 %*									*
@@ -338,7 +388,7 @@ type ErrMsg = PprStyle -> Pretty
 
 data LintLocInfo
   = RhsOf Id		-- The variable bound
-  | LambdaBodyOf [Id]	-- The lambda-binder
+  | LambdaBodyOf Id	-- The lambda-binder
   | BodyOfLetRec [Id]	-- One of the binders
   | ImportedUnfolding SrcLoc -- Some imported unfolding (ToDo: say which)
 
@@ -346,9 +396,9 @@ instance Outputable LintLocInfo where
     ppr sty (RhsOf v)
       = ppBesides [ppr sty (getSrcLoc v), ppStr ": [RHS of ", pp_binders sty [v], ppStr "]"]
 
-    ppr sty (LambdaBodyOf bs)
-      = ppBesides [ppr sty (getSrcLoc (head bs)),
-		ppStr ": [in body of lambda with binders ", pp_binders sty bs, ppStr "]"]
+    ppr sty (LambdaBodyOf b)
+      = ppBesides [ppr sty (getSrcLoc b),
+		ppStr ": [in body of lambda with binder ", pp_binder sty b, ppStr "]"]
 
     ppr sty (BodyOfLetRec bs)
       = ppBesides [ppr sty (getSrcLoc (head bs)),
@@ -358,11 +408,10 @@ instance Outputable LintLocInfo where
       = ppBeside (ppr sty locn) (ppStr ": [in an imported unfolding]")
 
 pp_binders :: PprStyle -> [Id] -> Pretty
-pp_binders sty bs
-  = ppInterleave ppComma (map pp_binder bs)
-  where
-    pp_binder b
-      = ppCat [ppr sty b, ppStr "::", ppr sty (getIdUniType b)]
+pp_binders sty bs = ppInterleave ppComma (map (pp_binder sty) bs)
+
+pp_binder :: PprStyle -> Id -> Pretty
+pp_binder sty b = ppCat [ppr sty b, ppStr "::", ppr sty (idType b)]
 \end{code}
 
 \begin{code}
@@ -382,12 +431,12 @@ returnL r spec loc scope errs = (r, errs)
 
 thenL :: LintM a -> (a -> LintM b) -> LintM b
 thenL m k spec loc scope errs
-  = case m spec loc scope errs of 
+  = case m spec loc scope errs of
       (r, errs') -> k r spec loc scope errs'
 
-thenL_ :: LintM a -> LintM b -> LintM b
-thenL_ m k spec loc scope errs
-  = case m spec loc scope errs of 
+seqL :: LintM a -> LintM b -> LintM b
+seqL m k spec loc scope errs
+  = case m spec loc scope errs of
       (_, errs') -> k spec loc scope errs'
 
 thenMaybeL :: LintM (Maybe a) -> (a -> LintM (Maybe b)) -> LintM (Maybe b)
@@ -396,8 +445,8 @@ thenMaybeL m k spec loc scope errs
       (Nothing, errs2) -> (Nothing, errs2)
       (Just r,  errs2) -> k r spec loc scope errs2
 
-thenMaybeL_ :: LintM (Maybe a) -> LintM (Maybe b) -> LintM (Maybe b)
-thenMaybeL_ m k spec loc scope errs
+seqMaybeL :: LintM (Maybe a) -> LintM (Maybe b) -> LintM (Maybe b)
+seqMaybeL m k spec loc scope errs
   = case m spec loc scope errs of
       (Nothing, errs2) -> (Nothing, errs2)
       (Just _,  errs2) -> k spec loc scope errs2
@@ -428,6 +477,9 @@ checkIfSpecDoneL True  msg spec  loc scope errs = ((), errs)
 checkIfSpecDoneL False msg True  loc scope errs = ((), addErr errs msg loc)
 checkIfSpecDoneL False msg False loc scope errs = ((), errs)
 
+addErrIfL pred spec
+  = if pred then addErrL spec else returnL ()
+
 addErrL :: ErrMsg -> LintM ()
 addErrL msg spec loc scope errs = ((), addErr errs msg loc)
 
@@ -463,108 +515,37 @@ addInScopeVars ids m spec loc scope errs
 --  )
 \end{code}
 
-\begin{code}
-checkTyApp :: UniType
-	   -> [UniType]
-	   -> ErrMsg
-	   -> LintM (Maybe UniType)
-
-checkTyApp forall_ty ty_args msg spec_done loc scope errs
-  = if (not spec_done && n_ty_args /= n_tyvars)
-    || (spec_done     && n_ty_args  > n_tyvars)
-    --
-    -- Things are *not* OK if:
-    --
-    -- * Unsaturated type app before specialisation has been done;
-    --
-    -- * Oversaturated type app after specialisation (eta reduction
-    --   may well be happening...);
-    --
-    -- Note: checkTyApp is usually followed by a call to checkSpecTyApp.
-    --
-    then (Nothing,     addErr errs msg loc)
-    else (Just res_ty, errs)
-  where
-    (tyvars, rho_ty) = splitForalls forall_ty
-    n_tyvars = length tyvars
-    n_ty_args = length ty_args
-    leftover_tyvars = drop n_ty_args tyvars
-    inst_env = tyvars `zip` ty_args
-    res_ty = mkForallTy leftover_tyvars (instantiateTy inst_env rho_ty)
-\end{code}
-
-\begin{code}
-checkSpecTyApp :: PlainCoreExpr -> [UniType] -> ErrMsg -> LintM (Maybe ())
-
-checkSpecTyApp expr ty_args msg spec_done loc scope errs
-  = if spec_done
-    && any isUnboxedDataType ty_args
-    && not (an_application_of_error expr)
-    then (Nothing, addErr errs msg loc)
-    else (Just (), errs)
-  where
-     -- always safe (but maybe unfriendly) to say "False"
-    an_application_of_error (CoVar id) | isBottomingId id = True
-    an_application_of_error _ = False
-\end{code}
-
-\begin{code}
-checkFunApp :: UniType 		-- The function type
-	    -> [UniType] 	-- The arg type(s)
-	    -> ErrMsg 		-- Error messgae
-	    -> LintM (Maybe UniType)	-- The result type
-
-checkFunApp fun_ty arg_tys msg spec loc scope errs
-  = cfa res_ty expected_arg_tys arg_tys
-  where
-    (expected_arg_tys, res_ty) = splitTyArgs fun_ty
-
-    cfa res_ty expected []	-- Args have run out; that's fine
-	= (Just (glueTyArgs expected res_ty), errs)
-
-    cfa res_ty [] arg_tys	-- Expected arg tys ran out first; maybe res_ty is a 
-				-- dictionary type which is actually a function?
-	= case splitTyArgs (unDictifyTy res_ty) of
-	    ([], _) 		    -> (Nothing, addErr errs msg loc)	-- Too many args
-	    (new_expected, new_res) -> cfa new_res new_expected arg_tys
-
-    cfa res_ty (expected_arg_ty:expected_arg_tys) (arg_ty:arg_tys)
-	= case (cmpUniType True{-properly-} expected_arg_ty arg_ty) of
-		EQ_ -> cfa res_ty expected_arg_tys arg_tys
-		other -> (Nothing, addErr errs msg loc)			-- Arg mis-match
-\end{code}
-
 \begin{code}
 checkInScope :: Id -> LintM ()
 checkInScope id spec loc scope errs
   = if isLocallyDefined id && not (id `elementOfUniqSet` scope) then
-	((), addErr errs (\ sty -> ppCat [ppr sty id, ppStr "is out of scope"]) loc)
+      ((),addErr errs (\sty -> ppCat [ppr sty id,ppStr "is out of scope"]) loc)
     else
-	((), errs)
+      ((),errs)
 
-checkTys :: UniType -> UniType -> ErrMsg -> LintM ()
+checkTys :: Type -> Type -> ErrMsg -> LintM ()
 checkTys ty1 ty2 msg spec loc scope errs
-  = case (cmpUniType True{-properly-} ty1 ty2) of
-	EQ_   -> ((), errs)
-	other -> ((), addErr errs msg loc)
+  = if ty1 `eqTy` ty2 then ((), errs) else ((), addErr errs msg loc)
 \end{code}
 
 \begin{code}
-mkCaseAltMsg :: PlainCoreCaseAlternatives -> ErrMsg
+mkCaseAltMsg :: CoreCaseAlts -> ErrMsg
 mkCaseAltMsg alts sty
-  = ppAbove (ppStr "In some case alternatives, type of alternatives not all same:")
+  = ppAbove (ppStr "Type of case alternatives not the same:")
 	    (ppr sty alts)
 
-mkCaseDataConMsg :: PlainCoreExpr -> ErrMsg
+mkCaseDataConMsg :: CoreExpr -> ErrMsg
 mkCaseDataConMsg expr sty
-  = ppAbove (ppStr "A case scrutinee not a type-constructor type:")
+  = ppAbove (ppStr "A case scrutinee not of data constructor type:")
 	    (pp_expr sty expr)
 
-mkCasePrimMsg :: Bool -> TyCon -> ErrMsg
-mkCasePrimMsg True tycon sty
+mkCaseNotPrimMsg :: TyCon -> ErrMsg
+mkCaseNotPrimMsg tycon sty
   = ppAbove (ppStr "A primitive case on a non-primitive type:")
 	    (ppr sty tycon)
-mkCasePrimMsg False tycon sty
+
+mkCasePrimMsg :: TyCon -> ErrMsg
+mkCasePrimMsg tycon sty
   = ppAbove (ppStr "An algebraic case on a primitive type:")
 	    (ppr sty tycon)
 
@@ -573,30 +554,41 @@ mkCaseAbstractMsg tycon sty
   = ppAbove (ppStr "An algebraic case on an abstract type:")
 	    (ppr sty tycon)
 
-mkDefltMsg :: PlainCoreCaseDefault -> ErrMsg
+mkDefltMsg :: CoreCaseDefault -> ErrMsg
 mkDefltMsg deflt sty
-  = ppAbove (ppStr "Binder in default case of a case expression doesn't match type of scrutinee:")
+  = ppAbove (ppStr "Binder in case default doesn't match type of scrutinee:")
 	    (ppr sty deflt)
 
-mkFunAppMsg :: UniType -> [UniType] -> PlainCoreExpr -> ErrMsg
-mkFunAppMsg fun_ty arg_tys expr sty
-  = ppAboves [ppStr "In a function application, function type doesn't match arg types:",
-	      ppHang (ppStr "Function type:") 4 (ppr sty fun_ty),
-	      ppHang (ppStr "Arg types:") 4 (ppAboves (map (ppr sty) arg_tys)),
+mkAppMsg :: Type -> Type -> CoreExpr -> ErrMsg
+mkAppMsg fun arg expr sty
+  = ppAboves [ppStr "Argument values doesn't match argument type:",
+	      ppHang (ppStr "Fun type:") 4 (ppr sty fun),
+	      ppHang (ppStr "Arg type:") 4 (ppr sty arg),
+	      ppHang (ppStr "Expression:") 4 (pp_expr sty expr)]
+
+mkTyAppMsg :: Type -> Type -> CoreExpr -> ErrMsg
+mkTyAppMsg ty arg expr sty
+  = panic "mkTyAppMsg"
+{-
+  = ppAboves [ppStr "Illegal type application:",
+	      ppHang (ppStr "Exp type:") 4 (ppr sty exp),
+	      ppHang (ppStr "Arg type:") 4 (ppr sty arg),
 	      ppHang (ppStr "Expression:") 4 (pp_expr sty expr)]
+-}
 
-mkUnappTyMsg :: Id -> UniType -> ErrMsg
-mkUnappTyMsg var ty sty
-  = ppAboves [ppStr "Variable has a for-all type, but isn't applied to any types.",
-	      ppBeside (ppStr "Var:      ") (ppr sty var),
-	      ppBeside (ppStr "Its type: ") (ppr sty ty)]
+mkUsageAppMsg :: Type -> Usage -> CoreExpr -> ErrMsg
+mkUsageAppMsg ty u expr sty
+  = ppAboves [ppStr "Illegal usage application:",
+	      ppHang (ppStr "Exp type:") 4 (ppr sty ty),
+	      ppHang (ppStr "Usage exp:") 4 (ppr sty u),
+	      ppHang (ppStr "Expression:") 4 (pp_expr sty expr)]
 
-mkAlgAltMsg1 :: UniType -> ErrMsg
+mkAlgAltMsg1 :: Type -> ErrMsg
 mkAlgAltMsg1 ty sty
   = ppAbove (ppStr "In some case statement, type of scrutinee is not a data type:")
 	    (ppr sty ty)
 
-mkAlgAltMsg2 :: UniType -> Id -> ErrMsg
+mkAlgAltMsg2 :: Type -> Id -> ErrMsg
 mkAlgAltMsg2 ty con sty
   = ppAboves [
 	ppStr "In some algebraic case alternative, constructor is not a constructor of scrutinee type:",
@@ -612,7 +604,7 @@ mkAlgAltMsg3 con alts sty
 	ppr sty alts
     ]
 
-mkAlgAltMsg4 :: UniType -> Id -> ErrMsg
+mkAlgAltMsg4 :: Type -> Id -> ErrMsg
 mkAlgAltMsg4 ty arg sty
   = ppAboves [
 	ppStr "In some algebraic case alternative, type of argument doesn't match data constructor:",
@@ -620,37 +612,34 @@ mkAlgAltMsg4 ty arg sty
 	ppr sty arg
     ]
 
-mkPrimAltMsg :: (BasicLit, PlainCoreExpr) -> ErrMsg
+mkPrimAltMsg :: (Literal, CoreExpr) -> ErrMsg
 mkPrimAltMsg alt sty
-  = ppAbove (ppStr "In a primitive case alternative, type of literal doesn't match type of scrutinee:")
+  = ppAbove
+    (ppStr "In a primitive case alternative, type of literal doesn't match type of scrutinee:")
 	    (ppr sty alt)
 
-mkRhsMsg :: Id -> UniType -> ErrMsg
+mkRhsMsg :: Id -> Type -> ErrMsg
 mkRhsMsg binder ty sty
-  = ppAboves [ppCat [ppStr "The type of this binder doesn't match the type of its RHS:", 
-		     ppr sty binder],
-	      ppCat [ppStr "Binder's type:", ppr sty (getIdUniType binder)],
-	      ppCat [ppStr "Rhs type:", ppr sty ty]
-	     ]
+  = ppAboves
+    [ppCat [ppStr "The type of this binder doesn't match the type of its RHS:",
+	    ppr sty binder],
+     ppCat [ppStr "Binder's type:", ppr sty (idType binder)],
+     ppCat [ppStr "Rhs type:", ppr sty ty]]
 
-mkRhsPrimMsg :: Id -> PlainCoreExpr -> ErrMsg
+mkRhsPrimMsg :: Id -> CoreExpr -> ErrMsg
 mkRhsPrimMsg binder rhs sty
-  = ppAboves [ppCat [ppStr "The type of this binder is primitive:", 
+  = ppAboves [ppCat [ppStr "The type of this binder is primitive:",
 		     ppr sty binder],
-	      ppCat [ppStr "Binder's type:", ppr sty (getIdUniType binder)]
+	      ppCat [ppStr "Binder's type:", ppr sty (idType binder)]
 	     ]
 
-mkTyAppMsg :: PlainCoreExpr -> ErrMsg
-mkTyAppMsg expr sty
-  = ppAboves [ppStr "In a type application, either the function's type doesn't match",
-	      ppStr "the argument types, or an argument type is primitive:",
-	      pp_expr sty expr]
-
-mkSpecTyAppMsg :: PlainCoreExpr -> ErrMsg
-mkSpecTyAppMsg expr sty
-  = ppAbove (ppStr "Unboxed types in a type application (after specialisation):")
-	    (pp_expr sty expr)
+mkSpecTyAppMsg :: CoreArg -> ErrMsg
+mkSpecTyAppMsg arg sty
+  = ppAbove
+      (ppStr "Unboxed types in a type application (after specialisation):")
+      (ppr sty arg)
 
+pp_expr :: PprStyle -> CoreExpr -> Pretty
 pp_expr sty expr
-  = pprCoreExpr sty pprBigCoreBinder pprTypedCoreBinder pprTypedCoreBinder expr
+  = pprCoreExpr sty (pprBigCoreBinder sty) (pprTypedCoreBinder sty) (pprTypedCoreBinder sty) expr
 \end{code}
diff --git a/ghc/compiler/coreSyn/CoreSyn.hi b/ghc/compiler/coreSyn/CoreSyn.hi
deleted file mode 100644
index e8745538cc..0000000000
--- a/ghc/compiler/coreSyn/CoreSyn.hi
+++ /dev/null
@@ -1,46 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface CoreSyn where
-import BasicLit(BasicLit)
-import CharSeq(CSeq)
-import CmdLineOpts(GlobalSwitch)
-import CostCentre(CostCentre)
-import Id(Id)
-import Maybes(Labda)
-import Outputable(Outputable)
-import PreludePS(_PackedString)
-import PreludeRatio(Ratio(..))
-import Pretty(Delay, PprStyle, PrettyRep)
-import PrimKind(PrimKind)
-import PrimOps(PrimOp)
-import TyCon(TyCon)
-import TyVar(TyVar)
-import UniType(UniType)
-data BasicLit 
-data CoreArg a   = TypeArg UniType | ValArg (CoreAtom a)
-data CoreAtom a   = CoVarAtom a | CoLitAtom BasicLit
-data CoreBinding a b   = CoNonRec a (CoreExpr a b) | CoRec [(a, CoreExpr a b)]
-data CoreCaseAlternatives a b   = CoAlgAlts [(Id, [a], CoreExpr a b)] (CoreCaseDefault a b) | CoPrimAlts [(BasicLit, CoreExpr a b)] (CoreCaseDefault a b)
-data CoreCaseDefault a b   = CoNoDefault | CoBindDefault a (CoreExpr a b)
-data CoreExpr a b   = CoVar b | CoLit BasicLit | CoCon Id [UniType] [CoreAtom b] | CoPrim PrimOp [UniType] [CoreAtom b] | CoLam [a] (CoreExpr a b) | CoTyLam TyVar (CoreExpr a b) | CoApp (CoreExpr a b) (CoreAtom b) | CoTyApp (CoreExpr a b) UniType | CoCase (CoreExpr a b) (CoreCaseAlternatives a b) | CoLet (CoreBinding a b) (CoreExpr a b) | CoSCC CostCentre (CoreExpr a b)
-data CostCentre 
-data Id 
-data Labda a 
-data PprStyle 
-data PrettyRep 
-data PrimOp 
-data TyCon 
-data TyVar 
-data UniType 
-applyToArgs :: CoreExpr a b -> [CoreArg b] -> CoreExpr a b
-collectArgs :: CoreExpr a b -> (CoreExpr a b, [CoreArg b])
-decomposeArgs :: [CoreArg a] -> ([UniType], [CoreAtom a], [CoreArg a])
-mkCoTyApp :: CoreExpr a b -> UniType -> CoreExpr a b
-pprCoreBinding :: PprStyle -> (PprStyle -> a -> Int -> Bool -> PrettyRep) -> (PprStyle -> a -> Int -> Bool -> PrettyRep) -> (PprStyle -> b -> Int -> Bool -> PrettyRep) -> CoreBinding a b -> Int -> Bool -> PrettyRep
-pprCoreExpr :: PprStyle -> (PprStyle -> a -> Int -> Bool -> PrettyRep) -> (PprStyle -> a -> Int -> Bool -> PrettyRep) -> (PprStyle -> b -> Int -> Bool -> PrettyRep) -> CoreExpr a b -> Int -> Bool -> PrettyRep
-instance Outputable a => Outputable (CoreArg a)
-instance Outputable a => Outputable (CoreAtom a)
-instance (Outputable a, Outputable b) => Outputable (CoreBinding a b)
-instance (Outputable a, Outputable b) => Outputable (CoreCaseAlternatives a b)
-instance (Outputable a, Outputable b) => Outputable (CoreCaseDefault a b)
-instance (Outputable a, Outputable b) => Outputable (CoreExpr a b)
-
diff --git a/ghc/compiler/coreSyn/CoreSyn.lhs b/ghc/compiler/coreSyn/CoreSyn.lhs
index f7accde8ee..1599273d24 100644
--- a/ghc/compiler/coreSyn/CoreSyn.lhs
+++ b/ghc/compiler/coreSyn/CoreSyn.lhs
@@ -1,5 +1,5 @@
 %
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
 %
 \section[CoreSyn]{A data type for the Haskell compiler midsection}
 
@@ -7,29 +7,63 @@
 #include "HsVersions.h"
 
 module CoreSyn (
-	GenCoreBinding(..), GenCoreExpr(..), GenCoreAtom(..),
-	GenCoreCaseAlternatives(..), GenCoreCaseDefault(..),
-	pprCoreBinding, pprCoreExpr,
-
-	GenCoreArg(..), applyToArgs, decomposeArgs, collectArgs,
+	GenCoreBinding(..), GenCoreExpr(..),
+	GenCoreArg(..),GenCoreBinder(..), GenCoreCaseAlts(..),
+	GenCoreCaseDefault(..),
+
+	bindersOf, pairsFromCoreBinds, rhssOfBind,
+
+	mkGenApp, mkValApp, mkTyApp, mkUseApp,
+	mkApp, mkCon, mkPrim,
+	mkValLam, mkTyLam, mkUseLam,
+	mkLam,
+	digForLambdas,
+	
+	collectArgs, isValArg,
+
+	mkCoLetAny, mkCoLetNoUnboxed, mkCoLetUnboxedToCase,
+	mkCoLetsAny, mkCoLetsNoUnboxed, mkCoLetsUnboxedToCase,
+	mkCoLetrecAny, mkCoLetrecNoUnboxed,
+
+	rhssOfAlts,
+
+	-- Common type instantiation...
+	CoreBinding(..),
+	CoreExpr(..),
+	CoreBinder(..),
+	CoreArg(..),
+	CoreCaseAlts(..),
+	CoreCaseDefault(..),
+
+	-- And not-so-common type instantiations...
+	TaggedCoreBinding(..),
+	TaggedCoreExpr(..),
+	TaggedCoreBinder(..),
+	TaggedCoreArg(..),
+	TaggedCoreCaseAlts(..),
+	TaggedCoreCaseDefault(..),
+
+	SimplifiableCoreBinding(..),
+	SimplifiableCoreExpr(..),
+	SimplifiableCoreBinder(..),
+	SimplifiableCoreArg(..),
+	SimplifiableCoreCaseAlts(..),
+	SimplifiableCoreCaseDefault(..)
 
 	-- and to make the interface self-sufficient ...
+
     ) where
 
-import PrelInfo		( PrimOp, PrimRep
-			  IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
-			  IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
-			)
-import Type		( isPrimType, pprParendUniType, TyVar, TyCon, Type
-			)
-import Literal		( Literal )
-import Id		( getIdUniType, isBottomingId, Id
-			  IF_ATTACK_PRAGMAS(COMMA bottomIsGuaranteed)
-			)
-import Outputable
-import Pretty
+import Ubiq{-uitous-}
+
 import CostCentre	( showCostCentre, CostCentre )
-import Util
+import Id		( idType )
+import Usage		( UVar(..) )
+import Util		( panic, assertPanic )
+
+isUnboxedDataType = panic "CoreSyn.isUnboxedDataType"
+--eqId :: Id -> Id -> Bool
+eqId = panic "CoreSyn.eqId"
 \end{code}
 
 %************************************************************************
@@ -52,6 +86,25 @@ data GenCoreBinding val_bdr val_occ tyvar uvar
   | Rec		[(val_bdr, GenCoreExpr val_bdr val_occ tyvar uvar)]
 \end{code}
 
+\begin{code}
+bindersOf :: GenCoreBinding val_bdr val_occ tyvar uvar -> [val_bdr]
+
+pairsFromCoreBinds ::
+  [GenCoreBinding val_bdr val_occ tyvar uvar] ->
+  [(val_bdr, GenCoreExpr val_bdr val_occ tyvar uvar)]
+
+rhssOfBind :: GenCoreBinding val_bdr val_occ tyvar uvar -> [GenCoreExpr val_bdr val_occ tyvar uvar]
+
+bindersOf (NonRec binder _) = [binder]
+bindersOf (Rec pairs)       = [binder | (binder, _) <- pairs]
+
+pairsFromCoreBinds []		       = []
+pairsFromCoreBinds ((NonRec b e) : bs) = (b,e) :  pairsFromCoreBinds bs
+pairsFromCoreBinds ((Rec  pairs) : bs) = pairs ++ pairsFromCoreBinds bs
+
+rhssOfBind (NonRec _ rhs) = [rhs]
+rhssOfBind (Rec pairs)    = [rhs | (_,rhs) <- pairs]
+\end{code}
 
 %************************************************************************
 %*									*
@@ -74,22 +127,17 @@ simplifier (and by the desugarer when it knows what it's doing).  The
 desugarer sets up constructors as applications of global @Vars@s.
 
 \begin{code}
-     | Con	Id (GenType tyvar) [GenCoreArg val_occ tyvar uvar]
+     | Con	Id [GenCoreArg val_occ tyvar uvar]
 		-- Saturated constructor application:
 		-- The constructor is a function of the form:
 		--	/\ a1 -> ... /\ am -> \ b1 -> ... \ bn ->
 		-- <expr> where "/\" is a type lambda and "\" the
 		-- regular kind; there will be "m" Types and
 		-- "n" bindees in the Con args.
-		--
-		-- The type given is the result type of the application;
-		-- you can figure out the argument types from it if you want.
 
-     | Prim	PrimOp Type [GenCoreArg val_occ tyvar uvar]
+     | Prim	PrimOp [GenCoreArg val_occ tyvar uvar]
 		-- saturated primitive operation;
 		-- comment on Cons applies here, too.
-		-- The types work the same way
-		-- (PrimitiveOps may be polymorphic).
 \end{code}
 
 Ye olde abstraction and application operators.
@@ -104,10 +152,10 @@ Ye olde abstraction and application operators.
 Case expressions (\tr{case <expr> of <List of alternatives>}): there
 are really two flavours masquerading here---those for scrutinising
 {\em algebraic} types and those for {\em primitive} types.  Please see
-under @GenCoreCaseAlternatives@.
+under @GenCoreCaseAlts@.
 \begin{code}
      | Case	(GenCoreExpr val_bdr val_occ tyvar uvar)
-		(GenCoreCaseAlternatives val_bdr val_occ tyvar uvar)
+		(GenCoreCaseAlts val_bdr val_occ tyvar uvar)
 \end{code}
 
 A Core case expression \tr{case e of v -> ...} implies evaluation of
@@ -119,7 +167,7 @@ doesn't buy you much, and it is an easy way to mess up variable
 scoping.
 \begin{code}
      | Let	(GenCoreBinding val_bdr val_occ tyvar uvar)
-		(GenCoreExpr binder val_occ tyvar uvar)
+		(GenCoreExpr val_bdr val_occ tyvar uvar)
 		-- both recursive and non-.
 		-- The "GenCoreBinding" records that information
 \end{code}
@@ -134,6 +182,102 @@ transformations of which we are unaware.
 \end{code}
 
 
+%************************************************************************
+%*									*
+\subsection{Core-constructing functions with checking}
+%*									*
+%************************************************************************
+
+When making @Lets@, we may want to take evasive action if the thing
+being bound has unboxed type. We have different variants ...
+
+@mkCoLet(s|rec)Any@ 		let-binds any binding, regardless of type
+@mkCoLet(s|rec)NoUnboxed@ 	prohibits unboxed bindings
+@mkCoLet(s)UnboxedToCase@ 	converts an unboxed binding to a case
+				(unboxed bindings in a letrec are still prohibited)
+
+\begin{code}
+mkCoLetAny :: GenCoreBinding val_bdr val_occ tyvar uvar
+	   -> GenCoreExpr    val_bdr val_occ tyvar uvar
+	   -> GenCoreExpr    val_bdr val_occ tyvar uvar
+mkCoLetsAny :: [GenCoreBinding val_bdr val_occ tyvar uvar] ->
+		GenCoreExpr val_bdr val_occ tyvar uvar ->
+		GenCoreExpr val_bdr val_occ tyvar uvar
+mkCoLetrecAny :: [(val_bdr, GenCoreExpr val_bdr val_occ tyvar uvar)]
+	      -> GenCoreExpr val_bdr val_occ tyvar uvar
+	      -> GenCoreExpr val_bdr val_occ tyvar uvar
+
+mkCoLetrecAny []    body = body
+mkCoLetrecAny binds body = Let (Rec binds) body
+
+mkCoLetsAny []    expr = expr
+mkCoLetsAny binds expr = foldr mkCoLetAny expr binds
+
+mkCoLetAny bind@(Rec binds) body = mkCoLetrecAny binds body
+mkCoLetAny bind@(NonRec binder rhs) body
+  = case body of
+      Var binder2 | binder `eqId` binder2
+	 -> rhs   -- hey, I have the rhs
+      other
+	 -> Let bind body
+\end{code}
+
+\begin{code}
+--mkCoLetNoUnboxed ::
+--  GenCoreBinding val_bdr val_occ tyvar uvar ->
+--  GenCoreExpr val_bdr val_occ tyvar uvar ->
+--  GenCoreExpr val_bdr val_occ tyvar uvar
+
+mkCoLetNoUnboxed bind@(Rec binds) body
+  = mkCoLetrecNoUnboxed binds body
+mkCoLetNoUnboxed bind@(NonRec binder rhs) body
+  = --ASSERT (not (isUnboxedDataType (idType binder)))
+    case body of
+      Var binder2 | binder `eqId` binder2
+	 -> rhs   -- hey, I have the rhs
+      other
+	 -> Let bind body
+
+mkCoLetsNoUnboxed []    expr = expr
+mkCoLetsNoUnboxed binds expr = foldr mkCoLetNoUnboxed expr binds
+
+--mkCoLetrecNoUnboxed :: [(Id, CoreExpr)]	-- bindings
+--  	            -> CoreExpr		-- body
+--		    -> CoreExpr 		-- result
+
+mkCoLetrecNoUnboxed []    body = body
+mkCoLetrecNoUnboxed binds body
+  = ASSERT (all is_boxed_bind binds)
+    Let (Rec binds) body
+  where
+    is_boxed_bind (binder, rhs)
+      = (not . isUnboxedDataType . idType) binder
+\end{code}
+
+\begin{code}
+--mkCoLetUnboxedToCase ::
+--  GenCoreBinding val_bdr val_occ tyvar uvar ->
+--  GenCoreExpr val_bdr val_occ tyvar uvar ->
+--  GenCoreExpr val_bdr val_occ tyvar uvar
+
+mkCoLetUnboxedToCase bind@(Rec binds) body
+  = mkCoLetrecNoUnboxed binds body
+mkCoLetUnboxedToCase bind@(NonRec binder rhs) body
+  = case body of
+      Var binder2 | binder `eqId` binder2
+	 -> rhs   -- hey, I have the rhs
+      other
+	 -> if (not (isUnboxedDataType (idType binder))) then
+		Let bind body		 -- boxed...
+	    else
+		Case rhs		  -- unboxed...
+	    	  (PrimAlts []
+		    (BindDefault binder body))
+
+mkCoLetsUnboxedToCase []    expr = expr
+mkCoLetsUnboxedToCase binds expr = foldr mkCoLetUnboxedToCase expr binds
+\end{code}
+
 %************************************************************************
 %*									*
 \subsection{Case alternatives in @GenCoreExpr@}
@@ -157,8 +301,7 @@ Case e [ BindDefaultAlt x -> b ]
 \end{verbatim}
 
 \begin{code}
-data GenCoreCaseAlternatives val_bdr val_occ tyvar uvar
-
+data GenCoreCaseAlts val_bdr val_occ tyvar uvar
   = AlgAlts	[(Id,				-- alts: data constructor,
 		  [val_bdr],			-- constructor's parameters,
 		  GenCoreExpr val_bdr val_occ tyvar uvar)]	-- rhs.
@@ -179,300 +322,228 @@ data GenCoreCaseDefault val_bdr val_occ tyvar uvar
 						-- be used in RHS.
 \end{code}
 
+\begin{code}
+rhssOfAlts (AlgAlts alts deflt)  = rhssOfDeflt deflt ++ [rhs | (_,_,rhs) <- alts]
+rhssOfAlts (PrimAlts alts deflt) = rhssOfDeflt deflt ++ [rhs | (_,rhs)   <- alts]
+
+rhssOfDeflt NoDefault		= []
+rhssOfDeflt (BindDefault _ rhs) = [rhs]
+\end{code}
+
 %************************************************************************
 %*									*
-\subsection[CoreSyn-arguments]{Core ``argument'' wrapper type}
+\subsection{Core binders}
 %*									*
 %************************************************************************
 
 \begin{code}
-data GenCoreAtom val_occ tyvar uvar
-  = LitAtom	Literal
-  | VarAtom	val_occ
-  | TyAtom	(GenType tyvar)
-  | UsageAtom	(Usage uvar)
-
+data GenCoreBinder val_bdr tyvar uvar
+  = ValBinder	val_bdr
+  | TyBinder	tyvar
+  | UsageBinder	uvar
+\end{code}
 
-===+*** fix from here down ****===
-=================================
+Clump Lams together if possible.
 
-instance Outputable bindee => Outputable (GenCoreArg bindee) where
-  ppr sty (ValArg atom) = ppr sty atom
-  ppr sty (TypeArg ty)  = ppr sty ty
+\begin{code}
+mkValLam :: [val_bdr]
+	 -> GenCoreExpr val_bdr val_occ tyvar uvar
+	 -> GenCoreExpr val_bdr val_occ tyvar uvar
+mkTyLam  :: [tyvar]
+	 -> GenCoreExpr val_bdr val_occ tyvar uvar
+	 -> GenCoreExpr val_bdr val_occ tyvar uvar
+mkUseLam :: [uvar]
+	 -> GenCoreExpr val_bdr val_occ tyvar uvar
+	 -> GenCoreExpr val_bdr val_occ tyvar uvar
+
+mkValLam binders body = foldr (Lam . ValBinder)   body binders
+mkTyLam  binders body = foldr (Lam . TyBinder)    body binders
+mkUseLam binders body = foldr (Lam . UsageBinder) body binders
+
+mkLam :: [tyvar] -> [val_bdr] -- ToDo: could add a [uvar] arg...
+	 -> GenCoreExpr val_bdr val_occ tyvar uvar
+	 -> GenCoreExpr val_bdr val_occ tyvar uvar
+
+mkLam tyvars valvars body
+  = mkTyLam tyvars (mkValLam valvars body)
 \end{code}
 
+We often want to strip off leading lambdas before getting down to
+business.  @digForLambdas@ is your friend.
+
+We expect (by convention) usage-, type-, and value- lambdas in that
+order.
+
 \begin{code}
-applyToArgs :: GenCoreExpr val_bdr bindee
-	    -> [GenCoreArg bindee]
-	    -> GenCoreExpr val_bdr bindee
+digForLambdas ::
+  GenCoreExpr val_bdr val_occ tyvar uvar ->
+  ([uvar], [tyvar], [val_bdr], GenCoreExpr val_bdr val_occ tyvar uvar)
 
-applyToArgs fun []		    = fun
-applyToArgs fun (ValArg val : args) = applyToArgs (App  fun val) args
-applyToArgs fun (TypeArg ty : args) = applyToArgs (CoTyApp fun ty) args
+digForLambdas (Lam (UsageBinder u) body)
+  = let
+	(uvars, tyvars, args, final_body) = digForLambdas body
+    in
+    (u:uvars, tyvars, args, final_body)
+
+digForLambdas other
+  = let
+	(tyvars, args, body) = dig_for_tyvars other
+    in
+    ([], tyvars, args, body)
+  where
+    dig_for_tyvars (Lam (TyBinder tv) body)
+      = let
+	    (tyvars, args, body2) = dig_for_tyvars body
+	in
+	(tv : tyvars, args, body2)
+
+    dig_for_tyvars body
+      = ASSERT(not (usage_lambda body))
+	let
+	    (args, body2) = dig_for_valvars body
+	in
+	([], args, body2)
+
+    ---------------------------------------
+    dig_for_valvars (Lam (ValBinder v) body)
+      = let
+	    (args, body2) = dig_for_valvars body
+	in
+	(v : args, body2)
+
+    dig_for_valvars body
+      = ASSERT(not (usage_lambda body))
+	ASSERT(not (tyvar_lambda body))
+	([], body)
+
+    ---------------------------------------
+    usage_lambda (Lam (UsageBinder _) _) = True
+    usage_lambda _			 = False
+
+    tyvar_lambda (Lam (TyBinder _) _)    = True
+    tyvar_lambda _			 = False
 \end{code}
 
-@decomposeArgs@ just pulls of the contiguous TypeArg-then-ValArg block
-on the front of the args.  Pretty common.
+%************************************************************************
+%*									*
+\subsection{Core arguments (atoms)}
+%*									*
+%************************************************************************
 
 \begin{code}
-decomposeArgs :: [GenCoreArg bindee]
-	      -> ([Type], [GenCoreAtom bindee], [GenCoreArg bindee])
-
-decomposeArgs [] = ([],[],[])
+data GenCoreArg val_occ tyvar uvar
+  = LitArg	Literal
+  | VarArg	val_occ
+  | TyArg	(GenType tyvar uvar)
+  | UsageArg	(GenUsage uvar)
+\end{code}
 
-decomposeArgs (TypeArg ty : args)
-  = case (decomposeArgs args) of { (tys, vals, rest) ->
-    (ty:tys, vals, rest) }
+General and specific forms:
+\begin{code}
+mkGenApp :: GenCoreExpr val_bdr val_occ tyvar uvar
+	 -> [GenCoreArg val_occ tyvar uvar]
+	 -> GenCoreExpr val_bdr val_occ tyvar uvar
+mkTyApp  :: GenCoreExpr val_bdr val_occ tyvar uvar
+	 -> [GenType tyvar uvar]
+	 -> GenCoreExpr val_bdr val_occ tyvar uvar
+mkUseApp :: GenCoreExpr val_bdr val_occ tyvar uvar
+	 -> [GenUsage uvar]
+	 -> GenCoreExpr val_bdr val_occ tyvar uvar
+mkValApp :: GenCoreExpr val_bdr val_occ tyvar uvar
+	 -> [GenCoreArg val_occ tyvar uvar] -- but we ASSERT they are LitArg or VarArg
+	 -> GenCoreExpr val_bdr val_occ tyvar uvar
+
+mkGenApp f args = foldl App		  		   f args
+mkTyApp  f args = foldl (\ e a -> App e (TyArg a))	   f args
+mkUseApp f args = foldl (\ e a -> App e (UsageArg a))	   f args
+mkValApp f args = foldl (\ e a -> App e (is_Lit_or_Var a)) f args
+
+#ifndef DEBUG
+is_Lit_or_Var a = a
+#else
+is_Lit_or_Var a
+  = if isValArg a then a else panic "CoreSyn.mkValApps:not LitArg or VarArg"
+#endif
+
+isValArg (LitArg _) = True  -- often used for sanity-checking
+isValArg (VarArg _) = True
+isValArg _	    = False
+\end{code}
 
-decomposeArgs (ValArg val : args)
-  = case (do_vals args) of { (vals, rest) ->
-    ([], val:vals, rest) }
-  where
-    do_vals (ValArg val : args)
-      = case (do_vals args) of { (vals, rest) ->
-    	(val:vals, rest) }
+\begin{code}
+mkApp  fun = mk_thing (mkGenApp fun)
+mkCon  con = mk_thing (Con      con)
+mkPrim op  = mk_thing (Prim     op)
 
-    do_vals args = ([], args)
+mk_thing thing uses tys vals
+  = thing (map UsageArg uses ++ map TyArg tys ++ map is_Lit_or_Var vals)
 \end{code}
 
 @collectArgs@ takes an application expression, returning the function
 and the arguments to which it is applied.
 
 \begin{code}
-collectArgs :: GenCoreExpr val_bdr bindee
-	    -> (GenCoreExpr val_bdr bindee, [GenCoreArg bindee])
+collectArgs :: GenCoreExpr val_bdr val_occ tyvar uvar
+	    -> (GenCoreExpr val_bdr val_occ tyvar uvar,
+	        [GenCoreArg val_occ tyvar uvar])
 
 collectArgs expr
   = collect expr []
   where
-    collect (App fun arg)  args = collect fun (ValArg arg : args)
-    collect (CoTyApp fun ty) args = collect fun (TypeArg ty : args)
-    collect other_expr args 	  = (other_expr, args)
+    collect (App fun arg) args = collect fun (arg : args)
+    collect fun		  args = (fun, args)
 \end{code}
 
 %************************************************************************
 %*									*
-\subsection[CoreSyn-output]{Instance declarations for output}
+\subsection{The main @Core*@ instantiation of the @GenCore*@ types}
 %*									*
 %************************************************************************
 
-@pprCoreBinding@ and @pprCoreExpr@ let you give special printing
-function for ``major'' val_bdrs (those next to equal signs :-),
-``minor'' ones (lambda-bound, case-bound), and bindees.  They would
-usually be called through some intermediary.
-
 \begin{code}
-pprCoreBinding
-	:: PprStyle
-	-> (PprStyle -> bndr -> Pretty)	-- to print "major" val_bdrs
-	-> (PprStyle -> bndr -> Pretty) -- to print "minor" val_bdrs
-	-> (PprStyle -> bdee -> Pretty) -- to print bindees
-	-> GenCoreBinding bndr bdee
-	-> Pretty
-
-pprCoreBinding sty pbdr1 pbdr2 pbdee (NonRec val_bdr expr)
-  = ppHang (ppCat [pbdr1 sty val_bdr, ppEquals])
-	 4 (pprCoreExpr sty pbdr1 pbdr2 pbdee expr)
-
-pprCoreBinding sty pbdr1 pbdr2 pbdee (Rec binds)
-  = ppAboves [ifPprDebug sty (ppStr "{- Rec -}"),
-	      ppAboves (map ppr_bind binds),
-	      ifPprDebug sty (ppStr "{- end Rec -}")]
-  where
-    ppr_bind (val_bdr, expr)
-      = ppHang (ppCat [pbdr1 sty val_bdr, ppEquals])
-	     4 (pprCoreExpr sty pbdr1 pbdr2 pbdee expr)
-\end{code}
-
-\begin{code}
-instance (Outputable bndr, Outputable bdee)
-		=> Outputable (GenCoreBinding bndr bdee) where
-    ppr sty bind = pprCoreBinding sty ppr ppr ppr bind
+type CoreBinding = GenCoreBinding  Id Id TyVar UVar
+type CoreExpr    = GenCoreExpr     Id Id TyVar UVar
+type CoreBinder	 = GenCoreBinder   Id    TyVar UVar
+type CoreArg     = GenCoreArg         Id TyVar UVar
 
-instance (Outputable bndr, Outputable bdee)
-		=> Outputable (GenCoreExpr bndr bdee) where
-    ppr sty expr = pprCoreExpr sty ppr ppr ppr expr
-
-instance Outputable bdee => Outputable (GenCoreAtom bdee) where
-    ppr sty atom = pprCoreAtom sty ppr atom
+type CoreCaseAlts    = GenCoreCaseAlts    Id Id TyVar UVar
+type CoreCaseDefault = GenCoreCaseDefault Id Id TyVar UVar
 \end{code}
 
-\begin{code}
-pprCoreAtom
-	:: PprStyle
-	-> (PprStyle -> bdee -> Pretty) -- to print bindees
-	-> GenCoreAtom bdee
-	-> Pretty
-
-pprCoreAtom sty pbdee (LitAtom lit) = ppr sty lit
-pprCoreAtom sty pbdee (VarAtom v)   = pbdee sty v
-\end{code}
+%************************************************************************
+%*									*
+\subsection{The @TaggedCore*@ instantiation of the @GenCore*@ types}
+%*									*
+%************************************************************************
 
+Binders are ``tagged'' with a \tr{t}:
 \begin{code}
-pprCoreExpr, pprParendCoreExpr
-	:: PprStyle
-	-> (PprStyle -> bndr -> Pretty)	-- to print "major" val_bdrs
-	-> (PprStyle -> bndr -> Pretty) -- to print "minor" val_bdrs
-	-> (PprStyle -> bdee -> Pretty) -- to print bindees
-	-> GenCoreExpr bndr bdee
-	-> Pretty
-
-pprCoreExpr sty pbdr1 pbdr2 pbdee (Var name) = pbdee sty name
-
-pprCoreExpr sty pbdr1 pbdr2 pbdee (Lit literal) = ppr sty literal
-
-pprCoreExpr sty pbdr1 pbdr2 pbdee (Con con [] []) = ppr sty con
-
-pprCoreExpr sty pbdr1 pbdr2 pbdee (Con con types args)
-  = ppHang (ppBesides [ppr sty con, ppChar '!'])
-	 4 (ppSep (  (map (pprParendUniType sty) types)
-		  ++ (map (pprCoreAtom sty pbdee) args)))
-
-pprCoreExpr sty pbdr1 pbdr2 pbdee (Prim prim tys args)
-  = ppHang (ppBesides [ppr sty prim, ppChar '!'])
-	 4 (ppSep (  (map (pprParendUniType sty) tys)
-		  ++ (map (pprCoreAtom sty pbdee) args) ))
-
-pprCoreExpr sty pbdr1 pbdr2 pbdee (Lam val_bdr expr)
-  = ppHang (ppCat [ppStr "\\", pbdr2 sty val_bdr, ppStr "->"])
-	 4 (pprCoreExpr sty pbdr1 pbdr2 pbdee expr)
-
-pprCoreExpr sty pbdr1 pbdr2 pbdee (CoTyLam tyvar expr)
-  = ppHang (ppCat [ppStr "/\\", interppSP sty (tyvar:tyvars),
-		   ppStr "->", pp_varss var_lists])
-	   4 (pprCoreExpr sty pbdr1 pbdr2 pbdee expr_after)
-  where
-    (tyvars, var_lists, expr_after) = collect_tyvars expr
+type Tagged t = (Id, t)
 
-    collect_tyvars (CoTyLam tyv e) = ( tyv:tyvs, vs, e_after )
-      where (tyvs, vs, e_after) = collect_tyvars e
-    collect_tyvars e@(Lam _ _)   = ( [], vss, e_after )
-      where (vss, e_after) = collect_vars e
-    collect_tyvars other_e	   = ( [], [], other_e )
+type TaggedCoreBinding t = GenCoreBinding (Tagged t) Id TyVar UVar
+type TaggedCoreExpr    t = GenCoreExpr    (Tagged t) Id TyVar UVar
+type TaggedCoreBinder  t = GenCoreBinder  (Tagged t)    TyVar UVar
+type TaggedCoreArg     t = GenCoreArg                Id TyVar UVar
 
-    collect_vars (Lam var e) = ([var]:varss, e_after)
-      where (varss, e_after) = collect_vars e
-    collect_vars other_e	   = ( [], other_e )
-
-    pp_varss [] = ppNil
-    pp_varss (vars:varss)
-      = ppCat [ppStr "\\", ppInterleave ppSP (map (pbdr2 sty) vars),
-	       ppStr "->", pp_varss varss]
-
-pprCoreExpr sty pbdr1 pbdr2 pbdee expr@(App fun_expr atom)
-  = let
-	(fun, args) = collect_args expr []
-    in
-    ppHang (pprParendCoreExpr sty pbdr1 pbdr2 pbdee fun)
-	 4 (ppSep (map (pprCoreAtom sty pbdee) args))
-  where
-    collect_args (App fun arg) args = collect_args fun (arg:args)
-    collect_args fun		 args = (fun, args)
-
-pprCoreExpr sty pbdr1 pbdr2 pbdee (CoTyApp expr ty)
-  = ppHang (ppBeside pp_note (pprParendCoreExpr sty pbdr1 pbdr2 pbdee expr))
-	 4 (pprParendUniType sty ty)
-  where
-    pp_note = ifPprShowAll sty (ppStr "{-CoTyApp-} ")
-
-pprCoreExpr sty pbdr1 pbdr2 pbdee (Case expr alts)
-  = ppSep [ppSep [ppStr "case", ppNest 4 (pprParendCoreExpr sty pbdr1 pbdr2 pbdee expr),
-		     ppStr "of {"],
-	   ppNest 2 (pprCoreCaseAlts sty pbdr1 pbdr2 pbdee alts),
-	   ppStr "}"]
-
--- special cases: let ... in let ...
--- ("disgusting" SLPJ)
-
-pprCoreExpr sty pbdr1 pbdr2 pbdee (Let bind@(NonRec val_bdr rhs@(Let _ _)) body)
-  = ppAboves [
-      ppCat [ppStr "let {", pbdr1 sty val_bdr, ppEquals],
-      ppNest 2 (pprCoreExpr sty pbdr1 pbdr2 pbdee rhs),
-      ppStr "} in",
-      pprCoreExpr sty pbdr1 pbdr2 pbdee body ]
-
-pprCoreExpr sty pbdr1 pbdr2 pbdee (Let bind@(NonRec val_bdr rhs) expr@(Let _ _))
-  = ppAbove
-      (ppHang (ppStr "let {")
-	    2 (ppCat [ppHang (ppCat [pbdr1 sty val_bdr, ppEquals])
-			   4 (pprCoreExpr sty pbdr1 pbdr2 pbdee rhs),
-       ppStr "} in"]))
-      (pprCoreExpr sty pbdr1 pbdr2 pbdee expr)
-
--- general case (recursive case, too)
-pprCoreExpr sty pbdr1 pbdr2 pbdee (Let bind expr)
-  = ppSep [ppHang (ppStr "let {") 2 (pprCoreBinding sty pbdr1 pbdr2 pbdee bind),
-	   ppHang (ppStr "} in ") 2 (pprCoreExpr    sty pbdr1 pbdr2 pbdee expr)]
-
-pprCoreExpr sty pbdr1 pbdr2 pbdee (SCC cc expr)
-  = ppSep [ ppCat [ppStr "_scc_", ppStr (showCostCentre sty True{-as string-} cc)],
-	    pprParendCoreExpr sty pbdr1 pbdr2 pbdee expr ]
+type TaggedCoreCaseAlts    t = GenCoreCaseAlts    (Tagged t) Id TyVar UVar
+type TaggedCoreCaseDefault t = GenCoreCaseDefault (Tagged t) Id TyVar UVar
 \end{code}
 
-\begin{code}
-pprParendCoreExpr sty pbdr1 pbdr2 pbdee e@(Var _) = pprCoreExpr sty pbdr1 pbdr2 pbdee e
-pprParendCoreExpr sty pbdr1 pbdr2 pbdee e@(Lit _) = pprCoreExpr sty pbdr1 pbdr2 pbdee e
-pprParendCoreExpr sty pbdr1 pbdr2 pbdee other_e
-  = ppBesides [ppLparen, pprCoreExpr sty pbdr1 pbdr2 pbdee other_e, ppRparen]
-\end{code}
-
-\begin{code}
-instance (Outputable bndr, Outputable bdee)
-		=> Outputable (GenCoreCaseAlternatives bndr bdee) where
-    ppr sty alts = pprCoreCaseAlts sty ppr ppr ppr alts
-\end{code}
+%************************************************************************
+%*									*
+\subsection{The @SimplifiableCore*@ instantiation of the @GenCore*@ types}
+%*									*
+%************************************************************************
 
+Binders are tagged with @BinderInfo@:
 \begin{code}
-pprCoreCaseAlts
-	:: PprStyle
-	-> (PprStyle -> bndr -> Pretty)	-- to print "major" val_bdrs
-	-> (PprStyle -> bndr -> Pretty) -- to print "minor" val_bdrs
-	-> (PprStyle -> bdee -> Pretty) -- to print bindees
-	-> GenCoreCaseAlternatives bndr bdee
-	-> Pretty
-
-pprCoreCaseAlts sty pbdr1 pbdr2 pbdee (AlgAlts alts deflt)
-  = ppAboves [ ppAboves (map ppr_alt alts),
-	       pprCoreCaseDefault sty pbdr1 pbdr2 pbdee deflt ]
-  where
-    ppr_alt (con, params, expr)
-      = ppHang (ppCat [ppr_con con,
-		       ppInterleave ppSP (map (pbdr2 sty) params),
-		       ppStr "->"])
-		4 (pprCoreExpr sty pbdr1 pbdr2 pbdee expr)
-      where
-    	ppr_con con
-    	  = if isOpLexeme con
-	    then ppBesides [ppLparen, ppr sty con, ppRparen]
-	    else ppr sty con
-
-pprCoreCaseAlts sty pbdr1 pbdr2 pbdee (PrimAlts alts deflt)
-  = ppAboves [ ppAboves (map ppr_alt alts),
-	       pprCoreCaseDefault sty pbdr1 pbdr2 pbdee deflt ]
-  where
-    ppr_alt (lit, expr)
-      = ppHang (ppCat [ppr sty lit, ppStr "->"])
-	     4 (pprCoreExpr sty pbdr1 pbdr2 pbdee expr)
-\end{code}
+type Simplifiable = (Id, BinderInfo)
 
-\begin{code}
-instance (Outputable bndr, Outputable bdee)
-		=> Outputable (GenCoreCaseDefault bndr bdee) where
-    ppr sty deflt  = pprCoreCaseDefault sty ppr ppr ppr deflt
-\end{code}
+type SimplifiableCoreBinding = GenCoreBinding Simplifiable Id TyVar UVar
+type SimplifiableCoreExpr    = GenCoreExpr    Simplifiable Id TyVar UVar
+type SimplifiableCoreBinder  = GenCoreBinder  Simplifiable    TyVar UVar
+type SimplifiableCoreArg     = GenCoreArg                  Id TyVar UVar
 
-\begin{code}
-pprCoreCaseDefault
-	:: PprStyle
-	-> (PprStyle -> bndr -> Pretty)	-- to print "major" val_bdrs
-	-> (PprStyle -> bndr -> Pretty) -- to print "minor" val_bdrs
-	-> (PprStyle -> bdee -> Pretty) -- to print bindees
-	-> GenCoreCaseDefault bndr bdee
-	-> Pretty
-
-pprCoreCaseDefault sty pbdr1 pbdr2 pbdee NoDefault = ppNil
-
-pprCoreCaseDefault sty pbdr1 pbdr2 pbdee (BindDefault val_bdr expr)
-  = ppHang (ppCat [pbdr2 sty val_bdr, ppStr "->"])
-	 4 (pprCoreExpr sty pbdr1 pbdr2 pbdee expr)
+type SimplifiableCoreCaseAlts    = GenCoreCaseAlts    Simplifiable Id TyVar UVar
+type SimplifiableCoreCaseDefault = GenCoreCaseDefault Simplifiable Id TyVar UVar
 \end{code}
diff --git a/ghc/compiler/coreSyn/CoreUnfold.hi b/ghc/compiler/coreSyn/CoreUnfold.hi
deleted file mode 100644
index 26619fc92e..0000000000
--- a/ghc/compiler/coreSyn/CoreUnfold.hi
+++ /dev/null
@@ -1,12 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface CoreUnfold where
-import Class(Class)
-import CoreSyn(CoreExpr)
-import Id(Id)
-import Pretty(PrettyRep)
-import SimplEnv(UnfoldingGuidance)
-import TyCon(TyCon)
-calcUnfoldingGuidance :: Bool -> Int -> CoreExpr Id Id -> UnfoldingGuidance
-mentionedInUnfolding :: (a -> Id) -> CoreExpr a Id -> ([Id], [TyCon], [Class], Bool)
-pprCoreUnfolding :: CoreExpr Id Id -> Int -> Bool -> PrettyRep
-
diff --git a/ghc/compiler/coreSyn/CoreUnfold.lhs b/ghc/compiler/coreSyn/CoreUnfold.lhs
index 7a2f380cdb..908c832705 100644
--- a/ghc/compiler/coreSyn/CoreUnfold.lhs
+++ b/ghc/compiler/coreSyn/CoreUnfold.lhs
@@ -1,56 +1,238 @@
 %
-% (c) The AQUA Project, Glasgow University, 1994-1995
+% (c) The AQUA Project, Glasgow University, 1994-1996
 %
-\section[CoreUnfold]{Core-syntax functions to do with unfoldings}
+\section[CoreUnfold]{Core-syntax unfoldings}
+
+Unfoldings (which can travel across module boundaries) are in Core
+syntax (namely @CoreExpr@s).
+
+The type @UnfoldingDetails@ sits ``above'' simply-Core-expressions
+unfoldings, capturing ``higher-level'' things we know about a binding,
+usually things that the simplifier found out (e.g., ``it's a
+literal'').  In the corner of a @GenForm@ unfolding, you will
+find, unsurprisingly, a Core expression.
 
 \begin{code}
 #include "HsVersions.h"
 
 module CoreUnfold (
-	calcUnfoldingGuidance,
+	UnfoldingDetails(..), UnfoldingGuidance(..), -- types
+	FormSummary(..),
 
-	pprCoreUnfolding,
+	mkFormSummary,
+	mkGenForm,
+	mkMagicUnfolding,
+	modifyUnfoldingDetails,
+	calcUnfoldingGuidance,
 	mentionedInUnfolding
-
     ) where
 
-import AbsPrel		( primOpCanTriggerGC, PrimOp(..), PrimKind
-			  IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
-			  IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
-			)
-import AbsUniType	( getMentionedTyConsAndClassesFromUniType,
-			  getUniDataTyCon, getTyConFamilySize,
-			  pprParendUniType, Class, TyCon, TyVar,
-			  UniType, TauType(..)
-			  IF_ATTACK_PRAGMAS(COMMA cmpTyCon COMMA cmpClass)
-			  IF_ATTACK_PRAGMAS(COMMA cmpTyVar)
-			  IF_ATTACK_PRAGMAS(COMMA cmpUniType)
-			)
-import Bag
-import BasicLit		( isNoRepLit, isLitLitLit, BasicLit(..){-.. is for pragmas-} )
+import Ubiq
+import IdLoop	 -- for paranoia checking
+import PrelLoop  -- for paranoia checking
+
+import Bag		( emptyBag, unitBag, unionBags, Bag )
+import BinderInfo	( oneTextualOcc, oneSafeOcc )
 import CgCompInfo	( uNFOLDING_CHEAP_OP_COST,
 			  uNFOLDING_DEAR_OP_COST,
 			  uNFOLDING_NOREP_LIT_COST
 			)
-import CoreFuns		( digForLambdas, typeOfCoreExpr )
-import CoreSyn		-- mostly re-exporting this stuff
-import CostCentre	( showCostCentre, noCostCentreAttached,
-			  currentOrSubsumedCosts, ccMentionsId, CostCentre
-			)
-import Id		( pprIdInUnfolding, getIdUniType,
-			  whatsMentionedInId, Id, DataCon(..)
-			)
-import IdInfo
-import Maybes
-import Outputable
-import PlainCore	( instCoreExpr )
+import CoreSyn
+import CoreUtils	( coreExprType )
+import CostCentre	( ccMentionsId )
+import Id		( IdSet(..), GenId{-instances-} )
+import IdInfo		( bottomIsGuaranteed )
+import Literal		( isNoRepLit, isLitLitLit )
+import MagicUFs		( mkMagicUnfoldingFun, MagicUnfoldingFun )
 import Pretty
-import SimplEnv		( UnfoldingGuidance(..) )
-import UniqSet
-import Unique		( uniqSupply_u, UniqueSupply )
-import Util
+import PrimOp		( PrimOp(..) )
+import Type		( getAppDataTyCon )
+import UniqSet		( emptyUniqSet, singletonUniqSet, mkUniqSet,
+			  unionUniqSets
+			)
+import Usage		( UVar(..) )
+import Util		( isIn, panic )
+
+manifestlyWHNF = panic "manifestlyWHNF (CoreUnfold)"
+primOpCanTriggerGC = panic "primOpCanTriggerGC (CoreUnfold)"
+getTyConFamilySize = panic "getTyConFamilySize (CoreUnfold)"
+whatsMentionedInId = panic "whatsMentionedInId (CoreUnfold)"
+getMentionedTyConsAndClassesFromType = panic "getMentionedTyConsAndClassesFromType (CoreUnfold)"
+\end{code}
+
+%************************************************************************
+%*									*
+\subsection{@UnfoldingDetails@ and @UnfoldingGuidance@ types}
+%*									*
+%************************************************************************
+
+(And @FormSummary@, too.)
+
+\begin{code}
+data UnfoldingDetails
+  = NoUnfoldingDetails
+
+  | LitForm
+	Literal
+
+  | OtherLitForm
+	[Literal]		-- It is a literal, but definitely not one of these
+
+  | ConForm
+	Id			-- The constructor
+	[CoreArg]		-- Value arguments; NB OutArgs, already cloned
+
+  | OtherConForm
+	[Id]			-- It definitely isn't one of these constructors
+				-- This captures the situation in the default branch of
+				-- a case:  case x of
+				--		c1 ... -> ...
+				--		c2 ... -> ...
+				--		v -> default-rhs
+				-- Then in default-rhs we know that v isn't c1 or c2.
+				--
+				-- NB.  In the degenerate: case x of {v -> default-rhs}
+				-- x will be bound to
+				--	OtherConForm []
+				-- which captures the idea that x is eval'd but we don't
+				-- know which constructor.
+
+
+  | GenForm
+	Bool			-- True <=> At most one textual occurrence of the
+				--		binder in its scope, *or*
+				--		if we are happy to duplicate this
+				--		binding.
+	FormSummary		-- Tells whether the template is a WHNF or bottom
+	TemplateOutExpr		-- The template
+	UnfoldingGuidance	-- Tells about the *size* of the template.
+
+  | MagicForm
+	Unique			-- of the Id whose magic unfolding this is
+	MagicUnfoldingFun
+
+type TemplateOutExpr = GenCoreExpr (Id, BinderInfo) Id TyVar UVar
+	-- An OutExpr with occurrence info attached.  This is used as
+	-- a template in GeneralForms.
+
+mkMagicUnfolding :: Unique -> UnfoldingDetails
+mkMagicUnfolding tag  = MagicForm tag (mkMagicUnfoldingFun tag)
+
+data FormSummary
+  = WhnfForm 		-- Expression is WHNF
+  | BottomForm		-- Expression is guaranteed to be bottom. We're more gung
+			-- ho about inlining such things, because it can't waste work
+  | OtherForm		-- Anything else
+
+instance Outputable FormSummary where
+   ppr sty WhnfForm   = ppStr "WHNF"
+   ppr sty BottomForm = ppStr "Bot"
+   ppr sty OtherForm  = ppStr "Other"
+
+--???mkFormSummary :: StrictnessInfo -> GenCoreExpr bndr Id -> FormSummary
+mkFormSummary si expr
+  | manifestlyWHNF     expr = WhnfForm
+  | bottomIsGuaranteed si   = BottomForm
+
+  -- Chances are that the Id will be decorated with strictness info
+  -- telling that the RHS is definitely bottom.  This *might* not be the
+  -- case, if it's been a while since strictness analysis, but leaving out
+  -- the test for manifestlyBottom makes things a little more efficient.
+  -- We can always put it back...
+  -- | manifestlyBottom expr  = BottomForm
+
+  | otherwise = OtherForm
+\end{code}
+
+\begin{code}
+data UnfoldingGuidance
+  = UnfoldNever			-- Don't do it!
+
+  | UnfoldAlways		-- There is no "original" definition,
+				-- so you'd better unfold.  Or: something
+				-- so cheap to unfold (e.g., 1#) that
+				-- you should do it absolutely always.
+
+  | EssentialUnfolding		-- Like UnfoldAlways, but you *must* do
+				-- it absolutely always.
+				-- This is what we use for data constructors
+				-- and PrimOps, because we don't feel like
+				-- generating curried versions "just in case".
+
+  | UnfoldIfGoodArgs	Int	-- if "m" type args and "n" value args; and
+			Int	-- those val args are manifestly data constructors
+			[Bool]	-- the val-arg positions marked True
+				-- (i.e., a simplification will definitely
+				-- be possible).
+			Int	-- The "size" of the unfolding; to be elaborated
+				-- later. ToDo
+
+  | BadUnfolding		-- This is used by TcPragmas if the *lazy*
+				-- lintUnfolding test fails
+				-- It will never escape from the IdInfo as
+				-- it is caught by getInfo_UF and converted
+				-- to NoUnfoldingDetails
+\end{code}
+
+\begin{code}
+instance Outputable UnfoldingGuidance where
+    ppr sty UnfoldNever	    	= ppStr "_N_"
+    ppr sty UnfoldAlways    	= ppStr "_ALWAYS_"
+    ppr sty EssentialUnfolding	= ppStr "_ESSENTIAL_" -- shouldn't appear in an iface
+    ppr sty (UnfoldIfGoodArgs t v cs size)
+      = ppCat [ppStr "_IF_ARGS_", ppInt t, ppInt v,
+	       if null cs	-- always print *something*
+	       	then ppChar 'X'
+		else ppBesides (map pp_c cs),
+	       ppInt size ]
+      where
+	pp_c False = ppChar 'X'
+	pp_c True  = ppChar 'C'
 \end{code}
 
+
+%************************************************************************
+%*									*
+\subsection{@mkGenForm@ and @modifyUnfoldingDetails@}
+%*									*
+%************************************************************************
+
+\begin{code}
+mkGenForm :: Bool		-- Ok to Dup code down different case branches,
+				-- because of either a flag saying so,
+				-- or alternatively the object is *SMALL*
+	  -> BinderInfo		--
+	  -> FormSummary
+	  -> TemplateOutExpr	-- Template
+	  -> UnfoldingGuidance	-- Tells about the *size* of the template.
+	  -> UnfoldingDetails
+
+mkGenForm safe_to_dup occ_info WhnfForm template guidance
+  = GenForm (oneTextualOcc safe_to_dup occ_info) WhnfForm template guidance
+
+mkGenForm safe_to_dup occ_info form_summary template guidance
+  | oneSafeOcc safe_to_dup occ_info	-- Non-WHNF with only safe occurrences
+  = GenForm True form_summary template guidance
+
+  | otherwise				-- Not a WHNF, many occurrences
+  = NoUnfoldingDetails
+\end{code}
+
+\begin{code}
+modifyUnfoldingDetails
+	:: Bool		-- OK to dup
+	-> BinderInfo	-- New occurrence info for the thing
+	-> UnfoldingDetails
+	-> UnfoldingDetails
+
+modifyUnfoldingDetails ok_to_dup occ_info
+	(GenForm only_one form_summary template guidance)
+  | only_one  = mkGenForm ok_to_dup occ_info form_summary template guidance
+
+modifyUnfoldingDetails ok_to_dup occ_info other = other
+\end{code}
+
+
 %************************************************************************
 %*									*
 \subsection[calcUnfoldingGuidance]{Calculate ``unfolding guidance'' for an expression}
@@ -61,19 +243,19 @@ import Util
 calcUnfoldingGuidance
 	:: Bool		    -- True <=> OK if _scc_s appear in expr
 	-> Int		    -- bomb out if size gets bigger than this
-	-> PlainCoreExpr    -- expression to look at
+	-> CoreExpr    -- expression to look at
 	-> UnfoldingGuidance
 
 calcUnfoldingGuidance scc_s_OK bOMB_OUT_SIZE expr
   = let
-    	(ty_binders, val_binders, body) = digForLambdas expr
+    	(use_binders, ty_binders, val_binders, body) = digForLambdas expr
     in
     case (sizeExpr scc_s_OK bOMB_OUT_SIZE val_binders body) of
 
       Nothing		     -> UnfoldNever
 
       Just (size, cased_args)
-        -> let
+	-> let
 	       uf = UnfoldIfGoodArgs
 			(length ty_binders)
 			(length val_binders)
@@ -91,7 +273,7 @@ sizeExpr :: Bool	    -- True <=> _scc_s OK
 	 -> Int 	    -- Bomb out if it gets bigger than this
 	 -> [Id]	    -- Arguments; we're interested in which of these
 			    -- get case'd
-	 -> PlainCoreExpr   
+	 -> CoreExpr
 	 -> Maybe (Int,	    -- Size
 		   [Id]	    -- Subset of args which are cased
 	    )
@@ -99,19 +281,19 @@ sizeExpr :: Bool	    -- True <=> _scc_s OK
 sizeExpr scc_s_OK bOMB_OUT_SIZE args expr
   = size_up expr
   where
-    size_up (CoVar v)        = sizeOne
-    size_up (CoApp fun arg)  = size_up fun `addSizeN` 1
-    size_up (CoTyApp fun ty) = size_up fun	-- They're free
-    size_up (CoLit lit)      = if isNoRepLit lit
+    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
 
-    size_up (CoSCC _ (CoCon _ _ _)) = Nothing -- **** HACK *****
-    size_up (CoSCC lbl body)
+    size_up (SCC _ (Con _ _)) = Nothing -- **** HACK *****
+    size_up (SCC lbl body)
       = if scc_s_OK then size_up body else Nothing
 
-    size_up (CoCon con tys args) = sizeN (length args + 1)
-    size_up (CoPrim op tys args) = sizeN op_cost -- NB: no charge for PrimOp args
+    size_up (Con con args) = -- 1 + # of val args
+			     sizeN (1 + length [ va | va <- args, isValArg va ])
+    size_up (Prim op args) = sizeN op_cost -- NB: no charge for PrimOp args
       where
 	op_cost = if primOpCanTriggerGC op
 		  then uNFOLDING_DEAR_OP_COST
@@ -119,31 +301,37 @@ sizeExpr scc_s_OK bOMB_OUT_SIZE args expr
 			-- number chosen to avoid unfolding (HACK)
 		  else uNFOLDING_CHEAP_OP_COST
 
-    size_up (CoLam binders body) = size_up body `addSizeN` length binders
-    size_up (CoTyLam tyvar body) = size_up body
+    size_up expr@(Lam _ _)
+      = let
+	    (uvars, tyvars, args, body) = digForLambdas expr
+	in
+	size_up body `addSizeN` length args
 
-    size_up (CoLet (CoNonRec binder rhs) body) 
+    size_up (Let (NonRec binder rhs) body)
       = size_up rhs
 		`addSize`
 	size_up body
 		`addSizeN`
 	1
 
-    size_up (CoLet (CoRec pairs) body) 
+    size_up (Let (Rec pairs) body)
       = foldr addSize sizeZero [size_up rhs | (_,rhs) <- pairs]
 		`addSize`
 	size_up body
 		`addSizeN`
 	length pairs
-	
-    size_up (CoCase scrut alts)
-      = size_up_scrut scrut 
+
+    size_up (Case scrut alts)
+      = size_up_scrut scrut
 		`addSize`
-	size_up_alts (typeOfCoreExpr scrut) alts
+	size_up_alts (coreExprType scrut) alts
 	    -- We charge for the "case" itself in "size_up_alts"
 
     ------------
-    size_up_alts scrut_ty (CoAlgAlts alts deflt)
+    size_up_arg arg = if isValArg arg then sizeOne else sizeZero{-it's free-}
+
+    ------------
+    size_up_alts scrut_ty (AlgAlts alts deflt)
       = foldr (addSize . size_alg_alt) (size_up_deflt deflt) alts
 		`addSizeN`
     	(case (getTyConFamilySize tycon) of { Just n -> n })
@@ -155,28 +343,28 @@ sizeExpr scc_s_OK bOMB_OUT_SIZE args expr
 	size_alg_alt (con,args,rhs) = size_up rhs
 	    -- Don't charge for args, so that wrappers look cheap
 
-	(tycon, _, _) = getUniDataTyCon scrut_ty
-
+	(tycon, _, _) = getAppDataTyCon scrut_ty
 
-    size_up_alts _ (CoPrimAlts alts deflt)
-      = foldr (addSize . size_prim_alt) (size_up_deflt deflt) alts  
+    size_up_alts _ (PrimAlts alts deflt)
+      = foldr (addSize . size_prim_alt) (size_up_deflt deflt) alts
 	    -- *no charge* for a primitive "case"!
       where
 	size_prim_alt (lit,rhs) = size_up rhs
 
     ------------
-    size_up_deflt CoNoDefault = sizeZero
-    size_up_deflt (CoBindDefault binder rhs) = size_up rhs
+    size_up_deflt NoDefault = sizeZero
+    size_up_deflt (BindDefault binder rhs) = size_up rhs
 
     ------------
 	-- Scrutinees.  There are two things going on here.
 	-- First, we want to record if we're case'ing an argument
 	-- Second, we want to charge nothing for the srutinee if it's just
 	-- a variable.  That way wrapper-like things look cheap.
-    size_up_scrut (CoVar v) | v `is_elem` args = Just (0, [v])
+    size_up_scrut (Var v) | v `is_elem` args = Just (0, [v])
 			    | otherwise	       = Just (0, [])
     size_up_scrut other			       = size_up other
 
+    is_elem :: Id -> [Id] -> Bool
     is_elem = isIn "size_up_scrut"
 
     ------------
@@ -188,8 +376,7 @@ sizeExpr scc_s_OK bOMB_OUT_SIZE args expr
     addSizeN Nothing _ = Nothing
     addSizeN (Just (n, xs)) m
       | tot < bOMB_OUT_SIZE = Just (tot, xs)
-      | otherwise = -- pprTrace "bomb1:" (ppCat [ppInt tot, ppInt bOMB_OUT_SIZE, ppr PprDebug expr])
-		    Nothing
+      | otherwise = Nothing
       where
 	tot = n+m
 
@@ -197,8 +384,7 @@ sizeExpr scc_s_OK bOMB_OUT_SIZE args expr
     addSize _ Nothing = Nothing
     addSize (Just (n, xs)) (Just (m, ys))
       | tot < bOMB_OUT_SIZE = Just (tot, xys)
-      | otherwise  = -- pprTrace "bomb2:" (ppCat [ppInt tot, ppInt bOMB_OUT_SIZE, ppr PprDebug expr])
-		     Nothing
+      | otherwise  = Nothing
       where
 	tot = n+m
 	xys = xs ++ ys
@@ -316,56 +502,53 @@ litlit_oops in_scopes get_id (ids, tcs, clss, _)
 %************************************************************************
 
 \begin{code}
+{-
 mentionedInUnfolding
 	:: (bndr -> Id)		-- so we can get Ids out of binders
-	-> CoreExpr bndr Id	-- input expression
-	-> ([Id], [TyCon], [Class],
+	-> 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)) ->
-	(bagToList ids_bag, bagToList tcs_bag, bagToList clss_bag, has_litlit)
+	(ids_bag, tcs_bag, clss_bag, has_litlit)
 \end{code}
 
 \begin{code}
-ment_expr :: CoreExpr bndr Id -> UnfoldM bndr ()
+--ment_expr :: GenCoreExpr bndr Id -> UnfoldM bndr ()
 
-ment_expr (CoVar v) = consider_Id  v
-ment_expr (CoLit l) = consider_lit l
+ment_expr (Var v) = consider_Id  v
+ment_expr (Lit l) = consider_lit l
 
-ment_expr (CoLam bs body)
-  = extractIdsUf bs		`thenUf` \ bs_ids ->
+ment_expr expr@(Lam _ _)
+  = let
+	(uvars, tyvars, args, body) = digForLambdas 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 (CoTyLam _ body) = ment_expr body
-
-ment_expr (CoApp fun arg)
+ment_expr (App fun arg)
   = ment_expr fun	`thenUf_`
-    ment_atom arg
-
-ment_expr (CoTyApp expr ty)
-  = ment_ty   ty	`thenUf_`
-    ment_expr expr
+    ment_arg  arg
 
-ment_expr (CoCon c ts as)
+ment_expr (Con c as)
   = consider_Id c	`thenUf_`
-    mapUf ment_ty ts	`thenUf_`
-    mapUf ment_atom as	`thenUf_`
+    mapUf ment_arg as	`thenUf_`
     returnUf ()
 
-ment_expr (CoPrim op ts as)
+ment_expr (Prim op as)
   = ment_op op		`thenUf_`
-    mapUf ment_ty   ts	`thenUf_`
-    mapUf ment_atom as	`thenUf_`
+    mapUf ment_arg as	`thenUf_`
     returnUf ()
   where
     ment_op (CCallOp str is_asm may_gc arg_tys res_ty)
@@ -373,29 +556,29 @@ ment_expr (CoPrim op ts as)
     	ment_ty res_ty
     ment_op other_op = returnUf ()
 
-ment_expr (CoCase scrutinee alts)
+ment_expr (Case scrutinee alts)
   = ment_expr scrutinee	`thenUf_`
     ment_alts alts
 
-ment_expr (CoLet (CoNonRec bind rhs) body)
+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 (CoLet (CoRec pairs) body)
+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 ment_expr rhss	     `thenUf_`
 	mapUf consider_Id binder_ids `thenUf_`
-        ment_expr body )
+	ment_expr body )
 
-ment_expr (CoSCC cc expr)
+ment_expr (SCC cc expr)
   = (case (ccMentionsId cc) of
       Just id -> consider_Id id
       Nothing -> returnUf ()
@@ -405,14 +588,14 @@ ment_expr (CoSCC cc expr)
 -------------
 ment_ty ty
   = let
-	(tycons, clss) = getMentionedTyConsAndClassesFromUniType ty
+	(tycons, clss) = getMentionedTyConsAndClassesFromType ty
     in
     addToMentionedTyConsUf  tycons  `thenUf_`
     addToMentionedClassesUf clss
 
 -------------
 
-ment_alts alg_alts@(CoAlgAlts alts deflt)
+ment_alts alg_alts@(AlgAlts alts deflt)
   = mapUf ment_alt alts   `thenUf_`
     ment_deflt deflt
   where
@@ -424,25 +607,27 @@ ment_alts alg_alts@(CoAlgAlts alts deflt)
 	  mapUf consider_Id param_ids `thenUf_`
 	  ment_expr rhs )
 
-ment_alts (CoPrimAlts alts deflt)
+ment_alts (PrimAlts alts deflt)
   = mapUf ment_alt alts   `thenUf_`
     ment_deflt deflt
   where
     ment_alt alt@(lit, rhs) = ment_expr rhs
 
 ----------------
-ment_deflt CoNoDefault
+ment_deflt NoDefault
   = returnUf ()
 
-ment_deflt d@(CoBindDefault b rhs)
+ment_deflt d@(BindDefault b rhs)
   = extractIdsUf [b]		`thenUf` \ bi@[b_id] ->
     addInScopesUf bi		(
 	consider_Id b_id `thenUf_`
 	ment_expr rhs )
 
 -----------
-ment_atom (CoVarAtom v) = consider_Id  v
-ment_atom (CoLitAtom l) = consider_lit l
+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
@@ -459,8 +644,9 @@ consider_lit lit
 Printing Core-expression unfoldings is sufficiently delicate that we
 give it its own function.
 \begin{code}
+{- OLD:
 pprCoreUnfolding
-	:: PlainCoreExpr
+	:: CoreExpr
 	-> Pretty
 
 pprCoreUnfolding expr
@@ -476,21 +662,21 @@ ppr_Unfolding = PprUnfolding (panic "CoreUnfold:ppr_Unfolding")
 \end{code}
 
 \begin{code}
-ppr_uf_Expr in_scopes (CoVar v) = pprIdInUnfolding in_scopes v
-ppr_uf_Expr in_scopes (CoLit l) = ppr ppr_Unfolding l
+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 (CoCon c ts as)
+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 (CoPrim op ts as)
+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 (CoLam binders body)
-  = ppCat [ppChar '\\', ppIntersperse ppSP (map ppr_uf_Binder binders),
-	   ppPStr SLIT("->"), ppr_uf_Expr (in_scopes `add_some` binders) body]
+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 "->",
@@ -502,27 +688,27 @@ ppr_uf_Expr in_scopes (CoTyLam tyvar expr)
       where (tyvs, e_after) = collect_tyvars e
     collect_tyvars other_e	   = ( [], other_e )
 
-ppr_uf_Expr in_scopes expr@(CoApp fun_expr atom)
+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 (CoApp fun arg) args = collect_args fun (arg:args)
+    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 (CoCase scrutinee alts)
+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 (CoAlgAlts  alts deflt)
+    pp_alts (AlgAlts  alts deflt)
       = ppCat [ppPStr SLIT("_ALG_"),  ppCat (map pp_alg  alts), pp_deflt deflt]
-    pp_alts (CoPrimAlts alts deflt)
+    pp_alts (PrimAlts alts deflt)
       = ppCat [ppPStr SLIT("_PRIM_"), ppCat (map pp_prim alts), pp_deflt deflt]
 
     pp_alg (con, params, rhs)
@@ -534,16 +720,16 @@ ppr_uf_Expr in_scopes (CoCase scrutinee alts)
       = ppBesides [ppr ppr_Unfolding lit,
 		   ppPStr SLIT(" -> "), ppr_uf_Expr in_scopes rhs, ppSemi]
 
-    pp_deflt CoNoDefault = ppPStr SLIT("_NO_DEFLT_")
-    pp_deflt (CoBindDefault binder rhs)
+    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 (CoLet (CoNonRec binder rhs) body)
+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 (CoLet (CoRec pairs) 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
@@ -552,7 +738,7 @@ ppr_uf_Expr in_scopes (CoLet (CoRec pairs) body)
 
     pp_pair (b, rhs) = ppCat [ppr_uf_Binder b, ppEquals, ppr_uf_Expr new_in_scopes rhs]
 
-ppr_uf_Expr in_scopes (CoSCC cc body)
+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]
@@ -562,8 +748,9 @@ ppr_uf_Expr in_scopes (CoSCC cc body)
 ppr_uf_Binder :: Id -> Pretty
 ppr_uf_Binder v
   = ppBesides [ppLparen, pprIdInUnfolding (singletonUniqSet v) v, ppPStr SLIT(" :: "),
-	       ppr ppr_Unfolding (getIdUniType v), ppRparen]
+	       ppr ppr_Unfolding (idType v), ppRparen]
 
-ppr_uf_Atom in_scopes (CoLitAtom l) = ppr ppr_Unfolding l
-ppr_uf_Atom in_scopes (CoVarAtom v) = pprIdInUnfolding in_scopes v
+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
new file mode 100644
index 0000000000..1a993e6a7e
--- /dev/null
+++ b/ghc/compiler/coreSyn/CoreUtils.lhs
@@ -0,0 +1,802 @@
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+%
+\section[CoreUtils]{Utility functions on @Core@ syntax}
+
+\begin{code}
+#include "HsVersions.h"
+
+module CoreUtils (
+	coreExprType, coreAltsType,
+
+	substCoreExpr
+
+	, mkCoreIfThenElse
+	, mkErrorApp, escErrorMsg
+	, argToExpr
+	, unTagBinders, unTagBindersAlts
+{-	exprSmallEnoughToDup,
+	manifestlyWHNF, manifestlyBottom,
+	coreExprArity,
+	isWrapperFor,
+	maybeErrorApp,
+	nonErrorRHSs,
+	squashableDictishCcExpr,
+
+-}  ) where
+
+import Ubiq
+import IdLoop	-- for pananoia-checking purposes
+
+import CoreSyn
+
+import CostCentre	( isDictCC )
+import Id		( idType, mkSysLocal,
+			  addOneToIdEnv, growIdEnvList, lookupIdEnv,
+			  isNullIdEnv, IdEnv(..),
+			  GenId{-instances-}
+			)
+import Literal		( literalType, isNoRepLit, Literal(..) )
+import Maybes		( catMaybes )
+import PprCore		( GenCoreExpr{-instances-}, GenCoreArg{-instances-} )
+import PprStyle		( PprStyle(..) )
+import PprType		( GenType{-instances-}, GenTyVar{-instance-} )
+import Pretty		( ppAboves )
+import PrelInfo		( trueDataCon, falseDataCon,
+			  augmentId, buildId,
+			  pAT_ERROR_ID
+			)
+import PrimOp		( primOpType, PrimOp(..) )
+import SrcLoc		( mkUnknownSrcLoc )
+import TyVar		( isNullTyVarEnv, TyVarEnv(..), GenTyVar{-instances-} )
+import Type		( mkFunTys, mkForAllTy, mkForAllUsageTy,
+			  getFunTy_maybe, applyTy, splitSigmaTy
+			)
+import Unique		( Unique{-instances-} )
+import UniqSupply	( initUs, returnUs, thenUs,
+			  mapUs, mapAndUnzipUs,
+			  UniqSM(..), UniqSupply
+			)
+import Util		( zipEqual, panic, pprPanic, assertPanic )
+
+type TypeEnv = TyVarEnv Type
+applyUsage = panic "CoreUtils.applyUsage:ToDo"
+dup_binder = panic "CoreUtils.dup_binder"
+applyTypeEnvToTy = panic "CoreUtils.applyTypeEnvToTy"
+\end{code}
+
+%************************************************************************
+%*									*
+\subsection{Find the type of a Core atom/expression}
+%*									*
+%************************************************************************
+
+\begin{code}
+coreExprType :: CoreExpr -> Type
+
+coreExprType (Var var) = idType   var
+coreExprType (Lit lit) = literalType lit
+
+coreExprType (Let _ body)	= coreExprType body
+coreExprType (SCC _ expr)	= coreExprType expr
+coreExprType (Case _ alts)	= coreAltsType alts
+
+-- a Con is a fully-saturated application of a data constructor
+-- a Prim is <ditto> of a PrimOp
+
+coreExprType (Con con args) = applyTypeToArgs (idType    con) args
+coreExprType (Prim op args) = applyTypeToArgs (primOpType op) args
+
+coreExprType (Lam (ValBinder binder) expr)
+  = mkFunTys [idType binder] (coreExprType expr)
+
+coreExprType (Lam (TyBinder tyvar) expr)
+  = mkForAllTy tyvar (coreExprType expr)
+
+coreExprType (Lam (UsageBinder uvar) expr)
+  = mkForAllUsageTy uvar (panic "coreExprType:Lam UsageBinder") (coreExprType expr)
+
+coreExprType (App expr (TyArg ty))
+  = applyTy (coreExprType expr) ty
+
+coreExprType (App expr (UsageArg use))
+  = applyUsage (coreExprType expr) use
+
+coreExprType (App expr val_arg)
+  = ASSERT(isValArg val_arg)
+    let
+	fun_ty = coreExprType expr
+    in
+    case (getFunTy_maybe fun_ty) of
+	  Just (_, result_ty) -> result_ty
+#ifdef DEBUG
+	  Nothing -> pprPanic "coreExprType:\n"
+		(ppAboves [ppr PprDebug fun_ty,
+			   ppr PprShowAll (App expr val_arg)])
+#endif
+\end{code}
+
+\begin{code}
+coreAltsType :: CoreCaseAlts -> Type
+
+coreAltsType (AlgAlts [] deflt)         = default_ty deflt
+coreAltsType (AlgAlts ((_,_,rhs1):_) _) = coreExprType rhs1
+
+coreAltsType (PrimAlts [] deflt)       = default_ty deflt
+coreAltsType (PrimAlts ((_,rhs1):_) _) = coreExprType rhs1
+
+default_ty NoDefault           = panic "coreExprType:Case:default_ty"
+default_ty (BindDefault _ rhs) = coreExprType rhs
+\end{code}
+
+\begin{code}
+applyTypeToArgs = panic "applyTypeToArgs"
+\end{code}
+
+%************************************************************************
+%*									*
+\subsection{Routines to manufacture bits of @CoreExpr@}
+%*									*
+%************************************************************************
+
+\begin{code}
+mkCoreIfThenElse (Var bool) then_expr else_expr
+    | bool == trueDataCon   = then_expr
+    | bool == falseDataCon  = else_expr
+
+mkCoreIfThenElse guard then_expr else_expr
+  = Case guard
+      (AlgAlts [ (trueDataCon,  [], then_expr),
+		 (falseDataCon, [], else_expr) ]
+       NoDefault )
+\end{code}
+
+\begin{code}
+mkErrorApp :: Type -> Id -> String -> CoreExpr
+
+mkErrorApp ty str_var error_msg
+  = Let (NonRec str_var (Lit (NoRepStr (_PK_ error_msg)))) (
+    mkApp (Var pAT_ERROR_ID) [] [ty] [VarArg str_var])
+
+escErrorMsg [] = []
+escErrorMsg ('%':xs) = '%' : '%' : escErrorMsg xs
+escErrorMsg (x:xs)   = x : escErrorMsg xs
+\end{code}
+
+For making @Apps@ and @Lets@, we must take appropriate evasive
+action if the thing being bound has unboxed type.  @mkCoApp@ requires
+a name supply to do its work.  Other-monad code will call @mkCoApp@
+through its own interface function (e.g., the desugarer uses
+@mkCoAppDs@).
+
+@mkCoApp@, @mkCoCon@ and @mkCoPrim@ also handle the
+arguments-must-be-atoms constraint.
+
+\begin{code}
+{- LATER:
+--mkCoApp :: CoreExpr -> CoreExpr -> UniqSM CoreExpr
+
+mkCoApp e1 (Var v) = returnUs (App e1 (VarArg v))
+mkCoApp e1 (Lit l) = returnUs (App e1 (LitArg l))
+mkCoApp e1 e2
+  = let
+	e2_ty = coreExprType e2
+    in
+    panic "getUnique"	`thenUs` \ uniq ->
+    let
+	new_var = mkSysLocal SLIT("a") uniq e2_ty mkUnknownSrcLoc
+    in
+    returnUs (
+    	mkCoLetUnboxedToCase (NonRec new_var e2)
+			     (App e1 (VarArg new_var))
+    )
+-}
+\end{code}
+
+\begin{code}
+{-LATER
+mkCoCon  :: Id     -> [CoreExpr] -> UniqSM CoreExpr
+mkCoPrim :: PrimOp -> [CoreExpr] -> UniqSM CoreExpr
+
+mkCoCon con args = mkCoThing (Con con) args
+mkCoPrim op args = mkCoThing (Prim op) args
+
+mkCoThing thing arg_exprs
+  = mapAndUnzipUs expr_to_arg arg_exprs `thenUs` \ (args, maybe_binds) ->
+    returnUs (mkCoLetsUnboxedToCase (catMaybes maybe_binds) (thing args))
+  where
+    expr_to_arg :: CoreExpr
+	       -> UniqSM (CoreArg, Maybe CoreBinding)
+
+    expr_to_arg (Var v) = returnUs (VarArg v, Nothing)
+    expr_to_arg (Lit l) = returnUs (LitArg l, Nothing)
+    expr_to_arg other_expr
+      = let
+	    e_ty = coreExprType other_expr
+	in
+	panic "getUnique" `thenUs` \ uniq ->
+	let
+	    new_var  = mkSysLocal SLIT("a") uniq e_ty mkUnknownSrcLoc
+	    new_atom = VarArg new_var
+	in
+	returnUs (new_atom, Just (NonRec new_var other_expr))
+-}
+\end{code}
+
+\begin{code}
+argToExpr ::
+  GenCoreArg val_occ tyvar uvar -> GenCoreExpr val_bdr val_occ tyvar uvar
+
+argToExpr (VarArg v)   = Var v
+argToExpr (LitArg lit) = Lit lit
+\end{code}
+
+\begin{code}
+{- LATER:
+--mkCoApps ::
+--  GenCoreExpr val_bdr val_occ tyvar uvar ->
+--  [GenCoreExpr val_bdr val_occ tyvar uvar] ->
+--  UniqSM(GenCoreExpr val_bdr val_occ tyvar uvar)
+
+mkCoApps fun []  = returnUs fun
+mkCoApps fun (arg:args)
+  = mkCoApp fun arg `thenUs` \ new_fun ->
+    mkCoApps new_fun args
+\end{code}
+
+\begin{code}
+exprSmallEnoughToDup :: GenCoreExpr binder Id -> Bool
+
+exprSmallEnoughToDup (Con _ _ _)   = True	-- Could check # of args
+exprSmallEnoughToDup (Prim op _ _) = not (fragilePrimOp op)	-- Could check # of args
+exprSmallEnoughToDup (Lit lit) = not (isNoRepLit lit)
+
+exprSmallEnoughToDup expr  -- for now, just: <var> applied to <args>
+  = case (collectArgs expr) of { (fun, args) ->
+    case fun of
+      Var v -> v /= buildId
+		 && v /= augmentId
+		 && length args <= 6 -- or 10 or 1 or 4 or anything smallish.
+      _       -> False
+    }
+\end{code}
+Question (ADR): What is the above used for?  Is a _ccall_ really small
+enough?
+
+@manifestlyWHNF@ looks at a Core expression and returns \tr{True} if
+it is obviously in weak head normal form.  It isn't a disaster if it
+errs on the conservative side (returning \tr{False})---I've probably
+left something out... [WDP]
+
+\begin{code}
+manifestlyWHNF :: GenCoreExpr bndr Id -> Bool
+
+manifestlyWHNF (Var _)     = True
+manifestlyWHNF (Lit _)     = True
+manifestlyWHNF (Con _ _ _) = True  -- ToDo: anything for Prim?
+manifestlyWHNF (Lam _ _)   = True
+manifestlyWHNF (CoTyLam _ e) = manifestlyWHNF e
+manifestlyWHNF (SCC _ e)   = manifestlyWHNF e
+manifestlyWHNF (Let _ e)   = False
+manifestlyWHNF (Case _ _)  = False
+
+manifestlyWHNF other_expr   -- look for manifest partial application
+  = case (collectArgs other_expr) of { (fun, args) ->
+    case fun of
+      Var f -> let
+		    num_val_args = length [ a | (ValArg a) <- args ]
+		 in
+		 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
+
+      _ -> False
+    }
+\end{code}
+
+@manifestlyBottom@ looks at a Core expression and returns \tr{True} if
+it is obviously bottom, that is, it will certainly return bottom at
+some point.  It isn't a disaster if it errs on the conservative side
+(returning \tr{False}).
+
+\begin{code}
+manifestlyBottom :: GenCoreExpr bndr Id -> Bool
+
+manifestlyBottom (Var v)     = isBottomingId v
+manifestlyBottom (Lit _)     = False
+manifestlyBottom (Con _ _ _) = False
+manifestlyBottom (Prim _ _ _)= False
+manifestlyBottom (Lam _ _)   = False  -- we do not assume \x.bottom == bottom. should we? ToDo
+manifestlyBottom (CoTyLam _ e) = manifestlyBottom e
+manifestlyBottom (SCC _ e)   = manifestlyBottom e
+manifestlyBottom (Let _ e)   = manifestlyBottom e
+
+manifestlyBottom (Case e a)
+  = manifestlyBottom e
+  || (case a of
+	AlgAlts  alts def -> all mbalg  alts && mbdef def
+	PrimAlts alts def -> all mbprim alts && mbdef def
+     )
+  where
+    mbalg  (_,_,e') = manifestlyBottom e'
+
+    mbprim (_,e')   = manifestlyBottom e'
+
+    mbdef NoDefault          = True
+    mbdef (BindDefault _ e') = manifestlyBottom e'
+
+manifestlyBottom other_expr   -- look for manifest partial application
+  = case (collectArgs other_expr) of { (fun, args) ->
+    case fun of
+      Var f | isBottomingId f -> True		-- Application of a function which
+						-- always gives bottom; we treat this as
+						-- a WHNF, because it certainly doesn't
+						-- need to be shared!
+      _ -> False
+    }
+\end{code}
+
+\begin{code}
+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 (digForLambdas  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, args) ->
+	case fun of
+	  Var scrut_var -> let
+				answer =
+				     scrut_var /= var && all (doesn't_mention var) args
+				  && 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, args) ->
+	case fun of
+	  Var wrkr -> let
+			    answer =
+				-- DOESN'T WORK: wrkr == var's_worker
+				wrkr /= var
+			     && isWorkerId wrkr
+			     && all (doesn't_mention var)  args
+			     && all (only_from case_ables) args
+			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.
+
+\begin{code}
+unTagBinders :: GenCoreExpr (Id,tag) bdee tv uv -> GenCoreExpr Id bdee tv uv
+unTagBinders expr = bop_expr fst expr
+
+unTagBindersAlts :: GenCoreCaseAlts (Id,tag) bdee tv uv -> GenCoreCaseAlts Id bdee tv uv
+unTagBindersAlts alts = bop_alts fst alts
+\end{code}
+
+\begin{code}
+bop_expr  :: (a -> b) -> GenCoreExpr a bdee tv uv -> GenCoreExpr b bdee tv uv
+
+bop_expr f (Var b)	     = Var b
+bop_expr f (Lit lit)	     = Lit lit
+bop_expr f (Con con args)    = Con con args
+bop_expr f (Prim op args)    = Prim op args
+bop_expr f (Lam binder expr) = Lam  (bop_binder f binder) (bop_expr f expr)
+bop_expr f (App expr arg)    = App  (bop_expr f expr) arg
+bop_expr f (SCC label expr)  = SCC  label (bop_expr f expr)
+bop_expr f (Let bind expr)   = Let  (bop_bind f bind) (bop_expr f expr)
+bop_expr f (Case expr alts)  = Case (bop_expr f expr) (bop_alts f alts)
+
+bop_binder f (ValBinder   v) = ValBinder (f v)
+bop_binder f (TyBinder    t) = TyBinder    t
+bop_binder f (UsageBinder u) = UsageBinder u
+
+bop_bind f (NonRec b e)	= NonRec (f b) (bop_expr f e)
+bop_bind f (Rec pairs)	= Rec [(f b, bop_expr f e) | (b, e) <- pairs]
+
+bop_alts f (AlgAlts alts deflt)
+  = AlgAlts  [ (con, [f b | b <- binders], bop_expr f e)
+	     | (con, binders, e) <- alts ]
+	     (bop_deflt f deflt)
+
+bop_alts f (PrimAlts alts deflt)
+  = PrimAlts [ (lit, bop_expr f e) | (lit, e) <- alts ]
+    	     (bop_deflt f deflt)
+
+bop_deflt f (NoDefault)		 = NoDefault
+bop_deflt f (BindDefault b expr) = BindDefault (f b) (bop_expr f expr)
+\end{code}
+
+OLD (but left here because of the nice example): @singleAlt@ checks
+whether a bunch of case alternatives is actually just one alternative.
+It specifically {\em ignores} alternatives which consist of just a
+call to @error@, because they won't result in any code duplication.
+
+Example:
+\begin{verbatim}
+	case (case <something> of
+		True  -> <rhs>
+		False -> error "Foo") of
+	<alts>
+
+===>
+
+	case <something> of
+	   True ->  case <rhs> of
+		    <alts>
+	   False -> case error "Foo" of
+		    <alts>
+
+===>
+
+	case <something> of
+	   True ->  case <rhs> of
+		    <alts>
+	   False -> error "Foo"
+\end{verbatim}
+Notice that the \tr{<alts>} don't get duplicated.
+
+\begin{code}
+{- LATER:
+nonErrorRHSs :: GenCoreCaseAlts binder Id -> [GenCoreExpr binder Id]
+
+nonErrorRHSs alts = filter not_error_app (find_rhss alts)
+  where
+    find_rhss (AlgAlts  alts deflt) = [rhs | (_,_,rhs) <- alts] ++ deflt_rhs deflt
+    find_rhss (PrimAlts alts deflt) = [rhs | (_,rhs)   <- alts] ++ deflt_rhs deflt
+
+    deflt_rhs NoDefault           = []
+    deflt_rhs (BindDefault _ rhs) = [rhs]
+
+    not_error_app rhs = case maybeErrorApp rhs Nothing of
+			 Just _  -> False
+			 Nothing -> True
+\end{code}
+
+maybeErrorApp checkes whether an expression is of the form
+
+	error ty args
+
+If so, it returns
+
+	Just (error ty' args)
+
+where ty' is supplied as an argument to maybeErrorApp.
+
+Here's where it is useful:
+
+		case (error ty "Foo" e1 e2) of <alts>
+ ===>
+		error ty' "Foo"
+
+where ty' is the type of any of the alternatives.
+You might think this never occurs, but see the comments on
+the definition of @singleAlt@.
+
+Note: we *avoid* the case where ty' might end up as a
+primitive type: this is very uncool (totally wrong).
+
+NOTICE: in the example above we threw away e1 and e2, but
+not the string "Foo".  How did we know to do that?
+
+Answer: for now anyway, we only handle the case of a function
+whose type is of form
+
+	bottomingFn :: forall a. t1 -> ... -> tn -> a
+	    	    	      ^---------------------^ NB!
+
+Furthermore, we only count a bottomingApp if the function is
+applied to more than n args.  If so, we transform:
+
+	bottomingFn ty e1 ... en en+1 ... em
+to
+	bottomingFn ty' e1 ... en
+
+That is, we discard en+1 .. em
+
+\begin{code}
+maybeErrorApp :: GenCoreExpr bndr Id   -- Expr to look at
+	      -> Maybe Type	    -- Just ty => a result type *already cloned*;
+				    -- Nothing => don't know result ty; we
+				    -- *pretend* that the result ty won't be
+				    -- primitive -- somebody later must
+				    -- ensure this.
+	       -> Maybe (GenCoreExpr bndr Id)
+
+maybeErrorApp expr result_ty_maybe
+  = case collectArgs expr of
+      (Var fun, (TypeArg ty : other_args))
+	| isBottomingId fun
+	&& maybeToBool result_ty_maybe -- we *know* the result type
+				       -- (otherwise: live a fairy-tale existence...)
+	&& not (isPrimType result_ty) ->
+	case splitSigmaTy (idType fun) of
+	  ([tyvar_tmpl], [], tau_ty) ->
+	      case (splitTyArgs tau_ty) of { (arg_tys, res_ty) ->
+	      let
+		  n_args_to_keep = length arg_tys
+		  args_to_keep   = take n_args_to_keep other_args
+	      in
+	      if  res_ty == mkTyVarTemplateTy tyvar_tmpl &&
+		  n_args_to_keep <= length other_args
+	      then
+		    -- Phew!  We're in business
+		  Just (mkGenApp (Var fun)
+			      (TypeArg result_ty : args_to_keep))
+	      else
+		  Nothing
+	      }
+
+	  other -> 	-- Function type wrong shape
+		    Nothing
+      other -> Nothing
+  where
+    Just result_ty = result_ty_maybe
+\end{code}
+
+\begin{code}
+squashableDictishCcExpr :: CostCentre -> GenCoreExpr a b -> Bool
+
+squashableDictishCcExpr cc expr
+  = if not (isDictCC cc) then
+	False -- that was easy...
+    else
+	squashable expr -- note: quite like the "atomic_rhs" stuff in simplifier
+  where
+    squashable (Var _)      = True
+    squashable (CoTyApp f _)  = squashable f
+    squashable (Con _ _ _)  = True -- I think so... WDP 94/09
+    squashable (Prim _ _ _) = True -- ditto
+    squashable other	      = False
+-}
+\end{code}
+
+%************************************************************************
+%*									*
+\subsection{Core-renaming utils}
+%*									*
+%************************************************************************
+
+\begin{code}
+substCoreExpr	:: ValEnv
+		-> TypeEnv -- TyVar=>Type
+		-> CoreExpr
+		-> UniqSM CoreExpr
+
+substCoreExpr venv tenv expr
+  -- if the envs are empty, then avoid doing anything
+  = if (isNullIdEnv venv && isNullTyVarEnv tenv) then
+       returnUs expr
+    else
+       do_CoreExpr venv tenv expr
+\end{code}
+
+The equiv code for @Types@ is in @TyUtils@.
+
+Because binders aren't necessarily unique: we don't do @plusEnvs@
+(which check for duplicates); rather, we use the shadowing version,
+@growIdEnv@ (and shorthand @addOneToIdEnv@).
+
+@do_CoreBindings@ takes into account the semantics of a list of
+@CoreBindings@---things defined early in the list are visible later in
+the list, but not vice versa.
+
+\begin{code}
+type ValEnv  = IdEnv CoreExpr
+
+do_CoreBindings :: ValEnv
+		-> TypeEnv
+		-> [CoreBinding]
+		-> UniqSM [CoreBinding]
+
+do_CoreBinding :: ValEnv
+	       -> TypeEnv
+	       -> CoreBinding
+	       -> UniqSM (CoreBinding, ValEnv)
+
+do_CoreBindings venv tenv [] = returnUs []
+do_CoreBindings venv tenv (b:bs)
+  = do_CoreBinding  venv     tenv b	`thenUs` \ (new_b,  new_venv) ->
+    do_CoreBindings new_venv tenv bs	`thenUs` \  new_bs ->
+    returnUs (new_b : new_bs)
+
+do_CoreBinding venv tenv (NonRec binder rhs)
+  = do_CoreExpr venv tenv rhs	`thenUs` \ new_rhs ->
+
+    dup_binder tenv binder	`thenUs` \ (new_binder, (old, new)) ->
+    -- now plug new bindings into envs
+    let  new_venv = addOneToIdEnv venv old new  in
+
+    returnUs (NonRec new_binder new_rhs, new_venv)
+
+do_CoreBinding venv tenv (Rec binds)
+  = -- for letrec, we plug in new bindings BEFORE cloning rhss
+    mapAndUnzipUs (dup_binder tenv) binders `thenUs` \ (new_binders, new_maps) ->
+    let  new_venv = growIdEnvList venv new_maps in
+
+    mapUs (do_CoreExpr new_venv tenv) rhss `thenUs` \ new_rhss ->
+    returnUs (Rec (new_binders `zipEqual` new_rhss), new_venv)
+  where
+    (binders, rhss) = unzip binds
+\end{code}
+
+\begin{code}
+do_CoreArg :: ValEnv
+	    -> TypeEnv
+	    -> CoreArg
+	    -> UniqSM CoreExpr
+
+do_CoreArg venv tenv (LitArg lit)     = returnUs (Lit lit)
+do_CoreArg venv tenv (TyArg ty)	      = panic "do_CoreArg: TyArg"
+do_CoreArg venv tenv (UsageArg usage) = panic "do_CoreArg: UsageArg"
+do_CoreArg venv tenv (VarArg v)
+  = returnUs (
+      case (lookupIdEnv venv v) of
+	Nothing   -> --false:ASSERT(toplevelishId v)
+		     Var v
+	Just expr -> expr
+    )
+\end{code}
+
+\begin{code}
+do_CoreExpr :: ValEnv
+	    -> TypeEnv
+	    -> CoreExpr
+	    -> UniqSM CoreExpr
+
+do_CoreExpr venv tenv orig_expr@(Var var)
+  = returnUs (
+      case (lookupIdEnv venv var) of
+	Nothing	    -> --false:ASSERT(toplevelishId var) (SIGH)
+		       orig_expr
+	Just expr   -> expr
+    )
+
+do_CoreExpr venv tenv e@(Lit _) = returnUs e
+
+do_CoreExpr venv tenv (Con con as)
+  = panic "CoreUtils.do_CoreExpr:Con"
+{- LATER:
+  = mapUs  (do_CoreArg venv tenv) as `thenUs`  \ new_as ->
+    mkCoCon con new_as
+-}
+
+do_CoreExpr venv tenv (Prim op as)
+  = panic "CoreUtils.do_CoreExpr:Prim"
+{- LATER:
+  = mapUs  (do_CoreArg venv tenv) as 	`thenUs`  \ new_as ->
+    do_PrimOp op			`thenUs`  \ new_op ->
+    mkCoPrim new_op new_as
+  where
+    do_PrimOp (CCallOp label is_asm may_gc arg_tys result_ty)
+      = let
+	    new_arg_tys   = map (applyTypeEnvToTy tenv) arg_tys
+	    new_result_ty = applyTypeEnvToTy tenv result_ty
+	in
+	returnUs (CCallOp label is_asm may_gc new_arg_tys new_result_ty)
+
+    do_PrimOp other_op = returnUs other_op
+-}
+
+do_CoreExpr venv tenv (Lam binder expr)
+  = dup_binder tenv binder `thenUs` \(new_binder, (old,new)) ->
+    let  new_venv = addOneToIdEnv venv old new  in
+    do_CoreExpr new_venv tenv expr  `thenUs` \ new_expr ->
+    returnUs (Lam new_binder new_expr)
+
+do_CoreExpr venv tenv (App expr arg)
+  = panic "CoreUtils.do_CoreExpr:App"
+{-
+  = do_CoreExpr venv tenv expr	`thenUs` \ new_expr ->
+    do_CoreArg  venv tenv arg   `thenUs` \ new_arg  ->
+    mkCoApp new_expr new_arg
+-}
+
+do_CoreExpr venv tenv (Case expr alts)
+  = do_CoreExpr venv tenv expr	    `thenUs` \ new_expr ->
+    do_alts venv tenv alts	    `thenUs` \ new_alts ->
+    returnUs (Case new_expr new_alts)
+  where
+    do_alts venv tenv (AlgAlts alts deflt)
+      = mapUs (do_boxed_alt venv tenv) alts `thenUs` \ new_alts ->
+    	do_default venv tenv deflt	    `thenUs` \ new_deflt ->
+	returnUs (AlgAlts new_alts new_deflt)
+      where
+	do_boxed_alt venv tenv (con, binders, expr)
+	  = mapAndUnzipUs (dup_binder tenv) binders `thenUs` \ (new_binders, new_vmaps) ->
+	    let  new_venv = growIdEnvList venv new_vmaps  in
+	    do_CoreExpr new_venv tenv expr  `thenUs` \ new_expr ->
+	    returnUs (con, new_binders, new_expr)
+
+
+    do_alts venv tenv (PrimAlts alts deflt)
+      = mapUs (do_unboxed_alt venv tenv) alts `thenUs` \ new_alts ->
+    	do_default venv tenv deflt	      `thenUs` \ new_deflt ->
+	returnUs (PrimAlts new_alts new_deflt)
+      where
+	do_unboxed_alt venv tenv (lit, expr)
+	  = do_CoreExpr venv tenv expr	`thenUs` \ new_expr ->
+	    returnUs (lit, new_expr)
+
+    do_default venv tenv NoDefault = returnUs NoDefault
+
+    do_default venv tenv (BindDefault binder expr)
+      =	dup_binder tenv binder		`thenUs` \ (new_binder, (old, new)) ->
+	let  new_venv = addOneToIdEnv venv old new  in
+	do_CoreExpr new_venv tenv expr	`thenUs` \ new_expr ->
+	returnUs (BindDefault new_binder new_expr)
+
+do_CoreExpr venv tenv (Let core_bind expr)
+  = do_CoreBinding venv tenv core_bind	`thenUs` \ (new_bind, new_venv) ->
+    -- and do the body of the let
+    do_CoreExpr new_venv tenv expr  	`thenUs` \ new_expr ->
+    returnUs (Let new_bind new_expr)
+
+do_CoreExpr venv tenv (SCC label expr)
+  = do_CoreExpr venv tenv expr	    	`thenUs` \ new_expr ->
+    returnUs (SCC label new_expr)
+\end{code}
diff --git a/ghc/compiler/coreSyn/FreeVars.hi b/ghc/compiler/coreSyn/FreeVars.hi
deleted file mode 100644
index 6f87f6726d..0000000000
--- a/ghc/compiler/coreSyn/FreeVars.hi
+++ /dev/null
@@ -1,33 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface FreeVars where
-import AnnCoreSyn(AnnCoreBinding, AnnCoreCaseAlternatives, AnnCoreCaseDefault, AnnCoreExpr', AnnCoreExpr(..))
-import BasicLit(BasicLit)
-import CoreSyn(CoreAtom, CoreBinding, CoreCaseAlternatives, CoreExpr)
-import CostCentre(CostCentre)
-import Id(Id)
-import PrimOps(PrimOp)
-import TyVar(TyVar)
-import UniType(UniType)
-import UniqFM(UniqFM)
-import UniqSet(IdSet(..), TyVarSet(..), UniqSet(..))
-data AnnCoreBinding a b c 
-data AnnCoreCaseAlternatives a b c 
-data AnnCoreCaseDefault a b c 
-type AnnCoreExpr a b c = (c, AnnCoreExpr' a b c)
-data AnnCoreExpr' a b c 
-data CoreExpr a b 
-type CoreExprWithFVs = (FVInfo, AnnCoreExpr' Id Id FVInfo)
-type FVCoreBinding = CoreBinding (Id, UniqFM Id) Id
-type FVCoreExpr = CoreExpr (Id, UniqFM Id) Id
-data FVInfo   = FVInfo (UniqFM Id) (UniqFM TyVar) LeakInfo
-data Id 
-data UniType 
-type IdSet = UniqFM Id
-data LeakInfo   = MightLeak | LeakFree Int
-type TyVarSet = UniqFM TyVar
-type UniqSet a = UniqFM a
-addTopBindsFVs :: (UniqFM Id -> Id -> Bool) -> [CoreBinding Id Id] -> ([CoreBinding (Id, UniqFM Id) Id], UniqFM Id)
-freeTyVarsOf :: (FVInfo, AnnCoreExpr' Id Id FVInfo) -> UniqFM TyVar
-freeVars :: CoreExpr Id Id -> (FVInfo, AnnCoreExpr' Id Id FVInfo)
-freeVarsOf :: (FVInfo, AnnCoreExpr' Id Id FVInfo) -> UniqFM Id
-
diff --git a/ghc/compiler/coreSyn/FreeVars.lhs b/ghc/compiler/coreSyn/FreeVars.lhs
index 54a242694f..62c8e80de2 100644
--- a/ghc/compiler/coreSyn/FreeVars.lhs
+++ b/ghc/compiler/coreSyn/FreeVars.lhs
@@ -9,14 +9,6 @@ Taken quite directly from the Peyton Jones/Lester paper.
 module FreeVars (
 	freeVars,
 
-#ifdef DPH
--- ToDo: DPH: you should probably use addExprFVs now... [WDP]
-	freeStuff,	-- Need a function that gives fvs of 
-			-- an expression. I therefore need a 
-			-- way of passing in candidates or top 
-			-- level will always be empty.
-#endif {- Data Parallel Haskell -}
-
 	-- cheap and cheerful variant...
 	addTopBindsFVs,
 
@@ -24,26 +16,21 @@ module FreeVars (
 	FVCoreExpr(..), FVCoreBinding(..),
 
 	CoreExprWithFVs(..),		-- For the above functions
-	AnnCoreExpr(..),		-- Dito	
-	FVInfo(..), LeakInfo(..),
+	AnnCoreExpr(..),		-- Dito
+	FVInfo(..), LeakInfo(..)
 
 	-- and to make the interface self-sufficient...
-	CoreExpr, Id, IdSet(..), TyVarSet(..), UniqSet(..), UniType,
-	AnnCoreExpr', AnnCoreBinding, AnnCoreCaseAlternatives,
-	AnnCoreCaseDefault
     ) where
 
 
-import PlainCore	-- input
 import AnnCoreSyn	-- output
 
-import AbsPrel		( PrimOp(..), PrimKind -- for CCallOp
+import PrelInfo		( PrimOp(..), PrimRep -- for CCallOp
 			  IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
 			  IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
 			)
-import AbsUniType	( extractTyVarsFromTy )
-import BasicLit		( typeOfBasicLit )
-import Id		( getIdUniType, getIdArity, toplevelishId, isBottomingId )
+import Type		( extractTyVarsFromTy )
+import Id		( idType, getIdArity, toplevelishId, isBottomingId )
 import IdInfo		-- Wanted for arityMaybe, but it seems you have
 			-- to import it all...  (Death to the Instance Virus!)
 import Maybes
@@ -75,7 +62,7 @@ type IdCands	= IdSet	    -- "candidate" TyVars/Ids.
 noTyVarCands    = emptyUniqSet
 noIdCands       = emptyUniqSet
 
-data FVInfo = FVInfo 
+data FVInfo = FVInfo
 		IdSet	    -- Free ids
 		TyVarSet    -- Free tyvars
 		LeakInfo
@@ -86,11 +73,11 @@ aFreeId i      = singletonUniqSet i
 aFreeTyVar t   = singletonUniqSet t
 is_among       = elementOfUniqSet
 combine	       = unionUniqSets
-munge_id_ty  i = mkUniqSet (extractTyVarsFromTy (getIdUniType i))
+munge_id_ty  i = mkUniqSet (extractTyVarsFromTy (idType i))
 
 combineFVInfo (FVInfo fvs1 tfvs1 leak1) (FVInfo fvs2 tfvs2 leak2)
-  = FVInfo (fvs1  `combine` fvs2) 
-	   (tfvs1 `combine` tfvs2) 
+  = FVInfo (fvs1  `combine` fvs2)
+	   (tfvs1 `combine` tfvs2)
 	   (leak1 `orLeak`	  leak2)
 \end{code}
 
@@ -119,7 +106,7 @@ orLeak (LeakFree n) (LeakFree m) = LeakFree (n `min` m)
 
 Main public interface:
 \begin{code}
-freeVars :: PlainCoreExpr -> CoreExprWithFVs
+freeVars :: CoreExpr -> CoreExprWithFVs
 
 freeVars expr = fvExpr noIdCands noTyVarCands expr
 \end{code}
@@ -135,10 +122,10 @@ put them on the candidates list.
 
 fvExpr :: IdCands	    -- In-scope Ids
        -> TyVarCands	    -- In-scope tyvars
-       -> PlainCoreExpr 
+       -> CoreExpr
        -> CoreExprWithFVs
 
-fvExpr id_cands tyvar_cands (CoVar v) 
+fvExpr id_cands tyvar_cands (Var v)
   = (FVInfo (if (v `is_among` id_cands)
 	     then aFreeId v
 	     else noFreeIds)
@@ -152,44 +139,40 @@ fvExpr id_cands tyvar_cands (CoVar v)
 			    Nothing    -> lEAK_FREE_0
 			    Just arity -> LeakFree arity
 
-fvExpr id_cands tyvar_cands (CoLit k) 
+fvExpr id_cands tyvar_cands (Lit k)
   = (FVInfo noFreeIds noFreeTyVars lEAK_FREE_0, AnnCoLit k)
 
-fvExpr id_cands tyvar_cands (CoCon c tys args)
+fvExpr id_cands tyvar_cands (Con c tys args)
   = (FVInfo args_fvs tfvs lEAK_FREE_0, AnnCoCon c tys args)
   where
     args_fvs = foldr (combine . freeAtom id_cands)  noFreeIds    args
     tfvs     = foldr (combine . freeTy tyvar_cands) noFreeTyVars tys
 
-fvExpr id_cands tyvar_cands (CoPrim op@(CCallOp _ _ _ _ res_ty) tys args)
+fvExpr id_cands tyvar_cands (Prim op@(CCallOp _ _ _ _ res_ty) tys args)
   = ASSERT (null tys)
     (FVInfo args_fvs tfvs lEAK_FREE_0, AnnCoPrim op tys args)
   where
     args_fvs = foldr (combine . freeAtom id_cands)  noFreeIds    args
     tfvs     = foldr (combine . freeTy tyvar_cands) noFreeTyVars (res_ty:tys)
 
-fvExpr id_cands tyvar_cands (CoPrim op tys args)
+fvExpr id_cands tyvar_cands (Prim op tys args)
   = (FVInfo args_fvs tfvs lEAK_FREE_0, AnnCoPrim op tys args)
   where
     args_fvs = foldr (combine . freeAtom id_cands)  noFreeIds    args
     tfvs     = foldr (combine . freeTy tyvar_cands) noFreeTyVars tys
 
-fvExpr id_cands tyvar_cands (CoLam binders body)
-  = (FVInfo (freeVarsOf body2   `minusUniqSet`  mkUniqSet binders)
-	    (freeTyVarsOf body2 `combine` binder_ftvs)
+fvExpr id_cands tyvar_cands (Lam binder body)
+  = (FVInfo (freeVarsOf body2   `minusUniqSet`  singletonUniqSet binder)
+	    (freeTyVarsOf body2 `combine` munge_id_ty binder)
 	    leakiness,
-     AnnCoLam binders body2)
+     AnnCoLam binder body2)
   where
 	-- We need to collect free tyvars from the binders
-    body2 = fvExpr (mkUniqSet binders `combine` id_cands) tyvar_cands body
-
-    binder_ftvs
-      = foldr (combine . munge_id_ty) noFreeTyVars binders
+    body2 = fvExpr (singletonUniqSet binder `combine` id_cands) tyvar_cands body
 
-    no_args   = length binders
     leakiness = case leakinessOf body2 of
-		  MightLeak  -> LeakFree  no_args
-		  LeakFree n -> LeakFree (n + no_args)
+		  MightLeak  -> LeakFree 1
+		  LeakFree n -> LeakFree (n + 1)
 
 fvExpr id_cands tyvar_cands (CoTyLam tyvar body)
   = (FVInfo (freeVarsOf body2)
@@ -199,7 +182,7 @@ fvExpr id_cands tyvar_cands (CoTyLam tyvar body)
   where
     body2 = fvExpr id_cands (aFreeTyVar tyvar `combine` tyvar_cands) body
 
-fvExpr id_cands tyvar_cands (CoApp fun arg)
+fvExpr id_cands tyvar_cands (App fun arg)
   = (FVInfo (freeVarsOf fun2 `combine` fvs_arg)
 	    (freeTyVarsOf fun2)
 	    leakiness,
@@ -221,19 +204,19 @@ fvExpr id_cands tyvar_cands (CoTyApp expr ty)
     expr2    = fvExpr id_cands tyvar_cands expr
     tfvs_arg = freeTy tyvar_cands ty
 
-fvExpr id_cands tyvar_cands (CoCase expr alts)
+fvExpr id_cands tyvar_cands (Case expr alts)
   = (combineFVInfo expr_fvinfo alts_fvinfo,
      AnnCoCase expr2 alts')
   where
     expr2@(expr_fvinfo,_) = fvExpr id_cands tyvar_cands expr
     (alts_fvinfo, alts') = annotate_alts alts
 
-    annotate_alts (CoAlgAlts alts deflt)
+    annotate_alts (AlgAlts alts deflt)
       = (fvinfo, AnnCoAlgAlts alts' deflt')
       where
     	(alts_fvinfo_s, alts') = unzip (map ann_boxed_alt alts)
     	(deflt_fvinfo, deflt') = annotate_default deflt
-        fvinfo = foldr combineFVInfo deflt_fvinfo alts_fvinfo_s
+	fvinfo = foldr combineFVInfo deflt_fvinfo alts_fvinfo_s
 
 	ann_boxed_alt (con, params, rhs)
 	  = (FVInfo (freeVarsOf rhs' `minusUniqSet` mkUniqSet params)
@@ -245,7 +228,7 @@ fvExpr id_cands tyvar_cands (CoCase expr alts)
 	    param_ftvs = foldr (combine . munge_id_ty) noFreeTyVars params
 		-- We need to collect free tyvars from the binders
 
-    annotate_alts (CoPrimAlts alts deflt)
+    annotate_alts (PrimAlts alts deflt)
       = (fvinfo, AnnCoPrimAlts alts' deflt')
       where
     	(alts_fvinfo_s, alts') = unzip (map ann_unboxed_alt alts)
@@ -256,40 +239,10 @@ fvExpr id_cands tyvar_cands (CoCase expr alts)
     	  where
 	    rhs'@(rhs_info,_) = fvExpr id_cands tyvar_cands rhs
 
-#ifdef DPH
-    annotate_alts id_cands tyvar_cands (CoParAlgAlts tycon ctxt binders alts deflt)
-      = ((alts_fvs `minusUniqSet` (mkUniqSet binders)) `combine` deflt_fvs,
-    	 AnnCoParAlgAlts tycon ctxt binders alts' deflt')
-      where
-    	(alts_fvs_sets,  alts')	= unzip (map (ann_boxed_par_alt id_cands tyvar_cands) alts)
-	alts_fvs		= unionManyUniqSets alts_fvs_sets
-    	(deflt_fvs, ???ToDo:DPH, deflt')	= annotate_default deflt
-
-	ann_boxed_par_alt id_cands tyvar_cands (con, rhs)
-	  = (rhs_fvs, (con, rhs'))
-    	  where
-	    rhs'     = fvExpr (mkUniqSet binders `combine` id_cands) tyvar_cands rhs
-	    rhs_fvs  = freeVarsOf rhs'
-
-    annotate_alts id_cands tyvar_cands (CoParPrimAlts tycon ctxt alts deflt)
-      = (alts_fvs `combine` deflt_fvs,
-    	 AnnCoParPrimAlts tycon ctxt alts' deflt')
-      where
-    	(alts_fvs_sets,  alts')	= unzip (map (ann_unboxed_par_alt id_cands tyvar_cands) alts)
-	alts_fvs		= unionManyUniqSets alts_fvs_sets
-    	(deflt_fvs, ??? ToDo:DPH, deflt')	= annotate_default deflt
-
-	ann_unboxed_par_alt id_cands tyvar_cands (lit, rhs)
-	  = (rhs_fvs, (lit, rhs'))
-    	  where
-	    rhs'     = fvExpr id_cands tyvar_cands rhs
-	    rhs_fvs  = freeVarsOf rhs'
-#endif {- Data Parallel Haskell -}
-
-    annotate_default CoNoDefault = (FVInfo noFreeIds noFreeTyVars lEAK_FREE_BIG, 
+    annotate_default NoDefault = (FVInfo noFreeIds noFreeTyVars lEAK_FREE_BIG,
 				    AnnCoNoDefault)
 
-    annotate_default (CoBindDefault binder rhs)
+    annotate_default (BindDefault binder rhs)
       = (FVInfo (freeVarsOf   rhs' `minusUniqSet` aFreeId binder)
 		(freeTyVarsOf rhs' `combine` binder_ftvs)
 		(leakinessOf rhs'),
@@ -299,7 +252,7 @@ fvExpr id_cands tyvar_cands (CoCase expr alts)
 	binder_ftvs = munge_id_ty binder
 	    -- We need to collect free tyvars from the binder
 
-fvExpr id_cands tyvar_cands (CoLet (CoNonRec binder rhs) body)
+fvExpr id_cands tyvar_cands (Let (NonRec binder rhs) body)
   = (FVInfo (freeVarsOf rhs'   `combine` body_fvs)
 	    (freeTyVarsOf rhs' `combine` freeTyVarsOf body2 `combine` binder_ftvs)
 	    (leakinessOf rhs' `orLeak` leakinessOf body2),
@@ -311,7 +264,7 @@ fvExpr id_cands tyvar_cands (CoLet (CoNonRec binder rhs) body)
     binder_ftvs = munge_id_ty binder
 	-- We need to collect free tyvars from the binder
 
-fvExpr id_cands tyvar_cands (CoLet (CoRec binds) body)
+fvExpr id_cands tyvar_cands (Let (Rec binds) body)
   = (FVInfo (binds_fvs `combine` body_fvs)
 	    (rhss_tfvs `combine` freeTyVarsOf body2 `combine` binders_ftvs)
 	    (leakiness_of_rhss `orLeak` leakinessOf body2),
@@ -331,51 +284,20 @@ fvExpr id_cands tyvar_cands (CoLet (CoRec binds) body)
     binders_ftvs      = foldr (combine . munge_id_ty) noFreeTyVars binders
 	-- We need to collect free tyvars from the binders
 
-fvExpr id_cands tyvar_cands (CoSCC label expr)
+fvExpr id_cands tyvar_cands (SCC label expr)
   = (fvinfo, AnnCoSCC label expr2)
   where
     expr2@(fvinfo,_) = fvExpr id_cands tyvar_cands expr
-
-#ifdef DPH
-fvExpr id_cands tyvar_cands e@(CoParCon c ctxt tys args)
-  = ((args_fvs, typeOfCoreExpr e), AnnCoParCon c ctxt tys args')
-  where
-    args'	= map (fvExpr id_cands tyvar_cands) args
-    args_fvs	= unionManyUniqSets [ fvs | ((fvs,_), _) <- args' ]
-
-fvExpr id_cands tyvar_cands e@(CoParComm ctxt expr comm)
-  = ((expr_fvs `combine` comm_fvs, tyOf expr2), AnnCoParComm ctxt expr2 comm')
-  where
-    expr2            = fvExpr id_cands tyvar_cands expr
-    expr_fvs         = freeVarsOf expr2
-    (comm_fvs,comm') = free_stuff_comm id_cands tyvar_cands comm
-
-    free_stuff_comm id_cands tyvar_cands (CoParSend exprs)
-      = let exprs'    = map (fvExpr id_cands tyvar_cands) exprs			in
-	let exprs_fvs = unionManyUniqSets [fvs | ((fvs,_), _) <- exprs' ]  in
-        (exprs_fvs,AnnCoParSend exprs')
-
-    free_stuff_comm id_cands tyvar_cands (CoParFetch exprs)
-      = let exprs'    = map (fvExpr id_cands tyvar_cands) exprs			in
-	let exprs_fvs = unionManyUniqSets [fvs | ((fvs,_), _) <- exprs' ]  in
-        (exprs_fvs,AnnCoParFetch exprs')
-
-    free_stuff_comm id_cands tyvar_cands (CoToPodized)
-      = (emptyUniqSet, AnnCoToPodized)
-
-    free_stuff_comm id_cands tyvar_cands (CoFromPodized)
-      = (emptyUniqSet, AnnCoFromPodized)     
-#endif {- Data Parallel Haskell -}
 \end{code}
 
 \begin{code}
-freeAtom :: IdCands -> PlainCoreAtom ->  IdSet
+freeAtom :: IdCands -> CoreArg ->  IdSet
 
-freeAtom cands (CoLitAtom k) = noFreeIds
-freeAtom cands (CoVarAtom v) | v `is_among` cands = aFreeId v
+freeAtom cands (LitArg k) = noFreeIds
+freeAtom cands (VarArg v) | v `is_among` cands = aFreeId v
 			     | otherwise	  = noFreeIds
 
-freeTy :: TyVarCands -> UniType -> TyVarSet
+freeTy :: TyVarCands -> Type -> TyVarSet
 
 freeTy cands ty = mkUniqSet (extractTyVarsFromTy ty) `intersectUniqSets` cands
 
@@ -409,7 +331,7 @@ expression!
   The free vars attached to a let(rec) binder are the free vars of the
   rhs of the binding.  In the case of letrecs, this set excludes the
   binders themselves.
-\item  
+\item
   The free vars attached to a case alternative binder are the free
   vars of the alternative, excluding the alternative's binders.
 \end{itemize}
@@ -417,7 +339,7 @@ expression!
 There's a predicate carried in which tells what is a free-var
 candidate. It is passed the Id and a set of in-scope Ids.
 
-(Global) constructors used on the rhs in a CoCon are also treated as
+(Global) constructors used on the rhs in a Con are also treated as
 potential free-var candidates (though they will not be recorded in the
 in-scope set). The predicate must decide if they are to be recorded as
 free-vars.
@@ -426,8 +348,8 @@ As it happens this is only ever used by the Specialiser!
 
 \begin{code}
 type FVCoreBinder  = (Id, IdSet)
-type FVCoreExpr    = CoreExpr    FVCoreBinder Id
-type FVCoreBinding = CoreBinding FVCoreBinder Id
+type FVCoreExpr    = GenCoreExpr    FVCoreBinder Id
+type FVCoreBinding = GenCoreBinding FVCoreBinder Id
 
 type InterestingIdFun
   =  IdSet	-- Non-top-level in-scope variables
@@ -438,32 +360,32 @@ type InterestingIdFun
 \begin{code}
 addExprFVs :: InterestingIdFun	-- "Interesting id" predicate
 	   -> IdSet		-- In scope ids
-	   -> PlainCoreExpr
+	   -> CoreExpr
 	   -> (FVCoreExpr, IdSet)
 
-addExprFVs fv_cand in_scope (CoVar v)
-  = (CoVar v, if fv_cand in_scope v
+addExprFVs fv_cand in_scope (Var v)
+  = (Var v, if fv_cand in_scope v
 	      then aFreeId v
 	      else noFreeIds)
 
-addExprFVs fv_cand in_scope (CoLit lit) = (CoLit lit, noFreeIds)
+addExprFVs fv_cand in_scope (Lit lit) = (Lit lit, noFreeIds)
 
-addExprFVs fv_cand in_scope (CoCon con tys args) 
-  = (CoCon con tys args,
-     if fv_cand in_scope con 
+addExprFVs fv_cand in_scope (Con con tys args)
+  = (Con con tys args,
+     if fv_cand in_scope con
      then aFreeId con
      else noFreeIds
 	`combine`
      unionManyUniqSets (map (fvsOfAtom fv_cand in_scope) args))
 
-addExprFVs fv_cand in_scope (CoPrim op tys args) 
-  = (CoPrim op tys args,
+addExprFVs fv_cand in_scope (Prim op tys args)
+  = (Prim op tys args,
      unionManyUniqSets (map (fvsOfAtom fv_cand in_scope) args))
 
-addExprFVs fv_cand in_scope (CoLam binders body)
-  = (CoLam (binders `zip` (repeat lam_fvs)) new_body, lam_fvs)
+addExprFVs fv_cand in_scope (Lam binder body)
+  = (Lam (binder,lam_fvs) new_body, lam_fvs)
   where
-    binder_set = mkUniqSet binders
+    binder_set = singletonUniqSet binder
     new_in_scope = in_scope `combine` binder_set
     (new_body, body_fvs) = addExprFVs fv_cand new_in_scope body
     lam_fvs = body_fvs `minusUniqSet` binder_set
@@ -473,8 +395,8 @@ addExprFVs fv_cand in_scope (CoTyLam tyvar body)
   where
     (body2, body_fvs) = addExprFVs fv_cand in_scope body
 
-addExprFVs fv_cand in_scope (CoApp fun arg)
-  = (CoApp fun2 arg, fun_fvs `combine` fvsOfAtom fv_cand in_scope arg)
+addExprFVs fv_cand in_scope (App fun arg)
+  = (App fun2 arg, fun_fvs `combine` fvsOfAtom fv_cand in_scope arg)
   where
     (fun2, fun_fvs) = addExprFVs fv_cand in_scope fun
 
@@ -483,26 +405,26 @@ addExprFVs fv_cand in_scope (CoTyApp fun ty)
   where
     (fun2, fun_fvs) = addExprFVs fv_cand in_scope fun
 
-addExprFVs fv_cand in_scope (CoCase scrut alts)
-  = (CoCase scrut' alts', scrut_fvs `combine` alts_fvs)
+addExprFVs fv_cand in_scope (Case scrut alts)
+  = (Case scrut' alts', scrut_fvs `combine` alts_fvs)
   where
     (scrut', scrut_fvs) = addExprFVs fv_cand in_scope scrut
 
     (alts', alts_fvs)
       = case alts of
-	  CoAlgAlts alg_alts deflt -> (CoAlgAlts alg_alts' deflt', fvs)
+	  AlgAlts alg_alts deflt -> (AlgAlts alg_alts' deflt', fvs)
 	    where
 	      (alg_alts', alt_fvs) = unzip (map do_alg_alt alg_alts)
 	      (deflt', deflt_fvs) = do_deflt deflt
 	      fvs = unionManyUniqSets (deflt_fvs : alt_fvs)
 
-	  CoPrimAlts prim_alts deflt -> (CoPrimAlts prim_alts' deflt', fvs)
+	  PrimAlts prim_alts deflt -> (PrimAlts prim_alts' deflt', fvs)
 	    where
 	      (prim_alts', alt_fvs) = unzip (map do_prim_alt prim_alts)
 	      (deflt', deflt_fvs) = do_deflt deflt
 	      fvs = unionManyUniqSets (deflt_fvs : alt_fvs)
 
-    do_alg_alt :: (Id, [Id], PlainCoreExpr)
+    do_alg_alt :: (Id, [Id], CoreExpr)
 	       -> ((Id, [FVCoreBinder], FVCoreExpr), IdSet)
 
     do_alg_alt (con, args, rhs) = ((con, args `zip` (repeat fvs), rhs'), fvs)
@@ -510,56 +432,54 @@ addExprFVs fv_cand in_scope (CoCase scrut alts)
 	new_in_scope = in_scope `combine` arg_set
 	(rhs', rhs_fvs) = addExprFVs fv_cand new_in_scope rhs
 	fvs = rhs_fvs `minusUniqSet` arg_set
-        arg_set = mkUniqSet args
+	arg_set = mkUniqSet args
 
     do_prim_alt (lit, rhs) = ((lit, rhs'), rhs_fvs)
       where
 	(rhs', rhs_fvs) = addExprFVs fv_cand in_scope rhs
 
-    do_deflt CoNoDefault = (CoNoDefault, noFreeIds)
-    do_deflt (CoBindDefault var rhs)
-      = (CoBindDefault (var,fvs) rhs', fvs)
+    do_deflt NoDefault = (NoDefault, noFreeIds)
+    do_deflt (BindDefault var rhs)
+      = (BindDefault (var,fvs) rhs', fvs)
       where
 	new_in_scope = in_scope `combine` var_set
 	(rhs', rhs_fvs) = addExprFVs fv_cand new_in_scope rhs
 	fvs = rhs_fvs `minusUniqSet` var_set
-        var_set = aFreeId var
+	var_set = aFreeId var
 
-addExprFVs fv_cand in_scope (CoLet binds body)
-  = (CoLet binds' body2, fvs_binds `combine` (fvs_body `minusUniqSet` binder_set))
+addExprFVs fv_cand in_scope (Let binds body)
+  = (Let binds' body2, fvs_binds `combine` (fvs_body `minusUniqSet` binder_set))
   where
     (binds', fvs_binds, new_in_scope, binder_set)
       = addBindingFVs fv_cand in_scope binds
 
     (body2, fvs_body)  = addExprFVs fv_cand new_in_scope body
 
-addExprFVs fv_cand in_scope (CoSCC label expr)
-  = (CoSCC label expr2, expr_fvs)
+addExprFVs fv_cand in_scope (SCC label expr)
+  = (SCC label expr2, expr_fvs)
   where
     (expr2, expr_fvs) = addExprFVs fv_cand in_scope expr
-
--- ToDo: DPH: add stuff here
 \end{code}
 
 \begin{code}
 addBindingFVs
 	    :: InterestingIdFun	-- "Interesting id" predicate
 	    -> IdSet		-- In scope ids
-	    -> PlainCoreBinding
+	    -> CoreBinding
 	    -> (FVCoreBinding,
 		IdSet,		-- Free vars of binding group
 		IdSet,		-- Augmented in-scope Ids
 		IdSet)		-- Set of Ids bound by this binding
 
-addBindingFVs fv_cand in_scope (CoNonRec binder rhs)
-  = (CoNonRec binder' rhs', fvs, new_in_scope, binder_set)
-  where 
+addBindingFVs fv_cand in_scope (NonRec binder rhs)
+  = (NonRec binder' rhs', fvs, new_in_scope, binder_set)
+  where
     ((binder', rhs'), fvs) = do_pair fv_cand in_scope binder_set (binder, rhs)
     new_in_scope = in_scope `combine` binder_set
     binder_set = aFreeId binder
 
-addBindingFVs fv_cand in_scope (CoRec pairs)
-  = (CoRec pairs', unionManyUniqSets fvs_s, new_in_scope, binder_set)
+addBindingFVs fv_cand in_scope (Rec pairs)
+  = (Rec pairs', unionManyUniqSets fvs_s, new_in_scope, binder_set)
   where
     binders = [binder | (binder,_) <- pairs]
     binder_set = mkUniqSet binders
@@ -570,7 +490,7 @@ addBindingFVs fv_cand in_scope (CoRec pairs)
 \begin{code}
 addTopBindsFVs
 	    :: InterestingIdFun	-- "Interesting id" predicate
-	    -> [PlainCoreBinding]
+	    -> [CoreBinding]
 	    -> ([FVCoreBinding],
 		IdSet)
 
@@ -586,10 +506,10 @@ addTopBindsFVs fv_cand (b:bs)
 \begin{code}
 fvsOfAtom   :: InterestingIdFun	-- "Interesting id" predicate
 	    -> IdSet		-- In scope ids
-	    -> PlainCoreAtom
+	    -> CoreArg
 	    -> IdSet
 
-fvsOfAtom fv_cand in_scope (CoVarAtom v)
+fvsOfAtom fv_cand in_scope (VarArg v)
   = if fv_cand in_scope v
     then aFreeId v
     else noFreeIds
@@ -598,7 +518,7 @@ fvsOfAtom _ _ _ = noFreeIds -- if a literal...
 do_pair	:: InterestingIdFun -- "Interesting id" predicate
 	-> IdSet   	    -- In scope ids
 	-> IdSet
-	-> (Id, PlainCoreExpr)
+	-> (Id, CoreExpr)
 	-> ((FVCoreBinder, FVCoreExpr), IdSet)
 
 do_pair fv_cand in_scope binder_set (binder,rhs)
diff --git a/ghc/compiler/coreSyn/Jmakefile b/ghc/compiler/coreSyn/Jmakefile
deleted file mode 100644
index 3e0bd41633..0000000000
--- a/ghc/compiler/coreSyn/Jmakefile
+++ /dev/null
@@ -1,11 +0,0 @@
-/* this is a standalone Jmakefile; NOT part of ghc "make world" */
-
-LitStuffNeededHere(docs depend)
-InfoStuffNeededHere(docs)
-HaskellSuffixRules()
-
-/* LIT2LATEX_OPTS=-tbird */
-
-LIT2LATEX_OPTS=-ttgrind
-
-LitDocRootTargetWithNamedOutput(root,lit,root-standalone)
diff --git a/ghc/compiler/coreSyn/PlainCore.hi b/ghc/compiler/coreSyn/PlainCore.hi
deleted file mode 100644
index d55bf95dff..0000000000
--- a/ghc/compiler/coreSyn/PlainCore.hi
+++ /dev/null
@@ -1,167 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface PlainCore where
-import Bag(Bag)
-import BasicLit(BasicLit)
-import BinderInfo(BinderInfo)
-import CharSeq(CSeq)
-import Class(Class)
-import CmdLineOpts(GlobalSwitch)
-import CoreFuns(atomToExpr, bindersOf, coreExprArity, digForLambdas, escErrorMsg, exprSmallEnoughToDup, instCoreBindings, instCoreExpr, isWrapperFor, manifestlyBottom, manifestlyWHNF, maybeErrorApp, mkCoApps, mkCoLam, mkCoLetAny, mkCoLetNoUnboxed, mkCoLetUnboxedToCase, mkCoLetrecAny, mkCoLetrecNoUnboxed, mkCoLetsAny, mkCoLetsNoUnboxed, mkCoLetsUnboxedToCase, mkCoTyApps, mkCoTyLam, mkCoreIfThenElse, mkErrorCoApp, mkFunction, nonErrorRHSs, pairsFromCoreBinds, squashableDictishCcExpr, substCoreExpr, substCoreExprUS, typeOfCoreAlts, typeOfCoreExpr)
-import CoreSyn(CoreArg(..), CoreAtom(..), CoreBinding(..), CoreCaseAlternatives(..), CoreCaseDefault(..), CoreExpr(..), applyToArgs, collectArgs, decomposeArgs, mkCoTyApp, pprCoreExpr)
-import CoreUnfold(calcUnfoldingGuidance, mentionedInUnfolding, pprCoreUnfolding)
-import CostCentre(CostCentre)
-import FreeVars(FVCoreBinding(..), FVCoreExpr(..), addTopBindsFVs)
-import Id(Id)
-import IdEnv(IdEnv(..))
-import IdInfo(Demand, IdInfo)
-import Maybes(Labda)
-import NameTypes(FullName)
-import Outputable(ExportFlag, NamedThing(..), Outputable(..))
-import PreludePS(_PackedString)
-import Pretty(Delay, PprStyle, Pretty(..), PrettyRep)
-import PrimOps(PrimOp)
-import SimplEnv(UnfoldingGuidance)
-import SrcLoc(SrcLoc)
-import TyCon(TyCon)
-import TyVar(TyVar)
-import TyVarEnv(TyVarEnv(..), TypeEnv(..))
-import UniType(SigmaType(..), TauType(..), ThetaType(..), UniType)
-import UniqFM(UniqFM)
-import UniqSet(IdSet(..), UniqSet(..))
-import Unique(UniqSM(..), Unique, UniqueSupply)
-class NamedThing a where
-	getExportFlag :: a -> ExportFlag
-	isLocallyDefined :: a -> Bool
-	getOrigName :: a -> (_PackedString, _PackedString)
-	getOccurrenceName :: a -> _PackedString
-	getInformingModules :: a -> [_PackedString]
-	getSrcLoc :: a -> SrcLoc
-	getTheUnique :: a -> Unique
-	hasType :: a -> Bool
-	getType :: a -> UniType
-	fromPreludeCore :: a -> Bool
-class Outputable a where
-	ppr :: PprStyle -> a -> Int -> Bool -> PrettyRep
-data Bag a 
-data BasicLit 
-data BinderInfo 
-data Class 
-data CoreArg a   = TypeArg UniType | ValArg (CoreAtom a)
-data CoreAtom a   = CoVarAtom a | CoLitAtom BasicLit
-data CoreBinding a b   = CoNonRec a (CoreExpr a b) | CoRec [(a, CoreExpr a b)]
-data CoreCaseAlternatives a b   = CoAlgAlts [(Id, [a], CoreExpr a b)] (CoreCaseDefault a b) | CoPrimAlts [(BasicLit, CoreExpr a b)] (CoreCaseDefault a b)
-data CoreCaseDefault a b   = CoNoDefault | CoBindDefault a (CoreExpr a b)
-data CoreExpr a b   = CoVar b | CoLit BasicLit | CoCon Id [UniType] [CoreAtom b] | CoPrim PrimOp [UniType] [CoreAtom b] | CoLam [a] (CoreExpr a b) | CoTyLam TyVar (CoreExpr a b) | CoApp (CoreExpr a b) (CoreAtom b) | CoTyApp (CoreExpr a b) UniType | CoCase (CoreExpr a b) (CoreCaseAlternatives a b) | CoLet (CoreBinding a b) (CoreExpr a b) | CoSCC CostCentre (CoreExpr a b)
-data CostCentre 
-type FVCoreBinding = CoreBinding (Id, UniqFM Id) Id
-type FVCoreExpr = CoreExpr (Id, UniqFM Id) Id
-data Id 
-type IdEnv a = UniqFM a
-data Demand 
-data IdInfo 
-data Labda a 
-data FullName 
-data ExportFlag 
-type PlainCoreArg = CoreArg Id
-type PlainCoreAtom = CoreAtom Id
-type PlainCoreBinding = CoreBinding Id Id
-type PlainCoreCaseAlternatives = CoreCaseAlternatives Id Id
-type PlainCoreCaseDefault = CoreCaseDefault Id Id
-type PlainCoreExpr = CoreExpr Id Id
-type PlainCoreProgram = [CoreBinding Id Id]
-data PprStyle 
-type Pretty = Int -> Bool -> PrettyRep
-data PrettyRep 
-data PrimOp 
-data UnfoldingGuidance 
-data SrcLoc 
-data TyCon 
-data TyVar 
-type TyVarEnv a = UniqFM a
-type TypeEnv = UniqFM UniType
-type SigmaType = UniType
-type TauType = UniType
-type ThetaType = [(Class, UniType)]
-data UniType 
-data UniqFM a 
-type IdSet = UniqFM Id
-type UniqSet a = UniqFM a
-type UniqSM a = UniqueSupply -> (UniqueSupply, a)
-data Unique 
-data UniqueSupply 
-atomToExpr :: CoreAtom b -> CoreExpr a b
-bindersOf :: CoreBinding b a -> [b]
-coreExprArity :: (Id -> Labda (CoreExpr a Id)) -> CoreExpr a Id -> Int
-digForLambdas :: CoreExpr a b -> ([TyVar], [a], CoreExpr a b)
-escErrorMsg :: [Char] -> [Char]
-exprSmallEnoughToDup :: CoreExpr a Id -> Bool
-instCoreBindings :: UniqueSupply -> [CoreBinding Id Id] -> (UniqueSupply, [CoreBinding Id Id])
-instCoreExpr :: UniqueSupply -> CoreExpr Id Id -> (UniqueSupply, CoreExpr Id Id)
-isWrapperFor :: CoreExpr Id Id -> Id -> Bool
-manifestlyBottom :: CoreExpr a Id -> Bool
-manifestlyWHNF :: CoreExpr a Id -> Bool
-maybeErrorApp :: CoreExpr a Id -> Labda UniType -> Labda (CoreExpr a Id)
-mkCoApps :: CoreExpr Id Id -> [CoreExpr Id Id] -> UniqueSupply -> (UniqueSupply, CoreExpr Id Id)
-mkCoLam :: [a] -> CoreExpr a b -> CoreExpr a b
-mkCoLetAny :: CoreBinding Id Id -> CoreExpr Id Id -> CoreExpr Id Id
-mkCoLetNoUnboxed :: CoreBinding Id Id -> CoreExpr Id Id -> CoreExpr Id Id
-mkCoLetUnboxedToCase :: CoreBinding Id Id -> CoreExpr Id Id -> CoreExpr Id Id
-mkCoLetrecAny :: [(Id, CoreExpr Id Id)] -> CoreExpr Id Id -> CoreExpr Id Id
-mkCoLetrecNoUnboxed :: [(Id, CoreExpr Id Id)] -> CoreExpr Id Id -> CoreExpr Id Id
-mkCoLetsAny :: [CoreBinding Id Id] -> CoreExpr Id Id -> CoreExpr Id Id
-mkCoLetsNoUnboxed :: [CoreBinding Id Id] -> CoreExpr Id Id -> CoreExpr Id Id
-mkCoLetsUnboxedToCase :: [CoreBinding Id Id] -> CoreExpr Id Id -> CoreExpr Id Id
-mkCoTyApps :: CoreExpr a b -> [UniType] -> CoreExpr a b
-mkCoTyLam :: [TyVar] -> CoreExpr a b -> CoreExpr a b
-mkCoreIfThenElse :: CoreExpr a Id -> CoreExpr a Id -> CoreExpr a Id -> CoreExpr a Id
-mkErrorCoApp :: UniType -> Id -> [Char] -> CoreExpr Id Id
-mkFunction :: [TyVar] -> [a] -> CoreExpr a b -> CoreExpr a b
-nonErrorRHSs :: CoreCaseAlternatives a Id -> [CoreExpr a Id]
-pairsFromCoreBinds :: [CoreBinding a b] -> [(a, CoreExpr a b)]
-squashableDictishCcExpr :: CostCentre -> CoreExpr a b -> Bool
-substCoreExpr :: UniqueSupply -> UniqFM (CoreExpr Id Id) -> UniqFM UniType -> CoreExpr Id Id -> (UniqueSupply, CoreExpr Id Id)
-substCoreExprUS :: UniqFM (CoreExpr Id Id) -> UniqFM UniType -> CoreExpr Id Id -> UniqueSupply -> (UniqueSupply, CoreExpr Id Id)
-typeOfCoreAlts :: CoreCaseAlternatives Id Id -> UniType
-typeOfCoreExpr :: CoreExpr Id Id -> UniType
-applyToArgs :: CoreExpr a b -> [CoreArg b] -> CoreExpr a b
-collectArgs :: CoreExpr a b -> (CoreExpr a b, [CoreArg b])
-decomposeArgs :: [CoreArg a] -> ([UniType], [CoreAtom a], [CoreArg a])
-mkCoTyApp :: CoreExpr a b -> UniType -> CoreExpr a b
-pprCoreExpr :: PprStyle -> (PprStyle -> a -> Int -> Bool -> PrettyRep) -> (PprStyle -> a -> Int -> Bool -> PrettyRep) -> (PprStyle -> b -> Int -> Bool -> PrettyRep) -> CoreExpr a b -> Int -> Bool -> PrettyRep
-calcUnfoldingGuidance :: Bool -> Int -> CoreExpr Id Id -> UnfoldingGuidance
-mentionedInUnfolding :: (a -> Id) -> CoreExpr a Id -> ([Id], [TyCon], [Class], Bool)
-pprCoreUnfolding :: CoreExpr Id Id -> Int -> Bool -> PrettyRep
-addTopBindsFVs :: (UniqFM Id -> Id -> Bool) -> [CoreBinding Id Id] -> ([CoreBinding (Id, UniqFM Id) Id], UniqFM Id)
-pprBigCoreBinder :: PprStyle -> Id -> Int -> Bool -> PrettyRep
-pprPlainCoreBinding :: PprStyle -> CoreBinding Id Id -> Int -> Bool -> PrettyRep
-pprTypedCoreBinder :: PprStyle -> Id -> Int -> Bool -> PrettyRep
-instance Eq Class
-instance Eq Id
-instance Eq Demand
-instance Eq UniType
-instance Eq Unique
-instance Ord Class
-instance Ord Id
-instance Ord Demand
-instance Ord Unique
-instance NamedThing Class
-instance NamedThing Id
-instance NamedThing FullName
-instance (Outputable a, Outputable b) => Outputable (a, b)
-instance (Outputable a, Outputable b, Outputable c) => Outputable (a, b, c)
-instance Outputable Bool
-instance Outputable Class
-instance Outputable a => Outputable (CoreArg a)
-instance Outputable a => Outputable (CoreAtom a)
-instance (Outputable a, Outputable b) => Outputable (CoreBinding a b)
-instance (Outputable a, Outputable b) => Outputable (CoreCaseAlternatives a b)
-instance (Outputable a, Outputable b) => Outputable (CoreCaseDefault a b)
-instance (Outputable a, Outputable b) => Outputable (CoreExpr a b)
-instance Outputable Id
-instance Outputable Demand
-instance Outputable FullName
-instance Outputable UniType
-instance Outputable a => Outputable [a]
-instance Text Demand
-instance Text Unique
-
diff --git a/ghc/compiler/coreSyn/PlainCore.lhs b/ghc/compiler/coreSyn/PlainCore.lhs
deleted file mode 100644
index 4aaf9480c2..0000000000
--- a/ghc/compiler/coreSyn/PlainCore.lhs
+++ /dev/null
@@ -1,185 +0,0 @@
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
-%
-\section[PlainCore]{``Plain'' core syntax: the usual parameterisation}
-
-This module defines a particular parameterisation of the @CoreSyntax@
-data type.  Both binders and bindees are just @Ids@.  This is the
-normal thing.
-
-\begin{code}
-#include "HsVersions.h"
-
-module PlainCore (
-	PlainCoreProgram(..), PlainCoreBinding(..), PlainCoreExpr(..),
-	PlainCoreAtom(..), PlainCoreCaseAlternatives(..),
-	PlainCoreCaseDefault(..), PlainCoreArg(..),
-#ifdef DPH
-	PlainCoreParQuals(..),
-	PlainCoreParCommunicate(..),
-	CoreParCommunicate(..),
-	CoreParQuals(..),
-	isParCoreCaseAlternative,
-	mkNonRecBinds, 
-#endif
-	pprPlainCoreBinding,
-	pprBigCoreBinder, pprTypedCoreBinder, -- not exported: pprBabyCoreBinder,
-
-	CoreBinding(..), CoreExpr(..), CoreAtom(..), -- re-exported
-	CoreCaseAlternatives(..), CoreCaseDefault(..),
-	pprCoreExpr,
-
-	CoreArg(..), applyToArgs, decomposeArgs, collectArgs,
-
-	-- and the related utility functions from CoreFuns...
-
-	typeOfCoreExpr,  typeOfCoreAlts,
-	instCoreExpr,   substCoreExpr,   -- UNUSED: cloneCoreExpr,
-	substCoreExprUS, -- UNUSED: instCoreExprUS, cloneCoreExprUS,
-	instCoreBindings,
-	mkCoLam, mkCoreIfThenElse,
---	mkCoApp, mkCoCon, mkCoPrim, -- no need for export
-	mkCoApps,
-	mkCoLetAny, mkCoLetNoUnboxed, mkCoLetUnboxedToCase,
-	mkCoLetsAny, mkCoLetsNoUnboxed, mkCoLetsUnboxedToCase,
-	mkCoLetrecAny, mkCoLetrecNoUnboxed,
-	mkCoTyLam, mkCoTyApp, mkCoTyApps,
-	mkErrorCoApp, escErrorMsg,
-	pairsFromCoreBinds,
-	mkFunction, atomToExpr,
-	digForLambdas,
-	exprSmallEnoughToDup,
-	manifestlyWHNF, manifestlyBottom, --UNUSED: manifestWHNFArgs,
-	coreExprArity,
-	isWrapperFor,
-	maybeErrorApp,
---UNUSED: boilsDownToConApp,
-	nonErrorRHSs, bindersOf,
-	squashableDictishCcExpr,
-
-	calcUnfoldingGuidance,
-	pprCoreUnfolding,
-	mentionedInUnfolding,
-
-	-- and one variant of free-var-finding stuff:
-	addTopBindsFVs, FVCoreExpr(..), FVCoreBinding(..),
-
-	-- and to make the interface self-sufficient ...
-	Outputable(..), NamedThing(..),
-	ExportFlag, SrcLoc, Unique,
-	Pretty(..), PprStyle, PrettyRep,
-
-	BasicLit, BinderInfo, Class, Id, Demand, IdInfo, FullName,
-	UnfoldingGuidance, UniType, TauType(..), ThetaType(..),
-	SigmaType(..), TyVar, TyCon, CostCentre, PrimOp, UniqueSupply,
-	UniqSM(..), IdEnv(..), UniqFM,
-	TyVarEnv(..), TypeEnv(..), IdSet(..), UniqSet(..),
-	Maybe, Bag
-	IF_ATTACK_PRAGMAS(COMMA cmpClass)
-	IF_ATTACK_PRAGMAS(COMMA cmpUniType)
-	IF_ATTACK_PRAGMAS(COMMA initUs) -- profiling
-
--- NOTE(hilly) Added UniqSM for cloneFunctions
-
-    ) where
-
---IMPORT_Trace	-- ToDo: rm (debugging)
-
-import CoreSyn		-- mostly re-exporting this stuff
-import CoreFuns
-import CoreUnfold
-
-import AbsUniType	( TauType(..), ThetaType(..), SigmaType(..),
-			  Class, UniType, FullName
-			  IF_ATTACK_PRAGMAS(COMMA cmpClass)
-			  IF_ATTACK_PRAGMAS(COMMA cmpUniType)
-			)
-import FreeVars
-import Id		( getIdUniType, getIdStrictness, getIdInfo,
-			  Id, TypeEnv(..)
-			)
-import IdEnv		-- ( nullIdEnv, IdEnv )
-import IdInfo
-import Maybes		( Maybe(..) )
-import Outputable
-import Pretty
-import Unique		( UniqSM(..), Unique
-			  IF_ATTACK_PRAGMAS(COMMA initUs)
-			)
-import Util
-
-infixr 9 `thenUf`, `thenUf_`
-\end{code}
-
-The ``Core things'' just described are parameterised with respect to
-the information kept about binding occurrences and bound occurrences
-of variables.
-
-The ``Plain Core things'' are instances of the ``Core things'' in
-which nothing but a name is kept, for both binders and variables.
-\begin{code}
-type PlainCoreProgram = [CoreBinding Id Id]
-type PlainCoreBinding = CoreBinding  Id Id
-type PlainCoreExpr    = CoreExpr     Id Id
-type PlainCoreAtom    = CoreAtom        Id
-#ifdef DPH
-type PlainCoreParQuals		= CoreParQuals Id Id
-type PlainCoreParCommunicate	= CoreParCommunicate Id Id
-#endif {- Data Parallel Haskell -}
-type PlainCoreCaseAlternatives	= CoreCaseAlternatives Id Id
-type PlainCoreCaseDefault	= CoreCaseDefault Id Id
-
-type PlainCoreArg = CoreArg Id
-\end{code}
-
-%************************************************************************
-%*									*
-\subsection[printing-PlainCore]{Printing @PlainCore@ things}
-%*									*
-%************************************************************************
-
-The most common core-printing interface:
-\begin{code}
-pprPlainCoreBinding :: PprStyle -> PlainCoreBinding -> Pretty
-
-pprPlainCoreBinding sty (CoNonRec binder expr)
-  = ppHang (ppCat [pprBigCoreBinder sty binder, ppEquals])
-    	 4 (pprCoreExpr sty pprBigCoreBinder pprBabyCoreBinder ppr expr)
-
-pprPlainCoreBinding sty (CoRec binds)
-  = ppAboves [ifPprDebug sty (ppStr "{- plain CoRec -}"),
-	      ppAboves (map ppr_bind binds),
-	      ifPprDebug sty (ppStr "{- end plain CoRec -}")]
-  where
-    ppr_bind (binder, expr)
-      = ppHang (ppCat [pprBigCoreBinder sty binder, ppEquals])
-	     4 (pprCoreExpr sty pprBigCoreBinder pprBabyCoreBinder ppr expr)
-\end{code}
-
-Other printing bits-and-bobs used with the general @pprCoreBinding@
-and @pprCoreExpr@ functions.
-\begin{code}
-pprBigCoreBinder sty binder
-  = ppAboves [sig, pragmas, ppr sty binder]
-  where
-    sig = ifnotPprShowAll sty (
-	    ppHang (ppCat [ppr sty binder, ppStr "::"])
-		 4 (ppr sty (getIdUniType binder)))
-
-    pragmas = ifnotPprForUser sty (
-	    ppIdInfo sty binder True{-specs, please-} id nullIdEnv (getIdInfo binder))
-
-pprBabyCoreBinder sty binder
-  = ppCat [ppr sty binder, pp_strictness]
-  where
-    pp_strictness
-      = case (getIdStrictness binder) of
-	  NoStrictnessInfo    -> ppNil
-	  BottomGuaranteed    -> ppStr "{- _!_ -}"
-	  StrictnessInfo xx _ -> ppStr ("{- " ++ (showList xx "") ++ " -}")
-
-pprTypedCoreBinder sty binder
-  = ppBesides [ppLparen, ppCat [ppr sty binder,
-	ppStr "::", ppr sty (getIdUniType binder)],
-	ppRparen]
-\end{code}
diff --git a/ghc/compiler/coreSyn/PprCore.lhs b/ghc/compiler/coreSyn/PprCore.lhs
new file mode 100644
index 0000000000..b3569e8866
--- /dev/null
+++ b/ghc/compiler/coreSyn/PprCore.lhs
@@ -0,0 +1,457 @@
+%
+% (c) The AQUA Project, Glasgow University, 1996
+%
+%************************************************************************
+%*									*
+\section[PprCore]{Printing of Core syntax, including for interfaces}
+%*									*
+%************************************************************************
+
+\begin{code}
+#include "HsVersions.h"
+
+module PprCore (
+	pprCoreExpr,
+	pprCoreBinding,
+	pprBigCoreBinder,
+	pprTypedCoreBinder,
+	pprPlainCoreBinding
+	
+	-- these are here to make the instances go in 0.26:
+#if __GLASGOW_HASKELL__ <= 26
+	, GenCoreBinding, GenCoreExpr, GenCoreCaseAlts
+	, GenCoreCaseDefault, GenCoreArg
+#endif
+    ) where
+
+import Ubiq{-uitous-}
+
+import CoreSyn
+import CostCentre	( showCostCentre )
+import Id		( idType, getIdInfo, getIdStrictness,
+			  nullIdEnv, DataCon(..), GenId{-instances-}
+			)
+import IdInfo		( ppIdInfo, StrictnessInfo(..) )
+import Literal		( Literal{-instances-} )
+import Outputable	-- quite a few things
+import PprType		( pprType_Internal,
+			  GenType{-instances-}, GenTyVar{-instance-}
+			)
+import PprStyle		( PprStyle(..) )
+import Pretty
+import PrimOp		( PrimOp{-instances-} )
+import TyVar		( GenTyVar{-instances-} )
+import Unique		( Unique{-instances-} )
+import Usage		( GenUsage{-instances-} )
+import Util		( panic{-ToDo:rm-} )
+\end{code}
+
+%************************************************************************
+%*									*
+\subsection{Public interfaces for Core printing (excluding instances)}
+%*									*
+%************************************************************************
+
+@pprCoreBinding@ and @pprCoreExpr@ let you give special printing
+function for ``major'' val_bdrs (those next to equal signs :-),
+``minor'' ones (lambda-bound, case-bound), and bindees.  They would
+usually be called through some intermediary.
+
+The binder/occ printers take the default ``homogenized'' (see
+@PrintEnv@...) @Pretty@ and the binder/occ.  They can either use the
+homogenized one, or they can ignore it completely.  In other words,
+the things passed in act as ``hooks'', getting the last word on how to
+print something.
+
+@pprParendCoreExpr@ puts parens around non-atomic Core expressions.
+
+\begin{code}
+pprPlainCoreBinding :: PprStyle -> CoreBinding -> Pretty
+
+pprCoreBinding
+	:: (Eq tyvar, Outputable tyvar,
+	    Eq uvar,  Outputable uvar,
+	    Outputable bndr,
+	    Outputable occ)
+	=> PprStyle
+	-> (bndr -> Pretty)	-- to print "major" val_bdrs
+	-> (bndr -> Pretty)	-- to print "minor" val_bdrs
+	-> (occ  -> Pretty)	-- to print bindees
+	-> GenCoreBinding bndr occ tyvar uvar
+	-> Pretty
+
+pprCoreBinding sty pbdr1 pbdr2 pocc bind
+  = ppr_bind (initial_pe sty (Left (pbdr1, pbdr2, pocc))) bind
+
+pprPlainCoreBinding sty (NonRec binder expr)
+  = ppHang (ppCat [pprBigCoreBinder sty binder, ppEquals])
+    	 4 (pprCoreExpr sty (pprBigCoreBinder sty) (pprBabyCoreBinder sty) (ppr sty) expr)
+
+pprPlainCoreBinding sty (Rec binds)
+  = ppAboves [ifPprDebug sty (ppStr "{- plain Rec -}"),
+	      ppAboves (map ppr_bind binds),
+	      ifPprDebug sty (ppStr "{- end plain Rec -}")]
+  where
+    ppr_bind (binder, expr)
+      = ppHang (ppCat [pprBigCoreBinder sty binder, ppEquals])
+	     4 (pprCoreExpr sty (pprBigCoreBinder sty) (pprBabyCoreBinder sty) (ppr sty) expr)
+\end{code}
+
+\begin{code}
+pprCoreExpr, pprParendCoreExpr
+	:: (Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar,
+	    Outputable bndr,
+	    Outputable occ)
+	=> PprStyle
+	-> (bndr -> Pretty) -- to print "major" val_bdrs
+	-> (bndr -> Pretty) -- to print "minor" val_bdrs
+	-> (occ  -> Pretty) -- to print bindees
+	-> GenCoreExpr bndr occ tyvar uvar
+	-> Pretty
+
+pprCoreExpr sty pbdr1 pbdr2 pocc expr
+  = ppr_expr (initial_pe sty (Left (pbdr1, pbdr2, pocc))) expr
+
+pprParendCoreExpr sty pbdr1 pbdr2 pocc expr
+  = let
+	parenify
+	  = case expr of
+	      Var _ -> id	-- leave unchanged
+	      Lit _ -> id
+	      _	    -> ppParens	-- wraps in parens
+    in
+    parenify (pprCoreExpr sty pbdr1 pbdr2 pocc expr)
+
+ppr_core_arg sty pocc arg
+  = ppr_arg (initial_pe sty (Left (pocc, pocc, pocc))) arg
+
+ppr_core_alts sty pbdr1 pbdr2 pocc alts
+  = ppr_alts (initial_pe sty (Left (pbdr1, pbdr2, pocc))) alts
+
+ppr_core_default sty pbdr1 pbdr2 pocc deflt
+  = ppr_default (initial_pe sty (Left (pbdr1, pbdr2, pocc))) deflt
+\end{code}
+
+%************************************************************************
+%*									*
+\subsection{Instance declarations for Core printing}
+%*									*
+%************************************************************************
+
+\begin{code}
+instance
+  (Outputable bndr, Outputable occ, Eq tyvar, Outputable tyvar,
+   Eq uvar, Outputable uvar)
+ =>
+  Outputable (GenCoreBinding bndr occ tyvar uvar) where
+    ppr sty bind = pprCoreBinding sty (ppr sty) (ppr sty) (ppr sty) bind
+
+instance
+  (Outputable bndr, Outputable occ, Eq tyvar, Outputable tyvar,
+   Eq uvar, Outputable uvar)
+ =>
+  Outputable (GenCoreExpr bndr occ tyvar uvar) where
+    ppr sty expr = pprCoreExpr sty (ppr sty) (ppr sty) (ppr sty) expr
+
+instance
+  (Outputable occ, Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar)
+ =>
+  Outputable (GenCoreArg occ tyvar uvar) where
+    ppr sty arg = ppr_core_arg sty (ppr sty) arg
+
+instance
+  (Outputable bndr, Outputable occ, Eq tyvar, Outputable tyvar,
+   Eq uvar, Outputable uvar)
+ =>
+  Outputable (GenCoreCaseAlts bndr occ tyvar uvar) where
+    ppr sty alts = ppr_core_alts sty (ppr sty) (ppr sty) (ppr sty) alts
+
+instance
+  (Outputable bndr, Outputable occ, Eq tyvar, Outputable tyvar,
+   Eq uvar, Outputable uvar)
+ =>
+  Outputable (GenCoreCaseDefault bndr occ tyvar uvar) where
+    ppr sty deflt  = ppr_core_default sty (ppr sty) (ppr sty) (ppr sty) deflt
+\end{code}
+
+%************************************************************************
+%*									*
+\subsection{Core printing environment (purely local)}
+%*									*
+%************************************************************************
+
+Similar to @VE@ in @PprType@.  The ``values'' we print here
+are locally-defined nested-scope names; callers to @pprCoreBinding@,
+etc., can override these.
+
+For tyvars and uvars, we {\em do} normally use these homogenized
+names; for values, we {\em don't}.  In printing interfaces, though,
+we use homogenized value names, so that interfaces don't wobble
+uncontrollably from changing Unique-based names.
+
+\begin{code}
+data PrintEnv tyvar uvar bndr occ
+  = PE	(Literal -> Pretty)	-- Doing these this way saves
+	(DataCon -> Pretty)	-- carrying around a PprStyle
+	(PrimOp  -> Pretty)
+	(CostCentre -> Pretty)
+
+	[Pretty]		-- Tyvar pretty names
+	(tyvar -> Pretty)	-- Tyvar lookup function
+        [Pretty]		-- Uvar  pretty names
+	(uvar -> Pretty)	-- Uvar  lookup function
+
+	(GenType tyvar uvar -> Pretty)
+	(GenUsage uvar -> Pretty)
+
+	(ValPrinters bndr occ)
+
+data ValPrinters bndr occ
+  = BOPE -- print binders/occs differently
+	 (bndr -> Pretty)	-- to print "major" val_bdrs
+	 (bndr -> Pretty)	-- to print "minor" val_bdrs
+	 (occ  -> Pretty)	-- to print bindees
+
+  | VPE  -- print all values the same way
+	 [Pretty]		-- Value pretty names
+	 (bndr -> Pretty)	-- Binder lookup function
+	 (occ  -> Pretty)	-- Occurrence lookup function
+\end{code}
+
+\begin{code}
+initial_pe :: (Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar,
+	       Outputable bndr, Outputable occ)
+	   => PprStyle
+	   -> Either
+		(bndr -> Pretty, bndr -> Pretty, occ -> Pretty)
+		()
+	   -> PrintEnv tyvar uvar bndr occ
+
+initial_pe sty val_printing
+  = PE	(ppr sty)   -- for a Literal
+	(ppr sty)   -- for a DataCon
+	(ppr sty)   -- for a PrimOp
+	(\ cc -> ppStr (showCostCentre sty True cc)) -- CostCentre
+
+	tv_pretties ppr_tv -- for a TyVar
+        uv_pretties ppr_uv -- for a UsageVar
+
+	(\ ty -> pprType_Internal sty tv_pretties ppr_tv uv_pretties ppr_uv ty)
+	(ppr sty) -- for a Usage
+
+	val_printing_stuff
+  where
+    ppr_tv = ppr sty -- to print a tyvar
+    ppr_uv = ppr sty -- to print a uvar
+
+    tv_pretties = map (\ c -> ppChar c ) ['a' .. 'h']
+		  ++
+		  map (\ n -> ppBeside (ppChar 'a') (ppInt n))
+		      ([0 .. ] :: [Int])	-- a0 ... aN
+    
+    uv_pretties = map (\ c -> ppChar c ) ['u' .. 'y']
+		  ++
+		  map (\ n -> ppBeside (ppChar 'u') (ppInt n))
+		      ([0 .. ] :: [Int])	-- u0 ... uN
+    
+    val_pretties = map (\ c -> ppChar c ) ['i' .. 'k']
+		++ map (\ n -> ppBeside (ppChar 'v') (ppInt n))
+		       ([0 .. ] :: [Int])	-- v0 ... vN
+
+    ------------------------
+    val_printing_stuff
+      = case val_printing of
+	  Left  (pbdr1, pbdr2, pocc) -> BOPE pbdr1 pbdr2 pocc
+	  Right () -> VPE val_pretties (ppr sty) (ppr sty)
+
+\end{code}
+
+\begin{code}
+plit	 (PE pp  _  _  _ _  _ _  _  _  _ _) = pp
+pcon	 (PE  _ pp  _  _ _  _ _  _  _  _ _) = pp
+pprim	 (PE  _  _ pp  _ _  _ _  _  _  _ _) = pp
+pscc	 (PE  _  _  _ pp _  _ _  _  _  _ _) = pp
+ptyvar	 (PE  _  _  _  _ _ pp _  _  _  _ _) = pp
+puvar	 (PE  _  _  _  _ _  _ _ pp  _  _ _) = pp
+  
+pty	 (PE  _  _  _  _ _  _ _  _ pp  _ _) = pp
+puse	 (PE  _  _  _  _ _  _ _  _  _ pp _) = pp
+
+pmaj_bdr (PE  _  _  _  _ _  _ _  _  _  _ (BOPE pp _ _)) = pp
+pmaj_bdr (PE  _  _  _  _ _  _ _  _  _  _ (VPE  _ pp _)) = pp
+				   
+pmin_bdr (PE  _  _  _  _ _  _ _  _  _  _ (BOPE _ pp _)) = pp
+pmin_bdr (PE  _  _  _  _ _  _ _  _  _  _ (VPE  _ pp _)) = pp
+				   
+pocc	 (PE  _  _  _  _ _  _ _  _  _  _ (BOPE _ _ pp)) = pp
+pocc	 (PE  _  _  _  _ _  _ _  _  _  _ (VPE  _ _ pp)) = pp
+\end{code}
+
+%************************************************************************
+%*									*
+\subsection{Workhorse routines (...????...)}
+%*									*
+%************************************************************************
+
+\begin{code}
+ppr_bind pe (NonRec val_bdr expr)
+  = ppHang (ppCat [pmaj_bdr pe val_bdr, ppEquals])
+	 4 (ppr_expr pe expr)
+
+ppr_bind pe (Rec binds)
+  = ppAboves [ ppStr "{- Rec -}",
+	       ppAboves (map ppr_pair binds),
+	       ppStr "{- end Rec -}" ]
+  where
+    ppr_pair (val_bdr, expr)
+      = ppHang (ppCat [pmaj_bdr pe val_bdr, ppEquals])
+	     4 (ppr_expr pe expr)
+\end{code}
+
+\begin{code}
+ppr_parend_expr pe expr
+  = let
+	parenify
+	  = case expr of
+	      Var _ -> id	-- leave unchanged
+	      Lit _ -> id
+	      _	    -> ppParens	-- wraps in parens
+    in
+    parenify (ppr_expr pe expr)
+\end{code}
+
+\begin{code}
+ppr_expr pe (Var name)   = pocc pe name
+ppr_expr pe (Lit lit)    = plit pe lit
+ppr_expr pe (Con con []) = pcon pe con
+
+ppr_expr pe (Con con args)
+  = ppHang (ppBesides [pcon pe con, ppChar '!'])
+	 4 (ppSep (map (ppr_arg pe) args))
+
+ppr_expr pe (Prim prim args)
+  = ppHang (ppBesides [pprim pe prim, ppChar '!'])
+	 4 (ppSep (map (ppr_arg pe) args))
+
+ppr_expr pe expr@(Lam _ _)
+  = let
+	(uvars, tyvars, vars, body) = digForLambdas expr
+    in
+    ppHang (ppCat [pp_vars SLIT("_/u\\_") (puvar    pe) uvars,
+		   pp_vars SLIT("_/\\_")  (ptyvar   pe) tyvars,
+		   pp_vars SLIT("\\")     (pmin_bdr pe) vars])
+	 4 (ppr_expr pe body)
+  where
+    pp_vars lam pp [] = ppNil
+    pp_vars lam pp vs
+      = ppCat [ppPStr lam, ppInterleave ppSP (map pp vs), ppStr "->"]
+
+ppr_expr pe expr@(App _ _)
+  = let
+	(fun, args) = collectArgs expr
+    in
+    ppHang (ppr_parend_expr pe fun)
+	 4 (ppSep (map (ppr_arg pe) args))
+
+ppr_expr pe (Case expr alts)
+  = ppSep
+    [ppSep [ppPStr SLIT("case"), ppNest 4 (ppr_parend_expr pe expr), ppStr "of {"],
+     ppNest 2 (ppr_alts pe alts),
+     ppStr "}"]
+
+-- special cases: let ... in let ...
+-- ("disgusting" SLPJ)
+
+ppr_expr pe (Let bind@(NonRec val_bdr rhs@(Let _ _)) body)
+  = ppAboves [
+      ppCat [ppStr "let {", pmaj_bdr pe val_bdr, ppEquals],
+      ppNest 2 (ppr_expr pe rhs),
+      ppStr "} in",
+      ppr_expr pe body ]
+
+ppr_expr pe (Let bind@(NonRec val_bdr rhs) expr@(Let _ _))
+  = ppAbove
+      (ppHang (ppStr "let {")
+	    2 (ppCat [ppHang (ppCat [pmaj_bdr pe val_bdr, ppEquals])
+			   4 (ppr_expr pe rhs),
+       ppStr "} in"]))
+      (ppr_expr pe expr)
+
+-- general case (recursive case, too)
+ppr_expr pe (Let bind expr)
+  = ppSep [ppHang (ppStr "let {") 2 (ppr_bind pe bind),
+	   ppHang (ppStr "} in ") 2 (ppr_expr pe expr)]
+
+ppr_expr pe (SCC cc expr)
+  = ppSep [ppCat [ppPStr SLIT("_scc_"), pscc pe cc],
+	   ppr_parend_expr pe expr ]
+\end{code}
+
+\begin{code}
+ppr_alts pe (AlgAlts alts deflt)
+  = ppAboves [ ppAboves (map ppr_alt alts), ppr_default pe deflt ]
+  where
+    ppr_alt (con, params, expr)
+      = ppHang (ppCat [ppr_con con (pcon pe con),
+		       ppInterleave ppSP (map (pmin_bdr pe) params),
+		       ppStr "->"])
+	     4 (ppr_expr pe expr)
+      where
+    	ppr_con con pp_con
+    	  = if isOpLexeme con then ppParens pp_con else pp_con
+
+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)
+\end{code}
+
+\begin{code}
+ppr_default pe NoDefault = ppNil
+
+ppr_default pe (BindDefault val_bdr expr)
+  = ppHang (ppCat [pmin_bdr pe val_bdr, ppStr "->"])
+	 4 (ppr_expr pe expr)
+\end{code}
+
+\begin{code}
+ppr_arg pe (LitArg   lit) = plit pe lit
+ppr_arg pe (VarArg   v)	  = pocc pe v
+ppr_arg pe (TyArg    ty)  = pty  pe ty
+ppr_arg pe (UsageArg use) = puse pe use
+\end{code}
+
+Other printing bits-and-bobs used with the general @pprCoreBinding@
+and @pprCoreExpr@ functions.
+
+\begin{code}
+pprBigCoreBinder sty binder
+  = ppAboves [sig, pragmas, ppr sty binder]
+  where
+    sig = ifnotPprShowAll sty (
+	    ppHang (ppCat [ppr sty binder, ppStr "::"])
+		 4 (ppr sty (idType binder)))
+
+    pragmas =
+	ifnotPprForUser sty
+	 (ppIdInfo sty binder True{-specs, please-} id nullIdEnv
+	  (getIdInfo binder))
+
+pprBabyCoreBinder sty binder
+  = ppCat [ppr sty binder, pp_strictness]
+  where
+    pp_strictness
+      = case (getIdStrictness binder) of
+	  NoStrictnessInfo    -> ppNil
+	  BottomGuaranteed    -> ppStr "{- _!_ -}"
+	  StrictnessInfo xx _ ->
+		panic "PprCore:pp_strictness:StrictnessInfo:ToDo"
+		-- ppStr ("{- " ++ (showList xx "") ++ " -}")
+
+pprTypedCoreBinder sty binder
+  = ppBesides [ppLparen, ppCat [ppr sty binder,
+	ppStr "::", ppr sty (idType binder)],
+	ppRparen]
+\end{code}
diff --git a/ghc/compiler/coreSyn/TaggedCore.hi b/ghc/compiler/coreSyn/TaggedCore.hi
deleted file mode 100644
index 966745cd84..0000000000
--- a/ghc/compiler/coreSyn/TaggedCore.hi
+++ /dev/null
@@ -1,81 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface TaggedCore where
-import BasicLit(BasicLit)
-import BinderInfo(BinderInfo)
-import CmdLineOpts(GlobalSwitch)
-import CoreFuns(unTagBinders, unTagBindersAlts)
-import CoreSyn(CoreArg(..), CoreAtom(..), CoreBinding(..), CoreCaseAlternatives(..), CoreCaseDefault(..), CoreExpr(..), applyToArgs, collectArgs, decomposeArgs)
-import CostCentre(CostCentre)
-import Id(Id)
-import Outputable(ExportFlag, NamedThing(..), Outputable(..))
-import PreludePS(_PackedString)
-import Pretty(PprStyle, Pretty(..), PrettyRep)
-import PrimOps(PrimOp)
-import SrcLoc(SrcLoc)
-import TyCon(TyCon)
-import TyVar(TyVar)
-import UniType(UniType)
-import Unique(Unique)
-class NamedThing a where
-	getExportFlag :: a -> ExportFlag
-	isLocallyDefined :: a -> Bool
-	getOrigName :: a -> (_PackedString, _PackedString)
-	getOccurrenceName :: a -> _PackedString
-	getInformingModules :: a -> [_PackedString]
-	getSrcLoc :: a -> SrcLoc
-	getTheUnique :: a -> Unique
-	hasType :: a -> Bool
-	getType :: a -> UniType
-	fromPreludeCore :: a -> Bool
-class Outputable a where
-	ppr :: PprStyle -> a -> Int -> Bool -> PrettyRep
-data BasicLit 
-data BinderInfo 
-data GlobalSwitch 
-data CoreArg a   = TypeArg UniType | ValArg (CoreAtom a)
-data CoreAtom a   = CoVarAtom a | CoLitAtom BasicLit
-data CoreBinding a b   = CoNonRec a (CoreExpr a b) | CoRec [(a, CoreExpr a b)]
-data CoreCaseAlternatives a b   = CoAlgAlts [(Id, [a], CoreExpr a b)] (CoreCaseDefault a b) | CoPrimAlts [(BasicLit, CoreExpr a b)] (CoreCaseDefault a b)
-data CoreCaseDefault a b   = CoNoDefault | CoBindDefault a (CoreExpr a b)
-data CoreExpr a b   = CoVar b | CoLit BasicLit | CoCon Id [UniType] [CoreAtom b] | CoPrim PrimOp [UniType] [CoreAtom b] | CoLam [a] (CoreExpr a b) | CoTyLam TyVar (CoreExpr a b) | CoApp (CoreExpr a b) (CoreAtom b) | CoTyApp (CoreExpr a b) UniType | CoCase (CoreExpr a b) (CoreCaseAlternatives a b) | CoLet (CoreBinding a b) (CoreExpr a b) | CoSCC CostCentre (CoreExpr a b)
-data CostCentre 
-data Id 
-data ExportFlag 
-data PprStyle 
-type Pretty = Int -> Bool -> PrettyRep
-data PrettyRep 
-data PrimOp 
-type SimplifiableBinder = (Id, BinderInfo)
-type SimplifiableCoreAtom = CoreAtom Id
-type SimplifiableCoreBinding = CoreBinding (Id, BinderInfo) Id
-type SimplifiableCoreCaseAlternatives = CoreCaseAlternatives (Id, BinderInfo) Id
-type SimplifiableCoreCaseDefault = CoreCaseDefault (Id, BinderInfo) Id
-type SimplifiableCoreExpr = CoreExpr (Id, BinderInfo) Id
-data SrcLoc 
-type TaggedBinder a = (Id, a)
-type TaggedCoreAtom a = CoreAtom Id
-type TaggedCoreBinding a = CoreBinding (Id, a) Id
-type TaggedCoreCaseAlternatives a = CoreCaseAlternatives (Id, a) Id
-type TaggedCoreCaseDefault a = CoreCaseDefault (Id, a) Id
-type TaggedCoreExpr a = CoreExpr (Id, a) Id
-data TyCon 
-data TyVar 
-data UniType 
-data Unique 
-unTagBinders :: CoreExpr (Id, a) b -> CoreExpr Id b
-unTagBindersAlts :: CoreCaseAlternatives (Id, a) b -> CoreCaseAlternatives Id b
-applyToArgs :: CoreExpr a b -> [CoreArg b] -> CoreExpr a b
-collectArgs :: CoreExpr a b -> (CoreExpr a b, [CoreArg b])
-decomposeArgs :: [CoreArg a] -> ([UniType], [CoreAtom a], [CoreArg a])
-instance (Outputable a, Outputable b) => Outputable (a, b)
-instance (Outputable a, Outputable b, Outputable c) => Outputable (a, b, c)
-instance Outputable BinderInfo
-instance Outputable Bool
-instance Outputable a => Outputable (CoreArg a)
-instance Outputable a => Outputable (CoreAtom a)
-instance (Outputable a, Outputable b) => Outputable (CoreBinding a b)
-instance (Outputable a, Outputable b) => Outputable (CoreCaseAlternatives a b)
-instance (Outputable a, Outputable b) => Outputable (CoreCaseDefault a b)
-instance (Outputable a, Outputable b) => Outputable (CoreExpr a b)
-instance Outputable a => Outputable [a]
-
diff --git a/ghc/compiler/coreSyn/TaggedCore.lhs b/ghc/compiler/coreSyn/TaggedCore.lhs
deleted file mode 100644
index 9af8bb15b7..0000000000
--- a/ghc/compiler/coreSyn/TaggedCore.lhs
+++ /dev/null
@@ -1,93 +0,0 @@
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
-%
-\section[TaggedCore]{``Tagged binder'' core syntax (including \tr{Simplifiable*})}
-
-This module defines a particular parameterisation of the @CoreSyntax@
-data type.  For ``binders,'' we use a pair: an @Id@ (the actual
-binder) and a ``tag''---any old thing we want to pin on.
-Bindees are @Ids@, as usual.
-
-By far the prevalent use is with a ``tag'' of a @BinderInfo@, as used
-in the simplifier.  So we have a full swatch of synonyms for
-\tr{Simplifiable} this and that.
-
-\begin{code}
-#include "HsVersions.h"
-
-module TaggedCore (
-	TaggedBinder(..), TaggedCoreBinding(..), TaggedCoreExpr(..),
-	TaggedCoreAtom(..), TaggedCoreCaseAlternatives(..),
-	TaggedCoreCaseDefault(..),
-#ifdef DPH
-	TaggedCoreParQuals(..),
-	TaggedCoreParCommunicate(..),
-	CoreParCommunicate(..),
-	CoreParQuals(..),
-#endif
-	unTagBinders, unTagBindersAlts,
-
-	CoreArg(..), applyToArgs, decomposeArgs, collectArgs,
-
-	SimplifiableBinder(..), SimplifiableCoreBinding(..),
-	SimplifiableCoreExpr(..), SimplifiableCoreAtom(..),
-	SimplifiableCoreCaseAlternatives(..),
-	SimplifiableCoreCaseDefault(..),
-#ifdef DPH
-	SimplifiableCoreParQuals(..),
-	SimplifiableCoreParCommunicate(..),
-#endif
-
-	CoreBinding(..), CoreExpr(..),	CoreAtom(..), -- re-exported
-	CoreCaseAlternatives(..), CoreCaseDefault(..),
-
-	-- and to make the interface self-sufficient ...
-	Outputable(..), NamedThing(..),
-	ExportFlag, Pretty(..), PprStyle, PrettyRep,
-
-	BasicLit, BinderInfo, GlobalSwitch, Id, PrimOp, CostCentre,
-	SrcLoc, TyCon, TyVar, UniType, Unique
-    ) where
-
-import CoreFuns		( unTagBinders, unTagBindersAlts, digForLambdas )
-import CoreSyn		-- mostly re-exporting this stuff
-import BinderInfo	( BinderInfo )
-import Outputable
-import Util
-\end{code}
-
-\begin{code}
-type TaggedBinder tag = (Id, tag)
-
-type TaggedCoreProgram tag = [CoreBinding (TaggedBinder tag) Id]
-type TaggedCoreBinding tag =  CoreBinding (TaggedBinder tag) Id
-type TaggedCoreExpr    tag =  CoreExpr    (TaggedBinder tag) Id
-type TaggedCoreAtom    tag =  CoreAtom			     Id
-
-#ifdef DPH
-type TaggedCoreParQuals tag = CoreParQuals (TaggedBinder tag) Id
-type TaggedCoreParCommunicate tag
-  = CoreParCommunicate (TaggedBinder tag) Id
-#endif {- Data Parallel Haskell -}
-
-type TaggedCoreCaseAlternatives tag = CoreCaseAlternatives (TaggedBinder tag) Id
-type TaggedCoreCaseDefault tag = CoreCaseDefault (TaggedBinder tag) Id
-\end{code}
-
-\begin{code}
-type SimplifiableBinder = (Id, BinderInfo)
-
-type SimplifiableCoreProgram = [CoreBinding SimplifiableBinder Id]
-type SimplifiableCoreBinding =  CoreBinding SimplifiableBinder Id
-type SimplifiableCoreExpr    =  CoreExpr    SimplifiableBinder Id
-type SimplifiableCoreAtom    =  CoreAtom		       Id
-
-#ifdef DPH
-type SimplifiableCoreParQuals = CoreParQuals SimplifiableBinder Id
-type SimplifiableCoreParCommunicate
-  = CoreParCommunicate SimplifiableBinder Id
-#endif {- Data Parallel Haskell -}
-
-type SimplifiableCoreCaseAlternatives = CoreCaseAlternatives SimplifiableBinder Id
-type SimplifiableCoreCaseDefault      = CoreCaseDefault SimplifiableBinder Id
-\end{code}
diff --git a/ghc/compiler/deSugar/Desugar.hi b/ghc/compiler/deSugar/Desugar.hi
deleted file mode 100644
index 564e214a46..0000000000
--- a/ghc/compiler/deSugar/Desugar.hi
+++ /dev/null
@@ -1,32 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface Desugar where
-import Bag(Bag)
-import CmdLineOpts(GlobalSwitch, SwitchResult)
-import CoreSyn(CoreBinding, CoreExpr)
-import DsMonad(DsMatchContext, DsMatchKind)
-import HsBinds(Bind, Binds, Sig)
-import HsExpr(ArithSeqInfo, Expr, Qual)
-import HsLit(Literal)
-import HsMatches(Match)
-import HsPat(TypecheckedPat)
-import HsTypes(PolyType)
-import Id(Id)
-import Inst(Inst)
-import PreludePS(_PackedString)
-import SplitUniq(SplitUniqSupply)
-import SrcLoc(SrcLoc)
-import TyVar(TyVar)
-import UniType(UniType)
-data Bag a 
-data GlobalSwitch 
-data SwitchResult 
-data CoreBinding a b 
-data DsMatchContext 
-data DsMatchKind 
-data Binds a b 
-data Expr a b 
-data TypecheckedPat 
-data Id 
-data SplitUniqSupply 
-deSugar :: SplitUniqSupply -> (GlobalSwitch -> SwitchResult) -> _PackedString -> (Binds Id TypecheckedPat, Binds Id TypecheckedPat, Binds Id TypecheckedPat, [(Inst, Expr Id TypecheckedPat)]) -> ([CoreBinding Id Id], Bag DsMatchContext)
-
diff --git a/ghc/compiler/deSugar/Desugar.lhs b/ghc/compiler/deSugar/Desugar.lhs
index da0b92a46e..4db1bdfc9d 100644
--- a/ghc/compiler/deSugar/Desugar.lhs
+++ b/ghc/compiler/deSugar/Desugar.lhs
@@ -1,56 +1,49 @@
 %
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
 %
 \section[Desugar]{@deSugar@: the main function}
 
 \begin{code}
 #include "HsVersions.h"
 
-module Desugar (
-	deSugar,
+module Desugar ( deSugar, DsMatchContext, pprDsWarnings ) where
 
-	-- and to make the interface self-sufficient...
-	SplitUniqSupply, Binds, Expr, Id, TypecheckedPat,
-	CoreBinding, GlobalSwitch, SwitchResult,
-	Bag, DsMatchContext, DsMatchKind
-    ) where
+import Ubiq{-uitous-}
 
+import HsSyn		( HsBinds, HsExpr )
+import TcHsSyn		( TypecheckedHsBinds(..), TypecheckedHsExpr(..) )
+import CoreSyn
 
-import AbsSyn		-- the stuff being desugared
-import PlainCore	-- the output of desugaring;
-			-- importing this module also gets all the
-			-- CoreSyn utility functions
-import DsMonad		-- the monadery used in the desugarer
+import DsMonad
+import DsBinds		( dsBinds, dsInstBinds )
+import DsUtils
 
-import Bag		( unionBags, Bag )
-import CmdLineOpts	( switchIsOn, GlobalSwitch(..), SwitchResult )
+import Bag		( unionBags )
+import CmdLineOpts	( opt_DoCoreLinting )
 import CoreLift		( liftCoreBindings )
 import CoreLint		( lintCoreBindings )
-import DsBinds		( dsBinds, dsInstBinds )
-import IdEnv
-import Pretty		( PprStyle(..) )
-import SplitUniq
-import Util
+import Id		( nullIdEnv, mkIdEnv )
+import PprStyle		( PprStyle(..) )
+import UniqSupply	( splitUniqSupply )
 \end{code}
 
-The only trick here is to get the @DesugarMonad@ stuff off to a good
+The only trick here is to get the @DsMonad@ stuff off to a good
 start.
 
 \begin{code}
-deSugar :: SplitUniqSupply		-- name supply
-	-> (GlobalSwitch->SwitchResult)	-- switch looker upper
+deSugar :: UniqSupply		-- name supply
 	-> FAST_STRING			-- module name
 
-	-> (TypecheckedBinds,   -- input: class, instance, and value
-	    TypecheckedBinds,	--   bindings; see "tcModule" (which produces
-	    TypecheckedBinds,	--   them)
-	    [(Inst, TypecheckedExpr)])
+	-> (TypecheckedHsBinds,   -- input: class, instance, and value
+	    TypecheckedHsBinds,	--   bindings; see "tcModule" (which produces
+	    TypecheckedHsBinds,	--   them)
+	    [(Id, TypecheckedHsExpr)])
 -- ToDo: handling of const_inst thingies is certainly WRONG ***************************
 
-	-> ([PlainCoreBinding],	-- output
+	-> ([CoreBinding],	-- output
 	    Bag DsMatchContext)	-- Shadowing complaints
 
-deSugar us sw_chkr mod_name (clas_binds, inst_binds, val_binds, const_inst_pairs)
+deSugar us mod_name (clas_binds, inst_binds, val_binds, const_inst_pairs)
   = let
 	(us0, us0a) = splitUniqSupply us
 	(us1, us1a) = splitUniqSupply us0a
@@ -58,20 +51,20 @@ deSugar us sw_chkr mod_name (clas_binds, inst_binds, val_binds, const_inst_pairs
 	(us3, us4)  = splitUniqSupply us2a
 
 	((core_const_prs, consts_pairs), shadows1)
-	    = initDs us0 nullIdEnv sw_chkr mod_name (dsInstBinds [] const_inst_pairs)
+	    = initDs us0 nullIdEnv mod_name (dsInstBinds [] const_inst_pairs)
 
 	consts_env = mkIdEnv consts_pairs
 
 	(core_clas_binds, shadows2)
-			= initDs us1 consts_env sw_chkr mod_name (dsBinds clas_binds)
+			= initDs us1 consts_env mod_name (dsBinds clas_binds)
 	core_clas_prs	= pairsFromCoreBinds core_clas_binds
-			
+
 	(core_inst_binds, shadows3)
-			= initDs us2 consts_env sw_chkr mod_name (dsBinds inst_binds)
+			= initDs us2 consts_env mod_name (dsBinds inst_binds)
 	core_inst_prs	= pairsFromCoreBinds core_inst_binds
-			
+
 	(core_val_binds, shadows4)
-			= initDs us3 consts_env sw_chkr mod_name (dsBinds val_binds)
+			= initDs us3 consts_env mod_name (dsBinds val_binds)
 	core_val_pairs	= pairsFromCoreBinds core_val_binds
 
     	final_binds
@@ -80,13 +73,11 @@ deSugar us sw_chkr mod_name (clas_binds, inst_binds, val_binds, const_inst_pairs
 		core_clas_binds ++ core_val_binds
 
 	    else -- gotta make it recursive (sigh)
-	       [CoRec (core_clas_prs ++ core_inst_prs ++ core_const_prs ++ core_val_pairs)]
+	       [Rec (core_clas_prs ++ core_inst_prs ++ core_const_prs ++ core_val_pairs)]
 
-	lift_final_binds = {-if switchIsOn sw_chkr GlasgowExts
-			   then-} liftCoreBindings us4 final_binds
-			   -- else final_binds
+	lift_final_binds = liftCoreBindings us4 final_binds
 
-	really_final_binds = if switchIsOn sw_chkr DoCoreLinting
+	really_final_binds = if opt_DoCoreLinting
 			     then lintCoreBindings PprDebug "Desugarer" False lift_final_binds
 			     else lift_final_binds
 
diff --git a/ghc/compiler/deSugar/DsBinds.hi b/ghc/compiler/deSugar/DsBinds.hi
deleted file mode 100644
index dfa1e5d126..0000000000
--- a/ghc/compiler/deSugar/DsBinds.hi
+++ /dev/null
@@ -1,19 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface DsBinds where
-import Bag(Bag)
-import CmdLineOpts(GlobalSwitch, SwitchResult)
-import CoreSyn(CoreBinding, CoreExpr)
-import DsMonad(DsMatchContext)
-import HsBinds(Binds)
-import HsExpr(Expr)
-import HsPat(TypecheckedPat)
-import Id(Id)
-import Inst(Inst)
-import PreludePS(_PackedString)
-import SplitUniq(SplitUniqSupply)
-import SrcLoc(SrcLoc)
-import TyVar(TyVar)
-import UniqFM(UniqFM)
-dsBinds :: Binds Id TypecheckedPat -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> ([CoreBinding Id Id], Bag DsMatchContext)
-dsInstBinds :: [TyVar] -> [(Inst, Expr Id TypecheckedPat)] -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (([(Id, CoreExpr Id Id)], [(Id, CoreExpr Id Id)]), Bag DsMatchContext)
-
diff --git a/ghc/compiler/deSugar/DsBinds.lhs b/ghc/compiler/deSugar/DsBinds.lhs
index f9e3bf2c92..691e086058 100644
--- a/ghc/compiler/deSugar/DsBinds.lhs
+++ b/ghc/compiler/deSugar/DsBinds.lhs
@@ -1,56 +1,62 @@
 %
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
 %
-\section[DsBinds]{Pattern-matching bindings (Binds and MonoBinds)}
+\section[DsBinds]{Pattern-matching bindings (HsBinds and MonoBinds)}
 
-Handles @Binds@; those at the top level require different handling, in
-that the @Rec@/@NonRec@/etc structure is thrown away (whereas at lower
-levels it is preserved with @let@/@letrec@s).
+Handles @HsBinds@; those at the top level require different handling,
+in that the @Rec@/@NonRec@/etc structure is thrown away (whereas at
+lower levels it is preserved with @let@/@letrec@s).
 
 \begin{code}
 #include "HsVersions.h"
 
-module DsBinds (
-	dsBinds, dsInstBinds
-    ) where
+module DsBinds ( dsBinds, dsInstBinds ) where
 
-IMPORT_Trace		-- ToDo: rm (debugging only)
+import Ubiq
+import DsLoop		-- break dsExpr-ish loop
 
-import AbsSyn		-- the stuff being desugared
-import PlainCore	-- the output of desugaring;
-			-- importing this module also gets all the
-			-- CoreSyn utility functions
-import DsMonad		-- the monadery used in the desugarer
+import HsSyn		-- lots of things
+import CoreSyn		-- lots of things
+import TcHsSyn		( TypecheckedHsBinds(..), TypecheckedHsExpr(..),
+			  TypecheckedBind(..), TypecheckedMonoBinds(..) )
+import DsHsSyn		( collectTypedBinders, collectTypedPatBinders )
 
-import AbsUniType
-import CmdLineOpts	( GlobalSwitch(..), SwitchResult, switchIsOn )
-import CostCentre	( mkAllDictsCC, preludeDictsCostCentre )
-import Inst		( getInstUniType )
-import DsExpr		( dsExpr )
+import DsMonad
 import DsGRHSs		( dsGuarded )
 import DsUtils
-import Id		( getIdUniType, mkInstId, Inst, Id, DictVar(..) )
 import Match		( matchWrapper )
-import Maybes		( Maybe(..),assocMaybe )
-import Outputable
-import Pretty
-import Util
+
+import CmdLineOpts	( opt_SccProfilingOn, opt_CompilingPrelude )
+import CoreUtils	( escErrorMsg )
+import CostCentre	( mkAllDictsCC, preludeDictsCostCentre )
+import Id		( idType, DictVar(..), GenId )
 import ListSetOps	( minusList, intersectLists )
+import PprType		( GenType, GenTyVar )
+import PprStyle		( PprStyle(..) )
+import Pretty		( ppShow )
+import Type		( mkTyVarTy, splitSigmaTy )
+import TyVar		( GenTyVar )
+import Unique		( Unique )
+import Util		( isIn, panic )
+
+extractTyVarsFromTy = panic "DsBinds.extractTyVarsFromTy"
+extractTyVarsFromTys = panic "DsBinds.extractTyVarsFromTys"
+isDictTy = panic "DsBinds.isDictTy"
+quantifyTy = panic "DsBinds.quantifyTy"
 \end{code}
 
-
 %************************************************************************
 %*									*
 \subsection[toplevel-and-regular-DsBinds]{Regular and top-level @dsBinds@}
 %*									*
 %************************************************************************
 
-Like @dsBinds@, @dsBind@ returns a @[PlainCoreBinding]@, but it may be
+Like @dsBinds@, @dsBind@ returns a @[CoreBinding]@, but it may be
 that some of the binders are of unboxed type.  This is sorted out when
 the caller wraps the bindings round an expression.
 
 \begin{code}
-dsBinds :: TypecheckedBinds -> DsM [PlainCoreBinding]
+dsBinds :: TypecheckedHsBinds -> DsM [CoreBinding]
 \end{code}
 
 All ``real'' bindings are expressed in terms of the
@@ -99,7 +105,7 @@ dsBinds (ThenBinds  binds_1 binds_2)
 \subsubsection{AbsBind case: no overloading}
 %==============================================
 
-Special case: no overloading.  
+Special case: no overloading.
 \begin{verbatim}
 	x1 = e1
 	x2 = e2
@@ -109,7 +115,7 @@ We abstract each wrt the type variables, giving
 	x1' = /\tyvars -> e1[x1' tyvars/x1, x2' tyvars/x2]
 	x2' = /\tyvars -> e2[x1' tyvars/x1, x2' tyvars/x2]
 \end{verbatim}
-There are some complications.  
+There are some complications.
 
 (i) The @val_binds@ might mention variable not in @local_global_prs@.
 In this case we need to make up new polymorphic versions of them.
@@ -124,7 +130,7 @@ dsBinds (AbsBinds tyvars [] local_global_prs inst_binds val_binds)
   = mapDs mk_poly_private_binder private_binders
 					`thenDs` \ poly_private_binders ->
     let
-	full_local_global_prs = (private_binders `zip` poly_private_binders) 
+	full_local_global_prs = (private_binders `zip` poly_private_binders)
 				++ local_global_prs
     in
     listDs [ mkSatTyApp global tyvar_tys `thenDs` \ app ->
@@ -150,7 +156,7 @@ dsBinds (AbsBinds tyvars [] local_global_prs inst_binds val_binds)
 	-- local_global_prs.
     private_binders = binders `minusList` [local | (local,_) <- local_global_prs]
     binders	    = collectTypedBinders val_binds
-    mk_poly_private_binder id = newSysLocalDs (snd (quantifyTy tyvars (getIdUniType id)))
+    mk_poly_private_binder id = newSysLocalDs (snd (quantifyTy tyvars (idType id)))
 
     tyvar_tys = map mkTyVarTy tyvars
 \end{code}
@@ -176,7 +182,7 @@ Here, f is fully polymorphic in b.  So we generate
 		 letrec f' b = ...(f' b)...
 		 in f' b
 
-*Notice* that we don't clone type variables, and *do* make use of 
+*Notice* that we don't clone type variables, and *do* make use of
 shadowing.  It is possible to do cloning, but it makes the code quite
 a bit more complicated, and the simplifier will clone it all anyway.
 
@@ -188,7 +194,7 @@ to a particular type for a.
 dsBinds (AbsBinds all_tyvars dicts local_global_prs dict_binds val_binds)
   = 	-- If there is any non-overloaded polymorphism, make new locals with
 	-- appropriate polymorphism
-    (if null non_overloaded_tyvars 
+    (if null non_overloaded_tyvars
      then
 	-- No non-overloaded polymorphism, so stay with current envt
 	returnDs (id, [], [])
@@ -199,29 +205,29 @@ dsBinds (AbsBinds all_tyvars dicts local_global_prs dict_binds val_binds)
 	mapDs mk_binder binders			`thenDs` \ new_binders ->
 	let
 	    old_new_pairs   = binders `zip` new_binders
-        in
+	in
 
 	listDs	[ mkSatTyApp new non_ov_tyvar_tys `thenDs` \ app ->
 		  returnDs (old, app)
 		| (old,new) <- old_new_pairs
 		]					`thenDs` \ extra_env ->
 	let
-	  local_binds = [CoNonRec old app | (old,app) <- extra_env, old `is_elem` locals]
+	  local_binds = [NonRec old app | (old,app) <- extra_env, old `is_elem` locals]
 	  is_elem     = isIn "dsBinds"
 	in
 	returnDs (lookupId old_new_pairs, extra_env, local_binds)
     )
 		`thenDs` \ (binder_subst_fn, local_env, local_binds) ->
-	
+
 --    pprTrace "AbsBinds:all:" (ppAbove (ppr PprDebug local_binds) (ppr PprDebug local_env)) $
 
     extendEnvDs local_env (
- 
+
       dsInstBinds non_overloaded_tyvars dict_binds	`thenDs` \ (inst_bind_pairs, inst_env) ->
 
       extendEnvDs inst_env		 (
 
-	dsBind non_overloaded_tyvars [] binder_subst_fn inst_bind_pairs val_binds	
+	dsBind non_overloaded_tyvars [] binder_subst_fn inst_bind_pairs val_binds
     ))							`thenDs` \ core_binds ->
 
     let
@@ -231,45 +237,43 @@ dsBinds (AbsBinds all_tyvars dicts local_global_prs dict_binds val_binds)
     in
     mkTupleBind all_tyvars dicts local_global_prs tuple_rhs  `thenDs` \ core_bind_prs ->
 
-    returnDs [ CoNonRec binder rhs | (binder,rhs) <- core_bind_prs ]
+    returnDs [ NonRec binder rhs | (binder,rhs) <- core_bind_prs ]
   where
     locals = [local | (local,global) <- local_global_prs]
     non_ov_tyvar_tys = map mkTyVarTy non_overloaded_tyvars
 
-    overloaded_tyvars     = extractTyVarsFromTys (map getIdUniType dicts)
+    overloaded_tyvars     = extractTyVarsFromTys (map idType dicts)
     non_overloaded_tyvars = all_tyvars `minusList` overloaded_tyvars
 
     binders      = collectTypedBinders val_binds
-    mk_binder id = newSysLocalDs (snd (quantifyTy non_overloaded_tyvars (getIdUniType id)))
+    mk_binder id = newSysLocalDs (snd (quantifyTy non_overloaded_tyvars (idType id)))
 \end{code}
 
 @mkSatTyApp id tys@ constructs an expression whose value is (id tys).
 However, sometimes id takes more type args than are in tys, and the
 specialiser hates that, so we have to eta expand, to
-(/\ a b -> id tys a b)
+@(/\ a b -> id tys a b)@.
 
 \begin{code}
 mkSatTyApp :: Id 		-- Id to apply to the types
-	   -> [UniType]		-- Types to apply it to
-	   -> DsM PlainCoreExpr
+	   -> [Type]		-- Types to apply it to
+	   -> DsM CoreExpr
 
-mkSatTyApp id [] = returnDs (CoVar id)
+mkSatTyApp id [] = returnDs (Var id)
 
 mkSatTyApp id tys
-  | null tyvar_templates 
-  = returnDs (mkCoTyApps (CoVar id) tys)	-- Common case
-
+  | null tvs
+  = returnDs ty_app	-- Common case
   | otherwise
-  = newTyVarsDs (drop (length tys) tyvar_templates)	`thenDs` \ tyvars ->
---  pprTrace "mkSatTyApp:" (ppCat [ppr PprDebug id, ppr PprDebug tyvar_templates, ppr PprDebug tyvars, ppr PprDebug theta, ppr PprDebug tau_ty, ppr PprDebug tys]) $
-    returnDs (mkCoTyLam tyvars (mkCoTyApps (mkCoTyApps (CoVar id) tys) 
-					   (map mkTyVarTy tyvars)))
+  = newTyVarsDs (drop (length tys) tvs)	`thenDs` \ tyvars ->
+    returnDs (mkTyLam tyvars (mkTyApp ty_app (map mkTyVarTy tyvars)))
   where
-    (tyvar_templates, theta, tau_ty) = splitType (getIdUniType id)
+    (tvs, theta, tau_ty) = splitSigmaTy (idType id)
+    ty_app = mkTyApp (Var id) tys
 \end{code}
 
-There are several places where we encounter ``inst binds,'' 
-@(Inst, TypecheckedExpr)@ pairs.  Many of these are ``trivial'' binds
+There are several places where we encounter ``inst binds,''
+@(Id, TypecheckedHsExpr)@ pairs.  Many of these are ``trivial'' binds
 (a var to a var or literal), which we want to substitute away; so we
 return both some desugared bindings {\em and} a substitution
 environment for the subbed-away ones.
@@ -279,32 +283,36 @@ later ones may mention earlier ones, but not vice versa.
 
 \begin{code}
 dsInstBinds :: [TyVar]				-- Abstract wrt these
-	    -> [(Inst, TypecheckedExpr)]	-- From AbsBinds
-	    -> DsM ([(Id,PlainCoreExpr)], 	-- Non-trivial bindings
-		    [(Id,PlainCoreExpr)])	-- Trivial ones to be substituted away
+	    -> [(Id, TypecheckedHsExpr)]	-- From AbsBinds
+	    -> DsM ([(Id,CoreExpr)], 	-- Non-trivial bindings
+		    [(Id,CoreExpr)])	-- Trivial ones to be substituted away
 
-do_nothing = ([], []) -- out here to avoid dsInstBinds CAF (sigh)
+do_nothing    = ([], []) -- out here to avoid dsInstBinds CAF (sigh)
 prel_dicts_cc = preludeDictsCostCentre False{-not dupd-} -- ditto
 
 dsInstBinds tyvars []
   = returnDs do_nothing
 
-dsInstBinds tyvars ((inst, expr@(Var _)) : bs)
+dsInstBinds _ _ = panic "DsBinds.dsInstBinds:maybe we want something different?"
+
+{- LATER
+
+dsInstBinds tyvars ((inst, expr@(HsVar _)) : bs)
   = dsExpr expr				`thenDs` ( \ rhs ->
-    let	-- Need to apply dsExpr to the variable in case it 
+    let	-- Need to apply dsExpr to the variable in case it
 	-- has a substitution in the current environment
-	subst_item = (mkInstId inst, rhs)
+	subst_item = (inst, rhs)
     in
     extendEnvDs [subst_item] (
-	dsInstBinds tyvars bs 	
+	dsInstBinds tyvars bs
     )					`thenDs` (\ (binds, subst_env) ->
     returnDs (binds, subst_item : subst_env)
     ))
 
-dsInstBinds tyvars ((inst, expr@(Lit _)) : bs)
+dsInstBinds tyvars ((inst, expr@(HsLit _)) : bs)
   = dsExpr expr				`thenDs` ( \ core_lit ->
     let
-	subst_item = (mkInstId inst, core_lit)
+	subst_item = (inst, core_lit)
     in
     extendEnvDs [subst_item]	 (
 	dsInstBinds tyvars bs
@@ -317,32 +325,32 @@ dsInstBinds tyvars ((inst, expr) : bs)
   = dsExpr expr			`thenDs` \ core_expr ->
     ds_dict_cc core_expr	`thenDs` \ dict_expr ->
     dsInstBinds tyvars bs	`thenDs` \ (core_rest, subst_env) ->
-    returnDs ((mkInstId inst, dict_expr) : core_rest, subst_env)
-	
+    returnDs ((inst, dict_expr) : core_rest, subst_env)
+
   | otherwise
-  =	-- Obscure case.  
+  =	-- Obscure case.
 	-- The inst mentions the type vars wrt which we are abstracting,
 	-- so we have to invent a new polymorphic version, and substitute
 	-- appropriately.
-	-- This can occur in, for example: 
+	-- This can occur in, for example:
 	--	leftPoll :: [FeedBack a] -> FeedBack a
 	--	leftPoll xs = take poll xs
 	-- Here there is an instance of take at the type of elts of xs,
-	-- as well as the type of poll.  
+	-- as well as the type of poll.
 
     dsExpr expr			`thenDs` \ core_expr ->
     ds_dict_cc core_expr	`thenDs` \ dict_expr ->
     newSysLocalDs poly_inst_ty	`thenDs` \ poly_inst_id ->
     let
-	subst_item = (mkInstId inst, mkCoTyApps (CoVar poly_inst_id) abs_tys)
+	subst_item = (inst, mkTyApp (Var poly_inst_id) abs_tys)
     in
     extendEnvDs [subst_item] (
-	dsInstBinds tyvars bs	
+	dsInstBinds tyvars bs
     )				`thenDs` \ (core_rest, subst_env) ->
-    returnDs ((poly_inst_id, mkCoTyLam abs_tyvars dict_expr) : core_rest, 
+    returnDs ((poly_inst_id, mkTyLam abs_tyvars dict_expr) : core_rest,
 	      subst_item : subst_env)
   where
-    inst_ty    = getInstUniType inst
+    inst_ty    = idType inst
     abs_tyvars = extractTyVarsFromTy inst_ty `intersectLists` tyvars
     abs_tys    = map mkTyVarTy abs_tyvars
     (_, poly_inst_ty) = quantifyTy abs_tyvars inst_ty
@@ -353,16 +361,15 @@ dsInstBinds tyvars ((inst, expr) : bs)
 
     ds_dict_cc expr
       = -- if profiling, wrap the dict in "_scc_ DICT <dict>":
-	getSwitchCheckerDs	`thenDs` \ sw_chkr ->
 	let
-	    doing_profiling   = sw_chkr SccProfilingOn
-	    compiling_prelude = sw_chkr CompilingPrelude
+	    doing_profiling   = opt_SccProfilingOn
+	    compiling_prelude = opt_CompilingPrelude
 	in
 	if not doing_profiling
 	|| not (isDictTy inst_ty) then -- that's easy: do nothing
 	    returnDs expr
 	else if compiling_prelude then
-	    returnDs (CoSCC prel_dicts_cc expr)
+	    returnDs (SCC prel_dicts_cc expr)
 	else
 	    getModuleAndGroupDs 	`thenDs` \ (mod_name, grp_name) ->
 	    -- ToDo: do -dicts-all flag (mark dict things
@@ -370,7 +377,8 @@ dsInstBinds tyvars ((inst, expr) : bs)
 	    let
 		dict_cc = mkAllDictsCC mod_name grp_name False{-not dupd-}
 	    in
-	    returnDs (CoSCC dict_cc expr)
+	    returnDs (SCC dict_cc expr)
+-}
 \end{code}
 
 %************************************************************************
@@ -379,28 +387,28 @@ dsInstBinds tyvars ((inst, expr) : bs)
 %*									*
 %************************************************************************
 
-Like @dsBinds@, @dsBind@ returns a @[PlainCoreBinding]@, but it may be that
-some of the binders are of unboxed type.  
+Like @dsBinds@, @dsBind@ returns a @[CoreBinding]@, but it may be that
+some of the binders are of unboxed type.
 
 For an explanation of the first three args, see @dsMonoBinds@.
 
 \begin{code}
 dsBind	:: [TyVar] -> [DictVar]		-- Abstract wrt these
 	-> (Id -> Id)			-- Binder substitution
-	-> [(Id,PlainCoreExpr)]		-- Inst bindings already dealt with
-	-> TypecheckedBind 
-	-> DsM [PlainCoreBinding]
+	-> [(Id,CoreExpr)]		-- Inst bindings already dealt with
+	-> TypecheckedBind
+	-> DsM [CoreBinding]
 
-dsBind tyvars dicts binder_subst inst_bind_pairs EmptyBind 
-  = returnDs [CoNonRec binder rhs | (binder,rhs) <- inst_bind_pairs]
+dsBind tyvars dicts binder_subst inst_bind_pairs EmptyBind
+  = returnDs [NonRec binder rhs | (binder,rhs) <- inst_bind_pairs]
 
 dsBind tyvars dicts binder_subst inst_bind_pairs (NonRecBind monobinds)
   = dsMonoBinds False tyvars dicts binder_subst monobinds   `thenDs` ( \ val_bind_pairs ->
-    returnDs [CoNonRec binder rhs | (binder,rhs) <- inst_bind_pairs ++ val_bind_pairs] )
+    returnDs [NonRec binder rhs | (binder,rhs) <- inst_bind_pairs ++ val_bind_pairs] )
 
 dsBind tyvars dicts binder_subst inst_bind_pairs (RecBind monobinds)
   = dsMonoBinds True tyvars dicts binder_subst monobinds   `thenDs` ( \ val_bind_pairs ->
-    returnDs [CoRec (inst_bind_pairs ++ val_bind_pairs)] )
+    returnDs [Rec (inst_bind_pairs ++ val_bind_pairs)] )
 \end{code}
 
 
@@ -410,11 +418,11 @@ dsBind tyvars dicts binder_subst inst_bind_pairs (RecBind monobinds)
 %*									*
 %************************************************************************
 
-@dsMonoBinds@ transforms @TypecheckedMonoBinds@ into @PlainCoreBinds@.
+@dsMonoBinds@ transforms @TypecheckedMonoBinds@ into @CoreBinds@.
 In addition to desugaring pattern matching, @dsMonoBinds@ takes
 a list of type variables and dicts, and adds abstractions for these
-to the front of every binding.	That requires that the 
-binders be altered too (their type has changed, 
+to the front of every binding.	That requires that the
+binders be altered too (their type has changed,
 so @dsMonoBinds@ also takes a function which maps binders into binders.
 This mapping gives the binder the correct new type.
 
@@ -427,7 +435,7 @@ dsMonoBinds :: Bool			-- True <=> recursive binding group
 	    -> [TyVar] -> [DictVar]	-- Abstract wrt these
 	    -> (Id -> Id)		-- Binder substitution
 	    -> TypecheckedMonoBinds
-	    -> DsM [(Id,PlainCoreExpr)]
+	    -> DsM [(Id,CoreExpr)]
 \end{code}
 
 
@@ -456,9 +464,9 @@ For the simplest bindings, we just heave them in the substitution env:
 	The extendEnvDs only scopes over the nested call!
 	Let the simplifier do this.
 
-dsMonoBinds is_rec tyvars dicts binder_subst (VarMonoBind was_var (Var new_var))
+dsMonoBinds is_rec tyvars dicts binder_subst (VarMonoBind was_var (HsVar new_var))
   | not (is_rec || isExported was_var)
-  = extendEnvDs [(was_var, CoVar new_var)] (
+  = extendEnvDs [(was_var, Var new_var)] (
     returnDs [] )
 
 dsMonoBinds is_rec tyvars dicts binder_subst (VarMonoBind was_var expr@(Lit _))
@@ -469,28 +477,28 @@ dsMonoBinds is_rec tyvars dicts binder_subst (VarMonoBind was_var expr@(Lit _))
 -}
 
 dsMonoBinds is_rec tyvars dicts binder_subst (VarMonoBind var expr)
-  = dsExpr expr		`thenDs` ( \ core_expr ->
-    returnDs [(binder_subst var, mkCoTyLam tyvars (mkCoLam dicts core_expr))] )
+  = dsExpr expr		`thenDs` \ core_expr ->
+    returnDs [(binder_subst var, mkLam tyvars dicts core_expr)]
 \end{code}
 
 \begin{code}
 dsMonoBinds is_rec tyvars dicts binder_subst (FunMonoBind fun matches locn)
-  = putSrcLocDs locn				 (
+  = putSrcLocDs locn	(
     let
 	new_fun = binder_subst fun
     in
     matchWrapper (FunMatch fun) matches (error_msg new_fun) `thenDs` \ (args, body) ->
     returnDs [(new_fun,
-	       mkCoTyLam tyvars (mkCoLam dicts (mkCoLam args body)))]
+	       mkLam tyvars (dicts ++ args) body)]
     )
   where
     error_msg fun = "%F" -- "incomplete pattern(s) to match in function \""
 		++ (escErrorMsg (ppShow 80 (ppr PprForUser fun))) ++ "\""
 
 dsMonoBinds is_rec tyvars dicts binder_subst (PatMonoBind (VarPat v) grhss_and_binds locn)
-  = putSrcLocDs locn			    (
+  = putSrcLocDs locn	(
     dsGuarded grhss_and_binds locn `thenDs` \ body_expr ->
-    returnDs [(binder_subst v, mkCoTyLam tyvars (mkCoLam dicts body_expr))]
+    returnDs [(binder_subst v, mkLam tyvars dicts body_expr)]
     )
 \end{code}
 
@@ -513,10 +521,10 @@ We handle three cases for the binding
 	pat = rhs
 
 \begin{description}
-\item[pat has no binders.]  
+\item[pat has no binders.]
 Then all this is dead code and we return an empty binding.
 
-\item[pat has exactly one binder, v.]  
+\item[pat has exactly one binder, v.]
 Then we can transform to:
 \begin{verbatim}
 	v' = /\ tyvars -> case rhs of { pat -> v }
@@ -531,7 +539,7 @@ Then we transform to:
 	vi = /\ tyvars -> case (t tyvars) of { (v1, ..., vn) -> vi }
 \end{verbatim}
 \end{description}
-  
+
 \begin{code}
 dsMonoBinds is_rec tyvars [] binder_subst (PatMonoBind pat grhss_and_binds locn)
   = putSrcLocDs locn (
@@ -549,57 +557,14 @@ dsMonoBinds is_rec tyvars [] binder_subst (PatMonoBind pat grhss_and_binds locn)
 	-- we can just use the rhs directly
     else
 -}
-    mkSelectorBinds tyvars pat 	      
+    mkSelectorBinds tyvars pat
 	[(binder, binder_subst binder) | binder <- pat_binders]
 	body_expr
     )
   where
     pat_binders = collectTypedPatBinders pat
-	-- NB For a simple tuple pattern, these binders 
+	-- NB For a simple tuple pattern, these binders
 	-- will appear in the right order!
-
-{- UNUSED, post-Sansom:
-    any_con_w_prim_arg :: TypecheckedPat -> Bool
-
-    any_con_w_prim_arg (WildPat ty)	= isPrimType ty
-    any_con_w_prim_arg (VarPat v)	= isPrimType (getIdUniType v)
-    any_con_w_prim_arg (LazyPat pat)	= any_con_w_prim_arg pat
-    any_con_w_prim_arg (AsPat _ pat)	= any_con_w_prim_arg pat
-    any_con_w_prim_arg p@(ConPat _ _ args)  = any any_con_w_prim_arg args
-    any_con_w_prim_arg (ConOpPat a1 _ a2 _) = any any_con_w_prim_arg [a1,a2]
-    any_con_w_prim_arg (ListPat _ args)	    = any any_con_w_prim_arg args
-    any_con_w_prim_arg (TuplePat  args)	    = any any_con_w_prim_arg args
-    any_con_w_prim_arg (LitPat _ ty)	    = isPrimType ty
-    any_con_w_prim_arg (NPat	  _ _ _)	= False -- be more paranoid?
-    any_con_w_prim_arg (NPlusKPat _ _ _ _ _ _)	= False -- ditto
-
-#ifdef DPH
-    -- Should be more efficient to find type of pid than pats 
-    any_con_w_prim_arg (ProcessorPat pats _ pat) 
-       = error "any_con_w_prim_arg:ProcessorPat (DPH)"
-#endif {- Data Parallel Haskell -}
--}
-
-{-	OLD ... removed 6 Feb 95
-
-    -- we allow it if the constructor has *only one*
-    -- argument and that is unboxed, as in
-    --
-    --	let (I# i#) = ... in ...
-    --
-    prim_args args
-      = let
-	    no_of_prim_args
-	      = length [ a | a <- args, isPrimType (typeOfPat a) ]
-        in
-	if no_of_prim_args == 0 then
-	    False
-	else if no_of_prim_args == 1 && length args == 1 then
-	    False -- special case we let through
-	else
-	    True
-
--}
 \end{code}
 
 Wild-card patterns could be made acceptable here, but it involves some
diff --git a/ghc/compiler/deSugar/DsCCall.hi b/ghc/compiler/deSugar/DsCCall.hi
deleted file mode 100644
index 1beb8b925a..0000000000
--- a/ghc/compiler/deSugar/DsCCall.hi
+++ /dev/null
@@ -1,14 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface DsCCall where
-import Bag(Bag)
-import CmdLineOpts(GlobalSwitch, SwitchResult)
-import CoreSyn(CoreExpr)
-import DsMonad(DsMatchContext)
-import Id(Id)
-import PreludePS(_PackedString)
-import SplitUniq(SplitUniqSupply)
-import SrcLoc(SrcLoc)
-import UniType(UniType)
-import UniqFM(UniqFM)
-dsCCall :: _PackedString -> [CoreExpr Id Id] -> Bool -> Bool -> UniType -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (CoreExpr Id Id, Bag DsMatchContext)
-
diff --git a/ghc/compiler/deSugar/DsCCall.lhs b/ghc/compiler/deSugar/DsCCall.lhs
index 87a834e07d..f2eb50bc1e 100644
--- a/ghc/compiler/deSugar/DsCCall.lhs
+++ b/ghc/compiler/deSugar/DsCCall.lhs
@@ -1,5 +1,5 @@
 %
-% (c) The AQUA Project, Glasgow University, 1994-1995
+% (c) The AQUA Project, Glasgow University, 1994-1996
 %
 \section[DsCCall]{Desugaring \tr{_ccall_}s and \tr{_casm_}s}
 
@@ -8,24 +8,30 @@
 
 module DsCCall ( dsCCall ) where
 
-IMPORT_Trace
+import Ubiq
 
-import AbsSyn		-- the stuff being desugared
-import PlainCore	-- the output of desugaring
-import DsMonad		-- the monadery used in the desugarer
+import CoreSyn
 
-import AbsPrel
-import TysPrim		-- ****** ToDo: PROPERLY
-import TysWiredIn
-import AbsUniType
+import DsMonad
 import DsUtils
-import Id		( getInstantiatedDataConSig, mkTupleCon, DataCon(..) )
-import Maybes		( maybeToBool, Maybe(..) )
+
+import CoreUtils	( coreExprType )
+import Id		( getInstantiatedDataConSig, mkTupleCon )
+import Maybes		( maybeToBool )
+import PprStyle		( PprStyle(..) )
+import PprType		( GenType{-instances-}, GenTyVar{-instance-} )
+import PrelInfo		( byteArrayPrimTy, getStatePairingConInfo,
+		          packStringForCId, realWorldStatePrimTy,
+			  realWorldStateTy, realWorldTy, stateDataCon,
+			  stringTy )
 import Pretty
-#if USE_ATTACK_PRAGMAS
-import Unique
-#endif
-import Util
+import PrimOp		( PrimOp(..) )
+import Type		( isPrimType, maybeAppDataTyCon, eqTy )
+import TyVar		( GenTyVar{-instance-} )
+import Unique		( Unique{-instances-} )
+import Util		( pprPanic, panic )
+
+maybeBoxedPrimType = panic "DsCCall.maybeBoxedPrimType"
 \end{code}
 
 Desugaring of @ccall@s consists of adding some state manipulation,
@@ -39,7 +45,7 @@ The unboxing is straightforward, as all information needed to unbox is
 available from the type.  For each boxed-primitive argument, we
 transform:
 \begin{verbatim}
-   _ccall_ foo [ r, t1, ... tm ] e1 ... em 
+   _ccall_ foo [ r, t1, ... tm ] e1 ... em
    |
    |
    V
@@ -60,61 +66,61 @@ follows:
    |
    V
    \ s# -> case (ccall# foo [ r, t1#, ... tm# ] s# e1# ... em#) of
-          (StateAnd<r># result# state#) -> (R# result#, realWorld#)
+	  (StateAnd<r># result# state#) -> (R# result#, realWorld#)
 \end{verbatim}
 
 \begin{code}
 dsCCall :: FAST_STRING		-- C routine to invoke
-	-> [PlainCoreExpr]	-- Arguments (desugared)
+	-> [CoreExpr]	-- Arguments (desugared)
 	-> Bool			-- True <=> might cause Haskell GC
 	-> Bool			-- True <=> really a "_casm_"
-	-> UniType		-- Type of the result (a boxed-prim type)
-	-> DsM PlainCoreExpr
+	-> Type		-- Type of the result (a boxed-prim type)
+	-> DsM CoreExpr
 
 dsCCall label args may_gc is_asm result_ty
   = newSysLocalDs realWorldStateTy	`thenDs` \ old_s ->
 
-    mapAndUnzipDs unboxArg (CoVar old_s : args)	`thenDs` \ (final_args, arg_wrappers) ->
+    mapAndUnzipDs unboxArg (Var old_s : args)	`thenDs` \ (final_args, arg_wrappers) ->
 
     boxResult result_ty				`thenDs` \ (final_result_ty, res_wrapper) ->
 
     let
 	the_ccall_op = CCallOp label is_asm may_gc
-			       (map typeOfCoreExpr final_args)
+			       (map coreExprType final_args)
 			       final_result_ty
     in
-    mkCoPrimDs the_ccall_op
+    mkPrimDs the_ccall_op
 	       [] -- ***NOTE*** no ty apps; the types are inside the_ccall_op.
 	       final_args	`thenDs` \ the_prim_app ->
     let
 	the_body = foldr apply (res_wrapper the_prim_app) arg_wrappers
     in
-    returnDs (CoLam [old_s] the_body)
+    returnDs (Lam (ValBinder old_s) the_body)
   where
     apply f x = f x
 \end{code}
 
 \begin{code}
-unboxArg :: PlainCoreExpr			-- The supplied argument
-	 -> DsM (PlainCoreExpr,			-- To pass as the actual argument
-		 PlainCoreExpr -> PlainCoreExpr	-- Wrapper to unbox the arg
+unboxArg :: CoreExpr			-- The supplied argument
+	 -> DsM (CoreExpr,			-- To pass as the actual argument
+		 CoreExpr -> CoreExpr	-- Wrapper to unbox the arg
 		)
 unboxArg arg
 
   -- Primitive types
   -- ADR Question: can this ever be used?  None of the PrimTypes are
   -- instances of the _CCallable class.
-  | isPrimType arg_ty 
+  | isPrimType arg_ty
   = returnDs (arg, \body -> body)
 
   -- Strings
-  | arg_ty == stringTy
+  | arg_ty `eqTy` stringTy
   -- ToDo (ADR): - allow synonyms of Strings too?
   = newSysLocalDs byteArrayPrimTy		`thenDs` \ prim_arg ->
-    mkCoAppDs (CoVar packStringForCId) arg	`thenDs` \ pack_appn ->
-    returnDs (CoVar prim_arg,
-	      \body -> CoCase pack_appn (CoPrimAlts [] 
-						    (CoBindDefault prim_arg body))
+    mkAppDs (Var packStringForCId) [] [arg]	`thenDs` \ pack_appn ->
+    returnDs (Var prim_arg,
+	      \body -> Case pack_appn (PrimAlts []
+						    (BindDefault prim_arg body))
     )
 
   | null data_cons
@@ -123,25 +129,25 @@ unboxArg arg
 
   -- Byte-arrays, both mutable and otherwise
   -- (HACKy method -- but we really don't want the TyCons wired-in...) [WDP 94/10]
-  | is_data_type && 
+  | is_data_type &&
     length data_con_arg_tys == 2 &&
     not (isPrimType data_con_arg_ty1) &&
     isPrimType data_con_arg_ty2
     -- and, of course, it is an instance of _CCallable
---  ( tycon == byteArrayTyCon || 
+--  ( tycon == byteArrayTyCon ||
 --    tycon == mutableByteArrayTyCon )
   = newSysLocalsDs data_con_arg_tys		`thenDs` \ vars@[ixs_var, arr_cts_var] ->
-    returnDs (CoVar arr_cts_var,
-	      \ body -> CoCase arg (CoAlgAlts [(the_data_con,vars,body)] 
-					      CoNoDefault)
+    returnDs (Var arr_cts_var,
+	      \ body -> Case arg (AlgAlts [(the_data_con,vars,body)]
+					      NoDefault)
     )
 
   -- Data types with a single constructor, which has a single, primitive-typed arg
   | maybeToBool maybe_boxed_prim_arg_ty
   = newSysLocalDs the_prim_arg_ty		`thenDs` \ prim_arg ->
-    returnDs (CoVar prim_arg,
-	      \ body -> CoCase arg (CoAlgAlts [(box_data_con,[prim_arg],body)] 
-					      CoNoDefault)
+    returnDs (Var prim_arg,
+	      \ body -> Case arg (AlgAlts [(box_data_con,[prim_arg],body)]
+					      NoDefault)
     )
   -- ... continued below ....
 \end{code}
@@ -164,11 +170,11 @@ we decide what's happening with enumerations. ADR
 
     let
       alts = [ (con, [], mkMachInt i) | (con,i) <- data_cons `zip` [0..] ]
-      arg_tag = CoCase arg (CoAlgAlts alts) CoNoDefault
+      arg_tag = Case arg (AlgAlts alts) NoDefault
     in
 
-    returnDs (CoVar prim_arg,
-	      \ body -> CoCase arg_tag (CoPrimAlts [(prim_arg, body)] CoNoDefault)
+    returnDs (Var prim_arg,
+	      \ body -> Case arg_tag (PrimAlts [(prim_arg, body)] NoDefault)
     )
 #endif
 \end{code}
@@ -178,12 +184,12 @@ we decide what's happening with enumerations. ADR
   | otherwise
   = pprPanic "unboxArg: " (ppr PprDebug arg_ty)
   where
-    arg_ty = typeOfCoreExpr arg
+    arg_ty = coreExprType arg
 
     maybe_boxed_prim_arg_ty = maybeBoxedPrimType arg_ty
     (Just (box_data_con, the_prim_arg_ty)) = maybe_boxed_prim_arg_ty
 
-    maybe_data_type 			   = getUniDataTyCon_maybe arg_ty
+    maybe_data_type 			   = maybeAppDataTyCon arg_ty
     is_data_type			   = maybeToBool maybe_data_type
     (Just (tycon, tycon_arg_tys, data_cons)) = maybe_data_type
     (the_data_con : other_data_cons)       = data_cons
@@ -198,11 +204,11 @@ can't_see_datacons_error thing ty
 
 \begin{code}
 tuple_con_2 = mkTupleCon 2 -- out here to avoid CAF (sigh)
-covar_tuple_con_0 = CoVar (mkTupleCon 0) -- ditto
+covar_tuple_con_0 = Var (mkTupleCon 0) -- ditto
 
-boxResult :: UniType				-- Type of desired result
-	  -> DsM (UniType,			-- Type of the result of the ccall itself
-		  PlainCoreExpr -> PlainCoreExpr)	-- Wrapper for the ccall 
+boxResult :: Type				-- Type of desired result
+	  -> DsM (Type,			-- Type of the result of the ccall itself
+		  CoreExpr -> CoreExpr)	-- Wrapper for the ccall
 							-- to box the result
 boxResult result_ty
   | null data_cons
@@ -214,41 +220,41 @@ boxResult result_ty
     (null other_data_cons) &&					-- Just one constr
     not (null data_con_arg_tys) && null other_args_tys	&& 	-- Just one arg
     isPrimType the_prim_result_ty				-- of primitive type
-  = 
+  =
     newSysLocalDs realWorldStatePrimTy				`thenDs` \ prim_state_id ->
     newSysLocalDs the_prim_result_ty 				`thenDs` \ prim_result_id ->
 
-    mkCoConDs stateDataCon [realWorldTy] [CoVar prim_state_id]	`thenDs` \ new_state ->
-    mkCoConDs the_data_con tycon_arg_tys   [CoVar prim_result_id]	`thenDs` \ the_result ->
-    
-    mkCoConDs tuple_con_2
-	      [result_ty, realWorldStateTy]
-	      [the_result, new_state]				`thenDs` \ the_pair ->
+    mkConDs stateDataCon [realWorldTy] [Var prim_state_id]	`thenDs` \ new_state ->
+    mkConDs the_data_con tycon_arg_tys [Var prim_result_id]	`thenDs` \ the_result ->
+
+    mkConDs tuple_con_2
+	    [result_ty, realWorldStateTy]
+	    [the_result, new_state]				`thenDs` \ the_pair ->
     let
 	the_alt = (state_and_prim_datacon, [prim_state_id, prim_result_id], the_pair)
     in
     returnDs (state_and_prim_ty,
-	      \prim_app -> CoCase prim_app (CoAlgAlts [the_alt] CoNoDefault)
+	      \prim_app -> Case prim_app (AlgAlts [the_alt] NoDefault)
     )
 
   -- Data types with a single nullary constructor
   | (maybeToBool maybe_data_type) &&				-- Data type
     (null other_data_cons) &&					-- Just one constr
     (null data_con_arg_tys)
-  = 
+  =
     newSysLocalDs realWorldStatePrimTy				`thenDs` \ prim_state_id ->
 
-    mkCoConDs stateDataCon [realWorldTy] [CoVar prim_state_id]	`thenDs` \ new_state ->
-    
-    mkCoConDs tuple_con_2
-	      [result_ty, realWorldStateTy]
-	      [covar_tuple_con_0, new_state]	`thenDs` \ the_pair ->
+    mkConDs stateDataCon [realWorldTy] [Var prim_state_id]	`thenDs` \ new_state ->
+
+    mkConDs tuple_con_2
+	    [result_ty, realWorldStateTy]
+	    [covar_tuple_con_0, new_state]	`thenDs` \ the_pair ->
 
     let
 	the_alt  = (stateDataCon, [prim_state_id], the_pair)
     in
     returnDs (realWorldStateTy,
-	      \prim_app -> CoCase prim_app (CoAlgAlts [the_alt] CoNoDefault)
+	      \prim_app -> Case prim_app (AlgAlts [the_alt] NoDefault)
     )
 
 #if 0
@@ -257,33 +263,33 @@ boxResult result_ty
   -- Data types with several nullary constructors (Enumerated types)
   | isEnumerationType result_ty &&				-- Enumeration
     (length data_cons) <= 5					-- fairly short
-  = 
+  =
     newSysLocalDs realWorldStatePrimTy				`thenDs` \ prim_state_id ->
     newSysLocalDs intPrimTy 					`thenDs` \ prim_result_id ->
 
-    mkCoConDs stateDataCon [realWorldTy] [CoVar prim_state_id]	`thenDs` \ new_state ->
+    mkConDs stateDataCon [realWorldTy] [Var prim_state_id]	`thenDs` \ new_state ->
 
     let
       alts = [ (mkMachInt i, con) | (i, con) <- [0..] `zip` data_cons ]
-      the_result = CoCase prim_result_id (CoPrimAlts alts) CoNoDefault
+      the_result = Case prim_result_id (PrimAlts alts) NoDefault
     in
 
-    mkCoConDs (mkTupleCon 2)
+    mkConDs (mkTupleCon 2)
 	      [result_ty, realWorldStateTy]
 	      [the_result, new_state]				`thenDs` \ the_pair ->
     let
 	the_alt = (state_and_prim_datacon, [prim_state_id, prim_result_id], the_pair)
     in
     returnDs (state_and_prim_ty,
-	      \prim_app -> CoCase prim_app (CoAlgAlts [the_alt] CoNoDefault)
+	      \prim_app -> Case prim_app (AlgAlts [the_alt] NoDefault)
     )
 #endif
 
-  | otherwise 
+  | otherwise
   = pprPanic "boxResult: " (ppr PprDebug result_ty)
 
   where
-    maybe_data_type 			   = getUniDataTyCon_maybe result_ty
+    maybe_data_type 			   = maybeAppDataTyCon result_ty
     Just (tycon, tycon_arg_tys, data_cons) = maybe_data_type
     (the_data_con : other_data_cons)       = data_cons
 
diff --git a/ghc/compiler/deSugar/DsExpr.hi b/ghc/compiler/deSugar/DsExpr.hi
deleted file mode 100644
index 7aaaf48090..0000000000
--- a/ghc/compiler/deSugar/DsExpr.hi
+++ /dev/null
@@ -1,15 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface DsExpr where
-import Bag(Bag)
-import CmdLineOpts(GlobalSwitch, SwitchResult)
-import CoreSyn(CoreExpr)
-import DsMonad(DsMatchContext)
-import HsExpr(Expr)
-import HsPat(TypecheckedPat)
-import Id(Id)
-import PreludePS(_PackedString)
-import SplitUniq(SplitUniqSupply)
-import SrcLoc(SrcLoc)
-import UniqFM(UniqFM)
-dsExpr :: Expr Id TypecheckedPat -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (CoreExpr Id Id, Bag DsMatchContext)
-
diff --git a/ghc/compiler/deSugar/DsExpr.lhs b/ghc/compiler/deSugar/DsExpr.lhs
index 9e444150a6..5d36347feb 100644
--- a/ghc/compiler/deSugar/DsExpr.lhs
+++ b/ghc/compiler/deSugar/DsExpr.lhs
@@ -1,5 +1,5 @@
 %
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
 %
 \section[DsExpr]{Matching expressions (Exprs)}
 
@@ -8,49 +8,45 @@
 
 module DsExpr ( dsExpr ) where
 
-IMPORT_Trace		-- ToDo: rm (debugging)
-import Pretty
-import Outputable
-
-import AbsSyn		-- the stuff being desugared
-import PlainCore	-- the output of desugaring;
-			-- importing this module also gets all the
-			-- CoreSyn utility functions
-import DsMonad		-- the monadery used in the desugarer
-
-import AbsPrel		( mkTupleTy, unitTy, nilDataCon, consDataCon,
-			  charDataCon, charTy,
-			  mkFunTy, mkBuild -- LATER: , foldrId
-#ifdef DPH
-			 ,fromDomainId, toDomainId
-#endif {- Data Parallel Haskell -}
-			)
-import PrimKind		( PrimKind(..) ) -- rather ugly import *** ToDo???
-import AbsUniType	( alpha, alpha_tv, beta, beta_tv, splitType,
-			  splitTyArgs, mkTupleTyCon, mkTyVarTy, mkForallTy,
-			  kindFromType, maybeBoxedPrimType,
-			  TyVarTemplate, TyCon, Arity(..), Class,
-			  TauType(..), UniType
-			)
-import BasicLit		( mkMachInt, BasicLit(..) )
-import CmdLineOpts	( GlobalSwitch(..), SwitchResult, switchIsOn )
-import CostCentre	( mkUserCC )
-import DsBinds		( dsBinds )
+import Ubiq
+import DsLoop		-- partly to get dsBinds, partly to chk dsExpr
+
+import HsSyn		( HsExpr(..), HsLit(..), ArithSeqInfo(..),
+			  Match, Qual, HsBinds, Stmt, PolyType )
+import TcHsSyn		( TypecheckedHsExpr(..), TypecheckedHsBinds(..) )
+import CoreSyn
+
+import DsMonad
 import DsCCall		( dsCCall )
 import DsListComp	( dsListComp )
-import DsUtils		( mkCoAppDs, mkCoConDs, mkCoPrimDs, dsExprToAtom )
-import Id
-import IdEnv
-import IdInfo
+import DsUtils		( mkAppDs, mkConDs, mkPrimDs, dsExprToAtom )
 import Match		( matchWrapper )
-import Maybes		( Maybe(..) )
-import TaggedCore	( TaggedBinder(..), unTagBinders )
-import TyVarEnv
-import Util
-
-#ifdef DPH
-import DsParZF		( dsParallelZF )
-#endif {- Data Parallel Haskell -}
+
+import CoreUnfold	( UnfoldingDetails(..), UnfoldingGuidance(..),
+			  FormSummary )
+import CoreUtils	( coreExprType, substCoreExpr, argToExpr,
+			  mkCoreIfThenElse, unTagBinders )
+import CostCentre	( mkUserCC )
+import Id		( mkTupleCon, idType, nullIdEnv, addOneToIdEnv,
+			  getIdUnfolding )
+import Literal		( mkMachInt, Literal(..) )
+import MagicUFs		( MagicUnfoldingFun )
+import PprStyle		( PprStyle(..) )
+import PprType		( GenType, GenTyVar )
+import PrelInfo		( mkTupleTy, unitTy, nilDataCon, consDataCon,
+			  charDataCon, charTy )
+import Pretty		( ppShow )
+import Type		( splitSigmaTy )
+import TyVar		( nullTyVarEnv, addOneToTyVarEnv, GenTyVar )
+import Unique		( Unique )
+import Usage		( UVar(..) )
+import Util		( panic )
+
+primRepFromType = panic "DsExpr.primRepFromType"
+maybeBoxedPrimType = panic "DsExpr.maybeBoxedPrimType"
+splitTyArgs = panic "DsExpr.splitTyArgs"
+
+mk_nil_con ty = mkCon nilDataCon [] [ty] []  -- micro utility...
 \end{code}
 
 The funny business to do with variables is that we look them up in the
@@ -64,9 +60,9 @@ around; if we get hits, we use the value accordingly.
 %************************************************************************
 
 \begin{code}
-dsExpr :: TypecheckedExpr -> DsM PlainCoreExpr
+dsExpr :: TypecheckedHsExpr -> DsM CoreExpr
 
-dsExpr (Var var) = dsApp (Var var) []
+dsExpr (HsVar var) = dsApp (HsVar var) []
 \end{code}
 
 %************************************************************************
@@ -91,98 +87,97 @@ representation decisions are delayed)...
 See also below where we look for @DictApps@ for \tr{plusInt}, etc.
 
 \begin{code}
-dsExpr (Lit (StringLit s))
+dsExpr (HsLitOut (HsString s) _)
   | _NULL_ s
-  = returnDs ( CoCon nilDataCon [charTy] [] )
+  = returnDs (mk_nil_con charTy)
 
   | _LENGTH_ s == 1
   = let
-	the_char = CoCon charDataCon [] [CoLitAtom (MachChar (_HEAD_ s))] 
-	the_nil  = CoCon nilDataCon  [charTy] []
+	the_char = mkCon charDataCon [] [] [LitArg (MachChar (_HEAD_ s))]
+	the_nil  = mk_nil_con charTy
     in
-    mkCoConDs consDataCon [charTy] [the_char, the_nil]
+    mkConDs consDataCon [charTy] [the_char, the_nil]
 
 -- "_" => build (\ c n -> c 'c' n)	-- LATER
 
 -- "str" ==> build (\ c n -> foldr charTy T c n "str")
 
 {- LATER:
-dsExpr (Lit (StringLit str)) =
-    newTyVarsDs [alpha_tv]		`thenDs` \ [new_tyvar] ->
+dsExpr (HsLitOut (HsString str) _) =
+    newTyVarsDs [alphaTyVar]		`thenDs` \ [new_tyvar] ->
     let
  	new_ty = mkTyVarTy new_tyvar
     in
-    newSysLocalsDs [ 
+    newSysLocalsDs [
 		charTy `mkFunTy` (new_ty `mkFunTy` new_ty),
 		new_ty,
-		       mkForallTy [alpha_tv]
-			       ((charTy `mkFunTy` (alpha `mkFunTy` alpha))
-			       	        `mkFunTy` (alpha `mkFunTy` alpha))
+		       mkForallTy [alphaTyVar]
+			       ((charTy `mkFunTy` (alphaTy `mkFunTy` alphaTy))
+			       	        `mkFunTy` (alphaTy `mkFunTy` alphaTy))
 		]			`thenDs` \ [c,n,g] ->
      returnDs (mkBuild charTy new_tyvar c n g (
-	foldl CoApp
-	  (CoTyApp (CoTyApp (CoVar foldrId) charTy) new_ty) *** ensure non-prim type ***
-   	  [CoVarAtom c,CoVarAtom n,CoLitAtom (NoRepStr str)]))
+	foldl App
+	  (CoTyApp (CoTyApp (Var foldrId) charTy) new_ty) *** ensure non-prim type ***
+   	  [VarArg c,VarArg n,LitArg (NoRepStr str)]))
 -}
 
 -- otherwise, leave it as a NoRepStr;
 -- the Core-to-STG pass will wrap it in an application of "unpackCStringId".
 
-dsExpr (Lit (StringLit str))
-  = returnDs (CoLit (NoRepStr str))
+dsExpr (HsLitOut (HsString str) _)
+  = returnDs (Lit (NoRepStr str))
 
-dsExpr (Lit (LitLitLit s ty))
-  = returnDs ( CoCon data_con [] [CoLitAtom (MachLitLit s kind)] )
+dsExpr (HsLitOut (HsLitLit s) ty)
+  = returnDs ( mkCon data_con [] [] [LitArg (MachLitLit s kind)] )
   where
     (data_con, kind)
       = case (maybeBoxedPrimType ty) of
 	  Nothing
 	    -> error ("ERROR: ``literal-literal'' not a single-constructor type: "++ _UNPK_ s ++"; type: "++(ppShow 80 (ppr PprDebug ty)))
 	  Just (boxing_data_con, prim_ty)
-	    -> (boxing_data_con, kindFromType prim_ty)
+	    -> (boxing_data_con, primRepFromType prim_ty)
 
-dsExpr (Lit (IntLit i))
-  = returnDs (CoLit (NoRepInteger i))
+dsExpr (HsLitOut (HsInt i) _)
+  = returnDs (Lit (NoRepInteger i))
 
-dsExpr (Lit (FracLit r))
-  = returnDs (CoLit (NoRepRational r))
+dsExpr (HsLitOut (HsFrac r) _)
+  = returnDs (Lit (NoRepRational r))
 
 -- others where we know what to do:
 
-dsExpr (Lit (IntPrimLit i))
+dsExpr (HsLitOut (HsIntPrim i) _)
   = if (i >= toInteger minInt && i <= toInteger maxInt) then
-    	returnDs (CoLit (mkMachInt i))
+    	returnDs (Lit (mkMachInt i))
     else
 	error ("ERROR: Int constant " ++ show i ++ out_of_range_msg)
 
-dsExpr (Lit (FloatPrimLit f))
-  = returnDs (CoLit (MachFloat f))
+dsExpr (HsLitOut (HsFloatPrim f) _)
+  = returnDs (Lit (MachFloat f))
     -- ToDo: range checking needed!
 
-dsExpr (Lit (DoublePrimLit d))
-  = returnDs (CoLit (MachDouble d))
+dsExpr (HsLitOut (HsDoublePrim d) _)
+  = returnDs (Lit (MachDouble d))
     -- ToDo: range checking needed!
 
-dsExpr (Lit (CharLit c))
-  = returnDs ( CoCon charDataCon [] [CoLitAtom (MachChar c)] )
+dsExpr (HsLitOut (HsChar c) _)
+  = returnDs ( mkCon charDataCon [] [] [LitArg (MachChar c)] )
 
-dsExpr (Lit (CharPrimLit c))
-  = returnDs (CoLit (MachChar c))
+dsExpr (HsLitOut (HsCharPrim c) _)
+  = returnDs (Lit (MachChar c))
 
-dsExpr (Lit (StringPrimLit s))
-  = returnDs (CoLit (MachStr s))
+dsExpr (HsLitOut (HsStringPrim s) _)
+  = returnDs (Lit (MachStr s))
 
 -- end of literals magic. --
 
-dsExpr expr@(Lam a_Match)
+dsExpr expr@(HsLam a_Match)
   = let
 	error_msg = "%L" --> "pattern-matching failed in lambda"
     in
     matchWrapper LambdaMatch [a_Match] error_msg `thenDs` \ (binders, matching_code) ->
-    returnDs ( mkCoLam binders matching_code )
-
-dsExpr expr@(App e1 e2) = dsApp expr []
+    returnDs ( mkValLam binders matching_code )
 
+dsExpr expr@(HsApp e1 e2)    = dsApp expr []
 dsExpr expr@(OpApp e1 op e2) = dsApp expr []
 \end{code}
 
@@ -190,7 +185,7 @@ Operator sections.  At first it looks as if we can convert
 \begin{verbatim}
 	(expr op)
 \end{verbatim}
-to 
+to
 \begin{verbatim}
 	\x -> op expr x
 \end{verbatim}
@@ -211,140 +206,121 @@ will sort it out.
 dsExpr (SectionL expr op)
   = dsExpr op			`thenDs` \ core_op ->
     dsExpr expr			`thenDs` \ core_expr ->
-    dsExprToAtom core_expr	( \ y_atom ->
+    dsExprToAtom core_expr	$ \ y_atom ->
 
     -- for the type of x, we need the type of op's 2nd argument
     let
-	x_ty  =	case (splitType (typeOfCoreExpr core_op)) of { (_, _, tau_ty) ->
+	x_ty  =	case (splitSigmaTy (coreExprType core_op)) of { (_, _, tau_ty) ->
 		case (splitTyArgs tau_ty)		  of {
 		  ((_:arg2_ty:_), _) -> arg2_ty;
-		  _ -> panic "dsExpr:SectionL:arg 2 ty"--++(ppShow 80 (ppAboves [ppr PprDebug (typeOfCoreExpr core_op), ppr PprDebug tau_ty]))
+		  _ -> panic "dsExpr:SectionL:arg 2 ty"
 		}}
     in
     newSysLocalDs x_ty		`thenDs` \ x_id ->
-    returnDs ( mkCoLam [x_id] (CoApp (CoApp core_op y_atom) (CoVarAtom x_id)) ))
+    returnDs (mkValLam [x_id] (core_op `App` y_atom `App` VarArg x_id)) 
 
 -- dsExpr (SectionR op expr)	-- \ x -> op x expr
 dsExpr (SectionR op expr)
   = dsExpr op			`thenDs` \ core_op ->
     dsExpr expr			`thenDs` \ core_expr ->
-    dsExprToAtom core_expr	(\ y_atom ->
+    dsExprToAtom core_expr	$ \ y_atom ->
 
     -- for the type of x, we need the type of op's 1st argument
     let
-	x_ty  =	case (splitType (typeOfCoreExpr core_op)) of { (_, _, tau_ty) ->
+	x_ty  =	case (splitSigmaTy (coreExprType core_op)) of { (_, _, tau_ty) ->
 		case (splitTyArgs tau_ty)		  of {
 		  ((arg1_ty:_), _) -> arg1_ty;
-		  _ -> panic "dsExpr:SectionR:arg 1 ty"--++(ppShow 80 (ppAboves [ppr PprDebug (typeOfCoreExpr core_op), ppr PprDebug tau_ty]))
+		  _ -> panic "dsExpr:SectionR:arg 1 ty"
 		}}
     in
     newSysLocalDs x_ty		`thenDs` \ x_id ->
-    returnDs ( mkCoLam [x_id] (CoApp (CoApp core_op (CoVarAtom x_id)) y_atom) ))
+    returnDs (mkValLam [x_id] (core_op `App` VarArg x_id `App` y_atom))
 
 dsExpr (CCall label args may_gc is_asm result_ty)
   = mapDs dsExpr args		`thenDs` \ core_args ->
     dsCCall label core_args may_gc is_asm result_ty
 	-- dsCCall does all the unboxification, etc.
 
-dsExpr (SCC cc expr)
+dsExpr (HsSCC cc expr)
   = dsExpr expr			`thenDs` \ core_expr ->
     getModuleAndGroupDs		`thenDs` \ (mod_name, group_name) ->
-    returnDs ( CoSCC (mkUserCC cc mod_name group_name) core_expr)
+    returnDs ( SCC (mkUserCC cc mod_name group_name) core_expr)
 
-dsExpr expr@(Case discrim matches)
-  = dsExpr discrim		   `thenDs` \ core_discrim ->
+dsExpr expr@(HsCase discrim matches src_loc)
+  = putSrcLocDs src_loc $
+    dsExpr discrim		`thenDs` \ core_discrim ->
     let
 	error_msg = "%C" --> "pattern-matching failed in case"
     in
     matchWrapper CaseMatch matches error_msg `thenDs` \ ([discrim_var], matching_code) ->
-    returnDs ( mkCoLetAny (CoNonRec discrim_var core_discrim) matching_code )
+    returnDs ( mkCoLetAny (NonRec discrim_var core_discrim) matching_code )
 
 dsExpr (ListComp expr quals)
   = dsExpr expr `thenDs` \ core_expr ->
     dsListComp core_expr quals
 
-dsExpr (Let binds expr)
+dsExpr (HsLet binds expr)
   = dsBinds binds	`thenDs` \ core_binds ->
     dsExpr expr		`thenDs` \ core_expr ->
     returnDs ( mkCoLetsAny core_binds core_expr )
 
-dsExpr (ExplicitList _)	= panic "dsExpr:ExplicitList -- not translated"
+dsExpr (HsDoOut stmts m_id mz_id src_loc)
+  = putSrcLocDs src_loc $
+    panic "dsExpr:HsDoOut"
 
 dsExpr (ExplicitListOut ty xs)
   = case xs of
-      []     -> returnDs ( CoCon nilDataCon [ty] [] )
+      []     -> returnDs (mk_nil_con ty)
       (y:ys) ->
 	dsExpr y			    `thenDs` \ core_hd  ->
 	dsExpr (ExplicitListOut ty ys)  `thenDs` \ core_tl  ->
-	mkCoConDs consDataCon [ty] [core_hd, core_tl]
+	mkConDs consDataCon [ty] [core_hd, core_tl]
 
 dsExpr (ExplicitTuple expr_list)
   = mapDs dsExpr expr_list	  `thenDs` \ core_exprs  ->
-    mkCoConDs (mkTupleCon (length expr_list))
-	      (map typeOfCoreExpr core_exprs)
-	      core_exprs
+    mkConDs (mkTupleCon (length expr_list))
+	    (map coreExprType core_exprs)
+	    core_exprs
 
-dsExpr (ExprWithTySig expr sig) = panic "dsExpr: ExprWithTySig"
+dsExpr (RecordCon con  rbinds) = panic "dsExpr:RecordCon"
+dsExpr (RecordUpd aexp rbinds) = panic "dsExpr:RecordUpd"
 
-dsExpr (If guard_expr then_expr else_expr)
-  = dsExpr guard_expr	`thenDs` \ core_guard ->
+dsExpr (HsIf guard_expr then_expr else_expr src_loc)
+  = putSrcLocDs src_loc $
+    dsExpr guard_expr	`thenDs` \ core_guard ->
     dsExpr then_expr	`thenDs` \ core_then ->
     dsExpr else_expr	`thenDs` \ core_else ->
     returnDs (mkCoreIfThenElse core_guard core_then core_else)
 
-dsExpr (ArithSeqIn info) = panic "dsExpr.ArithSeqIn"
-
 dsExpr (ArithSeqOut expr (From from))
   = dsExpr expr		  `thenDs` \ expr2 ->
     dsExpr from		  `thenDs` \ from2 ->
-    mkCoAppDs expr2 from2
+    mkAppDs expr2 [] [from2]
 
 dsExpr (ArithSeqOut expr (FromTo from two))
   = dsExpr expr		  `thenDs` \ expr2 ->
     dsExpr from		  `thenDs` \ from2 ->
     dsExpr two		  `thenDs` \ two2 ->
-    mkCoAppDs expr2 from2 `thenDs` \ app1 ->
-    mkCoAppDs app1  two2
+    mkAppDs expr2 [] [from2, two2]
 
 dsExpr (ArithSeqOut expr (FromThen from thn))
   = dsExpr expr		  `thenDs` \ expr2 ->
     dsExpr from		  `thenDs` \ from2 ->
     dsExpr thn		  `thenDs` \ thn2 ->
-    mkCoAppDs expr2 from2 `thenDs` \ app1 ->
-    mkCoAppDs app1  thn2
+    mkAppDs expr2 [] [from2, thn2]
 
 dsExpr (ArithSeqOut expr (FromThenTo from thn two))
   = dsExpr expr		  `thenDs` \ expr2 ->
     dsExpr from		  `thenDs` \ from2 ->
     dsExpr thn		  `thenDs` \ thn2 ->
     dsExpr two		  `thenDs` \ two2 ->
-    mkCoAppDs expr2 from2 `thenDs` \ app1 ->
-    mkCoAppDs app1  thn2  `thenDs` \ app2 ->
-    mkCoAppDs app2  two2
-
-#ifdef DPH
-dsExpr (ParallelZF expr quals)
-  = dsParallelZF expr  quals
-
-dsExpr (ExplicitPodIn _) 
-  = panic "dsExpr:ExplicitPodIn -- not translated"
-
-dsExpr (ExplicitPodOut _ _)
-  = panic "dsExpr:ExplicitPodOut should remove this."
-
-dsExpr (ExplicitProcessor exprs expr)
-  = mapDs dsExpr exprs		`thenDs` \ core_exprs	->
-    dsExpr expr			`thenDs` \ core_expr ->
-    mkCoConDs (mkProcessorCon (length exprs))
-	      ((map typeOfCoreExpr core_exprs)++[typeOfCoreExpr core_expr])
-	      (core_exprs++[core_expr])
-#endif {- Data Parallel Haskell -}
+    mkAppDs expr2 [] [from2, thn2, two2]
 \end{code}
 
 \begin{code}
 dsExpr (TyLam tyvars expr)
   = dsExpr expr `thenDs` \ core_expr ->
-    returnDs( foldr CoTyLam core_expr tyvars)
+    returnDs (mkTyLam tyvars core_expr)
 
 dsExpr expr@(TyApp e tys) = dsApp expr []
 \end{code}
@@ -355,7 +331,7 @@ complicated; reminiscent of fully-applied constructors.
 \begin{code}
 dsExpr (DictLam dictvars expr)
   = dsExpr expr `thenDs` \ core_expr ->
-    returnDs( mkCoLam dictvars core_expr )
+    returnDs( mkValLam dictvars core_expr )
 
 ------------------
 
@@ -371,7 +347,7 @@ of length 0 or 1.
 \end{verbatim}
 \begin{code}
 dsExpr (SingleDict dict)	-- just a local
-  = lookupEnvWithDefaultDs dict (CoVar dict)
+  = lookupEnvWithDefaultDs dict (Var dict)
 
 dsExpr (Dictionary dicts methods)
   = -- hey, these things may have been substituted away...
@@ -385,41 +361,48 @@ dsExpr (Dictionary dicts methods)
       1 -> returnDs (head core_d_and_ms) -- just a single Id
 
       _ ->	    -- tuple 'em up
-	   mkCoConDs (mkTupleCon num_of_d_and_ms)
-		     (map typeOfCoreExpr core_d_and_ms)
-		     core_d_and_ms 
+	   mkConDs (mkTupleCon num_of_d_and_ms)
+		   (map coreExprType core_d_and_ms)
+		   core_d_and_ms
     )
   where
     dicts_and_methods	    = dicts ++ methods
-    dicts_and_methods_exprs = map CoVar dicts_and_methods
+    dicts_and_methods_exprs = map Var dicts_and_methods
     num_of_d_and_ms	    = length dicts_and_methods
 
 dsExpr (ClassDictLam dicts methods expr)
   = dsExpr expr		`thenDs` \ core_expr ->
     case num_of_d_and_ms of
 	0 -> newSysLocalDs unitTy `thenDs` \ new_x ->
-	     returnDs (CoLam [new_x] core_expr)
+	     returnDs (mkValLam [new_x] core_expr)
 
 	1 -> -- no untupling
-	    returnDs (CoLam dicts_and_methods core_expr)
+	    returnDs (mkValLam dicts_and_methods core_expr)
 
 	_ ->				-- untuple it
 	    newSysLocalDs tuple_ty `thenDs` \ new_x ->
 	    returnDs (
-	      CoLam [new_x]
-		(CoCase (CoVar new_x)
-		    (CoAlgAlts
+	      Lam (ValBinder new_x)
+		(Case (Var new_x)
+		    (AlgAlts
 			[(tuple_con, dicts_and_methods, core_expr)]
-			CoNoDefault)))
+			NoDefault)))
   where
+    num_of_d_and_ms	    = length dicts + length methods
     dicts_and_methods	    = dicts ++ methods
-    num_of_d_and_ms	    = length dicts_and_methods
-    tuple_ty		    = mkTupleTy num_of_d_and_ms (map getIdUniType dicts_and_methods)
-    tuple_tycon		    = mkTupleTyCon num_of_d_and_ms
+    tuple_ty		    = mkTupleTy    num_of_d_and_ms (map idType dicts_and_methods)
     tuple_con		    = mkTupleCon   num_of_d_and_ms
 
-cocon_unit = CoCon (mkTupleCon 0) [] [] -- out here to avoid CAF (sigh)
-out_of_range_msg			-- ditto
+#ifdef DEBUG
+-- HsSyn constructs that just shouldn't be here:
+dsExpr (HsDo _ _)	    = panic "dsExpr:HsDo"
+dsExpr (ExplicitList _)	    = panic "dsExpr:ExplicitList"
+dsExpr (ExprWithTySig _ _)  = panic "dsExpr:ExprWithTySig"
+dsExpr (ArithSeqIn _)	    = panic "dsExpr:ArithSeqIn"
+#endif
+
+cocon_unit = mkCon (mkTupleCon 0) [] [] [] -- out here to avoid CAF (sigh)
+out_of_range_msg			   -- ditto
   = " out of range: [" ++ show minInt ++ ", " ++ show maxInt ++ "]\n"
 \end{code}
 
@@ -435,79 +418,77 @@ We're doing all this so we can saturate constructors (as painlessly as
 possible).
 
 \begin{code}
-data DsCoreArg
-  = DsTypeArg UniType
-  | DsValArg  PlainCoreExpr
+type DsCoreArg = GenCoreArg CoreExpr{-NB!-} TyVar UVar
 
-dsApp :: TypecheckedExpr	-- expr to desugar
+dsApp :: TypecheckedHsExpr	-- expr to desugar
       -> [DsCoreArg]		-- accumulated ty/val args: NB:
-      -> DsM PlainCoreExpr	-- final result
+      -> DsM CoreExpr	-- final result
 
-dsApp (App e1 e2) args
+dsApp (HsApp e1 e2) args
   = dsExpr e2			`thenDs` \ core_e2 ->
-    dsApp  e1 (DsValArg core_e2 : args)
+    dsApp  e1 (VarArg core_e2 : args)
 
 dsApp (OpApp e1 op e2) args
   = dsExpr e1			`thenDs` \ core_e1 ->
     dsExpr e2			`thenDs` \ core_e2 ->
-    dsApp  op (DsValArg core_e1 : DsValArg core_e2 : args)
+    dsApp  op (VarArg core_e1 : VarArg core_e2 : args)
 
 dsApp (DictApp expr dicts) args
   =	-- now, those dicts may have been substituted away...
-    zipWithDs lookupEnvWithDefaultDs dicts (map CoVar dicts)
+    zipWithDs lookupEnvWithDefaultDs dicts (map Var dicts)
 				`thenDs` \ core_dicts ->
-    dsApp expr (map DsValArg core_dicts ++ args)
+    dsApp expr (map VarArg core_dicts ++ args)
 
 dsApp (TyApp expr tys) args
-  = dsApp expr (map DsTypeArg tys ++ args)
+  = dsApp expr (map TyArg tys ++ args)
 
 -- we might should look out for SectionLs, etc., here, but we don't
 
-dsApp (Var v) args
+dsApp (HsVar v) args
   = lookupEnvDs v	`thenDs` \ maybe_expr ->
     case maybe_expr of
       Just expr -> apply_to_args expr args
 
       Nothing -> -- we're only saturating constructors and PrimOps
 	case getIdUnfolding v of
-	  GeneralForm _ _ the_unfolding EssentialUnfolding 
+	  GenForm _ _ the_unfolding EssentialUnfolding
 	    -> do_unfold nullTyVarEnv nullIdEnv (unTagBinders the_unfolding) args
 
-	  _ -> apply_to_args (CoVar v) args
+	  _ -> apply_to_args (Var v) args
 
 
 dsApp anything_else args
   = dsExpr anything_else	`thenDs` \ core_expr ->
     apply_to_args core_expr args
 
--- a DsM version of applyToArgs:
-apply_to_args :: PlainCoreExpr -> [DsCoreArg] -> DsM PlainCoreExpr
-
-apply_to_args fun [] = returnDs fun
-
-apply_to_args fun (DsValArg expr : args)
-  = mkCoAppDs fun expr	`thenDs` \ fun2 ->
-    apply_to_args fun2 args
+-- a DsM version of mkGenApp:
+apply_to_args :: CoreExpr -> [DsCoreArg] -> DsM CoreExpr
 
-apply_to_args fun (DsTypeArg ty : args)
-  = apply_to_args (mkCoTyApp fun ty) args
+apply_to_args fun args
+  = let
+	(ty_args, val_args) = foldr sep ([],[]) args
+    in
+    mkAppDs fun ty_args val_args
+  where
+    sep a@(LitArg l)   (tys,vals) = (tys,    (Lit l):vals)
+    sep a@(VarArg e)   (tys,vals) = (tys,    e:vals)
+    sep a@(TyArg ty)   (tys,vals) = (ty:tys, vals)
+    sep a@(UsageArg _) _	  = panic "DsExpr:apply_to_args:UsageArg"
 \end{code}
 
 \begin{code}
-do_unfold ty_env val_env (CoTyLam tyvar body) (DsTypeArg ty : args)
+do_unfold ty_env val_env (Lam (TyBinder tyvar) body) (TyArg ty : args)
   = do_unfold (addOneToTyVarEnv ty_env tyvar ty) val_env body args
 
-do_unfold ty_env val_env (CoLam [] body) args
-  = do_unfold ty_env val_env body args
-
-do_unfold ty_env val_env (CoLam (binder:binders) body) (DsValArg expr : args)
-  = dsExprToAtom expr (\ arg_atom ->
-	    do_unfold ty_env (addOneToIdEnv val_env binder (atomToExpr arg_atom)) (CoLam binders body) args
-    )
+do_unfold ty_env val_env (Lam (ValBinder binder) body) (VarArg expr : args)
+  = dsExprToAtom expr  $ \ arg_atom ->
+    do_unfold ty_env
+	      (addOneToIdEnv val_env binder (argToExpr arg_atom))
+	      body args
 
 do_unfold ty_env val_env body args
   = 	-- Clone the remaining part of the template
-    uniqSMtoDsM (substCoreExprUS val_env ty_env body)	`thenDs` \ body' ->
+    uniqSMtoDsM (substCoreExpr val_env ty_env body)	`thenDs` \ body' ->
 
 	-- Apply result to remaining arguments
     apply_to_args body' args
diff --git a/ghc/compiler/deSugar/DsGRHSs.hi b/ghc/compiler/deSugar/DsGRHSs.hi
deleted file mode 100644
index ec2f74920a..0000000000
--- a/ghc/compiler/deSugar/DsGRHSs.hi
+++ /dev/null
@@ -1,18 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface DsGRHSs where
-import Bag(Bag)
-import CmdLineOpts(GlobalSwitch, SwitchResult)
-import CoreSyn(CoreExpr)
-import DsMonad(DsMatchContext, DsMatchKind)
-import DsUtils(MatchResult)
-import HsMatches(GRHS, GRHSsAndBinds)
-import HsPat(TypecheckedPat)
-import Id(Id)
-import PreludePS(_PackedString)
-import SplitUniq(SplitUniqSupply)
-import SrcLoc(SrcLoc)
-import UniType(UniType)
-import UniqFM(UniqFM)
-dsGRHSs :: UniType -> DsMatchKind -> [TypecheckedPat] -> [GRHS Id TypecheckedPat] -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (MatchResult, Bag DsMatchContext)
-dsGuarded :: GRHSsAndBinds Id TypecheckedPat -> SrcLoc -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (CoreExpr Id Id, Bag DsMatchContext)
-
diff --git a/ghc/compiler/deSugar/DsGRHSs.lhs b/ghc/compiler/deSugar/DsGRHSs.lhs
index fde76e6e62..5287b22ff9 100644
--- a/ghc/compiler/deSugar/DsGRHSs.lhs
+++ b/ghc/compiler/deSugar/DsGRHSs.lhs
@@ -8,21 +8,28 @@
 
 module DsGRHSs ( dsGuarded, dsGRHSs ) where
 
+import Ubiq
+import DsLoop		-- break dsExpr/dsBinds-ish loop
 
-import AbsSyn		-- the stuff being desugared
-import PlainCore	-- the output of desugaring;
-			-- importing this module also gets all the
-			-- CoreSyn utility functions
-import DsMonad		-- the monadery used in the desugarer
-
-import AbsPrel		( stringTy
-			  IF_ATTACK_PRAGMAS(COMMA mkListTy COMMA charTy)
-			)
-import DsBinds		( dsBinds )
-import DsExpr		( dsExpr )
+import HsSyn		( GRHSsAndBinds(..), GRHS(..),
+			  HsExpr, HsBinds )
+import TcHsSyn		( TypecheckedGRHSsAndBinds(..), TypecheckedGRHS(..),
+			  TypecheckedPat(..), TypecheckedHsBinds(..),
+			  TypecheckedHsExpr(..)	)
+import CoreSyn		( CoreBinding(..), CoreExpr(..) )
+
+import DsMonad
 import DsUtils
-import Pretty
-import Util
+
+import CoreUtils	( escErrorMsg, mkErrorApp )
+import PrelInfo		( stringTy )
+import PprStyle		( PprStyle(..) )
+import Pretty		( ppShow )
+import SrcLoc		( SrcLoc{-instance-} )
+import Util		( panic )
+
+mkCoLetsAny = panic "DsGRHSs.mkCoLetsAny"
+mkCoreIfThenElse = panic "DsGRHSs.mkCoreIfThenElse"
 \end{code}
 
 @dsGuarded@ is used for both @case@ expressions and pattern bindings.
@@ -39,7 +46,7 @@ necessary.  The type argument gives the type of the ei.
 \begin{code}
 dsGuarded :: TypecheckedGRHSsAndBinds
 	  -> SrcLoc
-	  -> DsM PlainCoreExpr
+	  -> DsM CoreExpr
 
 dsGuarded (GRHSsAndBindsOut grhss binds err_ty) err_loc
   = dsBinds binds				`thenDs` \ core_binds ->
@@ -51,8 +58,8 @@ dsGuarded (GRHSsAndBindsOut grhss binds err_ty) err_loc
   where
     unencoded_part_of_msg = escErrorMsg (ppShow 80 (ppr PprForUser err_loc))
 
-    error_expr :: Id -> PlainCoreExpr
-    error_expr str_var = mkErrorCoApp err_ty str_var
+    error_expr :: Id -> CoreExpr
+    error_expr str_var = mkErrorApp err_ty str_var
 			  (unencoded_part_of_msg
 			  ++ "%N") --> ": non-exhaustive guards"
 \end{code}
@@ -65,11 +72,11 @@ p | g1 = e1
   ...
   | gm = em
 \end{verbatim}
-We supply a @PlainCoreExpr@ for the case in which all of
+We supply a @CoreExpr@ for the case in which all of
 the guards fail.
 
 \begin{code}
-dsGRHSs :: UniType				-- Type of RHSs
+dsGRHSs :: Type				-- Type of RHSs
 	-> DsMatchKind -> [TypecheckedPat]	-- These are to build a MatchContext from
 	-> [TypecheckedGRHS]			-- Guarded RHSs
 	-> DsM MatchResult
diff --git a/ghc/compiler/deSugar/DsHsSyn.lhs b/ghc/compiler/deSugar/DsHsSyn.lhs
new file mode 100644
index 0000000000..91601a112b
--- /dev/null
+++ b/ghc/compiler/deSugar/DsHsSyn.lhs
@@ -0,0 +1,75 @@
+%
+% (c) The AQUA Project, Glasgow University, 1996
+%
+\section[DsHsSyn]{Haskell abstract syntax---added things for desugarer}
+
+\begin{code}
+#include "HsVersions.h"
+
+module DsHsSyn where
+
+import Ubiq
+
+import HsSyn		( OutPat(..), HsBinds(..), Bind(..), MonoBinds(..),
+			  Sig, HsExpr, GRHSsAndBinds, Match, HsLit )
+import TcHsSyn		( TypecheckedPat(..), TypecheckedBind(..), 
+			  TypecheckedMonoBinds(..) )
+
+import Id		( idType )
+import PrelInfo		( mkListTy, mkTupleTy, unitTy )
+import Util		( panic )
+\end{code}
+
+Note: If @outPatType@ doesn't bear a strong resemblance to @coreExprType@,
+then something is wrong.
+\begin{code}
+outPatType :: TypecheckedPat -> Type
+
+outPatType (WildPat ty)		= ty
+outPatType (VarPat var)		= idType var
+outPatType (LazyPat pat)	= outPatType pat
+outPatType (AsPat var pat)	= idType var
+outPatType (ConPat _ ty _)	= ty
+outPatType (ConOpPat _ _ _ ty)	= ty
+outPatType (ListPat ty _)	= mkListTy ty
+outPatType (TuplePat pats)	= mkTupleTy (length pats) (map outPatType pats)
+outPatType (LitPat lit ty)	= ty
+outPatType (NPat lit ty _)	= ty
+outPatType (DictPat ds ms)      = case (length ds + length ms) of
+				    0 -> unitTy
+				    1 -> idType (head (ds ++ ms))
+				    n -> mkTupleTy n (map idType (ds ++ ms))
+\end{code}
+
+
+Nota bene: DsBinds relies on the fact that at least for simple
+tuple patterns @collectTypedPatBinders@ returns the binders in
+the same order as they appear in the tuple.
+
+collectTypedBinders and collectedTypedPatBinders are the exportees.
+
+\begin{code}
+collectTypedBinders :: TypecheckedBind -> [Id]
+collectTypedBinders EmptyBind	    = []
+collectTypedBinders (NonRecBind bs) = collectTypedMonoBinders bs
+collectTypedBinders (RecBind    bs) = collectTypedMonoBinders bs
+
+collectTypedMonoBinders :: TypecheckedMonoBinds -> [Id]
+collectTypedMonoBinders EmptyMonoBinds	      = []
+collectTypedMonoBinders (PatMonoBind pat _ _) = collectTypedPatBinders pat
+collectTypedMonoBinders (FunMonoBind f _ _)   = [f]
+collectTypedMonoBinders (VarMonoBind v _)     = [v]
+collectTypedMonoBinders (AndMonoBinds bs1 bs2)
+ = collectTypedMonoBinders bs1 ++ collectTypedMonoBinders bs2
+
+collectTypedPatBinders :: TypecheckedPat -> [Id]
+collectTypedPatBinders (VarPat var)	    = [var]
+collectTypedPatBinders (LazyPat pat)	    = collectTypedPatBinders pat
+collectTypedPatBinders (AsPat a pat)	    = a : collectTypedPatBinders pat
+collectTypedPatBinders (ConPat _ _ pats)    = concat (map collectTypedPatBinders pats)
+collectTypedPatBinders (ConOpPat p1 _ p2 _) = collectTypedPatBinders p1 ++ collectTypedPatBinders p2
+collectTypedPatBinders (ListPat t pats)     = concat (map collectTypedPatBinders pats)
+collectTypedPatBinders (TuplePat pats)	    = concat (map collectTypedPatBinders pats)
+collectTypedPatBinders (DictPat ds ms)	    = ds ++ ms
+collectTypedPatBinders any_other_pat	    = [ {-no binders-} ]
+\end{code}
diff --git a/ghc/compiler/deSugar/DsListComp.hi b/ghc/compiler/deSugar/DsListComp.hi
deleted file mode 100644
index a682df8153..0000000000
--- a/ghc/compiler/deSugar/DsListComp.hi
+++ /dev/null
@@ -1,15 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface DsListComp where
-import Bag(Bag)
-import CmdLineOpts(GlobalSwitch, SwitchResult)
-import CoreSyn(CoreExpr)
-import DsMonad(DsMatchContext)
-import HsExpr(Qual)
-import HsPat(TypecheckedPat)
-import Id(Id)
-import PreludePS(_PackedString)
-import SplitUniq(SplitUniqSupply)
-import SrcLoc(SrcLoc)
-import UniqFM(UniqFM)
-dsListComp :: CoreExpr Id Id -> [Qual Id TypecheckedPat] -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (CoreExpr Id Id, Bag DsMatchContext)
-
diff --git a/ghc/compiler/deSugar/DsListComp.lhs b/ghc/compiler/deSugar/DsListComp.lhs
index 51748b6135..39b00d4a2c 100644
--- a/ghc/compiler/deSugar/DsListComp.lhs
+++ b/ghc/compiler/deSugar/DsListComp.lhs
@@ -1,29 +1,31 @@
 %
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
 %
 \section[DsListComp]{Desugaring list comprehensions}
 
 \begin{code}
 module DsListComp ( dsListComp ) where
 
+import Ubiq
+import DsLoop		-- break dsExpr-ish loop
 
-import AbsSyn		-- the stuff being desugared
-import PlainCore	-- the output of desugaring;
-			-- importing this module also gets all the
-			-- CoreSyn utility functions
-import DsMonad		-- the monadery used in the desugarer
+import HsSyn		( Qual(..), HsExpr, HsBinds )
+import TcHsSyn		( TypecheckedQual(..), TypecheckedHsExpr(..) )
+import DsHsSyn		( outPatType )
+import CoreSyn
 
-import AbsPrel		( mkFunTy, nilDataCon, consDataCon, listTyCon,
-			  mkBuild, mkFoldr
-			)
-import AbsUniType	( alpha_tv, alpha, mkTyVarTy, mkForallTy )
-import CmdLineOpts	( GlobalSwitch(..) )
-import DsExpr		( dsExpr )
+import DsMonad		-- the monadery used in the desugarer
 import DsUtils
-import Id		( getIdInfo, replaceIdInfo )
-import IdInfo
+
+import CmdLineOpts	( opt_FoldrBuildOn )
+import CoreUtils	( coreExprType, mkCoreIfThenElse )
+import PrelInfo		( nilDataCon, consDataCon, listTyCon,
+			  mkBuild, foldrId )
+import Type		( mkTyVarTy, mkForAllTy, mkFunTys )
+import TysPrim		( alphaTy )
+import TyVar		( alphaTyVar )
 import Match		( matchSimply )
-import Util
+import Util		( panic )
 \end{code}
 
 List comprehensions may be desugared in one of two ways: ``ordinary''
@@ -33,37 +35,38 @@ turned on'' (if you read Gill {\em et al.}'s paper on the subject).
 There will be at least one ``qualifier'' in the input.
 
 \begin{code}
-dsListComp :: PlainCoreExpr -> [TypecheckedQual] -> DsM PlainCoreExpr
+dsListComp :: CoreExpr -> [TypecheckedQual] -> DsM CoreExpr
 
 dsListComp expr quals
-  = let  expr_ty    = typeOfCoreExpr expr
+  = let
+	expr_ty = coreExprType expr
     in
-    ifSwitchSetDs FoldrBuildOn (
+    if not opt_FoldrBuildOn then -- be boring
+	deListComp expr quals (nIL_EXPR expr_ty)
+
+    else -- foldr/build lives!
 	new_alpha_tyvar		    `thenDs` \ (n_tyvar, n_ty) ->
 	let
-	    c_ty = expr_ty `mkFunTy` (n_ty `mkFunTy` n_ty)
-	    g_ty = mkForallTy [alpha_tv] (
-			(expr_ty `mkFunTy` (alpha `mkFunTy` alpha))
-				 `mkFunTy` (alpha `mkFunTy` alpha))
+	    alpha_to_alpha = mkFunTys [alphaTy] alphaTy
+
+	    c_ty = mkFunTys [expr_ty, n_ty] n_ty
+	    g_ty = mkForAllTy alphaTyVar (
+			(mkFunTys [expr_ty, alpha_to_alpha] alpha_to_alpha))
 	in
-	newSysLocalsDs [c_ty,n_ty,g_ty]  `thenDs` \ [c, n, g] -> 
+	newSysLocalsDs [c_ty,n_ty,g_ty]  `thenDs` \ [c, n, g] ->
 
 	dfListComp expr expr_ty
-			c_ty c 
+			c_ty c
 			n_ty n
 			quals	    `thenDs` \ result ->
 
 	returnDs (mkBuild expr_ty n_tyvar c n g result)
-
-    ) {-else be boring-} (
-	deListComp expr quals (nIL_EXPR expr_ty)
-    )
   where
-    nIL_EXPR ty = CoCon nilDataCon [ty] []
+    nIL_EXPR ty = mkCon nilDataCon [] [ty] []
 
-    new_alpha_tyvar :: DsM (TyVar, UniType)
+    new_alpha_tyvar :: DsM (TyVar, Type)
     new_alpha_tyvar
-      = newTyVarsDs [alpha_tv]	`thenDs` \ [new_ty] ->
+      = newTyVarsDs [alphaTyVar]    `thenDs` \ [new_ty] ->
 	returnDs (new_ty,mkTyVarTy new_ty)
 \end{code}
 
@@ -111,26 +114,29 @@ is the TE translation scheme.  Note that we carry around the @L@ list
 already desugared.  @dsListComp@ does the top TE rule mentioned above.
 
 \begin{code}
-deListComp :: PlainCoreExpr -> [TypecheckedQual] -> PlainCoreExpr -> DsM PlainCoreExpr
+deListComp :: CoreExpr -> [TypecheckedQual] -> CoreExpr -> DsM CoreExpr
 
 deListComp expr [] list		-- Figure 7.4, SLPJ, p 135, rule C above
-  = mkCoConDs consDataCon [typeOfCoreExpr expr] [expr, list]
+  = mkConDs consDataCon [coreExprType expr] [expr, list]
 
-deListComp expr ((FilterQual filt): quals) list	-- rule B above
+deListComp expr (FilterQual filt : quals) list	-- rule B above
   = dsExpr filt                `thenDs` \ core_filt ->
     deListComp expr quals list `thenDs` \ core_rest ->
     returnDs ( mkCoreIfThenElse core_filt core_rest list )
 
+deListComp expr (LetQual binds : quals) list
+  = panic "deListComp:LetQual"
+
 deListComp expr ((GeneratorQual pat list1):quals) core_list2 -- rule A' above
   = dsExpr list1		    `thenDs` \ core_list1 ->
     let
-	u3_ty@u1_ty = typeOfCoreExpr core_list1	-- two names, same thing
+	u3_ty@u1_ty = coreExprType core_list1	-- two names, same thing
 
 	-- u1_ty is a [alpha] type, and u2_ty = alpha
-	u2_ty = typeOfPat pat
-	
-        res_ty = typeOfCoreExpr core_list2
-	h_ty = mkFunTy u1_ty res_ty
+	u2_ty = outPatType pat
+
+	res_ty = coreExprType core_list2
+	h_ty = mkFunTys [u1_ty] res_ty
     in
     newSysLocalsDs [h_ty, u1_ty, u2_ty, u3_ty]
 				    `thenDs` \ [h', u1, u2, u3] ->
@@ -139,30 +145,30 @@ deListComp expr ((GeneratorQual pat list1):quals) core_list2 -- rule A' above
        Since it only occurs once in the body, we can't get
        an increase in code size by unfolding it.
     -}
---  getSwitchCheckerDs		    `thenDs` \ sw_chkr ->
     let
 	h = if False -- LATER: sw_chkr DoDeforest???
-	    then replaceIdInfo h' (addInfo (getIdInfo h') DoDeforest)
+	    then panic "deListComp:deforest"
+		 -- replaceIdInfo h' (addInfo (getIdInfo h') DoDeforest)
 	    else h'
     in
     -- the "fail" value ...
-    mkCoAppDs (CoVar h) (CoVar u3)  `thenDs` \ core_fail ->
+    mkAppDs (Var h) [] [Var u3]  `thenDs` \ core_fail ->
 
     deListComp expr quals core_fail `thenDs` \ rest_expr ->
 
-    matchSimply (CoVar u2) pat res_ty rest_expr core_fail `thenDs` \ core_match ->
+    matchSimply (Var u2) pat res_ty rest_expr core_fail `thenDs` \ core_match ->
 
-    mkCoAppDs (CoVar h) core_list1  `thenDs` \ letrec_body ->
+    mkAppDs (Var h) [] [core_list1]  `thenDs` \ letrec_body ->
 
     returnDs (
       mkCoLetrecAny [
       ( h,
-	(CoLam [ u1 ]
-	 (CoCase (CoVar u1)
-	    (CoAlgAlts
+	(Lam (ValBinder u1)
+	 (Case (Var u1)
+	    (AlgAlts
 	      [(nilDataCon,  [], core_list2),
 	       (consDataCon, [u2, u3], core_match)]
-	    CoNoDefault)))
+	    NoDefault)))
       )] letrec_body
     )
 \end{code}
@@ -177,38 +183,40 @@ deListComp expr ((GeneratorQual pat list1):quals) core_list2 -- rule A' above
 \begin{verbatim}
 TE < [ e | ] >>          c n = c e n
 TE << [ e | b , q ] >>   c n = if b then TE << [ e | q ] >> c n else n
-TE << [ e | p <- l , q ] c n =  foldr 
-			(\ TE << p >> b -> TE << [ e | q ] >> c b 
+TE << [ e | p <- l , q ] c n =  foldr
+			(\ TE << p >> b -> TE << [ e | q ] >> c b
 			   _          b  -> b)	n l
 \end{verbatim}
 \begin{code}
-dfListComp :: PlainCoreExpr 		-- the inside of the comp 
-	   -> UniType			-- the type of the inside
-	   -> UniType -> Id		-- 'c'; its type and id
-	   -> UniType -> Id		-- 'n'; its type and id
+dfListComp :: CoreExpr 		-- the inside of the comp
+	   -> Type			-- the type of the inside
+	   -> Type -> Id		-- 'c'; its type and id
+	   -> Type -> Id		-- 'n'; its type and id
 	   -> [TypecheckedQual] 	-- the rest of the qual's
-	   -> DsM PlainCoreExpr
+	   -> DsM CoreExpr
 
-dfListComp expr expr_ty c_ty c_id n_ty n_id [] 
-  = mkCoAppDs (CoVar c_id) expr   `thenDs` \ inner ->
-    mkCoAppDs inner (CoVar n_id)
+dfListComp expr expr_ty c_ty c_id n_ty n_id []
+  = mkAppDs (Var c_id) [] [expr, Var n_id]
 
-dfListComp expr expr_ty c_ty c_id n_ty n_id ((FilterQual filt) : quals)
+dfListComp expr expr_ty c_ty c_id n_ty n_id (FilterQual filt : quals)
   = dsExpr filt                			`thenDs` \ core_filt ->
     dfListComp expr expr_ty c_ty c_id n_ty n_id quals
 						`thenDs` \ core_rest ->
-    returnDs (mkCoreIfThenElse core_filt core_rest (CoVar n_id))
+    returnDs (mkCoreIfThenElse core_filt core_rest (Var n_id))
 
-dfListComp expr expr_ty c_ty c_id n_ty n_id ((GeneratorQual pat list1):quals)
+dfListComp expr expr_ty c_ty c_id n_ty n_id (LetQual binds : quals)
+  = panic "dfListComp:LetQual"
+
+dfListComp expr expr_ty c_ty c_id n_ty n_id (GeneratorQual pat list1 : quals)
     -- evaluate the two lists
   = dsExpr list1				`thenDs` \ core_list1 ->
 
     -- find the required type
 
-    let p_ty = typeOfPat pat
-	b_ty = n_ty		-- alias b_ty to n_ty
-	fn_ty = p_ty `mkFunTy` (b_ty `mkFunTy` b_ty)
-	lst_ty = typeOfCoreExpr core_list1
+    let p_ty   = outPatType pat
+	b_ty   = n_ty		-- alias b_ty to n_ty
+	fn_ty  = mkFunTys [p_ty, b_ty] b_ty
+	lst_ty = coreExprType core_list1
     in
 
     -- create some new local id's
@@ -220,15 +228,17 @@ dfListComp expr expr_ty c_ty c_id n_ty n_id ((GeneratorQual pat list1):quals)
     dfListComp expr expr_ty c_ty c_id b_ty b quals	`thenDs` \ core_rest ->
     -- build the pattern match
 
-    matchSimply (CoVar p) pat b_ty core_rest (CoVar b)	`thenDs` \ core_expr ->
+    matchSimply (Var p) pat b_ty core_rest (Var b)	`thenDs` \ core_expr ->
 
     -- now build the outermost foldr, and return
 
     returnDs (
       mkCoLetsAny
-	[CoNonRec fn (CoLam [p,b] core_expr),
-	 CoNonRec lst core_list1]
+	[NonRec fn (mkValLam [p, b] core_expr),
+	 NonRec lst core_list1]
 	(mkFoldr p_ty n_ty fn n_id lst)
     )
-\end{code}
 
+mkFoldr a b f z xs
+  = mkValApp (mkTyApp (Var foldrId) [a,b]) [VarArg f, VarArg z, VarArg xs]
+\end{code}
diff --git a/ghc/compiler/deSugar/DsLoop.lhi b/ghc/compiler/deSugar/DsLoop.lhi
new file mode 100644
index 0000000000..26a0c4b313
--- /dev/null
+++ b/ghc/compiler/deSugar/DsLoop.lhi
@@ -0,0 +1,31 @@
+Break the loop between Match and DsUtils and the loops
+between DsExpr/DsBinds and various things.
+
+\begin{code}
+interface DsLoop where
+
+import CoreSyn	( CoreBinding(..), CoreExpr(..) )
+import DsMonad	( DsM(..) )
+import DsBinds	( dsBinds )
+import DsExpr	( dsExpr )
+import DsUtils	( EquationInfo, MatchResult )
+import Id	( Id(..) )
+import Match	( match, matchSimply )
+import TcHsSyn	( TypecheckedHsBinds(..), TypecheckedHsExpr(..), TypecheckedPat(..) )
+import Type	( Type(..) )
+
+match :: [Id]		  -- Variables rep'ing the exprs we're matching with
+      -> [EquationInfo]	  -- Info about patterns, etc. (type synonym below)
+      -> [EquationInfo]	  -- Potentially shadowing equations above this one
+      -> DsM MatchResult  -- Desugared result!
+
+matchSimply :: CoreExpr			-- Scrutinee
+	    -> TypecheckedPat		-- Pattern it should match
+	    -> Type			-- Type of result
+	    -> CoreExpr			-- Return this if it matches
+	    -> CoreExpr			-- Return this if it does
+	    -> DsM CoreExpr
+
+dsBinds :: TypecheckedHsBinds -> DsM [CoreBinding]
+dsExpr  :: TypecheckedHsExpr  -> DsM CoreExpr
+\end{code}
diff --git a/ghc/compiler/deSugar/DsMonad.hi b/ghc/compiler/deSugar/DsMonad.hi
deleted file mode 100644
index acc7df5655..0000000000
--- a/ghc/compiler/deSugar/DsMonad.hi
+++ /dev/null
@@ -1,68 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface DsMonad where
-import Bag(Bag)
-import BasicLit(BasicLit)
-import Class(Class)
-import CmdLineOpts(GlobalSwitch, SwitchResult)
-import CoreSyn(CoreAtom, CoreBinding, CoreCaseAlternatives, CoreExpr)
-import CostCentre(CostCentre)
-import HsPat(TypecheckedPat)
-import Id(DataCon(..), Id)
-import Maybes(Labda)
-import PlainCore(PlainCoreExpr(..))
-import PreludePS(_PackedString)
-import Pretty(PprStyle, PrettyRep)
-import PrimOps(PrimOp)
-import SplitUniq(SplitUniqSupply)
-import SrcLoc(SrcLoc)
-import TyVar(TyVar, TyVarTemplate)
-import UniType(SigmaType(..), TauType(..), ThetaType(..), UniType)
-import UniqFM(UniqFM)
-import Unique(UniqSM(..), UniqueSupply)
-infixr 9 `thenDs`
-data GlobalSwitch 
-data SwitchResult 
-data CoreExpr a b 
-type DataCon = Id
-type DsIdEnv = UniqFM (CoreExpr Id Id)
-type DsM a = SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (a, Bag DsMatchContext)
-data DsMatchContext   = DsMatchContext DsMatchKind [TypecheckedPat] SrcLoc | NoMatchContext
-data DsMatchKind   = FunMatch Id | CaseMatch | LambdaMatch | PatBindMatch
-data Id 
-type PlainCoreExpr = CoreExpr Id Id
-data SplitUniqSupply 
-data SrcLoc 
-data TyVar 
-data TyVarTemplate 
-type SigmaType = UniType
-type TauType = UniType
-type ThetaType = [(Class, UniType)]
-data UniType 
-type UniqSM a = UniqueSupply -> (UniqueSupply, a)
-andDs :: (a -> a -> a) -> (SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (a, Bag DsMatchContext)) -> (SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (a, Bag DsMatchContext)) -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (a, Bag DsMatchContext)
-cloneTyVarsDs :: [TyVar] -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> ([TyVar], Bag DsMatchContext)
-dsShadowError :: DsMatchContext -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> ((), Bag DsMatchContext)
-duplicateLocalDs :: Id -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (Id, Bag DsMatchContext)
-extendEnvDs :: [(Id, CoreExpr Id Id)] -> (SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (a, Bag DsMatchContext)) -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (a, Bag DsMatchContext)
-getModuleAndGroupDs :: SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> ((_PackedString, _PackedString), Bag DsMatchContext)
-getSrcLocDs :: SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (([Char], [Char]), Bag DsMatchContext)
-getSwitchCheckerDs :: SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (GlobalSwitch -> Bool, Bag DsMatchContext)
-ifSwitchSetDs :: GlobalSwitch -> (SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (a, Bag DsMatchContext)) -> (SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (a, Bag DsMatchContext)) -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (a, Bag DsMatchContext)
-initDs :: SplitUniqSupply -> UniqFM (CoreExpr Id Id) -> (GlobalSwitch -> SwitchResult) -> _PackedString -> (SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (a, Bag DsMatchContext)) -> (a, Bag DsMatchContext)
-listDs :: [SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (a, Bag DsMatchContext)] -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> ([a], Bag DsMatchContext)
-lookupEnvDs :: Id -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (Labda (CoreExpr Id Id), Bag DsMatchContext)
-lookupEnvWithDefaultDs :: Id -> CoreExpr Id Id -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (CoreExpr Id Id, Bag DsMatchContext)
-lookupId :: [(Id, a)] -> Id -> a
-mapAndUnzipDs :: (a -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> ((b, c), Bag DsMatchContext)) -> [a] -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (([b], [c]), Bag DsMatchContext)
-mapDs :: (a -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (b, Bag DsMatchContext)) -> [a] -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> ([b], Bag DsMatchContext)
-newFailLocalDs :: UniType -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (Id, Bag DsMatchContext)
-newSysLocalDs :: UniType -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (Id, Bag DsMatchContext)
-newSysLocalsDs :: [UniType] -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> ([Id], Bag DsMatchContext)
-newTyVarsDs :: [TyVarTemplate] -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> ([TyVar], Bag DsMatchContext)
-pprDsWarnings :: PprStyle -> Bag DsMatchContext -> Int -> Bool -> PrettyRep
-putSrcLocDs :: SrcLoc -> (SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (a, Bag DsMatchContext)) -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (a, Bag DsMatchContext)
-returnDs :: a -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (a, Bag DsMatchContext)
-thenDs :: (SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (a, Bag DsMatchContext)) -> (a -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (b, Bag DsMatchContext)) -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (b, Bag DsMatchContext)
-uniqSMtoDsM :: (UniqueSupply -> (UniqueSupply, a)) -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (a, Bag DsMatchContext)
-zipWithDs :: (a -> b -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (c, Bag DsMatchContext)) -> [a] -> [b] -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> ([c], Bag DsMatchContext)
-
diff --git a/ghc/compiler/deSugar/DsMonad.lhs b/ghc/compiler/deSugar/DsMonad.lhs
index 9a01390cc9..636ebf43eb 100644
--- a/ghc/compiler/deSugar/DsMonad.lhs
+++ b/ghc/compiler/deSugar/DsMonad.lhs
@@ -1,7 +1,7 @@
 %
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
 %
-\section[DesugarMonad]{@DesugarMonad@: monadery used in desugaring}
+\section[DsMonad]{@DsMonad@: monadery used in desugaring}
 
 \begin{code}
 #include "HsVersions.h"
@@ -15,52 +15,40 @@ module DsMonad (
 	duplicateLocalDs, newSysLocalDs, newSysLocalsDs,
 	newFailLocalDs,
 	getSrcLocDs, putSrcLocDs,
-	getSwitchCheckerDs, ifSwitchSetDs,
 	getModuleAndGroupDs,
 	extendEnvDs, lookupEnvDs, lookupEnvWithDefaultDs,
 	DsIdEnv(..),
 	lookupId,
 
 	dsShadowError,
-	DsMatchContext(..), DsMatchKind(..), pprDsWarnings,
-
-#ifdef DPH
-	listDs,
-#endif
-
-	-- and to make the interface self-sufficient...
-	Id, DataCon(..), SrcLoc, TyVar, TyVarTemplate, UniType, TauType(..),
-	ThetaType(..), SigmaType(..), SplitUniqSupply, UniqSM(..),
-	PlainCoreExpr(..), CoreExpr, GlobalSwitch, SwitchResult
-	
-	IF_ATTACK_PRAGMAS(COMMA lookupUFM COMMA lookupIdEnv)
-	IF_ATTACK_PRAGMAS(COMMA mkIdWithNewUniq COMMA mkSysLocal)
-	IF_ATTACK_PRAGMAS(COMMA unpackSrcLoc COMMA mkUniqueSupplyGrimily)
-	IF_ATTACK_PRAGMAS(COMMA mkUniqueGrimily)
-	IF_ATTACK_PRAGMAS(COMMA splitUniqSupply COMMA getSUnique)
+	DsMatchContext(..), DsMatchKind(..), pprDsWarnings
     ) where
 
-import AbsSyn
-import AbsUniType	( cloneTyVarFromTemplate, cloneTyVar,
-			  TyVar, TyVarTemplate, UniType, TauType(..),
-			  ThetaType(..), SigmaType(..), Class
-			  IF_ATTACK_PRAGMAS(COMMA cmpTyVar)
-			)
-import Bag
-import CmdLineOpts	-- ( GlobalSwitch(..), SwitchResult(..), switchIsOn )
-import Id		( mkIdWithNewUniq, mkSysLocal, Id, DataCon(..) )
-import IdEnv		-- ( mkIdEnv, IdEnv )
-import Maybes		( assocMaybe, Maybe(..) )
-import Outputable
-import PlainCore
+import Ubiq
+
+import Bag		( emptyBag, snocBag, bagToList )
+import CmdLineOpts	( opt_SccGroup )
+import CoreSyn		( CoreExpr(..) )
+import CoreUtils	( substCoreExpr )
+import HsSyn		( OutPat )
+import Id		( mkSysLocal, lookupIdEnv, growIdEnvList, GenId, IdEnv(..) )
+import PprType		( GenType, GenTyVar )
+import PprStyle		( PprStyle(..) )
 import Pretty
 import SrcLoc		( unpackSrcLoc, mkUnknownSrcLoc, SrcLoc )
-import TyVarEnv		-- ( nullTyVarEnv, TyVarEnv )
-import SplitUniq
-import Unique
-import Util
+import TcHsSyn		( TypecheckedPat(..) )
+import TyVar		( nullTyVarEnv, GenTyVar )
+import Unique		( Unique{-instances-} )
+import UniqSupply	( splitUniqSupply, getUnique, getUniques,
+			  mapUs, thenUs, returnUs, UniqSM(..) )
+import Unique		( Unique )
+import Util		( assoc, mapAccumL, zipWithEqual, panic )
 
 infixr 9 `thenDs`
+
+cloneTyVar = panic "DsMonad.cloneTyVar"
+cloneTyVarFromTemplate = panic "DsMonad.cloneTyVarFromTemplate"
+mkIdWithNewUniq = panic "DsMonad.mkIdWithNewUniq"
 \end{code}
 
 Now the mondo monad magic (yes, @DsM@ is a silly name)---carry around
@@ -68,56 +56,51 @@ a @UniqueSupply@ and some annotations, which
 presumably include source-file location information:
 \begin{code}
 type DsM result =
-	SplitUniqSupply
-	-> SrcLoc			    -- to put in pattern-matching error msgs
-	-> (GlobalSwitch -> SwitchResult)   -- so we can consult global switches
-	-> (FAST_STRING, FAST_STRING)		    -- "module"+"group" : for SCC profiling
+	UniqSupply
+	-> SrcLoc			-- to put in pattern-matching error msgs
+	-> (FAST_STRING, FAST_STRING)	-- "module"+"group" : for SCC profiling
 	-> DsIdEnv
 	-> DsWarnings
 	-> (result, DsWarnings)
 
-type DsWarnings = Bag DsMatchContext	-- The desugarer reports matches which are 
+type DsWarnings = Bag DsMatchContext	-- The desugarer reports matches which are
 					-- completely shadowed
-
-#ifdef __GLASGOW_HASKELL__
 {-# INLINE andDs #-}
 {-# INLINE thenDs #-}
 {-# INLINE returnDs #-}
-#endif
 
 -- initDs returns the UniqSupply out the end (not just the result)
 
-initDs  :: SplitUniqSupply
+initDs  :: UniqSupply
 	-> DsIdEnv
-	-> (GlobalSwitch -> SwitchResult)
 	-> FAST_STRING -- module name: for profiling; (group name: from switches)
 	-> DsM a
 	-> (a, DsWarnings)
 
-initDs init_us env sw_chkr mod_name action
-  = action init_us mkUnknownSrcLoc sw_chkr module_and_group env emptyBag
+initDs init_us env mod_name action
+  = action init_us mkUnknownSrcLoc module_and_group env emptyBag
   where
     module_and_group = (mod_name, grp_name)
-    grp_name  = case (stringSwitchSet sw_chkr SccGroup) of
-		    Just xx -> _PK_ xx
+    grp_name  = case opt_SccGroup of
+		    Just xx -> xx
 		    Nothing -> mod_name	-- default: module name
 
 thenDs :: DsM a -> (a -> DsM b) -> DsM b
 andDs  :: (a -> a -> a) -> DsM a -> DsM a -> DsM a
 
-thenDs expr cont us loc sw_chkr mod_and_grp env warns
-  = case splitUniqSupply us	    of { (s1, s2) ->
-    case (expr s1 loc sw_chkr mod_and_grp env warns)  of { (result, warns1) ->
-    cont result s2 loc sw_chkr mod_and_grp env warns1}}
+thenDs m1 m2 us loc mod_and_grp env warns
+  = case splitUniqSupply us		    of { (s1, s2) ->
+    case (m1 s1 loc mod_and_grp env warns)  of { (result, warns1) ->
+    m2 result s2 loc mod_and_grp env warns1}}
 
-andDs combiner m1 m2 us loc sw_chkr mod_and_grp env warns
-  = case splitUniqSupply us	    of { (s1, s2) ->
-    case (m1 s1 loc sw_chkr mod_and_grp env warns)    of { (result1, warns1) ->
-    case (m2 s2 loc sw_chkr mod_and_grp env warns1)   of { (result2, warns2) ->
+andDs combiner m1 m2 us loc mod_and_grp env warns
+  = case splitUniqSupply us		    of { (s1, s2) ->
+    case (m1 s1 loc mod_and_grp env warns)  of { (result1, warns1) ->
+    case (m2 s2 loc mod_and_grp env warns1) of { (result2, warns2) ->
     (combiner result1 result2, warns2) }}}
 
 returnDs :: a -> DsM a
-returnDs result us loc sw_chkr mod_and_grp env warns = (result, warns)
+returnDs result us loc mod_and_grp env warns = (result, warns)
 
 listDs :: [DsM a] -> DsM [a]
 listDs []     = returnDs []
@@ -149,6 +132,7 @@ zipWithDs f (x:xs) (y:ys)
   = f x y		`thenDs` \ r  ->
     zipWithDs f xs ys	`thenDs` \ rs ->
     returnDs (r:rs)
+-- Note: crashes if lists not equal length (like zipWithEqual)
 \end{code}
 
 And all this mysterious stuff is so we can occasionally reach out and
@@ -156,9 +140,9 @@ grab one or more names.  @newLocalDs@ isn't exported---exported
 functions are defined with it.  The difference in name-strings makes
 it easier to read debugging output.
 \begin{code}
-newLocalDs :: FAST_STRING -> UniType -> DsM Id
-newLocalDs nm ty us loc sw_chkr mod_and_grp env warns
-  = case (getSUnique us) of { assigned_uniq ->
+newLocalDs :: FAST_STRING -> Type -> DsM Id
+newLocalDs nm ty us loc mod_and_grp env warns
+  = case (getUnique us) of { assigned_uniq ->
     (mkSysLocal nm assigned_uniq ty loc, warns) }
 
 newSysLocalDs	    = newLocalDs SLIT("ds")
@@ -166,22 +150,22 @@ newSysLocalsDs tys  = mapDs (newLocalDs SLIT("ds")) tys
 newFailLocalDs	    = newLocalDs SLIT("fail")
 
 duplicateLocalDs :: Id -> DsM Id
-duplicateLocalDs old_local us loc sw_chkr mod_and_grp env warns
-  = case (getSUnique us) of { assigned_uniq ->
+duplicateLocalDs old_local us loc mod_and_grp env warns
+  = case (getUnique us) of { assigned_uniq ->
     (mkIdWithNewUniq old_local assigned_uniq, warns) }
 
 cloneTyVarsDs :: [TyVar] -> DsM [TyVar]
-cloneTyVarsDs tyvars us loc sw_chkr mod_and_grp env warns
-  = case (getSUniques (length tyvars) us) of { uniqs ->
-    (zipWith cloneTyVar tyvars uniqs, warns) }
+cloneTyVarsDs tyvars us loc mod_and_grp env warns
+  = case (getUniques (length tyvars) us) of { uniqs ->
+    (zipWithEqual cloneTyVar tyvars uniqs, warns) }
 \end{code}
 
 \begin{code}
-newTyVarsDs :: [TyVarTemplate] -> DsM [TyVar]
+newTyVarsDs :: [TyVar] -> DsM [TyVar]
 
-newTyVarsDs tyvar_tmpls us loc sw_chkr mod_and_grp env warns
-  = case (getSUniques (length tyvar_tmpls) us) of { uniqs ->
-    (zipWith cloneTyVarFromTemplate tyvar_tmpls uniqs, warns) }
+newTyVarsDs tyvar_tmpls us loc mod_and_grp env warns
+  = case (getUniques (length tyvar_tmpls) us) of { uniqs ->
+    (zipWithEqual cloneTyVarFromTemplate tyvar_tmpls uniqs, warns) }
 \end{code}
 
 We can also reach out and either set/grab location information from
@@ -189,69 +173,57 @@ the @SrcLoc@ being carried around.
 \begin{code}
 uniqSMtoDsM :: UniqSM a -> DsM a
 
-uniqSMtoDsM u_action us loc sw_chkr mod_and_grp env warns
-  = let
-    	us_to_use = mkUniqueSupplyGrimily us
-    in
-    (snd (u_action us_to_use), warns)
+uniqSMtoDsM u_action us loc mod_and_grp env warns
+  = (u_action us, warns)
 
 getSrcLocDs :: DsM (String, String)
-getSrcLocDs us loc sw_chkr mod_and_grp env warns
+getSrcLocDs us loc mod_and_grp env warns
   = case (unpackSrcLoc loc) of { (x,y) ->
     ((_UNPK_ x, _UNPK_ y), warns) }
 
 putSrcLocDs :: SrcLoc -> DsM a -> DsM a
-putSrcLocDs new_loc expr us old_loc sw_chkr mod_and_grp env warns
-  = expr us new_loc sw_chkr mod_and_grp env warns
+putSrcLocDs new_loc expr us old_loc mod_and_grp env warns
+  = expr us new_loc mod_and_grp env warns
 
 dsShadowError :: DsMatchContext -> DsM ()
-dsShadowError cxt us loc sw_chkr mod_and_grp env warns
+dsShadowError cxt us loc mod_and_grp env warns
   = ((), warns `snocBag` cxt)
 \end{code}
 
 \begin{code}
-getSwitchCheckerDs :: DsM (GlobalSwitch -> Bool)
-getSwitchCheckerDs us loc sw_chkr mod_and_grp env warns
-  = (switchIsOn sw_chkr, warns)
-
-ifSwitchSetDs :: GlobalSwitch -> DsM a -> DsM a -> DsM a
-ifSwitchSetDs switch then_ else_ us loc sw_chkr mod_and_grp env warns
-  = (if switchIsOn sw_chkr switch then then_ else else_)
-	us loc sw_chkr mod_and_grp env warns
-
 getModuleAndGroupDs :: DsM (FAST_STRING, FAST_STRING)
-getModuleAndGroupDs us loc sw_chkr mod_and_grp env warns
+getModuleAndGroupDs us loc mod_and_grp env warns
   = (mod_and_grp, warns)
 \end{code}
 
 \begin{code}
-type DsIdEnv = IdEnv PlainCoreExpr
+type DsIdEnv = IdEnv CoreExpr
 
-extendEnvDs :: [(Id, PlainCoreExpr)] -> DsM a -> DsM a
+extendEnvDs :: [(Id, CoreExpr)] -> DsM a -> DsM a
 
-extendEnvDs pairs expr us loc sw_chkr mod_and_grp old_env warns
+extendEnvDs pairs then_do us loc mod_and_grp old_env warns
   = case splitUniqSupply us 	    of { (s1, s2) ->
-    case (mapAccumL subst s1 pairs) of { (_, revised_pairs) ->
-    expr s2 loc sw_chkr mod_and_grp (growIdEnvList old_env revised_pairs) warns
-    }}
+    let
+	revised_pairs = subst_all pairs s1
+    in
+    then_do s2 loc mod_and_grp (growIdEnvList old_env revised_pairs) warns
+    }
   where
-    subst us (v, expr)
-      = case splitUniqSupply us	of { (s1, s2) ->
-	let
-	    us_to_use = mkUniqueSupplyGrimily s1
-	in
-	case (substCoreExpr us_to_use old_env nullTyVarEnv expr) of { (_, expr2) ->
-	(s2, (v, expr2)) }}
-
-lookupEnvDs :: Id -> DsM (Maybe PlainCoreExpr)
-lookupEnvDs id us loc sw_chkr mod_and_grp env warns
+    subst_all pairs = mapUs subst pairs
+
+    subst (v, expr)
+      = substCoreExpr old_env nullTyVarEnv expr `thenUs` \ new_expr ->
+	returnUs (v, new_expr)
+
+lookupEnvDs :: Id -> DsM (Maybe CoreExpr)
+lookupEnvDs id us loc mod_and_grp env warns
   = (lookupIdEnv env id, warns)
   -- Note: we don't assert anything about the Id
   -- being looked up.  There's not really anything
   -- much to say about it. (WDP 94/06)
 
-lookupEnvWithDefaultDs :: Id -> PlainCoreExpr -> DsM PlainCoreExpr
-lookupEnvWithDefaultDs id deflt us loc sw_chkr mod_and_grp env warns
+lookupEnvWithDefaultDs :: Id -> CoreExpr -> DsM CoreExpr
+lookupEnvWithDefaultDs id deflt us loc mod_and_grp env warns
   = (case (lookupIdEnv env id) of
       Nothing -> deflt
       Just xx -> xx,
diff --git a/ghc/compiler/deSugar/DsParZF.lhs b/ghc/compiler/deSugar/DsParZF.lhs
deleted file mode 100644
index 0f8ff6ddf4..0000000000
--- a/ghc/compiler/deSugar/DsParZF.lhs
+++ /dev/null
@@ -1,233 +0,0 @@
-%************************************************************************
-%*									*
-\section[DsParZF]{Desugaring Parallel ZF expressisions}
-%*									*
-%************************************************************************
-
-\begin{code}
-#include "HsVersions.h"
-module DsParZF	where
-
-IMPORT_Trace		-- ToDo: rm
-
-import AbsSyn		-- the stuff being desugared
-import PlainCore	-- the output of desugaring;
-			-- importing this module also gets all the
-			-- CoreSyn utility functions
-import DsMonad		-- the monadery used in the desugarer
-import AbsPrel		( mkFunTy , eRROR_ID , integerTy,
-			  fromDomainId , toDomainId)
-import DsExpr		( dsExpr )
-import DsUtils		( mkSelectorBinds , EquationInfo(..))
-import Match		( match )
-import FiniteMap	-- WAS: Set
-import FreeVars
-import SrcLoc
-import BasicLit		 ( BasicLit(..) )
-import Util
-\end{code}
-
-The purpose of the module is to convert the abstract syntax representation
-of parallel ZF expressions into the core syntax representation. The two 
-representations differ in that the core syntax only contains binders in 
-drawn and index from generators. 
-
-\begin{description}
-\item[The ``Idea''] For each pattern in a generator we apply the function 
-$\lambda hole\ .\ {\cal D}[[{\tt (\\pat ->}\ hole {\tt )x}]]$ to 
-{\em every} expression in an inner scope than that of the definition of 
-the pattern; {\tt x} represents the binder in the generator after translation,
-${\cal D}[[exp]]$ represents the desugaring of the expression $exp$.
-
-\item[Optimising the ``Idea''] We catagorise each pattern into two types;
-simple patterns in which their are no binders, and complex patterns. We
-only apply simple patterns to the left handside of a ZF expressions, and 
-complex patterns to expressions in which the intersection of the free
-variables of the expression, and the binders of the pattern is non-empty.
-\end{description}
-
-%************************************************************************
-%*									*
-\subsection[dsParallelZF]{Interface to the outside world}
-%*									*
-%************************************************************************
-
-\begin{code}
-dsParallelZF::TypecheckedExpr -> TypecheckedParQuals -> DsM PlainCoreExpr
-dsParallelZF expr quals 
-  = dsParQuals quals			`thenDs`	(\ (quals',hf)	 ->
-    dsExpr expr				`thenDs`	( \ expr'	 ->
-    let_1_0 (typeOfCoreExpr expr')			( \ ty		 ->
-    returnDs (CoZfExpr (applyHoleLhsExpr ty expr' hf) quals') )))
-\end{code}
-
-%************************************************************************
-%*									*
-\subsection[dsZF_datatype]{DataType used to represent ``HoleFunction''}
-%*									*
-%************************************************************************
-
-\begin{code}
-type HoleFunction = (UniType -> PlainCoreExpr -> PlainCoreExpr,
-		     [(PlainCoreExpr -> Bool,
-		       UniType -> PlainCoreExpr -> PlainCoreExpr)])
-\end{code}
-
-\begin{code}
-combine fn fn' = \t e -> fn t (fn' t e)
-\end{code}
-
-\begin{code}
-combineHoles:: HoleFunction -> HoleFunction -> HoleFunction
-combineHoles (lhs,rhs) (lhs',rhs') 
-   = (combine lhs lhs',rhs++rhs')
-\end{code}
-
-\begin{code}
-identityHole::HoleFunction
-identityHole = (\t e -> e,[])
-\end{code}
-
-\begin{code}
-applyHoleLhsExpr:: UniType	
-		-> PlainCoreExpr 
-		-> HoleFunction 
-		-> PlainCoreExpr
-applyHoleLhsExpr ty expr (lhs,rhs)
-   = (combine lhs (foldr combine (\t e -> e) (map snd rhs))) ty expr
-\end{code}
-
-\begin{code}
-applyHoleRhsExpr ty expr (_,rhs)
-   = (foldr combine (\t e -> e) [ y | (x,y) <- rhs, (x expr)]) ty expr
-\end{code}
-
-\begin{code}
-applyHoleFunction :: PlainCoreParQuals
-		  -> HoleFunction
-		  -> PlainCoreParQuals
-applyHoleFunction (CoAndQuals left right) hf
-   = CoAndQuals (applyHoleFunction left hf) (applyHoleFunction right hf)
-
-applyHoleFunction (CoParFilter expr) hf
-   = CoParFilter (applyHoleRhsExpr (typeOfCoreExpr expr) expr hf)
-
-applyHoleFunction (CoDrawnGen pats pat expr) hf
-   = CoDrawnGen pats pat (applyHoleRhsExpr (typeOfCoreExpr expr) expr hf)
-
-applyHoleFunction (CoIndexGen exprs pat expr) hf
-   = CoIndexGen (map (\x -> applyHoleRhsExpr (typeOfCoreExpr x) x hf) exprs) 
-		pat 
-		(applyHoleRhsExpr (typeOfCoreExpr expr) expr hf)
-\end{code}
-
-%************************************************************************
-%*									*
-\subsection[dsParQuals]{Desugaring the qualifiers}
-%*									*
-%************************************************************************
-
-\begin{code}
-dsParQuals::TypecheckedParQuals 
-	   -> DsM (PlainCoreParQuals,HoleFunction)
-\end{code}
-
-\begin{code}
-dsParQuals (AndParQuals left right) 
-   = dsParQuals left		`thenDs`      (\ (left', hfleft)  ->
-     dsParQuals right		`thenDs`      (\ (right',hfright) ->
-     returnDs (CoAndQuals left'	 (applyHoleFunction right' hfleft), 
-	       combineHoles hfleft hfright) ))
- 
-\end{code}
-
-\begin{code}
-dsParQuals (ParFilter expr)
-   = dsExpr expr		`thenDs`	(\ expr' ->
-     returnDs (CoParFilter expr', identityHole) )
-
-dsParQuals (DrawnGenOut pats convs pat dRHS) 
-   = listDs  (map dsExpr convs)	`thenDs`	(\ convs'	   ->
-     listDs  (map prettyNewLocalDs pats)	
-				`thenDs`	(\ binders	   ->
-     listDs (zipWith3 dsPid  pats binders convs')	
-				`thenDs`	(\ hfList	   ->
-     let_1_0 (foldr1 (combineHoles) hfList)	(\ hf		   ->
-     prettyNewLocalDs pat	`thenDs`	(\ iden		   ->  
-     duplicateLocalDs iden	`thenDs`	(\ binder	   ->
-     dsPid pat binder (CoLam [iden] (CoVar iden))
-				`thenDs`	(\ hf'		   ->
-     dsExpr dRHS		`thenDs`	(\ dRHS'	   ->
-     returnDs (CoDrawnGen binders binder dRHS', 
-	       combineHoles hf hf') ))))))))
-
-
-dsParQuals (IndexGen exprs pat iRHS)
-   = listDs (map dsExpr exprs)	`thenDs`	(\ exprs'	 ->
-     prettyNewLocalDs pat	`thenDs`	(\ binder	   -> 
-     duplicateLocalDs binder	`thenDs`	(\ iden	       ->
-     dsPid pat binder (CoLam [iden] (CoVar iden))
-				`thenDs`	(\ hf		 ->
-     dsExpr iRHS		`thenDs`	(\ iRHS'	 ->
-     returnDs (CoIndexGen exprs' binder iRHS' ,hf) )))))	
-
-\end{code}
-
-\begin{code}
-dsPid:: TypecheckedPat			-- Pattern to be desugared
-     -> Id				-- Patterns desugared binder
-     -> PlainCoreExpr			-- Conversion function
-     -> DsM HoleFunction			
-
-dsPid pat binder conv
-  = duplicateLocalDs binder	`thenDs`		(\ lambdaBind	 ->
-    getSrcLocDs			`thenDs`		(\ (sfile,sline) ->
-    let_1_0 ("\""++sfile++"\", line "++sline++" : "++
-	     "Processor not defined\n")			( \ errorStr	 ->
-    getUniqueSupplyDs		`thenDs`		(\ us		 ->
-    let_1_0 (collectTypedPatBinders pat)		(\ patBinders	 ->
-    case (null patBinders) of
-    True  -> returnDs (mkHole lambdaBind errorStr us,[])
-    False -> 
-       returnDs (\t e -> e, [(mkPredicate patBinders,
-			      mkHole lambdaBind errorStr us)]) )))))
-   
-  where
-     mkPredicate b e
-	= let_1_0 (freeStuff b e)	(\ ((fvSet,_),_) ->
-	  let_1_0 (mkSet b)		(\ bSet		 ->
-	  not (isEmptySet (intersect fvSet bSet)) ))
-
-     mkHole lambdaBind errorStr us
-	= \ ty expr ->
-	     (CoApp
-		(CoLam
-		   [lambdaBind]
-		   (snd (initDs
-			   us
-			   nullIdEnv
-			   (\ _ -> False)	-- Hack alert!!!
-			   (panic "mkHole: module name")
-			   (match [lambdaBind] [([pat], \x -> expr)] 
-				  (CoApp 
-				     (mkCoTyApp (CoVar eRROR_ID) ty) 
-				     (CoLit (NoRepStr (_PK_ errorStr))))))))
-		(CoApp conv (CoVar binder)))
-\end{code} 
-
-In the mkHole function we need to conjure up some state so we can
-use the match function...
-%************************************************************************
-%*									*
-\subsection[prettyLocals]{Make a new binder; try and keep names nice :-)}
-%*									*
-%************************************************************************
-
-\begin{code}
-prettyNewLocalDs::TypecheckedPat -> DsM Id
-prettyNewLocalDs (VarPat id)  = duplicateLocalDs id
-prettyNewLocalDs (AsPat id _) = duplicateLocalDs id
-preetyNewLocalDs pat	      = let_1_0 (typeOfPat pat)		(\ pat_ty->
-				newSysLocalDs pat_ty
-				)
-\end{code}
diff --git a/ghc/compiler/deSugar/DsUtils.hi b/ghc/compiler/deSugar/DsUtils.hi
deleted file mode 100644
index bd4691db80..0000000000
--- a/ghc/compiler/deSugar/DsUtils.hi
+++ /dev/null
@@ -1,35 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface DsUtils where
-import Bag(Bag)
-import BasicLit(BasicLit)
-import CmdLineOpts(GlobalSwitch, SwitchResult)
-import CoreSyn(CoreAtom, CoreBinding, CoreExpr)
-import DsMonad(DsMatchContext)
-import HsPat(TypecheckedPat)
-import Id(Id)
-import PreludePS(_PackedString)
-import PrimOps(PrimOp)
-import SplitUniq(SplitUniqSupply)
-import SrcLoc(SrcLoc)
-import TyVar(TyVar)
-import UniType(UniType)
-import UniqFM(UniqFM)
-data CanItFail   = CanFail | CantFail
-data EquationInfo   = EqnInfo [TypecheckedPat] MatchResult
-data MatchResult   = MatchResult CanItFail UniType (CoreExpr Id Id -> CoreExpr Id Id) DsMatchContext
-combineGRHSMatchResults :: MatchResult -> MatchResult -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (MatchResult, Bag DsMatchContext)
-combineMatchResults :: MatchResult -> MatchResult -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (MatchResult, Bag DsMatchContext)
-dsExprToAtom :: CoreExpr Id Id -> (CoreAtom Id -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (CoreExpr Id Id, Bag DsMatchContext)) -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (CoreExpr Id Id, Bag DsMatchContext)
-mkCoAlgCaseMatchResult :: Id -> [(Id, [Id], MatchResult)] -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (MatchResult, Bag DsMatchContext)
-mkCoAppDs :: CoreExpr Id Id -> CoreExpr Id Id -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (CoreExpr Id Id, Bag DsMatchContext)
-mkCoConDs :: Id -> [UniType] -> [CoreExpr Id Id] -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (CoreExpr Id Id, Bag DsMatchContext)
-mkCoLetsMatchResult :: [CoreBinding Id Id] -> MatchResult -> MatchResult
-mkCoPrimCaseMatchResult :: Id -> [(BasicLit, MatchResult)] -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (MatchResult, Bag DsMatchContext)
-mkCoPrimDs :: PrimOp -> [UniType] -> [CoreExpr Id Id] -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (CoreExpr Id Id, Bag DsMatchContext)
-mkFailurePair :: UniType -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> ((CoreExpr Id Id -> CoreBinding Id Id, CoreExpr Id Id), Bag DsMatchContext)
-mkGuardedMatchResult :: CoreExpr Id Id -> MatchResult -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (MatchResult, Bag DsMatchContext)
-mkSelectorBinds :: [TyVar] -> TypecheckedPat -> [(Id, Id)] -> CoreExpr Id Id -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> ([(Id, CoreExpr Id Id)], Bag DsMatchContext)
-mkTupleBind :: [TyVar] -> [Id] -> [(Id, Id)] -> CoreExpr Id Id -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> ([(Id, CoreExpr Id Id)], Bag DsMatchContext)
-mkTupleExpr :: [Id] -> CoreExpr Id Id
-selectMatchVars :: [TypecheckedPat] -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> ([Id], Bag DsMatchContext)
-
diff --git a/ghc/compiler/deSugar/DsUtils.lhs b/ghc/compiler/deSugar/DsUtils.lhs
index 5e0031dd67..b58c6d5ebc 100644
--- a/ghc/compiler/deSugar/DsUtils.lhs
+++ b/ghc/compiler/deSugar/DsUtils.lhs
@@ -1,5 +1,5 @@
 %
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
 %
 \section[DsUtils]{Utilities for desugaring}
 
@@ -15,11 +15,9 @@ module DsUtils (
 	combineMatchResults,
 	dsExprToAtom,
 	mkCoAlgCaseMatchResult,
-	mkCoAppDs,
-	mkCoConDs,
+	mkAppDs, mkConDs, mkPrimDs,
 	mkCoLetsMatchResult,
 	mkCoPrimCaseMatchResult,
-	mkCoPrimDs,
 	mkFailurePair,
 	mkGuardedMatchResult,
 	mkSelectorBinds,
@@ -28,30 +26,31 @@ module DsUtils (
 	selectMatchVars
     ) where
 
-import AbsSyn		-- the stuff being desugared
-import PlainCore	-- the output of desugaring;
-			-- importing this module also gets all the
-			-- CoreSyn utility functions
-import DsMonad		-- the monadery used in the desugarer
-
-import AbsPrel		( mkFunTy, stringTy
-			  IF_ATTACK_PRAGMAS(COMMA mkListTy COMMA charTy)
-			)
-import AbsUniType	( mkTyVarTy, quantifyTy, mkTupleTyCon,
-			  mkRhoTy, splitDictType, applyTyCon,
-			  getUniDataTyCon, isUnboxedDataType, 
-			  TyVar, TyVarTemplate, TyCon, Arity(..), Class,
-			  UniType, RhoType(..), SigmaType(..)
-			)
-import Id		( getIdUniType, getInstantiatedDataConSig,
-			  mkTupleCon, DataCon(..), Id
-			)
-import Maybes		( Maybe(..) )
-import Match		( match, matchSimply )
-import Pretty
-import Unique		( initUs, UniqueSupply, UniqSM(..) )
-import UniqSet
-import Util
+import Ubiq
+import DsLoop		( match, matchSimply )
+
+import HsSyn		( HsExpr(..), OutPat(..), HsLit(..),
+			  Match, HsBinds, Stmt, Qual, PolyType, ArithSeqInfo )
+import TcHsSyn		( TypecheckedPat(..) )
+import DsHsSyn		( outPatType )
+import CoreSyn
+
+import DsMonad
+
+import CoreUtils	( coreExprType, escErrorMsg, mkCoreIfThenElse, mkErrorApp )
+import PrelInfo		( stringTy )
+import Id		( idType, getInstantiatedDataConSig, mkTupleCon,
+			  DataCon(..), DictVar(..), Id(..), GenId )
+import TyCon		( mkTupleTyCon )
+import Type		( mkTyVarTy, mkRhoTy, mkFunTys,
+			  applyTyCon, getAppDataTyCon )
+import UniqSet		( mkUniqSet, minusUniqSet, uniqSetToList, UniqSet(..) )
+import Util		( panic, assertPanic )
+
+isUnboxedDataType = panic "DsUtils.isUnboxedDataType"
+quantifyTy = panic "DsUtils.quantifyTy"
+splitDictType = panic "DsUtils.splitDictType"
+mkCoTyApps = panic "DsUtils.mkCoTyApps"
 \end{code}
 
 %************************************************************************
@@ -65,7 +64,7 @@ The ``equation info'' used by @match@ is relatively complicated and
 worthy of a type synonym and a few handy functions.
 
 \begin{code}
-data EquationInfo 
+data EquationInfo
   = EqnInfo
 	[TypecheckedPat]    -- the patterns for an eqn
       	MatchResult	    -- Encapsulates the guards and bindings
@@ -75,9 +74,9 @@ data EquationInfo
 data MatchResult
   = MatchResult
 	CanItFail
-	UniType		-- Type of argument expression
+	Type		-- Type of argument expression
 
-	(PlainCoreExpr -> PlainCoreExpr)
+	(CoreExpr -> CoreExpr)
 			-- Takes a expression to plug in at the
 			-- failure point(s). The expression should
 			-- be duplicatable!
@@ -93,11 +92,11 @@ orFail CantFail CantFail = CantFail
 orFail _        _	 = CanFail
 
 
-mkCoLetsMatchResult :: [PlainCoreBinding] -> MatchResult -> MatchResult
-mkCoLetsMatchResult binds (MatchResult can_it_fail ty body_fn cxt) 
+mkCoLetsMatchResult :: [CoreBinding] -> MatchResult -> MatchResult
+mkCoLetsMatchResult binds (MatchResult can_it_fail ty body_fn cxt)
   = MatchResult can_it_fail ty (\body -> mkCoLetsAny binds (body_fn body)) cxt
 
-mkGuardedMatchResult :: PlainCoreExpr -> MatchResult -> DsM MatchResult
+mkGuardedMatchResult :: CoreExpr -> MatchResult -> DsM MatchResult
 mkGuardedMatchResult pred_expr (MatchResult can_it_fail ty body_fn cxt)
   = returnDs (MatchResult CanFail
 			  ty
@@ -106,10 +105,10 @@ mkGuardedMatchResult pred_expr (MatchResult can_it_fail ty body_fn cxt)
     )
 
 mkCoPrimCaseMatchResult :: Id				-- Scrutinee
-		    -> [(BasicLit, MatchResult)]	-- Alternatives    
+		    -> [(Literal, MatchResult)]	-- Alternatives
 		    -> DsM MatchResult
 mkCoPrimCaseMatchResult var alts
-  = newSysLocalDs (getIdUniType var)	`thenDs` \ wild ->
+  = newSysLocalDs (idType var)	`thenDs` \ wild ->
     returnDs (MatchResult CanFail
 			  ty1
 			  (mk_case alts wild)
@@ -118,52 +117,52 @@ mkCoPrimCaseMatchResult var alts
     ((_,MatchResult _ ty1 _ cxt1) : _) = alts
 
     mk_case alts wild fail_expr
-      = CoCase (CoVar var) (CoPrimAlts final_alts (CoBindDefault wild fail_expr))
+      = Case (Var var) (PrimAlts final_alts (BindDefault wild fail_expr))
       where
-	final_alts = [ (lit, body_fn fail_expr) 
+	final_alts = [ (lit, body_fn fail_expr)
 		     | (lit, MatchResult _ _ body_fn _) <- alts
 		     ]
 
 
 mkCoAlgCaseMatchResult :: Id				-- Scrutinee
-		    -> [(DataCon, [Id], MatchResult)]	-- Alternatives    
+		    -> [(DataCon, [Id], MatchResult)]	-- Alternatives
 		    -> DsM MatchResult
 mkCoAlgCaseMatchResult var alts
   =	    -- Find all the constructors in the type which aren't
 	    -- explicitly mentioned in the alternatives:
     case un_mentioned_constructors of
 	[] ->	-- All constructors mentioned, so no default needed
-		returnDs (MatchResult can_any_alt_fail 
-			  	      ty1 
-				      (mk_case alts (\ignore -> CoNoDefault)) 
+		returnDs (MatchResult can_any_alt_fail
+			  	      ty1
+				      (mk_case alts (\ignore -> NoDefault))
 				      cxt1)
 
 	[con] ->     -- Just one constructor missing, so add a case for it
-		     -- We need to build new locals for the args of the constructor, 
+		     -- We need to build new locals for the args of the constructor,
 		     -- and figuring out their types is somewhat tiresome.
 		let
 			(_,arg_tys,_) = getInstantiatedDataConSig con tycon_arg_tys
 		in
 		newSysLocalsDs arg_tys	`thenDs` \ arg_ids ->
-    
+
 		     -- Now we are ready to construct the new alternative
 		let
 			new_alt = (con, arg_ids, MatchResult CanFail ty1 id NoMatchContext)
 		in
 		returnDs (MatchResult CanFail
-			  	      ty1 
-				      (mk_case (new_alt:alts) (\ignore -> CoNoDefault)) 
+			  	      ty1
+				      (mk_case (new_alt:alts) (\ignore -> NoDefault))
 				      cxt1)
 
 	other ->      -- Many constructors missing, so use a default case
 		newSysLocalDs scrut_ty		`thenDs` \ wild ->
 		returnDs (MatchResult CanFail
-			  	      ty1 
-				      (mk_case alts (\fail_expr -> CoBindDefault wild fail_expr))
+			  	      ty1
+				      (mk_case alts (\fail_expr -> BindDefault wild fail_expr))
 				      cxt1)
   where
-    scrut_ty = getIdUniType var
-    (tycon, tycon_arg_tys, data_cons) = getUniDataTyCon scrut_ty
+    scrut_ty = idType var
+    (tycon, tycon_arg_tys, data_cons) = getAppDataTyCon scrut_ty
 
     un_mentioned_constructors
       = uniqSetToList (mkUniqSet data_cons `minusUniqSet` mkUniqSet [ con | (con, _, _) <- alts] )
@@ -173,24 +172,24 @@ mkCoAlgCaseMatchResult var alts
     can_any_alt_fail = foldr1 orFail [can_it_fail | MatchResult can_it_fail _ _ _ <- match_results]
 
     mk_case alts deflt_fn fail_expr
-      = CoCase (CoVar var) (CoAlgAlts final_alts (deflt_fn fail_expr))
+      = Case (Var var) (AlgAlts final_alts (deflt_fn fail_expr))
       where
-	final_alts = [ (con, args, body_fn fail_expr) 
+	final_alts = [ (con, args, body_fn fail_expr)
 		     | (con, args, MatchResult _ _ body_fn _) <- alts
 		     ]
 
 
 combineMatchResults :: MatchResult -> MatchResult -> DsM MatchResult
 combineMatchResults (MatchResult CanFail      ty1 body_fn1 cxt1)
-		    (MatchResult can_it_fail2 ty2 body_fn2 cxt2) 
+		    (MatchResult can_it_fail2 ty2 body_fn2 cxt2)
   = mkFailurePair ty1		`thenDs` \ (bind_fn, duplicatable_expr) ->
     let
-	new_body_fn1 = \body1 -> CoLet (bind_fn body1) (body_fn1 duplicatable_expr)
+	new_body_fn1 = \body1 -> Let (bind_fn body1) (body_fn1 duplicatable_expr)
 	new_body_fn2 = \body2 -> new_body_fn1 (body_fn2 body2)
     in
     returnDs (MatchResult can_it_fail2 ty1 new_body_fn2 cxt1)
 
-combineMatchResults match_result1@(MatchResult CantFail ty body_fn1 cxt1) 
+combineMatchResults match_result1@(MatchResult CantFail ty body_fn1 cxt1)
 				  match_result2
   = returnDs match_result1
 
@@ -199,7 +198,7 @@ combineMatchResults match_result1@(MatchResult CantFail ty body_fn1 cxt1)
 -- need to let-bind to avoid code duplication
 combineGRHSMatchResults :: MatchResult -> MatchResult -> DsM MatchResult
 combineGRHSMatchResults (MatchResult CanFail     ty1 body_fn1 cxt1)
-		        (MatchResult can_it_fail ty2 body_fn2 cxt2) 
+			(MatchResult can_it_fail ty2 body_fn2 cxt2)
   = returnDs (MatchResult can_it_fail ty1 (\ body -> body_fn1 (body_fn2 body)) cxt1)
 
 combineGRHSMatchResults match_result1 match_result2
@@ -214,58 +213,63 @@ combineGRHSMatchResults match_result1 match_result2
 %************************************************************************
 
 \begin{code}
-dsExprToAtom :: PlainCoreExpr 				-- The argument expression
-	     -> (PlainCoreAtom -> DsM PlainCoreExpr)	-- Something taking the argument *atom*,
-							-- and delivering an expression E
-	     -> DsM PlainCoreExpr			-- Either E or let x=arg-expr in E
+dsExprToAtom :: CoreExpr		    -- The argument expression
+	     -> (CoreArg -> DsM CoreExpr)   -- Something taking the argument *atom*,
+					    -- and delivering an expression E
+	     -> DsM CoreExpr		    -- Either E or let x=arg-expr in E
 
-dsExprToAtom (CoVar v) continue_with = continue_with (CoVarAtom v)
-dsExprToAtom (CoLit v) continue_with = continue_with (CoLitAtom v)
+dsExprToAtom (Var v) continue_with = continue_with (VarArg v)
+dsExprToAtom (Lit v) continue_with = continue_with (LitArg v)
 
 dsExprToAtom arg_expr continue_with
-  = newSysLocalDs ty			`thenDs` \ arg_id ->
-    continue_with (CoVarAtom arg_id)	`thenDs` \ body   ->
-    if isUnboxedDataType ty
-    then returnDs (CoCase arg_expr (CoPrimAlts [] (CoBindDefault arg_id body)))
-    else returnDs (CoLet (CoNonRec arg_id arg_expr) body)
-  where
-    ty = typeOfCoreExpr arg_expr
+  = let
+	ty = coreExprType arg_expr
+    in
+    newSysLocalDs ty			`thenDs` \ arg_id ->
+    continue_with (VarArg arg_id)	`thenDs` \ body   ->
+    returnDs (
+	if isUnboxedDataType ty
+	then Case arg_expr (PrimAlts [] (BindDefault arg_id body))
+	else Let (NonRec arg_id arg_expr) body
+    )
 
-dsExprsToAtoms :: [PlainCoreExpr]
-	       -> ([PlainCoreAtom] -> DsM PlainCoreExpr)
-	       -> DsM PlainCoreExpr
+dsExprsToAtoms :: [CoreExpr]
+	       -> ([CoreArg] -> DsM CoreExpr)
+	       -> DsM CoreExpr
 
 dsExprsToAtoms [] continue_with
   = continue_with []
 
 dsExprsToAtoms (arg:args) continue_with
-  = dsExprToAtom   arg 	(\ arg_atom ->
-    dsExprsToAtoms args (\ arg_atoms ->
+  = dsExprToAtom   arg 	$ \ arg_atom  ->
+    dsExprsToAtoms args $ \ arg_atoms ->
     continue_with (arg_atom:arg_atoms)
-    ))
 \end{code}
 
 %************************************************************************
 %*									*
-\subsection[mkCoAppDs]{Desugarer's versions of some Core functions}
+\subsection{Desugarer's versions of some Core functions}
 %*									*
 %************************************************************************
 
-Plumb the desugarer's @UniqueSupply@ in/out of the @UniqueSupplyMonad@
+Plumb the desugarer's @UniqueSupply@ in/out of the @UniqSupply@ monad
 world.
 \begin{code}
-mkCoAppDs  :: PlainCoreExpr -> PlainCoreExpr -> DsM PlainCoreExpr
-mkCoConDs  :: Id -> [UniType] -> [PlainCoreExpr] -> DsM PlainCoreExpr
-mkCoPrimDs :: PrimOp -> [UniType] -> [PlainCoreExpr] -> DsM PlainCoreExpr
+mkAppDs  :: CoreExpr -> [Type] -> [CoreExpr] -> DsM CoreExpr
+mkConDs  :: Id       -> [Type] -> [CoreExpr] -> DsM CoreExpr
+mkPrimDs :: PrimOp   -> [Type] -> [CoreExpr] -> DsM CoreExpr
 
-mkCoAppDs fun arg_expr
-  = dsExprToAtom arg_expr (\ arg_atom -> returnDs (CoApp fun arg_atom))
+mkAppDs fun tys arg_exprs 
+  = dsExprsToAtoms arg_exprs $ \ vals ->
+    returnDs (mkApp fun [] tys vals)
 
-mkCoConDs con tys arg_exprs
-  = dsExprsToAtoms arg_exprs (\ arg_atoms -> returnDs (CoCon con tys arg_atoms))
+mkConDs con tys arg_exprs
+  = dsExprsToAtoms arg_exprs $ \ vals ->
+    returnDs (mkCon con [] tys vals)
 
-mkCoPrimDs op tys arg_exprs
-  = dsExprsToAtoms arg_exprs (\ arg_atoms -> returnDs (CoPrim op tys arg_atoms))
+mkPrimDs op tys arg_exprs
+  = dsExprsToAtoms arg_exprs $ \ vals ->
+    returnDs (mkPrim op [] tys vals)
 \end{code}
 
 %************************************************************************
@@ -295,8 +299,8 @@ mkSelectorBinds :: [TyVar]	    -- Variables wrt which the pattern is polymorphic
 		-> TypecheckedPat   -- The pattern
 		-> [(Id,Id)]	    -- Monomorphic and polymorphic binders for
 				    -- the pattern
-		-> PlainCoreExpr    -- Expression to which the pattern is bound
-		-> DsM [(Id,PlainCoreExpr)]
+		-> CoreExpr    -- Expression to which the pattern is bound
+		-> DsM [(Id,CoreExpr)]
 
 mkSelectorBinds tyvars pat locals_and_globals val_expr
   = getSrcLocDs		`thenDs` \ (src_file, src_line) ->
@@ -308,14 +312,14 @@ mkSelectorBinds tyvars pat locals_and_globals val_expr
 	let
 	    src_loc_str   = escErrorMsg ('"' : src_file) ++ "%l" ++ src_line
 	    error_string  = src_loc_str ++ "%~" --> ": pattern-match failed on an irrefutable pattern"
-	    error_msg     = mkErrorCoApp res_ty str_var error_string
+	    error_msg     = mkErrorApp res_ty str_var error_string
 	in
 	matchSimply val_expr pat res_ty local_tuple error_msg `thenDs` \ tuple_expr ->
 	mkTupleBind tyvars [] locals_and_globals tuple_expr
   where
     locals	= [local | (local, _) <- locals_and_globals]
     local_tuple = mkTupleExpr locals
-    res_ty      = typeOfCoreExpr local_tuple
+    res_ty      = coreExprType local_tuple
 
     is_simple_tuple_pat (TuplePat ps) = all is_var_pat ps
     is_simple_tuple_pat other         = False
@@ -326,7 +330,7 @@ mkSelectorBinds tyvars pat locals_and_globals val_expr
 
 We're about to match against some patterns.  We want to make some
 @Ids@ to use as match variables.  If a pattern has an @Id@ readily at
-hand, which should indeed be bound to the pattern as a whole, then use it; 
+hand, which should indeed be bound to the pattern as a whole, then use it;
 otherwise, make one up.
 \begin{code}
 selectMatchVars :: [TypecheckedPat] -> DsM [Id]
@@ -336,27 +340,23 @@ selectMatchVars pats
     var_from_pat_maybe (VarPat var)	= returnDs var
     var_from_pat_maybe (AsPat var pat)	= returnDs var
     var_from_pat_maybe (LazyPat pat)	= var_from_pat_maybe pat
-
---  var_from_pat_maybe (NPlusKPat n _ _ _ _ _) = returnDs n
--- WRONG!  We don't want to bind n to the pattern as a whole!
-
     var_from_pat_maybe other_pat
-      = newSysLocalDs (typeOfPat other_pat) -- OK, better make up one...
+      = newSysLocalDs (outPatType other_pat) -- OK, better make up one...
 \end{code}
 
 \begin{code}
 mkTupleBind :: [TyVar]	    -- Abstract wrt these...
 	-> [DictVar]	    -- ... and these
-			    
+
 	-> [(Id, Id)]	    -- Local, global pairs, equal in number
 			    -- to the size of the tuple.  The types
 			    -- of the globals is the generalisation of
 			    -- the corresp local, wrt the tyvars and dicts
-			    	
-	-> PlainCoreExpr    -- Expr whose value is a tuple; the expression
+
+	-> CoreExpr    -- Expr whose value is a tuple; the expression
 			    -- may mention the tyvars and dicts
-					
-	-> DsM [(Id, PlainCoreExpr)]	-- Bindings for the globals
+
+	-> DsM [(Id, CoreExpr)]	-- Bindings for the globals
 \end{code}
 
 The general call is
@@ -377,7 +377,7 @@ Otherwise, the result is:
 
 \begin{code}
 mkTupleBind tyvars dicts [(local,global)] tuple_expr
-  = returnDs [(global, mkCoTyLam tyvars (mkCoLam dicts tuple_expr))]
+  = returnDs [(global, mkLam tyvars dicts tuple_expr)]
 \end{code}
 
 The general case:
@@ -386,13 +386,13 @@ The general case:
 mkTupleBind tyvars dicts local_global_prs tuple_expr
   = newSysLocalDs tuple_var_ty	`thenDs` \ tuple_var ->
 
-    zipWithDs (mk_selector (CoVar tuple_var))
+    zipWithDs (mk_selector (Var tuple_var))
 	      local_global_prs
 	      [(0::Int) .. (length local_global_prs - 1)]
 				`thenDs` \ tup_selectors ->
     returnDs (
-	(tuple_var, mkCoTyLam tyvars (mkCoLam dicts tuple_expr)) :
-	tup_selectors
+	(tuple_var, mkLam tyvars dicts tuple_expr)
+	: tup_selectors
     )
   where
     locals, globals :: [Id]
@@ -402,16 +402,16 @@ mkTupleBind tyvars dicts local_global_prs tuple_expr
     no_of_binders = length local_global_prs
     tyvar_tys = map mkTyVarTy tyvars
 
-    tuple_var_ty :: UniType
+    tuple_var_ty :: Type
     tuple_var_ty
       = case (quantifyTy tyvars (mkRhoTy theta
-				  (applyTyCon (mkTupleTyCon no_of_binders) 
-					      (map getIdUniType locals)))) of
+				  (applyTyCon (mkTupleTyCon no_of_binders)
+					      (map idType locals)))) of
 	  (_{-tossed templates-}, ty) -> ty
       where
-	theta = map (splitDictType . getIdUniType) dicts
+	theta = map (splitDictType . idType) dicts
 
-    mk_selector :: PlainCoreExpr -> (Id, Id) -> Int -> DsM (Id, PlainCoreExpr)
+    mk_selector :: CoreExpr -> (Id, Id) -> Int -> DsM (Id, CoreExpr)
 
     mk_selector tuple_var_expr (local, global) which_local
       = mapDs duplicateLocalDs locals{-the whole bunch-} `thenDs` \ binders ->
@@ -419,37 +419,36 @@ mkTupleBind tyvars dicts local_global_prs tuple_expr
 	    selected = binders !! which_local
 	in
 	returnDs (
-	  (global, mkCoTyLam tyvars (
-		    mkCoLam dicts (
-		    mkTupleSelector (mkCoApp_XX (mkCoTyApps tuple_var_expr tyvar_tys) dicts)
-				    binders selected)))
+	    global,
+	    mkLam tyvars dicts (
+		mkTupleSelector (mkApp_XX (mkCoTyApps tuple_var_expr tyvar_tys) dicts)
+				binders selected)
 	)
 
-mkCoApp_XX :: PlainCoreExpr -> [Id] -> PlainCoreExpr
-mkCoApp_XX expr []	 = expr
-mkCoApp_XX expr (id:ids) = mkCoApp_XX (CoApp expr (CoVarAtom id)) ids
+mkApp_XX :: CoreExpr -> [Id] -> CoreExpr
+mkApp_XX expr []	 = expr
+mkApp_XX expr (id:ids) = mkApp_XX (App expr (VarArg id)) ids
 \end{code}
 
 
 
-@mkTupleExpr@ builds a tuple; the inverse to mkTupleSelector.  
-If it has only one element, it is
-the identity function.
-
+@mkTupleExpr@ builds a tuple; the inverse to @mkTupleSelector@.  If it
+has only one element, it is the identity function.
 \begin{code}
-mkTupleExpr :: [Id] -> PlainCoreExpr
-
-mkTupleExpr []	 = CoCon (mkTupleCon 0) [] []
-mkTupleExpr [id] = CoVar id
-mkTupleExpr ids	 = CoCon (mkTupleCon (length ids)) 
-			 (map getIdUniType ids) 
-			 [ CoVarAtom i | i <- ids ]
+mkTupleExpr :: [Id] -> CoreExpr
+
+mkTupleExpr []	 = Con (mkTupleCon 0) []
+mkTupleExpr [id] = Var id
+mkTupleExpr ids	 = mkCon (mkTupleCon (length ids))
+			 [{-usages-}]
+			 (map idType ids)
+			 [ VarArg i | i <- ids ]
 \end{code}
 
 
 @mkTupleSelector@ builds a selector which scrutises the given
 expression and extracts the one name from the list given.
-If you want the no-shadowing rule to apply, the caller 
+If you want the no-shadowing rule to apply, the caller
 is responsible for making sure that none of these names
 are in scope.
 
@@ -457,10 +456,10 @@ If there is just one id in the ``tuple'', then the selector is
 just the identity.
 
 \begin{code}
-mkTupleSelector :: PlainCoreExpr	-- Scrutinee
+mkTupleSelector :: CoreExpr	-- Scrutinee
 		-> [Id]			-- The tuple args
 		-> Id			-- The selected one
-		-> PlainCoreExpr
+		-> CoreExpr
 
 mkTupleSelector expr [] the_var = panic "mkTupleSelector"
 
@@ -468,9 +467,9 @@ mkTupleSelector expr [var] should_be_the_same_var
   = ASSERT(var == should_be_the_same_var)
     expr
 
-mkTupleSelector expr vars the_var 
- = CoCase expr (CoAlgAlts [(mkTupleCon arity, vars, CoVar the_var)]
-			  CoNoDefault)
+mkTupleSelector expr vars the_var
+ = Case expr (AlgAlts [(mkTupleCon arity, vars, Var the_var)]
+			  NoDefault)
  where
    arity = length vars
 \end{code}
@@ -515,7 +514,7 @@ there is every chance that someone will change the let into a case:
 \end{verbatim}
 
 which is of course utterly wrong.  Rather than drop the condition that
-only boxed types can be let-bound, we just turn the fail into a function 
+only boxed types can be let-bound, we just turn the fail into a function
 for the primitive case:
 \begin{verbatim}
 	let fail.33 :: () -> Int#
@@ -531,26 +530,27 @@ for the primitive case:
 Now fail.33 is a function, so it can be let-bound.
 
 \begin{code}
-mkFailurePair :: UniType		-- Result type of the whole case expression
-	      -> DsM (PlainCoreExpr -> PlainCoreBinding,
-					-- Binds the newly-created fail variable 
-					-- to either the expression or \_ -> expression
-		      PlainCoreExpr)	-- Either the fail variable, or fail variable 
-					-- applied to unit tuple
+mkFailurePair :: Type		-- Result type of the whole case expression
+	      -> DsM (CoreExpr -> CoreBinding,
+				-- Binds the newly-created fail variable
+				-- to either the expression or \ _ -> expression
+		      CoreExpr)	-- Either the fail variable, or fail variable
+				-- applied to unit tuple
 mkFailurePair ty
   | isUnboxedDataType ty
-  = newFailLocalDs (mkFunTy unit_ty ty)	`thenDs` \ fail_fun_var ->
-    newSysLocalDs unit_ty		`thenDs` \ fail_fun_arg ->
-    returnDs (\ body -> CoNonRec fail_fun_var (CoLam [fail_fun_arg] body), 
-	      CoApp (CoVar fail_fun_var) (CoVarAtom unit_id))
+  = newFailLocalDs (mkFunTys [unit_ty] ty)	`thenDs` \ fail_fun_var ->
+    newSysLocalDs unit_ty			`thenDs` \ fail_fun_arg ->
+    returnDs (\ body ->
+		NonRec fail_fun_var (Lam (ValBinder fail_fun_arg) body),
+	      App (Var fail_fun_var) (VarArg unit_id))
 
   | otherwise
   = newFailLocalDs ty 		`thenDs` \ fail_var ->
-    returnDs (\ body -> CoNonRec fail_var body, CoVar fail_var)
+    returnDs (\ body -> NonRec fail_var body, Var fail_var)
 
 unit_id :: Id	-- out here to avoid CAF (sigh)
 unit_id = mkTupleCon 0
 
-unit_ty :: UniType
-unit_ty = getIdUniType unit_id
+unit_ty :: Type
+unit_ty = idType unit_id
 \end{code}
diff --git a/ghc/compiler/deSugar/Match.hi b/ghc/compiler/deSugar/Match.hi
deleted file mode 100644
index e4e6b3f937..0000000000
--- a/ghc/compiler/deSugar/Match.hi
+++ /dev/null
@@ -1,19 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface Match where
-import Bag(Bag)
-import CmdLineOpts(GlobalSwitch, SwitchResult)
-import CoreSyn(CoreExpr)
-import DsMonad(DsMatchContext, DsMatchKind)
-import DsUtils(EquationInfo, MatchResult)
-import HsMatches(Match)
-import HsPat(TypecheckedPat)
-import Id(Id)
-import PreludePS(_PackedString)
-import SplitUniq(SplitUniqSupply)
-import SrcLoc(SrcLoc)
-import UniType(UniType)
-import UniqFM(UniqFM)
-match :: [Id] -> [EquationInfo] -> [EquationInfo] -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (MatchResult, Bag DsMatchContext)
-matchSimply :: CoreExpr Id Id -> TypecheckedPat -> UniType -> CoreExpr Id Id -> CoreExpr Id Id -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (CoreExpr Id Id, Bag DsMatchContext)
-matchWrapper :: DsMatchKind -> [Match Id TypecheckedPat] -> [Char] -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (([Id], CoreExpr Id Id), Bag DsMatchContext)
-
diff --git a/ghc/compiler/deSugar/Match.lhs b/ghc/compiler/deSugar/Match.lhs
index 5f1eaea9c8..f657e967a3 100644
--- a/ghc/compiler/deSugar/Match.lhs
+++ b/ghc/compiler/deSugar/Match.lhs
@@ -1,51 +1,44 @@
 %
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1994
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
 %
 \section[Main_match]{The @match@ function}
 
 \begin{code}
-module Match (
-	match, matchWrapper, matchSimply
-    ) where
-
 #include "HsVersions.h"
 
-import AbsSyn		-- the stuff being desugared
-import PlainCore	-- the output of desugaring;
-			-- importing this module also gets all the
-			-- CoreSyn utility functions
-import DsMonad		-- the monadery used in the desugarer
+module Match ( match, matchWrapper, matchSimply ) where
 
-import AbsPrel		( nilDataCon, consDataCon, mkTupleTy, mkListTy,
-			  charTy, charDataCon, intTy, intDataCon, floatTy,
-			  floatDataCon, doubleTy, doubleDataCon,
-			  integerTy, intPrimTy, charPrimTy,
-			  floatPrimTy, doublePrimTy, mkFunTy, stringTy,
-			  addrTy, addrPrimTy, addrDataCon,
-			  wordTy, wordPrimTy, wordDataCon
-#ifdef DPH
-			 ,mkProcessorTy
-#endif {- Data Parallel Haskell -}
-			)
-import PrimKind		( PrimKind(..) ) -- Rather ugly import; ToDo???
-
-import AbsUniType	( isPrimType )
-import DsBinds		( dsBinds )
-import DsExpr		( dsExpr )
+import Ubiq
+import DsLoop		-- here for paranoia-checking reasons
+			-- and to break dsExpr/dsBinds-ish loop
+
+import HsSyn
+import TcHsSyn		( TypecheckedPat(..), TypecheckedMatch(..),
+			  TypecheckedHsBinds(..), TypecheckedHsExpr(..)	)
+import DsHsSyn		( outPatType, collectTypedPatBinders )
+import CoreSyn
+
+import DsMonad
 import DsGRHSs		( dsGRHSs )
 import DsUtils
-#ifdef DPH
-import Id		( eqId, getIdUniType, mkTupleCon, mkProcessorCon )
-import MatchProc	( matchProcessor)
-#else
-import Id		( eqId, getIdUniType, mkTupleCon, DataCon(..), Id )
-#endif {- Data Parallel Haskell -}
-import Maybes		( Maybe(..) )
 import MatchCon		( matchConFamily )
 import MatchLit		( matchLiterals )
-import Outputable	-- all for one "panic"...
-import Pretty
-import Util
+
+import CoreUtils	( escErrorMsg, mkErrorApp )
+import Id		( idType, mkTupleCon, GenId{-instance-} )
+import PprStyle		( PprStyle(..) )
+import PprType		( GenTyVar{-instance-}, GenType{-instance-} )
+import PrelInfo		( nilDataCon, consDataCon, mkTupleTy, mkListTy,
+			  charTy, charDataCon, intTy, intDataCon,
+			  floatTy, floatDataCon, doubleTy, doubleDataCon,
+			  integerTy, intPrimTy, charPrimTy,
+			  floatPrimTy, doublePrimTy, stringTy,
+			  addrTy, addrPrimTy, addrDataCon,
+			  wordTy, wordPrimTy, wordDataCon )
+import Type		( isPrimType, eqTy )
+import TyVar		( GenTyVar )
+import Unique		( Unique )
+import Util		( panic, pprPanic )
 \end{code}
 
 The function @match@ is basically the same as in the Wadler chapter,
@@ -67,7 +60,7 @@ the $m$ equations:
 \item
 the $n$ patterns for that equation, and
 \item
-a list of Core bindings [@(Id, PlainCoreExpr)@ pairs] to be ``stuck on
+a list of Core bindings [@(Id, CoreExpr)@ pairs] to be ``stuck on
 the front'' of the matching code, as in:
 \begin{verbatim}
 let <binds>
@@ -90,11 +83,11 @@ showed no benefit.
 \item
 A default expression---what to evaluate if the overall pattern-match
 fails.  This expression will (almost?) always be
-a measly expression @CoVar@, unless we know it will only be used once
+a measly expression @Var@, unless we know it will only be used once
 (as we do in @glue_success_exprs@).
 
 Leaving out this third argument to @match@ (and slamming in lots of
-@CoVar "fail"@s) is a positively {\em bad} idea, because it makes it
+@Var "fail"@s) is a positively {\em bad} idea, because it makes it
 impossible to share the default expressions.  (Also, it stands no
 chance of working in our post-upheaval world of @Locals@.)
 \end{enumerate}
@@ -159,14 +152,14 @@ match [] eqns_info shadows
 	returnDs match_result
     else
 	returnDs match_result
-	
+
   where
     pin_eqns [EqnInfo [] match_result] = returnDs match_result
       -- Last eqn... can't have pats ...
 
     pin_eqns (EqnInfo [] match_result1 : more_eqns)
       = pin_eqns more_eqns 			`thenDs` \ match_result2 ->
-        combineMatchResults match_result1 match_result2
+	combineMatchResults match_result1 match_result2
 
     pin_eqns other_pat = panic "match: pin_eqns"
 
@@ -199,7 +192,7 @@ corresponds roughly to @matchVarCon@.
 match vars@(v:vs) eqns_info shadows
   = mapDs (tidyEqnInfo v) eqns_info	`thenDs` \ tidy_eqns_info ->
     mapDs (tidyEqnInfo v) shadows	`thenDs` \ tidy_shadows ->
-    let  
+    let
 	tidy_eqns_blks = unmix_eqns tidy_eqns_info
     in
     match_unmixed_eqn_blks vars tidy_eqns_blks tidy_shadows
@@ -261,12 +254,12 @@ The @VarPat@ information isn't needed any more after this.
 \item[@ConPats@:]
 @ListPats@, @TuplePats@, etc., are all converted into @ConPats@.
 
-\item[@LitPats@ and @NPats@ (and @NPlusKPats@):]
-@LitPats@/@NPats@/@NPlusKPats@ of ``known friendly types'' (Int, Char,
+\item[@LitPats@ and @NPats@:]
+@LitPats@/@NPats@ of ``known friendly types'' (Int, Char,
 Float, 	Double, at least) are converted to unboxed form; e.g.,
-\tr{(NPat (IntLit i) _ _)} is converted to:
+\tr{(NPat (HsInt i) _ _)} is converted to:
 \begin{verbatim}
-(ConPat I# _ _ [LitPat (IntPrimLit i) _])
+(ConPat I# _ _ [LitPat (HsIntPrim i) _])
 \end{verbatim}
 \end{description}
 
@@ -288,17 +281,17 @@ tidy1 :: Id 					-- The Id being scrutinised
 						-- of new bindings to be added to the front
 
 tidy1 v (VarPat var) match_result
-  = returnDs (WildPat (getIdUniType var),
+  = returnDs (WildPat (idType var),
 	      mkCoLetsMatchResult extra_binds match_result)
   where
-    extra_binds | v `eqId` var = []
-		| otherwise    = [CoNonRec var (CoVar v)]
+    extra_binds | v == var  = []
+		| otherwise = [NonRec var (Var v)]
 
 tidy1 v (AsPat var pat) match_result
   = tidy1 v pat (mkCoLetsMatchResult extra_binds match_result)
   where
-    extra_binds | v `eqId` var = []
-		| otherwise    = [CoNonRec var (CoVar v)]
+    extra_binds | v == var  = []
+		| otherwise = [NonRec var (Var v)]
 
 tidy1 v (WildPat ty) match_result
   = returnDs (WildPat ty, match_result)
@@ -311,13 +304,13 @@ tidy1 v (WildPat ty) match_result
 
     ToDo: in "v_i = ... -> v_i", are the v_i's really the same thing?
 
-    The case expr for v_i is just: match [v] [(p, [], \ x -> CoVar v_i)] any_expr
+    The case expr for v_i is just: match [v] [(p, [], \ x -> Var v_i)] any_expr
 -}
 
 tidy1 v (LazyPat pat) match_result
-  = mkSelectorBinds [] pat l_to_l (CoVar v)	`thenDs` \ sel_binds ->
-    returnDs (WildPat (getIdUniType v), 
-	      mkCoLetsMatchResult [CoNonRec b rhs | (b,rhs) <- sel_binds] match_result)
+  = mkSelectorBinds [] pat l_to_l (Var v)	`thenDs` \ sel_binds ->
+    returnDs (WildPat (idType v),
+	      mkCoLetsMatchResult [NonRec b rhs | (b,rhs) <- sel_binds] match_result)
   where
     l_to_l = binders `zip` binders 	-- Boring
     binders = collectTypedPatBinders pat
@@ -342,22 +335,18 @@ tidy1 v (TuplePat pats) match_result
     arity = length pats
     tuple_ConPat
       = ConPat (mkTupleCon arity)
-	       (mkTupleTy arity (map typeOfPat pats))
+	       (mkTupleTy arity (map outPatType pats))
 	       pats
 
-#ifdef DPH
-tidy1 v (ProcessorPat pats convs pat) match_result
-  = returnDs ((ProcessorPat pats convs pat), match_result)
-{-
-tidy1 v (ProcessorPat pats _ _ pat) match_result
-  = returnDs (processor_ConPat, match_result)
+tidy1 v (DictPat dicts methods) match_result
+  = case num_of_d_and_ms of
+	0 -> tidy1 v (TuplePat []) match_result
+	1 -> tidy1 v (head dict_and_method_pats) match_result
+	_ -> tidy1 v (TuplePat dict_and_method_pats) match_result
   where
-    processor_ConPat
-      = ConPat (mkProcessorCon (length pats))
-	       (mkProcessorTy (map typeOfPat pats) (typeOfPat pat))
-	       (pats++[pat])
--}
-#endif {- Data Parallel Haskell -}
+    num_of_d_and_ms	 = length dicts + length methods
+    dict_and_method_pats = map VarPat (dicts ++ methods)
+
 
 -- deeply ugly mangling for some (common) NPats/LitPats
 
@@ -367,61 +356,45 @@ tidy1 v pat@(LitPat lit lit_ty) match_result
   | isPrimType lit_ty
   = returnDs (pat, match_result)
 
-  | lit_ty == charTy
+  | lit_ty `eqTy` charTy
   = returnDs (ConPat charDataCon charTy [LitPat (mk_char lit) charPrimTy],
 	      match_result)
 
   | otherwise = pprPanic "tidy1:LitPat:" (ppr PprDebug pat)
   where
-    mk_char (CharLit c)    = CharPrimLit c
+    mk_char (HsChar c)    = HsCharPrim c
 
 -- NPats: we *might* be able to replace these w/ a simpler form
 
 tidy1 v pat@(NPat lit lit_ty _) match_result
   = returnDs (better_pat, match_result)
   where
-    better_pat 
-      | lit_ty == charTy   = ConPat charDataCon   lit_ty [LitPat (mk_char lit)   charPrimTy]
-      | lit_ty == intTy    = ConPat intDataCon    lit_ty [LitPat (mk_int lit)    intPrimTy]
-      | lit_ty == wordTy   = ConPat wordDataCon   lit_ty [LitPat (mk_word lit)   wordPrimTy]
-      | lit_ty == addrTy   = ConPat addrDataCon   lit_ty [LitPat (mk_addr lit)   addrPrimTy]
-      | lit_ty == floatTy  = ConPat floatDataCon  lit_ty [LitPat (mk_float lit)  floatPrimTy]
-      | lit_ty == doubleTy = ConPat doubleDataCon lit_ty [LitPat (mk_double lit) doublePrimTy]
+    better_pat
+      | lit_ty `eqTy` charTy   = ConPat charDataCon   lit_ty [LitPat (mk_char lit)   charPrimTy]
+      | lit_ty `eqTy` intTy    = ConPat intDataCon    lit_ty [LitPat (mk_int lit)    intPrimTy]
+      | lit_ty `eqTy` wordTy   = ConPat wordDataCon   lit_ty [LitPat (mk_word lit)   wordPrimTy]
+      | lit_ty `eqTy` addrTy   = ConPat addrDataCon   lit_ty [LitPat (mk_addr lit)   addrPrimTy]
+      | lit_ty `eqTy` floatTy  = ConPat floatDataCon  lit_ty [LitPat (mk_float lit)  floatPrimTy]
+      | lit_ty `eqTy` doubleTy = ConPat doubleDataCon lit_ty [LitPat (mk_double lit) doublePrimTy]
       | otherwise	   = pat
 
-    mk_int    (IntLit i) = IntPrimLit i
-    mk_int    l@(LitLitLit s _) = l
-	      
-    mk_char   (CharLit c)= CharPrimLit c
-    mk_char   l@(LitLitLit s _) = l
-	      
-    mk_word   l@(LitLitLit s _) = l
-
-    mk_addr   l@(LitLitLit s _) = l
-
-    mk_float  (IntLit i) = FloatPrimLit (fromInteger i)
-#if __GLASGOW_HASKELL__ <= 22
-    mk_float  (FracLit f)= FloatPrimLit (fromRational f) -- ToDo???
-#else
-    mk_float  (FracLit f)= FloatPrimLit f
-#endif
-    mk_float  l@(LitLitLit s _) = l
-	      
-    mk_double (IntLit i) = DoublePrimLit (fromInteger i)
-#if __GLASGOW_HASKELL__ <= 22
-    mk_double (FracLit f)= DoublePrimLit (fromRational f) -- ToDo???
-#else
-    mk_double (FracLit f)= DoublePrimLit f
-#endif
-    mk_double l@(LitLitLit s _) = l
-
-{- OLD: and wrong!  I don't think we can do anything 
-   useful with n+k patterns, so drop through to default case
-
-tidy1 v pat@(NPlusKPat n k lit_ty and so on) match_result
-  = returnDs (NPlusKPat v k lit_ty and so on,
-	      (if v `eqId` n then id else (mkCoLet (CoNonRec n (CoVar v)))) . match_result)
--}
+    mk_int    (HsInt i)      = HsIntPrim i
+    mk_int    l@(HsLitLit s) = l
+
+    mk_char   (HsChar c)     = HsCharPrim c
+    mk_char   l@(HsLitLit s) = l
+
+    mk_word   l@(HsLitLit s) = l
+
+    mk_addr   l@(HsLitLit s) = l
+
+    mk_float  (HsInt i)      = HsFloatPrim (fromInteger i)
+    mk_float  (HsFrac f)     = HsFloatPrim f
+    mk_float  l@(HsLitLit s) = l
+
+    mk_double (HsInt i)      = HsDoublePrim (fromInteger i)
+    mk_double (HsFrac f)     = HsDoublePrim f
+    mk_double l@(HsLitLit s) = l
 
 -- and everything else goes through unchanged...
 
@@ -518,12 +491,6 @@ matchUnmixedEqns all_vars@(var:vars) eqns_info shadows
   =	-- Real true variables, just like in matchVar, SLPJ p 94
     match vars remaining_eqns_info remaining_shadows
 
-#ifdef DPH
-  | patsAreAllProcessor column_1_pats
-  =	-- ToDo: maybe check just one...
-    matchProcessor all_vars eqns_info
-#endif {- Data Parallel Haskell -}
-
   | patsAreAllCons column_1_pats	-- ToDo: maybe check just one...
   = matchConFamily all_vars eqns_info shadows
 
@@ -536,7 +503,7 @@ matchUnmixedEqns all_vars@(var:vars) eqns_info shadows
   where
     column_1_pats 	= [pat                       | EqnInfo (pat:_)  _            <- eqns_info]
     remaining_eqns_info = [EqnInfo pats match_result | EqnInfo (_:pats) match_result <- eqns_info]
-    remaining_shadows   = [EqnInfo pats match_result | EqnInfo (pat:pats) match_result <- shadows, 
+    remaining_shadows   = [EqnInfo pats match_result | EqnInfo (pat:pats) match_result <- shadows,
 						       irrefutablePat pat ]
 	-- Discard shadows which can be refuted, since they don't shadow
 	-- a variable
@@ -567,7 +534,7 @@ As results, @matchWrapper@ produces:
 A list of variables (@Locals@) that the caller must ``promise'' to
 bind to appropriate values; and
 \item
-a @PlainCoreExpr@, the desugared output (main result).
+a @CoreExpr@, the desugared output (main result).
 \end{itemize}
 
 The main actions of @matchWrapper@ include:
@@ -590,7 +557,7 @@ Call @match@ with all of this information!
 matchWrapper :: DsMatchKind			-- For shadowing warning messages
 	     -> [TypecheckedMatch]		-- Matches being desugared
 	     -> String 				-- Error message if the match fails
-	     -> DsM ([Id], PlainCoreExpr) 	-- Results
+	     -> DsM ([Id], CoreExpr) 	-- Results
 
 -- a special case for the common ...:
 --	just one Match
@@ -620,13 +587,13 @@ matchWrapper kind matches error_string
   = flattenMatches kind matches	`thenDs` \ eqns_info@(EqnInfo arg_pats (MatchResult _ result_ty _ _) : _) ->
 
     selectMatchVars arg_pats	`thenDs` \ new_vars ->
-    match new_vars eqns_info []	`thenDs` \ match_result -> 
+    match new_vars eqns_info []	`thenDs` \ match_result ->
 
     getSrcLocDs			`thenDs` \ (src_file, src_line) ->
     newSysLocalDs stringTy	`thenDs` \ str_var -> -- to hold the String
     let
 	src_loc_str = escErrorMsg ('"' : src_file) ++ "%l" ++ src_line
-	fail_expr   = mkErrorCoApp result_ty str_var (src_loc_str++": "++error_string)
+	fail_expr   = mkErrorApp result_ty str_var (src_loc_str++": "++error_string)
     in
     extractMatchResult match_result fail_expr	`thenDs` \ result_expr ->
     returnDs (new_vars, result_expr)
@@ -643,27 +610,27 @@ situation where we want to match a single expression against a single
 pattern. It returns an expression.
 
 \begin{code}
-matchSimply :: PlainCoreExpr			-- Scrutinee
+matchSimply :: CoreExpr			-- Scrutinee
 	    -> TypecheckedPat			-- Pattern it should match
-	    -> UniType				-- Type of result
-	    -> PlainCoreExpr			-- Return this if it matches
-	    -> PlainCoreExpr			-- Return this if it does
-	    -> DsM PlainCoreExpr
+	    -> Type				-- Type of result
+	    -> CoreExpr			-- Return this if it matches
+	    -> CoreExpr			-- Return this if it does
+	    -> DsM CoreExpr
 
-matchSimply (CoVar var) pat result_ty result_expr fail_expr
+matchSimply (Var var) pat result_ty result_expr fail_expr
   = match [var] [eqn_info] []	`thenDs` \ match_result ->
     extractMatchResult match_result fail_expr
   where
     eqn_info = EqnInfo [pat] initial_match_result
-    initial_match_result = MatchResult CantFail 
+    initial_match_result = MatchResult CantFail
 				       result_ty
-				       (\ ignore -> result_expr) 
+				       (\ ignore -> result_expr)
 				       NoMatchContext
-    
+
 matchSimply scrut_expr pat result_ty result_expr msg
-  = newSysLocalDs (typeOfPat pat) 				`thenDs` \ scrut_var ->
-    matchSimply (CoVar scrut_var) pat result_ty result_expr msg	`thenDs` \ expr ->
-    returnDs (CoLet (CoNonRec scrut_var scrut_expr) expr)
+  = newSysLocalDs (outPatType pat) 				`thenDs` \ scrut_var ->
+    matchSimply (Var scrut_var) pat result_ty result_expr msg	`thenDs` \ expr ->
+    returnDs (Let (NonRec scrut_var scrut_expr) expr)
 
 
 extractMatchResult (MatchResult CantFail _ match_fn _) fail_expr
@@ -671,7 +638,7 @@ extractMatchResult (MatchResult CantFail _ match_fn _) fail_expr
 
 extractMatchResult (MatchResult CanFail result_ty match_fn _) fail_expr
   = mkFailurePair result_ty 	`thenDs` \ (fail_bind_fn, if_it_fails) ->
-    returnDs (CoLet (fail_bind_fn fail_expr) (match_fn if_it_fails))
+    returnDs (Let (fail_bind_fn fail_expr) (match_fn if_it_fails))
 \end{code}
 
 %************************************************************************
@@ -697,7 +664,7 @@ flattenMatches kind (match : matches)
     returnDs (eqn_info : eqn_infos)
   where
     flatten_match :: [TypecheckedPat] 		-- Reversed list of patterns encountered so far
-		  -> TypecheckedMatch 
+		  -> TypecheckedMatch
 		  -> DsM EquationInfo
 
     flatten_match pats_so_far (PatMatch pat match)
diff --git a/ghc/compiler/deSugar/MatchCon.hi b/ghc/compiler/deSugar/MatchCon.hi
deleted file mode 100644
index 2c6cedf523..0000000000
--- a/ghc/compiler/deSugar/MatchCon.hi
+++ /dev/null
@@ -1,14 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface MatchCon where
-import Bag(Bag)
-import CmdLineOpts(GlobalSwitch, SwitchResult)
-import CoreSyn(CoreExpr)
-import DsMonad(DsMatchContext)
-import DsUtils(EquationInfo, MatchResult)
-import Id(Id)
-import PreludePS(_PackedString)
-import SplitUniq(SplitUniqSupply)
-import SrcLoc(SrcLoc)
-import UniqFM(UniqFM)
-matchConFamily :: [Id] -> [EquationInfo] -> [EquationInfo] -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (MatchResult, Bag DsMatchContext)
-
diff --git a/ghc/compiler/deSugar/MatchCon.lhs b/ghc/compiler/deSugar/MatchCon.lhs
index 80b16eace1..11dbd1d99a 100644
--- a/ghc/compiler/deSugar/MatchCon.lhs
+++ b/ghc/compiler/deSugar/MatchCon.lhs
@@ -1,42 +1,30 @@
 %
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
 %
 \section[MatchCon]{Pattern-matching constructors}
 
 \begin{code}
 #include "HsVersions.h"
 
-module MatchCon (
-    matchConFamily
-) where
-
-import AbsSyn		-- the stuff being desugared
-import PlainCore	-- the output of desugaring;
-			-- importing this module also gets all the
-			-- CoreSyn utility functions
-import DsMonad		-- the monadery used in the desugarer
-
-import AbsUniType	( mkTyVarTy, splitType, TyVar, TyVarTemplate,
-			  getTyConDataCons,
-			  instantiateTauTy, TyCon, Class, UniType,
-			  TauType(..), InstTyEnv(..)
-			  IF_ATTACK_PRAGMAS(COMMA instantiateTy)
-			)
+module MatchCon ( matchConFamily ) where
+
+import Ubiq
+import DsLoop		( match )	-- break match-ish loop
+
+import HsSyn		( OutPat(..), HsLit, HsExpr )
+import DsHsSyn		( outPatType )
+
+import DsMonad
 import DsUtils
-import Id		( eqId, getInstantiatedDataConSig,
-			  getIdUniType, isDataCon, DataCon(..)
-			)
-import Maybes		( Maybe(..) )
-import Match		( match )
-import Util
-\end{code}
 
-\subsection[matchConFamily]{Making alternatives for a constructor family}
+import Id		( isDataCon, GenId{-instances-} )
+import Util		( panic, assertPanic )
+\end{code}
 
 We are confronted with the first column of patterns in a set of
 equations, all beginning with constructors from one ``family'' (e.g.,
 @[]@ and @:@ make up the @List@ ``family'').  We want to generate the
-alternatives for a @CoCase@ expression.  There are several choices:
+alternatives for a @Case@ expression.  There are several choices:
 \begin{enumerate}
 \item
 Generate an alternative for every constructor in the family, whether
@@ -44,13 +32,12 @@ they are used in this set of equations or not; this is what the Wadler
 chapter does.
 \begin{description}
 \item[Advantages:]
-(a)~Simple.  (b)~It may also be that large sparsely-used constructor families are mainly
-handled by the code for literals.
+(a)~Simple.  (b)~It may also be that large sparsely-used constructor
+families are mainly handled by the code for literals.
 \item[Disadvantages:]
-(a)~Not practical for large sparsely-used constructor families, e.g., the
-ASCII character set.  (b)~Have to look up (in the TDE environment) a
-list of what constructors make up the whole family.  So far, this is
-the only part of desugaring that needs information from the environments.
+(a)~Not practical for large sparsely-used constructor families, e.g.,
+the ASCII character set.  (b)~Have to look up a list of what
+constructors make up the whole family.
 \end{description}
 
 \item
@@ -77,12 +64,12 @@ which should be amenable to optimisation.  Tuples are a common example.
 \end{description}
 \end{enumerate}
 
-We are implementing the ``do-it-right'' option for now.
-The arguments to @matchConFamily@ are the same as to @match@; the extra
-@Int@ returned is the number of constructors in the family.
+We are implementing the ``do-it-right'' option for now.  The arguments
+to @matchConFamily@ are the same as to @match@; the extra @Int@
+returned is the number of constructors in the family.
 
 The function @matchConFamily@ is concerned with this
-have-we-used-all-the-constructors question; the local function
+have-we-used-all-the-constructors? question; the local function
 @match_cons_used@ does all the real work.
 \begin{code}
 matchConFamily :: [Id]
@@ -95,8 +82,9 @@ matchConFamily (var:vars) eqns_info shadows
     mkCoAlgCaseMatchResult var alts
 \end{code}
 
-And here is the local function that does all the work.  It is more-or-less the
-@matchCon@/@matchClause@ functions on page~94 in Wadler's chapter in SLPJ.
+And here is the local function that does all the work.  It is
+more-or-less the @matchCon@/@matchClause@ functions on page~94 in
+Wadler's chapter in SLPJ.
 \begin{code}
 match_cons_used _ [{- no more eqns -}] _ = returnDs []
 
@@ -114,8 +102,8 @@ match_cons_used vars eqns_info@(EqnInfo (ConPat data_con _ arg_pats : ps1) _ : e
     selectMatchVars arg_pats						`thenDs` \ new_vars ->
 
     -- Now do the business to make the alt for _this_ ConPat ...
-    match (new_vars++vars) 
-	  (map shift_con_pat eqns_for_this_con)	
+    match (new_vars++vars)
+	  (map shift_con_pat eqns_for_this_con)
 	  (map shift_con_pat shadows_for_this_con)			`thenDs` \ match_result ->
 
     returnDs (
@@ -125,13 +113,13 @@ match_cons_used vars eqns_info@(EqnInfo (ConPat data_con _ arg_pats : ps1) _ : e
   where
     splitByCon :: [EquationInfo] -> ([EquationInfo], [EquationInfo])
     splitByCon [] = ([],[])
-    splitByCon (info@(EqnInfo (pat : _) _) : rest) 
+    splitByCon (info@(EqnInfo (pat : _) _) : rest)
 	= case pat of
-		ConPat n _ _ | n `eqId` data_con -> (info:rest_yes, rest_no)
-		WildPat _			 -> (info:rest_yes, info:rest_no)
-			-- WildPats will be in the shadows only, 
+		ConPat n _ _ | n == data_con -> (info:rest_yes, rest_no)
+		WildPat _		     -> (info:rest_yes, info:rest_no)
+			-- WildPats will be in the shadows only,
 			-- and they go into both groups
-		other_pat			 -> (rest_yes,      info:rest_no)
+		other_pat		     -> (rest_yes,      info:rest_no)
 	where
 	  (rest_yes, rest_no) = splitByCon rest
 
@@ -139,7 +127,7 @@ match_cons_used vars eqns_info@(EqnInfo (ConPat data_con _ arg_pats : ps1) _ : e
     shift_con_pat (EqnInfo (ConPat _ _ pats': pats) match_result)
       = EqnInfo (pats' ++ pats) match_result
     shift_con_pat (EqnInfo (WildPat _: pats) match_result)	-- Will only happen in shadow
-      = EqnInfo ([WildPat (typeOfPat arg_pat) | arg_pat <- arg_pats] ++ pats) match_result
+      = EqnInfo ([WildPat (outPatType arg_pat) | arg_pat <- arg_pats] ++ pats) match_result
     shift_con_pat other = panic "matchConFamily:match_cons_used:shift_con_pat"
 \end{code}
 
diff --git a/ghc/compiler/deSugar/MatchLit.hi b/ghc/compiler/deSugar/MatchLit.hi
deleted file mode 100644
index 9b3e4765a6..0000000000
--- a/ghc/compiler/deSugar/MatchLit.hi
+++ /dev/null
@@ -1,14 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface MatchLit where
-import Bag(Bag)
-import CmdLineOpts(GlobalSwitch, SwitchResult)
-import CoreSyn(CoreExpr)
-import DsMonad(DsMatchContext)
-import DsUtils(EquationInfo, MatchResult)
-import Id(Id)
-import PreludePS(_PackedString)
-import SplitUniq(SplitUniqSupply)
-import SrcLoc(SrcLoc)
-import UniqFM(UniqFM)
-matchLiterals :: [Id] -> [EquationInfo] -> [EquationInfo] -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (MatchResult, Bag DsMatchContext)
-
diff --git a/ghc/compiler/deSugar/MatchLit.lhs b/ghc/compiler/deSugar/MatchLit.lhs
index 31d8be74cb..52bb3a6ed5 100644
--- a/ghc/compiler/deSugar/MatchLit.lhs
+++ b/ghc/compiler/deSugar/MatchLit.lhs
@@ -1,29 +1,28 @@
 %
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
 %
-\section[MatchLit]{Pattern-matching literal and n+k patterns}
+\section[MatchLit]{Pattern-matching literal patterns}
 
 \begin{code}
 #include "HsVersions.h"
 
-module MatchLit (
-	matchLiterals
-    ) where
+module MatchLit ( matchLiterals ) where
 
-import AbsSyn		-- the stuff being desugared
-import PlainCore	-- the output of desugaring;
-			-- importing this module also gets all the
-			-- CoreSyn utility functions
-import DsMonad		-- the monadery used in the desugarer
+import Ubiq
+import DsLoop		-- break match-ish and dsExpr-ish loops
 
-import AbsUniType	( isPrimType, getUniDataTyCon, kindFromType )
-import BasicLit		( mkMachInt, BasicLit(..), PrimKind )
-import DsExpr		( dsExpr )
+import HsSyn		( HsLit(..), OutPat(..), HsExpr(..),
+			  Match, HsBinds, Stmt, Qual, PolyType, ArithSeqInfo )
+import TcHsSyn		( TypecheckedHsExpr(..) )
+import CoreSyn		( CoreExpr(..) )
+
+import DsMonad
 import DsUtils
-import Maybes		( Maybe(..), catMaybes )
-import Match		( match )
-import Id		( getIdUniType, eqId )
-import Util
+
+import Literal		( mkMachInt, Literal(..) )
+import Maybes		( catMaybes )
+import Type		( isPrimType )
+import Util		( panic, assertPanic )
 \end{code}
 
 \begin{code}
@@ -50,12 +49,12 @@ matchLiterals all_vars@(var:vars) eqns_info@(EqnInfo (LitPat literal lit_ty : ps
   where
     match_prims_used _ [{-no more eqns-}] _ = returnDs []
 
-    match_prims_used vars eqns_info@(EqnInfo ((LitPat literal _):ps1) _ : eqns) shadows
+    match_prims_used vars eqns_info@(EqnInfo ((LitPat literal lit_ty):ps1) _ : eqns) shadows
       = let
 	    (shifted_eqns_for_this_lit, eqns_not_for_this_lit)
-	      = partitionEqnsByLit Nothing literal eqns_info
+	      = partitionEqnsByLit literal eqns_info
 	    (shifted_shadows_for_this_lit, shadows_not_for_this_lit)
-	      = partitionEqnsByLit Nothing literal shadows
+	      = partitionEqnsByLit literal shadows
 	in
 	-- recursive call to make other alts...
 	match_prims_used vars eqns_not_for_this_lit shadows_not_for_this_lit	`thenDs` \ rest_of_alts ->
@@ -64,38 +63,38 @@ matchLiterals all_vars@(var:vars) eqns_info@(EqnInfo (LitPat literal lit_ty : ps
 	-- now do the business to make the alt for _this_ LitPat ...
 	match vars shifted_eqns_for_this_lit shifted_shadows_for_this_lit	`thenDs` \ match_result ->
 	returnDs (
-	    (mk_core_lit literal, match_result)
+	    (mk_core_lit lit_ty literal, match_result)
 	    : rest_of_alts
 	)
       where
-	mk_core_lit :: Literal -> BasicLit
-
-	mk_core_lit (IntPrimLit     i) = mkMachInt  i
-	mk_core_lit (CharPrimLit    c) = MachChar   c
-	mk_core_lit (StringPrimLit  s) = MachStr    s
-	mk_core_lit (FloatPrimLit   f) = MachFloat  f
-	mk_core_lit (DoublePrimLit  d) = MachDouble d
-	mk_core_lit (LitLitLit    s t) = ASSERT(isPrimType t)
-					 MachLitLit s (kindFromType t)
-    	mk_core_lit other	       = panic "matchLiterals:mk_core_lit:unhandled"
+	mk_core_lit :: Type -> HsLit -> Literal
+
+	mk_core_lit ty (HsIntPrim     i) = mkMachInt  i
+	mk_core_lit ty (HsCharPrim    c) = MachChar   c
+	mk_core_lit ty (HsStringPrim  s) = MachStr    s
+	mk_core_lit ty (HsFloatPrim   f) = MachFloat  f
+	mk_core_lit ty (HsDoublePrim  d) = MachDouble d
+	mk_core_lit ty (HsLitLit      s) = ASSERT(isPrimType ty)
+					   MachLitLit s (panic "MatchLit.matchLiterals:mk_core_lit:HsLitLit; primRepFromType???")
+    	mk_core_lit ty other	         = panic "matchLiterals:mk_core_lit:unhandled"
 \end{code}
 
 \begin{code}
 matchLiterals all_vars@(var:vars) eqns_info@(EqnInfo ((NPat literal lit_ty eq_chk):ps1) _ : eqns) shadows
   = let
 	(shifted_eqns_for_this_lit, eqns_not_for_this_lit)
-	  = partitionEqnsByLit Nothing literal eqns_info
+	  = partitionEqnsByLit literal eqns_info
 	(shifted_shadows_for_this_lit, shadows_not_for_this_lit)
-	      = partitionEqnsByLit Nothing literal shadows
+	  = partitionEqnsByLit literal shadows
     in
-    dsExpr (App eq_chk (Var var))					`thenDs` \ pred_expr ->
+    dsExpr (HsApp eq_chk (HsVar var))					`thenDs` \ pred_expr ->
     match vars shifted_eqns_for_this_lit shifted_shadows_for_this_lit	`thenDs` \ inner_match_result ->
     mkGuardedMatchResult pred_expr inner_match_result			`thenDs` \ match_result1 ->
 
     if (null eqns_not_for_this_lit)
-    then 
+    then
 	returnDs match_result1
-    else 
+    else
 	matchLiterals all_vars eqns_not_for_this_lit shadows_not_for_this_lit 	`thenDs` \ match_result2 ->
 	combineMatchResults match_result1 match_result2
 \end{code}
@@ -110,45 +109,12 @@ We generate:
 	<try-next-pattern-or-whatever>
 \end{verbatim}
 
-\begin{code}
-matchLiterals all_vars@(var:vars) eqns_info@(EqnInfo ((NPlusKPat master_n k ty from_lit ge sub):ps1) _ : eqns) shadows
-  = let
-	(shifted_eqns_for_this_lit, eqns_not_for_this_lit)
-	  = partitionEqnsByLit (Just master_n) k eqns_info
-	(shifted_shadows_for_this_lit, shadows_not_for_this_lit)
-	  = partitionEqnsByLit (Just master_n) k shadows
-    in
-    match vars shifted_eqns_for_this_lit shifted_shadows_for_this_lit	`thenDs` \ inner_match_result ->
-
-    dsExpr from_lit			`thenDs` \ core_lit ->
-    dsExpr (App ge (Var var))		`thenDs` \ var_ge ->
-    dsExpr (App sub (Var var))		`thenDs` \ var_sub ->
-    mkCoAppDs var_ge  core_lit		`thenDs` \ var_ge_lit ->
-    mkCoAppDs var_sub core_lit		`thenDs` \ var_sub_lit ->
-
-    mkGuardedMatchResult
-	var_ge_lit
-	(mkCoLetsMatchResult [CoNonRec master_n var_sub_lit] inner_match_result)
-					`thenDs` \ match_result1 ->
-
-    if (null eqns_not_for_this_lit)
-    then 
-	returnDs match_result1
-    else 
-	matchLiterals all_vars eqns_not_for_this_lit shadows_not_for_this_lit 	`thenDs` \ match_result2 ->
-	combineMatchResults match_result1 match_result2
-\end{code}
-
-Given a blob of LitPats/NPats/NPlusKPats, we want to split them into those
+Given a blob of LitPats/NPats, we want to split them into those
 that are ``same''/different as one we are looking at.  We need to know
-whether we're looking at a LitPat/NPat or NPlusKPat (initial Bool arg is
-@True@ for the latter), and what literal we're after.
+whether we're looking at a LitPat/NPat, and what literal we're after.
 
 \begin{code}
-partitionEqnsByLit :: Maybe Id	-- (Just v) for N-plus-K patterns, where v
-				-- is the "master" variable;
-				-- Nothing for NPats and LitPats
-		   -> Literal
+partitionEqnsByLit :: HsLit
 		   -> [EquationInfo]
 		   -> ([EquationInfo], 	-- These ones are for this lit, AND
 					-- they've been "shifted" by stripping
@@ -157,49 +123,40 @@ partitionEqnsByLit :: Maybe Id	-- (Just v) for N-plus-K patterns, where v
 					-- are exactly as fed in.
 		      )
 
-partitionEqnsByLit want_NPlusK lit eqns
+partitionEqnsByLit lit eqns
   = ( \ (xs,ys) -> (catMaybes xs, catMaybes ys))
-	(unzip (map (partition_eqn want_NPlusK lit) eqns))
+	(unzip (map (partition_eqn lit) eqns))
   where
-    partition_eqn :: Maybe Id -> Literal -> EquationInfo ->
+    partition_eqn :: HsLit -> EquationInfo ->
 		(Maybe EquationInfo, Maybe EquationInfo)
 
-    partition_eqn Nothing lit (EqnInfo (LitPat k _ : remaining_pats) match_result)
+    partition_eqn lit (EqnInfo (LitPat k _ : remaining_pats) match_result)
       | lit `eq_lit` k  = (Just (EqnInfo remaining_pats match_result), Nothing)
 			  -- NB the pattern is stripped off thhe EquationInfo
 
-    partition_eqn Nothing lit (EqnInfo (NPat k _ _ : remaining_pats) match_result)
+    partition_eqn lit (EqnInfo (NPat k _ _ : remaining_pats) match_result)
       | lit `eq_lit` k  = (Just (EqnInfo remaining_pats match_result), Nothing)
 			  -- NB the pattern is stripped off thhe EquationInfo
 
-    partition_eqn (Just master_n) lit  (EqnInfo (NPlusKPat n k _ _ _ _ : remaining_pats) match_result)
-      | lit `eq_lit` k  = (Just (EqnInfo remaining_pats new_match_result), Nothing)
-			  -- NB the pattern is stripped off thhe EquationInfo
-      where
-	new_match_result = if master_n `eqId` n then 
-				match_result
-			   else 
-				mkCoLetsMatchResult [CoNonRec n (CoVar master_n)] match_result
-
 	-- Wild-card patterns, which will only show up in the shadows, go into both groups
-    partition_eqn wantNPlusK lit eqn@(EqnInfo (WildPat _ : remaining_pats) match_result) 
+    partition_eqn lit eqn@(EqnInfo (WildPat _ : remaining_pats) match_result)
 			= (Just (EqnInfo remaining_pats match_result), Just eqn)
 
 	-- Default case; not for this pattern
-    partition_eqn wantNPlusK lit eqn = (Nothing, Just eqn)
+    partition_eqn lit eqn = (Nothing, Just eqn)
 
 -- ToDo: meditate about this equality business...
 
-eq_lit (IntLit  i1)   	  (IntLit  i2)       = i1 == i2
-eq_lit (FracLit f1) 	  (FracLit f2)       = f1 == f2
-			  		     
-eq_lit (IntPrimLit i1)	  (IntPrimLit i2)    = i1 == i2
-eq_lit (FloatPrimLit f1)  (FloatPrimLit f2)  = f1 == f2
-eq_lit (DoublePrimLit d1) (DoublePrimLit d2) = d1 == d2
-eq_lit (CharLit c1) 	  (CharLit c2)       = c1 == c2
-eq_lit (CharPrimLit c1)	  (CharPrimLit c2)   = c1 == c2
-eq_lit (StringLit s1)	  (StringLit s2)     = s1 == s2
-eq_lit (StringPrimLit s1) (StringPrimLit s2) = s1 == s2
-eq_lit (LitLitLit s1 _)	  (LitLitLit s2 _)   = s1 == s2 -- ToDo: ??? (dubious)
-eq_lit other1	      	  other2	     = panic "matchLiterals:eq_lit"
+eq_lit (HsInt  i1)   	 (HsInt  i2)       = i1 == i2
+eq_lit (HsFrac f1) 	 (HsFrac f2)       = f1 == f2
+
+eq_lit (HsIntPrim i1)	 (HsIntPrim i2)    = i1 == i2
+eq_lit (HsFloatPrim f1)  (HsFloatPrim f2)  = f1 == f2
+eq_lit (HsDoublePrim d1) (HsDoublePrim d2) = d1 == d2
+eq_lit (HsChar c1) 	 (HsChar c2)       = c1 == c2
+eq_lit (HsCharPrim c1)	 (HsCharPrim c2)   = c1 == c2
+eq_lit (HsString s1)	 (HsString s2)     = s1 == s2
+eq_lit (HsStringPrim s1) (HsStringPrim s2) = s1 == s2
+eq_lit (HsLitLit s1)	 (HsLitLit s2)     = s1 == s2 -- ToDo: ??? (dubious)
+eq_lit other1	      	 other2		   = panic "matchLiterals:eq_lit"
 \end{code}
diff --git a/ghc/compiler/deSugar/MatchProc.lhs b/ghc/compiler/deSugar/MatchProc.lhs
deleted file mode 100644
index fb8a5cb35e..0000000000
--- a/ghc/compiler/deSugar/MatchProc.lhs
+++ /dev/null
@@ -1,98 +0,0 @@
-%               Filename:  %M%
-%               Version :  %I%
-%               Date    :  %G%
-%
-\section[MatchProcessors]{Pattern-matching processors}
-\begin{code}
-module MatchProc (
-    matchProcessor
-) where
-
-#include "HsVersions.h"
-
-import AbsSyn		-- the stuff being desugared
-import PlainCore	-- the output of desugaring;
-			-- importing this module also gets all the
-			-- CoreSyn utility functions
-import DsMonad		-- the monadery used in the desugarer
-
-import AbsUniType	( mkTyVarTy, splitType, mkProcessorTyCon,
-			  TyVar, TyCon, Class, UniType,
-			  TauType(..)
-			)
-import DsUtils		( EquationInfo(..), selectMatchVars )
-import Id		( getDataConFamily, getDataConTyCon,
-			  getIdUniType, mkProcessorCon
-			)
-import ListSetOps	( minusList )
-import Maybes		( Maybe(..) )
-import Match		( match )
-import Util
-import DsExpr		( dsExpr)
-\end{code}
-
-The matching of processors is based upon that of constructors. Given the 
-pattern :
-\begin{verbatim}
-	(|x1,..xn;y|)
-\end{verbatim}
-
-The pattern matching compiler converts the above into :
-\begin{verbatim}
-	case x of
-		(|u1,..un;uy|) -> let x1 = fromDomain u_1 of
-				  	 ....
-				  let xn = fromDomain u_n of
-				  let y  = fromDomain uy of
-				      PATTERN MATCH REST
-\end{verbatim}
-
-\begin{code}
-matchProcessor :: [Id]
-	       -> [EquationInfo]
-	       -> PlainCoreExpr
-	       -> DsM PlainCoreExpr
-
-matchProcessor (v:vs) eqnInfo ifFail  
-  = selectMatchVars [pat]	             `thenDs` 	(\ [var]             -> 
-    selectMatchVars pats	             `thenDs` 	(\ vars              -> 
-    match (var:vs) 
-	  [(pat:ps,after_fun)]
-	  ifFail		             `thenDs` 	(\ body              ->
-    create_lets vars pats convs body ifFail  `thenDs` 	(\ rhs	             ->
-    returnDs (
-      CoCase 
-	  (CoVar v)
-	  (CoAlgAlts
-	      [((mkProcessorCon podSize),vars++[var], rhs)]
-	      CoNoDefault))
-    )))) 
-  where
-    podSize = (length pats)
-    -- Sanity checking pattern match. Product type of processors ensures
-    -- there can be only one result if the equations are properly unmixed.
-    ((ProcessorPat pats convs pat):ps,after_fun)
-    	| length eqnInfo == 1 = head eqnInfo
-        | otherwise           = panic "matchProcessor more than one"
-
-\end{code}
-
-\begin{code}
-create_lets::[Id] ->
-	     [TypecheckedPat] -> 
-	     [TypecheckedExpr] -> 
-	     PlainCoreExpr ->
-	     PlainCoreExpr ->
-	     (DsM PlainCoreExpr)
-
-create_lets [] _ _ body _ = returnDs (body)
-create_lets (v:vs) (p:ps) (c:cs) body ifFail
-   = selectMatchVars [p]	        	`thenDs`  (\ var   -> 
-     create_lets vs ps cs body ifFail		`thenDs`  (\ after ->
-     dsExpr c					`thenDs`  (\ c'    ->
-     match var 
-	   [([p], \x -> after)] 
-	   ifFail				`thenDs`  (\ exp  ->
-     returnDs ( CoApp (CoLam var exp) (CoApp c' (CoVar v))) ))))
-\end{code}
-
diff --git a/ghc/compiler/deforest/Core2Def.hi b/ghc/compiler/deforest/Core2Def.hi
deleted file mode 100644
index a1e84c6931..0000000000
--- a/ghc/compiler/deforest/Core2Def.hi
+++ /dev/null
@@ -1,17 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 3 #-}
-interface Core2Def where
-import BinderInfo(BinderInfo)
-import CmdLineOpts(GlobalSwitch, SwitchResult)
-import CoreSyn(CoreBinding, CoreExpr)
-import DefSyn(DefBindee, DefProgram(..))
-import Id(Id)
-import PlainCore(PlainCoreProgram(..))
-import UniqFM(UniqFM)
-data CoreBinding a b 
-data DefBindee 
-type DefProgram = [CoreBinding Id DefBindee]
-data Id 
-type PlainCoreProgram = [CoreBinding Id Id]
-c2d :: UniqFM (CoreExpr Id DefBindee) -> CoreExpr (Id, BinderInfo) Id -> CoreExpr Id DefBindee
-core2def :: (GlobalSwitch -> SwitchResult) -> [CoreBinding Id Id] -> [CoreBinding Id DefBindee]
-
diff --git a/ghc/compiler/deforest/Core2Def.lhs b/ghc/compiler/deforest/Core2Def.lhs
index 1ca4e45bbe..25c5d31111 100644
--- a/ghc/compiler/deforest/Core2Def.lhs
+++ b/ghc/compiler/deforest/Core2Def.lhs
@@ -5,21 +5,15 @@
 
 >#include "HsVersions.h"
 >
-> module Core2Def ( 
+> module Core2Def (
 > 	core2def, c2d,
->	
->	PlainCoreProgram(..), DefProgram(..),
->	CoreBinding, Id, DefBindee ) where
-> 
+>
+>	DefProgram(..),
+>	GenCoreBinding, Id, DefBindee ) where
+>
 > import DefSyn
->#ifdef __HBC__
-> import Trace
->#endif
 
 > import CoreSyn
-> import IdEnv
-> import PlainCore
-> import TaggedCore
 > import BinderInfo	-- ( BinderInfo(..), isFun, isDupDanger )
 > import CmdLineOpts	( switchIsOn, SwitchResult, SimplifierSwitch )
 > import OccurAnal	( occurAnalyseBinds )
@@ -28,7 +22,7 @@
 > import Pretty
 > import Outputable
 
-This module translates the PlainCoreProgram into a DefCoreProgram,
+This module translates the CoreProgram into a DefCoreProgram,
 which includes non-atomic right-hand sides.  The decisions about which
 expressions to inline are left to the substitution analyser, which we
 run beforehand.
@@ -41,7 +35,7 @@ Current thinking:
 
 2.  We don't inline top-level lets that occur only once, because these
     might not be pulled out again by the let-floater, due to non-
-    garbage collection of CAFs.  
+    garbage collection of CAFs.
 
 2.1.  Also, what about these lit things that occur at the top level,
     and are usually marked as macros?
@@ -49,99 +43,99 @@ Current thinking:
 3.  No recusrive functions are unfolded.
 
 ToDo:
-4.  Lambdas and case alternatives that bind a variable that occurs 
+4.  Lambdas and case alternatives that bind a variable that occurs
     multiple times are transformed:
     \x -> ..x..x..  ===>  \x -> let x' = x in ..x'..x'..
 
 
-> core2def :: (GlobalSwitch -> SwitchResult) -> PlainCoreProgram -> DefProgram
-> core2def sw prog = 
+> core2def :: (GlobalSwitch -> SwitchResult) -> [CoreBinding] -> DefProgram
+> core2def sw prog =
 > 	map coreBinding2def tagged_program
->   where  
+>   where
 >   	tagged_program = occurAnalyseBinds prog switch_is_on (const False)
 >	switch_is_on   = switchIsOn sw
 
 
 > coreBinding2def :: SimplifiableCoreBinding -> DefBinding
-> coreBinding2def (CoNonRec (v,_) e) = CoNonRec v (c2d nullIdEnv e)
-> coreBinding2def (CoRec bs) = CoRec (map recBind2def bs)
+> coreBinding2def (NonRec (v,_) e) = NonRec v (c2d nullIdEnv e)
+> coreBinding2def (Rec bs) = Rec (map recBind2def bs)
 > 	where recBind2def ((v,_),e) = (v, c2d nullIdEnv e)
 
 
-> coreAtom2def :: IdEnv DefExpr -> PlainCoreAtom -> DefAtom
-> coreAtom2def p (CoVarAtom v) = CoVarAtom (DefArgExpr (lookup p v))
-> coreAtom2def p (CoLitAtom l) = CoVarAtom (DefArgExpr (CoLit l))
+> coreAtom2def :: IdEnv DefExpr -> CoreArg -> DefAtom
+> coreAtom2def p (VarArg v) = VarArg (DefArgExpr (lookup p v))
+> coreAtom2def p (LitArg l) = VarArg (DefArgExpr (Lit l))
 
-> isTrivial (CoCon c [] []) = True
-> isTrivial (CoVar v)       = True
-> isTrivial (CoLit l)       = True
+> isTrivial (Con c [] []) = True
+> isTrivial (Var v)       = True
+> isTrivial (Lit l)       = True
 > isTrivial _               = False
 
 > c2d :: IdEnv DefExpr -> SimplifiableCoreExpr -> DefExpr
 > c2d p e = case e of
-> 
->       CoVar v         -> lookup p v 
->	
->       CoLit l         -> CoLit l
->	
->       CoCon c ts es   -> CoCon c ts (map (coreAtom2def p) es)
->	
->       CoPrim op ts es -> CoPrim op ts (map (coreAtom2def p) es)
->	
->       CoLam vs e      -> CoLam (map fst vs) (c2d p e)
->	
+>
+>       Var v         -> lookup p v
+>
+>       Lit l         -> Lit l
+>
+>       Con c ts es   -> Con c ts (map (coreAtom2def p) es)
+>
+>       Prim op ts es -> Prim op ts (map (coreAtom2def p) es)
+>
+>       Lam vs e      -> Lam (map fst vs) (c2d p e)
+>
 >       CoTyLam alpha e -> CoTyLam alpha (c2d p e)
->	
->       CoApp e v       -> CoApp (c2d p e) (coreAtom2def p v)
->	
+>
+>       App e v       -> App (c2d p e) (coreAtom2def p v)
+>
 >       CoTyApp e t     -> CoTyApp (c2d p e) t
->	
->       CoCase e ps     -> CoCase (c2d p e) (coreCaseAlts2def p ps)
->	
->       CoLet (CoNonRec (v,ManyOcc _) e) e' 
+>
+>       Case e ps     -> Case (c2d p e) (coreCaseAlts2def p ps)
+>
+>       Let (NonRec (v,ManyOcc _) e) e'
 >		| isTrivial e -> c2d (addOneToIdEnv p v (c2d p e)) e'
 >		| otherwise ->
 >		trace ("Not inlining ManyOcc " ++ ppShow 80 (ppr PprDebug v)) (
->		CoLet (CoNonRec v (c2d p e)) (c2d p e'))
->		
->	CoLet (CoNonRec (v,DeadCode) e) e' ->
+>		Let (NonRec v (c2d p e)) (c2d p e'))
+>
+>	Let (NonRec (v,DeadCode) e) e' ->
 >		panic "Core2Def(c2d): oops, unexpected DeadCode"
->		
->	CoLet (CoNonRec (v,OneOcc fun_or_arg dup_danger _ _ _) e) e'
+>
+>	Let (NonRec (v,OneOcc fun_or_arg dup_danger _ _ _) e) e'
 >	   | isTrivial e -> inline_it
 >	   | isDupDanger dup_danger ->
 >		trace ("Not inlining DupDanger " ++ ppShow 80 (ppr PprDebug v))(
->		CoLet (CoNonRec v (c2d p e)) (c2d p e'))
+>		Let (NonRec v (c2d p e)) (c2d p e'))
 >	   | isFun fun_or_arg ->
 >		panic "Core2Def(c2d): oops, unexpected Macro"
 >	   | otherwise -> inline_it
 >	 where inline_it = c2d (addOneToIdEnv p v (c2d p e)) e'
->	 
->       CoLet (CoRec bs) e -> CoLet (CoRec (map recBind2def bs)) (c2d p e)
+>
+>       Let (Rec bs) e -> Let (Rec (map recBind2def bs)) (c2d p e)
 >               where recBind2def ((v,_),e) = (v, c2d p e)
->		
->       CoSCC l e       -> CoSCC l (c2d p e)
+>
+>       SCC l e       -> SCC l (c2d p e)
 
 
-> coreCaseAlts2def 
-> 	:: IdEnv DefExpr 
-> 	-> SimplifiableCoreCaseAlternatives
+> coreCaseAlts2def
+> 	:: IdEnv DefExpr
+> 	-> SimplifiableCoreCaseAlts
 >	-> DefCaseAlternatives
->	
+>
 > coreCaseAlts2def p alts = case alts of
-> 	CoAlgAlts as def  -> CoAlgAlts (map algAlt2def as) (defAlt2def def)
->	CoPrimAlts as def -> CoPrimAlts (map primAlt2def as) (defAlt2def def)
->	
->   where 
->	
+> 	AlgAlts as def  -> AlgAlts (map algAlt2def as) (defAlt2def def)
+>	PrimAlts as def -> PrimAlts (map primAlt2def as) (defAlt2def def)
+>
+>   where
+>
 >	algAlt2def  (c, vs, e) = (c, (map fst vs), c2d p e)
 >	primAlt2def (l, e)     = (l, c2d p e)
 
->	defAlt2def CoNoDefault = CoNoDefault
->	defAlt2def (CoBindDefault (v,_) e) = CoBindDefault v (c2d p e)
+>	defAlt2def NoDefault = NoDefault
+>	defAlt2def (BindDefault (v,_) e) = BindDefault v (c2d p e)
 
 
 > lookup :: IdEnv DefExpr -> Id -> DefExpr
 > lookup p v = case lookupIdEnv p v of
-> 			Nothing -> CoVar (DefArgVar v)
+> 			Nothing -> Var (DefArgVar v)
 >			Just e  -> e
diff --git a/ghc/compiler/deforest/Cyclic.hi b/ghc/compiler/deforest/Cyclic.hi
deleted file mode 100644
index ed6be3471d..0000000000
--- a/ghc/compiler/deforest/Cyclic.hi
+++ /dev/null
@@ -1,9 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 3 #-}
-interface Cyclic where
-import CoreSyn(CoreExpr)
-import DefSyn(DefBindee)
-import Id(Id)
-import SplitUniq(SplitUniqSupply)
-fixupFreeVars :: [Id] -> Id -> CoreExpr Id DefBindee -> ((Id, CoreExpr Id DefBindee), [(Id, CoreExpr Id DefBindee)])
-mkLoops :: CoreExpr Id DefBindee -> SplitUniqSupply -> ([(Id, CoreExpr Id DefBindee)], CoreExpr Id DefBindee)
-
diff --git a/ghc/compiler/deforest/Cyclic.lhs b/ghc/compiler/deforest/Cyclic.lhs
index 318921ccec..62f1fe0470 100644
--- a/ghc/compiler/deforest/Cyclic.lhs
+++ b/ghc/compiler/deforest/Cyclic.lhs
@@ -10,25 +10,21 @@
 > 	) where
 
 > import DefSyn
-> import PlainCore
 > import DefUtils
 > import Def2Core 	( d2c, defPanic )
->#ifdef __HBC__
-> import Trace
->#endif
 
-> import AbsUniType	( glueTyArgs, quantifyTy, mkForallTy, mkTyVarTy,
+> import Type		( glueTyArgs, quantifyTy, mkForallTy, mkTyVarTy,
 >			  TyVarTemplate
 >			)
 > import Digraph	( dfs )
-> import Id		( getIdUniType, toplevelishId, updateIdType,
+> import Id		( idType, toplevelishId, updateIdType,
 > 			  getIdInfo, replaceIdInfo, eqId, Id
 >			)
 > import IdInfo
 > import Maybes		( Maybe(..) )
 > import Outputable
 > import Pretty
-> import SplitUniq
+> import UniqSupply
 > import Util
 
 -----------------------------------------------------------------------------
@@ -45,21 +41,21 @@ times, but only examined once.
 -----------------------------------------------------------------------------
 Monad for the knot-tier.
 
-> type Lbl a = SUniqSM (
+> type Lbl a = UniqSM (
 > 	[(Id)],				-- loops used
 >	[(Id,DefExpr,[Id],DefExpr)],	-- bindings floating upwards
 >	[(Id,DefExpr)],			-- back loops
 >	a)				-- computation result
-> 
+>
 > thenLbl :: Lbl a -> (a -> Lbl b) -> Lbl b
 > thenLbl a k
-> 	= a 	`thenSUs` \(ls, bs, bls,  a) ->
->	  k a	`thenSUs` \(ls',bs',bls', b) ->
->	  returnSUs (ls ++ ls', bs ++ bs', bls ++ bls', b)
-> 
+> 	= a 	`thenUs` \(ls, bs, bls,  a) ->
+>	  k a	`thenUs` \(ls',bs',bls', b) ->
+>	  returnUs (ls ++ ls', bs ++ bs', bls ++ bls', b)
+>
 > returnLbl :: a -> Lbl a
-> returnLbl a = returnSUs ([],[],[],a)
-> 
+> returnLbl a = returnUs ([],[],[],a)
+>
 > mapLbl :: (a -> Lbl b) -> [a] -> Lbl [b]
 > mapLbl f [] = returnLbl []
 > mapLbl f (x:xs)
@@ -71,11 +67,11 @@ Monad for the knot-tier.
 
 This is terribly inefficient.
 
-> mkLoops :: DefExpr -> SUniqSM ([(Id,DefExpr)],DefExpr)
-> mkLoops e = 
+> mkLoops :: DefExpr -> UniqSM ([(Id,DefExpr)],DefExpr)
+> mkLoops e =
 >  error "mkLoops"
 >{- LATER:
-> 	loop [] e `thenSUs` \(ls,bs,bls,e) ->
+> 	loop [] e `thenUs` \(ls,bs,bls,e) ->
 
 Throw away all the extracted bindings that can't be reached.  These
 can occur as the result of some forward loops being short-circuited by
@@ -87,36 +83,36 @@ of the expression being returned.
 >		loops_out = filter deforestable (freeVars e)
 >		(_,reachable) = dfs (==) r ([],[]) loops_out
 >		r f = lookup f bs
->				
+>
 >		lookup f [] = []
 >		lookup f ((g,out,_):xs) | f == g = out
 >					| otherwise = lookup f xs
->					
+>
 >		isReachable (f,_,_) = f `elem` reachable
 >	in
-> 	returnSUs (map (\(f,_,e) -> (f,e)) (filter isReachable bs),e)
+> 	returnUs (map (\(f,_,e) -> (f,e)) (filter isReachable bs),e)
 >   where
 
 >       loop :: [(Id,DefExpr,[Id],[TyVar])] -> DefExpr -> Lbl DefExpr
 
->   	loop ls (CoVar (Label e e1))
->   	    = 
->	     d2c e `thenSUs` \core_e ->
+>   	loop ls (Var (Label e e1))
+>   	    =
+>	     d2c e `thenUs` \core_e ->
 >--	     trace ("loop:\n" ++ ppShow 80 (ppr PprDebug core_e)) $
 
->	     mapSUs (\(f,e',val_args,ty_args) -> 
->	             renameExprs e' e	`thenSUs` \r ->
->		     returnSUs (f,val_args,ty_args,r)) ls `thenSUs` \results ->
+>	     mapUs (\(f,e',val_args,ty_args) ->
+>	             renameExprs e' e	`thenUs` \r ->
+>		     returnUs (f,val_args,ty_args,r)) ls `thenUs` \results ->
 >	     let
-> 		loops = 
->			[ (f,val_args,ty_args,r) | 
+> 		loops =
+>			[ (f,val_args,ty_args,r) |
 >			  (f,val_args,ty_args,IsRenaming r) <- results ]
->		inconsistent_renamings = 
->			[ (f,r) | 
->			  (f,val_args,ty_args,InconsistentRenaming r) 
+>		inconsistent_renamings =
+>			[ (f,r) |
+>			  (f,val_args,ty_args,InconsistentRenaming r)
 >			  	<- results ]
 >	     in
->	
+>
 >  	     (case loops of
 >	      [] ->
 
@@ -128,32 +124,32 @@ actually done unless the function is required).
 The type of a new function, if one is generated at this point, is
 constructed as follows:
 
-    \/ a1 ... \/ an . b1 -> ... -> bn -> t 
+    \/ a1 ... \/ an . b1 -> ... -> bn -> t
 
 where a1...an are the free type variables in the expression, b1...bn
 are the types of the free variables in the expression, and t is the
 type of the expression itself.
 
 >		let
->		
+>
 > 		   -- Collect the value/type arguments for the function
 >		   fvs       = freeVars e
 >		   val_args  = filter isArgId fvs
 >		   ty_args   = freeTyVars e
->		   
+>
 >		   -- Now to make up the type...
->		   base_type = typeOfCoreExpr core_e
->		   fun_type  = glueTyArgs (map getIdUniType val_args) base_type
+>		   base_type = coreExprType core_e
+>		   fun_type  = glueTyArgs (map idType val_args) base_type
 >		   (_, type_of_f) = quantifyTy ty_args fun_type
 >		in
->		
->		newDefId type_of_f	`thenSUs` \f' ->
->		let 
-> 		       f = replaceIdInfo f' 
+>
+>		newDefId type_of_f	`thenUs` \f' ->
+>		let
+> 		       f = replaceIdInfo f'
 >		       		(addInfo (getIdInfo f') DoDeforest)
 >		in
 >		loop ((f,e,val_args,ty_args):ls) e1
->					`thenSUs` \res@(ls',bs,bls,e') ->
+>					`thenUs` \res@(ls',bs,bls,e') ->
 
 Key: ls = loops, bs = bindings, bls = back loops, e = expression.
 
@@ -168,43 +164,43 @@ Comment the next section out to disable back-loops.
 >		let back_loops = reverse [ e | (f',e) <- bls, f' == f ] in
 >		if not (null back_loops){- && not (f `elem` ls')-} then
 >		   --if length back_loops > 1 then panic "barf!" else
->		   	d2c (head back_loops)	`thenSUs` \core_e ->
->		   	trace ("Back Loop:\n" ++ 
+>		   	d2c (head back_loops)	`thenUs` \core_e ->
+>		   	trace ("Back Loop:\n" ++
 >				ppShow 80 (ppr PprDebug core_e)) $
 
 If we find a back-loop that also occurs where we would normally make a
 new function...
 
 >		   if f `elem` ls' then
->			d2c e'			`thenSUs` \core_e' ->
+>			d2c e'			`thenUs` \core_e' ->
 >			trace ("In Forward Loop " ++
 >				ppShow 80 (ppr PprDebug f) ++ "\n" ++
 >				ppShow 80 (ppr PprDebug core_e')) $
 >		   	if f `notElem` (freeVars (head back_loops)) then
->				returnSUs (ls', bs, bls, head back_loops)
+>				returnUs (ls', bs, bls, head back_loops)
 >			else
 >				panic "hello"
 >		   else
 
-> 		   returnSUs (ls', bs, bls, head back_loops)
+> 		   returnUs (ls', bs, bls, head back_loops)
 >		else
 
 If we are in a forward-loop (i.e. we found a label somewhere below
 which is a renaming of this one), then make a new function definition.
 
 >		if f `elem` ls' then
->		
->			rebindExpr (mkCoTyLam ty_args (mkCoLam val_args e'))
->							`thenSUs` \rhs ->
->			returnSUs
->			    (ls', 
->			     (f,filter deforestable (freeVars e'),e,rhs) : bs, 
+>
+>			rebindExpr (mkLam ty_args val_args e')
+>							`thenUs` \rhs ->
+>			returnUs
+>			    (ls',
+>			     (f,filter deforestable (freeVars e'),e,rhs) : bs,
 >			     bls,
 >			     mkLoopFunApp val_args ty_args f)
 
 otherwise, forget about it
 
->			else returnSUs res
+>			else returnUs res
 
 This is a loop, just make a call to the function which we
 will create on the way back up the tree.
@@ -212,81 +208,81 @@ will create on the way back up the tree.
 (NB: it appears that sometimes we do get more than one loop matching,
 investigate this?)
 
->	      ((f,val_args,ty_args,r):_) -> 
->	      
->		     returnSUs 
+>	      ((f,val_args,ty_args,r):_) ->
+>
+>		     returnUs
 >		     	([f],		-- found a loop, propagate it back
 >			 [],		-- no bindings
 >			 [],		-- no back loops
 >		         mkLoopFunApp (applyRenaming r val_args) ty_args f)
->			 
->		) `thenSUs` \res@(ls',bs,bls,e') ->
+>
+>		) `thenUs` \res@(ls',bs,bls,e') ->
 
 If this expression reoccurs, record the binding and replace the cycle
 with a call to the new function.  We also rebind all the free
 variables in the new function to avoid name clashes later.
 
 >	   let
->		findBackLoops (g,r) bls 
->			| consistent r' = subst s e' `thenSUs` \e' ->
->					  returnSUs ((g,e') : bls)
->			| otherwise     = returnSUs bls
+>		findBackLoops (g,r) bls
+>			| consistent r' = subst s e' `thenUs` \e' ->
+>					  returnUs ((g,e') : bls)
+>			| otherwise     = returnUs bls
 >			where
 >			  r' = map swap r
->			  s = map (\(x,y) -> (x, CoVar (DefArgVar y))) (nub r')
+>			  s = map (\(x,y) -> (x, Var (DefArgVar y))) (nub r')
 >	   in
 
 We just want the first one (ie. furthest up the tree), so reverse the
 list of inconsistent renamings.
 
 >	   foldrSUs findBackLoops [] (reverse inconsistent_renamings)
->						`thenSUs` \back_loops ->
+>						`thenUs` \back_loops ->
 
 Comment out the next block to disable back-loops.  ToDo: trace all of them.
 
 >	   if not (null back_loops) then
->		d2c e'	`thenSUs` \core_e ->
->		trace ("Floating back loop:\n" 
->			++ ppShow 80 (ppr PprDebug core_e)) 
->		returnSUs (ls', bs, back_loops ++ bls, e')
+>		d2c e'	`thenUs` \core_e ->
+>		trace ("Floating back loop:\n"
+>			++ ppShow 80 (ppr PprDebug core_e))
+>		returnUs (ls', bs, back_loops ++ bls, e')
 >	   else
-> 		returnSUs res
+> 		returnUs res
 
->   	loop ls e@(CoVar (DefArgVar v))
+>   	loop ls e@(Var (DefArgVar v))
 > 	    = returnLbl e
->   	loop ls e@(CoLit l)
+>   	loop ls e@(Lit l)
 >   	    = returnLbl e
->   	loop ls (CoCon c ts es)
+>   	loop ls (Con c ts es)
 >   	    = mapLbl (loopAtom ls) es       `thenLbl` \es ->
->   	      returnLbl (CoCon c ts es)
->   	loop ls (CoPrim op ts es)
+>   	      returnLbl (Con c ts es)
+>   	loop ls (Prim op ts es)
 >   	    = mapLbl (loopAtom ls) es       `thenLbl` \es ->
->   	      returnLbl (CoPrim op ts es)
->   	loop ls (CoLam vs e)
+>   	      returnLbl (Prim op ts es)
+>   	loop ls (Lam vs e)
 >   	    = loop ls e                     `thenLbl` \e ->
->   	      returnLbl (CoLam vs e)
+>   	      returnLbl (Lam vs e)
 >   	loop ls (CoTyLam alpha e)
 >   	    = loop ls e                     `thenLbl` \e ->
 >   	      returnLbl (CoTyLam alpha e)
->   	loop ls (CoApp e v)
+>   	loop ls (App e v)
 >   	    = loop ls e                     `thenLbl` \e ->
 >   	      loopAtom ls v                 `thenLbl` \v ->
->   	      returnLbl (CoApp e v)
+>   	      returnLbl (App e v)
 >   	loop ls (CoTyApp e t)
 >   	    = loop ls e                     `thenLbl` \e ->
 >   	      returnLbl (CoTyApp e t)
->   	loop ls (CoCase e ps)
+>   	loop ls (Case e ps)
 >   	    = loop ls e                     `thenLbl` \e ->
 >   	      loopCaseAlts ls ps            `thenLbl` \ps ->
->   	      returnLbl (CoCase e ps)
->   	loop ls (CoLet (CoNonRec v e) e')
+>   	      returnLbl (Case e ps)
+>   	loop ls (Let (NonRec v e) e')
 >   	    = loop ls e                     `thenLbl` \e ->
 >   	      loop ls e'                    `thenLbl` \e' ->
->   	      returnLbl (CoLet (CoNonRec v e) e')
->   	loop ls (CoLet (CoRec bs) e)
+>   	      returnLbl (Let (NonRec v e) e')
+>   	loop ls (Let (Rec bs) e)
 >   	    = mapLbl loopRecBind bs         `thenLbl` \bs ->
 >   	      loop ls e                     `thenLbl` \e ->
->   	      returnLbl (CoLet (CoRec bs) e)
+>   	      returnLbl (Let (Rec bs) e)
 >   	    where
 >	      vs = map fst bs
 >   	      loopRecBind (v, e)
@@ -295,42 +291,42 @@ Comment out the next block to disable back-loops.  ToDo: trace all of them.
 >	loop ls e
 >	    = defPanic "Cyclic" "loop" e
 
-> 	loopAtom ls (CoVarAtom (DefArgExpr e))
+> 	loopAtom ls (VarArg (DefArgExpr e))
 > 	      = loop ls e                     `thenLbl` \e ->
-> 	        returnLbl (CoVarAtom (DefArgExpr e))
-> 	loopAtom ls (CoVarAtom e@(DefArgVar v))
-> 	      = defPanic "Cyclic" "loopAtom" (CoVar e)
-> 	loopAtom ls (CoVarAtom e@(Label _ _))
-> 	      = defPanic "Cyclic" "loopAtom" (CoVar e)
-> 	loopAtom ls e@(CoLitAtom l)
+> 	        returnLbl (VarArg (DefArgExpr e))
+> 	loopAtom ls (VarArg e@(DefArgVar v))
+> 	      = defPanic "Cyclic" "loopAtom" (Var e)
+> 	loopAtom ls (VarArg e@(Label _ _))
+> 	      = defPanic "Cyclic" "loopAtom" (Var e)
+> 	loopAtom ls e@(LitArg l)
 > 	      = returnLbl e
 >
-> 	loopCaseAlts ls (CoAlgAlts as def) = 
+> 	loopCaseAlts ls (AlgAlts as def) =
 >		mapLbl loopAlgAlt as		`thenLbl` \as ->
 > 	        loopDefault ls def		`thenLbl` \def ->
-> 	        returnLbl (CoAlgAlts as def)
+> 	        returnLbl (AlgAlts as def)
 >	      where
 >	      	loopAlgAlt (c, vs, e) =
 >			loop ls e		`thenLbl` \e ->
 > 	        	returnLbl (c, vs, e)
 
-> 	loopCaseAlts ls (CoPrimAlts as def) = 
+> 	loopCaseAlts ls (PrimAlts as def) =
 >		mapLbl loopPrimAlt as		`thenLbl` \as ->
 > 	        loopDefault ls def		`thenLbl` \def ->
-> 	        returnLbl (CoPrimAlts as def)
+> 	        returnLbl (PrimAlts as def)
 >	      where
->	      	loopPrimAlt (l, e) = 
+>	      	loopPrimAlt (l, e) =
 >			loop ls e		`thenLbl` \e ->
 > 	        	returnLbl (l, e)
 
-> 	loopDefault ls CoNoDefault = 
->		returnLbl CoNoDefault
-> 	loopDefault ls (CoBindDefault v e) = 
+> 	loopDefault ls NoDefault =
+>		returnLbl NoDefault
+> 	loopDefault ls (BindDefault v e) =
 >		loop ls e			`thenLbl` \e ->
-> 	        returnLbl (CoBindDefault v e)
+> 	        returnLbl (BindDefault v e)
 > -}
 
-> mkVar v = CoVarAtom (DefArgExpr (CoVar (DefArgVar v)))
+> mkVar v = VarArg (DefArgExpr (Var (DefArgVar v)))
 
 -----------------------------------------------------------------------------
 The next function is applied to all deforestable functions which are
@@ -347,20 +343,20 @@ expressions and function right hand sides that call this function.
 > 	case fvs of
 >		[] -> ((id,e),[])
 >		_  -> let new_type =
->		      		glueTyArgs (map getIdUniType fvs) 
->					(getIdUniType id)
+>		      		glueTyArgs (map idType fvs)
+>					(idType id)
 >			  new_id =
 >			  	updateIdType id new_type
 >		      in
 >		      let
->		          t = foldl CoApp (CoVar (DefArgVar new_id)) 
+>		          t = foldl App (Var (DefArgVar new_id))
 >			  			(map mkVar fvs)
 > 		      in
 >		      trace ("adding " ++ show (length fvs) ++ " args to " ++ ppShow 80 (ppr PprDebug id)) $
->		      ((new_id, mkCoLam fvs e), [(id,t)])
+>		      ((new_id, mkValLam fvs e), [(id,t)])
 >	where
 >		fvs = case e of
->			CoLam bvs e -> filter (`notElem` bvs) total_fvs
+>			Lam bvs e -> filter (`notElem` bvs) total_fvs
 >			_ -> total_fvs
 
 > swap (x,y) = (y,x)
@@ -374,8 +370,8 @@ expressions and function right hand sides that call this function.
 
 > mkLoopFunApp :: [Id] -> [TyVar] -> Id -> DefExpr
 > mkLoopFunApp val_args ty_args f =
-> 	foldl CoApp 
->	  (foldl CoTyApp (CoVar (DefArgVar f))
+> 	foldl App
+>	  (foldl CoTyApp (Var (DefArgVar f))
 >	    (map mkTyVarTy ty_args))
 >	  	(map mkVar val_args)
 
@@ -384,28 +380,28 @@ Removing duplicates from a list of definitions.
 
 > removeDuplicateDefinitions
 > 	:: [(DefExpr,(Id,DefExpr))] 	-- (label,(id,rhs))
-> 	-> SUniqSM [(Id,DefExpr)]
+> 	-> UniqSM [(Id,DefExpr)]
 
-> removeDuplicateDefinitions defs = 
-> 	foldrSUs rem ([],[]) defs	`thenSUs` \(newdefs,s) ->
->	mapSUs (\(l,(f,e)) -> subst s e `thenSUs` \e -> 
->			      returnSUs (f, e)) newdefs
->   where 
+> removeDuplicateDefinitions defs =
+> 	foldrSUs rem ([],[]) defs	`thenUs` \(newdefs,s) ->
+>	mapUs (\(l,(f,e)) -> subst s e `thenUs` \e ->
+>			      returnUs (f, e)) newdefs
+>   where
 
 > 	rem d@(l,(f,e)) (defs,s) =
->		findDup l defs		`thenSUs` \maybe ->
+>		findDup l defs		`thenUs` \maybe ->
 > 		case maybe of
->		   Nothing -> returnSUs (d:defs,s)
->		   Just g  -> returnSUs (defs, (f,(CoVar.DefArgVar) g):s)
+>		   Nothing -> returnUs (d:defs,s)
+>		   Just g  -> returnUs (defs, (f,(Var.DefArgVar) g):s)
 
 We insist that labels rename in both directions, is this necessary?
 
-> 	findDup l [] = returnSUs Nothing
+> 	findDup l [] = returnUs Nothing
 > 	findDup l ((l',(f,e)):defs) =
-> 		renameExprs l l' 	`thenSUs` \r ->
+> 		renameExprs l l' 	`thenUs` \r ->
 >		case r of
->		  IsRenaming _ -> renameExprs l' l 	`thenSUs` \r ->
+>		  IsRenaming _ -> renameExprs l' l 	`thenUs` \r ->
 >				  case r of
->				  	IsRenaming r -> returnSUs (Just f)
+>				  	IsRenaming r -> returnUs (Just f)
 >					_ -> findDup l defs
 >		  _ -> findDup l defs
diff --git a/ghc/compiler/deforest/Def2Core.hi b/ghc/compiler/deforest/Def2Core.hi
deleted file mode 100644
index 13b3c658eb..0000000000
--- a/ghc/compiler/deforest/Def2Core.hi
+++ /dev/null
@@ -1,17 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 3 #-}
-interface Def2Core where
-import CoreSyn(CoreBinding, CoreExpr)
-import DefSyn(DefBindee, DefBinding(..))
-import Id(Id)
-import PlainCore(PlainCoreProgram(..))
-import SplitUniq(SUniqSM(..), SplitUniqSupply)
-data CoreBinding a b 
-data DefBindee 
-type DefBinding = CoreBinding Id DefBindee
-data Id 
-type PlainCoreProgram = [CoreBinding Id Id]
-type SUniqSM a = SplitUniqSupply -> a
-d2c :: CoreExpr Id DefBindee -> SplitUniqSupply -> CoreExpr Id Id
-def2core :: [CoreBinding Id DefBindee] -> SplitUniqSupply -> [CoreBinding Id Id]
-defPanic :: [Char] -> [Char] -> CoreExpr Id DefBindee -> SplitUniqSupply -> a
-
diff --git a/ghc/compiler/deforest/Def2Core.lhs b/ghc/compiler/deforest/Def2Core.lhs
index 7fe5b115e1..6660f31c7a 100644
--- a/ghc/compiler/deforest/Def2Core.lhs
+++ b/ghc/compiler/deforest/Def2Core.lhs
@@ -5,152 +5,151 @@
 
 >#include "HsVersions.h"
 >
-> module Def2Core ( 
+> module Def2Core (
 > 	def2core, d2c,
->	
+>
 >	-- and to make the interface self-sufficient, all this stuff:
->	DefBinding(..), SUniqSM(..), PlainCoreProgram(..),
->	CoreBinding, Id, DefBindee,
+>	DefBinding(..), UniqSM(..),
+>	GenCoreBinding, Id, DefBindee,
 >	defPanic
 >	) where
 
 > import DefSyn
 > import DefUtils
-> 
+>
 > import Maybes		( Maybe(..) )
 > import Outputable
-> import PlainCore
 > import Pretty
-> import SplitUniq
+> import UniqSupply
 > import Util
 
 
-> def2core :: DefProgram -> SUniqSM PlainCoreProgram
-> def2core prog = mapSUs defBinding2core prog
+> def2core :: DefProgram -> UniqSM [CoreBinding]
+> def2core prog = mapUs defBinding2core prog
 
-> defBinding2core :: DefBinding -> SUniqSM PlainCoreBinding
-> defBinding2core (CoNonRec v e) = 
-> 	d2c e `thenSUs` \e' -> 
->	returnSUs (CoNonRec v e')
-> defBinding2core (CoRec bs) = 
-> 	mapSUs recBind2core bs `thenSUs` \bs' ->
->	returnSUs (CoRec bs')
->		where recBind2core (v,e) 
->			= d2c e `thenSUs` \e' -> 
->			  returnSUs (v, e')
+> defBinding2core :: DefBinding -> UniqSM CoreBinding
+> defBinding2core (NonRec v e) =
+> 	d2c e `thenUs` \e' ->
+>	returnUs (NonRec v e')
+> defBinding2core (Rec bs) =
+> 	mapUs recBind2core bs `thenUs` \bs' ->
+>	returnUs (Rec bs')
+>		where recBind2core (v,e)
+>			= d2c e `thenUs` \e' ->
+>			  returnUs (v, e')
 
 
-> defAtom2core :: DefAtom -> SUniqSM (PlainCoreAtom, Maybe PlainCoreExpr)
+> defAtom2core :: DefAtom -> UniqSM (CoreArg, Maybe CoreExpr)
 > defAtom2core atom = case atom of
-> 	CoLitAtom l -> returnSUs (CoLitAtom l, Nothing)
-> 	CoVarAtom (DefArgVar id) -> returnSUs (CoVarAtom id, Nothing)
->	CoVarAtom (DefArgExpr (CoVar (DefArgVar id))) ->
->		returnSUs (CoVarAtom id, Nothing)
->	CoVarAtom (DefArgExpr (CoLit l)) ->
->		returnSUs (CoLitAtom l, Nothing)
-> 	CoVarAtom (DefArgExpr e) -> 
->		d2c e		`thenSUs` \e' ->
->		newTmpId (typeOfCoreExpr e')	`thenSUs` \new_id ->
->		returnSUs (CoVarAtom new_id, Just e')
->	CoVarAtom (Label _ _) -> 
->		panic "Def2Core(defAtom2core): CoVarAtom (Label _ _)"
+> 	LitArg l -> returnUs (LitArg l, Nothing)
+> 	VarArg (DefArgVar id) -> returnUs (VarArg id, Nothing)
+>	VarArg (DefArgExpr (Var (DefArgVar id))) ->
+>		returnUs (VarArg id, Nothing)
+>	VarArg (DefArgExpr (Lit l)) ->
+>		returnUs (LitArg l, Nothing)
+> 	VarArg (DefArgExpr e) ->
+>		d2c e		`thenUs` \e' ->
+>		newTmpId (coreExprType e')	`thenUs` \new_id ->
+>		returnUs (VarArg new_id, Just e')
+>	VarArg (Label _ _) ->
+>		panic "Def2Core(defAtom2core): VarArg (Label _ _)"
 
-> d2c :: DefExpr -> SUniqSM PlainCoreExpr
+> d2c :: DefExpr -> UniqSM CoreExpr
 > d2c e = case e of
-> 
->	CoVar (DefArgExpr e) ->
->		panic "Def2Core(d2c): CoVar (DefArgExpr _)"
->		
->	CoVar (Label _ _) ->
->		panic "Def2Core(d2c): CoVar (Label _ _)"
->		
->	CoVar (DefArgVar v) ->
->		returnSUs (CoVar v)
->	
->       CoLit l -> 
->		returnSUs (CoLit l)
->	
->       CoCon c ts as -> 
->		mapSUs defAtom2core as	`thenSUs` \atom_expr_pairs ->
->		returnSUs (
->			foldr (\(a,b) -> mkLet a b) 
->				(CoCon c ts (map fst atom_expr_pairs))
+>
+>	Var (DefArgExpr e) ->
+>		panic "Def2Core(d2c): Var (DefArgExpr _)"
+>
+>	Var (Label _ _) ->
+>		panic "Def2Core(d2c): Var (Label _ _)"
+>
+>	Var (DefArgVar v) ->
+>		returnUs (Var v)
+>
+>       Lit l ->
+>		returnUs (Lit l)
+>
+>       Con c ts as ->
+>		mapUs defAtom2core as	`thenUs` \atom_expr_pairs ->
+>		returnUs (
+>			foldr (\(a,b) -> mkLet a b)
+>				(Con c ts (map fst atom_expr_pairs))
 >				atom_expr_pairs)
->			   
->       CoPrim op ts as -> 
->		mapSUs defAtom2core as	`thenSUs` \atom_expr_pairs ->
->		returnSUs (
+>
+>       Prim op ts as ->
+>		mapUs defAtom2core as	`thenUs` \atom_expr_pairs ->
+>		returnUs (
 >			foldr (\(a,b) -> mkLet a b)
->				(CoPrim op ts (map fst atom_expr_pairs))
+>				(Prim op ts (map fst atom_expr_pairs))
 >				atom_expr_pairs)
->			   
->       CoLam vs e -> 
->		d2c e			`thenSUs` \e' ->
->		returnSUs (CoLam vs e')
->		
->       CoTyLam alpha e -> 
->		d2c e			`thenSUs` \e' ->
->		returnSUs (CoTyLam alpha e')
->		
->       CoApp e v       -> 
->		d2c e			`thenSUs` \e' ->
->		defAtom2core v		`thenSUs` \(v',e'') ->
->		returnSUs (mkLet v' e'' (CoApp e' v'))
->		
->       CoTyApp e t     -> 
->		d2c e			`thenSUs` \e' ->
->		returnSUs (CoTyApp e' t)	
->
->       CoCase e ps ->
->		d2c e			`thenSUs` \e' ->
->		defCaseAlts2Core ps	`thenSUs` \ps' ->
->		returnSUs (CoCase e' ps')
->		
->	CoLet b e ->
->		d2c e			`thenSUs` \e' ->
->		defBinding2core b	`thenSUs` \b' ->
->		returnSUs (CoLet b' e')
-> 
->       CoSCC l e ->
->		d2c e			`thenSUs` \e' ->
->		returnSUs (CoSCC l e')
+>
+>       Lam vs e ->
+>		d2c e			`thenUs` \e' ->
+>		returnUs (Lam vs e')
+>
+>       CoTyLam alpha e ->
+>		d2c e			`thenUs` \e' ->
+>		returnUs (CoTyLam alpha e')
+>
+>       App e v       ->
+>		d2c e			`thenUs` \e' ->
+>		defAtom2core v		`thenUs` \(v',e'') ->
+>		returnUs (mkLet v' e'' (App e' v'))
+>
+>       CoTyApp e t     ->
+>		d2c e			`thenUs` \e' ->
+>		returnUs (CoTyApp e' t)
+>
+>       Case e ps ->
+>		d2c e			`thenUs` \e' ->
+>		defCaseAlts2Core ps	`thenUs` \ps' ->
+>		returnUs (Case e' ps')
+>
+>	Let b e ->
+>		d2c e			`thenUs` \e' ->
+>		defBinding2core b	`thenUs` \b' ->
+>		returnUs (Let b' e')
+>
+>       SCC l e ->
+>		d2c e			`thenUs` \e' ->
+>		returnUs (SCC l e')
 
-> defCaseAlts2Core :: DefCaseAlternatives 
-> 	-> SUniqSM PlainCoreCaseAlternatives
->	
+> defCaseAlts2Core :: DefCaseAlternatives
+> 	-> UniqSM CoreCaseAlts
+>
 > defCaseAlts2Core alts = case alts of
-> 	CoAlgAlts alts dflt -> 
->		mapSUs algAlt2Core alts	`thenSUs` \alts' ->
->		defAlt2Core dflt	`thenSUs` \dflt' ->
->		returnSUs (CoAlgAlts alts' dflt')
->		
->	CoPrimAlts alts dflt ->
->		mapSUs primAlt2Core alts `thenSUs` \alts' ->
->		defAlt2Core dflt	 `thenSUs` \dflt' ->
->		returnSUs (CoPrimAlts alts' dflt')
-> 
+> 	AlgAlts alts dflt ->
+>		mapUs algAlt2Core alts	`thenUs` \alts' ->
+>		defAlt2Core dflt	`thenUs` \dflt' ->
+>		returnUs (AlgAlts alts' dflt')
+>
+>	PrimAlts alts dflt ->
+>		mapUs primAlt2Core alts `thenUs` \alts' ->
+>		defAlt2Core dflt	 `thenUs` \dflt' ->
+>		returnUs (PrimAlts alts' dflt')
+>
 >  where
->  	
->	algAlt2Core (c, vs, e)	= d2c e `thenSUs` \e' -> returnSUs (c, vs, e')
->	primAlt2Core (l, e)	= d2c e `thenSUs` \e' -> returnSUs (l, e')
->	
->	defAlt2Core CoNoDefault = returnSUs CoNoDefault
->	defAlt2Core (CoBindDefault v e) = 
->		d2c e `thenSUs` \e' ->
->		returnSUs (CoBindDefault v e')
+>
+>	algAlt2Core (c, vs, e)	= d2c e `thenUs` \e' -> returnUs (c, vs, e')
+>	primAlt2Core (l, e)	= d2c e `thenUs` \e' -> returnUs (l, e')
+>
+>	defAlt2Core NoDefault = returnUs NoDefault
+>	defAlt2Core (BindDefault v e) =
+>		d2c e `thenUs` \e' ->
+>		returnUs (BindDefault v e')
 
-> mkLet :: PlainCoreAtom
-> 	-> Maybe PlainCoreExpr 
->	-> PlainCoreExpr 
->	-> PlainCoreExpr
->	
-> mkLet (CoVarAtom v) (Just e) e' = CoLet (CoNonRec v e) e'
+> mkLet :: CoreArg
+> 	-> Maybe CoreExpr
+>	-> CoreExpr
+>	-> CoreExpr
+>
+> mkLet (VarArg v) (Just e) e' = Let (NonRec v e) e'
 > mkLet v Nothing  e' = e'
 
 -----------------------------------------------------------------------------
 XXX - in here becuase if it goes in DefUtils we've got mutual recursion.
 
-> defPanic :: String -> String -> DefExpr -> SUniqSM a
+> defPanic :: String -> String -> DefExpr -> UniqSM a
 > defPanic modl fun expr =
-> 	d2c expr	`thenSUs` \expr ->
+> 	d2c expr	`thenUs` \expr ->
 > 	panic (modl ++ "(" ++ fun ++ "): " ++ ppShow 80 (ppr PprDebug expr))
diff --git a/ghc/compiler/deforest/DefExpr.hi b/ghc/compiler/deforest/DefExpr.hi
deleted file mode 100644
index 56bcc06d4c..0000000000
--- a/ghc/compiler/deforest/DefExpr.hi
+++ /dev/null
@@ -1,11 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 3 #-}
-interface DefExpr where
-import CmdLineOpts(SwitchResult)
-import CoreSyn(CoreArg, CoreExpr)
-import DefSyn(DefBindee)
-import Id(Id)
-import SplitUniq(SplitUniqSupply)
-import UniType(UniType)
-import UniqFM(UniqFM)
-tran :: (a -> SwitchResult) -> UniqFM (CoreExpr Id DefBindee) -> UniqFM UniType -> CoreExpr Id DefBindee -> [CoreArg DefBindee] -> SplitUniqSupply -> CoreExpr Id DefBindee
-
diff --git a/ghc/compiler/deforest/DefExpr.lhs b/ghc/compiler/deforest/DefExpr.lhs
index a418773b1c..5cfd349b64 100644
--- a/ghc/compiler/deforest/DefExpr.lhs
+++ b/ghc/compiler/deforest/DefExpr.lhs
@@ -1,5 +1,5 @@
 %
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
 %
 \section[DefExpr]{Transformation Algorithm for Expressions}
 
@@ -8,7 +8,7 @@
 > module DefExpr (
 > 	tran
 >	) where
-> 
+>
 > import DefSyn
 > import CoreSyn
 > import DefUtils
@@ -16,23 +16,21 @@
 > import TreelessForm
 > import Cyclic
 
-> import AbsUniType	( applyTypeEnvToTy, isPrimType,
->			  SigmaType(..), UniType
+> import Type		( applyTypeEnvToTy, isPrimType,
+>			  SigmaType(..), Type
 >			  IF_ATTACK_PRAGMAS(COMMA cmpUniType)
 >			)
 > import CmdLineOpts	( SwitchResult, switchIsOn )
-> import CoreFuns	( mkCoLam, unTagBinders, typeOfCoreExpr )
+> import CoreUnfold	( UnfoldingDetails(..) )
+> import CoreUtils	( mkValLam, unTagBinders, coreExprType )
 > import Id		( applyTypeEnvToId, getIdUnfolding, isTopLevId, Id,
 > 			  isInstId_maybe
 >			)
 > import Inst		-- Inst(..)
-> import IdEnv
 > import IdInfo
 > import Maybes		( Maybe(..) )
 > import Outputable
-> import SimplEnv	( SwitchChecker(..), UnfoldingDetails(..) )
-> import SplitUniq
-> import TyVarEnv
+> import UniqSupply
 > import Util
 
 > -- tmp
@@ -51,47 +49,47 @@ This is extended by one rule only: reduction of a type application.
 >	-> TypeEnv			-- Type environment
 >	-> DefExpr			-- input expression
 >	-> [DefCoreArg]			-- args
->	-> SUniqSM DefExpr
+>	-> UniqSM DefExpr
 
-> tran sw p t e@(CoVar (DefArgVar id)) as =
+> tran sw p t e@(Var (DefArgVar id)) as =
 > 	tranVar sw p id
 >    		(
->		 mapArgs (\e -> tran sw p t e []) as  `thenSUs` \as ->
->		 returnSUs (applyToArgs (CoVar (DefArgVar new_id)) as)
+>		 mapArgs (\e -> tran sw p t e []) as  `thenUs` \as ->
+>		 returnUs (mkGenApp (Var (DefArgVar new_id)) as)
 >		)
 >		(
->		 \e -> 
->		   tran sw p t e as	`thenSUs` \e ->
->		   returnSUs (mkLabel (applyToArgs (CoVar (DefArgVar new_id)) 
->		   			(map (substTyArg t) as)) 
+>		 \e ->
+>		   tran sw p t e as	`thenUs` \e ->
+>		   returnUs (mkLabel (mkGenApp (Var (DefArgVar new_id))
+>		   			(map (substTyArg t) as))
 >				      e)
 >		)
 >	where new_id = applyTypeEnvToId t id
 
-> tran sw p t e@(CoLit l) [] =
-> 	returnSUs e
->	
-> tran sw p t (CoCon c ts es) [] =
-> 	mapSUs (tranAtom sw p t) es 		`thenSUs` \es ->
->	returnSUs (CoCon c (map (applyTypeEnvToTy t) ts) es)
->	
-> tran sw p t (CoPrim op ts es) [] =	-- XXX constant folding?
-> 	mapSUs (tranAtom sw p t) es	`thenSUs` \es ->
->	returnSUs (CoPrim op (map (applyTypeEnvToTy t) ts) es)
->
-> tran sw p t (CoLam vs e) [] =
-> 	tran sw p t e []			`thenSUs` \e ->
->	returnSUs (mkCoLam (map (applyTypeEnvToId t) vs) e)
->
-> tran sw p t (CoLam vs e) as =
-> 	subst s e				`thenSUs` \e ->
-> 	tran sw p t (mkCoLam rvs e) ras
+> tran sw p t e@(Lit l) [] =
+> 	returnUs e
+>
+> tran sw p t (Con c ts es) [] =
+> 	mapUs (tranAtom sw p t) es 		`thenUs` \es ->
+>	returnUs (Con c (map (applyTypeEnvToTy t) ts) es)
+>
+> tran sw p t (Prim op ts es) [] =	-- XXX constant folding?
+> 	mapUs (tranAtom sw p t) es	`thenUs` \es ->
+>	returnUs (Prim op (map (applyTypeEnvToTy t) ts) es)
+>
+> tran sw p t (Lam vs e) [] =
+> 	tran sw p t e []			`thenUs` \e ->
+>	returnUs (mkValLam (map (applyTypeEnvToId t) vs) e)
+>
+> tran sw p t (Lam vs e) as =
+> 	subst s e				`thenUs` \e ->
+> 	tran sw p t (mkValLam rvs e) ras
 >   where
 >   	(rvs,ras,s) = mkSubst vs as []
 
 > tran sw p t (CoTyLam alpha e) [] =
-> 	tran sw p t e []			`thenSUs` \e ->
->	returnSUs (CoTyLam alpha e)
+> 	tran sw p t e []			`thenUs` \e ->
+>	returnUs (CoTyLam alpha e)
 >
 
 	ToDo: use the environment rather than doing explicit substitution
@@ -100,8 +98,8 @@ This is extended by one rule only: reduction of a type application.
 > tran sw p t (CoTyLam alpha e) (TypeArg ty : as) =
 > 	tran sw p t (applyTypeEnvToExpr (mkTyVarEnv [(alpha,ty)]) e) as
 
-> tran sw p t (CoApp e v) as =
-> 	maybeJumbleApp e v			`thenSUs` \j ->
+> tran sw p t (App e v) as =
+> 	maybeJumbleApp e v			`thenUs` \j ->
 >	case j of
 >		Nothing -> tran sw p t e (ValArg v : as)
 >		Just e' -> tran sw p t e' as
@@ -109,31 +107,31 @@ This is extended by one rule only: reduction of a type application.
 > tran sw p t (CoTyApp e ty) as =
 >	tran sw p t e (TypeArg (applyTypeEnvToTy t ty) : as)
 >
-> tran sw p t (CoLet (CoNonRec v e) e') as =
-> 	tran sw p t e []			`thenSUs` \e  ->
+> tran sw p t (Let (NonRec v e) e') as =
+> 	tran sw p t e []			`thenUs` \e  ->
 >	if isConstant e then
 >		trace "yippee!!" $
->		subst [(v,removeLabels e)] e'		`thenSUs` \e' ->
+>		subst [(v,removeLabels e)] e'		`thenUs` \e' ->
 >		tran sw p t e' as
 >	else
->		tran sw p t e' as		`thenSUs` \e' ->
->		returnSUs (CoLet (CoNonRec (applyTypeEnvToId t v) e) e')
->
-> tran sw p t (CoLet (CoRec bs) e) as =
-> 	tranRecBinds sw p t bs e		`thenSUs` \(p',resid,e) ->
->	tran sw p' t e as			`thenSUs` \e ->
->	returnSUs (mkDefLetrec resid e)
->	
-> tran sw p t (CoSCC l e) as =
-> 	tran sw p t e []			`thenSUs` \e ->
->	mapArgs (\e -> tran sw p t e []) as	`thenSUs` \as ->
->	returnSUs (applyToArgs (CoSCC l e) as)
->	
-> tran sw p t (CoCase e ps) as =
+>		tran sw p t e' as		`thenUs` \e' ->
+>		returnUs (Let (NonRec (applyTypeEnvToId t v) e) e')
+>
+> tran sw p t (Let (Rec bs) e) as =
+> 	tranRecBinds sw p t bs e		`thenUs` \(p',resid,e) ->
+>	tran sw p' t e as			`thenUs` \e ->
+>	returnUs (mkDefLetrec resid e)
+>
+> tran sw p t (SCC l e) as =
+> 	tran sw p t e []			`thenUs` \e ->
+>	mapArgs (\e -> tran sw p t e []) as	`thenUs` \as ->
+>	returnUs (mkGenApp (SCC l e) as)
+>
+> tran sw p t (Case e ps) as =
 > 	tranCase sw p t e [] ps as
->	
-> tran _ _ _ e as = 
-> 	defPanic "DefExpr" "tran" (applyToArgs e as)
+>
+> tran _ _ _ e as =
+> 	defPanic "DefExpr" "tran" (mkGenApp e as)
 
 -----------------------------------------------------------------------------
 Transformation for case expressions of the form (case e1..en of {..})
@@ -146,62 +144,62 @@ Transformation for case expressions of the form (case e1..en of {..})
 >	-> [DefCoreArg]
 >	-> DefCaseAlternatives
 >	-> [DefCoreArg]
->	-> SUniqSM DefExpr
+>	-> UniqSM DefExpr
 
 > tranCase sw p t e bs ps as = case e of
->	
->	CoVar (DefArgVar id) ->
+>
+>	Var (DefArgVar id) ->
 >	   	tranVar sw p id
 >		   (
->		     tranAlts sw p t ps as	`thenSUs` \ps ->
->		     mapArgs (\e -> tran sw p t e []) bs  `thenSUs` \bs ->
->		     returnSUs 
->			  (CoCase 
->		           (applyToArgs (CoVar (DefArgVar 
->			   			  (applyTypeEnvToId t id))) 
+>		     tranAlts sw p t ps as	`thenUs` \ps ->
+>		     mapArgs (\e -> tran sw p t e []) bs  `thenUs` \bs ->
+>		     returnUs
+>			  (Case
+>		           (mkGenApp (Var (DefArgVar
+>			   			  (applyTypeEnvToId t id)))
 >			   	  bs)
 >			   ps)
 >		   )
 >		   (
 >		     \e ->
->		     tranCase sw p t e bs ps as	`thenSUs` \e ->
->		     returnSUs 
->		       (mkLabel 
->		           (applyToArgs 
->			      (CoCase (applyToArgs (CoVar (DefArgVar id)) 
+>		     tranCase sw p t e bs ps as	`thenUs` \e ->
+>		     returnUs
+>		       (mkLabel
+>		           (mkGenApp
+>			      (Case (mkGenApp (Var (DefArgVar id))
 >			      		(map (substTyArg t) bs))
 >				      ps)
 >			      (map (substTyArg t) as))
 >			   e)
 >		   )
 >
->	CoLit l ->
+>	Lit l ->
 >		case bs of
->		  [] -> tranAlts sw p t ps as		`thenSUs` \ps ->
->		  	returnSUs (CoCase e ps)
+>		  [] -> tranAlts sw p t ps as		`thenUs` \ps ->
+>		  	returnUs (Case e ps)
 >		  _ -> die_horribly
->		
->	CoPrim op ts es -> 
+>
+>	Prim op ts es ->
 >		case bs of
->		  [] -> tranAlts sw p t ps as 		`thenSUs` \ps ->
->			mapSUs (tranAtom sw p t) es	`thenSUs` \es ->
->			returnSUs (CoCase (CoPrim op 
+>		  [] -> tranAlts sw p t ps as 		`thenUs` \ps ->
+>			mapUs (tranAtom sw p t) es	`thenUs` \es ->
+>			returnUs (Case (Prim op
 >					(map (applyTypeEnvToTy t) ts) es) ps)
 >		  _ -> die_horribly
->		  
->	CoCon c ts es ->
+>
+>	Con c ts es ->
 >		case bs of
 >		  [] -> case ps of
->			  CoAlgAlts alts def -> 
+>			  AlgAlts alts def ->
 >				reduceCase sw p c ts es alts def as
->			  CoPrimAlts alts def -> die_horribly
+>			  PrimAlts alts def -> die_horribly
 >		  _ -> die_horribly
->	
->	CoLam vs e ->
+>
+>	Lam vs e ->
 >		case bs of
 >			[] -> die_horribly
 >			(TypeArg _ : _) -> die_horribly
->			_ -> subst s e		`thenSUs` \e ->
+>			_ -> subst s e		`thenUs` \e ->
 >			     tranCase sw p t e rbs ps as
 >	   where
 >	   	(rvs,rbs,s) = mkSubst vs bs []
@@ -211,73 +209,73 @@ Transformation for case expressions of the form (case e1..en of {..})
 >		  TypeArg ty : bs' -> tranCase sw p t e' bs' ps as
 >		     where e' = applyTypeEnvToExpr (mkTyVarEnv [(alpha,ty)]) e
 >		  _ -> die_horribly
->			
->	CoApp e v ->
->		maybeJumbleApp e v	 		`thenSUs` \j ->
+>
+>	App e v ->
+>		maybeJumbleApp e v	 		`thenUs` \j ->
 >		case j of
 >			Nothing -> tranCase sw p t e (ValArg v : bs) ps as
 >			Just e' -> tranCase sw p t e' bs ps as
->		
+>
 >	CoTyApp e ty ->
 >		tranCase sw p t e (TypeArg (applyTypeEnvToTy t ty) : bs)
 >			ps as
->	
->	CoLet (CoNonRec v e) e' ->
-> 		tran sw p t e []			`thenSUs` \e  ->
+>
+>	Let (NonRec v e) e' ->
+> 		tran sw p t e []			`thenUs` \e  ->
 >		if isConstant e then
 >			trace "yippee2!!" $
->			subst [(v,removeLabels e)] e'	`thenSUs` \e' ->
+>			subst [(v,removeLabels e)] e'	`thenUs` \e' ->
 >			tranCase sw p t e' bs ps as
 >		else
->			tranCase sw p t e' bs ps as	`thenSUs` \e' ->
->			returnSUs (CoLet (CoNonRec 
+>			tranCase sw p t e' bs ps as	`thenUs` \e' ->
+>			returnUs (Let (NonRec
 >						(applyTypeEnvToId t v) e) e')
 >
->	CoLet (CoRec binds) e ->
-> 		tranRecBinds sw p t binds e	`thenSUs` \(p',resid,e) ->
->		tranCase sw p' t e bs ps as		`thenSUs` \e ->
->		returnSUs (mkDefLetrec resid e)
->		
+>	Let (Rec binds) e ->
+> 		tranRecBinds sw p t binds e	`thenUs` \(p',resid,e) ->
+>		tranCase sw p' t e bs ps as		`thenUs` \e ->
+>		returnUs (mkDefLetrec resid e)
+>
 >	-- ToDo: sort out cost centres.  Currently they act as a barrier
 >	-- to optimisation.
->	CoSCC l e ->
->	   	tran sw p t e []			`thenSUs` \e ->
+>	SCC l e ->
+>	   	tran sw p t e []			`thenUs` \e ->
 >		mapArgs (\e -> tran sw p t e []) bs
->							`thenSUs` \bs ->
->		tranAlts sw p t ps as			`thenSUs` \ps ->
->		returnSUs (CoCase (applyToArgs (CoSCC l e) bs)
+>							`thenUs` \bs ->
+>		tranAlts sw p t ps as			`thenUs` \ps ->
+>		returnUs (Case (mkGenApp (SCC l e) bs)
 >				  ps)
->		
->	CoCase e ps' ->
+>
+>	Case e ps' ->
 >		tranCase sw p t e []
->		     (mapAlts (\e -> applyToArgs (CoCase e ps) bs) ps') as
->		
+>		     (mapAlts (\e -> mkGenApp (Case e ps) bs) ps') as
+>
 >	_ -> die_horribly
->	
->    where die_horribly = defPanic "DefExpr" "tranCase" 
->    			(applyToArgs (CoCase (applyToArgs e bs) ps) as)
+>
+>    where die_horribly = defPanic "DefExpr" "tranCase"
+>    			(mkGenApp (Case (mkGenApp e bs) ps) as)
 
 -----------------------------------------------------------------------------
-Deciding whether or not to replace a function variable with it's 
+Deciding whether or not to replace a function variable with it's
 definition.  The tranVar function is passed four arguments: the
 environment, the Id itself, the expression to return if no
 unfolding takes place, and a function to apply to the unfolded expression
 should an unfolding be required.
 
-> tranVar 
+> tranVar
 > 	:: SwitchChecker who_knows
 >	-> IdEnv DefExpr
 >	-> Id
->	-> SUniqSM DefExpr
->	-> (DefExpr -> SUniqSM DefExpr)
->	-> SUniqSM DefExpr
->	
+>	-> UniqSM DefExpr
+>	-> (DefExpr -> UniqSM DefExpr)
+>	-> UniqSM DefExpr
+>
 > tranVar sw p id no_unfold unfold_with =
-> 	
+>
 >   case lookupIdEnv p id of
 >	Just e' ->
->		rebindExpr e' 	`thenSUs` \e' ->
->		if deforestable id 
+>		rebindExpr e' 	`thenUs` \e' ->
+>		if deforestable id
 >	   	   then unfold_with e'
 >		   else panic "DefExpr(tran): not deforestable id in env"
 
@@ -286,18 +284,18 @@ should an unfolding be required.
 	in which case it will have an unfolding inside the Id
 	itself.
 
->	Nothing -> 
+>	Nothing ->
 >	  if (not . deforestable) id
 >	  	then  no_unfold
->					
+>
 >		else case (getIdUnfolding id) of
->			GeneralForm _ _ expr guidance ->
->			  panic "DefExpr:GeneralForm has changed a little; needs mod here"
+>			GenForm _ _ expr guidance ->
+>			  panic "DefExpr:GenForm has changed a little; needs mod here"
 >			  -- SLPJ March 95
 >
 >--???			  -- ToDo: too much overhead here.
 >--???		          let e' = c2d nullIdEnv expr in
->--???			  convertToTreelessForm sw e'	`thenSUs` \e'' ->
+>--???			  convertToTreelessForm sw e'	`thenUs` \e'' ->
 >--???			  unfold_with e''
 >		      	_ -> no_unfold
 
@@ -309,65 +307,65 @@ should an unfolding be required.
 
 >			{- panic
 >		       		("DefExpr(tran): Deforestable id `"
->		     		++ ppShow 80 (ppr PprDebug id) 
+>		     		++ ppShow 80 (ppr PprDebug id)
 >				++ "' doesn't have an unfolding.") -}
 
 -----------------------------------------------------------------------------
 Transform a set of case alternatives.
 
-> tranAlts 
+> tranAlts
 > 	:: SwitchChecker who_knows
 >	-> IdEnv DefExpr
 >	-> TypeEnv
 >	-> DefCaseAlternatives
 >	-> [DefCoreArg]
->	-> SUniqSM DefCaseAlternatives
+>	-> UniqSM DefCaseAlternatives
 
-> tranAlts sw p t (CoAlgAlts alts def) as =
-> 	mapSUs (tranAlgAlt sw p t as) alts	`thenSUs` \alts ->
->	tranDefault sw p t def as		`thenSUs` \def ->
->	returnSUs (CoAlgAlts alts def)
-> tranAlts sw p t (CoPrimAlts alts def) as =
-> 	mapSUs (tranPrimAlt sw p t as) alts	`thenSUs` \alts ->
->	tranDefault sw p t def as		`thenSUs` \def ->
->	returnSUs (CoPrimAlts alts def)
+> tranAlts sw p t (AlgAlts alts def) as =
+> 	mapUs (tranAlgAlt sw p t as) alts	`thenUs` \alts ->
+>	tranDefault sw p t def as		`thenUs` \def ->
+>	returnUs (AlgAlts alts def)
+> tranAlts sw p t (PrimAlts alts def) as =
+> 	mapUs (tranPrimAlt sw p t as) alts	`thenUs` \alts ->
+>	tranDefault sw p t def as		`thenUs` \def ->
+>	returnUs (PrimAlts alts def)
 
 > tranAlgAlt sw p t as (c, vs, e) =
-> 	tran sw p t e as			`thenSUs` \e ->
->	returnSUs (c, map (applyTypeEnvToId t) vs, e)
+> 	tran sw p t e as			`thenUs` \e ->
+>	returnUs (c, map (applyTypeEnvToId t) vs, e)
 > tranPrimAlt sw p t as (l, e) =
-> 	tran sw p t e as			`thenSUs` \e ->
->	returnSUs (l, e)
->	
-> tranDefault sw p t CoNoDefault as = returnSUs CoNoDefault
-> tranDefault sw p t (CoBindDefault v e) as =
-> 	tran sw p t e as			`thenSUs` \e ->
->	returnSUs (CoBindDefault (applyTypeEnvToId t v) e)
+> 	tran sw p t e as			`thenUs` \e ->
+>	returnUs (l, e)
+>
+> tranDefault sw p t NoDefault as = returnUs NoDefault
+> tranDefault sw p t (BindDefault v e) as =
+> 	tran sw p t e as			`thenUs` \e ->
+>	returnUs (BindDefault (applyTypeEnvToId t v) e)
 
 -----------------------------------------------------------------------------
 Transform an atom.
 
-> tranAtom 
+> tranAtom
 > 	:: SwitchChecker who_knows
->	-> IdEnv DefExpr 
->	-> TypeEnv 
->	-> DefAtom 
->	-> SUniqSM DefAtom
+>	-> IdEnv DefExpr
+>	-> TypeEnv
+>	-> DefAtom
+>	-> UniqSM DefAtom
 
-> tranAtom sw p t (CoVarAtom v) =
-> 	tranArg sw p t v			`thenSUs` \v ->
->	returnSUs (CoVarAtom v)
-> tranAtom sw p t e@(CoLitAtom l) =	-- XXX
-> 	returnSUs e
+> tranAtom sw p t (VarArg v) =
+> 	tranArg sw p t v			`thenUs` \v ->
+>	returnUs (VarArg v)
+> tranAtom sw p t e@(LitArg l) =	-- XXX
+> 	returnUs e
 
 > tranArg sw p t (DefArgExpr e) =
-> 	tran sw p t e []			`thenSUs` \e ->
->	returnSUs (DefArgExpr e)
+> 	tran sw p t e []			`thenUs` \e ->
+>	returnUs (DefArgExpr e)
 > tranArg sw p t e@(Label _ _) =
-> 	defPanic "DefExpr" "tranArg" (CoVar e)
+> 	defPanic "DefExpr" "tranArg" (Var e)
 > tranArg sw p t (DefArgVar v) =
-> 	tran sw p t (CoVar (DefArgVar v)) []	`thenSUs` \e -> 
->	returnSUs (DefArgExpr e) 	-- XXX remove this case
+> 	tran sw p t (Var (DefArgVar v)) []	`thenUs` \e ->
+>	returnUs (DefArgExpr e) 	-- XXX remove this case
 
 -----------------------------------------------------------------------------
 Translating recursive definition groups.
@@ -391,21 +389,21 @@ fvs.  Expand the argument list of each function by
 and substitute the new function calls throughout the function set.
 
 
->	let 
+>	let
 >	    (unfold,resid) = partition (deforestable . fst) bs
 >	in
 
-> 	mapSUs (tranRecBind sw p t) unfold	`thenSUs` \unfold ->
-> 	mapSUs (tranRecBind sw p t) resid	`thenSUs` \resid ->
+> 	mapUs (tranRecBind sw p t) unfold	`thenUs` \unfold ->
+> 	mapUs (tranRecBind sw p t) resid	`thenUs` \resid ->
 
-	Tie knots in the deforestable right-hand sides, and convert the 
-	results to treeless form. Then extract any nested deforestable 
-	recursive functions, and place everything we've got in the new 
+	Tie knots in the deforestable right-hand sides, and convert the
+	results to treeless form. Then extract any nested deforestable
+	recursive functions, and place everything we've got in the new
 	environment.
 
 > 	let (vs,es) = unzip unfold in
->	mapSUs mkLoops es			`thenSUs` \res ->
->	let 
+>	mapUs mkLoops es			`thenUs` \res ->
+>	let
 >		(extracted,new_rhss) = unzip res
 >		new_binds = zip vs new_rhss ++ concat extracted
 >	in
@@ -415,9 +413,9 @@ and substitute the new function calls throughout the function set.
 	bound in this letrec are about to change status from not
 	unfolded to unfolded).
 
->	mapSUs (\(v,e) -> 
->		convertToTreelessForm sw e 	`thenSUs` \e ->
->		returnSUs (v,e)) new_binds	`thenSUs` \fs ->
+>	mapUs (\(v,e) ->
+>		convertToTreelessForm sw e 	`thenUs` \e ->
+>		returnUs (v,e)) new_binds	`thenUs` \fs ->
 
 	Now find the total set of free variables of this function set.
 
@@ -432,82 +430,82 @@ and substitute the new function calls throughout the function set.
 >	    stuff          = [ fixupFreeVars fvs id e | (id,e) <- fs ]
 >	    fs'	   	   = map fst stuff
 >	    s 		   = concat (map snd stuff)
->	    subIt (id,e)   = subst s e `thenSUs` \e -> returnSUs (id,e)
+>	    subIt (id,e)   = subst s e `thenUs` \e -> returnUs (id,e)
 >	in
->	subst s e				`thenSUs` \e  ->
->	mapSUs subIt resid			`thenSUs` \resid ->
->	mapSUs subIt fs'			`thenSUs` \fs ->
+>	subst s e				`thenUs` \e  ->
+>	mapUs subIt resid			`thenUs` \resid ->
+>	mapUs subIt fs'			`thenUs` \fs ->
 
->	let res = returnSUs (growIdEnvList p fs, resid, e) in
+>	let res = returnUs (growIdEnvList p fs, resid, e) in
 >	case unzip fs of
->		(evs,ees) -> mapSUs d2c ees `thenSUs` \ees ->
+>		(evs,ees) -> mapUs d2c ees `thenUs` \ees ->
 >			   let (vs',es') = unzip bs in
->			   mapSUs d2c es' `thenSUs` \es' ->
->		      trace ("extraction " 
->		      		++ showIds (map fst bs) 
+>			   mapUs d2c es' `thenUs` \es' ->
+>		      trace ("extraction "
+>		      		++ showIds (map fst bs)
 >		      		++ showIds evs
 >				++ "\n{ input:\n" ++ (concat (map showBind (zip vs' es'))) ++ "}\n"
 >				++ "{ result:\n" ++ (concat  (map showBind (zip evs ees))) ++ "}\n") res
 >		   where showBind (v,e) = ppShow 80 (ppr PprDebug v) ++ "=\n" ++ ppShow 80 (ppr PprDebug e) ++ "\n"
 
 > tranRecBind sw p t (id,e) =
->	tran sw p t e []			`thenSUs` \e ->
->	returnSUs (applyTypeEnvToId t id,e)
+>	tran sw p t e []			`thenUs` \e ->
+>	returnUs (applyTypeEnvToId t id,e)
 
 > showIds :: [Id] -> String
-> showIds ids = "(" ++ concat (map ((' ' :) . ppShow 80 . ppr PprDebug) ids) 
+> showIds ids = "(" ++ concat (map ((' ' :) . ppShow 80 . ppr PprDebug) ids)
 > 	++ " )"
 
 -----------------------------------------------------------------------------
 
-> reduceCase sw p c ts es alts def as = 
+> reduceCase sw p c ts es alts def as =
 > 	case [ a | a@(c',vs,e) <- alts, c' == c ] of
 >		[(c,vs,e)] ->
->			subst (zip vs (map atom2expr es)) e `thenSUs` \e ->
+>			subst (zip vs (map atom2expr es)) e `thenUs` \e ->
 >			tran sw p nullTyVarEnv e as
 >		[] -> case def of
->			CoNoDefault -> 
+>			NoDefault ->
 >				panic "DefExpr(reduceCase): no match"
->			CoBindDefault v e ->
->				subst [(v,CoCon c ts es)] e `thenSUs` \e ->
+>			BindDefault v e ->
+>				subst [(v,Con c ts es)] e `thenUs` \e ->
 >				tran sw p nullTyVarEnv e as
 >		_ -> panic "DefExpr(reduceCase): multiple matches"
 
 -----------------------------------------------------------------------------
 Type Substitutions.
 
-> applyTypeEnvToExpr 
+> applyTypeEnvToExpr
 > 	:: TypeEnv
 > 	-> DefExpr
 >	-> DefExpr
 
 > applyTypeEnvToExpr p e = substTy e
->   where 
+>   where
 >     substTy e' = case e' of
-> 	CoVar (DefArgExpr e) -> panic "DefExpr(substTy): CoVar (DefArgExpr _)"
->	CoVar (Label l e)    -> panic "DefExpr(substTy): CoVar (Label _ _)"
->       CoVar (DefArgVar id) -> CoVar (DefArgVar (applyTypeEnvToId p id))
->       CoLit l              -> e'
->       CoCon c ts es        -> 
->		CoCon c (map (applyTypeEnvToTy p) ts) (map substTyAtom es)
->       CoPrim op ts es      -> 
->		CoPrim op (map (applyTypeEnvToTy p) ts) (map substTyAtom es)
->       CoLam vs e           -> CoLam (map (applyTypeEnvToId p) vs) (substTy e)
+> 	Var (DefArgExpr e) -> panic "DefExpr(substTy): Var (DefArgExpr _)"
+>	Var (Label l e)    -> panic "DefExpr(substTy): Var (Label _ _)"
+>       Var (DefArgVar id) -> Var (DefArgVar (applyTypeEnvToId p id))
+>       Lit l              -> e'
+>       Con c ts es        ->
+>		Con c (map (applyTypeEnvToTy p) ts) (map substTyAtom es)
+>       Prim op ts es      ->
+>		Prim op (map (applyTypeEnvToTy p) ts) (map substTyAtom es)
+>       Lam vs e           -> Lam (map (applyTypeEnvToId p) vs) (substTy e)
 >       CoTyLam alpha e      -> CoTyLam alpha (substTy e)
->       CoApp e v            -> CoApp (substTy e) (substTyAtom v)
->       CoTyApp e t          -> mkCoTyApp (substTy e) (applyTypeEnvToTy p t)
->       CoCase e ps          -> CoCase (substTy e) (substTyCaseAlts ps)
->       CoLet (CoNonRec id e) e' -> 
->		CoLet (CoNonRec (applyTypeEnvToId p id) (substTy e)) 
+>       App e v            -> App (substTy e) (substTyAtom v)
+>       CoTyApp e t          -> CoTyApp (substTy e) (applyTypeEnvToTy p t)
+>       Case e ps          -> Case (substTy e) (substTyCaseAlts ps)
+>       Let (NonRec id e) e' ->
+>		Let (NonRec (applyTypeEnvToId p id) (substTy e))
 >			(substTy e')
->       CoLet (CoRec bs) e   -> 
->		CoLet (CoRec (map substTyRecBind bs)) (substTy e)
+>       Let (Rec bs) e   ->
+>		Let (Rec (map substTyRecBind bs)) (substTy e)
 >		where substTyRecBind (v,e) = (applyTypeEnvToId p v, substTy e)
->       CoSCC l e            -> CoSCC l (substTy e)
+>       SCC l e            -> SCC l (substTy e)
 
 >     substTyAtom :: DefAtom -> DefAtom
->     substTyAtom (CoVarAtom v) = CoVarAtom (substTyArg v)
->     substTyAtom (CoLitAtom l) = CoLitAtom l -- XXX
+>     substTyAtom (VarArg v) = VarArg (substTyArg v)
+>     substTyAtom (LitArg l) = LitArg l -- XXX
 
 >     substTyArg :: DefBindee -> DefBindee
 >     substTyArg (DefArgExpr e) = DefArgExpr (substTy e)
@@ -515,51 +513,51 @@ Type Substitutions.
 >     substTyArg e@(DefArgVar id)  =	-- XXX
 >		DefArgVar (applyTypeEnvToId p id)
 
->     substTyCaseAlts (CoAlgAlts as def) 
-> 	= CoAlgAlts (map substTyAlgAlt as) (substTyDefault def)
->     substTyCaseAlts (CoPrimAlts as def) 
-> 	= CoPrimAlts (map substTyPrimAlt as) (substTyDefault def)
+>     substTyCaseAlts (AlgAlts as def)
+> 	= AlgAlts (map substTyAlgAlt as) (substTyDefault def)
+>     substTyCaseAlts (PrimAlts as def)
+> 	= PrimAlts (map substTyPrimAlt as) (substTyDefault def)
 
 >     substTyAlgAlt  (c, vs, e) = (c, map (applyTypeEnvToId p) vs, substTy e)
 >     substTyPrimAlt (l, e) = (l, substTy e)
 
->     substTyDefault CoNoDefault = CoNoDefault
->     substTyDefault (CoBindDefault id e) = 
->     		CoBindDefault (applyTypeEnvToId p id) (substTy e)
+>     substTyDefault NoDefault = NoDefault
+>     substTyDefault (BindDefault id e) =
+>     		BindDefault (applyTypeEnvToId p id) (substTy e)
 
-> substTyArg t (ValArg e)   = 
-> 	ValArg (CoVarAtom (DefArgExpr (applyTypeEnvToExpr t (atom2expr e))))
+> substTyArg t (ValArg e)   =
+> 	ValArg (VarArg (DefArgExpr (applyTypeEnvToExpr t (atom2expr e))))
 > substTyArg t (TypeArg ty) = TypeArg ty
 
 -----------------------------------------------------------------------------
 
 > mapAlts f ps = case ps of
->	CoAlgAlts alts def -> 
->	   CoAlgAlts (map (\(c,vs,e) -> (c,vs,f e)) alts) (mapDef f def)
->	CoPrimAlts alts def ->
->	   CoPrimAlts (map (\(l,e) -> (l, f e)) alts) (mapDef f def)
->				
-> mapDef f CoNoDefault 		= CoNoDefault
-> mapDef f (CoBindDefault v e)  = CoBindDefault v (f e)
+>	AlgAlts alts def ->
+>	   AlgAlts (map (\(c,vs,e) -> (c,vs,f e)) alts) (mapDef f def)
+>	PrimAlts alts def ->
+>	   PrimAlts (map (\(l,e) -> (l, f e)) alts) (mapDef f def)
+>
+> mapDef f NoDefault 		= NoDefault
+> mapDef f (BindDefault v e)  = BindDefault v (f e)
 
 -----------------------------------------------------------------------------
 Apply a function to all the ValArgs in an Args list.
 
-> mapArgs 
-> 	:: (DefExpr -> SUniqSM DefExpr) 
->	-> [DefCoreArg] 
->	-> SUniqSM [DefCoreArg]
->	
-> mapArgs f [] = 
-> 	returnSUs []
-> mapArgs f (a@(TypeArg ty) : as) = 
-> 	mapArgs f as			`thenSUs` \as ->
->	returnSUs (a:as)
+> mapArgs
+> 	:: (DefExpr -> UniqSM DefExpr)
+>	-> [DefCoreArg]
+>	-> UniqSM [DefCoreArg]
+>
+> mapArgs f [] =
+> 	returnUs []
+> mapArgs f (a@(TypeArg ty) : as) =
+> 	mapArgs f as			`thenUs` \as ->
+>	returnUs (a:as)
 > mapArgs f (ValArg v : as) =
-> 	f (atom2expr v)			`thenSUs` \e ->
->	mapArgs f as			`thenSUs` \as ->
->	returnSUs (ValArg (CoVarAtom (DefArgExpr e)) : as)
-> 	
+> 	f (atom2expr v)			`thenUs` \e ->
+>	mapArgs f as			`thenUs` \as ->
+>	returnUs (ValArg (VarArg (DefArgExpr e)) : as)
+>
 
 > mkSubst [] as s = ([],as,s)
 > mkSubst vs [] s = (vs,[],s)
@@ -580,7 +578,7 @@ earlier, and avoids the need to do matching instead of renaming.
 We also pull out lets from function arguments, and primitive case
 expressions (which can't fail anyway).
 
-Think: 
+Think:
 
 	(t (case u of x -> v))
 	====>
@@ -591,55 +589,55 @@ has an unboxed type.
 
 ToDo: sort this mess out - could be more efficient.
 
-> maybeJumbleApp :: DefExpr -> DefAtom -> SUniqSM (Maybe DefExpr)
-> maybeJumbleApp e (CoLitAtom _) = returnSUs Nothing -- ToDo remove
-> maybeJumbleApp e (CoVarAtom (DefArgExpr (CoVar (DefArgVar _))))
-> 	= returnSUs Nothing
-> maybeJumbleApp e (CoVarAtom (DefArgExpr t))
+> maybeJumbleApp :: DefExpr -> DefAtom -> UniqSM (Maybe DefExpr)
+> maybeJumbleApp e (LitArg _) = returnUs Nothing -- ToDo remove
+> maybeJumbleApp e (VarArg (DefArgExpr (Var (DefArgVar _))))
+> 	= returnUs Nothing
+> maybeJumbleApp e (VarArg (DefArgExpr t))
 >	= let t' = pull_out t [] in
 >	  case t' of
->		CoLet _ _ -> returnSUs (Just t')
->		CoCase (CoPrim _ _ _) (CoPrimAlts [] _) -> returnSUs (Just t')
+>		Let _ _ -> returnUs (Just t')
+>		Case (Prim _ _ _) (PrimAlts [] _) -> returnUs (Just t')
 >		_ -> if isBoringExpr t then
 >			rebind_with_let t
 >		     else
->		     	returnSUs Nothing
+>		     	returnUs Nothing
 
->	where isBoringExpr (CoVar (DefArgVar z)) = (not . deforestable) z
->	      isBoringExpr (CoPrim op ts es) = True
->	      isBoringExpr (CoCase e ps) = isBoringExpr e 
+>	where isBoringExpr (Var (DefArgVar z)) = (not . deforestable) z
+>	      isBoringExpr (Prim op ts es) = True
+>	      isBoringExpr (Case e ps) = isBoringExpr e
 >	      			&& boringCaseAlternatives ps
->	      isBoringExpr (CoApp l r) = isBoringExpr l
+>	      isBoringExpr (App l r) = isBoringExpr l
 >	      isBoringExpr (CoTyApp l t) = isBoringExpr l
 >	      isBoringExpr _ = False
 >
->	      boringCaseAlternatives (CoAlgAlts as d) =
+>	      boringCaseAlternatives (AlgAlts as d) =
 >	      	all boringAlgAlt as && boringDefault d
->	      boringCaseAlternatives (CoPrimAlts as d) =
+>	      boringCaseAlternatives (PrimAlts as d) =
 >	      	all boringPrimAlt as && boringDefault d
->		
+>
 >	      boringAlgAlt  (c,xs,e) = isBoringExpr e
 >	      boringPrimAlt (l,e)    = isBoringExpr e
->	      
->	      boringDefault CoNoDefault = True
->	      boringDefault (CoBindDefault x e) = isBoringExpr e
-
->	      pull_out (CoLet b t) as = CoLet b (pull_out t as)
->	      pull_out (CoApp l r) as = pull_out l (r:as)
->	      pull_out (CoCase prim@(CoPrim _ _ _) 
->	    		(CoPrimAlts [] (CoBindDefault x u))) as
->		= CoCase prim (CoPrimAlts [] (CoBindDefault x 
+>
+>	      boringDefault NoDefault = True
+>	      boringDefault (BindDefault x e) = isBoringExpr e
+
+>	      pull_out (Let b t) as = Let b (pull_out t as)
+>	      pull_out (App l r) as = pull_out l (r:as)
+>	      pull_out (Case prim@(Prim _ _ _)
+>	    		(PrimAlts [] (BindDefault x u))) as
+>		= Case prim (PrimAlts [] (BindDefault x
 >			(pull_out u as)))
->	      pull_out t as 
->	      	= CoApp e (CoVarAtom (DefArgExpr (foldl CoApp t as)))
->	      
->	      rebind_with_let t = 
->			d2c t	`thenSUs`  \core_t ->
->			newDefId (typeOfCoreExpr core_t) `thenSUs` \x ->
+>	      pull_out t as
+>	      	= App e (VarArg (DefArgExpr (foldl App t as)))
+>
+>	      rebind_with_let t =
+>			d2c t	`thenUs`  \core_t ->
+>			newDefId (coreExprType core_t) `thenUs` \x ->
 >			trace "boring epxr found!" $
->			returnSUs (Just (CoLet (CoNonRec x t)
->				     (CoApp e (CoVarAtom (
->					DefArgExpr (CoVar (
+>			returnUs (Just (Let (NonRec x t)
+>				     (App e (VarArg (
+>					DefArgExpr (Var (
 >					   DefArgVar x)))))))
 
 -----------------------------------------------------------------------------
@@ -648,10 +646,10 @@ ToDo: sort this mess out - could be more efficient.
 >		Just (LitInst _ _ _ _) -> True
 >		_ -> False
 
-> isConstant (CoCon c [] []) = True
-> isConstant (CoLit l)       = True
-> isConstant (CoVar (Label l e)) = isConstant e
+> isConstant (Con c [] []) = True
+> isConstant (Lit l)       = True
+> isConstant (Var (Label l e)) = isConstant e
 > isConstant _               = False
 
-> removeLabels (CoVar (Label l e)) = removeLabels e
+> removeLabels (Var (Label l e)) = removeLabels e
 > removeLabels e = e
diff --git a/ghc/compiler/deforest/DefSyn.hi b/ghc/compiler/deforest/DefSyn.hi
deleted file mode 100644
index 7a023f2e54..0000000000
--- a/ghc/compiler/deforest/DefSyn.hi
+++ /dev/null
@@ -1,14 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 3 #-}
-interface DefSyn where
-import CoreSyn(CoreArg, CoreAtom, CoreBinding, CoreCaseAlternatives, CoreCaseDefault, CoreExpr)
-import Id(Id)
-type DefAtom = CoreAtom DefBindee
-data DefBindee   = DefArgExpr (CoreExpr Id DefBindee) | DefArgVar Id | Label (CoreExpr Id DefBindee) (CoreExpr Id DefBindee)
-type DefBinding = CoreBinding Id DefBindee
-type DefCaseAlternatives = CoreCaseAlternatives Id DefBindee
-type DefCaseDefault = CoreCaseDefault Id DefBindee
-type DefCoreArg = CoreArg DefBindee
-type DefExpr = CoreExpr Id DefBindee
-type DefProgram = [CoreBinding Id DefBindee]
-mkLabel :: CoreExpr Id DefBindee -> CoreExpr Id DefBindee -> CoreExpr Id DefBindee
-
diff --git a/ghc/compiler/deforest/DefSyn.lhs b/ghc/compiler/deforest/DefSyn.lhs
index afb72d536a..512d2ad565 100644
--- a/ghc/compiler/deforest/DefSyn.lhs
+++ b/ghc/compiler/deforest/DefSyn.lhs
@@ -12,16 +12,16 @@
 This is exactly the same as core, except that the argument to
 application can be an arbitrary expression.
 
-> type DefProgram 		= [CoreBinding 	Id DefBindee]
-> type DefBinding 		= CoreBinding  	Id DefBindee
-> type DefExpr    		= CoreExpr     	Id DefBindee
-> type DefAtom    		= CoreAtom	DefBindee
-> type DefCaseAlternatives	= CoreCaseAlternatives Id DefBindee
-> type DefCaseDefault		= CoreCaseDefault Id DefBindee
+> type DefProgram 		= [GenCoreBinding 	Id DefBindee]
+> type DefBinding 		= GenCoreBinding  	Id DefBindee
+> type DefExpr    		= GenCoreExpr     	Id DefBindee
+> type DefAtom    		= GenCoreAtom	DefBindee
+> type DefCaseAlternatives	= GenCoreCaseAlts Id DefBindee
+> type DefCaseDefault		= GenCoreCaseDefault Id DefBindee
 
-> type DefCoreArg = CoreArg DefBindee
+> type DefCoreArg = GenCoreArg DefBindee
 
-> data DefBindee 
+> data DefBindee
 > 	= DefArgExpr DefExpr		-- arbitrary expressions as argumemts
 >	| DefArgVar  Id			-- or just ids
 >	| Label DefExpr DefExpr		-- labels for detecting cycles
@@ -44,16 +44,16 @@ invariants that will be adhered to during the transformation.  The
 following are alternative representations for certain expressions.
 The forms on the left are disallowed:
 
-CoVar (DefArgExpr e)	==  e
-CoVarAtom (Label l e)	==  CoVarAtom (DefArgExpr (CoVar (Label l e)))
+Var (DefArgExpr e)	==  e
+VarArg (Label l e)	==  VarArg (DefArgExpr (Var (Label l e)))
 
 For completeness, we should also have:
 
-CoVarAtom (DefArgVar v) == CoVarAtom (DefArgExpr (CoVar (DefArgVar v)))
-CoLitAtom l		== CoVarAtom (DefArgExpr (CoLit l))
+VarArg (DefArgVar v) == VarArg (DefArgExpr (Var (DefArgVar v)))
+LitArg l		== VarArg (DefArgExpr (Lit l))
 
-In other words, atoms must all be of the form (CoVarAtom (DefArgExpr
-_)) and the argument to a CoVar can only be Label or DefArgVar.
+In other words, atoms must all be of the form (VarArg (DefArgExpr
+_)) and the argument to a Var can only be Label or DefArgVar.
 
 > mkLabel :: DefExpr -> DefExpr -> DefExpr
-> mkLabel l e = CoVar (Label l e)
+> mkLabel l e = Var (Label l e)
diff --git a/ghc/compiler/deforest/DefUtils.hi b/ghc/compiler/deforest/DefUtils.hi
deleted file mode 100644
index bef19d3dd1..0000000000
--- a/ghc/compiler/deforest/DefUtils.hi
+++ /dev/null
@@ -1,27 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 3 #-}
-interface DefUtils where
-import CoreSyn(CoreAtom, CoreCaseAlternatives, CoreExpr)
-import DefSyn(DefBindee)
-import Id(Id)
-import SplitUniq(SplitUniqSupply)
-import TyVar(TyVar)
-import UniType(UniType)
-data RenameResult   = NotRenaming | IsRenaming [(Id, Id)] | InconsistentRenaming [(Id, Id)]
-atom2expr :: CoreAtom DefBindee -> CoreExpr Id DefBindee
-consistent :: [(Id, Id)] -> Bool
-deforestable :: Id -> Bool
-foldrSUs :: (a -> b -> SplitUniqSupply -> b) -> b -> [a] -> SplitUniqSupply -> b
-freeTyVars :: CoreExpr Id DefBindee -> [TyVar]
-freeVars :: CoreExpr Id DefBindee -> [Id]
-isArgId :: Id -> Bool
-mkDefLetrec :: [(a, CoreExpr a b)] -> CoreExpr a b -> CoreExpr a b
-newDefId :: UniType -> SplitUniqSupply -> Id
-newTmpId :: UniType -> SplitUniqSupply -> Id
-rebindExpr :: CoreExpr Id DefBindee -> SplitUniqSupply -> CoreExpr Id DefBindee
-renameExprs :: CoreExpr Id DefBindee -> CoreExpr Id DefBindee -> SplitUniqSupply -> RenameResult
-strip :: CoreExpr Id DefBindee -> CoreExpr Id DefBindee
-stripAtom :: CoreAtom DefBindee -> CoreAtom DefBindee
-stripCaseAlts :: CoreCaseAlternatives Id DefBindee -> CoreCaseAlternatives Id DefBindee
-subst :: [(Id, CoreExpr Id DefBindee)] -> CoreExpr Id DefBindee -> SplitUniqSupply -> CoreExpr Id DefBindee
-union :: Eq a => [a] -> [a] -> [a]
-
diff --git a/ghc/compiler/deforest/DefUtils.lhs b/ghc/compiler/deforest/DefUtils.lhs
index 81752f9b2a..54f8eeb118 100644
--- a/ghc/compiler/deforest/DefUtils.lhs
+++ b/ghc/compiler/deforest/DefUtils.lhs
@@ -1,5 +1,5 @@
 %
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
 %
 \section[DefUtils]{Miscellaneous Utility functions}
 
@@ -10,7 +10,7 @@
 >	atom2expr, newDefId, newTmpId, deforestable, foldrSUs,
 >	mkDefLetrec, subst, freeTyVars, union, consistent, RenameResult(..),
 >	isArgId
->	) 
+>	)
 > 	where
 
 > import DefSyn
@@ -20,22 +20,20 @@
 > import Trace
 >#endif
 
-> import AbsUniType	( cloneTyVar, mkTyVarTy, applyTypeEnvToTy, 
+> import Type		( cloneTyVar, mkTyVarTy, applyTypeEnvToTy,
 > 			  extractTyVarsFromTy, TyVar, SigmaType(..)
 >			  IF_ATTACK_PRAGMAS(COMMA cmpTyVar)
 >			)
-> import BasicLit	( BasicLit )	-- for Eq BasicLit
+> import Literal	( Literal )	-- for Eq Literal
 > import CoreSyn
 > import Id		( mkIdWithNewUniq, mkSysLocal, applyTypeEnvToId,
-> 			  getIdInfo, toplevelishId, getIdUniType, Id )
-> import IdEnv
+> 			  getIdInfo, toplevelishId, idType, Id )
 > import IdInfo
 > import Outputable
 > import Pretty
-> import PrimOps	( PrimOp )	-- for Eq PrimOp
-> import SplitUniq
+> import PrimOp	( PrimOp )	-- for Eq PrimOp
+> import UniqSupply
 > import SrcLoc		( mkUnknownSrcLoc )
-> import TyVarEnv
 > import Util
 
 -----------------------------------------------------------------------------
@@ -48,41 +46,41 @@ its left hand side.  The result is a term with no labels.
 > strip :: DefExpr -> DefExpr
 
 > strip e' = case e' of
-> 	CoVar (DefArgExpr e) -> panic "DefUtils(strip): CoVar (DefExpr _)"
->	CoVar (Label l e)    -> l
->       CoVar (DefArgVar v)  -> e'
->       CoLit l              -> e'
->       CoCon c ts es        -> CoCon c ts (map stripAtom es)
->       CoPrim op ts es      -> CoPrim op ts (map stripAtom es)
->       CoLam vs e           -> CoLam vs (strip e)
+> 	Var (DefArgExpr e) -> panic "DefUtils(strip): Var (DefExpr _)"
+>	Var (Label l e)    -> l
+>       Var (DefArgVar v)  -> e'
+>       Lit l              -> e'
+>       Con c ts es        -> Con c ts (map stripAtom es)
+>       Prim op ts es      -> Prim op ts (map stripAtom es)
+>       Lam vs e           -> Lam vs (strip e)
 >       CoTyLam alpha e      -> CoTyLam alpha (strip e)
->       CoApp e v            -> CoApp (strip e) (stripAtom v)
+>       App e v            -> App (strip e) (stripAtom v)
 >       CoTyApp e t          -> CoTyApp (strip e) t
->       CoCase e ps          -> CoCase (strip e) (stripCaseAlts ps)
->       CoLet (CoNonRec v e) e' -> CoLet (CoNonRec v (strip e)) (strip e')
->       CoLet (CoRec bs) e   -> 
->		CoLet (CoRec [ (v, strip e) | (v,e) <- bs ]) (strip e)
->       CoSCC l e            -> CoSCC l (strip e)
+>       Case e ps          -> Case (strip e) (stripCaseAlts ps)
+>       Let (NonRec v e) e' -> Let (NonRec v (strip e)) (strip e')
+>       Let (Rec bs) e   ->
+>		Let (Rec [ (v, strip e) | (v,e) <- bs ]) (strip e)
+>       SCC l e            -> SCC l (strip e)
 
 > stripAtom :: DefAtom -> DefAtom
-> stripAtom (CoVarAtom v) = CoVarAtom (stripArg v)
-> stripAtom (CoLitAtom l) = CoLitAtom l	-- XXX
+> stripAtom (VarArg v) = VarArg (stripArg v)
+> stripAtom (LitArg l) = LitArg l	-- XXX
 
 > stripArg :: DefBindee -> DefBindee
 > stripArg (DefArgExpr e) = DefArgExpr (strip e)
 > stripArg (Label l e)   = panic "DefUtils(stripArg): Label _ _"
 > stripArg (DefArgVar v) = panic "DefUtils(stripArg): DefArgVar _ _"
 
-> stripCaseAlts (CoAlgAlts as def) 
-> 	= CoAlgAlts (map stripAlgAlt as) (stripDefault def)
-> stripCaseAlts (CoPrimAlts as def) 
-> 	= CoPrimAlts (map stripPrimAlt as) (stripDefault def)
+> stripCaseAlts (AlgAlts as def)
+> 	= AlgAlts (map stripAlgAlt as) (stripDefault def)
+> stripCaseAlts (PrimAlts as def)
+> 	= PrimAlts (map stripPrimAlt as) (stripDefault def)
 
 > stripAlgAlt  (c, vs, e) = (c, vs, strip e)
 > stripPrimAlt (l, e) = (l, strip e)
 
-> stripDefault CoNoDefault = CoNoDefault
-> stripDefault (CoBindDefault v e) = CoBindDefault v (strip e)
+> stripDefault NoDefault = NoDefault
+> stripDefault (BindDefault v e) = BindDefault v (strip e)
 
 -----------------------------------------------------------------------------
 \subsection{Free Variables}
@@ -94,48 +92,48 @@ but l is guranteed to be finite so we choose that one.
 
 > freeVars :: DefExpr -> [Id]
 > freeVars e = free e []
->   where 
+>   where
 >   	free e fvs = case e of
->		CoVar (DefArgExpr e) -> 
->			panic "DefUtils(free): CoVar (DefExpr _)"
->		CoVar (Label l e)    -> free l fvs
->       	CoVar (DefArgVar v)
+>		Var (DefArgExpr e) ->
+>			panic "DefUtils(free): Var (DefExpr _)"
+>		Var (Label l e)    -> free l fvs
+>       	Var (DefArgVar v)
 >			| v `is_elem` fvs	-> fvs
 >			| otherwise	-> v : fvs
 >		  where { is_elem = isIn "freeVars(deforest)" }
->       	CoLit l              -> fvs
->       	CoCon c ts es        -> foldr freeAtom fvs es
->       	CoPrim op ts es      -> foldr freeAtom fvs es
->       	CoLam vs e           -> free' vs (free e fvs)
+>       	Lit l              -> fvs
+>       	Con c ts es        -> foldr freeAtom fvs es
+>       	Prim op ts es      -> foldr freeAtom fvs es
+>       	Lam vs e           -> free' vs (free e fvs)
 >       	CoTyLam alpha e      -> free e fvs
->       	CoApp 	e v          -> free e (freeAtom v fvs)
+>       	App 	e v          -> free e (freeAtom v fvs)
 >       	CoTyApp e t          -> free e fvs
->       	CoCase e ps          -> free e (freeCaseAlts ps fvs)
->       	CoLet (CoNonRec v e) e' -> free e (free' [v] (free e' fvs))
->       	CoLet (CoRec bs) e   -> free' vs (foldr free (free e fvs) es)
+>       	Case e ps          -> free e (freeCaseAlts ps fvs)
+>       	Let (NonRec v e) e' -> free e (free' [v] (free e' fvs))
+>       	Let (Rec bs) e   -> free' vs (foldr free (free e fvs) es)
 >			where (vs,es) = unzip bs
->       	CoSCC l e            -> free e fvs
+>       	SCC l e            -> free e fvs
 
 >	free' :: [Id] -> [Id] -> [Id]
 > 	free' vs fvs = filter (\x -> notElem x vs) fvs
 
-> 	freeAtom (CoVarAtom (DefArgExpr e)) fvs = free e fvs
-> 	freeAtom (CoVarAtom (Label l e)) fvs 
-> 		= panic "DefUtils(free): CoVarAtom (Label _ _)"
-> 	freeAtom (CoVarAtom (DefArgVar v)) fvs
-> 		= panic "DefUtils(free): CoVarAtom (DefArgVar _ _)"
-> 	freeAtom (CoLitAtom l) fvs = fvs
+> 	freeAtom (VarArg (DefArgExpr e)) fvs = free e fvs
+> 	freeAtom (VarArg (Label l e)) fvs
+> 		= panic "DefUtils(free): VarArg (Label _ _)"
+> 	freeAtom (VarArg (DefArgVar v)) fvs
+> 		= panic "DefUtils(free): VarArg (DefArgVar _ _)"
+> 	freeAtom (LitArg l) fvs = fvs
 
-> 	freeCaseAlts (CoAlgAlts as def) fvs
+> 	freeCaseAlts (AlgAlts as def) fvs
 > 		= foldr freeAlgAlt  (freeDefault def fvs) as
-> 	freeCaseAlts (CoPrimAlts as def) fvs
+> 	freeCaseAlts (PrimAlts as def) fvs
 > 		= foldr freePrimAlt (freeDefault def fvs) as
->		
+>
 > 	freeAlgAlt  (c, vs, e) fvs = free' vs (free e fvs)
 > 	freePrimAlt (l, e) fvs = free e fvs
 
-> 	freeDefault CoNoDefault fvs = fvs
-> 	freeDefault (CoBindDefault v e) fvs = free' [v] (free e fvs)
+> 	freeDefault NoDefault fvs = fvs
+> 	freeDefault (BindDefault v e) fvs = free' [v] (free e fvs)
 
 -----------------------------------------------------------------------------
 \subsection{Free Type Variables}
@@ -144,43 +142,43 @@ but l is guranteed to be finite so we choose that one.
 > freeTyVars e = free e []
 >   where
 >   	free e tvs = case e of
->		CoVar (DefArgExpr e)    ->
->			panic "DefUtils(freeVars): CoVar (DefExpr _)"
->		CoVar (Label l e)       -> free l tvs
->       	CoVar (DefArgVar id)    -> freeId id tvs
->       	CoLit l                 -> tvs
->       	CoCon c ts es           -> foldr freeTy (foldr freeAtom tvs es) ts
->       	CoPrim op ts es         -> foldr freeTy (foldr freeAtom tvs es) ts
->       	CoLam vs e              -> foldr freeId (free e tvs) vs
+>		Var (DefArgExpr e)    ->
+>			panic "DefUtils(freeVars): Var (DefExpr _)"
+>		Var (Label l e)       -> free l tvs
+>       	Var (DefArgVar id)    -> freeId id tvs
+>       	Lit l                 -> tvs
+>       	Con c ts es           -> foldr freeTy (foldr freeAtom tvs es) ts
+>       	Prim op ts es         -> foldr freeTy (foldr freeAtom tvs es) ts
+>       	Lam vs e              -> foldr freeId (free e tvs) vs
 >       	CoTyLam alpha e         -> filter (/= alpha) (free e tvs)
->       	CoApp e v               -> free e (freeAtom v tvs)
+>       	App e v               -> free e (freeAtom v tvs)
 >       	CoTyApp e t             -> free e (freeTy t tvs)
->       	CoCase e ps             -> free e (freeCaseAlts ps tvs)
->       	CoLet (CoNonRec v e) e' -> free e (freeId v (free e' tvs))
->       	CoLet (CoRec bs) e      -> foldr freeBind (free e tvs) bs
->       	CoSCC l e               -> free e tvs
->		
->	freeId id tvs = extractTyVarsFromTy (getIdUniType id) `union` tvs
+>       	Case e ps             -> free e (freeCaseAlts ps tvs)
+>       	Let (NonRec v e) e' -> free e (freeId v (free e' tvs))
+>       	Let (Rec bs) e      -> foldr freeBind (free e tvs) bs
+>       	SCC l e               -> free e tvs
+>
+>	freeId id tvs = extractTyVarsFromTy (idType id) `union` tvs
 >	freeTy t  tvs = extractTyVarsFromTy t `union` tvs
 >	freeBind (v,e) tvs = freeId v (free e tvs)
-  
-> 	freeAtom (CoVarAtom (DefArgExpr e)) tvs = free e tvs
-> 	freeAtom (CoVarAtom (Label l e)) tvs
-> 		= panic "DefUtils(freeVars): CoVarAtom (Label _ _)"
-> 	freeAtom (CoVarAtom (DefArgVar v)) tvs
-> 		= panic "DefUtils(freeVars): CoVarAtom (DefArgVar _ _)"
-> 	freeAtom (CoLitAtom l) tvs = tvs	-- XXX
-
-> 	freeCaseAlts (CoAlgAlts as def) tvs
+
+> 	freeAtom (VarArg (DefArgExpr e)) tvs = free e tvs
+> 	freeAtom (VarArg (Label l e)) tvs
+> 		= panic "DefUtils(freeVars): VarArg (Label _ _)"
+> 	freeAtom (VarArg (DefArgVar v)) tvs
+> 		= panic "DefUtils(freeVars): VarArg (DefArgVar _ _)"
+> 	freeAtom (LitArg l) tvs = tvs	-- XXX
+
+> 	freeCaseAlts (AlgAlts as def) tvs
 > 		= foldr freeAlgAlt  (freeDefault def tvs) as
-> 	freeCaseAlts (CoPrimAlts as def) tvs
+> 	freeCaseAlts (PrimAlts as def) tvs
 > 		= foldr freePrimAlt (freeDefault def tvs) as
 
 > 	freeAlgAlt  (c, vs, e) tvs = foldr freeId (free e tvs) vs
 > 	freePrimAlt (l, e) tvs = free e tvs
 
-> 	freeDefault CoNoDefault tvs = tvs
-> 	freeDefault (CoBindDefault v e) tvs = freeId v (free e tvs)
+> 	freeDefault NoDefault tvs = tvs
+> 	freeDefault (BindDefault v e) tvs = freeId v (free e tvs)
 
 -----------------------------------------------------------------------------
 \subsection{Rebinding variables in an expression}
@@ -188,114 +186,114 @@ but l is guranteed to be finite so we choose that one.
 Here is the code that renames all the bound variables in an expression
 with new uniques.  Free variables are left unchanged.
 
-> rebindExpr :: DefExpr -> SUniqSM DefExpr
+> rebindExpr :: DefExpr -> UniqSM DefExpr
 > rebindExpr e = uniqueExpr nullIdEnv nullTyVarEnv e
 
-> uniqueExpr :: IdEnv Id -> TypeEnv -> DefExpr -> SUniqSM DefExpr
+> uniqueExpr :: IdEnv Id -> TypeEnv -> DefExpr -> UniqSM DefExpr
 > uniqueExpr p t e =
 >   case e of
-> 	CoVar (DefArgVar v) -> 
-> 		returnSUs (CoVar (DefArgVar (lookup v p)))
-> 	
-> 	CoVar (Label l e) -> 
-> 		uniqueExpr p t l		`thenSUs` \l ->
-> 		uniqueExpr p t e		`thenSUs` \e ->
-> 		returnSUs (mkLabel l e)
-> 		
-> 	CoVar (DefArgExpr _) ->
-> 		panic "DefUtils(uniqueExpr): CoVar(DefArgExpr _)"
-> 		
-> 	CoLit l ->
-> 		returnSUs e
-> 		
-> 	CoCon c ts es ->
-> 		mapSUs (uniqueAtom p t) es 	`thenSUs` \es ->
-> 		returnSUs (CoCon c (map (applyTypeEnvToTy t) ts) es)
-> 		
-> 	CoPrim op ts es ->
-> 		mapSUs (uniqueAtom p t) es	 `thenSUs` \es ->
-> 		returnSUs (CoPrim op (map (applyTypeEnvToTy t) ts) es)
-> 		
-> 	CoLam vs e ->
-> 		mapSUs (newVar t) vs		`thenSUs` \vs' ->
-> 		uniqueExpr (growIdEnvList p (zip vs vs')) t e `thenSUs` \e ->
-> 		returnSUs (CoLam vs' e)
-> 		
+> 	Var (DefArgVar v) ->
+> 		returnUs (Var (DefArgVar (lookup v p)))
+>
+> 	Var (Label l e) ->
+> 		uniqueExpr p t l		`thenUs` \l ->
+> 		uniqueExpr p t e		`thenUs` \e ->
+> 		returnUs (mkLabel l e)
+>
+> 	Var (DefArgExpr _) ->
+> 		panic "DefUtils(uniqueExpr): Var(DefArgExpr _)"
+>
+> 	Lit l ->
+> 		returnUs e
+>
+> 	Con c ts es ->
+> 		mapUs (uniqueAtom p t) es 	`thenUs` \es ->
+> 		returnUs (Con c (map (applyTypeEnvToTy t) ts) es)
+>
+> 	Prim op ts es ->
+> 		mapUs (uniqueAtom p t) es	 `thenUs` \es ->
+> 		returnUs (Prim op (map (applyTypeEnvToTy t) ts) es)
+>
+> 	Lam vs e ->
+> 		mapUs (newVar t) vs		`thenUs` \vs' ->
+> 		uniqueExpr (growIdEnvList p (zip vs vs')) t e `thenUs` \e ->
+> 		returnUs (Lam vs' e)
+>
 > 	CoTyLam v e ->
->		getSUnique			`thenSUs` \u ->
+>		getUnique			`thenUs` \u ->
 >		let v' = cloneTyVar v u
 >		    t' = addOneToTyVarEnv t v (mkTyVarTy v') in
-> 		uniqueExpr p t' e 		`thenSUs` \e ->
-> 		returnSUs (CoTyLam v' e)
-> 	
-> 	CoApp e v ->
-> 		uniqueExpr p t e		`thenSUs` \e ->
-> 		uniqueAtom p t v		`thenSUs` \v ->
-> 		returnSUs (CoApp e v)
-> 		
+> 		uniqueExpr p t' e 		`thenUs` \e ->
+> 		returnUs (CoTyLam v' e)
+>
+> 	App e v ->
+> 		uniqueExpr p t e		`thenUs` \e ->
+> 		uniqueAtom p t v		`thenUs` \v ->
+> 		returnUs (App e v)
+>
 > 	CoTyApp e ty ->
-> 		uniqueExpr p t e		`thenSUs` \e ->
-> 		returnSUs (mkCoTyApp e (applyTypeEnvToTy t ty))
-> 	
-> 	CoCase e alts ->
-> 		uniqueExpr p t e		`thenSUs` \e ->
-> 		uniqueAlts alts			`thenSUs` \alts ->
-> 		returnSUs (CoCase e alts)
+> 		uniqueExpr p t e		`thenUs` \e ->
+> 		returnUs (CoTyApp e (applyTypeEnvToTy t ty))
+>
+> 	Case e alts ->
+> 		uniqueExpr p t e		`thenUs` \e ->
+> 		uniqueAlts alts			`thenUs` \alts ->
+> 		returnUs (Case e alts)
 > 	     where
-> 	     	uniqueAlts (CoAlgAlts  as d) = 
-> 			mapSUs uniqueAlgAlt  as	`thenSUs` \as ->
-> 			uniqueDefault d		`thenSUs` \d ->
-> 			returnSUs (CoAlgAlts as d)
-> 		uniqueAlts (CoPrimAlts as d) =
-> 			mapSUs uniquePrimAlt as `thenSUs` \as ->
-> 			uniqueDefault d		`thenSUs` \d ->
-> 			returnSUs (CoPrimAlts as d)
-> 			
-> 		uniqueAlgAlt (c, vs, e) = 
-> 			mapSUs (newVar t) vs	`thenSUs` \vs' ->
-> 			uniqueExpr (growIdEnvList p (zip vs vs')) t e 
->						`thenSUs` \e ->
-> 			returnSUs (c, vs', e)
+> 	     	uniqueAlts (AlgAlts  as d) =
+> 			mapUs uniqueAlgAlt  as	`thenUs` \as ->
+> 			uniqueDefault d		`thenUs` \d ->
+> 			returnUs (AlgAlts as d)
+> 		uniqueAlts (PrimAlts as d) =
+> 			mapUs uniquePrimAlt as `thenUs` \as ->
+> 			uniqueDefault d		`thenUs` \d ->
+> 			returnUs (PrimAlts as d)
+>
+> 		uniqueAlgAlt (c, vs, e) =
+> 			mapUs (newVar t) vs	`thenUs` \vs' ->
+> 			uniqueExpr (growIdEnvList p (zip vs vs')) t e
+>						`thenUs` \e ->
+> 			returnUs (c, vs', e)
 > 		uniquePrimAlt (l, e) =
-> 			uniqueExpr p t e	`thenSUs` \e ->
-> 			returnSUs (l, e)
-> 			
-> 		uniqueDefault CoNoDefault = returnSUs CoNoDefault
-> 		uniqueDefault (CoBindDefault v e) = 
->			newVar t v	`thenSUs` \v' ->
-> 			uniqueExpr (addOneToIdEnv p v v') t e `thenSUs` \e ->
-> 			returnSUs (CoBindDefault v' e)
-> 
-> 	CoLet (CoNonRec v e) e' ->
-> 		uniqueExpr p t e		`thenSUs` \e ->
-> 		newVar t v			`thenSUs` \v' ->
-> 		uniqueExpr (addOneToIdEnv p v v') t e'  `thenSUs` \e' ->
-> 		returnSUs (CoLet (CoNonRec v' e) e')
-> 		
-> 	CoLet (CoRec ds) e ->
+> 			uniqueExpr p t e	`thenUs` \e ->
+> 			returnUs (l, e)
+>
+> 		uniqueDefault NoDefault = returnUs NoDefault
+> 		uniqueDefault (BindDefault v e) =
+>			newVar t v	`thenUs` \v' ->
+> 			uniqueExpr (addOneToIdEnv p v v') t e `thenUs` \e ->
+> 			returnUs (BindDefault v' e)
+>
+> 	Let (NonRec v e) e' ->
+> 		uniqueExpr p t e		`thenUs` \e ->
+> 		newVar t v			`thenUs` \v' ->
+> 		uniqueExpr (addOneToIdEnv p v v') t e'  `thenUs` \e' ->
+> 		returnUs (Let (NonRec v' e) e')
+>
+> 	Let (Rec ds) e ->
 > 		let (vs,es) = unzip ds in
-> 		mapSUs (newVar t) vs		`thenSUs` \vs' ->
+> 		mapUs (newVar t) vs		`thenUs` \vs' ->
 > 		let p' = growIdEnvList p (zip vs vs') in
-> 		mapSUs (uniqueExpr p' t) es  	`thenSUs` \es ->
-> 		uniqueExpr p' t e		`thenSUs` \e ->
-> 		returnSUs (CoLet (CoRec (zip vs' es)) e)
-> 
-> 	CoSCC l e ->
-> 		uniqueExpr p t e		`thenSUs` \e ->
-> 		returnSUs (CoSCC l e)
-> 		
-> 
-> uniqueAtom :: IdEnv Id -> TypeEnv -> DefAtom -> SUniqSM DefAtom
-> uniqueAtom p t (CoLitAtom l) = returnSUs (CoLitAtom l) -- XXX
-> uniqueAtom p t (CoVarAtom v) = 
-> 	uniqueArg p t v	`thenSUs` \v ->
->	returnSUs (CoVarAtom v)
-> 
+> 		mapUs (uniqueExpr p' t) es  	`thenUs` \es ->
+> 		uniqueExpr p' t e		`thenUs` \e ->
+> 		returnUs (Let (Rec (zip vs' es)) e)
+>
+> 	SCC l e ->
+> 		uniqueExpr p t e		`thenUs` \e ->
+> 		returnUs (SCC l e)
+>
+>
+> uniqueAtom :: IdEnv Id -> TypeEnv -> DefAtom -> UniqSM DefAtom
+> uniqueAtom p t (LitArg l) = returnUs (LitArg l) -- XXX
+> uniqueAtom p t (VarArg v) =
+> 	uniqueArg p t v	`thenUs` \v ->
+>	returnUs (VarArg v)
+>
 > uniqueArg p t (DefArgVar v) =
 > 	panic "DefUtils(uniqueArg): DefArgVar _ _"
 > uniqueArg p t (DefArgExpr e) =
-> 	uniqueExpr p t e	`thenSUs` \e ->
-> 	returnSUs (DefArgExpr e)
+> 	uniqueExpr p t e	`thenUs` \e ->
+> 	returnUs (DefArgExpr e)
 > uniqueArg p t (Label l e) =
 > 	panic "DefUtils(uniqueArg): Label _ _"
 
@@ -309,10 +307,10 @@ expression as a whole (?)
 >		Nothing -> id
 >		Just new_id -> new_id
 
-> newVar :: TypeEnv -> Id -> SUniqSM Id
-> newVar t id = 
-> 	getSUnique		`thenSUs` \u ->
-> 	returnSUs (mkIdWithNewUniq (applyTypeEnvToId t id) u)
+> newVar :: TypeEnv -> Id -> UniqSM Id
+> newVar t id =
+> 	getUnique		`thenUs` \u ->
+> 	returnUs (mkIdWithNewUniq (applyTypeEnvToId t id) u)
 
 -----------------------------------------------------------------------------
 \subsection{Detecting Renamings}
@@ -326,24 +324,24 @@ expression).
 We only allow renaming of sysLocal ids - ie. not top-level, imported
 or otherwise global ids.
 
-> data RenameResult 
+> data RenameResult
 > 	= NotRenaming
 >	| IsRenaming [(Id,Id)]
 >	| InconsistentRenaming [(Id,Id)]
 
-> renameExprs :: DefExpr -> DefExpr -> SUniqSM RenameResult
-> renameExprs u u' = 
+> renameExprs :: DefExpr -> DefExpr -> UniqSM RenameResult
+> renameExprs u u' =
 >	case ren u u' of
->		[]   -> returnSUs NotRenaming
->		[r] -> if not (consistent r) then 
->				d2c (strip u)	`thenSUs` \u ->
->				d2c (strip u')  `thenSUs` \u' ->
+>		[]   -> returnUs NotRenaming
+>		[r] -> if not (consistent r) then
+>				d2c (strip u)	`thenUs` \u ->
+>				d2c (strip u')  `thenUs` \u' ->
 >				trace ("failed consistency check:\n" ++
 >				       ppShow 80 (ppr PprDebug u) ++ "\n" ++
 >				       ppShow 80 (ppr PprDebug u'))
->				(returnSUs (InconsistentRenaming r))
->			else 
->				trace "Renaming!" (returnSUs (IsRenaming r))
+>				(returnUs (InconsistentRenaming r))
+>			else
+>				trace "Renaming!" (returnUs (IsRenaming r))
 >		_ -> panic "DefUtils(renameExprs)"
 
 Check that we have a consistent renaming.  A renaming is consistent if
@@ -355,10 +353,10 @@ same variable.
 
 > checkConsistency :: [(Id,Id)] -> [[(Id,Id)]] -> [[(Id,Id)]]
 > checkConsistency bound free = [ r' | r <- free, r' <- check r ]
-> 	where 
+> 	where
 >	   check r | they're_consistent = [frees]
 >		   | otherwise          = []
-> 	   	where  
+> 	   	where
 >		   (bounds,frees) = partition (\(a,b) -> a `elem` lbound) r
 >	           (lbound,rbound) = unzip bound
 >	           they're_consistent = consistent (bound ++ bounds)
@@ -379,124 +377,124 @@ Main renaming function.  Returns a list of renamings made while
 comparing the expressions.
 
 > ren :: DefExpr -> DefExpr -> [[(Id,Id)]]
-> 
+>
 >	-- renaming or identical cases --
->	
+>
 >
 > 	-- same variable, no renaming
-> ren (CoVar (DefArgVar x)) t@(CoVar (DefArgVar y)) 
+> ren (Var (DefArgVar x)) t@(Var (DefArgVar y))
 > 	| x == y = [[(x,y)]]
 >	| isArgId x && isArgId y = [[(x,y)]]
 >
 >	-- if we're doing matching, use the next rule,
 >	-- and delete the second clause in the above rule.
 > {-
-> ren (CoVar (DefArgVar x)) t 
+> ren (Var (DefArgVar x)) t
 > 	| okToRename x && all (not. deforestable) (freeVars t)
 >	= [[(x,t)]]
 > -}
 
-> ren (CoLit l) (CoLit l') | l == l'
+> ren (Lit l) (Lit l') | l == l'
 > 	= [[]]
-> ren (CoCon c ts es) (CoCon c' ts' es') | c == c'
+> ren (Con c ts es) (Con c' ts' es') | c == c'
 > 	= foldr (....) [[]] (zipWith renAtom es es')
-> ren (CoPrim op ts es) (CoPrim op' ts' es') | op == op'
+> ren (Prim op ts es) (Prim op' ts' es') | op == op'
 > 	= foldr (....) [[]] (zipWith renAtom es es')
-> ren (CoLam vs e) (CoLam vs' e')
+> ren (Lam vs e) (Lam vs' e')
 > 	= checkConsistency (zip vs vs') (ren e e')
 > ren (CoTyLam vs e) (CoTyLam vs' e')
 > 	= ren e e'			-- XXX!
-> ren (CoApp e v) (CoApp e' v')
+> ren (App e v) (App e' v')
 > 	= ren e e' .... renAtom v v'
 > ren (CoTyApp e t) (CoTyApp e' t')
 > 	= ren e e'			-- XXX!
-> ren (CoCase e alts) (CoCase e' alts')
+> ren (Case e alts) (Case e' alts')
 > 	= ren e e' .... renAlts alts alts'
-> ren (CoLet (CoNonRec v a) b) (CoLet (CoNonRec v' a') b')
+> ren (Let (NonRec v a) b) (Let (NonRec v' a') b')
 > 	= ren a a' .... (checkConsistency [(v,v')] (ren b b'))
-> ren (CoLet (CoRec ds) e) (CoLet (CoRec ds') e')
-> 	= checkConsistency (zip vs vs') 
+> ren (Let (Rec ds) e) (Let (Rec ds') e')
+> 	= checkConsistency (zip vs vs')
 >		(ren e e' .... (foldr (....) [[]] (zipWith ren es es')))
 >	where (vs ,es ) = unzip ds
 >	      (vs',es') = unzip ds'
->	   
+>
 > 	-- label cases --
->	
-> ren (CoVar (Label l e)) e' 	= ren l e'
-> ren e (CoVar (Label l e'))	= ren e l
+>
+> ren (Var (Label l e)) e' 	= ren l e'
+> ren e (Var (Label l e'))	= ren e l
 >
 >	-- error cases --
->	
-> ren (CoVar (DefArgExpr _)) _
-> 	= panic "DefUtils(ren): CoVar (DefArgExpr _)"
-> ren _ (CoVar (DefArgExpr _))
-> 	= panic "DefUtils(ren): CoVar (DefArgExpr _)"
->	
+>
+> ren (Var (DefArgExpr _)) _
+> 	= panic "DefUtils(ren): Var (DefArgExpr _)"
+> ren _ (Var (DefArgExpr _))
+> 	= panic "DefUtils(ren): Var (DefArgExpr _)"
+>
 >	-- default case --
->	
-> ren _ _ = [] 
+>
+> ren _ _ = []
 
 Rename atoms.
 
-> renAtom (CoVarAtom (DefArgExpr e)) (CoVarAtom (DefArgExpr e'))
+> renAtom (VarArg (DefArgExpr e)) (VarArg (DefArgExpr e'))
 > 	= ren e e'
 >  -- XXX shouldn't need the next two
-> renAtom (CoLitAtom l) (CoLitAtom l') | l == l' = [[]]				
-> renAtom (CoVarAtom (DefArgVar v)) _ =
-> 	panic "DefUtils(renAtom): CoVarAtom (DefArgVar _ _)"
-> renAtom _ (CoVarAtom (DefArgVar v)) =
-> 	panic "DefUtils(renAtom): CoVarAtom (DefArgVar _ _)"
-> renAtom (CoVarAtom (Label _ _)) _ = 
-> 	panic "DefUtils(renAtom): CoVarAtom (Label _ _)"
-> renAtom e (CoVarAtom (Label l e')) =
-> 	panic "DefUtils(renAtom): CoVarAtom (Label _ _)"
->	
+> renAtom (LitArg l) (LitArg l') | l == l' = [[]]
+> renAtom (VarArg (DefArgVar v)) _ =
+> 	panic "DefUtils(renAtom): VarArg (DefArgVar _ _)"
+> renAtom _ (VarArg (DefArgVar v)) =
+> 	panic "DefUtils(renAtom): VarArg (DefArgVar _ _)"
+> renAtom (VarArg (Label _ _)) _ =
+> 	panic "DefUtils(renAtom): VarArg (Label _ _)"
+> renAtom e (VarArg (Label l e')) =
+> 	panic "DefUtils(renAtom): VarArg (Label _ _)"
+>
 > renAtom _ _ = []
 
 Renamings of case alternatives doesn't allow reordering, but that
 should be Ok (we don't ever change the ordering anyway).
 
-> renAlts (CoAlgAlts as dflt) (CoAlgAlts as' dflt')
+> renAlts (AlgAlts as dflt) (AlgAlts as' dflt')
 > 	= foldr (....) [[]] (zipWith renAlgAlt as as') .... renDefault dflt dflt'
-> renAlts (CoPrimAlts as dflt) (CoPrimAlts as' dflt')
+> renAlts (PrimAlts as dflt) (PrimAlts as' dflt')
 > 	= foldr (....) [[]] (zipWith renPrimAlt as as') .... renDefault dflt dflt'
 > renAlts _ _ = []
->	
-> renAlgAlt (c,vs,e) (c',vs',e') | c == c' 
+>
+> renAlgAlt (c,vs,e) (c',vs',e') | c == c'
 > 	= checkConsistency (zip vs vs') (ren e e')
 > renAlgAlt _ _ = []
-> 
+>
 > renPrimAlt (l,e) (l',e') | l == l' = ren e e'
 > renPrimAlt _ _ = []
 >
-> renDefault CoNoDefault CoNoDefault = [[]]
-> renDefault (CoBindDefault v e) (CoBindDefault v' e')
+> renDefault NoDefault NoDefault = [[]]
+> renDefault (BindDefault v e) (BindDefault v' e')
 > 	= checkConsistency [(v,v')] (ren e e')
 
 -----------------------------------------------------------------------------
 
 > atom2expr :: DefAtom -> DefExpr
-> atom2expr (CoVarAtom (DefArgExpr e)) = e
-> atom2expr (CoVarAtom (Label l e)) = mkLabel l e
+> atom2expr (VarArg (DefArgExpr e)) = e
+> atom2expr (VarArg (Label l e)) = mkLabel l e
 > -- XXX next two should be illegal
-> atom2expr (CoLitAtom l) = CoLit l
-> atom2expr (CoVarAtom (DefArgVar v)) = 
-> 	panic "DefUtils(atom2expr): CoVarAtom (DefArgVar _)"
+> atom2expr (LitArg l) = Lit l
+> atom2expr (VarArg (DefArgVar v)) =
+> 	panic "DefUtils(atom2expr): VarArg (DefArgVar _)"
 
-> expr2atom = CoVarAtom . DefArgExpr
+> expr2atom = VarArg . DefArgExpr
 
 -----------------------------------------------------------------------------
 Grab a new Id and tag it as coming from the Deforester.
 
-> newDefId :: UniType -> SUniqSM Id
-> newDefId t = 
-> 	getSUnique	`thenSUs` \u ->
->	returnSUs (mkSysLocal SLIT("def") u t mkUnknownSrcLoc)
+> newDefId :: Type -> UniqSM Id
+> newDefId t =
+> 	getUnique	`thenUs` \u ->
+>	returnUs (mkSysLocal SLIT("def") u t mkUnknownSrcLoc)
 
-> newTmpId :: UniType -> SUniqSM Id
+> newTmpId :: Type -> UniqSM Id
 > newTmpId t =
-> 	getSUnique	`thenSUs` \u ->
->	returnSUs (mkSysLocal SLIT("tmp") u t mkUnknownSrcLoc)
+> 	getUnique	`thenUs` \u ->
+>	returnUs (mkSysLocal SLIT("tmp") u t mkUnknownSrcLoc)
 
 -----------------------------------------------------------------------------
 Check whether an Id was given a `DEFOREST' annotation by the programmer.
@@ -510,113 +508,113 @@ Check whether an Id was given a `DEFOREST' annotation by the programmer.
 -----------------------------------------------------------------------------
 Filter for free variables to abstract from new functions.
 
-> isArgId id 
-> 	=    (not . deforestable)  id  
->         && (not . toplevelishId) id 
+> isArgId id
+> 	=    (not . deforestable)  id
+>         && (not . toplevelishId) id
 
 -----------------------------------------------------------------------------
 
-> foldrSUs f c [] = returnSUs c
+> foldrSUs f c [] = returnUs c
 > foldrSUs f c (x:xs)
-> 	= foldrSUs f c xs	`thenSUs` \xs' ->
+> 	= foldrSUs f c xs	`thenUs` \xs' ->
 >	  f x xs'
 
 -----------------------------------------------------------------------------
 
 > mkDefLetrec [] e = e
-> mkDefLetrec bs e = CoLet (CoRec bs) e
+> mkDefLetrec bs e = Let (Rec bs) e
 
 -----------------------------------------------------------------------------
 Substitutions.
 
 > subst :: [(Id,DefExpr)]
 > 	-> DefExpr
->	-> SUniqSM DefExpr
+>	-> UniqSM DefExpr
 
 > subst p e' = sub e'
 >  where
 >     p' = mkIdEnv p
 >     sub e' = case e' of
-> 	CoVar (DefArgExpr e) -> panic "DefExpr(sub): CoVar (DefArgExpr _)"
->	CoVar (Label l e)    -> panic "DefExpr(sub): CoVar (Label _ _)"
->       CoVar (DefArgVar v) ->
+> 	Var (DefArgExpr e) -> panic "DefExpr(sub): Var (DefArgExpr _)"
+>	Var (Label l e)    -> panic "DefExpr(sub): Var (Label _ _)"
+>       Var (DefArgVar v) ->
 >		case lookupIdEnv p' v of
->			Just e  -> rebindExpr e	`thenSUs` \e -> returnSUs e
->			Nothing -> returnSUs e'
->       CoLit l              -> returnSUs e'
->       CoCon c ts es        -> mapSUs substAtom es	`thenSUs` \es ->
->				returnSUs (CoCon c ts es)
->       CoPrim op ts es      -> mapSUs substAtom es	`thenSUs` \es ->
->				returnSUs (CoPrim op ts es)
->       CoLam vs e           -> sub e			`thenSUs` \e ->
->				returnSUs (CoLam vs e)
->       CoTyLam alpha e      -> sub e			`thenSUs` \e ->
->				returnSUs (CoTyLam alpha e)
->       CoApp e v            -> sub e			`thenSUs` \e ->
->				substAtom v		`thenSUs` \v ->
->				returnSUs (CoApp e v)
->       CoTyApp e t          -> sub e			`thenSUs` \e ->
->				returnSUs (CoTyApp e t)
->       CoCase e ps          -> sub e			`thenSUs` \e ->
->				substCaseAlts ps	`thenSUs` \ps ->
->				returnSUs (CoCase e ps)
->       CoLet (CoNonRec v e) e' 
->			     -> sub e			`thenSUs` \e ->
->			        sub e'			`thenSUs` \e' ->
->				returnSUs (CoLet (CoNonRec v e) e')
->       CoLet (CoRec bs) e   -> sub e			`thenSUs` \e ->
->				mapSUs substBind bs	`thenSUs` \bs ->
->				returnSUs (CoLet (CoRec bs) e)
+>			Just e  -> rebindExpr e	`thenUs` \e -> returnUs e
+>			Nothing -> returnUs e'
+>       Lit l              -> returnUs e'
+>       Con c ts es        -> mapUs substAtom es	`thenUs` \es ->
+>				returnUs (Con c ts es)
+>       Prim op ts es      -> mapUs substAtom es	`thenUs` \es ->
+>				returnUs (Prim op ts es)
+>       Lam vs e           -> sub e			`thenUs` \e ->
+>				returnUs (Lam vs e)
+>       CoTyLam alpha e      -> sub e			`thenUs` \e ->
+>				returnUs (CoTyLam alpha e)
+>       App e v            -> sub e			`thenUs` \e ->
+>				substAtom v		`thenUs` \v ->
+>				returnUs (App e v)
+>       CoTyApp e t          -> sub e			`thenUs` \e ->
+>				returnUs (CoTyApp e t)
+>       Case e ps          -> sub e			`thenUs` \e ->
+>				substCaseAlts ps	`thenUs` \ps ->
+>				returnUs (Case e ps)
+>       Let (NonRec v e) e'
+>			     -> sub e			`thenUs` \e ->
+>			        sub e'			`thenUs` \e' ->
+>				returnUs (Let (NonRec v e) e')
+>       Let (Rec bs) e   -> sub e			`thenUs` \e ->
+>				mapUs substBind bs	`thenUs` \bs ->
+>				returnUs (Let (Rec bs) e)
 >			where
->				substBind (v,e) = 
->					sub e 		`thenSUs` \e ->
->					returnSUs (v,e)
->       CoSCC l e            -> sub e			`thenSUs` \e ->
->				returnSUs (CoSCC l e)
-
->     substAtom (CoVarAtom v) = 
->     		substArg v `thenSUs` \v ->
->		returnSUs (CoVarAtom v)
->     substAtom (CoLitAtom l) = 
->     		returnSUs (CoLitAtom l)	-- XXX
-
->     substArg (DefArgExpr e) = 
->     		sub e		`thenSUs` \e ->
->		returnSUs (DefArgExpr e)
->     substArg e@(Label _ _)  = 
+>				substBind (v,e) =
+>					sub e 		`thenUs` \e ->
+>					returnUs (v,e)
+>       SCC l e            -> sub e			`thenUs` \e ->
+>				returnUs (SCC l e)
+
+>     substAtom (VarArg v) =
+>     		substArg v `thenUs` \v ->
+>		returnUs (VarArg v)
+>     substAtom (LitArg l) =
+>     		returnUs (LitArg l)	-- XXX
+
+>     substArg (DefArgExpr e) =
+>     		sub e		`thenUs` \e ->
+>		returnUs (DefArgExpr e)
+>     substArg e@(Label _ _)  =
 >     		panic "DefExpr(substArg): Label _ _"
 >     substArg e@(DefArgVar v)  =	-- XXX
 >     		case lookupIdEnv p' v of
->			Just e -> rebindExpr e	`thenSUs` \e ->
->				  returnSUs (DefArgExpr e)
->			Nothing -> returnSUs e
-
->     substCaseAlts (CoAlgAlts as def) = 
->     		mapSUs substAlgAlt as		`thenSUs` \as ->
->		substDefault def		`thenSUs` \def ->
->		returnSUs (CoAlgAlts as def)
->     substCaseAlts (CoPrimAlts as def) =
->     		mapSUs substPrimAlt as		`thenSUs` \as ->
->		substDefault def		`thenSUs` \def ->
->		returnSUs (CoPrimAlts as def)
-
->     substAlgAlt  (c, vs, e) = 
->     		sub e				`thenSUs` \e ->
->		returnSUs (c, vs, e)
->     substPrimAlt (l, e) = 
->     		sub e				`thenSUs` \e ->
->		returnSUs (l, e)
-
->     substDefault CoNoDefault = 
->     		returnSUs CoNoDefault
->     substDefault (CoBindDefault v e) = 
->     		sub e				`thenSUs` \e ->
->		returnSUs (CoBindDefault v e)
+>			Just e -> rebindExpr e	`thenUs` \e ->
+>				  returnUs (DefArgExpr e)
+>			Nothing -> returnUs e
+
+>     substCaseAlts (AlgAlts as def) =
+>     		mapUs substAlgAlt as		`thenUs` \as ->
+>		substDefault def		`thenUs` \def ->
+>		returnUs (AlgAlts as def)
+>     substCaseAlts (PrimAlts as def) =
+>     		mapUs substPrimAlt as		`thenUs` \as ->
+>		substDefault def		`thenUs` \def ->
+>		returnUs (PrimAlts as def)
+
+>     substAlgAlt  (c, vs, e) =
+>     		sub e				`thenUs` \e ->
+>		returnUs (c, vs, e)
+>     substPrimAlt (l, e) =
+>     		sub e				`thenUs` \e ->
+>		returnUs (l, e)
+
+>     substDefault NoDefault =
+>     		returnUs NoDefault
+>     substDefault (BindDefault v e) =
+>     		sub e				`thenUs` \e ->
+>		returnUs (BindDefault v e)
 
 -----------------------------------------------------------------------------
 
 > union [] ys = ys
-> union (x:xs) ys 
+> union (x:xs) ys
 > 	| x `is_elem` ys = union xs ys
 >	| otherwise   = x : union xs ys
 >   where { is_elem = isIn "union(deforest)" }
diff --git a/ghc/compiler/deforest/Deforest.hi b/ghc/compiler/deforest/Deforest.hi
deleted file mode 100644
index 6aa23d2ed5..0000000000
--- a/ghc/compiler/deforest/Deforest.hi
+++ /dev/null
@@ -1,8 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 3 #-}
-interface Deforest where
-import CmdLineOpts(GlobalSwitch, SwitchResult)
-import CoreSyn(CoreBinding)
-import Id(Id)
-import SplitUniq(SplitUniqSupply)
-deforestProgram :: (GlobalSwitch -> SwitchResult) -> [CoreBinding Id Id] -> SplitUniqSupply -> [CoreBinding Id Id]
-
diff --git a/ghc/compiler/deforest/Deforest.lhs b/ghc/compiler/deforest/Deforest.lhs
index 623750a591..8c75121cb7 100644
--- a/ghc/compiler/deforest/Deforest.lhs
+++ b/ghc/compiler/deforest/Deforest.lhs
@@ -23,12 +23,10 @@
 > import CmdLineOpts	( GlobalSwitch, SwitchResult )
 > import CoreSyn
 > import Id		( getIdInfo, Id )
-> import IdEnv
 > import IdInfo
 > import Outputable
 > import SimplEnv	( SwitchChecker(..) )
-> import SplitUniq
-> import TyVarEnv
+> import UniqSupply
 > import Util
 
 > -- tmp, for traces
@@ -37,17 +35,17 @@
 > -- stub (ToDo)
 > domIdEnv = panic "Deforest: domIdEnv"
 
-> deforestProgram 
+> deforestProgram
 > 	:: SwitchChecker GlobalSwitch{-maybe-}
->	-> PlainCoreProgram 
->	-> SplitUniqSupply 
->	-> PlainCoreProgram
->	
-> deforestProgram sw prog uq = 
+>	-> [CoreBinding]
+>	-> UniqSupply
+>	-> [CoreBinding]
+>
+> deforestProgram sw prog uq =
 > 	let
 >		def_program = core2def sw prog
 >		out_program = (
->			defProg sw nullIdEnv def_program  `thenSUs` \prog ->
+>			defProg sw nullIdEnv def_program  `thenUs` \prog ->
 >			def2core prog)
 >			uq
 >	in
@@ -61,8 +59,8 @@ Recursive functions are first transformed by the deforester.  If the
 function is annotated as deforestable, then it is converted to
 treeless form for unfolding later on.
 
-Also converting non-recursive functions that are annotated with 
-{-# DEFOREST #-} now.  Probably don't need to convert these to treeless 
+Also converting non-recursive functions that are annotated with
+{-# DEFOREST #-} now.  Probably don't need to convert these to treeless
 form: just the inner recursive bindings they contain.  eg:
 
 repeat = \x -> letrec xs = x:xs in xs
@@ -70,71 +68,71 @@ repeat = \x -> letrec xs = x:xs in xs
 is non-recursive, but we want to unfold it and annotate the binding
 for xs as unfoldable, too.
 
-> defProg 
+> defProg
 > 	:: SwitchChecker GlobalSwitch{-maybe-}
->	-> IdEnv DefExpr 
->	-> [DefBinding] 
->	-> SUniqSM [DefBinding]
->	
-> defProg sw p [] = returnSUs []
-> 
-> defProg sw p (CoNonRec v e : bs) = 
+>	-> IdEnv DefExpr
+>	-> [DefBinding]
+>	-> UniqSM [DefBinding]
+>
+> defProg sw p [] = returnUs []
+>
+> defProg sw p (NonRec v e : bs) =
 > 	trace ("Processing: `" ++
 >		     	ppShow 80 (ppr PprDebug v) ++ "'\n") (
->	tran sw p nullTyVarEnv e []	 	`thenSUs` \e ->
->	mkLoops e				`thenSUs` \(extracted,e) ->
+>	tran sw p nullTyVarEnv e []	 	`thenUs` \e ->
+>	mkLoops e				`thenUs` \(extracted,e) ->
 >	let e' = mkDefLetrec extracted e in
 >	(
 >	  if deforestable v then
 >	  	let (vs,es) = unzip extracted in
->		convertToTreelessForm sw e	`thenSUs` \e ->
->		mapSUs (convertToTreelessForm sw) es	`thenSUs` \es ->
+>		convertToTreelessForm sw e	`thenUs` \e ->
+>		mapUs (convertToTreelessForm sw) es	`thenUs` \es ->
 >		defProg sw (growIdEnvList p ((v,e):zip vs es)) bs
 >	  else
->		defProg sw p bs		
->	)					`thenSUs` \bs ->
->	returnSUs (CoNonRec v e' : bs)
+>		defProg sw p bs
+>	)					`thenUs` \bs ->
+>	returnUs (NonRec v e' : bs)
 >	)
->		
-> defProg sw p (CoRec bs : bs') =
->	mapSUs (defRecBind sw p) bs		`thenSUs` \res  ->
+>
+> defProg sw p (Rec bs : bs') =
+>	mapUs (defRecBind sw p) bs		`thenUs` \res  ->
 >	let
 >		(resid, unfold) = unzip res
 >		p' = growIdEnvList p (concat unfold)
 >	in
->	defProg sw p' bs' 			`thenSUs` \bs' ->
->	returnSUs (CoRec resid: bs')
+>	defProg sw p' bs' 			`thenUs` \bs' ->
+>	returnUs (Rec resid: bs')
 
 
-> defRecBind 
+> defRecBind
 > 	:: SwitchChecker GlobalSwitch{-maybe-}
->	-> IdEnv DefExpr 
+>	-> IdEnv DefExpr
 >	-> (Id,DefExpr)
->	-> SUniqSM ((Id,DefExpr),[(Id,DefExpr)])
->	
+>	-> UniqSM ((Id,DefExpr),[(Id,DefExpr)])
+>
 > defRecBind sw p (v,e) =
 > 	trace ("Processing: `" ++
 >		     	ppShow 80 (ppr PprDebug v) ++ "'\n") (
-> 	tran sw p nullTyVarEnv e []		`thenSUs` \e' ->
->	mkLoops e'				`thenSUs` \(bs,e') ->
+> 	tran sw p nullTyVarEnv e []		`thenUs` \e' ->
+>	mkLoops e'				`thenUs` \(bs,e') ->
 >	let e'' = mkDefLetrec bs e' in
->	
->	d2c e'' `thenSUs` \core_e ->
->	let showBind (v,e) = ppShow 80 (ppr PprDebug v) ++ 
->		"=\n" ++ ppShow 80 (ppr PprDebug e) ++ "\n" 
+>
+>	d2c e'' `thenUs` \core_e ->
+>	let showBind (v,e) = ppShow 80 (ppr PprDebug v) ++
+>		"=\n" ++ ppShow 80 (ppr PprDebug e) ++ "\n"
 >	in
->	trace ("Extracting from `" ++ 
+>	trace ("Extracting from `" ++
 >		ppShow 80 (ppr PprDebug v) ++ "'\n"
 >		++ "{ result:\n" ++ showBind (v,core_e) ++ "}\n") $
->	
+>
 >	if deforestable v
->		then 
+>		then
 >			let (vs,es) = unzip bs in
->		     	convertToTreelessForm sw e'	`thenSUs` \e' ->
->			mapSUs (convertToTreelessForm sw) es `thenSUs` \es ->
->		     	returnSUs ((v,e''),(v,e'):zip vs es)
->		else 
+>		     	convertToTreelessForm sw e'	`thenUs` \e' ->
+>			mapUs (convertToTreelessForm sw) es `thenUs` \es ->
+>		     	returnUs ((v,e''),(v,e'):zip vs es)
+>		else
 >			trace (show (length bs)) (
->			returnSUs ((v,e''),[])
+>			returnUs ((v,e''),[])
 >			)
 >	)
diff --git a/ghc/compiler/deforest/TreelessForm.hi b/ghc/compiler/deforest/TreelessForm.hi
deleted file mode 100644
index 68b982e6f0..0000000000
--- a/ghc/compiler/deforest/TreelessForm.hi
+++ /dev/null
@@ -1,9 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 3 #-}
-interface TreelessForm where
-import CmdLineOpts(SwitchResult)
-import CoreSyn(CoreExpr)
-import DefSyn(DefBindee)
-import Id(Id)
-import SplitUniq(SplitUniqSupply)
-convertToTreelessForm :: (a -> SwitchResult) -> CoreExpr Id DefBindee -> SplitUniqSupply -> CoreExpr Id DefBindee
-
diff --git a/ghc/compiler/deforest/TreelessForm.lhs b/ghc/compiler/deforest/TreelessForm.lhs
index 88a6deef60..2526a5795c 100644
--- a/ghc/compiler/deforest/TreelessForm.lhs
+++ b/ghc/compiler/deforest/TreelessForm.lhs
@@ -8,22 +8,19 @@
 > module TreelessForm (
 > 	convertToTreelessForm
 >	) where
-> 
+>
 > import DefSyn
-> import PlainCore
 > import DefUtils
 
-> import CoreFuns	( typeOfCoreExpr )
-> import IdEnv
 > import CmdLineOpts	( SwitchResult, switchIsOn )
-> import SplitUniq
-> import SimplEnv	( SwitchChecker(..) )
-> import Maybes		( Maybe(..) )
+> import CoreUtils	( coreExprType )
 > import Id		( replaceIdInfo, getIdInfo )
 > import IdInfo
-> import Util
+> import Maybes		( Maybe(..) )
 > import Outputable
-
+> import SimplEnv	( SwitchChecker(..) )
+> import UniqSupply
+> import Util
 
 > -- tmp
 > import Pretty
@@ -39,89 +36,89 @@ ToDo: make this better.
 > convertToTreelessForm
 > 	:: SwitchChecker sw
 >	-> DefExpr
->	-> SUniqSM DefExpr
->	
+>	-> UniqSM DefExpr
+>
 > convertToTreelessForm sw e
 > 	= convExpr e
 >
 > convExpr
 > 	:: DefExpr
->	-> SUniqSM DefExpr
+>	-> UniqSM DefExpr
 
 > convExpr e = case e of
 >
-> 	CoVar (DefArgExpr e) -> 
->		panic "TreelessForm(substTy): CoVar (DefArgExpr _)"
->		
->	CoVar (Label l e) -> 
->		panic "TreelessForm(substTy): CoVar (Label _ _)"
->		
->       CoVar (DefArgVar id) -> returnSUs e
->	
->       CoLit l -> returnSUs e
->	
->       CoCon c ts es -> 
->		mapSUs convAtom es		`thenSUs` \es ->
->		returnSUs (CoCon c ts es)
->	
->       CoPrim op ts es -> 
->		mapSUs convAtom es		`thenSUs` \es ->
->		returnSUs (CoPrim op ts es)
->		
->       CoLam vs e -> 
->		convExpr e			`thenSUs` \e ->
->		returnSUs (CoLam vs e)
->
->       CoTyLam alpha e -> 
->		convExpr e			`thenSUs` \e ->
->		returnSUs (CoTyLam alpha e)
->
->       CoApp e v -> 
->		convExpr e			`thenSUs` \e ->
+> 	Var (DefArgExpr e) ->
+>		panic "TreelessForm(substTy): Var (DefArgExpr _)"
+>
+>	Var (Label l e) ->
+>		panic "TreelessForm(substTy): Var (Label _ _)"
+>
+>       Var (DefArgVar id) -> returnUs e
+>
+>       Lit l -> returnUs e
+>
+>       Con c ts es ->
+>		mapUs convAtom es		`thenUs` \es ->
+>		returnUs (Con c ts es)
+>
+>       Prim op ts es ->
+>		mapUs convAtom es		`thenUs` \es ->
+>		returnUs (Prim op ts es)
+>
+>       Lam vs e ->
+>		convExpr e			`thenUs` \e ->
+>		returnUs (Lam vs e)
+>
+>       CoTyLam alpha e ->
+>		convExpr e			`thenUs` \e ->
+>		returnUs (CoTyLam alpha e)
+>
+>       App e v ->
+>		convExpr e			`thenUs` \e ->
 >		case v of
->		  CoLitAtom l -> returnSUs (CoApp e v)
->		  CoVarAtom v' ->
+>		  LitArg l -> returnUs (App e v)
+>		  VarArg v' ->
 >		    case v' of
 >		    	DefArgVar _ -> panic "TreelessForm(convExpr): DefArgVar"
->			DefArgExpr (CoVar (DefArgVar id)) 
->				| (not.deforestable) id -> 
->					returnSUs (CoApp e v)
->			DefArgExpr e' -> 
->			   newLet e' (\id -> CoApp e (CoVarAtom 
+>			DefArgExpr (Var (DefArgVar id))
+>				| (not.deforestable) id ->
+>					returnUs (App e v)
+>			DefArgExpr e' ->
+>			   newLet e' (\id -> App e (VarArg
 >			   				(DefArgExpr id)))
->						
->       CoTyApp e ty -> 
->		convExpr e			`thenSUs` \e ->
->		returnSUs (CoTyApp e ty)
->		
->       CoCase e ps -> 
->		convCaseAlts ps			`thenSUs` \ps ->
->		case e of 
->			CoVar (DefArgVar id)  | (not.deforestable) id ->
->				returnSUs (CoCase e ps)
->			CoPrim op ts es -> returnSUs (CoCase e ps) 
->			_ -> d2c e		`thenSUs` \e' ->
->			     newLet e (\v -> CoCase v ps)
->
->       CoLet (CoNonRec id e) e' -> 
->		convExpr e			`thenSUs` \e  ->
->		convExpr e'			`thenSUs` \e' ->
->		returnSUs (CoLet (CoNonRec id e) e')
->		
->       CoLet (CoRec bs) e -> 
->--		convRecBinds bs e		`thenSUs` \(bs,e) ->
->--		returnSUs (CoLet (CoRec bs) e)
->		convExpr e			`thenSUs` \e ->
->		mapSUs convRecBind bs		`thenSUs` \bs ->
->		returnSUs (CoLet (CoRec bs) e)
+>
+>       CoTyApp e ty ->
+>		convExpr e			`thenUs` \e ->
+>		returnUs (CoTyApp e ty)
+>
+>       Case e ps ->
+>		convCaseAlts ps			`thenUs` \ps ->
+>		case e of
+>			Var (DefArgVar id)  | (not.deforestable) id ->
+>				returnUs (Case e ps)
+>			Prim op ts es -> returnUs (Case e ps)
+>			_ -> d2c e		`thenUs` \e' ->
+>			     newLet e (\v -> Case v ps)
+>
+>       Let (NonRec id e) e' ->
+>		convExpr e			`thenUs` \e  ->
+>		convExpr e'			`thenUs` \e' ->
+>		returnUs (Let (NonRec id e) e')
+>
+>       Let (Rec bs) e ->
+>--		convRecBinds bs e		`thenUs` \(bs,e) ->
+>--		returnUs (Let (Rec bs) e)
+>		convExpr e			`thenUs` \e ->
+>		mapUs convRecBind bs		`thenUs` \bs ->
+>		returnUs (Let (Rec bs) e)
 >	   where
->	   	convRecBind (v,e) = 
->			convExpr e		`thenSUs` \e ->
->			returnSUs (v,e)
->			
->       CoSCC l e ->
->		convExpr e			`thenSUs` \e ->
->		returnSUs (CoSCC l e)
+>	   	convRecBind (v,e) =
+>			convExpr e		`thenUs` \e ->
+>			returnUs (v,e)
+>
+>       SCC l e ->
+>		convExpr e			`thenUs` \e ->
+>		returnUs (SCC l e)
 
 Mark all the recursive functions as deforestable.  Might as well,
 since they will be in treeless form anyway.  This helps to cope with
@@ -129,61 +126,61 @@ overloaded functions, where the compiler earlier lifts out the
 dictionary deconstruction.
 
 > convRecBinds bs e =
-> 	convExpr e				`thenSUs` \e'   ->
->	mapSUs convExpr es			`thenSUs` \es'  ->
-> 	mapSUs (subst s) es'			`thenSUs` \es'' ->
->	subst s	e'				`thenSUs` \e''  ->
-> 	returnSUs (zip vs' es', e')
+> 	convExpr e				`thenUs` \e'   ->
+>	mapUs convExpr es			`thenUs` \es'  ->
+> 	mapUs (subst s) es'			`thenUs` \es'' ->
+>	subst s	e'				`thenUs` \e''  ->
+> 	returnUs (zip vs' es', e')
 >    where
 >	(vs,es) = unzip bs
 >	vs'  = map mkDeforestable vs
->	s = zip vs (map (CoVar . DefArgVar) vs')
+>	s = zip vs (map (Var . DefArgVar) vs')
 >	mkDeforestable v = replaceIdInfo v (addInfo (getIdInfo v) DoDeforest)
 
-> convAtom :: DefAtom -> SUniqSM DefAtom
-> 
-> convAtom (CoVarAtom v) = 
-> 	convArg v				`thenSUs` \v ->
-> 	returnSUs (CoVarAtom v)
-> convAtom (CoLitAtom l) =
-> 	returnSUs (CoLitAtom l)		-- XXX
+> convAtom :: DefAtom -> UniqSM DefAtom
+>
+> convAtom (VarArg v) =
+> 	convArg v				`thenUs` \v ->
+> 	returnUs (VarArg v)
+> convAtom (LitArg l) =
+> 	returnUs (LitArg l)		-- XXX
 
-> convArg :: DefBindee -> SUniqSM DefBindee
-> 
+> convArg :: DefBindee -> UniqSM DefBindee
+>
 > convArg (DefArgExpr e) =
-> 	convExpr e				`thenSUs` \e ->
->	returnSUs (DefArgExpr e)
-> convArg e@(Label _ _)  = 
+> 	convExpr e				`thenUs` \e ->
+>	returnUs (DefArgExpr e)
+> convArg e@(Label _ _)  =
 > 	panic "TreelessForm(convArg): Label _ _"
 > convArg e@(DefArgVar id)  =
 > 	panic "TreelessForm(convArg): DefArgVar _ _"
 
-> convCaseAlts :: DefCaseAlternatives -> SUniqSM DefCaseAlternatives
-> 
-> convCaseAlts (CoAlgAlts as def) =
-> 	mapSUs convAlgAlt as			`thenSUs` \as ->
->	convDefault def				`thenSUs` \def ->
->	returnSUs (CoAlgAlts as def)
-> convCaseAlts (CoPrimAlts as def) =
-> 	mapSUs convPrimAlt as			`thenSUs` \as ->
->	convDefault def				`thenSUs` \def ->
->	returnSUs (CoPrimAlts as def)
-
-> convAlgAlt  (c, vs, e) = 
-> 	convExpr e				`thenSUs` \e ->
->	returnSUs (c, vs, e)
-> convPrimAlt (l, e) = 
-> 	convExpr e				`thenSUs` \e ->
->	returnSUs (l, e)
-
-> convDefault CoNoDefault = 
-> 	returnSUs CoNoDefault
-> convDefault (CoBindDefault id e) = 
-> 	convExpr e				`thenSUs` \e ->
->     	returnSUs (CoBindDefault id e)
-
-> newLet :: DefExpr -> (DefExpr -> DefExpr) -> SUniqSM DefExpr
-> newLet e body = 
-> 	d2c e					`thenSUs` \core_expr ->
->	newDefId (typeOfCoreExpr core_expr)	`thenSUs` \new_id ->
->	returnSUs (CoLet (CoNonRec new_id e) (body (CoVar (DefArgVar new_id))))
+> convCaseAlts :: DefCaseAlternatives -> UniqSM DefCaseAlternatives
+>
+> convCaseAlts (AlgAlts as def) =
+> 	mapUs convAlgAlt as			`thenUs` \as ->
+>	convDefault def				`thenUs` \def ->
+>	returnUs (AlgAlts as def)
+> convCaseAlts (PrimAlts as def) =
+> 	mapUs convPrimAlt as			`thenUs` \as ->
+>	convDefault def				`thenUs` \def ->
+>	returnUs (PrimAlts as def)
+
+> convAlgAlt  (c, vs, e) =
+> 	convExpr e				`thenUs` \e ->
+>	returnUs (c, vs, e)
+> convPrimAlt (l, e) =
+> 	convExpr e				`thenUs` \e ->
+>	returnUs (l, e)
+
+> convDefault NoDefault =
+> 	returnUs NoDefault
+> convDefault (BindDefault id e) =
+> 	convExpr e				`thenUs` \e ->
+>     	returnUs (BindDefault id e)
+
+> newLet :: DefExpr -> (DefExpr -> DefExpr) -> UniqSM DefExpr
+> newLet e body =
+> 	d2c e					`thenUs` \core_expr ->
+>	newDefId (coreExprType core_expr)	`thenUs` \new_id ->
+>	returnUs (Let (NonRec new_id e) (body (Var (DefArgVar new_id))))
diff --git a/ghc/compiler/envs/CE.hi b/ghc/compiler/envs/CE.hi
deleted file mode 100644
index e10777505f..0000000000
--- a/ghc/compiler/envs/CE.hi
+++ /dev/null
@@ -1,32 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface CE where
-import CharSeq(CSeq)
-import Class(Class)
-import CmdLineOpts(GlobalSwitch)
-import ErrUtils(Error(..))
-import Id(Id)
-import Maybes(MaybeErr)
-import Name(Name)
-import NameTypes(FullName, ShortName)
-import PreludePS(_PackedString)
-import Pretty(Delay, PprStyle, Pretty(..), PrettyRep)
-import TyCon(TyCon)
-import UniqFM(UniqFM)
-import Unique(Unique)
-type CE = UniqFM Class
-data Class 
-type Error = PprStyle -> Int -> Bool -> PrettyRep
-data MaybeErr a b 
-data Name 
-data PprStyle 
-type Pretty = Int -> Bool -> PrettyRep
-data PrettyRep 
-data UniqFM a 
-data Unique 
-checkClassCycles :: UniqFM Class -> MaybeErr () (PprStyle -> Int -> Bool -> PrettyRep)
-lookupCE :: UniqFM Class -> Name -> Class
-nullCE :: UniqFM Class
-plusCE :: UniqFM Class -> UniqFM Class -> UniqFM Class
-rngCE :: UniqFM Class -> [Class]
-unitCE :: Unique -> Class -> UniqFM Class
-
diff --git a/ghc/compiler/envs/CE.lhs b/ghc/compiler/envs/CE.lhs
deleted file mode 100644
index d1e4ea73ea..0000000000
--- a/ghc/compiler/envs/CE.lhs
+++ /dev/null
@@ -1,90 +0,0 @@
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1994
-%
-\section[CE]{Class environment}
-
-\begin{code}
-#include "HsVersions.h"
-
-module CE (
-	CE(..),
-	nullCE, unitCE, rngCE,
-	plusCE, lookupCE,
-	checkClassCycles,
-
-	-- imported things so we're self-contained...
-	Unique, UniqFM,
-	Class, MaybeErr, Name, Pretty(..), PprStyle,
-	PrettyRep, Error(..)
-	
-	IF_ATTACK_PRAGMAS(COMMA emptyUFM COMMA plusUFM)
-	IF_ATTACK_PRAGMAS(COMMA eltsUFM  COMMA singletonDirectlyUFM)
-	IF_ATTACK_PRAGMAS(COMMA u2i)
-    ) where
-
-import AbsUniType	( getClassSig, Class, ClassOp, TyCon, FullName, Arity(..)
-			  IF_ATTACK_PRAGMAS(COMMA cmpTyCon COMMA cmpClass)
-			)
-import Digraph		( topologicalSort )
-import Errors		-- notably classCycleErr
-import UniqFM		-- basic environment handling
-import Maybes		( Maybe(..), MaybeErr(..) )
-import Name		-- Name(..), etc.
-import Pretty
-import Outputable	-- def of ppr
-import Unique		-- for ClassKey uniques
-import Util
-\end{code}
-
-%************************************************************************
-%*									*
-%*		The main representation					*
-%*									*
-%************************************************************************
-
-\begin{code}
---data CE = MkCE (FiniteMap Unique Class) -- keyed off Class's Uniques
-type CE = UniqFM Class
-#define MkCE {--}
--- also killed instance CE, exported non-abstractly
-
-nullCE :: CE
-nullCE = MkCE emptyUFM
-
-rngCE :: CE -> [Class]
-rngCE (MkCE env) = eltsUFM env
-
-unitCE :: Unique{-ClassKey-} -> Class -> CE
-unitCE u c = MkCE (singletonDirectlyUFM u c)
-
-plusCE :: CE -> CE -> CE
-plusCE (MkCE ce1) (MkCE ce2) = MkCE (plusUFM ce1 ce2)
-
-lookupCE :: CE -> Name -> Class
-lookupCE (MkCE ce) name
-  = case name of
-      PreludeClass key _  -> case (lookupDirectlyUFM ce key) of
-				Just clas -> clas
-				Nothing	-> err_msg
-      OtherClass uniq _	_ -> case (lookupDirectlyUFM ce uniq) of
-				Just clas -> clas
-				Nothing	-> panic "lookupCE! (non-prelude)"
-  where
-    err_msg = error ("ERROR: in looking up a Prelude class! "++(ppShow 80 (ppr PprDebug name))++"\n(This can happen if you use `-fno-implicit-prelude'\nor you hide the system's Prelude.hi in some way.)\n")
-
-checkClassCycles :: CE -> MaybeErr () Error
-checkClassCycles (MkCE stuff)
-  = case (topologicalSort (==) edges classes) of
-      Succeeded _ -> Succeeded ()
-      Failed cycles
-	   -> Failed (classCycleErr [ map fmt_tycon c | c <- cycles ])
-		where
-		  fmt_tycon c = (ppr PprForUser c, getSrcLoc c)
-  where
-    classes = eltsUFM stuff	-- the "vertices"
-    edges   = concat (map get_edges classes)
-
-    get_edges clas
-      = let  (_, super_classes, _) = getClassSig clas  in
-	[ (clas, super_class) | super_class <- super_classes ]
-\end{code}
diff --git a/ghc/compiler/envs/E.hi b/ghc/compiler/envs/E.hi
deleted file mode 100644
index 7c5b5ad1dc..0000000000
--- a/ghc/compiler/envs/E.hi
+++ /dev/null
@@ -1,44 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface E where
-import CE(CE(..))
-import Class(Class)
-import Id(Id)
-import Maybes(Labda)
-import Name(Name)
-import NameTypes(FullName, ShortName)
-import PreludePS(_PackedString)
-import TCE(TCE(..))
-import TyCon(TyCon)
-import TyVar(TyVar)
-import UniqFM(UniqFM)
-import Unique(Unique)
-type CE = UniqFM Class
-data E 
-type GVE = [(Name, Id)]
-data Id 
-type LVE = [(Name, Id)]
-data Labda a 
-data Name 
-type TCE = UniqFM TyCon
-data TyVar 
-data UniqFM a 
-getE_CE :: E -> UniqFM Class
-getE_GlobalVals :: E -> [Id]
-getE_TCE :: E -> UniqFM TyCon
-growE_LVE :: E -> [(Name, Id)] -> E
-lookupE_Binder :: E -> Name -> Id
-lookupE_ClassOpByKey :: E -> Unique -> _PackedString -> Id
-lookupE_Value :: E -> Name -> Id
-lookupE_ValueQuietly :: E -> Name -> Labda Id
-mkE :: UniqFM TyCon -> UniqFM Class -> E
-nullE :: E
-nullGVE :: [(Name, Id)]
-nullLVE :: [(Name, Id)]
-plusE_CE :: E -> UniqFM Class -> E
-plusE_GVE :: E -> [(Name, Id)] -> E
-plusE_TCE :: E -> UniqFM TyCon -> E
-plusGVE :: [a] -> [a] -> [a]
-plusLVE :: [a] -> [a] -> [a]
-tvOfE :: E -> [TyVar]
-unitGVE :: Name -> Id -> [(Name, Id)]
-
diff --git a/ghc/compiler/envs/E.lhs b/ghc/compiler/envs/E.lhs
deleted file mode 100644
index c0c8b0f764..0000000000
--- a/ghc/compiler/envs/E.lhs
+++ /dev/null
@@ -1,268 +0,0 @@
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
-%
-\section[E]{Main typechecker environment}
-
-\begin{code}
-#include "HsVersions.h"
-
-module E (
-	E,
-	mkE, nullE,
-	getE_GlobalVals, getE_TCE, getE_CE,
-	plusE_TCE, plusE_CE,
-
-	growE_LVE, plusE_GVE, tvOfE,
-
-	lookupE_Value, lookupE_ValueQuietly,
-	lookupE_ClassOpByKey, lookupE_Binder,
-
-	GVE(..), LVE(..),
-	plusLVE, nullLVE,
-	plusGVE, nullGVE, unitGVE, -- UNUSED: rngGVE,
-
-	-- and to make the interface self-sufficient...
-	CE(..), Id, Name, TCE(..), TyVar, Maybe, UniqFM
-    ) where
-
-import CE
-import TCE
-import UniqFM		-- basic env handling code
-
-import AbsPrel		( PrimOp
-			  IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
-			  IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
-			)
-import AbsUniType	( getClassOps, extractTyVarsFromTy,
-			  getClassBigSig, getClassOpString, TyVar,
-			  TyVarTemplate, ClassOp, Class, Arity(..),
-			  TauType(..)
-			  IF_ATTACK_PRAGMAS(COMMA cmpTyVar COMMA cmpClass)
-			)
-import Id		( getIdUniType, Id, IdInfo )
-import Maybes		( MaybeErr(..), Maybe(..) )
-import Name		-- Name(..), etc.
-import Outputable	-- def of ppr, etc.
-import Pretty		-- to pretty-print error messages
-import UniqSet		-- this use of Sets is a HACK (WDP 94/05)
-import Unique		-- *Key stuff
-import Util
-\end{code}
-
-
-%************************************************************************
-%*									*
-\subsection{Type declarations}
-%*									*
-%************************************************************************
-
-
-\begin{code}
-data E
-  = MkE	TCE 	    -- type environment                                        
-	GVB	    -- "global" value bindings; no free type vars
-	LVB	    -- "local" value bindings; may have free type vars      
-	CE 	    -- class environment                                       
-
-mkE :: TCE -> CE -> E
-mkE tce ce = MkE tce nullGVB nullLVB ce
-
-nullE :: E
-nullE = MkE nullTCE nullGVB nullLVB nullCE
-\end{code}
-
-The ``local'' and ``global'' bindings, @LVB@ and @GVB@, are
-non-exported synonyms.  The important thing is that @GVB@ doesn't
-contain any free type variables.  This is used (only) in @tvOfE@,
-which extracts free type variables from the environment.  It's quite a
-help to have this separation because there may be quite a large bunch
-of imported things in the @GVB@, all of which are guaranteed
-polymorphic.
-
-\begin{code}
-type LVB = UniqFM Id -- Locals just have a Unique
-type GVB = UniqFM Id -- Globals might be a prelude thing; hence IdKey
-
-nullLVB = (emptyUFM :: LVB)
-nullGVB = (emptyUFM :: GVB)
-\end{code}
-
-The ``local'' and ``global'' value environments are not part of @E@ at
-all, but is used to provide increments to the value bindings.  GVE are
-carries the implication that there are no free type variables.
-
-\begin{code}
-type LVE = [(Name, Id)]	-- Maps Names to Ids
-type GVE = [(Name, Id)]	-- Maps Names to Ids
-
-nullLVE     = ([] :: LVE)
-plusLVE a b = a ++ b
-nullGVE     = ([] :: GVE)
-unitGVE n i = ( [(n, i)] :: GVE )
--- UNUSED: rngGVE  gve = map snd gve
-plusGVE a b = a ++ b
-\end{code}
-
-%************************************************************************
-%*									*
-\subsection{Value environment stuff}
-%*									*
-%************************************************************************
-
-Looking up things should mostly succeed, because the renamer should
-have spotted all out-of-scope names.  The exception is instances.
-
-The ``Quietly'' version is for pragmas, where lookups very well may
-fail. @lookup_val@ is the internal function that does the work.
-
-\begin{code}
-lookupE_Value	     :: E -> Name -> Id
-lookupE_ValueQuietly :: E -> Name -> Maybe Id
-
-lookupE_Value e nm
-  = case lookup_val e nm of
-      Succeeded id -> id
-      Failed (should_panic, msg)
-	-> if should_panic then panic msg else error msg
-
-lookupE_ValueQuietly e nm
-  = case lookup_val e nm of
-      Succeeded id -> Just id
-      Failed _	   -> Nothing
-\end{code}
-
-\begin{code}
-lookup_val (MkE _ gvb lvb ce) name
-  = case name of
-
-      WiredInVal id   -> Succeeded id
-      PreludeVal key _ -> case (lookupDirectlyUFM gvb key) of
-			    Just id -> Succeeded id
-			    Nothing -> Failed (False, prelude_err_msg)
-
-      ClassOpName uniq clas_name _ tag -> id_from_env uniq
-
-      -- You might think that top-level ids are guaranteed to have no
-      -- free tyvars, so look only in gvb; but you'd be wrong!  When
-      -- type-checking the RHS of recursive top-level defns, the name
-      -- of the thing is bound to a *monomorphic* type, which is later
-      -- generalised.  So we have to look in the LVE too.
-
-      OtherTopId uniq _ -> id_from_env uniq
-
-      -- Short names could be in either GVB or LVB
-      Short uniq _      -> id_from_env uniq
-
-      funny_name -> pprPanic "lookup_val: funny Name" (ppr PprDebug funny_name)
-  where
-    prelude_err_msg = "ERROR: in looking up a built-in Prelude value!\n(This can happen if you use `-fno-implicit-prelude'\nor you hide the system's Prelude.hi in some way.)"
-
-    id_from_env uniq
-      = case (lookupDirectlyUFM lvb uniq) of
-	  Just id -> Succeeded id
-	  Nothing ->
-	    case (lookupDirectlyUFM gvb uniq) of
-	      Just id -> Succeeded id
-	      Nothing -> Failed (True, -- should panic
-			  ("lookupE_Value: unbound name: "++(ppShow 80 (ppr PprShowAll name))))
-\end{code}
-
-For Prelude things that we reach out and grab, we have only an @Unique@.
-\begin{code}
-lookupE_ClassOpByKey :: E -> Unique{-ClassKey-} -> FAST_STRING -> Id
-
-lookupE_ClassOpByKey (MkE _ gvb lvb ce) clas_key op_str
-  = let
-	clas   = lookupCE ce (PreludeClass clas_key bottom)
-	bottom = pprPanic ("lookupE_ClassOpByKey: "++(_UNPK_ op_str))
-			  (ppAbove (pprUnique clas_key) (ppr PprShowAll (rngCE ce)))
-
-	(clas_tyvar_tmpl, scs, sc_sel_ids, ops, op_sel_ids, defm_ids)
-	  = getClassBigSig clas
-    in
-    case [ op_sel_id | (op, op_sel_id) <- ops `zip` op_sel_ids,
-		       op_str == getClassOpString op ] of
-      [op] -> op
-    -- Seems a rather horrible way to do it (ToDo)
-\end{code}
-
-@lookupE_Binder@ is like @lookupE_Value@, but it is used for {\em
-binding} occurrences of a variable, rather than {\em uses}.  The
-difference is that there should always be an entry in the LVE for
-binding occurrences.  Just a sanity check now, really.
-
-\begin{code}
-lookupE_Binder :: E -> Name -> Id
-lookupE_Binder (MkE _ _ lvb _) name
-  = case (lookupDirectlyUFM lvb (name2uniq name)) of
-      Just id -> id
-      Nothing -> pprPanic "lookupE_Binder: unbound name: " (ppr PprShowAll name)
-\end{code}
-
-\begin{code}
-getE_GlobalVals :: E -> [Id]
-getE_GlobalVals  (MkE tce gvb lvb ce)
-  = let
-    	result = eltsUFM gvb ++ eltsUFM lvb
-    in
-    -- pprTrace "Global Ids:" (ppr PprShowAll result)
-    result
-
-plusE_GVE :: E -> GVE -> E
-plusE_GVE (MkE tce gvb lvb ce) gve
-  = let
-	new_stuff = listToUFM_Directly [(name2idkey n, i) | (n,i) <- gve ]
-    in
-    MkE tce (plusUFM gvb new_stuff) lvb ce
-  where
-    name2idkey (PreludeVal k _) = k
-    name2idkey (OtherTopId u _) = u
-    name2idkey (ClassOpName u _ _ _) = u
-
-growE_LVE :: E -> LVE -> E
-growE_LVE (MkE tce gvb lvb ce) lve
-  = let
-	new_stuff = listToUFM_Directly [(name2uniq n, i) | (n,i) <- lve ]
-    in
-    MkE tce gvb (plusUFM lvb new_stuff) ce
-
--- ToDo: move this elsewhere??
-name2uniq (Short u _)   	= u
-name2uniq (OtherTopId u _)	= u
-name2uniq (ClassOpName u _ _ _) = panic "growE_LVE:name2uniq"
-\end{code}
-
-Return the free type variables of an LVE; there are no duplicates in
-the result---hence all the @Set@ bozo-ery.  The free tyvars can only
-occur in the LVB part.
-
-\begin{code}
-tvOfE :: E -> [TyVar]
-tvOfE (MkE tce gvb lvb ce) 
-  = uniqSetToList (mkUniqSet (
-	foldr ((++) . extractTyVarsFromTy . getIdUniType) [] (eltsUFM lvb)
-    ))
-\end{code}
-
-%************************************************************************
-%*									*
-%*	
-\subsection{Type and class environments}
-%*									*
-%************************************************************************
-
-\begin{code}
-getE_TCE :: E -> TCE
-getE_TCE (MkE tce gvb lvb ce) = tce
-
-getE_CE :: E -> CE
-getE_CE  (MkE tce gvb lvb ce) = ce
-
-plusE_TCE :: E -> TCE -> E
-plusE_TCE (MkE tce gvb lvb ce) tce'
-  = MkE (plusTCE tce' tce) gvb lvb ce
-
-plusE_CE :: E -> CE -> E
-plusE_CE (MkE tce gvb lvb ce) ce'
-  = MkE tce gvb lvb (plusCE ce ce')
-\end{code}
diff --git a/ghc/compiler/envs/IdEnv.hi b/ghc/compiler/envs/IdEnv.hi
deleted file mode 100644
index 196e95e6be..0000000000
--- a/ghc/compiler/envs/IdEnv.hi
+++ /dev/null
@@ -1,27 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface IdEnv where
-import Id(Id)
-import Maybes(Labda(..))
-import UniqFM(UniqFM)
-import Unique(Unique)
-data Id 
-type IdEnv a = UniqFM a
-data Labda a   = Hamna | Ni a
-data UniqFM a 
-data Unique 
-addOneToIdEnv :: UniqFM a -> Id -> a -> UniqFM a
-combineIdEnvs :: (a -> a -> a) -> UniqFM a -> UniqFM a -> UniqFM a
-delManyFromIdEnv :: UniqFM a -> [Id] -> UniqFM a
-delOneFromIdEnv :: UniqFM a -> Id -> UniqFM a
-growIdEnv :: UniqFM a -> UniqFM a -> UniqFM a
-growIdEnvList :: UniqFM a -> [(Id, a)] -> UniqFM a
-isNullIdEnv :: UniqFM a -> Bool
-lookupIdEnv :: UniqFM a -> Id -> Labda a
-lookupNoFailIdEnv :: UniqFM a -> Id -> a
-mapIdEnv :: (a -> b) -> UniqFM a -> UniqFM b
-mkIdEnv :: [(Id, a)] -> UniqFM a
-modifyIdEnv :: UniqFM a -> (a -> a) -> Id -> UniqFM a
-nullIdEnv :: UniqFM a
-rngIdEnv :: UniqFM a -> [a]
-unitIdEnv :: Id -> a -> UniqFM a
-
diff --git a/ghc/compiler/envs/IdEnv.lhs b/ghc/compiler/envs/IdEnv.lhs
deleted file mode 100644
index a06ef63719..0000000000
--- a/ghc/compiler/envs/IdEnv.lhs
+++ /dev/null
@@ -1,113 +0,0 @@
-%
-% (c) The AQUA Project, Glasgow University, 1995
-%
-\section[IdEnv]{Lookup tables that have @Id@ keys}
-
-An interface to the @FiniteMap@ machinery, which exports
-a ``personality'' the same as that of the old @IdEnv@ module.
-
-\begin{code}
-#include "HsVersions.h"
-
-module IdEnv (
-	IdEnv(..),  -- abstract: NOT
-
-	lookupIdEnv, lookupNoFailIdEnv,
-	nullIdEnv, unitIdEnv, mkIdEnv, growIdEnv, growIdEnvList,
-	isNullIdEnv,
-	addOneToIdEnv,
-	delOneFromIdEnv, delManyFromIdEnv, --UNUSED: minusIdEnv,
-	modifyIdEnv, combineIdEnvs,
-	rngIdEnv,
-	mapIdEnv,
--- UNUSED:	filterIdEnv,
-
-	-- and to make the interface self-sufficient...
-	UniqFM,
-	Id, Unique, Maybe(..)
-	
-	-- and for pragma-friendliness...
-#ifdef USE_ATTACK_PRAGMAS
-	, addToUFM, plusUFM_C, delListFromUFM, delFromUFM, plusUFM,
-	lookupUFM, mapUFM, filterUFM, minusUFM, listToUFM, emptyUFM,
-	eltsUFM, singletonUFM,
-	u2i
-#endif
-    ) where
-
-import UniqFM
-import Id
-import IdInfo
-import Maybes		( Maybe(..), MaybeErr(..) )
-import Outputable
-import Unique		( Unique, u2i )
-import Util
-\end{code}
-
-\begin{code}
-type IdEnv elt = UniqFM elt
-\end{code}
-
-Signatures:
-\begin{code}
-addOneToIdEnv :: IdEnv a -> Id -> a -> IdEnv a
-combineIdEnvs :: (a -> a -> a) -> IdEnv a -> IdEnv a -> IdEnv a
-delManyFromIdEnv :: IdEnv a -> [Id] -> IdEnv a
-delOneFromIdEnv :: IdEnv a -> Id -> IdEnv a
-growIdEnv :: IdEnv a -> IdEnv a -> IdEnv a
-growIdEnvList :: IdEnv a -> [(Id, a)] -> IdEnv a
-isNullIdEnv :: IdEnv a -> Bool
-lookupIdEnv :: IdEnv a -> Id -> Maybe a
-lookupNoFailIdEnv :: IdEnv a -> Id -> a
-mapIdEnv :: (a -> b) -> IdEnv a -> IdEnv b
---filterIdEnv :: (a -> Bool) -> IdEnv a -> IdEnv a
---minusIdEnv :: IdEnv a -> IdEnv a -> IdEnv a
-mkIdEnv :: [(Id, a)] -> IdEnv a
-modifyIdEnv :: IdEnv a -> (a -> a) -> Id -> IdEnv a
-nullIdEnv :: IdEnv a
-rngIdEnv :: IdEnv a -> [a]
-unitIdEnv :: Id -> a -> IdEnv a
-\end{code}
-
-\begin{code}
-addOneToIdEnv env id elt = addToUFM env id elt
-
-combineIdEnvs combiner env1 env2 = plusUFM_C combiner env1 env2
-
-delManyFromIdEnv env ids = delListFromUFM env ids
-
-delOneFromIdEnv env id = delFromUFM env id
-
-growIdEnv old_env new_stuff = plusUFM old_env new_stuff
-
-growIdEnvList old_env pairs = plusUFM old_env (listToUFM pairs)
-
-isNullIdEnv env = sizeUFM env == 0
-
-lookupIdEnv env id = lookupUFM env id
-
-lookupNoFailIdEnv env id = case (lookupIdEnv env id) of { Just xx -> xx }
-
-mapIdEnv f env = mapUFM f env
-
-{- UNUSED:
-filterIdEnv p env = filterUFM p env
-minusIdEnv env1 env2 = minusUFM env1 env2
--}
-
-mkIdEnv stuff = listToUFM stuff
-
--- modifyIdEnv: Look up a thing in the IdEnv, then mash it with the
--- modify function, and put it back.
-
-modifyIdEnv env mangle_fn key
-  = case (lookupIdEnv env key) of
-      Nothing -> env
-      Just xx -> addOneToIdEnv env key (mangle_fn xx)
-
-nullIdEnv = emptyUFM
-
-rngIdEnv env = eltsUFM env
-
-unitIdEnv id elt = singletonUFM id elt
-\end{code}
diff --git a/ghc/compiler/envs/InstEnv.hi b/ghc/compiler/envs/InstEnv.hi
deleted file mode 100644
index 89159f5bde..0000000000
--- a/ghc/compiler/envs/InstEnv.hi
+++ /dev/null
@@ -1,54 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface InstEnv where
-import BasicLit(BasicLit)
-import Class(Class, ClassOp)
-import CoreSyn(CoreAtom, CoreBinding, CoreCaseAlternatives, CoreExpr)
-import CostCentre(CostCentre)
-import HsBinds(Binds)
-import HsExpr(ArithSeqInfo, Expr, Qual)
-import HsLit(Literal)
-import HsMatches(Match)
-import HsPat(InPat, TypecheckedPat)
-import HsTypes(PolyType)
-import Id(Id)
-import IdInfo(SpecEnv, SpecInfo)
-import Inst(Inst, InstOrigin, OverloadedLit)
-import Maybes(Labda, MaybeErr)
-import Name(Name)
-import PreludePS(_PackedString)
-import PrimOps(PrimOp)
-import SplitUniq(SplitUniqSupply)
-import SrcLoc(SrcLoc)
-import TyCon(TyCon)
-import TyVar(TyVar, TyVarTemplate)
-import UniType(UniType)
-import Unique(Unique)
-data Class 
-type ClassInstEnv = [(UniType, InstTemplate)]
-data ClassOp 
-data CoreExpr a b 
-data Expr a b 
-data Id 
-data Inst 
-data InstOrigin 
-data InstTemplate 
-data InstTy 
-type InstanceMapper = Class -> ([(UniType, InstTemplate)], ClassOp -> SpecEnv)
-data Labda a 
-type MatchEnv a b = [(a, b)]
-data MaybeErr a b 
-type MethodInstInfo = (Id, [UniType], InstTemplate)
-data TypecheckedPat 
-data SpecEnv 
-data SpecInfo 
-data SplitUniqSupply 
-data TyCon 
-data TyVarTemplate 
-data UniType 
-addClassInst :: Class -> [(UniType, InstTemplate)] -> UniType -> Id -> [TyVarTemplate] -> [(Class, UniType)] -> SrcLoc -> MaybeErr [(UniType, InstTemplate)] (Class, (UniType, SrcLoc), (UniType, SrcLoc))
-lookupClassInstAtSimpleType :: Class -> UniType -> Labda Id
-lookupInst :: SplitUniqSupply -> Inst -> Labda (Expr Id TypecheckedPat, [Inst])
-lookupNoBindInst :: SplitUniqSupply -> Inst -> Labda [Inst]
-mkInstSpecEnv :: Class -> UniType -> [TyVarTemplate] -> [(Class, UniType)] -> SpecEnv
-nullMEnv :: [(a, b)]
-
diff --git a/ghc/compiler/envs/InstEnv.lhs b/ghc/compiler/envs/InstEnv.lhs
deleted file mode 100644
index 0afa6c9ae6..0000000000
--- a/ghc/compiler/envs/InstEnv.lhs
+++ /dev/null
@@ -1,593 +0,0 @@
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1993-1995
-%
-\section[InstEnv]{Instance environments}
-
-\begin{code}
-#include "HsVersions.h"
-
-module InstEnv (
-	-- these types could use some abstractification (??? ToDo)
-	ClassInstEnv(..), -- OLD: IdInstEnv(..),
-	InstTemplate, InstTy,
-	MethodInstInfo(..),	-- needs to be exported? (ToDo)
-	InstanceMapper(..),	-- widely-used synonym
-
---	instMethod, instTemplate, -- no need to export
-	addClassInst, {- NOT USED addConstMethInst, -}
-	lookupInst,
-	lookupClassInstAtSimpleType,
-	lookupNoBindInst,
-	mkInstSpecEnv,
-
-	MatchEnv(..),	-- mk more abstract (??? ToDo)
-	nullMEnv,
---	mkMEnv, lookupMEnv, matchMEnv, insertMEnv, -- no need to export
-
-	-- and to make the interface self-sufficient...
-	Class, ClassOp, CoreExpr, Expr, TypecheckedPat, Id,
-	Inst, InstOrigin, Maybe, MaybeErr, TyVarTemplate, TyCon,
-	UniType, SplitUniqSupply, SpecInfo, SpecEnv
-    ) where
-
-IMPORT_Trace		-- ToDo: rm (debugging)
-
-import AbsPrel		( intTyCon, --wordTyCon, addrTyCon,
-			  floatTyCon, doubleTyCon, charDataCon, intDataCon,
-			  wordDataCon, addrDataCon, floatDataCon,
-			  doubleDataCon,
-			  intPrimTyCon, doublePrimTyCon
-			)
-import AbsSyn		-- TypecheckedExpr, etc.
-import AbsUniType
-import Id
-import IdInfo
-import Inst
-import Maybes		-- most of it
-import Outputable	( isExported )
-import PlainCore	-- PlainCoreExpr, etc.
-import Pretty
-import PrimKind		-- rather grubby import (ToDo?)
-import SplitUniq
-import Util
-\end{code}
-
-%************************************************************************
-%*									*
-\subsection[InstEnv-types]{Type declarations}
-%*									*
-%************************************************************************
-
-\begin{code}
-type InstanceMapper
-  = Class -> (ClassInstEnv, ClassOp -> SpecEnv)
-
-type ClassInstEnv
-  = MatchEnv UniType InstTemplate	-- Instances of dicts
-
-data InstTemplate
-  = MkInstTemplate
-	Id		-- A fully polymorphic Id; it is the function
-			-- which produces the Id instance or dict from
-			-- the pieces specified by the rest of the
-			-- template.  Its SrcLoc tells where the
-			-- instance was defined.
-	[UniType]	-- Apply it to these types, suitably instantiated
-	[InstTy]	-- and instances of these things
-
-type MethodInstInfo = (Id, [UniType], InstTemplate) -- Specifies a method instance
-\end{code}
-
-There is an important consistency constraint between the @MatchEnv@s
-in and the @InstTemplate@s inside them: the @UniType@(s) which is/are
-the key for the @MatchEnv@ must contain only @TyVarTemplates@, and
-these must be a superset of the @TyVarTemplates@ mentioned in the
-corresponding @InstTemplate@.
-
-Reason: the lookup process matches the key against the desired value,
-returning a substitution which is used to instantiate the template.
-
-\begin{code}
-data InstTy
-  = DictTy	Class UniType
-  | MethodTy	Id    [UniType]
-\end{code}
-
-	MkInstTemplate f tvs insts
-
-says that, given a particular mapping of type variables tvs to some
-types tys, the value which is the required instance is
-
-	f tys (insts [tys/tvs])
-
-
-@instMethod@ is used if there is no instance for a method; then it is
-expressed in terms of the corresponding dictionary (or possibly, in a
-wired-in case only, dictionaries).
-
-\begin{code}
-instMethod :: SplitUniqSupply
-	   -> InstOrigin
-	   -> Id -> [UniType]
-	   -> (TypecheckedExpr, [Inst])
-
-instMethod uniqs orig id tys
-  = (mkDictApp (mkTyApp (Var id) tys) dicts,
-     insts)
-  where
-   (tyvars, theta, tau_ty) = splitType (getIdUniType id)
-   tenv			   = tyvars `zipEqual` tys
-   insts		   = mk_dict_insts uniqs theta
-   dicts		   = map mkInstId insts
-
-   mk_dict_insts us [] = []
-   mk_dict_insts us ((clas, ty) : rest)
-      = case splitUniqSupply us of { (s1, s2) ->
-        (Dict (getSUnique s1) clas (instantiateTauTy tenv ty) orig)
-	: mk_dict_insts s2 rest
-	}
-\end{code}
-
-@instTemplate@ is used if there is an instance for a method or dictionary.
-
-\begin{code}
-instTemplate :: SplitUniqSupply
-	     -> InstOrigin
-	     -> [(TyVarTemplate, UniType)]
-	     -> InstTemplate
-	     -> (TypecheckedExpr, [Inst])
-
-instTemplate uniqs orig tenv (MkInstTemplate id ty_tmpls inst_tys)
-  = (mkDictApp (mkTyApp (Var id) ty_args) ids,	-- ToDo: not strictly a dict app
-						-- for Method inst_tys
-     insts)
-  where
-    ty_args	    = map (instantiateTy tenv) ty_tmpls
-    insts	    = mk_insts uniqs inst_tys
-    ids		    = map mkInstId insts
-
-    mk_insts us [] = []
-    mk_insts us (inst_ty : rest)
-      = case splitUniqSupply us of { (s1, s2) ->
-	let
-	    uniq = getSUnique s1
-	in
-        (case inst_ty of
-	   DictTy clas ty  -> Dict uniq clas (instantiateTy tenv ty) orig
-	   MethodTy id tys -> Method uniq id (map (instantiateTy tenv) tys) orig
-	) : mk_insts s2 rest
-	}
-\end{code}
-
-
-%************************************************************************
-%*									*
-\subsection[InstEnv-adding]{Adding new class instances}
-%*									*
-%************************************************************************
-
-@addClassInstance@ adds the appropriate stuff to the @ClassInstEnv@ based on
-information from a single instance declaration.	 It complains about
-any overlap with an existing instance.
-
-Notice that we manufacture the @DictFunId@ and @ConstMethodId@s from
-scratch here, rather than passing them in.  This means a small amount
-of duplication (no big deal) and that we can't attach a single
-canonical unfolding; but they don't have a slot for unfoldings
-anyway...  This could be improved.  (We do, however, snaffle in the
-pragma info from the interface...)
-
-{\em Random notes}
-
-\begin{verbatim}
-class Foo a where
-  fop :: Ord b => a -> b -> b -> a
-
-instance Foo Int where
-  fop x y z = if y<z then x else fop x z y
-
-instance Foo a => Foo [a] where
-  fop []     y z = []
-  fop (x:xs) y z = [fop x y z]
-\end{verbatim}
-
-
-For the Int instance we add to the ??? envt
-\begin{verbatim}
-  (ClassOpId Foo fop) |--> [Int,b] |--> InstTemplate (ConstMethodId Foo fop Int) [b] [Ord b]
-\end{verbatim}
-
-If there are no type variables, @addClassInstance@ adds constant
-instances for those class ops not mentioned in the class-op details
-(possibly using the pragma info that was passed in).  This MUST
-be the same decision as that by @tcInstDecls2@ about whether to
-generate constant methods.  NB: A slightly more permissive version
-would base the decision on the context being empty, but there is
-slightly more admin associated and the benefits are very slight; the
-context is seldom empty unless there are no tyvars involved.
-
-Note: the way of specifying class-op instance details is INADEQUATE
-for polymorphic class ops.  That just means you can't specify clever
-instances for them via this function.
-
-\begin{code}
-addClassInst
-    :: Class			-- class in question (for err msg only)    	
-    -> ClassInstEnv		-- Incoming envt
-    -> UniType			-- The instance type
-    -> Id			-- Dict fun id to apply
-    -> [TyVarTemplate]		-- Types to which (after instantiation) to apply the dfun
-    -> ThetaType		-- Dicts to which to apply the dfun
-    -> SrcLoc			-- associated SrcLoc (for err msg only)
-    -> MaybeErr
-	  ClassInstEnv		-- Success
-	  (Class, (UniType, SrcLoc),  -- Failure: the overlapping pair
-		  (UniType, SrcLoc))
-
-addClassInst clas inst_env inst_ty dfun_id inst_tyvars dfun_theta locn
-  = case (insertMEnv matchTy inst_env inst_ty dict_template) of
-      Succeeded inst_env' -> Succeeded inst_env'
-      Failed (ty', MkInstTemplate id' _ _)
-	-> Failed (clas, (inst_ty, locn), (ty', getSrcLoc id'))
-  where
-    dict_template = MkInstTemplate dfun_id 
-				   (map mkTyVarTemplateTy inst_tyvars) 
-				   (unzipWith DictTy dfun_theta)
-\end{code}
-
-============ NOT USED =============
-@addConstMethInst@ panics on overlap, because @addClassInst@ has already found
-any overlap.
-
-\begin{pseudocode}
-addConstMethInst :: IdInstEnv
-		 -> UniType		-- The instance type
-		 -> Id			-- The constant method
-		 -> [TyVarTemplate]	-- Apply method to these (as above)
-		 -> IdInstEnv
-
-addConstMethInst inst_env inst_ty meth_id inst_tyvars
-  = case (insertMEnv matchTys inst_env [inst_ty] template) of
-      Succeeded inst_env' -> inst_env'
-      Failed (tys', MkInstTemplate id' _ _) ->
-	pprPanic "addConstMethInst:"
-		(ppSep [ppr PprDebug meth_id,
-		        ppr PprDebug inst_ty,
-			ppr PprDebug id'])
-  where
-     template = MkInstTemplate meth_id (map mkTyVarTemplateTy inst_tyvars) []
-	-- Constant method just needs to be applied to tyvars
-	-- (which are usually empty)
-\end{pseudocode}
-
-@mkIdInstEnv@ is useful in the simple case where we've a list of
-@(types, id)@ pairs; the \tr{id} is the \tr{types} specialisation of
-some other Id (in which the resulting IdInstEnv will doubtless be
-embedded.  There's no messing about with type variables or
-dictionaries here.
-
-\begin{code}
-{- OLD:
-mkIdInstEnv :: [([TauType],Id)] -> IdInstEnv
-
-mkIdInstEnv [] = nullMEnv
-mkIdInstEnv ((tys,id) : rest) 
-  = let
-	inst_env = mkIdInstEnv rest
-    in
-    case (insertMEnv matchTys inst_env tys template) of
-      Succeeded inst_env' -> inst_env'
-      Failed _ -> panic "Failed in mkIdInstEnv"
-  where
-    template = MkInstTemplate id [] []
--}
-\end{code}
-
-%************************************************************************
-%*									*
-\subsection[InstEnv-lookup]{Performing lookup}
-%*									*
-%************************************************************************
-
-\begin{code}
-lookupInst :: SplitUniqSupply
-	   -> Inst
-	   -> Maybe (TypecheckedExpr,
-		     [Inst])
-
-lookupInst uniqs (Dict _ clas ty orig)
-  = if isTyVarTy ty then
-	Nothing	-- No instances of a class at a type variable
-    else
-      case (lookupMEnv matchTy inst_env ty) of
-	Nothing		    -> Nothing
-	Just (_,tenv,templ) -> Just (instTemplate uniqs orig tenv templ)
-  where
-    inst_env
-      = case orig of
-
-	  -- During deriving and instance specialisation operations
-	  -- we can't get the instances of the class from inside the
-	  -- class, because the latter ain't ready yet.  Instead we
-	  -- find a mapping from classes to envts inside the dict origin.
-	  -- (A Simon hack [WDP])
-
-	  DerivingOrigin inst_mapper _ _ _ _ -> fst (inst_mapper clas)
-
-	  InstanceSpecOrigin inst_mapper _ _ _ -> fst (inst_mapper clas)
-
-	  -- Usually we just get the instances of the class from
-	  -- inside the class itself.
-
-	  other -> getClassInstEnv clas
-
-lookupInst uniqs (Method _ id tys orig)
-  = if (all isTyVarTy tys) then
-	general_case	-- Instance types are all type variables, so there can't be
-			-- a special instance for this method
-
-    else	-- Get the inst env from the Id, and look up in it
-      case (lookupSpecEnv (getIdSpecialisation id) tys) of
-	Nothing		    -> general_case
-	Just (spec_id, types_left, num_dicts_to_toss)
-	  -> Just (instMethod uniqs orig spec_id types_left)
-  where
-    general_case = Just (instMethod uniqs orig id tys)
-\end{code}
-
-Now "overloaded" literals: the plain truth is that the compiler
-is intimately familiar w/ the types Int, Integer, Float, and Double;
-for everything else, we actually conjure up an appropriately-applied
-fromInteger/fromRational, as the Haskell report suggests.
-
-\begin{code}
-lookupInst uniqs (LitInst u (OverloadedIntegral i from_int from_integer) ty orig)
-  = Just (
-    case (getUniDataTyCon_maybe ty) of	-- this way is *unflummoxed* by synonyms
-      Just (tycon, [], _)
-        | tycon == intPrimTyCon		-> (intprim_lit,    [])
-	| tycon == doublePrimTyCon	-> (doubleprim_lit, [])
-        | tycon == intTyCon		-> (int_lit,        [])
-	| tycon == doubleTyCon		-> (double_lit,     [])
-	| tycon == floatTyCon		-> (float_lit,      [])
---	| tycon == wordTyCon		-> (word_lit,       [])
---	| tycon == addrTyCon		-> (addr_lit,       [])
-
-      _{-otherwise-} ->
-
-	if (i >= toInteger minInt && i <= toInteger maxInt) then
-	    -- It's overloaded but small enough to fit into an Int
-
-	    let u2		= getSUnique uniqs
-		method	= Method u2 from_int [ty] orig
-	    in
-	    (App (Var (mkInstId method)) int_lit, [method])
-
-	else
-	    -- Alas, it is overloaded and a big literal!
-
-	    let u2	   = getSUnique uniqs
-		method = Method u2 from_integer [ty] orig
-	    in
-	    (App (Var (mkInstId method)) (Lit (IntLit i)), [method])
-    )
-  where
-#if __GLASGOW_HASKELL__ <= 22
-    iD = ((fromInteger i) :: Double)
-#else
-    iD = ((fromInteger i) :: Rational)
-#endif
-    intprim_lit    = Lit (IntPrimLit i)
-    doubleprim_lit = Lit (DoublePrimLit iD)
-    int_lit        = App (Var intDataCon)    intprim_lit
-    double_lit     = App (Var doubleDataCon) doubleprim_lit
-    float_lit      = App (Var floatDataCon)  (Lit (FloatPrimLit iD))
---  word_lit       = App (Var wordDataCon)   intprim_lit
---  addr_lit       = App (Var addrDataCon)   intprim_lit
-
-lookupInst uniqs (LitInst u (OverloadedFractional f from_rational) ty orig)
-  = Just (
-    case (getUniDataTyCon_maybe ty) of	-- this way is *unflummoxed* by synonyms
-      Just (tycon, [], _)
-	| tycon == doublePrimTyCon -> (doubleprim_lit, [])
-	| tycon == doubleTyCon	   -> (double_lit, [])
-	| tycon == floatTyCon	   -> (float_lit,  [])
-
-      _ {-otherwise-} ->    -- gotta fromRational it...
-	--pprTrace "lookupInst:fractional lit ty?:" (ppr PprDebug ty) (
-	let
-	    u2	   = getSUnique uniqs
-	    method = Method u2 from_rational [ty] orig
-	in
-	(App (Var (mkInstId method)) (Lit (FracLit f)), [method])
-	--)
-    )
-  where
-#if __GLASGOW_HASKELL__ <= 22
-    fD = ((fromRational f) :: Double)
-#else
-    fD = f
-#endif
-    doubleprim_lit = Lit (DoublePrimLit fD)
-    double_lit     = App (Var doubleDataCon) doubleprim_lit
-    float_lit      = App (Var floatDataCon)  (Lit (FloatPrimLit  fD))
-\end{code}
-
-There is a second, simpler interface, when you want an instance of a
-class at a given nullary type constructor.  It just returns the
-appropriate dictionary if it exists.  It is used only when resolving
-ambiguous dictionaries.
-
-\begin{code}
-lookupClassInstAtSimpleType :: Class -> UniType -> Maybe Id
-
-lookupClassInstAtSimpleType clas ty
-  = case (lookupMEnv matchTy (getClassInstEnv clas) ty) of
-      Nothing				   -> Nothing
-      Just (_,_,MkInstTemplate dict [] []) -> Just dict
-\end{code}
-
-Notice in the above that the type constructors in the default list
-should all have arity zero, so there should be no type variables
-or thetas in the instance declaration.
-
-There's yet a third interface for Insts which need no binding.
-They are used to record constraints on type variables, notably
-for CCall arguments and results.
-
-\begin{code}
-lookupNoBindInst :: SplitUniqSupply
-	         -> Inst
-	         -> Maybe [Inst]
-
-lookupNoBindInst uniqs (Dict _ clas ty orig)
-  = if isTyVarTy ty then
-	Nothing	-- No instances of a class at a type variable
-    else
-      case (lookupMEnv matchTy inst_env ty) of
-	Nothing		    -> Nothing
-	Just (_,tenv,templ) ->
-	  case (instTemplate uniqs orig tenv templ) of
-	    (bottom_rhs, insts)
-	      -> Just insts
-		-- The idea here is that the expression built by
-		-- instTemplate isn't relevant; indeed, it might well
-		-- be a place-holder bottom value.
-  where
-    inst_env = getClassInstEnv clas
-\end{code}
-
-\begin{code}
-mkInstSpecEnv :: Class			-- class
-	      -> UniType		-- instance type
-	      -> [TyVarTemplate]	-- instance tyvars
-	      -> ThetaType		-- superclasses dicts
-	      -> SpecEnv		-- specenv for dfun of instance
-
-mkInstSpecEnv clas inst_ty inst_tvs inst_theta
-  = mkSpecEnv (catMaybes (map maybe_spec_info matches))
-  where
-    matches = matchMEnv matchTy (getClassInstEnv clas) inst_ty
-
-    maybe_spec_info (_, match_info, MkInstTemplate dfun _ [])
-      = Just (SpecInfo (map (assocMaybe match_info) inst_tvs) (length inst_theta) dfun)
-    maybe_spec_info (_, match_info, _)
-      = Nothing
-
-\end{code}
-
-%************************************************************************
-%*									*
-\subsection[MatchEnv]{Matching environments}
-%*									*
-%************************************************************************
-
-``Matching'' environments allow you to bind a template to a value;
-when you look up in it, you supply a value which is matched against
-the template.
-
-\begin{code}
-type MatchEnv key value = [(key, value)]
-\end{code}
-
-For now we just use association lists.	The list is maintained sorted
-in order of {\em decreasing specificness} of @key@, so that the first
-match will be the most specific.
-
-\begin{code}
-nullMEnv :: MatchEnv a b
-nullMEnv = []
-
-mkMEnv :: [(key, value)] -> MatchEnv key value
-mkMEnv stuff = stuff
-\end{code}
-
-@lookupMEnv@ looks up in a @MatchEnv@.
-It simply takes the first match, should be the most specific.
-
-\begin{code}
-lookupMEnv :: (key {- template -} ->	-- Matching function
-	       key {- instance -} ->
-	       Maybe match_info)
-	   -> MatchEnv key value	-- The envt
-	   -> key			-- Key
-	   -> Maybe (key,		-- Template
-		     match_info,	-- Match info returned by matching fn
-		     value)		-- Value
-
-lookupMEnv key_match alist key
-  = find alist
-  where
-    find [] = Nothing
-    find ((tpl, val) : rest)
-      = case key_match tpl key of
-	  Nothing	  -> find rest
-	  Just match_info -> Just (tpl, match_info, val)
-\end{code}
-
-@matchEnv@ returns all more specidfic matches in a @MatchEnv@,
-most specific first.
-
-\begin{code}
-matchMEnv :: (key {- template -} ->	-- Matching function
-	      key {- instance -} ->
-	      Maybe match_info)
-	  -> MatchEnv key value		-- The envt
-	  -> key			-- Key
-	  -> [(key,
-	       match_info,		-- Match info returned by matching fn
-	       value)]			-- Value
-
-matchMEnv key_match alist key
-  = match alist
-  where
-    match [] = []
-    match ((tpl, val) : rest)
-      = case key_match tpl key of
-	  Nothing -> case key_match key tpl of
-		       Nothing         -> match rest
-		       Just match_info -> (tpl, match_info, val) : match rest 
-	  Just _  -> []
-\end{code}
-
-@insertMEnv@ extends a match environment, checking for overlaps.
-
-\begin{code}
-insertMEnv :: (key {- template -} ->		-- Matching function
-	       key {- instance -} ->
-	       Maybe match_info)
-	   -> MatchEnv key value		-- Envt
-	   -> key -> value			-- New item
-	   -> MaybeErr (MatchEnv key value)	-- Success...
-		       (key, value)		-- Failure: Offending overlap
-
-insertMEnv match_fn alist key value
-  = insert alist
-  where
-    -- insert has to put the new item in BEFORE any keys which are
-    -- LESS SPECIFIC than the new key, and AFTER any keys which are
-    -- MORE SPECIFIC The list is maintained in specific-ness order, so
-    -- we just stick it in either last, or just before the first key
-    -- of which the new key is an instance.  We check for overlap at
-    -- that point.
-
-    insert [] = returnMaB [(key, value)]
-    insert ((t,v) : rest)
-      = case (match_fn t key) of
-	  Nothing ->
-	    -- New key is not an instance of this existing one, so
-	    -- continue down the list.
-	    insert rest			`thenMaB` (\ rest' ->
-	    returnMaB ((t,v):rest') )
-
-	  Just match_info ->
-	    -- New key *is* an instance of the old one, so check the
-	    -- other way round in case of identity.
-
-	    case (match_fn key t) of
-	      Just _  -> failMaB (t,v)
-			 -- Oops; overlap
-
-	      Nothing -> returnMaB ((key,value):(t,v):rest)
-			 -- All ok; insert here
-\end{code}
diff --git a/ghc/compiler/envs/LIE.hi b/ghc/compiler/envs/LIE.hi
deleted file mode 100644
index 30118af18f..0000000000
--- a/ghc/compiler/envs/LIE.hi
+++ /dev/null
@@ -1,11 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface LIE where
-import Inst(Inst)
-data Inst 
-data LIE 
-mkLIE :: [Inst] -> LIE
-nullLIE :: LIE
-plusLIE :: LIE -> LIE -> LIE
-unMkLIE :: LIE -> [Inst]
-unitLIE :: Inst -> LIE
-
diff --git a/ghc/compiler/envs/LIE.lhs b/ghc/compiler/envs/LIE.lhs
deleted file mode 100644
index cd3e38cd62..0000000000
--- a/ghc/compiler/envs/LIE.lhs
+++ /dev/null
@@ -1,44 +0,0 @@
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1994
-%
-\section[LIE]{Id instance environment}
-
-This is not really an ``environment.''
-
-\begin{code}
-#include "HsVersions.h"
-
-module LIE (
-	LIE,		-- abstract type
-	mkLIE, nullLIE, unitLIE, unMkLIE, plusLIE,
-
-	-- imported things so this module's interface is self-contained
-	Inst
-    ) where
-
-import Inst		( Inst )
-import Outputable
-import Util
-\end{code}
-
-%************************************************************************
-%*									*
-\subsection[LIE-building]{Building LIEs}
-%*									*
-%************************************************************************
-
-\begin{code}
-data LIE = MkLIE [Inst]
-
-mkLIE = MkLIE
-
-nullLIE   = MkLIE []
-unitLIE x = MkLIE [x]
-
-unMkLIE :: LIE -> [Inst]
-unMkLIE (MkLIE insts) = insts
-
-plusLIE :: LIE -> LIE -> LIE
-plusLIE (MkLIE lie1) (MkLIE lie2)
-  = MkLIE (lie1 ++ lie2)
-\end{code}
diff --git a/ghc/compiler/envs/TCE.hi b/ghc/compiler/envs/TCE.hi
deleted file mode 100644
index cde124a525..0000000000
--- a/ghc/compiler/envs/TCE.hi
+++ /dev/null
@@ -1,30 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface TCE where
-import CharSeq(CSeq)
-import ErrUtils(Error(..))
-import Id(Id)
-import Maybes(MaybeErr)
-import Name(Name)
-import NameTypes(FullName, ShortName)
-import PreludePS(_PackedString)
-import Pretty(Delay, PprStyle, Pretty(..), PrettyRep)
-import SrcLoc(SrcLoc)
-import TyCon(TyCon)
-import UniqFM(UniqFM)
-import Unique(Unique)
-type Error = PprStyle -> Int -> Bool -> PrettyRep
-data MaybeErr a b 
-data Name 
-type Pretty = Int -> Bool -> PrettyRep
-data PrettyRep 
-data SrcLoc 
-type TCE = UniqFM TyCon
-data TyCon 
-data UniqFM a 
-checkTypeCycles :: UniqFM TyCon -> MaybeErr () (PprStyle -> Int -> Bool -> PrettyRep)
-lookupTCE :: UniqFM TyCon -> Name -> TyCon
-nullTCE :: UniqFM TyCon
-plusTCE :: UniqFM TyCon -> UniqFM TyCon -> UniqFM TyCon
-rngTCE :: UniqFM TyCon -> [TyCon]
-unitTCE :: Unique -> TyCon -> UniqFM TyCon
-
diff --git a/ghc/compiler/envs/TCE.lhs b/ghc/compiler/envs/TCE.lhs
deleted file mode 100644
index aac6057bcf..0000000000
--- a/ghc/compiler/envs/TCE.lhs
+++ /dev/null
@@ -1,110 +0,0 @@
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
-%
-\section[TCE]{Type constructor environment}
-
-\begin{code}
-#include "HsVersions.h"
-
-module TCE (
-	TCE(..), UniqFM,
-	nullTCE, unitTCE,
-	rngTCE,
-	lookupTCE,
-	plusTCE, checkTypeCycles,
--- NOT REALLY USED: printTypeInfoForPop,
-
-	-- and to make the interface self-sufficient...
-	MaybeErr, Name, TyCon,
-	Error(..), SrcLoc, Pretty(..), PrettyRep
-
-	IF_ATTACK_PRAGMAS(COMMA emptyUFM COMMA plusUFM)
-	IF_ATTACK_PRAGMAS(COMMA eltsUFM  COMMA singletonDirectlyUFM)
-	IF_ATTACK_PRAGMAS(COMMA u2i)
-   ) where
-
-import AbsUniType	( getMentionedTyCons, isDataTyCon, getTyConDataCons,
-			  TyCon, Arity(..), Class, UniType
-			  IF_ATTACK_PRAGMAS(COMMA cmpTyCon COMMA cmpClass)
-			  IF_ATTACK_PRAGMAS(COMMA cmpUniType)
-			)
-import Digraph		( topologicalSort )
-import Errors		-- notably typeCycleErr
-import Id		( getDataConArity, Id, DataCon(..) )
-import Maybes		( Maybe(..), MaybeErr(..) )
-import Name
-import Outputable
-import Pretty
-import UniqFM		-- basic environment handling
-import Unique		( Unique )
-import Util
-\end{code}
-
-\begin{code}
---data TCE = MkTCE (UniqFM TyCon)
-type TCE = UniqFM TyCon
-#define MkTCE {--}
--- also killed instance TCE, exported non-abstractly
-
-nullTCE :: TCE
-nullTCE = MkTCE emptyUFM
-
-unitTCE :: Unique -> TyCon -> TCE
-unitTCE uniq tycon = MkTCE (singletonDirectlyUFM uniq tycon)
-
-rngTCE :: TCE -> [TyCon]
-rngTCE (MkTCE tce) = eltsUFM tce
-
-lookupTCE :: TCE -> Name -> TyCon
-lookupTCE (MkTCE tce) name
-  = case name of
-      WiredInTyCon tycon       -> tycon
-      PreludeTyCon key _ _ _   -> case (lookupDirectlyUFM tce key) of
-				    Just tycon -> tycon
-				    Nothing    -> err_msg
-      OtherTyCon uniq _ _ _ _  -> case (lookupDirectlyUFM tce uniq) of
-				    Just tycon -> tycon
-				    Nothing    -> err_msg
-  where
-    err_msg = error ("ERROR: in looking up a type constructor! "++(ppShow 80 (ppr PprDebug name))++"\n(This can happen if you use `-fno-implicit-prelude'\nor you hide or change the system's Prelude.hi in some way.\nA -fhaskell-1.3 flag, or lack thereof, can trigger this error.)\n")
-
-plusTCE :: TCE -> TCE -> TCE
-plusTCE (MkTCE tce1) (MkTCE tce2) = MkTCE (plusUFM tce1 tce2)
-\end{code}
-
-\begin{code}
-checkTypeCycles :: TCE -> MaybeErr () Error
-checkTypeCycles tce
- = case (topologicalSort (==) edges vertices) of
-    Succeeded ordering -> Succeeded ()
-    Failed cycles
-         -> Failed (typeCycleErr (map (\ c -> map fmt_tycon c) cycles))
-	      where
-		fmt_tycon c = (ppr PprForUser c, getSrcLoc c)
-   where
-   vertices = [ vertex1 | (vertex1, vertex2) <- edges]
-   edges = concat (map get_edges (rngTCE tce))
-	    where
-	    get_edges tycon = [(tycon, dep) | dep <- getMentionedTyCons tycon]
-		-- Make an arc for every dependency
-\end{code}
-
-\begin{code}
-{- NOT REALLY USED:
-printTypeInfoForPop :: TCE -> Pretty
-
-printTypeInfoForPop (MkTCE tce)
-  = ppAboves [ pp_type tc | tc <- eltsUFM tce, isDataTyCon tc ]
-  where
-    pp_type tycon
-      = ppBesides [
-	    ppStr "data ",
-	    ppr PprForUser tycon, ppSP,
-	    ppInterleave ppSP (map pp_data_con (getTyConDataCons tycon)),
-	    ppSemi
-    	]
-      where
-	pp_data_con data_con
-	  = ppCat [ppr PprForUser data_con, ppInt (getDataConArity data_con)]
--}
-\end{code}
diff --git a/ghc/compiler/envs/TVE.hi b/ghc/compiler/envs/TVE.hi
deleted file mode 100644
index 4edf8d558d..0000000000
--- a/ghc/compiler/envs/TVE.hi
+++ /dev/null
@@ -1,25 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface TVE where
-import Id(Id)
-import Maybes(Labda)
-import Name(Name)
-import NameTypes(FullName, ShortName)
-import PreludePS(_PackedString)
-import TyCon(TyCon)
-import TyVar(TyVarTemplate)
-import UniType(UniType)
-import UniqFM(UniqFM)
-import Unique(Unique)
-data Labda a 
-data Name 
-type TVE = UniqFM UniType
-data TyVarTemplate 
-data UniType 
-data UniqFM a 
-lookupTVE :: UniqFM UniType -> Name -> UniType
-lookupTVE_NoFail :: UniqFM a -> Name -> Labda a
-mkTVE :: [Name] -> (UniqFM UniType, [TyVarTemplate], [UniType])
-nullTVE :: UniqFM UniType
-plusTVE :: UniqFM UniType -> UniqFM UniType -> UniqFM UniType
-unitTVE :: Unique -> a -> UniqFM a
-
diff --git a/ghc/compiler/envs/TVE.lhs b/ghc/compiler/envs/TVE.lhs
deleted file mode 100644
index ab927df407..0000000000
--- a/ghc/compiler/envs/TVE.lhs
+++ /dev/null
@@ -1,74 +0,0 @@
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1994
-%
-\section[TVE]{Type variable environment}
-
-This environment is not part of the big one that is carried around
-monadically.
-
-\begin{code}
-#include "HsVersions.h"
-
-module TVE (
-	TVE(..), UniqFM,
-
-	mkTVE, nullTVE, unitTVE,
-	lookupTVE, lookupTVE_NoFail, plusTVE,
-
-	-- and to make the interface self-sufficient...
-	Maybe, Name, TyVarTemplate, UniType
-
-	IF_ATTACK_PRAGMAS(COMMA emptyUFM COMMA plusUFM)
-	IF_ATTACK_PRAGMAS(COMMA eltsUFM  COMMA singletonDirectlyUFM)
-	IF_ATTACK_PRAGMAS(COMMA u2i)
-    ) where
-
-import AbsUniType	( mkUserTyVarTemplate, mkTyVarTemplateTy,
-			  getTyVar, TyVarTemplate, TyVar, Class,
-			  ClassOp, Arity(..), TyCon,
-			  TauType(..), UniType
-			  IF_ATTACK_PRAGMAS(COMMA cmpTyCon COMMA cmpClass)
-			  IF_ATTACK_PRAGMAS(COMMA cmpTyVar)
-			  IF_ATTACK_PRAGMAS(COMMA cmpUniType)
-			)
-import Maybes		( Maybe(..), MaybeErr(..) )
-import Name
-import Outputable	-- def of ppr
-import Pretty		-- to pretty-print error messages
-import UniqFM		-- basic environment handling
-import Unique		( Unique )
-import Util
-\end{code}
-
-\begin{code}
-type TVE = UniqFM UniType
-#define MkTVE {--}
--- also: export non-abstractly
-
-mkTVE :: [Name] -> (TVE, [TyVarTemplate], [TauType])
-mkTVE names
-  = case (unzip3 (map mk_tve_one names)) of { (env, tyvars, tys) ->
-    (MkTVE (listToUFM_Directly env), tyvars, tys) }
-  where
-    mk_tve_one (Short uniq short_name)
-      = case (mkUserTyVarTemplate uniq short_name)  of { tyvar ->
-	case (mkTyVarTemplateTy tyvar)		    of { ty ->
-    	((uniq, ty), tyvar, ty) }}
-
-nullTVE :: TVE
-nullTVE = MkTVE emptyUFM
-
-unitTVE u ty = MkTVE (singletonDirectlyUFM u ty)
-
-lookupTVE :: TVE -> Name -> UniType
-lookupTVE (MkTVE tve) (Short uniq short_name)
- = case (lookupDirectlyUFM tve uniq) of
-     Just ty -> ty
-     Nothing -> panic "lookupTVE!"
-
-lookupTVE_NoFail (MkTVE tve) (Short uniq short_name)
- = lookupDirectlyUFM tve uniq
-
-plusTVE :: TVE -> TVE -> TVE
-plusTVE (MkTVE tve1) (MkTVE tve2) = MkTVE (plusUFM tve1 tve2)
-\end{code}
diff --git a/ghc/compiler/envs/TyVarEnv.hi b/ghc/compiler/envs/TyVarEnv.hi
deleted file mode 100644
index 5ceec0629d..0000000000
--- a/ghc/compiler/envs/TyVarEnv.hi
+++ /dev/null
@@ -1,20 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface TyVarEnv where
-import Maybes(Labda(..))
-import TyVar(TyVar)
-import UniType(UniType)
-import UniqFM(UniqFM)
-import Unique(Unique)
-data Labda a   = Hamna | Ni a
-data TyVar 
-type TyVarEnv a = UniqFM a
-type TypeEnv = UniqFM UniType
-data UniqFM a 
-data Unique 
-addOneToTyVarEnv :: UniqFM a -> TyVar -> a -> UniqFM a
-growTyVarEnvList :: UniqFM a -> [(TyVar, a)] -> UniqFM a
-isNullTyVarEnv :: UniqFM a -> Bool
-lookupTyVarEnv :: UniqFM a -> TyVar -> Labda a
-mkTyVarEnv :: [(TyVar, a)] -> UniqFM a
-nullTyVarEnv :: UniqFM a
-
diff --git a/ghc/compiler/envs/TyVarEnv.lhs b/ghc/compiler/envs/TyVarEnv.lhs
deleted file mode 100644
index 421b4a2121..0000000000
--- a/ghc/compiler/envs/TyVarEnv.lhs
+++ /dev/null
@@ -1,71 +0,0 @@
-%
-% (c) The AQUA Project, Glasgow University, 1994
-%
-\section[TyVarEnv]{Lookup tables that have @TyVar@ keys}
-
-An interface to the @FiniteMap@ machinery, which exports
-a ``personality'' the same as that of the old @TyVarEnv@ module.
-
-\begin{code}
-#include "HsVersions.h"
-
-module TyVarEnv (
-	TyVarEnv(..),  -- abstract: NOT
-
-	TypeEnv(..),	-- most common/important kind of TyVarEnv
-
-	mkTyVarEnv,
-	lookupTyVarEnv,
-	nullTyVarEnv, growTyVarEnvList,
-	isNullTyVarEnv,
-	addOneToTyVarEnv,
-
-	-- and to make the interface self-sufficient...
-	UniqFM,
-	TyVar, Unique, Maybe(..)
-	
-#ifdef USE_ATTACK_PRAGMAS
-	, addToUFM, plusUFM_C, delListFromUFM, delFromUFM, plusUFM,
-	lookupUFM, mapUFM, minusUFM, listToUFM, emptyUFM, eltsUFM,
-	singletonUFM,
-	u2i
-#endif
-    ) where
-
-import AbsUniType
-import UniqFM
-import Maybes		( Maybe(..) )
-import Outputable
-import Unique		( Unique, u2i )
-import Util
-\end{code}
-
-\begin{code}
-type TyVarEnv elt = UniqFM elt
-
-type TypeEnv = TyVarEnv UniType -- most common flavo(u)r
-\end{code}
-
-Signatures:
-\begin{code}
-mkTyVarEnv :: [(TyVar, a)] -> TyVarEnv a
-addOneToTyVarEnv :: TyVarEnv a -> TyVar -> a -> TyVarEnv a
-growTyVarEnvList :: TyVarEnv a -> [(TyVar, a)] -> TyVarEnv a
-isNullTyVarEnv :: TyVarEnv a -> Bool
-lookupTyVarEnv :: TyVarEnv a -> TyVar -> Maybe a
-nullTyVarEnv :: TyVarEnv a
-\end{code}
-
-\begin{code}
-mkTyVarEnv stuff = listToUFM stuff
-
-addOneToTyVarEnv env id elt = addToUFM env id elt
-
-growTyVarEnvList env pairs = plusUFM env (listToUFM pairs)
-
-isNullTyVarEnv env = sizeUFM env == 0
-
-lookupTyVarEnv env id = lookupUFM env id
-
-nullTyVarEnv = emptyUFM
-\end{code}
diff --git a/ghc/compiler/hsSyn/HsBinds.lhs b/ghc/compiler/hsSyn/HsBinds.lhs
new file mode 100644
index 0000000000..a01b198ab8
--- /dev/null
+++ b/ghc/compiler/hsSyn/HsBinds.lhs
@@ -0,0 +1,331 @@
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+%
+\section[HsBinds]{Abstract syntax: top-level bindings and signatures}
+
+Datatype for: @HsBinds@, @Bind@, @Sig@, @MonoBinds@.
+
+\begin{code}
+#include "HsVersions.h"
+
+module HsBinds where
+
+import Ubiq{-uitous-}
+
+-- friends:
+import HsLoop
+
+import HsMatches	( pprMatches, pprGRHSsAndBinds,
+			  Match, GRHSsAndBinds
+			)
+import HsPat		( collectPatBinders, InPat )
+import HsPragmas	( GenPragmas, ClassOpPragmas )
+import HsTypes		( PolyType )
+
+--others:
+import Id		( DictVar(..), Id(..), GenId )
+import Outputable
+import PprType		( pprType )
+import Pretty
+import SrcLoc		( SrcLoc{-instances-} )
+import TyVar		( GenTyVar{-instances-} )
+\end{code}
+
+%************************************************************************
+%*									*
+\subsection{Bindings: @HsBinds@}
+%*									*
+%************************************************************************
+
+The following syntax may produce new syntax which is not part of the input,
+and which is instead a translation of the input to the typechecker.
+Syntax translations are marked TRANSLATION in comments. New empty
+productions are useful in development but may not appear in the final
+grammar.
+
+Collections of bindings, created by dependency analysis and translation:
+
+\begin{code}
+data HsBinds tyvar uvar id pat		-- binders and bindees
+  = EmptyBinds
+
+  | ThenBinds	(HsBinds tyvar uvar id pat)
+		(HsBinds tyvar uvar id pat)
+
+  | SingleBind	(Bind  tyvar uvar id pat)
+
+  | BindWith		-- Bind with a type signature.
+			-- These appear only on typechecker input
+			-- (PolyType [in Sigs] can't appear on output)
+		(Bind tyvar uvar id pat)
+		[Sig id]
+
+  | AbsBinds			-- Binds abstraction; TRANSLATION
+		[tyvar]
+		[id]		-- Dicts
+		[(id, id)]	-- (old, new) pairs
+		[(id, HsExpr tyvar uvar id pat)]	-- local dictionaries
+		(Bind tyvar uvar id pat)		-- "the business end"
+
+	-- Creates bindings for *new* (polymorphic, overloaded) locals
+	-- in terms of *old* (monomorphic, non-overloaded) ones.
+	--
+	-- See section 9 of static semantics paper for more details.
+	-- (You can get a PhD for explaining the True Meaning
+	--  of this last construct.)
+\end{code}
+
+\begin{code}
+nullBinds :: HsBinds tyvar uvar id pat -> Bool
+
+nullBinds EmptyBinds		= True
+nullBinds (ThenBinds b1 b2)	= nullBinds b1 && nullBinds b2
+nullBinds (SingleBind b)	= nullBind b
+nullBinds (BindWith b _)	= nullBind b
+nullBinds (AbsBinds _ _ _ ds b)	= null ds && nullBind b
+\end{code}
+
+\begin{code}
+instance (Outputable pat, NamedThing id, Outputable id,
+	  Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar) =>
+		Outputable (HsBinds tyvar uvar id pat) where
+
+    ppr sty EmptyBinds = ppNil
+    ppr sty (ThenBinds binds1 binds2)
+     = ppAbove (ppr sty binds1) (ppr sty binds2)
+    ppr sty (SingleBind bind) = ppr sty bind
+    ppr sty (BindWith bind sigs)
+     = ppAbove (if null sigs 
+		then ppNil
+		else ppAboves (map (ppr sty) sigs))
+	       (ppr sty bind)
+    ppr sty (AbsBinds tyvars dictvars local_pairs dict_binds val_binds)
+     = ppAbove (ppSep [ppPStr SLIT("AbsBinds"),
+		      ppBesides[ppLbrack, interpp'SP sty tyvars, ppRbrack],
+		      ppBesides[ppLbrack, interpp'SP sty dictvars, ppRbrack],
+		      ppBesides[ppLbrack, interpp'SP sty local_pairs, ppRbrack]])
+	    (ppNest 4 (ppAbove (ppAboves (map (ppr sty) dict_binds)) (ppr sty val_binds)))
+\end{code}
+
+%************************************************************************
+%*									*
+\subsection{@Sig@: type signatures and value-modifying user pragmas}
+%*									*
+%************************************************************************
+
+It is convenient to lump ``value-modifying'' user-pragmas (e.g.,
+``specialise this function to these four types...'') in with type
+signatures.  Then all the machinery to move them into place, etc.,
+serves for both.
+
+\begin{code}
+data Sig name
+  = Sig		name		-- a bog-std type signature
+		(PolyType name)
+		(GenPragmas name) -- only interface ones have pragmas
+		SrcLoc
+
+  | ClassOpSig	name		-- class-op sigs have different pragmas
+		(PolyType name)
+		(ClassOpPragmas name)	-- only interface ones have pragmas
+		SrcLoc
+
+  | SpecSig 	name		-- specialise a function or datatype ...
+		(PolyType 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
+
+  | MagicUnfoldingSig
+		name		-- Associate the "name"d function with
+		FAST_STRING	-- the compiler-builtin unfolding (known
+		SrcLoc		-- by the String name)
+\end{code}
+
+\begin{code}
+instance (NamedThing name, Outputable name) => Outputable (Sig name) where
+    ppr sty (Sig var ty pragmas _)
+      = ppHang (ppCat [pprNonOp sty var, ppPStr SLIT("::")])
+	     4 (ppHang (ppr sty ty)
+		     4 (ifnotPprForUser sty (ppr sty pragmas)))
+
+    ppr sty (ClassOpSig var ty pragmas _)
+      = ppHang (ppCat [pprNonOp sty var, ppPStr SLIT("::")])
+	     4 (ppHang (ppr sty ty)
+		     4 (ifnotPprForUser sty (ppr sty pragmas)))
+
+    ppr sty (DeforestSig var _)
+      = ppHang (ppCat [ppStr "{-# DEFOREST", pprNonOp sty var])
+		   4 (ppStr "#-}")
+
+    ppr sty (SpecSig var ty using _)
+      = ppHang (ppCat [ppPStr SLIT("{-# SPECIALIZE"), pprNonOp sty var, ppPStr SLIT("::")])
+	     4 (ppCat [ppr sty ty, pp_using using, ppPStr SLIT("#-}")])
+      where
+	pp_using Nothing   = ppNil
+	pp_using (Just me) = ppCat [ppChar '=', ppr sty me]
+
+    ppr sty (InlineSig var _)
+      = ppCat [ppPStr SLIT("{-# INLINE"), pprNonOp sty var, ppPStr SLIT("#-}")]
+
+    ppr sty (MagicUnfoldingSig var str _)
+      = ppCat [ppPStr SLIT("{-# MAGIC_UNFOLDING"), pprNonOp sty var, ppPStr str, ppPStr SLIT("#-}")]
+\end{code}
+
+%************************************************************************
+%*									*
+\subsection{Binding: @Bind@}
+%*									*
+%************************************************************************
+
+\begin{code}
+data Bind tyvar uvar id pat		-- binders and bindees
+  = EmptyBind	-- because it's convenient when parsing signatures
+  | NonRecBind	(MonoBinds tyvar uvar id pat)
+  | RecBind	(MonoBinds tyvar uvar id pat)
+\end{code}
+
+\begin{code}
+nullBind :: Bind tyvar uvar id pat -> Bool
+
+nullBind EmptyBind	 = True
+nullBind (NonRecBind bs) = nullMonoBinds bs
+nullBind (RecBind bs)	 = nullMonoBinds bs
+\end{code}
+
+\begin{code}
+bindIsRecursive :: Bind tyvar uvar id pat -> Bool
+
+bindIsRecursive EmptyBind	= False
+bindIsRecursive (NonRecBind _)	= False
+bindIsRecursive (RecBind _)	= True
+\end{code}
+
+\begin{code}
+instance (NamedThing id, Outputable id, Outputable pat,
+	  Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar) =>
+		Outputable (Bind tyvar uvar id pat) where
+    ppr sty EmptyBind = ppNil
+    ppr sty (NonRecBind binds)
+     = ppAbove (ifnotPprForUser sty (ppStr "{- nonrec -}"))
+	       (ppr sty binds)
+    ppr sty (RecBind binds)
+     = ppAbove (ifnotPprForUser sty (ppStr "{- rec -}"))
+	       (ppr sty binds)
+\end{code}
+
+%************************************************************************
+%*									*
+\subsection{Bindings: @MonoBinds@}
+%*									*
+%************************************************************************
+
+Global bindings (where clauses)
+
+\begin{code}
+data MonoBinds tyvar uvar id pat
+  = EmptyMonoBinds
+  | AndMonoBinds    (MonoBinds tyvar uvar id pat)
+		    (MonoBinds tyvar uvar id pat)
+  | PatMonoBind     pat
+		    (GRHSsAndBinds tyvar uvar id pat)
+		    SrcLoc
+  | FunMonoBind     id
+		    [Match tyvar uvar id pat]	-- must have at least one Match
+		    SrcLoc
+  | VarMonoBind	    id			-- TRANSLATION
+		    (HsExpr tyvar uvar id pat)
+\end{code}
+
+\begin{code}
+nullMonoBinds :: MonoBinds tyvar uvar id pat -> Bool
+
+nullMonoBinds EmptyMonoBinds	     = True
+nullMonoBinds (AndMonoBinds bs1 bs2) = nullMonoBinds bs1 && nullMonoBinds bs2
+nullMonoBinds other_monobind	     = False
+\end{code}
+
+\begin{code}
+instance (NamedThing id, Outputable id, Outputable pat,
+	  Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar) =>
+		Outputable (MonoBinds tyvar uvar id pat) where
+    ppr sty EmptyMonoBinds = ppNil
+    ppr sty (AndMonoBinds binds1 binds2)
+      = ppAbove (ppr sty binds1) (ppr sty binds2)
+
+    ppr sty (PatMonoBind pat grhss_n_binds locn)
+      = ppHang (ppr sty pat) 4 (pprGRHSsAndBinds sty False grhss_n_binds)
+
+    ppr sty (FunMonoBind fun matches locn)
+      = pprMatches sty (False, pprNonOp sty fun) matches
+
+    ppr sty (VarMonoBind name expr)
+      = ppHang (ppCat [pprNonOp sty name, ppEquals]) 4 (ppr sty expr)
+\end{code}
+
+%************************************************************************
+%*									*
+\subsection{Collecting binders from @HsBinds@}
+%*									*
+%************************************************************************
+
+Get all the binders in some @MonoBinds@, IN THE ORDER OF
+APPEARANCE; e.g., in:
+\begin{verbatim}
+...
+where
+  (x, y) = ...
+  f i j  = ...
+  [a, b] = ...
+\end{verbatim}
+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 	      = []
+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 (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
+\end{code}
diff --git a/ghc/compiler/hsSyn/HsCore.lhs b/ghc/compiler/hsSyn/HsCore.lhs
new file mode 100644
index 0000000000..08bce62fbd
--- /dev/null
+++ b/ghc/compiler/hsSyn/HsCore.lhs
@@ -0,0 +1,342 @@
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1993-1996
+%
+%************************************************************************
+%*									*
+\section[HsCore]{Core-syntax unfoldings in Haskell interface files}
+%*									*
+%************************************************************************
+
+We could either use this, or parameterise @GenCoreExpr@ on @Types@ and
+@TyVars@ as well.  Currently trying the former.
+
+\begin{code}
+#include "HsVersions.h"
+
+module HsCore (
+	-- types:
+	UnfoldingCoreExpr(..), UnfoldingCoreAlts(..),
+	UnfoldingCoreDefault(..), UnfoldingCoreBinding(..),
+	UnfoldingCoreAtom(..), UfId(..), UnfoldingType(..),
+	UnfoldingPrimOp(..), UfCostCentre(..),
+
+	-- function:
+	eqUfExpr
+    ) where
+
+import Ubiq{-uitous-}
+
+-- friends:
+import HsTypes		( cmpPolyType, MonoType(..), PolyType(..) )
+import PrimOp		( PrimOp, tagOf_PrimOp )
+
+-- others:
+import Literal		( Literal )
+import Outputable	( Outputable(..) {-instances-} )
+import Pretty
+import ProtoName	( cmpProtoName, eqProtoName, ProtoName )
+import Util		( panic )
+\end{code}
+
+%************************************************************************
+%*									*
+\subsection[HsCore-types]{Types for read/written Core unfoldings}
+%*									*
+%************************************************************************
+
+\begin{code}
+data UnfoldingCoreExpr name
+  = UfVar 	(UfId 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
+  = UfCCallOp	FAST_STRING	     -- callee
+		Bool		     -- True <=> casm, rather than ccall
+		Bool		     -- True <=> might cause GC
+		[UnfoldingType 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
+\end{code}
+
+%************************************************************************
+%*									*
+\subsection[HsCore-print]{Printing Core unfoldings}
+%*									*
+%************************************************************************
+
+\begin{code}
+instance Outputable name => Outputable (UnfoldingCoreExpr name) where
+    ppr sty (UfVar v) = pprUfId 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 (UfLam bs body)
+      = ppCat [ppChar '\\', ppr sty bs, ppStr "->", ppr sty body]
+
+    ppr sty (UfApp fun arg)
+      = ppCat [ppStr "(UfApp", ppr sty fun, ppr sty arg, ppStr ")"]
+
+    ppr sty (UfCase scrut alts)
+      = ppCat [ppStr "case", ppr sty scrut, ppStr "of {", pp_alts alts, ppStr "}"]
+      where
+    	pp_alts (UfCoAlgAlts 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)
+	  = 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]
+
+    ppr sty (UfLet (UfCoNonRec b rhs) body)
+      = ppCat [ppStr "let", ppr sty b, ppEquals, ppr sty rhs, ppStr "in", ppr sty body]
+    ppr sty (UfLet (UfCoRec 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]
+
+    ppr sty (UfSCC uf_cc body)
+      = ppCat [ppStr "_scc_ <cost-centre[ToDo]>", ppr sty body]
+
+instance Outputable name => Outputable (UnfoldingPrimOp 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]
+    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 ")"]
+\end{code}
+
+%************************************************************************
+%*									*
+\subsection[HsCore-equality]{Comparing Core unfoldings}
+%*									*
+%************************************************************************
+
+We want to check that they are {\em exactly} the same.
+
+\begin{code}
+--eqUfExpr :: ProtoNameCoreExpr -> ProtoNameCoreExpr -> Bool
+
+eqUfExpr (UfVar v1)     (UfVar v2)     = eqUfId v1 v2
+eqUfExpr (UfLit l1) (UfLit l2) = l1 == l2
+
+eqUfExpr (UfCon c1 tys1 as1) (UfCon c2 tys2 as2)
+  = eq_name c1 c2 && eq_lists eq_type tys1 tys2 && eq_lists eq_atom as1 as2
+eqUfExpr (UfPrim o1 tys1 as1) (UfPrim o2 tys2 as2)
+  = eq_op o1 o2 && eq_lists eq_type tys1 tys2 && eq_lists eq_atom as1 as2
+  where
+    eq_op (UfCCallOp _ _ _ _ _) (UfCCallOp _ _ _ _ _) = True
+    eq_op (UfOtherOp o1)        (UfOtherOp o2)
+      = tagOf_PrimOp o1 _EQ_ tagOf_PrimOp o2
+
+eqUfExpr (UfLam bs1 body1) (UfLam bs2 body2)
+  = eq_binder bs1 bs2 && eqUfExpr body1 body2
+
+eqUfExpr (UfApp fun1 arg1) (UfApp fun2 arg2)
+  = eqUfExpr fun1 fun2 && eq_atom arg1 arg2
+
+eqUfExpr (UfCase scrut1 alts1) (UfCase scrut2 alts2)
+  = eqUfExpr scrut1 scrut2 && eq_alts alts1 alts2
+  where
+    eq_alts (UfCoAlgAlts alts1 deflt1) (UfCoAlgAlts alts2 deflt2)
+      = eq_lists eq_alt alts1 alts2 && eq_deflt deflt1 deflt2
+      where
+       eq_alt (c1,bs1,rhs1) (c2,bs2,rhs2)
+	 = eq_name c1 c2 && eq_lists eq_binder bs1 bs2 && eqUfExpr rhs1 rhs2
+
+    eq_alts (UfCoPrimAlts alts1 deflt1) (UfCoPrimAlts alts2 deflt2)
+      = eq_lists eq_alt alts1 alts2 && eq_deflt deflt1 deflt2
+      where
+       eq_alt (l1,rhs1) (l2,rhs2)
+	 = l1 == l2 && eqUfExpr rhs1 rhs2
+
+    eq_alts _ _ = False -- catch-all
+
+    eq_deflt UfCoNoDefault UfCoNoDefault = True
+    eq_deflt (UfCoBindDefault b1 rhs1) (UfCoBindDefault b2 rhs2)
+      = eq_binder b1 b2 && eqUfExpr rhs1 rhs2
+    eq_deflt _ _ = False
+
+eqUfExpr (UfLet (UfCoNonRec b1 rhs1) body1) (UfLet (UfCoNonRec b2 rhs2) body2)
+  = eq_binder b1 b2 && eqUfExpr rhs1 rhs2 && eqUfExpr body1 body2
+
+eqUfExpr (UfLet (UfCoRec pairs1) body1) (UfLet (UfCoRec pairs2) body2)
+  = eq_lists eq_pair pairs1 pairs2 && eqUfExpr body1 body2
+  where
+    eq_pair (b1,rhs1) (b2,rhs2) = eq_binder b1 b2 && eqUfExpr rhs1 rhs2
+
+eqUfExpr (UfSCC cc1 body1) (UfSCC cc2 body2)
+  = {-trace "eqUfExpr: not comparing cost-centres!"-} (eqUfExpr body1 body2)
+
+eqUfExpr _ _ = False -- Catch-all
+\end{code}
+
+\begin{code}
+eqUfId (BoringUfId n1) (BoringUfId n2)
+  = eq_name n1 n2
+eqUfId (SuperDictSelUfId a1 b1) (SuperDictSelUfId a2 b2)
+  = eq_name a1 a2 && eq_name b1 b2
+eqUfId (ClassOpUfId a1 b1) (ClassOpUfId a2 b2)
+  = eq_name a1 a2 && eq_name b1 b2
+eqUfId (DictFunUfId c1 t1) (DictFunUfId c2 t2)
+  = eq_name c1 c2 && eq_tycon t1 t2 -- NB: **** only compare TyCons ******
+  where
+    eq_tycon = panic "HsCore:eqUfId:eq_tycon:ToDo"
+{- LATER:
+    eq_tycon (UnoverloadedTy ty1) (UnoverloadedTy ty2)
+      = case (cmpInstanceTypes ty1 ty2) of { EQ_ -> True; _ -> False }
+    eq_tycon ty1 ty2
+      = trace "eq_tycon" (eq_type ty1 ty2) -- desperately try something else
+-}
+
+eqUfId (ConstMethodUfId	a1 b1 t1) (ConstMethodUfId a2 b2 t2)
+  = eq_name a1 a2 && eq_name b1 b2 && eq_type t1 t2
+eqUfId (DefaultMethodUfId a1 b1) (DefaultMethodUfId a2 b2)
+  = eq_name a1 a2 && eq_name b1 b2
+eqUfId (SpecUfId id1 tms1) (SpecUfId id2 tms2)
+  = eqUfId id1 id2 && eq_lists eq_ty_maybe tms1 tms2
+  where
+    eq_ty_maybe = panic "HsCore:eqUfId:eq_ty_maybe:ToDo"
+{-
+    eq_ty_maybe Nothing Nothing = True
+    eq_ty_maybe (Just ty1) (Just ty2)
+      = eq_type (UnoverloadedTy ty1) (UnoverloadedTy ty2)
+      -- a HACKy way to compare MonoTypes (ToDo) [WDP 94/05/02]
+    eq_ty_maybe _ _ = False
+-}
+eqUfId (WorkerUfId id1) (WorkerUfId id2)
+  = eqUfId id1 id2
+eqUfId _ _ = False -- catch-all
+\end{code}
+
+\begin{code}
+eq_atom (UfCoVarAtom id1) (UfCoVarAtom id2) = eqUfId id1 id2
+eq_atom (UfCoLitAtom l1) (UfCoLitAtom l2) = l1 == l2
+eq_atom _ _ = False
+
+eq_binder (n1, ty1) (n2, ty2) = eq_name n1 n2 && eq_type ty1 ty2
+
+eq_name :: ProtoName -> ProtoName -> Bool
+eq_name pn1 pn2 = eqProtoName pn1 pn2 -- uses original names
+
+eq_type ty1 ty2
+  = case (cmpPolyType cmpProtoName ty1 ty2) of { EQ_ -> True; _ -> False }
+\end{code}
+
+\begin{code}
+eq_lists :: (a -> a -> Bool) -> [a] -> [a] -> Bool
+
+eq_lists eq [] [] = True
+eq_lists eq [] _  = False
+eq_lists eq _  [] = False
+eq_lists eq (x:xs) (y:ys) = eq x y && eq_lists eq xs ys
+\end{code}
diff --git a/ghc/compiler/hsSyn/HsDecls.lhs b/ghc/compiler/hsSyn/HsDecls.lhs
new file mode 100644
index 0000000000..dad1f5294d
--- /dev/null
+++ b/ghc/compiler/hsSyn/HsDecls.lhs
@@ -0,0 +1,339 @@
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+%
+\section[HsDecls]{Abstract syntax: global declarations}
+
+Definitions for: @FixityDecl@, @TyDecl@ and @ConDecl@, @ClassDecl@,
+@InstDecl@, @DefaultDecl@.
+
+\begin{code}
+#include "HsVersions.h"
+
+module HsDecls where
+
+import Ubiq{-uitous-}
+
+-- friends:
+import HsLoop		( nullMonoBinds, MonoBinds, Sig )
+import HsPragmas	( DataPragmas, ClassPragmas,
+			  InstancePragmas, ClassOpPragmas
+			)
+import HsTypes
+
+-- others:
+import Outputable
+import Pretty
+import ProtoName	( cmpProtoName, ProtoName )
+import SrcLoc		( SrcLoc )
+import Util		( cmpList, panic#{-ToDo:rm eventually-} )
+\end{code}
+
+%************************************************************************
+%*									*
+\subsection[FixityDecl]{A fixity declaration}
+%*									*
+%************************************************************************
+
+These are only used in generating interfaces at the moment.  They are
+not used in pretty-printing.
+
+\begin{code}
+data FixityDecl name
+  = InfixL	name Int
+  | InfixR	name Int
+  | InfixN	name Int
+\end{code}
+
+\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
+
+print_it sty suff prec var
+  = ppBesides [ppStr "infix", ppStr suff, ppSP, ppInt prec, ppSP, pprOp sty var]
+\end{code}
+
+%************************************************************************
+%*									*
+\subsection[TyDecl]{@data@, @newtype@ or @type@ (synonym) type declaration}
+%*									*
+%************************************************************************
+
+\begin{code}
+data TyDecl name
+  = TyData	(Context name)	-- context
+		name		-- type constructor
+		[name]		-- type variables
+		[ConDecl name]	-- data constructors (empty if abstract)
+		(Maybe [name])	-- derivings; Nothing => not specified
+				-- (i.e., derive default); Just [] => derive
+				-- *nothing*; Just <list> => as you would
+				-- expect...
+		(DataPragmas name)
+		SrcLoc
+
+  | TyNew	(Context name)	-- context
+		name		-- type constructor
+		[name]		-- type variables
+		[ConDecl name]	-- data constructor (empty if abstract)
+		(Maybe [name])	-- derivings; as above
+		(DataPragmas name)
+		SrcLoc
+
+  | TySynonym	name		-- type constructor
+		[name]		-- type variables
+		(MonoType name)	-- synonym expansion
+		SrcLoc
+
+\end{code}
+
+\begin{code}
+instance (NamedThing name, Outputable name)
+	      => Outputable (TyDecl name) where
+
+    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])
+
+    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_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)
+		  derivings
+
+pp_decl_head sty str pp_context tycon tyvars
+  = ppCat [ppPStr str, pp_context, ppr sty tycon, interppSP sty tyvars]
+
+pp_condecls sty [] = ppNil -- abstract datatype
+pp_condecls sty (c:cs)
+  = ppSep (ppBeside (ppStr "= ") (ppr sty c)
+	   : map (\ x -> ppBeside (ppStr "| ") (ppr sty x)) 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)))])
+\end{code}
+
+A type for recording what types a datatype should be specialised to.
+It's called a ``Sig'' because it's sort of like a ``type signature''
+for an datatype declaration.
+
+\begin{code}
+data SpecDataSig name
+  = SpecDataSig name		-- tycon to specialise
+		(MonoType name)
+		SrcLoc
+
+instance (NamedThing name, Outputable name)
+	      => Outputable (SpecDataSig name) where
+
+    ppr sty (SpecDataSig tycon ty _)
+      = ppCat [ppStr "{-# SPECIALIZE data", ppr sty ty, ppStr "#-}"]
+\end{code}
+
+%************************************************************************
+%*									*
+\subsection[ConDecl]{A data-constructor declaration}
+%*									*
+%************************************************************************
+
+\begin{code}
+data ConDecl name
+  = ConDecl	name		-- prefix-style con decl
+		[BangType name]
+		SrcLoc
+
+  | ConOpDecl	(BangType name)	-- infix-style con decl
+		name
+		(BangType name)
+		SrcLoc
+
+  | RecConDecl	name
+		[(name, BangType name)]	-- list of "fields"
+		SrcLoc
+
+  | NewConDecl  name		-- newtype con decl
+		(MonoType name)
+		SrcLoc
+
+data BangType name
+  = Banged   (MonoType name)
+  | Unbanged (MonoType name)
+\end{code}
+
+In checking interfaces, we need to ``compare'' @ConDecls@.  Use with care!
+\begin{code}
+eqConDecls cons1 cons2
+  = case (cmpList cmp cons1 cons2) of { EQ_ -> True; _ -> False }
+  where
+    cmp (ConDecl n1 tys1 _) (ConDecl n2 tys2 _)
+      = case cmpProtoName n1 n2 of
+	  EQ_ -> cmpList cmp_bang_ty tys1 tys2
+	  xxx -> xxx
+    cmp (ConOpDecl _ _ _ _) _  = panic# "eqConDecls:ConOpDecl"
+    cmp (RecConDecl _ _ _)  _  = panic# "eqConDecls:RecConDecl"
+    cmp (NewConDecl _ _ _)  _  = panic# "eqConDecls:NewConDecl"
+    -------------
+
+    cmp_ty = cmpMonoType cmpProtoName
+    -------------
+    cmp_bang_ty (Banged   ty1) (Banged   ty2) = cmp_ty ty1 ty2
+    cmp_bang_ty (Unbanged ty1) (Unbanged ty2) = cmp_ty ty1 ty2
+    cmp_bang_ty (Banged   _)   _	      = LT_
+    cmp_bang_ty _	       _	      = GT_
+\end{code}
+
+\begin{code}
+instance (NamedThing name, Outputable name) => Outputable (ConDecl name) where
+
+    ppr sty (ConDecl con tys _)
+      = ppCat [pprNonOp sty con, ppInterleave ppNil (map (ppr_bang sty) tys)]
+    ppr sty (ConOpDecl ty1 op ty2 _)
+      = ppCat [ppr_bang sty ty1, pprOp sty op, ppr_bang sty ty2]
+    ppr sty (NewConDecl con ty _)
+      = ppCat [pprNonOp sty con, pprParendMonoType sty ty]
+    ppr sty (RecConDecl con fields _)
+      = ppCat [pprNonOp sty con, ppChar '{',
+	       ppInterleave pp'SP (map pp_field fields), ppChar '}']
+      where
+	pp_field (n, ty) = ppCat [ppr sty n, ppPStr SLIT("::"), ppr_bang sty ty]
+
+ppr_bang sty (Banged   ty) = ppBeside (ppChar '!') (pprParendMonoType sty ty)
+ppr_bang sty (Unbanged ty) = pprParendMonoType sty ty
+\end{code}
+
+%************************************************************************
+%*									*
+\subsection[ClassDecl]{A class declaration}
+%*									*
+%************************************************************************
+
+\begin{code}
+data ClassDecl tyvar uvar name pat
+  = ClassDecl	(Context name)	    		-- context...
+		name		    		-- name of the class
+		name		    		-- the class type variable
+		[Sig name]			-- methods' signatures
+		(MonoBinds tyvar uvar name pat)	-- default methods
+		(ClassPragmas name)
+		SrcLoc
+\end{code}
+
+\begin{code}
+instance (NamedThing name, Outputable name, Outputable pat,
+	  Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar)
+		=> Outputable (ClassDecl tyvar uvar name pat) where
+
+    ppr sty (ClassDecl context clas tyvar sigs methods pragmas src_loc)
+     = ppAboves [ppCat [ppStr "class", pprContext sty context, ppr sty clas,
+			ppr sty tyvar, ppStr "where"],
+			-- ToDo: really shouldn't print "where" unless there are sigs
+		 ppNest 4 (ppAboves (map (ppr sty) sigs)),
+		 ppNest 4 (ppr sty methods),
+		 ppNest 4 (ppr sty pragmas)]
+\end{code}
+
+%************************************************************************
+%*									*
+\subsection[InstDecl]{An instance declaration (also, @SpecInstSig@)}
+%*									*
+%************************************************************************
+
+\begin{code}
+data InstDecl tyvar uvar name pat
+  = InstDecl	name		-- Class
+
+		(PolyType name)	-- Context => 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.
+
+		FAST_STRING	-- The name of the module where the instance decl
+				-- originally came from; easy enough if it's
+				-- the module being compiled; otherwise, the
+				-- info comes from a pragma.
+
+		[Sig name]		-- actually user-supplied pragmatic info
+		(InstancePragmas name)	-- interface-supplied pragmatic info
+		SrcLoc
+\end{code}
+
+\begin{code}
+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 local 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) ]
+\end{code}
+
+A type for recording what instances the user wants to specialise;
+called a ``Sig'' because it's sort of like a ``type signature'' for an
+instance.
+\begin{code}
+data SpecInstSig name
+  = SpecInstSig  name		    -- class
+		 (MonoType name)    -- type to specialise to
+		 SrcLoc
+
+instance (NamedThing name, Outputable name)
+	      => Outputable (SpecInstSig name) where
+
+    ppr sty (SpecInstSig clas ty _)
+      = ppCat [ppStr "{-# SPECIALIZE instance", ppr sty clas, ppr sty ty, ppStr "#-}"]
+\end{code}
+
+%************************************************************************
+%*									*
+\subsection[DefaultDecl]{A @default@ declaration}
+%*									*
+%************************************************************************
+
+There can only be one default declaration per module, but it is hard
+for the parser to check that; we pass them all through in the abstract
+syntax, and that restriction must be checked in the front end.
+
+\begin{code}
+data DefaultDecl name
+  = DefaultDecl	[MonoType name]
+		SrcLoc
+
+instance (NamedThing name, Outputable name)
+	      => Outputable (DefaultDecl name) where
+
+    ppr sty (DefaultDecl tys src_loc)
+      = ppBeside (ppPStr SLIT("default ")) (ppParens (interpp'SP sty tys))
+\end{code}
diff --git a/ghc/compiler/hsSyn/HsExpr.lhs b/ghc/compiler/hsSyn/HsExpr.lhs
new file mode 100644
index 0000000000..2004ddf329
--- /dev/null
+++ b/ghc/compiler/hsSyn/HsExpr.lhs
@@ -0,0 +1,453 @@
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1994
+%
+\section[HsExpr]{Abstract Haskell syntax: expressions}
+
+\begin{code}
+#include "HsVersions.h"
+
+module HsExpr where
+
+import Ubiq{-uitous-}
+import HsLoop -- for paranoia checking
+
+-- friends:
+import HsBinds		( HsBinds )
+import HsLit		( HsLit )
+import HsMatches	( pprMatches, pprMatch, Match )
+import HsTypes		( PolyType )
+
+-- others:
+import Id		( DictVar(..), GenId, Id(..) )
+import Outputable
+import PprType		( pprType, pprParendType, GenType{-instance-}, GenTyVar{-instance-} )
+import Pretty
+import PprStyle		( PprStyle(..) )
+import SrcLoc		( SrcLoc )
+import TyVar		( GenTyVar{-instances-} )
+import Usage		( GenUsage{-instance-} )
+import Unique		( Unique{-instances-} )
+import Util		( panic{-ToDo:rm eventually-} )
+\end{code}
+
+%************************************************************************
+%*									*
+\subsection{Expressions proper}
+%*									*
+%************************************************************************
+
+\begin{code}
+data HsExpr tyvar uvar id pat
+  = HsVar	id				-- variable
+  | HsLit	HsLit				-- literal
+  | HsLitOut	HsLit				-- TRANSLATION
+		(GenType tyvar uvar)		-- (with its type)
+
+  | HsLam	(Match  tyvar uvar id pat)	-- lambda
+  | HsApp	(HsExpr tyvar uvar id pat)	-- application
+		(HsExpr tyvar uvar id pat)
+
+  -- Operator applications and sections.
+  -- NB Bracketed ops such as (+) come out as Vars.
+
+  | OpApp	(HsExpr tyvar uvar id pat)	-- left operand
+		(HsExpr tyvar uvar id pat)	-- operator
+		(HsExpr tyvar uvar id pat)	-- right operand
+
+  -- ADR Question? Why is the "op" in a section an expr when it will
+  -- have to be of the form (HsVar op) anyway?
+  -- WDP Answer: But when the typechecker gets ahold of it, it may
+  -- apply the var to a few types; it will then be an expression.
+
+  | SectionL	(HsExpr tyvar uvar id pat)	-- operand
+		(HsExpr tyvar uvar id pat)	-- operator
+  | SectionR	(HsExpr tyvar uvar id pat)	-- operator
+		(HsExpr tyvar uvar id pat)	-- operand
+				
+
+  | HsCase	(HsExpr tyvar uvar id pat)
+		[Match  tyvar uvar id pat]	-- must have at least one Match
+		SrcLoc
+
+  | HsIf	(HsExpr tyvar uvar id pat)	--  predicate
+		(HsExpr tyvar uvar id pat)	--  then part
+		(HsExpr tyvar uvar id pat)	--  else part
+		SrcLoc
+
+  | HsLet	(HsBinds tyvar uvar id pat)	-- let(rec)
+		(HsExpr  tyvar uvar id pat)
+
+  | HsDo	[Stmt tyvar uvar id pat]	-- "do":one or more stmts
+		SrcLoc
+
+  | HsDoOut	[Stmt tyvar uvar id pat]	-- "do":one or more stmts
+		id id				-- Monad and MonadZero dicts
+		SrcLoc
+
+  | ListComp	(HsExpr tyvar uvar id pat)	-- list comprehension
+		[Qual   tyvar uvar id pat]	-- at least one Qual(ifier)
+
+  | ExplicitList		-- syntactic list
+		[HsExpr tyvar uvar id pat]
+  | ExplicitListOut		-- TRANSLATION
+		(GenType tyvar uvar)	-- Gives type of components of list
+		[HsExpr tyvar uvar id pat]
+
+  | ExplicitTuple		-- tuple
+		[HsExpr tyvar uvar id pat]
+				-- NB: Unit is ExplicitTuple []
+				-- for tuples, we can get the types
+				-- direct from the components
+
+  | RecordCon	id		-- record construction
+		[(id, Maybe (HsExpr tyvar uvar id pat))]
+
+  | RecordUpd	(HsExpr tyvar uvar id pat) -- record update
+		[(id, Maybe (HsExpr tyvar uvar id pat))]
+
+  | ExprWithTySig		-- signature binding
+		(HsExpr tyvar uvar id pat)
+		(PolyType id)
+  | ArithSeqIn			-- arithmetic sequence
+		(ArithSeqInfo tyvar uvar id pat)
+  | ArithSeqOut
+		(HsExpr       tyvar uvar id pat) -- (typechecked, of course)
+		(ArithSeqInfo tyvar uvar id pat)
+
+  | CCall	FAST_STRING	-- call into the C world; string is
+		[HsExpr tyvar uvar id pat]	-- the C function; exprs are the
+				-- arguments to pass.
+		Bool		-- True <=> might cause Haskell
+				-- garbage-collection (must generate
+				-- more paranoid code)
+		Bool		-- True <=> it's really a "casm"
+				-- NOTE: this CCall is the *boxed*
+				-- version; the desugarer will convert
+				-- it into the unboxed "ccall#".
+		(GenType tyvar uvar)	-- The result type; will be *bottom*
+				-- until the typechecker gets ahold of it
+
+  | HsSCC	FAST_STRING	-- "set cost centre" (_scc_) annotation
+		(HsExpr tyvar uvar id pat) -- expr whose cost is to be measured
+\end{code}
+
+Everything from here on appears only in typechecker output.
+
+\begin{code}
+  | TyLam			-- TRANSLATION
+		[tyvar]
+		(HsExpr tyvar uvar id pat)
+  | TyApp			-- TRANSLATION
+		(HsExpr  tyvar uvar id pat) -- generated by Spec
+		[GenType tyvar uvar]
+
+  -- DictLam and DictApp are "inverses"
+  |  DictLam
+		[id]
+		(HsExpr tyvar uvar id pat)
+  |  DictApp
+		(HsExpr tyvar uvar id pat)
+		[id]
+
+  -- ClassDictLam and Dictionary are "inverses" (see note below)
+  |  ClassDictLam
+		[id]		-- superclass dicts
+		[id]		-- methods
+		(HsExpr tyvar uvar id pat)
+  |  Dictionary
+		[id]		-- superclass dicts
+		[id]		-- methods
+
+  |  SingleDict			-- a simple special case of Dictionary
+		id		-- local dictionary name
+\end{code}
+
+A @Dictionary@, unless of length 0 or 1, becomes a tuple.  A
+@ClassDictLam dictvars methods expr@ is, therefore:
+\begin{verbatim}
+\ x -> case x of ( dictvars-and-methods-tuple ) -> expr
+\end{verbatim}
+
+\begin{code}
+instance (NamedThing id, Outputable id, Outputable pat,
+	  Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar) =>
+		Outputable (HsExpr tyvar uvar id pat) where
+    ppr = pprExpr
+\end{code}
+
+\begin{code}
+pprExpr sty (HsVar v)
+  = (if (isOpLexeme v) then ppParens else id) (ppr sty v)
+
+pprExpr sty (HsLit    lit)   = ppr sty lit
+pprExpr sty (HsLitOut lit _) = ppr sty lit
+
+pprExpr sty (HsLam match)
+  = ppCat [ppStr "\\", ppNest 2 (pprMatch sty True match)]
+
+pprExpr sty expr@(HsApp e1 e2)
+  = let (fun, args) = collect_args expr [] in
+    ppHang (pprParendExpr sty fun) 4 (ppSep (map (pprParendExpr sty) args))
+  where
+    collect_args (HsApp fun arg) args = collect_args fun (arg:args)
+    collect_args fun		 args = (fun, args)
+
+pprExpr sty (OpApp e1 op e2)
+  = case op of
+      HsVar v -> pp_infixly v
+      _	      -> pp_prefixly
+  where
+    pp_e1 = pprParendExpr sty e1
+    pp_e2 = pprParendExpr sty e2
+
+    pp_prefixly
+      = ppHang (pprParendExpr sty op) 4 (ppSep [pp_e1, pp_e2])
+
+    pp_infixly v
+      = ppSep [pp_e1, ppCat [pprOp sty v, pp_e2]]
+
+pprExpr sty (SectionL expr op)
+  = case op of
+      HsVar v -> pp_infixly v
+      _	      -> pp_prefixly
+  where
+    pp_expr = pprParendExpr sty expr
+
+    pp_prefixly = ppHang (ppCat [ppStr "( \\ _x ->", ppr sty op])
+		       4 (ppCat [pp_expr, ppStr "_x )"])
+    pp_infixly v
+      = ppSep [ ppBeside ppLparen pp_expr,
+	    	ppBeside (pprOp sty v) ppRparen ]
+
+pprExpr sty (SectionR op expr)
+  = case op of
+      HsVar v -> pp_infixly v
+      _	      -> pp_prefixly
+  where
+    pp_expr = pprParendExpr sty expr
+
+    pp_prefixly = ppHang (ppCat [ppStr "( \\ _x ->", ppr sty op, ppPStr SLIT("_x")])
+		       4 (ppBeside pp_expr ppRparen)
+    pp_infixly v
+      = ppSep [ ppBeside ppLparen (pprOp sty v),
+		ppBeside pp_expr  ppRparen ]
+
+pprExpr sty (CCall fun args _ is_asm result_ty)
+  = ppHang (if is_asm
+	    then ppBesides [ppStr "_casm_ ``", ppPStr fun, ppStr "''"]
+	    else ppBeside  (ppPStr SLIT("_ccall_ ")) (ppPStr fun))
+	 4 (ppSep (map (pprParendExpr sty) args))
+
+pprExpr sty (HsSCC label expr)
+  = ppSep [ ppBeside (ppPStr SLIT("_scc_ ")) (ppBesides [ppChar '"', ppPStr label, ppChar '"']),
+	    pprParendExpr sty expr ]
+
+pprExpr sty (HsCase expr matches _)
+  = ppSep [ ppSep [ppPStr SLIT("case"), ppNest 4 (pprExpr sty expr), ppPStr SLIT("of")],
+	    ppNest 2 (pprMatches sty (True, ppNil) matches) ]
+
+pprExpr sty (ListComp expr quals)
+  = ppHang (ppCat [ppLbrack, pprExpr sty expr, ppChar '|'])
+	 4 (ppSep [interpp'SP sty quals, ppRbrack])
+
+-- special case: let ... in let ...
+pprExpr sty (HsLet binds expr@(HsLet _ _))
+  = ppSep [ppHang (ppPStr SLIT("let")) 2 (ppCat [ppr sty binds, ppPStr SLIT("in")]),
+	   ppr sty expr]
+
+pprExpr sty (HsLet binds expr)
+  = ppSep [ppHang (ppPStr SLIT("let")) 2 (ppr sty binds),
+	   ppHang (ppPStr SLIT("in"))  2 (ppr sty expr)]
+
+pprExpr sty (HsDo stmts _)
+  = ppCat [ppPStr SLIT("do"), ppAboves (map (ppr sty) stmts)]
+
+pprExpr sty (HsIf e1 e2 e3 _)
+  = ppSep [ppCat [ppPStr SLIT("if"), ppNest 2 (pprExpr sty e1), ppPStr SLIT("then")],
+	   ppNest 4 (pprExpr sty e2),
+	   ppPStr SLIT("else"),
+	   ppNest 4 (pprExpr sty e3)]
+
+pprExpr sty (ExplicitList exprs)
+  = ppBracket (ppInterleave ppComma (map (pprExpr sty) exprs))
+pprExpr sty (ExplicitListOut ty exprs)
+  = ppBesides [ ppBracket (ppInterleave ppComma (map (pprExpr sty) exprs)),
+		ifnotPprForUser sty (ppBeside ppSP (ppParens (pprType sty ty))) ]
+
+pprExpr sty (ExplicitTuple exprs)
+  = ppParens (ppInterleave ppComma (map (pprExpr sty) exprs))
+pprExpr sty (ExprWithTySig expr sig)
+  = ppHang (ppBesides [ppLparen, ppNest 2 (pprExpr sty expr), ppPStr SLIT(" ::")])
+	 4 (ppBeside  (ppr sty sig) ppRparen)
+
+pprExpr sty (RecordCon con  rbinds)
+  = pp_rbinds sty (ppr sty con) rbinds
+
+pprExpr sty (RecordUpd aexp rbinds)
+  = pp_rbinds sty (pprParendExpr sty aexp) rbinds
+
+pprExpr sty (ArithSeqIn info)
+  = ppBracket (ppr sty info)
+pprExpr sty (ArithSeqOut expr info)
+  = case sty of
+  	PprForUser ->
+    	  ppBracket (ppr sty info)
+	_   	   ->
+    	  ppBesides [ppLbrack, ppParens (ppr sty expr), ppr sty info, ppRbrack]
+
+pprExpr sty (TyLam tyvars expr)
+  = ppHang (ppCat [ppStr "/\\", interppSP sty tyvars, ppStr "->"])
+	 4 (pprExpr sty expr)
+
+pprExpr sty (TyApp expr [ty])
+  = ppHang (pprExpr sty expr) 4 (pprParendType sty ty)
+
+pprExpr sty (TyApp expr tys)
+  = ppHang (pprExpr sty expr)
+	 4 (ppBracket (interpp'SP sty tys))
+
+pprExpr sty (DictLam dictvars expr)
+  = ppHang (ppCat [ppStr "\\{-dict-}", interppSP sty dictvars, ppStr "->"])
+	 4 (pprExpr sty expr)
+
+pprExpr sty (DictApp expr [dname])
+  = ppHang (pprExpr sty expr) 4 (ppr sty dname)
+
+pprExpr sty (DictApp expr dnames)
+  = ppHang (pprExpr sty expr)
+	 4 (ppBracket (interpp'SP sty dnames))
+
+pprExpr sty (ClassDictLam dicts methods expr)
+  = ppHang (ppCat [ppStr "\\{-classdict-}",
+		   ppBracket (interppSP sty dicts),
+		   ppBracket (interppSP sty methods),
+		   ppStr "->"])
+	 4 (pprExpr sty expr)
+
+pprExpr sty (Dictionary dicts methods)
+ = ppSep [ppBesides [ppLparen, ppPStr SLIT("{-dict-}")],
+	  ppBracket (interpp'SP sty dicts),
+	  ppBesides [ppBracket (interpp'SP sty methods), ppRparen]]
+
+pprExpr sty (SingleDict dname)
+ = ppCat [ppPStr SLIT("{-singleDict-}"), ppr sty dname]
+\end{code}
+
+Parenthesize unless very simple:
+\begin{code}
+pprParendExpr :: (NamedThing id, Outputable id, Outputable pat,
+		  Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar)
+	      => PprStyle -> HsExpr tyvar uvar id pat -> Pretty
+
+pprParendExpr sty expr
+  = let
+	pp_as_was = pprExpr sty expr
+    in
+    case expr of
+      HsLit l		    -> ppr sty l
+      HsLitOut l _	    -> ppr sty l
+      HsVar _		    -> pp_as_was
+      ExplicitList _	    -> pp_as_was
+      ExplicitListOut _ _   -> pp_as_was
+      ExplicitTuple _	    -> pp_as_was
+      _			    -> ppParens pp_as_was
+\end{code}
+
+%************************************************************************
+%*									*
+\subsection{Record binds}
+%*									*
+%************************************************************************
+
+\begin{code}
+pp_rbinds sty thing rbinds
+  = ppHang thing 4
+	(ppBesides [ppChar '{', ppInterleave ppComma (map (pp_rbind sty) rbinds), ppChar '}'])
+
+pp_rbind :: (NamedThing id, Outputable id, Outputable pat,
+		  Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar)
+	      => PprStyle -> (id, Maybe (HsExpr tyvar uvar id pat)) -> Pretty
+
+pp_rbind sty (v, Nothing) = ppr sty v
+pp_rbind sty (v, Just e)  = ppCat [ppr sty v, ppStr "<-", ppr sty e]
+\end{code}
+
+%************************************************************************
+%*									*
+\subsection{Do stmts}
+%*									*
+%************************************************************************
+
+\begin{code}
+data Stmt tyvar uvar id pat
+  = BindStmt	pat
+		(HsExpr  tyvar uvar id pat)
+		SrcLoc
+  | ExprStmt	(HsExpr  tyvar uvar id pat)
+		SrcLoc
+  | LetStmt	(HsBinds tyvar uvar id pat)
+\end{code}
+
+\begin{code}
+instance (NamedThing id, Outputable id, Outputable pat,
+	  Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar) =>
+		Outputable (Stmt tyvar uvar id pat) where
+    ppr sty (BindStmt pat expr _)
+     = ppCat [ppr sty pat, ppStr "<-", ppr sty expr]
+    ppr sty (LetStmt binds)
+     = ppCat [ppPStr SLIT("let"), ppr sty binds]
+    ppr sty (ExprStmt expr _)
+     = ppr sty expr
+\end{code}
+
+%************************************************************************
+%*									*
+\subsection{Enumerations and list comprehensions}
+%*									*
+%************************************************************************
+
+\begin{code}
+data ArithSeqInfo  tyvar uvar id pat
+  = From	    (HsExpr tyvar uvar id pat)
+  | FromThen 	    (HsExpr tyvar uvar id pat)
+		    (HsExpr tyvar uvar id pat)
+  | FromTo	    (HsExpr tyvar uvar id pat)
+		    (HsExpr tyvar uvar id pat)
+  | FromThenTo	    (HsExpr tyvar uvar id pat)
+		    (HsExpr tyvar uvar id pat)
+		    (HsExpr tyvar uvar id pat)
+\end{code}
+
+\begin{code}
+instance (NamedThing id, Outputable id, Outputable pat,
+	  Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar) =>
+		Outputable (ArithSeqInfo tyvar uvar id pat) where
+    ppr sty (From e1)		= ppBesides [ppr sty e1, pp_dotdot]
+    ppr sty (FromThen e1 e2)	= ppBesides [ppr sty e1, pp'SP, ppr sty e2, pp_dotdot]
+    ppr sty (FromTo e1 e3)	= ppBesides [ppr sty e1, pp_dotdot, ppr sty e3]
+    ppr sty (FromThenTo e1 e2 e3)
+      = ppBesides [ppr sty e1, pp'SP, ppr sty e2, pp_dotdot, ppr sty e3]
+
+pp_dotdot = ppPStr SLIT(" .. ")
+\end{code}
+
+``Qualifiers'' in list comprehensions:
+\begin{code}
+data Qual tyvar uvar id pat
+  = GeneratorQual   pat
+		    (HsExpr  tyvar uvar id pat)
+  | LetQual	    (HsBinds tyvar uvar id pat)
+  | FilterQual	    (HsExpr  tyvar uvar id pat)
+\end{code}
+
+\begin{code}
+instance (NamedThing id, Outputable id, Outputable pat,
+	  Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar) =>
+		Outputable (Qual tyvar uvar id pat) where
+    ppr sty (GeneratorQual pat expr)
+     = ppCat [ppr sty pat, ppStr "<-", ppr sty expr]
+    ppr sty (LetQual binds)
+     = ppCat [ppPStr SLIT("let"), ppr sty binds]
+    ppr sty (FilterQual expr)
+     = ppr sty expr
+\end{code}
diff --git a/ghc/compiler/hsSyn/HsImpExp.lhs b/ghc/compiler/hsSyn/HsImpExp.lhs
new file mode 100644
index 0000000000..f5c579b318
--- /dev/null
+++ b/ghc/compiler/hsSyn/HsImpExp.lhs
@@ -0,0 +1,144 @@
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+%
+\section[HsImpExp]{Abstract syntax: imports, exports, interfaces}
+
+\begin{code}
+#include "HsVersions.h"
+
+module HsImpExp where
+
+import Ubiq{-uitous-}
+
+-- friends:
+import HsDecls		( FixityDecl, TyDecl, ClassDecl, InstDecl )
+import HsBinds		( Sig )
+
+-- others:
+import Outputable
+import PprStyle		( PprStyle(..) )
+import Pretty
+import SrcLoc		( SrcLoc{-instances-} )
+\end{code}
+
+%************************************************************************
+%*									*
+\subsection{Import and export declaration lists}
+%*									*
+%************************************************************************
+
+One per \tr{import} declaration in a module.
+\begin{code}
+data ImportedInterface tyvar uvar name pat
+  = ImportMod	  (Interface tyvar uvar name pat)
+		  Bool				-- qualified?
+		  (Maybe FAST_STRING)		-- as Modid
+		  (Maybe (Bool, [IE name]))	-- (hiding?, names)
+\end{code}
+
+\begin{code}
+instance (NamedThing name, Outputable name, Outputable pat,
+	  Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar)
+	   => Outputable (ImportedInterface tyvar uvar name pat) where
+
+    ppr sty (ImportMod iface qual as spec)
+      = ppAbove (ppHang (ppCat [ppStr "import", pp_qual qual, ppr PprForUser iface, pp_as as])
+	              4 (pp_spec spec))
+		(case sty of {PprForUser -> ppNil; _ -> ppr sty iface})
+      where
+	pp_qual False   = ppNil
+	pp_qual True	= ppStr "qualified"
+
+	pp_as Nothing   = ppNil
+	pp_as (Just a)  = ppCat [ppStr "as", ppPStr a]
+
+	pp_spec Nothing = ppNil
+	pp_spec (Just (False, spec))
+			= ppBesides [ppStr "(", interpp'SP sty spec, ppStr ")"]
+	pp_spec (Just (True, spec))
+			= ppBesides [ppStr "hiding (", interpp'SP sty spec, ppStr ")"]
+
+\end{code}
+
+%************************************************************************
+%*									*
+\subsection{Imported and exported entities}
+%*									*
+%************************************************************************
+\begin{code}
+data IE name
+  = IEVar		name
+  | IEThingAbs          name		-- Constructor/Type/Class (can't tell)
+  | IEThingAll          name		-- Class/Type plus all methods/constructors
+  | IEThingWith		name [name]	-- Class/Type plus some methods/constructors
+  | IEModuleContents    FAST_STRING	-- (Export Only)
+\end{code}
+
+\begin{code}
+instance (Outputable name) => Outputable (IE name) where
+    ppr sty (IEVar	var)	= ppr sty var
+    ppr sty (IEThingAbs	thing)	= ppr sty thing
+    ppr sty (IEThingAll	thing)
+	= ppBesides [ppr sty thing, ppStr "(..)"]
+    ppr sty (IEThingWith thing withs)
+	= ppBesides [ppr sty thing, ppLparen, ppInterleave ppComma (map (ppr sty) withs), ppRparen]
+    ppr sty (IEModuleContents mod)
+	= ppBeside (ppPStr SLIT("module ")) (ppPStr mod)
+\end{code}
+
+%************************************************************************
+%*									*
+\subsection{Interfaces}
+%*									*
+%************************************************************************
+
+\begin{code}
+data Interface tyvar uvar name pat
+  = Interface	FAST_STRING			-- module name
+		[IfaceImportDecl name]
+		[FixityDecl name]
+		[TyDecl name]			-- data decls may have no constructors
+		[ClassDecl tyvar uvar name pat]	-- without default methods
+		[InstDecl  tyvar uvar name pat]	-- without method defns
+		[Sig name]
+		SrcLoc
+\end{code}
+
+\begin{code}
+instance (NamedThing name, Outputable name, Outputable pat,
+	  Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar)
+	     => Outputable (Interface tyvar uvar name pat) where
+
+    ppr PprForUser (Interface name _ _ _ _ _ _ _) = ppPStr name
+
+    ppr sty (Interface name iimpdecls fixities tydecls classdecls instdecls sigs anns)
+      = ppAboves [ppStr "{-",
+		  ifPprShowAll sty (ppr sty anns),
+		  ppCat [ppStr "interface", ppPStr name, ppStr "where"],
+		  ppNest 4 (ppAboves [
+		      pp_nonnull iimpdecls,
+		      pp_nonnull fixities,
+		      pp_nonnull tydecls,
+		      pp_nonnull classdecls,
+		      pp_nonnull instdecls,
+		      pp_nonnull sigs]),
+		  ppStr "-}"]
+      where
+	pp_nonnull [] = ppNil
+	pp_nonnull xs = ppAboves (map (ppr sty) xs)
+\end{code}
+
+\begin{code}
+data IfaceImportDecl name
+  = IfaceImportDecl FAST_STRING	    -- module we're being told about
+		    [IE name]	    -- things we're being told about
+		    SrcLoc
+\end{code}
+
+\begin{code}
+instance Outputable name => Outputable (IfaceImportDecl name) where
+
+    ppr sty (IfaceImportDecl mod names src_loc)
+      = ppHang (ppCat [ppPStr SLIT("import"), ppPStr mod, ppLparen])
+	     4 (ppSep [ppCat [interpp'SP sty names, ppRparen]])
+\end{code}
diff --git a/ghc/compiler/hsSyn/HsLit.lhs b/ghc/compiler/hsSyn/HsLit.lhs
new file mode 100644
index 0000000000..f18cde5a67
--- /dev/null
+++ b/ghc/compiler/hsSyn/HsLit.lhs
@@ -0,0 +1,60 @@
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+%
+\section[HsLit]{Abstract syntax: source-language literals}
+
+\begin{code}
+#include "HsVersions.h"
+
+module HsLit where
+
+import Ubiq{-uitous-}
+
+import Pretty
+\end{code}
+
+\begin{code}
+data HsLit
+  = HsChar	    Char	-- characters
+  | HsCharPrim	    Char	-- unboxed char literals
+  | HsString	    FAST_STRING	-- strings
+  | HsStringPrim    FAST_STRING	-- packed string
+
+  | HsInt	    Integer	-- integer-looking literals
+  | HsFrac	    Rational	-- frac-looking literals
+	-- Up through dict-simplification, HsInt and HsFrac simply
+	-- mean the literal was integral- or fractional-looking; i.e.,
+	-- whether it had an explicit decimal-point in it.  *After*
+	-- dict-simplification, they mean (boxed) "Integer" and
+	-- "Rational" [Ratio Integer], respectively.
+
+	-- Dict-simplification tries to replace such lits w/ more
+	-- specific ones, using the unboxed variants that follow...
+  | HsIntPrim	    Integer	-- unboxed Int literals
+  | HsFloatPrim	    Rational	-- unboxed Float literals
+  | HsDoublePrim    Rational	-- unboxed Double literals
+
+  | HsLitLit	    FAST_STRING	-- to pass ``literal literals'' through to C
+				-- also: "overloaded" type; but
+				-- must resolve to boxed-primitive!
+				-- (WDP 94/10)
+\end{code}
+
+\begin{code}
+negLiteral (HsInt  i) = HsInt  (-i)
+negLiteral (HsFrac f) = HsFrac (-f)
+\end{code}
+
+\begin{code}
+instance Outputable HsLit where
+    ppr sty (HsChar c)		= ppStr (show c)
+    ppr sty (HsCharPrim c)	= ppBeside (ppStr (show c)) (ppChar '#')
+    ppr sty (HsString s)	= ppStr (show s)
+    ppr sty (HsStringPrim s)	= ppBeside (ppStr (show s)) (ppChar '#')
+    ppr sty (HsInt i)		= ppInteger i
+    ppr sty (HsFrac f)		= ppRational f
+    ppr sty (HsFloatPrim f)	= ppBeside (ppRational f) (ppChar '#')
+    ppr sty (HsDoublePrim d)	= ppBeside (ppRational d) (ppStr "##")
+    ppr sty (HsIntPrim i)	= ppBeside (ppInteger i) (ppChar '#')
+    ppr sty (HsLitLit s)	= ppBesides [ppStr "``", ppPStr s, ppStr "''"]
+\end{code}
diff --git a/ghc/compiler/hsSyn/HsLoop.lhi b/ghc/compiler/hsSyn/HsLoop.lhi
new file mode 100644
index 0000000000..e425c234d1
--- /dev/null
+++ b/ghc/compiler/hsSyn/HsLoop.lhi
@@ -0,0 +1,41 @@
+\begin{code}
+
+interface HsLoop where
+
+import HsExpr( HsExpr )
+import Outputable( NamedThing, Outputable )
+import HsBinds ( Bind, HsBinds, MonoBinds, Sig, nullBinds, nullMonoBinds )
+import HsDecls ( ConDecl )
+
+-- HsExpr outputs
+data HsExpr tyvar uvar id pat
+
+instance (NamedThing id, Outputable id, Outputable pat,
+	  Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar)
+  => Outputable (HsExpr tyvar uvar id pat)
+
+
+-- HsBinds outputs
+data Sig id
+instance (NamedThing name, Outputable name) => Outputable (Sig name)
+
+data Bind tyvar uvar id pat
+
+data HsBinds tyvar uvar id pat
+
+instance (Outputable pat, NamedThing id, Outputable id,
+	  Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar) =>
+		Outputable (HsBinds tyvar uvar id pat)
+
+data MonoBinds tyvar uvar id pat
+
+instance (NamedThing id, Outputable id, Outputable pat,
+	  Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar) =>
+		Outputable (MonoBinds tyvar uvar id pat)
+
+nullBinds     :: HsBinds tyvar uvar id pat -> Bool
+nullMonoBinds :: MonoBinds tyvar uvar id pat -> Bool
+
+-- HsDecls outputs
+data ConDecl name
+\end{code}
diff --git a/ghc/compiler/hsSyn/HsMatches.lhs b/ghc/compiler/hsSyn/HsMatches.lhs
new file mode 100644
index 0000000000..4c8186f940
--- /dev/null
+++ b/ghc/compiler/hsSyn/HsMatches.lhs
@@ -0,0 +1,150 @@
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+%
+\section[HsMatches]{Abstract syntax: matches and guarded right-hand-sides}
+
+The @Match@, @GRHSsAndBinds@ and @GRHS@ datatypes.
+
+\begin{code}
+#include "HsVersions.h"
+
+module HsMatches where
+
+import Ubiq{-uitous-}
+
+import HsLoop		( HsExpr, nullBinds, HsBinds )
+import Outputable	( ifPprShowAll )
+import PprType
+import Pretty
+import SrcLoc		( SrcLoc{-instances-} )
+import TyVar		( GenTyVar{-instances-} )
+import Unique		( Unique{-instances-} )
+import Util		( panic )
+\end{code}
+
+%************************************************************************
+%*									*
+\subsection{@Match@, @GRHSsAndBinds@, and @GRHS@ datatypes}
+%*									*
+%************************************************************************
+
+@Match@es are sets of pattern bindings and right hand sides for
+functions, patterns or case branches. For example, if a function @g@
+is defined as:
+\begin{verbatim}
+g (x,y) = y
+g ((x:ys),y) = y+1,
+\end{verbatim}
+then \tr{g} has two @Match@es: @(x,y) = y@ and @((x:ys),y) = y+1@.
+
+It is always the case that each element of an @[Match]@ list has the
+same number of @PatMatch@s inside it.  This corresponds to saying that
+a function defined by pattern matching must have the same number of
+patterns in each equation.
+
+\begin{code}
+data Match tyvar uvar id pat
+  = PatMatch	    pat
+		    (Match tyvar uvar id pat)
+  | GRHSMatch	    (GRHSsAndBinds tyvar uvar id pat)
+\end{code}
+
+Sets of guarded right hand sides (GRHSs). In:
+\begin{verbatim}
+f (x,y) | x==True = y
+	| otherwise = y*2
+\end{verbatim}
+a guarded right hand side is either
+@(x==True = y)@, or @(otherwise = y*2)@.
+
+For each match, there may be several guarded right hand
+sides, as the definition of @f@ shows.
+
+\begin{code}
+data GRHSsAndBinds tyvar uvar id pat
+  = GRHSsAndBindsIn 	[GRHS tyvar uvar id pat]	    -- at least one GRHS
+			(HsBinds tyvar uvar id pat)
+
+  | GRHSsAndBindsOut 	[GRHS tyvar uvar id pat]	    -- at least one GRHS
+			(HsBinds tyvar uvar id pat)
+			(GenType tyvar uvar)
+
+data GRHS tyvar uvar id pat
+  = GRHS	    (HsExpr tyvar uvar id pat)	-- guard(ed)...
+		    (HsExpr tyvar uvar id pat)	-- ... right-hand side
+		    SrcLoc
+
+  | OtherwiseGRHS   (HsExpr tyvar uvar id pat)	-- guard-free
+		    SrcLoc
+\end{code}
+
+%************************************************************************
+%*									*
+\subsection{Printing}
+%*									*
+%************************************************************************
+
+We know the list must have at least one @Match@ in it.
+\begin{code}
+pprMatches :: (NamedThing id, Outputable id, Outputable pat,
+	       Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar) =>
+		PprStyle -> (Bool, Pretty) -> [Match tyvar uvar id pat] -> Pretty
+
+pprMatches sty print_info@(is_case, name) [match]
+  = if is_case then
+    	pprMatch sty is_case match
+    else
+    	ppHang name 4 (pprMatch sty is_case match)
+
+pprMatches sty print_info (match1 : rest)
+ = ppAbove (pprMatches sty print_info [match1])
+	   (pprMatches sty print_info rest)
+
+---------------------------------------------
+pprMatch :: (NamedThing id, Outputable id, Outputable pat,
+	       Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar) =>
+	PprStyle -> Bool -> Match tyvar uvar id pat -> Pretty
+
+pprMatch sty is_case first_match
+ = ppHang (ppSep (map (ppr sty) row_of_pats))
+	8 grhss_etc_stuff
+ where
+    (row_of_pats, grhss_etc_stuff) = ppr_match sty is_case first_match
+
+    ppr_match sty is_case (PatMatch pat match)
+     = (pat:pats, grhss_stuff)
+     where
+	(pats, grhss_stuff) = ppr_match sty is_case match
+
+    ppr_match sty is_case (GRHSMatch grhss_n_binds)
+     = ([], pprGRHSsAndBinds sty is_case grhss_n_binds)
+
+----------------------------------------------------------
+
+pprGRHSsAndBinds sty is_case (GRHSsAndBindsIn grhss binds)
+ = ppAbove (ppAboves (map (pprGRHS sty is_case) grhss))
+	   (if (nullBinds binds)
+	    then ppNil
+	    else ppAboves [ ppStr "where", ppNest 4 (ppr sty binds) ])
+
+pprGRHSsAndBinds sty is_case (GRHSsAndBindsOut grhss binds ty)
+ = ppAbove (ppAboves (map (pprGRHS sty is_case) grhss))
+	   (if (nullBinds binds)
+	    then ppNil
+	    else ppAboves [ ifPprShowAll sty
+				(ppCat [ppStr "{- ty:", ppr sty ty, ppStr "-}"]),
+			    ppStr "where", ppNest 4 (ppr sty binds) ])
+
+---------------------------------------------
+pprGRHS :: (NamedThing id, Outputable id, Outputable pat,
+	    Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar)
+	=> PprStyle -> Bool -> GRHS tyvar uvar id pat -> Pretty
+
+pprGRHS sty is_case (GRHS guard expr locn)
+ = ppHang (ppCat [ppChar '|', ppr sty guard, ppStr (if is_case then "->" else "=")])
+        4 (ppr sty expr)
+
+pprGRHS sty is_case (OtherwiseGRHS  expr locn)
+  = ppHang (ppStr (if is_case then "->" else "="))
+	 4 (ppr sty expr)
+\end{code}
diff --git a/ghc/compiler/hsSyn/HsPat.lhs b/ghc/compiler/hsSyn/HsPat.lhs
new file mode 100644
index 0000000000..73124ac4f0
--- /dev/null
+++ b/ghc/compiler/hsSyn/HsPat.lhs
@@ -0,0 +1,286 @@
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+%
+\section[PatSyntax]{Abstract Haskell syntax---patterns}
+
+\begin{code}
+#include "HsVersions.h"
+
+module HsPat (
+	InPat(..),
+	OutPat(..),
+
+	unfailablePats, unfailablePat,
+	patsAreAllCons, isConPat,
+	patsAreAllLits,	isLitPat,
+	irrefutablePat,
+	collectPatBinders
+    ) where
+
+import Ubiq
+
+-- friends:
+import HsLit		( HsLit )
+import HsLoop		( HsExpr )
+
+-- others:
+import Id		( GenId, getDataConSig )
+import Maybes		( maybeToBool )
+import Outputable
+import PprStyle		( PprStyle(..) )
+import Pretty
+import TyCon		( maybeTyConSingleCon )
+import TyVar		( GenTyVar )
+import PprType		( GenType, GenTyVar )
+import Unique		( Unique )
+
+\end{code}
+
+Patterns come in distinct before- and after-typechecking flavo(u)rs.
+\begin{code}
+data InPat name
+  = WildPatIn				-- wild card
+  | VarPatIn	    name		-- variable
+  | LitPatIn	    HsLit		-- literal
+  | LazyPatIn	    (InPat name)	-- lazy pattern
+  | AsPatIn	    name		-- as pattern
+		    (InPat name)
+  | ConPatIn	    name		-- constructed type
+		    [InPat name]
+  | ConOpPatIn	    (InPat name)
+		    name
+		    (InPat name)
+  | ListPatIn	    [InPat name]	-- syntactic list
+					-- must have >= 1 elements
+  | TuplePatIn	    [InPat name]	-- tuple
+
+  | RecPatIn	    name 		-- record
+		    [(name, Maybe (InPat name))]
+
+data OutPat tyvar uvar id
+  = WildPat	    (GenType tyvar uvar)	 	    	-- wild card
+
+  | VarPat	    id				-- variable (type is in the Id)
+
+  | LazyPat	    (OutPat tyvar uvar id)	-- lazy pattern
+
+  | AsPat	    id				-- as pattern
+		    (OutPat tyvar uvar id)
+
+  | ConPat	    Id				-- Constructor is always an Id
+		    (GenType tyvar uvar)    	-- the type of the pattern
+		    [(OutPat tyvar uvar id)]
+
+  | ConOpPat	    (OutPat tyvar uvar id)	-- just a special case...
+		    Id
+		    (OutPat tyvar uvar id)
+		    (GenType tyvar uvar)
+  | ListPat		 	    		-- syntactic list
+		    (GenType tyvar uvar)	-- the type of the elements
+   	    	    [(OutPat tyvar uvar id)]
+
+  | TuplePat	    [(OutPat tyvar uvar id)]	-- tuple
+						-- UnitPat is TuplePat []
+
+  | RecPat	    id 				-- record
+		    [(id, Maybe (OutPat tyvar uvar id))]
+
+  | LitPat	    -- Used for *non-overloaded* literal patterns:
+		    -- Int#, Char#, Int, Char, String, etc.
+		    HsLit
+		    (GenType tyvar uvar) 	-- type of pattern
+
+  | NPat	    -- Used for *overloaded* literal patterns
+		    HsLit			-- the literal is retained so that
+						-- the desugarer can readily identify
+						-- equations with identical literal-patterns
+		    (GenType tyvar uvar) 	-- type of pattern, t
+   	    	    (HsExpr tyvar uvar id (OutPat tyvar uvar id))
+						-- of type t -> Bool; detects match
+
+  |  DictPat	    -- Used when destructing Dictionaries with an explicit case
+		    [id]			-- superclass dicts
+		    [id]			-- methods
+\end{code}
+
+\begin{code}
+instance (Outputable name, NamedThing name) => Outputable (InPat name) where
+    ppr = pprInPat
+
+pprInPat :: (Outputable name, NamedThing name) => PprStyle -> InPat name -> Pretty
+
+pprInPat sty (WildPatIn)	= ppStr "_"
+pprInPat sty (VarPatIn var)	= pprNonOp sty var
+pprInPat sty (LitPatIn s)	= ppr sty s
+pprInPat sty (LazyPatIn pat)	= ppBeside (ppChar '~') (ppr sty pat)
+pprInPat sty (AsPatIn name pat)
+    = ppBesides [ppLparen, ppr sty name, ppChar '@', ppr sty pat, ppRparen]
+
+pprInPat sty (ConPatIn c pats)
+ = if null pats then
+      ppr sty c
+   else
+      ppBesides [ppLparen, ppr sty c, ppSP, interppSP sty pats, ppRparen]
+
+
+pprInPat sty (ConOpPatIn pat1 op pat2)
+ = ppBesides [ppLparen, ppr sty pat1, ppSP, ppr sty op, ppSP, ppr sty pat2, ppRparen]
+
+-- ToDo: use pprOp to print op (but this involves fiddling various
+-- contexts & I'm lazy...); *PatIns are *rarely* printed anyway... (WDP)
+
+pprInPat sty (ListPatIn pats)
+  = ppBesides [ppLbrack, interpp'SP sty pats, ppRbrack]
+pprInPat sty (TuplePatIn pats)
+  = ppBesides [ppLparen, interpp'SP sty pats, ppRparen]
+
+pprInPat sty (RecPatIn con rpats)
+  = ppBesides [ppr sty con, ppSP, ppChar '{', ppInterleave ppComma (map pp_rpat rpats), ppChar '}']
+  where
+    pp_rpat (v, Nothing) = ppr sty v
+    pp_rpat (v, Just 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)
+       => Outputable (OutPat tyvar uvar id) where
+    ppr = pprOutPat
+\end{code}
+
+\begin{code}
+pprOutPat sty (WildPat ty)	= ppChar '_'
+pprOutPat sty (VarPat var)	= pprNonOp 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]
+
+pprOutPat sty (ConPat name ty [])
+  = ppBeside (ppr sty name)
+	(ifPprShowAll sty (pprConPatTy sty ty))
+
+pprOutPat sty (ConPat name ty pats)
+  = ppBesides [ppLparen, ppr sty name, ppSP,
+    	 interppSP sty pats, ppRparen,
+    	 ifPprShowAll sty (pprConPatTy sty ty) ]
+
+pprOutPat sty (ConOpPat pat1 op pat2 ty)
+  = ppBesides [ppLparen, ppr sty pat1, ppSP, pprOp sty op, ppSP, ppr sty pat2, ppRparen]
+
+pprOutPat sty (ListPat ty pats)
+  = ppBesides [ppLbrack, interpp'SP sty pats, ppRbrack]
+pprOutPat sty (TuplePat pats)
+  = ppBesides [ppLparen, interpp'SP sty pats, ppRparen]
+
+pprOutPat sty (RecPat con rpats)
+  = ppBesides [ppr sty con, ppChar '{', ppInterleave ppComma (map pp_rpat rpats), ppChar '}']
+  where
+    pp_rpat (v, Nothing) = ppr sty v
+    pp_rpat (v, Just p)  = ppBesides [ppr sty v, ppStr "<-", ppr sty p]
+
+pprOutPat sty (LitPat l ty) 	= ppr sty l	-- ToDo: print more
+pprOutPat sty (NPat   l ty e)	= ppr sty l	-- ToDo: print more
+
+pprOutPat sty (DictPat dicts methods)
+ = ppSep [ppBesides [ppLparen, ppPStr SLIT("{-dict-}")],
+	  ppBracket (interpp'SP sty dicts),
+	  ppBesides [ppBracket (interpp'SP sty methods), ppRparen]]
+
+pprConPatTy sty ty
+ = ppBesides [ppLparen, ppr sty ty, ppRparen]
+\end{code}
+
+%************************************************************************
+%*									*
+%* predicates for checking things about pattern-lists in EquationInfo	*
+%*									*
+%************************************************************************
+\subsection[Pat-list-predicates]{Look for interesting things in patterns}
+
+Unlike in the Wadler chapter, where patterns are either ``variables''
+or ``constructors,'' here we distinguish between:
+\begin{description}
+\item[unfailable:]
+Patterns that cannot fail to match: variables, wildcards, and lazy
+patterns.
+
+These are the irrefutable patterns; the two other categories
+are refutable patterns.
+
+\item[constructor:]
+A non-literal constructor pattern (see next category).
+
+\item[literal patterns:]
+At least the numeric ones may be overloaded.
+\end{description}
+
+A pattern is in {\em exactly one} of the above three categories; `as'
+patterns are treated specially, of course.
+
+\begin{code}
+unfailablePats :: [OutPat a b c] -> Bool
+unfailablePats pat_list = all unfailablePat pat_list
+
+unfailablePat (AsPat	_ pat)	= unfailablePat pat
+unfailablePat (WildPat	_)	= True
+unfailablePat (VarPat	_)	= True
+unfailablePat (LazyPat	_)	= True
+unfailablePat (DictPat ds ms)	= (length ds + length ms) <= 1
+unfailablePat other		= False
+
+patsAreAllCons :: [OutPat a b c] -> Bool
+patsAreAllCons pat_list = all isConPat pat_list
+
+isConPat (AsPat _ pat)		= isConPat pat
+isConPat (ConPat _ _ _)		= True
+isConPat (ConOpPat _ _ _ _)	= True
+isConPat (ListPat _ _)		= True
+isConPat (TuplePat _)		= True
+isConPat (DictPat ds ms)	= (length ds + length ms) > 1
+isConPat other			= False
+
+patsAreAllLits :: [OutPat a b c] -> Bool
+patsAreAllLits pat_list = all isLitPat pat_list
+
+isLitPat (AsPat _ pat)	= isLitPat pat
+isLitPat (LitPat _ _)	= True
+isLitPat (NPat   _ _ _)	= True
+isLitPat other		= False
+\end{code}
+
+A pattern is irrefutable if a match on it cannot fail
+(at any depth).
+\begin{code}
+irrefutablePat :: OutPat a b c -> Bool
+
+irrefutablePat (WildPat _) 		  = True
+irrefutablePat (VarPat _)  		  = True
+irrefutablePat (LazyPat	_) 		  = True
+irrefutablePat (AsPat _ pat)		  = irrefutablePat pat
+irrefutablePat (ConPat con tys pats)	  = all irrefutablePat pats && only_con con
+irrefutablePat (ConOpPat pat1 con pat2 _) = irrefutablePat pat1 && irrefutablePat pat1 && only_con con
+irrefutablePat (ListPat _ _)		  = False
+irrefutablePat (TuplePat pats)		  = all irrefutablePat pats
+irrefutablePat (DictPat _ _)		  = True
+irrefutablePat other_pat		  = False   -- Literals, NPat
+
+only_con con = maybeToBool (maybeTyConSingleCon tycon)
+ 	       where
+		 (_,_,_,tycon) = getDataConSig con
+\end{code}
+
+This function @collectPatBinders@ works with the ``collectBinders''
+functions for @HsBinds@, etc.  The order in which the binders are
+collected is important; see @HsBinds.lhs@.
+\begin{code}
+collectPatBinders :: InPat a -> [a]
+
+collectPatBinders (VarPatIn var)     = [var]
+collectPatBinders (LazyPatIn pat)    = collectPatBinders pat
+collectPatBinders (AsPatIn a pat)    = a : collectPatBinders pat
+collectPatBinders (ConPatIn c pats)  = concat (map collectPatBinders pats)
+collectPatBinders (ConOpPatIn p1 c p2)= collectPatBinders p1 ++ collectPatBinders p2
+collectPatBinders (ListPatIn pats)   = concat (map collectPatBinders pats)
+collectPatBinders (TuplePatIn pats)  = concat (map collectPatBinders pats)
+collectPatBinders any_other_pat	     = [ {-no binders-} ]
+\end{code}
diff --git a/ghc/compiler/hsSyn/HsPragmas.lhs b/ghc/compiler/hsSyn/HsPragmas.lhs
new file mode 100644
index 0000000000..1e5d9d10fa
--- /dev/null
+++ b/ghc/compiler/hsSyn/HsPragmas.lhs
@@ -0,0 +1,178 @@
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1993-1996
+%
+%************************************************************************
+%*									*
+\section[HsPragmas]{Pragmas in Haskell interface files}
+%*									*
+%************************************************************************
+
+See also: @Sig@ (``signatures'') which is where user-supplied pragmas
+for values show up; ditto @SpecInstSig@ (for instances) and
+@SpecDataSig@ (for data types and type synonyms).
+
+\begin{code}
+#include "HsVersions.h"
+
+module HsPragmas where
+
+import Ubiq{-uitous-}
+
+-- friends:
+import HsLoop		( ConDecl )
+import HsCore		( UnfoldingCoreExpr )
+import HsTypes		( MonoType )
+
+-- others:
+import IdInfo
+import Outputable	( Outputable(..){-instances-} )
+import Pretty
+\end{code}
+
+Certain pragmas expect to be pinned onto certain constructs.
+
+Pragma types may be parameterised, just as with any other
+abstract-syntax type.
+
+For a @data@ declaration---makes visible the constructors for an
+abstract @data@ type and indicates which specialisations exist.
+\begin{code}
+data DataPragmas name
+  = DataPragmas	[ConDecl name]		   -- hidden data constructors
+		[[Maybe (MonoType name)]]  -- types to which specialised
+\end{code}
+
+These are {\em general} things you can know about any value:
+\begin{code}
+data GenPragmas name
+  = NoGenPragmas
+  | GenPragmas	(Maybe Int)		-- arity (maybe)
+		(Maybe UpdateInfo)	-- update info (maybe)
+		DeforestInfo		-- deforest info
+		(ImpStrictness name)	-- strictness, worker-wrapper
+		(ImpUnfolding name)	-- unfolding (maybe)
+		[([Maybe (MonoType name)], -- Specialisations: types to which spec'd;
+		  Int,			   -- # dicts to ignore
+		  GenPragmas name)] 	   -- Gen info about the spec'd version
+
+noGenPragmas = NoGenPragmas
+
+data ImpUnfolding name
+  = NoImpUnfolding
+  | ImpMagicUnfolding FAST_STRING	-- magic "unfolding"
+					-- known to the compiler by "String"
+  | ImpUnfolding UnfoldingGuidance	-- always, if you like, etc.
+		 (UnfoldingCoreExpr name)
+
+data ImpStrictness name
+  = NoImpStrictness
+  | ImpStrictness Bool			-- True <=> bottoming Id
+		  [Demand]		-- demand info
+		  (GenPragmas name)	-- about the *worker*
+\end{code}
+
+For an ordinary imported function: it can have general pragmas (only).
+
+For a class's super-class dictionary selectors:
+\begin{code}
+data ClassPragmas name
+  = NoClassPragmas
+  | SuperDictPragmas [GenPragmas name]	-- list mustn't be empty
+\end{code}
+
+For a class's method selectors:
+\begin{code}
+data ClassOpPragmas name
+  = NoClassOpPragmas
+  | ClassOpPragmas  (GenPragmas name) -- for method selector
+		    (GenPragmas name) -- for default method
+
+noClassOpPragmas = NoClassOpPragmas
+\end{code}
+
+\begin{code}
+data InstancePragmas name
+  = NoInstancePragmas
+
+  | SimpleInstancePragma	   -- nothing but for the dfun itself...
+	(GenPragmas name)
+
+  | ConstantInstancePragma
+	(GenPragmas name)	   -- for the "dfun" itself
+	[(name, GenPragmas name)]  -- one per class op
+
+  | SpecialisedInstancePragma
+	(GenPragmas name)	   -- for its "dfun"
+	[([Maybe (MonoType name)], -- specialised instance; type...
+	  Int,			   -- #dicts to ignore
+	  InstancePragmas name)]   -- (no SpecialisedInstancePragma please!)
+\end{code}
+
+Some instances for printing (just for debugging, really)
+\begin{code}
+instance Outputable name => Outputable (ClassPragmas name) where
+    ppr sty NoClassPragmas = ppNil
+    ppr sty (SuperDictPragmas sdsel_prags)
+      = ppAbove (ppStr "{-superdict pragmas-}")
+		(ppr sty sdsel_prags)
+
+instance Outputable name => Outputable (ClassOpPragmas name) where
+    ppr sty NoClassOpPragmas = ppNil
+    ppr sty (ClassOpPragmas op_prags defm_prags)
+      = ppAbove (ppCat [ppStr "{-meth-}", ppr sty op_prags])
+		(ppCat [ppStr "{-defm-}", ppr sty defm_prags])
+
+instance Outputable name => Outputable (InstancePragmas name) where
+    ppr sty NoInstancePragmas = ppNil
+    ppr sty (SimpleInstancePragma dfun_pragmas)
+      = ppCat [ppStr "{-dfun-}", ppr sty dfun_pragmas]
+    ppr sty (ConstantInstancePragma dfun_pragmas name_pragma_pairs)
+      = ppAbove (ppCat [ppStr "{-constm-}", ppr sty dfun_pragmas])
+	    	(ppAboves (map pp_pair name_pragma_pairs))
+      where
+	pp_pair (n, prags)
+	  = ppCat [ppr sty n, ppEquals, ppr sty prags]
+
+    ppr sty (SpecialisedInstancePragma dfun_pragmas spec_pragma_info)
+      = ppAbove (ppCat [ppStr "{-spec'd-}", ppr sty dfun_pragmas])
+	    	(ppAboves (map pp_info spec_pragma_info))
+      where
+	pp_info (ty_maybes, num_dicts, prags)
+	  = ppBesides [ppLbrack, ppInterleave ppSP (map pp_ty ty_maybes), ppRbrack,
+		       ppLparen, ppInt num_dicts, ppRparen, ppEquals, ppr sty prags]
+	pp_ty Nothing = ppStr "_N_"
+	pp_ty (Just t)= ppr sty t
+
+instance Outputable name => Outputable (GenPragmas name) where
+    ppr sty NoGenPragmas = ppNil
+    ppr sty (GenPragmas arity_maybe upd_maybe def strictness unfolding specs)
+      = ppCat [pp_arity arity_maybe, pp_upd upd_maybe, -- ToDo: print def?
+	       pp_str strictness, pp_unf unfolding,
+	       pp_specs specs]
+      where
+    	pp_arity Nothing  = ppNil
+	pp_arity (Just i) = ppBeside (ppStr "ARITY=") (ppInt i)
+
+	pp_upd Nothing  = ppNil
+	pp_upd (Just u) = ppInfo sty id u
+
+	pp_str NoImpStrictness = ppNil
+	pp_str (ImpStrictness is_bot demands wrkr_prags)
+	  = ppBesides [ppStr "IS_BOT=", ppr sty is_bot,
+		       ppStr "STRICTNESS=", ppStr (showList demands ""),
+		       ppStr " {", ppr sty wrkr_prags, ppStr "}"]
+
+	pp_unf NoImpUnfolding = ppStr "NO_UNFOLDING"
+	pp_unf (ImpMagicUnfolding m) = ppBeside (ppStr "MAGIC=") (ppPStr m)
+	pp_unf (ImpUnfolding g core) = ppBeside (ppStr "UNFOLD=") (ppr sty core)
+
+	pp_specs [] = ppNil
+	pp_specs specs
+	  = ppBesides [ppStr "SPECS=[", ppInterleave ppSP (map pp_spec specs), ppStr "]"]
+	  where
+	    pp_spec (ty_maybes, num_dicts, gprags)
+	      = ppCat [ppLbrack, ppInterleave ppSP (map pp_MaB ty_maybes), ppRbrack, ppInt num_dicts, ppr sty gprags]
+
+	    pp_MaB Nothing  = ppStr "_N_"
+	    pp_MaB (Just x) = ppr sty x
+\end{code}
diff --git a/ghc/compiler/hsSyn/HsSyn.lhs b/ghc/compiler/hsSyn/HsSyn.lhs
new file mode 100644
index 0000000000..447027c8bd
--- /dev/null
+++ b/ghc/compiler/hsSyn/HsSyn.lhs
@@ -0,0 +1,113 @@
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+%
+\section{Haskell abstract syntax definition}
+
+This module glues together the pieces of the Haskell abstract syntax,
+which is declared in the various \tr{Hs*} modules.  This module,
+therefore, is almost nothing but re-exporting.
+
+\begin{code}
+#include "HsVersions.h"
+
+module HsSyn (
+
+	-- NB: don't reexport HsCore or HsPragmas;
+	-- this module tells about "real Haskell"
+
+	HsSyn.. ,
+	HsBinds.. ,
+	HsDecls.. ,
+	HsExpr.. ,
+	HsImpExp.. ,
+	HsLit.. ,
+	HsMatches.. ,
+	HsPat.. ,
+	HsTypes..
+
+     ) where
+
+import Ubiq{-uitous-}
+
+-- friends:
+import HsBinds
+import HsDecls
+import HsExpr
+import HsImpExp
+import HsLit
+import HsMatches
+import HsPat
+import HsTypes
+import HsPragmas	( ClassPragmas, ClassOpPragmas,
+			  DataPragmas, GenPragmas, InstancePragmas
+			)
+-- others:
+import FiniteMap	( FiniteMap )
+import Outputable	( ifPprShowAll, interpp'SP, Outputable(..){-instances-} )
+import Pretty
+import SrcLoc		( SrcLoc{-instances-} )
+\end{code}
+
+@Fake@ is a placeholder type; for when tyvars and uvars aren't used.
+\begin{code}
+data Fake = Fake
+instance Eq Fake
+instance Outputable Fake
+\end{code}
+
+All we actually declare here is the top-level structure for a module.
+\begin{code}
+data HsModule tyvar uvar name pat
+  = HsModule
+	FAST_STRING		-- module name
+	(Maybe [IE name])	-- export list; Nothing => export everything
+				-- Just [] => export *nothing* (???)
+				-- Just [...] => as you would expect...
+	[ImportedInterface tyvar uvar name pat]
+				-- We snaffle interesting stuff out of the
+				-- imported interfaces early on, adding that
+				-- 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!
+	[Sig name]		-- "Sigs" are folded into the "HsBinds"
+				-- pretty early on, so this list is
+				-- often either empty or just the
+				-- interface signatures.
+	SrcLoc
+\end{code}
+
+\begin{code}
+instance (NamedThing name, Outputable name, Outputable pat,
+	  Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar)
+	=> Outputable (HsModule tyvar uvar name pat) where
+
+    ppr sty (HsModule name exports imports fixities
+		      typedecls typesigs classdecls instdecls instsigs
+		      defdecls binds sigs src_loc)
+      = ppAboves [
+	    ifPprShowAll sty (ppr sty src_loc),
+	    case exports of
+	      Nothing -> ppCat [ppPStr SLIT("module"), ppPStr name, ppPStr SLIT("where")]
+	      Just es -> ppAboves [
+			    ppCat [ppPStr SLIT("module"), ppPStr name, ppLparen],
+			    ppNest 8 (interpp'SP sty es),
+			    ppNest 4 (ppPStr SLIT(") where"))
+			  ],
+	    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
+	]
+      where
+	pp_nonnull [] = ppNil
+	pp_nonnull xs = ppAboves (map (ppr sty) xs)
+\end{code}
diff --git a/ghc/compiler/hsSyn/HsTypes.lhs b/ghc/compiler/hsSyn/HsTypes.lhs
new file mode 100644
index 0000000000..471c620cf8
--- /dev/null
+++ b/ghc/compiler/hsSyn/HsTypes.lhs
@@ -0,0 +1,265 @@
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+%
+\section[HsTypes]{Abstract syntax: user-defined types}
+
+If compiled without \tr{#define COMPILING_GHC}, you get
+(part of) a Haskell-abstract-syntax library.  With it,
+you get part of GHC.
+
+\begin{code}
+#include "HsVersions.h"
+
+module HsTypes (
+	PolyType(..), MonoType(..),
+	Context(..), ClassAssertion(..)
+
+#ifdef COMPILING_GHC
+	, cmpPolyType, cmpMonoType
+	, pprParendMonoType, pprContext
+	, extractMonoTyNames, extractCtxtTyNames
+#endif
+    ) where
+
+#ifdef COMPILING_GHC
+import Ubiq{-uitous-}
+
+import Outputable	( interppSP, ifnotPprForUser )
+import Pretty
+import ProtoName	( cmpProtoName, ProtoName )
+import Type		( Kind )
+import Util		( cmpList, panic# )
+
+#endif {- COMPILING_GHC -}
+\end{code}
+
+This is the syntax for types as seen in type signatures.
+
+\begin{code}
+data PolyType name
+  = HsPreForAllTy	(Context name)
+			(MonoType name)
+
+	-- The renamer turns HsPreForAllTys into HsForAllTys when they
+	-- occur in signatures, to make the binding of variables
+	-- explicit.  This distinction is made visible for
+	-- non-COMPILING_GHC code, because you probably want to do the
+	-- same thing.
+
+  | HsForAllTy		[name]
+			(Context name)
+			(MonoType name)
+
+type Context name = [ClassAssertion name]
+
+type ClassAssertion name = (name, name)
+
+data MonoType name
+  = MonoTyVar		name		-- Type variable
+
+  | MonoTyApp		name		-- Type constructor or variable
+			[MonoType 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)
+
+  | MonoListTy		(MonoType name) -- list type
+  | MonoTupleTy		[MonoType name] -- tuple type (length gives arity)
+
+#ifdef COMPILING_GHC
+  -- these next two are only used in unfoldings in interfaces
+  | MonoDictTy		name	-- Class
+			(MonoType name)
+
+  | MonoForAllTy	[(name, Kind)]
+			(MonoType name)
+	-- *** 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 -}
+\end{code}
+
+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_
+cmpContext  :: (a -> a -> TAG_) -> Context  a -> Context  a -> TAG_
+
+-- 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"
+# endif
+
+cmpPolyType cmp (HsForAllTy tvs1 c1 t1) (HsForAllTy tvs2 c2 t2)
+  = case (cmp_tvs tvs1 tvs2) of
+      EQ_ -> case (cmpContext cmp c1 c2) of
+	       EQ_ -> cmpMonoType cmp t1 t2
+	       xxx -> xxx
+      xxx -> xxx
+  where
+    cmp_tvs [] [] = EQ_
+    cmp_tvs [] _  = LT_
+    cmp_tvs _  [] = GT_
+    cmp_tvs (a:as) (b:bs)
+      = case cmp a b of { EQ_ -> cmp_tvs as bs; xxx -> xxx }
+    cmp_tvs _ _ = panic# "cmp_tvs"
+
+-----------
+cmpMonoType 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
+
+cmpMonoType cmp (MonoTyApp tc1 tys1) (MonoTyApp tc2 tys2)
+  = case cmp tc1 tc2 of { EQ_ -> cmpList (cmpMonoType cmp) tys1 tys2; xxx -> xxx }
+
+cmpMonoType cmp (MonoFunTy a1 b1) (MonoFunTy a2 b2)
+  = case cmpMonoType cmp a1 a2 of { EQ_ -> cmpMonoType cmp b1 b2; xxx -> xxx }
+
+cmpMonoType cmp (MonoDictTy c1 ty1)   (MonoDictTy c2 ty2)
+  = case cmp c1 c2 of { EQ_ -> cmpMonoType cmp ty1 ty2; xxx -> xxx }
+
+cmpMonoType 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 (MonoTyApp tc1 tys1)	= ILIT(4)
+    tag (MonoFunTy a1 b1)	= ILIT(5)
+    tag (MonoDictTy c1 ty1)	= ILIT(7)
+
+-------------------
+cmpContext cmp a b
+  = cmpList cmp_ctxt a b
+  where
+    cmp_ctxt (c1, tv1) (c2, tv2)
+      = case cmp c1 c2 of { EQ_ -> cmp tv1 tv2; xxx -> xxx }
+
+-------------------
+\end{code}
+
+This is used in various places:
+\begin{code}
+pprContext :: (Outputable name) => PprStyle -> (Context name) -> Pretty
+
+pprContext sty []	    = ppNil
+pprContext sty [(clas, ty)] = ppCat [ppr sty clas, ppr sty ty, ppStr "=>"]
+pprContext sty context
+  = ppBesides [ppLparen,
+	   ppInterleave ppComma (map pp_assert context),
+	   ppRparen, ppStr " =>"]
+  where
+    pp_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 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]
+
+instance (Outputable name) => Outputable (MonoType name) where
+    ppr = pprMonoType
+
+pREC_TOP = (0 :: Int)
+pREC_FUN = (1 :: Int)
+pREC_CON = (2 :: Int)
+
+-- printing works more-or-less as for Types
+
+pprMonoType, pprParendMonoType :: (Outputable name) => PprStyle -> MonoType name -> Pretty
+
+pprMonoType sty ty  	 = ppr_mono_ty sty pREC_TOP ty
+pprParendMonoType sty ty = ppr_mono_ty sty pREC_CON ty
+
+ppr_mono_ty sty ctxt_prec (MonoTyVar name) = ppr sty name
+
+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]]
+
+ppr_mono_ty sty ctxt_prec (MonoTupleTy tys)
+ = ppBesides [ppLparen, ppInterleave ppComma (map (ppr sty) tys), ppRparen]
+
+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 ]
+
+-- 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 -}
+\end{code}
+
+Get the type variable names from a @MonoType@.  Don't use class @Eq@
+because @ProtoNames@ aren't in it.
+
+\begin{code}
+#ifdef COMPILING_GHC
+
+extractCtxtTyNames :: (name -> name -> Bool) -> Context  name -> [name]
+extractMonoTyNames :: (name -> name -> Bool) -> MonoType name -> [name]
+
+extractCtxtTyNames eq ctxt
+  = foldr get [] ctxt
+  where
+    get (clas, tv) acc
+      | is_elem eq tv acc = acc
+      | otherwise	  = tv : acc
+
+extractMonoTyNames eq ty
+  = get ty []
+  where
+    get (MonoTyApp con tys) acc = foldr get acc tys
+    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 name)    acc
+      | is_elem eq name acc	= acc
+      | otherwise		= name : acc
+
+is_elem eq n []     = False
+is_elem eq n (x:xs) = n `eq` x || is_elem eq n xs
+
+#endif {- COMPILING_GHC -}
+\end{code}
diff --git a/ghc/compiler/main/CmdLineOpts.hi b/ghc/compiler/main/CmdLineOpts.hi
deleted file mode 100644
index 91c9490256..0000000000
--- a/ghc/compiler/main/CmdLineOpts.hi
+++ /dev/null
@@ -1,22 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface CmdLineOpts where
-import MainMonad(MainIO(..))
-import Maybes(Labda)
-type CmdLineInfo = (GlobalSwitch -> SwitchResult, [CoreToDo], [StgToDo])
-data CoreToDo   = CoreDoSimplify (SimplifierSwitch -> SwitchResult) | Core_Unused_Flag_1 | CoreDoCalcInlinings1 | CoreDoCalcInlinings2 | CoreDoFloatInwards | CoreDoFullLaziness | CoreLiberateCase | CoreDoPrintCore | CoreDoStaticArgs | CoreDoStrictness | CoreDoSpecialising | CoreDoDeforest | CoreDoAutoCostCentres | CoreDoFoldrBuildWorkerWrapper | CoreDoFoldrBuildWWAnal
-data GlobalSwitch
-  = ProduceC [Char] | ProduceS [Char] | ProduceHi [Char] | AsmTarget [Char] | ForConcurrent | Haskell_1_3 | GlasgowExts | CompilingPrelude | HideBuiltinNames | HideMostBuiltinNames | EnsureSplittableC [Char] | Verbose | PprStyle_User | PprStyle_Debug | PprStyle_All | DoCoreLinting | EmitArityChecks | OmitInterfacePragmas | OmitDerivedRead | OmitReexportedInstances | UnfoldingUseThreshold Int | UnfoldingCreationThreshold Int | UnfoldingOverrideThreshold Int | ReportWhyUnfoldingsDisallowed | UseGetMentionedVars | ShowPragmaNameErrs | NameShadowingNotOK | SigsRequired | SccProfilingOn | AutoSccsOnExportedToplevs | AutoSccsOnAllToplevs | AutoSccsOnIndividualCafs | SccGroup [Char] | DoTickyProfiling | DoSemiTagging | FoldrBuildOn | FoldrBuildTrace | SpecialiseImports | ShowImportSpecs | OmitDefaultInstanceMethods | SpecialiseOverloaded | SpecialiseUnboxed | SpecialiseAll | SpecialiseTrace | OmitBlackHoling | StgDoLetNoEscapes | IgnoreStrictnessPragmas | IrrefutableTuples | IrrefutableEverything | AllStrict | NumbersStrict | AllDemanded | ReturnInRegsThreshold Int | VectoredReturnThreshold Int | D_dump_rif2hs | D_dump_rn4 | D_dump_tc | D_dump_deriv | D_dump_ds | D_dump_occur_anal | D_dump_simpl | D_dump_spec | D_dump_stranal | D_dump_deforest | D_dump_stg | D_dump_absC | D_dump_flatC | D_dump_realC | D_dump_asm | D_show_passes | D_verbose_core2core | D_verbose_stg2stg | D_simplifier_stats | D_source_stats
-type MainIO a = _State _RealWorld -> (a, _State _RealWorld)
-data Labda a 
-data SimplifierSwitch   = SimplOkToDupCode | SimplFloatLetsExposingWHNF | SimplOkToFloatPrimOps | SimplAlwaysFloatLetsFromLets | SimplDoCaseElim | SimplReuseCon | SimplCaseOfCase | SimplLetToCase | SimplMayDeleteConjurableIds | SimplPedanticBottoms | SimplDoArityExpand | SimplDoFoldrBuild | SimplDoNewOccurAnal | SimplDoInlineFoldrBuild | IgnoreINLINEPragma | SimplDoLambdaEtaExpansion | SimplDoEtaReduction | EssentialUnfoldingsOnly | ShowSimplifierProgress | MaxSimplifierIterations Int | SimplUnfoldingUseThreshold Int | SimplUnfoldingCreationThreshold Int | KeepSpecPragmaIds | KeepUnusedBindings | SimplNoLetFromCase | SimplNoLetFromApp | SimplNoLetFromStrictLet | SimplDontFoldBackAppend
-data StgToDo   = StgDoStaticArgs | StgDoUpdateAnalysis | StgDoLambdaLift | StgDoMassageForProfiling | D_stg_stats
-data SwitchResult   = SwBool Bool | SwString [Char] | SwInt Int
-classifyOpts :: [[Char]] -> _State _RealWorld -> ((GlobalSwitch -> SwitchResult, [CoreToDo], [StgToDo]), _State _RealWorld)
-intSwitchSet :: (a -> SwitchResult) -> (Int -> a) -> Labda Int
-stringSwitchSet :: (a -> SwitchResult) -> ([Char] -> a) -> Labda [Char]
-switchIsOn :: (a -> SwitchResult) -> a -> Bool
-instance Eq GlobalSwitch
-instance Eq SimplifierSwitch
-instance Ord GlobalSwitch
-instance Ord SimplifierSwitch
-
diff --git a/ghc/compiler/main/CmdLineOpts.lhs b/ghc/compiler/main/CmdLineOpts.lhs
index 4588a889f2..cf036450aa 100644
--- a/ghc/compiler/main/CmdLineOpts.lhs
+++ b/ghc/compiler/main/CmdLineOpts.lhs
@@ -1,34 +1,20 @@
 %
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The AQUA Project, Glasgow University, 1996
 %
 \section[CmdLineOpts]{Things to do with command-line options}
 
 \begin{code}
 #include "HsVersions.h"
 
-module CmdLineOpts (
-	CmdLineInfo(..), SwitchResult(..),
-	GlobalSwitch(..), SimplifierSwitch(..),
-	CoreToDo(..),
-	StgToDo(..),
-#ifdef DPH
-	PodizeToDo(..),
-#endif {- Data Parallel Haskell -}
-	
-	classifyOpts,
-	switchIsOn, stringSwitchSet, intSwitchSet,
-	
-	-- to make the interface self-sufficient
-	Maybe, MainIO(..)
-    ) where
-
-import MainMonad
-import Maybes		( maybeToBool, Maybe(..) )
-import Outputable
-import Util
-#ifdef __GLASGOW_HASKELL__
-import PreludeGlaST	-- bad bad bad boy, Will
-#endif
+module CmdLineOpts where
+
+import PreludeGlaST	-- bad bad bad boy, Will (_Array internals)
+import Argv
+
+CHK_Ubiq() -- debugging consistency check
+
+import Maybes		( assocMaybe, firstJust, maybeToBool, Maybe(..) )
+import Util		( panic, panic#, assertPanic )
 \end{code}
 
 A command-line {\em switch} is (generally) either on or off; e.g., the
@@ -45,31 +31,17 @@ main loop (\tr{main/Main.lhs}), in the Core-to-Core processing loop
 (\tr{simplCore/SimplCore.lhs), and in the STG-to-STG processing loop
 (\tr{simplStg/SimplStg.lhs}).
 
-We use function @classifyOpts@ to take raw command-line arguments from
-@GetArgs@ and get back the @CmdLineInfo@, which is what we really
-want.
-
 %************************************************************************
 %*									*
-\subsection[CmdLineOpts-datatype]{Datatypes associated with command-line options}
+\subsection{Datatypes associated with command-line options}
 %*									*
 %************************************************************************
 
 \begin{code}
-type CmdLineInfo 
-  = (GlobalSwitch -> SwitchResult,	-- Switch lookup function
-     [CoreToDo],			-- Core-to-core spec
-#ifdef DPH 
-     [PodizeToDo],			-- Podizer spec
-     [CoreToDo],			-- post podized Core-to-core spec 
-#endif
-     [StgToDo]				-- Stg-to-stg spec
-    )
-
 data SwitchResult
-  = SwBool	Bool	-- on/off
-  | SwString	String	-- nothing or a String
-  | SwInt	Int	-- nothing or an Int
+  = SwBool	Bool		-- on/off
+  | SwString	FAST_STRING	-- nothing or a String
+  | SwInt	Int		-- nothing or an Int
 \end{code}
 
 \begin{code}
@@ -81,8 +53,6 @@ data CoreToDo		-- These are diff core-to-core passes,
 	(SimplifierSwitch -> SwitchResult)
 			-- Each run of the simplifier can take a different
 			-- set of simplifier-specific flags.
-
-  | Core_Unused_Flag_1
   | CoreDoCalcInlinings1
   | CoreDoCalcInlinings2
   | CoreDoFloatInwards
@@ -96,9 +66,6 @@ data CoreToDo		-- These are diff core-to-core passes,
   | CoreDoAutoCostCentres
   | CoreDoFoldrBuildWorkerWrapper
   | CoreDoFoldrBuildWWAnal
--- ANDY:
---| CoreDoHaskPrint
---| CoreDoHaskLetlessPrint
 \end{code}
 
 \begin{code}
@@ -112,129 +79,6 @@ data StgToDo
   | D_stg_stats
 \end{code}
 
-\begin{code}
-#ifdef DPH
-data PodizeToDo
-  = PodizeNeeded Int		-- Which dimensioned PODs need vectorizing
-#endif {- Data Parallel Haskell -}
-\end{code}
-
-@GlobalSwitches@ may be visible everywhere in the compiler.
-@SimplifierSwitches@ (which follow) are visible only in the main
-Core-to-Core simplifier.
-
-\begin{code}
-data GlobalSwitch
-  = ProduceC	String	-- generate C output into this file
-  | ProduceS	String	-- generate native-code assembler into this file
-  | ProduceHi	String	-- generate .hi interface  into this file
-
-  | AsmTarget	String  -- architecture we are generating code for
-  | ForConcurrent
-
-  | Haskell_1_3		-- if set => Haskell 1.3; else 1.2
-  | GlasgowExts		-- Glasgow Haskell extensions allowed
-  | CompilingPrelude	-- Compiling prelude source
-
-  | HideBuiltinNames 	-- fiddle builtin namespace; used for compiling Prelude
-  | HideMostBuiltinNames
-  | EnsureSplittableC String -- (by globalising all top-level Ids w/ this String)
-
-  | Verbose
-  | PprStyle_User	-- printing "level" (mostly for debugging)
-  | PprStyle_Debug
-  | PprStyle_All
-
-  | DoCoreLinting	-- paranoia flags
-  | EmitArityChecks
-
-  | OmitInterfacePragmas
-  | OmitDerivedRead
-  | OmitReexportedInstances
-
-  | UnfoldingUseThreshold      Int  -- global one; see also SimplUnf...
-  | UnfoldingCreationThreshold Int  -- ditto
-  | UnfoldingOverrideThreshold Int
-
-  | ReportWhyUnfoldingsDisallowed
-  | UseGetMentionedVars
-  | ShowPragmaNameErrs
-  | NameShadowingNotOK
-  | SigsRequired
-
-  | SccProfilingOn
-  | AutoSccsOnExportedToplevs
-  | AutoSccsOnAllToplevs
-  | AutoSccsOnIndividualCafs
-  | SccGroup String	-- name of "group" for this cost centres in this module
-
-  | DoTickyProfiling
-
-  | DoSemiTagging
-
-  -- ToDo: turn these into SimplifierSwitches?
-  | FoldrBuildOn	-- If foldr/build-style transformations are on.
-			-- See also SimplDoFoldrBuild, which is used
-			-- inside the simplifier.
-  | FoldrBuildTrace	-- show all foldr/build optimisations.
-
-  | SpecialiseImports	   -- Treat non-essential spec requests as errors
-  | ShowImportSpecs	   -- Output spec requests for non-essential specs
-  | OmitDefaultInstanceMethods
-  | SpecialiseOverloaded
-  | SpecialiseUnboxed
-  | SpecialiseAll
-  | SpecialiseTrace
-
-  -- this batch of flags is for particular experiments;
-  -- v unlikely to be used in any other circumstance
-  | OmitBlackHoling
-  | StgDoLetNoEscapes
-  | IgnoreStrictnessPragmas -- ToDo: still useful?
-  | IrrefutableTuples	    -- We inject extra "LazyPat"s in the typechecker
-  | IrrefutableEverything   -- (TcPat); doing it any earlier would mean that
-			    -- deriving-generated code wouldn't be irrefutablified.
-  | AllStrict
-  | NumbersStrict
-  | AllDemanded
-
-  | ReturnInRegsThreshold   Int
-  | VectoredReturnThreshold Int -- very likely UNUSED
-
-  | D_dump_rif2hs	-- debugging: print out various things
-  | D_dump_rn4
-  | D_dump_tc
-  | D_dump_deriv
-  | D_dump_ds
-  | D_dump_occur_anal
-  | D_dump_simpl
-  | D_dump_spec
-  | D_dump_stranal
-  | D_dump_deforest
-  | D_dump_stg
-  | D_dump_absC
-  | D_dump_flatC
-  | D_dump_realC
-  | D_dump_asm
-  | D_show_passes
---ANDY:  | D_dump_core_passes_info	-- A Gill-ism
-
-  | D_verbose_core2core
-  | D_verbose_stg2stg
-  | D_simplifier_stats
-  | D_source_stats
-
-#ifdef DPH
-  | PodizeIntelligent
-  | PodizeAggresive
-  | PodizeVeryAggresive
-  | PodizeExtremelyAggresive
-  | D_dump_pod
-  | D_dump_psimpl
-  | D_dump_nextC
-#endif {- Data Parallel Haskell -}
-\end{code}
-
 \begin{code}
 data SimplifierSwitch
   = SimplOkToDupCode
@@ -251,7 +95,6 @@ data SimplifierSwitch
   | SimplDoFoldrBuild	 -- This is the per-simplification flag;
 			 -- see also FoldrBuildOn, used elsewhere
 			 -- in the compiler.
-  | SimplDoNewOccurAnal	 --  use the *new*, all singing, Occurance analysis
   | SimplDoInlineFoldrBuild
 			 -- inline foldr/build (*after* f/b rule is used)
 
@@ -280,194 +123,156 @@ data SimplifierSwitch
   | SimplDontFoldBackAppend
 		 	-- we fold `foldr (:)' back into flip (++),
 			-- but we *don't* want to do it when compiling
-			-- List.hs, otherwise 
+			-- List.hs, otherwise
 			-- xs ++ ys = foldr (:) ys xs
 			-- {- via our loopback -}
 			-- xs ++ ys = xs ++ ys
 			-- Oops!
 			-- So only use this flag inside List.hs
 			-- (Sigh, what a HACK, Andy.  WDP 96/01)
-{-
-  | Extra__SimplFlag1
-  | Extra__SimplFlag2
-  | Extra__SimplFlag3
-  | Extra__SimplFlag4
-  | Extra__SimplFlag5
-  | Extra__SimplFlag6
-  | Extra__SimplFlag7
-  | Extra__SimplFlag8
--}
 \end{code}
 
 %************************************************************************
 %*									*
-\subsection[CmdLineOpts-classify]{Classifying command-line options}
+\subsection{Classifying command-line options}
 %*									*
 %************************************************************************
 
 \begin{code}
-classifyOpts :: [String]	    -- cmd-line args, straight from GetArgs
-	     -> MainIO CmdLineInfo
--- The MainIO bit is because we might find an unknown flag
--- in which case we print an error message
-
-#ifndef DPH
-classifyOpts opts
-  = sep opts [] [] [] -- accumulators...
-  where
-    sep :: [String]				 -- cmd-line opts (input)
-	-> [GlobalSwitch]			 -- switch accumulator
-	-> [CoreToDo] -> [StgToDo]		 -- to_do accumulators
-	-> MainIO CmdLineInfo			 -- result
-
-    sep [] glob_sw core_td stg_td
-      = returnMn (
-	  isAmong glob_sw,
-	  reverse core_td,
-	  reverse stg_td
-	)
-
-    sep (opt1:opts) glob_sw core_td stg_td
-
-#else {- Data Parallel Haskell -}
-classifyOpts opts
-  = sep opts [] [] [] [] [] -- accumulators...
+lookup	   :: FAST_STRING -> Bool
+lookup_int :: FAST_STRING -> Maybe Int
+lookup_str :: FAST_STRING -> Maybe FAST_STRING 
+
+lookup     sw = maybeToBool (assoc_opts sw)
+	
+lookup_str sw = let
+		    unpk_sw = _UNPK_ sw
+		in
+		case (firstJust (map (starts_with unpk_sw) unpacked_opts)) of
+		  Nothing -> Nothing
+		  Just xx -> Just (_PK_ xx)
+
+lookup_int sw = case (lookup_str sw) of
+		  Nothing -> Nothing
+		  Just xx -> Just (read (_UNPK_ xx))
+
+assoc_opts    = assocMaybe [ (a, True) | a <- argv ]
+unpacked_opts = map _UNPK_ argv
+
+starts_with :: String -> String -> Maybe String
+
+starts_with []     str = Just str
+starts_with (c:cs) (s:ss)
+  = if c /= s then Nothing else starts_with cs ss
+\end{code}
+
+\begin{code}
+opt_AllDemanded			= lookup  SLIT("-fall-demanded")
+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_CompilingPrelude		= lookup  SLIT("-prelude")
+opt_D_dump_absC			= lookup  SLIT("-ddump-absC")
+opt_D_dump_asm			= lookup  SLIT("-ddump-asm")
+opt_D_dump_deforest		= lookup  SLIT("-ddump-deforest")
+opt_D_dump_deriv		= lookup  SLIT("-ddump-deriv")
+opt_D_dump_ds			= lookup  SLIT("-ddump-ds")
+opt_D_dump_flatC		= lookup  SLIT("-ddump-flatC")
+opt_D_dump_occur_anal		= lookup  SLIT("-ddump-occur-anal")
+opt_D_dump_rdr			= lookup  SLIT("-ddump-rdr")
+opt_D_dump_realC		= lookup  SLIT("-ddump-realC")
+opt_D_dump_rn			= lookup  SLIT("-ddump-rn")
+opt_D_dump_simpl		= lookup  SLIT("-ddump-simpl")
+opt_D_dump_spec			= lookup  SLIT("-ddump-spec")
+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_simplifier_stats		= lookup  SLIT("-dsimplifier-stats")
+opt_D_source_stats		= lookup  SLIT("-dsource-stats")
+opt_D_verbose_core2core		= lookup  SLIT("-dverbose-simpl")
+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_EmitArityChecks		= lookup  SLIT("-darity-checks")
+opt_FoldrBuildOn		= lookup  SLIT("-ffoldr-build-on")
+opt_FoldrBuildTrace		= lookup  SLIT("-ffoldr-build-trace")
+opt_ForConcurrent		= lookup  SLIT("-fconcurrent")
+opt_GlasgowExts			= lookup  SLIT("-fglasgow-exts")
+opt_Haskell_1_3			= lookup  SLIT("-fhaskell-1.3")
+opt_HideBuiltinNames		= lookup  SLIT("-fhide-builtin-names")
+opt_HideMostBuiltinNames	= lookup  SLIT("-fmin-builtin-names")
+opt_IgnoreStrictnessPragmas	= lookup  SLIT("-fignore-strictness-pragmas")
+opt_IrrefutableEverything	= lookup  SLIT("-firrefutable-everything")
+opt_IrrefutableTuples		= lookup  SLIT("-firrefutable-tuples")
+opt_NameShadowingNotOK		= lookup  SLIT("-fname-shadowing-not-ok")
+opt_NumbersStrict		= lookup  SLIT("-fnumbers-strict")
+opt_OmitBlackHoling		= lookup  SLIT("-dno-black-holing")
+opt_OmitDefaultInstanceMethods	= lookup  SLIT("-fomit-default-instance-methods")
+opt_OmitInterfacePragmas	= lookup  SLIT("-fomit-interface-pragmas")
+opt_OmitReexportedInstances	= lookup  SLIT("-fomit-reexported-instances")
+opt_PprStyle_All		= lookup  SLIT("-dppr-all")
+opt_PprStyle_Debug		= lookup  SLIT("-dppr-debug")
+opt_PprStyle_User		= lookup  SLIT("-dppr-user")
+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_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_UseGetMentionedVars		= lookup  SLIT("-fuse-get-mentioned-vars")
+opt_Verbose			= lookup  SLIT("-v")
+opt_AsmTarget 			= lookup_str SLIT("-fasm-")
+opt_SccGroup  			= lookup_str SLIT("-G")
+opt_ProduceC  			= lookup_str SLIT("-C")
+opt_ProduceS  			= lookup_str SLIT("-S")
+opt_ProduceHi 			= lookup_str SLIT("-hi")
+opt_EnsureSplittableC		= lookup_str SLIT("-fglobalise-toplev-names")
+opt_UnfoldingUseThreshold	= lookup_int SLIT("-funfolding-use-threshold")
+opt_UnfoldingCreationThreshold	= lookup_int SLIT("-funfolding-creation-threshold")
+opt_UnfoldingOverrideThreshold	= lookup_int SLIT("-funfolding-override-threshold")
+opt_ReturnInRegsThreshold	= lookup_int SLIT("-freturn-in-regs-threshold")
+\end{code}
+
+\begin{code}
+classifyOpts :: ([CoreToDo],	-- Core-to-Core processing spec
+		 [StgToDo])	-- STG-to-STG   processing spec
+
+classifyOpts = sep argv [] [] -- accumulators...
   where
-    sep :: [String]				 -- cmd-line opts (input)
-	-> [GlobalSwitch]			 -- switch accumulator
-	-> [CoreToDo] -> [PodizeToDo]		 -- to_do accumulators
-	-> [CoreToDo] -> [StgToDo]
-	-> MainIO CmdLineInfo			 -- result
-
-    -- see also the related "simpl_sep" function, used
-    -- to collect up the SimplifierSwitches for a "-fsimplify".
-
-    sep [] glob_sw core_td pod_td pcore_td stg_td
-      = returnMn (
-	  isAmong glob_sw,
-	  reverse core_td,
-	  reverse pod_td,
-	  reverse pcore_td,
-	  reverse stg_td
-	)
-
-    sep (opt1:opts) glob_sw core_td pod_td pcore_td stg_td
-#endif {- Data Parallel Haskell -}
-
-#ifndef DPH
-#define GLOBAL_SW(switch)   sep opts (switch:glob_sw) core_td stg_td
-#define CORE_TD(to_do)	    sep opts glob_sw (to_do:core_td) stg_td
-#define POD_TD(to_do)       sep opts glob_sw core_td stg_td
-#define PAR_CORE_TD(to_do)  sep opts glob_sw core_td stg_td
-#define BOTH_CORE_TD(to_do) sep opts glob_sw (to_do:core_td) stg_td
-#define STG_TD(to_do)	    sep opts glob_sw core_td (to_do:stg_td)
-#define IGNORE_ARG()	    sep opts glob_sw core_td stg_td
-
-#else
-
-#define GLOBAL_SW(switch) sep opts (switch:glob_sw) core_td pod_td pcore_td stg_td
-#define CORE_TD(to_do)	  sep opts glob_sw (to_do:core_td) pod_td pcore_td stg_td
-#define POD_TD(to_do)	  sep opts glob_sw core_td (to_do:pod_td) pcore_td stg_td
-#define PAR_CORE_TD(do)	  sep opts glob_sw core_td pod_td (do:pcore_td) stg_td
-#define BOTH_CORE_TD(do)  sep opts glob_sw (do:core_td) pod_td (do:pcore_td) stg_td
-#define STG_TD(to_do)	  sep opts glob_sw core_td pod_td pcore_td (to_do:stg_td)
-#define IGNORE_ARG()	  sep opts glob_sw core_td pod_td pcore_td stg_td
-
-#endif {- Data Parallel Haskell -}
-
--- ToDo: DPH-ify
-#define GLOBAL_SIMPL_SW(switch) simpl_sep opts (switch:simpl_sw) glob_sw core_td stg_td
-
-      = let
-	    maybe_fasm		= starts_with "-fasm-"  opt1
-	    maybe_G		= starts_with "-G"	opt1
-	    maybe_C		= starts_with "-C"	opt1
-	    maybe_S		= starts_with "-S"	opt1
-	    maybe_hi		= starts_with "-hi"	opt1
-	    maybe_hu		= starts_with "-hu"	opt1
-	    maybe_uut		= starts_with "-funfolding-use-threshold"      opt1
-	    maybe_uct		= starts_with "-funfolding-creation-threshold" opt1
-	    maybe_uot		= starts_with "-funfolding-override-threshold" opt1
-	    maybe_rirt		= starts_with "-freturn-in-regs-threshold"     opt1
-	    maybe_gtn		= starts_with "-fglobalise-toplev-names"       opt1
-	    starts_with_fasm	= maybeToBool maybe_fasm
-	    starts_with_G	= maybeToBool maybe_G
-	    starts_with_C	= maybeToBool maybe_C
-	    starts_with_S	= maybeToBool maybe_S
-	    starts_with_hi	= maybeToBool maybe_hi
-	    starts_with_hu	= maybeToBool maybe_hu
-	    starts_with_uut	= maybeToBool maybe_uut
-	    starts_with_uct	= maybeToBool maybe_uct
-	    starts_with_uot	= maybeToBool maybe_uot
-	    starts_with_rirt	= maybeToBool maybe_rirt
-	    starts_with_gtn	= maybeToBool maybe_gtn
-	    (Just after_fasm)	= maybe_fasm
-	    (Just after_G)	= maybe_G
-	    (Just after_C)	= maybe_C
-	    (Just after_S)	= maybe_S
-	    (Just after_hi)	= maybe_hi
-	    (Just after_hu)	= maybe_hu
-	    (Just after_uut)	= maybe_uut
-	    (Just after_uct)	= maybe_uct
-	    (Just after_uot)	= maybe_uot
-	    (Just after_rirt)	= maybe_rirt
-	    (Just after_gtn)	= maybe_gtn
-	in
-	case opt1 of -- the non-"just match a string" options are at the end...
-	  ',' : _	   -> IGNORE_ARG() -- it is for the parser
-	  "-ddump-rif2hs"  -> GLOBAL_SW(D_dump_rif2hs)
-	  "-ddump-rn4"	   -> GLOBAL_SW(D_dump_rn4)
-	  "-ddump-tc"	   -> GLOBAL_SW(D_dump_tc)
-	  "-ddump-deriv"   -> GLOBAL_SW(D_dump_deriv)
-	  "-ddump-ds"	   -> GLOBAL_SW(D_dump_ds)
-	  "-ddump-stranal" -> GLOBAL_SW(D_dump_stranal)
-	  "-ddump-deforest"-> GLOBAL_SW(D_dump_deforest)
-	  "-ddump-spec"    -> GLOBAL_SW(D_dump_spec)
-	  "-ddump-simpl"   -> GLOBAL_SW(D_dump_simpl)
-	  "-ddump-occur-anal" -> GLOBAL_SW(D_dump_occur_anal)
-#ifdef DPH
-	  "-ddump-pod"    ->  GLOBAL_SW(D_dump_pod)
-	  "-ddump-psimpl" ->  GLOBAL_SW(D_dump_psimpl)
-	  "-ddump-nextC"  ->  GLOBAL_SW(D_dump_nextC)
-#endif {- Data Parallel Haskell -}
-
-	  "-ddump-stg"	  ->  GLOBAL_SW(D_dump_stg)
-	  "-ddump-absC"	  ->  GLOBAL_SW(D_dump_absC)
-	  "-ddump-flatC"  ->  GLOBAL_SW(D_dump_flatC)
-	  "-ddump-realC"  ->  GLOBAL_SW(D_dump_realC)
-          "-ddump-asm"    ->  GLOBAL_SW(D_dump_asm)
-          "-dshow-passes" ->  GLOBAL_SW(D_show_passes)
-
--- ANDY:  "-ddump-haskell"	    -> GLOBAL_SW(D_dump_core_passes_info)
-	  "-dsimplifier-stats"	    -> GLOBAL_SW(D_simplifier_stats)
-	  "-dsource-stats"	    -> GLOBAL_SW(D_source_stats)
-
-	  "-dverbose-simpl" ->GLOBAL_SW(D_verbose_core2core)
-	  "-dverbose-stg" ->  GLOBAL_SW(D_verbose_stg2stg)
-
-	  "-fuse-get-mentioned-vars" -> GLOBAL_SW(UseGetMentionedVars)
-
-	  "-fhaskell-1.3"		-> GLOBAL_SW(Haskell_1_3)
-	  "-dcore-lint"			-> GLOBAL_SW(DoCoreLinting)
-	  "-fomit-interface-pragmas"	-> GLOBAL_SW(OmitInterfacePragmas)
-	  "-fignore-strictness-pragmas" -> GLOBAL_SW(IgnoreStrictnessPragmas)
-	  "-firrefutable-tuples"	-> GLOBAL_SW(IrrefutableTuples)
-	  "-firrefutable-everything"	-> GLOBAL_SW(IrrefutableEverything)
-	  "-fall-strict"		-> GLOBAL_SW(AllStrict)
-	  "-fnumbers-strict"		-> GLOBAL_SW(NumbersStrict)
-	  "-fall-demanded"		-> GLOBAL_SW(AllDemanded)
-
-	  "-fsemi-tagging"   -> GLOBAL_SW(DoSemiTagging)
-
-	  "-fsimplify"       -> -- gather up SimplifierSwitches specially...
-				simpl_sep opts [] glob_sw core_td stg_td
+    sep :: [FAST_STRING]			 -- cmd-line opts (input)
+	-> [CoreToDo] -> [StgToDo]	 -- to_do accumulators
+	-> ([CoreToDo], [StgToDo])	 -- result
+
+    sep [] core_td stg_td -- all done!
+      = (reverse core_td, reverse stg_td)
+
+#	define CORE_TD(to_do) sep opts (to_do:core_td) stg_td
+#	define STG_TD(to_do)  sep opts core_td (to_do:stg_td)
+#	define IGNORE_ARG()   sep opts core_td stg_td
+
+    sep (opt1:opts) core_td stg_td
+      =
+	case (_UNPK_ opt1) of -- the non-"just match a string" options are at the end...
+
+	  ',' : _	-> IGNORE_ARG() -- it is for the parser
+
+	  "-fsimplify"  -> -- gather up SimplifierSwitches specially...
+			   simpl_sep opts [] core_td stg_td
 
 	  "-fcalc-inlinings1"-> CORE_TD(CoreDoCalcInlinings1)
 	  "-fcalc-inlinings2"-> CORE_TD(CoreDoCalcInlinings2)
 	  "-ffloat-inwards"  -> CORE_TD(CoreDoFloatInwards)
 	  "-ffull-laziness"  -> CORE_TD(CoreDoFullLaziness)
-          "-fliberate-case"  -> CORE_TD(CoreLiberateCase)
-          "-fprint-core"     -> CORE_TD(CoreDoPrintCore)
+	  "-fliberate-case"  -> CORE_TD(CoreLiberateCase)
+	  "-fprint-core"     -> CORE_TD(CoreDoPrintCore)
 	  "-fstatic-args"    -> CORE_TD(CoreDoStaticArgs)
 	  "-fstrictness"     -> CORE_TD(CoreDoStrictness)
 	  "-fspecialise"     -> CORE_TD(CoreDoSpecialising)
@@ -475,23 +280,6 @@ classifyOpts opts
 	  "-fadd-auto-sccs"  -> CORE_TD(CoreDoAutoCostCentres)
 	  "-ffoldr-build-worker-wrapper"  -> CORE_TD(CoreDoFoldrBuildWorkerWrapper)
 	  "-ffoldr-build-ww-anal"  -> CORE_TD(CoreDoFoldrBuildWWAnal)
---ANDY:   "-fprint-haskell-core" -> CORE_TD(CoreDoHaskPrint)
---        "-fprint-haskell-letless-core" -> CORE_TD(CoreDoHaskLetlessPrint)
-	  "-fomit-default-instance-methods" -> GLOBAL_SW(OmitDefaultInstanceMethods)
-	  "-fspecialise-overloaded" -> GLOBAL_SW(SpecialiseOverloaded)
-	  "-fspecialise-unboxed"    -> GLOBAL_SW(SpecialiseUnboxed)
-	  "-fspecialise-all" 	    -> GLOBAL_SW(SpecialiseAll)
-	  "-fspecialise-imports"    -> GLOBAL_SW(SpecialiseImports)
-	  "-fshow-import-specs"     -> GLOBAL_SW(ShowImportSpecs)
-	  "-ftrace-specialisation"  -> GLOBAL_SW(SpecialiseTrace)
-
-	  "-freport-disallowed-unfoldings"
-			     -> GLOBAL_SW(ReportWhyUnfoldingsDisallowed)
-
-	  "-fomit-derived-read" -> GLOBAL_SW(OmitDerivedRead)
-
-          "-ffoldr-build-on"	    -> GLOBAL_SW(FoldrBuildOn)
-          "-ffoldr-build-trace"	    -> GLOBAL_SW(FoldrBuildTrace)
 
 	  "-fstg-static-args" -> STG_TD(StgDoStaticArgs)
 	  "-fupdate-analysis" -> STG_TD(StgDoUpdateAnalysis)
@@ -499,156 +287,84 @@ classifyOpts opts
 	  "-flambda-lift"     -> STG_TD(StgDoLambdaLift)
 	  "-fmassage-stg-for-profiling" -> STG_TD(StgDoMassageForProfiling)
 
-	  "-flet-no-escape"   -> GLOBAL_SW(StgDoLetNoEscapes)
-
-#ifdef DPH
-	  "-fpodize-vector"              -> POD_TD(PodizeNeeded 1)
-	  "-fpodize-matrix"              -> POD_TD(PodizeNeeded 2)
-	  "-fpodize-cube"                -> POD_TD(PodizeNeeded 3)
-	  "-fpodize-intelligent"         -> GLOBAL_SW(PodizeIntelligent)
-	  "-fpodize-aggresive"           -> GLOBAL_SW(PodizeAggresive)
-	  "-fpodize-very-aggresive"      -> GLOBAL_SW(PodizeVeryAggresive)
-	  "-fpodize-extremely-aggresive" -> GLOBAL_SW(PodizeExtremelyAggresive)
-#endif {- Data Parallel Haskell -}
-
-	  "-v"		->	    GLOBAL_SW(Verbose)
-
-	  "-fglasgow-exts" ->	    GLOBAL_SW(GlasgowExts)
-	  "-prelude"	->	    GLOBAL_SW(CompilingPrelude)
-
-	  "-fscc-profiling" 	    	    -> GLOBAL_SW(SccProfilingOn)
-	  "-fauto-sccs-on-exported-toplevs" -> GLOBAL_SW(AutoSccsOnExportedToplevs)
-	  "-fauto-sccs-on-all-toplevs"	    -> GLOBAL_SW(AutoSccsOnAllToplevs)
-	  "-fauto-sccs-on-individual-cafs"  -> GLOBAL_SW(AutoSccsOnIndividualCafs)
-
-	  "-fticky-ticky"  -> GLOBAL_SW(DoTickyProfiling)
-
-	  "-dppr-user"	->  	    GLOBAL_SW(PprStyle_User)
-	  "-dppr-debug"	->  	    GLOBAL_SW(PprStyle_Debug)
-	  "-dppr-all"	->  	    GLOBAL_SW(PprStyle_All)
-
-	  "-fhide-builtin-names"-> 	GLOBAL_SW(HideBuiltinNames)
-	  "-fmin-builtin-names"	-> 	GLOBAL_SW(HideMostBuiltinNames)
-
-	  "-fconcurrent"	    -> GLOBAL_SW(ForConcurrent)
-
-	  "-fshow-pragma-name-errs" -> GLOBAL_SW(ShowPragmaNameErrs)
-	  "-fname-shadowing-not-ok" -> GLOBAL_SW(NameShadowingNotOK)
-	  "-fsignatures-required"   -> GLOBAL_SW(SigsRequired)
-	  "-fomit-reexported-instances" -> GLOBAL_SW(OmitReexportedInstances)
-	  "-darity-checks"  -> GLOBAL_SW(EmitArityChecks)
-	  "-dno-black-holing"-> GLOBAL_SW(OmitBlackHoling)
-
-	  _ | starts_with_fasm -> GLOBAL_SW(AsmTarget after_fasm)
-	    | starts_with_G    -> GLOBAL_SW(SccGroup  after_G)  -- profiling "group"
-	    | starts_with_C    -> GLOBAL_SW(ProduceC  after_C)  -- main C output 
-	    | starts_with_S    -> GLOBAL_SW(ProduceS  after_S)  -- main .s output 
-	    | starts_with_hi   -> GLOBAL_SW(ProduceHi after_hi) -- interface 
---UNUSED:   | starts_with_hu   -> GLOBAL_SW(ProduceHu after_hu)	-- usage info
-
-	    | starts_with_uut  -> GLOBAL_SW(UnfoldingUseThreshold      (read after_uut))
-	    | starts_with_uct  -> GLOBAL_SW(UnfoldingCreationThreshold (read after_uct))
-	    | starts_with_uot  -> GLOBAL_SW(UnfoldingOverrideThreshold (read after_uot))
-
-	    | starts_with_rirt -> -- trace ("rirt:"++after_rirt) $
-				  GLOBAL_SW(ReturnInRegsThreshold (read after_rirt))
-
-	    | starts_with_gtn  -> GLOBAL_SW(EnsureSplittableC after_gtn)
-
-
-	  _ -> writeMn stderr ("*** WARNING: bad option: "++opt1++"\n") `thenMn` ( \ _ ->
-		-- NB: the driver is really supposed to handle bad options
-	       IGNORE_ARG() )
+	  _ -> -- NB: the driver is really supposed to handle bad options
+	       IGNORE_ARG()
 
     ----------------
 
-    starts_with :: String -> String -> Maybe String
-
-    starts_with []     str = Just str
-    starts_with (c:cs) (s:ss)
-      = if c /= s then Nothing else starts_with cs ss
-
-    ----------------
-
-    -- ToDo: DPH-ify "simpl_sep"!
-
-    simpl_sep :: [String]			-- cmd-line opts (input)
-	-> [SimplifierSwitch]			-- simplifier-switch accumulator
-	-> [GlobalSwitch]			-- switch accumulator
-	-> [CoreToDo] -> [StgToDo]		-- to_do accumulators
-	-> MainIO CmdLineInfo			-- result
+    simpl_sep :: [FAST_STRING]	    -- cmd-line opts (input)
+	-> [SimplifierSwitch]	    -- simplifier-switch accumulator
+	-> [CoreToDo] -> [StgToDo]  -- to_do accumulators
+	-> ([CoreToDo], [StgToDo])  -- result
 
 	-- "simpl_sep" tailcalls "sep" once it's seen one set
 	-- of SimplifierSwitches for a CoreDoSimplify.
 
 #ifdef DEBUG
-    simpl_sep input@[] simpl_sw glob_sw core_td stg_td
+    simpl_sep input@[] simpl_sw core_td stg_td
       = panic "simpl_sep []"
 #endif
 
 	-- The SimplifierSwitches should be delimited by "(" and ")".
 
-    simpl_sep ("(":opts) [{-better be empty-}] glob_sw core_td stg_td
-      = simpl_sep opts [] glob_sw core_td stg_td
-
-    simpl_sep (")":opts) simpl_sw glob_sw core_td stg_td
-      = let
-	    this_CoreDoSimplify = CoreDoSimplify (isAmongSimpl simpl_sw)
-	in
-	sep opts glob_sw (this_CoreDoSimplify : core_td) stg_td
-
-    simpl_sep (opt1:opts) simpl_sw glob_sw core_td stg_td
-      = let
-	    maybe_suut		= starts_with "-fsimpl-uf-use-threshold"      opt1
-	    maybe_suct		= starts_with "-fsimpl-uf-creation-threshold" opt1
-	    maybe_msi		= starts_with "-fmax-simplifier-iterations"   opt1
+    simpl_sep (opt1:opts) simpl_sw core_td stg_td
+      = case (_UNPK_ opt1) of
+	  "(" -> ASSERT (null simpl_sw)
+		 simpl_sep opts [] core_td stg_td
+	  ")" -> let
+		    this_simpl = CoreDoSimplify (isAmongSimpl simpl_sw)
+		 in
+		 sep opts (this_simpl : core_td) stg_td
+
+#	  define SIMPL_SW(sw) simpl_sep opts (sw:simpl_sw) core_td stg_td
+
+	  -- the non-"just match a string" options are at the end...
+	  "-fshow-simplifier-progress"	    -> SIMPL_SW(ShowSimplifierProgress)
+	  "-fcode-duplication-ok"	    -> SIMPL_SW(SimplOkToDupCode)
+	  "-ffloat-lets-exposing-whnf"	    -> SIMPL_SW(SimplFloatLetsExposingWHNF)
+	  "-ffloat-primops-ok"		    -> SIMPL_SW(SimplOkToFloatPrimOps)
+	  "-falways-float-lets-from-lets"   -> SIMPL_SW(SimplAlwaysFloatLetsFromLets)
+	  "-fdo-case-elim"		    -> SIMPL_SW(SimplDoCaseElim)
+	  "-fdo-eta-reduction"		    -> SIMPL_SW(SimplDoEtaReduction)
+	  "-fdo-lambda-eta-expansion"	    -> SIMPL_SW(SimplDoLambdaEtaExpansion)
+	  "-fdo-foldr-build"		    -> SIMPL_SW(SimplDoFoldrBuild)
+	  "-fdo-not-fold-back-append"	    -> SIMPL_SW(SimplDontFoldBackAppend)
+	  "-fdo-arity-expand"		    -> SIMPL_SW(SimplDoArityExpand)
+	  "-fdo-inline-foldr-build"	    -> SIMPL_SW(SimplDoInlineFoldrBuild)
+	  "-freuse-con"			    -> SIMPL_SW(SimplReuseCon)
+	  "-fcase-of-case"		    -> SIMPL_SW(SimplCaseOfCase)
+	  "-flet-to-case"		    -> SIMPL_SW(SimplLetToCase)
+	  "-fpedantic-bottoms"		    -> SIMPL_SW(SimplPedanticBottoms)
+	  "-fkeep-spec-pragma-ids"	    -> SIMPL_SW(KeepSpecPragmaIds)
+	  "-fkeep-unused-bindings"	    -> SIMPL_SW(KeepUnusedBindings)
+	  "-fmay-delete-conjurable-ids"     -> SIMPL_SW(SimplMayDeleteConjurableIds)
+	  "-fessential-unfoldings-only"     -> SIMPL_SW(EssentialUnfoldingsOnly)
+	  "-fignore-inline-pragma"  	    -> SIMPL_SW(IgnoreINLINEPragma)
+	  "-fno-let-from-case"		    -> SIMPL_SW(SimplNoLetFromCase)
+	  "-fno-let-from-app"		    -> SIMPL_SW(SimplNoLetFromApp)
+	  "-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))
+	   where
+	    maybe_suut		= starts_with "-fsimpl-uf-use-threshold"      o
+	    maybe_suct		= starts_with "-fsimpl-uf-creation-threshold" o
+	    maybe_msi		= starts_with "-fmax-simplifier-iterations"   o
 	    starts_with_suut	= maybeToBool maybe_suut
 	    starts_with_suct	= maybeToBool maybe_suct
 	    starts_with_msi	= maybeToBool maybe_msi
 	    (Just after_suut)	= maybe_suut
 	    (Just after_suct)	= maybe_suct
 	    (Just after_msi)	= maybe_msi
-	in
-	case opt1 of -- the non-"just match a string" options are at the end...
-	  "-fshow-simplifier-progress" -> GLOBAL_SIMPL_SW(ShowSimplifierProgress)
-
-	  "-fcode-duplication-ok" -> GLOBAL_SIMPL_SW(SimplOkToDupCode)
-	  "-ffloat-lets-exposing-whnf"	-> GLOBAL_SIMPL_SW(SimplFloatLetsExposingWHNF)
-	  "-ffloat-primops-ok"	-> GLOBAL_SIMPL_SW(SimplOkToFloatPrimOps)
-	  "-falways-float-lets-from-lets" -> GLOBAL_SIMPL_SW(SimplAlwaysFloatLetsFromLets)
-	  "-fdo-case-elim" -> GLOBAL_SIMPL_SW(SimplDoCaseElim)
-	  "-fdo-eta-reduction" -> GLOBAL_SIMPL_SW(SimplDoEtaReduction)
-	  "-fdo-lambda-eta-expansion" -> GLOBAL_SIMPL_SW(SimplDoLambdaEtaExpansion)
-	  "-fdo-foldr-build"  -> GLOBAL_SIMPL_SW(SimplDoFoldrBuild)
-	  "-fdo-not-fold-back-append"  -> GLOBAL_SIMPL_SW(SimplDontFoldBackAppend)
-	  "-fdo-new-occur-anal"  -> GLOBAL_SIMPL_SW(SimplDoNewOccurAnal)
-	  "-fdo-arity-expand"  -> GLOBAL_SIMPL_SW(SimplDoArityExpand)
-	  "-fdo-inline-foldr-build"  -> GLOBAL_SIMPL_SW(SimplDoInlineFoldrBuild)
-	  "-freuse-con"       -> GLOBAL_SIMPL_SW(SimplReuseCon)
-	  "-fcase-of-case"    ->    GLOBAL_SIMPL_SW(SimplCaseOfCase)
-	  "-flet-to-case"     -> GLOBAL_SIMPL_SW(SimplLetToCase)
-	  "-fpedantic-bottoms" -> GLOBAL_SIMPL_SW(SimplPedanticBottoms)
-	  "-fkeep-spec-pragma-ids" -> GLOBAL_SIMPL_SW(KeepSpecPragmaIds)
-	  "-fkeep-unused-bindings" -> GLOBAL_SIMPL_SW(KeepUnusedBindings)
-	  "-fmay-delete-conjurable-ids" -> GLOBAL_SIMPL_SW(SimplMayDeleteConjurableIds)
-	  "-fessential-unfoldings-only" -> GLOBAL_SIMPL_SW(EssentialUnfoldingsOnly) 
-	  "-fignore-inline-pragma"  -> GLOBAL_SIMPL_SW(IgnoreINLINEPragma)
-	  "-fno-let-from-case"  -> GLOBAL_SIMPL_SW(SimplNoLetFromCase)
-	  "-fno-let-from-app"  -> GLOBAL_SIMPL_SW(SimplNoLetFromApp)
-	  "-fno-let-from-strict-let"  -> GLOBAL_SIMPL_SW(SimplNoLetFromStrictLet)
-
-	  _ | starts_with_msi  -> GLOBAL_SIMPL_SW(MaxSimplifierIterations (read after_msi))
-	    | starts_with_suut  -> GLOBAL_SIMPL_SW(SimplUnfoldingUseThreshold (read after_suut))
-	    | starts_with_suct  -> GLOBAL_SIMPL_SW(SimplUnfoldingCreationThreshold (read after_suct))
-
-	  _ -> writeMn stderr ("*** WARNING: bad simplifier option: "++opt1++"\n") `thenMn` ( \ _ ->
-		-- NB: the driver is really supposed to handle bad options
-	       simpl_sep opts simpl_sw glob_sw core_td stg_td )
+
+	  _ -> -- NB: the driver is really supposed to handle bad options
+	       simpl_sep opts simpl_sw core_td stg_td
 \end{code}
 
 %************************************************************************
 %*									*
-\subsection[CmdLineOpts-order]{Switch ordering}
+\subsection{Switch ordering}
 %*									*
 %************************************************************************
 
@@ -656,13 +372,6 @@ In spite of the @Produce*@ and @SccGroup@ constructors, these things
 behave just like enumeration types.
 
 \begin{code}
-instance Eq GlobalSwitch where
-    a == b = tagOf_Switch a _EQ_ tagOf_Switch b
-
-instance Ord GlobalSwitch where
-    a <  b  = tagOf_Switch a _LT_ tagOf_Switch b
-    a <= b  = tagOf_Switch a _LE_ tagOf_Switch b
-
 instance Eq SimplifierSwitch where
     a == b = tagOf_SimplSwitch a _EQ_ tagOf_SimplSwitch b
 
@@ -670,111 +379,6 @@ instance Ord SimplifierSwitch where
     a <  b  = tagOf_SimplSwitch a _LT_ tagOf_SimplSwitch b
     a <= b  = tagOf_SimplSwitch a _LE_ tagOf_SimplSwitch b
 
-tagOf_Switch (ProduceC _)		=(ILIT(0) :: FAST_INT)
-tagOf_Switch (ProduceS _)		= ILIT(1)
-tagOf_Switch (ProduceHi	_)		= ILIT(2)
-tagOf_Switch (AsmTarget _)              = ILIT(4)
-tagOf_Switch ForConcurrent		= ILIT(6)
-tagOf_Switch Haskell_1_3		= ILIT(8)
-tagOf_Switch GlasgowExts		= ILIT(9)
-tagOf_Switch CompilingPrelude		= ILIT(10)
-tagOf_Switch HideBuiltinNames		= ILIT(11)
-tagOf_Switch HideMostBuiltinNames	= ILIT(12)
-tagOf_Switch (EnsureSplittableC _)	= ILIT(13)
-tagOf_Switch Verbose			= ILIT(14)
-tagOf_Switch PprStyle_User		= ILIT(15)
-tagOf_Switch PprStyle_Debug		= ILIT(16)
-tagOf_Switch PprStyle_All		= ILIT(17)
-tagOf_Switch DoCoreLinting		= ILIT(18)
-tagOf_Switch EmitArityChecks		= ILIT(19)
-tagOf_Switch OmitInterfacePragmas	= ILIT(20)
-tagOf_Switch OmitDerivedRead		= ILIT(21)
-tagOf_Switch OmitReexportedInstances	= ILIT(22)
-tagOf_Switch (UnfoldingUseThreshold _)  = ILIT(23)
-tagOf_Switch (UnfoldingCreationThreshold _) = ILIT(24)
-tagOf_Switch (UnfoldingOverrideThreshold _) = ILIT(25)
-tagOf_Switch ReportWhyUnfoldingsDisallowed = ILIT(26)
-tagOf_Switch UseGetMentionedVars	= ILIT(27)
-tagOf_Switch ShowPragmaNameErrs		= ILIT(28)
-tagOf_Switch NameShadowingNotOK		= ILIT(29)
-tagOf_Switch SigsRequired		= ILIT(30)
-tagOf_Switch SccProfilingOn		= ILIT(31)
-tagOf_Switch AutoSccsOnExportedToplevs	= ILIT(32)
-tagOf_Switch AutoSccsOnAllToplevs	= ILIT(33)
-tagOf_Switch AutoSccsOnIndividualCafs	= ILIT(34)
-tagOf_Switch (SccGroup _)		= ILIT(36)
-tagOf_Switch DoTickyProfiling		= ILIT(37)
-tagOf_Switch DoSemiTagging		= ILIT(38)
-tagOf_Switch FoldrBuildOn		= ILIT(39)
-tagOf_Switch FoldrBuildTrace		= ILIT(40)
-tagOf_Switch SpecialiseImports		= ILIT(41)
-tagOf_Switch ShowImportSpecs		= ILIT(42)
-tagOf_Switch OmitDefaultInstanceMethods	= ILIT(43)
-tagOf_Switch SpecialiseOverloaded	= ILIT(44)
-tagOf_Switch SpecialiseUnboxed		= ILIT(45)
-tagOf_Switch SpecialiseAll		= ILIT(46)
-tagOf_Switch SpecialiseTrace		= ILIT(47)
-
-tagOf_Switch OmitBlackHoling		= ILIT(49)
-tagOf_Switch StgDoLetNoEscapes		= ILIT(50)
-tagOf_Switch IgnoreStrictnessPragmas	= ILIT(51)
-tagOf_Switch IrrefutableTuples		= ILIT(52)
-tagOf_Switch IrrefutableEverything	= ILIT(53)
-tagOf_Switch AllStrict			= ILIT(54)
-tagOf_Switch NumbersStrict		= ILIT(55)
-tagOf_Switch AllDemanded		= ILIT(56)
-
-tagOf_Switch (ReturnInRegsThreshold _)	= ILIT(57)
-tagOf_Switch (VectoredReturnThreshold _)= ILIT(58)
-tagOf_Switch D_dump_rif2hs		= ILIT(59)
-tagOf_Switch D_dump_rn4			= ILIT(60)
-tagOf_Switch D_dump_tc			= ILIT(61)
-tagOf_Switch D_dump_deriv		= ILIT(62)
-tagOf_Switch D_dump_ds			= ILIT(63)
-tagOf_Switch D_dump_simpl		= ILIT(64)
-tagOf_Switch D_dump_spec		= ILIT(65)
-tagOf_Switch D_dump_occur_anal		= ILIT(66)
-tagOf_Switch D_dump_stranal		= ILIT(67)
-tagOf_Switch D_dump_stg			= ILIT(68)
-tagOf_Switch D_dump_absC		= ILIT(69)
-tagOf_Switch D_dump_flatC		= ILIT(70)
-tagOf_Switch D_dump_realC		= ILIT(71)
-tagOf_Switch D_dump_asm			= ILIT(72)
-tagOf_Switch D_show_passes		= ILIT(73)
---ANDY:tagOf_Switch D_dump_core_passes_info	= ILIT(??)
-tagOf_Switch D_verbose_core2core	= ILIT(74)
-tagOf_Switch D_verbose_stg2stg		= ILIT(75)
-tagOf_Switch D_simplifier_stats		= ILIT(76)
-tagOf_Switch D_source_stats		= ILIT(77) {-see note below!-}
-
-#ifndef DPH
-tagOf_Switch _ = case (panic "tagOf_Switch") of -- BUG avoidance
-		   s -> tagOf_Switch s
-
-lAST_SWITCH_TAG = IBOX(tagOf_Switch D_source_stats)
-
-#else {- Data Parallel Haskell -}
-
-tagOf_Switch PodizeIntelligent		= ILIT(90)
-tagOf_Switch PodizeAggresive		= ILIT(91)
-tagOf_Switch PodizeVeryAggresive	= ILIT(92)
-tagOf_Switch PodizeExtremelyAggresive	= ILIT(93)
-tagOf_Switch D_dump_pod			= ILIT(94)
-tagOf_Switch D_dump_psimpl		= ILIT(95)
-tagOf_Switch D_dump_nextC		= ILIT(96)
-
-tagOf_Switch _ = case (panic "tagOf_Switch") of -- BUG avoidance
-		   s -> tagOf_Switch s
-
-lAST_SWITCH_TAG = IBOX(tagOf_Switch D_dump_nextC)
-
-#endif {- Data Parallel Haskell -}
-\end{code}
-
-(Note For Will): Could you please leave a little extra room between
-your last option and @D_dump_spec@... Thanks... jon...
-
-\begin{code}
 tagOf_SimplSwitch SimplOkToDupCode		=(ILIT(0) :: FAST_INT)
 tagOf_SimplSwitch SimplFloatLetsExposingWHNF	= ILIT(1)
 tagOf_SimplSwitch SimplOkToFloatPrimOps		= ILIT(2)
@@ -787,7 +391,6 @@ tagOf_SimplSwitch SimplMayDeleteConjurableIds	= ILIT(9)
 tagOf_SimplSwitch SimplPedanticBottoms		= ILIT(10)
 tagOf_SimplSwitch SimplDoArityExpand		= ILIT(11)
 tagOf_SimplSwitch SimplDoFoldrBuild		= ILIT(12)
-tagOf_SimplSwitch SimplDoNewOccurAnal		= ILIT(13)
 tagOf_SimplSwitch SimplDoInlineFoldrBuild	= ILIT(14)
 tagOf_SimplSwitch IgnoreINLINEPragma 		= ILIT(15)
 tagOf_SimplSwitch SimplDoLambdaEtaExpansion	= ILIT(16)
@@ -805,89 +408,20 @@ tagOf_SimplSwitch SimplNoLetFromStrictLet	= ILIT(28)
 tagOf_SimplSwitch SimplDontFoldBackAppend       = ILIT(29)
 -- If you add anything here, be sure to change lAST_SIMPL_SWITCH_TAG, too!
 
-{-
-tagOf_SimplSwitch Extra__SimplFlag1		= ILIT(26)
-tagOf_SimplSwitch Extra__SimplFlag2		= ILIT(27)
-tagOf_SimplSwitch Extra__SimplFlag3		= ILIT(28)
-tagOf_SimplSwitch Extra__SimplFlag4		= ILIT(29)
-tagOf_SimplSwitch Extra__SimplFlag5		= ILIT(30)
-tagOf_SimplSwitch Extra__SimplFlag6		= ILIT(31)
-tagOf_SimplSwitch Extra__SimplFlag8		= ILIT(32)
--}
-
-tagOf_SimplSwitch _ = case (panic "tagOf_SimplSwitch") of -- BUG avoidance
-			s -> tagOf_SimplSwitch s
+tagOf_SimplSwitch _ = panic# "tagOf_SimplSwitch"
 
 lAST_SIMPL_SWITCH_TAG = IBOX(tagOf_SimplSwitch SimplDontFoldBackAppend)
 \end{code}
 
 %************************************************************************
 %*									*
-\subsection[CmdLineOpts-lookup]{Switch lookup}
+\subsection{Switch lookup}
 %*									*
 %************************************************************************
 
 \begin{code}
-isAmong	     :: [GlobalSwitch]     -> GlobalSwitch     -> SwitchResult
 isAmongSimpl :: [SimplifierSwitch] -> SimplifierSwitch -> SwitchResult
 
-isAmong on_switches
-  = let
-	tidied_on_switches = foldl rm_dups [] on_switches
-
-	sw_tbl :: Array Int SwitchResult
-
-	sw_tbl = (array	(0, lAST_SWITCH_TAG) -- bounds...
-			all_undefined)
-		 // defined_elems
-
-	all_undefined = [ i := SwBool False | i <- [0 .. lAST_SWITCH_TAG ] ]
-
-	defined_elems = map mk_assoc_elem tidied_on_switches
-    in
-#ifndef __GLASGOW_HASKELL__
-    \ switch -> sw_tbl ! IBOX((tagOf_Switch switch))	-- but this is fast!
-#else
-    -- and this is faster!
-    -- (avoid some unboxing, bounds checking, and other horrible things:)
-    case sw_tbl of { _Array bounds_who_needs_'em stuff ->
-    \ switch ->
-	case (indexArray# stuff (tagOf_Switch switch)) of
-	  _Lift v -> v
-    }
-#endif
-  where
-    mk_assoc_elem k@(ProduceC  str) = IBOX(tagOf_Switch k) := SwString str
-    mk_assoc_elem k@(ProduceS  str) = IBOX(tagOf_Switch k) := SwString str
-    mk_assoc_elem k@(ProduceHi str) = IBOX(tagOf_Switch k) := SwString str
---UNUSED:    mk_assoc_elem k@(ProduceHu str) = IBOX(tagOf_Switch k) := SwString str
-    mk_assoc_elem k@(SccGroup  str) = IBOX(tagOf_Switch k) := SwString str
-    mk_assoc_elem k@(AsmTarget str) = IBOX(tagOf_Switch k) := SwString str
-    mk_assoc_elem k@(EnsureSplittableC str) = IBOX(tagOf_Switch k) := SwString str
-
-    mk_assoc_elem k@(UnfoldingUseThreshold      lvl) = IBOX(tagOf_Switch k) := SwInt lvl
-    mk_assoc_elem k@(UnfoldingCreationThreshold lvl) = IBOX(tagOf_Switch k) := SwInt lvl
-    mk_assoc_elem k@(UnfoldingOverrideThreshold lvl) = IBOX(tagOf_Switch k) := SwInt lvl
-
-    mk_assoc_elem k@(ReturnInRegsThreshold lvl) = IBOX(tagOf_Switch k) := SwInt lvl
-
-    mk_assoc_elem k = IBOX(tagOf_Switch k) := SwBool True -- I'm here, Mom!
-
-    -- cannot have duplicates if we are going to use the array thing
-
-    rm_dups switches_so_far switch
-      = if switch `is_elem` switches_so_far
-    	then switches_so_far
-	else switch : switches_so_far
-      where
-	sw `is_elem` []     = False
-	sw `is_elem` (s:ss) = (tagOf_Switch sw) _EQ_ (tagOf_Switch s)
-			    || sw `is_elem` ss
-\end{code}
-
-Same thing for @SimplifierSwitches@; for efficiency reasons, we
-probably do {\em not} want something overloaded.
- \begin{code}
 isAmongSimpl on_switches
   = let
 	tidied_on_switches = foldl rm_dups [] on_switches
@@ -902,17 +436,12 @@ isAmongSimpl on_switches
 
 	defined_elems = map mk_assoc_elem tidied_on_switches
     in
-#ifndef __GLASGOW_HASKELL__
-    \ switch -> sw_tbl ! IBOX((tagOf_SimplSwitch switch)) -- but this is fast!
-#else
-    -- and this is faster!
     -- (avoid some unboxing, bounds checking, and other horrible things:)
     case sw_tbl of { _Array bounds_who_needs_'em stuff ->
     \ switch ->
 	case (indexArray# stuff (tagOf_SimplSwitch switch)) of
 	  _Lift v -> v
     }
-#endif
   where
     mk_assoc_elem k@(MaxSimplifierIterations lvl) = IBOX(tagOf_SimplSwitch k) := SwInt lvl
     mk_assoc_elem k@(SimplUnfoldingUseThreshold      i) = IBOX(tagOf_SimplSwitch k) := SwInt i
@@ -934,7 +463,7 @@ isAmongSimpl on_switches
 
 %************************************************************************
 %*									*
-\subsection[CmdLineOpts-misc]{Misc functions for command-line options}
+\subsection{Misc functions for command-line options}
 %*									*
 %************************************************************************
 
@@ -948,8 +477,8 @@ switchIsOn lookup_fn switch
       _	    	   -> True
 
 stringSwitchSet :: (switch -> SwitchResult)
-		-> (String -> switch)
-		-> Maybe String
+		-> (FAST_STRING -> switch)
+		-> Maybe FAST_STRING
 
 stringSwitchSet lookup_fn switch
   = case (lookup_fn (switch (panic "stringSwitchSet"))) of
@@ -961,8 +490,7 @@ intSwitchSet :: (switch -> SwitchResult)
 	     -> Maybe Int
 
 intSwitchSet lookup_fn switch
-  = -- pprTrace "intSwitchSet:" (ppInt (IBOX (tagOf_Switch (switch (panic "xxx"))))) $
-    case (lookup_fn (switch (panic "intSwitchSet"))) of
+  = case (lookup_fn (switch (panic "intSwitchSet"))) of
       SwInt int -> Just int
       _	    	-> Nothing
 \end{code}
diff --git a/ghc/compiler/main/ErrUtils.hi b/ghc/compiler/main/ErrUtils.hi
deleted file mode 100644
index 2c8cccd059..0000000000
--- a/ghc/compiler/main/ErrUtils.hi
+++ /dev/null
@@ -1,11 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface ErrUtils where
-import Bag(Bag)
-import Pretty(PprStyle, PrettyRep)
-import SrcLoc(SrcLoc)
-type Error = PprStyle -> Int -> Bool -> PrettyRep
-addErrLoc :: SrcLoc -> [Char] -> (PprStyle -> Int -> Bool -> PrettyRep) -> PprStyle -> Int -> Bool -> PrettyRep
-addShortErrLocLine :: SrcLoc -> (PprStyle -> Int -> Bool -> PrettyRep) -> PprStyle -> Int -> Bool -> PrettyRep
-dontAddErrLoc :: [Char] -> (PprStyle -> Int -> Bool -> PrettyRep) -> PprStyle -> Int -> Bool -> PrettyRep
-pprBagOfErrors :: PprStyle -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> Int -> Bool -> PrettyRep
-
diff --git a/ghc/compiler/main/ErrUtils.lhs b/ghc/compiler/main/ErrUtils.lhs
index 5146016e5c..d455ff0b41 100644
--- a/ghc/compiler/main/ErrUtils.lhs
+++ b/ghc/compiler/main/ErrUtils.lhs
@@ -3,25 +3,30 @@
 %
 \section[ErrsUtils]{Utilities for error reporting}
 
-This is an internal module---access to these functions is through
-@Errors@.
-
-DPH errors are in here, too.
-
 \begin{code}
 #include "HsVersions.h"
 
-module ErrUtils where
+module ErrUtils (
+
+	Error(..),
+	addErrLoc, addShortErrLocLine,
+	dontAddErrLoc, pprBagOfErrors,
+
+	TcError(..), TcWarning(..), Message(..),
+	mkTcErr, arityErr
 
-import Bag		( Bag, bagToList )
-import Outputable
-import Pretty		-- to pretty-print error messages
-import SrcLoc		( mkUnknownSrcLoc, SrcLoc )
-import Util
+    ) where
+
+import Ubiq{-uitous-}
+
+import Bag		( bagToList )
+import PprStyle		( PprStyle(..) )
+import Pretty
+import SrcLoc		( mkUnknownSrcLoc, SrcLoc{-instance-} )
 \end{code}
 
 \begin{code}
-type Error = PprStyle -> Pretty
+type Error   = PprStyle -> Pretty
 
 addErrLoc :: SrcLoc -> String -> Error -> Error
 addErrLoc locn title rest_of_err_msg sty
@@ -44,18 +49,35 @@ pprBagOfErrors :: PprStyle -> Bag Error -> Pretty
 pprBagOfErrors sty bag_of_errors
   = let  pretties = map ( \ e -> e sty ) (bagToList bag_of_errors)  in
     ppAboves (map (\ p -> ppAbove ppSP p) pretties)
+\end{code}
+
+TypeChecking Errors
+~~~~~~~~~~~~~~~~~~~
+
+\begin{code}
+type Message   = PprStyle -> Pretty
+type TcError   = Message
+type TcWarning = Message
+
+
+mkTcErr :: SrcLoc 		-- Where
+	-> [Message] 		-- Context
+	-> Message 		-- What went wrong
+	-> TcError		-- The complete error report
+
+mkTcErr locn ctxt msg sty
+  = ppHang (ppBesides [ppr PprForUser locn, ppStr ": ", msg sty])
+    	 4 (ppAboves [msg sty | msg <- ctxt])
+
 
-#ifdef DPH
-addWarningLoc :: SrcLoc -> Error -> Error
-addWarningLoc locn rest_of_err_msg sty
-  = ppHang (ppBesides [ppStr "*** Warning *** ",
-		       ppr PprForUser locn,ppStr ": "])
-    	 4 (ppAbove (rest_of_err_msg sty)
-		    (ppSP))
-
-addWarning :: Error -> Error
-addWarning rest_of_err_msg sty
-  = ppBeside (ppStr "*** Warning *** : ")
-	     (rest_of_err_msg sty)
-#endif {- Data Parallel Haskell -}
+arityErr kind name n m sty =
+    ppBesides [ ppStr "`", ppr sty name, ppStr "' should have ",
+		n_arguments, ppStr ", but has been given ", ppInt m, ppChar '.']
+    where
+	errmsg = kind ++ " has too " ++ quantity ++ " arguments"
+	quantity | m < n     = "few"
+		 | otherwise = "many"
+	n_arguments | n == 0 = ppStr "no arguments"
+		    | n == 1 = ppStr "1 argument"
+		    | True   = ppCat [ppInt n, ppStr "arguments"]
 \end{code}
diff --git a/ghc/compiler/main/Errors.hi b/ghc/compiler/main/Errors.hi
deleted file mode 100644
index 3e17e3184f..0000000000
--- a/ghc/compiler/main/Errors.hi
+++ /dev/null
@@ -1,124 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface Errors where
-import Bag(Bag)
-import CharSeq(CSeq)
-import Class(Class, ClassOp)
-import CmdLineOpts(GlobalSwitch)
-import ErrUtils(Error(..), pprBagOfErrors)
-import ErrsRn(badClassOpErr, badExportNameErr, badImportNameErr, derivingInIfaceErr, derivingNonStdClassErr, dupNamesErr, dupPreludeNameErr, dupSigDeclErr, duplicateImportsInInterfaceErr, inlineInRecursiveBindsErr, methodBindErr, missingSigErr, shadowedNameErr, unknownNameErr, unknownSigDeclErr, weirdImportExportConstraintErr)
-import ErrsTc(UnifyErrContext(..), UnifyErrInfo(..), ambigErr, badMatchErr, badSpecialisationErr, classCycleErr, confusedNameErr, dataConArityErr, defaultErr, derivingEnumErr, derivingIxErr, derivingWhenInstanceExistsErr, dupInstErr, genCantGenErr, instTypeErr, lurkingRank2Err, methodTypeLacksTyVarErr, naughtyCCallContextErr, noInstanceErr, nonBoxedPrimCCallErr, notAsPolyAsSigErr, preludeInstanceErr, reduceErr, sigContextsErr, specCtxtGroundnessErr, specDataNoSpecErr, specDataUnboxedErr, specGroundnessErr, specInstUnspecInstNotFoundErr, topLevelUnboxedDeclErr, tyConArityErr, typeCycleErr, underAppliedTyErr, unifyErr, varyingArgsErr)
-import GenSpecEtc(SignatureInfo)
-import HsBinds(Binds, MonoBinds, ProtoNameMonoBinds(..), RenamedSig(..), Sig)
-import HsExpr(ArithSeqInfo, Expr, Qual, RenamedExpr(..), TypecheckedExpr(..))
-import HsImpExp(IE)
-import HsLit(Literal)
-import HsMatches(GRHS, GRHSsAndBinds, Match, RenamedGRHS(..), RenamedGRHSsAndBinds(..), RenamedMatch(..))
-import HsPat(InPat, ProtoNamePat(..), RenamedPat(..), TypecheckedPat)
-import HsPragmas(ClassOpPragmas, GenPragmas)
-import HsTypes(PolyType)
-import Id(Id)
-import Inst(Inst)
-import Maybes(Labda)
-import Name(Name)
-import NameTypes(FullName, ShortName)
-import PreludePS(_PackedString)
-import Pretty(Delay, PprStyle, Pretty(..), PrettyRep)
-import ProtoName(ProtoName)
-import SimplEnv(UnfoldingGuidance)
-import SrcLoc(SrcLoc)
-import TyCon(TyCon)
-import TyVar(TyVar, TyVarTemplate)
-import UniType(TauType(..), UniType)
-import Unique(Unique)
-data Bag a 
-data Class 
-data ClassOp 
-type Error = PprStyle -> Int -> Bool -> PrettyRep
-data UnifyErrContext
-  = PredCtxt (Expr Name (InPat Name)) | AppCtxt (Expr Name (InPat Name)) (Expr Name (InPat Name)) | TooManyArgsCtxt (Expr Name (InPat Name)) | FunAppCtxt (Expr Name (InPat Name)) (Labda Id) (Expr Name (InPat Name)) UniType UniType Int | OpAppCtxt (Expr Name (InPat Name)) (Expr Name (InPat Name)) (Expr Name (InPat Name)) | SectionLAppCtxt (Expr Name (InPat Name)) (Expr Name (InPat Name)) | SectionRAppCtxt (Expr Name (InPat Name)) (Expr Name (InPat Name)) | CaseCtxt (Expr Name (InPat Name)) [Match Name (InPat Name)] | BranchCtxt (Expr Name (InPat Name)) (Expr Name (InPat Name)) | ListCtxt [Expr Name (InPat Name)] | PatCtxt (InPat Name) | CaseBranchesCtxt [Match Name (InPat Name)] | FilterCtxt (Expr Name (InPat Name)) | GeneratorCtxt (InPat Name) (Expr Name (InPat Name)) | GRHSsBranchCtxt [GRHS Name (InPat Name)] | GRHSsGuardCtxt (Expr Name (InPat Name)) | PatMonoBindsCtxt (InPat Name) (GRHSsAndBinds Name (InPat Name)) | FunMonoBindsCtxt Name [Match Name (InPat Name)] | MatchCtxt UniType UniType | ArithSeqCtxt (Expr Name (InPat Name)) | CCallCtxt [Char] [Expr Name (InPat Name)] | AmbigDictCtxt [Inst] | SigCtxt Id UniType | MethodSigCtxt Name UniType | ExprSigCtxt (Expr Name (InPat Name)) UniType | ValSpecSigCtxt Name UniType SrcLoc | ValSpecSpecIdCtxt Name UniType Name SrcLoc | BindSigCtxt [Id] | SuperClassSigCtxt | CaseBranchCtxt (Match Name (InPat Name)) | Rank2ArgCtxt (Expr Id TypecheckedPat) UniType
-data UnifyErrInfo   = UnifyMisMatch UniType UniType | TypeRec TyVar UniType | UnifyListMisMatch [UniType] [UniType] | UnifyUnboxedMisMatch UniType UniType
-data SignatureInfo 
-data MonoBinds a b 
-type ProtoNameMonoBinds = MonoBinds ProtoName (InPat ProtoName)
-type RenamedSig = Sig Name
-data Sig a 
-data Expr a b 
-type RenamedExpr = Expr Name (InPat Name)
-type TypecheckedExpr = Expr Id TypecheckedPat
-data IE 
-data GRHS a b 
-data GRHSsAndBinds a b 
-data Match a b 
-type RenamedGRHS = GRHS Name (InPat Name)
-type RenamedGRHSsAndBinds = GRHSsAndBinds Name (InPat Name)
-type RenamedMatch = Match Name (InPat Name)
-data InPat a 
-type ProtoNamePat = InPat ProtoName
-type RenamedPat = InPat Name
-data TypecheckedPat 
-data GenPragmas a 
-data Id 
-data Inst 
-data Labda a 
-data Name 
-data PprStyle 
-type Pretty = Int -> Bool -> PrettyRep
-data PrettyRep 
-data ProtoName 
-data SrcLoc 
-data TyCon 
-data TyVar 
-data TyVarTemplate 
-type TauType = UniType
-data UniType 
-pprBagOfErrors :: PprStyle -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> Int -> Bool -> PrettyRep
-badClassOpErr :: Name -> ProtoName -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep
-badExportNameErr :: [Char] -> [Char] -> PprStyle -> Int -> Bool -> PrettyRep
-badImportNameErr :: [Char] -> [Char] -> [Char] -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep
-derivingInIfaceErr :: ProtoName -> [ProtoName] -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep
-derivingNonStdClassErr :: Name -> ProtoName -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep
-dupNamesErr :: [Char] -> [(ProtoName, SrcLoc)] -> PprStyle -> Int -> Bool -> PrettyRep
-dupPreludeNameErr :: [Char] -> (ProtoName, SrcLoc) -> PprStyle -> Int -> Bool -> PrettyRep
-dupSigDeclErr :: [Sig Name] -> PprStyle -> Int -> Bool -> PrettyRep
-duplicateImportsInInterfaceErr :: [Char] -> [ProtoName] -> PprStyle -> Int -> Bool -> PrettyRep
-inlineInRecursiveBindsErr :: [(Name, SrcLoc)] -> PprStyle -> Int -> Bool -> PrettyRep
-methodBindErr :: MonoBinds ProtoName (InPat ProtoName) -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep
-missingSigErr :: SrcLoc -> ProtoName -> PprStyle -> Int -> Bool -> PrettyRep
-shadowedNameErr :: Name -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep
-unknownNameErr :: [Char] -> ProtoName -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep
-unknownSigDeclErr :: [Char] -> ProtoName -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep
-weirdImportExportConstraintErr :: ProtoName -> IE -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep
-ambigErr :: [Inst] -> PprStyle -> Int -> Bool -> PrettyRep
-badMatchErr :: UniType -> UniType -> UnifyErrContext -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep
-badSpecialisationErr :: [Char] -> [Char] -> Int -> [Labda UniType] -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep
-classCycleErr :: [[(Int -> Bool -> PrettyRep, SrcLoc)]] -> PprStyle -> Int -> Bool -> PrettyRep
-confusedNameErr :: [Char] -> Name -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep
-dataConArityErr :: Id -> Int -> Int -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep
-defaultErr :: [Inst] -> [UniType] -> PprStyle -> Int -> Bool -> PrettyRep
-derivingEnumErr :: TyCon -> PprStyle -> Int -> Bool -> PrettyRep
-derivingIxErr :: TyCon -> PprStyle -> Int -> Bool -> PrettyRep
-derivingWhenInstanceExistsErr :: Class -> TyCon -> PprStyle -> Int -> Bool -> PrettyRep
-dupInstErr :: (Class, (UniType, SrcLoc), (UniType, SrcLoc)) -> PprStyle -> Int -> Bool -> PrettyRep
-genCantGenErr :: [Inst] -> PprStyle -> Int -> Bool -> PrettyRep
-instTypeErr :: UniType -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep
-lurkingRank2Err :: Name -> UniType -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep
-methodTypeLacksTyVarErr :: TyVarTemplate -> [Char] -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep
-naughtyCCallContextErr :: Name -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep
-noInstanceErr :: Inst -> PprStyle -> Int -> Bool -> PrettyRep
-nonBoxedPrimCCallErr :: Class -> UniType -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep
-notAsPolyAsSigErr :: UniType -> [TyVar] -> UnifyErrContext -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep
-preludeInstanceErr :: Class -> UniType -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep
-reduceErr :: [Inst] -> UnifyErrContext -> PprStyle -> Int -> Bool -> PrettyRep
-sigContextsErr :: [SignatureInfo] -> PprStyle -> Int -> Bool -> PrettyRep
-specCtxtGroundnessErr :: UnifyErrContext -> [Inst] -> PprStyle -> Int -> Bool -> PrettyRep
-specDataNoSpecErr :: Name -> [UniType] -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep
-specDataUnboxedErr :: Name -> [UniType] -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep
-specGroundnessErr :: UnifyErrContext -> [UniType] -> PprStyle -> Int -> Bool -> PrettyRep
-specInstUnspecInstNotFoundErr :: Class -> UniType -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep
-topLevelUnboxedDeclErr :: Id -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep
-tyConArityErr :: Name -> Int -> Int -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep
-typeCycleErr :: [[(Int -> Bool -> PrettyRep, SrcLoc)]] -> PprStyle -> Int -> Bool -> PrettyRep
-underAppliedTyErr :: UniType -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep
-unifyErr :: UnifyErrInfo -> UnifyErrContext -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep
-varyingArgsErr :: Name -> [Match Name (InPat Name)] -> PprStyle -> Int -> Bool -> PrettyRep
-
diff --git a/ghc/compiler/main/Errors.lhs b/ghc/compiler/main/Errors.lhs
deleted file mode 100644
index 3a8a376498..0000000000
--- a/ghc/compiler/main/Errors.lhs
+++ /dev/null
@@ -1,124 +0,0 @@
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
-%
-\section[Errors]{Error reporting}
-
-This module now merely re-exports the work of @ErrsRn@ and @ErrsTc@;
-this is the public interface. (WDP 94/06)
-
-\begin{code}
-#include "HsVersions.h"
-
-module Errors (
-	Error(..),
-	pprBagOfErrors,
-
-	-- renamer errors:
-	badClassOpErr,
-	badExportNameErr,
-	badImportNameErr,
-	derivingInIfaceErr,
-	derivingNonStdClassErr,
-	dupNamesErr,
-	dupPreludeNameErr,
-	dupSigDeclErr,
-	duplicateImportsInInterfaceErr,
-	inlineInRecursiveBindsErr,
-	missingSigErr,
---	mismatchedPragmasErr, UNUSED
-	shadowedNameErr,
-	unknownNameErr,
-	unknownSigDeclErr,
-	weirdImportExportConstraintErr,
-
-	-- typechecker errors:
-	ambigErr,
-	badMatchErr,
-	badSpecialisationErr,
-	confusedNameErr,
-	classCycleErr,
-	typeCycleErr,
-	dataConArityErr,
-	defaultErr,
-	derivingEnumErr,
-	derivingIxErr,
-	derivingWhenInstanceExistsErr,
---	derivingNoSuperClassInstanceErr, UNUSED
-	dupInstErr,
---	extraMethodsErr, UNUSED
-	genCantGenErr,
---	genPrimTyVarErr, UNUSED
-	noInstanceErr,
---	instOpErr, UNUSED
-	instTypeErr,
---	methodInstErr, UNUSED
-	methodBindErr,
-	lurkingRank2Err,
-	methodTypeLacksTyVarErr,
---	missingClassOpErr, UNUSED
-	naughtyCCallContextErr,
-	nonBoxedPrimCCallErr,
-	notAsPolyAsSigErr,
---	patMatchWithPrimErr, UNUSED
-	preludeInstanceErr,
---	purelyLocalErr, UNUSED
-	reduceErr,
-	sigContextsErr,
-	specGroundnessErr,
-	specCtxtGroundnessErr,
-	specDataNoSpecErr,
-	specDataUnboxedErr,
-	specInstUnspecInstNotFoundErr,
-	topLevelUnboxedDeclErr,
-	tyConArityErr,
-	underAppliedTyErr,
-	unifyErr,
-	varyingArgsErr,
-#ifdef DPH
-	podCompLhsError,
-	pprPodizedWarning,
-	PodWarning,
-#endif {- Data Parallel Haskell -}
-
-	UnifyErrContext(..),
-	UnifyErrInfo(..),
-
-	-- and to make the interface self-sufficient
-	Bag, Class, ClassOp, MonoBinds, ProtoNameMonoBinds(..), Sig,
-	RenamedSig(..), Expr, RenamedExpr(..), GRHS, RenamedGRHS(..),
-	GRHSsAndBinds, RenamedGRHSsAndBinds(..), Match, IE,
-	RenamedMatch(..), InPat, ProtoNamePat(..), RenamedPat(..),
-	GenPragmas, Id, Inst, Name, PprStyle, Pretty(..), PrettyRep,
-	ProtoName, SrcLoc, TyCon, TyVar, TyVarTemplate, UniType,
-	TauType(..), Maybe, SignatureInfo, TypecheckedPat,
-	TypecheckedExpr(..)
-    ) where
-
--- I don't know how much of this is needed... (WDP 94/06)
-
-import ErrsRn
-import ErrsTc
-import ErrUtils
-
-import AbsSyn		-- we print a bunch of stuff in here
-import UniType		( UniType(..) )		-- Concrete, to make some errors
-						-- more informative.
-import AbsUniType	( TyVar, TyVarTemplate, TyCon,
-			  TauType(..), Class, ClassOp
-			  IF_ATTACK_PRAGMAS(COMMA pprUniType)
-			)
-import Bag		( Bag, bagToList )
-import GenSpecEtc	( SignatureInfo(..) )
-import HsMatches	( pprMatches, pprMatch, pprGRHS )
-import Id		( getIdUniType, Id, isSysLocalId )
-import Inst		( getInstOrigin, getDictClassAndType, Inst )
-import Maybes		( Maybe(..) )
-import Name		( cmpName )
-import Outputable
-import Pretty		-- to pretty-print error messages
-#ifdef DPH
-import PodizeMonad	( PodWarning(..) )
-#endif {- Data Parallel Haskell -}
-import SrcLoc		( mkUnknownSrcLoc, SrcLoc )
-import Util
-\end{code}
diff --git a/ghc/compiler/main/ErrsRn.hi b/ghc/compiler/main/ErrsRn.hi
deleted file mode 100644
index 1a4de4c433..0000000000
--- a/ghc/compiler/main/ErrsRn.hi
+++ /dev/null
@@ -1,26 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface ErrsRn where
-import HsBinds(MonoBinds, Sig)
-import HsImpExp(IE)
-import HsPat(InPat)
-import Name(Name)
-import Pretty(PprStyle, PrettyRep)
-import ProtoName(ProtoName)
-import SrcLoc(SrcLoc)
-badClassOpErr :: Name -> ProtoName -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep
-badExportNameErr :: [Char] -> [Char] -> PprStyle -> Int -> Bool -> PrettyRep
-badImportNameErr :: [Char] -> [Char] -> [Char] -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep
-derivingInIfaceErr :: ProtoName -> [ProtoName] -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep
-derivingNonStdClassErr :: Name -> ProtoName -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep
-dupNamesErr :: [Char] -> [(ProtoName, SrcLoc)] -> PprStyle -> Int -> Bool -> PrettyRep
-dupPreludeNameErr :: [Char] -> (ProtoName, SrcLoc) -> PprStyle -> Int -> Bool -> PrettyRep
-dupSigDeclErr :: [Sig Name] -> PprStyle -> Int -> Bool -> PrettyRep
-duplicateImportsInInterfaceErr :: [Char] -> [ProtoName] -> PprStyle -> Int -> Bool -> PrettyRep
-inlineInRecursiveBindsErr :: [(Name, SrcLoc)] -> PprStyle -> Int -> Bool -> PrettyRep
-methodBindErr :: MonoBinds ProtoName (InPat ProtoName) -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep
-missingSigErr :: SrcLoc -> ProtoName -> PprStyle -> Int -> Bool -> PrettyRep
-shadowedNameErr :: Name -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep
-unknownNameErr :: [Char] -> ProtoName -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep
-unknownSigDeclErr :: [Char] -> ProtoName -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep
-weirdImportExportConstraintErr :: ProtoName -> IE -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep
-
diff --git a/ghc/compiler/main/ErrsRn.lhs b/ghc/compiler/main/ErrsRn.lhs
deleted file mode 100644
index 72b7dc3a3c..0000000000
--- a/ghc/compiler/main/ErrsRn.lhs
+++ /dev/null
@@ -1,194 +0,0 @@
-%
-% (c) The AQUA Project, Glasgow University, 1994-1995
-%
-\section[ErrsRn]{Reporting errors from the renamer}
-
-This is an internal module---access to these functions is through
-@Errors@.
-
-\begin{code}
-#include "HsVersions.h"
-
-module ErrsRn where
-
-import AbsSyn		-- we print a bunch of stuff in here
-import AbsUniType	( TyVarTemplate )
-import UniType		( UniType(..) )
-			-- UniType is concrete, to make some errors
-			-- more informative.
-import ErrUtils
-import Name		( cmpName )
-import Outputable
-import Pretty		-- to pretty-print error messages
-import SrcLoc		( mkUnknownSrcLoc, SrcLoc )
-import Util
-\end{code}
-
-\begin{code}
-badClassOpErr :: Name{-class-} -> ProtoName{-op-} -> SrcLoc -> Error
-	-- Class op expected but something else found
-badClassOpErr clas op locn
-  = addErrLoc locn "" ( \ sty ->
-    ppBesides [ppChar '`', ppr sty op, ppStr "' is not an operation of class `",
-	      ppr sty clas, ppStr "'."] )
-
-----------------------------------------------------------------
-badExportNameErr :: String -> String -> Error
-
-badExportNameErr name whats_wrong
-  = dontAddErrLoc
-	"Error in the export list" ( \ sty ->
-    ppBesides [ppChar '`', ppStr name, ppStr "' ", ppStr whats_wrong] )
-
-----------------------------------------------------------------
-badImportNameErr :: String -> String -> String -> SrcLoc -> Error
-
-badImportNameErr mod name whats_wrong locn
-  = addErrLoc locn
-	("Error in an import list for the module `"++mod++"'") ( \ sty ->
-    ppBesides [ppChar '`', ppStr name, ppStr "' ", ppStr whats_wrong] )
-
-----------------------------------------------------------------
-derivingInIfaceErr :: ProtoName -> [ProtoName] -> SrcLoc -> Error
-	-- GHC doesn't support "deriving" in interfaces
-
-derivingInIfaceErr ty deriveds locn
-  = addErrLoc locn "Glasgow Haskell doesn't support `deriving' in interfaces" ( \ sty ->
-    ppBesides [ ppStr "type: ", ppr sty ty,
-		ppStr "; derived: ", interpp'SP sty deriveds ] )
-
-----------------------------------------------------------------
-derivingNonStdClassErr :: Name -> ProtoName -> SrcLoc -> Error
-	-- if "deriving" specified for a non-standard class
-
-derivingNonStdClassErr tycon clas locn
-  = addErrLoc locn "Can't have a derived instance of this class" ( \ sty ->
-    ppBesides [ppStr "type constructor: ", ppr sty tycon,
-				 ppStr "; class: ", ppr sty clas] )
-
-----------------------------------------------------------------
-dupNamesErr :: String -> [(ProtoName,SrcLoc)] -> Error
-
-dupNamesErr descriptor ((first_pname,locn1) : dup_things) sty
-  = ppAboves (first_item : map dup_item dup_things)
-  where
-    first_item
-      = ppBesides [ ppr PprForUser locn1,
-	    ppStr ": multiple declarations of a ", ppStr descriptor, ppStr ": ",
-	    ppr sty first_pname ]
-
-    dup_item (pname, locn)
-      = ppBesides [ ppr PprForUser locn,
-	    ppStr ": here was another declaration of `", ppr sty pname, ppStr "'" ]
-
-----------------------------------------------------------------
-dupPreludeNameErr :: String -> (ProtoName, SrcLoc) -> Error
-
-dupPreludeNameErr descriptor (nm, locn)
-  = addShortErrLocLine locn ( \ sty ->
-    ppBesides [ ppStr "A conflict with a Prelude ", ppStr descriptor,
-		ppStr ": ", ppr sty nm ])
-
-----------------------------------------------------------------
-dupSigDeclErr :: [RenamedSig] -> Error
-	-- Duplicate signatures in a group; the sigs have locns on them
-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) )
-  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 `cmpName` 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
-
-----------------------------------------------------------------
-duplicateImportsInInterfaceErr :: String -> [ProtoName] -> Error
-duplicateImportsInInterfaceErr iface dups
-  = panic "duplicateImportsInInterfaceErr: NOT DONE YET?"
-
-----------------------------------------------------------------
-inlineInRecursiveBindsErr  :: [(Name, SrcLoc)] -> Error
-
-inlineInRecursiveBindsErr [(name, locn)]
-  = addShortErrLocLine locn ( \ sty ->
-    ppBesides [ppStr "INLINE pragma for a recursive definition: ",
-	ppr sty name] )
-inlineInRecursiveBindsErr names_n_locns
-  = \ sty ->
-    ppHang (ppStr "INLINE pragmas for some recursive definitions:")
-	 4 (ppAboves [ ppBesides [ppr PprForUser locn, ppStr ": ", ppr sty n]
-		     | (n, locn) <- names_n_locns ])
-
-----------------------------------------------------------------
---mismatchedPragmasErr :: (Annotations, SrcLoc)
---		     -> (Annotations, SrcLoc)
---		     -> Error
-{- UNUSED:
-mismatchedPragmasErr (anns1, _) (anns2, _)
-  = dontAddErrLoc "Mismatched pragmas from interfaces" ( \ sty ->
-    ppSep [ppr sty anns1, ppr sty anns2] )
--}
-
-----------------------------------------------------------------
-shadowedNameErr :: Name -> SrcLoc -> Error
-shadowedNameErr shadow locn
-  = addShortErrLocLine locn ( \ sty ->
-    ppBesides [ppStr "more than one value with the same name (shadowing): ",
-	ppr sty shadow] )
-
-----------------------------------------------------------------
-unknownNameErr :: String -> ProtoName -> SrcLoc -> Error
-unknownNameErr descriptor undef_thing locn
-  = addShortErrLocLine locn ( \ sty ->
-    ppBesides [ppStr "undefined ", ppStr descriptor, ppStr ": ",
-	ppr sty undef_thing] )
-
-----------------------------------------------------------------
-missingSigErr :: SrcLoc -> ProtoName -> Error
-	-- Top-level definition without a type signature
-	-- (when SigsRequired flag is in use)
-missingSigErr locn var
-  = addShortErrLocLine locn ( \ sty ->
-    ppBesides [ppStr "a definition but no type signature for `",
-	       ppr sty var,
-	       ppStr "'."])
-
-----------------------------------------------------------------
-unknownSigDeclErr :: String -> ProtoName -> SrcLoc -> Error
-	-- Signature/Pragma given for unknown variable
-unknownSigDeclErr flavor var locn
-  = addShortErrLocLine locn ( \ sty ->
-    ppBesides [ppStr flavor, ppStr " but no definition for `",
-	       ppr sty var,
-	       ppStr "'."])
-
-----------------------------------------------------------------
-weirdImportExportConstraintErr :: ProtoName -> IE -> SrcLoc -> Error
-
-weirdImportExportConstraintErr thing constraint locn
-  = addShortErrLocLine locn ( \ sty ->
-    ppBesides [ppStr "Illegal import/export constraint on `",
-	       ppr sty thing,
-	       ppStr "': ", ppr PprForUser constraint])
-
-----------------------------------------------------------------
-methodBindErr :: ProtoNameMonoBinds -> SrcLoc -> Error
-methodBindErr mbind locn
- = addErrLoc locn "Can't handle multiple methods defined by one pattern binding"
-	(\ sty -> ppr sty mbind)
-\end{code}
diff --git a/ghc/compiler/main/ErrsTc.hi b/ghc/compiler/main/ErrsTc.hi
deleted file mode 100644
index 73f6e86f23..0000000000
--- a/ghc/compiler/main/ErrsTc.hi
+++ /dev/null
@@ -1,53 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface ErrsTc where
-import Class(Class)
-import GenSpecEtc(SignatureInfo)
-import HsExpr(Expr)
-import HsMatches(GRHS, GRHSsAndBinds, Match)
-import HsPat(InPat, TypecheckedPat)
-import Id(Id)
-import Inst(Inst)
-import Maybes(Labda)
-import Name(Name)
-import Pretty(PprStyle, PrettyRep)
-import SrcLoc(SrcLoc)
-import TyCon(TyCon)
-import TyVar(TyVar, TyVarTemplate)
-import UniType(UniType)
-data UnifyErrContext
-  = PredCtxt (Expr Name (InPat Name)) | AppCtxt (Expr Name (InPat Name)) (Expr Name (InPat Name)) | TooManyArgsCtxt (Expr Name (InPat Name)) | FunAppCtxt (Expr Name (InPat Name)) (Labda Id) (Expr Name (InPat Name)) UniType UniType Int | OpAppCtxt (Expr Name (InPat Name)) (Expr Name (InPat Name)) (Expr Name (InPat Name)) | SectionLAppCtxt (Expr Name (InPat Name)) (Expr Name (InPat Name)) | SectionRAppCtxt (Expr Name (InPat Name)) (Expr Name (InPat Name)) | CaseCtxt (Expr Name (InPat Name)) [Match Name (InPat Name)] | BranchCtxt (Expr Name (InPat Name)) (Expr Name (InPat Name)) | ListCtxt [Expr Name (InPat Name)] | PatCtxt (InPat Name) | CaseBranchesCtxt [Match Name (InPat Name)] | FilterCtxt (Expr Name (InPat Name)) | GeneratorCtxt (InPat Name) (Expr Name (InPat Name)) | GRHSsBranchCtxt [GRHS Name (InPat Name)] | GRHSsGuardCtxt (Expr Name (InPat Name)) | PatMonoBindsCtxt (InPat Name) (GRHSsAndBinds Name (InPat Name)) | FunMonoBindsCtxt Name [Match Name (InPat Name)] | MatchCtxt UniType UniType | ArithSeqCtxt (Expr Name (InPat Name)) | CCallCtxt [Char] [Expr Name (InPat Name)] | AmbigDictCtxt [Inst] | SigCtxt Id UniType | MethodSigCtxt Name UniType | ExprSigCtxt (Expr Name (InPat Name)) UniType | ValSpecSigCtxt Name UniType SrcLoc | ValSpecSpecIdCtxt Name UniType Name SrcLoc | BindSigCtxt [Id] | SuperClassSigCtxt | CaseBranchCtxt (Match Name (InPat Name)) | Rank2ArgCtxt (Expr Id TypecheckedPat) UniType
-data UnifyErrInfo   = UnifyMisMatch UniType UniType | TypeRec TyVar UniType | UnifyListMisMatch [UniType] [UniType] | UnifyUnboxedMisMatch UniType UniType
-ambigErr :: [Inst] -> PprStyle -> Int -> Bool -> PrettyRep
-badMatchErr :: UniType -> UniType -> UnifyErrContext -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep
-badSpecialisationErr :: [Char] -> [Char] -> Int -> [Labda UniType] -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep
-classCycleErr :: [[(Int -> Bool -> PrettyRep, SrcLoc)]] -> PprStyle -> Int -> Bool -> PrettyRep
-confusedNameErr :: [Char] -> Name -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep
-dataConArityErr :: Id -> Int -> Int -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep
-defaultErr :: [Inst] -> [UniType] -> PprStyle -> Int -> Bool -> PrettyRep
-derivingEnumErr :: TyCon -> PprStyle -> Int -> Bool -> PrettyRep
-derivingIxErr :: TyCon -> PprStyle -> Int -> Bool -> PrettyRep
-derivingWhenInstanceExistsErr :: Class -> TyCon -> PprStyle -> Int -> Bool -> PrettyRep
-dupInstErr :: (Class, (UniType, SrcLoc), (UniType, SrcLoc)) -> PprStyle -> Int -> Bool -> PrettyRep
-genCantGenErr :: [Inst] -> PprStyle -> Int -> Bool -> PrettyRep
-instTypeErr :: UniType -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep
-lurkingRank2Err :: Name -> UniType -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep
-methodTypeLacksTyVarErr :: TyVarTemplate -> [Char] -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep
-naughtyCCallContextErr :: Name -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep
-noInstanceErr :: Inst -> PprStyle -> Int -> Bool -> PrettyRep
-nonBoxedPrimCCallErr :: Class -> UniType -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep
-notAsPolyAsSigErr :: UniType -> [TyVar] -> UnifyErrContext -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep
-preludeInstanceErr :: Class -> UniType -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep
-reduceErr :: [Inst] -> UnifyErrContext -> PprStyle -> Int -> Bool -> PrettyRep
-sigContextsErr :: [SignatureInfo] -> PprStyle -> Int -> Bool -> PrettyRep
-specCtxtGroundnessErr :: UnifyErrContext -> [Inst] -> PprStyle -> Int -> Bool -> PrettyRep
-specDataNoSpecErr :: Name -> [UniType] -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep
-specDataUnboxedErr :: Name -> [UniType] -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep
-specGroundnessErr :: UnifyErrContext -> [UniType] -> PprStyle -> Int -> Bool -> PrettyRep
-specInstUnspecInstNotFoundErr :: Class -> UniType -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep
-topLevelUnboxedDeclErr :: Id -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep
-tyConArityErr :: Name -> Int -> Int -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep
-typeCycleErr :: [[(Int -> Bool -> PrettyRep, SrcLoc)]] -> PprStyle -> Int -> Bool -> PrettyRep
-underAppliedTyErr :: UniType -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep
-unifyErr :: UnifyErrInfo -> UnifyErrContext -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep
-varyingArgsErr :: Name -> [Match Name (InPat Name)] -> PprStyle -> Int -> Bool -> PrettyRep
-
diff --git a/ghc/compiler/main/ErrsTc.lhs b/ghc/compiler/main/ErrsTc.lhs
deleted file mode 100644
index 331e3b9835..0000000000
--- a/ghc/compiler/main/ErrsTc.lhs
+++ /dev/null
@@ -1,981 +0,0 @@
-%
-% (c) The AQUA Project, Glasgow University, 1994-1995
-%
-\section[ErrsTc]{Reporting errors from the typechecker}
-
-This is an internal module---access to these functions is through
-@Errors@.
-
-DPH errors are in here, too.
-
-\begin{code}
-#include "HsVersions.h"
-
-module ErrsTc (
-	UnifyErrContext(..), UnifyErrInfo(..),
-
-	ambigErr,
-	badMatchErr,
-	badSpecialisationErr,
-	classCycleErr,
-	confusedNameErr,
-	dataConArityErr,
-	defaultErr,
-	derivingEnumErr,
-	derivingIxErr,
-	derivingWhenInstanceExistsErr,
-	dupInstErr,
-	genCantGenErr,
-	instTypeErr,
-	lurkingRank2Err,
-	methodTypeLacksTyVarErr,
-	naughtyCCallContextErr,
-	noInstanceErr,
-	nonBoxedPrimCCallErr,
-	notAsPolyAsSigErr,
-	preludeInstanceErr,
-	reduceErr,
-	sigContextsErr,
-	specCtxtGroundnessErr,
-	specDataNoSpecErr,
-	specDataUnboxedErr,
-	specGroundnessErr,
-	specInstUnspecInstNotFoundErr,
-	topLevelUnboxedDeclErr,
-	tyConArityErr,
-	typeCycleErr,
-	underAppliedTyErr,
-	unifyErr,
-	varyingArgsErr
-    ) where
-
-import AbsSyn		-- we print a bunch of stuff in here
-import UniType		( UniType(..) )		-- Concrete, to make some errors
-						-- more informative.
-import ErrUtils
-import AbsUniType	( extractTyVarsFromTy, pprMaybeTy,
-			  TyVar, TyVarTemplate, TyCon,
-			  TauType(..), Class, ClassOp
-			  IF_ATTACK_PRAGMAS(COMMA pprUniType)
-			)
-import Bag		( Bag, bagToList )
-import GenSpecEtc	( SignatureInfo(..) )
-import HsMatches	( pprMatches, pprMatch, pprGRHS )
-import Id		( getIdUniType, Id, isSysLocalId )
-import Inst		( getInstOrigin, getDictClassAndType, Inst )
-import Name		( cmpName )
-import Outputable
-import Pretty		-- to pretty-print error messages
-#ifdef DPH
-import PodizeMonad	( PodWarning(..) )
-#endif {- Data Parallel Haskell -}
-import SrcLoc		( mkUnknownSrcLoc, SrcLoc )
-import Util
-\end{code}
-
-\begin{code}
-ambigErr :: [Inst] -> Error
-ambigErr insts@(inst1:_)
-  = addErrLoc loc1 "Ambiguous overloading" ( \ sty ->
-    ppAboves (map (ppr_inst sty) insts) )
-  where
-    (loc1, _) = getInstOrigin inst1
-
-ppr_inst sty inst
-  = let
-	(clas, ty)  = getDictClassAndType inst
-	(locn, msg) = getInstOrigin inst
-    in
-    ppSep [ ppBesides [ppStr "class `", ppr sty clas,
-		       ppStr "', type `", ppr sty ty, ppStr "'"],
-	    ppBesides [ppStr "(", msg sty, ppStr ")"] ]
-
-----------------------------------------------------------------
-badMatchErr :: UniType -> UniType -> UnifyErrContext -> SrcLoc -> Error
-badMatchErr sig_ty inferred_ty ctxt locn
-  = addErrLoc locn "Type signature mismatch" ( \ sty ->
-    let
-	thing
-	  = case ctxt of 
-	      SigCtxt id _     -> ppBesides [ppChar '`', ppr sty id, ppChar '\'']
-	      MethodSigCtxt op _ -> ppBesides [ppStr "class method `", ppr sty op, ppStr "'"]
-	      ExprSigCtxt _ _  -> ppStr "an expression"
-	      Rank2ArgCtxt _ _ -> ppStr "an expression with rank-2 polymorphic type(!)"
-	      ctxt  	       -> pprUnifyErrContext sty ctxt
-		-- the latter is ugly, but better than a patt-match failure
-    in
-    ppAboves [ppSep [
-		ppStr "Signature for", thing, ppStr "doesn't match its inferred type."
-	      ],
-	      ppHang (ppStr "Signature:") 4 (ppr sty sig_ty),
-	      ppHang (ppStr "Inferred type:") 4 (ppr sty inferred_ty)
-    ] )
-
-----------------------------------------------------------------
-badSpecialisationErr :: String -> String -> Int -> [Maybe UniType] -> SrcLoc -> Error
-
-badSpecialisationErr flavor messg no_tyvars ty_maybes locn
-  = addErrLoc locn ("Bad "++flavor++" specialisation pragma: "++messg)  ( \ sty ->
-    ppStr "MSG NOT DONE YET"
-    )
-
-----------------------------------------------------------------
-confusedNameErr :: String
-		-> Name		-- the confused name
-		-> SrcLoc
-		-> Error
-confusedNameErr msg nm locn
-  = addErrLoc locn msg ( \ sty ->
-    ppr sty nm )
-{-
-  where
-    msg = if flag then "Type constructor used where a class is expected"
-		  else "Class used where a type constructor is expected"
--}
-
-----------------------------------------------------------------
-typeCycleErr :: [[(Pretty, SrcLoc)]] -> Error
-typeCycleErr = cycleErr  "The following type synonyms refer to themselves:"
-
-classCycleErr :: [[(Pretty, SrcLoc)]] -> Error
-classCycleErr = cycleErr  "The following classes form a cycle:"
-
-cycleErr :: String -> [[(Pretty, SrcLoc)]] -> Error
-cycleErr msg cycles sty
- = ppHang (ppStr msg)
-	4 (ppAboves (map pp_cycle cycles))
- where
-   pp_cycle things	= ppAboves (map pp_thing things)
-   pp_thing (thing,loc) = ppHang (ppBesides [ppr PprForUser loc, ppStr ": "]) 4 thing
-
-----------------------------------------------------------------
-defaultErr :: [Inst]{-dicts-} -> [UniType] -> Error
-	-- when default-resolution fails...
-
-defaultErr dicts defaulting_tys sty
-  = ppHang (ppStr "Ambiguously-overloaded types could not be resolved:")
-	 4 (ppAboves [
-	     ppHang (ppStr "Conflicting:")
-	          4 (ppInterleave ppSemi (map (ppr_inst sty) dicts)),
-	     ppHang (ppStr "Defaulting types :")
-		  4 (ppr sty defaulting_tys),
-	     ppStr "([Int, Double] is the default list of defaulting types.)" ])
-
-----------------------------------------------------------------
-derivingEnumErr :: TyCon -> Error
-derivingEnumErr tycon
-  = addErrLoc (getSrcLoc tycon) "Can't derive an instance of `Enum'" ( \ sty ->
-    ppBesides [ppStr "type `", ppr sty tycon, ppStr "'"] )
-
-----------------------------------------------------------------
-derivingIxErr :: TyCon -> Error
-derivingIxErr tycon
-  = addErrLoc (getSrcLoc tycon) "Can't derive an instance of `Ix'" ( \ sty ->
-    ppBesides [ppStr "type `", ppr sty tycon, ppStr "'"] )
-
-----------------------------------------------------------------
-derivingWhenInstanceExistsErr :: Class -> TyCon -> Error
-derivingWhenInstanceExistsErr clas tycon
-  = addErrLoc (getSrcLoc tycon) "`deriving' when an instance also exists" ( \ sty ->
-    ppBesides [ppStr "class `", ppr sty clas,
-	       ppStr "', type `", ppr sty tycon, ppStr "'"] )
-
-----------------------------------------------------------------
-{- UNUSED:
-derivingNoSuperClassInstanceErr :: Class -> TyCon -> Class -> Error
-derivingNoSuperClassInstanceErr clas tycon super_class
-  = addErrLoc (getSrcLoc tycon) "No instance for a superclass in a `deriving'" ( \ sty ->
-    ppSep [ppBesides [ppStr "the superclass `", ppr sty super_class, ppStr "' has no instance"],
-	   ppBesides [ppStr "at the type `", ppr sty tycon, ppStr "';"],
-	   ppBesides [ppStr "(the class being \"derived\" is `", ppr sty clas, ppStr "')"]
-    	  ])
--}
-
-----------------------------------------------------------------
-dupInstErr :: (Class, (UniType, SrcLoc), (UniType, SrcLoc)) -> Error
-dupInstErr (clas, info1@(ty1, locn1), info2@(ty2, locn2))
-	-- Overlapping/duplicate instances for given class; msg could be more glamourous
-  = addErrLoc locn1 "Duplicate/overlapping instances" ( \ sty ->
-    ppSep [ ppBesides [ppStr "class `", ppr sty clas, ppStr "',"],
-	    showOverlap sty info1 info2] )
-
-----------------------------------------------------------------
-{- UNUSED?
-extraMethodsErr :: [Id] {-dicts-} -> SrcLoc -> Error
-	-- when an instance decl has binds for methods that aren't in the class decl
-extraMethodsErr extra_methods locn
-  = addErrLoc locn "Extra methods in instance declaration" ( \ sty ->
-    interpp'SP sty extra_methods )
--}
-
-----------------------------------------------------------------
-genCantGenErr :: [Inst] -> Error
-genCantGenErr insts@(inst1:_)
-  = addErrLoc loc1 "Cannot generalise these overloadings (in a _ccall_):" ( \ sty ->
-    ppAboves (map (ppr_inst sty) insts) )
-  where
-    (loc1, _) = getInstOrigin inst1
-
-----------------------------------------------------------------
-{- UNUSED:
-genPrimTyVarErr :: [TyVar] -> SrcLoc -> Error
-	-- Attempt to generalise over a primitive type variable
-
-genPrimTyVarErr tyvars locn
-  = addErrLoc locn "These primitive type variables can't be made more general" ( \ sty ->
-    	ppAbove (interpp'SP sty tyvars)
-		(ppStr "(Solution: add a type signature.)") )
--}
-----------------------------------------------------------------
-noInstanceErr :: Inst -> Error
-noInstanceErr inst
-  = let (clas, ty)  = getDictClassAndType inst
-	(locn, msg) = getInstOrigin inst
-    in
-    addErrLoc locn "No such instance" ( \ sty ->
-    ppSep [ ppBesides [ppStr "class `", ppr sty clas,
-		       ppStr "', type `", ppr sty ty, ppStr "'"],
-	    ppBesides [ppStr "(", msg sty, ppStr ")"] ]
-    )
-
-----------------------------------------------------------------
-{- UNUSED:
-instOpErr :: Id -> Class -> TyCon -> Error
-
-instOpErr dict clas tycon
-	-- no instance of "Class" for "TyCon"
-	-- the Id is the offending dictionary; has src location
-	-- (and we could get the Class and TyCon from it, but
-	-- since we already have it at hand ...)
-  = addErrLoc (getSrcLoc dict) "Invalid instance" ( \ sty ->
-    ppBesides [ ppStr "There is no instance of `", ppr sty tycon,
-		ppStr "' for class `",
-		ppr sty clas, ppChar '\'' ] )
--}
-
-----------------------------------------------------------------
-instTypeErr :: UniType -> SrcLoc -> Error
-instTypeErr ty locn
-  = addShortErrLocLine locn (\ sty ->
-    let
-	rest_of_msg = ppStr "' cannot be used as the instance type\n    in an instance declaration."
-    in
-    case ty of
-      UniSyn tc _ _ -> ppBesides [ppStr "The type synonym `", ppr sty tc, rest_of_msg]
-      UniTyVar tv   -> ppBesides [ppStr "The type variable `", ppr sty tv, rest_of_msg]
-      other	    -> ppBesides [ppStr "The type `", ppr sty ty, rest_of_msg]
-    )
-
-----------------------------------------------------------------
-lurkingRank2Err :: Name -> UniType -> SrcLoc -> Error
-lurkingRank2Err name ty locn
-  = addErrLoc locn "Illegal use of a non-Hindley-Milner variable" ( \ sty ->
-    ppAboves [
-      ppBesides [ppStr "The variable is `", ppr sty name, ppStr "'."],
-      ppStr "Its type does not have all its for-alls at the top",
-      ppBesides [ppStr "(the type is `", ppr sty ty, ppStr "'),"],
-      ppStr "nor is it a full application of a rank-2-typed variable.",
-      ppStr "(Most common cause: `_runST' or `_build' not applied to an argument.)"])
-
-----------------------------------------------------------------
-{- UNUSED:
-methodInstErr :: (ClassOp, (UniType, SrcLoc), (UniType, SrcLoc)) -> Error
-methodInstErr (class_op, info1, info2) sty
-	-- Two instances for given class op
-  = ppHang (ppBesides [ ppStr "The class method `", ppr sty class_op, ppStr "' has been given more than one definition for"])
-	4 (showOverlap sty info1 info2)
--}
-
-showOverlap :: PprStyle -> (UniType, SrcLoc) -> (UniType, SrcLoc) -> Pretty
-showOverlap sty (ty1,loc1) (ty2,loc2)
-  = ppSep [ppBesides [ppStr "type `", ppr sty ty1, ppStr "'"],
-	   ppBeside (ppStr "at ") (ppr sty loc1),
-	   ppBeside (ppStr "and ") (ppr sty loc2)]
-
-----------------------------------------------------------------
-methodTypeLacksTyVarErr :: TyVarTemplate -> String -> SrcLoc -> Error
-methodTypeLacksTyVarErr tyvar method_name locn
-  = addErrLoc locn "Method's type doesn't mention the class type variable"  (\ sty ->
-    ppAboves [ppBeside (ppStr "Class type variable: ") (ppr sty tyvar),
-	      ppBeside (ppStr "Method: ") (ppStr method_name)] )
-
-----------------------------------------------------------------
-{- UNUSED:
-missingClassOpErr :: Id -> [ClassOp] -> SrcLoc -> Error
-missingClassOpErr op classops locn
-  = addErrLoc locn "Undefined class method" ( \ sty ->
-    ppBesides [ ppr sty op, ppStr "; valid method(s):",
-		interpp'SP sty classops ] )
--}
-
-----------------------------------------------------------------
-naughtyCCallContextErr :: Name -> SrcLoc -> Error
-naughtyCCallContextErr clas_name locn
-  = addErrLoc locn "Can't use this class in a context" (\ sty ->
-    ppr sty clas_name )
-
-----------------------------------------------------------------
-nonBoxedPrimCCallErr :: Class -> UniType -> SrcLoc -> Error
-nonBoxedPrimCCallErr clas inst_ty locn
-  = addErrLoc locn "Instance isn't for a `boxed-primitive' type" ( \ sty ->
-    ppBesides [ ppStr "class `", ppr sty clas, ppStr "'; type `",
-    		ppr sty inst_ty, ppStr "'"] )
-
-----------------------------------------------------------------
-notAsPolyAsSigErr :: UniType -> [TyVar] -> UnifyErrContext -> SrcLoc -> Error
-notAsPolyAsSigErr sig_ty mono_tyvars ctxt locn
-  = addErrLoc locn "A type signature is more polymorphic than the inferred type" ( \ sty ->
-    ppAboves [  ppStr "(That is, one or more type variables in the inferred type can't be forall'd.)",
-	        pprUnifyErrContext sty ctxt,
-		ppHang (ppStr "Monomorphic type variable(s):")
-		   4 (interpp'SP sty mono_tyvars),
-		ppStr "Possible cause: the RHS mentions something subject to the monomorphism restriction"
-	] )
-
-----------------------------------------------------------------
-{- UNUSED:
-patMatchWithPrimErr :: Error
-patMatchWithPrimErr
-  = dontAddErrLoc
-	"Pattern-bindings may not involve primitive types." ( \ sty ->
-	ppNil )
--}
-
-----------------------------------------------------------------
-preludeInstanceErr :: Class -> UniType -> SrcLoc -> Error
-preludeInstanceErr clas ty locn
-  = addShortErrLocLine locn ( \ sty ->
-    ppHang (ppBesides [ppStr "Illegal instance: for Prelude class `", ppr sty clas,
-	      		 ppStr "' and Prelude type `", ppr sty ty, ppStr "'."] )
-	 4 (ppStr "(An instance decl must be in the same module as the type decl or the class decl)") )
-
-----------------------------------------------------------------
-{- UNUSED:
-purelyLocalErr :: Name -> SrcLoc -> Error
-purelyLocalErr thing locn
-  = addShortErrLocLine locn ( \ sty ->
-    ppBesides [ppStr "`", ppr sty thing,
-	       ppStr "' cannot be exported -- it would refer to an unexported local entity."] )
--}
-
-----------------------------------------------------------------
-reduceErr :: [Inst] -> UnifyErrContext -> Error
-	-- Used by tcSimplifyCheckLIE
-	-- Could not express required dictionaries in terms of the signature
-reduceErr insts ctxt
-  = dontAddErrLoc "Type signature lacks context required by inferred type" ( \ sty ->
-    ppAboves [
-	pprUnifyErrContext sty ctxt,
-	ppHang (ppStr "Context reqd: ")
-	     4 (ppAboves (map (ppr_inst sty) insts))
-    ])
-  where
-    ppr_inst sty inst
-      = let (clas, ty)  = getDictClassAndType inst
-	    (locn, msg) = getInstOrigin inst
-	in
-	ppSep [ ppBesides [ppr sty locn, ppStr ": ", ppr sty clas, ppSP, ppr sty ty],
-		ppBesides [ppStr "(", msg sty, ppStr ")"] ]
-
-----------------------------------------------------------------
-{-
-unexpectedPreludeThingErr :: Outputable a => String -> a -> SrcLoc -> Error
-
-unexpectedPreludeThingErr category thing locn
-  = addShortErrLocLine locn ( \ sty ->
-    ppBesides [ppStr "Prelude ", ppStr category,
-	       ppStr " not expected here: ", ppr sty thing])
--}
-
-----------------------------------------------------------------
-specGroundnessErr :: UnifyErrContext -> [UniType] -> Error
-
-specGroundnessErr (ValSpecSigCtxt name spec_ty locn) arg_tys
-  = addShortErrLocLine locn ( \ sty ->
-    ppHang (
-    	ppSep [ppStr "In the SPECIALIZE pragma for `", ppr sty name,
-	       ppStr "'... not all type variables were specialised",
-	       ppStr "to type variables or ground types (nothing in between, please!):"])
-      4 (ppAboves (map (ppr sty) arg_tys))
-    )
-
-specGroundnessErr (ValSpecSpecIdCtxt name spec_ty spec locn) arg_tys
-  = addShortErrLocLine locn ( \ sty ->
-    ppHang (
-        ppSep [ppBesides [ppStr "In the SPECIALIZE pragma for `", ppr sty name, ppStr "'"],
-	       ppBesides [ppStr "... type of explicit id `", ppr sty spec, ppStr "'"],
-	       ppStr "... not all type variables were instantiated",
-	       ppStr "to type variables or ground types (nothing in between, please!):"])
-      4 (ppAboves (map (ppr sty) arg_tys))
-    )
-
-----------------------------------------------------------------
-specCtxtGroundnessErr :: UnifyErrContext -> [Inst] -> Error
-
-specCtxtGroundnessErr err_ctxt dicts
-  = addShortErrLocLine locn ( \ sty ->
-    ppHang (
-    	ppSep [ppBesides [ppStr "In the SPECIALIZE pragma for `", ppr sty name, ppStr "'"],
-	       ppBesides [ppStr " specialised to the type `", ppr sty spec_ty,  ppStr "'"],
-	       pp_spec_id sty,
-	       ppStr "... not all overloaded type variables were instantiated",
-	       ppStr "to ground types:"])
-      4 (ppAboves [ppCat [ppr sty c, ppr sty t]
-		  | (c,t) <- map getDictClassAndType dicts])
-    )
-  where
-    (name, spec_ty, locn, pp_spec_id)
-      = case err_ctxt of
-	  ValSpecSigCtxt    n ty loc      -> (n, ty, loc, \ x -> ppNil)
-	  ValSpecSpecIdCtxt n ty spec loc ->
-	    (n, ty, loc,
-	     \ sty -> ppBesides [ppStr "... type of explicit id `", ppr sty spec, ppStr "'"])
-
-----------------------------------------------------------------
-specDataNoSpecErr :: Name -> [UniType] -> SrcLoc -> Error
-
-specDataNoSpecErr name arg_tys locn
-  = addShortErrLocLine locn ( \ sty ->
-    ppHang (
-    	ppSep [ppBesides [ppStr "In the SPECIALIZE pragma for `", ppr sty name, ppStr "'"],
-	       ppStr "... no unboxed type arguments in specialisation:"])
-     4 (ppAboves (map (ppr sty) arg_tys))
-    )
-
-----------------------------------------------------------------
-specDataUnboxedErr :: Name -> [UniType] -> SrcLoc -> Error
-
-specDataUnboxedErr name arg_tys locn
-  = addShortErrLocLine locn ( \ sty ->
-    ppHang (
-    	ppSep [ppBesides [ppStr "In the SPECIALIZE pragma for `", ppr sty name, ppStr "'"],
-	       ppStr "... not all type arguments were specialised to",
-	       ppStr "specific unboxed types or (boxed) type variables:"])
-      4 (ppAboves (map (ppr sty) arg_tys))
-    )
-
-----------------------------------------------------------------
-specInstUnspecInstNotFoundErr :: Class -> UniType -> SrcLoc -> Error
-
-specInstUnspecInstNotFoundErr clas inst_ty locn
-  = addErrLoc locn "No local instance to specialise" ( \ sty ->
-    ppBesides [ ppStr "class `", ppr sty clas, ppStr "' at the type `",
-    		ppr sty inst_ty, ppStr "'"] )
-
-----------------------------------------------------------------
--- The type signatures on a mutually-recursive group of definitions
--- must all have the same context (or none).  For example:
---	f :: Eq a => ...
---	g :: (Eq a, Text a) => ...
--- is illegal if f and g are mutually recursive.  This also
--- applies to variables bound in the same pattern binding.
-
-sigContextsErr :: [SignatureInfo] -> Error
-
-sigContextsErr infos
-  = dontAddErrLoc "A group of type signatures have mismatched contexts" ( \ sty ->
-    ppAboves (map (ppr_sig_info sty) infos) )
-  where
-    ppr_sig_info sty (TySigInfo val tyvars insts tau_ty _)
-      = ppHang (ppBeside (ppr sty val) (ppStr " :: "))
-    	     4 (ppHang (if null insts
-			then ppNil
-			else ppBesides [ppStr "(", ppInterleave ppComma (map (ppr_inst sty) insts), ppStr ") => "])
-		     4 (ppr sty tau_ty))
-
-    ppr_inst sty inst
-      = let (clas, ty)  = getDictClassAndType inst
-	    (locn, msg) = getInstOrigin inst
-	in
-	ppCat [ppr sty clas, ppr sty ty]
-
-----------------------------------------------------------------
-topLevelUnboxedDeclErr :: Id -> SrcLoc -> Error
-	-- Top level decl of something with a primitive type
-
-topLevelUnboxedDeclErr id locn
-  = addShortErrLocLine locn ( \ sty ->
-	ppBesides [ppStr "The top-level value `", ppr sty id, ppStr "' shouldn't have an unboxed type." ])
-
-----------------------------------------------------------------
-dataConArityErr :: Id   -> Int -> Int -> SrcLoc -> Error
-tyConArityErr   :: Name -> Int -> Int -> SrcLoc -> Error
-
-tyConArityErr   = arityError "Type"
-dataConArityErr = arityError "Constructor"
-
-arityError kind name n m locn = 
-    addErrLoc locn errmsg
-    (\ sty ->
-    ppBesides [ ppStr "`", ppr sty name, ppStr "' should have ",
-		n_arguments, ppStr ", but has been given ", ppInt m, ppChar '.'])
-    where
-	errmsg = kind ++ " has too " ++ quantity ++ " arguments"
-	quantity | m < n     = "few"
-		 | otherwise = "many"
-	n_arguments | n == 0 = ppStr "no arguments"
-		    | n == 1 = ppStr "1 argument"
-		    | True   = ppCat [ppInt n, ppStr "arguments"]
-
-----------------------------------------------------------------
-underAppliedTyErr :: UniType -> SrcLoc -> Error
-underAppliedTyErr ty locn
-  = addErrLoc locn "A for-all type has been applied to too few arguments" ( \ sty ->
-    ppAboves [
-      ppBesides [ppStr "The type is `", ppr sty ty, ppStr "';"],
-      ppStr "This might be because of a GHC bug; feel free to report",
-      ppStr "it to glasgow-haskell-bugs@dcs.glasgow.ac.uk."])
-
-----------------------------------------------------------------
-unifyErr :: UnifyErrInfo -> UnifyErrContext -> SrcLoc -> Error
-
-unifyErr unify_err_info unify_err_context locn
-  = addShortErrLocLine locn ( \ sty ->
-    pprUnifyErrInfo sty unify_err_info unify_err_context)
-
-----------------------------------------------------------------
-varyingArgsErr :: Name -> [RenamedMatch] -> Error
-	-- Different number of arguments in different equations
-
-varyingArgsErr name matches
-  = dontAddErrLoc "Varying number of arguments for function" ( \ sty ->
-    ppr sty name )
-{-
-varyingArgsErr name matches
-  = addErrLoc locn "Function Definition Error" ( \ sty ->
-	ppBesides [ppStr "Function `", ppr sty name, ppStr "' should have a fixed number of arguments" ])
--}
-\end{code}
-
-%************************************************************************
-%*									*
-\subsection[UnifyErr-types]{@UnifyErrInfo@ and @UnifyErrContext@ datatypes}
-%*									*
-%************************************************************************
-
-Here are the things that can go wrong during unification:
-
-\begin{code}
-data UnifyErrInfo
-  = UnifyMisMatch	UniType UniType
-  | TypeRec		TyVar   TauType		-- Occurs check failure
-
-  | UnifyListMisMatch	[TauType] [TauType]   	-- Args to unifyList: diff lengths
-					      	-- produces system error
-
-  | UnifyUnboxedMisMatch UniType UniType	-- No unboxed specialisation
-
-\end{code}
-
-@UnifyErrContext@ gives some context for unification
-errors found in expressions.  Also see the @UnifyErrInfo@ type (above),
-as well as the general error-reporting type @Error@ (in @TcErrors@).
-\begin{code}
-data UnifyErrContext
-  = PredCtxt		RenamedExpr
-  | AppCtxt		RenamedExpr RenamedExpr
-
-  | TooManyArgsCtxt	RenamedExpr	-- The offending function
-					-- We don't want the typechecked expr here,
-					-- because that may be full of 
-					-- confusing dictionaries
-
-  | FunAppCtxt		RenamedExpr	-- The offending function
-			(Maybe Id)	-- same info (probably) in a more convenient form
-			RenamedExpr	-- The offending arg
-			UniType		-- Expected type of offending arg
-			UniType		-- Inferred type for offending arg
-			Int		-- Which arg number (first is 1)
-
-  | OpAppCtxt		RenamedExpr RenamedExpr RenamedExpr
-  | SectionLAppCtxt	RenamedExpr RenamedExpr
-  | SectionRAppCtxt	RenamedExpr RenamedExpr
-  | CaseCtxt		RenamedExpr [RenamedMatch]
-  | BranchCtxt		RenamedExpr RenamedExpr
-  | ListCtxt		[RenamedExpr]
-  | PatCtxt		RenamedPat
-  | CaseBranchesCtxt	[RenamedMatch]
-  | FilterCtxt		RenamedExpr
-  | GeneratorCtxt	RenamedPat RenamedExpr
-  | GRHSsBranchCtxt	[RenamedGRHS]
-  | GRHSsGuardCtxt	RenamedExpr
-  | PatMonoBindsCtxt	RenamedPat RenamedGRHSsAndBinds
-  | FunMonoBindsCtxt	Name [RenamedMatch]
-  | MatchCtxt		UniType UniType
-  | ArithSeqCtxt	RenamedExpr
-  | CCallCtxt		String [RenamedExpr]
-  | AmbigDictCtxt	[Inst]	-- Occurs check when simplifying ambiguous
-				-- dictionaries.  Should never happen!
-  | SigCtxt		Id UniType
-  | MethodSigCtxt	Name UniType
-  | ExprSigCtxt		RenamedExpr UniType
-  | ValSpecSigCtxt	Name UniType SrcLoc
-  | ValSpecSpecIdCtxt	Name UniType Name SrcLoc
-
-	-- The next two contexts are associated only with TcSimplifyAndCheck failures
-  | BindSigCtxt		[Id]		-- Signature(s) for a group of bindings
-  | SuperClassSigCtxt			-- Superclasses for this instance decl
-
-  | CaseBranchCtxt	RenamedMatch
-  | Rank2ArgCtxt	TypecheckedExpr UniType
-#ifdef DPH
-  | PodCtxt		[RenamedExpr]
-  | ParFilterCtxt       RenamedExpr
-  | DrawnCtxt		[RenamedPat]  RenamedPat RenamedExpr
-  | IndexCtxt		[RenamedExpr] RenamedPat RenamedExpr
-  | ParPidPatCtxt	RenamedPat 
-  | ParPidExpCtxt	RenamedExpr
-  | ParZFlhsCtxt	RenamedExpr
-#endif {- Data Parallel Haskell -}
-\end{code}
-
-%************************************************************************
-%*									*
-\subsection[Errors-print-unify]{Printing unification error info}
-%*									*
-%************************************************************************
-
-\begin{code}
-ppUnifyErr :: Pretty -> Pretty -> Pretty
-ppUnifyErr head rest = ppSep [head, {-if you want a blank line: ppSP,-} rest]
-
-pprUnifyErrInfo sty (UnifyMisMatch mt1 mt2) err_ctxt
- = ppUnifyErr (ppSep [ppBesides [ppStr "Couldn't match the type `", ppr sty mt1, ppStr "'"],
-		       ppBesides [ppStr "against `", ppr sty mt2, ppStr "'."]])
-	      (pprUnifyErrContext sty err_ctxt)
-
-pprUnifyErrInfo sty (TypeRec tyvar ty) err_ctxt
- = ppUnifyErr (ppBesides [ppStr "Cannot construct the infinite type `",
-				 ppr sty tyvar, 
-				 ppStr "' = `",ppr sty ty, ppStr "' (\"occurs check\")."])
-	      (pprUnifyErrContext sty err_ctxt)
-
-pprUnifyErrInfo sty (UnifyListMisMatch tys1 tys2) err_ctxt
- = panic "pprUnifyErrInfo: unifying lists of types of different lengths"
-
-pprUnifyErrInfo sty (UnifyUnboxedMisMatch mt1 mt2) err_ctxt
- = ppUnifyErr (ppSep [ppBesides [ppStr "Couldn't match the type variable `", ppr sty mt1, ppStr "'"],
-		      ppBesides [ppStr "against unboxed type `", ppr sty mt2, ppStr "'."],
-		      ppStr "Try using  -fspecialise-unboxed  ..." ])
-	      (pprUnifyErrContext sty err_ctxt)
-\end{code}
-
-%************************************************************************
-%*									*
-\subsection[Errors-print-context]{Printing unification error context}
-%*									*
-%************************************************************************
-
-\begin{code}
-pp_nest_hang :: String -> Pretty -> Pretty
-pp_nest_hang label stuff = ppNest 2 (ppHang (ppStr label) 4 stuff)
-
-context = "Error detected when type-checking "
-
-ppContext s = ppStr (context ++ s)
-
-pprUnifyErrContext sty (PredCtxt e)
-  = ppHang (ppStr "In a predicate expression:") 4 (ppr sty e)
-
-pprUnifyErrContext sty (AppCtxt f a)
-  = ppHang (ppStr "In a function application:") 4 (ppr sty (App f a))
-
-pprUnifyErrContext sty (FunAppCtxt f maybe_id actual_arg expected_arg_ty actual_arg_ty n)
-  = let
-
-	(have_extra_info, f_id, f_type)
-	   = case maybe_id of
-	       Nothing -> (False, bottom, bottom)
-	       Just id -> (True,  id, getIdUniType id)
-
-	free_tyvars = extractTyVarsFromTy f_type
-	bottom = panic "no maybe_id"
-    in
-    ppAboves [
-	ppHang (ppCat [ ppStr "In the", speakNth n, ppStr "argument of",
-			ppBesides [ppChar '`', ppr sty f, ppStr "',"] ])
-	4 (ppBesides [ppStr " namely `", ppr sty actual_arg, ppStr "'," ]),
-
-	ppHang  (ppStr "Expected type of the argument: ")
-		4 (ppr sty expected_arg_ty),
-
-	ppHang  (ppStr "Inferred type of the argument: ")
-		4 (ppr sty actual_arg_ty),
-
-{- OMIT
-   I'm not sure this adds anything 
-
-	if have_extra_info
-	then ppHang (ppCat [ppStr "The type of",
-			    ppBesides [ppChar '`', ppr sty f_id, ppChar '\''],
-			    ppStr "is"]) 4
-		    (ppBesides [ppChar '`', ppr sty f_type, ppStr "'."])
-	else ppNil,
--}
-	
-	if not have_extra_info || null free_tyvars || isSysLocalId f_id
-		-- SysLocals are created for the local (monomorphic) versions
-		-- of recursive functions, and the monomorphism suggestion 
-		-- below is sometimes positively misleading.  Notably,
-		-- if you give an erroneous type sig, you may well end
-		-- up with a unification error like this, and it usually ain't due
-		-- to monomorphism.
-	then ppNil
-	else
-	   ppAboves [
-		ppSep [ppStr "Possible cause of error:",
-		       ppBesides [ppChar '`', ppr sty f, ppChar '\''],
-		       ppStr "is not polymorphic"],
-		ppSep [ppStr "it is monomorphic in the type variable(s):", 
-		       interpp'SP sty free_tyvars]
-	   ]
-    ]
-
-pprUnifyErrContext sty (TooManyArgsCtxt f)
-  = ppHang (ppStr "Too many arguments in an application of the function")
-	 4 (ppBesides [ ppChar '`', ppr sty f, ppStr "'." ])
-
-pprUnifyErrContext sty (SectionLAppCtxt expr op)
-  = ppHang (ppStr "In a left section:")  4 (ppr sty (SectionL expr op))
-
-pprUnifyErrContext sty (SectionRAppCtxt op expr)
-  = ppHang (ppStr "In a right section:") 4 (ppr sty (SectionR op expr))
-
-pprUnifyErrContext sty (OpAppCtxt a1 op a2)
-  = ppHang (ppStr "In an infix-operator application:") 4 (ppr sty (OpApp a1 op a2))
-
-pprUnifyErrContext sty (CaseCtxt e as)
-  = ppHang (ppStr "In a case expression:") 4 (ppr sty (Case e as))
-
-pprUnifyErrContext sty (BranchCtxt b1 b2)
-  = ppSep [ppStr "In the branches of a conditional:",
-	   pp_nest_hang "`then' branch:" (ppr sty b1),
-	   pp_nest_hang "`else' branch:" (ppr sty b2)]
-
-pprUnifyErrContext sty (ListCtxt es)
-  = ppHang (ppStr "In a list expression:") 4 (
-	      ppBesides [ppLbrack, interpp'SP sty es, ppRbrack])
-
-pprUnifyErrContext sty (PatCtxt (ConPatIn name pats))
-  = ppHang (ppStr "In a constructed pattern:")
-	 4 (ppCat [ppr sty name, interppSP sty pats])
-
-pprUnifyErrContext sty (PatCtxt (ConOpPatIn pat1 op pat2))
-  = ppHang (ppStr "In an infix-operator pattern:")
-	 4 (ppCat [ppr sty pat1, ppr sty op, ppr sty pat2])
-
-pprUnifyErrContext sty (PatCtxt (ListPatIn ps))
-  = ppHang (ppStr "In an explicit list pattern:")
-	 4 (ppBesides [ppLbrack, interpp'SP sty ps, ppRbrack])
-
-pprUnifyErrContext sty (PatCtxt pat@(AsPatIn _ _))
-  = ppHang (ppStr "In an as-pattern:") 4 (ppr sty pat)
-
-pprUnifyErrContext sty (CaseBranchesCtxt (m:ms))
-  = ppAboves [ppStr "Inside two case alternatives:",
-	      ppNest 4 (ppBeside (ppStr "... ") (pprMatches sty (True,ppNil) [m])),
-	      ppNest 4 (ppBeside (ppStr "... ") (pprMatches sty (True,ppNil) ms))]
-
-pprUnifyErrContext sty (FilterCtxt e)
-  = ppHang (ppStr "In a guard in a list-comprehension:") 4 (ppr sty e)
-
-pprUnifyErrContext sty (GeneratorCtxt p e)
-  = ppHang (ppStr "In a generator in a list-comprehension:")
-	 4 (ppSep [ppr sty p, ppStr "<-", ppr sty e])
-
-pprUnifyErrContext sty (GRHSsBranchCtxt grhss)
-  = ppAboves [ppStr "In some guarded right-hand-sides:",
-	      ppNest 4 (ppAboves (map (pprGRHS sty False) grhss))]
-
-pprUnifyErrContext sty (GRHSsGuardCtxt g)
-  = ppHang (ppStr "In a guard on an equation:") 4 (ppr sty g)
-
-pprUnifyErrContext sty (PatMonoBindsCtxt pat grhss_and_binds)
-  = ppHang (ppStr "In a pattern binding:")
-	 4 (ppr sty (PatMonoBind pat grhss_and_binds mkUnknownSrcLoc))
-
-pprUnifyErrContext sty (FunMonoBindsCtxt id matches)
-  = ppHang (ppStr "When combining a function's equation(s) & type signature (if applicable):")
-	 4 (ppBesides [ppr sty id, ppSP, pprMatches sty (False,ppNil) matches])
-
-pprUnifyErrContext sty (CaseBranchCtxt match)
-  = ppHang (ppStr "When combining a \"case\" branch & type signature (if applicable):")
-	 4 (pprMatch sty True{-is_case-} match)
-
-pprUnifyErrContext sty (MatchCtxt ty1 ty2)
-  = ppAboves [ppStr "In a type signature:",
-	      pp_nest_hang "Signature:" (ppr sty ty1),
-	      pp_nest_hang "Inferred type:" (ppr sty ty2)]
-
-pprUnifyErrContext sty (ArithSeqCtxt expr)
-  = ppHang (ppStr "In an arithmetic sequence:") 4 (ppr sty expr)
-
-pprUnifyErrContext sty (CCallCtxt label args)
-  = ppAboves [ppStr "In a _ccall_ or _casm_:",
-	      pp_nest_hang "C-calling magic:" (ppStr label),
-	      pp_nest_hang "Arguments:" (ppInterleave ppComma (map (ppr sty) args))]
-
--- OLD: kill
-pprUnifyErrContext sty (AmbigDictCtxt dicts)
-  = ppStr "Ambiguous dictionary occurs check: should never happen!"
-
-pprUnifyErrContext sty (SigCtxt id tau_ty)
-  = ppHang (ppBesides [ppStr "In the type signature for ",
-		   ppr sty id,
-		   ppStr ":"]
-	   ) 4 (ppr sty tau_ty)
-
-pprUnifyErrContext sty (MethodSigCtxt name ty)
-  = ppHang (ppBesides [ ppStr "When matching the definition of class method `",
-	        ppr sty name, ppStr "' to its signature :" ]
-	   ) 4 (ppr sty ty)
-
-pprUnifyErrContext sty (ExprSigCtxt expr ty)
-  = ppHang (ppStr "In an expression with a type signature:")
-	 4 (ppSep [ppBeside (ppr sty expr) (ppStr " ::"),
-		  ppr sty ty])
-
-pprUnifyErrContext sty (BindSigCtxt ids)
-  = ppHang (ppStr "When checking type signatures for: ")
-	 4 (ppInterleave (ppStr ", ") (map (ppr sty) ids))
-
-pprUnifyErrContext sty SuperClassSigCtxt
-  = ppStr "When checking superclass constraints on instance declaration"
-
-pprUnifyErrContext sty (Rank2ArgCtxt expr ty)
-  = ppHang (ppStr "In an argument which has rank-2 polymorphic type:")
-	 4 (ppSep [ppBeside (ppr sty expr) (ppStr " ::"),
-		  ppr sty ty])
-
-pprUnifyErrContext sty (ValSpecSigCtxt v ty src_loc)
-  = ppHang (ppStr "In a SPECIALIZE pragma for a value:")
-	 4 (ppSep [ppBeside (ppr sty v) (ppStr " ::"),
-		  ppr sty ty])
-
-pprUnifyErrContext sty (ValSpecSpecIdCtxt v ty spec src_loc)
-  = ppHang (ppStr "When checking type of explicit id in SPECIALIZE pragma:")
-	 4 (ppSep [ppBeside (ppr sty v) (ppStr " ::"),
-		  ppr sty ty,
-		  ppBeside (ppStr " = ") (ppr sty spec)])
-
-#ifdef DPH
-pprUnifyErrContext sty (PodCtxt es)
-  = ppAboves [ppStr "In a POD expression:",
-	      ppBesides [ppStr "<<", interpp'SP sty es, ppStr ">>"]]
-
-pprUnifyErrContext sty (ParFilterCtxt e)
-  = ppHang (ppStr "In a guard of a POD comprehension:") 4 
-	   (ppr sty e)
-
-pprUnifyErrContext sty (DrawnCtxt ps p e)
-  = ppHang (ppStr "In parallel drawn from generator:")
-	   4 (ppSep [ppStr "(|" ,interpp'SP sty ps, ppStr ";" , 
-		     ppr sty p ,ppStr "|)", ppStr "<<-", ppr sty e])
-
-pprUnifyErrContext sty (IndexCtxt es p e)
-  = ppHang (ppStr "In parallel index from generator:")
-	   4 (ppSep [ppStr "(|",interpp'SP sty es, ppStr ";" , 
-		     ppr sty p ,ppStr "|)" , ppStr "<<=", ppr sty e])
-
-pprUnifyErrContext sty (ParPidPatCtxt p)
-  = ppHang (ppStr "In pattern for processor ID has to be in class Pid:")
-	   4 (ppr sty p)
-
-pprUnifyErrContext sty (ParPidExpCtxt e)
-  = ppHang (ppStr "In expression for processor ID has to be in class Pid:")
-	   4 (ppr sty e)
-
-pprUnifyErrContext sty (ParZFlhsCtxt e)
-  = ppHang (ppStr "In LHS of a POD comprehension has to be in class Processor")
-	   4 (ppr sty e)
-
-#endif {- Data Parallel Haskell -}
-\end{code}
-
-\begin{code}
-#ifdef DPH
-pprPodizedWarning :: PodWarning -> Error
-pprPodizedWarning (EntryNotPodized b)
-   = addWarningLoc (getSrcLoc b) 			 	(\ sty ->
-     ppBeside (ppStr "Unable to parallelise entry: ")
-              (ppr sty b)
-     )
-
-pprPodizedWarning (NoGoNestedPodized b)
-   = addWarningLoc (getSrcLoc b) 			 	(\ sty ->
-     ppBeside (ppStr "Sorry no nested parallelism yet: ")
-	      (ppr sty b)
-   )
-
-pprPodizedWarning (ContextNotAvailable b c)
-   = addWarningLoc (getSrcLoc b) 				(\ sty ->
-     ppAbove (ppBesides [ppStr "No parallelisation of binding for a ",
-			 ppStr (show_context c) , ppStr ": ",ppr sty b])
-	     (ppBesides [ppStr "Maybe you should re-compile this module ",
-		         ppStr "with the `",ppStr (which_flag c), 
-			 ppStr "' flag."])
-     )
-
-pprPodizedWarning (ImportNotAvailable b c)
-   = addWarningLoc (getSrcLoc b) 				(\ sty ->
-     ppAboves [ppBesides [ppStr "No parallelisation of binding for a ",
-			  ppStr (show_context c),ppStr ": ", ppr sty b],
-	       ppBesides [ppStr "If you re-compile the module `",
-			  ppStr (fst (getOrigName b)), ppStr "`"],
-	       ppBesides [ppStr "with the `",ppStr (which_flag c),
-			  ppStr "' flag I may do a better job :-)"]]
-     )
-
-
-pprPodizedWarning (ArgsInDifferentContexts b)
-   = addWarningLoc (getSrcLoc b) 				(\ sty ->
-     ppBesides [ppStr "Higher Order argument used in different ",
-		ppStr "parallel contexts : ",ppr sty b]
-     )
-
-pprPodizedWarning (NoPodization)
-   = addWarning 		 				(\ sty ->
-     ppStr "Program not podized")
-
-pprPodizedWarning (PodizeStats ci pi vl pl)
-   = addWarning 		 				(\ sty ->
-     (ppHang (ppStr "Podization Statistics:")
-	     5
-             (ppAboves [ppCat [ppStr "Info collecting passes =",ppr sty ci],
-		        ppCat [ppStr "Podization passes      =",ppr sty pi],
-		        ppCat [ppStr "Vanilla's deleted      =",ppr sty vl],
-		        ppCat [ppStr "Podized   deleted      =",ppr sty pl]]))
-     )
-
-show_context :: Int -> String
-show_context 1 = "\"vector\""
-show_context 2 = "\"matrix\""
-show_context 3 = "\"cube\""
-show_context n = "\""++(show n)++"-D Pod\""
-
-which_flag :: Int -> String
-which_flag 1 = "-fpodize-vector"
-which_flag 2 = "-fpodize-matrix"
-which_flag 3 = "-fpodize-cube"
-#endif {- Data Parallel Haskell -}
-\end{code}
-
-
-@speakNth@ converts an integer to a verbal index; eg 1 maps to ``first'' etc.
-\begin{code}
-speakNth :: Int -> Pretty
-speakNth 1 = ppStr "first"
-speakNth 2 = ppStr "second"
-speakNth 3 = ppStr "third"
-speakNth 4 = ppStr "fourth"
-speakNth 5 = ppStr "fifth"
-speakNth 6 = ppStr "sixth"
-speakNth n = ppBesides [ ppInt n, ppStr st_nd_rd_th ]
-  where
-    st_nd_rd_th | n_rem_10 == 1 = "st"
-		| n_rem_10 == 2 = "nd"
-		| n_rem_10 == 3 = "rd"
-		| otherwise     = "th"
-
-    n_rem_10 = n `rem` 10
-\end{code}
diff --git a/ghc/compiler/main/Main.hi b/ghc/compiler/main/Main.hi
deleted file mode 100644
index 1b8b0a4726..0000000000
--- a/ghc/compiler/main/Main.hi
+++ /dev/null
@@ -1,4 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface Main where
-mainPrimIO :: _State _RealWorld -> ((), _State _RealWorld)
-
diff --git a/ghc/compiler/main/Main.lhs b/ghc/compiler/main/Main.lhs
index d10aae9ef7..c69184443b 100644
--- a/ghc/compiler/main/Main.lhs
+++ b/ghc/compiler/main/Main.lhs
@@ -1,413 +1,219 @@
 %
-% (c) The GRASP/AQUA Project, Glasgow University, 1993-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1993-1996
 %
 \section[GHC_Main]{Main driver for Glasgow Haskell compiler}
 
 \begin{code}
 #include "HsVersions.h"
 
-module Main (
-#ifdef __GLASGOW_HASKELL__
-	mainPrimIO
-#else
-	main
-#endif
-    ) where
+module Main ( main ) where
+
+import Ubiq{-uitous-}
+
+import PreludeGlaST	( thenPrimIO, _FILE{-instances-} ) -- ToDo: STOP using this...
 
 import MainMonad
+import HsSyn
+
+import ReadPrefix	( rdModule )
+import Rename		( renameModule )
+import Typecheck	( typecheckModule, InstInfo )
+import Desugar		( deSugar, DsMatchContext, pprDsWarnings )
+
+import Bag		( emptyBag, isEmptyBag )
 import CmdLineOpts
+import ErrUtils		( pprBagOfErrors )
+import Maybes		( MaybeErr(..) )
+import PrelInfo		( builtinNameInfo )
+import RdrHsSyn		( getRawExportees )
 
-import AbsCSyn
-import AbsPrel		( builtinNameInfo )
-import AbsSyn
-import AbsUniType	( isDataTyCon, TauType(..), UniType, TyVar, TyCon, Class )
-import Bag		( emptyBag, isEmptyBag, Bag )
-import CE		( CE(..), UniqFM )
-import CodeGen		( codeGen )
-import CoreToStg	( topCoreBindsToStg )
-import Desugar		( deSugar )
-import DsMonad		( DsMatchContext, DsMatchKind, pprDsWarnings )
-import E		( getE_TCE, E, GVE(..) )
-				-- most of above needed by mkInterface
-#ifndef DPH
-import Errors		( pprBagOfErrors, Error(..) )
-#else
-import Errors		( pprBagOfErrors, pprPodizedWarning, Error(..) )
-#endif {- Data Parallel Haskell -}
-import Id		( mkInstId, Id, Inst )
-import Maybes		( maybeToBool, Maybe(..), MaybeErr(..) )
-import MkIface		( mkInterface )
-import Outputable
-import PlainCore	( CoreExpr, CoreBinding, pprPlainCoreBinding,
-			  PlainCoreProgram(..), PlainCoreBinding(..)
-			)
+import PprCore		( pprPlainCoreBinding )
+import PprStyle		( PprStyle(..) )
 import Pretty
 
-#ifdef USE_NEW_READER
-import ReadPrefix2	( rdModule )
-#else
-import {-hide from mkdependHS-}
-	ReadPrefix	( rdModule )
-#endif
-import Rename		-- renameModule ...
-import SimplCore	-- core2core
-import SimplStg		( stg2stg )
---ANDY: import SimplHaskell
-import StgSyn		( pprPlainStgBinding, StgBinding, StgRhs, CostCentre,
-			  StgBinderInfo, PlainStgProgram(..), PlainStgBinding(..)
+import Id		( GenId )		-- instances
+import Name		( Name )		-- instances
+import ProtoName	( ProtoName )		-- instances
+import PprType		( GenType, GenTyVar )	-- instances
+import TyVar		( GenTyVar )		-- instances
+import Unique		( Unique)		-- instances
+
+{-
+--import AbsCSyn
+--import CodeGen		( codeGen )
+--import CoreToStg	( topCoreBindsToStg )
+--import MkIface		( mkInterface )
+
+--import SimplCore	( core2core )
+--import SimplStg		( stg2stg )
+--import StgSyn		( pprPlainStgBinding, GenStgBinding, GenStgRhs, CostCentre,
+			  StgBinderInfo, StgBinding(..)
 			)
-import TCE		( rngTCE, {- UNUSED: printTypeInfoForPop,-} TCE(..)
-			  IF_ATTACK_PRAGMAS(COMMA eltsUFM)
-			)
-import Typecheck	-- typecheckModule ...
-import SplitUniq
-import Unique		-- lots of UniqueSupplies, etc.
-import Util
 
 #if ! OMIT_NATIVE_CODEGEN
-import AsmCodeGen	( dumpRealAsm
-# if __GLASGOW_HASKELL__
-			  , writeRealAsm
-# endif
-			)
+--import AsmCodeGen	( dumpRealAsm, writeRealAsm )
 #endif
+-}
 
-#ifdef USE_SEMANTIQUE_STRANAL
-import ProgEnv		( ProgEnv(..), TreeProgEnv(..), createProgEnv )
-import StrAnal		( ppShowStrAnal, OAT )
-#endif
-#ifdef DPH
-import PodizeCore	( podizeCore , PodWarning)
-import AbsCTopApal      ( nuAbsCToApal )
-import NextUsed         ( pprTopNextUsedC, getTopLevelNexts, AbsCNextUsed,
-                          TopAbsCNextUsed(..) , MagicId)
-
-#endif {- Data Parallel Haskell -}
 \end{code}
 
 \begin{code}
-#ifndef __GLASGOW_HASKELL__
-main :: Dialogue
-
-main = mainIOtoDialogue main_io
-
-main_io :: MainIO ()
-main_io
-#else
-mainPrimIO
-#endif
-  = BSCC("mainIO")
-    BSCC("rdInput") readMn stdin ESCC	`thenMn` \ input_pgm ->
-    getArgsMn			    	`thenMn` \ raw_cmd_line ->
-    classifyOpts raw_cmd_line	    	`thenMn` \ cmd_line_info ->
-    BSCC("doPasses")
+main
+  = readMn stdin	`thenMn` \ input_pgm     ->
+    let
+	cmd_line_info = classifyOpts
+    in
     doIt cmd_line_info input_pgm
-    ESCC ESCC
 \end{code}
 
 \begin{code}
-doIt :: CmdLineInfo -> String -> MainIO ()
-#ifndef DPH
-doIt (switch_lookup_fn, core_cmds, stg_cmds) input_pgm
-#else
-doIt (switch_lookup_fn, core_cmds, podize_cmds, pcore_cmds, stg_cmds) input_pgm
-#endif {- Data Parallel Haskell -}
-  --
-  -- Help functions and boring global variables (e.g., printing style)
-  -- are figured out first; the "business end" follows, in the
-  -- body of the let.
-  --
-  = let 
-    	-- ****** help functions:
-
-	switch_is_on switch = switchIsOn switch_lookup_fn switch
-
-	string_switch_is_on switch
-	  = maybeToBool (stringSwitchSet switch_lookup_fn switch)
-
-        show_pass
-          = if switch_is_on D_show_passes
-	    then \ what -> writeMn stderr ("*** "++what++":\n")
-	    else \ what -> returnMn ()
-
-	doOutput switch io_action
-	  = BSCC("doOutput")
-	    case (stringSwitchSet switch_lookup_fn switch) of
-	      Nothing	 -> returnMn ()
-	      Just fname -> 
-		fopen fname "a+"	`thenMn` \ file ->
-		if (file == ``NULL'') then
-		    error ("doOutput: failed to open:"++fname)
-		else
-		    io_action file		`thenMn` \ () ->
-		    fclose file			`thenMn` \ status ->
-		    if status == 0
-		    then returnMn ()
-		    else error ("doOutput: closed failed: "{-++show status++" "-}++fname)
-	    ESCC
-
-	doDump switch hdr string
-	  = BSCC("doDump")
-	    if (switch_is_on switch)
-	    then writeMn stderr hdr		`thenMn_`
-		 writeMn stderr ('\n': string)	`thenMn_`
-		 writeMn stderr "\n"
-	    else returnMn ()
-	    ESCC
-
-	-- ****** printing styles and column width:
-
-	pprCols = (80 :: Int) -- could make configurable
-
-	(pprStyle, pprErrorsStyle)
-	  = if      switch_is_on PprStyle_All   then
-		    (PprShowAll, PprShowAll)
-	    else if switch_is_on PprStyle_Debug then
-		    (PprDebug, PprDebug)
-	    else if switch_is_on PprStyle_User  then
-		    (PprForUser, PprForUser)
-	    else -- defaults...
-		    (PprDebug, PprForUser)
-
-	pp_show p = ppShow {-WAS:pprCols-}10000{-random-} p
-    in
-    -- non-tuple-ish bindings...
- 
-	-- ****** possibly fiddle builtin namespaces:
-
-    BIND (BSCC("builtinEnv") 
-	  builtinNameInfo switch_is_on {-switch looker-upper-}
-	  ESCC
-	 )
-      _TO_ (init_val_lookup_fn, init_tc_lookup_fn) ->
-
-    -- **********************************************
-    -- Welcome to the business end of the main module
-    -- of the Glorious Glasgow Haskell compiler!
-    -- **********************************************
-#ifndef DPH
-    doDump Verbose "Glasgow Haskell Compiler, version 0.27" "" `thenMn_`
-#else
-    doDump Verbose "Data Parallel Haskell Compiler, version 0.06 (Glasgow 0.27)" ""
-	`thenMn_`
-#endif {- Data Parallel Haskell -}
+doIt :: ([CoreToDo], [StgToDo]) -> String -> MainIO ()
+
+doIt (core_cmds, stg_cmds) input_pgm
+  = doDump opt_Verbose "Glasgow Haskell Compiler, version 1.3-xx" ""
+						`thenMn_`
 
     -- ******* READER
-    show_pass "Read" `thenMn_`
-#ifdef USE_NEW_READER
-    BSCC("rdModule") 
-    rdModule
-    ESCC
-	`thenMn` \ (mod_name, export_list_fns, absyn_tree) ->
-
-    BIND (\x -> x) _TO_ bar_foo ->
-    -- so BINDs and BENDs add up...
-#else
-    BIND BSCC("rdModule") 
-	 rdModule input_pgm
-	 ESCC
-    _TO_ (mod_name, export_list_fns, absyn_tree) ->
-#endif
+    show_pass "Reader"				`thenMn_`
+    rdModule 					`thenMn`
+
+	\ (mod_name, export_list_fns, absyn_tree) ->
+
     let
-	-- reader things used (much?) later
+	-- reader things used much later
 	ds_mod_name = mod_name
 	if_mod_name = mod_name
 	co_mod_name = mod_name
 	st_mod_name = mod_name
 	cc_mod_name = mod_name
-	-- also: export_list_fns
     in
-    doDump D_source_stats "\nSource Statistics:"
-			 (pp_show (ppSourceStats absyn_tree)) `thenMn_`
+    doDump opt_D_dump_rdr "Reader:"
+	(pp_show (ppr pprStyle absyn_tree))	`thenMn_`
 
-    doDump D_dump_rif2hs "Parsed, Haskellised:" 
-			 (pp_show (ppr pprStyle absyn_tree))  `thenMn_`
+    doDump opt_D_source_stats "\nSource Statistics:"
+	(pp_show (ppSourceStats absyn_tree)) 	`thenMn_`
 
-    -- UniqueSupplies for later use
+    -- UniqueSupplies for later use (these are the only lower case uniques)
     getSplitUniqSupplyMn 'r'	`thenMn` \ rn_uniqs ->	-- renamer
     getSplitUniqSupplyMn 't'	`thenMn` \ tc_uniqs ->	-- typechecker
     getSplitUniqSupplyMn 'd'	`thenMn` \ ds_uniqs ->	-- desugarer
     getSplitUniqSupplyMn 's'	`thenMn` \ sm_uniqs ->	-- core-to-core simplifier
-    getSplitUniqSupplyMn 'C'	`thenMn` \ c2s_uniqs ->	-- core-to-stg
-    getSplitUniqSupplyMn 'T'	`thenMn` \ st_uniqs ->	-- stg-to-stg passes
-    getSplitUniqSupplyMn 'F'	`thenMn` \ fl_uniqs ->	-- absC flattener
-    getSplitUniqSupplyMn 'P'	`thenMn` \ prof_uniqs -> -- profiling tidy-upper
-    getSplitUniqSupplyMn 'L'	`thenMn` \ pre_ncg_uniqs -> -- native-code generator
-    let
-	ncg_uniqs = {-mkUniqueSupplyGrimily-} pre_ncg_uniqs
-    in
+    getSplitUniqSupplyMn 'c'	`thenMn` \ c2s_uniqs ->	-- core-to-stg
+    getSplitUniqSupplyMn 'g'	`thenMn` \ st_uniqs ->	-- stg-to-stg passes
+    getSplitUniqSupplyMn 'f'	`thenMn` \ fl_uniqs ->	-- absC flattener
+    getSplitUniqSupplyMn 'n'	`thenMn` \ ncg_uniqs -> -- native-code generator
+
     -- ******* RENAMER
-    show_pass "Rename" `thenMn_`
-    BIND BSCC("Renamer")
-	 renameModule switch_is_on
-		      (init_val_lookup_fn, init_tc_lookup_fn)
-		      absyn_tree
-		      rn_uniqs
-	 ESCC
-    _TO_ (mod4, import_names, final_name_funs, rn_errs_bag) ->
+    show_pass "Renamer" 			`thenMn_`
+
+    case builtinNameInfo
+    of { (init_val_lookup_fn, init_tc_lookup_fn) ->
+
+    case (renameModule (init_val_lookup_fn, init_tc_lookup_fn)
+		       absyn_tree
+		       rn_uniqs)
+    of { (mod4, import_names, final_name_funs, rn_errs_bag) ->
     let
-	-- renamer things used (much?) later
+	-- renamer things used much later
 	cc_import_names = import_names
     in
 
-    doDump D_dump_rn4 "Renamer-pass4:"
-			(pp_show (ppr pprStyle mod4))	`thenMn_`
-
     if (not (isEmptyBag rn_errs_bag)) then
-	-- Stop right here
 	writeMn stderr (ppShow pprCols (pprBagOfErrors pprErrorsStyle rn_errs_bag))
 	`thenMn_` writeMn stderr "\n"
 	`thenMn_` exitMn 1
 
-    else -- No renaming errors, carry on with...
+    else -- No renaming errors ...
+
+    doDump opt_D_dump_rn "Renamer:"
+	(pp_show (ppr pprStyle mod4))		`thenMn_`
 
     -- ******* TYPECHECKER
-    show_pass "TypeCheck" `thenMn_`
-    BIND (case BSCC("TypeChecker")
-	       typecheckModule switch_is_on tc_uniqs final_name_funs mod4
-	       ESCC
-	  of
-	    Succeeded stuff
-		-> (emptyBag, stuff)
-	    Failed tc_errs_bag
-		-> (tc_errs_bag,
-		    panic "main: tickled tc_results even though there were errors"))
-
-    _TO_ (tc_errs_bag, tc_results) ->
+    show_pass "TypeCheck" 			`thenMn_`
+    case (case (typecheckModule tc_uniqs final_name_funs mod4) of
+	    Succeeded (stuff, warns)
+		-> (emptyBag, warns, stuff)
+	    Failed (errs, warns)
+		-> (errs, warns, error "tc_results"))
+
+    of { (tc_errs_bag, tc_warns_bag, tc_results) ->
+
+    (if (isEmptyBag tc_warns_bag) then
+	returnMn ()
+     else
+	writeMn stderr (ppShow pprCols (pprBagOfErrors pprErrorsStyle tc_errs_bag))
+	`thenMn_` writeMn stderr "\n"
+    )   					`thenMn_`
 
-    let
-	ppr_b :: (Inst, TypecheckedExpr) -> Pretty
-	ppr_b (i,e) = ppr pprStyle (VarMonoBind (mkInstId i) e)
-    in
     if (not (isEmptyBag tc_errs_bag)) then
-	-- Must stop *before* trying to dump tc output, because
-	-- if it fails it does not give you any useful stuff back!
 	writeMn stderr (ppShow pprCols (pprBagOfErrors pprErrorsStyle tc_errs_bag))
 	`thenMn_` writeMn stderr "\n"
 	`thenMn_` exitMn 1
 
-    else ( -- No typechecking errors either -- so, go for broke!
+    else ( -- No typechecking errors ...
 
-    BIND tc_results
-    _TO_  (typechecked_quad@(class_binds, inst_binds, val_binds, const_binds),
+    case tc_results
+    of {  (typechecked_quad@(class_binds, inst_binds, val_binds, const_binds),
 	   interface_stuff@(_,_,_,_,_),  -- @-pat just for strictness...
-	   pragma_tycon_specs, {-UNUSED:big_env,-} this_mod_env, ddump_deriv) ->
-    let
---	big_tce  = getE_TCE big_env
---	big_elts = rngTCE big_tce
-
-	this_mod_tce  = getE_TCE this_mod_env
-	this_mod_elts = rngTCE this_mod_tce
-	
-	local_tycons = [tc | tc <- this_mod_elts,
-		 		   isLocallyDefined tc, -- from this module only
-				   isDataTyCon tc ] 	-- algebraic types only
-    in
---    pprTrace "Envs:" (ppAboves [
---	ppr pprStyle if_global_ids,
---	ppr pprStyle if_tce,
---	ppr pprStyle if_ce,
---	ppr pprStyle this_mod_env,
---	ppr pprStyle big_env
---	]) (
-
-    doDump D_dump_tc "Typechecked:"
-		      (pp_show
-			(ppAboves [ppr pprStyle class_binds,
-				   ppr pprStyle inst_binds,
-				   ppAboves (map ppr_b const_binds),
-				   ppr pprStyle val_binds]))    `thenMn_`
-
-    doDump D_dump_deriv   "Derived instances:"
-			  (pp_show (ddump_deriv pprStyle))	`thenMn_`
-
---NOT REALLY USED:
---  doDump D_dump_type_info "" (pp_show (printTypeInfoForPop big_tce)) `thenMn_`
+	   (local_tycons,local_classes), pragma_tycon_specs, ddump_deriv) ->
+
+    doDump opt_D_dump_tc "Typechecked:"
+	(pp_show (ppAboves [
+	    ppr pprStyle class_binds,
+	    ppr pprStyle inst_binds,
+	    ppAboves (map (\ (i,e) -> ppr pprStyle (VarMonoBind i e)) const_binds),
+	    ppr pprStyle val_binds]))   	`thenMn_`
+
+    doDump opt_D_dump_deriv "Derived instances:"
+	(pp_show (ddump_deriv pprStyle))	`thenMn_`
+
+
     -- ******* DESUGARER
-    show_pass "DeSugar" `thenMn_`
+    show_pass "DeSugar" 			`thenMn_`
     let
 	(desugared,ds_warnings)
-	  = BSCC("DeSugarer")
-	    deSugar ds_uniqs switch_lookup_fn ds_mod_name typechecked_quad
-	    ESCC
+	  = deSugar ds_uniqs ds_mod_name typechecked_quad
     in
     (if isEmptyBag ds_warnings then
 	returnMn ()
      else
 	writeMn stderr (ppShow pprCols (pprDsWarnings pprErrorsStyle ds_warnings))
 	`thenMn_` writeMn stderr "\n"
-    ) `thenMn_`
+    ) 						`thenMn_`
+
+    doDump opt_D_dump_ds "Desugared:" (pp_show (ppAboves
+	(map (pprPlainCoreBinding pprStyle) desugared)))
+						`thenMn_`
 
-    doDump D_dump_ds "Desugared:" (pp_show (ppAboves
-			(map (pprPlainCoreBinding pprStyle) desugared)))   `thenMn_`
+{- LATER ...
 
     -- ******* CORE-TO-CORE SIMPLIFICATION (NB: I/O op)
     core2core core_cmds switch_lookup_fn co_mod_name pprStyle
 	      sm_uniqs local_tycons pragma_tycon_specs desugared
-		`thenMn` \ (simplified, inlinings_env,
-			    SpecData _ _ _ gen_tycons all_tycon_specs _ _ _) ->
+						`thenMn`
 
-    doDump D_dump_simpl "Simplified:" (pp_show (ppAboves
-			(map (pprPlainCoreBinding pprStyle) simplified)))   `thenMn_`
+	 \ (simplified, inlinings_env,
+	    SpecData _ _ _ gen_tycons all_tycon_specs _ _ _) ->
 
--- ANDY:
---  doDump D_dump_core_passes_info "(Haskell) Simplified:" 
---			(coreToHaskell simplified)			    `thenMn_`
-
-#ifdef DPH
-    -- ******* PODIZE (VECTORIZE) THE CORE PROGRAM	
-    let
-        (warn,podized) = BSCC("PodizeCore")
-			 podizeCore podize_cmds switch_is_on
-				    uniqSupply_p simplified
-			 ESCC
-    in
-    (if (not (null warn))
-     then writeMn stderr "\n"						    `thenMn_`
-	  writeMn stderr (ppShow pprCols (ppAboves
-                    (map (\w -> pprPodizedWarning w pprErrorsStyle) warn))) `thenMn_`
-	  writeMn stderr "\n"
-     else returnMn ())							    `thenMn_`
-           
-    doDump D_dump_pod   "Podization:" (pp_show (ppAboves
-		     (map (pprPlainCoreBinding pprStyle) podized)))	    `thenMn_`
-
-    -- ******** CORE-TO-CORE SIMPLIFICATION OF PODIZED PROGRAM
-    let 
-    	psimplified = BSCC("PodizeCore2Core")
-		      core2core pcore_cmds switch_is_on pprStyle
-				uniqSupply_S podized
-		      ESCC
-    in
-    doDump D_dump_psimpl "Par Simplified:" (pp_show (ppAboves
-			(map (pprPlainCoreBinding pprStyle) psimplified)))  `thenMn_`
-
-#endif {- Data Parallel Haskell -}
-
-#ifdef USE_SEMANTIQUE_STRANAL
-    -- ******* SEMANTIQUE STRICTNESS ANALYSER
-    doDump D_dump_stranal_sem "Strictness:" (ppShowStrAnal simplified big_env) `thenMn_`
-#endif
+    doDump opt_D_dump_simpl "Simplified:" (pp_show (ppAboves
+	(map (pprPlainCoreBinding pprStyle) simplified)))
+						`thenMn_`
 
     -- ******* STG-TO-STG SIMPLIFICATION
-    show_pass "Core2Stg" `thenMn_`
+    show_pass "Core2Stg" 			`thenMn_`
     let
-#ifndef DPH
-	stg_binds   = BSCC("Core2Stg")
-		      topCoreBindsToStg c2s_uniqs simplified
-		      ESCC
-#else
-	stg_binds   = BSCC("Core2Stg")
-		      topCoreBindsToStg c2s_uniqs psimplified
-		      ESCC
-#endif {- Data Parallel Haskell -}
+	stg_binds   = topCoreBindsToStg c2s_uniqs simplified
     in
-    show_pass "Stg2Stg" `thenMn_`
+
+    show_pass "Stg2Stg" 			`thenMn_`
     stg2stg stg_cmds switch_lookup_fn st_mod_name pprStyle st_uniqs stg_binds
-			`thenMn` \ (stg_binds2, cost_centre_info) ->
+						`thenMn`
 
-    doDump D_dump_stg "STG syntax:" (pp_show (ppAboves
-		      (map (pprPlainStgBinding pprStyle) stg_binds2)))	`thenMn_`
+	\ (stg_binds2, cost_centre_info) ->
+
+    doDump opt_D_dump_stg "STG syntax:"
+	(pp_show (ppAboves (map (pprPlainStgBinding pprStyle) stg_binds2)))
+						`thenMn_`
 
     -- ******* INTERFACE GENERATION (needs STG output)
 {-  let
@@ -421,41 +227,36 @@ doIt (switch_lookup_fn, core_cmds, podize_cmds, pcore_cmds, stg_cmds) input_pgm
 	if_inst_info = emptyBag
     in
 -}
-    show_pass "Interface" `thenMn_`
+    show_pass "Interface" 			`thenMn_`
     let
 	mod_interface
-    	  = BSCC("MkInterface")
-	    mkInterface switch_is_on if_mod_name export_list_fns
+    	  = mkInterface switch_is_on if_mod_name export_list_fns
 			inlinings_env all_tycon_specs
 			interface_stuff
 			stg_binds2
-	    ESCC
     in
-    doOutput ProduceHi BSCC("PrintInterface")
-		       ( \ file ->
-		         ppAppendFile file 1000{-pprCols-} mod_interface )
-		       ESCC 						`thenMn_`
+    doOutput ProduceHi ( \ file ->
+			 ppAppendFile file 1000{-pprCols-} mod_interface )
+       						`thenMn_`
 
     -- ******* "ABSTRACT", THEN "FLAT", THEN *REAL* C!
-    show_pass "CodeGen" `thenMn_`
+    show_pass "CodeGen" 			`thenMn_`
     let
-	abstractC      = BSCC("CodeGen")
-		         codeGen cc_mod_name     -- module name for CC labelling
+	abstractC      = codeGen cc_mod_name     -- module name for CC labelling
 				 cost_centre_info
 				 cc_import_names -- import names for CC registering
 				 switch_lookup_fn
 				 gen_tycons	 -- type constructors generated locally
 				 all_tycon_specs -- tycon specialisations
 				 stg_binds2
-		         ESCC
 
-    	flat_abstractC = BSCC("FlattenAbsC")
-			 flattenAbsC fl_uniqs abstractC
-		         ESCC
+    	flat_abstractC = flattenAbsC fl_uniqs abstractC
     in
-    doDump D_dump_absC  "Abstract C:" (dumpRealC switch_is_on abstractC)   `thenMn_`
+    doDump opt_D_dump_absC  "Abstract C:"
+	(dumpRealC switch_is_on abstractC)  	`thenMn_`
 
-    doDump D_dump_flatC "Flat Abstract C:" (dumpRealC switch_is_on flat_abstractC) `thenMn_`
+    doDump opt_D_dump_flatC "Flat Abstract C:"
+	(dumpRealC switch_is_on flat_abstractC)	`thenMn_`
 
     -- You can have C (c_output) or assembly-language (ncg_output),
     -- but not both.  [Allowing for both gives a space leak on
@@ -469,75 +270,93 @@ doIt (switch_lookup_fn, core_cmds, podize_cmds, pcore_cmds, stg_cmds) input_pgm
 	     (False, False) -> (AbsCNop, AbsCNop)
 	     (True,  True)  -> error "ERROR: Can't do both .hc and .s at the same time"
 
-	c_output_d = BSCC("PrintRealC")
-		     dumpRealC switch_is_on flat_absC_c
-    		     ESCC
-
-#ifdef __GLASGOW_HASKELL__
-	c_output_w = BSCC("PrintRealC")
-		     (\ f -> writeRealC switch_is_on f flat_absC_c)
-    		     ESCC
-#else
-	c_output_w = c_output_d
-#endif
+	c_output_d = dumpRealC switch_is_on flat_absC_c
+	c_output_w = (\ f -> writeRealC switch_is_on f flat_absC_c)
 
 #if OMIT_NATIVE_CODEGEN
-	ncg_output_d
-	  = error "*** GHC not built with a native-code generator ***"
+	ncg_output_d = error "*** GHC not built with a native-code generator ***"
 	ncg_output_w = ncg_output_d
 #else
-	ncg_output_d = BSCC("nativeCode")
-		     dumpRealAsm switch_lookup_fn flat_absC_ncg ncg_uniqs
-    		     ESCC
-
-#ifdef __GLASGOW_HASKELL__
-	ncg_output_w = BSCC("nativeCode")
-		     (\ f -> writeRealAsm switch_lookup_fn f flat_absC_ncg ncg_uniqs)
-    		     ESCC
-#else
-	ncg_output_w = ncg_output_d
-#endif
+	ncg_output_d = dumpRealAsm switch_lookup_fn flat_absC_ncg ncg_uniqs
+	ncg_output_w = (\ f -> writeRealAsm switch_lookup_fn f flat_absC_ncg ncg_uniqs)
 #endif
     in
-    doDump D_dump_asm "" ncg_output_d `thenMn_`
-    doOutput ProduceS    ncg_output_w `thenMn_`
 
-#ifndef DPH
-    -- ********* GHC Finished !!!!
-    doDump D_dump_realC "" c_output_d `thenMn_`
-    doOutput ProduceC 	   c_output_w `thenMn_`
+    doDump opt_D_dump_asm "" ncg_output_d 	`thenMn_`
+    doOutput ProduceS ncg_output_w 		`thenMn_`
 
-#else
-    -- ********* DPH needs native code generator, nearly finished.....
-    let 
-	next_used_flatC = getTopLevelNexts flat_abstractC []
-	apal_module     = nuAbsCToApal uniqSupply_L mod_name next_used_flatC
-    in
-    doDump D_dump_nextC "Next Used annotated C:" (ppShow pprCols 
-				(pprTopNextUsedC next_used_flatC))	    `thenMn_`
-    doOutput ProduceC 	("! /* DAP assembler (APAL): */\n"++apal_module)    `thenMn_`
+    doDump opt_D_dump_realC "" c_output_d 	`thenMn_`
+    doOutput ProduceC c_output_w 		`thenMn_`
 
-#endif {- Data Parallel Haskell -}
+LATER -}
     exitMn 0
-    {-)-} BEND ) BEND BEND BEND BEND
-
-
-ppSourceStats (Module name exports imports fixities typedecls typesigs
+    } ) } } }
+  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:
+
+    show_pass
+      = if opt_D_show_passes
+	then \ what -> writeMn stderr ("*** "++what++":\n")
+	else \ what -> returnMn ()
+
+    doOutput switch io_action
+      = case switch of
+	  Nothing	 -> returnMn ()
+	  Just fname ->
+	    fopen fname "a+"	`thenPrimIO` \ file ->
+	    if (file == ``NULL'') then
+		error ("doOutput: failed to open:"++fname)
+	    else
+		io_action file		`thenMn`     \ () ->
+		fclose file		`thenPrimIO` \ status ->
+		if status == 0
+		then returnMn ()
+		else error ("doOutput: closed failed: "{-++show status++" "-}++fname)
+
+    doDump switch hdr string
+      = if switch
+	then writeMn stderr hdr		`thenMn_`
+	     writeMn stderr ('\n': string)	`thenMn_`
+	     writeMn stderr "\n"
+	else returnMn ()
+
+
+ppSourceStats (HsModule name exports imports fixities typedecls typesigs
 		      classdecls instdecls instsigs defdecls binds
 		      [{-no sigs-}] src_loc)
  = ppAboves (map pp_val
 	       [("ExportAll        ", export_all), -- 1 if no export list
 		("ExportDecls      ", export_ds),
 		("ExportModules    ", export_ms),
-		("ImportAll        ", import_all),
-		("ImportPartial    ", import_partial),
-		("  PartialDecls   ", partial_decls),
-		("ImportHiding     ", import_hiding),
-		("  HidingDecls    ", hiding_decls),
+		("Imports          ", import_no),
+		("  ImpQual        ", import_qual),
+		("  ImpAs          ", import_as),
+		("  ImpAll         ", import_all),
+		("  ImpPartial     ", import_partial),
+		("  ImpHiding      ", import_hiding),
 		("FixityDecls      ", fixity_ds),
 		("DefaultDecls     ", defalut_ds),
 	      	("TypeDecls        ", type_ds),
 	      	("DataDecls        ", data_ds),
+	      	("NewTypeDecls     ", newt_ds),
 	      	("DataConstrs      ", data_constrs),
 		("DataDerivings    ", data_derivs),
 	      	("ClassDecls       ", class_ds),
@@ -559,9 +378,10 @@ ppSourceStats (Module name exports imports fixities typedecls typesigs
     pp_val (str, 0) = ppNil
     pp_val (str, n) = ppBesides [ppStr str, ppInt n]
 
-    (export_decls, export_mods) = getRawIEStrings exports
+    (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
@@ -569,26 +389,26 @@ ppSourceStats (Module name exports imports fixities typedecls typesigs
 
     fixity_ds  = length fixities
     defalut_ds = length defdecls
-    type_ds    = length type_decls 
+    type_ds    = length type_decls
     data_ds    = length data_decls
-    class_ds   = length classdecls       
+    newt_ds    = length newt_decls
+    class_ds   = length classdecls
     inst_ds    = length instdecls
 
     (val_bind_ds, fn_bind_ds, bind_tys, bind_specs, bind_inlines)
 	= count_binds binds
 
-    (import_all, import_partial, partial_decls, import_hiding, hiding_decls)
-        = foldr add5 (0,0,0,0,0) (map import_info imports)
+    (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 data_decls)
+	= 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 classdecls)
     (inst_method_ds, method_specs, method_inlines)
 	= foldr add3 (0,0,0) (map inst_info instdecls)
 
-    data_specs  = length (filter is_data_spec_sig typesigs)
-    inst_specs  = length (filter is_inst_spec_sig instsigs)
-
+    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
@@ -612,33 +432,40 @@ ppSourceStats (Module name exports imports fixities typedecls typesigs
     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)
+    sig_info (InlineSig _ _)      = (0,0,0,1)
     sig_info _                    = (0,0,0,0)
 
-    import_info (ImportAll _ _)        = (1,0,0,0,0)
-    import_info (ImportSome _ ds _)    = (0,1,length ds,0,0)
-    import_info (ImportButHide _ ds _) = (0,0,0,1,length ds)
+    import_info (ImportMod _ qual as spec)
+	= add6 (1, qual_info qual, as_info as, 0,0,0) (spec_info spec)
+    qual_info False  = 0
+    qual_info True   = 1
+    as_info Nothing  = 0
+    as_info (Just _) = 1
+    spec_info Nothing 	        = (0,0,0,1,0,0)
+    spec_info (Just (False, _)) = (0,0,0,0,1,0)
+    spec_info (Just (True, _))  = (0,0,0,0,0,1)
 
     data_info (TyData _ _ _ constrs derivs _ _)
-	= (length constrs, length 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})
 
     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 _ _)
-        = case count_sigs inst_sigs of
+    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 (TySynonym _ _ _ _)     = True
     is_type_decl _		         = False
     is_data_decl (TyData _ _ _ _ _ _ _)  = True
     is_data_decl _		         = False
-    is_data_spec_sig (SpecDataSig _ _ _) = True
-    is_data_spec_sig _			 = False
-    is_inst_spec_sig (InstSpecSig _ _ _) = True
+    is_newt_decl (TyNew  _ _ _ _ _ _ _)  = True
+    is_newt_decl _		         = False
 
     addpr (x,y) = x+y
     add1 x1 y1  = x1+y1
@@ -646,6 +473,5 @@ ppSourceStats (Module name exports imports fixities typedecls typesigs
     add3 (x1,x2,x3) (y1,y2,y3) = (x1+y1,x2+y2,x3+y3)
     add4 (x1,x2,x3,x4) (y1,y2,y3,y4) = (x1+y1,x2+y2,x3+y3,x4+y4)
     add5 (x1,x2,x3,x4,x5) (y1,y2,y3,y4,y5) = (x1+y1,x2+y2,x3+y3,x4+y4,x5+y5)
+    add6 (x1,x2,x3,x4,x5,x6) (y1,y2,y3,y4,y5,y6) = (x1+y1,x2+y2,x3+y3,x4+y4,x5+y5,x6+y6)
 \end{code}
-
-
diff --git a/ghc/compiler/main/MainMonad.hi b/ghc/compiler/main/MainMonad.hi
deleted file mode 100644
index 230a6e1c46..0000000000
--- a/ghc/compiler/main/MainMonad.hi
+++ /dev/null
@@ -1,25 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface MainMonad where
-import PreludeArray(_ByteArray)
-import SplitUniq(SplitUniqSupply)
-import Stdio(_FILE(..), fclose, fopen, fwrite)
-infixr 9 `thenMn`
-infixr 9 `thenMn_`
-type MainIO a = _State _RealWorld -> (a, _State _RealWorld)
-data SplitUniqSupply 
-data _FILE   = _FILE Addr#
-exitMn :: Int -> _State _RealWorld -> ((), _State _RealWorld)
-fclose :: _FILE -> _State _RealWorld -> (Int, _State _RealWorld)
-fopen :: [Char] -> [Char] -> _State _RealWorld -> (_FILE, _State _RealWorld)
-fwrite :: _ByteArray Int -> Int -> Int -> _FILE -> _State _RealWorld -> (Int, _State _RealWorld)
-getArgsMn :: _State _RealWorld -> ([[Char]], _State _RealWorld)
-getSplitUniqSupplyMn :: Char -> _State _RealWorld -> (SplitUniqSupply, _State _RealWorld)
-readMn :: [Char] -> _State _RealWorld -> ([Char], _State _RealWorld)
-returnMn :: a -> _State _RealWorld -> (a, _State _RealWorld)
-thenMn :: (_State _RealWorld -> (a, _State _RealWorld)) -> (a -> _State _RealWorld -> (b, _State _RealWorld)) -> _State _RealWorld -> (b, _State _RealWorld)
-thenMn_ :: (_State _RealWorld -> (a, _State _RealWorld)) -> (_State _RealWorld -> (b, _State _RealWorld)) -> _State _RealWorld -> (b, _State _RealWorld)
-writeMn :: [Char] -> [Char] -> _State _RealWorld -> ((), _State _RealWorld)
-instance Eq _FILE
-instance _CCallable _FILE
-instance _CReturnable _FILE
-
diff --git a/ghc/compiler/main/MainMonad.lhs b/ghc/compiler/main/MainMonad.lhs
index 4d0960bbc8..eae6adfc64 100644
--- a/ghc/compiler/main/MainMonad.lhs
+++ b/ghc/compiler/main/MainMonad.lhs
@@ -1,5 +1,5 @@
 %
-% (c) The GRASP/AQUA Project, Glasgow University, 1993-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1993-1996
 %
 \section[MainMonad]{I/O monad used in @Main@ module of the compiler}
 
@@ -8,10 +8,6 @@
 
 module MainMonad (
 	MainIO(..),
-#ifndef __GLASGOW_HASKELL__
-	mainIOtoDialogue,
-	appendFileMn,
-#endif
 	returnMn,
 	thenMn,
 	thenMn_,
@@ -21,11 +17,9 @@ module MainMonad (
 	getArgsMn,
 	getSplitUniqSupplyMn,
 	exitMn,
-#if __GLASGOW_HASKELL__ >= 23
 	fopen, fclose, fwrite, _FILE(..),
-#endif
 
-	SplitUniqSupply
+	UniqSupply
 	IF_ATTACK_PRAGMAS(COMMA getArgsPrimIO)
 	IF_ATTACK_PRAGMAS(COMMA appendFilePrimIO)
 	IF_ATTACK_PRAGMAS(COMMA appendChanPrimIO)
@@ -33,27 +27,20 @@ module MainMonad (
 	IF_ATTACK_PRAGMAS(COMMA mkSplitUniqSupply) -- profiling only, really
     ) where
 
-#ifdef __GLASGOW_HASKELL__
+#if __HASKELL1__ >= 3
+import LibSystem
+#endif
 
-# if __GLASGOW_HASKELL__ < 26
-import PreludePrimIO
-# endif
 import PreludeGlaST
 
-#endif
+import Ubiq{-uitous-}
 
-import SplitUniq
-import Outputable
-import Util
+import UniqSupply	( mkSplitUniqSupply, UniqSupply )
 
 infixr 9 `thenMn`	-- right-associative, please
 infixr 9 `thenMn_`
 \end{code}
 
-For Glasgow Haskell, we'll eventually be able to use the underlying
-Glasgow I/O {\em directly}.  However, for now we do the business
-through regular a @Dialogue@.
-
 A value of type @MainIO a@ represents an I/O-performing computation
 returning a value of type @a@.  It is a function from the whole list
 of responses-to-the-rest-of-the-program, to a triple consisting of:
@@ -72,37 +59,30 @@ the depleted list of responses.
 returnMn    :: a -> MainIO a
 thenMn	    :: MainIO a -> (a -> MainIO b) -> MainIO b
 thenMn_	    :: MainIO a -> MainIO b -> MainIO b
---foldlMn	    :: (a -> b -> MainIO a) -> a -> [b] -> MainIO a
 
+#if __HASKELL1__ < 3
 readMn	    :: String{-channel-} -> MainIO String
 writeMn	    :: String{-channel-} -> String -> MainIO ()
-#ifndef __GLASGOW_HASKELL__
-appendFileMn:: String{-filename-} -> String -> MainIO ()
+#else
+readMn	    :: Handle -> MainIO String
+writeMn	    :: Handle -> String -> MainIO ()
 #endif
+
 getArgsMn   :: MainIO [String]
-getSplitUniqSupplyMn :: Char -> MainIO SplitUniqSupply
+getSplitUniqSupplyMn
+	    :: Char -> MainIO UniqSupply
 exitMn	    :: Int -> MainIO ()
 
-#ifdef __GLASGOW_HASKELL__
 {-# INLINE returnMn #-}
 {-# INLINE thenMn   #-}
 {-# INLINE thenMn_  #-}
-#endif
-
-{- INLINEd at its uses
-foldlMn f z []     = returnMn z
-foldlMn f z (x:xs) = f z x	`thenMn` \ zz ->
-		     foldlMn f zz xs
--}
 
 exitMn val
-  = -- trace ("exitMn:"++(show val)) (
-    if val /= 0
+  = if val /= 0
     then error "Compilation had errors\n"
     else returnMn ()
-    -- )
 
-#ifdef __GLASGOW_HASKELL__
+#if __HASKELL1__ < 3
 
 type MainIO a = PrimIO a
 
@@ -115,144 +95,22 @@ writeMn chan str	    = appendChanPrimIO chan str
 getArgsMn		    = getArgsPrimIO
 
 getSplitUniqSupplyMn char = mkSplitUniqSupply char
-\end{code}
-
-\begin{code}
-#else {- ! __GLASGOW_HASKELL -}
-
-type MainIO a = (a -> Dialogue) -> Dialogue
-
--- returnMn :: x -> MainIO x
-returnMn x cont = cont x
-
--- thenMn :: MainIO a -> (a -> MainIO b) -> MainIO b
-thenMn m k cont = m (\ a -> k a cont)
-
--- thenMn_ :: MainIO a -> MainIO b -> MainIO b
-thenMn_ m k cont = m (\ _ -> k cont)
-\end{code}
-
-\begin{code}
-mainIOtoDialogue :: MainIO () -> Dialogue
-
-mainIOtoDialogue io = io (\ _ _ -> [])
-
-readMn chan		= readChanIO chan
-writeMn chan str	= appendChanIO chan str
-appendFileMn fname str	= appendFileIO fname str
-getArgsMn		= getArgsIO
-
-getSplitUniqSupplyMn char = returnMn (mkSplitUniqSupply char)
-\end{code}
-
-\begin{code}
-processRequestIO   :: Request -> MainIO Response
-processRequestIO req cont ~(resp:resps) = req : cont resp resps
-
-doneIO :: MainIO a
-doneIO cont = \ _ -> []
-
-data IoResult a = IoSucc a
-                | IoFail IOError
 
-type IOE a = MainIO (IoResult a)         
+#else {- 1.3 -}
 
-processRequestIOUnit :: Request -> IOE ()
-processRequestIOUnit req =
-        processRequestIO req                           `thenMn` \ resp -> 
-        case resp of
-          Success       -> returnMn (IoSucc ())
-          Str str       -> error "funny Response, expected a Success"
-          StrList strl  -> error "funny Response, expected a Success" 
-          Failure ioerr -> returnMn (IoFail ioerr)
+type MainIO a = IO a
 
-processRequestIOString :: Request -> IOE String
-processRequestIOString req =
-        processRequestIO req                           `thenMn` \ resp -> 
-        case resp of
-          Success       -> error "funny Response, expected a String"
-          Str str       -> returnMn (IoSucc str)
-          StrList strl  -> error "funny Response, expected a String" 
-          Failure ioerr -> returnMn (IoFail ioerr)
+returnMn    = return
+thenMn	    = (>>=)
+thenMn_	    = (>>)
 
-processRequestIOStringList :: Request -> IOE [String]
-processRequestIOStringList req =
-        processRequestIO req                           `thenMn` \ resp -> 
-        case resp of
-          Success       -> error "funny Response, expected a [String]"
-          Str str       -> error "funny Response, expected a [String]" 
-          StrList strl  -> returnMn (IoSucc strl)
-          Failure ioerr -> returnMn (IoFail ioerr)
+readMn chan		    = hGetContents chan
+writeMn chan str	    = hPutStr chan str
+getArgsMn		    = getArgs
 
-readFileIOE     :: String ->           IOE String
-writeFileIOE    :: String -> String -> IOE ()
-appendFileIOE   :: String -> String -> IOE ()
-deleteFileIOE   :: String ->           IOE ()
-statusFileIOE   :: String ->           IOE String
-readChanIOE     :: String ->           IOE String
-appendChanIOE   :: String -> String -> IOE ()
-statusChanIOE   :: String ->           IOE String
-echoIOE         :: Bool   ->           IOE ()
-getArgsIOE      ::                     IOE [String]
-getEnvIOE       :: String ->           IOE String
-setEnvIOE       :: String -> String -> IOE ()
-sigActionIOE    :: Int    -> SigAct -> IOE ()
+getSplitUniqSupplyMn char
+  = mkSplitUniqSupply char `thenPrimIO` \ us ->
+    return us
 
-readFileIOE    file     = processRequestIOString     ( ReadFile file )
-writeFileIOE   file str = processRequestIOUnit       ( WriteFile file str )
-appendFileIOE  file str = processRequestIOUnit       ( AppendFile file str )
-deleteFileIOE  file     = processRequestIOUnit       ( DeleteFile file )
-statusFileIOE  file     = processRequestIOString     ( StatusFile file )
-readChanIOE    chan     = processRequestIOString     ( ReadChan chan )
-appendChanIOE  chan str = processRequestIOUnit       ( AppendChan chan str )
-statusChanIOE  chan     = processRequestIOString     ( StatusChan chan )
-echoIOE        bool     = processRequestIOUnit       ( Echo bool )
-getArgsIOE              = processRequestIOStringList ( GetArgs )
-getEnvIOE      var      = processRequestIOString     ( GetEnv var )
-setEnvIOE      var obj  = processRequestIOUnit       ( SetEnv var obj )
-sigActionIOE   sig act  = processRequestIOUnit       ( SigAction sig act )
-
-handleErrIO :: IoResult a -> MainIO a 
-handleErrIO (IoSucc a)     = returnMn a
-handleErrIO (IoFail ioerr) = exitIO   ioerr
-
-readFileIO      :: String ->           MainIO String
-writeFileIO     :: String -> String -> MainIO ()
-appendFileIO    :: String -> String -> MainIO ()
-deleteFileIO    :: String ->           MainIO ()
-statusFileIO    :: String ->           MainIO String
-readChanIO      :: String ->           MainIO String
-appendChanIO    :: String -> String -> MainIO ()
-statusChanIO    :: String ->           MainIO String
-echoIO          :: Bool   ->           MainIO ()
-getArgsIO       ::                     MainIO [String]
-getEnvIO        :: String ->           MainIO String
-setEnvIO        :: String -> String -> MainIO ()
-sigActionIO     :: Int    -> SigAct -> MainIO ()
-
-readFileIO      file       = readFileIOE file           `thenMn` handleErrIO
-writeFileIO     file str   = writeFileIOE file str      `thenMn` handleErrIO
-appendFileIO    file str   = appendFileIOE file str     `thenMn` handleErrIO
-deleteFileIO    file       = deleteFileIOE file         `thenMn` handleErrIO
-statusFileIO    file       = statusFileIOE file         `thenMn` handleErrIO
-readChanIO      chan       = readChanIOE chan           `thenMn` handleErrIO
-appendChanIO    chan str   = appendChanIOE chan str     `thenMn` handleErrIO
-statusChanIO    chan       = statusChanIOE chan         `thenMn` handleErrIO
-echoIO          bool       = echoIOE bool               `thenMn` handleErrIO
-getArgsIO                  = getArgsIOE                 `thenMn` handleErrIO
-getEnvIO        var        = getEnvIOE var              `thenMn` handleErrIO
-setEnvIO        var obj    = setEnvIOE var obj          `thenMn` handleErrIO
-sigActionIO     sig act    = sigActionIOE sig act       `thenMn` handleErrIO
-
-exitIO     :: IOError -> MainIO a
-
-exitIO (ReadError s)   = error s
-exitIO (WriteError s)  = error s
-exitIO (SearchError s) = error s
-exitIO (FormatError s) = error s
-exitIO (OtherError s)  = error s
-\end{code}
-
-\begin{code}
-#endif {- ! __GLASGOW_HASKELL -}
+#endif {- 1.3 -}
 \end{code}
diff --git a/ghc/compiler/main/MkIface.hi b/ghc/compiler/main/MkIface.hi
deleted file mode 100644
index 43508c7fa2..0000000000
--- a/ghc/compiler/main/MkIface.hi
+++ /dev/null
@@ -1,40 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface MkIface where
-import Bag(Bag)
-import CE(CE(..))
-import CharSeq(CSeq)
-import Class(Class)
-import CmdLineOpts(GlobalSwitch)
-import FiniteMap(FiniteMap)
-import HsBinds(MonoBinds, Sig)
-import HsDecls(FixityDecl)
-import HsPat(InPat)
-import Id(Id)
-import Maybes(Labda)
-import Name(Name)
-import NameTypes(FullName, ShortName)
-import PreludePS(_PackedString)
-import Pretty(Delay, PrettyRep)
-import SimplEnv(UnfoldingDetails)
-import SrcLoc(SrcLoc)
-import StgSyn(StgBinding, StgRhs)
-import TCE(TCE(..))
-import TcInstDcls(InstInfo)
-import TyCon(TyCon)
-import TyVar(TyVarTemplate)
-import UniType(UniType)
-import UniqFM(UniqFM)
-import Unique(Unique)
-data Bag a 
-type CE = UniqFM Class
-data GlobalSwitch 
-data FixityDecl a 
-data Id 
-data Name 
-data PrettyRep 
-data StgBinding a b 
-type TCE = UniqFM TyCon
-data InstInfo 
-data UniqFM a 
-mkInterface :: (GlobalSwitch -> Bool) -> _PackedString -> (_PackedString -> Bool, _PackedString -> Bool) -> UniqFM UnfoldingDetails -> FiniteMap TyCon [(Bool, [Labda UniType])] -> ([FixityDecl Name], [Id], UniqFM Class, UniqFM TyCon, Bag InstInfo) -> [StgBinding Id Id] -> Int -> Bool -> PrettyRep
-
diff --git a/ghc/compiler/main/MkIface.lhs b/ghc/compiler/main/MkIface.lhs
index b809142135..0b8de5f9db 100644
--- a/ghc/compiler/main/MkIface.lhs
+++ b/ghc/compiler/main/MkIface.lhs
@@ -6,24 +6,14 @@
 \begin{code}
 #include "HsVersions.h"
 
-module MkIface (
-	mkInterface,
+module MkIface ( mkInterface ) where
 
-	-- and to make the interface self-sufficient...
-	Bag, CE(..), GlobalSwitch, FixityDecl, Id,
-	Name, PrettyRep, StgBinding, TCE(..), UniqFM, InstInfo
-    ) where
-
-IMPORT_Trace		-- ToDo: rm (debugging)
-
-import AbsPrel		( mkLiftTy, pRELUDE_CORE, pRELUDE_BUILTIN )
-import AbsSyn		( FixityDecl(..), RenamedFixityDecl(..), MonoBinds,
+import PrelInfo		( mkLiftTy, pRELUDE_CORE, pRELUDE_BUILTIN )
+import HsSyn		( FixityDecl(..), RenamedFixityDecl(..), MonoBinds,
 			  RenamedMonoBinds(..), Name, RenamedPat(..), Sig
 			)
-import AbsUniType
+import Type
 import Bag
-import CE
-import CmdLineOpts	-- ( GlobalSwitch(..) )
 import FiniteMap
 import Id
 import IdInfo		-- plenty from here
@@ -31,7 +21,6 @@ import Maybes		( catMaybes, Maybe(..) )
 import Outputable
 import Pretty
 import StgSyn
-import TCE
 import TcInstDcls	( InstInfo(..) )
 import Util
 \end{code}
@@ -56,7 +45,7 @@ those particular \tr{Ids} {\em do not have} the best @IdInfos@!!!
 Those @IdInfos@ were figured out long after the \tr{InstInfo} was
 created.
 
-That's why we actually look at the final \tr{PlainStgBindings} that go
+That's why we actually look at the final \tr{StgBindings} that go
 into the code-generator: they have the best @IdInfos@ on them.
 Whenever, we are about to print info about an @Id@, we look in the
 Ids-from-STG-bindings list to see if we have an ``equivalent'' @Id@
@@ -78,21 +67,20 @@ to \tr{make}.
 \end{enumerate}
 
 \begin{code}
-mkInterface :: (GlobalSwitch -> Bool)
-	    -> FAST_STRING
+mkInterface :: FAST_STRING
 	    -> (FAST_STRING -> Bool,  -- is something in export list, explicitly?
 		FAST_STRING -> Bool)  -- is a module among the "dotdot" exported modules?
 	    -> IdEnv UnfoldingDetails
-	    -> FiniteMap TyCon [(Bool, [Maybe UniType])]
+	    -> FiniteMap TyCon [(Bool, [Maybe Type])]
 	    -> ([RenamedFixityDecl],  -- interface info from the typecheck
-	        [Id],
-	        CE,
-	        TCE,
-	        Bag InstInfo)
-	    -> [PlainStgBinding]
+		[Id],
+		CE,
+		TCE,
+		Bag InstInfo)
+	    -> [StgBinding]
 	    -> Pretty
 
-mkInterface sw_chkr modname export_list_fns inline_env tycon_specs
+mkInterface modname export_list_fns inline_env tycon_specs
 	    (fixity_decls, global_ids, ce, tce, inst_infos)
 	    stg_binds
   = let
@@ -100,12 +88,12 @@ mkInterface sw_chkr modname export_list_fns inline_env tycon_specs
 
 	exported_tycons  = [ tc | tc <- rngTCE tce,
 			   isExported tc,
-			   is_exportable_tycon_or_class sw_chkr export_list_fns tc ]
+			   is_exportable_tycon_or_class export_list_fns tc ]
 	exported_classes = [  c |  c <- rngCE  ce,
 			   isExported  c,
-			   is_exportable_tycon_or_class sw_chkr export_list_fns  c ]
+			   is_exportable_tycon_or_class export_list_fns  c ]
 	exported_inst_infos = [ i | i <- bagToList inst_infos,
-			   is_exported_inst_info sw_chkr export_list_fns i ]
+			   is_exported_inst_info export_list_fns i ]
 	exported_vals
     	  = [ v | v <- global_ids,
 	      isExported v && not (isDataCon v) && not (isClassOpId v) ]
@@ -119,20 +107,20 @@ mkInterface sw_chkr modname export_list_fns inline_env tycon_specs
 	  = foldr ( \ (tcs1, cls1) (tcs2, cls2)
 		      -> (tcs1 `unionBags` tcs2, cls1 `unionBags` cls2) )
 		  (emptyBag, emptyBag)
-		  (map getMentionedTyConsAndClassesFromClass exported_classes  ++ 
+		  (map getMentionedTyConsAndClassesFromClass exported_classes  ++
 		   map getMentionedTyConsAndClassesFromTyCon exported_tycons   ++
 		   map getMentionedTyConsAndClassesFromId    exported_vals     ++
 		   map getMentionedTyConsAndClassesFromInstInfo exported_inst_infos)
 
 	mentionable_classes
-	  = filter (is_mentionable sw_chkr) (bagToList mentioned_classes)
+	  = filter is_mentionable (bagToList mentioned_classes)
 	mentionable_tycons
 	  = [ tc | tc <- bagToList mentioned_tycons,
-		   is_mentionable sw_chkr tc,
+		   is_mentionable tc,
 		   not (isPrimTyCon tc) ]
 
-	nondup_mentioned_tycons  = fst (removeDups cmpTyCon mentionable_tycons)
-	nondup_mentioned_classes = fst (removeDups cmpClass mentionable_classes)
+	nondup_mentioned_tycons  = fst (removeDups cmp mentionable_tycons)
+	nondup_mentioned_classes = fst (removeDups cmp mentionable_classes)
 
 	-- Next: as discussed in the notes, we want the top-level
 	-- Ids straight from the final STG code, so we can use
@@ -177,22 +165,21 @@ mkInterface sw_chkr modname export_list_fns inline_env tycon_specs
     else
 --  trace ("mkIface:Ids:"++(ppShow 80 (ppr PprDebug global_ids))) (
     ppAboves
-       [ppPStr SLIT("{-# GHC_PRAGMA INTERFACE VERSION 6 #-}"),
+       [ppPStr SLIT("{-# GHC_PRAGMA INTERFACE VERSION 7 #-}"),
 	ppCat [ppPStr SLIT("interface"), ppPStr modname, ppPStr SLIT("where")],
 
-	do_import_decls sw_chkr modname
+	do_import_decls modname
 		sorted_vals sorted_mentioned_classes sorted_mentioned_tycons,
 		-- Mustn't give the data constructors to do_import_decls,
 		-- because they aren't explicitly imported; their tycon is.
-		-- ToDo: modify if we ever add renaming properly.
 
-	ppAboves (map (do_fixity sw_chkr)		              fixity_decls),
-	ppAboves (map (pprIfaceClass sw_chkr better_id_fn inline_env) sorted_classes),
-	ppAboves (map (do_tycon    sw_chkr tycon_specs)	              sorted_tycons),
-	ppAboves (map (do_value    sw_chkr better_id_fn inline_env)   sorted_vals),
-	ppAboves (map (do_instance sw_chkr better_id_fn inline_env)   sorted_inst_infos),
+	ppAboves (map do_fixity					fixity_decls),
+	ppAboves (map (pprIfaceClass better_id_fn inline_env)	sorted_classes),
+	ppAboves (map (do_tycon      tycon_specs)		sorted_tycons),
+	ppAboves (map (do_value      better_id_fn inline_env)   sorted_vals),
+	ppAboves (map (do_instance   better_id_fn inline_env)   sorted_inst_infos),
 
-        ppChar '\n'
+	ppChar '\n'
        ]
 --  )
   where
@@ -205,7 +192,7 @@ mkInterface sw_chkr modname export_list_fns inline_env tycon_specs
 	      Just xs -> naughty_trace cl xs
 
 	bad_id id
-	  = case (maybePurelyLocalType (getIdUniType id)) of
+	  = case (maybePurelyLocalType (idType id)) of
 	      Nothing -> False
 	      Just xs -> naughty_trace id xs
 
@@ -229,8 +216,6 @@ mkInterface sw_chkr modname export_list_fns inline_env tycon_specs
 %*									*
 %************************************************************************
 
-Not handling renaming yet (ToDo)
-
 We gather up lots of (module, name) pairs for which we might print an
 import declaration.  We sort them, for the usual canonicalisation
 reasons.  NB: We {\em assume} the lists passed in don't have duplicates in
@@ -240,22 +225,21 @@ All rather horribly turgid (WDP).
 
 \begin{code}
 do_import_decls
-	:: (GlobalSwitch -> Bool)
-	-> FAST_STRING
+	:: FAST_STRING
 	-> [Id] -> [Class] -> [TyCon]
 	-> Pretty
 
-do_import_decls sw_chkr mod_name vals classes tycons
+do_import_decls mod_name vals classes tycons
   = let
-	-- Conjure up (module, name, maybe_renaming) triples for all
+	-- Conjure up (module, name) pairs for all
 	-- the potentially import-decls things:
 
 	vals_names, classes_names, tycons_names :: [(FAST_STRING, FAST_STRING, [Maybe FAST_STRING])]
-	vals_names	= map get_val_triple   vals
-	classes_names	= map get_class_triple classes
-	tycons_names	= map get_tycon_triple tycons
+	vals_names	= map get_val_pair   vals
+	classes_names	= map get_class_pair classes
+	tycons_names	= map get_tycon_pair tycons
 
-	-- sort the (module, name, renaming) triples and chop
+	-- sort the (module, name) pairs and chop
 	-- them into per-module groups:
 
 	ie_list = sortLt lt (tycons_names ++ classes_names ++ vals_names)
@@ -264,15 +248,15 @@ do_import_decls sw_chkr mod_name vals classes tycons
     in
     ppAboves (map print_a_decl per_module_groups)
   where
-    lt, same_module :: (FAST_STRING, FAST_STRING, [Maybe FAST_STRING])
-		    -> (FAST_STRING, FAST_STRING, [Maybe FAST_STRING]) -> Bool 
+    lt, same_module :: (FAST_STRING, FAST_STRING)
+		    -> (FAST_STRING, FAST_STRING) -> Bool
 
-    lt (m1, ie1, _) (m2, ie2, _)
-      = case _CMP_STRING_ m1 m2 of { LT_ -> True; EQ_ -> ie1 < ie2; GT__ -> False }
+    lt (m1, ie1, ie2)
+      = case (_CMP_STRING_ m1 m2) of { LT_ -> True; EQ_ -> ie1 < ie2; GT__ -> False }
 
     same_module (m1, _, _) (m2, _, _) = m1 == m2
-   
-    compiling_the_prelude = sw_chkr CompilingPrelude
+
+    compiling_the_prelude = opt_CompilingPrelude
 
     print_a_decl :: [(FAST_STRING, FAST_STRING, [Maybe FAST_STRING])] -> Pretty
     {-
@@ -287,18 +271,15 @@ do_import_decls sw_chkr mod_name vals classes tycons
 	try to do it as "normally" as possible.
     -}
     print_a_decl (ielist@((m,_,_) : _))
-      |  m == mod_name 
+      |  m == mod_name
       || (not compiling_the_prelude &&
 	  (m == pRELUDE_CORE || m == pRELUDE_BUILTIN))
       = ppNil
 
       | otherwise
-      = ppBesides [ppPStr SLIT("import "), ppPStr m, ppLparen, 
+      = ppBesides [ppPStr SLIT("import "), ppPStr m, ppLparen,
 		   ppIntersperse pp'SP{-'-} (map pp_str [n | (_,n,_) <- ielist]),
-		   ppRparen,
-		   case (grab_non_Nothings [rns | (_,_,rns) <- ielist]) of
-		     []	       -> ppNil
-		     renamings -> pp_renamings renamings
+		   ppRparen
 		  ]
       where
 	isnt_tycon_ish :: FAST_STRING -> Bool
@@ -313,38 +294,28 @@ do_import_decls sw_chkr mod_name vals classes tycons
 	  = if isAvarop pstr then ppStr ("("++str++")") else ppPStr pstr
 	  where
 	    str = _UNPK_ pstr
-
-	pp_renamings strs
-	  = ppBesides [ ppPStr SLIT(" renaming "), ppLparen, ppIntersperse pp'SP{-'-} (map ppPStr strs), ppRparen ]
 \end{code}
 
-Most of the huff and puff here is to ferret out renaming strings.
-
 \begin{code}
-get_val_triple   :: Id    -> (FAST_STRING, FAST_STRING, [Maybe FAST_STRING])
-get_class_triple :: Class -> (FAST_STRING, FAST_STRING, [Maybe FAST_STRING])
-get_tycon_triple :: TyCon -> (FAST_STRING, FAST_STRING, [Maybe FAST_STRING])
+get_val_pair   :: Id    -> (FAST_STRING, FAST_STRING)
+get_class_pair :: Class -> (FAST_STRING, FAST_STRING)
+get_tycon_pair :: TyCon -> (FAST_STRING, FAST_STRING)
 
-get_val_triple id
-  = case (generic_triple id) of { (a,b,rn) ->
-    (a,b,[rn]) }
+get_val_pair id
+  = generic_pair id
 
-get_class_triple clas
-  = case (generic_triple clas) of { (orig_mod, orig_nm, clas_rn) ->
+get_class_pair clas
+  = case (generic_pair clas) of { (orig_mod, orig_nm) ->
     let
 	nm_to_print = case (getExportFlag clas) of
 			ExportAll   -> orig_nm _APPEND_ SLIT("(..)") -- nothing like a good HACK!
 			ExportAbs   -> orig_nm
 			NotExported -> orig_nm
-
--- Ops don't have renaming info (bug) ToDo
---	ops	    = getClassOps clas
---	ops_rns	    = [ rn | (_,_,rn) <- map generic_triple ops ]
     in
-    (orig_mod, nm_to_print, [clas_rn]) }
+    (orig_mod, nm_to_print) }
 
-get_tycon_triple tycon
-  = case (generic_triple tycon) of { (orig_mod, orig_nm, tycon_rn) ->
+get_tycon_pair tycon
+  = case (generic_pair tycon) of { (orig_mod, orig_nm) ->
     let
 	nm_to_print = case (getExportFlag tycon) of
 			ExportAll   -> orig_nm _APPEND_ SLIT("(..)") -- nothing like a good HACK!
@@ -352,18 +323,13 @@ get_tycon_triple tycon
 			NotExported -> orig_nm
 
 	cons	    = getTyConDataCons tycon
-	cons_rns    = [ rn | (_,_,rn) <- map generic_triple cons ]
     in
-    (orig_mod, nm_to_print, tycon_rn : cons_rns) }
+    (orig_mod, nm_to_print) }
 
-generic_triple thing
+generic_pair thing
   = case (getOrigName       thing) of { (orig_mod, orig_nm) ->
     case (getOccurrenceName thing) of { occur_name ->
-    (orig_mod, orig_nm,
-     if orig_nm == occur_name
-     then Nothing
-     else Just (orig_nm _APPEND_ SLIT(" to ") _APPEND_ occur_name)
-    )}}
+    (orig_mod, orig_nm) }}
 \end{code}
 
 %************************************************************************
@@ -374,11 +340,11 @@ generic_triple thing
 
 
 \begin{code}
-do_fixity :: (GlobalSwitch -> Bool) -> RenamedFixityDecl -> Pretty
+do_fixity :: -> RenamedFixityDecl -> Pretty
 
-do_fixity sw_chkr fixity_decl
+do_fixity fixity_decl
   = case (getExportFlag (get_name fixity_decl)) of
-      ExportAll -> ppr (PprInterface sw_chkr) fixity_decl
+      ExportAll -> ppr PprInterface fixity_decl
       _	    	-> ppNil
   where
      get_name (InfixL n _) = n
@@ -393,10 +359,10 @@ do_fixity sw_chkr fixity_decl
 %************************************************************************
 
 \begin{code}
-do_tycon :: (GlobalSwitch -> Bool) -> FiniteMap TyCon [(Bool, [Maybe UniType])] -> TyCon -> Pretty
+do_tycon :: FiniteMap TyCon [(Bool, [Maybe Type])] -> TyCon -> Pretty
 
-do_tycon sw_chkr tycon_specs_map tycon
-  = pprTyCon (PprInterface sw_chkr) tycon tycon_specs
+do_tycon tycon_specs_map tycon
+  = pprTyCon PprInterface tycon tycon_specs
   where
     tycon_specs = map snd (lookupWithDefaultFM tycon_specs_map [] tycon)
 \end{code}
@@ -408,23 +374,22 @@ do_tycon sw_chkr tycon_specs_map tycon
 %************************************************************************
 
 \begin{code}
-do_value :: (GlobalSwitch -> Bool)
-	 -> (Id -> Id)
+do_value :: (Id -> Id)
 	 -> IdEnv UnfoldingDetails
 	 -> Id
 	 -> Pretty
 
-do_value sw_chkr better_id_fn inline_env val
+do_value better_id_fn inline_env val
   = let
-	sty 	    = PprInterface sw_chkr
+	sty 	    = PprInterface
 	better_val  = better_id_fn val
 	name_str    = getOccurrenceName better_val -- NB: not orig name!
 
 	id_info	    = getIdInfo better_val
 
-	val_ty	    = let 
-			 orig_ty  = getIdUniType val
-			 final_ty = getIdUniType better_val
+	val_ty	    = let
+			 orig_ty  = idType val
+			 final_ty = idType better_val
 		      in
 --		      ASSERT (orig_ty == final_ty || mkLiftTy orig_ty == final_ty)
 		      ASSERT (if (orig_ty == final_ty || mkLiftTy orig_ty == final_ty) then True else pprTrace "do_value:" (ppCat [ppr PprDebug val, ppr PprDebug better_val]) False)
@@ -437,7 +402,7 @@ do_value sw_chkr better_id_fn inline_env val
 	-- The importing module must lift the Id before using the imported id_info
 
 	pp_id_info
-	  = if sw_chkr OmitInterfacePragmas
+	  = if opt_OmitInterfacePragmas
 	    || boringIdInfo id_info
 	    then ppNil
 	    else ppCat [ppPStr SLIT("\t{-# GHC_PRAGMA"),
@@ -446,7 +411,7 @@ do_value sw_chkr better_id_fn inline_env val
 			ppPStr SLIT("#-}")]
     in
     ppAbove (ppCat [ppr_non_op name_str,
-		    ppPStr SLIT("::"), pprUniType sty val_ty])
+		    ppPStr SLIT("::"), pprType sty val_ty])
 	    pp_id_info
 
 -- sadly duplicates Outputable.pprNonOp (ToDo)
@@ -471,16 +436,15 @@ dictionary information.  (It can be reconsituted on the other end,
 from instance and class decls).
 
 \begin{code}
-do_instance :: (GlobalSwitch -> Bool)
-	    -> (Id -> Id)
+do_instance :: (Id -> Id)
 	    -> IdEnv UnfoldingDetails
 	    -> InstInfo
 	    -> Pretty
 
-do_instance sw_chkr better_id_fn inline_env
+do_instance better_id_fn inline_env
     (InstInfo clas tv_tmpls ty inst_decl_theta dfun_theta dfun_id constm_ids _ from_here modname _ _)
   = let
-	sty = PprInterface sw_chkr
+	sty = PprInterface
 
 	better_dfun 	 = better_id_fn dfun_id
 	better_dfun_info = getIdInfo better_dfun
@@ -514,11 +478,11 @@ do_instance sw_chkr better_id_fn inline_env
 	pp_the_list [p]    = p
 	pp_the_list (p:ps) = ppAbove (ppBeside p ppComma) (pp_the_list ps)
 
-	real_stuff 
+	real_stuff
 	  = ppCat [ppPStr SLIT("instance"),
 		   ppr sty (mkSigmaTy tv_tmpls inst_decl_theta (mkDictTy clas ty))]
     in
-    if sw_chkr OmitInterfacePragmas
+    if opt_OmitInterfacePragmas
     || boringIdInfo better_dfun_info
     then real_stuff
     else ppAbove real_stuff
@@ -542,12 +506,12 @@ Classes/TyCons are ``known,'' more-or-less.  Prelude TyCons are
 Classes usually don't need to be mentioned in interfaces, but if we're
 compiling the prelude, then we treat them without special favours.
 \begin{code}
-is_exportable_tycon_or_class sw_chkr export_list_fns tc
+is_exportable_tycon_or_class export_list_fns tc
   = if not (fromPreludeCore tc) then
 	True
     else
 	in_export_list_or_among_dotdot_modules
-	    (sw_chkr CompilingPrelude) -- ignore M.. stuff if compiling prelude
+	    opt_CompilingPrelude -- ignore M.. stuff if compiling prelude
 	    export_list_fns tc
 
 in_export_list_or_among_dotdot_modules ignore_Mdotdots (in_export_list, among_dotdot_modules) tc
@@ -561,8 +525,8 @@ in_export_list_or_among_dotdot_modules ignore_Mdotdots (in_export_list, among_do
 	any among_dotdot_modules (getInformingModules tc)
 --  )
 
-is_mentionable sw_chkr tc
-  = not (from_PreludeCore_or_Builtin tc) || (sw_chkr CompilingPrelude)
+is_mentionable tc
+  = not (from_PreludeCore_or_Builtin tc) || opt_CompilingPrelude
   where
     from_PreludeCore_or_Builtin thing
       = let
@@ -570,28 +534,24 @@ is_mentionable sw_chkr tc
 	in
 	mod_name == pRELUDE_CORE || mod_name == pRELUDE_BUILTIN
 
-is_exported_inst_info sw_chkr export_list_fns
+is_exported_inst_info export_list_fns
 	(InstInfo clas _ ty _ _ _ _ _ from_here _ _ _)
   = let
-	is_fun_tycon = isFunType ty
-
     	seems_exported = instanceIsExported clas ty from_here
-
-	(tycon, _, _) = getUniDataTyCon ty
+	(tycon, _, _) = getAppTyCon ty
     in
-    if (sw_chkr OmitReexportedInstances && not from_here) then
+    if (opt_OmitReexportedInstances && not from_here) then
 	False -- Flag says to violate Haskell rules, blatantly
 
-    else if not (sw_chkr CompilingPrelude)
-         || not (is_fun_tycon || fromPreludeCore tycon)
-         || not (fromPreludeCore clas) then
+    else if not opt_CompilingPrelude
+	 || not (isFunTyCon tycon || fromPreludeCore tycon)
+	 || not (fromPreludeCore clas) then
 	seems_exported -- take what we got
 
     else -- compiling Prelude & tycon/class are Prelude things...
 	from_here
 	|| in_export_list_or_among_dotdot_modules True{-ignore M..s-} export_list_fns clas
-	|| (not is_fun_tycon
-	    && in_export_list_or_among_dotdot_modules True{-ignore M..s-} export_list_fns tycon)
+	|| in_export_list_or_among_dotdot_modules True{-ignore M..s-} export_list_fns tycon
 \end{code}
 
 \begin{code}
@@ -601,7 +561,7 @@ lt_lexical_inst_info (InstInfo _ _ _ _ _ dfun1 _ _ _ _ _ _) (InstInfo _ _ _ _ _
 
 \begin{code}
 getMentionedTyConsAndClassesFromInstInfo (InstInfo clas _ ty _ dfun_theta _ _ _ _ _ _ _)
-  = case (getMentionedTyConsAndClassesFromUniType ty) of { (ts, cs) ->
+  = case (getMentionedTyConsAndClassesFromType ty) of { (ts, cs) ->
     case [ c | (c, _) <- dfun_theta ]  	    	      of { theta_classes ->
     (ts, (cs `unionBags` listToBag theta_classes) `snocBag` clas)
     }}
diff --git a/ghc/compiler/nativeGen/AbsCStixGen.hi b/ghc/compiler/nativeGen/AbsCStixGen.hi
deleted file mode 100644
index 867abb4089..0000000000
--- a/ghc/compiler/nativeGen/AbsCStixGen.hi
+++ /dev/null
@@ -1,25 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface AbsCStixGen where
-import AbsCSyn(AbstractC, CAddrMode, CStmtMacro, MagicId, RegRelative, ReturnInfo)
-import BasicLit(BasicLit)
-import CLabelInfo(CLabel)
-import CharSeq(CSeq)
-import ClosureInfo(ClosureInfo)
-import CostCentre(CostCentre)
-import HeapOffs(HeapOffset)
-import MachDesc(RegLoc, Target)
-import Maybes(Labda)
-import PreludePS(_PackedString)
-import PreludeRatio(Ratio(..))
-import PrimKind(PrimKind)
-import PrimOps(PrimOp)
-import SMRep(SMRep)
-import SplitUniq(SUniqSM(..), SplitUniqSupply)
-import Stix(CodeSegment, StixReg, StixTree)
-data AbstractC 
-data Target 
-type SUniqSM a = SplitUniqSupply -> a
-data SplitUniqSupply 
-data StixTree 
-genCodeAbstractC :: Target -> AbstractC -> SplitUniqSupply -> [[StixTree]]
-
diff --git a/ghc/compiler/nativeGen/AbsCStixGen.lhs b/ghc/compiler/nativeGen/AbsCStixGen.lhs
index 718775a3d5..3997048dff 100644
--- a/ghc/compiler/nativeGen/AbsCStixGen.lhs
+++ b/ghc/compiler/nativeGen/AbsCStixGen.lhs
@@ -9,27 +9,26 @@ module AbsCStixGen (
 	genCodeAbstractC,
 
 	-- and, of course, that's not enough...
-	AbstractC, Target, StixTree, SplitUniqSupply, SUniqSM(..)
+	AbstractC, Target, StixTree, UniqSupply, UniqSM(..)
     ) where
 
 import AbsCSyn
-import AbsPrel		( PrimOp(..), primOpNeedsWrapper, isCompareOp
+import PrelInfo		( PrimOp(..), primOpNeedsWrapper, isCompareOp
 			  IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
 			  IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
 			)
 import CgCompInfo   	( mIN_UPD_SIZE )
-import ClosureInfo	( infoTableLabelFromCI, entryLabelFromCI, fastLabelFromCI, 
+import ClosureInfo	( infoTableLabelFromCI, entryLabelFromCI, fastLabelFromCI,
 			  closureUpdReqd
 			)
-import MachDesc	    
+import MachDesc
 import Maybes	    	( Maybe(..), maybeToBool )
-import Outputable     
-import PrimKind	    	( isFloatingKind )
+import Outputable
+import PrimRep	    	( isFloatingRep )
 import SMRep	    	( SMRep(..), SMSpecRepKind(..), SMUpdateKind(..) )
-import Stix	
+import Stix
 import StixInfo	    	( genCodeInfoTable )
-import SplitUniq
-import Unique
+import UniqSupply
 import Util
 \end{code}
 
@@ -41,14 +40,14 @@ separated so that register allocation can be performed locally within the chunk.
 -- hacking with Uncle Will:
 #define target_STRICT target@(Target _ _ _ _ _ _ _ _)
 
-genCodeAbstractC 
-    :: Target 
+genCodeAbstractC
+    :: Target
     -> AbstractC
-    -> SUniqSM [[StixTree]]
+    -> UniqSM [[StixTree]]
 
-genCodeAbstractC target_STRICT absC = 
-    mapSUs gentopcode (mkAbsCStmtList absC) `thenSUs` \ trees ->
-    returnSUs ([StComment SLIT("Native Code")] : trees)
+genCodeAbstractC target_STRICT absC =
+    mapUs gentopcode (mkAbsCStmtList absC) `thenUs` \ trees ->
+    returnUs ([StComment SLIT("Native Code")] : trees)
  where
  -- "target" munging things... ---
  a2stix  = amodeToStix  target
@@ -66,56 +65,56 @@ Here we handle top-level things, like @CCodeBlock@s and
 
 \begin{code}
  {-
- genCodeTopAbsC 
-    :: Target 
+ genCodeTopAbsC
+    :: Target
     -> AbstractC
-    -> SUniqSM [StixTree]
+    -> UniqSM [StixTree]
  -}
 
  gentopcode (CCodeBlock label absC) =
-    gencode absC				`thenSUs` \ code ->
-    returnSUs (StSegment TextSegment : StFunBegin label : code [StFunEnd label])
+    gencode absC				`thenUs` \ code ->
+    returnUs (StSegment TextSegment : StFunBegin label : code [StFunEnd label])
 
- gentopcode stmt@(CStaticClosure label _ _ _) = 
-    genCodeStaticClosure stmt			`thenSUs` \ code ->
-    returnSUs (StSegment DataSegment : StLabel label : code [])
+ gentopcode stmt@(CStaticClosure label _ _ _) =
+    genCodeStaticClosure stmt			`thenUs` \ code ->
+    returnUs (StSegment DataSegment : StLabel label : code [])
 
- gentopcode stmt@(CRetUnVector _ _) = returnSUs []
+ gentopcode stmt@(CRetUnVector _ _) = returnUs []
 
  gentopcode stmt@(CFlatRetVector label _) =
-    genCodeVecTbl stmt				`thenSUs` \ code ->
-    returnSUs (StSegment TextSegment : code [StLabel label])
+    genCodeVecTbl stmt				`thenUs` \ code ->
+    returnUs (StSegment TextSegment : code [StLabel label])
 
  gentopcode stmt@(CClosureInfoAndCode cl_info slow Nothing _ _ _)
 
   | slow_is_empty
-  = genCodeInfoTable hp_rel a2stix stmt		`thenSUs` \ itbl ->
-    returnSUs (StSegment TextSegment : itbl [])
+  = genCodeInfoTable hp_rel a2stix stmt		`thenUs` \ itbl ->
+    returnUs (StSegment TextSegment : itbl [])
 
   | otherwise
-  = genCodeInfoTable hp_rel a2stix stmt		`thenSUs` \ itbl ->
-    gencode slow				`thenSUs` \ slow_code ->
-    returnSUs (StSegment TextSegment : itbl (StFunBegin slow_lbl : 
-              slow_code [StFunEnd slow_lbl]))
+  = genCodeInfoTable hp_rel a2stix stmt		`thenUs` \ itbl ->
+    gencode slow				`thenUs` \ slow_code ->
+    returnUs (StSegment TextSegment : itbl (StFunBegin slow_lbl :
+	      slow_code [StFunEnd slow_lbl]))
   where
     slow_is_empty = not (maybeToBool (nonemptyAbsC slow))
     slow_lbl = entryLabelFromCI cl_info
 
  gentopcode stmt@(CClosureInfoAndCode cl_info slow (Just fast) _ _ _) =
  -- ToDo: what if this is empty? ------------------------^^^^
-    genCodeInfoTable hp_rel a2stix stmt		`thenSUs` \ itbl ->
-    gencode slow				`thenSUs` \ slow_code ->
-    gencode fast				`thenSUs` \ fast_code ->
-    returnSUs (StSegment TextSegment : itbl (StFunBegin slow_lbl : 
-              slow_code (StFunEnd slow_lbl : StFunBegin fast_lbl :
-              fast_code [StFunEnd fast_lbl])))
+    genCodeInfoTable hp_rel a2stix stmt		`thenUs` \ itbl ->
+    gencode slow				`thenUs` \ slow_code ->
+    gencode fast				`thenUs` \ fast_code ->
+    returnUs (StSegment TextSegment : itbl (StFunBegin slow_lbl :
+	      slow_code (StFunEnd slow_lbl : StFunBegin fast_lbl :
+	      fast_code [StFunEnd fast_lbl])))
   where
     slow_lbl = entryLabelFromCI cl_info
     fast_lbl = fastLabelFromCI cl_info
 
  gentopcode absC =
-    gencode absC				`thenSUs` \ code ->
-    returnSUs (StSegment TextSegment : code [])
+    gencode absC				`thenUs` \ code ->
+    returnUs (StSegment TextSegment : code [])
 
 \end{code}
 
@@ -123,15 +122,15 @@ Vector tables are trivial!
 
 \begin{code}
  {-
- genCodeVecTbl 
-    :: Target 
+ genCodeVecTbl
+    :: Target
     -> AbstractC
-    -> SUniqSM StixTreeList
+    -> UniqSM StixTreeList
  -}
  genCodeVecTbl (CFlatRetVector label amodes) =
-    returnSUs (\xs -> vectbl : xs)
+    returnUs (\xs -> vectbl : xs)
   where
-    vectbl = StData PtrKind (reverse (map a2stix amodes))
+    vectbl = StData PtrRep (reverse (map a2stix amodes))
 
 \end{code}
 
@@ -139,18 +138,18 @@ Static closures are not so hard either.
 
 \begin{code}
  {-
- genCodeStaticClosure 
-    :: Target 
+ genCodeStaticClosure
+    :: Target
     -> AbstractC
-    -> SUniqSM StixTreeList
+    -> UniqSM StixTreeList
  -}
  genCodeStaticClosure (CStaticClosure _ cl_info cost_centre amodes) =
-    returnSUs (\xs -> table : xs)
+    returnUs (\xs -> table : xs)
   where
-    table = StData PtrKind (StCLbl info_lbl : body)
+    table = StData PtrRep (StCLbl info_lbl : body)
     info_lbl = infoTableLabelFromCI cl_info
 
-    body = if closureUpdReqd cl_info then 
+    body = if closureUpdReqd cl_info then
     	    	take (max mIN_UPD_SIZE (length amodes')) (amodes' ++ zeros)
     	   else
     	    	amodes'
@@ -160,8 +159,8 @@ Static closures are not so hard either.
     amodes' = map amodeZeroVoid amodes
 
     	-- Watch out for VoidKinds...cf. PprAbsC
-    amodeZeroVoid item 
-      | getAmodeKind item == VoidKind = StInt 0
+    amodeZeroVoid item
+      | getAmodeRep item == VoidRep = StInt 0
       | otherwise = a2stix item
 
 \end{code}
@@ -171,9 +170,9 @@ Now the individual AbstractC statements.
 \begin{code}
  {-
  gencode
-    :: Target 
+    :: Target
     -> AbstractC
-    -> SUniqSM StixTreeList
+    -> UniqSM StixTreeList
  -}
 \end{code}
 
@@ -181,15 +180,7 @@ Now the individual AbstractC statements.
 
 \begin{code}
 
- gencode AbsCNop = returnSUs id
-
-\end{code}
-
-OLD:@CComment@s are passed through as the corresponding @StComment@s.
-
-\begin{code}
-
- --UNUSED:gencode (CComment s) = returnSUs (\xs -> StComment s : xs)
+ gencode AbsCNop = returnUs id
 
 \end{code}
 
@@ -197,7 +188,7 @@ Split markers are a NOP in this land.
 
 \begin{code}
 
- gencode CSplitMarker = returnSUs id
+ gencode CSplitMarker = returnUs id
 
 \end{code}
 
@@ -207,9 +198,9 @@ resulting StixTreeLists are joined together.
 \begin{code}
 
  gencode (AbsCStmts c1 c2) =
-    gencode c1				`thenSUs` \ b1 ->
-    gencode c2				`thenSUs` \ b2 ->
-    returnSUs (b1 . b2)
+    gencode c1				`thenUs` \ b1 ->
+    gencode c2				`thenUs` \ b2 ->
+    returnUs (b1 . b2)
 
 \end{code}
 
@@ -223,10 +214,10 @@ addresses, etc.)
 
  gencode (CInitHdr cl_info reg_rel _ _) =
     let
-	lhs = a2stix (CVal reg_rel PtrKind)
+	lhs = a2stix (CVal reg_rel PtrRep)
     	lbl = infoTableLabelFromCI cl_info
     in
-	returnSUs (\xs -> StAssign PtrKind lhs (StCLbl lbl) : xs)
+	returnUs (\xs -> StAssign PtrRep lhs (StCLbl lbl) : xs)
 
 \end{code}
 
@@ -234,20 +225,20 @@ Assignment, the curse of von Neumann, is the center of the code we
 produce.  In most cases, the type of the assignment is determined
 by the type of the destination.  However, when the destination can
 have mixed types, the type of the assignment is ``StgWord'' (we use
-PtrKind for lack of anything better).  Think:  do we also want a cast
+PtrRep for lack of anything better).  Think:  do we also want a cast
 of the source?  Be careful about floats/doubles.
 
 \begin{code}
 
  gencode (CAssign lhs rhs)
-  | getAmodeKind lhs == VoidKind = returnSUs id
+  | getAmodeRep lhs == VoidRep = returnUs id
   | otherwise =
-    let pk = getAmodeKind lhs
-    	pk' = if mixedTypeLocn lhs && not (isFloatingKind pk) then IntKind else pk
+    let pk = getAmodeRep lhs
+    	pk' = if mixedTypeLocn lhs && not (isFloatingRep pk) then IntRep else pk
     	lhs' = a2stix lhs
     	rhs' = a2stix' rhs
     in
-        returnSUs (\xs -> StAssign pk' lhs' rhs' : xs)
+	returnUs (\xs -> StAssign pk' lhs' rhs' : xs)
 
 \end{code}
 
@@ -258,24 +249,24 @@ with the address of the info table before jumping to the entry code for Node.
 \begin{code}
 
  gencode (CJump dest) =
-    returnSUs (\xs -> StJump (a2stix dest) : xs)
+    returnUs (\xs -> StJump (a2stix dest) : xs)
 
  gencode (CFallThrough (CLbl lbl _)) =
-    returnSUs (\xs -> StFallThrough lbl : xs)
+    returnUs (\xs -> StFallThrough lbl : xs)
 
  gencode (CReturn dest DirectReturn) =
-    returnSUs (\xs -> StJump (a2stix dest) : xs)
+    returnUs (\xs -> StJump (a2stix dest) : xs)
 
  gencode (CReturn table (StaticVectoredReturn n)) =
-    returnSUs (\xs -> StJump dest : xs)
-  where 
-    dest = StInd PtrKind (StIndex PtrKind (a2stix table)
+    returnUs (\xs -> StJump dest : xs)
+  where
+    dest = StInd PtrRep (StIndex PtrRep (a2stix table)
     	    	    	    	    	  (StInt (toInteger (-n-1))))
 
  gencode (CReturn table (DynamicVectoredReturn am)) =
-    returnSUs (\xs -> StJump dest : xs)
-  where 
-    dest = StInd PtrKind (StIndex PtrKind (a2stix table) dyn_off)
+    returnUs (\xs -> StJump dest : xs)
+  where
+    dest = StInd PtrRep (StIndex PtrRep (a2stix table) dyn_off)
     dyn_off = StPrim IntSubOp [StPrim IntNegOp [a2stix am], StInt 1]
 
 \end{code}
@@ -288,16 +279,16 @@ Now the PrimOps, some of which may need caller-saves register wrappers.
   -- ToDo (ADR?): use that liveness mask
   | primOpNeedsWrapper op =
     let
-        saves = volsaves vols
+	saves = volsaves vols
     	restores = volrestores vols
     in
     	p2stix (nonVoid results) op (nonVoid args)
-    	    	    	    		    	      	`thenSUs` \ code ->
-    	returnSUs (\xs -> saves ++ code (restores ++ xs))
+    	    	    	    		    	      	`thenUs` \ code ->
+    	returnUs (\xs -> saves ++ code (restores ++ xs))
 
   | otherwise = p2stix (nonVoid results) op (nonVoid args)
     where
-        nonVoid = filter ((/= VoidKind) . getAmodeKind)
+	nonVoid = filter ((/= VoidRep) . getAmodeRep)
 
 \end{code}
 
@@ -306,11 +297,11 @@ Now the dreaded conditional jump.
 Now the if statement.  Almost *all* flow of control are of this form.
 @
 	if (am==lit) { absC } else { absCdef }
-@ 
+@
 	=>
 @
 	IF am = lit GOTO l1:
-	absC 
+	absC
 	jump l2:
    l1:
 	absCdef
@@ -319,29 +310,29 @@ Now the if statement.  Almost *all* flow of control are of this form.
 
 \begin{code}
 
- gencode (CSwitch discrim alts deflt) 
+ gencode (CSwitch discrim alts deflt)
   = case alts of
       [] -> gencode deflt
 
       [(tag,alt_code)] -> case maybe_empty_deflt of
 				Nothing -> gencode alt_code
-			        Just dc -> mkIfThenElse discrim tag alt_code dc
+				Just dc -> mkIfThenElse discrim tag alt_code dc
 
       [(tag1@(MachInt i1 _), alt_code1),
-       (tag2@(MachInt i2 _), alt_code2)] 
+       (tag2@(MachInt i2 _), alt_code2)]
 	| deflt_is_empty && i1 == 0 && i2 == 1
 	-> mkIfThenElse discrim tag1 alt_code1 alt_code2
 	| deflt_is_empty && i1 == 1 && i2 == 0
 	-> mkIfThenElse discrim tag2 alt_code2 alt_code1
- 
+
 	-- If the @discrim@ is simple, then this unfolding is safe.
       other | simple_discrim -> mkSimpleSwitches discrim alts deflt
 
 	-- Otherwise, we need to do a bit of work.
-      other ->  getSUnique		      	  `thenSUs` \ u ->
+      other ->  getUnique		      	  `thenUs` \ u ->
 		gencode (AbsCStmts
-	        (CAssign (CTemp u pk) discrim)
-	        (CSwitch (CTemp u pk) alts deflt))
+		(CAssign (CTemp u pk) discrim)
+		(CSwitch (CTemp u pk) alts deflt))
 
   where
     maybe_empty_deflt = nonemptyAbsC deflt
@@ -349,7 +340,7 @@ Now the if statement.  Almost *all* flow of control are of this form.
 			Nothing -> True
 			Just _  -> False
 
-    pk = getAmodeKind discrim
+    pk = getAmodeRep discrim
 
     simple_discrim = case discrim of
 			CReg _    -> True
@@ -366,10 +357,10 @@ Finally, all of the disgusting AbstractC macros.
  gencode (CMacroStmt macro args) = macro_code macro args
 
  gencode (CCallProfCtrMacro macro _) =
-    returnSUs (\xs -> StComment macro : xs)
+    returnUs (\xs -> StComment macro : xs)
 
  gencode (CCallProfCCMacro macro _) =
-    returnSUs (\xs -> StComment macro : xs)
+    returnUs (\xs -> StComment macro : xs)
 
 \end{code}
 
@@ -379,26 +370,26 @@ comparison tree.  (Perhaps this could be tuned.)
 
 \begin{code}
 
- intTag :: BasicLit -> Integer
+ intTag :: Literal -> Integer
  intTag (MachChar c) = toInteger (ord c)
  intTag (MachInt i _) = i
  intTag _ = panic "intTag"
 
- fltTag :: BasicLit -> Rational
+ fltTag :: Literal -> Rational
 
  fltTag (MachFloat f) = f
  fltTag (MachDouble d) = d
  fltTag _ = panic "fltTag"
 
  {-
- mkSimpleSwitches 
-    :: Target 
-    -> CAddrMode -> [(BasicLit,AbstractC)] -> AbstractC
-    -> SUniqSM StixTreeList
+ mkSimpleSwitches
+    :: Target
+    -> CAddrMode -> [(Literal,AbstractC)] -> AbstractC
+    -> UniqSM StixTreeList
  -}
  mkSimpleSwitches am alts absC =
-    getUniqLabelNCG 	    	    	    	    	`thenSUs` \ udlbl ->
-    getUniqLabelNCG 	    	    	    	    	`thenSUs` \ ujlbl ->
+    getUniqLabelNCG 	    	    	    	    	`thenUs` \ udlbl ->
+    getUniqLabelNCG 	    	    	    	    	`thenUs` \ ujlbl ->
     let am' = a2stix am
     	joinedAlts = map (\ (tag,code) -> (tag, mkJoin code ujlbl)) alts
     	sortedAlts = naturalMergeSortLe leAlt joinedAlts
@@ -425,13 +416,13 @@ comparison tree.  (Perhaps this could be tuned.)
     	else
     	    mkBinaryTree am' floating sortedAlts choices lowest highest udlbl
     	)
-    	    	    	    	    	    	    	`thenSUs` \ alt_code ->
-        gencode absC				`thenSUs` \ dflt_code ->
+    	    	    	    	    	    	    	`thenUs` \ alt_code ->
+	gencode absC				`thenUs` \ dflt_code ->
 
-    	returnSUs (\xs -> alt_code (StLabel udlbl : dflt_code (StLabel ujlbl : xs)))
+    	returnUs (\xs -> alt_code (StLabel udlbl : dflt_code (StLabel ujlbl : xs)))
 
     where
-    	floating = isFloatingKind (getAmodeKind am)
+    	floating = isFloatingRep (getAmodeRep am)
     	choices = length alts
 
     	(x@(MachChar _),_)  `leAlt` (y,_) = intTag x <= intTag y
@@ -442,7 +433,7 @@ comparison tree.  (Perhaps this could be tuned.)
 
 We use jump tables when doing an integer switch on a relatively dense list of
 alternatives.  We expect to be given a list of alternatives, sorted by tag,
-and a range of values for which we are to generate a table.  Of course, the tags of 
+and a range of values for which we are to generate a table.  Of course, the tags of
 the alternatives should lie within the indicated range.  The alternatives need
 not cover the range; a default target is provided for the missing alternatives.
 
@@ -452,39 +443,39 @@ with a jump to the join point.
 \begin{code}
  {-
  mkJumpTable
-    :: Target 
+    :: Target
     -> StixTree  	    	-- discriminant
-    -> [(BasicLit, AbstractC)] 	-- alternatives
+    -> [(Literal, AbstractC)] 	-- alternatives
     -> Integer 	    	    	-- low tag
     -> Integer 	    	    	-- high tag
     -> CLabel	    	    	-- default label
-    -> SUniqSM StixTreeList
+    -> UniqSM StixTreeList
  -}
 
  mkJumpTable am alts lowTag highTag dflt =
-    getUniqLabelNCG 	    	    	    	    	`thenSUs` \ utlbl ->
-    mapSUs genLabel alts 	  	    	    	`thenSUs` \ branches ->
+    getUniqLabelNCG 	    	    	    	    	`thenUs` \ utlbl ->
+    mapUs genLabel alts 	  	    	    	`thenUs` \ branches ->
     let	cjmpLo = StCondJump dflt (StPrim IntLtOp [am, StInt lowTag])
     	cjmpHi = StCondJump dflt (StPrim IntGtOp [am, StInt highTag])
 
     	offset = StPrim IntSubOp [am, StInt lowTag]
-    	jump = StJump (StInd PtrKind (StIndex PtrKind (StCLbl utlbl) offset))
+    	jump = StJump (StInd PtrRep (StIndex PtrRep (StCLbl utlbl) offset))
 
     	tlbl = StLabel utlbl
-    	table = StData PtrKind (mkTable branches [lowTag..highTag] [])
-    in    
-    	mapSUs mkBranch branches       	    	    	`thenSUs` \ alts ->
+    	table = StData PtrRep (mkTable branches [lowTag..highTag] [])
+    in
+    	mapUs mkBranch branches       	    	    	`thenUs` \ alts ->
 
-        returnSUs (\xs -> cjmpLo : cjmpHi : jump : 
-                         StSegment DataSegment : tlbl : table : 
-                         StSegment TextSegment : foldr1 (.) alts xs)
+	returnUs (\xs -> cjmpLo : cjmpHi : jump :
+			 StSegment DataSegment : tlbl : table :
+			 StSegment TextSegment : foldr1 (.) alts xs)
 
     where
-    	genLabel x = getUniqLabelNCG `thenSUs` \ lbl -> returnSUs (lbl, x)
+    	genLabel x = getUniqLabelNCG `thenUs` \ lbl -> returnUs (lbl, x)
 
     	mkBranch (lbl,(_,alt)) =
-            gencode alt  	    		`thenSUs` \ alt_code ->
-    	    returnSUs (\xs -> StLabel lbl : alt_code xs)
+	    gencode alt  	    		`thenUs` \ alt_code ->
+    	    returnUs (\xs -> StLabel lbl : alt_code xs)
 
     	mkTable _  []     tbl = reverse tbl
     	mkTable [] (x:xs) tbl = mkTable [] xs (StCLbl dflt : tbl)
@@ -503,51 +494,51 @@ is longer.)  We can handle either integer or floating kind alternatives,
 so long as they are not mixed.  (We assume that the type of the discriminant
 determines the type of the alternatives.)
 
-As with the jump table approach, if a join is necessary after the switch, the 
+As with the jump table approach, if a join is necessary after the switch, the
 alternatives should already finish with a jump to the join point.
 
 \begin{code}
  {-
- mkBinaryTree 
-    :: Target 
+ mkBinaryTree
+    :: Target
     -> StixTree  	    	-- discriminant
     -> Bool 	    	    	-- floating point?
-    -> [(BasicLit, AbstractC)] 	-- alternatives
+    -> [(Literal, AbstractC)] 	-- alternatives
     -> Int  	    	    	-- number of choices
-    -> BasicLit     	    	-- low tag
-    -> BasicLit     	    	-- high tag
+    -> Literal     	    	-- low tag
+    -> Literal     	    	-- high tag
     -> CLabel	    	    	-- default code label
-    -> SUniqSM StixTreeList
+    -> UniqSM StixTreeList
  -}
 
- mkBinaryTree am floating [(tag,alt)] _ lowTag highTag udlbl 
+ mkBinaryTree am floating [(tag,alt)] _ lowTag highTag udlbl
   | rangeOfOne = gencode alt
-  | otherwise = 
+  | otherwise =
     let	tag' = a2stix (CLit tag)
     	cmpOp = if floating then DoubleNeOp else IntNeOp
     	test = StPrim cmpOp [am, tag']
     	cjmp = StCondJump udlbl test
     in
-    	gencode alt 	    	    	    	`thenSUs` \ alt_code ->
-        returnSUs (\xs -> cjmp : alt_code xs)
+    	gencode alt 	    	    	    	`thenUs` \ alt_code ->
+	returnUs (\xs -> cjmp : alt_code xs)
 
-    where 
+    where
     	rangeOfOne = not floating && intTag lowTag + 1 >= intTag highTag
     	-- When there is only one possible tag left in range, we skip the comparison
 
  mkBinaryTree am floating alts choices lowTag highTag udlbl =
-    getUniqLabelNCG					`thenSUs` \ uhlbl ->
+    getUniqLabelNCG					`thenUs` \ uhlbl ->
     let tag' = a2stix (CLit splitTag)
     	cmpOp = if floating then DoubleGeOp else IntGeOp
     	test = StPrim cmpOp [am, tag']
     	cjmp = StCondJump uhlbl test
     in
     	mkBinaryTree am floating alts_lo half lowTag splitTag udlbl
-    	    	    	    	    	    	  	`thenSUs` \ lo_code ->
+    	    	    	    	    	    	  	`thenUs` \ lo_code ->
     	mkBinaryTree am floating alts_hi (choices - half) splitTag highTag udlbl
-    	    	    	    	    		    	`thenSUs` \ hi_code ->
+    	    	    	    	    		    	`thenUs` \ hi_code ->
 
-        returnSUs (\xs -> cjmp : lo_code (StLabel uhlbl : hi_code xs))
+	returnUs (\xs -> cjmp : lo_code (StLabel uhlbl : hi_code xs))
 
     where
     	half = choices `div` 2
@@ -558,34 +549,34 @@ alternatives should already finish with a jump to the join point.
 
 \begin{code}
  {-
- mkIfThenElse 
-    :: Target 
+ mkIfThenElse
+    :: Target
     -> CAddrMode    	    -- discriminant
-    -> BasicLit     	    -- tag
+    -> Literal     	    -- tag
     -> AbstractC    	    -- if-part
     -> AbstractC    	    -- else-part
-    -> SUniqSM StixTreeList
+    -> UniqSM StixTreeList
  -}
 
  mkIfThenElse discrim tag alt deflt =
-    getUniqLabelNCG					`thenSUs` \ ujlbl ->
-    getUniqLabelNCG					`thenSUs` \ utlbl ->
+    getUniqLabelNCG					`thenUs` \ ujlbl ->
+    getUniqLabelNCG					`thenUs` \ utlbl ->
     let discrim' = a2stix discrim
     	tag' = a2stix (CLit tag)
-    	cmpOp = if (isFloatingKind (getAmodeKind discrim)) then DoubleNeOp else IntNeOp
+    	cmpOp = if (isFloatingRep (getAmodeRep discrim)) then DoubleNeOp else IntNeOp
     	test = StPrim cmpOp [discrim', tag']
     	cjmp = StCondJump utlbl test
     	dest = StLabel utlbl
     	join = StLabel ujlbl
     in
-        gencode (mkJoin alt ujlbl)		`thenSUs` \ alt_code ->
-        gencode deflt				`thenSUs` \ dflt_code ->
-        returnSUs (\xs -> cjmp : alt_code (dest : dflt_code (join : xs)))
+	gencode (mkJoin alt ujlbl)		`thenUs` \ alt_code ->
+	gencode deflt				`thenUs` \ dflt_code ->
+	returnUs (\xs -> cjmp : alt_code (dest : dflt_code (join : xs)))
 
 mkJoin :: AbstractC -> CLabel -> AbstractC
 
-mkJoin code lbl 
-  | mightFallThrough code = mkAbsCStmts code (CJump (CLbl lbl PtrKind))
+mkJoin code lbl
+  | mightFallThrough code = mkAbsCStmts code (CJump (CLbl lbl PtrRep))
   | otherwise = code
 \end{code}
 
@@ -605,7 +596,7 @@ mightFallThrough absC = ft absC True
 
   ft (CJump _)       if_empty = False
   ft (CReturn _ _)   if_empty = False
-  ft (CSwitch _ alts deflt) if_empty 
+  ft (CSwitch _ alts deflt) if_empty
 	= ft deflt if_empty ||
 	  or [ft alt if_empty | (_,alt) <- alts]
 
diff --git a/ghc/compiler/nativeGen/AlphaCode.hi b/ghc/compiler/nativeGen/AlphaCode.hi
deleted file mode 100644
index 1b9966ca18..0000000000
--- a/ghc/compiler/nativeGen/AlphaCode.hi
+++ /dev/null
@@ -1,57 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface AlphaCode where
-import AbsCSyn(MagicId)
-import AsmRegAlloc(MachineCode, MachineRegisters, Reg)
-import BitSet(BitSet)
-import CLabelInfo(CLabel)
-import CharSeq(CSeq)
-import FiniteMap(FiniteMap)
-import Maybes(Labda)
-import OrdList(OrdList)
-import PreludePS(_PackedString)
-import Pretty(PprStyle)
-import PrimKind(PrimKind)
-import Stix(CodeSegment)
-import UniqFM(UniqFM)
-import UniqSet(UniqSet(..))
-import Unique(Unique)
-data Addr   = AddrImm Imm | AddrReg Reg | AddrRegImm Reg Imm
-type AlphaCode = OrdList AlphaInstr
-data AlphaInstr
-  = LD Size Reg Addr | LDA Reg Addr | LDAH Reg Addr | LDGP Reg Addr | LDI Size Reg Imm | ST Size Reg Addr | CLR Reg | ABS Size RI Reg | NEG Size Bool RI Reg | ADD Size Bool Reg RI Reg | SADD Size Size Reg RI Reg | SUB Size Bool Reg RI Reg | SSUB Size Size Reg RI Reg | MUL Size Bool Reg RI Reg | DIV Size Bool Reg RI Reg | REM Size Bool Reg RI Reg | NOT RI Reg | AND Reg RI Reg | ANDNOT Reg RI Reg | OR Reg RI Reg | ORNOT Reg RI Reg | XOR Reg RI Reg | XORNOT Reg RI Reg | SLL Reg RI Reg | SRL Reg RI Reg | SRA Reg RI Reg | ZAP Reg RI Reg | ZAPNOT Reg RI Reg | NOP | CMP Cond Reg RI Reg | FCLR Reg | FABS Reg Reg | FNEG Size Reg Reg | FADD Size Reg Reg Reg | FDIV Size Reg Reg Reg | FMUL Size Reg Reg Reg | FSUB Size Reg Reg Reg | CVTxy Size Size Reg Reg | FCMP Size Cond Reg Reg Reg | FMOV Reg Reg | BI Cond Reg Imm | BF Cond Reg Imm | BR Imm | JMP Reg Addr Int | BSR Imm Int | JSR Reg Addr Int | LABEL CLabel | FUNBEGIN CLabel | FUNEND CLabel | COMMENT _PackedString | SEGMENT CodeSegment | ASCII Bool [Char] | DATA Size [Imm]
-data AlphaRegs 
-data MagicId 
-data Reg 
-data BitSet 
-data CLabel 
-data CSeq 
-data Cond   = EQ | LT | LE | ULT | ULE | NE | GT | GE | ALWAYS | NEVER
-data FiniteMap a b 
-data Imm   = ImmInt Int | ImmInteger Integer | ImmCLbl CLabel | ImmLab CSeq
-data OrdList a 
-data PrimKind 
-data CodeSegment 
-data RI   = RIReg Reg | RIImm Imm
-data Size   = B | BU | W | WU | L | Q | FF | DF | GF | SF | TF
-data UniqFM a 
-type UniqSet a = UniqFM a
-data Unique 
-argRegs :: [(Reg, Reg)]
-baseRegOffset :: MagicId -> Int
-callerSaves :: MagicId -> Bool
-f0 :: Reg
-freeRegs :: [Reg]
-gp :: Reg
-kindToSize :: PrimKind -> Size
-printLabeledCodes :: PprStyle -> [AlphaInstr] -> CSeq
-pv :: Reg
-ra :: Reg
-reservedRegs :: [Int]
-sp :: Reg
-stgRegMap :: MagicId -> Labda Reg
-strImmLab :: [Char] -> Imm
-v0 :: Reg
-zero :: Reg
-instance MachineCode AlphaInstr
-instance MachineRegisters AlphaRegs
-
diff --git a/ghc/compiler/nativeGen/AlphaCode.lhs b/ghc/compiler/nativeGen/AlphaCode.lhs
index 5d7f4b2a3f..5b5069a39f 100644
--- a/ghc/compiler/nativeGen/AlphaCode.lhs
+++ b/ghc/compiler/nativeGen/AlphaCode.lhs
@@ -20,11 +20,9 @@ module AlphaCode (
 
 	v0, f0, sp, ra, pv, gp, zero, argRegs,
 
-	freeRegs, reservedRegs,
+	freeRegs, reservedRegs
 
 	-- and, for self-sufficiency ...
-	CLabel, CodeSegment, OrdList, PrimKind, Reg, UniqSet(..),
-	UniqFM, FiniteMap, Unique, MagicId, CSeq, BitSet
     ) where
 
 IMPORT_Trace
@@ -34,13 +32,13 @@ import AsmRegAlloc  ( MachineCode(..), MachineRegisters(..), FutureLive(..),
 		      Reg(..), RegUsage(..), RegLiveness(..)
 		    )
 import BitSet
-import CLabelInfo   ( CLabel, pprCLabel, externallyVisibleCLabel, charToC )
+import CLabel   ( CLabel, pprCLabel, externallyVisibleCLabel, charToC )
 import CgCompInfo   ( mAX_Double_REG, mAX_Float_REG, mAX_Vanilla_REG )
 import FiniteMap
 import Maybes	    ( Maybe(..), maybeToBool )
 import OrdList	    ( OrdList, mkUnitList, flattenOrdList )
 import Outputable
-import PrimKind	    ( PrimKind(..) )
+import PrimRep	    ( PrimRep(..) )
 import UniqSet
 import Stix
 import Unpretty
@@ -772,8 +770,8 @@ instance MachineRegisters AlphaRegs where
 	(ints, floats) = partition (< 32) xs
 	floats' = map (subtract 32) floats
 
-    possibleMRegs FloatKind (SRegs _ floats) = [ x + 32 | x <- listBS floats]
-    possibleMRegs DoubleKind (SRegs _ floats) = [ x + 32 | x <- listBS floats]
+    possibleMRegs FloatRep (SRegs _ floats) = [ x + 32 | x <- listBS floats]
+    possibleMRegs DoubleRep (SRegs _ floats) = [ x + 32 | x <- listBS floats]
     possibleMRegs _ (SRegs ints _) = listBS ints
 
     useMReg (SRegs ints floats) n =
@@ -797,10 +795,6 @@ instance MachineRegisters AlphaRegs where
 	SRegs ints' floats' = mkMRegs xs
 
 instance MachineCode AlphaInstr where
-    -- Alas, we don't do anything clever with our OrdLists
---OLD:
---  flatten = flattenOrdList
-
     regUsage = alphaRegUsage
     regLiveness = alphaRegLiveness
     patchRegs = alphaPatchRegs
@@ -812,23 +806,22 @@ instance MachineCode AlphaInstr where
 spRel :: Int -> Addr
 spRel n = AddrRegImm sp (ImmInt (n * 8))
 
-kindToSize :: PrimKind -> Size
-kindToSize PtrKind	    = Q
-kindToSize CodePtrKind	    = Q
-kindToSize DataPtrKind	    = Q
-kindToSize RetKind	    = Q
-kindToSize InfoPtrKind	    = Q
-kindToSize CostCentreKind   = Q
-kindToSize CharKind	    = BU
-kindToSize IntKind	    = Q
-kindToSize WordKind	    = Q
-kindToSize AddrKind	    = Q
-kindToSize FloatKind	    = TF
-kindToSize DoubleKind	    = TF
-kindToSize ArrayKind	    = Q
-kindToSize ByteArrayKind    = Q
-kindToSize StablePtrKind    = Q
-kindToSize MallocPtrKind    = Q
+kindToSize :: PrimRep -> Size
+kindToSize PtrRep	    = Q
+kindToSize CodePtrRep	    = Q
+kindToSize DataPtrRep	    = Q
+kindToSize RetRep	    = Q
+kindToSize CostCentreRep   = Q
+kindToSize CharRep	    = BU
+kindToSize IntRep	    = Q
+kindToSize WordRep	    = Q
+kindToSize AddrRep	    = Q
+kindToSize FloatRep	    = TF
+kindToSize DoubleRep	    = TF
+kindToSize ArrayRep	    = Q
+kindToSize ByteArrayRep    = Q
+kindToSize StablePtrRep    = Q
+kindToSize MallocPtrRep    = Q
 
 \end{code}
 
@@ -930,10 +923,6 @@ freeSet = mkUniqSet freeRegs
 noUsage :: RegUsage
 noUsage = RU emptyUniqSet emptyUniqSet
 
---OLD:
---endUsage :: RegUsage
---endUsage = RU emptyUniqSet freeSet
-
 -- Color me CAF-like
 argSet :: Int -> UniqSet Reg
 argSet 0 = emptyUniqSet
@@ -977,7 +966,7 @@ alphaRegLiveness instr info@(RL live future@(FL all env)) = case instr of
     BSR _ _		 -> RL live future
     JSR _ _ _		 -> RL live future
     LABEL lbl		 -> RL live (FL (all `unionUniqSets` live) (addToFM env lbl live))
-    _			 -> info  
+    _			 -> info
 
   where
     lookup lbl = case lookupFM env lbl of
diff --git a/ghc/compiler/nativeGen/AlphaDesc.hi b/ghc/compiler/nativeGen/AlphaDesc.hi
deleted file mode 100644
index 750e28eb31..0000000000
--- a/ghc/compiler/nativeGen/AlphaDesc.hi
+++ /dev/null
@@ -1,24 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface AlphaDesc where
-import AbsCSyn(MagicId)
-import CLabelInfo(CLabel)
-import CharSeq(CSeq)
-import CmdLineOpts(GlobalSwitch, SwitchResult)
-import MachDesc(RegLoc, Target)
-import PreludePS(_PackedString)
-import PreludeRatio(Ratio(..))
-import Pretty(PprStyle)
-import PrimKind(PrimKind)
-import PrimOps(PrimOp)
-import SMRep(SMRep, SMSpecRepKind, SMUpdateKind)
-import SplitUniq(SplitUniqSupply)
-import Stix(CodeSegment, StixReg, StixTree)
-data MagicId 
-data SwitchResult 
-data RegLoc 
-data PprStyle 
-data PrimKind 
-data SMRep 
-data StixTree 
-mkAlpha :: (GlobalSwitch -> SwitchResult) -> (Target, PprStyle -> [[StixTree]] -> SplitUniqSupply -> CSeq, Bool, [Char] -> [Char])
-
diff --git a/ghc/compiler/nativeGen/AlphaDesc.lhs b/ghc/compiler/nativeGen/AlphaDesc.lhs
index 2c0eeb544e..43852f2082 100644
--- a/ghc/compiler/nativeGen/AlphaDesc.lhs
+++ b/ghc/compiler/nativeGen/AlphaDesc.lhs
@@ -7,40 +7,36 @@
 #include "HsVersions.h"
 
 module AlphaDesc (
-    	mkAlpha,
+    	mkAlpha
 
     	-- and assorted nonsense referenced by the class methods
-
-        PprStyle, SMRep, MagicId, RegLoc, StixTree, PrimKind, SwitchResult
-
     ) where
 
 import AbsCSyn
-import AbsPrel		( PrimOp(..)
+import PrelInfo		( PrimOp(..)
 			  IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
 			  IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
 			)
 import AsmRegAlloc  	( Reg, MachineCode(..), MachineRegisters(..),
 			  RegUsage(..), RegLiveness(..), FutureLive(..)
 			)
-import CLabelInfo   	( CLabel )
+import CLabel   	( CLabel )
 import CmdLineOpts  	( GlobalSwitch(..), stringSwitchSet,
 			  switchIsOn, SwitchResult(..)
 			)
 import HeapOffs	    	( hpRelToInt )
-import MachDesc	    	
+import MachDesc
 import Maybes	    	( Maybe(..) )
-import OrdList	   	
-import Outputable     	
-import PrimKind	    	( PrimKind(..) )
+import OrdList
+import Outputable
+import PrimRep	    	( PrimRep(..) )
 import SMRep	    	( SMRep(..), SMSpecRepKind(..), SMUpdateKind(..) )
-import AlphaCode     	
+import AlphaCode
 import AlphaGen	    	( alphaCodeGen )
 import Stix
 import StixMacro
 import StixPrim
-import SplitUniq
-import Unique
+import UniqSupply
 import Util
 
 \end{code}
@@ -89,11 +85,11 @@ alphaReg switches x =
     	    StkStubReg -> sStLitLbl SLIT("STK_STUB_closure")
     	    StdUpdRetVecReg -> sStLitLbl SLIT("vtbl_StdUpdFrame")
     	    BaseReg -> sStLitLbl SLIT("MainRegTable")
-    	    Hp -> StInd PtrKind (sStLitLbl SLIT("StorageMgrInfo"))
-    	    HpLim -> StInd PtrKind (sStLitLbl SLIT("StorageMgrInfo+8"))
-    	    TagReg -> StInd IntKind (StPrim IntSubOp [infoptr, StInt (1*8)])
-    	    	      where 
-    	    	    	  r2 = VanillaReg PtrKind ILIT(2)
+    	    Hp -> StInd PtrRep (sStLitLbl SLIT("StorageMgrInfo"))
+    	    HpLim -> StInd PtrRep (sStLitLbl SLIT("StorageMgrInfo+8"))
+    	    TagReg -> StInd IntRep (StPrim IntSubOp [infoptr, StInt (1*8)])
+    	    	      where
+    	    	    	  r2 = VanillaReg PtrRep ILIT(2)
     	    	    	  infoptr = case alphaReg switches r2 of
     	    	    	    	    	Always tree -> tree
     	    	    	    	    	Save _ -> StReg (StixMagicId r2)
@@ -102,8 +98,8 @@ alphaReg switches x =
     	  baseLoc = case stgRegMap BaseReg of
     	    Just _ -> StReg (StixMagicId BaseReg)
     	    Nothing -> sStLitLbl SLIT("MainRegTable")
-          offset = baseRegOffset x
-		    
+	  offset = baseRegOffset x
+
 \end{code}
 
 Sizes in bytes.
@@ -121,20 +117,20 @@ because some are reloaded from constants.
 
 \begin{code}
 
-vsaves switches vols = 
+vsaves switches vols =
     map save ((filter callerSaves) ([BaseReg,SpA,SuA,SpB,SuB,Hp,HpLim,RetReg{-,ActivityReg-}] ++ vols))
     where
-        save x = StAssign (kindFromMagicId x) loc reg
+	save x = StAssign (kindFromMagicId x) loc reg
     	    	    where reg = StReg (StixMagicId x)
     	    	    	  loc = case alphaReg switches x of
     	    	    	    	    Save loc -> loc
     	    	    	    	    Always loc -> panic "vsaves"
 
-vrests switches vols = 
-    map restore ((filter callerSaves) 
+vrests switches vols =
+    map restore ((filter callerSaves)
     	([BaseReg,SpA,SuA,SpB,SuB,Hp,HpLim,RetReg,{-ActivityReg,-}StkStubReg,StdUpdRetVecReg] ++ vols))
     where
-        restore x = StAssign (kindFromMagicId x) reg loc
+	restore x = StAssign (kindFromMagicId x) reg loc
     	    	    where reg = StReg (StixMagicId x)
     	    	    	  loc = case alphaReg switches x of
     	    	    	    	    Save loc -> loc
@@ -148,22 +144,22 @@ Static closure sizes.
 
 charLikeSize, intLikeSize :: Target -> Int
 
-charLikeSize target = 
-    size PtrKind * (fixedHeaderSize target + varHeaderSize target charLikeRep + 1)
+charLikeSize target =
+    size PtrRep * (fixedHeaderSize target + varHeaderSize target charLikeRep + 1)
     where charLikeRep = SpecialisedRep CharLikeRep 0 1 SMNormalForm
 
-intLikeSize target = 
-    size PtrKind * (fixedHeaderSize target + varHeaderSize target intLikeRep + 1)
+intLikeSize target =
+    size PtrRep * (fixedHeaderSize target + varHeaderSize target intLikeRep + 1)
     where intLikeRep = SpecialisedRep IntLikeRep 0 1 SMNormalForm
 
 mhs, dhs :: (GlobalSwitch -> SwitchResult) -> StixTree
 
 mhs switches = StInt (toInteger words)
-  where 
+  where
     words = fhs switches + vhs switches (MuTupleRep 0)
 
 dhs switches = StInt (toInteger words)
-  where 
+  where
     words = fhs switches + vhs switches (DataRep 0)
 
 \end{code}
@@ -174,27 +170,27 @@ Setting up a alpha target.
 
 mkAlpha :: (GlobalSwitch -> SwitchResult)
 	-> (Target,
-	    (PprStyle -> [[StixTree]] -> SUniqSM Unpretty), -- codeGen
+	    (PprStyle -> [[StixTree]] -> UniqSM Unpretty), -- codeGen
 	    Bool,					    -- underscore
 	    (String -> String))				    -- fmtAsmLbl
 
-mkAlpha switches = 
+mkAlpha switches =
     let
 	fhs' = fhs switches
     	vhs' = vhs switches
     	alphaReg' = alphaReg switches
     	vsaves' = vsaves switches
     	vrests' = vrests switches
-    	hprel = hpRelToInt target 
-        as = amodeCode target
-        as' = amodeCode' target
+    	hprel = hpRelToInt target
+	as = amodeCode target
+	as' = amodeCode' target
     	csz = charLikeSize target
     	isz = intLikeSize target
     	mhs' = mhs switches
     	dhs' = dhs switches
     	ps = genPrimCode target
     	mc = genMacroCode target
-    	hc = doHeapCheck --UNUSED NOW: target
+    	hc = doHeapCheck
     	target = mkTarget {-switches-} fhs' vhs' alphaReg' {-id-} size
     	    	    	  hprel as as'
 			  (vsaves', vrests', csz, isz, mhs', dhs', ps, mc, hc)
diff --git a/ghc/compiler/nativeGen/AlphaGen.hi b/ghc/compiler/nativeGen/AlphaGen.hi
deleted file mode 100644
index 9d24768163..0000000000
--- a/ghc/compiler/nativeGen/AlphaGen.hi
+++ /dev/null
@@ -1,17 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface AlphaGen where
-import CLabelInfo(CLabel)
-import CharSeq(CSeq)
-import CmdLineOpts(GlobalSwitch)
-import PreludePS(_PackedString)
-import PreludeRatio(Ratio(..))
-import Pretty(PprStyle)
-import PrimKind(PrimKind)
-import PrimOps(PrimOp)
-import SplitUniq(SplitUniqSupply)
-import Stix(CodeSegment, StixReg, StixTree)
-data CSeq 
-data PprStyle 
-data StixTree 
-alphaCodeGen :: PprStyle -> [[StixTree]] -> SplitUniqSupply -> CSeq
-
diff --git a/ghc/compiler/nativeGen/AlphaGen.lhs b/ghc/compiler/nativeGen/AlphaGen.lhs
index 533a5184db..2d5071acf0 100644
--- a/ghc/compiler/nativeGen/AlphaGen.lhs
+++ b/ghc/compiler/nativeGen/AlphaGen.lhs
@@ -15,7 +15,7 @@ module AlphaGen (
 IMPORT_Trace
 
 import AbsCSyn	    ( AbstractC, MagicId(..), kindFromMagicId )
-import AbsPrel	    ( PrimOp(..)
+import PrelInfo	    ( PrimOp(..)
 		      IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
 			  IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
 		    )
@@ -23,17 +23,15 @@ import AsmRegAlloc  ( runRegAllocate, extractMappedRegNos, mkReg,
 		      Reg(..), RegLiveness(..), RegUsage(..), FutureLive(..),
 		      MachineRegisters(..), MachineCode(..)
     	    	    )
-import CLabelInfo   ( CLabel, isAsmTemp )
+import CLabel   ( CLabel, isAsmTemp )
 import AlphaCode    {- everything -}
 import MachDesc
 import Maybes	    ( maybeToBool, Maybe(..) )
 import OrdList	    -- ( mkEmptyList, mkUnitList, mkSeqList, mkParList, OrdList )
 import Outputable
-import PrimKind	    ( PrimKind(..), isFloatingKind )
 import AlphaDesc
 import Stix
-import SplitUniq
-import Unique
+import UniqSupply
 import Pretty
 import Unpretty
 import Util
@@ -52,14 +50,14 @@ This is the top-level code-generation function for the Alpha.
 
 \begin{code}
 
-alphaCodeGen :: PprStyle -> [[StixTree]] -> SUniqSM Unpretty
-alphaCodeGen sty trees = 
-    mapSUs genAlphaCode trees	    	`thenSUs` \ dynamicCodes ->
+alphaCodeGen :: PprStyle -> [[StixTree]] -> UniqSM Unpretty
+alphaCodeGen sty trees =
+    mapUs genAlphaCode trees	    	`thenUs` \ dynamicCodes ->
     let
     	staticCodes = scheduleAlphaCode dynamicCodes
     	pretty = printLabeledCodes sty staticCodes
     in
-    	returnSUs pretty
+    	returnUs pretty
 
 \end{code}
 
@@ -84,9 +82,9 @@ register to put it in.
 
 \begin{code}
 
-data Register 
-  = Fixed Reg PrimKind (CodeBlock AlphaInstr) 
-  | Any PrimKind (Reg -> (CodeBlock AlphaInstr))
+data Register
+  = Fixed Reg PrimRep (CodeBlock AlphaInstr)
+  | Any PrimRep (Reg -> (CodeBlock AlphaInstr))
 
 registerCode :: Register -> Reg -> CodeBlock AlphaInstr
 registerCode (Fixed _ _ code) reg = code
@@ -96,7 +94,7 @@ registerName :: Register -> Reg -> Reg
 registerName (Fixed reg _ _) _ = reg
 registerName (Any _ _) reg = reg
 
-registerKind :: Register -> PrimKind
+registerKind :: Register -> PrimRep
 registerKind (Fixed _ pk _) = pk
 registerKind (Any pk _) = pk
 
@@ -133,14 +131,14 @@ asmSeq is = foldr (mkSeqList . asmInstr) asmVoid is
 asmParThen :: [AlphaCode] -> CodeBlock AlphaInstr
 asmParThen others code = mkSeqList (foldr mkParList mkEmptyList others) code
 
-returnInstr :: AlphaInstr -> SUniqSM (CodeBlock AlphaInstr)
-returnInstr instr = returnSUs (\xs -> mkSeqList (asmInstr instr) xs)
+returnInstr :: AlphaInstr -> UniqSM (CodeBlock AlphaInstr)
+returnInstr instr = returnUs (\xs -> mkSeqList (asmInstr instr) xs)
 
-returnInstrs :: [AlphaInstr] -> SUniqSM (CodeBlock AlphaInstr)
-returnInstrs instrs = returnSUs (\xs -> mkSeqList (asmSeq instrs) xs)
+returnInstrs :: [AlphaInstr] -> UniqSM (CodeBlock AlphaInstr)
+returnInstrs instrs = returnUs (\xs -> mkSeqList (asmSeq instrs) xs)
 
-returnSeq :: (CodeBlock AlphaInstr) -> [AlphaInstr] -> SUniqSM (CodeBlock AlphaInstr)
-returnSeq code instrs = returnSUs (\xs -> code (mkSeqList (asmSeq instrs) xs))
+returnSeq :: (CodeBlock AlphaInstr) -> [AlphaInstr] -> UniqSM (CodeBlock AlphaInstr)
+returnSeq code instrs = returnUs (\xs -> code (mkSeqList (asmSeq instrs) xs))
 
 mkSeqInstr :: AlphaInstr -> (CodeBlock AlphaInstr)
 mkSeqInstr instr code = mkSeqList (asmInstr instr) code
@@ -154,11 +152,11 @@ Top level alpha code generator for a chunk of stix code.
 
 \begin{code}
 
-genAlphaCode :: [StixTree] -> SUniqSM (AlphaCode)
+genAlphaCode :: [StixTree] -> UniqSM (AlphaCode)
 
 genAlphaCode trees =
-    mapSUs getCode trees    	    	`thenSUs` \ blocks ->
-    returnSUs (foldr (.) id blocks asmVoid)
+    mapUs getCode trees    	    	`thenUs` \ blocks ->
+    returnUs (foldr (.) id blocks asmVoid)
 
 \end{code}
 
@@ -166,14 +164,14 @@ Code extractor for an entire stix tree---stix statement level.
 
 \begin{code}
 
-getCode 
+getCode
     :: StixTree     -- a stix statement
-    -> SUniqSM (CodeBlock AlphaInstr)
+    -> UniqSM (CodeBlock AlphaInstr)
 
 getCode (StSegment seg) = returnInstr (SEGMENT seg)
 
 getCode (StAssign pk dst src)
-  | isFloatingKind pk = assignFltCode pk dst src
+  | isFloatingRep pk = assignFltCode pk dst src
   | otherwise = assignIntCode pk dst src
 
 getCode (StLabel lab) = returnInstr (LABEL lab)
@@ -190,27 +188,22 @@ getCode (StFallThrough lbl) = returnInstr (LDA pv (AddrImm (ImmCLbl lbl)))
 
 getCode (StCondJump lbl arg) = genCondJump lbl arg
 
-getCode (StData kind args) = 
-    mapAndUnzipSUs getData args		    `thenSUs` \ (codes, imms) ->
-    returnSUs (\xs -> mkSeqList (asmInstr (DATA (kindToSize kind) imms))
-                                (foldr1 (.) codes xs))
+getCode (StData kind args) =
+    mapAndUnzipUs getData args		    `thenUs` \ (codes, imms) ->
+    returnUs (\xs -> mkSeqList (asmInstr (DATA (kindToSize kind) imms))
+				(foldr1 (.) codes xs))
   where
-    getData :: StixTree -> SUniqSM (CodeBlock AlphaInstr, Imm)
-    getData (StInt i) = returnSUs (id, ImmInteger i)
-#if __GLASGOW_HASKELL__ >= 23
---  getData (StDouble d) = returnSUs (id, strImmLab (_showRational 30 d))
-    getData (StDouble d) = returnSUs (id, ImmLab (prettyToUn (ppRational d)))
-#else
-    getData (StDouble d) = returnSUs (id, strImmLab (show d))
-#endif
-    getData (StLitLbl s) = returnSUs (id, ImmLab s)
-    getData (StLitLit s) = returnSUs (id, strImmLab (cvtLitLit (_UNPK_ s)))
-    getData (StString s) = 
-        getUniqLabelNCG 	    	    `thenSUs` \ lbl ->
-	returnSUs (mkSeqInstrs [LABEL lbl, ASCII True (_UNPK_ s)], ImmCLbl lbl)
-    getData (StCLbl l)   = returnSUs (id, ImmCLbl l)
-
-getCode (StCall fn VoidKind args) = genCCall fn VoidKind args
+    getData :: StixTree -> UniqSM (CodeBlock AlphaInstr, Imm)
+    getData (StInt i) = returnUs (id, ImmInteger i)
+    getData (StDouble d) = returnUs (id, ImmLab (prettyToUn (ppRational d)))
+    getData (StLitLbl s) = returnUs (id, ImmLab s)
+    getData (StLitLit s) = returnUs (id, strImmLab (cvtLitLit (_UNPK_ s)))
+    getData (StString s) =
+	getUniqLabelNCG 	    	    `thenUs` \ lbl ->
+	returnUs (mkSeqInstrs [LABEL lbl, ASCII True (_UNPK_ s)], ImmCLbl lbl)
+    getData (StCLbl l)   = returnUs (id, ImmCLbl l)
+
+getCode (StCall fn VoidRep args) = genCCall fn VoidRep args
 
 getCode (StComment s) = returnInstr (COMMENT s)
 
@@ -220,35 +213,30 @@ Generate code to get a subtree into a register.
 
 \begin{code}
 
-getReg :: StixTree -> SUniqSM Register
+getReg :: StixTree -> UniqSM Register
 
 getReg (StReg (StixMagicId stgreg)) =
     case stgRegMap stgreg of
-    	Just reg -> returnSUs (Fixed reg (kindFromMagicId stgreg) id)
+    	Just reg -> returnUs (Fixed reg (kindFromMagicId stgreg) id)
     	-- cannae be Nothing
 
-getReg (StReg (StixTemp u pk)) = returnSUs (Fixed (UnmappedReg u pk) pk id)
+getReg (StReg (StixTemp u pk)) = returnUs (Fixed (UnmappedReg u pk) pk id)
 
 getReg (StDouble d) =
-    getUniqLabelNCG 	    	    `thenSUs` \ lbl ->
-    getNewRegNCG PtrKind    	    `thenSUs` \ tmp ->
+    getUniqLabelNCG 	    	    `thenUs` \ lbl ->
+    getNewRegNCG PtrRep    	    `thenUs` \ tmp ->
     let code dst = mkSeqInstrs [
     	    SEGMENT DataSegment,
 	    LABEL lbl,
-#if __GLASGOW_HASKELL__ >= 23
---	    DATA TF [strImmLab (_showRational 30 d)],
 	    DATA TF [ImmLab (prettyToUn (ppRational d))],
-#else
-	    DATA TF [strImmLab (show d)],
-#endif
 	    SEGMENT TextSegment,
 	    LDA tmp (AddrImm (ImmCLbl lbl)),
 	    LD TF dst (AddrReg tmp)]
     in
-    	returnSUs (Any DoubleKind code)
+    	returnUs (Any DoubleRep code)
 
 getReg (StString s) =
-    getUniqLabelNCG 	    	    `thenSUs` \ lbl ->
+    getUniqLabelNCG 	    	    `thenUs` \ lbl ->
     let code dst = mkSeqInstrs [
 	    SEGMENT DataSegment,
 	    LABEL lbl,
@@ -256,10 +244,10 @@ getReg (StString s) =
 	    SEGMENT TextSegment,
 	    LDA dst (AddrImm (ImmCLbl lbl))]
     in
-    	returnSUs (Any PtrKind code)
+    	returnUs (Any PtrRep code)
 
 getReg (StLitLit s) | _HEAD_ s == '"' && last xs == '"' =
-    getUniqLabelNCG 	    	    `thenSUs` \ lbl ->
+    getUniqLabelNCG 	    	    `thenUs` \ lbl ->
     let code dst = mkSeqInstrs [
 	    SEGMENT DataSegment,
 	    LABEL lbl,
@@ -267,19 +255,19 @@ getReg (StLitLit s) | _HEAD_ s == '"' && last xs == '"' =
 	    SEGMENT TextSegment,
 	    LDA dst (AddrImm (ImmCLbl lbl))]
     in
-    	returnSUs (Any PtrKind code)
+    	returnUs (Any PtrRep code)
   where
     xs = _UNPK_ (_TAIL_ s)
 
 getReg tree@(StIndex _ _ _) = getReg (mangleIndexTree tree)
 
-getReg (StCall fn kind args) = 
-    genCCall fn kind args   	    `thenSUs` \ call ->
-    returnSUs (Fixed reg kind call)
+getReg (StCall fn kind args) =
+    genCCall fn kind args   	    `thenUs` \ call ->
+    returnUs (Fixed reg kind call)
   where
-    reg = if isFloatingKind kind then f0 else v0
+    reg = if isFloatingRep kind then f0 else v0
 
-getReg (StPrim primop args) = 
+getReg (StPrim primop args) =
     case primop of
 
     	CharGtOp -> case args of [x,y] -> trivialCode (CMP LT) [y,x]
@@ -297,7 +285,7 @@ getReg (StPrim primop args) =
     	IntRemOp -> trivialCode (REM Q False) args
     	IntNegOp -> trivialUCode (NEG Q False) args
     	IntAbsOp -> trivialUCode (ABS Q) args
-   
+
     	AndOp -> trivialCode AND args
     	OrOp  -> trivialCode OR args
     	NotOp -> trivialUCode NOT args
@@ -307,7 +295,7 @@ getReg (StPrim primop args) =
     	ISllOp -> panic "AlphaGen:isll"
     	ISraOp -> panic "AlphaGen:isra"
     	ISrlOp -> panic "AlphaGen:isrl"
-   
+
     	IntGtOp -> case args of [x,y] -> trivialCode (CMP LT) [y,x]
     	IntGeOp -> case args of [x,y] -> trivialCode (CMP LE) [y,x]
     	IntEqOp -> trivialCode (CMP EQ) args
@@ -342,30 +330,30 @@ getReg (StPrim primop args) =
     	FloatLtOp -> cmpFCode (FCMP TF LT) NE args
     	FloatLeOp -> cmpFCode (FCMP TF LE) NE args
 
-    	FloatExpOp -> call SLIT("exp") DoubleKind
-    	FloatLogOp -> call SLIT("log") DoubleKind
-    	FloatSqrtOp -> call SLIT("sqrt") DoubleKind
-       
-    	FloatSinOp -> call SLIT("sin") DoubleKind
-    	FloatCosOp -> call SLIT("cos") DoubleKind
-    	FloatTanOp -> call SLIT("tan") DoubleKind
-       
-    	FloatAsinOp -> call SLIT("asin") DoubleKind
-    	FloatAcosOp -> call SLIT("acos") DoubleKind
-    	FloatAtanOp -> call SLIT("atan") DoubleKind
-       
-    	FloatSinhOp -> call SLIT("sinh") DoubleKind
-    	FloatCoshOp -> call SLIT("cosh") DoubleKind
-    	FloatTanhOp -> call SLIT("tanh") DoubleKind
-       
-    	FloatPowerOp -> call SLIT("pow") DoubleKind
+    	FloatExpOp -> call SLIT("exp") DoubleRep
+    	FloatLogOp -> call SLIT("log") DoubleRep
+    	FloatSqrtOp -> call SLIT("sqrt") DoubleRep
+
+    	FloatSinOp -> call SLIT("sin") DoubleRep
+    	FloatCosOp -> call SLIT("cos") DoubleRep
+    	FloatTanOp -> call SLIT("tan") DoubleRep
+
+    	FloatAsinOp -> call SLIT("asin") DoubleRep
+    	FloatAcosOp -> call SLIT("acos") DoubleRep
+    	FloatAtanOp -> call SLIT("atan") DoubleRep
+
+    	FloatSinhOp -> call SLIT("sinh") DoubleRep
+    	FloatCoshOp -> call SLIT("cosh") DoubleRep
+    	FloatTanhOp -> call SLIT("tanh") DoubleRep
+
+    	FloatPowerOp -> call SLIT("pow") DoubleRep
 
     	DoubleAddOp -> trivialFCode (FADD TF) args
     	DoubleSubOp -> trivialFCode (FSUB TF) args
     	DoubleMulOp -> trivialFCode (FMUL TF) args
    	DoubleDivOp -> trivialFCode (FDIV TF) args
     	DoubleNegOp -> trivialUFCode (FNEG TF) args
-   
+
     	DoubleGtOp -> cmpFCode (FCMP TF LE) EQ args
     	DoubleGeOp -> cmpFCode (FCMP TF LT) EQ args
     	DoubleEqOp -> cmpFCode (FCMP TF EQ) NE args
@@ -373,32 +361,32 @@ getReg (StPrim primop args) =
     	DoubleLtOp -> cmpFCode (FCMP TF LT) NE args
     	DoubleLeOp -> cmpFCode (FCMP TF LE) NE args
 
-    	DoubleExpOp -> call SLIT("exp") DoubleKind
-    	DoubleLogOp -> call SLIT("log") DoubleKind
-    	DoubleSqrtOp -> call SLIT("sqrt") DoubleKind
-
-    	DoubleSinOp -> call SLIT("sin") DoubleKind
-    	DoubleCosOp -> call SLIT("cos") DoubleKind
-    	DoubleTanOp -> call SLIT("tan") DoubleKind
-       
-    	DoubleAsinOp -> call SLIT("asin") DoubleKind
-    	DoubleAcosOp -> call SLIT("acos") DoubleKind
-    	DoubleAtanOp -> call SLIT("atan") DoubleKind
-       
-    	DoubleSinhOp -> call SLIT("sinh") DoubleKind
-    	DoubleCoshOp -> call SLIT("cosh") DoubleKind
-    	DoubleTanhOp -> call SLIT("tanh") DoubleKind
-       
-    	DoublePowerOp -> call SLIT("pow") DoubleKind
-
-    	OrdOp -> coerceIntCode IntKind args
+    	DoubleExpOp -> call SLIT("exp") DoubleRep
+    	DoubleLogOp -> call SLIT("log") DoubleRep
+    	DoubleSqrtOp -> call SLIT("sqrt") DoubleRep
+
+    	DoubleSinOp -> call SLIT("sin") DoubleRep
+    	DoubleCosOp -> call SLIT("cos") DoubleRep
+    	DoubleTanOp -> call SLIT("tan") DoubleRep
+
+    	DoubleAsinOp -> call SLIT("asin") DoubleRep
+    	DoubleAcosOp -> call SLIT("acos") DoubleRep
+    	DoubleAtanOp -> call SLIT("atan") DoubleRep
+
+    	DoubleSinhOp -> call SLIT("sinh") DoubleRep
+    	DoubleCoshOp -> call SLIT("cosh") DoubleRep
+    	DoubleTanhOp -> call SLIT("tanh") DoubleRep
+
+    	DoublePowerOp -> call SLIT("pow") DoubleRep
+
+    	OrdOp -> coerceIntCode IntRep args
     	ChrOp -> chrCode args
-       
+
     	Float2IntOp -> coerceFP2Int args
     	Int2FloatOp -> coerceInt2FP args
     	Double2IntOp -> coerceFP2Int args
     	Int2DoubleOp -> coerceInt2FP args
-       
+
     	Double2FloatOp -> coerceFltCode args
     	Float2DoubleOp -> coerceFltCode args
 
@@ -406,26 +394,26 @@ getReg (StPrim primop args) =
     call fn pk = getReg (StCall fn pk args)
 
 getReg (StInd pk mem) =
-    getAmode mem    	    	    `thenSUs` \ amode ->
-    let 
+    getAmode mem    	    	    `thenUs` \ amode ->
+    let
     	code = amodeCode amode
     	src   = amodeAddr amode
     	size = kindToSize pk
     	code__2 dst = code . mkSeqInstr (LD size dst src)
     in
-    	returnSUs (Any pk code__2)
+    	returnUs (Any pk code__2)
 
 getReg (StInt i)
   | is8Bits i =
     let
     	code dst = mkSeqInstr (OR zero (RIImm src) dst)
     in
-    	returnSUs (Any IntKind code)
+    	returnUs (Any IntRep code)
   | otherwise =
     let
     	code dst = mkSeqInstr (LDI Q dst src)
     in
-    	returnSUs (Any IntKind code)
+    	returnUs (Any IntRep code)
   where
     src = ImmInt (fromInteger i)
 
@@ -434,7 +422,7 @@ getReg leaf
     let
     	code dst = mkSeqInstr (LDA dst (AddrImm imm__2))
     in
-    	returnSUs (Any PtrKind code)
+    	returnUs (Any PtrRep code)
   where
     imm = maybeImm leaf
     imm__2 = case imm of Just x -> x
@@ -446,46 +434,46 @@ produce a suitable addressing mode.
 
 \begin{code}
 
-getAmode :: StixTree -> SUniqSM Amode
+getAmode :: StixTree -> UniqSM Amode
 
 getAmode tree@(StIndex _ _ _) = getAmode (mangleIndexTree tree)
 
 getAmode (StPrim IntSubOp [x, StInt i]) =
-    getNewRegNCG PtrKind    	    `thenSUs` \ tmp ->
-    getReg x    	    	    `thenSUs` \ register ->
+    getNewRegNCG PtrRep    	    `thenUs` \ tmp ->
+    getReg x    	    	    `thenUs` \ register ->
     let
     	code = registerCode register tmp
     	reg  = registerName register tmp
     	off  = ImmInt (-(fromInteger i))
     in
-    	returnSUs (Amode (AddrRegImm reg off) code)
+    	returnUs (Amode (AddrRegImm reg off) code)
 
 
 getAmode (StPrim IntAddOp [x, StInt i]) =
-    getNewRegNCG PtrKind    	    `thenSUs` \ tmp ->
-    getReg x    	    	    `thenSUs` \ register ->
+    getNewRegNCG PtrRep    	    `thenUs` \ tmp ->
+    getReg x    	    	    `thenUs` \ register ->
     let
     	code = registerCode register tmp
     	reg  = registerName register tmp
     	off  = ImmInt (fromInteger i)
     in
-    	returnSUs (Amode (AddrRegImm reg off) code)
+    	returnUs (Amode (AddrRegImm reg off) code)
 
 getAmode leaf
   | maybeToBool imm =
-    	returnSUs (Amode (AddrImm imm__2) id)
+    	returnUs (Amode (AddrImm imm__2) id)
   where
     imm = maybeImm leaf
     imm__2 = case imm of Just x -> x
 
 getAmode other =
-    getNewRegNCG PtrKind    	    `thenSUs` \ tmp ->
-    getReg other    	    	    `thenSUs` \ register ->
+    getNewRegNCG PtrRep    	    `thenUs` \ tmp ->
+    getReg other    	    	    `thenUs` \ register ->
     let
     	code = registerCode register tmp
     	reg  = registerName register tmp
     in
-    	returnSUs (Amode (AddrReg reg) code)
+    	returnUs (Amode (AddrReg reg) code)
 
 \end{code}
 
@@ -500,44 +488,44 @@ can be applied to all of a call's arguments using @mapAccumL@.
 
 \begin{code}
 
-getCallArg 
+getCallArg
     :: ([(Reg,Reg)],Int)    -- Argument registers and stack offset (accumulator)
     -> StixTree 	    -- Current argument
-    -> SUniqSM (([(Reg,Reg)],Int), CodeBlock AlphaInstr) -- Updated accumulator and code
+    -> UniqSM (([(Reg,Reg)],Int), CodeBlock AlphaInstr) -- Updated accumulator and code
 
 -- We have to use up all of our argument registers first.
 
-getCallArg ((iDst,fDst):dsts, offset) arg = 
-    getReg arg	    	    	    `thenSUs` \ register ->
+getCallArg ((iDst,fDst):dsts, offset) arg =
+    getReg arg	    	    	    `thenUs` \ register ->
     let
-    	reg = if isFloatingKind pk then fDst else iDst
+    	reg = if isFloatingRep pk then fDst else iDst
     	code = registerCode register reg
     	src = registerName register reg
     	pk = registerKind register
     in
-    	returnSUs (
-            if isFloatingKind pk then
-    	        ((dsts, offset), if isFixed register then 
+    	returnUs (
+	    if isFloatingRep pk then
+    	        ((dsts, offset), if isFixed register then
     	    	    code . mkSeqInstr (FMOV src fDst)
     	    	    else code)
-    	    else 
-                ((dsts, offset), if isFixed register then 
+    	    else
+		((dsts, offset), if isFixed register then
     	    	    code . mkSeqInstr (OR src (RIReg src) iDst)
     	    	    else code))
 
 -- Once we have run out of argument registers, we move to the stack
 
-getCallArg ([], offset) arg = 
-    getReg arg	    	    	    `thenSUs` \ register ->
+getCallArg ([], offset) arg =
+    getReg arg	    	    	    `thenUs` \ register ->
     getNewRegNCG (registerKind register)
-    	    	        	    `thenSUs` \ tmp ->
-    let 
+    	    	        	    `thenUs` \ tmp ->
+    let
     	code = registerCode register tmp
     	src = registerName register tmp
     	pk = registerKind register
     	sz = kindToSize pk
     in
-    	returnSUs (([], offset + 1), code . mkSeqInstr (ST sz src (spRel offset)))
+    	returnUs (([], offset + 1), code . mkSeqInstr (ST sz src (spRel offset)))
 
 \end{code}
 
@@ -547,17 +535,17 @@ correspond to loads, stores, or register transfers.  If we're really lucky,
 some of the register transfers will go away, because we can use the destination
 register to complete the code generation for the right hand side.  This only
 fails when the right hand side is forced into a fixed register (e.g. the result
-of a call).  
+of a call).
 
 \begin{code}
 
-assignIntCode :: PrimKind -> StixTree -> StixTree -> SUniqSM (CodeBlock AlphaInstr)
+assignIntCode :: PrimRep -> StixTree -> StixTree -> UniqSM (CodeBlock AlphaInstr)
 
 assignIntCode pk (StInd _ dst) src =
-    getNewRegNCG IntKind    	    `thenSUs` \ tmp ->
-    getAmode dst    	    	    `thenSUs` \ amode ->
-    getReg src	    	    	    `thenSUs` \ register ->
-    let 
+    getNewRegNCG IntRep    	    `thenUs` \ tmp ->
+    getAmode dst    	    	    `thenUs` \ amode ->
+    getReg src	    	    	    `thenUs` \ register ->
+    let
     	code1 = amodeCode amode asmVoid
     	dst__2  = amodeAddr amode
     	code2 = registerCode register tmp asmVoid
@@ -565,28 +553,28 @@ assignIntCode pk (StInd _ dst) src =
     	sz    = kindToSize pk
     	code__2 = asmParThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2)
     in
-    	returnSUs code__2
+    	returnUs code__2
 
 assignIntCode pk dst src =
-    getReg dst	    	    	    `thenSUs` \ register1 ->
-    getReg src	    	    	    `thenSUs` \ register2 ->
-    let 
+    getReg dst	    	    	    `thenUs` \ register1 ->
+    getReg src	    	    	    `thenUs` \ register2 ->
+    let
     	dst__2 = registerName register1 zero
     	code = registerCode register2 dst__2
     	src__2 = registerName register2 dst__2
-    	code__2 = if isFixed register2 then 
+    	code__2 = if isFixed register2 then
     	    	    code . mkSeqInstr (OR src__2 (RIReg src__2) dst__2)
     	    	else code
     in
-    	returnSUs code__2
+    	returnUs code__2
 
-assignFltCode :: PrimKind -> StixTree -> StixTree -> SUniqSM (CodeBlock AlphaInstr)
+assignFltCode :: PrimRep -> StixTree -> StixTree -> UniqSM (CodeBlock AlphaInstr)
 
 assignFltCode pk (StInd _ dst) src =
-    getNewRegNCG pk        	    `thenSUs` \ tmp ->
-    getAmode dst    	    	    `thenSUs` \ amode ->
-    getReg src	    	    	    `thenSUs` \ register ->
-    let 
+    getNewRegNCG pk        	    `thenUs` \ tmp ->
+    getAmode dst    	    	    `thenUs` \ amode ->
+    getReg src	    	    	    `thenUs` \ register ->
+    let
     	code1 = amodeCode amode asmVoid
     	dst__2  = amodeAddr amode
     	code2 = registerCode register tmp asmVoid
@@ -594,22 +582,22 @@ assignFltCode pk (StInd _ dst) src =
     	sz    = kindToSize pk
     	code__2 = asmParThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2)
     in
-        returnSUs code__2
+	returnUs code__2
 
 assignFltCode pk dst src =
-    getReg dst	    	    	    `thenSUs` \ register1 ->
-    getReg src	    	    	    `thenSUs` \ register2 ->
-    let 
+    getReg dst	    	    	    `thenUs` \ register1 ->
+    getReg src	    	    	    `thenUs` \ register2 ->
+    let
     	dst__2 = registerName register1 zero
     	code = registerCode register2 dst__2
     	src__2 = registerName register2 dst__2
-    	code__2 = if isFixed register2 then 
+    	code__2 = if isFixed register2 then
     	    	    code . mkSeqInstr (FMOV src__2 dst__2)
     	    	else code
     in
-    	returnSUs code__2
+    	returnUs code__2
 
-\end{code} 
+\end{code}
 
 Generating an unconditional branch.  We accept two types of targets:
 an immediate CLabel or a tree that gets evaluated into a register.
@@ -619,19 +607,19 @@ are assumed to be far away, so we use jmp.
 
 \begin{code}
 
-genJump 
+genJump
     :: StixTree     -- the branch target
-    -> SUniqSM (CodeBlock AlphaInstr)
+    -> UniqSM (CodeBlock AlphaInstr)
 
-genJump (StCLbl lbl) 
+genJump (StCLbl lbl)
   | isAsmTemp lbl = returnInstr (BR target)
   | otherwise     = returnInstrs [LDA pv (AddrImm target), JMP zero (AddrReg pv) 0]
   where
     target = ImmCLbl lbl
 
 genJump tree =
-    getReg tree	    	    	    `thenSUs` \ register ->
-    getNewRegNCG PtrKind    	    `thenSUs` \ tmp ->
+    getReg tree	    	    	    `thenUs` \ register ->
+    getNewRegNCG PtrRep    	    `thenUs` \ tmp ->
     let
     	dst = registerName register pv
     	code = registerCode register pv
@@ -640,31 +628,31 @@ genJump tree =
     	if isFixed register then
     	    returnSeq code [OR dst (RIReg dst) pv, JMP zero (AddrReg pv) 0]
     	else
-    	    returnSUs (code . mkSeqInstr (JMP zero (AddrReg pv) 0))
+    	    returnUs (code . mkSeqInstr (JMP zero (AddrReg pv) 0))
 
 \end{code}
 
 Conditional jumps are always to local labels, so we can use
-branch instructions.  We peek at the arguments to decide what kind 
-of comparison to do.  For comparisons with 0, we're laughing, because 
-we can just do the desired conditional branch.  
+branch instructions.  We peek at the arguments to decide what kind
+of comparison to do.  For comparisons with 0, we're laughing, because
+we can just do the desired conditional branch.
 
 \begin{code}
 
-genCondJump 
+genCondJump
     :: CLabel	    -- the branch target
     -> StixTree     -- the condition on which to branch
-    -> SUniqSM (CodeBlock AlphaInstr)
+    -> UniqSM (CodeBlock AlphaInstr)
 
 genCondJump lbl (StPrim op [x, StInt 0]) =
-    getReg x	  	    	    `thenSUs` \ register ->
+    getReg x	  	    	    `thenUs` \ register ->
     getNewRegNCG (registerKind register)
-    	    	        	    `thenSUs` \ tmp ->
+    	    	        	    `thenUs` \ tmp ->
     let
     	code = registerCode register tmp
     	value = registerName register tmp
     	pk = registerKind register
-        target = ImmCLbl lbl    
+	target = ImmCLbl lbl
     in
     	    returnSeq code [BI (cmpOp op) value target]
   where
@@ -694,16 +682,16 @@ genCondJump lbl (StPrim op [x, StInt 0]) =
     cmpOp AddrLeOp = EQ
 
 genCondJump lbl (StPrim op [x, StDouble 0.0]) =
-    getReg x	  	    	    `thenSUs` \ register ->
+    getReg x	  	    	    `thenUs` \ register ->
     getNewRegNCG (registerKind register)
-    	    	        	    `thenSUs` \ tmp ->
+    	    	        	    `thenUs` \ tmp ->
     let
     	code = registerCode register tmp
     	value = registerName register tmp
     	pk = registerKind register
-        target = ImmCLbl lbl    
+	target = ImmCLbl lbl
     in
-    	    returnSUs (code . mkSeqInstr (BF (cmpOp op) value target))
+    	    returnUs (code . mkSeqInstr (BF (cmpOp op) value target))
   where
     cmpOp FloatGtOp = GT
     cmpOp FloatGeOp = GE
@@ -718,80 +706,80 @@ genCondJump lbl (StPrim op [x, StDouble 0.0]) =
     cmpOp DoubleLtOp = LT
     cmpOp DoubleLeOp = LE
 
-genCondJump lbl (StPrim op args) 
+genCondJump lbl (StPrim op args)
   | fltCmpOp op =
-    trivialFCode instr args    	    `thenSUs` \ register ->
-    getNewRegNCG DoubleKind    	    `thenSUs` \ tmp ->
+    trivialFCode instr args    	    `thenUs` \ register ->
+    getNewRegNCG DoubleRep    	    `thenUs` \ tmp ->
     let
     	code = registerCode register tmp
     	result = registerName register tmp
-        target = ImmCLbl lbl    
+	target = ImmCLbl lbl
     in
-        returnSUs (code . mkSeqInstr (BF cond result target))
+	returnUs (code . mkSeqInstr (BF cond result target))
   where
     fltCmpOp op = case op of
-        FloatGtOp -> True
-        FloatGeOp -> True
-        FloatEqOp -> True
-        FloatNeOp -> True
-        FloatLtOp -> True
-        FloatLeOp -> True
-        DoubleGtOp -> True
-        DoubleGeOp -> True
-        DoubleEqOp -> True
-        DoubleNeOp -> True
-        DoubleLtOp -> True
-        DoubleLeOp -> True
-        _ -> False
+	FloatGtOp -> True
+	FloatGeOp -> True
+	FloatEqOp -> True
+	FloatNeOp -> True
+	FloatLtOp -> True
+	FloatLeOp -> True
+	DoubleGtOp -> True
+	DoubleGeOp -> True
+	DoubleEqOp -> True
+	DoubleNeOp -> True
+	DoubleLtOp -> True
+	DoubleLeOp -> True
+	_ -> False
     (instr, cond) = case op of
-        FloatGtOp -> (FCMP TF LE, EQ)
-        FloatGeOp -> (FCMP TF LT, EQ)
-        FloatEqOp -> (FCMP TF EQ, NE)
-        FloatNeOp -> (FCMP TF EQ, EQ)
-        FloatLtOp -> (FCMP TF LT, NE)
-        FloatLeOp -> (FCMP TF LE, NE)
-        DoubleGtOp -> (FCMP TF LE, EQ)
-        DoubleGeOp -> (FCMP TF LT, EQ)
-        DoubleEqOp -> (FCMP TF EQ, NE)
-        DoubleNeOp -> (FCMP TF EQ, EQ)
-        DoubleLtOp -> (FCMP TF LT, NE)
-        DoubleLeOp -> (FCMP TF LE, NE)
+	FloatGtOp -> (FCMP TF LE, EQ)
+	FloatGeOp -> (FCMP TF LT, EQ)
+	FloatEqOp -> (FCMP TF EQ, NE)
+	FloatNeOp -> (FCMP TF EQ, EQ)
+	FloatLtOp -> (FCMP TF LT, NE)
+	FloatLeOp -> (FCMP TF LE, NE)
+	DoubleGtOp -> (FCMP TF LE, EQ)
+	DoubleGeOp -> (FCMP TF LT, EQ)
+	DoubleEqOp -> (FCMP TF EQ, NE)
+	DoubleNeOp -> (FCMP TF EQ, EQ)
+	DoubleLtOp -> (FCMP TF LT, NE)
+	DoubleLeOp -> (FCMP TF LE, NE)
 
 genCondJump lbl (StPrim op args) =
-    trivialCode instr args    	    `thenSUs` \ register ->
-    getNewRegNCG IntKind    	    `thenSUs` \ tmp ->
+    trivialCode instr args    	    `thenUs` \ register ->
+    getNewRegNCG IntRep    	    `thenUs` \ tmp ->
     let
     	code = registerCode register tmp
     	result = registerName register tmp
-        target = ImmCLbl lbl    
+	target = ImmCLbl lbl
     in
-        returnSUs (code . mkSeqInstr (BI cond result target))
+	returnUs (code . mkSeqInstr (BI cond result target))
   where
     (instr, cond) = case op of
-        CharGtOp -> (CMP LE, EQ)
-        CharGeOp -> (CMP LT, EQ)
-        CharEqOp -> (CMP EQ, NE)
-        CharNeOp -> (CMP EQ, EQ)
-        CharLtOp -> (CMP LT, NE)
-        CharLeOp -> (CMP LE, NE)
-        IntGtOp -> (CMP LE, EQ)
-        IntGeOp -> (CMP LT, EQ)
-        IntEqOp -> (CMP EQ, NE)
-        IntNeOp -> (CMP EQ, EQ)
-        IntLtOp -> (CMP LT, NE)
-        IntLeOp -> (CMP LE, NE)
-        WordGtOp -> (CMP ULE, EQ)
-        WordGeOp -> (CMP ULT, EQ)
-        WordEqOp -> (CMP EQ, NE)
-        WordNeOp -> (CMP EQ, EQ)
-        WordLtOp -> (CMP ULT, NE)
-        WordLeOp -> (CMP ULE, NE)
-        AddrGtOp -> (CMP ULE, EQ)
-        AddrGeOp -> (CMP ULT, EQ)
-        AddrEqOp -> (CMP EQ, NE)
-        AddrNeOp -> (CMP EQ, EQ)
-        AddrLtOp -> (CMP ULT, NE)
-        AddrLeOp -> (CMP ULE, NE)
+	CharGtOp -> (CMP LE, EQ)
+	CharGeOp -> (CMP LT, EQ)
+	CharEqOp -> (CMP EQ, NE)
+	CharNeOp -> (CMP EQ, EQ)
+	CharLtOp -> (CMP LT, NE)
+	CharLeOp -> (CMP LE, NE)
+	IntGtOp -> (CMP LE, EQ)
+	IntGeOp -> (CMP LT, EQ)
+	IntEqOp -> (CMP EQ, NE)
+	IntNeOp -> (CMP EQ, EQ)
+	IntLtOp -> (CMP LT, NE)
+	IntLeOp -> (CMP LE, NE)
+	WordGtOp -> (CMP ULE, EQ)
+	WordGeOp -> (CMP ULT, EQ)
+	WordEqOp -> (CMP EQ, NE)
+	WordNeOp -> (CMP EQ, EQ)
+	WordLtOp -> (CMP ULT, NE)
+	WordLeOp -> (CMP ULE, NE)
+	AddrGtOp -> (CMP ULE, EQ)
+	AddrGeOp -> (CMP ULT, EQ)
+	AddrEqOp -> (CMP EQ, NE)
+	AddrNeOp -> (CMP EQ, EQ)
+	AddrLtOp -> (CMP ULT, NE)
+	AddrLeOp -> (CMP ULE, NE)
 
 \end{code}
 
@@ -803,27 +791,27 @@ locations.  Apart from that, the code is easy.
 
 genCCall
     :: FAST_STRING    -- function to call
-    -> PrimKind	    -- type of the result
+    -> PrimRep	    -- type of the result
     -> [StixTree]   -- arguments (of mixed type)
-    -> SUniqSM (CodeBlock AlphaInstr)
+    -> UniqSM (CodeBlock AlphaInstr)
 
 genCCall fn kind args =
-    mapAccumLNCG getCallArg (argRegs,stackArgLoc) args 
-    	    	    	    	    `thenSUs` \ ((unused,_), argCode) ->
+    mapAccumLNCG getCallArg (argRegs,stackArgLoc) args
+    	    	    	    	    `thenUs` \ ((unused,_), argCode) ->
     let
     	nRegs = length argRegs - length unused
     	code = asmParThen (map ($ asmVoid) argCode)
     in
     	returnSeq code [
     	    LDA pv (AddrImm (ImmLab (uppPStr fn))),
-    	    JSR ra (AddrReg pv) nRegs, 
+    	    JSR ra (AddrReg pv) nRegs,
     	    LDGP gp (AddrReg ra)]
   where
-    mapAccumLNCG f b []     = returnSUs (b, [])
-    mapAccumLNCG f b (x:xs) = 
-    	f b x   	        	    `thenSUs` \ (b__2, x__2) ->
-    	mapAccumLNCG f b__2 xs   	    `thenSUs` \ (b__3, xs__2) ->
-    	returnSUs (b__3, x__2:xs__2)
+    mapAccumLNCG f b []     = returnUs (b, [])
+    mapAccumLNCG f b (x:xs) =
+    	f b x   	        	    `thenUs` \ (b__2, x__2) ->
+    	mapAccumLNCG f b__2 xs   	    `thenUs` \ (b__3, xs__2) ->
+    	returnUs (b__3, x__2:xs__2)
 
 \end{code}
 
@@ -832,28 +820,28 @@ side, because that's where the generic optimizer will have put them.
 
 \begin{code}
 
-trivialCode 
-    :: (Reg -> RI -> Reg -> AlphaInstr) 
+trivialCode
+    :: (Reg -> RI -> Reg -> AlphaInstr)
     -> [StixTree]
-    -> SUniqSM Register
+    -> UniqSM Register
 
 trivialCode instr [x, StInt y]
   | is8Bits y =
-    getReg x	    	    	    `thenSUs` \ register ->
-    getNewRegNCG IntKind    	    `thenSUs` \ tmp ->
+    getReg x	    	    	    `thenUs` \ register ->
+    getNewRegNCG IntRep    	    `thenUs` \ tmp ->
     let
     	code = registerCode register tmp
     	src1 = registerName register tmp
     	src2 = ImmInt (fromInteger y)
     	code__2 dst = code . mkSeqInstr (instr src1 (RIImm src2) dst)
     in
-    	returnSUs (Any IntKind code__2)
+    	returnUs (Any IntRep code__2)
 
 trivialCode instr [x, y] =
-    getReg x	    	    	    `thenSUs` \ register1 ->
-    getReg y	    	    	    `thenSUs` \ register2 ->
-    getNewRegNCG IntKind    	    `thenSUs` \ tmp1 ->
-    getNewRegNCG IntKind    	    `thenSUs` \ tmp2 ->
+    getReg x	    	    	    `thenUs` \ register1 ->
+    getReg y	    	    	    `thenUs` \ register2 ->
+    getNewRegNCG IntRep    	    `thenUs` \ tmp1 ->
+    getNewRegNCG IntRep    	    `thenUs` \ tmp2 ->
     let
     	code1 = registerCode register1 tmp1 asmVoid
     	src1  = registerName register1 tmp1
@@ -862,18 +850,18 @@ trivialCode instr [x, y] =
     	code__2 dst = asmParThen [code1, code2] .
     	    	     mkSeqInstr (instr src1 (RIReg src2) dst)
     in
-    	returnSUs (Any IntKind code__2)
+    	returnUs (Any IntRep code__2)
 
-trivialFCode 
-    :: (Reg -> Reg -> Reg -> AlphaInstr) 
-    -> [StixTree] 
-    -> SUniqSM Register
+trivialFCode
+    :: (Reg -> Reg -> Reg -> AlphaInstr)
+    -> [StixTree]
+    -> UniqSM Register
 
 trivialFCode instr [x, y] =
-    getReg x	    	    	    `thenSUs` \ register1 ->
-    getReg y	    	    	    `thenSUs` \ register2 ->
-    getNewRegNCG DoubleKind   	    `thenSUs` \ tmp1 ->
-    getNewRegNCG DoubleKind   	    `thenSUs` \ tmp2 ->
+    getReg x	    	    	    `thenUs` \ register1 ->
+    getReg y	    	    	    `thenUs` \ register2 ->
+    getNewRegNCG DoubleRep   	    `thenUs` \ tmp1 ->
+    getNewRegNCG DoubleRep   	    `thenUs` \ tmp2 ->
     let
     	code1 = registerCode register1 tmp1
     	src1  = registerName register1 tmp1
@@ -884,41 +872,41 @@ trivialFCode instr [x, y] =
     	code__2 dst = asmParThen [code1 asmVoid, code2 asmVoid] .
     	    	      mkSeqInstr (instr src1 src2 dst)
     in
-    	returnSUs (Any DoubleKind code__2)
+    	returnUs (Any DoubleRep code__2)
 
 \end{code}
 
 Some bizarre special code for getting condition codes into registers.
 Integer non-equality is a test for equality followed by an XOR with 1.
 (Integer comparisons always set the result register to 0 or 1.)  Floating
-point comparisons of any kind leave the result in a floating point register, 
+point comparisons of any kind leave the result in a floating point register,
 so we need to wrangle an integer register out of things.
 
 \begin{code}
 intNECode
     :: [StixTree]
-    -> SUniqSM Register
+    -> UniqSM Register
 
 intNECode args =
-    trivialCode (CMP EQ) args  	    `thenSUs` \ register ->
-    getNewRegNCG IntKind    	    `thenSUs` \ tmp ->
+    trivialCode (CMP EQ) args  	    `thenUs` \ register ->
+    getNewRegNCG IntRep    	    `thenUs` \ tmp ->
     let
     	code = registerCode register tmp
     	src  = registerName register tmp
     	code__2 dst = code . mkSeqInstr (XOR src (RIImm (ImmInt 1)) dst)
     in
-    	returnSUs (Any IntKind code__2)
+    	returnUs (Any IntRep code__2)
 
-cmpFCode 
-    :: (Reg -> Reg -> Reg -> AlphaInstr) 
+cmpFCode
+    :: (Reg -> Reg -> Reg -> AlphaInstr)
     -> Cond
-    -> [StixTree] 
-    -> SUniqSM Register
+    -> [StixTree]
+    -> UniqSM Register
 
 cmpFCode instr cond args =
-    trivialFCode instr args    	    `thenSUs` \ register ->
-    getNewRegNCG DoubleKind    	    `thenSUs` \ tmp ->
-    getUniqLabelNCG 	    	    `thenSUs` \ lbl ->
+    trivialFCode instr args    	    `thenUs` \ register ->
+    getNewRegNCG DoubleRep    	    `thenUs` \ tmp ->
+    getUniqLabelNCG 	    	    `thenUs` \ lbl ->
     let
     	code = registerCode register tmp
     	result  = registerName register tmp
@@ -927,9 +915,9 @@ cmpFCode instr cond args =
     	    OR zero (RIImm (ImmInt 1)) dst,
     	    BF cond result (ImmCLbl lbl),
     	    OR zero (RIReg zero) dst,
-            LABEL lbl]
+	    LABEL lbl]
     in
-    	returnSUs (Any IntKind code__2)
+    	returnUs (Any IntRep code__2)
 
 \end{code}
 
@@ -939,35 +927,35 @@ have handled the constant-folding.
 
 \begin{code}
 
-trivialUCode 
-    :: (RI -> Reg -> AlphaInstr) 
+trivialUCode
+    :: (RI -> Reg -> AlphaInstr)
     -> [StixTree]
-    -> SUniqSM Register
+    -> UniqSM Register
 
 trivialUCode instr [x] =
-    getReg x	    	    	    `thenSUs` \ register ->
-    getNewRegNCG IntKind    	    `thenSUs` \ tmp ->
+    getReg x	    	    	    `thenUs` \ register ->
+    getNewRegNCG IntRep    	    `thenUs` \ tmp ->
     let
     	code = registerCode register tmp
     	src  = registerName register tmp
     	code__2 dst = code . mkSeqInstr (instr (RIReg src) dst)
     in
-    	returnSUs (Any IntKind code__2)
+    	returnUs (Any IntRep code__2)
 
-trivialUFCode 
-    :: (Reg -> Reg -> AlphaInstr) 
+trivialUFCode
+    :: (Reg -> Reg -> AlphaInstr)
     -> [StixTree]
-    -> SUniqSM Register
+    -> UniqSM Register
 
 trivialUFCode instr [x] =
-    getReg x	    	    	    `thenSUs` \ register ->
-    getNewRegNCG DoubleKind    	    `thenSUs` \ tmp ->
+    getReg x	    	    	    `thenUs` \ register ->
+    getNewRegNCG DoubleRep    	    `thenUs` \ tmp ->
     let
     	code = registerCode register tmp
     	src  = registerName register tmp
     	code__2 dst = code . mkSeqInstr (instr src dst)
     in
-    	returnSUs (Any DoubleKind code__2)
+    	returnUs (Any DoubleRep code__2)
 
 \end{code}
 
@@ -976,35 +964,35 @@ Here we just change the type on the register passed on up
 
 \begin{code}
 
-coerceIntCode :: PrimKind -> [StixTree] -> SUniqSM Register
+coerceIntCode :: PrimRep -> [StixTree] -> UniqSM Register
 coerceIntCode pk [x] =
-    getReg x	    	    	    `thenSUs` \ register ->
+    getReg x	    	    	    `thenUs` \ register ->
     case register of
-    	Fixed reg _ code -> returnSUs (Fixed reg pk code)
-    	Any _ code       -> returnSUs (Any pk code)
+    	Fixed reg _ code -> returnUs (Fixed reg pk code)
+    	Any _ code       -> returnUs (Any pk code)
 
-coerceFltCode :: [StixTree] -> SUniqSM Register
+coerceFltCode :: [StixTree] -> UniqSM Register
 coerceFltCode [x] =
-    getReg x	    	    	    `thenSUs` \ register ->
+    getReg x	    	    	    `thenUs` \ register ->
     case register of
-    	Fixed reg _ code -> returnSUs (Fixed reg DoubleKind code)
-    	Any _ code       -> returnSUs (Any DoubleKind code)
+    	Fixed reg _ code -> returnUs (Fixed reg DoubleRep code)
+    	Any _ code       -> returnUs (Any DoubleRep code)
 
 \end{code}
 
-Integer to character conversion.  
+Integer to character conversion.
 
 \begin{code}
 
 chrCode [x] =
-    getReg x	    	    	    `thenSUs` \ register ->
-    getNewRegNCG IntKind    	    `thenSUs` \ reg ->
+    getReg x	    	    	    `thenUs` \ register ->
+    getNewRegNCG IntRep    	    `thenUs` \ reg ->
     let
     	code = registerCode register reg
     	src  = registerName register reg
     	code__2 dst = code . mkSeqInstr (ZAPNOT src (RIImm (ImmInt 1)) dst)
     in
-    	returnSUs (Any IntKind code__2)
+    	returnUs (Any IntRep code__2)
 
 \end{code}
 
@@ -1014,10 +1002,10 @@ point register sets.
 
 \begin{code}
 
-coerceInt2FP :: [StixTree] -> SUniqSM Register
-coerceInt2FP [x] = 
-    getReg x	    	    	    `thenSUs` \ register ->
-    getNewRegNCG IntKind      	    `thenSUs` \ reg ->
+coerceInt2FP :: [StixTree] -> UniqSM Register
+coerceInt2FP [x] =
+    getReg x	    	    	    `thenUs` \ register ->
+    getNewRegNCG IntRep      	    `thenUs` \ reg ->
     let
     	code = registerCode register reg
     	src  = registerName register reg
@@ -1027,12 +1015,12 @@ coerceInt2FP [x] =
     	    LD TF dst (spRel 0),
     	    CVTxy Q TF dst dst]
     in
-    	returnSUs (Any DoubleKind code__2)
+    	returnUs (Any DoubleRep code__2)
 
-coerceFP2Int :: [StixTree] -> SUniqSM Register
+coerceFP2Int :: [StixTree] -> UniqSM Register
 coerceFP2Int [x] =
-    getReg x	    	    	    `thenSUs` \ register ->
-    getNewRegNCG DoubleKind    	    `thenSUs` \ tmp ->
+    getReg x	    	    	    `thenUs` \ register ->
+    getNewRegNCG DoubleRep    	    `thenUs` \ tmp ->
     let
     	code = registerCode register tmp
     	src  = registerName register tmp
@@ -1042,7 +1030,7 @@ coerceFP2Int [x] =
     	    ST TF tmp (spRel 0),
     	    LD Q dst (spRel 0)]
     in
-    	returnSUs (Any IntKind code__2)
+    	returnUs (Any IntRep code__2)
 
 \end{code}
 
@@ -1054,7 +1042,7 @@ is8Bits :: Integer -> Bool
 is8Bits i = i >= -256 && i < 256
 
 maybeImm :: StixTree -> Maybe Imm
-maybeImm (StInt i) 
+maybeImm (StInt i)
   | i >= toInteger minInt && i <= toInteger maxInt = Just (ImmInt (fromInteger i))
   | otherwise = Just (ImmInteger i)
 maybeImm (StLitLbl s)  = Just (ImmLab s)
@@ -1064,17 +1052,17 @@ maybeImm _          = Nothing
 
 mangleIndexTree :: StixTree -> StixTree
 
-mangleIndexTree (StIndex pk base (StInt i)) = 
+mangleIndexTree (StIndex pk base (StInt i)) =
     StPrim IntAddOp [base, off]
   where
     off = StInt (i * size pk)
-    size :: PrimKind -> Integer
+    size :: PrimRep -> Integer
     size pk = case kindToSize pk of
     	{B -> 1; BU -> 1; W -> 2; WU -> 2; L -> 4; FF -> 4; SF -> 4; _ -> 8}
 
-mangleIndexTree (StIndex pk base off) = 
+mangleIndexTree (StIndex pk base off) =
     case pk of
-    	CharKind -> StPrim IntAddOp [base, off]
+    	CharRep -> StPrim IntAddOp [base, off]
     	_   	 -> StPrim IntAddOp [base, off__2]
   where
     off__2 = StPrim SllOp [off, StInt 3]
@@ -1083,10 +1071,10 @@ cvtLitLit :: String -> String
 cvtLitLit "stdin" = "_iob+0"   -- This one is probably okay...
 cvtLitLit "stdout" = "_iob+56" -- but these next two are dodgy at best
 cvtLitLit "stderr" = "_iob+112"
-cvtLitLit s 
+cvtLitLit s
   | isHex s = s
   | otherwise = error ("Native code generator can't handle ``" ++ s ++ "''")
-  where 
+  where
     isHex ('0':'x':xs) = all isHexDigit xs
     isHex _ = False
     -- Now, where have I seen this before?
@@ -1100,7 +1088,7 @@ and for excess call arguments.
 
 \begin{code}
 
-spRel 
+spRel
     :: Int  	-- desired stack offset in words, positive or negative
     -> Addr
 spRel n = AddrRegImm sp (ImmInt (n * 8))
@@ -1111,9 +1099,9 @@ stackArgLoc = 0 :: Int	    -- where to stack extra call arguments (beyond 6)
 
 \begin{code}
 
-getNewRegNCG :: PrimKind -> SUniqSM Reg
-getNewRegNCG pk = 
-      getSUnique          `thenSUs` \ u ->
-      returnSUs (mkReg u pk)
+getNewRegNCG :: PrimRep -> UniqSM Reg
+getNewRegNCG pk =
+      getUnique          `thenUs` \ u ->
+      returnUs (mkReg u pk)
 
 \end{code}
diff --git a/ghc/compiler/nativeGen/AsmCodeGen.hi b/ghc/compiler/nativeGen/AsmCodeGen.hi
deleted file mode 100644
index 4119e7ece5..0000000000
--- a/ghc/compiler/nativeGen/AsmCodeGen.hi
+++ /dev/null
@@ -1,14 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface AsmCodeGen where
-import AbsCSyn(AbstractC)
-import CmdLineOpts(GlobalSwitch, SwitchResult)
-import SplitUniq(SUniqSM(..), SplitUniqSupply)
-import Stdio(_FILE)
-data AbstractC 
-data GlobalSwitch 
-data SwitchResult 
-type SUniqSM a = SplitUniqSupply -> a
-data SplitUniqSupply 
-dumpRealAsm :: (GlobalSwitch -> SwitchResult) -> AbstractC -> SplitUniqSupply -> [Char]
-writeRealAsm :: (GlobalSwitch -> SwitchResult) -> _FILE -> AbstractC -> SplitUniqSupply -> _State _RealWorld -> ((), _State _RealWorld)
-
diff --git a/ghc/compiler/nativeGen/AsmCodeGen.lhs b/ghc/compiler/nativeGen/AsmCodeGen.lhs
index 47bc965c8f..da0d83bb7a 100644
--- a/ghc/compiler/nativeGen/AsmCodeGen.lhs
+++ b/ghc/compiler/nativeGen/AsmCodeGen.lhs
@@ -8,19 +8,17 @@
 #include "../../includes/GhcConstants.h"
 
 module AsmCodeGen (
-#ifdef __GLASGOW_HASKELL__
 	writeRealAsm,
-#endif
 	dumpRealAsm,
 
 	-- And, I guess we need these...
 	AbstractC, GlobalSwitch, SwitchResult,
-	SplitUniqSupply, SUniqSM(..)
+	UniqSupply, UniqSM(..)
     ) where
 
 import AbsCSyn	    ( AbstractC )
 import AbsCStixGen  ( genCodeAbstractC )
-import AbsPrel	    ( PrimKind, PrimOp(..)
+import PrelInfo	    ( PrimRep, PrimOp(..)
 		      IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
 			  IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
 		    )
@@ -38,14 +36,9 @@ import I386Desc	    ( mkI386 )
 import SparcDesc    ( mkSparc )
 #endif
 import Stix
-import SplitUniq
-import Unique
+import UniqSupply
 import Unpretty
 import Util
-#if defined(__HBC__)
-import
-       Word
-#endif
 \end{code}
 
 This is a generic assembly language generator for the Glasgow Haskell
@@ -73,7 +66,7 @@ There are two main components to the code generator.
 	with a Twig-like system handling each statement in turn.
 \item A scheduler turns the tree of assembly language orderings
       into a sequence suitable for input to an assembler.
-\end{itemize} 
+\end{itemize}
 The @codeGenerate@ function returns the final assembly language output
 (as a String).	We can return a string, because there is only one way
 of printing the output suitable for assembler consumption. It also
@@ -86,13 +79,13 @@ instructions.  The generic algorithm is heavily inspired by Twig
 (ref), but also draws concepts from (ref).  The basic idea is to
 (dynamically) walk the Abstract C syntax tree, annotating it with
 possible code matches.	For example, on the Sparc, a possible match
-(with its translation) could be 
-@ 
-   := 
-   / \ 
-  i   r2	=> ST r2,[r1] 
+(with its translation) could be
+@
+   :=
+   / \
+  i   r2	=> ST r2,[r1]
   |
-  r1 
+  r1
 @
 where @r1,r2@ are registers, and @i@ is an indirection.	 The Twig
 bit twiddling algorithm for tree matching has been abandoned. It is
@@ -120,27 +113,20 @@ The flag that needs to be added is -fasm-<platform> where platform is one of
 the choices below.
 
 \begin{code}
-
-#ifdef __GLASGOW_HASKELL__
-# if __GLASGOW_HASKELL__ < 23
-# define _FILE _Addr
-# endif
-writeRealAsm :: (GlobalSwitch -> SwitchResult) -> _FILE -> AbstractC -> SplitUniqSupply -> PrimIO ()
+writeRealAsm :: (GlobalSwitch -> SwitchResult) -> _FILE -> AbstractC -> UniqSupply -> PrimIO ()
 
 writeRealAsm flags file absC uniq_supply
   = uppAppendFile file 80 (runNCG (code flags absC) uniq_supply)
 
-#endif
-
-dumpRealAsm :: (GlobalSwitch -> SwitchResult) -> AbstractC -> SplitUniqSupply -> String
+dumpRealAsm :: (GlobalSwitch -> SwitchResult) -> AbstractC -> UniqSupply -> String
 
 dumpRealAsm flags absC uniq_supply = uppShow 80 (runNCG (code flags absC) uniq_supply)
 
 runNCG m uniq_supply = m uniq_supply
 
 code flags absC =
-    genCodeAbstractC target absC		    `thenSUs` \ treelists ->
-    let 
+    genCodeAbstractC target absC		    `thenUs` \ treelists ->
+    let
 	stix = map (map (genericOpt target)) treelists
     in
     codeGen {-target-} sty stix
@@ -163,7 +149,7 @@ code flags absC =
     	Just _ {-???"sparc-sun-solaris2"-} -> mkSparc False flags
 # endif
 #endif
-        _ -> error
+	_ -> error
 	     ("ERROR:Trying to generate assembly language for an unsupported architecture\n"++
 	      "(or one for which this build is not configured).")
 
@@ -186,9 +172,9 @@ introduced some new opportunities for constant-folding wrt address manipulations
 
 \begin{code}
 
-genericOpt 
-    :: Target 
-    -> StixTree 
+genericOpt
+    :: Target
+    -> StixTree
     -> StixTree
 
 \end{code}
@@ -222,11 +208,11 @@ Fold indices together when the types match.
 
 genericOpt target (StIndex pk (StIndex pk' base off) off')
   | pk == pk' =
-    StIndex pk (genericOpt target base) 
+    StIndex pk (genericOpt target base)
     	       (genericOpt target (StPrim IntAddOp [off, off']))
 
 genericOpt target (StIndex pk base off) =
-    StIndex pk (genericOpt target base) 
+    StIndex pk (genericOpt target base)
     	       (genericOpt target off)
 
 \end{code}
@@ -246,8 +232,8 @@ Replace register leaves with appropriate StixTrees for the given target.
 
 \begin{code}
 
-genericOpt target leaf@(StReg (StixMagicId id)) = 
-    case stgReg target id of 
+genericOpt target leaf@(StReg (StixMagicId id)) =
+    case stgReg target id of
     	Always tree -> genericOpt target tree
     	Save _     -> leaf
 
@@ -271,7 +257,7 @@ primOpt op arg@[StInt x] =
     	IntAbsOp -> StInt (abs x)
     	_ -> StPrim op arg
 
-primOpt op args@[StInt x, StInt y] = 
+primOpt op args@[StInt x, StInt y] =
     case op of
     	CharGtOp -> StInt (if x > y then 1 else 0)
     	CharGeOp -> StInt (if x >= y then 1 else 0)
@@ -299,18 +285,13 @@ can match for strength reductions.  Note that the code generator will
 also assume that constants have been shifted to the right when possible.
 
 \begin{code}
-
-primOpt op [x@(StInt _), y]    | commutableOp op = primOpt op [y, x]
---OLD:
---primOpt op [x@(StDouble _), y] | commutableOp op = primOpt op [y, x]
-
+primOpt op [x@(StInt _), y] | commutableOp op = primOpt op [y, x]
 \end{code}
 
 We can often do something with constants of 0 and 1 ...
 
 \begin{code}
-
-primOpt op args@[x, y@(StInt 0)] = 
+primOpt op args@[x, y@(StInt 0)] =
     case op of
     	IntAddOp -> x
     	IntSubOp -> x
@@ -325,73 +306,40 @@ primOpt op args@[x, y@(StInt 0)] =
     	ISrlOp -> x
     	_ -> StPrim op args
 
-primOpt op args@[x, y@(StInt 1)] = 
+primOpt op args@[x, y@(StInt 1)] =
     case op of
     	IntMulOp -> x
     	IntQuotOp -> x
     	IntRemOp -> StInt 0
     	_ -> StPrim op args
-
--- The following code tweaks a bug in early versions of GHC (pre-0.21)
-
-{- OLD: (death to constant folding in ncg)
-primOpt op args@[x, y@(StDouble 0.0)] = 
-    case op of
-    	FloatAddOp -> x
-    	FloatSubOp -> x
-    	FloatMulOp -> y
-    	DoubleAddOp -> x
-    	DoubleSubOp -> x
-    	DoubleMulOp -> y
-    	_ -> StPrim op args
-
-primOpt op args@[x, y@(StDouble 1.0)] = 
-    case op of
-    	FloatMulOp -> x
-    	FloatDivOp -> x
-    	DoubleMulOp -> x
-    	DoubleDivOp -> x
-    	_ -> StPrim op args
-
-primOpt op args@[x, y@(StDouble 2.0)] =
-    case op of
-    	FloatMulOp -> StPrim FloatAddOp [x, x]
-    	DoubleMulOp -> StPrim DoubleAddOp [x, x]
-    	_ -> StPrim op args
--}
-
 \end{code}
 
 Now look for multiplication/division by powers of 2 (integers).
 
 \begin{code}
-
-primOpt op args@[x, y@(StInt n)] = 
+primOpt op args@[x, y@(StInt n)] =
     case op of
     	IntMulOp -> case exact_log2 n of
-            Nothing -> StPrim op args
+	    Nothing -> StPrim op args
     	    Just p -> StPrim SllOp [x, StInt p]
     	IntQuotOp -> case exact_log2 n of
-            Nothing -> StPrim op args
+	    Nothing -> StPrim op args
     	    Just p -> StPrim SraOp [x, StInt p]
     	_ -> StPrim op args
-
 \end{code}
 
 Anything else is just too hard.
 
 \begin{code}
-
 primOpt op args = StPrim op args
-
 \end{code}
 
-The commutable ops are those for which we will try to move constants to the
-right hand side for strength reduction.
+The commutable ops are those for which we will try to move constants
+to the right hand side for strength reduction.
 
 \begin{code}
-
 commutableOp :: PrimOp -> Bool
+
 commutableOp CharEqOp = True
 commutableOp CharNeOp = True
 commutableOp IntAddOp = True
@@ -411,50 +359,26 @@ commutableOp DoubleMulOp = True
 commutableOp DoubleEqOp = True
 commutableOp DoubleNeOp = True
 commutableOp _ = False
-
 \end{code}
 
-This algorithm for determining the $\log_2$ of exact powers of 2 comes from gcc.  It
-requires bit manipulation primitives, so we have a ghc version and an hbc version.
-Other Haskell compilers are on their own.
+This algorithm for determining the $\log_2$ of exact powers of 2 comes
+from gcc.  It requires bit manipulation primitives, so we have a ghc
+version and an hbc version.  Other Haskell compilers are on their own.
 
 \begin{code}
-
-#ifdef __GLASGOW_HASKELL__
-
 w2i x = word2Int# x
 i2w x = int2Word# x
 i2w_s x = (x::Int#)
 
 exact_log2 :: Integer -> Maybe Integer
-exact_log2 x 
+exact_log2 x
     | x <= 0 || x >= 2147483648 = Nothing
     | otherwise = case fromInteger x of
-        I# x# -> if (w2i ((i2w x#) `and#` (i2w (0# -# x#))) /=# x#) then Nothing
+	I# x# -> if (w2i ((i2w x#) `and#` (i2w (0# -# x#))) /=# x#) then Nothing
     	         else Just (toInteger (I# (pow2 x#)))
 
     	    where pow2 x# | x# ==# 1# = 0#
     	    	    	  | otherwise = 1# +# pow2 (w2i (i2w x# `shiftr` i2w_s 1#))
 
-# if __GLASGOW_HASKELL__ >= 23
 		  shiftr x y = shiftRA# x y
-# else
-		  shiftr x y = shiftR#  x y
-# endif
-
-#else {-probably HBC-}
-
-exact_log2 :: Integer -> Maybe Integer
-exact_log2 x 
-    | x <= 0 || x >= 2147483648 = Nothing
-    | otherwise =
-    	if x' `bitAnd` (-x') /= x' then Nothing
-    	else Just (toInteger (pow2 x'))
-
-            where x' = ((fromInteger x) :: Word)
-    	    	  pow2 x | x == bit0 = 0 :: Int
-    	                 | otherwise = 1 + pow2 (x `bitRsh` 1)
-
-#endif {-probably HBC-}
-
 \end{code}
diff --git a/ghc/compiler/nativeGen/AsmRegAlloc.hi b/ghc/compiler/nativeGen/AsmRegAlloc.hi
deleted file mode 100644
index 4959627422..0000000000
--- a/ghc/compiler/nativeGen/AsmRegAlloc.hi
+++ /dev/null
@@ -1,44 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface AsmRegAlloc where
-import CLabelInfo(CLabel)
-import FiniteMap(FiniteMap)
-import OrdList(OrdList)
-import Outputable(NamedThing, Outputable)
-import PrimKind(PrimKind)
-import UniqFM(UniqFM)
-import UniqSet(UniqSet(..))
-import Unique(Unique)
-class MachineCode a where
-	regUsage :: a -> RegUsage
-	regLiveness :: a -> RegLiveness -> RegLiveness
-	patchRegs :: a -> (Reg -> Reg) -> a
-	spillReg :: Reg -> Reg -> OrdList a
-	loadReg :: Reg -> Reg -> OrdList a
-class MachineRegisters a where
-	mkMRegs :: [Int] -> a
-	possibleMRegs :: PrimKind -> a -> [Int]
-	useMReg :: a -> Int# -> a
-	useMRegs :: a -> [Int] -> a
-	freeMReg :: a -> Int# -> a
-	freeMRegs :: a -> [Int] -> a
-data CLabel 
-data FiniteMap a b 
-data FutureLive   = FL (UniqFM Reg) (FiniteMap CLabel (UniqFM Reg))
-data OrdList a 
-data PrimKind 
-data Reg   = FixedReg Int# | MappedReg Int# | MemoryReg Int PrimKind | UnmappedReg Unique PrimKind
-data RegLiveness   = RL (UniqFM Reg) FutureLive
-data RegUsage   = RU (UniqFM Reg) (UniqFM Reg)
-data UniqFM a 
-type UniqSet a = UniqFM a
-data Unique 
-extractMappedRegNos :: [Reg] -> [Int]
-mkReg :: Unique -> PrimKind -> Reg
-runHairyRegAllocate :: (MachineRegisters a, MachineCode b) => a -> [Int] -> OrdList b -> [b]
-runRegAllocate :: (MachineRegisters a, MachineCode b) => a -> [Int] -> OrdList b -> [b]
-instance Eq Reg
-instance Ord Reg
-instance NamedThing Reg
-instance Outputable Reg
-instance Text Reg
-
diff --git a/ghc/compiler/nativeGen/AsmRegAlloc.lhs b/ghc/compiler/nativeGen/AsmRegAlloc.lhs
index d71b00ec8d..29061de5bf 100644
--- a/ghc/compiler/nativeGen/AsmRegAlloc.lhs
+++ b/ghc/compiler/nativeGen/AsmRegAlloc.lhs
@@ -12,25 +12,20 @@ module AsmRegAlloc (
 	MachineRegisters(..), MachineCode(..),
 
 	mkReg, runRegAllocate, runHairyRegAllocate,
-	extractMappedRegNos,
+	extractMappedRegNos
 
 	-- And, for self-sufficiency
-	CLabel, OrdList, PrimKind, UniqSet(..), UniqFM,
-	FiniteMap, Unique
     ) where
 
-IMPORT_Trace
-
-import CLabelInfo	( CLabel )
+import CLabel	( CLabel )
 import FiniteMap
 import MachDesc
 import Maybes		( maybeToBool, Maybe(..) )
 import OrdList		-- ( mkUnitList, mkSeqList, mkParList, OrdList )
 import Outputable
 import Pretty
-import PrimKind		( PrimKind(..) )
 import UniqSet
-import Unique
+import Unique		( Unique )
 import Util
 
 #if ! OMIT_NATIVE_CODEGEN
@@ -83,16 +78,16 @@ data Reg = FixedReg  FAST_INT		-- A pre-allocated machine register
 
 	 | MappedReg FAST_INT		-- A dynamically allocated machine register
 
-	 | MemoryReg Int PrimKind	-- A machine "register" actually held in a memory
+	 | MemoryReg Int PrimRep	-- A machine "register" actually held in a memory
 					-- allocated table of registers which didn't fit
 					-- in real registers.
 
-	 | UnmappedReg Unique PrimKind	-- One of an infinite supply of registers,
+	 | UnmappedReg Unique PrimRep	-- One of an infinite supply of registers,
 					-- always mapped to one of the earlier two
 					-- before we're done.
 	 -- No thanks: deriving (Eq)
 
-mkReg :: Unique -> PrimKind -> Reg
+mkReg :: Unique -> PrimRep -> Reg
 mkReg = UnmappedReg
 
 instance Text Reg where
@@ -109,7 +104,7 @@ instance Outputable Reg where
 cmpReg (FixedReg i) (FixedReg i') = cmp_ihash i i'
 cmpReg (MappedReg i) (MappedReg i') = cmp_ihash i i'
 cmpReg (MemoryReg i _) (MemoryReg i' _) = cmp_i i i'
-cmpReg (UnmappedReg u _) (UnmappedReg u' _) = cmpUnique u u'
+cmpReg (UnmappedReg u _) (UnmappedReg u' _) = cmp u u'
 cmpReg r1 r2 =
     let tag1 = tagReg r1
 	tag2 = tagReg r2
@@ -136,17 +131,15 @@ instance Ord Reg where
     a <	 b = case cmpReg a b of { LT_ -> True;	EQ_ -> False; GT__ -> False }
     a >= b = case cmpReg a b of { LT_ -> False; EQ_ -> True;  GT__ -> True  }
     a >	 b = case cmpReg a b of { LT_ -> False; EQ_ -> False; GT__ -> True  }
-#ifdef __GLASGOW_HASKELL__
     _tagCmp a b = case cmpReg a b of { LT_ -> _LT; EQ_ -> _EQ; GT__ -> _GT }
-#endif
 
 instance NamedThing Reg where
-    -- the *only* method that should be defined is "getTheUnique"!
+    -- the *only* method that should be defined is "getItsUnique"!
     -- (so we can use UniqFMs/UniqSets on Regs
-    getTheUnique (UnmappedReg u _) = u
-    getTheUnique (FixedReg i)	   = mkPseudoUnique1 IBOX(i)
-    getTheUnique (MappedReg i)	   = mkPseudoUnique2 IBOX(i)
-    getTheUnique (MemoryReg i _)   = mkPseudoUnique3 i
+    getItsUnique (UnmappedReg u _) = u
+    getItsUnique (FixedReg i)	   = mkPseudoUnique1 IBOX(i)
+    getItsUnique (MappedReg i)	   = mkPseudoUnique2 IBOX(i)
+    getItsUnique (MemoryReg i _)   = mkPseudoUnique3 i
 \end{code}
 
 This is the generic register allocator.
@@ -167,7 +160,7 @@ exist (for allocation purposes, anyway).
 
 class MachineRegisters a where
     mkMRegs	    :: [Int] -> a
-    possibleMRegs   :: PrimKind -> a -> [Int]
+    possibleMRegs   :: PrimRep -> a -> [Int]
     useMReg	    :: a -> FAST_INT -> a
     useMRegs	    :: a -> [Int] -> a
     freeMReg	    :: a -> FAST_INT -> a
@@ -207,21 +200,17 @@ data RegLiveness
 	FutureLive
 
 class MachineCode a where
--- OLD:
---    flatten	    :: OrdList a -> [a]
       regUsage	    :: a -> RegUsage
       regLiveness   :: a -> RegLiveness -> RegLiveness
       patchRegs	    :: a -> (Reg -> Reg) -> a
       spillReg	    :: Reg -> Reg -> OrdList a
       loadReg	    :: Reg -> Reg -> OrdList a
-
 \end{code}
 
 First we try something extremely simple.
 If that fails, we have to do things the hard way.
 
 \begin{code}
-
 runRegAllocate
     :: (MachineRegisters a, MachineCode b)
     => a
@@ -230,7 +219,7 @@ runRegAllocate
     -> [b]
 
 runRegAllocate regs reserve_regs instrs =
-    case simpleAlloc of 
+    case simpleAlloc of
 	Just x  -> x
 	Nothing -> hairyAlloc
   where
diff --git a/ghc/compiler/nativeGen/I386Code.hi b/ghc/compiler/nativeGen/I386Code.hi
deleted file mode 100644
index e5fdf14b11..0000000000
--- a/ghc/compiler/nativeGen/I386Code.hi
+++ /dev/null
@@ -1,99 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface I386Code where
-import AbsCSyn(MagicId)
-import AsmRegAlloc(MachineCode, MachineRegisters, Reg)
-import BitSet(BitSet)
-import CLabelInfo(CLabel)
-import CharSeq(CSeq)
-import FiniteMap(FiniteMap)
-import Maybes(Labda)
-import OrdList(OrdList)
-import PreludePS(_PackedString)
-import Pretty(PprStyle)
-import PrimKind(PrimKind)
-import Stix(CodeSegment)
-import UniqFM(UniqFM)
-import UniqSet(UniqSet(..))
-import Unique(Unique)
-data Addr   = Addr (Labda Reg) (Labda (Reg, Int)) Imm | ImmAddr Imm Int
-type Base = Labda Reg
-data MagicId 	{-# GHC_PRAGMA BaseReg | StkOReg | VanillaReg PrimKind Int# | FloatReg Int# | DoubleReg Int# | TagReg | RetReg | SpA | SuA | SpB | SuB | Hp | HpLim | LivenessReg | ActivityReg | StdUpdRetVecReg | StkStubReg | CurCostCentre | VoidReg #-}
-data Reg 	{-# GHC_PRAGMA FixedReg Int# | MappedReg Int# | MemoryReg Int PrimKind | UnmappedReg Unique PrimKind #-}
-data BitSet 	{-# GHC_PRAGMA MkBS Word# #-}
-data CLabel 
-data CSeq 	{-# GHC_PRAGMA CNil | CAppend CSeq CSeq | CIndent Int CSeq | CNewline | CStr [Char] | CCh Char | CInt Int | CPStr _PackedString #-}
-data CodeSegment 	{-# GHC_PRAGMA DataSegment | TextSegment #-}
-data Cond   = ALWAYS | GEU | LU | EQ | GT | GE | GU | LT | LE | LEU | NE | NEG | POS
-type Displacement = Imm
-data FiniteMap a b 	{-# GHC_PRAGMA EmptyFM | Branch a b Int# (FiniteMap a b) (FiniteMap a b) #-}
-type I386Code = OrdList I386Instr
-data I386Instr
-  = MOV Size Operand Operand | MOVZX Size Operand Operand | MOVSX Size Operand Operand | LEA Size Operand Operand | ADD Size Operand Operand | SUB Size Operand Operand | IMUL Size Operand Operand | IDIV Size Operand | AND Size Operand Operand | OR Size Operand Operand | XOR Size Operand Operand | NOT Size Operand | NEGI Size Operand | SHL Size Operand Operand | SAR Size Operand Operand | SHR Size Operand Operand | NOP | SAHF | FABS | FADD Size Operand | FADDP | FIADD Size Addr | FCHS | FCOM Size Operand | FCOS | FDIV Size Operand | FDIVP | FIDIV Size Addr | FDIVR Size Operand | FDIVRP | FIDIVR Size Addr | FICOM Size Addr | FILD Size Addr Reg | FIST Size Addr | FLD Size Operand | FLD1 | FLDZ | FMUL Size Operand | FMULP | FIMUL Size Addr | FRNDINT | FSIN | FSQRT | FST Size Operand | FSTP Size Operand | FSUB Size Operand | FSUBP | FISUB Size Addr | FSUBR Size Operand | FSUBRP | FISUBR Size Addr | FTST | FCOMP Size Operand | FUCOMPP | FXCH | FNSTSW | FNOP | TEST Size Operand Operand | CMP Size Operand Operand | SETCC Cond Operand | PUSH Size Operand | POP Size Operand | JMP Operand | JXX Cond CLabel | CALL Imm | CLTD | LABEL CLabel | COMMENT _PackedString | SEGMENT CodeSegment | ASCII Bool [Char] | DATA Size [Imm]
-data I386Regs 	{-# GHC_PRAGMA SRegs BitSet BitSet #-}
-data Imm   = ImmInt Int | ImmInteger Integer | ImmCLbl CLabel | ImmLab CSeq | ImmLit CSeq
-type Index = Labda (Reg, Int)
-data Operand   = OpReg Reg | OpImm Imm | OpAddr Addr
-data OrdList a 	{-# GHC_PRAGMA SeqList (OrdList a) (OrdList a) | ParList (OrdList a) (OrdList a) | OrdObj a | NoObj #-}
-data PrimKind 	{-# GHC_PRAGMA PtrKind | CodePtrKind | DataPtrKind | RetKind | InfoPtrKind | CostCentreKind | CharKind | IntKind | WordKind | AddrKind | FloatKind | DoubleKind | MallocPtrKind | StablePtrKind | ArrayKind | ByteArrayKind | VoidKind #-}
-data Size   = B | HB | S | L | F | D
-data UniqFM a 	{-# GHC_PRAGMA EmptyUFM | LeafUFM Int# a | NodeUFM Int# Int# (UniqFM a) (UniqFM a) #-}
-type UniqSet a = UniqFM a
-data Unique 	{-# GHC_PRAGMA MkUnique Int# #-}
-baseRegOffset :: MagicId -> Int
-	{-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
-callerSaves :: MagicId -> Bool
-	{-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _F_ _IF_ARGS_ 0 1 C 21 \ (u0 :: MagicId) -> case u0 of { _ALG_ _ORIG_ AbsCSyn Hp  -> _!_ True [] []; (u1 :: MagicId) -> _!_ False [] [] } _N_ #-}
-eax :: Reg
-	{-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ _ORIG_ AsmRegAlloc FixedReg [] [0#] _N_ #-}
-ebp :: Reg
-	{-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ _ORIG_ AsmRegAlloc FixedReg [] [6#] _N_ #-}
-ebx :: Reg
-	{-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ _ORIG_ AsmRegAlloc FixedReg [] [1#] _N_ #-}
-ecx :: Reg
-	{-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ _ORIG_ AsmRegAlloc FixedReg [] [2#] _N_ #-}
-edi :: Reg
-	{-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ _ORIG_ AsmRegAlloc FixedReg [] [5#] _N_ #-}
-edx :: Reg
-	{-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ _ORIG_ AsmRegAlloc FixedReg [] [3#] _N_ #-}
-esi :: Reg
-	{-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ _ORIG_ AsmRegAlloc FixedReg [] [4#] _N_ #-}
-esp :: Reg
-	{-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ _ORIG_ AsmRegAlloc FixedReg [] [7#] _N_ #-}
-freeRegs :: [Reg]
-	{-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
-is13Bits :: Integral a => a -> Bool
-	{-# GHC_PRAGMA _A_ 1 _U_ 12 _N_ _S_ "U(LU(U(ALASAAAA)AAA)AAAAAAAAAA)" {_A_ 3 _U_ 1112 _N_ _N_ _N_ _N_} _N_ _SPECIALISE_ [ Int ] 1 { _A_ 1 _U_ 1 _N_ _S_ "U(P)" {_A_ 1 _U_ 2 _N_ _N_ _N_ _N_} _N_ _N_ }, [ Integer ] 1 { _A_ 1 _U_ 1 _N_ _S_ "U(PPP)" {_A_ 3 _U_ 222 _N_ _N_ _N_ _N_} _N_ _N_ } #-}
-kindToSize :: PrimKind -> Size
-	{-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "E" _N_ _N_ #-}
-offset :: Addr -> Int -> Labda Addr
-	{-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "SL" _N_ _N_ #-}
-printLabeledCodes :: PprStyle -> [I386Instr] -> CSeq
-	{-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LS" _N_ _N_ #-}
-reservedRegs :: [Int]
-	{-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ _NIL_ [Int] [] _N_ #-}
-spRel :: Int -> Addr
-	{-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _N_ _N_ _N_ #-}
-st0 :: Reg
-	{-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
-st1 :: Reg
-	{-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
-stgRegMap :: MagicId -> Labda Reg
-	{-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
-strImmLit :: [Char] -> Imm
-	{-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _N_ _N_ #-}
-instance MachineCode I386Instr
-	{-# GHC_PRAGMA _M_ I386Code {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 6 _!_ _TUP_5 [(I386Instr -> RegUsage), (I386Instr -> RegLiveness -> RegLiveness), (I386Instr -> (Reg -> Reg) -> I386Instr), (Reg -> Reg -> OrdList I386Instr), (Reg -> Reg -> OrdList I386Instr)] [_CONSTM_ MachineCode regUsage (I386Instr), _CONSTM_ MachineCode regLiveness (I386Instr), _CONSTM_ MachineCode patchRegs (I386Instr), _CONSTM_ MachineCode spillReg (I386Instr), _CONSTM_ MachineCode loadReg (I386Instr)] _N_
-	 regUsage = _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_,
-	 regLiveness = _A_ 2 _U_ 11 _N_ _S_ "SU(LU(LL))" {_A_ 4 _U_ 1222 _N_ _N_ _N_ _N_} _N_ _N_,
-	 patchRegs = _A_ 2 _U_ 22 _N_ _S_ "SL" _N_ _N_,
-	 spillReg = _A_ 2 _U_ 21 _N_ _S_ "LS" _N_ _N_,
-	 loadReg = _A_ 2 _U_ 12 _N_ _S_ "SL" _N_ _N_ #-}
-instance MachineRegisters I386Regs
-	{-# GHC_PRAGMA _M_ I386Code {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 7 _!_ _TUP_6 [([Int] -> I386Regs), (PrimKind -> I386Regs -> [Int]), (I386Regs -> Int# -> I386Regs), (I386Regs -> [Int] -> I386Regs), (I386Regs -> Int# -> I386Regs), (I386Regs -> [Int] -> I386Regs)] [_CONSTM_ MachineRegisters mkMRegs (I386Regs), _CONSTM_ MachineRegisters possibleMRegs (I386Regs), _CONSTM_ MachineRegisters useMReg (I386Regs), _CONSTM_ MachineRegisters useMRegs (I386Regs), _CONSTM_ MachineRegisters freeMReg (I386Regs), _CONSTM_ MachineRegisters freeMRegs (I386Regs)] _N_
-	 mkMRegs = _A_ 1 _U_ 1 _N_ _N_ _N_ _N_,
-	 possibleMRegs = _A_ 2 _U_ 11 _N_ _S_ "EU(LL)" {_A_ 3 _U_ 111 _N_ _N_ _N_ _N_} _N_ _N_,
-	 useMReg = _A_ 2 _U_ 12 _N_ _S_ "U(LL)P" {_A_ 3 _U_ 222 _N_ _N_ _N_ _N_} _N_ _N_,
-	 useMRegs = _A_ 2 _U_ 11 _N_ _S_ "U(LL)L" {_A_ 3 _U_ 111 _N_ _N_ _N_ _N_} _N_ _N_,
-	 freeMReg = _A_ 2 _U_ 12 _N_ _S_ "U(LL)P" {_A_ 3 _U_ 222 _N_ _N_ _N_ _N_} _N_ _N_,
-	 freeMRegs = _A_ 2 _U_ 11 _N_ _S_ "U(LL)L" {_A_ 3 _U_ 111 _N_ _N_ _N_ _N_} _N_ _N_ #-}
-
diff --git a/ghc/compiler/nativeGen/I386Code.lhs b/ghc/compiler/nativeGen/I386Code.lhs
index 8730e86aa3..2205224d92 100644
--- a/ghc/compiler/nativeGen/I386Code.lhs
+++ b/ghc/compiler/nativeGen/I386Code.lhs
@@ -9,12 +9,12 @@
 #include "HsVersions.h"
 
 module I386Code (
-	Addr(..), 
-        Cond(..), Imm(..), Operand(..), Size(..),
-        Base(..), Index(..), Displacement(..),
+	Addr(..),
+	Cond(..), Imm(..), Operand(..), Size(..),
+	Base(..), Index(..), Displacement(..),
 	I386Code(..),I386Instr(..),I386Regs,
-	strImmLit, --UNUSED: strImmLab,
-        spRel,
+	strImmLit,
+	spRel,
 
     	printLabeledCodes,
 
@@ -26,27 +26,22 @@ module I386Code (
 
     	st0, st1, eax, ebx, ecx, edx, esi, edi, ebp, esp,
 
-    	freeRegs, reservedRegs,
+    	freeRegs, reservedRegs
 
 	-- and, for self-sufficiency ...
-	CLabel, CodeSegment, OrdList, PrimKind, Reg, UniqSet(..),
-	UniqFM, FiniteMap, Unique, MagicId, CSeq, BitSet
     ) where
 
-IMPORT_Trace
-
 import AbsCSyn	    	( MagicId(..) )
 import AsmRegAlloc  	( MachineCode(..), MachineRegisters(..), FutureLive(..),
     	    	    	  Reg(..), RegUsage(..), RegLiveness(..)
     	    	    	)
-import BitSet	 
+import BitSet
 import CgCompInfo   	( mAX_Double_REG, mAX_Float_REG, mAX_Vanilla_REG )
-import CLabelInfo   	( CLabel, pprCLabel, externallyVisibleCLabel, charToC )
-import FiniteMap    
+import CLabel   	( CLabel, pprCLabel, externallyVisibleCLabel, charToC )
+import FiniteMap
 import Maybes	    	( Maybe(..), maybeToBool )
 import OrdList	    	( OrdList, mkUnitList, flattenOrdList )
-import Outputable    
-import PrimKind	    	( PrimKind(..) )
+import Outputable
 import UniqSet
 import Stix
 import Unpretty
@@ -112,7 +107,6 @@ data Imm = ImmInt Int
 	 | ImmLit Unpretty	      -- Simple string
 	 deriving ()
 
---UNUSED:strImmLab s = ImmLab (uppStr s)
 strImmLit s = ImmLit (uppStr s)
 
 data Cond = ALWAYS
@@ -140,13 +134,13 @@ data Size = B
 	  deriving ()
 
 data Operand = OpReg  Reg	-- register
-             | OpImm  Imm	-- immediate value
-             | OpAddr Addr	-- memory reference
+	     | OpImm  Imm	-- immediate value
+	     | OpAddr Addr	-- memory reference
 	     deriving ()
 
 data Addr = Addr Base Index Displacement
-          | ImmAddr Imm Int
-          -- deriving Eq
+	  | ImmAddr Imm Int
+	  -- deriving Eq
 
 type Base         = Maybe Reg
 type Index        = Maybe (Reg, Int)	-- Int is 2, 4 or 8
@@ -156,18 +150,18 @@ data I386Instr =
 
 -- Moves.
 
-		MOV	      Size Operand Operand 
+		MOV	      Size Operand Operand
 	      | MOVZX	      Size Operand Operand -- size is the size of operand 2
 	      | MOVSX	      Size Operand Operand -- size is the size of operand 2
 
 -- Load effective address (also a very useful three-operand add instruction :-)
 
-              | LEA           Size Operand Operand
+	      | LEA           Size Operand Operand
 
 -- Int Arithmetic.
 
-	      | ADD	      Size Operand Operand 
-	      | SUB	      Size Operand Operand 
+	      | ADD	      Size Operand Operand
+	      | SUB	      Size Operand Operand
 
 -- Multiplication (signed and unsigned), Division (signed and unsigned),
 -- result in %eax, %edx.
@@ -177,15 +171,15 @@ data I386Instr =
 
 -- Simple bit-twiddling.
 
-	      | AND	      Size Operand Operand 
-	      | OR	      Size Operand Operand 
-	      | XOR	      Size Operand Operand 
-	      | NOT	      Size Operand 
+	      | AND	      Size Operand Operand
+	      | OR	      Size Operand Operand
+	      | XOR	      Size Operand Operand
+	      | NOT	      Size Operand
 	      | NEGI	      Size Operand -- NEG instruction (name clash with Cond)
 	      | SHL	      Size Operand Operand -- 1st operand must be an Imm
 	      | SAR	      Size Operand Operand -- 1st operand must be an Imm
 	      | SHR	      Size Operand Operand -- 1st operand must be an Imm
-	      | NOP	      
+	      | NOP
 
 -- Float Arithmetic. -- ToDo for 386
 
@@ -193,66 +187,66 @@ data I386Instr =
 -- right up until we spit them out.
 
 	      | SAHF	      -- stores ah into flags
-    	      | FABS          
+    	      | FABS
 	      | FADD	      Size Operand -- src
-	      | FADDP	      
+	      | FADDP
 	      | FIADD	      Size Addr -- src
-    	      | FCHS          
+    	      | FCHS
     	      | FCOM	      Size Operand -- src
-    	      | FCOS          
+    	      | FCOS
 	      | FDIV	      Size Operand -- src
-	      | FDIVP	      
+	      | FDIVP
 	      | FIDIV	      Size Addr -- src
 	      | FDIVR	      Size Operand -- src
-	      | FDIVRP	      
+	      | FDIVRP
 	      | FIDIVR	      Size Addr -- src
     	      | FICOM	      Size Addr -- src
     	      | FILD	      Size Addr Reg -- src, dst
     	      | FIST	      Size Addr -- dst
     	      | FLD	      Size Operand -- src
-    	      | FLD1          
-    	      | FLDZ          
+    	      | FLD1
+    	      | FLDZ
     	      | FMUL	      Size Operand -- src
-    	      | FMULP	      
+    	      | FMULP
     	      | FIMUL	      Size Addr -- src
-    	      | FRNDINT       
-    	      | FSIN          
-    	      | FSQRT         
+    	      | FRNDINT
+    	      | FSIN
+    	      | FSQRT
     	      | FST	      Size Operand -- dst
     	      | FSTP	      Size Operand -- dst
 	      | FSUB	      Size Operand -- src
-	      | FSUBP	      
+	      | FSUBP
 	      | FISUB	      Size Addr -- src
 	      | FSUBR	      Size Operand -- src
-	      | FSUBRP	      
+	      | FSUBRP
 	      | FISUBR	      Size Addr -- src
-	      | FTST          
+	      | FTST
     	      | FCOMP	      Size Operand -- src
-    	      | FUCOMPP	      
+    	      | FUCOMPP
 	      | FXCH
 	      | FNSTSW
 	      | FNOP
 
 -- Comparison
-        
-              | TEST          Size Operand Operand
-              | CMP           Size Operand Operand
-              | SETCC         Cond Operand
+
+	      | TEST          Size Operand Operand
+	      | CMP           Size Operand Operand
+	      | SETCC         Cond Operand
 
 -- Stack Operations.
 
-              | PUSH          Size Operand
-              | POP           Size Operand
+	      | PUSH          Size Operand
+	      | POP           Size Operand
 
 -- Jumping around.
 
 	      | JMP	      Operand -- target
 	      | JXX	      Cond CLabel -- target
-	      | CALL	      Imm 
+	      | CALL	      Imm
 
 -- Other things.
 
-              | CLTD -- sign extend %eax into %edx:%eax
+	      | CLTD -- sign extend %eax into %edx:%eax
 
 -- Pseudo-ops.
 
@@ -292,32 +286,32 @@ pprReg s other         = uppStr (show other) -- should only happen when debuggin
 pprI386Reg :: Size -> FAST_INT -> Unpretty
 pprI386Reg B i = uppPStr
     (case i of {
-        ILIT( 0) -> SLIT("%al");  ILIT( 1) -> SLIT("%bl");
+	ILIT( 0) -> SLIT("%al");  ILIT( 1) -> SLIT("%bl");
 	ILIT( 2) -> SLIT("%cl");  ILIT( 3) -> SLIT("%dl");
 	_ -> SLIT("very naughty I386 byte register")
     })
 
 pprI386Reg HB i = uppPStr
     (case i of {
-        ILIT( 0) -> SLIT("%ah");  ILIT( 1) -> SLIT("%bh");
+	ILIT( 0) -> SLIT("%ah");  ILIT( 1) -> SLIT("%bh");
 	ILIT( 2) -> SLIT("%ch");  ILIT( 3) -> SLIT("%dh");
 	_ -> SLIT("very naughty I386 high byte register")
     })
 
 pprI386Reg S i = uppPStr
     (case i of {
-        ILIT( 0) -> SLIT("%ax");  ILIT( 1) -> SLIT("%bx");
+	ILIT( 0) -> SLIT("%ax");  ILIT( 1) -> SLIT("%bx");
 	ILIT( 2) -> SLIT("%cx");  ILIT( 3) -> SLIT("%dx");
-        ILIT( 4) -> SLIT("%si");  ILIT( 5) -> SLIT("%di");
+	ILIT( 4) -> SLIT("%si");  ILIT( 5) -> SLIT("%di");
 	ILIT( 6) -> SLIT("%bp");  ILIT( 7) -> SLIT("%sp");
 	_ -> SLIT("very naughty I386 word register")
     })
 
 pprI386Reg L i = uppPStr
     (case i of {
-        ILIT( 0) -> SLIT("%eax");  ILIT( 1) -> SLIT("%ebx");
+	ILIT( 0) -> SLIT("%eax");  ILIT( 1) -> SLIT("%ebx");
 	ILIT( 2) -> SLIT("%ecx");  ILIT( 3) -> SLIT("%edx");
-        ILIT( 4) -> SLIT("%esi");  ILIT( 5) -> SLIT("%edi");
+	ILIT( 4) -> SLIT("%esi");  ILIT( 5) -> SLIT("%edi");
 	ILIT( 6) -> SLIT("%ebp");  ILIT( 7) -> SLIT("%esp");
 	_ -> SLIT("very naughty I386 double word register")
     })
@@ -325,9 +319,9 @@ pprI386Reg L i = uppPStr
 pprI386Reg F i = uppPStr
     (case i of {
 --ToDo: rm these
-        ILIT( 8) -> SLIT("%st(0)");  ILIT( 9) -> SLIT("%st(1)");
+	ILIT( 8) -> SLIT("%st(0)");  ILIT( 9) -> SLIT("%st(1)");
 	ILIT(10) -> SLIT("%st(2)");  ILIT(11) -> SLIT("%st(3)");
-        ILIT(12) -> SLIT("%st(4)");  ILIT(13) -> SLIT("%st(5)");
+	ILIT(12) -> SLIT("%st(4)");  ILIT(13) -> SLIT("%st(5)");
 	ILIT(14) -> SLIT("%st(6)");  ILIT(15) -> SLIT("%st(7)");
 	_ -> SLIT("very naughty I386 float register")
     })
@@ -335,9 +329,9 @@ pprI386Reg F i = uppPStr
 pprI386Reg D i = uppPStr
     (case i of {
 --ToDo: rm these
-        ILIT( 8) -> SLIT("%st(0)");  ILIT( 9) -> SLIT("%st(1)");
+	ILIT( 8) -> SLIT("%st(0)");  ILIT( 9) -> SLIT("%st(1)");
 	ILIT(10) -> SLIT("%st(2)");  ILIT(11) -> SLIT("%st(3)");
-        ILIT(12) -> SLIT("%st(4)");  ILIT(13) -> SLIT("%st(5)");
+	ILIT(12) -> SLIT("%st(4)");  ILIT(13) -> SLIT("%st(5)");
 	ILIT(14) -> SLIT("%st(6)");  ILIT(15) -> SLIT("%st(7)");
 	_ -> SLIT("very naughty I386 float register")
     })
@@ -352,7 +346,7 @@ pprCond x = uppPStr
 	LEU	-> SLIT("be");	NE    -> SLIT("ne");
 	NEG	-> SLIT("s");	POS   -> SLIT("ns");
 	ALWAYS	-> SLIT("mp");	-- hack
-        _       -> error "Spix: iI386Code: unknown conditional!"
+	_       -> error "Spix: iI386Code: unknown conditional!"
     })
 
 pprDollImm :: PprStyle -> Imm -> Unpretty
@@ -374,24 +368,24 @@ pprImm sty (ImmLit s) = s
 pprAddr :: PprStyle -> Addr -> Unpretty
 pprAddr sty (ImmAddr imm off)
   =  uppBesides [pprImm sty imm,
-                 if off > 0 then uppChar '+' else uppPStr SLIT(""),
-                 if off == 0 then uppPStr SLIT("") else uppInt off
-                ]
+		 if off > 0 then uppChar '+' else uppPStr SLIT(""),
+		 if off == 0 then uppPStr SLIT("") else uppInt off
+		]
 pprAddr sty (Addr Nothing Nothing displacement)
   =  uppBesides [pprDisp sty displacement]
 pprAddr sty (Addr base index displacement)
   =  uppBesides [pprDisp sty displacement,
-                 uppChar '(',
-                 pprBase base,
-                 pprIndex index,
-                 uppChar ')'
-                ]
+		 uppChar '(',
+		 pprBase base,
+		 pprIndex index,
+		 uppChar ')'
+		]
   where
     pprBase (Just r) = uppBesides [pprReg L r,
-                                   case index of 
-                                     Nothing -> uppPStr SLIT("")
-                                     _       -> uppChar ','
-                                  ]
+				   case index of
+				     Nothing -> uppPStr SLIT("")
+				     _       -> uppChar ','
+				  ]
     pprBase _        = uppPStr SLIT("")
     pprIndex (Just (r,i)) = uppBesides [pprReg L r, uppChar ',', uppInt i]
     pprIndex _       = uppPStr SLIT("")
@@ -410,7 +404,7 @@ pprSize x = uppPStr
     (case x of
 	B  -> SLIT("b")
 	HB -> SLIT("b")
-        S  -> SLIT("w")
+	S  -> SLIT("w")
 	L  -> SLIT("l")
 	F  -> SLIT("s")
 	D  -> SLIT("l")
@@ -469,7 +463,7 @@ pprSizeAddrReg sty name size op dst =
 	uppChar ' ',
 	pprAddr sty op,
 	uppComma,
-        pprReg size dst
+	pprReg size dst
     ]
 
 pprOpOp :: PprStyle -> FAST_STRING -> Size -> Operand -> Operand -> Unpretty
@@ -499,29 +493,29 @@ pprI386Instr :: PprStyle -> I386Instr -> Unpretty
 pprI386Instr sty (MOV size (OpReg src) (OpReg dst)) -- hack
   | src == dst
   = uppPStr SLIT("")
-pprI386Instr sty (MOV size src dst) 
+pprI386Instr sty (MOV size src dst)
   = pprSizeOpOp sty SLIT("mov") size src dst
 pprI386Instr sty (MOVZX size src dst) = pprSizeOpOpCoerce sty SLIT("movzx") L size src dst
 pprI386Instr sty (MOVSX size src dst) = pprSizeOpOpCoerce sty SLIT("movxs") L size src dst
 
 -- here we do some patching, since the physical registers are only set late
 -- in the code generation.
-pprI386Instr sty (LEA size (OpAddr (Addr src1@(Just reg1) (Just (reg2,1)) (ImmInt 0))) dst@(OpReg reg3)) 
+pprI386Instr sty (LEA size (OpAddr (Addr src1@(Just reg1) (Just (reg2,1)) (ImmInt 0))) dst@(OpReg reg3))
   | reg1 == reg3
   = pprSizeOpOp sty SLIT("add") size (OpReg reg2) dst
-pprI386Instr sty (LEA size (OpAddr (Addr src1@(Just reg1) (Just (reg2,1)) (ImmInt 0))) dst@(OpReg reg3)) 
+pprI386Instr sty (LEA size (OpAddr (Addr src1@(Just reg1) (Just (reg2,1)) (ImmInt 0))) dst@(OpReg reg3))
   | reg2 == reg3
   = pprSizeOpOp sty SLIT("add") size (OpReg reg1) dst
-pprI386Instr sty (LEA size (OpAddr (Addr src1@(Just reg1) Nothing displ)) dst@(OpReg reg3)) 
+pprI386Instr sty (LEA size (OpAddr (Addr src1@(Just reg1) Nothing displ)) dst@(OpReg reg3))
   | reg1 == reg3
   = pprI386Instr sty (ADD size (OpImm displ) dst)
 pprI386Instr sty (LEA size src dst) = pprSizeOpOp sty SLIT("lea") size src dst
 
-pprI386Instr sty (ADD size (OpImm (ImmInt (-1))) dst) 
+pprI386Instr sty (ADD size (OpImm (ImmInt (-1))) dst)
   = pprSizeOp sty SLIT("dec") size dst
-pprI386Instr sty (ADD size (OpImm (ImmInt 1)) dst) 
+pprI386Instr sty (ADD size (OpImm (ImmInt 1)) dst)
   = pprSizeOp sty SLIT("inc") size dst
-pprI386Instr sty (ADD size src dst) 
+pprI386Instr sty (ADD size src dst)
   = pprSizeOpOp sty SLIT("add") size src dst
 pprI386Instr sty (SUB size src dst) = pprSizeOpOp sty SLIT("sub") size src dst
 pprI386Instr sty (IMUL size op1 op2) = pprSizeOpOp sty SLIT("imul") size op1 op2
@@ -557,22 +551,22 @@ pprI386Instr sty (CALL imm) =
 pprI386Instr sty SAHF = uppPStr SLIT("\tsahf")
 pprI386Instr sty FABS = uppPStr SLIT("\tfabs")
 
-pprI386Instr sty (FADD sz src@(OpAddr _)) 
+pprI386Instr sty (FADD sz src@(OpAddr _))
   = uppBesides [uppPStr SLIT("\tfadd"), pprSize sz, uppChar ' ', pprOperand sty sz src]
-pprI386Instr sty (FADD sz src) 
+pprI386Instr sty (FADD sz src)
   = uppPStr SLIT("\tfadd")
-pprI386Instr sty FADDP 
+pprI386Instr sty FADDP
   = uppPStr SLIT("\tfaddp")
-pprI386Instr sty (FMUL sz src) 
+pprI386Instr sty (FMUL sz src)
   = uppBesides [uppPStr SLIT("\tfmul"), pprSize sz, uppChar ' ', pprOperand sty sz src]
-pprI386Instr sty FMULP 
+pprI386Instr sty FMULP
   = uppPStr SLIT("\tfmulp")
 pprI386Instr sty (FIADD size op) = pprSizeAddr sty SLIT("fiadd") size op
 pprI386Instr sty FCHS = uppPStr SLIT("\tfchs")
 pprI386Instr sty (FCOM size op) = pprSizeOp sty SLIT("fcom") size op
 pprI386Instr sty FCOS = uppPStr SLIT("\tfcos")
 pprI386Instr sty (FIDIV size op) = pprSizeAddr sty SLIT("fidiv") size op
-pprI386Instr sty (FDIV sz src) 
+pprI386Instr sty (FDIV sz src)
   = uppBesides [uppPStr SLIT("\tfdiv"), pprSize sz, uppChar ' ', pprOperand sty sz src]
 pprI386Instr sty FDIVP
   = uppPStr SLIT("\tfdivp")
@@ -584,9 +578,9 @@ pprI386Instr sty (FIDIVR size op) = pprSizeAddr sty SLIT("fidivr") size op
 pprI386Instr sty (FICOM size op) = pprSizeAddr sty SLIT("ficom") size op
 pprI386Instr sty (FILD sz op reg) = pprSizeAddrReg sty SLIT("fild") sz op reg
 pprI386Instr sty (FIST size op) = pprSizeAddr sty SLIT("fist") size op
-pprI386Instr sty (FLD sz (OpImm (ImmCLbl src))) 
+pprI386Instr sty (FLD sz (OpImm (ImmCLbl src)))
   = uppBesides [uppPStr SLIT("\tfld"),pprSize sz,uppChar ' ',pprCLabel sty src]
-pprI386Instr sty (FLD sz src) 
+pprI386Instr sty (FLD sz src)
   = uppBesides [uppPStr SLIT("\tfld"),pprSize sz,uppChar ' ',pprOperand sty sz src]
 pprI386Instr sty FLD1 = uppPStr SLIT("\tfld1")
 pprI386Instr sty FLDZ = uppPStr SLIT("\tfldz")
@@ -594,12 +588,12 @@ pprI386Instr sty (FIMUL size op) = pprSizeAddr sty SLIT("fimul") size op
 pprI386Instr sty FRNDINT = uppPStr SLIT("\tfrndint")
 pprI386Instr sty FSIN = uppPStr SLIT("\tfsin")
 pprI386Instr sty FSQRT = uppPStr SLIT("\tfsqrt")
-pprI386Instr sty (FST sz dst) 
+pprI386Instr sty (FST sz dst)
   = uppBesides [uppPStr SLIT("\tfst"), pprSize sz, uppChar ' ', pprOperand sty sz dst]
-pprI386Instr sty (FSTP sz dst) 
+pprI386Instr sty (FSTP sz dst)
   = uppBesides [uppPStr SLIT("\tfstp"), pprSize sz, uppChar ' ', pprOperand sty sz dst]
 pprI386Instr sty (FISUB size op) = pprSizeAddr sty SLIT("fisub") size op
-pprI386Instr sty (FSUB sz src) 
+pprI386Instr sty (FSUB sz src)
   = uppBesides [uppPStr SLIT("\tfsub"), pprSize sz, uppChar ' ', pprOperand sty sz src]
 pprI386Instr sty FSUBP
   = uppPStr SLIT("\tfsubp")
@@ -607,10 +601,10 @@ pprI386Instr sty (FSUBR size src)
   = pprSizeOp sty SLIT("fsubr") size src
 pprI386Instr sty FSUBRP
   = uppPStr SLIT("\tfsubpr")
-pprI386Instr sty (FISUBR size op) 
+pprI386Instr sty (FISUBR size op)
   = pprSizeAddr sty SLIT("fisubr") size op
 pprI386Instr sty FTST = uppPStr SLIT("\tftst")
-pprI386Instr sty (FCOMP sz op) 
+pprI386Instr sty (FCOMP sz op)
   = uppBesides [uppPStr SLIT("\tfcomp"), pprSize sz, uppChar ' ', pprOperand sty sz op]
 pprI386Instr sty FUCOMPP = uppPStr SLIT("\tfucompp")
 pprI386Instr sty FXCH = uppPStr SLIT("\tfxch")
@@ -648,9 +642,9 @@ pprI386Instr sty (ASCII True str) = uppBeside (uppStr "\t.ascii \"") (asciify st
     	asciify :: String -> Int -> Unpretty
     	asciify [] _ = uppStr ("\\0\"")
     	asciify s n | n <= 0 = uppBeside (uppStr "\"\n\t.ascii \"") (asciify s 60)
-        asciify ('\\':cs) n = uppBeside (uppStr "\\\\") (asciify cs (n-1))
-        asciify ('\"':cs) n = uppBeside (uppStr "\\\"") (asciify cs (n-1))
-        asciify (c:cs) n | isPrint c = uppBeside (uppChar c) (asciify cs (n-1))
+	asciify ('\\':cs) n = uppBeside (uppStr "\\\\") (asciify cs (n-1))
+	asciify ('\"':cs) n = uppBeside (uppStr "\\\"") (asciify cs (n-1))
+	asciify (c:cs) n | isPrint c = uppBeside (uppChar c) (asciify cs (n-1))
     	asciify [c] _ = uppBeside (uppStr (charToC c)) (uppStr ("\\0\""))
     	asciify (c:(cs@(d:_))) n | isDigit d =
     	    	    	    	    	uppBeside (uppStr (charToC c)) (asciify cs 0)
@@ -684,8 +678,8 @@ instance MachineRegisters I386Regs where
     	(ints, floats) = partition (< 8) xs
     	floats' = map (subtract 8) floats
 
-    possibleMRegs FloatKind (SRegs _ floats) = [ x + 8 | x <- listBS floats]
-    possibleMRegs DoubleKind (SRegs _ floats) = [ x + 8 | x <- listBS floats]
+    possibleMRegs FloatRep (SRegs _ floats) = [ x + 8 | x <- listBS floats]
+    possibleMRegs DoubleRep (SRegs _ floats) = [ x + 8 | x <- listBS floats]
     possibleMRegs _ (SRegs ints _) = listBS ints
 
     useMReg (SRegs ints floats) n =
@@ -696,60 +690,55 @@ instance MachineRegisters I386Regs where
     	SRegs (ints `minusBS` ints')
     	      (floats `minusBS` floats')
       where
-        SRegs ints' floats' = mkMRegs xs
+	SRegs ints' floats' = mkMRegs xs
 
     freeMReg (SRegs ints floats) n =
     	if n _LT_ ILIT(8) then SRegs (ints `unionBS` singletonBS IBOX(n)) floats
     	else SRegs ints (floats `unionBS` singletonBS (IBOX(n _SUB_ ILIT(8))))
 
     freeMRegs (SRegs ints floats) xs =
-        SRegs (ints `unionBS` ints')
+	SRegs (ints `unionBS` ints')
     	      (floats `unionBS` floats')
       where
-        SRegs ints' floats' = mkMRegs xs
+	SRegs ints' floats' = mkMRegs xs
 
 instance MachineCode I386Instr where
-    -- Alas, we don't do anything clever with our OrdLists
---OLD:
---  flatten = flattenOrdList
-
     regUsage = i386RegUsage
     regLiveness = i386RegLiveness
     patchRegs = i386PatchRegs
 
     -- We spill just below the stack pointer, leaving two words per spill location.
-    spillReg dyn (MemoryReg i pk) 
+    spillReg dyn (MemoryReg i pk)
       = trace "spillsave"
-        (mkUnitList (MOV (kindToSize pk) (OpReg dyn) (OpAddr (spRel (-2 * i)))))
-    loadReg (MemoryReg i pk) dyn 
+	(mkUnitList (MOV (kindToSize pk) (OpReg dyn) (OpAddr (spRel (-2 * i)))))
+    loadReg (MemoryReg i pk) dyn
       = trace "spillload"
-        (mkUnitList (MOV (kindToSize pk) (OpAddr (spRel (-2 * i))) (OpReg dyn)))
+	(mkUnitList (MOV (kindToSize pk) (OpAddr (spRel (-2 * i))) (OpReg dyn)))
 
 --spRel gives us a stack relative addressing mode for volatile temporaries
 --and for excess call arguments.
 
-spRel  
+spRel
     :: Int      -- desired stack offset in words, positive or negative
     -> Addr
 spRel n = Addr (Just esp) Nothing (ImmInt (n * 4))
 
-kindToSize :: PrimKind -> Size
-kindToSize PtrKind	    = L
-kindToSize CodePtrKind	    = L
-kindToSize DataPtrKind	    = L
-kindToSize RetKind	    = L
-kindToSize InfoPtrKind	    = L
-kindToSize CostCentreKind   = L
-kindToSize CharKind	    = L
-kindToSize IntKind	    = L
-kindToSize WordKind	    = L
-kindToSize AddrKind	    = L
-kindToSize FloatKind	    = F
-kindToSize DoubleKind	    = D
-kindToSize ArrayKind	    = L
-kindToSize ByteArrayKind    = L
-kindToSize StablePtrKind    = L
-kindToSize MallocPtrKind    = L
+kindToSize :: PrimRep -> Size
+kindToSize PtrRep	    = L
+kindToSize CodePtrRep	    = L
+kindToSize DataPtrRep	    = L
+kindToSize RetRep	    = L
+kindToSize CostCentreRep   = L
+kindToSize CharRep	    = L
+kindToSize IntRep	    = L
+kindToSize WordRep	    = L
+kindToSize AddrRep	    = L
+kindToSize FloatRep	    = F
+kindToSize DoubleRep	    = D
+kindToSize ArrayRep	    = L
+kindToSize ByteArrayRep    = L
+kindToSize StablePtrRep    = L
+kindToSize MallocPtrRep    = L
 
 \end{code}
 
@@ -843,7 +832,7 @@ i386RegUsage instr = case instr of
     usage1 (OpAddr ea)    = usage (addrToRegs ea) []
     allFPRegs = [st0,st1,st2,st3,st4,st5,st6,st7]
     --callClobberedRegs = [ eax, ecx, edx ] -- according to gcc, anyway.
-    callClobberedRegs = [eax] 
+    callClobberedRegs = [eax]
 
 -- General purpose register collecting functions.
 
@@ -853,9 +842,9 @@ i386RegUsage instr = case instr of
 
     addrToRegs (Addr base index _) = baseToReg base ++ indexToReg index
       where  baseToReg Nothing       = []
-             baseToReg (Just r)      = [r]
-             indexToReg Nothing      = []
-             indexToReg (Just (r,_)) = [r]
+	     baseToReg (Just r)      = [r]
+	     indexToReg Nothing      = []
+	     indexToReg (Just (r,_)) = [r]
     addrToRegs (ImmAddr _ _) = []
 
     usage src dst = RU (mkUniqSet (filter interesting src))
@@ -910,7 +899,7 @@ i386RegLiveness instr info@(RL live future@(FL all env)) = case instr of
     lookup lbl = case lookupFM env lbl of
 	Just regs -> regs
 	Nothing -> trace ("Missing " ++ (uppShow 80 (pprCLabel (PprForAsm (\_->False) False id) lbl)) ++
-                          " in future?") emptyUniqSet
+			  " in future?") emptyUniqSet
 
 \end{code}
 
@@ -928,7 +917,7 @@ i386PatchRegs instr env = case instr of
     ADD  sz src dst	-> patch2 (ADD  sz) src dst
     SUB  sz src dst	-> patch2 (SUB  sz) src dst
     IMUL sz src dst 	-> patch2 (IMUL sz) src dst
-    IDIV sz src  	-> patch1 (IDIV sz) src 
+    IDIV sz src  	-> patch1 (IDIV sz) src
     AND  sz src dst	-> patch2 (AND  sz) src dst
     OR   sz src dst	-> patch2 (OR   sz) src dst
     XOR  sz src dst	-> patch2 (XOR  sz) src dst
@@ -969,7 +958,7 @@ i386PatchRegs instr env = case instr of
     FISUBR sz asrc	-> FISUBR sz (lookupAddr asrc)
     FCOMP sz src	-> FCOMP sz (patchOp src)
     _			-> instr
-	
+
   where
 		patch1 insn op = insn (patchOp op)
 		patch2 insn src dst = insn (patchOp src) (patchOp dst)
@@ -978,13 +967,13 @@ i386PatchRegs instr env = case instr of
 		patchOp (OpImm  imm) = OpImm imm
 		patchOp (OpAddr ea)  = OpAddr (lookupAddr ea)
 
-		lookupAddr (Addr base index disp) 
+		lookupAddr (Addr base index disp)
 			= Addr (lookupBase base) (lookupIndex index) disp
 			where lookupBase Nothing        = Nothing
  	      		      lookupBase (Just r)       = Just (env r)
 	      		      lookupIndex Nothing       = Nothing
 	      		      lookupIndex (Just (r,i))  = Just (env r, i)
-		lookupAddr (ImmAddr imm off) 
+		lookupAddr (ImmAddr imm off)
 			= ImmAddr imm off
 
 \end{code}
@@ -993,9 +982,6 @@ Sometimes, we want to be able to modify addresses at compile time.
 (Okay, just for chrCode of a fetch.)
 
 \begin{code}
-
-#ifdef __GLASGOW_HASKELL__
-
 {-# SPECIALIZE
     is13Bits :: Int -> Bool
   #-}
@@ -1003,8 +989,6 @@ Sometimes, we want to be able to modify addresses at compile time.
     is13Bits :: Integer -> Bool
   #-}
 
-#endif
-
 is13Bits :: Integral a => a -> Bool
 is13Bits x = x >= -4096 && x < 4096
 
@@ -1022,7 +1006,6 @@ offset (ImmAddr imm off1) off2
   where off3 = off1 + off2
 
 offset _ _ = Nothing
-
 \end{code}
 
 If you value your sanity, do not venture below this line.
@@ -1054,7 +1037,7 @@ If you value your sanity, do not venture below this line.
 #define st5 13
 #define st6 14
 #define st7 15
-#define CALLER_SAVES_Hp 
+#define CALLER_SAVES_Hp
 -- ToDo: rm when we give esp back
 #define REG_Hp esp
 #define REG_R2 ecx
@@ -1160,7 +1143,7 @@ callerSaves SpB	    	    	= True
 #ifdef CALLER_SAVES_SuB
 callerSaves SuB	    	    	= True
 #endif
-#ifdef CALLER_SAVES_Hp 
+#ifdef CALLER_SAVES_Hp
 callerSaves Hp	    	    	= True
 #endif
 #ifdef CALLER_SAVES_HpLim
@@ -1248,7 +1231,7 @@ stgRegMap SpB	    	   = Just (FixedReg ILIT(REG_SpB))
 #ifdef REG_SuB
 stgRegMap SuB	    	   = Just (FixedReg ILIT(REG_SuB))
 #endif
-#ifdef REG_Hp 
+#ifdef REG_Hp
 stgRegMap Hp	    	   = Just (FixedReg ILIT(REG_Hp))
 #endif
 #ifdef REG_HpLim
diff --git a/ghc/compiler/nativeGen/I386Desc.hi b/ghc/compiler/nativeGen/I386Desc.hi
deleted file mode 100644
index ef711c7e58..0000000000
--- a/ghc/compiler/nativeGen/I386Desc.hi
+++ /dev/null
@@ -1,25 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface I386Desc where
-import AbsCSyn(MagicId)
-import CLabelInfo(CLabel)
-import CharSeq(CSeq)
-import CmdLineOpts(GlobalSwitch, SwitchResult)
-import MachDesc(RegLoc, Target)
-import PreludePS(_PackedString)
-import PreludeRatio(Ratio(..))
-import Pretty(PprStyle)
-import PrimKind(PrimKind)
-import PrimOps(PrimOp)
-import SMRep(SMRep, SMSpecRepKind, SMUpdateKind)
-import SplitUniq(SplitUniqSupply)
-import Stix(CodeSegment, StixReg, StixTree)
-data MagicId 	{-# GHC_PRAGMA BaseReg | StkOReg | VanillaReg PrimKind Int# | FloatReg Int# | DoubleReg Int# | TagReg | RetReg | SpA | SuA | SpB | SuB | Hp | HpLim | LivenessReg | ActivityReg | StdUpdRetVecReg | StkStubReg | CurCostCentre | VoidReg #-}
-data SwitchResult 	{-# GHC_PRAGMA SwBool Bool | SwString [Char] | SwInt Int #-}
-data RegLoc 	{-# GHC_PRAGMA Save StixTree | Always StixTree #-}
-data PprStyle 	{-# GHC_PRAGMA PprForUser | PprDebug | PprShowAll | PprInterface (GlobalSwitch -> Bool) | PprForC (GlobalSwitch -> Bool) | PprUnfolding (GlobalSwitch -> Bool) | PprForAsm (GlobalSwitch -> Bool) Bool ([Char] -> [Char]) #-}
-data PrimKind 	{-# GHC_PRAGMA PtrKind | CodePtrKind | DataPtrKind | RetKind | InfoPtrKind | CostCentreKind | CharKind | IntKind | WordKind | AddrKind | FloatKind | DoubleKind | MallocPtrKind | StablePtrKind | ArrayKind | ByteArrayKind | VoidKind #-}
-data SMRep 	{-# GHC_PRAGMA StaticRep Int Int | SpecialisedRep SMSpecRepKind Int Int SMUpdateKind | GenericRep Int Int SMUpdateKind | BigTupleRep Int | DataRep Int | DynamicRep | BlackHoleRep | PhantomRep | MuTupleRep Int #-}
-data StixTree 	{-# GHC_PRAGMA StSegment CodeSegment | StInt Integer | StDouble (Ratio Integer) | StString _PackedString | StLitLbl CSeq | StLitLit _PackedString | StCLbl CLabel | StReg StixReg | StIndex PrimKind StixTree StixTree | StInd PrimKind StixTree | StAssign PrimKind StixTree StixTree | StLabel CLabel | StFunBegin CLabel | StFunEnd CLabel | StJump StixTree | StFallThrough CLabel | StCondJump CLabel StixTree | StData PrimKind [StixTree] | StPrim PrimOp [StixTree] | StCall _PackedString PrimKind [StixTree] | StComment _PackedString #-}
-mkI386 :: Bool -> (GlobalSwitch -> SwitchResult) -> (Target, PprStyle -> [[StixTree]] -> SplitUniqSupply -> CSeq, Bool, [Char] -> [Char])
-	{-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _N_ _N_ _N_ #-}
-
diff --git a/ghc/compiler/nativeGen/I386Desc.lhs b/ghc/compiler/nativeGen/I386Desc.lhs
index 402cdc0f87..b7b32332b3 100644
--- a/ghc/compiler/nativeGen/I386Desc.lhs
+++ b/ghc/compiler/nativeGen/I386Desc.lhs
@@ -7,40 +7,34 @@
 #include "HsVersions.h"
 
 module I386Desc (
-    	mkI386,
+    	mkI386
 
     	-- and assorted nonsense referenced by the class methods
-
-        PprStyle, SMRep, MagicId, RegLoc, StixTree, PrimKind, SwitchResult
-
     ) where
 
 import AbsCSyn
-import AbsPrel	    ( PrimOp(..)
+import PrelInfo	    ( PrimOp(..)
 		      IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
 			  IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
 		    )
 import AsmRegAlloc  ( Reg, MachineCode(..), MachineRegisters(..),
 		      RegLiveness(..), RegUsage(..), FutureLive(..)
 		    )
-import CLabelInfo   ( CLabel )
+import CLabel   ( CLabel )
 import CmdLineOpts  ( GlobalSwitch(..), stringSwitchSet, switchIsOn, SwitchResult(..) )
 import HeapOffs	    ( hpRelToInt )
 import MachDesc
 import Maybes	    ( Maybe(..) )
 import OrdList
 import Outputable
-import PrimKind	    ( PrimKind(..) )
 import SMRep	    ( SMRep(..), SMSpecRepKind(..), SMUpdateKind(..) )
 import I386Code
 import I386Gen	    ( i386CodeGen )
 import Stix
 import StixMacro
 import StixPrim
-import SplitUniq
-import Unique
+import UniqSupply
 import Util
-
 \end{code}
 
 Header sizes depend only on command-line options, not on the target
@@ -87,11 +81,11 @@ i386Reg switches x =
     	    StkStubReg -> sStLitLbl SLIT("STK_STUB_closure")
     	    StdUpdRetVecReg -> sStLitLbl SLIT("vtbl_StdUpdFrame")
     	    BaseReg -> sStLitLbl SLIT("MainRegTable")
-    	    --Hp -> StInd PtrKind (sStLitLbl SLIT("StorageMgrInfo"))
-    	    --HpLim -> StInd PtrKind (sStLitLbl SLIT("StorageMgrInfo+4"))
-    	    TagReg -> StInd IntKind (StPrim IntSubOp [infoptr, StInt (1*4)])
-    	    	      where 
-    	    	    	  r2 = VanillaReg PtrKind ILIT(2)
+    	    --Hp -> StInd PtrRep (sStLitLbl SLIT("StorageMgrInfo"))
+    	    --HpLim -> StInd PtrRep (sStLitLbl SLIT("StorageMgrInfo+4"))
+    	    TagReg -> StInd IntRep (StPrim IntSubOp [infoptr, StInt (1*4)])
+    	    	      where
+    	    	    	  r2 = VanillaReg PtrRep ILIT(2)
     	    	    	  infoptr = case i386Reg switches r2 of
     	    	    	    	    	Always tree -> tree
     	    	    	    	    	Save _ -> StReg (StixMagicId r2)
@@ -100,8 +94,8 @@ i386Reg switches x =
     	  baseLoc = case stgRegMap BaseReg of
     	    Just _ -> StReg (StixMagicId BaseReg)
     	    Nothing -> sStLitLbl SLIT("MainRegTable")
-          offset = baseRegOffset x
-		    
+	  offset = baseRegOffset x
+
 \end{code}
 
 Sizes in bytes.
@@ -119,20 +113,20 @@ because some are reloaded from constants.
 
 \begin{code}
 
-vsaves switches vols = 
+vsaves switches vols =
     map save ((filter callerSaves) ([BaseReg,SpA,SuA,SpB,SuB,Hp,HpLim,RetReg{-,ActivityReg-}] ++ vols))
     where
-        save x = StAssign (kindFromMagicId x) loc reg
+	save x = StAssign (kindFromMagicId x) loc reg
     	    	    where reg = StReg (StixMagicId x)
     	    	    	  loc = case i386Reg switches x of
     	    	    	    	    Save loc -> loc
     	    	    	    	    Always loc -> panic "vsaves"
 
-vrests switches vols = 
-    map restore ((filter callerSaves) 
+vrests switches vols =
+    map restore ((filter callerSaves)
     	([BaseReg,SpA,SuA,SpB,SuB,Hp,HpLim,RetReg{-,ActivityReg-},StkStubReg,StdUpdRetVecReg] ++ vols))
     where
-        restore x = StAssign (kindFromMagicId x) reg loc
+	restore x = StAssign (kindFromMagicId x) reg loc
     	    	    where reg = StReg (StixMagicId x)
     	    	    	  loc = case i386Reg switches x of
     	    	    	    	    Save loc -> loc
@@ -146,22 +140,22 @@ Static closure sizes.
 
 charLikeSize, intLikeSize :: Target -> Int
 
-charLikeSize target = 
-    size PtrKind * (fixedHeaderSize target + varHeaderSize target charLikeRep + 1)
+charLikeSize target =
+    size PtrRep * (fixedHeaderSize target + varHeaderSize target charLikeRep + 1)
     where charLikeRep = SpecialisedRep CharLikeRep 0 1 SMNormalForm
 
-intLikeSize target = 
-    size PtrKind * (fixedHeaderSize target + varHeaderSize target intLikeRep + 1)
+intLikeSize target =
+    size PtrRep * (fixedHeaderSize target + varHeaderSize target intLikeRep + 1)
     where intLikeRep = SpecialisedRep IntLikeRep 0 1 SMNormalForm
 
 mhs, dhs :: (GlobalSwitch -> SwitchResult) -> StixTree
 
 mhs switches = StInt (toInteger words)
-  where 
+  where
     words = fhs switches + vhs switches (MuTupleRep 0)
 
 dhs switches = StInt (toInteger words)
-  where 
+  where
     words = fhs switches + vhs switches (DataRep 0)
 
 \end{code}
@@ -172,26 +166,26 @@ Setting up a i386 target.
 mkI386 :: Bool
 	-> (GlobalSwitch -> SwitchResult)
 	-> (Target,
-	    (PprStyle -> [[StixTree]] -> SUniqSM Unpretty), -- codeGen
+	    (PprStyle -> [[StixTree]] -> UniqSM Unpretty), -- codeGen
 	    Bool,					    -- underscore
 	    (String -> String))				    -- fmtAsmLbl
 
-mkI386 decentOS switches = 
+mkI386 decentOS switches =
     let fhs' = fhs switches
     	vhs' = vhs switches
     	i386Reg' = i386Reg switches
     	vsaves' = vsaves switches
     	vrests' = vrests switches
-    	hprel = hpRelToInt target 
-        as = amodeCode target
-        as' = amodeCode' target
+    	hprel = hpRelToInt target
+	as = amodeCode target
+	as' = amodeCode' target
     	csz = charLikeSize target
     	isz = intLikeSize target
     	mhs' = mhs switches
     	dhs' = dhs switches
     	ps = genPrimCode target
     	mc = genMacroCode target
-    	hc = doHeapCheck --UNUSED NOW: target
+    	hc = doHeapCheck
     	target = mkTarget {-switches-} fhs' vhs' i386Reg' {-id-} size
     	    	    	  hprel as as'
 			  (vsaves', vrests', csz, isz, mhs', dhs', ps, mc, hc)
@@ -199,6 +193,6 @@ mkI386 decentOS switches =
     in
     (target, i386CodeGen, decentOS, id)
 \end{code}
-            
+
 
 
diff --git a/ghc/compiler/nativeGen/I386Gen.hi b/ghc/compiler/nativeGen/I386Gen.hi
deleted file mode 100644
index 41a8681477..0000000000
--- a/ghc/compiler/nativeGen/I386Gen.hi
+++ /dev/null
@@ -1,18 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface I386Gen where
-import CLabelInfo(CLabel)
-import CharSeq(CSeq)
-import CmdLineOpts(GlobalSwitch)
-import PreludePS(_PackedString)
-import PreludeRatio(Ratio(..))
-import Pretty(PprStyle)
-import PrimKind(PrimKind)
-import PrimOps(PrimOp)
-import SplitUniq(SplitUniqSupply)
-import Stix(CodeSegment, StixReg, StixTree)
-data CSeq 	{-# GHC_PRAGMA CNil | CAppend CSeq CSeq | CIndent Int CSeq | CNewline | CStr [Char] | CCh Char | CInt Int | CPStr _PackedString #-}
-data PprStyle 	{-# GHC_PRAGMA PprForUser | PprDebug | PprShowAll | PprInterface (GlobalSwitch -> Bool) | PprForC (GlobalSwitch -> Bool) | PprUnfolding (GlobalSwitch -> Bool) | PprForAsm (GlobalSwitch -> Bool) Bool ([Char] -> [Char]) #-}
-data StixTree 	{-# GHC_PRAGMA StSegment CodeSegment | StInt Integer | StDouble (Ratio Integer) | StString _PackedString | StLitLbl CSeq | StLitLit _PackedString | StCLbl CLabel | StReg StixReg | StIndex PrimKind StixTree StixTree | StInd PrimKind StixTree | StAssign PrimKind StixTree StixTree | StLabel CLabel | StFunBegin CLabel | StFunEnd CLabel | StJump StixTree | StFallThrough CLabel | StCondJump CLabel StixTree | StData PrimKind [StixTree] | StPrim PrimOp [StixTree] | StCall _PackedString PrimKind [StixTree] | StComment _PackedString #-}
-i386CodeGen :: PprStyle -> [[StixTree]] -> SplitUniqSupply -> CSeq
-	{-# GHC_PRAGMA _A_ 2 _U_ 211 _N_ _S_ "LS" _N_ _N_ #-}
-
diff --git a/ghc/compiler/nativeGen/I386Gen.lhs b/ghc/compiler/nativeGen/I386Gen.lhs
index 8f0d191b2c..0edbba123e 100644
--- a/ghc/compiler/nativeGen/I386Gen.lhs
+++ b/ghc/compiler/nativeGen/I386Gen.lhs
@@ -16,31 +16,28 @@ module I386Gen (
 IMPORT_Trace
 
 import AbsCSyn	    ( AbstractC, MagicId(..), kindFromMagicId )
-import AbsPrel	    ( PrimOp(..)
+import PrelInfo	    ( PrimOp(..)
 		      IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
 			  IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
 		    )
 import AsmRegAlloc  ( runRegAllocate, mkReg, extractMappedRegNos,
-		      Reg(..), RegLiveness(..), RegUsage(..), 
+		      Reg(..), RegLiveness(..), RegUsage(..),
     	    	      FutureLive(..), MachineRegisters(..), MachineCode(..)
     	    	    )
-import CLabelInfo   ( CLabel, isAsmTemp )
+import CLabel   ( CLabel, isAsmTemp )
 import I386Code    {- everything -}
 import MachDesc
 import Maybes	    ( maybeToBool, Maybe(..) )
 import OrdList	    -- ( mkEmptyList, mkUnitList, mkSeqList, mkParList, OrdList )
 import Outputable
-import PrimKind	    ( PrimKind(..), isFloatingKind )
 import I386Desc
 import Stix
-import SplitUniq
-import Unique
+import UniqSupply
 import Pretty
 import Unpretty
 import Util
 
 type CodeBlock a = (OrdList a -> OrdList a)
-
 \end{code}
 
 %************************************************************************
@@ -53,14 +50,14 @@ This is the top-level code-generation function for the I386.
 
 \begin{code}
 
-i386CodeGen :: PprStyle -> [[StixTree]] -> SUniqSM Unpretty
-i386CodeGen sty trees = 
-    mapSUs genI386Code trees	    	`thenSUs` \ dynamicCodes ->
+i386CodeGen :: PprStyle -> [[StixTree]] -> UniqSM Unpretty
+i386CodeGen sty trees =
+    mapUs genI386Code trees	    	`thenUs` \ dynamicCodes ->
     let
     	staticCodes = scheduleI386Code dynamicCodes
     	pretty = printLabeledCodes sty staticCodes
     in
-    	returnSUs pretty
+    	returnUs pretty
 
 \end{code}
 
@@ -86,9 +83,9 @@ register to put it in.
 
 \begin{code}
 
-data Register 
-  = Fixed Reg PrimKind (CodeBlock I386Instr) 
-  | Any PrimKind (Reg -> (CodeBlock I386Instr))
+data Register
+  = Fixed Reg PrimRep (CodeBlock I386Instr)
+  | Any PrimRep (Reg -> (CodeBlock I386Instr))
 
 registerCode :: Register -> Reg -> CodeBlock I386Instr
 registerCode (Fixed _ _ code) reg = code
@@ -98,7 +95,7 @@ registerName :: Register -> Reg -> Reg
 registerName (Fixed reg _ _) _ = reg
 registerName (Any _ _) reg = reg
 
-registerKind :: Register -> PrimKind
+registerKind :: Register -> PrimRep
 registerKind (Fixed _ pk _) = pk
 registerKind (Any pk _) = pk
 
@@ -147,14 +144,14 @@ asmSeq is = foldr (mkSeqList . asmInstr) asmVoid is
 asmParThen :: [I386Code] -> (CodeBlock I386Instr)
 asmParThen others code = mkSeqList (foldr mkParList mkEmptyList others) code
 
-returnInstr :: I386Instr -> SUniqSM (CodeBlock I386Instr)
-returnInstr instr = returnSUs (\xs -> mkSeqList (asmInstr instr) xs)
+returnInstr :: I386Instr -> UniqSM (CodeBlock I386Instr)
+returnInstr instr = returnUs (\xs -> mkSeqList (asmInstr instr) xs)
 
-returnInstrs :: [I386Instr] -> SUniqSM (CodeBlock I386Instr)
-returnInstrs instrs = returnSUs (\xs -> mkSeqList (asmSeq instrs) xs)
+returnInstrs :: [I386Instr] -> UniqSM (CodeBlock I386Instr)
+returnInstrs instrs = returnUs (\xs -> mkSeqList (asmSeq instrs) xs)
 
-returnSeq :: (CodeBlock I386Instr) -> [I386Instr] -> SUniqSM (CodeBlock I386Instr)
-returnSeq code instrs = returnSUs (\xs -> code (mkSeqList (asmSeq instrs) xs))
+returnSeq :: (CodeBlock I386Instr) -> [I386Instr] -> UniqSM (CodeBlock I386Instr)
+returnSeq code instrs = returnUs (\xs -> code (mkSeqList (asmSeq instrs) xs))
 
 mkSeqInstr :: I386Instr -> (CodeBlock I386Instr)
 mkSeqInstr instr code = mkSeqList (asmInstr instr) code
@@ -168,11 +165,11 @@ Top level i386 code generator for a chunk of stix code.
 
 \begin{code}
 
-genI386Code :: [StixTree] -> SUniqSM (I386Code)
+genI386Code :: [StixTree] -> UniqSM (I386Code)
 
 genI386Code trees =
-    mapSUs getCode trees    	    	`thenSUs` \ blocks ->
-    returnSUs (foldr (.) id blocks asmVoid)
+    mapUs getCode trees    	    	`thenUs` \ blocks ->
+    returnUs (foldr (.) id blocks asmVoid)
 
 \end{code}
 
@@ -180,50 +177,44 @@ Code extractor for an entire stix tree---stix statement level.
 
 \begin{code}
 
-getCode 
+getCode
     :: StixTree     -- a stix statement
-    -> SUniqSM (CodeBlock I386Instr)
+    -> UniqSM (CodeBlock I386Instr)
 
 getCode (StSegment seg) = returnInstr (SEGMENT seg)
 
 getCode (StAssign pk dst src)
-  | isFloatingKind pk = assignFltCode pk dst src
+  | isFloatingRep pk = assignFltCode pk dst src
   | otherwise = assignIntCode pk dst src
 
 getCode (StLabel lab) = returnInstr (LABEL lab)
 
 getCode (StFunBegin lab) = returnInstr (LABEL lab)
 
-getCode (StFunEnd lab) = returnSUs id
+getCode (StFunEnd lab) = returnUs id
 
 getCode (StJump arg) = genJump arg
 
-getCode (StFallThrough lbl) = returnSUs id
+getCode (StFallThrough lbl) = returnUs id
 
 getCode (StCondJump lbl arg) = genCondJump lbl arg
 
-getCode (StData kind args) = 
-    mapAndUnzipSUs getData args		    `thenSUs` \ (codes, imms) ->
-    returnSUs (\xs -> mkSeqList (asmInstr (DATA (kindToSize kind) imms))
-                                (foldr1 (.) codes xs))
+getCode (StData kind args) =
+    mapAndUnzipUs getData args		    `thenUs` \ (codes, imms) ->
+    returnUs (\xs -> mkSeqList (asmInstr (DATA (kindToSize kind) imms))
+				(foldr1 (.) codes xs))
   where
-    getData :: StixTree -> SUniqSM (CodeBlock I386Instr, Imm)
-    getData (StInt i) = returnSUs (id, ImmInteger i)
-#if __GLASGOW_HASKELL__ >= 23
---  getData (StDouble d) = returnSUs (id, strImmLit ('0' : 'd' : _showRational 30 d))
-    -- yurgh (WDP 94/12)
-    getData (StDouble d) = returnSUs (id, strImmLit ('0' : 'd' : ppShow 80 (ppRational d)))
-#else
-    getData (StDouble d) = returnSUs (id, strImmLit ('0' : 'd' : show d))
-#endif
-    getData (StLitLbl s) = returnSUs (id, ImmLit (uppBeside (uppChar '_') s))
-    getData (StLitLit s) = returnSUs (id, strImmLit (cvtLitLit (_UNPK_ s)))
-    getData (StString s) = 
-        getUniqLabelNCG 	    	    `thenSUs` \ lbl ->
-	returnSUs (mkSeqInstrs [LABEL lbl, ASCII True (_UNPK_ s)], ImmCLbl lbl)
-    getData (StCLbl l)   = returnSUs (id, ImmCLbl l)
-
-getCode (StCall fn VoidKind args) = genCCall fn VoidKind args
+    getData :: StixTree -> UniqSM (CodeBlock I386Instr, Imm)
+    getData (StInt i) = returnUs (id, ImmInteger i)
+    getData (StDouble d) = returnUs (id, strImmLit ('0' : 'd' : ppShow 80 (ppRational d)))
+    getData (StLitLbl s) = returnUs (id, ImmLit (uppBeside (uppChar '_') s))
+    getData (StLitLit s) = returnUs (id, strImmLit (cvtLitLit (_UNPK_ s)))
+    getData (StString s) =
+	getUniqLabelNCG 	    	    `thenUs` \ lbl ->
+	returnUs (mkSeqInstrs [LABEL lbl, ASCII True (_UNPK_ s)], ImmCLbl lbl)
+    getData (StCLbl l)   = returnUs (id, ImmCLbl l)
+
+getCode (StCall fn VoidRep args) = genCCall fn VoidRep args
 
 getCode (StComment s) = returnInstr (COMMENT s)
 
@@ -233,47 +224,42 @@ Generate code to get a subtree into a register.
 
 \begin{code}
 
-getReg :: StixTree -> SUniqSM Register
+getReg :: StixTree -> UniqSM Register
 
 getReg (StReg (StixMagicId stgreg)) =
     case stgRegMap stgreg of
-    	Just reg -> returnSUs (Fixed reg (kindFromMagicId stgreg) id)
+    	Just reg -> returnUs (Fixed reg (kindFromMagicId stgreg) id)
     	-- cannot be Nothing
 
-getReg (StReg (StixTemp u pk)) = returnSUs (Fixed (UnmappedReg u pk) pk id)
+getReg (StReg (StixTemp u pk)) = returnUs (Fixed (UnmappedReg u pk) pk id)
 
 getReg (StDouble 0.0)
   = let
     	code dst = mkSeqInstrs [FLDZ]
     in
-    	returnSUs (Any DoubleKind code)
+    	returnUs (Any DoubleRep code)
 
 getReg (StDouble 1.0)
   = let
     	code dst = mkSeqInstrs [FLD1]
     in
-    	returnSUs (Any DoubleKind code)
+    	returnUs (Any DoubleRep code)
 
 getReg (StDouble d) =
-    getUniqLabelNCG 	    	    `thenSUs` \ lbl ->
-    --getNewRegNCG PtrKind    	    `thenSUs` \ tmp ->
+    getUniqLabelNCG 	    	    `thenUs` \ lbl ->
+    --getNewRegNCG PtrRep    	    `thenUs` \ tmp ->
     let code dst = mkSeqInstrs [
     	    SEGMENT DataSegment,
 	    LABEL lbl,
-#if __GLASGOW_HASKELL__ >= 23
---	    DATA D [strImmLit ('0' : 'd' :_showRational 30 d)],
 	    DATA D [strImmLit ('0' : 'd' :ppShow 80 (ppRational d))],
-#else
-	    DATA D [strImmLit ('0' : 'd' :show d)],
-#endif
 	    SEGMENT TextSegment,
-	    FLD D (OpImm (ImmCLbl lbl)) 
-            ]
+	    FLD D (OpImm (ImmCLbl lbl))
+	    ]
     in
-    	returnSUs (Any DoubleKind code)
+    	returnUs (Any DoubleRep code)
 
 getReg (StString s) =
-    getUniqLabelNCG 	    	    `thenSUs` \ lbl ->
+    getUniqLabelNCG 	    	    `thenUs` \ lbl ->
     let code dst = mkSeqInstrs [
 	    SEGMENT DataSegment,
 	    LABEL lbl,
@@ -281,10 +267,10 @@ getReg (StString s) =
 	    SEGMENT TextSegment,
 	    MOV L (OpImm (ImmCLbl lbl)) (OpReg dst)]
     in
-    	returnSUs (Any PtrKind code)
+    	returnUs (Any PtrRep code)
 
 getReg (StLitLit s) | _HEAD_ s == '"' && last xs == '"' =
-    getUniqLabelNCG 	    	    `thenSUs` \ lbl ->
+    getUniqLabelNCG 	    	    `thenUs` \ lbl ->
     let code dst = mkSeqInstrs [
 	    SEGMENT DataSegment,
 	    LABEL lbl,
@@ -292,20 +278,20 @@ getReg (StLitLit s) | _HEAD_ s == '"' && last xs == '"' =
 	    SEGMENT TextSegment,
 	    MOV L (OpImm (ImmCLbl lbl)) (OpReg dst)]
     in
-    	returnSUs (Any PtrKind code)
+    	returnUs (Any PtrRep code)
   where
     xs = _UNPK_ (_TAIL_ s)
 
 
 getReg tree@(StIndex _ _ _) = getReg (mangleIndexTree tree)
 
-getReg (StCall fn kind args) = 
-    genCCall fn kind args   	    `thenSUs` \ call ->
-    returnSUs (Fixed reg kind call)
+getReg (StCall fn kind args) =
+    genCCall fn kind args   	    `thenUs` \ call ->
+    returnUs (Fixed reg kind call)
   where
-    reg = if isFloatingKind kind then st0 else eax
+    reg = if isFloatingRep kind then st0 else eax
 
-getReg (StPrim primop args) = 
+getReg (StPrim primop args) =
     case primop of
 
     	CharGtOp -> condIntReg GT args
@@ -315,11 +301,11 @@ getReg (StPrim primop args) =
     	CharLtOp -> condIntReg LT args
     	CharLeOp -> condIntReg LE args
 
-    	IntAddOp -> -- this should be optimised by the generic Opts, 
-                    -- I don't know why it is not (sometimes)!
-                    case args of 
-                      [x, StInt 0] -> getReg x
-                      _ -> addCode L args
+    	IntAddOp -> -- this should be optimised by the generic Opts,
+		    -- I don't know why it is not (sometimes)!
+		    case args of
+		      [x, StInt 0] -> getReg x
+		      _ -> addCode L args
 
     	IntSubOp -> subCode L args
     	IntMulOp -> trivialCode (IMUL L) args True
@@ -327,7 +313,7 @@ getReg (StPrim primop args) =
     	IntRemOp -> divCode L args False -- remainder
     	IntNegOp -> trivialUCode (NEGI L) args
     	IntAbsOp -> absIntCode args
-   
+
     	AndOp -> trivialCode (AND L) args True
     	OrOp  -> trivialCode (OR L) args True
     	NotOp -> trivialUCode (NOT L) args
@@ -337,14 +323,14 @@ getReg (StPrim primop args) =
     	ISllOp -> panic "I386Gen:isll"
     	ISraOp -> panic "I386Gen:isra"
     	ISrlOp -> panic "I386Gen:isrl"
-   
+
     	IntGtOp -> condIntReg GT args
     	IntGeOp -> condIntReg GE args
     	IntEqOp -> condIntReg EQ args
     	IntNeOp -> condIntReg NE args
     	IntLtOp -> condIntReg LT args
     	IntLeOp -> condIntReg LE args
-   
+
     	WordGtOp -> condIntReg GU args
     	WordGeOp -> condIntReg GEU args
     	WordEqOp -> condIntReg EQ args
@@ -359,11 +345,11 @@ getReg (StPrim primop args) =
     	AddrLtOp -> condIntReg LU args
     	AddrLeOp -> condIntReg LEU args
 
-    	FloatAddOp -> trivialFCode FloatKind FADD FADD FADDP FADDP args
-    	FloatSubOp -> trivialFCode FloatKind FSUB FSUBR FSUBP FSUBRP args
-    	FloatMulOp -> trivialFCode FloatKind FMUL FMUL FMULP FMULP args
-    	FloatDivOp -> trivialFCode FloatKind FDIV FDIVR FDIVP FDIVRP args
-    	FloatNegOp -> trivialUFCode FloatKind FCHS args
+    	FloatAddOp -> trivialFCode FloatRep FADD FADD FADDP FADDP args
+    	FloatSubOp -> trivialFCode FloatRep FSUB FSUBR FSUBP FSUBRP args
+    	FloatMulOp -> trivialFCode FloatRep FMUL FMUL FMULP FMULP args
+    	FloatDivOp -> trivialFCode FloatRep FDIV FDIVR FDIVP FDIVRP args
+    	FloatNegOp -> trivialUFCode FloatRep FCHS args
 
     	FloatGtOp -> condFltReg GT args
     	FloatGeOp -> condFltReg GE args
@@ -372,32 +358,32 @@ getReg (StPrim primop args) =
     	FloatLtOp -> condFltReg LT args
     	FloatLeOp -> condFltReg LE args
 
-    	FloatExpOp -> promoteAndCall SLIT("exp") DoubleKind
-    	FloatLogOp -> promoteAndCall SLIT("log") DoubleKind
-    	FloatSqrtOp -> trivialUFCode FloatKind FSQRT args
-       
-    	FloatSinOp -> promoteAndCall SLIT("sin") DoubleKind 
-                      --trivialUFCode FloatKind FSIN args
-    	FloatCosOp -> promoteAndCall SLIT("cos") DoubleKind 
-                      --trivialUFCode FloatKind FCOS args
-    	FloatTanOp -> promoteAndCall SLIT("tan") DoubleKind
-       
-    	FloatAsinOp -> promoteAndCall SLIT("asin") DoubleKind
-    	FloatAcosOp -> promoteAndCall SLIT("acos") DoubleKind
-    	FloatAtanOp -> promoteAndCall SLIT("atan") DoubleKind
-       
-    	FloatSinhOp -> promoteAndCall SLIT("sinh") DoubleKind
-    	FloatCoshOp -> promoteAndCall SLIT("cosh") DoubleKind
-    	FloatTanhOp -> promoteAndCall SLIT("tanh") DoubleKind
-       
-    	FloatPowerOp -> promoteAndCall SLIT("pow") DoubleKind
-
-    	DoubleAddOp -> trivialFCode DoubleKind FADD FADD FADDP FADDP args
-    	DoubleSubOp -> trivialFCode DoubleKind FSUB FSUBR FSUBP FSUBRP args
-    	DoubleMulOp -> trivialFCode DoubleKind FMUL FMUL FMULP FMULP args
-   	DoubleDivOp -> trivialFCode DoubleKind FDIV FDIVR FDIVP FDIVRP args
-    	DoubleNegOp -> trivialUFCode DoubleKind FCHS args
-   
+    	FloatExpOp -> promoteAndCall SLIT("exp") DoubleRep
+    	FloatLogOp -> promoteAndCall SLIT("log") DoubleRep
+    	FloatSqrtOp -> trivialUFCode FloatRep FSQRT args
+
+    	FloatSinOp -> promoteAndCall SLIT("sin") DoubleRep
+		      --trivialUFCode FloatRep FSIN args
+    	FloatCosOp -> promoteAndCall SLIT("cos") DoubleRep
+		      --trivialUFCode FloatRep FCOS args
+    	FloatTanOp -> promoteAndCall SLIT("tan") DoubleRep
+
+    	FloatAsinOp -> promoteAndCall SLIT("asin") DoubleRep
+    	FloatAcosOp -> promoteAndCall SLIT("acos") DoubleRep
+    	FloatAtanOp -> promoteAndCall SLIT("atan") DoubleRep
+
+    	FloatSinhOp -> promoteAndCall SLIT("sinh") DoubleRep
+    	FloatCoshOp -> promoteAndCall SLIT("cosh") DoubleRep
+    	FloatTanhOp -> promoteAndCall SLIT("tanh") DoubleRep
+
+    	FloatPowerOp -> promoteAndCall SLIT("pow") DoubleRep
+
+    	DoubleAddOp -> trivialFCode DoubleRep FADD FADD FADDP FADDP args
+    	DoubleSubOp -> trivialFCode DoubleRep FSUB FSUBR FSUBP FSUBRP args
+    	DoubleMulOp -> trivialFCode DoubleRep FMUL FMUL FMULP FMULP args
+   	DoubleDivOp -> trivialFCode DoubleRep FDIV FDIVR FDIVP FDIVRP args
+    	DoubleNegOp -> trivialUFCode DoubleRep FCHS args
+
     	DoubleGtOp -> condFltReg GT args
     	DoubleGeOp -> condFltReg GE args
     	DoubleEqOp -> condFltReg EQ args
@@ -405,33 +391,33 @@ getReg (StPrim primop args) =
     	DoubleLtOp -> condFltReg LT args
     	DoubleLeOp -> condFltReg LE args
 
-    	DoubleExpOp -> call SLIT("exp") DoubleKind
-    	DoubleLogOp -> call SLIT("log") DoubleKind
-    	DoubleSqrtOp -> trivialUFCode DoubleKind FSQRT args
-
-    	DoubleSinOp -> call SLIT("sin") DoubleKind
-                       --trivialUFCode DoubleKind FSIN args
-    	DoubleCosOp -> call SLIT("cos") DoubleKind
-                       --trivialUFCode DoubleKind FCOS args
-    	DoubleTanOp -> call SLIT("tan") DoubleKind
-       
-    	DoubleAsinOp -> call SLIT("asin") DoubleKind
-    	DoubleAcosOp -> call SLIT("acos") DoubleKind
-    	DoubleAtanOp -> call SLIT("atan") DoubleKind
-       
-    	DoubleSinhOp -> call SLIT("sinh") DoubleKind
-    	DoubleCoshOp -> call SLIT("cosh") DoubleKind
-    	DoubleTanhOp -> call SLIT("tanh") DoubleKind
-       
-    	DoublePowerOp -> call SLIT("pow") DoubleKind
-
-    	OrdOp -> coerceIntCode IntKind args
+    	DoubleExpOp -> call SLIT("exp") DoubleRep
+    	DoubleLogOp -> call SLIT("log") DoubleRep
+    	DoubleSqrtOp -> trivialUFCode DoubleRep FSQRT args
+
+    	DoubleSinOp -> call SLIT("sin") DoubleRep
+		       --trivialUFCode DoubleRep FSIN args
+    	DoubleCosOp -> call SLIT("cos") DoubleRep
+		       --trivialUFCode DoubleRep FCOS args
+    	DoubleTanOp -> call SLIT("tan") DoubleRep
+
+    	DoubleAsinOp -> call SLIT("asin") DoubleRep
+    	DoubleAcosOp -> call SLIT("acos") DoubleRep
+    	DoubleAtanOp -> call SLIT("atan") DoubleRep
+
+    	DoubleSinhOp -> call SLIT("sinh") DoubleRep
+    	DoubleCoshOp -> call SLIT("cosh") DoubleRep
+    	DoubleTanhOp -> call SLIT("tanh") DoubleRep
+
+    	DoublePowerOp -> call SLIT("pow") DoubleRep
+
+    	OrdOp -> coerceIntCode IntRep args
     	ChrOp -> chrCode args
 
     	Float2IntOp -> coerceFP2Int args
-    	Int2FloatOp -> coerceInt2FP FloatKind args
+    	Int2FloatOp -> coerceInt2FP FloatRep args
     	Double2IntOp -> coerceFP2Int args
-    	Int2DoubleOp -> coerceInt2FP DoubleKind args
+    	Int2DoubleOp -> coerceInt2FP DoubleRep args
 
     	Double2FloatOp -> coerceFltCode args
     	Float2DoubleOp -> coerceFltCode args
@@ -440,20 +426,20 @@ getReg (StPrim primop args) =
     call fn pk = getReg (StCall fn pk args)
     promoteAndCall fn pk = getReg (StCall fn pk (map promote args))
       where
-        promote x = StPrim Float2DoubleOp [x]
+	promote x = StPrim Float2DoubleOp [x]
 
 getReg (StInd pk mem) =
-    getAmode mem    	    	    `thenSUs` \ amode ->
-    let 
+    getAmode mem    	    	    `thenUs` \ amode ->
+    let
     	code = amodeCode amode
     	src   = amodeAddr amode
     	size = kindToSize pk
-    	code__2 dst = code . 
-                      if pk == DoubleKind || pk == FloatKind
-                      then mkSeqInstr (FLD {-D-} size (OpAddr src))
-                      else mkSeqInstr (MOV size (OpAddr src) (OpReg dst))
+    	code__2 dst = code .
+		      if pk == DoubleRep || pk == FloatRep
+		      then mkSeqInstr (FLD {-D-} size (OpAddr src))
+		      else mkSeqInstr (MOV size (OpAddr src) (OpReg dst))
     in
-    	returnSUs (Any pk code__2)
+    	returnUs (Any pk code__2)
 
 
 getReg (StInt i)
@@ -461,14 +447,14 @@ getReg (StInt i)
     	src = ImmInt (fromInteger i)
     	code dst = mkSeqInstr (MOV L (OpImm src) (OpReg dst))
     in
-    	returnSUs (Any IntKind code)
+    	returnUs (Any IntRep code)
 
 getReg leaf
   | maybeToBool imm =
     let
-    	code dst = mkSeqInstr (MOV L (OpImm imm__2) (OpReg dst)) 
+    	code dst = mkSeqInstr (MOV L (OpImm imm__2) (OpReg dst))
     in
-    	returnSUs (Any PtrKind code)
+    	returnUs (Any PtrRep code)
   where
     imm = maybeImm leaf
     imm__2 = case imm of Just x -> x
@@ -480,47 +466,47 @@ produce a suitable addressing mode.
 
 \begin{code}
 
-getAmode :: StixTree -> SUniqSM Amode
+getAmode :: StixTree -> UniqSM Amode
 
 getAmode tree@(StIndex _ _ _) = getAmode (mangleIndexTree tree)
 
 getAmode (StPrim IntSubOp [x, StInt i])
   =
-    getNewRegNCG PtrKind    	    `thenSUs` \ tmp ->
-    getReg x    	    	    `thenSUs` \ register ->
+    getNewRegNCG PtrRep    	    `thenUs` \ tmp ->
+    getReg x    	    	    `thenUs` \ register ->
     let
     	code = registerCode register tmp
     	reg  = registerName register tmp
     	off  = ImmInt (-(fromInteger i))
     in
-    	returnSUs (Amode (Addr (Just reg) Nothing off) code)
+    	returnUs (Amode (Addr (Just reg) Nothing off) code)
 
 getAmode (StPrim IntAddOp [x, StInt i])
-  | maybeToBool imm 
+  | maybeToBool imm
   = let
-        code = mkSeqInstrs []
+	code = mkSeqInstrs []
     in
-    	returnSUs (Amode (ImmAddr imm__2 (fromInteger i)) code)
+    	returnUs (Amode (ImmAddr imm__2 (fromInteger i)) code)
   where
     imm = maybeImm x
     imm__2 = case imm of Just x -> x
 
 getAmode (StPrim IntAddOp [x, StInt i])
   =
-    getNewRegNCG PtrKind    	    `thenSUs` \ tmp ->
-    getReg x    	    	    `thenSUs` \ register ->
+    getNewRegNCG PtrRep    	    `thenUs` \ tmp ->
+    getReg x    	    	    `thenUs` \ register ->
     let
     	code = registerCode register tmp
     	reg  = registerName register tmp
     	off  = ImmInt (fromInteger i)
     in
-    	returnSUs (Amode (Addr (Just reg) Nothing off) code)
+    	returnUs (Amode (Addr (Just reg) Nothing off) code)
 
 getAmode (StPrim IntAddOp [x, y]) =
-    getNewRegNCG PtrKind    	    `thenSUs` \ tmp1 ->
-    getNewRegNCG IntKind    	    `thenSUs` \ tmp2 ->
-    getReg x    	    	    `thenSUs` \ register1 ->
-    getReg y    	    	    `thenSUs` \ register2 ->
+    getNewRegNCG PtrRep    	    `thenUs` \ tmp1 ->
+    getNewRegNCG IntRep    	    `thenUs` \ tmp2 ->
+    getReg x    	    	    `thenUs` \ register1 ->
+    getReg y    	    	    `thenUs` \ register2 ->
     let
     	code1 = registerCode register1 tmp1 asmVoid
     	reg1  = registerName register1 tmp1
@@ -528,77 +514,77 @@ getAmode (StPrim IntAddOp [x, y]) =
     	reg2  = registerName register2 tmp2
     	code__2 = asmParThen [code1, code2]
     in
-    	returnSUs (Amode (Addr (Just reg1) (Just (reg2,4)) (ImmInt 0)) code__2)
+    	returnUs (Amode (Addr (Just reg1) (Just (reg2,4)) (ImmInt 0)) code__2)
 
 getAmode leaf
   | maybeToBool imm =
     let code = mkSeqInstrs []
     in
-        returnSUs (Amode (ImmAddr imm__2 0) code)
+	returnUs (Amode (ImmAddr imm__2 0) code)
   where
     imm = maybeImm leaf
     imm__2 = case imm of Just x -> x
 
 getAmode other =
-    getNewRegNCG PtrKind    	    `thenSUs` \ tmp ->
-    getReg other    	    	    `thenSUs` \ register ->
+    getNewRegNCG PtrRep    	    `thenUs` \ tmp ->
+    getReg other    	    	    `thenUs` \ register ->
     let
     	code = registerCode register tmp
     	reg  = registerName register tmp
     	off  = Nothing
     in
-    	returnSUs (Amode (Addr (Just reg) Nothing (ImmInt 0)) code)
+    	returnUs (Amode (Addr (Just reg) Nothing (ImmInt 0)) code)
 
 \end{code}
 
 \begin{code}
 getOp
-    :: StixTree	
-    -> SUniqSM (CodeBlock I386Instr,Operand, Size)	-- code, operator, size
+    :: StixTree
+    -> UniqSM (CodeBlock I386Instr,Operand, Size)	-- code, operator, size
 getOp (StInt i)
-  = returnSUs (asmParThen [], OpImm (ImmInt (fromInteger i)), L)
+  = returnUs (asmParThen [], OpImm (ImmInt (fromInteger i)), L)
 
 getOp (StInd pk mem)
-  = getAmode mem    	    	    `thenSUs` \ amode ->
+  = getAmode mem    	    	    `thenUs` \ amode ->
     let
     	code = amodeCode amode --asmVoid
     	addr  = amodeAddr amode
     	sz = kindToSize pk
-    in returnSUs (code, OpAddr addr, sz)
+    in returnUs (code, OpAddr addr, sz)
 
 getOp op
-  = getReg op	    	    	    `thenSUs` \ register ->
+  = getReg op	    	    	    `thenUs` \ register ->
     getNewRegNCG (registerKind register)
-    	    	        	    `thenSUs` \ tmp ->
-    let 
+    	    	        	    `thenUs` \ tmp ->
+    let
     	code = registerCode register tmp
     	reg = registerName register tmp
     	pk = registerKind register
     	sz = kindToSize pk
     in
-    	returnSUs (code, OpReg reg, sz)
+    	returnUs (code, OpReg reg, sz)
 
 getOpRI
-    :: StixTree	
-    -> SUniqSM (CodeBlock I386Instr,Operand, Size)	-- code, operator, size
+    :: StixTree
+    -> UniqSM (CodeBlock I386Instr,Operand, Size)	-- code, operator, size
 getOpRI op
   | maybeToBool imm
-  = returnSUs (asmParThen [], OpImm imm_op, L)
+  = returnUs (asmParThen [], OpImm imm_op, L)
   where
     imm = maybeImm op
     imm_op = case imm of Just x -> x
 
 getOpRI op
-  = getReg op	    	    	    `thenSUs` \ register ->
+  = getReg op	    	    	    `thenUs` \ register ->
     getNewRegNCG (registerKind register)
-    	    	        	    `thenSUs` \ tmp ->
-    let 
+    	    	        	    `thenUs` \ tmp ->
+    let
     	code = registerCode register tmp
     	reg = registerName register tmp
     	pk = registerKind register
     	sz = kindToSize pk
     in
-    	returnSUs (code, OpReg reg, sz)
+    	returnUs (code, OpReg reg, sz)
 
 \end{code}
 
@@ -606,9 +592,9 @@ Set up a condition code for a conditional branch.
 
 \begin{code}
 
-getCondition :: StixTree -> SUniqSM Condition
+getCondition :: StixTree -> UniqSM Condition
 
-getCondition (StPrim primop args) = 
+getCondition (StPrim primop args) =
     case primop of
 
     	CharGtOp -> condIntCode GT args
@@ -624,7 +610,7 @@ getCondition (StPrim primop args) =
     	IntNeOp -> condIntCode NE args
    	IntLtOp -> condIntCode LT args
     	IntLeOp -> condIntCode LE args
-   
+
     	WordGtOp -> condIntCode GU args
     	WordGeOp -> condIntCode GEU args
     	WordEqOp -> condIntCode EQ args
@@ -660,94 +646,94 @@ back up the tree.
 
 \begin{code}
 
-condIntCode, condFltCode :: Cond -> [StixTree] -> SUniqSM Condition
-condIntCode cond [StInd _ x, y] 
+condIntCode, condFltCode :: Cond -> [StixTree] -> UniqSM Condition
+condIntCode cond [StInd _ x, y]
   | maybeToBool imm
-  = getAmode x    	    	    `thenSUs` \ amode ->
+  = getAmode x    	    	    `thenUs` \ amode ->
     let
     	code1 = amodeCode amode asmVoid
     	y__2  = amodeAddr amode
-    	code__2 = asmParThen [code1] . 
+    	code__2 = asmParThen [code1] .
     	    	  mkSeqInstr (CMP L (OpImm imm__2) (OpAddr y__2))
     in
-        returnSUs (Condition False cond code__2)
+	returnUs (Condition False cond code__2)
   where
     imm = maybeImm y
     imm__2 = case imm of Just x -> x
 
-condIntCode cond [x, StInt 0] 
-  = getReg x	    	    	    `thenSUs` \ register1 ->
-    getNewRegNCG IntKind    	    `thenSUs` \ tmp1 ->
+condIntCode cond [x, StInt 0]
+  = getReg x	    	    	    `thenUs` \ register1 ->
+    getNewRegNCG IntRep    	    `thenUs` \ tmp1 ->
     let
-        code1 = registerCode register1 tmp1 asmVoid
-        src1  = registerName register1 tmp1
-        code__2 = asmParThen [code1] . 
+	code1 = registerCode register1 tmp1 asmVoid
+	src1  = registerName register1 tmp1
+	code__2 = asmParThen [code1] .
     	    	mkSeqInstr (TEST L (OpReg src1) (OpReg src1))
     in
-        returnSUs (Condition False cond code__2)
+	returnUs (Condition False cond code__2)
 
-condIntCode cond [x, y] 
+condIntCode cond [x, y]
   | maybeToBool imm
-  = getReg x	    	    	    `thenSUs` \ register1 ->
-    getNewRegNCG IntKind    	    `thenSUs` \ tmp1 ->
+  = getReg x	    	    	    `thenUs` \ register1 ->
+    getNewRegNCG IntRep    	    `thenUs` \ tmp1 ->
     let
-        code1 = registerCode register1 tmp1 asmVoid
-        src1  = registerName register1 tmp1
-        code__2 = asmParThen [code1] . 
+	code1 = registerCode register1 tmp1 asmVoid
+	src1  = registerName register1 tmp1
+	code__2 = asmParThen [code1] .
     	    	mkSeqInstr (CMP L (OpImm imm__2) (OpReg src1))
     in
-        returnSUs (Condition False cond code__2)
+	returnUs (Condition False cond code__2)
   where
     imm = maybeImm y
     imm__2 = case imm of Just x -> x
 
-condIntCode cond [StInd _ x, y] 
-  = getAmode x    	    	    `thenSUs` \ amode ->
-    getReg y	    	    	    `thenSUs` \ register2 ->
-    getNewRegNCG IntKind    	    `thenSUs` \ tmp2 ->
+condIntCode cond [StInd _ x, y]
+  = getAmode x    	    	    `thenUs` \ amode ->
+    getReg y	    	    	    `thenUs` \ register2 ->
+    getNewRegNCG IntRep    	    `thenUs` \ tmp2 ->
     let
     	code1 = amodeCode amode asmVoid
     	src1  = amodeAddr amode
-        code2 = registerCode register2 tmp2 asmVoid
-        src2  = registerName register2 tmp2
-    	code__2 = asmParThen [code1, code2] . 
+	code2 = registerCode register2 tmp2 asmVoid
+	src2  = registerName register2 tmp2
+    	code__2 = asmParThen [code1, code2] .
     	    	  mkSeqInstr (CMP L (OpReg src2) (OpAddr src1))
     in
-        returnSUs (Condition False cond code__2)
+	returnUs (Condition False cond code__2)
 
-condIntCode cond [y, StInd _ x] 
-  = getAmode x    	    	    `thenSUs` \ amode ->
-    getReg y	    	    	    `thenSUs` \ register2 ->
-    getNewRegNCG IntKind    	    `thenSUs` \ tmp2 ->
+condIntCode cond [y, StInd _ x]
+  = getAmode x    	    	    `thenUs` \ amode ->
+    getReg y	    	    	    `thenUs` \ register2 ->
+    getNewRegNCG IntRep    	    `thenUs` \ tmp2 ->
     let
     	code1 = amodeCode amode asmVoid
     	src1  = amodeAddr amode
-        code2 = registerCode register2 tmp2 asmVoid
-        src2  = registerName register2 tmp2
-    	code__2 = asmParThen [code1, code2] . 
+	code2 = registerCode register2 tmp2 asmVoid
+	src2  = registerName register2 tmp2
+    	code__2 = asmParThen [code1, code2] .
     	    	  mkSeqInstr (CMP L (OpAddr src1) (OpReg src2))
     in
-        returnSUs (Condition False cond code__2)
+	returnUs (Condition False cond code__2)
 
 condIntCode cond [x, y] =
-    getReg x	    	    	    `thenSUs` \ register1 ->
-    getReg y	    	    	    `thenSUs` \ register2 ->
-    getNewRegNCG IntKind    	    `thenSUs` \ tmp1 ->
-    getNewRegNCG IntKind    	    `thenSUs` \ tmp2 ->
+    getReg x	    	    	    `thenUs` \ register1 ->
+    getReg y	    	    	    `thenUs` \ register2 ->
+    getNewRegNCG IntRep    	    `thenUs` \ tmp1 ->
+    getNewRegNCG IntRep    	    `thenUs` \ tmp2 ->
     let
-        code1 = registerCode register1 tmp1 asmVoid
-        src1  = registerName register1 tmp1
-        code2 = registerCode register2 tmp2 asmVoid
-        src2  = registerName register2 tmp2
-        code__2 = asmParThen [code1, code2] . 
+	code1 = registerCode register1 tmp1 asmVoid
+	src1  = registerName register1 tmp1
+	code2 = registerCode register2 tmp2 asmVoid
+	src2  = registerName register2 tmp2
+	code__2 = asmParThen [code1, code2] .
     	    	mkSeqInstr (CMP L (OpReg src2) (OpReg src1))
     in
-        returnSUs (Condition False cond code__2)
+	returnUs (Condition False cond code__2)
 
 condFltCode cond [x, StDouble 0.0] =
-    getReg x	    	    	    `thenSUs` \ register1 ->
+    getReg x	    	    	    `thenUs` \ register1 ->
     getNewRegNCG (registerKind register1)
-      	    	        	    `thenSUs` \ tmp1 ->
+      	    	        	    `thenUs` \ tmp1 ->
     let
     	pk1   = registerKind register1
     	code1 = registerCode register1 tmp1
@@ -755,21 +741,21 @@ condFltCode cond [x, StDouble 0.0] =
 
     	code__2 = asmParThen [code1 asmVoid] .
     	    	  mkSeqInstrs [FTST, FSTP D (OpReg st0), -- or FLDZ, FUCOMPP ?
-                               FNSTSW,
-                               --AND HB (OpImm (ImmInt 68)) (OpReg eax),
-                               --XOR HB (OpImm (ImmInt 64)) (OpReg eax)
-                               SAHF
-                              ]
+			       FNSTSW,
+			       --AND HB (OpImm (ImmInt 68)) (OpReg eax),
+			       --XOR HB (OpImm (ImmInt 64)) (OpReg eax)
+			       SAHF
+			      ]
     in
-    	returnSUs (Condition True (fixFPCond cond) code__2)
+    	returnUs (Condition True (fixFPCond cond) code__2)
 
 condFltCode cond [x, y] =
-    getReg x	    	    	    `thenSUs` \ register1 ->
-    getReg y	    	    	    `thenSUs` \ register2 ->
+    getReg x	    	    	    `thenUs` \ register1 ->
+    getReg y	    	    	    `thenUs` \ register2 ->
     getNewRegNCG (registerKind register1)
-      	    	        	    `thenSUs` \ tmp1 ->
+      	    	        	    `thenUs` \ tmp1 ->
     getNewRegNCG (registerKind register2)
-     	    	        	    `thenSUs` \ tmp2 ->
+     	    	        	    `thenUs` \ tmp2 ->
     let
     	pk1   = registerKind register1
     	code1 = registerCode register1 tmp1
@@ -780,13 +766,13 @@ condFltCode cond [x, y] =
 
     	code__2 = asmParThen [code2 asmVoid, code1 asmVoid] .
     	    	  mkSeqInstrs [FUCOMPP,
-                               FNSTSW,
-                               --AND HB (OpImm (ImmInt 68)) (OpReg eax),
-                               --XOR HB (OpImm (ImmInt 64)) (OpReg eax)
-                               SAHF
-                              ]
+			       FNSTSW,
+			       --AND HB (OpImm (ImmInt 68)) (OpReg eax),
+			       --XOR HB (OpImm (ImmInt 64)) (OpReg eax)
+			       SAHF
+			      ]
     in
-    	returnSUs (Condition True (fixFPCond cond) code__2)
+    	returnUs (Condition True (fixFPCond cond) code__2)
 
 \end{code}
 
@@ -795,42 +781,42 @@ the right hand side of an assignment).
 
 \begin{code}
 
-condIntReg :: Cond -> [StixTree] -> SUniqSM Register
+condIntReg :: Cond -> [StixTree] -> UniqSM Register
 condIntReg cond args =
-    condIntCode cond args 	    `thenSUs` \ condition ->
-    getNewRegNCG IntKind    	    `thenSUs` \ tmp ->
-    --getReg dst	    	    	    `thenSUs` \ register ->
-    let 
+    condIntCode cond args 	    `thenUs` \ condition ->
+    getNewRegNCG IntRep    	    `thenUs` \ tmp ->
+    --getReg dst	    	    	    `thenUs` \ register ->
+    let
     	--code2 = registerCode register tmp asmVoid
     	--dst__2  = registerName register tmp
-        code = condCode condition
-        cond = condName condition
+	code = condCode condition
+	cond = condName condition
 -- ToDo: if dst is eax, ebx, ecx, or edx we would not need the move.
-        code__2 dst = code . mkSeqInstrs [
+	code__2 dst = code . mkSeqInstrs [
 	    SETCC cond (OpReg tmp),
 	    AND L (OpImm (ImmInt 1)) (OpReg tmp),
-	    MOV L (OpReg tmp) (OpReg dst)] 
+	    MOV L (OpReg tmp) (OpReg dst)]
     in
-        returnSUs (Any IntKind code__2)
+	returnUs (Any IntRep code__2)
 
-condFltReg :: Cond -> [StixTree] -> SUniqSM Register
+condFltReg :: Cond -> [StixTree] -> UniqSM Register
 
 condFltReg cond args =
-    getUniqLabelNCG	    	    `thenSUs` \ lbl1 ->
-    getUniqLabelNCG	    	    `thenSUs` \ lbl2 ->
-    condFltCode cond args 	    `thenSUs` \ condition ->
+    getUniqLabelNCG	    	    `thenUs` \ lbl1 ->
+    getUniqLabelNCG	    	    `thenUs` \ lbl2 ->
+    condFltCode cond args 	    `thenUs` \ condition ->
     let
     	code = condCode condition
     	cond = condName condition
     	code__2 dst = code . mkSeqInstrs [
-	    JXX cond lbl1, 
+	    JXX cond lbl1,
 	    MOV L (OpImm (ImmInt 0)) (OpReg dst),
 	    JXX ALWAYS lbl2,
 	    LABEL lbl1,
 	    MOV L (OpImm (ImmInt 1)) (OpReg dst),
 	    LABEL lbl2]
     in
-        returnSUs (Any IntKind code__2)
+	returnUs (Any IntRep code__2)
 
 \end{code}
 
@@ -840,59 +826,59 @@ correspond to loads, stores, or register transfers.  If we're really lucky,
 some of the register transfers will go away, because we can use the destination
 register to complete the code generation for the right hand side.  This only
 fails when the right hand side is forced into a fixed register (e.g. the result
-of a call).  
+of a call).
 
 \begin{code}
 
-assignIntCode :: PrimKind -> StixTree -> StixTree -> SUniqSM (CodeBlock I386Instr)
-assignIntCode pk (StInd _ dst) src 
-  = getAmode dst    	    	    `thenSUs` \ amode ->
-    getOpRI src                     `thenSUs` \ (codesrc, opsrc, sz) ->
-    let 
+assignIntCode :: PrimRep -> StixTree -> StixTree -> UniqSM (CodeBlock I386Instr)
+assignIntCode pk (StInd _ dst) src
+  = getAmode dst    	    	    `thenUs` \ amode ->
+    getOpRI src                     `thenUs` \ (codesrc, opsrc, sz) ->
+    let
     	code1 = amodeCode amode asmVoid
     	dst__2  = amodeAddr amode
-    	code__2 = asmParThen [code1, codesrc asmVoid] . 
-                  mkSeqInstr (MOV sz opsrc (OpAddr dst__2))
+    	code__2 = asmParThen [code1, codesrc asmVoid] .
+		  mkSeqInstr (MOV sz opsrc (OpAddr dst__2))
     in
-    	returnSUs code__2
+    	returnUs code__2
 
 assignIntCode pk dst (StInd _ src) =
-    getNewRegNCG IntKind    	    `thenSUs` \ tmp ->
-    getAmode src    	    	    `thenSUs` \ amode ->
-    getReg dst	    	    	    `thenSUs` \ register ->
-    let 
+    getNewRegNCG IntRep    	    `thenUs` \ tmp ->
+    getAmode src    	    	    `thenUs` \ amode ->
+    getReg dst	    	    	    `thenUs` \ register ->
+    let
     	code1 = amodeCode amode asmVoid
     	src__2  = amodeAddr amode
     	code2 = registerCode register tmp asmVoid
     	dst__2  = registerName register tmp
     	sz    = kindToSize pk
-    	code__2 = asmParThen [code1, code2] . 
-                  mkSeqInstr (MOV sz (OpAddr src__2) (OpReg dst__2))
+    	code__2 = asmParThen [code1, code2] .
+		  mkSeqInstr (MOV sz (OpAddr src__2) (OpReg dst__2))
     in
-    	returnSUs code__2
+    	returnUs code__2
 
 assignIntCode pk dst src =
-    getReg dst	    	    	    `thenSUs` \ register1 ->
-    getReg src	    	    	    `thenSUs` \ register2 ->
-    getNewRegNCG IntKind    	    `thenSUs` \ tmp ->
-    let 
+    getReg dst	    	    	    `thenUs` \ register1 ->
+    getReg src	    	    	    `thenUs` \ register2 ->
+    getNewRegNCG IntRep    	    `thenUs` \ tmp ->
+    let
     	dst__2 = registerName register1 tmp
     	code = registerCode register2 dst__2
     	src__2 = registerName register2 dst__2
     	code__2 = if isFixed register2 && dst__2 /= src__2
     	    	  then code . mkSeqInstr (MOV L (OpReg src__2) (OpReg dst__2))
-    	    	  else 
-                       code
+    	    	  else
+		       code
     in
-    	returnSUs code__2
-
-assignFltCode :: PrimKind -> StixTree -> StixTree -> SUniqSM (CodeBlock I386Instr)
-assignFltCode pk (StInd pk_dst dst) (StInd pk_src src) 
-  = getNewRegNCG IntKind       	    `thenSUs` \ tmp ->
-    getAmode src    	    	    `thenSUs` \ amodesrc ->
-    getAmode dst    	    	    `thenSUs` \ amodedst ->
-    --getReg src	    	    	    `thenSUs` \ register ->
-    let 
+    	returnUs code__2
+
+assignFltCode :: PrimRep -> StixTree -> StixTree -> UniqSM (CodeBlock I386Instr)
+assignFltCode pk (StInd pk_dst dst) (StInd pk_src src)
+  = getNewRegNCG IntRep       	    `thenUs` \ tmp ->
+    getAmode src    	    	    `thenUs` \ amodesrc ->
+    getAmode dst    	    	    `thenUs` \ amodedst ->
+    --getReg src	    	    	    `thenUs` \ register ->
+    let
     	codesrc1 = amodeCode amodesrc asmVoid
     	addrsrc1 = amodeAddr amodesrc
     	codedst1 = amodeCode amodedst asmVoid
@@ -900,22 +886,22 @@ assignFltCode pk (StInd pk_dst dst) (StInd pk_src src)
     	addrsrc2 = case (offset addrsrc1 4) of Just x -> x
     	addrdst2 = case (offset addrdst1 4) of Just x -> x
 
-    	code__2 = asmParThen [codesrc1, codedst1] . 
+    	code__2 = asmParThen [codesrc1, codedst1] .
 		  mkSeqInstrs ([MOV L (OpAddr addrsrc1) (OpReg tmp),
-		                MOV L (OpReg tmp) (OpAddr addrdst1)]
-                               ++
-		               if pk == DoubleKind 
-                               then [MOV L (OpAddr addrsrc2) (OpReg tmp),
-		                     MOV L (OpReg tmp) (OpAddr addrdst2)]
-                               else [])
+				MOV L (OpReg tmp) (OpAddr addrdst1)]
+			       ++
+			       if pk == DoubleRep
+			       then [MOV L (OpAddr addrsrc2) (OpReg tmp),
+				     MOV L (OpReg tmp) (OpAddr addrdst2)]
+			       else [])
     in
-        returnSUs code__2
+	returnUs code__2
 
 assignFltCode pk (StInd _ dst) src =
-    --getNewRegNCG pk        	    `thenSUs` \ tmp ->
-    getAmode dst    	    	    `thenSUs` \ amode ->
-    getReg src	    	    	    `thenSUs` \ register ->
-    let 
+    --getNewRegNCG pk        	    `thenUs` \ tmp ->
+    getAmode dst    	    	    `thenUs` \ amode ->
+    getReg src	    	    	    `thenUs` \ register ->
+    let
     	sz    = kindToSize pk
     	dst__2  = amodeAddr amode
 
@@ -926,28 +912,28 @@ assignFltCode pk (StInd _ dst) src =
     	pk__2  = registerKind register
     	sz__2 = kindToSize pk__2
 
-    	code__2 = asmParThen [code1, code2] . 
+    	code__2 = asmParThen [code1, code2] .
 		  mkSeqInstr (FSTP sz (OpAddr dst__2))
     in
-        returnSUs code__2
+	returnUs code__2
 
 assignFltCode pk dst src =
-    getReg dst	    	    	    `thenSUs` \ register1 ->
-    getReg src	    	    	    `thenSUs` \ register2 ->
+    getReg dst	    	    	    `thenUs` \ register1 ->
+    getReg src	    	    	    `thenUs` \ register2 ->
     --getNewRegNCG (registerKind register2)
-    --	    	        	    `thenSUs` \ tmp ->
-    let 
+    --	    	        	    `thenUs` \ tmp ->
+    let
     	sz = kindToSize pk
     	dst__2 = registerName register1 st0 --tmp
 
     	code = registerCode register2 dst__2
     	src__2 = registerName register2 dst__2
 
-    	code__2 = code 
+    	code__2 = code
     in
-    	returnSUs code__2
+    	returnUs code__2
 
-\end{code} 
+\end{code}
 
 Generating an unconditional branch.  We accept two types of targets:
 an immediate CLabel or a tree that gets evaluated into a register.
@@ -959,12 +945,12 @@ Do not fill the delay slots here; you will confuse the register allocator.
 
 \begin{code}
 
-genJump 
+genJump
     :: StixTree     -- the branch target
-    -> SUniqSM (CodeBlock I386Instr)
+    -> UniqSM (CodeBlock I386Instr)
 
 {-
-genJump (StCLbl lbl) 
+genJump (StCLbl lbl)
   | isAsmTemp lbl = returnInstrs [JXX ALWAYS lbl]
   | otherwise     = returnInstrs [JMP (OpImm target)]
   where
@@ -972,14 +958,14 @@ genJump (StCLbl lbl)
 -}
 
 genJump (StInd pk mem) =
-    getAmode mem    	    	    `thenSUs` \ amode ->
+    getAmode mem    	    	    `thenUs` \ amode ->
     let
     	code = amodeCode amode
     	target  = amodeAddr amode
     in
     	returnSeq code [JMP (OpAddr target)]
 
-genJump tree 
+genJump tree
   | maybeToBool imm
   = returnInstr (JMP (OpImm target))
   where
@@ -988,8 +974,8 @@ genJump tree
 
 
 genJump tree =
-    getReg tree	    	    	    `thenSUs` \ register ->
-    getNewRegNCG PtrKind    	    `thenSUs` \ tmp ->
+    getReg tree	    	    	    `thenUs` \ register ->
+    getNewRegNCG PtrRep    	    `thenUs` \ tmp ->
     let
     	code = registerCode register tmp
     	target = registerName register tmp
@@ -1004,19 +990,19 @@ codes are set according to the supplied comparison operation.
 
 \begin{code}
 
-genCondJump 
+genCondJump
     :: CLabel	    -- the branch target
     -> StixTree     -- the condition on which to branch
-    -> SUniqSM (CodeBlock I386Instr)
+    -> UniqSM (CodeBlock I386Instr)
 
-genCondJump lbl bool = 
-    getCondition bool  	    	    `thenSUs` \ condition ->
+genCondJump lbl bool =
+    getCondition bool  	    	    `thenUs` \ condition ->
     let
     	code = condCode condition
     	cond = condName condition
-        target = ImmCLbl lbl    
+	target = ImmCLbl lbl
     in
-        returnSeq code [JXX cond lbl]
+	returnSeq code [JXX cond lbl]
 
 \end{code}
 
@@ -1024,36 +1010,36 @@ genCondJump lbl bool =
 
 genCCall
     :: FAST_STRING  -- function to call
-    -> PrimKind	    -- type of the result
+    -> PrimRep	    -- type of the result
     -> [StixTree]   -- arguments (of mixed type)
-    -> SUniqSM (CodeBlock I386Instr)
+    -> UniqSM (CodeBlock I386Instr)
 
-genCCall fn kind [StInt i] 
+genCCall fn kind [StInt i]
   | fn == SLIT ("PerformGC_wrapper")
-  = getUniqLabelNCG    	    	    `thenSUs` \ lbl ->
+  = getUniqLabelNCG    	    	    `thenUs` \ lbl ->
     let
-        call = [MOV L (OpImm (ImmInt (fromInteger i))) (OpReg eax),
-                MOV L (OpImm (ImmCLbl lbl)) 
-                      -- this is hardwired
-                      (OpAddr (Addr (Just ebx) Nothing (ImmInt 104))),
-                JMP (OpImm (ImmLit (uppPStr (SLIT ("_PerformGC_wrapper"))))),
-                LABEL lbl]
+	call = [MOV L (OpImm (ImmInt (fromInteger i))) (OpReg eax),
+		MOV L (OpImm (ImmCLbl lbl))
+		      -- this is hardwired
+		      (OpAddr (Addr (Just ebx) Nothing (ImmInt 104))),
+		JMP (OpImm (ImmLit (uppPStr (SLIT ("_PerformGC_wrapper"))))),
+		LABEL lbl]
     in
     	returnInstrs call
 
 genCCall fn kind args =
-    mapSUs getCallArg args `thenSUs` \ argCode ->
+    mapUs getCallArg args `thenUs` \ argCode ->
     let
-        nargs = length args
-        code1 = asmParThen [asmSeq [ -- MOV L (OpReg esp) (OpAddr (Addr (Just ebx) Nothing (ImmInt 80))),
-                        MOV L (OpAddr (Addr (Just ebx) Nothing (ImmInt 100))) (OpReg esp)
-                                   ]
-                           ]
-        code2 = asmParThen (map ($ asmVoid) (reverse argCode)) 
-        call = [CALL (ImmLit fn__2) -- ,
-                -- ADD L (OpImm (ImmInt (nargs * 4))) (OpReg esp),
-                -- MOV L (OpAddr (Addr (Just ebx) Nothing (ImmInt 80))) (OpReg esp)
-                ]
+	nargs = length args
+	code1 = asmParThen [asmSeq [ -- MOV L (OpReg esp) (OpAddr (Addr (Just ebx) Nothing (ImmInt 80))),
+			MOV L (OpAddr (Addr (Just ebx) Nothing (ImmInt 100))) (OpReg esp)
+				   ]
+			   ]
+	code2 = asmParThen (map ($ asmVoid) (reverse argCode))
+	call = [CALL (ImmLit fn__2) -- ,
+		-- ADD L (OpImm (ImmInt (nargs * 4))) (OpReg esp),
+		-- MOV L (OpAddr (Addr (Just ebx) Nothing (ImmInt 80))) (OpReg esp)
+		]
     in
     	returnSeq (code1 . code2) call
   where
@@ -1063,12 +1049,12 @@ genCCall fn kind args =
 	      '.' -> uppPStr fn
 	      _   -> uppBeside (uppChar '_') (uppPStr fn)
 
-    getCallArg 
-        :: StixTree				-- Current argument
-        -> SUniqSM (CodeBlock I386Instr)	-- code
-    getCallArg arg = 
-        getOp arg	    	    	    `thenSUs` \ (code, op, sz) ->
-        returnSUs (code . mkSeqInstr (PUSH sz op))
+    getCallArg
+	:: StixTree				-- Current argument
+	-> UniqSM (CodeBlock I386Instr)	-- code
+    getCallArg arg =
+	getOp arg	    	    	    `thenUs` \ (code, op, sz) ->
+	returnUs (code . mkSeqInstr (PUSH sz op))
 \end{code}
 
 Trivial (dyadic) instructions.  Only look for constants on the right hand
@@ -1076,96 +1062,96 @@ side, because that's where the generic optimizer will have put them.
 
 \begin{code}
 
-trivialCode 
-    :: (Operand -> Operand -> I386Instr) 
+trivialCode
+    :: (Operand -> Operand -> I386Instr)
     -> [StixTree]
     -> Bool	-- is the instr commutative?
-    -> SUniqSM Register
+    -> UniqSM Register
 
 trivialCode instr [x, y] _
   | maybeToBool imm
-  = getReg x	    	    	    `thenSUs` \ register1 ->
-    --getNewRegNCG IntKind    	    `thenSUs` \ tmp1 ->
+  = getReg x	    	    	    `thenUs` \ register1 ->
+    --getNewRegNCG IntRep    	    `thenUs` \ tmp1 ->
     let
     	fixedname  = registerName register1 eax
-    	code__2 dst = let code1 = registerCode register1 dst 
+    	code__2 dst = let code1 = registerCode register1 dst
     	                  src1  = registerName register1 dst
-                      in code1 .
-                         if isFixed register1 && src1 /= dst
-                         then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst),
-                                           instr (OpImm imm__2) (OpReg dst)]
-                         else 
-                                mkSeqInstrs [instr (OpImm imm__2) (OpReg src1)]
+		      in code1 .
+			 if isFixed register1 && src1 /= dst
+			 then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst),
+					   instr (OpImm imm__2) (OpReg dst)]
+			 else
+				mkSeqInstrs [instr (OpImm imm__2) (OpReg src1)]
     in
-    	returnSUs (Any IntKind code__2)
+    	returnUs (Any IntRep code__2)
   where
     imm = maybeImm y
     imm__2 = case imm of Just x -> x
 
 trivialCode instr [x, y] _
   | maybeToBool imm
-  = getReg y	    	    	    `thenSUs` \ register1 ->
-    --getNewRegNCG IntKind    	    `thenSUs` \ tmp1 ->
+  = getReg y	    	    	    `thenUs` \ register1 ->
+    --getNewRegNCG IntRep    	    `thenUs` \ tmp1 ->
     let
     	fixedname  = registerName register1 eax
     	code__2 dst = let code1 = registerCode register1 dst
-                          src1  = registerName register1 dst
-                      in code1 .
-                         if isFixed register1 && src1 /= dst
-                         then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst),
-                                           instr (OpImm imm__2) (OpReg dst)]
-                         else 
-                                mkSeqInstr (instr (OpImm imm__2) (OpReg src1))
+			  src1  = registerName register1 dst
+		      in code1 .
+			 if isFixed register1 && src1 /= dst
+			 then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst),
+					   instr (OpImm imm__2) (OpReg dst)]
+			 else
+				mkSeqInstr (instr (OpImm imm__2) (OpReg src1))
     in
-    	returnSUs (Any IntKind code__2)
+    	returnUs (Any IntRep code__2)
   where
     imm = maybeImm x
     imm__2 = case imm of Just x -> x
 
 trivialCode instr [x, StInd pk mem] _
-  = getReg x	    	    	    `thenSUs` \ register ->
-    --getNewRegNCG IntKind    	    `thenSUs` \ tmp ->
-    getAmode mem    	    	    `thenSUs` \ amode ->
+  = getReg x	    	    	    `thenUs` \ register ->
+    --getNewRegNCG IntRep    	    `thenUs` \ tmp ->
+    getAmode mem    	    	    `thenUs` \ amode ->
     let
     	fixedname  = registerName register eax
     	code2 = amodeCode amode asmVoid
     	src2  = amodeAddr amode
     	code__2 dst = let code1 = registerCode register dst asmVoid
-                          src1  = registerName register dst
-                      in asmParThen [code1, code2] .
-                         if isFixed register && src1 /= dst
-                         then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst),
-                                           instr (OpAddr src2)  (OpReg dst)]
-                         else 
-                                mkSeqInstr (instr (OpAddr src2) (OpReg src1))
+			  src1  = registerName register dst
+		      in asmParThen [code1, code2] .
+			 if isFixed register && src1 /= dst
+			 then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst),
+					   instr (OpAddr src2)  (OpReg dst)]
+			 else
+				mkSeqInstr (instr (OpAddr src2) (OpReg src1))
     in
-    	returnSUs (Any pk code__2)
+    	returnUs (Any pk code__2)
 
 trivialCode instr [StInd pk mem, y] _
-  = getReg y	    	    	    `thenSUs` \ register ->
-    --getNewRegNCG IntKind    	    `thenSUs` \ tmp ->
-    getAmode mem    	    	    `thenSUs` \ amode ->
+  = getReg y	    	    	    `thenUs` \ register ->
+    --getNewRegNCG IntRep    	    `thenUs` \ tmp ->
+    getAmode mem    	    	    `thenUs` \ amode ->
     let
     	fixedname  = registerName register eax
     	code2 = amodeCode amode asmVoid
     	src2  = amodeAddr amode
-    	code__2 dst = let 
+    	code__2 dst = let
     	                  code1 = registerCode register dst asmVoid
     	                  src1  = registerName register dst
-                      in asmParThen [code1, code2] .
-                         if isFixed register && src1 /= dst
-                         then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst),
-                                           instr (OpAddr src2)  (OpReg dst)]
-                         else 
-                                mkSeqInstr (instr (OpAddr src2) (OpReg src1))
+		      in asmParThen [code1, code2] .
+			 if isFixed register && src1 /= dst
+			 then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst),
+					   instr (OpAddr src2)  (OpReg dst)]
+			 else
+				mkSeqInstr (instr (OpAddr src2) (OpReg src1))
     in
-    	returnSUs (Any pk code__2)
+    	returnUs (Any pk code__2)
 
-trivialCode instr [x, y] is_comm_op 
-  = getReg x	    	    	    `thenSUs` \ register1 ->
-    getReg y	    	    	    `thenSUs` \ register2 ->
-    --getNewRegNCG IntKind    	    `thenSUs` \ tmp1 ->
-    getNewRegNCG IntKind    	    `thenSUs` \ tmp2 ->
+trivialCode instr [x, y] is_comm_op
+  = getReg x	    	    	    `thenUs` \ register1 ->
+    getReg y	    	    	    `thenUs` \ register2 ->
+    --getNewRegNCG IntRep    	    `thenUs` \ tmp1 ->
+    getNewRegNCG IntRep    	    `thenUs` \ tmp2 ->
     let
     	fixedname  = registerName register1 eax
     	code2 = registerCode register2 tmp2 asmVoid
@@ -1173,38 +1159,38 @@ trivialCode instr [x, y] is_comm_op
     	code__2 dst = let
     	                  code1 = registerCode register1 dst asmVoid
     	                  src1  = registerName register1 dst
-                      in asmParThen [code1, code2] .
-                         if isFixed register1 && src1 /= dst
-                         then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst),
-                                           instr (OpReg src2)  (OpReg dst)]
-                         else 
-                                mkSeqInstr (instr (OpReg src2) (OpReg src1))
+		      in asmParThen [code1, code2] .
+			 if isFixed register1 && src1 /= dst
+			 then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst),
+					   instr (OpReg src2)  (OpReg dst)]
+			 else
+				mkSeqInstr (instr (OpReg src2) (OpReg src1))
     in
-    	returnSUs (Any IntKind code__2)
+    	returnUs (Any IntRep code__2)
 
-addCode 
+addCode
     :: Size
     -> [StixTree]
-    -> SUniqSM Register
+    -> UniqSM Register
 addCode sz [x, StInt y]
   =
-    getReg x	    	    	    `thenSUs` \ register ->
-    getNewRegNCG IntKind    	    `thenSUs` \ tmp ->
+    getReg x	    	    	    `thenUs` \ register ->
+    getNewRegNCG IntRep    	    `thenUs` \ tmp ->
     let
     	code = registerCode register tmp
     	src1 = registerName register tmp
     	src2 = ImmInt (fromInteger y)
-    	code__2 dst = code . 
-                      mkSeqInstr (LEA sz (OpAddr (Addr (Just src1) Nothing src2)) (OpReg dst))
+    	code__2 dst = code .
+		      mkSeqInstr (LEA sz (OpAddr (Addr (Just src1) Nothing src2)) (OpReg dst))
     in
-    	returnSUs (Any IntKind code__2)
+    	returnUs (Any IntRep code__2)
 
 addCode sz [x, StInd _ mem]
-  = getReg x	    	    	    `thenSUs` \ register1 ->
+  = getReg x	    	    	    `thenUs` \ register1 ->
     --getNewRegNCG (registerKind register1)
-    --  	    	        	    `thenSUs` \ tmp1 ->
-    getAmode mem    	    	    `thenSUs` \ amode ->
-    let 
+    --  	    	        	    `thenUs` \ tmp1 ->
+    getAmode mem    	    	    `thenUs` \ amode ->
+    let
     	code2 = amodeCode amode
     	src2  = amodeAddr amode
 
@@ -1212,183 +1198,183 @@ addCode sz [x, StInd _ mem]
     	code__2 dst = let code1 = registerCode register1 dst
     	                  src1  = registerName register1 dst
     	              in asmParThen [code2 asmVoid,code1 asmVoid] .
-                         if isFixed register1 && src1 /= dst
-                         then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst),
-                                           ADD sz (OpAddr src2)  (OpReg dst)]
-                         else 
-                                mkSeqInstrs [ADD sz (OpAddr src2) (OpReg src1)]
+			 if isFixed register1 && src1 /= dst
+			 then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst),
+					   ADD sz (OpAddr src2)  (OpReg dst)]
+			 else
+				mkSeqInstrs [ADD sz (OpAddr src2) (OpReg src1)]
     in
-    	returnSUs (Any IntKind code__2)
+    	returnUs (Any IntRep code__2)
 
 addCode sz [StInd _ mem, y]
-  = getReg y	    	    	    `thenSUs` \ register2 ->
+  = getReg y	    	    	    `thenUs` \ register2 ->
     --getNewRegNCG (registerKind register2)
-    --  	    	        	    `thenSUs` \ tmp2 ->
-    getAmode mem    	    	    `thenSUs` \ amode ->
-    let 
+    --  	    	        	    `thenUs` \ tmp2 ->
+    getAmode mem    	    	    `thenUs` \ amode ->
+    let
     	code1 = amodeCode amode
     	src1  = amodeAddr amode
 
     	fixedname  = registerName register2 eax
     	code__2 dst = let code2 = registerCode register2 dst
-                          src2  = registerName register2 dst
-                      in asmParThen [code1 asmVoid,code2 asmVoid] .
-                         if isFixed register2 && src2 /= dst
-                         then mkSeqInstrs [MOV L (OpReg src2) (OpReg dst),
-                                           ADD sz (OpAddr src1)  (OpReg dst)]
-                         else 
-                                mkSeqInstrs [ADD sz (OpAddr src1) (OpReg src2)]
+			  src2  = registerName register2 dst
+		      in asmParThen [code1 asmVoid,code2 asmVoid] .
+			 if isFixed register2 && src2 /= dst
+			 then mkSeqInstrs [MOV L (OpReg src2) (OpReg dst),
+					   ADD sz (OpAddr src1)  (OpReg dst)]
+			 else
+				mkSeqInstrs [ADD sz (OpAddr src1) (OpReg src2)]
     in
-    	returnSUs (Any IntKind code__2)
+    	returnUs (Any IntRep code__2)
 
 addCode sz [x, y] =
-    getReg x	    	    	    `thenSUs` \ register1 ->
-    getReg y	    	    	    `thenSUs` \ register2 ->
-    getNewRegNCG IntKind    	    `thenSUs` \ tmp1 ->
-    getNewRegNCG IntKind    	    `thenSUs` \ tmp2 ->
+    getReg x	    	    	    `thenUs` \ register1 ->
+    getReg y	    	    	    `thenUs` \ register2 ->
+    getNewRegNCG IntRep    	    `thenUs` \ tmp1 ->
+    getNewRegNCG IntRep    	    `thenUs` \ tmp2 ->
     let
     	code1 = registerCode register1 tmp1 asmVoid
     	src1  = registerName register1 tmp1
     	code2 = registerCode register2 tmp2 asmVoid
     	src2  = registerName register2 tmp2
     	code__2 dst = asmParThen [code1, code2] .
-                      mkSeqInstr (LEA sz (OpAddr (Addr (Just src1) (Just (src2,1)) (ImmInt 0))) (OpReg dst))
+		      mkSeqInstr (LEA sz (OpAddr (Addr (Just src1) (Just (src2,1)) (ImmInt 0))) (OpReg dst))
     in
-    	returnSUs (Any IntKind code__2)
+    	returnUs (Any IntRep code__2)
 
-subCode 
+subCode
     :: Size
     -> [StixTree]
-    -> SUniqSM Register
+    -> UniqSM Register
 subCode sz [x, StInt y]
-  = getReg x	    	    	    `thenSUs` \ register ->
-    getNewRegNCG IntKind    	    `thenSUs` \ tmp ->
+  = getReg x	    	    	    `thenUs` \ register ->
+    getNewRegNCG IntRep    	    `thenUs` \ tmp ->
     let
     	code = registerCode register tmp
     	src1 = registerName register tmp
     	src2 = ImmInt (-(fromInteger y))
-    	code__2 dst = code . 
-                      mkSeqInstr (LEA sz (OpAddr (Addr (Just src1) Nothing src2)) (OpReg dst))
+    	code__2 dst = code .
+		      mkSeqInstr (LEA sz (OpAddr (Addr (Just src1) Nothing src2)) (OpReg dst))
     in
-    	returnSUs (Any IntKind code__2)
+    	returnUs (Any IntRep code__2)
 
 subCode sz args = trivialCode (SUB sz) args False
 
-divCode 
+divCode
     :: Size
     -> [StixTree]
     -> Bool -- True => division, False => remainder operation
-    -> SUniqSM Register
+    -> UniqSM Register
 
--- x must go into eax, edx must be a sign-extension of eax, 
+-- x must go into eax, edx must be a sign-extension of eax,
 -- and y should go in some other register (or memory),
 -- so that we get edx:eax / reg -> eax (remainder in edx)
 -- Currently we chose to put y in memory (if it is not there already)
 divCode sz [x, StInd pk mem] is_division
-  = getReg x		    	    `thenSUs` \ register1 ->
-    getNewRegNCG IntKind    	    `thenSUs` \ tmp1 ->
-    getAmode mem    	    	    `thenSUs` \ amode ->
-    let 
+  = getReg x		    	    `thenUs` \ register1 ->
+    getNewRegNCG IntRep    	    `thenUs` \ tmp1 ->
+    getAmode mem    	    	    `thenUs` \ amode ->
+    let
     	code1 = registerCode register1 tmp1 asmVoid
     	src1 = registerName register1 tmp1
     	code2 = amodeCode amode asmVoid
     	src2  = amodeAddr amode
     	code__2 = asmParThen [code1, code2] .
-                  mkSeqInstrs [MOV L (OpReg src1) (OpReg eax),
-                               CLTD,
-                               IDIV sz (OpAddr src2)]
+		  mkSeqInstrs [MOV L (OpReg src1) (OpReg eax),
+			       CLTD,
+			       IDIV sz (OpAddr src2)]
     in
-        returnSUs (Fixed (if is_division then eax else edx) IntKind code__2)
+	returnUs (Fixed (if is_division then eax else edx) IntRep code__2)
 
 divCode sz [x, StInt i] is_division
-  = getReg x		    	    `thenSUs` \ register1 ->
-    getNewRegNCG IntKind    	    `thenSUs` \ tmp1 ->
+  = getReg x		    	    `thenUs` \ register1 ->
+    getNewRegNCG IntRep    	    `thenUs` \ tmp1 ->
     let
     	code1 = registerCode register1 tmp1 asmVoid
     	src1 = registerName register1 tmp1
     	src2 = ImmInt (fromInteger i)
     	code__2 = asmParThen [code1] .
-                  mkSeqInstrs [-- we put src2 in (ebx)
-                               MOV L (OpImm src2) (OpAddr (Addr (Just ebx) Nothing (ImmInt OFFSET_R1))),
-                               MOV L (OpReg src1) (OpReg eax),
-                               CLTD,
-                               IDIV sz (OpAddr (Addr (Just ebx) Nothing (ImmInt OFFSET_R1)))]
+		  mkSeqInstrs [-- we put src2 in (ebx)
+			       MOV L (OpImm src2) (OpAddr (Addr (Just ebx) Nothing (ImmInt OFFSET_R1))),
+			       MOV L (OpReg src1) (OpReg eax),
+			       CLTD,
+			       IDIV sz (OpAddr (Addr (Just ebx) Nothing (ImmInt OFFSET_R1)))]
     in
-        returnSUs (Fixed (if is_division then eax else edx) IntKind code__2)
+	returnUs (Fixed (if is_division then eax else edx) IntRep code__2)
 
 divCode sz [x, y] is_division
-  = getReg x		    	    `thenSUs` \ register1 ->
-    getNewRegNCG IntKind    	    `thenSUs` \ tmp1 ->
-    getReg y	    	    	    `thenSUs` \ register2 ->
-    getNewRegNCG IntKind    	    `thenSUs` \ tmp2 ->
+  = getReg x		    	    `thenUs` \ register1 ->
+    getNewRegNCG IntRep    	    `thenUs` \ tmp1 ->
+    getReg y	    	    	    `thenUs` \ register2 ->
+    getNewRegNCG IntRep    	    `thenUs` \ tmp2 ->
     let
     	code1 = registerCode register1 tmp1 asmVoid
     	src1 = registerName register1 tmp1
     	code2 = registerCode register2 tmp2 asmVoid
     	src2 = registerName register2 tmp2
     	code__2 = asmParThen [code1, code2] .
-                  if src2 == ecx || src2 == esi
-                  then mkSeqInstrs [ MOV L (OpReg src1) (OpReg eax),
-                                     CLTD,
-                                     IDIV sz (OpReg src2)]
-                  else mkSeqInstrs [ -- we put src2 in (ebx)
-                                     MOV L (OpReg src2) (OpAddr (Addr (Just ebx) Nothing (ImmInt OFFSET_R1))),
-                                     MOV L (OpReg src1) (OpReg eax),
-                                     CLTD,
-                                     IDIV sz (OpAddr (Addr (Just ebx) Nothing (ImmInt OFFSET_R1)))]
+		  if src2 == ecx || src2 == esi
+		  then mkSeqInstrs [ MOV L (OpReg src1) (OpReg eax),
+				     CLTD,
+				     IDIV sz (OpReg src2)]
+		  else mkSeqInstrs [ -- we put src2 in (ebx)
+				     MOV L (OpReg src2) (OpAddr (Addr (Just ebx) Nothing (ImmInt OFFSET_R1))),
+				     MOV L (OpReg src1) (OpReg eax),
+				     CLTD,
+				     IDIV sz (OpAddr (Addr (Just ebx) Nothing (ImmInt OFFSET_R1)))]
     in
-        returnSUs (Fixed (if is_division then eax else edx) IntKind code__2)
+	returnUs (Fixed (if is_division then eax else edx) IntRep code__2)
 
-trivialFCode 
-    :: PrimKind
-    -> (Size -> Operand -> I386Instr) 
+trivialFCode
+    :: PrimRep
+    -> (Size -> Operand -> I386Instr)
     -> (Size -> Operand -> I386Instr) -- reversed instr
     -> I386Instr -- pop
     -> I386Instr -- reversed instr, pop
-    -> [StixTree] 
-    -> SUniqSM Register
+    -> [StixTree]
+    -> UniqSM Register
 trivialFCode pk _ instrr _ _ [StInd pk' mem, y]
-  = getReg y	    	    	    `thenSUs` \ register2 ->
+  = getReg y	    	    	    `thenUs` \ register2 ->
     --getNewRegNCG (registerKind register2)
-    --  	    	        	    `thenSUs` \ tmp2 ->
-    getAmode mem    	    	    `thenSUs` \ amode ->
-    let 
+    --  	    	        	    `thenUs` \ tmp2 ->
+    getAmode mem    	    	    `thenUs` \ amode ->
+    let
     	code1 = amodeCode amode
     	src1  = amodeAddr amode
 
-    	code__2 dst = let 
+    	code__2 dst = let
     	                  code2 = registerCode register2 dst
-                      	  src2  = registerName register2 dst
-                      in asmParThen [code1 asmVoid,code2 asmVoid] .
+		      	  src2  = registerName register2 dst
+		      in asmParThen [code1 asmVoid,code2 asmVoid] .
     	    	         mkSeqInstrs [instrr (kindToSize pk) (OpAddr src1)]
     in
-    	returnSUs (Any pk code__2)
+    	returnUs (Any pk code__2)
 
 trivialFCode pk instr _ _ _ [x, StInd pk' mem]
-  = getReg x	    	    	    `thenSUs` \ register1 ->
+  = getReg x	    	    	    `thenUs` \ register1 ->
     --getNewRegNCG (registerKind register1)
-    --  	    	        	    `thenSUs` \ tmp1 ->
-    getAmode mem    	    	    `thenSUs` \ amode ->
-    let 
+    --  	    	        	    `thenUs` \ tmp1 ->
+    getAmode mem    	    	    `thenUs` \ amode ->
+    let
     	code2 = amodeCode amode
     	src2  = amodeAddr amode
 
-    	code__2 dst = let 
+    	code__2 dst = let
     	                  code1 = registerCode register1 dst
     	                  src1  = registerName register1 dst
-                      in asmParThen [code2 asmVoid,code1 asmVoid] .
+		      in asmParThen [code2 asmVoid,code1 asmVoid] .
     	    	         mkSeqInstrs [instr (kindToSize pk) (OpAddr src2)]
     in
-    	returnSUs (Any pk code__2)
+    	returnUs (Any pk code__2)
 
 trivialFCode pk _ _ _ instrpr [x, y] =
-    getReg x	    	    	    `thenSUs` \ register1 ->
-    getReg y	    	    	    `thenSUs` \ register2 ->
+    getReg x	    	    	    `thenUs` \ register1 ->
+    getReg y	    	    	    `thenUs` \ register2 ->
     --getNewRegNCG (registerKind register1)
-    --  	    	        	    `thenSUs` \ tmp1 ->
+    --  	    	        	    `thenUs` \ tmp1 ->
     --getNewRegNCG (registerKind register2)
-    -- 	    	        	    `thenSUs` \ tmp2 ->
-    getNewRegNCG DoubleKind   	    `thenSUs` \ tmp ->
+    -- 	    	        	    `thenUs` \ tmp2 ->
+    getNewRegNCG DoubleRep   	    `thenUs` \ tmp ->
     let
     	pk1   = registerKind register1
     	code1 = registerCode register1 st0 --tmp1
@@ -1396,13 +1382,13 @@ trivialFCode pk _ _ _ instrpr [x, y] =
 
     	pk2   = registerKind register2
 
-    	code__2 dst = let 
+    	code__2 dst = let
     	                  code2 = registerCode register2 dst
     	                  src2  = registerName register2 dst
     	              in asmParThen [code1 asmVoid, code2 asmVoid] .
-    	    	         mkSeqInstr instrpr 
+    	    	         mkSeqInstr instrpr
     in
-    	returnSUs (Any pk1 code__2)
+    	returnUs (Any pk1 code__2)
 
 \end{code}
 
@@ -1412,52 +1398,52 @@ have handled the constant-folding.
 
 \begin{code}
 
-trivialUCode 
-    :: (Operand -> I386Instr) 
+trivialUCode
+    :: (Operand -> I386Instr)
     -> [StixTree]
-    -> SUniqSM Register
+    -> UniqSM Register
 
 trivialUCode instr [x] =
-    getReg x	    	    	    `thenSUs` \ register ->
---    getNewRegNCG IntKind    	    `thenSUs` \ tmp ->
+    getReg x	    	    	    `thenUs` \ register ->
+--    getNewRegNCG IntRep    	    `thenUs` \ tmp ->
     let
 --    	fixedname = registerName register eax
     	code__2 dst = let
     	                  code = registerCode register dst
-                      	  src  = registerName register dst
-                      in code . if isFixed register && dst /= src
-                                then mkSeqInstrs [MOV L (OpReg src) (OpReg dst),
-                                                  instr (OpReg dst)]
-                                else mkSeqInstr (instr (OpReg src))
+		      	  src  = registerName register dst
+		      in code . if isFixed register && dst /= src
+				then mkSeqInstrs [MOV L (OpReg src) (OpReg dst),
+						  instr (OpReg dst)]
+				else mkSeqInstr (instr (OpReg src))
     in
-        returnSUs (Any IntKind code__2)
+	returnUs (Any IntRep code__2)
 
-trivialUFCode 
-    :: PrimKind
+trivialUFCode
+    :: PrimRep
     -> I386Instr
     -> [StixTree]
-    -> SUniqSM Register
+    -> UniqSM Register
 
 trivialUFCode pk instr [StInd pk' mem] =
-    getAmode mem    	    	    `thenSUs` \ amode ->
-    let 
+    getAmode mem    	    	    `thenUs` \ amode ->
+    let
     	code = amodeCode amode
     	src  = amodeAddr amode
     	code__2 dst = code . mkSeqInstrs [FLD (kindToSize pk) (OpAddr src),
-                                          instr]
+					  instr]
     in
-    	returnSUs (Any pk code__2)
+    	returnUs (Any pk code__2)
 
 trivialUFCode pk instr [x] =
-    getReg x	    	    	    `thenSUs` \ register ->
-    --getNewRegNCG pk        	    `thenSUs` \ tmp ->
+    getReg x	    	    	    `thenUs` \ register ->
+    --getNewRegNCG pk        	    `thenUs` \ tmp ->
     let
     	code__2 dst = let
     	                  code = registerCode register dst
     	                  src  = registerName register dst
-                      in code . mkSeqInstrs [instr]
+		      in code . mkSeqInstrs [instr]
     in
-    	returnSUs (Any pk code__2)
+    	returnUs (Any pk code__2)
 \end{code}
 
 Absolute value on integers, mostly for gmp size check macros.  Again,
@@ -1466,47 +1452,47 @@ constants.
 
 \begin{code}
 
-absIntCode :: [StixTree] -> SUniqSM Register
+absIntCode :: [StixTree] -> UniqSM Register
 absIntCode [x] =
-    getReg x	    	    	    `thenSUs` \ register ->
-    --getNewRegNCG IntKind    	    `thenSUs` \ reg ->
-    getUniqLabelNCG    	    	    `thenSUs` \ lbl ->
+    getReg x	    	    	    `thenUs` \ register ->
+    --getNewRegNCG IntRep    	    `thenUs` \ reg ->
+    getUniqLabelNCG    	    	    `thenUs` \ lbl ->
     let
     	code__2 dst = let code = registerCode register dst
     	                  src  = registerName register dst
-                      in code . if isFixed register && dst /= src
-                                then mkSeqInstrs [MOV L (OpReg src) (OpReg dst),
-                                                  TEST L (OpReg dst) (OpReg dst),
-                                                  JXX GE lbl,
-                                                  NEGI L (OpReg dst),
-                                                  LABEL lbl]
-                                else mkSeqInstrs [TEST L (OpReg src) (OpReg src),
-                                                  JXX GE lbl,
-                                                  NEGI L (OpReg src),
-                                                  LABEL lbl]
+		      in code . if isFixed register && dst /= src
+				then mkSeqInstrs [MOV L (OpReg src) (OpReg dst),
+						  TEST L (OpReg dst) (OpReg dst),
+						  JXX GE lbl,
+						  NEGI L (OpReg dst),
+						  LABEL lbl]
+				else mkSeqInstrs [TEST L (OpReg src) (OpReg src),
+						  JXX GE lbl,
+						  NEGI L (OpReg src),
+						  LABEL lbl]
     in
-    	returnSUs (Any IntKind code__2)
+    	returnUs (Any IntRep code__2)
 
 \end{code}
-                      
+
 Simple integer coercions that don't require any code to be generated.
 Here we just change the type on the register passed on up
 
 \begin{code}
 
-coerceIntCode :: PrimKind -> [StixTree] -> SUniqSM Register
+coerceIntCode :: PrimRep -> [StixTree] -> UniqSM Register
 coerceIntCode pk [x] =
-    getReg x	    	    	    `thenSUs` \ register ->
+    getReg x	    	    	    `thenUs` \ register ->
     case register of
-    	Fixed reg _ code -> returnSUs (Fixed reg pk code)
-    	Any _ code       -> returnSUs (Any pk code)
+    	Fixed reg _ code -> returnUs (Fixed reg pk code)
+    	Any _ code       -> returnUs (Any pk code)
 
-coerceFltCode :: [StixTree] -> SUniqSM Register
+coerceFltCode :: [StixTree] -> UniqSM Register
 coerceFltCode [x] =
-    getReg x	    	    	    `thenSUs` \ register ->
+    getReg x	    	    	    `thenUs` \ register ->
     case register of
-    	Fixed reg _ code -> returnSUs (Fixed reg DoubleKind code)
-    	Any _ code       -> returnSUs (Any DoubleKind code)
+    	Fixed reg _ code -> returnUs (Fixed reg DoubleRep code)
+    	Any _ code       -> returnUs (Any DoubleRep code)
 
 \end{code}
 
@@ -1514,32 +1500,32 @@ Integer to character conversion.  We try to do this in one step if
 the original object is in memory.
 
 \begin{code}
-chrCode :: [StixTree] -> SUniqSM Register
+chrCode :: [StixTree] -> UniqSM Register
 {-
 chrCode [StInd pk mem] =
-    getAmode mem    	    	    `thenSUs` \ amode ->
-    let 
+    getAmode mem    	    	    `thenUs` \ amode ->
+    let
     	code = amodeCode amode
     	src  = amodeAddr amode
     	code__2 dst = code . mkSeqInstr (MOVZX L (OpAddr src) (OpReg dst))
     in
-    	returnSUs (Any pk code__2)
+    	returnUs (Any pk code__2)
 -}
 chrCode [x] =
-    getReg x	    	    	    `thenSUs` \ register ->
-    --getNewRegNCG IntKind    	    `thenSUs` \ reg ->
+    getReg x	    	    	    `thenUs` \ register ->
+    --getNewRegNCG IntRep    	    `thenUs` \ reg ->
     let
     	fixedname = registerName register eax
     	code__2 dst = let
     	                  code = registerCode register dst
     	                  src  = registerName register dst
-                      in code . 
-                         if isFixed register && src /= dst
-                         then mkSeqInstrs [MOV L (OpReg src) (OpReg dst),
-                                           AND L (OpImm (ImmInt 255)) (OpReg dst)]
-                         else mkSeqInstr (AND L (OpImm (ImmInt 255)) (OpReg src))
+		      in code .
+			 if isFixed register && src /= dst
+			 then mkSeqInstrs [MOV L (OpReg src) (OpReg dst),
+					   AND L (OpImm (ImmInt 255)) (OpReg dst)]
+			 else mkSeqInstr (AND L (OpImm (ImmInt 255)) (OpReg src))
     in
-        returnSUs (Any IntKind code__2)
+	returnUs (Any IntRep code__2)
 
 \end{code}
 
@@ -1548,37 +1534,37 @@ temporaries in memory to move between the integer and the floating
 point register sets.
 
 \begin{code}
-coerceInt2FP :: PrimKind -> [StixTree] -> SUniqSM Register
-coerceInt2FP pk [x] = 
-    getReg x	    	    	    `thenSUs` \ register ->
-    getNewRegNCG IntKind      	    `thenSUs` \ reg ->
+coerceInt2FP :: PrimRep -> [StixTree] -> UniqSM Register
+coerceInt2FP pk [x] =
+    getReg x	    	    	    `thenUs` \ register ->
+    getNewRegNCG IntRep      	    `thenUs` \ reg ->
     let
     	code = registerCode register reg
     	src  = registerName register reg
 
     	code__2 dst = code . mkSeqInstrs [
-        -- to fix: should spill instead of using R1
+	-- to fix: should spill instead of using R1
     	              MOV L (OpReg src) (OpAddr (Addr (Just ebx) Nothing (ImmInt OFFSET_R1))),
     	              FILD (kindToSize pk) (Addr (Just ebx) Nothing (ImmInt OFFSET_R1)) dst]
     in
-    	returnSUs (Any pk code__2)
+    	returnUs (Any pk code__2)
 
-coerceFP2Int :: [StixTree] -> SUniqSM Register
+coerceFP2Int :: [StixTree] -> UniqSM Register
 coerceFP2Int [x] =
-    getReg x	    	    	    `thenSUs` \ register ->
-    getNewRegNCG DoubleKind    	    `thenSUs` \ tmp ->
+    getReg x	    	    	    `thenUs` \ register ->
+    getNewRegNCG DoubleRep    	    `thenUs` \ tmp ->
     let
     	code = registerCode register tmp
     	src  = registerName register tmp
     	pk   = registerKind register
 
-    	code__2 dst = let 
-                      in code . mkSeqInstrs [
+    	code__2 dst = let
+		      in code . mkSeqInstrs [
     	                        FRNDINT,
     	                        FIST L (Addr (Just ebx) Nothing (ImmInt OFFSET_R1)),
     	                        MOV L (OpAddr (Addr (Just ebx) Nothing (ImmInt OFFSET_R1))) (OpReg dst)]
     in
-    	returnSUs (Any IntKind code__2)
+    	returnUs (Any IntRep code__2)
 \end{code}
 
 Some random little helpers.
@@ -1586,7 +1572,7 @@ Some random little helpers.
 \begin{code}
 
 maybeImm :: StixTree -> Maybe Imm
-maybeImm (StInt i) 
+maybeImm (StInt i)
   | i >= toInteger minInt && i <= toInteger maxInt = Just (ImmInt (fromInteger i))
   | otherwise = Just (ImmInteger i)
 maybeImm (StLitLbl s)  = Just (ImmLit (uppBeside (uppChar '_') s))
@@ -1596,32 +1582,32 @@ maybeImm _          = Nothing
 
 mangleIndexTree :: StixTree -> StixTree
 
-mangleIndexTree (StIndex pk base (StInt i)) = 
+mangleIndexTree (StIndex pk base (StInt i)) =
     StPrim IntAddOp [base, off]
   where
     off = StInt (i * size pk)
-    size :: PrimKind -> Integer
+    size :: PrimRep -> Integer
     size pk = case kindToSize pk of
     	{B -> 1; S -> 2; L -> 4; F -> 4; D -> 8 }
 
-mangleIndexTree (StIndex pk base off) = 
+mangleIndexTree (StIndex pk base off) =
     case pk of
-    	CharKind -> StPrim IntAddOp [base, off]
+    	CharRep -> StPrim IntAddOp [base, off]
     	_   	 -> StPrim IntAddOp [base, off__2]
   where
     off__2 = StPrim SllOp [off, StInt (shift pk)]
-    shift :: PrimKind -> Integer
-    shift DoubleKind 	= 3
+    shift :: PrimRep -> Integer
+    shift DoubleRep 	= 3
     shift _ 	       	= 2
 
 cvtLitLit :: String -> String
-cvtLitLit "stdin"  = "_IO_stdin_"   
-cvtLitLit "stdout" = "_IO_stdout_" 
+cvtLitLit "stdin"  = "_IO_stdin_"
+cvtLitLit "stdout" = "_IO_stdout_"
 cvtLitLit "stderr" = "_IO_stderr_"
-cvtLitLit s 
+cvtLitLit s
   | isHex s = s
   | otherwise = error ("Native code generator can't handle ``" ++ s ++ "''")
-  where 
+  where
     isHex ('0':'x':xs) = all isHexDigit xs
     isHex _ = False
     -- Now, where have I seen this before?
@@ -1632,16 +1618,16 @@ cvtLitLit s
 
 \begin{code}
 
-stackArgLoc = 23 :: Int	-- where to stack call arguments 
+stackArgLoc = 23 :: Int	-- where to stack call arguments
 
 \end{code}
 
 \begin{code}
 
-getNewRegNCG :: PrimKind -> SUniqSM Reg
-getNewRegNCG pk = 
-      getSUnique          `thenSUs` \ u ->
-      returnSUs (mkReg u pk)
+getNewRegNCG :: PrimRep -> UniqSM Reg
+getNewRegNCG pk =
+      getUnique          `thenUs` \ u ->
+      returnUs (mkReg u pk)
 
 fixFPCond :: Cond -> Cond
 -- on the 486 the flags set by FP compare are the unsigned ones!
diff --git a/ghc/compiler/nativeGen/MachDesc.hi b/ghc/compiler/nativeGen/MachDesc.hi
deleted file mode 100644
index abc8db6c19..0000000000
--- a/ghc/compiler/nativeGen/MachDesc.hi
+++ /dev/null
@@ -1,64 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface MachDesc where
-import AbsCSyn(AbstractC, CAddrMode, CExprMacro, CStmtMacro, MagicId, RegRelative, ReturnInfo)
-import BasicLit(BasicLit)
-import CLabelInfo(CLabel)
-import CharSeq(CSeq)
-import ClosureInfo(ClosureInfo)
-import CmdLineOpts(GlobalSwitch, SwitchResult)
-import CostCentre(CostCentre)
-import HeapOffs(HeapOffset)
-import Maybes(Labda)
-import PreludePS(_PackedString)
-import PreludeRatio(Ratio(..))
-import Pretty(PprStyle)
-import PrimKind(PrimKind)
-import PrimOps(PrimOp)
-import SMRep(SMRep)
-import SplitUniq(SUniqSM(..), SplitUniqSupply)
-import Stix(CodeSegment, StixReg, StixTree, StixTreeList(..))
-import Unique(Unique)
-import Unpretty(Unpretty(..))
-data AbstractC 
-data CAddrMode 
-data CExprMacro 
-data CStmtMacro 
-data MagicId 
-data RegRelative 
-data BasicLit 
-data CLabel 
-data CSeq 
-data GlobalSwitch 
-data RegLoc   = Save StixTree | Always StixTree
-data SwitchResult 
-data HeapOffset 
-data PprStyle 
-data PrimKind 
-data PrimOp 
-data SMRep 
-type SUniqSM a = SplitUniqSupply -> a
-data SplitUniqSupply 
-data StixTree 
-type StixTreeList = [StixTree] -> [StixTree]
-data Target   = Target Int (SMRep -> Int) (MagicId -> RegLoc) (PrimKind -> Int) (HeapOffset -> Int) (CAddrMode -> StixTree) (CAddrMode -> StixTree) ([MagicId] -> [StixTree], [MagicId] -> [StixTree], Int, Int, StixTree, StixTree, [CAddrMode] -> PrimOp -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree], CStmtMacro -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree], StixTree -> StixTree -> StixTree -> SplitUniqSupply -> [StixTree] -> [StixTree])
-data Unique 
-type Unpretty = CSeq
-amodeToStix :: Target -> CAddrMode -> StixTree
-amodeToStix' :: Target -> CAddrMode -> StixTree
-charLikeClosureSize :: Target -> Int
-dataHS :: Target -> StixTree
-fixedHeaderSize :: Target -> Int
-heapCheck :: Target -> StixTree -> StixTree -> StixTree -> SplitUniqSupply -> [StixTree] -> [StixTree]
-hpRel :: Target -> HeapOffset -> Int
-intLikeClosureSize :: Target -> Int
-macroCode :: Target -> CStmtMacro -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]
-mkTarget :: Int -> (SMRep -> Int) -> (MagicId -> RegLoc) -> (PrimKind -> Int) -> (HeapOffset -> Int) -> (CAddrMode -> StixTree) -> (CAddrMode -> StixTree) -> ([MagicId] -> [StixTree], [MagicId] -> [StixTree], Int, Int, StixTree, StixTree, [CAddrMode] -> PrimOp -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree], CStmtMacro -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree], StixTree -> StixTree -> StixTree -> SplitUniqSupply -> [StixTree] -> [StixTree]) -> Target
-mutHS :: Target -> StixTree
-primToStix :: Target -> [CAddrMode] -> PrimOp -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]
-saveLoc :: Target -> MagicId -> StixTree
-sizeof :: Target -> PrimKind -> Int
-stgReg :: Target -> MagicId -> RegLoc
-varHeaderSize :: Target -> SMRep -> Int
-volatileRestores :: Target -> [MagicId] -> [StixTree]
-volatileSaves :: Target -> [MagicId] -> [StixTree]
-
diff --git a/ghc/compiler/nativeGen/MachDesc.lhs b/ghc/compiler/nativeGen/MachDesc.lhs
index 19b0bcb18d..c89d228fb5 100644
--- a/ghc/compiler/nativeGen/MachDesc.lhs
+++ b/ghc/compiler/nativeGen/MachDesc.lhs
@@ -2,7 +2,8 @@
 % (c) The AQUA Project, Glasgow University, 1993-1995
 %
 
-Machine- and flag- specific bits that the abstract code generator has to know about.
+Machine- and flag- specific bits that the abstract code generator has
+to know about.
 
 No doubt there will be more...
 
@@ -10,54 +11,40 @@ No doubt there will be more...
 #include "HsVersions.h"
 
 module MachDesc (
-	Target(..){-(..) for target_STRICT only-}, mkTarget, RegLoc(..), 
+	Target(..){-(..) for target_STRICT only-}, mkTarget, RegLoc(..),
 
     	saveLoc,
 
---	targetSwitches, UNUSED FOR NOW
 	fixedHeaderSize, varHeaderSize, stgReg,
---	nativeOpt, UNUSED FOR NOW
 	sizeof, volatileSaves, volatileRestores, hpRel,
 	amodeToStix, amodeToStix', charLikeClosureSize,
 	intLikeClosureSize, mutHS, dataHS, primToStix, macroCode,
-	heapCheck,
---	codeGen, underscore, fmtAsmLbl, UNUSED FOR NOW (done a diff way)
+	heapCheck
 
 	-- and, for self-sufficiency...
-	AbstractC, CAddrMode, CExprMacro, CStmtMacro, MagicId,
-	RegRelative, CSeq, BasicLit, CLabel, GlobalSwitch,
-	SwitchResult, HeapOffset, PrimOp, PprStyle,
-	PrimKind, SMRep, StixTree, Unique, SplitUniqSupply,
-	StixTreeList(..), SUniqSM(..), Unpretty(..)
     ) where
 
 import AbsCSyn
 import CmdLineOpts  ( GlobalSwitch(..), stringSwitchSet, switchIsOn, SwitchResult(..) )
 import Outputable
 import OrdList	    ( OrdList )
-import PrimKind	    ( PrimKind )
 import SMRep	    ( SMRep )
 import Stix
-import SplitUniq
+import UniqSupply
 import Unique
 import Unpretty	    ( PprStyle, CSeq )
 import Util
 
-data RegLoc = Save (StixTree) | Always (StixTree)
-
+data RegLoc = Save StixTree | Always StixTree
 \end{code}
 
-Think of this as a big runtime class dictionary
-
+Think of this as a big runtime class dictionary:
 \begin{code}
-
 data Target = Target
---  (GlobalSwitch -> SwitchResult)  	-- switches
     Int     	    	    	    	-- fixedHeaderSize
     (SMRep -> Int)     	    	    	-- varHeaderSize
     (MagicId -> RegLoc)     	    	-- stgReg
---  (StixTree -> StixTree)         	-- nativeOpt
-    (PrimKind -> Int)     	    	-- sizeof
+    (PrimRep -> Int)     	    	-- sizeof
     (HeapOffset -> Int)	    	    	-- hpRel
     (CAddrMode -> StixTree)     	-- amodeToStix
     (CAddrMode -> StixTree)     	-- amodeToStix'
@@ -68,61 +55,41 @@ data Target = Target
     Int, 	    	    	    	-- intLikeClosureSize
     StixTree,    	    	    	-- mutHS
     StixTree,    	    	    	-- dataHS
-    ([CAddrMode] -> PrimOp -> [CAddrMode] -> SUniqSM StixTreeList),
+    ([CAddrMode] -> PrimOp -> [CAddrMode] -> UniqSM StixTreeList),
     	    	    	    	    	-- primToStix
-    (CStmtMacro -> [CAddrMode] -> SUniqSM StixTreeList),
+    (CStmtMacro -> [CAddrMode] -> UniqSM StixTreeList),
     	    	    	    	    	-- macroCode
-    (StixTree -> StixTree -> StixTree -> SUniqSM StixTreeList)
+    (StixTree -> StixTree -> StixTree -> UniqSM StixTreeList)
     	    	    	    	    	-- heapCheck
     )
-{- UNUSED: done a diff way:
-    (PprStyle -> [[StixTree]] -> SUniqSM Unpretty)
-    	    	    	    	    	-- codeGen
-
-    Bool    	    	   	    	-- underscore
-    (String -> String)    	    	-- fmtAsmLbl
--}
 
 mkTarget = Target
 
-{- UNUSED FOR NOW:
-targetSwitches (Target {-sw-} fhs vhs reg {-opt-} size hprel am am' ~(vsave, vrest, csz, isz, mhs, dhs, ps, mc, hc) {-cg us fmt-}) x = {-sw-} x
--}
-fixedHeaderSize (Target {-sw-} fhs vhs reg {-opt-} size hprel am am' ~(vsave, vrest, csz, isz, mhs, dhs, ps, mc, hc) {-cg us fmt-}) = fhs
-varHeaderSize (Target {-sw-} fhs vhs reg {-opt-} size hprel am am' ~(vsave, vrest, csz, isz, mhs, dhs, ps, mc, hc) {-cg us fmt-}) x = vhs x
-stgReg (Target {-sw-} fhs vhs reg {-opt-} size hprel am am' ~(vsave, vrest, csz, isz, mhs, dhs, ps, mc, hc) {-cg us fmt-}) x = reg x
-{- UNUSED FOR NOW:
-nativeOpt (Target {-sw-} fhs vhs reg {-opt-} size hprel am am' ~(vsave, vrest, csz, isz, mhs, dhs, ps, mc, hc) {-cg us fmt-}) x = {-opt-} x
--}
-sizeof (Target {-sw-} fhs vhs reg {-opt-} size hprel am am' ~(vsave, vrest, csz, isz, mhs, dhs, ps, mc, hc) {-cg us fmt-}) x = size x
+fixedHeaderSize (Target fhs vhs reg size hprel am am' ~(vsave, vrest, csz, isz, mhs, dhs, ps, mc, hc) ) = fhs
+varHeaderSize (Target fhs vhs reg size hprel am am' ~(vsave, vrest, csz, isz, mhs, dhs, ps, mc, hc) ) x = vhs x
+stgReg (Target fhs vhs reg size hprel am am' ~(vsave, vrest, csz, isz, mhs, dhs, ps, mc, hc) ) x = reg x
+sizeof (Target fhs vhs reg size hprel am am' ~(vsave, vrest, csz, isz, mhs, dhs, ps, mc, hc) ) x = size x
 -- used only for wrapper-hungry PrimOps:
-hpRel (Target {-sw-} fhs vhs reg {-opt-} size hprel am am' ~(vsave, vrest, csz, isz, mhs, dhs, ps, mc, hc) {-cg us fmt-}) x = hprel x
-amodeToStix (Target {-sw-} fhs vhs reg {-opt-} size hprel am am' ~(vsave, vrest, csz, isz, mhs, dhs, ps, mc, hc) {-cg us fmt-}) x = am x
-amodeToStix' (Target {-sw-} fhs vhs reg {-opt-} size hprel am am' ~(vsave, vrest, csz, isz, mhs, dhs, ps, mc, hc) {-cg us fmt-}) x = am' x
+hpRel (Target fhs vhs reg size hprel am am' ~(vsave, vrest, csz, isz, mhs, dhs, ps, mc, hc) ) x = hprel x
+amodeToStix (Target fhs vhs reg size hprel am am' ~(vsave, vrest, csz, isz, mhs, dhs, ps, mc, hc) ) x = am x
+amodeToStix' (Target fhs vhs reg size hprel am am' ~(vsave, vrest, csz, isz, mhs, dhs, ps, mc, hc) ) x = am' x
 
-volatileSaves (Target {-sw-} fhs vhs reg {-opt-} size hprel am am' (vsave, vrest, csz, isz, mhs, dhs, ps, mc, hc) {-cg us fmt-}) x = vsave x
+volatileSaves (Target fhs vhs reg size hprel am am' (vsave, vrest, csz, isz, mhs, dhs, ps, mc, hc) ) x = vsave x
 -- used only for wrapper-hungry PrimOps:
-volatileRestores (Target {-sw-} fhs vhs reg {-opt-} size hprel am am' (vsave, vrest, csz, isz, mhs, dhs, ps, mc, hc) {-cg us fmt-}) x = vrest x
-charLikeClosureSize (Target {-sw-} fhs vhs reg {-opt-} size hprel am am' (vsave, vrest, csz, isz, mhs, dhs, ps, mc, hc) {-cg us fmt-}) = csz
-intLikeClosureSize (Target {-sw-} fhs vhs reg {-opt-} size hprel am am' (vsave, vrest, csz, isz, mhs, dhs, ps, mc, hc) {-cg us fmt-}) = isz
-mutHS (Target {-sw-} fhs vhs reg {-opt-} size hprel am am' (vsave, vrest, csz, isz, mhs, dhs, ps, mc, hc) {-cg us fmt-}) = mhs
-dataHS (Target {-sw-} fhs vhs reg {-opt-} size hprel am am' (vsave, vrest, csz, isz, mhs, dhs, ps, mc, hc) {-cg us fmt-}) = dhs
-primToStix (Target {-sw-} fhs vhs reg {-opt-} size hprel am am' (vsave, vrest, csz, isz, mhs, dhs, ps, mc, hc) {-cg us fmt-}) x y z = ps x y z
-macroCode (Target {-sw-} fhs vhs reg {-opt-} size hprel am am' (vsave, vrest, csz, isz, mhs, dhs, ps, mc, hc) {-cg us fmt-}) x y = mc x y
-heapCheck (Target {-sw-} fhs vhs reg {-opt-} size hprel am am' (vsave, vrest, csz, isz, mhs, dhs, ps, mc, hc) {-cg us fmt-}) x y z = hc x y z
-{- UNUSED: done a diff way:
-codeGen (Target {-sw-} fhs vhs reg {-opt-} size hprel am am' (vsave, vrest, csz, isz, mhs, dhs, ps, mc, hc) {-cg us fmt-}) x y = cg x y
-underscore (Target {-sw-} fhs vhs reg {-opt-} size hprel am am' (vsave, vrest, csz, isz, mhs, dhs, ps, mc, hc) {-cg us fmt-}) = us
-fmtAsmLbl (Target {-sw-} fhs vhs reg {-opt-} size hprel am am' (vsave, vrest, csz, isz, mhs, dhs, ps, mc, hc) {-cg us fmt-}) x = fmt x
--}
+volatileRestores (Target fhs vhs reg size hprel am am' (vsave, vrest, csz, isz, mhs, dhs, ps, mc, hc) ) x = vrest x
+charLikeClosureSize (Target fhs vhs reg size hprel am am' (vsave, vrest, csz, isz, mhs, dhs, ps, mc, hc) ) = csz
+intLikeClosureSize (Target fhs vhs reg size hprel am am' (vsave, vrest, csz, isz, mhs, dhs, ps, mc, hc) ) = isz
+mutHS (Target fhs vhs reg size hprel am am' (vsave, vrest, csz, isz, mhs, dhs, ps, mc, hc) ) = mhs
+dataHS (Target fhs vhs reg size hprel am am' (vsave, vrest, csz, isz, mhs, dhs, ps, mc, hc) ) = dhs
+primToStix (Target fhs vhs reg size hprel am am' (vsave, vrest, csz, isz, mhs, dhs, ps, mc, hc) ) x y z = ps x y z
+macroCode (Target fhs vhs reg size hprel am am' (vsave, vrest, csz, isz, mhs, dhs, ps, mc, hc) ) x y = mc x y
+heapCheck (Target fhs vhs reg size hprel am am' (vsave, vrest, csz, isz, mhs, dhs, ps, mc, hc) ) x y z = hc x y z
 \end{code}
 
 Trees for register save locations
-
 \begin{code}
-
 saveLoc :: Target -> MagicId -> StixTree
-saveLoc target reg = case stgReg target reg of {Always loc -> loc; Save loc -> loc}
 
+saveLoc target reg = case stgReg target reg of {Always loc -> loc; Save loc -> loc}
 \end{code}
 
diff --git a/ghc/compiler/nativeGen/SparcCode.hi b/ghc/compiler/nativeGen/SparcCode.hi
deleted file mode 100644
index a2004a4ee4..0000000000
--- a/ghc/compiler/nativeGen/SparcCode.hi
+++ /dev/null
@@ -1,56 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface SparcCode where
-import AbsCSyn(MagicId)
-import AsmRegAlloc(MachineCode, MachineRegisters, Reg)
-import BitSet(BitSet)
-import CLabelInfo(CLabel)
-import CharSeq(CSeq)
-import FiniteMap(FiniteMap)
-import Maybes(Labda)
-import OrdList(OrdList)
-import PreludePS(_PackedString)
-import Pretty(PprStyle)
-import PrimKind(PrimKind)
-import Stix(CodeSegment)
-import UniqFM(UniqFM)
-import UniqSet(UniqSet(..))
-import Unique(Unique)
-data Addr   = AddrRegReg Reg Reg | AddrRegImm Reg Imm
-data MagicId 
-data Reg 
-data BitSet 
-data CLabel 
-data CSeq 
-data FiniteMap a b 
-data OrdList a 
-data PrimKind 
-data CodeSegment 
-data Cond   = ALWAYS | NEVER | GEU | LU | EQ | GT | GE | GU | LT | LE | LEU | NE | NEG | POS | VC | VS
-data Imm   = ImmInt Int | ImmInteger Integer | ImmCLbl CLabel | ImmLab CSeq | ImmLit CSeq | LO Imm | HI Imm
-data RI   = RIReg Reg | RIImm Imm
-data Size   = SB | HW | UB | UHW | W | D | F | DF
-type SparcCode = OrdList SparcInstr
-data SparcInstr   = LD Size Addr Reg | ST Size Reg Addr | ADD Bool Bool Reg RI Reg | SUB Bool Bool Reg RI Reg | AND Bool Reg RI Reg | ANDN Bool Reg RI Reg | OR Bool Reg RI Reg | ORN Bool Reg RI Reg | XOR Bool Reg RI Reg | XNOR Bool Reg RI Reg | SLL Reg RI Reg | SRL Reg RI Reg | SRA Reg RI Reg | SETHI Imm Reg | NOP | FABS Size Reg Reg | FADD Size Reg Reg Reg | FCMP Bool Size Reg Reg | FDIV Size Reg Reg Reg | FMOV Size Reg Reg | FMUL Size Reg Reg Reg | FNEG Size Reg Reg | FSQRT Size Reg Reg | FSUB Size Reg Reg Reg | FxTOy Size Size Reg Reg | BI Cond Bool Imm | BF Cond Bool Imm | JMP Addr | CALL Imm Int Bool | LABEL CLabel | COMMENT _PackedString | SEGMENT CodeSegment | ASCII Bool [Char] | DATA Size [Imm]
-data SparcRegs 
-data UniqFM a 
-type UniqSet a = UniqFM a
-data Unique 
-argRegs :: [Reg]
-baseRegOffset :: MagicId -> Int
-callerSaves :: MagicId -> Bool
-f0 :: Reg
-fp :: Reg
-freeRegs :: [Reg]
-g0 :: Reg
-is13Bits :: Integral a => a -> Bool
-kindToSize :: PrimKind -> Size
-o0 :: Reg
-offset :: Addr -> Int -> Labda Addr
-printLabeledCodes :: PprStyle -> [SparcInstr] -> CSeq
-reservedRegs :: [Int]
-sp :: Reg
-stgRegMap :: MagicId -> Labda Reg
-strImmLit :: [Char] -> Imm
-instance MachineCode SparcInstr
-instance MachineRegisters SparcRegs
-
diff --git a/ghc/compiler/nativeGen/SparcCode.lhs b/ghc/compiler/nativeGen/SparcCode.lhs
index e068093f18..203807e5d0 100644
--- a/ghc/compiler/nativeGen/SparcCode.lhs
+++ b/ghc/compiler/nativeGen/SparcCode.lhs
@@ -11,7 +11,7 @@
 module SparcCode (
 	Addr(..),Cond(..),Imm(..),RI(..),Size(..),
 	SparcCode(..),SparcInstr(..),SparcRegs,
-	strImmLit, --UNUSED: strImmLab,
+	strImmLit,
 
     	printLabeledCodes,
 
@@ -23,11 +23,9 @@ module SparcCode (
 
     	g0, o0, f0, fp, sp, argRegs,
 
-    	freeRegs, reservedRegs,
+    	freeRegs, reservedRegs
 
 	-- and, for self-sufficiency ...
-	CLabel, CodeSegment, OrdList, PrimKind, Reg, UniqSet(..),
-	UniqFM, FiniteMap, Unique, MagicId, CSeq, BitSet
     ) where
 
 IMPORT_Trace
@@ -36,14 +34,13 @@ import AbsCSyn	    	( MagicId(..) )
 import AsmRegAlloc  	( MachineCode(..), MachineRegisters(..), FutureLive(..),
     	    	    	  Reg(..), RegUsage(..), RegLiveness(..)
     	    	    	)
-import BitSet	 
+import BitSet
 import CgCompInfo   	( mAX_Double_REG, mAX_Float_REG, mAX_Vanilla_REG )
-import CLabelInfo   	( CLabel, pprCLabel, externallyVisibleCLabel, charToC )
-import FiniteMap    
+import CLabel   	( CLabel, pprCLabel, externallyVisibleCLabel, charToC )
+import FiniteMap
 import Maybes	    	( Maybe(..), maybeToBool )
 import OrdList	    	( OrdList, mkUnitList, flattenOrdList )
-import Outputable    
-import PrimKind	    	( PrimKind(..) )
+import Outputable
 import UniqSet
 import Stix
 import Unpretty
@@ -108,7 +105,6 @@ data Imm = ImmInt Int
 	 | HI Imm
 	 deriving ()
 
---UNUSED:strImmLab s = ImmLab (uppStr s)
 strImmLit s = ImmLit (uppStr s)
 
 data Addr = AddrRegReg Reg Reg
@@ -241,37 +237,37 @@ pprReg other = uppStr (show other)   -- should only happen when debugging
 pprSparcReg :: FAST_INT -> Unpretty
 pprSparcReg i = uppPStr
     (case i of {
-        ILIT( 0) -> SLIT("%g0");  ILIT( 1) -> SLIT("%g1");
+	ILIT( 0) -> SLIT("%g0");  ILIT( 1) -> SLIT("%g1");
 	ILIT( 2) -> SLIT("%g2");  ILIT( 3) -> SLIT("%g3");
-        ILIT( 4) -> SLIT("%g4");  ILIT( 5) -> SLIT("%g5");
+	ILIT( 4) -> SLIT("%g4");  ILIT( 5) -> SLIT("%g5");
 	ILIT( 6) -> SLIT("%g6");  ILIT( 7) -> SLIT("%g7");
-        ILIT( 8) -> SLIT("%o0");  ILIT( 9) -> SLIT("%o1");
+	ILIT( 8) -> SLIT("%o0");  ILIT( 9) -> SLIT("%o1");
 	ILIT(10) -> SLIT("%o2");  ILIT(11) -> SLIT("%o3");
-        ILIT(12) -> SLIT("%o4");  ILIT(13) -> SLIT("%o5");
+	ILIT(12) -> SLIT("%o4");  ILIT(13) -> SLIT("%o5");
 	ILIT(14) -> SLIT("%o6");  ILIT(15) -> SLIT("%o7");
-        ILIT(16) -> SLIT("%l0");  ILIT(17) -> SLIT("%l1");
+	ILIT(16) -> SLIT("%l0");  ILIT(17) -> SLIT("%l1");
 	ILIT(18) -> SLIT("%l2");  ILIT(19) -> SLIT("%l3");
-        ILIT(20) -> SLIT("%l4");  ILIT(21) -> SLIT("%l5");
+	ILIT(20) -> SLIT("%l4");  ILIT(21) -> SLIT("%l5");
 	ILIT(22) -> SLIT("%l6");  ILIT(23) -> SLIT("%l7");
-        ILIT(24) -> SLIT("%i0");  ILIT(25) -> SLIT("%i1");
+	ILIT(24) -> SLIT("%i0");  ILIT(25) -> SLIT("%i1");
 	ILIT(26) -> SLIT("%i2");  ILIT(27) -> SLIT("%i3");
-        ILIT(28) -> SLIT("%i4");  ILIT(29) -> SLIT("%i5");
+	ILIT(28) -> SLIT("%i4");  ILIT(29) -> SLIT("%i5");
 	ILIT(30) -> SLIT("%i6");  ILIT(31) -> SLIT("%i7");
-        ILIT(32) -> SLIT("%f0");  ILIT(33) -> SLIT("%f1");
+	ILIT(32) -> SLIT("%f0");  ILIT(33) -> SLIT("%f1");
 	ILIT(34) -> SLIT("%f2");  ILIT(35) -> SLIT("%f3");
-        ILIT(36) -> SLIT("%f4");  ILIT(37) -> SLIT("%f5");
+	ILIT(36) -> SLIT("%f4");  ILIT(37) -> SLIT("%f5");
 	ILIT(38) -> SLIT("%f6");  ILIT(39) -> SLIT("%f7");
-        ILIT(40) -> SLIT("%f8");  ILIT(41) -> SLIT("%f9");
+	ILIT(40) -> SLIT("%f8");  ILIT(41) -> SLIT("%f9");
 	ILIT(42) -> SLIT("%f10"); ILIT(43) -> SLIT("%f11");
-        ILIT(44) -> SLIT("%f12"); ILIT(45) -> SLIT("%f13");
+	ILIT(44) -> SLIT("%f12"); ILIT(45) -> SLIT("%f13");
 	ILIT(46) -> SLIT("%f14"); ILIT(47) -> SLIT("%f15");
-        ILIT(48) -> SLIT("%f16"); ILIT(49) -> SLIT("%f17");
+	ILIT(48) -> SLIT("%f16"); ILIT(49) -> SLIT("%f17");
 	ILIT(50) -> SLIT("%f18"); ILIT(51) -> SLIT("%f19");
-        ILIT(52) -> SLIT("%f20"); ILIT(53) -> SLIT("%f21");
+	ILIT(52) -> SLIT("%f20"); ILIT(53) -> SLIT("%f21");
 	ILIT(54) -> SLIT("%f22"); ILIT(55) -> SLIT("%f23");
-        ILIT(56) -> SLIT("%f24"); ILIT(57) -> SLIT("%f25");
+	ILIT(56) -> SLIT("%f24"); ILIT(57) -> SLIT("%f25");
 	ILIT(58) -> SLIT("%f26"); ILIT(59) -> SLIT("%f27");
-        ILIT(60) -> SLIT("%f28"); ILIT(61) -> SLIT("%f29");
+	ILIT(60) -> SLIT("%f28"); ILIT(61) -> SLIT("%f29");
 	ILIT(62) -> SLIT("%f30"); ILIT(63) -> SLIT("%f31");
 	_ -> SLIT("very naughty sparc register")
     })
@@ -675,9 +671,9 @@ pprSparcInstr sty (ASCII True str) = uppBeside (uppStr "\t.ascii \"") (asciify s
     	asciify :: String -> Int -> Unpretty
     	asciify [] _ = uppStr ("\\0\"")
     	asciify s n | n <= 0 = uppBeside (uppStr "\"\n\t.ascii \"") (asciify s 60)
-        asciify ('\\':cs) n = uppBeside (uppStr "\\\\") (asciify cs (n-1))
-        asciify ('\"':cs) n = uppBeside (uppStr "\\\"") (asciify cs (n-1))
-        asciify (c:cs) n | isPrint c = uppBeside (uppChar c) (asciify cs (n-1))
+	asciify ('\\':cs) n = uppBeside (uppStr "\\\\") (asciify cs (n-1))
+	asciify ('\"':cs) n = uppBeside (uppStr "\\\"") (asciify cs (n-1))
+	asciify (c:cs) n | isPrint c = uppBeside (uppChar c) (asciify cs (n-1))
     	asciify [c] _ = uppBeside (uppStr (charToC c)) (uppStr ("\\0\""))
     	asciify (c:(cs@(d:_))) n | isDigit d =
     	    	    	    	    	uppBeside (uppStr (charToC c)) (asciify cs 0)
@@ -701,7 +697,7 @@ pprSparcInstr sty (DATA s xs) = uppInterleave (uppChar '\n') (map pp_item xs)
 
 Getting the conflicts right is a bit tedious for doubles.  We'd have to
 add a conflict function to the MachineRegisters class, and we'd have to
-put a PrimKind in the MappedReg datatype, or use some kludge (e.g. register
+put a PrimRep in the MappedReg datatype, or use some kludge (e.g. register
 64 + n is really the same as 32 + n, except that it's used for a double,
 so it also conflicts with 33 + n) to deal with it.  It's just not worth the
 bother, so we just partition the free floating point registers into two
@@ -718,10 +714,10 @@ instance MachineRegisters SparcRegs where
     	(ints, floats) = partition (< 32) xs
     	(singles, doubles) = partition (< 48) floats
     	singles' = map (subtract 32) singles
-        doubles' = map (subtract 32) (filter even doubles)
+	doubles' = map (subtract 32) (filter even doubles)
 
-    possibleMRegs FloatKind (SRegs _ singles _) = [ x + 32 | x <- listBS singles]
-    possibleMRegs DoubleKind (SRegs _ _ doubles) = [ x + 32 | x <- listBS doubles]
+    possibleMRegs FloatRep (SRegs _ singles _) = [ x + 32 | x <- listBS singles]
+    possibleMRegs DoubleRep (SRegs _ _ doubles) = [ x + 32 | x <- listBS doubles]
     possibleMRegs _ (SRegs ints _ _) = listBS ints
 
     useMReg (SRegs ints singles doubles) n =
@@ -734,7 +730,7 @@ instance MachineRegisters SparcRegs where
     	      (singles `minusBS` singles')
     	      (doubles `minusBS` doubles')
       where
-        SRegs ints' singles' doubles' = mkMRegs xs
+	SRegs ints' singles' doubles' = mkMRegs xs
 
     freeMReg (SRegs ints singles doubles) n =
     	if n _LT_ ILIT(32) then SRegs (ints `unionBS` singletonBS IBOX(n)) singles doubles
@@ -742,17 +738,13 @@ instance MachineRegisters SparcRegs where
     	else SRegs ints singles (doubles `unionBS` singletonBS (IBOX(n _SUB_ ILIT(32))))
 
     freeMRegs (SRegs ints singles doubles) xs =
-        SRegs (ints `unionBS` ints')
+	SRegs (ints `unionBS` ints')
     	      (singles `unionBS` singles')
     	      (doubles `unionBS` doubles')
       where
-        SRegs ints' singles' doubles' = mkMRegs xs
+	SRegs ints' singles' doubles' = mkMRegs xs
 
 instance MachineCode SparcInstr where
-    -- Alas, we don't do anything clever with our OrdLists
---OLD:
---  flatten = flattenOrdList
-
     regUsage = sparcRegUsage
     regLiveness = sparcRegLiveness
     patchRegs = sparcPatchRegs
@@ -765,23 +757,22 @@ instance MachineCode SparcInstr where
 fpRel :: Int -> Addr
 fpRel n = AddrRegImm fp (ImmInt (n * 4))
 
-kindToSize :: PrimKind -> Size
-kindToSize PtrKind	    = W
-kindToSize CodePtrKind	    = W
-kindToSize DataPtrKind	    = W
-kindToSize RetKind	    = W
-kindToSize InfoPtrKind	    = W
-kindToSize CostCentreKind   = W
-kindToSize CharKind	    = UB
-kindToSize IntKind	    = W
-kindToSize WordKind	    = W
-kindToSize AddrKind	    = W
-kindToSize FloatKind	    = F
-kindToSize DoubleKind	    = DF
-kindToSize ArrayKind	    = W
-kindToSize ByteArrayKind    = W
-kindToSize StablePtrKind    = W
-kindToSize MallocPtrKind    = W
+kindToSize :: PrimRep -> Size
+kindToSize PtrRep	    = W
+kindToSize CodePtrRep	    = W
+kindToSize DataPtrRep	    = W
+kindToSize RetRep	    = W
+kindToSize CostCentreRep   = W
+kindToSize CharRep	    = UB
+kindToSize IntRep	    = W
+kindToSize WordRep	    = W
+kindToSize AddrRep	    = W
+kindToSize FloatRep	    = F
+kindToSize DoubleRep	    = DF
+kindToSize ArrayRep	    = W
+kindToSize ByteArrayRep    = W
+kindToSize StablePtrRep    = W
+kindToSize MallocPtrRep    = W
 
 \end{code}
 
@@ -912,7 +903,7 @@ sparcRegLiveness instr info@(RL live future@(FL all env)) = case instr of
     lookup lbl = case lookupFM env lbl of
 	Just regs -> regs
 	Nothing -> trace ("Missing " ++ (uppShow 80 (pprCLabel (PprForAsm (\_->False) False id) lbl)) ++
-                          " in future?") emptyUniqSet
+			  " in future?") emptyUniqSet
 
 \end{code}
 
@@ -962,9 +953,6 @@ Sometimes, we want to be able to modify addresses at compile time.
 (Okay, just for chrCode of a fetch.)
 
 \begin{code}
-
-#ifdef __GLASGOW_HASKELL__
-
 {-# SPECIALIZE
     is13Bits :: Int -> Bool
   #-}
@@ -972,8 +960,6 @@ Sometimes, we want to be able to modify addresses at compile time.
     is13Bits :: Integer -> Bool
   #-}
 
-#endif
-
 is13Bits :: Integral a => a -> Bool
 is13Bits x = x >= -4096 && x < 4096
 
diff --git a/ghc/compiler/nativeGen/SparcDesc.hi b/ghc/compiler/nativeGen/SparcDesc.hi
deleted file mode 100644
index 9d40f7ca7f..0000000000
--- a/ghc/compiler/nativeGen/SparcDesc.hi
+++ /dev/null
@@ -1,24 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface SparcDesc where
-import AbsCSyn(MagicId)
-import CLabelInfo(CLabel)
-import CharSeq(CSeq)
-import CmdLineOpts(GlobalSwitch, SwitchResult)
-import MachDesc(RegLoc, Target)
-import PreludePS(_PackedString)
-import PreludeRatio(Ratio(..))
-import Pretty(PprStyle)
-import PrimKind(PrimKind)
-import PrimOps(PrimOp)
-import SMRep(SMRep, SMSpecRepKind, SMUpdateKind)
-import SplitUniq(SplitUniqSupply)
-import Stix(CodeSegment, StixReg, StixTree)
-data MagicId 
-data SwitchResult 
-data RegLoc 
-data PprStyle 
-data PrimKind 
-data SMRep 
-data StixTree 
-mkSparc :: Bool -> (GlobalSwitch -> SwitchResult) -> (Target, PprStyle -> [[StixTree]] -> SplitUniqSupply -> CSeq, Bool, [Char] -> [Char])
-
diff --git a/ghc/compiler/nativeGen/SparcDesc.lhs b/ghc/compiler/nativeGen/SparcDesc.lhs
index 0a0de397be..8445399b60 100644
--- a/ghc/compiler/nativeGen/SparcDesc.lhs
+++ b/ghc/compiler/nativeGen/SparcDesc.lhs
@@ -7,40 +7,34 @@
 #include "HsVersions.h"
 
 module SparcDesc (
-    	mkSparc,
+    	mkSparc
 
     	-- and assorted nonsense referenced by the class methods
-
-        PprStyle, SMRep, MagicId, RegLoc, StixTree, PrimKind, SwitchResult
-
     ) where
 
 import AbsCSyn
-import AbsPrel	    ( PrimOp(..)
+import PrelInfo	    ( PrimOp(..)
 		      IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
 			  IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
 		    )
 import AsmRegAlloc  ( Reg, MachineCode(..), MachineRegisters(..),
 		      RegLiveness(..), RegUsage(..), FutureLive(..)
 		    )
-import CLabelInfo   ( CLabel )
+import CLabel   ( CLabel )
 import CmdLineOpts  ( GlobalSwitch(..), stringSwitchSet, switchIsOn, SwitchResult(..) )
 import HeapOffs	    ( hpRelToInt )
 import MachDesc
 import Maybes	    ( Maybe(..) )
 import OrdList
 import Outputable
-import PrimKind	    ( PrimKind(..) )
 import SMRep	    ( SMRep(..), SMSpecRepKind(..), SMUpdateKind(..) )
 import SparcCode
 import SparcGen	    ( sparcCodeGen )
 import Stix
 import StixMacro
 import StixPrim
-import SplitUniq
-import Unique
+import UniqSupply
 import Util
-
 \end{code}
 
 Header sizes depend only on command-line options, not on the target
@@ -87,11 +81,11 @@ sparcReg switches x =
     	    StkStubReg -> sStLitLbl SLIT("STK_STUB_closure")
     	    StdUpdRetVecReg -> sStLitLbl SLIT("vtbl_StdUpdFrame")
     	    BaseReg -> sStLitLbl SLIT("MainRegTable")
-    	    Hp -> StInd PtrKind (sStLitLbl SLIT("StorageMgrInfo"))
-    	    HpLim -> StInd PtrKind (sStLitLbl SLIT("StorageMgrInfo+4"))
-    	    TagReg -> StInd IntKind (StPrim IntSubOp [infoptr, StInt (1*4)])
-    	    	      where 
-    	    	    	  r2 = VanillaReg PtrKind ILIT(2)
+    	    Hp -> StInd PtrRep (sStLitLbl SLIT("StorageMgrInfo"))
+    	    HpLim -> StInd PtrRep (sStLitLbl SLIT("StorageMgrInfo+4"))
+    	    TagReg -> StInd IntRep (StPrim IntSubOp [infoptr, StInt (1*4)])
+    	    	      where
+    	    	    	  r2 = VanillaReg PtrRep ILIT(2)
     	    	    	  infoptr = case sparcReg switches r2 of
     	    	    	    	    	Always tree -> tree
     	    	    	    	    	Save _ -> StReg (StixMagicId r2)
@@ -100,8 +94,8 @@ sparcReg switches x =
     	  baseLoc = case stgRegMap BaseReg of
     	    Just _ -> StReg (StixMagicId BaseReg)
     	    Nothing -> sStLitLbl SLIT("MainRegTable")
-          offset = baseRegOffset x
-		    
+	  offset = baseRegOffset x
+
 \end{code}
 
 Sizes in bytes.
@@ -119,20 +113,20 @@ because some are reloaded from constants.
 
 \begin{code}
 
-vsaves switches vols = 
+vsaves switches vols =
     map save ((filter callerSaves) ([BaseReg,SpA,SuA,SpB,SuB,Hp,HpLim,RetReg{-,ActivityReg-}] ++ vols))
     where
-        save x = StAssign (kindFromMagicId x) loc reg
+	save x = StAssign (kindFromMagicId x) loc reg
     	    	    where reg = StReg (StixMagicId x)
     	    	    	  loc = case sparcReg switches x of
     	    	    	    	    Save loc -> loc
     	    	    	    	    Always loc -> panic "vsaves"
 
-vrests switches vols = 
-    map restore ((filter callerSaves) 
+vrests switches vols =
+    map restore ((filter callerSaves)
     	([BaseReg,SpA,SuA,SpB,SuB,Hp,HpLim,RetReg{-,ActivityReg-},StkStubReg,StdUpdRetVecReg] ++ vols))
     where
-        restore x = StAssign (kindFromMagicId x) reg loc
+	restore x = StAssign (kindFromMagicId x) reg loc
     	    	    where reg = StReg (StixMagicId x)
     	    	    	  loc = case sparcReg switches x of
     	    	    	    	    Save loc -> loc
@@ -146,22 +140,22 @@ Static closure sizes.
 
 charLikeSize, intLikeSize :: Target -> Int
 
-charLikeSize target = 
-    size PtrKind * (fixedHeaderSize target + varHeaderSize target charLikeRep + 1)
+charLikeSize target =
+    size PtrRep * (fixedHeaderSize target + varHeaderSize target charLikeRep + 1)
     where charLikeRep = SpecialisedRep CharLikeRep 0 1 SMNormalForm
 
-intLikeSize target = 
-    size PtrKind * (fixedHeaderSize target + varHeaderSize target intLikeRep + 1)
+intLikeSize target =
+    size PtrRep * (fixedHeaderSize target + varHeaderSize target intLikeRep + 1)
     where intLikeRep = SpecialisedRep IntLikeRep 0 1 SMNormalForm
 
 mhs, dhs :: (GlobalSwitch -> SwitchResult) -> StixTree
 
 mhs switches = StInt (toInteger words)
-  where 
+  where
     words = fhs switches + vhs switches (MuTupleRep 0)
 
 dhs switches = StInt (toInteger words)
-  where 
+  where
     words = fhs switches + vhs switches (DataRep 0)
 
 \end{code}
@@ -173,27 +167,27 @@ Setting up a sparc target.
 mkSparc :: Bool
 	-> (GlobalSwitch -> SwitchResult)
 	-> (Target,
-	    (PprStyle -> [[StixTree]] -> SUniqSM Unpretty), -- codeGen
+	    (PprStyle -> [[StixTree]] -> UniqSM Unpretty), -- codeGen
 	    Bool,					    -- underscore
 	    (String -> String))				    -- fmtAsmLbl
 
-mkSparc decentOS switches = 
+mkSparc decentOS switches =
     let
 	fhs' = fhs switches
     	vhs' = vhs switches
     	sparcReg' = sparcReg switches
     	vsaves' = vsaves switches
     	vrests' = vrests switches
-    	hprel = hpRelToInt target 
-        as = amodeCode target
-        as' = amodeCode' target
+    	hprel = hpRelToInt target
+	as = amodeCode target
+	as' = amodeCode' target
     	csz = charLikeSize target
     	isz = intLikeSize target
     	mhs' = mhs switches
     	dhs' = dhs switches
     	ps = genPrimCode target
     	mc = genMacroCode target
-    	hc = doHeapCheck --UNUSED NOW: target
+    	hc = doHeapCheck
     	target = mkTarget {-switches-} fhs' vhs' sparcReg' {-id-} size
     	    	    	  hprel as as'
 			  (vsaves', vrests', csz, isz, mhs', dhs', ps, mc, hc)
diff --git a/ghc/compiler/nativeGen/SparcGen.hi b/ghc/compiler/nativeGen/SparcGen.hi
deleted file mode 100644
index 2a32fbcc63..0000000000
--- a/ghc/compiler/nativeGen/SparcGen.hi
+++ /dev/null
@@ -1,17 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface SparcGen where
-import CLabelInfo(CLabel)
-import CharSeq(CSeq)
-import CmdLineOpts(GlobalSwitch)
-import PreludePS(_PackedString)
-import PreludeRatio(Ratio(..))
-import Pretty(PprStyle)
-import PrimKind(PrimKind)
-import PrimOps(PrimOp)
-import SplitUniq(SplitUniqSupply)
-import Stix(CodeSegment, StixReg, StixTree)
-data CSeq 
-data PprStyle 
-data StixTree 
-sparcCodeGen :: PprStyle -> [[StixTree]] -> SplitUniqSupply -> CSeq
-
diff --git a/ghc/compiler/nativeGen/SparcGen.lhs b/ghc/compiler/nativeGen/SparcGen.lhs
index b271591dec..f5046d79e1 100644
--- a/ghc/compiler/nativeGen/SparcGen.lhs
+++ b/ghc/compiler/nativeGen/SparcGen.lhs
@@ -15,31 +15,28 @@ module SparcGen (
 IMPORT_Trace
 
 import AbsCSyn	    ( AbstractC, MagicId(..), kindFromMagicId )
-import AbsPrel	    ( PrimOp(..)
+import PrelInfo	    ( PrimOp(..)
 		      IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
 			  IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
 		    )
 import AsmRegAlloc  ( runRegAllocate, mkReg, extractMappedRegNos,
-		      Reg(..), RegLiveness(..), RegUsage(..), 
+		      Reg(..), RegLiveness(..), RegUsage(..),
     	    	      FutureLive(..), MachineRegisters(..), MachineCode(..)
     	    	    )
-import CLabelInfo   ( CLabel, isAsmTemp )
+import CLabel   ( CLabel, isAsmTemp )
 import SparcCode    {- everything -}
 import MachDesc
 import Maybes	    ( maybeToBool, Maybe(..) )
 import OrdList	    -- ( mkEmptyList, mkUnitList, mkSeqList, mkParList, OrdList )
 import Outputable
-import PrimKind	    ( PrimKind(..), isFloatingKind )
 import SparcDesc
 import Stix
-import SplitUniq
-import Unique
+import UniqSupply
 import Pretty
 import Unpretty
 import Util
 
 type CodeBlock a = (OrdList a -> OrdList a)
-
 \end{code}
 
 %************************************************************************
@@ -52,14 +49,14 @@ This is the top-level code-generation function for the Sparc.
 
 \begin{code}
 
-sparcCodeGen :: PprStyle -> [[StixTree]] -> SUniqSM Unpretty
-sparcCodeGen sty trees = 
-    mapSUs genSparcCode trees	    	`thenSUs` \ dynamicCodes ->
+sparcCodeGen :: PprStyle -> [[StixTree]] -> UniqSM Unpretty
+sparcCodeGen sty trees =
+    mapUs genSparcCode trees	    	`thenUs` \ dynamicCodes ->
     let
     	staticCodes = scheduleSparcCode dynamicCodes
     	pretty = printLabeledCodes sty staticCodes
     in
-    	returnSUs pretty
+    	returnUs pretty
 
 \end{code}
 
@@ -85,9 +82,9 @@ register to put it in.
 
 \begin{code}
 
-data Register 
-  = Fixed Reg PrimKind (CodeBlock SparcInstr) 
-  | Any PrimKind (Reg -> (CodeBlock SparcInstr))
+data Register
+  = Fixed Reg PrimRep (CodeBlock SparcInstr)
+  | Any PrimRep (Reg -> (CodeBlock SparcInstr))
 
 registerCode :: Register -> Reg -> CodeBlock SparcInstr
 registerCode (Fixed _ _ code) reg = code
@@ -97,7 +94,7 @@ registerName :: Register -> Reg -> Reg
 registerName (Fixed reg _ _) _ = reg
 registerName (Any _ _) reg = reg
 
-registerKind :: Register -> PrimKind
+registerKind :: Register -> PrimRep
 registerKind (Fixed _ pk _) = pk
 registerKind (Any pk _) = pk
 
@@ -146,14 +143,14 @@ asmSeq is = foldr (mkSeqList . asmInstr) asmVoid is
 asmParThen :: [SparcCode] -> (CodeBlock SparcInstr)
 asmParThen others code = mkSeqList (foldr mkParList mkEmptyList others) code
 
-returnInstr :: SparcInstr -> SUniqSM (CodeBlock SparcInstr)
-returnInstr instr = returnSUs (\xs -> mkSeqList (asmInstr instr) xs)
+returnInstr :: SparcInstr -> UniqSM (CodeBlock SparcInstr)
+returnInstr instr = returnUs (\xs -> mkSeqList (asmInstr instr) xs)
 
-returnInstrs :: [SparcInstr] -> SUniqSM (CodeBlock SparcInstr)
-returnInstrs instrs = returnSUs (\xs -> mkSeqList (asmSeq instrs) xs)
+returnInstrs :: [SparcInstr] -> UniqSM (CodeBlock SparcInstr)
+returnInstrs instrs = returnUs (\xs -> mkSeqList (asmSeq instrs) xs)
 
-returnSeq :: (CodeBlock SparcInstr) -> [SparcInstr] -> SUniqSM (CodeBlock SparcInstr)
-returnSeq code instrs = returnSUs (\xs -> code (mkSeqList (asmSeq instrs) xs))
+returnSeq :: (CodeBlock SparcInstr) -> [SparcInstr] -> UniqSM (CodeBlock SparcInstr)
+returnSeq code instrs = returnUs (\xs -> code (mkSeqList (asmSeq instrs) xs))
 
 mkSeqInstr :: SparcInstr -> (CodeBlock SparcInstr)
 mkSeqInstr instr code = mkSeqList (asmInstr instr) code
@@ -167,11 +164,11 @@ Top level sparc code generator for a chunk of stix code.
 
 \begin{code}
 
-genSparcCode :: [StixTree] -> SUniqSM (SparcCode)
+genSparcCode :: [StixTree] -> UniqSM (SparcCode)
 
 genSparcCode trees =
-    mapSUs getCode trees    	    	`thenSUs` \ blocks ->
-    returnSUs (foldr (.) id blocks asmVoid)
+    mapUs getCode trees    	    	`thenUs` \ blocks ->
+    returnUs (foldr (.) id blocks asmVoid)
 
 \end{code}
 
@@ -179,50 +176,44 @@ Code extractor for an entire stix tree---stix statement level.
 
 \begin{code}
 
-getCode 
+getCode
     :: StixTree     -- a stix statement
-    -> SUniqSM (CodeBlock SparcInstr)
+    -> UniqSM (CodeBlock SparcInstr)
 
 getCode (StSegment seg) = returnInstr (SEGMENT seg)
 
 getCode (StAssign pk dst src)
-  | isFloatingKind pk = assignFltCode pk dst src
+  | isFloatingRep pk = assignFltCode pk dst src
   | otherwise = assignIntCode pk dst src
 
 getCode (StLabel lab) = returnInstr (LABEL lab)
 
 getCode (StFunBegin lab) = returnInstr (LABEL lab)
 
-getCode (StFunEnd lab) = returnSUs id
+getCode (StFunEnd lab) = returnUs id
 
 getCode (StJump arg) = genJump arg
 
-getCode (StFallThrough lbl) = returnSUs id
+getCode (StFallThrough lbl) = returnUs id
 
 getCode (StCondJump lbl arg) = genCondJump lbl arg
 
-getCode (StData kind args) = 
-    mapAndUnzipSUs getData args		    `thenSUs` \ (codes, imms) ->
-    returnSUs (\xs -> mkSeqList (asmInstr (DATA (kindToSize kind) imms))
-                                (foldr1 (.) codes xs))
+getCode (StData kind args) =
+    mapAndUnzipUs getData args		    `thenUs` \ (codes, imms) ->
+    returnUs (\xs -> mkSeqList (asmInstr (DATA (kindToSize kind) imms))
+				(foldr1 (.) codes xs))
   where
-    getData :: StixTree -> SUniqSM (CodeBlock SparcInstr, Imm)
-    getData (StInt i) = returnSUs (id, ImmInteger i)
-#if __GLASGOW_HASKELL__ >= 23
---  getData (StDouble d) = returnSUs (id, strImmLit ('0' : 'r' : _showRational 30 d))
-    -- yurgh (WDP 94/12)
-    getData (StDouble d) = returnSUs (id, strImmLit ('0' : 'r' : ppShow 80 (ppRational d)))
-#else
-    getData (StDouble d) = returnSUs (id, strImmLit ('0' : 'r' : show d))
-#endif
-    getData (StLitLbl s) = returnSUs (id, ImmLab s)
-    getData (StLitLit s) = returnSUs (id, strImmLit (cvtLitLit (_UNPK_ s)))
-    getData (StString s) = 
-        getUniqLabelNCG 	    	    `thenSUs` \ lbl ->
-	returnSUs (mkSeqInstrs [LABEL lbl, ASCII True (_UNPK_ s)], ImmCLbl lbl)
-    getData (StCLbl l)   = returnSUs (id, ImmCLbl l)
-
-getCode (StCall fn VoidKind args) = genCCall fn VoidKind args
+    getData :: StixTree -> UniqSM (CodeBlock SparcInstr, Imm)
+    getData (StInt i) = returnUs (id, ImmInteger i)
+    getData (StDouble d) = returnUs (id, strImmLit ('0' : 'r' : ppShow 80 (ppRational d)))
+    getData (StLitLbl s) = returnUs (id, ImmLab s)
+    getData (StLitLit s) = returnUs (id, strImmLit (cvtLitLit (_UNPK_ s)))
+    getData (StString s) =
+	getUniqLabelNCG 	    	    `thenUs` \ lbl ->
+	returnUs (mkSeqInstrs [LABEL lbl, ASCII True (_UNPK_ s)], ImmCLbl lbl)
+    getData (StCLbl l)   = returnUs (id, ImmCLbl l)
+
+getCode (StCall fn VoidRep args) = genCCall fn VoidRep args
 
 getCode (StComment s) = returnInstr (COMMENT s)
 
@@ -232,35 +223,30 @@ Generate code to get a subtree into a register.
 
 \begin{code}
 
-getReg :: StixTree -> SUniqSM Register
+getReg :: StixTree -> UniqSM Register
 
 getReg (StReg (StixMagicId stgreg)) =
     case stgRegMap stgreg of
-    	Just reg -> returnSUs (Fixed reg (kindFromMagicId stgreg) id)
+    	Just reg -> returnUs (Fixed reg (kindFromMagicId stgreg) id)
     	-- cannae be Nothing
 
-getReg (StReg (StixTemp u pk)) = returnSUs (Fixed (UnmappedReg u pk) pk id)
+getReg (StReg (StixTemp u pk)) = returnUs (Fixed (UnmappedReg u pk) pk id)
 
 getReg (StDouble d) =
-    getUniqLabelNCG 	    	    `thenSUs` \ lbl ->
-    getNewRegNCG PtrKind    	    `thenSUs` \ tmp ->
+    getUniqLabelNCG 	    	    `thenUs` \ lbl ->
+    getNewRegNCG PtrRep    	    `thenUs` \ tmp ->
     let code dst = mkSeqInstrs [
     	    SEGMENT DataSegment,
 	    LABEL lbl,
-#if __GLASGOW_HASKELL__ >= 23
---	    DATA DF [strImmLit ('0' : 'r' : (_showRational 30 d))],
 	    DATA DF [strImmLit ('0' : 'r' : ppShow  80 (ppRational d))],
-#else
-	    DATA DF [strImmLit ('0' : 'r' : (show d))],
-#endif
 	    SEGMENT TextSegment,
 	    SETHI (HI (ImmCLbl lbl)) tmp,
 	    LD DF (AddrRegImm tmp (LO (ImmCLbl lbl))) dst]
     in
-    	returnSUs (Any DoubleKind code)
+    	returnUs (Any DoubleRep code)
 
 getReg (StString s) =
-    getUniqLabelNCG 	    	    `thenSUs` \ lbl ->
+    getUniqLabelNCG 	    	    `thenUs` \ lbl ->
     let code dst = mkSeqInstrs [
 	    SEGMENT DataSegment,
 	    LABEL lbl,
@@ -269,10 +255,10 @@ getReg (StString s) =
 	    SETHI (HI (ImmCLbl lbl)) dst,
 	    OR False dst (RIImm (LO (ImmCLbl lbl))) dst]
     in
-    	returnSUs (Any PtrKind code)
+    	returnUs (Any PtrRep code)
 
 getReg (StLitLit s) | _HEAD_ s == '"' && last xs == '"' =
-    getUniqLabelNCG 	    	    `thenSUs` \ lbl ->
+    getUniqLabelNCG 	    	    `thenUs` \ lbl ->
     let code dst = mkSeqInstrs [
 	    SEGMENT DataSegment,
 	    LABEL lbl,
@@ -281,19 +267,19 @@ getReg (StLitLit s) | _HEAD_ s == '"' && last xs == '"' =
 	    SETHI (HI (ImmCLbl lbl)) dst,
 	    OR False dst (RIImm (LO (ImmCLbl lbl))) dst]
     in
-    	returnSUs (Any PtrKind code)
+    	returnUs (Any PtrRep code)
   where
     xs = _UNPK_ (_TAIL_ s)
 
 getReg tree@(StIndex _ _ _) = getReg (mangleIndexTree tree)
 
-getReg (StCall fn kind args) = 
-    genCCall fn kind args   	    `thenSUs` \ call ->
-    returnSUs (Fixed reg kind call)
+getReg (StCall fn kind args) =
+    genCCall fn kind args   	    `thenUs` \ call ->
+    returnUs (Fixed reg kind call)
   where
-    reg = if isFloatingKind kind then f0 else o0
+    reg = if isFloatingRep kind then f0 else o0
 
-getReg (StPrim primop args) = 
+getReg (StPrim primop args) =
     case primop of
 
     	CharGtOp -> condIntReg GT args
@@ -306,12 +292,12 @@ getReg (StPrim primop args) =
     	IntAddOp -> trivialCode (ADD False False) args
 
     	IntSubOp -> trivialCode (SUB False False) args
-    	IntMulOp -> call SLIT(".umul") IntKind
-    	IntQuotOp -> call SLIT(".div") IntKind
-    	IntRemOp -> call SLIT(".rem") IntKind
+    	IntMulOp -> call SLIT(".umul") IntRep
+    	IntQuotOp -> call SLIT(".div") IntRep
+    	IntRemOp -> call SLIT(".rem") IntRep
     	IntNegOp -> trivialUCode (SUB False False g0) args
     	IntAbsOp -> absIntCode args
-   
+
     	AndOp -> trivialCode (AND False) args
     	OrOp  -> trivialCode (OR False) args
     	NotOp -> trivialUCode (XNOR False g0) args
@@ -321,14 +307,14 @@ getReg (StPrim primop args) =
     	ISllOp -> panic "SparcGen:isll"
     	ISraOp -> panic "SparcGen:isra"
     	ISrlOp -> panic "SparcGen:isrl"
-   
+
     	IntGtOp -> condIntReg GT args
     	IntGeOp -> condIntReg GE args
     	IntEqOp -> condIntReg EQ args
     	IntNeOp -> condIntReg NE args
     	IntLtOp -> condIntReg LT args
     	IntLeOp -> condIntReg LE args
-   
+
     	WordGtOp -> condIntReg GU args
     	WordGeOp -> condIntReg GEU args
     	WordEqOp -> condIntReg EQ args
@@ -343,11 +329,11 @@ getReg (StPrim primop args) =
     	AddrLtOp -> condIntReg LU args
     	AddrLeOp -> condIntReg LEU args
 
-    	FloatAddOp -> trivialFCode FloatKind FADD args
-    	FloatSubOp -> trivialFCode FloatKind FSUB args
-    	FloatMulOp -> trivialFCode FloatKind FMUL args
-    	FloatDivOp -> trivialFCode FloatKind FDIV args
-    	FloatNegOp -> trivialUFCode FloatKind (FNEG F) args
+    	FloatAddOp -> trivialFCode FloatRep FADD args
+    	FloatSubOp -> trivialFCode FloatRep FSUB args
+    	FloatMulOp -> trivialFCode FloatRep FMUL args
+    	FloatDivOp -> trivialFCode FloatRep FDIV args
+    	FloatNegOp -> trivialUFCode FloatRep (FNEG F) args
 
     	FloatGtOp -> condFltReg GT args
     	FloatGeOp -> condFltReg GE args
@@ -356,30 +342,30 @@ getReg (StPrim primop args) =
     	FloatLtOp -> condFltReg LT args
     	FloatLeOp -> condFltReg LE args
 
-    	FloatExpOp -> promoteAndCall SLIT("exp") DoubleKind
-    	FloatLogOp -> promoteAndCall SLIT("log") DoubleKind
-    	FloatSqrtOp -> promoteAndCall SLIT("sqrt") DoubleKind
-       
-    	FloatSinOp -> promoteAndCall SLIT("sin") DoubleKind
-    	FloatCosOp -> promoteAndCall SLIT("cos") DoubleKind
-    	FloatTanOp -> promoteAndCall SLIT("tan") DoubleKind
-       
-    	FloatAsinOp -> promoteAndCall SLIT("asin") DoubleKind
-    	FloatAcosOp -> promoteAndCall SLIT("acos") DoubleKind
-    	FloatAtanOp -> promoteAndCall SLIT("atan") DoubleKind
-       
-    	FloatSinhOp -> promoteAndCall SLIT("sinh") DoubleKind
-    	FloatCoshOp -> promoteAndCall SLIT("cosh") DoubleKind
-    	FloatTanhOp -> promoteAndCall SLIT("tanh") DoubleKind
-       
-    	FloatPowerOp -> promoteAndCall SLIT("pow") DoubleKind
-
-    	DoubleAddOp -> trivialFCode DoubleKind FADD args
-    	DoubleSubOp -> trivialFCode DoubleKind FSUB args
-    	DoubleMulOp -> trivialFCode DoubleKind FMUL args
-   	DoubleDivOp -> trivialFCode DoubleKind FDIV args
-    	DoubleNegOp -> trivialUFCode DoubleKind (FNEG DF) args
-   
+    	FloatExpOp -> promoteAndCall SLIT("exp") DoubleRep
+    	FloatLogOp -> promoteAndCall SLIT("log") DoubleRep
+    	FloatSqrtOp -> promoteAndCall SLIT("sqrt") DoubleRep
+
+    	FloatSinOp -> promoteAndCall SLIT("sin") DoubleRep
+    	FloatCosOp -> promoteAndCall SLIT("cos") DoubleRep
+    	FloatTanOp -> promoteAndCall SLIT("tan") DoubleRep
+
+    	FloatAsinOp -> promoteAndCall SLIT("asin") DoubleRep
+    	FloatAcosOp -> promoteAndCall SLIT("acos") DoubleRep
+    	FloatAtanOp -> promoteAndCall SLIT("atan") DoubleRep
+
+    	FloatSinhOp -> promoteAndCall SLIT("sinh") DoubleRep
+    	FloatCoshOp -> promoteAndCall SLIT("cosh") DoubleRep
+    	FloatTanhOp -> promoteAndCall SLIT("tanh") DoubleRep
+
+    	FloatPowerOp -> promoteAndCall SLIT("pow") DoubleRep
+
+    	DoubleAddOp -> trivialFCode DoubleRep FADD args
+    	DoubleSubOp -> trivialFCode DoubleRep FSUB args
+    	DoubleMulOp -> trivialFCode DoubleRep FMUL args
+   	DoubleDivOp -> trivialFCode DoubleRep FDIV args
+    	DoubleNegOp -> trivialUFCode DoubleRep (FNEG DF) args
+
     	DoubleGtOp -> condFltReg GT args
     	DoubleGeOp -> condFltReg GE args
     	DoubleEqOp -> condFltReg EQ args
@@ -387,67 +373,67 @@ getReg (StPrim primop args) =
     	DoubleLtOp -> condFltReg LT args
     	DoubleLeOp -> condFltReg LE args
 
-    	DoubleExpOp -> call SLIT("exp") DoubleKind
-    	DoubleLogOp -> call SLIT("log") DoubleKind
-    	DoubleSqrtOp -> call SLIT("sqrt") DoubleKind
-
-    	DoubleSinOp -> call SLIT("sin") DoubleKind
-    	DoubleCosOp -> call SLIT("cos") DoubleKind
-    	DoubleTanOp -> call SLIT("tan") DoubleKind
-       
-    	DoubleAsinOp -> call SLIT("asin") DoubleKind
-    	DoubleAcosOp -> call SLIT("acos") DoubleKind
-    	DoubleAtanOp -> call SLIT("atan") DoubleKind
-       
-    	DoubleSinhOp -> call SLIT("sinh") DoubleKind
-    	DoubleCoshOp -> call SLIT("cosh") DoubleKind
-    	DoubleTanhOp -> call SLIT("tanh") DoubleKind
-       
-    	DoublePowerOp -> call SLIT("pow") DoubleKind
-
-    	OrdOp -> coerceIntCode IntKind args
+    	DoubleExpOp -> call SLIT("exp") DoubleRep
+    	DoubleLogOp -> call SLIT("log") DoubleRep
+    	DoubleSqrtOp -> call SLIT("sqrt") DoubleRep
+
+    	DoubleSinOp -> call SLIT("sin") DoubleRep
+    	DoubleCosOp -> call SLIT("cos") DoubleRep
+    	DoubleTanOp -> call SLIT("tan") DoubleRep
+
+    	DoubleAsinOp -> call SLIT("asin") DoubleRep
+    	DoubleAcosOp -> call SLIT("acos") DoubleRep
+    	DoubleAtanOp -> call SLIT("atan") DoubleRep
+
+    	DoubleSinhOp -> call SLIT("sinh") DoubleRep
+    	DoubleCoshOp -> call SLIT("cosh") DoubleRep
+    	DoubleTanhOp -> call SLIT("tanh") DoubleRep
+
+    	DoublePowerOp -> call SLIT("pow") DoubleRep
+
+    	OrdOp -> coerceIntCode IntRep args
     	ChrOp -> chrCode args
-       
+
     	Float2IntOp -> coerceFP2Int args
-    	Int2FloatOp -> coerceInt2FP FloatKind args
+    	Int2FloatOp -> coerceInt2FP FloatRep args
     	Double2IntOp -> coerceFP2Int args
-    	Int2DoubleOp -> coerceInt2FP DoubleKind args
-       
-    	Double2FloatOp -> trivialUFCode FloatKind (FxTOy DF F) args
-    	Float2DoubleOp -> trivialUFCode DoubleKind (FxTOy F DF) args
+    	Int2DoubleOp -> coerceInt2FP DoubleRep args
+
+    	Double2FloatOp -> trivialUFCode FloatRep (FxTOy DF F) args
+    	Float2DoubleOp -> trivialUFCode DoubleRep (FxTOy F DF) args
 
   where
     call fn pk = getReg (StCall fn pk args)
     promoteAndCall fn pk = getReg (StCall fn pk (map promote args))
       where
-        promote x = StPrim Float2DoubleOp [x]
+	promote x = StPrim Float2DoubleOp [x]
 
 getReg (StInd pk mem) =
-    getAmode mem    	    	    `thenSUs` \ amode ->
-    let 
+    getAmode mem    	    	    `thenUs` \ amode ->
+    let
     	code = amodeCode amode
     	src   = amodeAddr amode
     	size = kindToSize pk
     	code__2 dst = code . mkSeqInstr (LD size src dst)
     in
-    	returnSUs (Any pk code__2)
+    	returnUs (Any pk code__2)
 
 getReg (StInt i)
-  | is13Bits i = 
+  | is13Bits i =
     let
     	src = ImmInt (fromInteger i)
     	code dst = mkSeqInstr (OR False g0 (RIImm src) dst)
     in
-    	returnSUs (Any IntKind code)
+    	returnUs (Any IntRep code)
 
 getReg leaf
   | maybeToBool imm =
     let
     	code dst = mkSeqInstrs [
-    	    SETHI (HI imm__2) dst, 
+    	    SETHI (HI imm__2) dst,
     	    OR False dst (RIImm (LO imm__2)) dst]
     in
-    	returnSUs (Any PtrKind code)
+    	returnUs (Any PtrRep code)
   where
     imm = maybeImm leaf
     imm__2 = case imm of Just x -> x
@@ -459,38 +445,38 @@ produce a suitable addressing mode.
 
 \begin{code}
 
-getAmode :: StixTree -> SUniqSM Amode
+getAmode :: StixTree -> UniqSM Amode
 
 getAmode tree@(StIndex _ _ _) = getAmode (mangleIndexTree tree)
 
 getAmode (StPrim IntSubOp [x, StInt i])
   | is13Bits (-i) =
-    getNewRegNCG PtrKind    	    `thenSUs` \ tmp ->
-    getReg x    	    	    `thenSUs` \ register ->
+    getNewRegNCG PtrRep    	    `thenUs` \ tmp ->
+    getReg x    	    	    `thenUs` \ register ->
     let
     	code = registerCode register tmp
     	reg  = registerName register tmp
     	off  = ImmInt (-(fromInteger i))
     in
-    	returnSUs (Amode (AddrRegImm reg off) code)
+    	returnUs (Amode (AddrRegImm reg off) code)
 
 
 getAmode (StPrim IntAddOp [x, StInt i])
   | is13Bits i =
-    getNewRegNCG PtrKind    	    `thenSUs` \ tmp ->
-    getReg x    	    	    `thenSUs` \ register ->
+    getNewRegNCG PtrRep    	    `thenUs` \ tmp ->
+    getReg x    	    	    `thenUs` \ register ->
     let
     	code = registerCode register tmp
     	reg  = registerName register tmp
     	off  = ImmInt (fromInteger i)
     in
-    	returnSUs (Amode (AddrRegImm reg off) code)
+    	returnUs (Amode (AddrRegImm reg off) code)
 
 getAmode (StPrim IntAddOp [x, y]) =
-    getNewRegNCG PtrKind    	    `thenSUs` \ tmp1 ->
-    getNewRegNCG IntKind    	    `thenSUs` \ tmp2 ->
-    getReg x    	    	    `thenSUs` \ register1 ->
-    getReg y    	    	    `thenSUs` \ register2 ->
+    getNewRegNCG PtrRep    	    `thenUs` \ tmp1 ->
+    getNewRegNCG IntRep    	    `thenUs` \ tmp2 ->
+    getReg x    	    	    `thenUs` \ register1 ->
+    getReg y    	    	    `thenUs` \ register2 ->
     let
     	code1 = registerCode register1 tmp1 asmVoid
     	reg1  = registerName register1 tmp1
@@ -498,28 +484,28 @@ getAmode (StPrim IntAddOp [x, y]) =
     	reg2  = registerName register2 tmp2
     	code__2 = asmParThen [code1, code2]
     in
-    	returnSUs (Amode (AddrRegReg reg1 reg2) code__2)
+    	returnUs (Amode (AddrRegReg reg1 reg2) code__2)
 
 getAmode leaf
   | maybeToBool imm =
-    getNewRegNCG PtrKind    	    `thenSUs` \ tmp ->
+    getNewRegNCG PtrRep    	    `thenUs` \ tmp ->
     let
     	code = mkSeqInstr (SETHI (HI imm__2) tmp)
     in
-    	returnSUs (Amode (AddrRegImm tmp (LO imm__2)) code)
+    	returnUs (Amode (AddrRegImm tmp (LO imm__2)) code)
   where
     imm = maybeImm leaf
     imm__2 = case imm of Just x -> x
 
 getAmode other =
-    getNewRegNCG PtrKind    	    `thenSUs` \ tmp ->
-    getReg other    	    	    `thenSUs` \ register ->
+    getNewRegNCG PtrRep    	    `thenUs` \ tmp ->
+    getReg other    	    	    `thenUs` \ register ->
     let
     	code = registerCode register tmp
     	reg  = registerName register tmp
     	off  = ImmInt 0
     in
-    	returnSUs (Amode (AddrRegImm reg off) code)
+    	returnUs (Amode (AddrRegImm reg off) code)
 
 \end{code}
 
@@ -533,25 +519,25 @@ to all of a call's arguments using @mapAccumL@.
 
 \begin{code}
 
-getCallArg 
+getCallArg
     :: ([Reg],Int)   	    -- Argument registers and stack offset (accumulator)
     -> StixTree 	    -- Current argument
-    -> SUniqSM (([Reg],Int), CodeBlock SparcInstr)    -- Updated accumulator and code
+    -> UniqSM (([Reg],Int), CodeBlock SparcInstr)    -- Updated accumulator and code
 
 -- We have to use up all of our argument registers first.
 
-getCallArg (dst:dsts, offset) arg = 
-    getReg arg	    	    	    `thenSUs` \ register ->
+getCallArg (dst:dsts, offset) arg =
+    getReg arg	    	    	    `thenUs` \ register ->
     getNewRegNCG (registerKind register)
-    	    	        	    `thenSUs` \ tmp ->
+    	    	        	    `thenUs` \ tmp ->
     let
-    	reg = if isFloatingKind pk then tmp else dst
+    	reg = if isFloatingRep pk then tmp else dst
     	code = registerCode register reg
     	src = registerName register reg
     	pk = registerKind register
     in
-    	returnSUs (case pk of
-    	    DoubleKind ->
+    	returnUs (case pk of
+    	    DoubleRep ->
     	    	case dsts of
     	    	    [] -> (([], offset + 1), code . mkSeqInstrs [
     	    	    	    -- conveniently put the second part in the right stack
@@ -559,30 +545,30 @@ getCallArg (dst:dsts, offset) arg =
     	    	    	    ST DF src (spRel (offset - 1)),
     	    	    	    LD W (spRel (offset - 1)) dst])
     	    	    (dst__2:dsts__2) -> ((dsts__2, offset), code . mkSeqInstrs [
-    	    	    	    ST DF src (spRel (-2)), 
-    	    	    	    LD W (spRel (-2)) dst, 
+    	    	    	    ST DF src (spRel (-2)),
+    	    	    	    LD W (spRel (-2)) dst,
     	    	    	    LD W (spRel (-1)) dst__2])
-    	    FloatKind -> ((dsts, offset), code . mkSeqInstrs [
+    	    FloatRep -> ((dsts, offset), code . mkSeqInstrs [
     	    	    	    ST F src (spRel (-2)),
     	    	    	    LD W (spRel (-2)) dst])
-    	    _ -> ((dsts, offset), if isFixed register then 
+    	    _ -> ((dsts, offset), if isFixed register then
     	    	    	    	  code . mkSeqInstr (OR False g0 (RIReg src) dst)
     	    	    	    	  else code))
 
 -- Once we have run out of argument registers, we move to the stack
 
-getCallArg ([], offset) arg = 
-    getReg arg	    	    	    `thenSUs` \ register ->
+getCallArg ([], offset) arg =
+    getReg arg	    	    	    `thenUs` \ register ->
     getNewRegNCG (registerKind register)
-    	    	        	    `thenSUs` \ tmp ->
-    let 
+    	    	        	    `thenUs` \ tmp ->
+    let
     	code = registerCode register tmp
     	src = registerName register tmp
     	pk = registerKind register
     	sz = kindToSize pk
-    	words = if pk == DoubleKind then 2 else 1
+    	words = if pk == DoubleRep then 2 else 1
     in
-    	returnSUs (([], offset + words), code . mkSeqInstr (ST sz src (spRel offset)))
+    	returnUs (([], offset + words), code . mkSeqInstr (ST sz src (spRel offset)))
 
 \end{code}
 
@@ -590,9 +576,9 @@ Set up a condition code for a conditional branch.
 
 \begin{code}
 
-getCondition :: StixTree -> SUniqSM Condition
+getCondition :: StixTree -> UniqSM Condition
 
-getCondition (StPrim primop args) = 
+getCondition (StPrim primop args) =
     case primop of
 
     	CharGtOp -> condIntCode GT args
@@ -608,7 +594,7 @@ getCondition (StPrim primop args) =
     	IntNeOp -> condIntCode NE args
    	IntLtOp -> condIntCode LT args
     	IntLeOp -> condIntCode LE args
-   
+
     	WordGtOp -> condIntCode GU args
     	WordGeOp -> condIntCode GEU args
     	WordEqOp -> condIntCode EQ args
@@ -644,43 +630,43 @@ back up the tree.
 
 \begin{code}
 
-condIntCode, condFltCode :: Cond -> [StixTree] -> SUniqSM Condition
+condIntCode, condFltCode :: Cond -> [StixTree] -> UniqSM Condition
 
 condIntCode cond [x, StInt y]
   | is13Bits y =
-    getReg x	    	    	    `thenSUs` \ register ->
-    getNewRegNCG IntKind    	    `thenSUs` \ tmp ->
+    getReg x	    	    	    `thenUs` \ register ->
+    getNewRegNCG IntRep    	    `thenUs` \ tmp ->
     let
-        code = registerCode register tmp
-        src1 = registerName register tmp
+	code = registerCode register tmp
+	src1 = registerName register tmp
     	src2 = ImmInt (fromInteger y)
-        code__2 = code . mkSeqInstr (SUB False True src1 (RIImm src2) g0)
+	code__2 = code . mkSeqInstr (SUB False True src1 (RIImm src2) g0)
     in
-        returnSUs (Condition False cond code__2)
+	returnUs (Condition False cond code__2)
 
 condIntCode cond [x, y] =
-    getReg x	    	    	    `thenSUs` \ register1 ->
-    getReg y	    	    	    `thenSUs` \ register2 ->
-    getNewRegNCG IntKind    	    `thenSUs` \ tmp1 ->
-    getNewRegNCG IntKind    	    `thenSUs` \ tmp2 ->
+    getReg x	    	    	    `thenUs` \ register1 ->
+    getReg y	    	    	    `thenUs` \ register2 ->
+    getNewRegNCG IntRep    	    `thenUs` \ tmp1 ->
+    getNewRegNCG IntRep    	    `thenUs` \ tmp2 ->
     let
-        code1 = registerCode register1 tmp1 asmVoid
-        src1  = registerName register1 tmp1
-        code2 = registerCode register2 tmp2 asmVoid
-        src2  = registerName register2 tmp2
-        code__2 = asmParThen [code1, code2] . 
+	code1 = registerCode register1 tmp1 asmVoid
+	src1  = registerName register1 tmp1
+	code2 = registerCode register2 tmp2 asmVoid
+	src2  = registerName register2 tmp2
+	code__2 = asmParThen [code1, code2] .
     	    	mkSeqInstr (SUB False True src1 (RIReg src2) g0)
     in
-        returnSUs (Condition False cond code__2)
+	returnUs (Condition False cond code__2)
 
 condFltCode cond [x, y] =
-    getReg x	    	    	    `thenSUs` \ register1 ->
-    getReg y	    	    	    `thenSUs` \ register2 ->
+    getReg x	    	    	    `thenUs` \ register1 ->
+    getReg y	    	    	    `thenUs` \ register2 ->
     getNewRegNCG (registerKind register1)
-      	    	        	    `thenSUs` \ tmp1 ->
+      	    	        	    `thenUs` \ tmp1 ->
     getNewRegNCG (registerKind register2)
-     	    	        	    `thenSUs` \ tmp2 ->
-    getNewRegNCG DoubleKind   	    `thenSUs` \ tmp ->
+     	    	        	    `thenUs` \ tmp2 ->
+    getNewRegNCG DoubleRep   	    `thenUs` \ tmp ->
     let
     	promote x = asmInstr (FxTOy F DF x tmp)
 
@@ -692,18 +678,18 @@ condFltCode cond [x, y] =
     	code2 = registerCode register2 tmp2
     	src2  = registerName register2 tmp2
 
-    	code__2 = 
+    	code__2 =
     	    	if pk1 == pk2 then
     	            asmParThen [code1 asmVoid, code2 asmVoid] .
     	    	    mkSeqInstr (FCMP True (kindToSize pk1) src1 src2)
-    	    	else if pk1 == FloatKind then
+    	    	else if pk1 == FloatRep then
     	    	    asmParThen [code1 (promote src1), code2 asmVoid] .
     	    	    mkSeqInstr (FCMP True DF tmp src2)
     	    	else
-    	    	    asmParThen [code1 asmVoid, code2 (promote src2)] .	
+    	    	    asmParThen [code1 asmVoid, code2 (promote src2)] .
     	    	    mkSeqInstr (FCMP True DF src1 tmp)
     in
-    	returnSUs (Condition True cond code__2)
+    	returnUs (Condition True cond code__2)
 
 \end{code}
 
@@ -714,25 +700,25 @@ Do not fill the delay slots here; you will confuse the register allocator.
 
 \begin{code}
 
-condIntReg :: Cond -> [StixTree] -> SUniqSM Register
+condIntReg :: Cond -> [StixTree] -> UniqSM Register
 
 condIntReg EQ [x, StInt 0] =
-    getReg x    	    	    `thenSUs` \ register ->
-    getNewRegNCG IntKind   	    `thenSUs` \ tmp ->
-    let 
-        code = registerCode register tmp
-        src  = registerName register tmp
-        code__2 dst = code . mkSeqInstrs [
+    getReg x    	    	    `thenUs` \ register ->
+    getNewRegNCG IntRep   	    `thenUs` \ tmp ->
+    let
+	code = registerCode register tmp
+	src  = registerName register tmp
+	code__2 dst = code . mkSeqInstrs [
     	    SUB False True g0 (RIReg src) g0,
     	    SUB True False g0 (RIImm (ImmInt (-1))) dst]
     in
-        returnSUs (Any IntKind code__2)
+	returnUs (Any IntRep code__2)
 
 condIntReg EQ [x, y] =
-    getReg x	    	    `thenSUs` \ register1 ->
-    getReg y	    	    `thenSUs` \ register2 ->
-    getNewRegNCG IntKind        `thenSUs` \ tmp1 ->
-    getNewRegNCG IntKind        `thenSUs` \ tmp2 ->
+    getReg x	    	    `thenUs` \ register1 ->
+    getReg y	    	    `thenUs` \ register2 ->
+    getNewRegNCG IntRep        `thenUs` \ tmp1 ->
+    getNewRegNCG IntRep        `thenUs` \ tmp2 ->
     let
     	code1 = registerCode register1 tmp1 asmVoid
     	src1  = registerName register1 tmp1
@@ -743,45 +729,45 @@ condIntReg EQ [x, y] =
     	    SUB False True g0 (RIReg dst) g0,
     	    SUB True False g0 (RIImm (ImmInt (-1))) dst]
     in
-        returnSUs (Any IntKind code__2)
+	returnUs (Any IntRep code__2)
 
 condIntReg NE [x, StInt 0] =
-    getReg x    	    	    `thenSUs` \ register ->
-    getNewRegNCG IntKind   	    `thenSUs` \ tmp ->
-    let 
+    getReg x    	    	    `thenUs` \ register ->
+    getNewRegNCG IntRep   	    `thenUs` \ tmp ->
+    let
     	code = registerCode register tmp
     	src  = registerName register tmp
     	code__2 dst = code . mkSeqInstrs [
     	    SUB False True g0 (RIReg src) g0,
     	    ADD True False g0 (RIImm (ImmInt 0)) dst]
     in
-        returnSUs (Any IntKind code__2)
+	returnUs (Any IntRep code__2)
 
 condIntReg NE [x, y] =
-    getReg x	    	    `thenSUs` \ register1 ->
-    getReg y	    	    `thenSUs` \ register2 ->
-    getNewRegNCG IntKind        `thenSUs` \ tmp1 ->
-    getNewRegNCG IntKind        `thenSUs` \ tmp2 ->
+    getReg x	    	    `thenUs` \ register1 ->
+    getReg y	    	    `thenUs` \ register2 ->
+    getNewRegNCG IntRep        `thenUs` \ tmp1 ->
+    getNewRegNCG IntRep        `thenUs` \ tmp2 ->
     let
-        code1 = registerCode register1 tmp1 asmVoid
-        src1  = registerName register1 tmp1
-        code2 = registerCode register2 tmp2 asmVoid
-        src2  = registerName register2 tmp2
-        code__2 dst = asmParThen [code1, code2] . mkSeqInstrs [
+	code1 = registerCode register1 tmp1 asmVoid
+	src1  = registerName register1 tmp1
+	code2 = registerCode register2 tmp2 asmVoid
+	src2  = registerName register2 tmp2
+	code__2 dst = asmParThen [code1, code2] . mkSeqInstrs [
     	    XOR False src1 (RIReg src2) dst,
     	    SUB False True g0 (RIReg dst) g0,
     	    ADD True False g0 (RIImm (ImmInt 0)) dst]
     in
-        returnSUs (Any IntKind code__2)
+	returnUs (Any IntRep code__2)
 
 condIntReg cond args =
-    getUniqLabelNCG	    	    `thenSUs` \ lbl1 ->
-    getUniqLabelNCG	    	    `thenSUs` \ lbl2 ->
-    condIntCode cond args 	    `thenSUs` \ condition ->
+    getUniqLabelNCG	    	    `thenUs` \ lbl1 ->
+    getUniqLabelNCG	    	    `thenUs` \ lbl2 ->
+    condIntCode cond args 	    `thenUs` \ condition ->
     let
-        code = condCode condition
-        cond = condName condition
-        code__2 dst = code . mkSeqInstrs [
+	code = condCode condition
+	cond = condName condition
+	code__2 dst = code . mkSeqInstrs [
 	    BI cond False (ImmCLbl lbl1), NOP,
 	    OR False g0 (RIImm (ImmInt 0)) dst,
 	    BI ALWAYS False (ImmCLbl lbl2), NOP,
@@ -789,14 +775,14 @@ condIntReg cond args =
 	    OR False g0 (RIImm (ImmInt 1)) dst,
 	    LABEL lbl2]
     in
-        returnSUs (Any IntKind code__2)
+	returnUs (Any IntRep code__2)
 
-condFltReg :: Cond -> [StixTree] -> SUniqSM Register
+condFltReg :: Cond -> [StixTree] -> UniqSM Register
 
 condFltReg cond args =
-    getUniqLabelNCG	    	    `thenSUs` \ lbl1 ->
-    getUniqLabelNCG	    	    `thenSUs` \ lbl2 ->
-    condFltCode cond args 	    `thenSUs` \ condition ->
+    getUniqLabelNCG	    	    `thenUs` \ lbl1 ->
+    getUniqLabelNCG	    	    `thenUs` \ lbl2 ->
+    condFltCode cond args 	    `thenUs` \ condition ->
     let
     	code = condCode condition
     	cond = condName condition
@@ -809,7 +795,7 @@ condFltReg cond args =
 	    OR False g0 (RIImm (ImmInt 1)) dst,
 	    LABEL lbl2]
     in
-        returnSUs (Any IntKind code__2)
+	returnUs (Any IntRep code__2)
 
 \end{code}
 
@@ -819,17 +805,17 @@ correspond to loads, stores, or register transfers.  If we're really lucky,
 some of the register transfers will go away, because we can use the destination
 register to complete the code generation for the right hand side.  This only
 fails when the right hand side is forced into a fixed register (e.g. the result
-of a call).  
+of a call).
 
 \begin{code}
 
-assignIntCode :: PrimKind -> StixTree -> StixTree -> SUniqSM (CodeBlock SparcInstr)
+assignIntCode :: PrimRep -> StixTree -> StixTree -> UniqSM (CodeBlock SparcInstr)
 
 assignIntCode pk (StInd _ dst) src =
-    getNewRegNCG IntKind    	    `thenSUs` \ tmp ->
-    getAmode dst    	    	    `thenSUs` \ amode ->
-    getReg src	    	    	    `thenSUs` \ register ->
-    let 
+    getNewRegNCG IntRep    	    `thenUs` \ tmp ->
+    getAmode dst    	    	    `thenUs` \ amode ->
+    getReg src	    	    	    `thenUs` \ register ->
+    let
     	code1 = amodeCode amode asmVoid
     	dst__2  = amodeAddr amode
     	code2 = registerCode register tmp asmVoid
@@ -837,28 +823,28 @@ assignIntCode pk (StInd _ dst) src =
     	sz    = kindToSize pk
     	code__2 = asmParThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2)
     in
-    	returnSUs code__2
+    	returnUs code__2
 
 assignIntCode pk dst src =
-    getReg dst	    	    	    `thenSUs` \ register1 ->
-    getReg src	    	    	    `thenSUs` \ register2 ->
-    let 
+    getReg dst	    	    	    `thenUs` \ register1 ->
+    getReg src	    	    	    `thenUs` \ register2 ->
+    let
     	dst__2 = registerName register1 g0
     	code = registerCode register2 dst__2
     	src__2 = registerName register2 dst__2
-    	code__2 = if isFixed register2 then 
+    	code__2 = if isFixed register2 then
     	    	    code . mkSeqInstr (OR False g0 (RIReg src__2) dst__2)
     	    	else code
     in
-    	returnSUs code__2
+    	returnUs code__2
 
-assignFltCode :: PrimKind -> StixTree -> StixTree -> SUniqSM (CodeBlock SparcInstr)
+assignFltCode :: PrimRep -> StixTree -> StixTree -> UniqSM (CodeBlock SparcInstr)
 
 assignFltCode pk (StInd _ dst) src =
-    getNewRegNCG pk        	    `thenSUs` \ tmp ->
-    getAmode dst    	    	    `thenSUs` \ amode ->
-    getReg src	    	    	    `thenSUs` \ register ->
-    let 
+    getNewRegNCG pk        	    `thenUs` \ tmp ->
+    getAmode dst    	    	    `thenUs` \ amode ->
+    getReg src	    	    	    `thenUs` \ register ->
+    let
     	sz    = kindToSize pk
     	dst__2  = amodeAddr amode
 
@@ -869,20 +855,20 @@ assignFltCode pk (StInd _ dst) src =
     	pk__2  = registerKind register
     	sz__2 = kindToSize pk__2
 
-    	code__2 = asmParThen [code1, code2] . 
-	    if pk == pk__2 then 
+    	code__2 = asmParThen [code1, code2] .
+	    if pk == pk__2 then
 		mkSeqInstr (ST sz src__2 dst__2)
 	    else
 		mkSeqInstrs [FxTOy sz__2 sz src__2 tmp, ST sz tmp dst__2]
     in
-        returnSUs code__2
+	returnUs code__2
 
 assignFltCode pk dst src =
-    getReg dst	    	    	    `thenSUs` \ register1 ->
-    getReg src	    	    	    `thenSUs` \ register2 ->
+    getReg dst	    	    	    `thenUs` \ register1 ->
+    getReg src	    	    	    `thenUs` \ register2 ->
     getNewRegNCG (registerKind register2)
-    	    	        	    `thenSUs` \ tmp ->
-    let 
+    	    	        	    `thenUs` \ tmp ->
+    let
     	sz = kindToSize pk
     	dst__2 = registerName register1 g0    -- must be Fixed
 
@@ -897,9 +883,9 @@ assignFltCode pk dst src =
     	    	else if isFixed register2 then code . mkSeqInstr (FMOV sz src__2 dst__2)
     	    	else code
     in
-    	returnSUs code__2
+    	returnUs code__2
 
-\end{code} 
+\end{code}
 
 Generating an unconditional branch.  We accept two types of targets:
 an immediate CLabel or a tree that gets evaluated into a register.
@@ -911,19 +897,19 @@ Do not fill the delay slots here; you will confuse the register allocator.
 
 \begin{code}
 
-genJump 
+genJump
     :: StixTree     -- the branch target
-    -> SUniqSM (CodeBlock SparcInstr)
+    -> UniqSM (CodeBlock SparcInstr)
 
-genJump (StCLbl lbl) 
+genJump (StCLbl lbl)
   | isAsmTemp lbl = returnInstrs [BI ALWAYS False target, NOP]
   | otherwise     = returnInstrs [CALL target 0 True, NOP]
   where
     target = ImmCLbl lbl
 
 genJump tree =
-    getReg tree	    	    	    `thenSUs` \ register ->
-    getNewRegNCG PtrKind    	    `thenSUs` \ tmp ->
+    getReg tree	    	    	    `thenUs` \ register ->
+    getNewRegNCG PtrRep    	    `thenUs` \ tmp ->
     let
     	code = registerCode register tmp
     	target = registerName register tmp
@@ -943,17 +929,17 @@ Do not fill the delay slots here; you will confuse the register allocator.
 
 \begin{code}
 
-genCondJump 
+genCondJump
     :: CLabel	    -- the branch target
     -> StixTree     -- the condition on which to branch
-    -> SUniqSM (CodeBlock SparcInstr)
+    -> UniqSM (CodeBlock SparcInstr)
 
-genCondJump lbl bool = 
-    getCondition bool  	    	    `thenSUs` \ condition ->
+genCondJump lbl bool =
+    getCondition bool  	    	    `thenUs` \ condition ->
     let
     	code = condCode condition
     	cond = condName condition
-        target = ImmCLbl lbl    
+	target = ImmCLbl lbl
     in
     	if condFloat condition then
     	    returnSeq code [NOP, BF cond False target, NOP]
@@ -972,13 +958,13 @@ Do not fill the delay slots here; you will confuse the register allocator.
 
 genCCall
     :: FAST_STRING  -- function to call
-    -> PrimKind	    -- type of the result
+    -> PrimRep	    -- type of the result
     -> [StixTree]   -- arguments (of mixed type)
-    -> SUniqSM (CodeBlock SparcInstr)
+    -> UniqSM (CodeBlock SparcInstr)
 
 genCCall fn kind args =
-    mapAccumLNCG getCallArg (argRegs,stackArgLoc) args 
-    	    	    	    	    `thenSUs` \ ((unused,_), argCode) ->
+    mapAccumLNCG getCallArg (argRegs,stackArgLoc) args
+    	    	    	    	    `thenUs` \ ((unused,_), argCode) ->
     let
     	nRegs = length argRegs - length unused
     	call = CALL fn__2 nRegs False
@@ -992,11 +978,11 @@ genCCall fn kind args =
 	      '.' -> ImmLit (uppPStr fn)
 	      _   -> ImmLab (uppPStr fn)
 
-    mapAccumLNCG f b []     = returnSUs (b, [])
-    mapAccumLNCG f b (x:xs) = 
-    	f b x   	        	    `thenSUs` \ (b__2, x__2) ->
-    	mapAccumLNCG f b__2 xs   	    `thenSUs` \ (b__3, xs__2) ->
-    	returnSUs (b__3, x__2:xs__2)
+    mapAccumLNCG f b []     = returnUs (b, [])
+    mapAccumLNCG f b (x:xs) =
+    	f b x   	        	    `thenUs` \ (b__2, x__2) ->
+    	mapAccumLNCG f b__2 xs   	    `thenUs` \ (b__3, xs__2) ->
+    	returnUs (b__3, x__2:xs__2)
 
 \end{code}
 
@@ -1005,28 +991,28 @@ side, because that's where the generic optimizer will have put them.
 
 \begin{code}
 
-trivialCode 
-    :: (Reg -> RI -> Reg -> SparcInstr) 
+trivialCode
+    :: (Reg -> RI -> Reg -> SparcInstr)
     -> [StixTree]
-    -> SUniqSM Register
+    -> UniqSM Register
 
 trivialCode instr [x, StInt y]
   | is13Bits y =
-    getReg x	    	    	    `thenSUs` \ register ->
-    getNewRegNCG IntKind    	    `thenSUs` \ tmp ->
+    getReg x	    	    	    `thenUs` \ register ->
+    getNewRegNCG IntRep    	    `thenUs` \ tmp ->
     let
     	code = registerCode register tmp
     	src1 = registerName register tmp
     	src2 = ImmInt (fromInteger y)
     	code__2 dst = code . mkSeqInstr (instr src1 (RIImm src2) dst)
     in
-    	returnSUs (Any IntKind code__2)
+    	returnUs (Any IntRep code__2)
 
 trivialCode instr [x, y] =
-    getReg x	    	    	    `thenSUs` \ register1 ->
-    getReg y	    	    	    `thenSUs` \ register2 ->
-    getNewRegNCG IntKind    	    `thenSUs` \ tmp1 ->
-    getNewRegNCG IntKind    	    `thenSUs` \ tmp2 ->
+    getReg x	    	    	    `thenUs` \ register1 ->
+    getReg y	    	    	    `thenUs` \ register2 ->
+    getNewRegNCG IntRep    	    `thenUs` \ tmp1 ->
+    getNewRegNCG IntRep    	    `thenUs` \ tmp2 ->
     let
     	code1 = registerCode register1 tmp1 asmVoid
     	src1  = registerName register1 tmp1
@@ -1035,22 +1021,22 @@ trivialCode instr [x, y] =
     	code__2 dst = asmParThen [code1, code2] .
     	    	     mkSeqInstr (instr src1 (RIReg src2) dst)
     in
-    	returnSUs (Any IntKind code__2)
+    	returnUs (Any IntRep code__2)
 
-trivialFCode 
-    :: PrimKind
-    -> (Size -> Reg -> Reg -> Reg -> SparcInstr) 
-    -> [StixTree] 
-    -> SUniqSM Register
+trivialFCode
+    :: PrimRep
+    -> (Size -> Reg -> Reg -> Reg -> SparcInstr)
+    -> [StixTree]
+    -> UniqSM Register
 
 trivialFCode pk instr [x, y] =
-    getReg x	    	    	    `thenSUs` \ register1 ->
-    getReg y	    	    	    `thenSUs` \ register2 ->
+    getReg x	    	    	    `thenUs` \ register1 ->
+    getReg y	    	    	    `thenUs` \ register2 ->
     getNewRegNCG (registerKind register1)
-      	    	        	    `thenSUs` \ tmp1 ->
+      	    	        	    `thenUs` \ tmp1 ->
     getNewRegNCG (registerKind register2)
-     	    	        	    `thenSUs` \ tmp2 ->
-    getNewRegNCG DoubleKind   	    `thenSUs` \ tmp ->
+     	    	        	    `thenUs` \ tmp2 ->
+    getNewRegNCG DoubleRep   	    `thenUs` \ tmp ->
     let
     	promote x = asmInstr (FxTOy F DF x tmp)
 
@@ -1066,14 +1052,14 @@ trivialFCode pk instr [x, y] =
     	    	if pk1 == pk2 then
     	            asmParThen [code1 asmVoid, code2 asmVoid] .
     	    	    mkSeqInstr (instr (kindToSize pk) src1 src2 dst)
-    	    	else if pk1 == FloatKind then
+    	    	else if pk1 == FloatRep then
     	    	    asmParThen [code1 (promote src1), code2 asmVoid] .
     	    	    mkSeqInstr (instr DF tmp src2 dst)
     	    	else
     	    	    asmParThen [code1 asmVoid, code2 (promote src2)] .
     	    	    mkSeqInstr (instr DF src1 tmp dst)
     in
-    	returnSUs (Any (if pk1 == pk2 then pk1 else DoubleKind) code__2)
+    	returnUs (Any (if pk1 == pk2 then pk1 else DoubleRep) code__2)
 
 \end{code}
 
@@ -1083,36 +1069,36 @@ have handled the constant-folding.
 
 \begin{code}
 
-trivialUCode 
-    :: (RI -> Reg -> SparcInstr) 
+trivialUCode
+    :: (RI -> Reg -> SparcInstr)
     -> [StixTree]
-    -> SUniqSM Register
+    -> UniqSM Register
 
 trivialUCode instr [x] =
-    getReg x	    	    	    `thenSUs` \ register ->
-    getNewRegNCG IntKind    	    `thenSUs` \ tmp ->
+    getReg x	    	    	    `thenUs` \ register ->
+    getNewRegNCG IntRep    	    `thenUs` \ tmp ->
     let
     	code = registerCode register tmp
     	src  = registerName register tmp
     	code__2 dst = code . mkSeqInstr (instr (RIReg src) dst)
     in
-    	returnSUs (Any IntKind code__2)
+    	returnUs (Any IntRep code__2)
 
-trivialUFCode 
-    :: PrimKind
-    -> (Reg -> Reg -> SparcInstr) 
+trivialUFCode
+    :: PrimRep
+    -> (Reg -> Reg -> SparcInstr)
     -> [StixTree]
-    -> SUniqSM Register
+    -> UniqSM Register
 
 trivialUFCode pk instr [x] =
-    getReg x	    	    	    `thenSUs` \ register ->
-    getNewRegNCG pk        	    `thenSUs` \ tmp ->
+    getReg x	    	    	    `thenUs` \ register ->
+    getNewRegNCG pk        	    `thenUs` \ tmp ->
     let
     	code = registerCode register tmp
     	src  = registerName register tmp
     	code__2 dst = code . mkSeqInstr (instr src dst)
     in
-    	returnSUs (Any pk code__2)
+    	returnUs (Any pk code__2)
 
 \end{code}
 
@@ -1124,35 +1110,35 @@ Do not fill the delay slots here; you will confuse the register allocator.
 
 \begin{code}
 
-absIntCode :: [StixTree] -> SUniqSM Register
+absIntCode :: [StixTree] -> UniqSM Register
 absIntCode [x] =
-    getReg x	    	    	    `thenSUs` \ register ->
-    getNewRegNCG IntKind    	    `thenSUs` \ reg ->
-    getUniqLabelNCG    	    	    `thenSUs` \ lbl ->
+    getReg x	    	    	    `thenUs` \ register ->
+    getNewRegNCG IntRep    	    `thenUs` \ reg ->
+    getUniqLabelNCG    	    	    `thenUs` \ lbl ->
     let
     	code = registerCode register reg
     	src  = registerName register reg
     	code__2 dst = code . mkSeqInstrs [
-            SUB False True g0 (RIReg src) dst,
-            BI GE False (ImmCLbl lbl), NOP,
-            OR False g0 (RIReg src) dst,
-            LABEL lbl]
+	    SUB False True g0 (RIReg src) dst,
+	    BI GE False (ImmCLbl lbl), NOP,
+	    OR False g0 (RIReg src) dst,
+	    LABEL lbl]
     in
-    	returnSUs (Any IntKind code__2)
+    	returnUs (Any IntRep code__2)
 
 \end{code}
-                      
+
 Simple integer coercions that don't require any code to be generated.
 Here we just change the type on the register passed on up
 
 \begin{code}
 
-coerceIntCode :: PrimKind -> [StixTree] -> SUniqSM Register
+coerceIntCode :: PrimRep -> [StixTree] -> UniqSM Register
 coerceIntCode pk [x] =
-    getReg x	    	    	    `thenSUs` \ register ->
+    getReg x	    	    	    `thenUs` \ register ->
     case register of
-    	Fixed reg _ code -> returnSUs (Fixed reg pk code)
-    	Any _ code       -> returnSUs (Any pk code)
+    	Fixed reg _ code -> returnUs (Fixed reg pk code)
+    	Any _ code       -> returnUs (Any pk code)
 
 \end{code}
 
@@ -1161,10 +1147,10 @@ the original object is in memory.
 
 \begin{code}
 
-chrCode :: [StixTree] -> SUniqSM Register
+chrCode :: [StixTree] -> UniqSM Register
 chrCode [StInd pk mem] =
-    getAmode mem    	    	    `thenSUs` \ amode ->
-    let 
+    getAmode mem    	    	    `thenUs` \ amode ->
+    let
     	code = amodeCode amode
     	src  = amodeAddr amode
     	srcOff = offset src 3
@@ -1173,20 +1159,20 @@ chrCode [StInd pk mem] =
     	    	    	code . mkSeqInstr (LD UB src__2 dst)
     	    	    else
     	    	    	code . mkSeqInstrs [
-    	    	    	    LD (kindToSize pk) src dst, 
+    	    	    	    LD (kindToSize pk) src dst,
     	    	    	    AND False dst (RIImm (ImmInt 255)) dst]
     in
-    	returnSUs (Any pk code__2)
+    	returnUs (Any pk code__2)
 
 chrCode [x] =
-    getReg x	    	    	    `thenSUs` \ register ->
-    getNewRegNCG IntKind    	    `thenSUs` \ reg ->
+    getReg x	    	    	    `thenUs` \ register ->
+    getNewRegNCG IntRep    	    `thenUs` \ reg ->
     let
     	code = registerCode register reg
     	src  = registerName register reg
     	code__2 dst = code . mkSeqInstr (AND False src (RIImm (ImmInt 255)) dst)
     in
-    	returnSUs (Any IntKind code__2)
+    	returnUs (Any IntRep code__2)
 
 \end{code}
 
@@ -1196,10 +1182,10 @@ point register sets.
 
 \begin{code}
 
-coerceInt2FP :: PrimKind -> [StixTree] -> SUniqSM Register
-coerceInt2FP pk [x] = 
-    getReg x	    	    	    `thenSUs` \ register ->
-    getNewRegNCG IntKind      	    `thenSUs` \ reg ->
+coerceInt2FP :: PrimRep -> [StixTree] -> UniqSM Register
+coerceInt2FP pk [x] =
+    getReg x	    	    	    `thenUs` \ register ->
+    getNewRegNCG IntRep      	    `thenUs` \ reg ->
     let
     	code = registerCode register reg
     	src  = registerName register reg
@@ -1209,13 +1195,13 @@ coerceInt2FP pk [x] =
     	    LD W (spRel (-2)) dst,
     	    FxTOy W (kindToSize pk) dst dst]
     in
-    	returnSUs (Any pk code__2)
+    	returnUs (Any pk code__2)
 
-coerceFP2Int :: [StixTree] -> SUniqSM Register
+coerceFP2Int :: [StixTree] -> UniqSM Register
 coerceFP2Int [x] =
-    getReg x	    	    	    `thenSUs` \ register ->
-    getNewRegNCG IntKind      	    `thenSUs` \ reg ->
-    getNewRegNCG FloatKind     	    `thenSUs` \ tmp ->
+    getReg x	    	    	    `thenUs` \ register ->
+    getNewRegNCG IntRep      	    `thenUs` \ reg ->
+    getNewRegNCG FloatRep     	    `thenUs` \ tmp ->
     let
     	code = registerCode register reg
     	src  = registerName register reg
@@ -1226,7 +1212,7 @@ coerceFP2Int [x] =
     	    ST W tmp (spRel (-2)),
     	    LD W (spRel (-2)) dst]
     in
-    	returnSUs (Any IntKind code__2)
+    	returnUs (Any IntRep code__2)
 
 \end{code}
 
@@ -1235,7 +1221,7 @@ Some random little helpers.
 \begin{code}
 
 maybeImm :: StixTree -> Maybe Imm
-maybeImm (StInt i) 
+maybeImm (StInt i)
   | i >= toInteger minInt && i <= toInteger maxInt = Just (ImmInt (fromInteger i))
   | otherwise = Just (ImmInteger i)
 maybeImm (StLitLbl s)  = Just (ImmLab s)
@@ -1245,32 +1231,32 @@ maybeImm _          = Nothing
 
 mangleIndexTree :: StixTree -> StixTree
 
-mangleIndexTree (StIndex pk base (StInt i)) = 
+mangleIndexTree (StIndex pk base (StInt i)) =
     StPrim IntAddOp [base, off]
   where
     off = StInt (i * size pk)
-    size :: PrimKind -> Integer
+    size :: PrimRep -> Integer
     size pk = case kindToSize pk of
     	{SB -> 1; UB -> 1; HW -> 2; UHW -> 2; W -> 4; D -> 8; F -> 4; DF -> 8}
 
-mangleIndexTree (StIndex pk base off) = 
+mangleIndexTree (StIndex pk base off) =
     case pk of
-    	CharKind -> StPrim IntAddOp [base, off]
+    	CharRep -> StPrim IntAddOp [base, off]
     	_   	 -> StPrim IntAddOp [base, off__2]
   where
     off__2 = StPrim SllOp [off, StInt (shift pk)]
-    shift :: PrimKind -> Integer
-    shift DoubleKind 	= 3
+    shift :: PrimRep -> Integer
+    shift DoubleRep 	= 3
     shift _ 	       	= 2
 
 cvtLitLit :: String -> String
 cvtLitLit "stdin" = "__iob+0x0"   -- This one is probably okay...
 cvtLitLit "stdout" = "__iob+0x14" -- but these next two are dodgy at best
 cvtLitLit "stderr" = "__iob+0x28"
-cvtLitLit s 
+cvtLitLit s
   | isHex s = s
   | otherwise = error ("Native code generator can't handle ``" ++ s ++ "''")
-  where 
+  where
     isHex ('0':'x':xs) = all isHexDigit xs
     isHex _ = False
     -- Now, where have I seen this before?
@@ -1284,7 +1270,7 @@ and for excess call arguments.
 
 \begin{code}
 
-spRel 
+spRel
     :: Int  	-- desired stack offset in words, positive or negative
     -> Addr
 spRel n = AddrRegImm sp (ImmInt (n * 4))
@@ -1295,9 +1281,9 @@ stackArgLoc = 23 :: Int	    -- where to stack extra call arguments (beyond 6x32
 
 \begin{code}
 
-getNewRegNCG :: PrimKind -> SUniqSM Reg
-getNewRegNCG pk = 
-      getSUnique          `thenSUs` \ u ->
-      returnSUs (mkReg u pk)
+getNewRegNCG :: PrimRep -> UniqSM Reg
+getNewRegNCG pk =
+      getUnique          `thenUs` \ u ->
+      returnUs (mkReg u pk)
 
 \end{code}
diff --git a/ghc/compiler/nativeGen/Stix.hi b/ghc/compiler/nativeGen/Stix.hi
deleted file mode 100644
index 4f371d17e7..0000000000
--- a/ghc/compiler/nativeGen/Stix.hi
+++ /dev/null
@@ -1,41 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface Stix where
-import AbsCSyn(MagicId)
-import CLabelInfo(CLabel)
-import CharSeq(CSeq)
-import PreludePS(_PackedString)
-import PreludeRatio(Ratio(..))
-import PrimKind(PrimKind)
-import PrimOps(PrimOp)
-import SplitUniq(SUniqSM(..), SplitUniqSupply)
-import UniType(UniType)
-import Unique(Unique)
-data MagicId 
-data CLabel 
-data CodeSegment   = DataSegment | TextSegment
-data PrimKind 
-data PrimOp 
-type SUniqSM a = SplitUniqSupply -> a
-data SplitUniqSupply 
-data StixReg   = StixMagicId MagicId | StixTemp Unique PrimKind
-data StixTree   = StSegment CodeSegment | StInt Integer | StDouble (Ratio Integer) | StString _PackedString | StLitLbl CSeq | StLitLit _PackedString | StCLbl CLabel | StReg StixReg | StIndex PrimKind StixTree StixTree | StInd PrimKind StixTree | StAssign PrimKind StixTree StixTree | StLabel CLabel | StFunBegin CLabel | StFunEnd CLabel | StJump StixTree | StFallThrough CLabel | StCondJump CLabel StixTree | StData PrimKind [StixTree] | StPrim PrimOp [StixTree] | StCall _PackedString PrimKind [StixTree] | StComment _PackedString
-type StixTreeList = [StixTree] -> [StixTree]
-data Unique 
-getUniqLabelNCG :: SplitUniqSupply -> CLabel
-sStLitLbl :: _PackedString -> StixTree
-stgBaseReg :: StixTree
-stgHp :: StixTree
-stgHpLim :: StixTree
-stgLivenessReg :: StixTree
-stgNode :: StixTree
-stgRetReg :: StixTree
-stgSpA :: StixTree
-stgSpB :: StixTree
-stgStdUpdRetVecReg :: StixTree
-stgStkOReg :: StixTree
-stgStkStubReg :: StixTree
-stgSuA :: StixTree
-stgSuB :: StixTree
-stgTagReg :: StixTree
-instance Eq CodeSegment
-
diff --git a/ghc/compiler/nativeGen/Stix.lhs b/ghc/compiler/nativeGen/Stix.lhs
index e2d4aa7b4e..8269dbdb3d 100644
--- a/ghc/compiler/nativeGen/Stix.lhs
+++ b/ghc/compiler/nativeGen/Stix.lhs
@@ -9,33 +9,29 @@ module Stix (
 	CodeSegment(..), StixReg(..), StixTree(..), StixTreeList(..),
 	sStLitLbl,
 
-	stgBaseReg, stgStkOReg, stgNode, stgTagReg, stgRetReg, 
+	stgBaseReg, stgStkOReg, stgNode, stgTagReg, stgRetReg,
 	stgSpA, stgSuA, stgSpB, stgSuB, stgHp, stgHpLim, stgLivenessReg,
 --	stgActivityReg,
 	stgStdUpdRetVecReg, stgStkStubReg,
-	getUniqLabelNCG,
+	getUniqLabelNCG
 
 	-- And for self-sufficiency, by golly...
-	MagicId, CLabel, PrimKind, PrimOp, Unique,
-	SplitUniqSupply, SUniqSM(..)
     ) where
 
 import AbsCSyn	    ( MagicId(..), kindFromMagicId, node, infoptr )
-import AbsPrel	    ( showPrimOp, PrimOp
+import PrelInfo	    ( showPrimOp, PrimOp
 		      IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
 			  IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
 		    )
-import CLabelInfo   ( CLabel, mkAsmTempLabel )
+import CLabel   ( CLabel, mkAsmTempLabel )
 import Outputable
-import PrimKind	    ( PrimKind(..) )
-import SplitUniq
-import Unique
-import Unpretty 
+import UniqSupply
+import Unpretty
 import Util
 \end{code}
 
 Here is the tag at the nodes of our @StixTree@.	 Notice its
-relationship with @PrimOp@ in prelude/PrimOps.
+relationship with @PrimOp@ in prelude/PrimOp.
 
 \begin{code}
 
@@ -48,11 +44,7 @@ data StixTree =
 	-- We can tag the leaves with constants/immediates.
 
       | StInt	  Integer      -- ** add Kind at some point
-#if __GLASGOW_HASKELL__ <= 22
-      | StDouble  Double
-#else
       | StDouble  Rational
-#endif
       | StString  FAST_STRING
       | StLitLbl  Unpretty	-- literal labels (will be _-prefixed on some machines)
       | StLitLit  FAST_STRING	-- innards from CLitLit
@@ -64,15 +56,15 @@ data StixTree =
 
 	-- A typed offset from a base location
 
-      | StIndex PrimKind StixTree StixTree -- kind, base, offset
+      | StIndex PrimRep StixTree StixTree -- kind, base, offset
 
 	-- An indirection from an address to its contents.
 
-      | StInd PrimKind StixTree
+      | StInd PrimRep StixTree
 
 	-- Assignment is typed to determine size and register placement
 
-      | StAssign PrimKind StixTree StixTree -- dst, src
+      | StAssign PrimRep StixTree StixTree -- dst, src
 
 	-- A simple assembly label that we might jump to.
 
@@ -99,7 +91,7 @@ data StixTree =
 
 	-- Raw data (as in an info table).
 
-      | StData PrimKind	[StixTree]
+      | StData PrimRep	[StixTree]
 
     	-- Primitive Operations
 
@@ -107,7 +99,7 @@ data StixTree =
 
     	-- Calls to C functions
 
-      | StCall FAST_STRING PrimKind [StixTree]
+      | StCall FAST_STRING PrimRep [StixTree]
 
 	-- Comments, of course
 
@@ -126,7 +118,7 @@ map to real, machine level registers.
 
 data StixReg = StixMagicId MagicId	-- Regs which are part of the abstract machine model
 
-	     | StixTemp Unique PrimKind -- "Regs" which model local variables (CTemps) in
+	     | StixTemp Unique PrimRep -- "Regs" which model local variables (CTemps) in
 					-- the abstract C.
 	     deriving ()
 
@@ -168,9 +160,9 @@ stgLivenessReg = StReg (StixMagicId LivenessReg)
 stgStdUpdRetVecReg = StReg (StixMagicId StdUpdRetVecReg)
 stgStkStubReg = StReg (StixMagicId StkStubReg)
 
-getUniqLabelNCG :: SUniqSM CLabel
-getUniqLabelNCG = 
-      getSUnique	      `thenSUs` \ u ->
-      returnSUs (mkAsmTempLabel u)
+getUniqLabelNCG :: UniqSM CLabel
+getUniqLabelNCG =
+      getUnique	      `thenUs` \ u ->
+      returnUs (mkAsmTempLabel u)
 
 \end{code}
diff --git a/ghc/compiler/nativeGen/StixInfo.hi b/ghc/compiler/nativeGen/StixInfo.hi
deleted file mode 100644
index 686d508700..0000000000
--- a/ghc/compiler/nativeGen/StixInfo.hi
+++ /dev/null
@@ -1,8 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface StixInfo where
-import AbsCSyn(AbstractC, CAddrMode)
-import HeapOffs(HeapOffset)
-import SplitUniq(SplitUniqSupply)
-import Stix(StixTree)
-genCodeInfoTable :: (HeapOffset -> Int) -> (CAddrMode -> StixTree) -> AbstractC -> SplitUniqSupply -> [StixTree] -> [StixTree]
-
diff --git a/ghc/compiler/nativeGen/StixInfo.lhs b/ghc/compiler/nativeGen/StixInfo.lhs
index b976193ff5..e82716778b 100644
--- a/ghc/compiler/nativeGen/StixInfo.lhs
+++ b/ghc/compiler/nativeGen/StixInfo.lhs
@@ -15,8 +15,7 @@ import MachDesc
 import Maybes		( maybeToBool, Maybe(..) )
 import SMRep		( SMRep(..), SMSpecRepKind(..), SMUpdateKind(..) )
 import Stix
-import SplitUniq
-import Unique
+import UniqSupply
 import Unpretty
 import Util
 
@@ -41,37 +40,37 @@ genCodeInfoTable
        (HeapOffset -> Int)	-- needed bit of Target
     -> (CAddrMode -> StixTree)	-- ditto
     -> AbstractC
-    -> SUniqSM StixTreeList
+    -> UniqSM StixTreeList
 
 genCodeInfoTable hp_rel amode2stix (CClosureInfoAndCode cl_info _ _ upd cl_descr _) =
-    returnSUs (\xs -> info : lbl : xs)
+    returnUs (\xs -> info : lbl : xs)
 
     where
-	info = StData PtrKind table
+	info = StData PtrRep table
 	lbl = StLabel info_lbl
 
 	table = case sm_rep of
 	    StaticRep _ _ -> [
 		StInt (toInteger ptrs),
-                StInt (toInteger size),
-                upd_code,
+		StInt (toInteger size),
+		upd_code,
 		static___rtbl,
-                tag]
+		tag]
 
 	    SpecialisedRep ConstantRep _ _ _ -> [
 		StCLbl closure_lbl,
-                upd_code,
-                const___rtbl,
-                tag]
+		upd_code,
+		const___rtbl,
+		tag]
 
 	    SpecialisedRep CharLikeRep _ _ _ -> [
 		upd_code,
 		charlike___rtbl,
-                tag]
+		tag]
 
 	    SpecialisedRep IntLikeRep _ _ _ -> [
 		upd_code,
-                intlike___rtbl,
+		intlike___rtbl,
 		tag]
 
 	    SpecialisedRep _ _ _ updatable ->
@@ -85,27 +84,27 @@ genCodeInfoTable hp_rel amode2stix (CClosureInfoAndCode cl_info _ _ upd cl_descr
 				    SMNormalForm -> SLIT("Spec_N_")
 				    SMSingleEntry -> SLIT("Spec_S_")
 				    SMUpdatable -> SLIT("Spec_U_")
-			           ),
+				   ),
 			   uppInt size,
 			   uppChar '_',
 			   uppInt ptrs,
 			   uppPStr SLIT("_rtbl")])
-                in
+		in
 		    case updatable of
 			SMNormalForm -> [upd_code, StLitLbl rtbl, tag]
-		        _            -> [StLitLbl rtbl, tag]
+			_            -> [StLitLbl rtbl, tag]
 
 	    GenericRep _ _ updatable ->
-                let rtbl = case updatable of
-                            SMNormalForm  -> gen_N___rtbl
-                            SMSingleEntry -> gen_S___rtbl
+		let rtbl = case updatable of
+			    SMNormalForm  -> gen_N___rtbl
+			    SMSingleEntry -> gen_S___rtbl
 			    SMUpdatable   -> gen_U___rtbl
-                in [
+		in [
 		    StInt (toInteger ptrs),
-                    StInt (toInteger size),
+		    StInt (toInteger size),
 		    upd_code,
-                    rtbl,
-                    tag]
+		    rtbl,
+		    tag]
 
 	    BigTupleRep _ -> [
 		tuple___rtbl,
@@ -126,9 +125,9 @@ genCodeInfoTable hp_rel amode2stix (CClosureInfoAndCode cl_info _ _ upd cl_descr
 	closure_lbl	= closureLabelFromCI   cl_info
 
 	sm_rep	= closureSMRep cl_info
-        maybe_selector = maybeSelectorInfo cl_info
-        is_selector = maybeToBool maybe_selector
-        (Just (_, select_word)) = maybe_selector
+	maybe_selector = maybeSelectorInfo cl_info
+	is_selector = maybeToBool maybe_selector
+	(Just (_, select_word)) = maybe_selector
 
 	tag = StInt (toInteger (closureSemiTag cl_info))
 
diff --git a/ghc/compiler/nativeGen/StixInteger.hi b/ghc/compiler/nativeGen/StixInteger.hi
deleted file mode 100644
index 889d352aa6..0000000000
--- a/ghc/compiler/nativeGen/StixInteger.hi
+++ /dev/null
@@ -1,18 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface StixInteger where
-import AbsCSyn(CAddrMode)
-import MachDesc(Target)
-import PreludePS(_PackedString)
-import PrimKind(PrimKind)
-import SplitUniq(SplitUniqSupply)
-import Stix(StixTree)
-decodeFloatingKind :: PrimKind -> Target -> (CAddrMode, CAddrMode, CAddrMode, CAddrMode) -> (CAddrMode, CAddrMode) -> SplitUniqSupply -> [StixTree] -> [StixTree]
-encodeFloatingKind :: PrimKind -> Target -> CAddrMode -> (CAddrMode, CAddrMode, CAddrMode, CAddrMode, CAddrMode) -> SplitUniqSupply -> [StixTree] -> [StixTree]
-gmpCompare :: Target -> CAddrMode -> (CAddrMode, CAddrMode, CAddrMode, CAddrMode, CAddrMode, CAddrMode, CAddrMode) -> SplitUniqSupply -> [StixTree] -> [StixTree]
-gmpInt2Integer :: Target -> (CAddrMode, CAddrMode, CAddrMode) -> (CAddrMode, CAddrMode) -> SplitUniqSupply -> [StixTree] -> [StixTree]
-gmpInteger2Int :: Target -> CAddrMode -> (CAddrMode, CAddrMode, CAddrMode, CAddrMode) -> SplitUniqSupply -> [StixTree] -> [StixTree]
-gmpString2Integer :: Target -> (CAddrMode, CAddrMode, CAddrMode) -> (CAddrMode, CAddrMode) -> SplitUniqSupply -> [StixTree] -> [StixTree]
-gmpTake1Return1 :: Target -> (CAddrMode, CAddrMode, CAddrMode) -> _PackedString -> (CAddrMode, CAddrMode, CAddrMode, CAddrMode) -> SplitUniqSupply -> [StixTree] -> [StixTree]
-gmpTake2Return1 :: Target -> (CAddrMode, CAddrMode, CAddrMode) -> _PackedString -> (CAddrMode, CAddrMode, CAddrMode, CAddrMode, CAddrMode, CAddrMode, CAddrMode) -> SplitUniqSupply -> [StixTree] -> [StixTree]
-gmpTake2Return2 :: Target -> (CAddrMode, CAddrMode, CAddrMode, CAddrMode, CAddrMode, CAddrMode) -> _PackedString -> (CAddrMode, CAddrMode, CAddrMode, CAddrMode, CAddrMode, CAddrMode, CAddrMode) -> SplitUniqSupply -> [StixTree] -> [StixTree]
-
diff --git a/ghc/compiler/nativeGen/StixInteger.lhs b/ghc/compiler/nativeGen/StixInteger.lhs
index a5268beab7..91d68d0cd2 100644
--- a/ghc/compiler/nativeGen/StixInteger.lhs
+++ b/ghc/compiler/nativeGen/StixInteger.lhs
@@ -5,10 +5,10 @@
 \begin{code}
 #include "HsVersions.h"
 
-module StixInteger ( 
-        gmpTake1Return1, gmpTake2Return1, gmpTake2Return2,
-        gmpCompare, gmpInteger2Int, gmpInt2Integer, gmpString2Integer,
-        encodeFloatingKind, decodeFloatingKind
+module StixInteger (
+	gmpTake1Return1, gmpTake2Return1, gmpTake2Return2,
+	gmpCompare, gmpInteger2Int, gmpInt2Integer, gmpString2Integer,
+	encodeFloatingKind, decodeFloatingKind
     ) where
 
 IMPORT_Trace	-- ToDo: rm debugging
@@ -16,37 +16,36 @@ IMPORT_Trace	-- ToDo: rm debugging
 import AbsCSyn
 import CgCompInfo   ( mIN_MP_INT_SIZE )
 import MachDesc
-import Pretty	    
-import AbsPrel	    ( PrimOp(..)
+import Pretty
+import PrelInfo	    ( PrimOp(..)
 		      IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
 			  IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
 		    )
 import SMRep	    ( SMRep(..), SMSpecRepKind, SMUpdateKind(..) )
 import Stix
-import SplitUniq
-import Unique
+import UniqSupply
 import Util
 
 \end{code}
 
 \begin{code}
 
-gmpTake1Return1 
-    :: Target 
+gmpTake1Return1
+    :: Target
     -> (CAddrMode,CAddrMode,CAddrMode)  -- result (3 parts)
     -> FAST_STRING			-- function name
     -> (CAddrMode, CAddrMode,CAddrMode,CAddrMode)
 					-- argument (4 parts)
-    -> SUniqSM StixTreeList
+    -> UniqSM StixTreeList
 
 argument1 = mpStruct 1 -- out here to avoid CAF (sigh)
 argument2 = mpStruct 2
 result2 = mpStruct 2
 result3 = mpStruct 3
 result4 = mpStruct 4
-init2 = StCall SLIT("mpz_init") VoidKind [result2]
-init3 = StCall SLIT("mpz_init") VoidKind [result3]
-init4 = StCall SLIT("mpz_init") VoidKind [result4]
+init2 = StCall SLIT("mpz_init") VoidRep [result2]
+init3 = StCall SLIT("mpz_init") VoidRep [result3]
+init4 = StCall SLIT("mpz_init") VoidRep [result4]
 
 -- hacking with Uncle Will:
 #define target_STRICT target@(Target _ _ _ _ _ _ _ _)
@@ -61,30 +60,30 @@ gmpTake1Return1 target_STRICT res@(car,csr,cdr) rtn arg@(clive,caa,csa,cda) =
 	dr	= a2stix cdr
     	liveness= a2stix clive
 	aa	= a2stix caa
-	sa	= a2stix csa      
-	da	= a2stix cda      
+	sa	= a2stix csa
+	da	= a2stix cda
 
     	space = mpSpace data_hs 2 1 [sa]
-    	oldHp = StIndex PtrKind stgHp (StPrim IntNegOp [space])
+    	oldHp = StIndex PtrRep stgHp (StPrim IntNegOp [space])
     	safeHp = saveLoc target Hp
-    	save = StAssign PtrKind safeHp oldHp
+    	save = StAssign PtrRep safeHp oldHp
     	(a1,a2,a3) = toStruct data_hs argument1 (aa,sa,da)
-    	mpz_op = StCall rtn VoidKind [result2, argument1]
-    	restore = StAssign PtrKind stgHp safeHp
+    	mpz_op = StCall rtn VoidRep [result2, argument1]
+    	restore = StAssign PtrRep stgHp safeHp
     	(r1,r2,r3) = fromStruct data_hs result2 (ar,sr,dr)
     in
-    	heapCheck target liveness space (StInt 0) `thenSUs` \ heap_chk ->
+    	heapCheck target liveness space (StInt 0) `thenUs` \ heap_chk ->
 
-    	returnSUs (heap_chk . 
+    	returnUs (heap_chk .
     	    (\xs -> a1 : a2 : a3 : save : init2 : mpz_op : r1 : r2 : r3 : restore : xs))
 
-gmpTake2Return1 
-    :: Target 
+gmpTake2Return1
+    :: Target
     -> (CAddrMode,CAddrMode,CAddrMode)	-- result (3 parts)
     -> FAST_STRING    	    		-- function name
     -> (CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode)
 					-- liveness + 2 arguments (3 parts each)
-    -> SUniqSM StixTreeList
+    -> UniqSM StixTreeList
 
 gmpTake2Return1 target_STRICT res@(car,csr,cdr) rtn args@(clive, caa1,csa1,cda1, caa2,csa2,cda2) =
     let
@@ -103,29 +102,29 @@ gmpTake2Return1 target_STRICT res@(car,csr,cdr) rtn args@(clive, caa1,csa1,cda1,
 	da2	= a2stix cda2
 
     	space = mpSpace data_hs 3 1 [sa1, sa2]
-    	oldHp = StIndex PtrKind stgHp (StPrim IntNegOp [space])
+    	oldHp = StIndex PtrRep stgHp (StPrim IntNegOp [space])
     	safeHp = saveLoc target Hp
-    	save = StAssign PtrKind safeHp oldHp
+    	save = StAssign PtrRep safeHp oldHp
     	(a1,a2,a3) = toStruct data_hs argument1 (aa1,sa1,da1)
     	(a4,a5,a6) = toStruct data_hs argument2 (aa2,sa2,da2)
-    	mpz_op = StCall rtn VoidKind [result3, argument1, argument2]
-    	restore = StAssign PtrKind stgHp safeHp
+    	mpz_op = StCall rtn VoidRep [result3, argument1, argument2]
+    	restore = StAssign PtrRep stgHp safeHp
     	(r1,r2,r3) = fromStruct data_hs result3 (ar,sr,dr)
     in
-    	heapCheck target liveness space (StInt 0) `thenSUs` \ heap_chk ->
+    	heapCheck target liveness space (StInt 0) `thenUs` \ heap_chk ->
 
-    	returnSUs (heap_chk .
-    	    (\xs -> a1 : a2 : a3 : a4 : a5 : a6 
+    	returnUs (heap_chk .
+    	    (\xs -> a1 : a2 : a3 : a4 : a5 : a6
     	    	    	: save : init3 : mpz_op : r1 : r2 : r3 : restore : xs))
 
 gmpTake2Return2
-    :: Target 
+    :: Target
     -> (CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode)
     		  	    -- 2 results (3 parts each)
     -> FAST_STRING    	    -- function name
     -> (CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode)
     		  	    -- liveness + 2 arguments (3 parts each)
-    -> SUniqSM StixTreeList
+    -> UniqSM StixTreeList
 
 gmpTake2Return2 target_STRICT res@(car1,csr1,cdr1, car2,csr2,cdr2)
 		rtn args@(clive, caa1,csa1,cda1, caa2,csa2,cda2) =
@@ -133,37 +132,37 @@ gmpTake2Return2 target_STRICT res@(car1,csr1,cdr1, car2,csr2,cdr2)
 	a2stix  = amodeToStix target
 	data_hs = dataHS target
 
-	ar1	= a2stix car1     
-	sr1	= a2stix csr1     
-	dr1	= a2stix cdr1     
-	ar2	= a2stix car2     
-	sr2	= a2stix csr2     
-	dr2	= a2stix cdr2     
+	ar1	= a2stix car1
+	sr1	= a2stix csr1
+	dr1	= a2stix cdr1
+	ar2	= a2stix car2
+	sr2	= a2stix csr2
+	dr2	= a2stix cdr2
     	liveness= a2stix clive
-	aa1	= a2stix caa1     
-	sa1	= a2stix csa1     
-	da1	= a2stix cda1     
-	aa2	= a2stix caa2     
+	aa1	= a2stix caa1
+	sa1	= a2stix csa1
+	da1	= a2stix cda1
+	aa2	= a2stix caa2
 	sa2	= a2stix csa2
 	da2	= a2stix cda2
 
     	space = StPrim IntMulOp [mpSpace data_hs 2 1 [sa1, sa2], StInt 2]
-    	oldHp = StIndex PtrKind stgHp (StPrim IntNegOp [space])
+    	oldHp = StIndex PtrRep stgHp (StPrim IntNegOp [space])
     	safeHp = saveLoc target Hp
-    	save = StAssign PtrKind safeHp oldHp
+    	save = StAssign PtrRep safeHp oldHp
     	(a1,a2,a3) = toStruct data_hs argument1 (aa1,sa1,da1)
     	(a4,a5,a6) = toStruct data_hs argument2 (aa2,sa2,da2)
-    	mpz_op = StCall rtn VoidKind [result3, result4, argument1, argument2]
-    	restore = StAssign PtrKind stgHp safeHp
+    	mpz_op = StCall rtn VoidRep [result3, result4, argument1, argument2]
+    	restore = StAssign PtrRep stgHp safeHp
     	(r1,r2,r3) = fromStruct data_hs result3 (ar1,sr1,dr1)
     	(r4,r5,r6) = fromStruct data_hs result4 (ar2,sr2,dr2)
 
     in
-    	heapCheck target liveness space (StInt 0) `thenSUs` \ heap_chk ->
+    	heapCheck target liveness space (StInt 0) `thenUs` \ heap_chk ->
 
-    	returnSUs (heap_chk .
-    	    (\xs -> a1 : a2 : a3 : a4 : a5 : a6 
-    	    	    	: save : init3 : init4 : mpz_op 
+    	returnUs (heap_chk .
+    	    (\xs -> a1 : a2 : a3 : a4 : a5 : a6
+    	    	    	: save : init3 : init4 : mpz_op
     	    	    	: r1 : r2 : r3 : r4 : r5 : r6 : restore : xs))
 
 \end{code}
@@ -175,12 +174,12 @@ available.  (See ``primOpHeapRequired.'')
 
 \begin{code}
 
-gmpCompare 
-    :: Target 
+gmpCompare
+    :: Target
     -> CAddrMode    	    -- result (boolean)
     -> (CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode)
     		  	    -- alloc hp + 2 arguments (3 parts each)
-    -> SUniqSM StixTreeList
+    -> UniqSM StixTreeList
 
 gmpCompare target_STRICT res args@(chp, caa1,csa1,cda1, caa2,csa2,cda2) =
     let
@@ -188,7 +187,7 @@ gmpCompare target_STRICT res args@(chp, caa1,csa1,cda1, caa2,csa2,cda2) =
 	data_hs = dataHS target
 
 	result	= a2stix res
-	hp	= a2stix chp      
+	hp	= a2stix chp
 	aa1	= a2stix caa1
 	sa1	= a2stix csa1
 	da1	= a2stix cda1
@@ -197,13 +196,13 @@ gmpCompare target_STRICT res args@(chp, caa1,csa1,cda1, caa2,csa2,cda2) =
 	da2	= a2stix cda2
 
     	argument1 = hp
-    	argument2 = StIndex IntKind hp (StInt (toInteger mpIntSize))
+    	argument2 = StIndex IntRep hp (StInt (toInteger mpIntSize))
     	(a1,a2,a3) = toStruct data_hs argument1 (aa1,sa1,da1)
     	(a4,a5,a6) = toStruct data_hs argument2 (aa2,sa2,da2)
-    	mpz_cmp = StCall SLIT("mpz_cmp") IntKind [argument1, argument2]
-    	r1 = StAssign IntKind result mpz_cmp
+    	mpz_cmp = StCall SLIT("mpz_cmp") IntRep [argument1, argument2]
+    	r1 = StAssign IntRep result mpz_cmp
     in
-    	returnSUs (\xs -> a1 : a2 : a3 : a4 : a5 : a6 : r1 : xs)
+    	returnUs (\xs -> a1 : a2 : a3 : a4 : a5 : a6 : r1 : xs)
 
 \end{code}
 
@@ -211,11 +210,11 @@ See the comment above regarding the heap check (or lack thereof).
 
 \begin{code}
 
-gmpInteger2Int 
-    :: Target 
+gmpInteger2Int
+    :: Target
     -> CAddrMode    	    -- result
     -> (CAddrMode, CAddrMode,CAddrMode,CAddrMode) -- alloc hp + argument (3 parts)
-    -> SUniqSM StixTreeList
+    -> UniqSM StixTreeList
 
 gmpInteger2Int target_STRICT res args@(chp, caa,csa,cda) =
     let
@@ -229,76 +228,76 @@ gmpInteger2Int target_STRICT res args@(chp, caa,csa,cda) =
 	da	= a2stix cda
 
     	(a1,a2,a3) = toStruct data_hs hp (aa,sa,da)
-    	mpz_get_si = StCall SLIT("mpz_get_si") IntKind [hp]
-    	r1 = StAssign IntKind result mpz_get_si
+    	mpz_get_si = StCall SLIT("mpz_get_si") IntRep [hp]
+    	r1 = StAssign IntRep result mpz_get_si
     in
-    	returnSUs (\xs -> a1 : a2 : a3 : r1 : xs)
+    	returnUs (\xs -> a1 : a2 : a3 : r1 : xs)
 
 arrayOfData_info = sStLitLbl SLIT("ArrayOfData_info")
 
-gmpInt2Integer 
-    :: Target 
+gmpInt2Integer
+    :: Target
     -> (CAddrMode, CAddrMode, CAddrMode) -- result (3 parts)
     -> (CAddrMode, CAddrMode)	-- allocated heap, Int to convert
-    -> SUniqSM StixTreeList
+    -> UniqSM StixTreeList
 
 gmpInt2Integer target_STRICT res@(car,csr,cdr) args@(chp, n) =
-    getUniqLabelNCG			`thenSUs` \ zlbl ->
-    getUniqLabelNCG			`thenSUs` \ nlbl ->
-    getUniqLabelNCG			`thenSUs` \ jlbl ->
+    getUniqLabelNCG			`thenUs` \ zlbl ->
+    getUniqLabelNCG			`thenUs` \ nlbl ->
+    getUniqLabelNCG			`thenUs` \ jlbl ->
     let
 	a2stix = amodeToStix target
 
 	ar  = a2stix car
 	sr  = a2stix csr
 	dr  = a2stix cdr
-        hp  = a2stix chp
+	hp  = a2stix chp
 	i   = a2stix n
 
-    	h1 = StAssign PtrKind (StInd PtrKind hp) arrayOfData_info
+    	h1 = StAssign PtrRep (StInd PtrRep hp) arrayOfData_info
     	size = varHeaderSize target (DataRep 0) + mIN_MP_INT_SIZE
-    	h2 = StAssign IntKind (StInd IntKind (StIndex IntKind hp (StInt 1)))
-                              (StInt (toInteger size))
-        cts = StInd IntKind (StIndex IntKind hp (dataHS target))
-        test1 = StPrim IntEqOp [i, StInt 0]
-        test2 = StPrim IntLtOp [i, StInt 0]
-        cjmp1 = StCondJump zlbl test1
-        cjmp2 = StCondJump nlbl test2
+    	h2 = StAssign IntRep (StInd IntRep (StIndex IntRep hp (StInt 1)))
+			      (StInt (toInteger size))
+	cts = StInd IntRep (StIndex IntRep hp (dataHS target))
+	test1 = StPrim IntEqOp [i, StInt 0]
+	test2 = StPrim IntLtOp [i, StInt 0]
+	cjmp1 = StCondJump zlbl test1
+	cjmp2 = StCondJump nlbl test2
     	-- positive
-        p1 = StAssign IntKind cts i
-        p2 = StAssign IntKind sr (StInt 1)
-        p3 = StJump (StCLbl jlbl)
+	p1 = StAssign IntRep cts i
+	p2 = StAssign IntRep sr (StInt 1)
+	p3 = StJump (StCLbl jlbl)
     	-- negative
-        n0 = StLabel nlbl
-        n1 = StAssign IntKind cts (StPrim IntNegOp [i])
-        n2 = StAssign IntKind sr (StInt (-1))
-        n3 = StJump (StCLbl jlbl)
+	n0 = StLabel nlbl
+	n1 = StAssign IntRep cts (StPrim IntNegOp [i])
+	n2 = StAssign IntRep sr (StInt (-1))
+	n3 = StJump (StCLbl jlbl)
     	-- zero
-        z0 = StLabel zlbl
-        z1 = StAssign IntKind sr (StInt 0)
-        -- everybody
-        a0 = StLabel jlbl
-        a1 = StAssign IntKind ar (StInt 1)
-        a2 = StAssign PtrKind dr hp
+	z0 = StLabel zlbl
+	z1 = StAssign IntRep sr (StInt 0)
+	-- everybody
+	a0 = StLabel jlbl
+	a1 = StAssign IntRep ar (StInt 1)
+	a2 = StAssign PtrRep dr hp
     in
-    	returnSUs (\xs -> 
+    	returnUs (\xs ->
     	    case n of
-            	CLit (MachInt c _) ->
+	    	CLit (MachInt c _) ->
     	    	    if c == 0 then     h1 : h2 : z1 : a1 : a2 : xs
-                    else if c > 0 then h1 : h2 : p1 : p2 : a1 : a2 : xs
-                    else               h1 : h2 : n1 : n2 : a1 : a2 : xs
-    	    	_                ->    h1 : h2 : cjmp1 : cjmp2 : p1 : p2 : p3 
-    	    	    	            	: n0 : n1 : n2 : n3 : z0 : z1 
+		    else if c > 0 then h1 : h2 : p1 : p2 : a1 : a2 : xs
+		    else               h1 : h2 : n1 : n2 : a1 : a2 : xs
+    	    	_                ->    h1 : h2 : cjmp1 : cjmp2 : p1 : p2 : p3
+    	    	    	            	: n0 : n1 : n2 : n3 : z0 : z1
     	    	    	    	    	: a0 : a1 : a2 : xs)
 
-gmpString2Integer 
-    :: Target 
+gmpString2Integer
+    :: Target
     -> (CAddrMode, CAddrMode, CAddrMode)    -- result (3 parts)
     -> (CAddrMode, CAddrMode)		    -- liveness, string
-    -> SUniqSM StixTreeList
+    -> UniqSM StixTreeList
 
 gmpString2Integer target_STRICT res@(car,csr,cdr) (liveness, str) =
-    getUniqLabelNCG					`thenSUs` \ ulbl ->
+    getUniqLabelNCG					`thenUs` \ ulbl ->
     let
 	a2stix  = amodeToStix target
 	data_hs = dataHS target
@@ -313,34 +312,34 @@ gmpString2Integer target_STRICT res@(car,csr,cdr) (liveness, str) =
     	    _ -> panic "String2Integer"
     	space = len `quot` 8 + 17 + mpIntSize +
     	    varHeaderSize target (DataRep 0) + fixedHeaderSize target
-    	oldHp = StIndex PtrKind stgHp (StInt (toInteger (-space)))
+    	oldHp = StIndex PtrRep stgHp (StInt (toInteger (-space)))
     	safeHp = saveLoc target Hp
-    	save = StAssign PtrKind safeHp oldHp
-    	result = StIndex IntKind stgHpLim (StInt (toInteger (-mpIntSize)))
-    	set_str = StCall SLIT("mpz_init_set_str") IntKind
+    	save = StAssign PtrRep safeHp oldHp
+    	result = StIndex IntRep stgHpLim (StInt (toInteger (-mpIntSize)))
+    	set_str = StCall SLIT("mpz_init_set_str") IntRep
     	    [result, a2stix str, StInt 10]
     	test = StPrim IntEqOp [set_str, StInt 0]
     	cjmp = StCondJump ulbl test
-    	abort = StCall SLIT("abort") VoidKind []
+    	abort = StCall SLIT("abort") VoidRep []
     	join = StLabel ulbl
-    	restore = StAssign PtrKind stgHp safeHp
+    	restore = StAssign PtrRep stgHp safeHp
     	(a1,a2,a3) = fromStruct data_hs result (ar,sr,dr)
     in
     	macroCode target HEAP_CHK [liveness, mkIntCLit space, mkIntCLit_0]
-    	    	    	    	    	    	    	`thenSUs` \ heap_chk ->
+    	    	    	    	    	    	    	`thenUs` \ heap_chk ->
 
-    	returnSUs (heap_chk .
+    	returnUs (heap_chk .
     	    (\xs -> save : cjmp : abort : join : a1 : a2 : a3 : restore : xs))
 
 mkIntCLit_0 = mkIntCLit 0 -- out here to avoid CAF (sigh)
 
-encodeFloatingKind 
-    :: PrimKind 
-    -> Target 
+encodeFloatingKind
+    :: PrimRep
+    -> Target
     -> CAddrMode  	-- result
     -> (CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode)
 		-- heap pointer for result, integer argument (3 parts), exponent
-    -> SUniqSM StixTreeList
+    -> UniqSM StixTreeList
 
 encodeFloatingKind pk target_STRICT res args@(chp, caa,csa,cda, cexpon) =
     let
@@ -349,33 +348,33 @@ encodeFloatingKind pk target_STRICT res args@(chp, caa,csa,cda, cexpon) =
 	data_hs = dataHS target
 
 	result  = a2stix res
-	hp	= a2stix chp      
-	aa	= a2stix caa      
-	sa	= a2stix csa      
-	da	= a2stix cda      
+	hp	= a2stix chp
+	aa	= a2stix caa
+	sa	= a2stix csa
+	da	= a2stix cda
 	expon	= a2stix cexpon
 
-        pk' = if size_of FloatKind == size_of DoubleKind
-	      then DoubleKind
-              else pk
+	pk' = if size_of FloatRep == size_of DoubleRep
+	      then DoubleRep
+	      else pk
     	(a1,a2,a3) = toStruct data_hs hp (aa,sa,da)
     	fn = case pk' of
-    	    FloatKind -> SLIT("__encodeFloat")
-    	    DoubleKind -> SLIT("__encodeDouble")
+    	    FloatRep -> SLIT("__encodeFloat")
+    	    DoubleRep -> SLIT("__encodeDouble")
     	    _ -> panic "encodeFloatingKind"
     	encode = StCall fn pk' [hp, expon]
     	r1 = StAssign pk' result encode
     in
-    	returnSUs (\xs -> a1 : a2 : a3 : r1 : xs)
+    	returnUs (\xs -> a1 : a2 : a3 : r1 : xs)
 
-decodeFloatingKind 
-    :: PrimKind 
-    -> Target 
+decodeFloatingKind
+    :: PrimRep
+    -> Target
     -> (CAddrMode, CAddrMode, CAddrMode, CAddrMode)
 			-- exponent result, integer result (3 parts)
     -> (CAddrMode, CAddrMode)
 			-- heap pointer for exponent, floating argument
-    -> SUniqSM StixTreeList
+    -> UniqSM StixTreeList
 
 decodeFloatingKind pk target_STRICT res@(cexponr,car,csr,cdr) args@(chp, carg) =
     let
@@ -383,26 +382,26 @@ decodeFloatingKind pk target_STRICT res@(cexponr,car,csr,cdr) args@(chp, carg) =
 	size_of = sizeof target
 	data_hs = dataHS target
 
-	exponr	= a2stix cexponr  
-	ar	= a2stix car      
-	sr	= a2stix csr      
-	dr	= a2stix cdr      
-        hp	= a2stix chp      
-	arg	= a2stix carg     
-
-        pk' = if size_of FloatKind == size_of DoubleKind
-	      then DoubleKind
-              else pk
-        setup = StAssign PtrKind mpData_mantissa (StIndex IntKind hp (StInt 1))
+	exponr	= a2stix cexponr
+	ar	= a2stix car
+	sr	= a2stix csr
+	dr	= a2stix cdr
+	hp	= a2stix chp
+	arg	= a2stix carg
+
+	pk' = if size_of FloatRep == size_of DoubleRep
+	      then DoubleRep
+	      else pk
+	setup = StAssign PtrRep mpData_mantissa (StIndex IntRep hp (StInt 1))
     	fn = case pk' of
-    	    FloatKind -> SLIT("__decodeFloat")
-    	    DoubleKind -> SLIT("__decodeDouble")
+    	    FloatRep -> SLIT("__decodeFloat")
+    	    DoubleRep -> SLIT("__decodeDouble")
     	    _ -> panic "decodeFloatingKind"
-    	decode = StCall fn VoidKind [mantissa, hp, arg]
+    	decode = StCall fn VoidRep [mantissa, hp, arg]
     	(a1,a2,a3) = fromStruct data_hs mantissa (ar,sr,dr)
-    	a4 = StAssign IntKind exponr (StInd IntKind hp)
+    	a4 = StAssign IntRep exponr (StInd IntRep hp)
     in
-    	returnSUs (\xs -> setup : decode : a1 : a2 : a3 : a4 : xs)
+    	returnUs (\xs -> setup : decode : a1 : a2 : a3 : a4 : xs)
 
 mantissa = mpStruct 1 -- out here to avoid CAF (sigh)
 mpData_mantissa = mpData mantissa
@@ -415,18 +414,18 @@ Support for the Gnu GMP multi-precision package.
 mpIntSize = 3 :: Int
 
 mpAlloc, mpSize, mpData :: StixTree -> StixTree
-mpAlloc base = StInd IntKind base
-mpSize base = StInd IntKind (StIndex IntKind base (StInt 1))
-mpData base = StInd PtrKind (StIndex IntKind base (StInt 2))
+mpAlloc base = StInd IntRep base
+mpSize base = StInd IntRep (StIndex IntRep base (StInt 1))
+mpData base = StInd PtrRep (StIndex IntRep base (StInt 2))
 
-mpSpace 
+mpSpace
     :: StixTree		-- dataHs from Target
     -> Int  	    	-- gmp structures needed
     -> Int  	    	-- number of results
     -> [StixTree]	-- sizes to add for estimating result size
     -> StixTree  	-- total space
 
-mpSpace data_hs gmp res sizes = 
+mpSpace data_hs gmp res sizes =
     foldr sum (StPrim IntAddOp [fixed, hdrs]) sizes
   where
     sum x y = StPrim IntAddOp [StPrim IntAbsOp [x], y]
@@ -442,33 +441,33 @@ which includes the space needed for these temporaries before you use them.
 
 \begin{code}
 mpStruct :: Int -> StixTree
-mpStruct n = StIndex IntKind stgHpLim (StInt (toInteger (-(n * mpIntSize))))
+mpStruct n = StIndex IntRep stgHpLim (StInt (toInteger (-(n * mpIntSize))))
 
-toStruct 
+toStruct
     :: StixTree		-- dataHS, from Target
-    -> StixTree 
-    -> (StixTree, StixTree, StixTree) 
-    -> (StixTree, StixTree, StixTree) 
+    -> StixTree
+    -> (StixTree, StixTree, StixTree)
+    -> (StixTree, StixTree, StixTree)
 
 toStruct data_hs str (alloc,size,arr) =
     let
-    	f1 = StAssign IntKind (mpAlloc str) alloc
-    	f2 = StAssign IntKind (mpSize str) size
-    	f3 = StAssign PtrKind (mpData str) (StIndex PtrKind arr data_hs)
+    	f1 = StAssign IntRep (mpAlloc str) alloc
+    	f2 = StAssign IntRep (mpSize str) size
+    	f3 = StAssign PtrRep (mpData str) (StIndex PtrRep arr data_hs)
     in
     	(f1, f2, f3)
 
-fromStruct 
+fromStruct
     :: StixTree		-- dataHS, from Target
-    -> StixTree 
-    -> (StixTree, StixTree, StixTree) 
-    -> (StixTree, StixTree, StixTree) 
+    -> StixTree
+    -> (StixTree, StixTree, StixTree)
+    -> (StixTree, StixTree, StixTree)
 
 fromStruct data_hs str (alloc,size,arr) =
     let
-    	e1 = StAssign IntKind alloc (mpAlloc str)
-    	e2 = StAssign IntKind size (mpSize str)
-    	e3 = StAssign PtrKind arr (StIndex PtrKind (mpData str) 
+    	e1 = StAssign IntRep alloc (mpAlloc str)
+    	e2 = StAssign IntRep size (mpSize str)
+    	e3 = StAssign PtrRep arr (StIndex PtrRep (mpData str)
     	    	    	    	    	    	   (StPrim IntNegOp [data_hs]))
     in
     	(e1, e2, e3)
diff --git a/ghc/compiler/nativeGen/StixMacro.hi b/ghc/compiler/nativeGen/StixMacro.hi
deleted file mode 100644
index dba792dbe0..0000000000
--- a/ghc/compiler/nativeGen/StixMacro.hi
+++ /dev/null
@@ -1,27 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface StixMacro where
-import AbsCSyn(AbstractC, CAddrMode, CExprMacro, CStmtMacro, MagicId, RegRelative)
-import BasicLit(BasicLit)
-import CLabelInfo(CLabel)
-import CharSeq(CSeq)
-import CostCentre(CostCentre)
-import HeapOffs(HeapOffset)
-import MachDesc(RegLoc, Target)
-import PreludePS(_PackedString)
-import PreludeRatio(Ratio(..))
-import PrimKind(PrimKind)
-import PrimOps(PrimOp)
-import SMRep(SMRep)
-import SplitUniq(SplitUniqSupply)
-import Stix(CodeSegment, StixReg, StixTree)
-import Unique(Unique)
-data CAddrMode 
-data CExprMacro 
-data CStmtMacro 
-data Target 
-data SplitUniqSupply 
-data StixTree 
-doHeapCheck :: StixTree -> StixTree -> StixTree -> SplitUniqSupply -> [StixTree] -> [StixTree]
-genMacroCode :: Target -> CStmtMacro -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]
-smStablePtrTable :: StixTree
-
diff --git a/ghc/compiler/nativeGen/StixMacro.lhs b/ghc/compiler/nativeGen/StixMacro.lhs
index 6f3e8c796b..b244110f02 100644
--- a/ghc/compiler/nativeGen/StixMacro.lhs
+++ b/ghc/compiler/nativeGen/StixMacro.lhs
@@ -8,22 +8,20 @@
 module StixMacro (
 	genMacroCode, doHeapCheck, smStablePtrTable,
 
-	Target, StixTree, SplitUniqSupply, CAddrMode, CExprMacro,
+	Target, StixTree, UniqSupply, CAddrMode, CExprMacro,
 	CStmtMacro
     ) where
 
 import AbsCSyn
-import AbsPrel      ( PrimOp(..)
+import PrelInfo      ( PrimOp(..)
 		      IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
 			  IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
 		    )
 import MachDesc	    {- lots -}
 import CgCompInfo   ( sTD_UF_SIZE, uF_RET, uF_SUA, uF_SUB, uF_UPDATEE )
 import Stix
-import SplitUniq
-import Unique
+import UniqSupply
 import Util
-
 \end{code}
 
 The @ARGS_CHK_A{_LOAD_NODE}@ macros check for sufficient arguments on
@@ -38,11 +36,11 @@ mkIntCLit_3 = mkIntCLit 3
 -- hacking with Uncle Will:
 #define target_STRICT target@(Target _ _ _ _ _ _ _ _)
 
-genMacroCode 
-    :: Target 
+genMacroCode
+    :: Target
     -> CStmtMacro   	    -- statement macro
     -> [CAddrMode]  	    -- args
-    -> SUniqSM StixTreeList
+    -> UniqSM StixTreeList
 
 genMacroCode target_STRICT macro args
  = genmacro macro args
@@ -52,25 +50,25 @@ genMacroCode target_STRICT macro args
 
   -- real thing: here we go -----------------------
 
-  genmacro ARGS_CHK_A_LOAD_NODE args = 
-    getUniqLabelNCG					`thenSUs` \ ulbl ->
+  genmacro ARGS_CHK_A_LOAD_NODE args =
+    getUniqLabelNCG					`thenUs` \ ulbl ->
     let [words, lbl] = map a2stix args
-    	temp = StIndex PtrKind stgSpA words
+    	temp = StIndex PtrRep stgSpA words
 	test = StPrim AddrGeOp [stgSuA, temp]
 	cjmp = StCondJump ulbl test
-	assign = StAssign PtrKind stgNode lbl
+	assign = StAssign PtrRep stgNode lbl
 	join = StLabel ulbl
     in
-	returnSUs (\xs -> cjmp : assign : updatePAP : join : xs)
+	returnUs (\xs -> cjmp : assign : updatePAP : join : xs)
 
-  genmacro ARGS_CHK_A [words] = 
-    getUniqLabelNCG					`thenSUs` \ ulbl ->
-    let temp = StIndex PtrKind stgSpA (a2stix words)
+  genmacro ARGS_CHK_A [words] =
+    getUniqLabelNCG					`thenUs` \ ulbl ->
+    let temp = StIndex PtrRep stgSpA (a2stix words)
 	test = StPrim AddrGeOp [stgSuA, temp]
 	cjmp = StCondJump ulbl test
 	join = StLabel ulbl
     in
-	returnSUs (\xs -> cjmp : updatePAP : join : xs)
+	returnUs (\xs -> cjmp : updatePAP : join : xs)
 
 \end{code}
 
@@ -82,25 +80,25 @@ directions are swapped relative to the A stack.
 
 \begin{code}
 
-  genmacro ARGS_CHK_B_LOAD_NODE args = 
-    getUniqLabelNCG					`thenSUs` \ ulbl ->
+  genmacro ARGS_CHK_B_LOAD_NODE args =
+    getUniqLabelNCG					`thenUs` \ ulbl ->
     let [words, lbl] = map a2stix args
-    	temp = StIndex PtrKind stgSuB (StPrim IntNegOp [words])
+    	temp = StIndex PtrRep stgSuB (StPrim IntNegOp [words])
 	test = StPrim AddrGeOp [stgSpB, temp]
 	cjmp = StCondJump ulbl test
-	assign = StAssign PtrKind stgNode lbl
+	assign = StAssign PtrRep stgNode lbl
 	join = StLabel ulbl
     in
-	returnSUs (\xs -> cjmp : assign : updatePAP : join : xs)
+	returnUs (\xs -> cjmp : assign : updatePAP : join : xs)
 
-  genmacro ARGS_CHK_B [words] = 
-    getUniqLabelNCG					`thenSUs` \ ulbl ->
-    let	temp = StIndex PtrKind stgSuB (StPrim IntNegOp [a2stix words])
+  genmacro ARGS_CHK_B [words] =
+    getUniqLabelNCG					`thenUs` \ ulbl ->
+    let	temp = StIndex PtrRep stgSuB (StPrim IntNegOp [a2stix words])
 	test = StPrim AddrGeOp [stgSpB, temp]
 	cjmp = StCondJump ulbl test
 	join = StLabel ulbl
     in
-	returnSUs (\xs -> cjmp : updatePAP : join : xs)
+	returnUs (\xs -> cjmp : updatePAP : join : xs)
 
 \end{code}
 
@@ -117,8 +115,7 @@ primOps, this is just a wrapper.
   genmacro HEAP_CHK args =
     let [liveness,words,reenter] = map a2stix args
     in
-	doHeapCheck {-UNUSED NOW:target-} liveness words reenter
-
+	doHeapCheck liveness words reenter
 \end{code}
 
 The @STK_CHK@ macro checks for enough space on the stack between @SpA@
@@ -129,19 +126,19 @@ so we don't have to @callWrapper@ it.
 
 \begin{code}
 
-  genmacro STK_CHK [liveness, aWords, bWords, spa, spb, prim, reenter] = 
+  genmacro STK_CHK [liveness, aWords, bWords, spa, spb, prim, reenter] =
 {- Need to check to see if we are compiling with stack checks
-    getUniqLabelNCG					`thenSUs` \ ulbl ->
-    let words = StPrim IntNegOp 
+    getUniqLabelNCG					`thenUs` \ ulbl ->
+    let words = StPrim IntNegOp
     	    [StPrim IntAddOp [a2stix aWords, a2stix bWords]]
-	temp = StIndex PtrKind stgSpA words
+	temp = StIndex PtrRep stgSpA words
 	test = StPrim AddrGtOp [temp, stgSpB]
 	cjmp = StCondJump ulbl test
 	join = StLabel ulbl
     in
-	returnSUs (\xs -> cjmp : stackOverflow : join : xs)
+	returnUs (\xs -> cjmp : stackOverflow : join : xs)
 -}
-    returnSUs id
+    returnUs id
 
 \end{code}
 
@@ -152,15 +149,15 @@ and putting the new CAF on a linked list for the storage manager.
 
   genmacro UPD_CAF args =
     let [cafptr,bhptr] = map a2stix args
-    	w0 = StInd PtrKind cafptr
-	w1 = StInd PtrKind (StIndex PtrKind cafptr (StInt 1))
-	w2 = StInd PtrKind (StIndex PtrKind cafptr (StInt 2))
-	a1 = StAssign PtrKind w0 caf_info
-	a2 = StAssign PtrKind w1 smCAFlist
-	a3 = StAssign PtrKind w2 bhptr
-	a4 = StAssign PtrKind smCAFlist cafptr
+    	w0 = StInd PtrRep cafptr
+	w1 = StInd PtrRep (StIndex PtrRep cafptr (StInt 1))
+	w2 = StInd PtrRep (StIndex PtrRep cafptr (StInt 2))
+	a1 = StAssign PtrRep w0 caf_info
+	a2 = StAssign PtrRep w1 smCAFlist
+	a3 = StAssign PtrRep w2 bhptr
+	a4 = StAssign PtrRep smCAFlist cafptr
     in
-	returnSUs (\xs -> a1 : a2 : a3 : a4 : xs)
+	returnUs (\xs -> a1 : a2 : a3 : a4 : xs)
 
 \end{code}
 
@@ -170,20 +167,20 @@ if we update an old generation object.
 
 \begin{code}
 
-  genmacro UPD_IND args = 
-    getUniqLabelNCG					`thenSUs` \ ulbl ->
+  genmacro UPD_IND args =
+    getUniqLabelNCG					`thenUs` \ ulbl ->
     let [updptr, heapptr] = map a2stix args
     	test = StPrim AddrGtOp [updptr, smOldLim]
     	cjmp = StCondJump ulbl test
-    	updRoots = StAssign PtrKind smOldMutables updptr
+    	updRoots = StAssign PtrRep smOldMutables updptr
 	join = StLabel ulbl
-    	upd0 = StAssign PtrKind (StInd PtrKind updptr) ind_info
-    	upd1 = StAssign PtrKind (StInd PtrKind 
-    	    	(StIndex PtrKind updptr (StInt 1))) smOldMutables
-    	upd2 = StAssign PtrKind (StInd PtrKind 
-    	    	(StIndex PtrKind updptr (StInt 2))) heapptr
+    	upd0 = StAssign PtrRep (StInd PtrRep updptr) ind_info
+    	upd1 = StAssign PtrRep (StInd PtrRep
+    	    	(StIndex PtrRep updptr (StInt 1))) smOldMutables
+    	upd2 = StAssign PtrRep (StInd PtrRep
+    	    	(StIndex PtrRep updptr (StInt 2))) heapptr
     in
-    	returnSUs (\xs -> cjmp : upd1 : updRoots : join : upd0 : upd2 : xs)
+    	returnUs (\xs -> cjmp : upd1 : updRoots : join : upd0 : upd2 : xs)
 
 \end{code}
 
@@ -191,34 +188,34 @@ if we update an old generation object.
 
 \begin{code}
 
-  genmacro UPD_INPLACE_NOPTRS args = returnSUs id
+  genmacro UPD_INPLACE_NOPTRS args = returnUs id
 
 \end{code}
 
 @UPD_INPLACE_PTRS@ is complicated by the fact that we are supporting
-the Appel-style garbage collector by default.  This means some extra work 
+the Appel-style garbage collector by default.  This means some extra work
 if we update an old generation object.
 
 \begin{code}
 
   genmacro UPD_INPLACE_PTRS [liveness] =
-    getUniqLabelNCG					`thenSUs` \ ulbl ->
+    getUniqLabelNCG					`thenUs` \ ulbl ->
     let cjmp = StCondJump ulbl testOldLim
-        testOldLim = StPrim AddrGtOp [stgNode, smOldLim]
+	testOldLim = StPrim AddrGtOp [stgNode, smOldLim]
 	join = StLabel ulbl
-        updUpd0 = StAssign PtrKind (StInd PtrKind stgNode) ind_info
-    	updUpd1 = StAssign PtrKind (StInd PtrKind 
-	    	    (StIndex PtrKind stgNode (StInt 1))) smOldMutables
-    	updUpd2 = StAssign PtrKind (StInd PtrKind 
-    	    	    (StIndex PtrKind stgNode (StInt 2))) hpBack2
-    	hpBack2 = StIndex PtrKind stgHp (StInt (-2))
-    	updOldMutables = StAssign PtrKind smOldMutables stgNode
-    	updUpdReg = StAssign PtrKind stgNode hpBack2
+	updUpd0 = StAssign PtrRep (StInd PtrRep stgNode) ind_info
+    	updUpd1 = StAssign PtrRep (StInd PtrRep
+	    	    (StIndex PtrRep stgNode (StInt 1))) smOldMutables
+    	updUpd2 = StAssign PtrRep (StInd PtrRep
+    	    	    (StIndex PtrRep stgNode (StInt 2))) hpBack2
+    	hpBack2 = StIndex PtrRep stgHp (StInt (-2))
+    	updOldMutables = StAssign PtrRep smOldMutables stgNode
+    	updUpdReg = StAssign PtrRep stgNode hpBack2
     in
 	genmacro HEAP_CHK [liveness, mkIntCLit_3, mkIntCLit_0]
-							`thenSUs` \ heap_chk ->
-	returnSUs (\xs -> (cjmp : 
-    	    	    	    heap_chk (updUpd0 : updUpd1 : updUpd2 : 
+							`thenUs` \ heap_chk ->
+	returnUs (\xs -> (cjmp :
+    	    	    	    heap_chk (updUpd0 : updUpd1 : updUpd2 :
     	    	    	    	    	updOldMutables : updUpdReg : join : xs)))
 
 \end{code}
@@ -229,13 +226,13 @@ to handle @UPD_BH_SINGLE_ENTRY@ in all cases.
 
 \begin{code}
 
-  genmacro UPD_BH_UPDATABLE args = returnSUs id
+  genmacro UPD_BH_UPDATABLE args = returnUs id
 
   genmacro UPD_BH_SINGLE_ENTRY [arg] =
     let
-    	update = StAssign PtrKind (StInd PtrKind (a2stix arg)) bh_info
+    	update = StAssign PtrRep (StInd PtrRep (a2stix arg)) bh_info
     in
-        returnSUs (\xs -> update : xs)
+	returnUs (\xs -> update : xs)
 
 \end{code}
 
@@ -246,22 +243,22 @@ registers to the current Sp[AB] locations.
 
   genmacro PUSH_STD_UPD_FRAME args =
     let [bhptr, aWords, bWords] = map a2stix args
-    	frame n = StInd PtrKind 
-	    (StIndex PtrKind stgSpB (StPrim IntAddOp 
+    	frame n = StInd PtrRep
+	    (StIndex PtrRep stgSpB (StPrim IntAddOp
     	    	[bWords, StInt (toInteger (sTD_UF_SIZE - n))]))
 
-	a1 = StAssign PtrKind (frame uF_RET) stgRetReg
-	a2 = StAssign PtrKind (frame uF_SUB) stgSuB
-	a3 = StAssign PtrKind (frame uF_SUA) stgSuA
-	a4 = StAssign PtrKind (frame uF_UPDATEE) bhptr
+	a1 = StAssign PtrRep (frame uF_RET) stgRetReg
+	a2 = StAssign PtrRep (frame uF_SUB) stgSuB
+	a3 = StAssign PtrRep (frame uF_SUA) stgSuA
+	a4 = StAssign PtrRep (frame uF_UPDATEE) bhptr
 
-	updSuB = StAssign PtrKind
-	    stgSuB (StIndex PtrKind stgSpB (StPrim IntAddOp 
+	updSuB = StAssign PtrRep
+	    stgSuB (StIndex PtrRep stgSpB (StPrim IntAddOp
     	    	[bWords, StInt (toInteger sTD_UF_SIZE)]))
-	updSuA = StAssign PtrKind
-	    stgSuA (StIndex PtrKind stgSpA (StPrim IntNegOp [aWords]))
+	updSuA = StAssign PtrRep
+	    stgSuA (StIndex PtrRep stgSpA (StPrim IntNegOp [aWords]))
     in
-	returnSUs (\xs -> a1 : a2 : a3 : a4 : updSuB : updSuA : xs)
+	returnUs (\xs -> a1 : a2 : a3 : a4 : updSuB : updSuA : xs)
 
 \end{code}
 
@@ -270,48 +267,34 @@ Pop a standard update frame.
 \begin{code}
 
   genmacro POP_STD_UPD_FRAME args =
-    let frame n = StInd PtrKind (StIndex PtrKind stgSpB (StInt (toInteger (-n))))
+    let frame n = StInd PtrRep (StIndex PtrRep stgSpB (StInt (toInteger (-n))))
 
-	grabRet = StAssign PtrKind stgRetReg (frame uF_RET)
-	grabSuB = StAssign PtrKind stgSuB    (frame uF_SUB)
-	grabSuA = StAssign PtrKind stgSuA    (frame uF_SUA)
+	grabRet = StAssign PtrRep stgRetReg (frame uF_RET)
+	grabSuB = StAssign PtrRep stgSuB    (frame uF_SUB)
+	grabSuA = StAssign PtrRep stgSuA    (frame uF_SUA)
 
-	updSpB = StAssign PtrKind
-	    stgSpB (StIndex PtrKind stgSpB (StInt (toInteger (-sTD_UF_SIZE))))
+	updSpB = StAssign PtrRep
+	    stgSpB (StIndex PtrRep stgSpB (StInt (toInteger (-sTD_UF_SIZE))))
     in
-	returnSUs (\xs -> grabRet : grabSuB : grabSuA : updSpB : xs)
+	returnUs (\xs -> grabRet : grabSuB : grabSuA : updSpB : xs)
 
 \end{code}
 
-@PUSH_CON_UPD_FRAME@ appears to be unused at the moment.
-
+The @SET_ARITY@ and @CHK_ARITY@ macros are disabled for ``normal''
+compilation.
 \begin{code}
-{- UNUSED:
-  genmacro PUSH_CON_UPD_FRAME args = 
-    panic "genMacroCode:PUSH_CON_UPD_FRAME"
--}
-\end{code}
-
-The @SET_ARITY@ and @CHK_ARITY@ macros are disabled for ``normal'' compilation.
-
-\begin{code}
-
-  genmacro SET_ARITY args = returnSUs id
-  genmacro CHK_ARITY args = returnSUs id
-
+  genmacro SET_ARITY args = returnUs id
+  genmacro CHK_ARITY args = returnUs id
 \end{code}
 
 This one only applies if we have a machine register devoted to TagReg.
-
 \begin{code}
-
-  genmacro SET_TAG [tag] = 
-    let set_tag = StAssign IntKind stgTagReg (a2stix tag)
+  genmacro SET_TAG [tag] =
+    let set_tag = StAssign IntRep stgTagReg (a2stix tag)
     in
-        case stg_reg TagReg of
-            Always _ -> returnSUs id
-            Save _ -> returnSUs (\xs -> set_tag : xs)
-
+	case stg_reg TagReg of
+	    Always _ -> returnUs id
+	    Save   _ -> returnUs (\ xs -> set_tag : xs)
 \end{code}
 
 Do the business for a @HEAP_CHK@, having converted the args to Trees
@@ -319,25 +302,25 @@ of StixOp.
 
 \begin{code}
 
-doHeapCheck 
-    :: {- unused now: Target 
+doHeapCheck
+    :: {- unused now: Target
     -> -}StixTree  	-- liveness
     -> StixTree  	-- words needed
     -> StixTree  	-- always reenter node? (boolean)
-    -> SUniqSM StixTreeList
+    -> UniqSM StixTreeList
 
 doHeapCheck {-target:unused now-} liveness words reenter =
-    getUniqLabelNCG					`thenSUs` \ ulbl ->
-    let newHp = StIndex PtrKind stgHp words
-	assign = StAssign PtrKind stgHp newHp
+    getUniqLabelNCG					`thenUs` \ ulbl ->
+    let newHp = StIndex PtrRep stgHp words
+	assign = StAssign PtrRep stgHp newHp
 	test = StPrim AddrLeOp [stgHp, stgHpLim]
 	cjmp = StCondJump ulbl test
-        arg = StPrim IntAddOp [StPrim IntMulOp [words, StInt 256], liveness]
+	arg = StPrim IntAddOp [StPrim IntMulOp [words, StInt 256], liveness]
 	-- ToDo: Overflow?  (JSM)
-	gc = StCall SLIT("PerformGC_wrapper") VoidKind [arg]
+	gc = StCall SLIT("PerformGC_wrapper") VoidRep [arg]
 	join = StLabel ulbl
     in
-	returnSUs (\xs -> assign : cjmp : gc : join : xs)
+	returnUs (\xs -> assign : cjmp : gc : join : xs)
 
 \end{code}
 
@@ -358,11 +341,11 @@ ind_info  = sStLitLbl SLIT("Ind_info")
 updatePAP, stackOverflow :: StixTree
 
 updatePAP     = StJump (sStLitLbl SLIT("UpdatePAP"))
-stackOverflow = StCall SLIT("StackOverflow") VoidKind []
+stackOverflow = StCall SLIT("StackOverflow") VoidRep []
 
 \end{code}
 
-Storage manager nonsense.  Note that the indices are dependent on 
+Storage manager nonsense.  Note that the indices are dependent on
 the definition of the smInfo structure in SMinterface.lh
 
 \begin{code}
@@ -382,11 +365,11 @@ the definition of the smInfo structure in SMinterface.lh
 storageMgrInfo, smCAFlist, smOldMutables, smOldLim :: StixTree
 
 storageMgrInfo = sStLitLbl SLIT("StorageMgrInfo")
-smCAFlist  = StInd PtrKind (StIndex PtrKind storageMgrInfo (StInt SM_CAFLIST))
-smOldMutables = StInd PtrKind (StIndex PtrKind storageMgrInfo (StInt SM_OLDMUTABLES))
-smOldLim   = StInd PtrKind (StIndex PtrKind storageMgrInfo (StInt SM_OLDLIM))
+smCAFlist  = StInd PtrRep (StIndex PtrRep storageMgrInfo (StInt SM_CAFLIST))
+smOldMutables = StInd PtrRep (StIndex PtrRep storageMgrInfo (StInt SM_OLDMUTABLES))
+smOldLim   = StInd PtrRep (StIndex PtrRep storageMgrInfo (StInt SM_OLDLIM))
 
-smStablePtrTable = StInd PtrKind 
-    	    	    	 (StIndex PtrKind storageMgrInfo (StInt SM_STABLEPOINTERTABLE))
+smStablePtrTable = StInd PtrRep
+    	    	    	 (StIndex PtrRep storageMgrInfo (StInt SM_STABLEPOINTERTABLE))
 
 \end{code}
diff --git a/ghc/compiler/nativeGen/StixPrim.hi b/ghc/compiler/nativeGen/StixPrim.hi
deleted file mode 100644
index a14b709ede..0000000000
--- a/ghc/compiler/nativeGen/StixPrim.hi
+++ /dev/null
@@ -1,27 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface StixPrim where
-import AbsCSyn(AbstractC, CAddrMode, CExprMacro, CStmtMacro, MagicId, RegRelative)
-import BasicLit(BasicLit)
-import CLabelInfo(CLabel)
-import CharSeq(CSeq)
-import CostCentre(CostCentre)
-import HeapOffs(HeapOffset)
-import MachDesc(RegLoc, Target)
-import PreludePS(_PackedString)
-import PreludeRatio(Ratio(..))
-import PrimKind(PrimKind)
-import PrimOps(PrimOp)
-import SMRep(SMRep)
-import SplitUniq(SplitUniqSupply)
-import Stix(CodeSegment, StixReg, StixTree)
-import UniType(UniType)
-import Unique(Unique)
-data CAddrMode 
-data Target 
-data PrimOp 
-data SplitUniqSupply 
-data StixTree 
-amodeCode :: Target -> CAddrMode -> StixTree
-amodeCode' :: Target -> CAddrMode -> StixTree
-genPrimCode :: Target -> [CAddrMode] -> PrimOp -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]
-
diff --git a/ghc/compiler/nativeGen/StixPrim.lhs b/ghc/compiler/nativeGen/StixPrim.lhs
index 40c1a3a878..e566c7b5e7 100644
--- a/ghc/compiler/nativeGen/StixPrim.lhs
+++ b/ghc/compiler/nativeGen/StixPrim.lhs
@@ -8,29 +8,27 @@
 module StixPrim (
 	genPrimCode, amodeCode, amodeCode',
 
-    	Target, CAddrMode, StixTree, PrimOp, SplitUniqSupply
+    	Target, CAddrMode, StixTree, PrimOp, UniqSupply
     ) where
 
 IMPORT_Trace	-- ToDo: rm debugging
 
 import AbsCSyn
-import AbsPrel		( PrimOp(..), PrimOpResultInfo(..), TyCon,
+import PrelInfo		( PrimOp(..), PrimOpResultInfo(..), TyCon,
 			  getPrimOpResultInfo, isCompareOp, showPrimOp
 			  IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
 			  IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
 			)
-import AbsUniType	( cmpTyCon ) -- pragmas only
 import CgCompInfo	( spARelToInt, spBRelToInt )
 import MachDesc
-import Pretty	    
-import PrimKind		( isFloatingKind )
+import Pretty
+import PrimRep		( isFloatingRep )
 import CostCentre
 import SMRep		( SMRep(..), SMSpecRepKind(..), SMUpdateKind(..) )
 import Stix
 import StixMacro	( smStablePtrTable )
 import StixInteger	{- everything -}
-import SplitUniq
-import Unique
+import UniqSupply
 import Unpretty
 import Util
 
@@ -43,11 +41,11 @@ arrayOfData_info      = sStLitLbl SLIT("ArrayOfData_info") -- out here to avoid
 imMutArrayOfPtrs_info = sStLitLbl SLIT("ImMutArrayOfPtrs_info")
 
 genPrimCode
-    :: Target 
+    :: Target
     -> [CAddrMode]  	-- results
     -> PrimOp 	    	-- op
     -> [CAddrMode]  	-- args
-    -> SUniqSM StixTreeList
+    -> UniqSM StixTreeList
 
 \end{code}
 
@@ -75,12 +73,12 @@ genPrimCode target_STRICT res op args
   heap_chkr = heapCheck target
   size_of   = sizeof target
   fixed_hs  = fixedHeaderSize target
-  var_hs    = varHeaderSize target 
+  var_hs    = varHeaderSize target
 
   --- real code will follow... -------------
 \end{code}
 
-The (MP) integer operations are a true nightmare.  Since we don't have a 
+The (MP) integer operations are a true nightmare.  Since we don't have a
 convenient abstract way of allocating temporary variables on the (C) stack,
 we use the space just below HpLim for the @MP_INT@ structures, and modify our
 heap check accordingly.
@@ -115,10 +113,10 @@ Since we are using the heap for intermediate @MP_INT@ structs, integer compariso
 
 \begin{code}
   genprim res@[exponr,ar,sr,dr] FloatDecodeOp args@[hp, arg] =
-    decodeFloatingKind FloatKind target (exponr,ar,sr,dr) (hp, arg)
+    decodeFloatingKind FloatRep target (exponr,ar,sr,dr) (hp, arg)
 
   genprim res@[exponr,ar,sr,dr] DoubleDecodeOp args@[hp, arg] =
-    decodeFloatingKind DoubleKind target (exponr,ar,sr,dr) (hp, arg)
+    decodeFloatingKind DoubleRep target (exponr,ar,sr,dr) (hp, arg)
 
   genprim res@[ar,sr,dr] Int2IntegerOp args@[hp, n]
     = gmpInt2Integer target (ar,sr,dr) (hp, n)
@@ -133,22 +131,22 @@ Since we are using the heap for intermediate @MP_INT@ structs, integer compariso
     = gmpInteger2Int target res (hp, aa,sa,da)
 
   genprim [res] FloatEncodeOp args@[hp, aa,sa,da, expon] =
-    encodeFloatingKind FloatKind target res (hp, aa,sa,da, expon)
+    encodeFloatingKind FloatRep target res (hp, aa,sa,da, expon)
 
   genprim [res] DoubleEncodeOp args@[hp, aa,sa,da, expon] =
-    encodeFloatingKind DoubleKind target res (hp, aa,sa,da, expon)
+    encodeFloatingKind DoubleRep target res (hp, aa,sa,da, expon)
 
   genprim [res] Int2AddrOp [arg] =
-    simpleCoercion AddrKind res arg
+    simpleCoercion AddrRep res arg
 
   genprim [res] Addr2IntOp [arg] =
-    simpleCoercion IntKind res arg
+    simpleCoercion IntRep res arg
 
   genprim [res] Int2WordOp [arg] =
-    simpleCoercion IntKind{-WordKind?-} res arg
+    simpleCoercion IntRep{-WordRep?-} res arg
 
   genprim [res] Word2IntOp [arg] =
-    simpleCoercion IntKind res arg
+    simpleCoercion IntRep res arg
 
 \end{code}
 
@@ -157,10 +155,10 @@ closure, flush stdout and stderr, and jump to the @ErrorIO_innards@.
 
 \begin{code}
 
-  genprim [] ErrorIOPrimOp [rhs] = 
-    let changeTop = StAssign PtrKind topClosure (a2stix rhs)
+  genprim [] ErrorIOPrimOp [rhs] =
+    let changeTop = StAssign PtrRep topClosure (a2stix rhs)
     in
-	returnSUs (\xs -> changeTop : flushStdout : flushStderr : errorIO : xs)
+	returnUs (\xs -> changeTop : flushStdout : flushStderr : errorIO : xs)
 
 \end{code}
 
@@ -169,44 +167,44 @@ closure, flush stdout and stderr, and jump to the @ErrorIO_innards@.
 \begin{code}
   genprim [res] NewArrayOp args =
     let	[liveness, n, initial] = map a2stix args
-        result = a2stix res
+	result = a2stix res
     	space = StPrim IntAddOp [n, mut_hs]
-    	loc = StIndex PtrKind stgHp 
+    	loc = StIndex PtrRep stgHp
     	      (StPrim IntNegOp [StPrim IntSubOp [space, StInt 1]])
-    	assign = StAssign PtrKind result loc
-    	initialise = StCall SLIT("newArrZh_init") VoidKind [result, n, initial]
+    	assign = StAssign PtrRep result loc
+    	initialise = StCall SLIT("newArrZh_init") VoidRep [result, n, initial]
     in
-    	heap_chkr liveness space (StInt 0)	`thenSUs` \ heap_chk ->
+    	heap_chkr liveness space (StInt 0)	`thenUs` \ heap_chk ->
 
-    	returnSUs (heap_chk . (\xs -> assign : initialise : xs))
+    	returnUs (heap_chk . (\xs -> assign : initialise : xs))
 
   genprim [res] (NewByteArrayOp pk) args =
     let	[liveness, count] = map a2stix args
-        result = a2stix res
+	result = a2stix res
     	n = StPrim IntMulOp [count, StInt (toInteger (size_of pk))]
-        slop = StPrim IntAddOp [n, StInt (toInteger (size_of IntKind - 1))]
-        words = StPrim IntQuotOp [slop, StInt (toInteger (size_of IntKind))]
+	slop = StPrim IntAddOp [n, StInt (toInteger (size_of IntRep - 1))]
+	words = StPrim IntQuotOp [slop, StInt (toInteger (size_of IntRep))]
     	space = StPrim IntAddOp [n, StPrim IntAddOp [words, data_hs]]
-    	loc = StIndex PtrKind stgHp 
+    	loc = StIndex PtrRep stgHp
     	      (StPrim IntNegOp [StPrim IntSubOp [space, StInt 1]])
-    	assign = StAssign PtrKind result loc
-    	init1 = StAssign PtrKind (StInd PtrKind loc) arrayOfData_info
-        init2 = StAssign IntKind 
-    	    	    	 (StInd IntKind 
-    	    	    	    	(StIndex IntKind loc 
+    	assign = StAssign PtrRep result loc
+    	init1 = StAssign PtrRep (StInd PtrRep loc) arrayOfData_info
+	init2 = StAssign IntRep
+    	    	    	 (StInd IntRep
+    	    	    	    	(StIndex IntRep loc
     	    	    	    	    	 (StInt (toInteger fixed_hs))))
-                         (StPrim IntAddOp [words, 
+			 (StPrim IntAddOp [words,
     	    	    	    	    	  StInt (toInteger (var_hs (DataRep 0)))])
     in
-    	heap_chkr liveness space (StInt 0)	`thenSUs` \ heap_chk ->
+    	heap_chkr liveness space (StInt 0)	`thenUs` \ heap_chk ->
 
-    	returnSUs (heap_chk . (\xs -> assign : init1 : init2 : xs))
+    	returnUs (heap_chk . (\xs -> assign : init1 : init2 : xs))
 
   genprim [res] SameMutableArrayOp args =
     let compare = StPrim AddrEqOp (map a2stix args)
-        assign = StAssign IntKind (a2stix res) compare
+	assign = StAssign IntRep (a2stix res) compare
     in
-        returnSUs (\xs -> assign : xs)
+	returnUs (\xs -> assign : xs)
 
   genprim res@[_] SameMutableByteArrayOp args =
     genprim res SameMutableArrayOp args
@@ -222,14 +220,14 @@ the indirection (most likely, it's a VanillaReg).
   genprim [lhs] UnsafeFreezeArrayOp [rhs] =
     let lhs' = a2stix lhs
     	rhs' = a2stix rhs
-    	header = StInd PtrKind lhs'
-	assign = StAssign PtrKind lhs' rhs'
-	freeze = StAssign PtrKind header imMutArrayOfPtrs_info
+    	header = StInd PtrRep lhs'
+	assign = StAssign PtrRep lhs' rhs'
+	freeze = StAssign PtrRep header imMutArrayOfPtrs_info
     in
-	returnSUs (\xs -> assign : freeze : xs)
+	returnUs (\xs -> assign : freeze : xs)
 
   genprim [lhs] UnsafeFreezeByteArrayOp [rhs] =
-    simpleCoercion PtrKind lhs rhs
+    simpleCoercion PtrRep lhs rhs
 
 \end{code}
 
@@ -244,19 +242,19 @@ Most other array primitives translate to simple indexing.
     let lhs' = a2stix lhs
     	obj' = a2stix obj
     	ix' = a2stix ix
-    	base = StIndex IntKind obj' mut_hs
-    	assign = StAssign PtrKind lhs' (StInd PtrKind (StIndex PtrKind base ix'))
+    	base = StIndex IntRep obj' mut_hs
+    	assign = StAssign PtrRep lhs' (StInd PtrRep (StIndex PtrRep base ix'))
     in
-    	returnSUs (\xs -> assign : xs)
+    	returnUs (\xs -> assign : xs)
 
   genprim [lhs] WriteArrayOp [obj, ix, v] =
     let	obj' = a2stix obj
     	ix' = a2stix ix
     	v' = a2stix v
-    	base = StIndex IntKind obj' mut_hs
-    	assign = StAssign PtrKind (StInd PtrKind (StIndex PtrKind base ix')) v'
+    	base = StIndex IntRep obj' mut_hs
+    	assign = StAssign PtrRep (StInd PtrRep (StIndex PtrRep base ix')) v'
     in
-    	returnSUs (\xs -> assign : xs)
+    	returnUs (\xs -> assign : xs)
 
   genprim lhs@[_] (IndexByteArrayOp pk) args =
     genprim lhs (ReadByteArrayOp pk) args
@@ -267,10 +265,10 @@ Most other array primitives translate to simple indexing.
     let lhs' = a2stix lhs
     	obj' = a2stix obj
     	ix' = a2stix ix
-    	base = StIndex IntKind obj' data_hs
+    	base = StIndex IntRep obj' data_hs
     	assign = StAssign pk lhs' (StInd pk (StIndex pk base ix'))
     in
-    	returnSUs (\xs -> assign : xs)
+    	returnUs (\xs -> assign : xs)
 
   genprim [lhs] (IndexOffAddrOp pk) [obj, ix] =
     let lhs' = a2stix lhs
@@ -278,16 +276,16 @@ Most other array primitives translate to simple indexing.
     	ix' = a2stix ix
     	assign = StAssign pk lhs' (StInd pk (StIndex pk obj' ix'))
     in
-    	returnSUs (\xs -> assign : xs)
+    	returnUs (\xs -> assign : xs)
 
   genprim [] (WriteByteArrayOp pk) [obj, ix, v] =
     let	obj' = a2stix obj
     	ix' = a2stix ix
     	v' = a2stix v
-    	base = StIndex IntKind obj' data_hs
+    	base = StIndex IntRep obj' data_hs
     	assign = StAssign pk (StInd pk (StIndex pk base ix')) v'
     in
-    	returnSUs (\xs -> assign : xs)
+    	returnUs (\xs -> assign : xs)
 \end{code}
 
 Stable pointer operations.
@@ -298,12 +296,12 @@ First the easy one.
 
   genprim [lhs] DeRefStablePtrOp [sp] =
     let lhs' = a2stix lhs
-    	pk = getAmodeKind lhs
+    	pk = getAmodeRep lhs
     	sp' = a2stix sp
 	call = StCall SLIT("deRefStablePointer") pk [sp', smStablePtrTable]
     	assign = StAssign pk lhs' call
     in
-    	returnSUs (\xs -> assign : xs)
+    	returnUs (\xs -> assign : xs)
 
 \end{code}
 
@@ -315,25 +313,25 @@ do {                                                                 \
   EXTDATA(MK_INFO_LBL(StablePointerTable));                          \
   EXTDATA(UnusedSP);                                                 \
   StgStablePtr newSP;                                                \
-                                                                     \
+								     \
   if (SPT_EMPTY(StorageMgrInfo.StablePointerTable)) { /* free stack is empty */ \
     I_ OldNoPtrs = SPT_NoPTRS(StorageMgrInfo.StablePointerTable);    \
-                                                                     \
+								     \
     /* any strictly increasing expression will do here */            \
     I_ NewNoPtrs = OldNoPtrs * 2 + 100;                              \
-                                                                     \
+								     \
     I_ NewSize = DYN_VHS + NewNoPtrs + 1 + NewNoPtrs;                \
     P_ SPTable;                                                      \
-                                                                     \
+								     \
     HEAP_CHK(NO_LIVENESS, _FHS+NewSize, 0);                          \
     CC_ALLOC(CCC, _FHS+NewSize, SPT_K); /* cc prof */                \
-                                                                     \
+								     \
     SPTable = Hp + 1 - (_FHS + NewSize);                             \
     SET_DYN_HDR(SPTable,StablePointerTable,CCC,NewSize,NewNoPtrs);   \
     SAFESTGCALL2(void, (void *, P_, P_), enlargeSPTable, SPTable, StorageMgrInfo.StablePointerTable);      \
     StorageMgrInfo.StablePointerTable = SPTable;                     \
   }                                                                  \
-                                                                     \
+								     \
   newSP = SPT_POP(StorageMgrInfo.StablePointerTable);                \
   SPT_SPTR(StorageMgrInfo.StablePointerTable, newSP) = unstablePtr; \
   stablePtr = newSP;                                                 \
@@ -352,33 +350,33 @@ Notes for ADR:
 
 \begin{pseudocode}
   genprim [lhs] MakeStablePtrOp args =
-    let 
+    let
 	-- some useful abbreviations (I'm sure these must exist already)
-	add = trPrim . IntAddOp 
+	add = trPrim . IntAddOp
 	sub = trPrim . IntSubOp
 	one = trInt [1]
-	dec x = trAssign IntKind [x, sub [x, one]]
-	inc x = trAssign IntKind [x, add [x, one]]
+	dec x = trAssign IntRep [x, sub [x, one]]
+	inc x = trAssign IntRep [x, add [x, one]]
 
 	-- tedious hardwiring in of closure layout offsets (from SMClosures)
 	dynHS = 2 + fixedHeaderSize md sty + varHeaderSize md sty DynamicRep
-	spt_SIZE c   = trIndex PtrKind [c, trInt [fhs + gc_reserved] ]
-	spt_NoPTRS c = trIndex PtrKind [c, trInt [fhs + gc_reserved + 1] ]
-	spt_SPTR c i = trIndex PtrKind [c, add [trInt [dynHS], i]]
-	spt_TOP c    = trIndex PtrKind [c, add [trInt [dynHS], spt_NoPTRS c]]
-	spt_FREE c i = trIndex PtrKind [c, add [trInt [dynHS], spt_NoPTRS c]]
+	spt_SIZE c   = trIndex PtrRep [c, trInt [fhs + gc_reserved] ]
+	spt_NoPTRS c = trIndex PtrRep [c, trInt [fhs + gc_reserved + 1] ]
+	spt_SPTR c i = trIndex PtrRep [c, add [trInt [dynHS], i]]
+	spt_TOP c    = trIndex PtrRep [c, add [trInt [dynHS], spt_NoPTRS c]]
+	spt_FREE c i = trIndex PtrRep [c, add [trInt [dynHS], spt_NoPTRS c]]
 
 	-- tedious hardwiring in of stack manipulation macros (from SMClosures)
 	spt_FULL c lbl =
 		trCondJump lbl [trPrim IntEqOp [spt_TOP c, spt_NoPTRS c]]
 	spt_EMPTY c lbl =
 		trCondJump lbl [trPrim IntEqOp [spt_TOP c, trInt [0]]]
-	spt_PUSH c f = [ 
-		trAssign PtrKind [spt_FREE c (spt_TOP c), f],
+	spt_PUSH c f = [
+		trAssign PtrRep [spt_FREE c (spt_TOP c), f],
 		inc (spt_TOP c),
-	spt_POP c x  = [ 
-		dec (spt_TOP c), 
-		trAssign PtrKind [x, spt_FREE c (spt_TOP c)]
+	spt_POP c x  = [
+		dec (spt_TOP c),
+		trAssign PtrRep [x, spt_FREE c (spt_TOP c)]
 	]
 
 	-- now to get down to business
@@ -391,83 +389,83 @@ Notes for ADR:
 	newSP = -- another temporary
 
 	allocNewTable = -- some sort fo heap allocation needed
-	copyOldTable = trCall "enlargeSPTable" PtrKind [newSPT, spt]
+	copyOldTable = trCall "enlargeSPTable" PtrRep [newSPT, spt]
 
-	enlarge = 
+	enlarge =
 		allocNewTable ++ [
 		copyOldTable,
-		trAssign PtrKind [spt, newSPT]
+		trAssign PtrRep [spt, newSPT]
 	allocate = [
 		spt_POP spt newSP,
-		trAssign PtrKind [spt_SPTR spt newSP, unstable],
-		trAssign StablePtrKind [lhs', newSP]
+		trAssign PtrRep [spt_SPTR spt newSP, unstable],
+		trAssign StablePtrRep [lhs', newSP]
 	]
-		
+
     in
     getUniqLabelCTS 	    	    	    	   `thenCTS` \ oklbl ->
-    returnCodes sty md 
+    returnCodes sty md
 	(spt_EMPTY spt oklbl : (enlarge ++ (trLabel [oklbl] : allocate)))
 \end{pseudocode}
 
 \begin{code}
   genprim res Word2IntegerOp args = panic "genPrimCode:Word2IntegerOp"
 
-  genprim lhs (CCallOp fn is_asm may_gc arg_tys result_ty) rhs 
+  genprim lhs (CCallOp fn is_asm may_gc arg_tys result_ty) rhs
    | is_asm = error "ERROR: Native code generator can't handle casm"
    | otherwise =
     case lhs of
-    	[] -> returnSUs (\xs -> (StCall fn VoidKind args) : xs)
+    	[] -> returnUs (\xs -> (StCall fn VoidRep args) : xs)
     	[lhs] ->
     	    let lhs' = a2stix lhs
-    	    	pk = if isFloatingKind (getAmodeKind lhs) then DoubleKind else IntKind
+    	    	pk = if isFloatingRep (getAmodeRep lhs) then DoubleRep else IntRep
 	    	call = StAssign pk lhs' (StCall fn pk args)
     	    in
-	    	returnSUs (\xs -> call : xs)
+	    	returnUs (\xs -> call : xs)
     where
     	args = map amodeCodeForCCall rhs
-        amodeCodeForCCall x = 
+	amodeCodeForCCall x =
     	    let base = a2stix' x
     	    in
-    	    	case getAmodeKind x of
-    	    	    ArrayKind -> StIndex PtrKind base mut_hs
-    	    	    ByteArrayKind -> StIndex IntKind base data_hs
-		    MallocPtrKind -> error "ERROR: native-code generator can't handle Malloc Ptrs (yet): use -fvia-C!"
+    	    	case getAmodeRep x of
+    	    	    ArrayRep -> StIndex PtrRep base mut_hs
+    	    	    ByteArrayRep -> StIndex IntRep base data_hs
+		    MallocPtrRep -> error "ERROR: native-code generator can't handle Malloc Ptrs (yet): use -fvia-C!"
     	    	    _ -> base
-\end{code}    
+\end{code}
 
 Now the more mundane operations.
 
 \begin{code}
-  genprim lhs op rhs = 
+  genprim lhs op rhs =
     let lhs' = map a2stix  lhs
     	rhs' = map a2stix' rhs
     in
-        returnSUs (\ xs -> simplePrim lhs' op rhs' : xs)
+	returnUs (\ xs -> simplePrim lhs' op rhs' : xs)
 
   {-
-  simpleCoercion 
-      :: Target 
-      -> PrimKind 
-      -> [CAddrMode] 
-      -> [CAddrMode] 
-      -> SUniqSM StixTreeList
+  simpleCoercion
+      :: Target
+      -> PrimRep
+      -> [CAddrMode]
+      -> [CAddrMode]
+      -> UniqSM StixTreeList
   -}
   simpleCoercion pk lhs rhs =
-      returnSUs (\xs -> StAssign pk (a2stix lhs) (a2stix rhs) : xs)
+      returnUs (\xs -> StAssign pk (a2stix lhs) (a2stix rhs) : xs)
 
 \end{code}
 
 Here we try to rewrite primitives into a form the code generator
-can understand.	 Any primitives not handled here must be handled 
+can understand.	 Any primitives not handled here must be handled
 at the level of the specific code generator.
 
 \begin{code}
   {-
-  simplePrim 
-    :: Target 
-    -> [StixTree] 
-    -> PrimOp 
-    -> [StixTree] 
+  simplePrim
+    :: Target
+    -> [StixTree]
+    -> PrimOp
+    -> [StixTree]
     -> StixTree
   -}
 \end{code}
@@ -477,8 +475,8 @@ Now look for something more conventional.
 \begin{code}
 
   simplePrim [lhs] op rest = StAssign pk lhs (StPrim op rest)
-    where pk = if isCompareOp op then IntKind 
-               else case getPrimOpResultInfo op of
+    where pk = if isCompareOp op then IntRep
+	       else case getPrimOpResultInfo op of
 		 ReturnsPrim pk -> pk
 		 _ -> simplePrim_error op
 
@@ -498,12 +496,12 @@ amodes that might possibly need the extra cast.
 
 \begin{code}
 
-amodeCode, amodeCode' 
-    :: Target 
-    -> CAddrMode 
+amodeCode, amodeCode'
+    :: Target
+    -> CAddrMode
     -> StixTree
 
-amodeCode'{-'-} target_STRICT am@(CVal rr CharKind) 
+amodeCode'{-'-} target_STRICT am@(CVal rr CharRep)
     | mixedTypeLocn am = StPrim ChrOp [amodeToStix target am]
     | otherwise = amodeToStix target am
 
@@ -519,22 +517,22 @@ amodeCode target_STRICT am
  a2stix    = amodeToStix target
 
  -- real code: ----------------------------------
- acode am@(CVal rr CharKind) | mixedTypeLocn am =
-	 StInd IntKind (acode (CAddr rr))
+ acode am@(CVal rr CharRep) | mixedTypeLocn am =
+	 StInd IntRep (acode (CAddr rr))
 
  acode (CVal rr pk) = StInd pk (acode (CAddr rr))
 
- acode (CAddr r@(SpARel spA off)) =
-     StIndex PtrKind stgSpA (StInt (toInteger (spARelToInt r)))
+ acode (CAddr (SpARel spA off)) =
+     StIndex PtrRep stgSpA (StInt (toInteger (spARelToInt spA off)))
 
- acode (CAddr r@(SpBRel spB off)) =
-     StIndex IntKind stgSpB (StInt (toInteger (spBRelToInt r)))
+ acode (CAddr (SpBRel spB off)) =
+     StIndex IntRep stgSpB (StInt (toInteger (spBRelToInt spB off)))
 
  acode (CAddr (HpRel hp off)) =
-     StIndex IntKind stgHp (StInt (toInteger (-(hp_rel (hp `subOff` off)))))
+     StIndex IntRep stgHp (StInt (toInteger (-(hp_rel (hp `subOff` off)))))
 
  acode (CAddr (NodeRel off)) =
-     StIndex IntKind stgNode (StInt (toInteger (hp_rel off)))
+     StIndex IntRep stgNode (StInt (toInteger (hp_rel off)))
 
  acode (CReg magic) = StReg (StixMagicId magic)
  acode (CTemp uniq pk) = StReg (StixTemp uniq pk)
@@ -543,25 +541,25 @@ amodeCode target_STRICT am
 
  acode (CUnVecLbl dir _) = StCLbl dir
 
- acode (CTableEntry base off pk) = 
+ acode (CTableEntry base off pk) =
      StInd pk (StIndex pk (acode base) (acode off))
 
  -- For CharLike and IntLike, we attempt some trivial constant-folding here.
 
- acode (CCharLike (CLit (MachChar c))) = 
+ acode (CCharLike (CLit (MachChar c))) =
      StLitLbl (uppBeside (uppPStr SLIT("CHARLIKE_closures+")) (uppInt off))
      where off = char_like * ord c
 
- acode (CCharLike x) = 
+ acode (CCharLike x) =
      StPrim IntAddOp [charLike, off]
-     where off = StPrim IntMulOp [acode x, 
+     where off = StPrim IntMulOp [acode x,
 	     StInt (toInteger (char_like))]
 
- acode (CIntLike (CLit (MachInt i _))) = 
+ acode (CIntLike (CLit (MachInt i _))) =
      StPrim IntAddOp [intLikePtr, StInt off]
      where off = toInteger int_like * i
 
- acode (CIntLike x) = 
+ acode (CIntLike x) =
      StPrim IntAddOp [intLikePtr, off]
      where off = StPrim IntMulOp [acode x,
 	     StInt (toInteger int_like)]
@@ -585,14 +583,14 @@ amodeCode target_STRICT am
  -- COffsets are in words, not bytes!
  acode (COffset off) = StInt (toInteger (hp_rel off))
 
- acode (CMacroExpr _ macro [arg]) = 
+ acode (CMacroExpr _ macro [arg]) =
      case macro of
-	 INFO_PTR -> StInd PtrKind (a2stix arg)
+	 INFO_PTR -> StInd PtrRep (a2stix arg)
 	 ENTRY_CODE -> a2stix arg
 	 INFO_TAG -> tag
 	 EVAL_TAG -> StPrim IntGeOp [tag, StInt 0]
    where
-     tag = StInd IntKind (StIndex IntKind (a2stix arg) (StInt (-2)))
+     tag = StInd IntRep (StIndex IntRep (a2stix arg) (StInt (-2)))
      -- That ``-2'' really bothers me. (JSM)
 
  acode (CCostCentre cc print_as_string)
@@ -610,7 +608,7 @@ data segment.  (These are in bytes.)
 
 intLikePtr :: StixTree
 
-intLikePtr = StInd PtrKind (sStLitLbl SLIT("INTLIKE_closures"))
+intLikePtr = StInd PtrRep (sStLitLbl SLIT("INTLIKE_closures"))
 
 -- The CHARLIKE base
 
@@ -622,10 +620,10 @@ charLike = sStLitLbl SLIT("CHARLIKE_closures")
 
 topClosure, flushStdout, flushStderr, errorIO :: StixTree
 
-topClosure = StInd PtrKind (sStLitLbl SLIT("TopClosure"))
-flushStdout = StCall SLIT("fflush") VoidKind [StLitLit SLIT("stdout")]
-flushStderr = StCall SLIT("fflush") VoidKind [StLitLit SLIT("stderr")]
-errorIO = StJump (StInd PtrKind (sStLitLbl SLIT("ErrorIO_innards")))
+topClosure = StInd PtrRep (sStLitLbl SLIT("TopClosure"))
+flushStdout = StCall SLIT("fflush") VoidRep [StLitLit SLIT("stdout")]
+flushStderr = StCall SLIT("fflush") VoidRep [StLitLit SLIT("stderr")]
+errorIO = StJump (StInd PtrRep (sStLitLbl SLIT("ErrorIO_innards")))
 
 \end{code}
 
diff --git a/ghc/compiler/parser/MAIL.byacc b/ghc/compiler/parser/MAIL.byacc
new file mode 100644
index 0000000000..7c25fab2e7
--- /dev/null
+++ b/ghc/compiler/parser/MAIL.byacc
@@ -0,0 +1,146 @@
+Return-Path: mattson@dcs.gla.ac.uk
+Return-Path: <mattson@dcs.gla.ac.uk>
+Received: from starbuck.dcs.gla.ac.uk by goggins.dcs.gla.ac.uk 
+          with LOCAL SMTP (PP) id <02535-0@goggins.dcs.gla.ac.uk>;
+          Thu, 18 Nov 1993 09:59:57 +0000
+To: Robert.Corbett@Eng.Sun.COM
+cc: partain@dcs.gla.ac.uk
+Subject: Re: [Robert.Corbett@Eng.Sun.COM: Re: possible bug, byacc 1.9]
+In-reply-to: Your message from 9:46 AM GMT
+Date: Thu, 18 Nov 93 09:59:53 +0000
+From: Jim Mattson <mattson@dcs.gla.ac.uk>
+
+It's clear that this feature improves error detection, but it's not
+clear to me how it improves the scope of possible error recoveries.
+
+If I understand your explanation, it sounds like the only alternative 
+(short of changing the byacc source) is to add tens or hundreds of
+error productions sprinkled throughout the code anywhere that an
+unexpected symbol may appear, since no intervening reductions are
+allowed.  
+
+Although the addition of all of these error productions increases the
+scope of possible error recoveries, the same functionality (with, in fact,
+the same approach) is provided by other versions of yacc.  The apparent
+advantage of other versions of yacc is that they provide a facility by
+which a single _default_ error production can handle a number of
+possibilities (after some possibly illegal reductions have been performed).
+
+Am I missing something?
+
+--jim
+--------
+In reply to the following message:
+--------
+
+------- Forwarded Message
+
+Date: Wed, 17 Nov 93 22:33:44 PST
+From: Robert.Corbett@Eng.Sun.COM (Robert Corbett)
+Message-Id: <9311180633.AA07545@lupa.Eng.Sun.COM>
+To: partain@dcs.gla.ac.uk
+Subject: Re: possible bug, byacc 1.9
+
+It is a feature.  One difference between Berkeley Yacc and its
+predecessors is that the parsers Berkeley Yacc produces detect
+errors as soon as possible.  That will lead to different behavior.
+
+In this particular case, the token "IN" is not a permitted
+lookahead symbol in state 390.  AT&T Yacc parsers will not detect
+the error until after doing more reductions than Berkeley Yacc
+parsers.  Doing reductions in illegal contexts limits the scope of
+recoveries that are possible (unless backtracking is possible).
+
+I am sorry that my attempt to provide better error detection is
+causing you trouble.  You can get the AT&T Yacc behavior by
+replacing the routine sole_reduction in mkpar.c with a routine
+that returns the most frequently occurring reduction.
+
+					Yours truly,
+					Bob Corbett
+
+- ----- Begin Included Message -----
+
+>From partain@dcs.gla.ac.uk Wed Nov 17 05:03:44 1993
+To: robert.corbett@Eng
+Subject: possible bug, byacc 1.9
+Date: Wed, 17 Nov 93 12:33:42 +0000
+From: Will Partain <partain@dcs.gla.ac.uk>
+
+Sadly, it's in a *HUGE* grammar, which I will send you if you have the
+stomach for it.
+
+The problem occurs where {Sun's /usr/lang/yacc, bison} say:
+
+    state 390
+
+	aexp  ->  var .   (rule 356)
+	aexp  ->  var . AT aexp   (rule 366)
+
+	AT  	shift, and go to state 508
+	$default	reduce using rule 356 (aexp)
+
+but byacc says
+
+    state 396
+	aexp : var .  (356)
+	aexp : var . AT aexp  (366)
+
+	AT  shift 511
+	error  reduce 356
+	VARID  reduce 356
+	CONID  reduce 356
+	VARSYM  reduce 356
+	CONSYM  reduce 356
+	MINUS  reduce 356
+	INTEGER  reduce 356
+	FLOAT  reduce 356
+	CHAR  reduce 356
+	STRING  reduce 356
+	CHARPRIM  reduce 356
+	INTPRIM  reduce 356
+	FLOATPRIM  reduce 356
+	DOUBLEPRIM  reduce 356
+	CLITLIT  reduce 356
+	VOIDPRIM  reduce 356
+	CCURLY  reduce 356
+	VCCURLY  reduce 356
+	SEMI  reduce 356
+	OBRACK  reduce 356
+	CBRACK  reduce 356
+	OPAREN  reduce 356
+	CPAREN  reduce 356
+	COMMA  reduce 356
+	BQUOTE  reduce 356
+	RARROW  reduce 356
+	VBAR  reduce 356
+	EQUAL  reduce 356
+	DOTDOT  reduce 356
+	DCOLON  reduce 356
+	LARROW  reduce 356
+	WILDCARD  reduce 356
+	LAZY  reduce 356
+	WHERE  reduce 356
+	OF  reduce 356
+	THEN  reduce 356
+	ELSE  reduce 356
+	PLUS  reduce 356
+
+The token that comes in is "IN"; bison/sun-yacc-generated parser
+tickles the default, reduces to "aexp", but byacc-generated tickles
+"error" and the rest is history.
+
+Maybe this is enough for you to exclaim, "Oh yes, that's a feature."
+
+As I say, more info if you want it.
+
+Will Partain
+
+
+- ----- End Included Message -----
+
+
+
+------- End of Forwarded Message
+
+--------
diff --git a/ghc/compiler/parser/README.debug b/ghc/compiler/parser/README.debug
new file mode 100644
index 0000000000..17503dd4b9
--- /dev/null
+++ b/ghc/compiler/parser/README.debug
@@ -0,0 +1,12 @@
+If you want to debug...
+
+* the lexer:
+
+    run "flex" with the -d flag; compile as normal thereafter
+
+* the parser:
+
+    compile hsparser.tab.c and main.c with EXTRA_CC_OPTS=-DHSP_DEBUG
+
+    run hsp with -D; it's dumping the output into *stdout*,
+    so you have to do something weird to look at it.
diff --git a/ghc/compiler/parser/UgenAll.lhs b/ghc/compiler/parser/UgenAll.lhs
new file mode 100644
index 0000000000..6a4066b412
--- /dev/null
+++ b/ghc/compiler/parser/UgenAll.lhs
@@ -0,0 +1,50 @@
+Stuff the Ugenny things show to the parser.
+
+\begin{code}
+module UgenAll (
+	-- re-exported Prelude stuff
+	returnUgn, thenUgn,
+
+	-- stuff defined in utils module
+	UgenUtil.. ,
+
+	-- re-exported ugen-generated stuff
+	U_binding.. ,
+	U_constr.. ,
+	U_coresyn.. ,
+	U_entidt.. ,
+	U_finfot.. ,
+	U_hpragma.. ,
+	U_list.. ,
+	U_literal.. ,
+	U_maybe.. ,
+	U_either.. ,
+	U_pbinding.. ,
+	U_qid.. ,
+	U_tree.. ,
+	U_ttype..
+
+    ) where
+
+import PreludeGlaST
+
+import Ubiq{-uitous-}
+
+-- friends:
+import U_binding
+import U_constr
+import U_coresyn
+import U_entidt
+import U_finfot
+import U_hpragma
+import U_list
+import U_literal
+import U_maybe
+import U_either
+import U_pbinding
+import U_qid
+import U_tree
+import U_ttype
+
+import UgenUtil
+\end{code}
diff --git a/ghc/compiler/parser/UgenUtil.lhs b/ghc/compiler/parser/UgenUtil.lhs
new file mode 100644
index 0000000000..95001bf02f
--- /dev/null
+++ b/ghc/compiler/parser/UgenUtil.lhs
@@ -0,0 +1,100 @@
+Glues lots of things together for ugen-generated
+.hs files here
+
+\begin{code}
+#include "HsVersions.h"
+
+module UgenUtil (
+	-- re-exported Prelude stuff
+	returnPrimIO, thenPrimIO,
+
+	-- stuff defined here
+	UgenUtil..,
+
+	-- complete interface
+	ProtoName
+    ) where
+
+import PreludeGlaST
+
+import Ubiq{-uitous-}
+
+import MainMonad	( MainIO(..) )		
+import ProtoName	( ProtoName(..) )
+import SrcLoc		( mkSrcLoc2 )
+
+--import ProtoName
+--import Outputable
+--import Util
+\end{code}
+
+\begin{code}
+type UgnM a
+  = FAST_STRING		   -- source file name; carried down
+  -> PrimIO a
+
+{-# INLINE returnUgn #-}
+{-# INLINE thenUgn #-}
+
+returnUgn x mod = returnPrimIO x
+
+thenUgn x y mod
+  = x mod	`thenPrimIO` \ z ->
+    y z mod
+
+initUgn :: FAST_STRING -> UgnM a -> MainIO a
+initUgn srcfile action
+  = action srcfile `thenPrimIO` \ result ->
+    return result
+
+ioToUgnM :: PrimIO a -> UgnM a
+ioToUgnM x mod = x
+\end{code}
+
+\begin{code}
+type ParseTree = _Addr
+
+type U_VOID_STAR = _Addr
+rdU_VOID_STAR ::  _Addr -> UgnM U_VOID_STAR
+rdU_VOID_STAR x = returnUgn x
+
+type U_long = Int
+rdU_long ::  Int -> UgnM U_long
+rdU_long x = returnUgn x -- (A# x) = returnUgn (I# (addr2Int# x))
+
+type U_unkId = ProtoName
+rdU_unkId :: _Addr -> UgnM U_unkId
+rdU_unkId x
+  = rdU_stringId x `thenUgn` \ y ->
+    returnUgn (Unk y)
+
+type U_stringId = FAST_STRING
+rdU_stringId :: _Addr -> UgnM U_stringId
+{-# INLINE rdU_stringId #-}
+rdU_stringId s
+  = -- ToDo (sometime): ioToUgnM (_ccall_ hash_index s) `thenUgn` \ (I# i) ->
+    returnUgn (_packCString s)
+
+type U_numId = Int -- ToDo: Int
+rdU_numId :: _Addr -> UgnM U_numId
+rdU_numId i = rdU_stringId i `thenUgn` \ y -> returnUgn ((read (_UNPK_ y))::Int)
+
+type U_hstring = FAST_STRING
+rdU_hstring :: _Addr -> UgnM U_hstring
+rdU_hstring x
+  = ioToUgnM (_ccall_ get_hstring_len   x)  `thenUgn` \ len ->
+    ioToUgnM (_ccall_ get_hstring_bytes x)  `thenUgn` \ bytes ->
+    returnUgn (_packCBytes len bytes)
+\end{code}
+
+\begin{code}
+setSrcFileUgn :: FAST_STRING{-filename-} -> UgnM a -> UgnM a
+setSrcFileUgn file action _ = action file
+
+getSrcFileUgn :: UgnM FAST_STRING{-filename-}
+getSrcFileUgn mod = returnUgn mod mod
+
+mkSrcLocUgn :: U_long -> UgnM SrcLoc
+mkSrcLocUgn ln mod
+  = returnUgn (mkSrcLoc2 mod ln) mod
+\end{code}
diff --git a/ghc/compiler/parser/binding.ugn b/ghc/compiler/parser/binding.ugn
new file mode 100644
index 0000000000..9337aaa002
--- /dev/null
+++ b/ghc/compiler/parser/binding.ugn
@@ -0,0 +1,103 @@
+%{
+#include "hspincl.h"
+%}
+%{{
+module U_binding where
+import Ubiq --  debugging consistency check
+import UgenUtil
+
+import U_constr
+import U_coresyn	( U_coresyn ) -- for interfaces only
+import U_hpragma
+import U_list
+import U_literal	( U_literal ) -- for interfaces only
+import U_maybe
+import U_qid
+import U_ttype
+%}}
+type binding;
+	tbind	: < gtbindc	: list;	 	/* [context entries] */
+		    gtbindid	: ttype; 	/* applied tycon */
+		    gtbindl	: list;  	/* [constr] */
+		    gtbindd	: maybe; 	/* Maybe [deriving] */
+		    gtline	: long;
+		    gtpragma	: hpragma; >;
+	ntbind	: < gntbindc	: list;	 	/* [context entries] */
+		    gntbindid	: ttype; 	/* applied tycon */
+		    gntbindcty	: list;  	/* [constr]  (only 1 constrnew) */ 
+		    gntbindd	: maybe; 	/* Maybe [deriving] */
+		    gntline	: long;
+		    gntpragma	: hpragma; >;
+	nbind	: < gnbindid	: ttype;
+		    gnbindas	: ttype;
+		    gnline	: long; >;
+	pbind	: < gpbindl	: list;
+		    gpline	: long; >;
+	fbind	: < gfbindl	: list;
+		    gfline	: long; >;
+	abind	: < gabindfst	: binding;
+		    gabindsnd	: binding; >;
+	ibind	: < gibindsrc   : long;		/* 1 => source; 0 => interface */
+		    gibindmod   : stringId;	/* the original module */
+		    gibindc	: list;
+		    gibindid	: qid;
+		    gibindi	: ttype;
+		    gibindw	: binding;
+		    giline	: long;
+		    gipragma	: hpragma; >;
+	dbind	: < gdbindts	: list;
+		    gdline	: long; >;
+	cbind	: < gcbindc	: list;
+		    gcbindid	: ttype;
+		    gcbindw	: binding;
+		    gcline	: long;
+		    gcpragma	: hpragma; >;
+	sbind	: < gsbindids	: list;
+		    gsbindid	: ttype;
+		    gsline	: long;
+		    gspragma	: hpragma; >;
+
+	mbind	: < gmbindmodn	: stringId;	/* import (in an interface) <mod> <entities> */
+		    gmbindimp	: list;		/* [entity] */
+		    gmline	: long; >;
+	mfbind	: < gmfixes     : list; >;	/* fixites in an import: [fixop] */
+
+	nullbind : < >;
+
+	import	: < gibindiface : stringId;
+		    gibindfile	: stringId;
+		    gibinddef	: binding;
+		    gibindimod	: stringId;
+		    gibindqual	: long;
+		    gibindas	: maybe;
+		    gibindspec	: maybe;
+		    gibindline	: long; >;
+
+	/* user-specified pragmas:XXXX */
+
+	vspec_uprag : <	gvspec_id   : qid;
+			gvspec_tys  : list;
+			gvspec_line : long; >;
+
+	vspec_ty_and_id : < gvspec_ty : ttype;
+			gvspec_tyid : maybe; /* nil or singleton */ >;
+
+	ispec_uprag : <	gispec_clas : qid;
+			gispec_ty   : ttype;
+			gispec_line : long; >;
+
+	inline_uprag: <	ginline_id   : qid;
+			ginline_line : long; >;
+
+	deforest_uprag: < gdeforest_id : qid;
+			gdeforest_line : long; >;
+
+	magicuf_uprag:< gmagicuf_id   : qid;
+			gmagicuf_str  : stringId;
+			gmagicuf_line : long; >;
+
+	dspec_uprag : <	gdspec_id   : qid;
+			gdspec_tys  : list;
+			gdspec_line : long; >;
+
+end;
diff --git a/ghc/compiler/parser/constants.h b/ghc/compiler/parser/constants.h
new file mode 100644
index 0000000000..775bde4292
--- /dev/null
+++ b/ghc/compiler/parser/constants.h
@@ -0,0 +1,48 @@
+/*
+  Include File for the Lexical Analyser and Parser.
+
+  19/11/91	kh	Created.
+*/
+
+
+#ifndef __CONSTANTS_H
+#define __CONSTANTS_H
+
+/*
+  Important Literal Constants.
+*/
+
+#define MODNAME_SIZE		512		/* Size of Module Name buffers 	*/
+#define FILENAME_SIZE		4096		/* Size of File buffers 	*/
+#define ERR_BUF_SIZE	  	512		/* Size of error buffers 	*/
+
+#ifdef YYLMAX					/* Get rid of YYLMAX 		*/
+#undef YYLMAX					/* Ugly -- but necessary 	*/
+#endif
+
+#define	YYLMAX			8192		/* Size of yytext -- limits strings, identifiers etc. */
+
+
+#define HASH_TABLE_SIZE		993		/* Default number of entries in the hash table. */
+
+#define MAX_CONTEXTS 		100   		/* Maximum nesting of wheres, cases etc */
+
+#define MAX_INFIX 		500		/* Maximum number of infix operators */
+
+#define MAX_ESC_CHAR 		255		/* Largest Recognised Character: \255 */
+#define MAX_ESC_DIGITS 		10		/* Maximum number of digits in an escape \dd */
+
+
+#ifdef TRUE
+#undef TRUE
+#endif
+
+#ifdef FALSE
+#undef FALSE
+#endif
+
+#define TRUE	1
+#define FALSE	0
+typedef int BOOLEAN;
+
+#endif /* __CONSTANTS_H */
diff --git a/ghc/compiler/parser/constr.ugn b/ghc/compiler/parser/constr.ugn
new file mode 100644
index 0000000000..e2d37336cf
--- /dev/null
+++ b/ghc/compiler/parser/constr.ugn
@@ -0,0 +1,38 @@
+%{
+#include "hspincl.h"
+%}
+%{{
+module U_constr where
+import Ubiq --  debugging consistency check
+import UgenUtil
+
+import U_maybe
+import U_list
+import U_qid
+import U_ttype
+%}}
+type constr;
+	/* constr in prefix form: */
+	constrpre   : < gconcid	    : qid;
+			gconctypel  : list; /* [ttype] */
+			gconcline   : long; >;
+
+	/* constr in infix form: */
+	constrinf   : < gconity1    : ttype;
+			gconiop	    : qid;
+			gconity2    : ttype;
+			gconiline   : long; >;
+
+	/* constr in record form: */
+	constrrec   : < gconrid	    : qid;
+			gconrfieldl : list; /* [field] */
+			gconrline   : long; >;
+
+	/* constr in simple "newtype" form: */
+	constrnew   : < gconnid	    : qid;
+			gconnty	    : ttype;
+			gconnline   : long; >;
+
+	field	    : < gfieldn	    : list;
+			gfieldt	    : ttype; >;
+end;
diff --git a/ghc/compiler/parser/coresyn.ugn b/ghc/compiler/parser/coresyn.ugn
new file mode 100644
index 0000000000..feeb5ac6a1
--- /dev/null
+++ b/ghc/compiler/parser/coresyn.ugn
@@ -0,0 +1,121 @@
+%{
+#include "hspincl.h"
+%}
+%{{
+module U_coresyn where
+import Ubiq --  debugging consistency check
+import UgenUtil
+
+import U_list
+import U_literal
+import U_qid		( U_qid ) -- for interfaces only
+import U_ttype
+%}}
+type coresyn;
+	/* binders: simple Id, plus a type */
+	cobinder : < gcobinder_v  : unkId;
+		     gcobinder_ty : ttype; >;
+
+	/* atoms */
+	colit	: < gcolit  	 : literal; >;
+	colocal : < gcolocal_v	 : coresyn; >;
+
+	cononrec : <gcononrec_b   : coresyn;
+		    gcononrec_rhs : coresyn; >;
+	corec :	   <gcorec  	  : list; >;
+	corec_pair: <gcorec_b 	: coresyn;
+		    gcorec_rhs 	: coresyn; >;
+
+	covar	: < gcovar	: coresyn; >;
+	coliteral :< gcoliteral : literal; >;
+	cocon	: < gcocon_con  : coresyn;
+		    gcocon_tys	: list;
+		    gcocon_args	: list; >;
+	coprim	: < gcoprim_op	: coresyn; /* primop or something */
+		    gcoprim_tys	: list;
+		    gcoprim_args: list; >;
+	colam	: < gcolam_vars	: list;
+		    gcolam_body	: coresyn; >;
+	cotylam	: < gcotylam_tvs: list;
+		    gcotylam_body : coresyn; >;
+	coapp	: < gcoapp_fun  : coresyn;
+		    gcoapp_args : list; >;
+	cotyapp	: < gcotyapp_e : coresyn;
+		    gcotyapp_t : ttype; >;
+	cocase	: < gcocase_s  : coresyn;
+		    gcocase_alts : coresyn; >;
+	colet	: < gcolet_bind	: coresyn;
+		    gcolet_body : coresyn; >;
+	coscc	: < gcoscc_scc  : coresyn;
+		    gcoscc_body : coresyn; >;
+
+	coalg_alts : <	gcoalg_alts : list;
+			gcoalg_deflt : coresyn; >;
+	coalg_alt  : <	gcoalg_con : coresyn;
+			gcoalg_bs  : list;
+			gcoalg_rhs : coresyn; >;
+
+	coprim_alts : < gcoprim_alts : list;
+		       gcoprim_deflt : coresyn; >;
+	coprim_alt  : <	gcoprim_lit  : literal;
+			gcoprim_rhs  : coresyn; >;
+
+	conodeflt : < >;
+	cobinddeflt : < gcobinddeflt_v : coresyn;
+			gcobinddeflt_rhs : coresyn; >;
+
+	co_primop :    < gco_primop : stringId;>;
+	co_ccall  :    < gco_ccall	    : stringId;
+			 gco_ccall_may_gc   : long;
+			 gco_ccall_arg_tys  : list;
+			 gco_ccall_res_ty   : ttype; >;
+    	co_casm   :    < gco_casm   	    : literal; 
+			 gco_casm_may_gc    : long;
+			 gco_casm_arg_tys   : list;
+			 gco_casm_res_ty    : ttype; >;
+
+	/* various flavours of cost-centres */
+	co_preludedictscc : < gco_preludedictscc_dupd : coresyn; >;
+	co_alldictscc	: < gco_alldictscc_m : hstring;
+			    gco_alldictscc_g : hstring;
+			    gco_alldictscc_dupd : coresyn; >;
+	co_usercc	: < gco_usercc_n    : hstring;
+			    gco_usercc_m    : hstring;
+			    gco_usercc_g    : hstring;
+			    gco_usercc_dupd : coresyn;
+			    gco_usercc_cafd : coresyn; >;
+	co_autocc	: < gco_autocc_i    : coresyn;
+			    gco_autocc_m    : hstring;
+			    gco_autocc_g    : hstring;
+			    gco_autocc_dupd : coresyn;
+			    gco_autocc_cafd : coresyn; >;
+	co_dictcc	: < gco_dictcc_i    : coresyn;
+			    gco_dictcc_m    : hstring;
+			    gco_dictcc_g    : hstring;
+			    gco_dictcc_dupd : coresyn;
+			    gco_dictcc_cafd : coresyn; >;
+	
+	co_scc_noncaf	: < >;
+	co_scc_caf	: < >;
+	co_scc_nondupd	: < >;
+	co_scc_dupd	: < >;
+
+	/* various flavours of Ids */
+	co_id		: < gco_id	    : stringId; >;
+	co_orig_id	: < gco_orig_id_m   : stringId;
+ 			    gco_orig_id_n   : stringId; >;
+	co_sdselid	: < gco_sdselid_c   : unkId;
+			    gco_sdselid_sc  : unkId; >;
+	co_classopid	: < gco_classopid_c : unkId;
+			    gco_classopid_o : unkId; >;
+	co_defmid	: < gco_defmid_c    : unkId;
+			    gco_defmid_op   : unkId; >;
+    	co_dfunid	: < gco_dfunid_c    : unkId;
+			    gco_dfunid_ty   : ttype; >;
+    	co_constmid	: < gco_constmid_c  : unkId;
+			    gco_constmid_op : unkId;
+			    gco_constmid_ty : ttype; >;
+	co_specid	: < gco_specid_un   : coresyn;
+			    gco_specid_tys  : list; >;
+	co_wrkrid   	: < gco_wrkrid_un   : coresyn; >;
+end;
diff --git a/ghc/compiler/parser/either.ugn b/ghc/compiler/parser/either.ugn
new file mode 100644
index 0000000000..a75acf94cb
--- /dev/null
+++ b/ghc/compiler/parser/either.ugn
@@ -0,0 +1,13 @@
+%{
+#include "hspincl.h"
+%}
+%{{
+module U_either where
+import Ubiq --  debugging consistency check
+import UgenUtil
+%}}
+type either;
+	left	: < gleft  : VOID_STAR; > ;
+	right	: < gright : VOID_STAR; > ;
+end;
+
diff --git a/ghc/compiler/parser/entidt.ugn b/ghc/compiler/parser/entidt.ugn
new file mode 100644
index 0000000000..eb661c0c73
--- /dev/null
+++ b/ghc/compiler/parser/entidt.ugn
@@ -0,0 +1,19 @@
+%{
+#include "hspincl.h"
+%}
+%{{
+module U_entidt where
+import Ubiq --  debugging consistency check
+import UgenUtil
+
+import U_list
+import U_qid
+%}}
+type entidt;
+	entid	     : < gentid	    : qid;	>;
+	enttype	     : < gtentid    : qid;	>;
+	enttypeall   : < gaentid    : qid;	>;
+	enttypenamed : < gnentid    : qid;	
+			 gnentnames : list;	>;
+	entmod	     : < gmentid    : stringId;	>;
+end;
diff --git a/ghc/compiler/parser/hpragma.ugn b/ghc/compiler/parser/hpragma.ugn
new file mode 100644
index 0000000000..e3f9c49c60
--- /dev/null
+++ b/ghc/compiler/parser/hpragma.ugn
@@ -0,0 +1,63 @@
+%{
+#include "hspincl.h"
+%}
+%{{
+module U_hpragma where
+import Ubiq --  debugging consistency check
+import UgenUtil
+
+import U_coresyn
+import U_list
+import U_literal	( U_literal )	-- ditto
+import U_ttype		( U_ttype )	-- interface only
+%}}
+type hpragma;
+	no_pragma:	    < > ;
+
+	idata_pragma:	    < gprag_data_constrs : list;  /*of con decls*/
+			      gprag_data_specs   : list;  /*specialisations*/ >;
+
+	itype_pragma:	    < >;
+	
+	iclas_pragma:	    < gprag_clas : list;    /*of gen pragmas*/ >;
+
+	iclasop_pragma:	    < gprag_dsel : hpragma; /* gen pragma: dict selector */
+			      gprag_defm : hpragma; /* gen pragma: default method */ >;
+
+	iinst_simpl_pragma: < gprag_dfun_simpl : hpragma; /* gen pragma: of dfun */ >;
+
+	iinst_const_pragma: < gprag_dfun_const : hpragma; /* gen pragma: of dfun */
+			      gprag_constms    : list; /* (name, gen pragma) pairs */ >;
+
+	igen_pragma:	    < gprag_arity      : hpragma; /* arity */
+			      gprag_update     : hpragma; /* update info */
+			      gprag_deforest   : hpragma; /* deforest info */
+			      gprag_strictness : hpragma; /* strictness info */
+		    	      gprag_unfolding  : hpragma; /* unfolding */
+			      gprag_specs      : list; /* (type, gen pragma) pairs */ >;
+
+	iarity_pragma:	    < gprag_arity_val  : numId; >;
+	iupdate_pragma:	    < gprag_update_val : stringId; >;
+	ideforest_pragma:   < >;
+	istrictness_pragma: < gprag_strict_spec : hstring;
+			      gprag_strict_wrkr : hpragma; /*about worker*/ >;
+	imagic_unfolding_pragma:  < gprag_magic_str : stringId; >;
+			
+	iunfolding_pragma:  < gprag_unfold_guide : hpragma; /* guidance */
+			      gprag_unfold_core : coresyn; >;
+
+	iunfold_always:	    < >;
+	iunfold_if_args:    < gprag_unfold_if_t_args : numId;
+			      gprag_unfold_if_v_args : numId;
+			      gprag_unfold_if_con_args : stringId;
+			      gprag_unfold_if_size : numId; >;
+
+	iname_pragma_pr:    < gprag_name_pr1	: unkId;
+			      gprag_name_pr2	: hpragma; >;
+	itype_pragma_pr:    < gprag_type_pr1	: list;   /* of maybe types */
+			      gprag_type_pr2	: numId; /* # dicts to ignore */
+			      gprag_type_pr3	: hpragma; >;
+
+	idata_pragma_4s:    < gprag_data_spec	: list; /* of maybe types */ >;
+
+end;
diff --git a/ghc/compiler/parser/hschooks.c b/ghc/compiler/parser/hschooks.c
new file mode 100644
index 0000000000..2700839712
--- /dev/null
+++ b/ghc/compiler/parser/hschooks.c
@@ -0,0 +1,66 @@
+/*
+These routines customise the error messages
+for various bits of the RTS.  They are linked
+in instead of the defaults.
+*/
+#include <stdio.h>
+
+#define W_ unsigned long int
+#define I_ long int
+
+void
+ErrorHdrHook (where)
+  FILE *where;
+{
+    fprintf(where, "\n"); /* no "Fail: " */
+}
+
+
+void
+OutOfHeapHook (request_size, heap_size)
+  W_ request_size; /* in bytes */
+  W_ heap_size;    /* in bytes */
+{
+    fprintf(stderr, "GHC's heap exhausted;\nwhile trying to allocate %lu bytes in a %lu-byte heap;\nuse the `-H<size>' option to increase the total heap size.\n",
+	request_size,
+	heap_size);
+}
+
+void
+StackOverflowHook (stack_size)
+  I_ stack_size;    /* in bytes */
+{
+    fprintf(stderr, "GHC stack-space overflow: current size %ld bytes.\nUse the `-K<size>' option to increase it.\n", stack_size);
+}
+
+#if 0
+/* nothing to add here, really */
+void
+MallocFailHook (request_size, msg)
+  I_ request_size;    /* in bytes */
+  char *msg;
+{
+    fprintf(stderr, "malloc: failed on request for %lu bytes\n", request_size);
+}
+#endif /* 0 */
+
+void
+PatErrorHdrHook (where)
+  FILE *where;
+{
+    fprintf(where, "\n*** Pattern-matching error within GHC!\n\nThis is a compiler bug; please report it to glasgow-haskell-bugs@dcs.glasgow.ac.uk.\n\nFail: ");
+}
+
+void
+PreTraceHook (where)
+  FILE *where;
+{
+    fprintf(where, "\n"); /* not "Trace On" */
+}
+
+void
+PostTraceHook (where)
+  FILE *where;
+{
+    fprintf(where, "\n"); /* not "Trace Off" */
+}
diff --git a/ghc/compiler/parser/hsclink.c b/ghc/compiler/parser/hsclink.c
new file mode 100644
index 0000000000..055304e611
--- /dev/null
+++ b/ghc/compiler/parser/hsclink.c
@@ -0,0 +1,62 @@
+/* This is the "top-level" file for the *linked-into-the-compiler* parser.
+   See also main.c.  (WDP 94/10)
+*/
+
+#include <stdio.h>
+
+#include "hspincl.h"
+#include "constants.h"
+#include "utils.h"
+
+/**********************************************************************
+*                                                                     *
+*                                                                     *
+*     The main program                                                *
+*                                                                     *
+*                                                                     *
+**********************************************************************/
+
+extern long  prog_argc;	
+extern char  **prog_argv;
+
+#define MAX_HSP_ARGS 64
+long hsp_argc;
+char *hsp_argv[MAX_HSP_ARGS];	/* sigh */
+
+tree
+hspmain()
+{
+    int hsp_i, prog_i;
+
+    Lnil = mklnil();	/* The null list -- used in lsing, etc. */
+
+    /* copy the args we're interested in (first char: comma)
+	to hsp_argv; arrange to point after the comma!
+    */
+    hsp_i = 0;
+    for (prog_i = 0; prog_i < prog_argc; prog_i++) {
+	if (prog_argv[prog_i][0] == ',') {
+	    hsp_argv[hsp_i] = &(prog_argv[prog_i][1]);
+	    hsp_i++;
+	}
+    }
+    hsp_argc = hsp_i; /* set count */
+
+    process_args(hsp_argc, hsp_argv); /* HACK */
+
+    hash_init();
+
+#ifdef HSP_DEBUG
+    fprintf(stderr,"input_file_dir=%s\n",input_file_dir);
+#endif
+
+    yyinit();
+
+    if (yyparse() != 0) {
+	/* There was a syntax error. */
+	printf("\n");
+	exit(1);
+    }
+
+    return(root);
+}
diff --git a/ghc/compiler/parser/hslexer.flex b/ghc/compiler/parser/hslexer.flex
new file mode 100644
index 0000000000..5cfe16d90c
--- /dev/null
+++ b/ghc/compiler/parser/hslexer.flex
@@ -0,0 +1,1383 @@
+%{
+/**********************************************************************
+*                                                                     *
+*                                                                     *
+*       FLEX for Haskell.                                             *
+*       -----------------                                             *
+*                                                                     *
+**********************************************************************/
+
+#include "../../includes/config.h"
+
+#include <stdio.h>
+
+#if defined(STDC_HEADERS) || defined(HAVE_STRING_H)
+#include <string.h>
+/* An ANSI string.h and pre-ANSI memory.h might conflict.  */
+#if !defined(STDC_HEADERS) && defined(HAVE_MEMORY_H)
+#include <memory.h>
+#endif /* not STDC_HEADERS and HAVE_MEMORY_H */
+#define index strchr
+#define rindex strrchr
+#define bcopy(s, d, n) memcpy ((d), (s), (n))
+#define bcmp(s1, s2, n) memcmp ((s1), (s2), (n))
+#define bzero(s, n) memset ((s), 0, (n))
+#else /* not STDC_HEADERS and not HAVE_STRING_H */
+#include <strings.h>
+/* memory.h and strings.h conflict on some systems.  */
+#endif /* not STDC_HEADERS and not HAVE_STRING_H */
+
+#include "hspincl.h"
+#include "hsparser.tab.h"
+#include "constants.h"
+#include "utils.h"
+
+/* Our substitute for <ctype.h> */
+
+#define NCHARS  256
+#define _S      0x1
+#define _D      0x2
+#define _H      0x4
+#define _O      0x8
+#define _C 	0x10
+
+#define _isconstr(s) 	(CharTable[*s]&(_C))
+BOOLEAN isconstr PROTO((char *)); /* fwd decl */
+
+static unsigned char CharTable[NCHARS] = {
+/* nul */    	0,  	0,  	0,  	0,  	0,  	0,  	0,  	0,
+/* bs  */    	0,  	_S,  	_S,  	_S,  	_S,  	0,  	0,  	0,
+/* dle */    	0,  	0,  	0,  	0,  	0,  	0,  	0,  	0,
+/* can */    	0,  	0,  	0,  	0,  	0,  	0,  	0,  	0,
+/* sp  */    	_S,  	0,  	0,  	0,  	0,  	0,  	0,  	0,
+/* '(' */       _C, 	0,  	0,  	0,  	0,  	0,  	0,  	0,	/* ( */
+/* '0' */	_D|_H|_O,_D|_H|_O,_D|_H|_O,_D|_H|_O,_D|_H|_O,_D|_H|_O,_D|_H|_O,_D|_H|_O,
+/* '8' */    	_D|_H,	_D|_H,	_C,  	0,  	0,  	0,  	0,  	0,
+/* '@' */    	0,  	_H|_C,	_H|_C,	_H|_C,	_H|_C,	_H|_C,	_H|_C,	_C,
+/* 'H' */    	_C,  	_C,  	_C,  	_C,  	_C,  	_C,  	_C,  	_C,
+/* 'P' */    	_C,  	_C,  	_C,  	_C,  	_C,  	_C,  	_C,  	_C,
+/* 'X' */    	_C,  	_C,  	_C,     _C,	0,  	0,  	0,  	0,	/* [ */
+/* '`' */    	0,  	_H,  	_H,  	_H,  	_H,  	_H,  	_H,  	0,
+/* 'h' */    	0,  	0,  	0,  	0,  	0,  	0,  	0,  	0,
+/* 'p' */    	0,  	0,  	0,  	0,  	0,  	0,  	0,  	0,
+/* 'x' */    	0,  	0,  	0,  	0,  	0,  	0,  	0,  	0,
+
+/*     */    	0,  	0,  	0,  	0,  	0,  	0,  	0,  	0,
+/*     */    	0,  	0,  	0,  	0,  	0,  	0,  	0,  	0,
+/*     */    	0,  	0,  	0,  	0,  	0,  	0,  	0,  	0,
+/*     */    	0,  	0,  	0,  	0,  	0,  	0,  	0,  	0,
+/*     */    	0,  	0,  	0,  	0,  	0,  	0,  	0,  	0,
+/*     */    	0,  	0,  	0,  	0,  	0,  	0,  	0,  	0,
+/*     */    	0,  	0,  	0,  	0,  	0,  	0,  	0,  	0,
+/*     */    	0,  	0,  	0,  	0,  	0,  	0,  	0,  	0,
+/*     */    	0,  	0,  	0,  	0,  	0,  	0,  	0,  	0,
+/*     */    	0,  	0,  	0,  	0,  	0,  	0,  	0,  	0,
+/*     */    	0,  	0,  	0,  	0,  	0,  	0,  	0,  	0,
+/*     */    	0,  	0,  	0,  	0,  	0,  	0,  	0,  	0,
+/*     */    	0,  	0,  	0,  	0,  	0,  	0,  	0,  	0,
+/*     */    	0,  	0,  	0,  	0,  	0,  	0,  	0,  	0,
+/*     */    	0,  	0,  	0,  	0,  	0,  	0,  	0,  	0,
+/*     */    	0,  	0,  	0,  	0,  	0,  	0,  	0,  	0,
+};
+
+/**********************************************************************
+*                                                                     *
+*                                                                     *
+*      Declarations                                                   *
+*                                                                     *
+*                                                                     *
+**********************************************************************/
+
+char *input_filename = NULL;	/* Always points to a dynamically allocated string */
+
+/*
+ * For my own sanity, things that are not part of the flex skeleton
+ * have been renamed as hsXXXXX rather than yyXXXXX.  --JSM
+ */
+
+static int hslineno = 0;	/* Line number at end of token */
+int hsplineno = 0;		/* Line number at end of previous token */
+
+static int hscolno = 0;		/* Column number at end of token */
+int hspcolno = 0;		/* Column number at end of previous token */
+static int hsmlcolno = 0;	/* Column number for multiple-rule lexemes */
+
+int modulelineno = -1;		/* The line number where the module starts */
+int startlineno = 0;		/* The line number where something starts */
+int endlineno = 0;		/* The line number where something ends */
+
+static BOOLEAN noGap = TRUE;	/* For checking string gaps */
+static BOOLEAN forgetindent = FALSE;	/* Don't bother applying indentation rules */
+
+static int nested_comments; 	/* For counting comment nesting depth */
+
+/* Hacky definition of yywrap: see flex doc.
+
+   If we don't do this, then we'll have to get the default
+   yywrap from the flex library, which is often something
+   we are not good at locating.  This avoids that difficulty.
+   (Besides which, this is the way old flexes (pre 2.4.x) did it.)
+   WDP 94/09/05
+*/
+#define yywrap() 1
+
+/* Essential forward declarations */
+
+static void hsnewid 	 PROTO((char *, int));
+static void layout_input PROTO((char *, int));
+static void cleartext	 (NO_ARGS);
+static void addtext 	 PROTO((char *, unsigned));
+static void addchar	 PROTO((char));
+static char *fetchtext	 PROTO((unsigned *));
+static void new_filename PROTO((char *));
+static int  Return	 PROTO((int));
+static void hsentercontext PROTO((int));
+
+/* Special file handling for IMPORTS */
+/*  Note: imports only ever go *one deep* (hence no need for a stack) WDP 94/09 */
+
+static YY_BUFFER_STATE hsbuf_save = NULL;	/* Saved input buffer	 */
+static char *filename_save;	    	/* File Name            	 */
+static int hslineno_save = 0,	    	/* Line Number          	 */
+ hsplineno_save = 0,	    		/* Line Number of Prev. token	 */
+ hscolno_save = 0,		    	/* Indentation          	 */
+ hspcolno_save = 0;		    	/* Left Indentation	 	 */
+static short icontexts_save = 0;    	/* Indent Context Level 	 */
+
+static BOOLEAN etags_save; /* saved: whether doing etags stuff or not */
+extern BOOLEAN etags;	   /* that which is saved */
+
+extern BOOLEAN nonstandardFlag;	/* Glasgow extensions allowed */
+
+static BOOLEAN in_interface = FALSE; /* TRUE if we are reading a .hi file */
+
+extern BOOLEAN ignorePragmas;		/* True when we should ignore pragmas */
+extern int minAcceptablePragmaVersion;	/* see documentation in main.c */
+extern int maxAcceptablePragmaVersion;
+extern int thisIfacePragmaVersion;
+
+static int hssttok = -1;	/* Stacked Token: -1   -- no token; -ve  -- ";"
+				 * inserted before token +ve  -- "}" inserted before
+				 * token */
+
+short icontexts = 0;		/* Which context we're in */
+
+
+
+/*
+	Table of indentations:  right bit indicates whether to use
+	  indentation rules (1 = use rules; 0 = ignore)
+
+    partain:
+    push one of these "contexts" at every "case" or "where"; the right bit says
+    whether user supplied braces, etc., or not.  pop appropriately (hsendindent).
+
+    ALSO, a push/pop when enter/exit a new file (e.g., on importing).  A -1 is
+    pushed (the "column" for "module", "interface" and EOF).  The -1 from the initial
+    push is shown just below.
+
+*/
+
+
+static short indenttab[MAX_CONTEXTS] = {-1};
+
+#define INDENTPT (indenttab[icontexts]>>1)
+#define INDENTON (indenttab[icontexts]&1)
+
+#define RETURN(tok) return(Return(tok))
+
+#undef YY_DECL
+#define YY_DECL int yylex1()
+
+/* We should not peek at yy_act, but flex calls us even for the internal action
+   triggered on 'end-of-buffer' (This is not true of flex 2.4.4 and up, but
+   to support older versions of flex, we'll continue to peek for now.
+ */
+#define YY_USER_ACTION \
+    if (yy_act != YY_END_OF_BUFFER) layout_input(yytext, yyleng);
+
+#if 0/*debug*/
+#undef YY_BREAK
+#define YY_BREAK if (etags) fprintf(stderr,"%d %d / %d %d / %d\n",hsplineno,hspcolno,hslineno,hscolno,startlineno); break;
+#endif
+
+/* Each time we enter a new start state, we push it onto the state stack.
+   Note that the rules do not allow us to underflow or overflow the stack.
+   (At least, they shouldn't.)  The maximum expected depth is 4:
+   0: Code -> 1: String -> 2: StringEsc -> 3: Comment
+*/
+static int StateStack[5];
+static int StateDepth = -1;
+
+#ifdef HSP_DEBUG
+#define PUSH_STATE(n)   do {\
+    fprintf(stderr,"Pushing %d (%d)\n", n, StateDepth + 1);\
+    StateStack[++StateDepth] = (n); BEGIN(n);} while(0)
+#define POP_STATE       do {--StateDepth;\
+    fprintf(stderr,"Popping %d (%d)\n", StateStack[StateDepth], StateDepth);\
+    BEGIN(StateStack[StateDepth]);} while(0)
+#else
+#define PUSH_STATE(n)   do {StateStack[++StateDepth] = (n); BEGIN(n);} while(0)
+#define POP_STATE       do {--StateDepth; BEGIN(StateStack[StateDepth]);} while(0)
+#endif
+
+%}
+
+/* The start states are:
+   Code -- normal Haskell code (principal lexer)
+   GlaExt -- Haskell code with Glasgow extensions
+   Comment -- Nested comment processing
+   String -- Inside a string literal with backslashes
+   StringEsc -- Immediately following a backslash in a string literal
+   Char -- Inside a character literal with backslashes
+   CharEsc -- Immediately following a backslash in a character literal 
+
+   Note that the INITIAL state is unused.  Also note that these states
+   are _exclusive_.  All rules should be prefixed with an appropriate
+   list of start states.
+ */
+
+%x Char CharEsc Code Comment GlaExt GhcPragma UserPragma String StringEsc
+
+isoS			[\xa1-\xbf\xd7\xf7]
+isoL			[\xc0-\xd6\xd8-\xde]
+isol			[\xdf-\xf6\xf8-\xff]
+isoA			[\xa1-\xff]
+
+D			[0-9]
+O			[0-7]
+H			[0-9A-Fa-f]
+N			{D}+
+F   	    	    	{N}"."{N}(("e"|"E")("+"|"-")?{N})?
+S			[!#$%&*+./<=>?@\\^|-~:\xa1-\xbf\xd7\xf7]
+SId			{S}{S}*
+L			[A-Z\xc0-\xd6\xd8-\xde]
+l			[a-z\xdf-\xf6\xf8-\xff]
+I			{L}|{l}
+i			{L}|{l}|[0-9'_]
+Id			{I}{i}*
+Mod			{L}{i}*
+CHAR			[ !#$%&()*+,\-./0-9:;<=>?@A-Z\[\]^_`a-z{|}~\xa1-\xff]
+CNTRL	    	    	[@A-Z\[\\\]^_]
+WS			[ \t\n\r\f\v]
+NL  	    	    	[\n\r]
+
+%%
+
+%{
+    /* 
+     * Special GHC pragma rules.  Do we need a start state for interface files,
+     * so these won't be matched in source files? --JSM
+     */
+%}
+
+<Code,GlaExt>^"# ".*{NL}    {
+    	    	    	  char tempf[FILENAME_SIZE];
+			  sscanf(yytext+1, "%d \"%[^\"]", &hslineno, tempf); 
+			  new_filename(tempf);
+			  hsplineno = hslineno; hscolno = 0; hspcolno = 0;
+			}
+
+<Code,GlaExt>^"#line ".*{NL}    {
+    	    	    	  char tempf[FILENAME_SIZE];
+			  sscanf(yytext+5, "%d \"%[^\"]", &hslineno, tempf); 
+			  new_filename(tempf); 
+			  hsplineno = hslineno; hscolno = 0; hspcolno = 0;
+			}
+
+<Code,GlaExt>"{-# LINE ".*"-}"{NL} { 
+    	    	    	  /* partain: pragma-style line directive */
+			  char tempf[FILENAME_SIZE];
+			  sscanf(yytext+9, "%d \"%[^\"]", &hslineno, tempf); 
+			  new_filename(tempf);
+			  hsplineno = hslineno; hscolno = 0; hspcolno = 0;
+			}
+<Code,GlaExt>"{-# GHC_PRAGMA INTERFACE VERSION "{D}+" #-}"   {
+			  sscanf(yytext+33,"%d ",&thisIfacePragmaVersion);
+			}
+<Code,GlaExt>"{-# GHC_PRAGMA "   { 
+    	    	    	  if ( ignorePragmas ||
+			       thisIfacePragmaVersion < minAcceptablePragmaVersion || 
+			       thisIfacePragmaVersion > maxAcceptablePragmaVersion) {
+			     nested_comments = 1;
+			     PUSH_STATE(Comment);
+			  } else {
+			     PUSH_STATE(GhcPragma);
+			     RETURN(GHC_PRAGMA);
+			  }
+			}
+<GhcPragma>"_N_"	    { RETURN(NO_PRAGMA); }
+<GhcPragma>"_NI_"	    { RETURN(NOINFO_PRAGMA); }
+<GhcPragma>"_DEFOREST_"	    { RETURN(DEFOREST_PRAGMA); }
+<GhcPragma>"_SPECIALISE_"   { RETURN(SPECIALISE_PRAGMA); }
+<GhcPragma>"_A_"	    { RETURN(ARITY_PRAGMA); }
+<GhcPragma>"_U_"	    { RETURN(UPDATE_PRAGMA); }
+<GhcPragma>"_S_"	    { RETURN(STRICTNESS_PRAGMA); }
+<GhcPragma>"_K_"	    { RETURN(KIND_PRAGMA); }
+<GhcPragma>"_MF_"	    { RETURN(MAGIC_UNFOLDING_PRAGMA); }
+<GhcPragma>"_F_"	    { RETURN(UNFOLDING_PRAGMA); }
+
+<GhcPragma>"_!_"	    { RETURN(COCON); }
+<GhcPragma>"_#_"	    { RETURN(COPRIM); }
+<GhcPragma>"_APP_"	    { RETURN(COAPP); }
+<GhcPragma>"_TYAPP_"	    { RETURN(COTYAPP); }
+<GhcPragma>"_ALG_"	    { RETURN(CO_ALG_ALTS); }
+<GhcPragma>"_PRIM_"	    { RETURN(CO_PRIM_ALTS); }
+<GhcPragma>"_NO_DEFLT_"	    { RETURN(CO_NO_DEFAULT); }
+<GhcPragma>"_LETREC_"	    { RETURN(CO_LETREC); }
+
+<GhcPragma>"_PRELUDE_DICTS_CC_" { RETURN(CO_PRELUDE_DICTS_CC); }
+<GhcPragma>"_ALL_DICTS_CC_" { RETURN(CO_ALL_DICTS_CC); }
+<GhcPragma>"_USER_CC_"	    { RETURN(CO_USER_CC); }
+<GhcPragma>"_AUTO_CC_"	    { RETURN(CO_AUTO_CC); }
+<GhcPragma>"_DICT_CC_"	    { RETURN(CO_DICT_CC); }
+
+<GhcPragma>"_DUPD_CC_"	    { RETURN(CO_DUPD_CC); }
+<GhcPragma>"_CAF_CC_"	    { RETURN(CO_CAF_CC); }
+
+<GhcPragma>"_SDSEL_"	    { RETURN(CO_SDSEL_ID); }
+<GhcPragma>"_METH_"	    { RETURN(CO_METH_ID); }
+<GhcPragma>"_DEFM_"	    { RETURN(CO_DEFM_ID); }
+<GhcPragma>"_DFUN_"	    { RETURN(CO_DFUN_ID); }
+<GhcPragma>"_CONSTM_"	    { RETURN(CO_CONSTM_ID); }
+<GhcPragma>"_SPEC_"	    { RETURN(CO_SPEC_ID); }
+<GhcPragma>"_WRKR_"	    { RETURN(CO_WRKR_ID); }
+<GhcPragma>"_ORIG_"	    { RETURN(CO_ORIG_NM); /* fully-qualified original name*/ }
+
+<GhcPragma>"_ALWAYS_"	    { RETURN(UNFOLD_ALWAYS); }
+<GhcPragma>"_IF_ARGS_"      { RETURN(UNFOLD_IF_ARGS); }
+
+<GhcPragma>"_NOREP_I_"	    { RETURN(NOREP_INTEGER); }
+<GhcPragma>"_NOREP_R_"	    { RETURN(NOREP_RATIONAL); }
+<GhcPragma>"_NOREP_S_"	    { RETURN(NOREP_STRING); }
+
+<GhcPragma>" #-}"	    { POP_STATE; RETURN(END_PRAGMA); }
+
+<Code,GlaExt>"{-#"{WS}*"SPECIALI"[SZ]E {
+			      PUSH_STATE(UserPragma);
+			      RETURN(SPECIALISE_UPRAGMA);
+			    }
+<Code,GlaExt>"{-#"{WS}*"INLINE" {
+			      PUSH_STATE(UserPragma);
+			      RETURN(INLINE_UPRAGMA);
+			    }
+<Code,GlaExt>"{-#"{WS}*"MAGIC_UNFOLDING" {
+			      PUSH_STATE(UserPragma);
+			      RETURN(MAGIC_UNFOLDING_UPRAGMA);
+			    }
+<Code,GlaExt>"{-#"{WS}*"DEFOREST" {
+                              PUSH_STATE(UserPragma);
+                              RETURN(DEFOREST_UPRAGMA);
+			    }
+<Code,GlaExt>"{-#"{WS}*[A-Z_]+ {
+    	    	    	      fprintf(stderr, "Warning: \"%s\", line %d: Unrecognised pragma '",
+    	    	    	        input_filename, hsplineno);
+    	    	    	      format_string(stderr, (unsigned char *) yytext, yyleng);
+    	    	    	      fputs("'\n", stderr);
+			      nested_comments = 1;
+			      PUSH_STATE(Comment);
+			    }
+<UserPragma>"#-}"	    { POP_STATE; RETURN(END_UPRAGMA); }
+
+%{
+    /*
+     * Haskell keywords.  `scc' is actually a Glasgow extension, but it is
+     * intentionally accepted as a keyword even for normal <Code>.
+     */
+%}
+
+<Code,GlaExt,GhcPragma>"case" 	{ RETURN(CASE); }
+<Code,GlaExt>"class"		{ RETURN(CLASS); }
+<Code,GlaExt,UserPragma>"data"	{ RETURN(DATA); }
+<Code,GlaExt>"default"  	{ RETURN(DEFAULT); }
+<Code,GlaExt>"deriving" 	{ RETURN(DERIVING); }
+<Code,GlaExt>"do" 		{ RETURN(DO); }
+<Code,GlaExt>"else"		{ RETURN(ELSE); }
+<Code,GlaExt>"if"		{ RETURN(IF); }
+<Code,GlaExt>"import"		{ RETURN(IMPORT); }
+<Code,GlaExt,GhcPragma>"in"	{ RETURN(IN); }
+<Code,GlaExt>"infix"		{ RETURN(INFIX); }
+<Code,GlaExt>"infixl"		{ RETURN(INFIXL); }
+<Code,GlaExt>"infixr"		{ RETURN(INFIXR); }
+<Code,GlaExt,UserPragma>"instance" { RETURN(INSTANCE); }
+<Code,GlaExt,GhcPragma>"let"	{ RETURN(LET); }
+<Code,GlaExt>"module"		{ RETURN(MODULE); }
+<Code,GlaExt>"newtype" 		{ RETURN(NEWTYPE); }
+<Code,GlaExt,GhcPragma>"of"	{ RETURN(OF); }
+<Code,GlaExt>"then"		{ RETURN(THEN); }
+<Code,GlaExt>"type"		{ RETURN(TYPE); }
+<Code,GlaExt>"where"		{ RETURN(WHERE); }
+
+<Code,GlaExt>"as"		{ RETURN(AS); }
+<Code,GlaExt>"hiding"		{ RETURN(HIDING); }
+<Code,GlaExt>"qualified"	{ RETURN(QUALIFIED); }
+<Code,GlaExt>"interface"        { RETURN(INTERFACE); }
+
+<Code,GlaExt,GhcPragma>"_scc_"	{ RETURN(SCC); }
+<GlaExt,GhcPragma>"_ccall_"	{ RETURN(CCALL); }
+<GlaExt,GhcPragma>"_ccall_GC_"	{ RETURN(CCALL_GC); }
+<GlaExt,GhcPragma>"_casm_"	{ RETURN(CASM); }
+<GlaExt,GhcPragma>"_casm_GC_"	{ RETURN(CASM_GC); }
+<GhcPragma>"_forall_"		{ RETURN(FORALL); }
+
+%{
+    /* 
+     * Haskell operators: special, reservedops and useful varsyms
+     */
+%}
+
+<Code,GlaExt,GhcPragma,UserPragma>"("	{ RETURN(OPAREN); }
+<Code,GlaExt,GhcPragma,UserPragma>")"	{ RETURN(CPAREN); }
+<Code,GlaExt,GhcPragma,UserPragma>"["	{ RETURN(OBRACK); }
+<Code,GlaExt,GhcPragma,UserPragma>"]"	{ RETURN(CBRACK); }
+<Code,GlaExt,GhcPragma>"{"		{ RETURN(OCURLY); }
+<Code,GlaExt,GhcPragma>"}"		{ RETURN(CCURLY); }
+<Code,GlaExt,GhcPragma,UserPragma>","	{ RETURN(COMMA); }
+<Code,GlaExt,GhcPragma>";"		{ RETURN(SEMI); }
+<Code,GlaExt,GhcPragma>"`"		{ RETURN(BQUOTE); }
+<Code,GlaExt>"_"			{ RETURN(WILDCARD); }
+
+<Code,GlaExt>".."			{ RETURN(DOTDOT); }
+<Code,GlaExt,GhcPragma,UserPragma>"::"	{ RETURN(DCOLON); }
+<Code,GlaExt,GhcPragma,UserPragma>"="	{ RETURN(EQUAL); }
+<Code,GlaExt,GhcPragma>"\\"		{ RETURN(LAMBDA); }
+<Code,GlaExt,GhcPragma>"|"		{ RETURN(VBAR); }
+<Code,GlaExt>"<-"			{ RETURN(LARROW); }
+<Code,GlaExt,GhcPragma,UserPragma>"->"	{ RETURN(RARROW); }
+<Code,GlaExt>"-"    			{ RETURN(MINUS); }
+
+<Code,GlaExt,GhcPragma,UserPragma>"=>"	{ RETURN(DARROW); }
+<Code,GlaExt>"@"			{ RETURN(AT); }
+<Code,GlaExt>"!"			{ RETURN(BANG); }
+<Code,GlaExt>"~"    			{ RETURN(LAZY); }
+
+<GhcPragma>"_/\\_"			{ RETURN(TYLAMBDA); }
+
+%{
+    /*
+     * Integers and (for Glasgow extensions) primitive integers.  Note that
+     * we pass all of the text on to the parser, because flex/C can't handle
+     * arbitrary precision numbers.
+     */
+%}
+
+<GlaExt>("-")?"0"[Oo]{O}+"#"  { /* octal */
+			 yylval.uid = xstrndup(yytext, yyleng - 1);
+			 RETURN(INTPRIM);
+			}
+<Code,GlaExt>"0"[Oo]{O}+  { /* octal */
+			 yylval.uid = xstrndup(yytext, yyleng);
+			 RETURN(INTEGER);
+			}
+<GlaExt>("-")?"0"[Xx]{H}+"#"  { /* hexadecimal */
+			 yylval.uid = xstrndup(yytext, yyleng - 1);
+			 RETURN(INTPRIM);
+			}
+<Code,GlaExt>"0"[Xx]{H}+  { /* hexadecimal */
+			 yylval.uid = xstrndup(yytext, yyleng);
+			 RETURN(INTEGER);
+			}
+<GlaExt,GhcPragma>("-")?{N}"#"	{
+			 yylval.uid = xstrndup(yytext, yyleng - 1);
+			 RETURN(INTPRIM);
+			}
+<Code,GlaExt,GhcPragma>{N} {
+			 yylval.uid = xstrndup(yytext, yyleng);
+			 RETURN(INTEGER);
+			}
+
+%{
+    /*
+     * Floats and (for Glasgow extensions) primitive floats/doubles.
+     */
+%}
+
+<GlaExt,GhcPragma>("-")?{F}"##" {
+			 yylval.uid = xstrndup(yytext, yyleng - 2);
+			 RETURN(DOUBLEPRIM);
+			}
+<GlaExt,GhcPragma>("-")?{F}"#" {
+			 yylval.uid = xstrndup(yytext, yyleng - 1);
+			 RETURN(FLOATPRIM);
+			}
+<Code,GlaExt>{F}        {
+			 yylval.uid = xstrndup(yytext, yyleng);
+			 RETURN(FLOAT);
+			}
+
+%{
+    /*
+     * Funky ``foo'' style C literals for Glasgow extensions
+     */
+%}
+
+<GlaExt,GhcPragma>"``"[^']+"''"	{
+			 hsnewid(yytext + 2, yyleng - 4);
+			 RETURN(CLITLIT);
+			}
+
+%{
+    /*
+     * Identifiers, both variables and operators.  The trailing hash is allowed
+     * for Glasgow extensions.
+     */
+%}
+
+<GhcPragma>"_NIL_"		{ hsnewid(yytext, yyleng); RETURN(CONID); }
+<GhcPragma>"_TUP_"{D}+		{ hsnewid(yytext, yyleng); RETURN(CONID); }
+<GhcPragma>[a-z]{i}*"$"[a-z]{i}* { hsnewid(yytext, yyleng); RETURN(TYVAR_TEMPLATE_ID); }
+
+%{
+/* These SHOULDNAE work in "Code" (sigh) */
+%}
+<Code,GlaExt,GhcPragma,UserPragma>{Id}"#" { 
+			 if (! (nonstandardFlag || in_interface)) {
+			    char errbuf[ERR_BUF_SIZE];
+			    sprintf(errbuf, "Non-standard identifier (trailing `#'): %s\n", yytext);
+			    hsperror(errbuf);
+			 }
+    	    	    	 hsnewid(yytext, yyleng);
+    	    	    	 RETURN(_isconstr(yytext) ? CONID : VARID);
+			}
+<Code,GlaExt,GhcPragma,UserPragma>_+{Id} { 
+			 if (! (nonstandardFlag || in_interface)) {
+			    char errbuf[ERR_BUF_SIZE];
+			    sprintf(errbuf, "Non-standard identifier (leading underscore): %s\n", yytext);
+			    hsperror(errbuf);
+			 }
+    	    	    	 hsnewid(yytext, yyleng);
+    	    	    	 RETURN(isconstr(yytext) ? CONID : VARID);
+			 /* NB: ^^^^^^^^ : not the macro! */
+			}
+<Code,GlaExt,GhcPragma,UserPragma>{Id}	{
+    	    	         hsnewid(yytext, yyleng);
+			 RETURN(_isconstr(yytext) ? CONID : VARID);
+			}
+<Code,GlaExt,GhcPragma,UserPragma>{SId}	{
+    	    		 hsnewid(yytext, yyleng);
+			 RETURN(_isconstr(yytext) ? CONSYM : VARSYM);
+			}
+<Code,GlaExt,GhcPragma,UserPragma>{Mod}"."{Id}	{
+			 BOOLEAN isconstr = hsnewqid(yytext, yyleng);
+			 RETURN(isconstr ? QCONID : QVARID);
+			}
+<Code,GlaExt,GhcPragma,UserPragma>{Mod}"."{SId}	{
+			 BOOLEAN isconstr = hsnewqid(yytext, yyleng);
+			 RETURN(isconstr ? QCONSYM : QVARSYM);
+			}
+
+%{
+    /* Why is `{Id}#` matched this way, and `{Id}` lexed as three tokens? --JSM */
+
+    /* Because we can make the former well-behaved (we defined them).
+
+       Sadly, the latter is defined by Haskell, which allows such
+       la-la land constructs as `{-a 900-line comment-} foo`.  (WDP 94/12)
+    */
+%}
+
+<GlaExt,GhcPragma,UserPragma>"`"{Id}"#`"	{	
+    	    	    	 hsnewid(yytext + 1, yyleng - 2);
+			 RETURN(_isconstr(yytext+1) ? CONSYM : VARSYM);
+			}
+
+%{
+    /*
+     * Character literals.  The first form is the quick form, for character
+     * literals that don't contain backslashes.  Literals with backslashes are
+     * lexed through multiple rules.  First, we match the open ' and as many
+     * normal characters as possible.  This puts us into the <Char> state, where
+     * a backslash is legal.  Then, we match the backslash and move into the 
+     * <CharEsc> state.  When we drop out of <CharEsc>, we collect more normal
+     * characters and the close '.  We may end up with too many characters, but
+     * this allows us to easily share the lex rules with strings.  Excess characters
+     * are ignored with a warning.
+     */
+%}
+
+<GlaExt,GhcPragma>'({CHAR}|"\"")"'#" {
+    	    	    	 yylval.uhstring = installHstring(1, yytext+1);
+    	    	    	 RETURN(CHARPRIM);
+    	    	    	}
+<Code,GlaExt>'({CHAR}|"\"")'	{
+    	    	    	 yylval.uhstring = installHstring(1, yytext+1);
+    	    	    	 RETURN(CHAR);
+    	    	    	}
+<Code,GlaExt>''		{char errbuf[ERR_BUF_SIZE];
+			 sprintf(errbuf, "'' is not a valid character (or string) literal\n");
+			 hsperror(errbuf);
+			}
+<Code,GlaExt,GhcPragma>'({CHAR}|"\"")* {
+    	    	    	 hsmlcolno = hspcolno;
+    	    	    	 cleartext();
+    	    	    	 addtext(yytext+1, yyleng-1);
+    	    	    	 PUSH_STATE(Char);
+    	    	    	}
+<Char>({CHAR}|"\"")*'#	{
+    	    	    	 unsigned length;
+    	    	    	 char *text;
+
+    	    	    	 addtext(yytext, yyleng - 2);
+    	    	    	 text = fetchtext(&length);
+
+			 if (! (nonstandardFlag || in_interface)) {
+			    char errbuf[ERR_BUF_SIZE];
+			    sprintf(errbuf, "`Char-hash' literals are non-standard: %s\n", text);
+			    hsperror(errbuf);
+			 }
+
+    	    	    	 if (length > 1) {
+    	    	    	    fprintf(stderr, "\"%s\", line %d, column %d: Unboxed character literal '",
+    	    	    	      input_filename, hsplineno, hspcolno + 1);
+    	    	    	    format_string(stderr, (unsigned char *) text, length);
+    	    	    	    fputs("' too long\n", stderr);
+			    hsperror("");
+    	    	    	 }
+			 yylval.uhstring = installHstring(1, text);
+    	    	    	 hspcolno = hsmlcolno;
+    	    	    	 POP_STATE;
+			 RETURN(CHARPRIM); 
+			}
+<Char>({CHAR}|"\"")*'	{
+    	    	    	 unsigned length;
+    	    	    	 char *text;
+
+    	    	    	 addtext(yytext, yyleng - 1);
+    	    	    	 text = fetchtext(&length);
+
+    	    	    	 if (length > 1) {
+    	    	    	    fprintf(stderr, "\"%s\", line %d, column %d: Character literal '",
+    	    	    	      input_filename, hsplineno, hspcolno + 1);
+    	    	    	    format_string(stderr, (unsigned char *) text, length);
+    	    	    	    fputs("' too long\n", stderr);
+			    hsperror("");
+    	    	    	 }
+			 yylval.uhstring = installHstring(1, text);
+    	    	    	 hspcolno = hsmlcolno;
+    	    	    	 POP_STATE;
+			 RETURN(CHAR); 
+			}
+<Char>({CHAR}|"\"")+	{ addtext(yytext, yyleng); }
+
+
+%{
+    /*
+     * String literals.  The first form is the quick form, for string literals
+     * that don't contain backslashes.  Literals with backslashes are lexed
+     * through multiple rules.  First, we match the open " and as many normal
+     * characters as possible.  This puts us into the <String> state, where
+     * a backslash is legal.  Then, we match the backslash and move into the 
+     * <StringEsc> state.  When we drop out of <StringEsc>, we collect more normal
+     * characters, moving back and forth between <String> and <StringEsc> as more
+     * backslashes are encountered.  (We may even digress into <Comment> mode if we
+     * find a comment in a gap between backslashes.)  Finally, we read the last chunk
+     * of normal characters and the close ".
+     */
+%}
+
+<GlaExt,GhcPragma>"\""({CHAR}|"'")*"\""#  {
+			 yylval.uhstring = installHstring(yyleng-3, yytext+1);
+			    /* the -3 accounts for the " on front, "# on the end */
+			 RETURN(STRINGPRIM); 
+    	    	    	}
+<Code,GlaExt,GhcPragma>"\""({CHAR}|"'")*"\""  {
+			 yylval.uhstring = installHstring(yyleng-2, yytext+1);
+			 RETURN(STRING); 
+    	    	    	}
+<Code,GlaExt,GhcPragma>"\""({CHAR}|"'")* {
+    	    	    	 hsmlcolno = hspcolno;
+    	    	    	 cleartext();
+    	    	    	 addtext(yytext+1, yyleng-1);
+    	    	    	 PUSH_STATE(String);
+    	    	    	}
+<String>({CHAR}|"'")*"\"#"   {
+    	    	    	 unsigned length;
+    	    	    	 char *text;
+
+    	    	    	 addtext(yytext, yyleng-2);
+    	    	    	 text = fetchtext(&length);
+
+			 if (! (nonstandardFlag || in_interface)) {
+			    char errbuf[ERR_BUF_SIZE];
+			    sprintf(errbuf, "`String-hash' literals are non-standard: %s\n", text);
+			    hsperror(errbuf);
+			 }
+
+			 yylval.uhstring = installHstring(length, text);
+    	    	    	 hspcolno = hsmlcolno;
+    	    	    	 POP_STATE;
+			 RETURN(STRINGPRIM);
+			}
+<String>({CHAR}|"'")*"\""   {
+    	    	    	 unsigned length;
+    	    	    	 char *text;
+
+    	    	    	 addtext(yytext, yyleng-1);
+    	    	    	 text = fetchtext(&length);
+
+			 yylval.uhstring = installHstring(length, text);
+    	    	    	 hspcolno = hsmlcolno;
+    	    	    	 POP_STATE;
+			 RETURN(STRING); 
+			}
+<String>({CHAR}|"'")+   { addtext(yytext, yyleng); }
+
+%{
+    /*
+     * Character and string escapes are roughly the same, but strings have the
+     * extra `\&' sequence which is not allowed for characters.  Also, comments
+     * are allowed in the <StringEsc> state.  (See the comment section much
+     * further down.)
+     *
+     * NB: Backslashes and tabs are stored in strings as themselves.
+     * But if we print them (in printtree.c), they must go out as
+     * "\\\\" and "\\t" respectively.  (This is because of the bogus
+     * intermediate format that the parser produces.  It uses '\t' fpr end of
+     * string, so it needs to be able to escape tabs, which means that it
+     * also needs to be able to escape the escape character ('\\').  Sigh.
+     */
+%}
+
+<Char>\\    	    	{ PUSH_STATE(CharEsc); }
+<String>\\&	    	/* Ignore */ ;
+<String>\\    	    	{ PUSH_STATE(StringEsc); noGap = TRUE; }
+
+<CharEsc>\\    	    	{ addchar(*yytext); POP_STATE; }
+<StringEsc>\\	    	{ if (noGap) { addchar(*yytext); } POP_STATE; }
+
+<CharEsc,StringEsc>["']	{ addchar(*yytext); POP_STATE; }
+<CharEsc,StringEsc>NUL 	{ addchar('\000'); POP_STATE; }
+<CharEsc,StringEsc>SOH 	{ addchar('\001'); POP_STATE; }
+<CharEsc,StringEsc>STX 	{ addchar('\002'); POP_STATE; }
+<CharEsc,StringEsc>ETX 	{ addchar('\003'); POP_STATE; }
+<CharEsc,StringEsc>EOT  { addchar('\004'); POP_STATE; }
+<CharEsc,StringEsc>ENQ	{ addchar('\005'); POP_STATE; }
+<CharEsc,StringEsc>ACK	{ addchar('\006'); POP_STATE; }
+<CharEsc,StringEsc>BEL 	|
+<CharEsc,StringEsc>a	{ addchar('\007'); POP_STATE; }
+<CharEsc,StringEsc>BS 	|
+<CharEsc,StringEsc>b	{ addchar('\010'); POP_STATE; }
+<CharEsc,StringEsc>HT 	|
+<CharEsc,StringEsc>t 	{ addchar('\011'); POP_STATE; }
+<CharEsc,StringEsc>LF 	|
+<CharEsc,StringEsc>n	{ addchar('\012'); POP_STATE; }
+<CharEsc,StringEsc>VT 	|
+<CharEsc,StringEsc>v	{ addchar('\013'); POP_STATE; }
+<CharEsc,StringEsc>FF 	|
+<CharEsc,StringEsc>f	{ addchar('\014'); POP_STATE; }
+<CharEsc,StringEsc>CR 	|
+<CharEsc,StringEsc>r	{ addchar('\015'); POP_STATE; }
+<CharEsc,StringEsc>SO	{ addchar('\016'); POP_STATE; }
+<CharEsc,StringEsc>SI	{ addchar('\017'); POP_STATE; }
+<CharEsc,StringEsc>DLE	{ addchar('\020'); POP_STATE; }
+<CharEsc,StringEsc>DC1	{ addchar('\021'); POP_STATE; }
+<CharEsc,StringEsc>DC2	{ addchar('\022'); POP_STATE; }
+<CharEsc,StringEsc>DC3	{ addchar('\023'); POP_STATE; }
+<CharEsc,StringEsc>DC4	{ addchar('\024'); POP_STATE; }
+<CharEsc,StringEsc>NAK	{ addchar('\025'); POP_STATE; }
+<CharEsc,StringEsc>SYN	{ addchar('\026'); POP_STATE; }
+<CharEsc,StringEsc>ETB	{ addchar('\027'); POP_STATE; }
+<CharEsc,StringEsc>CAN	{ addchar('\030'); POP_STATE; }
+<CharEsc,StringEsc>EM	{ addchar('\031'); POP_STATE; }
+<CharEsc,StringEsc>SUB	{ addchar('\032'); POP_STATE; }
+<CharEsc,StringEsc>ESC	{ addchar('\033'); POP_STATE; }
+<CharEsc,StringEsc>FS	{ addchar('\034'); POP_STATE; }
+<CharEsc,StringEsc>GS	{ addchar('\035'); POP_STATE; }
+<CharEsc,StringEsc>RS	{ addchar('\036'); POP_STATE; }
+<CharEsc,StringEsc>US	{ addchar('\037'); POP_STATE; }
+<CharEsc,StringEsc>SP	{ addchar('\040'); POP_STATE; }
+<CharEsc,StringEsc>DEL	{ addchar('\177'); POP_STATE; }
+<CharEsc,StringEsc>"^"{CNTRL} { char c = yytext[1] - '@'; addchar(c); POP_STATE; }
+<CharEsc,StringEsc>{D}+	 {
+    	    	    	  int i = strtol(yytext, NULL, 10);
+			  if (i < NCHARS) {
+			     addchar((char) i);
+			  } else {
+			     char errbuf[ERR_BUF_SIZE];
+			     sprintf(errbuf, "Numeric escape \"\\%s\" out of range\n", 
+				yytext);
+			     hsperror(errbuf);
+			  }
+    	    	    	  POP_STATE;
+			}
+<CharEsc,StringEsc>o{O}+ {
+    	    	   	  int i = strtol(yytext + 1, NULL, 8);
+			  if (i < NCHARS) {
+			     addchar((char) i);
+			  } else {
+			     char errbuf[ERR_BUF_SIZE];
+			     sprintf(errbuf, "Numeric escape \"\\%s\" out of range\n", 
+				yytext);
+			     hsperror(errbuf);
+			  }
+    	    	    	  POP_STATE;
+			}
+<CharEsc,StringEsc>x{H}+ {
+    	    	    	  int i = strtol(yytext + 1, NULL, 16);
+			  if (i < NCHARS) {
+			     addchar((char) i);
+			  } else {
+			     char errbuf[ERR_BUF_SIZE];
+			     sprintf(errbuf, "Numeric escape \"\\%s\" out of range\n", 
+				yytext);
+			     hsperror(errbuf);
+			  }
+    	    	    	  POP_STATE;
+			}
+
+%{
+    /*
+     * Simple comments and whitespace.  Normally, we would just ignore these, but
+     * in case we're processing a string escape, we need to note that we've seen
+     * a gap.
+     *
+     * Note that we cater for a comment line that *doesn't* end in a newline.
+     * This is incorrect, strictly speaking, but seems like the right thing
+     * to do.  Reported by Rajiv Mirani.  (WDP 95/08)
+     */
+%}
+
+<Code,GlaExt,StringEsc>"--".*{NL}?{WS}* |
+<Code,GlaExt,GhcPragma,UserPragma,StringEsc>{WS}+	{ noGap = FALSE; }
+
+%{
+    /*
+     * Nested comments.  The major complication here is in trying to match the
+     * longest lexemes possible, for better performance.  (See the flex document.)
+     * That's why the rules look so bizarre.
+     */
+%}
+
+<Code,GlaExt,GhcPragma,UserPragma,StringEsc>"{-"	{ 
+    	    	    	  noGap = FALSE; nested_comments = 1; PUSH_STATE(Comment); 
+    	    	    	}
+
+<Comment>[^-{]*     	|
+<Comment>"-"+[^-{}]+ 	|
+<Comment>"{"+[^-{}]+	;
+<Comment>"{-"		{ nested_comments++; }
+<Comment>"-}"	    	{ if (--nested_comments == 0) POP_STATE; }
+<Comment>(.|\n)	    	;
+
+%{
+    /*
+     * Illegal characters.  This used to be a single rule, but we might as well
+     * pass on as much information as we have, so now we indicate our state in
+     * the error message.
+     */
+%}
+
+<INITIAL,Code,GlaExt,GhcPragma,UserPragma>(.|\n)	{ 
+    	    	    	 fprintf(stderr, "\"%s\", line %d, column %d: Illegal character: `", 
+    	    	    	    input_filename, hsplineno, hspcolno + 1); 
+    	    	    	 format_string(stderr, (unsigned char *) yytext, 1);
+    	    	    	 fputs("'\n", stderr);
+			 hsperror("");
+			}
+<Char>(.|\n)		{ 
+    	    	    	 fprintf(stderr, "\"%s\", line %d, column %d: Illegal character: `",
+    	    	    	    input_filename, hsplineno, hspcolno + 1); 
+    	    	    	 format_string(stderr, (unsigned char *) yytext, 1);
+    	    	    	 fputs("' in a character literal\n", stderr);
+			 hsperror("");
+			}
+<CharEsc>(.|\n)		{
+    	    	    	 fprintf(stderr, "\"%s\", line %d, column %d: Illegal character escape: `\\",
+    	    	    	    input_filename, hsplineno, hspcolno + 1); 
+    	    	    	 format_string(stderr, (unsigned char *) yytext, 1);
+    	    	    	 fputs("'\n", stderr);
+			 hsperror("");
+    	    	    	}
+<String>(.|\n)		{ if (nonstandardFlag) {
+                             addtext(yytext, yyleng);
+                          } else { 
+                                fprintf(stderr, "\"%s\", line %d, column %d: Illegal character: `", 
+                                input_filename, hsplineno, hspcolno + 1); 
+                                format_string(stderr, (unsigned char *) yytext, 1);
+                                fputs("' in a string literal\n", stderr);
+                                hsperror("");
+			  }
+			}
+<StringEsc>(.|\n)	{
+    	    	    	 if (noGap) {
+    	    	    	     fprintf(stderr, "\"%s\", line %d, column %d: Illegal string escape: `\\", 
+    	    	    	    	input_filename, hsplineno, hspcolno + 1); 
+    	    	    	     format_string(stderr, (unsigned char *) yytext, 1);
+    	    	    	     fputs("'\n", stderr);
+			     hsperror("");
+    	    	    	 } else {
+    	    	    	     fprintf(stderr, "\"%s\", line %d, column %d: Illegal character: `",
+    	    	    	    	input_filename, hsplineno, hspcolno + 1);
+    	    	    	     format_string(stderr, (unsigned char *) yytext, 1);
+    	    	    	     fputs("' in a string gap\n", stderr);
+			     hsperror("");
+    	    	    	 }
+    	    	    	}
+
+%{
+    /*
+     * End of file.  In any sub-state, this is an error.  However, for the primary
+     * <Code> and <GlaExt> states, this is perfectly normal.  We just return an EOF
+     * and let the yylex() wrapper deal with whatever has to be done next (e.g.
+     * adding virtual close curlies, or closing an interface and returning to the
+     * primary source file.
+     *
+     * Note that flex does not call YY_USER_ACTION for <<EOF>> rules.  Hence the
+     * line/column advancement has to be done by hand.
+     */
+%}
+
+<Char,CharEsc><<EOF>>  	{ 
+    	    	    	  hsplineno = hslineno; hspcolno = hscolno;
+    	    	    	  hsperror("unterminated character literal");
+    	    	    	}
+<Comment><<EOF>>    	{ 
+    	    	    	  hsplineno = hslineno; hspcolno = hscolno;
+    	    	    	  hsperror("unterminated comment"); 
+    	    	    	}
+<String,StringEsc><<EOF>>   { 
+    	    	    	  hsplineno = hslineno; hspcolno = hscolno;
+    	    	    	  hsperror("unterminated string literal"); 
+    	    	    	}
+<GhcPragma><<EOF>>  	{
+    	    	    	  hsplineno = hslineno; hspcolno = hscolno;
+    	    	    	  hsperror("unterminated interface pragma"); 
+			}
+<UserPragma><<EOF>>  	{
+    	    	    	  hsplineno = hslineno; hspcolno = hscolno;
+    	    	    	  hsperror("unterminated user-specified pragma"); 
+			}
+<Code,GlaExt><<EOF>>   	{ hsplineno = hslineno; hspcolno = hscolno; return(EOF); }
+
+%%
+
+/**********************************************************************
+*                                                                     *
+*                                                                     *
+*     YACC/LEX Initialisation etc.                                    *
+*                                                                     *
+*                                                                     *
+**********************************************************************/
+
+/*
+   We initialise input_filename to "<stdin>".
+   This allows unnamed sources to be piped into the parser.
+*/
+
+extern BOOLEAN acceptPrim;
+
+void
+yyinit(void)
+{
+    input_filename = xstrdup("<stdin>");
+
+    /* We must initialize the input buffer _now_, because we call
+       setyyin _before_ calling yylex for the first time! */
+    yy_switch_to_buffer(yy_create_buffer(stdin, YY_BUF_SIZE));
+
+    if (acceptPrim)
+	PUSH_STATE(GlaExt);
+    else
+	PUSH_STATE(Code);
+}
+
+static void
+new_filename(char *f) /* This looks pretty dodgy to me (WDP) */
+{
+    if (input_filename != NULL)
+	free(input_filename);
+    input_filename = xstrdup(f);
+}
+
+/**********************************************************************
+*                                                                     *
+*                                                                     *
+*     Layout Processing                                               *
+*                                                                     *
+*                                                                     *
+**********************************************************************/
+
+/*
+	The following section deals with Haskell Layout conventions
+	forcing insertion of ; or } as appropriate
+*/
+
+static BOOLEAN
+hsshouldindent(void)
+{
+    return (!forgetindent && INDENTON);
+}
+
+
+/* Enter new context and set new indentation level */
+void
+hssetindent(void)
+{
+#ifdef HSP_DEBUG
+    fprintf(stderr, "hssetindent:hscolno=%d,hspcolno=%d,INDENTPT[%d]=%d\n", hscolno, hspcolno, icontexts, INDENTPT);
+#endif
+
+    /*
+     * partain: first chk that new indent won't be less than current one; this code
+     * doesn't make sense to me; hscolno tells the position of the _end_ of the
+     * current token; what that has to do with indenting, I don't know.
+     */
+
+
+    if (hscolno - 1 <= INDENTPT) {
+	if (INDENTPT == -1)
+	    return;		/* Empty input OK for Haskell 1.1 */
+	else {
+	    char errbuf[ERR_BUF_SIZE];
+
+	    sprintf(errbuf, "Layout error -- indentation should be > %d cols", INDENTPT);
+	    hsperror(errbuf);
+	}
+    }
+    hsentercontext((hspcolno << 1) | 1);
+}
+
+
+/* Enter a new context without changing the indentation level */
+void
+hsincindent(void)
+{
+#ifdef HSP_DEBUG
+    fprintf(stderr, "hsincindent:hscolno=%d,hspcolno=%d,INDENTPT[%d]=%d\n", hscolno, hspcolno, icontexts, INDENTPT);
+#endif
+    hsentercontext(indenttab[icontexts] & ~1);
+}
+
+
+/* Turn off indentation processing, usually because an explicit "{" has been seen */
+void
+hsindentoff(void)
+{
+    forgetindent = TRUE;
+}
+
+
+/* Enter a new layout context. */
+static void
+hsentercontext(int indent)
+{
+    /* Enter new context and set indentation as specified */
+    if (++icontexts >= MAX_CONTEXTS) {
+	char errbuf[ERR_BUF_SIZE];
+
+	sprintf(errbuf, "`wheres' and `cases' nested too deeply (>%d)", MAX_CONTEXTS - 1);
+	hsperror(errbuf);
+    }
+    forgetindent = FALSE;
+    indenttab[icontexts] = indent;
+#ifdef HSP_DEBUG
+    fprintf(stderr, "hsentercontext:indent=%d,hscolno=%d,hspcolno=%d,INDENTPT[%d]=%d\n", indent, hscolno, hspcolno, icontexts, INDENTPT);
+#endif
+}
+
+
+/* Exit a layout context */
+void
+hsendindent(void)
+{
+    --icontexts;
+#ifdef HSP_DEBUG
+    fprintf(stderr, "hsendindent:hscolno=%d,hspcolno=%d,INDENTPT[%d]=%d\n", hscolno, hspcolno, icontexts, INDENTPT);
+#endif
+}
+
+/*
+ * 	Return checks the indentation level and returns ;, } or the specified token.
+ */
+
+static int
+Return(int tok)
+{
+#ifdef HSP_DEBUG
+    extern int yyleng;
+#endif
+
+    if (hsshouldindent()) {
+	if (hspcolno < INDENTPT) {
+#ifdef HSP_DEBUG
+	    fprintf(stderr, "inserted '}' before %d (%d:%d:%d:%d)\n", tok, hspcolno, hscolno, yyleng, INDENTPT);
+#endif
+	    hssttok = tok;
+	    return (VCCURLY);
+	} else if (hspcolno == INDENTPT) {
+#ifdef HSP_DEBUG
+	    fprintf(stderr, "inserted ';' before %d (%d:%d)\n", tok, hspcolno, INDENTPT);
+#endif
+	    hssttok = -tok;
+	    return (SEMI);
+	}
+    }
+    hssttok = -1;
+#ifdef HSP_DEBUG
+    fprintf(stderr, "returning %d (%d:%d)\n", tok, hspcolno, INDENTPT);
+#endif
+    return (tok);
+}
+
+
+/*
+ *	Redefine yylex to check for stacked tokens, yylex1() is the original yylex()
+ */
+int
+yylex()
+{
+    int tok;
+    static BOOLEAN eof = FALSE;
+
+    if (!eof) {
+	if (hssttok != -1) {
+	    if (hssttok < 0) {
+		tok = -hssttok;
+		hssttok = -1;
+		return tok;
+	    }
+	    RETURN(hssttok);
+	} else {
+    	    endlineno = hslineno;
+	    if ((tok = yylex1()) != EOF)
+		return tok;
+	    else
+		eof = TRUE;
+	}
+    }
+    if (icontexts > icontexts_save) {
+	if (INDENTON) {
+	    eof = TRUE;
+	    indenttab[icontexts] = 0;
+	    return (VCCURLY);
+	} else
+	    hsperror("missing '}' at end of file");
+    } else if (hsbuf_save != NULL) {
+	fclose(yyin);
+	yy_delete_buffer(YY_CURRENT_BUFFER);
+	yy_switch_to_buffer(hsbuf_save);
+	hsbuf_save = NULL;
+	new_filename(filename_save);
+    	free(filename_save);
+	hslineno = hslineno_save;
+	hsplineno = hsplineno_save;
+	hscolno = hscolno_save;
+	hspcolno = hspcolno_save;
+	etags = etags_save;
+	in_interface = FALSE;
+	icontexts = icontexts_save - 1;
+	icontexts_save = 0;
+#ifdef HSP_DEBUG
+	fprintf(stderr, "finished reading interface (%d:%d:%d)\n", hscolno, hspcolno, INDENTPT);
+#endif
+	eof = FALSE;
+	RETURN(LEOF);
+    } else {
+	yyterminate();
+    }
+    abort(); /* should never get here! */
+    return(0);
+}
+
+/**********************************************************************
+*                                                                     *
+*                                                                     *
+*     Input Processing for Interfaces                                 *
+*                                                                     *
+*                                                                     *
+**********************************************************************/
+
+/* setyyin(file)	open file as new lex input buffer */
+extern FILE *yyin;
+
+void
+setyyin(char *file)
+{
+    hsbuf_save = YY_CURRENT_BUFFER;
+    if ((yyin = fopen(file, "r")) == NULL) {
+	char errbuf[ERR_BUF_SIZE];
+
+	sprintf(errbuf, "can't read \"%-.50s\"", file);
+	hsperror(errbuf);
+    }
+    yy_switch_to_buffer(yy_create_buffer(yyin, YY_BUF_SIZE));
+
+    hslineno_save = hslineno;
+    hsplineno_save = hsplineno;
+    hslineno = hsplineno = 1;
+
+    filename_save = input_filename;
+    input_filename = NULL;
+    new_filename(file);
+    hscolno_save = hscolno;
+    hspcolno_save = hspcolno;
+    hscolno = hspcolno = 0;
+    in_interface = TRUE;
+    etags_save = etags; /* do not do "etags" stuff in interfaces */
+    etags = 0;		/* We remember whether we are doing it in
+			   the module, so we can restore it later [WDP 94/09] */
+    hsentercontext(-1);		/* partain: changed this from 0 */
+    icontexts_save = icontexts;
+#ifdef HSP_DEBUG
+    fprintf(stderr, "reading %s (%d:%d:%d)\n", input_filename, hscolno_save, hspcolno_save, INDENTPT);
+#endif
+}
+
+static void
+layout_input(char *text, int len)
+{
+#ifdef HSP_DEBUG
+    fprintf(stderr, "Scanning \"%s\"\n", text);
+#endif
+
+    hsplineno = hslineno;
+    hspcolno = hscolno;
+
+    while (len-- > 0) {
+	switch (*text++) {
+	case '\n':
+	case '\r':
+	case '\f':
+	    hslineno++;
+	    hscolno = 0;
+	    break;
+	case '\t':
+	    hscolno += 8 - (hscolno % 8);	/* Tabs stops are 8 columns apart */
+	    break;
+	case '\v':
+	    break;
+	default:
+	    ++hscolno;
+	    break;
+	}
+    }
+}
+
+void
+setstartlineno(void)
+{
+    startlineno = hsplineno;
+
+    if (modulelineno == 0) {
+	modulelineno = startlineno;
+    }
+
+#if 1/*etags*/
+#else
+    if (etags)
+	fprintf(stderr,"%u\tsetstartlineno (col %u)\n",startlineno,hscolno);
+#endif
+}
+
+/**********************************************************************
+*                                                                     *
+*                                                                     *
+*                      Text Caching                                   *
+*                                                                     *
+*                                                                     *
+**********************************************************************/
+
+#define CACHE_SIZE YY_BUF_SIZE
+
+static struct {
+    unsigned allocated;
+    unsigned next;
+    char *text;
+} textcache = { 0, 0, NULL };
+
+static void
+cleartext(void)
+{
+/*  fprintf(stderr, "cleartext\n"); */
+    textcache.next = 0;
+    if (textcache.allocated == 0) {
+	textcache.allocated = CACHE_SIZE;
+	textcache.text = xmalloc(CACHE_SIZE);
+    }
+}
+
+static void
+addtext(char *text, unsigned length)
+{
+/*  fprintf(stderr, "addtext: %d %s\n", length, text); */
+
+    if (length == 0)
+	return;
+
+    if (textcache.next + length + 1 >= textcache.allocated) {
+	textcache.allocated += length + CACHE_SIZE;
+	textcache.text = xrealloc(textcache.text, textcache.allocated);
+    }
+    bcopy(text, textcache.text + textcache.next, length);
+    textcache.next += length;
+}
+
+static void
+addchar(char c)
+{
+/*  fprintf(stderr, "addchar: %c\n", c); */
+
+    if (textcache.next + 2 >= textcache.allocated) {
+	textcache.allocated += CACHE_SIZE;
+	textcache.text = xrealloc(textcache.text, textcache.allocated);
+    }
+    textcache.text[textcache.next++] = c;
+}
+
+static char *
+fetchtext(unsigned *length)
+{
+/*  fprintf(stderr, "fetchtext: %d\n", textcache.next); */
+
+    *length = textcache.next;
+    textcache.text[textcache.next] = '\0';
+    return textcache.text;
+}
+
+/**********************************************************************
+*                                                                     *
+*                                                                     *
+*    Identifier Processing                                             *
+*                                                                     *
+*                                                                     *
+**********************************************************************/
+
+/*
+	hsnewid		Enters an id of length n into the symbol table.
+*/
+
+static void
+hsnewid(char *name, int length)
+{
+    char save = name[length];
+
+    name[length] = '\0';
+    yylval.uid = installid(name);
+    name[length] = save;
+}
+
+BOOLEAN
+hsnewqid(char *name, int length)
+{
+    char* dot;
+    char save = name[length];
+    name[length] = '\0';
+
+    dot = strchr(name, '.');
+    *dot = '\0';
+    yylval.uqid = mkaqual(installid(name),installid(dot+1));
+    *dot = '.';
+    name[length] = save;
+
+    return _isconstr(dot+1);
+}
+
+BOOLEAN 
+isconstr(char *s) /* walks past leading underscores before using the macro */
+{
+    char *temp = s;
+
+    for ( ; temp != NULL && *temp == '_' ; temp++ );
+
+    return _isconstr(temp);
+}
diff --git a/ghc/compiler/parser/hsparser.y b/ghc/compiler/parser/hsparser.y
new file mode 100644
index 0000000000..a3e99174bc
--- /dev/null
+++ b/ghc/compiler/parser/hsparser.y
@@ -0,0 +1,2309 @@
+/**************************************************************************
+*   File:               hsparser.y                                        *
+*                                                                         *
+*                       Author:                 Maria M. Gutierrez        *
+*                       Modified by:            Kevin Hammond             *
+*                       Last date revised:      December 13 1991. KH.     *
+*                       Modification:           Haskell 1.1 Syntax.       *
+*                                                                         *
+*                                                                         *
+*   Description:  This file contains the LALR(1) grammar for Haskell.     *
+*                                                                         *
+*   Entry Point:  module                                                  *
+*                                                                         *
+*   Problems:     None known.                                             *
+*                                                                         *
+*                                                                         *
+*                 LALR(1) Syntax for Haskell 1.2                          *
+*                                                                         *
+**************************************************************************/
+
+
+%{
+#ifdef HSP_DEBUG
+# define YYDEBUG 1
+#endif
+
+#include <stdio.h>
+#include <ctype.h>
+#include <string.h>
+#include "hspincl.h"
+#include "constants.h"
+#include "utils.h"
+
+/**********************************************************************
+*                                                                     *
+*                                                                     *
+*     Imported Variables and Functions                                *
+*                                                                     *
+*                                                                     *
+**********************************************************************/
+
+static BOOLEAN expect_ccurly = FALSE; /* Used to signal that a CCURLY could be inserted here */
+
+extern BOOLEAN nonstandardFlag;
+extern BOOLEAN etags;
+
+extern VOID find_module_on_imports_dirlist PROTO((char *, BOOLEAN, char *));
+
+extern char *input_filename;
+static char *the_module_name;
+static char *iface_name;
+static char iface_filename[FILENAME_SIZE];
+
+static maybe module_exports;		/* Exported entities */
+static list prelude_core_import, prelude_imports;
+					/* Entities imported from the Prelude */
+
+extern tree niltree;
+extern list Lnil;
+
+extern tree root;
+
+/* For FN, PREVPATT and SAMEFN macros */
+extern qid	fns[];
+extern BOOLEAN	samefn[];
+extern tree	prevpatt[];
+extern short	icontexts;
+
+/* Line Numbers */
+extern int hsplineno, hspcolno;
+extern int modulelineno;
+extern int startlineno;
+extern int endlineno;
+
+/**********************************************************************
+*                                                                     *
+*                                                                     *
+*      Fixity and Precedence Declarations                             *
+*                                                                     *
+*                                                                     *
+**********************************************************************/
+
+/* OLD 95/08: list fixlist; */
+static int Fixity = 0, Precedence = 0;
+struct infix;
+
+char *ineg PROTO((char *));
+
+int importlineno = 0;		/* The line number where an import starts */
+
+long	inimport; 		/* Info about current import */
+id 	importmod;
+long 	importas;
+id	asmod;
+long 	importqual;
+long 	importspec;
+long 	importhide;
+list 	importlist;
+
+extern BOOLEAN inpat;			/*  True when parsing a pattern */
+extern BOOLEAN implicitPrelude;		/*  True when we should read the Prelude if not given */
+extern BOOLEAN haskell1_2Flag;		/*  True if we are attempting (proto)Haskell 1.3 */
+
+extern int thisIfacePragmaVersion;
+%}
+
+%union {
+	tree utree;
+	list ulist;
+	ttype uttype;
+	constr uconstr;
+	binding ubinding;
+	pbinding upbinding;
+	entidt uentid;
+	id uid;
+	qid uqid;
+	literal uliteral;
+        maybe umaybe;
+        either ueither;
+	long ulong;
+	float ufloat;
+	char *ustring;
+	hstring uhstring;
+	hpragma uhpragma;
+	coresyn ucoresyn;
+}
+
+
+/**********************************************************************
+*                                                                     *
+*                                                                     *
+*     These are lexemes.                                              *
+*                                                                     *
+*                                                                     *
+**********************************************************************/
+
+
+%token 	VARID 		CONID		QVARID		QCONID
+	VARSYM		CONSYM		QVARSYM		QCONSYM
+
+%token 	INTEGER 	FLOAT 		CHAR 		STRING
+	CHARPRIM	STRINGPRIM	INTPRIM		FLOATPRIM
+	DOUBLEPRIM	CLITLIT
+
+
+
+/**********************************************************************
+*                                                                     *
+*                                                                     *
+*      Special Symbols                                                *
+*                                                                     *
+*                                                                     *
+**********************************************************************/
+
+%token	OCURLY		CCURLY		VCCURLY		SEMI
+%token	OBRACK		CBRACK		OPAREN		CPAREN
+%token	COMMA		BQUOTE
+
+
+/**********************************************************************
+*                                                                     *
+*                                                                     *
+*     Reserved Operators                                              *
+*                                                                     *
+*                                                                     *
+**********************************************************************/
+
+%token	DOTDOT		DCOLON		EQUAL
+%token	LAMBDA		VBAR		RARROW
+%token 	LARROW		MINUS
+
+
+/**********************************************************************
+*                                                                     *
+*                                                                     *
+*     Reserved Identifiers                                            *
+*                                                                     *
+*                                                                     *
+**********************************************************************/
+
+%token  CASE		CLASS		DATA
+%token	DEFAULT		DERIVING	DO
+%token  ELSE		IF		IMPORT
+%token	IN		INFIX		INFIXL
+%token  INFIXR		INSTANCE	LET
+%token	MODULE		NEWTYPE		OF
+%token	THEN		TYPE		WHERE
+
+%token  INTERFACE	SCC
+%token	CCALL		CCALL_GC	CASM		CASM_GC
+
+
+/**********************************************************************
+*                                                                     *
+*                                                                     *
+*     Valid symbols/identifiers which need to be recognised           *
+*                                                                     *
+*                                                                     *
+**********************************************************************/
+
+%token	WILDCARD	AT		LAZY		BANG
+%token 	AS		HIDING		QUALIFIED
+
+
+/**********************************************************************
+*                                                                     *
+*                                                                     *
+*     Special Symbols for the Lexer                                   *
+*                                                                     *
+*                                                                     *
+**********************************************************************/
+
+%token	LEOF
+%token  GHC_PRAGMA END_PRAGMA NO_PRAGMA NOINFO_PRAGMA SPECIALISE_PRAGMA
+%token  ARITY_PRAGMA UPDATE_PRAGMA STRICTNESS_PRAGMA KIND_PRAGMA
+%token  UNFOLDING_PRAGMA MAGIC_UNFOLDING_PRAGMA DEFOREST_PRAGMA
+%token  SPECIALISE_UPRAGMA INLINE_UPRAGMA MAGIC_UNFOLDING_UPRAGMA
+%token  DEFOREST_UPRAGMA END_UPRAGMA
+%token  TYLAMBDA COCON COPRIM COAPP COTYAPP FORALL TYVAR_TEMPLATE_ID
+%token  CO_ALG_ALTS CO_PRIM_ALTS CO_NO_DEFAULT CO_LETREC
+%token  CO_SDSEL_ID CO_METH_ID CO_DEFM_ID CO_DFUN_ID CO_CONSTM_ID
+%token  CO_SPEC_ID CO_WRKR_ID CO_ORIG_NM
+%token  UNFOLD_ALWAYS UNFOLD_IF_ARGS
+%token  NOREP_INTEGER NOREP_RATIONAL NOREP_STRING
+%token  CO_PRELUDE_DICTS_CC CO_ALL_DICTS_CC CO_USER_CC CO_AUTO_CC CO_DICT_CC
+%token  CO_CAF_CC CO_DUPD_CC
+
+/**********************************************************************
+*                                                                     *
+*                                                                     *
+*     Precedences of the various tokens                               *
+*                                                                     *
+*                                                                     *
+**********************************************************************/
+
+
+%left	CASE	LET	IN
+  	IF	ELSE	LAMBDA
+	SCC	CASM	CCALL	CASM_GC	CCALL_GC
+
+%left	VARSYM	CONSYM	QVARSYM	QCONSYM
+	MINUS	BQUOTE	BANG	DARROW
+
+%left	DCOLON
+
+%left	SEMI	COMMA
+
+%left	OCURLY	OBRACK	OPAREN
+
+%left 	EQUAL
+
+%right	RARROW
+
+/**********************************************************************
+*                                                                     *
+*                                                                     *
+*      Type Declarations                                              *
+*                                                                     *
+*                                                                     *
+**********************************************************************/
+
+
+%type <ulist>   caserest alts alt quals
+		dorest stmts stmt
+		rbinds rpats list_exps 
+		qvarsk qvars_list
+		constrs constr1 fields 
+		types atypes batypes
+		types_and_maybe_ids
+  		pats context context_list tyvar_list
+		export_list enames
+  		import_list inames
+ 		impdecls maybeimpdecls impdecl
+		maybefixes fixes fix ops
+		dtyclses dtycls_list
+  		gdrhs gdpat valrhs
+  		lampats	cexps
+		idata_pragma_specs idata_pragma_specslist
+		gen_pragma_list type_pragma_pairs
+		type_pragma_pairs_maybe name_pragma_pairs
+		type_maybes
+		core_binders core_tyvars core_tv_templates
+		core_types core_type_list
+		core_atoms core_atom_list
+		core_alg_alts core_prim_alts corec_binds
+		core_type_maybes
+
+%type <umaybe>  maybeexports impas maybeimpspec
+		type_maybe core_type_maybe
+
+
+%type <ueither> impspec  
+
+%type <uliteral> lit_constant
+
+%type <utree>	exp oexp dexp kexp fexp aexp rbind texps
+		expL oexpL kexpL expLno oexpLno dexpLno kexpLno
+		qual gd leftexp
+ 		apat bpat pat apatc conpat dpat fpat opat aapat
+ 		dpatk fpatk opatk aapatk rpat
+
+
+%type <uid>	MINUS DARROW AS LAZY
+		VARID CONID VARSYM CONSYM 
+		TYVAR_TEMPLATE_ID
+  		var con varop conop op
+		vark varid varsym varsym_nominus
+	        tycon modid impmod ccallid
+
+%type <uqid>	QVARID QCONID QVARSYM QCONSYM 
+		qvarid qconid qvarsym qconsym
+		qvar qcon qvarop qconop qop
+		qvark qconk qtycon qtycls
+		gcon gconk gtycon qop1 qvarop1 
+		ename iname 
+
+%type <ubinding>  topdecl topdecls letdecls
+		  typed datad newtd classd instd defaultd
+		  decl decls valdef instdef instdefs
+  		  maybeifixes iimport iimports maybeiimports
+		  ityped idatad inewtd iclassd iinstd ivarsd
+  		  itopdecl itopdecls
+  		  maybe_where
+  		  interface dointerface readinterface ibody
+		  cbody rinst
+		  type_and_maybe_id
+
+%type <upbinding> valrhs1 altrest
+
+%type <uttype>    simple ctype type atype btype
+		  gtyconapp ntyconapp ntycon gtyconvars
+		  bbtype batype btyconapp
+		  class restrict_inst general_inst tyvar
+		  core_type
+
+%type <uconstr>	  constr field
+
+%type <ustring>   FLOAT INTEGER INTPRIM
+		  FLOATPRIM DOUBLEPRIM CLITLIT
+
+%type <uhstring>  STRING STRINGPRIM CHAR CHARPRIM
+
+%type <uentid>	  export import
+
+%type <uhpragma>  idata_pragma inewt_pragma idata_pragma_spectypes
+		  iclas_pragma iclasop_pragma
+		  iinst_pragma gen_pragma ival_pragma arity_pragma
+		  update_pragma strictness_pragma worker_info
+		  deforest_pragma
+		  unfolding_pragma unfolding_guidance type_pragma_pair
+		  name_pragma_pair
+
+%type <ucoresyn>  core_expr core_case_alts core_id core_binder core_atom
+		  core_alg_alt core_prim_alt core_default corec_bind
+		  co_primop co_scc co_caf co_dupd
+
+%type <ulong>     commas impqual
+
+/**********************************************************************
+*                                                                     *
+*                                                                     *
+*      Start Symbol for the Parser                                    *
+*                                                                     *
+*                                                                     *
+**********************************************************************/
+
+%start pmodule
+
+
+%%
+
+pmodule	:  	{
+		  inimport   = 1;
+		  importmod  = install_literal("Prelude");
+		  importas   = 0;
+		  asmod      = NULL;
+		  importqual = 0;
+		  importspec = 0;
+		  importhide = 0;
+		  importlist = Lnil;
+		}
+	   readpreludecore readprelude
+		{
+		  inimport   = 0;
+		  importmod  = NULL;
+
+	  	  modulelineno = 0;
+		}
+	   module
+	;
+
+module	:  modulekey modid maybeexports
+		{
+		  the_module_name = $2;
+		  module_exports = $3;
+		}
+	   WHERE body
+	|	{ 
+		  the_module_name = install_literal("Main");
+		  module_exports = mknothing();
+                }
+	   body
+	;
+
+body	:  ocurly { setstartlineno(); } orestm
+	|  vocurly vrestm
+	;
+
+orestm  :  maybeimpdecls maybefixes topdecls ccurly
+	       {
+		 root = mkhmodule(the_module_name,lconc(prelude_imports,$1),module_exports,$2,$3,modulelineno);
+	       }
+	|  impdecls ccurly
+	       {
+		 root = mkhmodule(the_module_name,lconc(prelude_imports,$1),module_exports,Lnil,mknullbind(),modulelineno);
+	       }
+
+vrestm  :  maybeimpdecls maybefixes topdecls vccurly
+	       {
+		 root = mkhmodule(the_module_name,lconc(prelude_imports,$1),module_exports,$2,$3,modulelineno);
+	       }
+	|  impdecls vccurly
+	       {
+		 root = mkhmodule(the_module_name,lconc(prelude_imports,$1),module_exports,Lnil,mknullbind(),modulelineno);
+	       }
+
+
+maybeexports :	/* empty */			{ $$ = mknothing(); }
+	|  OPAREN export_list CPAREN		{ $$ = mkjust($2); }
+	|  OPAREN export_list COMMA CPAREN	{ $$ = mkjust($2); }
+	;
+
+export_list:
+	   export				{ $$ = lsing($1); }
+  	|  export_list COMMA export		{ $$ = lapp($1, $3); }
+	;
+
+export	:  qvar					{ $$ = mkentid($1); }
+	|  gtycon				{ $$ = mkenttype($1); }
+	|  gtycon OPAREN DOTDOT CPAREN		{ $$ = mkenttypeall($1); }
+	|  gtycon OPAREN CPAREN		        { $$ = mkenttypenamed($1,Lnil); }
+	|  gtycon OPAREN enames CPAREN		{ $$ = mkenttypenamed($1,$3); }
+	|  MODULE modid				{ $$ = mkentmod($2); }
+	;
+
+enames  :  ename				{ $$ = lsing($1); }
+	|  enames COMMA ename			{ $$ = lapp($1,$3); }
+	;
+ename   :  qvar
+	|  qcon
+	;
+
+
+maybeimpdecls : /* empty */			{ $$ = Lnil; }
+	|  impdecls SEMI			{ $$ = $1; }
+	;
+
+impdecls:  impdecl				{ $$ = $1; }
+	|  impdecls SEMI impdecl		{ $$ = lconc($1,$3); }
+	;
+
+
+impdecl	:  importkey
+		{ 
+		  inimport = 1;
+		  importlineno = startlineno;
+		}
+	   impqual impmod dointerface impas maybeimpspec
+		{ 
+		  $$ = lsing(mkimport(iface_name,xstrdup(iface_filename),$5,
+				      $4,$3,$6,$7,importlineno));
+		  inimport   = 0;
+		  importmod  = NULL;	
+		  importas   = 0;
+		  asmod      = NULL;
+		  importqual = 0;
+		  importspec = 0;
+		  importhide = 0;
+		  importlist = Lnil;
+	        }
+	;
+
+impmod  : modid					{ $$ = importmod = $1; }
+	;
+
+impqual :  /* noqual */				{ $$ = importqual = 0; }
+	|  QUALIFIED 				{ $$ = importqual = 1; }
+	;
+
+impas   :  /* noas */				{ $$ = mknothing(); importas = 0; asmod = NULL; }
+	|  AS modid				{ $$ = mkjust($2);  importas = 1; asmod = $2;   }
+	;
+
+maybeimpspec :	/* empty */			{ $$ = mknothing(); importspec = 0; }
+	|  impspec				{ $$ = mkjust($1);  importspec = 1; }
+	;
+
+impspec	:  OPAREN CPAREN			  { $$ = mkleft(Lnil); importhide = 0; importlist = Lnil; }
+	|  OPAREN import_list CPAREN		  { $$ = mkleft($2);   importhide = 0; importlist = $2; }
+	|  OPAREN import_list COMMA CPAREN	  { $$ = mkleft($2);   importhide = 0; importlist = $2; }
+	|  HIDING OPAREN import_list CPAREN	  { $$ = mkright($3);  importhide = 1; importlist = $3; }
+	|  HIDING OPAREN import_list COMMA CPAREN { $$ = mkright($3);  importhide = 1; importlist = $3; }
+  	;
+
+import_list:
+	   import				{ $$ = lsing($1); }
+	|  import_list COMMA import		{ $$ = lapp($1, $3); }
+	;
+
+import	:  var					{ $$ = mkentid(mknoqual($1)); }
+	|  tycon				{ $$ = mkenttype(mknoqual($1)); }
+	|  tycon OPAREN DOTDOT CPAREN		{ $$ = mkenttypeall(mknoqual($1)); }
+	|  tycon OPAREN CPAREN			{ $$ = mkenttypenamed(mknoqual($1),Lnil); }
+	|  tycon OPAREN inames CPAREN		{ $$ = mkenttypenamed(mknoqual($1),$3); }
+	;
+
+inames  :  iname				{ $$ = lsing($1); }
+	|  inames COMMA iname			{ $$ = lapp($1,$3); }
+	;
+iname   :  var					{ $$ = mknoqual($1); }
+	|  con					{ $$ = mknoqual($1); }
+	;
+
+
+/**********************************************************************
+*                                                                     *
+*                                                                     *
+*      Reading interface files					      *
+*                                                                     *
+*                                                                     *
+**********************************************************************/
+
+dointerface :	{ /* filename returned in "iface_filename" */
+		  char *module_name = id_to_string(importmod);
+		  if ( ! etags ) {
+		      find_module_on_imports_dirlist(
+			(haskell1_2Flag && strcmp(module_name, "Prelude") == 0)
+			    ? "Prel12" : module_name,
+			FALSE, iface_filename);
+		  } else {
+		     find_module_on_imports_dirlist("PreludeNull_",TRUE,iface_filename);
+		  }
+		  if (strcmp(module_name,"PreludeCore")==0) {
+			    hsperror("Cannot explicitly import `PreludeCore'");
+
+		  } else if (strcmp(module_name,"Prelude")==0) {
+		    prelude_imports = prelude_core_import; /* unavoidable */
+		  }
+		  thisIfacePragmaVersion = 0;
+		  setyyin(iface_filename);
+		}
+	readinterface
+		{ $$ = $2; }
+	;
+
+readpreludecore:{
+		  if ( implicitPrelude && !etags ) {
+		     /* we try to avoid reading interfaces when etagging */
+		     find_module_on_imports_dirlist(
+			(haskell1_2Flag) ? "PrelCore12" : "PreludeCore",
+			TRUE,iface_filename);
+		  } else {
+		     find_module_on_imports_dirlist("PreludeNull_",TRUE,iface_filename);
+		  }
+		  thisIfacePragmaVersion = 0;
+		  setyyin(iface_filename);
+		}
+	   readinterface
+		{
+		  binding prelude_core = mkimport(iface_name,xstrdup(iface_filename),$2,
+				                  install_literal("PreludeCore"),
+						  0,mknothing(),mknothing(),0);
+		  prelude_core_import = (! implicitPrelude) ? Lnil : lsing(prelude_core);
+		}
+	;
+
+readprelude :   {
+		  if ( implicitPrelude && !etags ) {
+		     find_module_on_imports_dirlist(
+			( haskell1_2Flag ) ? "Prel12" : "Prelude",
+			TRUE,iface_filename);
+		  } else {
+		     find_module_on_imports_dirlist("PreludeNull_",TRUE,iface_filename);
+		  }
+		  thisIfacePragmaVersion = 0;
+		  setyyin(iface_filename);
+		}
+	   readinterface
+		{
+		  binding prelude = mkimport(iface_name,xstrdup(iface_filename),$2,
+				             install_literal("Prelude"),
+					     0,mknothing(),mknothing(),0);
+		  prelude_imports = (! implicitPrelude) ? Lnil
+					: lconc(prelude_core_import,lsing(prelude));
+		}
+	;
+
+readinterface:
+	   interface LEOF
+		{
+		  $$ = $1;
+		}
+	;
+
+interface:
+  	   INTERFACE modid
+		{ 
+		  iface_name = $2;
+		}
+	   WHERE ibody
+		{
+		  $$ = $5;
+		}
+	;
+
+ibody	:  ocurly maybeiimports maybeifixes itopdecls ccurly
+		{
+		  $$ = mkabind($2,mkabind($3,$4));
+		}
+	|  ocurly iimports ccurly
+		{
+		  $$ = $2;
+		}
+	|  vocurly maybeiimports maybeifixes itopdecls vccurly
+		{
+		  $$ = mkabind($2,mkabind($3,$4));
+		}
+	|  vocurly iimports vccurly
+		{
+		  $$ = $2;
+		}
+  	;
+
+maybeifixes:  /* empty */			{ $$ = mknullbind(); }
+	|  fixes SEMI				{ $$ = mkmfbind($1); }
+	;
+
+maybeiimports : /* empty */			{ $$ = mknullbind(); }
+	|  iimports SEMI			{ $$ = $1; }
+	;
+
+iimports : iimport				{ $$ = $1; }
+	 | iimports SEMI iimport		{ $$ = mkabind($1,$3); }
+	 ;
+
+iimport :  importkey modid OPAREN import_list CPAREN
+		{ $$ = mkmbind($2,$4,startlineno); }
+	;
+
+
+itopdecls : itopdecl				{ $$ = $1; }
+	| itopdecls SEMI itopdecl		{ $$ = mkabind($1,$3); }
+  	;
+
+itopdecl:  ityped	 			{ $$ = $1; }
+	|  idatad 				{ $$ = $1; }
+	|  inewtd 				{ $$ = $1; }
+	|  iclassd 				{ $$ = $1; }
+	|  iinstd 				{ $$ = $1; }
+	|  ivarsd				{ $$ = $1; }
+	|  /* empty */				{ $$ = mknullbind(); }
+	;
+
+ivarsd	:  qvarsk DCOLON ctype ival_pragma
+		{ $$ = mksbind($1,$3,startlineno,$4); }
+	;
+
+ityped	:  typekey simple EQUAL type
+		{ $$ = mknbind($2,$4,startlineno); }
+	;
+
+idatad	:  datakey simple idata_pragma
+		{ $$ = mktbind(Lnil,$2,Lnil,mknothing(),startlineno,$3); }
+	|  datakey simple EQUAL constrs idata_pragma
+		{ $$ = mktbind(Lnil,$2,$4,mknothing(),startlineno,$5); }
+	|  datakey context DARROW simple idata_pragma
+		{ $$ = mktbind($2,$4,Lnil,mknothing(),startlineno,$5); }
+	|  datakey context DARROW simple EQUAL constrs idata_pragma
+		{ $$ = mktbind($2,$4,$6,mknothing(),startlineno,$7); }
+	;
+
+inewtd	:  newtypekey simple inewt_pragma
+		{ $$ = mkntbind(Lnil,$2,Lnil,mknothing(),startlineno,$3); }
+	|  newtypekey simple EQUAL constr1 inewt_pragma
+		{ $$ = mkntbind(Lnil,$2,$4,mknothing(),startlineno,$5); }
+	|  newtypekey context DARROW simple inewt_pragma
+		{ $$ = mkntbind($2,$4,Lnil,mknothing(),startlineno,$5); }
+	|  newtypekey context DARROW simple EQUAL constr1 inewt_pragma
+		{ $$ = mkntbind($2,$4,$6,mknothing(),startlineno,$7); }
+	;
+
+iclassd	:  classkey context DARROW class iclas_pragma cbody
+		{ $$ = mkcbind($2,$4,$6,startlineno,$5); }
+	|  classkey class iclas_pragma cbody
+		{ $$ = mkcbind(Lnil,$2,$4,startlineno,$3); }
+	;
+
+iinstd	:  instkey modid context DARROW gtycon general_inst iinst_pragma
+		{ $$ = mkibind(0/*not source*/,$2,$3,$5,$6,mknullbind(),startlineno,$7); }
+	|  instkey modid gtycon general_inst iinst_pragma
+		{ $$ = mkibind(0/*not source*/,$2,Lnil,$3,$4,mknullbind(),startlineno,$5); }
+	;
+
+
+/**********************************************************************
+*                                                                     *
+*                                                                     *
+*     Interface pragma stuff					      *
+*                                                                     *
+*                                                                     *
+**********************************************************************/
+
+idata_pragma:
+	   GHC_PRAGMA constrs idata_pragma_specs END_PRAGMA
+						{ $$ = mkidata_pragma($2, $3); }
+	|  GHC_PRAGMA idata_pragma_specs END_PRAGMA
+						{ $$ = mkidata_pragma(Lnil, $2); }
+	|  /* empty */			    	{ $$ = mkno_pragma(); }
+	;
+
+inewt_pragma:
+	   GHC_PRAGMA constr1 idata_pragma_specs END_PRAGMA
+						{ $$ = mkidata_pragma($2, $3); }
+	|  GHC_PRAGMA idata_pragma_specs END_PRAGMA
+						{ $$ = mkidata_pragma(Lnil, $2); }
+	|  /* empty */			    	{ $$ = mkno_pragma(); }
+	;
+
+idata_pragma_specs : 
+	   SPECIALISE_PRAGMA idata_pragma_specslist
+						{ $$ = $2; }
+	|  /* empty */			    	{ $$ = Lnil; }
+	;
+
+idata_pragma_specslist:
+	   idata_pragma_spectypes		{ $$ = lsing($1); }
+	|  idata_pragma_specslist COMMA idata_pragma_spectypes
+						{ $$ = lapp($1, $3); }
+	;
+
+idata_pragma_spectypes:
+	   OBRACK type_maybes CBRACK		{ $$ = mkidata_pragma_4s($2); }
+	;
+
+iclas_pragma:
+	   GHC_PRAGMA gen_pragma_list END_PRAGMA { $$ = mkiclas_pragma($2); }
+	|  /* empty */				 { $$ = mkno_pragma(); }
+	;
+
+iclasop_pragma:
+	   GHC_PRAGMA gen_pragma gen_pragma END_PRAGMA
+		{ $$ = mkiclasop_pragma($2, $3); }
+	|  /* empty */
+		{ $$ = mkno_pragma(); }
+	;
+
+iinst_pragma:
+	   GHC_PRAGMA gen_pragma END_PRAGMA
+		{ $$ = mkiinst_simpl_pragma($2); }
+
+	|  GHC_PRAGMA gen_pragma name_pragma_pairs END_PRAGMA
+		{ $$ = mkiinst_const_pragma($2, $3); }
+
+	|  /* empty */
+		{ $$ = mkno_pragma(); }
+	;
+
+ival_pragma:
+	   GHC_PRAGMA gen_pragma END_PRAGMA
+		{ $$ = $2; }
+	|  /* empty */
+		{ $$ = mkno_pragma(); }
+	;
+
+gen_pragma:
+	   NOINFO_PRAGMA
+		{ $$ = mkno_pragma(); }
+	|  arity_pragma update_pragma deforest_pragma strictness_pragma unfolding_pragma type_pragma_pairs_maybe
+		{ $$ = mkigen_pragma($1, $2, $3, $4, $5, $6); }
+	;
+
+arity_pragma:
+	   NO_PRAGMA		    { $$ = mkno_pragma(); }
+	|  ARITY_PRAGMA INTEGER	    { $$ = mkiarity_pragma($2); }
+	;
+
+update_pragma:
+	   NO_PRAGMA		    { $$ = mkno_pragma(); }
+	|  UPDATE_PRAGMA INTEGER    { $$ = mkiupdate_pragma($2); }
+	;
+
+deforest_pragma:
+           NO_PRAGMA                { $$ = mkno_pragma(); }
+        |  DEFOREST_PRAGMA          { $$ = mkideforest_pragma(); }
+        ;
+
+strictness_pragma:
+	   NO_PRAGMA		    { $$ = mkno_pragma(); }
+	|  STRICTNESS_PRAGMA COCON  { $$ = mkistrictness_pragma(installHstring(1, "B"),
+				      /* _!_ = COCON = bottom */ mkno_pragma());
+				    }
+	|  STRICTNESS_PRAGMA STRING worker_info
+				    { $$ = mkistrictness_pragma($2, $3); }
+	;
+
+worker_info:
+	   OCURLY gen_pragma CCURLY { $$ = $2; }
+	|  /* empty */		    { $$ = mkno_pragma(); }
+
+unfolding_pragma:
+	   NO_PRAGMA		    { $$ = mkno_pragma(); }
+	|  MAGIC_UNFOLDING_PRAGMA vark
+				    { $$ = mkimagic_unfolding_pragma($2); }
+	|  UNFOLDING_PRAGMA unfolding_guidance core_expr
+				    { $$ = mkiunfolding_pragma($2, $3); }
+	;
+
+unfolding_guidance:
+	   UNFOLD_ALWAYS
+				    { $$ = mkiunfold_always(); }
+	|  UNFOLD_IF_ARGS INTEGER INTEGER CONID INTEGER
+				    { $$ = mkiunfold_if_args($2, $3, $4, $5); }
+	;
+
+gen_pragma_list:
+	   gen_pragma				{ $$ = lsing($1); }
+	|  gen_pragma_list COMMA gen_pragma	{ $$ = lapp($1, $3); }
+	;
+
+type_pragma_pairs_maybe:
+	  NO_PRAGMA				{ $$ = Lnil; }
+	| SPECIALISE_PRAGMA type_pragma_pairs	{ $$ = $2; }
+	;
+
+/* 1 S/R conflict at COMMA -> shift */
+type_pragma_pairs:
+	   type_pragma_pair			    { $$ = lsing($1); }
+	|  type_pragma_pairs COMMA type_pragma_pair { $$ = lapp($1, $3); }
+	;
+
+type_pragma_pair:
+	   OBRACK type_maybes CBRACK INTEGER worker_info
+		{ $$ = mkitype_pragma_pr($2, $4, $5); }
+	;
+
+type_maybes:
+	   type_maybe			{ $$ = lsing($1); }
+	|  type_maybes COMMA type_maybe	{ $$ = lapp($1, $3); }
+	;
+
+type_maybe:
+	   NO_PRAGMA			{ $$ = mknothing(); }
+    	|  type				{ $$ = mkjust($1); }
+	;
+
+name_pragma_pairs:
+	   name_pragma_pair			    { $$ = lsing($1); }
+	|  name_pragma_pairs COMMA name_pragma_pair { $$ = lapp($1, $3); }
+	;
+
+name_pragma_pair:
+	   /* if the gen_pragma concludes with a *comma*-separated SPECs list,
+	      we get a parse error --- we have to bracket the gen_pragma
+	   */
+
+	   var EQUAL OCURLY gen_pragma CCURLY
+		{ $$ = mkiname_pragma_pr($1, $4); }
+	;
+
+/**********************************************************************
+*                                                                     *
+*                                                                     *
+*     Core syntax stuff 					      *
+*                                                                     *
+*                                                                     *
+**********************************************************************/
+
+core_expr:
+	   LAMBDA core_binders RARROW core_expr
+			{ $$ = mkcolam($2, $4); }
+	|  TYLAMBDA core_tyvars RARROW core_expr
+			{ $$ = mkcotylam($2, $4); }
+	|  COCON con core_types core_atoms
+			{ $$ = mkcocon(mkco_id($2), $3, $4); }
+	|  COCON CO_ORIG_NM modid con core_types core_atoms
+			{ $$ = mkcocon(mkco_orig_id($3,$4), $5, $6); }
+	|  COPRIM co_primop core_types core_atoms
+			{ $$ = mkcoprim($2, $3, $4); }
+	|  COAPP core_expr core_atoms
+			{ $$ = mkcoapp($2, $3); }
+	|  COTYAPP core_expr OCURLY core_type CCURLY
+			{ $$ = mkcotyapp($2, $4); }
+	|  CASE core_expr OF OCURLY core_case_alts CCURLY
+			{ $$ = mkcocase($2, $5); }
+	|  LET OCURLY core_binder EQUAL core_expr CCURLY IN core_expr
+			{ $$ = mkcolet(mkcononrec($3, $5), $8); }
+	|  CO_LETREC OCURLY corec_binds CCURLY IN core_expr
+			{ $$ = mkcolet(mkcorec($3), $6); }
+	|  SCC OCURLY co_scc CCURLY core_expr
+			{ $$ = mkcoscc($3, $5); }
+	|  lit_constant { $$ = mkcoliteral($1); }
+	|  core_id	{ $$ = mkcovar($1); }
+	;
+
+core_case_alts :
+	   CO_ALG_ALTS  core_alg_alts  core_default
+			{ $$ = mkcoalg_alts($2, $3); }
+	|  CO_PRIM_ALTS core_prim_alts core_default
+			{ $$ = mkcoprim_alts($2, $3); }
+	;
+
+core_alg_alts :
+	   /* empty */			{ $$ = Lnil; }
+	|  core_alg_alts core_alg_alt	{ $$ = lapp($1, $2); }
+	;
+
+core_alg_alt:
+	   core_id core_binders RARROW core_expr SEMI { $$ = mkcoalg_alt($1, $2, $4); }
+	   /* core_id is really too generous */
+	;
+
+core_prim_alts :
+	   /* empty */			{ $$ = Lnil; }
+	|  core_prim_alts core_prim_alt	{ $$ = lapp($1, $2); }
+	;
+
+core_prim_alt:
+	   lit_constant RARROW core_expr SEMI { $$ = mkcoprim_alt($1, $3); }
+	;
+
+core_default:
+	   CO_NO_DEFAULT		{ $$ = mkconodeflt(); }
+	|  core_binder RARROW core_expr	{ $$ = mkcobinddeflt($1, $3); }
+	;
+
+corec_binds:
+	   corec_bind			{ $$ = lsing($1); }
+	|  corec_binds SEMI corec_bind	{ $$ = lapp($1, $3); }
+	;
+
+corec_bind:
+	   core_binder EQUAL core_expr	{ $$ = mkcorec_pair($1, $3); }
+	;
+
+co_scc	:
+	   CO_PRELUDE_DICTS_CC co_dupd		 { $$ = mkco_preludedictscc($2); }
+	|  CO_ALL_DICTS_CC STRING STRING co_dupd { $$ = mkco_alldictscc($2,$3,$4); }
+	|  CO_USER_CC STRING  STRING STRING co_dupd co_caf
+						{ $$ = mkco_usercc($2,$3,$4,$5,$6); }
+	|  CO_AUTO_CC core_id STRING STRING co_dupd co_caf
+						{ $$ = mkco_autocc($2,$3,$4,$5,$6); }
+	|  CO_DICT_CC core_id STRING STRING co_dupd co_caf
+						{ $$ = mkco_dictcc($2,$3,$4,$5,$6); }
+
+co_caf	:  NO_PRAGMA	{ $$ = mkco_scc_noncaf(); }
+	|  CO_CAF_CC	{ $$ = mkco_scc_caf(); }
+
+co_dupd	:  NO_PRAGMA	{ $$ = mkco_scc_nondupd(); }
+	|  CO_DUPD_CC	{ $$ = mkco_scc_dupd(); }
+
+core_id: /* more to come?? */
+	   CO_SDSEL_ID  tycon tycon	{ $$ = mkco_sdselid($2, $3); }
+	|  CO_METH_ID   tycon var	{ $$ = mkco_classopid($2, $3); }
+	|  CO_DEFM_ID   tycon var	{ $$ = mkco_defmid($2, $3); }
+	|  CO_DFUN_ID   tycon OPAREN core_type CPAREN
+					{ $$ = mkco_dfunid($2, $4); }
+	|  CO_CONSTM_ID tycon var OPAREN core_type CPAREN
+					{ $$ = mkco_constmid($2, $3, $5); }
+	|  CO_SPEC_ID	core_id OBRACK core_type_maybes CBRACK
+					{ $$ = mkco_specid($2, $4); }
+	|  CO_WRKR_ID	core_id		{ $$ = mkco_wrkrid($2); }
+	|  CO_ORIG_NM   modid var	{ $$ = mkco_orig_id($2, $3); }
+	|  CO_ORIG_NM   modid con	{ $$ = mkco_orig_id($2, $3); }
+	|  var				{ $$ = mkco_id($1); }
+	|  con				{ $$ = mkco_id($1); }
+	;
+
+co_primop :
+	   OPAREN CCALL ccallid	     OCURLY core_types core_type CCURLY CPAREN
+					{ $$ = mkco_ccall($3,0,$5,$6); }
+	|  OPAREN CCALL_GC ccallid   OCURLY core_types core_type CCURLY CPAREN
+					{ $$ = mkco_ccall($3,1,$5,$6); }
+	|  OPAREN CASM  lit_constant OCURLY core_types core_type CCURLY CPAREN
+					{ $$ = mkco_casm($3,0,$5,$6); }
+	|  OPAREN CASM_GC lit_constant OCURLY core_types core_type CCURLY CPAREN
+					{ $$ = mkco_casm($3,1,$5,$6); }
+	|  VARID			{ $$ = mkco_primop($1); }
+	;
+
+core_binders :
+	   /* empty */			{ $$ = Lnil; }
+	|  core_binders core_binder	{ $$ = lapp($1, $2); }
+	;
+
+core_binder :
+	   OPAREN VARID DCOLON core_type CPAREN	{ $$ = mkcobinder($2, $4); }
+
+core_atoms :
+	   OBRACK CBRACK		{ $$ = Lnil; }
+	|  OBRACK core_atom_list CBRACK	{ $$ = $2; }
+	;
+
+core_atom_list :
+	   core_atom			    { $$ = lsing($1); }
+	|  core_atom_list COMMA core_atom   { $$ = lapp($1, $3); }
+	;
+
+core_atom :
+	   lit_constant		{ $$ = mkcolit($1); }
+	|  core_id		{ $$ = mkcolocal($1); }
+	;
+
+core_tyvars :
+	   VARID		{ $$ = lsing($1); }
+	|  core_tyvars VARID  	{ $$ = lapp($1, $2); }
+	;
+
+core_tv_templates :
+	   TYVAR_TEMPLATE_ID				{ $$ = lsing($1); }
+	|  core_tv_templates COMMA TYVAR_TEMPLATE_ID 	{ $$ = lapp($1, $3); }
+	;
+
+core_types :
+	   OBRACK CBRACK		{ $$ = Lnil; }
+	|  OBRACK core_type_list CBRACK	{ $$ = $2; }
+	;
+
+core_type_list :
+	   core_type			    { $$ = lsing($1); }
+	|  core_type_list COMMA core_type   { $$ = lapp($1, $3); }
+	;
+
+core_type :
+	   type { $$ = $1; }
+	;
+
+/*
+core_type :
+	   FORALL core_tv_templates DARROW core_type
+		{ $$ = mkuniforall($2, $4); }
+	|  OCURLY OCURLY CONID core_type CCURLY CCURLY RARROW core_type
+		{ $$ = mktfun(mkunidict($3, $4), $8); }
+	|  OCURLY OCURLY CONID core_type CCURLY CCURLY
+		{ $$ = mkunidict($3, $4); }
+	|  OPAREN OCURLY OCURLY CONID core_type CCURLY CCURLY COMMA core_type_list CPAREN RARROW core_type
+		{ $$ = mktfun(mkttuple(mklcons(mkunidict($4, $5), $9)), $12); }
+	|  OPAREN OCURLY OCURLY CONID core_type CCURLY CCURLY COMMA core_type_list CPAREN
+		{ $$ = mkttuple(mklcons(mkunidict($4,$5), $9)); }
+	|  type { $$ = $1; }
+	;
+*/
+
+core_type_maybes:
+	   core_type_maybe			    { $$ = lsing($1); }
+	|  core_type_maybes COMMA core_type_maybe   { $$ = lapp($1, $3); }
+	;
+
+core_type_maybe:
+	   NO_PRAGMA			{ $$ = mknothing(); }
+    	|  core_type			{ $$ = mkjust($1); }
+	;
+
+
+/**********************************************************************
+*                                                                     *
+*                                                                     *
+*     Fixes and Decls etc 					      *
+*                                                                     *
+*                                                                     *
+**********************************************************************/
+
+maybefixes:  /* empty */		{ $$ = Lnil; }
+	|  fixes SEMI			{ $$ = $1; }
+	;
+
+fixes	:  fix				{ $$ = $1; }
+	|  fixes SEMI fix		{ $$ = lconc($1,$3); }
+	;
+
+fix	:  INFIXL INTEGER	{ Precedence = checkfixity($2); Fixity = INFIXL; }
+	   ops  		{ $$ = $4; }
+	|  INFIXR INTEGER	{ Precedence = checkfixity($2); Fixity = INFIXR; }
+	   ops  		{ $$ = $4; }
+	|  INFIX  INTEGER	{ Precedence = checkfixity($2); Fixity = INFIX; }
+	   ops  		{ $$ = $4; }
+	|  INFIXL		{ Fixity = INFIXL; Precedence = 9; }
+	   ops  		{ $$ = $3; }
+	|  INFIXR		{ Fixity = INFIXR; Precedence = 9; }
+	   ops  		{ $$ = $3; }
+	|  INFIX		{ Fixity = INFIX; Precedence = 9; }
+	   ops  		{ $$ = $3; }
+	;
+
+ops	:  op		 { makeinfix($1,Fixity,Precedence,the_module_name,
+				     inimport,importas,importmod,asmod,importqual,
+				     importspec,importhide,importlist);
+			   $$ = lsing(mkfixop($1,infixint(Fixity),Precedence));
+			 }
+	|  ops COMMA op  { makeinfix($3,Fixity,Precedence,the_module_name,
+				     inimport,importas,importmod,asmod,importqual,
+				     importspec,importhide,importlist);
+			   $$ = lapp($1,mkfixop($3,infixint(Fixity),Precedence));
+			 }
+	;
+
+topdecls:  topdecl
+	|  topdecls SEMI topdecl
+		{
+		  if($1 != NULL)
+		    if($3 != NULL)
+		      if(SAMEFN)
+			{
+			  extendfn($1,$3);
+			  $$ = $1;
+			}
+		      else
+			$$ = mkabind($1,$3);
+		    else
+		      $$ = $1;
+		  else
+		    $$ = $3;
+		  SAMEFN = 0;
+		}
+	;
+
+topdecl	:  typed				{ $$ = $1; }
+	|  datad 				{ $$ = $1; }
+	|  newtd				{ $$ = $1; }
+	|  classd 				{ $$ = $1; }
+	|  instd 				{ $$ = $1; }
+	|  defaultd 				{ $$ = $1; }
+	|  decl 				{ $$ = $1; }
+	;
+
+typed	:  typekey simple EQUAL type		{ $$ = mknbind($2,$4,startlineno); }
+	;
+
+
+datad	:  datakey simple EQUAL constrs
+		{ $$ = mktbind(Lnil,$2,$4,mknothing(),startlineno,mkno_pragma()); }
+	|  datakey simple EQUAL constrs DERIVING dtyclses
+		{ $$ = mktbind(Lnil,$2,$4,mkjust($6),startlineno,mkno_pragma()); }
+	|  datakey context DARROW simple EQUAL constrs
+		{ $$ = mktbind($2,$4,$6,mknothing(),startlineno,mkno_pragma()); }
+	|  datakey context DARROW simple EQUAL constrs DERIVING dtyclses
+		{ $$ = mktbind($2,$4,$6,mkjust($8),startlineno,mkno_pragma()); }
+	;
+
+newtd	:  newtypekey simple EQUAL constr1
+		{ $$ = mkntbind(Lnil,$2,$4,mknothing(),startlineno,mkno_pragma()); }
+	|  newtypekey simple EQUAL constr1 DERIVING dtyclses
+		{ $$ = mkntbind(Lnil,$2,$4,mkjust($6),startlineno,mkno_pragma()); }
+	|  newtypekey context DARROW simple EQUAL constr1
+		{ $$ = mkntbind($2,$4,$6,mknothing(),startlineno,mkno_pragma()); }
+	|  newtypekey context DARROW simple EQUAL constr1 DERIVING dtyclses
+		{ $$ = mkntbind($2,$4,$6,mkjust($8),startlineno,mkno_pragma()); }
+	;
+
+classd	:  classkey context DARROW class cbody	{ $$ = mkcbind($2,$4,$5,startlineno,mkno_pragma()); }
+	|  classkey class cbody		 	{ $$ = mkcbind(Lnil,$2,$3,startlineno,mkno_pragma()); }
+	;
+
+cbody	:  /* empty */				{ $$ = mknullbind(); }
+	|  WHERE ocurly decls ccurly		{ checkorder($3); $$ = $3; }
+	|  WHERE vocurly decls vccurly		{ checkorder($3); $$ = $3; }
+	;
+
+instd	:  instkey context DARROW gtycon restrict_inst rinst
+		{ $$ = mkibind(1/*source*/,the_module_name,$2,$4,$5,$6,startlineno,mkno_pragma()); }
+	|  instkey gtycon general_inst rinst
+	 	{ $$ = mkibind(1/*source*/,the_module_name,Lnil,$2,$3,$4,startlineno,mkno_pragma()); }
+	;
+
+rinst	:  /* empty */			  	{ $$ = mknullbind(); }
+	|  WHERE ocurly  instdefs ccurly  	{ $$ = $3; }
+	|  WHERE vocurly instdefs vccurly 	{ $$ = $3; }
+	;
+
+restrict_inst : gtycon				{ $$ = mktname($1); }
+	|  OPAREN gtyconvars CPAREN		{ $$ = $2; }
+	|  OPAREN tyvar COMMA tyvar_list CPAREN	{ $$ = mkttuple(mklcons($2,$4)); }
+	|  OBRACK tyvar CBRACK			{ $$ = mktllist($2); }
+	|  OPAREN tyvar RARROW tyvar CPAREN	{ $$ = mktfun($2,$4); }
+	;
+
+general_inst : gtycon				{ $$ = mktname($1); }
+	|  OPAREN gtyconapp CPAREN		{ $$ = $2; }
+	|  OPAREN type COMMA types CPAREN	{ $$ = mkttuple(mklcons($2,$4)); }
+	|  OBRACK type CBRACK			{ $$ = mktllist($2); }
+	|  OPAREN btype RARROW type CPAREN	{ $$ = mktfun($2,$4); }
+	;
+
+defaultd:  defaultkey OPAREN types CPAREN       { $$ = mkdbind($3,startlineno); }
+	|  defaultkey OPAREN CPAREN		{ $$ = mkdbind(Lnil,startlineno); }
+	;
+
+decls	:  decl
+	|  decls SEMI decl
+		{
+		  if(SAMEFN)
+		    {
+		      extendfn($1,$3);
+		      $$ = $1;
+		    }
+		  else
+		    $$ = mkabind($1,$3);
+		}
+	;
+
+
+/*
+    Note: if there is an iclasop_pragma here, then we must be
+    doing a class-op in an interface -- unless the user is up
+    to real mischief (ugly, but likely to work).
+*/
+
+decl	:  qvarsk DCOLON ctype iclasop_pragma
+		{ $$ = mksbind($1,$3,startlineno,$4);
+		  PREVPATT = NULL; FN = NULL; SAMEFN = 0;
+		}
+	/* User-specified pragmas come in as "signatures"...
+	   They are similar in that they can appear anywhere in the module,
+	   and have to be "joined up" with their related entity.
+
+	   Have left out the case specialising to an overloaded type.
+	   Let's get real, OK?  (WDP)
+	*/
+	|  SPECIALISE_UPRAGMA qvark DCOLON types_and_maybe_ids END_UPRAGMA
+		{
+		  $$ = mkvspec_uprag($2, $4, startlineno);
+		  PREVPATT = NULL; FN = NULL; SAMEFN = 0;
+		}
+
+	|  SPECIALISE_UPRAGMA INSTANCE gtycon general_inst END_UPRAGMA
+		{
+		  $$ = mkispec_uprag($3, $4, startlineno);
+		  PREVPATT = NULL; FN = NULL; SAMEFN = 0;
+		}
+
+	|  SPECIALISE_UPRAGMA DATA gtycon atypes END_UPRAGMA
+		{
+		  $$ = mkdspec_uprag($3, $4, startlineno);
+		  PREVPATT = NULL; FN = NULL; SAMEFN = 0;
+		}
+
+	|  INLINE_UPRAGMA qvark END_UPRAGMA
+		{
+		  $$ = mkinline_uprag($2, startlineno);
+		  PREVPATT = NULL; FN = NULL; SAMEFN = 0;
+		}
+
+	|  MAGIC_UNFOLDING_UPRAGMA qvark vark END_UPRAGMA
+		{
+		  $$ = mkmagicuf_uprag($2, $3, startlineno);
+		  PREVPATT = NULL; FN = NULL; SAMEFN = 0;
+		}
+
+        |  DEFOREST_UPRAGMA qvark END_UPRAGMA
+                {
+		  $$ = mkdeforest_uprag($2, startlineno);
+ 		  PREVPATT = NULL; FN = NULL; SAMEFN = 0;
+		}
+
+	/* end of user-specified pragmas */
+
+	|  valdef
+	|  /* empty */ { $$ = mknullbind(); PREVPATT = NULL; FN = NULL; SAMEFN = 0; }
+  	;
+
+qvarsk	:  qvark COMMA qvars_list		{ $$ = mklcons($1,$3); }
+	|  qvark				{ $$ = lsing($1); }
+	;
+
+qvars_list: qvar				{ $$ = lsing($1); }
+	|   qvars_list COMMA qvar		{ $$ = lapp($1,$3); }
+	;
+
+types_and_maybe_ids :
+	   type_and_maybe_id				{ $$ = lsing($1); }
+	|  types_and_maybe_ids COMMA type_and_maybe_id	{ $$ = lapp($1,$3); }
+	;
+
+type_and_maybe_id :
+	   type					{ $$ = mkvspec_ty_and_id($1,mknothing()); }
+	|  type EQUAL qvark			{ $$ = mkvspec_ty_and_id($1,mkjust($3)); }
+
+
+/**********************************************************************
+*                                                                     *
+*                                                                     *
+*     Types etc     	 					      *
+*                                                                     *
+*                                                                     *
+**********************************************************************/
+
+/*  "DCOLON context => type" vs "DCOLON type" is a problem,
+    because you can't distinguish between
+
+	foo :: (Baz a, Baz a)
+	bar :: (Baz a, Baz a) => [a] -> [a] -> [a]
+
+    with one token of lookahead.  The HACK is to have "DCOLON ttype"
+    [tuple type] in the first case, then check that it has the right
+    form C a, or (C1 a, C2 b, ... Cn z) and convert it into a
+    context.  Blaach!
+*/
+
+	/* 1 S/R conflict at DARROW -> shift */
+ctype   : type DARROW type			{ $$ = mkcontext(type2context($1),$3); }
+	| type
+	;
+
+	/* 1 S/R conflict at RARROW -> shift */
+type	:  btype				{ $$ = $1; }
+	|  btype RARROW type			{ $$ = mktfun($1,$3); }
+
+	|  FORALL core_tv_templates DARROW type { $$ = mkuniforall($2, $4); }
+	;
+
+/* btype is split so we can parse gtyconapp without S/R conflicts */
+btype	:  gtyconapp				{ $$ = $1; }
+	|  ntyconapp				{ $$ = $1; }
+	;
+
+ntyconapp: ntycon				{ $$ = $1; }
+	|  ntyconapp atype			{ $$ = mktapp($1,$2); }
+	;
+
+gtyconapp: gtycon				{ $$ = mktname($1); }
+	|  gtyconapp atype			{ $$ = mktapp($1,$2); }
+	;
+
+
+atype  	:  gtycon				{ $$ = mktname($1); }
+	|  ntycon				{ $$ = $1; }
+	;
+
+ntycon	:  tyvar				{ $$ = $1; }
+	|  OPAREN type COMMA types CPAREN	{ $$ = mkttuple(mklcons($2,$4)); }
+	|  OBRACK type CBRACK			{ $$ = mktllist($2); }
+	|  OPAREN type CPAREN			{ $$ = $2; }
+
+	|  OCURLY OCURLY gtycon type CCURLY CCURLY { $$ = mkunidict($3, $4); }
+	|  TYVAR_TEMPLATE_ID			{ $$ = mkunityvartemplate($1); }
+	;
+
+gtycon	:  qtycon
+	|  OPAREN RARROW CPAREN			{ $$ = creategid(-2); }
+	|  OBRACK CBRACK			{ $$ = creategid(-1); }         
+	|  OPAREN CPAREN			{ $$ = creategid(0); }         
+	|  OPAREN commas CPAREN 		{ $$ = creategid($2); }
+	;
+
+atypes	:  atype				{ $$ = lsing($1); }
+	|  atypes atype				{ $$ = lapp($1,$2); }
+	;
+
+types	:  type					{ $$ = lsing($1); }
+	|  types COMMA type			{ $$ = lapp($1,$3); }
+	;
+
+commas	: COMMA					{ $$ = 1; }
+	| commas COMMA				{ $$ = $1 + 1; }
+	;
+
+/**********************************************************************
+*                                                                     *
+*                                                                     *
+*     Declaration stuff 					      *
+*                                                                     *
+*                                                                     *
+**********************************************************************/
+
+simple	:  gtycon				{ $$ = mktname($1); }
+	|  gtyconvars	  			{ $$ = $1; }
+	;
+
+gtyconvars: gtycon tyvar			{ $$ = mktapp(mktname($1),$2); }
+	|  gtyconvars tyvar			{ $$ = mktapp($1,$2); }
+	;
+
+context	:  OPAREN context_list CPAREN		{ $$ = $2; }
+	|  class				{ $$ = lsing($1); }
+	;
+
+context_list:  class				{ $$ = lsing($1); }
+	|  context_list COMMA class	 	{ $$ = lapp($1,$3); }
+	;
+
+class	:  gtycon tyvar 			{ $$ = mktapp(mktname($1),$2); }
+	;
+
+constrs	:  constr				{ $$ = lsing($1); }
+	|  constrs VBAR constr			{ $$ = lapp($1,$3); }
+	;
+
+constr	:  btyconapp				{ qid tyc; list tys;
+						  splittyconapp($1, &tyc, &tys);
+					          $$ = mkconstrpre(tyc,tys,hsplineno); }
+	|  OPAREN qconsym CPAREN		{ $$ = mkconstrpre($2,Lnil,hsplineno); }
+	|  OPAREN qconsym CPAREN batypes	{ $$ = mkconstrpre($2,$4,hsplineno); }
+	|  btyconapp qconop bbtype		{ checknobangs($1);
+						  $$ = mkconstrinf($1,$2,$3,hsplineno); }
+	|  ntyconapp qconop bbtype		{ $$ = mkconstrinf($1,$2,$3,hsplineno); }
+	|  BANG atype qconop bbtype		{ $$ = mkconstrinf(mktbang($2),$3,$4,hsplineno); }
+
+	/* 1 S/R conflict on OCURLY -> shift */
+	|  gtycon OCURLY fields CCURLY		{ $$ = mkconstrrec($1,$3,hsplineno); }
+	;
+
+btyconapp: gtycon				{ $$ = mktname($1); }
+	|  btyconapp batype			{ $$ = mktapp($1,$2); }
+	;
+
+bbtype	:  btype				{ $$ = $1; }
+	|  BANG atype				{ $$ = mktbang($2); }
+	;
+
+batype	:  atype				{ $$ = $1; }
+	|  BANG atype				{ $$ = mktbang($2); }
+	;
+
+batypes	:  batype				{ $$ = lsing($1); }
+	|  batypes batype			{ $$ = lapp($1,$2); }
+	;
+
+
+fields	: field					{ $$ = lsing($1); }
+	| fields COMMA field			{ $$ = lapp($1,$3); }
+	;
+
+field	:  qvars_list DCOLON type		{ $$ = mkfield($1,$3); }
+	|  qvars_list DCOLON BANG atype		{ $$ = mkfield($1,mktbang($4)); }
+	; 
+
+constr1 :  gtycon atype				{ $$ = lsing(mkconstrnew($1,$2,hsplineno)); }
+	;
+
+
+dtyclses:  OPAREN dtycls_list CPAREN		{ $$ = $2; }
+	|  OPAREN CPAREN			{ $$ = Lnil; }
+	|  qtycls				{ $$ = lsing($1); }
+	;
+
+dtycls_list:  qtycls				{ $$ = lsing($1); }
+	|  dtycls_list COMMA qtycls		{ $$ = lapp($1,$3); }
+	;
+
+instdefs : /* empty */				{ $$ = mknullbind(); }
+	 | instdef				{ $$ = $1; }
+	 | instdefs SEMI instdef
+		{
+		  if(SAMEFN)
+		    {
+		      extendfn($1,$3);
+		      $$ = $1;
+		    }
+		  else
+		    $$ = mkabind($1,$3);
+		}
+	;
+
+/* instdef: same as valdef, except certain user-pragmas may appear */
+instdef :
+	   SPECIALISE_UPRAGMA qvark DCOLON types_and_maybe_ids END_UPRAGMA
+		{
+		  $$ = mkvspec_uprag($2, $4, startlineno);
+		  PREVPATT = NULL; FN = NULL; SAMEFN = 0;
+		}
+
+	|  INLINE_UPRAGMA qvark END_UPRAGMA
+		{
+		  $$ = mkinline_uprag($2, startlineno);
+		  PREVPATT = NULL; FN = NULL; SAMEFN = 0;
+		}
+
+	|  MAGIC_UNFOLDING_UPRAGMA qvark vark END_UPRAGMA
+		{
+		  $$ = mkmagicuf_uprag($2, $3, startlineno);
+		  PREVPATT = NULL; FN = NULL; SAMEFN = 0;
+		}
+
+	|  valdef
+  	;
+
+
+valdef	:  opatk
+		{
+		  tree fn = function($1);
+		  PREVPATT = $1;
+
+		  if(ttree(fn) == ident)
+		    {
+		      qid fun_id = gident((struct Sident *) fn);
+		      checksamefn(fun_id);
+		      FN = fun_id;
+		    }
+
+		  else if (ttree(fn) == infixap)
+		    {
+		      qid fun_id = ginffun((struct Sinfixap *) fn); 
+		      checksamefn(fun_id);
+		      FN = fun_id;
+		    }
+
+		  else if(etags)
+#if 1/*etags*/
+		    printf("%u\n",startlineno);
+#else
+		    fprintf(stderr,"%u\tvaldef\n",startlineno);
+#endif
+		}
+	   valrhs
+	  	{
+		  if ( lhs_is_patt($1) )
+		    {
+		      $$ = mkpbind($3, startlineno);
+		      FN = NULL;
+		      SAMEFN = 0;
+		    }
+		  else /* lhs is function */
+		    $$ = mkfbind($3,startlineno);
+
+		  PREVPATT = NULL;
+		}
+	;
+
+valrhs	:  valrhs1 maybe_where			{ $$ = lsing(createpat($1, $2)); }
+	;
+
+valrhs1	:  gdrhs				{ $$ = mkpguards($1); }
+	|  EQUAL exp				{ $$ = mkpnoguards($2); }
+	;
+
+gdrhs	:  gd EQUAL exp				{ $$ = lsing(mkpgdexp($1,$3)); }
+	|  gd EQUAL exp gdrhs			{ $$ = mklcons(mkpgdexp($1,$3),$4); }
+	;
+
+maybe_where:
+	   WHERE ocurly decls ccurly		{ $$ = $3; }
+	|  WHERE vocurly decls vccurly		{ $$ = $3; }
+	|  /* empty */				{ $$ = mknullbind(); }
+	;
+
+gd	:  VBAR oexp				{ $$ = $2; }
+	;
+
+
+/**********************************************************************
+*                                                                     *
+*                                                                     *
+*     Expressions						      *
+*                                                                     *
+*                                                                     *
+**********************************************************************/
+
+exp	:  oexp DCOLON ctype			{ $$ = mkrestr($1,$3); }
+	|  oexp
+	;
+
+/*
+  Operators must be left-associative at the same precedence for
+  precedence parsing to work.
+*/
+	/* 9 S/R conflicts on qop -> shift */
+oexp	:  oexp qop oexp %prec MINUS		{ $$ = mkinfixap($2,$1,$3); precparse($$); }
+	|  dexp
+	;
+
+/*
+  This comes here because of the funny precedence rules concerning
+  prefix minus.
+*/
+dexp	:  MINUS kexp				{ $$ = mknegate($2,NULL,NULL); }
+	|  kexp
+	;
+
+/*
+  We need to factor out a leading let expression so we can set
+  inpat=TRUE when parsing (non let) expressions inside stmts and quals
+*/
+expLno 	:  oexpLno DCOLON ctype			{ $$ = mkrestr($1,$3); }
+	|  oexpLno
+	;
+oexpLno	:  oexpLno qop oexp %prec MINUS		{ $$ = mkinfixap($2,$1,$3); precparse($$); }
+	|  dexpLno
+	;
+dexpLno	:  MINUS kexp				{ $$ = mknegate($2,NULL,NULL); }
+	|  kexpLno
+	;
+
+expL 	:  oexpL DCOLON ctype			{ $$ = mkrestr($1,$3); }
+	|  oexpL
+	;
+oexpL	:  oexpL qop oexp %prec MINUS		{ $$ = mkinfixap($2,$1,$3); precparse($$); }
+	|  kexpL
+	;
+
+/*
+  let/if/lambda/case have higher precedence than infix operators.
+*/
+
+kexp	:  kexpL
+	|  kexpLno
+	;
+
+kexpL	:  letdecls IN exp			{ $$ = mklet($1,$3); }
+	;
+
+kexpLno	:  LAMBDA
+		{ hsincindent();        /* push new context for FN = NULL;        */
+		  FN = NULL; 	        /* not actually concerned about indenting */
+		  $<ulong>$ = hsplineno; /* remember current line number           */
+		}
+	   lampats
+  		{ hsendindent();
+		}
+	   RARROW exp		        /* lambda abstraction */
+		{
+		  $$ = mklambda($3, $6, $<ulong>2);
+		}
+
+	/* If Expression */
+	|  IF {$<ulong>$ = hsplineno;}
+	   exp THEN exp ELSE exp		{ $$ = mkife($3,$5,$7,$<ulong>2); }
+
+	/* Case Expression */
+	|  CASE {$<ulong>$ = hsplineno;}
+	   exp OF caserest			{ $$ = mkcasee($3,$5,$<ulong>2); }
+
+	/* Do Expression */
+	|  DO {$<ulong>$ = hsplineno;}
+	   dorest				{ $$ = mkdoe($3,$<ulong>2); }
+
+	/* CCALL/CASM Expression */
+	|  CCALL ccallid cexps			{ $$ = mkccall($2,install_literal("n"),$3); }
+	|  CCALL ccallid			{ $$ = mkccall($2,install_literal("n"),Lnil); }
+	|  CCALL_GC ccallid cexps		{ $$ = mkccall($2,install_literal("p"),$3); }
+	|  CCALL_GC ccallid 			{ $$ = mkccall($2,install_literal("p"),Lnil); }
+	|  CASM CLITLIT cexps			{ $$ = mkccall($2,install_literal("N"),$3); }
+	|  CASM CLITLIT				{ $$ = mkccall($2,install_literal("N"),Lnil); }
+	|  CASM_GC CLITLIT cexps		{ $$ = mkccall($2,install_literal("P"),$3); }
+	|  CASM_GC CLITLIT 			{ $$ = mkccall($2,install_literal("P"),Lnil); }
+
+	/* SCC Expression */
+	|  SCC STRING exp
+		{ if (ignoreSCC) {
+		    $$ = $3;
+		  } else {
+		    $$ = mkscc($2, $3);
+		  }
+		}
+	|  fexp
+  	;
+
+fexp	:  fexp aexp				{ $$ = mkap($1,$2); }
+	|  aexp
+	;
+
+	/* simple expressions */
+aexp	:  qvar					{ $$ = mkident($1); }
+	|  gcon					{ $$ = mkident($1); }
+	|  lit_constant				{ $$ = mklit($1); }
+	|  OPAREN exp CPAREN			{ $$ = mkpar($2); }	  /* mkpar: stop infix parsing at ()'s */
+	|  qcon OCURLY rbinds CCURLY		{ $$ = mkrecord($1,$3); } /* 1 S/R conflict on OCURLY -> shift */
+	|  OBRACK list_exps CBRACK		{ $$ = mkllist($2); }
+	|  OPAREN exp COMMA texps CPAREN	{ if (ttree($4) == tuple)
+			     			     $$ = mktuple(mklcons($2, gtuplelist((struct Stuple *) $4)));
+						  else
+						     $$ = mktuple(ldub($2, $4)); }
+
+	/* only in expressions ... */
+	|  aexp OCURLY rbinds CCURLY		{ $$ = mkrupdate($1,$3); }
+	|  OBRACK exp VBAR quals CBRACK		{ $$ = mkcomprh($2,$4); }
+	|  OBRACK exp COMMA exp DOTDOT exp CBRACK {$$= mkeenum($2,mkjust($4),mkjust($6)); }
+	|  OBRACK exp COMMA exp DOTDOT CBRACK	{ $$ = mkeenum($2,mkjust($4),mknothing()); }
+	|  OBRACK exp DOTDOT exp CBRACK		{ $$ = mkeenum($2,mknothing(),mkjust($4)); }
+	|  OBRACK exp DOTDOT CBRACK		{ $$ = mkeenum($2,mknothing(),mknothing()); }
+	|  OPAREN oexp qop CPAREN		{ $$ = mklsection($2,$3); }
+	|  OPAREN qop1 oexp CPAREN		{ $$ = mkrsection($2,$3); }
+
+	/* only in patterns ... */
+	/* these add 2 S/R conflict with with  aexp . OCURLY rbinds CCURLY */
+	|  qvar AT aexp				{ checkinpat(); $$ = mkas($1,$3); }
+	|  LAZY aexp				{ checkinpat(); $$ = mklazyp($2); }
+	|  WILDCARD				{ checkinpat(); $$ = mkwildp();   }
+	;
+
+	/* ccall arguments */
+cexps	:  cexps aexp				{ $$ = lapp($1,$2); }
+	|  aexp					{ $$ = lsing($1); }
+	;
+
+caserest:  ocurly alts ccurly			{ $$ = $2; }
+	|  vocurly alts vccurly			{ $$ = $2; }
+
+dorest  :  ocurly stmts ccurly			{ checkdostmts($2); $$ = $2; }
+	|  vocurly stmts vccurly		{ checkdostmts($2); $$ = $2; }
+	;
+
+rbinds	:  rbind				{ $$ = lsing($1); }
+	|  rbinds COMMA rbind			{ $$ = lapp($1,$3); }
+	;
+
+rbind  	:  qvar					{ $$ = mkrbind($1,mknothing()); }
+	|  qvar EQUAL exp			{ $$ = mkrbind($1,mkjust($3)); }
+	;
+
+texps	:  exp	{ $$ = mkpar($1); }	/* mkpar: so we don't flatten last element in tuple */
+	|  exp COMMA texps
+		{ if (ttree($3) == tuple)
+		    $$ = mktuple(mklcons($1, gtuplelist((struct Stuple *) $3)));
+		  else
+		    $$ = mktuple(ldub($1, $3));
+		}
+	/* right recursion? WDP */
+	;
+
+
+list_exps :
+	   exp					{ $$ = lsing($1); }
+	|  exp COMMA list_exps		{ $$ = mklcons($1, $3); }
+	/* right recursion? (WDP)
+
+	   It has to be this way, though, otherwise you
+	   may do the wrong thing to distinguish between...
+
+	   [ e1 , e2 .. ]	-- an enumeration ...
+	   [ e1 , e2 , e3 ]	-- a list
+
+	   (In fact, if you change the grammar and throw yacc/bison
+	   at it, it *will* do the wrong thing [WDP 94/06])
+	*/
+	;
+
+letdecls:  LET ocurly decls ccurly		{ $$ = $3 }
+	|  LET vocurly decls vccurly		{ $$ = $3 }
+	;
+
+quals	:  qual					{ $$ = lsing($1); }
+	|  quals COMMA qual			{ $$ = lapp($1,$3); }
+	;
+
+qual	:  letdecls				{ $$ = mkseqlet($1); }
+	|  expL					{ $$ = $1; }
+	|  {inpat=TRUE;} expLno {inpat=FALSE;}leftexp
+		{ if ($4 == NULL) {
+		      expORpat(LEGIT_EXPR,$2);
+		      $$ = mkguard($2);
+		  } else {
+		      expORpat(LEGIT_PATT,$2);
+		      $$ = mkqual($2,$4);
+		  }
+		}
+	;
+
+alts	:  alt					{ $$ = $1; }
+	|  alts SEMI alt			{ $$ = lconc($1,$3); }
+	;
+
+alt	:  pat { PREVPATT = $1; } altrest	{ $$ = lsing($3); PREVPATT = NULL; }
+	|  /* empty */				{ $$ = Lnil; }
+	;
+
+altrest	:  gdpat maybe_where	 		{ $$ = createpat(mkpguards($1), $2); }
+	|  RARROW exp maybe_where		{ $$ = createpat(mkpnoguards($2),$3); }
+	;
+
+gdpat	:  gd RARROW exp			{ $$ = lsing(mkpgdexp($1,$3)); }
+	|  gd RARROW exp gdpat			{ $$ = mklcons(mkpgdexp($1,$3),$4);  }
+	;
+
+stmts	:  stmt					{ $$ = $1; }
+	|  stmts SEMI stmt			{ $$ = lconc($1,$3); }
+	;
+
+stmt	:  /* empty */				{ $$ = Lnil; }
+	|  letdecls				{ $$ = lsing(mkseqlet($1)); }
+	|  expL					{ $$ = lsing($1); }
+	|  {inpat=TRUE;} expLno {inpat=FALSE;} leftexp
+		{ if ($4 == NULL) {
+		      expORpat(LEGIT_EXPR,$2);
+		      $$ = lsing(mkdoexp($2,endlineno));
+		  } else {
+		      expORpat(LEGIT_PATT,$2);
+		      $$ = lsing(mkdobind($2,$4,endlineno));
+		  }
+		}
+	;
+
+leftexp	:  LARROW exp				{ $$ = $2; }
+        |  /* empty */				{ $$ = NULL; }
+	;
+
+/**********************************************************************
+*                                                                     *
+*                                                                     *
+*     Patterns							      *
+*                                                                     *
+*                                                                     *
+**********************************************************************/
+
+/*
+	The xpatk business is to do with accurately recording
+	the starting line for definitions.
+*/
+
+opatk	:  dpatk
+	|  opatk qop opat %prec MINUS
+		{
+		  $$ = mkinfixap($2,$1,$3);
+
+		  if (isconstr(qid_to_string($2)))
+		    precparse($$);
+		  else
+		    {
+		      checkprec($1,$2,FALSE);	/* Check the precedence of the left pattern */
+		      checkprec($3,$2,TRUE);	/* then check the right pattern */
+		    }
+		}
+	;
+
+opat	:  dpat
+	|  opat qop opat %prec MINUS
+		{
+		  $$ = mkinfixap($2,$1,$3);
+
+		  if(isconstr(qid_to_string($2)))
+		    precparse($$);
+		  else
+		    {
+		      checkprec($1,$2,FALSE);	/* Check the precedence of the left pattern */
+		      checkprec($3,$2,TRUE);	/* then check the right pattern */
+		    }
+		}
+	;
+
+/*
+  This comes here because of the funny precedence rules concerning
+  prefix minus.
+*/
+
+
+dpat	:  MINUS fpat				{ $$ = mknegate($2,NULL,NULL); }
+	|  fpat
+	;
+
+	/* Function application */
+fpat	:  fpat aapat				{ $$ = mkap($1,$2); }
+	|  aapat
+	;
+
+dpatk	:  minuskey fpat			{ $$ = mknegate($2,NULL,NULL); }
+	|  fpatk
+	;
+
+	/* Function application */
+fpatk	:  fpatk aapat				{ $$ = mkap($1,$2); }
+	|  aapatk
+	;
+
+aapat	:  qvar		 			{ $$ = mkident($1); }
+	|  qvar AT apat			 	{ $$ = mkas($1,$3); }
+	|  gcon		 			{ $$ = mkident($1); }
+	|  qcon OCURLY rpats CCURLY		{ $$ = mkrecord($1,$3); }
+	|  lit_constant				{ $$ = mklit($1); }
+	|  WILDCARD				{ $$ = mkwildp(); }
+	|  OPAREN opat CPAREN			{ $$ = mkpar($2); }
+	|  OPAREN opat COMMA pats CPAREN 	{ $$ = mktuple(mklcons($2,$4)); }
+	|  OBRACK pats CBRACK			{ $$ = mkllist($2); }
+	|  LAZY apat				{ $$ = mklazyp($2); }
+	;
+
+
+aapatk	:  qvark	 			{ $$ = mkident($1); }
+	|  qvark AT apat	 		{ $$ = mkas($1,$3); }
+	|  gconk	 			{ $$ = mkident($1); }
+	|  qconk OCURLY rpats CCURLY		{ $$ = mkrecord($1,$3); }
+	|  lit_constant				{ $$ = mklit($1); setstartlineno(); }
+	|  WILDCARD				{ $$ = mkwildp(); setstartlineno(); }
+	|  oparenkey opat CPAREN		{ $$ = mkpar($2); }
+	|  oparenkey opat COMMA pats CPAREN 	{ $$ = mktuple(mklcons($2,$4)); }
+	|  obrackkey pats CBRACK		{ $$ = mkllist($2); }
+	|  lazykey apat				{ $$ = mklazyp($2); }
+	;
+
+gcon	:  qcon
+	|  OBRACK CBRACK			{ $$ = creategid(-1); }
+	|  OPAREN CPAREN			{ $$ = creategid(0); }
+	|  OPAREN commas CPAREN			{ $$ = creategid($2); }
+	;
+
+gconk	:  qconk		 		
+	|  obrackkey CBRACK			{ $$ = creategid(-1); }
+	|  oparenkey CPAREN			{ $$ = creategid(0); }
+	|  oparenkey commas CPAREN		{ $$ = creategid($2); }
+	;
+
+lampats	:  apat lampats				{ $$ = mklcons($1,$2); }
+	|  apat					{ $$ = lsing($1); }
+	/* right recursion? (WDP) */
+	;
+
+pats	:  pat COMMA pats			{ $$ = mklcons($1, $3); }
+	|  pat					{ $$ = lsing($1); }
+    	/* right recursion? (WDP) */
+	;
+
+pat	:  pat qconop bpat			{ $$ = mkinfixap($2,$1,$3); precparse($$); }
+	|  bpat
+	;
+
+bpat	:  apatc
+ 	|  conpat
+	|  qcon OCURLY rpats CCURLY		{ $$ = mkrecord($1,$3); }
+	|  MINUS INTEGER			{ $$ = mklit(mkinteger(ineg($2))); }
+	|  MINUS FLOAT				{ $$ = mklit(mkfloatr(ineg($2))); }
+	;
+
+conpat	:  gcon					{ $$ = mkident($1); }
+	|  conpat apat				{ $$ = mkap($1,$2); }
+	;
+
+apat	:  gcon		 			{ $$ = mkident($1); }
+	|  qcon OCURLY rpats CCURLY		{ $$ = mkrecord($1,$3); }
+	|  apatc
+	;
+
+apatc	:  qvar		 			{ $$ = mkident($1); }
+	|  qvar AT apat			 	{ $$ = mkas($1,$3); }
+	|  lit_constant				{ $$ = mklit($1); }
+	|  WILDCARD				{ $$ = mkwildp(); }
+	|  OPAREN pat CPAREN			{ $$ = mkpar($2); }
+	|  OPAREN pat COMMA pats CPAREN 	{ $$ = mktuple(mklcons($2,$4)); }
+	|  OBRACK pats CBRACK			{ $$ = mkllist($2); }
+	|  LAZY apat				{ $$ = mklazyp($2); }
+	;
+
+lit_constant:
+	   INTEGER				{ $$ = mkinteger($1); }
+	|  FLOAT				{ $$ = mkfloatr($1); }
+	|  CHAR					{ $$ = mkcharr($1); }
+	|  STRING				{ $$ = mkstring($1); }
+	|  CHARPRIM				{ $$ = mkcharprim($1); }
+	|  STRINGPRIM				{ $$ = mkstringprim($1); }
+	|  INTPRIM				{ $$ = mkintprim($1); }
+	|  FLOATPRIM				{ $$ = mkfloatprim($1); }
+	|  DOUBLEPRIM				{ $$ = mkdoubleprim($1); }
+	|  CLITLIT /* yurble yurble */		{ $$ = mkclitlit($1, ""); }
+	|  CLITLIT KIND_PRAGMA CONID		{ $$ = mkclitlit($1, $3); }
+	|  NOREP_INTEGER  INTEGER		{ $$ = mknorepi($2); }
+	|  NOREP_RATIONAL INTEGER INTEGER	{ $$ = mknorepr($2, $3); }
+	|  NOREP_STRING   STRING		{ $$ = mknoreps($2); }
+	;
+
+rpats	: rpat					{ $$ = lsing($1); }
+	| rpats COMMA rpat			{ $$ = lapp($1,$3); }
+	;
+
+rpat	:  qvar					{ $$ = mkrbind($1,mknothing()); }
+	|  qvar EQUAL pat			{ $$ = mkrbind($1,mkjust($3)); }
+	;
+
+
+/**********************************************************************
+*                                                                     *
+*                                                                     *
+*     Keywords which record the line start			      *
+*                                                                     *
+*                                                                     *
+**********************************************************************/
+
+importkey:  IMPORT	{ setstartlineno(); }
+	;
+
+datakey	:   DATA	{ setstartlineno();
+			  if(etags)
+#if 1/*etags*/
+			    printf("%u\n",startlineno);
+#else
+			    fprintf(stderr,"%u\tdata\n",startlineno);
+#endif
+			}
+	;
+
+typekey	:   TYPE	{ setstartlineno();
+			  if(etags)
+#if 1/*etags*/
+			    printf("%u\n",startlineno);
+#else
+			    fprintf(stderr,"%u\ttype\n",startlineno);
+#endif
+			}
+	;
+
+newtypekey : NEWTYPE	{ setstartlineno();
+			  if(etags)
+#if 1/*etags*/
+			    printf("%u\n",startlineno);
+#else
+			    fprintf(stderr,"%u\tnewtype\n",startlineno);
+#endif
+			}
+	;
+
+instkey	:   INSTANCE	{ setstartlineno();
+#if 1/*etags*/
+/* OUT:			  if(etags)
+			    printf("%u\n",startlineno);
+*/
+#else
+			    fprintf(stderr,"%u\tinstance\n",startlineno);
+#endif
+			}
+	;
+
+defaultkey: DEFAULT	{ setstartlineno(); }
+	;
+
+classkey:   CLASS	{ setstartlineno();
+			  if(etags)
+#if 1/*etags*/
+			    printf("%u\n",startlineno);
+#else
+			    fprintf(stderr,"%u\tclass\n",startlineno);
+#endif
+			}
+	;
+
+minuskey:   MINUS	{ setstartlineno(); }
+	;
+
+modulekey:  MODULE	{ setstartlineno();
+			  if(etags)
+#if 1/*etags*/
+			    printf("%u\n",startlineno);
+#else
+			    fprintf(stderr,"%u\tmodule\n",startlineno);
+#endif
+			}
+	;
+
+oparenkey:  OPAREN	{ setstartlineno(); }
+	;
+
+obrackkey:  OBRACK	{ setstartlineno(); }
+	;
+
+lazykey	:   LAZY	{ setstartlineno(); }
+	;
+
+
+/**********************************************************************
+*                                                                     *
+*                                                                     *
+*     Basic qualified/unqualified ids/ops                             *
+*                                                                     *
+*                                                                     *
+**********************************************************************/
+
+qvar	:  qvarid
+	|  OPAREN qvarsym CPAREN	{ $$ = $2; }
+	;
+qcon    :  qconid
+	|  OPAREN qconsym CPAREN	{ $$ = $2; }
+	;
+qvarop	:  qvarsym
+	|  BQUOTE qvarid BQUOTE		{ $$ = $2; }
+	;
+qconop	:  qconsym
+	|  BQUOTE qconid BQUOTE		{ $$ = $2; }
+	;
+qop	:  qconop
+	|  qvarop
+  	;
+
+/* Non "-" op, used in right sections */
+qop1	:  qconop
+	|  qvarop1
+  	;
+
+/* Non "-" varop, used in right sections */
+qvarop1	:  QVARSYM
+	|  varsym_nominus		{ $$ = mknoqual($1); }
+	|  BQUOTE qvarid BQUOTE		{ $$ = $2; }
+	;
+
+
+var	:  varid
+	|  OPAREN varsym CPAREN		{ $$ = $2; }
+	;
+con	:  tycon			/* using tycon removes conflicts */
+	|  OPAREN CONSYM CPAREN		{ $$ = $2; }
+	;
+varop	:  varsym
+	|  BQUOTE varid BQUOTE		{ $$ = $2; }
+	;
+conop	:  CONSYM
+	|  BQUOTE CONID BQUOTE		{ $$ = $2; }
+	;
+op	:  conop
+	|  varop
+	;
+
+qvark	:  qvarid			{ setstartlineno(); $$ = $1; }
+	|  oparenkey qvarsym CPAREN	{ $$ = $2; }
+	;
+qconk	:  qconid			{ setstartlineno(); $$ = $1; }
+	|  oparenkey qconsym CPAREN	{ $$ = $2; }
+	;
+vark	:  varid			{ setstartlineno(); $$ = $1; }
+	|  oparenkey varsym CPAREN	{ $$ = $2; }
+	;
+
+qvarid	:  QVARID
+	|  varid			{ $$ = mknoqual($1); }
+	;
+qvarsym	:  QVARSYM
+	|  varsym			{ $$ = mknoqual($1); }
+	;
+qconid	:  QCONID
+	|  tycon			{ $$ = mknoqual($1); } /* using tycon removes conflicts */
+	;
+qconsym	:  QCONSYM
+	|  CONSYM			{ $$ = mknoqual($1); }
+	;
+qtycon	:  QCONID
+	|  tycon			{ $$ = mknoqual($1); } /* using tycon removes conflicts */
+	;
+qtycls  :  QCONID
+	|  tycon			{ $$ = mknoqual($1); } /* using tycon removes conflicts */
+	;
+
+varsym	:  varsym_nominus
+	|  MINUS			{ $$ = install_literal("-"); }
+	;
+
+/* AS HIDING QUALIFIED are valid varids */
+varid   :  VARID
+	|  AS				{ $$ = install_literal("as"); }
+	|  HIDING			{ $$ = install_literal("hiding"); }
+	|  QUALIFIED			{ $$ = install_literal("qualified"); }
+	|  INTERFACE			{ $$ = install_literal("interface"); }
+	;
+
+/* DARROW BANG are valid varsyms */
+varsym_nominus : VARSYM
+	|  DARROW			{ $$ = install_literal("=>"); }
+	|  BANG				{ $$ = install_literal("!"); }	
+	;
+
+ccallid	:  VARID
+	|  CONID
+	;
+
+tyvar	:  varid			{ $$ = mknamedtvar($1); }
+	;
+tycon	:  CONID
+	;
+modid	:  CONID
+	;
+
+tyvar_list: tyvar			{ $$ = lsing($1); }
+	|  tyvar_list COMMA tyvar 	{ $$ = lapp($1,$3); }
+	;
+
+/**********************************************************************
+*                                                                     *
+*                                                                     *
+*     Stuff to do with layout                                         *
+*                                                                     *
+*                                                                     *
+**********************************************************************/
+
+ocurly	: layout OCURLY				{ hsincindent(); }
+
+vocurly	: layout				{ hssetindent(); }
+	;
+
+layout	: 					{ hsindentoff(); }
+	;
+
+ccurly	:
+	 CCURLY
+		{
+		  FN = NULL; SAMEFN = 0; PREVPATT = NULL;
+		  hsendindent();
+		}
+	;
+
+vccurly	:  { expect_ccurly = 1; }  vccurly1  { expect_ccurly = 0; }
+	;
+
+vccurly1:
+	 VCCURLY
+		{
+		  FN = NULL; SAMEFN = 0; PREVPATT = NULL;
+		  hsendindent();
+		}
+	| error
+		{
+		  yyerrok;
+		  FN = NULL; SAMEFN = 0; PREVPATT = NULL;
+		  hsendindent();
+		}
+	;
+
+%%
+
+/**********************************************************************
+*                                                                     *
+*      Error Processing and Reporting                                 *
+*                                                                     *
+*  (This stuff is here in case we want to use Yacc macros and such.)  *
+*                                                                     *
+**********************************************************************/
+
+/* The parser calls "hsperror" when it sees a
+   `report this and die' error.  It sets the stage
+   and calls "yyerror".
+
+   There should be no direct calls in the parser to
+   "yyerror", except for the one from "hsperror".  Thus,
+   the only other calls will be from the error productions
+   introduced by yacc/bison/whatever.
+
+   We need to be able to recognise the from-error-production
+   case, because we sometimes want to say, "Oh, never mind",
+   because the layout rule kicks into action and may save
+   the day.  [WDP]
+*/
+
+static BOOLEAN error_and_I_mean_it = FALSE;
+
+void
+hsperror(s)
+  char *s;
+{
+    error_and_I_mean_it = TRUE;
+    yyerror(s);
+}
+
+extern char *yytext;
+extern int yyleng;
+
+void
+yyerror(s)
+  char *s;
+{
+    /* We want to be able to distinguish 'error'-raised yyerrors
+       from yyerrors explicitly coded by the parser hacker.
+    */
+    if (expect_ccurly && ! error_and_I_mean_it ) {
+	/*NOTHING*/;
+
+    } else {
+	fprintf(stderr, "\"%s\", line %d, column %d: %s on input: ",
+	  input_filename, hsplineno, hspcolno + 1, s);
+
+	if (yyleng == 1 && *yytext == '\0')
+	    fprintf(stderr, "<EOF>");
+
+	else {
+	    fputc('"', stderr);
+	    format_string(stderr, (unsigned char *) yytext, yyleng);
+	    fputc('"', stderr);
+	}
+	fputc('\n', stderr);
+
+	/* a common problem */
+	if (strcmp(yytext, "#") == 0)
+	    fprintf(stderr, "\t(Perhaps you forgot a `-cpp' or `-fglasgow-exts' flag?)\n");
+
+	exit(1);
+    }
+}
+
+void
+format_string(fp, s, len)
+  FILE *fp;
+  unsigned char *s;
+  int len;
+{
+    while (len-- > 0) {
+	switch (*s) {
+	case '\0':    fputs("\\NUL", fp);   break;
+	case '\007':  fputs("\\a", fp);	    break;
+	case '\010':  fputs("\\b", fp);	    break;
+	case '\011':  fputs("\\t", fp);	    break;
+	case '\012':  fputs("\\n", fp);	    break;
+	case '\013':  fputs("\\v", fp);	    break;
+	case '\014':  fputs("\\f", fp);	    break;
+	case '\015':  fputs("\\r", fp);	    break;
+	case '\033':  fputs("\\ESC", fp);   break;
+	case '\034':  fputs("\\FS", fp);    break;
+	case '\035':  fputs("\\GS", fp);    break;
+	case '\036':  fputs("\\RS", fp);    break;
+	case '\037':  fputs("\\US", fp);    break;
+	case '\177':  fputs("\\DEL", fp);   break;
+	default:
+    	    if (*s >= ' ')
+    		fputc(*s, fp);
+	    else
+		fprintf(fp, "\\^%c", *s + '@');
+	    break;
+	}
+	s++;
+    }
+}
diff --git a/ghc/compiler/parser/hspincl.h b/ghc/compiler/parser/hspincl.h
new file mode 100644
index 0000000000..0f3530f89b
--- /dev/null
+++ b/ghc/compiler/parser/hspincl.h
@@ -0,0 +1,62 @@
+#ifndef HSPINCL_H
+#define HSPINCL_H
+
+#include "../../includes/config.h"
+
+#if __STDC__
+#define PROTO(x)	x
+#define NO_ARGS		void
+#define CONST		const
+#define VOID		void
+#define VOID_STAR	void *
+#define VOLATILE	volatile
+#else
+#define PROTO(x)	()
+#define NO_ARGS		/* no args */
+#define CONST		/* no const */
+#define VOID		void /* hope for the best... */
+#define VOID_STAR	long *
+#define VOLATILE	/* no volatile */
+#endif /* ! __STDC__ */
+
+#if defined(STDC_HEADERS) || defined(HAVE_STRING_H)
+#include <string.h>
+/* An ANSI string.h and pre-ANSI memory.h might conflict.  */
+#if !defined(STDC_HEADERS) && defined(HAVE_MEMORY_H)
+#include <memory.h>
+#endif /* not STDC_HEADERS and HAVE_MEMORY_H */
+#define index strchr
+#define rindex strrchr
+#define bcopy(s, d, n) memcpy ((d), (s), (n))
+#define bcmp(s1, s2, n) memcmp ((s1), (s2), (n))
+#define bzero(s, n) memset ((s), 0, (n))
+#else /* not STDC_HEADERS and not HAVE_STRING_H */
+#include <strings.h>
+/* memory.h and strings.h conflict on some systems.  */
+#endif /* not STDC_HEADERS and not HAVE_STRING_H */
+
+#ifdef HAVE_MALLOC_H
+#include <malloc.h>
+#endif
+#ifdef HAVE_STDLIB_H
+#include <stdlib.h>
+#endif
+
+#include "id.h"
+#include "qid.h"
+#include "literal.h"
+#include "list.h"
+#include "maybe.h"
+#include "either.h"
+#include "ttype.h"
+#include "constr.h"
+#include "coresyn.h"
+#include "hpragma.h"
+#include "binding.h"
+#include "entidt.h"
+#include "tree.h"
+#include "pbinding.h"
+
+extern char *input_filename;
+
+#endif /* HSPINCL_H */
diff --git a/ghc/compiler/parser/id.c b/ghc/compiler/parser/id.c
new file mode 100644
index 0000000000..9fac62b0b5
--- /dev/null
+++ b/ghc/compiler/parser/id.c
@@ -0,0 +1,362 @@
+/**********************************************************************
+*                                                                     *
+*                                                                     *
+*      Identifier Processing                                          *
+*                                                                     *
+*                                                                     *
+**********************************************************************/
+
+#include <stdio.h>
+
+#include "hspincl.h"
+#include "constants.h"
+#include "id.h"
+#include "utils.h"
+
+/* partain: special version for strings that may have NULs (etc) in them
+   (used in UgenUtil.lhs)
+*/
+long
+get_hstring_len(hs)
+  hstring hs;
+{
+    return(hs->len);
+}
+
+char *
+get_hstring_bytes(hs)
+  hstring hs;
+{
+  return(hs->bytes);
+}
+
+hstring
+installHstring(length, s)
+  int  length;
+  char *s;
+{
+  char *p;
+  hstring str;
+  int i;
+
+/* fprintf(stderr, "installHstring: %d, %s\n",length, s); */
+
+  if (length > 999999) { /* too long */
+      fprintf(stderr,"String length more than six digits\n");
+      exit(1);
+  } else if (length < 0) { /* too short */
+      fprintf(stderr,"String length < 0 !!\n");
+      abort();
+  }
+
+  /* alloc the struct and store the length */
+  str = (hstring) xmalloc(sizeof(Hstring));
+  str->len = length;
+
+  if (length == 0) {
+     str->bytes = NULL;
+
+  } else {
+     p = xmalloc(length);
+
+     /* now store the string */
+     for (i = 0; i < length; i++) {
+       p[i] = s[i];
+     }
+     str->bytes = p;
+  }
+  return str;
+}
+
+
+/**********************************************************************
+*                                                                     *
+*                                                                     *
+*      Hashed Identifiers                                             *
+*                                                                     *
+*                                                                     *
+**********************************************************************/
+
+
+extern BOOLEAN hashIds;				/* Whether to use hashed ids. */
+
+unsigned hash_table_size = HASH_TABLE_SIZE;
+
+static char **hashtab = NULL;
+
+static unsigned  max_hash_table_entries = 0;
+
+void
+hash_init()
+{
+  if(!hashIds) {
+    /*NOTHING*/;
+
+  } else {
+
+  /* Create an initialised hash table */
+  hashtab = (char **) calloc( hash_table_size, sizeof(char *) );
+  if(hashtab == NULL)
+    {
+      fprintf(stderr,"Cannot allocate a hash table with %d entries -- insufficient memory\n",hash_table_size);
+      exit(1);
+    }
+#ifdef HSP_DEBUG
+  fprintf(stderr,"hashtab = %x\n",hashtab);
+#endif
+
+  /* Allow no more than 90% occupancy -- Divide first to avoid overflows with BIG tables! */
+  max_hash_table_entries = (hash_table_size / 10) * 9;
+  }
+}
+
+void
+print_hash_table()
+{
+  if(hashIds)
+    {
+      unsigned i;
+
+      printf("%u ",hash_table_size);
+
+      for(i=0; i < hash_table_size; ++i)
+	if(hashtab[i] != NULL)
+	  printf("(%u,%s) ",i,hashtab[i]);
+    }
+}
+
+
+long int
+hash_index(ident)
+  id ident;
+{
+  return((char **) /* YURGH */ ident - hashtab);
+}
+
+
+/*
+  The hash function.  Returns 0 for Null strings.
+*/
+
+static unsigned hash_fn(char *ident)
+{
+  unsigned len = (unsigned) strlen(ident);
+  unsigned res;
+
+  if(*ident == '\0')
+    return( 0 );
+
+  /* does not work well for hash tables with more than 35K elements */
+  res = (((unsigned)ident[0]*631)+((unsigned)ident[len/2-1]*217)+((unsigned)ident[len-1]*43)+len)
+	  % hash_table_size;
+
+#ifdef HSP_DEBUG
+  fprintf(stderr,"\"%s\" hashes to %d\n",ident,res);
+#endif
+  return(res);
+}
+
+
+/*
+  Install a literal identifier, such as "+" in hsparser.
+  If we are not using hashing, just return the string.
+*/
+
+id
+install_literal(s)
+  char *s;
+{
+  return( hashIds? installid(s): s);
+}
+
+
+char *
+id_to_string(sp)
+  id sp;
+{
+  return( hashIds? *(char **)sp: (char *)sp );
+}
+
+id
+installid(s)
+  char *s;
+{
+  unsigned hash, count;
+
+  if(!hashIds)
+    return(xstrdup(s));
+
+  for(hash = hash_fn(s),count=0; count<max_hash_table_entries; ++hash,++count)
+    {
+      if (hash >= hash_table_size) hash = 0;
+
+      if(hashtab[hash] == NULL)
+	{
+	  hashtab[hash] = xstrdup(s);
+#ifdef HSP_DEBUG
+	  fprintf(stderr,"New Hash Entry %x\n",(char *)&hashtab[hash]);
+#endif
+	  if ( count >= 100 ) {
+	    fprintf(stderr, "installid: %d collisions for %s\n", count, s);
+	  }
+
+	  return((char *)&hashtab[hash]);
+	}
+
+      if(strcmp(hashtab[hash],s) == 0)
+	{
+#ifdef HSP_DEBUG
+	  fprintf(stderr,"Old Hash Entry %x (%s)\n",(char *)&hashtab[hash],hashtab[hash]);
+#endif
+	  if ( count >= 100 ) {
+	    fprintf(stderr, "installid: %d collisions for %s\n", count, s);
+	  }
+
+	  return((char *)&hashtab[hash]);
+	}
+    }
+  fprintf(stderr,"Hash Table Contains more than %d entries -- make larger?\n",max_hash_table_entries);
+  exit(1);
+}
+
+/**********************************************************************
+*                                                                     *
+*                                                                     *
+*     Qualified Ids                                                   *
+*                                                                     *
+*                                                                     *
+**********************************************************************/
+
+id
+qid_to_id(q)
+  qid q;
+{
+  switch(tqid(q))
+    {
+      case noqual:
+	return(gnoqual((struct Snoqual *)q));
+      case aqual:
+	return(gqualname((struct Saqual *)q));
+      case gid:
+	return(gidname((struct Sgid *)q));
+    }	
+}
+
+char *
+qid_to_string(q)
+  qid q;
+{
+  return(id_to_string(qid_to_id(q)));
+}
+
+char *
+qid_to_mod(q)
+  qid q;
+{
+  switch(tqid(q))
+    {
+      case noqual:
+	return(NULL);
+      case aqual:
+	return(id_to_string(gqualmod((struct Saqual *)q)));
+      case gid:
+	return(NULL);
+    }	
+}
+
+char *
+qid_to_pmod(q)
+  qid q;
+{
+  char *mod = qid_to_mod(q);
+  if (mod == NULL) mod = "?";
+  return mod;
+}
+
+qid
+creategid(i)
+  long i;
+{
+  switch(i) {
+    case -2:
+      return(mkgid(i,install_literal("(->)")));
+    case -1:
+      return(mkgid(i,install_literal("[]")));
+    case  0:
+      return(mkgid(i,install_literal("()")));
+    default:
+      {
+      char tmp[64]; int c = 0;
+      tmp[c++] = '(';
+      while (c <= i) tmp[c++] = ',';
+      tmp[c++] = ')';
+      tmp[c]   = '\0';
+      return(mkgid(i,installid(tmp)));
+      }
+  }
+}
+
+/**********************************************************************
+*                                                                     *
+*                                                                     *
+*     Memory Allocation                                               *
+*                                                                     *
+*                                                                     *
+**********************************************************************/
+
+/* Malloc with error checking */
+
+char *
+xmalloc(length)
+unsigned length;
+{
+    char *stuff = malloc(length);
+
+    if (stuff == NULL) {
+	fprintf(stderr, "xmalloc failed on a request for %d bytes\n", length);
+	exit(1);
+    }
+    return (stuff);
+}
+
+char *
+xrealloc(ptr, length)
+char *ptr;
+unsigned length;
+{
+    char *stuff = realloc(ptr, length);
+
+    if (stuff == NULL) {
+	fprintf(stderr, "xrealloc failed on a request for %d bytes\n", length);
+	exit(1);
+    }
+    return (stuff);
+}
+
+/* Strdup with error checking */
+
+char *
+xstrdup(s)
+char *s;
+{
+    unsigned len = strlen(s);
+    return xstrndup(s, len);
+}
+
+/*
+ * Strdup for possibly unterminated strings (e.g. substrings of longer strings)
+ * with error checking.  Handles NULs as well.
+ */
+
+char *
+xstrndup(s, len)
+char *s;
+unsigned len;
+{
+    char *p = xmalloc(len + 1);
+
+    bcopy(s, p, len);
+    p[len] = '\0';
+
+    return (p);
+}
diff --git a/ghc/compiler/parser/id.h b/ghc/compiler/parser/id.h
new file mode 100644
index 0000000000..b0fd009aa4
--- /dev/null
+++ b/ghc/compiler/parser/id.h
@@ -0,0 +1,15 @@
+#ifndef ID_H
+#define ID_H
+
+typedef char *id;
+typedef id unkId;	/* synonym */
+typedef id stringId;	/* synonym */
+typedef id numId;	/* synonym, for now */
+
+typedef struct { long len; char *bytes; } Hstring;
+typedef Hstring *hstring;
+
+long  get_hstring_len  PROTO((hstring));
+char *get_hstring_bytes PROTO((hstring));
+
+#endif
diff --git a/ghc/compiler/parser/import_dirlist.c b/ghc/compiler/parser/import_dirlist.c
new file mode 100644
index 0000000000..d81de59c23
--- /dev/null
+++ b/ghc/compiler/parser/import_dirlist.c
@@ -0,0 +1,223 @@
+/**********************************************************************
+*                                                                     *
+*                                                                     *
+*      Import Directory List Handling                                 *
+*                                                                     *
+*                                                                     *
+**********************************************************************/
+
+#include <stdio.h>
+
+#include "hspincl.h"
+#include "constants.h"
+#include "utils.h"
+
+#ifdef HAVE_UNISTD_H
+#include <unistd.h>
+#endif
+
+#ifdef HAVE_SYS_TYPES_H
+#include <sys/types.h>
+#else
+#ifdef HAVE_TYPES_H
+#include <types.h>
+#endif
+#endif
+
+#ifdef HAVE_SYS_STAT_H
+#include <sys/stat.h>
+#endif
+
+#ifdef HAVE_SYS_FILE_H
+#include <sys/file.h>
+#endif
+
+#ifndef HAVE_ACCESS
+#define R_OK "r"
+#define F_OK "r"
+short
+access(const char *fileName, const char *mode)
+{
+    FILE *fp = fopen(fileName, mode);
+    if (fp != NULL) {
+	(void) fclose(fp);
+	return 0;
+    }
+    return 1;
+}
+#endif /* HAVE_ACCESS */
+
+
+list	imports_dirlist, sys_imports_dirlist; /* The imports lists */
+extern  char HiSuffix[];
+extern  char PreludeHiSuffix[];
+/* OLD 95/08: extern BOOLEAN ExplicitHiSuffixGiven; */
+
+#define MAX_MATCH 16
+
+/*
+  This finds a module along the imports directory list.
+*/
+
+void
+find_module_on_imports_dirlist(char *module_name, BOOLEAN is_sys_import, char *returned_filename)
+{
+    char try[FILENAME_SIZE];
+
+    list imports_dirs;
+
+#ifdef HAVE_STAT
+    struct stat sbuf[MAX_MATCH];
+#endif
+
+    int no_of_matches = 0;
+    BOOLEAN tried_source_dir = FALSE;
+
+    char *try_end;
+    char *suffix_to_use    = (is_sys_import) ? PreludeHiSuffix : HiSuffix;
+    char *suffix_to_report = suffix_to_use; /* save this for reporting, because we
+						might change suffix_to_use later */
+    int modname_len = strlen(module_name);
+
+    /* 
+       Check every directory in (sys_)imports_dirlist for the imports file.
+       The first directory in the list is the source directory.
+    */
+    for (imports_dirs = (is_sys_import) ? sys_imports_dirlist : imports_dirlist;
+	 tlist(imports_dirs) == lcons; 
+	 imports_dirs = ltl(imports_dirs))
+      {
+	char *dir = (char *) lhd(imports_dirs);
+	strcpy(try, dir);
+
+	try_end = try + strlen(try);
+
+#ifdef macintosh /* ToDo: use DIR_SEP_CHAR */
+	if (*(try_end - 1) != ':')
+	    strcpy (try_end++, ":");
+#else
+	if (*(try_end - 1) != '/')
+	  strcpy (try_end++, "/");
+#endif /* ! macintosh */
+
+	strcpy(try_end, module_name);
+
+	strcpy(try_end+modname_len, suffix_to_use);
+
+	/* See whether the file exists and is readable. */
+	if (access (try,R_OK) == 0)
+	  {
+	    if ( no_of_matches == 0 ) 
+		strcpy(returned_filename, try);
+
+	    /* Return as soon as a match is found in the source directory. */
+	    if (!tried_source_dir)
+	      return;
+
+#ifdef HAVE_STAT
+    	    if ( no_of_matches < MAX_MATCH && stat(try, sbuf + no_of_matches) == 0 )
+    	      {
+    	    	int i;
+    	    	for (i = 0; i < no_of_matches; i++)
+    	    	  {
+    	    	    if ( sbuf[no_of_matches].st_dev == sbuf[i].st_dev &&
+    	    	    	 sbuf[no_of_matches].st_ino == sbuf[i].st_ino)
+    	    	      goto next;    /* Skip dups */
+    	    	  }
+              }
+#endif /* HAVE_STAT */
+    	    no_of_matches++;
+	  }
+	else if (access (try,F_OK) == 0)
+	  fprintf(stderr,"Warning: %s exists, but is not readable\n",try);
+
+      next:	
+	tried_source_dir = TRUE;
+      }
+
+    if ( no_of_matches == 0 && ! is_sys_import ) { /* Nothing so far */
+
+	/* If we are explicitly meddling about with .hi suffixes,
+	   then some system-supplied modules may need to be looked
+	   for with PreludeHiSuffix; unsavoury but true...
+	*/
+	suffix_to_use = PreludeHiSuffix;
+
+	for (imports_dirs = sys_imports_dirlist;
+	     tlist(imports_dirs) == lcons; 
+	     imports_dirs = ltl(imports_dirs))
+	  {
+	    char *dir = (char *) lhd(imports_dirs);
+	    strcpy(try, dir);
+
+	    try_end = try + strlen(try);
+
+#ifdef macintosh /* ToDo: use DIR_SEP_STRING */
+	    if (*(try_end - 1) != ':')
+		strcpy (try_end++, ":");
+#else
+	    if (*(try_end - 1) != '/')
+	      strcpy (try_end++, "/");
+#endif /* ! macintosh */
+
+	    strcpy(try_end, module_name);
+
+	    strcpy(try_end+modname_len, suffix_to_use);
+
+	    /* See whether the file exists and is readable. */
+	    if (access (try,R_OK) == 0)
+	      {
+		if ( no_of_matches == 0 ) 
+		    strcpy(returned_filename, try);
+
+#ifdef HAVE_STAT
+    	        if ( no_of_matches < MAX_MATCH && stat(try, sbuf + no_of_matches) == 0 )
+    	          {
+    	    	    int i;
+    	    	    for (i = 0; i < no_of_matches; i++)
+    	    	      {
+    	    	        if ( sbuf[no_of_matches].st_dev == sbuf[i].st_dev &&
+    	    	    	     sbuf[no_of_matches].st_ino == sbuf[i].st_ino)
+    	    	          goto next_again;    /* Skip dups */
+    	    	      }
+                  }
+#endif /* HAVE_STAT */
+    	        no_of_matches++;
+	      }
+	    else if (access (try,F_OK) == 0)
+	      fprintf(stderr,"Warning: %s exists, but is not readable\n",try);
+          next_again:
+	   /*NOTHING*/;
+	  }
+    }
+
+    /* Error checking */
+
+    switch ( no_of_matches ) {
+    default:
+	  fprintf(stderr,"Warning: found %d %s files for module \"%s\"\n",
+			no_of_matches, suffix_to_report, module_name);
+    	  break;
+    case 0:
+    	  {
+	    char disaster_msg[MODNAME_SIZE+1000];
+	    sprintf(disaster_msg,"can't find interface (%s) file for module \"%s\"%s",
+			suffix_to_report, module_name,
+			(strncmp(module_name, "PreludeGlaIO", 12) == 0)
+			? "\n(The PreludeGlaIO interface no longer exists);"
+			:(
+			(strncmp(module_name, "PreludePrimIO", 13) == 0)
+			? "\n(The PreludePrimIO interface no longer exists -- just use PreludeGlaST);"
+			:(
+			(strncmp(module_name, "Prelude", 7) == 0)
+			? "\n(Perhaps you forgot a `-fglasgow-exts' flag?);"
+			: ""
+	    )));
+	    hsperror(disaster_msg);
+    	    break;
+    	  }
+    case 1:
+    	/* Everything is fine */
+    	break;
+    }
+}
diff --git a/ghc/compiler/parser/infix.c b/ghc/compiler/parser/infix.c
new file mode 100644
index 0000000000..627fb92473
--- /dev/null
+++ b/ghc/compiler/parser/infix.c
@@ -0,0 +1,200 @@
+/*
+ *	Infix operator stuff -- modified from LML
+ */
+
+#include <stdio.h>
+
+#include "hspincl.h"
+#include "hsparser.tab.h"
+#include "constants.h"
+#include "utils.h"
+
+static struct infix {
+    char *imod;
+    char *iop;
+    short thismod;
+    short unqualok;
+    short ifixity;
+    short iprecedence;
+} infixtab[MAX_INFIX];
+
+static int ninfix = 0;
+
+void
+makeinfix(opid, fixity, precedence, modid, imported,
+	  withas, impmodid, impasid, withqual,
+	  withspec, withhiding, importspec)
+  id opid;
+  int fixity, precedence;
+  long imported, withas, withqual, withspec, withhiding;
+  id modid, impmodid, impasid;
+  list importspec;
+/*
+  ToDo: Throw away infix operator if hidden by importspec!
+*/
+{
+    int i;
+    char *op = id_to_string(opid);
+    char *mod = id_to_string(imported ? (withas ? impasid : impmodid) : modid);
+    short thismod = ! imported;
+    short unqualok = ! (imported && withqual);
+
+    for(i=0; i < ninfix; ++i)
+      {
+	if(strcmp(op,infixtab[i].iop)==0 &&
+	   strcmp(mod,infixtab[i].imod)==0 &&
+	   unqualok==infixtab[i].unqualok)
+	  {
+	    /* Allow duplicate definitions if they are identical */
+	    if (infixtab[i].ifixity==fixity && 
+	        infixtab[i].iprecedence==precedence)
+	      {
+		return;
+	      }
+
+	    /* Allow local definition to override an import */
+	    else if(thismod && !infixtab[i].thismod)
+	      {
+		/*continue*/
+	      }
+
+	    else
+	      {
+		char errbuf[ERR_BUF_SIZE];
+		sprintf(errbuf,"%s.%s %s already declared to be %s %d\n",
+			mod, op, unqualok ? "(unqualified)" : "(qualified)",
+			infixstr(infixtab[i].ifixity),
+			infixtab[i].iprecedence);
+		hsperror(errbuf);
+	      }
+	  }
+      }
+
+    if (ninfix >= MAX_INFIX) {
+        char errbuf[ERR_BUF_SIZE];
+	sprintf(errbuf,"Too many Infix identifiers (> %d)",MAX_INFIX);
+	hsperror(errbuf);
+    }
+
+#ifdef HSP_DEBUG
+    fprintf(stderr,"makeinfix: %s.%s, fixity=%d prec=%d\n",mod,op,infixint(fixity),precedence);
+#endif
+    infixtab[ninfix].imod = mod;
+    infixtab[ninfix].iop = op;
+    infixtab[ninfix].thismod = thismod;
+    infixtab[ninfix].unqualok = unqualok;
+    infixtab[ninfix].ifixity = fixity;
+    infixtab[ninfix].iprecedence = precedence;
+    ninfix++;
+}
+
+struct infix *
+infixlookup(name)
+  qid name;
+{
+    int i;
+    struct infix *found = NULL;
+    char *op  = qid_to_string(name);
+    char *mod = qid_to_mod(name);
+    short unqual = mod == NULL;
+
+    for(i = 0; i < ninfix; i++)
+      {
+	if(strcmp(op,infixtab[i].iop)==0 &&
+	   ( (unqual && infixtab[i].unqualok) ||
+	     (!unqual && strcmp(mod,infixtab[i].imod)==0)
+	   ))
+	  {
+	    if (! found)
+	      {
+		/* first find */
+		found = infixtab+i;
+	      }
+	    else if (found && ! found->thismod && infixtab[i].thismod)
+	      {
+		/* new find for this module; overrides */
+		found = infixtab+i;
+	      }
+	    else if (found && found->thismod && ! infixtab[i].thismod)
+	      {
+		/* prev find for this module */
+	      }
+	    else if (found->ifixity == infixtab[i].ifixity &&
+		     found->iprecedence == infixtab[i].iprecedence)
+	      {
+	        /* finds are identical */
+	      }
+	    else
+	      {
+		char errbuf[ERR_BUF_SIZE];
+		sprintf(errbuf,"conflicting infix declarations for %s.%s\n  %s.%s %s (%s,%d) and %s.%s %s (%s,%d)\n",
+			qid_to_pmod(name), op,
+			found->imod, found->iop, found->unqualok ? "(unqualified)" : "(qualified)",
+			   infixstr(found->ifixity),found->iprecedence,
+			infixtab[i].imod, infixtab[i].iop, infixtab[i].unqualok ? "(unqualified)" : "(qualified)",
+			   infixstr(infixtab[i].ifixity),infixtab[i].iprecedence);
+		hsperror(errbuf);
+
+	      }
+	  }
+      }
+
+#ifdef HSP_DEBUG
+  fprintf(stderr,"infixlookup: %s.%s = fixity=%d prec=%d\n",qid_to_pmod(name),op,infixint(pfixity(found)),pprecedence(found));
+#endif
+
+  return(found);
+}
+
+int
+pfixity(ip)
+  struct infix *ip;
+{
+  return(ip == NULL? INFIXL: ip->ifixity);
+}
+
+int
+pprecedence(ip)
+  struct infix *ip;
+{
+  return(ip == NULL? 9: ip->iprecedence);
+}
+
+char *
+infixstr(n)
+  int n;
+{
+  switch(n) {
+    case INFIXL:
+      return "infixl";
+      
+    case INFIXR:
+      return "infixr";
+	
+    case INFIX:
+      return "infix";
+
+    default:
+      hsperror("infixstr");
+  }
+}
+
+long
+infixint(n)
+  int n;
+{
+  switch(n) {
+    case INFIXL:
+      return -1;
+      
+    case INFIX:
+      return 0;
+
+    case INFIXR:
+      return 1;
+	
+    default:
+      hsperror("infixint");
+  }
+}
+
diff --git a/ghc/compiler/parser/list.ugn b/ghc/compiler/parser/list.ugn
new file mode 100644
index 0000000000..6ffd8920c6
--- /dev/null
+++ b/ghc/compiler/parser/list.ugn
@@ -0,0 +1,13 @@
+%{
+#include "hspincl.h"
+%}
+%{{
+module U_list where
+import Ubiq --  debugging consistency check
+import UgenUtil
+%}}
+type list;
+	lcons	: < lhd	: VOID_STAR;
+		    ltl : list; >;
+	lnil	: <>;
+end;
diff --git a/ghc/compiler/parser/literal.ugn b/ghc/compiler/parser/literal.ugn
new file mode 100644
index 0000000000..d8424a45ff
--- /dev/null
+++ b/ghc/compiler/parser/literal.ugn
@@ -0,0 +1,25 @@
+%{
+#include "hspincl.h"
+%}
+%{{
+module U_literal where
+import Ubiq --  debugging consistency check
+import UgenUtil
+%}}
+type literal;
+	integer	    : < ginteger    : stringId; >;
+	intprim	    : < gintprim    : stringId; >;
+	floatr	    : < gfloatr	    : stringId; >;
+	doubleprim  : < gdoubleprim : stringId; >;
+	floatprim   : < gfloatprim  : stringId; >;
+	charr	    : < gchar	    : hstring; >;
+	charprim    : < gcharprim   : hstring; >;
+	string	    : < gstring	    : hstring; >;
+	stringprim  : < gstringprim : hstring; >;
+	clitlit	    : < gclitlit    : stringId;
+			gclitlit_kind : stringId; >;
+	norepi	    : < gnorepi	    : stringId; >;
+	norepr	    : < gnorepr_n   : stringId; 
+			gnorepr_d   : stringId; >;
+	noreps	    : < gnoreps	    : hstring; >;
+end;
diff --git a/ghc/compiler/parser/main.c b/ghc/compiler/parser/main.c
new file mode 100644
index 0000000000..8463644a77
--- /dev/null
+++ b/ghc/compiler/parser/main.c
@@ -0,0 +1,54 @@
+/* This is the "top-level" file for the *standalone* hsp parser.
+   See also hsclink.c.  (WDP 94/10)
+*/
+
+#include <stdio.h>
+
+#include "hspincl.h"
+#include "constants.h"
+#include "utils.h"
+
+/*OLD:static char *progname;*/		/* The name of the program.              */
+
+
+/**********************************************************************
+*                                                                     *
+*                                                                     *
+*     The main program                                                *
+*                                                                     *
+*                                                                     *
+**********************************************************************/
+
+int
+main(int argc, char **argv)
+{
+    Lnil = mklnil();	/* The null list -- used in lsing, etc. */
+
+    process_args(argc,argv);
+
+    hash_init();
+
+#ifdef HSP_DEBUG
+    fprintf(stderr,"input_file_dir=%s\n",input_file_dir);
+#endif
+
+    yyinit();
+
+    if(yyparse() == 0 && !etags)
+      {
+	/* No syntax errors. */
+	pprogram(root);
+	printf("\n");
+	exit(0);
+      } 
+    else if(etags)
+      {
+	exit(0);
+      }
+    else
+      {
+	/* There was a syntax error. */
+	printf("\n");
+	exit(1);
+      }
+}
diff --git a/ghc/compiler/parser/maybe.ugn b/ghc/compiler/parser/maybe.ugn
new file mode 100644
index 0000000000..a9120832c1
--- /dev/null
+++ b/ghc/compiler/parser/maybe.ugn
@@ -0,0 +1,12 @@
+%{
+#include "hspincl.h"
+%}
+%{{
+module U_maybe where
+import Ubiq --  debugging consistency check
+import UgenUtil
+%}}
+type maybe;
+	nothing	: <> ;
+	just	: < gthing : VOID_STAR; > ;
+end;
diff --git a/ghc/compiler/parser/pbinding.ugn b/ghc/compiler/parser/pbinding.ugn
new file mode 100644
index 0000000000..03e76889ad
--- /dev/null
+++ b/ghc/compiler/parser/pbinding.ugn
@@ -0,0 +1,31 @@
+%{
+#include "hspincl.h"
+%}
+%{{
+module U_pbinding where
+import Ubiq --  debugging consistency check
+import UgenUtil
+
+import U_constr		( U_constr )	-- interface only
+import U_binding
+import U_coresyn	( U_coresyn )	-- ditto
+import U_hpragma	( U_hpragma )	-- ditto
+import U_list
+import U_literal	( U_literal )	-- ditto
+import U_maybe		( U_maybe )	-- ditto
+import U_qid
+import U_tree
+import U_ttype		( U_ttype )	-- ditto
+%}}
+type pbinding;
+	pgrhs	: < ggpat	: tree;
+		    ggdexprs	: pbinding;
+		    ggbind	: binding;
+	 	    ggfuncname	: qid;
+		    ggline	: long; >;
+
+	pnoguards : < gpnoguard : tree; >;
+	pguards   : < gpguards  : list; >;
+	pgdexp	  : < gpguard	: tree;
+	              gpexp     : tree; >;
+end;
diff --git a/ghc/compiler/parser/printtree.c b/ghc/compiler/parser/printtree.c
new file mode 100644
index 0000000000..a5056ef635
--- /dev/null
+++ b/ghc/compiler/parser/printtree.c
@@ -0,0 +1,934 @@
+/**********************************************************************
+*                                                                     *
+*                                                                     *
+*      Syntax Tree Printing Routines                                  *
+*                                                                     *
+*                                                                     *
+**********************************************************************/
+
+
+#define	COMPACT	TRUE	/* No spaces in output -- #undef this for debugging */
+
+
+#include <stdio.h>
+
+#include "hspincl.h"
+#include "constants.h"
+#include "utils.h"
+
+/* fwd decls, necessary and otherwise */
+static void pbool   PROTO( (BOOLEAN) );
+static void pconstr PROTO( (constr) );
+static void pcoresyn PROTO((coresyn));
+static void pentid  PROTO( (entidt) );
+static void pgrhses PROTO( (list) );
+static void pid	    PROTO( (id) );
+static void plist   PROTO( (void (*)(/*NOT WORTH IT: void * */), list) );
+static void pmaybe  PROTO( (void (*)(), maybe) );
+static void pmaybe_list  PROTO( (void (*)(), maybe) );
+static void ppbinding PROTO((pbinding));
+static void ppragma PROTO( (hpragma) );
+static void pqid    PROTO( (qid) );
+static void prbind  PROTO( (binding) );
+static void pstr    PROTO( (char *) );
+static void ptree   PROTO( (tree) );
+static void pttype  PROTO( (ttype) );
+
+extern char *input_filename;
+extern BOOLEAN hashIds;
+
+/*	How to print tags	*/
+
+#if COMPACT
+#define	PUTTAG(c)	putchar(c);
+#define PUTTAGSTR(s)	printf("%s",(s));
+#else
+#define	PUTTAG(c)	putchar(c); \
+  			putchar(' ');
+#define PUTTAGSTR(s)	printf("%s",(s)); \
+			putchar(' ');
+#endif
+
+
+/* 	Performs a post order walk of the tree
+	to print it.
+*/
+
+void
+pprogram(t)
+  tree t;
+{
+    print_hash_table();
+    ptree(t);
+}
+
+/* print_string: we must escape \t and \\, as described in
+   char/string lexer comments.  (WDP 94/11)
+*/
+static void
+print_string(hstring str)
+{
+    char *gs;
+    char c;
+    int i, str_length;
+
+    putchar('#');
+    str_length = str->len;
+    gs = str->bytes;
+
+    for (i = 0; i < str_length; i++) {
+	c = gs[i];
+	if ( c == '\t' ) {
+	    putchar('\\');
+	    putchar('t');
+	} else if ( c == '\\' ) {
+	    putchar('\\');
+	    putchar('\\');
+	} else {
+	    putchar(gs[i]);
+	}
+    }
+    putchar('\t');
+}
+
+static int
+get_character(hstring str)
+{
+    int c = (int)((str->bytes)[0]);
+
+    if (str->len != 1) { /* ToDo: assert */
+	fprintf(stderr, "get_character: length != 1? (%ld: %s)\n", str->len, str->bytes);
+    }
+
+    if (c < 0) {
+	c += 256; 	/* "This is not a hack" -- KH */
+    }
+
+    return(c);
+}
+
+static void
+pliteral(literal t)
+{
+    switch(tliteral(t)) {
+      case integer:
+		      PUTTAG('4');
+		      pstr(ginteger(t));
+		      break;
+      case intprim:
+		      PUTTAG('H');
+		      pstr(gintprim(t));
+		      break;
+      case floatr:
+		      PUTTAG('F');
+		      pstr(gfloatr(t));
+		      break;
+      case doubleprim:
+		      PUTTAG('J');
+		      pstr(gdoubleprim(t));
+		      break;
+      case floatprim:
+		      PUTTAG('K');
+		      pstr(gfloatprim(t));
+		      break;
+      case charr:
+		      PUTTAG('C');
+		      /* Changed %d to %u, since negative chars
+			 make little sense -- KH @ 16/4/91
+		      */
+		      printf("#%u\t", get_character(gchar(t)));
+		      break;
+      case charprim:
+		      PUTTAG('P');
+		      printf("#%u\t", get_character(gcharprim(t)));
+		      break;
+      case string:
+		      PUTTAG('S');
+		      print_string(gstring(t));
+		      break;
+      case stringprim:
+		      PUTTAG('V');
+		      print_string(gstringprim(t));
+		      break;
+      case clitlit:
+		      PUTTAG('Y');
+		      pstr(gclitlit(t));
+		      pstr(gclitlit_kind(t));
+		      break;
+
+      case norepi:
+		      PUTTAG('I');
+		      pstr(gnorepi(t));
+		      break;
+      case norepr:
+		      PUTTAG('R');
+		      pstr(gnorepr_n(t));
+		      pstr(gnorepr_d(t));
+		      break;
+      case noreps:
+		      PUTTAG('s');
+		      print_string(gnoreps(t));
+		      break;
+      default:
+		      error("Bad pliteral");
+    }
+}
+
+static void
+ptree(t)
+  tree t;
+{
+again:
+    switch(ttree(t)) {
+      case par:		t = gpare(t); goto again;
+      case hmodule:
+		      PUTTAG('M');
+		      printf("#%lu\t",ghmodline(t));
+		      pid(ghname(t));
+		      pstr(input_filename);
+		      prbind(ghmodlist(t));
+	              /* pfixes(); */
+		      plist(prbind, ghimplist(t));
+		      pmaybe_list(pentid, ghexplist(t));
+		      break;
+      case ident: 
+		      PUTTAG('i');
+		      pqid(gident(t));
+		      break;
+      case lit:
+		      PUTTAG('C');
+		      pliteral(glit(t));
+		      break;
+
+      case ap: 
+		      PUTTAG('a');
+		      ptree(gfun(t)); 
+		      ptree(garg(t)); 
+		      break;
+      case infixap: 
+		      PUTTAG('@');
+		      pqid(ginffun(t));
+		      ptree(ginfarg1(t));
+		      ptree(ginfarg2(t));
+		      break;
+      case lambda: 
+		      PUTTAG('l');
+		      printf("#%lu\t",glamline(t));
+		      plist(ptree,glampats(t));
+		      ptree(glamexpr(t));
+		      break;
+
+      case let: 
+		      PUTTAG('E');
+		      prbind(gletvdefs(t));
+		      ptree(gletvexpr(t));
+		      break;
+      case casee:
+		      PUTTAG('c');
+		      ptree(gcaseexpr(t));
+		      plist(ppbinding, gcasebody(t));
+		      break;
+      case ife:
+		      PUTTAG('b');
+		      ptree(gifpred(t));
+		      ptree(gifthen(t));
+		      ptree(gifelse(t));
+		      break;
+      /* case doe: */
+      /* case dobind: */
+      /* case doexp: */
+      /* case seqlet: */
+      /* case record: */
+      /* case rupdate: */
+      /* case rbind: */
+
+      case as:
+		      PUTTAG('s');
+		      pqid(gasid(t));
+		      ptree(gase(t));
+		      break;
+      case lazyp:
+		      PUTTAG('~');
+		      ptree(glazyp(t));
+		      break;
+      case wildp:
+		      PUTTAG('_');
+		      break;
+
+      case restr:
+		      PUTTAG('R');
+		      ptree(grestre(t));
+		      pttype(grestrt(t));
+		      break;
+      case tuple:
+		      PUTTAG(',');
+		      plist(ptree,gtuplelist(t));
+		      break;
+      case llist:
+		      PUTTAG(':');
+		      plist(ptree,gllist(t));
+		      break;
+      case eenum:
+		      PUTTAG('.');
+		      ptree(gefrom(t));
+		      pmaybe(ptree,gestep(t));
+		      pmaybe(ptree,geto(t));
+		      break;
+      case comprh:
+		      PUTTAG('Z');
+		      ptree(gcexp(t));
+		      plist(ptree,gcquals(t));
+		      break;
+      case qual:
+		      PUTTAG('G');
+		      ptree(gqpat(t));
+		      ptree(gqexp(t));
+		      break;
+      case guard:
+		      PUTTAG('g');
+		      ptree(ggexp(t));
+		      break;
+      case lsection:
+		      PUTTAG('(');
+		      ptree(glsexp(t)); 
+		      pqid(glsop(t)); 
+		      break;
+      case rsection:
+		      PUTTAG(')');
+		      pqid(grsop(t)); 
+		      ptree(grsexp(t)); 
+		      break;
+      case ccall:
+		      PUTTAG('j');
+		      pstr(gccid(t));
+		      pstr(gccinfo(t));
+		      plist(ptree,gccargs(t));
+		      break;
+      case scc:
+		      PUTTAG('k');
+		      print_string(gsccid(t));
+		      ptree(gsccexp(t));
+		      break;
+      case negate:
+		      PUTTAG('-');
+		      ptree(gnexp(t));
+		      break;
+      default:
+		      error("Bad ptree");
+    }
+}
+
+static void
+plist(fun, l)
+  void (*fun)(/* NOT WORTH IT: void * */);
+  list l;
+{
+    if (tlist(l) == lnil) {
+	PUTTAG('N');
+    } else  {
+	PUTTAG('L');
+	(*fun)(lhd(l));
+	plist(fun, ltl(l));
+    }
+}
+
+static void
+pmaybe(fun, m)
+  void (*fun)(/* NOT WORTH IT: void * */);
+  maybe m;
+{
+    if (tmaybe(m) == nothing) {
+	PUTTAG('N');
+    } else  {
+	PUTTAG('J');
+	(*fun)(gthing(m));
+    }
+}
+
+static void
+pmaybe_list(fun, m)
+  void (*fun)(/* NOT WORTH IT: void * */);
+  maybe m;
+{
+    if (tmaybe(m) == nothing) {
+	PUTTAG('N');
+    } else  {
+	PUTTAG('J');
+	plist(fun, gthing(m));
+    }
+}
+
+static void
+pid(i)
+  id i;
+{
+  if(hashIds)
+	printf("!%lu\t", hash_index(i));
+  else
+	printf("#%s\t", id_to_string(i));
+}
+
+static void
+pqid(i)
+  qid i;
+{
+  if(hashIds)
+	printf("!%lu\t", hash_index(qid_to_id(i)));
+  else
+	printf("#%s\t", qid_to_string(i));
+}
+
+static void
+pstr(i)
+  char *i;
+{
+	printf("#%s\t", i);
+}
+
+static void
+prbind(b)
+  binding b;
+{
+	switch(tbinding(b)) {
+	case tbind: 
+			  PUTTAG('t');
+			  printf("#%lu\t",gtline(b));
+			  plist(pttype, gtbindc(b));
+			  pmaybe_list(pid, gtbindd(b));
+			  pttype(gtbindid(b));
+			  plist(pconstr, gtbindl(b));
+			  ppragma(gtpragma(b));
+			  break;
+	/* case ntbind: */
+	case nbind	: 
+			  PUTTAG('n');
+			  printf("#%lu\t",gnline(b));
+			  pttype(gnbindid(b));
+			  pttype(gnbindas(b));
+			  break;
+	case pbind	: 
+			  PUTTAG('p');
+			  printf("#%lu\t",gpline(b));
+			  plist(ppbinding, gpbindl(b));
+			  break;
+	case fbind	: 
+			  PUTTAG('f');
+			  printf("#%lu\t",gfline(b));
+			  plist(ppbinding, gfbindl(b));
+			  break;
+	case abind	: 
+			  PUTTAG('A');
+			  prbind(gabindfst(b));
+			  prbind(gabindsnd(b));
+			  break;
+	case cbind	:
+			  PUTTAG('$');
+			  printf("#%lu\t",gcline(b));
+			  plist(pttype,gcbindc(b));
+			  pttype(gcbindid(b));
+			  prbind(gcbindw(b));
+			  ppragma(gcpragma(b));
+			  break;
+	case ibind	:
+			  PUTTAG('%');
+			  printf("#%lu\t",giline(b));
+			  plist(pttype,gibindc(b));
+			  pqid(gibindid(b));
+			  pttype(gibindi(b));
+			  prbind(gibindw(b));
+			  ppragma(gipragma(b));
+			  break;
+	case dbind	:
+			  PUTTAG('D');
+			  printf("#%lu\t",gdline(b));
+			  plist(pttype,gdbindts(b));
+			  break;
+
+	/* signature(-like) things, including user pragmas */
+	case sbind	:
+			  PUTTAGSTR("St");
+			  printf("#%lu\t",gsline(b));
+			  plist(pqid,gsbindids(b));
+			  pttype(gsbindid(b));
+			  ppragma(gspragma(b));
+			  break;
+
+	case vspec_uprag:
+			  PUTTAGSTR("Ss");
+			  printf("#%lu\t",gvspec_line(b));
+			  pqid(gvspec_id(b));
+			  plist(pttype,gvspec_tys(b));
+			  break;
+	case ispec_uprag:
+			  PUTTAGSTR("SS");
+			  printf("#%lu\t",gispec_line(b));
+			  pqid(gispec_clas(b));
+			  pttype(gispec_ty(b));
+			  break;
+	case inline_uprag:
+			  PUTTAGSTR("Si");
+			  printf("#%lu\t",ginline_line(b));
+			  pqid(ginline_id(b));
+			  break;
+	case deforest_uprag:
+			  PUTTAGSTR("Sd");
+			  printf("#%lu\t",gdeforest_line(b));
+			  pqid(gdeforest_id(b));
+			  break;
+	case magicuf_uprag:
+			  PUTTAGSTR("Su");
+			  printf("#%lu\t",gmagicuf_line(b));
+			  pqid(gmagicuf_id(b));
+			  pid(gmagicuf_str(b));
+			  break;
+	case dspec_uprag:
+			  PUTTAGSTR("Sd");
+			  printf("#%lu\t",gdspec_line(b));
+			  pqid(gdspec_id(b));
+			  plist(pttype,gdspec_tys(b));
+			  break;
+
+	/* end of signature(-like) things */
+
+	case mbind:	  
+			  PUTTAG('7');
+			  printf("#%lu\t",gmline(b));
+			  pid(gmbindmodn(b));
+			  plist(pentid,gmbindimp(b));
+			  break;
+	case import:	  
+			  PUTTAG('e');
+			  printf("#%lu\t",gibindline(b));
+			  pid(gibindfile(b));
+			  pid(gibindmod(b));
+			  /* plist(pentid,giebindexp(b)); ??? */
+			  /* prbind(giebinddef(b)); ???? */
+			  break;
+	case nullbind	:
+			  PUTTAG('B');
+			  break;
+	default		: error("Bad prbind");
+			  break;
+	}
+}
+
+static void
+pttype(t)
+  ttype t;
+{
+	switch (tttype(t)) {
+	case tname	: PUTTAG('T');
+			  pqid(gtypeid(t));
+			  break;
+	case namedtvar	: PUTTAG('y');
+			  pid(gnamedtvar(t));
+			  break;
+	case tllist	: PUTTAG(':');
+			  pttype(gtlist(t));
+			  break;
+	case ttuple	: PUTTAG(',');
+			  plist(pttype,gttuple(t));
+			  break;
+	case tfun	: PUTTAG('>');
+			  pttype(gtin(t));
+			  pttype(gtout(t));
+			  break;
+	case tapp	: PUTTAG('@');
+			  pttype(gtapp(t));
+			  pttype(gtarg(t));
+			  break;
+	case tbang	: PUTTAG('!');
+			  pttype(gtbang(t));
+			  break;
+	case context	: PUTTAG('3');
+			  plist(pttype,gtcontextl(t));
+			  pttype(gtcontextt(t));
+			  break;
+
+	case unidict	: PUTTAGSTR("2A");
+			  pqid(gunidict_clas(t));
+			  pttype(gunidict_ty(t));
+			  break;
+	case unityvartemplate : PUTTAGSTR("2B");
+			  pid(gunityvartemplate(t));
+			  break;
+	case uniforall	: PUTTAGSTR("2C");
+			  plist(pid,guniforall_tv(t));
+			  pttype(guniforall_ty(t));
+			  break;
+
+	default		: error("bad pttype");
+	}
+}
+
+static void
+pconstr(a)
+  constr a;
+{
+	switch (tconstr(a)) {
+	case constrpre	:
+			  PUTTAG('1');
+			  printf("#%lu\t",gconcline(a));
+			  pqid(gconcid(a));
+			  plist(pttype, gconctypel(a));
+			  break;
+	case constrinf	:
+			  PUTTAG('2');
+			  printf("#%lu\t",gconiline(a));
+			  pqid(gconiop(a));
+			  pttype(gconity1(a));
+			  pttype(gconity2(a));
+			  break;
+
+	default		: fprintf(stderr, "Bad tag in abstree %d\n", tconstr(a));
+			  exit(1);
+	}
+}
+
+
+static void
+pentid(i)
+  entidt i;
+{
+	switch (tentidt(i)) {
+	case entid	: PUTTAG('x');
+			  pqid(gentid(i));
+			  break;
+	case enttype	: PUTTAG('X');
+			  pqid(gtentid(i));
+			  break;
+	case enttypeall	: PUTTAG('z');
+			  pqid(gaentid(i));
+			  break;
+	case enttypenamed:PUTTAG('8');
+			  pqid(gnentid(i));
+			  plist(pqid,gnentnames(i));
+			  break;
+	case entmod	: PUTTAG('m');
+			  pid(gmentid(i));
+			  break;
+	default	        :
+			  error("Bad pentid");
+	}
+}
+
+
+static void
+ppbinding(p)
+  pbinding p;
+{
+	switch(tpbinding(p)) {
+	case pgrhs	: PUTTAG('W');
+  			  printf("#%lu\t",ggline(p));
+	  		  pqid(ggfuncname(p));
+			  ptree(ggpat(p));
+			  plist(pgrhses,ggdexprs(p));
+	  		  prbind(ggbind(p));
+	  		  break;
+	default	        :
+			  error("Bad pbinding");
+	}
+}
+
+
+static void
+pgrhses(l)
+  list l;
+{
+  ptree(lhd(l));		/* Guard */
+  ptree(lhd(ltl(l)));		/* Expression */
+}
+
+static void
+ppragma(p)
+  hpragma p;
+{
+    switch(thpragma(p)) {
+      case no_pragma:		PUTTAGSTR("PN");
+				break;
+      case idata_pragma:	PUTTAGSTR("Pd");
+				plist(pconstr, gprag_data_constrs(p));
+				plist(ppragma, gprag_data_specs(p));
+				break;
+      case itype_pragma:	PUTTAGSTR("Pt");
+				break;
+      case iclas_pragma:	PUTTAGSTR("Pc");
+				plist(ppragma, gprag_clas(p));
+				break;
+      case iclasop_pragma:	PUTTAGSTR("Po");
+				ppragma(gprag_dsel(p));
+				ppragma(gprag_defm(p));
+				break;
+
+      case iinst_simpl_pragma:	PUTTAGSTR("Pis");
+				pid(gprag_imod_simpl(p));
+				ppragma(gprag_dfun_simpl(p));
+				break;
+      case iinst_const_pragma:	PUTTAGSTR("Pic");
+				pid(gprag_imod_const(p));
+				ppragma(gprag_dfun_const(p));
+				plist(ppragma, gprag_constms(p));
+				break;
+
+      case igen_pragma:		PUTTAGSTR("Pg");
+				ppragma(gprag_arity(p));
+				ppragma(gprag_update(p));
+				ppragma(gprag_deforest(p));
+				ppragma(gprag_strictness(p));
+				ppragma(gprag_unfolding(p));
+				plist(ppragma, gprag_specs(p));
+				break;
+      case iarity_pragma:	PUTTAGSTR("PA");
+				pid(gprag_arity_val(p));
+				break;
+      case iupdate_pragma:	PUTTAGSTR("Pu");
+				pid(gprag_update_val(p));
+				break;
+      case ideforest_pragma:	PUTTAGSTR("PD");
+				break;
+      case istrictness_pragma:	PUTTAGSTR("PS");
+				print_string(gprag_strict_spec(p));
+				ppragma(gprag_strict_wrkr(p));
+				break;
+      case imagic_unfolding_pragma: PUTTAGSTR("PM");
+				pid(gprag_magic_str(p));
+				break;
+
+      case iunfolding_pragma:	PUTTAGSTR("PU");
+				ppragma(gprag_unfold_guide(p));
+				pcoresyn(gprag_unfold_core(p));
+				break;
+
+      case iunfold_always:	PUTTAGSTR("Px");
+				break;
+      case iunfold_if_args:	PUTTAGSTR("Py");
+				pid(gprag_unfold_if_t_args(p));
+				pid(gprag_unfold_if_v_args(p));
+				pid(gprag_unfold_if_con_args(p));
+				pid(gprag_unfold_if_size(p));
+				break;
+
+      case iname_pragma_pr:	PUTTAGSTR("P1");
+				pid(gprag_name_pr1(p));
+				ppragma(gprag_name_pr2(p));
+				break;
+      case itype_pragma_pr:	PUTTAGSTR("P2");
+				plist(pttype, gprag_type_pr1(p));
+				pid(gprag_type_pr2(p));
+				ppragma(gprag_type_pr3(p));
+				break;
+
+      case idata_pragma_4s:	PUTTAGSTR("P4");
+				plist(pttype, gprag_data_spec(p));
+	                        break;
+
+      default:           	error("Bad Pragma");
+      }
+}
+
+static void
+pbool(b)
+  BOOLEAN b;
+{
+    if (b) {
+      putchar('T');
+    } else {
+      putchar('F');
+    }
+}
+
+static void
+pcoresyn(p)
+  coresyn p;
+{
+    switch(tcoresyn(p)) {
+      case cobinder:		PUTTAGSTR("Fa");
+			    	pid(gcobinder_v(p));
+				pttype(gcobinder_ty(p));
+				break;
+
+      case colit:		PUTTAGSTR("Fb");
+				pliteral(gcolit(p));
+				break;
+      case colocal:		PUTTAGSTR("Fc");
+				pcoresyn(gcolocal_v(p));
+				break;
+
+      case cononrec:		PUTTAGSTR("Fd");
+				pcoresyn(gcononrec_b(p));
+				pcoresyn(gcononrec_rhs(p));
+				break;
+      case corec:		PUTTAGSTR("Fe");
+				plist(pcoresyn,gcorec(p));
+				break;
+      case corec_pair:		PUTTAGSTR("Ff");
+				pcoresyn(gcorec_b(p));
+				pcoresyn(gcorec_rhs(p));
+				break;		
+
+      case covar:		PUTTAGSTR("Fg");
+				pcoresyn(gcovar(p));
+				break;
+      case coliteral:		PUTTAGSTR("Fh");
+				pliteral(gcoliteral(p));
+				break;
+      case cocon:		PUTTAGSTR("Fi");
+				pcoresyn(gcocon_con(p));
+				plist(pttype, gcocon_tys(p));
+				plist(pcoresyn, gcocon_args(p));
+				break;
+      case coprim:		PUTTAGSTR("Fj");
+				pcoresyn(gcoprim_op(p));
+				plist(pttype, gcoprim_tys(p));
+				plist(pcoresyn, gcoprim_args(p));
+				break;
+      case colam:		PUTTAGSTR("Fk");
+				plist(pcoresyn, gcolam_vars(p));
+				pcoresyn(gcolam_body(p));
+				break;
+      case cotylam:		PUTTAGSTR("Fl");
+				plist(pid, gcotylam_tvs(p));
+				pcoresyn(gcotylam_body(p));
+				break;
+      case coapp:		PUTTAGSTR("Fm");
+				pcoresyn(gcoapp_fun(p));
+				plist(pcoresyn, gcoapp_args(p));
+				break;
+      case cotyapp:		PUTTAGSTR("Fn");
+				pcoresyn(gcotyapp_e(p));
+				pttype(gcotyapp_t(p));
+				break;
+      case cocase:		PUTTAGSTR("Fo");
+				pcoresyn(gcocase_s(p));
+				pcoresyn(gcocase_alts(p));
+				break;
+      case colet:		PUTTAGSTR("Fp");
+				pcoresyn(gcolet_bind(p));
+				pcoresyn(gcolet_body(p));
+				break;
+      case coscc:		PUTTAGSTR("Fz");	/* out of order! */
+				pcoresyn(gcoscc_scc(p));
+				pcoresyn(gcoscc_body(p));
+				break;
+
+      case coalg_alts:		PUTTAGSTR("Fq");
+				plist(pcoresyn, gcoalg_alts(p));
+				pcoresyn(gcoalg_deflt(p));
+				break;
+      case coalg_alt:		PUTTAGSTR("Fr");
+				pcoresyn(gcoalg_con(p));
+				plist(pcoresyn, gcoalg_bs(p));
+				pcoresyn(gcoalg_rhs(p));
+				break;
+      case coprim_alts:		PUTTAGSTR("Fs");
+				plist(pcoresyn, gcoprim_alts(p));
+				pcoresyn(gcoprim_deflt(p));
+				break;
+      case coprim_alt:		PUTTAGSTR("Ft");
+				pliteral(gcoprim_lit(p));
+				pcoresyn(gcoprim_rhs(p));
+				break;
+      case conodeflt:		PUTTAGSTR("Fu");
+				break;
+      case cobinddeflt:		PUTTAGSTR("Fv");
+				pcoresyn(gcobinddeflt_v(p));
+				pcoresyn(gcobinddeflt_rhs(p));
+				break;
+
+      case co_primop:		PUTTAGSTR("Fw");
+				pid(gco_primop(p));
+				break;
+      case co_ccall:		PUTTAGSTR("Fx");
+	                        pbool(gco_ccall_may_gc(p));
+				pid(gco_ccall(p));
+				plist(pttype, gco_ccall_arg_tys(p));
+				pttype(gco_ccall_res_ty(p));
+				break;
+      case co_casm:		PUTTAGSTR("Fy");
+	                        pbool(gco_casm_may_gc(p));
+				pliteral(gco_casm(p));
+				plist(pttype, gco_casm_arg_tys(p));
+				pttype(gco_casm_res_ty(p));
+				break;
+
+	/* Cost-centre stuff */
+      case co_preludedictscc:	PUTTAGSTR("F?a");
+				pcoresyn(gco_preludedictscc_dupd(p));
+				break;
+      case co_alldictscc:	PUTTAGSTR("F?b");
+				print_string(gco_alldictscc_m(p));
+				print_string(gco_alldictscc_g(p));
+				pcoresyn(gco_alldictscc_dupd(p));
+				break;
+      case co_usercc:		PUTTAGSTR("F?c");
+				print_string(gco_usercc_n(p));
+				print_string(gco_usercc_m(p));
+				print_string(gco_usercc_g(p));
+				pcoresyn(gco_usercc_dupd(p));
+				pcoresyn(gco_usercc_cafd(p));
+				break;
+      case co_autocc:		PUTTAGSTR("F?d");
+				pcoresyn(gco_autocc_i(p));
+				print_string(gco_autocc_m(p));
+				print_string(gco_autocc_g(p));
+				pcoresyn(gco_autocc_dupd(p));
+				pcoresyn(gco_autocc_cafd(p));
+				break;
+      case co_dictcc:		PUTTAGSTR("F?e");
+				pcoresyn(gco_dictcc_i(p));
+				print_string(gco_dictcc_m(p));
+				print_string(gco_dictcc_g(p));
+				pcoresyn(gco_dictcc_dupd(p));
+				pcoresyn(gco_dictcc_cafd(p));
+				break;
+
+      case co_scc_noncaf:	PUTTAGSTR("F?f");
+				break;
+      case co_scc_caf:		PUTTAGSTR("F?g");
+				break;
+      case co_scc_nondupd:	PUTTAGSTR("F?h");
+				break;
+      case co_scc_dupd:		PUTTAGSTR("F?i");
+				break;
+
+	/* Id stuff */
+      case co_id:		PUTTAGSTR("F1");
+				pid(gco_id(p));
+				break;
+      case co_orig_id:		PUTTAGSTR("F9");
+				pid(gco_orig_id_m(p));
+				pid(gco_orig_id_n(p));
+				break;
+      case co_sdselid:		PUTTAGSTR("F2");
+				pid(gco_sdselid_c(p));
+				pid(gco_sdselid_sc(p));
+				break;
+      case co_classopid:	PUTTAGSTR("F3");
+				pid(gco_classopid_c(p));
+				pid(gco_classopid_o(p));
+				break;
+      case co_defmid:		PUTTAGSTR("F4");
+				pid(gco_defmid_c(p));
+				pid(gco_defmid_op(p));
+				break;
+      case co_dfunid:		PUTTAGSTR("F5");
+				pid(gco_dfunid_c(p));
+				pttype(gco_dfunid_ty(p));
+				break;
+      case co_constmid:		PUTTAGSTR("F6");
+				pid(gco_constmid_c(p));
+				pid(gco_constmid_op(p));
+				pttype(gco_constmid_ty(p));
+				break;
+      case co_specid:		PUTTAGSTR("F7");
+				pcoresyn(gco_specid_un(p));
+				plist(pttype,gco_specid_tys(p));
+				break;
+      case co_wrkrid:		PUTTAGSTR("F8");
+				pcoresyn(gco_wrkrid_un(p));
+				break;
+      /* more to come?? */
+
+      default :		    	error("Bad Core syntax");
+    }
+}
diff --git a/ghc/compiler/parser/qid.ugn b/ghc/compiler/parser/qid.ugn
new file mode 100644
index 0000000000..f42d5072a6
--- /dev/null
+++ b/ghc/compiler/parser/qid.ugn
@@ -0,0 +1,16 @@
+%{
+#include "hspincl.h"
+%}
+%{{
+module U_qid where
+import Ubiq --  debugging consistency check
+import UgenUtil
+%}}
+type qid;
+	noqual	: < gnoqual 	: stringId; >;
+	aqual	: < gqualmod  	: stringId;
+		    gqualname 	: stringId; >;
+	gid	: < ggid	: long;
+		    gidname     : stringId; >;
+end;
+
diff --git a/ghc/compiler/parser/syntax.c b/ghc/compiler/parser/syntax.c
new file mode 100644
index 0000000000..ad5d3d68b1
--- /dev/null
+++ b/ghc/compiler/parser/syntax.c
@@ -0,0 +1,720 @@
+/**********************************************************************
+*                                                                     *
+*                                                                     *
+*     Syntax-related Utility Functions                                *
+*                                                                     *
+*                                                                     *
+**********************************************************************/
+
+#include <stdio.h>
+#include <ctype.h>
+
+#include "hspincl.h"
+#include "constants.h"
+#include "utils.h"
+#include "tree.h"
+
+#include "hsparser.tab.h"
+
+/* Imported values */
+extern short icontexts;
+extern list Lnil;
+extern unsigned endlineno, startlineno;
+extern BOOLEAN hashIds, etags;
+
+/* Forward Declarations */
+
+char *ineg		    PROTO((char *));
+static tree unparen	    PROTO((tree));
+static void is_conapp_patt  PROTO((int, tree, tree));
+static void rearrangeprec   PROTO((tree, tree));
+static void error_if_expr_wanted PROTO((int, char *));
+static void error_if_patt_wanted PROTO((int, char *));
+
+qid	fns[MAX_CONTEXTS] = { NULL };
+BOOLEAN samefn[MAX_CONTEXTS] = { FALSE };
+tree	prevpatt[MAX_CONTEXTS] = { NULL };
+
+BOOLEAN inpat = FALSE;
+
+static BOOLEAN	 checkorder2 PROTO((binding, BOOLEAN));
+static BOOLEAN	 checksig PROTO((BOOLEAN, binding));
+
+/*
+  check infix value in range 0..9
+*/
+
+
+int
+checkfixity(vals)
+  char *vals;
+{
+  int value;
+  sscanf(vals,"%d",&value);
+
+  if (value < 0 || value > 9)
+    {
+      int oldvalue = value;
+      value = value < 0 ? 0 : 9;
+      fprintf(stderr,"Precedence must be between 0 and 9 (value given: %d, changed to %d)\n",
+	      oldvalue,value);
+    }
+  return(value);
+}
+
+
+/*
+  Check Previous Pattern usage
+*/
+
+void
+checksamefn(fn)
+  qid fn;
+{
+  char *this = qid_to_string(fn);
+  char *was  = (FN==NULL) ? NULL : qid_to_string(FN);
+
+  SAMEFN = (was != NULL && strcmp(this,was) == 0);
+
+  if(!SAMEFN && etags)
+#if 1/*etags*/
+    printf("%u\n",startlineno);
+#else
+    fprintf(stderr,"%u\tchecksamefn:%s\n",startlineno,this);
+#endif
+}
+
+
+void
+checkinpat()
+{
+  if(!inpat)
+    hsperror("pattern syntax used in expression");
+}
+
+/* ------------------------------------------------------------------------
+*/
+
+void
+expORpat(int wanted, tree e)
+{
+  switch(ttree(e))
+    {
+      case ident: /* a pattern or expr */
+	break;
+
+      case wildp:
+	error_if_expr_wanted(wanted, "wildcard in expression");
+	break;
+
+      case as:
+	error_if_expr_wanted(wanted, "`as'-pattern instead of an expression");
+	expORpat(wanted, gase(e));
+	break;
+
+      case lazyp:
+	error_if_expr_wanted(wanted, "irrefutable pattern instead of an expression");
+	expORpat(wanted, glazyp(e));
+	break;
+
+      case lit:
+	switch (tliteral(glit(e))) {
+	  case integer:
+	  case intprim:
+	  case floatr:
+	  case doubleprim:
+	  case floatprim:
+	  case string:
+	  case stringprim:
+	  case charr:
+	  case charprim:
+	    break; /* pattern or expr */
+
+	  case clitlit:
+	    error_if_patt_wanted(wanted, "``literal-literal'' in pattern");
+
+	  default: /* the others only occur in pragmas */
+	    hsperror("not a valid literal pattern or expression");
+	}
+	break;
+
+      case negate:
+	{ tree sub = gnexp(e);
+	  if (ttree(sub) != lit) {
+	      error_if_patt_wanted(wanted, "\"-\" applied to a non-literal");
+	  } else {
+	      literal l = glit(sub);
+
+	      if (tliteral(l) != integer && tliteral(l) != floatr) {
+		error_if_patt_wanted(wanted, "\"-\" applied to a non-number");
+	      }
+	  }
+	  expORpat(wanted, sub);
+	}
+	break;
+
+      case ap:
+	{
+	  tree f = gfun(e);
+	  tree a = garg(e);
+
+	  is_conapp_patt(wanted, f, a); /* does nothing unless wanted == LEGIT_PATT */
+	  expORpat(wanted, f);
+	  expORpat(wanted, a);
+	}
+	break;
+
+      case infixap:
+	{
+	  qid  f  = ginffun ((struct Sinfixap *)e);
+	  tree a1 = ginfarg1((struct Sinfixap *)e);
+	  tree a2 = ginfarg2((struct Sinfixap *)e);
+
+	  expORpat(wanted, a1);
+	  expORpat(wanted, a2);
+
+	  if (wanted == LEGIT_PATT && !isconstr(qid_to_string(f)))
+	     hsperror("variable application in pattern");
+	}
+	break;
+
+      case record:
+	{
+          list field;
+	  for (field = grbinds(e); tlist(field) == lcons; field = ltl(field)) {
+	      expORpat(wanted, lhd(field));
+	  }
+	}
+	break;
+
+      case rbind:
+	if (tmaybe(grbindexp(e)) == just)
+	    expORpat(wanted, gthing(grbindexp(e)));
+	break;
+
+      case tuple:
+	{
+	  list tup;
+	  for (tup = gtuplelist(e); tlist(tup) == lcons; tup = ltl(tup)) {
+	      expORpat(wanted, lhd(tup));
+	  }
+	}
+	break;
+
+      case llist:
+	{
+	  list l;
+	  for (l = gllist(e); tlist(l) == lcons; l = ltl(l)) {
+	      expORpat(wanted, lhd(l));
+	  }
+	}
+	break;
+
+      case par: /* parenthesised */
+	expORpat(wanted, gpare(e));
+	break;
+
+      case restr:
+      case lambda:
+      case let:
+      case casee:
+      case ife:
+      case doe:
+      case ccall:
+      case scc:
+      case rupdate:
+      case comprh:
+      case eenum:
+      case lsection:
+      case rsection:
+	error_if_patt_wanted(wanted, "unexpected construct in a pattern");
+	break;
+
+      default:
+	hsperror("not a pattern or expression");
+      }
+}
+
+static void
+is_conapp_patt(int wanted, tree f, tree a)
+{
+  if (wanted == LEGIT_EXPR)
+     return; /* that was easy */
+
+  switch(ttree(f))
+    {
+      case ident:
+        if (isconstr(qid_to_string(gident(f))))
+	  {
+	    expORpat(wanted, a);
+	    return;
+	  }
+	{
+	  char errbuf[ERR_BUF_SIZE];
+	  sprintf(errbuf,"not a constructor application -- %s",qid_to_string(gident(f)));
+	  hsperror(errbuf);
+	}
+
+      case ap:
+	is_conapp_patt(wanted, gfun(f), garg(f));
+	expORpat(wanted, a);
+	return;
+
+      case par:
+	is_conapp_patt(wanted, gpare(f), a);
+	break;
+
+      case tuple:
+	{
+	   char errbuf[ERR_BUF_SIZE];
+	   sprintf(errbuf,"tuple pattern `applied' to arguments (missing comma?)");
+	   hsperror(errbuf);
+	}
+	break;
+
+      default:
+	hsperror("not a constructor application");
+      }
+}
+
+static void
+error_if_expr_wanted(int wanted, char *msg)
+{
+    if (wanted == LEGIT_EXPR)
+	hsperror(msg);
+}
+
+static void
+error_if_patt_wanted(int wanted, char *msg)
+{
+    if (wanted == LEGIT_PATT)
+	hsperror(msg);
+}
+
+/* ---------------------------------------------------------------------- */
+
+BOOLEAN /* return TRUE if LHS is a pattern */
+lhs_is_patt(tree e)
+{
+  switch(ttree(e))
+    {
+      case lit:
+	switch (tliteral(glit(e))) {
+	  case integer:
+	  case intprim:
+	  case floatr:
+	  case doubleprim:
+	  case floatprim:
+	  case string:
+	  case charr:
+	  case charprim:
+	  case stringprim:
+	    return TRUE;
+	  default:
+	    hsperror("Literal is not a valid LHS");
+	}
+
+      case wildp:
+        return TRUE;
+
+      case as:
+      case lazyp:
+      case llist:
+      case tuple:
+      case negate:
+	expORpat(LEGIT_PATT, e);
+	return TRUE;
+
+      case ident:
+	return(TRUE);
+	/* This change might break ap infixop below.  BEWARE.
+	   return (isconstr(qid_to_string(gident(e))));
+        */
+
+      case ap:
+	{
+	  tree f = function(e);
+	  tree a = garg(e);       /* do not "unparen", otherwise the error
+				       fromInteger ((x,y) {-no comma-} z)
+				     will be missed.
+			          */
+
+	  /* definitions must have pattern arguments */
+	  expORpat(LEGIT_PATT, a);
+
+	  if(ttree(f) == ident)
+	    return(isconstr(qid_to_string(gident(f))));
+
+	  else if(ttree(f) == infixap)
+	    return(lhs_is_patt(f));
+
+	  else
+	    hsperror("Not a legal pattern binding in LHS");
+	}
+
+      case infixap:
+	{
+	  qid  f  = ginffun((struct Sinfixap *)e);
+	  tree a1 = unparen(ginfarg1((struct Sinfixap *)e)),
+	       a2 = unparen(ginfarg2((struct Sinfixap *)e));
+
+	  /* definitions must have pattern arguments */
+	  expORpat(LEGIT_PATT, a1);
+	  expORpat(LEGIT_PATT, a2);
+
+	  return(isconstr(qid_to_string(f)));
+	}
+
+      case par:
+	return(lhs_is_patt(gpare(e)));
+
+      /* Anything else must be an illegal LHS */
+      default:
+	hsperror("Not a valid LHS");
+      }
+
+  abort(); /* should never get here */
+  return(FALSE);
+}
+
+
+/*
+  Return the function at the root of a series of applications.
+*/
+
+tree
+function(e)
+  tree e;
+{
+  switch (ttree(e))
+    {
+      case ap:
+        expORpat(LEGIT_PATT, garg(e));
+        return(function(gfun(e)));
+
+      case par:
+	return(function(gpare(e)));
+	
+      default:
+	return(e);
+    }
+}
+
+
+static tree
+unparen(e)
+  tree e;
+{
+  while (ttree(e) == par)
+      e = gpare(e);
+
+  return(e);
+}
+
+
+/*
+  Extend a function by adding a new definition to its list of bindings.
+*/
+
+void
+extendfn(bind,rule)
+binding bind;
+binding rule;
+{
+/*  fprintf(stderr,"extending binding (%d)\n",tbinding(bind));*/
+  if(tbinding(bind) == abind)
+    bind = gabindsnd(bind);
+
+  if(tbinding(bind) == pbind)
+    gpbindl(bind) = lconc(gpbindl(bind), gpbindl(rule));
+  else if(tbinding(bind) == fbind)
+    gfbindl(bind) = lconc(gfbindl(bind), gfbindl(rule));
+  else
+    fprintf(stderr,"bind error in decl (%d)\n",tbinding(bind));
+}
+
+/* 
+
+  Precedence Parser for Haskell.  By default operators are left-associative, 
+  so it is only necessary to rearrange the parse tree where the new operator
+  has a greater precedence than the existing one, or where two operators have
+  the same precedence and are both right-associative. Error conditions are
+  handled.
+
+  Note:  Prefix negation has the same precedence as infix minus.
+         The algorithm must thus take account of explicit negates.
+*/
+
+void
+precparse(tree t)
+{
+  if(ttree(t) == infixap)
+    {
+      tree left = ginfarg1(t);
+
+      if(ttree(left) == negate)
+	{
+	  struct infix *ttabpos = infixlookup(ginffun(t));
+	  struct infix *ntabpos = infixlookup(mknoqual(install_literal("-")));
+	  
+	  if(pprecedence(ntabpos) < pprecedence(ttabpos))
+	    {
+	      /* (-x)*y  ==> -(x*y) */
+	      qid  lop  = ginffun(t);
+	      tree arg1 = gnexp(left);
+	      tree arg2 = ginfarg2(t);
+
+	      t->tag = negate;
+	      gnexp(t) = left;
+	      gnxxx1(t) = NULL;
+	      gnxxx2(t) = NULL;
+
+	      left->tag = infixap;
+	      ginffun(left)  = lop;
+	      ginfarg1(left) = arg1;
+	      ginfarg2(left) = arg2;
+
+	      precparse(left);
+	    }
+	}
+
+      else if(ttree(left) == infixap)
+	{
+	  struct infix *ttabpos    = infixlookup(ginffun(t));
+	  struct infix *lefttabpos = infixlookup(ginffun(left));
+
+	  if(pprecedence(lefttabpos) < pprecedence(ttabpos))
+	    rearrangeprec(left,t);
+
+	  else if(pprecedence(lefttabpos) == pprecedence(ttabpos))
+	    {
+	      if(pfixity(lefttabpos) == INFIXR && pfixity(ttabpos) == INFIXR)
+		rearrangeprec(left,t);
+
+	      else if(pfixity(lefttabpos) == INFIXL && pfixity(ttabpos) == INFIXL)
+		/* SKIP */;
+
+	      else
+		{
+		  char errbuf[ERR_BUF_SIZE];
+		  sprintf(errbuf,"Cannot mix %s and %s in the same infix expression", 
+			  qid_to_string(ginffun(left)), qid_to_string(ginffun(t)));
+		  hsperror(errbuf);
+	      }
+	    }
+	}
+    }
+}
+
+
+/*
+  Rearrange a tree to effectively insert an operator in the correct place.
+
+  x+y*z ==parsed== (x+y)*z  ==>  x+(y*z)
+
+  The recursive call to precparse ensures this filters down as necessary.
+*/
+
+static void
+rearrangeprec(tree left, tree t)
+{
+  qid top  = ginffun(left);
+  qid lop  = ginffun(t);
+  tree arg1 = ginfarg1(left);
+  tree arg2 = ginfarg2(left);
+  tree arg3 = ginfarg2(t);
+
+  ginffun(t)  = top;
+  ginfarg1(t) = arg1;
+  ginfarg2(t) = left;
+
+  ginffun(left)  = lop;
+  ginfarg1(left) = arg2;
+  ginfarg2(left) = arg3;
+
+  precparse(left);
+}
+
+pbinding
+createpat(guards,where)
+  pbinding guards;
+  binding where;
+{
+  qid func;
+
+  if(FN != NULL)
+    func = FN;
+  else
+    func = mknoqual(install_literal(""));
+
+  return(mkpgrhs(PREVPATT,guards,where,func,endlineno));
+}
+
+char *
+ineg(i)
+  char *i;
+{
+  char *p = xmalloc(strlen(i)+2);
+
+  *p = '-';
+  strcpy(p+1,i);
+  return(p);
+}
+
+#if 0
+/* UNUSED: at the moment */
+void
+checkmodname(import,interface)
+  id import, interface;
+{
+  if(strcmp(import,interface) != 0)
+    {
+      char errbuf[ERR_BUF_SIZE];
+      sprintf(errbuf,"interface name (%s) does not agree with import name (%s)",interface,import);
+      hsperror(errbuf);
+    }
+}
+#endif /* 0 */
+
+/*
+  Check the ordering of declarations in a cbody.
+  All signatures must appear before any declarations.
+*/
+
+void
+checkorder(decls)
+  binding decls;
+{
+  /* The ordering must be correct for a singleton */
+  if(tbinding(decls)!=abind)
+    return;
+
+  checkorder2(decls,TRUE);
+}
+
+static BOOLEAN
+checkorder2(decls,sigs)
+  binding decls;
+  BOOLEAN sigs;
+{
+  while(tbinding(decls)==abind)
+    {
+      /* Perform a left-traversal if necessary */
+      binding left = gabindfst(decls);
+      if(tbinding(left)==abind)
+	sigs = checkorder2(left,sigs);
+      else
+	sigs = checksig(sigs,left);
+      decls = gabindsnd(decls);
+    }
+
+  return(checksig(sigs,decls));
+}
+
+
+static BOOLEAN
+checksig(sig,decl)
+  BOOLEAN sig;
+  binding decl;
+{
+  BOOLEAN issig = tbinding(decl) == sbind || tbinding(decl) == nullbind;
+  if(!sig && issig)
+    hsperror("Signature appears after definition in class body");
+
+  return(issig);
+}
+
+
+/*
+  Check the last expression in a list of do statements.
+*/
+
+void
+checkdostmts(stmts)
+  list stmts;
+{
+  if (tlist(stmts) == lnil)
+      hsperror("do expression with no statements");
+
+  for(; tlist(ltl(stmts)) != lnil; stmts = ltl(stmts))
+      ;
+  if (ttree(lhd(stmts)) != doexp)
+      hsperror("do statements must end with expression");
+}
+
+
+/*
+  Check the precedence of a pattern or expression to ensure that
+  sections and function definitions have the correct parse.
+*/
+
+void
+checkprec(exp,qfn,right)
+  tree exp;
+  qid qfn;
+  BOOLEAN right;
+{
+  if(ttree(exp) == infixap)
+    {
+      struct infix *ftabpos = infixlookup(qfn);
+      struct infix *etabpos = infixlookup(ginffun(exp));
+
+      if (pprecedence(etabpos) > pprecedence(ftabpos) ||
+	 (pprecedence(etabpos) == pprecedence(ftabpos) &&
+	  ((pfixity(etabpos) == INFIXR && pfixity(ftabpos) == INFIXR && right) ||
+	  ((pfixity(etabpos) == INFIXL && pfixity(ftabpos) == INFIXL && !right)))))
+	/* SKIP */;
+      else
+	{
+	  char errbuf[ERR_BUF_SIZE];
+	  sprintf(errbuf,"Cannot mix %s and %s on a LHS or in a section", 
+		  qid_to_string(qfn), qid_to_string(ginffun(exp)));
+	  hsperror(errbuf);
+	}
+    }
+}
+
+
+/*
+  Checks there are no bangs in a tycon application.
+*/
+
+void
+checknobangs(app)
+  ttype app;
+{
+  if(tttype(app) == tapp)
+    {
+      if(tttype(gtarg((struct Stapp *)app)) == tbang)
+	hsperror("syntax error: unexpected ! in type");
+
+      checknobangs(gtapp((struct Stapp *)app));
+    }	  
+}
+
+
+/*
+  Splits a tycon application into its constructor and a list of types.
+*/
+
+void
+splittyconapp(app, tyc, tys)
+  ttype app;
+  qid *tyc;
+  list *tys;
+{
+  if(tttype(app) == tapp) 
+    {
+      splittyconapp(gtapp((struct Stapp *)app), tyc, tys);
+      *tys = lapp(*tys, gtarg((struct Stapp *)app));
+    }
+  else if(tttype(app) == tname)
+    {
+      *tyc = gtypeid((struct Stname *)app);
+      *tys = Lnil;
+    }
+  else
+    {
+      hsperror("panic: splittyconap: bad tycon application (no tycon)");
+    }
+}
diff --git a/ghc/compiler/parser/tree.ugn b/ghc/compiler/parser/tree.ugn
new file mode 100644
index 0000000000..60974fa48a
--- /dev/null
+++ b/ghc/compiler/parser/tree.ugn
@@ -0,0 +1,106 @@
+%{
+#include "hspincl.h"
+%}
+%{{
+module U_tree where
+import Ubiq --  debugging consistency check
+import UgenUtil
+
+import U_constr		( U_constr )	-- interface only
+import U_binding
+import U_coresyn	( U_coresyn )	-- interface only
+import U_hpragma	( U_hpragma )	-- interface only
+import U_list
+import U_literal
+import U_maybe
+import U_qid
+import U_ttype
+%}}
+type tree;
+	hmodule : < ghname	: stringId;
+		    ghimplist	: list;	 	/* [import] */
+		    ghexplist	: maybe;	/* Maybe [entity] */
+		    ghfixes     : list;		/* [fixop] */
+		    ghmodlist	: binding;
+		    ghmodline	: long; >;
+	fixop	: < gfixop	: unkId;
+		    gfixinfx	: long;
+		    gfixprec	: long;	>;
+
+	ident	: < gident 	: qid; >;
+	lit 	: < glit	: literal; >;
+
+	ap	: < gfun	: tree;
+		    garg	: tree; >;
+	infixap : < ginffun	: qid;
+		    ginfarg1	: tree;
+		    ginfarg2	: tree; >;
+	negate	: < gnexp	: tree;
+		    gnxxx1	: VOID_STAR;
+		    gnxxx2	: VOID_STAR; >;
+	/*
+	  infixap and negate have the same size
+	  so they can be rearranged in precparse
+	*/
+
+	lambda	: < glampats	: list;
+		    glamexpr	: tree;
+		    glamline	: long; >;
+
+	let	: < gletvdefs   : binding;
+		    gletvexpr	: tree; >;
+	casee	: < gcaseexpr	: tree;
+		    gcasebody	: list;
+		    gcaseline 	: long;	>;
+	ife	: < gifpred	: tree;
+		    gifthen	: tree;
+		    gifelse	: tree;
+		    gifline 	: long;	>;
+	doe	: < gdo		: list;
+		    gdoline 	: long;	>;
+
+	dobind	: < gdobindpat	: tree;
+		    gdobindexp	: tree;
+		    gdobindline	: long;	>;
+	doexp	: < gdoexp	: tree;
+		    gdoexpline	: long; >;
+	seqlet	: < gseqlet	: binding; >;
+
+	record	: < grcon	: qid;
+		    grbinds	: list;	>;  	/* [rbind] */ 
+	rupdate	: < gupdexp	: tree;
+		    gupdbinds	: list; >;   	/* [rbind] */ 
+	rbind   : < grbindvar   : qid;
+		    grbindexp   : maybe; >;  	/* Maybe expr */
+
+	par	: < gpare	: tree; >;
+	as	: < gasid	: qid;
+		    gase	: tree; >;
+	lazyp	: < glazyp	: tree; >;
+	wildp	: < >;
+
+	restr	: < grestre	: tree;
+		    grestrt	: ttype; >;
+
+	tuple	: < gtuplelist	: list; >;
+	llist	: < gllist	: list; >;
+	eenum	: < gefrom	: tree;
+		    gestep	: maybe;
+		    geto	: maybe; >;
+	comprh	: < gcexp	: tree;
+		    gcquals	: list; >;
+	qual	: < gqpat	: tree;
+		    gqexp	: tree;	>;
+	guard	: < ggexp	: tree; >;
+
+	lsection: < glsexp	: tree; 
+		    glsop	: qid; >;
+	rsection: < grsop	: qid;
+		    grsexp	: tree; >;
+
+	ccall	: < gccid	: stringId;
+		    gccinfo	: stringId;
+		    gccargs	: list; >;
+	scc	: < gsccid	: hstring;
+		    gsccexp	: tree; >;
+end;
diff --git a/ghc/compiler/parser/ttype.ugn b/ghc/compiler/parser/ttype.ugn
new file mode 100644
index 0000000000..3b03cd376e
--- /dev/null
+++ b/ghc/compiler/parser/ttype.ugn
@@ -0,0 +1,31 @@
+%{
+#include "hspincl.h"
+%}
+%{{
+module U_ttype where
+import Ubiq --  debugging consistency check
+import UgenUtil
+
+import U_list
+import U_qid
+%}}
+type ttype;
+	tname	: < gtypeid	: qid; 	>;
+	namedtvar : < gnamedtvar : unkId; /* ToDo: rm unkIds entirely??? */ >;
+	tllist	: < gtlist	: ttype; >;
+	ttuple	: < gttuple	: list; >;
+	tfun	: < gtin	: ttype;
+		    gtout	: ttype; >;
+	tapp	: < gtapp	: ttype;
+		    gtarg	: ttype; >;
+	tbang	: < gtbang	: ttype; >;
+	context	: < gtcontextl	: list;
+		    gtcontextt	: ttype; >;
+
+	unidict :   < gunidict_clas : qid;
+		      gunidict_ty   : ttype; >;
+	unityvartemplate: <gunityvartemplate : unkId; >;
+	uniforall : < guniforall_tv : list;
+		      guniforall_ty : ttype; >;
+end;
+
diff --git a/ghc/compiler/parser/type2context.c b/ghc/compiler/parser/type2context.c
new file mode 100644
index 0000000000..029da1a2ce
--- /dev/null
+++ b/ghc/compiler/parser/type2context.c
@@ -0,0 +1,126 @@
+/**********************************************************************
+*                                                                     *
+*                                                                     *
+*      Convert Types to Contexts                                      *
+*                                                                     *
+*                                                                     *
+**********************************************************************/
+
+
+#include <stdio.h>
+#include "hspincl.h"
+#include "constants.h"
+#include "utils.h"
+
+static void is_context_format PROTO((ttype, int)); /* forward */
+
+/* 
+    partain: see also the comment by "decl" in hsparser.y.
+
+    Here, we've been given a type that must be of the form
+    "C a" or "(C1 a, C2 a, ...)" [otherwise an error]
+
+    Convert it to a list.
+*/
+
+
+list
+type2context(t)
+  ttype t;
+{
+    list  args;
+
+    switch (tttype(t)) {
+      case ttuple:
+	/* returning the list is OK, but ensure items are right format */
+	args = gttuple(t);
+
+	if (tlist(args) == lnil)
+	  hsperror ("type2context: () found instead of a context");
+
+	while (tlist(args) != lnil) 
+	  {
+	    is_context_format(lhd(args), 0);
+	    args = ltl(args);
+	  }
+
+	return(gttuple(t)); /* args */
+	
+
+      case tapp:
+      case tname:
+	/* a single item, ensure correct format */
+	is_context_format(t, 0);
+	return(lsing(t));
+
+      case namedtvar:
+    	hsperror ("type2context: unexpected namedtvar found in a context");
+
+      case tllist:
+    	hsperror ("type2context: list constructor found in a context");
+
+      case tfun:
+    	hsperror ("type2context: arrow (->) constructor found in a context");
+
+      case context:
+    	hsperror ("type2context: unexpected context-thing found in a context");
+
+      default:
+    	hsperror ("type2context: totally unexpected input");
+    }
+    abort(); /* should never get here! */
+}
+
+
+/* is_context_format is the same as "type2context" except that it just performs checking */
+/* ttype is either "tycon" [class] or "tycon (named)tvar" [class var] */
+
+static void
+is_context_format(t, tyvars)
+  ttype t;
+  int tyvars;
+{
+    list  rest_args;
+    ttype first_arg;
+
+    switch (tttype(t)) 
+      {
+        case tname :
+	  /* should be just: ":: C a =>" */
+
+	  if (tyvars == 0)
+	    hsperror("is_context_format: variable missing after class name");
+
+	  else if (tyvars > 1)
+	    hsperror ("is_context_format: too many variables after class name");
+
+	  /* tyvars == 1; everything is cool */
+	  break;
+
+	case tapp:
+	  if (tttype(gtarg(t)) != namedtvar)
+	      hsperror ("is_context_format: something wrong with variable after class name");
+
+	  is_context_format(gtapp(t), tyvars+1);
+	  break;
+
+	case ttuple:
+	  hsperror ("is_context_format: tuple found in a context");
+
+	case namedtvar:
+	  hsperror ("is_context_format: unexpected namedtvar found in a context");
+
+	case tllist:
+	  hsperror ("is_context_format: list constructor found in a context");
+
+	case tfun:
+	  hsperror ("is_context_format: arrow (->) constructor found in a context");
+
+	case context:
+	  hsperror ("is_context_format: unexpected context-thing found in a context");
+
+	default:
+	    hsperror ("is_context_format: totally unexpected input");
+      }
+}
+
diff --git a/ghc/compiler/parser/util.c b/ghc/compiler/parser/util.c
new file mode 100644
index 0000000000..de26eb0217
--- /dev/null
+++ b/ghc/compiler/parser/util.c
@@ -0,0 +1,252 @@
+/**********************************************************************
+*                                                                     *
+*                                                                     *
+*      Declarations                                                   *
+*                                                                     *
+*                                                                     *
+**********************************************************************/
+
+#include "hspincl.h"
+#include "constants.h"
+#include "utils.h"
+
+#define PARSER_VERSION "1.3-???"
+
+tree root; 		/* The root of the built syntax tree. */
+list Lnil;
+
+BOOLEAN nonstandardFlag = FALSE;  /* Set if non-std Haskell extensions to be used. */
+BOOLEAN acceptPrim = FALSE;	  /* Set if Int#, etc., may be used		   */
+BOOLEAN haskell1_2Flag = FALSE;	  /* Set if we are compiling for 1.2    	   */
+BOOLEAN etags = FALSE;		  /* Set if we're parsing only to produce tags.	   */
+BOOLEAN hashIds = FALSE; 	  /* Set if Identifiers should be hashed.          */
+				  
+BOOLEAN ignoreSCC = TRUE;         /* Set if we ignore/filter scc expressions.      */
+				  
+BOOLEAN implicitPrelude = TRUE;   /* Set if we implicitly import the Prelude.      */
+BOOLEAN ignorePragmas = FALSE;    /* Set if we want to ignore pragmas		   */
+
+/* From time to time, the format of interface files may change.
+
+   So that we don't get gratuitous syntax errors or silently slurp in
+   junk info, two things: (a) the compiler injects a "this is a
+   version N interface":
+
+	{-# GHC_PRAGMA INTERFACE VERSION <n> #-}
+
+   (b) this parser has a "minimum acceptable version", below which it
+   refuses to parse the pragmas (it just considers them as comments).
+   It also has a "maximum acceptable version", above which...
+
+   The minimum is so a new parser won't try to grok overly-old
+   interfaces; the maximum (usually the current version number when
+   the parser was released) is so an old parser will not try to grok
+   since-upgraded interfaces.
+
+   If an interface has no INTERFACE VERSION line, it is taken to be
+   version 0.
+*/
+int minAcceptablePragmaVersion = 7;  /* 1.3-xx ONLY */
+int maxAcceptablePragmaVersion = 7;  /* 1.3-xx+ */
+int thisIfacePragmaVersion = 0;
+
+char *input_file_dir; /* The directory where the input file is. */
+
+char HiSuffix[64] = ".hi";		/* can be changed with -h flag */
+char PreludeHiSuffix[64] = ".hi";	/* can be changed with -g flag */
+
+static BOOLEAN verbose = FALSE;		/* Set for verbose messages. */
+
+/* Forward decls */
+static void who_am_i PROTO((void));
+
+/**********************************************************************
+*                                                                     *
+*                                                                     *
+*     Utility Functions                                               *
+*                                                                     *
+*                                                                     *
+**********************************************************************/
+
+# include <stdio.h>
+# include "constants.h"
+# include "hspincl.h"
+# include "utils.h"
+
+void
+process_args(argc,argv)
+  int argc;
+  char **argv;
+{
+    BOOLEAN keep_munging_option = FALSE;
+
+    imports_dirlist     = mklnil();
+    sys_imports_dirlist = mklnil();
+
+    argc--, argv++;
+
+    while (argc > 0 && argv[0][0] == '-') {
+
+	keep_munging_option = TRUE;
+
+	while (keep_munging_option && *++*argv != '\0') {
+	    switch(**argv) {
+
+	    /* -I dir */
+	    case 'I':
+		    imports_dirlist = lapp(imports_dirlist,*argv+1);
+		    keep_munging_option = FALSE;
+		    break;
+
+	    /* -J dir (for system imports) */
+	    case 'J':
+		    sys_imports_dirlist = lapp(sys_imports_dirlist,*argv+1);
+		    keep_munging_option = FALSE;
+		    break;
+
+	    case 'g':
+		    strcpy(PreludeHiSuffix, *argv+1);
+		    keep_munging_option = FALSE;
+		    break;
+
+	    case 'h':
+		    strcpy(HiSuffix, *argv+1);
+		    keep_munging_option = FALSE;
+		    break;
+
+	    case 'v':
+		    who_am_i(); /* identify myself */
+		    verbose = TRUE;
+		    break;
+
+	    case 'N':
+		    nonstandardFlag = TRUE;
+		    acceptPrim = TRUE;
+		    break;
+
+	    case '2':
+		    haskell1_2Flag = TRUE;
+		    break;
+
+	    case 'S':
+		    ignoreSCC = FALSE;
+		    break;
+
+	    case 'p':
+		    ignorePragmas = TRUE;
+		    break;
+
+	    case 'P':
+		    implicitPrelude = FALSE;
+		    break;
+
+	    case 'D':
+#ifdef HSP_DEBUG
+		    { extern int yydebug;
+		      yydebug = 1;
+		    }
+#endif
+		    break;
+
+	    /* -Hn -- Use Hash Table, Size n (if given) */
+	    case 'H':
+		    hashIds = TRUE;
+		    if(*(*argv+1)!= '\0')
+		      hash_table_size = atoi(*argv+1);
+		    break;
+	    case 'E':
+		    etags = TRUE;
+		    break;
+	    }
+	}
+	argc--, argv++;
+    }
+
+    if(argc >= 1 && freopen(argv[0], "r", stdin) == NULL) {
+	    fprintf(stderr, "Cannot open %s.\n", argv[0]);
+	    exit(1);
+    }
+
+    if(argc >= 2 && freopen(argv[1], "w", stdout) == NULL) {
+	    fprintf(stderr, "Cannot open %s.\n", argv[1]);
+	    exit(1);
+    }
+
+
+    /* By default, imports come from the directory of the source file */
+    if ( argc >= 1 ) 
+      { 
+	char *endchar;
+
+	input_file_dir = xmalloc (strlen(argv[0]) + 1);
+	strcpy(input_file_dir, argv[0]);
+#ifdef macintosh
+	endchar = rindex(input_file_dir, (int) ':');
+#else
+	endchar = rindex(input_file_dir, (int) '/');
+#endif /* ! macintosh */
+
+	if ( endchar == NULL ) 
+	  {
+	    free(input_file_dir);
+	    input_file_dir = ".";
+	  } 
+	else
+	  *endchar = '\0';
+      } 
+
+    /* No input file -- imports come from the current directory first */
+    else
+      input_file_dir = ".";
+
+    imports_dirlist = mklcons( input_file_dir, imports_dirlist );
+
+    if (verbose)
+      {
+	fprintf(stderr,"Hash Table Contains %d entries\n",hash_table_size);
+	if(acceptPrim)
+	  fprintf(stderr,"Allowing special syntax for Unboxed Values\n");
+      }
+}
+
+void
+error(s)
+  char *s;
+{
+	fprintf(stderr, "PARSER: Error %s\n", s);
+	exit(1);
+}
+
+static void
+who_am_i(void)
+{
+  fprintf(stderr,"Glasgow Haskell parser, version %s\n", PARSER_VERSION);
+}
+
+list
+lconc(l1, l2)
+  list l1;
+  list l2;
+{
+	list t;
+
+	if (tlist(l1) == lnil)
+		return(l2);
+	for(t = l1; tlist(ltl(t)) != lnil; t = ltl(t))
+		;
+	ltl(t) = l2;
+	return(l1);
+}
+
+list
+lapp(list l1, VOID_STAR l2)
+{
+	list t;
+
+	if (tlist(l1) == lnil)
+		return(mklcons(l2, mklnil()));
+	for(t = l1; tlist(ltl(t)) != lnil; t = ltl(t))
+		;
+	ltl(t) = mklcons(l2, mklnil());
+	return(l1);
+}
diff --git a/ghc/compiler/parser/utils.h b/ghc/compiler/parser/utils.h
new file mode 100644
index 0000000000..282bfc7657
--- /dev/null
+++ b/ghc/compiler/parser/utils.h
@@ -0,0 +1,136 @@
+/*
+	Utility Definitions.
+*/
+
+#ifndef __UTILS_H
+#define __UTILS_H
+
+/* stuff from util.c */
+extern tree root;
+extern list Lnil;
+extern list all;
+
+extern BOOLEAN nonstandardFlag;
+extern BOOLEAN hashIds;
+extern BOOLEAN acceptPrim;
+extern BOOLEAN etags;
+				  
+extern BOOLEAN ignoreSCC;
+				  
+extern BOOLEAN implicitPrelude;
+extern BOOLEAN ignorePragmas;
+
+extern int minAcceptablePragmaVersion;
+extern int maxAcceptablePragmaVersion;
+extern int thisIfacePragmaVersion;
+
+extern unsigned hash_table_size;
+extern char *input_file_dir;
+
+extern list imports_dirlist;
+extern list sys_imports_dirlist;
+
+extern char HiSuffix[];
+extern char PreludeHiSuffix[];
+
+void process_args PROTO((int, char **));
+
+/* end of util.c stuff */
+
+list mklcons	PROTO((void *h, list t)); /* if we have PROTO, we have "void *" */
+list lapp	PROTO((list l1, void *l2));
+list lconc	PROTO((list l1, list l2));
+
+#define lsing(l) mklcons(l, Lnil)		/* Singleton Lists */
+#define ldub(l1, l2) mklcons(l1, lsing(l2))	/* Two-element Lists */
+
+#define FN fns[icontexts]
+#define SAMEFN samefn[icontexts]
+#define PREVPATT prevpatt[icontexts]
+
+id installid PROTO((char *));		     /* Create a new identifier */
+hstring installHstring PROTO((int, char *)); /* Create a new literal string */
+
+id	install_literal PROTO((char *));
+char   *id_to_string PROTO((id));
+
+id      qid_to_id PROTO((qid));
+char   *qid_to_string PROTO((qid));
+char   *qid_to_mod PROTO((qid));	     /* NULL if unqual */
+char   *qid_to_pmod PROTO((qid));	     /* "?"  if unqual */
+qid	creategid PROTO((long));
+
+/* partain additions */
+
+char	*xmalloc PROTO((unsigned)); /* just a GNU-style error-checking malloc */
+int	 printf  PROTO((const char *, ...));
+int	 fprintf PROTO((FILE *, const char *, ...));
+/*varies (sun/alpha): int fputc   PROTO((char, FILE *)); */
+int	 fputs	 PROTO((const char *, FILE *));
+int  	 sscanf	 PROTO((const char *, const char *, ...));
+long	 strtol  PROTO((const char *, char **, int));
+size_t	 fread	 PROTO((void *, size_t, size_t, FILE *));
+int	 fclose  PROTO((FILE *));
+int	 isatty	 PROTO((int));
+/*extern ???       _filbuf */
+/*extern ???  	 _flsbuf */
+
+void	 pprogram PROTO((tree));
+
+void	 format_string PROTO((FILE *, unsigned char *, int));
+list	 type2context PROTO((ttype));
+pbinding createpat PROTO((pbinding, binding));
+void	 process_args PROTO((int, char **));
+void	 hash_init PROTO((void));
+void	 print_hash_table PROTO((void));
+long int hash_index PROTO((id));
+void	 yyinit PROTO((void));
+int	 yyparse PROTO((void));
+int	 yylex PROTO((void));
+void	 setyyin PROTO((char *));
+void	 yyerror PROTO((char *));
+void	 error PROTO((char *));
+void	 hsperror PROTO((char *));
+
+void	 makeinfix PROTO((id, int, int, id, long, long, id, id, long, long, long, list));
+struct infix *infixlookup PROTO((qid));
+int	 pprecedence PROTO((struct infix *));
+int	 pfixity PROTO((struct infix *));
+char *   infixstr PROTO((int));
+long     infixint PROTO((int));
+
+void 	 hsincindent PROTO((void));
+void	 hssetindent PROTO((void));
+void	 hsendindent PROTO((void));
+void	 hsindentoff PROTO((void));
+
+int	 checkfixity PROTO((char *));
+void	 checksamefn PROTO((qid));
+void	 checkinpat PROTO((void));
+
+void	 expORpat PROTO((int,tree));
+/* the "int" arg says what we want; it is one of: */
+#define LEGIT_PATT 1
+#define LEGIT_EXPR 2
+
+BOOLEAN	lhs_is_patt PROTO((tree));
+tree	function PROTO((tree));
+void	extendfn PROTO((binding, binding));
+void	checkorder PROTO((binding));
+
+void	precparse PROTO((tree));
+void	checkprec PROTO((tree, qid, BOOLEAN));
+void    checkdostmts PROTO((list));
+void	checknobangs PROTO((ttype));
+void	splittyconapp PROTO((ttype, qid *, list *));
+
+BOOLEAN	isconstr PROTO((char *));
+void	setstartlineno PROTO((void));
+void	find_module_on_imports_dirlist PROTO((char *, BOOLEAN, char *));
+
+/* mattson additions */
+char *xstrdup PROTO((char *));	    	  /* Duplicate a string */
+char *xstrndup PROTO((char *, unsigned)); /* Duplicate a substring */
+char *xrealloc PROTO((char *, unsigned)); /* Re-allocate a string */
+
+#endif /* __UTILS_H */
diff --git a/ghc/compiler/prelude/AbsPrel.hi b/ghc/compiler/prelude/AbsPrel.hi
deleted file mode 100644
index 0eba17f161..0000000000
--- a/ghc/compiler/prelude/AbsPrel.hi
+++ /dev/null
@@ -1,170 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface AbsPrel where
-import Class(Class)
-import CmdLineOpts(GlobalSwitch)
-import CoreSyn(CoreExpr)
-import HeapOffs(HeapOffset)
-import Id(Id)
-import Maybes(Labda)
-import Name(Name)
-import NameTypes(FullName, ShortName)
-import Outputable(NamedThing, Outputable)
-import PlainCore(PlainCoreExpr(..))
-import PrelFuns(gLASGOW_MISC, gLASGOW_ST, pRELUDE, pRELUDE_BUILTIN, pRELUDE_CORE, pRELUDE_IO, pRELUDE_LIST, pRELUDE_PRIMIO, pRELUDE_PS, pRELUDE_RATIO, pRELUDE_TEXT)
-import PrelVals(aBSENT_ERROR_ID, appendId, augmentId, buildId, eRROR_ID, foldlId, foldrId, integerMinusOneId, integerPlusOneId, integerPlusTwoId, integerZeroId, mkBuild, mkFoldl, mkFoldr, pAT_ERROR_ID, packStringForCId, realWorldPrimId, unpackCString2Id, unpackCStringAppendId, unpackCStringFoldrId, unpackCStringId, voidPrimId)
-import PreludePS(_PackedString)
-import Pretty(PprStyle, PrettyRep)
-import PrimKind(PrimKind)
-import PrimOps(HeapRequirement(..), PrimOp(..), PrimOpResultInfo(..), fragilePrimOp, getPrimOpResultInfo, isCompareOp, pprPrimOp, primOpCanTriggerGC, primOpHeapReq, primOpIsCheap, primOpNameInfo, primOpNeedsWrapper, primOpOkForSpeculation, showPrimOp, typeOfPrimOp)
-import TyCon(TyCon)
-import TyVar(TyVar, TyVarTemplate)
-import TysPrim(addrPrimTy, addrPrimTyCon, charPrimTy, charPrimTyCon, doublePrimTy, doublePrimTyCon, floatPrimTy, floatPrimTyCon, intPrimTy, intPrimTyCon, realWorldStatePrimTy, realWorldTy, realWorldTyCon, voidPrimTy, wordPrimTy, wordPrimTyCon)
-import TysWiredIn(addrDataCon, addrTy, addrTyCon, boolTy, boolTyCon, charDataCon, charTy, charTyCon, cmpTagTy, consDataCon, doubleDataCon, doubleTy, doubleTyCon, eqPrimDataCon, falseDataCon, floatDataCon, floatTy, floatTyCon, getStatePairingConInfo, gtPrimDataCon, intDataCon, intTy, intTyCon, integerDataCon, integerTy, integerTyCon, liftDataCon, liftTyCon, listTyCon, ltPrimDataCon, mkLiftTy, mkListTy, mkPrimIoTy, mkTupleTy, nilDataCon, ratioDataCon, rationalTy, rationalTyCon, realWorldStateTy, stateDataCon, stringTy, trueDataCon, unitTy, wordDataCon, wordTy, wordTyCon)
-import UniType(TauType(..), UniType)
-import Unique(Unique)
-data GlobalSwitch 
-data CoreExpr a b 
-data HeapOffset 
-data Id 
-data Labda a 
-data Name 
-type PlainCoreExpr = CoreExpr Id Id
-data PprStyle 
-data PrimKind 
-data HeapRequirement   = NoHeapRequired | FixedHeapRequired HeapOffset | VariableHeapRequired
-data PrimOp
-  = CharGtOp | CharGeOp | CharEqOp | CharNeOp | CharLtOp | CharLeOp | IntGtOp | IntGeOp | IntEqOp | IntNeOp | IntLtOp | IntLeOp | WordGtOp | WordGeOp | WordEqOp | WordNeOp | WordLtOp | WordLeOp | AddrGtOp | AddrGeOp | AddrEqOp | AddrNeOp | AddrLtOp | AddrLeOp | FloatGtOp | FloatGeOp | FloatEqOp | FloatNeOp | FloatLtOp | FloatLeOp | DoubleGtOp | DoubleGeOp | DoubleEqOp | DoubleNeOp | DoubleLtOp | DoubleLeOp | OrdOp | ChrOp | IntAddOp | IntSubOp | IntMulOp | IntQuotOp | IntDivOp | IntRemOp | IntNegOp | IntAbsOp | AndOp | OrOp | NotOp | SllOp | SraOp | SrlOp | ISllOp | ISraOp | ISrlOp | Int2WordOp | Word2IntOp | Int2AddrOp | Addr2IntOp | FloatAddOp | FloatSubOp | FloatMulOp | FloatDivOp | FloatNegOp | Float2IntOp | Int2FloatOp | FloatExpOp | FloatLogOp | FloatSqrtOp | FloatSinOp | FloatCosOp | FloatTanOp | FloatAsinOp | FloatAcosOp | FloatAtanOp | FloatSinhOp | FloatCoshOp | FloatTanhOp | FloatPowerOp | DoubleAddOp | DoubleSubOp | DoubleMulOp | DoubleDivOp | DoubleNegOp | Double2IntOp | Int2DoubleOp | Double2FloatOp | Float2DoubleOp | DoubleExpOp | DoubleLogOp | DoubleSqrtOp | DoubleSinOp | DoubleCosOp | DoubleTanOp | DoubleAsinOp | DoubleAcosOp | DoubleAtanOp | DoubleSinhOp | DoubleCoshOp | DoubleTanhOp | DoublePowerOp | IntegerAddOp | IntegerSubOp | IntegerMulOp | IntegerQuotRemOp | IntegerDivModOp | IntegerNegOp | IntegerCmpOp | Integer2IntOp | Int2IntegerOp | Word2IntegerOp | Addr2IntegerOp | FloatEncodeOp | FloatDecodeOp | DoubleEncodeOp | DoubleDecodeOp | NewArrayOp | NewByteArrayOp PrimKind | SameMutableArrayOp | SameMutableByteArrayOp | ReadArrayOp | WriteArrayOp | IndexArrayOp | ReadByteArrayOp PrimKind | WriteByteArrayOp PrimKind | IndexByteArrayOp PrimKind | IndexOffAddrOp PrimKind | UnsafeFreezeArrayOp | UnsafeFreezeByteArrayOp | NewSynchVarOp | TakeMVarOp | PutMVarOp | ReadIVarOp | WriteIVarOp | MakeStablePtrOp | DeRefStablePtrOp | CCallOp _PackedString Bool Bool [UniType] UniType | ErrorIOPrimOp | ReallyUnsafePtrEqualityOp | SeqOp | ParOp | ForkOp | DelayOp | WaitOp
-data PrimOpResultInfo   = ReturnsPrim PrimKind | ReturnsAlg TyCon
-data TyCon 
-type TauType = UniType
-data UniType 
-data Unique 
-gLASGOW_MISC :: _PackedString
-gLASGOW_ST :: _PackedString
-pRELUDE :: _PackedString
-pRELUDE_BUILTIN :: _PackedString
-pRELUDE_CORE :: _PackedString
-pRELUDE_IO :: _PackedString
-pRELUDE_LIST :: _PackedString
-pRELUDE_PRIMIO :: _PackedString
-pRELUDE_PS :: _PackedString
-pRELUDE_RATIO :: _PackedString
-pRELUDE_TEXT :: _PackedString
-aBSENT_ERROR_ID :: Id
-appendId :: Id
-augmentId :: Id
-buildId :: Id
-eRROR_ID :: Id
-foldlId :: Id
-foldrId :: Id
-integerMinusOneId :: Id
-integerPlusOneId :: Id
-integerPlusTwoId :: Id
-integerZeroId :: Id
-mkBuild :: UniType -> TyVar -> Id -> Id -> Id -> CoreExpr Id Id -> CoreExpr Id Id
-mkFoldl :: UniType -> UniType -> Id -> Id -> Id -> CoreExpr a Id
-mkFoldr :: UniType -> UniType -> Id -> Id -> Id -> CoreExpr a Id
-fragilePrimOp :: PrimOp -> Bool
-getPrimOpResultInfo :: PrimOp -> PrimOpResultInfo
-isCompareOp :: PrimOp -> Bool
-addrPrimTy :: UniType
-addrPrimTyCon :: TyCon
-charPrimTy :: UniType
-charPrimTyCon :: TyCon
-doublePrimTy :: UniType
-doublePrimTyCon :: TyCon
-floatPrimTy :: UniType
-floatPrimTyCon :: TyCon
-intPrimTy :: UniType
-intPrimTyCon :: TyCon
-addrDataCon :: Id
-addrTy :: UniType
-addrTyCon :: TyCon
-boolTy :: UniType
-boolTyCon :: TyCon
-builtinNameInfo :: (GlobalSwitch -> Bool) -> (_PackedString -> Labda Name, _PackedString -> Labda Name)
-charDataCon :: Id
-charTy :: UniType
-charTyCon :: TyCon
-cmpTagTy :: UniType
-consDataCon :: Id
-doubleDataCon :: Id
-doubleTy :: UniType
-doubleTyCon :: TyCon
-eqPrimDataCon :: Id
-falseDataCon :: Id
-floatDataCon :: Id
-floatTy :: UniType
-floatTyCon :: TyCon
-getStatePairingConInfo :: UniType -> (Id, UniType)
-gtPrimDataCon :: Id
-intDataCon :: Id
-intTy :: UniType
-intTyCon :: TyCon
-integerDataCon :: Id
-integerTy :: UniType
-integerTyCon :: TyCon
-liftDataCon :: Id
-liftTyCon :: TyCon
-listTyCon :: TyCon
-ltPrimDataCon :: Id
-mkFunTy :: UniType -> UniType -> UniType
-pAT_ERROR_ID :: Id
-packStringForCId :: Id
-realWorldPrimId :: Id
-unpackCString2Id :: Id
-unpackCStringAppendId :: Id
-unpackCStringFoldrId :: Id
-unpackCStringId :: Id
-voidPrimId :: Id
-pprPrimOp :: PprStyle -> PrimOp -> Int -> Bool -> PrettyRep
-primOpCanTriggerGC :: PrimOp -> Bool
-primOpHeapReq :: PrimOp -> HeapRequirement
-primOpIsCheap :: PrimOp -> Bool
-primOpNameInfo :: PrimOp -> (_PackedString, Name)
-primOpNeedsWrapper :: PrimOp -> Bool
-primOpOkForSpeculation :: PrimOp -> Bool
-showPrimOp :: PprStyle -> PrimOp -> [Char]
-typeOfPrimOp :: PrimOp -> UniType
-realWorldStatePrimTy :: UniType
-realWorldTy :: UniType
-realWorldTyCon :: TyCon
-voidPrimTy :: UniType
-wordPrimTy :: UniType
-wordPrimTyCon :: TyCon
-mkLiftTy :: UniType -> UniType
-mkListTy :: UniType -> UniType
-mkPrimIoTy :: UniType -> UniType
-mkTupleTy :: Int -> [UniType] -> UniType
-nilDataCon :: Id
-ratioDataCon :: Id
-rationalTy :: UniType
-rationalTyCon :: TyCon
-readUnfoldingPrimOp :: _PackedString -> PrimOp
-realWorldStateTy :: UniType
-stateDataCon :: Id
-stringTy :: UniType
-trueDataCon :: Id
-unitTy :: UniType
-wordDataCon :: Id
-wordTy :: UniType
-wordTyCon :: TyCon
-instance Eq GlobalSwitch
-instance Eq Id
-instance Eq PrimKind
-instance Eq PrimOp
-instance Eq TyCon
-instance Eq Unique
-instance Ord GlobalSwitch
-instance Ord Id
-instance Ord PrimKind
-instance Ord TyCon
-instance Ord Unique
-instance NamedThing Id
-instance NamedThing TyCon
-instance Outputable Id
-instance Outputable PrimKind
-instance Outputable PrimOp
-instance Outputable TyCon
-instance Text Unique
-
diff --git a/ghc/compiler/prelude/AbsPrel.lhs b/ghc/compiler/prelude/AbsPrel.lhs
deleted file mode 100644
index 3f58196095..0000000000
--- a/ghc/compiler/prelude/AbsPrel.lhs
+++ /dev/null
@@ -1,622 +0,0 @@
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
-%
-\section[AbsPrel]{The @AbsPrel@ interface to the compiler's prelude knowledge}
-
-\begin{code}
-#include "HsVersions.h"
-
-module AbsPrel (
-
--- unlike most export lists, this one is actually interesting :-)
-
-	-- re-export some PrimOp stuff:
-	PrimOp(..), typeOfPrimOp, primOpNameInfo,
-	HeapRequirement(..), primOpHeapReq, primOpCanTriggerGC, 
-	primOpNeedsWrapper, primOpOkForSpeculation, primOpIsCheap,
-	fragilePrimOp,
-	PrimOpResultInfo(..), getPrimOpResultInfo,
-	pprPrimOp, showPrimOp, isCompareOp,
-	readUnfoldingPrimOp,  -- actually, defined herein
-
-	pRELUDE, pRELUDE_BUILTIN, pRELUDE_CORE, pRELUDE_RATIO,
-	pRELUDE_LIST, pRELUDE_TEXT, --OLD: pRELUDE_ARRAY, pRELUDE_COMPLEX,
-	pRELUDE_PRIMIO, pRELUDE_IO, pRELUDE_PS,
-	gLASGOW_ST, {-gLASGOW_IO,-} gLASGOW_MISC,
-
-	-- lookup functions for built-in names, for the renamer:
-	builtinNameInfo,
-
-	-- *odd* values that need to be reached out and grabbed:
-	eRROR_ID, pAT_ERROR_ID, aBSENT_ERROR_ID,
-	packStringForCId,
-	unpackCStringId, unpackCString2Id,
-	unpackCStringAppendId, unpackCStringFoldrId,
-	integerZeroId, integerPlusOneId,
-	integerPlusTwoId, integerMinusOneId,
-
-#ifdef DPH
-	-- ProcessorClass
-	toPodId,
-
-	-- Pid Class
-	fromDomainId, toDomainId,
-#endif {- Data Parallel Haskell -}
-
-	-----------------------------------------------------
-	-- the rest of the export list is organised by *type*
-	-----------------------------------------------------
-
-	-- "type": functions ("arrow" type constructor)
-	mkFunTy,
-
-	-- type: Bool
-	boolTyCon, boolTy, falseDataCon, trueDataCon,
-
-	-- types: Char#, Char, String (= [Char])
-	charPrimTy, charTy, stringTy,
-	charPrimTyCon, charTyCon, charDataCon,
-
-	-- type: CMP_TAG (used in deriving)
-	cmpTagTy, ltPrimDataCon, eqPrimDataCon, gtPrimDataCon,
-
-	-- types: Double#, Double
-	doublePrimTy, doubleTy,
-	doublePrimTyCon, doubleTyCon, doubleDataCon,
-
-	-- types: Float#, Float
-	floatPrimTy, floatTy,
-	floatPrimTyCon, floatTyCon, floatDataCon,
-
-	-- types: Glasgow *primitive* arrays, sequencing and I/O
-	mkPrimIoTy, -- to typecheck "mainIO", "mainPrimIO" & for _ccall_s
-	realWorldStatePrimTy, realWorldStateTy{-boxed-},
-	realWorldTy, realWorldTyCon, realWorldPrimId,
-	stateDataCon, getStatePairingConInfo,
-
-	-- types: Void# (only used within the compiler)
-	voidPrimTy, voidPrimId,
-
-	-- types: Addr#, Int#, Word#, Int
-	intPrimTy, intTy, intPrimTyCon, intTyCon, intDataCon,
-	wordPrimTyCon, wordPrimTy, wordTy, wordTyCon, wordDataCon,
-	addrPrimTyCon, addrPrimTy, addrTy, addrTyCon, addrDataCon,
-
-	-- types: Integer, Rational (= Ratio Integer)
-	integerTy, rationalTy,
-	integerTyCon, integerDataCon,
-	rationalTyCon, ratioDataCon,
-
-	-- type: Lift
-	liftTyCon, liftDataCon, mkLiftTy,
-
-	-- type: List
-	listTyCon, mkListTy, nilDataCon, consDataCon,
-	-- NOT USED: buildDataCon,
-
-	-- type: tuples
-	mkTupleTy, unitTy,
-
-	-- packed Strings
---	packedStringTyCon, packedStringTy, psDataCon, cpsDataCon,
-
-	-- for compilation of List Comprehensions and foldr
-	foldlId, foldrId, mkFoldl, mkFoldr,
-	mkBuild, buildId, augmentId, appendId,
-
-#ifdef DPH
-	mkProcessorTy,
-        mkPodTy, mkPodNTy, podTyCon,			     -- user model
-	mkPodizedPodNTy, 		     		     -- podized model
-	mkInterfacePodNTy, interfacePodTyCon, mKINTERPOD_ID, -- interface model
-
-        -- Misc used during podization
-        primIfromPodNSelectorId,
-#endif {- Data Parallel Haskell -}
-
-	-- and, finally, we must put in some (abstract) data types,
-	-- to make the interface self-sufficient
-	GlobalSwitch, Id, Maybe, Name, PprStyle, PrimKind, HeapOffset,
-	TyCon, UniType, TauType(..), Unique, CoreExpr, PlainCoreExpr(..)
-
-	IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
-	IF_ATTACK_PRAGMAS(COMMA mkStatePrimTy)
-
-#ifndef __GLASGOW_HASKELL__
-	,TAG_
-#endif
-    ) where
-
-#ifdef DPH
-import TyPod
-import TyProcs
-#endif {- Data Parallel Haskell -}
-
-import PrelFuns		-- help functions, types and things
-import PrimKind
-
-import TysPrim		-- TYPES
-import TysWiredIn
-import PrelVals		-- VALUES
-import PrimOps		-- PRIMITIVE OPS
-
-import AbsUniType	( getTyConDataCons, TyCon
-			  IF_ATTACK_PRAGMAS(COMMA cmpTyCon)
-			)
-import CmdLineOpts	( GlobalSwitch(..) )
-import FiniteMap
-import Id		( Id )
---OLD:import NameEnv
-import Maybes
-import Unique		-- *Key stuff
-import Util
-\end{code}
-
-This little devil is too small to merit its own ``TyFun'' module:
-
-\begin{code}
-mkFunTy = UniFun
-\end{code}
-
-%************************************************************************
-%*									*
-\subsection[builtinNameInfo]{Lookup built-in names}
-%*									*
-%************************************************************************
-
-We have two ``builtin name funs,'' one to look up @TyCons@ and
-@Classes@, the other to look up values.
-
-\begin{code}
-builtinNameInfo :: (GlobalSwitch -> Bool)	-- access to global cmd-line flags
-		-> (FAST_STRING -> Maybe Name,	-- name lookup fn for values
-		    FAST_STRING -> Maybe Name)	-- name lookup fn for tycons/classes
-
-builtinNameInfo switch_is_on
-  = (init_val_lookup_fn, init_tc_lookup_fn)
-  where
-    --
-    -- values (including data constructors)
-    --
-    init_val_lookup_fn
-      =	if	switch_is_on HideBuiltinNames then
-		(\ x -> Nothing)
-	else if switch_is_on HideMostBuiltinNames then
-		lookupFM (listToFM min_val_assoc_list)
-		-- OLD: mkStringLookupFn min_val_assoc_list False{-not pre-sorted-}
-	else
-		lookupFM (listToFM (concat list_of_val_assoc_lists))
-		-- mkStringLookupFn (concat list_of_val_assoc_lists) False{-not pre-sorted-}
-
-    min_val_assoc_list		-- this is an ad-hoc list; what "happens"
-	=  totally_wired_in_Ids	-- to be needed (when compiling bits of
-	++ unboxed_ops		-- Prelude).
-	++ (concat (map pcDataConNameInfo min_nonprim_tycon_list))
-
-    -- 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.
-    list_of_val_assoc_lists
-    	= [ -- each list is empty or all there
-
-	    totally_wired_in_Ids,
-
-	    concat (map pcDataConNameInfo data_tycons),
-
-	    unboxed_ops,
-
-	    if switch_is_on ForConcurrent then parallel_vals else []
-	  ]
-
-    --
-    -- type constructors and classes
-    --
-    init_tc_lookup_fn
-      =	if	switch_is_on HideBuiltinNames then
-		(\ x -> Nothing)
-	else if switch_is_on HideMostBuiltinNames then
-		lookupFM (listToFM min_tc_assoc_list)
-		--OLD: mkStringLookupFn min_tc_assoc_list False{-not pre-sorted-}
-	else
-		lookupFM (listToFM (
-		-- OLD: mkStringLookupFn
-		    map pcTyConNameInfo (data_tycons ++ synonym_tycons)
-		    ++ std_tycon_list -- TyCons not quite so wired in
-		    ++ std_class_list
-		    ++ prim_tys))
-		    -- The prim_tys,etc., are OK, because they all
-		    -- have "non-standard" names (and we really
-		    -- want them for interface pragmas).
-		  --OLD: False{-not pre-sorted-}
-
-    min_tc_assoc_list	-- again, pretty ad-hoc
-	= prim_tys ++ (map pcTyConNameInfo min_nonprim_tycon_list)
---HA!	  ++ std_class_list -- no harm in this
-
-min_nonprim_tycon_list -- used w/ HideMostBuiltinNames
-  = [ boolTyCon,
-      cmpTagTyCon,
-      charTyCon,
-      intTyCon,
-      floatTyCon,
-      doubleTyCon,
-      integerTyCon,
-      ratioTyCon,
-      liftTyCon,
-      return2GMPsTyCon,	-- ADR asked for these last two (WDP 94/11)
-      returnIntAndGMPTyCon ]
-
--- sigh: I (WDP) think these should be local defns
--- but you cannot imagine how bad it is for speed (w/ GHC)
-prim_tys    = map pcTyConNameInfo prim_tycons
-
--- values
-
-totally_wired_in_Ids
-  = [(SLIT(":"),		WiredInVal consDataCon),
-     (SLIT("error"),		WiredInVal eRROR_ID),
-     (SLIT("patError#"),	WiredInVal pAT_ERROR_ID), -- occurs in i/faces
-     (SLIT("parError#"),	WiredInVal pAR_ERROR_ID), -- ditto
-     (SLIT("_trace"),		WiredInVal tRACE_ID),
-
-     -- now the foldr/build Ids, which need to be built in
-     -- because they have magic unfoldings
-     (SLIT("_build"),		WiredInVal buildId),
-     (SLIT("_augment"),		WiredInVal augmentId),
-     (SLIT("foldl"),		WiredInVal foldlId),
-     (SLIT("foldr"),		WiredInVal foldrId),
-     (SLIT("unpackAppendPS#"),	WiredInVal unpackCStringAppendId),
-     (SLIT("unpackFoldrPS#"),	WiredInVal unpackCStringFoldrId),
-
-     (SLIT("_runST"),		WiredInVal runSTId),
-     (SLIT("_seq_"),		WiredInVal seqId),  -- yes, used in sequential-land, too
-						    -- WDP 95/11
-    (SLIT("realWorld#"),	WiredInVal realWorldPrimId)
-    ]
-
-parallel_vals
-  =[(SLIT("_par_"),		WiredInVal parId),
-    (SLIT("_fork_"),		WiredInVal forkId)
-#ifdef GRAN
-    ,
-    (SLIT("_parLocal_"),	WiredInVal parLocalId),
-    (SLIT("_parGlobal_"),	WiredInVal parGlobalId)
-    -- Add later:
-    -- (SLIT("_parAt_"),	WiredInVal parAtId)
-    -- (SLIT("_parAtForNow_"),	WiredInVal parAtForNowId)
-    -- (SLIT("_copyable_"),	WiredInVal copyableId)
-    -- (SLIT("_noFollow_"),	WiredInVal noFollowId)
-#endif {-GRAN-}
-   ]
-
-unboxed_ops
-  = (map primOpNameInfo lots_of_primops)
-   ++
-    -- plus some of the same ones but w/ different names
-   [case (primOpNameInfo IntAddOp) 	of (_,n) -> (SLIT("+#"),   n),
-    case (primOpNameInfo IntSubOp) 	of (_,n) -> (SLIT("-#"),   n),
-    case (primOpNameInfo IntMulOp) 	of (_,n) -> (SLIT("*#"),   n),
-    case (primOpNameInfo IntGtOp)  	of (_,n) -> (SLIT(">#"),   n),
-    case (primOpNameInfo IntGeOp)  	of (_,n) -> (SLIT(">=#"),  n),
-    case (primOpNameInfo IntEqOp)  	of (_,n) -> (SLIT("==#"),  n),
-    case (primOpNameInfo IntNeOp)  	of (_,n) -> (SLIT("/=#"),  n),
-    case (primOpNameInfo IntLtOp)  	of (_,n) -> (SLIT("<#"),   n),
-    case (primOpNameInfo IntLeOp)  	of (_,n) -> (SLIT("<=#"),  n),
-    case (primOpNameInfo DoubleAddOp)   of (_,n) -> (SLIT("+##"),  n),
-    case (primOpNameInfo DoubleSubOp)   of (_,n) -> (SLIT("-##"),  n),
-    case (primOpNameInfo DoubleMulOp)   of (_,n) -> (SLIT("*##"),  n),
-    case (primOpNameInfo DoubleDivOp)   of (_,n) -> (SLIT("/##"),  n),
-    case (primOpNameInfo DoublePowerOp) of (_,n) -> (SLIT("**##"), n),
-    case (primOpNameInfo DoubleGtOp)    of (_,n) -> (SLIT(">##"),  n),
-    case (primOpNameInfo DoubleGeOp)    of (_,n) -> (SLIT(">=##"), n),
-    case (primOpNameInfo DoubleEqOp)    of (_,n) -> (SLIT("==##"), n),
-    case (primOpNameInfo DoubleNeOp)    of (_,n) -> (SLIT("/=##"), n),
-    case (primOpNameInfo DoubleLtOp)    of (_,n) -> (SLIT("<##"),  n),
-    case (primOpNameInfo DoubleLeOp)    of (_,n) -> (SLIT("<=##"), n)]
-
-prim_tycons
-  = [addrPrimTyCon,
-     arrayPrimTyCon,
-     byteArrayPrimTyCon,
-     charPrimTyCon,
-     doublePrimTyCon,
-     floatPrimTyCon,
-     intPrimTyCon,
-     mallocPtrPrimTyCon,
-     mutableArrayPrimTyCon,
-     mutableByteArrayPrimTyCon,
-     synchVarPrimTyCon,
-     realWorldTyCon,
-     stablePtrPrimTyCon,
-     statePrimTyCon,
-     wordPrimTyCon
-    ]
-
-std_tycon_list
-  = let
-	swizzle_over (mod, nm, key, arity, is_data)
-	  = let
-		fname = mkPreludeCoreName mod nm
-	    in
-	    (nm, PreludeTyCon key fname arity is_data)
-    in
-    map swizzle_over
-	[--(pRELUDE_IO,	   SLIT("Request"),  requestTyConKey,  0, True),
---OLD:	 (pRELUDE_IO,	   SLIT("Response"), responseTyConKey, 0, True),
-	 (pRELUDE_IO,	   SLIT("Dialogue"), dialogueTyConKey, 0, False),
-	 (SLIT("PreludeMonadicIO"), SLIT("IO"), iOTyConKey,    1, False)
-	]
-
--- Several of these are non-std, but they have non-std
--- names, so they won't get past the parser in user code
--- (but will be visible for interface-pragma purposes).
-
-data_tycons
-  = [addrTyCon,
-     boolTyCon,
---   byteArrayTyCon,
-     charTyCon,
-     cmpTagTyCon,
-     doubleTyCon,
-     floatTyCon,
-     intTyCon,
-     integerTyCon,
-     liftTyCon,
-     mallocPtrTyCon,
---   mutableArrayTyCon,
---   mutableByteArrayTyCon,
-     ratioTyCon,
-     return2GMPsTyCon,
-     returnIntAndGMPTyCon,
-     stablePtrTyCon,
-     stateAndAddrPrimTyCon,
-     stateAndArrayPrimTyCon,
-     stateAndByteArrayPrimTyCon,
-     stateAndCharPrimTyCon,
-     stateAndDoublePrimTyCon,
-     stateAndFloatPrimTyCon,
-     stateAndIntPrimTyCon,
-     stateAndMallocPtrPrimTyCon,
-     stateAndMutableArrayPrimTyCon,
-     stateAndMutableByteArrayPrimTyCon,
-     stateAndSynchVarPrimTyCon,
-     stateAndPtrPrimTyCon,
-     stateAndStablePtrPrimTyCon,
-     stateAndWordPrimTyCon,
-     stateTyCon,
-     wordTyCon
-#ifdef DPH
-     ,podTyCon
-#endif {- Data Parallel Haskell -}
-    ]
-
-synonym_tycons
-  = [primIoTyCon,
-     rationalTyCon,
-     stTyCon,
-     stringTyCon]
-
-std_class_list
-  = let
-	swizzle_over (str, key)
-	  = (str, PreludeClass key (mkPreludeCoreName pRELUDE_CORE str))
-    in
-    map swizzle_over
-	[(SLIT("Eq"),		eqClassKey),
-	 (SLIT("Ord"),		ordClassKey),
-	 (SLIT("Num"),		numClassKey),
-	 (SLIT("Real"),		realClassKey),
-	 (SLIT("Integral"),	integralClassKey),
-	 (SLIT("Fractional"),	fractionalClassKey),
-	 (SLIT("Floating"),	floatingClassKey),
-	 (SLIT("RealFrac"),	realFracClassKey),
-	 (SLIT("RealFloat"),	realFloatClassKey),
-	 (SLIT("Ix"),		ixClassKey),
-	 (SLIT("Enum"),		enumClassKey),
-	 (SLIT("Text"),		textClassKey),
-	 (SLIT("_CCallable"),	cCallableClassKey),
-	 (SLIT("_CReturnable"), cReturnableClassKey),
-	 (SLIT("Binary"),	binaryClassKey)
-#ifdef DPH
-	 , (SLIT("Pid"),	pidClassKey)
-	 , (SLIT("Processor"),processorClassKey)
-#endif {- Data Parallel Haskell -}
-	]
-
-lots_of_primops
-  = [	CharGtOp,
-	CharGeOp,
-	CharEqOp,
-	CharNeOp,
-	CharLtOp,
-	CharLeOp,
-	IntGtOp,
-	IntGeOp,
-	IntEqOp,
-	IntNeOp,
-	IntLtOp,
-	IntLeOp,
-	WordGtOp,
-	WordGeOp,
-	WordEqOp,
-	WordNeOp,
-	WordLtOp,
-	WordLeOp,
-	AddrGtOp,
-	AddrGeOp,
-	AddrEqOp,
-	AddrNeOp,
-	AddrLtOp,
-	AddrLeOp,
-	FloatGtOp,
-	FloatGeOp,
-	FloatEqOp,
-	FloatNeOp,
-	FloatLtOp,
-	FloatLeOp,
-	DoubleGtOp,
-	DoubleGeOp,
-	DoubleEqOp,
-	DoubleNeOp,
-	DoubleLtOp,
-	DoubleLeOp,
-	OrdOp,
-	ChrOp,
-	IntAddOp,
-	IntSubOp,
-	IntMulOp,
-	IntQuotOp,
-	IntRemOp,
-	IntNegOp,
-	AndOp,
-	OrOp,
-	NotOp,
-    	SllOp,
-    	SraOp,
-    	SrlOp,
-    	ISllOp,
-    	ISraOp,
-    	ISrlOp,
-	Int2WordOp,
-	Word2IntOp,
-	Int2AddrOp,
-	Addr2IntOp,
-	FloatAddOp,
-	FloatSubOp,
-	FloatMulOp,
-	FloatDivOp,
-	FloatNegOp,
-	Float2IntOp,
-	Int2FloatOp,
-	FloatExpOp,
-	FloatLogOp,
-	FloatSqrtOp,
-	FloatSinOp,
-	FloatCosOp,
-	FloatTanOp,
-	FloatAsinOp,
-	FloatAcosOp,
-	FloatAtanOp,
-	FloatSinhOp,
-	FloatCoshOp,
-	FloatTanhOp,
-	FloatPowerOp,
-	DoubleAddOp,
-	DoubleSubOp,
-	DoubleMulOp,
-	DoubleDivOp,
-	DoubleNegOp,
-	Double2IntOp,
-	Int2DoubleOp,
-	Double2FloatOp,
-	Float2DoubleOp,
-	DoubleExpOp,
-	DoubleLogOp,
-	DoubleSqrtOp,
-	DoubleSinOp,
-	DoubleCosOp,
-	DoubleTanOp,
-	DoubleAsinOp,
-	DoubleAcosOp,
-	DoubleAtanOp,
-	DoubleSinhOp,
-	DoubleCoshOp,
-	DoubleTanhOp,
-	DoublePowerOp,
-	IntegerAddOp,
-	IntegerSubOp,
-	IntegerMulOp,
-	IntegerQuotRemOp,
-	IntegerDivModOp,
-	IntegerNegOp,
-	IntegerCmpOp,
-	Integer2IntOp,
-	Int2IntegerOp,
-	Word2IntegerOp,
-	Addr2IntegerOp,
-	FloatEncodeOp,
-	FloatDecodeOp,
-	DoubleEncodeOp,
-	DoubleDecodeOp,
-	NewArrayOp,
-	NewByteArrayOp CharKind,
-	NewByteArrayOp IntKind,
-	NewByteArrayOp AddrKind,
-	NewByteArrayOp FloatKind,
-	NewByteArrayOp DoubleKind,
-	SameMutableArrayOp,
-	SameMutableByteArrayOp,
-	ReadArrayOp,
-	WriteArrayOp,
-	IndexArrayOp,
-	ReadByteArrayOp CharKind,
-	ReadByteArrayOp IntKind,
-	ReadByteArrayOp AddrKind,
-	ReadByteArrayOp FloatKind,
-	ReadByteArrayOp DoubleKind,
-	WriteByteArrayOp CharKind,
-	WriteByteArrayOp IntKind,
-	WriteByteArrayOp AddrKind,
-	WriteByteArrayOp FloatKind,
-	WriteByteArrayOp DoubleKind,
-	IndexByteArrayOp CharKind,
-	IndexByteArrayOp IntKind,
-	IndexByteArrayOp AddrKind,
-	IndexByteArrayOp FloatKind,
-	IndexByteArrayOp DoubleKind,
-	IndexOffAddrOp CharKind,
-	IndexOffAddrOp IntKind,
-	IndexOffAddrOp AddrKind,
-	IndexOffAddrOp FloatKind,
-	IndexOffAddrOp DoubleKind,
-	UnsafeFreezeArrayOp,
-	UnsafeFreezeByteArrayOp,
-    	NewSynchVarOp,
-	ReadArrayOp,
-	TakeMVarOp,
-	PutMVarOp,
-	ReadIVarOp,
-	WriteIVarOp,
-	MakeStablePtrOp,
-	DeRefStablePtrOp,
-	ReallyUnsafePtrEqualityOp,
-	ErrorIOPrimOp,
-#ifdef GRAN
-	ParGlobalOp,
-	ParLocalOp,
-#endif {-GRAN-}
-	SeqOp,
-    	ParOp,
-    	ForkOp,
-	DelayOp,
-	WaitOp
-    ]
-\end{code}
-
-\begin{code}
-readUnfoldingPrimOp :: FAST_STRING -> PrimOp
-
-readUnfoldingPrimOp
-  = let
-	-- "reverse" lookup table
-	tbl = map (\ o -> let { (str,_) = primOpNameInfo o } in (str, o)) lots_of_primops
-    in
-    \ str -> case [ op | (s, op) <- tbl, s == str ] of
-	       (op:_) -> op
-#ifdef DEBUG
-	       [] -> panic "readUnfoldingPrimOp" -- ++ _UNPK_ str ++"::"++show (map fst tbl))
-#endif
-\end{code}
-
-Make table entries for various things:
-\begin{code}
-pcTyConNameInfo :: TyCon -> (FAST_STRING, Name)
-pcTyConNameInfo tycon
-  = (getOccurrenceName tycon, WiredInTyCon tycon)
-
-pcDataConNameInfo :: TyCon -> [(FAST_STRING, Name)]
-pcDataConNameInfo tycon
-  = -- slurp out its data constructors...
-    [(getOccurrenceName con, WiredInVal con) | con <- getTyConDataCons tycon]
-\end{code}
diff --git a/ghc/compiler/prelude/PrelFuns.hi b/ghc/compiler/prelude/PrelFuns.hi
deleted file mode 100644
index 2e1b648a4b..0000000000
--- a/ghc/compiler/prelude/PrelFuns.hi
+++ /dev/null
@@ -1,153 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface PrelFuns where
-import Bag(Bag)
-import BasicLit(BasicLit)
-import BinderInfo(BinderInfo)
-import CharSeq(CSeq)
-import Class(Class, ClassOp)
-import CmdLineOpts(GlobalSwitch)
-import CoreSyn(CoreArg, CoreAtom, CoreBinding, CoreCaseAlternatives, CoreCaseDefault, CoreExpr)
-import CostCentre(CostCentre)
-import Id(Id)
-import IdEnv(IdEnv(..))
-import IdInfo(ArgUsage, ArgUsageInfo, ArityInfo, DeforestInfo, Demand, DemandInfo, FBConsum, FBProd, FBType, FBTypeInfo, IdInfo, OptIdInfo(..), SpecEnv, StrictnessInfo, UpdateInfo, arityMaybe, mkArityInfo, mkUnfolding, noIdInfo, noInfo_UF, nullSpecEnv)
-import InstEnv(InstTemplate)
-import MagicUFs(MagicUnfoldingFun)
-import Maybes(Labda)
-import Name(Name(..))
-import NameTypes(FullName, ShortName, mkPreludeCoreName)
-import Outputable(ExportFlag, NamedThing(..), Outputable(..))
-import PlainCore(PlainCoreAtom(..), PlainCoreExpr(..))
-import PreludePS(_PackedString)
-import Pretty(Delay, PprStyle, Pretty(..), PrettyRep)
-import PrimKind(PrimKind(..))
-import PrimOps(PrimOp(..))
-import SimplEnv(FormSummary, UnfoldingDetails, UnfoldingGuidance(..))
-import SrcLoc(SrcLoc)
-import TyCon(Arity(..), TyCon)
-import TyVar(TyVar, TyVarTemplate, alpha_tv, alpha_tyvar, beta_tv, beta_tyvar, delta_tv, delta_tyvar, epsilon_tv, epsilon_tyvar, gamma_tv, gamma_tyvar)
-import TyVarEnv(TyVarEnv(..))
-import UniType(SigmaType(..), TauType(..), ThetaType(..), UniType(..), alpha, alpha_ty, beta, beta_ty, delta, delta_ty, epsilon, epsilon_ty, gamma, gamma_ty)
-import UniqFM(UniqFM)
-import Unique(Unique)
-class OptIdInfo a where
-	noInfo :: a
-	getInfo :: IdInfo -> a
-	addInfo :: IdInfo -> a -> IdInfo
-	ppInfo :: PprStyle -> (Id -> Id) -> a -> Int -> Bool -> PrettyRep
-class NamedThing a where
-	getExportFlag :: a -> ExportFlag
-	isLocallyDefined :: a -> Bool
-	getOrigName :: a -> (_PackedString, _PackedString)
-	getOccurrenceName :: a -> _PackedString
-	getInformingModules :: a -> [_PackedString]
-	getSrcLoc :: a -> SrcLoc
-	getTheUnique :: a -> Unique
-	hasType :: a -> Bool
-	getType :: a -> UniType
-	fromPreludeCore :: a -> Bool
-class Outputable a where
-	ppr :: PprStyle -> a -> Int -> Bool -> PrettyRep
-data Bag a 
-data BasicLit 
-data BinderInfo 
-data Class 
-data ClassOp 
-data GlobalSwitch 
-data CoreArg a 
-data CoreAtom a 
-data CoreBinding a b 
-data CoreCaseAlternatives a b 
-data CoreCaseDefault a b 
-data CoreExpr a b 
-data CostCentre 
-data Id 
-type IdEnv a = UniqFM a
-data ArgUsage 
-data ArgUsageInfo 
-data ArityInfo 
-data DeforestInfo 
-data Demand 
-data DemandInfo 
-data FBConsum 
-data FBProd 
-data FBType 
-data FBTypeInfo 
-data IdInfo 
-data SpecEnv 
-data StrictnessInfo 
-data UpdateInfo 
-data InstTemplate 
-data Labda a 
-data Name   = Short Unique ShortName | WiredInTyCon TyCon | WiredInVal Id | PreludeVal Unique FullName | PreludeTyCon Unique FullName Int Bool | PreludeClass Unique FullName | OtherTyCon Unique FullName Int Bool [Name] | OtherClass Unique FullName [Name] | OtherTopId Unique FullName | ClassOpName Unique Name _PackedString Int | Unbound _PackedString
-data FullName 
-data ShortName 
-data ExportFlag 
-type PlainCoreAtom = CoreAtom Id
-type PlainCoreExpr = CoreExpr Id Id
-data PprStyle 
-type Pretty = Int -> Bool -> PrettyRep
-data PrettyRep 
-data PrimKind   = PtrKind | CodePtrKind | DataPtrKind | RetKind | InfoPtrKind | CostCentreKind | CharKind | IntKind | WordKind | AddrKind | FloatKind | DoubleKind | MallocPtrKind | StablePtrKind | ArrayKind | ByteArrayKind | VoidKind
-data PrimOp
-  = CharGtOp | CharGeOp | CharEqOp | CharNeOp | CharLtOp | CharLeOp | IntGtOp | IntGeOp | IntEqOp | IntNeOp | IntLtOp | IntLeOp | WordGtOp | WordGeOp | WordEqOp | WordNeOp | WordLtOp | WordLeOp | AddrGtOp | AddrGeOp | AddrEqOp | AddrNeOp | AddrLtOp | AddrLeOp | FloatGtOp | FloatGeOp | FloatEqOp | FloatNeOp | FloatLtOp | FloatLeOp | DoubleGtOp | DoubleGeOp | DoubleEqOp | DoubleNeOp | DoubleLtOp | DoubleLeOp | OrdOp | ChrOp | IntAddOp | IntSubOp | IntMulOp | IntQuotOp | IntDivOp | IntRemOp | IntNegOp | IntAbsOp | AndOp | OrOp | NotOp | SllOp | SraOp | SrlOp | ISllOp | ISraOp | ISrlOp | Int2WordOp | Word2IntOp | Int2AddrOp | Addr2IntOp | FloatAddOp | FloatSubOp | FloatMulOp | FloatDivOp | FloatNegOp | Float2IntOp | Int2FloatOp | FloatExpOp | FloatLogOp | FloatSqrtOp | FloatSinOp | FloatCosOp | FloatTanOp | FloatAsinOp | FloatAcosOp | FloatAtanOp | FloatSinhOp | FloatCoshOp | FloatTanhOp | FloatPowerOp | DoubleAddOp | DoubleSubOp | DoubleMulOp | DoubleDivOp | DoubleNegOp | Double2IntOp | Int2DoubleOp | Double2FloatOp | Float2DoubleOp | DoubleExpOp | DoubleLogOp | DoubleSqrtOp | DoubleSinOp | DoubleCosOp | DoubleTanOp | DoubleAsinOp | DoubleAcosOp | DoubleAtanOp | DoubleSinhOp | DoubleCoshOp | DoubleTanhOp | DoublePowerOp | IntegerAddOp | IntegerSubOp | IntegerMulOp | IntegerQuotRemOp | IntegerDivModOp | IntegerNegOp | IntegerCmpOp | Integer2IntOp | Int2IntegerOp | Word2IntegerOp | Addr2IntegerOp | FloatEncodeOp | FloatDecodeOp | DoubleEncodeOp | DoubleDecodeOp | NewArrayOp | NewByteArrayOp PrimKind | SameMutableArrayOp | SameMutableByteArrayOp | ReadArrayOp | WriteArrayOp | IndexArrayOp | ReadByteArrayOp PrimKind | WriteByteArrayOp PrimKind | IndexByteArrayOp PrimKind | IndexOffAddrOp PrimKind | UnsafeFreezeArrayOp | UnsafeFreezeByteArrayOp | NewSynchVarOp | TakeMVarOp | PutMVarOp | ReadIVarOp | WriteIVarOp | MakeStablePtrOp | DeRefStablePtrOp | CCallOp _PackedString Bool Bool [UniType] UniType | ErrorIOPrimOp | ReallyUnsafePtrEqualityOp | SeqOp | ParOp | ForkOp | DelayOp | WaitOp
-data UnfoldingDetails 
-data UnfoldingGuidance   = UnfoldNever | UnfoldAlways | EssentialUnfolding | UnfoldIfGoodArgs Int Int [Bool] Int | BadUnfolding
-data SrcLoc 
-type Arity = Int
-data TyCon 
-data TyVar 
-data TyVarTemplate 
-type TyVarEnv a = UniqFM a
-type SigmaType = UniType
-type TauType = UniType
-type ThetaType = [(Class, UniType)]
-data UniType   = UniTyVar TyVar | UniFun UniType UniType | UniData TyCon [UniType] | UniSyn TyCon [UniType] UniType | UniDict Class UniType | UniTyVarTemplate TyVarTemplate | UniForall TyVarTemplate UniType
-data UniqFM a 
-data Unique 
-arityMaybe :: ArityInfo -> Labda Int
-mkArityInfo :: Int -> ArityInfo
-mkUnfolding :: UnfoldingGuidance -> CoreExpr Id Id -> UnfoldingDetails
-noIdInfo :: IdInfo
-noInfo_UF :: UnfoldingDetails
-nullSpecEnv :: SpecEnv
-mkPreludeCoreName :: _PackedString -> _PackedString -> FullName
-alpha_tv :: TyVarTemplate
-alpha_tyvar :: TyVar
-beta_tv :: TyVarTemplate
-beta_tyvar :: TyVar
-delta_tv :: TyVarTemplate
-delta_tyvar :: TyVar
-epsilon_tv :: TyVarTemplate
-epsilon_tyvar :: TyVar
-gamma_tv :: TyVarTemplate
-gamma_tyvar :: TyVar
-alpha :: UniType
-alpha_ty :: UniType
-beta :: UniType
-beta_ty :: UniType
-delta :: UniType
-delta_ty :: UniType
-epsilon :: UniType
-epsilon_ty :: UniType
-gLASGOW_MISC :: _PackedString
-gLASGOW_ST :: _PackedString
-gamma :: UniType
-gamma_ty :: UniType
-pRELUDE :: _PackedString
-pRELUDE_BUILTIN :: _PackedString
-pRELUDE_CORE :: _PackedString
-pRELUDE_IO :: _PackedString
-pRELUDE_LIST :: _PackedString
-pRELUDE_PRIMIO :: _PackedString
-pRELUDE_PS :: _PackedString
-pRELUDE_RATIO :: _PackedString
-pRELUDE_TEXT :: _PackedString
-pcDataCon :: Unique -> _PackedString -> _PackedString -> [TyVarTemplate] -> [(Class, UniType)] -> [UniType] -> TyCon -> SpecEnv -> Id
-pcDataTyCon :: Unique -> _PackedString -> _PackedString -> [TyVarTemplate] -> [Id] -> TyCon
-pcGenerateDataSpecs :: UniType -> SpecEnv
-pcGenerateSpecs :: Unique -> Id -> IdInfo -> UniType -> SpecEnv
-pcGenerateTupleSpecs :: Int -> UniType -> SpecEnv
-pcMiscPrelId :: Unique -> _PackedString -> _PackedString -> UniType -> IdInfo -> Id
-pcPrimTyCon :: Unique -> _PackedString -> Int -> ([PrimKind] -> PrimKind) -> TyCon
-
diff --git a/ghc/compiler/prelude/PrelFuns.lhs b/ghc/compiler/prelude/PrelFuns.lhs
deleted file mode 100644
index 2b9d240a39..0000000000
--- a/ghc/compiler/prelude/PrelFuns.lhs
+++ /dev/null
@@ -1,260 +0,0 @@
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
-%
-\section[PrelFuns]{Help functions for prelude-related stuff}
-
-\begin{code}
-#include "HsVersions.h"
-
-module PrelFuns (
-	pRELUDE, pRELUDE_BUILTIN, pRELUDE_CORE, pRELUDE_RATIO,
-	pRELUDE_LIST, pRELUDE_TEXT,  --OLD: pRELUDE_ARRAY, pRELUDE_COMPLEX,
-	pRELUDE_PRIMIO, pRELUDE_IO, pRELUDE_PS,
-	gLASGOW_ST, {-gLASGOW_IO,-} gLASGOW_MISC,
-
-	alpha_tv, alpha, beta_tv, beta,
-	gamma_tv, gamma, delta_tv, delta, epsilon_tv, epsilon,
-	alpha_tyvar, alpha_ty, beta_tyvar, beta_ty,
-	gamma_tyvar, gamma_ty, delta_tyvar, delta_ty,
-	epsilon_tyvar, epsilon_ty,
-
-	pcDataTyCon, pcPrimTyCon,
-	pcDataCon, pcMiscPrelId,
-	pcGenerateSpecs, pcGenerateDataSpecs, pcGenerateTupleSpecs,
-
-	-- mkBuild, mkListFilter,
-
-	-- re-export a few helpful things
-	mkPreludeCoreName, nullSpecEnv,
-
-	IdInfo, ArityInfo, DemandInfo, SpecEnv, StrictnessInfo,
-	UpdateInfo, ArgUsageInfo, ArgUsage, DeforestInfo, FBTypeInfo,
-	FBType, FBConsum, FBProd,
-	OptIdInfo(..),	-- class
-	noIdInfo,
-	mkArityInfo, arityMaybe,
-	noInfo_UF, mkUnfolding, UnfoldingGuidance(..), UnfoldingDetails,
-
-	-- and to make the interface self-sufficient...
-	Outputable(..), NamedThing(..),
-	ExportFlag, SrcLoc, Unique,
-	Pretty(..), PprStyle, PrettyRep,
-	-- urgh: because their instances go out w/ Outputable(..)
-	BasicLit, CoreBinding, CoreCaseAlternatives, CoreArg,
-	CoreCaseDefault, CoreExpr, CoreAtom, TyVarEnv(..),
-	IdEnv(..), UniqFM,
-#ifdef DPH
-	CoreParQuals,
-	CoreParCommunicate,
-#endif {- Data Parallel Haskell -}
-
-	PrimOp(..),			-- NB: non-abstract
-	PrimKind(..),			-- NB: non-abstract
-	Name(..),				-- NB: non-abstract
-	UniType(..),				-- Mega-NB: non-abstract
-
-	Class, ClassOp, Id, FullName, ShortName, TyCon, TyVarTemplate,
-	TyVar, Arity(..), TauType(..), ThetaType(..), SigmaType(..),
-	CostCentre, GlobalSwitch, Maybe, BinderInfo, PlainCoreExpr(..),
-	PlainCoreAtom(..), InstTemplate, Demand, Bag
-	IF_ATTACK_PRAGMAS(COMMA cmpTyCon)
-#ifndef __GLASGOW_HASKELL__
-	,TAG_
-#endif
-    ) where
-
-import AbsUniType	( mkDataTyCon, mkPrimTyCon,
-			  specialiseTy, splitType, applyTyCon,
-			  alpha_tv, alpha, beta_tv, beta, gamma_tv,
-			  gamma, alpha_tyvar, alpha_ty, beta_tyvar,
-			  beta_ty, gamma_tyvar, gamma_ty, delta_tv,
-			  delta, epsilon_tv, epsilon, delta_tyvar,
-			  delta_ty, epsilon_tyvar, epsilon_ty, TyVar,
-			  TyVarTemplate, Class, ClassOp, TyCon,
-			  Arity(..), ThetaType(..), TauType(..),
-			  SigmaType(..), UniType, InstTemplate
-			  IF_ATTACK_PRAGMAS(COMMA pprUniType)
-			  IF_ATTACK_PRAGMAS(COMMA cmpTyCon COMMA cmpTyVar)
-			)
-import Id		( mkPreludeId, mkSpecId, mkDataCon, getIdUniType,
-			  mkTemplateLocals, DataCon(..)
-			)
-import IdInfo		-- lots
-import Maybes		( Maybe(..) )
-import Name		( Name(..) )
-import NameTypes	( mkShortName, mkPreludeCoreName, ShortName, FullName )
-import Outputable
-import PlainCore
-import Pretty
-import PrimKind		( PrimKind(..) )
-import PrimOps		( PrimOp(..)
-			  IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
-			  IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
-			)
-import SrcLoc		( mkBuiltinSrcLoc, SrcLoc )
-import TysPrim		( charPrimTy, intPrimTy, doublePrimTy )
-import UniType		( UniType(..)	-- **** CAN SEE THE CONSTRUCTORS ****
-			  IF_ATTACK_PRAGMAS(COMMA cmpUniType)
-			)
-import Util
-\end{code}
-
-\begin{code}
-pRELUDE		= SLIT("Prelude")
-pRELUDE_BUILTIN = SLIT("PreludeBuiltin")
-pRELUDE_CORE	= SLIT("PreludeCore")
-pRELUDE_RATIO	= SLIT("PreludeRatio")
-pRELUDE_LIST	= SLIT("PreludeList")
---OLD:pRELUDE_ARRAY	= SLIT("PreludeArray")
-pRELUDE_TEXT	= SLIT("PreludeText")
---OLD:pRELUDE_COMPLEX	= SLIT("PreludeComplex")
-pRELUDE_PRIMIO	= SLIT("PreludePrimIO")
-pRELUDE_IO	= SLIT("PreludeIO")
-pRELUDE_PS	= SLIT("PreludePS")
-gLASGOW_ST	= SLIT("PreludeGlaST")
---gLASGOW_IO	= SLIT("PreludeGlaIO")
-gLASGOW_MISC	= SLIT("PreludeGlaMisc")
-\end{code}
-
-\begin{code}
--- things for TyCons -----------------------------------------------------
-
-pcDataTyCon :: Unique{-TyConKey-} -> FAST_STRING -> FAST_STRING -> [TyVarTemplate] -> [Id] -> TyCon
-pcDataTyCon key mod name tyvars cons
-  = mkDataTyCon key full_name arity tyvars cons [{-no derivings-}] True
-  where
-    arity     = length tyvars
-    full_name = mkPreludeCoreName mod name
-
-pcPrimTyCon :: Unique{-TyConKey-} -> FAST_STRING -> Int -> ([PrimKind] -> PrimKind) -> TyCon
-pcPrimTyCon key name arity kind_fn
-  = mkPrimTyCon key full_name arity kind_fn
-  where
-    full_name = mkPreludeCoreName pRELUDE_BUILTIN name
-\end{code}
-
-\begin{code}
--- things for Ids -----------------------------------------------------
-
-pcDataCon :: Unique{-DataConKey-} -> FAST_STRING -> FAST_STRING -> [TyVarTemplate] -> ThetaType -> [TauType] -> TyCon -> SpecEnv -> Id
-pcDataCon key mod name tyvars context arg_tys tycon specenv
-  = mkDataCon key (mkPreludeCoreName mod name) tyvars context arg_tys tycon specenv
-
-pcMiscPrelId :: Unique{-IdKey-} -> FAST_STRING -> FAST_STRING -> UniType -> IdInfo -> Id
-
-pcMiscPrelId key mod name ty info
- = mkPreludeId	key (mkPreludeCoreName mod name) ty info
-\end{code}
-
-@mkBuild@ is suger for building a build !
-@mkbuild ty tv c n e@ $Rightarrow$ @build ty (/\ tv -> \ c n -> e)@
-@ty@ is the type of the list.
-@tv@ is always a new type variable.
-@c,n@ are Id's for the abstract cons and nil
-\begin{verbatim}
-	c :: a -> b -> b
-	n :: b
-	v :: (\/ b . (a -> b -> b) -> b -> b) -> [a]
---  \/ a .  (\/ b . (a -> b -> b) -> b -> b) -> [a]
-\end{verbatim}
-@e@ is the object right inside the @build@
-
-\begin{code}
---LATER: mkBuild :: UniType
---LATER: 	-> TyVar
---LATER: 	-> Id
---LATER: 	-> Id
---LATER: 	-> PlainCoreExpr
---LATER: 	-> PlainCoreExpr
---LATER: mkBuild ty tv c n expr
---LATER:  = CoApp (CoTyApp (CoVar buildId) ty)
---LATER:               (CoTyLam tv (mkCoLam [c,n] expr))
---LATER: -- CoCon buildDataCon [ty] [CoTyLam tv (mkCoLam [c,n] expr)]
-\end{code}
-
-\begin{code}
---LATER: mkListFilter tys args ty ity c n exp
---LATER:   = foldr CoTyLam
---LATER: 	 (CoLam args (mkBuild ty ity c n exp))
---LATER: 	  tys
-\end{code}
-
-
-%************************************************************************
-%*									*
-\subsection[PrelFuns-specialisations]{Specialisations for builtin values}
-%*									*
-%************************************************************************
-
-The specialisations which exist for the builtin values must be recorded in
-their IdInfos.
-
-NOTE: THE USES OF THE pcGenerate... FUNCTIONS MUST CORRESPOND
-      TO THE SPECIALISATIONS DECLARED IN THE PRELUDE !!!
-
-HACK: We currently use the same unique for the specialised Ids.
-
-The list @specing_types@ determines the types for which specialised
-versions are created. Note: This should correspond with the
-types passed to the pre-processor with the -genSPECS arg (see ghc.lprl).
-
-ToDo: Create single mkworld definition which is grabbed here and in ghc.lprl
-
-\begin{code}
-pcGenerateSpecs :: Unique -> Id -> IdInfo -> UniType -> SpecEnv
-pcGenerateSpecs key id info ty
-  = pc_gen_specs True key id info ty
-
-pcGenerateDataSpecs :: UniType -> SpecEnv
-pcGenerateDataSpecs ty
-  = pc_gen_specs False err err err ty
-  where
-    err = panic "PrelFuns:GenerateDataSpecs"
-
-pcGenerateTupleSpecs :: Int -> UniType -> SpecEnv
-pcGenerateTupleSpecs arity ty
-  = if arity < 5 then
-	pcGenerateDataSpecs ty
-    else if arity == 5 then
-	let
-	    tup5_spec jty = SpecInfo (take 5 (repeat jty))
-	 			     0 (panic "SpecData:SpecInfo:SpecId")
-	in
-	mkSpecEnv (map tup5_spec (tail specing_types))
-    else if arity == 19 then
-	mkSpecEnv [SpecInfo (Nothing : Just doublePrimTy : take 17 (repeat Nothing))
-			    0 (panic "SpecData:SpecInfo:SpecId")]
-    else
-        nullSpecEnv
-
-pc_gen_specs is_id key id info ty
- = mkSpecEnv spec_infos
- where
-   spec_infos = [ let spec_ty = specialiseTy ty spec_tys 0
-		      spec_id = if is_id 
-			        then mkSpecId key {- HACK WARNING: same unique! -}
-				              id spec_tys spec_ty info
-				else panic "SpecData:SpecInfo:SpecId"
-		  in
-		  SpecInfo spec_tys (length ctxts) spec_id
-		| spec_tys <- specialisations ]
-
-   (tyvars, ctxts, _) = splitType ty
-   no_tyvars	      = length tyvars
-
-   specialisations    = if no_tyvars == 0
-			then []
-		        else tail (cross_product no_tyvars specing_types)
-
-			-- N.B. tail removes fully polymorphic specialisation
-
-cross_product 0 tys = []
-cross_product 1 tys = map (:[]) tys
-cross_product n tys = concat [map (:cp) tys | cp <- cross_product (n-1) tys]
-
-
-specing_types = [Nothing,	
-		 Just charPrimTy,
-		 Just doublePrimTy,
-		 Just intPrimTy ]
-\end{code}
diff --git a/ghc/compiler/prelude/PrelInfo.lhs b/ghc/compiler/prelude/PrelInfo.lhs
new file mode 100644
index 0000000000..18d0e56dd0
--- /dev/null
+++ b/ghc/compiler/prelude/PrelInfo.lhs
@@ -0,0 +1,405 @@
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+%
+\section[PrelInfo]{The @PrelInfo@ interface to the compiler's prelude knowledge}
+
+\begin{code}
+#include "HsVersions.h"
+
+module PrelInfo (
+
+	pRELUDE, pRELUDE_BUILTIN, pRELUDE_CORE, pRELUDE_RATIO,
+	pRELUDE_LIST, pRELUDE_TEXT,
+	pRELUDE_PRIMIO, pRELUDE_IO, pRELUDE_PS,
+	gLASGOW_ST, gLASGOW_MISC,
+
+	-- lookup functions for built-in names, for the renamer:
+	builtinNameInfo,
+
+	-- *odd* values that need to be reached out and grabbed:
+	eRROR_ID, pAT_ERROR_ID, aBSENT_ERROR_ID,
+	packStringForCId,
+	unpackCStringId, unpackCString2Id,
+	unpackCStringAppendId, unpackCStringFoldrId,
+	integerZeroId, integerPlusOneId,
+	integerPlusTwoId, integerMinusOneId,
+
+	-----------------------------------------------------
+	-- the rest of the export list is organised by *type*
+	-----------------------------------------------------
+
+	-- type: Bool
+	boolTyCon, boolTy, falseDataCon, trueDataCon,
+
+	-- types: Char#, Char, String (= [Char])
+	charPrimTy, charTy, stringTy,
+	charPrimTyCon, charTyCon, charDataCon,
+
+	-- type: Ordering (used in deriving)
+	orderingTy, ltDataCon, eqDataCon, gtDataCon,
+
+	-- types: Double#, Double
+	doublePrimTy, doubleTy,
+	doublePrimTyCon, doubleTyCon, doubleDataCon,
+
+	-- types: Float#, Float
+	floatPrimTy, floatTy,
+	floatPrimTyCon, floatTyCon, floatDataCon,
+
+	-- types: Glasgow *primitive* arrays, sequencing and I/O
+	mkPrimIoTy, -- to typecheck "mainPrimIO" & for _ccall_s
+	realWorldStatePrimTy, realWorldStateTy{-boxed-},
+	realWorldTy, realWorldTyCon, realWorldPrimId,
+	statePrimTyCon, stateDataCon, getStatePairingConInfo,
+
+	byteArrayPrimTy,
+
+	-- types: Void# (only used within the compiler)
+	voidPrimTy, voidPrimId,
+
+	-- types: Addr#, Int#, Word#, Int
+	intPrimTy, intTy, intPrimTyCon, intTyCon, intDataCon,
+	wordPrimTyCon, wordPrimTy, wordTy, wordTyCon, wordDataCon,
+	addrPrimTyCon, addrPrimTy, addrTy, addrTyCon, addrDataCon,
+
+	-- types: Integer, Rational (= Ratio Integer)
+	integerTy, rationalTy,
+	integerTyCon, integerDataCon,
+	rationalTyCon, ratioDataCon,
+
+	-- type: Lift
+	liftTyCon, liftDataCon, mkLiftTy,
+
+	-- type: List
+	listTyCon, mkListTy, nilDataCon, consDataCon,
+
+	-- type: tuples
+	mkTupleTy, unitTy,
+
+	-- for compilation of List Comprehensions and foldr
+	foldlId, foldrId,
+	mkBuild, buildId, augmentId, appendId
+
+	-- and, finally, we must put in some (abstract) data types,
+	-- to make the interface self-sufficient
+    ) where
+
+import Ubiq
+import PrelLoop		( primOpNameInfo )
+
+-- friends:
+import PrelMods		-- Prelude module names
+import PrelVals		-- VALUES
+import PrimOp		( PrimOp(..), allThePrimOps )
+import PrimRep		( PrimRep(..) )
+import TysPrim		-- TYPES
+import TysWiredIn
+
+-- others:
+import CmdLineOpts
+import FiniteMap
+import Id		( mkTupleCon, GenId{-instances-} )
+import Name		( Name(..) )
+import NameTypes	( mkPreludeCoreName, FullName, ShortName )
+import TyCon		( getTyConDataCons, mkFunTyCon, mkTupleTyCon, TyCon{-instances-} )
+import Type
+import Unique		-- *Key stuff
+import Util		( nOfThem, panic )
+\end{code}
+
+%************************************************************************
+%*									*
+\subsection[builtinNameInfo]{Lookup built-in names}
+%*									*
+%************************************************************************
+
+We have two ``builtin name funs,'' one to look up @TyCons@ and
+@Classes@, the other to look up values.
+
+\begin{code}
+builtinNameInfo :: (FAST_STRING -> Maybe Name,	-- name lookup fn for values
+		    FAST_STRING -> Maybe Name)	-- name lookup fn for tycons/classes
+
+builtinNameInfo
+  = (init_val_lookup_fn, init_tc_lookup_fn)
+  where
+    --
+    -- values (including data constructors)
+    --
+    init_val_lookup_fn
+      =	if	opt_HideBuiltinNames then
+		(\ x -> Nothing)
+	else if opt_HideMostBuiltinNames then
+		lookupFM (listToFM (concat min_val_assoc_lists))
+	else
+		lookupFM (listToFM (concat val_assoc_lists))
+
+    min_val_assoc_lists		-- min needed when compiling bits of Prelude
+	= [
+	    concat (map pcDataConNameInfo g_con_tycons),
+	    concat (map pcDataConNameInfo min_nonprim_tycon_list),
+	    totally_wired_in_Ids,
+	    unboxed_ops
+	  ]
+
+    val_assoc_lists
+    	= [
+	    concat (map pcDataConNameInfo g_con_tycons),
+	    concat (map pcDataConNameInfo data_tycons),
+	    totally_wired_in_Ids,
+	    unboxed_ops,
+	    special_class_ops,
+	    if opt_ForConcurrent then parallel_vals else []
+	  ]
+
+    --
+    -- type constructors and classes
+    --
+    init_tc_lookup_fn
+      =	if	opt_HideBuiltinNames then
+		(\ x -> Nothing)
+	else if opt_HideMostBuiltinNames then
+		lookupFM (listToFM (concat min_tc_assoc_lists))
+	else
+		lookupFM (listToFM (concat tc_assoc_lists))
+
+    min_tc_assoc_lists	-- again, pretty ad-hoc
+	= [
+	    map pcTyConNameInfo prim_tycons,
+	    map pcTyConNameInfo g_tycons,
+	    map pcTyConNameInfo min_nonprim_tycon_list
+	  ]
+
+    tc_assoc_lists
+	= [
+	    map pcTyConNameInfo prim_tycons,
+	    map pcTyConNameInfo g_tycons,
+	    map pcTyConNameInfo data_tycons,
+	    map pcTyConNameInfo synonym_tycons,
+	    std_tycon_list,
+	    std_class_list
+	  ]
+
+    -- 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.
+
+
+prim_tycons
+  = [addrPrimTyCon,
+     arrayPrimTyCon,
+     byteArrayPrimTyCon,
+     charPrimTyCon,
+     doublePrimTyCon,
+     floatPrimTyCon,
+     intPrimTyCon,
+     mallocPtrPrimTyCon,
+     mutableArrayPrimTyCon,
+     mutableByteArrayPrimTyCon,
+     synchVarPrimTyCon,
+     realWorldTyCon,
+     stablePtrPrimTyCon,
+     statePrimTyCon,
+     wordPrimTyCon
+    ]
+
+g_tycons
+  = mkFunTyCon : g_con_tycons
+
+g_con_tycons
+  = listTyCon : mkTupleTyCon 0 : [mkTupleTyCon i | i <- [2..32] ]
+
+min_nonprim_tycon_list 	-- used w/ HideMostBuiltinNames
+  = [ boolTyCon,
+      orderingTyCon,
+      charTyCon,
+      intTyCon,
+      floatTyCon,
+      doubleTyCon,
+      integerTyCon,
+      ratioTyCon,
+      liftTyCon,
+      return2GMPsTyCon,	-- ADR asked for these last two (WDP 94/11)
+      returnIntAndGMPTyCon ]
+
+data_tycons
+  = [addrTyCon,
+     boolTyCon,
+--   byteArrayTyCon,
+     charTyCon,
+     orderingTyCon,
+     doubleTyCon,
+     floatTyCon,
+     intTyCon,
+     integerTyCon,
+     liftTyCon,
+     mallocPtrTyCon,
+--   mutableArrayTyCon,
+--   mutableByteArrayTyCon,
+     ratioTyCon,
+     return2GMPsTyCon,
+     returnIntAndGMPTyCon,
+     stablePtrTyCon,
+     stateAndAddrPrimTyCon,
+     stateAndArrayPrimTyCon,
+     stateAndByteArrayPrimTyCon,
+     stateAndCharPrimTyCon,
+     stateAndDoublePrimTyCon,
+     stateAndFloatPrimTyCon,
+     stateAndIntPrimTyCon,
+     stateAndMallocPtrPrimTyCon,
+     stateAndMutableArrayPrimTyCon,
+     stateAndMutableByteArrayPrimTyCon,
+     stateAndSynchVarPrimTyCon,
+     stateAndPtrPrimTyCon,
+     stateAndStablePtrPrimTyCon,
+     stateAndWordPrimTyCon,
+     stateTyCon,
+     wordTyCon
+    ]
+
+synonym_tycons
+  = [primIoTyCon,
+     rationalTyCon,
+     stTyCon,
+     stringTyCon]
+
+
+totally_wired_in_Ids
+  = [(SLIT("error"),		WiredInVal eRROR_ID),
+     (SLIT("patError#"),	WiredInVal pAT_ERROR_ID), -- occurs in i/faces
+     (SLIT("parError#"),	WiredInVal pAR_ERROR_ID), -- ditto
+     (SLIT("_trace"),		WiredInVal tRACE_ID),
+
+     -- now the foldr/build Ids, which need to be built in
+     -- because they have magic unfoldings
+     (SLIT("_build"),		WiredInVal buildId),
+     (SLIT("_augment"),		WiredInVal augmentId),
+     (SLIT("foldl"),		WiredInVal foldlId),
+     (SLIT("foldr"),		WiredInVal foldrId),
+     (SLIT("unpackAppendPS#"),	WiredInVal unpackCStringAppendId),
+     (SLIT("unpackFoldrPS#"),	WiredInVal unpackCStringFoldrId),
+
+     (SLIT("_runST"),		WiredInVal runSTId),
+     (SLIT("_seq_"),		WiredInVal seqId),  -- yes, used in sequential-land, too
+						    -- WDP 95/11
+     (SLIT("realWorld#"),	WiredInVal realWorldPrimId)
+    ]
+
+parallel_vals
+  =[(SLIT("_par_"),		WiredInVal parId),
+    (SLIT("_fork_"),		WiredInVal forkId)
+#ifdef GRAN
+    ,
+    (SLIT("_parLocal_"),	WiredInVal parLocalId),
+    (SLIT("_parGlobal_"),	WiredInVal parGlobalId)
+    -- Add later:
+    -- (SLIT("_parAt_"),	WiredInVal parAtId)
+    -- (SLIT("_parAtForNow_"),	WiredInVal parAtForNowId)
+    -- (SLIT("_copyable_"),	WiredInVal copyableId)
+    -- (SLIT("_noFollow_"),	WiredInVal noFollowId)
+#endif {-GRAN-}
+   ]
+
+special_class_ops
+  = let
+	swizzle_over (str, key)
+	  = (str, ClassOpName key bottom1 str bottom2)
+
+	bottom1 = panic "PrelInfo.special_class_ops:class"
+	bottom2 = panic "PrelInfo.special_class_ops:tag"
+    in
+     map swizzle_over
+      [	(SLIT("fromInt"),	fromIntClassOpKey),
+	(SLIT("fromInteger"),	fromIntegerClassOpKey),
+	(SLIT("fromRational"),	fromRationalClassOpKey),
+	(SLIT("enumFrom"),	enumFromClassOpKey),
+	(SLIT("enumFromThen"),	enumFromThenClassOpKey),
+	(SLIT("enumFromTo"),	enumFromToClassOpKey),
+	(SLIT("enumFromThenTo"),enumFromThenToClassOpKey),
+	(SLIT("=="),		eqClassOpKey),
+	(SLIT(">="),		geClassOpKey),
+	(SLIT("-"),		negateClassOpKey)
+      ]
+
+unboxed_ops
+  =  map primOpNameInfo allThePrimOps
+     -- plus some of the same ones but w/ different names ...
+  ++ map fn funny_name_primops
+  where
+    fn (op,s) = case (primOpNameInfo op) of (_,n) -> (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("<=##"))]
+
+
+std_tycon_list
+  = let
+	swizzle_over (mod, nm, key, arity, is_data)
+	  = let
+		fname = mkPreludeCoreName mod nm
+	    in
+	    (nm, TyConName key fname arity is_data (panic "std_tycon_list:data_cons"))
+    in
+    map swizzle_over
+	[(SLIT("PreludeMonadicIO"), SLIT("IO"), iOTyConKey,    1, False)
+	]
+
+std_class_list
+  = let
+	swizzle_over (str, key)
+	  = (str, ClassName key (mkPreludeCoreName pRELUDE_CORE str) (panic "std_class_list:ops"))
+    in
+    map swizzle_over
+	[(SLIT("Eq"),		eqClassKey),
+	 (SLIT("Ord"),		ordClassKey),
+	 (SLIT("Num"),		numClassKey),
+	 (SLIT("Real"),		realClassKey),
+	 (SLIT("Integral"),	integralClassKey),
+	 (SLIT("Fractional"),	fractionalClassKey),
+	 (SLIT("Floating"),	floatingClassKey),
+	 (SLIT("RealFrac"),	realFracClassKey),
+	 (SLIT("RealFloat"),	realFloatClassKey),
+	 (SLIT("Ix"),		ixClassKey),
+	 (SLIT("Enum"),		enumClassKey),
+	 (SLIT("Show"),		showClassKey),
+	 (SLIT("Read"),		readClassKey),
+	 (SLIT("Monad"),	monadClassKey),
+	 (SLIT("MonadZero"),	monadZeroClassKey),
+	 (SLIT("Binary"),	binaryClassKey),
+	 (SLIT("_CCallable"),	cCallableClassKey),
+	 (SLIT("_CReturnable"), cReturnableClassKey)
+	]
+
+\end{code}
+
+Make table entries for various things:
+\begin{code}
+pcTyConNameInfo :: TyCon -> (FAST_STRING, Name)
+pcTyConNameInfo tc = (getOccurrenceName tc, WiredInTyCon tc)
+
+pcDataConNameInfo :: TyCon -> [(FAST_STRING, Name)]
+pcDataConNameInfo tycon
+  = -- slurp out its data constructors...
+    [ (getOccurrenceName con, WiredInVal con) | con <- getTyConDataCons tycon ]
+\end{code}
diff --git a/ghc/compiler/prelude/PrelLoop.lhi b/ghc/compiler/prelude/PrelLoop.lhi
new file mode 100644
index 0000000000..229343141a
--- /dev/null
+++ b/ghc/compiler/prelude/PrelLoop.lhi
@@ -0,0 +1,25 @@
+Breaks the PrelVal loop and the PrelInfo loop caused by primOpNameInfo.
+
+\begin{code}
+interface PrelLoop where
+
+import PreludePS	( _PackedString )
+
+import Class		( GenClass )
+import CoreUnfold	( mkMagicUnfolding, UnfoldingDetails )
+import IdUtils		( primOpNameInfo )
+import Name		( Name )
+import NameTypes	( mkPreludeCoreName, FullName )
+import PrimOp		( PrimOp )
+import Type		( mkSigmaTy, mkFunTys, GenType )
+import TyVar		( GenTyVar )
+import Unique		( Unique )
+import Usage		( GenUsage )
+
+mkMagicUnfolding :: Unique -> UnfoldingDetails
+mkPreludeCoreName :: _PackedString -> _PackedString -> FullName
+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
+
+primOpNameInfo	:: PrimOp -> (_PackedString, Name)
+\end{code}
diff --git a/ghc/compiler/prelude/PrelMods.lhs b/ghc/compiler/prelude/PrelMods.lhs
new file mode 100644
index 0000000000..88b17a8715
--- /dev/null
+++ b/ghc/compiler/prelude/PrelMods.lhs
@@ -0,0 +1,36 @@
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+%
+\section[PrelMods]{Definitions of prelude modules}
+
+The strings identify built-in prelude modules.  They are
+defined here so as to avod
+\begin{code}
+#include "HsVersions.h"
+
+module PrelMods (
+	pRELUDE, pRELUDE_BUILTIN, pRELUDE_CORE, pRELUDE_RATIO,
+	pRELUDE_LIST, pRELUDE_TEXT,
+	pRELUDE_PRIMIO, pRELUDE_IO, pRELUDE_PS,
+	gLASGOW_ST, gLASGOW_MISC,
+	pRELUDE_FB
+  ) where
+
+CHK_Ubiq() -- debugging consistency check
+\end{code}
+
+
+\begin{code}
+gLASGOW_MISC	= SLIT("PreludeGlaMisc")
+gLASGOW_ST	= SLIT("PreludeGlaST")
+pRELUDE		= SLIT("Prelude")
+pRELUDE_BUILTIN = SLIT("PreludeBuiltin")
+pRELUDE_CORE	= SLIT("PreludeCore")
+pRELUDE_FB	= SLIT("PreludeFoldrBuild")
+pRELUDE_IO	= SLIT("PreludeIO")
+pRELUDE_LIST	= SLIT("PreludeList")
+pRELUDE_PRIMIO	= SLIT("PreludePrimIO")
+pRELUDE_PS	= SLIT("PreludePS")
+pRELUDE_RATIO	= SLIT("PreludeRatio")
+pRELUDE_TEXT	= SLIT("PreludeText")
+\end{code}
diff --git a/ghc/compiler/prelude/PrelVals.hi b/ghc/compiler/prelude/PrelVals.hi
deleted file mode 100644
index d5981a4c10..0000000000
--- a/ghc/compiler/prelude/PrelVals.hi
+++ /dev/null
@@ -1,40 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface PrelVals where
-import CoreSyn(CoreExpr)
-import Id(Id)
-import PreludePS(_PackedString)
-import TyVar(TyVar)
-import UniType(UniType)
-import Unique(Unique)
-aBSENT_ERROR_ID :: Id
-appendId :: Id
-augmentId :: Id
-buildId :: Id
-eRROR_ID :: Id
-errorTy :: UniType
-foldlId :: Id
-foldrId :: Id
-forkId :: Id
-integerMinusOneId :: Id
-integerPlusOneId :: Id
-integerPlusTwoId :: Id
-integerZeroId :: Id
-mkBuild :: UniType -> TyVar -> Id -> Id -> Id -> CoreExpr Id Id -> CoreExpr Id Id
-mkFoldl :: UniType -> UniType -> Id -> Id -> Id -> CoreExpr a Id
-mkFoldr :: UniType -> UniType -> Id -> Id -> Id -> CoreExpr a Id
-pAR_ERROR_ID :: Id
-pAT_ERROR_ID :: Id
-pRELUDE_FB :: _PackedString
-packStringForCId :: Id
-parId :: Id
-pc_bottoming_Id :: Unique -> _PackedString -> _PackedString -> UniType -> Id
-realWorldPrimId :: Id
-runSTId :: Id
-seqId :: Id
-tRACE_ID :: Id
-unpackCString2Id :: Id
-unpackCStringAppendId :: Id
-unpackCStringFoldrId :: Id
-unpackCStringId :: Id
-voidPrimId :: Id
-
diff --git a/ghc/compiler/prelude/PrelVals.lhs b/ghc/compiler/prelude/PrelVals.lhs
index e8c7ce41b1..457d11b9ce 100644
--- a/ghc/compiler/prelude/PrelVals.lhs
+++ b/ghc/compiler/prelude/PrelVals.lhs
@@ -8,34 +8,38 @@
 
 module PrelVals where
 
-import PrelFuns		-- help functions, types and things
-import BasicLit		( mkMachInt, BasicLit(..), PrimKind )
+import Ubiq
+import IdLoop		( UnfoldingGuidance(..) )
+import PrelLoop
+
+-- friends:
+import PrelMods
 import TysPrim
 import TysWiredIn
-#ifdef DPH
-import TyPod		( mkPodNTy ,mkPodTy )
-import TyProcs		( mkProcessorTy )
-#endif {- Data Parallel Haskell -}
-
-#ifndef DPH
-import AbsUniType
-import Id		( mkTemplateLocals, mkTupleCon, getIdUniType,
-			  mkSpecId
-			)
-#else
-import AbsUniType	( mkSigmaTy, mkDictTy, mkTyVarTy , SigmaType(..),
-			  applyTyCon, splitType, specialiseTy
-			)
-import Id		( mkTemplateLocals, mkTupleCon, getIdUniType,
-			  mkSpecId, mkProcessorCon
-			)
-#endif {- Data Parallel Haskell -}
-import IdInfo
-
-import Maybes		( Maybe(..) )
-import PlainCore	-- to make unfolding templates
-import Unique		-- *Key things
-import Util
+
+-- others:
+import CoreSyn		-- quite a bit
+--import CoreUnfold	( UnfoldingGuidance(..), mkMagicUnfolding )
+import IdInfo		-- quite a bit
+import Literal		( mkMachInt )
+--import NameTypes	( mkPreludeCoreName )
+import PrimOp		( PrimOp(..) )
+import SpecEnv		( SpecEnv(..), nullSpecEnv )
+--import Type		( mkSigmaTy, mkFunTys, GenType(..) )
+import TyVar		( alphaTyVar, betaTyVar )
+import Unique		-- lots of *Keys
+import Util		( panic )
+
+-- only used herein:
+mkPreludeId = panic "PrelVals:Id.mkPreludeId"
+mkSpecId = panic "PrelVals:Id.mkSpecId"
+mkTemplateLocals = panic "PrelVals:Id.mkTemplateLocals"
+specialiseTy = panic "PrelVals:specialiseTy"
+
+pcMiscPrelId :: Unique{-IdKey-} -> FAST_STRING -> FAST_STRING -> Type -> IdInfo -> Id
+
+pcMiscPrelId key mod name ty info
+ = mkPreludeId	key (mkPreludeCoreName mod name) ty info
 \end{code}
 
 %************************************************************************
@@ -73,14 +77,14 @@ pAT_ERROR_ID
 
 aBSENT_ERROR_ID
   = pc_bottoming_Id absentErrorIdKey pRELUDE_BUILTIN SLIT("absent#")
-	(mkSigmaTy [alpha_tv] [] alpha)
+	(mkSigmaTy [alphaTyVar] [] alphaTy)
 
 pAR_ERROR_ID
   = pcMiscPrelId parErrorIdKey pRELUDE_BUILTIN SLIT("parError#")
-    (mkSigmaTy [alpha_tv] [] alpha) noIdInfo
+    (mkSigmaTy [alphaTyVar] [] alphaTy) noIdInfo
 
-errorTy  :: UniType
-errorTy  = mkSigmaTy [alpha_tv] [] (UniFun (mkListTy charTy) alpha)
+errorTy  :: Type
+errorTy  = mkSigmaTy [alphaTyVar] [] (mkFunTys [mkListTy charTy] alphaTy)
 \end{code}
 
 We want \tr{_trace} (NB: name not in user namespace) to be wired in
@@ -95,7 +99,7 @@ tRACE_ID
   = pcMiscPrelId traceIdKey pRELUDE_BUILTIN SLIT("_trace") traceTy
 	(noIdInfo `addInfo` pcGenerateSpecs traceIdKey tRACE_ID noIdInfo traceTy)
   where
-    traceTy = mkSigmaTy [alpha_tv] [] (UniFun (mkListTy charTy) (UniFun alpha alpha))
+    traceTy = mkSigmaTy [alphaTyVar] [] (mkFunTys [mkListTy charTy, alphaTy] alphaTy)
 \end{code}
 
 %************************************************************************
@@ -105,53 +109,42 @@ tRACE_ID
 %************************************************************************
 
 \begin{code}
-{- OLD:
-int2IntegerId
-  = pcMiscPrelId int2IntegerIdKey pRELUDE_BUILTIN SLIT("_int2Integer")
-	(UniFun intTy integerTy)
-	noIdInfo
--}
-
---------------------------------------------------------------------
-
 packStringForCId
   = pcMiscPrelId packCStringIdKey{-ToDo:rename-} pRELUDE_PS SLIT("_packStringForC")
-	(UniFun stringTy byteArrayPrimTy) noIdInfo
+	(mkFunTys [stringTy] byteArrayPrimTy) noIdInfo
 
 --------------------------------------------------------------------
 
 unpackCStringId
   = pcMiscPrelId unpackCStringIdKey pRELUDE_BUILTIN SLIT("unpackPS#")
-		 (addrPrimTy{-a char *-} `UniFun` stringTy) noIdInfo
+		 (mkFunTys [addrPrimTy{-a char *-}] stringTy) noIdInfo
 -- Andy says:
---	(UniFun addrPrimTy{-a char *-} stringTy) (noIdInfo `addInfo` mkArityInfo 1)
+--	(FunTy addrPrimTy{-a char *-} stringTy) (noIdInfo `addInfo` mkArityInfo 1)
 -- but I don't like wired-in IdInfos (WDP)
 
 unpackCString2Id -- for cases when a string has a NUL in it
   = pcMiscPrelId unpackCString2IdKey pRELUDE_BUILTIN SLIT("unpackPS2#")
-		 (addrPrimTy{-a char *-}
-	`UniFun` (intPrimTy -- length
-	`UniFun` stringTy)) noIdInfo
-
+		 (mkFunTys [addrPrimTy{-a char *-}, intPrimTy{-length-}] stringTy)
+		 noIdInfo
 
 --------------------------------------------------------------------
 unpackCStringAppendId
   = pcMiscPrelId unpackCStringAppendIdKey pRELUDE_BUILTIN SLIT("unpackAppendPS#")
-				(addrPrimTy{-a "char *" pointer-} 
-		`UniFun`	(stringTy
-		`UniFun`	stringTy)) ((noIdInfo 
-				`addInfo_UF` mkMagicUnfolding SLIT("unpackAppendPS#"))
-				`addInfo` mkArityInfo 2)
-  
+		(mkFunTys [addrPrimTy{-a "char *" pointer-},stringTy] stringTy)
+		((noIdInfo
+		 `addInfo_UF` mkMagicUnfolding unpackCStringAppendIdKey)
+		 `addInfo` mkArityInfo 2)
+
 unpackCStringFoldrId
   = pcMiscPrelId unpackCStringFoldrIdKey pRELUDE_BUILTIN SLIT("unpackFoldrPS#")
-		(mkSigmaTy [alpha_tv] [] 
-			   (addrPrimTy{-a "char *" pointer-} 
-		`UniFun`   ((charTy `UniFun` (alpha `UniFun` alpha))
-		`UniFun`   (alpha
-		`UniFun`   alpha)))) ((noIdInfo 
-				`addInfo_UF` mkMagicUnfolding SLIT("unpackFoldrPS#"))
-				`addInfo` mkArityInfo 3)
+		(mkSigmaTy [alphaTyVar] []
+		(mkFunTys [addrPrimTy{-a "char *" pointer-},
+			   mkFunTys [charTy, alphaTy] alphaTy,
+			   alphaTy]
+			  alphaTy))
+		((noIdInfo
+		 `addInfo_UF` mkMagicUnfolding unpackCStringFoldrIdKey)
+		 `addInfo` mkArityInfo 3)
 \end{code}
 
 OK, this is Will's idea: we should have magic values for Integers 0,
@@ -173,13 +166,6 @@ integerMinusOneId
 %*									*
 %************************************************************************
 
-In the definitions that follow, we use the @TyVar@-based
-alpha/beta/gamma types---not the usual @TyVarTemplate@ ones.
-
-This is so the @TyVars@ in the @CoTyLams@ (@alpha_tyvar@, etc) match
-up with those in the types of the {\em lambda-bound} template-locals
-we create (using types @alpha_ty@, etc.).
-
 \begin{code}
 --------------------------------------------------------------------
 -- seqId :: "_seq_", used w/ GRIP, etc., is really quite similar to
@@ -197,25 +183,23 @@ we create (using types @alpha_ty@, etc.).
 -}
 
 seqId = pcMiscPrelId seqIdKey pRELUDE_BUILTIN SLIT("_seq_")
-		  (mkSigmaTy [alpha_tv, beta_tv] []
-		    (alpha `UniFun` (beta `UniFun` beta)))
+		  (mkSigmaTy [alphaTyVar, betaTyVar] []
+		    (mkFunTys [alphaTy, betaTy] betaTy))
 		  (noIdInfo `addInfo_UF` (mkUnfolding EssentialUnfolding seq_template))
   where
     [x, y, z]
       = mkTemplateLocals [
-    	{-x-} alpha_ty,
-    	{-y-} beta_ty,
-        {-z-} intPrimTy
+    	{-x-} alphaTy,
+    	{-y-} betaTy,
+	{-z-} intPrimTy
     	]
 
     seq_template
-      = CoTyLam alpha_tyvar
-    	  (CoTyLam beta_tyvar
-	     (mkCoLam [x, y] (
-		CoCase (CoPrim SeqOp [alpha_ty] [CoVarAtom x]) (
-		  CoPrimAlts
-		    [(mkMachInt 0, CoTyApp (CoVar pAR_ERROR_ID) beta_ty)]
-		    (CoBindDefault z (CoVar y))))))
+      = mkLam [alphaTyVar, betaTyVar] [x, y] (
+		Case (Prim SeqOp [TyArg alphaTy, VarArg x]) (
+		  PrimAlts
+		    [(mkMachInt 0, mkTyApp (Var pAR_ERROR_ID) [betaTy])]
+		    (BindDefault z (Var y))))
 
 --------------------------------------------------------------------
 -- parId :: "_par_", also used w/ GRIP, etc.
@@ -234,50 +218,46 @@ seqId = pcMiscPrelId seqIdKey pRELUDE_BUILTIN SLIT("_seq_")
 
 -}
 parId = pcMiscPrelId parIdKey pRELUDE_BUILTIN SLIT("_par_")
-		  (mkSigmaTy [alpha_tv, beta_tv] []
-		    (alpha `UniFun` (beta `UniFun` beta)))
+		  (mkSigmaTy [alphaTyVar, betaTyVar] []
+		    (mkFunTys [alphaTy, betaTy] betaTy))
 		  (noIdInfo `addInfo_UF` (mkUnfolding EssentialUnfolding par_template))
   where
     [x, y, z]
       = mkTemplateLocals [
-    	{-x-} alpha_ty,
-    	{-y-} beta_ty,
-        {-z-} intPrimTy
+    	{-x-} alphaTy,
+    	{-y-} betaTy,
+	{-z-} intPrimTy
     	]
 
     par_template
-      = CoTyLam alpha_tyvar
-    	  (CoTyLam beta_tyvar
-	     (mkCoLam [x, y] (
-		CoCase (CoPrim ParOp [alpha_ty] [CoVarAtom x]) (
-		  CoPrimAlts
-		    [(mkMachInt 0, CoTyApp (CoVar pAR_ERROR_ID) beta_ty)]
-		    (CoBindDefault z (CoVar y))))))
+      = mkLam [alphaTyVar, betaTyVar] [x, y] (
+		Case (Prim ParOp [TyArg alphaTy, VarArg x]) (
+		  PrimAlts
+		    [(mkMachInt 0, mkTyApp (Var pAR_ERROR_ID) [betaTy])]
+		    (BindDefault z (Var y))))
 
 -- forkId :: "_fork_", for *required* concurrent threads
 {-
    _fork_ = /\ a b -> \ x::a y::b -> case fork# x of { 0# -> parError#; _ -> y; }
 -}
 forkId = pcMiscPrelId forkIdKey pRELUDE_BUILTIN SLIT("_fork_")
-		  (mkSigmaTy [alpha_tv, beta_tv] []
-		    (alpha `UniFun` (beta `UniFun` beta)))
+		  (mkSigmaTy [alphaTyVar, betaTyVar] []
+		    (mkFunTys [alphaTy, betaTy] betaTy))
 		  (noIdInfo `addInfo_UF` (mkUnfolding EssentialUnfolding fork_template))
   where
     [x, y, z]
       = mkTemplateLocals [
-    	{-x-} alpha_ty,
-    	{-y-} beta_ty,
-        {-z-} intPrimTy
+    	{-x-} alphaTy,
+    	{-y-} betaTy,
+	{-z-} intPrimTy
     	]
 
     fork_template
-      = CoTyLam alpha_tyvar
-    	  (CoTyLam beta_tyvar
-	     (mkCoLam [x, y] (
-		CoCase (CoPrim ForkOp [alpha_ty] [CoVarAtom x]) (
-		  CoPrimAlts
-		    [(mkMachInt 0, CoTyApp (CoVar pAR_ERROR_ID) beta_ty)]
-		    (CoBindDefault z (CoVar y))))))
+      = mkLam [alphaTyVar, betaTyVar] [x, y] (
+		Case (Prim ForkOp [TyArg alphaTy, VarArg x]) (
+		  PrimAlts
+		    [(mkMachInt 0, mkTyApp (Var pAR_ERROR_ID) [betaTy])]
+		    (BindDefault z (Var y))))
 
 \end{code}
 
@@ -285,141 +265,48 @@ forkId = pcMiscPrelId forkIdKey pRELUDE_BUILTIN SLIT("_fork_")
 #ifdef GRAN
 
 parLocalId = pcMiscPrelId parLocalIdKey pRELUDE_BUILTIN SLIT("_parLocal_")
-		  (mkSigmaTy [alpha_tv, beta_tv] []
-		    (intPrimTy `UniFun` (alpha `UniFun` (beta `UniFun` beta))))
+		  (mkSigmaTy [alphaTyVar, betaTyVar] []
+		    (mkFunTys [intPrimTy, alphaTy, betaTy] betaTy))
 		  (noIdInfo `addInfo_UF` (mkUnfolding EssentialUnfolding parLocal_template))
   where
     [w, x, y, z]
       = mkTemplateLocals [
 	{-w-} intPrimTy,
-    	{-x-} alpha_ty,
-    	{-y-} beta_ty,
-	{-z-} beta_ty
+    	{-x-} alphaTy,
+    	{-y-} betaTy,
+	{-z-} betaTy
     	]
 
     parLocal_template
-      = CoTyLam alpha_tyvar
-    	  (CoTyLam beta_tyvar
-	     (mkCoLam [w, x, y] (
-		CoCase (CoPrim ParLocalOp [alpha_ty, beta_ty] [CoVarAtom x, CoVarAtom w, CoVarAtom y]) (
-		  CoAlgAlts
-		    [(liftDataCon, [z], CoVar z)]
-		    (CoNoDefault)))))
+      = mkLam [alphaTyVar, betaTyVar] [w, x, y] (
+		Case (Prim ParLocalOp [TyArg alphaTy, TyArg betaTy, VarArg x, VarArg w, VarArg y]) (
+		  AlgAlts
+		    [(liftDataCon, [z], Var z)]
+		    (NoDefault)))
 
 parGlobalId = pcMiscPrelId parGlobalIdKey pRELUDE_BUILTIN SLIT("_parGlobal_")
-		  (mkSigmaTy [alpha_tv, beta_tv] []
-		    (intPrimTy `UniFun` (alpha `UniFun` (beta `UniFun` beta))))
+		  (mkSigmaTy [alphaTyVar, betaTyVar] []
+		    (mkFunTys [intPrimTy,alphaTy,betaTy] betaTy))
 		  (noIdInfo `addInfo_UF` (mkUnfolding EssentialUnfolding parGlobal_template))
   where
     [w, x, y, z]
       = mkTemplateLocals [
     	{-w-} intPrimTy,
-    	{-x-} alpha_ty,
-    	{-y-} beta_ty,
-	{-z-} beta_ty
+    	{-x-} alphaTy,
+    	{-y-} betaTy,
+	{-z-} betaTy
     	]
 
     parGlobal_template
-      = CoTyLam alpha_tyvar
-    	  (CoTyLam beta_tyvar
-	     (mkCoLam [w, x, y] (
-		CoCase (CoPrim ParGlobalOp [alpha_ty, beta_ty] [CoVarAtom x, CoVarAtom w, CoVarAtom y]) (
-		  CoAlgAlts
-		    [(liftDataCon, [z], CoVar z)]
-		    (CoNoDefault)))))
+      = mkLam [alphaTyVar, betaTyVar] [w, x, y] (
+		Case (Prim ParGlobalOp [TyArg alphaTy, TyArg betaTy, VarArg x, VarArg w, VarArg y]) (
+		  AlgAlts
+		    [(liftDataCon, [z], Var z)]
+		    (NoDefault)))
 
 #endif {-GRAN-}
 \end{code}
 
-\begin{code}
-#ifdef DPH
-vectorMapId = pcChooseToKnowId vectorMapU pRELUDE "vectorMap"
-              (mkSigmaTy [alpha_tv, beta_tv , gamma_tv]
-			 [(pidClass,alpha)]
-	      ((beta `UniFun` gamma) 			 `UniFun`
-	         ((mkPodTy (mkProcessorTy [alpha] beta)) `UniFun`
-		    (mkPodTy (mkProcessorTy [alpha] gamma)))))
-	      (panic "vectorMap:unfolding")--ToDo:DPH: (mkUnfoldTemplate vector_map_template)
-	      [(2,"","")]
- where
-{-
-vectorMap fn vec = << (|x;fn y|) | (|x;y|) <<- vec >>
-
-Simplified :
-vectorMap :: for all a.83, b.82, c.86. <Pid a.83>
-	  -> (b.82 -> c.86)
-	  -> <<a.83;b.82>>
-	  -> <<a.83;c.86>>
-vectorMap =
-    /\ t83 t82 o86 -> \ dict.127 ->
-        let
-          vecMap.128 =
-              \ fn.129 vec.130 ->
-                  << let si.133 = fn.129 ds.132 in
-                     let
-                       si.134 =
-                           (fromDomain t82)
-                               dict.127 ((toDomain t82) dict.127 ds.131)
-                     in  MkProcessor1! Integer o86 si.134 si.133 |
-                      (| ds.131 ; ds.132 |) <<- vec.130 >>
-        in  vecMap.128
-
- NOTE : no need to bother with overloading in class Pid; because the result
-	PID (si.133) is wrapped in fromDomain.toDomain == id . Therefore we
-	use the simplification below.
-
-Simplified:
-vectorMap ::
-    for all d.83, e.82, f.86.
-        <Pid e.82> -> (d.83 -> f.86) -> <<e.82;d.83>> -> <<e.82;f.86>>
-vectorMap =
-    /\ t83 t82 o86 -> \ dict.127 fn.129 vec.130 ->
-    << MkProcessor1! Integer o86 ds.131 (fn.129 ds.132) |
-                      (| ds.131 ; ds.132 |) <<- vec.130 >>
--}
-
-    vector_map_template
-      = let
-	   [dict,fn,vec,ds131,ds132]
-	     = mkTemplateLocals
-		    [mkDictTy pidClass alpha_ty,
-		     beta_ty `UniFun` gamma_ty,
-		     mkPodTy (mkProcessorTy [alpha_ty] beta_ty),
-		     integerTy,
-		     beta_ty]
-	in
-	  CoTyLam alpha_tyvar
-	    (CoTyLam beta_tyvar
-              (CoTyLam gamma_tyvar
-	        (mkCoLam [dict,fn,vec]
-	          (CoZfExpr
-		    (CoCon (mkProcessorCon 1)
-			   [integerTy,mkTyVarTy gamma_tyvar]
-			   [CoVar ds131,
-			    (CoApp (CoVar fn) (CoVar ds132))])
-		    (CoDrawnGen [ds131] ds132 (CoVar vec)) ))))
-
-#endif {- Data Parallel Haskell -}
-\end{code}
-
-\begin{code}
-#ifdef DPH
--- A function used during podization that produces an index POD for a given
--- POD as argument.
-
-primIfromPodNSelectorId :: Int -> Int -> Id
-primIfromPodNSelectorId i n
-   = pcMiscPrelId
-	podSelectorIdKey
-	pRELUDE_BUILTIN
-        ("prim"++ show i ++ "fromPod" ++ show n ++ "Selector")
-        (UniFun
-	   (mkPodNTy n alpha)
-	   (mkPodNTy n alpha))
-	noIdInfo
-#endif {- Data Parallel Haskell -}
-\end{code}
-
 %************************************************************************
 %*									*
 \subsection[PrelVals-deriving]{Values known about mainly for doing derived instance decls}
@@ -438,39 +325,6 @@ showParen	:: Bool -> ShowS -> ShowS
 readParen	:: Bool -> ReadS a -> ReadS a
 lex		:: ReadS String
 
-\begin{code}
-{- OLD:
-readS_ty :: UniType -> UniType
-readS_ty ty
-  = UniFun stringTy (mkListTy (mkTupleTy 2 [ty, stringTy]))
-
-showS_ty :: UniType
-showS_ty = UniFun stringTy stringTy
--}
-\end{code}
-
-\begin{code}
-{- OLD:
-showSpaceId = pcMiscPrelId showSpaceIdKey pRELUDE_TEXT SLIT("_showSpace")
-				showS_ty
-				noIdInfo
-
-showParenId = pcMiscPrelId showParenIdKey pRELUDE_TEXT SLIT("showParen")
-				(boolTy `UniFun` (showS_ty `UniFun` showS_ty))
-				noIdInfo
-
-readParenId = pcMiscPrelId readParenIdKey pRELUDE_TEXT SLIT("readParen")
-				(mkSigmaTy [alpha_tv] [] (
-				 boolTy `UniFun` (
-				 (readS_ty alpha) `UniFun` (readS_ty alpha))))
-				noIdInfo
-
-lexId = pcMiscPrelId lexIdKey pRELUDE_TEXT SLIT("lex")
-				(readS_ty (mkListTy charTy))
-				noIdInfo
--}
-\end{code}
-
 %************************************************************************
 %*									*
 \subsection[PrelVals-void]{@void#@: Magic value of type @Void#@}
@@ -498,46 +352,45 @@ voidPrimId
 --	     forall a. (forall s. (_State s -> (a, _State s))) -> a
 
 _runST a m = case m _RealWorld (S# _RealWorld realWorld#) of
-               (r :: a, wild :: _State _RealWorld) -> r
+	       (r :: a, wild :: _State _RealWorld) -> r
 \end{verbatim}
 We unfold always, just for simplicity:
 \begin{code}
 runSTId
   = pcMiscPrelId runSTIdKey pRELUDE_BUILTIN SLIT("_runST") run_ST_ty id_info
   where
-    s_tv = beta_tv
-    s	 = beta
+    s_tv = betaTyVar
+    s	 = betaTy
 
     st_ty a = mkSigmaTy [s_tv] [] (mkStateTransformerTy s a)
 
     run_ST_ty
-      = mkSigmaTy [alpha_tv] [] (st_ty alpha `UniFun` alpha)
+      = mkSigmaTy [alphaTyVar] [] (mkFunTys [st_ty alphaTy] alphaTy)
 	    -- NB: rank-2 polymorphism! (forall inside the st_ty...)
 
     id_info
       = noIdInfo
 	`addInfo` mkArityInfo 1
-        `addInfo` mkStrictnessInfo [WwStrict] Nothing
+	`addInfo` mkStrictnessInfo [WwStrict] Nothing
 	`addInfo` mkArgUsageInfo [ArgUsage 1]
 	-- ABSOLUTELY NO UNFOLDING, e.g.: (mkUnfolding EssentialUnfolding run_ST_template)
 	-- see example below
 {- OUT:
     [m, t, r, wild]
       = mkTemplateLocals [
-	{-m-} st_ty alpha_ty,
+	{-m-} st_ty alphaTy,
 	{-t-} realWorldStateTy,
-	{-r-} alpha_ty,
+	{-r-} alphaTy,
 	{-_-} realWorldStateTy
 	]
 
     run_ST_template
-      = CoTyLam alpha_tyvar
-	 (mkCoLam [m] (
-	    CoLet (CoNonRec t (CoCon stateDataCon [realWorldTy] [CoVarAtom realWorldPrimId])) (
-	      CoCase (CoApp (mkCoTyApp (CoVar m) realWorldTy) (CoVarAtom t)) (
-		CoAlgAlts
-		  [(mkTupleCon 2, [r, wild], CoVar r)]
-		  CoNoDefault))))
+      = mkLam [alphaTyVar] [m] (
+	    Let (NonRec t (Con stateDataCon [TyArg realWorldTy, VarArg realWorldPrimId])) (
+	      Case (App (mkTyApp (Var m) [realWorldTy]) (VarArg t)) (
+		AlgAlts
+		  [(mkTupleCon 2, [r, wild], Var r)]
+		  NoDefault)))
 -}
 \end{code}
 
@@ -571,7 +424,7 @@ f = let
 All calls to @f@ will share a {\em single} array!  End SLPJ 95/04.
 
 @realWorld#@ used to be a magic literal, \tr{void#}.  If things get
-nasty as-is, change it back to a literal (@BasicLit@).
+nasty as-is, change it back to a literal (@Literal@).
 \begin{code}
 realWorldPrimId
   = pcMiscPrelId realWorldPrimIdKey pRELUDE_BUILTIN SLIT("realWorld#")
@@ -585,41 +438,23 @@ realWorldPrimId
 %*									*
 %************************************************************************
 
-\begin{code}
-{- NO:
-rangeComplaint_Ix_IntId
- = pcMiscPrelId rangeComplaintIdKey pRELUDE_BUILTIN SLIT("_rangeComplaint_Ix_Int") my_ty id_info
-  where
-    my_ty
-      = mkSigmaTy [alpha_tv] [] (
-			intPrimTy `UniFun` (
-			intPrimTy `UniFun` (
-			intPrimTy `UniFun` alpha)))
-    id_info
-      = noIdInfo
-	`addInfo` mkArityInfo 3
-        `addInfo` mkBottomStrictnessInfo
--}
-\end{code}
-
 \begin{code}
 buildId
   = pcMiscPrelId buildIdKey pRELUDE_CORE SLIT("_build") buildTy
-	((((noIdInfo 
-		`addInfo_UF` mkMagicUnfolding SLIT("build"))
+	((((noIdInfo
+		`addInfo_UF` mkMagicUnfolding buildIdKey)
 		`addInfo` mkStrictnessInfo [WwStrict] Nothing)
 		`addInfo` mkArgUsageInfo [ArgUsage 2])
-	        `addInfo` pcGenerateSpecs buildIdKey buildId noIdInfo{-ToDo-} buildTy)
+		`addInfo` pcGenerateSpecs buildIdKey buildId noIdInfo{-ToDo-} buildTy)
 	-- cheating, but since _build never actually exists ...
   where
     -- The type of this strange object is:
     --  \/ a . (\/ b . (a -> b -> b) -> b -> b) -> [a]
 
-    buildTy = mkSigmaTy [alpha_tv] [] (buildUniTy `UniFun` (mkListTy alpha))
+    buildTy = mkSigmaTy [alphaTyVar] [] (mkFunTys [build_ty] (mkListTy alphaTy))
 	where
-	    buildUniTy = mkSigmaTy [beta_tv] []
-		    ((alpha `UniFun` (beta `UniFun` beta))
-			    `UniFun` (beta `UniFun` beta))
+	    build_ty = mkSigmaTy [betaTyVar] []
+			(mkFunTys [alphaTy, mkFunTys [betaTy] betaTy, betaTy] betaTy)
 \end{code}
 
 @mkBuild@ is sugar for building a build!
@@ -635,83 +470,65 @@ buildId
 @e@ is the object right inside the @build@
 
 \begin{code}
-mkBuild :: UniType
+mkBuild :: Type
 	-> TyVar
 	-> Id
 	-> Id
 	-> Id
-	-> PlainCoreExpr -- template
-	-> PlainCoreExpr -- template
+	-> CoreExpr -- template
+	-> CoreExpr -- template
 
 mkBuild ty tv c n g expr
- = CoLet (CoNonRec g (CoTyLam tv (mkCoLam [c,n] expr)))
-	 (CoApp (mkCoTyApp (CoVar buildId) ty) (CoVarAtom g))
+  = Let (NonRec g (mkLam [tv] [c,n] expr))
+	(App (mkTyApp (Var buildId) [ty]) (VarArg g))
 \end{code}
 
 \begin{code}
 augmentId
-  = pcMiscPrelId buildIdKey pRELUDE_CORE SLIT("_augment") augmentTy
-	(((noIdInfo 
-		`addInfo_UF` mkMagicUnfolding SLIT("augment"))
+  = pcMiscPrelId augmentIdKey pRELUDE_CORE SLIT("_augment") augmentTy
+	(((noIdInfo
+		`addInfo_UF` mkMagicUnfolding augmentIdKey)
 		`addInfo` mkStrictnessInfo [WwStrict,WwLazy False] Nothing)
 		`addInfo` mkArgUsageInfo [ArgUsage 2,UnknownArgUsage])
-	-- cheating, but since _build never actually exists ...
+	-- cheating, but since _augment never actually exists ...
   where
     -- The type of this strange object is:
     --  \/ a . (\/ b . (a -> b -> b) -> b -> b) -> [a] -> [a]
 
-    augmentTy = mkSigmaTy [alpha_tv] [] (buildUniTy `UniFun` 
-					(mkListTy alpha `UniFun` mkListTy alpha))
+    augmentTy = mkSigmaTy [alphaTyVar] [] (mkFunTys [aug_ty, mkListTy alphaTy] (mkListTy alphaTy))
 	where
-	    buildUniTy = mkSigmaTy [beta_tv] []
-		    ((alpha `UniFun` (beta `UniFun` beta))
-			    `UniFun` (beta `UniFun` beta))
+	    aug_ty = mkSigmaTy [betaTyVar] []
+			(mkFunTys [alphaTy, mkFunTys [betaTy] betaTy, betaTy] betaTy)
 \end{code}
 
-mkFoldr ty_a ty_b [x,y...] => foldr ty_a ty_b x y ..
-
 \begin{code}
 foldrId = pcMiscPrelId foldrIdKey pRELUDE_FB{-not "List"-} SLIT("foldr")
 		 foldrTy idInfo
   where
 	foldrTy =
-	  mkSigmaTy [alpha_tv, beta_tv] []
-		((alpha `UniFun` (beta `UniFun` beta))
-		`UniFun` (beta
-		`UniFun` ((mkListTy alpha)
-		`UniFun` beta)))
-
-	idInfo = (((((noIdInfo 
-			`addInfo_UF` mkMagicUnfolding SLIT("foldr"))
+	  mkSigmaTy [alphaTyVar, betaTyVar] []
+		(mkFunTys [alphaTy, mkFunTys [betaTy] betaTy, betaTy, mkListTy alphaTy] betaTy)
+
+	idInfo = (((((noIdInfo
+			`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)
-
-mkFoldr a b f z xs = foldl CoApp
-			   (mkCoTyApps (CoVar foldrId) [a, b]) 
-			   [CoVarAtom f,CoVarAtom z,CoVarAtom xs]
+			`addInfo` pcGenerateSpecs foldrIdKey foldrId noIdInfo{-ToDo-} foldrTy)
 
 foldlId = pcMiscPrelId foldlIdKey pRELUDE_FB{-not "List"-} SLIT("foldl")
 		 foldlTy idInfo
   where
 	foldlTy =
-	  mkSigmaTy [alpha_tv, beta_tv] []
-		((alpha `UniFun` (beta `UniFun` alpha))
-		`UniFun` (alpha
-		`UniFun` ((mkListTy beta)
-		`UniFun` alpha)))
-
-	idInfo = (((((noIdInfo 
-			`addInfo_UF` mkMagicUnfolding SLIT("foldl"))
+	  mkSigmaTy [alphaTyVar, betaTyVar] []
+		(mkFunTys [alphaTy, mkFunTys [betaTy] betaTy, alphaTy, mkListTy betaTy] alphaTy)
+
+	idInfo = (((((noIdInfo
+			`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)
-
-mkFoldl a b f z xs = foldl CoApp
-			   (mkCoTyApps (CoVar foldlId) [a, b]) 
-			   [CoVarAtom f,CoVarAtom z,CoVarAtom xs]
+			`addInfo` 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:
@@ -719,7 +536,7 @@ mkFoldl a b f z xs = foldl CoApp
 --		 {- unfold augment -}
 --		 = foldr (:) ys xs
 --		 {- fold foldr to append -}
---		 = ys `appendId` xs		
+--		 = ys `appendId` xs
 --		 = ys ++ xs		-- ugg!
 -- *BUT* you want (++) and not _append in your interfaces.
 --
@@ -731,12 +548,72 @@ appendId
   = pcMiscPrelId appendIdKey pRELUDE_LIST SLIT("++") appendTy idInfo
   where
     appendTy =
-      (mkSigmaTy [alpha_tv] []
-	    ((mkListTy alpha) `UniFun` ((mkListTy alpha) `UniFun` (mkListTy alpha))))
-    idInfo = (((noIdInfo 
+      (mkSigmaTy [alphaTyVar] []
+	    (mkFunTys [mkListTy alphaTy, mkListTy alphaTy] (mkListTy alphaTy)))
+    idInfo = (((noIdInfo
 		`addInfo` mkStrictnessInfo [WwStrict,WwLazy False] Nothing)
 		`addInfo` mkArityInfo 2)
 		`addInfo` mkUpdateInfo [1,2])
+\end{code}
+
+%************************************************************************
+%*									*
+\subsection[PrelUtils-specialisations]{Specialisations for builtin values}
+%*									*
+%************************************************************************
+
+The specialisations which exist for the builtin values must be recorded in
+their IdInfos.
 
-pRELUDE_FB = SLIT("PreludeFoldrBuild")
+NOTE: THE USES OF THE pcGenerate... FUNCTIONS MUST CORRESPOND
+      TO THE SPECIALISATIONS DECLARED IN THE PRELUDE !!!
+
+HACK: We currently use the same unique for the specialised Ids.
+
+The list @specing_types@ determines the types for which specialised
+versions are created. Note: This should correspond with the
+types passed to the pre-processor with the -genSPECS arg (see ghc.lprl).
+
+ToDo: Create single mkworld definition which is grabbed here and in ghc.lprl
+
+\begin{code}
+pcGenerateSpecs :: Unique -> Id -> IdInfo -> Type -> SpecEnv
+pcGenerateSpecs key id info ty
+  = nullSpecEnv
+
+{- LATER:
+
+pc_gen_specs True key id info ty
+
+pc_gen_specs is_id key id info ty
+ = mkSpecEnv spec_infos
+ where
+   spec_infos = [ let spec_ty = specialiseTy ty spec_tys 0
+		      spec_id = if is_id
+				then mkSpecId key {- HACK WARNING: same unique! -}
+					      id spec_tys spec_ty info
+				else panic "SpecData:SpecInfo:SpecId"
+		  in
+		  SpecInfo spec_tys (length ctxts) spec_id
+		| spec_tys <- specialisations ]
+
+   (tyvars, ctxts, _) = splitSigmaTy ty
+   no_tyvars	      = length tyvars
+
+   specialisations    = if no_tyvars == 0
+			then []
+			else tail (cross_product no_tyvars specing_types)
+
+			-- N.B. tail removes fully polymorphic specialisation
+
+cross_product 0 tys = []
+cross_product 1 tys = map (:[]) tys
+cross_product n tys = concat [map (:cp) tys | cp <- cross_product (n-1) tys]
+
+
+specing_types = [Nothing,
+		 Just charPrimTy,
+		 Just doublePrimTy,
+		 Just intPrimTy ]
+-}
 \end{code}
diff --git a/ghc/compiler/prelude/PrimKind.hi b/ghc/compiler/prelude/PrimKind.hi
deleted file mode 100644
index 7dd2713e37..0000000000
--- a/ghc/compiler/prelude/PrimKind.hi
+++ /dev/null
@@ -1,23 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface PrimKind where
-import Id(DataCon(..), Id)
-import Outputable(Outputable)
-import TyCon(TyCon)
-import UniType(UniType)
-type DataCon = Id
-data Id 
-data PrimKind   = PtrKind | CodePtrKind | DataPtrKind | RetKind | InfoPtrKind | CostCentreKind | CharKind | IntKind | WordKind | AddrKind | FloatKind | DoubleKind | MallocPtrKind | StablePtrKind | ArrayKind | ByteArrayKind | VoidKind
-data TyCon 
-data UniType 
-getKindInfo :: PrimKind -> ([Char], UniType, TyCon)
-getKindSize :: PrimKind -> Int
-guessPrimKind :: [Char] -> PrimKind
-isFloatingKind :: PrimKind -> Bool
-isFollowableKind :: PrimKind -> Bool
-retKindSize :: Int
-separateByPtrFollowness :: (a -> PrimKind) -> [a] -> ([a], [a])
-showPrimKind :: PrimKind -> [Char]
-instance Eq PrimKind
-instance Ord PrimKind
-instance Outputable PrimKind
-
diff --git a/ghc/compiler/prelude/PrimKind.lhs b/ghc/compiler/prelude/PrimKind.lhs
deleted file mode 100644
index 872fcc5b72..0000000000
--- a/ghc/compiler/prelude/PrimKind.lhs
+++ /dev/null
@@ -1,279 +0,0 @@
-%
-% (c) The GRASP Project, Glasgow University, 1992-1995
-%
-\section[PrimKind]{Primitive machine-level kinds of things.}
-
-At various places in the back end, we want to be to tag things with a
-``primitive kind''---i.e., the machine-manipulable implementation
-types.
-
-\begin{code}
-#include "HsVersions.h"
-
-module PrimKind (
-	PrimKind(..),
-	separateByPtrFollowness, isFollowableKind, isFloatingKind,
-	getKindSize, retKindSize,
-	getKindInfo, -- ToDo: DIE DIE DIE DIE DIE
-	showPrimKind,
-	guessPrimKind,
-
-	-- and to make the interface self-sufficient...
-	Id, DataCon(..), TyCon, UniType
-    ) where
-
-IMPORT_Trace
-
-#ifdef DPH
-import TyPod
-#endif {- Data Parallel Haskell -}
-
-import AbsUniType	-- we use more than I want to type in...
-import Id		( Id, DataCon(..) )
-import Outputable	-- class for printing, forcing
-import TysPrim
-import Pretty		-- pretty-printing code
-import Util
-
-#ifndef DPH
-#include "../../includes/GhcConstants.h"
-#else
-#include "../dphsystem/imports/DphConstants.h"
-#endif {- Data Parallel Haskell -}
-\end{code}
-
-%************************************************************************
-%*									*
-\subsection[PrimKind-datatype]{The @PrimKind@ datatype}
-%*									*
-%************************************************************************
-
-\begin{code}
-data PrimKind
-  = -- These pointer-kinds are all really the same, but we keep
-    -- them separate for documentation purposes.
-    PtrKind		-- Pointer to a closure; a ``word''.
-  | CodePtrKind		-- Pointer to code
-  | DataPtrKind		-- Pointer to data
-  | RetKind 	    	-- Pointer to code or data (return vector or code pointer)
-  | InfoPtrKind		-- Pointer to info table (DPH only?)
-  | CostCentreKind	-- Pointer to a cost centre
-
-  | CharKind		-- Machine characters
-  | IntKind		--	   integers (at least 32 bits)
-  | WordKind		--	   ditto (but *unsigned*)
-  | AddrKind		--	   addresses ("C pointers")
-  | FloatKind		--	   floats
-  | DoubleKind		--	   doubles
-
-  | MallocPtrKind	-- This has to be a special kind because ccall
-			-- generates special code when passing/returning
-			-- one of these. [ADR]
-
-  | StablePtrKind	-- We could replace this with IntKind but maybe
-			-- there's some documentation gain from having
-			-- it special? [ADR]
-
-  | ArrayKind		-- Primitive array of Haskell pointers
-  | ByteArrayKind	-- Primitive array of bytes (no Haskell pointers)
-
-  | VoidKind		-- Occupies no space at all!
-			-- (Primitive states are mapped onto this)
-#ifdef DPH
-  | PodNKind Int PrimKind
-#endif {- Data Parallel Haskell -}
-  deriving (Eq, Ord)
-	-- Kinds are used in PrimTyCons, which need both Eq and Ord
-	-- Text is needed for derived-Text on PrimitiveOps
-\end{code}
-
-%************************************************************************
-%*									*
-\subsection[PrimKind-predicates]{Follow-ness, sizes, and such---on @PrimitiveKinds@}
-%*									*
-%************************************************************************
-
-Whether or not the thing is a pointer that the garbage-collector
-should follow.
-
-Or, to put it another (less confusing) way, whether the object in
-question is a heap object.
-
-\begin{code}
-isFollowableKind :: PrimKind -> Bool
-isFollowableKind PtrKind    	= True
-isFollowableKind ArrayKind  	= True
-isFollowableKind ByteArrayKind 	= True
-isFollowableKind MallocPtrKind  = True
-
-isFollowableKind StablePtrKind  = False
--- StablePtrs aren't followable because they are just indices into a
--- table for which explicit allocation/ deallocation is required.
-
-isFollowableKind other	    	= False
-
-separateByPtrFollowness :: (a -> PrimKind) -> [a] -> ([a], [a])
-separateByPtrFollowness kind_fun things
-  = sep_things kind_fun things [] []
-    -- accumulating params for follow-able and don't-follow things...
-  where
-    sep_things kfun []     bs us = (reverse bs, reverse us)
-    sep_things kfun (t:ts) bs us
-      = if (isFollowableKind . kfun) t then
-	    sep_things kfun ts (t:bs) us
-	else
-	    sep_things kfun ts bs (t:us)
-\end{code}
-
-@isFloatingKind@ is used to distinguish @Double@ and @Float@ which
-cause inadvertent numeric conversions if you aren't jolly careful.
-See codeGen/CgCon:cgTopRhsCon.
-
-\begin{code}
-isFloatingKind :: PrimKind -> Bool
-isFloatingKind DoubleKind = True
-isFloatingKind FloatKind  = True
-isFloatingKind other      = False
-\end{code}
-
-\begin{code}
-getKindSize :: PrimKind -> Int
-getKindSize DoubleKind	  = DOUBLE_SIZE	-- "words", of course
---getKindSize FloatKind	  = 1
---getKindSize CharKind	  = 1	-- ToDo: count in bytes?
---getKindSize ArrayKind	  = 1	-- Listed specifically for *documentation*
---getKindSize ByteArrayKind = 1
-
-#ifdef DPH
-getKindSize (PodNKind _ _) = panic "getKindSize: PodNKind"
-#endif {- Data Parallel Haskell -}
-
-getKindSize VoidKind	  = 0
-getKindSize other	  = 1
-
-
-retKindSize :: Int
-retKindSize = getKindSize RetKind
-\end{code}
-
-%************************************************************************
-%*									*
-\subsection[PrimKind-type-fns]{@PrimitiveKinds@ and @UniTypes@}
-%*									*
-%************************************************************************
-
-@PrimitiveKinds@ are used in @PrimitiveOps@, for which we often need
-to reconstruct various type information.  (It's slightly more
-convenient/efficient to make type info from kinds, than kinds [etc.]
-from type info.)
-
-\begin{code}
-getKindInfo ::
-    PrimKind -> (String,			-- tag string
-		      UniType, TyCon)		-- prim type and tycon
-
-getKindInfo CharKind   = ("Char",   charPrimTy,   charPrimTyCon)
-getKindInfo IntKind    = ("Int",    intPrimTy,    intPrimTyCon)
-getKindInfo WordKind   = ("Word",   wordPrimTy,   wordPrimTyCon)
-getKindInfo AddrKind   = ("Addr",   addrPrimTy,   addrPrimTyCon)
-getKindInfo FloatKind  = ("Float",  floatPrimTy,  floatPrimTyCon)
-getKindInfo DoubleKind = ("Double", doublePrimTy, doublePrimTyCon)
-#ifdef DPH
-getKindInfo k@(PodNKind d kind)
-  = case kind of
-      PtrKind	->(no_no, no_no, no_no, no_no, no_no, no_no)
-      CharKind  ->("Char.Pod"++show d, mkPodizedPodNTy d charPrimTy,
-		    no_no, mkPodizedPodNTy d charTy, no_no, no_no)
-
-      IntKind   ->("Int.Pod"++show d, mkPodizedPodNTy d intPrimTy,
-		    no_no, mkPodizedPodNTy d intTy, no_no , no_no)
-
-      FloatKind ->("Float.Pod"++show d, mkPodizedPodNTy d floatPrimTy,
-		    no_no ,mkPodizedPodNTy d floatTy, no_no, no_no)
-
-      DoubleKind->("Double.Pod"++show d, mkPodizedPodNTy d doublePrimTy,
-		    no_no, mkPodizedPodNTy d doubleTy, no_no, no_no)
-      AddrKind  ->("Addr.Pod"++show d, mkPodizedPodNTy d addrPrimTy,
-		      no_no, no_no, no_no, no_no)
-      _         -> pprPanic "Found PodNKind" (ppr PprDebug k)
-   where
-     no_no = panic "getKindInfo: PodNKind"
-
-getKindInfo other = pprPanic "getKindInfo" (ppr PprDebug other)
-#endif {- Data Parallel Haskell -}
-\end{code}
-
-%************************************************************************
-%*									*
-\subsection[PrimKind-instances]{Boring instance decls for @PrimKind@}
-%*									*
-%************************************************************************
-
-\begin{code}
-instance Outputable PrimKind where
-#ifdef DPH
-    ppr sty (PodNKind d k)  = ppBesides [ppr sty k , ppStr ".POD" , ppr sty d]
-#endif {- Data Parallel Haskell -}
-    ppr sty kind = ppStr (showPrimKind kind)
-
-showPrimKind  :: PrimKind -> String
-guessPrimKind :: String -> PrimKind	-- a horrible "inverse" function
-
-showPrimKind PtrKind	    = "P_"	-- short for StgPtr
-
-showPrimKind CodePtrKind    = "P_"	-- DEATH to StgFunPtr! (94/02/22 WDP)
-    -- but aren't code pointers and function pointers different sizes
-    -- on some machines (eg 80x86)? ADR
-    -- Are you trying to ruin my life, or what? (WDP)
-
-showPrimKind DataPtrKind    = "D_"
-showPrimKind RetKind        = "StgRetAddr"
-showPrimKind InfoPtrKind    = "StgInfoPtr"
-showPrimKind CostCentreKind = "CostCentre"
-showPrimKind CharKind	    = "StgChar"
-showPrimKind IntKind	    = "I_"	-- short for StgInt
-showPrimKind WordKind	    = "W_"	-- short for StgWord
-showPrimKind AddrKind	    = "StgAddr"
-showPrimKind FloatKind	    = "StgFloat"
-showPrimKind DoubleKind	    = "StgDouble"
-showPrimKind ArrayKind	    = "StgArray" -- see comment below
-showPrimKind ByteArrayKind  = "StgByteArray"
-showPrimKind StablePtrKind  = "StgStablePtr"
-showPrimKind MallocPtrKind  = "StgPtr" -- see comment below
-showPrimKind VoidKind	    = "!!VOID_KIND!!"
-
-guessPrimKind "D_"	     = DataPtrKind
-guessPrimKind "StgRetAddr"   = RetKind
-guessPrimKind "StgInfoPtr"   = InfoPtrKind
-guessPrimKind "StgChar"	     = CharKind
-guessPrimKind "I_"	     = IntKind
-guessPrimKind "W_"	     = WordKind
-guessPrimKind "StgAddr"	     = AddrKind
-guessPrimKind "StgFloat"     = FloatKind
-guessPrimKind "StgDouble"    = DoubleKind
-guessPrimKind "StgArray"     = ArrayKind
-guessPrimKind "StgByteArray" = ByteArrayKind
-guessPrimKind "StgStablePtr" = StablePtrKind
-\end{code}
-
-All local C variables of @ArrayKind@ are declared in C as type
-@StgArray@.  The coercion to a more precise C type is done just before
-indexing (by the relevant C primitive-op macro).
-
-Nota Bene. There are three types associated with Malloc Pointers: 
-\begin{itemize}
-\item
-@StgMallocClosure@ is the type of the thing the C world gives us.
-(This typename is hardwired into @ppr_casm_results@ in
-@PprAbsC.lhs@.)
-
-\item
-@StgMallocPtr@ is the type of the thing we give the C world.
-
-\item
-@StgPtr@ is the type of the (pointer to the) heap object which we
-pass around inside the STG machine.
-\end{itemize}
-
-It is really easy to confuse the two.  (I'm not sure this choice of
-type names helps.) [ADR]
diff --git a/ghc/compiler/prelude/PrimOp.lhs b/ghc/compiler/prelude/PrimOp.lhs
new file mode 100644
index 0000000000..5dd0ccbb3f
--- /dev/null
+++ b/ghc/compiler/prelude/PrimOp.lhs
@@ -0,0 +1,1681 @@
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+%
+\section[PrimOp]{Primitive operations (machine-level)}
+
+\begin{code}
+#include "HsVersions.h"
+
+module PrimOp (
+	PrimOp(..), allThePrimOps,
+	tagOf_PrimOp, -- ToDo: rm
+	primOp_str,   -- sigh
+	primOpType, isCompareOp,
+
+	PrimOpResultInfo(..),
+	getPrimOpResultInfo,
+
+--MOVE:	primOpCanTriggerGC, primOpNeedsWrapper,
+--MOVE:	primOpOkForSpeculation, primOpIsCheap,
+--MOVE:	fragilePrimOp,
+--MOVE:	HeapRequirement(..), primOpHeapReq,
+
+       -- export for the Native Code Generator
+	primOpInfo, -- needed for primOpNameInfo
+	PrimOpInfo(..),
+
+	pprPrimOp, showPrimOp
+
+	-- and to make the interface self-sufficient....
+    ) where
+
+import Ubiq{-uitous-}
+
+import PrimRep		-- most of it
+import TysPrim
+import TysWiredIn
+
+import CStrings		( identToC )
+import CgCompInfo   	( mIN_MP_INT_SIZE, mP_STRUCT_SIZE )
+import NameTypes	( mkPreludeCoreName, FullName, ShortName )
+import PprStyle		( codeStyle )
+import Pretty
+import SMRep	    	( SMRep(..), SMSpecRepKind(..), SMUpdateKind(..) )
+import TyCon		( TyCon{-instances-} )
+import Type		( getAppDataTyCon, maybeAppDataTyCon,
+			  mkForAllTys, mkFunTys, applyTyCon )
+import TyVar		( alphaTyVar, betaTyVar )
+import Util		( panic#, assoc, panic{-ToDo:rm-} )
+
+glueTyArgs = panic "PrimOp:glueTyArgs"
+pprParendType = panic "PrimOp:pprParendType"
+primRepFromType = panic "PrimOp:primRepFromType"
+\end{code}
+
+%************************************************************************
+%*									*
+\subsection[PrimOp-datatype]{Datatype for @PrimOp@ (an enumeration)}
+%*									*
+%************************************************************************
+
+These are in \tr{state-interface.verb} order.
+
+\begin{code}
+data PrimOp
+    -- dig the FORTRAN/C influence on the names...
+
+    -- comparisons:
+
+    = CharGtOp   | CharGeOp   | CharEqOp   | CharNeOp   | CharLtOp   | CharLeOp
+    | IntGtOp    | IntGeOp    | IntEqOp    | IntNeOp	| IntLtOp    | IntLeOp
+    | WordGtOp   | WordGeOp   | WordEqOp   | WordNeOp	| WordLtOp   | WordLeOp
+    | AddrGtOp   | AddrGeOp   | AddrEqOp   | AddrNeOp	| AddrLtOp   | AddrLeOp
+    | FloatGtOp	 | FloatGeOp  | FloatEqOp  | FloatNeOp	| FloatLtOp  | FloatLeOp
+    | DoubleGtOp | DoubleGeOp | DoubleEqOp | DoubleNeOp | DoubleLtOp | DoubleLeOp
+
+    -- Char#-related ops:
+    | OrdOp | ChrOp
+
+    -- Int#-related ops:
+    -- IntAbsOp unused?? ADR
+    | IntAddOp | IntSubOp | IntMulOp | IntQuotOp
+    | IntRemOp | IntNegOp | IntAbsOp
+
+    -- Word#-related ops:
+    | AndOp  | OrOp   | NotOp
+    | SllOp  | SraOp  | SrlOp  -- shift {left,right} {arithmetic,logical}
+    | ISllOp | ISraOp | ISrlOp -- equivs on Int#s
+    | Int2WordOp | Word2IntOp -- casts
+
+    -- Addr#-related ops:
+    | Int2AddrOp | Addr2IntOp -- casts
+
+    -- Float#-related ops:
+    | FloatAddOp | FloatSubOp | FloatMulOp | FloatDivOp | FloatNegOp
+    | Float2IntOp | Int2FloatOp
+
+    | FloatExpOp   | FloatLogOp	  | FloatSqrtOp
+    | FloatSinOp   | FloatCosOp	  | FloatTanOp
+    | FloatAsinOp  | FloatAcosOp  | FloatAtanOp
+    | FloatSinhOp  | FloatCoshOp  | FloatTanhOp
+    -- not all machines have these available conveniently:
+    -- | FloatAsinhOp | FloatAcoshOp | FloatAtanhOp
+    | FloatPowerOp -- ** op
+
+    -- Double#-related ops:
+    | DoubleAddOp | DoubleSubOp | DoubleMulOp | DoubleDivOp | DoubleNegOp
+    | Double2IntOp | Int2DoubleOp
+    | Double2FloatOp | Float2DoubleOp
+
+    | DoubleExpOp   | DoubleLogOp   | DoubleSqrtOp
+    | DoubleSinOp   | DoubleCosOp   | DoubleTanOp
+    | DoubleAsinOp  | DoubleAcosOp  | DoubleAtanOp
+    | DoubleSinhOp  | DoubleCoshOp  | DoubleTanhOp
+    -- not all machines have these available conveniently:
+    -- | DoubleAsinhOp | DoubleAcoshOp | DoubleAtanhOp
+    | DoublePowerOp -- ** op
+
+    -- Integer (and related...) ops:
+    -- slightly weird -- to match GMP package.
+    | IntegerAddOp | IntegerSubOp | IntegerMulOp
+    | IntegerQuotRemOp | IntegerDivModOp | IntegerNegOp
+
+    | IntegerCmpOp
+
+    | Integer2IntOp  | Int2IntegerOp
+    | Word2IntegerOp
+    | Addr2IntegerOp -- "Addr" is *always* a literal string
+    -- ?? gcd, etc?
+
+    | FloatEncodeOp  | FloatDecodeOp
+    | DoubleEncodeOp | DoubleDecodeOp
+
+    -- primitive ops for primitive arrays
+
+    | NewArrayOp
+    | NewByteArrayOp PrimRep
+
+    | SameMutableArrayOp
+    | SameMutableByteArrayOp
+
+    | ReadArrayOp | WriteArrayOp | IndexArrayOp -- for arrays of Haskell ptrs
+
+    | ReadByteArrayOp	PrimRep
+    | WriteByteArrayOp	PrimRep
+    | IndexByteArrayOp	PrimRep
+    | IndexOffAddrOp	PrimRep
+	-- PrimRep can be one of {Char,Int,Addr,Float,Double}Kind.
+	-- This is just a cheesy encoding of a bunch of ops.
+	-- Note that MallocPtrRep is not included -- the only way of
+	-- creating a MallocPtr is with a ccall or casm.
+
+    | UnsafeFreezeArrayOp | UnsafeFreezeByteArrayOp
+
+    | NewSynchVarOp -- for MVars and IVars
+    | TakeMVarOp | PutMVarOp
+    | ReadIVarOp | WriteIVarOp
+
+    | MakeStablePtrOp | DeRefStablePtrOp
+\end{code}
+
+A special ``trap-door'' to use in making calls direct to C functions:
+\begin{code}
+    | CCallOp	FAST_STRING	-- An "unboxed" ccall# to this named function
+		Bool		-- True <=> really a "casm"
+		Bool		-- True <=> might invoke Haskell GC
+		[Type]	-- Unboxed argument; the state-token
+				-- argument will have been put *first*
+		Type		-- Return type; one of the "StateAnd<blah>#" types
+
+    -- (... to be continued ... )
+\end{code}
+
+The ``type'' of @CCallOp foo [t1, ... tm] r@ is @t1 -> ... tm -> r@.
+(See @primOpInfo@ for details.)
+
+Note: that first arg and part of the result should be the system state
+token (which we carry around to fool over-zealous optimisers) but
+which isn't actually passed.
+
+For example, we represent
+\begin{pseudocode}
+((ccall# foo [StablePtr# a, Int] Float) sp# i#) :: (Float, IoWorld)
+\end{pseudocode}
+by
+\begin{pseudocode}
+Case
+  ( Prim
+      (CCallOp "foo" [Universe#, StablePtr# a, Int#] FloatPrimAndUniverse False)
+       -- :: Universe# -> StablePtr# a -> Int# -> FloatPrimAndUniverse
+      []
+      [w#, sp# i#]
+  )
+  (AlgAlts [ ( FloatPrimAndIoWorld,
+		 [f#, w#],
+		 Con (TupleCon 2) [Float, IoWorld] [F# f#, World w#]
+	       ) ]
+	     NoDefault
+  )
+\end{pseudocode}
+
+Nota Bene: there are some people who find the empty list of types in
+the @Prim@ somewhat puzzling and would represent the above by
+\begin{pseudocode}
+Case
+  ( Prim
+      (CCallOp "foo" [alpha1, alpha2, alpha3] alpha4 False)
+       -- :: /\ alpha1, alpha2 alpha3, alpha4.
+       --       alpha1 -> alpha2 -> alpha3 -> alpha4
+      [Universe#, StablePtr# a, Int#, FloatPrimAndIoWorld]
+      [w#, sp# i#]
+  )
+  (AlgAlts [ ( FloatPrimAndIoWorld,
+		 [f#, w#],
+		 Con (TupleCon 2) [Float, IoWorld] [F# f#, World w#]
+	       ) ]
+	     NoDefault
+  )
+\end{pseudocode}
+
+But, this is a completely different way of using @CCallOp@.  The most
+major changes required if we switch to this are in @primOpInfo@, and
+the desugarer. The major difficulty is in moving the HeapRequirement
+stuff somewhere appropriate.  (The advantage is that we could simplify
+@CCallOp@ and record just the number of arguments with corresponding
+simplifications in reading pragma unfoldings, the simplifier,
+instantiation (etc) of core expressions, ... .  Maybe we should think
+about using it this way?? ADR)
+
+\begin{code}
+    -- (... continued from above ... )
+
+    -- one to support "errorIO" (and, thereby, "error")
+    | ErrorIOPrimOp
+
+    -- Operation to test two closure addresses for equality (yes really!)
+    -- BLAME ALASTAIR REID FOR THIS!  THE REST OF US ARE INNOCENT!
+    | ReallyUnsafePtrEqualityOp
+
+    -- three for parallel stuff
+    | SeqOp
+    | ParOp
+    | ForkOp
+
+    -- two for concurrency
+    | DelayOp
+    | WaitOp
+
+#ifdef GRAN
+    | ParGlobalOp	-- named global par
+    | ParLocalOp	-- named local par
+    | ParAtOp		-- specifies destination of local par
+    | ParAtForNowOp	-- specifies initial destination of global par
+    | CopyableOp	-- marks copyable code
+    | NoFollowOp	-- marks non-followup expression
+#endif {-GRAN-}
+\end{code}
+
+Deriving Ix is what we really want! ToDo
+(Chk around before deleting...)
+\begin{code}
+tagOf_PrimOp CharGtOp			= (ILIT(1) :: FAST_INT)
+tagOf_PrimOp CharGeOp			= ILIT(  2)
+tagOf_PrimOp CharEqOp			= ILIT(  3)
+tagOf_PrimOp CharNeOp			= ILIT(  4)
+tagOf_PrimOp CharLtOp			= ILIT(  5)
+tagOf_PrimOp CharLeOp			= ILIT(  6)
+tagOf_PrimOp IntGtOp			= ILIT(  7)
+tagOf_PrimOp IntGeOp			= ILIT(  8)
+tagOf_PrimOp IntEqOp			= ILIT(  9)
+tagOf_PrimOp IntNeOp			= ILIT( 10)
+tagOf_PrimOp IntLtOp			= ILIT( 11)
+tagOf_PrimOp IntLeOp			= ILIT( 12)
+tagOf_PrimOp WordGtOp			= ILIT( 13)
+tagOf_PrimOp WordGeOp			= ILIT( 14)
+tagOf_PrimOp WordEqOp			= ILIT( 15)
+tagOf_PrimOp WordNeOp			= ILIT( 16)
+tagOf_PrimOp WordLtOp			= ILIT( 17)
+tagOf_PrimOp WordLeOp			= ILIT( 18)
+tagOf_PrimOp AddrGtOp			= ILIT( 19)
+tagOf_PrimOp AddrGeOp			= ILIT( 20)
+tagOf_PrimOp AddrEqOp			= ILIT( 21)
+tagOf_PrimOp AddrNeOp			= ILIT( 22)
+tagOf_PrimOp AddrLtOp			= ILIT( 23)
+tagOf_PrimOp AddrLeOp			= ILIT( 24)
+tagOf_PrimOp FloatGtOp			= ILIT( 25)
+tagOf_PrimOp FloatGeOp			= ILIT( 26)
+tagOf_PrimOp FloatEqOp			= ILIT( 27)
+tagOf_PrimOp FloatNeOp			= ILIT( 28)
+tagOf_PrimOp FloatLtOp			= ILIT( 29)
+tagOf_PrimOp FloatLeOp			= ILIT( 30)
+tagOf_PrimOp DoubleGtOp			= ILIT( 31)
+tagOf_PrimOp DoubleGeOp			= ILIT( 32)
+tagOf_PrimOp DoubleEqOp			= ILIT( 33)
+tagOf_PrimOp DoubleNeOp			= ILIT( 34)
+tagOf_PrimOp DoubleLtOp			= ILIT( 35)
+tagOf_PrimOp DoubleLeOp			= ILIT( 36)
+tagOf_PrimOp OrdOp			= ILIT( 37)
+tagOf_PrimOp ChrOp			= ILIT( 38)
+tagOf_PrimOp IntAddOp			= ILIT( 39)
+tagOf_PrimOp IntSubOp			= ILIT( 40)
+tagOf_PrimOp IntMulOp			= ILIT( 41)
+tagOf_PrimOp IntQuotOp			= ILIT( 42)
+tagOf_PrimOp IntRemOp			= ILIT( 44)
+tagOf_PrimOp IntNegOp			= ILIT( 45)
+tagOf_PrimOp IntAbsOp			= ILIT( 46)
+tagOf_PrimOp AndOp			= ILIT( 47)
+tagOf_PrimOp OrOp			= ILIT( 48)
+tagOf_PrimOp NotOp			= ILIT( 49)
+tagOf_PrimOp SllOp			= ILIT( 50)
+tagOf_PrimOp SraOp			= ILIT( 51)
+tagOf_PrimOp SrlOp			= ILIT( 52)
+tagOf_PrimOp ISllOp			= ILIT( 53)
+tagOf_PrimOp ISraOp			= ILIT( 54)
+tagOf_PrimOp ISrlOp			= ILIT( 55)
+tagOf_PrimOp Int2WordOp			= ILIT( 56)
+tagOf_PrimOp Word2IntOp			= ILIT( 57)
+tagOf_PrimOp Int2AddrOp			= ILIT( 58)
+tagOf_PrimOp Addr2IntOp			= ILIT( 59)
+tagOf_PrimOp FloatAddOp			= ILIT( 60)
+tagOf_PrimOp FloatSubOp			= ILIT( 61)
+tagOf_PrimOp FloatMulOp			= ILIT( 62)
+tagOf_PrimOp FloatDivOp			= ILIT( 63)
+tagOf_PrimOp FloatNegOp			= ILIT( 64)
+tagOf_PrimOp Float2IntOp		= ILIT( 65)
+tagOf_PrimOp Int2FloatOp		= ILIT( 66)
+tagOf_PrimOp FloatExpOp			= ILIT( 67)
+tagOf_PrimOp FloatLogOp			= ILIT( 68)
+tagOf_PrimOp FloatSqrtOp		= ILIT( 69)
+tagOf_PrimOp FloatSinOp			= ILIT( 70)
+tagOf_PrimOp FloatCosOp			= ILIT( 71)
+tagOf_PrimOp FloatTanOp			= ILIT( 72)
+tagOf_PrimOp FloatAsinOp		= ILIT( 73)
+tagOf_PrimOp FloatAcosOp		= ILIT( 74)
+tagOf_PrimOp FloatAtanOp		= ILIT( 75)
+tagOf_PrimOp FloatSinhOp		= ILIT( 76)
+tagOf_PrimOp FloatCoshOp		= ILIT( 77)
+tagOf_PrimOp FloatTanhOp		= ILIT( 78)
+tagOf_PrimOp FloatPowerOp		= ILIT( 79)
+tagOf_PrimOp DoubleAddOp		= ILIT( 80)
+tagOf_PrimOp DoubleSubOp		= ILIT( 81)
+tagOf_PrimOp DoubleMulOp		= ILIT( 82)
+tagOf_PrimOp DoubleDivOp		= ILIT( 83)
+tagOf_PrimOp DoubleNegOp		= ILIT( 84)
+tagOf_PrimOp Double2IntOp		= ILIT( 85)
+tagOf_PrimOp Int2DoubleOp		= ILIT( 86)
+tagOf_PrimOp Double2FloatOp		= ILIT( 87)
+tagOf_PrimOp Float2DoubleOp		= ILIT( 88)
+tagOf_PrimOp DoubleExpOp		= ILIT( 89)
+tagOf_PrimOp DoubleLogOp		= ILIT( 90)
+tagOf_PrimOp DoubleSqrtOp		= ILIT( 91)
+tagOf_PrimOp DoubleSinOp		= ILIT( 92)
+tagOf_PrimOp DoubleCosOp		= ILIT( 93)
+tagOf_PrimOp DoubleTanOp		= ILIT( 94)
+tagOf_PrimOp DoubleAsinOp		= ILIT( 95)
+tagOf_PrimOp DoubleAcosOp		= ILIT( 96)
+tagOf_PrimOp DoubleAtanOp		= ILIT( 97)
+tagOf_PrimOp DoubleSinhOp		= ILIT( 98)
+tagOf_PrimOp DoubleCoshOp		= ILIT( 99)
+tagOf_PrimOp DoubleTanhOp		= ILIT(100)
+tagOf_PrimOp DoublePowerOp		= ILIT(101)
+tagOf_PrimOp IntegerAddOp		= ILIT(102)
+tagOf_PrimOp IntegerSubOp		= ILIT(103)
+tagOf_PrimOp IntegerMulOp		= ILIT(104)
+tagOf_PrimOp IntegerQuotRemOp		= ILIT(105)
+tagOf_PrimOp IntegerDivModOp		= ILIT(106)
+tagOf_PrimOp IntegerNegOp		= ILIT(107)
+tagOf_PrimOp IntegerCmpOp		= ILIT(108)
+tagOf_PrimOp Integer2IntOp		= ILIT(109)
+tagOf_PrimOp Int2IntegerOp		= ILIT(110)
+tagOf_PrimOp Word2IntegerOp		= ILIT(111)
+tagOf_PrimOp Addr2IntegerOp		= ILIT(112)
+tagOf_PrimOp FloatEncodeOp		= ILIT(113)
+tagOf_PrimOp FloatDecodeOp		= ILIT(114)
+tagOf_PrimOp DoubleEncodeOp		= ILIT(115)
+tagOf_PrimOp DoubleDecodeOp		= ILIT(116)
+tagOf_PrimOp NewArrayOp			= ILIT(117)
+tagOf_PrimOp (NewByteArrayOp CharRep)	= ILIT(118)
+tagOf_PrimOp (NewByteArrayOp IntRep)	= ILIT(119)
+tagOf_PrimOp (NewByteArrayOp AddrRep)	= ILIT(120)
+tagOf_PrimOp (NewByteArrayOp FloatRep)	= ILIT(121)
+tagOf_PrimOp (NewByteArrayOp DoubleRep)= ILIT(122)
+tagOf_PrimOp SameMutableArrayOp		= ILIT(123)
+tagOf_PrimOp SameMutableByteArrayOp	= ILIT(124)
+tagOf_PrimOp ReadArrayOp		= ILIT(125)
+tagOf_PrimOp WriteArrayOp		= ILIT(126)
+tagOf_PrimOp IndexArrayOp		= ILIT(127)
+tagOf_PrimOp (ReadByteArrayOp CharRep)	    = ILIT(128)
+tagOf_PrimOp (ReadByteArrayOp IntRep)	    = ILIT(129)
+tagOf_PrimOp (ReadByteArrayOp AddrRep)	    = ILIT(130)
+tagOf_PrimOp (ReadByteArrayOp FloatRep)    = ILIT(131)
+tagOf_PrimOp (ReadByteArrayOp DoubleRep)   = ILIT(132)
+tagOf_PrimOp (WriteByteArrayOp CharRep)    = ILIT(133)
+tagOf_PrimOp (WriteByteArrayOp IntRep)	    = ILIT(134)
+tagOf_PrimOp (WriteByteArrayOp AddrRep)    = ILIT(135)
+tagOf_PrimOp (WriteByteArrayOp FloatRep)   = ILIT(136)
+tagOf_PrimOp (WriteByteArrayOp DoubleRep)  = ILIT(137)
+tagOf_PrimOp (IndexByteArrayOp CharRep)    = ILIT(138)
+tagOf_PrimOp (IndexByteArrayOp IntRep)	    = ILIT(139)
+tagOf_PrimOp (IndexByteArrayOp AddrRep)    = ILIT(140)
+tagOf_PrimOp (IndexByteArrayOp FloatRep)   = ILIT(141)
+tagOf_PrimOp (IndexByteArrayOp DoubleRep)  = ILIT(142)
+tagOf_PrimOp (IndexOffAddrOp CharRep)	    = ILIT(143)
+tagOf_PrimOp (IndexOffAddrOp IntRep)	    = ILIT(144)
+tagOf_PrimOp (IndexOffAddrOp AddrRep)	    = ILIT(145)
+tagOf_PrimOp (IndexOffAddrOp FloatRep)	    = ILIT(146)
+tagOf_PrimOp (IndexOffAddrOp DoubleRep)    = ILIT(147)
+tagOf_PrimOp UnsafeFreezeArrayOp	    = ILIT(148)
+tagOf_PrimOp UnsafeFreezeByteArrayOp	    = ILIT(149)
+tagOf_PrimOp NewSynchVarOp		    = ILIT(150)
+tagOf_PrimOp TakeMVarOp		    	    = ILIT(151)
+tagOf_PrimOp PutMVarOp		    	    = ILIT(152)
+tagOf_PrimOp ReadIVarOp		    	    = ILIT(153)
+tagOf_PrimOp WriteIVarOp		    = ILIT(154)
+tagOf_PrimOp MakeStablePtrOp		    = ILIT(155)
+tagOf_PrimOp DeRefStablePtrOp		    = ILIT(156)
+tagOf_PrimOp (CCallOp _ _ _ _ _)	    = ILIT(157)
+tagOf_PrimOp ErrorIOPrimOp		    = ILIT(158)
+tagOf_PrimOp ReallyUnsafePtrEqualityOp	    = ILIT(159)
+tagOf_PrimOp SeqOp			    = ILIT(160)
+tagOf_PrimOp ParOp			    = ILIT(161)
+tagOf_PrimOp ForkOp			    = ILIT(162)
+tagOf_PrimOp DelayOp			    = ILIT(163)
+tagOf_PrimOp WaitOp			    = ILIT(164)
+
+#ifdef GRAN
+tagOf_PrimOp ParGlobalOp		    = ILIT(165)
+tagOf_PrimOp ParLocalOp			    = ILIT(166)
+tagOf_PrimOp ParAtOp			    = ILIT(167)
+tagOf_PrimOp ParAtForNowOp		    = ILIT(168)
+tagOf_PrimOp CopyableOp			    = ILIT(169)
+tagOf_PrimOp NoFollowOp			    = ILIT(170)
+#endif {-GRAN-}
+
+tagOf_PrimOp _ = panic# "tagOf_PrimOp: pattern-match"
+
+instance Eq PrimOp where
+    op == op2 = tagOf_PrimOp op _EQ_ tagOf_PrimOp op2
+\end{code}
+
+An @Enum@-derived list would be better; meanwhile... (ToDo)
+\begin{code}
+allThePrimOps
+  = [	CharGtOp,
+	CharGeOp,
+	CharEqOp,
+	CharNeOp,
+	CharLtOp,
+	CharLeOp,
+	IntGtOp,
+	IntGeOp,
+	IntEqOp,
+	IntNeOp,
+	IntLtOp,
+	IntLeOp,
+	WordGtOp,
+	WordGeOp,
+	WordEqOp,
+	WordNeOp,
+	WordLtOp,
+	WordLeOp,
+	AddrGtOp,
+	AddrGeOp,
+	AddrEqOp,
+	AddrNeOp,
+	AddrLtOp,
+	AddrLeOp,
+	FloatGtOp,
+	FloatGeOp,
+	FloatEqOp,
+	FloatNeOp,
+	FloatLtOp,
+	FloatLeOp,
+	DoubleGtOp,
+	DoubleGeOp,
+	DoubleEqOp,
+	DoubleNeOp,
+	DoubleLtOp,
+	DoubleLeOp,
+	OrdOp,
+	ChrOp,
+	IntAddOp,
+	IntSubOp,
+	IntMulOp,
+	IntQuotOp,
+	IntRemOp,
+	IntNegOp,
+	AndOp,
+	OrOp,
+	NotOp,
+    	SllOp,
+    	SraOp,
+    	SrlOp,
+    	ISllOp,
+    	ISraOp,
+    	ISrlOp,
+	Int2WordOp,
+	Word2IntOp,
+	Int2AddrOp,
+	Addr2IntOp,
+	FloatAddOp,
+	FloatSubOp,
+	FloatMulOp,
+	FloatDivOp,
+	FloatNegOp,
+	Float2IntOp,
+	Int2FloatOp,
+	FloatExpOp,
+	FloatLogOp,
+	FloatSqrtOp,
+	FloatSinOp,
+	FloatCosOp,
+	FloatTanOp,
+	FloatAsinOp,
+	FloatAcosOp,
+	FloatAtanOp,
+	FloatSinhOp,
+	FloatCoshOp,
+	FloatTanhOp,
+	FloatPowerOp,
+	DoubleAddOp,
+	DoubleSubOp,
+	DoubleMulOp,
+	DoubleDivOp,
+	DoubleNegOp,
+	Double2IntOp,
+	Int2DoubleOp,
+	Double2FloatOp,
+	Float2DoubleOp,
+	DoubleExpOp,
+	DoubleLogOp,
+	DoubleSqrtOp,
+	DoubleSinOp,
+	DoubleCosOp,
+	DoubleTanOp,
+	DoubleAsinOp,
+	DoubleAcosOp,
+	DoubleAtanOp,
+	DoubleSinhOp,
+	DoubleCoshOp,
+	DoubleTanhOp,
+	DoublePowerOp,
+	IntegerAddOp,
+	IntegerSubOp,
+	IntegerMulOp,
+	IntegerQuotRemOp,
+	IntegerDivModOp,
+	IntegerNegOp,
+	IntegerCmpOp,
+	Integer2IntOp,
+	Int2IntegerOp,
+	Word2IntegerOp,
+	Addr2IntegerOp,
+	FloatEncodeOp,
+	FloatDecodeOp,
+	DoubleEncodeOp,
+	DoubleDecodeOp,
+	NewArrayOp,
+	NewByteArrayOp CharRep,
+	NewByteArrayOp IntRep,
+	NewByteArrayOp AddrRep,
+	NewByteArrayOp FloatRep,
+	NewByteArrayOp DoubleRep,
+	SameMutableArrayOp,
+	SameMutableByteArrayOp,
+	ReadArrayOp,
+	WriteArrayOp,
+	IndexArrayOp,
+	ReadByteArrayOp CharRep,
+	ReadByteArrayOp IntRep,
+	ReadByteArrayOp AddrRep,
+	ReadByteArrayOp FloatRep,
+	ReadByteArrayOp DoubleRep,
+	WriteByteArrayOp CharRep,
+	WriteByteArrayOp IntRep,
+	WriteByteArrayOp AddrRep,
+	WriteByteArrayOp FloatRep,
+	WriteByteArrayOp DoubleRep,
+	IndexByteArrayOp CharRep,
+	IndexByteArrayOp IntRep,
+	IndexByteArrayOp AddrRep,
+	IndexByteArrayOp FloatRep,
+	IndexByteArrayOp DoubleRep,
+	IndexOffAddrOp CharRep,
+	IndexOffAddrOp IntRep,
+	IndexOffAddrOp AddrRep,
+	IndexOffAddrOp FloatRep,
+	IndexOffAddrOp DoubleRep,
+	UnsafeFreezeArrayOp,
+	UnsafeFreezeByteArrayOp,
+    	NewSynchVarOp,
+	ReadArrayOp,
+	TakeMVarOp,
+	PutMVarOp,
+	ReadIVarOp,
+	WriteIVarOp,
+	MakeStablePtrOp,
+	DeRefStablePtrOp,
+	ReallyUnsafePtrEqualityOp,
+	ErrorIOPrimOp,
+#ifdef GRAN
+	ParGlobalOp,
+	ParLocalOp,
+#endif {-GRAN-}
+	SeqOp,
+    	ParOp,
+    	ForkOp,
+	DelayOp,
+	WaitOp
+    ]
+\end{code}
+
+%************************************************************************
+%*									*
+\subsection[PrimOp-info]{The essential info about each @PrimOp@}
+%*									*
+%************************************************************************
+
+The @String@ in the @PrimOpInfos@ is the ``base name'' by which the user may
+refer to the primitive operation.  The conventional \tr{#}-for-
+unboxed ops is added on later.
+
+The reason for the funny characters in the names is so we do not
+interfere with the programmer's Haskell name spaces.
+
+We use @PrimKinds@ for the ``type'' information, because they're
+(slightly) more convenient to use than @TyCons@.
+\begin{code}
+data PrimOpInfo
+  = Dyadic	FAST_STRING	-- string :: T -> T -> T
+		Type
+  | Monadic	FAST_STRING	-- string :: T -> T
+		Type
+  | Compare	FAST_STRING	-- string :: T -> T -> Bool
+		Type
+  | Coerce	FAST_STRING	-- string :: T1 -> T2
+		Type
+		Type
+
+  | PrimResult	FAST_STRING
+		[TyVar] [Type] TyCon PrimRep [Type]
+		-- "PrimResult tvs [t1,..,tn] D# kind [s1,..,sm]"
+		-- has type Forall tvs. t1 -> ... -> tn -> (D# s1 ... sm)
+		-- D# is a primitive type constructor.
+		-- (the kind is the same info as D#, in another convenient form)
+
+  | AlgResult	FAST_STRING
+		[TyVar] [Type] TyCon [Type]
+		-- "AlgResult tvs [t1,..,tn] T [s1,..,sm]"
+		-- has type Forall tvs. t1 -> ... -> tn -> (T s1 ... sm)
+
+-- ToDo: Specialised calls to PrimOps are prohibited but may be desirable
+\end{code}
+
+Utility bits:
+\begin{code}
+one_Integer_ty = [intPrimTy, intPrimTy, byteArrayPrimTy]
+two_Integer_tys
+  = [intPrimTy, intPrimTy, byteArrayPrimTy, -- first Integer pieces
+     intPrimTy, intPrimTy, byteArrayPrimTy] -- second '' pieces
+an_Integer_and_Int_tys
+  = [intPrimTy, intPrimTy, byteArrayPrimTy, -- Integer
+     intPrimTy]
+
+integerMonadic name = AlgResult name [] one_Integer_ty integerTyCon []
+
+integerDyadic name = AlgResult name [] two_Integer_tys integerTyCon []
+
+integerDyadic2Results name = AlgResult name [] two_Integer_tys return2GMPsTyCon []
+
+integerCompare name = PrimResult name [] two_Integer_tys intPrimTyCon IntRep []
+\end{code}
+
+@primOpInfo@ gives all essential information (from which everything
+else, notably a type, can be constructed) for each @PrimOp@.
+
+\begin{code}
+primOpInfo :: PrimOp -> PrimOpInfo
+\end{code}
+
+There's plenty of this stuff!
+
+%************************************************************************
+%*									*
+\subsubsection[PrimOp-comparison]{PrimOpInfo basic comparison ops}
+%*									*
+%************************************************************************
+
+\begin{code}
+primOpInfo CharGtOp   = Compare SLIT("gtChar#")   charPrimTy
+primOpInfo CharGeOp   = Compare SLIT("geChar#")   charPrimTy
+primOpInfo CharEqOp   = Compare SLIT("eqChar#")   charPrimTy
+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 WordGtOp   = Compare SLIT("gtWord#")   wordPrimTy
+primOpInfo WordGeOp   = Compare SLIT("geWord#")   wordPrimTy
+primOpInfo WordEqOp   = Compare SLIT("eqWord#")   wordPrimTy
+primOpInfo WordNeOp   = Compare SLIT("neWord#")   wordPrimTy
+primOpInfo WordLtOp   = Compare SLIT("ltWord#")   wordPrimTy
+primOpInfo WordLeOp   = Compare SLIT("leWord#")   wordPrimTy
+
+primOpInfo AddrGtOp   = Compare SLIT("gtAddr#")   addrPrimTy
+primOpInfo AddrGeOp   = Compare SLIT("geAddr#")   addrPrimTy
+primOpInfo AddrEqOp   = Compare SLIT("eqAddr#")   addrPrimTy
+primOpInfo AddrNeOp   = Compare SLIT("neAddr#")   addrPrimTy
+primOpInfo AddrLtOp   = Compare SLIT("ltAddr#")   addrPrimTy
+primOpInfo AddrLeOp   = Compare SLIT("leAddr#")   addrPrimTy
+
+primOpInfo FloatGtOp  = Compare SLIT("gtFloat#")  floatPrimTy
+primOpInfo FloatGeOp  = Compare SLIT("geFloat#")  floatPrimTy
+primOpInfo FloatEqOp  = Compare SLIT("eqFloat#")  floatPrimTy
+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
+\end{code}
+
+%************************************************************************
+%*									*
+\subsubsection[PrimOp-Char]{PrimOpInfo for @Char#@s}
+%*									*
+%************************************************************************
+
+\begin{code}
+primOpInfo OrdOp = Coerce SLIT("ord#") charPrimTy intPrimTy
+primOpInfo ChrOp = Coerce SLIT("chr#") intPrimTy charPrimTy
+\end{code}
+
+%************************************************************************
+%*									*
+\subsubsection[PrimOp-Int]{PrimOpInfo for @Int#@s}
+%*									*
+%************************************************************************
+
+\begin{code}
+primOpInfo IntAddOp  = Dyadic SLIT("plusInt#")	 intPrimTy
+primOpInfo IntSubOp  = Dyadic SLIT("minusInt#") intPrimTy
+primOpInfo IntMulOp  = Dyadic SLIT("timesInt#") intPrimTy
+primOpInfo IntQuotOp = Dyadic SLIT("quotInt#")	 intPrimTy
+primOpInfo IntRemOp  = Dyadic SLIT("remInt#")	 intPrimTy
+
+primOpInfo IntNegOp  = Monadic SLIT("negateInt#") intPrimTy
+\end{code}
+
+%************************************************************************
+%*									*
+\subsubsection[PrimOp-Word]{PrimOpInfo for @Word#@s}
+%*									*
+%************************************************************************
+
+A @Word#@ is an unsigned @Int#@.
+
+\begin{code}
+primOpInfo AndOp    = Dyadic  SLIT("and#")	wordPrimTy
+primOpInfo OrOp	    = Dyadic  SLIT("or#")	wordPrimTy
+primOpInfo NotOp    = Monadic SLIT("not#")	wordPrimTy
+
+primOpInfo SllOp
+  = PrimResult SLIT("shiftL#")  [] [wordPrimTy, intPrimTy] wordPrimTyCon WordRep []
+primOpInfo SraOp
+  = PrimResult SLIT("shiftRA#") [] [wordPrimTy, intPrimTy] wordPrimTyCon WordRep []
+primOpInfo SrlOp
+  = PrimResult SLIT("shiftRL#") [] [wordPrimTy, intPrimTy] wordPrimTyCon WordRep []
+
+primOpInfo ISllOp
+  = PrimResult SLIT("iShiftL#")  [] [intPrimTy, intPrimTy] intPrimTyCon IntRep []
+primOpInfo ISraOp
+  = PrimResult SLIT("iShiftRA#") [] [intPrimTy, intPrimTy] intPrimTyCon IntRep []
+primOpInfo ISrlOp
+  = PrimResult SLIT("iShiftRL#") [] [intPrimTy, intPrimTy] intPrimTyCon IntRep []
+
+primOpInfo Int2WordOp = Coerce SLIT("int2Word#") intPrimTy wordPrimTy
+primOpInfo Word2IntOp = Coerce SLIT("word2Int#") wordPrimTy intPrimTy
+\end{code}
+
+%************************************************************************
+%*									*
+\subsubsection[PrimOp-Addr]{PrimOpInfo for @Addr#@s}
+%*									*
+%************************************************************************
+
+\begin{code}
+primOpInfo Int2AddrOp = Coerce SLIT("int2Addr#") intPrimTy addrPrimTy
+primOpInfo Addr2IntOp = Coerce SLIT("addr2Int#") addrPrimTy intPrimTy
+\end{code}
+
+%************************************************************************
+%*									*
+\subsubsection[PrimOp-Float]{PrimOpInfo for @Float#@s}
+%*									*
+%************************************************************************
+
+@encodeFloat#@ and @decodeFloat#@ are given w/ Integer-stuff (it's
+similar).
+
+\begin{code}
+primOpInfo FloatAddOp	= Dyadic    SLIT("plusFloat#")	   floatPrimTy
+primOpInfo FloatSubOp	= Dyadic    SLIT("minusFloat#")   floatPrimTy
+primOpInfo FloatMulOp	= Dyadic    SLIT("timesFloat#")   floatPrimTy
+primOpInfo FloatDivOp	= Dyadic    SLIT("divideFloat#")  floatPrimTy
+primOpInfo FloatNegOp	= Monadic   SLIT("negateFloat#")  floatPrimTy
+
+primOpInfo Float2IntOp	= Coerce SLIT("float2Int#") floatPrimTy intPrimTy
+primOpInfo Int2FloatOp	= Coerce SLIT("int2Float#") intPrimTy floatPrimTy
+
+primOpInfo FloatExpOp	= Monadic   SLIT("expFloat#")	   floatPrimTy
+primOpInfo FloatLogOp	= Monadic   SLIT("logFloat#")	   floatPrimTy
+primOpInfo FloatSqrtOp	= Monadic   SLIT("sqrtFloat#")	   floatPrimTy
+primOpInfo FloatSinOp	= Monadic   SLIT("sinFloat#")	   floatPrimTy
+primOpInfo FloatCosOp	= Monadic   SLIT("cosFloat#")	   floatPrimTy
+primOpInfo FloatTanOp	= Monadic   SLIT("tanFloat#")	   floatPrimTy
+primOpInfo FloatAsinOp	= Monadic   SLIT("asinFloat#")	   floatPrimTy
+primOpInfo FloatAcosOp	= Monadic   SLIT("acosFloat#")	   floatPrimTy
+primOpInfo FloatAtanOp	= Monadic   SLIT("atanFloat#")	   floatPrimTy
+primOpInfo FloatSinhOp	= Monadic   SLIT("sinhFloat#")	   floatPrimTy
+primOpInfo FloatCoshOp	= Monadic   SLIT("coshFloat#")	   floatPrimTy
+primOpInfo FloatTanhOp	= Monadic   SLIT("tanhFloat#")	   floatPrimTy
+primOpInfo FloatPowerOp	= Dyadic    SLIT("powerFloat#")   floatPrimTy
+\end{code}
+
+%************************************************************************
+%*									*
+\subsubsection[PrimOp-Double]{PrimOpInfo for @Double#@s}
+%*									*
+%************************************************************************
+
+@encodeDouble#@ and @decodeDouble#@ are given w/ Integer-stuff (it's
+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 DoubleNegOp	= Monadic   SLIT("negateDouble#") doublePrimTy
+
+primOpInfo Double2IntOp	    = Coerce SLIT("double2Int#")   doublePrimTy intPrimTy
+primOpInfo Int2DoubleOp	    = Coerce SLIT("int2Double#")   intPrimTy doublePrimTy
+
+primOpInfo Double2FloatOp   = Coerce SLIT("double2Float#") doublePrimTy floatPrimTy
+primOpInfo Float2DoubleOp   = Coerce SLIT("float2Double#") floatPrimTy doublePrimTy
+
+primOpInfo DoubleExpOp	= Monadic   SLIT("expDouble#")	   doublePrimTy
+primOpInfo DoubleLogOp	= Monadic   SLIT("logDouble#")	   doublePrimTy
+primOpInfo DoubleSqrtOp	= Monadic   SLIT("sqrtDouble#")   doublePrimTy
+primOpInfo DoubleSinOp	= Monadic   SLIT("sinDouble#")	   doublePrimTy
+primOpInfo DoubleCosOp	= Monadic   SLIT("cosDouble#")	   doublePrimTy
+primOpInfo DoubleTanOp	= Monadic   SLIT("tanDouble#")	   doublePrimTy
+primOpInfo DoubleAsinOp	= Monadic   SLIT("asinDouble#")   doublePrimTy
+primOpInfo DoubleAcosOp	= Monadic   SLIT("acosDouble#")   doublePrimTy
+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
+\end{code}
+
+%************************************************************************
+%*									*
+\subsubsection[PrimOp-Integer]{PrimOpInfo for @Integer@ (and related!)}
+%*									*
+%************************************************************************
+
+\begin{code}
+primOpInfo IntegerNegOp	= integerMonadic SLIT("negateInteger#")
+
+primOpInfo IntegerAddOp	= integerDyadic SLIT("plusInteger#")
+primOpInfo IntegerSubOp	= integerDyadic SLIT("minusInteger#")
+primOpInfo IntegerMulOp	= integerDyadic SLIT("timesInteger#")
+
+primOpInfo IntegerCmpOp	= integerCompare SLIT("cmpInteger#")
+
+primOpInfo IntegerQuotRemOp = integerDyadic2Results SLIT("quotRemInteger#")
+primOpInfo IntegerDivModOp  = integerDyadic2Results SLIT("divModInteger#")
+
+primOpInfo Integer2IntOp
+  = PrimResult SLIT("integer2Int#") [] one_Integer_ty intPrimTyCon IntRep []
+
+primOpInfo Int2IntegerOp
+  = AlgResult SLIT("int2Integer#") [] [intPrimTy] integerTyCon []
+
+primOpInfo Word2IntegerOp
+  = AlgResult SLIT("word2Integer#") [] [wordPrimTy] integerTyCon []
+
+primOpInfo Addr2IntegerOp
+  = AlgResult SLIT("addr2Integer#") [] [addrPrimTy] integerTyCon []
+\end{code}
+
+Encoding and decoding of floating-point numbers is sorta
+Integer-related.
+
+\begin{code}
+primOpInfo FloatEncodeOp
+  = PrimResult SLIT("encodeFloat#") [] an_Integer_and_Int_tys
+	 floatPrimTyCon FloatRep []
+
+primOpInfo DoubleEncodeOp
+  = PrimResult SLIT("encodeDouble#") [] an_Integer_and_Int_tys
+	doublePrimTyCon DoubleRep []
+
+primOpInfo FloatDecodeOp
+  = AlgResult SLIT("decodeFloat#") [] [floatPrimTy] returnIntAndGMPTyCon []
+
+primOpInfo DoubleDecodeOp
+  = AlgResult SLIT("decodeDouble#") [] [doublePrimTy] returnIntAndGMPTyCon []
+\end{code}
+
+%************************************************************************
+%*									*
+\subsubsection[PrimOp-Arrays]{PrimOpInfo for primitive arrays}
+%*									*
+%************************************************************************
+
+\begin{code}
+primOpInfo NewArrayOp
+  = let {
+	elt = alphaTy; elt_tv = alphaTyVar; s = betaTy; s_tv = betaTyVar
+    } in
+    AlgResult SLIT("newArray#") [s_tv, elt_tv] [intPrimTy, elt, mkStatePrimTy s]
+				stateAndMutableArrayPrimTyCon [s, elt]
+
+primOpInfo (NewByteArrayOp kind)
+  = let
+	s = alphaTy; s_tv = alphaTyVar
+
+	(str, _, prim_tycon) = getPrimRepInfo kind
+
+	op_str	       = _PK_ ("new" ++ str ++ "Array#")
+    in
+    AlgResult op_str [s_tv]
+	[intPrimTy, mkStatePrimTy s]
+	stateAndMutableByteArrayPrimTyCon [s]
+
+---------------------------------------------------------------------------
+
+primOpInfo SameMutableArrayOp
+  = let {
+	elt = alphaTy; elt_tv = alphaTyVar; s = betaTy; s_tv = betaTyVar;
+	mut_arr_ty = mkMutableArrayPrimTy s elt
+    } in
+    AlgResult SLIT("sameMutableArray#") [s_tv, elt_tv] [mut_arr_ty, mut_arr_ty]
+				   boolTyCon []
+
+primOpInfo SameMutableByteArrayOp
+  = let {
+	s = alphaTy; s_tv = alphaTyVar;
+	mut_arr_ty = mkMutableByteArrayPrimTy s
+    } in
+    AlgResult SLIT("sameMutableByteArray#") [s_tv] [mut_arr_ty, mut_arr_ty]
+				   boolTyCon []
+
+---------------------------------------------------------------------------
+-- Primitive arrays of Haskell pointers:
+
+primOpInfo ReadArrayOp
+  = let {
+	elt = alphaTy; elt_tv = alphaTyVar; s = betaTy; s_tv = betaTyVar
+    } in
+    AlgResult SLIT("readArray#") [s_tv, elt_tv]
+	[mkMutableArrayPrimTy s elt, intPrimTy, mkStatePrimTy s]
+	stateAndPtrPrimTyCon [s, elt]
+
+
+primOpInfo WriteArrayOp
+  = let {
+	elt = alphaTy; elt_tv = alphaTyVar; s = betaTy; s_tv = betaTyVar
+    } in
+    PrimResult SLIT("writeArray#") [s_tv, elt_tv]
+	[mkMutableArrayPrimTy s elt, intPrimTy, elt, mkStatePrimTy s]
+	statePrimTyCon VoidRep [s]
+
+primOpInfo IndexArrayOp
+  = let { elt = alphaTy; elt_tv = alphaTyVar } in
+    AlgResult SLIT("indexArray#") [elt_tv] [mkArrayPrimTy elt, intPrimTy]
+				   liftTyCon [elt]
+
+---------------------------------------------------------------------------
+-- Primitive arrays full of unboxed bytes:
+
+primOpInfo (ReadByteArrayOp kind)
+  = let
+	s = alphaTy; s_tv = alphaTyVar
+
+	(str, _, prim_tycon) = getPrimRepInfo kind
+
+	op_str	       = _PK_ ("read" ++ str ++ "Array#")
+	relevant_tycon = assoc "primOpInfo" tbl kind
+    in
+    AlgResult op_str [s_tv]
+	[mkMutableByteArrayPrimTy s, intPrimTy, mkStatePrimTy s]
+	relevant_tycon [s]
+  where
+    tbl = [ (CharRep,	 stateAndCharPrimTyCon),
+	    (IntRep,	 stateAndIntPrimTyCon),
+	    (AddrRep,	 stateAndAddrPrimTyCon),
+	    (FloatRep,	 stateAndFloatPrimTyCon),
+	    (DoubleRep, stateAndDoublePrimTyCon) ]
+
+  -- How come there's no Word byte arrays? ADR
+
+primOpInfo (WriteByteArrayOp kind)
+  = let
+	s = alphaTy; s_tv = alphaTyVar
+
+	(str, prim_ty, _) = getPrimRepInfo kind
+	op_str = _PK_ ("write" ++ str ++ "Array#")
+    in
+    -- NB: *Prim*Result --
+    PrimResult op_str [s_tv]
+	[mkMutableByteArrayPrimTy s, intPrimTy, prim_ty, mkStatePrimTy s]
+	statePrimTyCon VoidRep [s]
+
+primOpInfo (IndexByteArrayOp kind)
+  = let
+	(str, _, prim_tycon) = getPrimRepInfo kind
+	op_str = _PK_ ("index" ++ str ++ "Array#")
+    in
+    -- NB: *Prim*Result --
+    PrimResult op_str [] [byteArrayPrimTy, intPrimTy] prim_tycon kind []
+
+primOpInfo (IndexOffAddrOp kind)
+  = let
+	(str, _, prim_tycon) = getPrimRepInfo kind
+	op_str = _PK_ ("index" ++ str ++ "OffAddr#")
+    in
+    PrimResult op_str [] [addrPrimTy, intPrimTy] prim_tycon kind []
+
+---------------------------------------------------------------------------
+primOpInfo UnsafeFreezeArrayOp
+  = let {
+	elt = alphaTy; elt_tv = alphaTyVar; s = betaTy; s_tv = betaTyVar
+    } in
+    AlgResult SLIT("unsafeFreezeArray#") [s_tv, elt_tv]
+	[mkMutableArrayPrimTy s elt, mkStatePrimTy s]
+	stateAndArrayPrimTyCon [s, elt]
+
+primOpInfo UnsafeFreezeByteArrayOp
+  = let { s = alphaTy; s_tv = alphaTyVar } in
+    AlgResult SLIT("unsafeFreezeByteArray#") [s_tv]
+	[mkMutableByteArrayPrimTy s, mkStatePrimTy s]
+	stateAndByteArrayPrimTyCon [s]
+\end{code}
+
+%************************************************************************
+%*									*
+\subsubsection[PrimOp-SynchVars]{PrimOpInfo for synchronizing Variables}
+%*									*
+%************************************************************************
+
+\begin{code}
+primOpInfo NewSynchVarOp
+  = let {
+	elt = alphaTy; elt_tv = alphaTyVar; s = betaTy; s_tv = betaTyVar
+    } in
+    AlgResult SLIT("newSynchVar#") [s_tv, elt_tv] [mkStatePrimTy s]
+				stateAndSynchVarPrimTyCon [s, elt]
+
+primOpInfo TakeMVarOp
+  = let {
+	elt = alphaTy; elt_tv = alphaTyVar; s = betaTy; s_tv = betaTyVar
+    } in
+    AlgResult SLIT("takeMVar#") [s_tv, elt_tv]
+	[mkSynchVarPrimTy s elt, mkStatePrimTy s]
+	stateAndPtrPrimTyCon [s, elt]
+
+primOpInfo PutMVarOp
+  = let {
+	elt = alphaTy; elt_tv = alphaTyVar; s = betaTy; s_tv = betaTyVar
+    } in
+    AlgResult SLIT("putMVar#") [s_tv, elt_tv]
+	[mkSynchVarPrimTy s elt, elt, mkStatePrimTy s]
+	statePrimTyCon [s]
+
+primOpInfo ReadIVarOp
+  = let {
+	elt = alphaTy; elt_tv = alphaTyVar; s = betaTy; s_tv = betaTyVar
+    } in
+    AlgResult SLIT("readIVar#") [s_tv, elt_tv]
+	[mkSynchVarPrimTy s elt, mkStatePrimTy s]
+	stateAndPtrPrimTyCon [s, elt]
+
+primOpInfo WriteIVarOp
+  = let {
+	elt = alphaTy; elt_tv = alphaTyVar; s = betaTy; s_tv = betaTyVar
+    } in
+    AlgResult SLIT("writeIVar#") [s_tv, elt_tv]
+	[mkSynchVarPrimTy s elt, elt, mkStatePrimTy s]
+	statePrimTyCon [s]
+
+\end{code}
+
+%************************************************************************
+%*									*
+\subsubsection[PrimOp-Wait]{PrimOpInfo for delay/wait operations}
+%*									*
+%************************************************************************
+
+\begin{code}
+
+primOpInfo DelayOp
+  = let {
+	s = alphaTy; s_tv = alphaTyVar
+    } in
+    PrimResult SLIT("delay#") [s_tv]
+	[intPrimTy, mkStatePrimTy s]
+	statePrimTyCon VoidRep [s]
+
+primOpInfo WaitOp
+  = let {
+	s = alphaTy; s_tv = alphaTyVar
+    } in
+    PrimResult SLIT("wait#") [s_tv]
+	[intPrimTy, mkStatePrimTy s]
+	statePrimTyCon VoidRep [s]
+
+\end{code}
+
+
+%************************************************************************
+%*									*
+\subsubsection[PrimOp-stable-pointers]{PrimOpInfo for ``stable pointers''}
+%*									*
+%************************************************************************
+
+A {\em stable pointer} is an index into a table of pointers into the
+heap.  Since the garbage collector is told about stable pointers, it
+is safe to pass a stable pointer to external systems such as C
+routines.
+
+Here's what the operations and types are supposed to be (from
+state-interface document).
+
+\begin{verbatim}
+makeStablePtr#  :: a -> State# _RealWorld -> StateAndStablePtr# _RealWorld a
+freeStablePtr#  :: StablePtr# a -> State# _RealWorld -> State# _RealWorld
+deRefStablePtr# :: StablePtr# a -> State# _RealWorld -> StateAndPtr _RealWorld a
+\end{verbatim}
+
+It may seem a bit surprising that @makeStablePtr#@ is a @PrimIO@
+operation since it doesn't (directly) involve IO operations.  The
+reason is that if some optimisation pass decided to duplicate calls to
+@makeStablePtr#@ and we only pass one of the stable pointers over, a
+massive space leak can result.  Putting it into the PrimIO monad
+prevents this.  (Another reason for putting them in a monad is to
+ensure correct sequencing wrt the side-effecting @freeStablePtr#@
+operation.)
+
+Note that we can implement @freeStablePtr#@ using @_ccall_@ (and,
+besides, it's not likely to be used from Haskell) so it's not a
+primop.
+
+Question: Why @_RealWorld@ - won't any instance of @_ST@ do the job? [ADR]
+
+\begin{code}
+primOpInfo MakeStablePtrOp
+  = AlgResult SLIT("makeStablePtr#") [alphaTyVar]
+	[alphaTy, realWorldStatePrimTy]
+	stateAndStablePtrPrimTyCon [realWorldTy, alphaTy]
+
+primOpInfo DeRefStablePtrOp
+  = AlgResult SLIT("deRefStablePtr#") [alphaTyVar]
+	[mkStablePtrPrimTy alphaTy, realWorldStatePrimTy]
+	stateAndPtrPrimTyCon [realWorldTy, alphaTy]
+\end{code}
+
+%************************************************************************
+%*									*
+\subsubsection[PrimOp-unsafePointerEquality]{PrimOpInfo for Pointer Equality}
+%*									*
+%************************************************************************
+
+[Alastair Reid is to blame for this!]
+
+These days, (Glasgow) Haskell seems to have a bit of everything from
+other languages: strict operations, mutable variables, sequencing,
+pointers, etc.  About the only thing left is LISP's ability to test
+for pointer equality.  So, let's add it in!
+
+\begin{verbatim}
+reallyUnsafePtrEquality :: a -> a -> Int#
+\end{verbatim}
+
+which tests any two closures (of the same type) to see if they're the
+same.  (Returns $0$ for @False@, $\neq 0$ for @True@ - to avoid
+difficulties of trying to box up the result.)
+
+NB This is {\em really unsafe\/} because even something as trivial as
+a garbage collection might change the answer by removing indirections.
+Still, no-one's forcing you to use it.  If you're worried about little
+things like loss of referential transparency, you might like to wrap
+it all up in a monad-like thing as John O'Donnell and John Hughes did
+for non-determinism (1989 (Fraserburgh) Glasgow FP Workshop
+Proceedings?)
+
+I'm thinking of using it to speed up a critical equality test in some
+graphics stuff in a context where the possibility of saying that
+denotationally equal things aren't isn't a problem (as long as it
+doesn't happen too often.)  ADR
+
+To Will: Jim said this was already in, but I can't see it so I'm
+adding it.  Up to you whether you add it.  (Note that this could have
+been readily implemented using a @veryDangerousCCall@ before they were
+removed...)
+
+\begin{code}
+primOpInfo ReallyUnsafePtrEqualityOp
+  = PrimResult SLIT("reallyUnsafePtrEquality#") [alphaTyVar]
+	[alphaTy, alphaTy] intPrimTyCon IntRep []
+\end{code}
+
+%************************************************************************
+%*									*
+\subsubsection[PrimOp-parallel]{PrimOpInfo for parallelism op(s)}
+%*									*
+%************************************************************************
+
+\begin{code}
+primOpInfo SeqOp	-- seq# :: a -> Int#
+  = PrimResult SLIT("seq#")	[alphaTyVar] [alphaTy] intPrimTyCon IntRep []
+
+primOpInfo ParOp	-- par# :: a -> Int#
+  = PrimResult SLIT("par#")	[alphaTyVar] [alphaTy] intPrimTyCon IntRep []
+
+primOpInfo ForkOp	-- fork# :: a -> Int#
+  = PrimResult SLIT("fork#")	[alphaTyVar] [alphaTy] intPrimTyCon IntRep []
+
+\end{code}
+
+\begin{code}
+#ifdef GRAN
+
+primOpInfo ParGlobalOp	-- parGlobal# :: Int -> a -> b -> b
+  = AlgResult SLIT("parGlobal#")	[alphaTyVar,betaTyVar] [intPrimTy,alphaTy,betaTy] liftTyCon [betaTy]
+
+primOpInfo ParLocalOp	-- parLocal# :: Int -> a -> b -> b
+  = AlgResult SLIT("parLocal#")	[alphaTyVar,betaTyVar] [intPrimTy,alphaTy,betaTy] liftTyCon [betaTy]
+
+primOpInfo ParAtOp	-- parAt# :: Int -> a -> b -> c -> c
+  = AlgResult SLIT("parAt#")	[alphaTyVar,betaTyVar,gammaTyVar] [intPrimTy,alphaTy,betaTy,gammaTy] liftTyCon [gammaTy]
+
+primOpInfo ParAtForNowOp	-- parAtForNow# :: Int -> a -> b -> c -> c
+  = AlgResult SLIT("parAtForNow#")	[alphaTyVar,betaTyVar,gammaTyVar] [intPrimTy,alphaTy,betaTy,gammaTy] liftTyCon [gammaTy]
+
+primOpInfo CopyableOp	-- copyable# :: a -> a
+  = AlgResult SLIT("copyable#")	[alphaTyVar] [alphaTy] liftTyCon [alphaTy]
+
+primOpInfo NoFollowOp	-- noFollow# :: a -> a
+  = AlgResult SLIT("noFollow#")	[alphaTyVar] [alphaTy] liftTyCon [alphaTy]
+
+#endif {-GRAN-}
+\end{code}
+
+%************************************************************************
+%*									*
+\subsubsection[PrimOp-errorIO]{PrimOpInfo for @errorIO#@}
+%*									*
+%************************************************************************
+
+\begin{code}
+primOpInfo ErrorIOPrimOp -- errorIO# :: PrimIO () -> State# RealWorld#
+  = PrimResult SLIT("errorIO#") []
+	[mkPrimIoTy unitTy]
+	statePrimTyCon VoidRep [realWorldTy]
+\end{code}
+
+%************************************************************************
+%*									*
+\subsubsection[PrimOp-IO-etc]{PrimOpInfo for C calls, and I/O-ish things}
+%*									*
+%************************************************************************
+
+\begin{code}
+primOpInfo (CCallOp _ _ _ arg_tys result_ty)
+  = AlgResult SLIT("ccall#") [] arg_tys result_tycon tys_applied
+  where
+    (result_tycon, tys_applied, _) = getAppDataTyCon result_ty
+\end{code}
+
+%************************************************************************
+%*									*
+\subsection[PrimOp-utils]{Utilities for @PrimitiveOps@}
+%*									*
+%************************************************************************
+
+The primitive-array-creation @PrimOps@ and {\em most} of those to do
+with @Integers@ can trigger GC.  Here we describe the heap requirements
+of the various @PrimOps@.  For most, no heap is required.  For a few,
+a fixed amount of heap is required, and the needs of the @PrimOp@ can
+be combined with the rest of the heap usage in the basic block.  For an
+unfortunate few, some unknown amount of heap is required (these are the
+ops which can trigger GC).
+
+\begin{code}
+{- MOVE:
+data HeapRequirement
+    = NoHeapRequired
+    | FixedHeapRequired HeapOffset
+    | VariableHeapRequired
+
+primOpHeapReq :: PrimOp -> HeapRequirement
+
+primOpHeapReq NewArrayOp	= VariableHeapRequired
+primOpHeapReq (NewByteArrayOp _)= VariableHeapRequired
+
+primOpHeapReq IntegerAddOp	= VariableHeapRequired
+primOpHeapReq IntegerSubOp	= VariableHeapRequired
+primOpHeapReq IntegerMulOp	= VariableHeapRequired
+primOpHeapReq IntegerQuotRemOp	= VariableHeapRequired
+primOpHeapReq IntegerDivModOp	= VariableHeapRequired
+primOpHeapReq IntegerNegOp	= VariableHeapRequired
+primOpHeapReq Int2IntegerOp	= FixedHeapRequired
+    	    	    	    	  (addOff (totHdrSize (DataRep mIN_MP_INT_SIZE))
+    	    	    	    	    	  (intOff mIN_MP_INT_SIZE))
+primOpHeapReq Word2IntegerOp	= FixedHeapRequired
+    	    	    	    	  (addOff (totHdrSize (DataRep mIN_MP_INT_SIZE))
+    	    	    	    	    	  (intOff mIN_MP_INT_SIZE))
+primOpHeapReq Addr2IntegerOp	= VariableHeapRequired
+primOpHeapReq FloatDecodeOp	= FixedHeapRequired
+				  (addOff (intOff (getPrimRepSize IntRep + mP_STRUCT_SIZE))
+    	    	    	    	  (addOff (totHdrSize (DataRep mIN_MP_INT_SIZE))
+    	    	    	    	    	  (intOff mIN_MP_INT_SIZE)))
+primOpHeapReq DoubleDecodeOp	= FixedHeapRequired
+				  (addOff (intOff (getPrimRepSize IntRep + mP_STRUCT_SIZE))
+    	    	    	    	  (addOff (totHdrSize (DataRep mIN_MP_INT_SIZE))
+    	    	    	    	    	  (intOff mIN_MP_INT_SIZE)))
+
+-- ccall may allocate heap if it is explicitly allowed to (_ccall_gc_)
+-- or if it returns a MallocPtr.
+
+primOpHeapReq (CCallOp _ _ mayGC@True _ _) = VariableHeapRequired
+primOpHeapReq (CCallOp _ _ mayGC@False _ return_ty)
+   = if returnsMallocPtr
+     then VariableHeapRequired
+     else NoHeapRequired
+  where
+   returnsMallocPtr
+     = case (maybeAppDataTyCon return_ty) of
+	 Nothing            -> False
+	 Just (tycon, _, _) -> tycon == stateAndMallocPtrPrimTyCon
+
+-- this occasionally has to expand the Stable Pointer table
+primOpHeapReq MakeStablePtrOp	= VariableHeapRequired
+
+-- These four only need heap space with the native code generator
+-- ToDo!: parameterize, so we know if native code generation is taking place(JSM)
+
+primOpHeapReq IntegerCmpOp	= FixedHeapRequired (intOff (2 * mP_STRUCT_SIZE))
+primOpHeapReq Integer2IntOp    	= FixedHeapRequired (intOff mP_STRUCT_SIZE)
+primOpHeapReq FloatEncodeOp    	= FixedHeapRequired (intOff mP_STRUCT_SIZE)
+primOpHeapReq DoubleEncodeOp   	= FixedHeapRequired (intOff mP_STRUCT_SIZE)
+
+-- a NewSynchVarOp creates a three-word mutuple in the heap.
+primOpHeapReq NewSynchVarOp	= FixedHeapRequired
+    	    	    	    	  (addOff (totHdrSize (MuTupleRep 3)) (intOff 3))
+
+-- Sparking ops no longer allocate any heap; however, _fork_ may
+-- require a context switch to clear space in the required thread
+-- pool, and that requires liveness information.
+
+primOpHeapReq ParOp	    	= NoHeapRequired
+primOpHeapReq ForkOp	    	= VariableHeapRequired
+
+-- A SeqOp requires unknown space to evaluate its argument
+primOpHeapReq SeqOp	    	= VariableHeapRequired
+
+#ifdef GRAN
+
+-- a ParGlobalOp creates a single 4-tuple in the heap.  ToDo: verify this!
+primOpHeapReq ParGlobalOp	= trace "primOpHeapReq:ParGlobalOp:verify!" (
+				  FixedHeapRequired
+    	    	    	    	  (addOff (totHdrSize (MuTupleRep 4)) (intOff 4))
+				  )
+
+-- a ParLocalOp creates a single 4-tuple in the heap.  ToDo: verify this!
+primOpHeapReq ParLocalOp	= trace "primOpHeapReq:ParLocalOp:verify!" (
+				  FixedHeapRequired
+    	    	    	    	  (addOff (totHdrSize (MuTupleRep 4)) (intOff 4))
+				  )
+
+-- ToDo: parAt, parAtForNow, copyable, noFollow !!  (HWL)
+#endif {-GRAN-}
+
+primOpHeapReq other_op	    	= NoHeapRequired
+-}
+\end{code}
+
+Primops which can trigger GC have to be called carefully.
+In particular, their arguments are guaranteed to be in registers,
+and a liveness mask tells which regs are live.
+
+\begin{code}
+{- MOVE:
+primOpCanTriggerGC op =
+    case op of
+    	TakeMVarOp  -> True
+    	ReadIVarOp  -> True
+	DelayOp     -> True
+	WaitOp      -> True
+	_           ->
+	    case primOpHeapReq op of
+    	    	VariableHeapRequired -> True
+    	    	_                    -> False
+-}
+\end{code}
+
+Sometimes we may choose to execute a PrimOp even though it isn't
+certain that its result will be required; ie execute them
+``speculatively''.  The same thing as ``cheap eagerness.'' Usually
+this is OK, because PrimOps are usually cheap, but it isn't OK for
+(a)~expensive PrimOps and (b)~PrimOps which can fail.
+
+See also @primOpIsCheap@ (below).
+
+There should be no worries about side effects; that's all taken care
+of by data dependencies.
+
+\begin{code}
+{- MOVE:
+primOpOkForSpeculation :: PrimOp -> Bool
+
+-- Int.
+primOpOkForSpeculation IntQuotOp	= False		-- Divide by zero
+primOpOkForSpeculation IntRemOp		= False		-- Divide by zero
+
+-- Integer
+primOpOkForSpeculation IntegerQuotRemOp = False		-- Divide by zero
+primOpOkForSpeculation IntegerDivModOp	= False		-- Divide by zero
+
+-- Float.  ToDo: tan? tanh?
+primOpOkForSpeculation FloatDivOp	= False		-- Divide by zero
+primOpOkForSpeculation FloatLogOp	= False		-- Log of zero
+primOpOkForSpeculation FloatAsinOp	= False		-- Arg out of domain
+primOpOkForSpeculation FloatAcosOp	= False		-- Arg out of domain
+
+-- Double.  ToDo: tan? tanh?
+primOpOkForSpeculation DoubleDivOp	= False		-- Divide by zero
+primOpOkForSpeculation DoubleLogOp	= False		-- Log of zero
+primOpOkForSpeculation DoubleAsinOp	= False		-- Arg out of domain
+primOpOkForSpeculation DoubleAcosOp	= False		-- Arg out of domain
+
+-- CCall
+primOpOkForSpeculation (CCallOp	_ _ _ _ _)= False	-- Could be expensive!
+
+-- errorIO#
+primOpOkForSpeculation ErrorIOPrimOp	= False		-- Could be disastrous!
+
+-- parallel
+primOpOkForSpeculation ParOp		= False	    	-- Could be expensive!
+primOpOkForSpeculation ForkOp	    	= False	    	-- Likewise
+primOpOkForSpeculation SeqOp	    	= False	    	-- Likewise
+
+#ifdef GRAN
+primOpOkForSpeculation ParGlobalOp	= False	    	-- Could be expensive!
+primOpOkForSpeculation ParLocalOp	= False	    	-- Could be expensive!
+#endif {-GRAN-}
+
+-- The default is "yes it's ok for speculation"
+primOpOkForSpeculation other_op		= True
+-}
+\end{code}
+
+@primOpIsCheap@, as used in \tr{SimplUtils.lhs}.  For now (HACK
+WARNING), we just borrow some other predicates for a
+what-should-be-good-enough test.
+\begin{code}
+{-MOVE:
+primOpIsCheap op
+  = primOpOkForSpeculation op && not (primOpCanTriggerGC op)
+-}
+\end{code}
+
+And some primops have side-effects and so, for example, must not be
+duplicated.
+
+\begin{code}
+{- MOVE:
+fragilePrimOp :: PrimOp -> Bool
+
+fragilePrimOp ParOp = True
+fragilePrimOp ForkOp = True
+fragilePrimOp SeqOp = True
+fragilePrimOp MakeStablePtrOp = True
+fragilePrimOp DeRefStablePtrOp = True  -- ??? JSM & ADR
+
+#ifdef GRAN
+fragilePrimOp ParGlobalOp = True
+fragilePrimOp ParLocalOp = True
+fragilePrimOp CopyableOp = trace "fragilePrimOp:CopyableOp" True  -- Possibly not.  ASP
+fragilePrimOp NoFollowOp = trace "fragilePrimOp:NoFollowOp" True  -- Possibly not.  ASP
+#endif {-GRAN-}
+
+fragilePrimOp other = False
+-}
+\end{code}
+
+Primitive operations that perform calls need wrappers to save any live variables
+that are stored in caller-saves registers
+
+\begin{code}
+{- MOVE:
+primOpNeedsWrapper :: PrimOp -> Bool
+
+primOpNeedsWrapper (CCallOp _ _ _ _ _) 	= True
+
+primOpNeedsWrapper NewArrayOp     	= True	-- ToDo: for nativeGen only!(JSM)
+primOpNeedsWrapper (NewByteArrayOp _)  	= True
+
+primOpNeedsWrapper IntegerAddOp		= True
+primOpNeedsWrapper IntegerSubOp		= True
+primOpNeedsWrapper IntegerMulOp		= True
+primOpNeedsWrapper IntegerQuotRemOp	= True
+primOpNeedsWrapper IntegerDivModOp	= True
+primOpNeedsWrapper IntegerNegOp		= True
+primOpNeedsWrapper IntegerCmpOp	    	= True
+primOpNeedsWrapper Integer2IntOp    	= True
+primOpNeedsWrapper Int2IntegerOp	= True
+primOpNeedsWrapper Word2IntegerOp	= True
+primOpNeedsWrapper Addr2IntegerOp	= True
+
+primOpNeedsWrapper FloatExpOp	    	= True
+primOpNeedsWrapper FloatLogOp	    	= True
+primOpNeedsWrapper FloatSqrtOp	    	= True
+primOpNeedsWrapper FloatSinOp	    	= True
+primOpNeedsWrapper FloatCosOp	    	= True
+primOpNeedsWrapper FloatTanOp	    	= True
+primOpNeedsWrapper FloatAsinOp	    	= True
+primOpNeedsWrapper FloatAcosOp	    	= True
+primOpNeedsWrapper FloatAtanOp	    	= True
+primOpNeedsWrapper FloatSinhOp	    	= True
+primOpNeedsWrapper FloatCoshOp	    	= True
+primOpNeedsWrapper FloatTanhOp	    	= True
+primOpNeedsWrapper FloatPowerOp	    	= True
+primOpNeedsWrapper FloatEncodeOp    	= True
+primOpNeedsWrapper FloatDecodeOp	= True
+
+primOpNeedsWrapper DoubleExpOp	    	= True
+primOpNeedsWrapper DoubleLogOp	    	= True
+primOpNeedsWrapper DoubleSqrtOp	    	= True
+primOpNeedsWrapper DoubleSinOp	    	= True
+primOpNeedsWrapper DoubleCosOp	    	= True
+primOpNeedsWrapper DoubleTanOp	    	= True
+primOpNeedsWrapper DoubleAsinOp	    	= True
+primOpNeedsWrapper DoubleAcosOp	    	= True
+primOpNeedsWrapper DoubleAtanOp	    	= True
+primOpNeedsWrapper DoubleSinhOp	    	= True
+primOpNeedsWrapper DoubleCoshOp	    	= True
+primOpNeedsWrapper DoubleTanhOp	    	= True
+primOpNeedsWrapper DoublePowerOp    	= True
+primOpNeedsWrapper DoubleEncodeOp   	= True
+primOpNeedsWrapper DoubleDecodeOp	= True
+
+primOpNeedsWrapper MakeStablePtrOp	= True
+primOpNeedsWrapper DeRefStablePtrOp	= True
+
+primOpNeedsWrapper TakeMVarOp	    	= True
+primOpNeedsWrapper PutMVarOp		= True
+primOpNeedsWrapper ReadIVarOp	    	= True
+
+primOpNeedsWrapper DelayOp	    	= True
+primOpNeedsWrapper WaitOp		= True
+
+primOpNeedsWrapper other_op 	    	= False
+-}
+\end{code}
+
+\begin{code}
+primOp_str op
+  = case (primOpInfo op) of
+      Dyadic str _	       -> str
+      Monadic str _	       -> str
+      Compare str _	       -> str
+      Coerce str _ _	       -> str
+      PrimResult str _ _ _ _ _ -> str
+      AlgResult str _ _ _ _    -> str
+\end{code}
+
+@primOpType@ duplicates some work of @primOpId@, but since we
+grab types pretty often...
+\begin{code}
+primOpType :: PrimOp -> Type
+
+primOpType op
+  = case (primOpInfo op) of
+      Dyadic str ty ->	    dyadic_fun_ty ty
+      Monadic str ty ->	    monadic_fun_ty ty
+      Compare str ty ->	    compare_fun_ty ty
+      Coerce str ty1 ty2 -> mkFunTys [ty1] ty2
+
+      PrimResult str tyvars arg_tys prim_tycon kind res_tys ->
+	mkForAllTys tyvars (glueTyArgs arg_tys (applyTyCon prim_tycon res_tys))
+
+      AlgResult str tyvars arg_tys tycon res_tys ->
+	mkForAllTys tyvars (glueTyArgs arg_tys (applyTyCon tycon res_tys))
+\end{code}
+
+\begin{code}
+data PrimOpResultInfo
+  = ReturnsPrim	    PrimRep
+  | ReturnsAlg	    TyCon
+
+-- ToDo: Deal with specialised PrimOps
+--	 Will need to return specialised tycon and data constructors
+
+getPrimOpResultInfo :: PrimOp -> PrimOpResultInfo
+
+getPrimOpResultInfo op
+  = case (primOpInfo op) of
+      Dyadic  _ ty		 -> ReturnsPrim (primRepFromType ty)
+      Monadic _ ty		 -> ReturnsPrim (primRepFromType ty)
+      Compare _ ty		 -> ReturnsAlg  boolTyCon
+      Coerce  _ _ ty		 -> ReturnsPrim (primRepFromType ty)
+      PrimResult _ _ _ _ kind _	 -> ReturnsPrim kind
+      AlgResult _ _ _ tycon _	 -> ReturnsAlg  tycon
+
+isCompareOp :: PrimOp -> Bool
+
+isCompareOp op
+  = case primOpInfo op of
+      Compare _ _ -> True
+      _	    	  -> False
+\end{code}
+
+Utils:
+\begin{code}
+dyadic_fun_ty  ty = mkFunTys [ty, ty] ty
+monadic_fun_ty ty = mkFunTys [ty] ty
+compare_fun_ty ty = mkFunTys [ty, ty] boolTy
+\end{code}
+
+Output stuff:
+\begin{code}
+pprPrimOp  :: PprStyle -> PrimOp -> Pretty
+showPrimOp :: PprStyle -> PrimOp -> String
+
+showPrimOp sty op
+  = ppShow 1000{-random-} (pprPrimOp sty op)
+
+pprPrimOp sty (CCallOp fun is_casm may_gc arg_tys res_ty)
+  = let
+	before
+	  = if is_casm then
+	       if may_gc then "(_casm_GC_ ``" else "(_casm_ ``"
+	    else
+	       if may_gc then "(_ccall_GC_ " else "(_ccall_ "
+
+	after
+	  = if is_casm then ppStr "''" else ppNil
+
+	pp_tys
+	  = ppBesides [ppStr " { [",
+		ppIntersperse pp'SP{-'-} (map (pprParendType sty) arg_tys),
+		ppRbrack, ppSP, pprParendType sty res_ty, ppStr " })"]
+
+    in
+    ppBesides [ppStr before, ppPStr fun, after, pp_tys]
+
+pprPrimOp sty other_op
+  = let
+	str = primOp_str other_op
+    in
+    if codeStyle sty
+    then identToC str
+    else ppPStr str
+
+instance Outputable PrimOp where
+    ppr sty op = pprPrimOp sty op
+\end{code}
diff --git a/ghc/compiler/prelude/PrimOps.hi b/ghc/compiler/prelude/PrimOps.hi
deleted file mode 100644
index 030fec1de4..0000000000
--- a/ghc/compiler/prelude/PrimOps.hi
+++ /dev/null
@@ -1,44 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface PrimOps where
-import Class(Class)
-import HeapOffs(HeapOffset)
-import Id(Id)
-import Name(Name)
-import NameTypes(FullName, ShortName)
-import Outputable(Outputable)
-import PreludePS(_PackedString)
-import Pretty(PprStyle, PrettyRep)
-import PrimKind(PrimKind)
-import TyCon(TyCon)
-import TyVar(TyVar, TyVarTemplate)
-import UniType(UniType)
-import Unique(Unique)
-data HeapOffset 
-data HeapRequirement   = NoHeapRequired | FixedHeapRequired HeapOffset | VariableHeapRequired
-data Id 
-data Name 
-data PrimKind 
-data PrimOp
-  = CharGtOp | CharGeOp | CharEqOp | CharNeOp | CharLtOp | CharLeOp | IntGtOp | IntGeOp | IntEqOp | IntNeOp | IntLtOp | IntLeOp | WordGtOp | WordGeOp | WordEqOp | WordNeOp | WordLtOp | WordLeOp | AddrGtOp | AddrGeOp | AddrEqOp | AddrNeOp | AddrLtOp | AddrLeOp | FloatGtOp | FloatGeOp | FloatEqOp | FloatNeOp | FloatLtOp | FloatLeOp | DoubleGtOp | DoubleGeOp | DoubleEqOp | DoubleNeOp | DoubleLtOp | DoubleLeOp | OrdOp | ChrOp | IntAddOp | IntSubOp | IntMulOp | IntQuotOp | IntDivOp | IntRemOp | IntNegOp | IntAbsOp | AndOp | OrOp | NotOp | SllOp | SraOp | SrlOp | ISllOp | ISraOp | ISrlOp | Int2WordOp | Word2IntOp | Int2AddrOp | Addr2IntOp | FloatAddOp | FloatSubOp | FloatMulOp | FloatDivOp | FloatNegOp | Float2IntOp | Int2FloatOp | FloatExpOp | FloatLogOp | FloatSqrtOp | FloatSinOp | FloatCosOp | FloatTanOp | FloatAsinOp | FloatAcosOp | FloatAtanOp | FloatSinhOp | FloatCoshOp | FloatTanhOp | FloatPowerOp | DoubleAddOp | DoubleSubOp | DoubleMulOp | DoubleDivOp | DoubleNegOp | Double2IntOp | Int2DoubleOp | Double2FloatOp | Float2DoubleOp | DoubleExpOp | DoubleLogOp | DoubleSqrtOp | DoubleSinOp | DoubleCosOp | DoubleTanOp | DoubleAsinOp | DoubleAcosOp | DoubleAtanOp | DoubleSinhOp | DoubleCoshOp | DoubleTanhOp | DoublePowerOp | IntegerAddOp | IntegerSubOp | IntegerMulOp | IntegerQuotRemOp | IntegerDivModOp | IntegerNegOp | IntegerCmpOp | Integer2IntOp | Int2IntegerOp | Word2IntegerOp | Addr2IntegerOp | FloatEncodeOp | FloatDecodeOp | DoubleEncodeOp | DoubleDecodeOp | NewArrayOp | NewByteArrayOp PrimKind | SameMutableArrayOp | SameMutableByteArrayOp | ReadArrayOp | WriteArrayOp | IndexArrayOp | ReadByteArrayOp PrimKind | WriteByteArrayOp PrimKind | IndexByteArrayOp PrimKind | IndexOffAddrOp PrimKind | UnsafeFreezeArrayOp | UnsafeFreezeByteArrayOp | NewSynchVarOp | TakeMVarOp | PutMVarOp | ReadIVarOp | WriteIVarOp | MakeStablePtrOp | DeRefStablePtrOp | CCallOp _PackedString Bool Bool [UniType] UniType | ErrorIOPrimOp | ReallyUnsafePtrEqualityOp | SeqOp | ParOp | ForkOp | DelayOp | WaitOp
-data PrimOpInfo   = Dyadic _PackedString UniType | Monadic _PackedString UniType | Compare _PackedString UniType | Coerce _PackedString UniType UniType | PrimResult _PackedString [TyVarTemplate] [UniType] TyCon PrimKind [UniType] | AlgResult _PackedString [TyVarTemplate] [UniType] TyCon [UniType]
-data PrimOpResultInfo   = ReturnsPrim PrimKind | ReturnsAlg TyCon
-data TyCon 
-data TyVarTemplate 
-data UniType 
-fragilePrimOp :: PrimOp -> Bool
-getPrimOpResultInfo :: PrimOp -> PrimOpResultInfo
-isCompareOp :: PrimOp -> Bool
-pprPrimOp :: PprStyle -> PrimOp -> Int -> Bool -> PrettyRep
-primOpCanTriggerGC :: PrimOp -> Bool
-primOpHeapReq :: PrimOp -> HeapRequirement
-primOpId :: PrimOp -> Id
-primOpIsCheap :: PrimOp -> Bool
-primOpNameInfo :: PrimOp -> (_PackedString, Name)
-primOpNeedsWrapper :: PrimOp -> Bool
-primOpOkForSpeculation :: PrimOp -> Bool
-showPrimOp :: PprStyle -> PrimOp -> [Char]
-tagOf_PrimOp :: PrimOp -> Int#
-typeOfPrimOp :: PrimOp -> UniType
-instance Eq PrimOp
-instance Outputable PrimOp
-
diff --git a/ghc/compiler/prelude/PrimOps.lhs b/ghc/compiler/prelude/PrimOps.lhs
deleted file mode 100644
index 6aca5a01db..0000000000
--- a/ghc/compiler/prelude/PrimOps.lhs
+++ /dev/null
@@ -1,1663 +0,0 @@
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
-%
-\section[PrimOps]{Primitive operations (machine-level)}
-
-\begin{code}
-#include "HsVersions.h"
-
-module PrimOps (
-	PrimOp(..),
-	tagOf_PrimOp, -- ToDo: rm
-	primOpNameInfo, primOpId,
-	typeOfPrimOp, isCompareOp,
-	primOpCanTriggerGC, primOpNeedsWrapper,
-    	primOpOkForSpeculation, primOpIsCheap,
-	fragilePrimOp,
-
-	PrimOpResultInfo(..),
-	getPrimOpResultInfo,
-
-    	HeapRequirement(..), primOpHeapReq, 
-
-       -- export for the Native Code Generator
---      primOpInfo, not exported
-        PrimOpInfo(..),
-
-	pprPrimOp, showPrimOp,
-
-	-- and to make the interface self-sufficient....
-	PrimKind, HeapOffset, Id, Name, TyCon, UniType, TyVarTemplate
-    ) where
-
-import PrelFuns		-- help stuff for prelude
-import PrimKind		-- most of it
-import TysPrim
-import TysWiredIn
-
-import AbsUniType	-- lots of things
-import CLabelInfo	( identToC )
-import CgCompInfo   	( mIN_MP_INT_SIZE, mP_STRUCT_SIZE )
-import BasicLit		( BasicLit(..) )
-import HeapOffs	    	( addOff, intOff, totHdrSize, HeapOffset )
-import Id		-- lots
-import IdInfo		-- plenty of this, too
-import Maybes		( Maybe(..) )
-import NameTypes	( mkPreludeCoreName, FullName, ShortName )
-import Outputable
-import PlainCore	-- all of it
-import Pretty
-import SMRep	    	( SMRep(..), SMSpecRepKind(..), SMUpdateKind(..) )
-import Unique
-import Util
-#ifdef DPH
-import TyPod
-#endif {- Data Parallel Haskell -}
-\end{code}
-
-%************************************************************************
-%*									*
-\subsection[PrimOps-datatype]{Datatype for @PrimOp@ (an enumeration)}
-%*									*
-%************************************************************************
-
-These are in \tr{state-interface.verb} order.
-
-\begin{code}
-data PrimOp
-    -- dig the FORTRAN/C influence on the names...
-
-    -- comparisons:
-
-    = CharGtOp   | CharGeOp   | CharEqOp   | CharNeOp   | CharLtOp   | CharLeOp
-    | IntGtOp    | IntGeOp    | IntEqOp    | IntNeOp	| IntLtOp    | IntLeOp
-    | WordGtOp   | WordGeOp   | WordEqOp   | WordNeOp	| WordLtOp   | WordLeOp
-    | AddrGtOp   | AddrGeOp   | AddrEqOp   | AddrNeOp	| AddrLtOp   | AddrLeOp
-    | FloatGtOp	 | FloatGeOp  | FloatEqOp  | FloatNeOp	| FloatLtOp  | FloatLeOp
-    | DoubleGtOp | DoubleGeOp | DoubleEqOp | DoubleNeOp | DoubleLtOp | DoubleLeOp
-
-    -- Char#-related ops:
-    | OrdOp | ChrOp
-
-    -- Int#-related ops:
-    -- IntAbsOp unused?? ADR
-    | IntAddOp | IntSubOp | IntMulOp | IntQuotOp
-    | IntDivOp{-UNUSED-} | IntRemOp | IntNegOp | IntAbsOp
-
-    -- Word#-related ops:
-    | AndOp  | OrOp   | NotOp
-    | SllOp  | SraOp  | SrlOp  -- shift {left,right} {arithmetic,logical}
-    | ISllOp | ISraOp | ISrlOp -- equivs on Int#s
-    | Int2WordOp | Word2IntOp -- casts
-
-    -- Addr#-related ops:
-    | Int2AddrOp | Addr2IntOp -- casts
-
-    -- Float#-related ops:
-    | FloatAddOp | FloatSubOp | FloatMulOp | FloatDivOp | FloatNegOp
-    | Float2IntOp | Int2FloatOp
-
-    | FloatExpOp   | FloatLogOp	  | FloatSqrtOp
-    | FloatSinOp   | FloatCosOp	  | FloatTanOp
-    | FloatAsinOp  | FloatAcosOp  | FloatAtanOp
-    | FloatSinhOp  | FloatCoshOp  | FloatTanhOp
-    -- not all machines have these available conveniently:
-    -- | FloatAsinhOp | FloatAcoshOp | FloatAtanhOp
-    | FloatPowerOp -- ** op
-
-    -- Double#-related ops:
-    | DoubleAddOp | DoubleSubOp | DoubleMulOp | DoubleDivOp | DoubleNegOp
-    | Double2IntOp | Int2DoubleOp
-    | Double2FloatOp | Float2DoubleOp
-
-    | DoubleExpOp   | DoubleLogOp   | DoubleSqrtOp
-    | DoubleSinOp   | DoubleCosOp   | DoubleTanOp
-    | DoubleAsinOp  | DoubleAcosOp  | DoubleAtanOp
-    | DoubleSinhOp  | DoubleCoshOp  | DoubleTanhOp
-    -- not all machines have these available conveniently:
-    -- | DoubleAsinhOp | DoubleAcoshOp | DoubleAtanhOp
-    | DoublePowerOp -- ** op
-
-    -- Integer (and related...) ops:
-    -- slightly weird -- to match GMP package.
-    | IntegerAddOp | IntegerSubOp | IntegerMulOp
-    | IntegerQuotRemOp | IntegerDivModOp | IntegerNegOp
-
-    | IntegerCmpOp
-
-    | Integer2IntOp  | Int2IntegerOp
-    | Word2IntegerOp
-    | Addr2IntegerOp -- "Addr" is *always* a literal string
-    -- ?? gcd, etc?
-
-    | FloatEncodeOp  | FloatDecodeOp
-    | DoubleEncodeOp | DoubleDecodeOp
-
-    -- primitive ops for primitive arrays
-
-    | NewArrayOp
-    | NewByteArrayOp PrimKind
-
-    | SameMutableArrayOp
-    | SameMutableByteArrayOp
-
-    | ReadArrayOp | WriteArrayOp | IndexArrayOp -- for arrays of Haskell ptrs
-
-    | ReadByteArrayOp	PrimKind
-    | WriteByteArrayOp	PrimKind
-    | IndexByteArrayOp	PrimKind
-    | IndexOffAddrOp	PrimKind
-	-- PrimKind can be one of {Char,Int,Addr,Float,Double}Kind.
-	-- This is just a cheesy encoding of a bunch of ops.
-	-- Note that MallocPtrKind is not included -- the only way of
-	-- creating a MallocPtr is with a ccall or casm.
-
-    | UnsafeFreezeArrayOp | UnsafeFreezeByteArrayOp
-
-    | NewSynchVarOp -- for MVars and IVars
-    | TakeMVarOp | PutMVarOp
-    | ReadIVarOp | WriteIVarOp
-
-    | MakeStablePtrOp | DeRefStablePtrOp
-\end{code}
-
-A special ``trap-door'' to use in making calls direct to C functions:
-\begin{code}
-    | CCallOp	FAST_STRING	-- An "unboxed" ccall# to this named function
-		Bool		-- True <=> really a "casm"
-		Bool		-- True <=> might invoke Haskell GC
-		[UniType]	-- Unboxed argument; the state-token
-				-- argument will have been put *first*
-		UniType		-- Return type; one of the "StateAnd<blah>#" types
-
-    -- (... to be continued ... )
-\end{code}
-
-The ``type'' of @CCallOp foo [t1, ... tm] r@ is @t1 -> ... tm -> r@.
-(See @primOpInfo@ for details.)
-
-Note: that first arg and part of the result should be the system state
-token (which we carry around to fool over-zealous optimisers) but
-which isn't actually passed.
-
-For example, we represent
-\begin{pseudocode}
-((ccall# foo [StablePtr# a, Int] Float) sp# i#) :: (Float, IoWorld)
-\end{pseudocode}
-by
-\begin{pseudocode}
-CoCase 
-  ( CoPrim
-      (CCallOp "foo" [Universe#, StablePtr# a, Int#] FloatPrimAndUniverse False) 
-       -- :: Universe# -> StablePtr# a -> Int# -> FloatPrimAndUniverse
-      []
-      [w#, sp# i#]
-  )
-  (CoAlgAlts [ ( FloatPrimAndIoWorld, 
-                 [f#, w#], 
-                 CoCon (TupleCon 2) [Float, IoWorld] [F# f#, World w#]
-               ) ]
-             CoNoDefault
-  )
-\end{pseudocode}
-
-Nota Bene: there are some people who find the empty list of types in
-the @CoPrim@ somewhat puzzling and would represent the above by
-\begin{pseudocode}
-CoCase 
-  ( CoPrim
-      (CCallOp "foo" [alpha1, alpha2, alpha3] alpha4 False)
-       -- :: /\ alpha1, alpha2 alpha3, alpha4. 
-       --       alpha1 -> alpha2 -> alpha3 -> alpha4
-      [Universe#, StablePtr# a, Int#, FloatPrimAndIoWorld]
-      [w#, sp# i#]
-  )
-  (CoAlgAlts [ ( FloatPrimAndIoWorld, 
-                 [f#, w#], 
-                 CoCon (TupleCon 2) [Float, IoWorld] [F# f#, World w#]
-               ) ]
-             CoNoDefault
-  )
-\end{pseudocode} 
-
-But, this is a completely different way of using @CCallOp@.  The most
-major changes required if we switch to this are in @primOpInfo@, and
-the desugarer. The major difficulty is in moving the HeapRequirement
-stuff somewhere appropriate.  (The advantage is that we could simplify
-@CCallOp@ and record just the number of arguments with corresponding
-simplifications in reading pragma unfoldings, the simplifier,
-instantiation (etc) of core expressions, ... .  Maybe we should think
-about using it this way?? ADR)
-
-\begin{code}
-    -- (... continued from above ... )
-
-    -- one to support "errorIO" (and, thereby, "error")
-    | ErrorIOPrimOp
-
-    -- Operation to test two closure addresses for equality (yes really!)
-    -- BLAME ALASTAIR REID FOR THIS!  THE REST OF US ARE INNOCENT!
-    | ReallyUnsafePtrEqualityOp
-
-    -- three for parallel stuff
-    | SeqOp
-    | ParOp
-    | ForkOp
-
-    -- two for concurrency
-    | DelayOp
-    | WaitOp
-
-#ifdef GRAN
-    | ParGlobalOp	-- named global par
-    | ParLocalOp	-- named local par
-    | ParAtOp		-- specifies destination of local par
-    | ParAtForNowOp	-- specifies initial destination of global par
-    | CopyableOp	-- marks copyable code
-    | NoFollowOp	-- marks non-followup expression
-#endif {-GRAN-}
-
-#ifdef DPH
--- Shadow all the the above primitive OPs for N dimensioned objects.
-    | PodNPrimOp Int PrimOp
-
--- Primitive conversion functions.
-
-    | Int2PodNOp Int	 | Char2PodNOp Int    | Float2PodNOp Int
-    | Double2PodNOp Int  | String2PodNOp Int
-
-#endif {-Data Parallel Haskell -}
-\end{code}
-
-Deriving Ix is what we really want! ToDo
-(Chk around before deleting...)
-\begin{code}
-tagOf_PrimOp CharGtOp			= (ILIT(1) :: FAST_INT)
-tagOf_PrimOp CharGeOp			= ILIT(  2)
-tagOf_PrimOp CharEqOp			= ILIT(  3)
-tagOf_PrimOp CharNeOp			= ILIT(  4)
-tagOf_PrimOp CharLtOp			= ILIT(  5)
-tagOf_PrimOp CharLeOp			= ILIT(  6)
-tagOf_PrimOp IntGtOp			= ILIT(  7)
-tagOf_PrimOp IntGeOp			= ILIT(  8)
-tagOf_PrimOp IntEqOp			= ILIT(  9)
-tagOf_PrimOp IntNeOp			= ILIT( 10)
-tagOf_PrimOp IntLtOp			= ILIT( 11)
-tagOf_PrimOp IntLeOp			= ILIT( 12)
-tagOf_PrimOp WordGtOp			= ILIT( 13)
-tagOf_PrimOp WordGeOp			= ILIT( 14)
-tagOf_PrimOp WordEqOp			= ILIT( 15)
-tagOf_PrimOp WordNeOp			= ILIT( 16)
-tagOf_PrimOp WordLtOp			= ILIT( 17)
-tagOf_PrimOp WordLeOp			= ILIT( 18)
-tagOf_PrimOp AddrGtOp			= ILIT( 19)
-tagOf_PrimOp AddrGeOp			= ILIT( 20)
-tagOf_PrimOp AddrEqOp			= ILIT( 21)
-tagOf_PrimOp AddrNeOp			= ILIT( 22)
-tagOf_PrimOp AddrLtOp			= ILIT( 23)
-tagOf_PrimOp AddrLeOp			= ILIT( 24)
-tagOf_PrimOp FloatGtOp			= ILIT( 25)
-tagOf_PrimOp FloatGeOp			= ILIT( 26)
-tagOf_PrimOp FloatEqOp			= ILIT( 27)
-tagOf_PrimOp FloatNeOp			= ILIT( 28)
-tagOf_PrimOp FloatLtOp			= ILIT( 29)
-tagOf_PrimOp FloatLeOp			= ILIT( 30)
-tagOf_PrimOp DoubleGtOp			= ILIT( 31)
-tagOf_PrimOp DoubleGeOp			= ILIT( 32)
-tagOf_PrimOp DoubleEqOp			= ILIT( 33)
-tagOf_PrimOp DoubleNeOp			= ILIT( 34)
-tagOf_PrimOp DoubleLtOp			= ILIT( 35)
-tagOf_PrimOp DoubleLeOp			= ILIT( 36)
-tagOf_PrimOp OrdOp			= ILIT( 37)
-tagOf_PrimOp ChrOp			= ILIT( 38)
-tagOf_PrimOp IntAddOp			= ILIT( 39)
-tagOf_PrimOp IntSubOp			= ILIT( 40)
-tagOf_PrimOp IntMulOp			= ILIT( 41)
-tagOf_PrimOp IntQuotOp			= ILIT( 42)
---UNUSED:tagOf_PrimOp IntDivOp			= ILIT( 43)
-tagOf_PrimOp IntRemOp			= ILIT( 44)
-tagOf_PrimOp IntNegOp			= ILIT( 45)
-tagOf_PrimOp IntAbsOp			= ILIT( 46)
-tagOf_PrimOp AndOp			= ILIT( 47)
-tagOf_PrimOp OrOp			= ILIT( 48)
-tagOf_PrimOp NotOp			= ILIT( 49)
-tagOf_PrimOp SllOp			= ILIT( 50)
-tagOf_PrimOp SraOp			= ILIT( 51)
-tagOf_PrimOp SrlOp			= ILIT( 52)
-tagOf_PrimOp ISllOp			= ILIT( 53)
-tagOf_PrimOp ISraOp			= ILIT( 54)
-tagOf_PrimOp ISrlOp			= ILIT( 55)
-tagOf_PrimOp Int2WordOp			= ILIT( 56)
-tagOf_PrimOp Word2IntOp			= ILIT( 57)
-tagOf_PrimOp Int2AddrOp			= ILIT( 58)
-tagOf_PrimOp Addr2IntOp			= ILIT( 59)
-tagOf_PrimOp FloatAddOp			= ILIT( 60)
-tagOf_PrimOp FloatSubOp			= ILIT( 61)
-tagOf_PrimOp FloatMulOp			= ILIT( 62)
-tagOf_PrimOp FloatDivOp			= ILIT( 63)
-tagOf_PrimOp FloatNegOp			= ILIT( 64)
-tagOf_PrimOp Float2IntOp		= ILIT( 65)
-tagOf_PrimOp Int2FloatOp		= ILIT( 66)
-tagOf_PrimOp FloatExpOp			= ILIT( 67)
-tagOf_PrimOp FloatLogOp			= ILIT( 68)
-tagOf_PrimOp FloatSqrtOp		= ILIT( 69)
-tagOf_PrimOp FloatSinOp			= ILIT( 70)
-tagOf_PrimOp FloatCosOp			= ILIT( 71)
-tagOf_PrimOp FloatTanOp			= ILIT( 72)
-tagOf_PrimOp FloatAsinOp		= ILIT( 73)
-tagOf_PrimOp FloatAcosOp		= ILIT( 74)
-tagOf_PrimOp FloatAtanOp		= ILIT( 75)
-tagOf_PrimOp FloatSinhOp		= ILIT( 76)
-tagOf_PrimOp FloatCoshOp		= ILIT( 77)
-tagOf_PrimOp FloatTanhOp		= ILIT( 78)
-tagOf_PrimOp FloatPowerOp		= ILIT( 79)
-tagOf_PrimOp DoubleAddOp		= ILIT( 80)
-tagOf_PrimOp DoubleSubOp		= ILIT( 81)
-tagOf_PrimOp DoubleMulOp		= ILIT( 82)
-tagOf_PrimOp DoubleDivOp		= ILIT( 83)
-tagOf_PrimOp DoubleNegOp		= ILIT( 84)
-tagOf_PrimOp Double2IntOp		= ILIT( 85)
-tagOf_PrimOp Int2DoubleOp		= ILIT( 86)
-tagOf_PrimOp Double2FloatOp		= ILIT( 87)
-tagOf_PrimOp Float2DoubleOp		= ILIT( 88)
-tagOf_PrimOp DoubleExpOp		= ILIT( 89)
-tagOf_PrimOp DoubleLogOp		= ILIT( 90)
-tagOf_PrimOp DoubleSqrtOp		= ILIT( 91)
-tagOf_PrimOp DoubleSinOp		= ILIT( 92)
-tagOf_PrimOp DoubleCosOp		= ILIT( 93)
-tagOf_PrimOp DoubleTanOp		= ILIT( 94)
-tagOf_PrimOp DoubleAsinOp		= ILIT( 95)
-tagOf_PrimOp DoubleAcosOp		= ILIT( 96)
-tagOf_PrimOp DoubleAtanOp		= ILIT( 97)
-tagOf_PrimOp DoubleSinhOp		= ILIT( 98)
-tagOf_PrimOp DoubleCoshOp		= ILIT( 99)
-tagOf_PrimOp DoubleTanhOp		= ILIT(100)
-tagOf_PrimOp DoublePowerOp		= ILIT(101)
-tagOf_PrimOp IntegerAddOp		= ILIT(102)
-tagOf_PrimOp IntegerSubOp		= ILIT(103)
-tagOf_PrimOp IntegerMulOp		= ILIT(104)
-tagOf_PrimOp IntegerQuotRemOp		= ILIT(105)
-tagOf_PrimOp IntegerDivModOp		= ILIT(106)
-tagOf_PrimOp IntegerNegOp		= ILIT(107)
-tagOf_PrimOp IntegerCmpOp		= ILIT(108)
-tagOf_PrimOp Integer2IntOp		= ILIT(109)
-tagOf_PrimOp Int2IntegerOp		= ILIT(110)
-tagOf_PrimOp Word2IntegerOp		= ILIT(111)
-tagOf_PrimOp Addr2IntegerOp		= ILIT(112)
-tagOf_PrimOp FloatEncodeOp		= ILIT(113)
-tagOf_PrimOp FloatDecodeOp		= ILIT(114)
-tagOf_PrimOp DoubleEncodeOp		= ILIT(115)
-tagOf_PrimOp DoubleDecodeOp		= ILIT(116)
-tagOf_PrimOp NewArrayOp			= ILIT(117)
-tagOf_PrimOp (NewByteArrayOp CharKind)	= ILIT(118)
-tagOf_PrimOp (NewByteArrayOp IntKind)	= ILIT(119)
-tagOf_PrimOp (NewByteArrayOp AddrKind)	= ILIT(120)
-tagOf_PrimOp (NewByteArrayOp FloatKind)	= ILIT(121)
-tagOf_PrimOp (NewByteArrayOp DoubleKind)= ILIT(122)
-tagOf_PrimOp SameMutableArrayOp		= ILIT(123)
-tagOf_PrimOp SameMutableByteArrayOp	= ILIT(124)
-tagOf_PrimOp ReadArrayOp		= ILIT(125)
-tagOf_PrimOp WriteArrayOp		= ILIT(126)
-tagOf_PrimOp IndexArrayOp		= ILIT(127)
-tagOf_PrimOp (ReadByteArrayOp CharKind)	    = ILIT(128)
-tagOf_PrimOp (ReadByteArrayOp IntKind)	    = ILIT(129)
-tagOf_PrimOp (ReadByteArrayOp AddrKind)	    = ILIT(130)
-tagOf_PrimOp (ReadByteArrayOp FloatKind)    = ILIT(131)
-tagOf_PrimOp (ReadByteArrayOp DoubleKind)   = ILIT(132)
-tagOf_PrimOp (WriteByteArrayOp CharKind)    = ILIT(133)
-tagOf_PrimOp (WriteByteArrayOp IntKind)	    = ILIT(134)
-tagOf_PrimOp (WriteByteArrayOp AddrKind)    = ILIT(135)
-tagOf_PrimOp (WriteByteArrayOp FloatKind)   = ILIT(136)
-tagOf_PrimOp (WriteByteArrayOp DoubleKind)  = ILIT(137)
-tagOf_PrimOp (IndexByteArrayOp CharKind)    = ILIT(138)
-tagOf_PrimOp (IndexByteArrayOp IntKind)	    = ILIT(139)
-tagOf_PrimOp (IndexByteArrayOp AddrKind)    = ILIT(140)
-tagOf_PrimOp (IndexByteArrayOp FloatKind)   = ILIT(141)
-tagOf_PrimOp (IndexByteArrayOp DoubleKind)  = ILIT(142)
-tagOf_PrimOp (IndexOffAddrOp CharKind)	    = ILIT(143)
-tagOf_PrimOp (IndexOffAddrOp IntKind)	    = ILIT(144)
-tagOf_PrimOp (IndexOffAddrOp AddrKind)	    = ILIT(145)
-tagOf_PrimOp (IndexOffAddrOp FloatKind)	    = ILIT(146)
-tagOf_PrimOp (IndexOffAddrOp DoubleKind)    = ILIT(147)
-tagOf_PrimOp UnsafeFreezeArrayOp	    = ILIT(148)
-tagOf_PrimOp UnsafeFreezeByteArrayOp	    = ILIT(149)
-tagOf_PrimOp NewSynchVarOp		    = ILIT(150)
-tagOf_PrimOp TakeMVarOp		    	    = ILIT(151)
-tagOf_PrimOp PutMVarOp		    	    = ILIT(152)
-tagOf_PrimOp ReadIVarOp		    	    = ILIT(153)
-tagOf_PrimOp WriteIVarOp		    = ILIT(154)
-tagOf_PrimOp MakeStablePtrOp		    = ILIT(155)
-tagOf_PrimOp DeRefStablePtrOp		    = ILIT(156)
-tagOf_PrimOp (CCallOp _ _ _ _ _)	    = ILIT(157)
-tagOf_PrimOp ErrorIOPrimOp		    = ILIT(158)
-tagOf_PrimOp ReallyUnsafePtrEqualityOp	    = ILIT(159)
-tagOf_PrimOp SeqOp			    = ILIT(160)
-tagOf_PrimOp ParOp			    = ILIT(161)
-tagOf_PrimOp ForkOp			    = ILIT(162)
-tagOf_PrimOp DelayOp			    = ILIT(163)
-tagOf_PrimOp WaitOp			    = ILIT(164)
-
-#ifdef GRAN
-tagOf_PrimOp ParGlobalOp		    = ILIT(165)
-tagOf_PrimOp ParLocalOp			    = ILIT(166)
-tagOf_PrimOp ParAtOp			    = ILIT(167)
-tagOf_PrimOp ParAtForNowOp		    = ILIT(168)
-tagOf_PrimOp CopyableOp			    = ILIT(169)
-tagOf_PrimOp NoFollowOp			    = ILIT(170)
-#endif {-GRAN-}
-
-#ifdef DPH
-tagOf_PrimOp (PodNPrimOp _ _)		= panic "ToDo:DPH:tagOf_PrimOp"
-tagOf_PrimOp (Int2PodNOp _)		= panic "ToDo:DPH:tagOf_PrimOp"
-tagOf_PrimOp (Char2PodNOp _)		= panic "ToDo:DPH:tagOf_PrimOp"
-tagOf_PrimOp (Float2PodNOp  _)		= panic "ToDo:DPH:tagOf_PrimOp"
-tagOf_PrimOp (Double2PodNOp _)		= panic "ToDo:DPH:tagOf_PrimOp"
-tagOf_PrimOp (String2PodNOp _)		= panic "ToDo:DPH:tagOf_PrimOp"
-#endif {-Data Parallel Haskell -}
-
--- avoid BUG
-tagOf_PrimOp _ = case (panic "tagOf_PrimOp: pattern-match") of { o ->
-		 tagOf_PrimOp o
-		 }
-
-instance Eq PrimOp where
-    op == op2 = tagOf_PrimOp op _EQ_ tagOf_PrimOp op2
-\end{code}
-
-%************************************************************************
-%*									*
-\subsection[PrimOps-info]{The essential info about each @PrimOp@}
-%*									*
-%************************************************************************
-
-The @String@ in the @PrimOpInfos@ is the ``base name'' by which the user may
-refer to the primitive operation.  The conventional \tr{#}-for-
-unboxed ops is added on later.
-
-The reason for the funny characters in the names is so we do not
-interfere with the programmer's Haskell name spaces.
-
-We use @PrimKinds@ for the ``type'' information, because they're
-(slightly) more convenient to use than @TyCons@.
-\begin{code}
-data PrimOpInfo
-  = Dyadic	FAST_STRING	-- string :: T -> T -> T
-		UniType
-  | Monadic	FAST_STRING	-- string :: T -> T
-		UniType
-  | Compare	FAST_STRING	-- string :: T -> T -> Bool
-		UniType
-  | Coerce	FAST_STRING	-- string :: T1 -> T2
-		UniType
-		UniType
-
-  | PrimResult	FAST_STRING
-		[TyVarTemplate] [UniType] TyCon PrimKind [UniType]
-		-- "PrimResult tvs [t1,..,tn] D# kind [s1,..,sm]"
-		-- has type Forall tvs. t1 -> ... -> tn -> (D# s1 ... sm)
-		-- D# is a primitive type constructor.
-		-- (the kind is the same info as D#, in another convenient form)
-
-  | AlgResult	FAST_STRING
-		[TyVarTemplate] [UniType] TyCon [UniType]
-		-- "AlgResult tvs [t1,..,tn] T [s1,..,sm]"
-		-- has type Forall tvs. t1 -> ... -> tn -> (T s1 ... sm)
-
--- ToDo: Specialised calls to PrimOps are prohibited but may be desirable
-
-#ifdef DPH
-  | PodNInfo	Int
-		PrimOpInfo
-#endif {- Data Parallel Haskell -}
-\end{code}
-
-Utility bits:
-\begin{code}
-one_Integer_ty = [intPrimTy, intPrimTy, byteArrayPrimTy]
-two_Integer_tys
-  = [intPrimTy, intPrimTy, byteArrayPrimTy, -- first Integer pieces
-     intPrimTy, intPrimTy, byteArrayPrimTy] -- second '' pieces
-an_Integer_and_Int_tys
-  = [intPrimTy, intPrimTy, byteArrayPrimTy, -- Integer
-     intPrimTy]
-
-integerMonadic name = AlgResult name [] one_Integer_ty integerTyCon []
-
-integerDyadic name = AlgResult name [] two_Integer_tys integerTyCon []
-
-integerDyadic2Results name = AlgResult name [] two_Integer_tys return2GMPsTyCon []
-
-integerCompare name = PrimResult name [] two_Integer_tys intPrimTyCon IntKind []
-\end{code}
-
-@primOpInfo@ gives all essential information (from which everything
-else, notably a type, can be constructed) for each @PrimOp@.
-
-\begin{code}
-primOpInfo :: PrimOp -> PrimOpInfo
-\end{code}
-
-There's plenty of this stuff!
-
-%************************************************************************
-%*									*
-\subsubsection[PrimOps-comparison]{PrimOpInfo basic comparison ops}
-%*									*
-%************************************************************************
-
-\begin{code}
-primOpInfo CharGtOp   = Compare SLIT("gtChar#")   charPrimTy
-primOpInfo CharGeOp   = Compare SLIT("geChar#")   charPrimTy
-primOpInfo CharEqOp   = Compare SLIT("eqChar#")   charPrimTy
-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 WordGtOp   = Compare SLIT("gtWord#")   wordPrimTy
-primOpInfo WordGeOp   = Compare SLIT("geWord#")   wordPrimTy
-primOpInfo WordEqOp   = Compare SLIT("eqWord#")   wordPrimTy
-primOpInfo WordNeOp   = Compare SLIT("neWord#")   wordPrimTy
-primOpInfo WordLtOp   = Compare SLIT("ltWord#")   wordPrimTy
-primOpInfo WordLeOp   = Compare SLIT("leWord#")   wordPrimTy
-		      	       		   
-primOpInfo AddrGtOp   = Compare SLIT("gtAddr#")   addrPrimTy
-primOpInfo AddrGeOp   = Compare SLIT("geAddr#")   addrPrimTy
-primOpInfo AddrEqOp   = Compare SLIT("eqAddr#")   addrPrimTy
-primOpInfo AddrNeOp   = Compare SLIT("neAddr#")   addrPrimTy
-primOpInfo AddrLtOp   = Compare SLIT("ltAddr#")   addrPrimTy
-primOpInfo AddrLeOp   = Compare SLIT("leAddr#")   addrPrimTy
-		      	       		   
-primOpInfo FloatGtOp  = Compare SLIT("gtFloat#")  floatPrimTy
-primOpInfo FloatGeOp  = Compare SLIT("geFloat#")  floatPrimTy
-primOpInfo FloatEqOp  = Compare SLIT("eqFloat#")  floatPrimTy
-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
-\end{code}
-
-%************************************************************************
-%*									*
-\subsubsection[PrimOps-Char]{PrimOpInfo for @Char#@s}
-%*									*
-%************************************************************************
-
-\begin{code}
-primOpInfo OrdOp = Coerce SLIT("ord#") charPrimTy intPrimTy
-primOpInfo ChrOp = Coerce SLIT("chr#") intPrimTy charPrimTy
-\end{code}
-
-%************************************************************************
-%*									*
-\subsubsection[PrimOps-Int]{PrimOpInfo for @Int#@s}
-%*									*
-%************************************************************************
-
-\begin{code}
-primOpInfo IntAddOp  = Dyadic SLIT("plusInt#")	 intPrimTy
-primOpInfo IntSubOp  = Dyadic SLIT("minusInt#") intPrimTy
-primOpInfo IntMulOp  = Dyadic SLIT("timesInt#") intPrimTy
-primOpInfo IntQuotOp = Dyadic SLIT("quotInt#")	 intPrimTy
---UNUSED:primOpInfo IntDivOp  = Dyadic SLIT("divInt#")	 intPrimTy
-primOpInfo IntRemOp  = Dyadic SLIT("remInt#")	 intPrimTy
-
-primOpInfo IntNegOp  = Monadic SLIT("negateInt#") intPrimTy
-\end{code}
-
-%************************************************************************
-%*									*
-\subsubsection[PrimOps-Word]{PrimOpInfo for @Word#@s}
-%*									*
-%************************************************************************
-
-A @Word#@ is an unsigned @Int#@.
-
-\begin{code}
-primOpInfo AndOp    = Dyadic  SLIT("and#")	wordPrimTy
-primOpInfo OrOp	    = Dyadic  SLIT("or#")	wordPrimTy
-primOpInfo NotOp    = Monadic SLIT("not#")	wordPrimTy
-
-primOpInfo SllOp
-  = PrimResult SLIT("shiftL#")  [] [wordPrimTy, intPrimTy] wordPrimTyCon WordKind []
-primOpInfo SraOp
-  = PrimResult SLIT("shiftRA#") [] [wordPrimTy, intPrimTy] wordPrimTyCon WordKind []
-primOpInfo SrlOp
-  = PrimResult SLIT("shiftRL#") [] [wordPrimTy, intPrimTy] wordPrimTyCon WordKind []
-
-primOpInfo ISllOp
-  = PrimResult SLIT("iShiftL#")  [] [intPrimTy, intPrimTy] intPrimTyCon IntKind []
-primOpInfo ISraOp
-  = PrimResult SLIT("iShiftRA#") [] [intPrimTy, intPrimTy] intPrimTyCon IntKind []
-primOpInfo ISrlOp
-  = PrimResult SLIT("iShiftRL#") [] [intPrimTy, intPrimTy] intPrimTyCon IntKind []
-
-primOpInfo Int2WordOp = Coerce SLIT("int2Word#") intPrimTy wordPrimTy
-primOpInfo Word2IntOp = Coerce SLIT("word2Int#") wordPrimTy intPrimTy
-\end{code}
-
-%************************************************************************
-%*									*
-\subsubsection[PrimOps-Addr]{PrimOpInfo for @Addr#@s}
-%*									*
-%************************************************************************
-
-\begin{code}
-primOpInfo Int2AddrOp = Coerce SLIT("int2Addr#") intPrimTy addrPrimTy
-primOpInfo Addr2IntOp = Coerce SLIT("addr2Int#") addrPrimTy intPrimTy
-\end{code}
-
-%************************************************************************
-%*									*
-\subsubsection[PrimOps-Float]{PrimOpInfo for @Float#@s}
-%*									*
-%************************************************************************
-
-@encodeFloat#@ and @decodeFloat#@ are given w/ Integer-stuff (it's
-similar).
-
-\begin{code}
-primOpInfo FloatAddOp	= Dyadic    SLIT("plusFloat#")	   floatPrimTy
-primOpInfo FloatSubOp	= Dyadic    SLIT("minusFloat#")   floatPrimTy
-primOpInfo FloatMulOp	= Dyadic    SLIT("timesFloat#")   floatPrimTy
-primOpInfo FloatDivOp	= Dyadic    SLIT("divideFloat#")  floatPrimTy
-primOpInfo FloatNegOp	= Monadic   SLIT("negateFloat#")  floatPrimTy
-
-primOpInfo Float2IntOp	= Coerce SLIT("float2Int#") floatPrimTy intPrimTy
-primOpInfo Int2FloatOp	= Coerce SLIT("int2Float#") intPrimTy floatPrimTy
-
-primOpInfo FloatExpOp	= Monadic   SLIT("expFloat#")	   floatPrimTy
-primOpInfo FloatLogOp	= Monadic   SLIT("logFloat#")	   floatPrimTy
-primOpInfo FloatSqrtOp	= Monadic   SLIT("sqrtFloat#")	   floatPrimTy
-primOpInfo FloatSinOp	= Monadic   SLIT("sinFloat#")	   floatPrimTy
-primOpInfo FloatCosOp	= Monadic   SLIT("cosFloat#")	   floatPrimTy
-primOpInfo FloatTanOp	= Monadic   SLIT("tanFloat#")	   floatPrimTy
-primOpInfo FloatAsinOp	= Monadic   SLIT("asinFloat#")	   floatPrimTy
-primOpInfo FloatAcosOp	= Monadic   SLIT("acosFloat#")	   floatPrimTy
-primOpInfo FloatAtanOp	= Monadic   SLIT("atanFloat#")	   floatPrimTy
-primOpInfo FloatSinhOp	= Monadic   SLIT("sinhFloat#")	   floatPrimTy
-primOpInfo FloatCoshOp	= Monadic   SLIT("coshFloat#")	   floatPrimTy
-primOpInfo FloatTanhOp	= Monadic   SLIT("tanhFloat#")	   floatPrimTy
-primOpInfo FloatPowerOp	= Dyadic    SLIT("powerFloat#")   floatPrimTy
-\end{code}
-
-%************************************************************************
-%*									*
-\subsubsection[PrimOps-Double]{PrimOpInfo for @Double#@s}
-%*									*
-%************************************************************************
-
-@encodeDouble#@ and @decodeDouble#@ are given w/ Integer-stuff (it's
-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 DoubleNegOp	= Monadic   SLIT("negateDouble#") doublePrimTy
-
-primOpInfo Double2IntOp	    = Coerce SLIT("double2Int#")   doublePrimTy intPrimTy
-primOpInfo Int2DoubleOp	    = Coerce SLIT("int2Double#")   intPrimTy doublePrimTy
-
-primOpInfo Double2FloatOp   = Coerce SLIT("double2Float#") doublePrimTy floatPrimTy
-primOpInfo Float2DoubleOp   = Coerce SLIT("float2Double#") floatPrimTy doublePrimTy
-
-primOpInfo DoubleExpOp	= Monadic   SLIT("expDouble#")	   doublePrimTy
-primOpInfo DoubleLogOp	= Monadic   SLIT("logDouble#")	   doublePrimTy
-primOpInfo DoubleSqrtOp	= Monadic   SLIT("sqrtDouble#")   doublePrimTy
-primOpInfo DoubleSinOp	= Monadic   SLIT("sinDouble#")	   doublePrimTy
-primOpInfo DoubleCosOp	= Monadic   SLIT("cosDouble#")	   doublePrimTy
-primOpInfo DoubleTanOp	= Monadic   SLIT("tanDouble#")	   doublePrimTy
-primOpInfo DoubleAsinOp	= Monadic   SLIT("asinDouble#")   doublePrimTy
-primOpInfo DoubleAcosOp	= Monadic   SLIT("acosDouble#")   doublePrimTy
-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
-\end{code}
-
-%************************************************************************
-%*									*
-\subsubsection[PrimOps-Integer]{PrimOpInfo for @Integer@ (and related!)}
-%*									*
-%************************************************************************
-
-\begin{code}
-primOpInfo IntegerNegOp	= integerMonadic SLIT("negateInteger#")
-
-primOpInfo IntegerAddOp	= integerDyadic SLIT("plusInteger#")
-primOpInfo IntegerSubOp	= integerDyadic SLIT("minusInteger#")
-primOpInfo IntegerMulOp	= integerDyadic SLIT("timesInteger#")
-
-primOpInfo IntegerCmpOp	= integerCompare SLIT("cmpInteger#")
-
-primOpInfo IntegerQuotRemOp = integerDyadic2Results SLIT("quotRemInteger#")
-primOpInfo IntegerDivModOp  = integerDyadic2Results SLIT("divModInteger#")
-
-primOpInfo Integer2IntOp
-  = PrimResult SLIT("integer2Int#") [] one_Integer_ty intPrimTyCon IntKind []
-
-primOpInfo Int2IntegerOp
-  = AlgResult SLIT("int2Integer#") [] [intPrimTy] integerTyCon []
-
-primOpInfo Word2IntegerOp
-  = AlgResult SLIT("word2Integer#") [] [wordPrimTy] integerTyCon []
-
-primOpInfo Addr2IntegerOp
-  = AlgResult SLIT("addr2Integer#") [] [addrPrimTy] integerTyCon []
-\end{code}
-
-Encoding and decoding of floating-point numbers is sorta
-Integer-related.
-
-\begin{code}
-primOpInfo FloatEncodeOp
-  = PrimResult SLIT("encodeFloat#") [] an_Integer_and_Int_tys
-	 floatPrimTyCon FloatKind []
-
-primOpInfo DoubleEncodeOp
-  = PrimResult SLIT("encodeDouble#") [] an_Integer_and_Int_tys
-	doublePrimTyCon DoubleKind []
-
-primOpInfo FloatDecodeOp
-  = AlgResult SLIT("decodeFloat#") [] [floatPrimTy] returnIntAndGMPTyCon []
-
-primOpInfo DoubleDecodeOp
-  = AlgResult SLIT("decodeDouble#") [] [doublePrimTy] returnIntAndGMPTyCon []
-\end{code}
-
-%************************************************************************
-%*									*
-\subsubsection[PrimOps-Arrays]{PrimOpInfo for primitive arrays}
-%*									*
-%************************************************************************
-
-\begin{code}
-primOpInfo NewArrayOp
-  = let {
-	elt = alpha; elt_tv = alpha_tv; s = beta; s_tv = beta_tv
-    } in
-    AlgResult SLIT("newArray#") [s_tv, elt_tv] [intPrimTy, elt, mkStatePrimTy s]
-				stateAndMutableArrayPrimTyCon [s, elt]
-
-primOpInfo (NewByteArrayOp kind)
-  = let
-	s = alpha; s_tv = alpha_tv
-
-	(str, _, prim_tycon) = getKindInfo kind
-
-	op_str	       = _PK_ ("new" ++ str ++ "Array#")
-    in
-    AlgResult op_str [s_tv] 
-        [intPrimTy, mkStatePrimTy s]
-	stateAndMutableByteArrayPrimTyCon [s]
-
----------------------------------------------------------------------------
-
-primOpInfo SameMutableArrayOp
-  = let {
-	elt = alpha; elt_tv = alpha_tv; s = beta; s_tv = beta_tv;
-	mut_arr_ty = mkMutableArrayPrimTy s elt
-    } in
-    AlgResult SLIT("sameMutableArray#") [s_tv, elt_tv] [mut_arr_ty, mut_arr_ty]
-				   boolTyCon []
-
-primOpInfo SameMutableByteArrayOp
-  = let {
-	s = alpha; s_tv = alpha_tv;
-	mut_arr_ty = mkMutableByteArrayPrimTy s
-    } in
-    AlgResult SLIT("sameMutableByteArray#") [s_tv] [mut_arr_ty, mut_arr_ty]
-				   boolTyCon []
-
----------------------------------------------------------------------------
--- Primitive arrays of Haskell pointers:
-
-primOpInfo ReadArrayOp
-  = let {
-	elt = alpha; elt_tv = alpha_tv; s = beta; s_tv = beta_tv
-    } in
-    AlgResult SLIT("readArray#") [s_tv, elt_tv]
-	[mkMutableArrayPrimTy s elt, intPrimTy, mkStatePrimTy s]
-	stateAndPtrPrimTyCon [s, elt]
-
-
-primOpInfo WriteArrayOp
-  = let {
-	elt = alpha; elt_tv = alpha_tv; s = beta; s_tv = beta_tv
-    } in
-    PrimResult SLIT("writeArray#") [s_tv, elt_tv]
-	[mkMutableArrayPrimTy s elt, intPrimTy, elt, mkStatePrimTy s]
-	statePrimTyCon VoidKind [s]
-
-primOpInfo IndexArrayOp
-  = let { elt = alpha; elt_tv = alpha_tv } in
-    AlgResult SLIT("indexArray#") [elt_tv] [mkArrayPrimTy elt, intPrimTy]
-				   liftTyCon [elt]
-
----------------------------------------------------------------------------
--- Primitive arrays full of unboxed bytes:
-
-primOpInfo (ReadByteArrayOp kind)
-  = let
-	s = alpha; s_tv = alpha_tv
-
-	(str, _, prim_tycon) = getKindInfo kind
-
-	op_str	       = _PK_ ("read" ++ str ++ "Array#")
-	relevant_tycon = assoc "primOpInfo" tbl kind
-    in
-    AlgResult op_str [s_tv]
-	[mkMutableByteArrayPrimTy s, intPrimTy, mkStatePrimTy s]
-	relevant_tycon [s]
-  where
-    tbl = [ (CharKind,	 stateAndCharPrimTyCon),
-	    (IntKind,	 stateAndIntPrimTyCon),
-	    (AddrKind,	 stateAndAddrPrimTyCon),
-	    (FloatKind,	 stateAndFloatPrimTyCon),
-	    (DoubleKind, stateAndDoublePrimTyCon) ]
-
-  -- How come there's no Word byte arrays? ADR
-
-primOpInfo (WriteByteArrayOp kind)
-  = let
-	s = alpha; s_tv = alpha_tv
-
-	(str, prim_ty, _) = getKindInfo kind
-	op_str = _PK_ ("write" ++ str ++ "Array#")
-    in
-    -- NB: *Prim*Result --
-    PrimResult op_str [s_tv]
-	[mkMutableByteArrayPrimTy s, intPrimTy, prim_ty, mkStatePrimTy s]
-	statePrimTyCon VoidKind [s]
-
-primOpInfo (IndexByteArrayOp kind)
-  = let
-	(str, _, prim_tycon) = getKindInfo kind
-	op_str = _PK_ ("index" ++ str ++ "Array#")
-    in
-    -- NB: *Prim*Result --
-    PrimResult op_str [] [byteArrayPrimTy, intPrimTy] prim_tycon kind []
-
-primOpInfo (IndexOffAddrOp kind)
-  = let
-	(str, _, prim_tycon) = getKindInfo kind
-	op_str = _PK_ ("index" ++ str ++ "OffAddr#")
-    in
-    PrimResult op_str [] [addrPrimTy, intPrimTy] prim_tycon kind []
-
----------------------------------------------------------------------------
-primOpInfo UnsafeFreezeArrayOp
-  = let {
-	elt = alpha; elt_tv = alpha_tv; s = beta; s_tv = beta_tv
-    } in
-    AlgResult SLIT("unsafeFreezeArray#") [s_tv, elt_tv]
-	[mkMutableArrayPrimTy s elt, mkStatePrimTy s]
-	stateAndArrayPrimTyCon [s, elt]
-
-primOpInfo UnsafeFreezeByteArrayOp
-  = let { s = alpha; s_tv = alpha_tv } in
-    AlgResult SLIT("unsafeFreezeByteArray#") [s_tv]
-	[mkMutableByteArrayPrimTy s, mkStatePrimTy s]
-	stateAndByteArrayPrimTyCon [s]
-\end{code}
-
-%************************************************************************
-%*									*
-\subsubsection[PrimOps-SynchVars]{PrimOpInfo for synchronizing Variables}
-%*									*
-%************************************************************************
-
-\begin{code}
-primOpInfo NewSynchVarOp
-  = let {
-	elt = alpha; elt_tv = alpha_tv; s = beta; s_tv = beta_tv
-    } in
-    AlgResult SLIT("newSynchVar#") [s_tv, elt_tv] [mkStatePrimTy s]
-				stateAndSynchVarPrimTyCon [s, elt]
-
-primOpInfo TakeMVarOp
-  = let {
-	elt = alpha; elt_tv = alpha_tv; s = beta; s_tv = beta_tv
-    } in
-    AlgResult SLIT("takeMVar#") [s_tv, elt_tv]
-	[mkSynchVarPrimTy s elt, mkStatePrimTy s]
-	stateAndPtrPrimTyCon [s, elt]
-
-primOpInfo PutMVarOp
-  = let {
-	elt = alpha; elt_tv = alpha_tv; s = beta; s_tv = beta_tv
-    } in
-    AlgResult SLIT("putMVar#") [s_tv, elt_tv]
-	[mkSynchVarPrimTy s elt, elt, mkStatePrimTy s]
-	statePrimTyCon [s]
-
-primOpInfo ReadIVarOp
-  = let {
-	elt = alpha; elt_tv = alpha_tv; s = beta; s_tv = beta_tv
-    } in
-    AlgResult SLIT("readIVar#") [s_tv, elt_tv]
-	[mkSynchVarPrimTy s elt, mkStatePrimTy s]
-	stateAndPtrPrimTyCon [s, elt]
-
-primOpInfo WriteIVarOp
-  = let {
-	elt = alpha; elt_tv = alpha_tv; s = beta; s_tv = beta_tv
-    } in
-    AlgResult SLIT("writeIVar#") [s_tv, elt_tv]
-	[mkSynchVarPrimTy s elt, elt, mkStatePrimTy s]
-	statePrimTyCon [s]
-
-\end{code}
-
-%************************************************************************
-%*									*
-\subsubsection[PrimOps-Wait]{PrimOpInfo for delay/wait operations}
-%*									*
-%************************************************************************
-
-\begin{code}
-
-primOpInfo DelayOp
-  = let {
-	s = alpha; s_tv = alpha_tv
-    } in
-    PrimResult SLIT("delay#") [s_tv]
-	[intPrimTy, mkStatePrimTy s]
-	statePrimTyCon VoidKind [s]
-
-primOpInfo WaitOp
-  = let {
-	s = alpha; s_tv = alpha_tv
-    } in
-    PrimResult SLIT("wait#") [s_tv]
-	[intPrimTy, mkStatePrimTy s]
-	statePrimTyCon VoidKind [s]
-
-\end{code}
-
-
-%************************************************************************
-%*									*
-\subsubsection[PrimOps-stable-pointers]{PrimOpInfo for ``stable pointers''}
-%*									*
-%************************************************************************
-
-A {\em stable pointer} is an index into a table of pointers into the
-heap.  Since the garbage collector is told about stable pointers, it
-is safe to pass a stable pointer to external systems such as C
-routines.
-
-Here's what the operations and types are supposed to be (from
-state-interface document).
-
-\begin{verbatim}
-makeStablePtr#  :: a -> State# _RealWorld -> StateAndStablePtr# _RealWorld a
-freeStablePtr#  :: StablePtr# a -> State# _RealWorld -> State# _RealWorld
-deRefStablePtr# :: StablePtr# a -> State# _RealWorld -> StateAndPtr _RealWorld a
-\end{verbatim}
-
-It may seem a bit surprising that @makeStablePtr#@ is a @PrimIO@
-operation since it doesn't (directly) involve IO operations.  The
-reason is that if some optimisation pass decided to duplicate calls to
-@makeStablePtr#@ and we only pass one of the stable pointers over, a
-massive space leak can result.  Putting it into the PrimIO monad
-prevents this.  (Another reason for putting them in a monad is to
-ensure correct sequencing wrt the side-effecting @freeStablePtr#@
-operation.)
-
-Note that we can implement @freeStablePtr#@ using @_ccall_@ (and,
-besides, it's not likely to be used from Haskell) so it's not a
-primop.
-
-Question: Why @_RealWorld@ - won't any instance of @_ST@ do the job? [ADR]
-
-\begin{code}
-primOpInfo MakeStablePtrOp
-  = AlgResult SLIT("makeStablePtr#") [alpha_tv] 
-	[alpha, realWorldStatePrimTy] 
-	stateAndStablePtrPrimTyCon [realWorldTy, alpha]
-
-primOpInfo DeRefStablePtrOp
-  = AlgResult SLIT("deRefStablePtr#") [alpha_tv] 
-	[mkStablePtrPrimTy alpha, realWorldStatePrimTy]
-	stateAndPtrPrimTyCon [realWorldTy, alpha]
-\end{code}
-
-%************************************************************************
-%*									*
-\subsubsection[PrimOps-unsafePointerEquality]{PrimOpInfo for Pointer Equality}
-%*									*
-%************************************************************************
-
-[Alastair Reid is to blame for this!]
-
-These days, (Glasgow) Haskell seems to have a bit of everything from
-other languages: strict operations, mutable variables, sequencing,
-pointers, etc.  About the only thing left is LISP's ability to test
-for pointer equality.  So, let's add it in!
-
-\begin{verbatim}
-reallyUnsafePtrEquality :: a -> a -> Int#
-\end{verbatim}
-
-which tests any two closures (of the same type) to see if they're the
-same.  (Returns $0$ for @False@, $\neq 0$ for @True@ - to avoid
-difficulties of trying to box up the result.)
-
-NB This is {\em really unsafe\/} because even something as trivial as
-a garbage collection might change the answer by removing indirections.
-Still, no-one's forcing you to use it.  If you're worried about little
-things like loss of referential transparency, you might like to wrap
-it all up in a monad-like thing as John O'Donnell and John Hughes did
-for non-determinism (1989 (Fraserburgh) Glasgow FP Workshop
-Proceedings?)
-
-I'm thinking of using it to speed up a critical equality test in some
-graphics stuff in a context where the possibility of saying that
-denotationally equal things aren't isn't a problem (as long as it
-doesn't happen too often.)  ADR
-
-To Will: Jim said this was already in, but I can't see it so I'm
-adding it.  Up to you whether you add it.  (Note that this could have
-been readily implemented using a @veryDangerousCCall@ before they were
-removed...)
-
-\begin{code}
-primOpInfo ReallyUnsafePtrEqualityOp
-  = PrimResult SLIT("reallyUnsafePtrEquality#") [alpha_tv] 
-	[alpha, alpha] intPrimTyCon IntKind []
-\end{code}
-
-%************************************************************************
-%*									*
-\subsubsection[PrimOps-parallel]{PrimOpInfo for parallelism op(s)}
-%*									*
-%************************************************************************
-
-\begin{code}
-primOpInfo SeqOp	-- seq# :: a -> Int#
-  = PrimResult SLIT("seq#")	[alpha_tv] [alpha] intPrimTyCon IntKind []
-
-primOpInfo ParOp	-- par# :: a -> Int#
-  = PrimResult SLIT("par#")	[alpha_tv] [alpha] intPrimTyCon IntKind []
-
-primOpInfo ForkOp	-- fork# :: a -> Int#
-  = PrimResult SLIT("fork#")	[alpha_tv] [alpha] intPrimTyCon IntKind []
-
-\end{code}
-
-\begin{code}
-#ifdef GRAN
-
-primOpInfo ParGlobalOp	-- parGlobal# :: Int -> a -> b -> b
-  = AlgResult SLIT("parGlobal#")	[alpha_tv,beta_tv] [intPrimTy,alpha,beta] liftTyCon [beta]
-
-primOpInfo ParLocalOp	-- parLocal# :: Int -> a -> b -> b
-  = AlgResult SLIT("parLocal#")	[alpha_tv,beta_tv] [intPrimTy,alpha,beta] liftTyCon [beta]
-
-primOpInfo ParAtOp	-- parAt# :: Int -> a -> b -> c -> c
-  = AlgResult SLIT("parAt#")	[alpha_tv,beta_tv,gamma_tv] [intPrimTy,alpha,beta,gamma] liftTyCon [gamma]
-
-primOpInfo ParAtForNowOp	-- parAtForNow# :: Int -> a -> b -> c -> c
-  = AlgResult SLIT("parAtForNow#")	[alpha_tv,beta_tv,gamma_tv] [intPrimTy,alpha,beta,gamma] liftTyCon [gamma]
-
-primOpInfo CopyableOp	-- copyable# :: a -> a
-  = AlgResult SLIT("copyable#")	[alpha_tv] [alpha] liftTyCon [alpha]
-
-primOpInfo NoFollowOp	-- noFollow# :: a -> a
-  = AlgResult SLIT("noFollow#")	[alpha_tv] [alpha] liftTyCon [alpha]
-
-#endif {-GRAN-}
-\end{code}
-
-%************************************************************************
-%*									*
-\subsubsection[PrimOps-errorIO]{PrimOpInfo for @errorIO#@}
-%*									*
-%************************************************************************
-
-\begin{code}
-primOpInfo ErrorIOPrimOp -- errorIO# :: PrimIO () -> State# RealWorld#
-  = PrimResult SLIT("errorIO#") []
-	[mkPrimIoTy unitTy]
-	statePrimTyCon VoidKind [realWorldTy]
-\end{code}
-
-%************************************************************************
-%*									*
-\subsubsection[PrimOps-IO-etc]{PrimOpInfo for C calls, and I/O-ish things}
-%*									*
-%************************************************************************
-
-\begin{code}
-primOpInfo (CCallOp _ _ _ arg_tys result_ty)
-  = AlgResult SLIT("ccall#") [] arg_tys result_tycon tys_applied
-  where
-    (result_tycon, tys_applied, _) = getUniDataTyCon result_ty
-\end{code}
-
-%************************************************************************
-%*									*
-\subsubsection[PrimOps-DPH]{PrimOpInfo for Data Parallel Haskell}
-%*									*
-%************************************************************************
-
-\begin{code}
-#ifdef DPH
--- ToDo:DPH: various things need doing here
-
-primOpInfo (Int2PodNOp d) =	Coerce ("int2Pod" ++ show d)
-				       IntKind
-				       (PodNKind d IntKind)
-
-primOpInfo (Char2PodNOp d) =	Coerce ("char2Pod" ++ show d)
-				       CharKind
-				       (PodNKind d CharKind)
-
-primOpInfo (Float2PodNOp d) =	Coerce ("float2Pod" ++ show d)
-				       FloatKind
-				       (PodNKind d FloatKind)
-
-primOpInfo (Double2PodNOp d) =	Coerce ("double2Pod" ++ show d)
-				       DoubleKind
-				       (PodNKind d DoubleKind)
-
-{-
-primOpInfo (Integer2PodNOp d) = Coerce ("integer2Pod" ++ show d)
-				       IntegerKind
-				       (PodNKind d IntegerKind)
--}
-
-primOpInfo (String2PodNOp d) =	Coerce ("string2Pod" ++ show d)
-				       LitStringKind
-				       (PodNKind d LitStringKind)
-
-primOpInfo (PodNPrimOp d p) = PodNInfo d (primOpInfo p)
-#endif {- Data Parallel Haskell -}
-\end{code}
-
-%************************************************************************
-%*									*
-\subsection[PrimOps-utils]{Utilities for @PrimitiveOps@}
-%*									*
-%************************************************************************
-
-The primitive-array-creation @PrimOps@ and {\em most} of those to do
-with @Integers@ can trigger GC.  Here we describe the heap requirements
-of the various @PrimOps@.  For most, no heap is required.  For a few,
-a fixed amount of heap is required, and the needs of the @PrimOp@ can
-be combined with the rest of the heap usage in the basic block.  For an
-unfortunate few, some unknown amount of heap is required (these are the
-ops which can trigger GC).  
-
-\begin{code}
-data HeapRequirement 
-    = NoHeapRequired 
-    | FixedHeapRequired HeapOffset 
-    | VariableHeapRequired
-
-primOpHeapReq :: PrimOp -> HeapRequirement
-
-primOpHeapReq NewArrayOp	= VariableHeapRequired
-primOpHeapReq (NewByteArrayOp _)= VariableHeapRequired
-
-primOpHeapReq IntegerAddOp	= VariableHeapRequired
-primOpHeapReq IntegerSubOp	= VariableHeapRequired
-primOpHeapReq IntegerMulOp	= VariableHeapRequired
-primOpHeapReq IntegerQuotRemOp	= VariableHeapRequired
-primOpHeapReq IntegerDivModOp	= VariableHeapRequired
-primOpHeapReq IntegerNegOp	= VariableHeapRequired
-primOpHeapReq Int2IntegerOp	= FixedHeapRequired 
-    	    	    	    	  (addOff (totHdrSize (DataRep mIN_MP_INT_SIZE))
-    	    	    	    	    	  (intOff mIN_MP_INT_SIZE))
-primOpHeapReq Word2IntegerOp	= FixedHeapRequired 
-    	    	    	    	  (addOff (totHdrSize (DataRep mIN_MP_INT_SIZE))
-    	    	    	    	    	  (intOff mIN_MP_INT_SIZE))
-primOpHeapReq Addr2IntegerOp	= VariableHeapRequired
-primOpHeapReq FloatDecodeOp	= FixedHeapRequired 
-                                  (addOff (intOff (getKindSize IntKind + mP_STRUCT_SIZE))
-    	    	    	    	  (addOff (totHdrSize (DataRep mIN_MP_INT_SIZE))
-    	    	    	    	    	  (intOff mIN_MP_INT_SIZE)))
-primOpHeapReq DoubleDecodeOp	= FixedHeapRequired 
-                                  (addOff (intOff (getKindSize IntKind + mP_STRUCT_SIZE))
-    	    	    	    	  (addOff (totHdrSize (DataRep mIN_MP_INT_SIZE))
-    	    	    	    	    	  (intOff mIN_MP_INT_SIZE)))
-
--- ccall may allocate heap if it is explicitly allowed to (_ccall_gc_)
--- or if it returns a MallocPtr.
-
-primOpHeapReq (CCallOp _ _ mayGC@True _ _) = VariableHeapRequired
-primOpHeapReq (CCallOp _ _ mayGC@False _ return_ty)
-   = if returnsMallocPtr
-     then VariableHeapRequired
-     else NoHeapRequired
-  where
-   returnsMallocPtr
-     = case (getUniDataTyCon_maybe return_ty) of
-	 Nothing            -> False
-	 Just (tycon, _, _) -> tycon == stateAndMallocPtrPrimTyCon
-
--- this occasionally has to expand the Stable Pointer table
-primOpHeapReq MakeStablePtrOp	= VariableHeapRequired
-
--- These four only need heap space with the native code generator
--- ToDo!: parameterize, so we know if native code generation is taking place(JSM)
-
-primOpHeapReq IntegerCmpOp	= FixedHeapRequired (intOff (2 * mP_STRUCT_SIZE))
-primOpHeapReq Integer2IntOp    	= FixedHeapRequired (intOff mP_STRUCT_SIZE)
-primOpHeapReq FloatEncodeOp    	= FixedHeapRequired (intOff mP_STRUCT_SIZE)
-primOpHeapReq DoubleEncodeOp   	= FixedHeapRequired (intOff mP_STRUCT_SIZE)
-
--- a NewSynchVarOp creates a three-word mutuple in the heap.
-primOpHeapReq NewSynchVarOp	= FixedHeapRequired 
-    	    	    	    	  (addOff (totHdrSize (MuTupleRep 3)) (intOff 3))
-
--- Sparking ops no longer allocate any heap; however, _fork_ may
--- require a context switch to clear space in the required thread
--- pool, and that requires liveness information.
-
-primOpHeapReq ParOp	    	= NoHeapRequired
-primOpHeapReq ForkOp	    	= VariableHeapRequired
-
--- A SeqOp requires unknown space to evaluate its argument
-primOpHeapReq SeqOp	    	= VariableHeapRequired
-
-#ifdef GRAN
-
--- a ParGlobalOp creates a single 4-tuple in the heap.  ToDo: verify this!
-primOpHeapReq ParGlobalOp	= trace "primOpHeapReq:ParGlobalOp:verify!" (
-				  FixedHeapRequired
-    	    	    	    	  (addOff (totHdrSize (MuTupleRep 4)) (intOff 4))
-				  )
-
--- a ParLocalOp creates a single 4-tuple in the heap.  ToDo: verify this!
-primOpHeapReq ParLocalOp	= trace "primOpHeapReq:ParLocalOp:verify!" (
-				  FixedHeapRequired
-    	    	    	    	  (addOff (totHdrSize (MuTupleRep 4)) (intOff 4))
-				  )
-
--- ToDo: parAt, parAtForNow, copyable, noFollow !!  (HWL)
-#endif {-GRAN-}
-
-primOpHeapReq other_op	    	= NoHeapRequired
-\end{code}
-
-Primops which can trigger GC have to be called carefully.
-In particular, their arguments are guaranteed to be in registers, 
-and a liveness mask tells which regs are live.
-
-\begin{code}
-primOpCanTriggerGC op = 
-    case op of
-    	TakeMVarOp  -> True
-    	ReadIVarOp  -> True
-	DelayOp     -> True
-	WaitOp      -> True
-        _           ->
-            case primOpHeapReq op of
-    	    	VariableHeapRequired -> True
-    	    	_                    -> False
-
-\end{code}
-
-Sometimes we may choose to execute a PrimOp even though it isn't
-certain that its result will be required; ie execute them
-``speculatively''.  The same thing as ``cheap eagerness.'' Usually
-this is OK, because PrimOps are usually cheap, but it isn't OK for
-(a)~expensive PrimOps and (b)~PrimOps which can fail.
-
-See also @primOpIsCheap@ (below).
-
-There should be no worries about side effects; that's all taken care
-of by data dependencies.
-
-\begin{code}
-primOpOkForSpeculation :: PrimOp -> Bool
-
--- Int.
---UNUSED:primOpOkForSpeculation IntDivOp		= False		-- Divide by zero
-primOpOkForSpeculation IntQuotOp	= False		-- Divide by zero
-primOpOkForSpeculation IntRemOp		= False		-- Divide by zero
-
--- Integer
-primOpOkForSpeculation IntegerQuotRemOp = False		-- Divide by zero
-primOpOkForSpeculation IntegerDivModOp	= False		-- Divide by zero
-
--- Float.  ToDo: tan? tanh?
-primOpOkForSpeculation FloatDivOp	= False		-- Divide by zero
-primOpOkForSpeculation FloatLogOp	= False		-- Log of zero
-primOpOkForSpeculation FloatAsinOp	= False		-- Arg out of domain
-primOpOkForSpeculation FloatAcosOp	= False		-- Arg out of domain
-
--- Double.  ToDo: tan? tanh?
-primOpOkForSpeculation DoubleDivOp	= False		-- Divide by zero
-primOpOkForSpeculation DoubleLogOp	= False		-- Log of zero
-primOpOkForSpeculation DoubleAsinOp	= False		-- Arg out of domain
-primOpOkForSpeculation DoubleAcosOp	= False		-- Arg out of domain
-
--- CCall
-primOpOkForSpeculation (CCallOp	_ _ _ _ _)= False	-- Could be expensive!
-
--- errorIO#
-primOpOkForSpeculation ErrorIOPrimOp	= False		-- Could be disastrous!
-
--- parallel
-primOpOkForSpeculation ParOp		= False	    	-- Could be expensive!
-primOpOkForSpeculation ForkOp	    	= False	    	-- Likewise
-primOpOkForSpeculation SeqOp	    	= False	    	-- Likewise
-
-#ifdef GRAN
-primOpOkForSpeculation ParGlobalOp	= False	    	-- Could be expensive!
-primOpOkForSpeculation ParLocalOp	= False	    	-- Could be expensive!
-#endif {-GRAN-}
-
--- The default is "yes it's ok for speculation"
-primOpOkForSpeculation other_op		= True
-\end{code}
-
-@primOpIsCheap@, as used in \tr{SimplUtils.lhs}.  For now (HACK
-WARNING), we just borrow some other predicates for a
-what-should-be-good-enough test.
-\begin{code}
-primOpIsCheap op
-  = primOpOkForSpeculation op && not (primOpCanTriggerGC op)
-\end{code}
-
-And some primops have side-effects and so, for example, must not be
-duplicated.
-
-\begin{code}
-fragilePrimOp :: PrimOp -> Bool
-
-fragilePrimOp ParOp = True
-fragilePrimOp ForkOp = True
-fragilePrimOp SeqOp = True
-fragilePrimOp MakeStablePtrOp = True
-fragilePrimOp DeRefStablePtrOp = True  -- ??? JSM & ADR
-
-#ifdef GRAN
-fragilePrimOp ParGlobalOp = True
-fragilePrimOp ParLocalOp = True
-fragilePrimOp CopyableOp = trace "fragilePrimOp:CopyableOp" True  -- Possibly not.  ASP
-fragilePrimOp NoFollowOp = trace "fragilePrimOp:NoFollowOp" True  -- Possibly not.  ASP
-#endif {-GRAN-}
-
-fragilePrimOp other = False
-\end{code}
-
-Primitive operations that perform calls need wrappers to save any live variables
-that are stored in caller-saves registers
-
-\begin{code}
-primOpNeedsWrapper :: PrimOp -> Bool
-
-primOpNeedsWrapper (CCallOp _ _ _ _ _) 	= True
-
---UNUSED:primOpNeedsWrapper IntDivOp 	    	= True
-
-primOpNeedsWrapper NewArrayOp     	= True	-- ToDo: for nativeGen only!(JSM)
-primOpNeedsWrapper (NewByteArrayOp _)  	= True
-
-primOpNeedsWrapper IntegerAddOp		= True
-primOpNeedsWrapper IntegerSubOp		= True
-primOpNeedsWrapper IntegerMulOp		= True
-primOpNeedsWrapper IntegerQuotRemOp	= True
-primOpNeedsWrapper IntegerDivModOp	= True
-primOpNeedsWrapper IntegerNegOp		= True
-primOpNeedsWrapper IntegerCmpOp	    	= True
-primOpNeedsWrapper Integer2IntOp    	= True
-primOpNeedsWrapper Int2IntegerOp	= True
-primOpNeedsWrapper Word2IntegerOp	= True
-primOpNeedsWrapper Addr2IntegerOp	= True
-
-primOpNeedsWrapper FloatExpOp	    	= True
-primOpNeedsWrapper FloatLogOp	    	= True
-primOpNeedsWrapper FloatSqrtOp	    	= True
-primOpNeedsWrapper FloatSinOp	    	= True
-primOpNeedsWrapper FloatCosOp	    	= True
-primOpNeedsWrapper FloatTanOp	    	= True
-primOpNeedsWrapper FloatAsinOp	    	= True
-primOpNeedsWrapper FloatAcosOp	    	= True
-primOpNeedsWrapper FloatAtanOp	    	= True
-primOpNeedsWrapper FloatSinhOp	    	= True
-primOpNeedsWrapper FloatCoshOp	    	= True
-primOpNeedsWrapper FloatTanhOp	    	= True
-primOpNeedsWrapper FloatPowerOp	    	= True
-primOpNeedsWrapper FloatEncodeOp    	= True
-primOpNeedsWrapper FloatDecodeOp	= True
-
-primOpNeedsWrapper DoubleExpOp	    	= True
-primOpNeedsWrapper DoubleLogOp	    	= True
-primOpNeedsWrapper DoubleSqrtOp	    	= True
-primOpNeedsWrapper DoubleSinOp	    	= True
-primOpNeedsWrapper DoubleCosOp	    	= True
-primOpNeedsWrapper DoubleTanOp	    	= True
-primOpNeedsWrapper DoubleAsinOp	    	= True
-primOpNeedsWrapper DoubleAcosOp	    	= True
-primOpNeedsWrapper DoubleAtanOp	    	= True
-primOpNeedsWrapper DoubleSinhOp	    	= True
-primOpNeedsWrapper DoubleCoshOp	    	= True
-primOpNeedsWrapper DoubleTanhOp	    	= True
-primOpNeedsWrapper DoublePowerOp    	= True
-primOpNeedsWrapper DoubleEncodeOp   	= True
-primOpNeedsWrapper DoubleDecodeOp	= True
-
-primOpNeedsWrapper MakeStablePtrOp	= True
-primOpNeedsWrapper DeRefStablePtrOp	= True
-
-primOpNeedsWrapper TakeMVarOp	    	= True
-primOpNeedsWrapper PutMVarOp		= True
-primOpNeedsWrapper ReadIVarOp	    	= True
-
-primOpNeedsWrapper DelayOp	    	= True
-primOpNeedsWrapper WaitOp		= True
-
-primOpNeedsWrapper other_op 	    	= False
-\end{code}
-
-\begin{code}
-primOpId	:: PrimOp -> Id
-primOpNameInfo	:: PrimOp -> (FAST_STRING, Name)
-
--- the *NameInfo ones are trivial:
-
-primOpNameInfo	op = (primOp_str  op, WiredInVal (primOpId op))
-
-primOp_str op
-  = case (primOpInfo op) of
-      Dyadic str _	       -> str
-      Monadic str _	       -> str
-      Compare str _	       -> str
-      Coerce str _ _	       -> str 
-      PrimResult str _ _ _ _ _ -> str
-      AlgResult str _ _ _ _    -> str
-#ifdef DPH
-      PodNInfo d i -> case i of
-			Dyadic str _	-> (str ++ ".POD" ++ show d ++ "#")
-			Monadic str _	-> (str ++ ".POD" ++ show d ++ "#")
-			Compare str _	-> (str ++ ".POD" ++ show d ++ "#")
-			Coerce str _ _	-> (str ++ ".POD" ++ show d ++ "#")
-			PrimResult str _ _ _ _ _ -> (str ++ ".POD" ++ show d)
-			AlgResult str _ _ _ _	-> (str ++ ".POD" ++ show d)
-#endif {- Data Parallel Haskell -}
-\end{code}
-
-@typeOfPrimOp@ duplicates some work of @primOpId@, but since we
-grab types pretty often...
-\begin{code}
-typeOfPrimOp :: PrimOp -> UniType
-
-#ifdef DPH
-typeOfPrimOp (PodNPrimOp d p)
-  = mkPodizedPodNTy d (typeOfPrimOp p)
-#endif {- Data Parallel Haskell -}
-
-typeOfPrimOp op
-  = case (primOpInfo op) of
-      Dyadic str ty ->	    dyadic_fun_ty ty
-      Monadic str ty ->	    monadic_fun_ty ty
-      Compare str ty ->	    prim_compare_fun_ty ty
-      Coerce str ty1 ty2 -> UniFun ty1 ty2
-
-      PrimResult str tyvars arg_tys prim_tycon kind res_tys ->
-	mkForallTy tyvars (glueTyArgs arg_tys (applyTyCon prim_tycon res_tys))
-
-      AlgResult str tyvars arg_tys tycon res_tys ->
-	mkForallTy tyvars (glueTyArgs arg_tys (applyTyCon tycon res_tys))
-\end{code}
-
-\begin{code}
-primOpId op
-  = case (primOpInfo op) of
-      Dyadic str ty ->
-	mk_prim_Id op pRELUDE_BUILTIN str [] [ty,ty] (dyadic_fun_ty ty) 2
-
-      Monadic str ty ->
-	mk_prim_Id op pRELUDE_BUILTIN str [] [ty] (monadic_fun_ty ty) 1
-
-      Compare str ty ->
-	mk_prim_Id op pRELUDE_BUILTIN str [] [ty,ty] (prim_compare_fun_ty ty) 2
-
-      Coerce str ty1 ty2 ->
-	mk_prim_Id op pRELUDE_BUILTIN str [] [ty1] (UniFun ty1 ty2) 1
-
-      PrimResult str tyvars arg_tys prim_tycon kind res_tys ->
-	mk_prim_Id op pRELUDE_BUILTIN str
-	    tyvars
-	    arg_tys
-	    (mkForallTy tyvars (glueTyArgs arg_tys (applyTyCon prim_tycon res_tys)))
-	    (length arg_tys) -- arity
-
-      AlgResult str tyvars arg_tys tycon res_tys ->
-	mk_prim_Id op pRELUDE_BUILTIN str
-	    tyvars
-	    arg_tys
-	    (mkForallTy tyvars (glueTyArgs arg_tys (applyTyCon tycon res_tys)))
-	    (length arg_tys) -- arity
-
-#ifdef DPH
-      PodNInfo d i -> panic "primOpId : Oi lazy, PodNInfo needs sorting out"
-#endif {- Data Parallel Haskell -}
-  where
-    mk_prim_Id prim_op mod name tyvar_tmpls arg_tys ty arity
-      = mkPreludeId
-	    (mkPrimOpIdUnique prim_op)
-	    (mkPreludeCoreName mod name)
-	    ty
-	    (noIdInfo
-		`addInfo` (mkArityInfo arity)
-		`addInfo_UF` (mkUnfolding EssentialUnfolding
-				(mk_prim_unfold prim_op tyvar_tmpls arg_tys)))
-\end{code}
-
-The functions to make common unfoldings are tedious.
-
-\begin{code}
-mk_prim_unfold :: PrimOp -> [TyVarTemplate] -> [UniType] -> PlainCoreExpr{-template-}
-
-mk_prim_unfold prim_op tv_tmpls arg_tys
-  = let
-	(inst_env, tyvars, tyvar_tys) = instantiateTyVarTemplates tv_tmpls (map getTheUnique tv_tmpls)
-	inst_arg_tys		      = map (instantiateTauTy inst_env) arg_tys
-	vars	    		      = mkTemplateLocals inst_arg_tys
-    in
-    foldr CoTyLam (mkCoLam vars
-			   (CoPrim prim_op tyvar_tys [CoVarAtom v | v <- vars]))
-		  tyvars
-\end{code}
-
-\begin{code}
-data PrimOpResultInfo
-  = ReturnsPrim	    PrimKind
-  | ReturnsAlg	    TyCon
-
--- ToDo: Deal with specialised PrimOps
---	 Will need to return specialised tycon and data constructors
-
-getPrimOpResultInfo :: PrimOp -> PrimOpResultInfo
-
-getPrimOpResultInfo op
-  = case (primOpInfo op) of
-      Dyadic  _ ty		 -> ReturnsPrim (kindFromType ty)
-      Monadic _ ty		 -> ReturnsPrim (kindFromType ty)
-      Compare _ ty		 -> ReturnsAlg  boolTyCon
-      Coerce  _ _ ty		 -> ReturnsPrim (kindFromType ty)
-      PrimResult _ _ _ _ kind _	 -> ReturnsPrim kind
-      AlgResult _ _ _ tycon _	 -> ReturnsAlg  tycon
-#ifdef DPH
-      PodNInfo d i		 -> panic "getPrimOpResultInfo:PodNInfo"
-#endif {- Data Parallel Haskell -}
-
-isCompareOp :: PrimOp -> Bool
-
-isCompareOp op
-  = case primOpInfo op of
-      Compare _ _ -> True
-      _	    	  -> False
-\end{code}
-
-Utils:
-\begin{code}
-dyadic_fun_ty ty    = ty `UniFun` (ty `UniFun` ty)
-monadic_fun_ty ty   = ty `UniFun` ty
-
-compare_fun_ty ty	= ty `UniFun` (ty `UniFun` boolTy)
-prim_compare_fun_ty ty	= ty `UniFun` (ty `UniFun` boolTy)
-\end{code}
-
-Output stuff:
-\begin{code}
-pprPrimOp  :: PprStyle -> PrimOp -> Pretty
-showPrimOp :: PprStyle -> PrimOp -> String
-
-showPrimOp sty op
-  = ppShow 1000{-random-} (pprPrimOp sty op)
-
-pprPrimOp sty (CCallOp fun is_casm may_gc arg_tys res_ty)
-  = let
-	before
-	  = if is_casm then
-	       if may_gc then "(_casm_GC_ ``" else "(_casm_ ``"
-	    else
-	       if may_gc then "(_ccall_GC_ " else "(_ccall_ "
-
-	after
-	  = if is_casm then ppStr "''" else ppNil
-
-	pp_tys
-	  = ppBesides [ppStr " { [",
-		ppIntersperse pp'SP{-'-} (map (pprParendUniType sty) arg_tys),
-		ppRbrack, ppSP, pprParendUniType sty res_ty, ppStr " })"]
-
-    in
-    ppBesides [ppStr before, ppPStr fun, after, pp_tys]
-#ifdef DPH
-  = fun	-- Comment buggers up machine code :-) -- ToDo:DPH
-#endif {- Data Parallel Haskell -}
-
-pprPrimOp sty other_op
-  = let
-	str = primOp_str other_op
-    in
-    if codeStyle sty
-    then identToC str
-    else ppPStr str
-
-instance Outputable PrimOp where
-    ppr sty op = pprPrimOp sty op
-\end{code}
diff --git a/ghc/compiler/prelude/PrimRep.lhs b/ghc/compiler/prelude/PrimRep.lhs
new file mode 100644
index 0000000000..b4fbf55e9f
--- /dev/null
+++ b/ghc/compiler/prelude/PrimRep.lhs
@@ -0,0 +1,205 @@
+%
+% (c) The GRASP Project, Glasgow University, 1992-1996
+%
+\section[PrimRep]{Primitive machine-level kinds of things.}
+
+At various places in the back end, we want to be to tag things with a
+``primitive kind''---i.e., the machine-manipulable implementation
+types.
+
+\begin{code}
+#include "HsVersions.h"
+
+module PrimRep (
+	PrimRep(..),
+
+	separateByPtrFollowness, isFollowableRep, isFloatingRep,
+	getPrimRepSize, retPrimRepSize,
+	showPrimRep,
+	guessPrimRep
+    ) where
+
+import Ubiq
+
+import Pretty		-- pretty-printing code
+import Util
+
+#include "../../includes/GhcConstants.h"
+\end{code}
+
+%************************************************************************
+%*									*
+\subsection[PrimRep-datatype]{The @PrimRep@ datatype}
+%*									*
+%************************************************************************
+
+\begin{code}
+data PrimRep
+  = -- These pointer-kinds are all really the same, but we keep
+    -- them separate for documentation purposes.
+    PtrRep		-- Pointer to a closure; a ``word''.
+  | CodePtrRep		-- Pointer to code
+  | DataPtrRep		-- Pointer to data
+  | RetRep 	    	-- Pointer to code or data (return vector or code pointer)
+  | CostCentreRep	-- Pointer to a cost centre
+
+  | CharRep		-- Machine characters
+  | IntRep		--	   integers (at least 32 bits)
+  | WordRep		--	   ditto (but *unsigned*)
+  | AddrRep		--	   addresses ("C pointers")
+  | FloatRep		--	   floats
+  | DoubleRep		--	   doubles
+
+  | MallocPtrRep	-- This has to be a special kind because ccall
+			-- generates special code when passing/returning
+			-- one of these. [ADR]
+
+  | StablePtrRep	-- We could replace this with IntRep but maybe
+			-- there's some documentation gain from having
+			-- it special? [ADR]
+
+  | ArrayRep		-- Primitive array of Haskell pointers
+  | ByteArrayRep	-- Primitive array of bytes (no Haskell pointers)
+
+  | VoidRep		-- Occupies no space at all!
+			-- (Primitive states are mapped onto this)
+  deriving (Eq, Ord)
+	-- Kinds are used in PrimTyCons, which need both Eq and Ord
+	-- Text is needed for derived-Text on PrimitiveOps
+\end{code}
+
+%************************************************************************
+%*									*
+\subsection[PrimRep-predicates]{Follow-ness, sizes, and such---on @PrimitiveKinds@}
+%*									*
+%************************************************************************
+
+Whether or not the thing is a pointer that the garbage-collector
+should follow.
+
+Or, to put it another (less confusing) way, whether the object in
+question is a heap object.
+
+\begin{code}
+isFollowableRep :: PrimRep -> Bool
+
+isFollowableRep PtrRep        = True
+isFollowableRep ArrayRep      = True
+isFollowableRep ByteArrayRep  = True
+isFollowableRep MallocPtrRep  = True
+
+isFollowableRep StablePtrRep  = False
+-- StablePtrs aren't followable because they are just indices into a
+-- table for which explicit allocation/ deallocation is required.
+
+isFollowableRep other	    	= False
+
+separateByPtrFollowness :: (a -> PrimRep) -> [a] -> ([a], [a])
+
+separateByPtrFollowness kind_fun things
+  = sep_things kind_fun things [] []
+    -- accumulating params for follow-able and don't-follow things...
+  where
+    sep_things kfun []     bs us = (reverse bs, reverse us)
+    sep_things kfun (t:ts) bs us
+      = if (isFollowableRep . kfun) t then
+	    sep_things kfun ts (t:bs) us
+	else
+	    sep_things kfun ts bs (t:us)
+\end{code}
+
+@isFloatingRep@ is used to distinguish @Double@ and @Float@ which
+cause inadvertent numeric conversions if you aren't jolly careful.
+See codeGen/CgCon:cgTopRhsCon.
+
+\begin{code}
+isFloatingRep :: PrimRep -> Bool
+
+isFloatingRep DoubleRep = True
+isFloatingRep FloatRep  = True
+isFloatingRep other     = False
+\end{code}
+
+\begin{code}
+getPrimRepSize :: PrimRep -> Int
+
+getPrimRepSize DoubleRep  = DOUBLE_SIZE	-- "words", of course
+--getPrimRepSize FloatRep = 1
+--getPrimRepSize CharRep  = 1	-- ToDo: count in bytes?
+--getPrimRepSize ArrayRep = 1	-- Listed specifically for *documentation*
+--getPrimRepSize ByteArrayRep = 1
+getPrimRepSize VoidRep	  = 0
+getPrimRepSize other	  = 1
+
+retPrimRepSize = getPrimRepSize RetRep
+\end{code}
+
+%************************************************************************
+%*									*
+\subsection[PrimRep-instances]{Boring instance decls for @PrimRep@}
+%*									*
+%************************************************************************
+
+\begin{code}
+instance Outputable PrimRep where
+    ppr sty kind = ppStr (showPrimRep kind)
+
+showPrimRep  :: PrimRep -> String
+guessPrimRep :: String -> PrimRep	-- a horrible "inverse" function
+
+showPrimRep PtrRep	    = "P_"	-- short for StgPtr
+
+showPrimRep CodePtrRep    = "P_"	-- DEATH to StgFunPtr! (94/02/22 WDP)
+    -- but aren't code pointers and function pointers different sizes
+    -- on some machines (eg 80x86)? ADR
+    -- Are you trying to ruin my life, or what? (WDP)
+
+showPrimRep DataPtrRep    = "D_"
+showPrimRep RetRep        = "StgRetAddr"
+showPrimRep CostCentreRep = "CostCentre"
+showPrimRep CharRep	  = "StgChar"
+showPrimRep IntRep	  = "I_"	-- short for StgInt
+showPrimRep WordRep	  = "W_"	-- short for StgWord
+showPrimRep AddrRep	  = "StgAddr"
+showPrimRep FloatRep	  = "StgFloat"
+showPrimRep DoubleRep	  = "StgDouble"
+showPrimRep ArrayRep	  = "StgArray" -- see comment below
+showPrimRep ByteArrayRep  = "StgByteArray"
+showPrimRep StablePtrRep  = "StgStablePtr"
+showPrimRep MallocPtrRep  = "StgPtr" -- see comment below
+showPrimRep VoidRep	  = "!!VOID_KIND!!"
+
+guessPrimRep "D_"	     = DataPtrRep
+guessPrimRep "StgRetAddr"   = RetRep
+guessPrimRep "StgChar"	     = CharRep
+guessPrimRep "I_"	     = IntRep
+guessPrimRep "W_"	     = WordRep
+guessPrimRep "StgAddr"	     = AddrRep
+guessPrimRep "StgFloat"     = FloatRep
+guessPrimRep "StgDouble"    = DoubleRep
+guessPrimRep "StgArray"     = ArrayRep
+guessPrimRep "StgByteArray" = ByteArrayRep
+guessPrimRep "StgStablePtr" = StablePtrRep
+\end{code}
+
+All local C variables of @ArrayRep@ are declared in C as type
+@StgArray@.  The coercion to a more precise C type is done just before
+indexing (by the relevant C primitive-op macro).
+
+Nota Bene. There are three types associated with Malloc Pointers:
+\begin{itemize}
+\item
+@StgMallocClosure@ is the type of the thing the C world gives us.
+(This typename is hardwired into @ppr_casm_results@ in
+@PprAbsC.lhs@.)
+
+\item
+@StgMallocPtr@ is the type of the thing we give the C world.
+
+\item
+@StgPtr@ is the type of the (pointer to the) heap object which we
+pass around inside the STG machine.
+\end{itemize}
+
+It is really easy to confuse the two.  (I'm not sure this choice of
+type names helps.) [ADR]
diff --git a/ghc/compiler/prelude/TyPod.lhs b/ghc/compiler/prelude/TyPod.lhs
deleted file mode 100644
index c494303162..0000000000
--- a/ghc/compiler/prelude/TyPod.lhs
+++ /dev/null
@@ -1,159 +0,0 @@
-%************************************************************************
-%*									*
-\section[TyPod]{The Pod datatype}
-%*									*
-%************************************************************************
-\begin{code}
-#include "HsVersions.h"
-
-module TyPod where
-
-import PrelFuns		-- help functions, types and things
-import TyInteger --ToDo:DPH: no such thing any more!
-import TyProcs
-import TyBool 		( boolTy )
-import Unique
-
-import AbsUniType	( getUniDataTyCon_maybe , mkPodizedPodTyCon )
-import Maybes
-\end{code}
-
-In the implementation of \DPHaskell{} for a SIMD machine, we adopt three
-diffrent models of \POD{}s.
-
-%************************************************************************
-\subsection[User]{The Users model}
-%************************************************************************
-The users model of a \POD{} is outlined in ``Data Parallel Haskell: Mixing old
-and new glue''\cite{hill:dpglue}. In this model, a \POD{} represents a
-collection of index value pairs, where each index uniquely identifies a
-single element of a \POD{}.  As \POD{}s are an abstraction of the processing
-elements of a data parallel machine, we choose to collect the index value
-pairs into a data type we call a `processor'.
-
-The indices of a \POD{} can be thought of as a subset of the
-integers\footnote{10/03/93: I've decided to change the index types of \POD{}'s
----they are now Int's {\em not} Integer's. The use of the GMP package has
-changed things, Integers are now special, and there's no way I'm going
-to have time to implement them on the DAP. I would like Integers to be like
-Ints, i.e a single boxed primitive value --- they are'nt like that any more.
-I've therefore plumped for Int's as index values, which means indices
-are restricted to 32bit signed values.}. We use
-the Haskell class system to extend the range of possible types for the indices
-such that any type that is an instance of the class {\tt Pid} (processor
-identifier) may be used as an index type.
-
-%************************************************************************
-\subsection[prePodized]{The Core Syntax model before podization}
-%************************************************************************
-Desugaring of the abstract syntax introduces the overloaded operators
-{\tt fromDomain} and {\tt toDomain} to convert the index types to integers.
-We bring the \POD{} type and processor types closer together in the core
-syntax; \POD{}s will have types such as {\tt <<Int,Int;Char>>} in
-which the integer types before the ``;'' determine the position of an
-element identified by those integers within a two dimensioned \POD{}
-(i.e a matrix).
-%************************************************************************
-\subsection[postPodized]{The Core Syntax model after podization}
-%************************************************************************
-Things drastically change after podization. There are four different
-variety of \POD{}s being used at runtime:
-\begin{enumerate}
-\item[Interface] A $k$ dimensional Interface \POD{} of $\alpha$'s is
-		 represented by a product type that contains a $k$ dimensional
-		 inside out \POD{} of Boolean values that determine at what
-		 processors the Interface \POD{} is to be defined; and a $k$
-		 dimensional inside out \POD{} of $\alpha$'s - the \POD{}s that
-		 the user manipulates in \POD{} comprehensions are all
-		 interface \POD{}'s --- see note **1** on efficiency below.
-
-\item[Podized]   The remaining types of \POD{}s are invisible to the user
-		  - See the podization files for more details (even a bit
-		 sketchy their :-(
-
-\item[Primitive] A $k$ dimensional unboxed \POD{} is a contiguous subset of
-		 primitive unboxed values - these will hopefully be the
-		 staple diet of Data Parallel evaluation. For non SIMD
-		 people, these are just like `C' arrays, except we can apply
-		 primitive parallel operations to them---for example add
-		 two arrays together.
-
-\item[Hard luck] Hard luck \POD{}s are the ones that we cann't implement in a
-		 parallel manner - see podization files for more details.
-\end{enumerate}
-
-Note **1** : Efficiency of parallel functions.
-
-There are various (trivial) laws concerning \POD{} comprehensions, such as
-
-(vectorMap f) . (vectorMap g) == vectorMap (f.g)
-
-The right of the above expressions is more ``efficient'' because we only
-unbox the interface \POD{}, then check for undefined elements once in contrast
-to twice in the left expression. Maybe theres some scope here for some
-simplifications ??
-
-%************************************************************************
-%*									*
-\section[User_POD]{The ``Users model'' of a Pod}
-%*									*
-%************************************************************************
-\begin{code}
-mkPodTy :: UniType -> UniType
-mkPodTy ty = UniData podTyCon [ty]
-
-mkPodNTy:: Int -> UniType -> UniType
-mkPodNTy n ty = UniData podTyCon [mkProcessorTy (take n int_tys) ty]
-	      where
-	         int_tys = integerTy : int_tys
-
-podTyCon = pcDataTyCon podTyConKey pRELUDE_BUILTIN "Pod" [alpha_tv] []
-\end{code}
-
-%************************************************************************
-%*									*
-\section[Podized_POD]{The ``Podized model'' of a Pod}
-%*									*
-%************************************************************************
-Theres a small problem with the following code, I wonder if anyone can help??
-
-I have defined podized versions of TyCons, by wrapping a TyCon and an Int in
-a PodizedTyCon (similiar to technique used for Ids). This is helpfull because
-when tycons are attached to cases, they show that they are podized (I want
-to preserve the info). TyCons are also used in the unitype world, the problem
-being if I want a podized dictionary - I cannt just call getUniDataTyCon
-to get me the dictionaries TyCon - it doesnt have one :-( What I've therefore
-done is get the tycon out of a unitype if it has one, otherwise I use a
-default podizedTyConKey which means the things podized, but dont ask anything
-about it - (also for polymorphic types).
-
-ToDo(hilly):	Using @getUniDataTyCon_maybe@ doesnt seem a good way of doing
-		things...
-\begin{code}
-mkPodizedPodNTy:: Int -> UniType -> UniType
-mkPodizedPodNTy n ty
-  = case (getUniDataTyCon_maybe ty) of
-     Nothing    ->let tc = pcDataTyCon (podizedPodTyConKey n) pRELUDE_BUILTIN
-			               ("PodizedUnk"++show n) [alpha_tv] []
- 		  in UniData tc [ty]
-
-     Just (tycon,_,_) ->UniData (mkPodizedPodTyCon n tycon) [ty]
-
-\end{code}
-%************************************************************************
-%*									*
-\section[Podized_POD]{The ``Interface model'' of a Pod}
-%*									*
-%************************************************************************
-\begin{code}
-mkInterfacePodNTy n ty
-  = UniData (interfacePodTyCon n) [mkPodizedPodNTy n ty]
-
-interfacePodTyCon n
-  = pcDataTyCon interfacePodTyConKey pRELUDE_BUILTIN
-	        "InterPod" [alpha_tv] [mKINTERPOD_ID n]
-
-mKINTERPOD_ID n
-  = pcDataCon interfacePodDataConKey pRELUDE_BUILTIN "MkInterPod"
-              [] [] [mkPodizedPodNTy n boolTy] (interfacePodTyCon n) nullSpecEnv
-\end{code}
diff --git a/ghc/compiler/prelude/TyProcs.lhs b/ghc/compiler/prelude/TyProcs.lhs
deleted file mode 100644
index 546f7e487a..0000000000
--- a/ghc/compiler/prelude/TyProcs.lhs
+++ /dev/null
@@ -1,26 +0,0 @@
-%
-% (c) The GRASP Project, Glasgow University, 1992
-%
-\section[TyProcessor]{The processor datatypes}
-
-This is used only for ``Data Parallel Haskell.''
-
-\begin{code}
-#include "HsVersions.h"
-
-module TyProcs where
-
-import PrelFuns		-- help functions, types and things
-import PrelUniqs
-
-import AbsUniType	( applyTyCon, mkProcessorTyCon )
-import Util
-
-mkProcessorTy :: [UniType] -> UniType -> UniType
-mkProcessorTy tys ty
- = applyTyCon (mkProcessorTyCon (length tys)) (tys++[ty])
-
-processor1TyCon = mkProcessorTyCon (1::Int)
-processor2TyCon = mkProcessorTyCon (2::Int)
-processor3TyCon = mkProcessorTyCon (3::Int)
-\end{code}
diff --git a/ghc/compiler/prelude/TysPrim.hi b/ghc/compiler/prelude/TysPrim.hi
deleted file mode 100644
index e93ab6abf6..0000000000
--- a/ghc/compiler/prelude/TysPrim.hi
+++ /dev/null
@@ -1,36 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface TysPrim where
-import TyCon(TyCon)
-import UniType(UniType)
-addrPrimTy :: UniType
-addrPrimTyCon :: TyCon
-arrayPrimTyCon :: TyCon
-byteArrayPrimTy :: UniType
-byteArrayPrimTyCon :: TyCon
-charPrimTy :: UniType
-charPrimTyCon :: TyCon
-doublePrimTy :: UniType
-doublePrimTyCon :: TyCon
-floatPrimTy :: UniType
-floatPrimTyCon :: TyCon
-intPrimTy :: UniType
-intPrimTyCon :: TyCon
-mallocPtrPrimTyCon :: TyCon
-mkArrayPrimTy :: UniType -> UniType
-mkMutableArrayPrimTy :: UniType -> UniType -> UniType
-mkMutableByteArrayPrimTy :: UniType -> UniType
-mkStablePtrPrimTy :: UniType -> UniType
-mkStatePrimTy :: UniType -> UniType
-mkSynchVarPrimTy :: UniType -> UniType -> UniType
-mutableArrayPrimTyCon :: TyCon
-mutableByteArrayPrimTyCon :: TyCon
-realWorldStatePrimTy :: UniType
-realWorldTy :: UniType
-realWorldTyCon :: TyCon
-stablePtrPrimTyCon :: TyCon
-statePrimTyCon :: TyCon
-synchVarPrimTyCon :: TyCon
-voidPrimTy :: UniType
-wordPrimTy :: UniType
-wordPrimTyCon :: TyCon
-
diff --git a/ghc/compiler/prelude/TysPrim.lhs b/ghc/compiler/prelude/TysPrim.lhs
index d70ed565db..afc81b93b3 100644
--- a/ghc/compiler/prelude/TysPrim.lhs
+++ b/ghc/compiler/prelude/TysPrim.lhs
@@ -1,5 +1,5 @@
 %
-% (c) The AQUA Project, Glasgow University, 1994-1995
+% (c) The AQUA Project, Glasgow University, 1994-1996
 %
 \section[TysPrim]{Wired-in knowledge about primitive types}
 
@@ -11,12 +11,24 @@ types and operations.''
 
 module TysPrim where
 
-import PrelFuns		-- help functions, types and things
-import PrimKind
-
-import AbsUniType	( applyTyCon )
+import Ubiq
+
+import Kind		( mkUnboxedTypeKind, mkBoxedTypeKind )
+import NameTypes	( mkPreludeCoreName, FullName )
+import PrelMods		( pRELUDE_BUILTIN )
+import PrimRep		( PrimRep(..) )	-- getPrimRepInfo uses PrimRep repn
+import TyCon		( mkPrimTyCon, mkDataTyCon,
+			  ConsVisible(..), NewOrData(..) )
+import TyVar		( GenTyVar(..), alphaTyVars )
+import Type		( applyTyCon, mkTyVarTy )
+import Usage		( usageOmega )
 import Unique
-import Util
+
+\end{code}
+
+\begin{code}
+alphaTys = map mkTyVarTy alphaTyVars
+(alphaTy:betaTy:gammaTy:deltaTy:_) = alphaTys
 \end{code}
 
 %************************************************************************
@@ -26,23 +38,49 @@ import Util
 %************************************************************************
 
 \begin{code}
+-- only used herein
+pcPrimTyCon :: Unique{-TyConKey-} -> FAST_STRING -> Int -> ([PrimRep] -> PrimRep) -> TyCon
+pcPrimTyCon key name arity{-UNUSED-} kind_fn{-UNUSED-}
+  = mkPrimTyCon key full_name mkUnboxedTypeKind
+  where
+    full_name = mkPreludeCoreName pRELUDE_BUILTIN name
+
+
 charPrimTy	= applyTyCon charPrimTyCon []
-charPrimTyCon	= pcPrimTyCon charPrimTyConKey SLIT("Char#") 0 (\ [] -> CharKind)
+charPrimTyCon	= pcPrimTyCon charPrimTyConKey SLIT("Char#") 0 (\ [] -> CharRep)
 
 intPrimTy	= applyTyCon intPrimTyCon []
-intPrimTyCon	= pcPrimTyCon intPrimTyConKey SLIT("Int#") 0 (\ [] -> IntKind)
+intPrimTyCon	= pcPrimTyCon intPrimTyConKey SLIT("Int#") 0 (\ [] -> IntRep)
 
 wordPrimTy	= applyTyCon wordPrimTyCon []
-wordPrimTyCon	= pcPrimTyCon wordPrimTyConKey SLIT("Word#") 0 (\ [] -> WordKind)
+wordPrimTyCon	= pcPrimTyCon wordPrimTyConKey SLIT("Word#") 0 (\ [] -> WordRep)
 
 addrPrimTy	= applyTyCon addrPrimTyCon []
-addrPrimTyCon	= pcPrimTyCon addrPrimTyConKey SLIT("Addr#") 0 (\ [] -> AddrKind)
+addrPrimTyCon	= pcPrimTyCon addrPrimTyConKey SLIT("Addr#") 0 (\ [] -> AddrRep)
 
 floatPrimTy	= applyTyCon floatPrimTyCon []
-floatPrimTyCon	= pcPrimTyCon floatPrimTyConKey SLIT("Float#") 0 (\ [] -> FloatKind)
+floatPrimTyCon	= pcPrimTyCon floatPrimTyConKey SLIT("Float#") 0 (\ [] -> FloatRep)
 
 doublePrimTy	= applyTyCon doublePrimTyCon []
-doublePrimTyCon	= pcPrimTyCon doublePrimTyConKey SLIT("Double#") 0 (\ [] -> DoubleKind)
+doublePrimTyCon	= pcPrimTyCon doublePrimTyConKey SLIT("Double#") 0 (\ [] -> DoubleRep)
+\end{code}
+
+@PrimitiveKinds@ are used in @PrimitiveOps@, for which we often need
+to reconstruct various type information.  (It's slightly more
+convenient/efficient to make type info from kinds, than kinds [etc.]
+from type info.)
+
+\begin{code}
+getPrimRepInfo ::
+    PrimRep -> (String,		-- tag string
+		Type, TyCon)	-- prim type and tycon
+
+getPrimRepInfo CharRep   = ("Char",   charPrimTy,   charPrimTyCon)
+getPrimRepInfo IntRep    = ("Int",    intPrimTy,    intPrimTyCon)
+getPrimRepInfo WordRep   = ("Word",   wordPrimTy,   wordPrimTyCon)
+getPrimRepInfo AddrRep   = ("Addr",   addrPrimTy,   addrPrimTyCon)
+getPrimRepInfo FloatRep  = ("Float",  floatPrimTy,  floatPrimTyCon)
+getPrimRepInfo DoubleRep = ("Double", doublePrimTy, doublePrimTyCon)
 \end{code}
 
 %************************************************************************
@@ -56,7 +94,7 @@ Very similar to the @State#@ type.
 voidPrimTy = applyTyCon voidPrimTyCon []
   where
    voidPrimTyCon = pcPrimTyCon voidPrimTyConKey SLIT("Void#") 0
-			(\ [] -> VoidKind)
+			(\ [] -> VoidRep)
 \end{code}
 
 %************************************************************************
@@ -68,16 +106,23 @@ voidPrimTy = applyTyCon voidPrimTyCon []
 \begin{code}
 mkStatePrimTy ty = applyTyCon statePrimTyCon [ty]
 statePrimTyCon	 = pcPrimTyCon statePrimTyConKey SLIT("State#") 1
-			(\ [s_kind] -> VoidKind)
+			(\ [s_kind] -> VoidRep)
 \end{code}
 
 @_RealWorld@ is deeply magical.  It {\em is primitive}, but it
 {\em is not unboxed}.
 \begin{code}
-realWorldTy	  = applyTyCon realWorldTyCon []
+realWorldTy = applyTyCon realWorldTyCon []
 realWorldTyCon
-  = pcDataTyCon realWorldTyConKey pRELUDE_BUILTIN SLIT("_RealWorld") []
+  = mkDataTyCon realWorldTyConKey mkBoxedTypeKind full_name
+	[{-no tyvars-}]
+	[{-no context-}]
 	[{-no data cons!-}] -- we tell you *nothing* about this guy
+	[{-no derivings-}]
+	ConsInvisible
+	DataType
+  where
+    full_name = mkPreludeCoreName pRELUDE_BUILTIN SLIT("_RealWorld")
 
 realWorldStatePrimTy = mkStatePrimTy realWorldTy
 \end{code}
@@ -93,16 +138,16 @@ defined in \tr{TysWiredIn.lhs}, not here.
 
 \begin{code}
 arrayPrimTyCon	= pcPrimTyCon arrayPrimTyConKey SLIT("Array#") 1
-			(\ [elt_kind] -> ArrayKind)
+			(\ [elt_kind] -> ArrayRep)
 
 byteArrayPrimTyCon = pcPrimTyCon byteArrayPrimTyConKey SLIT("ByteArray#") 0
-			(\ [] -> ByteArrayKind)
+			(\ [] -> ByteArrayRep)
 
 mutableArrayPrimTyCon = pcPrimTyCon mutableArrayPrimTyConKey SLIT("MutableArray#") 2
-			(\ [s_kind, elt_kind] -> ArrayKind)
+			(\ [s_kind, elt_kind] -> ArrayRep)
 
 mutableByteArrayPrimTyCon = pcPrimTyCon mutableByteArrayPrimTyConKey SLIT("MutableByteArray#") 1
-			(\ [s_kind] -> ByteArrayKind)
+			(\ [s_kind] -> ByteArrayRep)
 
 mkArrayPrimTy elt    	    = applyTyCon arrayPrimTyCon [elt]
 byteArrayPrimTy	    	    = applyTyCon byteArrayPrimTyCon []
@@ -118,7 +163,7 @@ mkMutableByteArrayPrimTy s  = applyTyCon mutableByteArrayPrimTyCon [s]
 
 \begin{code}
 synchVarPrimTyCon = pcPrimTyCon synchVarPrimTyConKey SLIT("SynchVar#") 2
-			(\ [s_kind, elt_kind] -> PtrKind)
+			(\ [s_kind, elt_kind] -> PtrRep)
 
 mkSynchVarPrimTy s elt 	    = applyTyCon synchVarPrimTyCon [s, elt]
 \end{code}
@@ -131,7 +176,7 @@ mkSynchVarPrimTy s elt 	    = applyTyCon synchVarPrimTyCon [s, elt]
 
 \begin{code}
 stablePtrPrimTyCon = pcPrimTyCon stablePtrPrimTyConKey SLIT("StablePtr#") 1
-			(\ [elt_kind] -> StablePtrKind)
+			(\ [elt_kind] -> StablePtrRep)
 
 mkStablePtrPrimTy ty = applyTyCon stablePtrPrimTyCon [ty]
 \end{code}
@@ -158,5 +203,5 @@ could possibly be added?)
 
 \begin{code}
 mallocPtrPrimTyCon = pcPrimTyCon mallocPtrPrimTyConKey SLIT("MallocPtr#") 0
-			(\ [] -> MallocPtrKind)
+			(\ [] -> MallocPtrRep)
 \end{code}
diff --git a/ghc/compiler/prelude/TysWiredIn.hi b/ghc/compiler/prelude/TysWiredIn.hi
deleted file mode 100644
index 69998008e2..0000000000
--- a/ghc/compiler/prelude/TysWiredIn.hi
+++ /dev/null
@@ -1,77 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface TysWiredIn where
-import Id(Id)
-import TyCon(TyCon)
-import UniType(UniType)
-addrDataCon :: Id
-addrTy :: UniType
-addrTyCon :: TyCon
-boolTy :: UniType
-boolTyCon :: TyCon
-charDataCon :: Id
-charTy :: UniType
-charTyCon :: TyCon
-cmpTagTy :: UniType
-cmpTagTyCon :: TyCon
-consDataCon :: Id
-doubleDataCon :: Id
-doubleTy :: UniType
-doubleTyCon :: TyCon
-eqPrimDataCon :: Id
-falseDataCon :: Id
-floatDataCon :: Id
-floatTy :: UniType
-floatTyCon :: TyCon
-getStatePairingConInfo :: UniType -> (Id, UniType)
-gtPrimDataCon :: Id
-intDataCon :: Id
-intTy :: UniType
-intTyCon :: TyCon
-integerDataCon :: Id
-integerTy :: UniType
-integerTyCon :: TyCon
-liftDataCon :: Id
-liftTyCon :: TyCon
-listTyCon :: TyCon
-ltPrimDataCon :: Id
-mallocPtrTyCon :: TyCon
-mkLiftTy :: UniType -> UniType
-mkListTy :: UniType -> UniType
-mkPrimIoTy :: UniType -> UniType
-mkStateTransformerTy :: UniType -> UniType -> UniType
-mkTupleTy :: Int -> [UniType] -> UniType
-nilDataCon :: Id
-primIoTyCon :: TyCon
-ratioDataCon :: Id
-ratioTyCon :: TyCon
-rationalTy :: UniType
-rationalTyCon :: TyCon
-realWorldStateTy :: UniType
-return2GMPsTyCon :: TyCon
-returnIntAndGMPTyCon :: TyCon
-stTyCon :: TyCon
-stablePtrTyCon :: TyCon
-stateAndAddrPrimTyCon :: TyCon
-stateAndArrayPrimTyCon :: TyCon
-stateAndByteArrayPrimTyCon :: TyCon
-stateAndCharPrimTyCon :: TyCon
-stateAndDoublePrimTyCon :: TyCon
-stateAndFloatPrimTyCon :: TyCon
-stateAndIntPrimTyCon :: TyCon
-stateAndMallocPtrPrimTyCon :: TyCon
-stateAndMutableArrayPrimTyCon :: TyCon
-stateAndMutableByteArrayPrimTyCon :: TyCon
-stateAndPtrPrimTyCon :: TyCon
-stateAndStablePtrPrimTyCon :: TyCon
-stateAndSynchVarPrimTyCon :: TyCon
-stateAndWordPrimTyCon :: TyCon
-stateDataCon :: Id
-stateTyCon :: TyCon
-stringTy :: UniType
-stringTyCon :: TyCon
-trueDataCon :: Id
-unitTy :: UniType
-wordDataCon :: Id
-wordTy :: UniType
-wordTyCon :: TyCon
-
diff --git a/ghc/compiler/prelude/TysWiredIn.lhs b/ghc/compiler/prelude/TysWiredIn.lhs
index b0b198cc60..514682d864 100644
--- a/ghc/compiler/prelude/TysWiredIn.lhs
+++ b/ghc/compiler/prelude/TysWiredIn.lhs
@@ -21,19 +21,17 @@ module TysWiredIn (
 	charDataCon,
 	charTy,
 	charTyCon,
-	cmpTagTy,
-	cmpTagTyCon,
 	consDataCon,
 	doubleDataCon,
 	doubleTy,
 	doubleTyCon,
-	eqPrimDataCon,
+	eqDataCon,
 	falseDataCon,
 	floatDataCon,
 	floatTy,
 	floatTyCon,
 	getStatePairingConInfo,
-	gtPrimDataCon,
+	gtDataCon,
 	intDataCon,
 	intTy,
 	intTyCon,
@@ -43,7 +41,7 @@ module TysWiredIn (
 	liftDataCon,
 	liftTyCon,
 	listTyCon,
-	ltPrimDataCon,
+	ltDataCon,
 	mallocPtrTyCon,
 	mkLiftTy,
 	mkListTy,
@@ -51,6 +49,8 @@ module TysWiredIn (
 	mkStateTransformerTy,
 	mkTupleTy,
 	nilDataCon,
+	orderingTy,
+	orderingTyCon,
 	primIoTyCon,
 	ratioDataCon,
 	ratioTyCon,
@@ -84,22 +84,56 @@ module TysWiredIn (
 	wordDataCon,
 	wordTy,
 	wordTyCon
+
     ) where
 
-import Pretty		--ToDo:rm debugging only
+import Ubiq
+import TyLoop		( mkDataCon, StrictnessMark(..) )
 
-import PrelFuns		-- help functions, types and things
+-- friends:
+import PrelMods
 import TysPrim
 
-import AbsUniType	( applyTyCon, mkTupleTyCon, mkSynonymTyCon,
-			  getUniDataTyCon_maybe, mkSigmaTy, TyCon
-			  , pprUniType --ToDo: rm debugging only
-			  IF_ATTACK_PRAGMAS(COMMA cmpTyCon)
-			)
-import IdInfo
-import Maybes		( Maybe(..) )
+-- others:
+import SpecEnv		( SpecEnv(..) )
+import NameTypes	( mkPreludeCoreName, mkShortName )
+import Kind		( mkBoxedTypeKind, mkArrowKind )
+import SrcLoc		( mkBuiltinSrcLoc )
+import TyCon		( mkDataTyCon, mkTupleTyCon, mkSynTyCon,
+			  ConsVisible(..), NewOrData(..), TyCon	)
+import Type		( mkTyConTy, applyTyCon, mkSynTy, mkSigmaTy,
+			  mkFunTys, maybeAppDataTyCon,
+			  GenType(..), ThetaType(..), TauType(..) )
+import TyVar		( getTyVarKind, alphaTyVar, betaTyVar )
 import Unique
-import Util
+import Util		( assoc, panic )
+
+nullSpecEnv =  error "TysWiredIn:nullSpecEnv =  "
+addOneToSpecEnv =  error "TysWiredIn:addOneToSpecEnv =  "
+pc_gen_specs = error "TysWiredIn:pc_gen_specs  "
+mkSpecInfo = error "TysWiredIn:SpecInfo"
+
+pcDataTyCon :: Unique{-TyConKey-} -> FAST_STRING -> FAST_STRING -> [TyVar] -> [Id] -> TyCon
+pcDataTyCon key mod name tyvars cons
+  = mkDataTyCon key tycon_kind full_name tyvars
+		[{-no context-}] cons [{-no derivings-}]
+		ConsVisible DataType
+  where
+    full_name = mkPreludeCoreName mod name
+    tycon_kind = foldr (mkArrowKind . getTyVarKind) mkBoxedTypeKind tyvars
+
+pcDataCon :: Unique{-DataConKey-} -> FAST_STRING -> FAST_STRING -> [TyVar] -> ThetaType -> [TauType] -> TyCon -> SpecEnv -> Id
+pcDataCon key mod name tyvars context arg_tys tycon specenv
+  = mkDataCon key (mkPreludeCoreName mod name)
+	[ NotMarkedStrict | a <- arg_tys ]
+	tyvars context arg_tys tycon
+	-- specenv
+
+pcGenerateDataSpecs :: Type -> SpecEnv
+pcGenerateDataSpecs ty
+  = pc_gen_specs False err err err ty
+  where
+    err = panic "PrelUtils:GenerateDataSpecs"
 \end{code}
 
 %************************************************************************
@@ -109,42 +143,42 @@ import Util
 %************************************************************************
 
 \begin{code}
-charTy = UniData charTyCon []
+charTy = mkTyConTy charTyCon
 
 charTyCon = pcDataTyCon charTyConKey pRELUDE_BUILTIN SLIT("Char") [] [charDataCon]
 charDataCon = pcDataCon charDataConKey pRELUDE_BUILTIN SLIT("C#") [] [] [charPrimTy] charTyCon nullSpecEnv
 \end{code}
 
 \begin{code}
-intTy = UniData intTyCon []
+intTy = mkTyConTy intTyCon 
 
 intTyCon = pcDataTyCon intTyConKey pRELUDE_BUILTIN SLIT("Int") [] [intDataCon]
-intDataCon = pcDataCon intDataConKey pRELUDE_BUILTIN SLIT("I#") [] [] [intPrimTy] intTyCon nullSpecEnv 
+intDataCon = pcDataCon intDataConKey pRELUDE_BUILTIN SLIT("I#") [] [] [intPrimTy] intTyCon nullSpecEnv
 \end{code}
 
 \begin{code}
-wordTy = UniData wordTyCon []
+wordTy = mkTyConTy wordTyCon
 
 wordTyCon = pcDataTyCon wordTyConKey pRELUDE_BUILTIN SLIT("_Word") [] [wordDataCon]
 wordDataCon = pcDataCon wordDataConKey pRELUDE_BUILTIN SLIT("W#") [] [] [wordPrimTy] wordTyCon nullSpecEnv
 \end{code}
 
 \begin{code}
-addrTy = UniData addrTyCon []
+addrTy = mkTyConTy addrTyCon
 
 addrTyCon = pcDataTyCon addrTyConKey pRELUDE_BUILTIN SLIT("_Addr") [] [addrDataCon]
 addrDataCon = pcDataCon addrDataConKey pRELUDE_BUILTIN SLIT("A#") [] [] [addrPrimTy] addrTyCon nullSpecEnv
 \end{code}
 
 \begin{code}
-floatTy	= UniData floatTyCon []
+floatTy	= mkTyConTy floatTyCon
 
 floatTyCon = pcDataTyCon floatTyConKey pRELUDE_BUILTIN SLIT("Float") [] [floatDataCon]
 floatDataCon = pcDataCon floatDataConKey pRELUDE_BUILTIN SLIT("F#") [] [] [floatPrimTy] floatTyCon nullSpecEnv
 \end{code}
 
 \begin{code}
-doubleTy = UniData doubleTyCon []
+doubleTy = mkTyConTy doubleTyCon
 
 doubleTyCon = pcDataTyCon doubleTyConKey pRELUDE_BUILTIN SLIT("Double") [] [doubleDataCon]
 doubleDataCon = pcDataCon doubleDataConKey pRELUDE_BUILTIN SLIT("D#") [] [] [doublePrimTy] doubleTyCon nullSpecEnv
@@ -154,62 +188,20 @@ doubleDataCon = pcDataCon doubleDataConKey pRELUDE_BUILTIN SLIT("D#") [] [] [dou
 mkStateTy ty	 = applyTyCon stateTyCon [ty]
 realWorldStateTy = mkStateTy realWorldTy -- a common use
 
-stateTyCon = pcDataTyCon stateTyConKey pRELUDE_BUILTIN SLIT("_State") [alpha_tv] [stateDataCon]
+stateTyCon = pcDataTyCon stateTyConKey pRELUDE_BUILTIN SLIT("_State") [alphaTyVar] [stateDataCon]
 stateDataCon
   = pcDataCon stateDataConKey pRELUDE_BUILTIN SLIT("S#")
-	[alpha_tv] [] [mkStatePrimTy alpha] stateTyCon nullSpecEnv
-\end{code}
-
-\begin{code}
-{- OLD:
-byteArrayTyCon
-  = pcDataTyCon byteArrayTyConKey pRELUDE_ARRAY SLIT("_ByteArray")
-	[alpha_tv] [byteArrayDataCon]
-
-byteArrayDataCon
-  = pcDataCon byteArrayDataConKey pRELUDE_ARRAY SLIT("_ByteArray")
-	[alpha_tv] []
-	[mkTupleTy 2 [alpha, alpha], byteArrayPrimTy]
-	byteArrayTyCon nullSpecEnv
--}
-\end{code}
-
-\begin{code}
-{- OLD:
-mutableArrayTyCon
-  = pcDataTyCon mutableArrayTyConKey gLASGOW_ST SLIT("_MutableArray")
-	[alpha_tv, beta_tv, gamma_tv] [mutableArrayDataCon]
-  where
-    mutableArrayDataCon
-      = pcDataCon mutableArrayDataConKey gLASGOW_ST SLIT("_MutableArray")
-	    [alpha_tv, beta_tv, gamma_tv] []
-	    [mkTupleTy 2 [beta, beta], applyTyCon mutableArrayPrimTyCon [alpha, gamma]]
-	    mutableArrayTyCon nullSpecEnv
--}
-\end{code}
-
-\begin{code}
-{-
-mutableByteArrayTyCon
-  = pcDataTyCon mutableByteArrayTyConKey gLASGOW_ST SLIT("_MutableByteArray")
-	[alpha_tv, beta_tv] [mutableByteArrayDataCon]
-
-mutableByteArrayDataCon
-  = pcDataCon mutableByteArrayDataConKey gLASGOW_ST SLIT("_MutableByteArray")
-	[alpha_tv, beta_tv] []
-	[mkTupleTy 2 [beta, beta], mkMutableByteArrayPrimTy alpha]
-	mutableByteArrayTyCon nullSpecEnv
--}
+	[alphaTyVar] [] [mkStatePrimTy alphaTy] stateTyCon nullSpecEnv
 \end{code}
 
 \begin{code}
 stablePtrTyCon
   = pcDataTyCon stablePtrTyConKey gLASGOW_MISC SLIT("_StablePtr")
-	[alpha_tv] [stablePtrDataCon]
+	[alphaTyVar] [stablePtrDataCon]
   where
     stablePtrDataCon
       = pcDataCon stablePtrDataConKey gLASGOW_MISC SLIT("_StablePtr")
-	    [alpha_tv] [] [applyTyCon stablePtrPrimTyCon [alpha]] stablePtrTyCon nullSpecEnv
+	    [alphaTyVar] [] [applyTyCon stablePtrPrimTyCon [alphaTy]] stablePtrTyCon nullSpecEnv
 \end{code}
 
 \begin{code}
@@ -230,19 +222,13 @@ mallocPtrTyCon
 
 @Integer@ and its pals are not really primitive.  @Integer@ itself, first:
 \begin{code}
-integerTy :: UniType
-integerTy    = UniData integerTyCon []
+integerTy :: GenType t u
+integerTy    = mkTyConTy integerTyCon
 
 integerTyCon = pcDataTyCon integerTyConKey pRELUDE_BUILTIN SLIT("Integer") [] [integerDataCon]
 
-#ifndef DPH
 integerDataCon = pcDataCon integerDataConKey pRELUDE_BUILTIN SLIT("J#")
 		[] [] [intPrimTy, intPrimTy, byteArrayPrimTy] integerTyCon nullSpecEnv
-#else
--- DPH: For the time being we implement Integers in the same way as Ints.
-integerDataCon = pcDataCon integerDataConKey pRELUDE_BUILTIN SLIT("J#")
-		[] [] [intPrimTy] integerTyCon nullSpecEnv
-#endif {- Data Parallel Haskell -}
 \end{code}
 
 And the other pairing types:
@@ -279,118 +265,118 @@ We fish one of these \tr{StateAnd<blah>#} things with
 \begin{code}
 stateAndPtrPrimTyCon
   = pcDataTyCon stateAndPtrPrimTyConKey pRELUDE_BUILTIN SLIT("StateAndPtr#")
-		[alpha_tv, beta_tv] [stateAndPtrPrimDataCon]
+		[alphaTyVar, betaTyVar] [stateAndPtrPrimDataCon]
 stateAndPtrPrimDataCon
   = pcDataCon stateAndPtrPrimDataConKey pRELUDE_BUILTIN SLIT("StateAndPtr#")
-		[alpha_tv, beta_tv] [] [mkStatePrimTy alpha, beta]
+		[alphaTyVar, betaTyVar] [] [mkStatePrimTy alphaTy, betaTy]
 		stateAndPtrPrimTyCon nullSpecEnv
 
 stateAndCharPrimTyCon
   = pcDataTyCon stateAndCharPrimTyConKey pRELUDE_BUILTIN SLIT("StateAndChar#")
-		[alpha_tv] [stateAndCharPrimDataCon]
+		[alphaTyVar] [stateAndCharPrimDataCon]
 stateAndCharPrimDataCon
   = pcDataCon stateAndCharPrimDataConKey pRELUDE_BUILTIN SLIT("StateAndChar#")
-		[alpha_tv] [] [mkStatePrimTy alpha, charPrimTy]
+		[alphaTyVar] [] [mkStatePrimTy alphaTy, charPrimTy]
 		stateAndCharPrimTyCon nullSpecEnv
 
 stateAndIntPrimTyCon
   = pcDataTyCon stateAndIntPrimTyConKey pRELUDE_BUILTIN SLIT("StateAndInt#")
-		[alpha_tv] [stateAndIntPrimDataCon]
+		[alphaTyVar] [stateAndIntPrimDataCon]
 stateAndIntPrimDataCon
   = pcDataCon stateAndIntPrimDataConKey pRELUDE_BUILTIN SLIT("StateAndInt#")
-		[alpha_tv] [] [mkStatePrimTy alpha, intPrimTy]
+		[alphaTyVar] [] [mkStatePrimTy alphaTy, intPrimTy]
 		stateAndIntPrimTyCon nullSpecEnv
 
 stateAndWordPrimTyCon
   = pcDataTyCon stateAndWordPrimTyConKey pRELUDE_BUILTIN SLIT("StateAndWord#")
-		[alpha_tv] [stateAndWordPrimDataCon]
+		[alphaTyVar] [stateAndWordPrimDataCon]
 stateAndWordPrimDataCon
   = pcDataCon stateAndWordPrimDataConKey pRELUDE_BUILTIN SLIT("StateAndWord#")
-		[alpha_tv] [] [mkStatePrimTy alpha, wordPrimTy]
+		[alphaTyVar] [] [mkStatePrimTy alphaTy, wordPrimTy]
 		stateAndWordPrimTyCon nullSpecEnv
 
 stateAndAddrPrimTyCon
   = pcDataTyCon stateAndAddrPrimTyConKey pRELUDE_BUILTIN SLIT("StateAndAddr#")
-		[alpha_tv] [stateAndAddrPrimDataCon]
+		[alphaTyVar] [stateAndAddrPrimDataCon]
 stateAndAddrPrimDataCon
   = pcDataCon stateAndAddrPrimDataConKey pRELUDE_BUILTIN SLIT("StateAndAddr#")
-		[alpha_tv] [] [mkStatePrimTy alpha, addrPrimTy]
+		[alphaTyVar] [] [mkStatePrimTy alphaTy, addrPrimTy]
 		stateAndAddrPrimTyCon nullSpecEnv
 
 stateAndStablePtrPrimTyCon
   = pcDataTyCon stateAndStablePtrPrimTyConKey pRELUDE_BUILTIN SLIT("StateAndStablePtr#")
-		[alpha_tv, beta_tv] [stateAndStablePtrPrimDataCon]
+		[alphaTyVar, betaTyVar] [stateAndStablePtrPrimDataCon]
 stateAndStablePtrPrimDataCon
   = pcDataCon stateAndStablePtrPrimDataConKey pRELUDE_BUILTIN SLIT("StateAndStablePtr#")
-		[alpha_tv, beta_tv] []
-		[mkStatePrimTy alpha, applyTyCon stablePtrPrimTyCon [beta]]
+		[alphaTyVar, betaTyVar] []
+		[mkStatePrimTy alphaTy, applyTyCon stablePtrPrimTyCon [betaTy]]
 		stateAndStablePtrPrimTyCon nullSpecEnv
 
 stateAndMallocPtrPrimTyCon
   = pcDataTyCon stateAndMallocPtrPrimTyConKey pRELUDE_BUILTIN SLIT("StateAndMallocPtr#")
-		[alpha_tv] [stateAndMallocPtrPrimDataCon]
+		[alphaTyVar] [stateAndMallocPtrPrimDataCon]
 stateAndMallocPtrPrimDataCon
   = pcDataCon stateAndMallocPtrPrimDataConKey pRELUDE_BUILTIN SLIT("StateAndMallocPtr#")
-		[alpha_tv] []
-		[mkStatePrimTy alpha, applyTyCon mallocPtrPrimTyCon []]
+		[alphaTyVar] []
+		[mkStatePrimTy alphaTy, applyTyCon mallocPtrPrimTyCon []]
 		stateAndMallocPtrPrimTyCon nullSpecEnv
 
 stateAndFloatPrimTyCon
   = pcDataTyCon stateAndFloatPrimTyConKey pRELUDE_BUILTIN SLIT("StateAndFloat#")
-		[alpha_tv] [stateAndFloatPrimDataCon]
+		[alphaTyVar] [stateAndFloatPrimDataCon]
 stateAndFloatPrimDataCon
   = pcDataCon stateAndFloatPrimDataConKey pRELUDE_BUILTIN SLIT("StateAndFloat#")
-		[alpha_tv] [] [mkStatePrimTy alpha, floatPrimTy]
+		[alphaTyVar] [] [mkStatePrimTy alphaTy, floatPrimTy]
 		stateAndFloatPrimTyCon nullSpecEnv
 
 stateAndDoublePrimTyCon
   = pcDataTyCon stateAndDoublePrimTyConKey pRELUDE_BUILTIN SLIT("StateAndDouble#")
-		[alpha_tv] [stateAndDoublePrimDataCon]
+		[alphaTyVar] [stateAndDoublePrimDataCon]
 stateAndDoublePrimDataCon
   = pcDataCon stateAndDoublePrimDataConKey pRELUDE_BUILTIN SLIT("StateAndDouble#")
-		[alpha_tv] [] [mkStatePrimTy alpha, doublePrimTy]
+		[alphaTyVar] [] [mkStatePrimTy alphaTy, doublePrimTy]
 		stateAndDoublePrimTyCon nullSpecEnv
 \end{code}
 
 \begin{code}
 stateAndArrayPrimTyCon
   = pcDataTyCon stateAndArrayPrimTyConKey pRELUDE_BUILTIN SLIT("StateAndArray#")
-		[alpha_tv, beta_tv] [stateAndArrayPrimDataCon]
+		[alphaTyVar, betaTyVar] [stateAndArrayPrimDataCon]
 stateAndArrayPrimDataCon
   = pcDataCon stateAndArrayPrimDataConKey pRELUDE_BUILTIN SLIT("StateAndArray#")
-		[alpha_tv, beta_tv] [] [mkStatePrimTy alpha, mkArrayPrimTy beta]
+		[alphaTyVar, betaTyVar] [] [mkStatePrimTy alphaTy, mkArrayPrimTy betaTy]
 		stateAndArrayPrimTyCon nullSpecEnv
 
 stateAndMutableArrayPrimTyCon
   = pcDataTyCon stateAndMutableArrayPrimTyConKey pRELUDE_BUILTIN SLIT("StateAndMutableArray#")
-		[alpha_tv, beta_tv] [stateAndMutableArrayPrimDataCon]
+		[alphaTyVar, betaTyVar] [stateAndMutableArrayPrimDataCon]
 stateAndMutableArrayPrimDataCon
   = pcDataCon stateAndMutableArrayPrimDataConKey pRELUDE_BUILTIN SLIT("StateAndMutableArray#")
-		[alpha_tv, beta_tv] [] [mkStatePrimTy alpha, mkMutableArrayPrimTy alpha beta]
+		[alphaTyVar, betaTyVar] [] [mkStatePrimTy alphaTy, mkMutableArrayPrimTy alphaTy betaTy]
 		stateAndMutableArrayPrimTyCon nullSpecEnv
 
 stateAndByteArrayPrimTyCon
   = pcDataTyCon stateAndByteArrayPrimTyConKey pRELUDE_BUILTIN SLIT("StateAndByteArray#")
-		[alpha_tv] [stateAndByteArrayPrimDataCon]
+		[alphaTyVar] [stateAndByteArrayPrimDataCon]
 stateAndByteArrayPrimDataCon
   = pcDataCon stateAndByteArrayPrimDataConKey pRELUDE_BUILTIN SLIT("StateAndByteArray#")
-		[alpha_tv] [] [mkStatePrimTy alpha, byteArrayPrimTy]
+		[alphaTyVar] [] [mkStatePrimTy alphaTy, byteArrayPrimTy]
 		stateAndByteArrayPrimTyCon nullSpecEnv
 
 stateAndMutableByteArrayPrimTyCon
   = pcDataTyCon stateAndMutableByteArrayPrimTyConKey pRELUDE_BUILTIN SLIT("StateAndMutableByteArray#")
-		[alpha_tv] [stateAndMutableByteArrayPrimDataCon]
+		[alphaTyVar] [stateAndMutableByteArrayPrimDataCon]
 stateAndMutableByteArrayPrimDataCon
   = pcDataCon stateAndMutableByteArrayPrimDataConKey pRELUDE_BUILTIN SLIT("StateAndMutableByteArray#")
-		[alpha_tv] [] [mkStatePrimTy alpha, applyTyCon mutableByteArrayPrimTyCon [alpha]]
+		[alphaTyVar] [] [mkStatePrimTy alphaTy, applyTyCon mutableByteArrayPrimTyCon [alphaTy]]
 		stateAndMutableByteArrayPrimTyCon nullSpecEnv
 
 stateAndSynchVarPrimTyCon
   = pcDataTyCon stateAndSynchVarPrimTyConKey pRELUDE_BUILTIN SLIT("StateAndSynchVar#")
-		[alpha_tv, beta_tv] [stateAndSynchVarPrimDataCon]
+		[alphaTyVar, betaTyVar] [stateAndSynchVarPrimDataCon]
 stateAndSynchVarPrimDataCon
   = pcDataCon stateAndSynchVarPrimDataConKey pRELUDE_BUILTIN SLIT("StateAndSynchVar#")
-		[alpha_tv, beta_tv] [] [mkStatePrimTy alpha, mkSynchVarPrimTy alpha beta]
+		[alphaTyVar, betaTyVar] [] [mkStatePrimTy alphaTy, mkSynchVarPrimTy alphaTy betaTy]
 		stateAndSynchVarPrimTyCon nullSpecEnv
 \end{code}
 
@@ -400,12 +386,12 @@ how many types to drop from \tr{tys_applied}.
 
 \begin{code}
 getStatePairingConInfo
-	:: UniType	-- primitive type
+	:: Type	-- primitive type
 	-> (Id,		-- state pair constructor for prim type
-	    UniType)	-- type of state pair
+	    Type)	-- type of state pair
 
 getStatePairingConInfo prim_ty
-  = case (getUniDataTyCon_maybe prim_ty) of
+  = case (maybeAppDataTyCon prim_ty) of
       Nothing -> panic "getStatePairingConInfo:1"
       Just (prim_tycon, tys_applied, _) ->
 	let
@@ -441,16 +427,16 @@ getStatePairingConInfo prim_ty
 This is really just an ordinary synonym, except it is ABSTRACT.
 
 \begin{code}
-mkStateTransformerTy s a = applyTyCon stTyCon [s, a]
+mkStateTransformerTy s a = mkSynTy stTyCon [s, a]
 
 stTyCon
-  = mkSynonymTyCon
+  = mkSynTyCon
      stTyConKey
      (mkPreludeCoreName gLASGOW_ST SLIT("_ST"))
+     (panic "TysWiredIn.stTyCon:Kind")
      2
-     [alpha_tv, beta_tv]
-     (mkStateTy alpha `UniFun` mkTupleTy 2 [beta, mkStateTy alpha])
-     True -- ToDo: make... *** ABSTRACT ***
+     [alphaTyVar, betaTyVar]
+     (mkFunTys [mkStateTy alphaTy] (mkTupleTy 2 [betaTy, mkStateTy alphaTy]))
 \end{code}
 
 %************************************************************************
@@ -459,19 +445,19 @@ stTyCon
 %*									*
 %************************************************************************
 
-@PrimIO@ and @IO@ really are just a plain synonyms.
+@PrimIO@ and @IO@ really are just plain synonyms.
 
 \begin{code}
-mkPrimIoTy a = applyTyCon primIoTyCon [a]
+mkPrimIoTy a = mkSynTy primIoTyCon [a]
 
 primIoTyCon
-  = mkSynonymTyCon
+  = mkSynTyCon
      primIoTyConKey
      (mkPreludeCoreName pRELUDE_PRIMIO SLIT("PrimIO"))
+     (panic "TysWiredIn.primIoTyCon:Kind")
      1
-     [alpha_tv]
-     (mkStateTransformerTy realWorldTy alpha)
-     True -- need not be abstract
+     [alphaTyVar]
+     (mkStateTransformerTy realWorldTy alphaTy)
 \end{code}
 
 %************************************************************************
@@ -523,7 +509,7 @@ primitive counterpart.
 {\em END IDLE SPECULATION BY SIMON}
 
 \begin{code}
-boolTy = UniData boolTyCon []
+boolTy = mkTyConTy boolTyCon
 
 boolTyCon = pcDataTyCon boolTyConKey pRELUDE_CORE SLIT("Bool") [] [falseDataCon, trueDataCon]
 
@@ -533,23 +519,23 @@ trueDataCon  = pcDataCon trueDataConKey	 pRELUDE_CORE SLIT("True")  [] [] [] boo
 
 %************************************************************************
 %*									*
-\subsection[TysWiredIn-CMP-TAG]{The @CMP_TAG#@ type (for fast `derived' comparisons)}
+\subsection[TysWiredIn-Ordering]{The @Ordering@ type}
 %*									*
 %************************************************************************
 
 \begin{code}
 ---------------------------------------------
--- data _CMP_TAG = _LT | _EQ | _GT deriving ()
+-- data Ordering = LT | EQ | GT deriving ()
 ---------------------------------------------
 
-cmpTagTy = UniData cmpTagTyCon []
+orderingTy = mkTyConTy orderingTyCon
 
-cmpTagTyCon = pcDataTyCon cmpTagTyConKey pRELUDE_BUILTIN SLIT("_CMP_TAG") []
-		[ltPrimDataCon, eqPrimDataCon, gtPrimDataCon]
+orderingTyCon = pcDataTyCon orderingTyConKey pRELUDE_BUILTIN SLIT("Ordering") []
+		            [ltDataCon, eqDataCon, gtDataCon]
 
-ltPrimDataCon  = pcDataCon ltTagDataConKey pRELUDE_BUILTIN SLIT("_LT") [] [] [] cmpTagTyCon nullSpecEnv
-eqPrimDataCon  = pcDataCon eqTagDataConKey pRELUDE_BUILTIN SLIT("_EQ") [] [] [] cmpTagTyCon nullSpecEnv
-gtPrimDataCon  = pcDataCon gtTagDataConKey pRELUDE_BUILTIN SLIT("_GT") [] [] [] cmpTagTyCon nullSpecEnv
+ltDataCon  = pcDataCon ltDataConKey pRELUDE_BUILTIN SLIT("LT") [] [] [] orderingTyCon nullSpecEnv
+eqDataCon  = pcDataCon eqDataConKey pRELUDE_BUILTIN SLIT("EQ") [] [] [] orderingTyCon nullSpecEnv
+gtDataCon  = pcDataCon gtDataConKey pRELUDE_BUILTIN SLIT("GT") [] [] [] orderingTyCon nullSpecEnv
 \end{code}
 
 %************************************************************************
@@ -562,35 +548,28 @@ Special syntax, deeply wired in, but otherwise an ordinary algebraic
 data type:
 \begin{verbatim}
 data List a = Nil | a : (List a)
+ToDo: data [] a = [] | a : (List a)
+ToDo: data () = ()
+      data (,,) a b c = (,,) a b c
 \end{verbatim}
 
 \begin{code}
-mkListTy :: UniType -> UniType
-mkListTy ty = UniData listTyCon [ty]
+mkListTy :: GenType t u -> GenType t u
+mkListTy ty = applyTyCon listTyCon [ty]
 
-alphaListTy = mkSigmaTy [alpha_tv] [] (mkListTy alpha)
+alphaListTy = mkSigmaTy [alphaTyVar] [] (applyTyCon listTyCon [alphaTy])
 
-listTyCon = pcDataTyCon listTyConKey pRELUDE_BUILTIN SLIT("List") [alpha_tv] [nilDataCon, consDataCon]
+listTyCon = pcDataTyCon listTyConKey pRELUDE_BUILTIN SLIT("[]") 
+			[alphaTyVar] [nilDataCon, consDataCon]
 
-nilDataCon  = pcDataCon nilDataConKey  pRELUDE_BUILTIN SLIT("Nil") [alpha_tv] [] [] listTyCon
+nilDataCon  = pcDataCon nilDataConKey  pRELUDE_BUILTIN SLIT("[]") [alphaTyVar] [] [] listTyCon
 		(pcGenerateDataSpecs alphaListTy)
 consDataCon = pcDataCon consDataConKey pRELUDE_BUILTIN SLIT(":")
-		[alpha_tv] [] [alpha, mkListTy alpha] listTyCon
+		[alphaTyVar] [] [alphaTy, applyTyCon listTyCon [alphaTy]] listTyCon
 		(pcGenerateDataSpecs alphaListTy)
-\end{code}
-
-This is the @_Build@ data constructor, it does {\em not} appear inside
-listTyCon.  It has this type: \tr{((a -> b -> b) -> b -> b) -> [a]}.
-\begin{code}
-{- NOT USED:
-buildDataCon
-  = pcDataCon buildDataConKey  pRELUDE_BUILTIN "Build"
-	[alpha_tv] [] [
-		mkSigmaTy [beta_tv] []
-			((alpha `UniFun` (beta `UniFun` beta))
-			`UniFun` (beta
-			`UniFun` beta))] listTyCon nullSpecEnv
--}
+-- Interesting: polymorphic recursion would help here.
+-- We can't use (mkListTy alphaTy) in the defn of consDataCon, else mkListTy
+-- gets the over-specific type (Type -> Type)
 \end{code}
 
 %************************************************************************
@@ -604,14 +583,12 @@ family.
 
 \begin{itemize}
 \item
-They have a special family of type constructors, of type
-@TyCon@\srcloc{uniType/TyCon.lhs}.
+They have a special family of type constructors, of type @TyCon@
 These contain the tycon arity, but don't require a Unique.
 
 \item
 They have a special family of constructors, of type
-@Id@\srcloc{basicTypes/Id.lhs}.	 Again these contain their arity but
-don't need a Unique.
+@Id@. Again these contain their arity but don't need a Unique.
 
 \item
 There should be a magic way of generating the info tables and
@@ -642,11 +619,11 @@ done by enumeration\srcloc{lib/prelude/InTup?.hs}.
 \end{itemize}
 
 \begin{code}
-mkTupleTy :: Int -> [UniType] -> UniType
+mkTupleTy :: Int -> [GenType t u] -> GenType t u
 
 mkTupleTy arity tys = applyTyCon (mkTupleTyCon arity) tys
 
-unitTy = mkTupleTy 0 []
+unitTy    = mkTupleTy 0 []
 \end{code}
 
 %************************************************************************
@@ -658,25 +635,25 @@ unitTy = mkTupleTy 0 []
 ToDo: make this (mostly) go away.
 
 \begin{code}
-rationalTy :: UniType
+rationalTy :: GenType t u
 
-mkRatioTy ty = UniData ratioTyCon [ty]
+mkRatioTy ty = applyTyCon ratioTyCon [ty]
 rationalTy   = mkRatioTy integerTy
 
-ratioTyCon = pcDataTyCon ratioTyConKey pRELUDE_RATIO SLIT("Ratio") [alpha_tv] [ratioDataCon]
+ratioTyCon = pcDataTyCon ratioTyConKey pRELUDE_RATIO SLIT("Ratio") [alphaTyVar] [ratioDataCon]
 
 ratioDataCon = pcDataCon ratioDataConKey pRELUDE_RATIO SLIT(":%")
-		[alpha_tv] [{-(integralClass,alpha)-}] [alpha, alpha] ratioTyCon nullSpecEnv
+		[alphaTyVar] [{-(integralClass,alphaTy)-}] [alphaTy, alphaTy] ratioTyCon nullSpecEnv
 	-- context omitted to match lib/prelude/ defn of "data Ratio ..."
 
 rationalTyCon
-  = mkSynonymTyCon
+  = mkSynTyCon
       rationalTyConKey
       (mkPreludeCoreName pRELUDE_RATIO SLIT("Rational"))
+      mkBoxedTypeKind
       0	 -- arity
       [] -- tyvars
       rationalTy -- == mkRatioTy integerTy
-      True -- unabstract
 \end{code}
 
 %************************************************************************
@@ -692,29 +669,29 @@ mkLiftTy ty = applyTyCon liftTyCon [ty]
 
 {-
 mkLiftTy ty
-  = mkSigmaTy tvs theta (UniData liftTyCon [tau])
+  = mkSigmaTy tvs theta (applyTyCon liftTyCon [tau])
   where
-    (tvs, theta, tau) = splitType ty
+    (tvs, theta, tau) = splitSigmaTy ty
 
 isLiftTy ty
-  = case getUniDataTyCon_maybe tau of
+  = case maybeAppDataTyCon tau of
       Just (tycon, tys, _) -> tycon == liftTyCon
       Nothing -> False
   where
-    (tvs, theta, tau) = splitType ty
+    (tvs, theta, tau) = splitSigmaTy ty
 -}
 
 
-alphaLiftTy = mkSigmaTy [alpha_tv] [] (UniData liftTyCon [alpha])
+alphaLiftTy = mkSigmaTy [alphaTyVar] [] (applyTyCon liftTyCon [alphaTy])
 
 liftTyCon
-  = pcDataTyCon liftTyConKey pRELUDE_BUILTIN SLIT("_Lift") [alpha_tv] [liftDataCon]
+  = pcDataTyCon liftTyConKey pRELUDE_BUILTIN SLIT("_Lift") [alphaTyVar] [liftDataCon]
 
 liftDataCon
   = pcDataCon liftDataConKey pRELUDE_BUILTIN SLIT("_Lift")
-		[alpha_tv] [] [alpha] liftTyCon 
+		[alphaTyVar] [] [alphaTy] liftTyCon
 		((pcGenerateDataSpecs alphaLiftTy) `addOneToSpecEnv`
-		 (SpecInfo [Just realWorldStatePrimTy] 0 bottom))
+		 (mkSpecInfo [Just realWorldStatePrimTy] 0 bottom))
   where
     bottom = panic "liftDataCon:State# _RealWorld"
 \end{code}
@@ -730,29 +707,11 @@ liftDataCon
 stringTy = mkListTy charTy
 
 stringTyCon
- = mkSynonymTyCon
+ = mkSynTyCon
      stringTyConKey
      (mkPreludeCoreName pRELUDE_CORE SLIT("String"))
+     mkBoxedTypeKind
      0
      []   -- type variables
      stringTy
-     True -- unabstract
-\end{code}
-
-\begin{code}
-{- UNUSED:
-packedStringTy = applyTyCon packedStringTyCon []
-
-packedStringTyCon
-  = pcDataTyCon packedStringTyConKey pRELUDE_PS SLIT("_PackedString") []
-	[psDataCon, cpsDataCon]
-
-psDataCon
-  = pcDataCon psDataConKey pRELUDE_PS SLIT("_PS")
-		[] [] [intPrimTy, byteArrayPrimTy] packedStringTyCon
-
-cpsDataCon
-  = pcDataCon cpsDataConKey pRELUDE_PS SLIT("_CPS")
-		[] [] [addrPrimTy] packedStringTyCon
--}
 \end{code}
diff --git a/ghc/compiler/profiling/CostCentre.hi b/ghc/compiler/profiling/CostCentre.hi
deleted file mode 100644
index abb818df97..0000000000
--- a/ghc/compiler/profiling/CostCentre.hi
+++ /dev/null
@@ -1,45 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface CostCentre where
-import CharSeq(CSeq)
-import Id(Id)
-import Maybes(Labda)
-import PreludePS(_PackedString)
-import Pretty(PprStyle)
-import Unpretty(Unpretty(..))
-data CSeq 
-data CcKind 
-data CostCentre 
-data Id 
-data IsCafCC   = IsCafCC | IsNotCafCC
-data IsDupdCC 
-data Labda a 
-type Unpretty = CSeq
-cafifyCC :: CostCentre -> CostCentre
-ccFromThisModule :: CostCentre -> _PackedString -> Bool
-ccMentionsId :: CostCentre -> Labda Id
-cmpCostCentre :: CostCentre -> CostCentre -> Int#
-costsAreSubsumed :: CostCentre -> Bool
-currentOrSubsumedCosts :: CostCentre -> Bool
-dontCareCostCentre :: CostCentre
-dupifyCC :: CostCentre -> CostCentre
-isCafCC :: CostCentre -> Bool
-isDictCC :: CostCentre -> Bool
-isDupdCC :: CostCentre -> Bool
-mkAllCafsCC :: _PackedString -> _PackedString -> CostCentre
-mkAllDictsCC :: _PackedString -> _PackedString -> Bool -> CostCentre
-mkAutoCC :: Id -> _PackedString -> _PackedString -> IsCafCC -> CostCentre
-mkDictCC :: Id -> _PackedString -> _PackedString -> IsCafCC -> CostCentre
-mkUserCC :: _PackedString -> _PackedString -> _PackedString -> CostCentre
-noCostCentre :: CostCentre
-noCostCentreAttached :: CostCentre -> Bool
-overheadCostCentre :: CostCentre
-preludeCafsCostCentre :: CostCentre
-preludeDictsCostCentre :: Bool -> CostCentre
-setToAbleCostCentre :: CostCentre -> Bool
-showCostCentre :: PprStyle -> Bool -> CostCentre -> [Char]
-subsumedCosts :: CostCentre
-unCafifyCC :: CostCentre -> CostCentre
-uppCostCentre :: PprStyle -> Bool -> CostCentre -> CSeq
-uppCostCentreDecl :: PprStyle -> Bool -> CostCentre -> CSeq
-useCurrentCostCentre :: CostCentre
-
diff --git a/ghc/compiler/profiling/CostCentre.lhs b/ghc/compiler/profiling/CostCentre.lhs
index 2b06375e83..f9d5a61913 100644
--- a/ghc/compiler/profiling/CostCentre.lhs
+++ b/ghc/compiler/profiling/CostCentre.lhs
@@ -1,5 +1,5 @@
 %
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
 %
 \section[CostCentre]{The @CostCentre@ data type}
 
@@ -24,22 +24,21 @@ module CostCentre (
 
 	uppCostCentre, uppCostCentreDecl, showCostCentre, -- printing
 
-	cmpCostCentre,	-- used for removing dups in a list
-
-	Id, Maybe, Unpretty(..), CSeq
+	cmpCostCentre	-- used for removing dups in a list
     ) where
 
-import CmdLineOpts	( GlobalSwitch(..) )
-import CLabelInfo	( identToC, stringToC )
-import Id		( cmpId, showId, pprIdInUnfolding,
-			  externallyVisibleId, Id
-			)
+import Id		( externallyVisibleId, GenId, Id(..) )
+import CStrings		( identToC, stringToC )
 import Maybes		( Maybe(..) )
 import Outputable
 import Pretty		( ppShow, prettyToUn )
+import PprStyle		( PprStyle(..) )
 import UniqSet
 import Unpretty
 import Util
+import Ubiq
+showId = panic "Whoops"
+pprIdInUnfolding = panic "Whoops"
 \end{code}
 
 \begin{code}
@@ -161,7 +160,7 @@ currentOrSubsumedCosts _		= False
 
 mkUserCC :: FAST_STRING -> FAST_STRING -> FAST_STRING -> CostCentre
 
-mkUserCC cc_name module_name group_name 
+mkUserCC cc_name module_name group_name
   = NormalCC (UserCC cc_name) module_name group_name
 	     AnOriginalCC IsNotCafCC{-might be changed-}
 
@@ -291,14 +290,14 @@ cmpCostCentre other_1 other_2
     tag_CC DontCareCC	      	= ILIT(7)
 
     -- some BUG avoidance here...
-    tag_CC NoCostCentre  = case (panic "tag_CC:NoCostCentre")  of { c -> tag_CC c }
-    tag_CC SubsumedCosts = case (panic "tag_CC:SubsumedCosts") of { c -> tag_CC c }
-    tag_CC CurrentCC	 = case (panic "tag_CC:SubsumedCosts") of { c -> tag_CC c }
+    tag_CC NoCostCentre  = panic# "tag_CC:NoCostCentre"
+    tag_CC SubsumedCosts = panic# "tag_CC:SubsumedCosts"
+    tag_CC CurrentCC	 = panic# "tag_CC:SubsumedCosts"
 
 
 cmp_kind (UserCC n1) (UserCC n2) = _CMP_STRING_ n1 n2
-cmp_kind (AutoCC i1) (AutoCC i2) = cmpId i1 i2
-cmp_kind (DictCC i1) (DictCC i2) = cmpId i1 i2
+cmp_kind (AutoCC i1) (AutoCC i2) = cmp i1 i2
+cmp_kind (DictCC i1) (DictCC i2) = cmp i1 i2
 cmp_kind other_1     other_2
   = let
 	tag1 = tag_CcKind other_1
@@ -316,7 +315,7 @@ showCostCentre    :: PprStyle -> Bool -> CostCentre -> String
 uppCostCentre	  :: PprStyle -> Bool -> CostCentre -> Unpretty
 uppCostCentreDecl :: PprStyle -> Bool -> CostCentre -> Unpretty
 
-showCostCentre (PprUnfolding _) print_as_string cc
+showCostCentre PprUnfolding print_as_string cc
   = ASSERT(not print_as_string) -- we never "print as string w/ Unfolding"
     ASSERT(not (noCostCentreAttached cc))
     ASSERT(not (currentOrSubsumedCosts cc))
@@ -421,7 +420,7 @@ friendly_style sty -- i.e., probably for human consumption
 
 Printing unfoldings is sufficiently weird that we do it separately.
 This should only apply to CostCentres that can be ``set to'' (cf
-@setToAbleCostCentre@).  That excludes CAFs and 
+@setToAbleCostCentre@).  That excludes CAFs and
 `overhead'---which are added at the very end---but includes dictionaries.
 Dict \tr{_scc_}s may cross module boundaries to show ``scope'' info;
 even if we won't ultimately do a \tr{SET_CCC} from it.
diff --git a/ghc/compiler/profiling/SCCauto.hi b/ghc/compiler/profiling/SCCauto.hi
deleted file mode 100644
index cca120db39..0000000000
--- a/ghc/compiler/profiling/SCCauto.hi
+++ /dev/null
@@ -1,8 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface SCCauto where
-import CmdLineOpts(GlobalSwitch, SwitchResult)
-import CoreSyn(CoreBinding)
-import Id(Id)
-import PreludePS(_PackedString)
-addAutoCostCentres :: (GlobalSwitch -> SwitchResult) -> _PackedString -> [CoreBinding Id Id] -> [CoreBinding Id Id]
-
diff --git a/ghc/compiler/profiling/SCCauto.lhs b/ghc/compiler/profiling/SCCauto.lhs
index 1a32e5615d..ba3da63cb8 100644
--- a/ghc/compiler/profiling/SCCauto.lhs
+++ b/ghc/compiler/profiling/SCCauto.lhs
@@ -1,13 +1,13 @@
 %
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1994
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
 %
 \section[SCCauto]{Automated SCC annotations}
 
 Automatic insertion of \tr{_scc_} annotations for top-level bindings.
 
 Automatic insertion of \tr{_scc_} annotations on CAFs is better left
-until STG land.  We do DICT annotations there, too, but maybe
-that will turn out to be a bummer...  (WDP 94/06)
+until STG land.  We do DICT annotations there, too, but maybe that
+will turn out to be a bummer...  (WDP 94/06)
 
 This is a Core-to-Core pass (usually run {\em last}).
 
@@ -16,22 +16,25 @@ This is a Core-to-Core pass (usually run {\em last}).
 
 module SCCauto ( addAutoCostCentres ) where
 
-import CmdLineOpts
-import Id		( isTopLevId )
-import PlainCore
+import Ubiq{-uitous-}
+
+import CmdLineOpts	( opt_AutoSccsOnAllToplevs,
+			  opt_AutoSccsOnExportedToplevs,
+			  opt_SccGroup
+			)
+import CoreSyn
+import Id		( isTopLevId, GenId{-instances-} )
 import Outputable	( isExported )
-import CostCentre	-- ( mkAutoCC )
-import Util		-- for pragmas only
+import CostCentre	( mkAutoCC, IsCafCC(..) )
 \end{code}
 
 \begin{code}
 addAutoCostCentres
-	:: (GlobalSwitch -> SwitchResult)	-- cmd-line switches
-	-> FAST_STRING				-- module name
-	-> [PlainCoreBinding]			-- input
-	-> [PlainCoreBinding]			-- output
+	:: FAST_STRING				-- module name
+	-> [CoreBinding]			-- input
+	-> [CoreBinding]			-- output
 
-addAutoCostCentres sw_chkr mod_name binds
+addAutoCostCentres mod_name binds
   = if not doing_something then
 	binds -- now *that* was quick...
     else
@@ -39,19 +42,20 @@ addAutoCostCentres sw_chkr mod_name binds
   where
     doing_something = auto_all_switch_on || auto_exported_switch_on
 
-    auto_all_switch_on	    = switchIsOn sw_chkr AutoSccsOnAllToplevs -- only use!
-    auto_exported_switch_on = switchIsOn sw_chkr AutoSccsOnExportedToplevs -- only use!
+    auto_all_switch_on	    = opt_AutoSccsOnAllToplevs -- only use!
+    auto_exported_switch_on = opt_AutoSccsOnExportedToplevs -- only use!
 
-    grp_name  = case (stringSwitchSet sw_chkr SccGroup) of
-		  Just xx -> _PK_ xx
-		  Nothing -> mod_name	-- default: module name
+    grp_name
+      = case opt_SccGroup of
+	  Just xx -> xx
+	  Nothing -> mod_name	-- default: module name
 
     -----------------------------
-    scc_top_bind (CoNonRec binder rhs)
-      = CoNonRec binder (scc_auto binder rhs)
+    scc_top_bind (NonRec binder rhs)
+      = NonRec binder (scc_auto binder rhs)
 
-    scc_top_bind (CoRec pairs)
-      = CoRec (map scc_pair pairs)
+    scc_top_bind (Rec pairs)
+      = Rec (map scc_pair pairs)
       where
 	scc_pair (binder, rhs) = (binder, scc_auto binder rhs)
 
@@ -61,7 +65,7 @@ addAutoCostCentres sw_chkr mod_name binds
     scc_auto binder rhs
       = if isTopLevId binder
 	&& (auto_all_switch_on || isExported binder)
-        then scc_rhs rhs
+	then scc_rhs rhs
 	else rhs
       where
 	-- park auto SCC inside lambdas; don't put one there
@@ -69,12 +73,11 @@ addAutoCostCentres sw_chkr mod_name binds
 
 	scc_rhs rhs
 	  = let
-		(tyvars, vars, body) = digForLambdas rhs
+		(usevars, tyvars, vars, body) = digForLambdas rhs
 	    in
 	    case body of
-	      CoSCC _ _ -> rhs -- leave it
-	      CoCon _ _ _ --??? | null vars
-		-> rhs
-	      _ -> mkFunction tyvars vars
-			(CoSCC (mkAutoCC binder mod_name grp_name IsNotCafCC) body)
+	      SCC _ _ -> rhs -- leave it
+	      Con _ _ -> rhs
+	      _ -> mkUseLam usevars (mkLam tyvars vars
+			(SCC (mkAutoCC binder mod_name grp_name IsNotCafCC) body))
 \end{code}
diff --git a/ghc/compiler/profiling/SCCfinal.hi b/ghc/compiler/profiling/SCCfinal.hi
deleted file mode 100644
index 088fee5266..0000000000
--- a/ghc/compiler/profiling/SCCfinal.hi
+++ /dev/null
@@ -1,10 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface SCCfinal where
-import CmdLineOpts(GlobalSwitch)
-import CostCentre(CostCentre)
-import Id(Id)
-import PreludePS(_PackedString)
-import SplitUniq(SplitUniqSupply)
-import StgSyn(StgBinding)
-stgMassageForProfiling :: _PackedString -> _PackedString -> SplitUniqSupply -> (GlobalSwitch -> Bool) -> [StgBinding Id Id] -> (([CostCentre], [CostCentre]), [StgBinding Id Id])
-
diff --git a/ghc/compiler/profiling/SCCfinal.lhs b/ghc/compiler/profiling/SCCfinal.lhs
index 06d4663685..58ca3cbbd8 100644
--- a/ghc/compiler/profiling/SCCfinal.lhs
+++ b/ghc/compiler/profiling/SCCfinal.lhs
@@ -1,7 +1,7 @@
 %
 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
 %
-\section[SCCfinal]{Modify and collect code generation for final StgProgram}
+\section[SCCfinal]{Modify and collect code generation for final STG program}
 
 This is now a sort-of-normal STG-to-STG pass (WDP 94/06), run by stg2stg.
 
@@ -29,20 +29,16 @@ module SCCfinal ( stgMassageForProfiling ) where
 
 import Pretty		-- ToDo: rm (debugging only)
 
-import AbsUniType	( isDictTy, getUniDataTyCon_maybe,
-			  isTupleTyCon, isFunType, getTauType,
-			  splitType -- pragmas
-			)
+import Type		( isFunType, getTauType )
 import CmdLineOpts
 import CostCentre
-import Id		( mkSysLocal, getIdUniType )
+import Id		( mkSysLocal, idType )
 import SrcLoc		( mkUnknownSrcLoc )
 import StgSyn
-import SplitUniq
+import UniqSupply
 import UniqSet		( emptyUniqSet
 			  IF_ATTACK_PRAGMAS(COMMA emptyUFM)
 			)
-import Unique
 import Util
 
 infixr 9 `thenMM`, `thenMM_`
@@ -54,10 +50,10 @@ type CollectedCCs = ([CostCentre],  	    -- locally defined ones
 
 stgMassageForProfiling
 	:: FAST_STRING -> FAST_STRING	    -- module name, group name
-	-> SplitUniqSupply		    -- unique supply
+	-> UniqSupply		    -- unique supply
 	-> (GlobalSwitch -> Bool)	    -- command-line opts checker
-	-> [PlainStgBinding]		    -- input
-	-> (CollectedCCs, [PlainStgBinding])
+	-> [StgBinding]		    -- input
+	-> (CollectedCCs, [StgBinding])
 
 stgMassageForProfiling mod_name grp_name us sw_chkr stg_binds
   = let
@@ -76,7 +72,6 @@ stgMassageForProfiling mod_name grp_name us sw_chkr stg_binds
     ((fixed_ccs ++ local_ccs_no_dups, extern_ccs_no_dups), stg_binds2)
   where
     do_auto_sccs_on_cafs  = sw_chkr AutoSccsOnIndividualCafs  -- only use!
---UNUSED:    do_auto_sccs_on_dicts = sw_chkr AutoSccsOnIndividualDicts -- only use! ** UNUSED really **
     doing_prelude	  = sw_chkr CompilingPrelude
 
     all_cafs_cc = if doing_prelude
@@ -84,9 +79,9 @@ stgMassageForProfiling mod_name grp_name us sw_chkr stg_binds
 		  else mkAllCafsCC mod_name grp_name
 
     ----------
-    do_top_binding :: PlainStgBinding -> MassageM PlainStgBinding
+    do_top_binding :: StgBinding -> MassageM StgBinding
 
-    do_top_binding (StgNonRec b rhs) 
+    do_top_binding (StgNonRec b rhs)
       = do_top_rhs b rhs 		`thenMM` \ rhs' ->
 	returnMM (StgNonRec b rhs')
 
@@ -94,25 +89,22 @@ stgMassageForProfiling mod_name grp_name us sw_chkr stg_binds
       = mapMM do_pair pairs		`thenMM` \ pairs2 ->
 	returnMM (StgRec pairs2)
       where
-	do_pair (b, rhs) 
+	do_pair (b, rhs)
 	   = do_top_rhs b rhs	`thenMM` \ rhs2 ->
 	     returnMM (b, rhs2)
 
     ----------
-    do_top_rhs :: Id -> PlainStgRhs -> MassageM PlainStgRhs
+    do_top_rhs :: Id -> StgRhs -> MassageM StgRhs
 
-    do_top_rhs binder (StgRhsClosure rhs_cc bi fv u [] (StgSCC ty cc (StgConApp con args lvs)))
+    do_top_rhs binder (StgRhsClosure rhs_cc bi fv u [] (StgSCC ty cc (StgCon con args lvs)))
 	-- top-level _scc_ around nothing but static data; toss it -- it's pointless
       = returnMM (StgRhsCon dontCareCostCentre con args)
 
     do_top_rhs binder (StgRhsClosure rhs_cc bi fv u [] (StgSCC ty cc expr))
--- OLD:
---    | noCostCentreAttached rhs_cc || currentOrSubsumedCosts rhs_cc
---	-- doubtful guard... ToDo?
 	-- Top level CAF with explicit scc expression.  Attach CAF
 	-- cost centre to StgRhsClosure and collect.
       = let
-           calved_cc = cafifyCC cc
+	   calved_cc = cafifyCC cc
 	in
 	collectCC calved_cc	`thenMM_`
 	set_prevailing_cc calved_cc (
@@ -137,7 +129,7 @@ stgMassageForProfiling mod_name grp_name us sw_chkr stg_binds
 	set_prevailing_cc cc2 (
 	    do_expr body
 	)			`thenMM`  \body2 ->
-        returnMM (StgRhsClosure cc2 bi fv u [] body2)
+	returnMM (StgRhsClosure cc2 bi fv u [] body2)
 
     do_top_rhs binder (StgRhsClosure _ bi fv u args body@(StgSCC ty cc expr))
 	-- We blindly use the cc off the _scc_
@@ -151,7 +143,7 @@ stgMassageForProfiling mod_name grp_name us sw_chkr stg_binds
 	    cc2 = if noCostCentreAttached cc
 		  then subsumedCosts -- it's not a thunk; it is top-level & arity > 0
 		  else cc
-        in
+	in
 	set_prevailing_cc cc2 (
 	    do_expr body
 	)		`thenMM` \ body' ->
@@ -164,16 +156,16 @@ stgMassageForProfiling mod_name grp_name us sw_chkr stg_binds
 	-- just slam in dontCareCostCentre
 
     ------
-    do_expr :: PlainStgExpr -> MassageM PlainStgExpr
+    do_expr :: StgExpr -> MassageM StgExpr
 
     do_expr (StgApp fn args lvs)
       = boxHigherOrderArgs (StgApp fn) args lvs
 
-    do_expr (StgConApp con args lvs)
-      = boxHigherOrderArgs (StgConApp con) args lvs
+    do_expr (StgCon con args lvs)
+      = boxHigherOrderArgs (StgCon con) args lvs
 
-    do_expr (StgPrimApp op args lvs)
-      = boxHigherOrderArgs (StgPrimApp op) args lvs
+    do_expr (StgPrim op args lvs)
+      = boxHigherOrderArgs (StgPrim op) args lvs
 
     do_expr (StgSCC ty cc expr)	-- Ha, we found a cost centre!
       = collectCC cc		`thenMM_`
@@ -187,7 +179,7 @@ stgMassageForProfiling mod_name grp_name us sw_chkr stg_binds
 	do_alts alts		`thenMM` \ alts' ->
 	returnMM (StgCase expr' fv1 fv2 uniq alts')
       where
-	do_alts (StgAlgAlts ty alts def) 
+	do_alts (StgAlgAlts ty alts def)
 	  = mapMM do_alt alts 	`thenMM` \ alts' ->
 	    do_deflt def	`thenMM` \ def' ->
 	    returnMM (StgAlgAlts ty alts' def')
@@ -196,7 +188,7 @@ stgMassageForProfiling mod_name grp_name us sw_chkr stg_binds
 	      = do_expr e `thenMM` \ e' ->
 		returnMM (id, bs, use_mask, e')
 
-	do_alts (StgPrimAlts ty alts def) 
+	do_alts (StgPrimAlts ty alts def)
 	  = mapMM do_alt alts	`thenMM` \ alts' ->
 	    do_deflt def	`thenMM` \ def' ->
 	    returnMM (StgPrimAlts ty alts' def')
@@ -206,7 +198,7 @@ stgMassageForProfiling mod_name grp_name us sw_chkr stg_binds
 		returnMM (l,e')
 
 	do_deflt StgNoDefault = returnMM StgNoDefault
-	do_deflt (StgBindDefault b is_used e) 
+	do_deflt (StgBindDefault b is_used e)
 	  = do_expr e			`thenMM` \ e' ->
 	    returnMM (StgBindDefault b is_used e')
 
@@ -223,9 +215,9 @@ stgMassageForProfiling mod_name grp_name us sw_chkr stg_binds
 	returnMM (StgLetNoEscape lvs1 lvs2 rhs' body') )
 
     ----------
-    do_binding :: PlainStgBinding -> MassageM PlainStgBinding
+    do_binding :: StgBinding -> MassageM StgBinding
 
-    do_binding (StgNonRec b rhs) 
+    do_binding (StgNonRec b rhs)
       = do_rhs rhs 			`thenMM` \ rhs' ->
 	returnMM (StgNonRec b rhs')
 
@@ -237,13 +229,13 @@ stgMassageForProfiling mod_name grp_name us sw_chkr stg_binds
 	  = do_rhs rhs	`thenMM` \ rhs' ->
 	    returnMM (b, rhs')
 
-    do_rhs :: PlainStgRhs -> MassageM PlainStgRhs
+    do_rhs :: StgRhs -> MassageM StgRhs
 	-- We play much the same game as we did in do_top_rhs above;
 	-- but we don't have to worry about cafifying, etc.
 	-- (ToDo: consolidate??)
 
 {- Patrick says NO: it will mess up our counts (WDP 95/07)
-    do_rhs (StgRhsClosure _ bi fv u [] (StgSCC _ cc (StgConApp con args lvs)))
+    do_rhs (StgRhsClosure _ bi fv u [] (StgSCC _ cc (StgCon con args lvs)))
       = collectCC cc `thenMM_`
 	returnMM (StgRhsCon cc con args)
 -}
@@ -263,7 +255,7 @@ stgMassageForProfiling mod_name grp_name us sw_chkr stg_binds
 
     do_rhs (StgRhsCon cc con args)
       = use_prevailing_cc_maybe cc  `thenMM` \ cc2 ->
-        returnMM (StgRhsCon cc2 con args)
+	returnMM (StgRhsCon cc2 con args)
       -- ToDo: Box args (if lex) Pass back let binding???
       -- Nope: maybe later? WDP 94/06
 \end{code}
@@ -276,13 +268,13 @@ stgMassageForProfiling mod_name grp_name us sw_chkr stg_binds
 
 \begin{code}
 boxHigherOrderArgs
-    :: ([PlainStgAtom] -> PlainStgLiveVars -> PlainStgExpr)
+    :: ([StgArg] -> StgLiveVars -> StgExpr)
 	-- An application lacking its arguments and live-var info
-    -> [PlainStgAtom]	-- arguments which we might box
-    -> PlainStgLiveVars	-- live var info, which we do *not* try
+    -> [StgArg]	-- arguments which we might box
+    -> StgLiveVars	-- live var info, which we do *not* try
 			-- to maintain/update (setStgVarInfo will
 			-- do that)
-    -> MassageM PlainStgExpr
+    -> MassageM StgExpr
 
 boxHigherOrderArgs almost_expr args live_vars
   = mapAccumMM do_arg [] args	`thenMM` \ (let_bindings, new_args) ->
@@ -290,11 +282,11 @@ boxHigherOrderArgs almost_expr args live_vars
     returnMM (foldr (mk_stg_let cc) (almost_expr new_args live_vars) let_bindings)
   where
     ---------------
-    do_arg bindings atom@(StgLitAtom _) = returnMM (bindings, atom)
+    do_arg bindings atom@(StgLitArg _) = returnMM (bindings, atom)
 
-    do_arg bindings atom@(StgVarAtom old_var)
+    do_arg bindings atom@(StgVarArg old_var)
       = let
-	    var_type = getIdUniType old_var
+	    var_type = idType old_var
 	in
 	if not (is_fun_type var_type) then
 	    returnMM (bindings, atom) -- easy
@@ -304,21 +296,21 @@ boxHigherOrderArgs almost_expr args live_vars
 	    let
 		new_var = mkSysLocal SLIT("ho") uniq var_type mkUnknownSrcLoc
 	    in
-	    returnMM ( (new_var, old_var) : bindings, StgVarAtom new_var )
+	    returnMM ( (new_var, old_var) : bindings, StgVarArg new_var )
       where
 	is_fun_type ty = isFunType (getTauType ty)
 
     ---------------
-    mk_stg_let :: CostCentre -> (Id, Id) -> PlainStgExpr -> PlainStgExpr
+    mk_stg_let :: CostCentre -> (Id, Id) -> StgExpr -> StgExpr
 
     mk_stg_let cc (new_var, old_var) body
       = let
-	    rhs_body = StgApp (StgVarAtom old_var) [{-no args-}] bOGUS_LVs
+	    rhs_body = StgApp (StgVarArg old_var) [{-no args-}] bOGUS_LVs
 
 	    rhs = StgRhsClosure cc
 			stgArgOcc -- safe...
 			[{-junk-}] Updatable [{-no args-}] rhs_body
-        in
+	in
 	StgLet (StgNonRec new_var rhs) body
       where
 	bOGUS_LVs = emptyUniqSet -- easier to print than: panic "mk_stg_let: LVs"
@@ -336,14 +328,14 @@ type MassageM result
   -> CostCentre		-- prevailing CostCentre
 			-- if none, subsumedCosts at top-level
 			-- useCurrentCostCentre at nested levels
-  -> SplitUniqSupply
+  -> UniqSupply
   -> CollectedCCs
   -> (CollectedCCs, result)
 
 -- the initUs function also returns the final UniqueSupply and CollectedCCs
 
 initMM :: FAST_STRING	-- module name, which we may consult
-       -> SplitUniqSupply
+       -> UniqSupply
        -> MassageM a
        -> (CollectedCCs, a)
 
@@ -385,7 +377,7 @@ mapAccumMM f b (m:ms)
     returnMM (b3, r:rs)
 
 getUniqueMM :: MassageM Unique
-getUniqueMM mod scope_cc us ccs = (ccs, getSUnique us)
+getUniqueMM mod scope_cc us ccs = (ccs, getUnique us)
 \end{code}
 
 \begin{code}
@@ -420,7 +412,7 @@ use_prevailing_cc_maybe cc_to_try mod scope_cc us ccs
 	cc_to_use
 	  = if not (noCostCentreAttached   cc_to_try
 		 || currentOrSubsumedCosts cc_to_try) then
-	        cc_to_try
+		cc_to_try
 	    else
 		uncalved_scope_cc
 		-- carry on as before, but be sure it
diff --git a/ghc/compiler/reader/PrefixSyn.hi b/ghc/compiler/reader/PrefixSyn.hi
deleted file mode 100644
index ad4b74d10f..0000000000
--- a/ghc/compiler/reader/PrefixSyn.hi
+++ /dev/null
@@ -1,22 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface PrefixSyn where
-import HsBinds(Sig)
-import HsDecls(ClassDecl, DataTypeSig, DefaultDecl, InstDecl, SpecialisedInstanceSig, TyDecl)
-import HsExpr(Expr)
-import HsImpExp(IfaceImportDecl)
-import HsPat(InPat)
-import HsPragmas(ClassOpPragmas, GenPragmas)
-import HsTypes(PolyType)
-import PreludePS(_PackedString)
-import ProtoName(ProtoName)
-import SrcLoc(SrcLoc)
-data RdrBinding   = RdrNullBind | RdrAndBindings RdrBinding RdrBinding | RdrTyData (TyDecl ProtoName) | RdrTySynonym (TyDecl ProtoName) | RdrFunctionBinding Int [RdrMatch] | RdrPatternBinding Int [RdrMatch] | RdrClassDecl (ClassDecl ProtoName (InPat ProtoName)) | RdrInstDecl (_PackedString -> _PackedString -> Bool -> InstDecl ProtoName (InPat ProtoName)) | RdrDefaultDecl (DefaultDecl ProtoName) | RdrIfaceImportDecl IfaceImportDecl | RdrTySig [ProtoName] (PolyType ProtoName) RdrTySigPragmas SrcLoc | RdrSpecValSig [Sig ProtoName] | RdrInlineValSig (Sig ProtoName) | RdrDeforestSig (Sig ProtoName) | RdrMagicUnfoldingSig (Sig ProtoName) | RdrSpecInstSig (SpecialisedInstanceSig ProtoName) | RdrAbstractTypeSig (DataTypeSig ProtoName) | RdrSpecDataSig (DataTypeSig ProtoName)
-type RdrId = ProtoName
-data RdrMatch   = RdrMatch Int _PackedString (InPat ProtoName) [(Expr ProtoName (InPat ProtoName), Expr ProtoName (InPat ProtoName))] RdrBinding
-data RdrTySigPragmas   = RdrNoPragma | RdrGenPragmas (GenPragmas ProtoName) | RdrClassOpPragmas (ClassOpPragmas ProtoName)
-type SigConverter = RdrBinding -> [Sig ProtoName]
-type SrcFile = _PackedString
-type SrcFun = _PackedString
-type SrcLine = Int
-readInteger :: [Char] -> Integer
-
diff --git a/ghc/compiler/reader/PrefixSyn.lhs b/ghc/compiler/reader/PrefixSyn.lhs
index 6dc0e55d8b..47e802ef79 100644
--- a/ghc/compiler/reader/PrefixSyn.lhs
+++ b/ghc/compiler/reader/PrefixSyn.lhs
@@ -1,5 +1,5 @@
 %
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
 %
 \section[PrefixSyn]{``Prefix-form'' syntax}
 
@@ -23,15 +23,16 @@ module PrefixSyn (
 	readInteger
     ) where
 
-import AbsSyn
-import ProtoName	( ProtoName(..) ) -- .. is for pragmas only
-import Outputable
-import Util		-- pragmas only
+import Ubiq{-uitous-}
+
+import HsSyn
+import RdrHsSyn
+import Util		( panic )
 
 type RdrId   = ProtoName
 type SrcLine = Int
 type SrcFile = FAST_STRING
-type SrcFun  = FAST_STRING
+type SrcFun  = ProtoName
 \end{code}
 
 \begin{code}
@@ -39,17 +40,14 @@ data RdrBinding
   = RdrNullBind
   | RdrAndBindings	RdrBinding RdrBinding
 
-  | RdrTyData		ProtoNameTyDecl
-  | RdrTySynonym	ProtoNameTyDecl
+  | RdrTyDecl		ProtoNameTyDecl
   | RdrFunctionBinding	SrcLine [RdrMatch]
   | RdrPatternBinding	SrcLine [RdrMatch]
   | RdrClassDecl 	ProtoNameClassDecl
-  | RdrInstDecl 	( FAST_STRING{-original  module's name-} ->
-			  FAST_STRING{-informant module's name-} ->
-			  Bool{-from here?-} ->
-			  ProtoNameInstDecl )
+  | RdrInstDecl 	ProtoNameInstDecl
   | RdrDefaultDecl	ProtoNameDefaultDecl
-  | RdrIfaceImportDecl	IfaceImportDecl
+  | RdrIfaceImportDecl	(IfaceImportDecl ProtoName)
+  | RdrIfaceFixities	[ProtoNameFixityDecl]
 
 			-- signatures are mysterious; we can't
 			-- tell if its a Sig or a ClassOpSig,
@@ -64,9 +62,8 @@ data RdrBinding
   | RdrInlineValSig 	ProtoNameSig
   | RdrDeforestSig 	ProtoNameSig
   | RdrMagicUnfoldingSig ProtoNameSig
-  | RdrSpecInstSig  	ProtoNameSpecialisedInstanceSig
-  | RdrAbstractTypeSig  ProtoNameDataTypeSig
-  | RdrSpecDataSig   	ProtoNameDataTypeSig
+  | RdrSpecInstSig  	ProtoNameSpecInstSig
+  | RdrSpecDataSig   	ProtoNameSpecDataSig
 
 data RdrTySigPragmas
   = RdrNoPragma
@@ -78,8 +75,18 @@ type SigConverter = RdrBinding {- a RdrTySig... -} -> [ProtoNameSig]
 
 \begin{code}
 data RdrMatch
-  = RdrMatch SrcLine SrcFun ProtoNamePat [(ProtoNameExpr, ProtoNameExpr)] RdrBinding
-				       -- (guard,         expr)
+  = RdrMatch_NoGuard
+	     SrcLine SrcFun
+	     ProtoNamePat
+	     ProtoNameHsExpr
+	     RdrBinding
+
+  | RdrMatch_Guards
+	     SrcLine SrcFun
+	     ProtoNamePat
+	     [(ProtoNameHsExpr, ProtoNameHsExpr)]
+	     -- (guard,         expr)
+	     RdrBinding
 \end{code}
 
 Unscramble strings representing oct/dec/hex integer literals:
diff --git a/ghc/compiler/reader/PrefixToHs.hi b/ghc/compiler/reader/PrefixToHs.hi
deleted file mode 100644
index d7a5a8f85d..0000000000
--- a/ghc/compiler/reader/PrefixToHs.hi
+++ /dev/null
@@ -1,22 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface PrefixToHs where
-import HsBinds(Binds, MonoBinds, Sig)
-import HsDecls(ClassDecl, DataTypeSig, DefaultDecl, InstDecl, SpecialisedInstanceSig, TyDecl)
-import HsImpExp(IfaceImportDecl)
-import HsMatches(Match)
-import HsPat(InPat)
-import PrefixSyn(RdrBinding, RdrMatch)
-import PreludePS(_PackedString)
-import ProtoName(ProtoName)
-cvBinds :: _PackedString -> (RdrBinding -> [Sig ProtoName]) -> RdrBinding -> Binds ProtoName (InPat ProtoName)
-cvClassOpSig :: RdrBinding -> [Sig ProtoName]
-cvInstDeclSig :: RdrBinding -> [Sig ProtoName]
-cvInstDecls :: Bool -> _PackedString -> _PackedString -> [_PackedString -> _PackedString -> Bool -> InstDecl ProtoName (InPat ProtoName)] -> [InstDecl ProtoName (InPat ProtoName)]
-cvMatches :: _PackedString -> Bool -> [RdrMatch] -> [Match ProtoName (InPat ProtoName)]
-cvMonoBinds :: _PackedString -> [RdrBinding] -> MonoBinds ProtoName (InPat ProtoName)
-cvSepdBinds :: _PackedString -> (RdrBinding -> [Sig ProtoName]) -> [RdrBinding] -> Binds ProtoName (InPat ProtoName)
-cvValSig :: RdrBinding -> [Sig ProtoName]
-sepDeclsForInterface :: RdrBinding -> ([TyDecl ProtoName], [ClassDecl ProtoName (InPat ProtoName)], [_PackedString -> _PackedString -> Bool -> InstDecl ProtoName (InPat ProtoName)], [RdrBinding], [IfaceImportDecl])
-sepDeclsForTopBinds :: RdrBinding -> ([TyDecl ProtoName], [DataTypeSig ProtoName], [ClassDecl ProtoName (InPat ProtoName)], [_PackedString -> _PackedString -> Bool -> InstDecl ProtoName (InPat ProtoName)], [SpecialisedInstanceSig ProtoName], [DefaultDecl ProtoName], [RdrBinding])
-sepDeclsIntoSigsAndBinds :: RdrBinding -> ([RdrBinding], [RdrBinding])
-
diff --git a/ghc/compiler/reader/PrefixToHs.lhs b/ghc/compiler/reader/PrefixToHs.lhs
index 96c993c875..c30abba2b4 100644
--- a/ghc/compiler/reader/PrefixToHs.lhs
+++ b/ghc/compiler/reader/PrefixToHs.lhs
@@ -1,5 +1,5 @@
 %
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
 %
 \section[PrefixToHS]{Support routines for converting ``prefix form'' to Haskell abstract syntax}
 
@@ -12,7 +12,6 @@ module PrefixToHs (
 	cvBinds,
 	cvClassOpSig,
 	cvInstDeclSig,
-	cvInstDecls,
 	cvMatches,
 	cvMonoBinds,
 	cvSepdBinds,
@@ -22,17 +21,16 @@ module PrefixToHs (
 	sepDeclsIntoSigsAndBinds
     ) where
 
-IMPORT_Trace		-- ToDo: rm
-import Pretty
+import Ubiq{-uitous-}
 
-import AbsSyn
-import HsCore		-- ****** NEED TO SEE CONSTRUCTORS ******
-import HsPragmas	-- ****** NEED TO SEE CONSTRUCTORS ******
-import Outputable
-import PrefixSyn
-import ProtoName	-- ProtoName(..), etc.
+import PrefixSyn	-- and various syntaxen.
+import HsSyn
+import RdrHsSyn
+import HsPragmas	( noGenPragmas, noClassOpPragmas )
+
+import ProtoName	( ProtoName(..) )
 import SrcLoc		( mkSrcLoc2 )
-import Util
+import Util		( panic, assertPanic )
 \end{code}
 
 %************************************************************************
@@ -41,16 +39,6 @@ import Util
 %*									*
 %************************************************************************
 
-\begin{code}
-cvInstDecls :: Bool -> FAST_STRING -> FAST_STRING
-	    -> [FAST_STRING -> FAST_STRING -> Bool -> ProtoNameInstDecl] -- incomplete InstDecls
-	    -> [ProtoNameInstDecl]
-
-cvInstDecls from_here orig_modname informant_modname decls
-  = [ decl_almost orig_modname informant_modname from_here
-    | decl_almost <- decls ]
-\end{code}
-
 We make a point not to throw any user-pragma ``sigs'' at
 these conversion functions:
 \begin{code}
@@ -59,13 +47,13 @@ cvValSig, cvClassOpSig, cvInstDeclSig :: SigConverter
 cvValSig (RdrTySig vars poly_ty pragmas src_loc)
   = [ Sig v poly_ty (cvt_pragmas pragmas) src_loc | v <- vars ]
   where
-    cvt_pragmas RdrNoPragma	   = NoGenPragmas
+    cvt_pragmas RdrNoPragma	   = noGenPragmas
     cvt_pragmas (RdrGenPragmas ps) = ps
 
 cvClassOpSig (RdrTySig vars poly_ty pragmas src_loc)
   = [ ClassOpSig v poly_ty (cvt_pragmas pragmas) src_loc | v <- vars ]
   where
-    cvt_pragmas RdrNoPragma	       = NoClassOpPragmas
+    cvt_pragmas RdrNoPragma	       = noClassOpPragmas
     cvt_pragmas (RdrClassOpPragmas ps) = ps
 
 cvInstDeclSig (RdrSpecValSig        sigs) = sigs
@@ -76,7 +64,7 @@ cvInstDeclSig (RdrMagicUnfoldingSig sig)  = [ sig ]
 
 %************************************************************************
 %*									*
-\subsection[cvBinds-etc]{Converting to @Binds@, @MonoBinds@, etc.}
+\subsection[cvBinds-etc]{Converting to @HsBinds@, @MonoBinds@, etc.}
 %*									*
 %************************************************************************
 
@@ -85,11 +73,11 @@ initially, and non recursive definitions are discovered by the dependency
 analyser.
 
 \begin{code}
-cvBinds :: SrcFile -> SigConverter -> RdrBinding -> ProtoNameBinds
+cvBinds :: SrcFile -> SigConverter -> RdrBinding -> ProtoNameHsBinds
 cvBinds sf sig_cvtr raw_binding
   = cvSepdBinds sf sig_cvtr (sepDeclsForBinds raw_binding)
 
-cvSepdBinds :: SrcFile -> SigConverter -> [RdrBinding] -> ProtoNameBinds
+cvSepdBinds :: SrcFile -> SigConverter -> [RdrBinding] -> ProtoNameHsBinds
 cvSepdBinds sf sig_cvtr bindings
   = case (mkMonoBindsAndSigs sf sig_cvtr bindings) of { (mbs, sigs) ->
     if (null sigs)
@@ -134,7 +122,7 @@ mkMonoBindsAndSigs sf sig_cvtr fbs
     mangle_bind (b_acc, s_acc) (RdrMagicUnfoldingSig sig) = (b_acc, sig : s_acc)
 
     mangle_bind (b_acc, s_acc)
-		(RdrPatternBinding lousy_srcline [patbinding@(RdrMatch good_srcline _ _ _ _)])
+		(RdrPatternBinding lousy_srcline [patbinding])
       -- WDP: the parser has trouble getting a good line-number on RdrPatternBindings.
       = case (cvPatMonoBind sf patbinding) of { (pat, grhss, binds) ->
 	let
@@ -143,6 +131,11 @@ mkMonoBindsAndSigs sf sig_cvtr fbs
 	(b_acc `AndMonoBinds`
 	 PatMonoBind pat (GRHSsAndBindsIn grhss binds) src_loc, s_acc)
 	}
+      where
+	good_srcline = case patbinding of
+			 RdrMatch_NoGuard ln _ _ _ _ -> ln
+			 RdrMatch_Guards  ln _ _ _ _ -> ln
+
 
     mangle_bind _ (RdrPatternBinding _ _)
       = panic "mangleBinding: more than one pattern on a RdrPatternBinding"
@@ -156,41 +149,50 @@ mkMonoBindsAndSigs sf sig_cvtr fbs
 \end{code}
 
 \begin{code}
-cvPatMonoBind :: SrcFile -> RdrMatch -> (ProtoNamePat, [ProtoNameGRHS], ProtoNameBinds)
+cvPatMonoBind :: SrcFile -> RdrMatch -> (ProtoNamePat, [ProtoNameGRHS], ProtoNameHsBinds)
 
-cvPatMonoBind sf (RdrMatch srcline srcfun pat guardedexprs binding)
-  = (pat, cvGRHSs srcfun sf srcline guardedexprs, cvBinds sf cvValSig binding)
+cvPatMonoBind sf (RdrMatch_NoGuard srcline srcfun pat expr binding)
+  = (pat, [OtherwiseGRHS expr (mkSrcLoc2 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)
 
 cvFunMonoBind :: SrcFile -> [RdrMatch] -> (ProtoName {-VarName-}, [ProtoNameMatch])
 
-cvFunMonoBind sf matches@((RdrMatch srcline srcfun pat guardedexprs binding):_)
-  = ( Unk srcfun, -- cheating ...
-      cvMatches sf False matches )
+cvFunMonoBind sf matches
+  = (srcfun {- cheating ... -}, cvMatches sf False matches)
+  where
+    srcfun = case (head matches) of
+	       RdrMatch_NoGuard _ sfun _ _ _ -> sfun
+	       RdrMatch_Guards  _ sfun _ _ _ -> sfun
 
 cvMatches :: SrcFile -> Bool -> [RdrMatch] -> [ProtoNameMatch]
 cvMatch	  :: SrcFile -> Bool -> RdrMatch   -> ProtoNameMatch
 
 cvMatches sf is_case matches = map (cvMatch sf is_case) matches
 
-cvMatch sf is_case (RdrMatch srcline srcfun pat guardedexprs binding)
+cvMatch sf is_case rdr_match
   = foldr PatMatch
-	  (GRHSMatch (GRHSsAndBindsIn (cvGRHSs srcfun sf srcline guardedexprs)
-				      (cvBinds sf cvValSig binding)))
+	  (GRHSMatch (GRHSsAndBindsIn guarded_exprs (cvBinds sf cvValSig binding)))
 
 	  -- For a FunMonoBinds, the first flattened "pattern" is
 	  -- just the function name, and we don't want to keep it.
 	  -- For a case expr, it's (presumably) a constructor name -- and
 	  -- we most certainly want to keep it!	 Hence the monkey busines...
 
---	  (trace ("cvMatch:"++(ppShow 80 (ppr PprDebug pat))) (
 	  (if is_case then -- just one pattern: leave it untouched...
 	      [pat']
 	   else
 	      case pat' of
 		ConPatIn _ pats -> pats
 	  )
---	  ))
   where
+    (pat, binding, guarded_exprs)
+      = case rdr_match of
+	  RdrMatch_NoGuard ln b c expr    d -> (c,d, [OtherwiseGRHS expr (mkSrcLoc2 sf ln)])
+	  RdrMatch_Guards  ln b c gd_exps d -> (c,d, map (cvGRHS sf ln) gd_exps)
+
+    ---------------------
     pat' = doctor_pat pat
 
     -- a ConOpPatIn in the corner may be handled by converting it to
@@ -199,18 +201,9 @@ cvMatch sf is_case (RdrMatch srcline srcfun pat guardedexprs binding)
     doctor_pat (ConOpPatIn p1 op p2) = ConPatIn op [p1, p2]
     doctor_pat other_pat	     = other_pat
 
-cvGRHSs :: FAST_STRING -> SrcFile -> SrcLine -> [(ProtoNameExpr, ProtoNameExpr)] -> [ProtoNameGRHS]
-
-cvGRHSs sfun sf sl guarded_exprs = map (cvGRHS sfun sf sl) guarded_exprs
-
-cvGRHS :: FAST_STRING -> SrcFile -> SrcLine -> (ProtoNameExpr, ProtoNameExpr) -> ProtoNameGRHS
-
-cvGRHS sfun sf sl (Var v@(Unk str), e)
-	| str == SLIT("__o") -- "__otherwise" ToDo: de-urgh-ify
-  = OtherwiseGRHS e (mkSrcLoc2 sf sl)
+cvGRHS :: SrcFile -> SrcLine -> (ProtoNameHsExpr, ProtoNameHsExpr) -> ProtoNameGRHS
 
-cvGRHS sfun sf sl (g, e)
-  = GRHS g e (mkSrcLoc2 sf sl)
+cvGRHS sf sl (g, e) = GRHS g e (mkSrcLoc2 sf sl)
 \end{code}
 
 %************************************************************************
@@ -221,11 +214,11 @@ cvGRHS sfun sf sl (g, e)
 
 Separate declarations into all the various kinds:
 \begin{display}
-tys		RdrTyData RdrTySynonym
-type "sigs" 	RdrAbstractTypeSig RdrSpecDataSig
+tys		RdrTyDecl
+ty "sigs" 	RdrSpecDataSig
 classes		RdrClassDecl
-instances	RdrInstDecl
-instance "sigs" RdrSpecInstSig
+insts		RdrInstDecl
+inst "sigs" 	RdrSpecInstSig
 defaults	RdrDefaultDecl
 binds		RdrFunctionBinding RdrPatternBinding RdrTySig
 		RdrSpecValSig RdrInlineValSig RdrDeforestSig
@@ -238,102 +231,100 @@ then checks that what it got is appropriate for that situation.
 (Those functions follow...)
 
 \begin{code}
-sepDecls (RdrTyData a)
-	 tys tysigs classes insts instsigs defaults binds iimps
- = (a:tys,tysigs,classes,insts,instsigs,defaults,binds,iimps)
-
-sepDecls (RdrTySynonym a)
-	 tys tysigs classes insts instsigs defaults binds iimps
- = (a:tys,tysigs,classes,insts,instsigs,defaults,binds,iimps)
+sepDecls (RdrTyDecl a)
+	 tys tysigs classes insts instsigs defaults binds iimps ifixs
+ = (a:tys,tysigs,classes,insts,instsigs,defaults,binds,iimps,ifixs)
 
 sepDecls a@(RdrFunctionBinding _ _)
-	 tys tysigs classes insts instsigs defaults binds iimps
- = (tys,tysigs,classes,insts,instsigs,defaults,a:binds,iimps)
+	 tys tysigs classes insts instsigs defaults binds iimps ifixs
+ = (tys,tysigs,classes,insts,instsigs,defaults,a:binds,iimps,ifixs)
 
 sepDecls a@(RdrPatternBinding _ _)
-	 tys tysigs classes insts instsigs defaults binds iimps
- = (tys,tysigs,classes,insts,instsigs,defaults,a:binds,iimps)
+	 tys tysigs classes insts instsigs defaults binds iimps ifixs
+ = (tys,tysigs,classes,insts,instsigs,defaults,a:binds,iimps,ifixs)
 
 -- RdrAndBindings catered for below...
 
 sepDecls (RdrClassDecl a)
-	 tys tysigs classes insts instsigs defaults binds iimps
-  = (tys,tysigs,a:classes,insts,instsigs,defaults,binds,iimps)
+	 tys tysigs classes insts instsigs defaults binds iimps ifixs
+  = (tys,tysigs,a:classes,insts,instsigs,defaults,binds,iimps,ifixs)
 
 sepDecls (RdrInstDecl a)
-	 tys tysigs classes insts instsigs defaults binds iimps
-  = (tys,tysigs,classes,a:insts,instsigs,defaults,binds,iimps)
+	 tys tysigs classes insts instsigs defaults binds iimps ifixs
+  = (tys,tysigs,classes,a:insts,instsigs,defaults,binds,iimps,ifixs)
 
 sepDecls (RdrDefaultDecl a)
-	 tys tysigs classes insts instsigs defaults binds iimps
-  = (tys,tysigs,classes,insts,instsigs,a:defaults,binds,iimps)
+	 tys tysigs classes insts instsigs defaults binds iimps ifixs
+  = (tys,tysigs,classes,insts,instsigs,a:defaults,binds,iimps,ifixs)
 
 sepDecls a@(RdrTySig _ _ _ _)
-	 tys tysigs classes insts instsigs defaults binds iimps
-  = (tys,tysigs,classes,insts,instsigs,defaults,a:binds,iimps)
+	 tys tysigs classes insts instsigs defaults binds iimps ifixs
+  = (tys,tysigs,classes,insts,instsigs,defaults,a:binds,iimps,ifixs)
 
 sepDecls (RdrIfaceImportDecl a)
-	 tys tysigs classes insts instsigs defaults binds iimps
-  = (tys,tysigs,classes,insts,instsigs,defaults,binds,a:iimps)
+	 tys tysigs classes insts instsigs defaults binds iimps ifixs
+  = (tys,tysigs,classes,insts,instsigs,defaults,binds,a:iimps,ifixs)
+
+sepDecls (RdrIfaceFixities a)
+	 tys tysigs classes insts instsigs defaults binds iimps ifixs
+  = (tys,tysigs,classes,insts,instsigs,defaults,binds,iimps,a++ifixs)
 
 sepDecls a@(RdrSpecValSig _)
-	 tys tysigs classes insts instsigs defaults binds iimps
-  = (tys,tysigs,classes,insts,instsigs,defaults,a:binds,iimps)
+	 tys tysigs classes insts instsigs defaults binds iimps ifixs
+  = (tys,tysigs,classes,insts,instsigs,defaults,a:binds,iimps,ifixs)
 
 sepDecls a@(RdrInlineValSig _)
-	 tys tysigs classes insts instsigs defaults binds iimps
-  = (tys,tysigs,classes,insts,instsigs,defaults,a:binds,iimps)
+	 tys tysigs classes insts instsigs defaults binds iimps ifixs
+  = (tys,tysigs,classes,insts,instsigs,defaults,a:binds,iimps,ifixs)
 
 sepDecls a@(RdrDeforestSig _)
-	 tys tysigs classes insts instsigs defaults binds iimps
-  = (tys,tysigs,classes,insts,instsigs,defaults,a:binds,iimps)
+	 tys tysigs classes insts instsigs defaults binds iimps ifixs
+  = (tys,tysigs,classes,insts,instsigs,defaults,a:binds,iimps,ifixs)
 
 sepDecls a@(RdrMagicUnfoldingSig _)
-	 tys tysigs classes insts instsigs defaults binds iimps
-  = (tys,tysigs,classes,insts,instsigs,defaults,a:binds,iimps)
+	 tys tysigs classes insts instsigs defaults binds iimps ifixs
+  = (tys,tysigs,classes,insts,instsigs,defaults,a:binds,iimps,ifixs)
 
 sepDecls (RdrSpecInstSig a)
-	 tys tysigs classes insts instsigs defaults binds iimps
-  = (tys,tysigs,classes,insts,a:instsigs,defaults,binds,iimps)
-
-sepDecls (RdrAbstractTypeSig a)
-	 tys tysigs classes insts instsigs defaults binds iimps
-  = (tys,a:tysigs,classes,insts,instsigs,defaults,binds,iimps)
+	 tys tysigs classes insts instsigs defaults binds iimps ifixs
+  = (tys,tysigs,classes,insts,a:instsigs,defaults,binds,iimps,ifixs)
 
 sepDecls (RdrSpecDataSig a)
-	 tys tysigs classes insts instsigs defaults binds iimps
-  = (tys,a:tysigs,classes,insts,instsigs,defaults,binds,iimps)
+	 tys tysigs classes insts instsigs defaults binds iimps ifixs
+  = (tys,a:tysigs,classes,insts,instsigs,defaults,binds,iimps,ifixs)
 
 sepDecls RdrNullBind
-	 tys tysigs classes insts instsigs defaults binds iimps
-  = (tys,tysigs,classes,insts,instsigs,defaults,binds,iimps)
+	 tys tysigs classes insts instsigs defaults binds iimps ifixs
+  = (tys,tysigs,classes,insts,instsigs,defaults,binds,iimps,ifixs)
 
 sepDecls (RdrAndBindings bs1 bs2)
-	 tys tysigs classes insts instsigs defaults binds iimps
-  = case (sepDecls bs2 tys tysigs classes insts instsigs defaults binds iimps) of {
-      (tys,tysigs,classes,insts,instsigs,defaults,binds,iimps) ->
-	  sepDecls bs1 tys tysigs classes insts instsigs defaults binds iimps
+	 tys tysigs classes insts instsigs defaults binds iimps ifixs
+  = case (sepDecls bs2 tys tysigs classes insts instsigs defaults binds iimps ifixs) of {
+      (tys,tysigs,classes,insts,instsigs,defaults,binds,iimps,ifixs) ->
+	  sepDecls bs1 tys tysigs classes insts instsigs defaults binds iimps ifixs
     }
 \end{code}
 
 \begin{code}
 sepDeclsForTopBinds binding
-  = case (sepDecls binding [] [] [] [] [] [] [] [])
-	of { (tys,tysigs,classes,insts,instsigs,defaults,binds,iimps) ->
-    ASSERT (null iimps)
+  = case (sepDecls binding [] [] [] [] [] [] [] [] [])
+	of { (tys,tysigs,classes,insts,instsigs,defaults,binds,iimps,ifixs) ->
+    ASSERT ((null iimps)
+	 && (null ifixs))
     (tys,tysigs,classes,insts,instsigs,defaults,binds)
     }
 
 sepDeclsForBinds binding
-  = case (sepDecls binding [] [] [] [] [] [] [] [])
-	of { (tys,tysigs,classes,insts,instsigs,defaults,binds,iimps) ->
+  = case (sepDecls binding [] [] [] [] [] [] [] [] [])
+	of { (tys,tysigs,classes,insts,instsigs,defaults,binds,iimps,ifixs) ->
     ASSERT ((null tys)
 	 && (null tysigs)
 	 && (null classes)
 	 && (null insts)
 	 && (null instsigs)
 	 && (null defaults)
-	 && (null iimps))
+	 && (null iimps)
+	 && (null ifixs))
     binds
     }
 
@@ -352,13 +343,13 @@ sepDeclsIntoSigsAndBinds binding
 
 
 sepDeclsForInterface binding
-  = case (sepDecls binding [] [] [] [] [] [] [] [])
-	of { (tys,tysigs,classes,insts,instsigs,defaults,sigs,iimps) ->
+  = case (sepDecls binding [] [] [] [] [] [] [] [] [])
+	of { (tys,tysigs,classes,insts,instsigs,defaults,sigs,iimps,ifixs) ->
     ASSERT ((null defaults)
 	 && (null tysigs)
 	 && (null instsigs))
     ASSERT (not (not_all_sigs sigs))
-    (tys,classes,insts,sigs,iimps)
+    (tys,classes,insts,sigs,iimps,ifixs)
     }
   where
     not_all_sigs sigs = not (all is_a_sig sigs)
diff --git a/ghc/compiler/reader/RdrHsSyn.lhs b/ghc/compiler/reader/RdrHsSyn.lhs
new file mode 100644
index 0000000000..3df812bb0e
--- /dev/null
+++ b/ghc/compiler/reader/RdrHsSyn.lhs
@@ -0,0 +1,395 @@
+%
+% (c) The AQUA Project, Glasgow University, 1996
+%
+\section[RdrHsSyn]{Specialisations of the @HsSyn@ syntax for the reader}
+
+(Well, really, for specialisations involving @ProtoName@s, even if
+they are used somewhat later on in the compiler...)
+
+\begin{code}
+#include "HsVersions.h"
+
+module RdrHsSyn (
+	cmpInstanceTypes,
+	eqMonoType,
+	getMentionedVars,
+	getNonPrelOuterTyCon,
+	ExportListInfo(..),
+	getImportees,
+	getExportees,
+	getRawImportees,
+	getRawExportees,
+
+	ProtoNameArithSeqInfo(..),
+	ProtoNameBind(..),
+	ProtoNameClassDecl(..),
+	ProtoNameClassOpPragmas(..),
+	ProtoNameClassOpSig(..),
+	ProtoNameClassPragmas(..),
+	ProtoNameConDecl(..),
+	ProtoNameContext(..),
+	ProtoNameCoreExpr(..),
+	ProtoNameDataPragmas(..),
+	ProtoNameSpecDataSig(..),
+	ProtoNameDefaultDecl(..),
+	ProtoNameFixityDecl(..),
+	ProtoNameGRHS(..),
+	ProtoNameGRHSsAndBinds(..),
+	ProtoNameGenPragmas(..),
+	ProtoNameHsBinds(..),
+	ProtoNameHsExpr(..),
+	ProtoNameHsModule(..),
+	ProtoNameIE(..),
+	ProtoNameImportedInterface(..),
+	ProtoNameInstDecl(..),
+	ProtoNameInstancePragmas(..),
+	ProtoNameInterface(..),
+	ProtoNameMatch(..),
+	ProtoNameMonoBinds(..),
+	ProtoNameMonoType(..),
+	ProtoNamePat(..),
+	ProtoNamePolyType(..),
+	ProtoNameQual(..),
+	ProtoNameSig(..),
+	ProtoNameSpecInstSig(..),
+	ProtoNameStmt(..),
+	ProtoNameTyDecl(..),
+	ProtoNameUnfoldingCoreExpr(..)
+    ) where
+
+import Ubiq{-uitous-}
+
+import Bag		( emptyBag, snocBag, unionBags, listToBag, Bag )
+import FiniteMap	( mkSet, listToFM, emptySet, emptyFM, FiniteSet(..), FiniteMap )
+import HsSyn
+import Outputable	( ExportFlag(..) )
+import ProtoName	( cmpProtoName, ProtoName(..) )
+import Util		( panic{-ToDo:rm eventually-} )
+\end{code}
+
+\begin{code}
+type ProtoNameArithSeqInfo	= ArithSeqInfo		Fake Fake ProtoName ProtoNamePat
+type ProtoNameBind		= Bind			Fake Fake ProtoName ProtoNamePat
+type ProtoNameClassDecl		= ClassDecl		Fake Fake ProtoName ProtoNamePat
+type ProtoNameClassOpPragmas	= ClassOpPragmas	ProtoName
+type ProtoNameClassOpSig	= Sig			ProtoName
+type ProtoNameClassPragmas	= ClassPragmas		ProtoName
+type ProtoNameConDecl		= ConDecl		ProtoName
+type ProtoNameContext		= Context 		ProtoName
+type ProtoNameCoreExpr		= UnfoldingCoreExpr	ProtoName
+type ProtoNameDataPragmas	= DataPragmas		ProtoName
+type ProtoNameSpecDataSig	= SpecDataSig		ProtoName
+type ProtoNameDefaultDecl	= DefaultDecl		ProtoName
+type ProtoNameFixityDecl	= FixityDecl		ProtoName
+type ProtoNameGRHS		= GRHS			Fake Fake ProtoName ProtoNamePat
+type ProtoNameGRHSsAndBinds	= GRHSsAndBinds		Fake Fake ProtoName ProtoNamePat
+type ProtoNameGenPragmas	= GenPragmas		ProtoName
+type ProtoNameHsBinds		= HsBinds		Fake Fake ProtoName ProtoNamePat
+type ProtoNameHsExpr		= HsExpr		Fake Fake ProtoName ProtoNamePat
+type ProtoNameHsModule		= HsModule		Fake Fake ProtoName ProtoNamePat
+type ProtoNameIE		= IE			ProtoName
+type ProtoNameImportedInterface	= ImportedInterface	Fake Fake ProtoName ProtoNamePat
+type ProtoNameInstDecl		= InstDecl		Fake Fake ProtoName ProtoNamePat
+type ProtoNameInstancePragmas	= InstancePragmas	ProtoName
+type ProtoNameInterface		= Interface		Fake Fake ProtoName ProtoNamePat
+type ProtoNameMatch		= Match			Fake Fake ProtoName ProtoNamePat
+type ProtoNameMonoBinds		= MonoBinds		Fake Fake ProtoName ProtoNamePat
+type ProtoNameMonoType		= MonoType		ProtoName
+type ProtoNamePat		= InPat			ProtoName
+type ProtoNamePolyType		= PolyType		ProtoName
+type ProtoNameQual		= Qual			Fake Fake ProtoName ProtoNamePat
+type ProtoNameSig		= Sig			ProtoName
+type ProtoNameSpecInstSig	= SpecInstSig 		ProtoName
+type ProtoNameStmt		= Stmt			Fake Fake ProtoName ProtoNamePat
+type ProtoNameTyDecl		= TyDecl		ProtoName
+type ProtoNameUnfoldingCoreExpr = UnfoldingCoreExpr	ProtoName
+\end{code}
+
+\begin{code}
+eqMonoType :: ProtoNameMonoType -> ProtoNameMonoType -> Bool
+
+eqMonoType a b = case (cmpMonoType cmpProtoName a b) of { EQ_ -> True; _ -> False }
+\end{code}
+
+
+@cmpInstanceTypes@ compares two @PolyType@s which are being used as
+``instance types.''  This is used when comparing as-yet-unrenamed
+instance decls to eliminate duplicates.  We allow things (e.g.,
+overlapping instances) which standard Haskell doesn't, so we must
+cater for that.  Generally speaking, the instance-type
+``shape''-checker in @tcInstDecl@ will catch any mischief later on.
+
+All we do is call @cmpMonoType@, passing it a tyvar-comparing function
+that always claims that tyvars are ``equal;'' the result is that we
+end up comparing the non-tyvar-ish structure of the two types.
+
+\begin{code}
+cmpInstanceTypes :: ProtoNamePolyType -> ProtoNamePolyType -> TAG_
+
+cmpInstanceTypes (HsPreForAllTy _ ty1) (HsPreForAllTy _ ty2)
+  = cmpMonoType funny_cmp ty1 ty2 -- Hey! ignore those contexts!
+  where
+    funny_cmp :: ProtoName -> ProtoName -> TAG_
+
+    {- The only case we are really trying to catch
+       is when both types are tyvars: which are both
+       "Unk"s and names that start w/ a lower-case letter! (Whew.)
+    -}
+    funny_cmp (Unk u1) (Unk u2)
+      | isLower s1 && isLower s2 = EQ_
+      where
+	s1 = _HEAD_ u1
+	s2 = _HEAD_ u2
+
+    funny_cmp x y = cmpProtoName x y -- otherwise completely normal
+\end{code}
+
+@getNonPrelOuterTyCon@ is a yukky function required when deciding
+whether to import an instance decl.  If the class name or type
+constructor are ``wanted'' then we should import it, otherwise not.
+But the built-in core constructors for lists, tuples and arrows are
+never ``wanted'' in this sense.  @getNonPrelOuterTyCon@ catches just a
+user-defined tycon and returns it.
+
+\begin{code}
+getNonPrelOuterTyCon :: ProtoNameMonoType -> Maybe ProtoName
+
+getNonPrelOuterTyCon (MonoTyApp con _)   = Just con
+getNonPrelOuterTyCon _			 = Nothing
+\end{code}
+
+%************************************************************************
+%*									*
+\subsection{Grabbing importees and exportees}
+%*									*
+%************************************************************************
+
+We want to know what names are exported (the first list of the result)
+and what modules are exported (the second list of the result).
+\begin{code}
+type ExportListInfo
+  = Maybe -- Nothing => no export list
+    ( FiniteMap FAST_STRING ExportFlag,
+			-- Assoc list of im/exported things &
+			-- their "export" flags (im/exported
+			-- abstractly, concretely, etc.)
+			-- Hmm... slight misnomer there (WDP 95/02)
+      FiniteSet FAST_STRING )
+			-- List of modules to be exported
+			-- entirely; NB: *not* everything with
+			-- original names in these modules;
+			-- but: everything that these modules'
+			-- interfaces told us about.
+			-- Note: This latter component can
+			-- only arise on export lists.
+
+getImportees    :: [ProtoNameIE] -> FiniteSet FAST_STRING
+getExportees    :: Maybe [ProtoNameIE] -> ExportListInfo
+
+getRawImportees :: [ProtoNameIE] ->  [FAST_STRING]
+getRawExportees :: Maybe [ProtoNameIE] -> ([(ProtoName, ExportFlag)], [FAST_STRING])
+  -- "Raw" gives the raw lists of things; we need this for
+  -- checking for duplicates.
+
+getImportees []   = emptySet
+getImportees imps = mkSet (getRawImportees imps)
+
+getExportees Nothing = Nothing
+getExportees exps
+  = case (getRawExportees exps) of { (pairs, mods) ->
+    Just (panic "RdrHsSyn.getExportees" {-listToFM pairs-}, mkSet mods) }
+
+getRawImportees imps
+  = foldr do_imp [] imps
+  where
+    do_imp (IEVar (Unk n))	acc = n:acc
+    do_imp (IEThingAbs (Unk n)) acc = n:acc
+    do_imp (IEThingAll (Unk 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 (IEModuleContents n) (prs, mods) = (prs, n : mods)
+\end{code}
+
+%************************************************************************
+%*									*
+\subsection{Collect mentioned variables}
+%*									*
+%************************************************************************
+
+This is just a {\em hack} whichs collects, from a module body, all the
+variables that are ``mentioned,'' either as top-level binders or as
+free variables.  We can then use this list when walking over
+interfaces, using it to avoid imported variables that are patently of
+no interest.
+
+We have to be careful to look out for \tr{M..} constructs in the
+export list; if so, the game is up (and we must so report).
+
+\begin{code}
+type NameMapper a = FAST_STRING -> Maybe a
+		    -- For our purposes here, we don't care *what*
+		    -- they are mapped to; only if the names are
+		    -- in the mapper
+
+getMentionedVars :: NameMapper any	-- a prelude-name lookup function, so
+					-- we can avoid recording prelude things
+					-- as "mentioned"
+		 -> Maybe [IE ProtoName]{-exports-}	-- All the bits of the module body to
+		 -> [ProtoNameFixityDecl]-- look in for "mentioned" vars.
+		 -> [ProtoNameClassDecl]
+		 -> [ProtoNameInstDecl]
+		 -> ProtoNameHsBinds
+
+		 -> (Bool,		-- True <=> M.. construct in exports
+		     Bag FAST_STRING)	-- list of vars "mentioned" in the module body
+
+getMentionedVars val_nf exports fixes class_decls inst_decls binds
+  = panic "getMentionedVars (RdrHsSyn)"
+{- TO THE END
+  = case (mention_IE exports) of { (module_dotdot_seen, export_mentioned) ->
+    (module_dotdot_seen,
+     initMentioned val_nf export_mentioned (
+--	mapMent fixity    fixes		`thenMent_` -- see note below.
+	mapMent classDecl class_decls	`thenMent_`
+	mapMent instDecl  inst_decls	`thenMent_`
+	bindsDecls True{-top-level-} binds )
+    )}
+\end{code}
+ToDo: if we ever do something proper with fixity declarations,
+we will need to create a @fixities@ function and make it do something.
+
+Here's relevant bit of monad fluff: hides carrying around
+the NameMapper function (down only) and passing along an
+accumulator:
+\begin{code}
+type MentionM nm a = NameMapper nm -> Bag FAST_STRING -> Bag FAST_STRING
+
+initMentioned :: NameMapper nm -> Bag FAST_STRING -> MentionM nm a -> Bag FAST_STRING
+thenMent_  :: MentionM nm a -> MentionM nm b -> MentionM nm b
+returnNothing :: MentionM nm a
+mapMent	   :: (a -> MentionM nm b) -> [a] -> MentionM nm b
+mentionedName  :: FAST_STRING   -> MentionM nm a
+mentionedNames :: [FAST_STRING] -> MentionM nm a
+lookupAndAdd   :: ProtoName -> MentionM nm a
+
+initMentioned val_nf acc action = action val_nf acc
+
+returnNothing val_nf acc = acc
+
+thenMent_ act1 act2 val_nf acc
+  = act2 val_nf (act1 val_nf acc)
+
+mapMent f []     = returnNothing
+mapMent f (x:xs)
+  = f x		    `thenMent_`
+    mapMent f xs
+
+mentionedName name val_nf acc
+  = acc `snocBag` name
+
+mentionedNames names val_nf acc
+  = acc `unionBags` listToBag names
+
+lookupAndAdd (Unk str) val_nf acc
+  | _LENGTH_ str >= 3 -- simply don't bother w/ very short names...
+  = case (val_nf str) of
+      Nothing -> acc `snocBag` str
+      Just _  -> acc
+
+lookupAndAdd _ _ acc = acc -- carry on with what we had
+\end{code}
+
+\begin{code}
+mention_IE :: [IE ProtoName] -> (Bool, Bag FAST_STRING)
+
+mention_IE exps
+  = foldr men (False, emptyBag) exps
+  where
+    men (IEVar str) (dotdot_seen, so_far) = (dotdot_seen, so_far `snocBag` str)
+    men (IEModuleContents _)  (_, so_far) = (True, so_far)
+    men other_ie    	      acc   	  = acc
+\end{code}
+
+\begin{code}
+classDecl (ClassDecl _ _ _ _ binds _ _)  = monoBinds True{-toplev-} binds
+instDecl  (InstDecl _ _ binds _ _ _ _ _) = monoBinds True{-toplev-} binds
+\end{code}
+
+\begin{code}
+bindsDecls toplev EmptyBinds	 = returnNothing
+bindsDecls toplev (ThenBinds a b)= bindsDecls toplev a `thenMent_` bindsDecls toplev b
+bindsDecls toplev (SingleBind a) = bindDecls toplev a
+bindsDecls toplev (BindWith a _) = bindDecls toplev a
+
+bindDecls toplev EmptyBind 	 = returnNothing
+bindDecls toplev (NonRecBind a)  = monoBinds toplev a
+bindDecls toplev (RecBind a)	 = monoBinds toplev a
+
+monoBinds toplev EmptyMonoBinds  = returnNothing
+monoBinds toplev (AndMonoBinds a b) = monoBinds toplev a `thenMent_` monoBinds toplev b
+monoBinds toplev (PatMonoBind p gb _)
+  = (if toplev
+    then mentionedNames (map stringify (collectPatBinders p))
+    else returnNothing)	`thenMent_`
+    grhssAndBinds gb
+
+monoBinds toplev (FunMonoBind v ms _)
+  = (if toplev
+    then mentionedName (stringify v)
+    else returnNothing) `thenMent_`
+    mapMent match ms
+
+stringify :: ProtoName -> FAST_STRING
+stringify (Unk s) = s
+\end{code}
+
+\begin{code}
+match (PatMatch _ m) = match m
+match (GRHSMatch gb) = grhssAndBinds gb
+
+grhssAndBinds (GRHSsAndBindsIn gs bs)
+  = mapMent grhs gs `thenMent_` bindsDecls False bs
+
+grhs (OtherwiseGRHS e _) = expr e
+grhs (GRHS g e _)	 = expr g  `thenMent_` expr e
+\end{code}
+
+\begin{code}
+expr (HsVar v)  = lookupAndAdd v
+
+expr (HsLit _) = returnNothing
+expr (HsLam m) = match m
+expr (HsApp a b)    = expr a `thenMent_` expr b
+expr (OpApp a b c)  = expr a `thenMent_` expr b `thenMent_` expr c
+expr (SectionL a b) = expr a `thenMent_` expr b
+expr (SectionR a b) = expr a `thenMent_` expr b
+expr (CCall _ es _ _ _) = mapMent expr es
+expr (HsSCC _ e)    = expr e
+expr (HsCase e ms _)= expr e `thenMent_` mapMent match ms
+expr (HsLet b e)    = expr e `thenMent_` bindsDecls False{-not toplev-} b
+expr (HsDo bs _)    = panic "mentioned_whatnot:RdrHsSyn:HsDo"
+expr (ListComp e q) = expr e `thenMent_` mapMent qual  q
+expr (ExplicitList es)   = mapMent expr es
+expr (ExplicitTuple es)  = mapMent expr es
+expr (RecordCon con  rbinds) = panic "mentioned:RdrHsSyn:RecordCon"
+expr (RecordUpd aexp rbinds) = panic "mentioned:RdrHsSyn:RecordUpd"
+expr (ExprWithTySig e _) = expr e
+expr (HsIf b t e _) = expr b `thenMent_` expr t `thenMent_` expr e
+expr (ArithSeqIn s) = arithSeq s
+
+arithSeq (From	     a)	    = expr a
+arithSeq (FromThen   a b)   = expr a `thenMent_` expr b
+arithSeq (FromTo     a b)   = expr a `thenMent_` expr b
+arithSeq (FromThenTo a b c) = expr a `thenMent_` expr b `thenMent_` expr c
+
+qual (GeneratorQual _ e) = expr e
+qual (FilterQual e)  	 = expr e
+qual (LetQual bs)	 = bindsDecls False{-not toplev-} bs
+-}
+\end{code}
diff --git a/ghc/compiler/reader/RdrLoop.lhi b/ghc/compiler/reader/RdrLoop.lhi
new file mode 100644
index 0000000000..debf4fc55d
--- /dev/null
+++ b/ghc/compiler/reader/RdrLoop.lhi
@@ -0,0 +1,25 @@
+This module breaks the loops among the reader modules
+ReadPragmas and ReadPrefix.
+
+\begin{code}
+interface RdrLoop where
+
+import PreludeStdIO	( Maybe )
+
+import U_list		( U_list )
+import U_maybe		( U_maybe )
+import U_ttype  	( U_ttype )
+import UgenUtil		( UgnM(..), ParseTree(..) )
+import ReadPrefix	( rdConDecl, rdMonoType, wlkList, wlkMaybe, wlkMonoType )
+import RdrHsSyn		( ProtoNameMonoType(..), ProtoNameConDecl(..) )
+
+data U_list
+data U_ttype
+
+rdConDecl   :: ParseTree -> UgnM ProtoNameConDecl
+rdMonoType  :: ParseTree -> UgnM ProtoNameMonoType
+wlkList	    :: (_Addr -> UgnM a) -> U_list -> UgnM [a]
+wlkMaybe    :: (_Addr -> UgnM a) -> U_maybe -> UgnM (Maybe a)
+wlkMonoType :: U_ttype -> UgnM ProtoNameMonoType
+\end{code}
+
diff --git a/ghc/compiler/reader/ReadPragmas.hi b/ghc/compiler/reader/ReadPragmas.hi
deleted file mode 100644
index d504e454da..0000000000
--- a/ghc/compiler/reader/ReadPragmas.hi
+++ /dev/null
@@ -1,46 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 3 #-}
-interface ReadPragmas where
-import BasicLit(BasicLit)
-import HsCore(UfId, UnfoldingCoreAtom, UnfoldingCoreExpr)
-import HsPragmas(ClassPragmas, DataPragmas, GenPragmas, InstancePragmas, TypePragmas)
-import HsTypes(MonoType, PolyType)
-import LiftMonad(LiftM)
-import Maybes(Labda)
-import PrefixSyn(RdrTySigPragmas)
-import ProtoName(ProtoName)
-import SimplEnv(UnfoldingGuidance)
-cvt_IdString :: [Char] -> ProtoName
-	{-# GHC_PRAGMA _A_ 1 _U_ 2 _S_ "S" _N_ _N_ #-}
-rdBasicLit :: [Char] -> LiftM (BasicLit, [Char])
-	{-# GHC_PRAGMA _A_ 1 _U_ 1 _S_ "S" _N_ _N_ #-}
-rdClassPragma :: [Char] -> LiftM (ClassPragmas ProtoName, [Char])
-	{-# GHC_PRAGMA _A_ 1 _U_ 1 _S_ "S" _N_ _N_ #-}
-rdCoreAtom :: [Char] -> LiftM (UnfoldingCoreAtom ProtoName, [Char])
-	{-# GHC_PRAGMA _A_ 1 _U_ 1 _S_ "S" _N_ _N_ #-}
-rdCoreBinder :: [Char] -> LiftM ((ProtoName, PolyType ProtoName), [Char])
-	{-# GHC_PRAGMA _A_ 1 _U_ 1 _S_ "S" _N_ _N_ #-}
-rdCoreExpr :: [Char] -> LiftM (UnfoldingCoreExpr ProtoName, [Char])
-	{-# GHC_PRAGMA _A_ 1 _U_ 1 _S_ "S" _N_ _N_ #-}
-rdCoreId :: [Char] -> LiftM (UfId ProtoName, [Char])
-	{-# GHC_PRAGMA _A_ 1 _U_ 1 _S_ "S" _N_ _N_ #-}
-rdCoreType :: [Char] -> LiftM (PolyType ProtoName, [Char])
-	{-# GHC_PRAGMA _A_ 1 _U_ 2 _S_ "S" _N_ _N_ #-}
-rdCoreTypeMaybe :: [Char] -> LiftM (Labda (PolyType ProtoName), [Char])
-	{-# GHC_PRAGMA _A_ 1 _U_ 1 _S_ "S" _N_ _N_ #-}
-rdDataPragma :: [Char] -> LiftM (DataPragmas ProtoName, [Char])
-	{-# GHC_PRAGMA _A_ 1 _U_ 1 _S_ "S" _N_ _N_ #-}
-rdGenPragma :: [Char] -> LiftM (GenPragmas ProtoName, [Char])
-	{-# GHC_PRAGMA _A_ 1 _U_ 1 _S_ "S" _N_ _N_ #-}
-rdGuidance :: [Char] -> LiftM (UnfoldingGuidance, [Char])
-	{-# GHC_PRAGMA _A_ 1 _U_ 1 _S_ "S" _N_ _N_ #-}
-rdInstPragma :: [Char] -> LiftM (Labda [Char], InstancePragmas ProtoName, [Char])
-	{-# GHC_PRAGMA _A_ 1 _U_ 1 _S_ "S" _N_ _N_ #-}
-rdMonoTypeMaybe :: [Char] -> LiftM (Labda (MonoType ProtoName), [Char])
-	{-# GHC_PRAGMA _A_ 1 _U_ 1 _S_ "S" _N_ _N_ #-}
-rdTySigPragmas :: [Char] -> LiftM (RdrTySigPragmas, [Char])
-	{-# GHC_PRAGMA _A_ 1 _U_ 2 _S_ "S" _N_ _N_ #-}
-rdTypePragma :: [Char] -> LiftM (TypePragmas, [Char])
-	{-# GHC_PRAGMA _A_ 1 _U_ 1 _S_ "S" _N_ _N_ #-}
-rd_constm :: [Char] -> LiftM ((ProtoName, GenPragmas ProtoName), [Char])
-	{-# GHC_PRAGMA _A_ 1 _U_ 1 _S_ "S" _N_ _N_ #-}
-
diff --git a/ghc/compiler/reader/ReadPragmas.lhs b/ghc/compiler/reader/ReadPragmas.lhs
index d46c28dd11..c62eb58889 100644
--- a/ghc/compiler/reader/ReadPragmas.lhs
+++ b/ghc/compiler/reader/ReadPragmas.lhs
@@ -1,167 +1,193 @@
 %
-% (c) The GRASP/AQUA Project, Glasgow University, 1993-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1993-1996
 %
-\section[ReadPragmas]{Read pragmatic interface info, including Core}
+\section{Read pragmatic interface info, including Core}
 
 \begin{code}
--- HBC does not have stack stubbing; you get a space leak w/
--- default defns from HsVersions.h.
+#include "HsVersions.h"
 
--- GHC may be overly slow to compile w/ the defaults...
+module ReadPragmas (
+	ProtoUfBinder(..),
 
-#define BIND {--}
-#define _TO_ `thenLft` ( \ {--}
-#define BEND )
-#define RETN returnLft
-#define RETN_TYPE LiftM
+	wlkClassPragma,
+	wlkDataPragma,
+	wlkInstPragma,
+	wlkTySigPragmas
+    ) where
 
-#include "HsVersions.h"
-\end{code}
+import Ubiq{-uitous-}
 
-\begin{code}
-module ReadPragmas where
-
-IMPORT_Trace		-- ToDo: rm (debugging)
-import Pretty
-
-import AbsPrel		( nilDataCon, readUnfoldingPrimOp, PrimOp(..), PrimKind
-			  IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
-			  IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
-			)
-import AbsSyn
-import BasicLit		( mkMachInt, BasicLit(..) )
-import HsCore		-- ****** NEED TO SEE CONSTRUCTORS ******
-import HsPragmas	-- ****** NEED TO SEE CONSTRUCTORS ******
+import RdrLoop	-- break dependency loop
+
+import UgenAll		-- all Yacc parser gumpff...
+import PrefixSyn	-- and various syntaxen.
+import HsSyn
+import RdrHsSyn
+import HsPragmas	-- NB: we are concerned with grimy
+import HsCore		-- *Pragmas and *Core stuff here
+
+-- others:
+import CoreUnfold	( UnfoldingGuidance(..) )
 import Id		( mkTupleCon )
-import IdInfo		-- ( UnfoldingGuidance(..) )
-import LiftMonad
-import Maybes		( Maybe(..) )
-import PrefixToHs
-import PrefixSyn
-import ProtoName
-import Outputable
-import ReadPrefix	( rdList, rdId, rdIdString, rdString, rdConDecl, rdMonoType )
-import Util
+import IdInfo
+import IdUtils		( primOpNameInfo )
+import Literal		( mkMachInt, Literal(..) )
+import Name		( Name(..) )
+import PrelInfo		( nilDataCon )
+import PrimOp		( PrimOp(..), allThePrimOps )
+import PrimRep		( guessPrimRep ) -- really, VERY horrible...
+import ProtoName	( ProtoName(..) )
+import Util		( assertPanic, panic )
 \end{code}
 
+Only used here:
 \begin{code}
-rdDataPragma :: String -> RETN_TYPE (ProtoNameDataPragmas, String)
+readUnfoldingPrimOp :: FAST_STRING -> PrimOp
 
-rdDataPragma ('P' : 'N' : xs) = RETN (DataPragmas [] [], xs)
-
-rdDataPragma ('P' : 'd' : xs)
-  = BIND (rdList (rdConDecl srcfile) xs)  _TO_ (cons, xs1) ->
-    BIND (rdList rd_spec xs1)  		  _TO_ (specs, xs2) ->
-    RETN (DataPragmas cons specs, xs2)
-    BEND BEND
-  where
-    srcfile = SLIT("<pragma>")
-
-    rd_spec ('P' : '4' : xs)
-      = BIND (rdList rdMonoTypeMaybe xs)  _TO_ (spec, xs1) ->
-	RETN (spec, xs1)
-	BEND
+readUnfoldingPrimOp
+  = let
+	-- "reverse" lookup table
+	tbl = map (\ o -> let { (str,_) = primOpNameInfo o } in (str, o)) allThePrimOps
+    in
+    \ str -> case [ op | (s, op) <- tbl, s == str ] of
+	       (op:_) -> op
+#ifdef DEBUG
+	       [] -> panic "readUnfoldingPrimOp" -- ++ _UNPK_ str ++"::"++show (map fst tbl))
+#endif
 \end{code}
 
 \begin{code}
-rdTypePragma :: String -> RETN_TYPE (TypePragmas, String)
+wlkDataPragma :: U_hpragma -> UgnM ProtoNameDataPragmas
+
+wlkDataPragma pragma
+  = case pragma of
+      U_no_pragma    -> returnUgn (DataPragmas [] [])
+      U_idata_pragma cs ss ->
+	wlkList rdConDecl cs `thenUgn` \ cons  ->
+	wlkList rd_spec   ss `thenUgn` \ specs ->
+	returnUgn (DataPragmas cons specs)
+  where
+    rd_spec pt
+      = rdU_hpragma pt  `thenUgn` \ stuff ->
+	case stuff of { U_idata_pragma_4s ss ->
 
-rdTypePragma ('P' : 'N' : xs) = RETN (NoTypePragmas, xs)
-rdTypePragma ('P' : 't' : xs) = RETN (AbstractTySynonym, xs)
+	wlkList rdMonoTypeMaybe ss `thenUgn` \ specs ->
+	returnUgn specs }
 \end{code}
 
 \begin{code}
-rdClassPragma :: String -> RETN_TYPE (ProtoNameClassPragmas, String)
-
-rdClassPragma ('P' : 'N' : xs) = RETN (NoClassPragmas, xs)
-rdClassPragma ('P' : 'c' : xs)
-  = BIND (rdList rdGenPragma xs)   _TO_ (gen_pragmas, xs1) ->
-    ASSERT(not (null gen_pragmas))
-    RETN (SuperDictPragmas gen_pragmas, xs1)
-    BEND
+wlkClassPragma :: U_hpragma -> UgnM ProtoNameClassPragmas
+
+wlkClassPragma pragma
+  = case pragma of
+      U_no_pragma    -> returnUgn NoClassPragmas
+      U_iclas_pragma gens ->
+	wlkList rdGenPragma gens `thenUgn` \ gen_pragmas ->
+	ASSERT(not (null gen_pragmas))
+	returnUgn (SuperDictPragmas gen_pragmas)
 \end{code}
 
 \begin{code}
-rdInstPragma :: String -> RETN_TYPE (Maybe FAST_STRING, ProtoNameInstancePragmas, String)
-
-rdInstPragma ('P' : 'N' : xs) = RETN (Nothing, NoInstancePragmas, xs)
-
-rdInstPragma ('P' : 'i' : 's' : xs)
-  = BIND (rdIdString  xs)   	_TO_ (modname,	   xs1) ->
-    BIND (rdGenPragma xs1)	_TO_ (gen_pragmas, xs2) ->
-    RETN (Just modname, SimpleInstancePragma gen_pragmas, xs2)
-    BEND BEND
-
-rdInstPragma ('P' : 'i' : 'c' : xs)
-  = BIND (rdIdString	     xs)  _TO_ (modname,	xs1) ->
-    BIND (rdGenPragma	     xs1) _TO_ (gen_pragma,	xs2) ->
-    BIND (rdList rd_constm   xs2) _TO_ (constm_pragmas, xs3) ->
-    RETN (Just modname, ConstantInstancePragma gen_pragma constm_pragmas, xs3)
-    BEND BEND BEND
-
-rd_constm ('P' : '1' : xs)
-  = BIND (rdId	xs)  _TO_ (name, xs1) ->
-    BIND (rdGenPragma  xs1) _TO_ (prag, xs2) ->
-    RETN ((name, prag), xs2)
-    BEND BEND
+wlkInstPragma :: U_hpragma -> UgnM ProtoNameInstancePragmas
+
+wlkInstPragma pragma
+  = case pragma of
+      U_no_pragma ->
+	returnUgn NoInstancePragmas
+
+      U_iinst_simpl_pragma dfun_gen ->
+	wlkGenPragma dfun_gen	`thenUgn` \ gen_pragmas ->
+	returnUgn (SimpleInstancePragma gen_pragmas)
+
+      U_iinst_const_pragma dfun_gen constm_stuff ->
+	wlkGenPragma	  dfun_gen     `thenUgn` \ gen_pragma	 ->
+	wlkList rd_constm constm_stuff `thenUgn` \ constm_pragmas ->
+	returnUgn (ConstantInstancePragma gen_pragma constm_pragmas)
+
+rd_constm pt
+  = rdU_hpragma pt  `thenUgn` \ stuff ->
+    case stuff of { U_iname_pragma_pr name gen ->
+
+    wlkGenPragma gen `thenUgn` \ prag ->
+    returnUgn (name, prag) }
 \end{code}
 
 \begin{code}
-rdGenPragma :: String -> RETN_TYPE (ProtoNameGenPragmas, String)
-
-rdGenPragma ('P' : 'N' : xs) = RETN (NoGenPragmas, xs)
-
-rdGenPragma ('P': 'g' : xs)
-  = BIND (rd_arity  xs)	      _TO_ (arity,  xs1) ->
-    BIND (rd_update xs1)      _TO_ (upd,    xs2) ->
-    BIND (rd_strict xs2)      _TO_ (strict, xs3) ->
-    BIND (rd_unfold xs3)      _TO_ (unfold, xs4) ->
-    BIND (rdList rd_spec xs4) _TO_ (specs,  xs5) ->
-ToDo: do something for DeforestInfo
-    RETN (GenPragmas arity upd strict unfold specs, xs5)
-    BEND BEND BEND BEND BEND
+rdGenPragma :: ParseTree -> UgnM ProtoNameGenPragmas
+
+rdGenPragma pt = rdU_hpragma pt `thenUgn` \ prag -> wlkGenPragma prag
+
+wlkGenPragma :: U_hpragma -> UgnM ProtoNameGenPragmas
+
+wlkGenPragma pragma
+  = case pragma of
+      U_no_pragma -> returnUgn noGenPragmas
+
+      U_igen_pragma aritee update deforest strct uf speccs ->
+	wlk_arity	aritee	 `thenUgn` \ arity   ->
+	wlk_update	update	 `thenUgn` \ upd     ->
+	wlk_deforest	deforest `thenUgn` \ def     ->
+	wlk_strict	strct	 `thenUgn` \ strict  ->
+	wlk_unfold	uf	 `thenUgn` \ unfold  ->
+	wlkList rd_spec	speccs	 `thenUgn` \ specs   ->
+	returnUgn (GenPragmas arity upd def strict unfold specs)
   where
-    rd_arity ('P' : 'N' : xs) = RETN (Nothing, xs)
-    rd_arity ('P' : 'A' : xs)
-      = BIND (rdIdString xs)	_TO_ (a_str, xs1) ->
-	RETN (Just ((read (_UNPK_ a_str))::Int), xs1)
-	BEND
-
-    rd_update ('P' : 'N' : xs) = RETN (Nothing, xs)
-    rd_update ('P' : 'u' : xs)
-      = BIND (rdIdString xs)	_TO_ (upd_spec, xs1) ->
-	RETN (Just ((read (_UNPK_ upd_spec))::UpdateInfo), xs1)
-	BEND
-
-    rd_unfold ('P' : 'N' : xs) = RETN (NoImpUnfolding, xs)
-
-    rd_unfold ('P' : 'M' : xs)
-      = BIND (rdIdString xs)	_TO_ (str, xs1) ->
-	RETN (ImpMagicUnfolding str, xs1)
-	BEND
-
-    rd_unfold ('P' : 'U' : xs)
-      = BIND (rdGuidance xs)	_TO_ (guidance, xs1) ->
-	BIND (rdCoreExpr xs1)	_TO_ (core, 	xs2) ->
-	RETN (ImpUnfolding guidance core, xs2)
-	BEND BEND
-
-    rd_strict ('P' : 'N' : xs) = RETN (NoImpStrictness, xs)
-    rd_strict ('P' : 'S' : xs)
-      = BIND (rdString    xs)	_TO_ (strict_spec, xs1) ->
-	BIND (rdGenPragma xs1)	_TO_ (wrkr_pragma, xs2) ->
-	let
-	    ww_strict_info = (read (_UNPK_ strict_spec))::[Demand]
-	in
-	RETN (ImpStrictness (trace "ImpStrictness" False) ww_strict_info wrkr_pragma, xs2)
-	BEND BEND
-
-    rd_spec ('P' : '2' : xs)
-      = BIND (rdList rdMonoTypeMaybe xs)  _TO_ (mono_tys_maybe, xs1) ->
-	BIND (rdIdString    	     xs1) _TO_ (num_dicts,  	xs2) ->
-	BIND (rdGenPragma            xs2) _TO_ (gen_prag, 	xs3) ->
-	RETN ((mono_tys_maybe, ((read (_UNPK_ num_dicts))::Int), gen_prag), xs3)
-	BEND BEND BEND
+    wlk_arity stuff
+      = case stuff of
+	  U_no_pragma -> returnUgn Nothing
+	  U_iarity_pragma arity ->
+	    returnUgn (Just arity)
+
+    ------------
+    wlk_update stuff
+      = case stuff of
+	  U_no_pragma -> returnUgn Nothing
+	  U_iupdate_pragma upd_spec ->
+	    returnUgn (Just ((read (_UNPK_ upd_spec))::UpdateInfo))
+
+    ------------
+    wlk_deforest stuff
+      = case stuff of
+	  U_no_pragma -> returnUgn Don'tDeforest
+	  U_ideforest_pragma -> returnUgn DoDeforest
+
+    ------------
+    wlk_unfold stuff
+      = case stuff of
+	  U_no_pragma -> returnUgn NoImpUnfolding
+
+	  U_imagic_unfolding_pragma magic ->
+	    returnUgn (ImpMagicUnfolding magic)
+
+	  U_iunfolding_pragma guide core ->
+	    wlkGuidance guide	`thenUgn` \ guidance ->
+	    wlkCoreExpr core	`thenUgn` \ coresyn  ->
+	    returnUgn (ImpUnfolding guidance coresyn)
+
+    ------------
+    wlk_strict stuff
+      = case stuff of
+	  U_no_pragma -> returnUgn NoImpStrictness
+
+	  U_istrictness_pragma strict_spec wrkr_stuff ->
+	    wlkGenPragma wrkr_stuff  `thenUgn` \ wrkr_pragma ->
+	    let
+		strict_spec_str = _UNPK_ strict_spec
+		(is_bot, ww_strict_info)
+		  = if (strict_spec_str == "B")
+		    then (True,  [])
+		    else (False, (read strict_spec_str)::[Demand])
+	    in
+	    returnUgn (ImpStrictness is_bot ww_strict_info wrkr_pragma)
+
+    ------------
+    rd_spec pt
+      = rdU_hpragma pt	`thenUgn` \ stuff ->
+	case stuff of { U_itype_pragma_pr maybe_tys num_dicts prag ->
+
+	wlkList rdMonoTypeMaybe	maybe_tys `thenUgn` \ mono_tys_maybe ->
+	wlkGenPragma		prag	  `thenUgn` \ gen_prag	     ->
+	returnUgn (mono_tys_maybe, num_dicts, gen_prag) }
 \end{code}
 
 The only tricky case is pragmas on signatures; we have no way of
@@ -169,366 +195,319 @@ knowing whether it is a @GenPragma@ or a @ClassOp@ pragma.  So we read
 whatever comes, store it in a @RdrTySigPragmas@ structure, and someone
 will sort it out later.
 \begin{code}
-rdTySigPragmas :: String -> RETN_TYPE (RdrTySigPragmas, String)
+wlkTySigPragmas :: U_hpragma -> UgnM RdrTySigPragmas
 
-rdTySigPragmas ('P' : 'N' : xs) = RETN (RdrNoPragma, xs)
+wlkTySigPragmas pragma
+  = case pragma of
+      U_no_pragma -> returnUgn RdrNoPragma
 
-rdTySigPragmas ('P' : 'o' : xs)
-  = BIND (rdGenPragma xs)   _TO_ (dsel_pragma, xs1) ->
-    BIND (rdGenPragma xs1)  _TO_ (defm_pragma, xs2) ->
-    RETN (RdrClassOpPragmas (ClassOpPragmas dsel_pragma defm_pragma), xs2)
-    BEND BEND
+      U_iclasop_pragma dsel defm ->
+	wlkGenPragma dsel   `thenUgn` \ dsel_pragma ->
+	wlkGenPragma defm   `thenUgn` \ defm_pragma ->
+	returnUgn (RdrClassOpPragmas (ClassOpPragmas dsel_pragma defm_pragma))
 
-rdTySigPragmas xs
-  = BIND (rdGenPragma 	 xs)  _TO_ (gen_pragmas, xs1) ->
-    RETN (RdrGenPragmas gen_pragmas, xs1)
-    BEND
+      other ->
+	wlkGenPragma other  `thenUgn` \ gen_pragmas ->
+	returnUgn (RdrGenPragmas gen_pragmas)
 \end{code}
 
 \begin{code}
-rdGuidance ('P' : 'x' : xs) = RETN (UnfoldAlways, xs)
-
--- EssentialUnfolding should never appear in interfaces, so we
--- don't have any way to read them.
-
-rdGuidance ('P' : 'y' : xs)
-  = BIND (rdIdString xs)	_TO_ (m_ty_args,    xs1) ->
-    BIND (rdIdString xs1)	_TO_ (n_val_args,   xs2) ->
-    BIND (rdIdString xs2)	_TO_ (con_arg_spec, xs3) ->
-    BIND (rdIdString xs3)   	_TO_ (size_str,	    xs4) ->
-    let
-	num_val_args = ((read (_UNPK_ n_val_args)) :: Int)
-	con_arg_info = take num_val_args (map cvt (_UNPK_ con_arg_spec))
-	-- if there were 0 args, we want to throw away
-	-- any dummy con_arg_spec stuff...
-    in
-    RETN (UnfoldIfGoodArgs (read (_UNPK_ m_ty_args)) num_val_args
-		con_arg_info (read (_UNPK_ size_str)), xs4)
-    BEND BEND BEND BEND
-  where
-    cvt 'C' = True  -- want a constructor in this arg position
-    cvt _   = False
-
-{- OLD:
-rdGuidance ('P' : 'z' : xs)
-  = BIND (rdIdString xs)	_TO_ (m_ty_args, xs1) ->
-    BIND (rdIdString xs1)	_TO_ (size,	 xs2) ->
-    RETN (trace "read:UnfoldIsCon" UnfoldNever, xs2) -- ToDo: rm
-    BEND BEND
--}
+wlkGuidance guide
+  = case guide of
+      U_iunfold_always -> returnUgn UnfoldAlways
+
+      U_iunfold_if_args num_ty_args num_val_args con_arg_spec size ->
+	let
+	    con_arg_info = take num_val_args (map cvt (_UNPK_ con_arg_spec))
+	    -- if there were 0 args, we want to throw away
+	    -- any dummy con_arg_spec stuff...
+	in
+	returnUgn (UnfoldIfGoodArgs num_ty_args num_val_args
+		    con_arg_info size)
+	where
+	  cvt 'C' = True  -- want a constructor in this arg position
+	  cvt _   = False
 \end{code}
 
 \begin{code}
-rdCoreExpr :: String -> RETN_TYPE (ProtoNameUnfoldingCoreExpr, String)
-
-rdCoreExpr ('F' : 'g' : xs)
-  = BIND (rdCoreId   xs)	_TO_ (var, xs1) ->
-    RETN (UfCoVar var, xs1)
-    BEND
-
-rdCoreExpr ('F' : 'h' : xs)
-  = BIND (rdBasicLit xs)	_TO_ (lit, xs1) ->
-    RETN (UfCoLit lit, xs1)
-    BEND
-
-rdCoreExpr ('F' : 'i' : xs)
-  = BIND (rdCoreId xs)		    _TO_ (BoringUfId con, xs1) ->
-    BIND (rdList rdCoreType xs1)    _TO_ (tys, xs2) ->
-    BIND (rdList rdCoreAtom xs2)    _TO_ (vs,  xs3) ->
-    RETN (UfCoCon con tys vs, xs3)
-    BEND BEND BEND
-
-rdCoreExpr ('F' : 'j' : xs)
-  = BIND (rd_primop xs)		    _TO_ (op,  xs1) ->
-    BIND (rdList rdCoreType xs1)    _TO_ (tys, xs2) ->
-    BIND (rdList rdCoreAtom xs2)    _TO_ (vs,  xs3) ->
-    RETN (UfCoPrim op tys vs, xs3)
-    BEND BEND BEND
-  where
-
--- Question: why did ccall once panic if you looked at the maygc flag?
--- Was this just laziness or is it not needed?  In that case, modify
--- the stuff that writes them to pragmas so that it never adds the _GC_
--- tag. ADR
-
-    rd_primop ('F' : 'w' : xs)
-      = BIND (rdIdString xs)	_TO_ (op_str, xs1) ->
-	RETN (UfOtherOp (readUnfoldingPrimOp op_str), xs1)
-	BEND
-    rd_primop ('F' : 'x' : t_or_f : xs)
-      = BIND (rdIdString    	xs)  _TO_ (fun_str, xs1) ->
-	BIND (rdList rdCoreType xs1) _TO_ (arg_tys, xs2) ->
-	BIND (rdCoreType    	xs2) _TO_ (res_ty,  xs3) ->
-	RETN (UfCCallOp fun_str False (is_T_or_F t_or_f) arg_tys res_ty, xs3)
-	BEND BEND BEND
-    rd_primop ('F' : 'y' : t_or_f : xs)
-      = BIND (rdBasicLit    	xs)  _TO_ (casm_litlit, xs1) ->
-	BIND (rdList rdCoreType xs1) _TO_ (arg_tys, xs2) ->
-	BIND (rdCoreType    	xs2) _TO_ (res_ty,  xs3) ->
+wlkCoreExpr :: U_coresyn -> UgnM ProtoNameUnfoldingCoreExpr
+
+wlkCoreExpr core_expr
+  = case core_expr of
+      U_covar v ->
+	wlkCoreId  v	`thenUgn` \ var ->
+	returnUgn (UfVar var)
+
+      U_coliteral l ->
+	wlkBasicLit l	`thenUgn` \ lit ->
+	returnUgn (UfLit lit)
+
+      U_cocon c ts as ->
+	wlkCoreId c		`thenUgn` \ (BoringUfId con) ->
+	wlkList rdCoreType ts	`thenUgn` \ tys ->
+	wlkList rdCoreAtom as	`thenUgn` \ vs  ->
+	returnUgn (UfCon con tys vs)
+
+      U_coprim o ts as ->
+	wlk_primop	   o	`thenUgn` \ op  ->
+	wlkList rdCoreType ts   `thenUgn` \ tys ->
+	wlkList rdCoreAtom as	`thenUgn` \ vs  ->
 	let
-	    (MachLitLit casm_str _) = casm_litlit
+	    fixed_vs = case op of { UfOtherOp pop -> fixup pop vs ; _ -> vs }
 	in
-	RETN (UfCCallOp casm_str True (is_T_or_F t_or_f) arg_tys res_ty, xs3)
-	BEND BEND BEND
-
-    is_T_or_F 'T' = True
-    is_T_or_F 'F' = False
-
-rdCoreExpr ('F' : 'k' : xs)
-  = BIND (rdList rdCoreBinder xs)   _TO_ (bs,   xs1) ->
-    BIND (rdCoreExpr	      xs1)  _TO_ (body, xs2) ->
-    RETN (UfCoLam bs body, xs2)
-    BEND BEND
-
-rdCoreExpr ('F' : 'l' : xs)
-  = BIND (rdList rdId	xs)	    _TO_ (tvs,  xs1) ->
-    BIND (rdCoreExpr	xs1)	    _TO_ (body, xs2) ->
-    RETN (foldr UfCoTyLam body tvs, xs2)
-    BEND BEND
-
-rdCoreExpr ('F' : 'm' : xs)
-  = BIND (rdCoreExpr	    xs)	    _TO_ (fun,  xs1) ->
-    BIND (rdList rdCoreAtom xs1)    _TO_ (args, xs2) ->
-    RETN (foldl UfCoApp fun args, xs2)
-    BEND BEND
-
-
-rdCoreExpr ('F' : 'n' : xs)
-  = BIND (rdCoreExpr	xs)	    _TO_ (expr, xs1) ->
-    BIND (rdCoreType	xs1)	    _TO_ (ty,   xs2) ->
-    RETN (UfCoTyApp expr ty, xs2)
-    BEND BEND
-
-rdCoreExpr ('F' : 'o' : xs)
-  = BIND (rdCoreExpr	xs)	    _TO_ (scrut, xs1) ->
-    BIND (rd_alts	xs1)	    _TO_ (alts,  xs2) ->
-    RETN (UfCoCase scrut alts, xs2)
-    BEND BEND
-  where
-    rd_alts ('F' : 'q' : xs)
-      = BIND (rdList rd_alg_alt xs)	_TO_ (alts,  xs1) ->
-	BIND (rd_deflt	    	xs1)	_TO_ (deflt, xs2) ->
-	RETN (UfCoAlgAlts alts deflt, xs2)
-	BEND BEND
-      where
-	rd_alg_alt ('F' : 'r' : xs)
-	  = BIND (rdCoreId	      xs)   _TO_ (BoringUfId con, xs1) ->
-	    BIND (rdList rdCoreBinder xs1)  _TO_ (params,   	  xs2) ->
-	    BIND (rdCoreExpr	      xs2)  _TO_ (rhs,	    	  xs3) ->
-	    RETN ((con, params, rhs), xs3)
-	    BEND BEND BEND
-
-    rd_alts ('F' : 's' : xs)
-      = BIND (rdList rd_prim_alt xs)	_TO_ (alts,  xs1) ->
-	BIND (rd_deflt	    	 xs1)	_TO_ (deflt, xs2) ->
-	RETN (UfCoPrimAlts alts deflt, xs2)
-	BEND BEND
-      where
-	rd_prim_alt ('F' : 't' : xs)
-	  = BIND (rdBasicLit	xs)   _TO_ (lit, xs1) ->
-	    BIND (rdCoreExpr	xs1)  _TO_ (rhs, xs2) ->
-	    RETN ((lit, rhs), xs2)
-	    BEND BEND
-
-    rd_deflt ('F' : 'u' : xs) = RETN (UfCoNoDefault, xs)
-    rd_deflt ('F' : 'v' : xs)
-      = BIND (rdCoreBinder xs)	_TO_ (b,   xs1) ->
-        BIND (rdCoreExpr   xs1)	_TO_ (rhs, xs2) ->
-	RETN (UfCoBindDefault b rhs, xs2)
-	BEND BEND
-
-rdCoreExpr ('F' : 'p' : xs)
-  = BIND (rd_bind    xs)  _TO_ (bind, xs1) ->
-    BIND (rdCoreExpr xs1) _TO_ (body, xs2) ->
-    RETN (UfCoLet bind body, xs2)
-    BEND BEND
-  where
-    rd_bind ('F' : 'd' : xs)
-      = BIND (rdCoreBinder xs)	_TO_ (b,   xs1) ->
-        BIND (rdCoreExpr   xs1) _TO_ (rhs, xs2) ->
-	RETN (UfCoNonRec b rhs, xs2)
-	BEND BEND
-
-    rd_bind ('F' : 'e' : xs)
-      = BIND (rdList rd_pair xs) _TO_ (pairs, xs1) ->
-        RETN (UfCoRec pairs, xs1)
-        BEND
+	returnUgn (UfPrim op tys fixed_vs)
+       where
+
+	-- Question: why did ccall once panic if you looked at the
+	-- maygc flag?  Was this just laziness or is it not needed?
+	-- In that case, modify the stuff that writes them to pragmas
+	-- so that it never adds the _GC_ tag. ADR
+
+	wlk_primop op
+	  = case op of
+	      U_co_primop op_str ->
+		returnUgn (UfOtherOp (readUnfoldingPrimOp op_str))
+
+	      U_co_ccall fun_str may_gc a_tys r_ty ->
+		wlkList rdCoreType a_tys `thenUgn` \ arg_tys ->
+		wlkCoreType	   r_ty	 `thenUgn` \ res_ty  ->
+		returnUgn (UfCCallOp fun_str False (is_T_or_F may_gc) arg_tys res_ty)
+
+	      U_co_casm litlit may_gc a_tys r_ty ->
+		wlkBasicLit	    litlit  `thenUgn` \ (MachLitLit casm_str _) ->
+		wlkList rdCoreType  a_tys   `thenUgn` \ arg_tys	    ->
+		wlkCoreType	    r_ty    `thenUgn` \ res_ty	    ->
+		returnUgn (UfCCallOp casm_str True (is_T_or_F may_gc) arg_tys res_ty)
+	  where
+	    is_T_or_F 0 = False
+	    is_T_or_F _ = True
+
+	-- Now *this* is a hack: we can't distinguish Int# literals
+	-- from Word# literals as they come in; this is only likely
+	-- to bite on the args of certain PrimOps (shifts, etc); so
+	-- we look for those and fix things up!!! (WDP 95/05)
+
+	fixup AndOp    [a1, a2] = [fixarg a1, fixarg a2]
+	fixup OrOp     [a1, a2] = [fixarg a1, fixarg a2]
+	fixup NotOp    [a1]     = [fixarg a1]
+	fixup SllOp    [a1, a2] = [fixarg a1, a2]
+	fixup SraOp    [a1, a2] = [fixarg a1, a2]
+	fixup SrlOp    [a1, a2] = [fixarg a1, a2]
+	fixup WordGtOp [a1, a2] = [fixarg a1, fixarg a2]
+	fixup WordGeOp [a1, a2] = [fixarg a1, fixarg a2]
+	fixup WordLtOp [a1, a2] = [fixarg a1, fixarg a2]
+	fixup WordLeOp [a1, a2] = [fixarg a1, fixarg a2]
+	fixup WordEqOp [a1, a2] = [fixarg a1, fixarg a2]
+	fixup WordNeOp [a1, a2] = [fixarg a1, fixarg a2]
+	fixup _	       as	= as
+
+	fixarg (UfCoLitAtom (MachInt i _)) = UfCoLitAtom (MachInt i False{-unsigned-})
+	fixarg arg			   = arg
+
+      U_colam vars expr ->
+	wlkList rdCoreBinder vars   `thenUgn` \ bs   ->
+	wlkCoreExpr	     expr   `thenUgn` \ body ->
+	returnUgn (foldr UfLam body bs)
+
+      U_coapp f as ->
+	wlkCoreExpr	   f	`thenUgn` \ fun  ->
+	wlkList rdCoreAtom as	`thenUgn` \ args ->
+	returnUgn (foldl UfApp fun args)
+
+      U_cocase s as ->
+	wlkCoreExpr s	    `thenUgn` \ scrut ->
+	wlk_alts    as	    `thenUgn` \ alts  ->
+	returnUgn (UfCase scrut alts)
+       where
+	wlk_alts (U_coalg_alts as d)
+	  = wlkList rd_alg_alt as   `thenUgn` \ alts  ->
+	    wlk_deflt	       d    `thenUgn` \ deflt ->
+	    returnUgn (UfCoAlgAlts alts deflt)
+	  where
+	    rd_alg_alt pt
+	      = rdU_coresyn pt	`thenUgn` \ (U_coalg_alt c bs exp) ->
+
+		wlkCoreId	     c   `thenUgn` \ (BoringUfId con) ->
+		wlkList rdCoreBinder bs  `thenUgn` \ params	      ->
+		wlkCoreExpr	     exp `thenUgn` \ rhs	      ->
+		returnUgn (con, params, rhs)
+
+	wlk_alts (U_coprim_alts as d)
+	  = wlkList rd_prim_alt as  `thenUgn` \ alts  ->
+	    wlk_deflt	    	d   `thenUgn` \ deflt ->
+	    returnUgn (UfCoPrimAlts alts deflt)
+	  where
+	    rd_prim_alt pt
+	      = rdU_coresyn pt	`thenUgn` \ (U_coprim_alt l exp) ->
+
+		wlkBasicLit l   `thenUgn` \ lit ->
+		wlkCoreExpr exp `thenUgn` \ rhs ->
+		returnUgn (lit, rhs)
+
+	wlk_deflt U_conodeflt = returnUgn UfCoNoDefault
+	wlk_deflt (U_cobinddeflt v exp)
+	  = wlkCoreBinder v	`thenUgn` \ b   ->
+	    wlkCoreExpr   exp	`thenUgn` \ rhs ->
+	    returnUgn (UfCoBindDefault b rhs)
+
+      U_colet b expr ->
+	wlk_bind    b    `thenUgn` \ bind ->
+	wlkCoreExpr expr `thenUgn` \ body ->
+	returnUgn (UfLet bind body)
+       where
+	wlk_bind (U_cononrec v expr)
+	  = wlkCoreBinder v	`thenUgn` \ b	->
+	    wlkCoreExpr   expr	`thenUgn` \ rhs ->
+	    returnUgn (UfCoNonRec b rhs)
+
+	wlk_bind (U_corec prs)
+	  = wlkList rd_pair prs `thenUgn` \ pairs ->
+	    returnUgn (UfCoRec pairs)
+	  where
+	    rd_pair pt
+	      = rdU_coresyn pt	`thenUgn` \ (U_corec_pair v expr) ->
+
+		wlkCoreBinder v    `thenUgn` \ b   ->
+		wlkCoreExpr   expr `thenUgn` \ rhs ->
+		returnUgn (b, rhs)
+
+      U_coscc c expr ->
+	wlk_cc	    c    `thenUgn` \ cc   ->
+	wlkCoreExpr expr `thenUgn` \ body ->
+	returnUgn (UfSCC cc body)
       where
-	rd_pair ('F' : 'f' : xs)
-	  = BIND (rdCoreBinder xs)  _TO_ (b,   xs1) ->
-	    BIND (rdCoreExpr   xs1) _TO_ (rhs, xs2) ->
-	    RETN ((b, rhs), xs2)
-	    BEND BEND
-
-rdCoreExpr ('F' : 'z' : xs)
-  = BIND (rd_cc	     xs)  _TO_ (cc,   xs1) ->
-    BIND (rdCoreExpr xs1) _TO_ (body, xs2) ->
-    RETN (UfCoSCC cc body, xs2)
-    BEND BEND
-  where
-    rd_cc ('F' : '?' : 'a' : xs)
-      = BIND (rd_dupd xs)	_TO_ (is_dupd, xs1) ->
-        RETN (UfPreludeDictsCC is_dupd, xs1)
-	BEND
-
-    rd_cc ('F' : '?' : 'b' : xs)
-      = BIND (rdString xs)	_TO_ (m,       xs1) ->
-	BIND (rdString xs1)	_TO_ (g,       xs2) ->
-        BIND (rd_dupd  xs2)	_TO_ (is_dupd, xs3) ->
-	RETN (UfAllDictsCC m g is_dupd, xs3)
-	BEND BEND BEND
-
-    rd_cc ('F' : '?' : 'c' : xs)
-      = BIND (rdString xs)	_TO_ (n, xs1) ->
-	BIND (rdString xs1)	_TO_ (m, xs2) ->
-	BIND (rdString xs2)	_TO_ (g, xs3) ->
-	BIND (rd_dupd  xs3)	_TO_ (is_dupd, xs4) ->
-	BIND (rd_cafd  xs4)	_TO_ (is_cafd, xs5) ->
-	RETN (UfUserCC n m g is_dupd is_cafd, xs5)
-	BEND BEND BEND BEND BEND
-
-    rd_cc ('F' : '?' : 'd' : xs)
-      = BIND (rdCoreId	 xs)	_TO_ (i, xs1) ->
-	BIND (rdString xs1)	_TO_ (m, xs2) ->
-	BIND (rdString xs2)	_TO_ (g, xs3) ->
-	BIND (rd_dupd  xs3)	_TO_ (is_dupd, xs4) ->
-	BIND (rd_cafd  xs4)	_TO_ (is_cafd, xs5) ->
-	RETN (UfAutoCC i m g is_dupd is_cafd, xs5)
-	BEND BEND BEND BEND BEND
-
-    rd_cc ('F' : '?' : 'e' : xs)
-      = BIND (rdCoreId	 xs)	_TO_ (i, xs1) ->
-	BIND (rdString xs1)	_TO_ (m, xs2) ->
-	BIND (rdString xs2)	_TO_ (g, xs3) ->
-	BIND (rd_dupd  xs3)	_TO_ (is_dupd, xs4) ->
-	BIND (rd_cafd  xs4)	_TO_ (is_cafd, xs5) ->
-	RETN (UfDictCC i m g is_dupd is_cafd, xs5)
-	BEND BEND BEND BEND BEND
-
-    ------
-    rd_cafd ('F' : '?' : 'f' : xs) = RETN (False, xs)
-    rd_cafd ('F' : '?' : 'g' : xs) = RETN (True,  xs)
---  rd_cafd xs = panic ("rd_cafd:\n"++xs)
-    
-    rd_dupd ('F' : '?' : 'h' : xs) = RETN (False, xs)
-    rd_dupd ('F' : '?' : 'i' : xs) = RETN (True,  xs)
+	wlk_cc (U_co_preludedictscc dupd)
+	  = wlk_dupd dupd	`thenUgn` \ is_dupd ->
+	    returnUgn (UfPreludeDictsCC is_dupd)
+
+	wlk_cc (U_co_alldictscc m g dupd)
+	  = wlk_dupd dupd	`thenUgn` \ is_dupd ->
+	    returnUgn (UfAllDictsCC m g is_dupd)
+
+	wlk_cc (U_co_usercc n m g dupd cafd)
+	  = wlk_dupd dupd	`thenUgn` \ is_dupd ->
+	    wlk_cafd cafd	`thenUgn` \ is_cafd ->
+	    returnUgn (UfUserCC n m g is_dupd is_cafd)
+
+	wlk_cc (U_co_autocc id m g dupd cafd)
+	  = wlkCoreId id	`thenUgn` \ i	    ->
+	    wlk_dupd  dupd	`thenUgn` \ is_dupd ->
+	    wlk_cafd  cafd	`thenUgn` \ is_cafd ->
+	    returnUgn (UfAutoCC i m g is_dupd is_cafd)
+
+	wlk_cc (U_co_dictcc id m g dupd cafd)
+	  = wlkCoreId id	`thenUgn` \ i	    ->
+	    wlk_dupd  dupd	`thenUgn` \ is_dupd ->
+	    wlk_cafd  cafd	`thenUgn` \ is_cafd ->
+	    returnUgn (UfDictCC i m g is_dupd is_cafd)
+
+	------
+	wlk_cafd U_co_scc_noncaf  = returnUgn False
+	wlk_cafd U_co_scc_caf	  = returnUgn True
+
+	wlk_dupd U_co_scc_nondupd = returnUgn False
+	wlk_dupd U_co_scc_dupd	  = returnUgn True
 \end{code}
 
 \begin{code}
-rdCoreBinder ('F' : 'a' : xs)
-  = BIND (rdId		xs)	_TO_ (b,  xs1) ->
-    BIND (rdCoreType	xs1)	_TO_ (ty, xs2) ->
-    RETN ((b, ty), xs2)
-    BEND BEND
-
-rdCoreAtom ('F' : 'b' : xs)
-  = BIND (rdBasicLit xs) _TO_ (lit, xs1) ->
-    RETN (UfCoLitAtom lit, xs1)
-    BEND
-
-rdCoreAtom ('F' : 'c' : xs)
-  = BIND (rdCoreId xs)	 _TO_ (v,   xs1) ->
-    RETN (UfCoVarAtom v, xs1)
-    BEND
-\end{code}
+type ProtoUfBinder = (ProtoName, PolyType ProtoName)
 
-\begin{code}
-rdCoreType :: String -> RETN_TYPE (ProtoNamePolyType, String)
-
-rdCoreType ('2' : 'C' : xs)
-  = BIND (rdList rdId xs)   	_TO_ (tvs, xs1) ->
-    BIND (rdMonoType  xs1)  	_TO_ (ty,  xs2) ->
-    RETN (ForAllTy tvs ty, xs2)
-    BEND BEND
-
-rdCoreType other
-  = BIND (rdMonoType other) 	_TO_ (ty, xs1) ->
-    RETN (UnoverloadedTy ty, xs1)
-    BEND
+rdCoreBinder :: ParseTree -> UgnM ProtoUfBinder
+
+rdCoreBinder pt = rdU_coresyn pt `thenUgn` \ x -> wlkCoreBinder x
+
+wlkCoreBinder :: U_coresyn -> UgnM ProtoUfBinder
+
+wlkCoreBinder (U_cobinder b t)
+  = wlkCoreType	t   `thenUgn` \ ty ->
+    returnUgn (b, ty)
+
+rdCoreAtom pt
+  = rdU_coresyn pt `thenUgn` \ atom ->
+    case atom of
+      U_colit l ->
+	wlkBasicLit l	`thenUgn` \ lit ->
+	returnUgn (UfCoLitAtom lit)
+
+      U_colocal var ->
+	wlkCoreId var	`thenUgn` \ v ->
+	returnUgn (UfCoVarAtom v)
 \end{code}
 
 \begin{code}
-rdCoreTypeMaybe :: String -> RETN_TYPE(Maybe ProtoNamePolyType, String)
+rdCoreType :: ParseTree -> UgnM ProtoNamePolyType
+
+rdCoreType pt = rdU_ttype pt `thenUgn` \ ttype -> wlkCoreType ttype
+
+wlkCoreType :: U_ttype -> UgnM ProtoNamePolyType
 
-rdCoreTypeMaybe ('2' : 'D' : xs) = RETN(Nothing, xs)
-rdCoreTypeMaybe ('2' : 'E' : xs)
-  = BIND (rdCoreType xs)    _TO_ (ty, xs1) ->
-    RETN(Just ty, xs1)
-    BEND
+wlkCoreType other
+  = panic "ReadPragmas:wlkCoreType:ToDo"
+{- LATER:
+wlkCoreType (U_uniforall ts t)
+  = wlkList rdU_???unkId ts    `thenUgn` \ tvs ->
+    wlkMonoType       t	    `thenUgn` \ ty  ->
+    returnUgn (HsForAllTy tvs ty)
 
-rdMonoTypeMaybe ('2' : 'D' : xs) = RETN (Nothing, xs)
+wlkCoreType other
+  = wlkMonoType other 	`thenUgn` \ ty ->
+    returnUgn (UnoverloadedTy ty)
+-}
+\end{code}
 
-rdMonoTypeMaybe ('2' : 'E' : xs)
-  = BIND (rdMonoType xs) _TO_ (mono_ty, xs1) ->
-    RETN (Just mono_ty, xs1)
-    BEND
+\begin{code}
+rdMonoTypeMaybe pt
+  = rdU_maybe pt `thenUgn` \ ty_maybe ->
+    wlkMaybe rdMonoType ty_maybe
 \end{code}
 
 \begin{code}
-rdCoreId :: String -> RETN_TYPE (UfId ProtoName, String)
-
-rdCoreId ('F' : '1' : xs)
-  = BIND (rdIdString xs)	_TO_ (v, xs1) ->
-    RETN (BoringUfId (cvt_IdString v), xs1)
-    BEND
-rdCoreId ('F' : '9' : xs)
-  = BIND (rdIdString xs)	_TO_ (mod, xs1) ->
-    BIND (rdIdString xs1)	_TO_ (nm,  xs2) ->
-    RETN (BoringUfId (Imp mod nm [mod]{-dubious, but doesn't matter-} nm), xs2)
-    BEND BEND
-rdCoreId ('F' : '2' : xs)
-  = BIND (rdId xs)		_TO_ (clas, 	  xs1) ->
-    BIND (rdId xs1)		_TO_ (super_clas, xs2) ->
-    RETN (SuperDictSelUfId clas super_clas, xs2)
-    BEND BEND
-rdCoreId ('F' : '3' : xs)
-  = BIND (rdId xs)		_TO_ (clas,   xs1) ->
-    BIND (rdId xs1)		_TO_ (method, xs2) ->
-    RETN (ClassOpUfId clas method, xs2)
-    BEND BEND
-rdCoreId ('F' : '4' : xs)
-  = BIND (rdId xs)		_TO_ (clas,   xs1) ->
-    BIND (rdId xs1)		_TO_ (method, xs2) ->
-    RETN (DefaultMethodUfId clas method, xs2)
-    BEND BEND
-rdCoreId ('F' : '5' : xs)
-  = BIND (rdId 	     xs)	_TO_ (clas, xs1) ->
-    BIND (rdCoreType xs1)	_TO_ (ty,   xs2) ->
-    RETN (DictFunUfId clas ty, xs2)
-    BEND BEND
-rdCoreId ('F' : '6' : xs)
-  = BIND (rdId 	     xs)	_TO_ (clas, xs1) ->
-    BIND (rdId	     xs1)	_TO_ (op,   xs2) ->
-    BIND (rdCoreType xs2)	_TO_ (ty,   xs3) ->
-    RETN (ConstMethodUfId clas op ty, xs3)
-    BEND BEND BEND
-rdCoreId ('F' : '7' : xs)
-  = BIND (rdCoreId xs)	    	    	_TO_ (unspec,    xs1) ->
-    BIND (rdList rdMonoTypeMaybe xs1)	_TO_ (ty_maybes, xs2) ->
-    RETN (SpecUfId unspec ty_maybes, xs2)
-    BEND BEND
-rdCoreId ('F' : '8' : xs)
-  = BIND (rdCoreId xs)	    	    	_TO_ (unwrkr,    xs1) ->
-    RETN (WorkerUfId unwrkr, xs1)
-    BEND
+wlkCoreId :: U_coresyn -> UgnM (UfId ProtoName)
+
+wlkCoreId (U_co_id v)
+  = returnUgn (BoringUfId (cvt_IdString v))
+
+wlkCoreId (U_co_orig_id mod nm)
+  = returnUgn (BoringUfId (Imp mod nm [mod]{-dubious, but doesn't matter-} nm))
+
+wlkCoreId (U_co_sdselid clas super_clas)
+  = returnUgn (SuperDictSelUfId clas super_clas)
+
+wlkCoreId (U_co_classopid clas method)
+  = returnUgn (ClassOpUfId clas method)
+
+wlkCoreId (U_co_defmid clas method)
+  = returnUgn (DefaultMethodUfId clas method)
 
+wlkCoreId (U_co_dfunid clas t)
+  = wlkCoreType t   `thenUgn` \ ty ->
+    returnUgn (DictFunUfId clas ty)
+
+wlkCoreId (U_co_constmid clas op t)
+  = wlkCoreType t   `thenUgn` \ ty ->
+    returnUgn (ConstMethodUfId clas op ty)
+
+wlkCoreId (U_co_specid id tys)
+  = wlkCoreId		    id	`thenUgn` \ unspec    ->
+    wlkList rdMonoTypeMaybe tys	`thenUgn` \ ty_maybes ->
+    returnUgn (SpecUfId unspec ty_maybes)
+
+wlkCoreId (U_co_wrkrid un)
+  = wlkCoreId un	`thenUgn` \ unwrkr ->
+    returnUgn (WorkerUfId unwrkr)
+
+------------
 cvt_IdString :: FAST_STRING -> ProtoName
 
 cvt_IdString s
   = if (_HEAD_ s /= '_') then
 	boring
     else if (sub_s == SLIT("NIL_")) then
---	trace (show s++"/*1*/"++show sub_s++"/"++show (_SUBSTR_ s 5 99999)++"\n") (
     	Prel (WiredInVal nilDataCon)
---	)
     else if (sub_s == SLIT("TUP_")) then
---	trace (show s++"/*2*/"++show sub_s++"/"++show (_SUBSTR_ s 5 99999)++"\n") (
 	Prel (WiredInVal (mkTupleCon arity))
---	)
     else
---	trace (show s++"/*3*/"++show sub_s++"/"++show (_SUBSTR_ s 5 99999)++"\n") (
 	boring
---	)
   where
     boring = Unk s
     sub_s  = _SUBSTR_ s 1 4	-- chars 1--4 (0-origin)
@@ -537,44 +516,32 @@ cvt_IdString s
 \end{code}
 
 \begin{code}
-rdBasicLit :: String -> RETN_TYPE (BasicLit, String)
+wlkBasicLit :: U_literal -> UgnM Literal
 
-rdBasicLit ('R' : xs)
-  = BIND (rdString xs)  _TO_ (n, xs1) ->
-    BIND (rdString xs1) _TO_ (d, xs2) ->
-    let
+wlkBasicLit (U_norepr n d)
+  = let
 	num = ((read (_UNPK_ n)) :: Integer)
 	den = ((read (_UNPK_ d)) :: Integer)
     in
-    RETN (NoRepRational (num % den), xs2)
-    BEND BEND
-
-rdBasicLit ( tag : xs)
-  = BIND (rdString xs) _TO_ (x, zs) ->
-    let
-	s = _UNPK_ x
-
-	as_char	    = chr ((read s) :: Int)
-	    -- a char comes in as a number string
-	    -- representing its ASCII code
-	as_integer  = readInteger s
-#ifdef __GLASGOW_HASKELL__
-	as_rational = _readRational s -- non-std
-#else
-	as_rational = ((read s)::Rational)
-#endif
-	as_double   = ((read s) :: Double)
-    in
-    case tag of {
-     'H' -> RETN (mkMachInt 	as_integer, zs);
-     'J' -> RETN (MachDouble 	as_rational,zs);
-     'K' -> RETN (MachFloat 	as_rational,zs);
-     'P' -> RETN (MachChar 	as_char,    zs);
-     'V' -> RETN (MachStr 	x,	    zs);
-     'Y' -> BIND (rdString zs) _TO_ (k, zs2) ->
-	    RETN (MachLitLit 	x (guessPrimKind k), zs2)
-	    BEND;
-     'I' -> RETN (NoRepInteger	as_integer, zs);
-     's' -> RETN (NoRepStr	x,  	    zs)
-    } BEND
+    returnUgn (NoRepRational (num % den))
+
+wlkBasicLit other
+  = returnUgn (
+    case other of
+      U_intprim    s -> mkMachInt   (as_integer  s)
+      U_doubleprim s -> MachDouble  (as_rational s)
+      U_floatprim  s -> MachFloat   (as_rational s)
+      U_charprim   s -> MachChar    (as_char     s)
+      U_stringprim s -> MachStr	    (as_string   s)
+
+      U_clitlit    s k -> MachLitLit (as_string  s) (guessPrimRep (_UNPK_ k))
+
+      U_norepi	   s -> NoRepInteger (as_integer s)
+      U_noreps	   s -> NoRepStr     (as_string  s)
+    )
+  where
+    as_char s	  = _HEAD_ s
+    as_integer s  = readInteger (_UNPK_ s)
+    as_rational s = _readRational (_UNPK_ s) -- non-std
+    as_string s	  = s
 \end{code}
diff --git a/ghc/compiler/reader/ReadPragmas2.hi b/ghc/compiler/reader/ReadPragmas2.hi
deleted file mode 100644
index 45eeb4f97a..0000000000
--- a/ghc/compiler/reader/ReadPragmas2.hi
+++ /dev/null
@@ -1,16 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface ReadPragmas2 where
-import HsPragmas(ClassPragmas, DataPragmas, InstancePragmas, TypePragmas)
-import HsTypes(PolyType)
-import Maybes(Labda)
-import PrefixSyn(RdrTySigPragmas)
-import PreludePS(_PackedString)
-import ProtoName(ProtoName)
-import U_hpragma(U_hpragma)
-type ProtoUfBinder = (ProtoName, PolyType ProtoName)
-wlkClassPragma :: U_hpragma -> _PackedString -> _State _RealWorld -> (ClassPragmas ProtoName, _State _RealWorld)
-wlkDataPragma :: U_hpragma -> _PackedString -> _State _RealWorld -> (DataPragmas ProtoName, _State _RealWorld)
-wlkInstPragma :: U_hpragma -> _PackedString -> _State _RealWorld -> ((Labda _PackedString, InstancePragmas ProtoName), _State _RealWorld)
-wlkTySigPragmas :: U_hpragma -> _PackedString -> _State _RealWorld -> (RdrTySigPragmas, _State _RealWorld)
-wlkTypePragma :: U_hpragma -> _PackedString -> _State _RealWorld -> (TypePragmas, _State _RealWorld)
-
diff --git a/ghc/compiler/reader/ReadPragmas2.lhs b/ghc/compiler/reader/ReadPragmas2.lhs
deleted file mode 100644
index b34fefbff5..0000000000
--- a/ghc/compiler/reader/ReadPragmas2.lhs
+++ /dev/null
@@ -1,569 +0,0 @@
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1993-1995
-%
-\section[ReadPragmas2]{Read pragmatic interface info, including Core}
-
-\begin{code}
-#include "HsVersions.h"
-
-module ReadPragmas2 (
-	ProtoUfBinder(..),
-
-	wlkClassPragma,
-	wlkDataPragma,
-	wlkInstPragma,
-	wlkTySigPragmas,
-	wlkTypePragma
-    ) where
-
-IMPORT_Trace		-- ToDo: rm (debugging)
-import Pretty
-
-import UgenAll
-
-import AbsPrel		( nilDataCon, readUnfoldingPrimOp, PrimOp(..)
-			  IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
-			  IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
-			)
-import PrimKind		( guessPrimKind, PrimKind )
-import AbsSyn
-import BasicLit		( mkMachInt, BasicLit(..) )
-import HsCore		-- ****** NEED TO SEE CONSTRUCTORS ******
-import HsPragmas	-- ****** NEED TO SEE CONSTRUCTORS ******
-import Id		( mkTupleCon )
-import IdInfo		-- ( UnfoldingGuidance(..) )
-import Maybes		( Maybe(..) )
-import PrefixToHs
-import PrefixSyn
-import ProtoName
-import Outputable
-import ReadPrefix2	( wlkList, rdConDecl, wlkMonoType )
-import Util
-\end{code}
-
-\begin{code}
-wlkDataPragma :: U_hpragma -> UgnM ProtoNameDataPragmas
-
-wlkDataPragma pragma
-  = case pragma of
-      U_no_pragma    -> returnUgn (DataPragmas [] [])
-      U_idata_pragma cs ss ->
-	wlkList rdConDecl cs `thenUgn` \ cons  ->
-	wlkList rd_spec   ss `thenUgn` \ specs ->
-	returnUgn (DataPragmas cons specs)
-  where
-    rd_spec pt
-      = rdU_hpragma pt  `thenUgn` \ stuff ->
-	case stuff of { U_idata_pragma_4s ss ->
-
-	wlkList rdMonoTypeMaybe ss `thenUgn` \ specs ->
-	returnUgn specs }
-\end{code}
-
-\begin{code}
-wlkTypePragma :: U_hpragma -> UgnM TypePragmas
-
-wlkTypePragma pragma
-  = case pragma of
-      U_no_pragma    -> returnUgn NoTypePragmas
-      U_itype_pragma -> returnUgn AbstractTySynonym
-\end{code}
-
-\begin{code}
-wlkClassPragma :: U_hpragma -> UgnM ProtoNameClassPragmas
-
-wlkClassPragma pragma
-  = case pragma of
-      U_no_pragma    -> returnUgn NoClassPragmas
-      U_iclas_pragma gens ->
-	wlkList rdGenPragma gens `thenUgn` \ gen_pragmas ->
-	ASSERT(not (null gen_pragmas))
-	returnUgn (SuperDictPragmas gen_pragmas)
-\end{code}
-
-\begin{code}
-wlkInstPragma :: U_hpragma -> UgnM (Maybe FAST_STRING, ProtoNameInstancePragmas)
-
-wlkInstPragma pragma
-  = case pragma of
-      U_no_pragma    -> returnUgn (Nothing, NoInstancePragmas)
-
-      U_iinst_simpl_pragma modname dfun_gen ->
-	wlkGenPragma dfun_gen	`thenUgn` \ gen_pragmas ->
-	returnUgn (Just modname, SimpleInstancePragma gen_pragmas)
-
-      U_iinst_const_pragma modname dfun_gen constm_stuff ->
-	wlkGenPragma	  dfun_gen     `thenUgn` \ gen_pragma	 ->
-	wlkList rd_constm constm_stuff `thenUgn` \ constm_pragmas ->
-	returnUgn (Just modname, ConstantInstancePragma gen_pragma constm_pragmas)
-
-rd_constm pt
-  = rdU_hpragma pt  `thenUgn` \ stuff ->
-    case stuff of { U_iname_pragma_pr name gen ->
-
-    wlkGenPragma gen `thenUgn` \ prag ->
-    returnUgn (name, prag) }
-\end{code}
-
-\begin{code}
-rdGenPragma :: ParseTree -> UgnM ProtoNameGenPragmas
-
-rdGenPragma pt = rdU_hpragma pt `thenUgn` \ prag -> wlkGenPragma prag
-
-wlkGenPragma :: U_hpragma -> UgnM ProtoNameGenPragmas
-
-wlkGenPragma pragma
-  = case pragma of
-      U_no_pragma -> returnUgn NoGenPragmas
-
-      U_igen_pragma aritee update deforest strct uf speccs ->
-	wlk_arity	aritee	 `thenUgn` \ arity   ->
-	wlk_update	update	 `thenUgn` \ upd     ->
-	wlk_deforest	deforest `thenUgn` \ def     ->
-	wlk_strict	strct	 `thenUgn` \ strict  ->
-	wlk_unfold	uf	 `thenUgn` \ unfold  ->
-	wlkList rd_spec	speccs	 `thenUgn` \ specs   ->
-	returnUgn (GenPragmas arity upd def strict unfold specs)
-  where
-    wlk_arity stuff
-      = case stuff of
-	  U_no_pragma -> returnUgn Nothing
-	  U_iarity_pragma arity ->
-	    returnUgn (Just arity)
-
-    ------------
-    wlk_update stuff
-      = case stuff of
-	  U_no_pragma -> returnUgn Nothing
-	  U_iupdate_pragma upd_spec ->
-	    returnUgn (Just ((read (_UNPK_ upd_spec))::UpdateInfo))
-
-    ------------
-    wlk_deforest stuff
-      = case stuff of
-	  U_no_pragma -> returnUgn Don'tDeforest
-	  U_ideforest_pragma -> returnUgn DoDeforest
-
-    ------------
-    wlk_unfold stuff
-      = case stuff of
-	  U_no_pragma -> returnUgn NoImpUnfolding
-
-	  U_imagic_unfolding_pragma magic ->
-	    returnUgn (ImpMagicUnfolding magic)
-
-	  U_iunfolding_pragma guide core ->
-	    wlkGuidance guide	`thenUgn` \ guidance ->
-	    wlkCoreExpr core	`thenUgn` \ coresyn  ->
-	    returnUgn (ImpUnfolding guidance coresyn)
-
-    ------------
-    wlk_strict stuff
-      = case stuff of
-	  U_no_pragma -> returnUgn NoImpStrictness
-
-	  U_istrictness_pragma strict_spec wrkr_stuff ->
-	    wlkGenPragma wrkr_stuff  `thenUgn` \ wrkr_pragma ->
-	    let
-		strict_spec_str = _UNPK_ strict_spec
-		(is_bot, ww_strict_info)
-		  = if (strict_spec_str == "B")
-		    then (True,  [])
-		    else (False, (read strict_spec_str)::[Demand])
-	    in
-	    returnUgn (ImpStrictness is_bot ww_strict_info wrkr_pragma)
-
-    ------------
-    rd_spec pt
-      = rdU_hpragma pt	`thenUgn` \ stuff ->
-        case stuff of { U_itype_pragma_pr maybe_tys num_dicts prag ->
-
-        wlkList rdMonoTypeMaybe	maybe_tys `thenUgn` \ mono_tys_maybe ->
-	wlkGenPragma		prag	  `thenUgn` \ gen_prag	     ->
-	returnUgn (mono_tys_maybe, num_dicts, gen_prag) }
-\end{code}
-
-The only tricky case is pragmas on signatures; we have no way of
-knowing whether it is a @GenPragma@ or a @ClassOp@ pragma.  So we read
-whatever comes, store it in a @RdrTySigPragmas@ structure, and someone
-will sort it out later.
-\begin{code}
-wlkTySigPragmas :: U_hpragma -> UgnM RdrTySigPragmas
-
-wlkTySigPragmas pragma
-  = case pragma of
-      U_no_pragma -> returnUgn RdrNoPragma
-
-      U_iclasop_pragma dsel defm ->
-        wlkGenPragma dsel   `thenUgn` \ dsel_pragma ->
-	wlkGenPragma defm   `thenUgn` \ defm_pragma ->
-	returnUgn (RdrClassOpPragmas (ClassOpPragmas dsel_pragma defm_pragma))
-
-      other -> 
-	wlkGenPragma other  `thenUgn` \ gen_pragmas ->
-	returnUgn (RdrGenPragmas gen_pragmas)
-\end{code}
-
-\begin{code}
-wlkGuidance guide
-  = case guide of
-      U_iunfold_always -> returnUgn UnfoldAlways
-
-      U_iunfold_if_args num_ty_args num_val_args con_arg_spec size ->
-	let
-	    con_arg_info = take num_val_args (map cvt (_UNPK_ con_arg_spec))
-	    -- if there were 0 args, we want to throw away
-	    -- any dummy con_arg_spec stuff...
-	in
-	returnUgn (UnfoldIfGoodArgs num_ty_args num_val_args
-		    con_arg_info size)
-	where
-	  cvt 'C' = True  -- want a constructor in this arg position
-	  cvt _   = False
-\end{code}
-
-\begin{code}
-wlkCoreExpr :: U_coresyn -> UgnM ProtoNameUnfoldingCoreExpr
-
-wlkCoreExpr core_expr
-  = case core_expr of
-      U_covar v ->
-        wlkCoreId  v	`thenUgn` \ var ->
-	returnUgn (UfCoVar var)
-
-      U_coliteral l ->
-        wlkBasicLit l	`thenUgn` \ lit ->
-	returnUgn (UfCoLit lit)
-
-      U_cocon c ts as ->
-        wlkCoreId c		`thenUgn` \ (BoringUfId con) ->
-	wlkList rdCoreType ts	`thenUgn` \ tys ->
-	wlkList rdCoreAtom as	`thenUgn` \ vs  ->
-	returnUgn (UfCoCon con tys vs)
-
-      U_coprim o ts as ->
-        wlk_primop	   o	`thenUgn` \ op  ->
-	wlkList rdCoreType ts   `thenUgn` \ tys ->
-	wlkList rdCoreAtom as	`thenUgn` \ vs  ->
-	let
-	    fixed_vs = case op of { UfOtherOp pop -> fixup pop vs ; _ -> vs }
-	in
-	returnUgn (UfCoPrim op tys fixed_vs)
-       where
-
-	-- Question: why did ccall once panic if you looked at the
-	-- maygc flag?  Was this just laziness or is it not needed?
-	-- In that case, modify the stuff that writes them to pragmas
-	-- so that it never adds the _GC_ tag. ADR
-
-	wlk_primop op
-	  = case op of
-	      U_co_primop op_str ->
-		returnUgn (UfOtherOp (readUnfoldingPrimOp op_str))
-
-	      U_co_ccall fun_str may_gc a_tys r_ty ->
-		wlkList rdCoreType a_tys `thenUgn` \ arg_tys ->
-		wlkCoreType	   r_ty	 `thenUgn` \ res_ty  ->
-		returnUgn (UfCCallOp fun_str False (is_T_or_F may_gc) arg_tys res_ty)
-
-	      U_co_casm litlit may_gc a_tys r_ty ->
-	        wlkBasicLit	    litlit  `thenUgn` \ (MachLitLit casm_str _) ->
-		wlkList rdCoreType  a_tys   `thenUgn` \ arg_tys	    ->
-		wlkCoreType	    r_ty    `thenUgn` \ res_ty	    ->
-		returnUgn (UfCCallOp casm_str True (is_T_or_F may_gc) arg_tys res_ty)
-	  where
-	    is_T_or_F 0 = False
-	    is_T_or_F _ = True
-
-	-- Now *this* is a hack: we can't distinguish Int# literals
-	-- from Word# literals as they come in; this is only likely
-	-- to bite on the args of certain PrimOps (shifts, etc); so
-	-- we look for those and fix things up!!! (WDP 95/05)
-
-	fixup AndOp    [a1, a2] = [fixarg a1, fixarg a2]
-	fixup OrOp     [a1, a2] = [fixarg a1, fixarg a2]
-	fixup NotOp    [a1]     = [fixarg a1]
-	fixup SllOp    [a1, a2] = [fixarg a1, a2]
-	fixup SraOp    [a1, a2] = [fixarg a1, a2]
-	fixup SrlOp    [a1, a2] = [fixarg a1, a2]
-	fixup WordGtOp [a1, a2] = [fixarg a1, fixarg a2]
-	fixup WordGeOp [a1, a2] = [fixarg a1, fixarg a2]
-	fixup WordLtOp [a1, a2] = [fixarg a1, fixarg a2]
-	fixup WordLeOp [a1, a2] = [fixarg a1, fixarg a2]
-	fixup WordEqOp [a1, a2] = [fixarg a1, fixarg a2]
-	fixup WordNeOp [a1, a2] = [fixarg a1, fixarg a2]
-	fixup _	       as	= as
-
-	fixarg (UfCoLitAtom (MachInt i _)) = UfCoLitAtom (MachInt i False{-unsigned-})
-	fixarg arg			   = arg
-
-      U_colam vars expr ->
-        wlkList rdCoreBinder vars   `thenUgn` \ bs   ->
-	wlkCoreExpr	     expr   `thenUgn` \ body ->
-	returnUgn (UfCoLam bs body)
-
-      U_cotylam vars expr ->
-        wlkList rdU_unkId   vars    `thenUgn` \ tvs  ->
-	wlkCoreExpr	    expr    `thenUgn` \ body ->
-	returnUgn (foldr UfCoTyLam body tvs)
-
-      U_coapp f as ->
-        wlkCoreExpr	   f	`thenUgn` \ fun  ->
-	wlkList rdCoreAtom as	`thenUgn` \ args ->
-	returnUgn (foldl UfCoApp fun args)
-
-      U_cotyapp e t ->
-        wlkCoreExpr e	    `thenUgn` \ expr ->
-	wlkCoreType t	    `thenUgn` \ ty	 ->
-	returnUgn (UfCoTyApp expr ty)
-
-      U_cocase s as ->
-        wlkCoreExpr s	    `thenUgn` \ scrut ->
-	wlk_alts    as	    `thenUgn` \ alts  ->
-	returnUgn (UfCoCase scrut alts)
-       where
-	wlk_alts (U_coalg_alts as d)
-	  = wlkList rd_alg_alt as   `thenUgn` \ alts  ->
-	    wlk_deflt	       d    `thenUgn` \ deflt ->
-	    returnUgn (UfCoAlgAlts alts deflt)
-	  where
-	    rd_alg_alt pt
-	      = rdU_coresyn pt	`thenUgn` \ (U_coalg_alt c bs exp) ->
-
-		wlkCoreId	     c   `thenUgn` \ (BoringUfId con) ->
-		wlkList rdCoreBinder bs  `thenUgn` \ params	      ->
-		wlkCoreExpr	     exp `thenUgn` \ rhs	      ->
-		returnUgn (con, params, rhs)
-
-	wlk_alts (U_coprim_alts as d)
-	  = wlkList rd_prim_alt as  `thenUgn` \ alts  ->
-	    wlk_deflt	    	d   `thenUgn` \ deflt ->
-	    returnUgn (UfCoPrimAlts alts deflt)
-	  where
-	    rd_prim_alt pt
-	      = rdU_coresyn pt	`thenUgn` \ (U_coprim_alt l exp) ->
-
-		wlkBasicLit l   `thenUgn` \ lit ->
-		wlkCoreExpr exp `thenUgn` \ rhs ->
-		returnUgn (lit, rhs)
-
-	wlk_deflt U_conodeflt = returnUgn UfCoNoDefault
-	wlk_deflt (U_cobinddeflt v exp)
-	  = wlkCoreBinder v	`thenUgn` \ b   ->  
-	    wlkCoreExpr   exp	`thenUgn` \ rhs ->
-	    returnUgn (UfCoBindDefault b rhs)
-
-      U_colet b expr ->
-        wlk_bind    b    `thenUgn` \ bind ->
-	wlkCoreExpr expr `thenUgn` \ body ->
-	returnUgn (UfCoLet bind body)
-       where
-	wlk_bind (U_cononrec v expr)
-	  = wlkCoreBinder v	`thenUgn` \ b	->
-	    wlkCoreExpr   expr	`thenUgn` \ rhs ->
-	    returnUgn (UfCoNonRec b rhs)
-
-	wlk_bind (U_corec prs)
-	  = wlkList rd_pair prs `thenUgn` \ pairs ->
-	    returnUgn (UfCoRec pairs)
-	  where
-	    rd_pair pt
-	      = rdU_coresyn pt	`thenUgn` \ (U_corec_pair v expr) ->
-
-		wlkCoreBinder v    `thenUgn` \ b   ->
-		wlkCoreExpr   expr `thenUgn` \ rhs ->
-		returnUgn (b, rhs)
-
-      U_coscc c expr ->
-        wlk_cc	    c    `thenUgn` \ cc   ->
-	wlkCoreExpr expr `thenUgn` \ body ->
-	returnUgn (UfCoSCC cc body)
-      where
-	wlk_cc (U_co_preludedictscc dupd)
-	  = wlk_dupd dupd	`thenUgn` \ is_dupd ->
-	    returnUgn (UfPreludeDictsCC is_dupd)
-
-	wlk_cc (U_co_alldictscc m g dupd)
-	  = wlk_dupd dupd	`thenUgn` \ is_dupd ->
-	    returnUgn (UfAllDictsCC m g is_dupd)
-
-	wlk_cc (U_co_usercc n m g dupd cafd)
-	  = wlk_dupd dupd	`thenUgn` \ is_dupd ->
-	    wlk_cafd cafd	`thenUgn` \ is_cafd ->
-	    returnUgn (UfUserCC n m g is_dupd is_cafd)
-
-	wlk_cc (U_co_autocc id m g dupd cafd)
-	  = wlkCoreId id	`thenUgn` \ i	    ->
-	    wlk_dupd  dupd	`thenUgn` \ is_dupd ->
-	    wlk_cafd  cafd	`thenUgn` \ is_cafd ->
-	    returnUgn (UfAutoCC i m g is_dupd is_cafd)
-
-	wlk_cc (U_co_dictcc id m g dupd cafd)
-	  = wlkCoreId id	`thenUgn` \ i	    ->
-	    wlk_dupd  dupd	`thenUgn` \ is_dupd ->
-	    wlk_cafd  cafd	`thenUgn` \ is_cafd ->
-	    returnUgn (UfDictCC i m g is_dupd is_cafd)
-
-	------
-	wlk_cafd U_co_scc_noncaf  = returnUgn False
-	wlk_cafd U_co_scc_caf	  = returnUgn True
-
-	wlk_dupd U_co_scc_nondupd = returnUgn False
-	wlk_dupd U_co_scc_dupd	  = returnUgn True
-\end{code}
-
-\begin{code}
-type ProtoUfBinder = (ProtoName, PolyType ProtoName)
-
-rdCoreBinder :: ParseTree -> UgnM ProtoUfBinder
-
-rdCoreBinder pt = rdU_coresyn pt `thenUgn` \ x -> wlkCoreBinder x
-
-wlkCoreBinder :: U_coresyn -> UgnM ProtoUfBinder
-
-wlkCoreBinder (U_cobinder b t)
-  = wlkCoreType	t   `thenUgn` \ ty ->
-    returnUgn (b, ty)
-
-rdCoreAtom pt
-  = rdU_coresyn pt `thenUgn` \ atom ->
-    case atom of
-      U_colit l ->
-        wlkBasicLit l	`thenUgn` \ lit ->
-	returnUgn (UfCoLitAtom lit)
-
-      U_colocal var ->
-        wlkCoreId var	`thenUgn` \ v ->
-	returnUgn (UfCoVarAtom v)
-\end{code}
-
-\begin{code}
-rdCoreType :: ParseTree -> UgnM ProtoNamePolyType
-
-rdCoreType pt = rdU_ttype pt `thenUgn` \ ttype -> wlkCoreType ttype
-
-wlkCoreType :: U_ttype -> UgnM ProtoNamePolyType
-
-wlkCoreType (U_uniforall ts t)
-  = wlkList rdU_unkId ts    `thenUgn` \ tvs ->
-    wlkMonoType       t	    `thenUgn` \ ty  ->
-    returnUgn (ForAllTy tvs ty)
-
-wlkCoreType other
-  = wlkMonoType other 	`thenUgn` \ ty ->
-    returnUgn (UnoverloadedTy ty)
-\end{code}
-
-\begin{code}
-{- OLD???
-wlkCoreTypeMaybe :: ParseTree -> RETN_TYPE(Maybe ProtoNamePolyType, FAST_STRING)
-
-wlkCoreTypeMaybe ('2' : 'D' : xs) = RETN(Nothing, xs)
-wlkCoreTypeMaybe ('2' : 'E' : xs)
-  = wlkCoreType xs)    `thenUgn` \ (ty, xs1) ->
-    RETN(Just ty, xs1)
-    BEND
--}
-
-rdMonoTypeMaybe pt
-  = rdU_ttype pt `thenUgn` \ ty ->
-    case ty of
-      U_ty_maybe_nothing -> returnUgn Nothing
-
-      U_ty_maybe_just t ->
-        wlkMonoType t	`thenUgn` \ mono_ty ->
-	returnUgn (Just mono_ty)
-\end{code}
-
-\begin{code}
-wlkCoreId :: U_coresyn -> UgnM (UfId ProtoName)
-
-wlkCoreId (U_co_id v)
-  = returnUgn (BoringUfId (cvt_IdString v))
-
-wlkCoreId (U_co_orig_id mod nm)
-  = returnUgn (BoringUfId (Imp mod nm [mod]{-dubious, but doesn't matter-} nm))
-
-wlkCoreId (U_co_sdselid clas super_clas)
-  = returnUgn (SuperDictSelUfId clas super_clas)
-
-wlkCoreId (U_co_classopid clas method)
-  = returnUgn (ClassOpUfId clas method)
-
-wlkCoreId (U_co_defmid clas method)
-  = returnUgn (DefaultMethodUfId clas method)
-
-wlkCoreId (U_co_dfunid clas t)
-  = wlkCoreType t   `thenUgn` \ ty ->
-    returnUgn (DictFunUfId clas ty)
-
-wlkCoreId (U_co_constmid clas op t)
-  = wlkCoreType t   `thenUgn` \ ty ->
-    returnUgn (ConstMethodUfId clas op ty)
-
-wlkCoreId (U_co_specid id tys)
-  = wlkCoreId		    id	`thenUgn` \ unspec    ->
-    wlkList rdMonoTypeMaybe tys	`thenUgn` \ ty_maybes ->
-    returnUgn (SpecUfId unspec ty_maybes)
-
-wlkCoreId (U_co_wrkrid un)
-  = wlkCoreId un	`thenUgn` \ unwrkr ->
-    returnUgn (WorkerUfId unwrkr)
-
-------------
-cvt_IdString :: FAST_STRING -> ProtoName
-
-cvt_IdString s
-  = if (_HEAD_ s /= '_') then
---	trace (show s++(show (_HEAD_ s /= '_'))++(_HEAD_ s):'_':"/*0*/\n") (
-	boring
---	)
-    else if (sub_s == SLIT("NIL_")) then
---	trace (show s++"/*1*/"++show sub_s++"/"++show (_SUBSTR_ s 5 99999)++"\n") (
-    	Prel (WiredInVal nilDataCon)
---	)
-    else if (sub_s == SLIT("TUP_")) then
---	trace (show s++"/*2*/"++show sub_s++"/"++show (_SUBSTR_ s 5 99999)++"\n") (
-	Prel (WiredInVal (mkTupleCon arity))
---	)
-    else
---	trace (show s++"/*3*/"++show sub_s++"/"++show (_SUBSTR_ s 5 99999)++"\n") (
-	boring
---	)
-  where
-    boring = Unk s
-    sub_s  = _SUBSTR_ s 1 4	-- chars 1--4 (0-origin)
-    arity  = read (_UNPK_ (_SUBSTR_ s 5 999999))
-				-- chars 5 onwards give the arity
-\end{code}
-
-\begin{code}
-wlkBasicLit :: U_literal -> UgnM BasicLit
-
-wlkBasicLit (U_norepr n d)
-  = let
-	num = ((read (_UNPK_ n)) :: Integer)
-	den = ((read (_UNPK_ d)) :: Integer)
-    in
-    returnUgn (NoRepRational (num % den))
-
-wlkBasicLit other
-  = returnUgn (
-    case other of
-      U_intprim    s -> mkMachInt   (as_integer  s)
-      U_doubleprim s -> MachDouble  (as_rational s)
-      U_floatprim  s -> MachFloat   (as_rational s)
-      U_charprim   s -> MachChar    (as_char     s)
-      U_stringprim s -> MachStr	    (as_string   s)
-
-      U_clitlit    s k -> MachLitLit (as_string  s) (guessPrimKind (_UNPK_ k))
-
-      U_norepi	   s -> NoRepInteger (as_integer s)
-      U_noreps	   s -> NoRepStr     (as_string  s)
-    )
-  where
-    as_char s	  = _HEAD_ s
-    as_integer s  = readInteger (_UNPK_ s)
-    as_rational s = _readRational (_UNPK_ s) -- non-std
-    as_string s	  = s
-\end{code}
diff --git a/ghc/compiler/reader/ReadPrefix.hi b/ghc/compiler/reader/ReadPrefix.hi
deleted file mode 100644
index 7c18e695a3..0000000000
--- a/ghc/compiler/reader/ReadPrefix.hi
+++ /dev/null
@@ -1,23 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 3 #-}
-interface ReadPrefix where
-import AbsSyn(Module)
-import HsDecls(ConDecl)
-import HsPat(InPat)
-import HsTypes(MonoType)
-import LiftMonad(LiftM)
-import ProtoName(ProtoName)
-rdConDecl :: [Char] -> [Char] -> LiftM (ConDecl ProtoName, [Char])
-	{-# GHC_PRAGMA _A_ 2 _U_ 21 _S_ "LS" _N_ _N_ #-}
-rdId :: [Char] -> LiftM (ProtoName, [Char])
-	{-# GHC_PRAGMA _A_ 1 _U_ 1 _S_ "S" _N_ _N_ #-}
-rdIdString :: [Char] -> LiftM ([Char], [Char])
-	{-# GHC_PRAGMA _A_ 1 _U_ 2 _S_ "S" _N_ _N_ #-}
-rdList :: ([Char] -> LiftM (a, [Char])) -> [Char] -> LiftM ([a], [Char])
-	{-# GHC_PRAGMA _A_ 2 _U_ 22 _S_ "LS" _N_ _N_ #-}
-rdModule :: [Char] -> ([Char], [Char] -> Bool, Module ProtoName (InPat ProtoName))
-	{-# GHC_PRAGMA _A_ 1 _U_ 1 _S_ "S" _N_ _N_ #-}
-rdMonoType :: [Char] -> LiftM (MonoType ProtoName, [Char])
-	{-# GHC_PRAGMA _A_ 1 _U_ 2 _S_ "S" _N_ _N_ #-}
-rdString :: [Char] -> LiftM ([Char], [Char])
-	{-# GHC_PRAGMA _A_ 1 _U_ 2 _S_ "S" _N_ _N_ #-}
-
diff --git a/ghc/compiler/reader/ReadPrefix.lhs b/ghc/compiler/reader/ReadPrefix.lhs
index 5458884e66..6043f72c10 100644
--- a/ghc/compiler/reader/ReadPrefix.lhs
+++ b/ghc/compiler/reader/ReadPrefix.lhs
@@ -1,56 +1,37 @@
 %
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The AQUA Project, Glasgow University, 1994-1996
 %
-\section[ReadPrefix]{Read prefix-form input}
-
-This module contains a function, @rdModule@, which reads a Haskell
-module in `prefix form' emitted by the Lex/Yacc parser.
-
-The prefix form string is converted into an algebraic data type
-defined in @PrefixSyn@.
-
-Identifier names are converted into the @ProtoName@ data type.
-
-@sf@ is used consistently to mean ``source file'' (name).
+\section{Read parse tree built by Yacc parser}
 
 \begin{code}
--- HBC does not have stack stubbing; you get a space leak w/
--- default defns from HsVersions.h.
-
--- GHC may be overly slow to compile w/ the defaults...
-
-#define BIND {--}
-#define _TO_ `thenLft` ( \ {--}
-#define BEND )
-#define RETN returnLft
-#define RETN_TYPE LiftM
-
 #include "HsVersions.h"
-\end{code}
 
-\begin{code}
 module ReadPrefix (
 	rdModule,
 
-	rdList, rdId, rdIdString, rdString, rdConDecl, rdMonoType
-    ) where
+	-- used over in ReadPragmas...
+	wlkList, wlkMaybe, rdConDecl, wlkMonoType, rdMonoType
+    )  where
 
-IMPORT_Trace		-- ToDo: rm (debugging)
-import Pretty
+import Ubiq{-uitous-}
+import RdrLoop 		-- for paranoia checking
+
+import UgenAll		-- all Yacc parser gumpff...
+import PrefixSyn	-- and various syntaxen.
+import HsSyn
+import RdrHsSyn
 
-import AbsSyn
-import HsCore		-- ****** NEED TO SEE CONSTRUCTORS ******
-import HsPragmas	-- ****** NEED TO SEE CONSTRUCTORS ******
-import IdInfo		( UnfoldingGuidance(..) )
-import LiftMonad
-import Maybes		( Maybe(..) )
-import PrefixToHs
-import PrefixSyn
-import ProtoName
-import Outputable
+-- friends:
 import ReadPragmas
-import SrcLoc		( mkSrcLoc )
-import Util
+import PrefixToHs	-- reader utilities
+
+-- others:
+import FiniteMap	( elemFM, FiniteMap )
+import MainMonad	( thenMn, MainIO(..) )
+import PprStyle		( PprStyle(..) )
+import Pretty
+import ProtoName	( isConopPN, ProtoName(..) )
+import Util		( nOfThem, panic )
 \end{code}
 
 %************************************************************************
@@ -60,52 +41,36 @@ import Util
 %************************************************************************
 
 \begin{code}
-rdList :: (String -> RETN_TYPE (a, String)) -> String -> RETN_TYPE ([a], String)
-
-rdList rd_it ('N':xs) = RETN ([], xs)
-rdList rd_it ('L':xs)
-  = BIND (rd_it xs)		_TO_ (hd_it, xs1) ->
-    BIND (rdList rd_it xs1)	_TO_ (tl_it, xs2) ->
-    RETN (hd_it : tl_it, xs2)
-    BEND BEND
-rdList rd_it junk = panic ("ReadPrefix.rdList:"++junk)
-
-rdString, rdIdString :: String -> RETN_TYPE (FAST_STRING, String)
-rdId :: String -> RETN_TYPE (ProtoName, String)
-
-rdString ('#':xs) = BIND (split_at_tab xs) _TO_ (str, rest) ->
-		    RETN (_PK_ (de_escape str), rest)
-		    BEND
-  where
-    -- partain: tabs and backslashes are escaped
-    de_escape []		= []
-    de_escape ('\\':'\\':xs)	= '\\' : (de_escape xs)
-    de_escape ('\\':'t':xs)	= '\t' : (de_escape xs)
-    de_escape (x:xs)		= x    : (de_escape xs)
-
-rdString xs = panic ("ReadPrefix.rdString:"++xs)
-
-rdIdString ('#':xs) = BIND (split_at_tab xs) _TO_ (stuff,rest) -> -- no de-escaping...
-		      RETN (_PK_ stuff, rest)
-		      BEND
-rdIdString other    = panic ("rdIdString:"++other)
-
- -- no need to de-escape it...
-rdId ('#':xs) = BIND (split_at_tab xs) _TO_ (str, rest) ->
-		RETN (Unk (_PK_ str), rest)
-		BEND
-
-split_at_tab :: String -> RETN_TYPE (String, String) -- a la Lennart
-split_at_tab xs
-  = split_me [] xs
-  where
-    split_me acc ('\t' : ys) = BIND (my_rev acc []) _TO_ reversed ->
-			       RETN (reversed, ys)
-			       BEND
-    split_me acc (y    : ys) = split_me (y:acc) ys
+wlkList :: (U_VOID_STAR -> UgnM a) -> U_list -> UgnM [a]
 
-    my_rev ""	  acc = RETN acc -- instead of reverse, so can see on heap-profiles
-    my_rev (x:xs) acc = my_rev xs (x:acc)
+wlkList wlk_it U_lnil = returnUgn []
+
+wlkList wlk_it (U_lcons hd tl)
+  = wlk_it  hd		`thenUgn` \ hd_it ->
+    wlkList wlk_it tl	`thenUgn` \ tl_it ->
+    returnUgn (hd_it : tl_it)
+\end{code}
+
+\begin{code}
+wlkMaybe :: (U_VOID_STAR -> UgnM a) -> U_maybe -> UgnM (Maybe a)
+
+wlkMaybe wlk_it U_nothing  = returnUgn Nothing
+wlkMaybe wlk_it (U_just x)
+  = wlk_it  x		`thenUgn` \ it ->
+    returnUgn (Just it)
+\end{code}
+
+\begin{code}
+rdQid   :: ParseTree -> UgnM ProtoName
+rdQid pt = rdU_qid pt `thenUgn` \ qid -> wlkQid qid
+
+wlkQid	:: U_qid -> UgnM ProtoName
+wlkQid (U_noqual name)
+  = returnUgn (Unk name)
+wlkQid (U_aqual  mod name)
+  = returnUgn (Qunk mod name)
+wlkQid (U_gid n name)
+  = returnUgn (Unk name)
 \end{code}
 
 %************************************************************************
@@ -115,735 +80,673 @@ split_at_tab xs
 %************************************************************************
 
 \begin{code}
-rdModule :: String
-	 -> (FAST_STRING,		-- this module's name
-	     (FAST_STRING -> Bool,	-- a function to chk if <x> is in the export list
-	      FAST_STRING -> Bool),	-- a function to chk if <M> is among the M..
-				-- ("dotdot") modules in the export list.
-	     ProtoNameModule)	-- the main goods
-
-rdModule (next_char:xs)
-  = case next_char of { 'M' ->
-
-    BIND (rdString		     	       xs)  _TO_ (srcline,  xs1) ->
-    BIND (rdIdString		     	       xs1) _TO_ (name,	  xs2) ->
-    BIND (rdString		     	       xs2) _TO_ (srcfile,  xs3) ->
-    BIND (rdBinding srcfile	     	       xs3) _TO_ (binding,  xs4) ->
-    BIND (rdList rdFixity	     	       xs4) _TO_ (fixities, xs5) ->
-    BIND (rdList (rdImportedInterface srcfile) xs5) _TO_ (imports,  xs6) ->
-    BIND (rdList rdEntity	     	       xs6) _TO_ (export_list, _) ->
+rdModule :: MainIO
+	   (FAST_STRING,	   -- this module's name
+	    (FAST_STRING -> Bool,  -- a function to chk if <x> is in the export list
+	     FAST_STRING -> Bool), -- a function to chk if <M> is among the M..
+				   -- ("dotdot") modules in the export list.
+	    ProtoNameHsModule)	   -- the main goods
+
+rdModule
+  = _ccall_ hspmain `thenPrimIO` \ pt -> -- call the Yacc parser!
+    let
+	srcfile  = _packCString ``input_filename'' -- What A Great Hack! (TM)
+    in
+    initUgn srcfile (
+
+    rdU_tree pt `thenUgn` \ (U_hmodule name himplist hexplist hfixlist hmodlist srcline) ->
+    wlkList  rdFixOp		 hfixlist `thenUgn` \ fixities 	->
+    wlkBinding			 hmodlist `thenUgn` \ binding	->
+    wlkList  rdImportedInterface himplist `thenUgn` \ imports	->
+    wlkMaybe rdEntities		 hexplist `thenUgn` \ exp_list	->
+    mkSrcLocUgn srcline			  `thenUgn` \ src_loc	->
 
     case sepDeclsForTopBinds binding	  of {
       (tydecls, tysigs, classdecls, instdecls, instsigs, defaultdecls, binds) ->
 
-    (name,
-     mk_export_list_chker export_list,
-     Module name
-	    export_list
-	    imports
-	    fixities
-	    tydecls
-	    tysigs
-	    classdecls
-	    (cvInstDecls True name name instdecls) -- True indicates not imported
-	    instsigs
-	    defaultdecls
-	    (cvSepdBinds srcfile cvValSig binds)
-	    [{-no sigs-}]
-	    (mkSrcLoc srcfile srcline)
-    )
-    } BEND BEND BEND BEND BEND BEND BEND
-    }
+    returnUgn (
+     name,
+     mk_export_list_chker exp_list,
+     HsModule name
+	      exp_list
+	      imports
+	      fixities
+	      tydecls
+	      tysigs
+	      classdecls
+	      instdecls
+	      instsigs
+	      defaultdecls
+	      (cvSepdBinds srcfile cvValSig binds)
+	      [{-no sigs-}]
+	      src_loc
+    ) } )
   where
+    mk_export_list_chker = panic "ReadPrefix:mk_export_list_chker"
+{- LATER:
     mk_export_list_chker exp_list
-      = case (getIEStrings exp_list) of { (entity_info, dotdot_modules) ->
-	( \ n -> n `elemFM` just_the_strings,
-	  \ n -> n `elemFM` dotdot_modules )
-    	}
+      = case (getExportees exp_list) of
+	  Nothing -> ( \ n -> False, \ n -> False ) -- all suspicious
+	  Just (entity_info, dotdot_modules) ->
+	    ( \ n -> n `elemFM` entity_info,
+	      \ n -> n `elemFM` dotdot_modules )
+-}
 \end{code}
 
 %************************************************************************
 %*									*
-\subsection[rdExprOrPat]{@rdExpr@ and @rdPat@}
+\subsection[wlkExprOrPat]{@wlkExpr@ and @wlkPat@}
 %*									*
 %************************************************************************
 
 \begin{code}
-rdExpr	 :: SrcFile -> String -> RETN_TYPE (ProtoNameExpr, String)
-rdPat	 :: SrcFile -> String -> RETN_TYPE (ProtoNamePat,  String)
-
-rdExpr sf (next_char:xs)
-  = case next_char of
-     '(' -> -- left section
-	    BIND (rdExpr sf xs)	   _TO_ (expr,xs1) ->
-	    BIND (rdId	    xs1)   _TO_ (id,  xs2) ->
-	    RETN (SectionL expr (Var id), xs2)
-	    BEND BEND
-
-     ')' -> -- right section
-	    BIND (rdId	    xs)	   _TO_ (id,  xs1) ->
-	    BIND (rdExpr sf xs1)   _TO_ (expr,xs2) ->
-	    RETN (SectionR (Var id) expr, xs2)
-	    BEND BEND
-
-     'j' -> -- ccall/casm
-	    BIND (rdString	     xs)  _TO_ (fun,	 xs1) ->
-	    BIND (rdString	     xs1) _TO_ (flavor,	 xs2) ->
-	    BIND (rdList (rdExpr sf) xs2) _TO_ (args,	 xs3) ->
-	    RETN (CCall fun args
-			(flavor == SLIT("p") || flavor == SLIT("P")) -- may invoke GC
-			(flavor == SLIT("N") || flavor == SLIT("P")) -- really a "casm"
-			(panic "CCall:result_ty"),
-		  xs3)
-	    BEND BEND BEND
-
-     'k' -> -- scc (set-cost-centre) expression
-	    BIND (rdString	xs)	_TO_ (label, xs1) ->
-	    BIND (rdExpr sf	xs1)	_TO_ (expr,  xs2) ->
-	    RETN (SCC label expr, xs2)
-	    BEND BEND
-
-     'l' -> -- lambda expression
-	    BIND (rdString	    xs)	  _TO_ (srcline, xs1) ->
-	    BIND (rdList (rdPat sf) xs1)  _TO_ (pats,	 xs2) ->
-	    BIND (rdExpr sf	    xs2)  _TO_ (body,	 xs3) ->
-	    let
-		src_loc = mkSrcLoc sf srcline
-	    in
-	    RETN (Lam (foldr PatMatch
-			     (GRHSMatch (GRHSsAndBindsIn
-					  [OtherwiseGRHS body src_loc]
-					  EmptyBinds))
-			     pats
-		      ),
-		 xs3)
-	    BEND BEND BEND
-
-     'c' -> -- case expression
-	    BIND (rdExpr sf	      xs)  _TO_ (expr, xs1) ->
-	    BIND (rdList (rdMatch sf) xs1) _TO_ (mats, xs2) ->
-	    let
-		matches = cvMatches sf True mats
-	    in
-	    RETN (Case expr matches, xs2)
-	    BEND BEND
-
-     'b' -> -- if expression
-	    BIND (rdExpr sf xs)	   _TO_ (e1, xs1) ->
-	    BIND (rdExpr sf xs1)   _TO_ (e2, xs2) ->
-	    BIND (rdExpr sf xs2)   _TO_ (e3, xs3) ->
-	    RETN (If e1 e2 e3, xs3)
-	    BEND BEND BEND
-
-     'E' -> -- let expression
-	    BIND (rdBinding sf xs)  _TO_ (binding,xs1) ->
-	    BIND (rdExpr sf    xs1) _TO_ (expr,	  xs2) ->
-	    let
-		binds = cvBinds sf cvValSig binding
-	    in
-	    RETN (Let binds expr, xs2)
-	    BEND BEND
-
-     'Z' -> -- list comprehension
-	    BIND (rdExpr sf	 xs)	_TO_ (expr,  xs1) ->
-	    BIND (rdList rd_qual xs1)	_TO_ (quals, xs2) ->
-	    RETN (ListComp expr quals, xs2)
-	    BEND BEND
-	    where
-	       rd_qual ('G':xs)
-		 = BIND (rdPat	sf xs)	_TO_ (pat, xs1) ->
-		   BIND (rdExpr sf xs1) _TO_ (expr,xs2) ->
-		   RETN (GeneratorQual pat expr, xs2)
-		   BEND BEND
-
-	       rd_qual ('g':xs)
-		 = BIND (rdExpr sf xs)	_TO_ (expr,xs1) ->
-		   RETN (FilterQual expr, xs1)
-		   BEND
-
-     '.' -> -- arithmetic sequence
-	    BIND (rdExpr sf		xs)	_TO_ (e1,  xs1) ->
-	    BIND (rdList (rdExpr sf)	xs1)	_TO_ (es2, xs2) ->
-	    BIND (rdList (rdExpr sf)	xs2)	_TO_ (es3, xs3) ->
-	    RETN (cv_arith_seq e1 es2 es3, xs3)
-	    BEND BEND BEND
-	    where
-	       cv_arith_seq e1 []   []	 = ArithSeqIn (From	  e1)
-	       cv_arith_seq e1 []   [e3] = ArithSeqIn (FromTo	  e1 e3)
-	       cv_arith_seq e1 [e2] []	 = ArithSeqIn (FromThen	  e1 e2)
-	       cv_arith_seq e1 [e2] [e3] = ArithSeqIn (FromThenTo e1 e2 e3)
-
-     'R' -> -- expression with type signature
-	    BIND (rdExpr   sf xs)    _TO_ (expr,xs1) ->
-	    BIND (rdPolyType  xs1)   _TO_ (ty,	xs2) ->
-	    RETN (ExprWithTySig expr ty, xs2)
-	    BEND BEND
-
-     '-' -> -- negated expression
-	    BIND (rdExpr sf  xs)   _TO_ (expr,xs1) ->
-	    RETN (App (Var (Unk SLIT("negate"))) expr, xs1)
-	    BEND
-#ifdef DPH
-     '5' -> -- parallel ZF expression
-	    BIND (rdExpr sf xs)		_TO_ (expr,	 xs1) ->
-	    BIND (rdList (rd_par_qual sf) xs1) _TO_ (qual_list, xs2) ->
-	    let
-		quals = foldr1 AndParQuals qual_list
-	    in
-	    RETN (RdrParallelZF expr quals, xs2)
-	    BEND BEND
-	    where
-	      rdParQual sf inp
-		= case inp of
-		-- ToDo:DPH: I have kawunkled your RdrExplicitProcessor hack
-		    '0':xs -> BIND (rdExPat sf xs)  _TO_ (RdrExplicitProcessor pats pat, xs1) ->
-			      BIND (rdExpr  sf xs1) _TO_ (expr, xs2) ->
-			      RETN (DrawnGenIn pats pat expr, xs2)
-			      BEND BEND
-
-		    'w':xs -> BIND (rdExPat sf xs)  _TO_ (RdrExplicitProcessor exprs pat, xs1) ->
-			      BIND (rdExpr  sf xs1) _TO_ (expr, xs2) ->
-			      RETN (IndexGen exprs pat expr, xs2)
-			      BEND BEND
-
-		    'I':xs -> BIND (rdExpr sf xs)	_TO_ (expr,xs1) ->
-			      RETN (ParFilter expr, xs1)
-			      BEND
-
-     '6' -> -- explicitPod expression
-	    BIND (rdList (rdExpr sf) xs)  _TO_ (exprs,xs1) ->
-	    RETN (RdrExplicitPod exprs,xs1)
-	    BEND
-#endif {- Data Parallel Haskell -}
-
-    --------------------------------------------------------------
-    -- now the prefix items that can either be an expression or
-    -- pattern, except we know they are *expressions* here
-    -- (this code could be commoned up with the pattern version;
-    -- but it probably isn't worth it)
-    --------------------------------------------------------------
-     'C' -> BIND (rdLiteral xs)	_TO_ (lit, xs1) ->
-	    RETN (Lit lit, xs1)
-	    BEND
-
-     'i' -> -- simple identifier
-	    BIND (rdId xs) _TO_ (str,xs1) ->
-	    RETN (Var str, xs1)
-	    BEND
-
-     'a' -> -- application
-	    BIND (rdExpr sf xs)	 _TO_ (expr1, xs1) ->
-	    BIND (rdExpr sf xs1) _TO_ (expr2, xs2) ->
-	    RETN (App expr1 expr2, xs2)
-	    BEND BEND
-
-     '@' -> -- operator application
-	    BIND (rdExpr sf xs)	  _TO_ (expr1, xs1) ->
-	    BIND (rdId	    xs1)  _TO_ (op,    xs2) ->
-	    BIND (rdExpr sf xs2)  _TO_ (expr2, xs3) ->
-	    RETN (OpApp expr1 (Var op) expr2, xs3)
-	    BEND BEND BEND
-
-     ':' -> -- explicit list
-	    BIND (rdList (rdExpr sf) xs) _TO_ (exprs, xs1) ->
-	    RETN (ExplicitList exprs, xs1)
-	    BEND
-
-     ',' -> -- explicit tuple
-	    BIND (rdList (rdExpr sf) xs) _TO_ (exprs, xs1) ->
-	    RETN (ExplicitTuple exprs, xs1)
-	    BEND
-
-#ifdef DPH
-     'O' -> -- explicitProcessor expression
-	    BIND (rdList (rdExpr sf) xs)  _TO_ (exprs,xs1) ->
-	    BIND (rdExpr sf xs1)	    _TO_ (expr, xs2) ->
-	    RETN (ExplicitProcessor exprs expr, xs2)
-	    BEND BEND
-#endif {- Data Parallel Haskell -}
-
-     huh -> panic ("ReadPrefix.rdExpr:"++(next_char:xs))
+rdExpr :: ParseTree -> UgnM ProtoNameHsExpr
+rdPat  :: ParseTree -> UgnM ProtoNamePat
+
+rdExpr pt = rdU_tree pt `thenUgn` \ tree -> wlkExpr tree
+rdPat  pt = rdU_tree pt `thenUgn` \ tree -> wlkPat  tree
+
+wlkExpr :: U_tree -> UgnM ProtoNameHsExpr
+wlkPat  :: U_tree -> UgnM ProtoNamePat
+
+wlkExpr expr
+  = case expr of
+      U_par expr -> -- parenthesised expr
+	wlkExpr expr
+
+      U_lsection lsexp lop -> -- left section
+	wlkExpr lsexp	`thenUgn` \ expr ->
+	wlkQid  lop	`thenUgn` \ op   ->
+	returnUgn (SectionL expr (HsVar op))
+
+      U_rsection rop rsexp -> -- right section
+	wlkQid  rop	`thenUgn` \ op   ->
+	wlkExpr rsexp	`thenUgn` \ expr ->
+	returnUgn (SectionR (HsVar op) expr)
+
+      U_ccall fun flavor ccargs -> -- ccall/casm
+	wlkList rdExpr ccargs   `thenUgn` \ args ->
+	let
+	    tag = _HEAD_ flavor
+	in
+	returnUgn (CCall fun args
+		    (tag == 'p' || tag == 'P') -- may invoke GC
+		    (tag == 'N' || tag == 'P') -- really a "casm"
+		    (panic "CCall:result_ty"))
+
+      U_scc label sccexp -> -- scc (set-cost-centre) expression
+	wlkExpr   sccexp	`thenUgn` \ expr  ->
+	returnUgn (HsSCC label expr)
+
+      U_lambda lampats lamexpr srcline -> -- lambda expression
+	wlkList rdPat lampats	`thenUgn` \ pats ->
+	wlkExpr       lamexpr	`thenUgn` \ body ->
+	mkSrcLocUgn   srcline	`thenUgn` \ src_loc ->
+	returnUgn (
+	    HsLam (foldr PatMatch
+			 (GRHSMatch (GRHSsAndBindsIn
+				      [OtherwiseGRHS body src_loc]
+				      EmptyBinds))
+			 pats)
+	)
+
+      U_casee caseexpr casebody srcline ->	-- case expression
+	wlkExpr	        caseexpr `thenUgn` \ expr ->
+	wlkList rdMatch casebody `thenUgn` \ mats ->
+	mkSrcLocUgn    srcline	 `thenUgn` \ src_loc ->
+	getSrcFileUgn		 `thenUgn` \ sf ->
+	let
+	    matches = cvMatches sf True mats
+	in
+	returnUgn (HsCase expr matches src_loc)
+
+      U_ife ifpred ifthen ifelse srcline ->	-- if expression
+	wlkExpr ifpred		`thenUgn` \ e1 ->
+	wlkExpr ifthen		`thenUgn` \ e2 ->
+	wlkExpr ifelse		`thenUgn` \ e3 ->
+	mkSrcLocUgn srcline	`thenUgn` \ src_loc ->
+	returnUgn (HsIf e1 e2 e3 src_loc)
+
+      U_let letvdefs letvexpr ->		-- let expression
+	wlkBinding letvdefs	`thenUgn` \ binding ->
+	wlkExpr    letvexpr	`thenUgn` \ expr    ->
+	getSrcFileUgn		`thenUgn` \ sf	    ->
+	let
+	    binds = cvBinds sf cvValSig binding
+	in
+	returnUgn (HsLet binds expr)
+
+      U_doe gdo srcline ->		-- do expression
+	wlkList rd_stmt gdo	`thenUgn` \ stmts ->
+	mkSrcLocUgn srcline	`thenUgn` \ src_loc ->
+	returnUgn (HsDo stmts src_loc)
+        where
+	rd_stmt pt
+	  = rdU_tree pt `thenUgn` \ bind ->
+	    case bind of
+	      U_doexp exp srcline ->
+		wlkExpr exp 		`thenUgn` \ expr ->
+		mkSrcLocUgn srcline	`thenUgn` \ src_loc ->
+		returnUgn (ExprStmt expr src_loc)
+
+	      U_dobind pat exp srcline ->
+		wlkPat  pat		`thenUgn` \ patt ->
+		wlkExpr exp 		`thenUgn` \ expr ->
+		mkSrcLocUgn srcline	`thenUgn` \ src_loc ->
+		returnUgn (BindStmt patt expr src_loc)
+
+	      U_seqlet seqlet ->
+		wlkBinding seqlet	`thenUgn` \ bs ->
+		getSrcFileUgn		`thenUgn` \ sf ->
+		let
+		    binds = cvBinds sf cvValSig bs
+		in
+		returnUgn (LetStmt binds)
+
+      U_comprh cexp cquals -> -- list comprehension
+	wlkExpr cexp		`thenUgn` \ expr  ->
+	wlkList rd_qual cquals	`thenUgn` \ quals ->
+	returnUgn (ListComp expr quals)
+	where
+	  rd_qual pt
+	    = rdU_tree pt	`thenUgn` \ qual ->
+	      wlk_qual qual
+
+	  wlk_qual qual
+	    = case qual of
+		U_guard exp ->
+		  wlkExpr exp  	`thenUgn` \ expr ->
+		  returnUgn (FilterQual expr)
+
+		U_qual qpat qexp ->
+		  wlkPat  qpat  `thenUgn` \ pat  ->
+		  wlkExpr qexp  `thenUgn` \ expr ->
+		  returnUgn (GeneratorQual pat expr)
+
+		U_seqlet seqlet ->
+		  wlkBinding seqlet	`thenUgn` \ bs ->
+		  getSrcFileUgn		`thenUgn` \ sf ->
+		  let
+		      binds = cvBinds sf cvValSig bs
+		  in
+		  returnUgn (LetQual binds)
+
+      U_eenum efrom estep eto -> -- arithmetic sequence
+	wlkExpr efrom		`thenUgn` \ e1  ->
+	wlkMaybe rdExpr estep	`thenUgn` \ es2 ->
+	wlkMaybe rdExpr eto	`thenUgn` \ es3 ->
+	returnUgn (cv_arith_seq e1 es2 es3)
+	where
+	   cv_arith_seq e1 Nothing   Nothing   = ArithSeqIn (From	e1)
+	   cv_arith_seq e1 Nothing   (Just e3) = ArithSeqIn (FromTo     e1 e3)
+	   cv_arith_seq e1 (Just e2) Nothing   = ArithSeqIn (FromThen   e1 e2)
+	   cv_arith_seq e1 (Just e2) (Just e3) = ArithSeqIn (FromThenTo e1 e2 e3)
+
+      U_restr restre restrt -> 	-- expression with type signature
+	wlkExpr	    restre	`thenUgn` \ expr ->
+	wlkPolyType restrt	`thenUgn` \ ty	 ->
+	returnUgn (ExprWithTySig expr ty)
+
+      --------------------------------------------------------------
+      -- now the prefix items that can either be an expression or
+      -- pattern, except we know they are *expressions* here
+      -- (this code could be commoned up with the pattern version;
+      -- but it probably isn't worth it)
+      --------------------------------------------------------------
+      U_lit lit ->
+	wlkLiteral lit	`thenUgn` \ lit ->
+	returnUgn (HsLit lit)
+
+      U_ident n -> 			-- simple identifier
+	wlkQid n	`thenUgn` \ var ->
+	returnUgn (HsVar var)
+
+      U_ap fun arg -> 			-- application
+	wlkExpr fun	`thenUgn` \ expr1 ->
+	wlkExpr arg	`thenUgn` \ expr2 ->
+	returnUgn (HsApp expr1 expr2)
+
+      U_infixap fun arg1 arg2 ->	-- infix application
+	wlkQid  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 ->
+	returnUgn (HsApp (HsVar (Unk SLIT("negate"))) expr)
+
+      U_llist llist -> -- explicit list
+	wlkList rdExpr llist `thenUgn` \ exprs ->
+	returnUgn (ExplicitList exprs)
+
+      U_tuple tuplelist -> -- explicit tuple
+	wlkList rdExpr tuplelist `thenUgn` \ exprs ->
+	returnUgn (ExplicitTuple exprs)
+
+      U_record con rbinds -> -- record construction
+	wlkQid  con		`thenUgn` \ rcon     ->
+	wlkList rdRbind rbinds	`thenUgn` \ recbinds ->
+	returnUgn (RecordCon rcon recbinds)
+
+      U_rupdate updexp updbinds -> -- record update
+	wlkExpr updexp		 `thenUgn` \ aexp ->
+	wlkList rdRbind updbinds `thenUgn` \ recbinds ->
+	returnUgn (RecordUpd aexp recbinds)
+
+#ifdef DEBUG
+      U_hmodule _ _ _ _ _ _ -> error "U_hmodule"
+      U_as _ _ 		    -> error "U_as"
+      U_lazyp _ 	    -> error "U_lazyp"
+      U_wildp 		    -> error "U_wildp"
+      U_qual _ _ 	    -> error "U_qual"
+      U_guard _ 	    -> error "U_guard"
+      U_seqlet _ 	    -> error "U_seqlet"
+      U_dobind _ _ _ 	    -> error "U_dobind"
+      U_doexp _ _	    -> error "U_doexp"
+      U_rbind _ _	    -> error "U_rbind"
+      U_fixop _ _ _	    -> error "U_fixop"
+#endif
+
+rdRbind pt
+  = rdU_tree pt		`thenUgn` \ (U_rbind var exp) ->
+    wlkQid   var	`thenUgn` \ rvar ->
+    wlkMaybe rdExpr exp	`thenUgn` \ expr_maybe ->
+    returnUgn (rvar, expr_maybe)
 \end{code}
 
 Patterns: just bear in mind that lists of patterns are represented as
 a series of ``applications''.
 \begin{code}
-rdPat sf (next_char:xs)
-  = case next_char of
-     's' -> -- "as" pattern
-	    BIND (rdId	   xs)	_TO_ (id, xs1) ->
-	    BIND (rdPat sf xs1) _TO_ (pat,xs2) ->
-	    RETN (AsPatIn id pat, xs2)
-	    BEND BEND
-
-     '~' -> -- irrefutable ("twiddle") pattern
-	    BIND (rdPat sf xs)	_TO_ (pat,xs1) ->
-	    RETN (LazyPatIn pat, xs1)
-	    BEND
-
-     '+' -> -- n+k pattern
-	    BIND (rdPat	    sf xs)  _TO_ (pat, xs1) ->
-	    BIND (rdLiteral    xs1) _TO_ (lit, xs2) ->
-	    let
-		n = case pat of
-		      VarPatIn n -> n
-		      WildPatIn	 -> error "ERROR: rdPat: GHC can't handle _+k patterns yet"
-	    in
-	    RETN (NPlusKPatIn n lit, xs2)
-	    BEND BEND
-
-     '_' -> -- wildcard pattern
-	    RETN (WildPatIn, xs)
-
-    --------------------------------------------------------------
-    -- now the prefix items that can either be an expression or
-    -- pattern, except we know they are *patterns* here.
-    --------------------------------------------------------------
-     '-' -> BIND (rdPat sf xs)	_TO_ (lit_pat, xs1) ->
-	    case lit_pat of
-	      LitPatIn lit -> RETN (LitPatIn (negLiteral lit), xs1)
-	      _	    	   -> panic "rdPat: bad negated pattern!"
-	    BEND
-
-     'C' -> BIND (rdLiteral xs) _TO_ (lit, xs1) ->
-	    RETN (LitPatIn lit, xs1)
-	    BEND
-
-     'i' -> -- simple identifier
-	    BIND (rdIdString xs) _TO_ (str, xs1) ->
-	    RETN (if isConop str then
-		     ConPatIn (Unk str) []
-		  else
-		     VarPatIn (Unk str),
-		  xs1)
-	    BEND
-
-     'a' -> -- "application": there's a list of patterns lurking here!
-	    BIND (rd_curried_pats    xs)  _TO_ (lpat:lpats, xs1) ->
-	    BIND (rdPat		  sf xs1) _TO_ (rpat,	    xs2) ->
-	    let
-		(n, llpats)
-		  = case lpat of
-		      VarPatIn x    -> (x, [])
-		      ConPatIn x [] -> (x, [])
-		      ConOpPatIn x op y -> (op, [x, y])
-		      other -> -- sorry about the weedy msg; the parser missed this one
-		        error (ppShow 100 (ppCat [ppStr "ERROR: an illegal `application' of a pattern to another one:", ppInterleave ppSP (map (ppr PprForUser) bad_app)]))
-
-		arg_pats = llpats ++ lpats ++ [rpat]
-		bad_app  = (lpat:lpats) ++ [rpat]
-	    in
-	    RETN (ConPatIn n arg_pats, xs2)
-	    BEND BEND
-	    where
-	      rd_curried_pats ('a' : ys)
-		= BIND (rd_curried_pats ys)  _TO_ (lpats, ys1) ->
-		  BIND (rdPat	     sf ys1) _TO_ (rpat,  ys2) ->
-		  RETN (lpats ++ [rpat], ys2)
-		  BEND BEND
-	      rd_curried_pats ys
-		= BIND (rdPat sf ys) _TO_ (pat,	 ys1) ->
-		  RETN ([pat], ys1)
-		  BEND
-
-     '@' -> -- operator application
-	    BIND (rdPat sf xs)	 _TO_ (pat1, xs1) ->
-	    BIND (rdId	   xs1)	 _TO_ (op,   xs2) ->
-	    BIND (rdPat sf xs2)	 _TO_ (pat2, xs3) ->
-	    RETN (ConOpPatIn pat1 op pat2, xs3)
-	    BEND BEND BEND
-
-     ':' -> -- explicit list
-	    BIND (rdList (rdPat sf) xs) _TO_ (pats, xs1) ->
-	    RETN (ListPatIn pats, xs1)
-	    BEND
-
-     ',' -> -- explicit tuple
-	    BIND (rdList (rdPat sf) xs) _TO_ (pats, xs1) ->
-	    RETN (TuplePatIn pats, xs1)
-	    BEND
-
-#ifdef DPH
-     'O' -> -- explicitProcessor pattern
-	    BIND (rdList (rdPat sf) xs) _TO_ (pats, xs1) ->
-	    BIND (rdPat sf xs1)		_TO_ (pat,  xs2) ->
-	    RETN (ProcessorPatIn pats pat, xs2)
-	    BEND BEND
-#endif {- Data Parallel Haskell -}
-
-     huh -> panic ("ReadPrefix.rdPat:"++(next_char:xs))
+wlkPat pat
+  = case pat of
+      U_par pat ->  			-- parenthesised pattern
+	wlkPat pat
+
+      U_as avar as_pat -> 		-- "as" pattern
+	wlkQid avar	`thenUgn` \ var ->
+	wlkPat as_pat	`thenUgn` \ pat ->
+	returnUgn (AsPatIn var pat)
+
+      U_lazyp lazyp -> 			-- irrefutable ("twiddle") pattern
+	wlkPat lazyp	`thenUgn` \ pat ->
+	returnUgn (LazyPatIn pat)
+
+      U_wildp -> returnUgn WildPatIn 	-- wildcard pattern
+
+      --------------------------------------------------------------
+      -- now the prefix items that can either be an expression or
+      -- pattern, except we know they are *patterns* here.
+      --------------------------------------------------------------
+      U_negate nexp _ _ -> 		-- negated pattern: must be a literal
+	wlkPat nexp	`thenUgn` \ lit_pat ->
+	case lit_pat of
+	  LitPatIn lit -> returnUgn (LitPatIn (negLiteral lit))
+	  _	       -> panic "wlkPat: bad negated pattern!"
+
+      U_lit lit ->			-- literal pattern
+	wlkLiteral lit	`thenUgn` \ lit ->
+	returnUgn (LitPatIn lit)
+
+      U_ident nn ->			-- simple identifier
+	wlkQid nn	`thenUgn` \ n ->
+	returnUgn (
+	  if isConopPN n
+	  then ConPatIn n []
+	  else VarPatIn n
+	)
+
+      U_ap l r ->	-- "application": there's a list of patterns lurking here!
+	wlkPat r	  	`thenUgn` \ rpat	 ->
+	collect_pats l [rpat] 	`thenUgn` \ (lpat,lpats) ->
+	let
+	    (n, arg_pats)
+	      = case lpat of
+		  VarPatIn x        -> (x,  lpats)
+		  ConPatIn x []     -> (x,  lpats)
+		  ConOpPatIn x op y -> (op, x:y:lpats)
+		  _ -> -- sorry about the weedy msg; the parser missed this one
+		       error (ppShow 100 (ppCat [
+			   ppStr "ERROR: an illegal `application' of a pattern to another one:",
+			   ppInterleave ppSP (map (ppr PprForUser) (lpat:lpats))]))
+	in
+	returnUgn (ConPatIn n arg_pats)
+	where
+	  collect_pats pat acc
+	    = case pat of
+		U_ap l r ->
+		  wlkPat r	`thenUgn` \ rpat  ->
+		  collect_pats l (rpat:acc)
+		other ->
+		  wlkPat other	`thenUgn` \ pat ->
+		  returnUgn (pat,acc)
+
+      U_infixap fun arg1 arg2 ->
+	wlkQid fun	`thenUgn` \ op   ->
+	wlkPat arg1	`thenUgn` \ pat1 ->
+	wlkPat arg2	`thenUgn` \ pat2 ->
+	returnUgn (ConOpPatIn pat1 op pat2)
+
+      U_llist llist -> 			-- explicit list
+	wlkList rdPat llist 	`thenUgn` \ pats ->
+	returnUgn (ListPatIn pats)
+
+      U_tuple tuplelist -> 		-- explicit tuple
+	wlkList rdPat tuplelist	`thenUgn` \ pats ->
+	returnUgn (TuplePatIn pats)
+
+      U_record con rpats -> 		-- record destruction
+	wlkQid  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 ->
+    	      wlkMaybe rdPat pat `thenUgn` \ pat_maybe ->
+    	      returnUgn (rvar, pat_maybe)
 \end{code}
 
-OLD, MISPLACED NOTE: The extra DPH syntax above is defined such that
-to the left of a \tr{<<-} or \tr{<<=} there has to be a processor (no
-expressions).  Therefore in the pattern matching below we are taking
-this into consideration to create the @DrawGen@ whose fields are the
-\tr{K} patterns, pat and the exp right of the generator.
-
 \begin{code}
-rdLiteral :: String -> RETN_TYPE (Literal, String)
-
-rdLiteral (tag : xs)
-  = BIND (rdString xs)	_TO_ (x, zs) ->
-    let
-	s = _UNPK_ x
-
-	as_char	    = chr ((read s) :: Int)
-	    -- a char comes in as a number string
-	    -- representing its ASCII code
-	as_integer  = readInteger s
-#if __GLASGOW_HASKELL__ <= 22
-	as_rational = toRational ((read s)::Double)
-#else
-#ifdef __GLASGOW_HASKELL__
-	as_rational = _readRational s -- non-std
-#else
-	as_rational = ((read s)::Rational)
-#endif
-#endif
-	as_double   = ((read s) :: Double)
-    in
-    case tag of {
-     '4' -> RETN (IntLit as_integer,	  zs);
-     'F' -> RETN (FracLit as_rational,	  zs);
-     'H' -> RETN (IntPrimLit as_integer,  zs);
-#if __GLASGOW_HASKELL__ <= 22
-     'J' -> RETN (DoublePrimLit as_double,zs);
-     'K' -> RETN (FloatPrimLit as_double, zs);
-#else
-     'J' -> RETN (DoublePrimLit as_rational,zs);
-     'K' -> RETN (FloatPrimLit as_rational, zs);
-#endif
-     'C' -> RETN (CharLit as_char,	  zs);
-     'P' -> RETN (CharPrimLit as_char,	  zs);
-     'S' -> RETN (StringLit x,		  zs);
-     'V' -> RETN (StringPrimLit x,	  zs);
-     'Y' -> RETN (LitLitLitIn x,	  zs)
-    } BEND
+wlkLiteral :: U_literal -> UgnM HsLit
+
+wlkLiteral ulit
+  = returnUgn (
+    case ulit of
+      U_integer    s   -> HsInt	       (as_integer  s)
+      U_floatr     s   -> HsFrac       (as_rational s)
+      U_intprim    s   -> HsIntPrim    (as_integer  s)
+      U_doubleprim s   -> HsDoublePrim (as_rational s)
+      U_floatprim  s   -> HsFloatPrim  (as_rational s)
+      U_charr	   s   -> HsChar       (as_char     s)
+      U_charprim   s   -> HsCharPrim   (as_char     s)
+      U_string     s   -> HsString     (as_string   s)
+      U_stringprim s   -> HsStringPrim (as_string   s)
+      U_clitlit    s _ -> HsLitLit     (as_string   s)
+    )
+  where
+    as_char s     = _HEAD_ s
+    as_integer s  = readInteger (_UNPK_ s)
+    as_rational s = _readRational (_UNPK_ s) -- non-std
+    as_string s   = s
 \end{code}
 
 %************************************************************************
 %*									*
-\subsection[rdBinding]{rdBinding}
+\subsection{wlkBinding}
 %*									*
 %************************************************************************
 
 \begin{code}
-rdBinding :: SrcFile -> String -> RETN_TYPE (RdrBinding, String)
-
-rdBinding sf (next_char:xs)
-  = case next_char of
-     'B' -> -- null binding
-	    RETN (RdrNullBind, xs)
-
-     'A' -> -- "and" binding (just glue, really)
-	    BIND (rdBinding sf xs)  _TO_ (binding1, xs1) ->
-	    BIND (rdBinding sf xs1) _TO_ (binding2, xs2) ->
-	    RETN (RdrAndBindings binding1 binding2, xs2)
-	    BEND BEND
-
-     't' -> -- "data" declaration
-	    BIND (rdString		xs)  _TO_ (srcline,	    xs1) ->
-	    BIND (rdContext		xs1) _TO_ (ctxt,	    xs2) ->
-	    BIND (rdList rdId		xs2) _TO_ (derivings,	    xs3) ->
-	    BIND (rdTyConAndTyVars	xs3) _TO_ ((tycon, tyvars), xs4) ->
-	    BIND (rdList (rdConDecl sf) xs4) _TO_ (cons,	    xs5) ->
-	    BIND (rdDataPragma		xs5) _TO_ (pragma,	    xs6) ->
-	    let
-		src_loc = mkSrcLoc sf srcline
-	    in
-	    RETN (RdrTyData (TyData ctxt tycon tyvars cons derivings pragma src_loc),
-		  xs6)
-	    BEND BEND BEND BEND BEND BEND
-
-     'n' -> -- "type" declaration
-	    BIND (rdString	   xs)	_TO_ (srcline,	       xs1) ->
-	    BIND (rdTyConAndTyVars xs1) _TO_ ((tycon, tyvars), xs2) ->
-	    BIND (rdMonoType	   xs2) _TO_ (expansion,       xs3) ->
-	    BIND (rdTypePragma	   xs3) _TO_ (pragma,	       xs4) ->
-	    let
-		src_loc = mkSrcLoc sf srcline
-	    in
-	    RETN (RdrTySynonym (TySynonym tycon tyvars expansion pragma src_loc),
-		  xs4)
-	    BEND BEND BEND BEND
-
-     'f' -> -- function binding
-	    BIND (rdString		xs) _TO_ (srcline, xs1) ->
-	    BIND (rdList (rdMatch sf) xs1)  _TO_ (matches, xs2) ->
-	    RETN (RdrFunctionBinding (read (_UNPK_ srcline)) matches, xs2)
-	    BEND BEND
-
-     'p' -> -- pattern binding
-	    BIND (rdString		xs)  _TO_ (srcline, xs1) ->
-	    BIND (rdList (rdMatch sf) xs1) _TO_ (matches, xs2) ->
-	    RETN (RdrPatternBinding (read (_UNPK_ srcline)) matches, xs2)
-	    BEND BEND
-
-     '$' -> -- "class" declaration
-	    BIND (rdString	  xs)	_TO_ (srcline,	     xs1) ->
-	    BIND (rdContext	  xs1)	_TO_ (ctxt,	     xs2) ->
-	    BIND (rdClassAssertTy xs2)	_TO_ ((clas, tyvar), xs3) ->
-	    BIND (rdBinding sf	  xs3)	_TO_ (binding,	     xs4) ->
-	    BIND (rdClassPragma	  xs4)	_TO_ (pragma,	     xs5) ->
-	    let
-		(class_sigs, class_methods) = sepDeclsIntoSigsAndBinds binding
-
-		final_sigs    = concat (map cvClassOpSig class_sigs)
-		final_methods = cvMonoBinds sf class_methods
-
-		src_loc = mkSrcLoc sf srcline
-	    in
-	    RETN (RdrClassDecl
-		  (ClassDecl ctxt clas tyvar final_sigs final_methods pragma src_loc),
-		  xs5)
-	    BEND BEND BEND BEND BEND
-
-     '%' -> -- "instance" declaration
-	    BIND (rdString     xs)	_TO_ (srcline,	xs1) ->
-	    BIND (rdContext    xs1)	_TO_ (ctxt,	xs2) ->
-	    BIND (rdId		xs2)	_TO_ (clas,	xs3) ->
-	    BIND (rdMonoType   xs3)	_TO_ (inst_ty,	xs4) ->
-	    BIND (rdBinding sf xs4)	_TO_ (binding,	xs5) ->
-	    BIND (rdInstPragma xs5)	_TO_ (modname_maybe, pragma, xs6) ->
-	    let
-		(ss, bs)   = sepDeclsIntoSigsAndBinds binding
-		binds	   = cvMonoBinds sf bs
-	    	uprags	   = concat (map cvInstDeclSig ss)
-		src_loc	   = mkSrcLoc sf srcline
-	    in
-	    case modname_maybe of {
-	      Nothing ->
-		RETN (RdrInstDecl (\ orig_mod infor_mod here ->
-		      InstDecl ctxt clas inst_ty binds here orig_mod infor_mod uprags pragma src_loc),
-		      xs6);
-	      Just orig_mod ->
-		RETN (RdrInstDecl (\ _ infor_mod here ->
-		      InstDecl ctxt clas inst_ty binds here orig_mod infor_mod uprags pragma src_loc),
-		      xs6)
-	    }
-	    BEND BEND BEND BEND BEND BEND
-
-     'D' -> -- "default" declaration
-	    BIND (rdString	    xs)	  _TO_ (srcline,xs1) ->
-	    BIND (rdList rdMonoType xs1)  _TO_ (tys,	xs2) ->
-
-	    RETN (RdrDefaultDecl (DefaultDecl tys (mkSrcLoc sf srcline)),
-		  xs2)
-	    BEND BEND
-
-     '7' -> -- "import" declaration in an interface
-	    BIND (rdString	    xs)	 _TO_ (srcline,	  xs1) ->
-	    BIND (rdIdString	    xs1) _TO_ (mod,	  xs2) ->
-	    BIND (rdList rdEntity   xs2) _TO_ (entities,  xs3) ->
-	    BIND (rdList rdRenaming xs3) _TO_ (renamings, xs4) ->
-	    let
-		src_loc = mkSrcLoc sf srcline
-	    in
-	    RETN (RdrIfaceImportDecl (IfaceImportDecl mod entities renamings src_loc),
-		  xs4)
-	    BEND BEND BEND BEND
-
-     'S' -> -- signature(-like) things, including user pragmas
-	    rd_sig_thing sf xs
+wlkBinding :: U_binding -> UgnM RdrBinding
+
+wlkBinding binding
+  = case binding of
+      U_nullbind -> -- null binding
+	returnUgn RdrNullBind
+
+      U_abind a b -> -- "and" binding (just glue, really)
+	wlkBinding a    `thenUgn` \ binding1 ->
+	wlkBinding b    `thenUgn` \ binding2 ->
+	returnUgn (RdrAndBindings binding1 binding2)
+
+      U_tbind tctxt ttype tcons tderivs srcline tpragma -> -- "data" declaration
+	wlkContext	   tctxt    `thenUgn` \ ctxt	    ->
+	wlkTyConAndTyVars  ttype    `thenUgn` \ (tycon, tyvars) ->
+	wlkList rdConDecl  tcons    `thenUgn` \ cons	    ->
+	wlkDerivings	   tderivs  `thenUgn` \ derivings   ->
+	wlkDataPragma	   tpragma  `thenUgn` \ pragmas	    ->
+	mkSrcLocUgn	   srcline  `thenUgn` \ src_loc	    ->
+	returnUgn (RdrTyDecl (TyData ctxt tycon tyvars cons derivings pragmas src_loc))
+
+      U_ntbind ntctxt nttype ntcon ntderivs srcline ntpragma -> -- "newtype" declaration
+	wlkContext	   ntctxt   `thenUgn` \ ctxt	    ->
+	wlkTyConAndTyVars  nttype   `thenUgn` \ (tycon, tyvars) ->
+	wlkList rdConDecl  ntcon    `thenUgn` \ con	    ->
+	wlkDerivings	   ntderivs `thenUgn` \ derivings   ->
+	wlkDataPragma	   ntpragma `thenUgn` \ pragma	    ->
+	mkSrcLocUgn	   srcline  `thenUgn` \ src_loc	    ->
+	returnUgn (RdrTyDecl (TyNew ctxt tycon tyvars con derivings pragma src_loc))
+
+      U_nbind nbindid nbindas srcline -> -- "type" declaration
+	wlkTyConAndTyVars nbindid `thenUgn` \ (tycon, tyvars) ->
+	wlkMonoType	  nbindas `thenUgn` \ expansion	    ->
+	mkSrcLocUgn	  srcline `thenUgn` \ src_loc	    ->
+	returnUgn (RdrTyDecl (TySynonym tycon tyvars expansion src_loc))
+
+      U_fbind fbindl srcline -> -- function binding
+	wlkList rdMatch fbindl	`thenUgn` \ matches ->
+	mkSrcLocUgn     srcline	`thenUgn` \ src_loc ->
+	returnUgn (RdrFunctionBinding srcline matches)
+
+      U_pbind pbindl srcline ->  -- pattern binding
+	wlkList rdMatch pbindl	`thenUgn` \ matches ->
+	mkSrcLocUgn     srcline	`thenUgn` \ src_loc ->
+	returnUgn (RdrPatternBinding srcline matches)
+
+      U_cbind cbindc cbindid cbindw srcline cpragma ->	 	-- "class" declaration
+	wlkContext	 cbindc	 `thenUgn` \ ctxt	  ->
+	wlkClassAssertTy cbindid `thenUgn` \ (clas, tyvar)->
+	wlkBinding	 cbindw	 `thenUgn` \ binding	  ->
+	wlkClassPragma   cpragma `thenUgn` \ pragma	  ->
+	mkSrcLocUgn	 srcline `thenUgn` \ src_loc	  ->
+	getSrcFileUgn		 `thenUgn` \ sf		  ->
+	let
+	    (class_sigs, class_methods) = sepDeclsIntoSigsAndBinds binding
+
+	    final_sigs    = concat (map cvClassOpSig class_sigs)
+	    final_methods = cvMonoBinds sf class_methods
+	in
+	returnUgn (RdrClassDecl
+	  (ClassDecl ctxt clas tyvar final_sigs final_methods pragma src_loc))
+
+      U_ibind from_source orig_mod		 		-- "instance" declaration
+	      ibindc iclas ibindi ibindw srcline ipragma ->
+	wlkContext	ibindc	`thenUgn` \ ctxt    ->
+	wlkQid		iclas	`thenUgn` \ clas    ->
+	wlkMonoType	ibindi	`thenUgn` \ inst_ty ->
+	wlkBinding	ibindw	`thenUgn` \ binding ->
+	wlkInstPragma   ipragma	`thenUgn` \ pragma  ->
+	mkSrcLocUgn	srcline	`thenUgn` \ src_loc ->
+	getSrcFileUgn		`thenUgn` \ sf	    ->
+	let
+	    from_here = case from_source of { 0 -> False; 1 -> True }
+	    (ss, bs)  = sepDeclsIntoSigsAndBinds binding
+	    binds     = cvMonoBinds sf bs
+	    uprags    = concat (map cvInstDeclSig ss)
+	    ctxt_inst_ty = HsPreForAllTy ctxt inst_ty
+	in
+	returnUgn (RdrInstDecl
+          (InstDecl clas ctxt_inst_ty binds from_here orig_mod uprags pragma src_loc))
+
+      U_dbind dbindts srcline -> -- "default" declaration
+	wlkList rdMonoType dbindts  `thenUgn` \ tys ->
+	mkSrcLocUgn        srcline  `thenUgn` \ src_loc ->
+	returnUgn (RdrDefaultDecl (DefaultDecl tys src_loc))
+
+      U_mbind mod mbindimp srcline ->
+	-- "import" declaration in an interface
+	wlkList rdEntity   mbindimp	`thenUgn` \ entities  ->
+	mkSrcLocUgn	   srcline	`thenUgn` \ src_loc   ->
+	returnUgn (RdrIfaceImportDecl (IfaceImportDecl mod entities src_loc))
+
+      U_mfbind fixes ->
+	-- "infix" declarations in an interface
+	wlkList rdFixOp fixes 		`thenUgn` \ fixities  ->
+	returnUgn (RdrIfaceFixities fixities)
+
+      a_sig_we_hope ->
+	-- signature(-like) things, including user pragmas
+	wlk_sig_thing a_sig_we_hope
+\end{code}
+
+\begin{code}
+wlkDerivings :: U_maybe -> UgnM (Maybe [ProtoName])
+
+wlkDerivings (U_nothing) = returnUgn Nothing
+wlkDerivings (U_just pt)
+  = rdU_list pt		 `thenUgn` \ ds	    ->
+    wlkList rdQid ds	 `thenUgn` \ derivs ->
+    returnUgn (Just derivs)
 \end{code}
 
 \begin{code}
-rd_sig_thing sf (next_char:xs)
-  = case next_char of
-     't' -> -- type signature
-	    BIND (rdString	 xs)  _TO_ (srcline, xs1) ->
-	    BIND (rdList rdId	 xs1) _TO_ (vars,    xs2) ->
-	    BIND (rdPolyType	 xs2) _TO_ (poly_ty, xs3) ->
-	    BIND (rdTySigPragmas xs3) _TO_ (pragma,  xs4) ->
-	    let
-		src_loc = mkSrcLoc sf srcline
-	    in
-	    RETN (RdrTySig vars poly_ty pragma src_loc, xs4)
-	    BEND BEND BEND BEND
-
-     's' -> -- value specialisation user-pragma
-	    BIND (rdString	    xs)  _TO_ (srcline, xs1) ->
-	    BIND (rdId		    xs1) _TO_ (var,     xs2) ->
-	    BIND (rdList rdPolyType xs2) _TO_ (tys,	xs3) ->
-	    let
-		src_loc = mkSrcLoc sf srcline
-	    in
-	    RETN (RdrSpecValSig [SpecSig var ty Nothing{-ToDo: using...s-} src_loc | ty <- tys], xs3)
-	    BEND BEND BEND
-
-     'S' -> -- instance specialisation user-pragma
-	    BIND (rdString	    xs)  _TO_ (srcline, xs1) ->
-	    BIND (rdId	    	    xs1) _TO_ (clas,    xs2) ->
-	    BIND (rdMonoType	    xs2) _TO_ (ty,	xs3) ->
-	    let
-		src_loc = mkSrcLoc sf srcline
-	    in
-	    RETN (RdrSpecInstSig (InstSpecSig clas ty src_loc), xs3)
-	    BEND BEND BEND
-
-     'i' -> -- value inlining user-pragma
-	    BIND (rdString	    xs)  _TO_ (srcline, xs1) ->
-	    BIND (rdId	    	    xs1) _TO_ (var,     xs2) ->
-	    BIND (rdList rdIdString xs2) _TO_ (howto,   xs3) ->
-	    let
-		src_loc = mkSrcLoc sf srcline
-
-		guidance
-		  = (case howto of {
-		      []  -> id;
-		      [x] -> trace "ignoring unfold howto" }) UnfoldAlways
-	    in
-	    RETN (RdrInlineValSig (InlineSig var guidance src_loc), xs3)
-	    BEND BEND BEND
-
-     'd' -> -- value deforest user-pragma
-            BIND (rdString       xs)  _TO_ (srcline, xs1) ->
-            BIND (rdId           xs1) _TO_ (var, xs2) ->
-            let
-                src_loc = mkSrcLoc sf srcline
-            in
-            RETN (RdrDeforestSig (DeforestSig var src_loc), xs2)
-            BEND BEND
-
-     'u' -> -- value magic-unfolding user-pragma
-	    BIND (rdString	 xs)  _TO_ (srcline, xs1) ->
-	    BIND (rdId	    	 xs1) _TO_ (var,     xs2) ->
-	    BIND (rdIdString   	 xs2) _TO_ (str,     xs3) ->
-	    let
-		src_loc = mkSrcLoc sf srcline
-	    in
-	    RETN (RdrMagicUnfoldingSig (MagicUnfoldingSig var str src_loc), xs3)
-	    BEND BEND BEND
-
-     'a' -> -- abstract-type-synonym user-pragma
-	    BIND (rdString	 xs)  _TO_ (srcline, xs1) ->
-	    BIND (rdId	    	 xs1) _TO_ (tycon,   xs2) ->
-	    let
-		src_loc = mkSrcLoc sf srcline
-	    in
-	    RETN (RdrAbstractTypeSig (AbstractTypeSig tycon src_loc), xs2)
-	    BEND BEND
-
-     'd' -> -- data specialisation user-pragma
-	    BIND (rdString	    xs)  _TO_ (srcline, xs1) ->
-	    BIND (rdId		    xs1) _TO_ (tycon,   xs2) ->
-	    BIND (rdList rdMonoType xs2) _TO_ (tys,	xs3) ->
-	    let
-		src_loc = mkSrcLoc sf srcline
-		spec_ty = MonoTyCon tycon tys
-	    in
-	    RETN (RdrSpecDataSig (SpecDataSig tycon spec_ty src_loc), xs3)
-	    BEND BEND BEND
+wlk_sig_thing (U_sbind sbindids sbindid srcline spragma)  -- type signature
+  = wlkList rdQid	sbindids `thenUgn` \ vars    ->
+    wlkPolyType		sbindid  `thenUgn` \ poly_ty ->
+    wlkTySigPragmas	spragma  `thenUgn` \ pragma  ->
+    mkSrcLocUgn		srcline  `thenUgn` \ src_loc ->
+    returnUgn (RdrTySig vars poly_ty pragma src_loc)
+
+wlk_sig_thing (U_vspec_uprag uvar vspec_tys srcline) -- value specialisation user-pragma
+  = wlkQid  uvar		    `thenUgn` \ var ->
+    wlkList rd_ty_and_id vspec_tys  `thenUgn` \ tys_and_ids ->
+    mkSrcLocUgn	         srcline    `thenUgn` \ src_loc ->
+    returnUgn (RdrSpecValSig [SpecSig var ty using_id src_loc
+			     | (ty, using_id) <- tys_and_ids ])
+  where
+    rd_ty_and_id :: ParseTree -> UgnM (ProtoNamePolyType, Maybe ProtoName)
+    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 ->
+	returnUgn(ty, id_maybe)
+
+wlk_sig_thing (U_ispec_uprag iclas ispec_ty srcline)-- instance specialisation user-pragma
+  = wlkQid	iclas		`thenUgn` \ clas    ->
+    wlkMonoType ispec_ty	`thenUgn` \ ty	    ->
+    mkSrcLocUgn srcline		`thenUgn` \ src_loc ->
+    returnUgn (RdrSpecInstSig (SpecInstSig clas ty src_loc))
+
+wlk_sig_thing (U_inline_uprag ivar srcline) -- value inlining user-pragma
+  = wlkQid	ivar		`thenUgn` \ var     ->
+    mkSrcLocUgn	srcline      	`thenUgn` \ src_loc ->
+    returnUgn (RdrInlineValSig (InlineSig var src_loc))
+
+wlk_sig_thing (U_deforest_uprag ivar srcline) -- "deforest me" user-pragma
+  = wlkQid	ivar		`thenUgn` \ var     ->
+    mkSrcLocUgn srcline		`thenUgn` \ src_loc ->
+    returnUgn (RdrDeforestSig (DeforestSig var src_loc))
+
+wlk_sig_thing (U_magicuf_uprag ivar str srcline) -- "magic" unfolding user-pragma
+  = wlkQid	ivar		`thenUgn` \ var     ->
+    mkSrcLocUgn srcline		`thenUgn` \ src_loc ->
+    returnUgn (RdrMagicUnfoldingSig (MagicUnfoldingSig var str src_loc))
+
+wlk_sig_thing (U_dspec_uprag itycon dspec_tys srcline)
+  = wlkQid	itycon		 `thenUgn` \ tycon   ->
+    mkSrcLocUgn srcline		 `thenUgn` \ src_loc ->
+    wlkList rdMonoType dspec_tys `thenUgn` \ tys     ->
+    let
+	spec_ty = MonoTyApp tycon tys
+    in
+    returnUgn (RdrSpecDataSig (SpecDataSig tycon spec_ty src_loc))
 \end{code}
 
 %************************************************************************
 %*									*
-\subsection[rdTypes]{Reading in types in various forms (and data constructors)}
+\subsection[wlkTypes]{Reading in types in various forms (and data constructors)}
 %*									*
 %************************************************************************
 
 \begin{code}
-rdPolyType :: String -> RETN_TYPE (ProtoNamePolyType, String)
-rdMonoType :: String -> RETN_TYPE (ProtoNameMonoType, String)
-
-rdPolyType ('3' : xs)
-  = BIND (rdContext	 xs)	_TO_ (ctxt, xs1) ->
-    BIND (rdMonoType xs1)	_TO_ (ty,   xs2) ->
-    RETN (OverloadedTy ctxt ty, xs2)
-    BEND BEND
-
-rdPolyType ('2' : 'C' : xs)
-  = BIND (rdList rdId xs)   	_TO_ (tvs, xs1) ->
-    BIND (rdMonoType  xs1)  	_TO_ (ty,  xs2) ->
-    RETN (ForAllTy tvs ty, xs2)
-    BEND BEND
-
-rdPolyType other
-  = BIND (rdMonoType other) 	    _TO_ (ty, xs1) ->
-    RETN (UnoverloadedTy ty, xs1)
-    BEND
-
-rdMonoType ('T' : xs)
-  = BIND (rdId		xs)  	    _TO_ (tycon, xs1) ->
-    BIND (rdList rdMonoType xs1)    _TO_ (tys,	 xs2) ->
-    RETN (MonoTyCon tycon tys, xs2)
-    BEND BEND
-
-rdMonoType (':' : xs)
-  = BIND (rdMonoType xs)	    _TO_ (ty, xs1) ->
-    RETN (ListMonoTy ty, xs1)
-    BEND
-
-rdMonoType (',' : xs)
-  = BIND (rdList rdPolyType xs)	    _TO_ (tys, xs1) ->
-    RETN (TupleMonoTy tys, xs1)
-    BEND
-
-rdMonoType ('>' : xs)
-  = BIND (rdMonoType xs)	_TO_ (ty1, xs1) ->
-    BIND (rdMonoType xs1)	_TO_ (ty2, xs2) ->
-    RETN (FunMonoTy ty1 ty2, xs2)
-    BEND BEND
-
-rdMonoType ('y' : xs)
-  = BIND (rdId xs)		_TO_ (tyvar, xs1) ->
-    RETN (MonoTyVar tyvar, xs1)
-    BEND
-
-rdMonoType ('2' : 'A' : xs)
-  = BIND (rdId	     xs)	_TO_ (clas, xs1) ->
-    BIND (rdMonoType xs1)	_TO_ (ty,   xs2) ->
-    RETN (MonoDict clas ty, xs2)
-    BEND BEND
-
-rdMonoType ('2' : 'B' : xs)
-  = BIND (rdId xs)  	    	_TO_ (tv_tmpl, xs1) ->
-    RETN (MonoTyVarTemplate tv_tmpl, xs1)
-    BEND
-
-#ifdef DPH
-rdMonoType ('v' : xs)
-  = BIND (rdMonoType xs)	    _TO_ (ty, xs1) ->
-    RETN (RdrExplicitPodTy ty, xs1)
-    BEND
-
-rdMonoType ('u' : xs)
-  = BIND (rdList rdMonoType xs) _TO_ (tys, xs1) ->
-    BIND (rdMonoType xs1)	_TO_ (ty,  xs2)  ->
-    RETN (RdrExplicitProcessorTy tys ty, xs2)
-    BEND BEND
-#endif {- Data Parallel Haskell -}
-
-rdMonoType oops = panic ("rdMonoType:"++oops)
+rdPolyType :: ParseTree -> UgnM ProtoNamePolyType
+rdMonoType :: ParseTree -> UgnM ProtoNameMonoType
+
+rdPolyType pt = rdU_ttype pt `thenUgn` \ ttype -> wlkPolyType ttype
+rdMonoType pt = rdU_ttype pt `thenUgn` \ ttype -> wlkMonoType ttype
+
+wlkPolyType :: U_ttype -> UgnM ProtoNamePolyType
+wlkMonoType :: U_ttype -> UgnM ProtoNameMonoType
+
+wlkPolyType ttype
+  = case ttype of
+{-LATER:
+      U_uniforall utvs uty -> -- forall type (pragmas)
+	wlkList rdU_unkId utvs  `thenUgn` \ tvs ->
+	wlkMonoType       uty	`thenUgn` \ ty  ->
+	returnUgn (HsForAllTy tvs ty)
+-}
+
+      U_context tcontextl tcontextt -> -- context
+	wlkContext  tcontextl	`thenUgn` \ ctxt ->
+	wlkMonoType tcontextt	`thenUgn` \ ty	 ->
+	returnUgn (HsPreForAllTy ctxt ty)
+
+      other -> -- something else
+	wlkMonoType other   `thenUgn` \ ty ->
+	returnUgn (HsPreForAllTy [{-no context-}] ty)
+
+wlkMonoType ttype
+  = case ttype of
+      U_namedtvar tyvar -> -- type variable
+	returnUgn (MonoTyVar tyvar)
+
+      U_tname tcon -> -- type constructor
+	wlkQid tcon	`thenUgn` \ tycon ->
+	returnUgn (MonoTyApp tycon [])
+
+      U_tapp t1 t2 ->
+	wlkMonoType t2		`thenUgn` \ ty2 ->
+	collect t1 [ty2]	`thenUgn` \ (tycon, tys) ->
+	returnUgn (MonoTyApp tycon tys)
+       where
+	collect t acc
+	  = case t of
+	      U_tapp t1 t2 -> wlkMonoType t2	`thenUgn` \ ty2 ->
+			      collect t1 (ty2:acc)
+	      U_tname tcon -> wlkQid tcon	`thenUgn` \ tycon  ->
+			      returnUgn (tycon, acc)
+	      U_namedtvar tv -> returnUgn (tv, acc)
+	      U_tllist _ -> panic "tlist"
+	      U_ttuple _ -> panic "ttuple"
+	      U_tfun _ _ -> panic "tfun"
+	      U_tbang _ -> panic "tbang"
+	      U_context _ _ -> panic "context"
+	      _ -> panic "something else"
+	      
+      U_tllist tlist -> -- list type
+	wlkMonoType tlist	`thenUgn` \ ty ->
+	returnUgn (MonoListTy ty)
+
+      U_ttuple ttuple ->
+	wlkList rdMonoType ttuple `thenUgn` \ tys ->
+	returnUgn (MonoTupleTy tys)
+
+      U_tfun tfun targ ->
+	wlkMonoType tfun	`thenUgn` \ ty1 ->
+	wlkMonoType targ	`thenUgn` \ ty2 ->
+	returnUgn (MonoFunTy ty1 ty2)
+
+      U_unidict uclas t -> -- DictTy (pragmas)
+	wlkQid uclas	`thenUgn` \ clas ->
+	wlkMonoType t	`thenUgn` \ ty	 ->
+	returnUgn (MonoDictTy clas ty)
 \end{code}
 
 \begin{code}
-rdTyConAndTyVars :: String -> RETN_TYPE ((ProtoName, [ProtoName]), String)
-rdContext   	 :: String -> RETN_TYPE (ProtoNameContext, String)
-rdClassAssertTy  :: String -> RETN_TYPE ((ProtoName, ProtoName), String)
+wlkTyConAndTyVars :: U_ttype -> UgnM (ProtoName, [ProtoName])
+wlkContext   	  :: U_list  -> UgnM ProtoNameContext
+wlkClassAssertTy  :: U_ttype -> UgnM (ProtoName, ProtoName)
 
-rdTyConAndTyVars xs
-  = BIND (rdMonoType xs)   _TO_ (MonoTyCon tycon ty_args, xs1) ->
+wlkTyConAndTyVars ttype
+  = wlkMonoType ttype	`thenUgn` \ (MonoTyApp tycon ty_args) ->
     let
 	args = [ a | (MonoTyVar a) <- ty_args ]
     in
-    RETN ((tycon, args), xs1)
-    BEND
+    returnUgn (tycon, args)
 
-rdContext xs
-  = BIND (rdList rdMonoType xs)	_TO_ (tys, xs1) ->
-    RETN (map mk_class_assertion tys, xs1)
-    BEND
+wlkContext list
+  = wlkList rdMonoType list `thenUgn` \ tys ->
+    returnUgn (map mk_class_assertion tys)
 
-rdClassAssertTy xs
-  = BIND (rdMonoType xs)   _TO_ (mono_ty, xs1) ->
-    RETN (mk_class_assertion mono_ty, xs1)
-    BEND
+wlkClassAssertTy xs
+  = wlkMonoType xs   `thenUgn` \ mono_ty ->
+    returnUgn (mk_class_assertion mono_ty)
 
 mk_class_assertion :: ProtoNameMonoType -> (ProtoName, ProtoName)
 
-mk_class_assertion (MonoTyCon name [(MonoTyVar tyname)]) = (name, tyname)
+mk_class_assertion (MonoTyApp name [(MonoTyVar tyname)]) = (name, tyname)
 mk_class_assertion other
   = error ("ERROR: malformed type context: "++ppShow 80 (ppr PprForUser other)++"\n")
     -- regrettably, the parser does let some junk past
@@ -851,62 +754,103 @@ mk_class_assertion other
 \end{code}
 
 \begin{code}
-rdConDecl :: SrcFile -> String -> RETN_TYPE (ProtoNameConDecl, String)
-
-rdConDecl sf ('1':xs)
-  = BIND (rdString	    xs)	 _TO_ (srcline,	  xs1) ->
-    BIND (rdId		    xs1) _TO_ (id,	  xs2) ->
-    BIND (rdList rdMonoType xs2) _TO_ (tys,	  xs3) ->
-    RETN (ConDecl id tys (mkSrcLoc sf srcline), xs3)
-    BEND BEND BEND
+rdConDecl :: ParseTree -> UgnM ProtoNameConDecl
+rdConDecl pt
+  = rdU_constr pt    `thenUgn` \ blah ->
+    wlkConDecl blah
+
+wlkConDecl :: U_constr -> UgnM ProtoNameConDecl
+
+wlkConDecl (U_constrpre ccon ctys srcline)
+  = mkSrcLocUgn srcline		`thenUgn` \ src_loc ->
+    wlkQid	ccon		`thenUgn` \ con	    ->
+    wlkList     rdBangType ctys	`thenUgn` \ tys	    ->
+    returnUgn (ConDecl con tys src_loc)
+
+wlkConDecl (U_constrinf cty1 cop cty2 srcline)
+  = mkSrcLocUgn srcline		`thenUgn` \ src_loc ->
+    wlkBangType cty1		`thenUgn` \ ty1	    ->
+    wlkQid	cop		`thenUgn` \ op	    ->
+    wlkBangType cty2		`thenUgn` \ ty2	    ->
+    returnUgn (ConOpDecl ty1 op ty2 src_loc)
+
+wlkConDecl (U_constrnew ccon cty srcline)
+  = mkSrcLocUgn srcline		`thenUgn` \ src_loc ->
+    wlkQid	ccon		`thenUgn` \ con	    ->
+    wlkMonoType cty		`thenUgn` \ ty	    ->
+    returnUgn (NewConDecl con ty src_loc)
+
+wlkConDecl (U_constrrec ccon cfields srcline)
+  = mkSrcLocUgn srcline		`thenUgn` \ src_loc      ->
+    wlkQid	ccon		`thenUgn` \ con		 ->
+    wlkList rd_field cfields	`thenUgn` \ fields_lists ->
+    returnUgn (RecConDecl con (concat fields_lists) src_loc)
+  where
+    rd_field :: ParseTree -> UgnM [(ProtoName, BangType ProtoName)]
+    rd_field pt
+      = rdU_constr pt		`thenUgn` \ (U_field fvars fty) ->
+	wlkList rdQid	fvars	`thenUgn` \ vars ->
+	wlkBangType fty		`thenUgn` \ ty ->
+	returnUgn [ (var, ty) | var <- vars ]
+
+-----------------
+rdBangType pt = rdU_ttype pt `thenUgn` \ ty -> wlkBangType ty
+
+wlkBangType :: U_ttype -> UgnM (BangType ProtoName)
+
+wlkBangType (U_tbang bty) = wlkMonoType bty `thenUgn` \ ty -> returnUgn (Banged   ty)
+wlkBangType uty		  = wlkMonoType uty `thenUgn` \ ty -> returnUgn (Unbanged ty)
+
 \end{code}
 
 %************************************************************************
 %*									*
-\subsection[rdMatch]{Read a ``match''}
+\subsection{Read a ``match''}
 %*									*
 %************************************************************************
 
 \begin{code}
-rdMatch :: SrcFile -> String -> RETN_TYPE (RdrMatch, String)
+rdMatch :: ParseTree -> UgnM RdrMatch
 
-rdMatch sf ('W':xs)
-  = BIND (rdString	    xs)	 _TO_ (srcline, xs1) ->
-    BIND (rdIdString	    xs1) _TO_ (srcfun,	xs2) ->
-    BIND (rdPat sf	    xs2) _TO_ (pat,	xs3) ->
-    BIND (rdList rd_guarded xs3) _TO_ (grhss,	xs4) ->
-    BIND (rdBinding sf	    xs4) _TO_ (binding, xs5) ->
+rdMatch pt
+  = rdU_pbinding pt `thenUgn` \ (U_pgrhs gpat gdexprs gbind gsrcfun srcline) ->
+
+    wlkPat		gpat	`thenUgn` \ pat     ->
+    wlkBinding		gbind	`thenUgn` \ binding ->
+    wlkQid		gsrcfun	`thenUgn` \ srcfun  ->
+    let
+	wlk_guards (U_pnoguards exp)
+	  = wlkExpr exp `thenUgn` \ expr ->
+	    returnUgn (RdrMatch_NoGuard srcline srcfun pat expr binding)
 
-    RETN (RdrMatch (read (_UNPK_ srcline)) srcfun pat grhss binding, xs5)
-    BEND BEND BEND BEND BEND
+	wlk_guards (U_pguards gs)
+	  = wlkList rd_gd_expr gs   `thenUgn` \ gd_exps ->
+	    returnUgn (RdrMatch_Guards  srcline srcfun pat gd_exps binding)
+    in
+    wlk_guards gdexprs
   where
-    rd_guarded xs
-      = BIND (rdExpr sf xs)	_TO_ (g, xs1) ->
-	BIND (rdExpr sf xs1)	_TO_ (e, xs2) ->
-	RETN ((g, e), xs2)
-	BEND BEND
+    rd_gd_expr pt
+      = rdU_pbinding pt `thenUgn` \ (U_pgdexp g e) ->
+	wlkExpr      g  `thenUgn` \ guard ->
+	wlkExpr	     e  `thenUgn` \ expr  ->
+	returnUgn (guard, expr)
 \end{code}
 
 %************************************************************************
 %*									*
-\subsection[rdFixity]{Read in a fixity declaration}
+\subsection[rdFixOp]{Read in a fixity declaration}
 %*									*
 %************************************************************************
 
 \begin{code}
-rdFixity :: String -> RETN_TYPE (ProtoNameFixityDecl, String)
-rdFixity xs
-  = BIND (rdId	   xs)	_TO_ (op,	     xs1) ->
-    BIND (rdString xs1)	_TO_ (associativity, xs2) ->
-    BIND (rdString xs2)	_TO_ (prec_str,	     xs3) ->
-    let
-	precedence = read (_UNPK_ prec_str)
-    in
-    case (_UNPK_ associativity) of {
-      "infix"  -> RETN (InfixN op precedence, xs3);
-      "infixl" -> RETN (InfixL op precedence, xs3);
-      "infixr" -> RETN (InfixR op precedence, xs3)
-    } BEND BEND BEND
+rdFixOp :: ParseTree -> UgnM ProtoNameFixityDecl
+rdFixOp pt 
+  = rdU_tree pt `thenUgn` \ fix ->
+    case fix of
+      U_fixop op (-1) prec -> returnUgn (InfixL op prec)
+      U_fixop op   0  prec -> returnUgn (InfixN op prec)
+      U_fixop op   1  prec -> returnUgn (InfixR op prec)
+      _ -> error "ReadPrefix:rdFixOp"
 \end{code}
 
 %************************************************************************
@@ -916,81 +860,73 @@ rdFixity xs
 %************************************************************************
 
 \begin{code}
-rdImportedInterface :: FAST_STRING -> String
-		    -> RETN_TYPE (ProtoNameImportedInterface, String)
+rdImportedInterface :: ParseTree
+		    -> UgnM ProtoNameImportedInterface
+
+rdImportedInterface pt
+  = rdU_binding pt
+	`thenUgn` \ (U_import ifname iffile binddef imod iqual ias ispec srcline) ->
 
-rdImportedInterface importing_srcfile (x:xs)
-  = BIND (rdString	    xs)	 _TO_ (srcline,	 xs1) ->
-    BIND (rdString	    xs1) _TO_ (srcfile,	 xs2) ->
-    BIND (rdIdString	    xs2) _TO_ (modname,	 xs3) ->
-    BIND (rdList rdEntity   xs3) _TO_ (imports,	 xs4) ->
-    BIND (rdList rdRenaming xs4) _TO_ (renamings,xs5) ->
-    BIND (rdBinding srcfile xs5) _TO_ (iface_bs, xs6) ->
+    mkSrcLocUgn	srcline 		`thenUgn` \ src_loc   	->
+    wlkMaybe rdU_stringId ias		`thenUgn` \ maybe_as	->
+    wlkMaybe rd_spec ispec		`thenUgn` \ maybe_spec	->
+
+    setSrcFileUgn iffile ( -- looking inside the .hi file...
+	wlkBinding binddef
+    )				`thenUgn` \ iface_bs  ->
 
     case (sepDeclsForInterface iface_bs) of {
-		(tydecls,classdecls,instdecls,sigs,iimpdecls) ->
+	(tydecls,classdecls,instdecls,sigs,iimpdecls,ifixities) ->
     let
-	expose_or_hide = case x of { 'e' -> ImportSome; 'h' -> ImportButHide }
-
-	cv_iface
-	  = MkInterface	modname
-		iimpdecls
-		[{-fixity decls-}]  -- can't get fixity decls in here yet (ToDo)
-		tydecls
-		classdecls
-		(cvInstDecls False SLIT(""){-probably superceded by modname < pragmas-}
-				   modname instdecls)
-			    -- False indicates imported
-		(concat (map cvValSig sigs))
-		(mkSrcLoc importing_srcfile srcline)
-    in
-    RETN (
-    (if null imports then
-	ImportAll cv_iface renamings
-     else
-	expose_or_hide cv_iface imports renamings
-    , xs6))
-    } BEND BEND BEND BEND BEND BEND
-\end{code}
+	cv_sigs  = concat (map cvValSig sigs)
 
-\begin{code}
-rdRenaming :: String -> RETN_TYPE (Renaming, String)
+	cv_iface = Interface ifname iimpdecls ifixities
+			tydecls	classdecls instdecls cv_sigs
+			src_loc
 
-rdRenaming xs
-  = BIND (rdIdString xs)    _TO_ (id1, xs1) ->
-    BIND (rdIdString xs1)   _TO_ (id2, xs2) ->
-    RETN (MkRenaming id1 id2, xs2)
-    BEND BEND
+	cv_qual = case iqual of {0 -> False; 1 -> True}
+    in
+    returnUgn (ImportMod cv_iface cv_qual maybe_as maybe_spec)
+    }
+  where
+    rd_spec pt = rdU_either pt 		`thenUgn` \ spec ->
+      case spec of
+	U_left pt  -> rdEntities pt	`thenUgn` \ ents ->
+		      returnUgn (False, ents)
+	U_right pt -> rdEntities pt 	`thenUgn` \ ents ->
+		      returnUgn (True, ents)
 \end{code}
 
 \begin{code}
-rdEntity :: String -> RETN_TYPE (IE, String)
-
-rdEntity inp
-  = case inp of
-      'x':xs -> BIND (rdIdString xs)	_TO_ (var, xs1) ->
-		RETN (IEVar var, xs1)
-		BEND
-
-      'X':xs -> BIND (rdIdString xs)	_TO_ (thing, xs1) ->
-		RETN (IEThingAbs thing, xs1)
-		BEND
-
-      'z':xs -> BIND (rdIdString xs)	_TO_ (thing, xs1) ->
-		RETN (IEThingAll thing, xs1)
-		BEND
-
-      '8':xs -> BIND (rdIdString	xs)  _TO_ (tycon, xs1) ->
-		BIND (rdList rdString	xs1) _TO_ (cons,  xs2) ->
-		RETN (IEConWithCons tycon cons, xs2)
-		BEND BEND
-
-      '9':xs -> BIND (rdIdString	xs)  _TO_ (c,	xs1) ->
-		BIND (rdList rdString	xs1) _TO_ (ops, xs2) ->
-		RETN (IEClsWithOps c ops, xs2)
-		BEND BEND
-
-      'm':xs -> BIND (rdIdString xs)	_TO_ (m, xs1) ->
-		RETN (IEModuleContents m, xs1)
-		BEND
+rdEntities pt
+  = rdU_list pt		    `thenUgn` \ list ->
+    wlkList rdEntity list
+
+rdEntity :: ParseTree -> UgnM (IE ProtoName)
+
+rdEntity pt
+  = rdU_entidt pt `thenUgn` \ entity ->
+    case entity of
+      U_entid evar -> 		-- just a value
+	wlkQid	evar		`thenUgn` \ var ->
+	returnUgn (IEVar var)
+
+      U_enttype x -> 		-- abstract type constructor/class
+	wlkQid	x		`thenUgn` \ thing ->
+	returnUgn (IEThingAbs thing)
+
+      U_enttypeall x -> 	-- non-abstract type constructor/class
+	wlkQid	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 -> 
+	returnUgn (IEThingAll thing)
+	-- returnUgn (IEThingWith thing names)
+
+      U_entmod mod -> -- everything provided by a module
+	returnUgn (IEModuleContents mod)
 \end{code}
+
diff --git a/ghc/compiler/reader/ReadPrefix2.hi b/ghc/compiler/reader/ReadPrefix2.hi
deleted file mode 100644
index 3eda3e9d7c..0000000000
--- a/ghc/compiler/reader/ReadPrefix2.hi
+++ /dev/null
@@ -1,15 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface ReadPrefix2 where
-import AbsSyn(Module)
-import HsDecls(ConDecl)
-import HsPat(InPat)
-import HsTypes(MonoType)
-import PreludePS(_PackedString)
-import ProtoName(ProtoName)
-import U_list(U_list)
-import U_ttype(U_ttype)
-rdConDecl :: _Addr -> _PackedString -> _State _RealWorld -> (ConDecl ProtoName, _State _RealWorld)
-rdModule :: _State _RealWorld -> ((_PackedString, (_PackedString -> Bool, _PackedString -> Bool), Module ProtoName (InPat ProtoName)), _State _RealWorld)
-wlkList :: (_Addr -> _PackedString -> _State _RealWorld -> (a, _State _RealWorld)) -> U_list -> _PackedString -> _State _RealWorld -> ([a], _State _RealWorld)
-wlkMonoType :: U_ttype -> _PackedString -> _State _RealWorld -> (MonoType ProtoName, _State _RealWorld)
-
diff --git a/ghc/compiler/reader/ReadPrefix2.lhs b/ghc/compiler/reader/ReadPrefix2.lhs
deleted file mode 100644
index 85990cbeeb..0000000000
--- a/ghc/compiler/reader/ReadPrefix2.lhs
+++ /dev/null
@@ -1,856 +0,0 @@
-%
-% (c) The AQUA Project, Glasgow University, 1994-1995
-%
-\section[ReadPrefix2]{Read parse tree built by Yacc parser}
-
-Comments?
-
-\begin{code}
-#include "HsVersions.h"
-
-module ReadPrefix2 (
-	rdModule,
-
-	-- used over in ReadPragmas2...
-	wlkList, rdConDecl, wlkMonoType
-    )  where
-
-IMPORT_Trace		-- ToDo: rm (debugging)
-import Pretty
-
-import UgenAll
-
-import AbsSyn
-import HsCore		-- ****** NEED TO SEE CONSTRUCTORS ******
-import HsPragmas	-- ****** NEED TO SEE CONSTRUCTORS ******
-import FiniteMap
-import IdInfo		( UnfoldingGuidance(..) )
-import MainMonad
-import Maybes		( Maybe(..) )
-import PrefixToHs
-import PrefixSyn
-import ProtoName
-import Outputable
-import ReadPragmas2
-import Util
-\end{code}
-
-%************************************************************************
-%*									*
-\subsection[ReadPrefix-help]{Help Functions}
-%*									*
-%************************************************************************
-
-\begin{code}
-wlkList :: (U_VOID_STAR -> UgnM a) -> U_list -> UgnM [a]
-
-wlkList wlk_it U_lnil = returnUgn []
-
-wlkList wlk_it (U_lcons hd tl)
-  = wlk_it  hd		`thenUgn` \ hd_it ->
-    wlkList wlk_it tl	`thenUgn` \ tl_it ->
-    returnUgn (hd_it : tl_it)
-\end{code}
-
-%************************************************************************
-%*									*
-\subsection[rdModule]{@rdModule@: reads in a Haskell module}
-%*									*
-%************************************************************************
-
-\begin{code}
-rdModule :: MainIO
-	    (FAST_STRING,			-- this module's name
-	     (FAST_STRING -> Bool,	-- a function to chk if <x> is in the export list
-	      FAST_STRING -> Bool),	-- a function to chk if <M> is among the M..
-					-- ("dotdot") modules in the export list.
-	     ProtoNameModule)		-- the main goods
-
-rdModule
-  = _ccall_ hspmain `thenMn` \ pt -> -- call the Yacc parser!
-    let
-	srcfile  = _packCString ``input_filename'' -- What A Great Hack! (TM)
-    in
-    initUgn srcfile (
-
-    rdU_tree pt `thenUgn` \ (U_hmodule name himplist hexplist hmodlist srcline) ->
-    rdFixities	`thenUgn` \ fixities ->
-    wlkBinding			hmodlist `thenUgn` \ binding	->
-    wlkList rdImportedInterface himplist `thenUgn` \ imports	->
-    wlkList rdEntity		hexplist `thenUgn` \ export_list->
-    mkSrcLocUgn srcline			 `thenUgn` \ src_loc	->
-
-    case sepDeclsForTopBinds binding	  of {
-      (tydecls, tysigs, classdecls, instdecls, instsigs, defaultdecls, binds) ->
-      -- ToDo: bad for laziness??
-
-    returnUgn (
-     name,
-     mk_export_list_chker export_list,
-     Module name
-	    export_list
-	    imports
-	    fixities
-	    tydecls
-	    tysigs
-	    classdecls
-	    (cvInstDecls True name name instdecls) -- True indicates not imported
-	    instsigs
-	    defaultdecls
-	    (cvSepdBinds srcfile cvValSig binds)
-	    [{-no sigs-}]
-	    src_loc
-    ) } )
-  where
-    mk_export_list_chker exp_list
-      = case (getIEStrings exp_list) of { (entity_info, dotdot_modules) ->
-	( \ n -> n `elemFM` entity_info,
-	  \ n -> n `elemFM` dotdot_modules )
-    	}
-\end{code}
-
-Convert fixities table:
-\begin{code}
-rdFixities :: UgnM [ProtoNameFixityDecl]
-
-rdFixities
-  = ioToUgnM (_ccall_ nfixes)	`thenUgn` \ num_fixities@(I# _) ->
-    let
-	rd i acc
-	  | i >= num_fixities
-	  = returnUgn acc
-
-	  | otherwise
-	  = ioToUgnM (_ccall_ fixtype i) `thenUgn` \ fix_ty@(A# _) ->
-	    if fix_ty == ``NULL'' then
-		rd (i+1) acc
-	    else
-		ioToUgnM (_ccall_ fixop      i) `thenUgn` \ fix_op@(A# _) ->
-		ioToUgnM (_ccall_ precedence i) `thenUgn` \ precedence@(I# _) ->
-		let
-		    op = Unk (_packCString fix_op)
-
-		    associativity
-		      = _UNPK_ (_packCString fix_ty)
-
-		    new_fix
-		      = case associativity of
-			  "infix"  -> InfixN op precedence
-			  "infixl" -> InfixL op precedence
-			  "infixr" -> InfixR op precedence
-		in
-		rd (i+1) (new_fix : acc)
-    in
-    rd 0 []
-\end{code}
-
-%************************************************************************
-%*									*
-\subsection[wlkExprOrPat]{@wlkExpr@ and @wlkPat@}
-%*									*
-%************************************************************************
-
-\begin{code}
-rdExpr :: ParseTree -> UgnM ProtoNameExpr
-rdPat  :: ParseTree -> UgnM ProtoNamePat
-
-rdExpr pt = rdU_tree pt `thenUgn` \ tree -> wlkExpr tree
-rdPat  pt = rdU_tree pt `thenUgn` \ tree -> wlkPat  tree
-
-wlkExpr :: U_tree -> UgnM ProtoNameExpr
-wlkPat  :: U_tree -> UgnM ProtoNamePat
-
-wlkExpr expr
-  = case expr of
-      U_par expr -> -- parenthesised expr
-	wlkExpr expr
-
-      U_lsection lsexp op ->	-- left section
-        wlkExpr lsexp	`thenUgn` \ expr ->
-	returnUgn (SectionL expr (Var op))
-
-      U_rsection op rsexp -> -- right section
-	wlkExpr rsexp	`thenUgn` \ expr ->
-	returnUgn (SectionR (Var op) expr)
-
-      U_ccall fun flavor ccargs -> -- ccall/casm
-	wlkList rdExpr ccargs   `thenUgn` \ args ->
-	let
-	    tag = _HEAD_ flavor
-	in
-	returnUgn (CCall fun args
-		    (tag == 'p' || tag == 'P') -- may invoke GC
-		    (tag == 'N' || tag == 'P') -- really a "casm"
-		    (panic "CCall:result_ty"))
-
-      U_scc label sccexp -> -- scc (set-cost-centre) expression
-	wlkExpr   sccexp	`thenUgn` \ expr  ->
-	returnUgn (SCC label expr)
-
-      U_lambda lampats lamexpr srcline -> -- lambda expression
-        wlkList rdPat lampats	`thenUgn` \ pats ->
-	wlkExpr       lamexpr	`thenUgn` \ body ->
-	mkSrcLocUgn   srcline	`thenUgn` \ src_loc ->
-	returnUgn (
-	    Lam (foldr PatMatch
-		       (GRHSMatch (GRHSsAndBindsIn
-				    [OtherwiseGRHS body src_loc]
-				    EmptyBinds))
-		       pats)
-	)
-
-      U_casee caseexpr casebody -> -- case expression
-        wlkExpr	       caseexpr	 `thenUgn` \ expr ->
-	wlkList rdMatch casebody `thenUgn` \ mats ->
-	getSrcFileUgn		 `thenUgn` \ sf ->
-	let
-	    matches = cvMatches sf True mats
-	in
-	returnUgn (Case expr matches)
-
-      U_ife ifpred ifthen ifelse -> -- if expression
-        wlkExpr ifpred	`thenUgn` \ e1 ->
-	wlkExpr ifthen	`thenUgn` \ e2 ->
-	wlkExpr ifelse	`thenUgn` \ e3 ->
-	returnUgn (If e1 e2 e3)
-
-      U_let letvdeflist letvexpr -> -- let expression
-        wlkBinding letvdeflist	`thenUgn` \ binding ->
-	wlkExpr    letvexpr	`thenUgn` \ expr    ->
-	getSrcFileUgn		`thenUgn` \ sf	    ->
-	let
-	    binds = cvBinds sf cvValSig binding
-	in
-	returnUgn (Let binds expr)
-
-      U_comprh cexp cquals -> -- list comprehension
-        wlkExpr cexp		`thenUgn` \ expr  ->
-	wlkList rd_qual cquals	`thenUgn` \ quals ->
-	returnUgn (ListComp expr quals)
-	where
-	  rd_qual pt
-	    = rdU_tree pt	`thenUgn` \ qual ->
-	      wlk_qual qual
-
-	  wlk_qual qual
-	    = case qual of
-		U_par expr -> wlk_qual expr -- overkill? (ToDo?)
-
-	        U_qual qpat qexp ->
-		  wlkPat  qpat  `thenUgn` \ pat  ->
-		  wlkExpr qexp  `thenUgn` \ expr ->
-		  returnUgn (GeneratorQual pat expr)
-
-		U_guard gexp ->
-		  wlkExpr gexp  `thenUgn` \ expr ->
-		  returnUgn (FilterQual expr)
-
-      U_eenum efrom estep eto -> -- arithmetic sequence
-        wlkExpr efrom		`thenUgn` \ e1  ->
-	wlkList rdExpr estep	`thenUgn` \ es2 ->
-	wlkList rdExpr eto	`thenUgn` \ es3 ->
-	returnUgn (cv_arith_seq e1 es2 es3)
-	where -- ToDo: use Maybe type
-	   cv_arith_seq e1 []   []   = ArithSeqIn (From	      e1)
-	   cv_arith_seq e1 []   [e3] = ArithSeqIn (FromTo     e1 e3)
-	   cv_arith_seq e1 [e2] []   = ArithSeqIn (FromThen   e1 e2)
-	   cv_arith_seq e1 [e2] [e3] = ArithSeqIn (FromThenTo e1 e2 e3)
-
-      U_restr restre restrt -> -- expression with type signature
-        wlkExpr	    restre	`thenUgn` \ expr ->
-	wlkPolyType restrt	`thenUgn` \ ty	 ->
-	returnUgn (ExprWithTySig expr ty)
-
-      U_negate nexp -> -- negated expression
-        wlkExpr nexp		`thenUgn` \ expr ->
-	returnUgn (App (Var (Unk SLIT("negate"))) expr)
-
-      -- ToDo: DPH stuff
-
-      --------------------------------------------------------------
-      -- now the prefix items that can either be an expression or
-      -- pattern, except we know they are *expressions* here
-      -- (this code could be commoned up with the pattern version;
-      -- but it probably isn't worth it)
-      --------------------------------------------------------------
-      U_lit lit ->
-        wlkLiteral lit	`thenUgn` \ lit ->
-	returnUgn (Lit lit)
-
-      U_ident n -> -- simple identifier
-	returnUgn (Var n)
-
-      U_ap fun arg -> -- application
-        wlkExpr fun	`thenUgn` \ expr1 ->
-	wlkExpr arg	`thenUgn` \ expr2 ->
-	returnUgn (App expr1 expr2)
-
-      U_tinfixop (op, arg1, arg2) ->
-        wlkExpr arg1	`thenUgn` \ expr1 ->
-	wlkExpr arg2	`thenUgn` \ expr2 ->
-	returnUgn (OpApp expr1 (Var op) expr2)
-
-      U_llist llist -> -- explicit list
-        wlkList rdExpr llist `thenUgn` \ exprs ->
-	returnUgn (ExplicitList exprs)
-
-      U_tuple tuplelist -> -- explicit tuple
-        wlkList rdExpr tuplelist `thenUgn` \ exprs ->
-	returnUgn (ExplicitTuple exprs)
-
-#ifdef DEBUG
-      U_hmodule _ _ _ _ _ -> error "U_hmodule"
-      U_as _ _ -> error "U_as"
-      U_lazyp _ -> error "U_lazyp"
-      U_plusp _ _ -> error "U_plusp"
-      U_wildp -> error "U_wildp"
-      U_qual _ _ -> error "U_qual"
-      U_guard _ -> error "U_guard"
-      U_def _ -> error "U_def"
-#endif
-
--- ToDo: DPH stuff
-\end{code}
-
-Patterns: just bear in mind that lists of patterns are represented as
-a series of ``applications''.
-\begin{code}
-wlkPat pat
-  = case pat of
-      U_par pat ->  -- parenthesised pattern
-	wlkPat pat
-
-      U_as var as_pat -> -- "as" pattern
-	wlkPat as_pat	`thenUgn` \ pat ->
-	returnUgn (AsPatIn var pat)
-
-      U_lazyp lazyp -> -- irrefutable ("twiddle") pattern
-        wlkPat lazyp	`thenUgn` \ pat ->
-	returnUgn (LazyPatIn pat)
-
-      U_plusp plusn plusk -> -- n+k pattern
-        wlkPat     plusn    `thenUgn` \ pat ->
-	wlkLiteral plusk    `thenUgn` \ lit ->
-	let
-	    n = case pat of
-		  VarPatIn n -> n
-		  WildPatIn  -> error "ERROR: wlkPat: GHC can't handle _+k patterns\n"
-	in
-	returnUgn (NPlusKPatIn n lit)
-
-      U_wildp -> returnUgn WildPatIn -- wildcard pattern
-
-      --------------------------------------------------------------
-      -- now the prefix items that can either be an expression or
-      -- pattern, except we know they are *patterns* here.
-      --------------------------------------------------------------
-      U_negate nexp ->	-- negated pattern: negatee must be a literal
-        wlkPat nexp	`thenUgn` \ lit_pat ->
-	case lit_pat of
-	  LitPatIn lit -> returnUgn (LitPatIn (negLiteral lit))
-	  _	       -> panic "wlkPat: bad negated pattern!"
-
-      U_lit lit ->
-        wlkLiteral lit	`thenUgn` \ lit ->
-	returnUgn (LitPatIn lit)
-
-      U_ident n -> -- simple identifier
-	returnUgn (
-	  if isConopPN n
-	  then ConPatIn n []
-	  else VarPatIn n
-	)
-
-      U_ap l r -> -- "application": there's a list of patterns lurking here!
-        wlk_curried_pats l `thenUgn` \ (lpat:lpats) ->
-	wlkPat		 r `thenUgn` \ rpat	    ->
-	let
-	    (n, llpats)
-	      = case lpat of
-		  VarPatIn x        -> (x, [])
-		  ConPatIn x []     -> (x, [])
-		  ConOpPatIn x op y -> (op, [x, y])
-		  _ -> -- sorry about the weedy msg; the parser missed this one
-		       error (ppShow 100 (ppCat [ppStr "ERROR: an illegal `application' of a pattern to another one:", ppInterleave ppSP (map (ppr PprForUser) bad_app)]))
-
-	    arg_pats = llpats ++ lpats ++ [rpat]
-	    bad_app  = (lpat:lpats) ++ [rpat]
-	in
-	returnUgn (ConPatIn n arg_pats)
-	where
-	  wlk_curried_pats pat
-	    = case pat of
-	        U_ap l r ->
-		  wlk_curried_pats l	`thenUgn` \ lpats ->
-		  wlkPat	   r	`thenUgn` \ rpat  ->
-		  returnUgn (lpats ++ [rpat])
-		other ->
-		  wlkPat other		`thenUgn` \ pat ->
-		  returnUgn [pat]
-
-      U_tinfixop (op, arg1, arg2) ->
-	wlkPat arg1	`thenUgn` \ pat1 ->
-	wlkPat arg2	`thenUgn` \ pat2 ->
-	returnUgn (ConOpPatIn pat1 op pat2)
-
-      U_llist llist -> -- explicit list
-        wlkList rdPat llist `thenUgn` \ pats ->
-	returnUgn (ListPatIn pats)
-
-      U_tuple tuplelist -> -- explicit tuple
-        wlkList rdPat tuplelist	`thenUgn` \ pats ->
-	returnUgn (TuplePatIn pats)
-
-      -- ToDo: DPH
-\end{code}
-
-OLD, MISPLACED NOTE: The extra DPH syntax above is defined such that
-to the left of a \tr{<<-} or \tr{<<=} there has to be a processor (no
-expressions).  Therefore in the pattern matching below we are taking
-this into consideration to create the @DrawGen@ whose fields are the
-\tr{K} patterns, pat and the exp right of the generator.
-
-\begin{code}
-wlkLiteral :: U_literal -> UgnM Literal
-
-wlkLiteral ulit
-  = returnUgn (
-    case ulit of
-      U_integer    s   -> IntLit	(as_integer  s)
-      U_floatr     s   -> FracLit	(as_rational s)
-      U_intprim    s   -> IntPrimLit    (as_integer  s)
-      U_doubleprim s   -> DoublePrimLit (as_rational s)
-      U_floatprim  s   -> FloatPrimLit  (as_rational s)
-      U_charr	   s   -> CharLit	(as_char     s)
-      U_charprim   s   -> CharPrimLit   (as_char     s)
-      U_string     s   -> StringLit     (as_string   s)
-      U_stringprim s   -> StringPrimLit (as_string   s)
-      U_clitlit    s _ -> LitLitLitIn   (as_string   s)
-    )
-  where
-    as_char s     = _HEAD_ s
-    as_integer s  = readInteger (_UNPK_ s)
-    as_rational s = _readRational (_UNPK_ s) -- non-std
-    as_string s   = s
-\end{code}
-
-%************************************************************************
-%*									*
-\subsection{wlkBinding}
-%*									*
-%************************************************************************
-
-\begin{code}
-wlkBinding :: U_binding -> UgnM RdrBinding
-
-wlkBinding binding
-  = case binding of
-      U_nullbind -> -- null binding
-	returnUgn RdrNullBind
-
-      U_abind a b -> -- "and" binding (just glue, really)
-        wlkBinding a    `thenUgn` \ binding1 ->
-	wlkBinding b    `thenUgn` \ binding2 ->
-	returnUgn (RdrAndBindings binding1 binding2)
-
-      U_tbind tbindc tbindid tbindl tbindd srcline tpragma -> -- "data" declaration
-        wlkContext	   tbindc  `thenUgn` \ ctxt	    ->
-	wlkList rdU_unkId  tbindd  `thenUgn` \ derivings    ->
-	wlkTyConAndTyVars  tbindid `thenUgn` \ (tycon, tyvars) ->
-	wlkList rdConDecl  tbindl  `thenUgn` \ cons	    ->
-	wlkDataPragma	   tpragma `thenUgn` \ pragma	    ->
-	mkSrcLocUgn	   srcline `thenUgn` \ src_loc	    ->
-	returnUgn (RdrTyData (TyData ctxt tycon tyvars cons derivings pragma src_loc))
-
-      U_nbind nbindid nbindas srcline npragma -> -- "type" declaration
-        wlkTyConAndTyVars nbindid `thenUgn` \ (tycon, tyvars) ->
-	wlkMonoType	  nbindas `thenUgn` \ expansion	    ->
-	wlkTypePragma	  npragma `thenUgn` \ pragma	    ->
-	mkSrcLocUgn	  srcline `thenUgn` \ src_loc	    ->
-	returnUgn (RdrTySynonym (TySynonym tycon tyvars expansion pragma src_loc))
-
-      U_fbind fbindl srcline -> -- function binding
-        wlkList rdMatch fbindl	`thenUgn` \ matches ->
-	mkSrcLocUgn     srcline	`thenUgn` \ src_loc ->
-	returnUgn (RdrFunctionBinding srcline matches)
-
-      U_pbind pbindl srcline ->  -- pattern binding
-        wlkList rdMatch pbindl	`thenUgn` \ matches ->
-	mkSrcLocUgn     srcline	`thenUgn` \ src_loc ->
-	returnUgn (RdrPatternBinding srcline matches)
-
-      U_cbind cbindc cbindid cbindw srcline cpragma -> -- "class" declaration
-        wlkContext	 cbindc	 `thenUgn` \ ctxt	  ->
-	wlkClassAssertTy cbindid `thenUgn` \ (clas, tyvar) ->
-	wlkBinding	 cbindw	 `thenUgn` \ binding	  ->
-	wlkClassPragma   cpragma `thenUgn` \ pragma	  ->
-	mkSrcLocUgn	 srcline `thenUgn` \ src_loc	  ->
-	getSrcFileUgn		 `thenUgn` \ sf		  ->
-	let
-	    (class_sigs, class_methods) = sepDeclsIntoSigsAndBinds binding
-
-	    final_sigs    = concat (map cvClassOpSig class_sigs)
-	    final_methods = cvMonoBinds sf class_methods
-	in
-	returnUgn (RdrClassDecl
-	  (ClassDecl ctxt clas tyvar final_sigs final_methods pragma src_loc))
-
-      U_ibind ibindc clas ibindi ibindw srcline ipragma -> -- "instance" declaration
-        wlkContext	ibindc	`thenUgn` \ ctxt    ->
-	wlkMonoType	ibindi	`thenUgn` \ inst_ty ->
-	wlkBinding	ibindw	`thenUgn` \ binding ->
-	wlkInstPragma   ipragma	`thenUgn` \ (modname_maybe, pragma) ->
-	mkSrcLocUgn	srcline	`thenUgn` \ src_loc ->
-	getSrcFileUgn		`thenUgn` \ sf	    ->
-	let
-	    (ss, bs) = sepDeclsIntoSigsAndBinds binding
-	    binds    = cvMonoBinds sf bs
-	    uprags   = concat (map cvInstDeclSig ss)
-	in
-	returnUgn (
-	case modname_maybe of {
-	  Nothing ->
-	    RdrInstDecl (\ orig_mod infor_mod here ->
-		  InstDecl ctxt clas inst_ty binds here orig_mod infor_mod uprags pragma src_loc);
-	  Just orig_mod ->
-	    RdrInstDecl (\ _ infor_mod here ->
-		  InstDecl ctxt clas inst_ty binds here orig_mod infor_mod uprags pragma src_loc)
-	})
-
-      U_dbind dbindts srcline -> -- "default" declaration
-        wlkList rdMonoType dbindts  `thenUgn` \ tys ->
-	mkSrcLocUgn        srcline  `thenUgn` \ src_loc ->
-	returnUgn (RdrDefaultDecl (DefaultDecl tys src_loc))
-
-      U_mbind mod mbindimp mbindren srcline ->
-        -- "import" declaration in an interface
-	wlkList rdEntity   mbindimp	`thenUgn` \ entities  ->
-	wlkList rdRenaming mbindren	`thenUgn` \ renamings ->
-	mkSrcLocUgn	   srcline	`thenUgn` \ src_loc   ->
-	returnUgn (RdrIfaceImportDecl (IfaceImportDecl mod entities renamings src_loc))
-
-      a_sig_we_hope ->
-        -- signature(-like) things, including user pragmas
-	wlk_sig_thing a_sig_we_hope
-\end{code}
-
-ToDo: really needed as separate?
-\begin{code}
-wlk_sig_thing (U_sbind sbindids sbindid srcline spragma)  -- type signature
-  = wlkList rdU_unkId	sbindids `thenUgn` \ vars    ->
-    wlkPolyType		sbindid  `thenUgn` \ poly_ty ->
-    wlkTySigPragmas	spragma  `thenUgn` \ pragma  ->
-    mkSrcLocUgn		srcline  `thenUgn` \ src_loc ->
-    returnUgn (RdrTySig vars poly_ty pragma src_loc)
-
-wlk_sig_thing (U_vspec_uprag var vspec_tys srcline) -- value specialisation user-pragma
-  = wlkList rd_ty_and_id vspec_tys `thenUgn` \ tys_and_ids ->
-    mkSrcLocUgn	         srcline   `thenUgn` \ src_loc ->
-    returnUgn (RdrSpecValSig [SpecSig var ty using_id src_loc
-			     | (ty, using_id) <- tys_and_ids ])
-  where
-    rd_ty_and_id :: ParseTree -> UgnM (ProtoNamePolyType, Maybe ProtoName)
-    rd_ty_and_id pt
-      = rdU_binding pt			`thenUgn` \ (U_vspec_ty_and_id vspec_ty vspec_id) ->
-	wlkPolyType vspec_ty		`thenUgn` \ ty	    ->
-	wlkList rdU_unkId vspec_id	`thenUgn` \ id_list ->
-	returnUgn(ty, case id_list of { []  -> Nothing; [x] -> Just x })
-
-wlk_sig_thing (U_ispec_uprag clas ispec_ty srcline)-- instance specialisation user-pragma
-  = wlkMonoType	    ispec_ty	`thenUgn` \ ty	    ->
-    mkSrcLocUgn	    srcline	`thenUgn` \ src_loc ->
-    returnUgn (RdrSpecInstSig (InstSpecSig clas ty src_loc))
-
-wlk_sig_thing (U_inline_uprag var inline_howto srcline) -- value inlining user-pragma
-  = wlkList rdU_stringId inline_howto `thenUgn` \ howto	 ->
-    mkSrcLocUgn		 srcline      `thenUgn` \ src_loc ->
-    let
-	guidance -- ToDo: use Maybe type
-	  = (case howto of {
-	      []  -> id;
-	      [x] -> trace "ignoring unfold howto" }) UnfoldAlways
-    in
-    returnUgn (RdrInlineValSig (InlineSig var guidance src_loc))
-
-wlk_sig_thing (U_deforest_uprag var srcline) -- "deforest me" user-pragma
-  = mkSrcLocUgn srcline	     `thenUgn` \ src_loc ->
-    returnUgn (RdrDeforestSig (DeforestSig var src_loc))
-
-wlk_sig_thing (U_magicuf_uprag var str srcline) -- "magic" unfolding user-pragma
-  = mkSrcLocUgn srcline	     `thenUgn` \ src_loc ->
-    returnUgn (RdrMagicUnfoldingSig (MagicUnfoldingSig var str src_loc))
-
-wlk_sig_thing (U_abstract_uprag tycon srcline) -- abstract-type-synonym user-pragma
-  = mkSrcLocUgn srcline	     `thenUgn` \ src_loc ->
-    returnUgn (RdrAbstractTypeSig (AbstractTypeSig tycon src_loc))
-
-wlk_sig_thing (U_dspec_uprag tycon dspec_tys srcline)
-  = mkSrcLocUgn srcline		 `thenUgn` \ src_loc ->
-    wlkList rdMonoType dspec_tys `thenUgn` \ tys ->
-    let
-	spec_ty = MonoTyCon tycon tys
-    in
-    returnUgn (RdrSpecDataSig (SpecDataSig tycon spec_ty src_loc))
-\end{code}
-
-%************************************************************************
-%*									*
-\subsection[wlkTypes]{Reading in types in various forms (and data constructors)}
-%*									*
-%************************************************************************
-
-\begin{code}
-rdPolyType :: ParseTree -> UgnM ProtoNamePolyType
-rdMonoType :: ParseTree -> UgnM ProtoNameMonoType
-
-rdPolyType pt = rdU_ttype pt `thenUgn` \ ttype -> wlkPolyType ttype
-rdMonoType pt = rdU_ttype pt `thenUgn` \ ttype -> wlkMonoType ttype
-
-wlkPolyType :: U_ttype -> UgnM ProtoNamePolyType
-wlkMonoType :: U_ttype -> UgnM ProtoNameMonoType
-
-wlkPolyType ttype
-  = case ttype of
-      U_context tcontextl tcontextt -> -- context
-	wlkContext  tcontextl	`thenUgn` \ ctxt ->
-	wlkMonoType tcontextt	`thenUgn` \ ty	 ->
-	returnUgn (OverloadedTy ctxt ty)
-
-      U_uniforall utvs uty -> -- forall type (pragmas)
-        wlkList rdU_unkId utvs  `thenUgn` \ tvs ->
-	wlkMonoType       uty	`thenUgn` \ ty  ->
-	returnUgn (ForAllTy tvs ty)
-
-      other -> -- something else
-        wlkMonoType other   `thenUgn` \ ty ->
-	returnUgn (UnoverloadedTy ty)
-
-wlkMonoType ttype
-  = case ttype of
-      U_tname tycon typel -> -- tycon
-	wlkList rdMonoType typel `thenUgn` \ tys ->
-	returnUgn (MonoTyCon tycon tys)
-
-      U_tllist tlist -> -- list type
-        wlkMonoType tlist	`thenUgn` \ ty ->
-	returnUgn (ListMonoTy ty)
-
-      U_ttuple ttuple ->
-        wlkList rdPolyType ttuple `thenUgn` \ tys ->
-	returnUgn (TupleMonoTy tys)
-
-      U_tfun tfun targ ->
-        wlkMonoType tfun	`thenUgn` \ ty1 ->
-	wlkMonoType targ	`thenUgn` \ ty2 ->
-	returnUgn (FunMonoTy ty1 ty2)
-
-      U_namedtvar tyvar -> -- type variable
-	returnUgn (MonoTyVar tyvar)
-
-      U_unidict clas t -> -- UniDict (pragmas)
-	wlkMonoType t	`thenUgn` \ ty	 ->
-	returnUgn (MonoDict clas ty)
-
-      U_unityvartemplate tv_tmpl -> -- pragmas only
-	returnUgn (MonoTyVarTemplate tv_tmpl)
-
-#ifdef DPH
-wlkMonoType ('v' : xs)
-  = wlkMonoType xs	    `thenUgn` \ (ty, xs1) ->
-    returnUgn (RdrExplicitPodTy ty, xs1)
-    BEND
-
-wlkMonoType ('u' : xs)
-  = wlkList rdMonoType xs `thenUgn` \ (tys, xs1) ->
-    wlkMonoType xs1	`thenUgn` \ (ty,  xs2)  ->
-    returnUgn (RdrExplicitProcessorTy tys ty, xs2)
-    BEND BEND
-#endif {- Data Parallel Haskell -}
-
---wlkMonoType oops = panic ("wlkMonoType:"++oops)
-\end{code}
-
-\begin{code}
-wlkTyConAndTyVars :: U_ttype -> UgnM (ProtoName, [ProtoName])
-wlkContext   	  :: U_list  -> UgnM ProtoNameContext
-wlkClassAssertTy  :: U_ttype -> UgnM (ProtoName, ProtoName)
-
-wlkTyConAndTyVars ttype
-  = wlkMonoType ttype	`thenUgn` \ (MonoTyCon tycon ty_args) ->
-    let
-	args = [ a | (MonoTyVar a) <- ty_args ]
-    in
-    returnUgn (tycon, args)
-
-wlkContext list
-  = wlkList rdMonoType list `thenUgn` \ tys ->
-    returnUgn (map mk_class_assertion tys)
-
-wlkClassAssertTy xs
-  = wlkMonoType xs   `thenUgn` \ mono_ty ->
-    returnUgn (mk_class_assertion mono_ty)
-
-mk_class_assertion :: ProtoNameMonoType -> (ProtoName, ProtoName)
-
-mk_class_assertion (MonoTyCon name [(MonoTyVar tyname)]) = (name, tyname)
-mk_class_assertion other
-  = error ("ERROR: malformed type context: "++ppShow 80 (ppr PprForUser other)++"\n")
-    -- regrettably, the parser does let some junk past
-    -- e.g., f :: Num {-nothing-} => a -> ...
-\end{code}
-
-\begin{code}
-rdConDecl :: ParseTree -> UgnM ProtoNameConDecl
-
-rdConDecl pt
-  = rdU_atype pt    `thenUgn` \ (U_atc con atctypel srcline) ->
-
-    mkSrcLocUgn srcline		`thenUgn` \ src_loc ->
-    wlkList rdMonoType atctypel	`thenUgn` \ tys	    ->
-    returnUgn (ConDecl con tys src_loc)
-\end{code}
-
-%************************************************************************
-%*									*
-\subsection{Read a ``match''}
-%*									*
-%************************************************************************
-
-\begin{code}
-rdMatch :: ParseTree -> UgnM RdrMatch
-
-rdMatch pt
-  = rdU_pbinding pt	`thenUgn` \ (U_pgrhs gpat gdexprs gbind srcfun srcline) ->
-
-    mkSrcLocUgn		srcline	`thenUgn` \ src_loc ->
-    wlkPat		gpat	`thenUgn` \ pat     ->
-    wlkList rd_guarded	gdexprs	`thenUgn` \ grhss   ->
-    wlkBinding		gbind	`thenUgn` \ binding ->
-
-    returnUgn (RdrMatch srcline srcfun pat grhss binding)
-  where
-    rd_guarded pt
-      = rdU_list pt	    `thenUgn` \ list ->
-	wlkList rdExpr list `thenUgn` \ [g,e] ->
-	returnUgn (g, e)
-\end{code}
-
-%************************************************************************
-%*									*
-\subsection[wlkFixity]{Read in a fixity declaration}
-%*									*
-%************************************************************************
-
-\begin{code}
-{-
-wlkFixity :: ParseTree -> UgnM ProtoNameFixityDecl
-
-wlkFixity pt
-  = wlkId	   xs	`thenUgn` \ (op,	     xs1) ->
-    wlkIdString xs1	`thenUgn` \ (associativity, xs2) ->
-    wlkIdString xs2	`thenUgn` \ (prec_str,	     xs3) ->
-    let
-	precedence = read prec_str
-    in
-    case associativity of {
-      "infix"  -> returnUgn (InfixN op precedence, xs3);
-      "infixl" -> returnUgn (InfixL op precedence, xs3);
-      "infixr" -> returnUgn (InfixR op precedence, xs3)
-    } BEND BEND BEND
--}
-\end{code}
-
-%************************************************************************
-%*									*
-\subsection[rdImportedInterface]{Read an imported interface}
-%*									*
-%************************************************************************
-
-\begin{code}
-rdImportedInterface :: ParseTree
-		    -> UgnM ProtoNameImportedInterface
-
-rdImportedInterface pt
-  = grab_pieces pt  `thenUgn`
-	\ (expose_or_hide,
-	   modname,
-	   bindexp,
-	   bindren,
-	   binddef,
-	   bindfile,
-	   srcline) ->
-
-    mkSrcLocUgn		srcline `thenUgn` \ src_loc   ->
-    wlkList rdEntity	bindexp `thenUgn` \ imports   ->
-    wlkList rdRenaming	bindren `thenUgn` \ renamings ->
-
-    setSrcFileUgn bindfile ( -- OK, we're now looking inside the .hi file...
-	wlkBinding binddef
-    )				`thenUgn` \ iface_bs  ->
-
-    case (sepDeclsForInterface iface_bs) of {
-		(tydecls,classdecls,instdecls,sigs,iimpdecls) ->
-    let
-	cv_iface
-	  = MkInterface	modname
-		iimpdecls
-		[{-fixity decls-}]  -- can't get fixity decls in here yet (ToDo)
-		tydecls
-		classdecls
-		(cvInstDecls False SLIT(""){-probably superceded by modname < pragmas-}
-				   modname instdecls)
-			    -- False indicates imported
-		(concat (map cvValSig sigs))
-		src_loc -- OLD: (mkSrcLoc importing_srcfile srcline)
-    in
-    returnUgn (
-     if null imports then
-	ImportAll cv_iface renamings
-     else
-	expose_or_hide cv_iface imports renamings
-    )}
-  where
-    grab_pieces pt
-      = rdU_binding pt `thenUgn` \ binding ->
-	returnUgn (
-        case binding of
-	  U_import a b c d e f -> (ImportSome,    a, b, c, d, e, f)
-	  U_hiding a b c d e f -> (ImportButHide, a, b, c, d, e, f)
-	)
-\end{code}
-
-\begin{code}
-rdRenaming :: ParseTree -> UgnM Renaming
-
-rdRenaming pt
-  = rdU_list 		 pt	`thenUgn` \ list ->
-    wlkList rdU_stringId list	`thenUgn` \ [id1, id2] ->
-    returnUgn (MkRenaming id1 id2)
-\end{code}
-
-\begin{code}
-rdEntity :: ParseTree -> UgnM IE
-
-rdEntity pt
-  = rdU_entidt pt   `thenUgn` \ entity ->
-    case entity of
-      U_entid var -> -- just a value
-	returnUgn (IEVar var)
-
-      U_enttype thing -> -- abstract type constructor/class
-	returnUgn (IEThingAbs thing)
-
-      U_enttypeall thing -> -- non-abstract type constructor/class
-	returnUgn (IEThingAll thing)
-
-      U_enttypecons tycon ctentcons -> -- type con w/ data cons listed
-	wlkList rdU_stringId   ctentcons   `thenUgn` \ cons  ->
-	returnUgn (IEConWithCons tycon cons)
-
-      U_entclass clas centops -> -- class with ops listed
-	wlkList rdU_stringId   centops	`thenUgn` \ ops ->
-	returnUgn (IEClsWithOps clas ops)
-
-      U_entmod mod -> -- everything provided by a module
-	returnUgn (IEModuleContents mod)
-\end{code}
diff --git a/ghc/compiler/rename/Rename.hi b/ghc/compiler/rename/Rename.hi
deleted file mode 100644
index 5529665937..0000000000
--- a/ghc/compiler/rename/Rename.hi
+++ /dev/null
@@ -1,43 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface Rename where
-import AbsSyn(Module)
-import Bag(Bag)
-import CmdLineOpts(GlobalSwitch)
-import ErrUtils(Error(..))
-import HsBinds(Binds, Sig)
-import HsDecls(ClassDecl, DataTypeSig, DefaultDecl, FixityDecl, InstDecl, SpecialisedInstanceSig, TyDecl)
-import HsImpExp(IE, ImportedInterface)
-import HsLit(Literal)
-import HsPat(InPat, ProtoNamePat(..), RenamedPat(..))
-import Id(Id)
-import Maybes(Labda)
-import Name(Name)
-import NameTypes(FullName, ShortName)
-import PreludePS(_PackedString)
-import Pretty(PprStyle, Pretty(..), PrettyRep)
-import ProtoName(ProtoName)
-import RenameAuxFuns(GlobalNameFun(..), GlobalNameFuns(..), PreludeNameFun(..), PreludeNameFuns(..))
-import SplitUniq(SplitUniqSupply)
-import SrcLoc(SrcLoc)
-import TyCon(TyCon)
-import Unique(Unique)
-data Module a b 
-data Bag a 
-data GlobalSwitch 
-type Error = PprStyle -> Int -> Bool -> PrettyRep
-data InPat a 
-type ProtoNamePat = InPat ProtoName
-type RenamedPat = InPat Name
-data Labda a 
-data Name 
-data PprStyle 
-type Pretty = Int -> Bool -> PrettyRep
-data PrettyRep 
-data ProtoName 
-type GlobalNameFun = ProtoName -> Labda Name
-type GlobalNameFuns = (ProtoName -> Labda Name, ProtoName -> Labda Name)
-type PreludeNameFun = _PackedString -> Labda Name
-type PreludeNameFuns = (_PackedString -> Labda Name, _PackedString -> Labda Name)
-data SplitUniqSupply 
-renameModule :: (GlobalSwitch -> Bool) -> (_PackedString -> Labda Name, _PackedString -> Labda Name) -> Module ProtoName (InPat ProtoName) -> SplitUniqSupply -> (Module Name (InPat Name), [_PackedString], (ProtoName -> Labda Name, ProtoName -> Labda Name), Bag (PprStyle -> Int -> Bool -> PrettyRep))
-
diff --git a/ghc/compiler/rename/Rename.lhs b/ghc/compiler/rename/Rename.lhs
index a2900c7671..3b7cdf2c86 100644
--- a/ghc/compiler/rename/Rename.lhs
+++ b/ghc/compiler/rename/Rename.lhs
@@ -1,39 +1,37 @@
 %
-% (c) The GRASP Project, Glasgow University, 1992-1994
+% (c) The GRASP Project, Glasgow University, 1992-1996
 %
 \section[Rename]{Renaming and dependency analysis passes}
 
 \begin{code}
 #include "HsVersions.h"
 
-module Rename (
-	renameModule,
-
-	-- for completeness
-	Module, Bag, InPat, ProtoNamePat(..), RenamedPat(..), Name,
-	ProtoName, SplitUniqSupply, PreludeNameFun(..),
-	PreludeNameFuns(..), Maybe, Error(..), Pretty(..), PprStyle,
-	PrettyRep, GlobalNameFuns(..), GlobalNameFun(..),
-	GlobalSwitch
-    ) where
-
-import AbsSyn
-import Bag		( isEmptyBag, unionBags, Bag )
-import CmdLineOpts	( GlobalSwitch(..) )
-import RenameMonad12
-import Rename1
-import Rename2
-import Rename3
-import Rename4
-import RenameAuxFuns	( PreludeNameFuns(..), GlobalNameFuns(..) )
---import Pretty		-- ToDo: rm debugging
-import SplitUniq	( splitUniqSupply, SplitUniqSupply )
-import Util
+module Rename ( renameModule ) where
+
+import Ubiq{-uitous-}
+
+import HsSyn
+import RdrHsSyn		( ProtoNameHsModule(..) )
+import RnHsSyn		( RenamedHsModule(..) )
+
+import Bag		( isEmptyBag, unionBags )
+import CmdLineOpts	( opt_UseGetMentionedVars )
+import ErrUtils		( Error(..) )
+import Pretty		( Pretty(..){-ToDo:rm?-} )
+import RnMonad12	( initRn12 )
+import RnMonad4		( initRn4 )
+import RnPass1
+import RnPass2
+import RnPass3
+import RnPass4
+import RnUtils		( PreludeNameMappers(..), GlobalNameMappers(..) )
+import UniqSupply	( splitUniqSupply )
+import Util		( panic )
 \end{code}
 
 Here's what the renamer does, basically:
 \begin{description}
-\item[@Rename1@:]
+\item[@RnPass1@:]
 Flattens out the declarations from the interfaces which this module
 imports.  The result is a new module with no imports, but with more
 declarations.  (Obviously, the imported declarations have ``funny
@@ -41,7 +39,7 @@ names'' [@ProtoNames@] to indicate their origin.)  Handles selective
 import, renaming, \& such.
 
 %--------------------------------------------------------------------
-\item[@Rename2@:]
+\item[@RnPass2@:]
 Removes duplicate declarations.  Duplicates can arise when two
 imported interface have a signature (or whatever) for the same
 thing. We check that the two are consistent and then drop one.
@@ -49,13 +47,13 @@ Considerable huff and puff to pick the one with the ``better''
 pragmatic information.
 
 %--------------------------------------------------------------------
-\item[@Rename3@:]
+\item[@RnPass3@:]
 Find all the top-level-ish (i.e., global) entities, assign them
 @Uniques@, and make a \tr{ProtoName -> Name} mapping for them,
 in preparation for...
 
 %--------------------------------------------------------------------
-\item[@Rename4@:]
+\item[@RnPass4@:]
 Actually prepare the ``renamed'' module.  In sticking @Names@ on
 everything, it will catch out-of-scope errors (and a couple of similar
 type-variable-use errors).  We also our initial dependency analysis of
@@ -63,14 +61,13 @@ the program (required before typechecking).
 \end{description}
 
 \begin{code}
-renameModule :: (GlobalSwitch -> Bool)	-- to check cmd-line opts
-	     -> PreludeNameFuns		-- lookup funs for deeply wired-in names
-	     -> ProtoNameModule		-- input
-	     -> SplitUniqSupply
-	     -> (RenamedModule,		-- output, after renaming
-		 [FAST_STRING],		-- Names of the imported modules
+renameModule :: PreludeNameMappers	-- lookup funs for deeply wired-in names
+	     -> ProtoNameHsModule	-- input
+	     -> UniqSupply
+	     -> (RenamedHsModule,	-- output, after renaming
+		 Bag FAST_STRING,	-- Names of the imported modules
 					-- (profiling needs to know this)
-		 GlobalNameFuns,	-- final name funs; used later
+		 GlobalNameMappers,	-- final name funs; used later
 					-- to rename generated `deriving'
 					-- bindings.
 		 Bag Error		-- Errors, from passes 1-4
@@ -78,33 +75,21 @@ renameModule :: (GlobalSwitch -> Bool)	-- to check cmd-line opts
 
 -- Very space-leak sensitive
 
-renameModule sw_chkr gnfs@(val_pnf, tc_pnf)
-	     input@(Module mod_name _ _ _ _ _ _ _ _ _ _ _ _)
+renameModule gnfs@(val_pnf, tc_pnf)
+	     input@(HsModule mod_name _ _ _ _ _ _ _ _ _ _ _ _)
 	     uniqs
   = let
-	use_mentioned_vars = sw_chkr UseGetMentionedVars
+	use_mentioned_vars = opt_UseGetMentionedVars
     in
-    BIND (
-    BSCC("Rename1")
-    initRn12 mod_name (rnModule1 gnfs use_mentioned_vars input)
-    ESCC
-    )		_TO_ ((mod1, imported_module_names), errs1) ->
+    case (initRn12 mod_name (rnModule1 gnfs use_mentioned_vars input))
+      of { ((mod1, imported_module_names), errs1) ->
 
-    BIND (
-    BSCC("Rename2")
-    initRn12 mod_name (rnModule2 mod1)
-    ESCC
-    )		_TO_ (mod2, errs2) ->
+    case (initRn12 mod_name (rnModule2 mod1)) of { (mod2, errs2) ->
 
---  pprTrace "rename2:" (ppr PprDebug mod2) (
+    case (splitUniqSupply uniqs) of { (us1, us2) ->
 
-    BIND (splitUniqSupply uniqs) _TO_ (us1, us2) ->
-
-    BIND (
-    BSCC("Rename3")
-    initRn3 (rnModule3 gnfs imported_module_names mod2) us1
-    ESCC
-    )		_TO_ (val_space, tc_space, v_gnf, tc_gnf, errs3) ->
+    case (initRn3 (rnModule3 gnfs imported_module_names mod2) us1)
+      of { (val_space, tc_space, v_gnf, tc_gnf, errs3) ->
 
     let
 	final_name_funs = (v_gnf, tc_gnf)
@@ -115,19 +100,11 @@ renameModule sw_chkr gnfs@(val_pnf, tc_pnf)
     if not (isEmptyBag errs_so_far) then -- give up now
 	( panic "rename", imported_module_names, final_name_funs, errs_so_far )
     else
-	BIND (
-	BSCC("Rename4")
-	initRn4 sw_chkr final_name_funs (rnModule4 mod2) us2
-	ESCC
-	)		_TO_ (mod4, errs4) ->
-
-	( mod4, imported_module_names, final_name_funs, errs4 )
-	BEND
-    BEND
---  )
-    BEND
-    BEND
-    BEND
+	case (initRn4 final_name_funs (rnModule mod2) us2)
+	  of { (mod4, errs4) ->
+
+	( mod4, imported_module_names, final_name_funs, errs4 ) }
+    }}}}
 \end{code}
 
 Why stop if errors in the first three passes: Suppose you're compiling
@@ -142,4 +119,4 @@ panic.
 
 Another way to handle this would be for the duplicate detector to
 clobber duplicates with some ``safe'' value.  Then things would be
-fine in \tr{rnModule4}.  Maybe some other time...
+fine in \tr{rnModule}.  Maybe some other time...
diff --git a/ghc/compiler/rename/Rename1.hi b/ghc/compiler/rename/Rename1.hi
deleted file mode 100644
index 808dd8b1c6..0000000000
--- a/ghc/compiler/rename/Rename1.hi
+++ /dev/null
@@ -1,36 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface Rename1 where
-import AbsSyn(Module)
-import Bag(Bag)
-import CharSeq(CSeq)
-import CmdLineOpts(GlobalSwitch)
-import HsBinds(Binds, Sig)
-import HsDecls(ClassDecl, DataTypeSig, DefaultDecl, FixityDecl, InstDecl, SpecialisedInstanceSig, TyDecl)
-import HsImpExp(IE, ImportedInterface)
-import HsLit(Literal)
-import HsPat(InPat, ProtoNamePat(..))
-import Id(Id)
-import Maybes(Labda)
-import Name(Name)
-import NameTypes(FullName, ShortName)
-import PreludePS(_PackedString)
-import Pretty(Delay, PprStyle, Pretty(..), PrettyRep)
-import ProtoName(ProtoName)
-import RenameAuxFuns(PreludeNameFun(..), PreludeNameFuns(..))
-import SrcLoc(SrcLoc)
-import TyCon(TyCon)
-import Unique(Unique)
-data Module a b 
-data Bag a 
-data InPat a 
-type ProtoNamePat = InPat ProtoName
-data Labda a 
-data Name 
-data PprStyle 
-type Pretty = Int -> Bool -> PrettyRep
-data PrettyRep 
-data ProtoName 
-type PreludeNameFun = _PackedString -> Labda Name
-type PreludeNameFuns = (_PackedString -> Labda Name, _PackedString -> Labda Name)
-rnModule1 :: (_PackedString -> Labda Name, _PackedString -> Labda Name) -> Bool -> Module ProtoName (InPat ProtoName) -> _PackedString -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> ((Module ProtoName (InPat ProtoName), [_PackedString]), Bag (PprStyle -> Int -> Bool -> PrettyRep))
-
diff --git a/ghc/compiler/rename/Rename1.lhs b/ghc/compiler/rename/Rename1.lhs
deleted file mode 100644
index 80f56d7ff0..0000000000
--- a/ghc/compiler/rename/Rename1.lhs
+++ /dev/null
@@ -1,901 +0,0 @@
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
-%
-\section[Rename1]{@Rename1@: gather up imported information}
-
-See the @Rename@ module for a basic description of the renamer.
-
-\begin{code}
-#include "HsVersions.h"
-
-module Rename1 (
-	rnModule1,
-
-	-- for completeness
-	Module, Bag, ProtoNamePat(..), InPat, Maybe,
-	PprStyle, Pretty(..), PrettyRep, ProtoName, Name,
-	PreludeNameFun(..), PreludeNameFuns(..)
-    ) where
-
-IMPORT_Trace		-- ToDo: rm
-import Pretty		-- these two too
-import Outputable
-
-import AbsSyn
-import AbsSynFuns	( getMentionedVars ) -- *** not via AbsSyn ***
-import Bag		( Bag, emptyBag, unitBag, snocBag, unionBags, bagToList )
-import Errors
-import HsPragmas
-import FiniteMap
-import Maybes		( maybeToBool, catMaybes, Maybe(..) )
---OLD: import NameEnv	( mkStringLookupFn )
-import ProtoName	( ProtoName(..), mkPreludeProtoName )
-import RenameAuxFuns
-import RenameMonad12
-import Util
-\end{code}
-
-
-%************************************************************************
-%*									*
-\subsection{Types and things used herein}
-%*									*
-%************************************************************************
-
-@AllIntDecls@ is the type returned from processing import statement(s)
-in the main module.
-
-\begin{code}
-type AllIntDecls = ([ProtoNameFixityDecl], [ProtoNameTyDecl],
-		    [ProtoNameClassDecl],  [ProtoNameInstDecl],
-		    [ProtoNameSig], Bag FAST_STRING)
-\end{code}
-
-The selective-import function @SelectiveImporter@ maps a @ProtoName@
-to something which indicates how much of the thing, if anything, is
-wanted by the importing module.
-\begin{code}
-type SelectiveImporter = ProtoName -> Wantedness
-
-data Wantedness
-  = Wanted
-  | NotWanted
-  | WantedWith IE
-\end{code}
-
-The @ProtoNames@ supplied to these ``name functions'' are always
-@Unks@, unless they are fully-qualified names, which occur only in
-interface pragmas (and, therefore, never on the {\em definitions} of
-things).  That doesn't happen in @Rename1@!
-\begin{code}
-type IntNameFun	  = ProtoName -> ProtoName
-type IntTCNameFun = ProtoName -> (ProtoName, IntNameFun)
-\end{code}
-
-%************************************************************************
-%*									*
-\subsection{First pass over the entire module}
-%*									*
-%************************************************************************
-
-This pass flattens out the declarations embedded within the interfaces
-which this module imports.  The result is a new module with no
-imports, but with more declarations.  The declarations which arose
-from the imported interfaces will have @ProtoNames@ with @Imp@
-constructors; the declarations in the body of this module are
-unaffected, so they will still be @Unk@'s.
-
-We import only the declarations from interfaces which are actually {\em
-used}.  This saves time later, because we don't need process the
-unused ones.
-
-\begin{code}
-rnModule1 :: PreludeNameFuns
-	  -> Bool		-- see use below
-	  -> ProtoNameModule
-	  -> Rn12M (ProtoNameModule, [FAST_STRING])
-
-rnModule1 pnf@(v_pnf, tc_pnf)
-	use_mentioned_vars_heuristic
-	(Module mod_name exports imports fixes
-		ty_decls absty_sigs class_decls inst_decls specinst_sigs
-		defaults binds _ src_loc)
-
-  =	-- slurp through the *body* of the module, collecting names of
-	-- mentioned *variables*, 3+ letters long & not prelude names.
-	-- Note: we *do* have to pick up top-level binders,
-	-- so we can check for conflicts with imported guys!
-    let
-{- OLD:MENTIONED-}
-	(uses_Mdotdot_in_exports, mentioned_vars)
-	  = getMentionedVars v_pnf exports fixes class_decls inst_decls binds
-
-	-- Using the collected "mentioned" variables, create an
-	-- "is-mentioned" function (:: FAST_STRING -> Bool), which gives
-	-- True if something is mentioned is in the list collected.
-	-- For more details, see under @selectAll@, notably the
-	-- handling of short (< 3 chars) names.
-
-	-- Note: this "is_mentioned" game doesn't work if the export
-	-- list includes any M.. constructs (because that mentions
-	-- variables *implicitly*, basically).  getMentionedVars tells
-	-- us this, and we act accordingly.
-
-	is_mentioned_maybe
-	  = lookupFM {-OLD: mkStringLookupFn-} (listToFM
-		[ (x, panic "is_mentioned_fn")
-		| x <- mentioned_vars ++ needed_for_deriving ]
-		)
-		-- OLD: False{-not-sorted-}
-	  where
-	    needed_for_deriving	-- is this a HACK or what?
-	      = [ SLIT("&&"),
-		  SLIT("."),
-		  SLIT("lex"),
-		  SLIT("map"),
-		  SLIT("not"),
-		  SLIT("readParen"),
-		  SLIT("showParen"),
-		  SLIT("showSpace__"),
-		  SLIT("showString")
-		]
-
-	is_mentioned_fn
-	  = if use_mentioned_vars_heuristic
-	    && not (uses_Mdotdot_in_exports)
-	    then \ x -> maybeToBool (is_mentioned_maybe x)
-	    else \ x -> True
-{- OLD:MENTIONED-}
---O:M	is_mentioned_fn = \ x -> True -- ToDo: delete altogether
-    in
-	-- OK, now do the business:
-    doImportedIfaces pnf is_mentioned_fn imports
-		 `thenRn12`  \ (int_fixes, int_ty_decls,
-				int_class_decls, int_inst_decls,
-				int_sigs, import_names) ->
-    let
-	inst_decls' = doRevoltingInstDecls tc_nf inst_decls
-    in
-    returnRn12
-	 ((Module mod_name
-		exports imports -- passed along mostly for later checking
-		(int_fixes	  ++ fixes)
-		(int_ty_decls	  ++ ty_decls)
-		absty_sigs
-		(int_class_decls ++ class_decls)
-		(int_inst_decls  ++ inst_decls')
-		specinst_sigs
-		defaults
-		binds
-		int_sigs
-		src_loc),
-	  bagToList import_names)
-  where
-    -- This function just spots prelude names
-    tc_nf pname@(Unk s) = case (tc_pnf s) of
-			   Nothing   -> pname
-			   Just name -> Prel name
-
-    tc_nf other_pname	= panic "In tc_nf passed to doRevoltingInstDecls"
-	-- The only place where Imps occur is on Ids in unfoldings;
-	-- this function is only used on type-things.
-\end{code}
-
-Instance declarations in the module itself are treated in a horribly
-special way.  Because their class name and type constructor will be
-compared against imported ones in the second pass (to eliminate
-duplicate instance decls) we need to make Prelude classes and tycons
-appear as such.  (For class and type decls, the module can't be
-declaring a prelude class or tycon, so Prel and Unk things can just
-compare non-equal.)  This is a HACK.
-
-\begin{code}
-doRevoltingInstDecls :: IntNameFun -> [ProtoNameInstDecl] -> [ProtoNameInstDecl]
-
-doRevoltingInstDecls tc_nf decls
-  = map revolt_me decls
-  where
-    revolt_me (InstDecl context cname ty binds True modname imod uprags pragma src_loc)
-      = InstDecl
-	    context			-- Context unchanged
-	    (tc_nf cname)		-- Look up the class
-	    (doIfaceMonoType1 tc_nf ty)	-- Ditto the type
-	    binds			-- Binds unchanged
-	    True
-	    modname
-	    imod
-	    uprags
-	    pragma
-	    src_loc
-\end{code}
-
-%************************************************************************
-%*									*
-\subsection{Process a module's imported interfaces}
-%*									*
-%************************************************************************
-
-@doImportedIfaces@ processes the entire set of interfaces imported by the
-module being renamed.
-
-\begin{code}
-doImportedIfaces :: PreludeNameFuns
-	      -> (FAST_STRING -> Bool)
-	      -> [ProtoNameImportedInterface]
-	      -> Rn12M AllIntDecls
-
-doImportedIfaces pnfs is_mentioned_fn []
-  = returnRn12 ( [{-fixities-}],  [{-tydecls-}], [{-clasdecls-}],
-		 [{-instdecls-}], [{-sigs-}], emptyBag )
-
-doImportedIfaces pnfs is_mentioned_fn (iface:ifaces)
-  = doOneIface  pnfs is_mentioned_fn iface
-			 `thenRn12` \ (ifixes1, itd1, icd1, iid1, isd1, names1) ->
-
-    doImportedIfaces pnfs is_mentioned_fn ifaces
-			 `thenRn12` \ (ifixes2, itd2, icd2, iid2, isd2, names2) ->
-
-    returnRn12 (ifixes1 ++ ifixes2,
-		itd1 ++ itd2,
-		icd1 ++ icd2,
-		iid1 ++ iid2,
-		isd1 ++ isd2,
-		names1 `unionBags` names2)
-\end{code}
-
-\begin{code}
-doOneIface pnfs is_mentioned_fn (ImportAll int renamings)
-  = let
-	renaming_fn = mkRenamingFun renamings
-	-- if there are any renamings, then we don't use
-	-- the "is_mentioned_fn" hack; possibly dangerous (paranoia reigns)
-	revised_is_mentioned_fn
-	  = if null renamings
-	    then is_mentioned_fn
-	    else (\ x -> True) -- pretend everything is mentioned
-    in
---  pprTrace "ImportAll:mod_rns:" (ppr PprDebug renamings) (
-    doIface1 renaming_fn pnfs (selectAll renaming_fn revised_is_mentioned_fn) int
---  )
-
-doOneIface pnfs unused_is_mentioned_fn (ImportSome int ie_list renamings)
-  = --pprTrace "ImportSome:mod_rns:" (ppr PprDebug renamings) (
-    doIface1 (mkRenamingFun renamings) pnfs si_fun int
-    --)
-  where
-    -- the `selective import' function should not be applied
-    -- to the Imps that occur on Ids in unfoldings.
-
-    si_fun (Unk str) = check_ie str ie_list
-    si_fun other     = panic "si_fun in doOneIface"
-
-    check_ie name [] = NotWanted
-    check_ie name (ie:ies)
-      = case ie of
-	      IEVar n		  | name == n -> Wanted
-	      IEThingAbs n	  | name == n -> WantedWith ie
-	      IEThingAll n	  | name == n -> WantedWith ie
-	      IEConWithCons n ns  | name == n -> WantedWith ie
-	      IEClsWithOps n ns	  | name == n -> WantedWith ie
-	      IEModuleContents _	      -> panic "Module.. in import list?"
-	      other			      -> check_ie name ies
-
-doOneIface pnfs unused_is_mentioned_fn (ImportButHide int ie_list renamings)
-  = --pprTrace "ImportButHide:mod_rns:" (ppr PprDebug renamings) (
-    doIface1 (mkRenamingFun renamings) pnfs si_fun int
-    --)
-  where
-    -- see comment above:
-
-    si_fun (Unk str) | str `elemFM` entity_info = NotWanted
-		     | otherwise		= Wanted
-
-    entity_info = fst (getIEStrings ie_list)
-\end{code}
-
-@selectAll@ ``normally'' creates an @SelectiveImporter@ that declares
-everything from an interface to be @Wanted@.  We may, however, pass
-in a more discriminating @is_mentioned_fn@ (returns @True@ if the
-named entity is mentioned in the body of the module in question), which
-can be used to trim off junk from an interface.
-
-For @selectAll@ to say something is @NotWanted@, it must be a
-variable, it must not be in the collected-up list of mentioned
-variables (checked with @is_mentioned_fn@), and it must be three chars
-or longer.
-
-And, of course, we mustn't forget to take account of renaming!
-
-ADR Question: What's so magical about names longer than 3 characters?
-Why would we want to keep long names which aren't mentioned when we're
-quite happy to throw away short names that aren't mentioned?
-
-\begin{code}
-selectAll :: (FAST_STRING -> FAST_STRING) -> (FAST_STRING -> Bool) -> SelectiveImporter
-
-selectAll renaming_fn is_mentioned_fn (Unk str) -- gotta be an Unk
-  = let
-	rn_str = renaming_fn str
-    in
-    if (isAvarid rn_str)
-    && (not (is_mentioned_fn rn_str))
-    && (_UNPK_ rn_str `lengthExceeds` 2)
-    then NotWanted
-    else Wanted
-\end{code}
-
-
-%************************************************************************
-%*									*
-\subsection{First pass over a particular interface}
-%*									*
-%************************************************************************
-
-
-@doIface1@ handles a specific interface. First it looks at the
-interface imports, creating a bag that maps local names back to their
-original names, from which it makes a function that does the same. It
-then uses this function to create a triple of bags for the interface
-type, class and value declarations, in which local names have been
-mapped back into original names.
-
-Notice that @mkLocalNameFun@ makes two different functions. The first
-is the name function for the interface. This takes a local name and
-provides an original name for any name in the interface by using
-either of:
-\begin{itemize}
-\item
-the original name produced by the renaming function;
-\item
-the local name in the interface and the interface name.
-\end{itemize}
-
-The function @doIfaceImports1@ receives two association lists which will
-be described at its definition.
-
-\begin{code}
-doIface1 :: (FAST_STRING -> FAST_STRING)    -- Renamings in import stmt of module
-       -> PreludeNameFuns
-       -> SelectiveImporter
-       -> ProtoNameInterface
-       -> Rn12M AllIntDecls
-
-doIface1 mod_rn_fn (v_pnf, tc_pnf) sifun
-       (MkInterface i_name import_decls fix_decls ty_decls class_decls
-		    inst_decls sig_decls anns)
-
-  = doIfaceImports1 mod_rn_fn i_name import_decls	`thenRn12` \ (v_bag, tc_bag) ->
-    do_body (v_bag, tc_bag)
-  where
-    do_body (v_bag, tc_bag)
-      = report_all_errors			`thenRn12` \ _ ->
-
-	doIfaceTyDecls1 sifun full_tc_nf ty_decls	`thenRn12` \ ty_decls' ->
-
-	doIfaceClassDecls1 sifun full_tc_nf class_decls  `thenRn12` \ class_decls' ->
-
-	let sig_decls'	= doIfaceSigs1 sifun v_nf tc_nf sig_decls
-	    fix_decls'	= doIfaceFixes1 sifun v_nf fix_decls
-	    inst_decls'	= doIfaceInstDecls1 sifun tc_nf inst_decls
-	in
-	returnRn12 (fix_decls', ty_decls', class_decls', inst_decls', sig_decls', unitBag i_name)
-      where
-	v_dups  :: [[(FAST_STRING, ProtoName)]]
-	tc_dups :: [[(FAST_STRING, (ProtoName, IntNameFun))]]
-
-	(imp_v_nf, v_dups)   = mkNameFun {-OLD:v_pnf-}  v_bag
-	(imp_tc_nf, tc_dups) = mkNameFun {-OLD:tc_pnf-} tc_bag
-
-	v_nf :: IntNameFun
-	v_nf (Unk s) = case v_pnf s of
-			 Just n	 -> mkPreludeProtoName n
-			 Nothing -> case imp_v_nf s of
-				      Just n  -> n
-				      Nothing -> Imp i_name s [i_name] (mod_rn_fn s)
-
-	prel_con_or_op_nf  :: FAST_STRING{-module name-}-> IntNameFun
-		 -- Used for (..)'d parts of prelude datatype/class decls;
-		 -- OLD:? For `data' types, we happen to know everything;
-		 -- OLD:? For class decls, we *don't* know what the class-ops are.
-	prel_con_or_op_nf m (Unk s)
-	  = case v_pnf s of
-	      Just n  -> mkPreludeProtoName n
-	      Nothing -> Imp m s [m] (mod_rn_fn s)
-			 -- Strictly speaking, should be *no renaming* here, folks
-
-	local_con_or_op_nf :: IntNameFun	
-		-- used for non-prelude constructors/ops
-	local_con_or_op_nf (Unk s) = Imp i_name s [i_name] (mod_rn_fn s)
-
-	full_tc_nf :: IntTCNameFun
-	full_tc_nf (Unk s)
-	  = case tc_pnf s of
-	      Just n  -> (mkPreludeProtoName n,
-			  let
-			      mod = fst (getOrigName n)
-			  in
-			  prel_con_or_op_nf mod)
-
-	      Nothing -> case imp_tc_nf s of
-			  Just pair -> pair
-			  Nothing   -> (Imp i_name s [i_name] (mod_rn_fn s),
-				        local_con_or_op_nf)
-
-	tc_nf = fst . full_tc_nf
-
-        -- ADR: commented out next new lines because I don't believe
-        -- ADR: the check is useful or required by the Standard. (It
-        -- ADR: also messes up the interpreter.)
-
-	tc_errs = [] -- map (map (fst . snd)) tc_dups
-		  -- Ugh! Just keep the dup'd protonames
-	v_errs	= [] -- map (map snd) v_dups
-		  -- Ditto
-
-	report_all_errors
-	  = mapRn12 (addErrRn12 . duplicateImportsInInterfaceErr (_UNPK_ i_name))
-		    (tc_errs ++ v_errs)
-\end{code}
-
-
-%************************************************************************
-%*									*
-\subsection{doIfaceImports1}
-%*									*
-%************************************************************************
-
-@ImportNameBags@ is a pair of bags (one for values, one for types and
-classes) which specify the new names brought into scope by some
-import declarations in an interface.
-
-\begin{code}
-type ImportNameBags = (Bag (FAST_STRING, ProtoName),
-		       Bag (FAST_STRING, (ProtoName, IntNameFun))
-		      )
-\end{code}
-
-\begin{code}
-doIfaceImports1
-	:: (FAST_STRING -> FAST_STRING)	-- Renamings in import stmt of module
-	-> FAST_STRING			-- name of module whose interface we're doing
-	-> [IfaceImportDecl]
-	-> Rn12M ImportNameBags
-
-doIfaceImports1 _ _  [] = returnRn12 (emptyBag, emptyBag)
-
-doIfaceImports1 mod_rn_fn int_mod_name (imp_decl1 : rest)
-  = do_decl				 imp_decl1  `thenRn12` \ (vb1, tcb1) ->
-    doIfaceImports1 mod_rn_fn int_mod_name rest	    `thenRn12` \ (vb2, tcb2) ->
---  pprTrace "vbags/tcbags:" (ppr PprDebug (vb1 `unionBags` vb2, [(s,p) | (s,(p,_)) <- bagToList (tcb1 `unionBags` tcb2)])) (
-    returnRn12 (vb1 `unionBags` vb2, tcb1 `unionBags` tcb2)
---  )
-  where
-    do_decl (IfaceImportDecl orig_mod_name imports renamings src_loc)
-      =		-- Look at the renamings to get a suitable renaming function
-	doRenamings mod_rn_fn int_mod_name orig_mod_name renamings	
-				    `thenRn12` \ (orig_to_pn, local_to_pn) ->
-
-	    -- Now deal with one import at a time, combining results.
-	returnRn12 (
-	  foldl (doIfaceImport1 orig_to_pn local_to_pn)
-		(emptyBag, emptyBag)
-		imports
-	)
-\end{code}
-
-@doIfaceImport1@ takes a list of imports and the pair of renaming functions,
-returning a bag which maps local names to original names.
-
-\begin{code}
-doIfaceImport1 :: ( FAST_STRING	    -- Original local name
-		 -> (FAST_STRING,   -- Local name in this interface
-		     ProtoName)	    -- Its full protoname
-		)		    
-				    
-	     -> IntNameFun	    -- Local name to ProtoName; use for
-				    --   constructors and class ops
-				    
-	     -> ImportNameBags	    -- Accumulator
-	     -> IE		    -- An item in the import list
-	     -> ImportNameBags
-
-doIfaceImport1 orig_to_pn local_to_pn (v_bag, tc_bag) (IEVar orig_name)
-  = (v_bag `snocBag` (orig_to_pn orig_name), tc_bag)
-
-doIfaceImport1 orig_to_pn local_to_pn acc (IEThingAbs orig_name)
-  = int_import1_help orig_to_pn local_to_pn acc orig_name
-
-doIfaceImport1 orig_to_pn local_to_pn acc (IEThingAll orig_name)
-  = int_import1_help orig_to_pn local_to_pn acc orig_name
-
--- the next ones will go away with 1.3:
-doIfaceImport1 orig_to_pn local_to_pn acc (IEConWithCons orig_name _)
-  = int_import1_help orig_to_pn local_to_pn acc orig_name
-
-doIfaceImport1 orig_to_pn local_to_pn acc (IEClsWithOps orig_name _)
-  = int_import1_help orig_to_pn local_to_pn acc orig_name
-
-doIfaceImport1 orig_to_pn local_to_pn (v_bag, tc_bag) other
-  = panic "Rename1: strange import decl"
-
--- Little help guy...
-
-int_import1_help orig_to_pn local_to_pn (v_bag, tc_bag) orig_name
-  = case (orig_to_pn orig_name) of { (str, o_name) ->
-    (v_bag, tc_bag `snocBag` (str, (o_name, local_to_pn)))
-    }
-\end{code}
-
-
-The renaming-processing code.  It returns two name-functions. The
-first maps the {\em original} name for an entity onto a @ProtoName@
---- it is used when running over the list of things to be imported.
-The second maps the {\em local} name for a constructor or class op
-back to its original name --- it is used when scanning the RHS of
-a @data@ or @class@ decl.
-
-It can produce errors, if there is a domain clash on the renamings.
-
-\begin{code}
---pprTrace
---instance Outputable _PackedString where
---    ppr sty s = ppStr (_UNPK_ s)
-
-doRenamings :: (FAST_STRING -> FAST_STRING) -- Renamings in import stmt of module
-	    -> FAST_STRING	-- Name of the module whose interface we're working on
-	    -> FAST_STRING	-- Original-name module for these renamings
-	    -> [Renaming]	-- Renamings
-	    -> Rn12M
-		((FAST_STRING	     -- Original local name to...
-		    -> (FAST_STRING, -- ... Local name in this interface
-		        ProtoName)   -- ... Its full protoname
-		 ),	
-		 IntNameFun)	     -- Use for constructors, class ops
-
-doRenamings mod_rn_fn int_mod orig_mod []
-  = returnRn12 (
-      \ s ->
-	let
-	    result = (s, Imp orig_mod s [int_mod] (mod_rn_fn s))
-	in
---	pprTrace "name1a:" (ppCat [ppr PprDebug s, ppr PprDebug result]) (
-	result
---	)
-	,
-
-      \ (Unk s) ->
-	let
-	    result = Imp orig_mod s [int_mod] (mod_rn_fn s)
-	in
---	pprTrace "name2a:" (ppCat [ppr PprDebug s, ppr PprDebug result]) (
-	result
---	)
-    )
-
-doRenamings mod_rn_fn int_mod orig_mod renamings
-  = let
-	local_rn_fn = mkRenamingFun renamings
-    in
-    --pprTrace "local_rns:" (ppr PprDebug renamings) (
-    returnRn12 (
-      \ s ->
-	let
-	    local_name = local_rn_fn s
-	    result
-	      = (local_name, Imp orig_mod s [int_mod] (mod_rn_fn local_name))
-	in
---	pprTrace "name1:" (ppCat [ppr PprDebug s, ppr PprDebug result]) (
-	result
---	)
-	,
-
-      \ (Unk s) ->
-	let
-	    result
-	      = Imp orig_mod s [int_mod] (mod_rn_fn (local_rn_fn s))
-	in
---	pprTrace "name2:" (ppCat [ppr PprDebug s, ppr PprDebug result]) (
-	result
---	)
-    )
-    --)
-\end{code}
-
-\begin{code}
-mkRenamingFun :: [Renaming] -> FAST_STRING -> FAST_STRING
-
-mkRenamingFun []	= \ s -> s
-mkRenamingFun renamings 
-  = let
-	rn_fn = lookupFM (listToFM -- OLD: mkStringLookupFn
-		  [ (old, new) | MkRenaming old new <- renamings ]
-		  ) -- OLD: False {-not-sorted-}
-    in
-    \s -> case rn_fn s of
-	    Nothing -> s
-	    Just s' -> s'
-\end{code}
-
-
-%************************************************************************
-%*									*
-\subsection{Type declarations}
-%*									*
-%************************************************************************
-
-@doIfaceTyDecls1@ uses the `name function' to map local tycon names into
-original names, calling @doConDecls1@ to do the same for the
-constructors. @doTyDecls1@ is used to do both module and interface
-type declarations.
-
-\begin{code}
-doIfaceTyDecls1 :: SelectiveImporter
-	      -> IntTCNameFun
-	      -> [ProtoNameTyDecl]
-	      -> Rn12M [ProtoNameTyDecl]
-
-doIfaceTyDecls1 sifun full_tc_nf ty_decls
-  = mapRn12 do_decl ty_decls `thenRn12` \ decls_maybe ->
-    returnRn12 (catMaybes decls_maybe)
-  where
-    do_decl (TyData context tycon tyvars condecls derivs (DataPragmas hidden_cons specs) src_loc)
-      = let
-	    full_thing = returnRn12 (Just ty_decl')
-	in
-		-- GHC doesn't allow derivings in interfaces
-	(if null derivs
-	 then returnRn12 ()
-	 else addErrRn12 (derivingInIfaceErr tycon derivs src_loc)
-	) `thenRn12` \ _ ->
-
-	case (sifun tycon) of
-	  NotWanted			-> returnRn12 Nothing
-	  Wanted			-> full_thing
-	  WantedWith (IEThingAll _)	-> full_thing
-	  WantedWith (IEThingAbs _)	-> returnRn12 (Just abs_ty_decl')
-	  WantedWith ie@(IEConWithCons _ _) -> full_thing
-
-	  WantedWith really_weird_ie -> -- probably a typo in the pgm
-	    addErrRn12 (weirdImportExportConstraintErr
-			tycon really_weird_ie src_loc) `thenRn12` \ _ ->
-	    full_thing
-      where
-	(tycon_name, constr_nf) = full_tc_nf tycon
-	tc_nf	    		= fst . full_tc_nf
-
-	condecls'   = map (do_condecl constr_nf tc_nf) condecls
-	hidden_cons' = map (do_condecl constr_nf tc_nf) hidden_cons
-
-	pragmas' invent_hidden
-    	  = DataPragmas (if null hidden_cons && invent_hidden
-			 then condecls' -- if importing abstractly but condecls were
-			                -- exported we add them to the data pragma
-			 else hidden_cons')
-			specs {- ToDo: do_specs -}
-
-	context'    = doIfaceContext1 tc_nf context
-	deriv'	    = map tc_nf derivs -- rename derived classes
-
-	ty_decl'    = TyData context' tycon_name tyvars condecls' deriv' (pragmas' False) src_loc
-	abs_ty_decl'= TyData context' tycon_name tyvars []	  deriv' (pragmas' True) src_loc
-
-    do_decl (TySynonym tycon tyvars monoty pragmas src_loc)
-      = let
-	    full_thing = returnRn12 (Just ty_decl')
-	in
-	case (sifun tycon) of
-	  NotWanted		    -> returnRn12 Nothing
-	  Wanted		    -> full_thing
-	  WantedWith (IEThingAll _) -> full_thing
-
-	  WantedWith weird_ie	    -> full_thing
-      where
-	(tycon_name,_) = full_tc_nf tycon
-	tc_nf	= fst . full_tc_nf
-	monoty'	= doIfaceMonoType1 tc_nf monoty
-	ty_decl' = TySynonym tycon_name tyvars monoty' pragmas src_loc
-
-    -- one name fun for the data constructor, another for the type:
-
-    do_condecl c_nf tc_nf (ConDecl name tys src_loc)
-      = ConDecl (c_nf name) (doIfaceMonoTypes1 tc_nf tys) src_loc
-\end{code}
-
-%************************************************************************
-%*									*
-\subsection{Class declarations}
-%*									*
-%************************************************************************
-
-@doIfaceClassDecls1@ uses the `name function' to map local class names into
-original names, calling @doIfaceClassOp1@ to do the same for the
-class operations. @doClassDecls1@ is used to process both module and
-interface class declarations.
-
-\begin{code}
-doIfaceClassDecls1 ::  SelectiveImporter
-		 -> IntTCNameFun
-		 -> [ProtoNameClassDecl]
-		 -> Rn12M [ProtoNameClassDecl]
-
-doIfaceClassDecls1 sifun full_tc_nf clas_decls
-  = mapRn12 do_decl clas_decls `thenRn12` \ decls_maybe ->
-    returnRn12 (catMaybes decls_maybe)
-  where
-    do_decl (ClassDecl ctxt cname tyvar sigs bs@EmptyMonoBinds prags locn)
-				     -- No defaults in interface
-      = let
-	    full_thing = returnRn12 (Just class_decl')
-	in
-        case (sifun cname) of
-	  NotWanted			-> returnRn12 Nothing
-	  Wanted			-> full_thing
-	  WantedWith (IEThingAll _)	-> full_thing
---???	  WantedWith (IEThingAbs _)	-> returnRn12 (Just abs_class_decl')
-	  WantedWith (IEClsWithOps _ _) -> full_thing
-	  -- ToDo: add checking of IEClassWithOps
-	  WantedWith really_weird_ie	-> -- probably a typo in the pgm
-	    addErrRn12 (weirdImportExportConstraintErr
-			cname really_weird_ie locn) `thenRn12` \ _ ->
-	    full_thing
-      where
-	(clas, op_nf) = full_tc_nf cname
-	tc_nf = fst . full_tc_nf
-
-	sigs' = map (doIfaceClassOp1 op_nf tc_nf) sigs
-	ctxt' = doIfaceContext1 tc_nf ctxt
-
-	class_decl'     = ClassDecl ctxt' clas tyvar sigs' bs prags locn
-	abs_class_decl' = ClassDecl ctxt' clas tyvar []    bs prags locn
-\end{code}
-
-\begin{code}
-doIfaceClassOp1 :: IntNameFun	-- Use this for the class ops
-	      -> IntNameFun	-- Use this for the types
-	      -> ProtoNameClassOpSig
-	      -> ProtoNameClassOpSig
-
-doIfaceClassOp1 op_nf tc_nf (ClassOpSig v ty pragma src_loc)
-  = ClassOpSig (op_nf v) (doIfacePolyType1 tc_nf ty) pragma src_loc
-\end{code}
-
-%************************************************************************
-%*									*
-\subsection{Instance declarations}
-%*									*
-%************************************************************************
-
-We select the instance decl if either the class or the type constructor
-are selected.
-
-\begin{code}
-doIfaceInstDecls1 :: SelectiveImporter
-	        -> IntNameFun
-		-> [ProtoNameInstDecl]
-		-> [ProtoNameInstDecl]
-
-doIfaceInstDecls1 si tc_nf inst_decls
-  = catMaybes (map do_decl inst_decls)
-  where
-    do_decl (InstDecl context cname ty EmptyMonoBinds False modname imod uprags pragmas src_loc)
-      = case (si cname, tycon_reqd) of
-	  (NotWanted, NotWanted) -> Nothing
-	  _			 -> Just inst_decl'
-     where
-       context' = doIfaceContext1	 tc_nf context
-       ty'	= doIfaceMonoType1 tc_nf ty
-
-       inst_decl' = InstDecl context' (tc_nf cname) ty' EmptyMonoBinds False modname imod uprags pragmas src_loc
-
-       tycon_reqd
-	 = case getNonPrelOuterTyCon ty of
-	     Nothing -> NotWanted    -- Type doesn't have a user-defined tycon
-				     -- at its outermost level
-	     Just tycon -> si tycon  -- It does, so look up in the si-fun
-\end{code}
-
-%************************************************************************
-%*									*
-\subsection{Signature declarations}
-%*									*
-%************************************************************************
-
-@doIfaceSigs1@ uses the name function to create a bag that
-maps local names into original names.
-
-NB: Can't have user-pragmas & other weird things in interfaces.
-
-\begin{code}
-doIfaceSigs1 :: SelectiveImporter -> IntNameFun -> IntNameFun
-	   -> [ProtoNameSig]
-	   -> [ProtoNameSig]
-
-doIfaceSigs1 si v_nf tc_nf sigs
-  = catMaybes (map do_sig sigs)
-  where
-    do_sig (Sig v ty pragma src_loc)
-      = case (si v) of
-	  NotWanted -> Nothing
-	  Wanted    -> Just (Sig (v_nf v) (doIfacePolyType1 tc_nf ty) pragma src_loc)
-	  -- WantedWith doesn't make sense
-\end{code}
-
-
-%************************************************************************
-%*									*
-\subsection{Fixity declarations}
-%*									*
-%************************************************************************
-
-\begin{code}
-doIfaceFixes1 :: SelectiveImporter -> IntNameFun
-	    -> [ProtoNameFixityDecl]
-	    -> [ProtoNameFixityDecl]
-
-doIfaceFixes1 si vnf fixities
-  = catMaybes (map do_fixity fixities)
-  where
-    do_fixity (InfixL name i) = do_one InfixL name i
-    do_fixity (InfixR name i) = do_one InfixR name i
-    do_fixity (InfixN name i) = do_one InfixN name i
-
-    do_one con name i
-      = case si name of
-	  Wanted    -> Just (con (vnf name) i)
-	  NotWanted -> Nothing
-\end{code}
-
-
-%************************************************************************
-%*									*
-\subsection{doContext, MonoTypes, MonoType, Polytype}
-%*									*
-%************************************************************************
-
-\begin{code}
-doIfacePolyType1 :: IntNameFun -> ProtoNamePolyType -> ProtoNamePolyType
-
-doIfacePolyType1 tc_nf (UnoverloadedTy ty)
-  = UnoverloadedTy (doIfaceMonoType1 tc_nf ty)
-
-doIfacePolyType1 tc_nf (OverloadedTy ctxt ty)
-  = OverloadedTy (doIfaceContext1 tc_nf ctxt) (doIfaceMonoType1 tc_nf ty)
-\end{code}
-
-\begin{code}
-doIfaceContext1 :: IntNameFun -> ProtoNameContext -> ProtoNameContext
-doIfaceContext1 tc_nf  context = [(tc_nf clas, tyvar) | (clas,tyvar) <- context]
-\end{code}
-
-
-\begin{code}
-doIfaceMonoTypes1 :: IntNameFun -> [ProtoNameMonoType] -> [ProtoNameMonoType]
-doIfaceMonoTypes1 tc_nf tys = map (doIfaceMonoType1 tc_nf) tys
-\end{code}
-
-
-\begin{code}
-doIfaceMonoType1 :: IntNameFun -> ProtoNameMonoType -> ProtoNameMonoType
-
-doIfaceMonoType1 tc_nf (MonoTyVar tyvar) = MonoTyVar tyvar
-
-doIfaceMonoType1 tc_nf (ListMonoTy ty)
-  = ListMonoTy (doIfaceMonoType1 tc_nf ty)
-
-doIfaceMonoType1 tc_nf (FunMonoTy ty1 ty2)
-  = FunMonoTy (doIfaceMonoType1 tc_nf ty1) (doIfaceMonoType1 tc_nf ty2)
-
-doIfaceMonoType1 tc_nf (TupleMonoTy tys)
-  = TupleMonoTy (map (doIfacePolyType1 tc_nf) tys)
-
-doIfaceMonoType1 tc_nf (MonoTyCon name tys)
-  = MonoTyCon (tc_nf name) (doIfaceMonoTypes1 tc_nf tys)
-
-#ifdef DPH
-doIfaceMonoType1 tc_nf (MonoTyProc tys ty)
-  = MonoTyProc (doIfaceMonoTypes1 tc_nf tys) (doIfaceMonoType1 tc_nf ty)
-
-doIfaceMonoType1 tc_nf (MonoTyPod ty)
-  = MonoTyPod (doIfaceMonoType1 tc_nf ty)
-#endif {- Data Parallel Haskell -}
-\end{code}
diff --git a/ghc/compiler/rename/Rename2.hi b/ghc/compiler/rename/Rename2.hi
deleted file mode 100644
index 68f4a63cf3..0000000000
--- a/ghc/compiler/rename/Rename2.hi
+++ /dev/null
@@ -1,26 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface Rename2 where
-import AbsSyn(Module)
-import Bag(Bag)
-import CharSeq(CSeq)
-import CmdLineOpts(GlobalSwitch)
-import HsBinds(Binds, Sig)
-import HsDecls(ClassDecl, DataTypeSig, DefaultDecl, FixityDecl, InstDecl, SpecialisedInstanceSig, TyDecl)
-import HsImpExp(IE, ImportedInterface)
-import HsLit(Literal)
-import HsPat(InPat, ProtoNamePat(..))
-import Name(Name)
-import PreludePS(_PackedString)
-import Pretty(Delay, PprStyle, Pretty(..), PrettyRep)
-import ProtoName(ProtoName)
-import SrcLoc(SrcLoc)
-data Module a b 
-data Bag a 
-data InPat a 
-type ProtoNamePat = InPat ProtoName
-data PprStyle 
-type Pretty = Int -> Bool -> PrettyRep
-data PrettyRep 
-data ProtoName 
-rnModule2 :: Module ProtoName (InPat ProtoName) -> _PackedString -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> (Module ProtoName (InPat ProtoName), Bag (PprStyle -> Int -> Bool -> PrettyRep))
-
diff --git a/ghc/compiler/rename/Rename2.lhs b/ghc/compiler/rename/Rename2.lhs
deleted file mode 100644
index bb7ac162c5..0000000000
--- a/ghc/compiler/rename/Rename2.lhs
+++ /dev/null
@@ -1,832 +0,0 @@
-%
-% (c) The GRASP Project, Glasgow University, 1992-1995
-%
-\section[Rename2]{Second renaming pass: boil down to non-duplicated info}
-
-\begin{code}
-#include "HsVersions.h"
-
-module Rename2 (
-	rnModule2,
-
-	-- for completeness
-	Module, Bag, ProtoNamePat(..), InPat,
-	PprStyle, Pretty(..), PrettyRep, ProtoName
-    ) where
-
-IMPORT_Trace		-- ToDo: rm (debugging)
-import Pretty
-import Outputable
-
-import AbsSyn
-import Errors		( dupNamesErr, Error(..) )
-import HsCore		-- ****** NEED TO SEE CONSTRUCTORS ******
-import HsPragmas	-- ****** NEED TO SEE CONSTRUCTORS ******
-import HsTypes		( cmpMonoType, pprParendMonoType )
-import IdInfo		( DeforestInfo(..) )
-import Maybes		( Maybe(..) )
-import ProtoName
-import RenameMonad12
-import SrcLoc		( mkUnknownSrcLoc, SrcLoc )
-import Util
-\end{code}
-
-This pass removes duplicate declarations.  Duplicates can arise when
-two imported interface have a signature (or whatever) for the same
-thing.	We check that the two are consistent and then drop one.
-
-For preference, if one is declared in this module and the other is
-imported, we keep the former; in the case of an instance decl or type
-decl, the local version has a lot more information which we must not
-lose!
-
-Similarly, if one has interesting pragmas and one has not, we keep the
-former.
-
-The notion of ``duplicate'' includes an imported signature and a
-binding in this module.	 In this case, the signature is discarded.
-See note below about how this should be improved.
-
-ToDo: There are still known cases in which we blithely consider two
-declarations to be ``duplicates'' and we then select one of them, {\em
-without} actually checking that they contain the same information!
-[WDP 93/8/16] [Improved, at least WDP 93/08/26]
-
-\begin{code}
-rnModule2  :: ProtoNameModule -> Rn12M ProtoNameModule
-
-rnModule2 (Module mod_name exports imports fixes
-	    ty_decls absty_sigs class_decls inst_decls specinst_sigs
-	    defaults binds int_sigs src_loc)
-
-  = uniquefy mod_name cmpFix selFix fixes
-				`thenRn12` \ fixes ->
-
-    uniquefy mod_name cmpTys selTys ty_decls
-				`thenRn12` \ ty_decls ->
-
-    uniquefy mod_name cmpTySigs selTySigs absty_sigs
-				`thenRn12` \ absty_sigs ->
-
-    uniquefy mod_name cmpClassDecl selClass class_decls
-				`thenRn12` \ class_decls ->
-
-    uniquefy mod_name cmpInst selInst inst_decls
-				`thenRn12` \ inst_decls ->
-
-    uniquefy mod_name cmpSpecInstSigs selSpecInstSigs specinst_sigs
-				`thenRn12` \ specinst_sigs ->
-
-	-- From the imported signatures discard any which are for
-	-- variables bound in this module.
-	-- But, be wary of those that *clash* with those for this
-	-- module...
-	-- Note that we want to do this properly later (ToDo) because imported
-	-- signatures may differ from those declared in the module itself.
-
-    rm_sigs_for_here mod_name int_sigs
-				`thenRn12` \ non_here_int_sigs ->
-
-    uniquefy mod_name cmpSig selSig non_here_int_sigs 
-				 `thenRn12` \ int_sigs ->
-    returnRn12
-	(Module mod_name
-		exports	-- export and import lists are passed along
-		imports	-- for checking in Rename3; no other reason
-		fixes
-		ty_decls
-		absty_sigs
-		class_decls
-		inst_decls
-		specinst_sigs
-		defaults
-		binds
-		int_sigs
-		src_loc)
-  where
-    top_level_binders = collectTopLevelBinders binds
-
-    rm_sigs_for_here :: FAST_STRING -> [ProtoNameSig] -> Rn12M [ProtoNameSig]
-	-- NB: operates only on interface signatures, so don't
-	-- need to worry about user-pragmas, etc.
-
-    rm_sigs_for_here mod_name [] = returnRn12 []
-
-    rm_sigs_for_here mod_name (sig@(Sig name _ _ src_loc) : more_sigs)
-      = rm_sigs_for_here mod_name more_sigs `thenRn12` \ rest_sigs ->
-
-	if  not (name `elemByLocalNames` top_level_binders) then -- no name clash...
-	    returnRn12 (sig : rest_sigs)
-
-	else -- name clash...
-	    if	name `elemProtoNames` top_level_binders
-	     && name_for_this_module name then
-		-- the very same thing; just drop it
-		returnRn12 rest_sigs
-	    else
-		-- a different thing with the same name (due to renaming?)
-		-- ToDo: locations need improving
-		report_dup "(renamed?) variable"
-			name src_loc name mkUnknownSrcLoc
-			rest_sigs
-      where
-	 name_for_this_module (Imp m _ _ _) = m == mod_name
-	 name_for_this_module other	    = True
-\end{code}
-
-%************************************************************************
-%*									*
-\subsection[FixityDecls-Rename2]{Functions for @FixityDecls@}
-%*									*
-%************************************************************************
-
-\begin{code}
-cmpFix :: ProtoNameFixityDecl -> ProtoNameFixityDecl -> TAG_
-
-cmpFix (InfixL n1 i1) (InfixL n2 i2) = n1 `cmpProtoName` n2
-cmpFix (InfixL n1 i1) other	     = LT_
-cmpFix (InfixR n1 i1) (InfixR n2 i2) = n1 `cmpProtoName` n2
-cmpFix (InfixR n1 i1) (InfixN n2 i2) = LT_
-cmpFix (InfixN n1 i1) (InfixN n2 i2) = n1 `cmpProtoName` n2
-cmpFix a	      b		     = GT_
-\end{code}
-
-We are pretty un-fussy about which FixityDecl we keep.
-
-\begin{code}
-selFix :: ProtoNameFixityDecl -> ProtoNameFixityDecl -> Rn12M ProtoNameFixityDecl
-selFix f1 f2 = returnRn12 f1
-\end{code}
-
-%************************************************************************
-%*									*
-\subsection[TyDecls-Rename2]{Functions for @TyDecls@}
-%*									*
-%************************************************************************
-
-\begin{code}
-cmpTys :: ProtoNameTyDecl -> ProtoNameTyDecl -> TAG_
-
-cmpTys (TyData _ n1 _ _ _ _ _) (TyData	_ n2 _ _ _ _ _) = cmpProtoName n1 n2
-cmpTys (TyData _ n1 _ _ _ _ _) other			= LT_
-cmpTys (TySynonym n1 _ _ _ _)  (TySynonym n2 _ _ _ _)	= cmpProtoName n1 n2
-cmpTys a		       b			= GT_
-\end{code}
-
-\begin{code}
-selTys :: ProtoNameTyDecl -> ProtoNameTyDecl
-       -> Rn12M ProtoNameTyDecl
-
--- Note: we could check these more closely.
--- NB: It would be a mistake to cross-check derivings,
--- because we don't preserve those in interfaces.
-
-selTys td1@(TyData c name1 tvs cons1 ds pragmas1 locn1)
-       td2@(TyData _ name2 _   cons2 _	pragmas2 locn2)
-  = selByBetterName "algebraic datatype"
-       name1 pragmas1 locn1 td1
-       name2 pragmas2 locn2 td2
-       (\ p -> TyData c name1 tvs cons1 ds p locn1)
-       chooser_TyData
-
-selTys ts1@(TySynonym name1 tvs expand1 pragmas1 locn1)
-       ts2@(TySynonym name2 _	expand2 pragmas2 locn2)
-  = selByBetterName "type synonym"
-	name1 pragmas1 locn1 ts1
-	name2 pragmas2 locn2 ts2
-	(\ p -> TySynonym name1 tvs expand1 p locn1)
-	chooser_TySynonym
-\end{code}
-
-If only one is ``abstract'' (no condecls), we take the other.
-
-Next, we check that they don't have differing lists of data
-constructors (what a disaster if those get through...); then we do a
-similar thing using pragmatic info.
-
-\begin{code}
-chooser_TyData wout pragmas1 locn1 td1@(TyData _ name1 _ cons1 _ _ _)
-		    pragmas2 locn2 td2@(TyData _ name2 _ cons2 _ _ _)
-  = let
-	td1_abstract = null cons1
-	td2_abstract = null cons2
-
-	choose_by_pragmas = sub_chooser pragmas1 pragmas2
-    in
-    if td1_abstract && td2_abstract then
-	choose_by_pragmas
-
-    else if td1_abstract then
-	returnRn12 td2
-
-    else if td2_abstract then
-	returnRn12 td1
-
-    else if not (eqConDecls cons1 cons2) then
-    	report_dup "algebraic datatype (mismatched data constuctors)"
-    		    name1 locn1 name2 locn2 td1
-    else
-	sub_chooser pragmas1 pragmas2
-  where
-    sub_chooser (DataPragmas [] []) b = returnRn12 (wout b)
-    sub_chooser a (DataPragmas [] []) = returnRn12 (wout a)
-    sub_chooser a@(DataPragmas cons1 specs1) (DataPragmas cons2 specs2)
-      = if not (eqConDecls cons1 cons2) then
-	    pprTrace "Mismatched info in DATA pragmas:\n"
-		     (ppAbove (ppr PprDebug cons1) (ppr PprDebug cons2)) (
-	    returnRn12 (wout (DataPragmas [] []))
-	    )
-	else if not (eq_data_specs specs1 specs2) then
-	    pprTrace "Mismatched specialisation info in DATA pragmas:\n"
-		     (ppAbove (ppr_data_specs specs1) (ppr_data_specs specs2)) (
-	    returnRn12 (wout (DataPragmas [] []))
-	    )
-	else
-	    returnRn12 (wout a)  -- same, pick one
-
-    -- ToDo: Should we use selByBetterName ???
-    -- ToDo: Report errors properly and recover quietly ???
-
-    -- ToDo: Should we merge specialisations ???
-
-    eq_data_specs [] [] = True
-    eq_data_specs (spec1:specs1) (spec2:specs2)
-      = eq_spec spec1 spec2 && eq_data_specs specs1 specs2
-    eq_data_specs _  _  = False
-
-    eq_spec spec1 spec2 = case cmp_spec spec1 spec2 of { EQ_ -> True; _ -> False}
-
-    ppr_data_specs specs
-      = ppBesides [ppStr "_SPECIALISE_ ", pp_the_list [
-	  ppCat [ppLbrack, ppInterleave ppComma (map pp_maybe ty_maybes), ppRbrack]
-	  | ty_maybes <- specs ]]
-         
-    pp_the_list [p]    = p
-    pp_the_list (p:ps) = ppAbove (ppBeside p ppComma) (pp_the_list ps)
-
-    pp_maybe Nothing   = pp_NONE
-    pp_maybe (Just ty) = pprParendMonoType PprDebug ty
-
-    pp_NONE = ppStr "_N_"
-\end{code}
-
-Sort of similar deal on synonyms: this is the time to check that the
-expansions are really the same; otherwise, we use the pragmas.
-
-\begin{code}
-chooser_TySynonym wout pragmas1 locn1 ts1@(TySynonym name1 _ expand1 _ _)
-		       pragmas2 locn2 ts2@(TySynonym name2 _ expand2 _ _)
-  = if not (eqMonoType expand1 expand2) then
-    	report_dup "type synonym" name1 locn1 name2 locn2 ts1
-    else
-	sub_chooser pragmas1 pragmas2
-  where
-    sub_chooser NoTypePragmas b = returnRn12 (wout b)
-    sub_chooser a NoTypePragmas = returnRn12 (wout a)
-    sub_chooser a _ 	    	= returnRn12 (wout a) -- same, just pick one
-\end{code}
-
-%************************************************************************
-%*									*
-\subsection[DataTypeSigs-Rename2]{Functions for @DataTypeSigs@}
-%*									*
-%************************************************************************
-
-\begin{code}
-cmpTySigs :: ProtoNameDataTypeSig -> ProtoNameDataTypeSig -> TAG_
-
-cmpTySigs (AbstractTypeSig n1 _) (AbstractTypeSig n2 _)
-  = cmpProtoName n1 n2
-cmpTySigs (SpecDataSig n1 ty1 _) (SpecDataSig n2 ty2 _)
-  = case cmpProtoName n1 n2 of
-	EQ_   -> LT_   -- multiple SPECIALIZE data pragmas allowed
-	other -> other
-cmpTySigs (AbstractTypeSig n1 _) (SpecDataSig n2 _ _)
-  = LT_
-cmpTySigs (SpecDataSig n1 _ _) (AbstractTypeSig n2 _)
-  = GT_
-
-selTySigs :: ProtoNameDataTypeSig
-	  -> ProtoNameDataTypeSig
-	  -> Rn12M ProtoNameDataTypeSig
-
-selTySigs s1@(AbstractTypeSig n1 locn1) s2@(AbstractTypeSig n2 locn2)
-  = selByBetterName "ABSTRACT user-pragma"
-	n1 bottom locn1 s1
-	n2 bottom locn2 s2
-	bottom bottom
-  where
-    bottom = panic "Rename2:selTySigs:AbstractTypeSig"
-
-selTySigs s1@(SpecDataSig n1 ty1 locn1) s2@(SpecDataSig n2 ty2 locn2)
-  = selByBetterName "ABSTRACT user-pragma"
-	n1 bottom locn1 s1
-	n2 bottom locn2 s2
-	bottom bottom
-  where
-    bottom = panic "Rename2:selTySigs:SpecDataSig"
-\end{code}
-
-%************************************************************************
-%*									*
-\subsection[ClassDecl-Rename2]{Functions for @ClassDecls@}
-%*									*
-%************************************************************************
-
-\begin{code}
-cmpClassDecl :: ProtoNameClassDecl -> ProtoNameClassDecl -> TAG_
-
-cmpClassDecl (ClassDecl _ n1 _ _ _ _ _) (ClassDecl _ n2 _ _ _ _ _)
-  = cmpProtoName n1 n2
-
-selClass  :: ProtoNameClassDecl -> ProtoNameClassDecl
-	  -> Rn12M ProtoNameClassDecl
-
-selClass cd1@(ClassDecl ctxt n1 tv sigs bs pragmas1 locn1)
-	 cd2@(ClassDecl _    n2 _  _	_  pragmas2 locn2)
-  = selByBetterName "class"
-	n1 pragmas1 locn1 cd1
-	n2 pragmas2 locn2 cd2
-	(\ p -> ClassDecl ctxt n1 tv sigs bs p locn1)
-	chooser_Class
-\end{code}
-
-\begin{code}
-chooser_Class wout NoClassPragmas   _ _ b		_ _ = returnRn12 (wout b)
-chooser_Class wout a		    _ _ NoClassPragmas	_ _ = returnRn12 (wout a)
-
-chooser_Class wout sd1@(SuperDictPragmas gs1) l1 _ sd2@(SuperDictPragmas gs2) l2 _
-  = if length gs1 /= length gs2 then	-- urgh
-       returnRn12 (wout NoClassPragmas)
-    else
-	recoverQuietlyRn12 [{-no gen prags-}] (
-	    zipWithRn12 choose_prag gs1 gs2
-	)			`thenRn12` \ new_gprags ->
-	returnRn12 (wout (
-	    if null new_gprags then
-		pprTrace "tossed all SuperDictPragmas (rename2):"
-			 (ppAbove (ppr PprDebug sd1) (ppr PprDebug sd2))
-		NoClassPragmas
-	    else
-		SuperDictPragmas new_gprags
-	))
-  where
-    choose_prag g1 g2 = selGenPragmas g1 l1 g2 l2
-\end{code}
-
-%************************************************************************
-%*									*
-\subsection[InstDecls-Rename2]{Functions for @InstDecls@}
-%*									*
-%************************************************************************
-
-\begin{code}
-cmpInst :: ProtoNameInstDecl -> ProtoNameInstDecl -> TAG_
-
-cmpInst (InstDecl _ c1 ty1 _ _ _ _ _ _ _) (InstDecl _ c2 ty2 _ _ _ _ _ _ _)
-  = case cmpProtoName c1 c2 of
-      EQ_   -> cmpInstanceTypes ty1 ty2
-      other -> other
-\end{code}
-
-Select the instance declaration from the module (rather than an
-interface), if it exists.
-
-\begin{code}
-selInst :: ProtoNameInstDecl -> ProtoNameInstDecl
-	-> Rn12M ProtoNameInstDecl
-
-selInst i1@(InstDecl ctxt c ty bs from_here1 orig_mod1 infor_mod1 uprags pragmas1 locn1)
-	i2@(InstDecl _	  _ _  _  from_here2 orig_mod2 infor_mod2 _      pragmas2 locn2)
-  = let
-	have_orig_mod1 = not (_NULL_ orig_mod1)
-	have_orig_mod2 = not (_NULL_ orig_mod2)
-
-	choose_no1 = returnRn12 i1
-	choose_no2 = returnRn12 i2
-    in
-	-- generally: try to keep the locally-defined instance decl
-
-    if from_here1 && from_here2 then
-	-- If they are both from this module, don't throw either away,
-	-- otherwise we silently discard erroneous duplicates
-	trace ("selInst: duplicate instance in this module (ToDo: msg!)")
-	choose_no1
-
-    else if from_here1 then
-	if ( have_orig_mod1 && have_orig_mod2 && orig_mod1 /= orig_mod2 ) then
-	    trace ("selInst: instance in this module also defined somewhere else! (ToDo: msg!)")
-	    choose_no1
-	else
-	    choose_no1
-
-    else if from_here2 then
-	if ( have_orig_mod1 && have_orig_mod2 && orig_mod1 /= orig_mod2 ) then
-	    trace ("selInst: instance in this module also defined somewhere else! (ToDo: msg!)")
-	    choose_no2
-	else
-	    choose_no2
-
-    else -- it's definitely an imported instance;
-	 -- first, a quick sanity check...
-	if ( have_orig_mod1 && have_orig_mod2 && orig_mod1 /= orig_mod2 ) then
-	    trace ("selInst: `same' instances coming in from two modules! (ToDo: msg!)")
-	    choose_no2 -- arbitrary
-	else
-	    -- now we *cheat*: so we can use the "informing module" stuff
-	    -- in "selByBetterName", we *make up* some ProtoNames for
-	    -- these instance decls
-	    let
-		ii = SLIT("!*INSTANCE*!")
-		n1 = Imp orig_mod1 ii [infor_mod1] ii
-		n2 = Imp orig_mod2 ii [infor_mod2] ii
-	    in
-	    selByBetterName "instance"
-		n1 pragmas1 locn1 i1
-		n2 pragmas2 locn2 i2
-	        (\ p -> InstDecl ctxt c ty bs from_here1 orig_mod1 infor_mod1
-			[{-none-}] p locn1)
-		chooser_Inst
-\end{code}
-
-\begin{code}
-chooser_Inst wout iprags1 loc1 i1 iprags2 loc2 i2
-  = chk_pragmas iprags1 iprags2
-  where
-	-- easy cases:
-    chk_pragmas NoInstancePragmas b = returnRn12 (wout b)
-    chk_pragmas a NoInstancePragmas = returnRn12 (wout a)
-
-	-- SimpleInstance pragmas meet: choose by GenPragmas
-    chk_pragmas (SimpleInstancePragma gprags1) (SimpleInstancePragma gprags2)
-      = recoverQuietlyRn12 NoGenPragmas (
-	    selGenPragmas gprags1 loc1 gprags2 loc2
-	)				`thenRn12` \ new_prags ->
-	returnRn12 (wout (
-	    case new_prags of
-	      NoGenPragmas -> NoInstancePragmas	-- bottled out
-	      _ -> SimpleInstancePragma new_prags
-	))
-
-	-- SimpleInstance pragma meets anything else... take the "else"
-    chk_pragmas (SimpleInstancePragma _) b = returnRn12 (wout b)
-    chk_pragmas a (SimpleInstancePragma _) = returnRn12 (wout a)
-
-    chk_pragmas (ConstantInstancePragma gp1 prs1) (ConstantInstancePragma gp2 prs2)
-      = recoverQuietlyRn12 NoGenPragmas (
-	    selGenPragmas gp1 loc1 gp2 loc2
-	)			`thenRn12` \ dfun_prags ->
-
-	recoverQuietlyRn12 [] (
-	    selNamePragmaPairs prs1 loc1 prs2 loc2
-	)			`thenRn12` \ new_pairs ->
-
-	returnRn12 (wout (
-	    if null new_pairs then -- bottled out
-		case dfun_prags of
-		  NoGenPragmas -> NoInstancePragmas -- doubly bottled out
-		  _ -> SimpleInstancePragma dfun_prags
-	    else
-		ConstantInstancePragma dfun_prags new_pairs
-	))
-
-	-- SpecialisedInstancePragmas: choose by gens, then specialisations
-    chk_pragmas a@(SpecialisedInstancePragma _ _) (SpecialisedInstancePragma _ _)
-      = trace "not checking two SpecialisedInstancePragma pragmas!" (returnRn12 (wout a))
-
-    chk_pragmas other1 other2  -- oops, bad mismatch
-      = pRAGMA_ERROR "instance pragmas" (wout other1) -- ToDo: msg
-\end{code}
-
-%************************************************************************
-%*									*
-\subsection[SpecInstSigs-Rename2]{Functions for @AbstractTypeSigs@}
-%*									*
-%************************************************************************
-
-We don't make any effort to look for duplicate ``SPECIALIZE instance''
-pragmas. (Later??)
-
-We do this by make \tr{cmp*} always return \tr{LT_}---then there's
-nothing for \tr{sel*} to do!
-
-\begin{code}
-cmpSpecInstSigs
-	:: ProtoNameSpecialisedInstanceSig -> ProtoNameSpecialisedInstanceSig -> TAG_
-selSpecInstSigs :: ProtoNameSpecialisedInstanceSig
-		-> ProtoNameSpecialisedInstanceSig
-		-> Rn12M ProtoNameSpecialisedInstanceSig
-
-cmpSpecInstSigs	a b = LT_
-selSpecInstSigs a b = panic "Rename2:selSpecInstSigs"
-\end{code}
-
-%************************************************************************
-%*									*
-\subsection{Functions for SigDecls}
-%*									*
-%************************************************************************
-
-These \tr{*Sig} functions only operate on things from interfaces, so
-we don't have to worry about user-pragmas and other such junk.
-
-\begin{code}
-cmpSig :: ProtoNameSig -> ProtoNameSig -> TAG_
-
-cmpSig (Sig n1 _ _ _) (Sig n2 _ _ _) = cmpProtoName n1 n2
-
--- avoid BUG (ToDo)
-cmpSig _ _ = case (panic "cmpSig (rename2)") of { s -> -- should never happen
-	     cmpSig s s }
-
-selSig :: ProtoNameSig -> ProtoNameSig -> Rn12M ProtoNameSig
-
-selSig s1@(Sig n1 ty pragmas1 locn1) s2@(Sig n2 _ pragmas2 locn2)
-  = selByBetterName "type signature"
-	n1 pragmas1 locn1 s1
-	n2 pragmas2 locn2 s2
-	(\ p -> Sig n1 ty p locn1) -- w/out its pragmas
-	chooser_Sig
-\end{code}
-
-\begin{code}
-chooser_Sig wout_prags g1 l1 s1@(Sig n1 ty1 _ _) g2 l2 s2@(Sig n2 ty2 _ _)
-  = case (cmpPolyType cmpProtoName ty1 ty2) of
-      EQ_ ->
-	recoverQuietlyRn12 NoGenPragmas (
-	    selGenPragmas g1 l1 g2 l2
-	)			`thenRn12` \ new_prags ->
-	returnRn12 (wout_prags new_prags)
-      _ -> report_dup "signature" n1 l1 n2 l2 s1
-\end{code}
-
-%************************************************************************
-%*									*
-\subsection{Help functions: selecting based on pragmas}
-%*									*
-%************************************************************************
-
-\begin{code}
-selGenPragmas
-	:: ProtoNameGenPragmas -> SrcLoc
-	-> ProtoNameGenPragmas -> SrcLoc
-	-> Rn12M ProtoNameGenPragmas
-
-selGenPragmas NoGenPragmas _ b	          _ = returnRn12 b
-selGenPragmas a		   _ NoGenPragmas _ = returnRn12 a
-
-selGenPragmas g1@(GenPragmas arity1 upd1 def1 strict1 unfold1 specs1) locn1
-	      g2@(GenPragmas arity2 upd2 def2 strict2 unfold2 specs2) locn2
-
-  = sel_arity  arity1  arity2	`thenRn12` \ arity  ->
-    sel_upd    upd1    upd2	`thenRn12` \ upd    ->
-    sel_def    def1    def2     `thenRn12` \ def    ->
-    sel_strict strict1 strict2	`thenRn12` \ strict ->
-    sel_unfold unfold1 unfold2	`thenRn12` \ unfold ->
-    sel_specs  specs1  specs2	`thenRn12` \ specs  ->
-    returnRn12 (GenPragmas arity upd def strict unfold specs)
-  where
-    sel_arity Nothing     Nothing   = returnRn12 Nothing
-    sel_arity a@(Just a1) (Just a2) = if a1 == a2
-				      then returnRn12 a
-				      else pRAGMA_ERROR "arity pragmas" a
-    sel_arity a		  _	    = pRAGMA_ERROR "arity pragmas" a
-
-    -------
-    sel_upd Nothing   	Nothing   = returnRn12 Nothing
-    sel_upd a@(Just u1) (Just u2) = if u1 == u2
-				    then returnRn12 a
-				    else pRAGMA_ERROR "update pragmas" a
-    sel_upd a	    	_	  = pRAGMA_ERROR "update pragmas" a
-
-    -------
-    sel_def Don'tDeforest Don'tDeforest = returnRn12 Don'tDeforest
-    sel_def DoDeforest    DoDeforest    = returnRn12 DoDeforest
-    sel_def a             _             = pRAGMA_ERROR "deforest pragmas" a
-
-    ----------
-    sel_unfold NoImpUnfolding b	    	     = returnRn12 b
-    sel_unfold a	      NoImpUnfolding = returnRn12 a
-
-    sel_unfold a@(ImpUnfolding _ c1) (ImpUnfolding _ c2)
-      = if c1 `eqUfExpr` c2 -- very paranoid (and rightly so)
-	then returnRn12 a
-	else pprTrace "mismatched unfoldings:\n" (ppAbove (ppr PprDebug c1) (ppr PprDebug c2)) (
-	     returnRn12 NoImpUnfolding
-	     )
-
-    sel_unfold a@(ImpMagicUnfolding b) (ImpMagicUnfolding c)
-      = if b == c then returnRn12 a else pRAGMA_ERROR "magic unfolding" a
-
-    sel_unfold a _ = pRAGMA_ERROR "unfolding pragmas" a
-
-    ----------
-    sel_strict NoImpStrictness NoImpStrictness = returnRn12 NoImpStrictness
-
-    sel_strict a@(ImpStrictness b1 i1 g1) (ImpStrictness b2 i2 g2)
-      = if b1 /= b2 || i1 /= i2
-        then pRAGMA_ERROR "strictness pragmas" a
-	else recoverQuietlyRn12 NoGenPragmas (
-		selGenPragmas g1 locn1 g2 locn2
-	     )	`thenRn12` \ wrkr_prags ->
-	     returnRn12 (ImpStrictness b1 i1 wrkr_prags)
-
-    sel_strict a _ = pRAGMA_ERROR "strictness pragmas" a
-
-    ---------
-    sel_specs specs1 specs2
-      = selSpecialisations specs1 locn1 specs2 locn2
-\end{code}
-
-\begin{code}
-selNamePragmaPairs
-	:: [(ProtoName, ProtoNameGenPragmas)] -> SrcLoc
-	-> [(ProtoName, ProtoNameGenPragmas)] -> SrcLoc
-	-> Rn12M [(ProtoName, ProtoNameGenPragmas)]
-
-selNamePragmaPairs [] _ [] _ = returnRn12 []
-selNamePragmaPairs [] _ bs _ = returnRn12 bs
-selNamePragmaPairs as _ [] _ = returnRn12 as
-
-selNamePragmaPairs ((name1, prags1) : pairs1) loc1
-		   ((name2, prags2) : pairs2) loc2
-
-  = if not (name1 `eqProtoName` name2) then
-	-- msg of any kind??? ToDo
-	pRAGMA_ERROR "named pragmas" pairs1
-    else
-    	selGenPragmas prags1 loc1 prags2 loc2	    `thenRn12` \ new_prags ->
-    	selNamePragmaPairs pairs1 loc1 pairs2 loc2  `thenRn12` \ rest ->
-	returnRn12 ( (name1, new_prags) : rest )
-\end{code}
-
-For specialisations we merge the lists from each Sig. This allows the user to
-declare specialised prelude functions in their own PreludeSpec module.
-
-\begin{code}
-selSpecialisations
-	:: [([Maybe ProtoNameMonoType], Int, ProtoNameGenPragmas)] -> SrcLoc
-	-> [([Maybe ProtoNameMonoType], Int, ProtoNameGenPragmas)] -> SrcLoc
-	-> Rn12M [([Maybe ProtoNameMonoType], Int, ProtoNameGenPragmas)]
-
-selSpecialisations [] _ [] _ = returnRn12 []
-selSpecialisations [] _ bs _ = returnRn12 bs -- arguable ... ToDo?
-selSpecialisations as _ [] _ = returnRn12 as -- ditto
-
-selSpecialisations all_specs1@((spec1, dicts1, prags1) : rest_specs1) loc1
-		   all_specs2@((spec2, dicts2, prags2) : rest_specs2) loc2
-
-  = case (cmp_spec spec1 spec2) of
-	 LT_ -> selSpecialisations rest_specs1 loc1 all_specs2 loc2
-					`thenRn12` \ rest ->
-    		returnRn12 ( (spec1, dicts1, prags1) : rest )
-
-	 EQ_ -> ASSERT(dicts1 == dicts2)
-	       	recoverQuietlyRn12 NoGenPragmas (
-	    	    selGenPragmas prags1 loc1 prags2 loc2
-	        )			`thenRn12` \ new_prags ->
-    	        selSpecialisations rest_specs1 loc1 rest_specs2 loc2
-					`thenRn12` \ rest ->
-    		returnRn12 ( (spec1, dicts1, new_prags) : rest )
-
-	 GT_ -> selSpecialisations all_specs1 loc1 rest_specs2 loc2
-					`thenRn12` \ rest ->
-    		returnRn12 ( (spec2, dicts2, prags2) : rest )
-
-cmp_spec [] []			   = EQ_
-cmp_spec (Nothing:xs) (Nothing:ys) = cmp_spec xs ys
-cmp_spec (Just t1:xs) (Just t2:ys) = case cmpMonoType cmpProtoName t1 t2 of
-					EQ_ -> cmp_spec xs ys
-					xxx -> xxx
-cmp_spec (Nothing:xs) (Just t2:ys) = LT_
-cmp_spec (Just t1:xs) (Nothing:ys) = GT_
-\end{code}
-
-%************************************************************************
-%*									*
-\subsection{Help functions: @uniquefy@ and @selByBetterName@}
-%*									*
-%************************************************************************
-
-\begin{code}
-uniquefy :: FAST_STRING			-- Module name
-	 -> (a -> a -> TAG_)		-- Comparison function
-	 -> (a -> a -> Rn12M a)		-- Selection function
-	 -> [a]				-- Things to be processed
-	 -> Rn12M [a]			-- Processed things
-
-uniquefy mod cmp sel things
-  = mapRn12 (check_group_consistency sel) grouped_things
-  where
-    grouped_things = equivClasses cmp things
-
-    check_group_consistency :: (a -> a -> Rn12M a)	-- Selection function
-			    -> [a]			-- things to be compared
-			    -> Rn12M a
-
-    check_group_consistency sel []	       = panic "Rename2: runs produced an empty list"
-    check_group_consistency sel (thing:things) = foldrRn12 sel thing things
-\end{code}
-
-@selByBetterName@: There are two ways one thing can have a ``better
-name'' than another.
-
-First: Something with an @Unk@ name is declared in this module, so we
-keep that, rather than something from an interface (with an @Imp@
-name, probably).
-
-Second: If we have two non-@Unk@ names, but one ``informant module''
-is also the {\em original} module for the entity, then we choose that
-one.  I.e., if one interface says, ``I am the module that created this
-thing'' then we believe it and take that one.
-
-If we can't figure out which one to choose by the names, we use the
-info provided to select based on the pragmas.
-
-LATER: but surely we have to worry about different-by-original-name
-things which are same-by-local-name things---these should be reported
-as errors.
-
-\begin{code}
-selByBetterName :: String   -- class/datatype/synonym (for error msg)
-
-		-- 1st/2nd comparee name/pragmas + their things
-		-> ProtoName -> pragmas -> SrcLoc -> thing
-		-> ProtoName -> pragmas -> SrcLoc -> thing
-
-		-- a thing without its pragmas
-		-> (pragmas -> thing)
-
-		-- choose-by-pragma function
-		-> ((pragmas -> thing)		    -- thing minus its pragmas
-		    -> pragmas -> SrcLoc -> thing   -- comparee 1
-		    -> pragmas -> SrcLoc -> thing   -- comparee 2
-		    -> Rn12M thing )	    	    -- thing w/ its new pragmas
-
-		-> Rn12M thing		-- selected thing
-
-selByBetterName dup_msg
-		pn1 pragmas1 locn1 thing1
-		pn2 pragmas2 locn2 thing2
-		thing_wout_pragmas
-		chooser
-  = getModuleNameRn12	`thenRn12` \ mod_name ->
-    let
-	choose_thing1	= chk_eq (returnRn12 thing1)
-	choose_thing2   = chk_eq (returnRn12 thing2)
-	check_n_choose  = chk_eq (chooser thing_wout_pragmas
-					  pragmas1 locn1 thing1
-					  pragmas2 locn2 thing2)
-
-	dup_error = report_dup dup_msg pn1 locn1 pn2 locn2 thing1
-    in
-    case pn1 of
-      Unk _  -> case pn2 of
-		 Unk _	-> dup_error
-		 _	-> if orig_modules_clash mod_name pn2
-			    then dup_error
-			    else choose_thing1
-
-      Prel _ -> case pn2 of
-		 Unk _	-> if orig_modules_clash mod_name pn1
-			   then dup_error
-			   else choose_thing2
-		 _	-> check_n_choose
-
-      Imp om1 _ im1 _ -> -- we're gonna check `informant module' info...
-	case pn2 of
-	  Unk _		  -> if orig_modules_clash mod_name pn1
-			     then dup_error
-			     else choose_thing2
-	  Prel _	  -> check_n_choose
-	  Imp om2 _ im2 _
-	    -> let
-		   is_elem = isIn "selByBetterName"
-
-		   name1_claims_orig = om1 `is_elem` im1 && not (_NULL_ om1)
-		   name2_claims_orig = om2 `is_elem` im2 && not (_NULL_ om2)
-	       in
-	       if name1_claims_orig
-	       then if name2_claims_orig then check_n_choose else choose_thing1
-	       else if name2_claims_orig then choose_thing2  else check_n_choose
-  where
-    chk_eq if_OK
-      = if not (eqProtoName pn1 pn2) && eqByLocalName pn1 pn2
-	then report_dup dup_msg pn1 locn1 pn2 locn2 thing1
-	else if_OK
-
-    orig_modules_clash this_module pn
-      = case (getOrigName pn) of { (that_module, _) ->
-	not (this_module == that_module) }
-
-report_dup dup_msg pn1 locn1 pn2 locn2 thing
-  = addErrRn12 err_msg `thenRn12` \ _ ->
-    returnRn12 thing
-  where
-    err_msg = dupNamesErr dup_msg [(pn1,locn1), (pn2,locn2)]
-
-pRAGMA_ERROR :: String -> a -> Rn12M a
-pRAGMA_ERROR msg x
-  = addErrRn12 (\ sty -> ppStr ("PRAGMA ERROR:"++msg)) `thenRn12` \ _ ->
-    returnRn12 x
-\end{code}
diff --git a/ghc/compiler/rename/Rename3.hi b/ghc/compiler/rename/Rename3.hi
deleted file mode 100644
index 484bf85563..0000000000
--- a/ghc/compiler/rename/Rename3.hi
+++ /dev/null
@@ -1,42 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface Rename3 where
-import AbsSyn(Module)
-import Bag(Bag)
-import FiniteMap(FiniteMap)
-import HsBinds(Binds, Sig)
-import HsDecls(ClassDecl, DataTypeSig, DefaultDecl, FixityDecl, InstDecl, SpecialisedInstanceSig, TyDecl)
-import HsImpExp(IE, ImportedInterface)
-import HsLit(Literal)
-import HsPat(InPat, ProtoNamePat(..))
-import Id(Id)
-import Maybes(Labda)
-import Name(Name)
-import NameTypes(FullName, ShortName)
-import Outputable(ExportFlag)
-import PreludePS(_PackedString)
-import Pretty(PprStyle, Pretty(..), PrettyRep)
-import ProtoName(ProtoName)
-import RenameAuxFuns(PreludeNameFun(..), PreludeNameFuns(..))
-import RenameMonad3(Rn3M(..), initRn3)
-import SplitUniq(SplitUniqSupply)
-import SrcLoc(SrcLoc)
-import TyCon(TyCon)
-import Unique(Unique)
-data Module a b 
-data Bag a 
-data InPat a 
-type ProtoNamePat = InPat ProtoName
-data Labda a 
-data Name 
-data ExportFlag 
-data PprStyle 
-type Pretty = Int -> Bool -> PrettyRep
-data PrettyRep 
-data ProtoName 
-type PreludeNameFun = _PackedString -> Labda Name
-type PreludeNameFuns = (_PackedString -> Labda Name, _PackedString -> Labda Name)
-type Rn3M a = (FiniteMap _PackedString ExportFlag, FiniteMap _PackedString ()) -> _PackedString -> SplitUniqSupply -> a
-data SplitUniqSupply 
-initRn3 :: ((FiniteMap _PackedString ExportFlag, FiniteMap _PackedString ()) -> _PackedString -> SplitUniqSupply -> a) -> SplitUniqSupply -> a
-rnModule3 :: (_PackedString -> Labda Name, _PackedString -> Labda Name) -> [_PackedString] -> Module ProtoName (InPat ProtoName) -> (FiniteMap _PackedString ExportFlag, FiniteMap _PackedString ()) -> _PackedString -> SplitUniqSupply -> ([(ProtoName, Name)], [(ProtoName, Name)], ProtoName -> Labda Name, ProtoName -> Labda Name, Bag (PprStyle -> Int -> Bool -> PrettyRep))
-
diff --git a/ghc/compiler/rename/Rename3.lhs b/ghc/compiler/rename/Rename3.lhs
deleted file mode 100644
index 845a2144f9..0000000000
--- a/ghc/compiler/rename/Rename3.lhs
+++ /dev/null
@@ -1,559 +0,0 @@
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
-%
-\section[Rename-three]{Third of the renaming passes}
-
-The business of this pass is to:
-\begin{itemize}
-\item	find all the things declared at top level,
-\item	assign uniques to them
-\item return an association list mapping their @ProtoName@s to
-	freshly-minted @Names@ for them.
-\end{itemize}
-
-No attempt is made to discover whether the same thing is declared
-twice: that is up to the caller to sort out.
-
-\begin{code}
-#include "HsVersions.h"
-
-module Rename3 (
-	rnModule3,
-	initRn3, Rn3M(..),  -- re-exported from monad
-
-	-- for completeness
-	Module, Bag, ProtoNamePat(..), InPat, Maybe, Name,
-	ExportFlag, PprStyle, Pretty(..), PrettyRep, ProtoName,
-	PreludeNameFun(..), PreludeNameFuns(..), SplitUniqSupply
-    ) where
-
-import AbsSyn
-import Bag		-- lots of stuff
-import Errors		( dupNamesErr, dupPreludeNameErr,
-			  badExportNameErr, badImportNameErr,
-			  Error(..)
-			)
-import HsCore		-- ****** NEED TO SEE CONSTRUCTORS ******
-import HsPragmas	-- ****** NEED TO SEE CONSTRUCTORS ******
-import FiniteMap
-import Maybes		( Maybe(..) )
-import Name		( Name(..) )
-import NameTypes	( fromPrelude, FullName )
-import ProtoName
-import RenameAuxFuns	( mkGlobalNameFun,
-			  GlobalNameFuns(..), GlobalNameFun(..),
-			  PreludeNameFuns(..), PreludeNameFun(..)
-			)
-import RenameMonad3
-import SrcLoc		( mkUnknownSrcLoc, SrcLoc )
-import Util
-\end{code}
-
-*********************************************************
-*							*
-\subsection{Type declarations}
-*							*
-*********************************************************
-
-\begin{code}
-type BagAssoc 	    = Bag (ProtoName, Name)	-- Bag version
-type NameSpaceAssoc = [(ProtoName, Name)]	-- List version
-\end{code}
-
-
-*********************************************************
-*							*
-\subsection{Main function: @rnModule3@}
-*							*
-*********************************************************
-
-\begin{code}
-rnModule3 :: PreludeNameFuns
-	  -> [FAST_STRING]	-- list of imported module names
-	  -> ProtoNameModule
-	  -> Rn3M ( NameSpaceAssoc, NameSpaceAssoc,
-		    GlobalNameFun,  GlobalNameFun,
-		    Bag Error )
-
-rnModule3 pnfs@(val_pnf, tc_pnf) imported_mod_names
-	  (Module mod_name exports imports _ ty_decls _ class_decls
-	    inst_decls _ _ binds sigs _)
-
-  = putInfoDownM3 {- ???pnfs -} mod_name exports (
-
-    doTyDecls3 ty_decls		`thenRn3` \ (constrs, tycons) ->
-    doClassDecls3 class_decls	`thenRn3` \ (ops, classes) ->
-    doBinds3 binds		`thenRn3` \ val_binds ->
-    doIntSigs3 sigs		`thenRn3` \ val_sigs ->
-
-    let val_namespace	= constrs `unionBags` ops `unionBags` val_binds
-				  `unionBags` val_sigs
-	tc_namespace	= tycons `unionBags` classes
-
-	(var_alist, var_dup_errs) = deal_with_dups "variable" val_pnf (bagToList val_namespace)
-	(tc_alist, tc_dup_errs)	  = deal_with_dups "type or class" tc_pnf (bagToList tc_namespace)
-	v_gnf  = mkGlobalNameFun mod_name val_pnf var_alist
-    	tc_gnf = mkGlobalNameFun mod_name tc_pnf  tc_alist
-    in
-
-    verifyExports v_gnf tc_gnf (mod_name : imported_mod_names) exports
-					`thenRn3` \ export_errs ->
-    verifyImports v_gnf tc_gnf imports	`thenRn3` \ import_errs ->
-
-    returnRn3 ( var_alist, tc_alist,
-		v_gnf, tc_gnf,
-		var_dup_errs `unionBags` tc_dup_errs `unionBags`
-		export_errs  `unionBags` import_errs
-    ))
-  where
-    deal_with_dups :: String -> PreludeNameFun -> NameSpaceAssoc
-		   -> (NameSpaceAssoc, Bag Error)
-
-    deal_with_dups kind_str pnf alist
-      = (goodies,
-	 listToBag (map mk_dup_err dup_lists) `unionBags`
-	 listToBag (map mk_prel_dup_err prel_dups) 
-	)
-      where
-	goodies   :: [(ProtoName,Name)]		--NameSpaceAssoc
-	dup_lists :: [[(ProtoName, Name)]]
-
-	-- Find all the names which are defined twice.
-	-- By "name" here, we mean "string"; that is, we are looking
-	-- for places where two strings are bound to different Names
-	-- in the top-level scope of this module.
-
-	(singles, dup_lists) = removeDups cmp alist
-	-- We want to compare their *local* names; the removeDups thing
-	-- is checking for whether two objects have the same local name.
-	cmp (a, _) (b, _) = cmpByLocalName a b
-
-	-- Anything in alist with a Unk name is defined right here in
-	-- this module; hence, it should not be a prelude name.  We
-	-- need to check this separately, because the prelude is
-	-- imported only implicitly, via the PrelNameFuns argument
-
-	(goodies, prel_dups) = if fromPrelude mod_name then
-				 (singles, [])	-- Compiling the prelude, so ignore this check
-			       else	
-				 partition local_def_of_prelude_thing singles
-
-	local_def_of_prelude_thing (Unk s, _)
-	  = case pnf s of 
-	      Just _  -> False		-- Eek!  It's a prelude name
-	      Nothing -> True		-- It isn't; all is ok
-	local_def_of_prelude_thing other = True
-
-	mk_dup_err :: [(ProtoName, Name)] -> Error
-	mk_dup_err dups_of_name
-	  = let
-		dup_pnames_w_src_loc = [ (pn, getSrcLoc name) | (pn,name) <- dups_of_name ]
-	    in
-	    dupNamesErr kind_str dup_pnames_w_src_loc
-
-	-- This module defines a prelude thing
-	mk_prel_dup_err :: (ProtoName, Name) -> Error
-	mk_prel_dup_err (pn, name)
-	  = dupPreludeNameErr kind_str (pn, getSrcLoc name)
-\end{code}
-
-*********************************************************
-*							*
-\subsection{Type and class declarations}
-*							*
-*********************************************************
-
-\begin{code}
-doTyDecls3 :: [ProtoNameTyDecl] -> Rn3M (BagAssoc, BagAssoc)
-
-doTyDecls3 [] = returnRn3 (emptyBag, emptyBag)
-
-doTyDecls3 (tyd:tyds)
-  = andRn3 combiner (do_decl tyd) (doTyDecls3 tyds)
-  where
-    combiner (cons1, tycons1) (cons2, tycons2)
-      = (cons1 `unionBags` cons2, tycons1 `unionBags` tycons2)
-
-    do_decl (TyData context tycon tyvars condecls deriv pragmas src_loc)
-      = newFullNameM3 tycon src_loc True{-tycon-ish-} Nothing
-					`thenRn3` \ (uniq, tycon_name) ->
-    	let
-	    exp_flag = getExportFlag tycon_name
-		-- we want to force all data cons to have the very
-		-- same export flag as their type constructor
-	in
-	doConDecls3 False{-not invisibles-} exp_flag condecls `thenRn3` \ data_cons ->
-	do_data_pragmas exp_flag pragmas		      `thenRn3` \ pragma_data_cons ->
-	returnRn3 (data_cons `unionBags` pragma_data_cons,
-		   unitBag (tycon, OtherTyCon uniq tycon_name (length tyvars)
-					True -- indicates @data@ tycon
-					[ c | (_,c) <- bagToList data_cons ]))
-			
-
-    do_decl (TySynonym tycon tyvars monoty pragmas src_loc)
-      = newFullNameM3 tycon src_loc True{-tycon-ish-} Nothing
-					`thenRn3` \ (uniq, tycon_name) ->
-	returnRn3 (emptyBag,
-		   unitBag (tycon, OtherTyCon uniq tycon_name (length tyvars) False bottom))
-					-- False indicates @type@ tycon
-      where
-	bottom = panic "do_decl: data cons on synonym?"
-
-    do_data_pragmas exp_flag (DataPragmas con_decls specs)
-      = doConDecls3 True{-invisibles-} exp_flag con_decls
-\end{code}
-
-\begin{code}
-doConDecls3 :: Bool		    -- True <=> mk invisible FullNames
-	    -> ExportFlag	    -- Export flag of the TyCon; we want
-				    -- to force its use.
-	    -> [ProtoNameConDecl]
-	    -> Rn3M BagAssoc
-
-doConDecls3 _ _ [] = returnRn3 emptyBag
-
-doConDecls3 want_invisibles exp_flag (cd:cds)
-  = andRn3 unionBags (do_decl cd) (doConDecls3 want_invisibles exp_flag cds)
-  where
-    mk_name = if want_invisibles then newInvisibleNameM3 else newFullNameM3
-
-    do_decl (ConDecl con tys src_loc)
-      = mk_name con src_loc True{-tycon-ish-} (Just exp_flag) `thenRn3` \ (uniq, con_name) ->
-	returnRn3 (unitBag (con, OtherTopId uniq con_name))
-\end{code}
-
-
-@doClassDecls3@ uses the `name function' to map local class names into
-original names, calling @doClassOps3@ to do the same for the
-class operations. @doClassDecls3@ is used to process module
-class declarations.
-
-\begin{code}
-doClassDecls3 :: [ProtoNameClassDecl] -> Rn3M (BagAssoc, BagAssoc)
-
-doClassDecls3 [] = returnRn3 (emptyBag, emptyBag)
-
-doClassDecls3 (cd:cds)
-  = andRn3 combiner (do_decl cd) (doClassDecls3 cds)
-  where
-    combiner (ops1, classes1) (ops2, classes2)
-      = (ops1 `unionBags` ops2, classes1 `unionBags` classes2)
-
-    do_decl (ClassDecl context cname@(Prel c) tyvar sigs defaults pragmas src_loc)
-      = doClassOps3 c 1 sigs	`thenRn3` \ (_, ops) ->
-	returnRn3 (ops, unitBag (cname, c))
-
-    do_decl (ClassDecl context cname tyvar sigs defaults pragmas src_loc)
-      = newFullNameM3 cname src_loc True{-tycon-ish-} Nothing
-					`thenRn3` \ (uniq, class_name) ->
-	fixRn3 ( \ ~(clas_ops,_) ->
-	    let
-		class_Name = OtherClass uniq class_name
-					[ o | (_,o) <- bagToList clas_ops ]
-	    in
-	    doClassOps3 class_Name 1 sigs   `thenRn3` \ (_, ops) ->
-	    returnRn3 (ops, class_Name)
-	)				`thenRn3` \ (ops, class_Name) ->
-
-	returnRn3 (ops, unitBag (cname, class_Name))
-\end{code}
-
-We stitch on a class-op tag to each class operation.  They are guaranteed
-to be done in left-to-right order.
-
-\begin{code}
-doClassOps3 :: Name{-class-} -> Int -> [ProtoNameSig] -> Rn3M (Int, BagAssoc)
-
-doClassOps3 clas tag [] = returnRn3 (tag, emptyBag)
-
-doClassOps3 clas tag (sig:rest)
-  = do_op		  sig	`thenRn3` \ (tag1, bag1) ->
-    doClassOps3 clas tag1 rest	`thenRn3` \ (tagr, bagr) ->
-    returnRn3 (tagr, bag1 `unionBags` bagr)
-  where
-    do_op (ClassOpSig op ty pragma src_loc)
-      = newFullNameM3 op src_loc False{-not tyconish-} Nothing `thenRn3` \ (uniq, _) ->
-	let
-	    op_name = ClassOpName uniq clas (get_str op) tag
-	in
-	returnRn3 (tag+1, unitBag (op, op_name))
-      where
-	-- A rather yukky function to get the original name out of a class operation.
-	get_str :: ProtoName -> FAST_STRING
-	get_str (Unk s)       = s
-	get_str (Imp _ d _ _) = d
-\end{code}
-
-Remember, interface signatures don't have user-pragmas, etc., in them.
-\begin{code}
-doIntSigs3 :: [ProtoNameSig] -> Rn3M BagAssoc
-
-doIntSigs3 [] = returnRn3 emptyBag
-
-doIntSigs3 (s:ss)
-  = andRn3 unionBags (do_sig s) (doIntSigs3 ss)
-  where
-    do_sig (Sig v ty pragma src_loc)
-      = newFullNameM3 v src_loc False{-distinctly untycon-ish-} Nothing
-					     `thenRn3` \ (uniq, v_fname) ->
-	returnRn3 (unitBag (v, OtherTopId uniq v_fname))
-\end{code}
-
-*********************************************************
-*							*
-\subsection{Bindings}
-*							*
-*********************************************************
-
-\begin{code}
-doBinds3 :: ProtoNameBinds -> Rn3M BagAssoc
-
-doBinds3 EmptyBinds = returnRn3 emptyBag
-
-doBinds3 (ThenBinds binds1 binds2)
-  = andRn3 unionBags (doBinds3 binds1) (doBinds3 binds2)
-
-doBinds3 (SingleBind bind)    = doBind3 bind
-
-doBinds3 (BindWith bind sigs) = doBind3 bind
-\end{code}
-
-\begin{code}
-doBind3 :: ProtoNameBind -> Rn3M BagAssoc
-doBind3 EmptyBind          = returnRn3 emptyBag
-doBind3 (NonRecBind mbind) = doMBinds3 mbind
-doBind3 (RecBind mbind)    = doMBinds3 mbind
-
-doMBinds3 :: ProtoNameMonoBinds -> Rn3M BagAssoc
-
-doMBinds3 EmptyMonoBinds 			 = returnRn3 emptyBag
-doMBinds3 (PatMonoBind pat grhss_and_binds locn) = doPat3 locn pat
-doMBinds3 (FunMonoBind p_name _ locn) 		 = doTopLevName locn p_name
-
-doMBinds3 (AndMonoBinds mbinds1 mbinds2)
-  = andRn3 unionBags (doMBinds3 mbinds1) (doMBinds3 mbinds2)
-\end{code}
-
-Fold over a list of patterns:
-\begin{code}
-doPats3 locn [] = returnRn3 emptyBag
-doPats3 locn (pat:pats)
-  = andRn3 unionBags (doPat3 locn pat) (doPats3 locn pats)
-\end{code}
-
-\begin{code}
-doPat3 :: SrcLoc -> ProtoNamePat -> Rn3M BagAssoc
-
-doPat3 locn WildPatIn       	= returnRn3 emptyBag
-doPat3 locn (LitPatIn _) 	= returnRn3 emptyBag
-doPat3 locn (LazyPatIn pat) 	= doPat3 locn pat
-doPat3 locn (VarPatIn n) 	= doTopLevName locn n
-doPat3 locn (ListPatIn pats)	= doPats3 locn pats
-doPat3 locn (TuplePatIn pats)	= doPats3 locn pats
-doPat3 locn (NPlusKPatIn n _)	= doTopLevName locn n
-
-doPat3 locn (AsPatIn p_name pat)
-  = andRn3 unionBags (doTopLevName locn p_name) (doPat3 locn pat)
-
-doPat3 locn (ConPatIn name pats) = doPats3 locn pats
-
-doPat3 locn (ConOpPatIn pat1 name pat2)
-  = andRn3 unionBags (doPat3 locn pat1) (doPat3 locn pat2)
-
-#ifdef DPH
-doPat3 locn (ProcessorPatIn pats pat)
-  = andRn3 unionBags (doPats3 locn pats) (doPat3 locn pat)
-#endif {- Data Parallel Haskell -}
-\end{code}
-
-\begin{code}
-doTopLevName :: SrcLoc -> ProtoName -> Rn3M BagAssoc
-
-doTopLevName locn pn
-  = newFullNameM3 pn locn False{-un-tycon-ish-}	Nothing `thenRn3` \ (uniq, name) ->
-    returnRn3 (unitBag (pn, OtherTopId uniq name))
-\end{code}
-
-Have to check that export/imports lists aren't too drug-crazed.
-
-\begin{code}
-verifyExports :: GlobalNameFun -> GlobalNameFun
-	      -> [FAST_STRING]	-- module names that might appear
-				-- in an export list; includes the
-				-- name of this module
-	      -> [IE]		-- export list
-	      -> Rn3M (Bag Error)
-
-verifyExports v_gnf tc_gnf imported_mod_names exports
-  = mapRn3 verify exports	`thenRn3` \ errs ->
-    chk_exp_dups  exports	`thenRn3` \ dup_errs ->
-    returnRn3 (unionManyBags (errs ++ dup_errs))
-  where
-    present nf str = nf (Unk str)
-
-    ok	    	   = returnRn3 emptyBag
-    naughty nm msg = returnRn3 (unitBag (badExportNameErr (_UNPK_ nm) msg))
-    undef_name nm  = naughty nm "is not defined."
-    dup_name (nm:_)= naughty nm "occurs more than once."
-
-    ----------------
-    chk_exp_dups exports
-      = let
-	    export_strs = [ nm | (nm, _) <- fst (getRawIEStrings exports) ]
-	    (_, dup_lists) = removeDups _CMP_STRING_ export_strs
-	in
-	mapRn3 dup_name dup_lists
-
-    ---------------- the more serious checking
-    verify (IEVar v)
-      = case (present v_gnf v) of { Nothing -> undef_name v; _ -> ok }
-
-    verify (IEModuleContents mod)
-      = if not (mod `is_elem` imported_mod_names) then undef_name mod else ok
-      where
-	is_elem = isIn "verifyExports"
-
-    verify (IEThingAbs tc) 
-      = case (present tc_gnf tc) of
-	  Nothing -> undef_name tc
-	  Just nm -> case nm of
-		       PreludeTyCon _ _ _ False{-syn-}
-			 -> naughty tc "must be exported with a `(..)' -- it's a Prelude synonym."
-		       OtherTyCon _ _ _ False{-syn-} _
-			 -> naughty tc "must be exported with a `(..)' -- it's a synonym."
-
-		       PreludeClass _ _
-		         -> naughty tc "cannot be exported \"abstractly\" (it's a Prelude class)."
-		       OtherClass _ _ _
-		         -> naughty tc "cannot be exported \"abstractly\" (it's a class)."
-		       _ -> ok
-
-    verify (IEThingAll tc)
-      = case (present tc_gnf tc) of
-	  Nothing -> undef_name tc
-	  Just nm -> case nm of
-		       OtherTyCon _ _ _ True{-data-} [{-no cons-}]
-			 -> naughty tc "can't be exported with a `(..)' -- it was imported abstractly."
-		       _ -> ok
-
-    verify (IEConWithCons tc cs)
-      = case (present tc_gnf tc) of
-	  Nothing -> undef_name tc
-	  Just nm -> mapRn3 verify (map IEVar cs) `thenRn3` \ errs ->
-		     returnRn3 (unionManyBags errs)
-		     -- ToDo: turgid checking which we don't care about (WDP 94/10)
-
-    verify (IEClsWithOps c ms)
-      = case (present tc_gnf c) of
-	  Nothing -> undef_name c
-	  Just  _ -> mapRn3 verify (map IEVar ms) `thenRn3` \ errs ->
-		     returnRn3 (unionManyBags errs)
-		     -- ToDo: turgid checking which we don't care about (WDP 94/10)
-\end{code}
-
-Note: we're not too particular about whether something mentioned in an
-import list is in {\em that} interface... (ToDo? Probably not.)
-
-\begin{code}
-verifyImports :: GlobalNameFun -> GlobalNameFun
-	      -> [ProtoNameImportedInterface]
-	      -> Rn3M (Bag Error)
-
-verifyImports v_gnf tc_gnf imports
-  = mapRn3 chk_one (map collect imports) `thenRn3` \ errs ->
-    returnRn3 (unionManyBags errs)
-  where
-    -- collect: name/locn, import list, renamings list
-
-    collect (ImportAll     iff renamings)
-      = (iface iff, [],       [],       renamings)
-    collect (ImportSome    iff imp_list renamings)
-      = (iface iff, imp_list, [],   	 renamings)
-    collect (ImportButHide iff hide_list renamings)
-      = (iface iff, [],        hide_list, renamings)
-
-    ------------
-    iface (MkInterface name _ _ _ _ _ _ locn) = (name, locn)
-
-    ------------
-    chk_one :: ((FAST_STRING, SrcLoc), [IE], [IE], [Renaming])
-	    -> Rn3M (Bag Error)
-
-    chk_one ((mod_name, locn), import_list, hide_list, renamings)
-      = mapRn3 verify import_list   `thenRn3` \ errs1 ->
-	chk_imp_dups  import_list   `thenRn3` \ dup_errs ->
-	-- ToDo: we could check the hiding list more carefully
-	chk_imp_dups  hide_list	    `thenRn3` \ dup_errs2 ->
-	mapRn3 chk_rn renamings	    `thenRn3` \ errs2 ->
-    	returnRn3 (unionManyBags (errs1 ++ dup_errs ++ dup_errs2 ++ errs2))
-      where
-	present nf str = nf (Unk (rename_it str))
-
-	rename_it str
-	  = case [ too | (MkRenaming from too) <- renamings, str == from ] of
-	      []    -> str
-	      (x:_) -> x
-
-	ok	          = returnRn3 emptyBag
-	naughty nm msg    = returnRn3 (unitBag (badImportNameErr (_UNPK_ mod_name) (_UNPK_ nm) msg locn))
-	undef_name nm     = naughty nm "is not defined."
-	undef_rn_name n r = naughty n  ("is not defined (renamed to `"++ _UNPK_ r ++"').")
-	dup_name (nm:_)   = naughty nm "occurs more than once."
-
-	----------------
-	chk_imp_dups imports
-	  = let
-		import_strs = [ nm | (nm, _) <- fst (getRawIEStrings imports) ]
-		(_, dup_lists) = removeDups _CMP_STRING_ import_strs
-	    in
-	    mapRn3 dup_name dup_lists
-
-	----------------
-	chk_rn (MkRenaming from too)	    -- Note: "present" will rename
-	  = case (present v_gnf from) of    -- the "from" to the "too"...
-	      Just  _ -> ok
-	      Nothing -> case (present tc_gnf from) of
-			   Just  _ -> ok
-			   Nothing -> undef_rn_name from too
-
-	----------------
-	verify (IEVar v)
-	  = case (present v_gnf v) of { Nothing -> undef_name v; _ -> ok }
-
-	verify (IEThingAbs tc) 
-	  = case (present tc_gnf tc) of
-	      Nothing -> undef_name tc
-	      Just nm -> case nm of
-			   PreludeTyCon _ _ _ False{-syn-}
-			     -> naughty tc "must be imported with a `(..)' -- it's a Prelude synonym."
-			   OtherTyCon _ _ _ False{-syn-} _
-			     -> naughty tc "must be imported with a `(..)' -- it's a synonym."
-			   PreludeClass _ _
-			     -> naughty tc "cannot be imported \"abstractly\" (it's a Prelude class)."
-			   OtherClass _ _ _
-			     -> naughty tc "cannot be imported \"abstractly\" (it's a class)."
-			   _ -> ok
-
-	verify (IEThingAll tc)
-	  = case (present tc_gnf tc) of
-	      Nothing -> undef_name tc
-	      Just nm -> case nm of
-			   OtherTyCon _ _ _ True{-data-} [{-no cons-}]
-			     -> naughty tc "can't be imported with a `(..)' -- the interface says it's abstract."
-			   _ -> ok
-
-	verify (IEConWithCons tc cs)
-	  = case (present tc_gnf tc) of
-	      Nothing -> undef_name tc
-	      Just nm -> mapRn3 verify (map IEVar cs) `thenRn3` \ errs ->
-			 returnRn3 (unionManyBags errs)
-			 -- One could add a great wad of tedious checking
-			 -- here, but I am too lazy to do so.  WDP 94/10
-
-	verify (IEClsWithOps c ms)
-	  = case (present tc_gnf c) of
-	      Nothing -> undef_name c
-	      Just  _ -> mapRn3 verify (map IEVar ms) `thenRn3` \ errs ->
-			 returnRn3 (unionManyBags errs)
-			 -- Ditto about tedious checking.  WDP 94/10
-\end{code}
diff --git a/ghc/compiler/rename/Rename4.hi b/ghc/compiler/rename/Rename4.hi
deleted file mode 100644
index 2e48e8a576..0000000000
--- a/ghc/compiler/rename/Rename4.hi
+++ /dev/null
@@ -1,51 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface Rename4 where
-import AbsSyn(Module)
-import Bag(Bag)
-import CharSeq(CSeq)
-import CmdLineOpts(GlobalSwitch)
-import ErrUtils(Error(..))
-import FiniteMap(FiniteMap)
-import HsBinds(Binds, Sig)
-import HsDecls(ClassDecl, DataTypeSig, DefaultDecl, FixityDecl, InstDecl, SpecialisedInstanceSig, TyDecl)
-import HsImpExp(IE, ImportedInterface)
-import HsLit(Literal)
-import HsPat(InPat, ProtoNamePat(..), RenamedPat(..))
-import HsPragmas(GenPragmas)
-import HsTypes(MonoType, PolyType)
-import Id(Id)
-import Maybes(Labda)
-import Name(Name)
-import NameTypes(FullName, ShortName)
-import PreludePS(_PackedString)
-import Pretty(Delay, PprStyle, Pretty(..), PrettyRep)
-import ProtoName(ProtoName)
-import RenameAuxFuns(GlobalNameFun(..))
-import RenameMonad4(Rn4M(..), TyVarNamesEnv(..), initRn4)
-import SplitUniq(SplitUniqSupply)
-import SrcLoc(SrcLoc)
-import TyCon(TyCon)
-import Unique(Unique)
-data Module a b 
-data Bag a 
-type Error = PprStyle -> Int -> Bool -> PrettyRep
-data InPat a 
-type ProtoNamePat = InPat ProtoName
-type RenamedPat = InPat Name
-data PolyType a 
-data Labda a 
-data Name 
-data PprStyle 
-type Pretty = Int -> Bool -> PrettyRep
-data PrettyRep 
-data ProtoName 
-type GlobalNameFun = ProtoName -> Labda Name
-type Rn4M a = (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (a, Bag (PprStyle -> Int -> Bool -> PrettyRep))
-type TyVarNamesEnv = [(ProtoName, Name)]
-data SplitUniqSupply 
-data SrcLoc 
-initRn4 :: (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> ((GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (a, Bag (PprStyle -> Int -> Bool -> PrettyRep))) -> SplitUniqSupply -> (a, Bag (PprStyle -> Int -> Bool -> PrettyRep))
-rnGenPragmas4 :: GenPragmas ProtoName -> (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (GenPragmas Name, Bag (PprStyle -> Int -> Bool -> PrettyRep))
-rnModule4 :: Module ProtoName (InPat ProtoName) -> (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (Module Name (InPat Name), Bag (PprStyle -> Int -> Bool -> PrettyRep))
-rnPolyType4 :: Bool -> Bool -> [(ProtoName, Name)] -> PolyType ProtoName -> (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (PolyType Name, Bag (PprStyle -> Int -> Bool -> PrettyRep))
-
diff --git a/ghc/compiler/rename/Rename4.lhs b/ghc/compiler/rename/Rename4.lhs
deleted file mode 100644
index ab61d94fb0..0000000000
--- a/ghc/compiler/rename/Rename4.lhs
+++ /dev/null
@@ -1,836 +0,0 @@
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
-%
-\section[Rename4]{Fourth of the renaming passes}
-
-\begin{code}
-#include "HsVersions.h"
-
-module Rename4 (
-	rnModule4, rnPolyType4, rnGenPragmas4,
-
-	initRn4, Rn4M(..), TyVarNamesEnv(..),  -- re-exported from the monad
-
-	-- for completeness
-
-	Module, Bag, InPat, ProtoNamePat(..), RenamedPat(..),
-	PolyType, Maybe, Name, ProtoName, GlobalNameFun(..),
-	SrcLoc, SplitUniqSupply, Error(..), PprStyle,
-	Pretty(..), PrettyRep
-    ) where
-
-IMPORT_Trace		-- ToDo: rm (debugging)
-import Outputable
-import Pretty
-
-import AbsSyn
-import AbsUniType	( derivableClassKeys )
-import Errors
-import HsCore		-- ****** NEED TO SEE CONSTRUCTORS ******
-import HsPragmas	-- ****** NEED TO SEE CONSTRUCTORS ******
-import Maybes		( catMaybes, maybeToBool, Maybe(..) )
-import ProtoName	( eqProtoName, elemProtoNames )
-import RenameBinds4	( rnTopBinds4, rnMethodBinds4 )
-import RenameMonad4
-import Util
-\end{code}
-
-This pass `renames' the module+imported info, simultaneously
-performing dependency analysis. It also does the following error
-checks:
-\begin{enumerate}
-\item
-Checks that tyvars are used properly. This includes checking
-for undefined tyvars, and tyvars in contexts that are ambiguous.
-\item
-Checks that local variables are defined.	
-\end{enumerate}
-
-\begin{code}
-rnModule4 :: ProtoNameModule -> Rn4M RenamedModule
-
-rnModule4 (Module mod_name exports _ fixes ty_decls absty_sigs
-	    class_decls inst_decls specinst_sigs defaults
-	    binds int_sigs src_loc)
-
-  = pushSrcLocRn4 src_loc			  (
-
-    mapRn4 rnTyDecl4 ty_decls	    	`thenRn4` \ new_ty_decls ->
-
-    mapRn4 rnTySig4 absty_sigs		`thenRn4` \ new_absty_sigs ->
-
-    mapRn4 rnClassDecl4 class_decls	`thenRn4` \ new_class_decls ->
-
-    mapRn4 rnInstDecl4 inst_decls	`thenRn4` \ new_inst_decls ->
-
-    mapRn4 rnInstSpecSig4 specinst_sigs `thenRn4` \ new_specinst_sigs ->
-
-    mapRn4 rnDefaultDecl4 defaults	`thenRn4` \ new_defaults ->
-
-    rnTopBinds4 binds		    	`thenRn4` \ new_binds ->
-
-    mapRn4 rnIntSig4 int_sigs	    	`thenRn4` \ new_int_sigs ->
-
-    rnFixes4 fixes			`thenRn4` \ new_fixes ->
-
-    returnRn4 (Module mod_name
-		exports [{-imports finally clobbered-}] new_fixes
-		new_ty_decls new_absty_sigs new_class_decls
-		new_inst_decls new_specinst_sigs new_defaults
-		new_binds new_int_sigs src_loc)
-    )
-\end{code}
-
-
-%*********************************************************
-%*							*
-\subsection{Type declarations}
-%*							*
-%*********************************************************
-
-@rnTyDecl4@ uses the `global name function' to create a new type
-declaration in which local names have been replaced by their original
-names, reporting any unknown names.
-
-Renaming type variables is a pain. Because they now contain uniques,
-it is necessary to pass in an association list which maps a parsed
-tyvar to its Name representation. In some cases (type signatures of
-values), it is even necessary to go over the type first in order to
-get the set of tyvars used by it, make an assoc list, and then go over
-it again to rename the tyvars! However, we can also do some scoping
-checks at the same time.
-
-\begin{code}
-rnTyDecl4 :: ProtoNameTyDecl -> Rn4M RenamedTyDecl
-
-rnTyDecl4 (TyData context tycon tyvars condecls derivings pragmas src_loc)
-  = pushSrcLocRn4 src_loc		        (
-    lookupTyCon tycon		      `thenRn4` \ tycon' ->
-    mkTyVarNamesEnv src_loc tyvars    `thenRn4` \ (tv_env, tyvars') ->
-    rnContext4 tv_env context	      `thenRn4` \ context' ->
-    rnConDecls4 tv_env False condecls `thenRn4` \ condecls' ->
-    mapRn4 (rn_deriv tycon' src_loc) derivings `thenRn4` \ derivings' ->
-    recoverQuietlyRn4 (DataPragmas [] []) (
-	rnDataPragmas4 tv_env pragmas
-    )				      `thenRn4` \ pragmas' ->
-    returnRn4 (TyData context' tycon' tyvars' condecls' derivings' pragmas' src_loc)
-    )
-  where
-    rn_deriv tycon2 locn deriv
-      = lookupClass deriv	    `thenRn4` \ clas_name ->
-	case clas_name of
-	  PreludeClass key _ | key `is_elem` derivableClassKeys
-	    -> returnRn4 clas_name
-	  _ -> addErrRn4 (derivingNonStdClassErr tycon2 deriv locn) `thenRn4_`
-	       returnRn4 clas_name
-      where
-	is_elem = isIn "rn_deriv"
-
-rnTyDecl4 (TySynonym name tyvars ty pragmas src_loc)
-  = pushSrcLocRn4 src_loc		      (
-    lookupTyCon name		    `thenRn4` \ name' ->
-    mkTyVarNamesEnv src_loc tyvars  `thenRn4` \ (tv_env, tyvars') ->
-    rnMonoType4 False{-no invisible types-} tv_env ty
-				    `thenRn4` \ ty' ->
-    returnRn4 (TySynonym name' tyvars' ty' pragmas src_loc)
-    )
-\end{code}
-
-@rnConDecls4@ 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}
-rnConDecls4 :: TyVarNamesEnv
-	    -> Bool		    -- True <=> allowed to see invisible data-cons
-	    -> [ProtoNameConDecl]
-	    -> Rn4M [RenamedConDecl]
-
-rnConDecls4 tv_env invisibles_allowed con_decls
-  = mapRn4 rn_decl con_decls
-  where
-    lookup_fn
-      = if invisibles_allowed
-	then lookupValueEvenIfInvisible
-	else lookupValue
-
-    rn_decl (ConDecl name tys src_loc)
-      = pushSrcLocRn4 src_loc			  (
-	lookup_fn name			`thenRn4` \ new_name ->
-	mapRn4 (rnMonoType4 invisibles_allowed tv_env) tys
-					`thenRn4` \ new_tys  ->
-
-	returnRn4 (ConDecl new_name new_tys src_loc)
-	)
-\end{code}
-
-%*********************************************************
-%*							*
-\subsection{ABSTRACT type-synonym pragmas}
-%*							*
-%*********************************************************
-
-\begin{code}
-rnTySig4 :: ProtoNameDataTypeSig
-	    -> Rn4M RenamedDataTypeSig
-
-rnTySig4 (AbstractTypeSig tycon src_loc)
-  = pushSrcLocRn4 src_loc		  (
-    lookupTyCon tycon		`thenRn4` \ tycon' ->
-    returnRn4 (AbstractTypeSig tycon' src_loc)
-    )
-
-rnTySig4 (SpecDataSig tycon ty src_loc)
-  = pushSrcLocRn4 src_loc		(
-    let
-	tyvars = extractMonoTyNames eqProtoName ty
-    in
-    mkTyVarNamesEnv src_loc tyvars     	`thenRn4` \ (tv_env,_) ->
-    lookupTyCon tycon			`thenRn4` \ tycon' ->
-    rnMonoType4 False tv_env ty		`thenRn4` \ ty' ->
-    returnRn4 (SpecDataSig tycon' ty' src_loc)
-    )
-\end{code}
-
-%*********************************************************
-%*							*
-\subsection{Class declarations}
-%*							*
-%*********************************************************
-
-@rnClassDecl4@ uses the `global name function' to create a new
-class declaration in which local names have been replaced by their
-original names, reporting any unknown names.
-
-\begin{code}
-rnClassDecl4 :: ProtoNameClassDecl -> Rn4M RenamedClassDecl
-
-rnClassDecl4 (ClassDecl context cname tyvar sigs mbinds pragmas src_loc)
-  = pushSrcLocRn4 src_loc			  (
-    mkTyVarNamesEnv src_loc [tyvar]	`thenRn4` \ (tv_env, [tyvar']) ->
-    rnContext4 tv_env context	    	`thenRn4` \ context' ->
-    lookupClass cname		    	`thenRn4` \ cname' ->
-    mapRn4 (rn_op cname' tv_env) sigs   `thenRn4` \ sigs' ->
-    rnMethodBinds4 cname' mbinds    	`thenRn4` \ mbinds' ->
-    recoverQuietlyRn4 NoClassPragmas (
-      rnClassPragmas4 pragmas
-    )					`thenRn4` \ pragmas' ->
-    returnRn4 (ClassDecl context' cname' tyvar' sigs' mbinds' pragmas' src_loc)
-    )
-  where
-    rn_op clas tv_env (ClassOpSig op ty pragma locn)
-      = pushSrcLocRn4 locn	    	      (
-	lookupClassOp clas op		 `thenRn4` \ op_name ->
-	rnPolyType4 False True tv_env ty `thenRn4` \ new_ty  ->
-	recoverQuietlyRn4 NoClassOpPragmas (
-	    rnClassOpPragmas4 pragma
-	)			    `thenRn4` \ new_pragma ->
-	returnRn4 (ClassOpSig op_name new_ty new_pragma locn)
-	)
-\end{code}
-
-
-%*********************************************************
-%*							*
-\subsection{Instance declarations}
-%*							*
-%*********************************************************
-
-
-@rnInstDecl4@ 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}
-rnInstDecl4 :: ProtoNameInstDecl -> Rn4M RenamedInstDecl
-
-rnInstDecl4 (InstDecl context cname ty mbinds from_here modname imod uprags pragmas src_loc)
-  = pushSrcLocRn4 src_loc		 	  (
-    let  tyvars = extractMonoTyNames eqProtoName ty  in
-    mkTyVarNamesEnv src_loc tyvars     	`thenRn4` \ (tv_env,_) ->
-    rnContext4 tv_env context 	    	`thenRn4` \ context' ->
-    lookupClass cname 		     	`thenRn4` \ cname' ->
-    rnMonoType4 False{-no invisibles-} tv_env ty
-					`thenRn4` \ ty' ->
-    rnMethodBinds4 cname' mbinds	`thenRn4` \ mbinds' ->
-    mapRn4 (rn_uprag cname') uprags	`thenRn4` \ new_uprags ->
-    recoverQuietlyRn4 NoInstancePragmas (
-	rnInstancePragmas4 cname' tv_env pragmas
-    )					`thenRn4` \ new_pragmas ->
-    returnRn4 (InstDecl context' cname' ty' mbinds'
-			from_here modname imod new_uprags new_pragmas src_loc)
-    )
-  where
-    rn_uprag class_name (SpecSig op ty using locn)
-      = ASSERT(not (maybeToBool using))	-- ToDo: SPEC method with explicit spec_id
-	pushSrcLocRn4 src_loc 				(
-	lookupClassOp class_name op			`thenRn4` \ op_name ->
-        rnPolyType4 False True nullTyVarNamesEnv ty	`thenRn4` \ new_ty ->
-	returnRn4 (SpecSig op_name new_ty Nothing locn)
-	)
-    rn_uprag class_name (InlineSig op guide locn)
-      = pushSrcLocRn4 locn	      	(
-	lookupClassOp class_name op	`thenRn4` \ op_name ->
-	returnRn4 (InlineSig op_name guide locn)
-	)
-    rn_uprag class_name (DeforestSig op locn)
-      = pushSrcLocRn4 locn            	(
-	lookupClassOp class_name op	`thenRn4` \ op_name ->
-	returnRn4 (DeforestSig op_name locn)
-	)
-    rn_uprag class_name (MagicUnfoldingSig op str locn)
-      = pushSrcLocRn4 locn		(
-	lookupClassOp class_name op	`thenRn4` \ op_name ->
-	returnRn4 (MagicUnfoldingSig op_name str locn)
-	)
-\end{code}
-
-%*********************************************************
-%*							*
-\subsection{@SPECIALIZE instance@ user-pragmas}
-%*							*
-%*********************************************************
-
-\begin{code}
-rnInstSpecSig4 :: ProtoNameSpecialisedInstanceSig
-		-> Rn4M RenamedSpecialisedInstanceSig
-
-rnInstSpecSig4 (InstSpecSig clas ty src_loc)
-  = pushSrcLocRn4 src_loc		  (
-    let  tyvars = extractMonoTyNames eqProtoName ty  in
-    mkTyVarNamesEnv src_loc tyvars     	`thenRn4` \ (tv_env,_) ->
-    lookupClass clas			`thenRn4` \ new_clas ->
-    rnMonoType4 False tv_env ty		`thenRn4` \ new_ty ->
-    returnRn4 (InstSpecSig new_clas new_ty src_loc)
-    )
-\end{code}
-
-%*********************************************************
-%*							*
-\subsection{Default declarations}
-%*							*
-%*********************************************************
-
-@rnDefaultDecl4@ 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}
-rnDefaultDecl4 :: ProtoNameDefaultDecl -> Rn4M RenamedDefaultDecl
-
-rnDefaultDecl4 (DefaultDecl tys src_loc)
-  = pushSrcLocRn4 src_loc		            	 (
-    mapRn4 (rnMonoType4 False nullTyVarNamesEnv) tys `thenRn4` \ tys' ->
-    returnRn4 (DefaultDecl tys' src_loc)
-    )
-\end{code}
-
-%*************************************************************************
-%*									*
-\subsection{Type signatures from interfaces}
-%*									*
-%*************************************************************************
-
-Non-interface type signatures (which may include user-pragmas) are
-handled with @Binds@.
-
-@ClassOpSigs@ are dealt with in class declarations.
-
-\begin{code}
-rnIntSig4 :: ProtoNameSig -> Rn4M RenamedSig
-
-rnIntSig4 (Sig name ty pragma src_loc)
-  = pushSrcLocRn4 src_loc			      (
-    lookupValue name				`thenRn4` \ new_name ->
-    rnPolyType4 False True nullTyVarNamesEnv ty `thenRn4` \ new_ty   ->
-    recoverQuietlyRn4 NoGenPragmas (
-	rnGenPragmas4 pragma
-    )					    `thenRn4` \ new_pragma ->
-    returnRn4 (Sig new_name new_ty new_pragma src_loc)
-    )
-\end{code}
-
-%*************************************************************************
-%*									*
-\subsection{Fixity declarations}
-%*									*
-%*************************************************************************
-
-\begin{code}
-rnFixes4 :: [ProtoNameFixityDecl]  -> Rn4M [RenamedFixityDecl]
-
-rnFixes4 fixities
-  = mapRn4 rn_fixity fixities `thenRn4` \ fixes_maybe ->
-    returnRn4 (catMaybes fixes_maybe)
-  where
-    rn_fixity (InfixL name i)
-      = lookupFixityOp name `thenRn4` \ res ->
-	returnRn4 (
-	  case res of
-	    Just name2 ->  Just (InfixL name2 i)
-	    Nothing    ->  Nothing
-	)
-
-    rn_fixity (InfixR name i)
-      = lookupFixityOp name	`thenRn4` \ res ->
-	returnRn4 (
-	  case res of
-	    Just name2 ->  Just (InfixR name2 i)
-	    Nothing    ->  Nothing
-	)
-
-    rn_fixity (InfixN name i)
-      = lookupFixityOp name	`thenRn4` \ res ->
-	returnRn4 (
-	  case res of
-	    Just name2 ->  Just (InfixN name2 i)
-	    Nothing    ->  Nothing
-	)
-\end{code}
-
-%*********************************************************
-%*							*
-\subsection{Support code to rename types}
-%*							*
-%*********************************************************
-
-\begin{code}
-rnPolyType4 :: Bool		-- True <=> "invisible" tycons (in pragmas) allowed 
-	    -> Bool		-- True <=> snaffle tyvars from ty and
-				--  stuff them in tyvar env; True for
-				--  signatures and things; False for type
-				--  synonym defns and things.
-	    -> TyVarNamesEnv
-	    -> ProtoNamePolyType
-	    -> Rn4M RenamedPolyType
-
-rnPolyType4 invisibles_allowed snaffle_tyvars tv_env (UnoverloadedTy ty)
-  = rn_poly_help invisibles_allowed snaffle_tyvars tv_env [] ty `thenRn4` \ (_, new_ty) ->
-    returnRn4 (UnoverloadedTy new_ty)
-
-rnPolyType4 invisibles_allowed snaffle_tyvars tv_env (OverloadedTy ctxt ty)
-  = rn_poly_help invisibles_allowed snaffle_tyvars tv_env ctxt ty `thenRn4` \ (new_ctxt, new_ty) ->
-    returnRn4 (OverloadedTy new_ctxt new_ty)
-
-rnPolyType4 invisibles_allowed snaffle_tyvars tv_env (ForAllTy tvs ty)
-  = getSrcLocRn4 		`thenRn4` \ src_loc ->
-    mkTyVarNamesEnv src_loc tvs `thenRn4` \ (tvenv2, new_tvs) ->
-    let
-	new_tvenv = catTyVarNamesEnvs tvenv2 tv_env
-    in
-    rnMonoType4 invisibles_allowed new_tvenv ty `thenRn4` \ new_ty ->
-    returnRn4 (ForAllTy new_tvs new_ty)
-
-------------
-rn_poly_help invisibles_allowed snaffle_tyvars tv_env ctxt ty
-  = getSrcLocRn4 		`thenRn4` \ src_loc ->
-    let
-	-- ToDo: this randomly-grabbing-tyvar names out
-	-- of the type seems a little weird to me
-	-- (WDP 94/11)
-
-	new_tyvars
-	  = extractMonoTyNames eqProtoName ty
-	    `minus_list` domTyVarNamesEnv tv_env
-    in
-    mkTyVarNamesEnv src_loc new_tyvars 	`thenRn4` \ (tv_env2, _) ->
-    let
-	tv_env3 = if snaffle_tyvars
-		  then catTyVarNamesEnvs tv_env2 tv_env
-		  else tv_env -- leave it alone
-    in
-    rnContext4 tv_env3 ctxt		`thenRn4` \ new_ctxt ->
-    rnMonoType4 invisibles_allowed tv_env3 ty
-					`thenRn4` \ new_ty ->
-    returnRn4 (new_ctxt, new_ty)
-  where
-    minus_list xs ys = [ x | x <- xs, not (x `elemProtoNames` ys)]
-\end{code}
-
-\begin{code}
-rnMonoType4 :: Bool		-- allowed to look at invisible tycons
-	    -> TyVarNamesEnv
-	    -> ProtoNameMonoType
-	    -> Rn4M RenamedMonoType
-
-rnMonoType4 invisibles_allowed  tv_env (MonoTyVar tyvar)
-  = lookupTyVarName tv_env tyvar 	`thenRn4` \ tyvar' ->
-    returnRn4 (MonoTyVar tyvar')
-
-rnMonoType4 invisibles_allowed  tv_env (ListMonoTy ty)
-  = rnMonoType4 invisibles_allowed tv_env ty	`thenRn4` \ ty' ->
-    returnRn4 (ListMonoTy ty')
-
-rnMonoType4 invisibles_allowed  tv_env (FunMonoTy ty1 ty2)
-  = andRn4 FunMonoTy (rnMonoType4 invisibles_allowed tv_env ty1)
-		     (rnMonoType4 invisibles_allowed tv_env ty2)
-
-rnMonoType4 invisibles_allowed  tv_env (TupleMonoTy tys)
-  = mapRn4 (rnPolyType4 invisibles_allowed False tv_env) tys `thenRn4` \ tys' ->
-    returnRn4 (TupleMonoTy tys')
-
-rnMonoType4 invisibles_allowed tv_env (MonoTyCon name tys)
-  = let
-	lookup_fn = if invisibles_allowed
-		    then lookupTyConEvenIfInvisible
-		    else lookupTyCon
-    in
-    lookup_fn name			`thenRn4` \ tycon_name' ->
-    mapRn4 (rnMonoType4 invisibles_allowed tv_env) tys	`thenRn4` \ tys' ->
-    returnRn4 (MonoTyCon tycon_name' tys')
-
--- for unfoldings only:
-
-rnMonoType4 invisibles_allowed tv_env (MonoTyVarTemplate name)
-  = --pprTrace "rnMonoType4:MonoTyVarTemplate:" (ppAbove (ppr PprDebug name) (ppr PprDebug tv_env)) (
-    lookupTyVarName tv_env name 	`thenRn4` \ new_name ->
-    returnRn4 (MonoTyVarTemplate new_name)
-    --)
-
-rnMonoType4 invisibles_allowed tv_env (MonoDict clas ty)
-  = lookupClass clas		`thenRn4` \ new_clas ->
-    rnMonoType4 invisibles_allowed tv_env ty	`thenRn4` \ new_ty ->
-    returnRn4 (MonoDict new_clas new_ty)
-
-#ifdef DPH
-rnMonoType4 invisibles_allowed tv_env (MonoTyProc tys ty)
-  = mapRn4 (rnMonoType4 invisibles_allowed  tv_env) tys	`thenRn4` \ tys' ->
-    rnMonoType4 invisibles_allowed   tv_env ty		`thenRn4` \ ty'  ->
-    returnRn4 (MonoTyProc tys' ty')
-
-rnMonoType4 invisibles_allowed tv_env (MonoTyPod ty)
-  = rnMonoType4 invisibles_allowed   tv_env ty  `thenRn4` \ ty'  ->
-    returnRn4 (MonoTyPod ty')
-#endif {- Data Parallel Haskell -}
-\end{code}
-
-\begin{code}
-rnContext4 :: TyVarNamesEnv -> ProtoNameContext -> Rn4M RenamedContext
-
-rnContext4 tv_env ctxt
-  = mapRn4 rn_ctxt ctxt
-  where
-    rn_ctxt (clas, tyvar)
-     = lookupClass clas	    	    `thenRn4` \ clas_name ->
-       lookupTyVarName tv_env tyvar `thenRn4` \ tyvar_name ->
-       returnRn4 (clas_name, tyvar_name)
-\end{code}
-
-%*********************************************************
-%*							*
-\subsection{Support code to rename various pragmas}
-%*							*
-%*********************************************************
-
-\begin{code}
-rnDataPragmas4 tv_env (DataPragmas cons specs)
-  = rnConDecls4 tv_env True{-invisibles allowed-} cons `thenRn4` \ new_cons ->
-    mapRn4 types_n_spec specs			       `thenRn4` \ new_specs ->
-    returnRn4 (DataPragmas new_cons new_specs)
-  where
-    types_n_spec ty_maybes
-      = mapRn4 (rn_ty_maybe nullTyVarNamesEnv) ty_maybes
-\end{code}
-
-\begin{code}
-rnClassOpPragmas4 NoClassOpPragmas = returnRn4 NoClassOpPragmas
-
-rnClassOpPragmas4 (ClassOpPragmas dsel defm)
-  = recoverQuietlyRn4 NoGenPragmas (rnGenPragmas4 dsel) `thenRn4` \ new_dsel ->
-    recoverQuietlyRn4 NoGenPragmas (rnGenPragmas4 defm) `thenRn4` \ new_defm ->
-    returnRn4 (ClassOpPragmas new_dsel new_defm)
-\end{code}
-
-\begin{code}
-rnClassPragmas4 NoClassPragmas = returnRn4 NoClassPragmas
-
-rnClassPragmas4 (SuperDictPragmas sds)
-  = mapRn4 rnGenPragmas4 sds	`thenRn4` \ new_sds ->
-    returnRn4 (SuperDictPragmas new_sds)
-\end{code}
-
-NB: In various cases around here, we don't @recoverQuietlyRn4@ around
-calls to @rnGenPragmas4@; not really worth it.
-
-\begin{code}
-rnInstancePragmas4 _ _ NoInstancePragmas = returnRn4 NoInstancePragmas
-
-rnInstancePragmas4 _ _ (SimpleInstancePragma dfun)
-  = rnGenPragmas4 dfun	`thenRn4` \ new_dfun ->
-    returnRn4 (SimpleInstancePragma new_dfun)
-
-rnInstancePragmas4 clas tv_env (ConstantInstancePragma dfun constms)
-  = recoverQuietlyRn4 NoGenPragmas (
-	rnGenPragmas4 dfun
-    )				`thenRn4` \ new_dfun ->
-    mapRn4 name_n_gen constms	`thenRn4` \ new_constms ->
-    returnRn4 (ConstantInstancePragma new_dfun new_constms)
-  where
-    name_n_gen (op, gen)
-      = lookupClassOp clas op	`thenRn4` \ new_op ->
-	rnGenPragmas4 gen	`thenRn4` \ new_gen ->
-	returnRn4 (new_op, new_gen)
-
-rnInstancePragmas4 clas tv_env (SpecialisedInstancePragma dfun specs)
-  = recoverQuietlyRn4 NoGenPragmas (
-	rnGenPragmas4 dfun
-    )				`thenRn4` \ new_dfun ->
-    mapRn4 types_n_spec specs	`thenRn4` \ new_specs ->
-    returnRn4 (SpecialisedInstancePragma new_dfun new_specs)
-  where
-    types_n_spec (ty_maybes, dicts_to_ignore, inst)
-      = mapRn4 (rn_ty_maybe tv_env) ty_maybes	`thenRn4` \ new_tys ->
-	rnInstancePragmas4 clas tv_env inst 	`thenRn4` \ new_inst ->
-	returnRn4 (new_tys, dicts_to_ignore, new_inst)
-\end{code}
-
-And some general pragma stuff: (Not sure what, if any, of this would
-benefit from a TyVarNamesEnv passed in.... [ToDo])
-\begin{code}
-rnGenPragmas4 NoGenPragmas = returnRn4 NoGenPragmas
-
-rnGenPragmas4 (GenPragmas arity upd def strict unfold specs)
-  = recoverQuietlyRn4 NoImpUnfolding (
-	rn_unfolding  unfold
-    )				`thenRn4` \ new_unfold ->
-    rn_strictness strict	`thenRn4` \ new_strict ->
-    recoverQuietlyRn4 [] (
-	mapRn4 types_n_gen specs
-    )				`thenRn4` \ new_specs ->
-    returnRn4 (GenPragmas arity upd def new_strict new_unfold new_specs)
-  where
-    rn_unfolding NoImpUnfolding = returnRn4 NoImpUnfolding
-
-    rn_unfolding (ImpMagicUnfolding str) = returnRn4 (ImpMagicUnfolding str)
-
-    rn_unfolding (ImpUnfolding guidance core)
-      = rn_core nullTyVarNamesEnv core	`thenRn4` \ new_core ->
-    	returnRn4 (ImpUnfolding guidance new_core)
-
-    ------------
-    rn_strictness NoImpStrictness = returnRn4 NoImpStrictness
-
-    rn_strictness (ImpStrictness is_bot ww_info wrkr_info)
-      = recoverQuietlyRn4 NoGenPragmas (
-	    rnGenPragmas4 wrkr_info
-	) 			`thenRn4` \ new_wrkr_info ->
-	returnRn4 (ImpStrictness is_bot ww_info new_wrkr_info)
-
-    -------------
-    types_n_gen (ty_maybes, dicts_to_ignore, gen)
-      = mapRn4 (rn_ty_maybe no_env) ty_maybes	`thenRn4` \ new_tys ->
-	recoverQuietlyRn4 NoGenPragmas (
-	    rnGenPragmas4 gen
-	)				`thenRn4` \ new_gen ->
-	returnRn4 (new_tys, dicts_to_ignore, new_gen)
-      where
-	no_env = nullTyVarNamesEnv
-
-------------
-rn_ty_maybe tv_env Nothing = returnRn4 Nothing
-
-rn_ty_maybe tv_env (Just ty)
-  = rnMonoType4 True{-invisibles OK-} tv_env ty  `thenRn4` \ new_ty ->
-    returnRn4 (Just new_ty)
-
-------------
-rn_core tvenv (UfCoVar v)
-  = rn_uf_id tvenv v	`thenRn4` \ vname ->
-    returnRn4 (UfCoVar vname)
-
-rn_core tvenv (UfCoLit lit)
-  = returnRn4 (UfCoLit lit)
-
-rn_core tvenv (UfCoCon con tys as)
-  = lookupValueEvenIfInvisible con	`thenRn4` \ new_con ->
-    mapRn4 (rn_core_type tvenv) tys	`thenRn4` \ new_tys ->
-    mapRn4 (rn_atom tvenv) as   	`thenRn4` \ new_as ->
-    returnRn4 (UfCoCon new_con new_tys new_as)
-
-rn_core tvenv (UfCoPrim op tys as)
-  = rn_core_primop tvenv op		`thenRn4` \ new_op ->
-    mapRn4 (rn_core_type tvenv) tys	`thenRn4` \ new_tys ->
-    mapRn4 (rn_atom tvenv) as   	`thenRn4` \ new_as ->
-    returnRn4 (UfCoPrim new_op new_tys new_as)
-
-rn_core tvenv (UfCoLam binders body)
-  = mapRn4 (rn_binder tvenv) binders `thenRn4` \ new_binders ->
-    let
-	bs = [ b | (b, ty) <- new_binders ]
-    in
-    extendSS bs (rn_core tvenv body) `thenRn4` \ new_body ->
-    returnRn4 (UfCoLam new_binders new_body)
-
-rn_core tvenv (UfCoTyLam tv body)
-  = getSrcLocRn4 		    	`thenRn4` \ src_loc ->
-    mkTyVarNamesEnv src_loc [tv] 	`thenRn4` \ (tvenv2, [new_tv]) ->
-    let
-	new_tvenv = catTyVarNamesEnvs tvenv2 tvenv
-    in
-    rn_core new_tvenv body		`thenRn4` \ new_body ->
-    returnRn4 (UfCoTyLam new_tv new_body)
-
-rn_core tvenv (UfCoApp fun arg)
-  = rn_core tvenv fun	`thenRn4` \ new_fun ->
-    rn_atom tvenv arg	`thenRn4` \ new_arg ->
-    returnRn4 (UfCoApp new_fun new_arg)
-
-rn_core tvenv (UfCoTyApp expr ty)
-  = rn_core tvenv expr	    `thenRn4` \ new_expr ->
-    rn_core_type tvenv ty   `thenRn4` \ new_ty ->
-    returnRn4 (UfCoTyApp new_expr new_ty)
-
-rn_core tvenv (UfCoCase expr alts)
-  = rn_core tvenv expr	    `thenRn4` \ new_expr ->
-    rn_alts 	  alts	    `thenRn4` \ new_alts ->
-    returnRn4 (UfCoCase new_expr new_alts)
-  where
-    rn_alts (UfCoAlgAlts alg_alts deflt)
-      = mapRn4 rn_alg_alt alg_alts  `thenRn4` \ new_alts ->
-        rn_deflt deflt	    	    `thenRn4` \ new_deflt ->
-	returnRn4 (UfCoAlgAlts new_alts new_deflt)
-      where
-        rn_alg_alt (con, params, rhs)
-	  = lookupValueEvenIfInvisible con  `thenRn4` \ new_con ->
-	    mapRn4 (rn_binder tvenv) params `thenRn4` \ new_params ->
-	    let
-		bs = [ b | (b, ty) <- new_params ]
-	    in
-	    extendSS bs (rn_core tvenv rhs) `thenRn4` \ new_rhs ->
-	    returnRn4 (new_con, new_params, new_rhs)
-
-    rn_alts (UfCoPrimAlts prim_alts deflt)
-      = mapRn4 rn_prim_alt prim_alts  `thenRn4` \ new_alts ->
-        rn_deflt deflt		      `thenRn4` \ new_deflt ->
-	returnRn4 (UfCoPrimAlts new_alts new_deflt)
-      where
-        rn_prim_alt (lit, rhs)
-	  = rn_core tvenv rhs	`thenRn4` \ new_rhs ->
-	    returnRn4 (lit, new_rhs)
-
-    rn_deflt UfCoNoDefault = returnRn4 UfCoNoDefault
-    rn_deflt (UfCoBindDefault b rhs)
-      = rn_binder tvenv b		      `thenRn4` \ new_b@(binder, ty) ->
-	extendSS [binder] (rn_core tvenv rhs) `thenRn4` \ new_rhs ->
-	returnRn4 (UfCoBindDefault new_b new_rhs)
-
-rn_core tvenv (UfCoLet bind body)
-  = rn_bind bind			      `thenRn4` \ (new_bind, new_binders) ->
-    extendSS new_binders (rn_core tvenv body) `thenRn4` \ new_body ->
-    returnRn4 (UfCoLet new_bind new_body)
-  where
-    rn_bind (UfCoNonRec b rhs)
-      = rn_binder tvenv b	`thenRn4` \ new_b@(binder, ty) ->
-        rn_core   tvenv rhs 	`thenRn4` \ new_rhs ->
-	returnRn4 (UfCoNonRec new_b new_rhs, [binder])
-
-    rn_bind (UfCoRec pairs)
-      = -- conjure up Names; we do this differently than
-	-- elsewhere for Core, because of the recursion here;
-	-- no deep issue.
-	-- [BEFORE IT WAS "FIXED"... 94/05...]
- 	-- [Andy -- It *was* a 'deep' issue to me...]
-	-- [Will -- Poor wee soul.]
-
-	getSrcLocRn4			    `thenRn4` \ locn ->
-	namesFromProtoNames "core variable"
-	  [ (b, locn) | ((b,_),_) <- pairs] `thenRn4` \ binders ->
-
-	extendSS binders (mapRn4 rn_pair (pairs `zip` binders)) `thenRn4` \ new_pairs ->
-	returnRn4 (UfCoRec new_pairs, binders)
-      where
-	rn_pair (((b, ty), rhs), new_b)
-	  = rn_core_type tvenv ty	`thenRn4` \ new_ty ->
-	    rn_core      tvenv rhs	`thenRn4` \ new_rhs ->
-	    returnRn4 ((new_b, new_ty), new_rhs)
-
-rn_core tvenv (UfCoSCC uf_cc body)
-  = rn_cc uf_cc		`thenRn4` \ new_cc ->
-    rn_core tvenv body	`thenRn4` \ new_body ->
-    returnRn4 (UfCoSCC new_cc new_body)
-  where
-    rn_cc (UfAutoCC id m g is_dupd is_caf)
-      = rn_uf_id tvenv id	`thenRn4` \ new_id ->
-	returnRn4 (UfAutoCC new_id m g is_dupd is_caf)
-
-    rn_cc (UfDictCC id m g is_caf is_dupd)
-      = rn_uf_id tvenv id	`thenRn4` \ new_id ->
-	returnRn4 (UfDictCC new_id m g is_dupd is_caf)
-
-    -- the rest are boring:
-    rn_cc (UfPreludeDictsCC d) = returnRn4 (UfPreludeDictsCC d)
-    rn_cc (UfAllDictsCC m g d) = returnRn4 (UfAllDictsCC m g d)
-    rn_cc (UfUserCC n m g d c) = returnRn4 (UfUserCC n m g d c)
-
-------------
-rn_core_primop tvenv (UfCCallOp str is_casm may_gc arg_tys res_ty)
-  = mapRn4 (rn_core_type tvenv) arg_tys	`thenRn4` \ new_arg_tys ->
-    rn_core_type tvenv res_ty		`thenRn4` \ new_res_ty  ->
-    returnRn4 (UfCCallOp str is_casm may_gc new_arg_tys new_res_ty)
-rn_core_primop tvenv (UfOtherOp op)
-  = returnRn4 (UfOtherOp op)
-
-------------
-rn_uf_id tvenv (BoringUfId v)
-  = lookupValueEvenIfInvisible v    `thenRn4` \ vname ->
-    returnRn4 (BoringUfId vname)
-
-rn_uf_id tvenv (SuperDictSelUfId c sc)
-  = lookupClass{-EvenIfInvisible-} c	`thenRn4` \ new_c ->
-    lookupClass{-EvenIfInvisible-} sc	`thenRn4` \ new_sc ->
-    returnRn4 (SuperDictSelUfId new_c new_sc)
-
-rn_uf_id tvenv (ClassOpUfId c op)
-  = lookupClass{-EvenIfInvisible-} c	    	`thenRn4` \ new_c ->
-    lookupClassOp{-EvenIfInvisible-} new_c op	`thenRn4` \ new_op ->
-    returnRn4 (ClassOpUfId new_c new_op)
-
-rn_uf_id tvenv (DictFunUfId c ty)
-  = lookupClass{-EvenIfInvisible-} c	`thenRn4` \ new_c ->
-    rn_core_type tvenv ty   	    	`thenRn4` \ new_ty ->
-    returnRn4 (DictFunUfId new_c new_ty)
-
-rn_uf_id tvenv (ConstMethodUfId c op ty)
-  = lookupClass{-EvenIfInvisible-} c	      `thenRn4` \ new_c ->
-    lookupClassOp{-EvenIfInvisible-} new_c op `thenRn4` \ new_op ->
-    rn_core_type tvenv ty   	    	      `thenRn4` \ new_ty ->
-    returnRn4 (ConstMethodUfId new_c new_op new_ty)
-
-rn_uf_id tvenv (DefaultMethodUfId c op)
-  = lookupClass{-EvenIfInvisible-} c	    	`thenRn4` \ new_c ->
-    lookupClassOp{-EvenIfInvisible-} new_c op	`thenRn4` \ new_op ->
-    returnRn4 (DefaultMethodUfId new_c new_op)
-
-rn_uf_id tvenv (SpecUfId unspec ty_maybes)
-  = rn_uf_id tvenv unspec		 `thenRn4` \ new_unspec ->
-    mapRn4 (rn_ty_maybe tvenv) ty_maybes `thenRn4` \ new_ty_maybes ->
-    returnRn4 (SpecUfId new_unspec new_ty_maybes)
-
-rn_uf_id tvenv (WorkerUfId unwrkr)
-  = rn_uf_id tvenv unwrkr	`thenRn4` \ new_unwrkr ->
-    returnRn4 (WorkerUfId new_unwrkr)
-
-------------
-rn_binder tvenv (b, ty)
-  = getSrcLocRn4			`thenRn4` \ src_loc ->
-    namesFromProtoNames "binder in core unfolding" [(b, src_loc)]
-					`thenRn4` \ [new_b] ->
-    rn_core_type tvenv ty		`thenRn4` \ new_ty ->
-    returnRn4 (new_b, new_ty)
-
-------------
-rn_atom tvenv (UfCoLitAtom l) = returnRn4 (UfCoLitAtom l)
-rn_atom tvenv (UfCoVarAtom v)
-  = rn_uf_id tvenv v			`thenRn4` \ vname ->
-    returnRn4 (UfCoVarAtom vname)
-
-------------
-rn_core_type_maybe tvenv Nothing = returnRn4 Nothing
-rn_core_type_maybe tvenv (Just ty)
-  = rn_core_type tvenv ty `thenRn4` \ new_ty ->
-    returnRn4 (Just new_ty)
-
-------------
-rn_core_type tvenv ty
-  = rnPolyType4 True{-invisible tycons OK-} False tvenv ty
-\end{code}
diff --git a/ghc/compiler/rename/RenameAuxFuns.hi b/ghc/compiler/rename/RenameAuxFuns.hi
deleted file mode 100644
index a04866e348..0000000000
--- a/ghc/compiler/rename/RenameAuxFuns.hi
+++ /dev/null
@@ -1,17 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface RenameAuxFuns where
-import Bag(Bag)
-import Maybes(Labda)
-import Name(Name)
-import PreludePS(_PackedString)
-import ProtoName(ProtoName)
-data Bag a 
-type GlobalNameFun = ProtoName -> Labda Name
-type GlobalNameFuns = (ProtoName -> Labda Name, ProtoName -> Labda Name)
-data Labda a 
-type PreludeNameFun = _PackedString -> Labda Name
-type PreludeNameFuns = (_PackedString -> Labda Name, _PackedString -> Labda Name)
-data ProtoName 
-mkGlobalNameFun :: _PackedString -> (_PackedString -> Labda Name) -> [(ProtoName, Name)] -> ProtoName -> Labda Name
-mkNameFun :: Bag (_PackedString, a) -> (_PackedString -> Labda a, [[(_PackedString, a)]])
-
diff --git a/ghc/compiler/rename/RenameAuxFuns.lhs b/ghc/compiler/rename/RenameAuxFuns.lhs
deleted file mode 100644
index 68106c1090..0000000000
--- a/ghc/compiler/rename/RenameAuxFuns.lhs
+++ /dev/null
@@ -1,132 +0,0 @@
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
-%
-\section[Rename-aux-funs]{Functions used by both renaming passes}
-
-\begin{code}
-#include "HsVersions.h"
-
-module RenameAuxFuns (
-	mkGlobalNameFun, mkNameFun,
-	GlobalNameFun(..),  GlobalNameFuns(..),
-	PreludeNameFun(..), PreludeNameFuns(..),
-
-	-- and for self-containedness...
-	Bag, ProtoName, Maybe
-    ) where
-
-IMPORT_Trace		-- ToDo: rm (for debugging)
-import Outputable
-import Pretty
-
-import Bag		( Bag, bagToList )
-import FiniteMap
-import Maybes
-import Name		( Name ) -- for instances
---OLD: import NameEnv
-import ProtoName
-import Util
-\end{code}
-
-\begin{code}
-type GlobalNameFun  = ProtoName -> Maybe Name
-type GlobalNameFuns = (GlobalNameFun, GlobalNameFun)
-
-type PreludeNameFun = FAST_STRING -> Maybe Name
-type PreludeNameFuns = (PreludeNameFun,		-- Values
-			PreludeNameFun		-- Types and classes
-		       )
-\end{code}
-
-\begin{code}
-mkGlobalNameFun :: FAST_STRING		-- The module name
-	        -> PreludeNameFun 	-- The prelude things
-	        -> [(ProtoName, Name)]	-- The local and imported things
-		-> GlobalNameFun	-- The global name function
-
-mkGlobalNameFun this_module prel_nf alist
-  = the_fun
-  where
-    the_fun (Prel n)	  = Just n
-    the_fun (Unk s) 	  = case (unk_fun s) of
-			      Just n  -> Just n
-			      Nothing -> prel_nf s
-    the_fun (Imp m d _ _) = imp_fun (d, m) -- NB: module-name 2nd!
-
-    -- Things in the domain of the prelude function shouldn't be put
-    -- in the unk_fun; because the prel_nf will catch them.
-    -- This can arise if, for example, an interface gives a signature
-    -- for a prelude thing.
-    --
-    -- Neither should they be in the domain of the imp_fun, because
-    -- prelude things will have been converted to Prel x rather than 
-    -- Imp p q r s.
-    --
-    -- So we strip out prelude things from the alist; this is not just
-    -- desirable, it's essential because get_orig and get_local don't handle
-    -- prelude things.
-
-    non_prel_alist = filter non_prel alist
-
-    non_prel (Prel _, _) = False
-    non_prel other       = True
-
-    -- unk_fun looks up local names (just strings),
-    -- imp_fun looks up original names: (string,string) pairs
-    unk_fun = lookupFM (listToFM [(get_local pn,n) | (pn,n) <- non_prel_alist])
-    imp_fun = lookupFM (listToFM [(get_orig  pn,n) | (pn,n) <- non_prel_alist])
-
-{- OLD:
-    unk_fun = mkStringLookupFn  [(get_local pn,n) | (pn,n) <- non_prel_alist] False{-not sorted-}
-    imp_fun = mk2StringLookupFn [(get_orig  pn,n) | (pn,n) <- non_prel_alist] False{-not sorted-}
--}
-		-- the lists *are* sorted by *some* ordering (by local
-		-- names), but not generally, and not in some way we
-		-- are going to rely on.
-
-    get_local :: ProtoName -> FAST_STRING
-    get_local (Unk s)       = s
-    get_local (Imp _ _ _ l) = l
-    get_local (Prel n)	    = pprPanic "get_local: " (ppr PprShowAll n)
-
-    get_orig :: ProtoName -> (FAST_STRING, FAST_STRING) -- **NB**! module-name 2nd!
-    get_orig (Unk s)       = (s, this_module)
-    get_orig (Imp m d _ _) = (d, m)
-    get_orig (Prel n)	    = pprPanic "get_orig: " (ppr PprShowAll n)
-\end{code}
-
-
-@mkNameFun@ builds a function from @ProtoName@s to things, where a
-``thing'' is either a @ProtoName@ (in the case of values), or a
-@(ProtoName, ProtoName -> ProtoName)@ pair in the case of types and
-classes.  It takes:
-
-\begin{itemize}
-\item	The name of the interface
-\item	A bag of new string-to-thing bindings to add,
-
-\item	An extractor function, to get a @ProtoName@ out of a thing,
-	for use in error messages.
-\end{itemize}
-The function it returns only expects to see @Unk@ things.
-
-@mkNameFun@ checks for clashes in the domain of the new bindings.
-
-ToDo: it should check for clashes with the prelude bindings too.
-
-\begin{code}
-mkNameFun :: Bag (FAST_STRING, thing)	    -- Value bindings
-	  -> (FAST_STRING -> Maybe thing,   -- The function to use
-	      [[(FAST_STRING,thing)]])	    -- Duplicates, if any
-
-mkNameFun the_bag
-  = case (removeDups cmp (bagToList the_bag)) of { (no_dup_list, dups) ->
-    case (lookupFM (listToFM no_dup_list))    of { the_fun -> 
-    --OLD :case (mkStringLookupFn no_dup_list True{-list is pre-sorted-}) of the_fun -> 
-    (the_fun, dups)
-    }}
-  where
-    cmp :: (FAST_STRING, a) -> (FAST_STRING, a) -> TAG_
-
-    cmp (s1,_) (s2,_) = _CMP_STRING_ s1 s2
-\end{code}
diff --git a/ghc/compiler/rename/RenameBinds4.hi b/ghc/compiler/rename/RenameBinds4.hi
deleted file mode 100644
index beedca4b85..0000000000
--- a/ghc/compiler/rename/RenameBinds4.hi
+++ /dev/null
@@ -1,50 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface RenameBinds4 where
-import Bag(Bag)
-import CmdLineOpts(GlobalSwitch)
-import ErrUtils(Error(..))
-import FiniteMap(FiniteMap)
-import HsBinds(Bind, Binds, MonoBinds, Sig)
-import HsExpr(Expr)
-import HsLit(Literal)
-import HsMatches(GRHSsAndBinds, Match)
-import HsPat(InPat)
-import Id(Id)
-import Inst(Inst)
-import Maybes(Labda)
-import Name(Name)
-import NameTypes(FullName, ShortName)
-import PreludePS(_PackedString)
-import Pretty(PprStyle, Pretty(..), PrettyRep)
-import ProtoName(ProtoName)
-import RenameAuxFuns(GlobalNameFun(..))
-import SplitUniq(SplitUniqSupply)
-import SrcLoc(SrcLoc)
-import TyCon(TyCon)
-import TyVar(TyVar)
-import UniqFM(UniqFM)
-import UniqSet(UniqSet(..))
-import Unique(Unique)
-data Bag a 
-type Error = PprStyle -> Int -> Bool -> PrettyRep
-data Binds a b 
-type DefinedVars = UniqFM Name
-type FreeVars = UniqFM Name
-data MonoBinds a b 
-data InPat a 
-data Labda a 
-data Name 
-data PprStyle 
-type Pretty = Int -> Bool -> PrettyRep
-data PrettyRep 
-data ProtoName 
-type GlobalNameFun = ProtoName -> Labda Name
-data SplitUniqSupply 
-data SrcLoc 
-data UniqFM a 
-type UniqSet a = UniqFM a
-data Unique 
-rnBinds4 :: Binds ProtoName (InPat ProtoName) -> (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> ((Binds Name (InPat Name), UniqFM Name, [Name]), Bag (PprStyle -> Int -> Bool -> PrettyRep))
-rnMethodBinds4 :: Name -> MonoBinds ProtoName (InPat ProtoName) -> (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (MonoBinds Name (InPat Name), Bag (PprStyle -> Int -> Bool -> PrettyRep))
-rnTopBinds4 :: Binds ProtoName (InPat ProtoName) -> (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (Binds Name (InPat Name), Bag (PprStyle -> Int -> Bool -> PrettyRep))
-
diff --git a/ghc/compiler/rename/RenameBinds4.lhs b/ghc/compiler/rename/RenameBinds4.lhs
deleted file mode 100644
index 76943f958d..0000000000
--- a/ghc/compiler/rename/RenameBinds4.lhs
+++ /dev/null
@@ -1,653 +0,0 @@
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
-%
-\section[RenameBinds4]{Renaming and dependency analysis of bindings}
-
-This module does renaming and dependency analysis on value bindings in
-@AbsSyntax@ programs.  It does {\em not} do cycle-checks on class or
-type-synonym declarations; those cannot be done at this stage because
-they may be affected by renaming (which isn't fully worked out yet).
-
-\begin{code}
-#include "HsVersions.h"
-
-module RenameBinds4 (
-	rnTopBinds4, rnMethodBinds4,
-	rnBinds4,
-	FreeVars(..), DefinedVars(..),
-
-	-- and to make the interface self-sufficient...
-	Bag, Binds, MonoBinds, InPat, Name, ProtoName,
-	GlobalNameFun(..), Maybe, UniqSet(..), UniqFM, SrcLoc, Unique,
-	SplitUniqSupply, Error(..), Pretty(..), PprStyle,
-	PrettyRep
-   ) where
-
-import AbsSyn
-import CmdLineOpts	( GlobalSwitch(..) )
-import Digraph		( stronglyConnComp {- MOVED HERE: , isCyclic -} )
-import Errors		-- ( unknownSigDeclErr, dupSigDeclErr, methodBindErr )
-import HsPragmas	-- ****** NEED TO SEE CONSTRUCTORS ******
-import Maybes		( catMaybes, Maybe(..) )
-import Name		( eqName, cmpName, isUnboundName )
-import ProtoName	( elemByLocalNames, eqByLocalName )
-import Rename4		( rnPolyType4, rnGenPragmas4 )
-import RenameAuxFuns	( GlobalNameFuns(..) )
-import RenameMonad4
-import RenameExpr4	( rnMatch4, rnGRHSsAndBinds4, rnPat4 )
-import UniqSet
-import Util
-\end{code}
-
--- ToDo: Put the annotations into the monad, so that they arrive in the proper
--- place and can be used when complaining.
-
-The code tree received by the function @rnBinds4@ contains definitions
-in where-clauses which are all apparently mutually recursive, but which may
-not really depend upon each other. For example, in the top level program
-\begin{verbatim}
-f x = y where a = x
-	      y = x
-\end{verbatim}
-the definitions of @a@ and @y@ do not depend on each other at all.
-Unfortunately, the typechecker cannot always check such definitions.
-\footnote{Mycroft, A. 1984. Polymorphic type schemes and recursive
-definitions. In Proceedings of the International Symposium on Programming,
-Toulouse, pp. 217-39. LNCS 167. Springer Verlag.}
-However, the typechecker usually can check definitions in which only the
-strongly connected components have been collected into recursive bindings.
-This is precisely what the function @rnBinds4@ 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 Name
-type FreeVars    = UniqSet Name
-\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).
-
-\begin{code}
-type VertexTag	= Int
-type Cycle	= [VertexTag]
-type Edge	= (VertexTag, VertexTag)
-\end{code}
-
-%************************************************************************
-%*									*
-%* naming conventions							*
-%*									*
-%************************************************************************
-\subsection[name-conventions]{Name conventions}
-
-The basic algorithm involves walking over the tree and returning a tuple
-containing the new tree plus its free variables. Some functions, such
-as those walking polymorphic bindings (Binds) and qualifier lists in
-list comprehensions (@Quals@), return the variables bound in local
-environments. These are then used to calculate the free variables of the
-expression evaluated in these environments.
-
-Conventions for variable names are as follows:
-\begin{itemize}
-\item
-new code is given a prime to distinguish it from the old.
-
-\item
-a set of variables defined in @Exp@ is written @dvExp@
-
-\item
-a set of variables free in @Exp@ is written @fvExp@
-\end{itemize}
-
-%************************************************************************
-%*									*
-%* analysing polymorphic bindings (Binds, Bind, MonoBinds)		*
-%*									*
-%************************************************************************
-\subsubsection[dep-Binds]{Polymorphic bindings}
-
-Non-recursive expressions are reconstructed without any changes at top
-level, although their component expressions may have to be altered.
-However, non-recursive expressions are currently not expected as
-\Haskell{} programs, and this code should not be executed.
-
-Monomorphic bindings contain information that is returned in a tuple
-(a @FlatMonoBindsInfo@) containing:
-
-\begin{enumerate}
-\item
-a unique @Int@ that serves as the ``vertex tag'' for this binding.
-
-\item
-the name of a function or the names in a pattern. These are a set
-referred to as @dvLhs@, the defined variables of the left hand side.
-
-\item
-the free variables of the body. These are referred to as @fvBody@.
-
-\item
-the definition's actual code. This is referred to as just @code@.
-\end{enumerate}
-
-The function @nonRecDvFv@ returns two sets of variables. The first is
-the set of variables defined in the set of monomorphic bindings, while the
-second is the set of free variables in those bindings.
-
-The set of variables defined in a non-recursive binding is just the
-union of all of them, as @union@ removes duplicates. However, the
-free variables in each successive set of cumulative bindings is the
-union of those in the previous set plus those of the newest binding after
-the defined variables of the previous set have been removed.
-
-@rnMethodBinds4@ deals only with the declarations in class and
-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).
-
-\begin{code}
-rnTopBinds4	:: ProtoNameBinds -> Rn4M RenamedBinds
-rnMethodBinds4  :: Name{-class-} -> ProtoNameMonoBinds -> Rn4M RenamedMonoBinds
-rnBinds4	:: ProtoNameBinds -> Rn4M (RenamedBinds, FreeVars, [Name])
-
-rnTopBinds4 EmptyBinds		       	   = returnRn4 EmptyBinds
-rnTopBinds4 (SingleBind (RecBind bind))    = rnTopMonoBinds4 bind []
-rnTopBinds4 (BindWith (RecBind bind) sigs) = rnTopMonoBinds4 bind sigs
-  -- the parser doesn't produce other forms
-
--- ********************************************************************
-
-rnMethodBinds4 class_name EmptyMonoBinds = returnRn4 EmptyMonoBinds
-
-rnMethodBinds4 class_name (AndMonoBinds mb1 mb2)
-  = andRn4 AndMonoBinds (rnMethodBinds4 class_name mb1)
-			(rnMethodBinds4 class_name mb2)
-
-rnMethodBinds4 class_name (FunMonoBind pname matches locn)
-  = pushSrcLocRn4 locn			      	  (
-    lookupClassOp class_name pname  	`thenRn4` \ op_name ->
-    mapAndUnzipRn4 rnMatch4 matches	`thenRn4` \ (new_matches, _) ->
-    returnRn4 (FunMonoBind op_name new_matches locn)
-    )
-
-rnMethodBinds4 class_name (PatMonoBind (VarPatIn pname) grhss_and_binds locn)
-  = pushSrcLocRn4 locn				  (
-    lookupClassOp class_name pname	`thenRn4` \ op_name ->
-    rnGRHSsAndBinds4 grhss_and_binds	`thenRn4` \ (grhss_and_binds', _) ->
-    returnRn4 (PatMonoBind (VarPatIn op_name) grhss_and_binds' locn)
-    )
-
--- Can't handle method pattern-bindings which bind multiple methods.
-rnMethodBinds4 _ mbind@(PatMonoBind other_pat _ locn)
-  = failButContinueRn4 EmptyMonoBinds (methodBindErr mbind locn)
-
--- ********************************************************************
-
-rnBinds4 EmptyBinds			= returnRn4 (EmptyBinds,emptyUniqSet,[])
-rnBinds4 (SingleBind (RecBind bind))	= rnNestedMonoBinds4 bind []
-rnBinds4 (BindWith (RecBind bind) sigs) = rnNestedMonoBinds4 bind sigs
-  -- the parser doesn't produce other forms
-\end{code}
-
-@rnNestedMonoBinds4@
-	- collects up the binders for this declaration group,
-	- checkes that they form a set
-	- extends the environment to bind them to new local names
-	- calls @rnMonoBinds4@ to do the real work
-
-In contrast, @rnTopMonoBinds4@ doesn't extend the environment, because that's
-already done in pass3.	All it does is call @rnMonoBinds4@ and discards
-the free var info.
-
-\begin{code}
-rnTopMonoBinds4 :: ProtoNameMonoBinds -> [ProtoNameSig] -> Rn4M RenamedBinds
-
-rnTopMonoBinds4 EmptyMonoBinds sigs = returnRn4 EmptyBinds
-
-rnTopMonoBinds4 mbs sigs
- = rnBindSigs4 True{-top-level-} (collectMonoBinders mbs) sigs `thenRn4` \ siglist ->
-   rnMonoBinds4 mbs siglist `thenRn4` \ (new_binds, fv_set) ->
-   returnRn4 new_binds
-
-
-rnNestedMonoBinds4 :: ProtoNameMonoBinds -> [ProtoNameSig]
-		      -> Rn4M (RenamedBinds, FreeVars, [Name])
-
-rnNestedMonoBinds4 EmptyMonoBinds sigs
-  = returnRn4 (EmptyBinds, emptyUniqSet, [])
-
-rnNestedMonoBinds4 mbinds sigs	-- 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
-    let
-	mbinders_w_srclocs = collectMonoBindersAndLocs mbinds
-	mbinders    	   = map fst mbinders_w_srclocs
-    in
-    namesFromProtoNames
-	"variable" -- in binding group
-	mbinders_w_srclocs		`thenRn4` \ new_mbinders ->
-
-    extendSS2 new_mbinders (
-	 rnBindSigs4 False{-not top- level-} mbinders sigs `thenRn4` \ siglist ->
-	 rnMonoBinds4 mbinds  siglist
-    )					`thenRn4` \ (new_binds, fv_set) ->
-    returnRn4 (new_binds, fv_set, new_mbinders)
-\end{code}
-
-@rnMonoBinds4@ 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 @rnNestedMonoBinds4@ (for the nested ones).
-
-\begin{code}
-rnMonoBinds4 :: ProtoNameMonoBinds
-	     -> [RenamedSig]	-- Signatures attached to this group
-	     -> Rn4M (RenamedBinds, FreeVars)
-
-rnMonoBinds4 mbinds siglist
-  =
-	 -- Rename the bindings, returning a MonoBindsInfo
-	 -- which is a list of indivisible vertices so far as
-	 -- the SCC analysis is concerned
-    flattenMonoBinds 0 siglist mbinds	`thenRn4` \ (_, mbinds_info) ->
-
-	 -- Do the SCC analysis
-    let vertices = mkVertices mbinds_info
-	edges	= mkEdges vertices mbinds_info
-
-	scc_result = stronglyConnComp (==) edges vertices
-
-	 -- 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 = returnRn4 (final_binds, rhs_free_vars)
-    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
--- 	addErrRn4 (inlineInRecursiveBindsErr names_n_locns) `thenRn4_`
-	{-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
-\end{code}
-
-@flattenMonoBinds@ is ever-so-slightly magical in that it sticks
-unique ``vertex tags'' on its output; minor plumbing required.
-
-\begin{code}
-flattenMonoBinds :: Int				-- Next free vertex tag
-		 -> [RenamedSig]		-- Signatures
-		 -> ProtoNameMonoBinds
-		 -> Rn4M (Int, FlatMonoBindsInfo)
-
-flattenMonoBinds uniq sigs EmptyMonoBinds = returnRn4 (uniq, [])
-
-flattenMonoBinds uniq sigs (AndMonoBinds mB1 mB2)
-  = flattenMonoBinds uniq sigs mB1	`thenRn4` \ (uniq1, flat1) ->
-    flattenMonoBinds uniq1 sigs mB2	`thenRn4` \ (uniq2, flat2) ->
-    returnRn4 (uniq2, flat1 ++ flat2)
-
-flattenMonoBinds uniq sigs (PatMonoBind pat grhss_and_binds locn)
-  = pushSrcLocRn4 locn		 		  (
-    rnPat4 pat				`thenRn4` \ pat' ->
-    rnGRHSsAndBinds4 grhss_and_binds	`thenRn4` \ (grhss_and_binds', fvs) ->
-
-	 -- 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"
-    in
-    returnRn4 (
-	uniq + 1,
-	[(uniq,
-	  mkUniqSet names_bound_here,
-	   fvs `unionUniqSets` sigs_fvs,
-	   PatMonoBind pat' grhss_and_binds' locn,
-	   sigs_etc_for_here
-	 )]
-    ))
-
-flattenMonoBinds uniq sigs (FunMonoBind name matches locn)
-  = pushSrcLocRn4 locn			    	  (
-    lookupValue name			`thenRn4` \ name' ->
-    mapAndUnzipRn4 rnMatch4 matches	`thenRn4` \ (new_matches, fv_lists) ->
-    let
-	fvs = unionManyUniqSets fv_lists
-
-	sigs_for_me = foldl (sig_for_here (\ n -> n `eqName` name')) [] sigs
-
-	sigs_fvs = foldr sig_fv emptyUniqSet sigs_for_me
-    in
-    returnRn4 (
-      uniq + 1,
-      [(uniq,
-        singletonUniqSet name',
-	fvs `unionUniqSets` sigs_fvs,
-	FunMonoBind name' new_matches locn,
-	sigs_for_me
-	)]
-    ))
-\end{code}
-
-Grab type-signatures/user-pragmas of interest:
-\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
-
--- 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` singletonUniqSet blah
-sig_fv _			   acc = acc
-\end{code}
-
-%************************************************************************
-%*									*
-\subsection[reconstruct-deps]{Reconstructing dependencies}
-%*									*
-%************************************************************************
-
-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
-		-> RenamedBinds
-
-reconstructRec cycles edges mbi
-  = foldr1 ThenBinds (map (reconstructCycle mbi) cycles)
-  where
-    reconstructCycle :: FlatMonoBindsInfo -> Cycle -> RenamedBinds
-
-    reconstructCycle mbi2 cycle
-      = BIND [(binds,sigs) | (vertex, _, _, binds, sigs) <- mbi2, vertex `is_elem` cycle]
-		  _TO_ relevant_binds_and_sigs ->
-
-	BIND (unzip relevant_binds_and_sigs) _TO_ (binds, sig_lists) ->
-
-	BIND (foldr AndMonoBinds EmptyMonoBinds binds) _TO_ 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
-	BEND BEND BEND
-      where
-	is_elem = isIn "reconstructRec"
-
-	mk_binds :: RenamedMonoBinds -> [RenamedSig]
-		 -> Bool -> Bool -> RenamedBinds
-
-	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
-\end{code}
-
-%************************************************************************
-%*									*
-%*	Manipulating FlatMonoBindInfo					*
-%*									*
-%************************************************************************
-
-During analysis a @MonoBinds@ is flattened to a @FlatMonoBindsInfo@.
-The @RenamedMonoBinds@ is always an empty bind, a pattern binding or
-a function binding, and has itself been dependency-analysed and
-renamed.
-
-\begin{code}
-type FlatMonoBindsInfo
-  = [(VertexTag,		-- Identifies the vertex
-      UniqSet Name,		-- Set of names defined in this vertex
-      UniqSet Name,		-- 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
-    ]
-
-mkVertices :: FlatMonoBindsInfo -> [VertexTag]
-mkVertices info = [ vertex | (vertex,_,_,_,_) <- info]
-
-mkEdges :: [VertexTag] -> FlatMonoBindsInfo -> [Edge]
-
-mkEdges vertices 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_vertex <- vertices_defining target_name flat_info
-   ]
-   where
-   -- If each name only has one binding in this group, then
-   -- vertices_defining will always return the empty list, or a
-   -- singleton.  The case when there is more than one binding (an
-   -- error) needs more thought.
-
-   vertices_defining name flat_info2
-    = [ vertex |  (vertex, names_defined, _, _, _) <- flat_info2,
-		name `elementOfUniqSet` names_defined
-      ]
-\end{code}
-
-
-%************************************************************************
-%*									*
-\subsubsection[dep-Sigs]{Signatures (and user-pragmas for values)}
-%*									*
-%************************************************************************
-
-@rnBindSigs4@ checks for: (a)~more than one sig for one thing;
-(b)~signatures given for things not bound here; (c)~with suitably
-flaggery, that all top-level things have type signatures.
-
-\begin{code}
-rnBindSigs4 :: Bool		    -- True <=> top-level binders
-	    -> [ProtoName]	    -- Binders for this decl group
-	    -> [ProtoNameSig]	    
-	    -> Rn4M [RenamedSig]    -- List of Sig constructors
-
-rnBindSigs4 is_toplev binder_pnames sigs
-  =
-	 -- Rename the signatures
-	 -- Will complain about sigs for variables not in this group
-    mapRn4 rename_sig sigs   `thenRn4` \ sigs_maybe ->
-    let
-	sigs' = catMaybes sigs_maybe
-
-	 -- Discard unbound ones we've already complained about, so we
-	 -- complain about duplicate ones.
-
-	(goodies, dups) = removeDups cmp (filter not_unbound sigs')
-    in
-    mapRn4 (addErrRn4 . dupSigDeclErr) dups `thenRn4_`
-
-    getSwitchCheckerRn4		`thenRn4` \ sw_chkr ->
-    getSrcLocRn4		`thenRn4` \ locn ->
-
-    (if (is_toplev && sw_chkr SigsRequired) then
-	let
-	    sig_frees = catMaybes (map (sig_free sigs) binder_pnames)
-	in
-	mapRn4 (addErrRn4 . missingSigErr locn) sig_frees
-     else
-	returnRn4 []
-    )					    `thenRn4_`
-
-    returnRn4 sigs' -- bad ones and all:
-		    -- we need bindings of *some* sort for every name
-  where
-    rename_sig (Sig v ty pragma src_loc)
-      = pushSrcLocRn4 src_loc 	(
-
-	if not (v `elemByLocalNames` binder_pnames) then
-	   addErrRn4 (unknownSigDeclErr "type signature" v src_loc) `thenRn4_`
-	   returnRn4 Nothing
-	else
-	   lookupValue v				`thenRn4` \ new_v ->
-	   rnPolyType4 False True nullTyVarNamesEnv ty	`thenRn4` \ new_ty ->
-	   recoverQuietlyRn4 NoGenPragmas (
-		rnGenPragmas4 pragma
-	   )					    `thenRn4` \ new_pragma ->
-	   returnRn4 (Just (Sig new_v new_ty new_pragma src_loc))
-	)
-
-    -- and now, the various flavours of value-modifying user-pragmas:
-
-    rename_sig (SpecSig v ty using src_loc)
-      = pushSrcLocRn4 src_loc 	(
-
-	if not (v `elemByLocalNames` binder_pnames) then
-	   addErrRn4 (unknownSigDeclErr "SPECIALIZE pragma" v src_loc) `thenRn4_`
-	   returnRn4 Nothing
-	else
-	   lookupValue v				`thenRn4` \ new_v ->
-	   rnPolyType4 False True nullTyVarNamesEnv ty	`thenRn4` \ new_ty ->
-	   rn_using using				`thenRn4` \ new_using ->
-	   returnRn4 (Just (SpecSig new_v new_ty new_using src_loc))
-	)
-      where
-	rn_using Nothing  = returnRn4 Nothing
-	rn_using (Just x) = lookupValue x `thenRn4` \ new_x ->
-			    returnRn4 (Just new_x)
-
-    rename_sig (InlineSig v howto src_loc)
-      = pushSrcLocRn4 src_loc 	(
-
-	if not (v `elemByLocalNames` binder_pnames) then
-	   addErrRn4 (unknownSigDeclErr "INLINE pragma" v src_loc) `thenRn4_`
-	   returnRn4 Nothing
-	else
-	   lookupValue v	`thenRn4` \ new_v ->
-	   returnRn4 (Just (InlineSig new_v howto src_loc))
-	)
-
-    rename_sig (DeforestSig v src_loc)
-      = pushSrcLocRn4 src_loc   (
-
-	if not (v `elemByLocalNames` binder_pnames) then
-	   addErrRn4 (unknownSigDeclErr "DEFOREST pragma" v src_loc) `thenRn4_`
-	   returnRn4 Nothing
-	else
-	   lookupValue v        `thenRn4` \ new_v ->
-	   returnRn4 (Just (DeforestSig new_v src_loc))
-	)
-
-    rename_sig (MagicUnfoldingSig v str src_loc)
-      = pushSrcLocRn4 src_loc 	(
-
-	if not (v `elemByLocalNames` binder_pnames) then
-	   addErrRn4 (unknownSigDeclErr "MAGIC_UNFOLDING pragma" v src_loc) `thenRn4_`
-	   returnRn4 Nothing
-	else
-	   lookupValue v	`thenRn4` \ new_v ->
-	   returnRn4 (Just (MagicUnfoldingSig new_v str src_loc))
-	)
-
-    not_unbound :: RenamedSig -> Bool
-
-    not_unbound (Sig n _ _ _)		  = not (isUnboundName n)
-    not_unbound (SpecSig n _ _ _)	  = not (isUnboundName n)
-    not_unbound (InlineSig n _ _)	  = not (isUnboundName n)
-    not_unbound (DeforestSig n _)	  = not (isUnboundName n)
-    not_unbound (MagicUnfoldingSig n _ _) = not (isUnboundName n)
-
-    -------------------------------------
-    sig_free :: [ProtoNameSig] -> ProtoName -> Maybe ProtoName
-	-- 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 `eqByLocalName` ny) then Nothing else sig_free rest ny
-    sig_free (_ : rest) ny = sig_free rest ny
-
-    -------------------------------------
-    cmp :: RenamedSig -> RenamedSig -> TAG_
-
-    cmp (Sig n1 _ _ _)	    	   (Sig n2 _ _ _)    	      = n1 `cmpName` n2
-    cmp (InlineSig n1 _ _)  	   (InlineSig n2 _ _) 	      = n1 `cmpName` n2
-    cmp (MagicUnfoldingSig n1 _ _) (MagicUnfoldingSig n2 _ _) = n1 `cmpName` n2
-    cmp (SpecSig n1 ty1 _ _)	   (SpecSig n2 ty2 _ _)
-      = -- may have many specialisations for one value;
-	-- but not ones that are exactly the same...
-	case (n1 `cmpName` n2) of
-	  EQ_   -> cmpPolyType cmpName ty1 ty2
-	  other -> other
-
-    cmp 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 _ = case (panic "tag(RenameBinds4)") of { s -> tag s } -- BUG avoidance
-\end{code}
diff --git a/ghc/compiler/rename/RenameExpr4.hi b/ghc/compiler/rename/RenameExpr4.hi
deleted file mode 100644
index cda02c4ba6..0000000000
--- a/ghc/compiler/rename/RenameExpr4.hi
+++ /dev/null
@@ -1,43 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface RenameExpr4 where
-import Bag(Bag)
-import CmdLineOpts(GlobalSwitch)
-import FiniteMap(FiniteMap)
-import HsBinds(Binds)
-import HsLit(Literal)
-import HsMatches(GRHS, GRHSsAndBinds, Match)
-import HsPat(InPat)
-import Id(Id)
-import Maybes(Labda)
-import Name(Name)
-import NameTypes(FullName, ShortName)
-import PreludePS(_PackedString)
-import Pretty(PprStyle, Pretty(..), PrettyRep)
-import ProtoName(ProtoName)
-import RenameAuxFuns(GlobalNameFun(..))
-import SplitUniq(SplitUniqSupply)
-import SrcLoc(SrcLoc)
-import TyCon(TyCon)
-import UniType(UniType)
-import UniqFM(UniqFM)
-import UniqSet(UniqSet(..))
-import Unique(Unique)
-data Bag a 
-data GRHSsAndBinds a b 
-data InPat a 
-data Labda a 
-data Name 
-data PprStyle 
-type Pretty = Int -> Bool -> PrettyRep
-data PrettyRep 
-data ProtoName 
-type GlobalNameFun = ProtoName -> Labda Name
-data SplitUniqSupply 
-data SrcLoc 
-data UniqFM a 
-type UniqSet a = UniqFM a
-data Unique 
-rnGRHSsAndBinds4 :: GRHSsAndBinds ProtoName (InPat ProtoName) -> (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> ((GRHSsAndBinds Name (InPat Name), UniqFM Name), Bag (PprStyle -> Int -> Bool -> PrettyRep))
-rnMatch4 :: Match ProtoName (InPat ProtoName) -> (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> ((Match Name (InPat Name), UniqFM Name), Bag (PprStyle -> Int -> Bool -> PrettyRep))
-rnPat4 :: InPat ProtoName -> (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (InPat Name, Bag (PprStyle -> Int -> Bool -> PrettyRep))
-
diff --git a/ghc/compiler/rename/RenameExpr4.lhs b/ghc/compiler/rename/RenameExpr4.lhs
deleted file mode 100644
index 34c702e8b6..0000000000
--- a/ghc/compiler/rename/RenameExpr4.lhs
+++ /dev/null
@@ -1,431 +0,0 @@
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1994
-%
-\section[RenameExpr]{Renaming of expressions}
-
-Basically dependency analysis.
-
-Handles @Match@, @GRHSsAndBinds@, @Expr@, and @Qual@ datatypes.  In
-general, all of these functions return a renamed thing, and a set of
-free variables.
-
-\begin{code}
-#include "HsVersions.h"
-
-module RenameExpr4 (
-	rnMatch4, rnGRHSsAndBinds4, rnPat4,
-	
-	-- and to make the interface self-sufficient...
-	Bag, GRHSsAndBinds, InPat, Name, Maybe,
-	ProtoName, GlobalNameFun(..), UniqSet(..), UniqFM, SrcLoc,
-	Unique, SplitUniqSupply,
-	Pretty(..), PprStyle, PrettyRep
-   ) where
-
-import AbsSyn
-import NameTypes	( FullName )
-import Outputable
-import ProtoName	( ProtoName(..) )
-import Rename4		( rnPolyType4 )
-import RenameAuxFuns	( GlobalNameFuns(..) ) -- ToDo: rm this line
-import RenameBinds4	( rnBinds4, FreeVars(..) )
-import RenameMonad4
-import UniqSet
-import Util
-\end{code}
-
-
-*********************************************************
-*							*
-\subsection{Patterns}
-*							*
-*********************************************************
-
-\begin{code}
-rnPat4 ::  ProtoNamePat -> Rn4M RenamedPat
-
-rnPat4  WildPatIn = returnRn4 WildPatIn
-
-rnPat4 (VarPatIn name)
-  = lookupValue name	`thenRn4` \ vname ->
-    returnRn4 (VarPatIn vname)
-
-rnPat4  (LitPatIn n) = returnRn4 (LitPatIn n)
-
-rnPat4  (LazyPatIn pat)
-  = rnPat4  pat	`thenRn4` \ pat' ->
-    returnRn4 (LazyPatIn pat')
-
-rnPat4  (AsPatIn name pat)
-  = rnPat4  pat	`thenRn4` \ pat' ->
-    lookupValue name	`thenRn4` \ vname ->
-    returnRn4 (AsPatIn vname pat')
-
-rnPat4 (ConPatIn name pats)
-  = lookupValue name	    `thenRn4` \ name' ->
-    mapRn4 rnPat4 pats  `thenRn4` \ patslist ->
-    returnRn4 (ConPatIn name' patslist)
-
-rnPat4  (ConOpPatIn pat1 name pat2)
-  = lookupValue name	`thenRn4` \ name' ->
-    rnPat4  pat1	`thenRn4` \ pat1' ->
-    rnPat4  pat2	`thenRn4` \ pat2' ->
-    returnRn4 (ConOpPatIn pat1' name' pat2')
-
-rnPat4  (ListPatIn pats)
-  = mapRn4 rnPat4 pats `thenRn4` \ patslist ->
-    returnRn4 (ListPatIn patslist)
-
-rnPat4  (TuplePatIn pats)
-  = mapRn4 rnPat4 pats `thenRn4` \ patslist ->
-    returnRn4 (TuplePatIn patslist)
-
-rnPat4  (NPlusKPatIn name lit)
-  = lookupValue name	`thenRn4` \ vname ->
-    returnRn4 (NPlusKPatIn vname lit)
-
-#ifdef DPH
-rnPat4  (ProcessorPatIn pats pat)
-  = mapRn4 rnPat4 pats  `thenRn4` \ pats' ->
-    rnPat4 pat	    `thenRn4` \ pat'  ->
-    returnRn4 (ProcessorPatIn pats' pat')
-#endif {- Data Parallel Haskell -}
-\end{code}
-
-************************************************************************
-*									*
-\subsection{Match}
-*									*
-************************************************************************
-
-\begin{code}
-rnMatch4 :: ProtoNameMatch -> Rn4M (RenamedMatch, FreeVars)
-
-rnMatch4 match
-  = getSrcLocRn4			`thenRn4` \ src_loc ->
-    namesFromProtoNames "variable in pattern"
-	 (binders `zip` repeat src_loc)	`thenRn4` \ new_binders ->
-    extendSS2 new_binders (rnMatch4_aux match)
-  where
-    binders = collect_binders match
-
-    collect_binders :: ProtoNameMatch -> [ProtoName]
-
-    collect_binders (GRHSMatch _) = []
-    collect_binders (PatMatch pat match)
-      = collectPatBinders pat ++ collect_binders match
-
-rnMatch4_aux (PatMatch pat match)
-  = rnPat4 pat		`thenRn4` \ pat' ->
-    rnMatch4_aux match	`thenRn4` \ (match', fvMatch) ->
-    returnRn4 (PatMatch pat' match', fvMatch)
-
-rnMatch4_aux (GRHSMatch grhss_and_binds)
-  = rnGRHSsAndBinds4 grhss_and_binds `thenRn4` \ (grhss_and_binds', fvs) ->
-    returnRn4 (GRHSMatch grhss_and_binds', fvs)
-\end{code}
-
-%************************************************************************
-%*									*
-\subsubsection[dep-GRHSs]{Guarded right-hand sides (GRHSsAndBinds)}
-%*									*
-%************************************************************************
-
-\begin{code}
-rnGRHSsAndBinds4 :: ProtoNameGRHSsAndBinds -> Rn4M (RenamedGRHSsAndBinds, FreeVars)
-
-rnGRHSsAndBinds4 (GRHSsAndBindsIn grhss binds)
-  = rnBinds4 binds			`thenRn4` \ (binds', fvBinds, scope) ->
-    extendSS2 scope (rnGRHSs4 grhss)	`thenRn4` \ (grhss', fvGRHS) ->
-    returnRn4 (GRHSsAndBindsIn grhss' binds', fvBinds `unionUniqSets` fvGRHS)
-  where
-    rnGRHSs4 [] = returnRn4 ([], emptyUniqSet)
-
-    rnGRHSs4 (grhs:grhss)
-      = rnGRHS4  grhs   `thenRn4` \ (grhs',  fvs) ->
-	rnGRHSs4 grhss  `thenRn4` \ (grhss', fvss) ->
-	returnRn4 (grhs' : grhss', fvs `unionUniqSets` fvss)
-
-    rnGRHS4 (GRHS guard expr locn)
-      = pushSrcLocRn4 locn			      	  (
-        rnExpr4 guard   `thenRn4` \ (guard', fvsg) ->
-	rnExpr4 expr	`thenRn4` \ (expr',  fvse) ->
-	returnRn4 (GRHS guard' expr' locn, fvsg `unionUniqSets` fvse)
-	)
-
-    rnGRHS4 (OtherwiseGRHS expr locn)
-      = pushSrcLocRn4 locn			      	  (
-        rnExpr4 expr	`thenRn4` \ (expr', fvs) ->
-	returnRn4 (OtherwiseGRHS expr' locn, fvs)
-	)
-\end{code}
-
-%************************************************************************
-%*									*
-\subsubsection[dep-Expr]{Expressions}
-%*									*
-%************************************************************************
-
-\begin{code}
-rnExprs4 :: [ProtoNameExpr] -> Rn4M ([RenamedExpr], FreeVars)
-
-rnExprs4 [] = returnRn4 ([], emptyUniqSet)
-
-rnExprs4 (expr:exprs)
-  = rnExpr4 expr 	`thenRn4` \ (expr', fvExpr) ->
-    rnExprs4 exprs	`thenRn4` \ (exprs', fvExprs) ->
-    returnRn4 (expr':exprs', fvExpr `unionUniqSets` 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 Name returned from the lookup, and make it part of the
-free-var set iff:
-\begin{itemize}
-\item
-if it's a @Short@,
-\item
-or it's an @OtherTopId@ and it's defined in this module
-(this includes locally-defined constructrs, but that's too bad)
-\end{itemize}
-
-\begin{code}
-rnExpr4 :: ProtoNameExpr -> Rn4M (RenamedExpr, FreeVars)
-
-rnExpr4 (Var v)
-  = lookupValue v		`thenRn4` \ vname ->
-    returnRn4 (Var vname, fv_set vname)
-  where
-    fv_set n@(Short uniq sname)	    = singletonUniqSet n
-    fv_set n@(OtherTopId uniq fname)
-	  | isLocallyDefined fname
-	  && not (isConop (getOccurrenceName fname))
-				    = singletonUniqSet n
-    fv_set other  		    = emptyUniqSet
-
-rnExpr4 (Lit lit)  = returnRn4 (Lit lit, emptyUniqSet)
-
-rnExpr4 (Lam match)
-  = rnMatch4 match	`thenRn4` \ (match', fvMatch) ->
-    returnRn4 (Lam match', fvMatch)
-
-rnExpr4 (App fun arg)
-  = rnExpr4 fun	`thenRn4` \ (fun',fvFun) ->
-    rnExpr4 arg	`thenRn4` \ (arg',fvArg) ->
-    returnRn4 (App fun' arg', fvFun `unionUniqSets` fvArg)
-
-rnExpr4 (OpApp e1 op e2)
-  = rnExpr4 e1 	`thenRn4` \ (e1', fvs_e1) ->
-    rnExpr4 op 	`thenRn4` \ (op', fvs_op) ->
-    rnExpr4 e2 	`thenRn4` \ (e2', fvs_e2) ->
-    returnRn4 (OpApp e1' op' e2', (fvs_op `unionUniqSets` fvs_e1) `unionUniqSets` fvs_e2)
-
-rnExpr4 (SectionL expr op)
-  = rnExpr4 expr	 `thenRn4` \ (expr', fvs_expr) ->
-    rnExpr4 op	 `thenRn4` \ (op', fvs_op) ->
-    returnRn4 (SectionL expr' op', fvs_op `unionUniqSets` fvs_expr)
-
-rnExpr4 (SectionR op expr)
-  = rnExpr4 op	 `thenRn4` \ (op',   fvs_op) ->
-    rnExpr4 expr	 `thenRn4` \ (expr', fvs_expr) ->
-    returnRn4 (SectionR op' expr', fvs_op `unionUniqSets` fvs_expr)
-
-rnExpr4 (CCall fun args may_gc is_casm fake_result_ty)
-  = rnExprs4 args	 `thenRn4` \ (args', fvs_args) ->
-    returnRn4 (CCall fun args' may_gc is_casm fake_result_ty, fvs_args)
-
-rnExpr4 (SCC label expr)
-  = rnExpr4 expr	 `thenRn4` \ (expr', fvs_expr) ->
-    returnRn4 (SCC label expr', fvs_expr)
-
-rnExpr4 (Case expr ms)
-  = rnExpr4 expr		 `thenRn4` \ (new_expr, e_fvs) ->
-    mapAndUnzipRn4 rnMatch4 ms   `thenRn4` \ (new_ms, ms_fvs) ->
-    returnRn4 (Case new_expr new_ms, unionManyUniqSets (e_fvs : ms_fvs))
-
-rnExpr4 (ListComp expr quals)
-  = rnQuals4 quals 	`thenRn4` \ ((quals', qual_binders), fvQuals) ->
-    extendSS2 qual_binders (rnExpr4 expr) `thenRn4` \ (expr', fvExpr) ->
-    returnRn4 (ListComp expr' quals', fvExpr `unionUniqSets` fvQuals)
-
-rnExpr4 (Let binds expr)
-  = rnBinds4 binds	`thenRn4` \ (binds', fvBinds, new_binders) ->
-    extendSS2 new_binders (rnExpr4 expr) `thenRn4` \ (expr',fvExpr) ->
-    returnRn4 (Let binds' expr', fvBinds `unionUniqSets` fvExpr)
-
-rnExpr4 (ExplicitList exps)
-  = rnExprs4 exps	 `thenRn4` \ (exps', fvs) ->
-    returnRn4  (ExplicitList exps', fvs)
-
-rnExpr4 (ExplicitTuple exps)
-  = rnExprs4 exps	 `thenRn4` \ (exps', fvExps) ->
-    returnRn4 (ExplicitTuple exps', fvExps)
-
-rnExpr4 (ExprWithTySig expr pty)
-  = rnExpr4 expr				 `thenRn4` \ (expr', fvExpr) ->
-    rnPolyType4 False True nullTyVarNamesEnv pty `thenRn4` \ pty' ->
-    returnRn4 (ExprWithTySig expr' pty', fvExpr)
-
-rnExpr4 (If p b1 b2)
-  = rnExpr4 p	`thenRn4` \ (p', fvP) ->
-    rnExpr4 b1	`thenRn4` \ (b1', fvB1) ->
-    rnExpr4 b2	`thenRn4` \ (b2', fvB2) ->
-    returnRn4 (If p' b1' b2', unionManyUniqSets [fvP, fvB1, fvB2])
-
-rnExpr4 (ArithSeqIn seq)
-  = rn_seq seq `thenRn4` \ (new_seq, fvs) ->
-    returnRn4 (ArithSeqIn new_seq, fvs)
-  where
-    rn_seq (From expr)
-     = rnExpr4 expr 	 `thenRn4` \ (expr', fvExpr) ->
-       returnRn4 (From expr', fvExpr)
-
-    rn_seq (FromThen expr1 expr2)
-     = rnExpr4 expr1 	 `thenRn4` \ (expr1', fvExpr1) ->
-       rnExpr4 expr2	 `thenRn4` \ (expr2', fvExpr2) ->
-       returnRn4 (FromThen expr1' expr2', fvExpr1 `unionUniqSets` fvExpr2)
-
-    rn_seq (FromTo expr1 expr2)
-     = rnExpr4 expr1	 `thenRn4` \ (expr1', fvExpr1) ->
-       rnExpr4 expr2	 `thenRn4` \ (expr2', fvExpr2) ->
-       returnRn4 (FromTo expr1' expr2', fvExpr1 `unionUniqSets` fvExpr2)
-
-    rn_seq (FromThenTo expr1 expr2 expr3)
-     = rnExpr4 expr1	 `thenRn4` \ (expr1', fvExpr1) ->
-       rnExpr4 expr2	 `thenRn4` \ (expr2', fvExpr2) ->
-       rnExpr4 expr3	 `thenRn4` \ (expr3', fvExpr3) ->
-       returnRn4 (FromThenTo expr1' expr2' expr3',
-		  unionManyUniqSets [fvExpr1, fvExpr2, fvExpr3])
-
-#ifdef DPH
-rnExpr4 (ParallelZF expr quals)
-  = rnParQuals4 quals	  `thenRn4` \ ((quals',binds),fvQuals)->
-    extendSS2  binds 
-		(rnExpr4 expr) `thenRn4` \ (expr', fvExpr ) ->
-    returnRn4 (ParallelZF expr' quals' , fvExpr `unionUniqSets` fvQuals)
-
-rnExpr4 (ExplicitProcessor exprs expr)
-  = rnExprs4 exprs	`thenRn4` \ (exprs',fvExprs) ->
-    rnExpr4  expr	`thenRn4` \ (expr' ,fvExpr)  ->
-    returnRn4 (ExplicitProcessor exprs' expr',fvExprs `unionUniqSets` fvExpr)
-
-rnExpr4 (ExplicitPodIn exprs)
-  = rnExprs4 exprs	`thenRn4` \ (exprs',fvExprs) ->
-    returnRn4 (ExplicitPodIn exprs',fvExprs)
-
--- ExplicitPodOut : not in ProtoNameExprs (pops out of typechecker :-)
-
-#endif {- Data Parallel Haskell -}
-
--- ArithSeqOut: not in ProtoNameExprs
-\end{code}
-
-%************************************************************************
-%*									*
-\subsubsection[dep-Quals]{@Qual@s: in list comprehensions}
-%*									*
-%************************************************************************
-
-Note that although some bound vars may appear in the free var set for
-the first qual, these will eventually be removed by the caller. For
-example, if we have @[p | r <- s, q <- r, p <- q]@, when doing
-@(AndQuals (q <- r) (p <- q))@, the free var set for @(q <- r)@ will
-be @[r]@, and the free var set for the entire Quals will be @[r]@. This
-@r@ will be removed only when we finally return from examining all the
-Quals.
-
-\begin{code}
-rnQuals4 :: [ProtoNameQual]  -> Rn4M (([RenamedQual], [Name]), FreeVars)
-
-rnQuals4 [qual]
-  = rnQual4 qual `thenRn4` \ ((new_qual, bs), fvs) ->
-    returnRn4 (([new_qual], bs), fvs)
-
-rnQuals4 (qual: quals)
-  = rnQual4 qual			`thenRn4` \ ((qual',  bs1), fvQuals1) ->
-    extendSS2 bs1 (rnQuals4 quals)	`thenRn4` \ ((quals', bs2), fvQuals2) ->
-    returnRn4
-       ((qual' : quals', bs2 ++ bs1),	-- The ones on the right (bs2) shadow the
-					-- ones on the left (bs1)
-	fvQuals1 `unionUniqSets` fvQuals2)
-
-rnQual4 (GeneratorQual pat expr)
-  = rnExpr4 expr		 `thenRn4` \ (expr', fvExpr) ->
-    let
-	binders = collectPatBinders pat
-    in
-    getSrcLocRn4		 `thenRn4` \ src_loc ->
-    namesFromProtoNames "variable in list-comprehension-generator pattern"
-	 (binders `zip` repeat src_loc)	  `thenRn4` \ new_binders ->
-    extendSS new_binders (rnPat4 pat) `thenRn4` \ pat' ->
-
-    returnRn4 ((GeneratorQual pat' expr', new_binders), fvExpr)
-
-rnQual4 (FilterQual expr)
-  = rnExpr4 expr	 `thenRn4` \ (expr', fvs) ->
-    returnRn4 ((FilterQual expr', []), fvs)
-\end{code}
-
-%************************************************************************
-%*									*
-%* Parallel Quals (in Parallel Zf expressions)				*
-%*									*
-%************************************************************************
-\subsubsection[dep-ParQuals]{ParQuals}
-
-\begin{code}
-#ifdef DPH
-rnPats4 :: [ProtoNamePat] -> Rn4M [RenamedPat]
-rnPats4 [] = returnRn4 []
-rnPats4 (pat:pats)
-  = (rnPat4  pat) 	 	`thenRn4` (\ pat'  ->
-    (rnPats4 pats)   	`thenRn4` (\ pats' ->
-    returnRn4 (pat':pats') ))
-
-rnParQuals4 :: ProtoNameParQuals  -> Rn4M ((RenamedParQuals, [Name]), FreeVars)
-
-rnParQuals4 (AndParQuals q1 q2)
- = rnParQuals4 q1		`thenRn4` (\ ((quals1', bs1), fvQuals1) ->
-   extendSS2 bs1 (rnParQuals4 q2)	
-				`thenRn4` (\ ((quals2', bs2), fvQuals2) ->
-   returnRn4 ((AndParQuals quals1' quals2', bs2 ++ bs1),
-       		    fvQuals1 `unionUniqSets` fvQuals2) ))
-
-	
-rnParQuals4 (DrawnGenIn pats pat expr)
- = rnExpr4 expr		 `thenRn4` 	(\ (expr', fvExpr) ->
-   let_1_0 (concat (map collectPatBinders pats))	(\ binders1 ->
-   getSrcLocRn4		`thenRn4`		(\ src_loc ->
-   namesFromProtoNames "variable in pattern" 
-	(binders1 `zip` repeat src_loc)
-				`thenRn4`		(\ binders1' ->
-   extendSS binders1' (rnPats4 pats)		
-				`thenRn4` 		(\ pats' ->
-   let_1_0 (collectPatBinders pat)			(\ binders2 ->
-   namesFromProtoNames "variable in pattern" 
-	(binders2 `zip` repeat src_loc)
-				`thenRn4`		(\ binders2' ->
-   extendSS binders2' (rnPat4 pat)		
-				`thenRn4` 		(\ pat' ->
-   returnRn4 ((DrawnGenIn pats' pat' expr' , binders1' ++ binders2'),
-		   fvExpr) ))))))))
-   
-rnParQuals4 (IndexGen exprs pat expr)
- = rnExpr4  expr		 `thenRn4` 	(\ (expr',  fvExpr) ->
-   rnExprs4 exprs		 `thenRn4` 	(\ (exprs', fvExprs) ->
-   let_1_0 (collectPatBinders pat)			(\ binders ->
-   getSrcLocRn4		`thenRn4`		(\ src_loc ->
-   namesFromProtoNames "variable in pattern" 
-	(binders `zip` repeat src_loc)
-				`thenRn4`	(\ binders' ->
-   extendSS binders' (rnPat4 pat)		
-				`thenRn4` 	(\ pat' ->
-   returnRn4 ((IndexGen exprs' pat' expr' , binders'),
-		   fvExpr `unionUniqSets` fvExprs) ))))))
-
-rnParQuals4 (ParFilter expr)
- = rnExpr4 expr	 `thenRn4` (\  (expr', fvExpr) ->
-   returnRn4         ((ParFilter expr', []), fvExpr) )
-#endif {- Data Parallel Haskell -}
-\end{code}
diff --git a/ghc/compiler/rename/RenameMonad12.hi b/ghc/compiler/rename/RenameMonad12.hi
deleted file mode 100644
index 0a929ad33d..0000000000
--- a/ghc/compiler/rename/RenameMonad12.hi
+++ /dev/null
@@ -1,23 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface RenameMonad12 where
-import Bag(Bag)
-import CharSeq(CSeq)
-import CmdLineOpts(GlobalSwitch)
-import PreludePS(_PackedString)
-import Pretty(Delay, PprStyle, Pretty(..), PrettyRep)
-infixr 9 `thenRn12`
-data Bag a 
-data PprStyle 
-type Pretty = Int -> Bool -> PrettyRep
-data PrettyRep 
-type Rn12M a = _PackedString -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> (a, Bag (PprStyle -> Int -> Bool -> PrettyRep))
-addErrRn12 :: (PprStyle -> Int -> Bool -> PrettyRep) -> _PackedString -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> ((), Bag (PprStyle -> Int -> Bool -> PrettyRep))
-foldrRn12 :: (a -> b -> _PackedString -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> (b, Bag (PprStyle -> Int -> Bool -> PrettyRep))) -> b -> [a] -> _PackedString -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> (b, Bag (PprStyle -> Int -> Bool -> PrettyRep))
-getModuleNameRn12 :: _PackedString -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> (_PackedString, Bag (PprStyle -> Int -> Bool -> PrettyRep))
-initRn12 :: _PackedString -> (_PackedString -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> (a, Bag (PprStyle -> Int -> Bool -> PrettyRep))) -> (a, Bag (PprStyle -> Int -> Bool -> PrettyRep))
-mapRn12 :: (a -> _PackedString -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> (b, Bag (PprStyle -> Int -> Bool -> PrettyRep))) -> [a] -> _PackedString -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> ([b], Bag (PprStyle -> Int -> Bool -> PrettyRep))
-recoverQuietlyRn12 :: a -> (_PackedString -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> (a, Bag (PprStyle -> Int -> Bool -> PrettyRep))) -> _PackedString -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> (a, Bag (PprStyle -> Int -> Bool -> PrettyRep))
-returnRn12 :: a -> _PackedString -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> (a, Bag (PprStyle -> Int -> Bool -> PrettyRep))
-thenRn12 :: (_PackedString -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> (a, Bag (PprStyle -> Int -> Bool -> PrettyRep))) -> (a -> _PackedString -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> (b, Bag (PprStyle -> Int -> Bool -> PrettyRep))) -> _PackedString -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> (b, Bag (PprStyle -> Int -> Bool -> PrettyRep))
-zipWithRn12 :: (a -> b -> _PackedString -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> (c, Bag (PprStyle -> Int -> Bool -> PrettyRep))) -> [a] -> [b] -> _PackedString -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> ([c], Bag (PprStyle -> Int -> Bool -> PrettyRep))
-
diff --git a/ghc/compiler/rename/RenameMonad12.lhs b/ghc/compiler/rename/RenameMonad12.lhs
deleted file mode 100644
index b60f2932b4..0000000000
--- a/ghc/compiler/rename/RenameMonad12.lhs
+++ /dev/null
@@ -1,98 +0,0 @@
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
-%
-\section[RenameMonad12]{The monad used by the renamer passes 1 and 2}
-
-\begin{code}
-#include "HsVersions.h"
-
-module RenameMonad12 (
-	Rn12M(..),
-	initRn12, thenRn12, returnRn12,
-	mapRn12, zipWithRn12, foldrRn12,
-	addErrRn12, getModuleNameRn12, recoverQuietlyRn12,
-
-	-- and to make the interface self-sufficient...
-	Bag, Pretty(..), PprStyle, PrettyRep
-    ) where
-
-import Bag
-import Errors
-import Outputable
-import Pretty		-- for type Pretty
-import Util		-- for pragmas only
-
-infixr 9 `thenRn12`
-\end{code}
-
-In this monad, we pass down the name of the module we are working on,
-and we thread the collected errors.
-
-\begin{code}
-type Rn12M result
-  =  FAST_STRING{-module name-}
-  -> Bag Error
-  -> (result, Bag Error)
-
-#ifdef __GLASGOW_HASKELL__
-{-# INLINE thenRn12 #-}
-{-# INLINE returnRn12 #-}
-#endif
-
-initRn12 :: FAST_STRING{-module name-} -> Rn12M a -> (a, Bag Error)
-initRn12 mod action = action mod emptyBag
-
-thenRn12 :: Rn12M a -> (a -> Rn12M b) -> Rn12M b
-thenRn12 expr continuation mod errs_so_far
-  = case (expr mod errs_so_far) of
-     (res1, errs1) -> continuation res1 mod errs1
-
-returnRn12 :: a -> Rn12M a
-returnRn12 x mod errs_so_far = (x, errs_so_far)
-
-mapRn12 :: (a -> Rn12M b) -> [a] -> Rn12M [b]
-
-mapRn12 f []     = returnRn12 []
-mapRn12 f (x:xs)
-  = f x		 `thenRn12` \ r ->
-    mapRn12 f xs `thenRn12` \ rs ->
-    returnRn12 (r:rs)
-
-zipWithRn12 :: (a -> b -> Rn12M c) -> [a] -> [b] -> Rn12M [c]
-
-zipWithRn12 f []     [] = returnRn12 []
-zipWithRn12 f (x:xs) (y:ys)
-  = f x y	     	`thenRn12` \ r ->
-    zipWithRn12 f xs ys `thenRn12` \ rs ->
-    returnRn12 (r:rs)
-
-foldrRn12 :: (a -> b -> Rn12M b) -> b -> [a] -> Rn12M b
-
-foldrRn12 f z []     = returnRn12 z
-foldrRn12 f z (x:xs)
- = foldrRn12 f z xs  `thenRn12` \ rest ->
-   f x rest
-
-addErrRn12 :: Error -> Rn12M ()
-addErrRn12 err mod errs_so_far
- = ( (), errs_so_far `snocBag` err )
-
-getModuleNameRn12 :: Rn12M FAST_STRING
-getModuleNameRn12 mod errs_so_far = (mod, errs_so_far)
-\end{code}
-
-\begin{code}
-recoverQuietlyRn12 :: a -> Rn12M a -> Rn12M a
-
-recoverQuietlyRn12 use_this_if_err action mod errs_so_far
-  = let
-	(result, errs_out)
-	  = case (action mod emptyBag{-no errors-}) of { (res, errs) ->
-	    if isEmptyBag errs then
-		(res, errs_so_far)  -- retain incoming errs
-	    else
-		(use_this_if_err, errs_so_far)
-	    }
-    in
-    (result, errs_out)
-\end{code}
diff --git a/ghc/compiler/rename/RenameMonad3.hi b/ghc/compiler/rename/RenameMonad3.hi
deleted file mode 100644
index 9d7799b9dc..0000000000
--- a/ghc/compiler/rename/RenameMonad3.hi
+++ /dev/null
@@ -1,31 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface RenameMonad3 where
-import FiniteMap(FiniteMap)
-import HsImpExp(IE)
-import Maybes(Labda)
-import Name(Name)
-import NameTypes(FullName)
-import Outputable(ExportFlag)
-import PreludePS(_PackedString)
-import ProtoName(ProtoName)
-import SplitUniq(SplitUniqSupply)
-import SrcLoc(SrcLoc)
-import Unique(Unique)
-infixr 9 `thenRn3`
-data IE 
-data FullName 
-data ExportFlag 
-data ProtoName 
-type Rn3M a = (FiniteMap _PackedString ExportFlag, FiniteMap _PackedString ()) -> _PackedString -> SplitUniqSupply -> a
-data SplitUniqSupply 
-data Unique 
-andRn3 :: (a -> a -> a) -> ((FiniteMap _PackedString ExportFlag, FiniteMap _PackedString ()) -> _PackedString -> SplitUniqSupply -> a) -> ((FiniteMap _PackedString ExportFlag, FiniteMap _PackedString ()) -> _PackedString -> SplitUniqSupply -> a) -> (FiniteMap _PackedString ExportFlag, FiniteMap _PackedString ()) -> _PackedString -> SplitUniqSupply -> a
-fixRn3 :: (a -> (FiniteMap _PackedString ExportFlag, FiniteMap _PackedString ()) -> _PackedString -> SplitUniqSupply -> a) -> (FiniteMap _PackedString ExportFlag, FiniteMap _PackedString ()) -> _PackedString -> SplitUniqSupply -> a
-initRn3 :: ((FiniteMap _PackedString ExportFlag, FiniteMap _PackedString ()) -> _PackedString -> SplitUniqSupply -> a) -> SplitUniqSupply -> a
-mapRn3 :: (a -> (FiniteMap _PackedString ExportFlag, FiniteMap _PackedString ()) -> _PackedString -> SplitUniqSupply -> b) -> [a] -> (FiniteMap _PackedString ExportFlag, FiniteMap _PackedString ()) -> _PackedString -> SplitUniqSupply -> [b]
-newFullNameM3 :: ProtoName -> SrcLoc -> Bool -> Labda ExportFlag -> (FiniteMap _PackedString ExportFlag, FiniteMap _PackedString ()) -> _PackedString -> SplitUniqSupply -> (Unique, FullName)
-newInvisibleNameM3 :: ProtoName -> SrcLoc -> Bool -> Labda ExportFlag -> (FiniteMap _PackedString ExportFlag, FiniteMap _PackedString ()) -> _PackedString -> SplitUniqSupply -> (Unique, FullName)
-putInfoDownM3 :: _PackedString -> [IE] -> ((FiniteMap _PackedString ExportFlag, FiniteMap _PackedString ()) -> _PackedString -> SplitUniqSupply -> a) -> (FiniteMap _PackedString ExportFlag, FiniteMap _PackedString ()) -> _PackedString -> SplitUniqSupply -> a
-returnRn3 :: a -> (FiniteMap _PackedString ExportFlag, FiniteMap _PackedString ()) -> _PackedString -> SplitUniqSupply -> a
-thenRn3 :: ((FiniteMap _PackedString ExportFlag, FiniteMap _PackedString ()) -> _PackedString -> SplitUniqSupply -> a) -> (a -> (FiniteMap _PackedString ExportFlag, FiniteMap _PackedString ()) -> _PackedString -> SplitUniqSupply -> b) -> (FiniteMap _PackedString ExportFlag, FiniteMap _PackedString ()) -> _PackedString -> SplitUniqSupply -> b
-
diff --git a/ghc/compiler/rename/RenameMonad3.lhs b/ghc/compiler/rename/RenameMonad3.lhs
deleted file mode 100644
index b9eddf94d3..0000000000
--- a/ghc/compiler/rename/RenameMonad3.lhs
+++ /dev/null
@@ -1,200 +0,0 @@
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
-%
-\section[RenameMonad3]{The monad used by the third renamer pass}
-
-\begin{code}
-#include "HsVersions.h"
-
-module RenameMonad3 (
-	Rn3M(..),
-	initRn3, thenRn3, andRn3, returnRn3, mapRn3, fixRn3,
-
-	putInfoDownM3,
-
-	newFullNameM3, newInvisibleNameM3,
-
-	-- for completeness
-	IE, FullName, ExportFlag, ProtoName, Unique,
-	SplitUniqSupply
-	IF_ATTACK_PRAGMAS(COMMA splitUniqSupply)
-    ) where
-
-import AbsSyn 		-- including, IE, getIEStrings, ...
-import FiniteMap
-import Maybes		( Maybe(..), assocMaybe )
-import NameTypes
-import Outputable
-import ProtoName
-import RenameMonad4     ( GlobalNameFun(..) )
-import SplitUniq
-import Unique
-import Util
-
-infixr 9 `thenRn3`
-\end{code}
-
-%************************************************************************
-%*									*
-\subsection{Plain @Rename3@ monadery}
-%*									*
-%************************************************************************
-
-\begin{code}
-type Rn3M result
-  =  ImExportListInfo -> FAST_STRING{-ModuleName-} -> SplitUniqSupply
-  -> result
-
-#ifdef __GLASGOW_HASKELL__
-{-# INLINE andRn3 #-}
-{-# INLINE thenRn3 #-}
-{-# INLINE returnRn3 #-}
-#endif
-
-initRn3 :: Rn3M a -> SplitUniqSupply -> a
-
-initRn3 m us = m (emptyFM,emptySet) (panic "initRn3: uninitialised module name") us
-
-thenRn3 :: Rn3M a -> (a -> Rn3M b) -> Rn3M b
-andRn3  :: (a -> a -> a) -> Rn3M a -> Rn3M a -> Rn3M a
-
-thenRn3 expr continuation exps mod_name uniqs
-  = case splitUniqSupply uniqs      of { (s1, s2) ->
-    case (expr exps mod_name s1)    of { res1 ->
-    continuation res1 exps mod_name s2 }}
-
-andRn3 combiner m1 m2 exps mod_name uniqs
-  = case splitUniqSupply uniqs      of { (s1, s2) ->
-    case (m1 exps mod_name s1)      of { res1 ->
-    case (m2 exps mod_name s2)	    of { res2 ->
-    combiner res1 res2 }}}
-
-returnRn3 :: a -> Rn3M a
-returnRn3 result exps mod_name uniqs = result
-
-mapRn3 :: (a -> Rn3M b) -> [a] -> Rn3M [b]
-
-mapRn3 f []     = returnRn3 []
-mapRn3 f (x:xs)
-  = f x		`thenRn3` \ r ->
-    mapRn3 f xs	`thenRn3` \ rs ->
-    returnRn3 (r:rs)
-
-fixRn3 :: (a -> Rn3M a) -> Rn3M a
-
-fixRn3 m exps mod_name us
-  = result
-  where
-    result = m result exps mod_name us
-
-putInfoDownM3 :: FAST_STRING{-ModuleName-} -> [IE] -> Rn3M a -> Rn3M a
-
-putInfoDownM3 mod_name exports cont _ _ uniqs
-  = cont (getIEStrings exports) mod_name uniqs
-\end{code}
-
-%************************************************************************
-%*									*
-\subsection[RenameMonad3-new-names]{Making new names}
-%*									*
-%************************************************************************
-
-@newFullNameM3@ makes a new user-visible FullName (the usual);
-@newInvisibleNameM3@ is the odd case.  @new_name@ does all the work.
-
-\begin{code}
-newFullNameM3, newInvisibleNameM3
-	:: ProtoName		-- input
-	-> SrcLoc		-- where it started life
-	-> Bool			-- if it is "TyCon"ish (rather than "val"ish)
-	-> Maybe ExportFlag	-- Just flag => force the use of that exportness
-	-> Rn3M (Unique, FullName)
-
-newFullNameM3 pn src_loc is_tycon_ish frcd_exp exps mod_name uniqs
-  = new_name pn src_loc is_tycon_ish frcd_exp False{-visible-} exps mod_name uniqs
-
-newInvisibleNameM3 pn src_loc is_tycon_ish frcd_exp exps mod_name uniqs
-  = new_name pn src_loc is_tycon_ish frcd_exp True{-invisible-} exps mod_name uniqs
-\end{code}
-
-\begin{code}
-new_name pn src_loc is_tycon_ish frcd_export_flag want_invisible exps mod_name uniqs
-  = (uniq, name)
-  where
-    uniq = getSUnique uniqs
-
-    mk_name = if want_invisible then mkPrivateFullName else mkFullName
-
-    name = case pn of
-
-	Unk s     -> mk_name mod_name s
-			(if fromPrelude mod_name
-			   && is_tycon_ish then -- & tycon/clas/datacon => Core
-			    HereInPreludeCore
-			 else
-			    ThisModule
-			)
-			(case frcd_export_flag of
-			   Just fl -> fl
-			   Nothing -> mk_export_flag True [mod_name] s exps)
-			src_loc
-
-	-- note: the assigning of prelude-ness is most dubious (ToDo)
-
-	Imp m d informant_mods l
-	  -> mk_name m d
-	       (if fromPrelude m then	-- as above
-		   if is_tycon_ish then
-		       ExportedByPreludeCore
-		   else
-		       OtherPrelude l
-		else if m == mod_name then -- pretty dang weird... (ToDo: anything?)
-		   ThisModule
-		else
-		   OtherModule l informant_mods -- for Other*, we save its occurrence name
-	       )
-	       (case frcd_export_flag of
-	          Just fl -> fl
-		  Nothing -> mk_export_flag (m==mod_name) informant_mods l exps)
-	       src_loc
-
-	Prel n	  -> panic "RenameMonad3.new_name: prelude name"
-\end{code}
-
-In deciding the ``exportness'' of something, there are these cases to
-consider:
-\begin{description}
-\item[No explicit export list:]
-Everything defined in this module goes out.
-
-\item[Matches a non-\tr{M..} item in the export list:]
-Then it's exported as its @name_pr@ item suggests.
-
-\item[Matches a \tr{M..} item in the export list:]
-
-(Note: the module \tr{M} may be {\em this} module!)  It's exported if
-we got it from \tr{M}'s interface; {\em most emphatically not} the
-same thing as ``it originally came from \tr{M}''.
-
-\item[Otherwise:]
-It isn't exported.
-\end{description}
-
-\begin{code}
-mk_export_flag	:: Bool		-- True <=> originally from the module we're compiling
-		-> [FAST_STRING] -- modules that told us about this thing
-		-> FAST_STRING	-- name of the thing we're looking at
-		-> ImExportListInfo
-		-> ExportFlag	-- result
-
-mk_export_flag this_module informant_mods thing (exports_alist, dotdot_modules)
-  | isEmptyFM exports_alist && isEmptySet dotdot_modules
-  = if this_module then ExportAll else NotExported
-
-  | otherwise
-  = case (lookupFM exports_alist thing) of
-      Just how_to_export -> how_to_export
-      Nothing		 -> if (or [ im `elementOf` dotdot_modules | im <- informant_mods ])
-			    then ExportAll
-			    else NotExported
-\end{code}
diff --git a/ghc/compiler/rename/RenameMonad4.hi b/ghc/compiler/rename/RenameMonad4.hi
deleted file mode 100644
index 4d3f3e41bc..0000000000
--- a/ghc/compiler/rename/RenameMonad4.hi
+++ /dev/null
@@ -1,79 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface RenameMonad4 where
-import AbsSyn(Module)
-import Bag(Bag)
-import CharSeq(CSeq)
-import CmdLineOpts(GlobalSwitch)
-import ErrUtils(Error(..))
-import FiniteMap(FiniteMap)
-import HsBinds(Binds, Sig)
-import HsDecls(ClassDecl, DataTypeSig, DefaultDecl, FixityDecl, InstDecl, SpecialisedInstanceSig, TyDecl)
-import HsImpExp(IE, ImportedInterface)
-import HsLit(Literal)
-import HsPat(InPat, RenamedPat(..))
-import Id(Id)
-import Maybes(Labda)
-import Name(Name)
-import NameTypes(FullName, ShortName)
-import PreludePS(_PackedString)
-import Pretty(Delay, PprStyle, Pretty(..), PrettyRep)
-import ProtoName(ProtoName)
-import RenameAuxFuns(GlobalNameFun(..), GlobalNameFuns(..))
-import SplitUniq(SplitUniqSupply)
-import SrcLoc(SrcLoc)
-import TyCon(TyCon)
-import UniqFM(UniqFM)
-import UniqSet(UniqSet(..))
-import Unique(Unique)
-infixr 9 `thenRn4`
-infixr 9 `thenRn4_`
-data Module a b 
-data Bag a 
-data GlobalSwitch 
-type Error = PprStyle -> Int -> Bool -> PrettyRep
-data InPat a 
-type RenamedPat = InPat Name
-data Labda a 
-data Name 
-data PprStyle 
-type Pretty = Int -> Bool -> PrettyRep
-data PrettyRep 
-data ProtoName 
-type GlobalNameFun = ProtoName -> Labda Name
-type GlobalNameFuns = (ProtoName -> Labda Name, ProtoName -> Labda Name)
-type Rn4M a = (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (a, Bag (PprStyle -> Int -> Bool -> PrettyRep))
-data SplitUniqSupply 
-data SrcLoc 
-type TyVarNamesEnv = [(ProtoName, Name)]
-data UniqFM a 
-type UniqSet a = UniqFM a
-data Unique 
-addErrRn4 :: (PprStyle -> Int -> Bool -> PrettyRep) -> (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> ((), Bag (PprStyle -> Int -> Bool -> PrettyRep))
-andRn4 :: (a -> a -> a) -> ((GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (a, Bag (PprStyle -> Int -> Bool -> PrettyRep))) -> ((GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (a, Bag (PprStyle -> Int -> Bool -> PrettyRep))) -> (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (a, Bag (PprStyle -> Int -> Bool -> PrettyRep))
-catTyVarNamesEnvs :: [(ProtoName, Name)] -> [(ProtoName, Name)] -> [(ProtoName, Name)]
-domTyVarNamesEnv :: [(ProtoName, Name)] -> [ProtoName]
-extendSS :: [Name] -> ((GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (a, Bag (PprStyle -> Int -> Bool -> PrettyRep))) -> (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (a, Bag (PprStyle -> Int -> Bool -> PrettyRep))
-extendSS2 :: [Name] -> ((GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> ((a, UniqFM Name), Bag (PprStyle -> Int -> Bool -> PrettyRep))) -> (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> ((a, UniqFM Name), Bag (PprStyle -> Int -> Bool -> PrettyRep))
-failButContinueRn4 :: a -> (PprStyle -> Int -> Bool -> PrettyRep) -> (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (a, Bag (PprStyle -> Int -> Bool -> PrettyRep))
-getSrcLocRn4 :: (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (SrcLoc, Bag (PprStyle -> Int -> Bool -> PrettyRep))
-getSwitchCheckerRn4 :: (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> Bool, Bag (PprStyle -> Int -> Bool -> PrettyRep))
-initRn4 :: (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> ((GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (a, Bag (PprStyle -> Int -> Bool -> PrettyRep))) -> SplitUniqSupply -> (a, Bag (PprStyle -> Int -> Bool -> PrettyRep))
-lookupClass :: ProtoName -> (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (Name, Bag (PprStyle -> Int -> Bool -> PrettyRep))
-lookupClassOp :: Name -> ProtoName -> (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (Name, Bag (PprStyle -> Int -> Bool -> PrettyRep))
-lookupFixityOp :: ProtoName -> (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (Labda Name, Bag (PprStyle -> Int -> Bool -> PrettyRep))
-lookupTyCon :: ProtoName -> (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (Name, Bag (PprStyle -> Int -> Bool -> PrettyRep))
-lookupTyConEvenIfInvisible :: ProtoName -> (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (Name, Bag (PprStyle -> Int -> Bool -> PrettyRep))
-lookupTyVarName :: [(ProtoName, Name)] -> ProtoName -> (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (Name, Bag (PprStyle -> Int -> Bool -> PrettyRep))
-lookupValue :: ProtoName -> (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (Name, Bag (PprStyle -> Int -> Bool -> PrettyRep))
-lookupValueEvenIfInvisible :: ProtoName -> (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (Name, Bag (PprStyle -> Int -> Bool -> PrettyRep))
-mapAndUnzipRn4 :: (a -> (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> ((b, c), Bag (PprStyle -> Int -> Bool -> PrettyRep))) -> [a] -> (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (([b], [c]), Bag (PprStyle -> Int -> Bool -> PrettyRep))
-mapRn4 :: (a -> (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (b, Bag (PprStyle -> Int -> Bool -> PrettyRep))) -> [a] -> (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> ([b], Bag (PprStyle -> Int -> Bool -> PrettyRep))
-mkTyVarNamesEnv :: SrcLoc -> [ProtoName] -> (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (([(ProtoName, Name)], [Name]), Bag (PprStyle -> Int -> Bool -> PrettyRep))
-namesFromProtoNames :: [Char] -> [(ProtoName, SrcLoc)] -> (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> ([Name], Bag (PprStyle -> Int -> Bool -> PrettyRep))
-nullTyVarNamesEnv :: [(ProtoName, Name)]
-pushSrcLocRn4 :: SrcLoc -> ((GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (a, Bag (PprStyle -> Int -> Bool -> PrettyRep))) -> (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (a, Bag (PprStyle -> Int -> Bool -> PrettyRep))
-recoverQuietlyRn4 :: a -> ((GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (a, Bag (PprStyle -> Int -> Bool -> PrettyRep))) -> (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (a, Bag (PprStyle -> Int -> Bool -> PrettyRep))
-returnRn4 :: a -> (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (a, Bag (PprStyle -> Int -> Bool -> PrettyRep))
-thenRn4 :: ((GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (a, Bag (PprStyle -> Int -> Bool -> PrettyRep))) -> (a -> (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (b, Bag (PprStyle -> Int -> Bool -> PrettyRep))) -> (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (b, Bag (PprStyle -> Int -> Bool -> PrettyRep))
-thenRn4_ :: ((GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (a, Bag (PprStyle -> Int -> Bool -> PrettyRep))) -> ((GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (b, Bag (PprStyle -> Int -> Bool -> PrettyRep))) -> (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (b, Bag (PprStyle -> Int -> Bool -> PrettyRep))
-
diff --git a/ghc/compiler/rename/RenameMonad4.lhs b/ghc/compiler/rename/RenameMonad4.lhs
deleted file mode 100644
index 68e6ce47b4..0000000000
--- a/ghc/compiler/rename/RenameMonad4.lhs
+++ /dev/null
@@ -1,490 +0,0 @@
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
-%
-\section[RenameMonad4]{The monad used by the fourth renamer pass}
-
-\begin{code}
-#include "HsVersions.h"
-
-module RenameMonad4 (
-	Rn4M(..),
-	initRn4, thenRn4, thenRn4_, andRn4, returnRn4, mapRn4, mapAndUnzipRn4,
-	addErrRn4, failButContinueRn4, recoverQuietlyRn4,
-	pushSrcLocRn4,
-	getSrcLocRn4,
-	getSwitchCheckerRn4,
-	lookupValue, lookupValueEvenIfInvisible,
-	lookupClassOp, lookupFixityOp,
-	lookupTyCon, lookupTyConEvenIfInvisible,
-	lookupClass,
-	extendSS2, extendSS,
-	namesFromProtoNames,
-
-	TyVarNamesEnv(..), mkTyVarNamesEnv, domTyVarNamesEnv,
-	lookupTyVarName, nullTyVarNamesEnv, catTyVarNamesEnvs,
-
-	-- for completeness
-	Module, Bag, RenamedPat(..), InPat, Maybe, Name, Error(..),
-	Pretty(..), PprStyle, PrettyRep, ProtoName, GlobalSwitch,
-	GlobalNameFun(..), GlobalNameFuns(..), UniqSet(..), UniqFM, SrcLoc,
-	Unique, SplitUniqSupply
-	IF_ATTACK_PRAGMAS(COMMA splitUniqSupply)
-    ) where
-
-IMPORT_Trace		-- ToDo: rm (debugging)
-import Pretty
-import Outputable
-
-import AbsSyn
-import Bag
-import CmdLineOpts	( GlobalSwitch(..) )
-import Errors		( dupNamesErr, unknownNameErr, shadowedNameErr,
-			  badClassOpErr, Error(..)
-			)
-import FiniteMap	( lookupFM, addToFM, addListToFM, emptyFM, FiniteMap )
-import Maybes		( Maybe(..), assocMaybe )
-import Name		( isTyConName, isClassName, isClassOpName,
-			  isUnboundName, invisibleName
-			)
-import NameTypes	( mkShortName, ShortName )
-import ProtoName	-- lots of stuff
-import RenameAuxFuns	-- oh, why not ... all of it
-import SrcLoc		( mkUnknownSrcLoc, SrcLoc )
-import SplitUniq
-import UniqSet
-import Unique
-import Util
-
-infixr 9 `thenRn4`, `thenRn4_`
-\end{code}
-
-%************************************************************************
-%*									*
-\subsection[RenameMonad]{Plain @Rename@ monadery}
-%*									*
-%************************************************************************
-
-\begin{code}
-type ScopeStack = FiniteMap FAST_STRING Name
-
-type Rn4M result
-  =  (GlobalSwitch -> Bool)
-  -> GlobalNameFuns
-  -> ScopeStack
-  -> Bag Error
-  -> SplitUniqSupply
-  -> SrcLoc
-  -> (result, Bag Error)
-
-#ifdef __GLASGOW_HASKELL__
-{-# INLINE andRn4 #-}
-{-# INLINE thenRn4 #-}
-{-# INLINE thenLazilyRn4 #-}
-{-# INLINE thenRn4_ #-}
-{-# INLINE returnRn4 #-}
-#endif
-
-initRn4 :: (GlobalSwitch -> Bool)
-	-> GlobalNameFuns
-	-> Rn4M result
-	-> SplitUniqSupply
-	-> (result, Bag Error)
-
-initRn4 sw_chkr gnfs renamer init_us
-  = renamer sw_chkr gnfs emptyFM emptyBag init_us mkUnknownSrcLoc
-
-thenRn4, thenLazilyRn4
-	 :: Rn4M a -> (a -> Rn4M b) -> Rn4M b
-thenRn4_ :: Rn4M a -> Rn4M b -> Rn4M b
-andRn4   :: (a -> a -> a) -> Rn4M a -> Rn4M a -> Rn4M a
-
-thenRn4 expr cont sw_chkr gnfs ss errs uniqs locn
-  = case (splitUniqSupply uniqs)    	    	   of { (s1, s2) ->
-    case (expr      sw_chkr gnfs ss errs  s1 locn) of { (res1, errs1) ->
-    case (cont res1 sw_chkr gnfs ss errs1 s2 locn) of { (res2, errs2) ->
-    (res2, errs2) }}}
-
-thenLazilyRn4 expr cont sw_chkr gnfs ss errs uniqs locn
-  = let
-	(s1, s2)      = splitUniqSupply uniqs
-	(res1, errs1) = expr      sw_chkr gnfs ss errs  s1 locn
-	(res2, errs2) = cont res1 sw_chkr gnfs ss errs1 s2 locn
-    in
-    (res2, errs2)
-
-thenRn4_ expr cont sw_chkr gnfs ss errs uniqs locn
-  = case (splitUniqSupply uniqs)    	      of { (s1, s2) ->
-    case (expr sw_chkr gnfs ss errs  s1 locn) of { (_,    errs1) ->
-    case (cont sw_chkr gnfs ss errs1 s2 locn) of { (res2, errs2) ->
-    (res2, errs2) }}}
-
-andRn4 combiner m1 m2 sw_chkr gnfs ss errs us locn
-  = case (splitUniqSupply us)	    	    of { (s1, s2) ->
-    case (m1 sw_chkr gnfs ss errs  s1 locn) of { (res1, errs1) ->
-    case (m2 sw_chkr gnfs ss errs1 s2 locn) of { (res2, errs2) ->
-    (combiner res1 res2, errs2) }}}
-
-returnRn4 :: a -> Rn4M a
-returnRn4 result sw_chkr gnfs ss errs_so_far uniqs locn
-   = (result, errs_so_far)
-
-failButContinueRn4 :: a -> Error -> Rn4M a
-failButContinueRn4 res err sw_chkr gnfs ss errs_so_far uniqs locn
-  = (res, errs_so_far `snocBag` err)
-
-addErrRn4 :: Error -> Rn4M ()
-addErrRn4 err sw_chkr gnfs ss errs_so_far uniqs locn
-  = ((), errs_so_far `snocBag` err)
-\end{code}
-
-When we're looking at interface pragmas, we want to be able to recover
-back to a ``I don't know anything pragmatic'' state if we encounter
-some problem.  @recoverQuietlyRn4@ is given a ``use-this-instead'' value,
-as well as the action to perform.  This code is intentionally very lazy,
-returning a triple immediately, no matter what.
-\begin{code}
-recoverQuietlyRn4 :: a -> Rn4M a -> Rn4M a
-
-recoverQuietlyRn4 use_this_if_err action sw_chkr gnfs ss errs_so_far uniqs locn
-  = let
-	(result, errs_out)
-    	  = case (action sw_chkr gnfs ss emptyBag{-leav out errs-} uniqs locn) of
-	      (result1, errs1) ->
-		if isEmptyBag errs1 then -- all's well! (but retain incoming errs)
-		    (result1, errs_so_far)
-		else -- give up; return *incoming* UniqueSupply...
-		    (use_this_if_err,
-		     if sw_chkr ShowPragmaNameErrs
-		     then errs_so_far `unionBags` errs1
-		     else errs_so_far) -- toss errs, otherwise
-    in
-    (result, errs_out)
-\end{code}
-
-\begin{code}
-mapRn4 :: (a -> Rn4M b) -> [a] -> Rn4M [b]
-
-mapRn4 f []     = returnRn4 []
-mapRn4 f (x:xs)
-  = f x		`thenRn4` \ r ->
-    mapRn4 f xs `thenRn4` \ rs ->
-    returnRn4 (r:rs)
-
-mapAndUnzipRn4  :: (a -> Rn4M (b,c))   -> [a] -> Rn4M ([b],[c])
-
-mapAndUnzipRn4 f [] = returnRn4 ([],[])
-mapAndUnzipRn4 f (x:xs)
-  = f x		    	`thenRn4` \ (r1,  r2)  ->
-    mapAndUnzipRn4 f xs	`thenRn4` \ (rs1, rs2) ->
-    returnRn4 (r1:rs1, r2:rs2)
-\end{code}
-
-\begin{code}
-pushSrcLocRn4 :: SrcLoc -> Rn4M a -> Rn4M a
-pushSrcLocRn4 locn exp sw_chkr gnfs ss errs_so_far uniq_supply old_locn
-  = exp sw_chkr gnfs ss errs_so_far uniq_supply locn
-
-getSrcLocRn4 :: Rn4M SrcLoc
-
-getSrcLocRn4 sw_chkr gnfs ss errs_so_far uniq_supply locn
-  = returnRn4 locn sw_chkr gnfs ss errs_so_far uniq_supply locn
-
-getSwitchCheckerRn4 :: Rn4M (GlobalSwitch -> Bool)
-
-getSwitchCheckerRn4 sw_chkr gnfs ss errs_so_far uniq_supply locn
-  = returnRn4 sw_chkr sw_chkr gnfs ss errs_so_far uniq_supply locn
-\end{code}
-
-\begin{code}
-getNextUniquesFromRn4 :: Int -> Rn4M [Unique]
-getNextUniquesFromRn4 n sw_chkr gnfs ss errs_so_far us locn
-  = case (getSUniques n us) of { next_uniques ->
-    (next_uniques, errs_so_far) }
-\end{code}
-
-*********************************************************
-*							*
-\subsection{Making new names}
-*							*
-*********************************************************
-
-@namesFromProtoNames@ takes a bunch of protonames, which are defined
-together in a group (eg a pattern or set of bindings), checks they
-are distinct, and creates new full names for them.
-
-\begin{code}
-namesFromProtoNames :: String 		-- Documentation string
-		    -> [(ProtoName, SrcLoc)]
-		    -> Rn4M [Name]	
-
-namesFromProtoNames kind pnames_w_src_loc sw_chkr gnfs ss errs_so_far us locn
-  = (mapRn4 (addErrRn4 . dupNamesErr kind) dups `thenRn4_`
-    mkNewNames goodies
-    ) {-Rn4-} sw_chkr gnfs ss errs_so_far us locn
-  where
-    (goodies, dups) = removeDups cmp pnames_w_src_loc
-	-- We want to compare their local names rather than their 
-	-- full protonames.  It probably doesn't matter here, but it
-	-- does in Rename3.lhs!
-    cmp (a, _) (b, _) = cmpByLocalName a b
-\end{code}
-
-@mkNewNames@ assumes the names are unique.
-
-\begin{code}
-mkNewNames :: [(ProtoName, SrcLoc)] -> Rn4M [Name]	
-mkNewNames pnames_w_locs
-  = getNextUniquesFromRn4 (length pnames_w_locs) `thenRn4` \ uniqs ->
-    returnRn4 (zipWith new_short_name uniqs pnames_w_locs)
-  where
-    new_short_name uniq (Unk str, srcloc)   -- gotta be an Unk...
-      = Short uniq (mkShortName str srcloc)
-\end{code}
-
-
-*********************************************************
-*							*
-\subsection{Local scope extension and lookup}
-*							*
-*********************************************************
-
-If the input name is an @Imp@, @lookupValue@ looks it up in the GNF.
-If it is an @Unk@, it looks it up first in the local environment
-(scope stack), and if it isn't found there, then in the value GNF.  If
-it isn't found at all, @lookupValue@ adds an error message, and
-returns an @Unbound@ name.
-
-\begin{code}
-unboundName :: ProtoName -> Name
-unboundName pn
-   = Unbound (grab_string pn)
-   where
-     grab_string (Unk s)       = s
-     grab_string (Imp _ _ _ s) = s
-\end{code}
-
-@lookupValue@ looks up a non-invisible value;
-@lookupValueEvenIfInvisible@ gives a successful lookup even if the
-value is not visible to the user (e.g., came out of a pragma).
-@lookup_val@ is the help function to do the work.
-
-\begin{code}
-lookupValue v {-Rn4-} sw_chkr gnfs ss errs_so_far us locn
-  = (lookup_val v	`thenLazilyRn4` \ name ->
-    if invisibleName name
-    then failButContinueRn4 (unboundName v) (unknownNameErr "value" v mkUnknownSrcLoc)
-    else returnRn4 name
-    ) {-Rn4-} sw_chkr gnfs ss errs_so_far us locn
-
-lookupValueEvenIfInvisible v = lookup_val v
-
-lookup_val :: ProtoName -> Rn4M Name
-
-lookup_val pname@(Unk v) sw_chkr gnfs@(v_gnf, tc_gnf) ss a b locn
-  = case (lookupFM ss v) of
-      Just name -> returnRn4 name sw_chkr gnfs ss a b locn
-      Nothing   -> case (v_gnf pname) of
-		     Just name  -> returnRn4 name sw_chkr gnfs ss a b locn
-		     Nothing    -> failButContinueRn4 (unboundName pname)
-					   (unknownNameErr "value" pname locn)
-  					   sw_chkr gnfs ss a b locn
-
--- If it ain't an Unk it must be in the global name fun; that includes
--- prelude things.
-lookup_val pname sw_chkr gnfs@(v_gnf, tc_gnf) ss a b locn
-  = case (v_gnf pname) of
-        Just name  -> returnRn4 name sw_chkr gnfs ss a b locn
-	Nothing    -> failButContinueRn4 (unboundName pname)
-			      (unknownNameErr "value" pname locn)
-			      sw_chkr gnfs ss a b locn
-\end{code}
-
-Looking up the operators in a fixity decl is done differently.  We
-want to simply drop any fixity decls which refer to operators which
-aren't in scope.  Unfortunately, such fixity decls {\em will} appear
-because the parser collects *all* the fixity decls from {\em all} the
-imported interfaces (regardless of selective import), and dumps them
-together as the module fixity decls.  This is really a bug.  In
-particular:
-\begin{itemize}
-\item
-We won't complain about fixity decls for operators which aren't
-declared.
-\item
-We won't attach the right fixity to something which has been renamed.
-\end{itemize}
-
-We're not going to export Prelude-related fixities (ToDo: correctly),
-so we nuke those, too.
-
-\begin{code}
-lookupFixityOp (Prel _) sw_chkr gnfs@(v_gnf, tc_gnf) = returnRn4 Nothing       sw_chkr gnfs
-lookupFixityOp pname	sw_chkr gnfs@(v_gnf, tc_gnf) = returnRn4 (v_gnf pname) sw_chkr gnfs
-\end{code}
-
-\begin{code}
-lookupTyCon, lookupTyConEvenIfInvisible :: ProtoName -> Rn4M Name
--- The global name funs handle Prel things
-
-lookupTyCon tc {-Rn4-} sw_chkr gnfs ss errs_so_far us locn
-  = (lookup_tycon tc `thenLazilyRn4` \ name ->
-    if invisibleName name
-    then failButContinueRn4 (unboundName tc) (unknownNameErr "type constructor" tc mkUnknownSrcLoc)
-    else returnRn4 name
-    ) {-Rn4-} sw_chkr gnfs ss errs_so_far us locn
-
-lookupTyConEvenIfInvisible tc = lookup_tycon tc
-
-lookup_tycon (Prel name) sw_chkr gnfs ss a b locn = returnRn4 name sw_chkr gnfs ss a b locn
-
-lookup_tycon pname sw_chkr gnfs@(v_gnf, tc_gnf) ss a b locn
-  = case (tc_gnf pname) of
-     Just name | isTyConName name -> returnRn4 name sw_chkr gnfs ss a b locn
-     _   -> failButContinueRn4 (unboundName pname)
-		    (unknownNameErr "type constructor" pname locn)
-		    sw_chkr gnfs ss a b locn
-\end{code}
-
-\begin{code}
-lookupClass :: ProtoName -> Rn4M Name
-
-lookupClass pname sw_chkr gnfs@(v_gnf, tc_gnf) ss a b locn
-  = case (tc_gnf pname) of
-     Just name | isClassName name -> returnRn4 name sw_chkr gnfs ss a b locn
-     _   -> failButContinueRn4 (unboundName pname)
-		    (unknownNameErr "class" pname locn)
-		    sw_chkr gnfs ss a b locn
-\end{code}
-
-@lookupClassOp@ is used when looking up the lhs identifiers in a class
-or instance decl.  It checks that the name it finds really is a class
-op, and that its class matches that of the class or instance decl
-being looked at.
-
-\begin{code}
-lookupClassOp :: Name -> ProtoName -> Rn4M Name
-
-lookupClassOp class_name pname sw_chkr gnfs@(v_gnf, tc_gnf) ss a b locn
-  = case v_gnf pname of
-	 Just op_name |  isClassOpName class_name op_name
-		      || isUnboundName class_name -- avoid spurious errors
-		 -> returnRn4 op_name sw_chkr gnfs ss a b locn
-
-	 other   -> failButContinueRn4 (unboundName pname)
-			    (badClassOpErr class_name pname locn)
-			    sw_chkr gnfs ss a b locn
-\end{code}
-
-@extendSS@ extends the scope; @extendSS2@ also removes the newly bound
-free vars from the result.
-
-\begin{code}
-extendSS :: [Name] 				-- Newly bound names
-	 -> Rn4M a
-	 -> Rn4M a
-
-extendSS binders expr sw_chkr gnfs ss errs us locn
-  = case (extend binders ss sw_chkr gnfs ss errs us locn) of { (new_ss, new_errs) ->
-    expr sw_chkr gnfs new_ss new_errs us locn }
-  where
-    extend :: [Name] -> ScopeStack -> Rn4M ScopeStack
-
-    extend names ss
-      = if (sw_chkr NameShadowingNotOK) then
-	    hard_way names ss
-	else -- ignore shadowing; blast 'em in
-	    returnRn4 (
-		addListToFM ss [ (getOccurrenceName x, n) | n@(Short _ x) <- names]
-	    )
-
-    hard_way [] ss = returnRn4 ss
-    hard_way (name@(Short _ sname):names) ss
-      = let
-	    str = getOccurrenceName sname
-	in
-	(case (lookupFM ss str) of
-	   Nothing -> returnRn4 (addToFM ss str name)
-	   Just  _ -> failButContinueRn4 ss (shadowedNameErr name locn)
-
-	)	`thenRn4` \ new_ss ->
-	hard_way names new_ss
-
-extendSS2 :: [Name] 				-- Newly bound names
-	 -> Rn4M (a, UniqSet Name)
-	 -> Rn4M (a, UniqSet Name)
-
-extendSS2 binders expr sw_chkr gnfs ss errs_so_far us locn
-  = case (extendSS binders expr sw_chkr gnfs ss errs_so_far us locn) of
-     ((e2, freevars), errs)
-       -> ((e2, freevars `minusUniqSet` (mkUniqSet binders)),
-	   errs)
-\end{code}
-
-The free var set returned by @(extendSS binders m)@ is that returned
-by @m@, {\em minus} binders.
-
-*********************************************************
-*							*
-\subsection{mkTyVarNamesEnv}
-*							*
-*********************************************************
-
-\begin{code}
-type TyVarNamesEnv = [(ProtoName, Name)]
-
-nullTyVarNamesEnv :: TyVarNamesEnv
-nullTyVarNamesEnv = []
-
-catTyVarNamesEnvs :: TyVarNamesEnv -> TyVarNamesEnv -> TyVarNamesEnv
-catTyVarNamesEnvs e1 e2 = e1 ++ e2
-
-domTyVarNamesEnv :: TyVarNamesEnv -> [ProtoName]
-domTyVarNamesEnv env = map fst env
-\end{code}
-
-@mkTyVarNamesEnv@ checks for duplicates, and complains if so.
-
-\begin{code}
-mkTyVarNamesEnv
-	:: SrcLoc
-	-> [ProtoName]			-- The type variables
-        -> Rn4M (TyVarNamesEnv,[Name])	-- Environment and renamed tyvars
-
-mkTyVarNamesEnv src_loc tyvars {-Rn4-} sw_chkr gnfs ss errs_so_far us locn
-  = (namesFromProtoNames "type variable"
-	 (tyvars `zip` repeat src_loc)	`thenRn4`  \ tyvars2 ->
-
-	 -- tyvars2 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_string_name_pairs 	= extend tyvars2 []
-    	tv_env	    	    	= map (lookup tv_string_name_pairs) tyvars
-	tyvars2_in_orig_order	= map snd tv_env
-    in
-    returnRn4  (tv_env, tyvars2_in_orig_order)
-    ) {-Rn4-} sw_chkr gnfs ss errs_so_far us locn
-  where
-    extend :: [Name] -> [(FAST_STRING, Name)] -> [(FAST_STRING, Name)]
-    extend [] ss = ss
-    extend (name@(Short _ sname):names) ss
-      = (getOccurrenceName sname, name) : extend names ss
-
-    lookup :: [(FAST_STRING, Name)] -> ProtoName -> (ProtoName, Name)
-    lookup pairs tyvar_pn
-      = (tyvar_pn, assoc "mkTyVarNamesEnv" pairs (getOccurrenceName tyvar_pn))
-\end{code}
-
-\begin{code}
-lookupTyVarName :: TyVarNamesEnv -> ProtoName -> Rn4M Name
-lookupTyVarName env pname {-Rn4-} sw_chkr gnfs ss errs_so_far us locn
-  = (case (assoc_maybe env pname) of
-     Just name -> returnRn4 name
-     Nothing   -> getSrcLocRn4	`thenRn4` \ loc ->
-		  failButContinueRn4 (unboundName pname)
-			  (unknownNameErr "type variable" pname loc)
-    ) {-Rn4-} sw_chkr gnfs ss errs_so_far us locn
-  where
-    assoc_maybe [] _ = Nothing
-    assoc_maybe ((tv,xxx) : tvs) key
-      = if tv `eqProtoName` key then Just xxx else assoc_maybe tvs key
-\end{code}
diff --git a/ghc/compiler/rename/RnBinds4.lhs b/ghc/compiler/rename/RnBinds4.lhs
new file mode 100644
index 0000000000..418c626967
--- /dev/null
+++ b/ghc/compiler/rename/RnBinds4.lhs
@@ -0,0 +1,711 @@
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+%
+\section[RnBinds4]{Renaming and dependency analysis of bindings}
+
+This module does renaming and dependency analysis on value bindings in
+the abstract syntax.  It does {\em not} do cycle-checks on class or
+type-synonym declarations; those cannot be done at this stage because
+they may be affected by renaming (which isn't fully worked out yet).
+
+\begin{code}
+#include "HsVersions.h"
+
+module RnBinds4 (
+	rnTopBinds, rnMethodBinds,
+	rnBinds,
+	FreeVars(..), DefinedVars(..)
+
+	-- and to make the interface self-sufficient...
+   ) where
+
+import Ubiq{-uitous-}
+import RnLoop	-- break the RnPass4/RnExpr4/RnBinds4 loops
+
+import HsSyn
+import RdrHsSyn
+import RnHsSyn
+import HsPragmas	( noGenPragmas )
+import RnMonad4
+
+-- others:
+import CmdLineOpts	( opt_SigsRequired )
+import Digraph		( stronglyConnComp )
+import ErrUtils		( addErrLoc, addShortErrLocLine )
+import Maybes		( catMaybes )
+import Name		( isUnboundName, Name{-instances-} )
+import Pretty
+import ProtoName	( elemByLocalNames, eqByLocalName, ProtoName{-instances-} )
+import RnExpr4		-- OK to look here; but not the other way 'round
+import UniqSet		( emptyUniqSet, singletonUniqSet, mkUniqSet,
+			  unionUniqSets, unionManyUniqSets,
+			  elementOfUniqSet,
+			  uniqSetToList,
+			  UniqSet(..)
+			)
+import Util		( isIn, removeDups, panic, panic# )
+\end{code}
+
+-- ToDo: Put the annotations into the monad, so that they arrive in the proper
+-- place and can be used when complaining.
+
+The code tree received by the function @rnBinds@ contains definitions
+in where-clauses which are all apparently mutually recursive, but which may
+not really depend upon each other. For example, in the top level program
+\begin{verbatim}
+f x = y where a = x
+	      y = x
+\end{verbatim}
+the definitions of @a@ and @y@ do not depend on each other at all.
+Unfortunately, the typechecker cannot always check such definitions.
+\footnote{Mycroft, A. 1984. Polymorphic type schemes and recursive
+definitions. In Proceedings of the International Symposium on Programming,
+Toulouse, pp. 217-39. LNCS 167. Springer Verlag.}
+However, the typechecker usually can check definitions in which only the
+strongly connected components have been collected into recursive bindings.
+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 Name
+type FreeVars    = UniqSet Name
+\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).
+
+\begin{code}
+type VertexTag	= Int
+type Cycle	= [VertexTag]
+type Edge	= (VertexTag, VertexTag)
+\end{code}
+
+%************************************************************************
+%*									*
+%* naming conventions							*
+%*									*
+%************************************************************************
+\subsection[name-conventions]{Name conventions}
+
+The basic algorithm involves walking over the tree and returning a tuple
+containing the new tree plus its free variables. Some functions, such
+as those walking polymorphic bindings (HsBinds) and qualifier lists in
+list comprehensions (@Quals@), return the variables bound in local
+environments. These are then used to calculate the free variables of the
+expression evaluated in these environments.
+
+Conventions for variable names are as follows:
+\begin{itemize}
+\item
+new code is given a prime to distinguish it from the old.
+
+\item
+a set of variables defined in @Exp@ is written @dvExp@
+
+\item
+a set of variables free in @Exp@ is written @fvExp@
+\end{itemize}
+
+%************************************************************************
+%*									*
+%* analysing polymorphic bindings (HsBinds, Bind, MonoBinds)		*
+%*									*
+%************************************************************************
+\subsubsection[dep-HsBinds]{Polymorphic bindings}
+
+Non-recursive expressions are reconstructed without any changes at top
+level, although their component expressions may have to be altered.
+However, non-recursive expressions are currently not expected as
+\Haskell{} programs, and this code should not be executed.
+
+Monomorphic bindings contain information that is returned in a tuple
+(a @FlatMonoBindsInfo@) containing:
+
+\begin{enumerate}
+\item
+a unique @Int@ that serves as the ``vertex tag'' for this binding.
+
+\item
+the name of a function or the names in a pattern. These are a set
+referred to as @dvLhs@, the defined variables of the left hand side.
+
+\item
+the free variables of the body. These are referred to as @fvBody@.
+
+\item
+the definition's actual code. This is referred to as just @code@.
+\end{enumerate}
+
+The function @nonRecDvFv@ returns two sets of variables. The first is
+the set of variables defined in the set of monomorphic bindings, while the
+second is the set of free variables in those bindings.
+
+The set of variables defined in a non-recursive binding is just the
+union of all of them, as @union@ removes duplicates. However, the
+free variables in each successive set of cumulative bindings is the
+union of those in the previous set plus those of the newest binding after
+the defined variables of the previous set have been removed.
+
+@rnMethodBinds@ deals only with the declarations in class and
+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).
+
+\begin{code}
+rnTopBinds	:: ProtoNameHsBinds -> Rn4M RenamedHsBinds
+rnMethodBinds  :: Name{-class-} -> ProtoNameMonoBinds -> Rn4M RenamedMonoBinds
+rnBinds	:: ProtoNameHsBinds -> Rn4M (RenamedHsBinds, FreeVars, [Name])
+
+rnTopBinds EmptyBinds		       	   = returnRn4 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 = returnRn4 EmptyMonoBinds
+
+rnMethodBinds class_name (AndMonoBinds mb1 mb2)
+  = andRn4 AndMonoBinds (rnMethodBinds class_name mb1)
+			(rnMethodBinds class_name mb2)
+
+rnMethodBinds class_name (FunMonoBind pname matches locn)
+  = pushSrcLocRn4 locn			      	  (
+    lookupClassOp class_name pname  	`thenRn4` \ op_name ->
+    mapAndUnzipRn4 rnMatch matches	`thenRn4` \ (new_matches, _) ->
+    returnRn4 (FunMonoBind op_name new_matches locn)
+    )
+
+rnMethodBinds class_name (PatMonoBind (VarPatIn pname) grhss_and_binds locn)
+  = pushSrcLocRn4 locn				  (
+    lookupClassOp class_name pname	`thenRn4` \ op_name ->
+    rnGRHSsAndBinds grhss_and_binds	`thenRn4` \ (grhss_and_binds', _) ->
+    returnRn4 (PatMonoBind (VarPatIn op_name) grhss_and_binds' locn)
+    )
+
+-- Can't handle method pattern-bindings which bind multiple methods.
+rnMethodBinds _ mbind@(PatMonoBind other_pat _ locn)
+  = failButContinueRn4 EmptyMonoBinds (methodBindErr mbind locn)
+
+-- ********************************************************************
+
+rnBinds EmptyBinds			= returnRn4 (EmptyBinds,emptyUniqSet,[])
+rnBinds (SingleBind (RecBind bind))	= rnNestedMonoBinds bind []
+rnBinds (BindWith (RecBind bind) sigs) = rnNestedMonoBinds bind sigs
+  -- the parser doesn't produce other forms
+\end{code}
+
+@rnNestedMonoBinds@
+	- collects up the binders for this declaration group,
+	- checkes that they form a set
+	- extends the environment to bind them to new local names
+	- calls @rnMonoBinds@ to do the real work
+
+In contrast, @rnTopMonoBinds@ doesn't extend the environment, because that's
+already done in pass3.	All it does is call @rnMonoBinds@ and discards
+the free var info.
+
+\begin{code}
+rnTopMonoBinds :: ProtoNameMonoBinds -> [ProtoNameSig] -> Rn4M RenamedHsBinds
+
+rnTopMonoBinds EmptyMonoBinds sigs = returnRn4 EmptyBinds
+
+rnTopMonoBinds mbs sigs
+ = rnBindSigs True{-top-level-} (collectMonoBinders mbs) sigs `thenRn4` \ siglist ->
+   rnMonoBinds mbs siglist `thenRn4` \ (new_binds, fv_set) ->
+   returnRn4 new_binds
+
+
+rnNestedMonoBinds :: ProtoNameMonoBinds -> [ProtoNameSig]
+		      -> Rn4M (RenamedHsBinds, FreeVars, [Name])
+
+rnNestedMonoBinds EmptyMonoBinds sigs
+  = returnRn4 (EmptyBinds, emptyUniqSet, [])
+
+rnNestedMonoBinds mbinds sigs	-- 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
+    let
+	mbinders_w_srclocs = collectMonoBindersAndLocs mbinds
+	mbinders    	   = map fst mbinders_w_srclocs
+    in
+    namesFromProtoNames
+	"variable" -- in binding group
+	mbinders_w_srclocs		`thenRn4` \ new_mbinders ->
+
+    extendSS2 new_mbinders (
+	 rnBindSigs False{-not top- level-} mbinders sigs `thenRn4` \ siglist ->
+	 rnMonoBinds mbinds  siglist
+    )					`thenRn4` \ (new_binds, fv_set) ->
+    returnRn4 (new_binds, fv_set, new_mbinders)
+\end{code}
+
+@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).
+
+\begin{code}
+rnMonoBinds :: ProtoNameMonoBinds
+	     -> [RenamedSig]	-- Signatures attached to this group
+	     -> Rn4M (RenamedHsBinds, FreeVars)
+
+rnMonoBinds mbinds siglist
+  =
+	 -- Rename the bindings, returning a MonoBindsInfo
+	 -- which is a list of indivisible vertices so far as
+	 -- the strongly-connected-components (SCC) analysis is concerned
+    flattenMonoBinds 0 siglist mbinds	`thenRn4` \ (_, mbinds_info) ->
+
+	 -- Do the SCC analysis
+    let vertices = mkVertices mbinds_info
+	edges	= mkEdges vertices mbinds_info
+
+	scc_result = stronglyConnComp (==) edges vertices
+
+	 -- 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 = returnRn4 (final_binds, rhs_free_vars)
+    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
+-- 	addErrRn4 (inlineInRecursiveBindsErr names_n_locns) `thenRn4_`
+	{-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
+\end{code}
+
+@flattenMonoBinds@ is ever-so-slightly magical in that it sticks
+unique ``vertex tags'' on its output; minor plumbing required.
+
+\begin{code}
+flattenMonoBinds :: Int				-- Next free vertex tag
+		 -> [RenamedSig]		-- Signatures
+		 -> ProtoNameMonoBinds
+		 -> Rn4M (Int, FlatMonoBindsInfo)
+
+flattenMonoBinds uniq sigs EmptyMonoBinds = returnRn4 (uniq, [])
+
+flattenMonoBinds uniq sigs (AndMonoBinds mB1 mB2)
+  = flattenMonoBinds uniq sigs mB1	`thenRn4` \ (uniq1, flat1) ->
+    flattenMonoBinds uniq1 sigs mB2	`thenRn4` \ (uniq2, flat2) ->
+    returnRn4 (uniq2, flat1 ++ flat2)
+
+flattenMonoBinds uniq sigs (PatMonoBind pat grhss_and_binds locn)
+  = pushSrcLocRn4 locn		 		  (
+    rnPat pat				`thenRn4` \ pat' ->
+    rnGRHSsAndBinds grhss_and_binds	`thenRn4` \ (grhss_and_binds', fvs) ->
+
+	 -- 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"
+    in
+    returnRn4 (
+	uniq + 1,
+	[(uniq,
+	  mkUniqSet names_bound_here,
+	   fvs `unionUniqSets` sigs_fvs,
+	   PatMonoBind pat' grhss_and_binds' locn,
+	   sigs_etc_for_here
+	 )]
+    ))
+
+flattenMonoBinds uniq sigs (FunMonoBind name matches locn)
+  = pushSrcLocRn4 locn			    	  (
+    lookupValue name			`thenRn4` \ name' ->
+    mapAndUnzipRn4 rnMatch matches	`thenRn4` \ (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
+    in
+    returnRn4 (
+      uniq + 1,
+      [(uniq,
+	singletonUniqSet name',
+	fvs `unionUniqSets` sigs_fvs,
+	FunMonoBind name' new_matches locn,
+	sigs_for_me
+	)]
+    ))
+\end{code}
+
+Grab type-signatures/user-pragmas of interest:
+\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
+
+-- 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` singletonUniqSet blah
+sig_fv _			   acc = acc
+\end{code}
+
+%************************************************************************
+%*									*
+\subsection[reconstruct-deps]{Reconstructing dependencies}
+%*									*
+%************************************************************************
+
+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
+
+reconstructRec cycles edges mbi
+  = foldr1 ThenBinds (map (reconstructCycle mbi) cycles)
+  where
+    reconstructCycle :: FlatMonoBindsInfo -> Cycle -> RenamedHsBinds
+
+    reconstructCycle mbi2 cycle
+      = BIND [(binds,sigs) | (vertex, _, _, binds, sigs) <- mbi2, vertex `is_elem` cycle]
+		  _TO_ relevant_binds_and_sigs ->
+
+	BIND (unzip relevant_binds_and_sigs) _TO_ (binds, sig_lists) ->
+
+	BIND (foldr AndMonoBinds EmptyMonoBinds binds) _TO_ 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
+	BEND BEND BEND
+      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
+\end{code}
+
+%************************************************************************
+%*									*
+%*	Manipulating FlatMonoBindInfo					*
+%*									*
+%************************************************************************
+
+During analysis a @MonoBinds@ is flattened to a @FlatMonoBindsInfo@.
+The @RenamedMonoBinds@ is always an empty bind, a pattern binding or
+a function binding, and has itself been dependency-analysed and
+renamed.
+
+\begin{code}
+type FlatMonoBindsInfo
+  = [(VertexTag,		-- Identifies the vertex
+      UniqSet Name,		-- Set of names defined in this vertex
+      UniqSet Name,		-- 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
+    ]
+
+mkVertices :: FlatMonoBindsInfo -> [VertexTag]
+mkVertices info = [ vertex | (vertex,_,_,_,_) <- info]
+
+mkEdges :: [VertexTag] -> FlatMonoBindsInfo -> [Edge]
+
+mkEdges vertices 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_vertex <- vertices_defining target_name flat_info
+   ]
+   where
+   -- If each name only has one binding in this group, then
+   -- vertices_defining will always return the empty list, or a
+   -- singleton.  The case when there is more than one binding (an
+   -- error) needs more thought.
+
+   vertices_defining name flat_info2
+    = [ vertex |  (vertex, names_defined, _, _, _) <- flat_info2,
+		name `elementOfUniqSet` names_defined
+      ]
+\end{code}
+
+
+%************************************************************************
+%*									*
+\subsubsection[dep-Sigs]{Signatures (and user-pragmas for values)}
+%*									*
+%************************************************************************
+
+@rnBindSigs@ checks for: (a)~more than one sig for one thing;
+(b)~signatures given for things not bound here; (c)~with suitably
+flaggery, that all top-level things have type signatures.
+
+\begin{code}
+rnBindSigs :: Bool		    -- True <=> top-level binders
+	    -> [ProtoName]	    -- Binders for this decl group
+	    -> [ProtoNameSig]
+	    -> Rn4M [RenamedSig]    -- List of Sig constructors
+
+rnBindSigs is_toplev binder_pnames sigs
+  =
+	 -- Rename the signatures
+	 -- Will complain about sigs for variables not in this group
+    mapRn4 rename_sig sigs   `thenRn4` \ sigs_maybe ->
+    let
+	sigs' = catMaybes sigs_maybe
+
+	 -- Discard unbound ones we've already complained about, so we
+	 -- complain about duplicate ones.
+
+	(goodies, dups) = removeDups compare (filter not_unbound sigs')
+    in
+    mapRn4 (addErrRn4 . dupSigDeclErr) dups `thenRn4_`
+
+    getSrcLocRn4		`thenRn4` \ locn ->
+
+    (if (is_toplev && opt_SigsRequired) then
+	let
+	    sig_frees = catMaybes (map (sig_free sigs) binder_pnames)
+	in
+	mapRn4 (addErrRn4 . missingSigErr locn) sig_frees
+     else
+	returnRn4 []
+    )					    `thenRn4_`
+
+    returnRn4 sigs' -- bad ones and all:
+		    -- we need bindings of *some* sort for every name
+  where
+    rename_sig (Sig v ty pragma src_loc)
+      = pushSrcLocRn4 src_loc 	(
+
+	if not (v `elemByLocalNames` binder_pnames) then
+	   addErrRn4 (unknownSigDeclErr "type signature" v src_loc) `thenRn4_`
+	   returnRn4 Nothing
+	else
+	   lookupValue v				`thenRn4` \ new_v ->
+	   rnPolyType False nullTyVarNamesEnv ty	`thenRn4` \ new_ty ->
+	   recoverQuietlyRn4 noGenPragmas (
+		rnGenPragmas pragma
+	   )					    `thenRn4` \ new_pragma ->
+	   returnRn4 (Just (Sig new_v new_ty new_pragma src_loc))
+	)
+
+    -- and now, the various flavours of value-modifying user-pragmas:
+
+    rename_sig (SpecSig v ty using src_loc)
+      = pushSrcLocRn4 src_loc 	(
+
+	if not (v `elemByLocalNames` binder_pnames) then
+	   addErrRn4 (unknownSigDeclErr "SPECIALIZE pragma" v src_loc) `thenRn4_`
+	   returnRn4 Nothing
+	else
+	   lookupValue v				`thenRn4` \ new_v ->
+	   rnPolyType False nullTyVarNamesEnv ty	`thenRn4` \ new_ty ->
+	   rn_using using				`thenRn4` \ new_using ->
+	   returnRn4 (Just (SpecSig new_v new_ty new_using src_loc))
+	)
+      where
+	rn_using Nothing  = returnRn4 Nothing
+	rn_using (Just x) = lookupValue x `thenRn4` \ new_x ->
+			    returnRn4 (Just new_x)
+
+    rename_sig (InlineSig v src_loc)
+      = pushSrcLocRn4 src_loc 	(
+
+	if not (v `elemByLocalNames` binder_pnames) then
+	   addErrRn4 (unknownSigDeclErr "INLINE pragma" v src_loc) `thenRn4_`
+	   returnRn4 Nothing
+	else
+	   lookupValue v	`thenRn4` \ new_v ->
+	   returnRn4 (Just (InlineSig new_v src_loc))
+	)
+
+    rename_sig (DeforestSig v src_loc)
+      = pushSrcLocRn4 src_loc   (
+
+	if not (v `elemByLocalNames` binder_pnames) then
+	   addErrRn4 (unknownSigDeclErr "DEFOREST pragma" v src_loc) `thenRn4_`
+	   returnRn4 Nothing
+	else
+	   lookupValue v        `thenRn4` \ new_v ->
+	   returnRn4 (Just (DeforestSig new_v src_loc))
+	)
+
+    rename_sig (MagicUnfoldingSig v str src_loc)
+      = pushSrcLocRn4 src_loc 	(
+
+	if not (v `elemByLocalNames` binder_pnames) then
+	   addErrRn4 (unknownSigDeclErr "MAGIC_UNFOLDING pragma" v src_loc) `thenRn4_`
+	   returnRn4 Nothing
+	else
+	   lookupValue v	`thenRn4` \ new_v ->
+	   returnRn4 (Just (MagicUnfoldingSig new_v str src_loc))
+	)
+
+    not_unbound :: RenamedSig -> Bool
+
+    not_unbound (Sig n _ _ _)		  = not (isUnboundName n)
+    not_unbound (SpecSig n _ _ _)	  = not (isUnboundName n)
+    not_unbound (InlineSig n _)		  = not (isUnboundName n)
+    not_unbound (DeforestSig n _)	  = not (isUnboundName n)
+    not_unbound (MagicUnfoldingSig n _ _) = not (isUnboundName n)
+
+    -------------------------------------
+    sig_free :: [ProtoNameSig] -> ProtoName -> Maybe ProtoName
+	-- 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 `eqByLocalName` ny) then Nothing else sig_free rest ny
+    sig_free (_ : rest) ny = sig_free rest ny
+
+    -------------------------------------
+    compare :: RenamedSig -> RenamedSig -> TAG_
+    compare x y = c x y
+
+    c (Sig n1 _ _ _)	    	 (Sig n2 _ _ _)    	    = n1 `cmp` n2
+    c (InlineSig n1 _)  	 (InlineSig n2 _) 	    = n1 `cmp` n2
+    c (MagicUnfoldingSig n1 _ _) (MagicUnfoldingSig n2 _ _) = n1 `cmp` n2
+    c (SpecSig n1 ty1 _ _)	 (SpecSig n2 ty2 _ _)
+      = -- may have many specialisations for one value;
+	-- but not ones that are exactly the same...
+	case (n1 `cmp` n2) of
+	  EQ_   -> cmpPolyType cmp ty1 ty2
+	  other -> other
+
+    c 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(RnBinds4)"
+\end{code}
+
+%************************************************************************
+%*									*
+\subsection{Error messages}
+%*									*
+%************************************************************************
+
+\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) )
+  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 "'."])
+\end{code}
diff --git a/ghc/compiler/rename/RnExpr4.lhs b/ghc/compiler/rename/RnExpr4.lhs
new file mode 100644
index 0000000000..21f5346e22
--- /dev/null
+++ b/ghc/compiler/rename/RnExpr4.lhs
@@ -0,0 +1,407 @@
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+%
+\section[RnExpr4]{Renaming of expressions (pass 4)}
+
+Basically dependency analysis.
+
+Handles @Match@, @GRHSsAndBinds@, @HsExpr@, and @Qual@ datatypes.  In
+general, all of these functions return a renamed thing, and a set of
+free variables.
+
+\begin{code}
+#include "HsVersions.h"
+
+module RnExpr4 (
+	rnMatch, rnGRHSsAndBinds, rnPat
+
+	-- and to make the interface self-sufficient...
+   ) where
+
+import Ubiq{-uitous-}
+import RnLoop		-- break the RnPass4/RnExpr4/RnBinds4 loops
+
+import HsSyn
+import RdrHsSyn
+import RnHsSyn
+import RnMonad4
+
+-- others:
+import Name		( Name(..) )
+import NameTypes	( FullName{-instances-} )
+import Outputable	( isConop )
+import UniqSet		( emptyUniqSet, singletonUniqSet,
+			  unionUniqSets, unionManyUniqSets,
+			  UniqSet(..)
+			)
+import Util		( panic )
+\end{code}
+
+
+*********************************************************
+*							*
+\subsection{Patterns}
+*							*
+*********************************************************
+
+\begin{code}
+rnPat ::  ProtoNamePat -> Rn4M RenamedPat
+
+rnPat WildPatIn = returnRn4 WildPatIn
+
+rnPat (VarPatIn name)
+  = lookupValue name	`thenRn4` \ vname ->
+    returnRn4 (VarPatIn vname)
+
+rnPat (LitPatIn n) = returnRn4 (LitPatIn n)
+
+rnPat (LazyPatIn pat)
+  = rnPat pat	`thenRn4` \ pat' ->
+    returnRn4 (LazyPatIn pat')
+
+rnPat (AsPatIn name pat)
+  = rnPat pat	`thenRn4` \ pat' ->
+    lookupValue name	`thenRn4` \ vname ->
+    returnRn4 (AsPatIn vname pat')
+
+rnPat (ConPatIn name pats)
+  = lookupValue name	    `thenRn4` \ name' ->
+    mapRn4 rnPat pats  `thenRn4` \ patslist ->
+    returnRn4 (ConPatIn name' patslist)
+
+rnPat (ConOpPatIn pat1 name pat2)
+  = lookupValue name	`thenRn4` \ name' ->
+    rnPat pat1	`thenRn4` \ pat1' ->
+    rnPat pat2	`thenRn4` \ pat2' ->
+    returnRn4 (ConOpPatIn pat1' name' pat2')
+
+rnPat (ListPatIn pats)
+  = mapRn4 rnPat pats `thenRn4` \ patslist ->
+    returnRn4 (ListPatIn patslist)
+
+rnPat (TuplePatIn pats)
+  = mapRn4 rnPat pats `thenRn4` \ patslist ->
+    returnRn4 (TuplePatIn patslist)
+
+rnPat (RecPatIn con rpats)
+  = panic "rnPat:RecPatIn"
+
+\end{code}
+
+************************************************************************
+*									*
+\subsection{Match}
+*									*
+************************************************************************
+
+\begin{code}
+rnMatch :: ProtoNameMatch -> Rn4M (RenamedMatch, FreeVars)
+
+rnMatch match
+  = getSrcLocRn4			`thenRn4` \ src_loc ->
+    namesFromProtoNames "variable in pattern"
+	 (binders `zip` repeat src_loc)	`thenRn4` \ new_binders ->
+    extendSS2 new_binders (rnMatch_aux match)
+  where
+    binders = collect_binders match
+
+    collect_binders :: ProtoNameMatch -> [ProtoName]
+
+    collect_binders (GRHSMatch _) = []
+    collect_binders (PatMatch pat match)
+      = collectPatBinders pat ++ collect_binders match
+
+rnMatch_aux (PatMatch pat match)
+  = rnPat pat		`thenRn4` \ pat' ->
+    rnMatch_aux match	`thenRn4` \ (match', fvMatch) ->
+    returnRn4 (PatMatch pat' match', fvMatch)
+
+rnMatch_aux (GRHSMatch grhss_and_binds)
+  = rnGRHSsAndBinds grhss_and_binds `thenRn4` \ (grhss_and_binds', fvs) ->
+    returnRn4 (GRHSMatch grhss_and_binds', fvs)
+\end{code}
+
+%************************************************************************
+%*									*
+\subsubsection{Guarded right-hand sides (GRHSsAndBinds)}
+%*									*
+%************************************************************************
+
+\begin{code}
+rnGRHSsAndBinds :: ProtoNameGRHSsAndBinds -> Rn4M (RenamedGRHSsAndBinds, FreeVars)
+
+rnGRHSsAndBinds (GRHSsAndBindsIn grhss binds)
+  = rnBinds binds			`thenRn4` \ (binds', fvBinds, scope) ->
+    extendSS2 scope (rnGRHSs grhss)	`thenRn4` \ (grhss', fvGRHS) ->
+    returnRn4 (GRHSsAndBindsIn grhss' binds', fvBinds `unionUniqSets` fvGRHS)
+  where
+    rnGRHSs [] = returnRn4 ([], emptyUniqSet)
+
+    rnGRHSs (grhs:grhss)
+      = rnGRHS  grhs   `thenRn4` \ (grhs',  fvs) ->
+	rnGRHSs grhss  `thenRn4` \ (grhss', fvss) ->
+	returnRn4 (grhs' : grhss', fvs `unionUniqSets` fvss)
+
+    rnGRHS (GRHS guard expr locn)
+      = pushSrcLocRn4 locn			      	  (
+	rnExpr guard   `thenRn4` \ (guard', fvsg) ->
+	rnExpr expr	`thenRn4` \ (expr',  fvse) ->
+	returnRn4 (GRHS guard' expr' locn, fvsg `unionUniqSets` fvse)
+	)
+
+    rnGRHS (OtherwiseGRHS expr locn)
+      = pushSrcLocRn4 locn			      	  (
+	rnExpr expr	`thenRn4` \ (expr', fvs) ->
+	returnRn4 (OtherwiseGRHS expr' locn, fvs)
+	)
+\end{code}
+
+%************************************************************************
+%*									*
+\subsubsection{Expressions}
+%*									*
+%************************************************************************
+
+\begin{code}
+rnExprs :: [ProtoNameHsExpr] -> Rn4M ([RenamedHsExpr], FreeVars)
+
+rnExprs [] = returnRn4 ([], emptyUniqSet)
+
+rnExprs (expr:exprs)
+  = rnExpr expr 	`thenRn4` \ (expr', fvExpr) ->
+    rnExprs exprs	`thenRn4` \ (exprs', fvExprs) ->
+    returnRn4 (expr':exprs', fvExpr `unionUniqSets` 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 Name returned from the lookup, and make it part of the
+free-var set iff:
+\begin{itemize}
+\item
+if it's a @Short@,
+\item
+or it's an @ValName@ and it's defined in this module
+(this includes locally-defined constructrs, but that's too bad)
+\end{itemize}
+
+\begin{code}
+rnExpr :: ProtoNameHsExpr -> Rn4M (RenamedHsExpr, FreeVars)
+
+rnExpr (HsVar v)
+  = lookupValue v	`thenRn4` \ vname ->
+    returnRn4 (HsVar vname, fv_set vname)
+  where
+    fv_set n@(Short uniq sname)	    = singletonUniqSet n
+    fv_set n@(ValName uniq fname)
+	  | isLocallyDefined fname
+	  && not (isConop (getOccurrenceName fname))
+				    = singletonUniqSet n
+    fv_set other  		    = emptyUniqSet
+
+rnExpr (HsLit lit)  = returnRn4 (HsLit lit, emptyUniqSet)
+
+rnExpr (HsLam match)
+  = rnMatch match	`thenRn4` \ (match', fvMatch) ->
+    returnRn4 (HsLam match', fvMatch)
+
+rnExpr (HsApp fun arg)
+  = rnExpr fun		`thenRn4` \ (fun',fvFun) ->
+    rnExpr arg		`thenRn4` \ (arg',fvArg) ->
+    returnRn4 (HsApp fun' arg', fvFun `unionUniqSets` fvArg)
+
+rnExpr (OpApp e1 op e2)
+  = rnExpr e1 		`thenRn4` \ (e1', fvs_e1) ->
+    rnExpr op 		`thenRn4` \ (op', fvs_op) ->
+    rnExpr e2 		`thenRn4` \ (e2', fvs_e2) ->
+    returnRn4 (OpApp e1' op' e2', (fvs_op `unionUniqSets` fvs_e1) `unionUniqSets` fvs_e2)
+
+rnExpr (SectionL expr op)
+  = rnExpr expr	 	`thenRn4` \ (expr', fvs_expr) ->
+    rnExpr op	 	`thenRn4` \ (op', fvs_op) ->
+    returnRn4 (SectionL expr' op', fvs_op `unionUniqSets` fvs_expr)
+
+rnExpr (SectionR op expr)
+  = rnExpr op	 	`thenRn4` \ (op',   fvs_op) ->
+    rnExpr expr	 	`thenRn4` \ (expr', fvs_expr) ->
+    returnRn4 (SectionR op' expr', fvs_op `unionUniqSets` fvs_expr)
+
+rnExpr (CCall fun args may_gc is_casm fake_result_ty)
+  = rnExprs args	 `thenRn4` \ (args', fvs_args) ->
+    returnRn4 (CCall fun args' may_gc is_casm fake_result_ty, fvs_args)
+
+rnExpr (HsSCC label expr)
+  = rnExpr expr	 	`thenRn4` \ (expr', fvs_expr) ->
+    returnRn4 (HsSCC label expr', fvs_expr)
+
+rnExpr (HsCase expr ms src_loc)
+  = pushSrcLocRn4 src_loc $
+    rnExpr expr		 	`thenRn4` \ (new_expr, e_fvs) ->
+    mapAndUnzipRn4 rnMatch ms   `thenRn4` \ (new_ms, ms_fvs) ->
+    returnRn4 (HsCase new_expr new_ms src_loc, unionManyUniqSets (e_fvs : ms_fvs))
+
+rnExpr (HsLet binds expr)
+  = rnBinds binds		`thenRn4` \ (binds', fvBinds, new_binders) ->
+    extendSS2 new_binders (rnExpr expr) `thenRn4` \ (expr',fvExpr) ->
+    returnRn4 (HsLet binds' expr', fvBinds `unionUniqSets` fvExpr)
+
+rnExpr (HsDo stmts src_loc)
+  = pushSrcLocRn4 src_loc $
+    rnStmts stmts		`thenRn4` \ (stmts', fvStmts) ->
+    returnRn4 (HsDo stmts' src_loc, fvStmts)
+
+rnExpr (ListComp expr quals)
+  = rnQuals quals 		`thenRn4` \ ((quals', qual_binders), fvQuals) ->
+    extendSS2 qual_binders (rnExpr expr) `thenRn4` \ (expr', fvExpr) ->
+    returnRn4 (ListComp expr' quals', fvExpr `unionUniqSets` fvQuals)
+
+rnExpr (ExplicitList exps)
+  = rnExprs exps	 `thenRn4` \ (exps', fvs) ->
+    returnRn4  (ExplicitList exps', fvs)
+
+rnExpr (ExplicitTuple exps)
+  = rnExprs exps	 `thenRn4` \ (exps', fvExps) ->
+    returnRn4 (ExplicitTuple exps', fvExps)
+
+rnExpr (RecordCon con rbinds)
+  = panic "rnExpr:RecordCon"
+rnExpr (RecordUpd exp rbinds)
+  = panic "rnExpr:RecordUpd"
+
+rnExpr (ExprWithTySig expr pty)
+  = rnExpr expr			    `thenRn4` \ (expr', fvExpr) ->
+    rnPolyType False nullTyVarNamesEnv pty `thenRn4` \ pty' ->
+    returnRn4 (ExprWithTySig expr' pty', fvExpr)
+
+rnExpr (HsIf p b1 b2 src_loc)
+  = pushSrcLocRn4 src_loc $
+    rnExpr p	`thenRn4` \ (p', fvP) ->
+    rnExpr b1	`thenRn4` \ (b1', fvB1) ->
+    rnExpr b2	`thenRn4` \ (b2', fvB2) ->
+    returnRn4 (HsIf p' b1' b2' src_loc, unionManyUniqSets [fvP, fvB1, fvB2])
+
+rnExpr (ArithSeqIn seq)
+  = rn_seq seq `thenRn4` \ (new_seq, fvs) ->
+    returnRn4 (ArithSeqIn new_seq, fvs)
+  where
+    rn_seq (From expr)
+     = rnExpr expr 	 `thenRn4` \ (expr', fvExpr) ->
+       returnRn4 (From expr', fvExpr)
+
+    rn_seq (FromThen expr1 expr2)
+     = rnExpr expr1 	 `thenRn4` \ (expr1', fvExpr1) ->
+       rnExpr expr2	 `thenRn4` \ (expr2', fvExpr2) ->
+       returnRn4 (FromThen expr1' expr2', fvExpr1 `unionUniqSets` fvExpr2)
+
+    rn_seq (FromTo expr1 expr2)
+     = rnExpr expr1	 `thenRn4` \ (expr1', fvExpr1) ->
+       rnExpr expr2	 `thenRn4` \ (expr2', fvExpr2) ->
+       returnRn4 (FromTo expr1' expr2', fvExpr1 `unionUniqSets` fvExpr2)
+
+    rn_seq (FromThenTo expr1 expr2 expr3)
+     = rnExpr expr1	 `thenRn4` \ (expr1', fvExpr1) ->
+       rnExpr expr2	 `thenRn4` \ (expr2', fvExpr2) ->
+       rnExpr expr3	 `thenRn4` \ (expr3', fvExpr3) ->
+       returnRn4 (FromThenTo expr1' expr2' expr3',
+		  unionManyUniqSets [fvExpr1, fvExpr2, fvExpr3])
+
+\end{code}
+
+%************************************************************************
+%*									*
+\subsubsection{@Qual@s: in list comprehensions}
+%*									*
+%************************************************************************
+
+Note that although some bound vars may appear in the free var set for
+the first qual, these will eventually be removed by the caller. For
+example, if we have @[p | r <- s, q <- r, p <- q]@, when doing
+@[q <- r, p <- q]@, the free var set for @q <- r@ will
+be @{r}@, and the free var set for the entire Quals will be @{r}@. This
+@r@ will be removed only when we finally return from examining all the
+Quals.
+
+\begin{code}
+rnQuals :: [ProtoNameQual]
+	 -> Rn4M (([RenamedQual],	-- renamed qualifiers
+		  [Name]),		-- qualifiers' binders
+		  FreeVars)		-- free variables
+
+rnQuals [qual] 				-- must be at least one qual
+  = rnQual qual `thenRn4` \ ((new_qual, bs), fvs) ->
+    returnRn4 (([new_qual], bs), fvs)
+
+rnQuals (qual: quals)
+  = rnQual qual				`thenRn4` \ ((qual',  bs1), fvQuals1) ->
+    extendSS2 bs1 (rnQuals quals)	`thenRn4` \ ((quals', bs2), fvQuals2) ->
+    returnRn4
+       ((qual' : quals', bs2 ++ bs1),	-- The ones on the right (bs2) shadow the
+					-- ones on the left (bs1)
+	fvQuals1 `unionUniqSets` fvQuals2)
+
+rnQual (GeneratorQual pat expr)
+  = rnExpr expr		 `thenRn4` \ (expr', fvExpr) ->
+    let
+	binders = collectPatBinders pat
+    in
+    getSrcLocRn4		 `thenRn4` \ src_loc ->
+    namesFromProtoNames "variable in list-comprehension-generator pattern"
+	 (binders `zip` repeat src_loc)	  `thenRn4` \ new_binders ->
+    extendSS new_binders (rnPat pat) `thenRn4` \ pat' ->
+
+    returnRn4 ((GeneratorQual pat' expr', new_binders), fvExpr)
+
+rnQual (FilterQual expr)
+  = rnExpr expr	 `thenRn4` \ (expr', fvs) ->
+    returnRn4 ((FilterQual expr', []), fvs)
+
+rnQual (LetQual binds)
+  = rnBinds binds	`thenRn4` \ (binds', binds_fvs, new_binders) ->
+    returnRn4 ((LetQual binds', new_binders), binds_fvs)
+\end{code}
+
+
+%************************************************************************
+%*									*
+\subsubsection{@Stmt@s: in @do@ expressions}
+%*									*
+%************************************************************************
+
+\begin{code}
+rnStmts :: [ProtoNameStmt]
+	-> Rn4M ([RenamedStmt],		-- renamed qualifiers
+	         FreeVars)		-- free variables
+
+rnStmts [stmt@(ExprStmt _ _)]		-- last stmt must be ExprStmt
+  = rnStmt stmt				`thenRn4` \ ((stmt',[]), fvStmt) ->
+    returnRn4 ([stmt'], fvStmt)
+
+rnStmts (stmt:stmts)
+  = rnStmt stmt				`thenRn4` \ ((stmt',bs), fvStmt) ->
+    extendSS2 bs (rnStmts stmts)	`thenRn4` \ (stmts',     fvStmts) ->
+    returnRn4 (stmt':stmts', fvStmt `unionUniqSets` fvStmts)
+
+
+rnStmt (BindStmt pat expr src_loc)
+  = pushSrcLocRn4 src_loc $
+    rnExpr expr		 		`thenRn4` \ (expr', fvExpr) ->
+    let
+	binders = collectPatBinders pat
+    in
+    namesFromProtoNames "variable in do binding"
+	 (binders `zip` repeat src_loc)	`thenRn4` \ new_binders ->
+    extendSS new_binders (rnPat pat) 	`thenRn4` \ pat' ->
+
+    returnRn4 ((BindStmt pat' expr' src_loc, new_binders), fvExpr)
+
+rnStmt (ExprStmt expr src_loc)
+  = 
+    rnExpr expr	 			`thenRn4` \ (expr', fvs) ->
+    returnRn4 ((ExprStmt expr' src_loc, []), fvs)
+
+rnStmt (LetStmt binds)
+  = rnBinds binds	`thenRn4` \ (binds', binds_fvs, new_binders) ->
+    returnRn4 ((LetStmt binds', new_binders), binds_fvs)
+
+\end{code}
diff --git a/ghc/compiler/rename/RnHsSyn.lhs b/ghc/compiler/rename/RnHsSyn.lhs
new file mode 100644
index 0000000000..b141a30294
--- /dev/null
+++ b/ghc/compiler/rename/RnHsSyn.lhs
@@ -0,0 +1,60 @@
+%
+% (c) The AQUA Project, Glasgow University, 1996
+%
+\section[RnHsSyn]{Specialisations of the @HsSyn@ syntax for the renamer}
+
+\begin{code}
+#include "HsVersions.h"
+
+module RnHsSyn where
+
+import Ubiq{-uitous-}
+
+import HsSyn
+\end{code}
+
+\begin{code}
+type RenamedArithSeqInfo	= ArithSeqInfo		Fake Fake Name RenamedPat
+type RenamedBind		= Bind			Fake Fake Name RenamedPat
+type RenamedClassDecl		= ClassDecl		Fake Fake Name RenamedPat
+type RenamedClassOpPragmas	= ClassOpPragmas	Name
+type RenamedClassOpSig		= Sig			Name
+type RenamedClassPragmas	= ClassPragmas		Name
+type RenamedConDecl		= ConDecl		Name
+type RenamedContext		= Context 		Name
+type RenamedDataPragmas		= DataPragmas		Name
+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 RenamedGenPragmas		= GenPragmas		Name
+type RenamedHsBinds		= HsBinds		Fake Fake Name RenamedPat
+type RenamedHsExpr		= HsExpr		Fake Fake Name RenamedPat
+type RenamedHsModule		= HsModule		Fake Fake Name RenamedPat
+type RenamedImportedInterface	= ImportedInterface	Fake Fake Name RenamedPat
+type RenamedInstDecl		= InstDecl		Fake Fake Name RenamedPat
+type RenamedInstancePragmas	= InstancePragmas	Name
+type RenamedInterface		= Interface		Fake Fake Name RenamedPat
+type RenamedMatch		= Match			Fake Fake Name RenamedPat
+type RenamedMonoBinds		= MonoBinds		Fake Fake Name RenamedPat
+type RenamedMonoType		= MonoType		Name
+type RenamedPat			= InPat			Name
+type RenamedPolyType		= PolyType		Name
+type RenamedQual		= Qual			Fake Fake Name RenamedPat
+type RenamedSig			= Sig			Name
+type RenamedSpecInstSig		= SpecInstSig 		Name
+type RenamedStmt		= Stmt			Fake Fake Name RenamedPat
+type RenamedTyDecl		= TyDecl		Name
+\end{code}
+
+\begin{code}
+collectQualBinders :: [RenamedQual] -> [Name]
+
+collectQualBinders quals
+  = concat (map collect quals)
+  where
+    collect (GeneratorQual pat _) = collectPatBinders pat
+    collect (FilterQual expr)	  = []
+    collect (LetQual    binds)	  = collectTopLevelBinders binds
+\end{code}
diff --git a/ghc/compiler/rename/RnLoop.lhi b/ghc/compiler/rename/RnLoop.lhi
new file mode 100644
index 0000000000..92b7d418b6
--- /dev/null
+++ b/ghc/compiler/rename/RnLoop.lhi
@@ -0,0 +1,22 @@
+Breaks the RnPass4/RnExpr4/RnBind4 loops.
+
+\begin{code}
+interface RnLoop where
+
+import Name		( Name )
+import RdrHsSyn		( ProtoNameHsBinds(..), ProtoNamePolyType(..), ProtoNameGenPragmas(..) )
+import RnHsSyn		( RenamedHsBinds(..), RenamedPolyType(..), RenamedGenPragmas(..) )
+import RnBinds4		( rnBinds, FreeVars(..) )
+import RnMonad4		( TyVarNamesEnv(..), Rn4M(..) )
+import RnPass4		( rnPolyType, rnGenPragmas )
+import UniqSet		( UniqSet(..) )
+
+rnBinds :: ProtoNameHsBinds -> Rn4M (RenamedHsBinds, FreeVars, [Name])
+rnGenPragmas :: ProtoNameGenPragmas -> Rn4M RenamedGenPragmas
+rnPolyType :: Bool
+	    -> TyVarNamesEnv
+	    -> ProtoNamePolyType
+	    -> Rn4M RenamedPolyType
+
+type FreeVars = UniqSet Name
+\end{code}
diff --git a/ghc/compiler/rename/RnMonad12.lhs b/ghc/compiler/rename/RnMonad12.lhs
new file mode 100644
index 0000000000..bfb7814657
--- /dev/null
+++ b/ghc/compiler/rename/RnMonad12.lhs
@@ -0,0 +1,97 @@
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+%
+\section[RnMonad12]{The monad used by the renamer passes 1 and 2}
+
+\begin{code}
+#include "HsVersions.h"
+
+module RnMonad12 (
+	Rn12M(..),
+	initRn12, thenRn12, returnRn12,
+	mapRn12, zipWithRn12, foldrRn12,
+	addErrRn12, getModuleNameRn12, recoverQuietlyRn12
+
+	-- and to make the interface self-sufficient...
+    ) where
+
+import Ubiq{-uitous-}
+
+import Bag		( emptyBag, isEmptyBag, snocBag, Bag )
+import ErrUtils		( Error(..) )
+import Pretty		( Pretty(..) )
+
+infixr 9 `thenRn12`
+\end{code}
+
+In this monad, we pass down the name of the module we are working on,
+and we thread the collected errors.
+
+\begin{code}
+type Rn12M result
+  =  FAST_STRING{-module name-}
+  -> Bag Error
+  -> (result, Bag Error)
+
+{-# INLINE thenRn12 #-}
+{-# INLINE returnRn12 #-}
+
+initRn12 :: FAST_STRING{-module name-} -> Rn12M a -> (a, Bag Error)
+initRn12 mod action = action mod emptyBag
+
+thenRn12 :: Rn12M a -> (a -> Rn12M b) -> Rn12M b
+thenRn12 expr continuation mod errs_so_far
+  = case (expr mod errs_so_far) of
+     (res1, errs1) -> continuation res1 mod errs1
+
+returnRn12 :: a -> Rn12M a
+returnRn12 x mod errs_so_far = (x, errs_so_far)
+
+mapRn12 :: (a -> Rn12M b) -> [a] -> Rn12M [b]
+
+mapRn12 f []     = returnRn12 []
+mapRn12 f (x:xs)
+  = f x		 `thenRn12` \ r ->
+    mapRn12 f xs `thenRn12` \ rs ->
+    returnRn12 (r:rs)
+
+zipWithRn12 :: (a -> b -> Rn12M c) -> [a] -> [b] -> Rn12M [c]
+
+zipWithRn12 f []     [] = returnRn12 []
+zipWithRn12 f (x:xs) (y:ys)
+  = f x y	     	`thenRn12` \ r ->
+    zipWithRn12 f xs ys `thenRn12` \ rs ->
+    returnRn12 (r:rs)
+-- NB: zipWithRn12 behaves like zipWithEqual
+-- (requires equal-length lists)
+
+foldrRn12 :: (a -> b -> Rn12M b) -> b -> [a] -> Rn12M b
+
+foldrRn12 f z []     = returnRn12 z
+foldrRn12 f z (x:xs)
+ = foldrRn12 f z xs  `thenRn12` \ rest ->
+   f x rest
+
+addErrRn12 :: Error -> Rn12M ()
+addErrRn12 err mod errs_so_far
+ = ( (), errs_so_far `snocBag` err )
+
+getModuleNameRn12 :: Rn12M FAST_STRING
+getModuleNameRn12 mod errs_so_far = (mod, errs_so_far)
+\end{code}
+
+\begin{code}
+recoverQuietlyRn12 :: a -> Rn12M a -> Rn12M a
+
+recoverQuietlyRn12 use_this_if_err action mod errs_so_far
+  = let
+	(result, errs_out)
+	  = case (action mod emptyBag{-no errors-}) of { (res, errs) ->
+	    if isEmptyBag errs then
+		(res, errs_so_far)  -- retain incoming errs
+	    else
+		(use_this_if_err, errs_so_far)
+	    }
+    in
+    (result, errs_out)
+\end{code}
diff --git a/ghc/compiler/rename/RnMonad3.lhs b/ghc/compiler/rename/RnMonad3.lhs
new file mode 100644
index 0000000000..ca69b1d575
--- /dev/null
+++ b/ghc/compiler/rename/RnMonad3.lhs
@@ -0,0 +1,209 @@
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+%
+\section[RnMonad3]{The monad used by the third renamer pass}
+
+\begin{code}
+#include "HsVersions.h"
+
+module RnMonad3 (
+	Rn3M(..),
+	initRn3, thenRn3, andRn3, returnRn3, mapRn3, fixRn3,
+
+	putInfoDownM3,
+
+	newFullNameM3, newInvisibleNameM3
+
+	-- for completeness
+    ) where
+
+import Ubiq{-uitous-}
+
+import FiniteMap	( emptyFM,  isEmptyFM,  lookupFM,
+			  emptySet, isEmptySet, elementOf
+			)
+import HsSyn		( IE )
+import NameTypes	-- lots of stuff
+import Outputable	( ExportFlag(..) )
+import ProtoName	( ProtoName(..) )
+import RdrHsSyn		( getExportees, ExportListInfo(..), ProtoNameIE(..) )
+import UniqSupply	( getUnique, splitUniqSupply )
+import Util		( panic )
+
+infixr 9 `thenRn3`
+\end{code}
+
+%************************************************************************
+%*									*
+\subsection{Plain @RnPass3@ monadery}
+%*									*
+%************************************************************************
+
+\begin{code}
+type Rn3M result
+  =  ExportListInfo -> FAST_STRING{-ModuleName-} -> UniqSupply
+  -> result
+
+{-# INLINE andRn3 #-}
+{-# INLINE thenRn3 #-}
+{-# INLINE returnRn3 #-}
+
+initRn3 :: Rn3M a -> UniqSupply -> a
+
+initRn3 m us = m Nothing{-no export list-} (panic "initRn3: uninitialised module name") us
+
+thenRn3 :: Rn3M a -> (a -> Rn3M b) -> Rn3M b
+andRn3  :: (a -> a -> a) -> Rn3M a -> Rn3M a -> Rn3M a
+
+thenRn3 expr continuation exps mod_name uniqs
+  = case splitUniqSupply uniqs      of { (s1, s2) ->
+    case (expr exps mod_name s1)    of { res1 ->
+    continuation res1 exps mod_name s2 }}
+
+andRn3 combiner m1 m2 exps mod_name uniqs
+  = case splitUniqSupply uniqs      of { (s1, s2) ->
+    case (m1 exps mod_name s1)      of { res1 ->
+    case (m2 exps mod_name s2)	    of { res2 ->
+    combiner res1 res2 }}}
+
+returnRn3 :: a -> Rn3M a
+returnRn3 result exps mod_name uniqs = result
+
+mapRn3 :: (a -> Rn3M b) -> [a] -> Rn3M [b]
+
+mapRn3 f []     = returnRn3 []
+mapRn3 f (x:xs)
+  = f x		`thenRn3` \ r ->
+    mapRn3 f xs	`thenRn3` \ rs ->
+    returnRn3 (r:rs)
+
+fixRn3 :: (a -> Rn3M a) -> Rn3M a
+
+fixRn3 m exps mod_name us
+  = result
+  where
+    result = m result exps mod_name us
+
+putInfoDownM3 :: FAST_STRING{-ModuleName-} -> Maybe [ProtoNameIE] -> Rn3M a -> Rn3M a
+
+putInfoDownM3 mod_name exports cont _ _ uniqs
+  = cont (getExportees exports) mod_name uniqs
+\end{code}
+
+%************************************************************************
+%*									*
+\subsection[RnMonad3-new-names]{Making new names}
+%*									*
+%************************************************************************
+
+@newFullNameM3@ makes a new user-visible FullName (the usual);
+@newInvisibleNameM3@ is the odd case.  @new_name@ does all the work.
+
+\begin{code}
+newFullNameM3, newInvisibleNameM3
+	:: ProtoName		-- input
+	-> SrcLoc		-- where it started life
+	-> Bool			-- if it is "TyCon"ish (rather than "val"ish)
+	-> Maybe ExportFlag	-- Just flag => force the use of that exportness
+	-> Rn3M (Unique, FullName)
+
+newFullNameM3 pn src_loc is_tycon_ish frcd_exp exps mod_name uniqs
+  = new_name pn src_loc is_tycon_ish frcd_exp False{-visible-} exps mod_name uniqs
+
+newInvisibleNameM3 pn src_loc is_tycon_ish frcd_exp exps mod_name uniqs
+  = new_name pn src_loc is_tycon_ish frcd_exp True{-invisible-} exps mod_name uniqs
+\end{code}
+
+\begin{code}
+new_name pn src_loc is_tycon_ish frcd_export_flag want_invisible exps mod_name uniqs
+  = (uniq, name)
+  where
+    uniq = getUnique uniqs
+
+    mk_name = if want_invisible then mkPrivateFullName else mkFullName
+
+    name = case pn of
+
+	Unk s -> mk_name mod_name s
+		   (if fromPrelude mod_name
+		      && is_tycon_ish then -- & tycon/clas/datacon => Core
+		       HereInPreludeCore
+		    else
+		       ThisModule
+		   )
+		   (case frcd_export_flag of
+		      Just fl -> fl
+		      Nothing -> mk_export_flag True [mod_name] s exps)
+		   src_loc
+
+	Qunk m s -> mk_name mod_name s
+		      (if fromPrelude mod_name
+			 && is_tycon_ish then -- & tycon/clas/datacon => Core
+			  HereInPreludeCore
+		       else
+			  ThisModule
+		      )
+		      (case frcd_export_flag of
+			 Just fl -> fl
+			 Nothing -> mk_export_flag (_trace "mk_export_flag?" True) [m] s exps)
+		      src_loc
+
+	-- note: the assigning of prelude-ness is most dubious (ToDo)
+
+	Imp m d informant_mods l
+	  -> mk_name m d
+	       (if fromPrelude m then	-- as above
+		   if is_tycon_ish then
+		       ExportedByPreludeCore
+		   else
+		       OtherPrelude l
+		else if m == mod_name then -- pretty dang weird... (ToDo: anything?)
+		   ThisModule
+		else
+		   OtherModule l informant_mods -- for Other*, we save its occurrence name
+	       )
+	       (case frcd_export_flag of
+		  Just fl -> fl
+		  Nothing -> mk_export_flag (m==mod_name) informant_mods l exps)
+	       src_loc
+
+	Prel n	  -> panic "RnMonad3.new_name: prelude name"
+\end{code}
+
+In deciding the ``exportness'' of something, there are these cases to
+consider:
+\begin{description}
+\item[No explicit export list:]
+Everything defined in this module goes out.
+
+\item[Matches a non-\tr{M..} item in the export list:]
+Then it's exported as its @name_pr@ item suggests.
+
+\item[Matches a \tr{M..} item in the export list:]
+
+(Note: the module \tr{M} may be {\em this} module!)  It's exported if
+we got it from \tr{M}'s interface; {\em most emphatically not} the
+same thing as ``it originally came from \tr{M}''.
+
+\item[Otherwise:]
+It isn't exported.
+\end{description}
+
+\begin{code}
+mk_export_flag	:: Bool		-- True <=> originally from the module we're compiling
+		-> [FAST_STRING]-- modules that told us about this thing
+		-> FAST_STRING	-- name of the thing we're looking at
+		-> ExportListInfo
+		-> ExportFlag	-- result
+
+mk_export_flag this_module informant_mods thing Nothing{-no export list-}
+  = if this_module then ExportAll else NotExported
+
+mk_export_flag this_module informant_mods thing (Just (exports_alist, dotdot_modules))
+  | otherwise
+  = case (lookupFM exports_alist thing) of
+      Just how_to_export -> how_to_export
+      Nothing		 -> if (or [ im `elementOf` dotdot_modules | im <- informant_mods ])
+			    then ExportAll
+			    else NotExported
+\end{code}
diff --git a/ghc/compiler/rename/RnMonad4.lhs b/ghc/compiler/rename/RnMonad4.lhs
new file mode 100644
index 0000000000..a9e2e37099
--- /dev/null
+++ b/ghc/compiler/rename/RnMonad4.lhs
@@ -0,0 +1,501 @@
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+%
+\section[RnMonad4]{The monad used by the fourth renamer pass}
+
+\begin{code}
+#include "HsVersions.h"
+
+module RnMonad4 (
+	Rn4M(..),
+	initRn4, thenRn4, thenRn4_, andRn4, returnRn4, mapRn4, mapAndUnzipRn4,
+	addErrRn4, failButContinueRn4, recoverQuietlyRn4,
+	pushSrcLocRn4,
+	getSrcLocRn4,
+	lookupValue, lookupValueEvenIfInvisible,
+	lookupClassOp, lookupFixityOp,
+	lookupTyCon, lookupTyConEvenIfInvisible,
+	lookupClass,
+	extendSS2, extendSS,
+	namesFromProtoNames,
+
+	TyVarNamesEnv(..), mkTyVarNamesEnv, domTyVarNamesEnv,
+	lookupTyVarName, nullTyVarNamesEnv, catTyVarNamesEnvs
+
+	-- for completeness
+    ) where
+
+import Ubiq{-uitous-}
+
+import Bag		( emptyBag, isEmptyBag, unionBags, snocBag, Bag )
+import CmdLineOpts	( opt_ShowPragmaNameErrs, opt_NameShadowingNotOK )
+import ErrUtils
+import FiniteMap	( emptyFM, addListToFM, addToFM, lookupFM )
+import Name		( invisibleName, isTyConName, isClassName,
+			  isClassOpName, isUnboundName, Name(..)
+			)
+import NameTypes	( mkShortName, ShortName{-instances-} )
+import Outputable	( pprNonOp )
+import Pretty
+import ProtoName	( eqProtoName, cmpByLocalName, ProtoName(..) )
+import RnUtils		( dupNamesErr, GlobalNameMappers(..) )
+import SrcLoc		( mkUnknownSrcLoc, SrcLoc{-instance-} )
+import UniqSet		( mkUniqSet, minusUniqSet, UniqSet(..) )
+import UniqSupply	( getUniques, splitUniqSupply )
+import Util		( assoc, removeDups, zipWithEqual, panic )
+
+infixr 9 `thenRn4`, `thenRn4_`
+\end{code}
+
+%************************************************************************
+%*									*
+\subsection[RnMonad4]{Plain @Rename@ monadery for pass~4}
+%*									*
+%************************************************************************
+
+\begin{code}
+type ScopeStack = FiniteMap FAST_STRING Name
+
+type Rn4M result
+  =  GlobalNameMappers
+  -> ScopeStack
+  -> Bag Error
+  -> UniqSupply
+  -> SrcLoc
+  -> (result, Bag Error)
+
+{-# INLINE andRn4 #-}
+{-# INLINE thenRn4 #-}
+{-# INLINE thenLazilyRn4 #-}
+{-# INLINE thenRn4_ #-}
+{-# INLINE returnRn4 #-}
+
+initRn4 :: GlobalNameMappers
+	-> Rn4M result
+	-> UniqSupply
+	-> (result, Bag Error)
+
+initRn4 gnfs renamer init_us
+  = renamer gnfs emptyFM emptyBag init_us mkUnknownSrcLoc
+
+thenRn4, thenLazilyRn4
+	 :: Rn4M a -> (a -> Rn4M b) -> Rn4M b
+thenRn4_ :: Rn4M a -> Rn4M b -> Rn4M b
+andRn4   :: (a -> a -> a) -> Rn4M a -> Rn4M a -> Rn4M a
+
+thenRn4 expr cont gnfs ss errs uniqs locn
+  = case (splitUniqSupply uniqs)    	   of { (s1, s2) ->
+    case (expr      gnfs ss errs  s1 locn) of { (res1, errs1) ->
+    case (cont res1 gnfs ss errs1 s2 locn) of { (res2, errs2) ->
+    (res2, errs2) }}}
+
+thenLazilyRn4 expr cont gnfs ss errs uniqs locn
+  = let
+	(s1, s2)      = splitUniqSupply uniqs
+	(res1, errs1) = expr      gnfs ss errs  s1 locn
+	(res2, errs2) = cont res1 gnfs ss errs1 s2 locn
+    in
+    (res2, errs2)
+
+thenRn4_ expr cont gnfs ss errs uniqs locn
+  = case (splitUniqSupply uniqs)      of { (s1, s2) ->
+    case (expr gnfs ss errs  s1 locn) of { (_,    errs1) ->
+    case (cont gnfs ss errs1 s2 locn) of { (res2, errs2) ->
+    (res2, errs2) }}}
+
+andRn4 combiner m1 m2 gnfs ss errs us locn
+  = case (splitUniqSupply us)	    of { (s1, s2) ->
+    case (m1 gnfs ss errs  s1 locn) of { (res1, errs1) ->
+    case (m2 gnfs ss errs1 s2 locn) of { (res2, errs2) ->
+    (combiner res1 res2, errs2) }}}
+
+returnRn4 :: a -> Rn4M a
+returnRn4 result gnfs ss errs_so_far uniqs locn
+   = (result, errs_so_far)
+
+failButContinueRn4 :: a -> Error -> Rn4M a
+failButContinueRn4 res err gnfs ss errs_so_far uniqs locn
+  = (res, errs_so_far `snocBag` err)
+
+addErrRn4 :: Error -> Rn4M ()
+addErrRn4 err gnfs ss errs_so_far uniqs locn
+  = ((), errs_so_far `snocBag` err)
+\end{code}
+
+When we're looking at interface pragmas, we want to be able to recover
+back to a ``I don't know anything pragmatic'' state if we encounter
+some problem.  @recoverQuietlyRn4@ is given a ``use-this-instead'' value,
+as well as the action to perform.  This code is intentionally very lazy,
+returning a triple immediately, no matter what.
+\begin{code}
+recoverQuietlyRn4 :: a -> Rn4M a -> Rn4M a
+
+recoverQuietlyRn4 use_this_if_err action gnfs ss errs_so_far uniqs locn
+  = let
+	(result, errs_out)
+    	  = case (action gnfs ss emptyBag{-leav out errs-} uniqs locn) of
+	      (result1, errs1) ->
+		if isEmptyBag errs1 then -- all's well! (but retain incoming errs)
+		    (result1, errs_so_far)
+		else -- give up; return *incoming* UniqueSupply...
+		    (use_this_if_err,
+		     if opt_ShowPragmaNameErrs
+		     then errs_so_far `unionBags` errs1
+		     else errs_so_far) -- toss errs, otherwise
+    in
+    (result, errs_out)
+\end{code}
+
+\begin{code}
+mapRn4 :: (a -> Rn4M b) -> [a] -> Rn4M [b]
+
+mapRn4 f []     = returnRn4 []
+mapRn4 f (x:xs)
+  = f x		`thenRn4` \ r ->
+    mapRn4 f xs `thenRn4` \ rs ->
+    returnRn4 (r:rs)
+
+mapAndUnzipRn4  :: (a -> Rn4M (b,c))   -> [a] -> Rn4M ([b],[c])
+
+mapAndUnzipRn4 f [] = returnRn4 ([],[])
+mapAndUnzipRn4 f (x:xs)
+  = f x		    	`thenRn4` \ (r1,  r2)  ->
+    mapAndUnzipRn4 f xs	`thenRn4` \ (rs1, rs2) ->
+    returnRn4 (r1:rs1, r2:rs2)
+\end{code}
+
+\begin{code}
+pushSrcLocRn4 :: SrcLoc -> Rn4M a -> Rn4M a
+pushSrcLocRn4 locn exp gnfs ss errs_so_far uniq_supply old_locn
+  = exp gnfs ss errs_so_far uniq_supply locn
+
+getSrcLocRn4 :: Rn4M SrcLoc
+
+getSrcLocRn4 gnfs ss errs_so_far uniq_supply locn
+  = returnRn4 locn gnfs ss errs_so_far uniq_supply locn
+\end{code}
+
+\begin{code}
+getNextUniquesFromRn4 :: Int -> Rn4M [Unique]
+getNextUniquesFromRn4 n gnfs ss errs_so_far us locn
+  = case (getUniques n us) of { next_uniques ->
+    (next_uniques, errs_so_far) }
+\end{code}
+
+*********************************************************
+*							*
+\subsection{Making new names}
+*							*
+*********************************************************
+
+@namesFromProtoNames@ takes a bunch of protonames, which are defined
+together in a group (eg a pattern or set of bindings), checks they
+are distinct, and creates new full names for them.
+
+\begin{code}
+namesFromProtoNames :: String 		-- Documentation string
+		    -> [(ProtoName, SrcLoc)]
+		    -> Rn4M [Name]
+
+namesFromProtoNames kind pnames_w_src_loc gnfs ss errs_so_far us locn
+  = (mapRn4 (addErrRn4 . dupNamesErr kind) dups `thenRn4_`
+    mkNewNames goodies
+    ) {-Rn4-} gnfs ss errs_so_far us locn
+  where
+    (goodies, dups) = removeDups cmp pnames_w_src_loc
+	-- We want to compare their local names rather than their
+	-- full protonames.  It probably doesn't matter here, but it
+	-- does in RnPass3.lhs!
+    cmp (a, _) (b, _) = cmpByLocalName a b
+\end{code}
+
+@mkNewNames@ assumes the names are unique.
+
+\begin{code}
+mkNewNames :: [(ProtoName, SrcLoc)] -> Rn4M [Name]
+mkNewNames pnames_w_locs
+  = getNextUniquesFromRn4 (length pnames_w_locs) `thenRn4` \ uniqs ->
+    returnRn4 (zipWithEqual new_short_name uniqs pnames_w_locs)
+  where
+    new_short_name uniq (Unk str, srcloc)   -- gotta be an Unk...
+      = Short uniq (mkShortName str srcloc)
+\end{code}
+
+
+*********************************************************
+*							*
+\subsection{Local scope extension and lookup}
+*							*
+*********************************************************
+
+If the input name is an @Imp@, @lookupValue@ looks it up in the GNF.
+If it is an @Unk@, it looks it up first in the local environment
+(scope stack), and if it isn't found there, then in the value GNF.  If
+it isn't found at all, @lookupValue@ adds an error message, and
+returns an @Unbound@ name.
+
+\begin{code}
+unboundName :: ProtoName -> Name
+unboundName pn
+   = Unbound (grab_string pn)
+   where
+     grab_string (Unk  s)      = s
+     grab_string (Qunk _ s)    = s
+     grab_string (Imp _ _ _ s) = s
+\end{code}
+
+@lookupValue@ looks up a non-invisible value;
+@lookupValueEvenIfInvisible@ gives a successful lookup even if the
+value is not visible to the user (e.g., came out of a pragma).
+@lookup_val@ is the help function to do the work.
+
+\begin{code}
+lookupValue v {-Rn4-} gnfs ss errs_so_far us locn
+  = (lookup_val v	`thenLazilyRn4` \ name ->
+    if invisibleName name
+    then failButContinueRn4 (unboundName v) (unknownNameErr "value" v mkUnknownSrcLoc)
+    else returnRn4 name
+    ) {-Rn4-} gnfs ss errs_so_far us locn
+
+lookupValueEvenIfInvisible v = lookup_val v
+
+lookup_val :: ProtoName -> Rn4M Name
+
+lookup_val pname@(Unk v) gnfs@(v_gnf, tc_gnf) ss a b locn
+  = case (lookupFM ss v) of
+      Just name -> returnRn4 name gnfs ss a b locn
+      Nothing   -> case (v_gnf pname) of
+		     Just name  -> returnRn4 name gnfs ss a b locn
+		     Nothing    -> failButContinueRn4 (unboundName pname)
+					   (unknownNameErr "value" pname locn)
+  					   gnfs ss a b locn
+
+lookup_val (Qunk _ _) _ _ _ _ _ = panic "RnMonad4:lookup_val:Qunk"
+
+-- If it ain't an Unk it must be in the global name fun; that includes
+-- prelude things.
+lookup_val pname gnfs@(v_gnf, tc_gnf) ss a b locn
+  = case (v_gnf pname) of
+	Just name  -> returnRn4 name gnfs ss a b locn
+	Nothing    -> failButContinueRn4 (unboundName pname)
+			      (unknownNameErr "value" pname locn)
+			      gnfs ss a b locn
+\end{code}
+
+Looking up the operators in a fixity decl is done differently.  We
+want to simply drop any fixity decls which refer to operators which
+aren't in scope.  Unfortunately, such fixity decls {\em will} appear
+because the parser collects *all* the fixity decls from {\em all} the
+imported interfaces (regardless of selective import), and dumps them
+together as the module fixity decls.  This is really a bug.  In
+particular:
+\begin{itemize}
+\item
+We won't complain about fixity decls for operators which aren't
+declared.
+\item
+We won't attach the right fixity to something which has been renamed.
+\end{itemize}
+
+We're not going to export Prelude-related fixities (ToDo: correctly),
+so we nuke those, too.
+
+\begin{code}
+lookupFixityOp (Prel _) gnfs@(v_gnf, tc_gnf) = returnRn4 Nothing       gnfs
+lookupFixityOp pname	gnfs@(v_gnf, tc_gnf) = returnRn4 (v_gnf pname) gnfs
+\end{code}
+
+\begin{code}
+lookupTyCon, lookupTyConEvenIfInvisible :: ProtoName -> Rn4M Name
+-- The global name funs handle Prel things
+
+lookupTyCon tc {-Rn4-} gnfs ss errs_so_far us locn
+  = (lookup_tycon tc `thenLazilyRn4` \ name ->
+    if invisibleName name
+    then failButContinueRn4 (unboundName tc) (unknownNameErr "type constructor" tc mkUnknownSrcLoc)
+    else returnRn4 name
+    ) {-Rn4-} gnfs ss errs_so_far us locn
+
+lookupTyConEvenIfInvisible tc = lookup_tycon tc
+
+lookup_tycon (Prel name) gnfs ss a b locn = returnRn4 name gnfs ss a b locn
+
+lookup_tycon pname gnfs@(v_gnf, tc_gnf) ss a b locn
+  = case (tc_gnf pname) of
+     Just name | isTyConName name -> returnRn4 name gnfs ss a b locn
+     _   -> failButContinueRn4 (unboundName pname)
+		    (unknownNameErr "type constructor" pname locn)
+		    gnfs ss a b locn
+\end{code}
+
+\begin{code}
+lookupClass :: ProtoName -> Rn4M Name
+
+lookupClass pname gnfs@(v_gnf, tc_gnf) ss a b locn
+  = case (tc_gnf pname) of
+     Just name | isClassName name -> returnRn4 name gnfs ss a b locn
+     _   -> failButContinueRn4 (unboundName pname)
+		    (unknownNameErr "class" pname locn)
+		    gnfs ss a b locn
+\end{code}
+
+@lookupClassOp@ is used when looking up the lhs identifiers in a class
+or instance decl.  It checks that the name it finds really is a class
+op, and that its class matches that of the class or instance decl
+being looked at.
+
+\begin{code}
+lookupClassOp :: Name -> ProtoName -> Rn4M Name
+
+lookupClassOp class_name pname gnfs@(v_gnf, tc_gnf) ss a b locn
+  = case v_gnf pname of
+	 Just op_name |  isClassOpName class_name op_name
+		      || isUnboundName class_name -- avoid spurious errors
+		 -> returnRn4 op_name gnfs ss a b locn
+
+	 other   -> failButContinueRn4 (unboundName pname)
+			    (badClassOpErr class_name pname locn)
+			    gnfs ss a b locn
+\end{code}
+
+@extendSS@ extends the scope; @extendSS2@ also removes the newly bound
+free vars from the result.
+
+\begin{code}
+extendSS :: [Name] 				-- Newly bound names
+	 -> Rn4M a
+	 -> Rn4M a
+
+extendSS binders expr gnfs ss errs us locn
+  = case (extend binders ss gnfs ss errs us locn) of { (new_ss, new_errs) ->
+    expr gnfs new_ss new_errs us locn }
+  where
+    extend :: [Name] -> ScopeStack -> Rn4M ScopeStack
+
+    extend names ss
+      = if opt_NameShadowingNotOK then
+	    hard_way names ss
+	else -- ignore shadowing; blast 'em in
+	    returnRn4 (
+		addListToFM ss [ (getOccurrenceName x, n) | n@(Short _ x) <- names]
+	    )
+
+    hard_way [] ss = returnRn4 ss
+    hard_way (name@(Short _ sname):names) ss
+      = let
+	    str = getOccurrenceName sname
+	in
+	(case (lookupFM ss str) of
+	   Nothing -> returnRn4 (addToFM ss str name)
+	   Just  _ -> failButContinueRn4 ss (shadowedNameErr name locn)
+
+	)	`thenRn4` \ new_ss ->
+	hard_way names new_ss
+
+extendSS2 :: [Name] 				-- Newly bound names
+	 -> Rn4M (a, UniqSet Name)
+	 -> Rn4M (a, UniqSet Name)
+
+extendSS2 binders expr gnfs ss errs_so_far us locn
+  = case (extendSS binders expr gnfs ss errs_so_far us locn) of
+     ((e2, freevars), errs)
+       -> ((e2, freevars `minusUniqSet` (mkUniqSet binders)),
+	   errs)
+\end{code}
+
+The free var set returned by @(extendSS binders m)@ is that returned
+by @m@, {\em minus} binders.
+
+*********************************************************
+*							*
+\subsection{mkTyVarNamesEnv}
+*							*
+*********************************************************
+
+\begin{code}
+type TyVarNamesEnv = [(ProtoName, Name)]
+
+nullTyVarNamesEnv :: TyVarNamesEnv
+nullTyVarNamesEnv = []
+
+catTyVarNamesEnvs :: TyVarNamesEnv -> TyVarNamesEnv -> TyVarNamesEnv
+catTyVarNamesEnvs e1 e2 = e1 ++ e2
+
+domTyVarNamesEnv :: TyVarNamesEnv -> [ProtoName]
+domTyVarNamesEnv env = map fst env
+\end{code}
+
+@mkTyVarNamesEnv@ checks for duplicates, and complains if so.
+
+\begin{code}
+mkTyVarNamesEnv
+	:: SrcLoc
+	-> [ProtoName]			-- The type variables
+	-> Rn4M (TyVarNamesEnv,[Name])	-- Environment and renamed tyvars
+
+mkTyVarNamesEnv src_loc tyvars {-Rn4-} gnfs ss errs_so_far us locn
+  = (namesFromProtoNames "type variable"
+	 (tyvars `zip` repeat src_loc)	`thenRn4`  \ tyvars2 ->
+
+	 -- tyvars2 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_string_name_pairs 	= extend tyvars2 []
+    	tv_env	    	    	= map (lookup tv_string_name_pairs) tyvars
+	tyvars2_in_orig_order	= map snd tv_env
+    in
+    returnRn4  (tv_env, tyvars2_in_orig_order)
+    ) {-Rn4-} gnfs ss errs_so_far us locn
+  where
+    extend :: [Name] -> [(FAST_STRING, Name)] -> [(FAST_STRING, Name)]
+    extend [] ss = ss
+    extend (name@(Short _ sname):names) ss
+      = (getOccurrenceName sname, name) : extend names ss
+
+    lookup :: [(FAST_STRING, Name)] -> ProtoName -> (ProtoName, Name)
+    lookup pairs tyvar_pn
+      = (tyvar_pn, assoc "mkTyVarNamesEnv" pairs (getOccurrenceName tyvar_pn))
+\end{code}
+
+\begin{code}
+lookupTyVarName :: TyVarNamesEnv -> ProtoName -> Rn4M Name
+lookupTyVarName env pname {-Rn4-} gnfs ss errs_so_far us locn
+  = (case (assoc_maybe env pname) of
+     Just name -> returnRn4 name
+     Nothing   -> getSrcLocRn4	`thenRn4` \ loc ->
+		  failButContinueRn4 (unboundName pname)
+			  (unknownNameErr "type variable" pname loc)
+    ) {-Rn4-} gnfs ss errs_so_far us locn
+  where
+    assoc_maybe [] _ = Nothing
+    assoc_maybe ((tv,xxx) : tvs) key
+      = if tv `eqProtoName` key then Just xxx else assoc_maybe tvs key
+\end{code}
+
+%************************************************************************
+%*									*
+\subsection{Error messages}
+%*									*
+%************************************************************************
+
+\begin{code}
+badClassOpErr clas op locn
+  = addErrLoc locn "" ( \ sty ->
+    ppBesides [ppChar '`', pprNonOp sty op, ppStr "' is not an operation of class `",
+	      ppr sty clas, ppStr "'."] )
+
+----------------------------
+-- dupNamesErr: from RnUtils
+
+---------------------------
+shadowedNameErr shadow locn
+  = addShortErrLocLine locn ( \ sty ->
+    ppBesides [ppStr "more than one value with the same name (shadowing): ",
+	ppr sty shadow] )
+
+------------------------------------------
+unknownNameErr descriptor undef_thing locn
+  = addShortErrLocLine locn ( \ sty ->
+    ppBesides [ppStr "undefined ", ppStr descriptor, ppStr ": ",
+	pprNonOp sty undef_thing] )
+\end{code}
diff --git a/ghc/compiler/rename/RnPass1.lhs b/ghc/compiler/rename/RnPass1.lhs
new file mode 100644
index 0000000000..53f4bb607c
--- /dev/null
+++ b/ghc/compiler/rename/RnPass1.lhs
@@ -0,0 +1,861 @@
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+%
+\section[RnPass1]{@RnPass1@: gather up imported information}
+
+See the @Rename@ module for a basic description of the renamer.
+
+\begin{code}
+#include "HsVersions.h"
+
+module RnPass1 (
+	rnModule1
+
+	-- for completeness
+    ) where
+
+import Ubiq{-uitous-}
+
+import HsSyn
+import HsPragmas	( DataPragmas(..) )
+import RdrHsSyn		-- ProtoName* instantiations...
+
+import Bag		( emptyBag, unitBag, snocBag, unionBags, Bag )
+import ErrUtils
+import FiniteMap	( lookupFM, listToFM, elementOf )
+import Maybes		( catMaybes, maybeToBool )
+import Name		( Name{-instances-} )
+import Outputable	( isAvarid, getLocalName, interpp'SP )
+import PprStyle		( PprStyle(..) )
+import Pretty
+import ProtoName	( mkPreludeProtoName, ProtoName(..) )
+import RnMonad12
+import RnUtils
+import Util		( lengthExceeds, panic )
+\end{code}
+
+%************************************************************************
+%*									*
+\subsection{Types and things used herein}
+%*									*
+%************************************************************************
+
+@AllIntDecls@ is the type returned from processing import statement(s)
+in the main module.
+
+\begin{code}
+type AllIntDecls = ([ProtoNameFixityDecl], [ProtoNameTyDecl],
+		    [ProtoNameClassDecl],  [ProtoNameInstDecl],
+		    [ProtoNameSig], Bag FAST_STRING)
+\end{code}
+
+The selective-import function @SelectiveImporter@ maps a @ProtoName@
+to something which indicates how much of the thing, if anything, is
+wanted by the importing module.
+\begin{code}
+type SelectiveImporter = ProtoName -> Wantedness
+
+data Wantedness
+  = Wanted
+  | NotWanted
+  | WantedWith (IE ProtoName)
+\end{code}
+
+The @ProtoNames@ supplied to these ``name functions'' are always
+@Unks@, unless they are fully-qualified names, which occur only in
+interface pragmas (and, therefore, never on the {\em definitions} of
+things).  That doesn't happen in @RnPass1@!
+\begin{code}
+type IntNameFun	  = ProtoName -> ProtoName
+type IntTCNameFun = ProtoName -> (ProtoName, IntNameFun)
+\end{code}
+
+%************************************************************************
+%*									*
+\subsection{First pass over the entire module}
+%*									*
+%************************************************************************
+
+This pass flattens out the declarations embedded within the interfaces
+which this module imports.  The result is a new module with no
+imports, but with more declarations.  The declarations which arose
+from the imported interfaces will have @ProtoNames@ with @Imp@
+constructors; the declarations in the body of this module are
+unaffected, so they will still be @Unk@'s.
+
+We import only the declarations from interfaces which are actually {\em
+used}.  This saves time later, because we don't need process the
+unused ones.
+
+\begin{code}
+rnModule1 :: PreludeNameMappers
+	  -> Bool		-- see use below
+	  -> ProtoNameHsModule
+	  -> Rn12M (ProtoNameHsModule, Bag FAST_STRING)
+
+rnModule1 pnf@(v_pnf, tc_pnf)
+	use_mentioned_vars_heuristic
+	(HsModule mod_name exports imports fixes
+		  ty_decls absty_sigs class_decls inst_decls specinst_sigs
+		  defaults binds _ src_loc)
+
+  =	-- slurp through the *body* of the module, collecting names of
+	-- mentioned *variables*, 3+ letters long & not prelude names.
+	-- Note: we *do* have to pick up top-level binders,
+	-- so we can check for conflicts with imported guys!
+    let
+	is_mentioned_fn = \ x -> True -- wimp way out
+{- OLD:
+	(uses_Mdotdot_in_exports, mentioned_vars)
+	  = getMentionedVars v_pnf exports fixes class_decls inst_decls binds
+
+	-- Using the collected "mentioned" variables, create an
+	-- "is-mentioned" function (:: FAST_STRING -> Bool), which gives
+	-- True if something is mentioned is in the list collected.
+	-- For more details, see under @selectAll@, notably the
+	-- handling of short (< 3 chars) names.
+
+	-- Note: this "is_mentioned" game doesn't work if the export
+	-- list includes any M.. constructs (because that mentions
+	-- variables *implicitly*, basically).  getMentionedVars tells
+	-- us this, and we act accordingly.
+
+	is_mentioned_maybe
+	  = lookupFM (listToFM
+		[ (x, panic "is_mentioned_fn")
+		| x <- mentioned_vars ++ needed_for_deriving ]
+		)
+	  where
+	    needed_for_deriving	-- is this a HACK or what?
+	      = [ SLIT("&&"),
+		  SLIT("."),
+		  SLIT("lex"),
+		  SLIT("map"),
+		  SLIT("not"),
+		  SLIT("readParen"),
+		  SLIT("showParen"),
+		  SLIT("showSpace__"),
+		  SLIT("showString")
+		]
+
+	is_mentioned_fn
+	  = if use_mentioned_vars_heuristic
+	    && not (uses_Mdotdot_in_exports)
+	    then \ x -> maybeToBool (is_mentioned_maybe x)
+	    else \ x -> True
+-}
+    in
+	-- OK, now do the business:
+    doImportedIfaces pnf is_mentioned_fn imports
+		 `thenRn12`  \ (int_fixes, int_ty_decls,
+				int_class_decls, int_inst_decls,
+				int_sigs, import_names) ->
+    let
+	inst_decls' = doRevoltingInstDecls tc_nf inst_decls
+    in
+    returnRn12
+	 ((HsModule mod_name
+		    exports imports -- passed along mostly for later checking
+		    (int_fixes ++ fixes)
+		    (int_ty_decls ++ ty_decls)
+		    absty_sigs
+		    (int_class_decls ++ class_decls)
+		    (int_inst_decls  ++ inst_decls')
+		    specinst_sigs
+		    defaults
+		    binds
+		    int_sigs
+		    src_loc),
+	  import_names)
+  where
+    -- This function just spots prelude names
+    tc_nf pname@(Unk s) = case (tc_pnf s) of
+			   Nothing   -> pname
+			   Just name -> Prel name
+
+    tc_nf other_pname	= panic "In tc_nf passed to doRevoltingInstDecls"
+	-- The only place where Imps occur is on Ids in unfoldings;
+	-- this function is only used on type-things.
+\end{code}
+
+Instance declarations in the module itself are treated in a horribly
+special way.  Because their class name and type constructor will be
+compared against imported ones in the second pass (to eliminate
+duplicate instance decls) we need to make Prelude classes and tycons
+appear as such.  (For class and type decls, the module can't be
+declaring a prelude class or tycon, so Prel and Unk things can just
+compare non-equal.)  This is a HACK.
+
+\begin{code}
+doRevoltingInstDecls :: IntNameFun -> [ProtoNameInstDecl] -> [ProtoNameInstDecl]
+
+doRevoltingInstDecls tc_nf decls
+  = map revolt_me decls
+  where
+    revolt_me (InstDecl cname ty binds True modname uprags pragma src_loc)
+      = InstDecl
+	    (tc_nf cname)		-- Look up the class
+	    (doIfacePolyType1 tc_nf ty)	-- Ditto the type
+	    binds			-- Binds unchanged
+	    True{-yes,defined in this module-}
+	    modname
+	    uprags
+	    pragma
+	    src_loc
+\end{code}
+
+%************************************************************************
+%*									*
+\subsection{Process a module's imported interfaces}
+%*									*
+%************************************************************************
+
+@doImportedIfaces@ processes the entire set of interfaces imported by the
+module being renamed.
+
+\begin{code}
+doImportedIfaces :: PreludeNameMappers
+	      -> (FAST_STRING -> Bool)
+	      -> [ProtoNameImportedInterface]
+	      -> Rn12M AllIntDecls
+
+doImportedIfaces pnfs is_mentioned_fn []
+  = returnRn12 ( [{-fixities-}],  [{-tydecls-}], [{-clasdecls-}],
+		 [{-instdecls-}], [{-sigs-}], emptyBag )
+
+doImportedIfaces pnfs is_mentioned_fn (iface:ifaces)
+  = doOneIface  pnfs is_mentioned_fn iface
+			 `thenRn12` \ (ifixes1, itd1, icd1, iid1, isd1, names1) ->
+
+    doImportedIfaces pnfs is_mentioned_fn ifaces
+			 `thenRn12` \ (ifixes2, itd2, icd2, iid2, isd2, names2) ->
+
+    returnRn12 (ifixes1 ++ ifixes2,
+		itd1 ++ itd2,
+		icd1 ++ icd2,
+		iid1 ++ iid2,
+		isd1 ++ isd2,
+		names1 `unionBags` names2)
+\end{code}
+
+\begin{code}
+doOneIface :: PreludeNameMappers
+	   -> (FAST_STRING -> Bool)
+	   -> ProtoNameImportedInterface
+	   -> Rn12M AllIntDecls
+
+doOneIface _ _ (ImportMod _ True{-qualified-} _ _)
+  = panic "RnPass1.doOneIface:can't grok `qualified'"
+
+doOneIface _ _ (ImportMod _ _ (Just _) _)
+  = panic "RnPass1.doOneIface:can't grok `as' module (blech)"
+
+doOneIface pnfs is_mentioned_fn (ImportMod iface qual asmod Nothing{-all-})
+  = doIface1 pnfs (selectAll is_mentioned_fn) iface
+
+doOneIface pnfs _ (ImportMod iface qual asmod (Just (False{-unhidden-}, ies)))
+  = doIface1 pnfs si_fun iface
+  where
+    -- the `selective import' function should not be applied
+    -- to the Imps that occur on Ids in unfoldings.
+
+    si_fun (Unk    n) = check_ie n ies
+    si_fun (Qunk _ n) = check_ie n ies
+
+    check_ie name [] = NotWanted
+    check_ie name (ie:ies)
+      = case ie of
+	  IEVar (Unk n)	     | name == n -> Wanted
+	  IEThingAbs (Unk n) | name == n -> WantedWith ie
+	  IEThingAll (Unk n) | name == n -> WantedWith ie
+	  IEModuleContents _ -> panic "Module.. in import list?"
+	  other		     -> check_ie name ies
+
+doOneIface pnfs _ (ImportMod iface qual asmod (Just (True{-hidden-}, ies)))
+  = doIface1 pnfs si_fun iface
+  where
+    -- see comment above:
+
+    si_fun x | n `elementOf` entity_info = NotWanted
+	     | otherwise		 = Wanted
+      where
+	n = case x of { Unk s -> s; Qunk _ s -> s }
+
+    entity_info = getImportees ies
+\end{code}
+
+@selectAll@ ``normally'' creates an @SelectiveImporter@ that declares
+everything from an interface to be @Wanted@.  We may, however, pass
+in a more discriminating @is_mentioned_fn@ (returns @True@ if the
+named entity is mentioned in the body of the module in question), which
+can be used to trim off junk from an interface.
+
+For @selectAll@ to say something is @NotWanted@, it must be a
+variable, it must not be in the collected-up list of mentioned
+variables (checked with @is_mentioned_fn@), and it must be three chars
+or longer.
+
+And, of course, we mustn't forget to take account of renaming!
+
+ADR Question: What's so magical about names longer than 3 characters?
+Why would we want to keep long names which aren't mentioned when we're
+quite happy to throw away short names that aren't mentioned?
+
+\begin{code}
+selectAll :: (FAST_STRING -> Bool) -> SelectiveImporter
+
+selectAll is_mentioned_fn n
+  = let
+	rn_str = case n of { Unk s -> s ; Qunk _ s -> s }
+    in
+    if (isAvarid rn_str)
+    && (not (is_mentioned_fn rn_str))
+    && (_UNPK_ rn_str `lengthExceeds` 2)
+    then NotWanted
+    else Wanted
+\end{code}
+
+
+%************************************************************************
+%*									*
+\subsection{First pass over a particular interface}
+%*									*
+%************************************************************************
+
+
+@doIface1@ handles a specific interface. First it looks at the
+interface imports, creating a bag that maps local names back to their
+original names, from which it makes a function that does the same. It
+then uses this function to create a triple of bags for the interface
+type, class and value declarations, in which local names have been
+mapped back into original names.
+
+Notice that @mkLocalNameFun@ makes two different functions. The first
+is the name function for the interface. This takes a local name and
+provides an original name for any name in the interface by using
+either of:
+\begin{itemize}
+\item
+the original name produced by the renaming function;
+\item
+the local name in the interface and the interface name.
+\end{itemize}
+
+The function @doIfaceImports1@ receives two association lists which will
+be described at its definition.
+
+\begin{code}
+doIface1 :: PreludeNameMappers
+	 -> SelectiveImporter
+	 -> ProtoNameInterface
+	 -> Rn12M AllIntDecls
+
+doIface1 (v_pnf, tc_pnf) sifun
+       (Interface i_name import_decls fix_decls ty_decls class_decls
+		    inst_decls sig_decls anns)
+
+  = doIfaceImports1 (panic "i_name"{-i_name-}) import_decls	`thenRn12` \ (v_bag, tc_bag) ->
+    do_body (v_bag, tc_bag)
+  where
+    do_body (v_bag, tc_bag)
+      = report_all_errors			`thenRn12` \ _ ->
+
+	doIfaceTyDecls1    sifun full_tc_nf ty_decls	`thenRn12` \ ty_decls' ->
+
+	doIfaceClassDecls1 sifun full_tc_nf class_decls  `thenRn12` \ class_decls' ->
+
+	let sig_decls'	= doIfaceSigs1      sifun v_nf tc_nf sig_decls
+	    fix_decls'	= doIfaceFixes1     sifun v_nf       fix_decls
+	    inst_decls'	= doIfaceInstDecls1 sifun      tc_nf inst_decls
+	in
+	returnRn12 (fix_decls', ty_decls', class_decls', inst_decls', sig_decls', unitBag i_name)
+      where
+	v_dups  :: [[(FAST_STRING, ProtoName)]]
+	tc_dups :: [[(FAST_STRING, (ProtoName, IntNameFun))]]
+
+	(imp_v_nf, v_dups)   = mkNameFun v_bag
+	(imp_tc_nf, tc_dups) = mkNameFun tc_bag
+
+	v_nf :: IntNameFun
+	v_nf (Unk s) = case v_pnf s of
+			 Just n	 -> mkPreludeProtoName n
+			 Nothing -> case imp_v_nf s of
+				      Just n  -> n
+				      Nothing -> Imp i_name s [i_name] s
+
+		-- used for (..)'d parts of prelude datatype/class decls
+	prel_con_or_op_nf  :: FAST_STRING{-module name-}-> IntNameFun
+	prel_con_or_op_nf m (Unk s)
+	  = case v_pnf s of
+	      Just n  -> mkPreludeProtoName n
+	      Nothing -> Imp m s [m] s
+			 -- Strictly speaking, should be *no renaming* here, folks
+
+		-- used for non-prelude constructors/ops/fields
+	local_con_or_op_nf :: IntNameFun
+	local_con_or_op_nf (Unk s) = Imp i_name s [i_name] s
+
+	full_tc_nf :: IntTCNameFun
+	full_tc_nf (Unk s)
+	  = case tc_pnf s of
+	      Just n  -> (mkPreludeProtoName n,
+			  let
+			      mod = fst (getOrigName n)
+			  in
+			  prel_con_or_op_nf mod)
+
+	      Nothing -> case imp_tc_nf s of
+			  Just pair -> pair
+			  Nothing   -> (Imp i_name s [i_name] s,
+					local_con_or_op_nf)
+
+	tc_nf = fst . full_tc_nf
+
+	-- ADR: commented out next new lines because I don't believe
+	-- ADR: the check is useful or required by the Standard. (It
+	-- ADR: also messes up the interpreter.)
+
+	tc_errs = [] -- map (map (fst . snd)) tc_dups
+		  -- Ugh! Just keep the dup'd protonames
+	v_errs	= [] -- map (map snd) v_dups
+		  -- Ditto
+
+	report_all_errors
+	  = mapRn12 (addErrRn12 . duplicateImportsInInterfaceErr (_UNPK_ i_name))
+		    (tc_errs ++ v_errs)
+\end{code}
+
+
+%************************************************************************
+%*									*
+\subsection{doIfaceImports1}
+%*									*
+%************************************************************************
+
+@ImportNameBags@ is a pair of bags (one for values, one for types and
+classes) which specify the new names brought into scope by some
+import declarations in an interface.
+
+\begin{code}
+type ImportNameBags = (Bag (FAST_STRING, ProtoName),
+		       Bag (FAST_STRING, (ProtoName, IntNameFun))
+		      )
+\end{code}
+
+\begin{code}
+doIfaceImports1
+	:: FAST_STRING			-- name of module whose interface we're doing
+	-> [IfaceImportDecl ProtoName]
+	-> Rn12M ImportNameBags
+
+doIfaceImports1 _  [] = returnRn12 (emptyBag, emptyBag)
+
+doIfaceImports1 int_mod_name (imp_decl1 : rest)
+  = do_decl			 imp_decl1  `thenRn12` \ (vb1, tcb1) ->
+    doIfaceImports1 int_mod_name rest	    `thenRn12` \ (vb2, tcb2) ->
+    returnRn12 (vb1 `unionBags` vb2, tcb1 `unionBags` tcb2)
+  where
+    do_decl (IfaceImportDecl orig_mod_name imports src_loc)
+      =		-- Look at the renamings to get a suitable renaming function
+	doRenamings{-not really-} int_mod_name orig_mod_name
+				    `thenRn12` \ (orig_to_pn, local_to_pn) ->
+
+	    -- Now deal with one import at a time, combining results.
+	returnRn12 (
+	  foldl (doIfaceImport1 orig_to_pn local_to_pn)
+		(emptyBag, emptyBag)
+		imports
+	)
+\end{code}
+
+@doIfaceImport1@ takes a list of imports and the pair of renaming functions,
+returning a bag which maps local names to original names.
+
+\begin{code}
+doIfaceImport1 :: ( ProtoName	    -- Original local name
+		 -> (FAST_STRING,   -- Local name in this interface
+		     ProtoName)	    -- Its full protoname
+		)
+
+	     -> IntNameFun	    -- Local name to ProtoName; use for
+				    --   constructors and class ops
+
+	     -> ImportNameBags	    -- Accumulator
+	     -> (IE ProtoName)	    -- An item in the import list 
+	     -> ImportNameBags
+
+doIfaceImport1 orig_to_pn local_to_pn (v_bag, tc_bag) (IEVar orig_name)
+  = (v_bag `snocBag` (orig_to_pn orig_name), tc_bag)
+
+doIfaceImport1 orig_to_pn local_to_pn acc (IEThingAbs orig_name)
+  = int_import1_help orig_to_pn local_to_pn acc orig_name
+
+doIfaceImport1 orig_to_pn local_to_pn acc (IEThingAll orig_name)
+  = int_import1_help orig_to_pn local_to_pn acc orig_name
+
+-- the next ones will go away with 1.3:
+{- OLD:
+doIfaceImport1 orig_to_pn local_to_pn acc (IEConWithCons orig_name _)
+  = int_import1_help orig_to_pn local_to_pn acc orig_name
+
+doIfaceImport1 orig_to_pn local_to_pn acc (IEClsWithOps orig_name _)
+  = int_import1_help orig_to_pn local_to_pn acc orig_name
+-}
+
+doIfaceImport1 orig_to_pn local_to_pn (v_bag, tc_bag) other
+  = panic "RnPass1: strange import decl"
+
+-- Little help guy...
+
+int_import1_help orig_to_pn local_to_pn (v_bag, tc_bag) orig_name
+  = case (orig_to_pn orig_name) of { (str, o_name) ->
+    (v_bag, tc_bag `snocBag` (str, (o_name, local_to_pn)))
+    }
+\end{code}
+
+
+The renaming-processing code.  It returns two name-functions. The
+first maps the {\em original} name for an entity onto a @ProtoName@
+--- it is used when running over the list of things to be imported.
+The second maps the {\em local} name for a constructor or class op
+back to its original name --- it is used when scanning the RHS of
+a @data@ or @class@ decl.
+
+It can produce errors, if there is a domain clash on the renamings.
+
+\begin{code}
+doRenamings :: FAST_STRING	-- Name of the module whose interface we're working on
+	    -> FAST_STRING	-- Original-name module for these renamings
+	    -> Rn12M
+		((ProtoName	     -- Original local name to...
+		    -> (FAST_STRING, -- ... Local name in this interface
+			ProtoName)   -- ... Its full protoname
+		 ),
+		 IntNameFun)	     -- Use for constructors, class ops
+
+doRenamings int_mod orig_mod
+  = returnRn12 (
+      \ (Unk s) ->
+	let
+	    result = (s, Imp orig_mod s [int_mod] s)
+	in
+	result
+	,
+
+      \ (Unk s) ->
+	let
+	    result = Imp orig_mod s [int_mod] s
+	in
+	result
+    )
+\end{code}
+
+%************************************************************************
+%*									*
+\subsection{Type declarations}
+%*									*
+%************************************************************************
+
+@doIfaceTyDecls1@ uses the `name function' to map local tycon names into
+original names, calling @doConDecls1@ to do the same for the
+constructors. @doTyDecls1@ is used to do both module and interface
+type declarations.
+
+\begin{code}
+doIfaceTyDecls1 :: SelectiveImporter
+	      -> IntTCNameFun
+	      -> [ProtoNameTyDecl]
+	      -> Rn12M [ProtoNameTyDecl]
+
+doIfaceTyDecls1 sifun full_tc_nf ty_decls
+  = mapRn12 do_decl ty_decls `thenRn12` \ decls_maybe ->
+    returnRn12 (catMaybes decls_maybe)
+  where
+    do_decl (TySynonym tycon tyvars monoty src_loc)
+      = let
+	    full_thing = returnRn12 (Just ty_decl')
+	in
+	case (sifun tycon) of
+	  NotWanted		    -> returnRn12 Nothing
+	  Wanted		    -> full_thing
+	  WantedWith (IEThingAll _) -> full_thing
+
+	  WantedWith weird_ie	    -> full_thing
+      where
+	(tycon_name,_) = full_tc_nf tycon
+	tc_nf	= fst . full_tc_nf
+	monoty'	= doIfaceMonoType1 tc_nf monoty
+	ty_decl' = TySynonym tycon_name tyvars monoty' src_loc
+
+    do_decl (TyData context tycon tyvars condecls derivs pragmas src_loc)
+      = do_data context tycon condecls derivs pragmas src_loc `thenRn12` \ done_data ->
+	case done_data of
+	  Nothing -> returnRn12 Nothing
+	  Just (context', tycon', condecls', derivs', pragmas') ->
+	     returnRn12 (Just (TyData context' tycon' tyvars condecls' derivs' pragmas' src_loc))
+
+    do_decl (TyNew context tycon tyvars condecl derivs pragmas src_loc)
+      = do_data context tycon condecl derivs pragmas src_loc `thenRn12` \ done_data ->
+	case done_data of
+	  Nothing -> returnRn12 Nothing
+	  Just (context', tycon', condecl', derivs', pragmas') ->
+	     returnRn12 (Just (TyNew context' tycon' tyvars condecl' derivs' pragmas' src_loc))
+
+    --------------------------------------------
+    do_data context tycon condecls derivs (DataPragmas hidden_cons specs) src_loc
+      = let
+	    full_thing = Just (context', tycon_name, condecls', deriv', (pragmas' False))
+	    abs_thing  = Just (context', tycon_name, [],        deriv', (pragmas' True))
+	in
+	case (sifun tycon) of
+	  NotWanted			-> returnRn12 Nothing
+	  Wanted			-> returnRn12 full_thing
+	  WantedWith (IEThingAll _)	-> returnRn12 full_thing
+	  WantedWith (IEThingAbs _)	-> returnRn12 abs_thing
+
+	  WantedWith really_weird_ie -> -- probably a typo in the pgm
+	    addErrRn12 (weirdImportExportConstraintErr
+			tycon really_weird_ie src_loc) `thenRn12` \ _ ->
+	    returnRn12 full_thing
+      where
+	(tycon_name, constrfield_nf) = full_tc_nf tycon
+	tc_nf	    		     = fst . full_tc_nf
+
+	condecls'    = map (do_condecl constrfield_nf tc_nf) condecls
+	hidden_cons' = map (do_condecl constrfield_nf tc_nf) hidden_cons
+
+	pragmas' invent_hidden
+    	  = DataPragmas (if null hidden_cons && invent_hidden
+			 then condecls'  -- if importing abstractly but condecls were
+			                 -- exported we add them to the data pragma
+			 else hidden_cons')
+			specs {- ToDo: do_specs -}
+
+	context'    = doIfaceContext1 tc_nf context
+	deriv'	    = case derivs of
+			Nothing -> Nothing
+			Just ds -> panic "doIfaceTyDecls1:derivs" -- Just (map tc_nf ds)
+								  -- rename derived classes
+
+    --------------------------------------------
+    -- one name fun for the data constructor, another for the type:
+
+    do_condecl cf_nf tc_nf (ConDecl name tys src_loc)
+      = ConDecl (cf_nf name) (map (do_bang tc_nf) tys) src_loc
+
+    do_condecl cf_nf tc_nf (ConOpDecl ty1 op ty2 src_loc)
+      = ConOpDecl (do_bang tc_nf ty1) (cf_nf op) (do_bang tc_nf ty2) src_loc
+
+    do_condecl cf_nf tc_nf (NewConDecl name ty src_loc)
+      = NewConDecl (cf_nf name) (doIfaceMonoType1 tc_nf ty) src_loc
+
+    do_condecl cf_nf tc_nf (RecConDecl con fields src_loc)
+      = RecConDecl (cf_nf con) (map do_field fields) src_loc
+      where
+	do_field (var, ty) = (cf_nf var, do_bang tc_nf ty)
+
+    --------------------------------------------
+    do_bang tc_nf (Banged   ty) = Banged   (doIfaceMonoType1 tc_nf ty)
+    do_bang tc_nf (Unbanged ty) = Unbanged (doIfaceMonoType1 tc_nf ty)
+\end{code}
+
+%************************************************************************
+%*									*
+\subsection{Class declarations}
+%*									*
+%************************************************************************
+
+@doIfaceClassDecls1@ uses the `name function' to map local class names into
+original names, calling @doIfaceClassOp1@ to do the same for the
+class operations. @doClassDecls1@ is used to process both module and
+interface class declarations.
+
+\begin{code}
+doIfaceClassDecls1 ::  SelectiveImporter
+		 -> IntTCNameFun
+		 -> [ProtoNameClassDecl]
+		 -> Rn12M [ProtoNameClassDecl]
+
+doIfaceClassDecls1 sifun full_tc_nf clas_decls
+  = mapRn12 do_decl clas_decls `thenRn12` \ decls_maybe ->
+    returnRn12 (catMaybes decls_maybe)
+  where
+    do_decl (ClassDecl ctxt cname tyvar sigs bs@EmptyMonoBinds prags locn)
+				     -- No defaults in interface
+      = let
+	    full_thing = returnRn12 (Just class_decl')
+	in
+	case (sifun cname) of
+	  NotWanted			-> returnRn12 Nothing
+	  Wanted			-> full_thing
+	  WantedWith (IEThingAll _)	-> full_thing
+	  -- ToDo: add checking of IEClassWithOps
+	  WantedWith really_weird_ie	-> -- probably a typo in the pgm
+	    addErrRn12 (weirdImportExportConstraintErr
+			cname really_weird_ie locn) `thenRn12` \ _ ->
+	    full_thing
+      where
+	(clas, op_nf) = full_tc_nf cname
+	tc_nf = fst . full_tc_nf
+
+	sigs' = map (doIfaceClassOp1 op_nf tc_nf) sigs
+	ctxt' = doIfaceContext1 tc_nf ctxt
+
+	class_decl'     = ClassDecl ctxt' clas tyvar sigs' bs prags locn
+	abs_class_decl' = ClassDecl ctxt' clas tyvar []    bs prags locn
+\end{code}
+
+\begin{code}
+doIfaceClassOp1 :: IntNameFun	-- Use this for the class ops
+	      -> IntNameFun	-- Use this for the types
+	      -> ProtoNameClassOpSig
+	      -> ProtoNameClassOpSig
+
+doIfaceClassOp1 op_nf tc_nf (ClassOpSig v ty pragma src_loc)
+  = ClassOpSig (op_nf v) (doIfacePolyType1 tc_nf ty) pragma src_loc
+\end{code}
+
+%************************************************************************
+%*									*
+\subsection{Instance declarations}
+%*									*
+%************************************************************************
+
+We select the instance decl if either the class or the type constructor
+are selected.
+
+\begin{code}
+doIfaceInstDecls1 :: SelectiveImporter
+		-> IntNameFun
+		-> [ProtoNameInstDecl]
+		-> [ProtoNameInstDecl]
+
+doIfaceInstDecls1 si tc_nf inst_decls
+  = catMaybes (map do_decl inst_decls)
+  where
+    do_decl (InstDecl cname ty EmptyMonoBinds False modname uprags pragmas src_loc)
+      = case (si cname, tycon_reqd) of
+	  (NotWanted, NotWanted) -> Nothing
+	  _			 -> Just inst_decl'
+     where
+       ty'	= doIfacePolyType1 tc_nf ty
+
+       inst_decl' = InstDecl (tc_nf cname) ty' EmptyMonoBinds False modname uprags pragmas src_loc
+
+       tycon_reqd = _trace "RnPass1.tycon_reqd" NotWanted
+{- LATER:
+	 = case getNonPrelOuterTyCon ty of
+	     Nothing -> NotWanted    -- Type doesn't have a user-defined tycon
+				     -- at its outermost level
+	     Just tycon -> si tycon  -- It does, so look up in the si-fun
+-}
+\end{code}
+
+%************************************************************************
+%*									*
+\subsection{Signature declarations}
+%*									*
+%************************************************************************
+
+@doIfaceSigs1@ uses the name function to create a bag that
+maps local names into original names.
+
+NB: Can't have user-pragmas & other weird things in interfaces.
+
+\begin{code}
+doIfaceSigs1 :: SelectiveImporter -> IntNameFun -> IntNameFun
+	   -> [ProtoNameSig]
+	   -> [ProtoNameSig]
+
+doIfaceSigs1 si v_nf tc_nf sigs
+  = catMaybes (map do_sig sigs)
+  where
+    do_sig (Sig v ty pragma src_loc)
+      = case (si v) of
+	  NotWanted -> Nothing
+	  Wanted    -> Just (Sig (v_nf v) (doIfacePolyType1 tc_nf ty) pragma src_loc)
+	  -- WantedWith doesn't make sense
+\end{code}
+
+
+%************************************************************************
+%*									*
+\subsection{Fixity declarations}
+%*									*
+%************************************************************************
+
+\begin{code}
+doIfaceFixes1 :: SelectiveImporter -> IntNameFun
+	    -> [ProtoNameFixityDecl]
+	    -> [ProtoNameFixityDecl]
+
+doIfaceFixes1 si vnf fixities
+  = catMaybes (map do_fixity fixities)
+  where
+    do_fixity (InfixL name i) = do_one InfixL name i
+    do_fixity (InfixR name i) = do_one InfixR name i
+    do_fixity (InfixN name i) = do_one InfixN name i
+
+    do_one con name i
+      = case si name of
+	  Wanted    -> Just (con (vnf name) i)
+	  NotWanted -> Nothing
+\end{code}
+
+
+%************************************************************************
+%*									*
+\subsection{doContext, MonoTypes, MonoType, Polytype}
+%*									*
+%************************************************************************
+
+\begin{code}
+doIfacePolyType1 :: IntNameFun -> ProtoNamePolyType -> ProtoNamePolyType
+
+doIfacePolyType1 tc_nf (HsPreForAllTy ctxt ty)
+  = HsPreForAllTy (doIfaceContext1 tc_nf ctxt) (doIfaceMonoType1 tc_nf ty)
+
+doIfacePolyType1 tc_nf (HsForAllTy tvs ctxt ty)
+  = HsForAllTy tvs (doIfaceContext1 tc_nf ctxt) (doIfaceMonoType1 tc_nf ty)
+\end{code}
+
+\begin{code}
+doIfaceContext1 :: IntNameFun -> ProtoNameContext -> ProtoNameContext
+doIfaceContext1 tc_nf  context = [(tc_nf clas, tyvar) | (clas,tyvar) <- context]
+\end{code}
+
+
+\begin{code}
+doIfaceMonoType1 :: IntNameFun -> ProtoNameMonoType -> ProtoNameMonoType
+
+doIfaceMonoType1 tc_nf tv@(MonoTyVar _) = tv
+
+doIfaceMonoType1 tc_nf (MonoListTy ty)
+  = MonoListTy (doIfaceMonoType1 tc_nf ty)
+
+doIfaceMonoType1 tc_nf (MonoFunTy ty1 ty2)
+  = MonoFunTy (doIfaceMonoType1 tc_nf ty1) (doIfaceMonoType1 tc_nf ty2)
+
+doIfaceMonoType1 tc_nf (MonoTupleTy tys)
+  = MonoTupleTy (map (doIfaceMonoType1 tc_nf) tys)
+
+doIfaceMonoType1 tc_nf (MonoTyApp name tys)
+  = MonoTyApp (tc_nf name) (map (doIfaceMonoType1 tc_nf) tys)
+\end{code}
+
+%************************************************************************
+%*									*
+\subsection{Error messages}
+%*									*
+%************************************************************************
+
+\begin{code}
+duplicateImportsInInterfaceErr iface dups
+  = panic "duplicateImportsInInterfaceErr: NOT DONE YET?"
+
+weirdImportExportConstraintErr thing constraint locn
+  = addShortErrLocLine locn ( \ sty ->
+    ppBesides [ppStr "Illegal import/export constraint on `",
+	       ppr sty thing,
+	       ppStr "': ", ppr PprForUser constraint])
+\end{code}
diff --git a/ghc/compiler/rename/RnPass2.lhs b/ghc/compiler/rename/RnPass2.lhs
new file mode 100644
index 0000000000..3feb281dbd
--- /dev/null
+++ b/ghc/compiler/rename/RnPass2.lhs
@@ -0,0 +1,845 @@
+%
+% (c) The GRASP Project, Glasgow University, 1992-1996
+%
+\section[RnPass2]{Second renaming pass: boil down to non-duplicated info}
+
+\begin{code}
+#include "HsVersions.h"
+
+module RnPass2 (
+	rnModule2
+
+	-- for completeness
+    ) where
+
+import Ubiq{-uitous-}
+
+import HsSyn
+import HsCore
+import HsPragmas
+import RdrHsSyn
+import RnMonad12
+
+import Bag		( Bag )
+import IdInfo		( DeforestInfo(..), Demand{-instances-}, UpdateInfo{-instance-} )
+import Outputable	( Outputable(..){-instances-} )
+import PprStyle		( PprStyle(..) )
+import Pretty		-- quite a bit of it
+import ProtoName	( cmpProtoName, eqProtoName, eqByLocalName,
+			  elemProtoNames, elemByLocalNames,
+			  ProtoName(..)
+			)
+import RnUtils		( dupNamesErr )
+import SrcLoc		( mkUnknownSrcLoc, SrcLoc{-instances-} )
+import Util		( isIn, equivClasses,
+			  panic, panic#, pprTrace, assertPanic
+			)
+\end{code}
+
+This pass removes duplicate declarations.  Duplicates can arise when
+two imported interface have a signature (or whatever) for the same
+thing.	We check that the two are consistent and then drop one.
+
+For preference, if one is declared in this module and the other is
+imported, we keep the former; in the case of an instance decl or type
+decl, the local version has a lot more information which we must not
+lose!
+
+Similarly, if one has interesting pragmas and one has not, we keep the
+former.
+
+The notion of ``duplicate'' includes an imported signature and a
+binding in this module.	 In this case, the signature is discarded.
+See note below about how this should be improved.
+
+ToDo: There are still known cases in which we blithely consider two
+declarations to be ``duplicates'' and we then select one of them, {\em
+without} actually checking that they contain the same information!
+[WDP 93/8/16] [Improved, at least WDP 93/08/26]
+
+\begin{code}
+rnModule2  :: ProtoNameHsModule -> Rn12M ProtoNameHsModule
+
+rnModule2 (HsModule mod_name exports imports fixes
+	    ty_decls absty_sigs class_decls inst_decls specinst_sigs
+	    defaults binds int_sigs src_loc)
+
+  = uniquefy mod_name cmpFix selFix fixes
+				`thenRn12` \ fixes ->
+
+    uniquefy mod_name cmpTys selTys ty_decls
+				`thenRn12` \ ty_decls ->
+
+    uniquefy mod_name cmpTySigs selTySigs absty_sigs
+				`thenRn12` \ absty_sigs ->
+
+    uniquefy mod_name cmpClassDecl selClass class_decls
+				`thenRn12` \ class_decls ->
+
+    uniquefy mod_name cmpInst selInst inst_decls
+				`thenRn12` \ inst_decls ->
+
+    uniquefy mod_name cmpSpecInstSigs selSpecInstSigs specinst_sigs
+				`thenRn12` \ specinst_sigs ->
+
+	-- From the imported signatures discard any which are for
+	-- variables bound in this module.
+	-- But, be wary of those that *clash* with those for this
+	-- module...
+	-- Note that we want to do this properly later (ToDo) because imported
+	-- signatures may differ from those declared in the module itself.
+
+    rm_sigs_for_here mod_name int_sigs
+				`thenRn12` \ non_here_int_sigs ->
+
+    uniquefy mod_name cmpSig selSig non_here_int_sigs
+				 `thenRn12` \ int_sigs ->
+    returnRn12
+	(HsModule mod_name
+		  exports   -- export and import lists are passed along
+		  imports   -- for checking in RnPass3; no other reason
+		  fixes
+		  ty_decls
+		  absty_sigs
+		  class_decls
+		  inst_decls
+		  specinst_sigs
+		  defaults
+		  binds
+		  int_sigs
+		  src_loc)
+  where
+    top_level_binders = collectTopLevelBinders binds
+
+    rm_sigs_for_here :: FAST_STRING -> [ProtoNameSig] -> Rn12M [ProtoNameSig]
+	-- NB: operates only on interface signatures, so don't
+	-- need to worry about user-pragmas, etc.
+
+    rm_sigs_for_here mod_name [] = returnRn12 []
+
+    rm_sigs_for_here mod_name (sig@(Sig name _ _ src_loc) : more_sigs)
+      = rm_sigs_for_here mod_name more_sigs `thenRn12` \ rest_sigs ->
+
+	if  not (name `elemByLocalNames` top_level_binders) then -- no name clash...
+	    returnRn12 (sig : rest_sigs)
+
+	else -- name clash...
+	    if	name `elemProtoNames` top_level_binders
+	     && name_for_this_module name then
+		-- the very same thing; just drop it
+		returnRn12 rest_sigs
+	    else
+		-- a different thing with the same name (due to renaming?)
+		-- ToDo: locations need improving
+		report_dup "(renamed?) variable"
+			name src_loc name mkUnknownSrcLoc
+			rest_sigs
+      where
+	 name_for_this_module (Imp m _ _ _) = m == mod_name
+	 name_for_this_module other	    = True
+\end{code}
+
+%************************************************************************
+%*									*
+\subsection[FixityDecls-RnPass2]{Functions for @FixityDecls@}
+%*									*
+%************************************************************************
+
+\begin{code}
+cmpFix :: ProtoNameFixityDecl -> ProtoNameFixityDecl -> TAG_
+
+cmpFix (InfixL n1 i1) (InfixL n2 i2) = n1 `cmpProtoName` n2
+cmpFix (InfixL n1 i1) other	     = LT_
+cmpFix (InfixR n1 i1) (InfixR n2 i2) = n1 `cmpProtoName` n2
+cmpFix (InfixR n1 i1) (InfixN n2 i2) = LT_
+cmpFix (InfixN n1 i1) (InfixN n2 i2) = n1 `cmpProtoName` n2
+cmpFix a	      b		     = GT_
+\end{code}
+
+We are pretty un-fussy about which FixityDecl we keep.
+
+\begin{code}
+selFix :: ProtoNameFixityDecl -> ProtoNameFixityDecl -> Rn12M ProtoNameFixityDecl
+selFix f1 f2 = returnRn12 f1
+\end{code}
+
+%************************************************************************
+%*									*
+\subsection[TyDecls-RnPass2]{Functions for @TyDecls@}
+%*									*
+%************************************************************************
+
+\begin{code}
+cmpTys :: ProtoNameTyDecl -> ProtoNameTyDecl -> TAG_
+
+cmpTys (TyData _ n1 _ _ _ _ _) (TyData _ n2 _ _ _ _ _)  = cmpProtoName n1 n2
+cmpTys (TyNew  _ n1 _ _ _ _ _) (TyNew  _ n2 _ _ _ _ _)  = cmpProtoName n1 n2
+cmpTys (TySynonym n1 _ _ _)    (TySynonym n2 _ _ _)	= cmpProtoName n1 n2
+cmpTys a b
+  = let tag1 = tag a
+	tag2 = tag b
+    in
+    if tag1 _LT_ tag2 then LT_ else GT_
+  where
+    tag (TyData    _ _ _ _ _ _ _) = (ILIT(1) :: FAST_INT)
+    tag (TyNew     _ _ _ _ _ _ _) = ILIT(2)
+    tag (TySynonym _ _ _ _)	  = ILIT(3)
+\end{code}
+
+\begin{code}
+selTys :: ProtoNameTyDecl -> ProtoNameTyDecl
+       -> Rn12M ProtoNameTyDecl
+
+-- Note: we could check these more closely.
+-- NB: It would be a mistake to cross-check derivings,
+-- because we don't preserve those in interfaces.
+
+selTys td1@(TyData c name1 tvs cons1 ds pragmas1 locn1)
+       td2@(TyData _ name2 _   cons2 _	pragmas2 locn2)
+  = selByBetterName "algebraic datatype"
+       name1 pragmas1 locn1 td1
+       name2 pragmas2 locn2 td2
+       (\ p -> TyData c name1 tvs cons1 ds p locn1)
+       chooser_TyData
+
+selTys td1@(TyNew c name1 tvs con1 ds pragmas1 locn1)
+       td2@(TyNew _ name2 _   con2 _  pragmas2 locn2)
+  = selByBetterName "algebraic newtype"
+       name1 pragmas1 locn1 td1
+       name2 pragmas2 locn2 td2
+       (\ p -> TyNew c name1 tvs con1 ds p locn1)
+       chooser_TyNew
+
+selTys ts1@(TySynonym name1 tvs expand1 locn1)
+       ts2@(TySynonym name2 _	expand2 locn2)
+  = selByBetterName "type synonym"
+	name1 bottom locn1 ts1
+	name2 bottom locn2 ts2
+	(\ p -> TySynonym name1 tvs expand1 locn1)
+	chooser_TySynonym
+  where
+    bottom = panic "RnPass2:selTys:TySynonym"
+\end{code}
+
+If only one is ``abstract'' (no condecls), we take the other.
+
+Next, we check that they don't have differing lists of data
+constructors (what a disaster if those get through...); then we do a
+similar thing using pragmatic info.
+
+\begin{code}
+chooser_TyNew  wout pragmas1 locn1 td1@(TyNew _ name1 _ con1 _ _ _)
+		    pragmas2 locn2 td2@(TyNew _ name2 _ con2 _ _ _)
+  = panic "RnPass2:chooser_TyNew"
+
+
+chooser_TyData wout pragmas1 locn1 td1@(TyData _ name1 _ cons1 _ _ _)
+		    pragmas2 locn2 td2@(TyData _ name2 _ cons2 _ _ _)
+  = let
+	td1_abstract = null cons1
+	td2_abstract = null cons2
+
+	choose_by_pragmas = sub_chooser pragmas1 pragmas2
+    in
+    if td1_abstract && td2_abstract then
+	choose_by_pragmas
+
+    else if td1_abstract then
+	returnRn12 td2
+
+    else if td2_abstract then
+	returnRn12 td1
+
+    else if not (eqConDecls cons1 cons2) then
+    	report_dup "algebraic datatype (mismatched data constuctors)"
+    		    name1 locn1 name2 locn2 td1
+    else
+	sub_chooser pragmas1 pragmas2
+  where
+    sub_chooser (DataPragmas [] []) b = returnRn12 (wout b)
+    sub_chooser a (DataPragmas [] []) = returnRn12 (wout a)
+    sub_chooser a@(DataPragmas cons1 specs1) (DataPragmas cons2 specs2)
+      = if not (eqConDecls cons1 cons2) then
+	    pprTrace "Mismatched info in DATA pragmas:\n"
+		     (ppAbove (ppr PprDebug cons1) (ppr PprDebug cons2)) (
+	    returnRn12 (wout (DataPragmas [] []))
+	    )
+	else if not (eq_data_specs specs1 specs2) then
+	    pprTrace "Mismatched specialisation info in DATA pragmas:\n"
+		     (ppAbove (ppr_data_specs specs1) (ppr_data_specs specs2)) (
+	    returnRn12 (wout (DataPragmas [] []))
+	    )
+	else
+	    returnRn12 (wout a)  -- same, pick one
+
+    -- ToDo: Should we use selByBetterName ???
+    -- ToDo: Report errors properly and recover quietly ???
+
+    -- ToDo: Should we merge specialisations ???
+
+    eq_data_specs [] [] = True
+    eq_data_specs (spec1:specs1) (spec2:specs2)
+      = eq_spec spec1 spec2 && eq_data_specs specs1 specs2
+    eq_data_specs _  _  = False
+
+    eq_spec spec1 spec2 = case cmp_spec spec1 spec2 of { EQ_ -> True; _ -> False}
+
+    ppr_data_specs specs
+      = ppBesides [ppStr "_SPECIALISE_ ", pp_the_list [
+	  ppCat [ppLbrack, ppInterleave ppComma (map pp_maybe ty_maybes), ppRbrack]
+	  | ty_maybes <- specs ]]
+
+    pp_the_list [p]    = p
+    pp_the_list (p:ps) = ppAbove (ppBeside p ppComma) (pp_the_list ps)
+
+    pp_maybe Nothing   = pp_NONE
+    pp_maybe (Just ty) = pprParendMonoType PprDebug ty
+
+    pp_NONE = ppStr "_N_"
+\end{code}
+
+Sort of similar deal on synonyms: this is the time to check that the
+expansions are really the same; otherwise, we use the pragmas.
+
+\begin{code}
+chooser_TySynonym wout _ locn1 ts1@(TySynonym name1 _ expand1 _)
+		       _ locn2 ts2@(TySynonym name2 _ expand2 _)
+  = if not (eqMonoType expand1 expand2) then
+    	report_dup "type synonym" name1 locn1 name2 locn2 ts1
+    else
+	returnRn12 ts1 -- same, just pick one
+\end{code}
+
+%************************************************************************
+%*									*
+\subsection[SpecDataSigs-RnPass2]{Functions for @SpecDataSigs@}
+%*									*
+%************************************************************************
+
+\begin{code}
+cmpTySigs :: ProtoNameSpecDataSig -> ProtoNameSpecDataSig -> TAG_
+
+cmpTySigs (SpecDataSig n1 ty1 _) (SpecDataSig n2 ty2 _)
+  = case cmpProtoName n1 n2 of
+	EQ_   -> LT_   -- multiple SPECIALIZE data pragmas allowed
+	other -> other
+
+selTySigs :: ProtoNameSpecDataSig
+	  -> ProtoNameSpecDataSig
+	  -> Rn12M ProtoNameSpecDataSig
+
+selTySigs s1@(SpecDataSig n1 ty1 locn1) s2@(SpecDataSig n2 ty2 locn2)
+  = selByBetterName "SPECIALIZE data user-pragma"
+	n1 bottom locn1 s1
+	n2 bottom locn2 s2
+	bottom bottom
+  where
+    bottom = panic "RnPass2:selTySigs:SpecDataSig"
+\end{code}
+
+%************************************************************************
+%*									*
+\subsection[ClassDecl-RnPass2]{Functions for @ClassDecls@}
+%*									*
+%************************************************************************
+
+\begin{code}
+cmpClassDecl :: ProtoNameClassDecl -> ProtoNameClassDecl -> TAG_
+
+cmpClassDecl (ClassDecl _ n1 _ _ _ _ _) (ClassDecl _ n2 _ _ _ _ _)
+  = cmpProtoName n1 n2
+
+selClass  :: ProtoNameClassDecl -> ProtoNameClassDecl
+	  -> Rn12M ProtoNameClassDecl
+
+selClass cd1@(ClassDecl ctxt n1 tv sigs bs pragmas1 locn1)
+	 cd2@(ClassDecl _    n2 _  _	_  pragmas2 locn2)
+  = selByBetterName "class"
+	n1 pragmas1 locn1 cd1
+	n2 pragmas2 locn2 cd2
+	(\ p -> ClassDecl ctxt n1 tv sigs bs p locn1)
+	chooser_Class
+\end{code}
+
+\begin{code}
+chooser_Class wout NoClassPragmas   _ _ b		_ _ = returnRn12 (wout b)
+chooser_Class wout a		    _ _ NoClassPragmas	_ _ = returnRn12 (wout a)
+
+chooser_Class wout sd1@(SuperDictPragmas gs1) l1 _ sd2@(SuperDictPragmas gs2) l2 _
+  = if length gs1 /= length gs2 then	-- urgh
+       returnRn12 (wout NoClassPragmas)
+    else
+	recoverQuietlyRn12 [{-no gen prags-}] (
+	    zipWithRn12 choose_prag gs1 gs2
+	)			`thenRn12` \ new_gprags ->
+	returnRn12 (wout (
+	    if null new_gprags then
+		pprTrace "tossed all SuperDictPragmas (rename2):"
+			 (ppAbove (ppr PprDebug sd1) (ppr PprDebug sd2))
+		NoClassPragmas
+	    else
+		SuperDictPragmas new_gprags
+	))
+  where
+    choose_prag g1 g2 = selGenPragmas g1 l1 g2 l2
+\end{code}
+
+%************************************************************************
+%*									*
+\subsection[InstDecls-RnPass2]{Functions for @InstDecls@}
+%*									*
+%************************************************************************
+
+\begin{code}
+cmpInst :: ProtoNameInstDecl -> ProtoNameInstDecl -> TAG_
+
+cmpInst (InstDecl c1 ty1 _ _ _ _ _ _) (InstDecl c2 ty2 _ _ _ _ _ _)
+  = case cmpProtoName c1 c2 of
+      EQ_   -> cmpInstanceTypes ty1 ty2
+      other -> other
+\end{code}
+
+Select the instance declaration from the module (rather than an
+interface), if it exists.
+
+\begin{code}
+selInst :: ProtoNameInstDecl -> ProtoNameInstDecl
+	-> Rn12M ProtoNameInstDecl
+
+selInst i1@(InstDecl c ty bs from_here1 orig_mod1 uprags pragmas1 locn1)
+	i2@(InstDecl _ _  _  from_here2 orig_mod2 _      pragmas2 locn2)
+  = let
+	have_orig_mod1 = not (_NULL_ orig_mod1)
+	have_orig_mod2 = not (_NULL_ orig_mod2)
+
+	choose_no1 = returnRn12 i1
+	choose_no2 = returnRn12 i2
+    in
+	-- generally: try to keep the locally-defined instance decl
+
+    if from_here1 && from_here2 then
+	-- If they are both from this module, don't throw either away,
+	-- otherwise we silently discard erroneous duplicates
+	trace ("selInst: duplicate instance in this module (ToDo: msg!)")
+	choose_no1
+
+    else if from_here1 then
+	if ( have_orig_mod1 && have_orig_mod2 && orig_mod1 /= orig_mod2 ) then
+	    trace ("selInst: instance in this module also defined somewhere else! (ToDo: msg!)")
+	    choose_no1
+	else
+	    choose_no1
+
+    else if from_here2 then
+	if ( have_orig_mod1 && have_orig_mod2 && orig_mod1 /= orig_mod2 ) then
+	    trace ("selInst: instance in this module also defined somewhere else! (ToDo: msg!)")
+	    choose_no2
+	else
+	    choose_no2
+
+    else -- it's definitely an imported instance;
+	 -- first, a quick sanity check...
+	if ( have_orig_mod1 && have_orig_mod2 && orig_mod1 /= orig_mod2 ) then
+	    trace ("selInst: `same' instances coming in from two modules! (ToDo: msg!)")
+	    choose_no2 -- arbitrary
+	else
+	    panic "RnPass2: need original modules for imported instances"
+
+{- LATER ???
+	    -- now we *cheat*: so we can use the "informing module" stuff
+	    -- in "selByBetterName", we *make up* some ProtoNames for
+	    -- these instance decls
+	    let
+		ii = SLIT("!*INSTANCE*!")
+		n1 = Imp orig_mod1 ii [infor_mod1] ii
+		n2 = Imp orig_mod2 ii [infor_mod2] ii
+	    in
+	    selByBetterName "instance"
+		n1 pragmas1 locn1 i1
+		n2 pragmas2 locn2 i2
+		(\ p -> InstDecl c ty bs from_here1 orig_mod1 infor_mod1
+			[{-none-}] p locn1)
+		chooser_Inst
+-}
+\end{code}
+
+\begin{code}
+chooser_Inst wout iprags1 loc1 i1 iprags2 loc2 i2
+  = chk_pragmas iprags1 iprags2
+  where
+	-- easy cases:
+    chk_pragmas NoInstancePragmas b = returnRn12 (wout b)
+    chk_pragmas a NoInstancePragmas = returnRn12 (wout a)
+
+	-- SimpleInstance pragmas meet: choose by GenPragmas
+    chk_pragmas (SimpleInstancePragma gprags1) (SimpleInstancePragma gprags2)
+      = recoverQuietlyRn12 NoGenPragmas (
+	    selGenPragmas gprags1 loc1 gprags2 loc2
+	)				`thenRn12` \ new_prags ->
+	returnRn12 (wout (
+	    case new_prags of
+	      NoGenPragmas -> NoInstancePragmas	-- bottled out
+	      _ -> SimpleInstancePragma new_prags
+	))
+
+	-- SimpleInstance pragma meets anything else... take the "else"
+    chk_pragmas (SimpleInstancePragma _) b = returnRn12 (wout b)
+    chk_pragmas a (SimpleInstancePragma _) = returnRn12 (wout a)
+
+    chk_pragmas (ConstantInstancePragma gp1 prs1) (ConstantInstancePragma gp2 prs2)
+      = recoverQuietlyRn12 NoGenPragmas (
+	    selGenPragmas gp1 loc1 gp2 loc2
+	)			`thenRn12` \ dfun_prags ->
+
+	recoverQuietlyRn12 [] (
+	    selNamePragmaPairs prs1 loc1 prs2 loc2
+	)			`thenRn12` \ new_pairs ->
+
+	returnRn12 (wout (
+	    if null new_pairs then -- bottled out
+		case dfun_prags of
+		  NoGenPragmas -> NoInstancePragmas -- doubly bottled out
+		  _ -> SimpleInstancePragma dfun_prags
+	    else
+		ConstantInstancePragma dfun_prags new_pairs
+	))
+
+	-- SpecialisedInstancePragmas: choose by gens, then specialisations
+    chk_pragmas a@(SpecialisedInstancePragma _ _) (SpecialisedInstancePragma _ _)
+      = trace "not checking two SpecialisedInstancePragma pragmas!" (returnRn12 (wout a))
+
+    chk_pragmas other1 other2  -- oops, bad mismatch
+      = pRAGMA_ERROR "instance pragmas" (wout other1) -- ToDo: msg
+\end{code}
+
+%************************************************************************
+%*									*
+\subsection[SpecInstSigs-RnPass2]{Functions for @AbstractTypeSigs@}
+%*									*
+%************************************************************************
+
+We don't make any effort to look for duplicate ``SPECIALIZE instance''
+pragmas. (Later??)
+
+We do this by make \tr{cmp*} always return \tr{LT_}---then there's
+nothing for \tr{sel*} to do!
+
+\begin{code}
+cmpSpecInstSigs
+    :: ProtoNameSpecInstSig -> ProtoNameSpecInstSig -> TAG_
+
+selSpecInstSigs :: ProtoNameSpecInstSig
+		-> ProtoNameSpecInstSig
+		-> Rn12M ProtoNameSpecInstSig
+
+cmpSpecInstSigs	a b = LT_
+selSpecInstSigs a b = panic "RnPass2:selSpecInstSigs"
+\end{code}
+
+%************************************************************************
+%*									*
+\subsection{Functions for SigDecls}
+%*									*
+%************************************************************************
+
+These \tr{*Sig} functions only operate on things from interfaces, so
+we don't have to worry about user-pragmas and other such junk.
+
+\begin{code}
+cmpSig :: ProtoNameSig -> ProtoNameSig -> TAG_
+
+cmpSig (Sig n1 _ _ _) (Sig n2 _ _ _) = cmpProtoName n1 n2
+
+cmpSig _ _ = panic# "cmpSig (rename2)"
+
+selSig :: ProtoNameSig -> ProtoNameSig -> Rn12M ProtoNameSig
+
+selSig s1@(Sig n1 ty pragmas1 locn1) s2@(Sig n2 _ pragmas2 locn2)
+  = selByBetterName "type signature"
+	n1 pragmas1 locn1 s1
+	n2 pragmas2 locn2 s2
+	(\ p -> Sig n1 ty p locn1) -- w/out its pragmas
+	chooser_Sig
+\end{code}
+
+\begin{code}
+chooser_Sig wout_prags g1 l1 s1@(Sig n1 ty1 _ _) g2 l2 s2@(Sig n2 ty2 _ _)
+  = case (cmpPolyType cmpProtoName ty1 ty2) of
+      EQ_ ->
+	recoverQuietlyRn12 NoGenPragmas (
+	    selGenPragmas g1 l1 g2 l2
+	)			`thenRn12` \ new_prags ->
+	returnRn12 (wout_prags new_prags)
+      _ -> report_dup "signature" n1 l1 n2 l2 s1
+\end{code}
+
+%************************************************************************
+%*									*
+\subsection{Help functions: selecting based on pragmas}
+%*									*
+%************************************************************************
+
+\begin{code}
+selGenPragmas
+	:: ProtoNameGenPragmas -> SrcLoc
+	-> ProtoNameGenPragmas -> SrcLoc
+	-> Rn12M ProtoNameGenPragmas
+
+selGenPragmas NoGenPragmas _ b	          _ = returnRn12 b
+selGenPragmas a		   _ NoGenPragmas _ = returnRn12 a
+
+selGenPragmas g1@(GenPragmas arity1 upd1 def1 strict1 unfold1 specs1) locn1
+	      g2@(GenPragmas arity2 upd2 def2 strict2 unfold2 specs2) locn2
+
+  = sel_arity  arity1  arity2	`thenRn12` \ arity  ->
+    sel_upd    upd1    upd2	`thenRn12` \ upd    ->
+    sel_def    def1    def2     `thenRn12` \ def    ->
+    sel_strict strict1 strict2	`thenRn12` \ strict ->
+    sel_unfold unfold1 unfold2	`thenRn12` \ unfold ->
+    sel_specs  specs1  specs2	`thenRn12` \ specs  ->
+    returnRn12 (GenPragmas arity upd def strict unfold specs)
+  where
+    sel_arity Nothing     Nothing   = returnRn12 Nothing
+    sel_arity a@(Just a1) (Just a2) = if a1 == a2
+				      then returnRn12 a
+				      else pRAGMA_ERROR "arity pragmas" a
+    sel_arity a		  _	    = pRAGMA_ERROR "arity pragmas" a
+
+    -------
+    sel_upd Nothing   	Nothing   = returnRn12 Nothing
+    sel_upd a@(Just u1) (Just u2) = if u1 == u2
+				    then returnRn12 a
+				    else pRAGMA_ERROR "update pragmas" a
+    sel_upd a	    	_	  = pRAGMA_ERROR "update pragmas" a
+
+    -------
+    sel_def Don'tDeforest Don'tDeforest = returnRn12 Don'tDeforest
+    sel_def DoDeforest    DoDeforest    = returnRn12 DoDeforest
+    sel_def a             _             = pRAGMA_ERROR "deforest pragmas" a
+
+    ----------
+    sel_unfold NoImpUnfolding b	    	     = returnRn12 b
+    sel_unfold a	      NoImpUnfolding = returnRn12 a
+
+    sel_unfold a@(ImpUnfolding _ c1) (ImpUnfolding _ c2)
+      = if c1 `eqUfExpr` c2 -- very paranoid (and rightly so)
+	then returnRn12 a
+	else pprTrace "mismatched unfoldings:\n" (ppAbove (ppr PprDebug c1) (ppr PprDebug c2)) (
+	     returnRn12 NoImpUnfolding
+	     )
+
+    sel_unfold a@(ImpMagicUnfolding b) (ImpMagicUnfolding c)
+      = if b == c then returnRn12 a else pRAGMA_ERROR "magic unfolding" a
+
+    sel_unfold a _ = pRAGMA_ERROR "unfolding pragmas" a
+
+    ----------
+    sel_strict NoImpStrictness NoImpStrictness = returnRn12 NoImpStrictness
+
+    sel_strict a@(ImpStrictness b1 i1 g1) (ImpStrictness b2 i2 g2)
+      = if b1 /= b2 || i1 /= i2
+	then pRAGMA_ERROR "strictness pragmas" a
+	else recoverQuietlyRn12 NoGenPragmas (
+		selGenPragmas g1 locn1 g2 locn2
+	     )	`thenRn12` \ wrkr_prags ->
+	     returnRn12 (ImpStrictness b1 i1 wrkr_prags)
+
+    sel_strict a _ = pRAGMA_ERROR "strictness pragmas" a
+
+    ---------
+    sel_specs specs1 specs2
+      = selSpecialisations specs1 locn1 specs2 locn2
+\end{code}
+
+\begin{code}
+selNamePragmaPairs
+	:: [(ProtoName, ProtoNameGenPragmas)] -> SrcLoc
+	-> [(ProtoName, ProtoNameGenPragmas)] -> SrcLoc
+	-> Rn12M [(ProtoName, ProtoNameGenPragmas)]
+
+selNamePragmaPairs [] _ [] _ = returnRn12 []
+selNamePragmaPairs [] _ bs _ = returnRn12 bs
+selNamePragmaPairs as _ [] _ = returnRn12 as
+
+selNamePragmaPairs ((name1, prags1) : pairs1) loc1
+		   ((name2, prags2) : pairs2) loc2
+
+  = if not (name1 `eqProtoName` name2) then
+	-- msg of any kind??? ToDo
+	pRAGMA_ERROR "named pragmas" pairs1
+    else
+    	selGenPragmas prags1 loc1 prags2 loc2	    `thenRn12` \ new_prags ->
+    	selNamePragmaPairs pairs1 loc1 pairs2 loc2  `thenRn12` \ rest ->
+	returnRn12 ( (name1, new_prags) : rest )
+\end{code}
+
+For specialisations we merge the lists from each Sig. This allows the user to
+declare specialised prelude functions in their own PreludeSpec module.
+
+\begin{code}
+selSpecialisations
+	:: [([Maybe ProtoNameMonoType], Int, ProtoNameGenPragmas)] -> SrcLoc
+	-> [([Maybe ProtoNameMonoType], Int, ProtoNameGenPragmas)] -> SrcLoc
+	-> Rn12M [([Maybe ProtoNameMonoType], Int, ProtoNameGenPragmas)]
+
+selSpecialisations [] _ [] _ = returnRn12 []
+selSpecialisations [] _ bs _ = returnRn12 bs -- arguable ... ToDo?
+selSpecialisations as _ [] _ = returnRn12 as -- ditto
+
+selSpecialisations all_specs1@((spec1, dicts1, prags1) : rest_specs1) loc1
+		   all_specs2@((spec2, dicts2, prags2) : rest_specs2) loc2
+
+  = case (cmp_spec spec1 spec2) of
+	 LT_ -> selSpecialisations rest_specs1 loc1 all_specs2 loc2
+					`thenRn12` \ rest ->
+    		returnRn12 ( (spec1, dicts1, prags1) : rest )
+
+	 EQ_ -> ASSERT(dicts1 == dicts2)
+	       	recoverQuietlyRn12 NoGenPragmas (
+	    	    selGenPragmas prags1 loc1 prags2 loc2
+		)			`thenRn12` \ new_prags ->
+    	        selSpecialisations rest_specs1 loc1 rest_specs2 loc2
+					`thenRn12` \ rest ->
+    		returnRn12 ( (spec1, dicts1, new_prags) : rest )
+
+	 GT_ -> selSpecialisations all_specs1 loc1 rest_specs2 loc2
+					`thenRn12` \ rest ->
+    		returnRn12 ( (spec2, dicts2, prags2) : rest )
+
+cmp_spec [] []			   = EQ_
+cmp_spec (Nothing:xs) (Nothing:ys) = cmp_spec xs ys
+cmp_spec (Just t1:xs) (Just t2:ys) = case cmpMonoType cmpProtoName t1 t2 of
+					EQ_ -> cmp_spec xs ys
+					xxx -> xxx
+cmp_spec (Nothing:xs) (Just t2:ys) = LT_
+cmp_spec (Just t1:xs) (Nothing:ys) = GT_
+\end{code}
+
+%************************************************************************
+%*									*
+\subsection{Help functions: @uniquefy@ and @selByBetterName@}
+%*									*
+%************************************************************************
+
+\begin{code}
+uniquefy :: FAST_STRING			-- Module name
+	 -> (a -> a -> TAG_)		-- Comparison function
+	 -> (a -> a -> Rn12M a)		-- Selection function
+	 -> [a]				-- Things to be processed
+	 -> Rn12M [a]			-- Processed things
+
+uniquefy mod cmp sel things
+  = mapRn12 (check_group_consistency sel) grouped_things
+  where
+    grouped_things = equivClasses cmp things
+
+    check_group_consistency :: (a -> a -> Rn12M a)	-- Selection function
+			    -> [a]			-- things to be compared
+			    -> Rn12M a
+
+    check_group_consistency sel [] = panic "RnPass2: runs produced an empty list"
+    check_group_consistency sel (thing:things) = foldrRn12 sel thing things
+\end{code}
+
+@selByBetterName@: There are two ways one thing can have a ``better
+name'' than another.
+
+First: Something with an @Unk@ name is declared in this module, so we
+keep that, rather than something from an interface (with an @Imp@
+name, probably).
+
+Second: If we have two non-@Unk@ names, but one ``informant module''
+is also the {\em original} module for the entity, then we choose that
+one.  I.e., if one interface says, ``I am the module that created this
+thing'' then we believe it and take that one.
+
+If we can't figure out which one to choose by the names, we use the
+info provided to select based on the pragmas.
+
+LATER: but surely we have to worry about different-by-original-name
+things which are same-by-local-name things---these should be reported
+as errors.
+
+\begin{code}
+selByBetterName :: String   -- class/datatype/synonym (for error msg)
+
+		-- 1st/2nd comparee name/pragmas + their things
+		-> ProtoName -> pragmas -> SrcLoc -> thing
+		-> ProtoName -> pragmas -> SrcLoc -> thing
+
+		-- a thing without its pragmas
+		-> (pragmas -> thing)
+
+		-- choose-by-pragma function
+		-> ((pragmas -> thing)		    -- thing minus its pragmas
+		    -> pragmas -> SrcLoc -> thing   -- comparee 1
+		    -> pragmas -> SrcLoc -> thing   -- comparee 2
+		    -> Rn12M thing )	    	    -- thing w/ its new pragmas
+
+		-> Rn12M thing		-- selected thing
+
+selByBetterName dup_msg
+		pn1 pragmas1 locn1 thing1
+		pn2 pragmas2 locn2 thing2
+		thing_wout_pragmas
+		chooser
+  = getModuleNameRn12	`thenRn12` \ mod_name ->
+    let
+	choose_thing1	= chk_eq (returnRn12 thing1)
+	choose_thing2   = chk_eq (returnRn12 thing2)
+	check_n_choose  = chk_eq (chooser thing_wout_pragmas
+					  pragmas1 locn1 thing1
+					  pragmas2 locn2 thing2)
+
+	dup_error = report_dup dup_msg pn1 locn1 pn2 locn2 thing1
+    in
+    case pn1 of
+      Unk _  -> case pn2 of
+		 Unk _	-> dup_error
+		 _	-> if orig_modules_clash mod_name pn2
+			    then dup_error
+			    else choose_thing1
+
+      Prel _ -> case pn2 of
+		 Unk _	-> if orig_modules_clash mod_name pn1
+			   then dup_error
+			   else choose_thing2
+		 _	-> check_n_choose
+
+      Imp om1 _ im1 _ -> -- we're gonna check `informant module' info...
+	case pn2 of
+	  Unk _		  -> if orig_modules_clash mod_name pn1
+			     then dup_error
+			     else choose_thing2
+	  Prel _	  -> check_n_choose
+	  Imp om2 _ im2 _
+	    -> let
+		   is_elem = isIn "selByBetterName"
+
+		   name1_claims_orig = om1 `is_elem` im1 && not (_NULL_ om1)
+		   name2_claims_orig = om2 `is_elem` im2 && not (_NULL_ om2)
+	       in
+	       if name1_claims_orig
+	       then if name2_claims_orig then check_n_choose else choose_thing1
+	       else if name2_claims_orig then choose_thing2  else check_n_choose
+  where
+    chk_eq if_OK
+      = if not (eqProtoName pn1 pn2) && eqByLocalName pn1 pn2
+	then report_dup dup_msg pn1 locn1 pn2 locn2 thing1
+	else if_OK
+
+    orig_modules_clash this_module pn
+      = case (getOrigName pn) of { (that_module, _) ->
+	not (this_module == that_module) }
+
+report_dup dup_msg pn1 locn1 pn2 locn2 thing
+  = addErrRn12 err_msg `thenRn12` \ _ ->
+    returnRn12 thing
+  where
+    err_msg = dupNamesErr dup_msg [(pn1,locn1), (pn2,locn2)]
+
+pRAGMA_ERROR :: String -> a -> Rn12M a
+pRAGMA_ERROR msg x
+  = addErrRn12 (\ sty -> ppStr ("PRAGMA ERROR:"++msg)) `thenRn12` \ _ ->
+    returnRn12 x
+\end{code}
diff --git a/ghc/compiler/rename/RnPass3.lhs b/ghc/compiler/rename/RnPass3.lhs
new file mode 100644
index 0000000000..ce905edec1
--- /dev/null
+++ b/ghc/compiler/rename/RnPass3.lhs
@@ -0,0 +1,620 @@
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+%
+\section[RnPass3]{Third of the renaming passes}
+
+The business of this pass is to:
+\begin{itemize}
+\item	find all the things declared at top level,
+\item	assign uniques to them
+\item return an association list mapping their @ProtoName@s to
+	freshly-minted @Names@ for them.
+\end{itemize}
+
+No attempt is made to discover whether the same thing is declared
+twice: that is up to the caller to sort out.
+
+\begin{code}
+#include "HsVersions.h"
+
+module RnPass3 (
+	rnModule3,
+	initRn3, Rn3M(..)  -- re-exported from monad
+
+	-- for completeness
+    ) where
+
+import Ubiq{-uitous-}
+
+import RnMonad3
+import HsSyn
+import RdrHsSyn
+
+import Bag		( emptyBag, listToBag, unionBags, unionManyBags,
+			  unitBag, snocBag, elemBag, bagToList, Bag
+			)
+import ErrUtils
+import HsPragmas	( DataPragmas(..) )
+import Name		( Name(..) )
+import NameTypes	( fromPrelude, FullName{-instances-} )
+import Pretty
+import ProtoName	( cmpByLocalName, ProtoName(..) )
+import RnUtils		( mkGlobalNameFun,
+			  GlobalNameMappers(..), GlobalNameMapper(..),
+			  PreludeNameMappers(..), PreludeNameMapper(..),
+			  dupNamesErr
+			)
+import SrcLoc		( SrcLoc{-instance-} )
+import Util		( isIn, removeDups, cmpPString, panic )
+\end{code}
+
+*********************************************************
+*							*
+\subsection{Type declarations}
+*							*
+*********************************************************
+
+\begin{code}
+type BagAssoc 	    = Bag (ProtoName, Name)	-- Bag version
+type NameSpaceAssoc = [(ProtoName, Name)]	-- List version
+\end{code}
+
+
+*********************************************************
+*							*
+\subsection{Main function: @rnModule3@}
+*							*
+*********************************************************
+
+\begin{code}
+rnModule3 :: PreludeNameMappers
+	  -> Bag FAST_STRING	-- list of imported module names
+	  -> ProtoNameHsModule
+	  -> Rn3M ( NameSpaceAssoc, NameSpaceAssoc,
+		    GlobalNameMapper,  GlobalNameMapper,
+		    Bag Error )
+
+rnModule3 pnfs@(val_pnf, tc_pnf) imported_mod_names
+	  (HsModule mod_name exports imports _ ty_decls _ class_decls
+	    inst_decls _ _ binds sigs _)
+
+  = putInfoDownM3 {- ???pnfs -} mod_name exports (
+
+    doTyDecls3 ty_decls		`thenRn3` \ (constrs, tycons) ->
+    doClassDecls3 class_decls	`thenRn3` \ (ops, classes) ->
+    doBinds3 binds		`thenRn3` \ val_binds ->
+    doIntSigs3 sigs		`thenRn3` \ val_sigs ->
+
+    let val_namespace	= constrs `unionBags` ops `unionBags` val_binds
+				  `unionBags` val_sigs
+	tc_namespace	= tycons `unionBags` classes
+
+	(var_alist, var_dup_errs) = deal_with_dups "variable" val_pnf (bagToList val_namespace)
+	(tc_alist, tc_dup_errs)	  = deal_with_dups "type or class" tc_pnf (bagToList tc_namespace)
+	v_gnf  = mkGlobalNameFun mod_name val_pnf var_alist
+    	tc_gnf = mkGlobalNameFun mod_name tc_pnf  tc_alist
+    in
+
+    verifyExports v_gnf tc_gnf (imported_mod_names `snocBag` mod_name) exports
+					`thenRn3` \ export_errs ->
+    verifyImports v_gnf tc_gnf imports	`thenRn3` \ import_errs ->
+
+    returnRn3 ( var_alist, tc_alist,
+		v_gnf, tc_gnf,
+		var_dup_errs `unionBags` tc_dup_errs `unionBags`
+		export_errs  `unionBags` import_errs
+    ))
+  where
+    deal_with_dups :: String -> PreludeNameMapper -> NameSpaceAssoc
+		   -> (NameSpaceAssoc, Bag Error)
+
+    deal_with_dups kind_str pnf alist
+      = (goodies,
+	 listToBag (map mk_dup_err dup_lists) `unionBags`
+	 listToBag (map mk_prel_dup_err prel_dups)
+	)
+      where
+	goodies   :: [(ProtoName,Name)]		--NameSpaceAssoc
+	dup_lists :: [[(ProtoName, Name)]]
+
+	-- Find all the names which are defined twice.
+	-- By "name" here, we mean "string"; that is, we are looking
+	-- for places where two strings are bound to different Names
+	-- in the top-level scope of this module.
+
+	(singles, dup_lists) = removeDups cmp alist
+	-- We want to compare their *local* names; the removeDups thing
+	-- is checking for whether two objects have the same local name.
+	cmp (a, _) (b, _) = cmpByLocalName a b
+
+	-- Anything in alist with a Unk name is defined right here in
+	-- this module; hence, it should not be a prelude name.  We
+	-- need to check this separately, because the prelude is
+	-- imported only implicitly, via the PrelNameFuns argument
+
+	(goodies, prel_dups) = if fromPrelude mod_name then
+				 (singles, [])	-- Compiling the prelude, so ignore this check
+			       else
+				 partition local_def_of_prelude_thing singles
+
+	local_def_of_prelude_thing (Unk s, _)
+	  = case pnf s of
+	      Just _  -> False		-- Eek!  It's a prelude name
+	      Nothing -> True		-- It isn't; all is ok
+	local_def_of_prelude_thing other = True
+
+	mk_dup_err :: [(ProtoName, Name)] -> Error
+	mk_dup_err dups_of_name
+	  = let
+		dup_pnames_w_src_loc = [ (pn, getSrcLoc name) | (pn,name) <- dups_of_name ]
+	    in
+	    dupNamesErr kind_str dup_pnames_w_src_loc
+
+	-- This module defines a prelude thing
+	mk_prel_dup_err :: (ProtoName, Name) -> Error
+	mk_prel_dup_err (pn, name)
+	  = dupPreludeNameErr kind_str (pn, getSrcLoc name)
+\end{code}
+
+*********************************************************
+*							*
+\subsection{Type and class declarations}
+*							*
+*********************************************************
+
+\begin{code}
+doTyDecls3 :: [ProtoNameTyDecl] -> Rn3M (BagAssoc, BagAssoc)
+
+doTyDecls3 [] = returnRn3 (emptyBag, emptyBag)
+
+doTyDecls3 (tyd:tyds)
+  = andRn3 combiner (do_decl tyd) (doTyDecls3 tyds)
+  where
+    combiner (cons1, tycons1) (cons2, tycons2)
+      = (cons1 `unionBags` cons2, tycons1 `unionBags` tycons2)
+
+    do_decl (TyData context tycon tyvars condecls _ pragmas src_loc)
+      = newFullNameM3 tycon src_loc True{-tycon-ish-} Nothing
+					`thenRn3` \ (uniq, tycon_name) ->
+    	let
+	    exp_flag = getExportFlag tycon_name
+		-- we want to force all data cons to have the very
+		-- same export flag as their type constructor
+	in
+	doConDecls3 False{-not invisibles-} exp_flag condecls `thenRn3` \ data_cons ->
+	do_data_pragmas exp_flag pragmas		      `thenRn3` \ pragma_data_cons ->
+	returnRn3 (data_cons `unionBags` pragma_data_cons,
+		   unitBag (tycon, TyConName uniq tycon_name (length tyvars)
+					True -- indicates data/newtype tycon
+					[ c | (_,c) <- bagToList data_cons ]))
+
+    do_decl (TyNew context tycon tyvars condecl _ pragmas src_loc)
+      = newFullNameM3 tycon src_loc True{-tycon-ish-} Nothing
+					`thenRn3` \ (uniq, tycon_name) ->
+    	let
+	    exp_flag = getExportFlag tycon_name
+		-- we want to force all data cons to have the very
+		-- same export flag as their type constructor
+	in
+	doConDecls3 False{-not invisibles-} exp_flag condecl  `thenRn3` \ data_con ->
+	do_data_pragmas exp_flag pragmas		      `thenRn3` \ pragma_data_con ->
+	returnRn3 (data_con `unionBags` pragma_data_con,
+		   unitBag (tycon, TyConName uniq tycon_name (length tyvars)
+					True -- indicates data/newtype tycon
+					[ c | (_,c) <- bagToList data_con ]))
+
+    do_decl (TySynonym tycon tyvars monoty src_loc)
+      = newFullNameM3 tycon src_loc True{-tycon-ish-} Nothing
+					`thenRn3` \ (uniq, tycon_name) ->
+	returnRn3 (emptyBag,
+		   unitBag (tycon, TyConName uniq tycon_name (length tyvars) False bottom))
+					-- Flase indicates type tycon
+      where
+	bottom = panic "do_decl: data cons on synonym?"
+
+    do_data_pragmas exp_flag (DataPragmas con_decls specs)
+      = doConDecls3 True{-invisibles-} exp_flag con_decls
+\end{code}
+
+\begin{code}
+doConDecls3 :: Bool		    -- True <=> mk invisible FullNames
+	    -> ExportFlag	    -- Export flag of the TyCon; we want
+				    -- to force its use.
+	    -> [ProtoNameConDecl]
+	    -> Rn3M BagAssoc
+
+doConDecls3 _ _ [] = returnRn3 emptyBag
+
+doConDecls3 want_invisibles exp_flag (cd:cds)
+  = andRn3 unionBags (do_decl cd) (doConDecls3 want_invisibles exp_flag cds)
+  where
+    mk_name = if want_invisibles then newInvisibleNameM3 else newFullNameM3
+
+    do_decl (ConDecl con tys src_loc)
+      = mk_name con src_loc True{-tycon-ish-} (Just exp_flag) `thenRn3` \ (uniq, con_name) ->
+	returnRn3 (unitBag (con, ValName uniq con_name))
+    do_decl (ConOpDecl ty1 op ty2 src_loc)
+      = mk_name op src_loc True{-tycon-ish-} (Just exp_flag)  `thenRn3` \ (uniq, con_name) ->
+	returnRn3 (unitBag (op, ValName uniq con_name))
+    do_decl (NewConDecl con ty src_loc)
+      = mk_name con src_loc True{-tycon-ish-} (Just exp_flag) `thenRn3` \ (uniq, con_name) ->
+	returnRn3 (unitBag (con, ValName uniq con_name))
+    do_decl (RecConDecl con fields src_loc)
+      = _trace "doConDecls3:RecConDecl:nothing for fields\n" $
+        mk_name con src_loc True{-tycon-ish-} (Just exp_flag) `thenRn3` \ (uniq, con_name) ->
+	returnRn3 (unitBag (con, ValName uniq con_name))
+\end{code}
+
+
+@doClassDecls3@ uses the `name function' to map local class names into
+original names, calling @doClassOps3@ to do the same for the
+class operations. @doClassDecls3@ is used to process module
+class declarations.
+
+\begin{code}
+doClassDecls3 :: [ProtoNameClassDecl] -> Rn3M (BagAssoc, BagAssoc)
+
+doClassDecls3 [] = returnRn3 (emptyBag, emptyBag)
+
+doClassDecls3 (cd:cds)
+  = andRn3 combiner (do_decl cd) (doClassDecls3 cds)
+  where
+    combiner (ops1, classes1) (ops2, classes2)
+      = (ops1 `unionBags` ops2, classes1 `unionBags` classes2)
+
+    do_decl (ClassDecl context cname@(Prel c) tyvar sigs defaults pragmas src_loc)
+      = doClassOps3 c 1 sigs	`thenRn3` \ (_, ops) ->
+	returnRn3 (ops, unitBag (cname, c))
+
+    do_decl (ClassDecl context cname tyvar sigs defaults pragmas src_loc)
+      = newFullNameM3 cname src_loc True{-tycon-ish-} Nothing
+					`thenRn3` \ (uniq, class_name) ->
+	fixRn3 ( \ ~(clas_ops,_) ->
+	    let
+		class_Name = ClassName uniq class_name
+					[ o | (_,o) <- bagToList clas_ops ]
+	    in
+	    doClassOps3 class_Name 1 sigs   `thenRn3` \ (_, ops) ->
+	    returnRn3 (ops, class_Name)
+	)				`thenRn3` \ (ops, class_Name) ->
+
+	returnRn3 (ops, unitBag (cname, class_Name))
+\end{code}
+
+We stitch on a class-op tag to each class operation.  They are guaranteed
+to be done in left-to-right order.
+
+\begin{code}
+doClassOps3 :: Name{-class-} -> Int -> [ProtoNameSig] -> Rn3M (Int, BagAssoc)
+
+doClassOps3 clas tag [] = returnRn3 (tag, emptyBag)
+
+doClassOps3 clas tag (sig:rest)
+  = do_op		  sig	`thenRn3` \ (tag1, bag1) ->
+    doClassOps3 clas tag1 rest	`thenRn3` \ (tagr, bagr) ->
+    returnRn3 (tagr, bag1 `unionBags` bagr)
+  where
+{- LATER: NB: OtherVal is a Name, not a ProtoName
+    do_op (ClassOpSig op@(OtherVal uniq name) ty pragma src_loc)
+      =	-- A classop whose unique is pre-ordained, so the type checker
+	-- can look it up easily
+	let
+	    op_name = ClassOpName uniq clas (snd (getOrigName name)) tag
+	in
+	returnRn3 (tag+1, unitBag (op, op_name))
+-}
+
+    do_op (ClassOpSig op ty pragma src_loc)
+      = newFullNameM3 op src_loc False{-not tyconish-} Nothing `thenRn3` \ (uniq, _) ->
+	let
+	    op_name = ClassOpName uniq clas (get_str op) tag
+	in
+	returnRn3 (tag+1, unitBag (op, op_name))
+      where
+	-- A rather yukky function to get the original name out of a
+	-- class operation.  The "snd (getOrigName ...)" in the other
+	-- ClassOpSig case does the corresponding yukky thing.
+	get_str :: ProtoName -> FAST_STRING
+	get_str (Unk s)       = s
+	get_str (Qunk _ s)    = s
+	get_str (Imp _ d _ _) = d
+\end{code}
+
+Remember, interface signatures don't have user-pragmas, etc., in them.
+\begin{code}
+doIntSigs3 :: [ProtoNameSig] -> Rn3M BagAssoc
+
+doIntSigs3 [] = returnRn3 emptyBag
+
+doIntSigs3 (s:ss)
+  = andRn3 unionBags (do_sig s) (doIntSigs3 ss)
+  where
+    do_sig (Sig v ty pragma src_loc)
+      = newFullNameM3 v src_loc False{-distinctly untycon-ish-} Nothing
+					     `thenRn3` \ (uniq, v_fname) ->
+	returnRn3 (unitBag (v, ValName uniq v_fname))
+\end{code}
+
+*********************************************************
+*							*
+\subsection{Bindings}
+*							*
+*********************************************************
+
+\begin{code}
+doBinds3 :: ProtoNameHsBinds -> Rn3M BagAssoc
+
+doBinds3 EmptyBinds = returnRn3 emptyBag
+
+doBinds3 (ThenBinds binds1 binds2)
+  = andRn3 unionBags (doBinds3 binds1) (doBinds3 binds2)
+
+doBinds3 (SingleBind bind)    = doBind3 bind
+
+doBinds3 (BindWith bind sigs) = doBind3 bind
+\end{code}
+
+\begin{code}
+doBind3 :: ProtoNameBind -> Rn3M BagAssoc
+doBind3 EmptyBind          = returnRn3 emptyBag
+doBind3 (NonRecBind mbind) = doMBinds3 mbind
+doBind3 (RecBind mbind)    = doMBinds3 mbind
+
+doMBinds3 :: ProtoNameMonoBinds -> Rn3M BagAssoc
+
+doMBinds3 EmptyMonoBinds 			 = returnRn3 emptyBag
+doMBinds3 (PatMonoBind pat grhss_and_binds locn) = doPat3 locn pat
+doMBinds3 (FunMonoBind p_name _ locn) 		 = doTopLevName locn p_name
+
+doMBinds3 (AndMonoBinds mbinds1 mbinds2)
+  = andRn3 unionBags (doMBinds3 mbinds1) (doMBinds3 mbinds2)
+\end{code}
+
+Fold over a list of patterns:
+\begin{code}
+doPats3 locn [] = returnRn3 emptyBag
+doPats3 locn (pat:pats)
+  = andRn3 unionBags (doPat3 locn pat) (doPats3 locn pats)
+\end{code}
+
+\begin{code}
+doPat3 :: SrcLoc -> ProtoNamePat -> Rn3M BagAssoc
+
+doPat3 locn WildPatIn       	= returnRn3 emptyBag
+doPat3 locn (LitPatIn _) 	= returnRn3 emptyBag
+doPat3 locn (LazyPatIn pat) 	= doPat3 locn pat
+doPat3 locn (VarPatIn n) 	= doTopLevName locn n
+doPat3 locn (ListPatIn pats)	= doPats3 locn pats
+doPat3 locn (TuplePatIn pats)	= doPats3 locn pats
+
+doPat3 locn (AsPatIn p_name pat)
+  = andRn3 unionBags (doTopLevName locn p_name) (doPat3 locn pat)
+
+doPat3 locn (ConPatIn name pats) = doPats3 locn pats
+
+doPat3 locn (ConOpPatIn pat1 name pat2)
+  = andRn3 unionBags (doPat3 locn pat1) (doPat3 locn pat2)
+\end{code}
+
+\begin{code}
+doTopLevName :: SrcLoc -> ProtoName -> Rn3M BagAssoc
+
+doTopLevName locn pn
+  = newFullNameM3 pn locn False{-un-tycon-ish-}	Nothing `thenRn3` \ (uniq, name) ->
+    returnRn3 (unitBag (pn, ValName uniq name))
+\end{code}
+
+Have to check that export/imports lists aren't too drug-crazed.
+
+\begin{code}
+verifyExports :: GlobalNameMapper -> GlobalNameMapper
+	      -> Bag FAST_STRING -- module names that might appear
+				 -- in an export list; includes the
+				 -- name of this module
+	      -> Maybe [IE ProtoName]	-- export list
+	      -> Rn3M (Bag Error)
+
+verifyExports _ _ _ Nothing{-no export list-} = returnRn3 emptyBag
+
+verifyExports v_gnf tc_gnf imported_mod_names export_list@(Just exports)
+  = mapRn3 verify exports	`thenRn3` \ errs ->
+    chk_exp_dups  export_list	`thenRn3` \ dup_errs ->
+    returnRn3 (unionManyBags (errs ++ dup_errs))
+  where
+    ok	    	   = returnRn3 emptyBag
+    naughty nm msg = returnRn3 (unitBag (badExportNameErr (_UNPK_ nm) msg))
+    undef_name nm  = naughty nm "is not defined."
+    dup_name (nm:_)= naughty nm "occurs more than once."
+
+    undef_name :: FAST_STRING -> Rn3M (Bag Error)
+    dup_name :: [FAST_STRING] -> Rn3M (Bag Error)
+
+    ----------------
+    chk_exp_dups :: Maybe [IE ProtoName] -> Rn3M [Bag Error]
+
+    chk_exp_dups exports
+      = let
+	    export_strs = [ nm | (nm, _) <- fst (getRawExportees exports) ]
+	    (_, dup_lists) = removeDups cmpByLocalName{-????-} export_strs
+	in
+	mapRn3 dup_name [map getOccurrenceName dl | dl <- dup_lists]
+
+    ---------------- the more serious checking
+    verify :: IE ProtoName -> Rn3M (Bag Error)
+
+    verify (IEVar v)
+      = case (v_gnf v) of { Nothing -> undef_name (getOccurrenceName v); _ -> ok }
+
+    verify (IEModuleContents mod)
+      = if not (mod `elemBag` imported_mod_names) then undef_name mod else ok
+
+    verify (IEThingAbs tc)
+      = case (tc_gnf tc) of
+	  Nothing -> undef_name (getOccurrenceName tc)
+	  Just nm -> let
+			naughty_tc = naughty (getOccurrenceName tc)
+		     in
+		     case nm of
+		       TyConName _ _ _ False{-syn-} _
+			 -> naughty_tc "must be exported with a `(..)' -- it's a synonym."
+
+		       ClassName _ _ _
+			 -> naughty_tc "cannot be exported \"abstractly\" (it's a class)."
+		       _ -> ok
+
+    verify (IEThingAll tc)
+      = case (tc_gnf tc) of
+	  Nothing -> undef_name (getOccurrenceName tc)
+	  Just nm -> let
+			naughty_tc = naughty (getOccurrenceName tc)
+		     in
+		     case nm of
+		       TyConName _ _ _ True{-data or newtype-} [{-no cons-}]
+			 -> naughty_tc "can't be exported with a `(..)' -- it was imported abstractly."
+		       _ -> ok
+
+{- OLD:
+    verify (IEConWithCons tc cs)
+      = case (tc_gnf tc) of
+	  Nothing -> undef_name tc
+	  Just nm -> mapRn3 verify (map IEVar cs) `thenRn3` \ errs ->
+		     returnRn3 (unionManyBags errs)
+		     -- ToDo: turgid checking which we don't care about (WDP 94/10)
+
+    verify (IEClsWithOps c ms)
+      = case (tc_gnf c) of
+	  Nothing -> undef_name c
+	  Just  _ -> mapRn3 verify (map IEVar ms) `thenRn3` \ errs ->
+		     returnRn3 (unionManyBags errs)
+		     -- ToDo: turgid checking which we don't care about (WDP 94/10)
+-}
+\end{code}
+
+Note: we're not too particular about whether something mentioned in an
+import list is in {\em that} interface... (ToDo? Probably not.)
+
+\begin{code}
+verifyImports :: GlobalNameMapper -> GlobalNameMapper
+	      -> [ProtoNameImportedInterface]
+	      -> Rn3M (Bag Error)
+
+verifyImports v_gnf tc_gnf imports
+  = mapRn3 chk_one (map collect imports) `thenRn3` \ errs ->
+    returnRn3 (unionManyBags errs)
+  where
+    -- collect: name/locn, import list
+
+    collect (ImportMod iff qual asmod details)
+      = (iface iff, imp_list, hide_list)
+      where
+	(imp_list, hide_list)
+	  = case details of
+	      Nothing			 -> ([],  [])
+	      Just (True{-hidden-}, ies) -> ([],  ies)
+	      Just (_ {-unhidden-}, ies) -> (ies, [])
+
+    ------------
+    iface (Interface name _ _ _ _ _ _ locn) = (name, locn)
+
+    ------------
+    chk_one :: ((FAST_STRING, SrcLoc), [IE ProtoName], [IE ProtoName])
+	    -> Rn3M (Bag Error)
+
+    chk_one ((mod_name, locn), import_list, hide_list)
+      = mapRn3 verify import_list   `thenRn3` \ errs1 ->
+	chk_imp_dups  import_list   `thenRn3` \ dup_errs ->
+	-- ToDo: we could check the hiding list more carefully
+	chk_imp_dups  hide_list	    `thenRn3` \ dup_errs2 ->
+    	returnRn3 (unionManyBags (errs1 ++ dup_errs ++ dup_errs2))
+      where
+	ok	          = returnRn3 emptyBag
+	naughty nm msg    = returnRn3 (unitBag (badImportNameErr (_UNPK_ mod_name) (_UNPK_ nm) msg locn))
+	undef_name nm     = naughty nm "is not defined."
+	dup_name (nm:_)   = naughty nm "occurs more than once."
+
+	undef_name :: FAST_STRING -> Rn3M (Bag Error)
+	dup_name :: [FAST_STRING] -> Rn3M (Bag Error)
+
+	----------------
+	chk_imp_dups imports
+	  = let
+		import_strs = getRawImportees imports
+		(_, dup_lists) = removeDups _CMP_STRING_ import_strs
+	    in
+	    mapRn3 dup_name dup_lists
+
+	----------------
+	verify :: IE ProtoName -> Rn3M (Bag Error)
+
+	verify (IEVar v)
+	  = case (v_gnf v) of { Nothing -> undef_name (getOccurrenceName v); _ -> ok }
+
+	verify (IEThingAbs tc)
+	  = case (tc_gnf tc) of
+	      Nothing -> undef_name (getOccurrenceName tc)
+	      Just nm -> let
+			    naughty_tc = naughty (getOccurrenceName tc)
+		         in
+		         case nm of
+			   TyConName _ _ _ False{-syn-} _
+			     -> naughty_tc "must be imported with a `(..)' -- it's a synonym."
+			   ClassName _ _ _
+			     -> naughty_tc "cannot be imported \"abstractly\" (it's a class)."
+			   _ -> ok
+
+	verify (IEThingAll tc)
+	  = case (tc_gnf tc) of
+	      Nothing -> undef_name (getOccurrenceName tc)
+	      Just nm -> let
+			    naughty_tc = naughty (getOccurrenceName tc)
+		         in
+		         case nm of
+			   TyConName _ _ _ True{-data or newtype-} [{-no cons-}]
+			     -> naughty_tc "can't be imported with a `(..)' -- the interface says it's abstract."
+			   _ -> ok
+
+{- OLD:
+	verify (IEConWithCons tc cs)
+	  = case (tc_gnf tc) of
+	      Nothing -> undef_name (getOccurrenceName tc)
+	      Just nm -> mapRn3 verify (map IEVar cs) `thenRn3` \ errs ->
+			 returnRn3 (unionManyBags errs)
+			 -- One could add a great wad of tedious checking
+			 -- here, but I am too lazy to do so.  WDP 94/10
+
+	verify (IEClsWithOps c ms)
+	  = case (tc_gnf c) of
+	      Nothing -> undef_name (getOccurrenceName c)
+	      Just  _ -> mapRn3 verify (map IEVar ms) `thenRn3` \ errs ->
+			 returnRn3 (unionManyBags errs)
+			 -- Ditto about tedious checking.  WDP 94/10
+-}
+\end{code}
+
+%************************************************************************
+%*									*
+\subsection{Error messages}
+%*									*
+%************************************************************************
+
+\begin{code}
+badExportNameErr name whats_wrong
+  = dontAddErrLoc
+	"Error in the export list" ( \ sty ->
+    ppBesides [ppChar '`', ppStr name, ppStr "' ", ppStr whats_wrong] )
+
+------------------------------------------
+badImportNameErr mod name whats_wrong locn
+  = addErrLoc locn
+	("Error in an import list for the module `"++mod++"'") ( \ sty ->
+    ppBesides [ppChar '`', ppStr name, ppStr "' ", ppStr whats_wrong] )
+
+----------------------------
+-- dupNamesErr: from RnUtils
+
+--------------------------------------
+dupPreludeNameErr descriptor (nm, locn)
+  = addShortErrLocLine locn ( \ sty ->
+    ppBesides [ ppStr "A conflict with a Prelude ", ppStr descriptor,
+		ppStr ": ", ppr sty nm ])
+\end{code}
diff --git a/ghc/compiler/rename/RnPass4.lhs b/ghc/compiler/rename/RnPass4.lhs
new file mode 100644
index 0000000000..9aaa2e7802
--- /dev/null
+++ b/ghc/compiler/rename/RnPass4.lhs
@@ -0,0 +1,877 @@
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+%
+\section[RnPass4]{Fourth of the renaming passes}
+
+\begin{code}
+#include "HsVersions.h"
+
+module RnPass4 ( rnModule, rnPolyType, rnGenPragmas ) where
+
+import Ubiq{-uitous-}
+import RnLoop -- *check* the RnPass4/RnExpr4/RnBinds4 loop-breaking
+
+import HsSyn
+import RdrHsSyn
+import RnHsSyn
+import HsPragmas	-- all of it
+import HsCore		-- all of it
+import RnMonad4
+
+import Class		( derivableClassKeys )
+import Maybes		( maybeToBool, catMaybes )
+import Name		( Name(..) )
+import Outputable	( Outputable(..), isAvarid )
+import Pretty		( ppHang, ppStr, ppCat, ppAboves )
+import ProtoName	( eqProtoName, elemProtoNames, ProtoName{-instance-} )
+import RnBinds4		( rnTopBinds, rnMethodBinds )
+import SrcLoc		( SrcLoc{-instance-} )
+import Unique		( Unique{-instances-} )
+import UniqSet		( UniqSet(..) )
+import Util		( isIn, panic, assertPanic )
+\end{code}
+
+This pass `renames' the module+imported info, simultaneously
+performing dependency analysis. It also does the following error
+checks:
+\begin{enumerate}
+\item
+Checks that tyvars are used properly. This includes checking
+for undefined tyvars, and tyvars in contexts that are ambiguous.
+\item
+Checks that local variables are defined.
+\end{enumerate}
+
+\begin{code}
+rnModule :: ProtoNameHsModule -> Rn4M RenamedHsModule
+
+rnModule (HsModule mod_name exports _ fixes ty_decls specdata_sigs
+	    class_decls inst_decls specinst_sigs defaults
+	    binds int_sigs src_loc)
+
+  = pushSrcLocRn4 src_loc			  (
+
+    mapRn4 rnTyDecl	    ty_decls	    `thenRn4` \ new_ty_decls ->
+    mapRn4 rnSpecDataSig    specdata_sigs   `thenRn4` \ new_specdata_sigs ->
+    mapRn4 rnClassDecl	    class_decls	    `thenRn4` \ new_class_decls ->
+    mapRn4 rnInstDecl	    inst_decls	    `thenRn4` \ new_inst_decls ->
+    mapRn4 rnSpecInstSig    specinst_sigs   `thenRn4` \ new_specinst_sigs ->
+    rnDefaultDecl	    defaults	    `thenRn4` \ new_defaults ->
+    rnTopBinds binds			    `thenRn4` \ new_binds ->
+    mapRn4 rnIntSig	    int_sigs	    `thenRn4` \ new_int_sigs ->
+    rnFixes fixes			    `thenRn4` \ new_fixes ->
+    rnExports exports			    `thenRn4` \ new_exports ->
+
+    returnRn4 (HsModule mod_name
+		new_exports [{-imports finally clobbered-}] new_fixes
+		new_ty_decls new_specdata_sigs new_class_decls
+		new_inst_decls new_specinst_sigs new_defaults
+		new_binds new_int_sigs src_loc)
+    )
+
+rnExports Nothing = returnRn4 Nothing
+rnExports (Just exp_list)
+  = returnRn4 (Just (_trace "rnExports:trashing exports" []))
+\end{code}
+
+%*********************************************************
+%*							*
+\subsection{Type declarations}
+%*							*
+%*********************************************************
+
+@rnTyDecl@ uses the `global name function' to create a new type
+declaration in which local names have been replaced by their original
+names, reporting any unknown names.
+
+Renaming type variables is a pain. Because they now contain uniques,
+it is necessary to pass in an association list which maps a parsed
+tyvar to its Name representation. In some cases (type signatures of
+values), it is even necessary to go over the type first in order to
+get the set of tyvars used by it, make an assoc list, and then go over
+it again to rename the tyvars! However, we can also do some scoping
+checks at the same time.
+
+\begin{code}
+rnTyDecl :: ProtoNameTyDecl -> Rn4M RenamedTyDecl
+
+rnTyDecl (TyData context tycon tyvars condecls derivings pragmas src_loc)
+  = pushSrcLocRn4 src_loc		        (
+    lookupTyCon tycon		      `thenRn4` \ tycon' ->
+    mkTyVarNamesEnv src_loc tyvars    `thenRn4` \ (tv_env, tyvars') ->
+    rnContext tv_env context	      `thenRn4` \ context' ->
+    rnConDecls tv_env False condecls `thenRn4` \ condecls' ->
+    rn_derivs tycon' src_loc derivings `thenRn4` \ derivings' ->
+    recoverQuietlyRn4 (DataPragmas [] []) (
+	rnDataPragmas tv_env pragmas
+    )				      `thenRn4` \ pragmas' ->
+    returnRn4 (TyData context' tycon' tyvars' condecls' derivings' pragmas' src_loc)
+    )
+
+rnTyDecl (TyNew context tycon tyvars condecl derivings pragmas src_loc)
+  = pushSrcLocRn4 src_loc		        (
+    lookupTyCon tycon		      `thenRn4` \ tycon' ->
+    mkTyVarNamesEnv src_loc tyvars    `thenRn4` \ (tv_env, tyvars') ->
+    rnContext tv_env context	      `thenRn4` \ context' ->
+    rnConDecls tv_env False condecl   `thenRn4` \ condecl' ->
+    rn_derivs tycon' src_loc derivings `thenRn4` \ derivings' ->
+    recoverQuietlyRn4 (DataPragmas [] []) (
+	rnDataPragmas tv_env pragmas
+    )				      `thenRn4` \ pragmas' ->
+    returnRn4 (TyNew context' tycon' tyvars' condecl' derivings' pragmas' src_loc)
+    )
+
+rnTyDecl (TySynonym name tyvars ty src_loc)
+  = pushSrcLocRn4 src_loc		      (
+    lookupTyCon name		    `thenRn4` \ name' ->
+    mkTyVarNamesEnv src_loc tyvars  `thenRn4` \ (tv_env, tyvars') ->
+    rnMonoType False{-no invisible types-} tv_env ty
+				    `thenRn4` \ ty' ->
+    returnRn4 (TySynonym name' tyvars' ty' src_loc)
+    )
+
+rn_derivs tycon2 locn Nothing -- derivs not specified
+  = returnRn4 Nothing
+
+rn_derivs tycon2 locn (Just ds)
+  = mapRn4 (rn_deriv tycon2 locn) ds `thenRn4` \ derivs ->
+    returnRn4 (Just derivs)
+  where
+    rn_deriv tycon2 locn clas
+      = lookupClass clas	    `thenRn4` \ clas_name ->
+	case clas_name of
+	  ClassName key _ _ | key `is_elem` derivableClassKeys
+	    -> returnRn4 clas_name
+	  _ -> addErrRn4 (derivingNonStdClassErr clas locn) `thenRn4_`
+	       returnRn4 clas_name
+      where
+	is_elem = isIn "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
+	    -> Bool		    -- True <=> allowed to see invisible data-cons
+	    -> [ProtoNameConDecl]
+	    -> Rn4M [RenamedConDecl]
+
+rnConDecls tv_env invisibles_allowed con_decls
+  = mapRn4 rn_decl con_decls
+  where
+    lookup_fn
+      = if invisibles_allowed
+	then lookupValueEvenIfInvisible
+	else lookupValue
+
+    rn_decl (ConDecl name tys src_loc)
+      = pushSrcLocRn4 src_loc			  (
+	lookup_fn name		`thenRn4` \ new_name ->
+	mapRn4 rn_bang_ty tys	`thenRn4` \ new_tys  ->
+	returnRn4 (ConDecl new_name new_tys src_loc)
+	)
+
+    rn_decl (ConOpDecl ty1 op ty2 src_loc)
+      = pushSrcLocRn4 src_loc			  (
+	lookup_fn op	`thenRn4` \ new_op  ->
+	rn_bang_ty ty1  `thenRn4` \ new_ty1 ->
+	rn_bang_ty ty2  `thenRn4` \ new_ty2 ->
+	returnRn4 (ConOpDecl new_ty1 new_op new_ty2 src_loc)
+	)
+
+    rn_decl (NewConDecl name ty src_loc)
+      = pushSrcLocRn4 src_loc			  (
+	lookup_fn name		`thenRn4` \ new_name ->
+	rn_mono_ty ty		`thenRn4` \ new_ty  ->
+	returnRn4 (NewConDecl new_name new_ty src_loc)
+	)
+
+    rn_decl (RecConDecl con fields src_loc)
+      = panic "rnConDecls:RecConDecl"
+
+    ----------
+    rn_mono_ty = rnMonoType invisibles_allowed tv_env
+
+    rn_bang_ty (Banged ty)
+      = rn_mono_ty ty `thenRn4` \ new_ty ->
+	returnRn4 (Banged new_ty)
+    rn_bang_ty (Unbanged ty)
+      = rn_mono_ty ty `thenRn4` \ new_ty ->
+	returnRn4 (Unbanged new_ty)
+\end{code}
+
+%*********************************************************
+%*							*
+\subsection{SPECIALIZE data pragmas}
+%*							*
+%*********************************************************
+
+\begin{code}
+rnSpecDataSig :: ProtoNameSpecDataSig
+	      -> Rn4M RenamedSpecDataSig
+
+rnSpecDataSig (SpecDataSig tycon ty src_loc)
+  = pushSrcLocRn4 src_loc		(
+    let
+	tyvars = extractMonoTyNames eqProtoName ty
+    in
+    mkTyVarNamesEnv src_loc tyvars     	`thenRn4` \ (tv_env,_) ->
+    lookupTyCon tycon			`thenRn4` \ tycon' ->
+    rnMonoType False tv_env ty		`thenRn4` \ ty' ->
+    returnRn4 (SpecDataSig tycon' ty' src_loc)
+    )
+\end{code}
+
+%*********************************************************
+%*							*
+\subsection{Class declarations}
+%*							*
+%*********************************************************
+
+@rnClassDecl@ uses the `global name function' to create a new
+class declaration in which local names have been replaced by their
+original names, reporting any unknown names.
+
+\begin{code}
+rnClassDecl :: ProtoNameClassDecl -> Rn4M RenamedClassDecl
+
+rnClassDecl (ClassDecl context cname tyvar sigs mbinds pragmas src_loc)
+  = pushSrcLocRn4 src_loc			  (
+    mkTyVarNamesEnv src_loc [tyvar]	`thenRn4` \ (tv_env, [tyvar']) ->
+    rnContext tv_env context	    	`thenRn4` \ context' ->
+    lookupClass cname		    	`thenRn4` \ cname' ->
+    mapRn4 (rn_op cname' tv_env) sigs   `thenRn4` \ sigs' ->
+    rnMethodBinds cname' mbinds    	`thenRn4` \ mbinds' ->
+    recoverQuietlyRn4 NoClassPragmas (
+      rnClassPragmas pragmas
+    )					`thenRn4` \ pragmas' ->
+    returnRn4 (ClassDecl context' cname' tyvar' sigs' mbinds' pragmas' src_loc)
+    )
+  where
+    rn_op clas tv_env (ClassOpSig op ty pragma locn)
+      = pushSrcLocRn4 locn	    	      (
+	lookupClassOp clas op		`thenRn4` \ op_name ->
+	rnPolyType False tv_env ty	`thenRn4` \ new_ty  ->
+
+{-
+*** Please check here that tyvar' appears in new_ty ***
+*** (used to be in tcClassSig, but it's better here)
+***	    not_elem = isn'tIn "tcClassSigs"
+***	    -- Check that the class type variable is mentioned
+***	checkTc (clas_tyvar `not_elem` extractTyVarTemplatesFromTy local_ty)
+***		(methodTypeLacksTyVarErr clas_tyvar (_UNPK_ op_name) src_loc) `thenTc_`
+-}
+	recoverQuietlyRn4 NoClassOpPragmas (
+	    rnClassOpPragmas pragma
+	)				`thenRn4` \ new_pragma ->
+	returnRn4 (ClassOpSig op_name new_ty new_pragma locn)
+	)
+\end{code}
+
+
+%*********************************************************
+%*							*
+\subsection{Instance declarations}
+%*							*
+%*********************************************************
+
+
+@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 :: ProtoNameInstDecl -> Rn4M RenamedInstDecl
+
+rnInstDecl (InstDecl cname ty mbinds from_here modname uprags pragmas src_loc)
+  = pushSrcLocRn4 src_loc		 	  (
+    let
+	tyvars = extract_poly_ty_names ty
+    in
+    mkTyVarNamesEnv src_loc tyvars     	`thenRn4` \ (tv_env,_) ->
+    lookupClass cname 		     	`thenRn4` \ cname' ->
+    rnPolyType False{-no invisibles-} tv_env ty
+					`thenRn4` \ ty' ->
+    rnMethodBinds cname' mbinds	`thenRn4` \ mbinds' ->
+    mapRn4 (rn_uprag cname') uprags	`thenRn4` \ new_uprags ->
+    recoverQuietlyRn4 NoInstancePragmas (
+	rnInstancePragmas cname' tv_env pragmas
+    )					`thenRn4` \ new_pragmas ->
+    returnRn4 (InstDecl cname' ty' mbinds'
+			from_here modname new_uprags new_pragmas src_loc)
+    )
+  where
+    rn_uprag class_name (SpecSig op ty using locn)
+      = ASSERT(not (maybeToBool using))	-- ToDo: SPEC method with explicit spec_id
+	pushSrcLocRn4 src_loc 				(
+	lookupClassOp class_name op		`thenRn4` \ op_name ->
+	rnPolyType False nullTyVarNamesEnv ty	`thenRn4` \ new_ty ->
+	returnRn4 (SpecSig op_name new_ty Nothing locn)
+	)
+    rn_uprag class_name (InlineSig op locn)
+      = pushSrcLocRn4 locn	      	(
+	lookupClassOp class_name op	`thenRn4` \ op_name ->
+	returnRn4 (InlineSig op_name locn)
+	)
+    rn_uprag class_name (DeforestSig op locn)
+      = pushSrcLocRn4 locn            	(
+	lookupClassOp class_name op	`thenRn4` \ op_name ->
+	returnRn4 (DeforestSig op_name locn)
+	)
+    rn_uprag class_name (MagicUnfoldingSig op str locn)
+      = pushSrcLocRn4 locn		(
+	lookupClassOp class_name op	`thenRn4` \ op_name ->
+	returnRn4 (MagicUnfoldingSig op_name str locn)
+	)
+\end{code}
+
+%*********************************************************
+%*							*
+\subsection{@SPECIALIZE instance@ user-pragmas}
+%*							*
+%*********************************************************
+
+\begin{code}
+rnSpecInstSig :: ProtoNameSpecInstSig
+	      -> Rn4M RenamedSpecInstSig
+
+rnSpecInstSig (SpecInstSig clas ty src_loc)
+  = pushSrcLocRn4 src_loc		  (
+    let  tyvars = extractMonoTyNames eqProtoName ty  in
+    mkTyVarNamesEnv src_loc tyvars     	`thenRn4` \ (tv_env,_) ->
+    lookupClass clas			`thenRn4` \ new_clas ->
+    rnMonoType False tv_env ty		`thenRn4` \ new_ty ->
+    returnRn4 (SpecInstSig new_clas new_ty src_loc)
+    )
+\end{code}
+
+%*********************************************************
+%*							*
+\subsection{Default 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}
+rnDefaultDecl :: [ProtoNameDefaultDecl] -> Rn4M [RenamedDefaultDecl]
+
+rnDefaultDecl [] = returnRn4 []
+rnDefaultDecl [DefaultDecl tys src_loc]
+  = pushSrcLocRn4 src_loc $
+    mapRn4 (rnMonoType False nullTyVarNamesEnv) tys `thenRn4` \ tys' ->
+    returnRn4 [DefaultDecl tys' src_loc]
+rnDefaultDecl defs@(d:ds)
+  = addErrRn4 (dupDefaultDeclErr defs) `thenRn4_`
+    rnDefaultDecl [d]
+\end{code}
+
+%*************************************************************************
+%*									*
+\subsection{Type signatures from interfaces}
+%*									*
+%*************************************************************************
+
+Non-interface type signatures (which may include user-pragmas) are
+handled with @HsBinds@.
+
+@ClassOpSigs@ are dealt with in class declarations.
+
+\begin{code}
+rnIntSig :: ProtoNameSig -> Rn4M RenamedSig
+
+rnIntSig (Sig name ty pragma src_loc)
+  = pushSrcLocRn4 src_loc			      (
+    lookupValue name				`thenRn4` \ new_name ->
+    rnPolyType False nullTyVarNamesEnv ty 	`thenRn4` \ new_ty   ->
+    recoverQuietlyRn4 NoGenPragmas (
+	rnGenPragmas pragma
+    )					    `thenRn4` \ new_pragma ->
+    returnRn4 (Sig new_name new_ty new_pragma src_loc)
+    )
+\end{code}
+
+%*************************************************************************
+%*									*
+\subsection{Fixity declarations}
+%*									*
+%*************************************************************************
+
+\begin{code}
+rnFixes :: [ProtoNameFixityDecl]  -> Rn4M [RenamedFixityDecl]
+
+rnFixes fixities
+  = mapRn4 rn_fixity fixities `thenRn4` \ fixes_maybe ->
+    returnRn4 (catMaybes fixes_maybe)
+  where
+    rn_fixity (InfixL name i)
+      = lookupFixityOp name `thenRn4` \ res ->
+	returnRn4 (
+	  case res of
+	    Just name2 ->  Just (InfixL name2 i)
+	    Nothing    ->  Nothing
+	)
+
+    rn_fixity (InfixR name i)
+      = lookupFixityOp name	`thenRn4` \ res ->
+	returnRn4 (
+	  case res of
+	    Just name2 ->  Just (InfixR name2 i)
+	    Nothing    ->  Nothing
+	)
+
+    rn_fixity (InfixN name i)
+      = lookupFixityOp name	`thenRn4` \ res ->
+	returnRn4 (
+	  case res of
+	    Just name2 ->  Just (InfixN name2 i)
+	    Nothing    ->  Nothing
+	)
+\end{code}
+
+%*********************************************************
+%*							*
+\subsection{Support code to rename types}
+%*							*
+%*********************************************************
+
+\begin{code}
+rnPolyType :: Bool		-- True <=> "invisible" tycons (in pragmas) allowed
+	    -> TyVarNamesEnv
+	    -> ProtoNamePolyType
+	    -> Rn4M RenamedPolyType
+
+rnPolyType invisibles_allowed tv_env (HsForAllTy tvs ctxt ty)
+  = rn_poly_help invisibles_allowed tv_env tvs ctxt ty
+
+rnPolyType invisibles_allowed tv_env poly_ty@(HsPreForAllTy ctxt ty)
+  = rn_poly_help invisibles_allowed tv_env forall_tyvars ctxt ty
+  where
+    mentioned_tyvars = extract_poly_ty_names poly_ty
+
+    forall_tyvars = mentioned_tyvars `minus_list` domTyVarNamesEnv tv_env
+
+	-- URGH! Why is this here?  SLPJ
+	-- Because we are doing very delicate comparisons
+	-- (eqProtoName and all that); if we got rid of
+	-- that, then we could use ListSetOps stuff.  WDP
+    minus_list xs ys = [ x | x <- xs, not (x `elemProtoNames` ys)]
+
+------------
+extract_poly_ty_names (HsPreForAllTy ctxt ty)
+  = extractCtxtTyNames eqProtoName ctxt
+    `union_list`
+    extractMonoTyNames eqProtoName ty
+  where
+    -- see comment above
+    union_list []     [] = []
+    union_list []     b	 = b
+    union_list a      [] = a
+    union_list (a:as) b
+      | a `elemProtoNames` b = union_list as b
+      | otherwise            = a : union_list as b
+
+------------
+rn_poly_help :: Bool
+	     -> TyVarNamesEnv
+	     -> [ProtoName]
+	     -> ProtoNameContext
+	     -> ProtoNameMonoType
+	     -> Rn4M RenamedPolyType
+
+rn_poly_help invisibles_allowed tv_env tyvars ctxt ty
+  = getSrcLocRn4 				`thenRn4` \ src_loc ->
+    mkTyVarNamesEnv src_loc tyvars	 	`thenRn4` \ (tv_env1, new_tyvars) ->
+    let
+	tv_env2 = catTyVarNamesEnvs tv_env1 tv_env
+    in
+    rnContext tv_env2 ctxt			`thenRn4` \ new_ctxt ->
+    rnMonoType invisibles_allowed tv_env2 ty	`thenRn4` \ new_ty ->
+    returnRn4 (HsForAllTy new_tyvars new_ctxt new_ty)
+\end{code}
+
+\begin{code}
+rnMonoType :: Bool		-- allowed to look at invisible tycons
+	    -> TyVarNamesEnv
+	    -> ProtoNameMonoType
+	    -> Rn4M RenamedMonoType
+
+rnMonoType invisibles_allowed  tv_env (MonoTyVar tyvar)
+  = lookupTyVarName tv_env tyvar 	`thenRn4` \ tyvar' ->
+    returnRn4 (MonoTyVar tyvar')
+
+rnMonoType invisibles_allowed  tv_env (MonoListTy ty)
+  = rnMonoType invisibles_allowed tv_env ty	`thenRn4` \ ty' ->
+    returnRn4 (MonoListTy ty')
+
+rnMonoType invisibles_allowed  tv_env (MonoFunTy ty1 ty2)
+  = andRn4 MonoFunTy (rnMonoType invisibles_allowed tv_env ty1)
+		     (rnMonoType invisibles_allowed tv_env ty2)
+
+rnMonoType invisibles_allowed  tv_env (MonoTupleTy tys)
+  = mapRn4 (rnMonoType invisibles_allowed tv_env) tys `thenRn4` \ tys' ->
+    returnRn4 (MonoTupleTy tys')
+
+rnMonoType invisibles_allowed tv_env (MonoTyApp name tys)
+  = let
+	lookup_fn = if isAvarid (getOccurrenceName name) 
+		    then lookupTyVarName tv_env
+		    else if invisibles_allowed
+		         then lookupTyConEvenIfInvisible
+		         else lookupTyCon
+    in
+    lookup_fn name					`thenRn4` \ name' ->
+    mapRn4 (rnMonoType invisibles_allowed tv_env) tys	`thenRn4` \ tys' ->
+    returnRn4 (MonoTyApp name' tys')
+
+-- for unfoldings only:
+
+rnMonoType invisibles_allowed tv_env (MonoForAllTy tyvars_w_kinds ty)
+  = getSrcLocRn4 				`thenRn4` \ src_loc ->
+    mkTyVarNamesEnv src_loc tyvars	 	`thenRn4` \ (tv_env1, new_tyvars) ->
+    let
+	tv_env2 = catTyVarNamesEnvs tv_env1 tv_env
+    in
+    rnMonoType invisibles_allowed tv_env2 ty	`thenRn4` \ ty' ->
+    returnRn4 (MonoForAllTy (new_tyvars `zip` kinds) ty')
+  where
+    (tyvars, kinds) = unzip tyvars_w_kinds
+
+rnMonoType invisibles_allowed tv_env (MonoDictTy clas ty)
+  = lookupClass clas		`thenRn4` \ new_clas ->
+    rnMonoType invisibles_allowed tv_env ty	`thenRn4` \ new_ty ->
+    returnRn4 (MonoDictTy new_clas new_ty)
+\end{code}
+
+\begin{code}
+rnContext :: TyVarNamesEnv -> ProtoNameContext -> Rn4M RenamedContext
+
+rnContext tv_env ctxt
+  = mapRn4 rn_ctxt ctxt
+  where
+    rn_ctxt (clas, tyvar)
+     = lookupClass clas	    	    `thenRn4` \ clas_name ->
+       lookupTyVarName tv_env tyvar `thenRn4` \ tyvar_name ->
+       returnRn4 (clas_name, tyvar_name)
+\end{code}
+
+%*********************************************************
+%*							*
+\subsection{Support code to rename various pragmas}
+%*							*
+%*********************************************************
+
+\begin{code}
+rnDataPragmas tv_env (DataPragmas cons specs)
+  = rnConDecls tv_env True{-invisibles allowed-} cons `thenRn4` \ new_cons ->
+    mapRn4 types_n_spec specs			       `thenRn4` \ new_specs ->
+    returnRn4 (DataPragmas new_cons new_specs)
+  where
+    types_n_spec ty_maybes
+      = mapRn4 (rn_ty_maybe nullTyVarNamesEnv) ty_maybes
+\end{code}
+
+\begin{code}
+rnClassOpPragmas NoClassOpPragmas = returnRn4 NoClassOpPragmas
+
+rnClassOpPragmas (ClassOpPragmas dsel defm)
+  = recoverQuietlyRn4 NoGenPragmas (rnGenPragmas dsel) `thenRn4` \ new_dsel ->
+    recoverQuietlyRn4 NoGenPragmas (rnGenPragmas defm) `thenRn4` \ new_defm ->
+    returnRn4 (ClassOpPragmas new_dsel new_defm)
+\end{code}
+
+\begin{code}
+rnClassPragmas NoClassPragmas = returnRn4 NoClassPragmas
+
+rnClassPragmas (SuperDictPragmas sds)
+  = mapRn4 rnGenPragmas sds	`thenRn4` \ new_sds ->
+    returnRn4 (SuperDictPragmas new_sds)
+\end{code}
+
+NB: In various cases around here, we don't @recoverQuietlyRn4@ around
+calls to @rnGenPragmas@; not really worth it.
+
+\begin{code}
+rnInstancePragmas _ _ NoInstancePragmas = returnRn4 NoInstancePragmas
+
+rnInstancePragmas _ _ (SimpleInstancePragma dfun)
+  = rnGenPragmas dfun	`thenRn4` \ new_dfun ->
+    returnRn4 (SimpleInstancePragma new_dfun)
+
+rnInstancePragmas clas tv_env (ConstantInstancePragma dfun constms)
+  = recoverQuietlyRn4 NoGenPragmas (
+	rnGenPragmas dfun
+    )				`thenRn4` \ new_dfun ->
+    mapRn4 name_n_gen constms	`thenRn4` \ new_constms ->
+    returnRn4 (ConstantInstancePragma new_dfun new_constms)
+  where
+    name_n_gen (op, gen)
+      = lookupClassOp clas op	`thenRn4` \ new_op ->
+	rnGenPragmas gen	`thenRn4` \ new_gen ->
+	returnRn4 (new_op, new_gen)
+
+rnInstancePragmas clas tv_env (SpecialisedInstancePragma dfun specs)
+  = recoverQuietlyRn4 NoGenPragmas (
+	rnGenPragmas dfun
+    )				`thenRn4` \ new_dfun ->
+    mapRn4 types_n_spec specs	`thenRn4` \ new_specs ->
+    returnRn4 (SpecialisedInstancePragma new_dfun new_specs)
+  where
+    types_n_spec (ty_maybes, dicts_to_ignore, inst)
+      = mapRn4 (rn_ty_maybe tv_env) ty_maybes	`thenRn4` \ new_tys ->
+	rnInstancePragmas clas tv_env inst 	`thenRn4` \ new_inst ->
+	returnRn4 (new_tys, dicts_to_ignore, new_inst)
+\end{code}
+
+And some general pragma stuff: (Not sure what, if any, of this would
+benefit from a TyVarNamesEnv passed in.... [ToDo])
+\begin{code}
+rnGenPragmas :: ProtoNameGenPragmas -> Rn4M RenamedGenPragmas
+
+rnGenPragmas NoGenPragmas = returnRn4 NoGenPragmas
+
+rnGenPragmas (GenPragmas arity upd def strict unfold specs)
+  = recoverQuietlyRn4 NoImpUnfolding (
+	rn_unfolding  unfold
+    )				`thenRn4` \ new_unfold ->
+    rn_strictness strict	`thenRn4` \ new_strict ->
+    recoverQuietlyRn4 [] (
+	mapRn4 types_n_gen specs
+    )				`thenRn4` \ new_specs ->
+    returnRn4 (GenPragmas arity upd def new_strict new_unfold new_specs)
+  where
+    rn_unfolding NoImpUnfolding = returnRn4 NoImpUnfolding
+
+    rn_unfolding (ImpMagicUnfolding str) = returnRn4 (ImpMagicUnfolding str)
+
+    rn_unfolding (ImpUnfolding guidance core)
+      = rn_core nullTyVarNamesEnv core	`thenRn4` \ new_core ->
+    	returnRn4 (ImpUnfolding guidance new_core)
+
+    ------------
+    rn_strictness NoImpStrictness = returnRn4 NoImpStrictness
+
+    rn_strictness (ImpStrictness is_bot ww_info wrkr_info)
+      = recoverQuietlyRn4 NoGenPragmas (
+	    rnGenPragmas wrkr_info
+	) 			`thenRn4` \ new_wrkr_info ->
+	returnRn4 (ImpStrictness is_bot ww_info new_wrkr_info)
+
+    -------------
+    types_n_gen (ty_maybes, dicts_to_ignore, gen)
+      = mapRn4 (rn_ty_maybe no_env) ty_maybes	`thenRn4` \ new_tys ->
+	recoverQuietlyRn4 NoGenPragmas (
+	    rnGenPragmas gen
+	)				`thenRn4` \ new_gen ->
+	returnRn4 (new_tys, dicts_to_ignore, new_gen)
+      where
+	no_env = nullTyVarNamesEnv
+
+------------
+rn_ty_maybe tv_env Nothing = returnRn4 Nothing
+
+rn_ty_maybe tv_env (Just ty)
+  = rnMonoType True{-invisibles OK-} tv_env ty  `thenRn4` \ new_ty ->
+    returnRn4 (Just new_ty)
+
+------------
+rn_core tvenv (UfVar v)
+  = rn_uf_id tvenv v	`thenRn4` \ vname ->
+    returnRn4 (UfVar vname)
+
+rn_core tvenv (UfLit lit)
+  = returnRn4 (UfLit lit)
+
+rn_core tvenv (UfCon con tys as)
+  = lookupValueEvenIfInvisible con	`thenRn4` \ new_con ->
+    mapRn4 (rn_core_type tvenv) tys	`thenRn4` \ new_tys ->
+    mapRn4 (rn_atom tvenv) as   	`thenRn4` \ new_as ->
+    returnRn4 (UfCon new_con new_tys new_as)
+
+rn_core tvenv (UfPrim op tys as)
+  = rn_core_primop tvenv op		`thenRn4` \ new_op ->
+    mapRn4 (rn_core_type tvenv) tys	`thenRn4` \ new_tys ->
+    mapRn4 (rn_atom tvenv) as   	`thenRn4` \ new_as ->
+    returnRn4 (UfPrim new_op new_tys new_as)
+
+rn_core tvenv (UfLam binder body)
+  = rn_binder tvenv binder `thenRn4` \ (b,ty) ->
+    extendSS [b] (rn_core tvenv body) `thenRn4` \ new_body ->
+    returnRn4 (UfLam (b,ty) new_body)
+
+rn_core tvenv (UfApp fun arg)
+  = rn_core tvenv fun	`thenRn4` \ new_fun ->
+    rn_atom tvenv arg	`thenRn4` \ new_arg ->
+    returnRn4 (UfApp new_fun new_arg)
+
+rn_core tvenv (UfCase expr alts)
+  = rn_core tvenv expr	    `thenRn4` \ new_expr ->
+    rn_alts 	  alts	    `thenRn4` \ new_alts ->
+    returnRn4 (UfCase new_expr new_alts)
+  where
+    rn_alts (UfCoAlgAlts alg_alts deflt)
+      = mapRn4 rn_alg_alt alg_alts  `thenRn4` \ new_alts ->
+	rn_deflt deflt	    	    `thenRn4` \ new_deflt ->
+	returnRn4 (UfCoAlgAlts new_alts new_deflt)
+      where
+	rn_alg_alt (con, params, rhs)
+	  = lookupValueEvenIfInvisible con  `thenRn4` \ new_con ->
+	    mapRn4 (rn_binder tvenv) params `thenRn4` \ new_params ->
+	    let
+		bs = [ b | (b, ty) <- new_params ]
+	    in
+	    extendSS bs (rn_core tvenv rhs) `thenRn4` \ new_rhs ->
+	    returnRn4 (new_con, new_params, new_rhs)
+
+    rn_alts (UfCoPrimAlts prim_alts deflt)
+      = mapRn4 rn_prim_alt prim_alts  `thenRn4` \ new_alts ->
+	rn_deflt deflt		      `thenRn4` \ new_deflt ->
+	returnRn4 (UfCoPrimAlts new_alts new_deflt)
+      where
+	rn_prim_alt (lit, rhs)
+	  = rn_core tvenv rhs	`thenRn4` \ new_rhs ->
+	    returnRn4 (lit, new_rhs)
+
+    rn_deflt UfCoNoDefault = returnRn4 UfCoNoDefault
+    rn_deflt (UfCoBindDefault b rhs)
+      = rn_binder tvenv b		      `thenRn4` \ new_b@(binder, ty) ->
+	extendSS [binder] (rn_core tvenv rhs) `thenRn4` \ new_rhs ->
+	returnRn4 (UfCoBindDefault new_b new_rhs)
+
+rn_core tvenv (UfLet bind body)
+  = rn_bind bind			      `thenRn4` \ (new_bind, new_binders) ->
+    extendSS new_binders (rn_core tvenv body) `thenRn4` \ new_body ->
+    returnRn4 (UfLet new_bind new_body)
+  where
+    rn_bind (UfCoNonRec b rhs)
+      = rn_binder tvenv b	`thenRn4` \ new_b@(binder, ty) ->
+	rn_core   tvenv rhs 	`thenRn4` \ new_rhs ->
+	returnRn4 (UfCoNonRec new_b new_rhs, [binder])
+
+    rn_bind (UfCoRec pairs)
+      = -- conjure up Names; we do this differently than
+	-- elsewhere for Core, because of the recursion here;
+	-- no deep issue.
+	-- [BEFORE IT WAS "FIXED"... 94/05...]
+ 	-- [Andy -- It *was* a 'deep' issue to me...]
+	-- [Will -- Poor wee soul.]
+
+	getSrcLocRn4			    `thenRn4` \ locn ->
+	namesFromProtoNames "core variable"
+	  [ (b, locn) | ((b,_),_) <- pairs] `thenRn4` \ binders ->
+
+	extendSS binders (mapRn4 rn_pair (pairs `zip` binders)) `thenRn4` \ new_pairs ->
+	returnRn4 (UfCoRec new_pairs, binders)
+      where
+	rn_pair (((b, ty), rhs), new_b)
+	  = rn_core_type tvenv ty	`thenRn4` \ new_ty ->
+	    rn_core      tvenv rhs	`thenRn4` \ new_rhs ->
+	    returnRn4 ((new_b, new_ty), new_rhs)
+
+rn_core tvenv (UfSCC uf_cc body)
+  = rn_cc uf_cc		`thenRn4` \ new_cc ->
+    rn_core tvenv body	`thenRn4` \ new_body ->
+    returnRn4 (UfSCC new_cc new_body)
+  where
+    rn_cc (UfAutoCC id m g is_dupd is_caf)
+      = rn_uf_id tvenv id	`thenRn4` \ new_id ->
+	returnRn4 (UfAutoCC new_id m g is_dupd is_caf)
+
+    rn_cc (UfDictCC id m g is_caf is_dupd)
+      = rn_uf_id tvenv id	`thenRn4` \ new_id ->
+	returnRn4 (UfDictCC new_id m g is_dupd is_caf)
+
+    -- the rest are boring:
+    rn_cc (UfPreludeDictsCC d) = returnRn4 (UfPreludeDictsCC d)
+    rn_cc (UfAllDictsCC m g d) = returnRn4 (UfAllDictsCC m g d)
+    rn_cc (UfUserCC n m g d c) = returnRn4 (UfUserCC n m g d c)
+
+------------
+rn_core_primop tvenv (UfCCallOp str is_casm may_gc arg_tys res_ty)
+  = mapRn4 (rn_core_type tvenv) arg_tys	`thenRn4` \ new_arg_tys ->
+    rn_core_type tvenv res_ty		`thenRn4` \ new_res_ty  ->
+    returnRn4 (UfCCallOp str is_casm may_gc new_arg_tys new_res_ty)
+rn_core_primop tvenv (UfOtherOp op)
+  = returnRn4 (UfOtherOp op)
+
+------------
+rn_uf_id tvenv (BoringUfId v)
+  = lookupValueEvenIfInvisible v    `thenRn4` \ vname ->
+    returnRn4 (BoringUfId vname)
+
+rn_uf_id tvenv (SuperDictSelUfId c sc)
+  = lookupClass{-EvenIfInvisible-} c	`thenRn4` \ new_c ->
+    lookupClass{-EvenIfInvisible-} sc	`thenRn4` \ new_sc ->
+    returnRn4 (SuperDictSelUfId new_c new_sc)
+
+rn_uf_id tvenv (ClassOpUfId c op)
+  = lookupClass{-EvenIfInvisible-} c	    	`thenRn4` \ new_c ->
+    lookupClassOp{-EvenIfInvisible-} new_c op	`thenRn4` \ new_op ->
+    returnRn4 (ClassOpUfId new_c new_op)
+
+rn_uf_id tvenv (DictFunUfId c ty)
+  = lookupClass{-EvenIfInvisible-} c	`thenRn4` \ new_c ->
+    rn_core_type tvenv ty   	    	`thenRn4` \ new_ty ->
+    returnRn4 (DictFunUfId new_c new_ty)
+
+rn_uf_id tvenv (ConstMethodUfId c op ty)
+  = lookupClass{-EvenIfInvisible-} c	      `thenRn4` \ new_c ->
+    lookupClassOp{-EvenIfInvisible-} new_c op `thenRn4` \ new_op ->
+    rn_core_type tvenv ty   	    	      `thenRn4` \ new_ty ->
+    returnRn4 (ConstMethodUfId new_c new_op new_ty)
+
+rn_uf_id tvenv (DefaultMethodUfId c op)
+  = lookupClass{-EvenIfInvisible-} c	    	`thenRn4` \ new_c ->
+    lookupClassOp{-EvenIfInvisible-} new_c op	`thenRn4` \ new_op ->
+    returnRn4 (DefaultMethodUfId new_c new_op)
+
+rn_uf_id tvenv (SpecUfId unspec ty_maybes)
+  = rn_uf_id tvenv unspec		 `thenRn4` \ new_unspec ->
+    mapRn4 (rn_ty_maybe tvenv) ty_maybes `thenRn4` \ new_ty_maybes ->
+    returnRn4 (SpecUfId new_unspec new_ty_maybes)
+
+rn_uf_id tvenv (WorkerUfId unwrkr)
+  = rn_uf_id tvenv unwrkr	`thenRn4` \ new_unwrkr ->
+    returnRn4 (WorkerUfId new_unwrkr)
+
+------------
+rn_binder tvenv (b, ty)
+  = getSrcLocRn4			`thenRn4` \ src_loc ->
+    namesFromProtoNames "binder in core unfolding" [(b, src_loc)]
+					`thenRn4` \ [new_b] ->
+    rn_core_type tvenv ty		`thenRn4` \ new_ty ->
+    returnRn4 (new_b, new_ty)
+
+------------
+rn_atom tvenv (UfCoLitAtom l) = returnRn4 (UfCoLitAtom l)
+rn_atom tvenv (UfCoVarAtom v)
+  = rn_uf_id tvenv v			`thenRn4` \ vname ->
+    returnRn4 (UfCoVarAtom vname)
+
+------------
+rn_core_type_maybe tvenv Nothing = returnRn4 Nothing
+rn_core_type_maybe tvenv (Just ty)
+  = rn_core_type tvenv ty `thenRn4` \ new_ty ->
+    returnRn4 (Just new_ty)
+
+------------
+rn_core_type tvenv ty
+  = rnPolyType True{-invisible tycons OK-} tvenv ty
+\end{code}
+
+
+\begin{code}
+derivingNonStdClassErr clas locn sty
+  = ppHang (ppStr "Non-standard class in deriving")
+         4 (ppCat [ppr sty clas, ppr sty locn])
+
+dupDefaultDeclErr defs sty
+  = ppHang (ppStr "Duplicate default declarations")
+         4 (ppAboves (map pp_def_loc defs))
+  where
+    pp_def_loc (DefaultDecl _ src_loc) = ppr sty src_loc
+\end{code}
diff --git a/ghc/compiler/rename/RnUtils.lhs b/ghc/compiler/rename/RnUtils.lhs
new file mode 100644
index 0000000000..1d4e45ba12
--- /dev/null
+++ b/ghc/compiler/rename/RnUtils.lhs
@@ -0,0 +1,138 @@
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+%
+\section[RnUtils]{Functions used by both renaming passes}
+
+\begin{code}
+#include "HsVersions.h"
+
+module RnUtils (
+	mkGlobalNameFun, mkNameFun,
+	GlobalNameMapper(..),  GlobalNameMappers(..),
+	PreludeNameMapper(..), PreludeNameMappers(..),
+
+	dupNamesErr -- used in various places
+    ) where
+
+import Ubiq{-uitous-}
+
+import Bag		( bagToList, Bag )
+import FiniteMap	( lookupFM, listToFM )
+import Name		( Name{-instances-} )
+import Outputable	( pprNonOp )
+import PprStyle		( PprStyle(..) )
+import Pretty
+import ProtoName	( ProtoName(..) )
+import Util		( cmpPString, removeDups, pprPanic, panic )
+\end{code}
+
+\begin{code}
+type GlobalNameMapper  = ProtoName -> Maybe Name
+type GlobalNameMappers = (GlobalNameMapper, GlobalNameMapper)
+
+type PreludeNameMapper = FAST_STRING -> Maybe Name
+type PreludeNameMappers = (PreludeNameMapper,		-- Values
+			PreludeNameMapper		-- Types and classes
+		       )
+\end{code}
+
+\begin{code}
+mkGlobalNameFun :: FAST_STRING		-- The module name
+		-> PreludeNameMapper 	-- The prelude things
+		-> [(ProtoName, Name)]	-- The local and imported things
+		-> GlobalNameMapper	-- The global name function
+
+mkGlobalNameFun this_module prel_nf alist
+  = the_fun
+  where
+    the_fun (Prel n)	  = Just n
+    the_fun (Unk s) 	  = case (unk_fun s) of
+			      Just n  -> Just n
+			      Nothing -> prel_nf s
+    the_fun (Imp m d _ _) = imp_fun (d, m) -- NB: module-name 2nd!
+
+    -- Things in the domain of the prelude function shouldn't be put
+    -- in the unk_fun; because the prel_nf will catch them.
+    -- This can arise if, for example, an interface gives a signature
+    -- for a prelude thing.
+    --
+    -- Neither should they be in the domain of the imp_fun, because
+    -- prelude things will have been converted to Prel x rather than
+    -- Imp p q r s.
+    --
+    -- So we strip out prelude things from the alist; this is not just
+    -- desirable, it's essential because get_orig and get_local don't handle
+    -- prelude things.
+
+    non_prel_alist = filter non_prel alist
+
+    non_prel (Prel _, _) = False
+    non_prel other       = True
+
+    -- unk_fun looks up local names (just strings),
+    -- imp_fun looks up original names: (string,string) pairs
+    unk_fun = lookupFM (listToFM [(get_local pn,n) | (pn,n) <- non_prel_alist])
+    imp_fun = lookupFM (listToFM [(get_orig  pn,n) | (pn,n) <- non_prel_alist])
+
+		-- the lists *are* sorted by *some* ordering (by local
+		-- names), but not generally, and not in some way we
+		-- are going to rely on.
+
+    get_local :: ProtoName -> FAST_STRING
+    get_local (Unk s)       = s
+    get_local (Imp _ _ _ l) = l
+    get_local (Prel n)	    = pprPanic "get_local: " (ppr PprShowAll n)
+
+    get_orig :: ProtoName -> (FAST_STRING, FAST_STRING) -- **NB**! module-name 2nd!
+    get_orig (Unk s)       = (s, this_module)
+    get_orig (Imp m d _ _) = (d, m)
+    get_orig (Prel n)	    = pprPanic "get_orig: " (ppr PprShowAll n)
+\end{code}
+
+
+@mkNameFun@ builds a function from @ProtoName@s to things, where a
+``thing'' is either a @ProtoName@ (in the case of values), or a
+@(ProtoName, ProtoName -> ProtoName)@ pair in the case of types and
+classes.  It takes:
+
+\begin{itemize}
+\item	The name of the interface
+\item	A bag of new string-to-thing bindings to add,
+
+\item	An extractor function, to get a @ProtoName@ out of a thing,
+	for use in error messages.
+\end{itemize}
+The function it returns only expects to see @Unk@ things.
+
+@mkNameFun@ checks for clashes in the domain of the new bindings.
+
+ToDo: it should check for clashes with the prelude bindings too.
+
+\begin{code}
+mkNameFun :: Bag (FAST_STRING, thing)	    -- Value bindings
+	  -> (FAST_STRING -> Maybe thing,   -- The function to use
+	      [[(FAST_STRING,thing)]])	    -- Duplicates, if any
+
+mkNameFun the_bag
+  = case (removeDups cmp (bagToList the_bag)) of { (no_dup_list, dups) ->
+    case (lookupFM (listToFM no_dup_list))    of { the_fun ->
+    (the_fun, dups) }}
+  where
+    cmp :: (FAST_STRING, a) -> (FAST_STRING, a) -> TAG_
+
+    cmp (s1,_) (s2,_) = _CMP_STRING_ s1 s2
+\end{code}
+
+\begin{code}
+dupNamesErr descriptor ((first_pname,locn1) : dup_things) sty
+  = ppAboves (first_item : map dup_item dup_things)
+  where
+    first_item
+      = ppBesides [ ppr PprForUser locn1,
+	    ppStr ": multiple declarations of a ", ppStr descriptor, ppStr ": ",
+	    pprNonOp sty first_pname ]
+
+    dup_item (pname, locn)
+      = ppBesides [ ppr PprForUser locn,
+	    ppStr ": here was another declaration of `", pprNonOp sty pname, ppStr "'" ]
+\end{code}
diff --git a/ghc/compiler/simplCore/AnalFBWW.hi b/ghc/compiler/simplCore/AnalFBWW.hi
deleted file mode 100644
index f610a4e431..0000000000
--- a/ghc/compiler/simplCore/AnalFBWW.hi
+++ /dev/null
@@ -1,7 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface AnalFBWW where
-import CmdLineOpts(GlobalSwitch)
-import CoreSyn(CoreBinding)
-import Id(Id)
-analFBWW :: (GlobalSwitch -> Bool) -> [CoreBinding Id Id] -> [CoreBinding Id Id]
-
diff --git a/ghc/compiler/simplCore/AnalFBWW.lhs b/ghc/compiler/simplCore/AnalFBWW.lhs
index ac9414d133..c2b8f8d569 100644
--- a/ghc/compiler/simplCore/AnalFBWW.lhs
+++ b/ghc/compiler/simplCore/AnalFBWW.lhs
@@ -1,5 +1,5 @@
 %
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1994
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
 %
 \section[AnalFBWW]{Spoting good functions for splitting into workers/wrappers}
 
@@ -8,32 +8,25 @@
 
 module AnalFBWW ( analFBWW ) where
 
-IMPORT_Trace
-import Outputable
-import Pretty
-
-import PlainCore
-import TaggedCore
 import Util
 import Id               	( addIdFBTypeInfo )
-import IdInfo           
-import IdEnv
-import AbsPrel          ( foldrId, buildId,
-                          nilDataCon, consDataCon, mkListTy, mkFunTy,
-                          unpackCStringAppendId
-                        )
+import IdInfo
+import PrelInfo          ( foldrId, buildId,
+			  nilDataCon, consDataCon, mkListTy, mkFunTy,
+			  unpackCStringAppendId
+			)
 import BinderInfo
 import SimplEnv		-- everything
-import NewOccurAnal
+import OccurAnal	-- OLD: was NewOccurAnal
 import Maybes
 
 \end{code}
 
 \begin{code}
-analFBWW 
-        :: (GlobalSwitch -> Bool)
-        -> PlainCoreProgram 
-        -> PlainCoreProgram
+analFBWW
+	:: (GlobalSwitch -> Bool)
+	-> [CoreBinding]
+	-> [CoreBinding]
 analFBWW switch top_binds = trace "ANALFBWW" (snd anno)
  where
 	anals :: [InBinding]
@@ -42,7 +35,7 @@ analFBWW switch top_binds = trace "ANALFBWW" (snd anno)
 \end{code}
 
 \begin{code}
-data OurFBType 
+data OurFBType
 	= IsFB FBType
 	| IsNotFB		-- unknown
 	| IsCons		-- \ xy -> (:) ty xy
@@ -50,7 +43,7 @@ data OurFBType
 		deriving (Eq)
 	-- We only handle *reasonable* types
 	-- Later might add concept of bottom
-	-- because foldr f z (<bottom>) = <bottom>		
+	-- because foldr f z (<bottom>) = <bottom>
 unknownFBType  = IsNotFB
 goodProdFBType = IsFB (FBType [] FBGoodProd)
 
@@ -58,7 +51,7 @@ maybeFBtoFB (Just ty) = ty
 maybeFBtoFB (Nothing) = IsNotFB
 
 addArgs :: Int -> OurFBType -> OurFBType
-addArgs n (IsFB (FBType args prod)) 
+addArgs n (IsFB (FBType args prod))
 	= IsFB (FBType (take n (repeat FBBadConsum) ++ args) prod)
 addArgs n IsNotFB = IsNotFB
 addArgs n IsCons = panic "adding argument to a cons"
@@ -93,16 +86,16 @@ analExprFBWW :: InExpr -> IdEnv OurFBType -> OurFBType
 --
 -- [ build g ]  	is a good context
 --
-analExprFBWW (CoApp (CoTyApp (CoVar bld) _) _) env  
+analExprFBWW (App (CoTyApp (Var bld) _) _) env
 	| bld == buildId         = goodProdFBType
 
 --
 -- [ foldr (:) ys xs ] ==> good
 --			(but better if xs)
 --
-analExprFBWW (CoApp (CoApp (CoApp 
-		(CoTyApp (CoTyApp (CoVar foldr_id) _) _) (CoVarAtom c)) _) _)
-		env 
+analExprFBWW (App (App (App
+		(CoTyApp (CoTyApp (Var foldr_id) _) _) (VarArg c)) _) _)
+		env
 	| pprTrace ("FOLDR:" ++ show (foldr_id == foldrId,isCons c))
 		(ppr PprDebug foldr_id)
 		(foldr_id == foldrId && isCons c) = goodProdFBType
@@ -110,44 +103,46 @@ analExprFBWW (CoApp (CoApp (CoApp
 	isCons c = case lookupIdEnv env c of
 		    Just IsCons -> True
 		    _ -> False
-analExprFBWW (CoVar v) env       = maybeFBtoFB (lookupIdEnv env v)
-analExprFBWW (CoLit _) _         = unknownFBType
+analExprFBWW (Var v) env       = maybeFBtoFB (lookupIdEnv env v)
+analExprFBWW (Lit _) _         = unknownFBType
 
 --
 -- [ x : xs ]  ==> good iff [ xs ] is good
 --
 
-analExprFBWW (CoCon con _ [_,CoVarAtom y]) env     
+analExprFBWW (Con con _ [_,VarArg y]) env
 	| con == consDataCon = maybeFBtoFB (lookupIdEnv env y)
 --
 -- [] is good
 --
-analExprFBWW (CoCon con _ []) _     
+analExprFBWW (Con con _ []) _
 	| con == nilDataCon = goodProdFBType
-analExprFBWW (CoCon _ _ _) _     = unknownFBType
-analExprFBWW (CoPrim _ _ _) _    = unknownFBType
+analExprFBWW (Con _ _ _) _     = unknownFBType
+analExprFBWW (Prim _ _ _) _    = unknownFBType
 
 -- \ xy -> (:) ty xy == a CONS
-analExprFBWW (CoLam [(x,_),(y,_)]
-		(CoCon con _ [CoVarAtom x',CoVarAtom y'])) env
-	| con == consDataCon && x == x' && y == y' 
-	= IsCons
-analExprFBWW (CoLam ids e) env   
-	= addArgs (length ids) (analExprFBWW e (delManyFromIdEnv env (map fst ids)))
+
+analExprFBWW (Lam (x,_) (Lam (y,_)
+		(Con con _ [VarArg x',VarArg y']))) env
+  | con == consDataCon && x == x' && y == y'
+  = IsCons
+analExprFBWW (Lam (id,_) e) env
+  = addArgs 1 (analExprFBWW e (delOneFromIdEnv env id))
+
 analExprFBWW (CoTyLam tyvar e) env = analExprFBWW e env
-analExprFBWW (CoApp f atom) env  = rmArg (analExprFBWW f env)
+analExprFBWW (App f atom) env  = rmArg (analExprFBWW f env)
 analExprFBWW (CoTyApp f ty) env  = analExprFBWW f env
-analExprFBWW (CoSCC lab e) env   = analExprFBWW e env
-analExprFBWW (CoLet binds e) env = analExprFBWW e (analBind binds env) 
-analExprFBWW (CoCase e alts) env = foldl1 joinFBType (analAltsFBWW alts env)
+analExprFBWW (SCC lab e) env   = analExprFBWW e env
+analExprFBWW (Let binds e) env = analExprFBWW e (analBind binds env)
+analExprFBWW (Case e alts) env = foldl1 joinFBType (analAltsFBWW alts env)
 
-analAltsFBWW (CoAlgAlts alts deflt) env = 
+analAltsFBWW (AlgAlts alts deflt) env =
     case analDefFBWW deflt env of
 	Just ty -> ty : tys
 	Nothing -> tys
    where
      tys = map (\(con,binders,e) -> analExprFBWW e (delManyFromIdEnv env (map fst binders))) alts
-analAltsFBWW (CoPrimAlts alts deflt) env = 
+analAltsFBWW (PrimAlts alts deflt) env =
     case analDefFBWW deflt env of
 	Just ty -> ty : tys
 	Nothing -> tys
@@ -155,8 +150,8 @@ analAltsFBWW (CoPrimAlts alts deflt) env =
      tys = map (\(lit,e) -> analExprFBWW e env) alts
 
 
-analDefFBWW CoNoDefault env = Nothing
-analDefFBWW (CoBindDefault v e) env = Just (analExprFBWW e (delOneFromIdEnv env (fst v)))
+analDefFBWW NoDefault env = Nothing
+analDefFBWW (BindDefault v e) env = Just (analExprFBWW e (delOneFromIdEnv env (fst v)))
 \end{code}
 
 
@@ -167,32 +162,32 @@ Only add a type info if:
 
 \begin{code}
 analBindExpr :: BinderInfo -> InExpr -> IdEnv OurFBType -> OurFBType
-analBindExpr bnd expr env = 
+analBindExpr bnd expr env =
        case analExprFBWW expr env of
-	      IsFB ty@(FBType [] _) -> 
+	      IsFB ty@(FBType [] _) ->
 		   if oneSafeOcc False bnd
 		   then IsFB ty
 		   else IsNotFB
 	      other -> other
 
 analBind :: InBinding -> IdEnv OurFBType -> IdEnv OurFBType
-analBind (CoNonRec (v,bnd) e) env = 
+analBind (NonRec (v,bnd) e) env =
 	case analBindExpr bnd e env of
 	 ty@(IsFB _) -> addOneToIdEnv env v ty
 	 ty@(IsCons) -> addOneToIdEnv env v ty
 	 _ -> delOneFromIdEnv env v	-- remember about shadowing!
 
-analBind (CoRec binds) env = 
+analBind (Rec binds) env =
    let
 	first_set = [ (v,IsFB (FBType [FBBadConsum | _ <- args ] FBGoodProd)) | ((v,_),e) <- binds,
-				(_,args,_) <- [digForLambdas e]]
+				(_,_,args,_) <- [digForLambdas e]]
 	env' = delManyFromIdEnv env (map (fst.fst) binds)
    in
 	growIdEnvList env' (fixpoint 0 binds env' first_set)
 
 fixpoint :: Int -> [(InBinder,InExpr)] -> IdEnv OurFBType -> [(Id,OurFBType)] -> [(Id,OurFBType)]
-fixpoint n binds env maps = 
-	if maps == maps' 
+fixpoint n binds env maps =
+	if maps == maps'
 	then maps
 	else fixpoint (n+1) binds env maps'
    where
@@ -204,50 +199,51 @@ fixpoint n binds env maps =
 
 
 \begin{code}
-annotateExprFBWW :: InExpr -> IdEnv OurFBType -> PlainCoreExpr
-annotateExprFBWW (CoVar v) env = CoVar v
-annotateExprFBWW (CoLit i) env = CoLit i
-annotateExprFBWW (CoCon c t a) env = CoCon c t a
-annotateExprFBWW (CoPrim p t a) env = CoPrim p t a 
-annotateExprFBWW (CoLam ids e) env = CoLam ids' (annotateExprFBWW e (delManyFromIdEnv env ids'))
-   where ids' = map fst ids
+annotateExprFBWW :: InExpr -> IdEnv OurFBType -> CoreExpr
+annotateExprFBWW (Var v) env = Var v
+annotateExprFBWW (Lit i) env = Lit i
+annotateExprFBWW (Con c t a) env = Con c t a
+annotateExprFBWW (Prim p t a) env = Prim p t a
+annotateExprFBWW (Lam (id,_) e) env
+  = Lam id (annotateExprFBWW e (delOneFromIdEnv env id))
+
 annotateExprFBWW (CoTyLam tyvar e) env = CoTyLam tyvar (annotateExprFBWW e env)
-annotateExprFBWW (CoApp f atom) env = CoApp (annotateExprFBWW f env) atom 
+annotateExprFBWW (App f atom) env = App (annotateExprFBWW f env) atom
 annotateExprFBWW (CoTyApp f ty) env = CoTyApp (annotateExprFBWW f env) ty
-annotateExprFBWW (CoSCC lab e) env = CoSCC lab (annotateExprFBWW e env)
-annotateExprFBWW (CoCase e alts) env = CoCase (annotateExprFBWW e env)
+annotateExprFBWW (SCC lab e) env = SCC lab (annotateExprFBWW e env)
+annotateExprFBWW (Case e alts) env = Case (annotateExprFBWW e env)
 					    (annotateAltsFBWW alts env)
-annotateExprFBWW (CoLet bnds e) env = CoLet bnds' (annotateExprFBWW e env')
+annotateExprFBWW (Let bnds e) env = Let bnds' (annotateExprFBWW e env')
   where
-	(env',bnds') = annotateBindingFBWW env bnds 
+	(env',bnds') = annotateBindingFBWW env bnds
 
-annotateAltsFBWW (CoAlgAlts alts deflt) env = CoAlgAlts alts' deflt'
+annotateAltsFBWW (AlgAlts alts deflt) env = AlgAlts alts' deflt'
   where
 	alts' = [ let
 		   binders' = map fst binders
 		  in (con,binders',annotateExprFBWW e (delManyFromIdEnv env binders'))
 				| (con,binders,e) <- alts ]
 	deflt' = annotateDefFBWW deflt env
-annotateAltsFBWW (CoPrimAlts alts deflt) env = CoPrimAlts alts' deflt'
+annotateAltsFBWW (PrimAlts alts deflt) env = PrimAlts alts' deflt'
   where
 	alts' = [ (lit,annotateExprFBWW e env) | (lit,e) <- alts ]
 	deflt' = annotateDefFBWW deflt env
 
-annotateDefFBWW CoNoDefault env = CoNoDefault
-annotateDefFBWW (CoBindDefault v e) env 
-	= CoBindDefault (fst v) (annotateExprFBWW e (delOneFromIdEnv env (fst v)))
+annotateDefFBWW NoDefault env = NoDefault
+annotateDefFBWW (BindDefault v e) env
+	= BindDefault (fst v) (annotateExprFBWW e (delOneFromIdEnv env (fst v)))
 
-annotateBindingFBWW :: IdEnv OurFBType -> InBinding -> (IdEnv OurFBType,PlainCoreBinding)
+annotateBindingFBWW :: IdEnv OurFBType -> InBinding -> (IdEnv OurFBType,CoreBinding)
 annotateBindingFBWW env bnds = (env',bnds')
   where
 	env' = analBind bnds env
 	bnds' = case bnds of
-		  CoNonRec (v,_) e -> CoNonRec (fixId v) (annotateExprFBWW e env)
-		  CoRec bnds -> CoRec [ (fixId v,annotateExprFBWW e env') | ((v,_),e) <- bnds ]
+		  NonRec (v,_) e -> NonRec (fixId v) (annotateExprFBWW e env)
+		  Rec bnds -> Rec [ (fixId v,annotateExprFBWW e env') | ((v,_),e) <- bnds ]
 	fixId v =
 		(case lookupIdEnv env' v of
 		   Just (IsFB ty@(FBType xs p))
 		    | not (null xs) -> pprTrace "ADDED to:" (ppr PprDebug v)
-				        (addIdFBTypeInfo v (mkFBTypeInfo ty))
+					(addIdFBTypeInfo v (mkFBTypeInfo ty))
 		   _ -> v)
 \end{code}
diff --git a/ghc/compiler/simplCore/BinderInfo.hi b/ghc/compiler/simplCore/BinderInfo.hi
deleted file mode 100644
index 52304cf781..0000000000
--- a/ghc/compiler/simplCore/BinderInfo.hi
+++ /dev/null
@@ -1,23 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface BinderInfo where
-import Outputable(Outputable)
-data BinderInfo   = DeadCode | ManyOcc Int | OneOcc FunOrArg DuplicationDanger InsideSCC Int Int
-data DuplicationDanger 
-data FunOrArg 
-data InsideSCC 
-argOccurrence :: Int -> BinderInfo
-combineAltsBinderInfo :: BinderInfo -> BinderInfo -> BinderInfo
-combineBinderInfo :: BinderInfo -> BinderInfo -> BinderInfo
-funOccurrence :: Int -> BinderInfo
-getBinderInfoArity :: BinderInfo -> Int
-inlineUnconditionally :: Bool -> BinderInfo -> Bool
-isDupDanger :: DuplicationDanger -> Bool
-isFun :: FunOrArg -> Bool
-markDangerousToDup :: BinderInfo -> BinderInfo
-markInsideSCC :: BinderInfo -> BinderInfo
-markMany :: BinderInfo -> BinderInfo
-oneSafeOcc :: Bool -> BinderInfo -> Bool
-oneTextualOcc :: Bool -> BinderInfo -> Bool
-setBinderInfoArityToZero :: BinderInfo -> BinderInfo
-instance Outputable BinderInfo
-
diff --git a/ghc/compiler/simplCore/BinderInfo.lhs b/ghc/compiler/simplCore/BinderInfo.lhs
index d89991631d..ebf64d75e7 100644
--- a/ghc/compiler/simplCore/BinderInfo.lhs
+++ b/ghc/compiler/simplCore/BinderInfo.lhs
@@ -1,5 +1,5 @@
 %
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
 %
 %************************************************************************
 %*									*
@@ -8,7 +8,6 @@
 %************************************************************************
 
 \begin{code}
-
 #include "HsVersions.h"
 
 module BinderInfo (
@@ -23,16 +22,14 @@ module BinderInfo (
 	markMany, markDangerousToDup, markInsideSCC,
 	getBinderInfoArity,
 	setBinderInfoArityToZero,
-	
+
 	isFun, isDupDanger -- for Simon Marlow deforestation
     ) where
 
-IMPORT_Trace		-- ToDo: rm (debugging)
+import Ubiq{-uitous-}
 
-import PlainCore
-import Outputable
 import Pretty
-import Util		-- for pragmas only
+import Util		( panic )
 \end{code}
 
 The @BinderInfo@ describes how a variable is used in a given scope.
@@ -86,7 +83,7 @@ data FunOrArg
     -- When combining branches of a case, only report FunOcc if
     -- both branches are FunOccs
 
-data DuplicationDanger 
+data DuplicationDanger
   = DupDanger	-- Inside a non-linear lambda (that is, a lambda which
 		-- is sure to be instantiated only once), or inside
 		-- the rhs of an INLINE-pragma'd thing.  Either way,
@@ -114,12 +111,12 @@ oneTextualOcc ok_to_dup (OneOcc _ _ _ n_alts _) = n_alts <= 1 || ok_to_dup
 oneTextualOcc _         other		        = False
 \end{code}
 
-@safeSingleOcc@ detects single occurences of values that are safe to 
+@safeSingleOcc@ detects single occurences of values that are safe to
 inline, {\em including} ones in an argument position.
 
 \begin{code}
 oneSafeOcc :: Bool -> BinderInfo -> Bool
-oneSafeOcc ok_to_dup (OneOcc _ NoDupDanger NotInsideSCC n_alts _) 
+oneSafeOcc ok_to_dup (OneOcc _ NoDupDanger NotInsideSCC n_alts _)
 						     = n_alts <= 1 || ok_to_dup
 oneSafeOcc _         other			     = False
 \end{code}
@@ -173,12 +170,12 @@ markInsideSCC (OneOcc posn dup_danger _ n_alts ar)
   = OneOcc posn dup_danger InsideSCC n_alts ar
 markInsideSCC other = other
 
-combineBinderInfo, combineAltsBinderInfo 
+combineBinderInfo, combineAltsBinderInfo
 	:: BinderInfo -> BinderInfo -> BinderInfo
 
 combineBinderInfo DeadCode info2 = info2
 combineBinderInfo info1 DeadCode = info1
-combineBinderInfo info1 info2	 
+combineBinderInfo info1 info2
 	= ManyOcc (min (getBinderInfoArity info1) (getBinderInfoArity info2))
 
 combineAltsBinderInfo DeadCode info2 = info2
diff --git a/ghc/compiler/simplCore/ConFold.hi b/ghc/compiler/simplCore/ConFold.hi
deleted file mode 100644
index f154a44309..0000000000
--- a/ghc/compiler/simplCore/ConFold.hi
+++ /dev/null
@@ -1,11 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface ConFold where
-import CoreSyn(CoreAtom, CoreExpr)
-import Id(Id)
-import PrimOps(PrimOp)
-import SimplEnv(SimplEnv)
-import SimplMonad(SimplCount)
-import SplitUniq(SplitUniqSupply)
-import UniType(UniType)
-completePrim :: SimplEnv -> PrimOp -> [UniType] -> [CoreAtom Id] -> SplitUniqSupply -> SimplCount -> (CoreExpr Id Id, SimplCount)
-
diff --git a/ghc/compiler/simplCore/ConFold.lhs b/ghc/compiler/simplCore/ConFold.lhs
index 1e1a1f0080..0a128aed9b 100644
--- a/ghc/compiler/simplCore/ConFold.lhs
+++ b/ghc/compiler/simplCore/ConFold.lhs
@@ -12,27 +12,23 @@ ToDo:
 
 module ConFold	( completePrim ) where
 
-IMPORT_Trace
-
-import PlainCore
-import TaggedCore
 import SimplEnv
 import SimplMonad
 
-import AbsPrel		( trueDataCon, falseDataCon, PrimOp(..), PrimKind
+import PrelInfo		( trueDataCon, falseDataCon, PrimOp(..), PrimRep
 			  IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
 			  IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
 			)
-import BasicLit		( mkMachInt, mkMachWord, BasicLit(..) )
-import Id 		( Id, getIdUniType )
+import Literal		( mkMachInt, mkMachWord, Literal(..) )
+import Id 		( Id, idType )
 import Maybes		( Maybe(..) )
 import Util
 \end{code}
 
 \begin{code}
-completePrim :: SimplEnv 
-	     -> PrimOp -> [OutType] -> [OutAtom] 
-	     -> SmplM OutExpr 
+completePrim :: SimplEnv
+	     -> PrimOp -> [OutType] -> [OutAtom]
+	     -> SmplM OutExpr
 \end{code}
 
 In the parallel world, we use _seq_ to control the order in which
@@ -46,7 +42,7 @@ Now, we know that the seq# primitive will never return 0#, but we
 don't let the simplifier know that.  We also use a special error
 value, parError#, which is *not* a bottoming Id, so as far as the
 simplifier is concerned, we have to evaluate seq# a before we know
-whether or not y will be evaluated.  
+whether or not y will be evaluated.
 
 If we didn't have the extra case, then after inlining the compiler might
 see:
@@ -56,7 +52,7 @@ If it sees that, it can see that f is strict in q, and hence it might
 evaluate q before p!  The "0# ->" case prevents this happening.
 By having the parError# branch we make sure that anything in the
 other branch stays there!
-  
+
 This is fine, but we'd like to get rid of the extraneous code.  Hence,
 we *do* let the simplifier know that seq# is strict in its argument.
 As a result, we hope that `a' will be evaluated before seq# is called.
@@ -68,19 +64,19 @@ NB: If we ever do case-floating, we have an extra worry:
 
     case a of
       a' -> let b' = case seq# a of { True -> b; False -> parError# }
-            in case b' of ...
+	    in case b' of ...
 
     =>
 
     case a of
-      a' -> let b' = case True of { True -> b; False -> parError# } 
-            in case b' of ...
+      a' -> let b' = case True of { True -> b; False -> parError# }
+	    in case b' of ...
 
     =>
 
     case a of
       a' -> let b' = b
-            in case b' of ...
+	    in case b' of ...
 
     =>
 
@@ -90,76 +86,76 @@ NB: If we ever do case-floating, we have an extra worry:
 The second case must never be floated outside of the first!
 
 \begin{code}
-completePrim env SeqOp [ty] [CoLitAtom lit]
-  = returnSmpl (CoLit (mkMachInt 1))
+completePrim env SeqOp [ty] [LitArg lit]
+  = returnSmpl (Lit (mkMachInt 1))
 
-completePrim env op@SeqOp tys@[ty] args@[CoVarAtom var]
+completePrim env op@SeqOp tys@[ty] args@[VarArg var]
   = case (lookupUnfolding env var) of
       NoUnfoldingDetails -> give_up
-      LiteralForm _ -> hooray
-      OtherLiteralForm _ -> hooray
-      ConstructorForm _ _ _ -> hooray
-      OtherConstructorForm _ -> hooray
-      GeneralForm _ WhnfForm _ _ -> hooray
-      _ -> give_up 
+      LitForm _ -> hooray
+      OtherLitForm _ -> hooray
+      ConForm _ _ _ -> hooray
+      OtherConForm _ -> hooray
+      GenForm _ WhnfForm _ _ -> hooray
+      _ -> give_up
   where
-    give_up = returnSmpl (CoPrim op tys args)
-    hooray = returnSmpl (CoLit (mkMachInt 1))
+    give_up = returnSmpl (Prim op tys args)
+    hooray = returnSmpl (Lit (mkMachInt 1))
 \end{code}
 
 \begin{code}
 completePrim env op tys args
   = case args of
-      [CoLitAtom (MachChar char_lit)]	   -> oneCharLit   op char_lit
-      [CoLitAtom (MachInt int_lit signed)] -> (if signed then oneIntLit else oneWordLit)
+      [LitArg (MachChar char_lit)]	   -> oneCharLit   op char_lit
+      [LitArg (MachInt int_lit signed)] -> (if signed then oneIntLit else oneWordLit)
 							   op int_lit
-      [CoLitAtom (MachFloat float_lit)]    -> oneFloatLit  op float_lit
-      [CoLitAtom (MachDouble double_lit)]  -> oneDoubleLit op double_lit
-      [CoLitAtom other_lit]		   -> oneLit       op other_lit 
+      [LitArg (MachFloat float_lit)]    -> oneFloatLit  op float_lit
+      [LitArg (MachDouble double_lit)]  -> oneDoubleLit op double_lit
+      [LitArg other_lit]		   -> oneLit       op other_lit
 
-      [CoLitAtom (MachChar char_lit1),
-       CoLitAtom (MachChar char_lit2)]     -> twoCharLits op char_lit1 char_lit2
+      [LitArg (MachChar char_lit1),
+       LitArg (MachChar char_lit2)]     -> twoCharLits op char_lit1 char_lit2
 
-      [CoLitAtom (MachInt int_lit1 True),     -- both *signed* literals
-       CoLitAtom (MachInt int_lit2 True)]  -> twoIntLits op int_lit1 int_lit2
+      [LitArg (MachInt int_lit1 True),     -- both *signed* literals
+       LitArg (MachInt int_lit2 True)]  -> twoIntLits op int_lit1 int_lit2
 
-      [CoLitAtom (MachInt int_lit1 False),    -- both *unsigned* literals
-       CoLitAtom (MachInt int_lit2 False)] -> twoWordLits op int_lit1 int_lit2
+      [LitArg (MachInt int_lit1 False),    -- both *unsigned* literals
+       LitArg (MachInt int_lit2 False)] -> twoWordLits op int_lit1 int_lit2
 
-      [CoLitAtom (MachInt int_lit1 False),    -- unsigned+signed (shift ops)
-       CoLitAtom (MachInt int_lit2 True)]  -> oneWordOneIntLit op int_lit1 int_lit2
+      [LitArg (MachInt int_lit1 False),    -- unsigned+signed (shift ops)
+       LitArg (MachInt int_lit2 True)]  -> oneWordOneIntLit op int_lit1 int_lit2
 
-      [CoLitAtom (MachFloat float_lit1),
-       CoLitAtom (MachFloat float_lit2)]   -> twoFloatLits op float_lit1 float_lit2
+      [LitArg (MachFloat float_lit1),
+       LitArg (MachFloat float_lit2)]   -> twoFloatLits op float_lit1 float_lit2
 
-      [CoLitAtom (MachDouble double_lit1),
-       CoLitAtom (MachDouble double_lit2)] -> twoDoubleLits op double_lit1 double_lit2
+      [LitArg (MachDouble double_lit1),
+       LitArg (MachDouble double_lit2)] -> twoDoubleLits op double_lit1 double_lit2
 
-      [CoLitAtom lit, CoVarAtom var]       -> litVar op lit var
-      [CoVarAtom var, CoLitAtom lit]       -> litVar op lit var
+      [LitArg lit, VarArg var]       -> litVar op lit var
+      [VarArg var, LitArg lit]       -> litVar op lit var
 
       other				   -> give_up
 
   where
-    give_up = returnSmpl (CoPrim op tys args)
+    give_up = returnSmpl (Prim op tys args)
 
-    return_char c   = returnSmpl (CoLit (MachChar   c))
-    return_int i    = returnSmpl (CoLit (mkMachInt  i))
-    return_word i   = returnSmpl (CoLit (mkMachWord i))
-    return_float f  = returnSmpl (CoLit (MachFloat  f))
-    return_double d = returnSmpl (CoLit (MachDouble d))
-    return_lit lit  = returnSmpl (CoLit lit)
+    return_char c   = returnSmpl (Lit (MachChar   c))
+    return_int i    = returnSmpl (Lit (mkMachInt  i))
+    return_word i   = returnSmpl (Lit (mkMachWord i))
+    return_float f  = returnSmpl (Lit (MachFloat  f))
+    return_double d = returnSmpl (Lit (MachDouble d))
+    return_lit lit  = returnSmpl (Lit lit)
 
     return_bool True  = returnSmpl trueVal
     return_bool False = returnSmpl falseVal
 
     return_prim_case var lit val_if_eq val_if_neq
-      = newId (getIdUniType var)	`thenSmpl` \ unused_binder ->
+      = newId (idType var)	`thenSmpl` \ unused_binder ->
 	let
 	    result
-	      =	CoCase (CoVar var)
-		  (CoPrimAlts [(lit,val_if_eq)] 
-		  (CoBindDefault unused_binder val_if_neq))
+	      =	Case (Var var)
+		  (PrimAlts [(lit,val_if_eq)]
+		  (BindDefault unused_binder val_if_neq))
 	in
 --	pprTrace "return_prim_case:" (ppr PprDebug result) (
 	returnSmpl result
@@ -300,7 +296,7 @@ completePrim env op tys args
 	-- This stuff turns
 	--	n ==# 3#
 	-- into
-	--	case n of 
+	--	case n of
 	--	  3# -> True
 	--	  m  -> False
 	--
@@ -323,6 +319,6 @@ completePrim env op tys args
     litVar other_op lit var = give_up
 
 
-trueVal  = CoCon trueDataCon  [] []
-falseVal = CoCon falseDataCon [] []
+trueVal  = Con trueDataCon  [] []
+falseVal = Con falseDataCon [] []
 \end{code}
diff --git a/ghc/compiler/simplCore/FloatIn.hi b/ghc/compiler/simplCore/FloatIn.hi
deleted file mode 100644
index 7ff3ada549..0000000000
--- a/ghc/compiler/simplCore/FloatIn.hi
+++ /dev/null
@@ -1,17 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface FloatIn where
-import BasicLit(BasicLit)
-import CoreSyn(CoreAtom, CoreBinding, CoreCaseAlternatives, CoreExpr)
-import CostCentre(CostCentre)
-import Id(Id)
-import PlainCore(PlainCoreExpr(..), PlainCoreProgram(..))
-import PrimOps(PrimOp)
-import TyVar(TyVar)
-import UniType(UniType)
-data CoreBinding a b 
-data CoreExpr a b 
-data Id 
-type PlainCoreExpr = CoreExpr Id Id
-type PlainCoreProgram = [CoreBinding Id Id]
-floatInwards :: [CoreBinding Id Id] -> [CoreBinding Id Id]
-
diff --git a/ghc/compiler/simplCore/FloatIn.lhs b/ghc/compiler/simplCore/FloatIn.lhs
index 25685333e6..c8b25177f5 100644
--- a/ghc/compiler/simplCore/FloatIn.lhs
+++ b/ghc/compiler/simplCore/FloatIn.lhs
@@ -1,5 +1,5 @@
 %
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
 %
 %************************************************************************
 %*									*
@@ -15,16 +15,11 @@ then discover that they aren't needed in the chosen branch.
 #include "HsVersions.h"
 
 module FloatIn (
-	floatInwards,
+	floatInwards
 
 	-- and to make the interface self-sufficient...
-	CoreExpr, CoreBinding, Id, 
-	PlainCoreProgram(..), PlainCoreExpr(..)
     ) where
 
-import Pretty		-- ToDo: debugging only
-
-import PlainCore
 import AnnCoreSyn
 
 import FreeVars
@@ -36,15 +31,15 @@ Top-level interface function, @floatInwards@.  Note that we do not
 actually float any bindings downwards from the top-level.
 
 \begin{code}
-floatInwards :: [PlainCoreBinding] -> [PlainCoreBinding]
+floatInwards :: [CoreBinding] -> [CoreBinding]
 
-floatInwards binds 
+floatInwards binds
   = map fi_top_bind binds
   where
-    fi_top_bind (CoNonRec binder rhs) 
-      = CoNonRec binder (fiExpr [] (freeVars rhs))
-    fi_top_bind (CoRec pairs)
-      = CoRec [ (b, fiExpr [] (freeVars rhs)) | (b, rhs) <- pairs ]
+    fi_top_bind (NonRec binder rhs)
+      = NonRec binder (fiExpr [] (freeVars rhs))
+    fi_top_bind (Rec pairs)
+      = Rec [ (b, fiExpr [] (freeVars rhs)) | (b, rhs) <- pairs ]
 \end{code}
 
 %************************************************************************
@@ -120,7 +115,7 @@ the closure for a is not built.
 \begin{code}
 type FreeVarsSet   = UniqSet Id
 
-type FloatingBinds = [(PlainCoreBinding, FreeVarsSet)]
+type FloatingBinds = [(CoreBinding, FreeVarsSet)]
 	-- In dependency order (outermost first)
 
 	-- The FreeVarsSet is the free variables of the binding.  In the case
@@ -130,31 +125,31 @@ type FloatingBinds = [(PlainCoreBinding, FreeVarsSet)]
 fiExpr :: FloatingBinds		-- binds we're trying to drop
 				-- as far "inwards" as possible
        -> CoreExprWithFVs	-- input expr
-       -> PlainCoreExpr		-- result
+       -> CoreExpr		-- result
 
-fiExpr to_drop (_,AnnCoVar v) = mkCoLets' to_drop (CoVar v)
+fiExpr to_drop (_,AnnCoVar v) = mkCoLets' to_drop (Var v)
 
-fiExpr to_drop (_,AnnCoLit k) = mkCoLets' to_drop (CoLit k)
+fiExpr to_drop (_,AnnCoLit k) = mkCoLets' to_drop (Lit k)
 
 fiExpr to_drop (_,AnnCoCon c tys atoms)
-  = mkCoLets' to_drop (CoCon c tys atoms)
+  = mkCoLets' to_drop (Con c tys atoms)
 
 fiExpr to_drop (_,AnnCoPrim c tys atoms)
-  = mkCoLets' to_drop (CoPrim c tys atoms)
+  = mkCoLets' to_drop (Prim c tys atoms)
 \end{code}
 
 Here we are not floating inside lambda (type lambdas are OK):
 \begin{code}
-fiExpr to_drop (_,AnnCoLam binders body)
-  = mkCoLets' to_drop (mkCoLam binders (fiExpr [] body))
+fiExpr to_drop (_,AnnCoLam binder body)
+  = mkCoLets' to_drop (Lam binder (fiExpr [] body))
 
 fiExpr to_drop (_,AnnCoTyLam tyvar body)
   | whnf body
-  -- we do not float into type lambdas if they are followed by 
-  -- a whnf (actually we check for lambdas and constructors). 
+  -- we do not float into type lambdas if they are followed by
+  -- a whnf (actually we check for lambdas and constructors).
   -- The reason is that a let binding will get stuck
   -- in between the type lambda and the whnf and the simplifier
-  -- does not know how to pull it back out from a type lambda. 
+  -- does not know how to pull it back out from a type lambda.
   -- Ex:
   -- 	let v = ...
   -- 	in let f = /\t -> \a -> ...
@@ -165,7 +160,7 @@ fiExpr to_drop (_,AnnCoTyLam tyvar body)
   = mkCoLets' to_drop (CoTyLam tyvar (fiExpr [] body))
   | otherwise
   = CoTyLam tyvar (fiExpr to_drop body)
-  where 
+  where
     whnf :: CoreExprWithFVs -> Bool
     whnf (_,AnnCoLit _)     = True
     whnf (_,AnnCoCon _ _ _) = True
@@ -173,7 +168,6 @@ fiExpr to_drop (_,AnnCoTyLam tyvar body)
     whnf (_,AnnCoTyLam _ e) = whnf e
     whnf (_,AnnCoSCC _ e)   = whnf e
     whnf _                  = False
-
 \end{code}
 
 Applications: we could float inside applications, but it's probably
@@ -181,7 +175,7 @@ not worth it (a purely practical choice, hunch- [not experience-]
 based).
 \begin{code}
 fiExpr to_drop (_,AnnCoApp fun atom)
-  = mkCoLets' to_drop (CoApp (fiExpr [] fun) atom)
+  = mkCoLets' to_drop (App (fiExpr [] fun) atom)
 
 fiExpr to_drop (_,AnnCoTyApp expr ty)
   = CoTyApp (fiExpr to_drop expr) ty
@@ -189,17 +183,17 @@ fiExpr to_drop (_,AnnCoTyApp expr ty)
 
 We don't float lets inwards past an SCC.
 
-ToDo: CoSCC: {\em should} keep info on current cc, and when passing
+ToDo: SCC: {\em should} keep info on current cc, and when passing
 one, if it is not the same, annotate all lets in binds with current
 cc, change current cc to the new one and float binds into expr.
 \begin{code}
 fiExpr to_drop (_, AnnCoSCC cc expr)
-  = mkCoLets' to_drop (CoSCC cc (fiExpr [] expr))
+  = mkCoLets' to_drop (SCC cc (fiExpr [] expr))
 \end{code}
 
-For @CoLets@, the possible ``drop points'' for the \tr{to_drop}
-bindings are: (a)~in the body, (b1)~in the RHS of a CoNonRec binding,
-or~(b2), in each of the RHSs of the pairs of a @CoRec@.
+For @Lets@, the possible ``drop points'' for the \tr{to_drop}
+bindings are: (a)~in the body, (b1)~in the RHS of a NonRec binding,
+or~(b2), in each of the RHSs of the pairs of a @Rec@.
 
 Note that we do {\em weird things} with this let's binding.  Consider:
 \begin{verbatim}
@@ -226,11 +220,11 @@ fiExpr to_drop (_,AnnCoLet (AnnCoNonRec id rhs) body)
     rhs_fvs  = freeVarsOf rhs
     body_fvs = freeVarsOf body
 
-    ([rhs_binds, body_binds], shared_binds) = sepBindsByDropPoint [rhs_fvs, body_fvs] to_drop 
+    ([rhs_binds, body_binds], shared_binds) = sepBindsByDropPoint [rhs_fvs, body_fvs] to_drop
 
     new_to_drop = body_binds ++				-- the bindings used only in the body
-		  [(CoNonRec id rhs', rhs_fvs')] ++ 	-- the new binding itself
-                  shared_binds  			-- the bindings used both in rhs and body
+		  [(NonRec id rhs', rhs_fvs')] ++ 	-- the new binding itself
+		  shared_binds  			-- the bindings used both in rhs and body
 
 	-- Push rhs_binds into the right hand side of the binding
     rhs'     = fiExpr rhs_binds rhs
@@ -244,29 +238,29 @@ fiExpr to_drop (_,AnnCoLet (AnnCoRec bindings) body)
     rhss_fvs = map freeVarsOf rhss
     body_fvs = freeVarsOf body
 
-    (body_binds:rhss_binds, shared_binds) 
-      = sepBindsByDropPoint (body_fvs:rhss_fvs) to_drop 
+    (body_binds:rhss_binds, shared_binds)
+      = sepBindsByDropPoint (body_fvs:rhss_fvs) to_drop
 
     new_to_drop = -- the bindings used only in the body
-                  body_binds ++
-                  -- the new binding itself
-                  [(CoRec (fi_bind rhss_binds bindings), rhs_fvs')] ++ 
-                  -- the bindings used both in rhs and body or in more than one rhs
-                  shared_binds
+		  body_binds ++
+		  -- the new binding itself
+		  [(Rec (fi_bind rhss_binds bindings), rhs_fvs')] ++
+		  -- the bindings used both in rhs and body or in more than one rhs
+		  shared_binds
 
-    rhs_fvs' = unionUniqSets (unionManyUniqSets rhss_fvs) 
-                     (unionManyUniqSets (map floatedBindsFVs rhss_binds))
+    rhs_fvs' = unionUniqSets (unionManyUniqSets rhss_fvs)
+		     (unionManyUniqSets (map floatedBindsFVs rhss_binds))
 
     -- Push rhs_binds into the right hand side of the binding
     fi_bind :: [FloatingBinds]	    -- one per "drop pt" conjured w/ fvs_of_rhss
 	    -> [(Id, CoreExprWithFVs)]
-	    -> [(Id, PlainCoreExpr)]
+	    -> [(Id, CoreExpr)]
 
     fi_bind to_drops pairs
       = [ (binder, fiExpr to_drop rhs) | ((binder, rhs), to_drop) <- zip pairs to_drops ]
 \end{code}
 
-For @CoCase@, the possible ``drop points'' for the \tr{to_drop}
+For @Case@, the possible ``drop points'' for the \tr{to_drop}
 bindings are: (a)~inside the scrutinee, (b)~inside one of the
 alternatives/default [default FVs always {\em first}!].
 
@@ -278,9 +272,9 @@ fiExpr to_drop (_, AnnCoCase scrut alts)
     in
     case (sepBindsByDropPoint drop_pts_fvs to_drop)
 		of (scrut_drops : deflt_drops : alts_drops, drop_here) ->
-                     mkCoLets' drop_here (CoCase (fiExpr scrut_drops scrut)
-		                                (fi_alts deflt_drops alts_drops alts))
-    
+		     mkCoLets' drop_here (Case (fiExpr scrut_drops scrut)
+						(fi_alts deflt_drops alts_drops alts))
+
   where
     ----------------------------
     -- pin default FVs on first!
@@ -296,19 +290,19 @@ fiExpr to_drop (_, AnnCoCase scrut alts)
 
     ----------------------------
     fi_alts to_drop_deflt to_drop_alts (AnnCoAlgAlts alts deflt)
-      = CoAlgAlts
+      = AlgAlts
 	    [ (con, params, fiExpr to_drop rhs)
 	    | ((con, params, rhs), to_drop) <- alts `zip` to_drop_alts ]
 	    (fi_default to_drop_deflt deflt)
 
     fi_alts to_drop_deflt to_drop_alts (AnnCoPrimAlts alts deflt)
-      = CoPrimAlts
+      = PrimAlts
 	    [ (lit, fiExpr to_drop rhs)
 	    | ((lit, rhs), to_drop) <- alts `zip` to_drop_alts ]
 	    (fi_default to_drop_deflt deflt)
 
-    fi_default to_drop AnnCoNoDefault	      = CoNoDefault
-    fi_default to_drop (AnnCoBindDefault b e) = CoBindDefault b (fiExpr to_drop e)
+    fi_default to_drop AnnCoNoDefault	      = NoDefault
+    fi_default to_drop (AnnCoBindDefault b e) = BindDefault b (fiExpr to_drop e)
 \end{code}
 
 %************************************************************************
@@ -338,7 +332,7 @@ sepBindsByDropPoint
     -> FloatingBinds 	    -- candidate floaters
     -> ([FloatingBinds],    -- floaters that *can* be floated into
 			    -- the corresponding drop point
-        FloatingBinds)	    -- everything else, bindings which must
+	FloatingBinds)	    -- everything else, bindings which must
 			    -- not be floated inside any drop point
 
 sepBindsByDropPoint drop_pts []
@@ -348,9 +342,9 @@ sepBindsByDropPoint drop_pts floaters
   = let
 	(per_drop_pt, must_stay_here, _)
 	    --= sep drop_pts emptyUniqSet{-fvs of prev drop_pts-} floaters
-            = split' drop_pts floaters [] empty_boxes
-        empty_boxes = take (length drop_pts) (repeat [])
-	
+	    = split' drop_pts floaters [] empty_boxes
+	empty_boxes = take (length drop_pts) (repeat [])
+
     in
     (map reverse per_drop_pt, reverse must_stay_here)
   where
@@ -360,31 +354,31 @@ sepBindsByDropPoint drop_pts floaters
     -- only in a or unused
     split' (a:as) (bind:binds) mult_branch (drop_box_a:drop_boxes)
       | all (\b -> {-b `elementOfUniqSet` a &&-}
-                   not (b `elementOfUniqSet` (unionManyUniqSets as)))
-            (bindersOf (fst bind))
+		   not (b `elementOfUniqSet` (unionManyUniqSets as)))
+	    (bindersOf (fst bind))
       = split' (a':as) binds mult_branch ((bind:drop_box_a):drop_boxes)
       where
-        a' = a `unionUniqSets` fvsOfBind bind
+	a' = a `unionUniqSets` fvsOfBind bind
 
-    -- not in a 
+    -- not in a
     split' (a:as) (bind:binds) mult_branch (drop_box_a:drop_boxes)
       | all (\b -> not (b `elementOfUniqSet` a)) (bindersOf (fst bind))
       = split' (a:as') binds mult_branch' (drop_box_a:drop_boxes')
       where
-        (drop_boxes',mult_branch',as') = split' as [bind] mult_branch drop_boxes
+	(drop_boxes',mult_branch',as') = split' as [bind] mult_branch drop_boxes
 
     -- in a and in as
     split' aas@(a:as) (bind:binds) mult_branch drop_boxes
       = split' aas' binds (bind : mult_branch) drop_boxes
-      where 
-        aas' = map (unionUniqSets (fvsOfBind bind)) aas 
+      where
+	aas' = map (unionUniqSets (fvsOfBind bind)) aas
 
     -------------------------
     fvsOfBind (_,fvs)	= fvs
 
---floatedBindsFVs :: 
+--floatedBindsFVs ::
 floatedBindsFVs binds = foldr unionUniqSets emptyUniqSet (map snd binds)
 
---mkCoLets' :: [FloatingBinds] -> PlainCoreExpr -> PlainCoreExpr
+--mkCoLets' :: [FloatingBinds] -> CoreExpr -> CoreExpr
 mkCoLets' to_drop e = mkCoLetsNoUnboxed (reverse (map fst to_drop)) e
 \end{code}
diff --git a/ghc/compiler/simplCore/FloatOut.hi b/ghc/compiler/simplCore/FloatOut.hi
deleted file mode 100644
index 4c7265948b..0000000000
--- a/ghc/compiler/simplCore/FloatOut.hi
+++ /dev/null
@@ -1,8 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface FloatOut where
-import CmdLineOpts(GlobalSwitch)
-import CoreSyn(CoreBinding)
-import Id(Id)
-import SplitUniq(SplitUniqSupply)
-floatOutwards :: (GlobalSwitch -> Bool) -> SplitUniqSupply -> [CoreBinding Id Id] -> [CoreBinding Id Id]
-
diff --git a/ghc/compiler/simplCore/FloatOut.lhs b/ghc/compiler/simplCore/FloatOut.lhs
index 046ab3e8b7..000ed33dd3 100644
--- a/ghc/compiler/simplCore/FloatOut.lhs
+++ b/ghc/compiler/simplCore/FloatOut.lhs
@@ -1,5 +1,5 @@
 %
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
 %
 \section[FloatOut]{Float bindings outwards (towards the top level)}
 
@@ -10,20 +10,13 @@
 
 module FloatOut ( floatOutwards ) where
 
-IMPORT_Trace		-- ToDo: rm (debugging)
-import Pretty
-import Outputable
-
-import PlainCore
-
-import BasicLit		( BasicLit(..), PrimKind )
+import Literal		( Literal(..) )
 import CmdLineOpts	( GlobalSwitch(..) )
 import CostCentre	( dupifyCC, CostCentre )
 import SetLevels
 import Id		( eqId )
-import IdEnv
 import Maybes		( Maybe(..), catMaybes, maybeToBool )
-import SplitUniq
+import UniqSupply
 import Util
 \end{code}
 
@@ -59,14 +52,14 @@ Well, maybe.  We don't do this at the moment.
 
 
 \begin{code}
-type LevelledExpr  = CoreExpr	 (Id, Level) Id
-type LevelledBind  = CoreBinding (Id, Level) Id
+type LevelledExpr  = GenCoreExpr	 (Id, Level) Id
+type LevelledBind  = GenCoreBinding (Id, Level) Id
 type FloatingBind  = (Level, Floater)
 type FloatingBinds = [FloatingBind]
 
-data Floater = LetFloater     PlainCoreBinding
+data Floater = LetFloater     CoreBinding
 
-	     | CaseFloater   (PlainCoreExpr -> PlainCoreExpr)
+	     | CaseFloater   (CoreExpr -> CoreExpr)
 				-- Give me a right-hand side of the
 				-- (usually single) alternative, and
 				-- I'll build the case
@@ -80,9 +73,9 @@ data Floater = LetFloater     PlainCoreBinding
 
 \begin{code}
 floatOutwards :: (GlobalSwitch -> Bool)	 -- access to all global cmd-line opts
-	      -> SplitUniqSupply
-	      -> PlainCoreProgram 
-	      -> PlainCoreProgram
+	      -> UniqSupply
+	      -> [CoreBinding]
+	      -> [CoreBinding]
 
 floatOutwards sw_chker us pgm
   = case (setLevels pgm sw_chker us) of { annotated_w_levels ->
@@ -108,16 +101,16 @@ floatOutwards sw_chker us pgm
     concat final_toplev_binds_s
     }}
 
-floatTopBind sw bind@(CoNonRec _ _)
+floatTopBind sw bind@(NonRec _ _)
   = case (floatBind sw nullIdEnv tOP_LEVEL bind) of { (fs, floats, bind', _) ->
     (fs, floatsToBinds floats ++ [bind'])
     }
 
-floatTopBind sw bind@(CoRec _)
-  = case (floatBind sw nullIdEnv tOP_LEVEL bind) of { (fs, floats, CoRec pairs', _) ->
+floatTopBind sw bind@(Rec _)
+  = case (floatBind sw nullIdEnv tOP_LEVEL bind) of { (fs, floats, Rec pairs', _) ->
 	-- Actually floats will be empty
     --false:ASSERT(null floats)
-    (fs, [CoRec (floatsToBindPairs floats ++ pairs')])
+    (fs, [Rec (floatsToBindPairs floats ++ pairs')])
     }
 \end{code}
 
@@ -129,30 +122,30 @@ floatTopBind sw bind@(CoRec _)
 
 
 \begin{code}
-floatBind :: (GlobalSwitch -> Bool) 
+floatBind :: (GlobalSwitch -> Bool)
 	  -> IdEnv Level
 	  -> Level
 	  -> LevelledBind
-	  -> (FloatStats, FloatingBinds, PlainCoreBinding, IdEnv Level)
+	  -> (FloatStats, FloatingBinds, CoreBinding, IdEnv Level)
 
-floatBind sw env lvl (CoNonRec (name,level) rhs)
+floatBind sw env lvl (NonRec (name,level) rhs)
   = case (floatExpr sw env level rhs) of { (fs, rhs_floats, rhs') ->
 
 	-- A good dumping point
     case (partitionByMajorLevel level rhs_floats)	of { (rhs_floats', heres) ->
 
-    (fs, rhs_floats',CoNonRec name (install heres rhs'), addOneToIdEnv env name level)
+    (fs, rhs_floats',NonRec name (install heres rhs'), addOneToIdEnv env name level)
     }}
-    
-floatBind sw env lvl bind@(CoRec pairs)
+
+floatBind sw env lvl bind@(Rec pairs)
   = case (unzip3 (map do_pair pairs)) of { (fss, rhss_floats, new_pairs) ->
 
     if not (isTopLvl bind_level) then
 	-- Standard case
-	(sum_stats fss, concat rhss_floats, CoRec new_pairs, new_env)
+	(sum_stats fss, concat rhss_floats, Rec new_pairs, new_env)
     else
-	{- In a recursive binding, destined for the top level (only), 
-	   the rhs floats may contain 
+	{- In a recursive binding, destined for the top level (only),
+	   the rhs floats may contain
 	   references to the bound things.  For example
 
 		f = ...(let v = ...f... in b) ...
@@ -162,13 +155,13 @@ floatBind sw env lvl bind@(CoRec pairs)
 		v = ...f...
 		f = ... b ...
 
-	   and hence we must (pessimistically) make all the floats recursive 
+	   and hence we must (pessimistically) make all the floats recursive
 	   with the top binding.  Later dependency analysis will unravel it.
 	-}
 
 	(sum_stats fss,
-	 [], 
-	 CoRec (new_pairs ++ floatsToBindPairs (concat rhss_floats)),
+	 [],
+	 Rec (new_pairs ++ floatsToBindPairs (concat rhss_floats)),
 	 new_env)
 
     }
@@ -194,23 +187,23 @@ floatBind sw env lvl bind@(CoRec pairs)
 %************************************************************************
 
 \begin{code}
-floatExpr :: (GlobalSwitch -> Bool) 
+floatExpr :: (GlobalSwitch -> Bool)
 	  -> IdEnv Level
-	  -> Level 
+	  -> Level
 	  -> LevelledExpr
-	  -> (FloatStats, FloatingBinds, PlainCoreExpr)
+	  -> (FloatStats, FloatingBinds, CoreExpr)
 
-floatExpr sw env _ (CoVar v)	     = (zero_stats, [], CoVar v)
+floatExpr sw env _ (Var v)	     = (zero_stats, [], Var v)
 
-floatExpr sw env _ (CoLit l)     = (zero_stats, [], CoLit l)
+floatExpr sw env _ (Lit l)     = (zero_stats, [], Lit l)
 
-floatExpr sw env _ (CoPrim op ty as) = (zero_stats, [], CoPrim op ty as)
-floatExpr sw env _ (CoCon con ty as) = (zero_stats, [], CoCon con ty as)
+floatExpr sw env _ (Prim op ty as) = (zero_stats, [], Prim op ty as)
+floatExpr sw env _ (Con con ty as) = (zero_stats, [], Con con ty as)
 
-floatExpr sw env lvl (CoApp e a)
+floatExpr sw env lvl (App e a)
   = case (floatExpr sw env lvl e) of { (fs, floating_defns, e') ->
-    (fs, floating_defns, CoApp e' a) }
-    
+    (fs, floating_defns, App e' a) }
+
 floatExpr sw env lvl (CoTyApp e ty)
   = case (floatExpr sw env lvl e) of { (fs, floating_defns, e') ->
     (fs, floating_defns, CoTyApp e' ty) }
@@ -227,10 +220,9 @@ floatExpr sw env lvl (CoTyLam tv e)
     (fs, floats', CoTyLam tv (install heres e'))
     }}
 
-floatExpr sw env lvl (CoLam args@((_,incd_lvl):_) rhs)
+floatExpr sw env lvl (Lam (arg,incd_lvl) rhs)
   = let
-	args'	 = map fst args
-	new_env  = growIdEnvList env args
+	new_env  = addOneToIdEnv env arg incd_lvl
     in
     case (floatExpr sw new_env incd_lvl rhs) of { (fs, floats, rhs') ->
 
@@ -239,10 +231,10 @@ floatExpr sw env lvl (CoLam args@((_,incd_lvl):_) rhs)
 
     (add_to_stats fs floats',
      floats',
-     mkCoLam args' (install heres rhs'))
+     Lam args' (install heres rhs'))
     }}
 
-floatExpr sw env lvl (CoSCC cc expr)
+floatExpr sw env lvl (SCC cc expr)
   = case (floatExpr sw env lvl expr)    of { (fs, floating_defns, expr') ->
     let
 	-- annotate bindings floated outwards past an scc expression
@@ -250,30 +242,30 @@ floatExpr sw env lvl (CoSCC cc expr)
 
 	annotated_defns = annotate (dupifyCC cc) floating_defns
     in
-    (fs, annotated_defns, CoSCC cc expr') }
+    (fs, annotated_defns, SCC cc expr') }
   where
     annotate :: CostCentre -> FloatingBinds -> FloatingBinds
 
     annotate dupd_cc defn_groups
       = [ (level, ann_bind floater) | (level, floater) <- defn_groups ]
       where
-	ann_bind (LetFloater (CoNonRec binder rhs)) 
-	  = LetFloater (CoNonRec binder (ann_rhs rhs))
+	ann_bind (LetFloater (NonRec binder rhs))
+	  = LetFloater (NonRec binder (ann_rhs rhs))
 
-	ann_bind (LetFloater (CoRec pairs))
-	  = LetFloater (CoRec [(binder, ann_rhs rhs) | (binder, rhs) <- pairs])
+	ann_bind (LetFloater (Rec pairs))
+	  = LetFloater (Rec [(binder, ann_rhs rhs) | (binder, rhs) <- pairs])
 
-	ann_bind (CaseFloater fn) = CaseFloater ( \ rhs -> CoSCC dupd_cc (fn rhs) )
+	ann_bind (CaseFloater fn) = CaseFloater ( \ rhs -> SCC dupd_cc (fn rhs) )
 
-	ann_rhs (CoLam	 args e) = CoLam   args (ann_rhs e)
-	ann_rhs (CoTyLam tv   e) = CoTyLam tv	(ann_rhs e)
-	ann_rhs rhs@(CoCon _ _ _)= rhs	-- no point in scc'ing WHNF data
-	ann_rhs rhs		 = CoSCC dupd_cc rhs
+	ann_rhs (Lam	 arg e)  = Lam   arg (ann_rhs e)
+	ann_rhs (CoTyLam tv  e)  = CoTyLam tv  (ann_rhs e)
+	ann_rhs rhs@(Con _ _ _)= rhs	-- no point in scc'ing WHNF data
+	ann_rhs rhs		 = SCC dupd_cc rhs
 
 	-- Note: Nested SCC's are preserved for the benefit of
 	--       cost centre stack profiling (Durham)
 
-floatExpr sw env lvl (CoLet bind body)
+floatExpr sw env lvl (Let bind body)
   = case (floatBind sw env     lvl bind) of { (fsb, rhs_floats, bind', new_env) ->
     case (floatExpr sw new_env lvl body) of { (fse, body_floats, body') ->
     (add_stats fsb fse,
@@ -283,14 +275,14 @@ floatExpr sw env lvl (CoLet bind body)
   where
     bind_lvl = getBindLevel bind
 
-floatExpr sw env lvl (CoCase scrut alts)
+floatExpr sw env lvl (Case scrut alts)
   = case (floatExpr sw env lvl scrut) of { (fse, fde, scrut') ->
 
-    case (scrut', float_alts alts) of 
+    case (scrut', float_alts alts) of
 
 {-	CASE-FLOATING DROPPED FOR NOW.  (SLPJ 7/2/94)
 
-	(CoVar scrut_var, (fda, CoAlgAlts [(con,bs,rhs')] CoNoDefault)) 
+	(Var scrut_var, (fda, AlgAlts [(con,bs,rhs')] NoDefault))
 	 	| scrut_var_lvl `ltMajLvl` lvl ->
 
 		-- Candidate for case floater; scrutinising a variable; it can
@@ -299,16 +291,16 @@ floatExpr sw env lvl (CoCase scrut alts)
 
 		where
 		case_floater = (scrut_var_lvl, CaseFloater fn)
-		fn body = CoCase scrut' (CoAlgAlts [(con,bs,body)] CoNoDefault)
+		fn body = Case scrut' (AlgAlts [(con,bs,body)] NoDefault)
 		scrut_var_lvl = case lookupIdEnv env scrut_var of
 				  Nothing  -> Level 0 0
 				  Just lvl -> unTopify lvl
 
  END OF CASE FLOATING DROPPED  	-}
 
-	(_, (fsa, fda, alts')) -> 
+	(_, (fsa, fda, alts')) ->
 
-		(add_stats fse fsa, fda ++ fde, CoCase scrut' alts') 
+		(add_stats fse fsa, fda ++ fde, Case scrut' alts')
     }
   where
       incd_lvl = incMinorLvl lvl
@@ -318,36 +310,36 @@ floatExpr sw env lvl (CoCase scrut alts)
 {-	OMITTED
 	We don't want to be too keen about floating lets out of case alternatives
 	because they may benefit from seeing the evaluation done by the case.
-	
+
 	The main reason for doing this is to allocate in fewer larger blocks
 	but that's really an STG-level issue.
 
 			case alts of
 				-- Just one alternative, then dump only
 				-- what *has* to be dumped
-			CoAlgAlts  [_] CoNoDefault	   -> partitionByLevel
-			CoAlgAlts  []  (CoBindDefault _ _) -> partitionByLevel
-			CoPrimAlts [_] CoNoDefault	   -> partitionByLevel
-			CoPrimAlts []  (CoBindDefault _ _) -> partitionByLevel
+			AlgAlts  [_] NoDefault	   -> partitionByLevel
+			AlgAlts  []  (BindDefault _ _) -> partitionByLevel
+			PrimAlts [_] NoDefault	   -> partitionByLevel
+			PrimAlts []  (BindDefault _ _) -> partitionByLevel
 
 				-- If there's more than one alternative, then
 				-- this is a dumping point
 			other				   -> partitionByMajorLevel
 -}
 
-      float_alts (CoAlgAlts alts deflt)
+      float_alts (AlgAlts alts deflt)
 	= case (float_deflt  deflt)		 of { (fsd,  fdd,  deflt') ->
 	  case (unzip3 (map float_alg_alt alts)) of { (fsas, fdas, alts') ->
 	  (foldr add_stats fsd fsas,
 	   concat fdas ++ fdd,
-	   CoAlgAlts alts' deflt') }}
+	   AlgAlts alts' deflt') }}
 
-      float_alts (CoPrimAlts alts deflt)
+      float_alts (PrimAlts alts deflt)
 	= case (float_deflt deflt)		  of { (fsd,   fdd, deflt') ->
 	  case (unzip3 (map float_prim_alt alts)) of { (fsas, fdas, alts') ->
 	  (foldr add_stats fsd fsas,
 	   concat fdas ++ fdd,
-	   CoPrimAlts alts' deflt') }}
+	   PrimAlts alts' deflt') }}
 
       -------------
       float_alg_alt (con, bs, rhs)
@@ -366,14 +358,14 @@ floatExpr sw env lvl (CoCase scrut alts)
 	  (fs, rhs_floats', (lit, install heres rhs')) }}
 
       --------------
-      float_deflt CoNoDefault = (zero_stats, [], CoNoDefault)
+      float_deflt NoDefault = (zero_stats, [], NoDefault)
 
-      float_deflt (CoBindDefault (b,lvl) rhs)
+      float_deflt (BindDefault (b,lvl) rhs)
 	= case (floatExpr sw new_env lvl rhs)		of { (fs, rhs_floats, rhs') ->
 	  case (partition_fn incd_lvl rhs_floats)	of { (rhs_floats', heres) ->
-	  (fs, rhs_floats', CoBindDefault b (install heres rhs')) }}
+	  (fs, rhs_floats', BindDefault b (install heres rhs')) }}
 	where
-	  new_env = addOneToIdEnv env b lvl        
+	  new_env = addOneToIdEnv env b lvl
 \end{code}
 
 %************************************************************************
@@ -415,8 +407,8 @@ add_to_stats (FlS a b c) floats
 %************************************************************************
 
 \begin{code}
-getBindLevel (CoNonRec (_, lvl) _)      = lvl
-getBindLevel (CoRec (((_,lvl), _) : _)) = lvl
+getBindLevel (NonRec (_, lvl) _)      = lvl
+getBindLevel (Rec (((_,lvl), _) : _)) = lvl
 \end{code}
 
 \begin{code}
@@ -429,7 +421,7 @@ partitionByMajorLevel, partitionByLevel
 	    FloatingBinds)	-- The rest
 
 
-partitionByMajorLevel ctxt_lvl defns 
+partitionByMajorLevel ctxt_lvl defns
   = partition float_further defns
   where
     float_further (my_lvl, _) = my_lvl `ltMajLvl` ctxt_lvl ||
@@ -442,25 +434,25 @@ partitionByLevel ctxt_lvl defns
 \end{code}
 
 \begin{code}
-floatsToBinds :: FloatingBinds -> [PlainCoreBinding]
+floatsToBinds :: FloatingBinds -> [CoreBinding]
 floatsToBinds floats = map get_bind floats
 		     where
 		       get_bind (_, LetFloater bind) = bind
 		       get_bind (_, CaseFloater _)   = panic "floatsToBinds"
 
-floatsToBindPairs :: FloatingBinds -> [(Id,PlainCoreExpr)]
+floatsToBindPairs :: FloatingBinds -> [(Id,CoreExpr)]
 
 floatsToBindPairs floats = concat (map mk_pairs floats)
   where
-   mk_pairs (_, LetFloater (CoRec pairs))         = pairs
-   mk_pairs (_, LetFloater (CoNonRec binder rhs)) = [(binder,rhs)]
+   mk_pairs (_, LetFloater (Rec pairs))         = pairs
+   mk_pairs (_, LetFloater (NonRec binder rhs)) = [(binder,rhs)]
    mk_pairs (_, CaseFloater _) 			  = panic "floatsToBindPairs"
 
-install :: FloatingBinds -> PlainCoreExpr -> PlainCoreExpr
+install :: FloatingBinds -> CoreExpr -> CoreExpr
 
 install defn_groups expr
   = foldr install_group expr defn_groups
   where
-    install_group (_, LetFloater defns) body = CoLet defns body
+    install_group (_, LetFloater defns) body = Let defns body
     install_group (_, CaseFloater fn)   body = fn body
 \end{code}
diff --git a/ghc/compiler/simplCore/FoldrBuildWW.hi b/ghc/compiler/simplCore/FoldrBuildWW.hi
deleted file mode 100644
index 4db2b9d4ca..0000000000
--- a/ghc/compiler/simplCore/FoldrBuildWW.hi
+++ /dev/null
@@ -1,8 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface FoldrBuildWW where
-import CmdLineOpts(GlobalSwitch)
-import CoreSyn(CoreBinding)
-import Id(Id)
-import SplitUniq(SplitUniqSupply)
-mkFoldrBuildWW :: (GlobalSwitch -> Bool) -> SplitUniqSupply -> [CoreBinding Id Id] -> [CoreBinding Id Id]
-
diff --git a/ghc/compiler/simplCore/FoldrBuildWW.lhs b/ghc/compiler/simplCore/FoldrBuildWW.lhs
index 9f480ee445..a3a8a6ab54 100644
--- a/ghc/compiler/simplCore/FoldrBuildWW.lhs
+++ b/ghc/compiler/simplCore/FoldrBuildWW.lhs
@@ -1,5 +1,5 @@
 %
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
 %
 \section[FoldrBuildWW]{Spliting suitable functions into Workers and Wrappers}
 
@@ -10,137 +10,135 @@ module FoldrBuildWW ( mkFoldrBuildWW ) where
 
 IMPORT_Trace
 import Outputable
-import Pretty 
-import AbsUniType	( alpha_tv, cloneTyVarFromTemplate, mkTyVarTy,
-			  splitTypeWithDictsAsArgs, eqTyCon,  mkForallTy,
-			  alpha_tyvar, alpha_ty, alpha, TyVarTemplate
-			  IF_ATTACK_PRAGMAS(COMMA cmpTyCon)
-			)
-import UniType		( UniType(..) ) -- **** CAN SEE THE CONSTRUCTORS ****
-import PlainCore
-import Unique		( runBuiltinUs )
+import Pretty
+import Type		( cloneTyVarFromTemplate, mkTyVarTy,
+			  splitTypeWithDictsAsArgs, eqTyCon,  mkForallTy )
+import TysPrim		( alphaTy )
+import TyVar		( alphaTyVar )
+
+import Type		( Type(..) ) -- **** CAN SEE THE CONSTRUCTORS ****
+import UniqSupply	( runBuiltinUs )
 import WwLib            -- share the same monad (is this eticit ?)
-import AbsPrel		( listTyCon, mkListTy, nilDataCon, consDataCon,
-			  foldrId, mkBuild, mkFoldr, buildId,
-			  mkFunTy
+import PrelInfo		( listTyCon, mkListTy, nilDataCon, consDataCon,
+			  foldrId, buildId
 			)
 import Id               ( getIdFBTypeInfo, mkWorkerId, getIdInfo,
-			  replaceIdInfo, mkSysLocal, getIdUniType
+			  replaceIdInfo, mkSysLocal, idType
 			)
-import IdInfo           
+import IdInfo
 import Maybes
 import SrcLoc		( mkUnknownSrcLoc, SrcLoc )
 import Util
 \end{code}
 
 \begin{code}
-mkFoldrBuildWW 
-        :: (GlobalSwitch -> Bool)
-        -> SplitUniqSupply 
-        -> PlainCoreProgram 
-        -> PlainCoreProgram
-mkFoldrBuildWW switch us top_binds = 
+mkFoldrBuildWW
+	:: (GlobalSwitch -> Bool)
+	-> UniqSupply
+	-> [CoreBinding]
+	-> [CoreBinding]
+mkFoldrBuildWW switch us top_binds =
    (mapWw wwBind top_binds `thenWw` \ top_binds2 ->
    returnWw (concat top_binds2)) us switch
 \end{code}
 
 \begin{code}
-wwBind :: PlainCoreBinding -> WwM [PlainCoreBinding]
-wwBind (CoNonRec bndr expr) 
+wwBind :: CoreBinding -> WwM [CoreBinding]
+wwBind (NonRec bndr expr)
   = try_split_bind bndr expr    `thenWw` \ re ->
-    returnWw [CoNonRec bnds expr | (bnds,expr) <- re]
-wwBind (CoRec binds) 
+    returnWw [NonRec bnds expr | (bnds,expr) <- re]
+wwBind (Rec binds)
   = mapWw (\ (bndr,expr) -> try_split_bind bndr expr) binds   `thenWw` \ res ->
-    returnWw [CoRec (concat res)]
-
-wwExpr :: PlainCoreExpr -> WwM PlainCoreExpr
-wwExpr e@(CoVar _) = returnWw e
-wwExpr e@(CoLit _) = returnWw e
-wwExpr e@(CoCon _ _ _) = returnWw e
-wwExpr e@(CoPrim _ _ _) = returnWw e
-wwExpr   (CoLam ids e) = 
-        wwExpr e                `thenWw` \ e' ->
-        returnWw (CoLam ids e')
-wwExpr   (CoTyLam tyvar e) = 
-        wwExpr e                `thenWw` \ e' ->
-        returnWw (CoTyLam tyvar e')
-wwExpr   (CoApp f atom) = 
-        wwExpr f                `thenWw` \ f' ->
-        returnWw (CoApp f atom)
-wwExpr   (CoTyApp f ty) = 
-        wwExpr f                `thenWw` \ f' ->
-        returnWw (CoTyApp f' ty)
-wwExpr   (CoSCC lab e) = 
-        wwExpr e                `thenWw` \ e' ->
-        returnWw (CoSCC lab e')
-wwExpr   (CoLet bnds e) = 
-        wwExpr e                `thenWw` \ e' ->
-        wwBind bnds             `thenWw` \ bnds' ->
-        returnWw (foldr CoLet e' bnds')
-wwExpr   (CoCase e alts) =
-        wwExpr e                `thenWw` \ e' ->
-        wwAlts alts             `thenWw` \ alts' ->
-        returnWw  (CoCase e' alts')
-
-wwAlts (CoAlgAlts alts deflt) =
-        mapWw (\(con,binders,e) -> 
-                        wwExpr e        `thenWw` \ e' ->
-                        returnWw (con,binders,e')) alts `thenWw` \ alts' ->
-        wwDef deflt                                     `thenWw` \ deflt' ->
-        returnWw (CoAlgAlts alts' deflt)
-wwAlts (CoPrimAlts alts deflt) =
-        mapWw (\(lit,e) -> 
-                        wwExpr e        `thenWw` \ e' ->
-                        returnWw (lit,e')) alts         `thenWw` \ alts' ->
-        wwDef deflt                                     `thenWw` \ deflt' ->
-        returnWw (CoPrimAlts alts' deflt)
-
-wwDef e@CoNoDefault = returnWw e
-wwDef  (CoBindDefault v e) = 
-        wwExpr e                                        `thenWw` \ e' ->
-        returnWw (CoBindDefault v e')
+    returnWw [Rec (concat res)]
+
+wwExpr :: CoreExpr -> WwM CoreExpr
+wwExpr e@(Var _) = returnWw e
+wwExpr e@(Lit _) = returnWw e
+wwExpr e@(Con _ _ _) = returnWw e
+wwExpr e@(Prim _ _ _) = returnWw e
+wwExpr   (Lam ids e) =
+	wwExpr e                `thenWw` \ e' ->
+	returnWw (Lam ids e')
+wwExpr   (CoTyLam tyvar e) =
+	wwExpr e                `thenWw` \ e' ->
+	returnWw (CoTyLam tyvar e')
+wwExpr   (App f atom) =
+	wwExpr f                `thenWw` \ f' ->
+	returnWw (App f atom)
+wwExpr   (CoTyApp f ty) =
+	wwExpr f                `thenWw` \ f' ->
+	returnWw (CoTyApp f' ty)
+wwExpr   (SCC lab e) =
+	wwExpr e                `thenWw` \ e' ->
+	returnWw (SCC lab e')
+wwExpr   (Let bnds e) =
+	wwExpr e                `thenWw` \ e' ->
+	wwBind bnds             `thenWw` \ bnds' ->
+	returnWw (foldr Let e' bnds')
+wwExpr   (Case e alts) =
+	wwExpr e                `thenWw` \ e' ->
+	wwAlts alts             `thenWw` \ alts' ->
+	returnWw  (Case e' alts')
+
+wwAlts (AlgAlts alts deflt) =
+	mapWw (\(con,binders,e) ->
+			wwExpr e        `thenWw` \ e' ->
+			returnWw (con,binders,e')) alts `thenWw` \ alts' ->
+	wwDef deflt                                     `thenWw` \ deflt' ->
+	returnWw (AlgAlts alts' deflt)
+wwAlts (PrimAlts alts deflt) =
+	mapWw (\(lit,e) ->
+			wwExpr e        `thenWw` \ e' ->
+			returnWw (lit,e')) alts         `thenWw` \ alts' ->
+	wwDef deflt                                     `thenWw` \ deflt' ->
+	returnWw (PrimAlts alts' deflt)
+
+wwDef e@NoDefault = returnWw e
+wwDef  (BindDefault v e) =
+	wwExpr e                                        `thenWw` \ e' ->
+	returnWw (BindDefault v e')
 \end{code}
 
 \begin{code}
-try_split_bind :: Id -> PlainCoreExpr -> WwM [(Id,PlainCoreExpr)]
-try_split_bind id expr = 
+try_split_bind :: Id -> CoreExpr -> WwM [(Id,CoreExpr)]
+try_split_bind id expr =
   wwExpr expr                   `thenWw` \ expr' ->
   case getFBType (getIdFBTypeInfo id) of
-    Just (FBType consum prod) 
-        |  FBGoodProd == prod ->
+    Just (FBType consum prod)
+	|  FBGoodProd == prod ->
 {-      || any (== FBGoodConsum) consum -}
       let
-        (big_args,args,body) = digForLambdas expr'
+	(use_args,big_args,args,body) = digForLambdas expr'
       in
-        if length args /= length consum   -- funny number of arguments
-        then returnWw [(id,expr')]
-        else 
-        -- f /\ t1 .. tn \ v1 .. vn -> e
-        -- 	===>
-        -- f_wrk /\ t1 .. tn t_new \ v1 .. vn c n -> foldr <exprTy> <nTy> c n e
-        -- f /\ t1 .. tn \ v1 .. vn 
+	if length args /= length consum   -- funny number of arguments
+	then returnWw [(id,expr')]
+	else
+	-- f /\ t1 .. tn \ v1 .. vn -> e
+	-- 	===>
+	-- f_wrk /\ t1 .. tn t_new \ v1 .. vn c n -> foldr <exprTy> <nTy> c n e
+	-- f /\ t1 .. tn \ v1 .. vn
 	--	-> build exprTy (\ c n -> f_wrk t1 .. tn t_new v1 .. vn c n)
 	pprTrace "WW:" (ppr PprDebug id) (returnWw ())
 				`thenWw` \ () ->
-        getUniqueWw             `thenWw` \ ty_new_uq ->
-        getUniqueWw             `thenWw` \ worker_new_uq ->
-        getUniqueWw             `thenWw` \ c_new_uq ->
-        getUniqueWw             `thenWw` \ n_new_uq ->
+	getUniqueWw             `thenWw` \ ty_new_uq ->
+	getUniqueWw             `thenWw` \ worker_new_uq ->
+	getUniqueWw             `thenWw` \ c_new_uq ->
+	getUniqueWw             `thenWw` \ n_new_uq ->
       let
 	-- The *new* type
-	n_ty = alpha_ty
-	n_ty_templ = alpha
+	n_ty = alphaTy
+	n_ty_templ = alphaTy
 
-	(templ,arg_tys,res) = splitTypeWithDictsAsArgs (getIdUniType id)
+	(templ,arg_tys,res) = splitTypeWithDictsAsArgs (idType id)
 	expr_ty = getListTy res
-   	getListTy res = case res of
-		         UniData lty [ty] | lty `eqTyCon` listTyCon -> ty
-		         _ -> panic "Trying to split a non List datatype into Worker/Wrapper"
+   	getListTy res = panic "FoldrBuildWW:getListTy:ToDo" {-LATER:case res of
+			 UniData lty [ty] | lty `eqTyCon` listTyCon -> ty
+			 _ -> panic "Trying to split a non List datatype into Worker/Wrapper"-}
 
-        c_ty       = expr_ty `mkFunTy` (n_ty `mkFunTy` n_ty)
-        c_ty_templ = expr_ty `mkFunTy` (n_ty_templ `mkFunTy` n_ty_templ)
+	c_ty       = expr_ty `mkFunTy` (n_ty `mkFunTy` n_ty)
+	c_ty_templ = expr_ty `mkFunTy` (n_ty_templ `mkFunTy` n_ty_templ)
 
-	worker_ty = mkForallTy (templ  ++ [alpha_tv])
+	worker_ty = mkForallTy (templ  ++ [alphaTyVar])
 			(foldr mkFunTy n_ty_templ (arg_tys++[c_ty_templ,n_ty_templ]))
 	wrapper_id  = id `replaceIdInfo`
 			      (getIdInfo id	`addInfo_UF`
@@ -150,32 +148,33 @@ try_split_bind id expr =
 		-- TODO : CHECK if mkWorkerId is thr
 		-- 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
-	worker_rhs = foldr CoTyLam 
-			(mkCoLam (args++[c_id,n_id]) worker_body) 
-			(big_args ++ [alpha_tyvar])
+	worker_rhs
+	  = mkTyLam [] (big_args ++ [alphaTyVar]) (args++[c_id,n_id]) worker_body
+			
 	worker_body = runBuiltinUs (
-			 mkCoApps (mkCoTyApps (CoVar foldrId) [expr_ty, n_ty])
-				  [CoVar c_id,CoVar n_id,body])
-	wrapper_rhs = foldr CoTyLam 
-			(mkCoLam (args) wrapper_body) 
-			big_args
+	  mkCoApps
+	    (Var foldrId `CoTyApp` expr_ty `CoTyApp` n_ty `App`
+	       VarArg c_id `App` VarArg n_id)
+	    [body])
+	wrapper_rhs = mkLam big_args args wrapper_body
+
 	wrapper_body = runBuiltinUs (
-		 mkCoApps (mkCoTyApp (CoVar buildId) expr_ty)
-				[CoTyLam alpha_tyvar (mkCoLam [c_id,n_id]
-		(foldl CoApp 
-			(mkCoTyApps (CoVar worker_id) 
-				[mkTyVarTy t | t <- big_args ++ [alpha_tyvar]])
-			(map CoVarAtom (args++[c_id,n_id]))))])
+		 mkCoApps (CoTyApp (Var buildId) expr_ty)
+				[mkLam [alphaTyVar] [c_id,n_id]
+		(foldl App
+			(mkCoTyApps (Var worker_id)
+				[mkTyVarTy t | t <- big_args ++ [alphaTyVar]])
+			(map VarArg (args++[c_id,n_id])))])
 
       in
 	if length args /= length arg_tys ||
-	   length big_args /= length templ 
+	   length big_args /= length templ
 	then panic "LEN PROBLEM"
 	else
-        returnWw  [(worker_id,worker_rhs),(wrapper_id,wrapper_rhs)]
+	returnWw  [(worker_id,worker_rhs),(wrapper_id,wrapper_rhs)]
     _ -> returnWw [(id,expr')]
 \end{code}
 
diff --git a/ghc/compiler/simplCore/LiberateCase.hi b/ghc/compiler/simplCore/LiberateCase.hi
deleted file mode 100644
index 5646aa0f6b..0000000000
--- a/ghc/compiler/simplCore/LiberateCase.hi
+++ /dev/null
@@ -1,6 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface LiberateCase where
-import CoreSyn(CoreBinding)
-import Id(Id)
-liberateCase :: Int -> [CoreBinding Id Id] -> [CoreBinding Id Id]
-
diff --git a/ghc/compiler/simplCore/LiberateCase.lhs b/ghc/compiler/simplCore/LiberateCase.lhs
index 908f28a523..4c17f204d0 100644
--- a/ghc/compiler/simplCore/LiberateCase.lhs
+++ b/ghc/compiler/simplCore/LiberateCase.lhs
@@ -9,15 +9,11 @@
 
 module LiberateCase ( liberateCase ) where
 
-IMPORT_Trace
-
+import CoreUnfold	( UnfoldingGuidance(..) )
 import Id		( localiseId, toplevelishId{-debugging-} )
-import IdEnv
 import Maybes
 import Outputable
-import PlainCore
 import Pretty
-import SimplEnv		( UnfoldingGuidance(..) )
 import Util
 \end{code}
 
@@ -30,7 +26,7 @@ Example
 
 \begin{verbatim}
 f = \ t -> case v of
-	       V a b -> a : f t 
+	       V a b -> a : f t
 \end{verbatim}
 
 => the inner f is replaced.
@@ -39,8 +35,8 @@ f = \ t -> case v of
 f = \ t -> case v of
 	       V a b -> a : (letrec
 				f =  \ t -> case v of
-					       V a b -> a : f t 
-			     in f) t 
+					       V a b -> a : f t
+			     in f) t
 \end{verbatim}
 (note the NEED for shadowing)
 
@@ -48,7 +44,7 @@ f = \ t -> case v of
 \begin{verbatim}
 f = \ t -> case v of
 	       V a b -> a : (letrec
-				f = \ t -> a : f t 
+				f = \ t -> a : f t
 			     in f t)
 \begin{verbatim}
 Better code, because 'a' is  free inside the inner letrec, rather
@@ -80,18 +76,18 @@ scope.  For example:
 	let h = ...
 	in ...
 \end{verbatim}
-Here, the level of @f@ is zero, the level of @g@ is one, 
+Here, the level of @f@ is zero, the level of @g@ is one,
 and the level of @h@ is zero (NB not one).
 
 \begin{code}
-type LibCaseLevel = Int		
+type LibCaseLevel = Int
 
 topLevel :: LibCaseLevel
 topLevel = 0
 \end{code}
 
 \begin{code}
-data LibCaseEnv 
+data LibCaseEnv
   = LibCaseEnv
 	Int			-- Bomb-out size for deciding if
 				-- potential liberatees are too big.
@@ -103,7 +99,7 @@ data LibCaseEnv
 				-- (top-level and imported things have
 				-- a level of zero)
 
-	(IdEnv PlainCoreBinding)-- Binds *only* recursively defined
+	(IdEnv CoreBinding)-- Binds *only* recursively defined
 				-- Ids, to their own binding group,
 				-- and *only* in their own RHSs
 
@@ -126,7 +122,7 @@ bombOutSize (LibCaseEnv bomb_size _ _ _ _) = bomb_size
 Programs
 ~~~~~~~~
 \begin{code}
-liberateCase :: Int -> [PlainCoreBinding] -> [PlainCoreBinding]
+liberateCase :: Int -> [CoreBinding] -> [CoreBinding]
 liberateCase bomb_size prog
   = do_prog (initEnv bomb_size) prog
   where
@@ -140,13 +136,13 @@ Bindings
 ~~~~~~~~
 
 \begin{code}
-libCaseBind :: LibCaseEnv -> PlainCoreBinding -> (LibCaseEnv, PlainCoreBinding)
+libCaseBind :: LibCaseEnv -> CoreBinding -> (LibCaseEnv, CoreBinding)
 
-libCaseBind env (CoNonRec binder rhs)
-  = (addBinders env [binder], CoNonRec binder (libCase env rhs))
+libCaseBind env (NonRec binder rhs)
+  = (addBinders env [binder], NonRec binder (libCase env rhs))
 
-libCaseBind env (CoRec pairs)
-  = (env_body, CoRec pairs') 
+libCaseBind env (Rec pairs)
+  = (env_body, Rec pairs')
   where
     (binders, rhss) = unzip pairs
 
@@ -168,7 +164,7 @@ libCaseBind env (CoRec pairs)
 	-- copy of the original binding.  In particular, the original
 	-- binding might have been for a TopLevId, and this copy clearly
 	-- will not be top-level!
-	
+
 	-- It is enough to change just the binder, because subsequent
 	-- simplification will propagate the right info from the binder.
 
@@ -190,33 +186,31 @@ Expressions
 
 \begin{code}
 libCase :: LibCaseEnv
-	-> PlainCoreExpr
-	-> PlainCoreExpr
+	-> CoreExpr
+	-> CoreExpr
 
-libCase env (CoLit lit)		 = CoLit lit
-libCase env (CoVar v)		 = mkCoLetsNoUnboxed (libCaseId env v) (CoVar v)
-libCase env (CoApp fun arg)      = mkCoLetsNoUnboxed (libCaseAtom env arg) (CoApp (libCase env fun) arg)
+libCase env (Lit lit)		 = Lit lit
+libCase env (Var v)		 = mkCoLetsNoUnboxed (libCaseId env v) (Var v)
+libCase env (App fun arg)      = mkCoLetsNoUnboxed (libCaseAtom env arg) (App (libCase env fun) arg)
 libCase env (CoTyApp fun ty)     = CoTyApp (libCase env fun) ty
-libCase env (CoCon con tys args) = mkCoLetsNoUnboxed (libCaseAtoms env args) (CoCon con tys args)
-libCase env (CoPrim op tys args) = mkCoLetsNoUnboxed (libCaseAtoms env args) (CoPrim op tys args)
+libCase env (Con con tys args) = mkCoLetsNoUnboxed (libCaseAtoms env args) (Con con tys args)
+libCase env (Prim op tys args) = mkCoLetsNoUnboxed (libCaseAtoms env args) (Prim op tys args)
 libCase env (CoTyLam tyvar body) = CoTyLam tyvar (libCase env body)
-libCase env (CoSCC cc body)      = CoSCC cc (libCase env body)
+libCase env (SCC cc body)      = SCC cc (libCase env body)
 
-libCase env (CoLam binders body)
-  = CoLam binders (libCase env' body)
-  where
-    env' = addBinders env binders
+libCase env (Lam binder body)
+  = Lam binder (libCase (addBinders env [binder]) body)
 
-libCase env (CoLet bind body) 
-  = CoLet bind' (libCase env_body body)
+libCase env (Let bind body)
+  = Let bind' (libCase env_body body)
   where
     (env_body, bind') = libCaseBind env bind
 
-libCase env (CoCase scrut alts)
-  = CoCase (libCase env scrut) (libCaseAlts env_alts alts)
+libCase env (Case scrut alts)
+  = Case (libCase env scrut) (libCaseAlts env_alts alts)
   where
     env_alts = case scrut of
-		  CoVar scrut_var -> addScrutedVar env scrut_var
+		  Var scrut_var -> addScrutedVar env scrut_var
 		  other		  -> env
 \end{code}
 
@@ -225,33 +219,33 @@ Case alternatives
 ~~~~~~~~~~~~~~~~~
 
 \begin{code}
-libCaseAlts env (CoAlgAlts alts deflt)
-  = CoAlgAlts (map do_alt alts) (libCaseDeflt env deflt)
+libCaseAlts env (AlgAlts alts deflt)
+  = AlgAlts (map do_alt alts) (libCaseDeflt env deflt)
   where
     do_alt (con,args,rhs) = (con, args, libCase (addBinders env args) rhs)
 
-libCaseAlts env (CoPrimAlts alts deflt)
-  = CoPrimAlts (map do_alt alts) (libCaseDeflt env deflt) 
+libCaseAlts env (PrimAlts alts deflt)
+  = PrimAlts (map do_alt alts) (libCaseDeflt env deflt)
   where
     do_alt (lit,rhs) = (lit, libCase env rhs)
 
-libCaseDeflt env CoNoDefault 
-   = CoNoDefault
-libCaseDeflt env (CoBindDefault binder rhs) 
-   = CoBindDefault binder (libCase (addBinders env [binder]) rhs)
+libCaseDeflt env NoDefault
+   = NoDefault
+libCaseDeflt env (BindDefault binder rhs)
+   = BindDefault binder (libCase (addBinders env [binder]) rhs)
 \end{code}
 
 Atoms and Ids
 ~~~~~~~~~~~~~
 \begin{code}
-libCaseAtoms :: LibCaseEnv -> [PlainCoreAtom] -> [PlainCoreBinding]
+libCaseAtoms :: LibCaseEnv -> [CoreArg] -> [CoreBinding]
 libCaseAtoms env atoms = concat [libCaseAtom env atom | atom <- atoms]
 
-libCaseAtom :: LibCaseEnv -> PlainCoreAtom -> [PlainCoreBinding]
-libCaseAtom env (CoVarAtom arg_id) = libCaseId env arg_id
-libCaseAtom env (CoLitAtom lit)    = []
+libCaseAtom :: LibCaseEnv -> CoreArg -> [CoreBinding]
+libCaseAtom env (VarArg arg_id) = libCaseId env arg_id
+libCaseAtom env (LitArg lit)    = []
 
-libCaseId :: LibCaseEnv -> Id -> [PlainCoreBinding]
+libCaseId :: LibCaseEnv -> Id -> [CoreBinding]
 libCaseId env v
   | maybeToBool maybe_rec_bind &&	-- It's a use of a recursive thing
     there_are_free_scruts		-- with free vars scrutinised in RHS
@@ -261,14 +255,14 @@ libCaseId env v
   = []
 
   where
-    maybe_rec_bind :: Maybe PlainCoreBinding	-- The binding of the recursive thingy
+    maybe_rec_bind :: Maybe CoreBinding	-- The binding of the recursive thingy
     maybe_rec_bind = lookupRecId env v
     Just the_bind = maybe_rec_bind
 
     rec_id_level = lookupLevel env v
 
     there_are_free_scruts = freeScruts env rec_id_level
-\end{code}			
+\end{code}
 
 
 
@@ -281,23 +275,23 @@ addBinders (LibCaseEnv bomb lvl lvl_env rec_env scruts) binders
   where
     lvl_env' = growIdEnvList lvl_env (binders `zip` repeat lvl)
 
-addRecBinds :: LibCaseEnv -> [(Id,PlainCoreExpr)] -> LibCaseEnv
+addRecBinds :: LibCaseEnv -> [(Id,CoreExpr)] -> LibCaseEnv
 addRecBinds (LibCaseEnv bomb lvl lvl_env rec_env scruts) pairs
   = LibCaseEnv bomb lvl' lvl_env' rec_env' scruts
   where
     lvl'     = lvl + 1
     lvl_env' = growIdEnvList lvl_env [(binder,lvl) | (binder,_) <- pairs]
-    rec_env' = growIdEnvList rec_env [(binder, CoRec pairs) | (binder,_) <- pairs]
+    rec_env' = growIdEnvList rec_env [(binder, Rec pairs) | (binder,_) <- pairs]
 
-addScrutedVar :: LibCaseEnv 
+addScrutedVar :: LibCaseEnv
 	      -> Id		-- This Id is being scrutinised by a case expression
-	      -> LibCaseEnv	
+	      -> LibCaseEnv
 
 addScrutedVar env@(LibCaseEnv bomb lvl lvl_env rec_env scruts) scrut_var
   | bind_lvl < lvl
   = LibCaseEnv bomb lvl lvl_env rec_env scruts'
 	-- Add to scruts iff the scrut_var is being scrutinised at
-	-- a deeper level than its defn 
+	-- a deeper level than its defn
 
   | otherwise = env
   where
@@ -307,7 +301,7 @@ addScrutedVar env@(LibCaseEnv bomb lvl lvl_env rec_env scruts) scrut_var
 		 Nothing  -> --false: ASSERT(toplevelishId scrut_var)
 			     topLevel
 
-lookupRecId :: LibCaseEnv -> Id -> Maybe PlainCoreBinding
+lookupRecId :: LibCaseEnv -> Id -> Maybe CoreBinding
 lookupRecId (LibCaseEnv bomb lvl lvl_env rec_env scruts) id
 #ifndef DEBUG
   = lookupIdEnv rec_env id
@@ -325,7 +319,7 @@ lookupLevel (LibCaseEnv bomb lvl lvl_env rec_env scruts) id
       Nothing  -> ASSERT(toplevelishId id)
 		  topLevel
 
-freeScruts :: LibCaseEnv 
+freeScruts :: LibCaseEnv
 	   -> LibCaseLevel 	-- Level of the recursive Id
 	   -> Bool		-- True <=> there is an enclosing case of a variable
 				-- bound outside (ie level <=) the recursive Id.
@@ -333,4 +327,4 @@ freeScruts (LibCaseEnv bomb lvl lvl_env rec_env scruts) rec_bind_lvl
   = not (null free_scruts)
   where
     free_scruts = [v | (v,lvl) <- scruts, lvl > rec_bind_lvl]
-\end{code} 
+\end{code}
diff --git a/ghc/compiler/simplCore/MagicUFs.hi b/ghc/compiler/simplCore/MagicUFs.hi
deleted file mode 100644
index daad918f39..0000000000
--- a/ghc/compiler/simplCore/MagicUFs.hi
+++ /dev/null
@@ -1,33 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface MagicUFs where
-import BasicLit(BasicLit)
-import CoreSyn(CoreArg, CoreAtom, CoreBinding, CoreCaseAlternatives, CoreExpr)
-import CostCentre(CostCentre)
-import Id(Id)
-import Maybes(Labda)
-import PlainCore(PlainCoreArg(..), PlainCoreAtom(..), PlainCoreExpr(..))
-import PreludePS(_PackedString)
-import PrimOps(PrimOp)
-import SimplEnv(SimplEnv)
-import SimplMonad(SimplCount, SmplM(..), TickType)
-import SplitUniq(SplitUniqSupply)
-import TyVar(TyVar)
-import UniType(UniType)
-data CoreArg a 
-data CoreAtom a 
-data CoreExpr a b 
-data Id 
-data Labda a 
-data MagicUnfoldingFun 
-type PlainCoreArg = CoreArg Id
-type PlainCoreAtom = CoreAtom Id
-type PlainCoreExpr = CoreExpr Id Id
-data SimplEnv 
-data SimplCount 
-type SmplM a = SplitUniqSupply -> SimplCount -> (a, SimplCount)
-data TickType 
-data SplitUniqSupply 
-data UniType 
-applyMagicUnfoldingFun :: MagicUnfoldingFun -> SimplEnv -> [CoreArg Id] -> SplitUniqSupply -> SimplCount -> (Labda (CoreExpr Id Id), SimplCount)
-mkMagicUnfoldingFun :: _PackedString -> MagicUnfoldingFun
-
diff --git a/ghc/compiler/simplCore/MagicUFs.lhs b/ghc/compiler/simplCore/MagicUFs.lhs
index 0f29a90a0f..a56b4c9003 100644
--- a/ghc/compiler/simplCore/MagicUFs.lhs
+++ b/ghc/compiler/simplCore/MagicUFs.lhs
@@ -1,5 +1,5 @@
 %
-% (c) The GRASP/AQUA Project, Glasgow University, 1993-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1993-1996
 %
 \section[MagicUFs]{Magic unfoldings that the simplifier knows about}
 
@@ -7,37 +7,21 @@
 #include "HsVersions.h"
 
 module MagicUFs (
-        MagicUnfoldingFun,  -- absolutely abstract
-
-        mkMagicUnfoldingFun,
-        applyMagicUnfoldingFun,
-        
-        CoreArg, PlainCoreArg(..), CoreAtom, PlainCoreAtom(..),
-        CoreExpr, PlainCoreExpr(..), Id, Maybe, SimplEnv,
-	SplitUniqSupply, TickType, UniType,
-	SmplM(..), SimplCount
+	MagicUnfoldingFun,  -- absolutely abstract
+
+	mkMagicUnfoldingFun,
+	applyMagicUnfoldingFun
     ) where
 
-IMPORT_Trace            -- ToDo: not sure why this is being used
-
-import AbsPrel          ( foldlId, foldrId, buildId, augmentId,
-                          nilDataCon, consDataCon, mkListTy, mkFunTy,
-                          unpackCStringAppendId, unpackCStringFoldrId,
-			  appendId
-                        )
-import AbsUniType       ( splitTypeWithDictsAsArgs, TyVarTemplate )
-import BasicLit         ( BasicLit(..) )
-import CmdLineOpts      ( SimplifierSwitch(..), switchIsOn, SwitchResult )
-import Id
-import IdInfo
-import Maybes           ( Maybe(..), maybeToBool )
-import Outputable
-import PlainCore
-import Pretty
-import SimplEnv
-import SimplMonad
-import TaggedCore
-import Util
+import Ubiq{-uitous-}
+
+import CoreSyn
+import PrelInfo		( mkListTy )
+import SimplEnv		( SimplEnv )
+import SimplMonad	( SmplM(..), SimplCount )
+import Type		( mkFunTys )
+import Unique		( Unique{-instances-} )
+import Util		( assoc, zipWith3Equal, panic )
 \end{code}
 
 %************************************************************************
@@ -49,29 +33,31 @@ import Util
 \begin{code}
 data MagicUnfoldingFun
   = MUF ( SimplEnv              -- state of play in simplifier...
-                                -- (note: we can get simplifier switches
-                                -- from the SimplEnv)
-        -> [PlainCoreArg]       -- arguments
-        -> SmplM (Maybe PlainCoreExpr))
-                                -- Just result, or Nothing
+				-- (note: we can get simplifier switches
+				-- from the SimplEnv)
+	-> [CoreArg]       -- arguments
+	-> SmplM (Maybe CoreExpr))
+				-- Just result, or Nothing
 \end{code}
 
-Give us a string tag, we'll give you back the corresponding MUF.
+Give us a value's @Unique@, we'll give you back the corresponding MUF.
 \begin{code}
-mkMagicUnfoldingFun :: FAST_STRING -> MagicUnfoldingFun
+mkMagicUnfoldingFun :: Unique -> MagicUnfoldingFun
 
 mkMagicUnfoldingFun tag
-  = assoc ("mkMagicUnfoldingFun:"  ++ _UNPK_ tag) magic_UFs_table tag
+  = assoc "mkMagicUnfoldingFun" magic_UFs_table tag
+
+magic_UFs_table = panic "MagicUFs.magic_UFs_table:ToDo"
 \end{code}
 
 Give us an MUF and stuff to apply it to, and we'll give you back the
 answer.
 \begin{code}
 applyMagicUnfoldingFun
-        :: MagicUnfoldingFun
-        -> SimplEnv
-        -> [PlainCoreArg]
-        -> SmplM (Maybe PlainCoreExpr)
+	:: MagicUnfoldingFun
+	-> SimplEnv
+	-> [CoreArg]
+	-> SmplM (Maybe CoreExpr)
 
 applyMagicUnfoldingFun (MUF fun) env args = fun env args
 \end{code}
@@ -83,6 +69,8 @@ applyMagicUnfoldingFun (MUF fun) env args = fun env args
 %************************************************************************
 
 \begin{code}
+{- LATER:
+
 magic_UFs_table :: [(FAST_STRING, MagicUnfoldingFun)]
 
 magic_UFs_table
@@ -104,44 +92,43 @@ magic_UFs_table
 -- First build, the way we express our lists.
 
 build_fun :: SimplEnv
-          -> [PlainCoreArg]
-          -> SmplM (Maybe PlainCoreExpr)
-build_fun env [TypeArg ty,ValArg (CoVarAtom e)] 
+	  -> [CoreArg]
+	  -> SmplM (Maybe CoreExpr)
+build_fun env [TypeArg ty,ValArg (VarArg e)]
 	| switchIsSet env SimplDoInlineFoldrBuild =
-        let
-                tyL     = mkListTy ty
-                ourCons = mkCoTyApp (CoVar consDataCon) ty
-                ourNil  = mkCoTyApp (CoVar nilDataCon) ty
-        in
-        newIds  [ ty `mkFunTy` (tyL `mkFunTy` tyL),
-                  tyL ]                 `thenSmpl` \ [c,n] ->
-        returnSmpl(Just (CoLet (CoNonRec c ourCons)
-                        (CoLet (CoNonRec n ourNil)
-                         (CoApp (CoApp (mkCoTyApp (CoVar e) tyL) (CoVarAtom c)) (CoVarAtom n)))))
+	let
+		tyL     = mkListTy ty
+		ourCons = CoTyApp (Var consDataCon) ty
+		ourNil  = CoTyApp (Var nilDataCon) ty
+	in
+	newIds  [ mkFunTys [ty, tyL] tyL, tyL ]	`thenSmpl` \ [c,n] ->
+	returnSmpl(Just (Let (NonRec c ourCons)
+			(Let (NonRec n ourNil)
+			 (App (App (CoTyApp (Var e) tyL) (VarArg c)) (VarArg n)))))
 -- ToDo: add `build' without an argument instance.
 -- This is strange, because of g's type.
-build_fun env _ = 
+build_fun env _ =
 	ASSERT (not (switchIsSet env SimplDoInlineFoldrBuild))
 	returnSmpl Nothing
 \end{code}
 
 \begin{code}
 augment_fun :: SimplEnv
-          -> [PlainCoreArg]
-          -> SmplM (Maybe PlainCoreExpr)
+	  -> [CoreArg]
+	  -> SmplM (Maybe CoreExpr)
 
-augment_fun env [TypeArg ty,ValArg (CoVarAtom e),ValArg nil] 
+augment_fun env [TypeArg ty,ValArg (VarArg e),ValArg nil]
 	| switchIsSet env SimplDoInlineFoldrBuild =
-        let
-                tyL     = mkListTy ty
-                ourCons = mkCoTyApp (CoVar consDataCon) ty
-        in
-        newId  (ty `mkFunTy` (tyL `mkFunTy` tyL))    `thenSmpl` \ c ->
-        returnSmpl (Just (CoLet (CoNonRec c ourCons)
-                         (CoApp (CoApp (mkCoTyApp (CoVar e) tyL) (CoVarAtom c)) nil)))
+	let
+		tyL     = mkListTy ty
+		ourCons = CoTyApp (Var consDataCon) ty
+	in
+	newId  (mkFunTys [ty, tyL] tyL)    `thenSmpl` \ c ->
+	returnSmpl (Just (Let (NonRec c ourCons)
+			 (App (App (CoTyApp (Var e) tyL) (VarArg c)) nil)))
 -- ToDo: add `build' without an argument instance.
 -- This is strange, because of g's type.
-augment_fun env _ = 
+augment_fun env _ =
 	ASSERT (not (switchIsSet env SimplDoInlineFoldrBuild))
 	returnSmpl Nothing
 \end{code}
@@ -150,8 +137,8 @@ Now foldr, the way we consume lists.
 
 \begin{code}
 foldr_fun :: SimplEnv
-          -> [PlainCoreArg]
-          -> SmplM (Maybe PlainCoreExpr)
+	  -> [CoreArg]
+	  -> SmplM (Maybe CoreExpr)
 
 foldr_fun env (TypeArg ty1:TypeArg ty2:ValArg arg_k:ValArg arg_z:rest_args)
   | do_fb_red && isConsFun env arg_k && isNilForm env arg_z
@@ -160,9 +147,9 @@ foldr_fun env (TypeArg ty1:TypeArg ty2:ValArg arg_k:ValArg arg_z:rest_args)
 	-- cf.  foldr (:) [] (build g) == g (:) []
 	-- with foldr (:) [] (build g) == build g
 	-- after unfolding build, they are the same thing.
-     tick Foldr_Cons_Nil		`thenSmpl_` 
+     tick Foldr_Cons_Nil		`thenSmpl_`
      newId (mkListTy ty1) 		`thenSmpl` \ x ->
-     returnSmpl({-trace "foldr (:) []"-} (Just (applyToArgs (CoLam [x] (CoVar x)) rest_args)))
+     returnSmpl({-trace "foldr (:) []"-} (Just (mkGenApp (Lam x (Var x)) rest_args)))
  where
    do_fb_red		= switchIsSet env SimplDoFoldrBuild
 
@@ -171,36 +158,36 @@ foldr_fun env (TypeArg ty1:TypeArg ty2:ValArg arg_k:ValArg arg_z:ValArg arg_list
   =     -- foldr f z [] = z
 	-- again another short cut, helps with unroling of constant lists
     tick Foldr_Nil	`thenSmpl_`
-    returnSmpl (Just (atomToExpr arg_z))
+    returnSmpl (Just (argToExpr arg_z))
 
-  | do_fb_red && arg_list_isBuildForm 
+  | do_fb_red && arg_list_isBuildForm
   =     -- foldr k z (build g) ==> g k z
 	-- this next line *is* the foldr/build rule proper.
     tick FoldrBuild	`thenSmpl_`
-    returnSmpl (Just (applyToArgs (CoVar g) (TypeArg ty2:ValArg arg_k:ValArg arg_z:rest_args)))
+    returnSmpl (Just (mkGenApp (Var g) (TypeArg ty2:ValArg arg_k:ValArg arg_z:rest_args)))
 
-  | do_fb_red && arg_list_isAugmentForm 
+  | do_fb_red && arg_list_isAugmentForm
   =     -- foldr k z (augment g h) ==> let v = foldr k z h in g k v
 	-- this next line *is* the foldr/augment rule proper.
     tick FoldrAugment	`thenSmpl_`
     newId ty2				`thenSmpl` \ v ->
-    returnSmpl (Just 
-		(CoLet (CoNonRec v (applyToArgs (CoVar foldrId)
+    returnSmpl (Just
+		(Let (NonRec v (mkGenApp (Var foldrId)
 					[TypeArg ty1,TypeArg ty2,
 					 ValArg arg_k,
 					 ValArg arg_z,
 					 ValArg h]))
-		(applyToArgs (CoVar g') (TypeArg ty2:ValArg arg_k:ValArg (CoVarAtom v):rest_args))))
+		(mkGenApp (Var g') (TypeArg ty2:ValArg arg_k:ValArg (VarArg v):rest_args))))
 
  | do_fb_red && arg_list_isListForm
- =      -- foldr k z (a:b:c:rest) = 
+ =      -- foldr k z (a:b:c:rest) =
 	--	(\ f -> f a (f b (f c (foldr f z rest)))) k rest_args
 	-- NB: 'k' is used just one by foldr, but 'f' is used many
 	-- times inside the list structure. This means that
 	-- 'f' needs to be inside a lambda, to make sure the simplifier
 	-- realises this.
-	-- 
-	-- The structure of	
+	--
+	-- The structure of
 	--	 f a (f b (f c (foldr f z rest)))
 	-- in core becomes:
 	--	let ele_1 = foldr f z rest
@@ -209,42 +196,41 @@ foldr_fun env (TypeArg ty1:TypeArg ty2:ValArg arg_k:ValArg arg_z:ValArg arg_list
 	--	in f a ele_3
 	--
   tick Foldr_List	`thenSmpl_`
-  newIds ( 
-		ty1 `mkFunTy` (ty2 `mkFunTy` ty2) :
+  newIds (
+		mkFunTys [ty1, ty2] ty2 :
 		take (length the_list) (repeat ty2)
 	)			`thenSmpl` \ (f_id:ele_id1:ele_ids) ->
   let
-	fst_bind = CoNonRec 
-			ele_id1 
-			(applyToArgs (CoVar foldrId) 
+	fst_bind = NonRec
+			ele_id1
+			(mkGenApp (Var foldrId)
 				[TypeArg ty1,TypeArg ty2,
-				 ValArg (CoVarAtom f_id),
+				 ValArg (VarArg f_id),
 				 ValArg arg_z,
 				 ValArg the_tl])
-	--ToDo: look for a zipWith that checks for the same length of a 3 lists
-	rest_binds = zipWith3 
-			 (\ e v e' -> CoNonRec e (mkRhs v e'))
+	rest_binds = zipWith3Equal
+			 (\ e v e' -> NonRec e (mkRhs v e'))
 			 ele_ids
 			 (reverse (tail the_list))
 			 (init (ele_id1:ele_ids))
-	mkRhs v e = CoApp (CoApp (CoVar f_id) v) (CoVarAtom e)
+	mkRhs v e = App (App (Var f_id) v) (VarArg e)
 	core_list = foldr
-			CoLet 
+			Let
 			(mkRhs (head the_list) (last (ele_id1:ele_ids)))
 			(fst_bind:rest_binds)
   in
- 	returnSmpl (Just (applyToArgs (CoLam [f_id] core_list)
+ 	returnSmpl (Just (mkGenApp (Lam f_id core_list)
 				      (ValArg arg_k:rest_args)))
 
 
-	-- 
+	--
 
  | do_fb_red && arg_list_isStringForm	-- ok, its a string!
 	-- foldr f z "foo" => unpackFoldrPS# f z "foo"#
    = tick Str_FoldrStr				`thenSmpl_`
-     returnSmpl (Just (applyToArgs (CoVar unpackCStringFoldrId)
+     returnSmpl (Just (mkGenApp (Var unpackCStringFoldrId)
 				(TypeArg ty2:
-				 ValArg (CoLitAtom (MachStr str_val)):
+				 ValArg (LitArg (MachStr str_val)):
 				 ValArg arg_k:
 				 ValArg arg_z:
 				 rest_args)))
@@ -274,21 +260,21 @@ foldr_fun env (TypeArg ty1:TypeArg ty2:ValArg arg_k:ValArg arg_z:ValArg arg_list
 
 foldr_fun env (TypeArg ty1:TypeArg ty2:ValArg arg_k:rest_args)
   | doing_inlining && isConsFun env arg_k && not dont_fold_back_append
-  =    -- foldr (:) z xs = xs ++ z              
+  =    -- foldr (:) z xs = xs ++ z
      tick Foldr_Cons	`thenSmpl_`
      newIds [ty2,mkListTy ty1] `thenSmpl` \ [z,x] ->
-     returnSmpl (Just (applyToArgs 
-                        (CoLam [z,x] (applyToArgs 
-                                        (CoVar appendId) [
-                                                TypeArg ty1,
-                                                ValArg (CoVarAtom x),
-                                                ValArg (CoVarAtom z)]))
-                        rest_args))
-  | doing_inlining && (isInterestingArg env arg_k  
+     returnSmpl (Just (mkGenApp
+			(Lam z (Lam x (mkGenApp
+					(Var appendId) [
+						TypeArg ty1,
+						ValArg (VarArg x),
+						ValArg (VarArg z)])))
+			rest_args))
+  | doing_inlining && (isInterestingArg env arg_k
 		       || isConsFun env arg_k)
-  =   -- foldr k args =                         
+  =   -- foldr k args =
       --        (\ f z xs ->
-      --          letrec                                 
+      --          letrec
       --             h x = case x of
       --		    [] -> z
       --          	    (a:b) -> f a (h b)
@@ -297,98 +283,98 @@ foldr_fun env (TypeArg ty1:TypeArg ty2:ValArg arg_k:rest_args)
       --
 --     tick FoldrInline		`thenSmpl_`
      newIds [
-                ty1,                    -- a :: t1
-                mkListTy ty1,           -- b :: [t1]
-                ty2,                    -- v :: t2
-                mkListTy ty1,           -- x :: t1
-                mkListTy ty1 `mkFunTy` ty2,
-                                        -- h :: [t1] -> t2
-                ty1 `mkFunTy` (ty2 `mkFunTy` ty2),
-                                        -- f
-                ty2,                    -- z
-                mkListTy ty1            -- xs
-                        ] `thenSmpl` \ [a,b,v,x,h,f,z,xs] ->
-           let
-             h_rhs = (CoLam [x] (CoCase (CoVar x)
-                      (CoAlgAlts
-                          [(nilDataCon,[],atomToExpr (CoVarAtom z)),
-                           (consDataCon,[a,b],body)]
-                       CoNoDefault)))
-             body = CoLet (CoNonRec v (CoApp (CoVar h) (CoVarAtom b)))
-                          (CoApp (CoApp (atomToExpr (CoVarAtom f))
-                                                  (CoVarAtom a))
-                                                    (CoVarAtom v))
-           in
-             returnSmpl (Just 
-                     (applyToArgs
-                         (CoLam [f,z,xs]
-                          (CoLet (CoRec [(h,h_rhs)]) 
-                                 (CoApp (CoVar h) (CoVarAtom xs))))
-                     (ValArg arg_k:rest_args)))
+		ty1,                    -- a :: t1
+		mkListTy ty1,           -- b :: [t1]
+		ty2,                    -- v :: t2
+		mkListTy ty1,           -- x :: t1
+		mkFunTys [mkListTy ty1] ty2,
+					-- h :: [t1] -> t2
+		mkFunTys [ty1, ty2] ty2,
+					-- f
+		ty2,                    -- z
+		mkListTy ty1            -- xs
+			] `thenSmpl` \ [a,b,v,x,h,f,z,xs] ->
+	   let
+	     h_rhs = (Lam x (Case (Var x)
+		      (AlgAlts
+			  [(nilDataCon,[],argToExpr (VarArg z)),
+			   (consDataCon,[a,b],body)]
+		       NoDefault)))
+	     body = Let (NonRec v (App (Var h) (VarArg b)))
+			  (App (App (argToExpr (VarArg f))
+						  (VarArg a))
+						    (VarArg v))
+	   in
+	     returnSmpl (Just
+		     (mkGenApp
+			 (Lam f (Lam z (Lam xs
+			  (Let (Rec [(h,h_rhs)])
+				 (App (Var h) (VarArg xs))))))
+		     (ValArg arg_k:rest_args)))
    where
-	doing_inlining = switchIsSet env SimplDoInlineFoldrBuild 
-        dont_fold_back_append = switchIsSet env SimplDontFoldBackAppend
+	doing_inlining = switchIsSet env SimplDoInlineFoldrBuild
+	dont_fold_back_append = switchIsSet env SimplDontFoldBackAppend
 foldr_fun _ _ = returnSmpl Nothing
 
-isConsFun :: SimplEnv -> PlainCoreAtom -> Bool
-isConsFun env (CoVarAtom v) = 
+isConsFun :: SimplEnv -> CoreArg -> Bool
+isConsFun env (VarArg v) =
     case lookupUnfolding env v of
-        GeneralForm _ _ (CoLam [(x,_),(y,_)] 
-                        (CoCon con tys [CoVarAtom x',CoVarAtom y'])) _
-                        | con == consDataCon && x==x' && y==y'
-          -> ASSERT ( length tys == 1 ) True
-        _ -> False
+	GenForm _ _ (Lam (x,_) (Lam (y,_)
+			(Con con tys [VarArg x',VarArg y']))) _
+			| con == consDataCon && x==x' && y==y'
+	  -> ASSERT ( length tys == 1 ) True
+	_ -> False
 isConsFun env _ = False
 
-isNilForm :: SimplEnv -> PlainCoreAtom -> Bool
-isNilForm env (CoVarAtom v) = 
+isNilForm :: SimplEnv -> CoreArg -> Bool
+isNilForm env (VarArg v) =
     case lookupUnfolding env v of
-        GeneralForm _ _ (CoTyApp (CoVar id) _) _
-          | id == nilDataCon -> True
-        ConstructorForm id _ _
-          | id == nilDataCon   -> True
-        LiteralForm (NoRepStr s) | _NULL_ s -> True
-        _ -> False
+	GenForm _ _ (CoTyApp (Var id) _) _
+	  | id == nilDataCon -> True
+	ConForm id _ _
+	  | id == nilDataCon   -> True
+	LitForm (NoRepStr s) | _NULL_ s -> True
+	_ -> False
 isNilForm env _ = False
 
-getBuildForm :: SimplEnv -> PlainCoreAtom -> Maybe Id
-getBuildForm env (CoVarAtom v) = 
+getBuildForm :: SimplEnv -> CoreArg -> Maybe Id
+getBuildForm env (VarArg v) =
     case lookupUnfolding env v of
-        GeneralForm False _ _ _ -> Nothing
+	GenForm False _ _ _ -> Nothing
 					-- not allowed to inline :-(
-        GeneralForm _ _ (CoApp (CoTyApp (CoVar bld) _) (CoVarAtom g)) _
-          | bld == buildId -> Just g
-        GeneralForm _ _ (CoApp (CoApp (CoTyApp (CoVar bld) _)
-					(CoVarAtom g)) h) _
-          | bld == augmentId && isNilForm env h  -> Just g
-        _ -> Nothing
+	GenForm _ _ (App (CoTyApp (Var bld) _) (VarArg g)) _
+	  | bld == buildId -> Just g
+	GenForm _ _ (App (App (CoTyApp (Var bld) _)
+					(VarArg g)) h) _
+	  | bld == augmentId && isNilForm env h  -> Just g
+	_ -> Nothing
 getBuildForm env _ = Nothing
 
 
 
-getAugmentForm :: SimplEnv -> PlainCoreAtom -> Maybe (Id,PlainCoreAtom)
-getAugmentForm env (CoVarAtom v) = 
+getAugmentForm :: SimplEnv -> CoreArg -> Maybe (Id,CoreArg)
+getAugmentForm env (VarArg v) =
     case lookupUnfolding env v of
-        GeneralForm False _ _ _ -> Nothing	
+	GenForm False _ _ _ -> Nothing
 				-- not allowed to inline :-(
-        GeneralForm _ _ (CoApp (CoApp (CoTyApp (CoVar bld) _) 
-						(CoVarAtom g)) h) _
-          | bld == augmentId -> Just (g,h)
-        _ -> Nothing
+	GenForm _ _ (App (App (CoTyApp (Var bld) _)
+						(VarArg g)) h) _
+	  | bld == augmentId -> Just (g,h)
+	_ -> Nothing
 getAugmentForm env _ = Nothing
 
-getStringForm :: SimplEnv -> PlainCoreAtom -> Maybe FAST_STRING
-getStringForm env (CoLitAtom (NoRepStr str)) = Just str
+getStringForm :: SimplEnv -> CoreArg -> Maybe FAST_STRING
+getStringForm env (LitArg (NoRepStr str)) = Just str
 getStringForm env _ = Nothing
 
 {-
-getAppendForm :: SimplEnv -> PlainCoreAtom -> Maybe (CoreAtom Id,CoreAtom Id)
-getAppendForm env (CoVarAtom v) = 
+getAppendForm :: SimplEnv -> CoreArg -> Maybe (GenCoreAtom Id,GenCoreAtom Id)
+getAppendForm env (VarArg v) =
     case lookupUnfolding env v of
-        GeneralForm False _ _ _ -> Nothing	-- not allowed to inline :-(
-        GeneralForm _ _ (CoApp (CoApp (CoApp (CoTyApp (CoTyApp (CoVar fld) _) _) con) ys) xs) _
-          | fld == foldrId && isConsFun env con -> Just (xs,ys)
-        _ -> Nothing
+	GenForm False _ _ _ -> Nothing	-- not allowed to inline :-(
+	GenForm _ _ (App (App (App (CoTyApp (CoTyApp (Var fld) _) _) con) ys) xs) _
+	  | fld == foldrId && isConsFun env con -> Just (xs,ys)
+	_ -> Nothing
 getAppendForm env _ = Nothing
 -}
 
@@ -398,24 +384,24 @@ getAppendForm env _ = Nothing
 --
 
 getListForm
-	:: SimplEnv 
-	-> PlainCoreAtom 
-	-> Maybe ([PlainCoreAtom],PlainCoreAtom)
-getListForm env (CoVarAtom v) = 
+	:: SimplEnv
+	-> CoreArg
+	-> Maybe ([CoreArg],CoreArg)
+getListForm env (VarArg v) =
     case lookupUnfolding env v of
-       ConstructorForm id _ [head,tail]
-          | id == consDataCon -> 
+       ConForm id _ [head,tail]
+	  | id == consDataCon ->
 		case getListForm env tail of
  		   Nothing -> Just ([head],tail)
 		   Just (lst,new_tail) -> Just (head:lst,new_tail)
        _ -> Nothing
 getListForm env _ = Nothing
 
-isInterestingArg :: SimplEnv -> PlainCoreAtom -> Bool
-isInterestingArg env (CoVarAtom v) = 
+isInterestingArg :: SimplEnv -> CoreArg -> Bool
+isInterestingArg env (VarArg v) =
     case lookupUnfolding env v of
-       GeneralForm False _ _ UnfoldNever -> False
-       GeneralForm _ _ exp guide -> True
+       GenForm False _ _ UnfoldNever -> False
+       GenForm _ _ exp guide -> True
        _ -> False
 isInterestingArg env _ = False
 
@@ -424,11 +410,11 @@ foldl_fun env (TypeArg ty1:TypeArg ty2:ValArg arg_k:ValArg arg_z:ValArg arg_list
   =     -- foldl f z [] = z
 	-- again another short cut, helps with unroling of constant lists
     tick Foldl_Nil	`thenSmpl_`
-    returnSmpl (Just (atomToExpr arg_z))
+    returnSmpl (Just (argToExpr arg_z))
 
-  | do_fb_red && arg_list_isBuildForm 
-  =     -- foldl t1 t2 k z (build t3 g) ==> 
-	--		   let c {- INLINE -} = \ b g' a -> g' (f a b) 
+  | do_fb_red && arg_list_isBuildForm
+  =     -- foldl t1 t2 k z (build t3 g) ==>
+	--		   let c {- INLINE -} = \ b g' a -> g' (f a b)
 	--		       n {- INLINE -} = \ a -> a
 	--		   in g t1 c n z
 	-- this next line *is* the foldr/build rule proper.
@@ -436,12 +422,12 @@ foldl_fun env (TypeArg ty1:TypeArg ty2:ValArg arg_k:ValArg arg_z:ValArg arg_list
 	-- c :: t2 -> (t1 -> t1) -> t1 -> t1
 	-- n :: t1 -> t1
     newIds [
-	{- pre_c -}	ty2 `mkFunTy` ((ty1 `mkFunTy` ty1) `mkFunTy` (ty1 `mkFunTy` ty1)),
-	{- pre_n -}	ty1 `mkFunTy` ty1,
+	{- pre_c -}	mkFunTys [ty2, mkFunTys [ty1] ty1, ty1]  ty1,
+	{- pre_n -}	mkFunTys [ty1] ty1,
 	{- b -}		ty2,
-	{- g' -}	ty1 `mkFunTy` ty1, 
+	{- g' -}	mkFunTys [ty1] ty1,
 	{- a -}		ty1,
-	{- a' -}	ty1,	
+	{- a' -}	ty1,
 	{- t -}		ty1
 	]		`thenSmpl` \ [pre_c,
 				      pre_n,
@@ -453,20 +439,20 @@ foldl_fun env (TypeArg ty1:TypeArg ty2:ValArg arg_k:ValArg arg_z:ValArg arg_list
 
     let
 	c     = addIdUnfolding pre_c (iWantToBeINLINEd UnfoldAlways)
-	c_rhs = CoLam [b,g',a]
-	         (CoLet (CoNonRec t (CoApp (CoApp (atomToExpr arg_k) (CoVarAtom a)) (CoVarAtom b)))
-		         (CoApp (CoVar g') (CoVarAtom t)))
-	n     = addIdUnfolding pre_n (iWantToBeINLINEd UnfoldAlways) 
-	n_rhs = CoLam [a'] (CoVar a')
+	c_rhs = Lam b (Lam g' (Lam a
+		 (Let (NonRec t (App (App (argToExpr arg_k) (VarArg a)) (VarArg b)))
+			 (App (Var g') (VarArg t)))))
+	n     = addIdUnfolding pre_n (iWantToBeINLINEd UnfoldAlways)
+	n_rhs = Lam a' (Var a')
     in
-    returnSmpl (Just (CoLet (CoNonRec c c_rhs) (CoLet (CoNonRec n n_rhs) 
-		  (applyToArgs (CoVar g) 
-		      (TypeArg (ty1 `mkFunTy` ty1):ValArg (CoVarAtom c):ValArg (CoVarAtom n)
+    returnSmpl (Just (Let (NonRec c c_rhs) (Let (NonRec n n_rhs)
+		  (mkGenApp (Var g)
+		      (TypeArg (mkFunTys [ty1] ty1):ValArg (VarArg c):ValArg (VarArg n)
 				:ValArg arg_z:rest_args)))))
 
-  | do_fb_red && arg_list_isAugmentForm 
-  =     -- foldl t1 t2 k z (augment t3 g h) ==> 
-	--		   let c {- INLINE -} = \ b g' a -> g' (f a b) 
+  | do_fb_red && arg_list_isAugmentForm
+  =     -- foldl t1 t2 k z (augment t3 g h) ==>
+	--		   let c {- INLINE -} = \ b g' a -> g' (f a b)
 	--		       n {- INLINE -} = \ a -> a
 	--		       r {- INLINE -} = foldr t2 (t1 -> t1) c n h
 	--		   in g t1 c r z
@@ -475,13 +461,13 @@ foldl_fun env (TypeArg ty1:TypeArg ty2:ValArg arg_k:ValArg arg_z:ValArg arg_list
 	-- c :: t2 -> (t1 -> t1) -> t1 -> t1
 	-- n :: t1 -> t1
     newIds [
-	{- pre_c -}	ty2 `mkFunTy` ((ty1 `mkFunTy` ty1) `mkFunTy` (ty1 `mkFunTy` ty1)),
-	{- pre_n -}	ty1 `mkFunTy` ty1,
-	{- pre_r -}	ty1 `mkFunTy` ty1, 
+	{- pre_c -}	mkFunTys [ty2, mkFunTys [ty1] ty1, ty1] ty1,
+	{- pre_n -}	mkFunTys [ty1] ty1,
+	{- pre_r -}	mkFunTys [ty1] ty1,
 	{- b -}		ty2,
-	{- g_ -}	ty1 `mkFunTy` ty1, 
+	{- g_ -}	mkFunTys [ty1] ty1,
 	{- a -}		ty1,
-	{- a' -}	ty1,	
+	{- a' -}	ty1,
 	{- t -}		ty1
 	]		`thenSmpl` \ [pre_c,
 				      pre_n,
@@ -494,34 +480,34 @@ foldl_fun env (TypeArg ty1:TypeArg ty2:ValArg arg_k:ValArg arg_z:ValArg arg_list
 
     let
 	c     = addIdUnfolding pre_c (iWantToBeINLINEd UnfoldAlways)
-	c_rhs = CoLam [b,g_,a]
-	         (CoLet (CoNonRec t (CoApp (CoApp (atomToExpr arg_k) (CoVarAtom a)) (CoVarAtom b)))
-		         (CoApp (CoVar g_) (CoVarAtom t)))
-	n     = addIdUnfolding pre_n (iWantToBeINLINEd UnfoldAlways) 
-	n_rhs = CoLam [a'] (CoVar a')
-	r     = addIdUnfolding pre_r (iWantToBeINLINEd UnfoldAlways) 
-	r_rhs = applyToArgs (CoVar foldrId)
-					[TypeArg ty2,TypeArg (ty1 `mkFunTy` ty1),
-					 ValArg (CoVarAtom c),
-					 ValArg (CoVarAtom n),
+	c_rhs = Lam b (Lam g_ (Lam a
+		 (Let (NonRec t (App (App (argToExpr arg_k) (VarArg a)) (VarArg b)))
+			 (App (Var g_) (VarArg t)))))
+	n     = addIdUnfolding pre_n (iWantToBeINLINEd UnfoldAlways)
+	n_rhs = Lam a' (Var a')
+	r     = addIdUnfolding pre_r (iWantToBeINLINEd UnfoldAlways)
+	r_rhs = mkGenApp (Var foldrId)
+					[TypeArg ty2,TypeArg (mkFunTys [ty1] ty1),
+					 ValArg (VarArg c),
+					 ValArg (VarArg n),
 					 ValArg h]
     in
-    returnSmpl (Just (CoLet (CoNonRec c c_rhs) 
-		     (CoLet (CoNonRec n n_rhs) 
-		     (CoLet (CoNonRec r r_rhs) 
-		  (applyToArgs (CoVar g') 
-		      (TypeArg (ty1 `mkFunTy` ty1):ValArg (CoVarAtom c):ValArg (CoVarAtom r)
+    returnSmpl (Just (Let (NonRec c c_rhs)
+		     (Let (NonRec n n_rhs)
+		     (Let (NonRec r r_rhs)
+		  (mkGenApp (Var g')
+		      (TypeArg (mkFunTys [ty1] ty1):ValArg (VarArg c):ValArg (VarArg r)
 				:ValArg arg_z:rest_args))))))
 
  | do_fb_red && arg_list_isListForm
- =      -- foldl k z (a:b:c:rest) = 
+ =      -- foldl k z (a:b:c:rest) =
 	--	(\ f -> foldl f (f (f (f z a) b) c) rest) k rest_args
 	-- NB: 'k' is used just one by foldr, but 'f' is used many
 	-- times inside the list structure. This means that
 	-- 'f' needs to be inside a lambda, to make sure the simplifier
 	-- realises this.
-	-- 
-	-- The structure of	
+	--
+	-- The structure of
 	-- 	 foldl f (f (f (f z a) b) c) rest
 	--	 f a (f b (f c (foldr f z rest)))
 	-- in core becomes:
@@ -531,30 +517,29 @@ foldl_fun env (TypeArg ty1:TypeArg ty2:ValArg arg_k:ValArg arg_z:ValArg arg_list
 	--	in foldl f ele_3 rest
 	--
   tick Foldl_List	`thenSmpl_`
-  newIds ( 
-		ty1 `mkFunTy` (ty2 `mkFunTy` ty1) :
+  newIds (
+		mkFunTys [ty1, ty2] ty1 :
 		take (length the_list) (repeat ty1)
 	)			`thenSmpl` \ (f_id:ele_ids) ->
   let
-	--ToDo: look for a zipWith that checks for the same length of a 3 lists
-	rest_binds = zipWith3 
-			 (\ e v e' -> CoNonRec e (mkRhs v e'))
+	rest_binds = zipWith3Equal
+			 (\ e v e' -> NonRec e (mkRhs v e'))
 			 ele_ids				-- :: [Id]
-			 the_list				-- :: [PlainCoreAtom]
-			 (init (arg_z:map CoVarAtom ele_ids))	-- :: [PlainCoreAtom]
-	mkRhs v e = CoApp (CoApp (CoVar f_id) e) v
+			 the_list				-- :: [CoreArg]
+			 (init (arg_z:map VarArg ele_ids))	-- :: [CoreArg]
+	mkRhs v e = App (App (Var f_id) e) v
 
-	last_bind = applyToArgs (CoVar foldlId) 
+	last_bind = mkGenApp (Var foldlId)
 				[TypeArg ty1,TypeArg ty2,
-				 ValArg (CoVarAtom f_id),
-				 ValArg (CoVarAtom (last ele_ids)),
+				 ValArg (VarArg f_id),
+				 ValArg (VarArg (last ele_ids)),
 				 ValArg the_tl]
 	core_list = foldr
-			CoLet 
+			Let
 			last_bind
 			rest_binds
   in
- 	returnSmpl (Just (applyToArgs (CoLam [f_id] core_list)
+ 	returnSmpl (Just (mkGenApp (Lam f_id core_list)
 				      (ValArg arg_k:rest_args)))
 
  where
@@ -579,11 +564,11 @@ foldl_fun env (TypeArg ty1:TypeArg ty2:ValArg arg_k:ValArg arg_z:ValArg arg_list
 -}
 
 foldl_fun env (TypeArg ty1:TypeArg ty2:ValArg arg_k:rest_args)
-  | doing_inlining && (isInterestingArg env arg_k  
+  | doing_inlining && (isInterestingArg env arg_k
 		       || isConsFun env arg_k)
-  =   -- foldl k args =                         
+  =   -- foldl k args =
       --        (\ f z xs ->
-      --          letrec                                 
+      --          letrec
       --             h x r = case x of
       --		      []    -> r
       --          	      (a:b) -> h b (f r a)
@@ -592,39 +577,39 @@ foldl_fun env (TypeArg ty1:TypeArg ty2:ValArg arg_k:rest_args)
       --
 --     tick FoldrInline				`thenSmpl_`
      newIds [
-                ty2,                    -- a :: t1
-                mkListTy ty2,           -- b :: [t1]
-                ty1,                    -- v :: t2
-                mkListTy ty2,           -- x :: t1
-                mkListTy ty2 `mkFunTy` (ty1 `mkFunTy` ty1),
-                                        -- h :: [t2] -> t1 -> t1
-                ty1 `mkFunTy` (ty2 `mkFunTy` ty1),
-                                        -- f
-                ty1,                    -- z
-                mkListTy ty2,           -- xs
+		ty2,                    -- a :: t1
+		mkListTy ty2,           -- b :: [t1]
+		ty1,                    -- v :: t2
+		mkListTy ty2,           -- x :: t1
+		mkFunTys [mkListTy ty2, ty1] ty1,
+					-- h :: [t2] -> t1 -> t1
+		mkFunTys [ty1, ty2] ty1,
+					-- f
+		ty1,                    -- z
+		mkListTy ty2,           -- xs
 		ty1			-- r
-                        ] `thenSmpl` \ [a,b,v,x,h,f,z,xs,r] ->
-           let
-             h_rhs = (CoLam [x,r] (CoCase (CoVar x)
-                      (CoAlgAlts
-                          [(nilDataCon,[],atomToExpr (CoVarAtom r)),
-                           (consDataCon,[a,b],body)]
-                       CoNoDefault)))
-             body = CoLet (CoNonRec v (CoApp (CoApp (CoVar f) (CoVarAtom r))
-							      (CoVarAtom a)))
-                          (CoApp (CoApp (atomToExpr (CoVarAtom h))
-                                                  (CoVarAtom b))
-                                                    (CoVarAtom v))
-           in
-             returnSmpl (Just 
-                     (applyToArgs
-                         (CoLam [f,z,xs]
-                          (CoLet (CoRec [(h,h_rhs)]) 
-                                 (CoApp (CoApp (CoVar h) (CoVarAtom xs)) 
-							 (CoVarAtom z))))
-                     (ValArg arg_k:rest_args)))
+			] `thenSmpl` \ [a,b,v,x,h,f,z,xs,r] ->
+	   let
+	     h_rhs = (Lam x (Lam r (Case (Var x))
+		      (AlgAlts
+			  [(nilDataCon,[],argToExpr (VarArg r)),
+			   (consDataCon,[a,b],body)]
+		       NoDefault)))
+	     body = Let (NonRec v (App (App (Var f) (VarArg r))
+							      (VarArg a)))
+			  (App (App (argToExpr (VarArg h))
+						  (VarArg b))
+						    (VarArg v))
+	   in
+	     returnSmpl (Just
+		     (mkGenApp
+			 (Lam f (Lam z (Lam xs
+			  (Let (Rec [(h,h_rhs)])
+				 (App (App (Var h) (VarArg xs))
+							 (VarArg z))))))
+		     (ValArg arg_k:rest_args)))
    where
-	doing_inlining = switchIsSet env SimplDoInlineFoldrBuild 
+	doing_inlining = switchIsSet env SimplDoInlineFoldrBuild
 
 foldl_fun env _ = returnSmpl Nothing
 \end{code}
@@ -632,20 +617,21 @@ foldl_fun env _ = returnSmpl Nothing
 
 \begin{code}
 --
---  Foldr unpackFoldr "str"# (:) stuff ==> unpackAppend "str"# 
+--  Foldr unpackFoldr "str"# (:) stuff ==> unpackAppend "str"#
 --
 unpack_foldr_fun env [TypeArg ty,ValArg str,ValArg arg_k,ValArg arg_z]
    | switchIsSet env SimplDoFoldrBuild && isConsFun env arg_k
    = tick Str_UnpackCons		`thenSmpl_`
-     returnSmpl (Just (applyToArgs (CoVar unpackCStringAppendId)
+     returnSmpl (Just (mkGenApp (Var unpackCStringAppendId)
 				[ValArg str,
 				 ValArg arg_z]))
 unpack_foldr_fun env _ = returnSmpl Nothing
 
-unpack_append_fun env 
-	[ValArg (CoLitAtom (MachStr str_val)),ValArg arg_z]
+unpack_append_fun env
+	[ValArg (LitArg (MachStr str_val)),ValArg arg_z]
    | switchIsSet env SimplDoFoldrBuild && isNilForm env arg_z
    = tick Str_UnpackNil		`thenSmpl_`
-     returnSmpl (Just (CoLit (NoRepStr str_val)))
+     returnSmpl (Just (Lit (NoRepStr str_val)))
 unpack_append_fun env _ = returnSmpl Nothing
+-}
 \end{code}
diff --git a/ghc/compiler/simplCore/NewOccurAnal.hi b/ghc/compiler/simplCore/NewOccurAnal.hi
deleted file mode 100644
index 0589783e6e..0000000000
--- a/ghc/compiler/simplCore/NewOccurAnal.hi
+++ /dev/null
@@ -1,26 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface NewOccurAnal where
-import BasicLit(BasicLit)
-import BinderInfo(BinderInfo, DuplicationDanger, FunOrArg, InsideSCC)
-import CmdLineOpts(GlobalSwitch, SimplifierSwitch)
-import CoreSyn(CoreAtom, CoreBinding, CoreCaseAlternatives, CoreExpr)
-import CostCentre(CostCentre)
-import Id(Id)
-import PlainCore(PlainCoreExpr(..), PlainCoreProgram(..))
-import PrimOps(PrimOp)
-import TaggedCore(SimplifiableCoreBinding(..), SimplifiableCoreExpr(..))
-import TyVar(TyVar)
-import UniType(UniType)
-import UniqFM(UniqFM)
-data BinderInfo 
-data GlobalSwitch 
-data CoreBinding a b 
-data CoreExpr a b 
-data Id 
-type PlainCoreExpr = CoreExpr Id Id
-type PlainCoreProgram = [CoreBinding Id Id]
-type SimplifiableCoreBinding = CoreBinding (Id, BinderInfo) Id
-type SimplifiableCoreExpr = CoreExpr (Id, BinderInfo) Id
-newOccurAnalyseBinds :: [CoreBinding Id Id] -> (GlobalSwitch -> Bool) -> (SimplifierSwitch -> Bool) -> [CoreBinding (Id, BinderInfo) Id]
-newOccurAnalyseExpr :: UniqFM Id -> CoreExpr Id Id -> (UniqFM BinderInfo, CoreExpr (Id, BinderInfo) Id)
-
diff --git a/ghc/compiler/simplCore/NewOccurAnal.lhs b/ghc/compiler/simplCore/NewOccurAnal.lhs
deleted file mode 100644
index 443b739749..0000000000
--- a/ghc/compiler/simplCore/NewOccurAnal.lhs
+++ /dev/null
@@ -1,721 +0,0 @@
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
-%
-%************************************************************************
-%*									*
-\section[NewOccurAnal]{The *New* Occurrence analysis pass}
-%*									*
-%************************************************************************
-
-The occurrence analyser analyses the way in which variables are used
-in their scope, and pins that information on the binder.  It does {\em
-not} take any strategic decisions about what to do as a result (eg
-discard binding, inline binding etc).  That's the job of the
-simplifier.
-
-The occurrence analyser {\em simply} records usage information.  That is,
-it pins on each binder info on how that binder occurs in its scope.
-
-Any uses within the RHS of a let(rec) binding for a variable which is
-itself unused are ignored.  For example:
-@
-	let x = ...
- 	    y = ...x...
-	in
-	x+1
-@
-Here, y is unused, so x will be marked as appearing just once.
-
-An exported Id gets tagged as ManyOcc.
-
-IT MUST OBSERVE SCOPING: CANNOT assume unique binders.
-
-Lambdas
-~~~~~~~
-The occurrence analyser marks each binder in a lambda the same way.
-Thus:
-	\ x y -> f y x
-will have both x and y marked as single occurrence, and *not* dangerous-to-dup.
-Technically, x occurs inside a lambda, and therefore *is* dangerous-to-dup,
-but the simplifer very carefully takes care of this special case.
-(See the CoLam case in simplExpr.)
-
-Why?  Because typically applications are saturated, in which case x is *not*
-dangerous-to-dup.
-
-Things to muse upon
-~~~~~~~~~~~~~~~~~~~
-
-There *is* a reason not to substitute for
-variables applied to types: it can undo the effect of floating
-Consider:
-\begin{verbatim}
-	c = /\a -> e
-	f = /\b -> let d = c b
-		   in \ x::b -> ...
-\end{verbatim}
-Here, inlining c would be a Bad Idea.
-
-At present I've set it up so that the "inside-lambda" flag sets set On
-for type-lambdas too, which effectively prevents such substitutions.
-I don't *think* it disables any interesting ones either.
-
-Oh yes it does.
-Consider
-
- 	 let { (u6.sAMi, <1,0>) = (_build s141374) ua.sALY } in
-	 let {
-	   (ua.sAMj, <1,0>) =
-	       /\ s141380 -> \ (u5.sAM1, <2,0>)  (u6.sAMl, <2,0>) ->
-		   let {
-		     (u9.sAM7, <2,0>) =
-			 \ (u7.sAM2, <3,0>) ->
-			     let { (u8.sAM3, <3,0>) = f.sALV u7.sAM2
-			     } in  u5.sAM1 u8.sAM3
-		   } in  ((foldr s141374) s141380) u9.sAM7 u6.sAMl u6.sAMi
-	 } in  (_build s141376) ua.sAMj]
-
-I want to `inline' u6.sAMi, via the foldr/build rule,
-but I cant. So I need to inline through /\. I only do it when
-I've got a `linear' stack, ie actually real arguments still to apply.
-
-\begin{code}
-#include "HsVersions.h"
-
-module NewOccurAnal (
-	newOccurAnalyseBinds, newOccurAnalyseExpr,
-
-	-- and to make the interface self-sufficient...
-	CoreExpr, CoreBinding, Id, BinderInfo, GlobalSwitch,
-	PlainCoreProgram(..), PlainCoreExpr(..),
-	SimplifiableCoreExpr(..), SimplifiableCoreBinding(..)
-    ) where
-
-IMPORT_Trace
-import Outputable	-- ToDo: rm; debugging
-import Pretty
-
-import PlainCore	-- the stuff we read...
-import TaggedCore	-- ... and produce Simplifiable*
-
-import AbsUniType
-import BinderInfo
-import CmdLineOpts	( GlobalSwitch(..), SimplifierSwitch(..) )
-import Digraph		( stronglyConnComp )
-import Id		( eqId, idWantsToBeINLINEd, isConstMethodId_maybe,
-			  isSpecPragmaId_maybe, getIdArgUsageInfo,
-			  SpecInfo
-			)
-import IdInfo		-- ( ArgUsage(..), ArgUsageInfo, OptIdInfo(..), getArgUsage)
-import IdEnv
-import Maybes
-import UniqSet
-import Util
-\end{code}
-
-
-%************************************************************************
-%*									*
-\subsection[OccurAnal-types]{Data types}
-%*									*
-%************************************************************************
-
-\begin{code}
-data OccEnv = OccEnv
-		Bool		-- Keep-unused-bindings flag
-				-- False <=> OK to chuck away binding
-				-- 	     and ignore occurrences within it
-		Bool		-- Keep-spec-pragma-ids flag
-				-- False <=> OK to chuck away spec pragma bindings
-				-- 	     and ignore occurrences within it
-		Bool		-- Keep-conjurable flag
-				-- False <=> OK to throw away *dead*
-				-- "conjurable" Ids; at the moment, that
-				-- *only* means constant methods, which
-				-- are top-level.  A use of a "conjurable"
-				-- Id may appear out of thin air -- e.g.,
-				-- specialiser conjuring up refs to const
-				-- methods.
-		Bool		-- IgnoreINLINEPragma flag
-				-- False <=> OK to use INLINEPragma information
-				-- True  <=> ignore INLINEPragma information
-		(UniqSet Id)	-- Candidates
-
-addNewCands :: OccEnv -> [Id] -> OccEnv
-addNewCands (OccEnv keep_dead keep_spec keep_conjurable ignore_inline_pragma cands) ids
-  = OccEnv keep_dead keep_spec keep_conjurable ignore_inline_pragma (cands `unionUniqSets` mkUniqSet ids)
-
-addNewCand :: OccEnv -> Id -> OccEnv
-addNewCand (OccEnv keep_dead keep_spec keep_conjurable ignore_inline_pragma cands) id
-  = OccEnv keep_dead keep_spec keep_conjurable ignore_inline_pragma (cands `unionUniqSets` singletonUniqSet id)
-
-isCandidate :: OccEnv -> Id -> Bool
-isCandidate (OccEnv _ _ _ _ cands) id = id `elementOfUniqSet` cands
-
-ignoreINLINEPragma :: OccEnv -> Bool
-ignoreINLINEPragma (OccEnv _ _ _ ignore_inline_pragma _) = ignore_inline_pragma
-
-keepUnusedBinding :: OccEnv -> Id -> Bool
-keepUnusedBinding (OccEnv keep_dead keep_spec keep_conjurable _ _) binder
-  = keep_dead || (keep_spec && is_spec)
-  where
-    is_spec = maybeToBool (isSpecPragmaId_maybe binder)
-
-keepBecauseConjurable :: OccEnv -> Id -> Bool
-keepBecauseConjurable (OccEnv _ _ keep_conjurable _ _) binder
-  = keep_conjurable && is_conjurable
-  where
-    is_conjurable = maybeToBool (isConstMethodId_maybe binder)
-
-type UsageDetails = IdEnv BinderInfo	-- A finite map from ids to their usage
-
-combineUsageDetails, combineAltsUsageDetails
-	:: UsageDetails -> UsageDetails -> UsageDetails
-
-combineUsageDetails usage1 usage2
-  = --BSCC("combineUsages")
-    combineIdEnvs combineBinderInfo usage1 usage2
-    --ESCC
-
-combineAltsUsageDetails usage1 usage2
-  = --BSCC("combineUsages")
-    combineIdEnvs combineAltsBinderInfo usage1 usage2
-    --ESCC
-
-addOneOcc :: UsageDetails -> Id -> BinderInfo -> UsageDetails
-addOneOcc usage id info = combineIdEnvs combineBinderInfo usage (unitIdEnv id info)
-	-- ToDo: make this more efficient
-
-emptyDetails = (nullIdEnv :: UsageDetails)
-
-unitDetails id info = (unitIdEnv id info :: UsageDetails)
-
-tagBinders :: UsageDetails 		-- Of scope
-	   -> [Id]			-- Binders
-	   -> (UsageDetails, 		-- Details with binders removed
-	      [(Id,BinderInfo)])	-- Tagged binders
-
-tagBinders usage binders
-  = (usage `delManyFromIdEnv` binders,
-     [(binder, usage_of usage binder) | binder <- binders]
-    )
-
-tagBinder :: UsageDetails 		-- Of scope
-	  -> Id				-- Binders
-	  -> (UsageDetails, 		-- Details with binders removed
-	      (Id,BinderInfo))		-- Tagged binders
-
-tagBinder usage binder
-  = (usage `delOneFromIdEnv` binder,
-     (binder, usage_of usage binder)
-    )
-
-usage_of usage binder
-  | isExported binder = ManyOcc	0 -- Exported things count as many
-  | otherwise
-  = case lookupIdEnv usage binder of
-      Nothing   -> DeadCode
-      Just info -> info
-
-fixStkToZero :: Id -> UsageDetails -> UsageDetails
-fixStkToZero id env = modifyIdEnv env setBinderInfoArityToZero id
-
-isNeeded env usage binder
-  = case usage_of usage binder of	
-      DeadCode  -> keepUnusedBinding env binder	-- Maybe keep it anyway
-      other     -> True
-\end{code}
-
-
-%************************************************************************
-%*									*
-\subsection[OccurAnal-main]{Counting occurrences: main function}
-%*									*
-%************************************************************************
-
-Here's the externally-callable interface:
-
-\begin{code}
-newOccurAnalyseBinds
-	:: [PlainCoreBinding]		-- input
-	-> (GlobalSwitch -> Bool)
-	-> (SimplifierSwitch -> Bool)
-	-> [SimplifiableCoreBinding]	-- output
-
-newOccurAnalyseBinds binds global_sw_chkr simplifier_sw_chkr
-  | global_sw_chkr D_dump_occur_anal = pprTrace "OccurAnal:" (ppr PprDebug binds') binds'
-  | otherwise	  		     = binds'
-  where
-    (_, binds') = do initial_env binds
-
-    initial_env = OccEnv (simplifier_sw_chkr KeepUnusedBindings)
-			 (simplifier_sw_chkr KeepSpecPragmaIds)
-			 (not (simplifier_sw_chkr SimplMayDeleteConjurableIds))
-			 (simplifier_sw_chkr IgnoreINLINEPragma)
-			 emptyUniqSet
-
-    do env [] = (emptyDetails, [])
-    do env (bind:binds)
-      = (final_usage, new_binds ++ the_rest)
-      where
-	new_env			 = env `addNewCands` (bindersOf bind)
-	(binds_usage, the_rest)  = do new_env binds
-	(final_usage, new_binds) = --BSCC("occAnalBind1")
-				   occAnalBind env bind binds_usage
-				   --ESCC
-\end{code}
-
-\begin{code}
-newOccurAnalyseExpr :: UniqSet Id 			-- Set of interesting free vars
-		 -> PlainCoreExpr 
-		 -> (IdEnv BinderInfo,		-- Occ info for interesting free vars
-		     SimplifiableCoreExpr)
-
-newOccurAnalyseExpr candidates expr
-  = occAnal initial_env initContext expr
-  where
-    initial_env = OccEnv False {- Drop unused bindings -}
-			 False {- Drop SpecPragmaId bindings -}
-			 True  {- Keep conjurable Ids -}
-			 False {- Do not ignore INLINE Pragma -}
-			 candidates
-
-newOccurAnalyseGlobalExpr :: PlainCoreExpr -> SimplifiableCoreExpr
-newOccurAnalyseGlobalExpr expr
-  = 	-- Top level expr, so no interesting free vars, and 
-	-- discard occurence info returned
-    expr' where (_, expr') = newOccurAnalyseExpr emptyUniqSet expr
-\end{code}
-
-%************************************************************************
-%*									*
-\subsection[OccurAnal-main]{Counting occurrences: main function}
-%*									*
-%************************************************************************
-
-Bindings
-~~~~~~~~
-
-\begin{code}
-occAnalBind :: OccEnv
-	    -> PlainCoreBinding
-	    -> UsageDetails		-- Usage details of scope
-	    -> (UsageDetails,		-- Of the whole let(rec)
-		[SimplifiableCoreBinding])
-
-occAnalBind env (CoNonRec binder rhs) body_usage
-  | isNeeded env body_usage binder		-- It's mentioned in body
-  = (final_body_usage `combineUsageDetails` rhs_usage,
-     [CoNonRec tagged_binder rhs'])
-
-  | otherwise
-  = (body_usage, [])
-
-  where
-    stk = mkContextFromBinderInfo (usage_of body_usage binder)
-    (rhs_usage, rhs')		      = occAnalRhs env binder stk rhs
-    (final_body_usage, tagged_binder) = tagBinder body_usage binder
-
-occAnalBind env (CoRec [(binder,rhs)]) body_usage
-  | getContextSize after_stk < getContextSize stk && mentions_itself
-				-- our pre-condition does not hold!
-				-- so, we have to go back, and
-				-- *make* of pre-condition hold.
-	-- Will, you can leave out this trace
-  = {-pprTrace ("after_stk < stk (BAD, BAD, VERY VERY BAD):" 
-	++ show (getContextSize after_stk,getContextSize stk)) (ppr PprDebug binder) -}
-    (occAnalBind env (CoRec [(binder,rhs)]) (fixStkToZero binder body_usage))
-
-  | isNeeded env body_usage binder		-- It's mentioned in body
-  = --BSCC("occAnalBindC")
-    (final_usage, [final_bind])
-    --ESCC
-
-  | otherwise
-  = --BSCC("occAnalBindD")
-    (body_usage, [])
-    --ESCC
-
-  where
-    stk = shareContext (mkContextFromBinderInfo (usage_of body_usage binder))
-    new_env			 = env `addNewCand` binder
-    (rhs_usage, rhs') 	  	 = occAnalRhs new_env binder stk rhs
-    total_usage 		 = combineUsageDetails body_usage rhs_usage
-    (final_usage, tagged_binder) = tagBinder total_usage binder
-
-    after_stk = mkContextFromBinderInfo (usage_of rhs_usage binder)
-
-    final_bind = if mentions_itself
-		 then CoRec    [(tagged_binder,rhs')]
-		 else CoNonRec tagged_binder rhs'
-
-    mentions_itself = maybeToBool (lookupIdEnv rhs_usage binder)
-\end{code}
-
-Dropping dead code for recursive bindings is done in a very simple way:
-
-	the entire set of bindings is dropped if none of its binders are
-	mentioned in its body; otherwise none are.
-
-This seems to miss an obvious improvement.
-@
-	letrec  f = ...g...	
-	        g = ...f...
-	in	
-	...g...
-
-===>
-
-	letrec f = ...g...
-	       g = ...(...g...)...
-	in
-	...g...
-@
-
-Now @f@ is unused. But dependency analysis will sort this out into a
-@letrec@ for @g@ and a @let@ for @f@, and then @f@ will get dropped.
-It isn't easy to do a perfect job in one blow.  Consider
-
-@
-	letrec f = ...g...
-	       g = ...h...
-	       h = ...k...
-	       k = ...m...
-	       m = ...m...
-	in
-	...m...
-@
-
-
-\begin{code}
-occAnalBind env (CoRec pairs) body_usage
-  = foldr do_final_bind (body_usage, []) sccs
-  where
-
-    (binders, rhss) = unzip pairs
-    new_env	    = env `addNewCands` binders
-
-    analysed_pairs :: [(Id, (UsageDetails, SimplifiableCoreExpr))]
-    analysed_pairs  = [(id, occAnalRhs new_env id initContext rhs) | (id,rhs) <- pairs]
-    
-    lookup :: Id -> (UsageDetails, SimplifiableCoreExpr)
-    lookup id =  assoc "occAnalBind:lookup" analysed_pairs id
-
-
-    ---- stuff for dependency analysis of binds -------------------------------
-
-    edges :: [(Id,Id)]		-- (a,b) means a mentions b
-    edges = concat [ edges_from binder rhs_usage 
-		   | (binder, (rhs_usage, _)) <- analysed_pairs]
-
-    edges_from :: Id -> UsageDetails -> [(Id,Id)]
-    edges_from id its_rhs_usage
-      = [(id,mentioned) | mentioned <- binders,
-		 	  maybeToBool (lookupIdEnv its_rhs_usage mentioned)
-	]
-
-    sccs :: [[Id]]
-    sccs = case binders of
-		[_]   -> [binders]	-- Singleton; no need to analyse
-		other -> stronglyConnComp eqId edges binders
-
-    ---- stuff to "re-constitute" bindings from dependency-analysis info ------
-
-    do_final_bind sCC@[binder] (body_usage, binds_so_far)
-      | isNeeded env body_usage binder
-      = (combined_usage, new_bind:binds_so_far)
-
-      | otherwise		-- Dead
-      = (body_usage, binds_so_far)
-      where
-	total_usage       	        = combineUsageDetails body_usage rhs_usage
-	(rhs_usage, rhs') 	        = lookup binder
-	(combined_usage, tagged_binder) = tagBinder total_usage binder
-
-	new_bind
-	  | mentions_itself binder rhs_usage = CoRec [(tagged_binder,rhs')]
-	  | otherwise		             = CoNonRec tagged_binder rhs'
-	  where
-	    mentions_itself binder usage
-	      = maybeToBool (lookupIdEnv usage binder)
-
-    do_final_bind sCC (body_usage, binds_so_far)
-      | any (isNeeded env body_usage) sCC
-      = (combined_usage, new_bind:binds_so_far)
-
-      | otherwise		-- Dead
-      = (body_usage, binds_so_far)
-      where
-	(rhs_usages, rhss')	         = unzip (map lookup sCC)
-	total_usage		         = foldr combineUsageDetails body_usage rhs_usages
-	(combined_usage, tagged_binders) = tagBinders total_usage sCC
-
-	new_bind	    	         = CoRec (tagged_binders `zip` rhss')
-\end{code}
-
-@occAnalRhs@ deals with the question of bindings where the Id is marked
-by an INLINE pragma.  For these we record that anything which occurs
-in its RHS occurs many times.  This pessimistically assumes that ths
-inlined binder also occurs many times in its scope, but if it doesn't
-we'll catch it next time round.  At worst this costs an extra simplifier pass.
-ToDo: try using the occurrence info for the inline'd binder.
-
-\begin{code}
-occAnalRhs :: OccEnv
-	   -> Id		-- Binder
-	   -> Context		-- Stack Style Context
-	   -> PlainCoreExpr	-- Rhs
-	   -> (UsageDetails, SimplifiableCoreExpr)
-
-occAnalRhs env id stk rhs
-  | idWantsToBeINLINEd id && not (ignoreINLINEPragma env)
-  = (mapIdEnv markMany rhs_usage, rhs')
-
-  | otherwise
-  = (rhs_usage, rhs')
-
-  where
-    (rhs_usage, rhs') = occAnal env stk rhs
-\end{code}
-
-Expressions
-~~~~~~~~~~~
-\begin{code}
-occAnal :: OccEnv
-	-> Context
-	-> PlainCoreExpr
-	-> (UsageDetails, 		-- Gives info only about the "interesting" Ids
-	    SimplifiableCoreExpr)
-
-occAnal env stk (CoVar v)
-  | isCandidate env v
-  = (unitIdEnv v (funOccurrence (getContextSize stk)), CoVar v)
-
-  | otherwise
-  = (emptyDetails, CoVar v)
-
-occAnal env _ (CoLit lit)	   = (emptyDetails, CoLit lit)
--- PERHAPS ASSERT THAT STACK == 0 ?
-occAnal env _ (CoCon con tys args) = (occAnalAtoms env args, CoCon con tys args)
-occAnal env _ (CoPrim op tys args) = (occAnalAtoms env args, CoPrim op tys args)
-
-occAnal env stk (CoSCC lbl body)
-  = (mapIdEnv markInsideSCC usage, CoSCC lbl body')
-  where
-    (usage, body') = occAnal env initContext body	
-
-occAnal env stk (CoApp fun arg)
-  = occAnalApp env (incContext stk) [ValArg arg] fun 
-occAnal env stk (CoTyApp fun arg)
-  = occAnalApp env stk [TypeArg arg] fun
-{-
-occAnal env (CoApp fun arg)
-  = (fun_usage `combineUsageDetails` arg_usage, CoApp fun' arg)
-  where
-    (fun_usage, fun') = occAnal env fun
-    arg_usage	      = occAnalAtom env arg
-			
-occAnal env (CoTyApp fun ty)
-  = (fun_usage, CoTyApp fun' ty)
-  where
-    (fun_usage, fun') = occAnal env fun
--}
-occAnal env stk (CoLam binders body) | isLinContext stk
-  = (final_usage, mkCoLam tagged_binders body')
-  where
-    (lin_binders,other_binders)   = splitAt (getContextSize stk) binders
-    new_env			  = env `addNewCands` lin_binders
-    (body_usage, body') 	  = occAnal new_env (lamOnContext stk (length lin_binders))
-						(mkCoLam other_binders body)
-    (final_usage, tagged_binders) = tagBinders body_usage lin_binders
-
-occAnal env stk (CoLam binders body)
-  = (mapIdEnv markDangerousToDup final_usage, mkCoLam tagged_binders body')
-  where
-    new_env			  = env `addNewCands` binders
-    (body_usage, body') 	  = occAnal new_env (lamOnContext stk (length binders)) body
-    (final_usage, tagged_binders) = tagBinders body_usage binders
-
-{-
-occAnal env (CoLam binders body)
-  = (mapIdEnv markDangerousToDup final_usage, mkCoLam tagged_binders body')
-  where
-    new_env			  = env `addNewCands` binders
-    (body_usage, body') 	  = occAnal new_env body
-    (final_usage, tagged_binders) = tagBinders body_usage binders
--}
-
-occAnal env stk (CoTyLam tyvar body) 
-  = (new_body_usage, CoTyLam tyvar body')
-  where
-    (body_usage, body') = occAnal env stk body
-    new_body_usage = if isLinContext stk 
-		     then body_usage
-		     else mapIdEnv markDangerousToDup body_usage
-
-occAnal env stk (CoCase scrut alts)
-  = (scrut_usage `combineUsageDetails` alts_usage,
-     CoCase scrut' alts')
-  where
-    (scrut_usage, scrut') = occAnal env initContext scrut
-    (alts_usage, alts')   = occAnalAlts env stk alts
-
-
-occAnal env stk (CoLet bind body)
-  = (final_usage  , foldr CoLet body' new_binds) -- mkCoLets* wants PlainCore... (sigh)
-  where
-    new_env		     = env `addNewCands` (bindersOf bind)
-    (body_usage, body')      = occAnal new_env stk {- ?? -} body
-    (final_usage, new_binds) = --BSCC("occAnalBind2")
-			       occAnalBind env bind body_usage
-			       --ESCC
-\end{code}
-
-Case alternatives
-~~~~~~~~~~~~~~~~~
-\begin{code}
-occAnalAlts env stk (CoAlgAlts alts deflt)
-  = (foldr combineAltsUsageDetails deflt_usage alts_usage,
-	-- Note: combine*Alts*UsageDetails...
-     CoAlgAlts alts' deflt')
-  where
-    (alts_usage,  alts')  = unzip (map do_alt alts)
-    (deflt_usage, deflt') = occAnalDeflt env stk deflt
-
-    do_alt (con, args, rhs)
-      = (final_usage, (con, tagged_args, rhs'))
-      where
-	new_env		   = env `addNewCands` args
-	(rhs_usage, rhs')	   = occAnal new_env stk rhs
-	(final_usage, tagged_args) = tagBinders rhs_usage args
-
-occAnalAlts env stk (CoPrimAlts alts deflt)
-  = (foldr combineAltsUsageDetails deflt_usage alts_usage,
-	-- Note: combine*Alts*UsageDetails...
-     CoPrimAlts alts' deflt')
-  where
-    (alts_usage, alts')   = unzip (map do_alt alts)
-    (deflt_usage, deflt') = occAnalDeflt env stk deflt
-
-    do_alt (lit, rhs)
-      = (rhs_usage, (lit, rhs'))
-      where
-	(rhs_usage, rhs') = occAnal env stk rhs
-
-occAnalDeflt env stk CoNoDefault = (emptyDetails, CoNoDefault)
-
-occAnalDeflt env stk (CoBindDefault binder rhs)
-  = (final_usage, CoBindDefault tagged_binder rhs')
-  where
-    new_env			 = env `addNewCand` binder
-    (rhs_usage, rhs')		 = occAnal new_env stk rhs
-    (final_usage, tagged_binder) = tagBinder rhs_usage binder
-\end{code}
-
-
-Atoms
-~~~~~
-\begin{code}
-occAnalAtoms :: OccEnv -> [PlainCoreAtom] -> UsageDetails
-
-occAnalAtoms env atoms
-  = foldr do_one_atom emptyDetails atoms
-  where
-    do_one_atom (CoLitAtom lit) usage = usage
-    do_one_atom (CoVarAtom v) usage
-	| isCandidate env v = addOneOcc usage v (argOccurrence 0)
-        | otherwise	    = usage
-
-
-occAnalArgAtoms :: OccEnv -> [(PlainCoreAtom,ArgUsage)] -> UsageDetails
-occAnalArgAtoms env atoms
-  = foldr do_one_atom emptyDetails atoms
-  where
-    do_one_atom (CoLitAtom lit,_) usage = usage
-    do_one_atom (CoVarAtom v,ArgUsage ar) usage
-	| isCandidate env v = addOneOcc usage v (argOccurrence ar)
-        | otherwise	    = usage
-    do_one_atom (CoVarAtom v,UnknownArgUsage) usage
-	| isCandidate env v = addOneOcc usage v (argOccurrence 0)
-        | otherwise	    = usage
-
-occAnalAtom  :: OccEnv -> PlainCoreAtom -> UsageDetails
-
-occAnalAtom env (CoLitAtom lit) = emptyDetails
-occAnalAtom env (CoVarAtom v)
-  | isCandidate env v = unitDetails v (argOccurrence 0)
-  | otherwise         = emptyDetails
---
--- This function looks for (fully) applied calls to special ids.
---
-occAnalApp 
-	:: OccEnv 
-	-> Context 
-	-> [PlainCoreArg]
-	-> PlainCoreExpr 
-	-> (UsageDetails, 	-- Gives info only about the "interesting" Ids
-	    SimplifiableCoreExpr)
-occAnalApp env stk args fun@(CoVar v)
-  | not (null aut) 
-  && getContextSize stk >= length aut	-- fully applied
-  = (fun_usage `combineUsageDetails` arg_usages,
-	applyToArgs fun' args)
-    where
-	val_args = [ x | ValArg x <- args ] 
-	aut = getArgUsage (getIdArgUsageInfo v)
-	(fun_usage, fun') = occAnal env stk fun
-	arg_usages = occAnalArgAtoms env (zip val_args aut)
-occAnalApp env stk args (CoApp fun arg)
-  = occAnalApp env (incContext stk) (ValArg arg:args) fun 
-occAnalApp env stk args (CoTyApp fun arg)
-  = occAnalApp env stk (TypeArg arg:args) fun 
-occAnalApp env stk args fun 
-  = (fun_usage `combineUsageDetails` arg_usages,
-	applyToArgs fun' args)
-    where
-	(fun_usage, fun') = occAnal env stk fun
-	arg_usages = occAnalAtoms env val_args
-	val_args = [ x | ValArg x <- args ] 
-\end{code}
-
-%************************************************************************
-%*									*
-\subsection[OccurAnal-main]{Counting occurrences: main function}
-%*									*
-%************************************************************************
-
-Abstract, but simple rep. for stacks.
-\begin{code}
-data Context = Context Int Bool	
-	-- if b then n > 0
-	-- ie. you *can't* have a linear content with *no* arguments.
-
-lamOnContext :: Context -> Int -> Context
-lamOnContext (Context n b) i = mkContext (max 0 (n - i)) b
-
-isLinContext :: Context -> Bool
-isLinContext (Context n b) = b
-
-getContextSize :: Context -> Int
-getContextSize (Context n b) = n
-
-incContext :: Context -> Context
-incContext (Context n u) = Context (n + 1) u
-
-initContext :: Context
-initContext = Context 0 False
-
-shareContext :: Context -> Context 
-shareContext (Context n u) = mkContext n False
-
-mkContext :: Int -> Bool -> Context
-mkContext 0 _ = Context 0 False
-mkContext i b = Context i b
-
-mkContextFromBinderInfo :: BinderInfo -> Context
-mkContextFromBinderInfo (DeadCode)         = mkContext 0 False
-mkContextFromBinderInfo (ManyOcc i)        = mkContext i False
-mkContextFromBinderInfo bi@(OneOcc _ _ _ _ i)
-					   = mkContext i (oneSafeOcc True bi)
-\end{code}
- 
diff --git a/ghc/compiler/simplCore/OccurAnal.hi b/ghc/compiler/simplCore/OccurAnal.hi
deleted file mode 100644
index d0c1fa0959..0000000000
--- a/ghc/compiler/simplCore/OccurAnal.hi
+++ /dev/null
@@ -1,27 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface OccurAnal where
-import BasicLit(BasicLit)
-import BinderInfo(BinderInfo, DuplicationDanger, FunOrArg, InsideSCC)
-import CmdLineOpts(GlobalSwitch, SimplifierSwitch)
-import CoreSyn(CoreAtom, CoreBinding, CoreCaseAlternatives, CoreExpr)
-import CostCentre(CostCentre)
-import Id(Id)
-import PlainCore(PlainCoreExpr(..), PlainCoreProgram(..))
-import PrimOps(PrimOp)
-import TaggedCore(SimplifiableCoreBinding(..), SimplifiableCoreExpr(..))
-import TyVar(TyVar)
-import UniType(UniType)
-import UniqFM(UniqFM)
-data BinderInfo 
-data GlobalSwitch 
-data CoreBinding a b 
-data CoreExpr a b 
-data Id 
-type PlainCoreExpr = CoreExpr Id Id
-type PlainCoreProgram = [CoreBinding Id Id]
-type SimplifiableCoreBinding = CoreBinding (Id, BinderInfo) Id
-type SimplifiableCoreExpr = CoreExpr (Id, BinderInfo) Id
-occurAnalyseBinds :: [CoreBinding Id Id] -> (GlobalSwitch -> Bool) -> (SimplifierSwitch -> Bool) -> [CoreBinding (Id, BinderInfo) Id]
-occurAnalyseExpr :: UniqFM Id -> CoreExpr Id Id -> (UniqFM BinderInfo, CoreExpr (Id, BinderInfo) Id)
-occurAnalyseGlobalExpr :: CoreExpr Id Id -> CoreExpr (Id, BinderInfo) Id
-
diff --git a/ghc/compiler/simplCore/OccurAnal.lhs b/ghc/compiler/simplCore/OccurAnal.lhs
index 8054ae31aa..b04eb4b031 100644
--- a/ghc/compiler/simplCore/OccurAnal.lhs
+++ b/ghc/compiler/simplCore/OccurAnal.lhs
@@ -7,85 +7,24 @@
 %*									*
 %************************************************************************
 
-The occurrence analyser analyses the way in which variables are used
-in their scope, and pins that information on the binder.  It does {\em
-not} take any strategic decisions about what to do as a result (eg
-discard binding, inline binding etc).  That's the job of the
-simplifier.
-
-The occurrence analyser {\em simply} records usage information.  That is,
-it pins on each binder info on how that binder occurs in its scope.
-
-Any uses within the RHS of a let(rec) binding for a variable which is
-itself unused are ignored.  For example:
-@
-	let x = ...
- 	    y = ...x...
-	in
-	x+1
-@
-Here, y is unused, so x will be marked as appearing just once.
-
-An exported Id gets tagged as ManyOcc.
-
-IT MUST OBSERVE SCOPING: CANNOT assume unique binders.
-
-Lambdas
-~~~~~~~
-The occurrence analyser marks each binder in a lambda the same way.
-Thus:
-	\ x y -> f y x
-will have both x and y marked as single occurrence, and *not* dangerous-to-dup.
-Technically, x occurs inside a lambda, and therefore *is* dangerous-to-dup,
-but the simplifer very carefully takes care of this special case.
-(See the CoLam case in simplExpr.)
-
-Why?  Because typically applications are saturated, in which case x is *not*
-dangerous-to-dup.
-
-Things to muse upon
-~~~~~~~~~~~~~~~~~~~
-
-There *is* a reason not to substitute for
-variables applied to types: it can undo the effect of floating
-Consider:
-\begin{verbatim}
-	c = /\a -> e
-	f = /\b -> let d = c b
-		   in \ x::b -> ...
-\end{verbatim}
-Here, inlining c would be a Bad Idea.
-
-At present I've set it up so that the "inside-lambda" flag sets set On for
-type-lambdas too, which effectively prevents such substitutions.  I don't *think*
-it disables any interesting ones either.
+The occurrence analyser re-typechecks a core expression, returning a new
+core expression with (hopefully) improved usage information.
 
 \begin{code}
 #include "HsVersions.h"
 
 module OccurAnal (
-	occurAnalyseBinds, occurAnalyseExpr, occurAnalyseGlobalExpr,
+	occurAnalyseBinds, occurAnalyseExpr, occurAnalyseGlobalExpr
 
 	-- and to make the interface self-sufficient...
-	CoreExpr, CoreBinding, Id, BinderInfo, GlobalSwitch,
-	PlainCoreProgram(..), PlainCoreExpr(..),
-	SimplifiableCoreExpr(..), SimplifiableCoreBinding(..)
     ) where
 
-IMPORT_Trace
-import Outputable	-- ToDo: rm; debugging
-import Pretty
-
-import PlainCore	-- the stuff we read...
-import TaggedCore	-- ... and produce Simplifiable*
-
-import AbsUniType
+import Type
 import BinderInfo
 import CmdLineOpts	( GlobalSwitch(..), SimplifierSwitch(..) )
 import Digraph		( stronglyConnComp )
-import Id		( eqId, idWantsToBeINLINEd, isConstMethodId_maybe,
+import Id		( eqId, idWantsToBeINLINEd, isConstMethodId,
 			  isSpecPragmaId_maybe, SpecInfo )
-import IdEnv
 import Maybes
 import UniqSet
 import Util
@@ -99,51 +38,47 @@ import Util
 %************************************************************************
 
 \begin{code}
-data OccEnv = OccEnv
-		Bool		-- Keep-unused-bindings flag
-				-- False <=> OK to chuck away binding
-				-- 	     and ignore occurrences within it
-		Bool		-- Keep-spec-pragma-ids flag
-				-- False <=> OK to chuck away spec pragma bindings
-				-- 	     and ignore occurrences within it
-		Bool		-- Keep-conjurable flag
-				-- False <=> OK to throw away *dead*
-				-- "conjurable" Ids; at the moment, that
-				-- *only* means constant methods, which
-				-- are top-level.  A use of a "conjurable"
-				-- Id may appear out of thin air -- e.g.,
-				-- specialiser conjuring up refs to const
-				-- methods.
-		Bool		-- IgnoreINLINEPragma flag
-				-- False <=> OK to use INLINEPragma information
-				-- True  <=> ignore INLINEPragma information
-		(UniqSet Id)	-- Candidates
+data OccEnv =
+  OccEnv
+    Bool	-- Keep-unused-bindings flag
+		-- False <=> OK to chuck away binding
+		-- 	     and ignore occurrences within it
+    Bool	-- Keep-spec-pragma-ids flag
+		-- False <=> OK to chuck away spec pragma bindings
+		-- 	     and ignore occurrences within it
+    Bool	-- Keep-conjurable flag
+		-- False <=> OK to throw away *dead*
+		-- "conjurable" Ids; at the moment, that
+		-- *only* means constant methods, which
+		-- are top-level.  A use of a "conjurable"
+		-- Id may appear out of thin air -- e.g.,
+		-- specialiser conjuring up refs to const methods.
+   Bool		-- IgnoreINLINEPragma flag
+		-- False <=> OK to use INLINEPragma information
+		-- True  <=> ignore INLINEPragma information
+   (UniqSet Id)	-- Candidates
 
 addNewCands :: OccEnv -> [Id] -> OccEnv
-addNewCands (OccEnv keep_dead keep_spec keep_conjurable ignore_inline_pragma cands) ids
-  = OccEnv keep_dead keep_spec keep_conjurable ignore_inline_pragma (cands `unionUniqSets` mkUniqSet ids)
+addNewCands (OccEnv kd ks kc ip cands) ids
+  = OccEnv kd ks kc ip (cands `unionUniqSets` mkUniqSet ids)
 
 addNewCand :: OccEnv -> Id -> OccEnv
-addNewCand (OccEnv keep_dead keep_spec keep_conjurable ignore_inline_pragma cands) id
-  = OccEnv keep_dead keep_spec keep_conjurable ignore_inline_pragma (cands `unionUniqSets` singletonUniqSet id)
+addNewCand (OccEnv ks kd kc ip cands) id
+  = OccEnv kd ks kc ip (cands `unionUniqSets` singletonUniqSet id)
 
 isCandidate :: OccEnv -> Id -> Bool
 isCandidate (OccEnv _ _ _ _ cands) id = id `elementOfUniqSet` cands
 
 ignoreINLINEPragma :: OccEnv -> Bool
-ignoreINLINEPragma (OccEnv _ _ _ ignore_inline_pragma _) = ignore_inline_pragma
+ignoreINLINEPragma (OccEnv _ _ _ ip _) = ip
 
 keepUnusedBinding :: OccEnv -> Id -> Bool
 keepUnusedBinding (OccEnv keep_dead keep_spec keep_conjurable _ _) binder
-  = keep_dead || (keep_spec && is_spec)
-  where
-    is_spec = maybeToBool (isSpecPragmaId_maybe binder)
+  = keep_dead || (keep_spec && maybeToBool (isSpecPragmaId_maybe binder))
 
 keepBecauseConjurable :: OccEnv -> Id -> Bool
 keepBecauseConjurable (OccEnv _ _ keep_conjurable _ _) binder
-  = keep_conjurable && is_conjurable
-  where
-    is_conjurable = maybeToBool (isConstMethodId_maybe binder)
+  = keep_conjurable && isConstMethodId binder
 
 type UsageDetails = IdEnv BinderInfo	-- A finite map from ids to their usage
 
@@ -196,7 +131,7 @@ usage_of usage binder
       Just info -> info
 
 isNeeded env usage binder
-  = case usage_of usage binder of	
+  = case usage_of usage binder of
       DeadCode  -> keepUnusedBinding env binder	-- Maybe keep it anyway
       other     -> True
 \end{code}
@@ -212,7 +147,7 @@ Here's the externally-callable interface:
 
 \begin{code}
 occurAnalyseBinds
-	:: [PlainCoreBinding]		-- input
+	:: [CoreBinding]		-- input
 	-> (GlobalSwitch -> Bool)
 	-> (SimplifierSwitch -> Bool)
 	-> [SimplifiableCoreBinding]	-- output
@@ -242,7 +177,7 @@ occurAnalyseBinds binds global_sw_chkr simplifier_sw_chkr
 
 \begin{code}
 occurAnalyseExpr :: UniqSet Id 			-- Set of interesting free vars
-		 -> PlainCoreExpr 
+		 -> CoreExpr
 		 -> (IdEnv BinderInfo,		-- Occ info for interesting free vars
 		     SimplifiableCoreExpr)
 
@@ -255,9 +190,9 @@ occurAnalyseExpr candidates expr
 			 False {- Do not ignore INLINE Pragma -}
 			 candidates
 
-occurAnalyseGlobalExpr :: PlainCoreExpr -> SimplifiableCoreExpr
+occurAnalyseGlobalExpr :: CoreExpr -> SimplifiableCoreExpr
 occurAnalyseGlobalExpr expr
-  = 	-- Top level expr, so no interesting free vars, and 
+  = 	-- Top level expr, so no interesting free vars, and
 	-- discard occurence info returned
     expr' where (_, expr') = occurAnalyseExpr emptyUniqSet expr
 \end{code}
@@ -273,15 +208,15 @@ Bindings
 
 \begin{code}
 occAnalBind :: OccEnv
-	    -> PlainCoreBinding
+	    -> CoreBinding
 	    -> UsageDetails		-- Usage details of scope
 	    -> (UsageDetails,		-- Of the whole let(rec)
 		[SimplifiableCoreBinding])
 
-occAnalBind env (CoNonRec binder rhs) body_usage
+occAnalBind env (NonRec binder rhs) body_usage
   | isNeeded env body_usage binder		-- It's mentioned in body
   = (final_body_usage `combineUsageDetails` rhs_usage,
-     [CoNonRec tagged_binder rhs'])
+     [NonRec tagged_binder rhs'])
 
   | otherwise
   = (body_usage, [])
@@ -298,9 +233,9 @@ Dropping dead code for recursive bindings is done in a very simple way:
 
 This seems to miss an obvious improvement.
 @
-	letrec  f = ...g...	
-	        g = ...f...
-	in	
+	letrec  f = ...g...
+		g = ...f...
+	in
 	...g...
 
 ===>
@@ -327,7 +262,7 @@ It isn't easy to do a perfect job in one blow.  Consider
 
 
 \begin{code}
-occAnalBind env (CoRec pairs) body_usage
+occAnalBind env (Rec pairs) body_usage
   = foldr do_final_bind (body_usage, []) sccs
   where
 
@@ -336,7 +271,7 @@ occAnalBind env (CoRec pairs) body_usage
 
     analysed_pairs :: [(Id, (UsageDetails, SimplifiableCoreExpr))]
     analysed_pairs  = [(id, occAnalRhs new_env id rhs) | (id,rhs) <- pairs]
-    
+
     lookup :: Id -> (UsageDetails, SimplifiableCoreExpr)
     lookup id =  assoc "occAnalBind:lookup" analysed_pairs id
 
@@ -344,7 +279,7 @@ occAnalBind env (CoRec pairs) body_usage
     ---- stuff for dependency analysis of binds -------------------------------
 
     edges :: [(Id,Id)]		-- (a,b) means a mentions b
-    edges = concat [ edges_from binder rhs_usage 
+    edges = concat [ edges_from binder rhs_usage
 		   | (binder, (rhs_usage, _)) <- analysed_pairs]
 
     edges_from :: Id -> UsageDetails -> [(Id,Id)]
@@ -372,8 +307,8 @@ occAnalBind env (CoRec pairs) body_usage
 	(combined_usage, tagged_binder) = tagBinder total_usage binder
 
 	new_bind
-	  | mentions_itself binder rhs_usage = CoRec [(tagged_binder,rhs')]
-	  | otherwise		             = CoNonRec tagged_binder rhs'
+	  | mentions_itself binder rhs_usage = Rec [(tagged_binder,rhs')]
+	  | otherwise		             = NonRec tagged_binder rhs'
 	  where
 	    mentions_itself binder usage
 	      = maybeToBool (lookupIdEnv usage binder)
@@ -389,7 +324,7 @@ occAnalBind env (CoRec pairs) body_usage
 	total_usage		         = foldr combineUsageDetails body_usage rhs_usages
 	(combined_usage, tagged_binders) = tagBinders total_usage sCC
 
-	new_bind	    	         = CoRec (tagged_binders `zip` rhss')
+	new_bind	    	         = Rec (tagged_binders `zip` rhss')
 \end{code}
 
 @occAnalRhs@ deals with the question of bindings where the Id is marked
@@ -402,7 +337,7 @@ ToDo: try using the occurrence info for the inline'd binder.
 \begin{code}
 occAnalRhs :: OccEnv
 	   -> Id		-- Binder
-	   -> PlainCoreExpr	-- Rhs
+	   -> CoreExpr	-- Rhs
 	   -> (UsageDetails, SimplifiableCoreExpr)
 
 occAnalRhs env id rhs
@@ -420,43 +355,42 @@ Expressions
 ~~~~~~~~~~~
 \begin{code}
 occAnal :: OccEnv
-	-> PlainCoreExpr
+	-> CoreExpr
 	-> (UsageDetails, 		-- Gives info only about the "interesting" Ids
 	    SimplifiableCoreExpr)
 
-occAnal env (CoVar v)
+occAnal env (Var v)
   | isCandidate env v
-  = (unitIdEnv v (funOccurrence 0), CoVar v)
+  = (unitIdEnv v (funOccurrence 0), Var v)
 
   | otherwise
-  = (emptyDetails, CoVar v)
+  = (emptyDetails, Var v)
 
-occAnal env (CoLit lit)	   = (emptyDetails, CoLit lit)
-occAnal env (CoCon con tys args) = (occAnalAtoms env args, CoCon con tys args)
-occAnal env (CoPrim op tys args) = (occAnalAtoms env args, CoPrim op tys args)
+occAnal env (Lit lit)	   = (emptyDetails, Lit lit)
+occAnal env (Con con tys args) = (occAnalAtoms env args, Con con tys args)
+occAnal env (Prim op tys args) = (occAnalAtoms env args, Prim op tys args)
 
-occAnal env (CoSCC cc body)
-  = (mapIdEnv markInsideSCC usage, CoSCC cc body')
+occAnal env (SCC cc body)
+  = (mapIdEnv markInsideSCC usage, SCC cc body')
   where
     (usage, body') = occAnal env body
 
-occAnal env (CoApp fun arg)
-  = (fun_usage `combineUsageDetails` arg_usage, CoApp fun' arg)
+occAnal env (App fun arg)
+  = (fun_usage `combineUsageDetails` arg_usage, App fun' arg)
   where
     (fun_usage, fun') = occAnal env fun
     arg_usage	      = occAnalAtom env arg
-			
+
 occAnal env (CoTyApp fun ty)
   = (fun_usage, CoTyApp fun' ty)
   where
     (fun_usage, fun') = occAnal env fun
 
-occAnal env (CoLam binders body)
-  = (mapIdEnv markDangerousToDup final_usage, mkCoLam tagged_binders body')
+occAnal env (Lam binder body)
+  = (mapIdEnv markDangerousToDup final_usage, Lam tagged_binder body')
   where
-    new_env			  = env `addNewCands` binders
-    (body_usage, body') 	  = occAnal new_env body
-    (final_usage, tagged_binders) = tagBinders body_usage binders
+    (body_usage, body') 	  = occAnal (env `addNewCand` binder) body
+    (final_usage, tagged_binder) = tagBinder body_usage binder
 
 -- ANDY: WE MUST THINK ABOUT THIS! (ToDo)
 occAnal env (CoTyLam tyvar body)
@@ -464,15 +398,15 @@ occAnal env (CoTyLam tyvar body)
   where
     (body_usage, body') = occAnal env body
 
-occAnal env (CoCase scrut alts)
+occAnal env (Case scrut alts)
   = (scrut_usage `combineUsageDetails` alts_usage,
-     CoCase scrut' alts')
+     Case scrut' alts')
   where
     (scrut_usage, scrut') = occAnal env scrut
     (alts_usage, alts')   = occAnalAlts env alts
 
-occAnal env (CoLet bind body)
-  = (final_usage, foldr CoLet body' new_binds) -- mkCoLet* wants PlainCore... (sigh)
+occAnal env (Let bind body)
+  = (final_usage, foldr Let body' new_binds) -- mkCoLet* wants Core... (sigh)
   where
     new_env		     = env `addNewCands` (bindersOf bind)
     (body_usage, body')      = occAnal new_env body
@@ -484,10 +418,10 @@ occAnal env (CoLet bind body)
 Case alternatives
 ~~~~~~~~~~~~~~~~~
 \begin{code}
-occAnalAlts env (CoAlgAlts alts deflt)
+occAnalAlts env (AlgAlts alts deflt)
   = (foldr combineAltsUsageDetails deflt_usage alts_usage,
 	-- Note: combine*Alts*UsageDetails...
-     CoAlgAlts alts' deflt')
+     AlgAlts alts' deflt')
   where
     (alts_usage,  alts')  = unzip (map do_alt alts)
     (deflt_usage, deflt') = occAnalDeflt env deflt
@@ -499,10 +433,10 @@ occAnalAlts env (CoAlgAlts alts deflt)
 	(rhs_usage, rhs')	   = occAnal new_env rhs
 	(final_usage, tagged_args) = tagBinders rhs_usage args
 
-occAnalAlts env (CoPrimAlts alts deflt)
+occAnalAlts env (PrimAlts alts deflt)
   = (foldr combineAltsUsageDetails deflt_usage alts_usage,
 	-- Note: combine*Alts*UsageDetails...
-     CoPrimAlts alts' deflt')
+     PrimAlts alts' deflt')
   where
     (alts_usage, alts')   = unzip (map do_alt alts)
     (deflt_usage, deflt') = occAnalDeflt env deflt
@@ -512,10 +446,10 @@ occAnalAlts env (CoPrimAlts alts deflt)
       where
 	(rhs_usage, rhs') = occAnal env rhs
 
-occAnalDeflt env CoNoDefault = (emptyDetails, CoNoDefault)
+occAnalDeflt env NoDefault = (emptyDetails, NoDefault)
 
-occAnalDeflt env (CoBindDefault binder rhs)
-  = (final_usage, CoBindDefault tagged_binder rhs')
+occAnalDeflt env (BindDefault binder rhs)
+  = (final_usage, BindDefault tagged_binder rhs')
   where
     new_env			 = env `addNewCand` binder
     (rhs_usage, rhs')		 = occAnal new_env rhs
@@ -526,21 +460,21 @@ occAnalDeflt env (CoBindDefault binder rhs)
 Atoms
 ~~~~~
 \begin{code}
-occAnalAtoms :: OccEnv -> [PlainCoreAtom] -> UsageDetails
+occAnalAtoms :: OccEnv -> [CoreArg] -> UsageDetails
 
 occAnalAtoms env atoms
   = foldr do_one_atom emptyDetails atoms
   where
-    do_one_atom (CoLitAtom lit) usage = usage
-    do_one_atom (CoVarAtom v) usage
+    do_one_atom (LitArg lit) usage = usage
+    do_one_atom (VarArg v) usage
 	| isCandidate env v = addOneOcc usage v (argOccurrence 0)
-        | otherwise	    = usage
+	| otherwise	    = usage
 
 
-occAnalAtom  :: OccEnv -> PlainCoreAtom -> UsageDetails
+occAnalAtom  :: OccEnv -> CoreArg -> UsageDetails
 
-occAnalAtom env (CoLitAtom lit) = emptyDetails
-occAnalAtom env (CoVarAtom v)
+occAnalAtom env (LitArg lit) = emptyDetails
+occAnalAtom env (VarArg v)
   | isCandidate env v = unitDetails v (argOccurrence 0)
   | otherwise         = emptyDetails
 \end{code}
diff --git a/ghc/compiler/simplCore/SAT.hi b/ghc/compiler/simplCore/SAT.hi
deleted file mode 100644
index fb1f3389aa..0000000000
--- a/ghc/compiler/simplCore/SAT.hi
+++ /dev/null
@@ -1,17 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface SAT where
-import BasicLit(BasicLit)
-import CoreSyn(CoreAtom, CoreBinding, CoreCaseAlternatives, CoreExpr)
-import CostCentre(CostCentre)
-import Id(Id)
-import PlainCore(PlainCoreProgram(..))
-import PrimOps(PrimOp)
-import SplitUniq(SplitUniqSupply)
-import TyVar(TyVar)
-import UniType(UniType)
-data CoreBinding a b 
-data CoreExpr a b 
-data Id 
-type PlainCoreProgram = [CoreBinding Id Id]
-doStaticArgs :: [CoreBinding Id Id] -> SplitUniqSupply -> [CoreBinding Id Id]
-
diff --git a/ghc/compiler/simplCore/SAT.lhs b/ghc/compiler/simplCore/SAT.lhs
index 6f484cfddf..dbd4f54000 100644
--- a/ghc/compiler/simplCore/SAT.lhs
+++ b/ghc/compiler/simplCore/SAT.lhs
@@ -33,51 +33,47 @@ they will eventually be removed in later stages of the compiler,
 therefore there is no penalty in keeping them.
 
 Experimental Evidence: Heap: +/- 7%
-                       Instrs: Always improves for 2 or more Static Args.
+		       Instrs: Always improves for 2 or more Static Args.
 
 \begin{code}
 #include "HsVersions.h"
 
 module SAT (
-	doStaticArgs,
+	doStaticArgs
 
 	-- and to make the interface self-sufficient...
-	PlainCoreProgram(..), CoreExpr, CoreBinding, Id
     ) where
 
-import IdEnv
 import Maybes		( Maybe(..) )
-import PlainCore
 import SATMonad
-import SplitUniq
 import Util
 \end{code}
 
 \begin{code}
-doStaticArgs :: PlainCoreProgram -> SplitUniqSupply -> PlainCoreProgram
+doStaticArgs :: [CoreBinding] -> UniqSupply -> [CoreBinding]
 
 doStaticArgs binds
   = initSAT (mapSAT sat_bind binds)
   where
-    sat_bind (CoNonRec binder expr)
+    sat_bind (NonRec binder expr)
       = emptyEnvSAT  `thenSAT_`
 	satExpr expr `thenSAT` (\ expr' ->
-	returnSAT (CoNonRec binder expr') )
-    sat_bind (CoRec [(binder,rhs)])
+	returnSAT (NonRec binder expr') )
+    sat_bind (Rec [(binder,rhs)])
       = emptyEnvSAT			  `thenSAT_`
 	insSAEnv binder (getArgLists rhs) `thenSAT_`
 	satExpr rhs			  `thenSAT` (\ rhs' ->
 	saTransform binder rhs')
-    sat_bind (CoRec pairs)
+    sat_bind (Rec pairs)
       = emptyEnvSAT		`thenSAT_`
 	mapSAT satExpr rhss	`thenSAT` \ rhss' ->
-	returnSAT (CoRec (binders `zip` rhss'))
+	returnSAT (Rec (binders `zip` rhss'))
       where
 	(binders, rhss)	= unzip pairs
 \end{code}
 
 \begin{code}
-satAtom (CoVarAtom v)
+satAtom (VarArg v)
   = updSAEnv (Just (v,([],[]))) `thenSAT_`
     returnSAT ()
 
@@ -85,102 +81,100 @@ satAtom _ = returnSAT ()
 \end{code}
 
 \begin{code}
-satExpr :: PlainCoreExpr -> SatM PlainCoreExpr
+satExpr :: CoreExpr -> SatM CoreExpr
 
-satExpr var@(CoVar v)
+satExpr var@(Var v)
   = updSAEnv (Just (v,([],[]))) `thenSAT_`
     returnSAT var
 
-satExpr lit@(CoLit _) = returnSAT lit
+satExpr lit@(Lit _) = returnSAT lit
 
-satExpr e@(CoCon con types args)
+satExpr e@(Con con types args)
   = mapSAT satAtom args	    `thenSAT_`
     returnSAT e
 
-satExpr e@(CoPrim prim ty args)
+satExpr e@(Prim prim ty args)
   = mapSAT satAtom args	    `thenSAT_`
     returnSAT e
 
-satExpr (CoLam binders body)
+satExpr (Lam binders body)
   = satExpr body		`thenSAT` \ body' ->
-    returnSAT (CoLam binders body')
+    returnSAT (Lam binders body')
 
 satExpr (CoTyLam tyvar body)
   = satExpr body	   `thenSAT` (\ body' ->
     returnSAT (CoTyLam tyvar body') )
 
-satExpr app@(CoApp _ _)
+satExpr app@(App _ _)
   = getAppArgs app
 
 satExpr app@(CoTyApp _ _)
   = getAppArgs app
 
-satExpr (CoCase expr alts)
+satExpr (Case expr alts)
   = satExpr expr	`thenSAT` \ expr' ->
     sat_alts alts	`thenSAT` \ alts' ->
-    returnSAT (CoCase expr' alts')
+    returnSAT (Case expr' alts')
   where
-    sat_alts (CoAlgAlts alts deflt)
+    sat_alts (AlgAlts alts deflt)
       = mapSAT satAlgAlt alts	    `thenSAT` \ alts' ->
 	sat_default deflt	    `thenSAT` \ deflt' ->
-	returnSAT (CoAlgAlts alts' deflt')
+	returnSAT (AlgAlts alts' deflt')
       where
 	satAlgAlt (con, params, rhs)
 	  = satExpr rhs		 `thenSAT` \ rhs' ->
 	    returnSAT (con, params, rhs')
 
-    sat_alts (CoPrimAlts alts deflt)
+    sat_alts (PrimAlts alts deflt)
       = mapSAT satPrimAlt alts	    `thenSAT` \ alts' ->
 	sat_default deflt	    `thenSAT` \ deflt' ->
-	returnSAT (CoPrimAlts alts' deflt')
+	returnSAT (PrimAlts alts' deflt')
       where
 	satPrimAlt (lit, rhs)
 	  = satExpr rhs `thenSAT` \ rhs' ->
 	    returnSAT (lit, rhs')
 
-    sat_default CoNoDefault
-      = returnSAT CoNoDefault
-    sat_default (CoBindDefault binder rhs)
+    sat_default NoDefault
+      = returnSAT NoDefault
+    sat_default (BindDefault binder rhs)
       = satExpr rhs		     `thenSAT` \ rhs' ->
-	returnSAT (CoBindDefault binder rhs')
+	returnSAT (BindDefault binder rhs')
 
-satExpr (CoLet (CoNonRec binder rhs) body)
+satExpr (Let (NonRec binder rhs) body)
   = satExpr body		`thenSAT` \ body' ->
     satExpr rhs			`thenSAT` \ rhs' ->
-    returnSAT (CoLet (CoNonRec binder rhs') body')
+    returnSAT (Let (NonRec binder rhs') body')
 
-satExpr (CoLet (CoRec [(binder,rhs)]) body)
+satExpr (Let (Rec [(binder,rhs)]) body)
   = satExpr body		      `thenSAT` \ body' ->
     insSAEnv binder (getArgLists rhs) `thenSAT_`
     satExpr rhs			      `thenSAT` \ rhs' ->
     saTransform binder rhs'	      `thenSAT` \ binding ->
-    returnSAT (CoLet binding body')
+    returnSAT (Let binding body')
 
-satExpr (CoLet (CoRec binds) body)
+satExpr (Let (Rec binds) body)
   = let
 	(binders, rhss) = unzip binds
     in
     satExpr body		    `thenSAT` \ body' ->
     mapSAT satExpr rhss		    `thenSAT` \ rhss' ->
-    returnSAT (CoLet (CoRec (binders `zip` rhss')) body')
+    returnSAT (Let (Rec (binders `zip` rhss')) body')
 
-satExpr (CoSCC cc expr)
+satExpr (SCC cc expr)
   = satExpr expr		    `thenSAT` \ expr2 ->
-    returnSAT (CoSCC cc expr2)
-
--- ToDo: DPH stuff
+    returnSAT (SCC cc expr2)
 \end{code}
 
 \begin{code}
-getAppArgs :: PlainCoreExpr -> SatM PlainCoreExpr
+getAppArgs :: CoreExpr -> SatM CoreExpr
 
 getAppArgs app
   = get app		`thenSAT` \ (app',result) ->
     updSAEnv result	`thenSAT_`
     returnSAT app'
   where
-    get :: PlainCoreExpr
-	-> SatM (PlainCoreExpr, Maybe (Id, SATInfo))
+    get :: CoreExpr
+	-> SatM (CoreExpr, Maybe (Id, SATInfo))
 
     get (CoTyApp e ty)
       = get e		`thenSAT` \ (e',result) ->
@@ -191,21 +185,21 @@ getAppArgs app
 	    Just (v,(tv,lv)) -> Just (v,(tv++[Static ty],lv))
 	)
 
-    get (CoApp e a)
+    get (App e a)
       = get e		`thenSAT` \ (e', result) ->
 	satAtom a	`thenSAT_`
 	let si = case a of
-		   (CoVarAtom v) -> Static v
+		   (VarArg v) -> Static v
 		   _	         -> NotStatic
 	in
 	  returnSAT (
-	    CoApp e' a,
+	    App e' a,
 	    case result of
 		Just (v,(tv,lv)) -> Just (v,(tv,lv++[si]))
 		Nothing	    	 -> Nothing
 	  )
 
-    get var@(CoVar v)
+    get var@(Var v)
       = returnSAT (var, Just (v,([],[])))
 
     get e
diff --git a/ghc/compiler/simplCore/SATMonad.hi b/ghc/compiler/simplCore/SATMonad.hi
deleted file mode 100644
index 1c24f25f7d..0000000000
--- a/ghc/compiler/simplCore/SATMonad.hi
+++ /dev/null
@@ -1,35 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface SATMonad where
-import CoreSyn(CoreBinding, CoreExpr)
-import Id(Id)
-import Maybes(Labda)
-import PlainCore(PlainCoreExpr(..))
-import SplitUniq(SplitUniqSupply)
-import UniType(UniType)
-import UniqFM(UniqFM)
-infixr 9 `thenSAT`
-infixr 9 `thenSAT_`
-data Arg a   = Static a | NotStatic
-data Id 
-type PlainCoreExpr = CoreExpr Id Id
-type SATEnv = UniqFM ([Arg UniType], [Arg Id])
-type SATInfo = ([Arg UniType], [Arg Id])
-type SatM a = SplitUniqSupply -> UniqFM ([Arg UniType], [Arg Id]) -> (a, UniqFM ([Arg UniType], [Arg Id]))
-data SplitUniqSupply 
-data UniType 
-dropStatics :: [Arg a] -> [b] -> [b]
-emptyEnvSAT :: SplitUniqSupply -> UniqFM ([Arg UniType], [Arg Id]) -> ((), UniqFM ([Arg UniType], [Arg Id]))
-getArgLists :: CoreExpr Id Id -> ([Arg UniType], [Arg Id])
-getSATInfo :: Id -> SplitUniqSupply -> UniqFM ([Arg UniType], [Arg Id]) -> (Labda ([Arg UniType], [Arg Id]), UniqFM ([Arg UniType], [Arg Id]))
-initSAT :: (SplitUniqSupply -> UniqFM ([Arg UniType], [Arg Id]) -> (a, UniqFM ([Arg UniType], [Arg Id]))) -> SplitUniqSupply -> a
-insSAEnv :: Id -> ([Arg UniType], [Arg Id]) -> SplitUniqSupply -> UniqFM ([Arg UniType], [Arg Id]) -> ((), UniqFM ([Arg UniType], [Arg Id]))
-isStatic :: Arg a -> Bool
-mapSAT :: (a -> SplitUniqSupply -> c -> (b, c)) -> [a] -> SplitUniqSupply -> c -> ([b], c)
-newSATName :: Id -> UniType -> SplitUniqSupply -> UniqFM ([Arg UniType], [Arg Id]) -> (Id, UniqFM ([Arg UniType], [Arg Id]))
-returnSAT :: b -> a -> c -> (b, c)
-saTransform :: Id -> CoreExpr Id Id -> SplitUniqSupply -> UniqFM ([Arg UniType], [Arg Id]) -> (CoreBinding Id Id, UniqFM ([Arg UniType], [Arg Id]))
-thenSAT :: (SplitUniqSupply -> c -> (a, b)) -> (a -> SplitUniqSupply -> b -> d) -> SplitUniqSupply -> c -> d
-thenSAT_ :: (SplitUniqSupply -> c -> (a, b)) -> (SplitUniqSupply -> b -> d) -> SplitUniqSupply -> c -> d
-updSAEnv :: Labda (Id, ([Arg UniType], [Arg Id])) -> SplitUniqSupply -> UniqFM ([Arg UniType], [Arg Id]) -> ((), UniqFM ([Arg UniType], [Arg Id]))
-instance Eq a => Eq (Arg a)
-
diff --git a/ghc/compiler/simplCore/SATMonad.lhs b/ghc/compiler/simplCore/SATMonad.lhs
index dbdff75125..265df4886f 100644
--- a/ghc/compiler/simplCore/SATMonad.lhs
+++ b/ghc/compiler/simplCore/SATMonad.lhs
@@ -16,24 +16,19 @@ module SATMonad (
 	returnSAT, thenSAT, thenSAT_, mapSAT, getSATInfo, newSATName,
 	getArgLists, Arg(..), insSAEnv, saTransform,
 
-	SATEnv(..), isStatic, dropStatics,
-
-	Id, UniType, SplitUniqSupply, PlainCoreExpr(..)
+	SATEnv(..), isStatic, dropStatics
     ) where
 
-import AbsUniType	( mkTyVarTy, mkSigmaTy, TyVarTemplate,
-			  extractTyVarsFromTy, splitType, splitTyArgs,
+import Type		( mkTyVarTy, mkSigmaTy, TyVarTemplate,
+			  extractTyVarsFromTy, splitSigmaTy, splitTyArgs,
 			  glueTyArgs, instantiateTy, TauType(..),
 			  Class, ThetaType(..), SigmaType(..),
 			  InstTyEnv(..)
 			)
-import IdEnv
-import Id		( mkSysLocal, getIdUniType )
+import Id		( mkSysLocal, idType )
 import Maybes		( Maybe(..) )
-import PlainCore
 import SrcLoc		( SrcLoc, mkUnknownSrcLoc )
-import SplitUniq
-import Unique
+import UniqSupply
 import Util
 
 infixr 9 `thenSAT`, `thenSAT_`
@@ -48,7 +43,7 @@ infixr 9 `thenSAT`, `thenSAT_`
 \begin{code}
 type SATEnv = IdEnv SATInfo
 
-type SATInfo = ([Arg UniType],[Arg Id])
+type SATInfo = ([Arg Type],[Arg Id])
 
 data Arg a = Static a | NotStatic
     deriving Eq
@@ -91,9 +86,9 @@ Two items of state to thread around: a UniqueSupply and a SATEnv.
 
 \begin{code}
 type SatM result
-  =  SplitUniqSupply -> SATEnv -> (result, SATEnv)
+  =  UniqSupply -> SATEnv -> (result, SATEnv)
 
-initSAT :: SatM a -> SplitUniqSupply -> a
+initSAT :: SatM a -> UniqSupply -> a
 
 initSAT f us = fst (f us nullIdEnv)
 
@@ -130,59 +125,58 @@ getSATInfo :: Id -> SatM (Maybe SATInfo)
 getSATInfo var us env
   = (lookupIdEnv env var, env)
 
-newSATName :: Id -> UniType -> SatM Id
+newSATName :: Id -> Type -> SatM Id
 newSATName id ty us env
-  = case (getSUnique us) of { unique ->
+  = case (getUnique us) of { unique ->
     (mkSysLocal new_str unique ty mkUnknownSrcLoc, env) }
   where
     new_str = getOccurrenceName id _APPEND_ SLIT("_sat")
 
-getArgLists :: PlainCoreExpr -> ([Arg UniType],[Arg Id])
+getArgLists :: CoreExpr -> ([Arg Type],[Arg Id])
 getArgLists expr
   = let
-	(tvs, lambda_bounds, body) = digForLambdas expr
+	(uvs, tvs, lambda_bounds, body) = digForLambdas expr
     in
     ([ Static (mkTyVarTy tv) | tv <- tvs ],
      [ Static v		     | v <- lambda_bounds ])
 
-dropArgs :: PlainCoreExpr -> PlainCoreExpr
-dropArgs (CoLam v e)	= dropArgs e
-dropArgs (CoTyLam ty e) = dropArgs e
+dropArgs :: CoreExpr -> CoreExpr
+dropArgs (Lam   _ e)	= dropArgs e
+dropArgs (CoTyLam _ e)	= dropArgs e
 dropArgs e		= e
-
 \end{code}
 
 We implement saTransform using shadowing of binders, that is
 we transform
 map = \f as -> case as of
-                 [] -> []
-                 (a':as') -> let x = f a'
-                                 y = map f as'
-                             in x:y
+		 [] -> []
+		 (a':as') -> let x = f a'
+				 y = map f as'
+			     in x:y
 to
 map = \f as -> let map = \f as -> map' as
-               in let rec map' = \as -> case as of
-                                          [] -> []
-                                          (a':as') -> let x = f a'
-                                                          y = map f as'
-                                                      in x:y
-                  in map' as
+	       in let rec map' = \as -> case as of
+					  [] -> []
+					  (a':as') -> let x = f a'
+							  y = map f as'
+						      in x:y
+		  in map' as
 
 the inner map should get inlined and eliminated.
 \begin{code}
-saTransform :: Id -> PlainCoreExpr -> SatM PlainCoreBinding
+saTransform :: Id -> CoreExpr -> SatM CoreBinding
 saTransform binder rhs
   = getSATInfo binder `thenSAT` \ r ->
     case r of
       -- [Andre] test: do it only if we have more than one static argument.
-      --Just (tyargs,args) | any isStatic args 
+      --Just (tyargs,args) | any isStatic args
       Just (tyargs,args) | length (filter isStatic args) > 1
 	-> newSATName binder (new_ty tyargs args)  `thenSAT` \ binder' ->
 	   mkNewRhs binder binder' tyargs args rhs `thenSAT` \ new_rhs ->
 	   trace ("SAT "++ show (length (filter isStatic args))) (
-           returnSAT (CoNonRec binder new_rhs)
-           )
-      _ -> returnSAT (CoRec [(binder, rhs)])
+	   returnSAT (NonRec binder new_rhs)
+	   )
+      _ -> returnSAT (Rec [(binder, rhs)])
   where
     mkNewRhs binder binder' tyargs args rhs
       = let
@@ -196,12 +190,12 @@ saTransform binder rhs
 		 get_nsa (NotStatic:args) (Static v:as) = v:get_nsa args as
 		 get_nsa (_:args)	  (_:as)	=   get_nsa args as
 
-	    local_body = foldl CoApp (CoVar binder')
-				[CoVarAtom a | a <- non_static_args]
+	    local_body = foldl App (Var binder')
+				[VarArg a | a <- non_static_args]
 
 	    nonrec_rhs = origLams local_body
 
-	    -- HACK! The following is a fake SysLocal binder with 
+	    -- HACK! The following is a fake SysLocal binder with
 	    -- *the same* unique as binder.
 	    -- the reason for this is the following:
 	    -- this binder *will* get inlined but if it happen to be
@@ -210,31 +204,31 @@ saTransform binder rhs
 	    -- top-level or exported somehow.
 	    -- A better fix is to use binder directly but with the TopLevel
 	    -- tag (or Exported tag) modified.
-            fake_binder = mkSysLocal 
-                            (getOccurrenceName binder _APPEND_ SLIT("_fsat")) 
-                            (getTheUnique binder)
-                            (getIdUniType binder) 
-                            mkUnknownSrcLoc
-	    rec_body = mkCoLam non_static_args 
-	                       ( CoLet (CoNonRec fake_binder nonrec_rhs)
-	                         {-in-} (dropArgs rhs))
+	    fake_binder = mkSysLocal
+			    (getOccurrenceName binder _APPEND_ SLIT("_fsat"))
+			    (getItsUnique binder)
+			    (idType binder)
+			    mkUnknownSrcLoc
+	    rec_body = mkValLam non_static_args
+			       ( Let (NonRec fake_binder nonrec_rhs)
+				 {-in-} (dropArgs rhs))
 	in
 	returnSAT (
-	    origLams (CoLet (CoRec [(binder',rec_body)]) {-in-} local_body)
+	    origLams (Let (Rec [(binder',rec_body)]) {-in-} local_body)
 	)
       where
 	origLams = origLams' rhs
-	         where 
-	           origLams' (CoLam v e)     e' = mkCoLam v  (origLams' e e')
-	           origLams' (CoTyLam ty e)  e' = CoTyLam ty (origLams' e e')
-	           origLams' _		     e' = e'
+		 where
+		   origLams' (Lam v e)     e' = Lam   v  (origLams' e e')
+		   origLams' (CoTyLam ty e)  e' = CoTyLam ty (origLams' e e')
+		   origLams' _		     e' = e'
 
     new_ty tyargs args
-      = instantiateTy (mk_inst_tyenv tyargs tv_tmpl) 
+      = instantiateTy (mk_inst_tyenv tyargs tv_tmpl)
 		      (mkSigmaTy tv_tmpl' dict_tys' tau_ty')
       where
 	-- get type info for the local function:
-	(tv_tmpl, dict_tys, tau_ty) = (splitType . getIdUniType) binder
+	(tv_tmpl, dict_tys, tau_ty) = (splitSigmaTy . idType) binder
 	(reg_arg_tys, res_type)	    = splitTyArgs tau_ty
 
 	-- now, we drop the ones that are
diff --git a/ghc/compiler/simplCore/SetLevels.hi b/ghc/compiler/simplCore/SetLevels.hi
deleted file mode 100644
index 8f09991630..0000000000
--- a/ghc/compiler/simplCore/SetLevels.hi
+++ /dev/null
@@ -1,16 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface SetLevels where
-import CmdLineOpts(GlobalSwitch)
-import CoreSyn(CoreBinding)
-import Id(Id)
-import Outputable(Outputable)
-import SplitUniq(SplitUniqSupply)
-data Level   = Level Int Int | Top
-incMinorLvl :: Level -> Level
-isTopLvl :: Level -> Bool
-ltLvl :: Level -> Level -> Bool
-ltMajLvl :: Level -> Level -> Bool
-setLevels :: [CoreBinding Id Id] -> (GlobalSwitch -> Bool) -> SplitUniqSupply -> [CoreBinding (Id, Level) Id]
-tOP_LEVEL :: Level
-instance Outputable Level
-
diff --git a/ghc/compiler/simplCore/SetLevels.lhs b/ghc/compiler/simplCore/SetLevels.lhs
index e9a0336ef6..32453a0a25 100644
--- a/ghc/compiler/simplCore/SetLevels.lhs
+++ b/ghc/compiler/simplCore/SetLevels.lhs
@@ -1,5 +1,5 @@
 %
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
 %
 \section{SetLevels}
 
@@ -15,35 +15,28 @@ will have a fighting chance of being floated sensible.
 module SetLevels (
 	setLevels,
 
-	Level(..), tOP_LEVEL, 
-	
+	Level(..), tOP_LEVEL,
+
 	incMinorLvl, ltMajLvl, ltLvl, isTopLvl
 -- not exported: , incMajorLvl, isTopMajLvl, unTopify
     ) where
 
-import PlainCore
-
-
-import AbsUniType	( isPrimType, isLeakFreeType, mkTyVarTy, 
+import Type		( isPrimType, isLeakFreeType, mkTyVarTy,
 		 	  quantifyTy, TyVarTemplate -- Needed for quantifyTy
 			)
 import AnnCoreSyn
-import BasicLit		( BasicLit(..) )
+import Literal		( Literal(..) )
 import CmdLineOpts	( GlobalSwitch(..) )
 import FreeVars
-import Id		( mkSysLocal, getIdUniType, eqId,
+import Id		( mkSysLocal, idType, eqId,
 			  isBottomingId, toplevelishId, DataCon(..)
 			  IF_ATTACK_PRAGMAS(COMMA bottomIsGuaranteed)
 			)
-import IdEnv
 import Maybes		( Maybe(..) )
 import Pretty		-- debugging only
-import PrimKind		( PrimKind(..) )
 import UniqSet
 import SrcLoc		( mkUnknownSrcLoc, SrcLoc )
-import TyVarEnv
-import SplitUniq
-import Unique
+import UniqSupply
 import Util
 \end{code}
 
@@ -61,7 +54,7 @@ data Level = Level
 
 	   | Top	-- Means *really* the top level.
 \end{code}
-		
+
 The {\em level number} on a (type-)lambda-bound variable is the
 nesting depth of the (type-)lambda which binds it.  On an expression, it's the
 maximum level number of its free (type-)variables.  On a let(rec)-bound
@@ -80,15 +73,15 @@ Level 0 0 will make something get floated to a top-level "equals", @Top@
 makes it go right to the top.
 
 The main function @lvlExpr@ carries a ``context level'' (@ctxt_lvl@).  That's
-meant to be the level number of the enclosing binder in the final (floated) 
+meant to be the level number of the enclosing binder in the final (floated)
 program.  If the level number of a sub-expression is less than that of the
 context, then it might be worth let-binding the sub-expression so that it
-will indeed float. This context level starts at @Level 0 0@; it is never @Top@.  
+will indeed float. This context level starts at @Level 0 0@; it is never @Top@.
 
 \begin{code}
-type LevelledExpr  = CoreExpr	 (Id, Level) Id
-type LevelledAtom  = CoreAtom    Id
-type LevelledBind  = CoreBinding (Id, Level) Id
+type LevelledExpr  = GenCoreExpr	 (Id, Level) Id
+type LevelledAtom  = GenCoreAtom    Id
+type LevelledBind  = GenCoreBinding (Id, Level) Id
 
 type LevelEnvs = (IdEnv    Level, -- bind Ids to levels
 		  TyVarEnv Level) -- bind type variables to levels
@@ -106,14 +99,14 @@ incMinorLvl (Level major minor) = Level major (minor+1)
 maxLvl :: Level -> Level -> Level
 maxLvl Top l2 = l2
 maxLvl l1 Top = l1
-maxLvl l1@(Level maj1 min1) l2@(Level maj2 min2) 
+maxLvl l1@(Level maj1 min1) l2@(Level maj2 min2)
   | (maj1 > maj2) || (maj1 == maj2 && min1 > min2) = l1
   | otherwise					   = l2
 
 ltLvl :: Level -> Level -> Bool
 ltLvl l1  		Top               = False
 ltLvl Top 		(Level _ _)       = True
-ltLvl (Level maj1 min1) (Level maj2 min2) = (maj1 < maj2) || 
+ltLvl (Level maj1 min1) (Level maj2 min2) = (maj1 < maj2) ||
 					    (maj1 == maj2 && min1 < min2)
 
 ltMajLvl :: Level -> Level -> Bool	-- Tells if one level belongs to a difft
@@ -121,7 +114,7 @@ ltMajLvl :: Level -> Level -> Bool	-- Tells if one level belongs to a difft
 ltMajLvl l1  		Top            = False
 ltMajLvl Top		(Level 0 _)    = False
 ltMajLvl Top 		(Level _ _)    = True
-ltMajLvl (Level maj1 _) (Level maj2 _) = maj1 < maj2		
+ltMajLvl (Level maj1 _) (Level maj2 _) = maj1 < maj2
 
 isTopLvl :: Level -> Bool
 isTopLvl Top   = True
@@ -147,9 +140,9 @@ instance Outputable Level where
 %************************************************************************
 
 \begin{code}
-setLevels :: [PlainCoreBinding]
+setLevels :: [CoreBinding]
 	  -> (GlobalSwitch -> Bool)	 -- access to all global cmd-line opts
-	  -> SplitUniqSupply
+	  -> UniqSupply
 	  -> [LevelledBind]
 
 setLevels binds sw us
@@ -158,7 +151,7 @@ setLevels binds sw us
     -- "do_them"'s main business is to thread the monad along
     -- It gives each top binding the same empty envt, because
     -- things unbound in the envt have level number zero implicitly
-    do_them :: [PlainCoreBinding] -> LvlM [LevelledBind]
+    do_them :: [CoreBinding] -> LvlM [LevelledBind]
 
     do_them [] = returnLvl []
     do_them (b:bs)
@@ -169,19 +162,19 @@ setLevels binds sw us
 initial_envs = (nullIdEnv, nullTyVarEnv)
 
 -- OLDER:
-lvlTopBind (CoNonRec binder rhs) 
+lvlTopBind (NonRec binder rhs)
   = lvlBind (Level 0 0) initial_envs (AnnCoNonRec binder (freeVars rhs))
 					-- Rhs can have no free vars!
 
-lvlTopBind (CoRec pairs)
+lvlTopBind (Rec pairs)
   = lvlBind (Level 0 0) initial_envs (AnnCoRec [(b,freeVars rhs) | (b,rhs) <- pairs])
 
 {- NEWER: Too bad about the types: WDP:
-lvlTopBind (CoNonRec binder rhs) 
+lvlTopBind (NonRec binder rhs)
   = {-SIGH:wrong type: ASSERT(isEmptyUniqSet (freeVarsOf rhs))-} -- Rhs can have no free vars!
     lvlBind (Level 0 0) initial_envs (AnnCoNonRec binder emptyUniqSet)
 
-lvlTopBind (CoRec pairs)
+lvlTopBind (Rec pairs)
   = lvlBind (Level 0 0) initial_envs
 	(AnnCoRec [(b, emptyUniqSet)
 		  | (b, rhs) <- pairs,
@@ -211,9 +204,9 @@ lvlBind ctxt_lvl envs@(venv, tenv) (AnnCoNonRec name rhs)
     let
 	new_envs = (addOneToIdEnv venv name final_lvl, tenv)
     in
-    returnLvl ([CoNonRec (name, final_lvl) rhs'], new_envs)
+    returnLvl ([NonRec (name, final_lvl) rhs'], new_envs)
   where
-    ty = getIdUniType name
+    ty = idType name
 
 
 lvlBind ctxt_lvl envs@(venv, tenv) (AnnCoRec pairs)
@@ -223,7 +216,7 @@ lvlBind ctxt_lvl envs@(venv, tenv) (AnnCoRec pairs)
 	binders_w_lvls = binders `zip` repeat final_lvl
 	new_envs       = (growIdEnvList venv binders_w_lvls, tenv)
     in
-    returnLvl (extra_binds ++ [CoRec (binders_w_lvls `zip` rhss')], new_envs)
+    returnLvl (extra_binds ++ [Rec (binders_w_lvls `zip` rhss')], new_envs)
   where
     (binders,rhss) = unzip pairs
 \end{code}
@@ -259,22 +252,22 @@ don't want @lvlExpr@ to turn the scrutinee of the @case@ into an MFE
 If there were another lambda in @r@'s rhs, it would get level-2 as well.
 
 \begin{code}
-lvlExpr _ _ (_, AnnCoVar v)     	  = returnLvl (CoVar v)
-lvlExpr _ _ (_, AnnCoLit l) 	  = returnLvl (CoLit l)
-lvlExpr _ _ (_, AnnCoCon con tys atoms) = returnLvl (CoCon con tys atoms)
-lvlExpr _ _ (_, AnnCoPrim op tys atoms) = returnLvl (CoPrim op tys atoms)
+lvlExpr _ _ (_, AnnCoVar v)     	  = returnLvl (Var v)
+lvlExpr _ _ (_, AnnCoLit l) 	  = returnLvl (Lit l)
+lvlExpr _ _ (_, AnnCoCon con tys atoms) = returnLvl (Con con tys atoms)
+lvlExpr _ _ (_, AnnCoPrim op tys atoms) = returnLvl (Prim op tys atoms)
 
-lvlExpr ctxt_lvl envs@(venv, tenv) (_, AnnCoTyApp expr ty) 
+lvlExpr ctxt_lvl envs@(venv, tenv) (_, AnnCoTyApp expr ty)
   = lvlExpr ctxt_lvl envs expr		`thenLvl` \ expr' ->
     returnLvl (CoTyApp expr' ty)
 
 lvlExpr ctxt_lvl envs@(venv, tenv) (_, AnnCoApp fun arg)
   = lvlExpr ctxt_lvl envs fun		`thenLvl` \ fun' ->
-    returnLvl (CoApp fun' arg)
+    returnLvl (App fun' arg)
 
 lvlExpr ctxt_lvl envs (_, AnnCoSCC cc expr)
   = lvlExpr ctxt_lvl envs expr 		`thenLvl` \ expr' ->
-    returnLvl (CoSCC cc expr')
+    returnLvl (SCC cc expr')
 
 lvlExpr ctxt_lvl (venv, tenv) (_, AnnCoTyLam tyvar e)
   = lvlExpr incd_lvl (venv, new_tenv) e	`thenLvl` \ e' ->
@@ -282,51 +275,31 @@ lvlExpr ctxt_lvl (venv, tenv) (_, AnnCoTyLam tyvar e)
   where
     incd_lvl = incMinorLvl ctxt_lvl
     new_tenv = addOneToTyVarEnv tenv tyvar incd_lvl
-    
-{- if we were splitting lambdas:
-lvlExpr ctxt_lvl envs@(venv, tenv) (_, AnnCoLam [arg] rhs)
-  = lvlMFE incd_lvl (new_venv, tenv) rhs	`thenLvl` \ rhs' ->
-    returnLvl (CoLam arg_w_lvl rhs')
-  where
-    incd_lvl    = incMajorLvl ctxt_lvl
-    arg_w_lvl   = [(arg, incd_lvl)]
-    new_venv    = growIdEnvList venv arg_w_lvl
-
-lvlExpr ctxt_lvl envs@(venv, tenv) (_, AnnCoLam (a:args) rhs)
-  = lvlExpr incd_lvl (new_venv, tenv) (AnnCoLam args rhs) `thenLvl` \ rhs' ->
-    -- don't use mkCoLam!
-    returnLvl (CoLam arg_w_lvl rhs')
-  where
-    incd_lvl    = incMajorLvl ctxt_lvl
-    arg_w_lvl   = [(a,incd_lvl)]
-    new_venv    = growIdEnvList venv arg_w_lvl
--}
-      
-lvlExpr ctxt_lvl envs@(venv, tenv) (_, AnnCoLam args rhs)
-  = lvlMFE incd_lvl (new_venv, tenv) rhs	`thenLvl` \ rhs' ->
-    returnLvl (CoLam args_w_lvls rhs')
+
+lvlExpr ctxt_lvl envs@(venv, tenv) (_, AnnCoLam arg rhs)
+  = lvlMFE incd_lvl (new_venv, tenv) rhs `thenLvl` \ rhs' ->
+    returnLvl (Lam (arg,incd_lvl) rhs')
   where
-    incd_lvl    = incMajorLvl ctxt_lvl
-    args_w_lvls = [ (a, incd_lvl) | a <- args ]
-    new_venv    = growIdEnvList venv args_w_lvls
+    incd_lvl = incMajorLvl ctxt_lvl
+    new_venv = growIdEnvList venv [(arg,incd_lvl)]
 
 lvlExpr ctxt_lvl envs (_, AnnCoLet bind body)
   = lvlBind ctxt_lvl envs bind		`thenLvl` \ (binds', new_envs) ->
     lvlExpr ctxt_lvl new_envs body	`thenLvl` \ body' ->
-    returnLvl (foldr CoLet body' binds') -- mkCoLet* requires PlainCore...
+    returnLvl (foldr Let body' binds') -- mkCoLet* requires Core...
 
 lvlExpr ctxt_lvl envs@(venv, tenv) (_, AnnCoCase expr alts)
   = lvlMFE ctxt_lvl envs expr	`thenLvl` \ expr' ->
     lvl_alts alts		`thenLvl` \ alts' ->
-    returnLvl (CoCase expr' alts')
+    returnLvl (Case expr' alts')
     where
-      expr_type = typeOfCoreExpr (deAnnotate expr)
+      expr_type = coreExprType (deAnnotate expr)
       incd_lvl  = incMinorLvl ctxt_lvl
 
       lvl_alts (AnnCoAlgAlts alts deflt)
 	= mapLvl lvl_alt alts	`thenLvl` \ alts' ->
 	  lvl_deflt deflt	`thenLvl` \ deflt' ->
-	  returnLvl (CoAlgAlts alts' deflt')
+	  returnLvl (AlgAlts alts' deflt')
 	where
 	  lvl_alt (con, bs, e)
 	    = let
@@ -339,20 +312,20 @@ lvlExpr ctxt_lvl envs@(venv, tenv) (_, AnnCoCase expr alts)
       lvl_alts (AnnCoPrimAlts alts deflt)
 	= mapLvl lvl_alt alts	`thenLvl` \ alts' ->
 	  lvl_deflt deflt	`thenLvl` \ deflt' ->
-	  returnLvl (CoPrimAlts alts' deflt')
+	  returnLvl (PrimAlts alts' deflt')
 	where
-	  lvl_alt (lit, e) 
+	  lvl_alt (lit, e)
 	    = lvlMFE incd_lvl envs e `thenLvl` \ e' ->
 	      returnLvl (lit, e')
 
-      lvl_deflt AnnCoNoDefault = returnLvl CoNoDefault
+      lvl_deflt AnnCoNoDefault = returnLvl NoDefault
 
       lvl_deflt (AnnCoBindDefault b expr)
 	= let
 	      new_envs = (addOneToIdEnv venv b incd_lvl, tenv)
 	  in
 	  lvlMFE incd_lvl new_envs expr `thenLvl` \ expr' ->
-	  returnLvl (CoBindDefault (b, incd_lvl) expr')
+	  returnLvl (BindDefault (b, incd_lvl) expr')
 \end{code}
 
 @lvlMFE@ is just like @lvlExpr@, except that it might let-bind
@@ -373,8 +346,8 @@ lvlMFE ctxt_lvl envs@(venv,_) ann_expr
 	ctxt_lvl envs ann_expr ty	`thenLvl` \ (final_lvl, expr') ->
     returnLvl expr'
   where
-    ty = typeOfCoreExpr (deAnnotate ann_expr)
-\end{code}	
+    ty = coreExprType (deAnnotate ann_expr)
+\end{code}
 
 
 %************************************************************************
@@ -387,41 +360,41 @@ lvlMFE ctxt_lvl envs@(venv,_) ann_expr
 are being created as let-bindings
 
 Decision tree:
-Let Bound? 
+Let Bound?
   YES. -> (a) try abstracting type variables.
        If we abstract type variables it will go further, that is, past more
        lambdas. same as asking if the level number given by the free
-       variables is less than the level number given by free variables 
+       variables is less than the level number given by free variables
        and type variables together.
-       Abstract offending type variables, e.g. 
+       Abstract offending type variables, e.g.
        change f ty a b
        to let v = /\ty' -> f ty' a b
-          in v ty
+	  in v ty
        so that v' is not stopped by the level number of ty
        tag the original let with its level number
        (from its variables and type variables)
-  NO.  is a WHNF? 
-         YES. -> No point in let binding to float a WHNF.
-                 Pin (leave) expression here.
-         NO. -> Will float past a lambda? 
-                (check using free variables only, not type variables)  
-                  YES. -> do the same as (a) above.
-                  NO. -> No point in let binding if it is not going anywhere
-                         Pin (leave) expression here.
+  NO.  is a WHNF?
+	 YES. -> No point in let binding to float a WHNF.
+		 Pin (leave) expression here.
+	 NO. -> Will float past a lambda?
+		(check using free variables only, not type variables)
+		  YES. -> do the same as (a) above.
+		  NO. -> No point in let binding if it is not going anywhere
+			 Pin (leave) expression here.
 
 \begin{code}
 setFloatLevel :: Bool			-- True <=> the expression is already let-bound
 					-- False <=> it's a possible MFE
 	      -> Level 			-- of context
-	      -> LevelEnvs 
+	      -> LevelEnvs
 
 	      -> CoreExprWithFVs	-- Original rhs
-	      -> UniType 		-- Type of rhs
+	      -> Type 		-- Type of rhs
 
 	      -> LvlM (Level, 		-- Level to attribute to this let-binding
 		       LevelledExpr)	-- Final rhs
 
-setFloatLevel alreadyLetBound ctxt_lvl envs@(venv, tenv) 
+setFloatLevel alreadyLetBound ctxt_lvl envs@(venv, tenv)
 	      expr@(FVInfo fvs tfvs might_leak, _) ty
 -- Invariant: ctxt_lvl is never = Top
 -- Beautiful ASSERT, dudes (WDP 95/04)...
@@ -440,9 +413,9 @@ setFloatLevel alreadyLetBound ctxt_lvl envs@(venv, tenv)
 -- If this gives any problems we could restrict the idea to things destined
 -- for top level.
 
-  | not alreadyLetBound 
+  | not alreadyLetBound
     && (manifestly_whnf || not will_float_past_lambda)
-  =   -- Pin whnf non-let-bound expressions, 
+  =   -- Pin whnf non-let-bound expressions,
       -- or ones which aren't going anywhere useful
     lvlExpr ctxt_lvl envs expr        `thenLvl` \ expr' ->
     returnLvl (ctxt_lvl, expr')
@@ -454,9 +427,9 @@ setFloatLevel alreadyLetBound ctxt_lvl envs@(venv, tenv)
     returnLvl (maybe_unTopify expr_lvl, expr')
 
   | otherwise -- This will create a let anyway, even if there is no
-              -- type variable to abstract, so we try to abstract anyway
-  = abstractWrtTyVars offending_tyvars ty envs lvl_after_ty_abstr expr  
-                                              `thenLvl` \ final_expr ->
+	      -- type variable to abstract, so we try to abstract anyway
+  = abstractWrtTyVars offending_tyvars ty envs lvl_after_ty_abstr expr
+					      `thenLvl` \ final_expr ->
     returnLvl (expr_lvl, final_expr)
       -- OLD LIE: The body of the let, just a type application, isn't worth floating
       --          so pin it with ctxt_lvl
@@ -471,17 +444,17 @@ setFloatLevel alreadyLetBound ctxt_lvl envs@(venv, tenv)
     lvl_after_ty_abstr = ids_only_lvl --`maxLvl` non_offending_tyvars_lvl
 
     will_float_past_lambda = 	-- Will escape lambda if let-bound
-			    ids_only_lvl `ltMajLvl` ctxt_lvl	
+			    ids_only_lvl `ltMajLvl` ctxt_lvl
 
-    worth_type_abstraction = -- Will escape (more) lambda(s)/type lambda(s) 
-                             -- if type abstracted
+    worth_type_abstraction = -- Will escape (more) lambda(s)/type lambda(s)
+			     -- if type abstracted
       (ids_only_lvl `ltLvl` tyvars_only_lvl)
       && not (is_trivial de_ann_expr) -- avoids abstracting trivial type applications
 
     de_ann_expr = deAnnotate expr
 
     is_trivial (CoTyApp e _) = is_trivial e
-    is_trivial (CoVar _)     = True
+    is_trivial (Var _)     = True
     is_trivial _             = False
 
     offending_tyvars = filter offending tv_list
@@ -495,30 +468,30 @@ setFloatLevel alreadyLetBound ctxt_lvl envs@(venv, tenv)
     maybe_unTopify Top | not (canFloatToTop (ty, expr)) = Level 0 0
     maybe_unTopify lvl                                  = lvl
 	{- ToDo [Andre]: the line above (maybe) should be Level 1 0,
-        -- so that the let will not go past the *last* lambda if it can
-        -- generate a space leak. If it is already in major level 0
-        -- It won't do any harm to give it a Level 1 0.
-        -- we should do the same test not only for things with level Top,
-        -- but also for anything that gets a major level 0.
-           the problem is that 
-           f = \a -> let x = [1..1000]
-                     in zip a x
-           ==> 
-           f = let x = [1..1000]
-               in \a -> zip a x 
-           is just as bad as floating x to the top level.
-           Notice it would be OK in cases like
-           f = \a -> let x = [1..1000]
-                         y = length x
-                     in a + y
-           ==>
-           f = let x = [1..1000]
-                   y = length x
-               in \a -> a + y
-           as x will be gc'd after y is updated.
-           [We did not hit any problems with the above (Level 0 0) code
-            in nofib benchmark]
-        -}
+	-- so that the let will not go past the *last* lambda if it can
+	-- generate a space leak. If it is already in major level 0
+	-- It won't do any harm to give it a Level 1 0.
+	-- we should do the same test not only for things with level Top,
+	-- but also for anything that gets a major level 0.
+	   the problem is that
+	   f = \a -> let x = [1..1000]
+		     in zip a x
+	   ==>
+	   f = let x = [1..1000]
+	       in \a -> zip a x
+	   is just as bad as floating x to the top level.
+	   Notice it would be OK in cases like
+	   f = \a -> let x = [1..1000]
+			 y = length x
+		     in a + y
+	   ==>
+	   f = let x = [1..1000]
+		   y = length x
+	       in \a -> a + y
+	   as x will be gc'd after y is updated.
+	   [We did not hit any problems with the above (Level 0 0) code
+	    in nofib benchmark]
+	-}
 \end{code}
 
 Abstract wrt tyvars, by making it just as if we had seen
@@ -531,14 +504,14 @@ has no free type variables. Of course, if E has no free type
 variables, then we just return E.
 
 \begin{code}
-abstractWrtTyVars offending_tyvars ty (venv,tenv) lvl expr 
+abstractWrtTyVars offending_tyvars ty (venv,tenv) lvl expr
   = lvlExpr incd_lvl new_envs expr	`thenLvl` \ expr' ->
     newLvlVar poly_ty			`thenLvl` \ poly_var ->
     let
        poly_var_rhs     = mkCoTyLam offending_tyvars expr'
-       poly_var_binding = CoNonRec (poly_var, lvl) poly_var_rhs
-       poly_var_app     = mkCoTyApps (CoVar poly_var) (map mkTyVarTy offending_tyvars)
-       final_expr       = CoLet poly_var_binding poly_var_app -- mkCoLet* requires PlainCore
+       poly_var_binding = NonRec (poly_var, lvl) poly_var_rhs
+       poly_var_app     = mkCoTyApps (Var poly_var) (map mkTyVarTy offending_tyvars)
+       final_expr       = Let poly_var_binding poly_var_app -- mkCoLet* requires Core
     in
     returnLvl final_expr
   where
@@ -547,7 +520,7 @@ abstractWrtTyVars offending_tyvars ty (venv,tenv) lvl expr
 	-- These defns are just like those in the TyLam case of lvlExpr
     (incd_lvl, tyvar_lvls) = mapAccumL next (unTopify lvl) offending_tyvars
 
-    next lvl tyvar = (lvl1, (tyvar,lvl1)) 
+    next lvl tyvar = (lvl1, (tyvar,lvl1))
 		     where lvl1 = incMinorLvl lvl
 
     new_tenv = growTyVarEnvList tenv tyvar_lvls
@@ -560,12 +533,12 @@ Recursive definitions.  We want to transform
 	   x1 = e1
 	   ...
 	   xn = en
-	in 
+	in
 	body
 
 to
 
-	letrec 
+	letrec
 	   x1' = /\ ab -> let D' in e1
 	   ...
 	   xn' = /\ ab -> let D' in en
@@ -576,7 +549,7 @@ where ab are the tyvars pinning the defn further in than it
 need be, and D  is a bunch of simple type applications:
 
 		x1_cl = x1' ab
-		...	
+		...
 		xn_cl = xn' ab
 
 The "_cl" indicates that in D, the level numbers on the xi are the context level
@@ -584,10 +557,10 @@ number; type applications aren't worth floating.  The D' decls are
 similar:
 
 		x1_ll = x1' ab
-		...	
+		...
 		xn_ll = xn' ab
 
-but differ in their level numbers; here the ab are the newly-introduced 
+but differ in their level numbers; here the ab are the newly-introduced
 type lambdas.
 
 \begin{code}
@@ -612,17 +585,17 @@ decideRecFloatLevel ctxt_lvl envs@(venv, tenv) ids rhss
 -}
 
   | ids_only_lvl `ltLvl` tyvars_only_lvl
-  = 	-- Abstract wrt tyvars; 
+  = 	-- Abstract wrt tyvars;
 	-- offending_tyvars is definitely non-empty
 	-- (I love the ASSERT to check this...  WDP 95/02)
     let
 	-- These defns are just like those in the TyLam case of lvlExpr
        (incd_lvl, tyvar_lvls) = mapAccumL next (unTopify ids_only_lvl) offending_tyvars
 
-       next lvl tyvar = (lvl1, (tyvar,lvl1)) 
+       next lvl tyvar = (lvl1, (tyvar,lvl1))
 		     where lvl1 = incMinorLvl lvl
 
-       ids_w_incd_lvl = [(id,incd_lvl) | id <- ids] 
+       ids_w_incd_lvl = [(id,incd_lvl) | id <- ids]
        new_tenv	      = growTyVarEnvList tenv tyvar_lvls
        new_venv	      = growIdEnvList    venv ids_w_incd_lvl
        new_envs	      = (new_venv, new_tenv)
@@ -630,23 +603,23 @@ decideRecFloatLevel ctxt_lvl envs@(venv, tenv) ids rhss
     mapLvl (lvlExpr incd_lvl new_envs) rhss	`thenLvl` \ rhss' ->
     mapLvl newLvlVar poly_tys			`thenLvl` \ poly_vars ->
     let
-        ids_w_poly_vars = ids `zip` poly_vars
+	ids_w_poly_vars = ids `zip` poly_vars
 
 		-- The "d_rhss" are the right-hand sides of "D" and "D'"
 		-- in the documentation above
-        d_rhss = [ mkCoTyApps (CoVar poly_var) offending_tyvar_tys | poly_var <- poly_vars]
+	d_rhss = [ mkCoTyApps (Var poly_var) offending_tyvar_tys | poly_var <- poly_vars]
 
 		-- "local_binds" are "D'" in the documentation above
-	local_binds = zipWith CoNonRec ids_w_incd_lvl d_rhss
+	local_binds = zipWithEqual NonRec ids_w_incd_lvl d_rhss
 
-        poly_var_rhss = [ mkCoTyLam offending_tyvars (foldr CoLet rhs' local_binds)
-			| rhs' <- rhss'	-- mkCoLet* requires PlainCore...
+	poly_var_rhss = [ mkCoTyLam offending_tyvars (foldr Let rhs' local_binds)
+			| rhs' <- rhss'	-- mkCoLet* requires Core...
 			]
 
 	poly_binds  = [(poly_var, ids_only_lvl) | poly_var <- poly_vars] `zip` poly_var_rhss
-	
+
     in
-    returnLvl (ctxt_lvl, [CoRec poly_binds], d_rhss)
+    returnLvl (ctxt_lvl, [Rec poly_binds], d_rhss)
 	-- The new right-hand sides, just a type application, aren't worth floating
 	-- so pin it with ctxt_lvl
 
@@ -660,7 +633,7 @@ decideRecFloatLevel ctxt_lvl envs@(venv, tenv) ids rhss
     returnLvl (expr_lvl, [], rhss')
 
   where
-    tys  = map getIdUniType ids
+    tys  = map idType ids
 
     fvs  = unionManyUniqSets [freeVarsOf   rhs | rhs <- rhss] `minusUniqSet` mkUniqSet ids
     tfvs = unionManyUniqSets [freeTyVarsOf rhs | rhs <- rhss]
@@ -671,12 +644,12 @@ decideRecFloatLevel ctxt_lvl envs@(venv, tenv) ids rhss
     tyvars_only_lvl = foldr (maxLvl . tyvarLevel tenv) tOP_LEVEL tv_list
     expr_lvl 	    = ids_only_lvl `maxLvl` tyvars_only_lvl
 
-    offending_tyvars 
+    offending_tyvars
 	| ids_only_lvl `ltLvl` tyvars_only_lvl = filter offending tv_list
 	| otherwise 			       = []
 
     offending_tyvar_tys = map mkTyVarTy offending_tyvars
-    poly_tys 	        = [ snd (quantifyTy offending_tyvars ty) 
+    poly_tys 	        = [ snd (quantifyTy offending_tyvars ty)
 			  | ty <- tys
 			  ]
 
@@ -688,7 +661,7 @@ decideRecFloatLevel ctxt_lvl envs@(venv, tenv) ids rhss
 {- ******** OMITTED NOW
 
 isWorthFloating :: Bool		-- True <=> already let-bound
-		-> PlainCoreExpr	-- The expression
+		-> CoreExpr	-- The expression
 		-> Bool
 
 isWorthFloating alreadyLetBound expr
@@ -697,18 +670,18 @@ isWorthFloating alreadyLetBound expr
 
   | otherwise       = 	-- No point in adding a fresh let-binding for a WHNF, because
 			-- floating it isn't beneficial enough.
-		      isWorthFloatingExpr expr && 
+		      isWorthFloatingExpr expr &&
 		      not (manifestlyWHNF expr || manifestlyBottom expr)
 ********** -}
 
-isWorthFloatingExpr :: PlainCoreExpr -> Bool
-isWorthFloatingExpr (CoVar v)	        = False
-isWorthFloatingExpr (CoLit lit)		= False
-isWorthFloatingExpr (CoCon con tys [])  = False	-- Just a type application
-isWorthFloatingExpr (CoTyApp expr ty)   = isWorthFloatingExpr expr	
+isWorthFloatingExpr :: CoreExpr -> Bool
+isWorthFloatingExpr (Var v)	        = False
+isWorthFloatingExpr (Lit lit)		= False
+isWorthFloatingExpr (Con con tys [])  = False	-- Just a type application
+isWorthFloatingExpr (CoTyApp expr ty)   = isWorthFloatingExpr expr
 isWorthFloatingExpr  other		= True
 
-canFloatToTop :: (UniType, CoreExprWithFVs) -> Bool
+canFloatToTop :: (Type, CoreExprWithFVs) -> Bool
 
 canFloatToTop (ty, (FVInfo _ _ (LeakFree _), expr)) = True
 canFloatToTop (ty, (FVInfo _ _ MightLeak,    expr)) = isLeakFreeType [] ty
@@ -747,7 +720,7 @@ tyvarLevel tenv tyvar
 
 \begin{code}
 type LvlM result
-  = (GlobalSwitch -> Bool) -> SplitUniqSupply -> result
+  = (GlobalSwitch -> Bool) -> UniqSupply -> result
 
 thenLvl m k sw us
   = case splitUniqSupply us	of { (s1, s2) ->
@@ -779,11 +752,11 @@ We create a let-binding for `interesting' (non-utterly-trivial)
 applications, to give them a fighting chance of being floated.
 
 \begin{code}
-newLvlVar :: UniType -> LvlM Id
+newLvlVar :: Type -> LvlM Id
 
 newLvlVar ty sw us
   = id
   where
     id = mkSysLocal SLIT("lvl") uniq ty mkUnknownSrcLoc
-    uniq = getSUnique us
+    uniq = getUnique us
 \end{code}
diff --git a/ghc/compiler/simplCore/SimplCase.hi b/ghc/compiler/simplCore/SimplCase.hi
deleted file mode 100644
index 96c024b845..0000000000
--- a/ghc/compiler/simplCore/SimplCase.hi
+++ /dev/null
@@ -1,12 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface SimplCase where
-import BinderInfo(BinderInfo)
-import CoreSyn(CoreBinding, CoreCaseAlternatives, CoreExpr)
-import Id(Id)
-import SimplEnv(SimplEnv)
-import SimplMonad(SimplCount)
-import SplitUniq(SplitUniqSupply)
-import UniType(UniType)
-bindLargeRhs :: SimplEnv -> [(Id, BinderInfo)] -> UniType -> (SimplEnv -> SplitUniqSupply -> SimplCount -> (CoreExpr Id Id, SimplCount)) -> SplitUniqSupply -> SimplCount -> ((CoreBinding Id Id, CoreExpr (Id, BinderInfo) Id), SimplCount)
-simplCase :: SimplEnv -> CoreExpr (Id, BinderInfo) Id -> CoreCaseAlternatives (Id, BinderInfo) Id -> (SimplEnv -> CoreExpr (Id, BinderInfo) Id -> SplitUniqSupply -> SimplCount -> (CoreExpr Id Id, SimplCount)) -> UniType -> SplitUniqSupply -> SimplCount -> (CoreExpr Id Id, SimplCount)
-
diff --git a/ghc/compiler/simplCore/SimplCase.lhs b/ghc/compiler/simplCore/SimplCase.lhs
index e9f76a4078..d2cb6c5e61 100644
--- a/ghc/compiler/simplCore/SimplCase.lhs
+++ b/ghc/compiler/simplCore/SimplCase.lhs
@@ -10,25 +10,19 @@ Support code for @Simplify@.
 
 module SimplCase ( simplCase, bindLargeRhs ) where
 
-IMPORT_Trace
-import Pretty		-- these are for debugging only
-import Outputable
-
 import SimplMonad
 import SimplEnv
-import TaggedCore
-import PlainCore
 
-import AbsPrel		( getPrimOpResultInfo, PrimOpResultInfo(..), PrimOp,
+import PrelInfo		( getPrimOpResultInfo, PrimOpResultInfo(..), PrimOp,
 			  voidPrimTy, voidPrimId, mkFunTy, primOpOkForSpeculation
 			  IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
 			  IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
 			)
-import AbsUniType	( splitType, splitTyArgs, glueTyArgs,
+import Type		( splitSigmaTy, splitTyArgs, glueTyArgs,
 			  getTyConFamilySize, isPrimType,
-			  getUniDataTyCon_maybe
+			  maybeDataTyCon
 			)
-import BasicLit		( isNoRepLit, BasicLit, PrimKind )
+import Literal		( isNoRepLit, Literal )
 import CmdLineOpts	( SimplifierSwitch(..) )
 import Id
 import IdInfo
@@ -53,7 +47,7 @@ simplCase :: SimplEnv
 	  -> OutUniType				-- Type of result expression
 	  -> SmplM OutExpr
 
-simplCase env (CoLet bind body) alts rhs_c result_ty
+simplCase env (Let bind body) alts rhs_c result_ty
   | not (switchIsSet env SimplNoLetFromCase)
   = 	-- Float the let outside the case scrutinee (if not disabled by flag)
     tick LetFloatFromCase		`thenSmpl_`
@@ -86,7 +80,7 @@ by abstracting the outer rhss wrt the pattern variables.  For example
 ===>
 	let b = \ x y -> body
 	in
-	case e of 
+	case e of
 	  p1 -> case rhs1 of (x,y) -> b x y
 	  ...
 	  pn -> case rhsn of (x,y) -> b x y
@@ -103,28 +97,28 @@ All of this works equally well if the outer case has multiple rhss.
 
 
 \begin{code}
-simplCase env (CoCase inner_scrut inner_alts) outer_alts rhs_c result_ty
+simplCase env (Case inner_scrut inner_alts) outer_alts rhs_c result_ty
   | switchIsSet env SimplCaseOfCase
   = 	-- Ha!  Do case-of-case
     tick CaseOfCase	`thenSmpl_`
 
     if no_need_to_bind_large_alts
     then
-	simplCase env inner_scrut inner_alts 
+	simplCase env inner_scrut inner_alts
 		  (\env rhs -> simplCase env rhs outer_alts rhs_c result_ty) result_ty
     else
 	bindLargeAlts env outer_alts rhs_c result_ty	`thenSmpl` \ (extra_bindings, outer_alts') ->
 	let
 	   rhs_c' = \env rhs -> simplExpr env rhs []
 	in
-	simplCase env inner_scrut inner_alts 
+	simplCase env inner_scrut inner_alts
 		  (\env rhs -> simplCase env rhs outer_alts' rhs_c' result_ty)
 		  result_ty
 						`thenSmpl` \ case_expr ->
 	returnSmpl (mkCoLetsNoUnboxed extra_bindings case_expr)
 
   where
-    no_need_to_bind_large_alts = switchIsSet env SimplOkToDupCode || 
+    no_need_to_bind_large_alts = switchIsSet env SimplOkToDupCode ||
    			         isSingleton (nonErrorRHSs inner_alts)
 \end{code}
 
@@ -137,7 +131,7 @@ simplCase env scrut alts rhs_c result_ty
     tick CaseOfError 	`thenSmpl_`
     rhs_c env retyped_error_app
   where
-    alts_ty 	    	   = typeOfCoreAlts (unTagBindersAlts alts)
+    alts_ty 	    	   = coreAltsType (unTagBindersAlts alts)
     maybe_error_app 	   = maybeErrorApp scrut (Just alts_ty)
     Just retyped_error_app = maybe_error_app
 \end{code}
@@ -167,7 +161,7 @@ completeCase
 	-> SmplM OutExpr	-- The whole case expression
 \end{code}
 
-Scrutinising a literal or constructor.  
+Scrutinising a literal or constructor.
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 It's an obvious win to do:
 
@@ -184,14 +178,14 @@ need to check for the variable case separately.
 Sanity check: we don't have a good
 story to tell about case analysis on NoRep things.  ToDo.
 
-\begin{code}	
-completeCase env (CoLit lit) alts rhs_c
+\begin{code}
+completeCase env (Lit lit) alts rhs_c
   | not (isNoRepLit lit)
   = 	-- Ha!  Select the appropriate alternative
     tick KnownBranch		`thenSmpl_`
     completePrimCaseWithKnownLit env lit alts rhs_c
 
-completeCase env expr@(CoCon con tys con_args) alts rhs_c
+completeCase env expr@(Con con tys con_args) alts rhs_c
   = 	-- Ha! Staring us in the face -- select the appropriate alternative
     tick KnownBranch		`thenSmpl_`
     completeAlgCaseWithKnownCon env con tys con_args alts rhs_c
@@ -215,7 +209,7 @@ match.  For example:
 	case x of
 	  0#    -> ...
 	  other -> ...(case x of
-			 0#    -> ... 
+			 0#    -> ...
 			 other -> ...) ...
 \end{code}
 Here the inner case can be eliminated.  This really only shows up in
@@ -226,7 +220,7 @@ Lastly, we generalise the transformation to handle this:
 	case e of	===> r
 	   True  -> r
 	   False -> r
-	   
+
 We only do this for very cheaply compared r's (constructors, literals
 and variables).  If pedantic bottoms is on, we only do it when the
 scrutinee is a PrimOp which can't fail.
@@ -246,7 +240,7 @@ So the case-elimination algorithm is:
 	3. Check we can safely ditch the case:
 		   * PedanticBottoms is off,
 		or * the scrutinee is an already-evaluated variable
-		or * the scrutinee is a primop which is ok for speculation 
+		or * the scrutinee is a primop which is ok for speculation
 			-- ie we want to preserve divide-by-zero errors, and
 			-- calls to error itself!
 
@@ -267,17 +261,17 @@ If so, then we can replace the case with one of the rhss.
 completeCase env scrut alts rhs_c
   | switchIsSet env SimplDoCaseElim &&
 
-    binders_unused && 
+    binders_unused &&
 
     all_rhss_same &&
 
-    (not  (switchIsSet env SimplPedanticBottoms) || 
+    (not  (switchIsSet env SimplPedanticBottoms) ||
      scrut_is_evald ||
      scrut_is_eliminable_primitive ||
      rhs1_is_scrutinee ||
      scrut_is_var_and_single_strict_default
      )
-    
+
   = tick CaseElim 	`thenSmpl_`
     rhs_c new_env rhs1
   where
@@ -289,7 +283,7 @@ completeCase env scrut alts rhs_c
 	-- whether none of their binders are used
     (binders_unused, possible_rhss, new_env)
       = case alts of
-	  CoPrimAlts alts deflt -> (deflt_binder_unused, 	-- No binders other than deflt
+	  PrimAlts alts deflt -> (deflt_binder_unused, 	-- No binders other than deflt
 				    deflt_rhs ++ rhss,
 				    new_env)
 	    where
@@ -297,12 +291,12 @@ completeCase env scrut alts rhs_c
 
 		-- Eliminate unused rhss if poss
 	      rhss = case scrut_form of
-			OtherLiteralForm not_these -> [rhs | (alt_lit,rhs) <- alts, 
+			OtherLitForm not_these -> [rhs | (alt_lit,rhs) <- alts,
 						       not (alt_lit `is_elem` not_these)
 						      ]
 			other -> [rhs | (_,rhs) <- alts]
 
-	  CoAlgAlts alts deflt -> (deflt_binder_unused && all alt_binders_unused possible_alts,
+	  AlgAlts alts deflt -> (deflt_binder_unused && all alt_binders_unused possible_alts,
 				   deflt_rhs ++ [rhs | (_,_,rhs) <- possible_alts],
 				   new_env)
 	    where
@@ -310,14 +304,14 @@ completeCase env scrut alts rhs_c
 
 		-- Eliminate unused alts if poss
 	      possible_alts = case scrut_form of
-				OtherConstructorForm not_these ->
+				OtherConForm not_these ->
 					 	-- Remove alts which can't match
 					[alt | alt@(alt_con,_,_) <- alts,
 					       not (alt_con `is_elem` not_these)]
 
 #ifdef DEBUG
---				ConstructorForm c t v -> pprPanic "completeCase!" (ppAbove (ppCat [ppr PprDebug c, ppr PprDebug t, ppr PprDebug v]) (ppr PprDebug alts))
-				  -- ConstructorForm can't happen, since we'd have
+--				ConForm c t v -> pprPanic "completeCase!" (ppAbove (ppCat [ppr PprDebug c, ppr PprDebug t, ppr PprDebug v]) (ppr PprDebug alts))
+				  -- ConForm can't happen, since we'd have
 				  -- inlined it, and be in completeCaseWithKnownCon by now
 #endif
 				other -> alts
@@ -328,51 +322,51 @@ completeCase env scrut alts rhs_c
 
 	-- If the scrutinee is a variable, look it up to see what we know about it
     scrut_form = case scrut of
-		  CoVar v -> lookupUnfolding env v
+		  Var v -> lookupUnfolding env v
 		  other   -> NoUnfoldingDetails
 
-	-- If the scrut is already eval'd then there's no worry about 
+	-- If the scrut is already eval'd then there's no worry about
 	-- eliminating the case
     scrut_is_evald = case scrut_form of
-			OtherLiteralForm _     -> True
-			ConstructorForm _ _ _  -> True
-			OtherConstructorForm _ -> True
+			OtherLitForm _     -> True
+			ConForm _ _ _  -> True
+			OtherConForm _ -> True
 			other		       -> False
 
 
     scrut_is_eliminable_primitive
       = case scrut of
-	   CoPrim op _ _ -> primOpOkForSpeculation op
-	   CoVar _       -> case alts of
-				CoPrimAlts _ _ -> True	-- Primitive, hence non-bottom
-				CoAlgAlts _ _  -> False	-- Not primitive
+	   Prim op _ _ -> primOpOkForSpeculation op
+	   Var _       -> case alts of
+				PrimAlts _ _ -> True	-- Primitive, hence non-bottom
+				AlgAlts _ _  -> False	-- Not primitive
 	   other	 -> False
-    
+
 	-- case v of w -> e{strict in w}  ===>   e[v/w]
     scrut_is_var_and_single_strict_default
       = case scrut of
-	  CoVar _ -> case alts of 
-			CoAlgAlts [] (CoBindDefault (v,_) _) -> willBeDemanded (getIdDemandInfo v)
-		        other -> False
+	  Var _ -> case alts of
+			AlgAlts [] (BindDefault (v,_) _) -> willBeDemanded (getIdDemandInfo v)
+			other -> False
 	  other -> False
 
-    elim_deflt_binder CoNoDefault 	    		 -- No Binder
-        = (True, [], env)
-    elim_deflt_binder (CoBindDefault (id, DeadCode) rhs) -- Binder unused
+    elim_deflt_binder NoDefault 	    		 -- No Binder
+	= (True, [], env)
+    elim_deflt_binder (BindDefault (id, DeadCode) rhs) -- Binder unused
 	= (True, [rhs], env)
-    elim_deflt_binder (CoBindDefault used_binder rhs) 	 -- Binder used
+    elim_deflt_binder (BindDefault used_binder rhs) 	 -- Binder used
 	= case scrut of
-		CoVar v -> 	-- Binder used, but can be eliminated in favour of scrut
-			   (True, [rhs], extendIdEnvWithAtom env used_binder (CoVarAtom v))
+		Var v -> 	-- Binder used, but can be eliminated in favour of scrut
+			   (True, [rhs], extendIdEnvWithAtom env used_binder (VarArg v))
 		non_var -> 	-- Binder used, and can't be elimd
 			   (False, [rhs], env)
 
 	-- Check whether the chosen unique rhs (ie rhs1) is the same as
 	-- the scrutinee.  Remember that the rhs is as yet unsimplified.
     rhs1_is_scrutinee = case (scrut, rhs1) of
-			  (CoVar scrut_var, CoVar rhs_var) 
+			  (Var scrut_var, Var rhs_var)
 				-> case lookupId env rhs_var of
-				    Just (ItsAnAtom (CoVarAtom rhs_var')) 
+				    Just (ItsAnAtom (VarArg rhs_var'))
 					-> rhs_var' == scrut_var
 				    other -> False
 			  other -> False
@@ -383,7 +377,7 @@ completeCase env scrut alts rhs_c
 Scrutinising anything else.  If it's a variable, it can't be bound to a
 constructor or literal, because that would have been inlined
 
-\begin{code}	
+\begin{code}
 completeCase env scrut alts rhs_c
   = simplAlts env scrut alts rhs_c	`thenSmpl` \ alts' ->
     mkCoCase scrut alts'
@@ -393,41 +387,41 @@ completeCase env scrut alts rhs_c
 
 
 \begin{code}
-bindLargeAlts :: SimplEnv 
-	      -> InAlts 
+bindLargeAlts :: SimplEnv
+	      -> InAlts
 	      -> (SimplEnv -> InExpr -> SmplM OutExpr)		-- Old rhs handler
 	      -> OutUniType					-- Result type
 	      -> SmplM ([OutBinding],	-- Extra bindings
 			InAlts)		-- Modified alts
 
-bindLargeAlts env the_lot@(CoAlgAlts alts deflt) rhs_c rhs_ty
+bindLargeAlts env the_lot@(AlgAlts alts deflt) rhs_c rhs_ty
   = mapAndUnzipSmpl do_alt alts			`thenSmpl` \ (alt_bindings, alts') ->
     bindLargeDefault env deflt rhs_ty rhs_c	`thenSmpl` \ (deflt_bindings, deflt') ->
-    returnSmpl (deflt_bindings ++ alt_bindings, CoAlgAlts alts' deflt')
+    returnSmpl (deflt_bindings ++ alt_bindings, AlgAlts alts' deflt')
   where
-    do_alt (con,args,rhs) = bindLargeRhs env args rhs_ty 
+    do_alt (con,args,rhs) = bindLargeRhs env args rhs_ty
 				(\env -> rhs_c env rhs) `thenSmpl` \ (bind,rhs') ->
 			    returnSmpl (bind, (con,args,rhs'))
 
-bindLargeAlts env the_lot@(CoPrimAlts alts deflt) rhs_c rhs_ty
+bindLargeAlts env the_lot@(PrimAlts alts deflt) rhs_c rhs_ty
   = mapAndUnzipSmpl do_alt alts			`thenSmpl` \ (alt_bindings, alts') ->
     bindLargeDefault env deflt rhs_ty rhs_c	`thenSmpl` \ (deflt_bindings, deflt') ->
-    returnSmpl (deflt_bindings ++ alt_bindings, CoPrimAlts alts' deflt')
+    returnSmpl (deflt_bindings ++ alt_bindings, PrimAlts alts' deflt')
   where
     do_alt (lit,rhs) = bindLargeRhs env [] rhs_ty
 				(\env -> rhs_c env rhs) `thenSmpl` \ (bind,rhs') ->
 		       returnSmpl (bind, (lit,rhs'))
 
-bindLargeDefault env CoNoDefault rhs_ty rhs_c
-  = returnSmpl ([], CoNoDefault)
-bindLargeDefault env (CoBindDefault binder rhs) rhs_ty rhs_c
-  = bindLargeRhs env [binder] rhs_ty 
+bindLargeDefault env NoDefault rhs_ty rhs_c
+  = returnSmpl ([], NoDefault)
+bindLargeDefault env (BindDefault binder rhs) rhs_ty rhs_c
+  = bindLargeRhs env [binder] rhs_ty
 		 (\env -> rhs_c env rhs) `thenSmpl` \ (bind,rhs') ->
-    returnSmpl ([bind], CoBindDefault binder rhs')
+    returnSmpl ([bind], BindDefault binder rhs')
 \end{code}
 
 	bindLargeRhs env [x1,..,xn] rhs rhs_ty rhs_c
-	 | otherwise        = (rhs_id = \x1..xn -> rhs_c rhs, 
+	 | otherwise        = (rhs_id = \x1..xn -> rhs_c rhs,
 			       rhs_id x1 .. xn)
 
 \begin{code}
@@ -445,7 +439,7 @@ bindLargeRhs env args rhs_ty rhs_c
 	-- with potentially-disastrous strictness results.  So
 	-- instead we turn it into a function: \v -> e
 	-- where v::VoidPrim.  Since arguments of type
-	-- VoidPrim don't generate any code, this gives the 
+	-- VoidPrim don't generate any code, this gives the
 	-- desired effect.
 	--
 	-- The general structure is just the same as for the common "otherwise~ case
@@ -453,8 +447,8 @@ bindLargeRhs env args rhs_ty rhs_c
     newId voidPrimTy		`thenSmpl` \ void_arg_id ->
     rhs_c env 			`thenSmpl` \ prim_new_body ->
 
-    returnSmpl (CoNonRec prim_rhs_fun_id (mkCoLam [void_arg_id] prim_new_body),
-	        CoApp (CoVar prim_rhs_fun_id) (CoVarAtom voidPrimId))
+    returnSmpl (NonRec prim_rhs_fun_id (mkValLam [void_arg_id] prim_new_body),
+		App (Var prim_rhs_fun_id) (VarArg voidPrimId))
 
   | otherwise
   = 	-- Make the new binding Id.  NB: it's an OutId
@@ -470,20 +464,20 @@ bindLargeRhs env args rhs_ty rhs_c
 	final_rhs
 	  = (if switchIsSet new_env SimplDoEtaReduction
 	     then mkCoLamTryingEta
-	     else mkCoLam) used_args' rhs'
+	     else mkValLam) used_args' rhs'
     in
-    returnSmpl (CoNonRec rhs_fun_id final_rhs,
-		foldl CoApp (CoVar rhs_fun_id) used_arg_atoms)
+    returnSmpl (NonRec rhs_fun_id final_rhs,
+		foldl App (Var rhs_fun_id) used_arg_atoms)
 	-- This is slightly wierd. We're retuning an OutId as part of the
 	-- modified rhs, which is meant to be an InExpr. However, that's ok, because when
 	-- it's processed the OutId won't be found in the environment, so it
 	-- will be left unmodified.
   where
     rhs_fun_ty :: OutUniType
-    rhs_fun_ty = glueTyArgs [simplTy env (getIdUniType id) | (id,_) <- used_args] rhs_ty
+    rhs_fun_ty = glueTyArgs [simplTy env (idType id) | (id,_) <- used_args] rhs_ty
 
     used_args      = [arg | arg@(_,usage) <- args, not (dead usage)]
-    used_arg_atoms = [CoVarAtom arg_id | (arg_id,_) <- used_args]
+    used_arg_atoms = [VarArg arg_id | (arg_id,_) <- used_args]
     dead DeadCode  = True
     dead other     = False
 
@@ -502,45 +496,45 @@ case x of
 it is best to make sure that \tr{default_e} mentions \tr{x} in
 preference to \tr{y}.  The code generator can do a cheaper job if it
 doesn't have to come up with a binding for \tr{y}.
-          
+
 \begin{code}
 simplAlts :: SimplEnv
 	  -> OutExpr			-- Simplified scrutinee;
-					-- only of interest if its a var, 
+					-- only of interest if its a var,
 					-- in which case we record its form
-	  -> InAlts 
+	  -> InAlts
 	  -> (SimplEnv -> InExpr -> SmplM OutExpr)	-- Rhs handler
 	  -> SmplM OutAlts
 
-simplAlts env scrut (CoAlgAlts alts deflt) rhs_c
+simplAlts env scrut (AlgAlts alts deflt) rhs_c
   = mapSmpl do_alt alts					`thenSmpl` \ alts' ->
     simplDefault env scrut deflt deflt_form rhs_c	`thenSmpl` \ deflt' ->
-    returnSmpl (CoAlgAlts alts' deflt')
+    returnSmpl (AlgAlts alts' deflt')
   where
-    deflt_form = OtherConstructorForm [con | (con,_,_) <- alts]
+    deflt_form = OtherConForm [con | (con,_,_) <- alts]
     do_alt (con, con_args, rhs)
       = cloneIds env con_args				`thenSmpl` \ con_args' ->
 	let
 	    env1    = extendIdEnvWithClones env con_args con_args'
-	    new_env = case scrut of 
-		       CoVar var -> _scc_ "euegC1" (extendUnfoldEnvGivenConstructor env1 var con con_args')
+	    new_env = case scrut of
+		       Var var -> _scc_ "euegC1" (extendUnfoldEnvGivenConstructor env1 var con con_args')
 		       other     -> env1
-        in
+	in
 	rhs_c new_env rhs 				`thenSmpl` \ rhs' ->
 	returnSmpl (con, con_args', rhs')
 
-simplAlts env scrut (CoPrimAlts alts deflt) rhs_c
+simplAlts env scrut (PrimAlts alts deflt) rhs_c
   = mapSmpl do_alt alts					`thenSmpl` \ alts' ->
     simplDefault env scrut deflt deflt_form rhs_c	`thenSmpl` \ deflt' ->
-    returnSmpl (CoPrimAlts alts' deflt')
+    returnSmpl (PrimAlts alts' deflt')
   where
-    deflt_form = OtherLiteralForm [lit | (lit,_) <- alts]
+    deflt_form = OtherLitForm [lit | (lit,_) <- alts]
     do_alt (lit, rhs)
       = let
 	    new_env = case scrut of
-			CoVar var -> _scc_ "euegFD1" (extendUnfoldEnvGivenFormDetails env var (LiteralForm lit))
+			Var var -> _scc_ "euegFD1" (extendUnfoldEnvGivenFormDetails env var (LitForm lit))
 			other	  -> env
-        in
+	in
 	rhs_c new_env rhs 				`thenSmpl` \ rhs' ->
 	returnSmpl (lit, rhs')
 \end{code}
@@ -577,25 +571,25 @@ simplDefault
 	-> OutExpr			-- Simplified scrutinee
 	-> InDefault 			-- Default alternative to be completed
 	-> UnfoldingDetails		-- Gives form of scrutinee
-        -> (SimplEnv -> InExpr -> SmplM OutExpr)		-- Old rhs handler
+	-> (SimplEnv -> InExpr -> SmplM OutExpr)		-- Old rhs handler
 	-> SmplM OutDefault
 
-simplDefault env scrut CoNoDefault form rhs_c
-  = returnSmpl CoNoDefault
+simplDefault env scrut NoDefault form rhs_c
+  = returnSmpl NoDefault
 
 -- Special case for variable scrutinee; see notes above.
-simplDefault env (CoVar scrut_var) (CoBindDefault binder rhs) form_from_this_case rhs_c
+simplDefault env (Var scrut_var) (BindDefault binder rhs) form_from_this_case rhs_c
   = cloneId env binder 	`thenSmpl` \ binder' ->
     let
-      env1    = extendIdEnvWithAtom env binder (CoVarAtom binder')
+      env1    = extendIdEnvWithAtom env binder (VarArg binder')
 
 	-- Add form details for the default binder
       scrut_form = lookupUnfolding env scrut_var
       final_form
-        = case (form_from_this_case, scrut_form) of
-	    (OtherConstructorForm cs, OtherConstructorForm ds) -> OtherConstructorForm (cs++ds)
-	    (OtherLiteralForm cs,     OtherLiteralForm ds)     -> OtherLiteralForm (cs++ds)
-			-- ConstructorForm, LiteralForm impossible
+	= case (form_from_this_case, scrut_form) of
+	    (OtherConForm cs, OtherConForm ds) -> OtherConForm (cs++ds)
+	    (OtherLitForm cs,     OtherLitForm ds)     -> OtherLitForm (cs++ds)
+			-- ConForm, LitForm impossible
 			-- (ASSERT?  ASSERT?  Hello? WDP 95/05)
 	    other 				               -> form_from_this_case
 
@@ -603,22 +597,22 @@ simplDefault env (CoVar scrut_var) (CoBindDefault binder rhs) form_from_this_cas
 
 	-- Change unfold details for scrut var.  We now want to unfold it
 	-- to binder'
-      new_scrut_var_form = GeneralForm True {- OK to dup -} WhnfForm 
-				       (CoVar binder') UnfoldAlways
+      new_scrut_var_form = GenForm True {- OK to dup -} WhnfForm
+				       (Var binder') UnfoldAlways
       new_env    = extendUnfoldEnvGivenFormDetails env2 scrut_var new_scrut_var_form
-			
+
     in
     rhs_c new_env rhs			`thenSmpl` \ rhs' ->
-    returnSmpl (CoBindDefault binder' rhs')
+    returnSmpl (BindDefault binder' rhs')
 
-simplDefault env scrut (CoBindDefault binder rhs) form rhs_c
+simplDefault env scrut (BindDefault binder rhs) form rhs_c
   = cloneId env binder 	`thenSmpl` \ binder' ->
     let
-	env1    = extendIdEnvWithAtom env binder (CoVarAtom binder')
+	env1    = extendIdEnvWithAtom env binder (VarArg binder')
 	new_env = _scc_ "euegFD2" (extendUnfoldEnvGivenFormDetails env1 binder' form)
     in
     rhs_c new_env rhs			`thenSmpl` \ rhs' ->
-    returnSmpl (CoBindDefault binder' rhs')
+    returnSmpl (BindDefault binder' rhs')
 \end{code}
 
 Case alternatives when we know what the scrutinee is
@@ -627,15 +621,15 @@ Case alternatives when we know what the scrutinee is
 \begin{code}
 completePrimCaseWithKnownLit
 	:: SimplEnv
-	-> BasicLit
+	-> Literal
 	-> InAlts
-        -> (SimplEnv -> InExpr -> SmplM OutExpr)	-- Rhs handler
+	-> (SimplEnv -> InExpr -> SmplM OutExpr)	-- Rhs handler
 	-> SmplM OutExpr
 
-completePrimCaseWithKnownLit env lit (CoPrimAlts alts deflt) rhs_c
+completePrimCaseWithKnownLit env lit (PrimAlts alts deflt) rhs_c
   = search_alts alts
   where
-    search_alts :: [(BasicLit, InExpr)] -> SmplM OutExpr
+    search_alts :: [(Literal, InExpr)] -> SmplM OutExpr
 
     search_alts ((alt_lit, rhs) : _)
       | alt_lit == lit
@@ -644,17 +638,17 @@ completePrimCaseWithKnownLit env lit (CoPrimAlts alts deflt) rhs_c
 
     search_alts (_ : other_alts)
       = 	-- This alternative doesn't match; keep looking
-        search_alts other_alts
+	search_alts other_alts
 
     search_alts []
       = case deflt of
-	  CoNoDefault 	 -> 	-- Blargh!
+	  NoDefault 	 -> 	-- Blargh!
 	    panic "completePrimCaseWithKnownLit: No matching alternative and no default"
 
-	  CoBindDefault binder rhs ->	-- OK, there's a default case
-				        -- Just bind the Id to the atom and continue
+	  BindDefault binder rhs ->	-- OK, there's a default case
+					-- Just bind the Id to the atom and continue
 	    let
-		new_env = extendIdEnvWithAtom env binder (CoLitAtom lit)
+		new_env = extendIdEnvWithAtom env binder (LitArg lit)
 	    in
 	    rhs_c new_env rhs
 \end{code}
@@ -669,13 +663,13 @@ var [substitute \tr{y} out of existence].
 \begin{code}
 completeAlgCaseWithKnownCon
 	:: SimplEnv
-	-> DataCon -> [UniType] -> [InAtom]
+	-> DataCon -> [Type] -> [InAtom]
 		-- Scrutinee is (con, type, value arguments)
 	-> InAlts
-        -> (SimplEnv -> InExpr -> SmplM OutExpr)	-- Rhs handler
+	-> (SimplEnv -> InExpr -> SmplM OutExpr)	-- Rhs handler
 	-> SmplM OutExpr
 
-completeAlgCaseWithKnownCon env con tys con_args (CoAlgAlts alts deflt) rhs_c
+completeAlgCaseWithKnownCon env con tys con_args (AlgAlts alts deflt) rhs_c
   = ASSERT(isDataCon con)
     search_alts alts
   where
@@ -688,29 +682,29 @@ completeAlgCaseWithKnownCon env con tys con_args (CoAlgAlts alts deflt) rhs_c
 	    new_env = extendIdEnvWithAtomList env (zip alt_args con_args)
 	in
 	rhs_c new_env rhs
-	
+
     search_alts (_ : other_alts)
       = 	-- This alternative doesn't match; keep looking
-        search_alts other_alts
+	search_alts other_alts
 
     search_alts []
       = 	-- No matching alternative
 	case deflt of
-	  CoNoDefault 	 -> 	-- Blargh!
+	  NoDefault 	 -> 	-- Blargh!
 	    panic "completeAlgCaseWithKnownCon: No matching alternative and no default"
 
-	  CoBindDefault binder rhs ->	-- OK, there's a default case
+	  BindDefault binder rhs ->	-- OK, there's a default case
 			-- let-bind the binder to the constructor
 		cloneId env binder		`thenSmpl` \ id' ->
 		let
 		    env1    = extendIdEnvWithClone env binder id'
-		    new_env = _scc_ "euegFD3" (extendUnfoldEnvGivenFormDetails env1 id' 
-					(ConstructorForm con tys con_args))
+		    new_env = _scc_ "euegFD3" (extendUnfoldEnvGivenFormDetails env1 id'
+					(ConForm con tys con_args))
 		in
 		rhs_c new_env rhs		`thenSmpl` \ rhs' ->
-		returnSmpl (CoLet (CoNonRec id' (CoCon con tys con_args)) rhs')
+		returnSmpl (Let (NonRec id' (Con con tys con_args)) rhs')
 \end{code}
-							
+
 Case absorption and identity-case elimination
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 
@@ -726,10 +720,10 @@ case v of                 ==>   case v of
   pm -> rhsm                      pm -> rhsm
   d  -> case v of                 pn -> rhsn[v/d]  {or (alg)  let d=v in rhsn}
 						   {or (prim) case v of d -> rhsn}
-          pn -> rhsn              ...
-          ...                     po -> rhso[v/d]
-          po -> rhso              d  -> rhsd[d/d'] {or let d'=d in rhsd}
-          d' -> rhsd
+	  pn -> rhsn              ...
+	  ...                     po -> rhso[v/d]
+	  po -> rhso              d  -> rhsd[d/d'] {or let d'=d in rhsd}
+	  d' -> rhsd
 
 which merges two cases in one case when -- the default alternative of
 the outer case scrutises the same variable as the outer case This
@@ -743,17 +737,17 @@ case e of                 ==>   case e of
   ...	                          ...
   pm -> rhsm                      pm -> rhsm
   d  -> case d of                 pn -> let d = pn in rhsn
-          pn -> rhsn              ...
-          ...                     po -> let d = po in rhso
-          po -> rhso              d  -> rhsd[d/d'] {or let d'=d in rhsd}
-          d' -> rhsd
+	  pn -> rhsn              ...
+	  ...                     po -> let d = po in rhso
+	  po -> rhso              d  -> rhsd[d/d'] {or let d'=d in rhsd}
+	  d' -> rhsd
 
 Here, the let's are essential, because d isn't in scope any more.
 Sigh.  Of course, they may be unused, in which case they'll be
 eliminated on the next round.  Unfortunately, we can't figure out
 whether or not they are used at this juncture.
 
-NB: The binder in a CoBindDefault USED TO BE guaranteed unused if the
+NB: The binder in a BindDefault USED TO BE guaranteed unused if the
 scrutinee is a variable, because it'll be mapped to the scrutinised
 variable.  Hence the [v/d] substitions can be omitted.
 
@@ -765,21 +759,21 @@ The following code handles *both* these transformations (one
 equation for AlgAlts, one for PrimAlts):
 
 \begin{code}
-mkCoCase scrut (CoAlgAlts outer_alts 
-			  (CoBindDefault deflt_var
-					 (CoCase (CoVar scrut_var') 
-						 (CoAlgAlts inner_alts inner_deflt))))
+mkCoCase scrut (AlgAlts outer_alts
+			  (BindDefault deflt_var
+					 (Case (Var scrut_var')
+						 (AlgAlts inner_alts inner_deflt))))
   |  (scrut_is_var && scrut_var == scrut_var')	-- First transformation
   || deflt_var == scrut_var'			-- Second transformation
   = 	-- Aha! The default-absorption rule applies
     tick CaseMerge	`thenSmpl_`
-    returnSmpl (CoCase scrut (CoAlgAlts (outer_alts ++ munged_reduced_inner_alts)
+    returnSmpl (Case scrut (AlgAlts (outer_alts ++ munged_reduced_inner_alts)
 			     (munge_alg_deflt deflt_var inner_deflt)))
-	-- NB: see comment in this location for the CoPrimAlts case
+	-- NB: see comment in this location for the PrimAlts case
   where
 	-- Check scrutinee
-    scrut_is_var = case scrut of {CoVar v -> True; other -> False}
-    scrut_var    = case scrut of CoVar v -> v
+    scrut_is_var = case scrut of {Var v -> True; other -> False}
+    scrut_var    = case scrut of Var v -> v
 
 	--  Eliminate any inner alts which are shadowed by the outer ones
     reduced_inner_alts = [alt | alt@(con,_,_) <- inner_alts,
@@ -790,40 +784,40 @@ mkCoCase scrut (CoAlgAlts outer_alts
 	-- Add the lets if necessary
     munged_reduced_inner_alts = map munge_alt reduced_inner_alts
 
-    munge_alt (con, args, rhs) = (con, args, CoLet (CoNonRec deflt_var v) rhs)
+    munge_alt (con, args, rhs) = (con, args, Let (NonRec deflt_var v) rhs)
        where
-	 v | scrut_is_var = CoVar scrut_var
-	   | otherwise    = CoCon con arg_tys (map CoVarAtom args)
+	 v | scrut_is_var = Var scrut_var
+	   | otherwise    = Con con arg_tys (map VarArg args)
 
-    arg_tys = case getUniDataTyCon_maybe (getIdUniType deflt_var) of
+    arg_tys = case maybeDataTyCon (idType deflt_var) of
 		Just (_, arg_tys, _) -> arg_tys
 
-mkCoCase scrut (CoPrimAlts 
-		  outer_alts 
-		  (CoBindDefault deflt_var (CoCase 
-					      (CoVar scrut_var') 
-					      (CoPrimAlts inner_alts inner_deflt))))
+mkCoCase scrut (PrimAlts
+		  outer_alts
+		  (BindDefault deflt_var (Case
+					      (Var scrut_var')
+					      (PrimAlts inner_alts inner_deflt))))
   | (scrut_is_var && scrut_var == scrut_var') ||
     deflt_var == scrut_var'
   = 	-- Aha! The default-absorption rule applies
     tick CaseMerge	`thenSmpl_`
-    returnSmpl (CoCase scrut (CoPrimAlts (outer_alts ++ munged_reduced_inner_alts)
+    returnSmpl (Case scrut (PrimAlts (outer_alts ++ munged_reduced_inner_alts)
 			     (munge_prim_deflt deflt_var inner_deflt)))
 
 	-- Nota Bene: we don't recurse to mkCoCase again, because the
 	-- default will now have a binding in it that prevents
 	-- mkCoCase doing anything useful.  Much worse, in this
 	-- PrimAlts case the binding in the default branch is another
-	-- CoCase, so if we recurse to mkCoCase we will get into an
+	-- Case, so if we recurse to mkCoCase we will get into an
 	-- infinite loop.
-	-- 
+	--
 	-- ToDo: think of a better way to do this.  At the moment
 	-- there is at most one case merge per round.  That's probably
 	-- plenty but it seems unclean somehow.
   where
 	-- Check scrutinee
-    scrut_is_var = case scrut of {CoVar v -> True; other -> False}
-    scrut_var    = case scrut of CoVar v -> v
+    scrut_is_var = case scrut of {Var v -> True; other -> False}
+    scrut_var    = case scrut of Var v -> v
 
 	--  Eliminate any inner alts which are shadowed by the outer ones
     reduced_inner_alts = [alt | alt@(lit,_) <- inner_alts,
@@ -838,17 +832,17 @@ mkCoCase scrut (CoPrimAlts
 	-- it isn't easy to do so right away.
     munged_reduced_inner_alts = map munge_alt reduced_inner_alts
 
-    munge_alt (lit, rhs) 
-      | scrut_is_var = (lit, CoCase (CoVar scrut_var)
-				    (CoPrimAlts [] (CoBindDefault deflt_var rhs)))
-      | otherwise = (lit, CoCase (CoLit lit) 
-				 (CoPrimAlts [] (CoBindDefault deflt_var rhs)))
+    munge_alt (lit, rhs)
+      | scrut_is_var = (lit, Case (Var scrut_var)
+				    (PrimAlts [] (BindDefault deflt_var rhs)))
+      | otherwise = (lit, Case (Lit lit)
+				 (PrimAlts [] (BindDefault deflt_var rhs)))
 \end{code}
 
 Now the identity-case transformation:
 
 	case e of 		===> e
-		True -> True; 
+		True -> True;
 		False -> False
 
 and similar friends.
@@ -859,15 +853,17 @@ mkCoCase scrut alts
   = tick CaseIdentity		`thenSmpl_`
     returnSmpl scrut
   where
-    identity_alts (CoAlgAlts alts deflt)  = all identity_alg_alt  alts && identity_deflt deflt
-    identity_alts (CoPrimAlts alts deflt) = all identity_prim_alt alts && identity_deflt deflt
+    identity_alts (AlgAlts alts deflt)  = all identity_alg_alt  alts && identity_deflt deflt
+    identity_alts (PrimAlts alts deflt) = all identity_prim_alt alts && identity_deflt deflt
 
-    identity_alg_alt (con, args, CoCon con' _ args') 
-	 = con == con' && and (zipWith eq_arg args args')
+    identity_alg_alt (con, args, Con con' _ args')
+	 = con == con'
+	   && and (zipWith eq_arg args args')
+	   && length args == length args'
     identity_alg_alt other
 	 = False
 
-    identity_prim_alt (lit, CoLit lit') = lit == lit'
+    identity_prim_alt (lit, Lit lit') = lit == lit'
     identity_prim_alt other	       = False
 
 	 -- For the default case we want to spot both
@@ -875,21 +871,21 @@ mkCoCase scrut alts
 	 -- and
 	 --	case y of { ... ; x -> y }
 	 -- as "identity" defaults
-    identity_deflt CoNoDefault = True
-    identity_deflt (CoBindDefault binder (CoVar x)) = x == binder ||
-						      case scrut of 
-							 CoVar y -> y == x
+    identity_deflt NoDefault = True
+    identity_deflt (BindDefault binder (Var x)) = x == binder ||
+						      case scrut of
+							 Var y -> y == x
 							 other   -> False
     identity_deflt _ = False
 
-    eq_arg binder (CoVarAtom x) = binder == x
+    eq_arg binder (VarArg x) = binder == x
     eq_arg _      _	       = False
 \end{code}
 
 The catch-all case
 
 \begin{code}
-mkCoCase other_scrut other_alts = returnSmpl (CoCase other_scrut other_alts)
+mkCoCase other_scrut other_alts = returnSmpl (Case other_scrut other_alts)
 \end{code}
 
 Boring local functions used above.  They simply introduce a trivial binding
@@ -900,43 +896,43 @@ or
 depending on whether it's an algebraic or primitive case.
 
 \begin{code}
-munge_prim_deflt _ CoNoDefault = CoNoDefault
+munge_prim_deflt _ NoDefault = NoDefault
 
-munge_prim_deflt deflt_var (CoBindDefault d' rhs) 
-  =   CoBindDefault deflt_var (CoCase (CoVar deflt_var)
-			 	      (CoPrimAlts [] (CoBindDefault d' rhs)))
+munge_prim_deflt deflt_var (BindDefault d' rhs)
+  =   BindDefault deflt_var (Case (Var deflt_var)
+			 	      (PrimAlts [] (BindDefault d' rhs)))
 
-munge_alg_deflt _ CoNoDefault = CoNoDefault
+munge_alg_deflt _ NoDefault = NoDefault
 
-munge_alg_deflt deflt_var (CoBindDefault d' rhs) 
-  =   CoBindDefault deflt_var (CoLet (CoNonRec d' (CoVar deflt_var)) rhs)
+munge_alg_deflt deflt_var (BindDefault d' rhs)
+  =   BindDefault deflt_var (Let (NonRec d' (Var deflt_var)) rhs)
 
 -- This line caused a generic version of munge_deflt (ie one used for
 -- both alg and prim) to space leak massively.  No idea why.
---  = CoBindDefault deflt_var (mkCoLetUnboxedToCase (CoNonRec d' (CoVar deflt_var)) rhs)
+--  = BindDefault deflt_var (mkCoLetUnboxedToCase (NonRec d' (Var deflt_var)) rhs)
 \end{code}
 
 \begin{code}
 	-- A cheap equality test which bales out fast!
 cheap_eq :: InExpr -> InExpr -> Bool
-cheap_eq (CoVar v1) (CoVar v2) = v1==v2
-cheap_eq (CoLit l1) (CoLit l2) = l1==l2
-cheap_eq (CoCon con1 tys1 args1) (CoCon con2 tys2 args2) = (con1==con2) && 
+cheap_eq (Var v1) (Var v2) = v1==v2
+cheap_eq (Lit l1) (Lit l2) = l1==l2
+cheap_eq (Con con1 tys1 args1) (Con con2 tys2 args2) = (con1==con2) &&
 							   (args1 `eq_args` args2)
 							   -- Types bound to be equal
-cheap_eq (CoPrim op1 tys1 args1) (CoPrim op2 tys2 args2) = (op1==op2) &&
+cheap_eq (Prim op1 tys1 args1) (Prim op2 tys2 args2) = (op1==op2) &&
 							   (args1 `eq_args` args2)
 							   -- Types bound to be equal
-cheap_eq (CoApp   f1 a1) (CoApp   f2 a2) = (f1 `cheap_eq` f2) && (a1 `eq_atom` a2)
+cheap_eq (App   f1 a1) (App   f2 a2) = (f1 `cheap_eq` f2) && (a1 `eq_atom` a2)
 cheap_eq (CoTyApp f1 t1) (CoTyApp f2 t2) = (f1 `cheap_eq` f2) && (t1 == t2)
 cheap_eq _ _ = False
 
--- ToDo: make CoreAtom an instance of Eq
+-- ToDo: make CoreArg an instance of Eq
 eq_args (arg1: args1) (arg2 : args2) = (arg1 `eq_atom` arg2) && (args1 `eq_args` args2)
 eq_args []		       []		      = True
 eq_args other1		       other2		      = False
 
-eq_atom (CoLitAtom l1) (CoLitAtom l2) =  l1==l2
-eq_atom (CoVarAtom v1) (CoVarAtom v2) =  v1==v2
+eq_atom (LitArg l1) (LitArg l2) =  l1==l2
+eq_atom (VarArg v1) (VarArg v2) =  v1==v2
 eq_atom other1	       other2	      =  False
 \end{code}
diff --git a/ghc/compiler/simplCore/SimplCore.hi b/ghc/compiler/simplCore/SimplCore.hi
deleted file mode 100644
index a0e7857de2..0000000000
--- a/ghc/compiler/simplCore/SimplCore.hi
+++ /dev/null
@@ -1,29 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface SimplCore where
-import Bag(Bag)
-import BasicLit(BasicLit)
-import BinderInfo(BinderInfo)
-import CmdLineOpts(CoreToDo, GlobalSwitch, SwitchResult)
-import CoreSyn(CoreAtom, CoreBinding, CoreExpr)
-import FiniteMap(FiniteMap)
-import Id(Id)
-import IdEnv(IdEnv(..))
-import MagicUFs(MagicUnfoldingFun)
-import Maybes(Labda)
-import PreludePS(_PackedString)
-import Pretty(PprStyle)
-import SimplEnv(FormSummary, UnfoldingDetails, UnfoldingGuidance)
-import Specialise(SpecialiseData(..))
-import SplitUniq(SplitUniqSupply)
-import TyCon(TyCon)
-import UniType(UniType)
-import UniqFM(UniqFM)
-import Unique(Unique)
-data Bag a 
-type IdEnv a = UniqFM a
-data UnfoldingDetails 
-data SpecialiseData   = SpecData Bool Bool [TyCon] [TyCon] (FiniteMap TyCon [(Bool, [Labda UniType])]) (Bag (Id, [Labda UniType])) (Bag (Id, [Labda UniType])) (Bag (TyCon, [Labda UniType]))
-data UniqFM a 
-data Unique 
-core2core :: [CoreToDo] -> (GlobalSwitch -> SwitchResult) -> _PackedString -> PprStyle -> SplitUniqSupply -> [TyCon] -> FiniteMap TyCon [(Bool, [Labda UniType])] -> [CoreBinding Id Id] -> _State _RealWorld -> (([CoreBinding Id Id], UniqFM UnfoldingDetails, SpecialiseData), _State _RealWorld)
-
diff --git a/ghc/compiler/simplCore/SimplCore.lhs b/ghc/compiler/simplCore/SimplCore.lhs
index e96e607471..cf446c0564 100644
--- a/ghc/compiler/simplCore/SimplCore.lhs
+++ b/ghc/compiler/simplCore/SimplCore.lhs
@@ -7,21 +7,10 @@
 #include "HsVersions.h"
 
 module SimplCore (
-	core2core,
-
-	IdEnv(..),
-	UnfoldingDetails,
-	SpecialiseData(..),
-	UniqFM, Unique, Bag
+	core2core
     ) where
 
-IMPORT_Trace
-import Outputable
-import Pretty
-
-import PlainCore
-
-import AbsUniType	( getTyConDataCons, alpha_ty, alpha_tyvar, beta_ty, beta_tyvar )
+import Type		( getTyConDataCons )
 --SAVE:import ArityAnal	( arityAnalProgram )
 import Bag
 import BinderInfo	( BinderInfo) -- instances only
@@ -35,39 +24,32 @@ import CoreLint		( lintCoreBindings )
 import FloatIn		( floatInwards )
 import FloatOut		( floatOutwards )
 import Id		( getIdUnfolding,
-			  getIdUniType, toplevelishId,
+			  idType, toplevelishId,
 			  idWantsToBeINLINEd,
 			  unfoldingUnfriendlyId, isWrapperId,
 			  mkTemplateLocals
-			  IF_ATTACK_PRAGMAS(COMMA getIdStrictness)
 			)
-import IdEnv
 import IdInfo
 import LiberateCase	( liberateCase )
 import MainMonad
 import Maybes
 import SAT		( doStaticArgs )
 import SCCauto
-import SimplEnv		( UnfoldingGuidance(..), SwitchChecker(..) ) -- instances
 --ANDY:
 --import SimplHaskell	( coreToHaskell )
 import SimplMonad	( zeroSimplCount, showSimplCount, TickType, SimplCount )
 import SimplPgm		( simplifyPgm )
 import SimplVar		( leastItCouldCost )
 import Specialise
-import SpecTyFuns	( pprSpecErrs )
+import SpecUtils	( pprSpecErrs )
 import StrictAnal	( saWwTopBinds )
-#if ! OMIT_FOLDR_BUILD
-import FoldrBuildWW	
+import FoldrBuildWW
 import AnalFBWW
-#endif
 #if ! OMIT_DEFORESTER
 import Deforest		( deforestProgram )
 import DefUtils		( deforestable )
 #endif
-import TyVarEnv	    	( nullTyVarEnv )
-import SplitUniq
-import Unique
+import UniqSupply
 import Util
 \end{code}
 
@@ -76,12 +58,12 @@ core2core :: [CoreToDo]			-- spec of what core-to-core passes to do
 	  -> (GlobalSwitch->SwitchResult)-- "global" command-line info lookup fn
 	  -> FAST_STRING		-- module name (profiling only)
 	  -> PprStyle			-- printing style (for debugging only)
-	  -> SplitUniqSupply		-- a name supply
+	  -> UniqSupply		-- a name supply
 	  -> [TyCon]			-- local data tycons and tycon specialisations
-	  -> FiniteMap TyCon [(Bool, [Maybe UniType])]
-	  -> [PlainCoreBinding]		-- input...
+	  -> FiniteMap TyCon [(Bool, [Maybe Type])]
+	  -> [CoreBinding]		-- input...
 	  -> MainIO
-	      ([PlainCoreBinding],	-- results: program, plus...
+	      ([CoreBinding],	-- results: program, plus...
 	       IdEnv UnfoldingDetails,	--  unfoldings to be exported from here
 	      SpecialiseData)		--  specialisation data
 
@@ -103,14 +85,14 @@ core2core core_todos sw_chkr module_name ppr_style us local_tycons tycon_specs b
 		core_todos
 		`thenMn` \ (processed_binds, _, inline_env, spec_data, simpl_stats) ->
 
-        (if  switch_is_on D_simplifier_stats
-         then writeMn stderr ("\nSimplifier Stats:\n")
+	(if  switch_is_on D_simplifier_stats
+	 then writeMn stderr ("\nSimplifier Stats:\n")
 		`thenMn_`
 	      writeMn stderr (showSimplCount simpl_stats)
 		`thenMn_`
 	      writeMn stderr "\n"
-         else returnMn ()
-        ) `thenMn_`
+	 else returnMn ()
+	) `thenMn_`
 
 	returnMn (processed_binds, inline_env, spec_data)
     ESCC
@@ -141,36 +123,28 @@ core2core core_todos sw_chkr module_name ppr_style us local_tycons tycon_specs b
 	  CoreDoSimplify simpl_sw_chkr
 	    -> BSCC("CoreSimplify")
 	       begin_pass ("Simplify" ++ if switchIsOn simpl_sw_chkr SimplDoFoldrBuild
-				         then " (foldr/build)" else "") `thenMn_`
+					 then " (foldr/build)" else "") `thenMn_`
 	       case (simplifyPgm binds sw_chkr simpl_sw_chkr simpl_stats us1) of
 		 (p, it_cnt, simpl_stats2)
 		   -> end_pass False us2 p inline_env spec_data simpl_stats2
-			       ("Simplify (" ++ show it_cnt ++ ")" 
+			       ("Simplify (" ++ show it_cnt ++ ")"
 				 ++ if switchIsOn simpl_sw_chkr SimplDoFoldrBuild
 				    then " foldr/build" else "")
 	       ESCC
 
 	  CoreDoFoldrBuildWorkerWrapper
-#if OMIT_FOLDR_BUILD
-	    -> error "ERROR: CoreDoFoldrBuildWorkerWrapper: not built into compiler\n"
-#else
 	    -> BSCC("CoreDoFoldrBuildWorkerWrapper")
 	       begin_pass "FBWW" `thenMn_`
 	       case (mkFoldrBuildWW switch_is_on us1 binds) of { binds2 ->
 	       end_pass False us2 binds2 inline_env spec_data simpl_stats "FBWW"
 	       } ESCC
-#endif
 
 	  CoreDoFoldrBuildWWAnal
-#if OMIT_FOLDR_BUILD
-	    -> error "ERROR: CoreDoFoldrBuildWWAnal: not built into compiler\n"
-#else
 	    -> BSCC("CoreDoFoldrBuildWWAnal")
 	       begin_pass "AnalFBWW" `thenMn_`
 	       case (analFBWW switch_is_on binds) of { binds2 ->
 	       end_pass False us2 binds2 inline_env spec_data simpl_stats "AnalFBWW"
 	       } ESCC
-#endif
 
 	  CoreLiberateCase
 	    -> BSCC("LiberateCase")
@@ -198,7 +172,7 @@ core2core core_todos sw_chkr module_name ppr_style us local_tycons tycon_specs b
 	       begin_pass "FloatIn" `thenMn_`
 	       case (floatInwards binds) of { binds2 ->
 	       end_pass False us2 binds2 inline_env spec_data simpl_stats "FloatIn"
-               } ESCC
+	       } ESCC
 
 	  CoreDoFullLaziness
 	    -> BSCC("CoreFloating")
@@ -232,7 +206,7 @@ core2core core_todos sw_chkr module_name ppr_style us local_tycons tycon_specs b
 					  spec_errs spec_warn spec_tyerrs)) ->
 
 		   -- if we got errors, we die straight away
-		   (if not spec_noerrs || 
+		   (if not spec_noerrs ||
 		       (switch_is_on ShowImportSpecs && not (isEmptyBag spec_warn)) then
 			writeMn stderr (ppShow 1000 {-pprCols-}
 			    (pprSpecErrs module_name spec_errs spec_warn spec_tyerrs))
@@ -241,7 +215,7 @@ core2core core_todos sw_chkr module_name ppr_style us local_tycons tycon_specs b
 			returnMn ()) `thenMn_`
 
 		   (if not spec_noerrs then -- Stop here if specialisation errors occured
-		        exitMn 1
+			exitMn 1
 		   else
 			returnMn ()) `thenMn_`
 
@@ -249,18 +223,18 @@ core2core core_todos sw_chkr module_name ppr_style us local_tycons tycon_specs b
 	       }
 	       ESCC
 
-          CoreDoDeforest
+	  CoreDoDeforest
 #if OMIT_DEFORESTER
 	    -> error "ERROR: CoreDoDeforest: not built into compiler\n"
 #else
-            -> BSCC("Deforestation")
-               begin_pass "Deforestation" `thenMn_`
+	    -> BSCC("Deforestation")
+	       begin_pass "Deforestation" `thenMn_`
 	       case (deforestProgram sw_chkr binds us1) of { binds2 ->
 	       end_pass False us2 binds2 inline_env spec_data simpl_stats "Deforestation"
-               }
-               ESCC
+	       }
+	       ESCC
 #endif
- 
+
 	  CoreDoAutoCostCentres
 	    -> BSCC("AutoSCCs")
 	       begin_pass "AutoSCCs" `thenMn_`
@@ -269,7 +243,7 @@ core2core core_todos sw_chkr module_name ppr_style us local_tycons tycon_specs b
 	       }
 	       ESCC
 
-          CoreDoPrintCore	-- print result of last pass
+	  CoreDoPrintCore	-- print result of last pass
 	    -> end_pass True us2 binds inline_env spec_data simpl_stats "Print"
 
 
@@ -285,11 +259,11 @@ core2core core_todos sw_chkr module_name ppr_style us local_tycons tycon_specs b
 	     simpl_stats2 what
       = -- report verbosely, if required
 	(if (do_verbose_core2core && not print) ||
-	    (print && not do_verbose_core2core) 
-         then
+	    (print && not do_verbose_core2core)
+	 then
 	    writeMn stderr ("\n*** "++what++":\n")
 		`thenMn_`
-	    writeMn stderr (ppShow 1000 
+	    writeMn stderr (ppShow 1000
 		(ppAboves (map (pprPlainCoreBinding ppr_style) binds2)))
 		`thenMn_`
 	    writeMn stderr "\n"
@@ -335,7 +309,7 @@ will be visible on the other side of an interface, too.
 calcInlinings :: Bool	-- True => inlinings with _scc_s are OK
 	      -> (GlobalSwitch -> SwitchResult)
 	      -> IdEnv UnfoldingDetails
-	      -> [PlainCoreBinding]
+	      -> [CoreBinding]
 	      -> IdEnv UnfoldingDetails
 
 calcInlinings scc_s_OK sw_chkr inline_env_so_far top_binds
@@ -350,7 +324,7 @@ calcInlinings scc_s_OK sw_chkr inline_env_so_far top_binds
       where
     	pp_det NoUnfoldingDetails   = ppStr "_N_"
 	pp_det (IWantToBeINLINEd _) = ppStr "INLINE"
-    	pp_det (GeneralForm _ _ expr guide)
+    	pp_det (GenForm _ _ expr guide)
     	  = ppAbove (ppr PprDebug guide) (ppr PprDebug expr)
     	pp_det other	    	    = ppStr "???"
 
@@ -378,10 +352,10 @@ calcInlinings scc_s_OK sw_chkr inline_env_so_far top_binds
 
     con_discount_weight = uNFOLDING_CON_DISCOUNT_WEIGHT
 
-    calci inline_env (CoRec pairs)
+    calci inline_env (Rec pairs)
       = foldl (calc True{-recursive-}) inline_env pairs
 
-    calci inline_env bind@(CoNonRec binder rhs)
+    calci inline_env bind@(NonRec binder rhs)
       = calc False{-not recursive-} inline_env (binder, rhs)
 
     ---------------------------------------
@@ -389,11 +363,11 @@ calcInlinings scc_s_OK sw_chkr inline_env_so_far top_binds
     calc is_recursive inline_env (binder, rhs)
       | not (toplevelishId binder)
       = --pprTrace "giving up on not top-level:" (ppr PprDebug binder)
-	ignominious_defeat 
+	ignominious_defeat
 
       | rhs_mentions_an_unmentionable
       || (not explicit_INLINE_requested
-          && (rhs_looks_like_a_caf || guidance_says_don't || guidance_size_too_big))
+	  && (rhs_looks_like_a_caf || guidance_says_don't || guidance_size_too_big))
       = let
 	    my_my_trace
 	      = if explicit_INLINE_requested
@@ -404,7 +378,7 @@ calcInlinings scc_s_OK sw_chkr inline_env_so_far top_binds
 
 	    which = if scc_s_OK then " (late):" else " (early):"
     	in
-	--pprTrace "giving up on size:" (ppCat [ppr PprDebug binder, ppr PprDebug 
+	--pprTrace "giving up on size:" (ppCat [ppr PprDebug binder, ppr PprDebug
 	--	[rhs_mentions_an_unmentionable, explicit_INLINE_requested,
 	--	 rhs_looks_like_a_caf, guidance_says_don't, guidance_size_too_big]]) (
 	my_my_trace ("unfolding disallowed for"++which++(ppShow 80 (ppr PprDebug binder))) (
@@ -420,18 +394,18 @@ calcInlinings scc_s_OK sw_chkr inline_env_so_far top_binds
 	ignominious_defeat
 
 #if ! OMIT_DEFORESTER
-	-- For the deforester: bypass the barbed wire for recursive 
+	-- 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 && 
+      | is_recursive &&
+	explicit_INLINE_requested &&
 	deforestable binder &&
-	scc_s_OK			-- hack, only get them in 
+	scc_s_OK			-- hack, only get them in
 					-- calc_inlinings2
       = glorious_success UnfoldAlways
-#endif      
+#endif
 
       | is_recursive && not rhs_looks_like_a_data_val
 	-- The only recursive defns we are prepared to tolerate at the
@@ -440,7 +414,7 @@ calcInlinings scc_s_OK sw_chkr inline_env_so_far top_binds
       = --pprTrace "giving up on rec:" (ppr PprDebug binder)
     	ignominious_defeat
 
-        -- Not really interested unless it's exported, but doing it
+	-- 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
@@ -479,7 +453,7 @@ calcInlinings scc_s_OK sw_chkr inline_env_so_far top_binds
 	      EssentialUnfolding -> False
 	      UnfoldIfGoodArgs _ no_val_args arg_info_vec size
 
-	        -> if explicit_creation_threshold then
+		-> if explicit_creation_threshold then
 		      False 	-- user set threshold; don't second-guess...
 
 		   else if no_val_args == 0 && rhs_looks_like_a_data_val then
@@ -494,18 +468,18 @@ calcInlinings scc_s_OK sw_chkr inline_env_so_far top_binds
 --		      (if (unfold_use_threshold < cost) then (pprTrace "cost:" (ppInt cost)) else \x->x ) (
 		      unfold_use_threshold < cost
 --		      )
-		        
+
 
 	rhs_looks_like_a_caf = not (manifestlyWHNF rhs)
 
 	rhs_looks_like_a_data_val
-	  = case digForLambdas rhs of
-	      (_, [], CoCon _ _ _) -> True
-	      other 		   -> False
+	  = case (digForLambdas rhs) of
+	      (_, _, [], Con _ _ _) -> True
+	      other		    -> False
 
 	rhs_arg_tys
-	  = case digForLambdas rhs of
-	      (_, val_binders, _) -> map getIdUniType val_binders
+	  = case (digForLambdas rhs) of
+	      (_, _, val_binders, _) -> map idType val_binders
 
 	(mentioned_ids, _, _, mentions_litlit)
 	  = mentionedInUnfolding (\x -> x) rhs
@@ -596,7 +570,7 @@ calcInlinings scc_s_OK sw_chkr inline_env_so_far top_binds
 		    ignominious_defeat -- and at the last hurdle, too!
 \end{code}
 
-ANDY, on the hatred of the check above; why obliterate it?  Consider 
+ANDY, on the hatred of the check above; why obliterate it?  Consider
 
  head xs = foldr (\ x _ -> x) (_|_) xs
 
diff --git a/ghc/compiler/simplCore/SimplEnv.hi b/ghc/compiler/simplCore/SimplEnv.hi
deleted file mode 100644
index 766a8fb222..0000000000
--- a/ghc/compiler/simplCore/SimplEnv.hi
+++ /dev/null
@@ -1,106 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface SimplEnv where
-import BasicLit(BasicLit)
-import BinderInfo(BinderInfo(..), DuplicationDanger, FunOrArg, InsideSCC)
-import CmdLineOpts(GlobalSwitch, SimplifierSwitch, SwitchResult)
-import CoreSyn(CoreArg, CoreAtom, CoreBinding, CoreCaseAlternatives, CoreCaseDefault, CoreExpr)
-import CostCentre(CostCentre)
-import FiniteMap(FiniteMap)
-import Id(Id)
-import IdEnv(IdEnv(..))
-import IdInfo(StrictnessInfo)
-import MagicUFs(MagicUnfoldingFun)
-import Maybes(Labda)
-import Outputable(Outputable)
-import PreludePS(_PackedString)
-import PreludeRatio(Ratio(..))
-import Pretty(PrettyRep)
-import PrimKind(PrimKind)
-import PrimOps(PrimOp)
-import TyVar(TyVar)
-import TyVarEnv(TyVarEnv(..), nullTyVarEnv)
-import UniType(UniType)
-import UniqFM(UniqFM)
-import Unique(Unique)
-data BasicLit 
-data BinderInfo   = DeadCode | ManyOcc Int | OneOcc FunOrArg DuplicationDanger InsideSCC Int Int
-data DuplicationDanger 
-data FunOrArg 
-data InsideSCC 
-data GlobalSwitch 
-data SimplifierSwitch 
-data CoreAtom a 
-data CoreCaseAlternatives a b 
-data CoreExpr a b 
-data EnclosingCcDetails   = NoEnclosingCcDetails | EnclosingCC CostCentre
-data FormSummary   = WhnfForm | BottomForm | OtherForm
-data Id 
-type IdEnv a = UniqFM a
-data IdVal   = InlineIt (UniqFM IdVal) (UniqFM UniType) (CoreExpr (Id, BinderInfo) Id) | ItsAnAtom (CoreAtom Id)
-type InAlts = CoreCaseAlternatives (Id, BinderInfo) Id
-type InArg = CoreArg Id
-type InAtom = CoreAtom Id
-type InBinder = (Id, BinderInfo)
-type InBinding = CoreBinding (Id, BinderInfo) Id
-type InDefault = CoreCaseDefault (Id, BinderInfo) Id
-type InExpr = CoreExpr (Id, BinderInfo) Id
-type InId = Id
-type InIdEnv = UniqFM IdVal
-type InType = UniType
-type InTypeEnv = UniqFM UniType
-type InUniType = UniType
-data MagicUnfoldingFun 
-data Labda a 
-type OutAlts = CoreCaseAlternatives Id Id
-type OutArg = CoreArg Id
-type OutAtom = CoreAtom Id
-type OutBinder = Id
-type OutBinding = CoreBinding Id Id
-type OutDefault = CoreCaseDefault Id Id
-type OutExpr = CoreExpr Id Id
-type OutId = Id
-type OutType = UniType
-type OutUniType = UniType
-data SimplEnv 
-type SwitchChecker a = a -> SwitchResult
-data SwitchResult 
-data TyVar 
-type TyVarEnv a = UniqFM a
-data UnfoldConApp 
-data UnfoldEnv 
-data UnfoldItem 
-data UnfoldingDetails   = NoUnfoldingDetails | LiteralForm BasicLit | OtherLiteralForm [BasicLit] | ConstructorForm Id [UniType] [CoreAtom Id] | OtherConstructorForm [Id] | GeneralForm Bool FormSummary (CoreExpr (Id, BinderInfo) Id) UnfoldingGuidance | MagicForm _PackedString MagicUnfoldingFun | IWantToBeINLINEd UnfoldingGuidance
-data UnfoldingGuidance   = UnfoldNever | UnfoldAlways | EssentialUnfolding | UnfoldIfGoodArgs Int Int [Bool] Int | BadUnfolding
-data UniType 
-data UniqFM a 
-data Unique 
-extendIdEnvWithAtom :: SimplEnv -> (Id, BinderInfo) -> CoreAtom Id -> SimplEnv
-extendIdEnvWithAtomList :: SimplEnv -> [((Id, BinderInfo), CoreAtom Id)] -> SimplEnv
-extendIdEnvWithClone :: SimplEnv -> (Id, BinderInfo) -> Id -> SimplEnv
-extendIdEnvWithClones :: SimplEnv -> [(Id, BinderInfo)] -> [Id] -> SimplEnv
-extendIdEnvWithInlining :: SimplEnv -> SimplEnv -> (Id, BinderInfo) -> CoreExpr (Id, BinderInfo) Id -> SimplEnv
-extendTyEnv :: SimplEnv -> TyVar -> UniType -> SimplEnv
-extendTyEnvList :: SimplEnv -> [(TyVar, UniType)] -> SimplEnv
-extendUnfoldEnvGivenConstructor :: SimplEnv -> Id -> Id -> [Id] -> SimplEnv
-extendUnfoldEnvGivenFormDetails :: SimplEnv -> Id -> UnfoldingDetails -> SimplEnv
-extendUnfoldEnvGivenRhs :: SimplEnv -> (Id, BinderInfo) -> Id -> CoreExpr Id Id -> SimplEnv
-filterUnfoldEnvForInlines :: SimplEnv -> SimplEnv
-getSwitchChecker :: SimplEnv -> SimplifierSwitch -> SwitchResult
-lookForConstructor :: SimplEnv -> Id -> [UniType] -> [CoreAtom Id] -> Labda Id
-lookupId :: SimplEnv -> Id -> Labda IdVal
-lookupUnfolding :: SimplEnv -> Id -> UnfoldingDetails
-mkFormSummary :: StrictnessInfo -> CoreExpr a Id -> FormSummary
-nullInEnvs :: (UniqFM UniType, UniqFM IdVal)
-nullSimplEnv :: (SimplifierSwitch -> SwitchResult) -> SimplEnv
-nullTyVarEnv :: UniqFM a
-pprSimplEnv :: SimplEnv -> Int -> Bool -> PrettyRep
-replaceInEnvs :: SimplEnv -> (UniqFM UniType, UniqFM IdVal) -> SimplEnv
-setEnclosingCC :: SimplEnv -> EnclosingCcDetails -> SimplEnv
-simplTy :: SimplEnv -> UniType -> UniType
-simplTyInId :: SimplEnv -> Id -> Id
-switchIsSet :: SimplEnv -> SimplifierSwitch -> Bool
-instance Eq UnfoldConApp
-instance Ord UnfoldConApp
-instance Outputable FormSummary
-instance Outputable UnfoldingGuidance
-
diff --git a/ghc/compiler/simplCore/SimplEnv.lhs b/ghc/compiler/simplCore/SimplEnv.lhs
index e55b6ea5a4..6712d6a55b 100644
--- a/ghc/compiler/simplCore/SimplEnv.lhs
+++ b/ghc/compiler/simplCore/SimplEnv.lhs
@@ -1,5 +1,5 @@
 %
-% (c) The AQUA Project, Glasgow University, 1993-1995
+% (c) The AQUA Project, Glasgow University, 1993-1996
 %
 \section[SimplEnv]{Environment stuff for the simplifier}
 
@@ -10,10 +10,8 @@ module SimplEnv (
 	nullSimplEnv,
 	pprSimplEnv, -- debugging only
 
---UNUSED: getInEnvs,
 	replaceInEnvs, nullInEnvs,
 
-	nullTyVarEnv,
 	extendTyEnv, extendTyEnvList,
 	simplTy, simplTyInId,
 
@@ -23,7 +21,6 @@ module SimplEnv (
 	lookupId,
 
 	extendUnfoldEnvGivenRhs,
---OLD:	extendUnfoldEnvWithRecInlinings,
 	extendUnfoldEnvGivenFormDetails,
 	extendUnfoldEnvGivenConstructor,
 	lookForConstructor,
@@ -31,67 +28,70 @@ module SimplEnv (
 
 	getSwitchChecker, switchIsSet,
 
---UNUSED: getEnclosingCC,
 	setEnclosingCC,
 
-	mkFormSummary,
-
 	-- Types
-	SwitchChecker(..), 
-	SimplEnv, UnfoldingDetails(..), UnfoldingGuidance(..),
-	FormSummary(..), EnclosingCcDetails(..),
+	SwitchChecker(..),
+	SimplEnv, EnclosingCcDetails(..),
 	InIdEnv(..), IdVal(..), InTypeEnv(..),
 	UnfoldEnv, UnfoldItem, UnfoldConApp,
 
-	-- re-exported from BinderInfo
-	BinderInfo(..),
-	FunOrArg, DuplicationDanger, InsideSCC, -- sigh
-
-	InId(..),  InBinder(..),  InType(..),  InBinding(..),  InUniType(..),
-	OutId(..), OutBinder(..), OutType(..), OutBinding(..), OutUniType(..),
+	InId(..),  InBinder(..),  InBinding(..),  InType(..),
+	OutId(..), OutBinder(..), OutBinding(..), OutType(..),
 
-	InExpr(..),  InAtom(..),  InAlts(..),  InDefault(..),  InArg(..),
-	OutExpr(..), OutAtom(..), OutAlts(..), OutDefault(..), OutArg(..),
+	InExpr(..),  InAlts(..),  InDefault(..),  InArg(..),
+	OutExpr(..), OutAlts(..), OutDefault(..), OutArg(..)
 
 	-- and to make the interface self-sufficient...
-	BasicLit, GlobalSwitch, SimplifierSwitch, SwitchResult, CoreAtom,
-	CoreCaseAlternatives, CoreExpr, Id,
-	IdEnv(..), UniqFM, Unique,
-	MagicUnfoldingFun, Maybe, TyVar, TyVarEnv(..), UniType
-	
-	IF_ATTACK_PRAGMAS(COMMA applyTypeEnvToTy COMMA applyTypeEnvToId)
-	IF_ATTACK_PRAGMAS(COMMA emptyUFM COMMA lookupUFM COMMA lookupIdEnv) -- profiling
     ) where
 
-IMPORT_Trace
+import Ubiq{-uitous-}
 
-import AbsUniType	( applyTypeEnvToTy, getUniDataTyCon, cmpUniType )
-import Bag		( emptyBag, Bag )
-import BasicLit		( isNoRepLit, BasicLit(..), PrimKind ) -- .. for pragmas only
-import BinderInfo
-import CmdLineOpts	( switchIsOn, intSwitchSet,
-			  SimplifierSwitch(..), SwitchResult
-			)
-import CgCompInfo	( uNFOLDING_CREATION_THRESHOLD )
-import CostCentre
-import FiniteMap
-import Id		( getIdUnfolding, eqId, cmpId, applyTypeEnvToId,
-			  getIdUniType, getIdStrictness, isWorkerId,
-			  isBottomingId
+import SmplLoop		-- breaks the MagicUFs / SimplEnv loop
+
+import BinderInfo	( BinderInfo{-instances-} )
+import CmdLineOpts	( switchIsOn, intSwitchSet, SimplifierSwitch(..), SwitchResult )
+import CoreSyn
+import CoreUnfold	( UnfoldingDetails(..), mkGenForm, modifyUnfoldingDetails,
+			  calcUnfoldingGuidance, UnfoldingGuidance(..),
+			  mkFormSummary, FormSummary
 			)
-import IdEnv
-import IdInfo
-import MagicUFs
-import Maybes		( assocMaybe, maybeToBool, Maybe(..) )
-import OccurAnal	( occurAnalyseExpr )
-import PlainCore	-- for the "Out*" types and things
-import Pretty		-- debugging only
-import SimplUtils	( simplIdWantsToBeINLINEd )
-import TaggedCore	-- for the "In*" types and things
-import TyVarEnv
-import UniqFM		( lookupDirectlyUFM, addToUFM_Directly, ufmToList )
-import UniqSet
-import Util
+import FiniteMap	-- lots of things
+import Id		( idType, getIdUnfolding, getIdStrictness,
+			  nullIdEnv, growIdEnvList, rngIdEnv, lookupIdEnv,
+			  addOneToIdEnv, modifyIdEnv,
+			  IdEnv(..), IdSet(..), GenId )
+import IdInfo		( StrictnessInfo )
+import Literal		( isNoRepLit, Literal{-instances-} )
+import Outputable	( Outputable(..){-instances-} )
+import PprCore		-- various instances
+import PprStyle		( PprStyle(..) )
+import PprType		( GenType, GenTyVar )
+import Pretty
+import Type		( getAppDataTyCon )
+import TyVar		( nullTyVarEnv, addOneToIdEnv, addOneToTyVarEnv,
+			  growTyVarEnvList,
+			  TyVarEnv(..), GenTyVar )
+import Unique		( Unique )
+import UniqSet		-- lots of things
+import Usage		( UVar(..), GenUsage{-instances-} )
+import Util		( zipEqual, panic, assertPanic )
+
+type TypeEnv = TyVarEnv Type
+addToUFM_Directly = panic "addToUFM_Directly (SimplEnv)"
+applyTypeEnvToId = panic "applyTypeEnvToId (SimplEnv)"
+applyTypeEnvToTy = panic "applyTypeEnvToTy (SimplEnv)"
+bottomIsGuaranteed = panic "bottomIsGuaranteed (SimplEnv)"
+cmpType = panic "cmpType (SimplEnv)"
+exprSmallEnoughToDup = panic "exprSmallEnoughToDup (SimplEnv)"
+lookupDirectlyUFM = panic "lookupDirectlyUFM (SimplEnv)"
+manifestlyWHNF = panic "manifestlyWHNF (SimplEnv)"
+occurAnalyseExpr = panic "occurAnalyseExpr (SimplEnv)"
+oneSafeOcc = panic "oneSafeOcc (SimplEnv)"
+oneTextualOcc = panic "oneTextualOcc (SimplEnv)"
+simplIdWantsToBeINLINEd = panic "simplIdWantsToBeINLINEd (SimplEnv)"
+uNFOLDING_CREATION_THRESHOLD = panic "uNFOLDING_CREATION_THRESHOLD (SimplEnv)"
+ufmToList = panic "ufmToList (SimplEnv)"
 \end{code}
 
 %************************************************************************
@@ -112,10 +112,10 @@ INVARIANT: we assume {\em no shadowing}.  (ToDo: How can we ASSERT
 this? WDP 94/06) This allows us to neglect keeping everything paired
 with its static environment.
 
-The environment contains bindings for all 
+The environment contains bindings for all
 	{\em in-scope,}
 	{\em locally-defined}
-things.  
+things.
 
 For such things, any unfolding is found in the environment, not in the
 Id.  Unfoldings in the Id itself are used only for imported things
@@ -124,34 +124,34 @@ inside the Ids, etc.).
 
 \begin{code}
 data SimplEnv
-  = SimplEnv 
-	(SwitchChecker SimplifierSwitch)
+  = SimplEnv
+	SwitchChecker
 
 	EnclosingCcDetails -- the enclosing cost-centre (when profiling)
 
 	InTypeEnv	-- For cloning types
 			-- Domain is all in-scope type variables
-  			
+
 	InIdEnv		-- IdEnv
-			-- Domain is 
-			-- 	*all* 
-			-- 	*in-scope*, 
-			--	*locally-defined* 
+			-- Domain is
+			-- 	*all*
+			-- 	*in-scope*,
+			--	*locally-defined*
 			-- 	*InIds*
 			-- (Could omit the exported top-level guys,
 			-- since their names mustn't change; and ditto
 			-- the non-exported top-level guys which you
 			-- don't want to macro-expand, since their
 			-- names need not change.)
-			-- 
+			--
 			-- Starts off empty
-			
+
 	UnfoldEnv	-- Domain is any *OutIds*, including imports
 			-- where we know something more than the
 			-- interface file tells about their value (see
 			-- below)
 
-nullSimplEnv :: SwitchChecker SimplifierSwitch -> SimplEnv
+nullSimplEnv :: SwitchChecker -> SimplEnv
 
 nullSimplEnv sw_chkr
   = SimplEnv sw_chkr NoEnclosingCcDetails nullTyVarEnv nullIdEnv null_unfold_env
@@ -168,25 +168,23 @@ pprSimplEnv (SimplEnv _ _ ty_env id_env (UFE unfold_env _ _))
     pp_id_entry (v, idval)
       = ppCat [ppr PprDebug v, ppStr "=>",
 	       case idval of
-	         InlineIt _ _ e -> ppCat [ppStr "InlineIt:", ppr PprDebug e]
-		 ItsAnAtom a -> ppCat [ppStr "Atom:", ppr PprDebug a]
+		 InlineIt _ _ e -> ppCat [ppStr "InlineIt:", ppr PprDebug e]
+		 ItsAnAtom a    -> ppCat [ppStr "Atom:", ppr PprDebug a]
 	      ]
 
     pp_uf_entry (UnfoldItem v form encl_cc)
       = ppCat [ppr PprDebug v, ppStr "=>",
 	       case form of
-	         NoUnfoldingDetails -> ppStr "NoUnfoldingDetails"
-		 LiteralForm l -> ppCat [ppStr "Lit:", ppr PprDebug l]
-		 OtherLiteralForm ls -> ppCat [ppStr "Other lit:", ppInterleave (ppStr ", ") [ppr PprDebug l | l <- ls]]
-		 ConstructorForm c t a -> ppCat [ppStr "Con:", ppr PprDebug c, ppr PprDebug a]
-		 OtherConstructorForm cs -> ppCat [ppStr "OtherCon:", ppInterleave (ppStr ", ") 
-									  [ppr PprDebug c | c <- cs]]
-		 GeneralForm t w e g -> ppCat [ppStr "UF:", 
-						 	ppr PprDebug t,
-						 	ppr PprDebug w,
+		 NoUnfoldingDetails -> ppStr "NoUnfoldingDetails"
+		 LitForm l -> ppCat [ppStr "Lit:", ppr PprDebug l]
+		 OtherLitForm ls -> ppCat [ppStr "Other lit:", ppInterleave (ppStr ", ")
+						               [ppr PprDebug l | l <- ls]]
+		 ConForm c a     -> ppCat [ppStr "Con:", ppr PprDebug c, ppr PprDebug a]
+		 OtherConForm cs -> ppCat [ppStr "OtherCon:", ppInterleave (ppStr ", ")
+							      [ppr PprDebug c | c <- cs]]
+		 GenForm t w e g -> ppCat [ppStr "UF:",	ppr PprDebug t,	ppr PprDebug w,
 							ppr PprDebug g, ppr PprDebug e]
-		 MagicForm s _ -> ppCat [ppStr "Magic:", ppPStr s]
-		 IWantToBeINLINEd _ -> ppStr "IWantToBeINLINEd"
+		 MagicForm s _   -> ppCat [ppStr "Magic:", ppr PprDebug s]
 	      ]
 \end{code}
 
@@ -224,16 +222,16 @@ data IdVal
 		-- If x gets an InlineIt, we must remember
 		-- the correct binding for y.
 
-  | ItsAnAtom OutAtom	-- Used either (a) to record the cloned Id
+  | ItsAnAtom OutArg	-- Used either (a) to record the cloned Id
 			-- or (b) if the orig defn is a let-binding, and
 			-- the RHS of the let simplifies to an atom,
-			-- we just bind the variable to that atom, and 
+			-- we just bind the variable to that atom, and
 			-- elide the let.
 \end{code}
 
 %************************************************************************
 %*									*
-\subsubsection{The @UnfoldEnv@, @UnfoldingDetails@, and @UnfoldingGuidance@ types}
+\subsubsection{The @UnfoldEnv@ type}
 %*									*
 %************************************************************************
 
@@ -260,15 +258,13 @@ data UnfoldItem -- a glorified triple...
 					-- that was in force.
 
 data UnfoldConApp -- yet another glorified triple
-  = UCA		OutId			-- same fields as ConstructorForm;
-		[UniType]		-- a new type so we can make
-		[OutAtom]		-- Ord work on it (instead of on
-					-- UnfoldingDetails).
+  = UCA		OutId			-- same fields as ConForm
+		[OutArg]
 
 data UnfoldEnv	-- yup, a glorified triple...
   = UFE		(IdEnv UnfoldItem)	-- Maps an OutId => its UnfoldItem
 		IdSet			-- The Ids in the domain of the env
-					-- which have details (GeneralForm True ...)
+					-- which have details (GenForm True ...)
 					-- i.e., they claim they are duplicatable.
 					-- These are the ones we have to worry
 					-- about when adding new items to the
@@ -303,7 +299,7 @@ lookup_unfold_env_encl_cc
 grow_unfold_env full_u_env id NoUnfoldingDetails _ = full_u_env
 
 grow_unfold_env (UFE u_env interesting_ids con_apps) id
-		uf_details@(GeneralForm True _ _ _) encl_cc
+		uf_details@(GenForm True _ _ _) encl_cc
     -- Only interested in Ids which have a "dangerous" unfolding; that is
     -- one that claims to have a single occurrence.
   = UFE (addOneToIdEnv u_env id (UnfoldItem id uf_details encl_cc))
@@ -317,12 +313,12 @@ grow_unfold_env (UFE u_env interesting_ids con_apps) id uf_details encl_cc
   where
     new_con_apps
       = case uf_details of
-	  ConstructorForm con targs vargs
+	  ConForm con vargs
 	    -> case (lookupFM con_apps entry) of
 		 Just _  -> con_apps -- unchanged; we hang onto what we have
 		 Nothing -> addToFM con_apps entry id
 	    where
-	      entry = UCA con targs vargs
+	      entry = UCA con vargs
 
 	  not_a_constructor -> con_apps -- unchanged
 
@@ -331,7 +327,7 @@ addto_unfold_env (UFE u_env interesting_ids con_apps) extra_items
     -- otherwise, we'd need to change con_apps
     UFE (growIdEnvList u_env extra_items) interesting_ids con_apps
   where
-    constructor_form_in_those (_, UnfoldItem _ (ConstructorForm _ _ _) _) = True
+    constructor_form_in_those (_, UnfoldItem _ (ConForm _ _) _) = True
     constructor_form_in_those _ = False
 
 rng_unfold_env (UFE u_env _ _) = rngIdEnv u_env
@@ -351,8 +347,8 @@ lookup_unfold_env_encl_cc (UFE u_env _ _) id
       Nothing	    	    	    -> NoEnclosingCcDetails
       Just (UnfoldItem _ _ encl_cc) -> encl_cc
 
-lookup_conapp (UFE _ _ con_apps) con ty_args con_args
-  = lookupFM con_apps (UCA con ty_args con_args)
+lookup_conapp (UFE _ _ con_apps) con args
+  = lookupFM con_apps (UCA con args)
 
 modify_unfold_env (UFE u_env interesting_ids con_apps) zapper id
   = UFE (modifyIdEnv u_env zapper id) interesting_ids con_apps
@@ -361,7 +357,7 @@ modify_unfold_env (UFE u_env interesting_ids con_apps) zapper id
 -- we modify it.
 modifyItem :: Bool -> BinderInfo -> UnfoldItem -> UnfoldItem
 
-modifyItem ok_to_dup occ_info (UnfoldItem id details enc_cc) 
+modifyItem ok_to_dup occ_info (UnfoldItem id details enc_cc)
   = UnfoldItem id (modifyUnfoldingDetails ok_to_dup occ_info details) enc_cc
 \end{code}
 
@@ -377,18 +373,16 @@ instance Ord UnfoldConApp where
     a <  b = case cmp_app a b of { LT_ -> True;  EQ_ -> False; GT__ -> False }
     a >= b = case cmp_app a b of { LT_ -> False; EQ_ -> True;  GT__ -> True  }
     a >  b = case cmp_app a b of { LT_ -> False; EQ_ -> False; GT__ -> True  }
-#ifdef __GLASGOW_HASKELL__
     _tagCmp a b = case cmp_app a b of { LT_ -> _LT; EQ_ -> _EQ; GT__ -> _GT }
-#endif
 
-cmp_app (UCA c1 tys1 as1) (UCA c2 tys2 as2)
-  = case cmpId c1 c2 of
+instance Ord3 UnfoldConApp where
+    cmp = cmp_app
+
+cmp_app (UCA c1 as1) (UCA c2 as2)
+  = case (c1 `cmp` c2) of
       LT_ -> LT_
       GT_ -> GT_
-      _   -> case (cmp_lists (cmpUniType True{-properly-}) tys1 tys2) of
-	       LT_ -> LT_
-	       GT_ -> GT_
-	       _   -> cmp_lists cmp_atom as1 as2
+      _   -> cmp_lists cmp_atom as1 as2
   where
     cmp_lists cmp_item []     []     = EQ_
     cmp_lists cmp_item (x:xs) []     = GT_
@@ -396,182 +390,11 @@ cmp_app (UCA c1 tys1 as1) (UCA c2 tys2 as2)
     cmp_lists cmp_item (x:xs) (y:ys)
       = case cmp_item x y of { EQ_ -> cmp_lists cmp_item xs ys; other -> other }
 
-    cmp_atom (CoVarAtom x) (CoVarAtom y) = x `cmpId` y
-    cmp_atom (CoVarAtom _) _		 = LT_
-    cmp_atom (CoLitAtom x) (CoLitAtom y)
-#ifdef __GLASGOW_HASKELL__
+    cmp_atom (VarArg x) (VarArg y) = x `cmp` y
+    cmp_atom (VarArg _) _		 = LT_
+    cmp_atom (LitArg x) (LitArg y)
       = case _tagCmp x y of { _LT -> LT_; _EQ -> EQ_; GT__ -> GT_ }
-#else
-      = if x == y then EQ_ elsid if x < y then LT_ else GT_
-#endif
-    cmp_atom (CoLitAtom _) _		 = GT_
-\end{code}
-
-\begin{code}
-data UnfoldingDetails
-  = NoUnfoldingDetails
-
-  | LiteralForm 
-	BasicLit
-
-  | OtherLiteralForm
-	[BasicLit]		-- It is a literal, but definitely not one of these
-
-  | ConstructorForm
-	Id			-- The constructor
-	[UniType]		-- Type args
-	[OutAtom]		-- Value arguments; NB OutAtoms, already cloned
-
-  | OtherConstructorForm
-	[Id]			-- It definitely isn't one of these constructors
-				-- This captures the situation in the default branch of
-				-- a case:  case x of
-				--		c1 ... -> ...
-				--		c2 ... -> ...
-				--		v -> default-rhs
-				-- Then in default-rhs we know that v isn't c1 or c2.
-				-- 
-				-- NB.  In the degenerate: case x of {v -> default-rhs}
-				-- x will be bound to 
-				--	OtherConstructorForm []
-				-- which captures the idea that x is eval'd but we don't
-				-- know which constructor.
-				
-
-  | GeneralForm
-	Bool			-- True <=> At most one textual occurrence of the
-				--		binder in its scope, *or*
-				--		if we are happy to duplicate this
-				--		binding.
-	FormSummary		-- Tells whether the template is a WHNF or bottom
-	TemplateOutExpr		-- The template
-	UnfoldingGuidance	-- Tells about the *size* of the template.
-
-  | MagicForm
-	FAST_STRING 
-	MagicUnfoldingFun
-
-  {-OLD? Nukable? ("Also turgid" SLPJ)-}
-  | IWantToBeINLINEd 		-- Means this has an INLINE pragma;
-				-- Used for things which have a defn in this module
-	UnfoldingGuidance	-- Guidance from the pragma; usually UnfoldAlways.
-
-data FormSummary
-  = WhnfForm 		-- Expression is WHNF
-  | BottomForm		-- Expression is guaranteed to be bottom. We're more gung
-			-- ho about inlining such things, because it can't waste work
-  | OtherForm		-- Anything else
-
-instance Outputable FormSummary where
-   ppr sty WhnfForm   = ppStr "WHNF"
-   ppr sty BottomForm = ppStr "Bot"
-   ppr sty OtherForm  = ppStr "Other"
-
-mkFormSummary :: StrictnessInfo -> CoreExpr bndr Id -> FormSummary
-mkFormSummary si expr
-  | manifestlyWHNF     expr = WhnfForm
-  | bottomIsGuaranteed si   = BottomForm
-
-  -- Chances are that the Id will be decorated with strictness info
-  -- telling that the RHS is definitely bottom.  This *might* not be the
-  -- case, if it's been a while since strictness analysis, but leaving out
-  -- the test for manifestlyBottom makes things a little more efficient.
-  -- We can always put it back...
-  -- | manifestlyBottom expr  = BottomForm
-
-  | otherwise = OtherForm
-\end{code}
-
-\begin{code}
-data UnfoldingGuidance
-  = UnfoldNever			-- Don't do it!
-
-  | UnfoldAlways		-- There is no "original" definition,
-				-- so you'd better unfold.  Or: something
-				-- so cheap to unfold (e.g., 1#) that
-				-- you should do it absolutely always.
-
-  | EssentialUnfolding		-- Like UnfoldAlways, but you *must* do
-				-- it absolutely always.
-				-- This is what we use for data constructors
-				-- and PrimOps, because we don't feel like
-				-- generating curried versions "just in case".
-
-  | UnfoldIfGoodArgs	Int	-- if "m" type args and "n" value args; and
-			Int	-- those val args are manifestly data constructors
-			[Bool]	-- the val-arg positions marked True
-				-- (i.e., a simplification will definitely
-				-- be possible).
-			Int	-- The "size" of the unfolding; to be elaborated
-				-- later. ToDo
-
-  | BadUnfolding		-- This is used by TcPragmas if the *lazy*
-				-- lintUnfolding test fails
-				-- It will never escape from the IdInfo as
-				-- it is caught by getInfo_UF and converted
-				-- to NoUnfoldingDetails
-\end{code}
-
-\begin{code}
-instance Outputable UnfoldingGuidance where
-    ppr sty UnfoldNever	    	= ppStr "_N_"
-    ppr sty UnfoldAlways    	= ppStr "_ALWAYS_"
-    ppr sty EssentialUnfolding	= ppStr "_ESSENTIAL_" -- shouldn't appear in an iface
-    ppr sty (UnfoldIfGoodArgs t v cs size)
-      = ppCat [ppStr "_IF_ARGS_", ppInt t, ppInt v,
-	       if null cs	-- always print *something*
-	       	then ppChar 'X'
-		else ppBesides (map pp_c cs),
-	       ppInt size ]
-      where
-	pp_c False = ppChar 'X'
-	pp_c True  = ppChar 'C'
-\end{code}
-
-%************************************************************************
-%*									*
-\subsection{@mkGenForm@ and @modifyUnfoldingDetails@}
-%*									*
-%************************************************************************
-
-\begin{code}
-mkGenForm :: Bool		-- Ok to Dup code down different case branches,
-				-- because of either a flag saying so,
-				-- or alternatively the object is *SMALL*
-	  -> BinderInfo		-- 
-	  -> FormSummary
-	  -> TemplateOutExpr	-- Template
-	  -> UnfoldingGuidance	-- Tells about the *size* of the template.
-	  -> UnfoldingDetails
-
-mkGenForm safe_to_dup occ_info WhnfForm template guidance
-  = GeneralForm (oneTextualOcc safe_to_dup occ_info) WhnfForm template guidance
-
-mkGenForm safe_to_dup occ_info form_summary template guidance
-  | oneSafeOcc safe_to_dup occ_info	-- Non-WHNF with only safe occurrences
-  = GeneralForm True form_summary template guidance
-
-  | otherwise				-- Not a WHNF, many occurrences
-  = NoUnfoldingDetails
-\end{code}
-
-\begin{code}
-modifyUnfoldingDetails 
-	:: Bool		-- OK to dup
-	-> BinderInfo	-- New occurrence info for the thing
-	-> UnfoldingDetails
-	-> UnfoldingDetails
-
-modifyUnfoldingDetails ok_to_dup occ_info 
-	(GeneralForm only_one form_summary template guidance)
-  | only_one  = mkGenForm ok_to_dup occ_info form_summary template guidance
-
-{- OLD:  
-	| otherwise = NoUnfoldingDetails  
-   I can't see why we zap bindings which don't claim to be unique 
--}
-
-modifyUnfoldingDetails ok_to_dup occ_info other = other
+    cmp_atom (LitArg _) _		 = GT_
 \end{code}
 
 %************************************************************************
@@ -593,35 +416,28 @@ data EnclosingCcDetails
 %************************************************************************
 
 \begin{code}
-type InId      = Id			-- Not yet cloned 
-type InBinder  = (InId, BinderInfo) 
-type InType    = UniType			-- Ditto 
+type InId      = Id			-- Not yet cloned
+type InBinder  = (InId, BinderInfo)
+type InType    = Type			-- Ditto
 type InBinding = SimplifiableCoreBinding
 type InExpr    = SimplifiableCoreExpr
-type InAtom    = SimplifiableCoreAtom	-- same as PlainCoreAtom
-type InAlts    = SimplifiableCoreCaseAlternatives
+type InAlts    = SimplifiableCoreCaseAlts
 type InDefault = SimplifiableCoreCaseDefault
-type InArg     = CoreArg InId
-type InUniType = UniType
+type InArg     = SimplifiableCoreArg
 
-type OutId	= Id			-- Cloned 
+type OutId	= Id			-- Cloned
 type OutBinder	= Id
-type OutType	= UniType		-- Cloned 
-type OutBinding	= PlainCoreBinding
-type OutExpr	= PlainCoreExpr
-type OutAtom	= PlainCoreAtom
-type OutAlts	= PlainCoreCaseAlternatives
-type OutDefault	= PlainCoreCaseDefault
-type OutArg	= CoreArg OutId
-type OutUniType = UniType
-
-type TemplateOutExpr = CoreExpr (OutId, BinderInfo) OutId
-	-- An OutExpr with occurrence info attached
-	-- This is used as a template in GeneralForms.
+type OutType	= Type			-- Cloned
+type OutBinding	= CoreBinding
+type OutExpr	= CoreExpr
+type OutAlts	= CoreCaseAlts
+type OutDefault	= CoreCaseDefault
+type OutArg	= CoreArg
+
 \end{code}
 
 \begin{code}
-type SwitchChecker switch = switch -> SwitchResult
+type SwitchChecker = SimplifierSwitch -> SwitchResult
 \end{code}
 
 %************************************************************************
@@ -637,7 +453,7 @@ type SwitchChecker switch = switch -> SwitchResult
 %************************************************************************
 
 \begin{code}
-getSwitchChecker :: SimplEnv -> SwitchChecker SimplifierSwitch
+getSwitchChecker :: SimplEnv -> SwitchChecker
 getSwitchChecker (SimplEnv chkr _ _ _ _) = chkr
 
 switchIsSet :: SimplEnv -> SimplifierSwitch -> Bool
@@ -652,10 +468,6 @@ switchIsSet (SimplEnv chkr _ _ _ _) switch
 %************************************************************************
 
 \begin{code}
--- UNUSED:
---getEnclosingCC :: SimplEnv -> EnclosingCcDetails
---getEnclosingCC (SimplEnv _ encl_cc _ _ _) = encl_cc
-
 setEnclosingCC :: SimplEnv -> EnclosingCcDetails -> SimplEnv
 
 setEnclosingCC (SimplEnv chkr _ ty_env id_env unfold_env) encl_cc
@@ -669,15 +481,15 @@ setEnclosingCC (SimplEnv chkr _ ty_env id_env unfold_env) encl_cc
 %************************************************************************
 
 \begin{code}
-type InTypeEnv = TypeEnv	-- Maps InTyVars to OutUniTypes
+type InTypeEnv = TypeEnv	-- Maps InTyVars to OutTypes
 
-extendTyEnv :: SimplEnv -> TyVar -> UniType -> SimplEnv
+extendTyEnv :: SimplEnv -> TyVar -> Type -> SimplEnv
 extendTyEnv (SimplEnv chkr encl_cc ty_env id_env unfold_env) tyvar ty
   = SimplEnv chkr encl_cc new_ty_env id_env unfold_env
   where
     new_ty_env = addOneToTyVarEnv ty_env tyvar ty
 
-extendTyEnvList :: SimplEnv -> [(TyVar,UniType)] -> SimplEnv
+extendTyEnvList :: SimplEnv -> [(TyVar,Type)] -> SimplEnv
 extendTyEnvList (SimplEnv chkr encl_cc ty_env id_env unfold_env) pairs
   = SimplEnv chkr encl_cc new_ty_env id_env unfold_env
   where
@@ -688,21 +500,18 @@ simplTy     (SimplEnv _ _ ty_env _ _) ty = applyTypeEnvToTy ty_env ty
 simplTyInId (SimplEnv _ _ ty_env _ _) id = applyTypeEnvToId ty_env id
 \end{code}
 
-@replaceInEnvs@ is used to install saved type and id envs 
+@replaceInEnvs@ is used to install saved type and id envs
 when pulling an un-simplified expression out of the environment, which
 was saved with its environments.
 
 \begin{code}
 nullInEnvs = (nullTyVarEnv, nullIdEnv) :: (InTypeEnv,InIdEnv)
 
--- UNUSED:
---getInEnvs :: SimplEnv -> (InTypeEnv,InIdEnv)
---getInEnvs (SimplEnv chkr encl_cc ty_env id_env unfold_env) = (ty_env,id_env)
-
 replaceInEnvs :: SimplEnv -> (InTypeEnv,InIdEnv) -> SimplEnv
-replaceInEnvs (SimplEnv chkr encl_cc ty_env id_env unfold_env) 
+
+replaceInEnvs (SimplEnv chkr encl_cc ty_env id_env unfold_env)
 	      (new_ty_env, new_id_env)
-  = SimplEnv chkr encl_cc new_ty_env new_id_env unfold_env 
+  = SimplEnv chkr encl_cc new_ty_env new_id_env unfold_env
 \end{code}
 
 %************************************************************************
@@ -714,16 +523,16 @@ replaceInEnvs (SimplEnv chkr encl_cc ty_env id_env unfold_env)
 \begin{code}
 extendIdEnvWithAtom
 	:: SimplEnv
-	-> InBinder -> OutAtom
+	-> InBinder -> OutArg
 	-> SimplEnv
 
-extendIdEnvWithAtom (SimplEnv chkr encl_cc ty_env id_env unfold_env) (in_id,occ_info) atom@(CoLitAtom lit)
+extendIdEnvWithAtom (SimplEnv chkr encl_cc ty_env id_env unfold_env) (in_id,occ_info) atom@(LitArg lit)
   = SimplEnv chkr encl_cc ty_env new_id_env unfold_env
   where
     new_id_env = addOneToIdEnv id_env in_id (ItsAnAtom atom)
 
 extendIdEnvWithAtom (SimplEnv chkr encl_cc ty_env id_env unfold_env)
-	    (in_id, occ_info) atom@(CoVarAtom out_id)
+	    (in_id, occ_info) atom@(VarArg out_id)
   = SimplEnv chkr encl_cc ty_env new_id_env new_unfold_env
   where
     new_id_env = addOneToIdEnv id_env in_id (ItsAnAtom atom)
@@ -740,7 +549,7 @@ extendIdEnvWithAtom (SimplEnv chkr encl_cc ty_env id_env unfold_env)
 
 extendIdEnvWithAtomList
 	:: SimplEnv
-	-> [(InBinder, OutAtom)]
+	-> [(InBinder, OutArg)]
 	-> SimplEnv
 extendIdEnvWithAtomList = foldr (\ (bndr,val) env -> extendIdEnvWithAtom env bndr val)
 
@@ -751,9 +560,9 @@ extendIdEnvWithInlining
 	-> InBinder -> InExpr
 	-> SimplEnv
 
-extendIdEnvWithInlining (SimplEnv chkr encl_cc ty_env        id_env        unfold_env) 
-		        ~(SimplEnv _   _       inline_ty_env inline_id_env _         )
-		        (in_id,occ_info) 
+extendIdEnvWithInlining (SimplEnv chkr encl_cc ty_env        id_env        unfold_env)
+			~(SimplEnv _   _       inline_ty_env inline_id_env _         )
+			(in_id,occ_info)
 			expr
   = SimplEnv chkr encl_cc ty_env new_id_env unfold_env
   where
@@ -766,10 +575,10 @@ extendIdEnvWithClone
 	-> SimplEnv
 
 extendIdEnvWithClone (SimplEnv chkr encl_cc ty_env id_env unfold_env)
-	(in_id,_) out_id 
+	(in_id,_) out_id
   = SimplEnv chkr encl_cc ty_env new_id_env unfold_env
   where
-    new_id_env = addOneToIdEnv id_env in_id (ItsAnAtom (CoVarAtom out_id))
+    new_id_env = addOneToIdEnv id_env in_id (ItsAnAtom (VarArg out_id))
 
 extendIdEnvWithClones	-- Like extendIdEnvWithClone
 	:: SimplEnv
@@ -783,7 +592,7 @@ extendIdEnvWithClones (SimplEnv chkr encl_cc ty_env id_env unfold_env)
   where
     new_id_env = growIdEnvList id_env (in_ids `zipEqual` out_vals)
     in_ids     = [id | (id,_) <- in_binders]
-    out_vals   = [ItsAnAtom (CoVarAtom out_id) | out_id <- out_ids]
+    out_vals   = [ItsAnAtom (VarArg out_id) | out_id <- out_ids]
 
 lookupId :: SimplEnv -> Id -> Maybe IdVal
 
@@ -829,15 +638,15 @@ extendUnfoldEnvGivenConstructor -- specialised variant
 extendUnfoldEnvGivenConstructor env var con args
   = let
 	-- conjure up the types to which the con should be applied
-	scrut_ty	= getIdUniType var
-	(_, ty_args, _) = getUniDataTyCon scrut_ty
+	scrut_ty	= idType var
+	(_, ty_args, _) = getAppDataTyCon scrut_ty
     in
     extendUnfoldEnvGivenFormDetails
-      env var (ConstructorForm con ty_args (map CoVarAtom args))
+      env var (ConForm con (map VarArg args))
 \end{code}
 
 
-@extendUnfoldEnvGivenRhs@ records in the UnfoldEnv info about the RHS 
+@extendUnfoldEnvGivenRhs@ records in the UnfoldEnv info about the RHS
 of a new binding.  There is a horrid case we have to take care about,
 due to Andr\'e Santos:
 @
@@ -848,20 +657,20 @@ due to Andr\'e Santos:
     tabulate      f (l,u)             = listArray (l,u) [f i | i <- [l..u]];
 
     f_iaamain a_xs=
-        let { 
-            f_aareorder::(Array_type Int) -> (Array_type t1) -> Array_type t1;
-            f_aareorder a_index a_ar=
-                let { 
-                    f_aareorder' a_i= a_ar ! (a_index ! a_i)
-                 } in  tabulate f_aareorder' (bounds a_ar);
-            r_index=tabulate ((+) 1) (1,1);
+	let {
+	    f_aareorder::(Array_type Int) -> (Array_type t1) -> Array_type t1;
+	    f_aareorder a_index a_ar=
+		let {
+		    f_aareorder' a_i= a_ar ! (a_index ! a_i)
+		 } in  tabulate f_aareorder' (bounds a_ar);
+	    r_index=tabulate ((+) 1) (1,1);
 	    arr    = listArray (1,1) a_xs;
 	    arg    = f_aareorder r_index arr
-         } in  elems arg
+	 } in  elems arg
 @
 Now, when the RHS of arg gets simplified, we inline f_aareorder to get
 @
-	arg  = let f_aareorder' a_i = arr ! (r_index ! a_i) 
+	arg  = let f_aareorder' a_i = arr ! (r_index ! a_i)
 	       in tabulate f_aareorder' (bounds arr)
 @
 Note that r_index is not inlined, because it was bound to a_index which
@@ -896,11 +705,11 @@ extendUnfoldEnvGivenRhs env@(SimplEnv chkr encl_cc ty_env id_env unfold_env)
 
 	-- Compute unfolding details
     details = case rhs of
-		CoVar v			   -> panic "CoVars already dealt with"
-		CoLit lit | isNoRepLit lit -> LiteralForm lit
-			  | otherwise	   -> panic "non-noRep CoLits already dealt with"
+		Var v			   -> panic "Vars already dealt with"
+		Lit lit | isNoRepLit lit -> LitForm lit
+			  | otherwise	   -> panic "non-noRep Lits already dealt with"
 
-		CoCon con tys args 	   -> ConstructorForm con tys args
+		Con con args 		   -> ConForm con args
 
 		other -> mkGenForm ok_to_dup occ_info
 				   (mkFormSummary (getIdStrictness out_id) rhs)
@@ -909,7 +718,7 @@ extendUnfoldEnvGivenRhs env@(SimplEnv chkr encl_cc ty_env id_env unfold_env)
 	-- Compute resulting unfold env
     new_unfold_env = case details of
 			NoUnfoldingDetails	-> unfold_env
-			GeneralForm _ _ _ _	-> unfold_env2{-test: unfold_env1 -}
+			GenForm _ _ _ _	-> unfold_env2{-test: unfold_env1 -}
 			other			-> unfold_env1
 
 	-- Add unfolding to unfold env
@@ -934,7 +743,7 @@ extendUnfoldEnvGivenRhs env@(SimplEnv chkr encl_cc ty_env id_env unfold_env)
 		      Nothing -> uNFOLDING_CREATION_THRESHOLD
 		      Just xx -> xx
 
-    ok_to_dup     = switchIsOn chkr SimplOkToDupCode 
+    ok_to_dup     = switchIsOn chkr SimplOkToDupCode
 			|| exprSmallEnoughToDup rhs
 			-- [Andy] added, Jun 95
 
@@ -953,36 +762,15 @@ extendUnfoldEnvGivenRhs env@(SimplEnv chkr encl_cc ty_env id_env unfold_env)
     --	   False -> g x
 -}
 {- OLD:
-   Omitted SLPJ Feb 95; should, I claim, be unnecessary 
+   Omitted SLPJ Feb 95; should, I claim, be unnecessary
 	-- is_really_small looks for things like f a b c
 	-- but making sure there are not *too* many arguments.
 	-- (This is brought to you by *ANDY* Magic Constants, Inc.)
     is_really_small
       = case collectArgs new_rhs of
-	  (CoVar _, xs) -> length xs < 10
+	  (Var _, xs) -> length xs < 10
 	  _ -> False
 -}
-
-
-{- UNUSED:
-extendUnfoldEnvWithRecInlinings :: SimplEnv -> [OutId] -> [InExpr] -> SimplEnv
-
-extendUnfoldEnvWithRecInlinings env@(SimplEnv chkr encl_cc ty_env id_env unfold_env)
-				new_ids old_rhss
-  = SimplEnv chkr encl_cc ty_env id_env new_unfold_env
-  where
-    extra_unfold_items
-      = [ (new_id, UnfoldItem new_id 
-			(GeneralForm True
-				     (mkFormSummary (getIdStrictness new_id) old_rhs)
-				     old_rhs UnfoldAlways) 
-			encl_cc)
-	| (new_id, old_rhs) <- new_ids `zipEqual` old_rhss,
-	  simplIdWantsToBeINLINEd new_id env
-	]
-
-    new_unfold_env = addto_unfold_env unfold_env extra_unfold_items
--}
 \end{code}
 
 \begin{code}
@@ -992,12 +780,12 @@ lookupUnfolding (SimplEnv _ _ _ _ unfold_env) var
   | not (isLocallyDefined var)	-- Imported, so look inside the id
   = getIdUnfolding var
 
-  | otherwise			-- Locally defined, so look in the envt.  
+  | otherwise			-- Locally defined, so look in the envt.
 				-- There'll be nothing inside the Id.
   = lookup_unfold_env unfold_env var
 \end{code}
 
-We need to remove any @GeneralForm@ bindings from the UnfoldEnv for
+We need to remove any @GenForm@ bindings from the UnfoldEnv for
 the RHS of an Id which has an INLINE pragma.
 
 \begin{code}
@@ -1011,26 +799,26 @@ filterUnfoldEnvForInlines env@(SimplEnv chkr encl_cc ty_env id_env unfold_env)
 	-- be inlined wherever they are used, and then all the
 	-- UnfoldEnv stuff will take effect.  Meanwhile, there isn't
 	-- much point in doing anything to the as-yet-un-INLINEd rhs.
-	
+
 	-- Andy disagrees! Example:
 	--	all xs = foldr (&&) True xs
 	--	any p = all . map p  {-# INLINE any #-}
-	-- 
-	-- Problem: any won't get deforested, and so if it's exported and 
+	--
+	-- Problem: any won't get deforested, and so if it's exported and
 	-- the importer doesn't use the inlining, (eg passes it as an arg)
 	-- then we won't get deforestation at all.
-	-- 
+	--
 	-- So he'd like not to filter the unfold env at all.  But that's a disaster:
 	-- Suppose we have:
 	--
 	-- let f = \pq -> BIG
-	-- in 
+	-- in
 	-- let g = \y -> f y y
 	--     {-# INLINE g #-}
 	-- in ...g...g...g...g...g...
-	-- 
+	--
 	-- Now, if that's the ONLY occurrence of f, it will be inlined inside g,
-	-- and thence copied multiple times when g is inlined. 
+	-- and thence copied multiple times when g is inlined.
 \end{code}
 
 ======================
@@ -1040,9 +828,9 @@ for nullary constructors:
 
 \begin{verbatim}
   = 	-- Don't re-use nullary constructors; it's a waste.  Consider
-	-- let 
+	-- let
 	-- 	  a = leInt#! p q
-	-- in 
+	-- in
 	-- case a of
 	--    True  -> ...
 	--    False -> False
@@ -1056,6 +844,6 @@ but now we only do constructor re-use in let-bindings the special
 case isn't necessary any more.
 
 \begin{code}
-lookForConstructor (SimplEnv _ _ _ _ unfold_env) con ty_args con_args
-  = lookup_conapp unfold_env con ty_args con_args
+lookForConstructor (SimplEnv _ _ _ _ unfold_env) con args
+  = lookup_conapp unfold_env con args
 \end{code}
diff --git a/ghc/compiler/simplCore/SimplHaskell.lhs b/ghc/compiler/simplCore/SimplHaskell.lhs
deleted file mode 100644
index d6d5027f01..0000000000
--- a/ghc/compiler/simplCore/SimplHaskell.lhs
+++ /dev/null
@@ -1,249 +0,0 @@
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1994
-%
-\section[SimplHaskell]{Printing Core that looks like Haskell}
-
-\begin{code}
-#include "HsVersions.h"
-
-module SimplHaskell ( coreToHaskell ) where
-
-IMPORT_Trace
-import Outputable
-import Pretty
-
-import BasicLit		( BasicLit )
-import PlainCore
-import IdEnv
-import IdInfo
-import Maybes
-import Util
-import AbsPrel		( PrimOp, nilDataCon, consDataCon )
-\end{code}
-
-\begin{code}
-coreToHaskell :: PlainCoreProgram -> String {- 0 -}
-coreToHaskell binds = ("[Haskell:\n\n" ++ ppShow 80 (pprHaskFuns (transformCoreProg binds)) ++ "\n\n]\n")
-\end{code}
-
-\begin{code}
-data HaskFun = HaskFun Id [([HaskExp],HaskExp)]
-
-data HaskExp 
-	= HaskVar Bool Id		-- true of used many times
-	| HaskLit BasicLit
-	| HaskWild
-	| HaskCon Id [HaskExp]
-	| HaskPrim PrimOp [HaskExp]
-	| HaskLam [HaskExp] HaskExp
-	| HaskApp HaskExp HaskExp
-	| HaskCase HaskExp [(HaskExp,HaskExp)] 
-	| HaskIf HaskExp HaskExp HaskExp
-	| HaskLet [HaskFun] HaskExp
-\end{code}
-
-Here is where the fun begins, you transform Core into Haskell!
-
-\begin{code}
-type InEnv = IdEnv HaskExp
-type OutEnv = IdEnv (Int,Bool)	-- number of times used, and if save to inline
-
-
-mkHaskPatVar :: OutEnv -> Id -> HaskExp
-mkHaskPatVar env id = case lookupIdEnv env id of
-			Nothing -> HaskWild
-			Just (n,_) -> HaskVar (n > 1) id
-
-transformCoreProg :: PlainCoreProgram -> [HaskFun]
-transformCoreProg prog = mergeCasesBindings funs
-  where
-   (_,_,funs) = transformCoreBindings nullIdEnv nullIdEnv prog
-
-transformCoreBindings :: InEnv -> OutEnv -> [PlainCoreBinding] -> (InEnv,OutEnv,[HaskFun])
-transformCoreBindings in_env out_env [bnd]      = transformCoreBinding in_env out_env bnd
-transformCoreBindings in_env out_env (bnd:bnds) = (in_env'',out_env',hask_bnd ++ hask_bnds)
-  where
-    (in_env',out_env',hask_bnd)    = transformCoreBinding in_env out_env'' bnd
-    (in_env'',out_env'',hask_bnds) = transformCoreBindings in_env' out_env bnds
-
-transformCoreBinding :: InEnv -> OutEnv -> PlainCoreBinding -> (InEnv,OutEnv,[HaskFun])
-transformCoreBinding in_env out_env (CoNonRec v expr) = (in_env',out_env'',[HaskFun v rhs])
-  where
-    out_env''      = merge out_env out_env'          
-    (out_env',rhs) = transformCoreRhs in_env expr
-    in_env'        = in_env `growIdEnvList` [ (v,exp) | [([],exp)] <- [rhs], False ]
-
-transformCoreBinding in_env out_env (CoRec bnds) = (in_env,out_env'',hask_bnds)
-  where
-    out_env''  = foldl merge out_env out_envs 
-    (out_envs,hask_bnds) = unzip
-		[ (out_env',HaskFun v rhs) |
-			(v,exp) <- bnds,
-			(out_env',rhs) <- [transformCoreRhs in_env exp]]
-
-
-transformCoreRhs :: InEnv -> PlainCoreExpr -> (OutEnv,[([HaskExp],HaskExp)])
-transformCoreRhs in_env exp = (out_env,[(vars',hask_exp)])
-    where
-	vars'		   = [ mkHaskPatVar out_env v | v <- vars ] 
-	(vars,exp')        = getLambdaVars exp
-	(out_env,hask_exp) = transformCoreExp in_env exp'
-	getLambdaVars (CoTyLam _ e) = getLambdaVars e
-	getLambdaVars (CoLam xs e) = (xs ++ xs',e')
-  	   where (xs',e') = getLambdaVars e
-	getLambdaVars e = ([],e)
-
-transformCoreExp :: InEnv -> PlainCoreExpr -> (OutEnv,HaskExp)
-transformCoreExp _      (CoVar v) = (unitIdEnv v (1,True),HaskVar False v)	-- lookup Env ?
-transformCoreExp _      (CoLit i) = (nullIdEnv,HaskLit i)
-transformCoreExp in_env (CoCon i _ atoms) = (out_env,HaskCon i hask_exps)
-  where
-    (out_env,hask_exps) = transformCoreExps in_env (map atomToExpr atoms)
-transformCoreExp in_env (CoPrim i _ atoms) = (out_env,HaskPrim i hask_exps)
-  where
-    (out_env,hask_exps) = transformCoreExps in_env (map atomToExpr atoms)
--- CoLam
--- CoTyLam
-transformCoreExp in_env (CoLam args exp) = (out_env,HaskLam args' h_exp)
-   where -- modify the env !!!!!
-	args' = [ mkHaskPatVar out_env v | v <- args ]
-	(out_env,h_exp) = transformCoreExp in_env exp
-transformCoreExp in_env (CoTyLam _ exp) = transformCoreExp in_env exp
-transformCoreExp in_env (CoApp fun atom) = (merge o1 o2,HaskApp h_fun h_arg)
-   where
-	(o1,h_fun) = transformCoreExp in_env fun
-	(o2,h_arg) = transformCoreExp in_env (atomToExpr atom)
-transformCoreExp in_env (CoTyApp fun _) = transformCoreExp in_env fun
-transformCoreExp in_env (CoCase e alts) = (foldl merge o1 o2,HaskCase h_e h_alts)
-   where
-	(o1,h_e)    = transformCoreExp in_env e
-	(o2,h_alts) = unzip [ (out_env,(pat,h_e)) | (out_env,pat,h_e) <- transformCoreAlts in_env alts ]
-
-transformCoreExp in_env exp@(CoLet _ _) = (o1,HaskLet h_binds h_exp)
-  where
-	(binds,exp') = getLets exp
-	(in_env',o1,h_binds) = transformCoreBindings in_env o2 binds
-	(o2,h_exp) = transformCoreExp in_env' exp'
-	getLets (CoLet bind exp) = (bind:binds,exp')
-	    where (binds,exp') = getLets exp
-	getLets exp = ([],exp)
-
-transformCoreExp _ _         = (nullIdEnv,HaskWild)
-
-transformCoreExps :: InEnv -> [PlainCoreExpr] -> (OutEnv,[HaskExp])
-transformCoreExps _ []          = (nullIdEnv,[])
-transformCoreExps in_env (e:es) = (merge o1 o2,h_e:hs_e)
-  where
-   (o1,h_e)  = transformCoreExp  in_env e
-   (o2,hs_e) = transformCoreExps in_env es
-
-transformCoreAlts :: InEnv -> PlainCoreCaseAlternatives -> [(OutEnv,HaskExp,HaskExp)]
-transformCoreAlts in_env (CoAlgAlts alts def) = map trans alts ++ mkdef def
-   where
-	trans (id,ids,e) = (o1,HaskCon id (map (mkHaskPatVar o1) ids),h_e)
-	   where
-		(o1,h_e) = transformCoreExp in_env e
-	mkdef (CoBindDefault bnd e) = [(o1,mkHaskPatVar o1 bnd,h_e)]
-	  where
-	    (o1,h_e) = transformCoreExp in_env e
-	mkdef _ = []
-transformCoreAlts in_env (CoPrimAlts alts def) = map trans alts ++ mkdef def
-   where
-	trans (lit,e) = (o1,HaskLit lit,h_e)
-	   where
-		(o1,h_e) = transformCoreExp in_env e
-	mkdef (CoBindDefault bnd e) = [(o1,mkHaskPatVar o1 bnd,h_e)]
-	  where
-	    (o1,h_e) = transformCoreExp in_env e
-	mkdef _ = []
-\end{code}
-
-\begin{code}
-merge :: OutEnv -> OutEnv -> OutEnv
-merge e1 e2 = combineIdEnvs fn e1 e2
-  where
-	fn (n,_) (m,_) = (n+m,False)
-\end{code}
-
-
-\begin{code}
-mergeCasesBindings = map mergeCasesFun 
-
-mergeCasesFun (HaskFun id rhss) = HaskFun id (concat (map mergeCasesRhs rhss))
-
-mergeCasesRhs (pats,exp) = [(pats,exp)]
-
-{-
-case v of 
-   A x -> e1	, v		==> Branch v  [ (A x,e1), (B y,e2) ]
-   B y -> e2			OR
-				    NoBranches (case v of 
-						  A x -> ...
-						  B y -> ...)
-
--}
---mergeCases :: HaskExp -> Set Id -> [(Id,HaskExp,HaskExp)]
---mergeCases _ _ = []
-\end{code}
-
-
-
-Maybe ???
-
-type SM a = OutEnv Z
-returnSH a s = (a,s)
-thenSH m k s = case m s of
-		(r,s') -> k r s
-thenSH_ m k s = case m s of
-		(_,s') -> k s
-
-\begin{code}
-pprHaskFuns xs = ppAboves (map pprHaskFun xs)
-
-pprHaskFun (HaskFun id stuff) = 
-	ppAboves [
-		ppSep [ ppCat ([ppr PprForUser id] ++ map (pprHaskExp True) pats),
-		        ppNest 2 (ppCat [ppStr "=",pprHaskExp False rhs])]
-		| (pats,rhs) <- stuff]
-
-pprHaskExp :: Bool -> HaskExp -> Pretty
-pprHaskExp _ (HaskVar _ id) = ppr PprForUser id
-pprHaskExp _ (HaskLit i)  = ppr PprForUser i
-pprHaskExp _ (HaskWild)   = ppStr "_"
-pprHaskExp True exp       = ppBesides [ppLparen,pprHaskExp False exp,ppRparen]
-pprHaskExp _ (HaskCon con []) | con == nilDataCon = ppStr "[]"
-pprHaskExp _ (HaskCon con [e1,e2]) | con == consDataCon =
-		ppCat [pprHaskExp True e1,ppStr ":",pprHaskExp True e2]
-pprHaskExp _ (HaskCon con exps) = 
-		ppCat (ppr PprForUser con:map (pprHaskExp True) exps)
-pprHaskExp _ (HaskPrim prim exps) = 
-		ppCat (ppr PprForUser prim:map (pprHaskExp True) exps)
-pprHaskExp _ app@(HaskLam xs e) = -- \ xs -> e
-	ppSep [ ppCat ([ppStr "\\"] ++ map (pprHaskExp True) xs),
-		ppNest 2 (ppCat [ppStr "->",pprHaskExp False e])]
-pprHaskExp _ app@(HaskApp _ _) = pprHaskApp app
-pprHaskExp _ (HaskCase e opts)
-  = ppAboves [ppCat [ppStr "case", pprHaskExp False e,ppStr "of"],
-	ppNest 2 (
-	   ppAboves [
-		(ppSep [ppCat [pprHaskExp False pat,ppStr "->"],
-				ppNest 2 (pprHaskExp False exp)])
-			| (pat,exp) <- opts])]
-pprHaskExp _ (HaskIf i t e) = ppAboves
-		[ppCat [ppStr "if",pprHaskExp False i],
-		 ppCat [ppStr "then",pprHaskExp False t],
-		 ppCat [ppStr "else",pprHaskExp False e]]
-pprHaskExp _ (HaskLet binds e)
-  = ppAboves [ppStr "let",
-	   ppNest 2 (pprHaskFuns binds),
-	   ppCat [ppStr "in",ppNest 1 (pprHaskExp False e)]]
-pprHaskExp _ _ = panic "pprHaskExp failed"
-
-
-pprHaskApp (HaskApp fun arg) = ppCat [pprHaskApp fun,pprHaskExp True arg]
-pprHaskApp e                 = pprHaskExp True e
-\end{code}
-
-
-
-pprHaskExp n exp = ppr
diff --git a/ghc/compiler/simplCore/SimplMonad.hi b/ghc/compiler/simplCore/SimplMonad.hi
deleted file mode 100644
index 611eead67d..0000000000
--- a/ghc/compiler/simplCore/SimplMonad.hi
+++ /dev/null
@@ -1,47 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface SimplMonad where
-import BasicLit(BasicLit)
-import BinderInfo(BinderInfo, DuplicationDanger, FunOrArg, InsideSCC)
-import CoreSyn(CoreAtom, CoreBinding, CoreCaseAlternatives, CoreExpr)
-import CostCentre(CostCentre)
-import Id(Id)
-import PrimOps(PrimOp)
-import SimplEnv(SimplEnv)
-import SplitUniq(SplitUniqSupply)
-import TyVar(TyVar)
-import UniType(UniType)
-infixr 9 `thenSmpl`
-infixr 9 `thenSmpl_`
-data BinderInfo 
-data CoreExpr a b 
-data Id 
-data PrimOp 
-data SimplCount 
-type SmplM a = SplitUniqSupply -> SimplCount -> (a, SimplCount)
-data SplitUniqSupply 
-data TickType   = UnfoldingDone | MagicUnfold | ConReused | CaseFloatFromLet | CaseOfCase | LetFloatFromLet | LetFloatFromCase | KnownBranch | Let2Case | CaseMerge | CaseElim | CaseIdentity | AtomicRhs | EtaExpansion | CaseOfError | TyBetaReduction | BetaReduction | FoldrBuild | FoldrAugment | Foldr_Nil | Foldr_List | FoldlBuild | FoldlAugment | Foldl_Nil | Foldl_List | Foldr_Cons_Nil | Foldr_Cons | Str_FoldrStr | Str_UnpackCons | Str_UnpackNil
-data TyVar 
-data UniType 
-cloneId :: SimplEnv -> (Id, BinderInfo) -> SplitUniqSupply -> SimplCount -> (Id, SimplCount)
-cloneIds :: SimplEnv -> [(Id, BinderInfo)] -> SplitUniqSupply -> SimplCount -> ([Id], SimplCount)
-cloneTyVarSmpl :: TyVar -> SplitUniqSupply -> SimplCount -> (TyVar, SimplCount)
-combineSimplCounts :: SimplCount -> SimplCount -> SimplCount
-detailedSimplCount :: SplitUniqSupply -> SimplCount -> (SimplCount, SimplCount)
-initSmpl :: SplitUniqSupply -> (SplitUniqSupply -> SimplCount -> (a, SimplCount)) -> (a, SimplCount)
-mapAndUnzipSmpl :: (a -> SplitUniqSupply -> SimplCount -> ((b, c), SimplCount)) -> [a] -> SplitUniqSupply -> SimplCount -> (([b], [c]), SimplCount)
-mapSmpl :: (a -> SplitUniqSupply -> SimplCount -> (b, SimplCount)) -> [a] -> SplitUniqSupply -> SimplCount -> ([b], SimplCount)
-newId :: UniType -> SplitUniqSupply -> SimplCount -> (Id, SimplCount)
-newIds :: [UniType] -> SplitUniqSupply -> SimplCount -> ([Id], SimplCount)
-returnSmpl :: a -> SplitUniqSupply -> SimplCount -> (a, SimplCount)
-showSimplCount :: SimplCount -> [Char]
-simplCount :: SplitUniqSupply -> SimplCount -> (Int, SimplCount)
-thenSmpl :: (SplitUniqSupply -> SimplCount -> (a, SimplCount)) -> (a -> SplitUniqSupply -> SimplCount -> (b, SimplCount)) -> SplitUniqSupply -> SimplCount -> (b, SimplCount)
-thenSmpl_ :: (SplitUniqSupply -> SimplCount -> (a, SimplCount)) -> (SplitUniqSupply -> SimplCount -> (b, SimplCount)) -> SplitUniqSupply -> SimplCount -> (b, SimplCount)
-tick :: TickType -> SplitUniqSupply -> SimplCount -> ((), SimplCount)
-tickN :: TickType -> Int -> SplitUniqSupply -> SimplCount -> ((), SimplCount)
-zeroSimplCount :: SimplCount
-instance Eq TickType
-instance Ix TickType
-instance Ord TickType
-instance Text TickType
-
diff --git a/ghc/compiler/simplCore/SimplMonad.lhs b/ghc/compiler/simplCore/SimplMonad.lhs
index de3bc24869..bc8fac77a7 100644
--- a/ghc/compiler/simplCore/SimplMonad.lhs
+++ b/ghc/compiler/simplCore/SimplMonad.lhs
@@ -1,5 +1,5 @@
 %
-% (c) The AQUA Project, Glasgow University, 1993-1995
+% (c) The AQUA Project, Glasgow University, 1993-1996
 %
 \section[SimplMonad]{The simplifier Monad}
 
@@ -10,43 +10,39 @@ module SimplMonad (
 	SmplM(..),
 	initSmpl, returnSmpl, thenSmpl, thenSmpl_,
 	mapSmpl, mapAndUnzipSmpl,
-	
+
 	-- Counting
 	SimplCount{-abstract-}, TickType(..), tick, tickN,
 	simplCount, detailedSimplCount,
 	zeroSimplCount, showSimplCount, combineSimplCounts,
 
 	-- Cloning
-	cloneId, cloneIds, cloneTyVarSmpl, newIds, newId,
+	cloneId, cloneIds, cloneTyVarSmpl, newIds, newId
 
 	-- and to make the interface self-sufficient...
-	BinderInfo, CoreExpr, Id, PrimOp, TyVar, UniType,
-	SplitUniqSupply
-
-	IF_ATTACK_PRAGMAS(COMMA splitUniqSupply)
     ) where
 
-IMPORT_Trace		-- ToDo: rm (debugging)
+import Ubiq{-uitous-}
 
-import TaggedCore
-import PlainCore
+import SmplLoop		-- well, cheating sort of
 
-import AbsUniType	( cloneTyVar )
-import CmdLineOpts
-import Id		( mkIdWithNewUniq, mkSysLocal )
-import IdInfo
+import Id		( mkSysLocal )
 import SimplEnv
-import SrcLoc		( mkUnknownSrcLoc, SrcLoc )
-import SplitUniq
-import Unique
-import Util
+import SrcLoc		( mkUnknownSrcLoc )
+import UniqSupply	( getUnique, getUniques, splitUniqSupply,
+			  UniqSupply
+			)
+import Util		( zipWithEqual, panic )
 
 infixr 9  `thenSmpl`, `thenSmpl_`
+
+cloneTyVar = panic "cloneTyVar (SimplMonad)"
+mkIdWithNewUniq = panic "mkIdWithNewUniq (SimplMonad)"
 \end{code}
 
 %************************************************************************
 %*									*
-\subsection[Monad]{Monad plumbing}
+\subsection{Monad plumbing}
 %*									*
 %************************************************************************
 
@@ -55,23 +51,21 @@ For the simplifier monad, we want to {\em thread} a unique supply and a counter.
 
 \begin{code}
 type SmplM result
-  = SplitUniqSupply
+  = UniqSupply
   -> SimplCount    -- things being threaded
   -> (result, SimplCount)
 \end{code}
 
 \begin{code}
-initSmpl :: SplitUniqSupply -- no init count; set to 0
+initSmpl :: UniqSupply -- no init count; set to 0
 	  -> SmplM a
 	  -> (a, SimplCount)
 
 initSmpl us m = m us zeroSimplCount
 
-#ifdef __GLASGOW_HASKELL__
 {-# INLINE thenSmpl #-}
 {-# INLINE thenSmpl_ #-}
 {-# INLINE returnSmpl #-}
-#endif
 
 returnSmpl :: a -> SmplM a
 returnSmpl e us sc = (e, sc)
@@ -108,7 +102,7 @@ mapAndUnzipSmpl f (x:xs)
 
 %************************************************************************
 %*									*
-\subsection[SimplCount]{Counting up what we've done}
+\subsection{Counting up what we've done}
 %*									*
 %************************************************************************
 
@@ -137,15 +131,15 @@ data TickType
   | BetaReduction
   {- BEGIN F/B ENTRIES -}
   -- the 8 rules
-  | FoldrBuild	     	-- foldr f z (build g) ==>     
-  | FoldrAugment	-- foldr f z (augment g z) ==> 
-  | Foldr_Nil		-- foldr f z [] ==>            
-  | Foldr_List		-- foldr f z (x:...) ==>       
+  | FoldrBuild	     	-- foldr f z (build g) ==>
+  | FoldrAugment	-- foldr f z (augment g z) ==>
+  | Foldr_Nil		-- foldr f z [] ==>
+  | Foldr_List		-- foldr f z (x:...) ==>
 
-  | FoldlBuild	        -- foldl f z (build g) ==>     
-  | FoldlAugment	-- foldl f z (augment g z) ==> 
-  | Foldl_Nil		-- foldl f z [] ==>            
-  | Foldl_List		-- foldl f z (x:...) ==>       
+  | FoldlBuild	        -- foldl f z (build g) ==>
+  | FoldlAugment	-- foldl f z (augment g z) ==>
+  | Foldl_Nil		-- foldl f z [] ==>
+  | Foldl_List		-- foldl f z (x:...) ==>
 
   | Foldr_Cons_Nil	-- foldr (:) [] => id
   | Foldr_Cons		-- foldr (:) => flip (++)
@@ -233,11 +227,11 @@ zeroSimplCount
 	(Foldr_Cons_Nil, 0),
 	(Foldr_Cons, 0),
 
-        (Str_FoldrStr, 0),
-        (Str_UnpackCons, 0),
-        (Str_UnpackNil, 0) ]
+	(Str_FoldrStr, 0),
+	(Str_UnpackCons, 0),
+	(Str_UnpackNil, 0) ]
 --
---= array (con2tag_TickType UnfoldingDone, con2tag_TickType FoldrInline) 
+--= array (con2tag_TickType UnfoldingDone, con2tag_TickType FoldrInline)
 --        [ i := 0 | i <- indices zeroSimplCount ]
 \end{code}
 
@@ -261,7 +255,7 @@ tick tick_type us (SimplCount n stuff)
 		incd = cnt + 1
 	    in
 	    (ttype, incd) : xs
-        else
+	else
 	    x : inc_tick xs
 
 tickN :: TickType -> Int -> SmplM ()
@@ -282,7 +276,7 @@ tickN tick_type IBOX(increment) us (SimplCount n stuff)
 		incd = cnt + IBOX(increment)
 	    in
 	    (ttype, incd) : xs
-        else
+	else
 	    x : inc_tick xs
 
 simplCount :: SmplM Int
@@ -300,7 +294,7 @@ combineSimplCounts (SimplCount n1 stuff1) (SimplCount n2 stuff2)
 #else
 combineSimplCounts (SimplCount n1 stuff1) (SimplCount n2 stuff2)
   = SimplCount (n1 _ADD_ n2)
-	       (zipWith (\ (t1,c1) (t2,c2) -> (t1,c1+c2)) stuff1 stuff2)
+	       (zipWithEqual (\ (t1,c1) (t2,c2) -> (t1,c1+c2)) stuff1 stuff2)
 #endif
 \end{code}
 
@@ -311,17 +305,17 @@ combineSimplCounts (SimplCount n1 stuff1) (SimplCount n2 stuff2)
 %************************************************************************
 
 \begin{code}
-newId :: UniType -> SmplM Id
+newId :: Type -> SmplM Id
 newId ty us sc
   = (mkSysLocal SLIT("s") uniq ty mkUnknownSrcLoc, sc)
   where
-    uniq = getSUnique us
+    uniq = getUnique us
 
-newIds :: [UniType] -> SmplM [Id]
+newIds :: [Type] -> SmplM [Id]
 newIds tys us sc
-  = (zipWith mk_id tys uniqs, sc)
+  = (zipWithEqual mk_id tys uniqs, sc)
   where
-    uniqs  = getSUniques (length tys) us
+    uniqs  = getUniques (length tys) us
     mk_id ty uniq = mkSysLocal SLIT("s") uniq ty mkUnknownSrcLoc
 
 cloneTyVarSmpl :: TyVar -> SmplM TyVar
@@ -329,7 +323,7 @@ cloneTyVarSmpl :: TyVar -> SmplM TyVar
 cloneTyVarSmpl tyvar us sc
   = (new_tyvar, sc)
   where
-   uniq = getSUnique us
+   uniq = getUnique us
    new_tyvar = cloneTyVar tyvar uniq
 
 cloneId :: SimplEnv -> InBinder -> SmplM OutId
@@ -337,7 +331,7 @@ cloneId env (id,_) us sc
   = (mkIdWithNewUniq id_with_new_ty uniq, sc)
   where
     id_with_new_ty = simplTyInId env id
-    uniq = getSUnique us
+    uniq = getUnique us
 
 cloneIds :: SimplEnv -> [InBinder] -> SmplM [OutId]
 cloneIds env binders = mapSmpl (cloneId env) binders
diff --git a/ghc/compiler/simplCore/SimplPgm.hi b/ghc/compiler/simplCore/SimplPgm.hi
deleted file mode 100644
index a330759912..0000000000
--- a/ghc/compiler/simplCore/SimplPgm.hi
+++ /dev/null
@@ -1,9 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface SimplPgm where
-import CmdLineOpts(GlobalSwitch, SimplifierSwitch, SwitchResult)
-import CoreSyn(CoreBinding)
-import Id(Id)
-import SimplMonad(SimplCount)
-import SplitUniq(SplitUniqSupply)
-simplifyPgm :: [CoreBinding Id Id] -> (GlobalSwitch -> SwitchResult) -> (SimplifierSwitch -> SwitchResult) -> SimplCount -> SplitUniqSupply -> ([CoreBinding Id Id], Int, SimplCount)
-
diff --git a/ghc/compiler/simplCore/SimplPgm.lhs b/ghc/compiler/simplCore/SimplPgm.lhs
index 6daa81d69f..ee791a6606 100644
--- a/ghc/compiler/simplCore/SimplPgm.lhs
+++ b/ghc/compiler/simplCore/SimplPgm.lhs
@@ -8,18 +8,11 @@
 
 module SimplPgm ( simplifyPgm ) where
 
-import PlainCore
-import TaggedCore
-
-import Pretty		-- ToDo: rm debugging
-IMPORT_Trace
-
-import AbsUniType	( getTyVarMaybe )
+import Type		( getTyVarMaybe )
 import CmdLineOpts	( switchIsOn, intSwitchSet,
 			  GlobalSwitch(..), SimplifierSwitch(..)
 			)
-import Id		( cmpId, externallyVisibleId )
-import IdEnv
+import Id		( externallyVisibleId )
 import IdInfo
 import Maybes		( catMaybes, Maybe(..) )
 import Outputable
@@ -27,23 +20,18 @@ import SimplEnv
 import SimplMonad
 import Simplify		( simplTopBinds )
 import OccurAnal	-- occurAnalyseBinds
-#if ! OMIT_FOLDR_BUILD
-import NewOccurAnal	-- newOccurAnalyseBinds
-#endif
-import TyVarEnv		-- ( nullTyVarEnv )
-import SplitUniq
-import Unique
+import UniqSupply
 import Util
 \end{code}
 
 \begin{code}
-simplifyPgm :: [PlainCoreBinding]		-- input
+simplifyPgm :: [CoreBinding]		-- input
 	    -> (GlobalSwitch->SwitchResult)	-- switch lookup fns (global
 	    -> (SimplifierSwitch->SwitchResult) -- and this-simplification-specific)
 	    -> SimplCount                       -- info about how many times
 						-- each transformation has occurred
-	    -> SplitUniqSupply
-	    -> ([PlainCoreBinding],	-- output
+	    -> UniqSupply
+	    -> ([CoreBinding],	-- output
 		 Int,			-- info about how much happened
 		 SimplCount)		-- accumulated simpl stats
 
@@ -56,20 +44,14 @@ simplifyPgm binds g_sw_chkr s_sw_chkr simpl_stats us
     global_switch_is_on = switchIsOn g_sw_chkr
     simpl_switch_is_on  = switchIsOn s_sw_chkr
 
-#if OMIT_FOLDR_BUILD
     occur_anal = occurAnalyseBinds
-#else
-    occur_anal = if simpl_switch_is_on SimplDoNewOccurAnal 
-		 then newOccurAnalyseBinds
-		 else occurAnalyseBinds
-#endif
 
     max_simpl_iterations
       = case (intSwitchSet s_sw_chkr MaxSimplifierIterations) of
 	  Nothing  -> 1    -- default
 	  Just max -> max
 
-    simpl_pgm :: Int -> Int -> [PlainCoreBinding] -> SmplM ([PlainCoreBinding], Int, SimplCount)
+    simpl_pgm :: Int -> Int -> [CoreBinding] -> SmplM ([CoreBinding], Int, SimplCount)
 
     simpl_pgm n iterations pgm
       =	-- find out what top-level binders are used,
@@ -104,11 +86,11 @@ simplifyPgm binds g_sw_chkr s_sw_chkr simpl_stats us
 	(let stop_now = r == n {-nothing happened-}
 		     || (if iterations > max_simpl_iterations then
 			    (if max_simpl_iterations > 1 {-otherwise too boring-} then
-				trace 
+				trace
 				("NOTE: Simplifier still going after "++show max_simpl_iterations++" iterations; bailing out.")
 			     else id)
 			    True
-			 else 
+			 else
 			    False)
 	in
 	if stop_now then
@@ -143,26 +125,26 @@ type BlastEnv = IdEnv Id  -- domain is local Ids; range is exported Ids
 
 not_elem = isn'tIn "undup"
 
-tidy_top :: [PlainCoreBinding] -> SUniqSM [PlainCoreBinding]
+tidy_top :: [CoreBinding] -> UniqSM [CoreBinding]
 
 tidy_top binds_in
   = if null blast_alist then
-	returnSUs binds_in    -- no joy there
+	returnUs binds_in    -- no joy there
     else
 	-- pprTrace "undup output length:" (ppInt (length blast_alist)) (
-	mapSUs blast binds_in	`thenSUs` \ binds_maybe ->
-	returnSUs (catMaybes binds_maybe)
+	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, CoVar e) | (l,e) <- blast_alist ]
+    blast_val_env= mkIdEnv [ (l, Var e) | (l,e) <- blast_alist ]
     blast_all_exps = map snd blast_alist
 
     ---------
-    find_cand blast_list (CoRec _) = blast_list	-- recursively paranoid, as usual
+    find_cand blast_list (Rec _) = blast_list	-- recursively paranoid, as usual
 
-    find_cand blast_list (CoNonRec binder rhs)
+    find_cand blast_list (NonRec binder rhs)
       = if not (isExported binder) then
 	   blast_list
     	else
@@ -178,73 +160,48 @@ tidy_top binds_in
     undup blast_list
       = -- pprTrace "undup input length:" (ppInt (length blast_list)) (
 	let
-	    (singles, dups) = removeDups cmp blast_list
+	    (singles, dups) = removeDups compare blast_list
 	    list_of_dups    = concat dups
 	in
 	[ s | s <- singles, s `not_elem` list_of_dups ]
 	-- )
       where
-        cmp (x,_) (y,_) = x `cmpId` y
+	compare (x,_) (y,_) = x `cmp` y
 
     ------------------------------------------
-    rhs_equiv_to_local_var (CoVar x)
+    rhs_equiv_to_local_var (Var x)
       = if externallyVisibleId x then Nothing else Just x
 
     rhs_equiv_to_local_var expr = Nothing
-{- MAYBE NOT:
-      = case (digForLambdas expr) of { (tyvars, binders, body) ->
-	case (collectArgs   body) of { (fun, args) ->
-	case fun of
-	  CoVar x -> if   null binders
-		       && not (isExported x)
-		       && tylams_match_tyargs tyvars args then
-		       -- may need to chk for "tyvars" occurring in "x"'s type
-		        Just x
-		     else
-		        Nothing
-	  _ -> Nothing
-        }}
-      where
-	-- looking for a very restricted special case:
-	-- /\ tv1 tv2 ... -> var tv1 tv2 ...
-
-	tylams_match_tyargs []       [] = True
-	tylams_match_tyargs (tv:tvs) (TypeArg ty : args)
-	  = ASSERT(not (isPrimType ty))
-	    case (getTyVarMaybe ty) of
-	      Nothing    -> False
-	      Just tyvar -> tv == tyvar
-	tylams_match_tyargs _ _ = False
--}
 
     ------------------------------------------
     -- "blast" does the substitution:
     -- returns Nothing  if a binding goes away
     -- returns "Just b" to give back a fixed-up binding
 
-    blast :: PlainCoreBinding -> SUniqSM (Maybe PlainCoreBinding)
+    blast :: CoreBinding -> UniqSM (Maybe CoreBinding)
 
-    blast (CoRec pairs)
-      = mapSUs blast_pr pairs `thenSUs` \ blasted_pairs ->
-	returnSUs (Just (CoRec blasted_pairs))
+    blast (Rec pairs)
+      = mapUs blast_pr pairs `thenUs` \ blasted_pairs ->
+	returnUs (Just (Rec blasted_pairs))
       where
 	blast_pr (binder, rhs)
-	  = subst_CoreExprUS blast_val_env nullTyVarEnv rhs `thenSUs` \ blasted_rhs ->
-	    returnSUs (
+	  = subst_CoreExprUS blast_val_env nullTyVarEnv rhs `thenUs` \ blasted_rhs ->
+	    returnUs (
 	    case lookupIdEnv blast_id_env binder of
 	      Just exportee -> (exportee, blasted_rhs)
 	      Nothing	    -> (binder,   blasted_rhs)
 	    )
 
-    blast (CoNonRec binder rhs)
+    blast (NonRec binder rhs)
       = if binder `is_elem` blast_all_exps then
-	   returnSUs Nothing -- this binding dies!
+	   returnUs Nothing -- this binding dies!
     	else
-	   subst_CoreExprUS blast_val_env nullTyVarEnv rhs `thenSUs` \ blasted_rhs ->
-	   returnSUs (Just (
+	   subst_CoreExprUS blast_val_env nullTyVarEnv rhs `thenUs` \ blasted_rhs ->
+	   returnUs (Just (
 	   case lookupIdEnv blast_id_env binder of
-	     Just exportee -> CoNonRec exportee blasted_rhs
-	     Nothing	   -> CoNonRec binder   blasted_rhs
+	     Just exportee -> NonRec exportee blasted_rhs
+	     Nothing	   -> NonRec binder   blasted_rhs
 	   ))
       where
 	is_elem = isIn "blast"
diff --git a/ghc/compiler/simplCore/SimplUtils.hi b/ghc/compiler/simplCore/SimplUtils.hi
deleted file mode 100644
index 138f518cf0..0000000000
--- a/ghc/compiler/simplCore/SimplUtils.hi
+++ /dev/null
@@ -1,18 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface SimplUtils where
-import BinderInfo(BinderInfo)
-import CoreSyn(CoreCaseAlternatives, CoreExpr)
-import Id(Id)
-import SimplEnv(SimplEnv)
-import SimplMonad(SimplCount)
-import SplitUniq(SplitUniqSupply)
-import TyVar(TyVar)
-import UniType(UniType)
-etaExpandCount :: CoreExpr a Id -> Int
-floatExposesHNF :: Bool -> Bool -> Bool -> CoreExpr a Id -> Bool
-mkCoLamTryingEta :: [Id] -> CoreExpr Id Id -> CoreExpr Id Id
-mkCoTyLamTryingEta :: [TyVar] -> CoreExpr Id Id -> CoreExpr Id Id
-mkIdentityAlts :: UniType -> SplitUniqSupply -> SimplCount -> (CoreCaseAlternatives (Id, BinderInfo) Id, SimplCount)
-simplIdWantsToBeINLINEd :: Id -> SimplEnv -> Bool
-type_ok_for_let_to_case :: UniType -> Bool
-
diff --git a/ghc/compiler/simplCore/SimplUtils.lhs b/ghc/compiler/simplCore/SimplUtils.lhs
index 3d4961f161..d1bd744fce 100644
--- a/ghc/compiler/simplCore/SimplUtils.lhs
+++ b/ghc/compiler/simplCore/SimplUtils.lhs
@@ -1,5 +1,5 @@
 %
-% (c) The AQUA Project, Glasgow University, 1993-1995
+% (c) The AQUA Project, Glasgow University, 1993-1996
 %
 \section[SimplUtils]{The simplifier utilities}
 
@@ -9,11 +9,11 @@
 module SimplUtils (
 
 	floatExposesHNF,
-	
+
 	mkCoTyLamTryingEta, mkCoLamTryingEta,
 
 	etaExpandCount,
-	
+
 	mkIdentityAlts,
 
 	simplIdWantsToBeINLINEd,
@@ -24,25 +24,22 @@ module SimplUtils (
 IMPORT_Trace		-- ToDo: rm (debugging)
 import Pretty
 
-import TaggedCore
-import PlainCore
 import SimplEnv
 import SimplMonad
 
 import BinderInfo
 
-import AbsPrel		( primOpIsCheap, realWorldStateTy,
+import PrelInfo		( primOpIsCheap, realWorldStateTy,
 			  buildId, augmentId
 			  IF_ATTACK_PRAGMAS(COMMA realWorldTy)
 			  IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
 			  IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
 			)
-import AbsUniType	( extractTyVarsFromTy, getTyVarMaybe, isPrimType,
-			  splitTypeWithDictsAsArgs, getUniDataTyCon_maybe,
+import Type		( extractTyVarsFromTy, getTyVarMaybe, isPrimType,
+			  splitTypeWithDictsAsArgs, maybeDataTyCon,
 			  applyTy, isFunType, TyVar, TyVarTemplate
-			  IF_ATTACK_PRAGMAS(COMMA cmpTyVar COMMA cmpClass)
 			)
-import Id		( getInstantiatedDataConSig, isDataCon, getIdUniType,
+import Id		( getInstantiatedDataConSig, isDataCon, idType,
 			  getIdArity, isBottomingId, idWantsToBeINLINEd,
 			  DataCon(..), Id
 			)
@@ -65,25 +62,25 @@ floatExposesHNF
 	:: Bool 		-- Float let(rec)s out of rhs
 	-> Bool 		-- Float cheap primops out of rhs
 	-> Bool 		-- OK to duplicate code
-	-> CoreExpr bdr Id
+	-> GenCoreExpr bdr Id
 	-> Bool
 
 floatExposesHNF float_lets float_primops ok_to_dup rhs
   = try rhs
   where
-    try (CoCase (CoPrim _ _ _) (CoPrimAlts alts deflt) )
+    try (Case (Prim _ _ _) (PrimAlts alts deflt) )
       | float_primops && (null alts || ok_to_dup)
       = or (try_deflt deflt : map try_alt alts)
 
-    try (CoLet bind body) | float_lets = try body
+    try (Let bind body) | float_lets = try body
 
     --    `build g'
     -- is like a HNF,
     -- because it *will* become one.
     -- likewise for `augment g h'
     --
-    try (CoApp (CoTyApp (CoVar bld) _) _) | bld == buildId = True
-    try (CoApp (CoApp (CoTyApp (CoVar bld) _) _) _) | bld == augmentId = True
+    try (App (CoTyApp (Var bld) _) _) | bld == buildId = True
+    try (App (App (CoTyApp (Var bld) _) _) _) | bld == augmentId = True
 
     try other = manifestlyWHNF other
 	{- but *not* necessarily "manifestlyBottom other"...
@@ -104,8 +101,8 @@ floatExposesHNF float_lets float_primops ok_to_dup rhs
 
     try_alt (lit,rhs)               = try rhs
 
-    try_deflt CoNoDefault           = False
-    try_deflt (CoBindDefault _ rhs) = try rhs 
+    try_deflt NoDefault           = False
+    try_deflt (BindDefault _ rhs) = try rhs
 \end{code}
 
 
@@ -116,7 +113,7 @@ We have a go at doing
 	\ x y -> f x y	===>  f
 
 But we only do this if it gets rid of a whole lambda, not part.
-The idea is that lambdas are often quite helpful: they indicate 
+The idea is that lambdas are often quite helpful: they indicate
 head normal forms, so we don't want to chuck them away lightly.
 But if they expose a simple variable then we definitely win.  Even
 if they expose a type application we win.  So we check for this special
@@ -131,24 +128,24 @@ f turns out to be just a single call to this recursive function.
 
 \begin{code}
 mkCoLamTryingEta :: [Id]		-- Args to the lambda
-	       -> PlainCoreExpr		-- Lambda body
-	       -> PlainCoreExpr
+	       -> CoreExpr		-- Lambda body
+	       -> CoreExpr
 
 mkCoLamTryingEta [] body = body
 
 mkCoLamTryingEta orig_ids body
   = reduce_it (reverse orig_ids) body
   where
-    bale_out = mkCoLam orig_ids body
+    bale_out = mkValLam orig_ids body
 
     reduce_it [] residual
       | residual_ok residual = residual
       | otherwise	     = bale_out
 
-    reduce_it (id:ids) (CoApp fun (CoVarAtom arg))
+    reduce_it (id:ids) (App fun (VarArg arg))
       | id == arg
-      && getIdUniType id /= realWorldStateTy
-         -- *never* eta-reduce away a PrimIO state token! (WDP 94/11)
+      && idType id /= realWorldStateTy
+	 -- *never* eta-reduce away a PrimIO state token! (WDP 94/11)
       = reduce_it ids fun
 
     reduce_it ids other = bale_out
@@ -156,11 +153,11 @@ mkCoLamTryingEta orig_ids body
     is_elem = isIn "mkCoLamTryingEta"
 
     -----------
-    residual_ok :: PlainCoreExpr -> Bool	-- Checks for type application
-						-- and function not one of the 
+    residual_ok :: CoreExpr -> Bool	-- Checks for type application
+						-- and function not one of the
 						-- bound vars
     residual_ok (CoTyApp fun ty) = residual_ok fun
-    residual_ok (CoVar v)        = not (v `is_elem` orig_ids)	-- Fun mustn't be one of
+    residual_ok (Var v)        = not (v `is_elem` orig_ids)	-- Fun mustn't be one of
 								-- the bound ids
     residual_ok other	         = False
 \end{code}
@@ -182,44 +179,44 @@ arguments as you care to give it.  For this special case we return 100,
 to represent "infinity", which is a bit of a hack.
 
 \begin{code}
-etaExpandCount :: CoreExpr bdr Id
+etaExpandCount :: GenCoreExpr bdr Id
 	       -> Int			-- Number of extra args you can safely abstract
 
-etaExpandCount (CoLam ids body)
-  = length ids + etaExpandCount body
+etaExpandCount (Lam _ body)
+  = 1 + etaExpandCount body
 
-etaExpandCount (CoLet bind body) 
-  | all manifestlyCheap (rhssOfBind bind) 
+etaExpandCount (Let bind body)
+  | all manifestlyCheap (rhssOfBind bind)
   = etaExpandCount body
-   
-etaExpandCount (CoCase scrut alts)
-  | manifestlyCheap scrut 
+
+etaExpandCount (Case scrut alts)
+  | manifestlyCheap scrut
   = minimum [etaExpandCount rhs | rhs <- rhssOfAlts alts]
 
-etaExpandCount (CoApp fun _) = case etaExpandCount fun of
+etaExpandCount (App fun _) = case etaExpandCount fun of
 				0 -> 0
 				n -> n-1	-- Knock off one
 
 etaExpandCount fun@(CoTyApp _ _) = eta_fun fun
-etaExpandCount fun@(CoVar _)     = eta_fun fun
+etaExpandCount fun@(Var _)     = eta_fun fun
 
 etaExpandCount other = 0			-- Give up
-	-- CoLit, CoCon, CoPrim, 
+	-- Lit, Con, Prim,
 	-- CoTyLam,
-	-- CoScc (pessimistic; ToDo),
-	-- CoLet with non-whnf rhs(s),
-	-- CoCase with non-whnf scrutinee
+	-- Scc (pessimistic; ToDo),
+	-- Let with non-whnf rhs(s),
+	-- Case with non-whnf scrutinee
 
-eta_fun :: CoreExpr bdr Id 	-- The function
+eta_fun :: GenCoreExpr bdr Id 	-- The function
 	-> Int			-- How many args it can safely be applied to
 
 eta_fun (CoTyApp fun ty) = eta_fun fun
 
-eta_fun expr@(CoVar v)
+eta_fun expr@(Var v)
   | isBottomingId v			-- Bottoming ids have "infinite arity"
   = 10000				-- Blargh.  Infinite enough!
 
-eta_fun expr@(CoVar v)
+eta_fun expr@(Var v)
   | maybeToBool arity_maybe		-- We know the arity
   = arity
   where
@@ -235,7 +232,7 @@ By ``cheap'' we mean a computation we're willing to duplicate in order
 to bring a couple of lambdas together.  The main examples of things
 which aren't WHNF but are ``cheap'' are:
 
-  * 	case e of 
+  * 	case e of
 	  pi -> ei
 
 	where e, and all the ei are cheap; and
@@ -250,35 +247,35 @@ which aren't WHNF but are ``cheap'' are:
 	where op is a cheap primitive operator
 
 \begin{code}
-manifestlyCheap :: CoreExpr bndr Id -> Bool
+manifestlyCheap :: GenCoreExpr bndr Id -> Bool
 
-manifestlyCheap (CoVar _)       = True
-manifestlyCheap (CoLit _)       = True
-manifestlyCheap (CoCon _ _ _)   = True
-manifestlyCheap (CoLam _ _)     = True
+manifestlyCheap (Var _)       = True
+manifestlyCheap (Lit _)       = True
+manifestlyCheap (Con _ _ _)   = True
+manifestlyCheap (Lam _ _)     = True
 manifestlyCheap (CoTyLam _ e)   = manifestlyCheap e
-manifestlyCheap (CoSCC _ e)     = manifestlyCheap e
+manifestlyCheap (SCC _ e)     = manifestlyCheap e
 
-manifestlyCheap (CoPrim op _ _) = primOpIsCheap op
+manifestlyCheap (Prim op _ _) = primOpIsCheap op
 
-manifestlyCheap (CoLet bind body)
+manifestlyCheap (Let bind body)
   = manifestlyCheap body && all manifestlyCheap (rhssOfBind bind)
 
-manifestlyCheap (CoCase scrut alts)
+manifestlyCheap (Case scrut alts)
   = manifestlyCheap scrut && all manifestlyCheap (rhssOfAlts alts)
 
 manifestlyCheap other_expr   -- look for manifest partial application
   = case (collectArgs other_expr) of { (fun, args) ->
     case fun of
 
-      CoVar f | isBottomingId f -> True		-- Application of a function which
+      Var f | isBottomingId f -> True		-- Application of a function which
 						-- always gives bottom; we treat this as
 						-- a WHNF, because it certainly doesn't
 						-- need to be shared!
 
-      CoVar f -> let
+      Var f -> let
 		    num_val_args = length [ a | (ValArg a) <- args ]
-		 in 
+		 in
 		 num_val_args == 0 ||		-- Just a type application of
 						-- a variable (f t1 t2 t3)
 						-- counts as WHNF
@@ -288,28 +285,11 @@ manifestlyCheap other_expr   -- look for manifest partial application
 
       _ -> False
     }
-
-
--- ToDo: Move to CoreFuns
-
-rhssOfBind :: CoreBinding bndr bdee -> [CoreExpr bndr bdee]
-
-rhssOfBind (CoNonRec _ rhs) = [rhs]
-rhssOfBind (CoRec pairs)    = [rhs | (_,rhs) <- pairs]
-
-rhssOfAlts :: CoreCaseAlternatives bndr bdee -> [CoreExpr bndr bdee]
-
-rhssOfAlts (CoAlgAlts alts deflt)  = rhssOfDeflt deflt ++ 
-				     [rhs | (_,_,rhs) <- alts]
-rhssOfAlts (CoPrimAlts alts deflt) = rhssOfDeflt deflt ++ 
-				     [rhs | (_,rhs) <- alts]
-rhssOfDeflt CoNoDefault = []
-rhssOfDeflt (CoBindDefault _ rhs) = [rhs]
 \end{code}
 
 Eta reduction on type lambdas
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We have a go at doing 
+We have a go at doing
 
 	/\a -> <expr> a	   ===>     <expr>
 
@@ -319,17 +299,17 @@ This is sometimes quite useful, because we can get the sequence:
 	f ab d = let d1 = ...d... in
 		 letrec f' b x = ...d...(f' b)... in
 		 f' b
-specialise ==> 
+specialise ==>
 
 	f.Int b = letrec f' b x = ...dInt...(f' b)... in
 		  f' b
 
-float ==> 
+float ==>
 
 	f' b x = ...dInt...(f' b)...
 	f.Int b = f' b
 
-Now we really want to simplify to 
+Now we really want to simplify to
 
 	f.Int = f'
 
@@ -341,7 +321,7 @@ applications since this breaks the specialiser:
 	/\ a -> f Char# a  	=NO=> f Char#
 
 \begin{code}
-mkCoTyLamTryingEta :: [TyVar] -> PlainCoreExpr -> PlainCoreExpr
+mkCoTyLamTryingEta :: [TyVar] -> CoreExpr -> CoreExpr
 
 mkCoTyLamTryingEta tyvars tylam_body
   = if
@@ -364,34 +344,8 @@ mkCoTyLamTryingEta tyvars tylam_body
     strip_tyvar_args args_so_far fun
       = (args_so_far, fun)
 
-    check_fun (CoVar f) = True	 -- Claim: tyvars not mentioned by type of f
+    check_fun (Var f) = True	 -- Claim: tyvars not mentioned by type of f
     check_fun other     = False
-
-{- OLD:
-mkCoTyLamTryingEta :: TyVar -> PlainCoreExpr -> PlainCoreExpr
-
-mkCoTyLamTryingEta tyvar body
-  = case body of 
-	CoTyApp fun ty ->
-	    case getTyVarMaybe ty of
-		Just tyvar' | tyvar == tyvar' &&
-			      ok fun   			-> fun
-			-- Ha!  So it's /\ a -> fun a, and fun is "ok"
-
-		other -> CoTyLam tyvar body
-	other -> CoTyLam tyvar body
-  where
-    is_elem = isIn "mkCoTyLamTryingEta"
-
-    ok :: PlainCoreExpr -> Bool	-- Returns True iff the expression doesn't
-				-- mention tyvar
-
-    ok (CoVar v)	= True		-- Claim: tyvar not mentioned by type of v
-    ok (CoApp fun arg)  = ok fun	-- Claim: tyvar not mentioned by type of arg
-    ok (CoTyApp fun ty) = not (tyvar `is_elem` extractTyVarsFromTy ty) &&
-			  ok fun
-    ok other            = False
--}
 \end{code}
 
 Let to case
@@ -410,33 +364,33 @@ if there's many, or if it's a primitive type.
 
 \begin{code}
 mkIdentityAlts
-	:: UniType		-- type of RHS
+	:: Type		-- type of RHS
 	-> SmplM InAlts		-- result
 
 mkIdentityAlts rhs_ty
   | isPrimType rhs_ty
   = newId rhs_ty	`thenSmpl` \ binder ->
-    returnSmpl (CoPrimAlts [] (CoBindDefault (binder, bad_occ_info) (CoVar binder)))
+    returnSmpl (PrimAlts [] (BindDefault (binder, bad_occ_info) (Var binder)))
 
   | otherwise
-  = case getUniDataTyCon_maybe rhs_ty of
+  = case maybeDataTyCon rhs_ty of
 	Just (tycon, ty_args, [data_con]) ->  -- algebraic type suitable for unpacking
 	    let
 		(_,inst_con_arg_tys,_) = getInstantiatedDataConSig data_con ty_args
 	    in
 	    newIds inst_con_arg_tys	`thenSmpl` \ new_bindees ->
 	    let
-		new_binders = [ (b, bad_occ_info) | b <- new_bindees ] 
+		new_binders = [ (b, bad_occ_info) | b <- new_bindees ]
 	    in
 	    returnSmpl (
-	      CoAlgAlts
-		[(data_con, new_binders, CoCon data_con ty_args (map CoVarAtom new_bindees))]
-		CoNoDefault
+	      AlgAlts
+		[(data_con, new_binders, Con data_con ty_args (map VarArg new_bindees))]
+		NoDefault
 	    )
 
-	_ -> -- Multi-constructor or abstract algebraic type 
+	_ -> -- Multi-constructor or abstract algebraic type
 	     newId rhs_ty	`thenSmpl` \ binder ->
-    	     returnSmpl (CoAlgAlts [] (CoBindDefault (binder,bad_occ_info) (CoVar binder)))
+    	     returnSmpl (AlgAlts [] (BindDefault (binder,bad_occ_info) (Var binder)))
   where
     bad_occ_info = ManyOcc 0	-- Non-committal!
 \end{code}
@@ -444,15 +398,15 @@ mkIdentityAlts rhs_ty
 \begin{code}
 simplIdWantsToBeINLINEd :: Id -> SimplEnv -> Bool
 
-simplIdWantsToBeINLINEd id env 
-  = if switchIsSet env IgnoreINLINEPragma 
+simplIdWantsToBeINLINEd id env
+  = if switchIsSet env IgnoreINLINEPragma
     then False
     else idWantsToBeINLINEd id
 
-type_ok_for_let_to_case :: UniType -> Bool
+type_ok_for_let_to_case :: Type -> Bool
 
-type_ok_for_let_to_case ty 
-  = case getUniDataTyCon_maybe ty of
+type_ok_for_let_to_case ty
+  = case maybeDataTyCon ty of
       Nothing                                   -> False
       Just (tycon, ty_args, [])                 -> False
       Just (tycon, ty_args, non_null_data_cons) -> True
diff --git a/ghc/compiler/simplCore/SimplVar.hi b/ghc/compiler/simplCore/SimplVar.hi
deleted file mode 100644
index 36b0352997..0000000000
--- a/ghc/compiler/simplCore/SimplVar.hi
+++ /dev/null
@@ -1,11 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface SimplVar where
-import CoreSyn(CoreArg, CoreExpr)
-import Id(Id)
-import SimplEnv(SimplEnv)
-import SimplMonad(SimplCount)
-import SplitUniq(SplitUniqSupply)
-import UniType(UniType)
-completeVar :: SimplEnv -> Id -> [CoreArg Id] -> SplitUniqSupply -> SimplCount -> (CoreExpr Id Id, SimplCount)
-leastItCouldCost :: Int -> Int -> Int -> [Bool] -> [UniType] -> Int
-
diff --git a/ghc/compiler/simplCore/SimplVar.lhs b/ghc/compiler/simplCore/SimplVar.lhs
index c5059dfd86..10a9f3caa0 100644
--- a/ghc/compiler/simplCore/SimplVar.lhs
+++ b/ghc/compiler/simplCore/SimplVar.lhs
@@ -11,15 +11,11 @@ module SimplVar (
 	leastItCouldCost
     ) where
 
-IMPORT_Trace
-
 import SimplMonad
 import SimplEnv
-import PlainCore
-import TaggedCore
-import BasicLit		( isNoRepLit )
+import Literal		( isNoRepLit )
 
-import AbsUniType	( getUniDataTyCon, getUniDataTyCon_maybe,
+import Type		( getAppDataTyCon, maybeAppDataTyCon,
 			  getTyConFamilySize, isPrimType
 			)
 import BinderInfo	( oneTextualOcc, oneSafeOcc )
@@ -27,7 +23,7 @@ import CgCompInfo	( uNFOLDING_USE_THRESHOLD,
 			  uNFOLDING_CON_DISCOUNT_WEIGHT
 			)
 import CmdLineOpts	( switchIsOn, intSwitchSet, SimplifierSwitch(..) )
-import Id		( getIdUniType, getIdInfo )
+import Id		( idType, getIdInfo )
 import IdInfo
 import Maybes		( maybeToBool, Maybe(..) )
 import Simplify		( simplExpr )
@@ -50,23 +46,23 @@ completeVar :: SimplEnv -> OutId -> [OutArg] -> SmplM OutExpr
 
 completeVar env var args
   = let
-	boring_result = applyToArgs (CoVar var) args
+	boring_result = mkGenApp (Var var) args
     in
     case (lookupUnfolding env var) of
-     
-      LiteralForm lit 
-	| not (isNoRepLit lit) 
+
+      LitForm lit
+	| not (isNoRepLit lit)
 		-- Inline literals, if they aren't no-repish things
 	-> ASSERT( null args )
-	   returnSmpl (CoLit lit)
+	   returnSmpl (Lit lit)
 
-      ConstructorForm con ty_args val_args
+      ConForm con ty_args val_args
 		-- Always inline constructors.
 		-- See comments before completeLetBinding
 	-> ASSERT( null args )
-	   returnSmpl (CoCon con ty_args val_args)	
+	   returnSmpl (Con con ty_args val_args)
 
-      GeneralForm txt_occ form_summary template guidance 
+      GenForm txt_occ form_summary template guidance
 	-> considerUnfolding env var args
 			     txt_occ form_summary template guidance
 
@@ -74,7 +70,7 @@ completeVar env var args
 	->  applyMagicUnfoldingFun magic_fun env args `thenSmpl` \ result ->
 	    case result of
 	      Nothing	        -> returnSmpl boring_result
-	      Just magic_result -> 
+	      Just magic_result ->
 		{- pprTrace "MagicForm:- " (ppAbove
 			(ppBesides [
 			   ppr PprDebug var,
@@ -123,7 +119,7 @@ considerUnfolding
 	-> FormSummary
 	-> InExpr		-- Template for unfolding;
 	-> UnfoldingGuidance	-- To help us decide...
-	-> SmplM PlainCoreExpr	-- Result!
+	-> SmplM CoreExpr	-- Result!
 
 considerUnfolding env var args txt_occ form_summary template guidance
   | switchIsOn sw_chkr EssentialUnfoldingsOnly
@@ -170,7 +166,7 @@ considerUnfolding env var args txt_occ form_summary template guidance
 	      dont_go_for_it
 
 	   else if n_vals_wanted == 0
-		&& rhs_looks_like_a_CoCon then
+		&& rhs_looks_like_a_Con then
 	      -- we are very keen on inlining data values
 	      -- (see comments elsewhere); we ignore any size issues!
 	      go_for_it
@@ -201,15 +197,15 @@ considerUnfolding env var args txt_occ form_summary template guidance
     no_tyargs  = length tyargs
     no_valargs = length valargs
 
-    rhs_looks_like_a_CoCon
+    rhs_looks_like_a_Con
       = let
-	    (_,val_binders,body) = digForLambdas template
+	    (_,_,val_binders,body) = digForLambdas template
     	in
     	case (val_binders, body) of
-    	  ([], CoCon _ _ _) -> True
+    	  ([], Con _ _ _) -> True
 	  other -> False
 
-    dont_go_for_it = returnSmpl (applyToArgs (CoVar var) args)
+    dont_go_for_it = returnSmpl (mkGenApp (Var var) args)
 
     go_for_it      = --pprTrace "unfolding:" (ppCat [ppr PprDebug var, ppChar ':', ppr PprDebug template]) (
 		     tick UnfoldingDone		`thenSmpl_`
@@ -234,7 +230,7 @@ discountedCost
 	-> Int		    -- the number of val args (== length args)
 	-> ArgInfoVector    -- what we know about the *use* of the arguments
 	-> [OutAtom]	    -- *an actual set of value arguments*!
-	-> Int		    
+	-> Int
 
     -- If we apply an expression (usually a function) of given "costs"
     -- to a particular set of arguments (possibly none), what will
@@ -252,7 +248,7 @@ discountedCost env con_discount_weight size no_args is_con_vec args
       = let
 	    full_price	         = disc size
 	    take_something_off v = let
-				     (tycon, _, _) = getUniDataTyCon (getIdUniType v)
+				     (tycon, _, _) = getAppDataTyCon (idType v)
 				     no_cons = case (getTyConFamilySize tycon) of
 						 Just n -> n
 				     reduced_size
@@ -264,9 +260,9 @@ discountedCost env con_discount_weight size no_args is_con_vec args
 	    full_price
 	else
 	    case arg of
-	      CoLitAtom _ -> full_price
-	      CoVarAtom v -> case lookupUnfolding env v of
-			       ConstructorForm _ _ _ -> take_something_off v
+	      LitArg _ -> full_price
+	      VarArg v -> case lookupUnfolding env v of
+			       ConForm _ _ _ -> take_something_off v
 			       other_form   	     -> full_price
 
 	) want_cons rest_args
@@ -280,7 +276,7 @@ leastItCouldCost
 	-> Int		    -- the size/cost of the expr
 	-> Int		    -- number of value args
 	-> ArgInfoVector    -- what we know about the *use* of the arguments
-	-> [UniType]	    -- NB: actual arguments *not* looked at;
+	-> [Type]	    -- NB: actual arguments *not* looked at;
 			    -- but we know their types
 	-> Int
 
@@ -308,9 +304,9 @@ leastItCouldCost con_discount_weight size no_val_args is_con_vec arg_tys
 	if not want_con_here then
 	    disc size want_cons rest_arg_tys
 	else
-	    case (getUniDataTyCon_maybe arg_ty, isPrimType arg_ty) of
+	    case (maybeAppDataTyCon arg_ty, isPrimType arg_ty) of
 	      (Just (tycon, _, _), False) ->
-	        disc (take_something_off tycon) want_cons rest_arg_tys
+		disc (take_something_off tycon) want_cons rest_arg_tys
 
 	      other -> disc size want_cons rest_arg_tys
 \end{code}
diff --git a/ghc/compiler/simplCore/Simplify.hi b/ghc/compiler/simplCore/Simplify.hi
deleted file mode 100644
index c612525fdb..0000000000
--- a/ghc/compiler/simplCore/Simplify.hi
+++ /dev/null
@@ -1,13 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface Simplify where
-import BinderInfo(BinderInfo)
-import CoreSyn(CoreArg, CoreBinding, CoreExpr)
-import Id(Id)
-import SimplEnv(SimplEnv)
-import SimplMonad(SimplCount)
-import SplitUniq(SplitUniqSupply)
-import UniType(UniType)
-simplBind :: SimplEnv -> CoreBinding (Id, BinderInfo) Id -> (SimplEnv -> SplitUniqSupply -> SimplCount -> (CoreExpr Id Id, SimplCount)) -> UniType -> SplitUniqSupply -> SimplCount -> (CoreExpr Id Id, SimplCount)
-simplExpr :: SimplEnv -> CoreExpr (Id, BinderInfo) Id -> [CoreArg Id] -> SplitUniqSupply -> SimplCount -> (CoreExpr Id Id, SimplCount)
-simplTopBinds :: SimplEnv -> [CoreBinding (Id, BinderInfo) Id] -> SplitUniqSupply -> SimplCount -> ([CoreBinding Id Id], SimplCount)
-
diff --git a/ghc/compiler/simplCore/Simplify.lhs b/ghc/compiler/simplCore/Simplify.lhs
index 46cd242863..fe5f6aebfd 100644
--- a/ghc/compiler/simplCore/Simplify.lhs
+++ b/ghc/compiler/simplCore/Simplify.lhs
@@ -1,5 +1,5 @@
 %
-% (c) The AQUA Project, Glasgow University, 1993-1995
+% (c) The AQUA Project, Glasgow University, 1993-1996
 %
 \section[Simplify]{The main module of the simplifier}
 
@@ -13,21 +13,19 @@ import Outputable
 
 import SimplMonad
 import SimplEnv
-import TaggedCore
-import PlainCore
 
-import AbsPrel		( getPrimOpResultInfo, PrimOpResultInfo(..),
-			  primOpOkForSpeculation, PrimOp(..), PrimKind,
+import PrelInfo		( getPrimOpResultInfo, PrimOpResultInfo(..),
+			  primOpOkForSpeculation, PrimOp(..), PrimRep,
 			  realWorldStateTy
 			  IF_ATTACK_PRAGMAS(COMMA realWorldTy)
 			  IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
 			  IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
 			)
-import AbsUniType	( getUniDataTyCon_maybe, mkTyVarTy, applyTy,
+import Type		( maybeDataTyCon, mkTyVarTy, applyTy,
 			  splitTyArgs, splitTypeWithDictsAsArgs,
 			  maybeUnpackFunTy, isPrimType
 			)
-import BasicLit		( isNoRepLit, BasicLit(..) )
+import Literal		( isNoRepLit, Literal(..) )
 import BinderInfo
 import CmdLineOpts	( SimplifierSwitch(..) )
 import ConFold		( completePrim )
@@ -48,7 +46,7 @@ passes:
 -fsimplify		= run the simplifier
 -ffloat-inwards		= runs the float lets inwards pass
 -ffloat			= runs the full laziness pass
-                          (ToDo: rename to -ffull-laziness)
+			  (ToDo: rename to -ffull-laziness)
 -fupdate-analysis	= runs update analyser
 -fstrictness		= runs strictness analyser
 -fsaturate-apps		= saturates applications (eta expansion)
@@ -56,20 +54,20 @@ passes:
 options:
 -------
 -ffloat-past-lambda	= OK to do full laziness.
-                          (ToDo: remove, as the full laziness pass is
-                                 useless without this flag, therefore
-                                 it is unnecessary. Just -ffull-laziness
-                                 should be kept.)
+			  (ToDo: remove, as the full laziness pass is
+				 useless without this flag, therefore
+				 it is unnecessary. Just -ffull-laziness
+				 should be kept.)
 
 -ffloat-lets-ok		= OK to float lets out of lets if the enclosing
-                          let is strict or if the floating will expose
-                          a WHNF [simplifier].
+			  let is strict or if the floating will expose
+			  a WHNF [simplifier].
 
--ffloat-primops-ok	= OK to float out of lets cases whose scrutinee 
-                          is a primop that cannot fail [simplifier].
+-ffloat-primops-ok	= OK to float out of lets cases whose scrutinee
+			  is a primop that cannot fail [simplifier].
 
 -fcode-duplication-ok	= allows the previous option to work on cases with
-                          multiple branches [simplifier].
+			  multiple branches [simplifier].
 
 -flet-to-case		= does let-to-case transformation [simplifier].
 
@@ -113,7 +111,7 @@ you decide not to use it.
 Head normal forms
 ~~~~~~~~~~~~~~~~~
 We *never* put a non-HNF unfolding in the UnfoldEnv except in the
-INLINE-pragma case.  
+INLINE-pragma case.
 
 At one time I thought it would be OK to put non-HNF unfoldings in for
 variables which occur only once [if they got inlined at that
@@ -126,7 +124,7 @@ would occur].   But consider:
 @
 Now, it seems that @x@ appears only once, but even so it is NOT safe to put @x@
 in the UnfoldEnv, because @f@ will be inlined, and will duplicate the references to
-@x@.  
+@x@.
 
 Becuase of this, the "unconditional-inline" mechanism above is the only way
 in which non-HNFs can get inlined.
@@ -151,7 +149,7 @@ because then we'd duplicate BIG when we inline'd y.  (Exception:
 things in the UnfoldEnv with UnfoldAlways flags, which originated in
 other INLINE pragmas.)
 
-So, we clean out the UnfoldEnv of all GeneralForm inlinings before
+So, we clean out the UnfoldEnv of all GenForm inlinings before
 going into such an RHS.
 
 What about imports?  They don't really matter much because we only
@@ -185,7 +183,7 @@ simplTopBinds env [] = returnSmpl []
 
 -- Dead code is now discarded by the occurrence analyser,
 
-simplTopBinds env (CoNonRec binder@(in_id, occ_info) rhs : binds)
+simplTopBinds env (NonRec binder@(in_id, occ_info) rhs : binds)
   | inlineUnconditionally ok_to_dup_code occ_info
   = --pprTrace "simplTopBinds (inline):" (ppr PprDebug in_id) (
     let
@@ -196,15 +194,15 @@ simplTopBinds env (CoNonRec binder@(in_id, occ_info) rhs : binds)
   where
     ok_to_dup_code = switchIsSet env SimplOkToDupCode
 
-simplTopBinds env (CoNonRec binder@(in_id,occ_info) rhs : binds)
+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' ->
     let
        new_env = case rhs' of
-	 CoVar var			  -> extendIdEnvWithAtom env binder (CoVarAtom var)
-         CoLit lit | not (isNoRepLit lit) -> extendIdEnvWithAtom env binder (CoLitAtom lit)
-         other				  -> extendUnfoldEnvGivenRhs env binder in_id rhs'
+	 Var var			  -> extendIdEnvWithAtom env binder (VarArg var)
+	 Lit lit | not (isNoRepLit lit) -> extendIdEnvWithAtom env binder (LitArg lit)
+	 other				  -> extendUnfoldEnvGivenRhs env binder in_id rhs'
     in
     --pprTrace "simplTopBinds (nonrec):" (ppCat [ppr PprDebug in_id, ppr PprDebug rhs']) (
 
@@ -212,13 +210,13 @@ simplTopBinds env (CoNonRec binder@(in_id,occ_info) rhs : binds)
     simplTopBinds new_env binds	`thenSmpl` \ binds' ->
 
 	-- Glue together and return ...
-	-- We leave it to susequent occurrence analysis to throw away 
+	-- We leave it to susequent occurrence analysis to throw away
 	-- an unused atom binding. This localises the decision about
 	-- discarding top-level bindings.
-    returnSmpl (CoNonRec in_id rhs' : binds')
+    returnSmpl (NonRec in_id rhs' : binds')
     --)
 
-simplTopBinds env (CoRec pairs : binds)
+simplTopBinds env (Rec pairs : binds)
   = simplRecursiveGroup env triples 	`thenSmpl` \ (bind', new_env) ->
 
     --pprTrace "simplTopBinds (rec):" (ppCat [ppr PprDebug bind']) (
@@ -240,11 +238,11 @@ simplTopBinds env (CoRec pairs : binds)
 %*									*
 %************************************************************************
 
-	
-\begin{code} 
+
+\begin{code}
 simplExpr :: SimplEnv
 	  -> InExpr -> [OutArg]
-	  -> SmplM OutExpr 
+	  -> SmplM OutExpr
 \end{code}
 
 The expression returned has the same meaning as the input expression
@@ -257,7 +255,7 @@ Check if there's a macro-expansion, and if so rattle on.  Otherwise
 do the more sophisticated stuff.
 
 \begin{code}
-simplExpr env (CoVar v) args
+simplExpr env (Var v) args
   = --pprTrace "simplExpr:Var:" (ppr PprDebug v) (
     case lookupId env v of
       Nothing -> let
@@ -267,17 +265,17 @@ simplExpr env (CoVar v) args
 
       Just info ->
 	case info of
-    	  ItsAnAtom (CoLitAtom lit) 	-- A boring old literal
+    	  ItsAnAtom (LitArg lit) 	-- A boring old literal
 			-- Paranoia check for args empty
 	    ->	case args of
-		  []    -> returnSmpl (CoLit lit)
+		  []    -> returnSmpl (Lit lit)
 		  other -> panic "simplExpr:coVar"
 
-	  ItsAnAtom (CoVarAtom var) 	-- More interesting!  An id!
+	  ItsAnAtom (VarArg var) 	-- More interesting!  An id!
 					-- No need to substitute the type env here,
 					-- because we already have!
-	    -> completeVar env var args	
-		
+	    -> completeVar env var args
+
 	  InlineIt id_env ty_env in_expr 	-- A macro-expansion
 	    -> simplExpr (replaceInEnvs env (ty_env, id_env)) in_expr args
     --)
@@ -287,18 +285,18 @@ Literals
 ~~~~~~~~~
 
 \begin{code}
-simplExpr env (CoLit l) [] = returnSmpl (CoLit l)
-simplExpr env (CoLit l) _  = panic "simplExpr:CoLit with argument"
+simplExpr env (Lit l) [] = returnSmpl (Lit l)
+simplExpr env (Lit l) _  = panic "simplExpr:Lit with argument"
 \end{code}
 
-Primitive applications are simple.  
+Primitive applications are simple.
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 
-NB: CoPrim expects an empty argument list! (Because it should be
+NB: Prim expects an empty argument list! (Because it should be
 saturated and not higher-order. ADR)
 
-\begin{code} 
-simplExpr env (CoPrim op tys prim_args) args
+\begin{code}
+simplExpr env (Prim op tys prim_args) args
   = ASSERT (null args)
     let
 	tys'       = [simplTy   env ty       | ty       <- tys]
@@ -309,7 +307,7 @@ simplExpr env (CoPrim op tys prim_args) args
   where
     -- PrimOps just need any types in them renamed.
 
-    simpl_op (CCallOp label is_asm may_gc arg_tys result_ty) 
+    simpl_op (CCallOp label is_asm may_gc arg_tys result_ty)
       = let
 	    arg_tys'	= map (simplTy env) arg_tys
 	    result_ty'	= simplTy env result_ty
@@ -319,27 +317,27 @@ simplExpr env (CoPrim op tys prim_args) args
     simpl_op other_op = other_op
 \end{code}
 
-Constructor applications 
-~~~~~~~~~~~~~~~~~~~~~~~~ 
+Constructor applications
+~~~~~~~~~~~~~~~~~~~~~~~~
 Nothing to try here.  We only reuse constructors when they appear as the
 rhs of a let binding (see completeLetBinding).
 
 \begin{code}
-simplExpr env (CoCon con tys con_args) args
+simplExpr env (Con con tys con_args) args
   = ASSERT( null args )
-    returnSmpl (CoCon con tys' con_args')
+    returnSmpl (Con con tys' con_args')
   where
     con_args' = [simplAtom env con_arg | con_arg <- con_args]
     tys'      = [simplTy   env ty      | ty <- tys]
 \end{code}
 
 
-Applications are easy too: 
-~~~~~~~~~~~~~~~~~~~~~~~~~~ 
+Applications are easy too:
+~~~~~~~~~~~~~~~~~~~~~~~~~~
 Just stuff 'em in the arg stack
 
-\begin{code} 
-simplExpr env (CoApp fun arg) args
+\begin{code}
+simplExpr env (App fun arg) args
   = simplExpr env fun (ValArg (simplAtom env arg) : args)
 
 simplExpr env (CoTyApp fun ty) args
@@ -353,7 +351,7 @@ We only eta-reduce a type lambda if all type arguments in the body can
 be eta-reduced. This requires us to collect up all tyvar parameters so
 we can pass them all to @mkCoTyLamTryingEta@.
 
-\begin{code} 
+\begin{code}
 simplExpr env (CoTyLam tyvar body) (TypeArg ty : args)
   = -- ASSERT(not (isPrimType ty))
     let
@@ -363,7 +361,7 @@ simplExpr env (CoTyLam tyvar body) (TypeArg ty : args)
     simplExpr new_env body args
 
 simplExpr env tylam@(CoTyLam tyvar body) []
-  = do_tylambdas env [] tylam 
+  = do_tylambdas env [] tylam
   where
     do_tylambdas env tyvars' (CoTyLam tyvar body)
       =	  -- Clone the type variable
@@ -382,7 +380,7 @@ simplExpr env tylam@(CoTyLam tyvar body) []
 	)
 
 simplExpr env (CoTyLam tyvar body) (ValArg _ : _)
-  = panic "simplExpr:CoTyLam ValArg" 
+  = panic "simplExpr:CoTyLam ValArg"
 \end{code}
 
 
@@ -390,7 +388,7 @@ Ordinary lambdas
 ~~~~~~~~~~~~~~~~
 
 \begin{code}
-simplExpr env (CoLam binders body) args
+simplExpr env (Lam binder body) args
   | null leftover_binders
   = 	-- The lambda is saturated (or over-saturated)
     tick BetaReduction	`thenSmpl_`
@@ -405,11 +403,11 @@ simplExpr env (CoLam binders body) args
      else returnSmpl (panic "BetaReduction")
     ) `thenSmpl_`
 
-    simplLam env_for_too_few_args leftover_binders body 
+    simplLam env_for_too_few_args leftover_binders body
 	     0 {- Guaranteed applied to at least 0 args! -}
 
   where
-    (binder_args_pairs, leftover_binders, leftover_args) = collect_val_args binders args
+    (binder_args_pairs, leftover_binders, leftover_args) = collect_val_args [binder] args
 
     env_for_enough_args  = extendIdEnvWithAtomList env binder_args_pairs
 
@@ -426,7 +424,7 @@ simplExpr env (CoLam binders body) args
 	--		(\ x y z -> e) p q r
 	--	    ==> e[p/x, q/y, r/z]
 	--
-    zapped_binder_args_pairs = [ ((id, markDangerousToDup occ_info), arg) 
+    zapped_binder_args_pairs = [ ((id, markDangerousToDup occ_info), arg)
 			       | ((id, occ_info), arg) <- binder_args_pairs ]
 
     collect_val_args :: [InBinder] 	-- Binders
@@ -434,7 +432,7 @@ simplExpr env (CoLam binders body) args
 		     -> ([(InBinder,OutAtom)], 	-- Binder,arg pairs
 			  [InBinder],		-- Leftover binders
 			  [OutArg])		-- Leftover args
-	
+
 	-- collect_val_args strips off the leading ValArgs from
 	-- the current arg list, returning them along with the
 	-- depleted list
@@ -446,36 +444,36 @@ simplExpr env (CoLam binders body) args
 	  (rest_pairs, leftover_binders, leftover_args) = collect_val_args binders args
 
     collect_val_args (binder:binders) (other_val_arg : args) = panic "collect_val_args"
-		-- TypeArg should never meet a CoLam
+		-- TypeArg should never meet a Lam
 \end{code}
 
 
-Let expressions 
+Let expressions
 ~~~~~~~~~~~~~~~
 
-\begin{code}	
-simplExpr env (CoLet bind body) args
+\begin{code}
+simplExpr env (Let bind body) args
   | not (switchIsSet env SimplNoLetFromApp)		-- The common case
-  = simplBind env bind (\env -> simplExpr env body args) 
+  = simplBind env bind (\env -> simplExpr env body args)
 		       (computeResultType env body args)
 
   | otherwise		-- No float from application
-  = simplBind env bind (\env -> simplExpr env body []) 
+  = simplBind env bind (\env -> simplExpr env body [])
 		       (computeResultType env body [])	`thenSmpl` \ let_expr' ->
-    returnSmpl (applyToArgs let_expr' args)
+    returnSmpl (mkGenApp let_expr' args)
 \end{code}
 
-Case expressions 
+Case expressions
 ~~~~~~~~~~~~~~~~
 
 \begin{code}
-simplExpr env expr@(CoCase scrut alts) args
+simplExpr env expr@(Case scrut alts) args
   = simplCase env scrut alts (\env rhs -> simplExpr env rhs args)
 			     (computeResultType env expr args)
 \end{code}
 
 
-Set-cost-centre 
+Set-cost-centre
 ~~~~~~~~~~~~~~~
 
 A special case we do:
@@ -486,20 +484,20 @@ Simon thinks it's OK, at least for lexical scoping; and it makes
 interfaces change less (arities).
 
 \begin{code}
-simplExpr env (CoSCC cc (CoLam binders body)) args
-  = simplExpr env (CoLam binders (CoSCC cc body)) args
+simplExpr env (SCC cc (Lam binder body)) args
+  = simplExpr env (Lam binder (SCC cc body)) args
 
-simplExpr env (CoSCC cc (CoTyLam tyvar body)) args
-  = simplExpr env (CoTyLam tyvar (CoSCC cc body)) args
+simplExpr env (SCC cc (CoTyLam tyvar body)) args
+  = simplExpr env (CoTyLam tyvar (SCC cc body)) args
 \end{code}
 
 Some other slightly turgid SCC tidying-up cases:
 \begin{code}
-simplExpr env (CoSCC cc1 expr@(CoSCC _ _)) args
+simplExpr env (SCC cc1 expr@(SCC _ _)) args
   = simplExpr env expr args
-    -- the outer _scc_ serves no purpose 
+    -- the outer _scc_ serves no purpose
 
-simplExpr env (CoSCC cc expr) args
+simplExpr env (SCC cc expr) args
   | squashableDictishCcExpr cc expr
   = simplExpr env expr args
     -- the DICT-ish CC is no longer serving any purpose
@@ -509,12 +507,12 @@ NB: for other set-cost-centre we move arguments inside the body.
 ToDo: check with Patrick that this is ok.
 
 \begin{code}
-simplExpr env (CoSCC cost_centre body) args
+simplExpr env (SCC cost_centre body) args
   = let
 	new_env = setEnclosingCC env (EnclosingCC cost_centre)
     in
     simplExpr new_env body args		`thenSmpl` \ body' ->
-    returnSmpl (CoSCC cost_centre body') 
+    returnSmpl (SCC cost_centre body')
 \end{code}
 
 %************************************************************************
@@ -536,13 +534,13 @@ it transforms the rhs to
 This is a Very Good Thing!
 
 \begin{code}
-simplRhsExpr 
+simplRhsExpr
 	:: SimplEnv
 	-> InBinder
 	-> InExpr
-	-> SmplM OutExpr 
+	-> SmplM OutExpr
 
-simplRhsExpr env binder@(id,occ_info) rhs 
+simplRhsExpr env binder@(id,occ_info) rhs
   | dont_eta_expand rhs
   = simplExpr rhs_env rhs []
 
@@ -570,8 +568,8 @@ simplRhsExpr env binder@(id,occ_info) rhs
 	-- we might want a {-# INLINE UNSIMPLIFIED #-} option.
     rhs_env | simplIdWantsToBeINLINEd id env = filterUnfoldEnvForInlines env
 	    | otherwise			     = env
-	
-    (tyvars, binders, body) = digForLambdas rhs
+
+    (uvars, tyvars, binders, body) = digForLambdas rhs
 
     min_no_of_args | not (null binders)			&& 	-- It's not a thunk
 		     switchIsSet env SimplDoArityExpand	 	-- Arity expansion on
@@ -587,18 +585,18 @@ simplRhsExpr env binder@(id,occ_info) rhs
 	-- get eta-reduced back to y.  Furthermore, if this was a top level defn,
 	-- and x was exported, then the defn won't be eliminated, so this
 	-- silly expand/reduce cycle will happen every time, which makes the
-	-- simplifier loop!. 
+	-- simplifier loop!.
 	-- The solution is to not even try eta expansion unless the rhs looks
-	-- non-trivial.  
-    dont_eta_expand (CoLit _)     = True
-    dont_eta_expand (CoVar _)     = True
+	-- non-trivial.
+    dont_eta_expand (Lit _)     = True
+    dont_eta_expand (Var _)     = True
     dont_eta_expand (CoTyApp f _) = dont_eta_expand f
     dont_eta_expand (CoTyLam _ b) = dont_eta_expand b
-    dont_eta_expand (CoCon _ _ _) = True
+    dont_eta_expand (Con _ _ _) = True
     dont_eta_expand _		  = False
 \end{code}
 
-		
+
 %************************************************************************
 %*									*
 \subsection{Simplify a lambda abstraction}
@@ -621,7 +619,7 @@ simplLam env binders body min_no_of_args
     returnSmpl (
       (if switchIsSet new_env SimplDoEtaReduction
        then mkCoLamTryingEta
-       else mkCoLam) binders' body'
+       else mkValLam) binders' body'
     )
 
   | otherwise				-- Eta expansion possible
@@ -631,16 +629,16 @@ simplLam env binders body min_no_of_args
 	new_env = extendIdEnvWithClones env binders binders'
     in
     newIds extra_binder_tys						`thenSmpl` \ extra_binders' ->
-    simplExpr new_env body (map (ValArg.CoVarAtom) extra_binders')	`thenSmpl` \ body' ->
+    simplExpr new_env body (map (ValArg.VarArg) extra_binders')	`thenSmpl` \ body' ->
     returnSmpl (
       (if switchIsSet new_env SimplDoEtaReduction
        then mkCoLamTryingEta
-       else mkCoLam) (binders' ++ extra_binders') body'
+       else mkValLam) (binders' ++ extra_binders') body'
     )
 
   where
-    (potential_extra_binder_tys, res_ty) 
-	= splitTyArgs (simplTy env (typeOfCoreExpr (unTagBinders body)))
+    (potential_extra_binder_tys, res_ty)
+	= splitTyArgs (simplTy env (coreExprType (unTagBinders body)))
 	-- Note: it's possible that simplLam will be applied to something
 	-- with a forall type.  Eg when being applied to the rhs of
 	--		let x = wurble
@@ -710,11 +708,11 @@ becomes:
 
 ==>
       let join_body x' = foldr c n x'
-        in case y of
-        p1 -> let x* = build e1
-                in join_body x*
-        p2 -> let x* = build e2
-                in join_body x*
+	in case y of
+	p1 -> let x* = build e1
+		in join_body x*
+	p2 -> let x* = build e2
+		in join_body x*
 
 note that join_body is a let-no-escape.
 In this particular example join_body will later be inlined,
@@ -726,7 +724,7 @@ ToDo: check this is OK with andy
 \begin{code}
 -- Dead code is now discarded by the occurrence analyser,
 
-simplBind env (CoNonRec binder@(id,occ_info) rhs) body_c body_ty
+simplBind env (NonRec binder@(id,occ_info) rhs) body_c body_ty
   |  inlineUnconditionally ok_to_dup occ_info
   = body_c (extendIdEnvWithInlining env env binder rhs)
 
@@ -740,7 +738,7 @@ simplBind env (CoNonRec binder@(id,occ_info) rhs) body_c body_ty
 -- If we do case-floating first we get this:
 --
 --	let k = \a* -> b
---	in case v of 
+--	in case v of
 --		p1-> let a*=e1 in k a
 --		p2-> let a*=e2 in k a
 --
@@ -757,7 +755,7 @@ simplBind env (CoNonRec binder@(id,occ_info) rhs) body_c body_ty
 -- The latter is clearly better.  (Remember the reboxing let-decl
 -- for a is likely to go away, because after all b is strict in a.)
 
-  | will_be_demanded && 
+  | will_be_demanded &&
     try_let_to_case &&
     type_ok_for_let_to_case rhs_ty &&
     not (manifestlyWHNF rhs)
@@ -787,7 +785,7 @@ simplBind env (CoNonRec binder@(id,occ_info) rhs) body_c body_ty
 	-}
 
   | (will_be_demanded && not no_float) ||
-    always_float_let_from_let || 
+    always_float_let_from_let ||
     floatExposesHNF float_lets float_primops ok_to_dup rhs
   = try_float env rhs body_c
 
@@ -796,7 +794,7 @@ simplBind env (CoNonRec binder@(id,occ_info) rhs) body_c body_ty
 
   where
     will_be_demanded = willBeDemanded (getIdDemandInfo id)
-    rhs_ty 	     = getIdUniType id
+    rhs_ty 	     = idType id
 
     float_lets       	      = switchIsSet env SimplFloatLetsExposingWHNF
     float_primops    	      = switchIsSet env SimplOkToFloatPrimOps
@@ -811,28 +809,28 @@ simplBind env (CoNonRec binder@(id,occ_info) rhs) body_c body_ty
 	  completeLet env binder rhs rhs' body_c body_ty
 
     ---------------------------------------
-    try_float env (CoLet bind rhs) body_c
+    try_float env (Let bind rhs) body_c
       = tick LetFloatFromLet                    `thenSmpl_`
-        simplBind env (fix_up_demandedness will_be_demanded bind) 
+	simplBind env (fix_up_demandedness will_be_demanded bind)
 		      (\env -> try_float env rhs body_c) body_ty
 
-    try_float env (CoCase scrut alts) body_c
+    try_float env (Case scrut alts) body_c
       | will_be_demanded || (float_primops && is_cheap_prim_app scrut)
       = tick CaseFloatFromLet				`thenSmpl_`
 
 	-- First, bind large let-body if necessary
 	if no_need_to_bind_large_body then
 	    simplCase env scrut alts (\env rhs -> try_float env rhs body_c) body_ty
-	else		
+	else
 	    bindLargeRhs env [binder] body_ty body_c	`thenSmpl` \ (extra_binding, new_body) ->
 	    let
 		body_c' = \env -> simplExpr env new_body []
 	    in
-	    simplCase env scrut alts 
+	    simplCase env scrut alts
 		      (\env rhs -> try_float env rhs body_c')
 		      body_ty				`thenSmpl` \ case_expr ->
 
-	    returnSmpl (CoLet extra_binding case_expr)
+	    returnSmpl (Let extra_binding case_expr)
       where
 	no_need_to_bind_large_body
 	  = ok_to_dup || isSingleton (nonErrorRHSs alts)
@@ -840,7 +838,7 @@ simplBind env (CoNonRec binder@(id,occ_info) rhs) body_c body_ty
     try_float env other_rhs body_c = done_float env other_rhs body_c
 \end{code}
 
-Letrec expressions 
+Letrec expressions
 ~~~~~~~~~~~~~~~~~~
 
 Simplify each RHS, float any let(recs) from the RHSs (if let-floating is
@@ -853,7 +851,7 @@ macro-expansion is:
 	letrec
 		f = ....g...
 		g = ....f...
-	in 
+	in
 	....f...
 
 Here we would like the single call to g to be inlined.
@@ -909,12 +907,12 @@ group that are bound to constructors.  For example:
        /= a b    = unpack tuple a, unpack tuple b, call f
     in d.Eq
 
-here, by knowing about d.Eq in f's rhs, one could get rid of 
+here, by knowing about d.Eq in f's rhs, one could get rid of
 the case (and break out the recursion completely).
-[This occurred with more aggressive inlining threshold (4), 
+[This occurred with more aggressive inlining threshold (4),
 nofib/spectral/knights]
 
-How to do it?  
+How to do it?
 	1: we simplify constructor rhss first.
 	2: we record the "known constructors" in the environment
 	3: we simplify the other rhss, with the knowledge about the constructors
@@ -922,10 +920,10 @@ How to do it?
 
 
 \begin{code}
-simplBind env (CoRec pairs) body_c body_ty
+simplBind env (Rec pairs) body_c body_ty
   =	-- Do floating, if necessary
     (if float_lets || always_float_let_from_let
-     then 
+     then
 	mapSmpl float pairs	`thenSmpl` \ floated_pairs_s ->
 	returnSmpl (concat floated_pairs_s)
      else
@@ -944,7 +942,7 @@ simplBind env (CoRec pairs) body_c body_ty
 
     body_c new_env				`thenSmpl` \ body' ->
 
-    returnSmpl (CoLet binding body')
+    returnSmpl (Let binding body')
 
   where
     ------------ Floating stuff -------------------
@@ -981,21 +979,21 @@ simplBind env (CoRec pairs) body_c body_ty
     float_pair (binder, rhs)
     	| always_float_let_from_let ||
 	  floatExposesHNF True False False rhs
-        = (binder,rhs') : pairs'
+	= (binder,rhs') : pairs'
 
 	| otherwise
 	= [(binder,rhs)]
-	where 
+	where
 	  (pairs', rhs') = do_float rhs
 
 	-- Float just pulls out any top-level let(rec) bindings
     do_float :: InExpr -> ([(InBinder,InExpr)], InExpr)
-    do_float (CoLet (CoRec pairs) body)     = (float_pairs pairs    ++ pairs', body')
-				            where
-				              (pairs', body') = do_float body
-    do_float (CoLet (CoNonRec id rhs) body) = (float_pair (id,rhs) ++ pairs', body')
-				            where
-				              (pairs', body') = do_float body
+    do_float (Let (Rec pairs) body)     = (float_pairs pairs    ++ pairs', body')
+					    where
+					      (pairs', body') = do_float body
+    do_float (Let (NonRec id rhs) body) = (float_pair (id,rhs) ++ pairs', body')
+					    where
+					      (pairs', body') = do_float body
     do_float other			    = ([], other)
 
 simplRecursiveGroup env triples
@@ -1030,7 +1028,7 @@ simplRecursiveGroup env triples
 	(early_triples, late_triples)
 	  = partition is_early_triple ordinary_triples
 
-	is_early_triple (_, (_, CoCon _ _ _)) = True
+	is_early_triple (_, (_, Con _ _ _)) = True
 	is_early_triple (i, _               ) = idWantsToBeINLINEd i
     in
 	-- Process the early bindings first
@@ -1039,20 +1037,20 @@ simplRecursiveGroup env triples
 	-- Now further extend the environment to record our knowledge
 	-- about the form of the binders bound in the constructor bindings
     let
-        env_w_early_info = foldr add_early_info env_w_inlinings early_triples'
-        add_early_info (binder, (id', rhs')) env = extendUnfoldEnvGivenRhs env binder id' rhs'
+	env_w_early_info = foldr add_early_info env_w_inlinings early_triples'
+	add_early_info (binder, (id', rhs')) env = extendUnfoldEnvGivenRhs env binder id' rhs'
     in
 	-- Now process the non-constructor bindings
     mapSmpl (do_one_binding env_w_early_info) late_triples	`thenSmpl` \ late_triples' ->
 
 	-- Phew! We're done
     let
-	binding = CoRec (map snd early_triples' ++ map snd late_triples')
+	binding = Rec (map snd early_triples' ++ map snd late_triples')
     in
     returnSmpl (binding, env_w_early_info)
   where
 
-    do_one_binding env (id', (binder,rhs)) 
+    do_one_binding env (id', (binder,rhs))
       = simplRhsExpr env binder rhs `thenSmpl` \ rhs' ->
 	returnSmpl (binder, (id', rhs'))
 \end{code}
@@ -1061,7 +1059,7 @@ simplRecursiveGroup env triples
 @completeLet@ looks at the simplified post-floating RHS of the
 let-expression, and decides what to do.  There's one interesting
 aspect to this, namely constructor reuse.  Consider
-@	
+@
 	f = \x -> case x of
 		    (y:ys) -> y:ys
 		    []     -> ...
@@ -1076,7 +1074,7 @@ const.Int.max.wrk{-s2516-} =
 	  a.s3299 :: Int
 	  _N_ {-# U(P) #-}
 	  a.s3299 = I#! upk.s3297#
-	} in 
+	} in
 	  case (const.Int._tagCmp.wrk{-s2513-} upk.s3297# upk.s3298#) of {
 	    _LT -> I#! upk.s3298#
 	    _EQ -> a.s3299
@@ -1091,8 +1089,8 @@ only do the reverse (turn a constructor application back into a
 variable) when we find a let-expression:
 @
 	let x = C a1 .. an
-	in 
-	... (let y = C a1 .. an in ...) ... 
+	in
+	... (let y = C a1 .. an in ...) ...
 @
 where it is always good to ditch the binding for y, and replace y by
 x.  That's just what completeLetBinding does.
@@ -1118,7 +1116,7 @@ completeLet env binder@(id,binder_info) old_rhs new_rhs body_c body_ty
     body_c new_env
 
   -- Maybe the rhs is an application of error, and sure to be demanded
-  | will_be_demanded && 
+  | will_be_demanded &&
     maybeToBool maybe_error_app
   = tick CaseOfError			`thenSmpl_`
     returnSmpl retyped_error_app
@@ -1131,7 +1129,7 @@ completeLet env binder@(id,binder_info) old_rhs new_rhs body_c body_ty
 	new_env = _scc_ "euegR2" (extendUnfoldEnvGivenRhs env1 binder id' new_rhs)
     in
     body_c new_env			`thenSmpl` \ body' ->
-    returnSmpl (CoLet (CoNonRec id' new_rhs) body')
+    returnSmpl (Let (NonRec id' new_rhs) body')
 
   where
     will_be_demanded = willBeDemanded (getIdDemandInfo id)
@@ -1145,22 +1143,22 @@ completeLet env binder@(id,binder_info) old_rhs new_rhs body_c body_ty
 
     maybe_atomic_rhs
       = case new_rhs of
-	  CoVar var -> Just (CoVarAtom var, AtomicRhs)
+	  Var var -> Just (VarArg var, AtomicRhs)
 
-	  CoLit lit | not (isNoRepLit lit) 
-	    -> Just (CoLitAtom lit, AtomicRhs)
+	  Lit lit | not (isNoRepLit lit)
+	    -> Just (LitArg lit, AtomicRhs)
 
-	  CoCon con tys con_args
-	    | try_to_reuse_constr 
+	  Con con tys con_args
+	    | try_to_reuse_constr
 		   -- Look out for
 		   --	let v = C args
-		   --	in 
+		   --	in
 		   --- ...(let w = C same-args in ...)...
 		   -- Then use v instead of w.	 This may save
 		   -- re-constructing an existing constructor.
 	     -> case lookForConstructor env con tys con_args of
 		  Nothing  -> Nothing
-		  Just var -> Just (CoVarAtom var, ConReused)
+		  Just var -> Just (VarArg var, ConReused)
 
 	  other -> Nothing
 
@@ -1177,18 +1175,18 @@ completeLet env binder@(id,binder_info) old_rhs new_rhs body_c body_ty
 \begin{code}
 simplAtom :: SimplEnv -> InAtom -> OutAtom
 
-simplAtom env (CoLitAtom lit) = CoLitAtom lit
+simplAtom env (LitArg lit) = LitArg lit
 
-simplAtom env (CoVarAtom id)
+simplAtom env (VarArg id)
   | isLocallyDefined id
   = case lookupId env id of
 	Just (ItsAnAtom atom) -> atom
 	Just (InlineIt _ _ _) -> pprPanic "simplAtom InLineIt:" (ppAbove (ppr PprDebug id) (pprSimplEnv env))
-	Nothing		      -> CoVarAtom id 	-- Must be an uncloned thing
+	Nothing		      -> VarArg id 	-- Must be an uncloned thing
 
   | otherwise
   = 	-- Not locally defined, so no change
-    CoVarAtom id
+    VarArg id
 \end{code}
 
 
@@ -1202,23 +1200,23 @@ simplAtom env (CoVarAtom id)
 \begin{code}
 -- fix_up_demandedness switches off the willBeDemanded Info field
 -- for bindings floated out of a non-demanded let
-fix_up_demandedness True {- Will be demanded -} bind 
+fix_up_demandedness True {- Will be demanded -} bind
    = bind	-- Simple; no change to demand info needed
-fix_up_demandedness False {- May not be demanded -} (CoNonRec binder rhs)
-   = CoNonRec (un_demandify binder) rhs
-fix_up_demandedness False {- May not be demanded -} (CoRec pairs)
-   = CoRec [(un_demandify binder, rhs) | (binder,rhs) <- pairs]
+fix_up_demandedness False {- May not be demanded -} (NonRec binder rhs)
+   = NonRec (un_demandify 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)
 
-is_cheap_prim_app (CoPrim op tys args) = primOpOkForSpeculation op
+is_cheap_prim_app (Prim op tys args) = primOpOkForSpeculation op
 is_cheap_prim_app other		       = False
 
 computeResultType :: SimplEnv -> InExpr -> [OutArg] -> OutUniType
 computeResultType env expr args
   = do expr_ty' args
   where
-    expr_ty  = typeOfCoreExpr (unTagBinders expr)
+    expr_ty  = coreExprType (unTagBinders expr)
     expr_ty' = simplTy env expr_ty
 
     do ty [] = ty
diff --git a/ghc/compiler/simplCore/SmplLoop.lhi b/ghc/compiler/simplCore/SmplLoop.lhi
new file mode 100644
index 0000000000..89de04b35c
--- /dev/null
+++ b/ghc/compiler/simplCore/SmplLoop.lhi
@@ -0,0 +1,10 @@
+Breaks the loop between SimplEnv and MagicUFs, by telling SimplEnv all
+it needs to know about MagicUFs (not much).
+
+\begin{code}
+interface SmplLoop where
+
+import MagicUFs (MagicUnfoldingFun )
+
+data MagicUnfoldingFun
+\end{code}
diff --git a/ghc/compiler/simplStg/LambdaLift.hi b/ghc/compiler/simplStg/LambdaLift.hi
deleted file mode 100644
index 33668240d1..0000000000
--- a/ghc/compiler/simplStg/LambdaLift.hi
+++ /dev/null
@@ -1,7 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface LambdaLift where
-import Id(Id)
-import SplitUniq(SplitUniqSupply)
-import StgSyn(StgBinding)
-liftProgram :: SplitUniqSupply -> [StgBinding Id Id] -> [StgBinding Id Id]
-
diff --git a/ghc/compiler/simplStg/LambdaLift.lhs b/ghc/compiler/simplStg/LambdaLift.lhs
index 5e406d175f..40d180a318 100644
--- a/ghc/compiler/simplStg/LambdaLift.lhs
+++ b/ghc/compiler/simplStg/LambdaLift.lhs
@@ -10,14 +10,13 @@ module LambdaLift ( liftProgram ) where
 
 import StgSyn
 
-import AbsUniType	( mkForallTy, splitForalls, glueTyArgs,
-			  UniType, RhoType(..), TauType(..)
+import Type		( mkForallTy, splitForalls, glueTyArgs,
+			  Type, RhoType(..), TauType(..)
 			)
 import Bag
-import Id		( mkSysLocal, getIdUniType, addIdArity, Id )
-import IdEnv
+import Id		( mkSysLocal, idType, addIdArity, Id )
 import Maybes
-import SplitUniq
+import UniqSupply
 import SrcLoc		( mkUnknownSrcLoc, SrcLoc )
 import UniqSet
 import Util
@@ -32,8 +31,8 @@ supercombinators on a selective basis:
 * Non-recursive bindings whose RHS is a lambda abstractions are lifted,
   provided all the occurrences of the bound variable is in a function
   postition.  In this example, f will be lifted:
-	
-	let 	
+
+	let
 	  f = \x -> e
 	in
 	..(f a1)...(f a2)...
@@ -47,7 +46,7 @@ supercombinators on a selective basis:
 
   But in this case, f won't be lifted:
 
-	let 	
+	let
 	  f = \x -> e
 	in
 	..(g f)...(f a2)...
@@ -58,22 +57,22 @@ supercombinators on a selective basis:
 
 	let
 	  f = $f p q r
-	in 
+	in
 	..(g f)...($f p q r a2)..
 
   so it might as well be the original lambda abstraction.
 
   We also do not lift if the function has an occurrence with no arguments, e.g.
-  
-        let
-          f = \x -> e
-        in f
-        
+
+	let
+	  f = \x -> e
+	in f
+
   as this form is more efficient than if we create a partial application
 
   $f p q r x = e      -- Supercombinator
 
-        f p q r
+	f p q r
 
 * Recursive bindings *all* of whose RHSs are lambda abstractions are
   lifted iff
@@ -81,7 +80,7 @@ supercombinators on a selective basis:
 	- there aren't ``too many'' free variables.
 
   Same reasoning as before for the function-position stuff.  The ``too many
-  free variable'' part comes from considering the (potentially many) 
+  free variable'' part comes from considering the (potentially many)
   recursive calls, which may now have lots of free vars.
 
 Recent Observations:
@@ -93,19 +92,19 @@ Recent Observations:
 * We do not lambda lift if the function has at least one occurrence
   without any arguments. This caused lots of problems. Ex:
   h = \ x -> ... let y = ...
-                 in let let f = \x -> ...y...
-                    in f
-  ==> 
+		 in let let f = \x -> ...y...
+		    in f
+  ==>
   f = \y x -> ...y...
   h = \ x -> ... let y = ...
-                 in f y
-  
+		 in f y
+
   now f y is a partial application, so it will be updated, and this
   is Bad.
 
 
 --- NOT RELEVANT FOR STG ----
-* All ``lone'' lambda abstractions are lifted.  Notably this means lambda 
+* All ``lone'' lambda abstractions are lifted.  Notably this means lambda
   abstractions:
 	- in a case alternative: case e of True -> (\x->b)
 	- in the body of a let:  let x=e in (\y->b)
@@ -118,11 +117,11 @@ Recent Observations:
 %************************************************************************
 
 \begin{code}
-liftProgram :: SplitUniqSupply -> [PlainStgBinding] -> [PlainStgBinding]
+liftProgram :: UniqSupply -> [StgBinding] -> [StgBinding]
 liftProgram us prog = concat (runLM Nothing us (mapLM liftTopBind prog))
 
 
-liftTopBind :: PlainStgBinding -> LiftM [PlainStgBinding]
+liftTopBind :: StgBinding -> LiftM [StgBinding]
 liftTopBind (StgNonRec id rhs)
   = dontLiftRhs rhs		`thenLM` \ (rhs', rhs_info) ->
     returnLM (getScBinds rhs_info ++ [StgNonRec id rhs'])
@@ -138,20 +137,20 @@ liftTopBind (StgRec pairs)
 
 
 \begin{code}
-liftExpr :: PlainStgExpr
-	 -> LiftM (PlainStgExpr, LiftInfo)
+liftExpr :: StgExpr
+	 -> LiftM (StgExpr, LiftInfo)
 
 
-liftExpr expr@(StgConApp con args lvs) = returnLM (expr, emptyLiftInfo)
-liftExpr expr@(StgPrimApp op args lvs) = returnLM (expr, emptyLiftInfo)
+liftExpr expr@(StgCon con args lvs) = returnLM (expr, emptyLiftInfo)
+liftExpr expr@(StgPrim op args lvs) = returnLM (expr, emptyLiftInfo)
 
-liftExpr expr@(StgApp (StgLitAtom lit) args lvs) = returnLM (expr, emptyLiftInfo)
-liftExpr expr@(StgApp (StgVarAtom v)  args lvs)
+liftExpr expr@(StgApp (StgLitArg lit) args lvs) = returnLM (expr, emptyLiftInfo)
+liftExpr expr@(StgApp (StgVarArg v)  args lvs)
   = lookup v		`thenLM` \ ~(sc, sc_args) ->	-- NB the ~.  We don't want to
 							-- poke these bindings too early!
-    returnLM (StgApp (StgVarAtom sc) (map StgVarAtom sc_args ++ args) lvs,
+    returnLM (StgApp (StgVarArg sc) (map StgVarArg sc_args ++ args) lvs,
 	      emptyLiftInfo)
-	-- The lvs field is probably wrong, but we reconstruct it 
+	-- The lvs field is probably wrong, but we reconstruct it
 	-- anyway following lambda lifting
 
 liftExpr (StgCase scrut lv1 lv2 uniq alts)
@@ -191,8 +190,8 @@ lambda anyway.
 liftExpr (StgLetNoEscape _ _ (StgNonRec binder rhs) body)
   = dontLiftRhs rhs	`thenLM` \ (rhs', rhs_info) ->
     liftExpr body	`thenLM` \ (body', body_info) ->
-    returnLM (StgLet (StgNonRec binder rhs') body', 
-              rhs_info `unionLiftInfo` body_info)
+    returnLM (StgLet (StgNonRec binder rhs') body',
+	      rhs_info `unionLiftInfo` body_info)
 
 liftExpr (StgLetNoEscape _ _ (StgRec pairs) body)
   = liftExpr body			`thenLM` \ (body', body_info) ->
@@ -208,26 +207,26 @@ liftExpr (StgLet (StgNonRec binder rhs) body)
   | not (isLiftable rhs)
   = dontLiftRhs rhs	`thenLM` \ (rhs', rhs_info) ->
     liftExpr body	`thenLM` \ (body', body_info) ->
-    returnLM (StgLet (StgNonRec binder rhs') body', 
-              rhs_info `unionLiftInfo` body_info)
+    returnLM (StgLet (StgNonRec binder rhs') body',
+	      rhs_info `unionLiftInfo` body_info)
 
   | otherwise	-- It's a lambda
   = 	-- Do the body of the let
     fixLM (\ ~(sc_inline, _, _) ->
       addScInlines [binder] [sc_inline]	(
-	liftExpr body	
+	liftExpr body
       )			`thenLM` \ (body', body_info) ->
 
 	-- Deal with the RHS
-      dontLiftRhs rhs		`thenLM` \ (rhs', rhs_info) -> 
+      dontLiftRhs rhs		`thenLM` \ (rhs', rhs_info) ->
 
 	-- All occurrences in function position, so lambda lift
       getFinalFreeVars (rhsFreeVars rhs)    `thenLM` \ final_free_vars ->
 
-      mkScPieces final_free_vars (binder,rhs')	`thenLM` \ (sc_inline, sc_bind) -> 
+      mkScPieces final_free_vars (binder,rhs')	`thenLM` \ (sc_inline, sc_bind) ->
 
-      returnLM (sc_inline, 
-		body', 
+      returnLM (sc_inline,
+		body',
 		nonRecScBind rhs_info sc_bind `unionLiftInfo` body_info)
 
     )			`thenLM` \ (_, expr', final_info) ->
@@ -235,7 +234,7 @@ liftExpr (StgLet (StgNonRec binder rhs) body)
     returnLM (expr', final_info)
 
 liftExpr (StgLet (StgRec pairs) body)
---[Andre-testing]  
+--[Andre-testing]
   | not (all isLiftableRec rhss)
   = liftExpr body			`thenLM` \ (body', body_info) ->
     mapAndUnzipLM dontLiftRhs rhss	`thenLM` \ (rhss', rhs_infos) ->
@@ -250,11 +249,11 @@ liftExpr (StgLet (StgRec pairs) body)
       liftExpr body			`thenLM` \ (body', body_info) ->
       mapAndUnzipLM dontLiftRhs rhss	`thenLM` \ (rhss', rhs_infos) ->
       let
-	-- Find the free vars of all the rhss, 
+	-- Find the free vars of all the rhss,
 	-- excluding the binders themselves.
 	rhs_free_vars = unionManyUniqSets (map rhsFreeVars rhss)
-		        `minusUniqSet`
-		        mkUniqSet binders
+			`minusUniqSet`
+			mkUniqSet binders
 
 	rhs_info      = unionLiftInfos rhs_infos
       in
@@ -262,8 +261,8 @@ liftExpr (StgLet (StgRec pairs) body)
 
       mapAndUnzipLM (mkScPieces final_free_vars) (binders `zip` rhss')
 	     				`thenLM` \ (sc_inlines, sc_pairs) ->
-      returnLM (sc_inlines, 
-		body', 
+      returnLM (sc_inlines,
+		body',
 		recScBind rhs_info sc_pairs `unionLiftInfo` body_info)
 
     ))			`thenLM` \ (_, expr', final_info) ->
@@ -283,9 +282,9 @@ A binding is liftable if it's a *function* (args not null) and never
 occurs in an argument position.
 
 \begin{code}
-isLiftable :: PlainStgRhs -> Bool
+isLiftable :: StgRhs -> Bool
 
-isLiftable (StgRhsClosure _ (StgBinderInfo arg_occ _ _ _ unapplied_occ) fvs _ args _) 
+isLiftable (StgRhsClosure _ (StgBinderInfo arg_occ _ _ _ unapplied_occ) fvs _ args _)
 
   -- Experimental evidence suggests we should lift only if we will be
   -- abstracting up to 4 fvs.
@@ -294,12 +293,12 @@ isLiftable (StgRhsClosure _ (StgBinderInfo arg_occ _ _ _ unapplied_occ) fvs _ ar
 	 unapplied_occ	|| 	-- Has an occ with no args at all
 	 arg_occ	|| 	-- Occurs in arg position
 	 length fvs > 4 	-- Too many free variables
-        )
+	)
     then {-trace ("LL: " ++ show (length fvs))-} True
     else False
 isLiftable other_rhs = False
 
-isLiftableRec :: PlainStgRhs -> Bool
+isLiftableRec :: StgRhs -> Bool
 
 -- this is just the same as for non-rec, except we only lift to
 -- abstract up to 1 argument this avoids undoing Static Argument
@@ -307,9 +306,9 @@ isLiftableRec :: PlainStgRhs -> Bool
 
 {- Andre's longer comment about isLiftableRec: 1996/01:
 
-A rec binding is "liftable" (according to our heuristics) if: 
-* It is a function, 
-* all occurrences have arguments, 
+A rec binding is "liftable" (according to our heuristics) if:
+* It is a function,
+* all occurrences have arguments,
 * does not occur in an argument position and
 * has up to *2* free variables (including the rec binding variable
   itself!)
@@ -325,17 +324,17 @@ static arguments, if we change things there we should change things
 here).
 -}
 
-isLiftableRec (StgRhsClosure _ (StgBinderInfo arg_occ _ _ _ unapplied_occ) fvs _ args _) 
+isLiftableRec (StgRhsClosure _ (StgBinderInfo arg_occ _ _ _ unapplied_occ) fvs _ args _)
   = if not (null args	|| 	-- Not a function
 	 unapplied_occ	|| 	-- Has an occ with no args at all
 	 arg_occ	|| 	-- Occurs in arg position
 	 length fvs > 2 	-- Too many free variables
-        )
+	)
     then {-trace ("LLRec: " ++ show (length fvs))-} True
     else False
 isLiftableRec other_rhs = False
 
-rhsFreeVars :: PlainStgRhs -> IdSet
+rhsFreeVars :: StgRhs -> IdSet
 rhsFreeVars (StgRhsClosure _ _ fvs _ _ _) = mkUniqSet fvs
 rhsFreeVars other 			  = panic "rhsFreeVars"
 \end{code}
@@ -346,21 +345,21 @@ definitions where we've decided *not* to lift: for example, top-level
 ones or mutually-recursive ones where not all are lambdas.
 
 \begin{code}
-dontLiftRhs :: PlainStgRhs -> LiftM (PlainStgRhs, LiftInfo)
+dontLiftRhs :: StgRhs -> LiftM (StgRhs, LiftInfo)
 
 dontLiftRhs rhs@(StgRhsCon cc v args) = returnLM (rhs, emptyLiftInfo)
 
-dontLiftRhs (StgRhsClosure cc bi fvs upd args body) 
+dontLiftRhs (StgRhsClosure cc bi fvs upd args body)
   = liftExpr body	`thenLM` \ (body', body_info) ->
     returnLM (StgRhsClosure cc bi fvs upd args body', body_info)
 \end{code}
 
 \begin{code}
 mkScPieces :: IdSet 		-- Extra args for the supercombinator
-	   -> (Id, PlainStgRhs)	-- The processed RHS and original Id
+	   -> (Id, StgRhs)	-- The processed RHS and original Id
 	   -> LiftM ((Id,[Id]), 	-- Replace abstraction with this;
 						-- the set is its free vars
-		     (Id,PlainStgRhs))	-- Binding for supercombinator
+		     (Id,StgRhs))	-- Binding for supercombinator
 
 mkScPieces extra_arg_set (id, StgRhsClosure cc bi _ upd args body)
   = ASSERT( n_args > 0 )
@@ -377,8 +376,8 @@ mkScPieces extra_arg_set (id, StgRhsClosure cc bi _ upd args body)
     arity      = n_args + length extra_args
 
 	-- Construct the supercombinator type
-    type_of_original_id = getIdUniType id
-    extra_arg_tys       = map getIdUniType extra_args
+    type_of_original_id = idType id
+    extra_arg_tys       = map idType extra_args
     (tyvars, rest)      = splitForalls type_of_original_id
     sc_ty 	        = mkForallTy tyvars (glueTyArgs extra_arg_tys rest)
 
@@ -396,10 +395,10 @@ The monad is used only to distribute global stuff, and the unique supply.
 
 \begin{code}
 type LiftM a =  LiftFlags
-	     -> SplitUniqSupply
+	     -> UniqSupply
 	     -> (IdEnv 				-- Domain = candidates for lifting
 		       (Id,			-- The supercombinator
-		        [Id])			-- Args to apply it to
+			[Id])			-- Args to apply it to
 		 )
 	     -> a
 
@@ -408,7 +407,7 @@ type LiftFlags = Maybe Int	-- No of fvs reqd to float recursive
 				-- binding; Nothing == infinity
 
 
-runLM :: LiftFlags -> SplitUniqSupply -> LiftM a -> a
+runLM :: LiftFlags -> UniqSupply -> LiftM a -> a
 runLM flags us m = m flags us nullIdEnv
 
 thenLM :: LiftM a -> (a -> LiftM b) -> LiftM b
@@ -439,7 +438,7 @@ mapAndUnzipLM f (a:as) = f a			`thenLM` \ (b,c) ->
 \end{code}
 
 \begin{code}
-newSupercombinator :: UniType 
+newSupercombinator :: Type
 		   -> Int		-- Arity
 		   -> LiftM Id
 
@@ -448,10 +447,10 @@ newSupercombinator ty arity ci us idenv
     `addIdArity` arity
 	-- ToDo: rm the addIdArity?  Just let subsequent stg-saturation pass do it?
   where
-    uniq = getSUnique us
-    
+    uniq = getUnique us
+
 lookup :: Id -> LiftM (Id,[Id])
-lookup v ci us idenv 
+lookup v ci us idenv
   = case lookupIdEnv idenv v of
 	Just result -> result
 	Nothing     -> (v, [])
@@ -488,7 +487,7 @@ addScInlines ids values m ci us idenv
 
 getFinalFreeVars :: IdSet -> LiftM IdSet
 
-getFinalFreeVars free_vars ci us idenv 
+getFinalFreeVars free_vars ci us idenv
   = unionManyUniqSets (map munge_it (uniqSetToList free_vars))
   where
     munge_it :: Id -> IdSet	-- Takes a free var and maps it to the "real"
@@ -496,7 +495,7 @@ getFinalFreeVars free_vars ci us idenv
     munge_it id = case lookupIdEnv idenv id of
 			Just (_, args) -> mkUniqSet args
 			Nothing	       -> singletonUniqSet id
-  
+
 \end{code}
 
 
@@ -507,21 +506,21 @@ getFinalFreeVars free_vars ci us idenv
 %************************************************************************
 
 \begin{code}
-type LiftInfo = Bag PlainStgBinding	-- Float to top
+type LiftInfo = Bag StgBinding	-- Float to top
 
 emptyLiftInfo = emptyBag
-			
+
 unionLiftInfo :: LiftInfo -> LiftInfo -> LiftInfo
 unionLiftInfo binds1 binds2 = binds1 `unionBags` binds2
 
 unionLiftInfos :: [LiftInfo] -> LiftInfo
 unionLiftInfos infos = foldr unionLiftInfo emptyLiftInfo infos
 
-mkScInfo :: PlainStgBinding -> LiftInfo
+mkScInfo :: StgBinding -> LiftInfo
 mkScInfo bind = unitBag bind
 
 nonRecScBind :: LiftInfo 		-- From body of supercombinator
-	     -> (Id, PlainStgRhs)	-- Supercombinator and its rhs
+	     -> (Id, StgRhs)	-- Supercombinator and its rhs
 	     -> LiftInfo
 nonRecScBind binds (sc_id,sc_rhs) = binds `snocBag` (StgNonRec sc_id sc_rhs)
 
@@ -531,22 +530,22 @@ nonRecScBind binds (sc_id,sc_rhs) = binds `snocBag` (StgNonRec sc_id sc_rhs)
 -- So we flatten the whole lot into a single recursive group.
 
 recScBind :: LiftInfo			-- From body of supercombinator
-	   -> [(Id,PlainStgRhs)]	-- Supercombinator rhs
+	   -> [(Id,StgRhs)]	-- Supercombinator rhs
 	   -> LiftInfo
 
 recScBind binds pairs = unitBag (co_rec_ify (StgRec pairs : bagToList binds))
 
-co_rec_ify :: [PlainStgBinding] -> PlainStgBinding
+co_rec_ify :: [StgBinding] -> StgBinding
 co_rec_ify binds = StgRec (concat (map f binds))
   where
     f (StgNonRec id rhs) = [(id,rhs)]
     f (StgRec pairs)     = pairs
 
 
-getScBinds :: LiftInfo -> [PlainStgBinding]
+getScBinds :: LiftInfo -> [StgBinding]
 getScBinds binds = bagToList binds
 
-looksLikeSATRhs [(f,StgRhsClosure _ _ _ _ ls _)] (StgApp (StgVarAtom f') args _)
+looksLikeSATRhs [(f,StgRhsClosure _ _ _ _ ls _)] (StgApp (StgVarArg f') args _)
   = (f == f') && (length args == length ls)
 looksLikeSATRhs _ _ = False
 \end{code}
diff --git a/ghc/compiler/simplStg/SatStgRhs.hi b/ghc/compiler/simplStg/SatStgRhs.hi
deleted file mode 100644
index 899ff8e45e..0000000000
--- a/ghc/compiler/simplStg/SatStgRhs.hi
+++ /dev/null
@@ -1,7 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface SatStgRhs where
-import Id(Id)
-import SplitUniq(SplitUniqSupply)
-import StgSyn(StgBinding)
-satStgRhs :: [StgBinding Id Id] -> SplitUniqSupply -> [StgBinding Id Id]
-
diff --git a/ghc/compiler/simplStg/SatStgRhs.lhs b/ghc/compiler/simplStg/SatStgRhs.lhs
index a6793d7a78..16c903e726 100644
--- a/ghc/compiler/simplStg/SatStgRhs.lhs
+++ b/ghc/compiler/simplStg/SatStgRhs.lhs
@@ -60,16 +60,14 @@ module SatStgRhs ( satStgRhs ) where
 
 import StgSyn
 
-import AbsUniType	( splitTypeWithDictsAsArgs, Class,
+import Type		( splitTypeWithDictsAsArgs, Class,
 			  TyVarTemplate, TauType(..)
 			)
 import CostCentre
-import IdEnv
-import Id		( mkSysLocal, getIdUniType, getIdArity, addIdArity )
+import Id		( mkSysLocal, idType, getIdArity, addIdArity )
 import IdInfo		-- SIGH: ( arityMaybe, ArityInfo, OptIdInfo(..) )
 import SrcLoc		( mkUnknownSrcLoc, SrcLoc )
-import SplitUniq
-import Unique
+import UniqSupply
 import Util
 import Maybes
 
@@ -79,12 +77,12 @@ type Count = Int
 type ExprArityInfo = Maybe Int	    -- Just n  => This expression has a guaranteed
 				    --	    	  arity of n
 				    -- Nothing => Don't know how many args it needs
-				    
+
 type Id_w_Arity = Id		    -- An Id with correct arity info pinned on it
 type SatEnv     = IdEnv Id_w_Arity  -- Binds only local, let(rec)-bound things
 \end{code}
 
-This pass 
+This pass
 \begin{itemize}
 \item adds extra args where necessary;
 \item pins the correct arity on everything.
@@ -97,17 +95,17 @@ This pass
 %************************************************************************
 
 \begin{code}
-satStgRhs :: PlainStgProgram -> SUniqSM PlainStgProgram
+satStgRhs :: [StgBinding] -> UniqSM [StgBinding]
 
 satStgRhs p = satProgram nullIdEnv p
 
-satProgram :: SatEnv -> PlainStgProgram -> SUniqSM PlainStgProgram
-satProgram env [] = returnSUs []
+satProgram :: SatEnv -> [StgBinding] -> UniqSM [StgBinding]
+satProgram env [] = returnUs []
 
-satProgram env (bind:binds) 
-  = satBinding True{-toplevel-} env bind    `thenSUs` \ (env2, bind2) ->
-    satProgram env2 binds		    `thenSUs` \ binds2 ->
-    returnSUs (bind2 : binds2)
+satProgram env (bind:binds)
+  = satBinding True{-toplevel-} env bind    `thenUs` \ (env2, bind2) ->
+    satProgram env2 binds		    `thenUs` \ binds2 ->
+    returnUs (bind2 : binds2)
 \end{code}
 
 %************************************************************************
@@ -118,44 +116,44 @@ satProgram env (bind:binds)
 
 \begin{code}
 satBinding :: Bool	-- True <=> top-level
-	   -> SatEnv 
-	   -> PlainStgBinding 
-           -> SUniqSM (SatEnv, PlainStgBinding)
+	   -> SatEnv
+	   -> StgBinding
+	   -> UniqSM (SatEnv, StgBinding)
 
 satBinding top env (StgNonRec b rhs)
-  = satRhs top env (b, rhs)	`thenSUs` \ (b2, rhs2) ->
+  = satRhs top env (b, rhs)	`thenUs` \ (b2, rhs2) ->
     let
 	env2 = addOneToIdEnv env b b2
     in
-    returnSUs (env2, StgNonRec b2 rhs2)
+    returnUs (env2, StgNonRec b2 rhs2)
 
 satBinding top env (StgRec pairs)
   = -- Do it once to get the arities right...
-    mapSUs (satRhs top env) pairs   `thenSUs` \ pairs2 ->
+    mapUs (satRhs top env) pairs   `thenUs` \ pairs2 ->
     let
 	env2 = growIdEnvList env (map fst pairs `zip` map fst pairs2)
     in
     -- Do it again to *use* those arities:
-    mapSUs (satRhs top env2) pairs  `thenSUs` \ pairs3 ->
+    mapUs (satRhs top env2) pairs  `thenUs` \ pairs3 ->
 
-    returnSUs (env2, StgRec pairs3)
+    returnUs (env2, StgRec pairs3)
 
-satRhs :: Bool -> SatEnv -> (Id, PlainStgRhs) -> SUniqSM (Id_w_Arity, PlainStgRhs)
+satRhs :: Bool -> SatEnv -> (Id, StgRhs) -> UniqSM (Id_w_Arity, StgRhs)
 
 satRhs top env (b, StgRhsCon cc con args)	-- Nothing much to do here
-  = let 
+  = let
 	b2 = b `addIdArity` 0 -- bound to a saturated constructor; hence zero.
     in
-    returnSUs (b2, StgRhsCon cc con (lookupArgs env args))
+    returnUs (b2, StgRhsCon cc con (lookupArgs env args))
 
 satRhs top env (b, StgRhsClosure cc bi fv u args body)
-  = satExpr env body	`thenSUs` \ (arity_info, body2) ->
+  = satExpr env body	`thenUs` \ (arity_info, body2) ->
     let
 	num_args = length args
     in
     (case arity_info of
       Nothing ->
-	returnSUs (num_args, StgRhsClosure cc bi fv u args body2)
+	returnUs (num_args, StgRhsClosure cc bi fv u args body2)
 
       Just needed_args ->
 	ASSERT(needed_args >= 1)
@@ -165,7 +163,7 @@ satRhs top env (b, StgRhsClosure cc bi fv u args body)
 	    new_arity = num_args + needed_args
 
 	     -- get type info for this function:
-	    (_,all_arg_tys,_) = splitTypeWithDictsAsArgs (getIdUniType b)
+	    (_,all_arg_tys,_) = splitTypeWithDictsAsArgs (idType b)
 
 	     -- now, we already have "args"; we drop that many types
 	    args_we_dont_have_tys = drop num_args all_arg_tys
@@ -175,25 +173,25 @@ satRhs top env (b, StgRhsClosure cc bi fv u args body)
 	    args_to_add_tys = take needed_args args_we_dont_have_tys
 	in
 	    -- make up names for them
-	mapSUs newName args_to_add_tys	`thenSUs` \ nns ->
+	mapUs newName args_to_add_tys	`thenUs` \ nns ->
 
 	    -- and do the business
 	let
-	    body3  = saturate body2 (map StgVarAtom nns)
+	    body3  = saturate body2 (map StgVarArg nns)
 
 	    new_cc -- if we're adding args, we'd better not
 		   -- keep calling something a CAF! (what about DICTs? ToDo: WDP 95/02)
-	      = if not (isCafCC cc) 
-	        then cc -- unchanged
+	      = if not (isCafCC cc)
+		then cc -- unchanged
 		else if top then subsumedCosts else useCurrentCostCentre
 	in
-	returnSUs (new_arity, StgRhsClosure new_cc bi fv ReEntrant (args++nns) body3)
+	returnUs (new_arity, StgRhsClosure new_cc bi fv ReEntrant (args++nns) body3)
     )
-				`thenSUs` \ (arity, rhs2) ->
-    let 
+				`thenUs` \ (arity, rhs2) ->
+    let
 	b2 = b `addIdArity` arity
     in
-    returnSUs (b2, rhs2)
+    returnUs (b2, rhs2)
 \end{code}
 
 %************************************************************************
@@ -202,77 +200,77 @@ satRhs top env (b, StgRhsClosure cc bi fv u args body)
 %*									*
 %************************************************************************
 
-\begin{code}    
-satExpr :: SatEnv -> PlainStgExpr -> SUniqSM (ExprArityInfo, PlainStgExpr)
+\begin{code}
+satExpr :: SatEnv -> StgExpr -> UniqSM (ExprArityInfo, StgExpr)
 
-satExpr env app@(StgApp (StgLitAtom lit) [] lvs) = returnSUs (Nothing, app)
+satExpr env app@(StgApp (StgLitArg lit) [] lvs) = returnUs (Nothing, app)
 
-satExpr env app@(StgApp (StgVarAtom f) as lvs)
-  = returnSUs (arity_to_return, StgApp (StgVarAtom f2) as2 lvs)
+satExpr env app@(StgApp (StgVarArg f) as lvs)
+  = returnUs (arity_to_return, StgApp (StgVarArg f2) as2 lvs)
   where
     as2 = lookupArgs env as
     f2  = lookupVar  env f
     arity_to_return = case arityMaybe (getIdArity f2) of
 			Nothing      -> Nothing
 
-			Just f_arity -> if remaining_arity > 0 
+			Just f_arity -> if remaining_arity > 0
 					then Just remaining_arity
 					else Nothing
 				     where
 					remaining_arity = f_arity - length as
-				
-satExpr env app@(StgConApp con as lvs)
-  = returnSUs (Nothing, StgConApp con (lookupArgs env as) lvs)
 
-satExpr env app@(StgPrimApp op as lvs)
-  = returnSUs (Nothing, StgPrimApp op (lookupArgs env as) lvs)
+satExpr env app@(StgCon con as lvs)
+  = returnUs (Nothing, StgCon con (lookupArgs env as) lvs)
+
+satExpr env app@(StgPrim op as lvs)
+  = returnUs (Nothing, StgPrim op (lookupArgs env as) lvs)
 
 satExpr env (StgSCC ty l e)
-  = satExpr env e	 `thenSUs` \ (_, e2) ->
-    returnSUs (Nothing, StgSCC ty l e2)
+  = satExpr env e	 `thenUs` \ (_, e2) ->
+    returnUs (Nothing, StgSCC ty l e2)
 
 {- OMITTED: Let-no-escapery should come *after* saturation
 
 satExpr (StgLetNoEscape lvs_whole lvs_rhss binds body)
-  = satBinding binds	`thenSUs` \ (binds2, c) ->
-    satExpr body	`thenSUs` \ (_, body2, c2) ->
-    returnSUs (Nothing, StgLetNoEscape lvs_whole lvs_rhss binds2 body2, c + c2)
+  = satBinding binds	`thenUs` \ (binds2, c) ->
+    satExpr body	`thenUs` \ (_, body2, c2) ->
+    returnUs (Nothing, StgLetNoEscape lvs_whole lvs_rhss binds2 body2, c + c2)
 -}
 
 satExpr env (StgLet binds body)
-  = satBinding False{-not top-level-} env binds	`thenSUs` \ (env2, binds2) ->
-    satExpr env2 body				`thenSUs` \ (_, body2) ->
-    returnSUs (Nothing, StgLet binds2 body2)
+  = satBinding False{-not top-level-} env binds	`thenUs` \ (env2, binds2) ->
+    satExpr env2 body				`thenUs` \ (_, body2) ->
+    returnUs (Nothing, StgLet binds2 body2)
 
 satExpr env (StgCase expr lve lva uniq alts)
-  = satExpr env expr	`thenSUs` \ (_, expr2) ->
-    sat_alts alts	`thenSUs` \ alts2 ->
-    returnSUs (Nothing, StgCase expr2 lve lva uniq alts2)
+  = satExpr env expr	`thenUs` \ (_, expr2) ->
+    sat_alts alts	`thenUs` \ alts2 ->
+    returnUs (Nothing, StgCase expr2 lve lva uniq alts2)
     where
       sat_alts (StgAlgAlts ty alts def)
-	= mapSUs sat_alg_alt alts	`thenSUs` \ alts2 ->
-	  sat_deflt def			`thenSUs` \ def2 ->
-	  returnSUs (StgAlgAlts ty alts2 def2)
+	= mapUs sat_alg_alt alts	`thenUs` \ alts2 ->
+	  sat_deflt def			`thenUs` \ def2 ->
+	  returnUs (StgAlgAlts ty alts2 def2)
 	where
 	  sat_alg_alt (id, bs, use_mask, e)
-	    = satExpr env e `thenSUs` \ (_, e2) ->
-	      returnSUs (id, bs, use_mask, e2)
+	    = satExpr env e `thenUs` \ (_, e2) ->
+	      returnUs (id, bs, use_mask, e2)
 
       sat_alts (StgPrimAlts ty alts def)
-	= mapSUs sat_prim_alt alts 	`thenSUs` \ alts2 ->
-	  sat_deflt def			`thenSUs` \ def2 ->
-	  returnSUs (StgPrimAlts ty alts2 def2)
+	= mapUs sat_prim_alt alts 	`thenUs` \ alts2 ->
+	  sat_deflt def			`thenUs` \ def2 ->
+	  returnUs (StgPrimAlts ty alts2 def2)
 	where
 	  sat_prim_alt (l, e)
-	    = satExpr env e `thenSUs` \ (_, e2) ->
-	      returnSUs (l, e2)
+	    = satExpr env e `thenUs` \ (_, e2) ->
+	      returnUs (l, e2)
 
       sat_deflt StgNoDefault
-	= returnSUs StgNoDefault
+	= returnUs StgNoDefault
 
       sat_deflt (StgBindDefault b u expr)
-	= satExpr env expr	`thenSUs` \ (_,expr2) ->
-	  returnSUs (StgBindDefault b u expr2)
+	= satExpr env expr	`thenUs` \ (_,expr2) ->
+	  returnUs (StgBindDefault b u expr2)
 \end{code}
 
 %************************************************************************
@@ -282,26 +280,26 @@ satExpr env (StgCase expr lve lva uniq alts)
 %************************************************************************
 
 \begin{code}
-saturate :: PlainStgExpr -> [PlainStgAtom] -> PlainStgExpr
+saturate :: StgExpr -> [StgArg] -> StgExpr
 
 saturate (StgApp f as lvs) ids = StgApp f (as ++ ids) lvs
 saturate other 		    _  = panic "SatStgRhs: saturate"
 \end{code}
 
 \begin{code}
-lookupArgs :: SatEnv -> [PlainStgAtom] -> [PlainStgAtom]
+lookupArgs :: SatEnv -> [StgArg] -> [StgArg]
 lookupArgs env args = map do args
-  where 
-    do    (StgVarAtom v)  = StgVarAtom (lookupVar env v)
-    do a@(StgLitAtom lit) = a
+  where
+    do    (StgVarArg v)  = StgVarArg (lookupVar env v)
+    do a@(StgLitArg lit) = a
 
 lookupVar :: SatEnv -> Id -> Id
 lookupVar env v = case lookupIdEnv env v of
 			Nothing -> v
 			Just v2 -> v2
 
-newName :: UniType -> SUniqSM Id
+newName :: Type -> UniqSM Id
 newName ut
-  = getSUnique	`thenSUs` \ uniq ->
-    returnSUs (mkSysLocal SLIT("sat") uniq ut mkUnknownSrcLoc)
+  = getUnique	`thenUs` \ uniq ->
+    returnUs (mkSysLocal SLIT("sat") uniq ut mkUnknownSrcLoc)
 \end{code}
diff --git a/ghc/compiler/simplStg/SimplStg.hi b/ghc/compiler/simplStg/SimplStg.hi
deleted file mode 100644
index e70e2fecb3..0000000000
--- a/ghc/compiler/simplStg/SimplStg.hi
+++ /dev/null
@@ -1,11 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface SimplStg where
-import CmdLineOpts(GlobalSwitch, StgToDo, SwitchResult)
-import CostCentre(CostCentre)
-import Id(Id)
-import PreludePS(_PackedString)
-import Pretty(PprStyle)
-import SplitUniq(SplitUniqSupply)
-import StgSyn(StgBinding)
-stg2stg :: [StgToDo] -> (GlobalSwitch -> SwitchResult) -> _PackedString -> PprStyle -> SplitUniqSupply -> [StgBinding Id Id] -> _State _RealWorld -> (([StgBinding Id Id], ([CostCentre], [CostCentre])), _State _RealWorld)
-
diff --git a/ghc/compiler/simplStg/SimplStg.lhs b/ghc/compiler/simplStg/SimplStg.lhs
index 6fdb44c02c..be139b7a9b 100644
--- a/ghc/compiler/simplStg/SimplStg.lhs
+++ b/ghc/compiler/simplStg/SimplStg.lhs
@@ -11,7 +11,7 @@ module SimplStg ( stg2stg ) where
 IMPORT_Trace
 
 import StgSyn
-import StgFuns
+import StgUtils
 
 import LambdaLift	( liftProgram )
 import SCCfinal		( stgMassageForProfiling )
@@ -22,16 +22,14 @@ import UpdAnal		( updateAnalyse )
 
 import CmdLineOpts
 import Id		( unlocaliseId )
-import IdEnv
 import MainMonad
 import Maybes		( maybeToBool, Maybe(..) )
 import Outputable
 import Pretty
-import SplitUniq
 import StgLint		( lintStgBindings )
 import StgSAT		( doStaticArgs )
 import UniqSet
-import Unique
+import UniqSupply
 import Util
 \end{code}
 
@@ -40,10 +38,10 @@ stg2stg :: [StgToDo]			-- spec of what stg-to-stg passes to do
 	-> (GlobalSwitch -> SwitchResult)-- access to all global cmd-line opts
 	-> FAST_STRING			-- module name (profiling only)
 	-> PprStyle			-- printing style (for debugging only)
-	-> SplitUniqSupply		-- a name supply
-	-> [PlainStgBinding]		-- input...
+	-> UniqSupply		-- a name supply
+	-> [StgBinding]		-- input...
 	-> MainIO
-	    ([PlainStgBinding],		-- output program...
+	    ([StgBinding],		-- output program...
 	     ([CostCentre],		-- local cost-centres that need to be decl'd
 	      [CostCentre]))		-- "extern" cost-centres
 
@@ -53,7 +51,7 @@ stg2stg stg_todos sw_chkr module_name ppr_style us binds
 
     (if do_verbose_stg2stg then
 	writeMn stderr "VERBOSE STG-TO-STG:\n" `thenMn_`
-	writeMn stderr (ppShow 1000 
+	writeMn stderr (ppShow 1000
 	(ppAbove (ppStr ("*** Core2Stg:"))
 		 (ppAboves (map (ppr ppr_style) (setStgVarInfo False binds)))
 	))
@@ -88,7 +86,7 @@ stg2stg stg_todos sw_chkr module_name ppr_style us binds
 	-- info.  Also, setStgVarInfo decides about let-no-escape
 	-- things, which in turn do a better job if arities are
 	-- correct, which is done by satStgRhs.
-	--	
+	--
     let
 		-- ToDo: provide proper flag control!
 	binds_to_mangle
@@ -168,7 +166,7 @@ stg2stg stg_todos sw_chkr module_name ppr_style us binds
     end_pass us2 what ccs binds2
       = -- report verbosely, if required
 	(if do_verbose_stg2stg then
-	    writeMn stderr (ppShow 1000 
+	    writeMn stderr (ppShow 1000
 	    (ppAbove (ppStr ("*** "++what++":"))
 		     (ppAboves (map (ppr ppr_style) binds2))
 	    ))
@@ -217,7 +215,7 @@ lookup_uenv env id =  case lookupIdEnv env id of
 			Nothing     -> id
 			Just new_id -> new_id
 
-unlocaliseStgBinds :: FAST_STRING -> UnlocalEnv -> [PlainStgBinding] -> (UnlocalEnv, [PlainStgBinding])
+unlocaliseStgBinds :: FAST_STRING -> UnlocalEnv -> [StgBinding] -> (UnlocalEnv, [StgBinding])
 
 unlocaliseStgBinds mod uenv [] = (uenv, [])
 
@@ -229,7 +227,7 @@ unlocaliseStgBinds mod uenv (b : bs)
 
 ------------------
 
-unlocal_top_bind :: FAST_STRING -> UnlocalEnv -> PlainStgBinding -> (UnlocalEnv, PlainStgBinding)
+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
@@ -240,7 +238,7 @@ unlocal_top_bind mod uenv bind@(StgNonRec binder _)
 
 unlocal_top_bind mod uenv bind@(StgRec pairs)
   = let maybe_unlocaliseds  = [ (b, unlocaliseId mod b) | (b, _) <- pairs ]
-	new_uenv	    = growIdEnvList uenv [ (b,new_b) 
+	new_uenv	    = growIdEnvList uenv [ (b,new_b)
 						 | (b, Just new_b) <- maybe_unlocaliseds]
     in
     (new_uenv, renameTopStgBind (lookup_uenv new_uenv) bind)
@@ -303,7 +301,7 @@ 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 :: [PlainStgBinding] -> [PlainStgBinding]
+elimIndirections :: [StgBinding] -> [StgBinding]
 
 elimIndirections binds_in
   = if isNullIdEnv blast_env then
@@ -317,12 +315,12 @@ elimIndirections binds_in
 
     (blast_env, reduced_binds) = mapAccumL try_bind nullIdEnv binds_in
 
-    try_bind :: IdEnv Id -> PlainStgBinding -> (IdEnv Id, Maybe PlainStgBinding)
-    try_bind env_so_far 
-	     (StgNonRec exported_binder 
-		       (StgRhsClosure _ _ _ _ 
+    try_bind :: IdEnv Id -> StgBinding -> (IdEnv Id, Maybe StgBinding)
+    try_bind env_so_far
+	     (StgNonRec exported_binder
+		       (StgRhsClosure _ _ _ _
 				lambda_args
-				(StgApp (StgVarAtom local_binder) fun_args _)
+				(StgApp (StgVarArg local_binder) fun_args _)
 	     ))
 	| isExported exported_binder &&	    -- Only if this is exported
 	  not (isExported local_binder) &&  -- Only if this one is defined in this
@@ -333,12 +331,12 @@ elimIndirections binds_in
 
 	= (addOneToIdEnv env_so_far local_binder exported_binder,
 	   Nothing)
-        where
+	where
 	  args_match [] [] = True
-	  args_match (la:las) (StgVarAtom fa:fas) = la == fa && args_match las fas
+	  args_match (la:las) (StgVarArg fa:fas) = la == fa && args_match las fas
 	  args_match _  _  = False
 
-    try_bind env_so_far bind 
+    try_bind env_so_far bind
 	= (env_so_far, Just bind)
 
     in_dom env id = maybeToBool (lookupIdEnv env id)
@@ -347,7 +345,7 @@ elimIndirections binds_in
 @renameTopStgBind@ renames top level binders and all occurrences thereof.
 
 \begin{code}
-renameTopStgBind :: (Id -> Id) -> PlainStgBinding -> PlainStgBinding
+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 ]
diff --git a/ghc/compiler/simplStg/StgSAT.hi b/ghc/compiler/simplStg/StgSAT.hi
deleted file mode 100644
index b3e732e6d1..0000000000
--- a/ghc/compiler/simplStg/StgSAT.hi
+++ /dev/null
@@ -1,16 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface StgSAT where
-import CostCentre(CostCentre)
-import Id(Id)
-import PrimOps(PrimOp)
-import SplitUniq(SplitUniqSupply)
-import StgSyn(PlainStgProgram(..), StgAtom, StgBinding, StgCaseAlternatives, StgExpr, StgRhs)
-import UniType(UniType)
-import UniqFM(UniqFM)
-import Unique(Unique)
-data Id 
-type PlainStgProgram = [StgBinding Id Id]
-data StgBinding a b 
-data StgExpr a b 
-doStaticArgs :: [StgBinding Id Id] -> SplitUniqSupply -> [StgBinding Id Id]
-
diff --git a/ghc/compiler/simplStg/StgSAT.lhs b/ghc/compiler/simplStg/StgSAT.lhs
index 80cdec4208..c8a5e35dfe 100644
--- a/ghc/compiler/simplStg/StgSAT.lhs
+++ b/ghc/compiler/simplStg/StgSAT.lhs
@@ -1,5 +1,5 @@
 %
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
 %
 %************************************************************************
 %*									*
@@ -31,26 +31,20 @@ useless as map' will be transformed back to what map was.
 \begin{code}
 #include "HsVersions.h"
 
-module StgSAT (
-	doStaticArgs,
+module StgSAT (	doStaticArgs ) where
 
-	-- and to make the interface self-sufficient...
-	PlainStgProgram(..), StgExpr, StgBinding, Id
-    ) where
-
-import IdEnv
 import Maybes		( Maybe(..) )
 import StgSyn
 import SATMonad		( SATEnv(..), SATInfo(..), Arg(..), updSAEnv, insSAEnv,
-                          SatM(..), initSAT, thenSAT, thenSAT_,
-                          emptyEnvSAT, returnSAT, mapSAT )
+			  SatM(..), initSAT, thenSAT, thenSAT_,
+			  emptyEnvSAT, returnSAT, mapSAT )
 import StgSATMonad
-import SplitUniq
+import UniqSupply
 import Util
 \end{code}
 
 \begin{code}
-doStaticArgs :: PlainStgProgram -> SplitUniqSupply -> PlainStgProgram
+doStaticArgs :: [StgBinding] -> UniqSupply -> [StgBinding]
 
 doStaticArgs binds
   = initSAT (mapSAT sat_bind binds)
@@ -73,7 +67,7 @@ doStaticArgs binds
 \end{code}
 
 \begin{code}
-satAtom (StgVarAtom v)
+satAtom (StgVarArg v)
   = updSAEnv (Just (v,([],[]))) `thenSAT_`
     returnSAT ()
 
@@ -81,27 +75,27 @@ satAtom _ = returnSAT ()
 \end{code}
 
 \begin{code}
-satExpr :: PlainStgExpr -> SatM PlainStgExpr
+satExpr :: StgExpr -> SatM StgExpr
 
-satExpr e@(StgConApp con args lvs)
+satExpr e@(StgCon con args lvs)
   = mapSAT satAtom args	    `thenSAT_`
     returnSAT e
 
-satExpr e@(StgPrimApp op args lvs)
+satExpr e@(StgPrim op args lvs)
   = mapSAT satAtom args	    `thenSAT_`
     returnSAT e
 
-satExpr e@(StgApp (StgLitAtom _) _ _)
+satExpr e@(StgApp (StgLitArg _) _ _)
   = returnSAT e
 
-satExpr e@(StgApp (StgVarAtom v) args _)
+satExpr e@(StgApp (StgVarArg v) args _)
   = updSAEnv (Just (v,([],map tagArg args)))	`thenSAT_`
     mapSAT satAtom args				`thenSAT_`
     returnSAT e
-  where 
-    tagArg (StgVarAtom v) = Static v
+  where
+    tagArg (StgVarArg v) = Static v
     tagArg _              = NotStatic
-    
+
 satExpr (StgCase expr lv1 lv2 uniq alts)
   = satExpr expr	`thenSAT` \ expr' ->
     sat_alts alts	`thenSAT` \ alts' ->
@@ -172,15 +166,13 @@ satExpr (StgLet (StgRec binds) body)
 satExpr (StgSCC ty cc expr)
   = satExpr expr		    `thenSAT` \ expr' ->
     returnSAT (StgSCC ty cc expr')
-
--- ToDo: DPH stuff
 \end{code}
 
 \begin{code}
 satRhs rhs@(StgRhsCon cc v args) = returnSAT rhs
-satRhs (StgRhsClosure cc bi fvs upd args body) 
+
+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.hi b/ghc/compiler/simplStg/StgSATMonad.hi
deleted file mode 100644
index 1e443af024..0000000000
--- a/ghc/compiler/simplStg/StgSATMonad.hi
+++ /dev/null
@@ -1,15 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface StgSATMonad where
-import Id(Id)
-import SATMonad(Arg)
-import SplitUniq(SplitUniqSupply)
-import StgSyn(PlainStgExpr(..), StgBinding, StgExpr, StgRhs)
-import UniType(UniType)
-import UniqFM(UniqFM)
-data Id 
-data SplitUniqSupply 
-type PlainStgExpr = StgExpr Id Id
-data UniType 
-getArgLists :: StgRhs Id Id -> ([Arg UniType], [Arg Id])
-saTransform :: Id -> StgRhs Id Id -> SplitUniqSupply -> UniqFM ([Arg UniType], [Arg Id]) -> (StgBinding Id Id, UniqFM ([Arg UniType], [Arg Id]))
-
diff --git a/ghc/compiler/simplStg/StgSATMonad.lhs b/ghc/compiler/simplStg/StgSATMonad.lhs
index f0cb84d4d1..1da8207597 100644
--- a/ghc/compiler/simplStg/StgSATMonad.lhs
+++ b/ghc/compiler/simplStg/StgSATMonad.lhs
@@ -11,28 +11,24 @@
 #include "HsVersions.h"
 
 module StgSATMonad (
-	getArgLists, saTransform, 
-
-	Id, UniType, SplitUniqSupply, PlainStgExpr(..)
+	getArgLists, saTransform
     ) where
 
-import AbsUniType	( mkTyVarTy, mkSigmaTy, TyVarTemplate,
-			  extractTyVarsFromTy, splitType, splitTyArgs,
+import Type		( mkTyVarTy, mkSigmaTy, TyVarTemplate,
+			  extractTyVarsFromTy, splitSigmaTy, splitTyArgs,
 			  glueTyArgs, instantiateTy, TauType(..),
 			  Class, ThetaType(..), SigmaType(..),
 			  InstTyEnv(..)
 			)
-import IdEnv
-import Id		( mkSysLocal, getIdUniType, eqId )
+import Id		( mkSysLocal, idType, eqId )
 import Maybes		( Maybe(..) )
 import StgSyn
 import SATMonad         ( SATEnv(..), SATInfo(..), Arg(..), updSAEnv, insSAEnv,
-                          SatM(..), initSAT, thenSAT, thenSAT_,
-                          emptyEnvSAT, returnSAT, mapSAT, isStatic, dropStatics,
-                          getSATInfo, newSATName )
+			  SatM(..), initSAT, thenSAT, thenSAT_,
+			  emptyEnvSAT, returnSAT, mapSAT, isStatic, dropStatics,
+			  getSATInfo, newSATName )
 import SrcLoc		( SrcLoc, mkUnknownSrcLoc )
-import SplitUniq
-import Unique
+import UniqSupply
 import UniqSet		( UniqSet(..), emptyUniqSet )
 import Util
 
@@ -47,12 +43,12 @@ import Util
 \begin{code}
 newSATNames :: [Id] -> SatM [Id]
 newSATNames [] = returnSAT []
-newSATNames (id:ids) = newSATName id (getIdUniType id)	`thenSAT` \ id' ->
-                       newSATNames ids			`thenSAT` \ ids' ->
-                       returnSAT (id:ids)
+newSATNames (id:ids) = newSATName id (idType id)	`thenSAT` \ id' ->
+		       newSATNames ids			`thenSAT` \ ids' ->
+		       returnSAT (id:ids)
 
-getArgLists :: PlainStgRhs -> ([Arg UniType],[Arg Id])
-getArgLists (StgRhsCon _ _ _) 
+getArgLists :: StgRhs -> ([Arg Type],[Arg Id])
+getArgLists (StgRhsCon _ _ _)
   = ([],[])
 getArgLists (StgRhsClosure _ _ _ _ args _)
   = ([], [Static v | v <- args])
@@ -60,22 +56,22 @@ getArgLists (StgRhsClosure _ _ _ _ args _)
 \end{code}
 
 \begin{code}
-saTransform :: Id -> PlainStgRhs -> SatM PlainStgBinding
+saTransform :: Id -> StgRhs -> SatM StgBinding
 saTransform binder rhs
   = getSATInfo binder `thenSAT` \ r ->
     case r of
-      Just (_,args) | any isStatic args 
+      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
+	   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 (StgNonRec binder new_rhs)
+	   )
       _ -> returnSAT (StgRec [(binder, rhs)])
 
   where
@@ -87,17 +83,17 @@ saTransform binder rhs
 
     mkNewRhs binder binder' args rhs@(StgRhsClosure cc bi fvs upd rhsargs body) non_static_args' non_static_args
       = let
-	  local_body = StgApp (StgVarAtom binder')
-			 [StgVarAtom a | a <- non_static_args] emptyUniqSet
+	  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)
+		       (doStgSubst binder args subst_env body)
 
-	  subst_env = mkIdEnv 
-                        ((binder,binder'):zip non_static_args non_static_args')
+	  subst_env = mkIdEnv
+			((binder,binder'):zip non_static_args non_static_args')
 	in
 	returnSAT (
-	    StgRhsClosure cc bi fvs upd rhsargs 
+	    StgRhsClosure cc bi fvs upd rhsargs
 	      (StgLet (StgRec [(binder',rec_body)]) {-in-} local_body)
 	)
 
@@ -105,7 +101,7 @@ saTransform binder rhs
       = instantiateTy [] (mkSigmaTy [] dict_tys' tau_ty')
       where
 	-- get type info for the local function:
-	(tv_tmpl, dict_tys, tau_ty) = (splitType . getIdUniType) binder
+	(tv_tmpl, dict_tys, tau_ty) = (splitSigmaTy . idType) binder
 	(reg_arg_tys, res_type)	    = splitTyArgs tau_ty
 
 	-- now, we drop the ones that are
@@ -121,62 +117,62 @@ NOTE: This does not keep live variable/free variable information!!
 \begin{code}
 doStgSubst binder orig_args subst_env body
   = substExpr body
-  where 
-    substExpr (StgConApp con args lvs) 
-      = StgConApp con (map substAtom args) emptyUniqSet
-    substExpr (StgPrimApp op args lvs)
-      = StgPrimApp op (map substAtom args) emptyUniqSet
-    substExpr expr@(StgApp (StgLitAtom _) [] _) 
+  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@(StgVarAtom v)  args lvs)
+    substExpr (StgApp atom@(StgVarArg v)  args lvs)
       | v `eqId` binder
-      = StgApp (StgVarAtom (lookupNoFailIdEnv subst_env v))
-               (remove_static_args orig_args args) emptyUniqSet
+      = 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)
+	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) 
+    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@(StgLitAtom lit) = atom
-    substAtom atom@(StgVarAtom v) 
+	(binders,rhss) = unzip pairs
+
+    substAtom atom@(StgLitArg lit) = atom
+    substAtom atom@(StgVarArg v)
       = case lookupIdEnv subst_env v of
-          Just v' -> StgVarAtom v'
-          Nothing -> atom
-    
-    remove_static_args _ [] 
+	  Just v' -> StgVarArg v'
+	  Nothing -> atom
+
+    remove_static_args _ []
       = []
-    remove_static_args (Static _:origs) (_:as) 
+    remove_static_args (Static _:origs) (_:as)
       = remove_static_args origs as
-    remove_static_args (NotStatic:origs) (a:as) 
+    remove_static_args (NotStatic:origs) (a:as)
       = substAtom a:remove_static_args origs as
 \end{code}
diff --git a/ghc/compiler/simplStg/StgStats.hi b/ghc/compiler/simplStg/StgStats.hi
deleted file mode 100644
index 73aecd708a..0000000000
--- a/ghc/compiler/simplStg/StgStats.hi
+++ /dev/null
@@ -1,6 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface StgStats where
-import Id(Id)
-import StgSyn(StgBinding)
-showStgStats :: [StgBinding Id Id] -> [Char]
-
diff --git a/ghc/compiler/simplStg/StgStats.lhs b/ghc/compiler/simplStg/StgStats.lhs
index bfe00f3fbb..a513b50fa3 100644
--- a/ghc/compiler/simplStg/StgStats.lhs
+++ b/ghc/compiler/simplStg/StgStats.lhs
@@ -76,7 +76,7 @@ countN = singletonFM
 %************************************************************************
 
 \begin{code}
-showStgStats :: PlainStgProgram -> String
+showStgStats :: [StgBinding] -> String
 
 showStgStats prog
   = "STG Statistics:\n\n"
@@ -101,9 +101,9 @@ showStgStats prog
     s (SingleEntryBinds _)    = "SingleEntryBinds_Nested    "
     s (UpdatableBinds _)      = "UpdatableBinds_Nested      "
 
-gatherStgStats :: PlainStgProgram -> StatEnv
+gatherStgStats :: [StgBinding] -> StatEnv
 
-gatherStgStats binds 
+gatherStgStats binds
   = combineSEs (map (statBinding True{-top-level-}) binds)
 \end{code}
 
@@ -115,7 +115,7 @@ gatherStgStats binds
 
 \begin{code}
 statBinding :: Bool -- True <=> top-level; False <=> nested
-	    -> PlainStgBinding
+	    -> StgBinding
 	    -> StatEnv
 
 statBinding top (StgNonRec b rhs)
@@ -124,13 +124,13 @@ statBinding top (StgNonRec b rhs)
 statBinding top (StgRec pairs)
   = combineSEs (map (statRhs top) pairs)
 
-statRhs :: Bool -> (Id, PlainStgRhs) -> StatEnv
+statRhs :: Bool -> (Id, StgRhs) -> StatEnv
 
 statRhs top (b, StgRhsCon cc con args)
   = countOne (ConstructorBinds top)
 
 statRhs top (b, StgRhsClosure cc bi fv u args body)
-  = statExpr body			`combineSE` 
+  = statExpr body			`combineSE`
     countN FreeVariables (length fv)	`combineSE`
     countOne (
       case u of
@@ -146,18 +146,18 @@ statRhs top (b, StgRhsClosure cc bi fv u args body)
 %*									*
 %************************************************************************
 
-\begin{code}    
-statExpr :: PlainStgExpr -> StatEnv
+\begin{code}
+statExpr :: StgExpr -> StatEnv
 
-statExpr (StgApp _ [] lvs) 
+statExpr (StgApp _ [] lvs)
   = countOne Literals
-statExpr (StgApp _ _ lvs) 
+statExpr (StgApp _ _ lvs)
   = countOne Applications
 
-statExpr (StgConApp con as lvs)
+statExpr (StgCon con as lvs)
   = countOne ConstructorApps
 
-statExpr (StgPrimApp op as lvs)
+statExpr (StgPrim op as lvs)
   = countOne PrimitiveApps
 
 statExpr (StgSCC ty l e)
@@ -165,11 +165,11 @@ statExpr (StgSCC ty l e)
 
 statExpr (StgLetNoEscape lvs_whole lvs_rhss binds body)
   = statBinding False{-not top-level-} binds	`combineSE`
-    statExpr body				`combineSE` 
+    statExpr body				`combineSE`
     countOne LetNoEscapes
 
 statExpr (StgLet binds body)
-  = statBinding False{-not top-level-} binds	`combineSE` 
+  = statBinding False{-not top-level-} binds	`combineSE`
     statExpr body
 
 statExpr (StgCase expr lve lva uniq alts)
@@ -178,7 +178,7 @@ statExpr (StgCase expr lve lva uniq alts)
     where
       stat_alts (StgAlgAlts ty alts def)
 	= combineSEs (map statExpr [ e | (_,_,_,e) <- alts ])
-					`combineSE` 
+					`combineSE`
 	  stat_deflt def		`combineSE`
 	  countOne AlgCases
 
@@ -190,6 +190,6 @@ statExpr (StgCase expr lve lva uniq alts)
 
       stat_deflt StgNoDefault = emptySE
 
-      stat_deflt (StgBindDefault b u expr) = statExpr expr	
+      stat_deflt (StgBindDefault b u expr) = statExpr expr
 \end{code}
 
diff --git a/ghc/compiler/simplStg/StgVarInfo.hi b/ghc/compiler/simplStg/StgVarInfo.hi
deleted file mode 100644
index e4ef0ef885..0000000000
--- a/ghc/compiler/simplStg/StgVarInfo.hi
+++ /dev/null
@@ -1,6 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface StgVarInfo where
-import Id(Id)
-import StgSyn(StgBinding)
-setStgVarInfo :: Bool -> [StgBinding Id Id] -> [StgBinding Id Id]
-
diff --git a/ghc/compiler/simplStg/StgVarInfo.lhs b/ghc/compiler/simplStg/StgVarInfo.lhs
index 10d618c4a7..258ab15219 100644
--- a/ghc/compiler/simplStg/StgVarInfo.lhs
+++ b/ghc/compiler/simplStg/StgVarInfo.lhs
@@ -1,5 +1,5 @@
 %
-% (c) The GRASP/AQUA Project, Glasgow University, 1993-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1993-1996
 %
 \section[StgVarInfo]{Sets free/live variable info in STG syntax}
 
@@ -20,7 +20,6 @@ import StgSyn
 import Id		( getIdArity, externallyVisibleId )
 import IdInfo		-- ( arityMaybe, ArityInfo )
 
-import IdEnv
 import Maybes		( maybeToBool, Maybe(..) )
 import UniqSet
 import Util
@@ -44,7 +43,7 @@ it can be referred to {\em directly} again.  In particular, a dead
 variable's stack slot (if it has one):
 \begin{enumerate}
 \item
-should be stubbed to avoid space leaks, and 
+should be stubbed to avoid space leaks, and
 \item
 may be reused for something else.
 \end{enumerate}
@@ -52,14 +51,14 @@ may be reused for something else.
 There ought to be a better way to say this.  Here are some examples:
 \begin{verbatim}
 	let v = [q] \[x] -> e
-	in 
+	in
 	...v...	 (but no q's)
 \end{verbatim}
 
 Just after the `in', v is live, but q is dead.	If the whole of that
 let expression was enclosed in a case expression, thus:
 \begin{verbatim}
-	case (let v = [q] \[x] -> e in ...v...) of 
+	case (let v = [q] \[x] -> e in ...v...) of
 		alts[...q...]
 \end{verbatim}
 (ie @alts@ mention @q@), then @q@ is live even after the `in'; because
@@ -68,7 +67,7 @@ we'll return later to the @alts@ and need it.
 Let-no-escapes make this a bit more interesting:
 \begin{verbatim}
 	let-no-escape v = [q] \ [x] -> e
-	in 
+	in
 	...v...
 \end{verbatim}
 Here, @q@ is still live at the `in', because @v@ is represented not by
@@ -86,14 +85,14 @@ if @v@ is.
 Top-level:
 \begin{code}
 setStgVarInfo	:: Bool			-- True <=> do let-no-escapes
-		-> [PlainStgBinding]	-- input
-		-> [PlainStgBinding]	-- result
+		-> [StgBinding]	-- input
+		-> [StgBinding]	-- result
 
-setStgVarInfo want_LNEs pgm 
-  = pgm' 
+setStgVarInfo want_LNEs pgm
+  = pgm'
   where
     (pgm', _) = initLne want_LNEs (varsTopBinds pgm)
-    
+
 \end{code}
 
 For top-level guys, we basically aren't worried about this
@@ -101,7 +100,7 @@ live-variable stuff; we do need to keep adding to the environment
 as we step through the bindings (using @extendVarEnv@).
 
 \begin{code}
-varsTopBinds :: [PlainStgBinding] -> LneM ([PlainStgBinding], FreeVarsInfo)
+varsTopBinds :: [StgBinding] -> LneM ([StgBinding], FreeVarsInfo)
 
 varsTopBinds [] = returnLne ([], emptyFVInfo)
 varsTopBinds (bind:binds)
@@ -111,10 +110,10 @@ varsTopBinds (bind:binds)
     	returnLne ((bind' : binds'),
 		   (fv_binds `unionFVInfo` fv_bind) `minusFVBinders` binders
 		  )
-		   
+
     )
   where
-    env_extension = [(b, LetrecBound 
+    env_extension = [(b, LetrecBound
 				True {- top level -}
 				(rhsArity rhs)
 				emptyUniqSet)
@@ -128,8 +127,8 @@ varsTopBinds (bind:binds)
 
 
 varsTopBind :: FreeVarsInfo		-- Info about the body
-	    -> PlainStgBinding
-	    -> LneM (PlainStgBinding, FreeVarsInfo)
+	    -> StgBinding
+	    -> LneM (StgBinding, FreeVarsInfo)
 
 varsTopBind body_fvs (StgNonRec binder rhs)
   = varsRhs body_fvs (binder,rhs)		`thenLne` \ (rhs2, fvs, _) ->
@@ -140,7 +139,7 @@ varsTopBind body_fvs (StgRec pairs)
 	(binders, rhss) = unzip pairs
     in
     fixLne (\ ~(_, rec_rhs_fvs) ->
-	let 
+	let
 		scope_fvs = unionFVInfo body_fvs rec_rhs_fvs
 	in
 	mapAndUnzip3Lne (varsRhs scope_fvs) pairs `thenLne` \ (rhss2, fvss, _) ->
@@ -154,41 +153,41 @@ varsTopBind body_fvs (StgRec pairs)
 
 \begin{code}
 varsRhs :: FreeVarsInfo		-- Free var info for the scope of the binding
-	-> (Id,PlainStgRhs)
-	-> LneM (PlainStgRhs, FreeVarsInfo, EscVarsSet)
+	-> (Id,StgRhs)
+	-> LneM (StgRhs, FreeVarsInfo, EscVarsSet)
 
 varsRhs scope_fv_info (binder, StgRhsCon cc con args)
   = varsAtoms args	`thenLne` \ fvs ->
     returnLne (StgRhsCon cc con args, fvs, getFVSet fvs)
 
-varsRhs scope_fv_info (binder, StgRhsClosure cc _ _ upd args body) 
+varsRhs scope_fv_info (binder, StgRhsClosure cc _ _ upd args body)
   = extendVarEnv [ (a, LambdaBound) | a <- args ] (
     do_body args body	`thenLne` \ (body2, body_fvs, body_escs) ->
     let
 	set_of_args	= mkUniqSet args
 	rhs_fvs		= body_fvs  `minusFVBinders` args
 	rhs_escs	= body_escs `minusUniqSet`   set_of_args
-        binder_info     = lookupFVInfo scope_fv_info binder
+	binder_info     = lookupFVInfo scope_fv_info binder
     in
-    returnLne (StgRhsClosure cc binder_info (getFVs rhs_fvs) upd args body2, 
+    returnLne (StgRhsClosure cc binder_info (getFVs rhs_fvs) upd args body2,
 	       rhs_fvs, rhs_escs)
     )
   where
 	-- Pick out special case of application in body of thunk
-    do_body [] (StgApp (StgVarAtom f) args _) = varsApp (Just upd) f args
+    do_body [] (StgApp (StgVarArg f) args _) = varsApp (Just upd) f args
     do_body _ other_body 		      = varsExpr other_body
 \end{code}
 
 \begin{code}
-varsAtoms :: [PlainStgAtom]
+varsAtoms :: [StgArg]
 	  -> LneM FreeVarsInfo
 
 varsAtoms atoms
   = mapLne var_atom atoms	`thenLne` \ fvs_lists ->
     returnLne (unionFVInfos fvs_lists)
   where
-    var_atom a@(StgLitAtom	   _) = returnLne emptyFVInfo
-    var_atom a@(StgVarAtom v)
+    var_atom a@(StgLitArg	   _) = returnLne emptyFVInfo
+    var_atom a@(StgVarArg v)
       = lookupVarEnv v	`thenLne` \ how_bound ->
 	returnLne (singletonFVInfo v how_bound stgArgOcc)
 \end{code}
@@ -202,21 +201,21 @@ varsAtoms atoms
 @varsExpr@ carries in a monad-ised environment, which binds each
 let(rec) variable (ie non top level, not imported, not lambda bound,
 not case-alternative bound) to:
-	- its STG arity, and 
-	- its set of live vars.	 
+	- its STG arity, and
+	- its set of live vars.
 For normal variables the set of live vars is just the variable
 itself.	 For let-no-escaped variables, the set of live vars is the set
 live at the moment the variable is entered.  The set is guaranteed to
 have no further let-no-escaped vars in it.
 
 \begin{code}
-varsExpr :: PlainStgExpr
-	 -> LneM (PlainStgExpr,	-- Decorated expr
+varsExpr :: StgExpr
+	 -> LneM (StgExpr,	-- Decorated expr
 		  FreeVarsInfo,	-- Its free vars (NB free, not live)
 		  EscVarsSet)	-- Its escapees, a subset of its free vars;
 				-- also a subset of the domain of the envt
 				-- because we are only interested in the escapees
-				-- for vars which might be turned into 
+				-- for vars which might be turned into
 				-- let-no-escaped ones.
 \end{code}
 
@@ -227,24 +226,24 @@ on these components, but it in turn is not scrutinised as the basis for any
 decisions.  Hence no black holes.
 
 \begin{code}
-varsExpr (StgApp lit@(StgLitAtom _) args _)
+varsExpr (StgApp lit@(StgLitArg _) args _)
   = --(if null args then id else (trace (ppShow 80 (ppr PprShowAll args)))) (
     returnLne (StgApp lit [] emptyUniqSet, emptyFVInfo, emptyUniqSet)
     --)
 
-varsExpr (StgApp fun@(StgVarAtom f) args _) = varsApp Nothing f args
+varsExpr (StgApp fun@(StgVarArg f) args _) = varsApp Nothing f args
 
-varsExpr (StgConApp con args _) 
+varsExpr (StgCon con args _)
   = getVarsLiveInCont		`thenLne` \ live_in_cont ->
     varsAtoms args		`thenLne` \ args_fvs ->
 
-    returnLne (StgConApp con args live_in_cont, args_fvs, getFVSet args_fvs)
+    returnLne (StgCon con args live_in_cont, args_fvs, getFVSet args_fvs)
 
-varsExpr (StgPrimApp op args _) 
+varsExpr (StgPrim op args _)
   = getVarsLiveInCont		`thenLne` \ live_in_cont ->
     varsAtoms args		`thenLne` \ args_fvs ->
 
-    returnLne (StgPrimApp op args live_in_cont, args_fvs, getFVSet args_fvs)
+    returnLne (StgPrim op args live_in_cont, args_fvs, getFVSet args_fvs)
 
 varsExpr (StgSCC ty label expr)
   = varsExpr expr		`thenLne` ( \ (expr2, fvs, escs) ->
@@ -345,26 +344,19 @@ then to let-no-escapes, if we wish.
 \begin{code}
 varsExpr (StgLetNoEscape _ _ _ _) = panic "varsExpr: unexpected StgLetNoEscape"
 
-varsExpr (StgLet bind body) 
+varsExpr (StgLet bind body)
   = isSwitchSetLne {-StgDoLetNoEscapes-} `thenLne` \ want_LNEs ->
 
     (fixLne (\ ~(_, _, _, no_binder_escapes) ->
-	let 
+	let
 	    non_escaping_let = want_LNEs && no_binder_escapes
 	in
-	vars_let non_escaping_let bind body 
+	vars_let non_escaping_let bind body
     ))					`thenLne` \ (new_let, fvs, escs, _) ->
 
     returnLne (new_let, fvs, escs)
 \end{code}
 
-\begin{code}
-#ifdef DPH
--- rest of varsExpr goes here
-
-#endif {- Data Parallel Haskell -}
-\end{code}
-
 Applications:
 \begin{code}
 varsApp :: Maybe UpdateFlag		-- Just upd <=> this application is
@@ -372,24 +364,24 @@ varsApp :: Maybe UpdateFlag		-- Just upd <=> this application is
 					-- 	x = [...] \upd [] -> the_app
 					-- with specified update flag
 	-> Id				-- Function
-	-> [PlainStgAtom]		-- Arguments
-	-> LneM (PlainStgExpr, FreeVarsInfo, EscVarsSet)
+	-> [StgArg]		-- Arguments
+	-> LneM (StgExpr, FreeVarsInfo, EscVarsSet)
 
 varsApp maybe_thunk_body f args
   = getVarsLiveInCont		`thenLne` \ live_in_cont ->
 
     varsAtoms args		`thenLne` \ args_fvs ->
-  
+
     lookupVarEnv f		`thenLne` \ how_bound ->
-   
+
     let
-        n_args = length args
+	n_args = length args
 
 	fun_fvs = singletonFVInfo f how_bound fun_occ
 
 	fun_occ =
-	  case how_bound of 
-	    LetrecBound _ arity _ 
+	  case how_bound of
+	    LetrecBound _ arity _
 		| n_args == 0 -> stgFakeFunAppOcc   -- Function Application
 						    -- with no arguments.
 						    -- used by the lambda lifter.
@@ -414,13 +406,13 @@ varsApp maybe_thunk_body f args
 
 	fun_escs = case how_bound of
 
-		     LetrecBound _ arity lvs -> 
+		     LetrecBound _ arity lvs ->
 		       if arity == n_args then
 			  emptyUniqSet -- Function doesn't escape
 		       else
 			  myself -- Inexact application; it does escape
 
-		     other -> emptyUniqSet	-- Only letrec-bound escapees 
+		     other -> emptyUniqSet	-- Only letrec-bound escapees
 						-- are interesting
 
 	-- At the moment of the call:
@@ -440,9 +432,9 @@ varsApp maybe_thunk_body f args
 				   other	       -> emptyUniqSet
     in
     returnLne (
-	StgApp (StgVarAtom f) args live_at_call,
+	StgApp (StgVarArg f) args live_at_call,
 	fun_fvs  `unionFVInfo` args_fvs,
-	fun_escs `unionUniqSets` (getFVSet args_fvs)	
+	fun_escs `unionUniqSets` (getFVSet args_fvs)
 				-- All the free vars of the args are disqualified
 				-- from being let-no-escaped.
     )
@@ -451,9 +443,9 @@ varsApp maybe_thunk_body f args
 The magic for lets:
 \begin{code}
 vars_let :: Bool		-- True <=> yes, we are let-no-escaping this let
-	 -> PlainStgBinding	-- bindings
-	 -> PlainStgExpr	-- body
-    	 -> LneM (PlainStgExpr,	-- new let
+	 -> StgBinding	-- bindings
+	 -> StgExpr	-- body
+    	 -> LneM (StgExpr,	-- new let
 		  FreeVarsInfo,	-- variables free in the whole let
 		  EscVarsSet,	-- variables that escape from the whole let
 		  Bool)		-- True <=> none of the binders in the bindings
@@ -474,7 +466,7 @@ vars_let let_no_escape bind body
 	-- by virtue of being accessible via the free vars of the binding (lvs_from_fvs)
 	-- together with the live_in_cont ones
 	lookupLiveVarsForSet (bind_fvs `minusFVBinders` binders)	`thenLne` \ lvs_from_fvs ->
-	let 
+	let
 		bind_lvs = lvs_from_fvs `unionUniqSets` live_in_cont
 	in
 
@@ -482,19 +474,19 @@ vars_let let_no_escape bind body
 	-- but bind_lvs does not
 
   	-- Do the body
-        extendVarEnv env_ext (
-	        varsExpr body			`thenLne` \ (body2, body_fvs, body_escs) ->
-	        lookupLiveVarsForSet body_fvs	`thenLne` \ body_lvs ->
+	extendVarEnv env_ext (
+		varsExpr body			`thenLne` \ (body2, body_fvs, body_escs) ->
+		lookupLiveVarsForSet body_fvs	`thenLne` \ body_lvs ->
 
-	        returnLne (bind2, bind_fvs, bind_escs, bind_lvs,
-		           body2, body_fvs, body_escs, body_lvs)
+		returnLne (bind2, bind_fvs, bind_escs, bind_lvs,
+			   body2, body_fvs, body_escs, body_lvs)
 
     )) `thenLne` (\ (bind2, bind_fvs, bind_escs, bind_lvs,
 		     body2, body_fvs, body_escs, body_lvs) ->
 
 
 	-- Compute the new let-expression
-    let 
+    let
 	new_let = if let_no_escape then
 		     -- trace "StgLetNoEscape!" (
 		     StgLetNoEscape live_in_whole_let bind_lvs bind2 body2
@@ -508,7 +500,7 @@ vars_let let_no_escape bind body
 	live_in_whole_let
 	  = bind_lvs `unionUniqSets` (body_lvs `minusUniqSet` set_of_binders)
 
-	real_bind_escs = if let_no_escape then 
+	real_bind_escs = if let_no_escape then
 			    bind_escs
 			 else
 			    getFVSet bind_fvs
@@ -520,7 +512,7 @@ vars_let let_no_escape bind body
 						-- this let(rec)
 
 	no_binder_escapes = isEmptyUniqSet (set_of_binders `intersectUniqSets` all_escs)
-		-- Mustn't depend on the passed-in let_no_escape flag, since 
+		-- Mustn't depend on the passed-in let_no_escape flag, since
 		-- no_binder_escapes is used by the caller to derive the flag!
     in
     returnLne (
@@ -542,15 +534,15 @@ vars_let let_no_escape bind body
 			live_vars
 	  )
 	where
-	   live_vars = if let_no_escape then 
+	   live_vars = if let_no_escape then
 			    bind_lvs `unionUniqSets` singletonUniqSet binder
-		       else 
+		       else
 			    singletonUniqSet binder
 
-    vars_bind :: PlainStgLiveVars
+    vars_bind :: StgLiveVars
 	      -> FreeVarsInfo			-- Free var info for body of binding
-	      -> PlainStgBinding
-	      -> LneM (PlainStgBinding,
+	      -> StgBinding
+	      -> LneM (StgBinding,
 		       FreeVarsInfo, EscVarsSet,	-- free vars; escapee vars
 		       [(Id, HowBound)])
 					 -- extension to environment
@@ -569,7 +561,7 @@ vars_let let_no_escape bind body
 	in
 	extendVarEnv env_ext		  (
 	fixLne (\ ~(_, rec_rhs_fvs, _, _) ->
-		let 
+		let
 			rec_scope_fvs = unionFVInfo rec_body_fvs rec_rhs_fvs
 		in
 		mapAndUnzip3Lne (varsRhs rec_scope_fvs) pairs `thenLne` \ (rhss2, fvss, escss) ->
@@ -593,7 +585,7 @@ help.  All the stuff here is only passed {\em down}.
 \begin{code}
 type LneM a =  Bool			-- True <=> do let-no-escapes
 	    -> IdEnv HowBound
-	    -> PlainStgLiveVars		-- vars live in continuation
+	    -> StgLiveVars		-- vars live in continuation
 	    -> a
 
 type Arity = Int
@@ -602,14 +594,14 @@ data HowBound
   = ImportBound
   | CaseBound
   | LambdaBound
-  | LetrecBound	
+  | LetrecBound
 	Bool			-- True <=> bound at top level
 	Arity			-- Arity
-	PlainStgLiveVars	-- Live vars... see notes below
+	StgLiveVars	-- Live vars... see notes below
 \end{code}
 
-For a let(rec)-bound variable, x,  we record what varibles are live if 
-x is live.  For "normal" variables that is just x alone.  If x is 
+For a let(rec)-bound variable, x,  we record what varibles are live if
+x is live.  For "normal" variables that is just x alone.  If x is
 a let-no-escaped variable then x is represented by a code pointer and
 a stack pointer (well, one for each stack).  So all of the variables
 needed in the execution of x are live if x is, and are therefore recorded
@@ -620,11 +612,9 @@ The std monad functions:
 initLne :: Bool -> LneM a -> a
 initLne want_LNEs m = m want_LNEs nullIdEnv emptyUniqSet
 
-#ifdef __GLASGOW_HASKELL__
 {-# INLINE thenLne #-}
 {-# INLINE thenLne_ #-}
 {-# INLINE returnLne #-}
-#endif
 
 returnLne :: a -> LneM a
 returnLne e sw env lvs_cont = e
@@ -671,20 +661,14 @@ fixLne expr sw env lvs_cont = result
 
 Functions specific to this monad:
 \begin{code}
-{- NOT USED:
-ifSwitchSetLne :: GlobalSwitch -> LneM a -> LneM a -> LneM a
-ifSwitchSetLne switch then_ else_ switch_checker env lvs_cont
-  = (if switch_checker switch then then_ else else_) switch_checker env lvs_cont
--}
-
 isSwitchSetLne :: LneM Bool
 isSwitchSetLne want_LNEs env lvs_cont
   = want_LNEs
 
-getVarsLiveInCont :: LneM PlainStgLiveVars
+getVarsLiveInCont :: LneM StgLiveVars
 getVarsLiveInCont sw env lvs_cont = lvs_cont
 
-setVarsLiveInCont :: PlainStgLiveVars -> LneM a -> LneM a
+setVarsLiveInCont :: StgLiveVars -> LneM a -> LneM a
 setVarsLiveInCont new_lvs_cont expr sw env lvs_cont
   = expr sw env new_lvs_cont
 
@@ -705,7 +689,7 @@ lookupVarEnv v sw env lvs_cont
 -- only ever tacked onto a decorated expression. It is never used as
 -- the basis of a control decision, which might give a black hole.
 
-lookupLiveVarsForSet :: FreeVarsInfo -> LneM PlainStgLiveVars
+lookupLiveVarsForSet :: FreeVarsInfo -> LneM StgLiveVars
 
 lookupLiveVarsForSet fvs sw env lvs_cont
   = returnLne (unionManyUniqSets (map do_one (getFVs fvs)))
@@ -729,11 +713,11 @@ lookupLiveVarsForSet fvs sw env lvs_cont
 %************************************************************************
 
 \begin{code}
-type FreeVarsInfo = IdEnv (Id, Bool, StgBinderInfo)	
+type FreeVarsInfo = IdEnv (Id, Bool, StgBinderInfo)
 			-- If f is mapped to NoStgBinderInfo, that means
 			-- that f *is* mentioned (else it wouldn't be in the
 			-- IdEnv at all), but only in a saturated applications.
-			-- 
+			--
 			-- All case/lambda-bound things are also mapped to
 			-- NoStgBinderInfo, since we aren't interested in their
 			-- occurence info.
@@ -781,7 +765,7 @@ plusFVInfo (id1,top1,info1) (id2,top2,info2)
 \end{code}
 
 \begin{code}
-rhsArity :: PlainStgRhs -> Arity
+rhsArity :: StgRhs -> Arity
 rhsArity (StgRhsCon _ _ _)              = 0
 rhsArity (StgRhsClosure _ _ _ _ args _) = length args
 \end{code}
diff --git a/ghc/compiler/simplStg/UpdAnal.hi b/ghc/compiler/simplStg/UpdAnal.hi
deleted file mode 100644
index f26ca4a9be..0000000000
--- a/ghc/compiler/simplStg/UpdAnal.hi
+++ /dev/null
@@ -1,6 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface UpdAnal where
-import Id(Id)
-import StgSyn(StgBinding)
-updateAnalyse :: [StgBinding Id Id] -> [StgBinding Id Id]
-
diff --git a/ghc/compiler/simplStg/UpdAnal.lhs b/ghc/compiler/simplStg/UpdAnal.lhs
index a50e672f65..f4ac876495 100644
--- a/ghc/compiler/simplStg/UpdAnal.lhs
+++ b/ghc/compiler/simplStg/UpdAnal.lhs
@@ -12,20 +12,17 @@
 
 > module UpdAnal ( updateAnalyse ) where
 >
-> IMPORT_Trace
-
-> import AbsUniType	( splitTyArgs, splitType, Class, TyVarTemplate, 
+> import Type		( splitTyArgs, splitSigmaTy, Class, TyVarTemplate,
 > 			  TauType(..)
 >			)
 > import Id
-> import IdEnv
 > import IdInfo
 > import Outputable	( isExported )
 > import Pretty
 > import SrcLoc 	( mkUnknownSrcLoc )
 > import StgSyn
 > import UniqSet
-> import Unique 	( getBuiltinUniques )
+> import UniqSupply 	( getBuiltinUniques )
 > import Util
 
 %-----------------------------------------------------------------------------
@@ -113,11 +110,11 @@ value.  Lookup is designed to be partially applied to a variable, and
 repeatedly applied to different environments after that.
 
 > lookup v
->   | isImportedId v 
+>   | isImportedId v
 >   = const (case updateInfoMaybe (getIdUpdateInfo v) of
 >		Nothing   -> unknownClosure
 >		Just spec -> convertUpdateSpec spec)
->   | otherwise	 
+>   | otherwise
 >   = \p -> case lookup_IdEnv p v of
 >		Just b  -> b
 >		Nothing -> unknownClosure
@@ -180,16 +177,16 @@ contains more buried references.
 udData is used when we are putting a list of closure references into a
 data structure, or something else that we know nothing about.
 
-> udData :: [PlainStgAtom] -> CaseBoundVars -> AbVal
+> udData :: [StgArg] -> CaseBoundVars -> AbVal
 > udData vs cvs
 > 	= \p -> (null_IdEnv, getrefs p local_ids noRefs, bottom)
->	where local_ids = [ lookup v | (StgVarAtom v) <- vs, v `notCaseBound` cvs ]
+>	where local_ids = [ lookup v | (StgVarArg v) <- vs, v `notCaseBound` cvs ]
 
 %-----------------------------------------------------------------------------
 \subsection{Analysing an atom}
 
-> udAtom :: CaseBoundVars -> PlainStgAtom -> AbVal
-> udAtom cvs (StgVarAtom v) 
+> udAtom :: CaseBoundVars -> StgArg -> AbVal
+> udAtom cvs (StgVarArg v)
 >	| v `isCaseBound` cvs = const unknownClosure
 >	| otherwise	      = lookup v
 >
@@ -198,13 +195,13 @@ data structure, or something else that we know nothing about.
 %-----------------------------------------------------------------------------
 \subsection{Analysing an STG expression}
 
-> ud :: PlainStgExpr			-- Expression to be analysed
+> ud :: StgExpr			-- Expression to be analysed
 >    -> CaseBoundVars			-- List of case-bound vars
 >    -> IdEnvClosure			-- Current environment
->    -> (PlainStgExpr, AbVal)		-- (New expression, abstract value)
+>    -> (StgExpr, AbVal)		-- (New expression, abstract value)
 >
-> ud e@(StgPrimApp _ vs _) cvs p = (e, udData vs cvs)
-> ud e@(StgConApp  _ vs _) cvs p = (e, udData vs cvs)
+> ud e@(StgPrim _ vs _) cvs p = (e, udData vs cvs)
+> ud e@(StgCon  _ vs _) cvs p = (e, udData vs cvs)
 > ud e@(StgSCC ty lab a)   cvs p = ud a cvs p =: \(a', abval_a) ->
 >                                  (StgSCC ty lab a', abval_a)
 
@@ -220,11 +217,11 @@ I've left the type signature for doApp in to make things a bit clearer.
 >   where
 >     abval_atoms = map (udAtom cvs) atoms
 >     abval_a     = udAtom cvs a
->     abval_app = \p -> 
+>     abval_app = \p ->
 >	let doApp :: Closure -> AbVal -> Closure
 >	    doApp (c, b, Fun f) abval_atom =
->		  abval_atom p		=: \e@(_,_,_)    -> 
-> 		  f e			=: \(c', b', f') -> 
+>		  abval_atom p		=: \e@(_,_,_)    ->
+> 		  f e			=: \(c', b', f') ->
 >		  (combine_IdEnvs (+) c' c, b', f')
 >	in foldl doApp (abval_a p) abval_atoms
 
@@ -240,11 +237,11 @@ I've left the type signature for doApp in to make things a bit clearer.
 >     in
 >     (StgCase expr' lve lva uniq alts', abval_case)
 >   where
->   
->     udAlt :: PlainStgCaseAlternatives
+>
+>     udAlt :: StgCaseAlts
 >           -> IdEnvClosure
->           -> (PlainStgCaseAlternatives, AbVal)
->	    
+>           -> (StgCaseAlts, AbVal)
+>
 >     udAlt (StgAlgAlts ty [alt] StgNoDefault) p
 >         = udAlgAlt p alt		=: \(alt', abval) ->
 >	    (StgAlgAlts ty [alt'] StgNoDefault, abval)
@@ -268,10 +265,10 @@ I've left the type signature for doApp in to make things a bit clearer.
 >     udAlgAlt p (id, vs, use_mask, e)
 >       = ud e (moreCaseBound cvs vs) p	=: \(e', v) -> ((id, vs, use_mask, e'), v)
 >
->     udDef :: PlainStgCaseDefault
+>     udDef :: StgCaseDefault
 >           -> IdEnvClosure
->           -> (PlainStgCaseDefault, AbVal)
-> 
+>           -> (StgCaseDefault, AbVal)
+>
 >     udDef StgNoDefault p
 >       = (StgNoDefault, \p -> (null_IdEnv, noRefs, dont_know noRefs))
 >     udDef (StgBindDefault v is_used expr) p
@@ -299,7 +296,7 @@ closure updatable or not, based on the results of analysing the body.
 >    ud body cvs p			=: \(body', abval_body) ->
 >    abval_body	p 			=: \(c, b, abfun) ->
 >    tag b (combine_IdEnvs (+) cs c) binds' =: \tagged_binds ->
->    let 
+>    let
 >       abval p
 >	  = abval2 p				=: \(c1, p')       ->
 >    	    abval_body (grow_IdEnv p p')	=: \(c2, b, abfun) ->
@@ -309,7 +306,7 @@ closure updatable or not, based on the results of analysing the body.
 
 %-----------------------------------------------------------------------------
 \subsection{Analysing bindings}
-  
+
 For recursive sets of bindings we perform one iteration of a fixed
 point algorithm, using (dont_know fv) as a safe approximation to the
 real fixed point, where fv are the (mappings in the environment of
@@ -321,15 +318,15 @@ respective bindings have already been analysed.
 
 We don't need to find anything out about closures with arguments,
 constructor closures etc.
-  
-> udBinding :: PlainStgBinding
+
+> udBinding :: StgBinding
 >	    -> CaseBoundVars
 >           -> IdEnvClosure
->	    -> (PlainStgBinding,
+>	    -> (StgBinding,
 >		[Id],
 >	    	IdEnvClosure -> (IdEnvInt, IdEnvClosure),
 >		IdEnvClosure -> (IdEnvInt, IdEnvClosure))
-> 
+>
 > udBinding (StgNonRec v rhs) cvs p
 >   = udRhs rhs cvs p			=: \(rhs', abval) ->
 >     abval p				=: \(c, b, abfun) ->
@@ -356,20 +353,20 @@ constructor closures etc.
 >	  (cs, ps) = unzip (doRec vs abvals)
 >
 >	  doRec [] _ = []
->	  doRec (v:vs) (abval:as) 
+>	  doRec (v:vs) (abval:as)
 >	  	= abval p'	=: \(c,b,abfun) ->
 >		  (c, (v,(null_IdEnv, b, abfun))) : doRec vs as
->		
+>
 >      	in
 >	(foldr (combine_IdEnvs (+)) null_IdEnv cs, mk_IdEnv ps)
->     
+>
 >     udBind (v,rhs)
 >       = udRhs rhs cvs p		=: \(rhs', abval) ->
 >	  (v,(v,rhs'), abval)
 >
 >     collectfv (_, StgRhsClosure _ _ fv _ _ _) = fv
->     collectfv (_, StgRhsCon _ con args)       = [ v | (StgVarAtom v) <- args ]
-  
+>     collectfv (_, StgRhsCon _ con args)       = [ v | (StgVarArg v) <- args ]
+
 %-----------------------------------------------------------------------------
 \subsection{Analysing Right-Hand Sides}
 
@@ -396,11 +393,11 @@ analyse each lambda expression.
 >
 >       doLam :: Id -> (Refs -> AbVal) -> Refs -> AbVal
 >       doLam i f b p
->		= (null_IdEnv, b, 
->		   Fun (\x@(c',b',_) -> 
+>		= (null_IdEnv, b,
+>		   Fun (\x@(c',b',_) ->
 >		   	let b'' = dom_IdEnv c' `merge2` b' `merge2` b in
 >			f b'' (addOneTo_IdEnv p i x)))
-  
+
 %-----------------------------------------------------------------------------
 \subsection{Adjusting Update flags}
 
@@ -408,9 +405,9 @@ The closure is tagged single entry iff it is used at most once, it is
 not referenced from inside a data structure or function, and it has no
 arguments (closures with arguments are re-entrant).
 
-> tag :: Refs -> IdEnvInt -> PlainStgBinding -> PlainStgBinding
+> tag :: Refs -> IdEnvInt -> StgBinding -> StgBinding
 >
-> tag b c r@(StgNonRec v (StgRhsClosure cc bi fv Updatable [] body)) 
+> tag b c r@(StgNonRec v (StgRhsClosure cc bi fv Updatable [] body))
 >   = if (v `notInRefs` b) && (lookupc c v <= 1)
 >     then -- trace "One!" (
 >	   StgNonRec v (StgRhsClosure cc bi fv SingleEntry [] body)
@@ -429,11 +426,11 @@ Should we tag top level closures? This could have good implications
 for CAFs (i.e. they could be made non-updateable if only used once,
 thus preventing a space leak).
 
-> updateAnalyse :: PlainStgProgram -> PlainStgProgram {- Exported -}
-> updateAnalyse bs 
+> updateAnalyse :: [StgBinding] -> [StgBinding] {- Exported -}
+> updateAnalyse bs
 >  = udProgram bs null_IdEnv
-  
-> udProgram :: PlainStgProgram -> IdEnvClosure -> PlainStgProgram
+
+> udProgram :: [StgBinding] -> IdEnvClosure -> [StgBinding]
 > udProgram [] p = []
 > udProgram (d:ds) p
 >  = udBinding d noCaseBound p		=: \(d', vs, _, abval_bind) ->
@@ -455,14 +452,14 @@ into a real Closure value.
 >
 > mkClosure c b b' []       = (c, b', dont_know b')
 > mkClosure c b b' (0 : ns) = (null_IdEnv, b, Fun (\ _ -> mkClosure c b b' ns))
-> mkClosure c b b' (1 : ns) = (null_IdEnv, b, Fun (\ (c',b'',f) -> 
->     mkClosure 
->             (combine_IdEnvs (+) c c') 
+> mkClosure c b b' (1 : ns) = (null_IdEnv, b, Fun (\ (c',b'',f) ->
+>     mkClosure
+>             (combine_IdEnvs (+) c c')
 >             (dom_IdEnv c' `merge2` b'' `merge2` b)
 >             (b'' `merge2` b')
 >	      ns ))
 > mkClosure c b b' (n : ns) = (null_IdEnv, b, Fun (\ (c',b'',f) ->
->     mkClosure c 
+>     mkClosure c
 >             (dom_IdEnv c' `merge2` b'' `merge2` b)
 >             (dom_IdEnv c' `merge2` b'' `merge2` b')
 >	      ns ))
@@ -471,7 +468,7 @@ Convert a Closure into a representation that can be placed in a .hi file.
 
 > mkUpdateSpec :: Id -> Closure -> UpdateSpec
 > mkUpdateSpec v f = {- removeSuperfluous2s -} (map countUses ids)
->	    where 
+>	    where
 >		(c,b,_)     = foldl doApp f ids
 >	      	ids         = map mkid (getBuiltinUniques arity)
 >	      	mkid u      = mkSysLocal SLIT("upd") u noType mkUnknownSrcLoc
@@ -479,10 +476,10 @@ Convert a Closure into a representation that can be placed in a .hi file.
 >	      	noType      = panic "UpdAnal: no type!"
 >
 >     		doApp (c,b,Fun f) i
->       		= f (unit_IdEnv i 1, noRefs, dont_know noRefs)  =: \(c',b',f') -> 
+>       		= f (unit_IdEnv i 1, noRefs, dont_know noRefs)  =: \(c',b',f') ->
 >	  		  (combine_IdEnvs (+) c' c, b', f')
 >
->		(_,dict_tys,tau_ty) = (splitType . getIdUniType) v
+>		(_,dict_tys,tau_ty) = (splitSigmaTy . idType) v
 > 	        (reg_arg_tys, _)    = splitTyArgs tau_ty
 >		arity               = length dict_tys + length reg_arg_tys
 
@@ -499,11 +496,11 @@ suffice for now.
 >   = case b of
 >	StgNonRec v rhs -> StgNonRec (attachOne v) rhs
 >	StgRec bs 	-> StgRec [ (attachOne v, rhs) | (v, rhs) <- bs ]
->	
+>
 >   where attachOne v
->		| isExported v 
+>		| isExported v
 >			= let c = lookup v p in
->		 		addIdUpdateInfo v 
+>		 		addIdUpdateInfo v
 >					(mkUpdateInfo (mkUpdateSpec v c))
 >		| otherwise    = v
 
diff --git a/ghc/compiler/specialise/SpecEnv.lhs b/ghc/compiler/specialise/SpecEnv.lhs
new file mode 100644
index 0000000000..374b4c0139
--- /dev/null
+++ b/ghc/compiler/specialise/SpecEnv.lhs
@@ -0,0 +1,253 @@
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1993-1996
+%
+\section[SpecEnv]{Specialisation info about an @Id@}
+
+\begin{code}
+#include "HsVersions.h"
+
+module SpecEnv (
+	SpecEnv(..), MatchEnv,
+	nullSpecEnv, isNullSpecEnv,
+	addOneToSpecEnv, lookupSpecEnv,
+	specEnvToList
+    ) where
+
+import Ubiq
+
+import MatchEnv
+import Type		( matchTys, isTyVarTy )
+import Usage		( UVar(..) )
+\end{code}
+
+
+A @SpecEnv@ holds details of an @Id@'s specialisations:
+
+\begin{code}
+type CoreExpr = GenCoreExpr Id Id TyVar Unique
+type SpecEnv = MatchEnv [Type] CoreExpr
+\end{code}
+
+For example, if \tr{f}'s @SpecEnv@ contains the mapping:
+\begin{verbatim}
+	[List a, b]  ===>  (\d -> f' a b)
+\end{verbatim}
+then
+\begin{verbatim}
+	f (List Int) Bool d  ===>  f' Int Bool
+\end{verbatim}
+
+\begin{code}
+nullSpecEnv :: SpecEnv
+nullSpecEnv = nullMEnv
+
+isNullSpecEnv :: SpecEnv -> Bool
+isNullSpecEnv env = null (mEnvToList env)
+
+specEnvToList :: SpecEnv -> [([Type],CoreExpr)]
+specEnvToList env = mEnvToList env
+	
+addOneToSpecEnv :: SpecEnv -> [Type] -> CoreExpr -> MaybeErr SpecEnv ([Type], CoreExpr)
+addOneToSpecEnv env tys rhs = insertMEnv matchTys env tys rhs
+
+lookupSpecEnv :: SpecEnv -> [Type] -> Maybe (CoreExpr, [(TyVar,Type)])
+lookupSpecEnv env tys 
+  | all isTyVarTy tys = Nothing	-- Short cut: no specialisation for simple tyvars
+  | otherwise	      = lookupMEnv matchTys env tys
+\end{code}
+
+
+
+=================================================================
+	BELOW HERE SCHEDULED FOR DELETION!
+
+
+The details of one specialisation, held in an @Id@'s
+@SpecEnv@ are as follows:
+\begin{pseudocode}
+data SpecInfo
+  = SpecInfo	[Maybe Type] -- Instance types; no free type variables in here
+	    	Int		-- No. of dictionaries to eat
+		Id		-- Specialised version
+\end{pseudocode}
+
+For example, if \tr{f} has this @SpecInfo@:
+\begin{verbatim}
+	SpecInfo [Just t1, Nothing, Just t3] 2 f'
+\end{verbatim}
+then
+\begin{verbatim}
+	f t1 t2 t3 d1 d2  ===>  f t2
+\end{verbatim}
+The \tr{Nothings} identify type arguments in which the specialised
+version is polymorphic.
+
+\begin{pseudocode}
+data SpecEnv = SpecEnv [SpecInfo]
+
+mkSpecEnv = SpecEnv
+nullSpecEnv = SpecEnv []
+addOneToSpecEnv (SpecEnv xs) x = SpecEnv (x : xs)
+
+
+lookupConstMethodId :: Id -> Type -> Maybe Id
+    -- slight variant on "lookupSpecEnv" below
+
+lookupConstMethodId sel_id spec_ty
+  = case (getInfo (getIdInfo sel_id)) of
+      SpecEnv spec_infos -> firstJust (map try spec_infos)
+  where
+    try (SpecInfo (Just ty:nothings) _ const_meth_id)
+      = ASSERT(all nothing_is_nothing nothings)
+	case (cmpType True{-properly-} ty spec_ty) of
+	  EQ_ -> Just const_meth_id
+	  _   -> Nothing
+
+    nothing_is_nothing Nothing = True  -- debugging only
+    nothing_is_nothing _ = panic "nothing_is_nothing!"
+
+lookupSpecId :: Id		-- *un*specialised Id
+	     -> [Maybe Type]	-- types to which it is to be specialised
+	     -> Id		-- specialised Id
+
+lookupSpecId unspec_id ty_maybes
+  = case (getInfo (getIdInfo unspec_id))  of { SpecEnv spec_infos ->
+
+    case (firstJust (map try spec_infos)) of
+      Just id -> id
+      Nothing -> error ("ERROR: There is some confusion about a value specialised to a type;\ndetails follow (and more info in the User's Guide):\n\t"++(ppShow 80 (ppr PprDebug unspec_id)))
+    }
+  where
+    try (SpecInfo template_maybes _ id)
+	| and (zipWith same template_maybes ty_maybes)
+	&& length template_maybes == length ty_maybes = Just id
+	| otherwise 				      = Nothing
+
+    same Nothing    Nothing    = True
+    same (Just ty1) (Just ty2) = ty1 == ty2
+    same _	    _	       = False
+
+lookupSpecEnv :: SpecEnv
+	      -> [Type]
+	      -> Maybe (Id,
+			[Type],
+			Int)
+
+lookupSpecEnv (SpecEnv []) _ = Nothing 	-- rather common case
+
+lookupSpecEnv spec_env [] = Nothing	-- another common case
+
+	-- This can happen even if there is a non-empty spec_env, because
+	-- of eta reduction.  For example, we might have a defn
+	--
+	--	f = /\a -> \d -> g a d
+	-- which gets transformed to
+	--	f = g
+	--
+	-- Now g isn't applied to any arguments
+
+lookupSpecEnv se@(SpecEnv spec_infos) spec_tys
+  = select_match spec_infos
+  where
+    select_match []		-- no matching spec_infos
+      = Nothing
+    select_match (SpecInfo ty_maybes toss spec_id : rest)
+      = case (match ty_maybes spec_tys) of
+	  Nothing       -> select_match rest
+	  Just tys_left -> select_next [(spec_id,tys_left,toss)] (length tys_left) toss rest
+
+	-- Ambiguity can only arise as a result of specialisations with
+	-- an explicit spec_id. The best match is deemed to be the match
+	-- with least polymorphism i.e. has the least number of tys left.
+	-- This is a non-critical approximation. The only type arguments
+	-- where there may be some discretion is for non-overloaded boxed
+	-- types. Unboxed types must be matched and we insist that we
+	-- always specialise on overloaded types (and discard all the dicts).
+
+    select_next best _ toss []
+      =	case best of
+	    [match] -> Just match	-- Unique best match
+	    ambig   -> pprPanic "Ambiguous Specialisation:\n"
+				(ppAboves [ppStr "(check specialisations with explicit spec ids)",
+					   ppCat (ppStr "between spec ids:" :
+						  map (ppr PprDebug) [id | (id, _, _) <- ambig]),
+					   pp_stuff])
+
+    select_next best tnum dnum (SpecInfo ty_maybes toss spec_id : rest)
+      = ASSERT(dnum == toss)
+	case (match ty_maybes spec_tys) of
+	  Nothing       -> select_next best tnum dnum rest
+	  Just tys_left ->
+	     let tys_len = length tys_left in
+	     case _tagCmp tnum tys_len of
+	       _LT -> select_next [(spec_id,tys_left,toss)] tys_len dnum rest	-- better match
+	       _EQ -> select_next ((spec_id,tys_left,toss):best) tnum dnum rest	-- equivalent match
+	       _GT -> select_next best tnum dnum rest				-- worse match
+
+
+    match [{-out of templates-}] [] = Just []
+
+    match (Nothing:ty_maybes) (spec_ty:spec_tys)
+      = case (isUnboxedDataType spec_ty) of
+	  True  -> Nothing	-- Can only match boxed type against
+				-- type argument which has not been
+				-- specialised on
+	  False -> case match ty_maybes spec_tys of
+		     Nothing  -> Nothing
+		     Just tys -> Just (spec_ty:tys)
+
+    match (Just ty:ty_maybes) (spec_ty:spec_tys)
+      = case (cmpType True{-properly-} ty spec_ty) of
+	  EQ_   -> match ty_maybes spec_tys
+	  other -> Nothing
+
+    match [] _ = pprPanic "lookupSpecEnv1\n" pp_stuff
+		 -- This is a Real Problem
+
+    match _ [] = pprPanic "lookupSpecEnv2\n" pp_stuff
+		 -- Partial eta abstraction might make this happen;
+		 -- meanwhile let's leave in the check
+
+    pp_stuff = ppAbove (pp_specs PprDebug True (\x->x) nullIdEnv se) (ppr PprDebug spec_tys)
+\end{pseudocode}
+
+
+\begin{pseudocode}
+instance OptIdInfo SpecEnv where
+    noInfo = nullSpecEnv
+
+    getInfo (IdInfo _ _ spec _ _ _ _ _ _ _) = spec
+
+    addInfo (IdInfo a b (SpecEnv old_spec) d e f g h i j) (SpecEnv new_spec)
+	= IdInfo a b (SpecEnv (new_spec ++ old_spec)) d e f g h i j
+	-- We *add* the new specialisation info rather than just replacing it
+	-- so that we don't lose old specialisation details.
+
+    ppInfo sty better_id_fn spec_env
+      = pp_specs sty True better_id_fn nullIdEnv spec_env
+
+pp_specs sty _ _ _ (SpecEnv [])  = pp_NONE
+pp_specs sty print_spec_ids better_id_fn inline_env (SpecEnv specs)
+  = ppBeside (ppPStr SLIT("_SPECIALISE_ ")) (pp_the_list [
+       ppCat [ppLbrack, ppIntersperse pp'SP{-'-} (map pp_maybe ty_maybes), ppRbrack,
+	      ppInt numds,
+	      let
+		 better_spec_id = better_id_fn spec_id
+		 spec_id_info = getIdInfo better_spec_id
+	      in
+	      if not print_spec_ids || boringIdInfo spec_id_info then
+		 ppNil
+	      else
+		 ppCat [ppChar '{',
+			ppIdInfo sty better_spec_id True{-wrkr specs too!-} better_id_fn inline_env spec_id_info,
+			ppChar '}']
+	     ]
+       | (SpecInfo ty_maybes numds spec_id) <- specs ])
+  where
+    pp_the_list [p]    = p
+    pp_the_list (p:ps) = ppBesides [p, pp'SP{-'-}, pp_the_list ps]
+
+    pp_maybe Nothing  = ifPprInterface sty pp_NONE
+    pp_maybe (Just t) = pprParendType sty t
+\end{pseudocode}
+
diff --git a/ghc/compiler/specialise/SpecTyFuns.hi b/ghc/compiler/specialise/SpecTyFuns.hi
deleted file mode 100644
index 12d1bc90b2..0000000000
--- a/ghc/compiler/specialise/SpecTyFuns.hi
+++ /dev/null
@@ -1,24 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface SpecTyFuns where
-import Bag(Bag)
-import Class(Class)
-import Id(Id)
-import Maybes(Labda(..))
-import PreludePS(_PackedString)
-import Pretty(Pretty(..), PrettyRep)
-import TyCon(TyCon)
-import TyVar(TyVarTemplate)
-import UniType(UniType)
-type ConstraintVector = [Bool]
-data Labda a   = Hamna | Ni a
-type Pretty = Int -> Bool -> PrettyRep
-data UniType 
-argTysMatchSpecTys_error :: [Labda UniType] -> [UniType] -> Labda (Int -> Bool -> PrettyRep)
-getIdOverloading :: Id -> ([TyVarTemplate], [(Class, TyVarTemplate)])
-isUnboxedSpecialisation :: [Labda UniType] -> Bool
-mkConstraintVector :: Id -> [Bool]
-mkSpecialisedCon :: Id -> [UniType] -> Id
-pprSpecErrs :: _PackedString -> Bag (Id, [Labda UniType]) -> Bag (Id, [Labda UniType]) -> Bag (TyCon, [Labda UniType]) -> Int -> Bool -> PrettyRep
-specialiseCallTys :: Bool -> Bool -> Bool -> [Bool] -> [UniType] -> [Labda UniType]
-specialiseConstrTys :: [UniType] -> [Labda UniType]
-
diff --git a/ghc/compiler/specialise/SpecTyFuns.lhs b/ghc/compiler/specialise/SpecTyFuns.lhs
deleted file mode 100644
index a0131943f4..0000000000
--- a/ghc/compiler/specialise/SpecTyFuns.lhs
+++ /dev/null
@@ -1,346 +0,0 @@
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1993-1995
-%
-\section[Specialise]{Stamping out overloading, and (optionally) polymorphism}
-
-\begin{code}
-#include "HsVersions.h"
-
-module SpecTyFuns (
-	specialiseCallTys,
-	ConstraintVector(..),
-	getIdOverloading,
-	mkConstraintVector,
-	isUnboxedSpecialisation,
-
-	specialiseConstrTys,
-	mkSpecialisedCon,
-
-	argTysMatchSpecTys_error,
-
-	pprSpecErrs,
-
-	Maybe(..), Pretty(..), UniType
-    ) where
-
-import AbsUniType
-import Bag		( Bag, isEmptyBag, bagToList )
-import FiniteMap	( FiniteMap, emptyFM, addListToFM_C,
-			  plusFM_C, keysFM, lookupWithDefaultFM
-			)
-import Id		( mkSameSpecCon, getIdUniType,
-			  isDictFunId, isConstMethodId_maybe,
-			  isDefaultMethodId_maybe,
-			  getInstIdModule, Id )
-import Maybes	
-import Outputable
-import Pretty
-import Util
-\end{code}
-
-@specialiseCallTys@ works out which type args don't need to be specialised on,
-based on flags, the overloading constraint vector, and the types.
-
-\begin{code}
-specialiseCallTys :: Bool 		-- Specialise on all type args
-		  -> Bool 		-- Specialise on unboxed type args
-		  -> Bool		-- Specialise on overloaded type args
-		  -> ConstraintVector	-- Tells which type args are overloaded
-		  -> [UniType]		-- Type args
-		  -> [Maybe UniType]	-- Nothings replace non-specialised type args
-
-specialiseCallTys True _ _ cvec tys
-  = map Just tys
-specialiseCallTys False spec_unboxed spec_overloading cvec tys
-  = zipWith spec_ty_other cvec tys
-  where
-    spec_ty_other c ty | (spec_unboxed && isUnboxedDataType ty)
-		         || (spec_overloading && c)
-		         = Just ty
-		       | otherwise
-                         = Nothing
-\end{code}
-
-@getIdOverloading@ grabs the type of an Id, and returns a 
-list of its polymorphic variables, and the initial segment of
-its ThetaType, in which the classes constrain only type variables.
-For example, if the Id's type is
-
-	forall a,b,c. Eq a -> Ord [a] -> tau
-
-we'll return
-
-	([a,b,c], [(Eq,a)])
-
-This seems curious at first.  For a start, the type above looks odd,
-because we usually only have dictionary args whose types are of
-the form (C a) where a is a type variable.  But this doesn't hold for
-the functions arising from instance decls, which sometimes get 
-arguements with types of form (C (T a)) for some type constructor T.
-
-Should we specialise wrt this compound-type dictionary?  This is
-a heuristic judgement, as indeed is the fact that we specialise wrt
-only dictionaries.  We choose *not* to specialise wrt compound dictionaries
-because at the moment the only place they show up is in instance decls,
-where they are simply plugged into a returned dictionary.  So nothing is
-gained by specialising wrt them.
-
-\begin{code}
-getIdOverloading :: Id
-		 -> ([TyVarTemplate], [(Class,TyVarTemplate)])
-getIdOverloading id
-  = (tyvars, tyvar_part_of theta)
-  where
-    (tyvars, theta, _) = splitType (getIdUniType id)
-
-    tyvar_part_of [] 		      = []
-    tyvar_part_of ((clas,ty) : theta) = case getTyVarTemplateMaybe ty of
-					    Nothing    -> []
-					    Just tyvar -> (clas, tyvar) : tyvar_part_of theta
-\end{code}
-
-\begin{code}
-type ConstraintVector = [Bool]	-- True for constrained tyvar, false otherwise
-
-mkConstraintVector :: Id 
-	           -> ConstraintVector
-
-mkConstraintVector id
-  = [tyvar `elem` constrained_tyvars | tyvar <- tyvars]
-  where
-    (tyvars, class_tyvar_pairs) = getIdOverloading id
-    constrained_tyvars   = map snd class_tyvar_pairs 	-- May contain dups
-\end{code}
-
-\begin{code}
-isUnboxedSpecialisation :: [Maybe UniType] -> Bool
-isUnboxedSpecialisation tys
-  = any is_unboxed tys
-  where
-    is_unboxed (Just ty) = isUnboxedDataType ty
-    is_unboxed Nothing   = False
-\end{code}
-
-@specialiseConstrTys@ works out which type args don't need to be
-specialised on. We only speciailise on unboxed types.
-
-\begin{code}
-specialiseConstrTys :: [UniType]
-		    -> [Maybe UniType]
-
-specialiseConstrTys tys
-  = map maybe_unboxed_ty tys
-  where
-    maybe_unboxed_ty ty = case isUnboxedDataType ty of
-			    True  -> Just ty
-			    False -> Nothing
-\end{code}
-
-\begin{code}
-mkSpecialisedCon :: Id -> [UniType] -> Id
-mkSpecialisedCon con tys
-  = if spec_reqd
-    then mkSameSpecCon spec_tys con
-    else con
-  where
-    spec_tys  = specialiseConstrTys tys
-    spec_reqd = maybeToBool (firstJust spec_tys)
-\end{code}
-
-@argTysMatchSpecTys@ checks if a list of argument types is consistent
-with a list of specialising types. An error message is returned if not.
-\begin{code}
-argTysMatchSpecTys_error :: [Maybe UniType]
-			 -> [UniType] 
-			 -> Maybe Pretty
-argTysMatchSpecTys_error spec_tys arg_tys
-  = if match spec_tys arg_tys
-    then Nothing
-    else Just (ppSep [ppStr "Spec and Arg Types Inconsistent:",
-		      ppStr "spectys=", ppSep [pprMaybeTy PprDebug ty | ty <- spec_tys],
-		      ppStr "argtys=", ppSep [pprParendUniType PprDebug ty | ty <- arg_tys]])
-  where
-    match (Nothing:spec_tys) (arg:arg_tys)
-      = not (isUnboxedDataType arg) &&
-        match spec_tys arg_tys
-    match (Just spec:spec_tys) (arg:arg_tys)
-      = case (cmpUniType True{-properly-} spec arg) of
-          EQ_   -> match spec_tys arg_tys
-          other -> False
-    match [] [] = True
-    match _  _  = False
-\end{code}
-
-@pprSpecErrs@ prints error and warning information
-about imported specialisations which do not exist.
-
-\begin{code}
-pprSpecErrs :: FAST_STRING			-- module name
-	    -> (Bag (Id,[Maybe UniType]))	-- errors
-	    -> (Bag (Id,[Maybe UniType]))	-- warnings
-	    -> (Bag (TyCon,[Maybe UniType]))	-- errors
-	    -> Pretty
-
-pprSpecErrs this_mod spec_errs spec_warn spec_tyerrs
-  | not any_errs && not any_warn
-  = ppNil
-
-  | otherwise
-  = ppAboves [
-	ppStr "SPECIALISATION MESSAGES:",
-	ppAboves (map pp_module_specs use_modules)
-        ]
-  where
-    any_errs = not (isEmptyBag spec_errs && isEmptyBag spec_tyerrs)
-    any_warn = not (isEmptyBag spec_warn)
-
-    mk_module_fm get_mod_data errs_bag
-      = addListToFM_C (++) emptyFM errs_list
-      where
-        errs_list = map get_mod_data (bagToList errs_bag)
-
-    tyspecs_fm = mk_module_fm get_ty_data spec_tyerrs
-
-    iderrs_fm  = mk_module_fm (get_id_data True) spec_errs
-    idwarn_fm  = mk_module_fm (get_id_data False) spec_warn
-    idspecs_fm = plusFM_C (++) idwarn_fm iderrs_fm
-
-    get_id_data is_err (id, tys)
-      = (mod_name, [(id_name, id, tys, is_err)])
-      where
-	(mod_name, id_name) = get_id_name id
-
-    get_id_name id
-      | maybeToBool (isDefaultMethodId_maybe id)
-      = (this_mod, _NIL_)
-
-      | isDictFunId id || maybeToBool (isConstMethodId_maybe id)
-      = let get_mod = getInstIdModule id
-	    use_mod = if from_prelude get_mod
-		      then SLIT("Prelude")
-		      else get_mod
-	in (use_mod, _NIL_)
-
-      | otherwise
-      = getOrigName id
-
-    get_ty_data (ty, tys)
-      = (mod_name, [(ty_name, ty, tys)])
-      where
-	(mod_name,ty_name) = getOrigName ty
-
-    from_prelude mod
-      = SLIT("Prelude") == (_SUBSTR_ mod 0 6)
- 
-    module_names    = concat [keysFM idspecs_fm, keysFM tyspecs_fm]
-    mods            = map head (equivClasses _CMP_STRING_ module_names)
-
-    (unks, known)   = if null mods
-		      then ([], [])
-		      else case _CMP_STRING_ (head mods) _NIL_ of
-			    EQ_   -> ([_NIL_], tail mods)
-			    other -> ([], mods)
-				   
-    (prels, others) = partition from_prelude known
-    use_modules     = unks ++ prels ++ others
-
-    pp_module_specs :: FAST_STRING -> Pretty
-    pp_module_specs mod
-      | mod == _NIL_
-      = ASSERT (null mod_tyspecs)
-	ppAboves (map (pp_idspec ty_sty (ppStr "UNKNOWN:")) mod_idspecs)
-
-      | have_specs
-      = ppAboves [
-	    ppAboves (map (pp_tyspec ty_sty (pp_module mod)) mod_tyspecs),
-	    ppAboves (map (pp_idspec ty_sty (pp_module mod)) mod_idspecs)
-	    ]
-
-      | otherwise
-      = ppNil
-
-      where
-        mod_tyspecs = lookupWithDefaultFM tyspecs_fm [] mod
-        mod_idspecs = lookupWithDefaultFM idspecs_fm [] mod
-	have_specs  = not (null mod_tyspecs && null mod_idspecs)
-	ty_sty = PprInterface (error "SpecTyFuns:PprInterface:sw_chkr")
-
-pp_module mod
-  = ppBesides [ppPStr mod, ppStr ":"]
-
-pp_tyspec :: PprStyle -> Pretty -> (FAST_STRING, TyCon, [Maybe UniType]) -> Pretty
-
-pp_tyspec sty pp_mod (_, tycon, tys)
-  = ppCat [pp_mod,
-	   ppStr "{-# SPECIALIZE", ppStr "data",
-	   pprNonOp PprForUser tycon, ppCat (map (pprParendUniType sty) spec_tys),
-	   ppStr "#-}", ppStr "{- Essential -}"
-           ]
-  where
-    tvs = getTyConTyVarTemplates tycon
-    (spec_args, tv_maybes) = unzip (map choose_ty (tvs `zip` tys))
-    spec_tys = map (mkForallTy (catMaybes tv_maybes)) spec_args
-
-    choose_ty (tv, Nothing) = (mkTyVarTemplateTy tv, Just tv)
-    choose_ty (tv, Just ty) = (ty, Nothing)
-
-pp_idspec :: PprStyle -> Pretty -> (FAST_STRING, Id, [Maybe UniType], Bool) -> Pretty
-
-pp_idspec sty pp_mod (_, id, tys, is_err)
-  | isDictFunId id
-  = ppCat [pp_mod,
-	   ppStr "{-# SPECIALIZE",
-	   ppStr "instance",
-	   pprUniType sty spec_ty,
-	   ppStr "#-}", pp_essential ]
-
-  | is_const_method_id
-  = let
-	Just (cls, clsty, clsop) = const_method_maybe
-    	(_, cls_str) = getOrigName cls
-	clsop_str    = getClassOpString clsop
-    in
-    ppCat [pp_mod,
-	   ppStr "{-# SPECIALIZE",
-	   pp_clsop clsop_str, ppStr "::",
-	   pprUniType sty spec_ty,
-	   ppStr "#-} {- IN instance",
-	   ppPStr cls_str, pprParendUniType sty clsty,
-	   ppStr "-}", pp_essential ]
-
-  | is_default_method_id
-  = let
-	Just (cls, clsop, _) = default_method_maybe
-    	(_, cls_str) = getOrigName cls
-	clsop_str    = getClassOpString clsop
-    in
-    ppCat [pp_mod,
-	   ppStr "{- instance",
-	   ppPStr cls_str,
-	   ppStr "EXPLICIT METHOD REQUIRED",
-	   pp_clsop clsop_str, ppStr "::",
-	   pprUniType sty spec_ty,
-	   ppStr "-}", pp_essential ]
-
-  | otherwise
-  = ppCat [pp_mod,
-	   ppStr "{-# SPECIALIZE",
-	   pprNonOp PprForUser id, ppStr "::",
-	   pprUniType sty spec_ty,
-	   ppStr "#-}", pp_essential ]
-  where
-    spec_ty = specialiseTy (getIdUniType id) tys 100   -- HACK to drop all dicts!!!
-    pp_essential = if is_err then ppStr "{- Essential -}" else ppNil
-
-    const_method_maybe = isConstMethodId_maybe id
-    is_const_method_id = maybeToBool const_method_maybe
-
-    default_method_maybe = isDefaultMethodId_maybe id
-    is_default_method_id = maybeToBool default_method_maybe
-
-    pp_clsop str | isAvarop str
-    	         = ppBesides [ppLparen, ppPStr str, ppRparen]
-    	         | otherwise
-		 = ppPStr str
-
-\end{code}
diff --git a/ghc/compiler/specialise/SpecUtils.lhs b/ghc/compiler/specialise/SpecUtils.lhs
new file mode 100644
index 0000000000..8a019922ab
--- /dev/null
+++ b/ghc/compiler/specialise/SpecUtils.lhs
@@ -0,0 +1,344 @@
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1993-1995
+%
+\section[Specialise]{Stamping out overloading, and (optionally) polymorphism}
+
+\begin{code}
+#include "HsVersions.h"
+
+module SpecUtils (
+	specialiseCallTys,
+	ConstraintVector(..),
+	getIdOverloading,
+	mkConstraintVector,
+	isUnboxedSpecialisation,
+
+	specialiseConstrTys,
+	mkSpecialisedCon,
+
+	argTysMatchSpecTys_error,
+
+	pprSpecErrs
+    ) where
+
+import Type
+import Bag		( Bag, isEmptyBag, bagToList )
+import FiniteMap	( FiniteMap, emptyFM, addListToFM_C,
+			  plusFM_C, keysFM, lookupWithDefaultFM
+			)
+import Id		( mkSameSpecCon, idType,
+			  isDictFunId, isConstMethodId_maybe,
+			  isDefaultMethodId_maybe,
+			  getInstIdModule, Id )
+import Maybes
+import Outputable
+import Pretty
+import Util
+\end{code}
+
+@specialiseCallTys@ works out which type args don't need to be specialised on,
+based on flags, the overloading constraint vector, and the types.
+
+\begin{code}
+specialiseCallTys :: Bool 		-- Specialise on all type args
+		  -> Bool 		-- Specialise on unboxed type args
+		  -> Bool		-- Specialise on overloaded type args
+		  -> ConstraintVector	-- Tells which type args are overloaded
+		  -> [Type]		-- Type args
+		  -> [Maybe Type]	-- Nothings replace non-specialised type args
+
+specialiseCallTys True _ _ cvec tys
+  = map Just tys
+specialiseCallTys False spec_unboxed spec_overloading cvec tys
+  = zipWithEqual spec_ty_other cvec tys
+  where
+    spec_ty_other c ty | (spec_unboxed && isUnboxedDataType ty)
+			 || (spec_overloading && c)
+			 = Just ty
+		       | otherwise
+			 = Nothing
+\end{code}
+
+@getIdOverloading@ grabs the type of an Id, and returns a
+list of its polymorphic variables, and the initial segment of
+its ThetaType, in which the classes constrain only type variables.
+For example, if the Id's type is
+
+	forall a,b,c. Eq a -> Ord [a] -> tau
+
+we'll return
+
+	([a,b,c], [(Eq,a)])
+
+This seems curious at first.  For a start, the type above looks odd,
+because we usually only have dictionary args whose types are of
+the form (C a) where a is a type variable.  But this doesn't hold for
+the functions arising from instance decls, which sometimes get
+arguements with types of form (C (T a)) for some type constructor T.
+
+Should we specialise wrt this compound-type dictionary?  This is
+a heuristic judgement, as indeed is the fact that we specialise wrt
+only dictionaries.  We choose *not* to specialise wrt compound dictionaries
+because at the moment the only place they show up is in instance decls,
+where they are simply plugged into a returned dictionary.  So nothing is
+gained by specialising wrt them.
+
+\begin{code}
+getIdOverloading :: Id
+		 -> ([TyVarTemplate], [(Class,TyVarTemplate)])
+getIdOverloading id
+  = (tyvars, tyvar_part_of theta)
+  where
+    (tyvars, theta, _) = splitSigmaTy (idType id)
+
+    tyvar_part_of [] 		      = []
+    tyvar_part_of ((clas,ty) : theta) = case getTyVarTemplateMaybe ty of
+					    Nothing    -> []
+					    Just tyvar -> (clas, tyvar) : tyvar_part_of theta
+\end{code}
+
+\begin{code}
+type ConstraintVector = [Bool]	-- True for constrained tyvar, false otherwise
+
+mkConstraintVector :: Id
+		   -> ConstraintVector
+
+mkConstraintVector id
+  = [tyvar `elem` constrained_tyvars | tyvar <- tyvars]
+  where
+    (tyvars, class_tyvar_pairs) = getIdOverloading id
+    constrained_tyvars   = map snd class_tyvar_pairs 	-- May contain dups
+\end{code}
+
+\begin{code}
+isUnboxedSpecialisation :: [Maybe Type] -> Bool
+isUnboxedSpecialisation tys
+  = any is_unboxed tys
+  where
+    is_unboxed (Just ty) = isUnboxedDataType ty
+    is_unboxed Nothing   = False
+\end{code}
+
+@specialiseConstrTys@ works out which type args don't need to be
+specialised on. We only speciailise on unboxed types.
+
+\begin{code}
+specialiseConstrTys :: [Type]
+		    -> [Maybe Type]
+
+specialiseConstrTys tys
+  = map maybe_unboxed_ty tys
+  where
+    maybe_unboxed_ty ty = case isUnboxedDataType ty of
+			    True  -> Just ty
+			    False -> Nothing
+\end{code}
+
+\begin{code}
+mkSpecialisedCon :: Id -> [Type] -> Id
+mkSpecialisedCon con tys
+  = if spec_reqd
+    then mkSameSpecCon spec_tys con
+    else con
+  where
+    spec_tys  = specialiseConstrTys tys
+    spec_reqd = maybeToBool (firstJust spec_tys)
+\end{code}
+
+@argTysMatchSpecTys@ checks if a list of argument types is consistent
+with a list of specialising types. An error message is returned if not.
+\begin{code}
+argTysMatchSpecTys_error :: [Maybe Type]
+			 -> [Type]
+			 -> Maybe Pretty
+argTysMatchSpecTys_error spec_tys arg_tys
+  = if match spec_tys arg_tys
+    then Nothing
+    else Just (ppSep [ppStr "Spec and Arg Types Inconsistent:",
+		      ppStr "spectys=", ppSep [pprMaybeTy PprDebug ty | ty <- spec_tys],
+		      ppStr "argtys=", ppSep [pprParendType PprDebug ty | ty <- arg_tys]])
+  where
+    match (Nothing:spec_tys) (arg:arg_tys)
+      = not (isUnboxedDataType arg) &&
+	match spec_tys arg_tys
+    match (Just spec:spec_tys) (arg:arg_tys)
+      = case (cmpUniType True{-properly-} spec arg) of
+	  EQ_   -> match spec_tys arg_tys
+	  other -> False
+    match [] [] = True
+    match _  _  = False
+\end{code}
+
+@pprSpecErrs@ prints error and warning information
+about imported specialisations which do not exist.
+
+\begin{code}
+pprSpecErrs :: FAST_STRING			-- module name
+	    -> (Bag (Id,[Maybe Type]))	-- errors
+	    -> (Bag (Id,[Maybe Type]))	-- warnings
+	    -> (Bag (TyCon,[Maybe Type]))	-- errors
+	    -> Pretty
+
+pprSpecErrs this_mod spec_errs spec_warn spec_tyerrs
+  | not any_errs && not any_warn
+  = ppNil
+
+  | otherwise
+  = ppAboves [
+	ppStr "SPECIALISATION MESSAGES:",
+	ppAboves (map pp_module_specs use_modules)
+	]
+  where
+    any_errs = not (isEmptyBag spec_errs && isEmptyBag spec_tyerrs)
+    any_warn = not (isEmptyBag spec_warn)
+
+    mk_module_fm get_mod_data errs_bag
+      = addListToFM_C (++) emptyFM errs_list
+      where
+	errs_list = map get_mod_data (bagToList errs_bag)
+
+    tyspecs_fm = mk_module_fm get_ty_data spec_tyerrs
+
+    iderrs_fm  = mk_module_fm (get_id_data True) spec_errs
+    idwarn_fm  = mk_module_fm (get_id_data False) spec_warn
+    idspecs_fm = plusFM_C (++) idwarn_fm iderrs_fm
+
+    get_id_data is_err (id, tys)
+      = (mod_name, [(id_name, id, tys, is_err)])
+      where
+	(mod_name, id_name) = get_id_name id
+
+    get_id_name id
+      | maybeToBool (isDefaultMethodId_maybe id)
+      = (this_mod, _NIL_)
+
+      | isDictFunId id || maybeToBool (isConstMethodId_maybe id)
+      = let get_mod = getInstIdModule id
+	    use_mod = if from_prelude get_mod
+		      then SLIT("Prelude")
+		      else get_mod
+	in (use_mod, _NIL_)
+
+      | otherwise
+      = getOrigName id
+
+    get_ty_data (ty, tys)
+      = (mod_name, [(ty_name, ty, tys)])
+      where
+	(mod_name,ty_name) = getOrigName ty
+
+    from_prelude mod
+      = SLIT("Prelude") == (_SUBSTR_ mod 0 6)
+
+    module_names    = concat [keysFM idspecs_fm, keysFM tyspecs_fm]
+    mods            = map head (equivClasses _CMP_STRING_ module_names)
+
+    (unks, known)   = if null mods
+		      then ([], [])
+		      else case _CMP_STRING_ (head mods) _NIL_ of
+			    EQ_   -> ([_NIL_], tail mods)
+			    other -> ([], mods)
+
+    (prels, others) = partition from_prelude known
+    use_modules     = unks ++ prels ++ others
+
+    pp_module_specs :: FAST_STRING -> Pretty
+    pp_module_specs mod
+      | mod == _NIL_
+      = ASSERT (null mod_tyspecs)
+	ppAboves (map (pp_idspec ty_sty (ppStr "UNKNOWN:")) mod_idspecs)
+
+      | have_specs
+      = ppAboves [
+	    ppAboves (map (pp_tyspec ty_sty (pp_module mod)) mod_tyspecs),
+	    ppAboves (map (pp_idspec ty_sty (pp_module mod)) mod_idspecs)
+	    ]
+
+      | otherwise
+      = ppNil
+
+      where
+	mod_tyspecs = lookupWithDefaultFM tyspecs_fm [] mod
+	mod_idspecs = lookupWithDefaultFM idspecs_fm [] mod
+	have_specs  = not (null mod_tyspecs && null mod_idspecs)
+	ty_sty = PprInterface (error "SpecUtils:PprInterface:sw_chkr")
+
+pp_module mod
+  = ppBesides [ppPStr mod, ppStr ":"]
+
+pp_tyspec :: PprStyle -> Pretty -> (FAST_STRING, TyCon, [Maybe Type]) -> Pretty
+
+pp_tyspec sty pp_mod (_, tycon, tys)
+  = ppCat [pp_mod,
+	   ppStr "{-# SPECIALIZE", ppStr "data",
+	   pprNonOp PprForUser tycon, ppCat (map (pprParendType sty) spec_tys),
+	   ppStr "#-}", ppStr "{- Essential -}"
+	   ]
+  where
+    tvs = getTyConTyVarTemplates tycon
+    (spec_args, tv_maybes) = unzip (map choose_ty (tvs `zip` tys))
+    spec_tys = map (mkForallTy (catMaybes tv_maybes)) spec_args
+
+    choose_ty (tv, Nothing) = (mkTyVarTemplateTy tv, Just tv)
+    choose_ty (tv, Just ty) = (ty, Nothing)
+
+pp_idspec :: PprStyle -> Pretty -> (FAST_STRING, Id, [Maybe Type], Bool) -> Pretty
+
+pp_idspec sty pp_mod (_, id, tys, is_err)
+  | isDictFunId id
+  = ppCat [pp_mod,
+	   ppStr "{-# SPECIALIZE",
+	   ppStr "instance",
+	   pprType sty spec_ty,
+	   ppStr "#-}", pp_essential ]
+
+  | is_const_method_id
+  = let
+	Just (cls, clsty, clsop) = const_method_maybe
+    	(_, cls_str) = getOrigName cls
+	clsop_str    = getClassOpString clsop
+    in
+    ppCat [pp_mod,
+	   ppStr "{-# SPECIALIZE",
+	   pp_clsop clsop_str, ppStr "::",
+	   pprType sty spec_ty,
+	   ppStr "#-} {- IN instance",
+	   ppPStr cls_str, pprParendType sty clsty,
+	   ppStr "-}", pp_essential ]
+
+  | is_default_method_id
+  = let
+	Just (cls, clsop, _) = default_method_maybe
+    	(_, cls_str) = getOrigName cls
+	clsop_str    = getClassOpString clsop
+    in
+    ppCat [pp_mod,
+	   ppStr "{- instance",
+	   ppPStr cls_str,
+	   ppStr "EXPLICIT METHOD REQUIRED",
+	   pp_clsop clsop_str, ppStr "::",
+	   pprType sty spec_ty,
+	   ppStr "-}", pp_essential ]
+
+  | otherwise
+  = ppCat [pp_mod,
+	   ppStr "{-# SPECIALIZE",
+	   pprNonOp PprForUser id, ppStr "::",
+	   pprType sty spec_ty,
+	   ppStr "#-}", pp_essential ]
+  where
+    spec_ty = specialiseTy (idType id) tys 100   -- HACK to drop all dicts!!!
+    pp_essential = if is_err then ppStr "{- Essential -}" else ppNil
+
+    const_method_maybe = isConstMethodId_maybe id
+    is_const_method_id = maybeToBool const_method_maybe
+
+    default_method_maybe = isDefaultMethodId_maybe id
+    is_default_method_id = maybeToBool default_method_maybe
+
+    pp_clsop str | isAvarop str
+    	         = ppBesides [ppLparen, ppPStr str, ppRparen]
+    	         | otherwise
+		 = ppPStr str
+
+\end{code}
diff --git a/ghc/compiler/specialise/Specialise.hi b/ghc/compiler/specialise/Specialise.hi
deleted file mode 100644
index 879bd3af86..0000000000
--- a/ghc/compiler/specialise/Specialise.hi
+++ /dev/null
@@ -1,17 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface Specialise where
-import Bag(Bag)
-import CmdLineOpts(GlobalSwitch)
-import CoreSyn(CoreBinding)
-import FiniteMap(FiniteMap)
-import Id(Id)
-import Maybes(Labda)
-import SplitUniq(SplitUniqSupply)
-import TyCon(TyCon)
-import UniType(UniType)
-data Bag a 
-data FiniteMap a b 
-data SpecialiseData   = SpecData Bool Bool [TyCon] [TyCon] (FiniteMap TyCon [(Bool, [Labda UniType])]) (Bag (Id, [Labda UniType])) (Bag (Id, [Labda UniType])) (Bag (TyCon, [Labda UniType]))
-initSpecData :: [TyCon] -> FiniteMap TyCon [(Bool, [Labda UniType])] -> SpecialiseData
-specProgram :: (GlobalSwitch -> Bool) -> SplitUniqSupply -> [CoreBinding Id Id] -> SpecialiseData -> ([CoreBinding Id Id], SpecialiseData)
-
diff --git a/ghc/compiler/specialise/Specialise.lhs b/ghc/compiler/specialise/Specialise.lhs
index 1cccff270b..e503a9c373 100644
--- a/ghc/compiler/specialise/Specialise.lhs
+++ b/ghc/compiler/specialise/Specialise.lhs
@@ -1,5 +1,5 @@
 %
-% (c) The GRASP/AQUA Project, Glasgow University, 1993-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1993-1996
 %
 \section[Specialise]{Stamping out overloading, and (optionally) polymorphism}
 
@@ -15,31 +15,23 @@ module Specialise (
 
     ) where
 
-import PlainCore
-import SpecTyFuns
+import SpecUtils
 
-IMPORT_Trace
-import Outputable	-- ToDo: these may be removable...
-import Pretty
-
-import AbsPrel		( liftDataCon, PrimOp(..), PrimKind -- for CCallOp
+import PrelInfo		( liftDataCon, PrimOp(..), PrimRep -- for CCallOp
 			  IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
 			  IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
 			)
-import AbsUniType
+import Type
 import Bag
 import CmdLineOpts	( GlobalSwitch(..) )
 import CoreLift		( mkLiftedId, liftExpr, bindUnlift, applyBindUnlifts )
 import FiniteMap
 import Id
-import IdEnv
 import IdInfo 		-- All of it
-import InstEnv		( lookupClassInstAtSimpleType )
 import Maybes		( catMaybes, firstJust, maybeToBool, Maybe(..) )
-import TyVarEnv		-- ( growTyVarEnvList, nullTyVarEnv, TyVarEnv, TypeEnv(..) )
 import UniqSet		-- All of it
 import Util
-import SplitUniq
+import UniqSupply
 
 infixr 9 `thenSM`
 \end{code}
@@ -78,7 +70,7 @@ Suppose we have
 	let f = <f_rhs>
 	in <body>
 
-and suppose f is overloaded.  
+and suppose f is overloaded.
 
 STEP 1: CALL-INSTANCE COLLECTION
 
@@ -93,11 +85,11 @@ then I think it's unlikely.  In any case, we simply don't accumulate such
 partial applications.)
 
 There's a choice of whether to collect details of all *polymorphic* functions
-or simply all *overloaded* ones.  How to sort this out? 
+or simply all *overloaded* ones.  How to sort this out?
   Pass in a predicate on the function to say if it is "interesting"?
   This is dependent on the user flags: SpecialiseOverloaded
 				       SpecialiseUnboxed
-			               SpecialiseAll
+				       SpecialiseAll
 
 STEP 2: EQUIVALENCES
 
@@ -134,7 +126,7 @@ it might arise from user SPECIALIZE pragmas.)
 
 Recursion
 ~~~~~~~~~
-Wait a minute!  What if f is recursive?  Then we can't just plug in 
+Wait a minute!  What if f is recursive?  Then we can't just plug in
 its right-hand side, can we?
 
 But it's ok.  The type checker *always* creates non-recursive definitions
@@ -144,10 +136,10 @@ for overloaded recursive functions.  For example:
 
 becomes
 
-	f a (d::Num a) = let p = +.sel a d 
+	f a (d::Num a) = let p = +.sel a d
 			 in
 			 letrec fl (y::a) = fl (p y y)
-			 in 
+			 in
 			 fl
 
 We still have recusion for non-overloadd functions which we
@@ -173,25 +165,25 @@ example is as follows.  Here's the Haskell:
 After typechecking we have
 
 	g a (d::Num a) (y::a) = let f b (d'::Num b) (x::b) = +.sel b d' x x
-			        in +.sel a d (f a d y) (f a d y)
+				in +.sel a d (f a d y) (f a d y)
 
 Notice that the call to f is at type type "a"; a non-constant type.
 Both calls to f are at the same type, so we can specialise to give:
 
 	g a (d::Num a) (y::a) = let f@a (x::a) = +.sel a d x x
-			        in +.sel a d (f@a y) (f@a y)
+				in +.sel a d (f@a y) (f@a y)
 
 
 (b) The other case is when the type variables in the instance types
 are *not* in scope at the definition point of f.  The example we are
 working with above is a good case.  There are two instances of (+.sel a d),
-but "a" is not in scope at the definition of +.sel.  Can we do anything?  
+but "a" is not in scope at the definition of +.sel.  Can we do anything?
 Yes, we can "common them up", a sort of limited common sub-expression deal.
 This would give:
 
 	g a (d::Num a) (y::a) = let +.sel@a = +.sel a d
 				    f@a (x::a) = +.sel@a x x
-			        in +.sel@a (f@a y) (f@a y)
+				in +.sel@a (f@a y) (f@a y)
 
 This can save work, and can't be spotted by the type checker, because
 the two instances of +.sel weren't originally at the same type.
@@ -210,7 +202,7 @@ that will duplicate code.  Just commoning up the call is the point.
 
 * Don't bother unless the equivalence class has more than one item!
 
-Not clear whether this is all worth it.  It is of course OK to 
+Not clear whether this is all worth it.  It is of course OK to
 simply discard call-instances when passing a big lambda.
 
 Polymorphism 2 -- Overloading
@@ -227,7 +219,7 @@ b types.
 
 That suggests that we should identify which of g's type variables
 are constrained (like "a") and which are unconstrained (like "b").
-Then when taking equivalence classes in STEP 2, we ignore the type args 
+Then when taking equivalence classes in STEP 2, we ignore the type args
 corresponding to unconstrained type variable.  In STEP 3 we make
 polymorphic versions.  Thus:
 
@@ -262,18 +254,18 @@ Before specialisation, leaving out type abstractions we have
 	f df x = let g :: Eq a => a -> a -> Bool
 		     g dg p q = == dg p q
 		     h :: Num a => a -> a -> (a, Bool)
-		     h dh r s = let deq = eqFromNum dh 
+		     h dh r s = let deq = eqFromNum dh
 				in (+ dh r s, g deq r s)
 	      in
 	      h df x x
 
 After specialising h we get a specialised version of h, like this:
 
-		    h' r s = let deq = eqFromNum df 
+		    h' r s = let deq = eqFromNum df
 			     in (+ df r s, g deq r s)
 
 But we can't naively make an instance for g from this, because deq is not in scope
-at the defn of g.  Instead, we have to float out the (new) defn of deq 
+at the defn of g.  Instead, we have to float out the (new) defn of deq
 to widen its scope.  Notice that this floating can't be done in advance -- it only
 shows up when specialisation is done.
 
@@ -292,7 +284,7 @@ by adding extra definitions along with that of f, in the same way as before
 Indeed the pragmas *have* to be dealt with by the type checker, because
 only it knows how to build the dictionaries d1 and d2!  For example
 
-	g :: Ord a => [a] -> [a] 
+	g :: Ord a => [a] -> [a]
 	{-# SPECIALIZE f :: [Tree Int] -> [Tree Int] #-}
 
 Here, the specialised version of g is an application of g's rhs to the
@@ -320,13 +312,13 @@ Again, the pragma should permit polymorphism in unconstrained variables:
 
 We *insist* that all overloaded type variables are specialised to ground types,
 (and hence there can be no context inside a SPECIALIZE pragma).
-We *permit* unconstrained type variables to be specialised to 
+We *permit* unconstrained type variables to be specialised to
 	- a ground type
 	- or left as a polymorphic type variable
 but nothing in between.  So
 
 	{-# SPECIALIZE h :: [Int] -> [c] -> [c] #-}
-	
+
 is *illegal*.  (It can be handled, but it adds complication, and gains the
 programmer nothing.)
 
@@ -357,7 +349,7 @@ In fact, matters are a little bit more complicated than this.
 When we make one of these specialised instances, we are defining
 a constant dictionary, and so we want immediate access to its constant
 methods and superclasses.  Indeed, these constant methods and superclasses
-must be in the IdInfo for the class selectors!  We need help from the 
+must be in the IdInfo for the class selectors!  We need help from the
 typechecker to sort this out, perhaps by generating a separate IdInfo
 for each.
 
@@ -375,10 +367,10 @@ so we'll want to compile enough to get those specialisations done.
 
 Lastly, there's no such thing as a local instance decl, so we can
 survive solely by spitting out *usage* information, and then reading that
-back in as a pragma when next compiling the file.  So for now, 
+back in as a pragma when next compiling the file.  So for now,
 we only specialise instance decls in response to pragmas.
 
-That means that even if an instance decl ain't otherwise exported it 
+That means that even if an instance decl ain't otherwise exported it
 needs to be spat out as with a SPECIALIZE pragma.  Furthermore, it needs
 something to say which module defined the instance, so the usage info
 can be fed into the right reqts info file.  Blegh.
@@ -394,7 +386,7 @@ type arguments.
 In addition to normal call instances we gather TyCon call instances at
 unboxed types, determine equivalence classes for the locally defined
 TyCons and build speciailised data constructor Ids for each TyCon and
-substitute these in the CoCon calls.
+substitute these in the Con calls.
 
 We need the list of local TyCons to partition the TyCon instance info.
 We pass out a FiniteMap from local TyCons to Specialised Instances to
@@ -483,11 +475,11 @@ What does the specialisation IdInfo look like?
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 
 	SpecInfo
-		[Maybe UniType] -- Instance types
+		[Maybe Type] -- Instance types
 		Int		-- No of dicts to eat
 		Id		-- Specialised version
 
-For example, if f has this SpecInfo: 
+For example, if f has this SpecInfo:
 
 	SpecInfo [Just t1, Nothing, Just t3] 2 f'
 
@@ -505,11 +497,11 @@ Eq a from a dictionary for Eq [a].  So if we find
 
 	==.sel [t] d
 
-we can't transform to 
+we can't transform to
 
 	eqList (==.sel t d')
 
-where 
+where
 	eqList :: (a->a->Bool) -> [a] -> [a] -> Bool
 
 Of course, we currently have no way to automatically derive
@@ -525,7 +517,7 @@ Mutter mutter
 ~~~~~~~~~~~~~
 What about types/classes mentioned in SPECIALIZE pragmas spat out,
 but not otherwise exported.  Even if they are exported, what about
-their original names.  
+their original names.
 
 Suggestion: use qualified names in pragmas, omitting module for
 prelude and "this module".
@@ -552,13 +544,13 @@ What should we do when a value is specialised to a *strict* unboxed value?
 
 	map_*_* f (x:xs) = let h = f x
 			       t = map f xs
-		           in h:t
+			   in h:t
 
 Could convert let to case:
 
 	map_*_Int# f (x:xs) = case f x of h# ->
-		              let t = map f xs
-		              in h#:t
+			      let t = map f xs
+			      in h#:t
 
 This may be undesirable since it forces evaluation here, but the value
 may not be used in all branches of the body. In the general case this
@@ -572,8 +564,8 @@ Solution: Lift the binding of the unboxed value and extract it when it
 is used:
 
 	map_*_Int# f (x:xs) = let h = case (f x) of h# -> _Lift h#
-		                  t = map f xs
-		              in case h of
+				  t = map f xs
+			      in case h of
 				 _Lift h# -> h#:t
 
 Now give it to the simplifier and the _Lifting will be optimised away.
@@ -590,14 +582,14 @@ value is bound. For example:
 	filtermap_*_* p f (x:xs)
 	  = let h = f x
 		t = ...
-            in case p x of
+	    in case p x of
 		True  -> h:t
 		False -> t
    ==>
 	filtermap_*_Int# p f (x:xs)
 	  = let h = case (f x) of h# -> _Lift h#
 		t = ...
-            in case p x of
+	    in case p x of
 		True  -> case h of _Lift h#
 			   -> h#:t
 		False -> t
@@ -625,13 +617,13 @@ strictness analyser deems the lifted binding strict.
 type FreeVarsSet   = UniqSet Id
 type FreeTyVarsSet = UniqSet TyVar
 
-data CallInstance 
-  = CallInstance 
+data CallInstance
+  = CallInstance
 		Id 			-- This Id; *new* ie *cloned* id
-		[Maybe UniType]		-- Specialised at these types (*new*, cloned)
+		[Maybe Type]		-- Specialised at these types (*new*, cloned)
 					-- Nothing => no specialisation on this type arg
 					--	      is required (flag dependent).
-		[PlainCoreArg]		-- And these dictionaries; all ValArgs
+		[CoreArg]		-- And these dictionaries; all ValArgs
 		FreeVarsSet		-- Free vars of the dict-args in terms of *new* ids
 		(Maybe SpecInfo)	-- For specialisation with explicit SpecId
 \end{code}
@@ -643,7 +635,7 @@ pprCI (CallInstance id spec_tys dicts _ maybe_specinfo)
 	 4 (ppAboves [ppCat (ppStr "types" : [pprMaybeTy PprDebug ty | ty <- spec_tys]),
 		      case maybe_specinfo of
 			Nothing -> ppCat (ppStr "dicts" : [ppr PprDebug dict | dict <- dicts])
-		        Just (SpecInfo _ _ spec_id)
+			Just (SpecInfo _ _ spec_id)
 				-> ppCat [ppStr "Explicit SpecId", ppr PprDebug spec_id]
 		     ])
 
@@ -663,8 +655,8 @@ Comparisons are based on the {\em types}, ignoring the dictionary args:
 \begin{code}
 
 cmpCI :: CallInstance -> CallInstance -> TAG_
-cmpCI (CallInstance id1 tys1 _ _ _) (CallInstance id2 tys2 _ _ _) 
-  = case cmpId id1 id2 of { EQ_ -> cmpUniTypeMaybeList tys1 tys2; other -> other }
+cmpCI (CallInstance id1 tys1 _ _ _) (CallInstance id2 tys2 _ _ _)
+  = case (id1 `cmp` id2) of { EQ_ -> cmpUniTypeMaybeList tys1 tys2; other -> other }
 
 cmpCI_tys :: CallInstance -> CallInstance -> TAG_
 cmpCI_tys (CallInstance _ tys1 _ _ _) (CallInstance _ tys2 _ _ _)
@@ -678,14 +670,14 @@ isCIofTheseIds :: [Id] -> CallInstance -> Bool
 isCIofTheseIds ids (CallInstance ci_id _ _ _ _)
   = any (eqId ci_id) ids
 
-singleCI :: Id -> [Maybe UniType] -> [PlainCoreArg] -> UsageDetails
+singleCI :: Id -> [Maybe Type] -> [CoreArg] -> UsageDetails
 singleCI id tys dicts
   = UsageDetails (unitBag (CallInstance id tys dicts fv_set Nothing))
 		 emptyBag [] emptyUniqSet 0 0
   where
-    fv_set = mkUniqSet (id : [dict | ValArg (CoVarAtom dict) <- dicts])
+    fv_set = mkUniqSet (id : [dict | ValArg (VarArg dict) <- dicts])
 
-explicitCI :: Id -> [Maybe UniType] -> SpecInfo -> UsageDetails
+explicitCI :: Id -> [Maybe Type] -> SpecInfo -> UsageDetails
 explicitCI id tys specinfo
   = UsageDetails (unitBag call_inst) emptyBag [] emptyUniqSet 0 0
   where
@@ -702,7 +694,7 @@ getCIids True ids = filter not_dict_or_defm ids
 getCIids _    ids = ids
 
 not_dict_or_defm id
-  = not (isDictTy (getIdUniType id) || maybeToBool (isDefaultMethodId_maybe id))
+  = not (isDictTy (idType id) || maybeToBool (isDefaultMethodId_maybe id))
 
 getCIs :: Bool -> [Id] -> UsageDetails -> ([CallInstance], UsageDetails)
 getCIs top_lev ids (UsageDetails cis tycon_cis dbs fvs c i)
@@ -718,18 +710,18 @@ getCIs top_lev ids (UsageDetails cis tycon_cis dbs fvs c i)
 dumpCIs :: Bag CallInstance	-- The call instances
 	-> Bool			-- True <=> top level bound Ids
 	-> Bool			-- True <=> dict bindings to be floated (specBind only)
-        -> [CallInstance]	-- Call insts for bound ids (instBind only)
+	-> [CallInstance]	-- Call insts for bound ids (instBind only)
 	-> [Id]			-- Bound ids *new*
 	-> [Id]			-- Full bound ids: includes dumped dicts
 	-> Bag CallInstance	-- Kept call instances
 
-   	-- CIs are dumped if: 
+   	-- CIs are dumped if:
 	--   1) they are a CI for one of the bound ids, or
 	--   2) they mention any of the dicts in a local unfloated binding
 	--
 	-- For top-level bindings we allow the call instances to
 	-- float past a dict bind and place all the top-level binds
-	-- in a *global* CoRec.
+	-- in a *global* Rec.
 	-- We leave it to the simplifier will sort it all out ...
 
 dumpCIs cis top_lev floating inst_cis bound_ids full_ids
@@ -737,9 +729,9 @@ dumpCIs cis top_lev floating inst_cis bound_ids full_ids
        not (isEmptyBag cis_of_bound_id_without_inst_cis)
     then
        pprTrace ("dumpCIs: dumping CI which was not instantiated ... \n" ++
-	         "         (may be a non-HM recursive call)\n")
+		 "         (may be a non-HM recursive call)\n")
        (ppHang (ppBesides [ppStr "{", ppr PprDebug bound_ids, ppStr "}"])
-             4 (ppAboves [ppStr "Dumping CIs:",
+	     4 (ppAboves [ppStr "Dumping CIs:",
 			  ppAboves (map pprCI (bagToList cis_of_bound_id)),
 			  ppStr "Instantiating CIs:",
 			  ppAboves (map pprCI inst_cis)]))
@@ -749,7 +741,7 @@ dumpCIs cis top_lev floating inst_cis bound_ids full_ids
    else
        (if not (isEmptyBag cis_dump_unboxed)
 	then pprTrace "dumpCIs: bound dictionary arg ... WITH UNBOXED TYPES!\n"
-             (ppHang (ppBesides [ppStr "{", ppr PprDebug full_ids, ppStr "}"])
+	     (ppHang (ppBesides [ppStr "{", ppr PprDebug full_ids, ppStr "}"])
 		   4 (ppAboves (map pprCI (bagToList cis_dump))))
 	else id)
        cis_keep_not_bound_id
@@ -761,7 +753,7 @@ dumpCIs cis top_lev floating inst_cis bound_ids full_ids
    (cis_dump, cis_keep_not_bound_id)
       = partitionBag ok_to_dump_ci cis_not_bound_id
 
-   ok_to_dump_ci (CallInstance _ _ _ fv_set _) 
+   ok_to_dump_ci (CallInstance _ _ _ fv_set _)
 	= or [i `elementOfUniqSet` fv_set | i <- full_ids]
 
    (_, cis_of_bound_id_without_inst_cis) = partitionBag have_inst_ci cis_of_bound_id
@@ -779,7 +771,7 @@ recursive calls should be at the same instance as the parent instance.
 Here, the type, t, at which f is used in its own RHS should be
 just "a"; that is, the recursive call is at the same type as
 the original call. That means that when specialising f at some
-type, say Int#, we shouldn't find any *new* instances of f 
+type, say Int#, we shouldn't find any *new* instances of f
 arising from specialising f's RHS.  The only instance we'll find
 is another call of (f Int#).
 
@@ -799,18 +791,18 @@ contain unboxed types.
 \begin{code}
 data TyConInstance
   = TyConInstance TyCon			-- Type Constructor
-		  [Maybe UniType]	-- Applied to these specialising types
+		  [Maybe Type]	-- Applied to these specialising types
 
 cmpTyConI :: TyConInstance -> TyConInstance -> TAG_
-cmpTyConI (TyConInstance tc1 tys1) (TyConInstance tc2 tys2) 
-  = case cmpTyCon tc1 tc2 of { EQ_ -> cmpUniTypeMaybeList tys1 tys2; other -> other }
+cmpTyConI (TyConInstance tc1 tys1) (TyConInstance tc2 tys2)
+  = case (cmp tc1 tc2) of { EQ_ -> cmpUniTypeMaybeList tys1 tys2; other -> other }
 
 cmpTyConI_tys :: TyConInstance -> TyConInstance -> TAG_
-cmpTyConI_tys (TyConInstance _ tys1) (TyConInstance _ tys2) 
+cmpTyConI_tys (TyConInstance _ tys1) (TyConInstance _ tys2)
   = cmpUniTypeMaybeList tys1 tys2
 
-singleTyConI :: TyCon -> [Maybe UniType] -> UsageDetails
-singleTyConI ty_con spec_tys 
+singleTyConI :: TyCon -> [Maybe Type] -> UsageDetails
+singleTyConI ty_con spec_tys
   = UsageDetails emptyBag (unitBag (TyConInstance ty_con spec_tys)) [] emptyUniqSet 0 0
 
 isTyConIofThisTyCon :: TyCon -> TyConInstance -> Bool
@@ -838,7 +830,7 @@ getLocalSpecTyConIs comp_prel (UsageDetails cis tycon_cis dbs fvs c i)
 
 \begin{code}
 data UsageDetails
-  = UsageDetails 
+  = UsageDetails
 	(Bag CallInstance) 	-- The collection of call-instances
 	(Bag TyConInstance) 	-- Constructor call-instances
 	[DictBindDetails]	-- Dictionary bindings in data-dependence order!
@@ -855,10 +847,10 @@ will *include* the binders of the DictBind details.
 A @DictBindDetails@ contains bindings for dictionaries *only*.
 
 \begin{code}
-data DictBindDetails 
-  = DictBindDetails 
+data DictBindDetails
+  = DictBindDetails
 	[Id]			-- Main binders, originally visible in scope of binding (cloned)
-	PlainCoreBinding	-- Fully processed
+	CoreBinding	-- Fully processed
 	FreeVarsSet		-- Free in binding group (cloned)
 	FreeTyVarsSet		-- Free in binding group
 \end{code}
@@ -879,27 +871,27 @@ tickSpecInsts (UsageDetails cis ty_cis dbs fvs c i)
 
 emptyUDs = UsageDetails emptyBag emptyBag [] emptyUniqSet 0 0
 
-unionUDs (UsageDetails cis1 tycon_cis1 dbs1 fvs1 c1 i1) (UsageDetails cis2 tycon_cis2 dbs2 fvs2 c2 i2) 
+unionUDs (UsageDetails cis1 tycon_cis1 dbs1 fvs1 c1 i1) (UsageDetails cis2 tycon_cis2 dbs2 fvs2 c2 i2)
  = UsageDetails (unionBags cis1 cis2) (unionBags tycon_cis1 tycon_cis2)
-	        (dbs1 ++ dbs2) (fvs1 `unionUniqSets` fvs2) (c1+c2) (i1+i2)
+		(dbs1 ++ dbs2) (fvs1 `unionUniqSets` fvs2) (c1+c2) (i1+i2)
 	-- The append here is really redundant, since the bindings don't
 	-- scope over each other.  ToDo.
 
 unionUDList = foldr unionUDs emptyUDs
 
-singleFvUDs (CoVarAtom v) | not (isImportedId v)
+singleFvUDs (VarArg v) | not (isImportedId v)
  = UsageDetails emptyBag emptyBag [] (singletonUniqSet v) 0 0
 singleFvUDs other
  = emptyUDs
 
 singleConUDs con = UsageDetails emptyBag emptyBag [] (singletonUniqSet con) 0 0
 
-dumpDBs :: [DictBindDetails] 
+dumpDBs :: [DictBindDetails]
 	-> Bool			-- True <=> top level bound Ids
 	-> [TyVar]		-- TyVars being bound (cloned)
 	-> [Id]			-- Ids being bound (cloned)
 	-> FreeVarsSet		-- Fvs of body
-	-> ([PlainCoreBinding],	-- These ones have to go here
+	-> ([CoreBinding],	-- These ones have to go here
 	    [DictBindDetails],	-- These can float further
 	    [Id],		-- Incoming list + names of dicts bound here
 	    FreeVarsSet		-- Incoming fvs + fvs of dicts bound here
@@ -910,13 +902,13 @@ dumpDBs :: [DictBindDetails]
 	-- auxillary derived instance defns and user instance
 	-- defns all getting in the way.
 	-- So we dump all dbinds as soon as we get to the top
-	-- level and place them in a *global* CoRec.
+	-- level and place them in a *global* Rec.
 	-- We leave it to the simplifier will sort it all out ...
 
 dumpDBs [] top_lev bound_tyvars bound_ids fvs
   = ([], [], bound_ids, fvs)
 
-dumpDBs ((db@(DictBindDetails dbinders dbind db_fvs db_ftv)):dbs) 
+dumpDBs ((db@(DictBindDetails dbinders dbind db_fvs db_ftv)):dbs)
 	top_lev bound_tyvars bound_ids fvs
   | top_lev
     || or [i `elementOfUniqSet` db_fvs  | i <- bound_ids]
@@ -935,14 +927,14 @@ dumpDBs ((db@(DictBindDetails dbinders dbind db_fvs db_ftv)):dbs)
     (dbinds_here, db : dbs_outer, full_bound_ids, full_fvs)
 
 
-     
+
 dumpUDs :: UsageDetails
 	-> Bool			-- True <=> top level bound Ids
 	-> Bool			-- True <=> dict bindings to be floated (specBind only)
 	-> [CallInstance]	-- Call insts for bound Ids (instBind only)
 	-> [Id]			-- Ids which are just being bound; *new*
 	-> [TyVar]		-- TyVars which are just being bound
-	-> ([PlainCoreBinding],	-- Bindings from UsageDetails which mention the ids
+	-> ([CoreBinding],	-- Bindings from UsageDetails which mention the ids
 	    UsageDetails)	-- The above bindings removed, and
 				-- any call-instances which mention the ids dumped too
 
@@ -957,23 +949,23 @@ dumpUDs (UsageDetails cis tycon_cis dbs fvs c i) top_lev floating inst_cis bound
 \end{code}
 
 \begin{code}
-addDictBinds :: [Id] -> PlainCoreBinding -> UsageDetails	-- Dict binding and RHS usage
+addDictBinds :: [Id] -> CoreBinding -> UsageDetails	-- Dict binding and RHS usage
 	     -> UsageDetails	 				-- The usage to augment
 	     -> UsageDetails
 addDictBinds dbinders dbind (UsageDetails db_cis db_tycon_cis db_dbs db_fvs db_c db_i)
 	 	            (UsageDetails cis    tycon_cis    dbs    fvs    c    i)
   = UsageDetails (db_cis `unionBags` cis)
 		 (db_tycon_cis `unionBags` tycon_cis)
-		 (db_dbs ++ [DictBindDetails dbinders dbind db_fvs db_ftvs] ++ dbs) 
+		 (db_dbs ++ [DictBindDetails dbinders dbind db_fvs db_ftvs] ++ dbs)
 		 fvs c i
 		 -- NB: We ignore counts from dictbinds since it is not user code
   where
 	-- The free tyvars of the dictionary bindings should really be
 	-- gotten from the RHSs, but I'm pretty sure it's good enough just
-	-- to look at the type of the dictionary itself.  
+	-- to look at the type of the dictionary itself.
 	-- Doing the proper job would entail keeping track of free tyvars as
 	-- well as free vars, which would be a bore.
-    db_ftvs = mkUniqSet (extractTyVarsFromTys (map getIdUniType dbinders))
+    db_ftvs = mkUniqSet (extractTyVarsFromTys (map idType dbinders))
 \end{code}
 
 %************************************************************************
@@ -984,9 +976,9 @@ addDictBinds dbinders dbind (UsageDetails db_cis db_tycon_cis db_dbs db_fvs db_c
 
 @SpecIdEnv@ maps old Ids to their new "clone". There are three cases:
 
-1) (NoLift CoLitAtom l) : an Id which is bound to a literal
+1) (NoLift LitArg l) : an Id which is bound to a literal
 
-2) (NoLift CoLitAtom l) : an Id bound to a "new" Id	      
+2) (NoLift LitArg l) : an Id bound to a "new" Id
    The new Id is a possibly-type-specialised clone of the original
 
 3) Lifted lifted_id unlifted_id :
@@ -1007,7 +999,7 @@ addDictBinds dbinders dbind (UsageDetails db_cis db_tycon_cis db_dbs db_fvs db_c
 type SpecIdEnv = IdEnv CloneInfo
 
 data CloneInfo
- = NoLift PlainCoreAtom	-- refers to cloned id or literal
+ = NoLift CoreArg	-- refers to cloned id or literal
 
  | Lifted Id		-- lifted, cloned id
 	  Id		-- unlifted, cloned id
@@ -1033,11 +1025,11 @@ data SpecialiseData
 	    [TyCon]
 		-- Those in-scope data types for which we want to
 		-- generate code for their constructors.
-		-- Namely: data types declared in this module + 
+		-- Namely: data types declared in this module +
 		-- 	   any big tuples used in this module
 		-- The initial (and default) value is the local tycons
 
-	    (FiniteMap TyCon [(Bool, [Maybe UniType])])
+	    (FiniteMap TyCon [(Bool, [Maybe Type])])
 		-- TyCon specialisations to be generated
 		-- We generate specialialised code (Bool=True) for data types
 		-- defined in this module and any tuples used in this module
@@ -1045,11 +1037,11 @@ data SpecialiseData
 		-- requested by source-level SPECIALIZE data pragmas (Bool=True)
 		-- and _SPECIALISE_ pragmas (Bool=False) in the interface files
 
-	    (Bag (Id,[Maybe UniType]))
+	    (Bag (Id,[Maybe Type]))
 		-- Imported specialisation errors
-	    (Bag (Id,[Maybe UniType]))
+	    (Bag (Id,[Maybe Type]))
 		-- Imported specialisation warnings
-	    (Bag (TyCon,[Maybe UniType]))
+	    (Bag (TyCon,[Maybe Type]))
 		-- Imported TyCon specialisation errors
 
 initSpecData local_tycons tycon_specs
@@ -1066,16 +1058,16 @@ ToDo[sansom]: Transformation data to process specialisation requests.
 
 \begin{code}
 specProgram :: (GlobalSwitch -> Bool)
-	    -> SplitUniqSupply
-	    -> [PlainCoreBinding]	-- input ...
+	    -> UniqSupply
+	    -> [CoreBinding]	-- input ...
 	    -> SpecialiseData
-	    -> ([PlainCoreBinding],	-- main result
+	    -> ([CoreBinding],	-- main result
 		SpecialiseData)		-- result specialise data
 
 specProgram sw_chker uniqs binds
 	   (SpecData False _ local_tycons _ init_specs init_errs init_warn init_tyerrs)
   = case (initSM (specTyConsAndScope (specTopBinds binds)) sw_chker uniqs) of
-      (final_binds, tycon_specs_list, 
+      (final_binds, tycon_specs_list,
 	UsageDetails import_cis import_tycis _ fvs spec_calls spec_insts)
 	 -> let
 		used_conids   = filter isDataCon (uniqSetToList fvs)
@@ -1084,10 +1076,10 @@ specProgram sw_chker uniqs binds
 		gen_tycons    = setToList (mkSet local_tycons `union` mkSet used_gen)
 
 		result_specs  = addListToFM_C (++) init_specs tycon_specs_list
- 
+
 		uniq_cis      = map head (equivClasses cmpCI (bagToList import_cis))
 		cis_list      = [(id, tys) | CallInstance id tys _ _ _ <- uniq_cis]
-	        (cis_unboxed, cis_other) = partition (isUnboxedSpecialisation . snd) cis_list
+		(cis_unboxed, cis_other) = partition (isUnboxedSpecialisation . snd) cis_list
 		cis_warn      = init_warn `unionBags` listToBag cis_other
 		cis_errs      = init_errs `unionBags` listToBag cis_unboxed
 
@@ -1101,18 +1093,18 @@ specProgram sw_chker uniqs binds
 	    (if sw_chker D_simplifier_stats then
 		pprTrace "\nSpecialiser Stats:\n" (ppAboves [
 					ppBesides [ppStr "SpecCalls  ", ppInt spec_calls],
-				        ppBesides [ppStr "SpecInsts  ", ppInt spec_insts],
+					ppBesides [ppStr "SpecInsts  ", ppInt spec_insts],
 					ppSP])
 	     else id)
 
 	    (final_binds,
 	     SpecData True no_errs local_tycons gen_tycons result_specs
-			           cis_errs cis_warn tycis_errs)
+				   cis_errs cis_warn tycis_errs)
 
 specProgram sw_chker uniqs binds (SpecData True _ _ _ _ _ _ _)
   = panic "Specialise:specProgram: specialiser called more than once"
 
--- It may be possible safely to call the specialiser more than once, 
+-- It may be possible safely to call the specialiser more than once,
 -- but I am not sure there is any benefit in doing so (Patrick)
 
 -- ToDo: What about unfoldings performed after specialisation ???
@@ -1131,22 +1123,22 @@ Core. These are only introduced when we convert to StgSyn.
 ToDo: Perhaps this collection should be done in CoreToStg to ensure no inconsistencies!
 
 \begin{code}
-specTyConsAndScope :: SpecM ([PlainCoreBinding], UsageDetails)
-           	   -> SpecM ([PlainCoreBinding], [(TyCon,[(Bool,[Maybe UniType])])], UsageDetails)
+specTyConsAndScope :: SpecM ([CoreBinding], UsageDetails)
+	   	   -> SpecM ([CoreBinding], [(TyCon,[(Bool,[Maybe Type])])], UsageDetails)
 
 specTyConsAndScope scopeM
   = scopeM			`thenSM` \ (binds, scope_uds) ->
     getSwitchCheckerSM		`thenSM` \ sw_chkr ->
     let
        (tycons_cis, gotci_scope_uds)
-         = getLocalSpecTyConIs (sw_chkr CompilingPrelude) scope_uds
+	 = getLocalSpecTyConIs (sw_chkr CompilingPrelude) scope_uds
 
        tycon_specs_list = collectTyConSpecs tycons_cis
     in
     (if sw_chkr SpecialiseTrace && not (null tycon_specs_list) then
 	 pprTrace "Specialising TyCons:\n"
 	 (ppAboves [ if not (null specs) then
-		         ppHang (ppCat [(ppr PprDebug tycon), ppStr "at types"])
+			 ppHang (ppCat [(ppr PprDebug tycon), ppStr "at types"])
 			      4 (ppAboves (map pp_specs specs))
 		     else ppNil
 		   | (tycon, specs) <- tycon_specs_list])
@@ -1159,14 +1151,14 @@ specTyConsAndScope scopeM
     collectTyConSpecs tycons_cis@(TyConInstance tycon _ : _)
       = (tycon, tycon_specs) : collectTyConSpecs other_tycons_cis
       where
-        (tycon_cis, other_tycons_cis) = partition (isTyConIofThisTyCon tycon) tycons_cis
-        uniq_cis = map head (equivClasses cmpTyConI_tys tycon_cis)
+	(tycon_cis, other_tycons_cis) = partition (isTyConIofThisTyCon tycon) tycons_cis
+	uniq_cis = map head (equivClasses cmpTyConI_tys tycon_cis)
 	tycon_specs = [(False, spec_tys) | TyConInstance _ spec_tys <- uniq_cis]
 
     pp_specs (False, spec_tys) = ppInterleave ppNil [pprMaybeTy PprDebug spec_ty | spec_ty <- spec_tys]
 
 \end{code}
-    
+
 %************************************************************************
 %*									*
 \subsection[specTopBinds]{Specialising top-level bindings}
@@ -1174,8 +1166,8 @@ specTyConsAndScope scopeM
 %************************************************************************
 
 \begin{code}
-specTopBinds :: [PlainCoreBinding] 
-	     -> SpecM ([PlainCoreBinding], UsageDetails)
+specTopBinds :: [CoreBinding]
+	     -> SpecM ([CoreBinding], UsageDetails)
 
 specTopBinds binds
   = spec_top_binds binds    `thenSM`  \ (binds, UsageDetails cis tycis dbind_details fvs c i) ->
@@ -1192,19 +1184,19 @@ specTopBinds binds
 	fvs_outer = full_fvs `minusUniqSet` (mkUniqSet (concat dbinders_s))
 
  	-- It is just to complex to try to sort out top-level dependencies
-	-- So we just place all the top-level binds in a *global* CoRec and
+	-- So we just place all the top-level binds in a *global* Rec and
 	-- leave it to the simplifier to sort it all out ...
     in
     ASSERT(null dbinds)
-    returnSM ([CoRec (pairsFromCoreBinds binds)], UsageDetails cis tycis [] fvs_outer c i)
+    returnSM ([Rec (pairsFromCoreBinds binds)], UsageDetails cis tycis [] fvs_outer c i)
 
   where
     spec_top_binds (first_bind:rest_binds)
       = specBindAndScope True first_bind (
 	    spec_top_binds rest_binds `thenSM` \ (rest_binds, rest_uds) ->
 	    returnSM (ItsABinds rest_binds, rest_uds)
-        ) 			`thenSM` \ (first_binds, ItsABinds rest_binds, all_uds) ->
-        returnSM (first_binds ++ rest_binds, all_uds)
+	) 			`thenSM` \ (first_binds, ItsABinds rest_binds, all_uds) ->
+	returnSM (first_binds ++ rest_binds, all_uds)
 
     spec_top_binds []
       = returnSM ([], emptyUDs)
@@ -1217,25 +1209,25 @@ specTopBinds binds
 %************************************************************************
 
 \begin{code}
-specExpr :: PlainCoreExpr 
-	 -> [PlainCoreArg]		-- The arguments: 
+specExpr :: CoreExpr
+	 -> [CoreArg]		-- The arguments:
 					--    TypeArgs are speced
 					--    ValArgs are unprocessed
-	 -> SpecM (PlainCoreExpr, 	-- Result expression with specialised versions installed
+	 -> SpecM (CoreExpr, 	-- Result expression with specialised versions installed
 		   UsageDetails)	-- Details of usage of enclosing binders in the result
 					-- expression.
 
-specExpr (CoVar v) args
-  = lookupId v			`thenSM` \ vlookup -> 
+specExpr (Var v) args
+  = lookupId v			`thenSM` \ vlookup ->
     case vlookup of
        Lifted vl vu
 	     -> -- Binding has been lifted, need to extract un-lifted value
 		-- NB: a function binding will never be lifted => args always null
 		--     i.e. no call instance required or call to be constructed
 		ASSERT (null args)
-		returnSM (bindUnlift vl vu (CoVar vu), singleFvUDs (CoVarAtom vl))
+		returnSM (bindUnlift vl vu (Var vu), singleFvUDs (VarArg vl))
 
-       NoLift vatom@(CoVarAtom new_v)
+       NoLift vatom@(VarArg new_v)
 	     -> mapSM specArg args			`thenSM` \ arg_info ->
 		mkCallInstance v new_v arg_info		`thenSM` \ call_uds ->
     		mkCall new_v arg_info			`thenSM` \ ~(speced, call) ->
@@ -1247,41 +1239,41 @@ specExpr (CoVar v) args
 		in
     		returnSM (call, tickSpecCall speced uds)
 
-specExpr expr@(CoLit _) null_args
+specExpr expr@(Lit _) null_args
   = ASSERT (null null_args)
     returnSM (expr, emptyUDs)
 
-specExpr (CoCon con tys args) null_args
+specExpr (Con con tys args) null_args
   = ASSERT (null null_args)
     mapSM specTy tys 			`thenSM` \ tys ->
     mapAndUnzip3SM specAtom args	`thenSM` \ (args, args_uds_s, unlifts) ->
     mkTyConInstance con tys		`thenSM` \ con_uds ->
-    returnSM (applyBindUnlifts unlifts (CoCon con tys args),
+    returnSM (applyBindUnlifts unlifts (Con con tys args),
 	      unionUDList args_uds_s `unionUDs` con_uds)
 
-specExpr (CoPrim op@(CCallOp str is_asm may_gc arg_tys res_ty) tys args) null_args
+specExpr (Prim op@(CCallOp str is_asm may_gc arg_tys res_ty) tys args) null_args
   = ASSERT (null null_args)
     ASSERT (null tys)
     mapSM specTy arg_tys		`thenSM` \ arg_tys ->
     specTy res_ty			`thenSM` \ res_ty ->
     mapAndUnzip3SM specAtom args	`thenSM` \ (args, args_uds_s, unlifts) ->
-    returnSM (applyBindUnlifts unlifts (CoPrim (CCallOp str is_asm may_gc arg_tys res_ty) tys args), 
+    returnSM (applyBindUnlifts unlifts (Prim (CCallOp str is_asm may_gc arg_tys res_ty) tys args),
 	      unionUDList args_uds_s)
 
-specExpr (CoPrim prim tys args) null_args
+specExpr (Prim prim tys args) null_args
   = ASSERT (null null_args)
     mapSM specTy tys	 		`thenSM` \ tys ->
     mapAndUnzip3SM specAtom args	`thenSM` \ (args, args_uds_s, unlifts) ->
     -- specPrimOp prim tys		`thenSM` \ (prim, tys, prim_uds) ->
-    returnSM (applyBindUnlifts unlifts (CoPrim prim tys args),
+    returnSM (applyBindUnlifts unlifts (Prim prim tys args),
 	      unionUDList args_uds_s {-`unionUDs` prim_uds-} )
 
 {- ToDo: specPrimOp
 
 specPrimOp :: PrimOp
-	   -> [UniType]
+	   -> [Type]
 	   -> SpecM (PrimOp,
-		     [UniType],
+		     [Type],
 	 	     UsageDetails)
 
 -- Checks that PrimOp can handle (possibly unboxed) tys passed
@@ -1289,11 +1281,11 @@ specPrimOp :: PrimOp
 -- Errors are dealt with by returning a PrimOp call instance
 --   which will result in a cis_errs message
 
--- ToDo: Deal with checkSpecTyApp for CoPrim in CoreLint
+-- ToDo: Deal with checkSpecTyApp for Prim in CoreLint
 -}
 
 
-specExpr (CoApp fun arg) args
+specExpr (App fun arg) args
   = 	-- Arg is passed on unprocessed
     specExpr fun (ValArg arg : args)	`thenSM` \ (expr,uds) ->
     returnSM (expr, uds)
@@ -1303,8 +1295,16 @@ specExpr (CoTyApp fun ty) args
     specTy ty 				`thenSM` \ ty ->
     specExpr fun (TypeArg ty : args)
 
-specExpr (CoLam bound_ids body)	args
-  = specLam bound_ids body args
+specExpr (Lam binder body) (ValArg arg : args)
+  = lookup_arg arg `thenSM` \ arg ->
+    bindId binder arg (specExpr body args)
+  where
+    lookup_arg (LitArg l) = returnSM (NoLift (LitArg l))
+    lookup_arg (VarArg v) = lookupId v
+
+specExpr (Lam binder body) []
+  = specLambdaOrCaseBody [binder] body [] `thenSM` \ ([binder], body, uds) ->
+    returnSM (Lam binder body, uds)
 
 specExpr (CoTyLam tyvar body) (TypeArg ty : args)
   =	-- Type lambda with argument; argument already spec'd
@@ -1319,40 +1319,38 @@ specExpr (CoTyLam tyvar body) []
 	specExpr body []	`thenSM` \ (body, body_uds) ->
 	let
 	    (binds_here, final_uds) = dumpUDs body_uds False False [] [] [new_tyvar]
-        in
+	in
 	returnSM (CoTyLam new_tyvar (mkCoLetsNoUnboxed binds_here body), final_uds)
     )
 
-specExpr (CoCase scrutinee alts) args
+specExpr (Case scrutinee alts) args
   = specExpr scrutinee []		`thenSM` \ (scrutinee, scrut_uds) ->
     specAlts alts scrutinee_type args	`thenSM` \ (alts, alts_uds) ->
-    returnSM (CoCase scrutinee alts, scrut_uds `unionUDs`  alts_uds)
+    returnSM (Case scrutinee alts, scrut_uds `unionUDs`  alts_uds)
   where
-    scrutinee_type = typeOfCoreExpr scrutinee
+    scrutinee_type = coreExprType scrutinee
 
 
-specExpr (CoLet bind body) args
+specExpr (Let bind body) args
   = specBindAndScope False bind (
 	specExpr body args 	`thenSM` \ (body, body_uds) ->
 	returnSM (ItsAnExpr body, body_uds)
     )				`thenSM` \ (binds, ItsAnExpr body, all_uds) ->
     returnSM (mkCoLetsUnboxedToCase binds body, all_uds)
 
-specExpr (CoSCC cc expr) args
+specExpr (SCC cc expr) args
   = specExpr expr []		`thenSM` \ (expr, expr_uds) ->
-    mapAndUnzip3SM specArg args	`thenSM` \ (args, args_uds_s, unlifts) -> 
+    mapAndUnzip3SM specArg args	`thenSM` \ (args, args_uds_s, unlifts) ->
     let
 	scc_expr
 	  = if squashableDictishCcExpr cc expr -- can toss the _scc_
 	    then expr
-	    else CoSCC cc expr
+	    else SCC cc expr
     in
-    returnSM (applyBindUnlifts unlifts (applyToArgs scc_expr args),
+    returnSM (applyBindUnlifts unlifts (mkGenApp scc_expr args),
 	      unionUDList args_uds_s `unionUDs` expr_uds)
 
--- ToDo: This may leave some unspeced dictionaries !!
-
--- ToDo: DPH: add stuff here!
+-- ToDo: This may leave some unspec'd dictionaries!!
 \end{code}
 
 %************************************************************************
@@ -1361,36 +1359,12 @@ specExpr (CoSCC cc expr) args
 %*									*
 %************************************************************************
 
-\begin{code}
-specLam :: [Id] -> PlainCoreExpr -> [PlainCoreArg]
-	-> SpecM (PlainCoreExpr, UsageDetails)
-
-specLam [] body args 
-  = 	-- All lambdas saturated
-    specExpr body args
-
-specLam (binder:binders) body (ValArg arg : args)
-  = 	-- Lambda with an unprocessed argument
-    lookup_arg arg				`thenSM` \ arg ->
-    bindId binder arg (
-	specLam binders body args
-    )
-  where
-    lookup_arg (CoLitAtom l) = returnSM (NoLift (CoLitAtom l))
-    lookup_arg (CoVarAtom v) = lookupId v
-
-specLam bound_ids body []
-  = 	-- Lambda with no arguments
-    specLambdaOrCaseBody bound_ids body [] 	`thenSM` \ (bound_ids, body, uds) ->
-    returnSM (CoLam bound_ids body, uds)
-\end{code}
-
 \begin{code}
 specLambdaOrCaseBody :: [Id]			-- The binders
-		     -> PlainCoreExpr		-- The body
-		     -> [PlainCoreArg]		-- Its args
+		     -> CoreExpr		-- The body
+		     -> [CoreArg]		-- Its args
 		     -> SpecM ([Id],		-- New binders
-			       PlainCoreExpr,	-- New body
+			       CoreExpr,	-- New body
 			       UsageDetails)
 
 specLambdaOrCaseBody bound_ids body args
@@ -1400,7 +1374,7 @@ specLambdaOrCaseBody bound_ids body args
 	specExpr body args	`thenSM` \ (body, body_uds) ->
 
 	let
-	    -- Dump any dictionary bindings (and call instances) 
+	    -- Dump any dictionary bindings (and call instances)
 	    -- from the scope which mention things bound here
  	    (binds_here, final_uds) = dumpUDs body_uds False False [] new_ids []
 	in
@@ -1436,7 +1410,7 @@ d.Foo.Int :: ( \/b . Int -> b -> Int, \/c . Int -> c -> Int )
 d.Foo.Int = (op1_Int, op2_Int)
 
 op1 = /\ a b -> \ dFoo -> case dFoo of (meth1, _) -> meth1 b
-  
+
 ... op1 {Int Int#} d.Foo.Int 1 3# ...
 \end{verbatim}
 
@@ -1455,7 +1429,7 @@ op1_Int_Int# = case d.Foo.Int of (meth1, _) -> meth1 {Int#}
 Though this is still invalid, after further simplification we get:
 
 op1_Int_Int# = opInt1 {Int#}
-  
+
 Another round of specialisation will result in the specialised
 version of op1Int being called directly.
 
@@ -1475,36 +1449,36 @@ ToDo: Implement and test second round of specialisation.
 
 
 \begin{code}
-specAlts (CoAlgAlts alts deflt) scrutinee_ty args
+specAlts (AlgAlts alts deflt) scrutinee_ty args
   = mapSM specTy ty_args 			`thenSM` \ ty_args ->
     mapAndUnzipSM (specAlgAlt ty_args) alts	`thenSM` \ (alts, alts_uds_s) ->
     specDeflt deflt args			`thenSM` \ (deflt, deflt_uds) ->
-    returnSM (CoAlgAlts alts deflt, 
+    returnSM (AlgAlts alts deflt,
 	      unionUDList alts_uds_s `unionUDs` deflt_uds)
 
   where
     -- We use ty_args of scrutinee type to identify specialisation of alternatives
-    (_, ty_args, _) = getUniDataTyCon scrutinee_ty
+    (_, ty_args, _) = getAppDataTyCon scrutinee_ty
 
-    specAlgAlt ty_args (con,binders,rhs) 
+    specAlgAlt ty_args (con,binders,rhs)
       = specLambdaOrCaseBody binders rhs args	`thenSM` \ (binders, rhs, rhs_uds) ->
 	mkTyConInstance con ty_args    		`thenSM` \ con_uds ->
 	returnSM ((con,binders,rhs), rhs_uds `unionUDs` con_uds)
 
-specAlts (CoPrimAlts alts deflt) scrutinee_ty args
+specAlts (PrimAlts alts deflt) scrutinee_ty args
   = mapAndUnzipSM specPrimAlt alts	`thenSM` \ (alts, alts_uds_s) ->
     specDeflt deflt args		`thenSM` \ (deflt, deflt_uds) ->
-    returnSM (CoPrimAlts alts deflt, 
+    returnSM (PrimAlts alts deflt,
 	      unionUDList alts_uds_s `unionUDs` deflt_uds)
   where
     specPrimAlt (lit,rhs) = specExpr rhs args	`thenSM` \ (rhs, uds) ->
 			    returnSM ((lit,rhs), uds)
 
 
-specDeflt CoNoDefault args = returnSM (CoNoDefault, emptyUDs)
-specDeflt (CoBindDefault binder rhs) args 
+specDeflt NoDefault args = returnSM (NoDefault, emptyUDs)
+specDeflt (BindDefault binder rhs) args
  = specLambdaOrCaseBody [binder] rhs args	`thenSM` \ ([binder], rhs, uds) ->
-   returnSM (CoBindDefault binder rhs, uds)
+   returnSM (BindDefault binder rhs, uds)
 \end{code}
 
 
@@ -1515,24 +1489,24 @@ specDeflt (CoBindDefault binder rhs) args
 %************************************************************************
 
 \begin{code}
-specAtom :: PlainCoreAtom -> SpecM (PlainCoreAtom, UsageDetails,
-				    PlainCoreExpr -> PlainCoreExpr)
+specAtom :: CoreArg -> SpecM (CoreArg, UsageDetails,
+				    CoreExpr -> CoreExpr)
 
-specAtom (CoLitAtom lit)
-  = returnSM (CoLitAtom lit, emptyUDs, id)
+specAtom (LitArg lit)
+  = returnSM (LitArg lit, emptyUDs, id)
 
-specAtom (CoVarAtom v)
+specAtom (VarArg v)
   = lookupId v		`thenSM` \ vlookup ->
-    case vlookup of 
+    case vlookup of
       Lifted vl vu
-	 -> returnSM (CoVarAtom vu, singleFvUDs (CoVarAtom vl), bindUnlift vl vu)
+	 -> returnSM (VarArg vu, singleFvUDs (VarArg vl), bindUnlift vl vu)
 
       NoLift vatom
 	 -> returnSM (vatom, singleFvUDs vatom, id)
 
 
-specArg :: PlainCoreArg -> SpecM (PlainCoreArg, UsageDetails,
-				  PlainCoreExpr -> PlainCoreExpr)
+specArg :: CoreArg -> SpecM (CoreArg, UsageDetails,
+				  CoreExpr -> CoreExpr)
 
 specArg (ValArg arg)	-- unprocessed; spec the atom
   = specAtom arg	`thenSM` \ (arg, uds, unlift) ->
@@ -1552,20 +1526,20 @@ specArg (TypeArg ty)	-- already speced; no action
 A classic case of when having a polymorphic recursive function would help!
 
 \begin{code}
-data BindsOrExpr = ItsABinds [PlainCoreBinding]
-		 | ItsAnExpr PlainCoreExpr
+data BindsOrExpr = ItsABinds [CoreBinding]
+		 | ItsAnExpr CoreExpr
 \end{code}
 
 \begin{code}
-specBindAndScope 
+specBindAndScope
 	:: Bool					-- True <=> a top level group
-	-> PlainCoreBinding			-- As yet unprocessed
+	-> CoreBinding			-- As yet unprocessed
 	-> SpecM (BindsOrExpr, UsageDetails)	-- Something to do the scope of the bindings
-	-> SpecM ([PlainCoreBinding],		-- Processed
+	-> SpecM ([CoreBinding],		-- Processed
 		  BindsOrExpr, 			-- Combined result
 		  UsageDetails)			-- Usage details of the whole lot
 
-specBindAndScope top_lev bind scopeM 
+specBindAndScope top_lev bind scopeM
   = cloneLetBinders top_lev (is_rec bind) binders
 				`thenSM` \ (new_binders, clone_infos) ->
 
@@ -1574,7 +1548,7 @@ specBindAndScope top_lev bind scopeM
 	-- in which case we see if they correspond to any call-instances
 	-- we have from processing the scope
 
-    if not top_lev && all (isDictTy . getIdUniType) binders
+    if not top_lev && all (isDictTy . idType) binders
     then
 	-- Ha! A group of local dictionary bindings
 
@@ -1585,7 +1559,7 @@ specBindAndScope top_lev bind scopeM
 
 		-- Process their scope
 	scopeM					`thenSM` \ (thing, scope_uds) ->
-	let 
+	let
 		-- Add the bindings to the current stuff
 	    final_uds = addDictBinds new_binders bind rhs_uds scope_uds
 	in
@@ -1596,7 +1570,7 @@ specBindAndScope top_lev bind scopeM
 
       fixSM (\ ~(_, _, _, rec_spec_infos) ->
 
-        bindSpecIds binders clone_infos rec_spec_infos (
+	bindSpecIds binders clone_infos rec_spec_infos (
 		-- It's ok to have new binders in scope in
 		-- non-recursive decls too, cos name shadowing is gone by now
 
@@ -1605,8 +1579,8 @@ specBindAndScope top_lev bind scopeM
 	  let
 	     (call_insts, gotci_scope_uds) = getCIs top_lev new_binders scope_uds
 
-             equiv_ciss = equivClasses cmpCI_tys call_insts
-             inst_cis   = map head equiv_ciss
+	     equiv_ciss = equivClasses cmpCI_tys call_insts
+	     inst_cis   = map head equiv_ciss
 	  in
 
 		-- Do the bindings themselves
@@ -1615,7 +1589,7 @@ specBindAndScope top_lev bind scopeM
 
 		-- Create any necessary instances
 	  instBind top_lev new_binders bind equiv_ciss inst_cis
-						`thenSM` \ (inst_binds, inst_uds, spec_infos) -> 
+						`thenSM` \ (inst_binds, inst_uds, spec_infos) ->
 
 	  let
 		-- NB: dumpUDs only worries about new_binders since the free var
@@ -1645,48 +1619,48 @@ specBindAndScope top_lev bind scopeM
 			-- have already been dumped by specBind and instBind
 			let
 			    (scope_dict_binds, final_scope_uds)
-		  	      = dumpUDs gotci_scope_uds False False [] new_binders [] 
+		  	      = dumpUDs gotci_scope_uds False False [] new_binders []
 			in
 			([spec_bind] ++ inst_binds ++ scope_dict_binds,
 			 spec_uds `unionUDs` final_scope_uds `unionUDs` inst_uds)
 
 		-- inst_uds comes last, because there may be dict bindings
-		-- floating outward in scope_uds which are mentioned 
+		-- floating outward in scope_uds which are mentioned
 		-- in the call-instances, and hence in spec_uds.
 		-- This ordering makes sure that the precedence order
 		-- among the dict bindings finally floated out is maintained.
 	  in
 	  returnSM (final_binds, thing, final_uds, spec_infos)
-        )
+	)
       )			`thenSM` 	\ (binds, thing, final_uds, spec_infos) ->
       returnSM (binds, thing, final_uds)
   where
     binders = bindersOf bind
 
-    is_rec (CoNonRec _ _) = False
+    is_rec (NonRec _ _) = False
     is_rec _	          = True
 \end{code}
 
 \begin{code}
 specBind :: Bool -> Bool -> [Id] -> [CallInstance]
-	 -> PlainCoreBinding
-	 -> SpecM (PlainCoreBinding, UsageDetails)
+	 -> CoreBinding
+	 -> SpecM (CoreBinding, UsageDetails)
 	-- The UsageDetails returned has already had stuff to do with this group
 	-- of binders deleted; that's why new_binders is passed in.
-specBind top_lev floating new_binders inst_cis (CoNonRec binder rhs) 
+specBind top_lev floating new_binders inst_cis (NonRec binder rhs)
   = specOneBinding top_lev floating new_binders inst_cis (binder,rhs)
 							`thenSM` \ ((binder,rhs), rhs_uds) ->
-    returnSM (CoNonRec binder rhs, rhs_uds)
+    returnSM (NonRec binder rhs, rhs_uds)
 
-specBind top_lev floating new_binders inst_cis (CoRec pairs)
+specBind top_lev floating new_binders inst_cis (Rec pairs)
   = mapAndUnzipSM (specOneBinding top_lev floating new_binders inst_cis) pairs
 							`thenSM` \ (pairs, rhs_uds_s) ->
-    returnSM (CoRec pairs, unionUDList rhs_uds_s)
+    returnSM (Rec pairs, unionUDList rhs_uds_s)
 
 
 specOneBinding :: Bool -> Bool -> [Id] -> [CallInstance]
-	       -> (Id,PlainCoreExpr)
-	       -> SpecM ((Id,PlainCoreExpr), UsageDetails)
+	       -> (Id,CoreExpr)
+	       -> SpecM ((Id,CoreExpr), UsageDetails)
 
 specOneBinding top_lev floating new_binders inst_cis (binder, rhs)
   = lookupId binder		`thenSM` \ blookup ->
@@ -1696,7 +1670,7 @@ specOneBinding top_lev floating new_binders inst_cis (binder, rhs)
 	is_specid           = maybeToBool specid_maybe_maybe
 	Just specinfo_maybe = specid_maybe_maybe
 	specid_with_info    = maybeToBool specinfo_maybe
-        Just spec_info      = specinfo_maybe
+	Just spec_info      = specinfo_maybe
 
 	-- If we have a SpecInfo stored in a SpecPragmaId binder
 	-- it will contain a SpecInfo with an explicit SpecId
@@ -1713,9 +1687,9 @@ specOneBinding top_lev floating new_binders inst_cis (binder, rhs)
 		ASSERT(toplevelishId orig_id)     -- must not be cloned!
 		explicitCI orig_id spec_tys spec_info
 	    else
-	        emptyUDs
+		emptyUDs
 
-	-- For a local binding we dump the usage details, creating 
+	-- For a local binding we dump the usage details, creating
 	-- any local dict bindings required
 	-- At the top-level the uds will be dumped in specBindAndScope
 	-- and the dict bindings made *global*
@@ -1727,16 +1701,16 @@ specOneBinding top_lev floating new_binders inst_cis (binder, rhs)
 		([], rhs_uds)
     in
     case blookup of
-	Lifted lift_binder unlift_binder 
-	  -> 	-- We may need to record an unboxed instance of 
+	Lifted lift_binder unlift_binder
+	  -> 	-- We may need to record an unboxed instance of
 		-- the _Lift data type in the usage details
-	     mkTyConInstance liftDataCon [getIdUniType unlift_binder]
+	     mkTyConInstance liftDataCon [idType unlift_binder]
 						`thenSM` \ lift_uds ->
 	     returnSM ((lift_binder,
-		        mkCoLetsNoUnboxed local_dict_binds (liftExpr unlift_binder rhs)),
+			mkCoLetsNoUnboxed local_dict_binds (liftExpr unlift_binder rhs)),
 		       final_uds `unionUDs` pragma_uds `unionUDs` lift_uds)
 
-	NoLift (CoVarAtom binder)
+	NoLift (VarArg binder)
 	  -> returnSM ((binder, mkCoLetsNoUnboxed local_dict_binds rhs),
 		       final_uds `unionUDs` pragma_uds)
 \end{code}
@@ -1755,11 +1729,11 @@ instBind top_lev new_ids@(first_binder:other_binders) bind equiv_ciss inst_cis
 
  | all same_overloading other_binders
  = 	-- For each call_inst, build an instance
-   mapAndUnzip3SM do_this_class equiv_ciss 
+   mapAndUnzip3SM do_this_class equiv_ciss
 	`thenSM` \ (inst_binds, inst_uds_s, spec_infos) ->
 
 	-- Add in the remaining UDs
-   returnSM (catMaybes inst_binds, 
+   returnSM (catMaybes inst_binds,
    	     unionUDList inst_uds_s,
 	     spec_infos
 	    )
@@ -1771,7 +1745,7 @@ instBind top_lev new_ids@(first_binder:other_binders) bind equiv_ciss inst_cis
     then pprTrace "dumpCIs: not same overloading ... top level \n"
     else (\ x y -> y)
    ) (ppHang (ppBesides [ppStr "{", ppr PprDebug new_ids, ppStr "}"])
-   	   4 (ppAboves [ppAboves (map (pprUniType PprDebug . getIdUniType) new_ids),
+   	   4 (ppAboves [ppAboves (map (pprType PprDebug . idType) new_ids),
 			ppAboves (map pprCI (concat equiv_ciss))]))
    (returnSM ([], emptyUDs, []))
 
@@ -1789,7 +1763,7 @@ instBind top_lev new_ids@(first_binder:other_binders) bind equiv_ciss inst_cis
 	do_cis = head (normal_cis ++ explicit_cis)
 	-- must choose a normal_cis in preference since dict_args will
 	-- not be defined for an explicit_cis
-		 
+
 	-- same_overloading tests whether the types of all the binders
 	-- are "compatible"; ie have the same type and dictionary abstractions
 	-- Almost always this is the case, because a recursive group is abstracted
@@ -1810,17 +1784,19 @@ instBind top_lev new_ids@(first_binder:other_binders) bind equiv_ciss inst_cis
 	-- mutually recursive!
 
     same_overloading :: Id -> Bool
-    same_overloading id 
-      = no_of_tyvars == length this_id_tyvars 					-- Same no of tyvars
-	&&
-	no_of_dicts == length this_id_class_tyvar_pairs				-- Same no of vdicts
-	&&
-	and (zipWith same_ov class_tyvar_pairs this_id_class_tyvar_pairs)	-- Same overloading
+    same_overloading id
+      = no_of_tyvars == length this_id_tyvars
+	-- Same no of tyvars
+	&& no_of_dicts == length this_id_class_tyvar_pairs
+	-- Same no of vdicts
+	&& and (zipWith same_ov class_tyvar_pairs this_id_class_tyvar_pairs)
+	&& length class_tyvar_pairs == length this_id_class_tyvar_pairs
+	-- Same overloading
       where
 	(this_id_tyvars, this_id_class_tyvar_pairs) = getIdOverloading id
   	tyvar_pairs = this_id_tyvars `zip` tyvar_tmpls
 
-	same_ov (clas1,tyvar1) (clas2,tyvar2) 
+	same_ov (clas1,tyvar1) (clas2,tyvar2)
 	  = clas1  == clas2 &&
 	    tyvar1 == assoc "same_overloading" tyvar_pairs tyvar2
 \end{code}
@@ -1838,7 +1814,7 @@ We return a new definition
 
 The SpecInfo for f will be (the "2" indicates 2 dictionaries to eat)
 
-	SpecInfo [Just t1, Nothing, Just t3] 2 f@t1//t3 
+	SpecInfo [Just t1, Nothing, Just t3] 2 f@t1//t3
 
 Based on this SpecInfo, a call instance of f
 
@@ -1857,8 +1833,8 @@ mkOneInst :: CallInstance
 	  -> Bool				-- Top level binders?
 	  -> [CallInstance]			-- Instantiated call insts for binders
 	  -> [Id]				-- New binders
-	  -> PlainCoreBinding			-- Unprocessed
-	  -> SpecM (Maybe PlainCoreBinding,	-- Instantiated version of input
+	  -> CoreBinding			-- Unprocessed
+	  -> SpecM (Maybe CoreBinding,	-- Instantiated version of input
 		    UsageDetails,
 		    [Maybe SpecInfo]		-- One for each id in the original binding
 		   )
@@ -1872,34 +1848,34 @@ mkOneInst do_cis@(CallInstance _ spec_tys dict_args _ _) explicit_cis
     let
 	-- arg_tys is spec_tys with tyvars instead of the Nothing spec_tys
 	-- which correspond to unspeciailsed args
-	arg_tys  :: [UniType]
+	arg_tys  :: [Type]
 	(_,arg_tys) = mapAccumL do_the_wotsit poly_tyvars spec_tys
 
-	args :: [PlainCoreArg]
+	args :: [CoreArg]
 	args = map TypeArg arg_tys ++ dict_args
 
 	(new_id:_) = new_ids
 	(spec_id:_) = spec_ids
 
-	do_bind (CoNonRec orig_id rhs) 
+	do_bind (NonRec orig_id rhs)
 	  = do_one_rhs (spec_id, new_id, (orig_id,rhs))
 					`thenSM` \ (maybe_spec, rhs_uds, spec_info) ->
 	    case maybe_spec of
-		Just (spec_id, rhs) -> returnSM (Just (CoNonRec spec_id rhs), rhs_uds, [spec_info])
+		Just (spec_id, rhs) -> returnSM (Just (NonRec spec_id rhs), rhs_uds, [spec_info])
 		Nothing 	    -> returnSM (Nothing, rhs_uds, [spec_info])
 
-	do_bind (CoRec pairs)
+	do_bind (Rec pairs)
 	  = mapAndUnzip3SM do_one_rhs (zip3 spec_ids new_ids pairs)
 					`thenSM` \ (maybe_pairs, rhss_uds_s, spec_infos) ->
-	    returnSM (Just (CoRec (catMaybes maybe_pairs)),
+	    returnSM (Just (Rec (catMaybes maybe_pairs)),
 		      unionUDList rhss_uds_s, spec_infos)
 
 	do_one_rhs (spec_id, new_id, (orig_id, orig_rhs))
 
 		-- Avoid duplicating a spec which has already been created ...
-		-- This can arise in a CoRec involving a dfun for which a
+		-- This can arise in a Rec involving a dfun for which a
 		-- a specialised instance has been created but specialisation
-		-- "required" by one of the other Ids in the CoRec
+		-- "required" by one of the other Ids in the Rec
 	  | top_lev && maybeToBool lookup_orig_spec
 	  = (if sw_chkr SpecialiseTrace
 	     then trace_nospec "  Exists: " exists_id
@@ -1914,7 +1890,7 @@ mkOneInst do_cis@(CallInstance _ spec_tys dict_args _ _) explicit_cis
 	    (if sw_chkr SpecialiseTrace
 	     then trace_nospec "  Explicit: " explicit_id
 	     else id) (
-	    
+
 	    returnSM (Nothing, tickSpecInsts emptyUDs, Just explicit_spec_info)
 	    )
 
@@ -1922,32 +1898,32 @@ mkOneInst do_cis@(CallInstance _ spec_tys dict_args _ _) explicit_cis
 	  | otherwise
 	  = ASSERT (no_of_dicts_to_specialise == length dict_args)
 	    specExpr orig_rhs args	`thenSM` \ (inst_rhs, inst_uds) ->
-	    let 
-	        -- For a local binding we dump the usage details, creating 
-	        -- any local dict bindings required
-	        -- At the top-level the uds will be dumped in specBindAndScope
-	        -- and the dict bindings made *global*
-	    
-	        (local_dict_binds, final_uds)
-	          = if not top_lev then
+	    let
+		-- For a local binding we dump the usage details, creating
+		-- any local dict bindings required
+		-- At the top-level the uds will be dumped in specBindAndScope
+		-- and the dict bindings made *global*
+
+		(local_dict_binds, final_uds)
+		  = if not top_lev then
 	    	        dumpUDs inst_uds False False inst_cis new_ids []
-	            else
+		    else
 	    	        ([], inst_uds)
-	    
-	        spec_info = Just (SpecInfo spec_tys no_of_dicts_to_specialise spec_id)
+
+		spec_info = Just (SpecInfo spec_tys no_of_dicts_to_specialise spec_id)
 	    in
-	    if isUnboxedDataType (getIdUniType spec_id) then
-	        ASSERT (null poly_tyvars)
-	        liftId spec_id		`thenSM` \ (lift_spec_id, unlift_spec_id) ->
-	        mkTyConInstance liftDataCon [getIdUniType unlift_spec_id]
+	    if isUnboxedDataType (idType spec_id) then
+		ASSERT (null poly_tyvars)
+		liftId spec_id		`thenSM` \ (lift_spec_id, unlift_spec_id) ->
+		mkTyConInstance liftDataCon [idType unlift_spec_id]
 	    				`thenSM` \ lift_uds ->
-	        returnSM (Just (lift_spec_id,
-	                        mkCoLetsNoUnboxed local_dict_binds (liftExpr unlift_spec_id inst_rhs)),
-	                  tickSpecInsts (final_uds `unionUDs` lift_uds), spec_info)
+		returnSM (Just (lift_spec_id,
+				mkCoLetsNoUnboxed local_dict_binds (liftExpr unlift_spec_id inst_rhs)),
+			  tickSpecInsts (final_uds `unionUDs` lift_uds), spec_info)
 	    else
-	        returnSM (Just (spec_id,
+		returnSM (Just (spec_id,
 	    	                mkCoLetsNoUnboxed local_dict_binds (mkCoTyLam poly_tyvars inst_rhs)),
-	                  tickSpecInsts final_uds, spec_info)
+			  tickSpecInsts final_uds, spec_info)
 	  where
 	    lookup_orig_spec = lookupSpecEnv (getIdSpecialisation orig_id) arg_tys
 	    Just (exists_id, _, _) = lookup_orig_spec
@@ -1963,21 +1939,21 @@ mkOneInst do_cis@(CallInstance _ spec_tys dict_args _ _) explicit_cis
     in
     (if sw_chkr SpecialiseTrace then
 	pprTrace "Specialising:"
-        (ppHang (ppBesides [ppStr "{", ppr PprDebug new_ids, ppStr "}"])
+	(ppHang (ppBesides [ppStr "{", ppr PprDebug new_ids, ppStr "}"])
 	      4 (ppAboves [
-	         ppBesides [ppStr "types: ", ppInterleave ppNil (map pp_ty arg_tys)],
+		 ppBesides [ppStr "types: ", ppInterleave ppNil (map pp_ty arg_tys)],
 		 if isExplicitCI do_cis then ppNil else
 		 ppBesides [ppStr "dicts: ", ppInterleave ppNil (map pp_dict dict_args)],
-	         ppBesides [ppStr "specs: ", ppr PprDebug spec_ids]]))
+		 ppBesides [ppStr "specs: ", ppr PprDebug spec_ids]]))
      else id) (
-	   
+
     do_bind orig_bind		`thenSM` \ (maybe_inst_bind, inst_uds, spec_infos) ->
 
     returnSM (maybe_inst_bind, inst_uds, spec_infos)
     )
   where
     pp_dict (ValArg d) = ppr PprDebug d
-    pp_ty t = pprParendUniType PprDebug t
+    pp_ty t = pprParendType PprDebug t
 
     do_the_wotsit (tyvar:tyvars) Nothing   = (tyvars, mkTyVarTy tyvar)
     do_the_wotsit tyvars         (Just ty) = (tyvars, ty)
@@ -1991,9 +1967,9 @@ mkOneInst do_cis@(CallInstance _ spec_tys dict_args _ _) explicit_cis
 %************************************************************************
 
 \begin{code}
-mkCallInstance :: Id 
+mkCallInstance :: Id
 	       -> Id
-	       -> [(PlainCoreArg, UsageDetails, PlainCoreExpr -> PlainCoreExpr)]
+	       -> [(CoreArg, UsageDetails, CoreExpr -> CoreExpr)]
 	       -> SpecM UsageDetails
 
 mkCallInstance id new_id []
@@ -2020,9 +1996,9 @@ mkCallInstance id new_id args
   | otherwise
   = getSwitchCheckerSM		`thenSM` \ sw_chkr ->
     let
-        spec_overloading = sw_chkr SpecialiseOverloaded
-        spec_unboxed     = sw_chkr SpecialiseUnboxed
-        spec_all	 = sw_chkr SpecialiseAll
+	spec_overloading = sw_chkr SpecialiseOverloaded
+	spec_unboxed     = sw_chkr SpecialiseUnboxed
+	spec_all	 = sw_chkr SpecialiseAll
 
 	(tyvars, class_tyvar_pairs) = getIdOverloading id
 
@@ -2035,7 +2011,7 @@ mkCallInstance id new_id args
 	  = (record, lookup, spec_tys)
 	  where
 	    spec_tys = specialiseCallTys spec_all spec_unboxed spec_overloading
-		                         (mkConstraintVector id) tys
+					 (mkConstraintVector id) tys
 
 	    record = any (not . isTyVarTy) (catMaybes spec_tys)
 
@@ -2043,11 +2019,11 @@ mkCallInstance id new_id args
     in
     if (not enough_args) then
 	pprPanic "Specialise:recordCallInst: Unsaturated Type & Dict Application:\n\t"
-		 (ppCat [ppr PprDebug id, ppr PprDebug [arg | (arg,_,_) <- args] ]) 
+		 (ppCat [ppr PprDebug id, ppr PprDebug [arg | (arg,_,_) <- args] ])
     else
     case record_spec id tys of
 	(False, _, _)
-	     -> -- pprTrace "CallInst:NotReqd\n" 
+	     -> -- pprTrace "CallInst:NotReqd\n"
 	   	-- (ppCat [ppr PprDebug id, ppCat (map (ppr PprDebug) args)])
 		(returnSM emptyUDs)
 
@@ -2056,7 +2032,7 @@ mkCallInstance id new_id args
 		    returnSM emptyUDs
 		else
 		    -- pprTrace "CallInst:Reqd\n"
-	            -- (ppAboves [ppCat [ppr PprDebug id, ppCat (map (ppr PprDebug) args)],
+		    -- (ppAboves [ppCat [ppr PprDebug id, ppCat (map (ppr PprDebug) args)],
 		    --	          ppCat [ppStr "CI", ppCat (map (pprMaybeTy PprDebug) spec_tys),
 	   	    --		                     ppCat (map (ppr PprDebug) dicts)]])
 		    (returnSM (singleCI new_id spec_tys dicts))
@@ -2067,15 +2043,15 @@ mkCallInstance id new_id args
 			-- NB: const method is top-level so spec_id will not be cloned
 		    case record_spec spec_id tys_left of
 		      (False, _, _)
-		    	-> -- pprTrace "CallInst:Exists\n" 
-	            	   -- (ppAboves [ppCat [ppr PprDebug id, ppCat (map (ppr PprDebug) args)],
+		    	-> -- pprTrace "CallInst:Exists\n"
+		    	   -- (ppAboves [ppCat [ppr PprDebug id, ppCat (map (ppr PprDebug) args)],
 		    	   --	         ppCat [ppStr "->", ppr PprDebug spec_id,
 		    	   --		        ppr PprDebug (tys_left ++ drop toss dicts)]])
 			   (returnSM emptyUDs)
 
 		      (True, Nothing, spec_tys)
 			-> -- pprTrace "CallInst:Exists:Reqd\n"
-	            	   -- (ppAboves [ppCat [ppr PprDebug id, ppCat (map (ppr PprDebug) args)],
+		    	   -- (ppAboves [ppCat [ppr PprDebug id, ppCat (map (ppr PprDebug) args)],
 		    	   --	         ppCat [ppStr "->", ppr PprDebug spec_id,
 		    	   --		        ppr PprDebug (tys_left ++ drop toss dicts)],
 			   --	         ppCat [ppStr "CI", ppCat (map (pprMaybeTy PprDebug) spec_tys),
@@ -2083,8 +2059,8 @@ mkCallInstance id new_id args
 			   (returnSM (singleCI spec_id spec_tys (drop toss dicts)))
 
 		      (True, Just (spec_spec_id, tys_left_left, toss_toss), _)
-			-> -- pprTrace "CallInst:Exists:Exists\n" 
-	            	   -- (ppAboves [ppCat [ppr PprDebug id, ppCat (map (ppr PprDebug) args)],
+			-> -- pprTrace "CallInst:Exists:Exists\n"
+		    	   -- (ppAboves [ppCat [ppr PprDebug id, ppCat (map (ppr PprDebug) args)],
 		    	   --	         ppCat [ppStr "->", ppr PprDebug spec_id,
 		    	   --		        ppr PprDebug (tys_left ++ drop toss dicts)],
 		    	   --	         ppCat [ppStr "->", ppr PprDebug spec_spec_id,
@@ -2092,25 +2068,25 @@ mkCallInstance id new_id args
 			   (returnSM emptyUDs)
 
 		else
-		    -- pprTrace "CallInst:Exists\n" 
-	            -- (ppAboves [ppCat [ppr PprDebug id, ppCat (map (ppr PprDebug) args)],
+		    -- pprTrace "CallInst:Exists\n"
+		    -- (ppAboves [ppCat [ppr PprDebug id, ppCat (map (ppr PprDebug) args)],
 		    --	          ppCat [ppStr "->", ppr PprDebug spec_id,
 		    --		         ppr PprDebug (tys_left ++ drop toss dicts)]])
 		    (returnSM emptyUDs)
 
 
-take_type_args (_:tyvars) class_tyvar_pairs ((TypeArg ty,_,_):args) 
+take_type_args (_:tyvars) class_tyvar_pairs ((TypeArg ty,_,_):args)
 	= case take_type_args tyvars class_tyvar_pairs args of
 		Nothing 	          -> Nothing
 		Just (tys, dicts, others) -> Just (ty:tys, dicts, others)
 take_type_args (_:tyvars) class_tyvar_pairs []
 	= Nothing
-take_type_args [] class_tyvar_pairs args 
+take_type_args [] class_tyvar_pairs args
 	= case take_dict_args class_tyvar_pairs args of
 		Nothing              -> Nothing
 		Just (dicts, others) -> Just ([], dicts, others)
 
-take_dict_args (_:class_tyvar_pairs) ((dict@(ValArg _),_,_):args) 
+take_dict_args (_:class_tyvar_pairs) ((dict@(ValArg _),_,_):args)
 	= case take_dict_args class_tyvar_pairs args of
 		Nothing              -> Nothing
 		Just (dicts, others) -> Just (dict:dicts, others)
@@ -2122,8 +2098,8 @@ take_dict_args [] args
 
 \begin{code}
 mkCall :: Id
-       -> [(PlainCoreArg, UsageDetails, PlainCoreExpr -> PlainCoreExpr)]
-       -> SpecM (Bool, PlainCoreExpr)
+       -> [(CoreArg, UsageDetails, CoreExpr -> CoreExpr)]
+       -> SpecM (Bool, CoreExpr)
 
 mkCall new_id args
   | maybeToBool (isSuperDictSelId_maybe new_id)
@@ -2135,11 +2111,11 @@ mkCall new_id args
 	--     have been specialised. We only do this to keep core-lint happy.
     = let
 	 Just (_, super_class) = isSuperDictSelId_maybe new_id
-         super_dict_id = case lookupClassInstAtSimpleType super_class (head ty_args) of
+	 super_dict_id = case lookupClassInstAtSimpleType super_class (head ty_args) of
 			 Nothing -> panic "Specialise:mkCall:SuperDictId"
 			 Just id -> id
       in
-      returnSM (False, CoVar super_dict_id)
+      returnSM (False, Var super_dict_id)
 
   | otherwise
     = case lookupSpecEnv (getIdSpecialisation new_id) ty_args of
@@ -2147,7 +2123,7 @@ mkCall new_id args
 		   returnSM (False, unspec_call)
 		   )
 
-	Just spec_1_details@(spec_id_1, tys_left_1, dicts_to_toss_1) 
+	Just spec_1_details@(spec_id_1, tys_left_1, dicts_to_toss_1)
 		-> let
 			-- It may be necessary to specialsie a constant method spec_id again
 		       (spec_id, tys_left, dicts_to_toss) =
@@ -2157,7 +2133,7 @@ mkCall new_id args
 				 (True, Nothing) -> spec_1_details
 				 (True, Just (spec_id_2, tys_left_2, dicts_to_toss_2))
 						 -> (spec_id_2, tys_left_2, dicts_to_toss_1 + dicts_to_toss_2)
-				
+
 		       args_left = toss_dicts dicts_to_toss val_args
 		   in
 		   checkSpecOK new_id ty_args spec_id tys_left (
@@ -2173,29 +2149,29 @@ mkCall new_id args
 			-- These top level defns should have been lifted.
 			-- We must add code to unlift such a spec_id.
 
-		   if isUnboxedDataType (getIdUniType spec_id) then
+		   if isUnboxedDataType (idType spec_id) then
 		       ASSERT (null tys_left && null args_left)
 		       if toplevelishId spec_id then
 		 	   liftId spec_id 	`thenSM` \ (lift_spec_id, unlift_spec_id) ->
 			   returnSM (True, bindUnlift lift_spec_id unlift_spec_id
-						      (CoVar unlift_spec_id))
+						      (Var unlift_spec_id))
 		       else
 			   pprPanic "Specialise:mkCall: unboxed spec_id not top-level ...\n"
 				    (ppCat [ppr PprDebug new_id,
-				            ppInterleave ppNil (map (pprParendUniType PprDebug) ty_args),
+					    ppInterleave ppNil (map (pprParendType PprDebug) ty_args),
 					    ppStr "==>",
 					    ppr PprDebug spec_id])
 		   else
 		   let
 		       (vals_left, _, unlifts_left) = unzip3 args_left
-		       applied_tys  = mkCoTyApps (CoVar spec_id) tys_left
-		       applied_vals = applyToArgs applied_tys vals_left
+		       applied_tys  = mkCoTyApps (Var spec_id) tys_left
+		       applied_vals = mkGenApp applied_tys vals_left
 		   in
 		   returnSM (True, applyBindUnlifts unlifts_left applied_vals)
 		   )
   where
     (tys_and_vals, _, unlifts) = unzip3 args
-    unspec_call = applyBindUnlifts unlifts (applyToArgs (CoVar new_id) tys_and_vals)
+    unspec_call = applyBindUnlifts unlifts (mkGenApp (Var new_id) tys_and_vals)
 
 
 	-- ty_args is the types at the front of the arg list
@@ -2214,34 +2190,34 @@ mkCall new_id args
 \end{code}
 
 \begin{code}
-checkUnspecOK :: Id -> [UniType] -> a -> a
+checkUnspecOK :: Id -> [Type] -> a -> a
 checkUnspecOK check_id tys
   = if isLocallyDefined check_id && any isUnboxedDataType tys
     then pprPanic "Specialise:checkUnspecOK: unboxed instance for local id not found\n"
 		  (ppCat [ppr PprDebug check_id,
-			  ppInterleave ppNil (map (pprParendUniType PprDebug) tys)])
+			  ppInterleave ppNil (map (pprParendType PprDebug) tys)])
     else id
 
-checkSpecOK :: Id -> [UniType] -> Id -> [UniType] -> a -> a
+checkSpecOK :: Id -> [Type] -> Id -> [Type] -> a -> a
 checkSpecOK check_id tys spec_id tys_left
   = if any isUnboxedDataType tys_left
     then pprPanic "Specialise:checkSpecOK: unboxed type args in specialised application\n"
 		  (ppAboves [ppCat [ppr PprDebug check_id,
-				    ppInterleave ppNil (map (pprParendUniType PprDebug) tys)],
+				    ppInterleave ppNil (map (pprParendType PprDebug) tys)],
 			     ppCat [ppr PprDebug spec_id,
-				    ppInterleave ppNil (map (pprParendUniType PprDebug) tys_left)]])
+				    ppInterleave ppNil (map (pprParendType PprDebug) tys_left)]])
     else id
 \end{code}
 
 \begin{code}
 mkTyConInstance :: Id
-		-> [UniType]
+		-> [Type]
    		-> SpecM UsageDetails
 mkTyConInstance con tys
   = recordTyConInst con tys	`thenSM` \ record_inst ->
     case record_inst of
       Nothing				-- No TyCon instance
-        -> -- pprTrace "NoTyConInst:" 
+	-> -- pprTrace "NoTyConInst:"
 	   -- (ppCat [ppr PprDebug tycon, ppStr "at",
 	   --	      ppr PprDebug con, ppCat (map (ppr PprDebug) tys)])
 	   (returnSM (singleConUDs con))
@@ -2250,7 +2226,7 @@ mkTyConInstance con tys
 	-> -- pprTrace "TyConInst:"
 	   -- (ppCat [ppr PprDebug tycon, ppStr "at",
 	   --	      ppr PprDebug con, ppCat (map (ppr PprDebug) tys),
-	   --	      ppBesides [ppStr "(", 
+	   --	      ppBesides [ppStr "(",
 	   --			 ppCat [pprMaybeTy PprDebug ty | ty <- spec_tys],
 	   --			 ppStr ")"]])
 	   (returnSM (singleTyConI tycon spec_tys `unionUDs` singleConUDs con))
@@ -2260,17 +2236,17 @@ mkTyConInstance con tys
 
 \begin{code}
 recordTyConInst :: Id
-		-> [UniType]
-		-> SpecM (Maybe [Maybe UniType])
+		-> [Type]
+		-> SpecM (Maybe [Maybe Type])
 
 recordTyConInst con tys
   = let
-        spec_tys = specialiseConstrTys tys
+	spec_tys = specialiseConstrTys tys
 
 	do_tycon_spec = maybeToBool (firstJust spec_tys)
 
-        spec_exists = maybeToBool (lookupSpecEnv 
-				      (getIdSpecialisation con) 
+	spec_exists = maybeToBool (lookupSpecEnv
+				      (getIdSpecialisation con)
 				      tys)
     in
     -- pprTrace "ConSpecExists?: "
@@ -2292,9 +2268,9 @@ Monad has:
  inherited: control flags and
 	    recordInst functions with flags cached
 
-	    environment mapping tyvars to types 
+	    environment mapping tyvars to types
 	    environment mapping Ids to Atoms
- 
+
  threaded in and out: unique supply
 
 \begin{code}
@@ -2302,7 +2278,7 @@ type SpecM result
   =  (GlobalSwitch -> Bool)
   -> TypeEnv
   -> SpecIdEnv
-  -> SplitUniqSupply
+  -> UniqSupply
   -> result
 
 initSM m sw_chker uniqs
@@ -2333,7 +2309,7 @@ The only interesting bit is figuring out the type of the SpecId!
 
 \begin{code}
 newSpecIds :: [Id]		-- The id of which to make a specialised version
-	   -> [Maybe UniType]	-- Specialise to these types
+	   -> [Maybe Type]	-- Specialise to these types
 	   -> Int		-- No of dicts to specialise
 	   -> SpecM [Id]
 
@@ -2341,14 +2317,14 @@ newSpecIds new_ids maybe_tys dicts_to_ignore sw_chkr tvenv idenv us
   = [ mkSpecId uniq id maybe_tys (spec_id_ty id) (selectIdInfoForSpecId id)
       | (id,uniq) <- new_ids `zip` uniqs ]
   where
-    uniqs = getSUniques (length new_ids) us
-    spec_id_ty id = specialiseTy (getIdUniType id) maybe_tys dicts_to_ignore
+    uniqs = getUniques (length new_ids) us
+    spec_id_ty id = specialiseTy (idType id) maybe_tys dicts_to_ignore
 
 newTyVars :: Int -> SpecM [TyVar]
 newTyVars n sw_chkr tvenv idenv us
  = map mkPolySysTyVar uniqs
  where
-   uniqs = getSUniques n us
+   uniqs = getUniques n us
 \end{code}
 
 @cloneLambdaOrCaseBinders@ and @cloneLetBinders@ take a bunch of
@@ -2362,19 +2338,19 @@ originals in three ways:
 
 As well as returning the list of cloned @Id@s they also return a list of
 @CloneInfo@s which the original binders should be bound to.
-	    
+
 \begin{code}
 cloneLambdaOrCaseBinders :: [Id] 			-- Old binders
 			 -> SpecM ([Id], [CloneInfo])	-- New ones
 
 cloneLambdaOrCaseBinders old_ids sw_chkr tvenv idenv us
   = let
-	uniqs = getSUniques (length old_ids) us
+	uniqs = getUniques (length old_ids) us
     in
-    unzip (zipWith clone_it old_ids uniqs)
+    unzip (zipWithEqual clone_it old_ids uniqs)
   where
     clone_it old_id uniq
-      = (new_id, NoLift (CoVarAtom new_id))
+      = (new_id, NoLift (VarArg new_id))
       where
 	new_id = applyTypeEnvToId tvenv (mkIdWithNewUniq old_id uniq)
 
@@ -2385,7 +2361,7 @@ cloneLetBinders :: Bool 			-- Top level ?
 
 cloneLetBinders top_lev is_rec old_ids sw_chkr tvenv idenv us
   = let
-	uniqs = getSUniques (2 * length old_ids) us
+	uniqs = getUniques (2 * length old_ids) us
     in
     unzip (clone_them old_ids uniqs)
   where
@@ -2394,10 +2370,10 @@ cloneLetBinders top_lev is_rec old_ids sw_chkr tvenv idenv us
     clone_them (old_id:olds) (u1:u2:uniqs)
       | top_lev
 	= (old_id,
-	   NoLift (CoVarAtom old_id)) : clone_rest
+	   NoLift (VarArg old_id)) : clone_rest
 
 	 -- Don't clone if it is a top-level thing. Why not?
-	 -- (a) we don't want to change the uniques 
+	 -- (a) we don't want to change the uniques
 	 --     on such things (see TopLevId in Id.lhs)
 	 -- (b) we don't have to be paranoid about name capture
 	 -- (c) the thing is polymorphic so no need to subst
@@ -2407,14 +2383,14 @@ cloneLetBinders top_lev is_rec old_ids sw_chkr tvenv idenv us
 	  then (lifted_id,
 		Lifted lifted_id unlifted_id) : clone_rest
 	  else (new_id,
-		NoLift (CoVarAtom new_id)) : clone_rest
+		NoLift (VarArg new_id)) : clone_rest
 
-      where 
+      where
 	clone_rest = clone_them olds uniqs
 
 	new_id = applyTypeEnvToId tvenv (mkIdWithNewUniq old_id u1)
-	new_ty = getIdUniType new_id
-	old_ty = getIdUniType old_id
+	new_ty = idType new_id
+	old_ty = idType old_id
 
 	(lifted_id, unlifted_id) = mkLiftedId new_id u2
 
@@ -2423,7 +2399,7 @@ cloneTyVarSM :: TyVar -> SpecM TyVar
 
 cloneTyVarSM old_tyvar sw_chkr tvenv idenv us
   = let
-	uniq = getSUnique us
+	uniq = getUnique us
     in
     cloneTyVar old_tyvar uniq -- new_tyvar
 
@@ -2442,7 +2418,7 @@ bindSpecIds :: [Id]			-- Old
 	    -> [[Maybe SpecInfo]]	-- Corresponding specialisations
 					-- Each sub-list corresponds to a different type,
 					-- and contains one Maybe spec_info for each id
-	    -> SpecM thing 
+	    -> SpecM thing
 	    -> SpecM thing
 
 bindSpecIds olds clones spec_infos specm sw_chkr tvenv idenv us
@@ -2453,12 +2429,12 @@ bindSpecIds olds clones spec_infos specm sw_chkr tvenv idenv us
    -- The important thing here is that we are *lazy* in spec_infos
    mk_old_to_clone [] [] _ = []
    mk_old_to_clone (old:rest_olds) (clone:rest_clones) spec_infos
-     = (old, add_spec_info clone) : 
+     = (old, add_spec_info clone) :
        mk_old_to_clone rest_olds rest_clones spec_infos_rest
      where
-       add_spec_info (NoLift (CoVarAtom new))
-	 = NoLift (CoVarAtom (new `addIdSpecialisation`
-			          (mkSpecEnv spec_infos_this_id)))
+       add_spec_info (NoLift (VarArg new))
+	 = NoLift (VarArg (new `addIdSpecialisation`
+				  (mkSpecEnv spec_infos_this_id)))
        add_spec_info lifted
 	 = lifted		-- no specialised instances for unboxed lifted values
 
@@ -2466,7 +2442,7 @@ bindSpecIds olds clones spec_infos specm sw_chkr tvenv idenv us
        spec_infos_rest    = map tail spec_infos
 
 
-bindTyVar :: TyVar -> UniType -> SpecM thing -> SpecM thing
+bindTyVar :: TyVar -> Type -> SpecM thing -> SpecM thing
 
 bindTyVar tyvar ty specm sw_chkr tvenv idenv us
  = specm sw_chkr (growTyVarEnvList tvenv [(tyvar,ty)]) idenv us
@@ -2475,16 +2451,16 @@ bindTyVar tyvar ty specm sw_chkr tvenv idenv us
 \begin{code}
 lookupId :: Id -> SpecM CloneInfo
 
-lookupId id sw_chkr tvenv idenv us 
+lookupId id sw_chkr tvenv idenv us
   = case lookupIdEnv idenv id of
-      Nothing   -> NoLift (CoVarAtom id)
+      Nothing   -> NoLift (VarArg id)
       Just info -> info
 \end{code}
 
 \begin{code}
-specTy :: UniType -> SpecM UniType	-- Apply the current type envt to the type
+specTy :: Type -> SpecM Type	-- Apply the current type envt to the type
 
-specTy ty sw_chkr tvenv idenv us 
+specTy ty sw_chkr tvenv idenv us
   = applyTypeEnvToTy tvenv ty
 \end{code}
 
@@ -2492,7 +2468,7 @@ specTy ty sw_chkr tvenv idenv us
 liftId :: Id -> SpecM (Id, Id)
 liftId id sw_chkr tvenv idenv us
   = let
-	uniq = getSUnique us
+	uniq = getUnique us
     in
     mkLiftedId id uniq
 \end{code}
diff --git a/ghc/compiler/stgSyn/CoreToStg.hi b/ghc/compiler/stgSyn/CoreToStg.hi
deleted file mode 100644
index 3348074b1b..0000000000
--- a/ghc/compiler/stgSyn/CoreToStg.hi
+++ /dev/null
@@ -1,20 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface CoreToStg where
-import BasicLit(BasicLit)
-import CoreSyn(CoreAtom, CoreBinding, CoreCaseAlternatives, CoreExpr)
-import CostCentre(CostCentre)
-import Id(Id)
-import PrimOps(PrimOp)
-import SplitUniq(SplitUniqSupply)
-import StgSyn(StgAtom, StgBinderInfo, StgBinding, StgExpr, StgRhs, UpdateFlag)
-import TyVar(TyVar)
-import UniType(UniType)
-data CoreBinding a b 
-data CoreExpr a b 
-data Id 
-data SplitUniqSupply 
-data StgBinderInfo 
-data StgBinding a b 
-data StgRhs a b 
-topCoreBindsToStg :: SplitUniqSupply -> [CoreBinding Id Id] -> [StgBinding Id Id]
-
diff --git a/ghc/compiler/stgSyn/CoreToStg.lhs b/ghc/compiler/stgSyn/CoreToStg.lhs
index 1fc7ba5a12..5afb086b07 100644
--- a/ghc/compiler/stgSyn/CoreToStg.lhs
+++ b/ghc/compiler/stgSyn/CoreToStg.lhs
@@ -1,5 +1,5 @@
 %
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
 %
 %************************************************************************
 %*									*
@@ -14,20 +14,16 @@ Convert a @CoreSyntax@ program to a @StgSyntax@ program.
 #include "HsVersions.h"
 
 module CoreToStg (
-	topCoreBindsToStg,
+	topCoreBindsToStg
 
 	-- and to make the interface self-sufficient...
-	SplitUniqSupply, Id, CoreExpr, CoreBinding, StgBinding,
-	StgRhs, StgBinderInfo
     ) where
 
-import PlainCore	-- input
 import AnnCoreSyn	-- intermediate form on which all work is done
 import StgSyn		-- output
-import SplitUniq
-import Unique		-- the UniqueSupply monadery used herein
+import UniqSupply
 
-import AbsPrel		( unpackCStringId, unpackCString2Id, stringTy,
+import PrelInfo		( unpackCStringId, unpackCString2Id, stringTy,
 			  integerTy, rationalTy, ratioDataCon,
 			  PrimOp(..),		-- For Int2IntegerOp etc
 			  integerZeroId, integerPlusOneId,
@@ -37,18 +33,17 @@ import AbsPrel		( unpackCStringId, unpackCString2Id, stringTy,
 			  IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
 			)
 
-import AbsUniType	( isPrimType, isLeakFreeType, getUniDataTyCon )
+import Type		( isPrimType, isLeakFreeType, getAppDataTyCon )
 import Bag		-- Bag operations
-import BasicLit		( mkMachInt, BasicLit(..), PrimKind )	-- ToDo: its use is ugly...
+import Literal		( mkMachInt, Literal(..) )	-- ToDo: its use is ugly...
 import CostCentre	( noCostCentre, CostCentre )
-import Id		( mkSysLocal, getIdUniType, isBottomingId
+import Id		( mkSysLocal, idType, isBottomingId
 			  IF_ATTACK_PRAGMAS(COMMA bottomIsGuaranteed)
 			)
-import IdEnv
 import Maybes		( Maybe(..), catMaybes )
 import Outputable	( isExported )
 import Pretty		-- debugging only!
-import SpecTyFuns	( mkSpecialisedCon )
+import SpecUtils	( mkSpecialisedCon )
 import SrcLoc		( SrcLoc, mkUnknownSrcLoc )
 import Util
 \end{code}
@@ -70,7 +65,7 @@ The business of this pass is to convert Core to Stg.  On the way:
 * 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'...} 
+* We convert	case x of {...; x' -> ...x'...}
 	to
 		case x of {...; _  -> ...x... }
 
@@ -89,7 +84,7 @@ environment, so we can just replace all occurrences of \tr{x}
 with \tr{y}.
 
 \begin{code}
-type StgEnv = IdEnv PlainStgAtom
+type StgEnv = IdEnv StgArg
 \end{code}
 
 No free/live variable information is pinned on in this pass; it's added
@@ -97,7 +92,7 @@ later.  For this pass
 we use @bOGUS_LVs@ and @bOGUS_FVs@ as placeholders.
 
 \begin{code}
-bOGUS_LVs :: PlainStgLiveVars
+bOGUS_LVs :: StgLiveVars
 bOGUS_LVs = panic "bOGUS_LVs" -- emptyUniqSet (used when pprTracing)
 
 bOGUS_FVs :: [Id]
@@ -105,29 +100,29 @@ bOGUS_FVs = panic "bOGUS_FVs" -- [] (ditto)
 \end{code}
 
 \begin{code}
-topCoreBindsToStg :: SplitUniqSupply	-- name supply
-		  -> [PlainCoreBinding]	-- input
-		  -> [PlainStgBinding]	-- output
+topCoreBindsToStg :: UniqSupply	-- name supply
+		  -> [CoreBinding]	-- input
+		  -> [StgBinding]	-- output
 
 topCoreBindsToStg us core_binds
-  = case (initSUs us (binds_to_stg nullIdEnv core_binds)) of
+  = case (initUs us (binds_to_stg nullIdEnv core_binds)) of
       (_, stuff) -> stuff
   where
-    binds_to_stg :: StgEnv -> [PlainCoreBinding] -> SUniqSM [PlainStgBinding]
+    binds_to_stg :: StgEnv -> [CoreBinding] -> UniqSM [StgBinding]
 
-    binds_to_stg env [] = returnSUs []
+    binds_to_stg env [] = returnUs []
     binds_to_stg env (b:bs)
-      = do_top_bind  env     b  `thenSUs` \ (new_b, new_env, float_binds) ->
-    	binds_to_stg new_env bs `thenSUs` \ new_bs ->
-    	returnSUs (bagToList float_binds ++ 	-- Literals
-		  new_b ++ 
-	          new_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@(CoRec pairs) 
+    do_top_bind env bind@(Rec pairs)
       = coreBindToStg env bind
 
-    do_top_bind env bind@(CoNonRec var rhs)
-      = coreBindToStg env bind		`thenSUs` \ (stg_binds, new_env, float_binds) ->
+    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)
@@ -136,27 +131,27 @@ topCoreBindsToStg us core_binds
 	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)] -> 
+	   [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 
+		let
 		  (extra_float_binds, rhs_body') = seek_liftable [] rhs_body
-		in 
-		returnSUs (extra_float_binds ++ 
+		in
+		returnUs (extra_float_binds ++
 			  [StgNonRec var (StgRhsClosure cc bi fvs u [] rhs_body')],
 			  new_env,
 			  float_binds)
 
-	   other -> returnSUs (stg_binds, 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 :: [PlainStgBinding] 	-- accumulator...
-		  -> PlainStgExpr	-- look for top-lev liftables
-		  -> ([PlainStgBinding], PlainStgExpr)	-- result
+    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
@@ -167,12 +162,12 @@ topCoreBindsToStg us core_binds
     --------------------
     is_liftable (StgNonRec binder (StgRhsClosure _ _ _ _ args body))
       = not (null args) -- it's manifestly a function...
-	|| isLeakFreeType [] (getIdUniType binder)
+	|| isLeakFreeType [] (idType binder)
 	|| is_whnf body
 	-- ToDo: use a decent manifestlyWHNF function for STG?
       where
-	is_whnf (StgConApp _ _ _) 	    = True
-	is_whnf (StgApp (StgVarAtom v) _ _) = isBottomingId v
+	is_whnf (StgCon _ _ _) 	    = True
+	is_whnf (StgApp (StgVarArg v) _ _) = isBottomingId v
 	is_whnf other 			    = False
 
     is_liftable (StgRec [(_, StgRhsClosure _ _ _ _ args body)])
@@ -189,13 +184,13 @@ topCoreBindsToStg us core_binds
 
 \begin{code}
 coreBindToStg :: StgEnv
-	      -> PlainCoreBinding
-	      -> SUniqSM ([PlainStgBinding],	-- Empty or singleton
+	      -> CoreBinding
+	      -> UniqSM ([StgBinding],	-- Empty or singleton
 		    	 StgEnv,		-- New envt
-			 Bag PlainStgBinding)	-- Floats
+			 Bag StgBinding)	-- Floats
 
-coreBindToStg env (CoNonRec binder rhs)
-  = coreRhsToStg env rhs	`thenSUs` \ (stg_rhs, rhs_binds) ->
+coreBindToStg env (NonRec binder rhs)
+  = coreRhsToStg env rhs	`thenUs` \ (stg_rhs, rhs_binds) ->
 
     let
 	-- Binds to return if RHS is trivial
@@ -205,29 +200,29 @@ coreBindToStg env (CoNonRec binder rhs)
 			[]				-- Discard it
     in
     case stg_rhs of
-      StgRhsClosure cc bi fvs upd [] (StgApp atom [] lvs) -> 	
+      StgRhsClosure cc bi fvs upd [] (StgApp atom [] lvs) ->
 		-- Trivial RHS, so augment envt, and ditch the binding
-		returnSUs (triv_binds, new_env, rhs_binds)
+		returnUs (triv_binds, new_env, rhs_binds)
 	   where
 		new_env = addOneToIdEnv env binder atom
-			  
-      StgRhsCon cc con_id [] -> 
+
+      StgRhsCon cc con_id [] ->
 		-- Trivial RHS, so augment envt, and ditch the binding
-		returnSUs (triv_binds, new_env, rhs_binds)
+		returnUs (triv_binds, new_env, rhs_binds)
 	   where
-		new_env = addOneToIdEnv env binder (StgVarAtom con_id)
+		new_env = addOneToIdEnv env binder (StgVarArg con_id)
 
       other -> 	-- Non-trivial RHS, so don't augment envt
-		returnSUs ([StgNonRec binder stg_rhs], env, rhs_binds)
+		returnUs ([StgNonRec binder stg_rhs], env, rhs_binds)
 
-coreBindToStg env (CoRec pairs)
+coreBindToStg env (Rec pairs)
   = -- NB: *** WE DO NOT CHECK FOR TRIV_BINDS in REC BIND ****
     -- (possibly ToDo)
     let
 	(binders, rhss) = unzip pairs
     in
-    mapAndUnzipSUs (coreRhsToStg env) rhss `thenSUs` \ (stg_rhss, rhs_binds) ->
-    returnSUs ([StgRec (binders `zip` stg_rhss)], env, unionManyBags rhs_binds)
+    mapAndUnzipUs (coreRhsToStg env) rhss `thenUs` \ (stg_rhss, rhs_binds) ->
+    returnUs ([StgRec (binders `zip` stg_rhss)], env, unionManyBags rhs_binds)
 \end{code}
 
 
@@ -238,28 +233,28 @@ coreBindToStg env (CoRec pairs)
 %************************************************************************
 
 \begin{code}
-coreRhsToStg :: StgEnv -> PlainCoreExpr -> SUniqSM (PlainStgRhs, Bag PlainStgBinding)
+coreRhsToStg :: StgEnv -> CoreExpr -> UniqSM (StgRhs, Bag StgBinding)
 
 coreRhsToStg env core_rhs
-  = coreExprToStg env core_rhs 	`thenSUs` \ (stg_expr, stg_binds) ->
+  = coreExprToStg env core_rhs 	`thenUs` \ (stg_expr, stg_binds) ->
 
     let stg_rhs = case stg_expr of
-		    StgLet (StgNonRec var1 rhs) (StgApp (StgVarAtom var2) [] _)
+		    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
 
-		    StgConApp con args _ -> StgRhsCon noCostCentre con args
+		    StgCon con args _ -> StgRhsCon noCostCentre con args
 
 		    other -> StgRhsClosure noCostCentre	-- No cost centre (ToDo?)
 					   stgArgOcc	-- safe
-				           bOGUS_FVs
-				           Updatable	-- Be pessimistic
-				           []
-				           stg_expr
+					   bOGUS_FVs
+					   Updatable	-- Be pessimistic
+					   []
+					   stg_expr
     in
-    returnSUs (stg_rhs, stg_binds)
+    returnUs (stg_rhs, stg_binds)
 \end{code}
 
 
@@ -282,46 +277,46 @@ tARGET_MIN_INT, tARGET_MAX_INT :: Integer
 tARGET_MIN_INT = -536870912
 tARGET_MAX_INT =  536870912
 
-litToStgAtom :: BasicLit -> SUniqSM (PlainStgAtom, Bag PlainStgBinding)
+litToStgArg :: Literal -> UniqSM (StgArg, Bag StgBinding)
 
-litToStgAtom (NoRepStr s)
-  = newStgVar stringTy 		`thenSUs` \ var ->
+litToStgArg (NoRepStr s)
+  = newStgVar stringTy 		`thenUs` \ var ->
     let
 	rhs = StgRhsClosure noCostCentre -- No cost centre (ToDo?)
 			    stgArgOcc	 -- safe
 			    bOGUS_FVs
-			    Updatable	 -- OLD: ReEntrant (see note below)
+			    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 
+-- 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 (StgVarAtom unpackCString2Id) 
-		     [StgLitAtom (MachStr s),
-		      StgLitAtom (mkMachInt (toInteger (_LENGTH_ s)))]
+		StgApp (StgVarArg unpackCString2Id)
+		     [StgLitArg (MachStr s),
+		      StgLitArg (mkMachInt (toInteger (_LENGTH_ s)))]
 		     bOGUS_LVs
 	      else
-		StgApp (StgVarAtom unpackCStringId) 
-		     [StgLitAtom (MachStr s)]
+		StgApp (StgVarArg unpackCStringId)
+		     [StgLitArg (MachStr s)]
 		     bOGUS_LVs
     in
-    returnSUs (StgVarAtom var, unitBag (StgNonRec var rhs))
+    returnUs (StgVarArg var, unitBag (StgNonRec var rhs))
   where
     is_NUL c = c == '\0'
 
-litToStgAtom (NoRepInteger i)
+litToStgArg (NoRepInteger i)
   -- extremely convenient to look out for a few very common
   -- Integer literals!
-  | i == 0    = returnSUs (StgVarAtom integerZeroId,     emptyBag)
-  | i == 1    = returnSUs (StgVarAtom integerPlusOneId,  emptyBag)
-  | i == 2    = returnSUs (StgVarAtom integerPlusTwoId,  emptyBag)
-  | i == (-1) = returnSUs (StgVarAtom integerMinusOneId, emptyBag)
+  | 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 integerTy 		`thenSUs` \ var ->
+  = newStgVar integerTy 		`thenUs` \ var ->
     let
 	rhs = StgRhsClosure noCostCentre -- No cost centre (ToDo?)
 			    stgArgOcc	 -- safe
@@ -330,31 +325,31 @@ litToStgAtom (NoRepInteger i)
 			    []		 -- No arguments
 			    val
 
-	val 
+	val
 	  | i > tARGET_MIN_INT && i < tARGET_MAX_INT
 	  =	-- Start from an Int
-	    StgPrimApp Int2IntegerOp [StgLitAtom (mkMachInt i)] bOGUS_LVs
+	    StgPrim Int2IntegerOp [StgLitArg (mkMachInt i)] bOGUS_LVs
 
 	  | otherwise
 	  = 	-- Start from a string
-	    StgPrimApp Addr2IntegerOp [StgLitAtom (MachStr (_PK_ (show i)))] bOGUS_LVs
+	    StgPrim Addr2IntegerOp [StgLitArg (MachStr (_PK_ (show i)))] bOGUS_LVs
     in
-    returnSUs (StgVarAtom var, unitBag (StgNonRec var rhs))
+    returnUs (StgVarArg var, unitBag (StgNonRec var rhs))
 
-litToStgAtom (NoRepRational r)
- = litToStgAtom (NoRepInteger (numerator   r))	`thenSUs` \ (num_atom,   binds1) ->
-   litToStgAtom (NoRepInteger (denominator r))	`thenSUs` \ (denom_atom, binds2) ->
-   newStgVar rationalTy			`thenSUs` \ var ->
+litToStgArg (NoRepRational r)
+ = litToStgArg (NoRepInteger (numerator   r))	`thenUs` \ (num_atom,   binds1) ->
+   litToStgArg (NoRepInteger (denominator r))	`thenUs` \ (denom_atom, binds2) ->
+   newStgVar rationalTy			`thenUs` \ var ->
    let
 	rhs = StgRhsCon noCostCentre	-- No cost centre (ToDo?)
-		        ratioDataCon	-- Constructor
+			ratioDataCon	-- Constructor
 			[num_atom, denom_atom]
    in
-   returnSUs (StgVarAtom var, binds1 `unionBags` 
+   returnUs (StgVarArg var, binds1 `unionBags`
 			   binds2 `unionBags`
 			   unitBag (StgNonRec var rhs))
 
-litToStgAtom other_lit = returnSUs (StgLitAtom other_lit, emptyBag)
+litToStgArg other_lit = returnUs (StgLitArg other_lit, emptyBag)
 \end{code}
 
 
@@ -365,19 +360,19 @@ litToStgAtom other_lit = returnSUs (StgLitAtom other_lit, emptyBag)
 %************************************************************************
 
 \begin{code}
-coreAtomToStg :: StgEnv -> PlainCoreAtom -> SUniqSM (PlainStgAtom, Bag PlainStgBinding)
+coreAtomToStg :: StgEnv -> CoreArg -> UniqSM (StgArg, Bag StgBinding)
 
-coreAtomToStg env (CoVarAtom var) = returnSUs (stgLookup env var, emptyBag)
-coreAtomToStg env (CoLitAtom lit) = litToStgAtom lit
+coreAtomToStg env (VarArg var) = returnUs (stgLookup env var, emptyBag)
+coreAtomToStg env (LitArg lit) = litToStgArg lit
 \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 -> PlainStgAtom
+stgLookup :: StgEnv -> Id -> StgArg
 
 stgLookup env var = case (lookupIdEnv env var) of
-		      Nothing   -> StgVarAtom var
+		      Nothing   -> StgVarArg var
 		      Just atom -> atom
 \end{code}
 
@@ -388,29 +383,29 @@ stgLookup env var = case (lookupIdEnv env var) of
 %************************************************************************
 
 \begin{code}
-coreExprToStg :: StgEnv 
-	      -> PlainCoreExpr 
-	      -> SUniqSM (PlainStgExpr,		-- Result
-			 Bag PlainStgBinding)	-- Float these to top level
+coreExprToStg :: StgEnv
+	      -> CoreExpr
+	      -> UniqSM (StgExpr,		-- Result
+			 Bag StgBinding)	-- Float these to top level
 \end{code}
 
 \begin{code}
-coreExprToStg env (CoLit lit) 
-  = litToStgAtom lit	`thenSUs` \ (atom, binds) ->
-    returnSUs (StgApp atom [] bOGUS_LVs, binds)
+coreExprToStg env (Lit lit)
+  = litToStgArg lit	`thenUs` \ (atom, binds) ->
+    returnUs (StgApp atom [] bOGUS_LVs, binds)
 
-coreExprToStg env (CoVar var)
-  = returnSUs (StgApp (stgLookup env var) [] bOGUS_LVs, emptyBag)
+coreExprToStg env (Var var)
+  = returnUs (StgApp (stgLookup env var) [] bOGUS_LVs, emptyBag)
 
-coreExprToStg env (CoCon con types args)
-  = mapAndUnzipSUs (coreAtomToStg env) args `thenSUs` \ (stg_atoms, stg_binds) ->
-    returnSUs (StgConApp spec_con stg_atoms bOGUS_LVs, unionManyBags stg_binds)
+coreExprToStg env (Con con types args)
+  = mapAndUnzipUs (coreAtomToStg env) args `thenUs` \ (stg_atoms, stg_binds) ->
+    returnUs (StgCon spec_con stg_atoms bOGUS_LVs, unionManyBags stg_binds)
   where
     spec_con = mkSpecialisedCon con types
 
-coreExprToStg env (CoPrim op tys args)
-  = mapAndUnzipSUs (coreAtomToStg env) args `thenSUs` \ (stg_atoms, stg_binds) ->
-    returnSUs (StgPrimApp op stg_atoms bOGUS_LVs, unionManyBags stg_binds)
+coreExprToStg env (Prim op tys args)
+  = mapAndUnzipUs (coreAtomToStg env) args `thenUs` \ (stg_atoms, stg_binds) ->
+    returnUs (StgPrim op stg_atoms bOGUS_LVs, unionManyBags stg_binds)
 \end{code}
 
 %************************************************************************
@@ -433,17 +428,26 @@ coreExprToStg env (CoTyApp expr  ty)   = coreExprToStg env expr
 %************************************************************************
 
 \begin{code}
-coreExprToStg env expr@(CoLam binders body) 
-  = coreExprToStg env body		`thenSUs` \ (stg_body, binds) ->
-    newStgVar (typeOfCoreExpr expr)	`thenSUs` \ var ->
-    returnSUs (StgLet (StgNonRec var (StgRhsClosure noCostCentre
-						   stgArgOcc
-						   bOGUS_FVs
-						   ReEntrant 	-- binders is non-empty
-						   binders 
-						   stg_body))
-		     (StgApp (StgVarAtom var) [] bOGUS_LVs),
-	      binds)
+coreExprToStg env expr@(Lam _ _)
+  = coreExprToStg env body		`thenUs` \ (stg_body, binds) ->
+    newStgVar (coreExprType expr)	`thenUs` \ var ->
+    returnUs
+      (StgLet (StgNonRec var (StgRhsClosure noCostCentre
+		 	      stgArgOcc
+			      bOGUS_FVs
+			      ReEntrant 	-- binders is non-empty
+			      binders
+			      stg_body))
+       (StgApp (StgVarArg var) [] bOGUS_LVs),
+       binds)
+  where
+    (binders,body) = collect expr
+
+    -- Collect lambda-bindings, discarding type abstractions and applications
+    collect (Lam x e)   = (x:binders, body) where (binders,body) = collect e
+    collect (CoTyLam _ e) = collect e
+    collect (CoTyApp e _) = collect e
+    collect body	  = ([], body)
 \end{code}
 
 %************************************************************************
@@ -453,18 +457,18 @@ coreExprToStg env expr@(CoLam binders body)
 %************************************************************************
 
 \begin{code}
-coreExprToStg env expr@(CoApp _ _)
+coreExprToStg env expr@(App _ _)
   = 	-- Deal with the arguments
-    mapAndUnzipSUs (coreAtomToStg env) args `thenSUs` \ (stg_args, arg_binds) ->
+    mapAndUnzipUs (coreAtomToStg env) args `thenUs` \ (stg_args, arg_binds) ->
 
 	-- Now deal with the function
-    case fun of 
-      CoVar fun_id -> returnSUs (StgApp (stgLookup env fun_id) stg_args bOGUS_LVs, 
+    case fun of
+      Var fun_id -> returnUs (StgApp (stgLookup env fun_id) stg_args bOGUS_LVs,
 				unionManyBags arg_binds)
 
       other ->	-- A non-variable applied to things; better let-bind it.
-		newStgVar (typeOfCoreExpr fun)	`thenSUs` \ fun_id ->
-		coreExprToStg env fun		`thenSUs` \ (stg_fun, fun_binds) ->
+		newStgVar (coreExprType fun)	`thenUs` \ fun_id ->
+		coreExprToStg env fun		`thenUs` \ (stg_fun, fun_binds) ->
 		let
 		   fun_rhs = StgRhsClosure noCostCentre	-- No cost centre (ToDo?)
 					   stgArgOcc
@@ -473,16 +477,17 @@ coreExprToStg env expr@(CoApp _ _)
 					   []
 					   stg_fun
 		in
-		returnSUs (StgLet (StgNonRec fun_id fun_rhs)
-			   	  (StgApp (StgVarAtom fun_id) stg_args bOGUS_LVs),
-			   unionManyBags arg_binds `unionBags` 
+		returnUs (StgLet (StgNonRec fun_id fun_rhs)
+			   	  (StgApp (StgVarArg fun_id) stg_args bOGUS_LVs),
+			   unionManyBags arg_binds `unionBags`
 			   fun_binds)
   where
     (fun,args) = collect_args expr []
 
-	-- Collect arguments, discarding type applications
-    collect_args (CoApp fun arg) args = collect_args fun (arg:args)
-    collect_args (CoTyApp e t)   args = collect_args e args
+    -- Collect arguments, discarding type abstractions and applications
+    collect_args (App fun arg) args = collect_args fun (arg:args)
+    collect_args (CoTyLam _ e)   args = collect_args e args
+    collect_args (CoTyApp e _)   args = collect_args e args
     collect_args fun             args = (fun, args)
 \end{code}
 
@@ -512,12 +517,12 @@ to
 
 \begin{code}
 
-coreExprToStg env (CoCase discrim@(CoPrim op tys args) alts)
+coreExprToStg env (Case discrim@(Prim op tys args) alts)
   | funnyParallelOp op =
-    getSUnique			`thenSUs` \ uniq ->
-    coreExprToStg env discrim	`thenSUs` \ (stg_discrim, discrim_binds) ->
-    alts_to_stg alts		`thenSUs` \ (stg_alts, alts_binds) ->
-    returnSUs (
+    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
@@ -531,22 +536,22 @@ coreExprToStg env (CoCase discrim@(CoPrim op tys args) alts)
     funnyParallelOp ForkOp = True
     funnyParallelOp _      = False
 
-    discrim_ty = typeOfCoreExpr discrim
+    discrim_ty = coreExprType discrim
 
-    alts_to_stg (CoPrimAlts _ (CoBindDefault binder rhs))
-      =	coreExprToStg env rhs  `thenSUs` \ (stg_rhs, rhs_binds) ->
-        let 
-            stg_deflt = StgBindDefault binder False stg_rhs
-        in
-	    returnSUs (StgPrimAlts discrim_ty [] stg_deflt, rhs_binds)
+    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 (CoCase discrim alts)
-  = coreExprToStg env discrim		`thenSUs` \ (stg_discrim, discrim_binds) ->
-    alts_to_stg discrim alts	`thenSUs` \ (stg_alts, alts_binds) ->
-    getSUnique				`thenSUs` \ uniq ->
-    returnSUs (
+coreExprToStg env (Case discrim alts)
+  = coreExprToStg env discrim		`thenUs` \ (stg_discrim, discrim_binds) ->
+    alts_to_stg discrim alts	`thenUs` \ (stg_alts, alts_binds) ->
+    getUnique				`thenUs` \ uniq ->
+    returnUs (
 	StgCase stg_discrim
 		bOGUS_LVs
 		bOGUS_LVs
@@ -555,62 +560,42 @@ coreExprToStg env (CoCase discrim alts)
 	discrim_binds `unionBags` alts_binds
     )
   where
-    discrim_ty		    = typeOfCoreExpr discrim
-    (_, discrim_ty_args, _) = getUniDataTyCon discrim_ty
+    discrim_ty		    = coreExprType discrim
+    (_, discrim_ty_args, _) = getAppDataTyCon discrim_ty
 
-    alts_to_stg discrim (CoAlgAlts alts deflt)
-      = default_to_stg discrim deflt		`thenSUs` \ (stg_deflt, deflt_binds) ->
-	mapAndUnzipSUs boxed_alt_to_stg alts	`thenSUs` \ (stg_alts, alts_binds)  ->
-	returnSUs (StgAlgAlts discrim_ty stg_alts stg_deflt,
+    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)
       where
 	boxed_alt_to_stg (con, bs, rhs)
-	  = coreExprToStg env rhs    `thenSUs` \ (stg_rhs, rhs_binds) ->
-	    returnSUs ((spec_con, bs, [ True | b <- bs ]{-bogus use mask-}, stg_rhs),
+	  = coreExprToStg env rhs    `thenUs` \ (stg_rhs, rhs_binds) ->
+	    returnUs ((spec_con, bs, [ True | b <- bs ]{-bogus use mask-}, stg_rhs),
 		       rhs_binds)
 	  where
 	    spec_con = mkSpecialisedCon con discrim_ty_args
 
-    alts_to_stg discrim (CoPrimAlts alts deflt)
-      = default_to_stg discrim deflt		`thenSUs` \ (stg_deflt,deflt_binds) ->
-	mapAndUnzipSUs unboxed_alt_to_stg alts	`thenSUs` \ (stg_alts, alts_binds)  ->
-	returnSUs (StgPrimAlts discrim_ty stg_alts stg_deflt,
+    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)
       where
 	unboxed_alt_to_stg (lit, rhs)
-	  = coreExprToStg env rhs    `thenSUs` \ (stg_rhs, rhs_binds) ->
-	    returnSUs ((lit, stg_rhs), rhs_binds)
-
-#ifdef DPH
-    alts_to_stg (CoParAlgAlts tycon ctxt params alts deflt)
-      = default_to_stg deflt	    `thenSUs` \ stg_deflt ->
-	mapSUs boxed_alt_to_stg alts `thenSUs` \ stg_alts  ->
-	returnSUs (StgParAlgAlts discrim_ty ctxt params stg_alts stg_deflt)
-      where
-	boxed_alt_to_stg (con, rhs)
-	  = coreExprToStg env rhs    `thenSUs` \ stg_rhs ->
-	    returnSUs (con, stg_rhs)
-
-    alts_to_stg (CoParPrimAlts tycon ctxt alts deflt)
-      = default_to_stg deflt	      `thenSUs` \ stg_deflt ->
-	mapSUs unboxed_alt_to_stg alts `thenSUs` \ stg_alts  ->
-	returnSUs (StgParPrimAlts discrim_ty ctxt stg_alts stg_deflt)
-      where
-	unboxed_alt_to_stg (lit, rhs)
-	  = coreExprToStg env rhs    `thenSUs` \ stg_rhs ->
-	    returnSUs (lit, stg_rhs)
-#endif {- Data Parallel Haskell -}
+	  = coreExprToStg env rhs    `thenUs` \ (stg_rhs, rhs_binds) ->
+	    returnUs ((lit, stg_rhs), rhs_binds)
 
-    default_to_stg discrim CoNoDefault
-      = returnSUs (StgNoDefault, emptyBag)
+    default_to_stg discrim NoDefault
+      = returnUs (StgNoDefault, emptyBag)
 
-    default_to_stg discrim (CoBindDefault binder rhs)
-      = coreExprToStg new_env rhs    `thenSUs` \ (stg_rhs, rhs_binds) ->
-	returnSUs (StgBindDefault binder True{-used? no it is lying-} stg_rhs,
+    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'...} 
+	-- We convert	case x of {...; x' -> ...x'...}
 	--	to
 	--		case x of {...; _  -> ...x... }
 	--
@@ -619,7 +604,7 @@ coreExprToStg env (CoCase discrim alts)
 	-- default binder to the scrutinee.
 	--
 	new_env = case discrim of
-		    CoVar v -> addOneToIdEnv env binder (stgLookup env v)
+		    Var v -> addOneToIdEnv env binder (stgLookup env v)
 		    other   -> env
 \end{code}
 
@@ -630,10 +615,10 @@ coreExprToStg env (CoCase discrim alts)
 %************************************************************************
 
 \begin{code}
-coreExprToStg env (CoLet bind body)
-  = coreBindToStg env     bind   `thenSUs` \ (stg_binds, new_env, float_binds1) ->
-    coreExprToStg new_env body   `thenSUs` \ (stg_body, float_binds2) ->
-    returnSUs (mkStgLets stg_binds stg_body, float_binds1 `unionBags` float_binds2)
+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)
 \end{code}
 
 
@@ -645,50 +630,11 @@ coreExprToStg env (CoLet bind body)
 
 Covert core @scc@ expression directly to STG @scc@ expression.
 \begin{code}
-coreExprToStg env (CoSCC cc expr)
-  = coreExprToStg env expr   `thenSUs` \ (stg_expr, binds) ->
-    returnSUs (StgSCC (typeOfCoreExpr expr) cc stg_expr, binds)
+coreExprToStg env (SCC cc expr)
+  = coreExprToStg env expr   `thenUs` \ (stg_expr, binds) ->
+    returnUs (StgSCC (coreExprType expr) cc stg_expr, binds)
 \end{code}
 
-%************************************************************************
-%*									*
-\subsubsection[coreToStg-dataParallel]{Data Parallel expressions}
-%*									*
-%************************************************************************
-\begin{code}
-#ifdef DPH
-coreExprToStg env (_, AnnCoParCon con ctxt types args)
-  = mapAndUnzipSUs (arg2stg env) args	`thenSUs` \ (stg_atoms, stg_binds) ->
-    returnSUs (mkStgLets	(catMaybes stg_binds)
-	                (StgParConApp con ctxt stg_atoms bOGUS_LVs))
-
-coreExprToStg env (_,AnnCoParComm ctxt expr comm)
-  = coreExprToStg env expr		`thenSUs` \ stg_expr             ->
-    annComm_to_stg comm			`thenSUs` \ (stg_comm,stg_binds) ->
-    returnSUs (mkStgLets (catMaybes stg_binds)
-		        (StgParComm ctxt stg_expr stg_comm))
-    ))
-  where
-    annComm_to_stg (AnnCoParSend args)
-      = mapAndUnzipSUs (arg2stg env) args `thenSUs` \ (stg_atoms, stg_binds) ->
-        returnSUs (StgParSend stg_atoms,stg_binds)
-
-    annComm_to_stg (AnnCoParFetch args)
-      = mapAndUnzipSUs (arg2stg env) args `thenSUs` \ (stg_atoms, stg_binds) ->
-        returnSUs (StgParFetch stg_atoms,stg_binds)
-
-    annComm_to_stg (AnnCoToPodized)
-      = returnSUs (StgToPodized,[])
-    annComm_to_stg (AnnCoFromPodized)
-      = returnSUs (StgFromPodized,[])
-#endif {- Data Parallel Haskell -}
-\end{code}
-
-\begin{code}
-#ifdef DEBUG
-coreExprToStg env other = panic "coreExprToStg: it really failed here"
-#endif
-\end{code}
 
 %************************************************************************
 %*									*
@@ -700,16 +646,16 @@ Utilities.
 
 Invent a fresh @Id@:
 \begin{code}
-newStgVar :: UniType -> SUniqSM Id
+newStgVar :: Type -> UniqSM Id
 newStgVar ty
- = getSUnique			`thenSUs` \ uniq ->
-   returnSUs (mkSysLocal SLIT("stg") uniq ty mkUnknownSrcLoc)
+ = getUnique			`thenUs` \ uniq ->
+   returnUs (mkSysLocal SLIT("stg") uniq ty mkUnknownSrcLoc)
 \end{code}
 
 \begin{code}
-mkStgLets ::   [PlainStgBinding]
-	    -> PlainStgExpr	-- body of let
-	    -> PlainStgExpr
+mkStgLets ::   [StgBinding]
+	    -> StgExpr	-- body of let
+	    -> StgExpr
 
 mkStgLets binds body = foldr StgLet body binds
 \end{code}
diff --git a/ghc/compiler/stgSyn/StgFuns.hi b/ghc/compiler/stgSyn/StgFuns.hi
deleted file mode 100644
index 01b2999bb1..0000000000
--- a/ghc/compiler/stgSyn/StgFuns.hi
+++ /dev/null
@@ -1,6 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface StgFuns where
-import Id(Id)
-import StgSyn(StgRhs)
-mapStgBindeesRhs :: (Id -> Id) -> StgRhs Id Id -> StgRhs Id Id
-
diff --git a/ghc/compiler/stgSyn/StgFuns.lhs b/ghc/compiler/stgSyn/StgFuns.lhs
deleted file mode 100644
index 8dd3f877c2..0000000000
--- a/ghc/compiler/stgSyn/StgFuns.lhs
+++ /dev/null
@@ -1,93 +0,0 @@
-x%
-% (c) The GRASP/AQUA Project, Glasgow University, 1993-1995
-%
-\section[StgFuns]{Utility functions for @STG@ programs}
-
-\begin{code}
-#include "HsVersions.h"
-
-module StgFuns (
-	mapStgBindeesRhs
-    ) where
-
-import StgSyn
-
-import UniqSet
-import Unique
-
-import Util
-\end{code}
-
-This utility function simply applies the given function to every
-bindee in the program.
-
-\begin{code}
-mapStgBindeesBind :: (Id -> Id) -> PlainStgBinding -> PlainStgBinding
-
-mapStgBindeesBind fn (StgNonRec b rhs) = StgNonRec b (mapStgBindeesRhs fn rhs)
-mapStgBindeesBind fn (StgRec pairs)    = StgRec [ (b, mapStgBindeesRhs fn r) | (b, r) <- pairs ]
-
-------------------
-mapStgBindeesRhs :: (Id -> Id) -> PlainStgRhs -> PlainStgRhs
-
-mapStgBindeesRhs fn (StgRhsClosure cc bi fvs u args expr)
-  = StgRhsClosure 
-	cc bi 
-	(map fn fvs) 
-	u 
-	(map fn args) 
-	(mapStgBindeesExpr fn expr)
-
-mapStgBindeesRhs fn (StgRhsCon cc con atoms)
-  = StgRhsCon cc con (map (mapStgBindeesAtom fn) atoms)
-
-------------------
-mapStgBindeesExpr :: (Id -> Id) -> PlainStgExpr -> PlainStgExpr
-
-mapStgBindeesExpr fn (StgApp f args lvs)
-  = StgApp (mapStgBindeesAtom fn f) 
-	   (map (mapStgBindeesAtom fn) args) 
-	   (mapUniqSet fn lvs)
-
-mapStgBindeesExpr fn (StgConApp con atoms lvs)
-  = StgConApp con (map (mapStgBindeesAtom fn) atoms) (mapUniqSet fn lvs)
-
-mapStgBindeesExpr fn (StgPrimApp op atoms lvs)
-  = StgPrimApp op (map (mapStgBindeesAtom fn) atoms) (mapUniqSet fn lvs)
-
-mapStgBindeesExpr fn (StgLet bind expr)
-  = StgLet (mapStgBindeesBind fn bind) (mapStgBindeesExpr fn expr)
-
-mapStgBindeesExpr fn (StgLetNoEscape lvs rhss_lvs bind body)
-  = StgLetNoEscape (mapUniqSet fn lvs) (mapUniqSet fn rhss_lvs)
-		   (mapStgBindeesBind fn bind) (mapStgBindeesExpr fn body)
-
-mapStgBindeesExpr fn (StgSCC ty label expr)
-  = StgSCC ty label (mapStgBindeesExpr fn expr)
-
-mapStgBindeesExpr fn (StgCase expr lvs1 lvs2 uniq alts)
-  = StgCase (mapStgBindeesExpr fn expr)
-	    (mapUniqSet fn lvs1)
-	    (mapUniqSet fn lvs2)
-	    uniq
-	    (mapStgBindeesAlts alts)
-  where
-    mapStgBindeesAlts (StgAlgAlts ty alts deflt)
-      = StgAlgAlts ty (map mapStgBindeesBoxed_alt alts) (mapStgBindeesDeflt deflt)
-      where
-	mapStgBindeesBoxed_alt (c,ps,use_mask,expr) = (c,ps,use_mask,mapStgBindeesExpr fn expr)
-
-    mapStgBindeesAlts (StgPrimAlts ty alts deflt)
-      = StgPrimAlts ty (map mapStgBindeesunboxed_alt alts) (mapStgBindeesDeflt deflt)
-      where
-	mapStgBindeesunboxed_alt (l,expr) = (l,mapStgBindeesExpr fn expr)
-
-    mapStgBindeesDeflt StgNoDefault		    = StgNoDefault
-    mapStgBindeesDeflt (StgBindDefault b used expr) = StgBindDefault b used (mapStgBindeesExpr fn expr)
-
-------------------
-mapStgBindeesAtom :: (Id -> Id) -> PlainStgAtom -> PlainStgAtom
-
-mapStgBindeesAtom fn a@(StgLitAtom _)	= a
-mapStgBindeesAtom fn a@(StgVarAtom id)  = StgVarAtom (fn id)
-\end{code}
diff --git a/ghc/compiler/stgSyn/StgLint.hi b/ghc/compiler/stgSyn/StgLint.hi
deleted file mode 100644
index 3587a1e281..0000000000
--- a/ghc/compiler/stgSyn/StgLint.hi
+++ /dev/null
@@ -1,12 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface StgLint where
-import CmdLineOpts(GlobalSwitch)
-import Id(Id)
-import Pretty(PprStyle)
-import StgSyn(PlainStgBinding(..), StgBinding, StgRhs)
-data Id 
-data PprStyle 
-type PlainStgBinding = StgBinding Id Id
-data StgBinding a b 
-lintStgBindings :: PprStyle -> [Char] -> [StgBinding Id Id] -> [StgBinding Id Id]
-
diff --git a/ghc/compiler/stgSyn/StgLint.lhs b/ghc/compiler/stgSyn/StgLint.lhs
index 9f1e5ba651..29faa874ce 100644
--- a/ghc/compiler/stgSyn/StgLint.lhs
+++ b/ghc/compiler/stgSyn/StgLint.lhs
@@ -6,25 +6,17 @@
 \begin{code}
 #include "HsVersions.h"
 
-module StgLint (
-	lintStgBindings,
-	
-	PprStyle, StgBinding, PlainStgBinding(..), Id
-    ) where
+module StgLint ( lintStgBindings ) where
 
-IMPORT_Trace
-
-import AbsPrel		( typeOfPrimOp, mkFunTy, PrimOp(..), PrimKind
+import PrelInfo		( primOpType, mkFunTy, PrimOp(..), PrimRep
 			  IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
 			  IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
 			)
-import AbsUniType
+import Type
 import Bag
-import BasicLit		( typeOfBasicLit, BasicLit )
-import Id		( getIdUniType, isNullaryDataCon, isDataCon,
-			  isBottomingId,
-			  getInstantiatedDataConSig, Id
-			  IF_ATTACK_PRAGMAS(COMMA bottomIsGuaranteed)
+import Literal		( literalType, Literal )
+import Id		( idType, isDataCon,
+			  getInstantiatedDataConSig
 			)
 import Maybes
 import Outputable
@@ -37,7 +29,7 @@ import Util
 infixr 9 `thenL`, `thenL_`, `thenMaybeL`, `thenMaybeL_`
 \end{code}
 
-Checks for 
+Checks for
 	(a) *some* type errors
 	(b) locally-defined variables used but not defined
 
@@ -50,7 +42,7 @@ Checks for
 @lintStgBindings@ is the top-level interface function.
 
 \begin{code}
-lintStgBindings :: PprStyle -> String -> [PlainStgBinding] -> [PlainStgBinding]
+lintStgBindings :: PprStyle -> String -> [StgBinding] -> [StgBinding]
 
 lintStgBindings sty whodunnit binds
   = BSCC("StgLint")
@@ -64,10 +56,10 @@ lintStgBindings sty whodunnit binds
 			ppStr "*** End of Offense ***"])
     ESCC
   where
-    lint_binds :: [PlainStgBinding] -> LintM ()
+    lint_binds :: [StgBinding] -> LintM ()
 
     lint_binds [] = returnL ()
-    lint_binds (bind:binds) 
+    lint_binds (bind:binds)
       = lintStgBinds bind 		`thenL` \ binders ->
 	addInScopeVars binders (
 	    lint_binds binds
@@ -76,21 +68,21 @@ lintStgBindings sty whodunnit binds
 
 
 \begin{code}
-lintStgAtom :: PlainStgAtom -> LintM (Maybe UniType)
+lintStgArg :: StgArg -> LintM (Maybe Type)
 
-lintStgAtom (StgLitAtom lit)       = returnL (Just (typeOfBasicLit lit))
-lintStgAtom a@(StgVarAtom v)
+lintStgArg (StgLitArg lit)       = returnL (Just (literalType lit))
+lintStgArg a@(StgVarArg v)
   = checkInScope v	`thenL_`
-    returnL (Just (getIdUniType v))
+    returnL (Just (idType v))
 \end{code}
 
 \begin{code}
-lintStgBinds :: PlainStgBinding -> LintM [Id]		-- Returns the binders
+lintStgBinds :: StgBinding -> LintM [Id]		-- Returns the binders
 lintStgBinds (StgNonRec binder rhs)
   = lint_binds_help (binder,rhs) 	`thenL_`
     returnL [binder]
 
-lintStgBinds (StgRec pairs) 
+lintStgBinds (StgRec pairs)
   = addInScopeVars binders (
 	mapL lint_binds_help pairs `thenL_`
 	returnL binders
@@ -106,68 +98,68 @@ lint_binds_help (binder, rhs)
 	-- Check match to RHS type
 	(case maybe_rhs_ty of
 	  Nothing     -> returnL ()
-	  Just rhs_ty -> checkTys (getIdUniType binder) 
-				   rhs_ty 
+	  Just rhs_ty -> checkTys (idType binder)
+				   rhs_ty
 				   (mkRhsMsg binder rhs_ty)
-	)			`thenL_` 
+	)			`thenL_`
 
 	returnL ()
     )
 \end{code}
 
 \begin{code}
-lintStgRhs :: PlainStgRhs -> LintM (Maybe UniType)
+lintStgRhs :: StgRhs -> LintM (Maybe Type)
 
 lintStgRhs (StgRhsClosure _ _ _ _ binders expr)
   = addLoc (LambdaBodyOf binders) (
     addInScopeVars binders (
 	lintStgExpr expr   `thenMaybeL` \ body_ty ->
-	returnL (Just (foldr (mkFunTy . getIdUniType) body_ty binders))
+	returnL (Just (foldr (mkFunTy . idType) body_ty binders))
     ))
 
 lintStgRhs (StgRhsCon _ con args)
-  = mapMaybeL lintStgAtom args	`thenL` \ maybe_arg_tys ->
+  = mapMaybeL lintStgArg args	`thenL` \ maybe_arg_tys ->
     case maybe_arg_tys of
       Nothing 	    -> returnL Nothing
       Just arg_tys  -> checkFunApp con_ty arg_tys (mkRhsConMsg con_ty arg_tys)
   where
-    con_ty = getIdUniType con
+    con_ty = idType con
 \end{code}
 
 \begin{code}
-lintStgExpr :: PlainStgExpr -> LintM (Maybe UniType)	-- Nothing if error found
+lintStgExpr :: StgExpr -> LintM (Maybe Type)	-- Nothing if error found
 
 lintStgExpr e@(StgApp fun args _)
-  = lintStgAtom fun		`thenMaybeL` \ fun_ty  ->
-    mapMaybeL lintStgAtom args	`thenL`      \ maybe_arg_tys ->
+  = lintStgArg fun		`thenMaybeL` \ fun_ty  ->
+    mapMaybeL lintStgArg args	`thenL`      \ maybe_arg_tys ->
     case maybe_arg_tys of
       Nothing 	    -> returnL Nothing
       Just arg_tys  -> checkFunApp fun_ty arg_tys (mkFunAppMsg fun_ty arg_tys e)
 
-lintStgExpr e@(StgConApp con args _)
-  = mapMaybeL lintStgAtom args	`thenL` \ maybe_arg_tys ->
+lintStgExpr e@(StgCon con args _)
+  = mapMaybeL lintStgArg args	`thenL` \ maybe_arg_tys ->
     case maybe_arg_tys of
       Nothing 	    -> returnL Nothing
       Just arg_tys  -> checkFunApp con_ty arg_tys (mkFunAppMsg con_ty arg_tys e)
   where
-    con_ty = getIdUniType con
+    con_ty = idType con
 
-lintStgExpr e@(StgPrimApp op args _)
-  = mapMaybeL lintStgAtom args	`thenL` \ maybe_arg_tys ->
+lintStgExpr e@(StgPrim op args _)
+  = mapMaybeL lintStgArg args	`thenL` \ maybe_arg_tys ->
     case maybe_arg_tys of
       Nothing      -> returnL Nothing
       Just arg_tys -> checkFunApp op_ty arg_tys (mkFunAppMsg op_ty arg_tys e)
   where
-    op_ty = typeOfPrimOp op
+    op_ty = primOpType op
 
-lintStgExpr (StgLet binds body)	
+lintStgExpr (StgLet binds body)
   = lintStgBinds binds		`thenL` \ binders ->
     addLoc (BodyOfLetRec binders) (
     addInScopeVars binders (
 	lintStgExpr body
     ))
 
-lintStgExpr (StgLetNoEscape _ _ binds body)	
+lintStgExpr (StgLetNoEscape _ _ binds body)
   = lintStgBinds binds		`thenL` \ binders ->
     addLoc (BodyOfLetRec binders) (
     addInScopeVars binders (
@@ -180,7 +172,7 @@ lintStgExpr e@(StgCase scrut _ _ _ alts)
   = lintStgExpr scrut		`thenMaybeL` \ _ ->
 
 	-- Check that it is a data type
-    case getUniDataTyCon_maybe scrut_ty of
+    case maybeDataTyCon scrut_ty of
       Nothing -> addErrL (mkCaseDataConMsg e)	`thenL_`
 		 returnL Nothing
       Just (tycon, _, _)
@@ -193,20 +185,20 @@ lintStgExpr e@(StgCase scrut _ _ _ alts)
 \end{code}
 
 \begin{code}
-lintStgAlts :: PlainStgCaseAlternatives
-	     -> UniType 		-- Type of scrutinee
+lintStgAlts :: StgCaseAlts
+	     -> Type 		-- Type of scrutinee
 	     -> TyCon			-- TyCon pinned on the case
-	     -> LintM (Maybe UniType)	-- Type of alternatives
+	     -> LintM (Maybe Type)	-- Type of alternatives
 
 lintStgAlts alts scrut_ty case_tycon
   = (case alts of
-	 StgAlgAlts _ alg_alts deflt ->  
+	 StgAlgAlts _ alg_alts deflt ->
 	   chk_non_abstract_type case_tycon	`thenL_`
 	   mapL (lintAlgAlt scrut_ty) alg_alts 	`thenL` \ maybe_alt_tys ->
 	   lintDeflt deflt scrut_ty		`thenL` \ maybe_deflt_ty ->
 	   returnL (maybe_deflt_ty : maybe_alt_tys)
 
-	 StgPrimAlts _ prim_alts deflt -> 
+	 StgPrimAlts _ prim_alts deflt ->
 	   mapL (lintPrimAlt scrut_ty) prim_alts `thenL` \ maybe_alt_tys ->
 	   lintDeflt deflt scrut_ty		 `thenL` \ maybe_deflt_ty ->
 	   returnL (maybe_deflt_ty : maybe_alt_tys)
@@ -226,15 +218,15 @@ lintStgAlts alts scrut_ty case_tycon
 	  Just  _ -> returnL () -- that's cool
 
 lintAlgAlt scrut_ty (con, args, _, rhs)
-  = (case getUniDataTyCon_maybe scrut_ty of
-      Nothing -> 
+  = (case maybeDataTyCon scrut_ty of
+      Nothing ->
 	 addErrL (mkAlgAltMsg1 scrut_ty)
       Just (tycon, tys_applied, cons) ->
 	 let
 	   (_, arg_tys, _) = getInstantiatedDataConSig con tys_applied
 	 in
 	 checkL (con `elem` cons) (mkAlgAltMsg2 scrut_ty con) `thenL_`
-	 checkL (length arg_tys == length args) (mkAlgAltMsg3 con args)	
+	 checkL (length arg_tys == length args) (mkAlgAltMsg3 con args)
 								 `thenL_`
 	 mapL check (arg_tys `zipEqual` args)			 `thenL_`
 	 returnL ()
@@ -243,7 +235,7 @@ lintAlgAlt scrut_ty (con, args, _, rhs)
 	 lintStgExpr rhs
     )
   where
-    check (ty, arg) = checkTys ty (getIdUniType arg) (mkAlgAltMsg4 ty arg)
+    check (ty, arg) = checkTys ty (idType arg) (mkAlgAltMsg4 ty arg)
 
     -- elem: yes, the elem-list here can sometimes be long-ish,
     -- but as it's use-once, probably not worth doing anything different
@@ -252,12 +244,12 @@ lintAlgAlt scrut_ty (con, args, _, rhs)
     elem x (y:ys)   = x==y || elem x ys
 
 lintPrimAlt scrut_ty alt@(lit,rhs)
- = checkTys (typeOfBasicLit lit) scrut_ty (mkPrimAltMsg alt)	`thenL_`
+ = checkTys (literalType lit) scrut_ty (mkPrimAltMsg alt)	`thenL_`
    lintStgExpr rhs
-   
+
 lintDeflt StgNoDefault scrut_ty = returnL Nothing
-lintDeflt deflt@(StgBindDefault binder _ rhs) scrut_ty 
-  = checkTys (getIdUniType binder) scrut_ty (mkDefltMsg deflt)	`thenL_`
+lintDeflt deflt@(StgBindDefault binder _ rhs) scrut_ty
+  = checkTys (idType binder) scrut_ty (mkDefltMsg deflt)	`thenL_`
     addInScopeVars [binder] (
 	lintStgExpr rhs
     )
@@ -300,7 +292,7 @@ pp_binders sty bs
   = ppInterleave ppComma (map pp_binder bs)
   where
     pp_binder b
-      = ppCat [ppr sty b, ppStr "::", ppr sty (getIdUniType b)]
+      = ppCat [ppr sty b, ppStr "::", ppr sty (idType b)]
 \end{code}
 
 \begin{code}
@@ -320,12 +312,12 @@ returnL r loc scope errs = (r, errs)
 
 thenL :: LintM a -> (a -> LintM b) -> LintM b
 thenL m k loc scope errs
-  = case m loc scope errs of 
+  = case m loc scope errs of
       (r, errs') -> k r loc scope errs'
 
 thenL_ :: LintM a -> LintM b -> LintM b
 thenL_ m k loc scope errs
-  = case m loc scope errs of 
+  = case m loc scope errs of
       (_, errs') -> k loc scope errs'
 
 thenMaybeL :: LintM (Maybe a) -> (a -> LintM (Maybe b)) -> LintM (Maybe b)
@@ -396,10 +388,10 @@ addInScopeVars ids m loc scope errs
 \end{code}
 
 \begin{code}
-checkFunApp :: UniType 		-- The function type
-	    -> [UniType] 	-- The arg type(s)
+checkFunApp :: Type 		-- The function type
+	    -> [Type] 	-- The arg type(s)
 	    -> ErrMsg 		-- Error messgae
-	    -> LintM (Maybe UniType)	-- The result type
+	    -> LintM (Maybe Type)	-- The result type
 
 checkFunApp fun_ty arg_tys msg loc scope errs
   = cfa res_ty expected_arg_tys arg_tys
@@ -411,7 +403,7 @@ checkFunApp fun_ty arg_tys msg loc scope errs
 
     cfa res_ty [] arg_tys	-- Expected arg tys ran out first;
 				-- first see if res_ty is a tyvar template;
-				-- otherwise, maybe res_ty is a 
+				-- otherwise, maybe res_ty is a
 				-- dictionary type which is actually a function?
       | isTyVarTemplateTy res_ty
       = (Just res_ty, errs)
@@ -434,7 +426,7 @@ checkInScope id loc scope errs
     else
 	((), errs)
 
-checkTys :: UniType -> UniType -> ErrMsg -> LintM ()
+checkTys :: Type -> Type -> ErrMsg -> LintM ()
 checkTys ty1 ty2 msg loc scope errs
   = case (sleazy_cmp_ty ty1 ty2) of
       EQ_   -> ((), errs)
@@ -442,13 +434,13 @@ checkTys ty1 ty2 msg loc scope errs
 \end{code}
 
 \begin{code}
-mkCaseAltMsg :: PlainStgCaseAlternatives -> ErrMsg
+mkCaseAltMsg :: StgCaseAlts -> ErrMsg
 mkCaseAltMsg alts sty
   = ppAbove (ppStr "In some case alternatives, type of alternatives not all same:")
 	    -- LATER: (ppr sty alts)
 	    (panic "mkCaseAltMsg")
 
-mkCaseDataConMsg :: PlainStgExpr -> ErrMsg
+mkCaseDataConMsg :: StgExpr -> ErrMsg
 mkCaseDataConMsg expr sty
   = ppAbove (ppStr "A case scrutinee not a type-constructor type:")
 	    (pp_expr sty expr)
@@ -458,37 +450,37 @@ mkCaseAbstractMsg tycon sty
   = ppAbove (ppStr "An algebraic case on an abstract type:")
 	    (ppr sty tycon)
 
-mkDefltMsg :: PlainStgCaseDefault -> ErrMsg
+mkDefltMsg :: StgCaseDefault -> ErrMsg
 mkDefltMsg deflt sty
   = ppAbove (ppStr "Binder in default case of a case expression doesn't match type of scrutinee:")
 	    --LATER: (ppr sty deflt)
 	    (panic "mkDefltMsg")
 
-mkFunAppMsg :: UniType -> [UniType] -> PlainStgExpr -> ErrMsg
+mkFunAppMsg :: Type -> [Type] -> StgExpr -> ErrMsg
 mkFunAppMsg fun_ty arg_tys expr sty
   = ppAboves [ppStr "In a function application, function type doesn't match arg types:",
 	      ppHang (ppStr "Function type:") 4 (ppr sty fun_ty),
 	      ppHang (ppStr "Arg types:") 4 (ppAboves (map (ppr sty) arg_tys)),
 	      ppHang (ppStr "Expression:") 4 (pp_expr sty expr)]
 
-mkRhsConMsg :: UniType -> [UniType] -> ErrMsg
+mkRhsConMsg :: Type -> [Type] -> ErrMsg
 mkRhsConMsg fun_ty arg_tys sty
   = ppAboves [ppStr "In a RHS constructor application, con type doesn't match arg types:",
 	      ppHang (ppStr "Constructor type:") 4 (ppr sty fun_ty),
 	      ppHang (ppStr "Arg types:") 4 (ppAboves (map (ppr sty) arg_tys))]
 
-mkUnappTyMsg :: Id -> UniType -> ErrMsg
+mkUnappTyMsg :: Id -> Type -> ErrMsg
 mkUnappTyMsg var ty sty
   = ppAboves [ppStr "Variable has a for-all type, but isn't applied to any types.",
 	      ppBeside (ppStr "Var:      ") (ppr sty var),
 	      ppBeside (ppStr "Its type: ") (ppr sty ty)]
 
-mkAlgAltMsg1 :: UniType -> ErrMsg
+mkAlgAltMsg1 :: Type -> ErrMsg
 mkAlgAltMsg1 ty sty
   = ppAbove (ppStr "In some case statement, type of scrutinee is not a data type:")
 	    (ppr sty ty)
 
-mkAlgAltMsg2 :: UniType -> Id -> ErrMsg
+mkAlgAltMsg2 :: Type -> Id -> ErrMsg
 mkAlgAltMsg2 ty con sty
   = ppAboves [
 	ppStr "In some algebraic case alternative, constructor is not a constructor of scrutinee type:",
@@ -504,7 +496,7 @@ mkAlgAltMsg3 con alts sty
 	ppr sty alts
     ]
 
-mkAlgAltMsg4 :: UniType -> Id -> ErrMsg
+mkAlgAltMsg4 :: Type -> Id -> ErrMsg
 mkAlgAltMsg4 ty arg sty
   = ppAboves [
 	ppStr "In some algebraic case alternative, type of argument doesn't match data constructor:",
@@ -512,20 +504,20 @@ mkAlgAltMsg4 ty arg sty
 	ppr sty arg
     ]
 
-mkPrimAltMsg :: (BasicLit, PlainStgExpr) -> ErrMsg
+mkPrimAltMsg :: (Literal, StgExpr) -> ErrMsg
 mkPrimAltMsg alt sty
   = ppAbove (ppStr "In a primitive case alternative, type of literal doesn't match type of scrutinee:")
 	    (ppr sty alt)
 
-mkRhsMsg :: Id -> UniType -> ErrMsg
+mkRhsMsg :: Id -> Type -> ErrMsg
 mkRhsMsg binder ty sty
-  = ppAboves [ppCat [ppStr "The type of this binder doesn't match the type of its RHS:", 
+  = ppAboves [ppCat [ppStr "The type of this binder doesn't match the type of its RHS:",
 		     ppr sty binder],
-	      ppCat [ppStr "Binder's type:", ppr sty (getIdUniType binder)],
+	      ppCat [ppStr "Binder's type:", ppr sty (idType binder)],
 	      ppCat [ppStr "Rhs type:", ppr sty ty]
 	     ]
 
-pp_expr :: PprStyle -> PlainStgExpr -> Pretty
+pp_expr :: PprStyle -> StgExpr -> Pretty
 pp_expr sty expr = ppr sty expr
 
 sleazy_cmp_ty ty1 ty2
diff --git a/ghc/compiler/stgSyn/StgSyn.hi b/ghc/compiler/stgSyn/StgSyn.hi
deleted file mode 100644
index 215db4c2b2..0000000000
--- a/ghc/compiler/stgSyn/StgSyn.hi
+++ /dev/null
@@ -1,165 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface StgSyn where
-import Bag(Bag)
-import BasicLit(BasicLit)
-import CharSeq(CSeq)
-import Class(Class, ClassOp)
-import CmdLineOpts(GlobalSwitch)
-import CostCentre(CostCentre)
-import HsBinds(Binds)
-import HsExpr(Expr)
-import HsMatches(GRHS, GRHSsAndBinds)
-import HsPat(InPat)
-import Id(Id)
-import IdEnv(IdEnv(..))
-import IdInfo(IdInfo)
-import Maybes(Labda)
-import Name(Name)
-import NameTypes(FullName, ShortName)
-import Outputable(ExportFlag, NamedThing(..), Outputable(..))
-import PreludePS(_PackedString)
-import PreludeRatio(Ratio(..))
-import Pretty(Delay, PprStyle, Pretty(..), PrettyRep)
-import PrimKind(PrimKind)
-import PrimOps(PrimOp)
-import SrcLoc(SrcLoc)
-import TyCon(TyCon)
-import TyVar(TyVar, TyVarTemplate)
-import TyVarEnv(TyVarEnv(..))
-import UniType(SigmaType(..), TauType(..), ThetaType(..), UniType)
-import UniqFM(UniqFM)
-import UniqSet(UniqSet(..))
-import Unique(Unique)
-class NamedThing a where
-	getExportFlag :: a -> ExportFlag
-	isLocallyDefined :: a -> Bool
-	getOrigName :: a -> (_PackedString, _PackedString)
-	getOccurrenceName :: a -> _PackedString
-	getInformingModules :: a -> [_PackedString]
-	getSrcLoc :: a -> SrcLoc
-	getTheUnique :: a -> Unique
-	hasType :: a -> Bool
-	getType :: a -> UniType
-	fromPreludeCore :: a -> Bool
-class Outputable a where
-	ppr :: PprStyle -> a -> Int -> Bool -> PrettyRep
-data Bag a 
-data BasicLit 
-data Class 
-data ClassOp 
-data CostCentre 
-data Binds a b 
-data Expr a b 
-data GRHS a b 
-data GRHSsAndBinds a b 
-data InPat a 
-data Id 
-type IdEnv a = UniqFM a
-data IdInfo 
-data Labda a 
-data Name 
-data FullName 
-data ShortName 
-data ExportFlag 
-type PlainStgAtom = StgAtom Id
-type PlainStgBinding = StgBinding Id Id
-type PlainStgCaseAlternatives = StgCaseAlternatives Id Id
-type PlainStgCaseDefault = StgCaseDefault Id Id
-type PlainStgExpr = StgExpr Id Id
-type PlainStgLiveVars = UniqFM Id
-type PlainStgProgram = [StgBinding Id Id]
-type PlainStgRhs = StgRhs Id Id
-data PprStyle 
-type Pretty = Int -> Bool -> PrettyRep
-data PrettyRep 
-data PrimKind 
-data PrimOp 
-data SrcLoc 
-data StgAtom a   = StgVarAtom a | StgLitAtom BasicLit
-data StgBinderInfo   = NoStgBinderInfo | StgBinderInfo Bool Bool Bool Bool Bool
-data StgBinding a b   = StgNonRec a (StgRhs a b) | StgRec [(a, StgRhs a b)]
-data StgCaseAlternatives a b   = StgAlgAlts UniType [(Id, [a], [Bool], StgExpr a b)] (StgCaseDefault a b) | StgPrimAlts UniType [(BasicLit, StgExpr a b)] (StgCaseDefault a b)
-data StgCaseDefault a b   = StgNoDefault | StgBindDefault a Bool (StgExpr a b)
-data StgExpr a b   = StgApp (StgAtom b) [StgAtom b] (UniqFM b) | StgConApp Id [StgAtom b] (UniqFM b) | StgPrimApp PrimOp [StgAtom b] (UniqFM b) | StgCase (StgExpr a b) (UniqFM b) (UniqFM b) Unique (StgCaseAlternatives a b) | StgLet (StgBinding a b) (StgExpr a b) | StgLetNoEscape (UniqFM b) (UniqFM b) (StgBinding a b) (StgExpr a b) | StgSCC UniType CostCentre (StgExpr a b)
-type StgLiveVars a = UniqFM a
-data StgRhs a b   = StgRhsClosure CostCentre StgBinderInfo [b] UpdateFlag [a] (StgExpr a b) | StgRhsCon CostCentre Id [StgAtom b]
-data TyCon 
-data TyVar 
-data TyVarTemplate 
-type TyVarEnv a = UniqFM a
-type SigmaType = UniType
-type TauType = UniType
-type ThetaType = [(Class, UniType)]
-data UniType 
-data UniqFM a 
-type UniqSet a = UniqFM a
-data Unique 
-data UpdateFlag   = ReEntrant | Updatable | SingleEntry
-collectExportedStgBinders :: [StgBinding Id Id] -> [Id]
-combineStgBinderInfo :: StgBinderInfo -> StgBinderInfo -> StgBinderInfo
-getAtomKind :: StgAtom Id -> PrimKind
-isLitLitStgAtom :: StgAtom a -> Bool
-pprPlainStgBinding :: PprStyle -> StgBinding Id Id -> Int -> Bool -> PrettyRep
-stgArgOcc :: StgBinderInfo
-stgArity :: StgRhs Id Id -> Int
-stgFakeFunAppOcc :: StgBinderInfo
-stgNoUpdHeapOcc :: StgBinderInfo
-stgNormalOcc :: StgBinderInfo
-stgStdHeapOcc :: StgBinderInfo
-stgUnsatOcc :: StgBinderInfo
-instance Eq BasicLit
-instance Eq Class
-instance Eq ClassOp
-instance Eq Id
-instance Eq PrimKind
-instance Eq PrimOp
-instance Eq TyCon
-instance Eq TyVar
-instance Eq TyVarTemplate
-instance Eq UniType
-instance Eq Unique
-instance Ord BasicLit
-instance Ord Class
-instance Ord ClassOp
-instance Ord Id
-instance Ord PrimKind
-instance Ord TyCon
-instance Ord TyVar
-instance Ord TyVarTemplate
-instance Ord Unique
-instance NamedThing Class
-instance NamedThing a => NamedThing (InPat a)
-instance NamedThing Id
-instance NamedThing FullName
-instance NamedThing ShortName
-instance NamedThing TyCon
-instance NamedThing TyVar
-instance NamedThing TyVarTemplate
-instance (Outputable a, Outputable b) => Outputable (a, b)
-instance (Outputable a, Outputable b, Outputable c) => Outputable (a, b, c)
-instance Outputable BasicLit
-instance Outputable Bool
-instance Outputable Class
-instance Outputable ClassOp
-instance (NamedThing a, Outputable a, NamedThing b, Outputable b) => Outputable (Binds a b)
-instance (NamedThing a, Outputable a, NamedThing b, Outputable b) => Outputable (Expr a b)
-instance (NamedThing a, Outputable a, NamedThing b, Outputable b) => Outputable (GRHS a b)
-instance (NamedThing a, Outputable a, NamedThing b, Outputable b) => Outputable (GRHSsAndBinds a b)
-instance Outputable a => Outputable (InPat a)
-instance Outputable Id
-instance Outputable FullName
-instance Outputable ShortName
-instance Outputable PrimKind
-instance Outputable PrimOp
-instance Outputable a => Outputable (StgAtom a)
-instance (Outputable a, Outputable b, Ord b) => Outputable (StgBinding a b)
-instance (Outputable a, Outputable b, Ord b) => Outputable (StgExpr a b)
-instance (Outputable a, Outputable b, Ord b) => Outputable (StgRhs a b)
-instance Outputable UpdateFlag
-instance Outputable TyCon
-instance Outputable TyVar
-instance Outputable TyVarTemplate
-instance Outputable UniType
-instance Outputable a => Outputable [a]
-instance Text Unique
-
diff --git a/ghc/compiler/stgSyn/StgSyn.lhs b/ghc/compiler/stgSyn/StgSyn.lhs
index 577498d63d..456a7f8e56 100644
--- a/ghc/compiler/stgSyn/StgSyn.lhs
+++ b/ghc/compiler/stgSyn/StgSyn.lhs
@@ -1,5 +1,5 @@
 %
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
 %
 \section[StgSyn]{Shared term graph (STG) syntax for spineless-tagless code generation}
 
@@ -12,14 +12,11 @@ suited to spineless tagless code generation.
 #include "HsVersions.h"
 
 module StgSyn (
-	StgAtom(..),
-	StgLiveVars(..),
+	GenStgArg(..),
+	GenStgLiveVars(..),
 
-	StgBinding(..), StgExpr(..), StgRhs(..),
-	StgCaseAlternatives(..), StgCaseDefault(..),
-#ifdef DPH
-	StgParCommunicate(..),
-#endif {- Data Parallel Haskell -}
+	GenStgBinding(..), GenStgExpr(..), GenStgRhs(..),
+	GenStgCaseAlts(..), GenStgCaseDefault(..),
 
 	UpdateFlag(..),
 
@@ -29,119 +26,93 @@ module StgSyn (
 	combineStgBinderInfo,
 
 	-- a set of synonyms for the most common (only :-) parameterisation
-	PlainStgAtom(..), PlainStgLiveVars(..), PlainStgProgram(..),
-	PlainStgBinding(..), PlainStgExpr(..), PlainStgRhs(..),
-	PlainStgCaseAlternatives(..), PlainStgCaseDefault(..),
+	StgArg(..), StgLiveVars(..),
+	StgBinding(..), StgExpr(..), StgRhs(..),
+	StgCaseAlts(..), StgCaseDefault(..),
 
 	pprPlainStgBinding,
---UNUSED:	fvsFromAtoms,
-	getAtomKind,
-	isLitLitStgAtom,
+	getArgPrimRep,
+	isLitLitArg,
 	stgArity,
-	collectExportedStgBinders,
+	collectExportedStgBinders
 
 	-- and to make the interface self-sufficient...
-	Outputable(..), NamedThing(..), Pretty(..),
-	Unique, ExportFlag, SrcLoc, PprStyle, PrettyRep,
-
-	BasicLit, Class, ClassOp, 
-	
-	Binds, Expr, GRHS, GRHSsAndBinds, InPat,
-
-	Id, IdInfo, Maybe, Name, FullName, ShortName,
-	PrimKind, PrimOp, CostCentre, TyCon, TyVar,
-	UniqSet(..), UniqFM, Bag,
-	TyVarTemplate, UniType, TauType(..),
-	ThetaType(..), SigmaType(..),
-	TyVarEnv(..), IdEnv(..)
-
-	IF_ATTACK_PRAGMAS(COMMA isLitLitLit)
-	IF_ATTACK_PRAGMAS(COMMA cmpTyCon COMMA cmpTyVar COMMA cmpClass)
-	IF_ATTACK_PRAGMAS(COMMA cmpUniType)
     ) where
 
-import AbsPrel		( getPrimOpResultInfo, PrimOpResultInfo(..),
-			  PrimOp, PrimKind
+import Ubiq{-uitous-}
+
+{-
+import PrelInfo		( getPrimOpResultInfo, PrimOpResultInfo(..),
+			  PrimOp, PrimRep
 			  IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
 			  IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
 			)
-import AbsSyn		( Binds, Expr, GRHS, GRHSsAndBinds, InPat )
-import AbsUniType
-import BasicLit		( typeOfBasicLit, kindOfBasicLit, isLitLitLit,
-			  BasicLit(..) -- (..) for pragmas
+import HsSyn		( HsBinds, HsExpr, GRHS, GRHSsAndBinds, InPat )
+import Type
+import Literal		( literalPrimRep, isLitLitLit,
+			  Literal(..) -- (..) for pragmas
 			)
-import Id		( getIdUniType, getIdKind, toplevelishId,
+import Id		( idType, getIdPrimRep, toplevelishId,
 			  isTopLevId, Id, IdInfo
 			)
 import Maybes		( Maybe(..), catMaybes )
 import Outputable
 import Pretty
-import PrimKind		( PrimKind )
 import CostCentre	( showCostCentre, CostCentre )
 import UniqSet
-import Unique
 import Util
+-}
 \end{code}
 
 %************************************************************************
 %*									*
-\subsection[StgBinding]{@StgBinding@}
+\subsection{@GenStgBinding@}
 %*									*
 %************************************************************************
 
 As usual, expressions are interesting; other things are boring.  Here
-are the boring things [except note the @StgRhs@], parameterised with
-respect to binder and bindee information (just as in @CoreSyntax@):
-\begin{code}
-data StgBinding binder bindee
-  = StgNonRec	binder (StgRhs binder bindee)
-  | StgRec	[(binder, StgRhs binder bindee)]
-\end{code}
+are the boring things [except note the @GenStgRhs@], parameterised
+with respect to binder and occurrence information (just as in
+@CoreSyn@):
 
-An @StgProgram@ is just a list of @StgBindings@; the
-properties/restrictions-on this list are the same as for a
-@CoreProgram@ (a list of @CoreBindings@).
 \begin{code}
---type StgProgram binder bindee = [StgBinding binder bindee]
+data GenStgBinding bndr occ
+  = StgNonRec	bndr (GenStgRhs bndr occ)
+  | StgRec	[(bndr, GenStgRhs bndr occ)]
 \end{code}
 
 %************************************************************************
 %*									*
-\subsection[StgAtom]{@StgAtom@}
+\subsection{@GenStgArg@}
 %*									*
 %************************************************************************
 
 \begin{code}
-data StgAtom bindee
-  = StgVarAtom	bindee
-  | StgLitAtom	BasicLit
+data GenStgArg occ
+  = StgVarArg	occ
+  | StgLitArg	Literal
 \end{code}
 
 \begin{code}
-getAtomKind (StgVarAtom  local) = getIdKind local
-getAtomKind (StgLitAtom  lit)	= kindOfBasicLit lit
+getArgPrimRep (StgVarArg  local) = getIdPrimRep local
+getArgPrimRep (StgLitArg  lit)	= literalPrimRep lit
 
-{- UNUSED happily
-fvsFromAtoms :: [PlainStgAtom] -> (UniqSet Id)	-- ToDo: this looks like a HACK to me (WDP)
-fvsFromAtoms as = mkUniqSet [ id | (StgVarAtom id) <- as, not (toplevelishId id) ]
--}
-
-isLitLitStgAtom (StgLitAtom x) = isLitLitLit x
-isLitLitStgAtom _   	       = False
+isLitLitArg (StgLitArg x) = isLitLitLit x
+isLitLitArg _		  = False
 \end{code}
 
 %************************************************************************
 %*									*
-\subsection[StgExpr]{STG expressions}
+\subsection{STG expressions}
 %*									*
 %************************************************************************
 
-The @StgExpr@ data type is parameterised on binder and bindee info, as
-before.
+The @GenStgExpr@ data type is parameterised on binder and occurrence
+info, as before.
 
 %************************************************************************
 %*									*
-\subsubsection[StgExpr-application]{@StgExpr@ application}
+\subsubsection{@GenStgExpr@ application}
 %*									*
 %************************************************************************
 
@@ -153,13 +124,13 @@ their closures first.)
 There is no constructor for a lone variable; it would appear as
 @StgApp var [] _@.
 \begin{code}
-type StgLiveVars bindee = UniqSet bindee
+type GenStgLiveVars occ = UniqSet occ
 
-data StgExpr binder bindee
-  = StgApp	
-	(StgAtom bindee)	-- function
-	[StgAtom bindee]	-- arguments
-	(StgLiveVars bindee)	-- Live vars in continuation; ie not
+data GenStgExpr bndr occ
+  = StgApp
+	(GenStgArg occ)	-- function
+	[GenStgArg occ]	-- arguments
+	(GenStgLiveVars occ)	-- Live vars in continuation; ie not
 				-- including the function and args
 
     -- NB: a literal is: StgApp <lit-atom> [] ...
@@ -167,23 +138,23 @@ data StgExpr binder bindee
 
 %************************************************************************
 %*									*
-\subsubsection[StgExpr-apps]{@StgConApp@ and @StgPrimApp@---saturated applications}
+\subsubsection{@StgCon@ and @StgPrim@---saturated applications}
 %*									*
 %************************************************************************
 
 There are two specialised forms of application, for
 constructors and primitives.
 \begin{code}
-  | StgConApp			-- always saturated
+  | StgCon			-- always saturated
 	Id -- data constructor
-	[StgAtom bindee]
-	(StgLiveVars bindee)	-- Live vars in continuation; ie not
+	[GenStgArg occ]
+	(GenStgLiveVars occ)	-- Live vars in continuation; ie not
 				-- including the constr and args
 
-  | StgPrimApp			-- always saturated
+  | StgPrim			-- always saturated
 	PrimOp
-	[StgAtom bindee]
-	(StgLiveVars bindee)	-- Live vars in continuation; ie not
+	[GenStgArg occ]
+	(GenStgLiveVars occ)	-- Live vars in continuation; ie not
 				-- including the op and args
 \end{code}
 These forms are to do ``inline versions,'' as it were.
@@ -191,21 +162,21 @@ An example might be: @f x = x:[]@.
 
 %************************************************************************
 %*									*
-\subsubsection[StgExpr-case]{@StgExpr@: case-expressions}
+\subsubsection{@GenStgExpr@: case-expressions}
 %*									*
 %************************************************************************
 
 This has the same boxed/unboxed business as Core case expressions.
 \begin{code}
   | StgCase
-	(StgExpr binder bindee)
+	(GenStgExpr bndr occ)
 			-- the thing to examine
 
-	(StgLiveVars bindee) -- Live vars of whole case
+	(GenStgLiveVars occ) -- Live vars of whole case
 			-- expression; i.e., those which mustn't be
 			-- overwritten
 
-	(StgLiveVars bindee) -- Live vars of RHSs;
+	(GenStgLiveVars occ) -- Live vars of RHSs;
 			-- i.e., those which must be saved before eval.
 			--
 			-- note that an alt's constructor's
@@ -217,12 +188,12 @@ This has the same boxed/unboxed business as Core case expressions.
 			-- variable to hold the tag of a primop with
 			-- algebraic result
 
-	(StgCaseAlternatives binder bindee)
+	(GenStgCaseAlts bndr occ)
 \end{code}
 
 %************************************************************************
 %*									*
-\subsubsection[StgExpr-lets]{@StgExpr@:  @let(rec)@-expressions}
+\subsubsection{@GenStgExpr@:  @let(rec)@-expressions}
 %*									*
 %************************************************************************
 
@@ -304,7 +275,7 @@ f x y = let z = huge-expression in
 \item
 We may eventually want:
 \begin{verbatim}
-let-literal x = BasicLit
+let-literal x = Literal
 in e
 \end{verbatim}
 
@@ -314,26 +285,26 @@ in e
 And so the code for let(rec)-things:
 \begin{code}
   | StgLet
-	(StgBinding binder bindee)	-- right hand sides (see below)
-	(StgExpr binder bindee)		-- body
+	(GenStgBinding bndr occ)	-- right hand sides (see below)
+	(GenStgExpr bndr occ)		-- body
 
   | StgLetNoEscape			-- remember: ``advanced stuff''
-	(StgLiveVars bindee)		-- Live in the whole let-expression
+	(GenStgLiveVars occ)		-- Live in the whole let-expression
 					-- Mustn't overwrite these stack slots
     	    	    	    	    	-- *Doesn't* include binders of the let(rec).
 
-	(StgLiveVars bindee)		-- Live in the right hand sides (only)
+	(GenStgLiveVars occ)		-- Live in the right hand sides (only)
 					-- These are the ones which must be saved on
 					-- the stack if they aren't there already
     	    	    	    	    	-- *Does* include binders of the let(rec) if recursive.
 
-	(StgBinding binder bindee)	-- right hand sides (see below)
-	(StgExpr binder bindee)		-- body
+	(GenStgBinding bndr occ)	-- right hand sides (see below)
+	(GenStgExpr bndr occ)		-- body
 \end{code}
 
 %************************************************************************
 %*									*
-\subsubsection[StgExpr-scc]{@StgExpr@: @scc@ expressions}
+\subsubsection{@GenStgExpr@: @scc@ expressions}
 %*									*
 %************************************************************************
 
@@ -341,52 +312,31 @@ Finally for @scc@ expressions we introduce a new STG construct.
 
 \begin{code}
   | StgSCC
-	UniType			-- the type of the body
+	Type			-- the type of the body
 	CostCentre		-- label of SCC expression
-	(StgExpr binder bindee)	-- scc expression
-\end{code}
-
-%************************************************************************
-%*									*
-\subsection[DataParallel]{Data parallel extensions to STG syntax}
-%*									*
-%************************************************************************
-
-\begin{code}
-#ifdef DPH
-  | StgParConApp			-- saturated parallel constructor
-        Id
-	Int				-- What parallel context
-	[StgAtom bindee]
-	(StgLiveVars bindee)
-
-  | StgParComm
-	Int
-	(StgExpr binder bindee)		-- The thing we are communicating
-	(StgParCommunicate binder bindee)
-#endif {- Data Parallel Haskell -}
-  -- end of StgExpr
+	(GenStgExpr bndr occ)	-- scc expression
+  -- end of GenStgExpr
 \end{code}
 
 %************************************************************************
 %*									*
-\subsection[StgRhs]{STG right-hand sides}
+\subsection{STG right-hand sides}
 %*									*
 %************************************************************************
 
 Here's the rest of the interesting stuff for @StgLet@s; the first
 flavour is for closures:
 \begin{code}
-data StgRhs binder bindee
+data GenStgRhs bndr occ
   = StgRhsClosure
 	CostCentre		-- cost centre to be attached (default is CCC)
 	StgBinderInfo		-- Info about how this binder is used (see below)
-	[bindee]		-- non-global free vars; a list, rather than
+	[occ]			-- non-global free vars; a list, rather than
 				-- a set, because order is important
 	UpdateFlag		-- ReEntrant | Updatable | SingleEntry
-	[binder]		-- arguments; if empty, then not a function;
+	[bndr]			-- arguments; if empty, then not a function;
 				-- as above, order is important
-	(StgExpr binder bindee)	-- body
+	(GenStgExpr bndr occ)	-- body
 \end{code}
 An example may be in order.  Consider:
 \begin{verbatim}
@@ -409,14 +359,13 @@ The second flavour of right-hand-side is for constructors (simple but important)
 				-- data in heap profiles, and we don't set CCC
 				-- from static closure.
 	Id			-- constructor
-	[StgAtom bindee]	-- args
+	[GenStgArg occ]	-- args
 \end{code}
 
 Here's the @StgBinderInfo@ type, and its combining op:
 \begin{code}
-data StgBinderInfo 
+data StgBinderInfo
   = NoStgBinderInfo
-
   | StgBinderInfo
 	Bool		-- At least one occurrence as an argument
 
@@ -431,7 +380,7 @@ data StgBinderInfo
 	Bool		-- At least one fake application occurrence, that is
 			-- an StgApp f args where args is an empty list
 			-- This is due to the fact that we do not have a
-			-- StgVar constructor. 
+			-- StgVar constructor.
 			-- Used by the lambda lifter.
 			-- True => "at least one unsat app" is True too
 
@@ -441,7 +390,7 @@ stgStdHeapOcc    = StgBinderInfo False False True  False False
 stgNoUpdHeapOcc  = StgBinderInfo False False False True  False
 stgNormalOcc     = StgBinderInfo False False False False False
 -- [Andre] can't think of a good name for the last one.
-stgFakeFunAppOcc = StgBinderInfo False True  False False True 
+stgFakeFunAppOcc = StgBinderInfo False True  False False True
 
 combineStgBinderInfo :: StgBinderInfo -> StgBinderInfo -> StgBinderInfo
 
@@ -465,81 +414,46 @@ combineStgBinderInfo (StgBinderInfo arg1 unsat1 std_heap1 upd_heap1 fkap1)
 Just like in @CoreSyntax@ (except no type-world stuff).
 
 \begin{code}
-data StgCaseAlternatives binder bindee
-  = StgAlgAlts	UniType	-- so we can find out things about constructor family
+data GenStgCaseAlts bndr occ
+  = StgAlgAlts	Type	-- so we can find out things about constructor family
 		[(Id,				-- alts: data constructor,
-		  [binder],			-- constructor's parameters,
+		  [bndr],			-- constructor's parameters,
 		  [Bool],			-- "use mask", same length as
 						-- parameters; a True in a
 						-- param's position if it is
 						-- used in the ...
-		  StgExpr binder bindee)]	-- ...right-hand side.
-		(StgCaseDefault binder bindee)
-  | StgPrimAlts	UniType	-- so we can find out things about constructor family
-		[(BasicLit,			-- alts: unboxed literal,
-		  StgExpr binder bindee)]	-- rhs.
-		(StgCaseDefault binder bindee)
-#ifdef DPH
-  | StgParAlgAlts	
-		UniType	
-		Int				-- What context we are in
-		[binder]			
-		[(Id,StgExpr binder bindee)]	
-		(StgCaseDefault binder bindee)
-  | StgParPrimAlts	UniType
-		Int				-- What context we are in
-		[(BasicLit,			-- alts: unboxed literal,
-		  StgExpr binder bindee)]	-- rhs.
-		(StgCaseDefault binder bindee)
-#endif {- Data Parallel Haskell -}
-
-data StgCaseDefault binder bindee
+		  GenStgExpr bndr occ)]	-- ...right-hand side.
+		(GenStgCaseDefault bndr occ)
+  | StgPrimAlts	Type	-- so we can find out things about constructor family
+		[(Literal,			-- alts: unboxed literal,
+		  GenStgExpr bndr occ)]	-- rhs.
+		(GenStgCaseDefault bndr occ)
+
+data GenStgCaseDefault bndr occ
   = StgNoDefault				-- small con family: all
 						-- constructor accounted for
-  | StgBindDefault  binder			-- form: var -> expr
+  | StgBindDefault  bndr			-- form: var -> expr
 		    Bool			-- True <=> var is used in rhs
 						-- i.e., False <=> "_ -> expr"
-		    (StgExpr binder bindee)
+		    (GenStgExpr bndr occ)
 \end{code}
 
 %************************************************************************
 %*									*
-\subsection[Stg-parComummunicate]{Communication operations}
-%*									*
-%************************************************************************
-
-\begin{code}
-#ifdef DPH
-data StgParCommunicate binder bindee
-  = StgParSend 
-	[StgAtom bindee]	-- Sending PODs
-
-  | StgParFetch 
-	[StgAtom bindee]	-- Fetching PODs
-
-  | StgToPodized		-- Convert a POD to the podized form
-
-  | StgFromPodized		-- Convert a POD from the podized form
-#endif {- Data Parallel Haskell -}
-\end{code}
-
-%************************************************************************
-%*									*
-\subsection[PlainStg]{The Plain STG parameterisation}
+\subsection[Stg]{The Plain STG parameterisation}
 %*									*
 %************************************************************************
 
 This happens to be the only one we use at the moment.
 
 \begin{code}
-type PlainStgProgram = [StgBinding Id Id]
-type PlainStgBinding = StgBinding Id Id
-type PlainStgAtom    = StgAtom    Id
-type PlainStgLiveVars= UniqSet Id
-type PlainStgExpr    = StgExpr    Id Id
-type PlainStgRhs     = StgRhs     Id Id
-type PlainStgCaseAlternatives = StgCaseAlternatives Id Id
-type PlainStgCaseDefault      = StgCaseDefault      Id Id
+type StgBinding     = GenStgBinding	Id Id
+type StgArg         = GenStgArg		Id
+type StgLiveVars    = GenStgLiveVars	Id
+type StgExpr        = GenStgExpr	Id Id
+type StgRhs         = GenStgRhs		Id Id
+type StgCaseAlts    = GenStgCaseAlts	Id Id
+type StgCaseDefault = GenStgCaseDefault	Id Id
 \end{code}
 
 %************************************************************************
@@ -547,12 +461,12 @@ type PlainStgCaseDefault      = StgCaseDefault      Id Id
 \subsubsection[UpdateFlag-datatype]{@UpdateFlag@}
 %*                                                                      *
 %************************************************************************
- 
+
 This is also used in @LambdaFormInfo@ in the @ClosureInfo@ module.
- 
+
 \begin{code}
 data UpdateFlag = ReEntrant | Updatable | SingleEntry
- 
+
 instance Outputable UpdateFlag where
     ppr sty u
       = ppChar (case u of { ReEntrant -> 'r';  Updatable -> 'u';  SingleEntry -> 's' })
@@ -571,27 +485,24 @@ latest/greatest pragma info.
 
 \begin{code}
 collectExportedStgBinders
-	:: [PlainStgBinding]	-- input: PlainStgProgram
+	:: [StgBinding]	-- input program
 	-> [Id]			-- exported top-level Ids
 
 collectExportedStgBinders binds
-  = exported_from_here [] binds
+  = ex [] binds
   where
-    exported_from_here es [] = es
+    ex es [] = es
 
-    exported_from_here es ((StgNonRec b _) : binds)
+    ex es ((StgNonRec b _) : binds)
       = if not (isExported b) then
-	    exported_from_here es binds
+	    ex es binds
 	else
-	    exported_from_here (b:es) binds
+	    ex (b:es) binds
 
-    exported_from_here es ((StgRec []) : binds)
-      = exported_from_here es binds
+    ex es ((StgRec []) : binds) = ex es binds
 
-    exported_from_here es ((StgRec ((b, rhs) : pairs)) : binds)
-      = exported_from_here
-	  es
-	  (StgNonRec b rhs : (StgRec pairs : binds))
+    ex es ((StgRec ((b, rhs) : pairs)) : binds)
+      = ex es (StgNonRec b rhs : (StgRec pairs : binds))
 	    -- OK, a total hack; laziness rules
 \end{code}
 
@@ -606,57 +517,51 @@ hoping he likes terminators instead...  Ditto for case alternatives.
 
 \begin{code}
 pprStgBinding :: (Outputable bndr, Outputable bdee, Ord bdee) =>
-		PprStyle -> StgBinding bndr bdee -> Pretty
+		PprStyle -> GenStgBinding bndr bdee -> Pretty
 
-pprStgBinding sty (StgNonRec binder rhs)
-  = ppHang (ppCat [ppr sty binder, ppEquals])
+pprStgBinding sty (StgNonRec bndr rhs)
+  = ppHang (ppCat [ppr sty bndr, ppEquals])
     	 4 (ppBeside (ppr sty rhs) ppSemi)
 
 pprStgBinding sty (StgRec pairs)
   = ppAboves ((ifPprDebug sty (ppStr "{- StgRec -}")) :
 	      (map (ppr_bind sty) pairs))
   where
-    ppr_bind sty (binder, expr)
-      = ppHang (ppCat [ppr sty binder, ppEquals])
+    ppr_bind sty (bndr, expr)
+      = ppHang (ppCat [ppr sty bndr, ppEquals])
 	     4 (ppBeside (ppr sty expr) ppSemi)
 
-pprPlainStgBinding :: PprStyle -> PlainStgBinding -> Pretty
+pprPlainStgBinding :: PprStyle -> StgBinding -> Pretty
 pprPlainStgBinding sty b = pprStgBinding sty b
 \end{code}
 
 \begin{code}
-instance (Outputable bdee) => Outputable (StgAtom bdee) where
-    ppr = pprStgAtom
+instance (Outputable bdee) => Outputable (GenStgArg bdee) where
+    ppr = pprStgArg
 
 instance (Outputable bndr, Outputable bdee, Ord bdee)
-		=> Outputable (StgBinding bndr bdee) where
+		=> Outputable (GenStgBinding bndr bdee) where
     ppr = pprStgBinding
 
 instance (Outputable bndr, Outputable bdee, Ord bdee)
-		=> Outputable (StgExpr bndr bdee) where
+		=> Outputable (GenStgExpr bndr bdee) where
     ppr = pprStgExpr
 
-{- OLD:
 instance (Outputable bndr, Outputable bdee, Ord bdee)
-		=> Outputable (StgCaseDefault bndr bdee) where
-    ppr sty deflt = panic "ppr:StgCaseDefault"
--}
-
-instance (Outputable bndr, Outputable bdee, Ord bdee)
-		=> Outputable (StgRhs bndr bdee) where
+		=> Outputable (GenStgRhs bndr bdee) where
     ppr sty rhs = pprStgRhs sty rhs
 \end{code}
 
 \begin{code}
-pprStgAtom :: (Outputable bdee) => PprStyle -> StgAtom bdee -> Pretty
+pprStgArg :: (Outputable bdee) => PprStyle -> GenStgArg bdee -> Pretty
 
-pprStgAtom sty (StgVarAtom var) = ppr sty var
-pprStgAtom sty (StgLitAtom lit) = ppr sty lit
+pprStgArg sty (StgVarArg var) = ppr sty var
+pprStgArg sty (StgLitArg lit) = ppr sty lit
 \end{code}
 
 \begin{code}
 pprStgExpr :: (Outputable bndr, Outputable bdee, Ord bdee) =>
-		PprStyle -> StgExpr bndr bdee -> Pretty
+		PprStyle -> GenStgExpr bndr bdee -> Pretty
 -- special case
 pprStgExpr sty (StgApp func [] lvs)
   = ppBeside (ppr sty func) (pprStgLVs sty lvs)
@@ -668,11 +573,11 @@ pprStgExpr sty (StgApp func args lvs)
 \end{code}
 
 \begin{code}
-pprStgExpr sty (StgConApp con args lvs)
+pprStgExpr sty (StgCon con args lvs)
   = ppBesides [ ppBeside (ppr sty con) (pprStgLVs sty lvs),
 		ppStr "! [", interppSP sty args, ppStr "]" ]
 
-pprStgExpr sty (StgPrimApp op args lvs)
+pprStgExpr sty (StgPrim op args lvs)
   = ppBesides [ ppr sty op, ppChar '#', pprStgLVs sty lvs,
 		ppStr " [", interppSP sty args, ppStr "]" ]
 \end{code}
@@ -681,20 +586,20 @@ pprStgExpr sty (StgPrimApp op args lvs)
 -- special case: let v = <very specific thing>
 --		 in
 --		 let ...
---		 in 
+--		 in
 --		 ...
 --
 -- Very special!  Suspicious! (SLPJ)
 
-pprStgExpr sty (StgLet (StgNonRec binder (StgRhsClosure cc bi free_vars upd_flag args rhs))
+pprStgExpr sty (StgLet (StgNonRec bndr (StgRhsClosure cc bi free_vars upd_flag args rhs))
 		    	expr@(StgLet _ _))
   = ppAbove
-      (ppHang (ppBesides [ppStr "let { ", ppr sty binder, ppStr " = ",
-		          ppStr (showCostCentre sty True{-as string-} cc),
+      (ppHang (ppBesides [ppStr "let { ", ppr sty bndr, ppStr " = ",
+			  ppStr (showCostCentre sty True{-as string-} cc),
 			  pp_binder_info sty bi,
-		          ppStr " [", ifPprDebug sty (interppSP sty free_vars), ppStr "] \\",
-		          ppr sty upd_flag, ppStr " [",
-		          interppSP sty args, ppStr "]"])
+			  ppStr " [", ifPprDebug sty (interppSP sty free_vars), ppStr "] \\",
+			  ppr sty upd_flag, ppStr " [",
+			  interppSP sty args, ppStr "]"])
 	    8 (ppSep [ppCat [ppr sty rhs, ppStr "} in"]]))
       (ppr sty expr)
 
@@ -766,64 +671,15 @@ pprStgExpr sty (StgCase expr lvs_whole lvs_rhss uniq alts)
 	  = ppHang (ppCat [ppr sty lit, ppStr "->"])
 		 4 (ppBeside (ppr sty expr) ppSemi)
 
-#ifdef DPH
-    ppr_alts sty (StgParAlgAlts ty dim params alts deflt)
-      = ppAboves [ ppBeside (ppCat (map (ppr sty) params))
-                        (ppCat [ppStr "|" , ppr sty dim , ppStr "|"]),
-		   ppAboves (map (ppr_bxd_alt sty) alts),
-		   ppr_default sty deflt ]
-      where
-	ppr_bxd_alt sty (con, expr)
-	  = ppHang (ppCat [ppStr "\\/", ppr_con sty con, ppStr "->"])
-		   4 (ppr sty expr)
-	  where
-	    ppr_con sty con
-	      = if isOpLexeme con
-		then ppBesides [ppLparen, ppr sty con, ppRparen]
-		else ppr sty con
-
-    ppr_alts sty (StgParPrimAlts ty dim alts deflt)
-      = ppAboves [ ifPprShowAll sty (ppr sty ty),
-		   ppCat [ppStr "|" , ppr sty dim , ppStr "|"],
-		   ppAboves (map (ppr_ubxd_alt sty) alts),
-		   ppr_default sty deflt ]
-      where
-	ppr_ubxd_alt sty (lit, expr)
-	  = ppHang (ppCat [ppStr "\\/", ppr sty lit, ppStr "->"]) 4 (ppr sty expr)
-#endif {- Data Parallel Haskell -}
-
     ppr_default sty StgNoDefault = ppNil
-    ppr_default sty (StgBindDefault binder used expr)
+    ppr_default sty (StgBindDefault bndr used expr)
       = ppHang (ppCat [pp_binder, ppStr "->"]) 4 (ppr sty expr)
       where
-    	pp_binder = if used then ppr sty binder else ppChar '_' 
-\end{code}
-
-\begin{code}
-#ifdef DPH
-pprStgExpr sty (StgParConApp con dim args lvs)
-  = ppBesides [ppr sty con, pprStgLVs sty lvs, ppStr "!<<" ,ppr sty dim , 
-	       ppStr ">> [", interppSP sty args, ppStr "]" ]
-
-pprStgExpr sty (StgParComm dim expr comm)
-  = ppSep [ppSep [ppStr "COMM ",
-                  ppNest 2 (pprStgExpr sty expr),ppStr "{"],
-           ppNest 2 (ppr_comm sty comm),
-           ppStr "}"]
-  where
-    ppr_comm sty (StgParSend args)
-      = ppSep [ppStr "SEND [",interppSP sty args, ppStr "]" ]
-    ppr_comm sty (StgParFetch args)
-      = ppSep [ppStr "FETCH [",interppSP sty args, ppStr "]" ]
-    ppr_comm sty (StgToPodized)
-      = ppStr "ToPodized"
-    ppr_comm sty (StgFromPodized)
-      = ppStr "FromPodized"
-#endif {- Data Parallel Haskell -}
+    	pp_binder = if used then ppr sty bndr else ppChar '_'
 \end{code}
 
 \begin{code}
--- pprStgLVs :: PprStyle -> StgLiveVars bindee -> Pretty
+-- pprStgLVs :: PprStyle -> GenStgLiveVars occ -> Pretty
 
 pprStgLVs PprForUser lvs = ppNil
 
@@ -836,7 +692,7 @@ pprStgLVs sty lvs
 
 \begin{code}
 pprStgRhs :: (Outputable bndr, Outputable bdee, Ord bdee) =>
-		PprStyle -> StgRhs bndr bdee -> Pretty
+		PprStyle -> GenStgRhs bndr bdee -> Pretty
 
 -- special case
 pprStgRhs sty (StgRhsClosure cc bi [free_var] upd_flag [{-no args-}] (StgApp func [] lvs))
@@ -875,7 +731,7 @@ Collect @IdInfo@ stuff that is most easily just snaffled straight
 from the STG bindings.
 
 \begin{code}
-stgArity :: PlainStgRhs -> Int
+stgArity :: StgRhs -> Int
 
 stgArity (StgRhsCon _ _ _)	         = 0 -- it's a constructor, fully applied
 stgArity (StgRhsClosure _ _ _ _ args _ ) = length args
diff --git a/ghc/compiler/stgSyn/StgUtils.lhs b/ghc/compiler/stgSyn/StgUtils.lhs
new file mode 100644
index 0000000000..830a75233d
--- /dev/null
+++ b/ghc/compiler/stgSyn/StgUtils.lhs
@@ -0,0 +1,90 @@
+x%
+% (c) The GRASP/AQUA Project, Glasgow University, 1993-1995
+%
+\section[StgUtils]{Utility functions for @STG@ programs}
+
+\begin{code}
+#include "HsVersions.h"
+
+module StgUtils ( mapStgBindeesRhs ) where
+
+import StgSyn
+
+import UniqSet
+
+import Util
+\end{code}
+
+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)
+mapStgBindeesBind fn (StgRec pairs)    = StgRec [ (b, mapStgBindeesRhs fn r) | (b, r) <- pairs ]
+
+------------------
+mapStgBindeesRhs :: (Id -> Id) -> StgRhs -> StgRhs
+
+mapStgBindeesRhs fn (StgRhsClosure cc bi fvs u args expr)
+  = StgRhsClosure
+	cc bi
+	(map fn fvs)
+	u
+	(map fn args)
+	(mapStgBindeesExpr fn expr)
+
+mapStgBindeesRhs fn (StgRhsCon cc con atoms)
+  = StgRhsCon cc con (map (mapStgBindeesAtom fn) atoms)
+
+------------------
+mapStgBindeesExpr :: (Id -> Id) -> StgExpr -> StgExpr
+
+mapStgBindeesExpr fn (StgApp f args lvs)
+  = StgApp (mapStgBindeesAtom fn f)
+	   (map (mapStgBindeesAtom fn) args)
+	   (mapUniqSet fn lvs)
+
+mapStgBindeesExpr fn (StgCon con atoms lvs)
+  = StgCon con (map (mapStgBindeesAtom fn) atoms) (mapUniqSet fn lvs)
+
+mapStgBindeesExpr fn (StgPrim op atoms lvs)
+  = StgPrim op (map (mapStgBindeesAtom fn) atoms) (mapUniqSet fn lvs)
+
+mapStgBindeesExpr fn (StgLet bind expr)
+  = StgLet (mapStgBindeesBind fn bind) (mapStgBindeesExpr fn expr)
+
+mapStgBindeesExpr fn (StgLetNoEscape lvs rhss_lvs bind body)
+  = StgLetNoEscape (mapUniqSet fn lvs) (mapUniqSet fn rhss_lvs)
+		   (mapStgBindeesBind fn bind) (mapStgBindeesExpr fn body)
+
+mapStgBindeesExpr fn (StgSCC ty label expr)
+  = StgSCC ty label (mapStgBindeesExpr fn expr)
+
+mapStgBindeesExpr fn (StgCase expr lvs1 lvs2 uniq alts)
+  = StgCase (mapStgBindeesExpr fn expr)
+	    (mapUniqSet fn lvs1)
+	    (mapUniqSet fn lvs2)
+	    uniq
+	    (mapStgBindeesAlts alts)
+  where
+    mapStgBindeesAlts (StgAlgAlts ty alts deflt)
+      = StgAlgAlts ty (map mapStgBindeesBoxed_alt alts) (mapStgBindeesDeflt deflt)
+      where
+	mapStgBindeesBoxed_alt (c,ps,use_mask,expr) = (c,ps,use_mask,mapStgBindeesExpr fn expr)
+
+    mapStgBindeesAlts (StgPrimAlts ty alts deflt)
+      = StgPrimAlts ty (map mapStgBindeesunboxed_alt alts) (mapStgBindeesDeflt deflt)
+      where
+	mapStgBindeesunboxed_alt (l,expr) = (l,mapStgBindeesExpr fn expr)
+
+    mapStgBindeesDeflt StgNoDefault		    = StgNoDefault
+    mapStgBindeesDeflt (StgBindDefault b used expr) = StgBindDefault b used (mapStgBindeesExpr fn expr)
+
+------------------
+mapStgBindeesAtom :: (Id -> Id) -> StgArg -> StgArg
+
+mapStgBindeesAtom fn a@(StgLitArg _)	= a
+mapStgBindeesAtom fn a@(StgVarArg id)  = StgVarArg (fn id)
+\end{code}
diff --git a/ghc/compiler/stranal/SaAbsInt.hi b/ghc/compiler/stranal/SaAbsInt.hi
deleted file mode 100644
index c243aee474..0000000000
--- a/ghc/compiler/stranal/SaAbsInt.hi
+++ /dev/null
@@ -1,14 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface SaAbsInt where
-import CoreSyn(CoreExpr)
-import Id(Id)
-import IdInfo(Demand)
-import SaLib(AbsVal, AbsValEnv, AnalysisKind)
-import UniType(UniType)
-absEval :: AnalysisKind -> CoreExpr Id Id -> AbsValEnv -> AbsVal
-findDemand :: AbsValEnv -> AbsValEnv -> CoreExpr Id Id -> Id -> Demand
-findStrictness :: (Bool, Bool) -> [UniType] -> AbsVal -> AbsVal -> [Demand]
-fixpoint :: AnalysisKind -> [Id] -> [CoreExpr Id Id] -> AbsValEnv -> [AbsVal]
-isBot :: AbsVal -> Bool
-widen :: AnalysisKind -> AbsVal -> AbsVal
-
diff --git a/ghc/compiler/stranal/SaAbsInt.lhs b/ghc/compiler/stranal/SaAbsInt.lhs
index 809a80211e..affcbfb142 100644
--- a/ghc/compiler/stranal/SaAbsInt.lhs
+++ b/ghc/compiler/stranal/SaAbsInt.lhs
@@ -1,5 +1,5 @@
 %
-% (c) The GRASP/AQUA Project, Glasgow University, 1993-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1993-1996
 %
 \section[SaAbsInt]{Abstract interpreter for strictness analysis}
 
@@ -20,29 +20,24 @@ import Pretty
 --import FiniteMap
 import Outputable
 
-import AbsPrel		( PrimOp(..),
+import PrelInfo		( PrimOp(..),
 			  intTyCon, integerTyCon, doubleTyCon,
 			  floatTyCon, wordTyCon, addrTyCon,
-			  PrimKind
+			  PrimRep
 			)
-import AbsUniType	( isPrimType, getUniDataTyCon_maybe,
+import Type		( isPrimType, maybeDataTyCon,
 			  maybeSingleConstructorTyCon,
 			  returnsRealWorld,
 			  isEnumerationTyCon, TyVarTemplate, TyCon
-			  IF_ATTACK_PRAGMAS(COMMA cmpTyCon)
 			)
-import Id		( getIdStrictness, getIdUniType, getIdUnfolding,
+import CoreUtils	( unTagBinders )
+import Id		( getIdStrictness, idType, getIdUnfolding,
 			  getDataConSig, getInstantiatedDataConSig,
 			  DataCon(..), isBottomingId
 			)
-
 import IdInfo		-- various bits
-import IdEnv
-import CoreFuns		( unTagBinders )
 import Maybes		( maybeToBool, Maybe(..) )
-import PlainCore
 import SaLib
-import SimplEnv		( FormSummary(..) ) -- nice data abstraction, huh? (WDP 95/03)
 import Util
 \end{code}
 
@@ -62,11 +57,10 @@ lub val1 val2 | isBot val2    = val1	-- one of the val's is a function which
 					-- always returns bottom, such as \y.x,
 					-- when x is bound to bottom.
 
-lub (AbsProd xs) (AbsProd ys) = ASSERT (length xs == length ys)
-				AbsProd (zipWith lub xs ys)
+lub (AbsProd xs) (AbsProd ys) = AbsProd (zipWithEqual lub xs ys)
 
 lub _		  _	      = AbsTop	-- Crude, but conservative
-					-- The crudity only shows up if there 
+					-- The crudity only shows up if there
 					-- are functions involved
 
 -- Slightly funny glb; for absence analysis only;
@@ -77,7 +71,7 @@ lub _		  _	      = AbsTop	-- Crude, but conservative
 --
 --   f = \a b -> ...
 --
---   g = \x y z -> case x of 
+--   g = \x y z -> case x of
 --	  	     []     -> f x
 --		     (p:ps) -> f p
 --
@@ -105,9 +99,9 @@ lub _		  _	      = AbsTop	-- Crude, but conservative
 -- Deal with functions specially, because AbsTop isn't the
 -- top of their domain.
 
-glb v1 v2 
+glb v1 v2
   | is_fun v1 || is_fun v2
-  = if not (anyBot v1) && not (anyBot v2) 
+  = if not (anyBot v1) && not (anyBot v2)
     then
 	AbsTop
     else
@@ -119,8 +113,7 @@ glb v1 v2
 
 -- The non-functional cases are quite straightforward
 
-glb (AbsProd xs) (AbsProd ys) = ASSERT (length xs == length ys)
-				AbsProd (zipWith glb xs ys)
+glb (AbsProd xs) (AbsProd ys) = AbsProd (zipWithEqual glb xs ys)
 
 glb AbsTop	 v2	      = v2
 glb v1           AbsTop	      = v1
@@ -129,7 +122,7 @@ glb _            _            = AbsBot 		-- Be pessimistic
 
 
 
-combineCaseValues 
+combineCaseValues
 	:: AnalysisKind
 	-> AbsVal	-- Value of scrutinee
 	-> [AbsVal]	-- Value of branches (at least one)
@@ -149,7 +142,7 @@ combineCaseValues StrAnal other_scrutinee branches
 	  AbsTop    -> True; 	-- i.e., cool
 	  AbsProd _ -> True; 	-- ditto
 	  _ 	    -> False 	-- party over
-	}  
+	}
 
 -- For absence analysis, check if the scrutinee is all poison (isBot)
 -- If so, return poison (AbsBot); otherwise, any nested poison will come
@@ -200,8 +193,8 @@ isBot :: AbsVal -> Bool
 
 isBot AbsBot		     = True
 isBot (AbsFun args body env) = isBot (absEval StrAnal body env)
-			       -- Don't bother to extend the envt because 
-			       -- unbound variables default to AbsTop anyway 
+			       -- Don't bother to extend the envt because
+			       -- unbound variables default to AbsTop anyway
 isBot other	 	     = False
 \end{code}
 
@@ -227,7 +220,7 @@ it, so it can be compared for equality by @sameVal@.
 \begin{code}
 widen :: AnalysisKind -> AbsVal -> AbsVal
 
-widen StrAnal (AbsFun args body env) 
+widen StrAnal (AbsFun args body env)
   | isBot (absEval StrAnal body env) = AbsBot
   | otherwise
   = ASSERT (not (null args))
@@ -248,12 +241,12 @@ widen StrAnal (AbsFun args body env)
     -- alternative here would be to bind g to its exact abstract
     -- value, but that entails lots of potential re-computation, at
     -- every application of g.)
-	
+
 widen StrAnal (AbsProd vals) = AbsProd (map (widen StrAnal) vals)
 widen StrAnal other_val	     = other_val
 
 
-widen AbsAnal (AbsFun args body env) 
+widen AbsAnal (AbsFun args body env)
   | anyBot (absEval AbsAnal body env) = AbsBot
 	-- In the absence-analysis case it's *essential* to check
 	-- that the function has no poison in its body.  If it does,
@@ -262,7 +255,7 @@ widen AbsAnal (AbsFun args body env)
   | otherwise
   = ASSERT (not (null args))
     AbsApproxFun (map (findDemandAbsOnly env body) args)
-	
+
 widen AbsAnal (AbsProd vals) = AbsProd (map (widen AbsAnal) vals)
 
 	-- It's desirable to do a good job of widening for product
@@ -280,7 +273,7 @@ widen AbsAnal (AbsProd vals) = AbsProd (map (widen AbsAnal) vals)
 
 widen AbsAnal other_val = other_val
 
--- OLD			  if anyBot val then AbsBot else AbsTop
+-- WAS:	  if anyBot val then AbsBot else AbsTop
 -- Nowadays widen is doing a better job on functions for absence analysis.
 \end{code}
 
@@ -309,8 +302,7 @@ sameVal AbsBot other  = False	-- widen has reduced AbsFun bots to AbsBot
 sameVal AbsTop AbsTop = True
 sameVal AbsTop other  = False		-- Right?
 
-sameVal (AbsProd vals1) (AbsProd vals2) = ASSERT (length vals1 == length vals2)
-					  and (zipWith sameVal vals1 vals2)
+sameVal (AbsProd vals1) (AbsProd vals2) = and (zipWithEqual sameVal vals1 vals2)
 sameVal (AbsProd _)	AbsTop 		= False
 sameVal (AbsProd _)	AbsBot 		= False
 
@@ -327,9 +319,9 @@ sameVal val1 val2 = panic "sameVal: type mismatch or AbsFun encountered"
 (@True@ is the exciting answer; @False@ is always safe.)
 
 \begin{code}
-evalStrictness :: Demand 
-	       -> AbsVal 
-	       -> Bool		-- True iff the value is sure 
+evalStrictness :: Demand
+	       -> AbsVal
+	       -> Bool		-- True iff the value is sure
 				-- to be less defined than the Demand
 
 evalStrictness (WwLazy _) _   = False
@@ -340,15 +332,14 @@ evalStrictness (WwUnpack demand_info) val
   = case val of
       AbsTop	   -> False
       AbsBot	   -> True
-      AbsProd vals -> ASSERT (length vals == length demand_info)
-		      or (zipWith evalStrictness demand_info vals)
+      AbsProd vals -> or (zipWithEqual evalStrictness demand_info vals)
       _	    	   -> trace "evalStrictness?" False
 
 evalStrictness WwPrim val
   = case val of
-      AbsTop -> False	
+      AbsTop -> False
 
-      other  ->   -- A primitive value should be defined, never bottom; 
+      other  ->   -- A primitive value should be defined, never bottom;
 		  -- hence this paranoia check
 		pprPanic "evalStrictness: WwPrim:" (ppr PprDebug other)
 \end{code}
@@ -359,15 +350,14 @@ function call; that is, whether the specified demand can {\em
 possibly} hit poison.
 
 \begin{code}
-evalAbsence (WwLazy True) _ = False	-- Can't possibly hit poison 
+evalAbsence (WwLazy True) _ = False	-- Can't possibly hit poison
 					-- with Absent demand
 
 evalAbsence (WwUnpack demand_info) val
   = case val of
 	AbsTop	     -> False		-- No poison in here
 	AbsBot 	     -> True		-- Pure poison
-	AbsProd vals -> ASSERT (length demand_info == length vals)
-			or (zipWith evalAbsence demand_info vals)
+	AbsProd vals -> or (zipWithEqual evalAbsence demand_info vals)
 	_	     -> panic "evalAbsence: other"
 
 evalAbsence other val = anyBot val
@@ -394,17 +384,17 @@ absId anal var env
      result =
       case (lookupAbsValEnv env var, getIdStrictness var, getIdUnfolding var) of
 
-        (Just abs_val, _, _) -> 
+	(Just abs_val, _, _) ->
 			abs_val	-- Bound in the environment
 
-	(Nothing, NoStrictnessInfo, LiteralForm _) -> 
+	(Nothing, NoStrictnessInfo, LitForm _) ->
 			AbsTop 	-- Literals all terminate, and have no poison
 
-	(Nothing, NoStrictnessInfo, ConstructorForm _ _ _) -> 
+	(Nothing, NoStrictnessInfo, ConForm _ _ _) ->
 			AbsTop -- An imported constructor won't have
 			       -- bottom components, nor poison!
 
-	(Nothing, NoStrictnessInfo, GeneralForm _ _ unfolding _) -> 
+	(Nothing, NoStrictnessInfo, GenForm _ _ unfolding _) ->
 			-- We have an unfolding for the expr
 			-- Assume the unfolding has no free variables since it
 			-- came from inside the Id
@@ -429,14 +419,14 @@ absId anal var env
 		--        "U(U(U(U(SL)LLLLLLLLL)LL)LLLLLSLLLLL)" _N_ _N_ #-}
 
 
-	(Nothing, strictness_info, _) -> 	
+	(Nothing, strictness_info, _) ->
 			-- Includes MagicForm, IWantToBeINLINEd, NoUnfoldingDetails
 			-- Try the strictness info
 			absValFromStrictness anal strictness_info
 
 
 	-- 	Done via strictness now
-	--	  GeneralForm _ BottomForm _ _ -> AbsBot
+	--	  GenForm _ BottomForm _ _ -> AbsBot
     in
     -- pprTrace "absId:" (ppBesides [ppr PprDebug var, ppStr "=:", pp_anal anal, ppStr ":=",ppr PprDebug result]) (
     result
@@ -445,16 +435,16 @@ absId anal var env
     pp_anal StrAnal = ppStr "STR"
     pp_anal AbsAnal = ppStr "ABS"
 
-absEvalAtom anal (CoVarAtom v) env = absId anal v env
-absEvalAtom anal (CoLitAtom _) env = AbsTop
+absEvalAtom anal (VarArg v) env = absId anal v env
+absEvalAtom anal (LitArg _) env = AbsTop
 \end{code}
 
 \begin{code}
-absEval :: AnalysisKind -> PlainCoreExpr -> AbsValEnv -> AbsVal
+absEval :: AnalysisKind -> CoreExpr -> AbsValEnv -> AbsVal
 
-absEval anal (CoVar var) env = absId anal var env
+absEval anal (Var var) env = absId anal var env
 
-absEval anal (CoLit _) env = AbsTop
+absEval anal (Lit _) env = AbsTop
     -- What if an unboxed literal?  That's OK: it terminates, so its
     -- abstract value is AbsTop.
 
@@ -484,12 +474,12 @@ Things are a little different for absence analysis, because we want
 to make sure that any poison (?????)
 
 \begin{code}
-absEval StrAnal (CoPrim SeqOp [t] [e]) env
+absEval StrAnal (Prim SeqOp [t] [e]) env
   = if isBot (absEvalAtom StrAnal e env) then AbsBot else AbsTop
 	-- This is a special case to ensure that seq# is strict in its argument.
 	-- The comments below (for most normal PrimOps) do not apply.
 
-absEval StrAnal (CoPrim op ts es) env = AbsTop
+absEval StrAnal (Prim op ts es) env = AbsTop
 	-- The arguments are all of unboxed type, so they will already
 	-- have been eval'd.  If the boxed version was bottom, we'll
 	-- already have returned bottom.
@@ -500,21 +490,21 @@ absEval StrAnal (CoPrim op ts es) env = AbsTop
 	-- uses boxed args and we don't know whether or not it's
     	-- strict, so we assume laziness. (JSM)
 
-absEval AbsAnal (CoPrim op ts as) env 
+absEval AbsAnal (Prim op ts as) env
   = if any anyBot [absEvalAtom AbsAnal a env | a <- as]
     then AbsBot
     else AbsTop
 	-- For absence analysis, we want to see if the poison shows up...
 
-absEval anal (CoCon con ts as) env
+absEval anal (Con con ts as) env
   | has_single_con
   = AbsProd [absEvalAtom anal a env | a <- as]
 
   | otherwise	-- Not single-constructor
   = case anal of
 	StrAnal -> 	-- Strictness case: it's easy: it certainly terminates
-		   AbsTop	
-	AbsAnal -> 	-- In the absence case we need to be more 
+		   AbsTop
+	AbsAnal -> 	-- In the absence case we need to be more
 			-- careful: look to see if there's any
 			-- poison in the components
 		   if any anyBot [absEvalAtom AbsAnal a env | a <- as]
@@ -526,18 +516,20 @@ absEval anal (CoCon con ts as) env
 \end{code}
 
 \begin{code}
-absEval anal (CoLam []      body) env	= absEval anal body env	-- paranoia
-absEval anal (CoLam binders body) env	= AbsFun binders body env
-absEval anal (CoTyLam ty expr)	  env	= absEval  anal expr env
-absEval anal (CoApp e1 e2)	  env	= absApply anal (absEval     anal e1 env) 
-							(absEvalAtom anal e2 env)
-absEval anal (CoTyApp expr ty)	  env	= absEval anal expr env
+absEval anal (Lam binder body) env
+  = AbsFun [binder] body env
+absEval anal (CoTyLam ty expr) env
+  = absEval  anal expr env
+absEval anal (App e1 e2) env
+  = absApply anal (absEval anal e1 env) (absEvalAtom anal e2 env)
+absEval anal (CoTyApp expr ty) env
+  = absEval anal expr env
 \end{code}
 
 For primitive cases, just GLB the branches, then LUB with the expr part.
 
 \begin{code}
-absEval anal (CoCase expr (CoPrimAlts alts deflt)) env
+absEval anal (Case expr (PrimAlts alts deflt)) env
   = let
 	expr_val    = absEval anal expr env
 	abs_alts    = [ absEval anal rhs env | (_, rhs) <- alts ]
@@ -549,9 +541,9 @@ absEval anal (CoCase expr (CoPrimAlts alts deflt)) env
 	combineCaseValues anal expr_val
 			       (abs_deflt ++ abs_alts)
 
-absEval anal (CoCase expr (CoAlgAlts alts deflt)) env
+absEval anal (Case expr (AlgAlts alts deflt)) env
   = let
-	expr_val  = absEval anal expr env 
+	expr_val  = absEval anal expr env
 	abs_alts  = [ absEvalAlgAlt anal expr_val alt env | alt <- alts ]
 	abs_deflt = absEvalDefault anal expr_val deflt env
     in
@@ -569,7 +561,7 @@ absEval anal (CoCase expr (CoAlgAlts alts deflt)) env
     result
 \end{code}
 
-For @CoLets@ we widen the value we get.  This is nothing to
+For @Lets@ we widen the value we get.  This is nothing to
 do with fixpointing.  The reason is so that we don't get an explosion
 in the amount of computation.  For example, consider:
 \begin{verbatim}
@@ -580,7 +572,7 @@ in the amount of computation.  For example, consider:
 	f x = case x of
 		p1 -> ...g r...
 		p2 -> ...g s...
-      in 
+      in
 	f e
 \end{verbatim}
 If we bind @f@ and @g@ to their exact abstract value, then we'll
@@ -594,31 +586,27 @@ alternative approach would be to try with a certain amount of ``fuel''
 and be prepared to bale out.
 
 \begin{code}
-absEval anal (CoLet (CoNonRec binder e1) e2) env
+absEval anal (Let (NonRec binder e1) e2) env
   = let
 	new_env = addOneToAbsValEnv env binder (widen anal (absEval anal e1 env))
     in
-	-- The binder of a CoNonRec should *not* be of unboxed type,
+	-- The binder of a NonRec should *not* be of unboxed type,
 	-- hence no need to strictly evaluate the Rhs.
     absEval anal e2 new_env
 
-absEval anal (CoLet (CoRec pairs) body) env
+absEval anal (Let (Rec pairs) body) env
   = let
 	(binders,rhss) = unzip pairs
 	rhs_vals = cheapFixpoint anal binders rhss env	-- Returns widened values
 	new_env  = growAbsValEnvList env (binders `zip` rhs_vals)
     in
     absEval anal body new_env
-\end{code}
-
-\begin{code}
-absEval anal (CoSCC cc expr) env = absEval anal expr env
 
--- ToDo: add DPH stuff here
+absEval anal (SCC cc expr) env = absEval anal expr env
 \end{code}
 
 \begin{code}
-absEvalAlgAlt :: AnalysisKind -> AbsVal -> (Id,[Id],PlainCoreExpr) -> AbsValEnv -> AbsVal
+absEvalAlgAlt :: AnalysisKind -> AbsVal -> (Id,[Id],CoreExpr) -> AbsValEnv -> AbsVal
 
 absEvalAlgAlt anal (AbsProd arg_vals) (con, args, rhs) env
   =	-- The scrutinee is a product value, so it must be of a single-constr
@@ -646,15 +634,15 @@ absEvalAlgAlt anal other_scrutinee (con, args, rhs) env
 	  _ 	 -> False   -- party over
 	}
 
- 
-absEvalDefault :: AnalysisKind 
+
+absEvalDefault :: AnalysisKind
 	       -> AbsVal		-- Value of scrutinee
-	       -> PlainCoreCaseDefault 
-	       -> AbsValEnv 
+	       -> CoreCaseDefault
+	       -> AbsValEnv
 	       -> [AbsVal]		-- Empty or singleton
 
-absEvalDefault anal scrut_val CoNoDefault env = []
-absEvalDefault anal scrut_val (CoBindDefault binder expr) env	   
+absEvalDefault anal scrut_val NoDefault env = []
+absEvalDefault anal scrut_val (BindDefault binder expr) env
   = [absEval anal expr (addOneToAbsValEnv env binder scrut_val)]
 \end{code}
 
@@ -673,7 +661,7 @@ absApply anal AbsBot arg = AbsBot
   -- AbsBot represents the abstract bottom *function* too
 
 absApply StrAnal AbsTop	arg = AbsTop
-absApply AbsAnal AbsTop	arg = if anyBot arg 
+absApply AbsAnal AbsTop	arg = if anyBot arg
 			      then AbsBot
 			      else AbsTop
 	-- To be conservative, we have to assume that a function about
@@ -682,7 +670,7 @@ absApply AbsAnal AbsTop	arg = if anyBot arg
 \end{code}
 
 An @AbsFun@ with only one more argument needed---bind it and eval the
-result.	 A @CoLam@ with two or more args: return another @AbsFun@ with
+result.	 A @Lam@ with two or more args: return another @AbsFun@ with
 an augmented environment.
 
 \begin{code}
@@ -741,8 +729,8 @@ See notes on @addStrictnessInfoToId@.
 
 \begin{code}
 findStrictness :: StrAnalFlags
-	       -> [UniType]	-- Types of args in which strictness is wanted
-	       -> AbsVal 	-- Abstract strictness value of function 
+	       -> [Type]	-- Types of args in which strictness is wanted
+	       -> AbsVal 	-- Abstract strictness value of function
 	       -> AbsVal	-- Abstract absence value of function
 	       -> [Demand]	-- Resulting strictness annotation
 
@@ -764,7 +752,7 @@ findStrictness strflags (ty:tys) str_val abs_val
 
 \begin{code}
 findDemandStrOnly str_env expr binder 	-- Only strictness environment available
-  = findRecDemand strflags [] str_fn abs_fn (getIdUniType binder)
+  = findRecDemand strflags [] str_fn abs_fn (idType binder)
   where
     str_fn val = absEval StrAnal expr (addOneToAbsValEnv str_env binder val)
     abs_fn val = AbsBot		-- Always says poison; so it looks as if
@@ -772,17 +760,17 @@ findDemandStrOnly str_env expr binder 	-- Only strictness environment available
     strflags   = getStrAnalFlags str_env
 
 findDemandAbsOnly abs_env expr binder 	-- Only absence environment available
-  = findRecDemand strflags [] str_fn abs_fn (getIdUniType binder)
+  = findRecDemand strflags [] str_fn abs_fn (idType binder)
   where
     str_fn val = AbsBot		-- Always says non-termination;
 				-- that'll make findRecDemand peer into the
 				-- structure of the value.
     abs_fn val = absEval AbsAnal expr (addOneToAbsValEnv abs_env binder val)
     strflags   = getStrAnalFlags abs_env
-  
+
 
 findDemand str_env abs_env expr binder
-  = findRecDemand strflags [] str_fn abs_fn (getIdUniType binder)
+  = findRecDemand strflags [] str_fn abs_fn (idType binder)
   where
     str_fn val = absEval StrAnal expr (addOneToAbsValEnv str_env binder val)
     abs_fn val = absEval AbsAnal expr (addOneToAbsValEnv abs_env binder val)
@@ -827,7 +815,7 @@ findRecDemand :: StrAnalFlags
 				    -- zooming into recursive types
 	      -> (AbsVal -> AbsVal) -- The strictness function
 	      -> (AbsVal -> AbsVal) -- The absence function
-	      -> UniType 	    -- The type of the argument
+	      -> Type 	    -- The type of the argument
 	      -> Demand
 
 findRecDemand strflags seen str_fn abs_fn ty
@@ -845,7 +833,7 @@ findRecDemand strflags seen str_fn abs_fn ty
 
     else -- It's strict (or we're pretending it is)!
 
-       case getUniDataTyCon_maybe ty of
+       case maybeDataTyCon ty of
 
 	 Nothing    -> wwStrict
 
@@ -886,7 +874,7 @@ findRecDemand strflags seen str_fn abs_fn ty
     (all_strict, num_strict) = strflags
 
     is_numeric_type ty
-      = case (getUniDataTyCon_maybe ty) of -- NB: duplicates stuff done above
+      = case (maybeDataTyCon ty) of -- NB: duplicates stuff done above
 	  Nothing -> False
 	  Just (tycon, _, _)
 	    | tycon `is_elem`
@@ -926,7 +914,7 @@ That allows us to make rapid progress, at the cost of a less-than-wonderful
 approximation.
 
 \begin{code}
-cheapFixpoint :: AnalysisKind -> [Id] -> [PlainCoreExpr] -> AbsValEnv -> [AbsVal]
+cheapFixpoint :: AnalysisKind -> [Id] -> [CoreExpr] -> AbsValEnv -> [AbsVal]
 
 cheapFixpoint AbsAnal [id] [rhs] env
   = [crudeAbsWiden (absEval AbsAnal rhs new_env)]
@@ -948,7 +936,7 @@ cheapFixpoint anal ids rhss env
   = [widen anal (absEval anal rhs new_env) | rhs <- rhss]
 		-- We do just one iteration, starting from a safe
 		-- approximation.  This won't do a good job in situations
-		-- like:	
+		-- like:
 		--	\x -> letrec f = ...g...
 		--		     g = ...f...x...
 		--	      in
@@ -980,16 +968,16 @@ mkLookupFun eq lt alist s
 \end{verbatim}
 
 \begin{code}
-fixpoint :: AnalysisKind -> [Id] -> [PlainCoreExpr] -> AbsValEnv -> [AbsVal]
+fixpoint :: AnalysisKind -> [Id] -> [CoreExpr] -> AbsValEnv -> [AbsVal]
 
 fixpoint anal [] _ env = []
 
-fixpoint anal ids rhss env 
+fixpoint anal ids rhss env
   = fix_loop initial_vals
   where
     initial_val id
       = case anal of	-- The (unsafe) starting point
-	  StrAnal -> if (returnsRealWorld (getIdUniType id))
+	  StrAnal -> if (returnsRealWorld (idType id))
 		     then AbsTop -- this is a massively horrible hack (SLPJ 95/05)
 		     else AbsBot
 	  AbsAnal -> AbsTop
@@ -998,15 +986,18 @@ fixpoint anal ids rhss env
 
     fix_loop :: [AbsVal] -> [AbsVal]
 
-    fix_loop current_widened_vals 
+    fix_loop current_widened_vals
       = let
 	    new_env  = growAbsValEnvList env (ids `zip` current_widened_vals)
 	    new_vals = [ absEval anal rhs new_env | rhs <- rhss ]
 	    new_widened_vals = map (widen anal) new_vals
-        in
+	in
 	if (and (zipWith sameVal current_widened_vals new_widened_vals)) then
 	    current_widened_vals
 
+	    -- NB: I was too chicken to make that a zipWithEqual,
+	    -- lest I jump into a black hole.  WDP 96/02
+
 	    -- Return the widened values.  We might get a slightly
 	    -- better value by returning new_vals (which we used to
 	    -- do, see below), but alas that means that whenever the
@@ -1035,7 +1026,7 @@ isn't safe).  Why isn't @AbsTop@ safe?  Consider:
 	letrec
 	  x = ...p..d...
 	  d = (x,y)
-	in 	
+	in
 	...
 \end{verbatim}
 Here, if p is @AbsBot@, then we'd better {\em not} end up with a ``fixed
diff --git a/ghc/compiler/stranal/SaLib.hi b/ghc/compiler/stranal/SaLib.hi
deleted file mode 100644
index 88303bc128..0000000000
--- a/ghc/compiler/stranal/SaLib.hi
+++ /dev/null
@@ -1,38 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface SaLib where
-import BasicLit(BasicLit)
-import CoreSyn(CoreAtom, CoreBinding, CoreCaseAlternatives, CoreExpr)
-import CostCentre(CostCentre)
-import Id(Id)
-import IdEnv(IdEnv(..))
-import IdInfo(Demand, StrictnessInfo)
-import Maybes(Labda)
-import Outputable(Outputable)
-import PlainCore(PlainCoreExpr(..))
-import PrimOps(PrimOp)
-import TyVar(TyVar)
-import UniType(UniType)
-import UniqFM(UniqFM)
-import Unique(Unique)
-data AbsVal   = AbsTop | AbsBot | AbsProd [AbsVal] | AbsFun [Id] (CoreExpr Id Id) AbsValEnv | AbsApproxFun [Demand]
-data AbsValEnv 
-type AbsenceEnv = AbsValEnv
-data AnalysisKind   = StrAnal | AbsAnal
-data CoreExpr a b 
-data Id 
-type IdEnv a = UniqFM a
-data Demand 
-type PlainCoreExpr = CoreExpr Id Id
-type StrAnalFlags = (Bool, Bool)
-type StrictEnv = AbsValEnv
-data UniqFM a 
-data Unique 
-absValFromStrictness :: AnalysisKind -> StrictnessInfo -> AbsVal
-addOneToAbsValEnv :: AbsValEnv -> Id -> AbsVal -> AbsValEnv
-getStrAnalFlags :: AbsValEnv -> (Bool, Bool)
-growAbsValEnvList :: AbsValEnv -> [(Id, AbsVal)] -> AbsValEnv
-lookupAbsValEnv :: AbsValEnv -> Id -> Labda AbsVal
-nullAbsValEnv :: (Bool, Bool) -> AbsValEnv
-instance Outputable AbsVal
-instance Text AnalysisKind
-
diff --git a/ghc/compiler/stranal/SaLib.lhs b/ghc/compiler/stranal/SaLib.lhs
index 52f66506ac..c4b7797d26 100644
--- a/ghc/compiler/stranal/SaLib.lhs
+++ b/ghc/compiler/stranal/SaLib.lhs
@@ -15,20 +15,14 @@ module SaLib (
 	StrAnalFlags(..), getStrAnalFlags,
 	nullAbsValEnv, addOneToAbsValEnv, growAbsValEnvList,
 	lookupAbsValEnv,
-	absValFromStrictness,
+	absValFromStrictness
 
 	-- and to make the interface self-sufficient...
-	CoreExpr, Id, IdEnv(..), UniqFM, Unique,
-	Demand, PlainCoreExpr(..)
     ) where
 
-import IdEnv
 import IdInfo
---import FiniteMap	-- debugging only
 import Outputable
-import PlainCore
 import Pretty
-import Util		-- for pragmas only
 \end{code}
 
 %************************************************************************
@@ -64,7 +58,7 @@ data AbsVal
 
   | AbsFun	    	    -- An abstract function, with the given:
 	    [Id]	    -- arguments
-	    PlainCoreExpr   -- body
+	    CoreExpr   -- body
 	    AbsValEnv	    -- and environment
 
   | AbsApproxFun	    -- This is used to represent a coarse
@@ -73,7 +67,7 @@ data AbsVal
 			    -- argument if the i'th element of the Demand
 			    -- list so indicates.
 			    -- The list of arguments is always non-empty.
-			    -- In effect, AbsApproxFun [] = AbsTop 
+			    -- In effect, AbsApproxFun [] = AbsTop
 
 instance Outputable AbsVal where
     ppr sty AbsTop = ppStr "AbsTop"
@@ -91,7 +85,7 @@ instance Outputable AbsVal where
 
 An @AbsValEnv@ maps @Ids@ to @AbsVals@.  Any unbound @Ids@ are
 implicitly bound to @AbsTop@, the completely uninformative,
-pessimistic value---see @absEval@ of a @CoVar@.
+pessimistic value---see @absEval@ of a @Var@.
 
 \begin{code}
 data AbsValEnv = AbsValEnv StrAnalFlags (IdEnv AbsVal)
diff --git a/ghc/compiler/stranal/StrictAnal.hi b/ghc/compiler/stranal/StrictAnal.hi
deleted file mode 100644
index 6ba8ea2354..0000000000
--- a/ghc/compiler/stranal/StrictAnal.hi
+++ /dev/null
@@ -1,9 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface StrictAnal where
-import CmdLineOpts(GlobalSwitch)
-import CoreSyn(CoreBinding)
-import Id(Id)
-import SplitUniq(SplitUniqSupply)
-saTopBinds :: (Bool, Bool) -> [CoreBinding Id Id] -> [CoreBinding Id Id]
-saWwTopBinds :: SplitUniqSupply -> (GlobalSwitch -> Bool) -> [CoreBinding Id Id] -> [CoreBinding Id Id]
-
diff --git a/ghc/compiler/stranal/StrictAnal.lhs b/ghc/compiler/stranal/StrictAnal.lhs
index 5e83966046..f98e5e4285 100644
--- a/ghc/compiler/stranal/StrictAnal.lhs
+++ b/ghc/compiler/stranal/StrictAnal.lhs
@@ -1,5 +1,5 @@
 %
-% (c) The GRASP/AQUA Project, Glasgow University, 1993-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1993-1996
 %
 \section[StrictAnal]{``Simple'' Mycroft-style strictness analyser}
 
@@ -11,23 +11,13 @@ Semantique analyser) was written by Andy Gill.
 
 module StrictAnal ( saWwTopBinds, saTopBinds ) where
 
-IMPORT_Trace
-import Outputable
-import Pretty
-
-import CmdLineOpts	( GlobalSwitch(..) )
-import CoreSyn		-- ToDo: get pprCoreBinding straight from PlainCore?
 import Id		( addIdDemandInfo, isWrapperId, addIdStrictness,
-			  getIdUniType, getIdDemandInfo
-			  IF_ATTACK_PRAGMAS(COMMA getIdStrictness) -- profiling
+			  idType, getIdDemandInfo
 			)
-import IdEnv
 import IdInfo
-import PlainCore
 import SaAbsInt
 import SaLib
-import SplitUniq
-import Unique
+import UniqSupply
 import Util
 import WorkWrap		-- "back-end" of strictness analyser
 import WwLib		( WwM(..) )
@@ -49,12 +39,12 @@ A note about worker-wrappering.  If we have
 and we deduce that f is strict, it is nevertheless NOT safe to worker-wapper to
 
 	f = \x -> case x of Int x# -> fw x#
-	fw = \x# -> let x = Int x# 
-		    in 
+	fw = \x# -> let x = Int x#
+		    in
 		    let v = <expensive>
 		    in <body>
 
-because this obviously loses laziness, since now <expensive> 
+because this obviously loses laziness, since now <expensive>
 is done each time.  Alas.
 
 WATCH OUT!  This can mean that something is unboxed only to be
@@ -81,10 +71,10 @@ Alas and alack.
 %************************************************************************
 
 \begin{code}
-saWwTopBinds :: SplitUniqSupply
+saWwTopBinds :: UniqSupply
 	     -> (GlobalSwitch -> Bool)
-	     -> [PlainCoreBinding]
-	     -> [PlainCoreBinding]
+	     -> [CoreBinding]
+	     -> [CoreBinding]
 
 saWwTopBinds us switch_chker binds
   = let
@@ -151,8 +141,8 @@ environment which maps @Id@s to their abstract values (i.e., an
 @AbsValEnv@ maps an @Id@ to its @AbsVal@).
 
 \begin{code}
-saTopBinds   :: StrAnalFlags -> [PlainCoreBinding] -> [PlainCoreBinding]     -- exported
-sa_top_binds :: StrAnalFlags -> [PlainCoreBinding] -> SaM [PlainCoreBinding] -- not exported
+saTopBinds   :: StrAnalFlags -> [CoreBinding] -> [CoreBinding]     -- exported
+sa_top_binds :: StrAnalFlags -> [CoreBinding] -> SaM [CoreBinding] -- not exported
 
 saTopBinds strflags binds
 #ifndef OMIT_STRANAL_STATS
@@ -181,10 +171,10 @@ be used; we can't turn top-level @let@s into @case@s.
 
 \begin{code}
 saTopBind :: StrictEnv -> AbsenceEnv
-	  -> PlainCoreBinding
-	  -> SaM (StrictEnv, AbsenceEnv, PlainCoreBinding)
+	  -> CoreBinding
+	  -> SaM (StrictEnv, AbsenceEnv, CoreBinding)
 
-saTopBind str_env abs_env (CoNonRec binder rhs)
+saTopBind str_env abs_env (NonRec binder rhs)
   = saExpr str_env abs_env rhs 	`thenSa` \ new_rhs ->
     let
 	strflags = getStrAnalFlags str_env
@@ -195,7 +185,7 @@ saTopBind str_env abs_env (CoNonRec binder rhs)
 	widened_str_rhs = widen StrAnal str_rhs
 	widened_abs_rhs = widen AbsAnal abs_rhs
 		-- The widening above is done for efficiency reasons.
-		-- See notes on CoLet case in SaAbsInt.lhs
+		-- See notes on Let case in SaAbsInt.lhs
 
 	new_binder
 	  = addStrictnessInfoToId
@@ -209,9 +199,9 @@ saTopBind str_env abs_env (CoNonRec binder rhs)
       	new_str_env = addOneToAbsValEnv str_env binder widened_str_rhs
       	new_abs_env = addOneToAbsValEnv abs_env binder widened_abs_rhs
     in
-    returnSa (new_str_env, new_abs_env, CoNonRec new_binder new_rhs)
+    returnSa (new_str_env, new_abs_env, NonRec new_binder new_rhs)
 
-saTopBind str_env abs_env (CoRec pairs)
+saTopBind str_env abs_env (Rec pairs)
   = let
 	strflags    = getStrAnalFlags str_env
 	(binders,rhss) = unzip pairs
@@ -220,14 +210,14 @@ saTopBind str_env abs_env (CoRec pairs)
 		      -- fixpoint returns widened values
       	new_str_env = growAbsValEnvList str_env (binders `zip` str_rhss)
       	new_abs_env = growAbsValEnvList abs_env (binders `zip` abs_rhss)
-	new_binders = zipWith4 (addStrictnessInfoToId strflags)
-				str_rhss abs_rhss binders rhss
+	new_binders = zipWith4Equal (addStrictnessInfoToId strflags)
+				    str_rhss abs_rhss binders rhss
     in
     mapSa (saExpr new_str_env new_abs_env) rhss	`thenSa` \ new_rhss ->
     let
 	new_pairs   = new_binders `zip` new_rhss
     in
-    returnSa (new_str_env, new_abs_env, CoRec new_pairs)
+    returnSa (new_str_env, new_abs_env, Rec new_pairs)
 \end{code}
 
 %************************************************************************
@@ -240,42 +230,42 @@ saTopBind str_env abs_env (CoRec pairs)
 environment.
 
 \begin{code}
-saExpr :: StrictEnv -> AbsenceEnv -> PlainCoreExpr -> SaM PlainCoreExpr
+saExpr :: StrictEnv -> AbsenceEnv -> CoreExpr -> SaM CoreExpr
 
-saExpr _ _ e@(CoVar _)      = returnSa e
-saExpr _ _ e@(CoLit _)      = returnSa e
-saExpr _ _ e@(CoCon _ _ _)  = returnSa e
-saExpr _ _ e@(CoPrim _ _ _) = returnSa e
+saExpr _ _ e@(Var _)      = returnSa e
+saExpr _ _ e@(Lit _)      = returnSa e
+saExpr _ _ e@(Con _ _ _)  = returnSa e
+saExpr _ _ e@(Prim _ _ _) = returnSa e
 
-saExpr str_env abs_env (CoLam args body)
+saExpr str_env abs_env (Lam arg body)
   = saExpr str_env abs_env body	`thenSa` \ new_body ->
     let
-      	new_args  = addDemandInfoToIds str_env abs_env body args
+	new_arg = addDemandInfoToId str_env abs_env body arg
     in
-    tickLambdas new_args	`thenSa_` -- stats
-    returnSa (CoLam new_args new_body)
+    tickLambda new_arg	`thenSa_` -- stats
+    returnSa (Lam new_arg new_body)
 
 saExpr str_env abs_env (CoTyLam ty expr)
   = saExpr str_env abs_env expr	`thenSa` \ new_expr ->
     returnSa (CoTyLam ty new_expr)
 
-saExpr str_env abs_env (CoApp fun arg)
+saExpr str_env abs_env (App fun arg)
   = saExpr str_env abs_env fun	`thenSa` \ new_fun ->
-    returnSa (CoApp new_fun arg)
+    returnSa (App new_fun arg)
 
 saExpr str_env abs_env (CoTyApp expr ty)
   = saExpr str_env abs_env expr	`thenSa` \ new_expr ->
     returnSa (CoTyApp new_expr ty)
 
-saExpr str_env abs_env (CoSCC cc expr)
+saExpr str_env abs_env (SCC cc expr)
   = saExpr str_env abs_env expr	`thenSa` \ new_expr ->
-    returnSa (CoSCC cc new_expr)
+    returnSa (SCC cc new_expr)
 
-saExpr str_env abs_env (CoCase expr (CoAlgAlts alts deflt))
+saExpr str_env abs_env (Case expr (AlgAlts alts deflt))
   = saExpr    str_env abs_env expr  `thenSa` \ new_expr  ->
     saDefault str_env abs_env deflt `thenSa` \ new_deflt ->
     mapSa sa_alt alts		    `thenSa` \ new_alts  ->
-    returnSa (CoCase new_expr (CoAlgAlts new_alts new_deflt))
+    returnSa (Case new_expr (AlgAlts new_alts new_deflt))
   where
     sa_alt (con, binders, rhs)
       = saExpr str_env abs_env rhs  `thenSa` \ new_rhs ->
@@ -285,17 +275,17 @@ saExpr str_env abs_env (CoCase expr (CoAlgAlts alts deflt))
 	tickCases new_binders	    `thenSa_` -- stats
 	returnSa (con, new_binders, new_rhs)
 
-saExpr str_env abs_env (CoCase expr (CoPrimAlts alts deflt))
+saExpr str_env abs_env (Case expr (PrimAlts alts deflt))
   = saExpr    str_env abs_env expr  `thenSa` \ new_expr  ->
     saDefault str_env abs_env deflt `thenSa` \ new_deflt ->
     mapSa sa_alt alts		    `thenSa` \ new_alts  ->
-    returnSa (CoCase new_expr (CoPrimAlts new_alts new_deflt))
+    returnSa (Case new_expr (PrimAlts new_alts new_deflt))
   where
     sa_alt (lit, rhs)
       = saExpr str_env abs_env rhs `thenSa` \ new_rhs ->
 	returnSa (lit, new_rhs)
 
-saExpr str_env abs_env (CoLet (CoNonRec binder rhs) body)
+saExpr str_env abs_env (Let (NonRec binder rhs) body)
   =	-- Analyse the RHS in the environment at hand
     saExpr str_env abs_env rhs  `thenSa` \ new_rhs  ->
     let
@@ -309,7 +299,7 @@ saExpr str_env abs_env (CoLet (CoNonRec binder rhs) body)
 	widened_str_rhs = widen StrAnal str_rhs_val
 	widened_abs_rhs = widen AbsAnal abs_rhs_val
 		-- The widening above is done for efficiency reasons.
-		-- See notes on CoLet case in SaAbsInt.lhs
+		-- See notes on Let case in SaAbsInt.lhs
 
       	new_str_env	= addOneToAbsValEnv str_env binder widened_str_rhs
       	new_abs_env	= addOneToAbsValEnv abs_env binder widened_abs_rhs
@@ -323,9 +313,9 @@ saExpr str_env abs_env (CoLet (CoNonRec binder rhs) body)
     in
     tickLet new_binder			`thenSa_` -- stats
     saExpr new_str_env new_abs_env body	`thenSa` \ new_body ->
-    returnSa (CoLet (CoNonRec new_binder new_rhs) new_body)
+    returnSa (Let (NonRec new_binder new_rhs) new_body)
 
-saExpr str_env abs_env (CoLet (CoRec pairs) body)
+saExpr str_env abs_env (Let (Rec pairs) body)
   = let
 	strflags       = getStrAnalFlags str_env
 	(binders,rhss) = unzip pairs
@@ -339,7 +329,7 @@ saExpr str_env abs_env (CoLet (CoRec pairs) body)
     mapSa (saExpr new_str_env new_abs_env) rhss	`thenSa` \ new_rhss ->
     let
 --	new_binders      = addDemandInfoToIds new_str_env new_abs_env body binders
--- 		DON'T add demand info in a CoRec!
+-- 		DON'T add demand info in a Rec!
 --		a) it's useless: we can't do let-to-case
 --		b) it's incorrect.  Consider
 --			letrec x = ...y...
@@ -350,28 +340,28 @@ saExpr str_env abs_env (CoLet (CoRec pairs) body)
 --		   deciding that y is absent, which is plain wrong!
 --		It's much easier simply not to do this.
 
-	improved_binders = zipWith4 (addStrictnessInfoToId strflags)
-				    str_vals abs_vals binders rhss
+	improved_binders = zipWith4Equal (addStrictnessInfoToId strflags)
+				         str_vals abs_vals binders rhss
 
 	whiter_than_white_binders = launder improved_binders
 
       	new_pairs   = whiter_than_white_binders `zip` new_rhss
     in
-    returnSa (CoLet (CoRec new_pairs) new_body)
+    returnSa (Let (Rec new_pairs) new_body)
   where
     launder me = {-still-} me
 \end{code}
 
 \begin{code}
-saDefault str_env abs_env CoNoDefault = returnSa CoNoDefault
+saDefault str_env abs_env NoDefault = returnSa NoDefault
 
-saDefault str_env abs_env (CoBindDefault bdr rhs)
+saDefault str_env abs_env (BindDefault bdr rhs)
   = saExpr str_env abs_env rhs	`thenSa` \ new_rhs ->
     let
 	new_bdr = addDemandInfoToId str_env abs_env rhs bdr
     in
     tickCases [new_bdr]		`thenSa_` -- stats
-    returnSa (CoBindDefault new_bdr new_rhs)
+    returnSa (BindDefault new_bdr new_rhs)
 \end{code}
 
 
@@ -393,26 +383,26 @@ A better idea might be to have some kind of arity analysis to
 tell how many args could safely be grabbed.
 
 \begin{code}
-addStrictnessInfoToId 
+addStrictnessInfoToId
 	:: StrAnalFlags
 	-> AbsVal 		-- Abstract strictness value
 	-> AbsVal		-- Ditto absence
 	-> Id 			-- The id
-	-> PlainCoreExpr	-- Its RHS
+	-> CoreExpr	-- Its RHS
 	-> Id			-- Augmented with strictness
 
 addStrictnessInfoToId strflags str_val abs_val binder body
   = if isWrapperId binder then
-	binder	-- Avoid clobbering existing strictness info 
+	binder	-- Avoid clobbering existing strictness info
 		-- (and, more importantly, worker info).
 		-- Deeply suspicious (SLPJ)
     else
     if (isBot str_val) then
 	binder `addIdStrictness` mkBottomStrictnessInfo
     else
-	case (digForLambdas body) of { (_, lambda_bounds, rhs) ->
-        let
-		tys        = map getIdUniType lambda_bounds
+	case (digForLambdas body) of { (_, _, lambda_bounds, rhs) ->
+	let
+		tys        = map idType lambda_bounds
 		strictness = findStrictness strflags tys str_val abs_val
 	in
 	binder `addIdStrictness` mkStrictnessInfo strictness Nothing
@@ -420,17 +410,17 @@ addStrictnessInfoToId strflags str_val abs_val binder body
 \end{code}
 
 \begin{code}
-addDemandInfoToId :: StrictEnv -> AbsenceEnv 
-		  -> PlainCoreExpr 	-- The scope of the id
-		  -> Id 
+addDemandInfoToId :: StrictEnv -> AbsenceEnv
+		  -> CoreExpr 	-- The scope of the id
+		  -> Id
 		  -> Id			-- Id augmented with Demand info
 
 addDemandInfoToId str_env abs_env expr binder
   = binder `addIdDemandInfo` (mkDemandInfo (findDemand str_env abs_env expr binder))
 
-addDemandInfoToIds :: StrictEnv -> AbsenceEnv -> PlainCoreExpr -> [Id] -> [Id]
+addDemandInfoToIds :: StrictEnv -> AbsenceEnv -> CoreExpr -> [Id] -> [Id]
 
-addDemandInfoToIds str_env abs_env expr binders 
+addDemandInfoToIds str_env abs_env expr binders
   = map (addDemandInfoToId str_env abs_env expr) binders
 \end{code}
 
@@ -453,15 +443,13 @@ thenSa	      :: SaM a -> (a -> SaM b) -> SaM b
 thenSa_	      :: SaM a -> SaM b -> SaM b
 returnSa      :: a -> SaM a
 
-#ifdef __GLASGOW_HASKELL__
 {-# INLINE thenSa #-}
 {-# INLINE thenSa_ #-}
 {-# INLINE returnSa #-}
-#endif
 
-tickLambdas :: [Id] -> SaM ()
-tickCases   :: [Id] -> SaM ()
-tickLet     :: Id   -> SaM ()
+tickLambda :: [Id] -> SaM ()
+tickCases  :: [Id] -> SaM ()
+tickLet    :: Id   -> SaM ()
 
 #ifndef OMIT_STRANAL_STATS
 type SaM a = SaStats -> (a, SaStats)
@@ -476,8 +464,8 @@ thenSa_ expr cont stats
 
 returnSa x stats = (x, stats)
 
-tickLambdas vars (SaStats tlam dlam tc dc tlet dlet)
-  = case (foldr tick_demanded (0,0) vars) of { (IBOX(tot), IBOX(demanded)) ->
+tickLambda var (SaStats tlam dlam tc dc tlet dlet)
+  = case (tick_demanded (0,0) var) of { (IBOX(tot), IBOX(demanded)) ->
     ((), SaStats (tlam _ADD_ tot) (dlam _ADD_ demanded) tc dc tlet dlet) }
 
 tickCases vars (SaStats tlam dlam tc dc tlet dlet)
@@ -504,9 +492,9 @@ thenSa_ expr cont = cont
 
 returnSa x = x
 
-tickLambdas vars = panic "OMIT_STRANAL_STATS: tickLambdas"
-tickCases   vars = panic "OMIT_STRANAL_STATS: tickCases"
-tickLet     var  = panic "OMIT_STRANAL_STATS: tickLet"
+tickLambda var  = panic "OMIT_STRANAL_STATS: tickLambda"
+tickCases  vars = panic "OMIT_STRANAL_STATS: tickCases"
+tickLet    var  = panic "OMIT_STRANAL_STATS: tickLet"
 
 #endif {-OMIT_STRANAL_STATS-}
 
diff --git a/ghc/compiler/stranal/WorkWrap.hi b/ghc/compiler/stranal/WorkWrap.hi
deleted file mode 100644
index 96bbdb672d..0000000000
--- a/ghc/compiler/stranal/WorkWrap.hi
+++ /dev/null
@@ -1,8 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface WorkWrap where
-import CmdLineOpts(GlobalSwitch)
-import CoreSyn(CoreBinding)
-import Id(Id)
-import SplitUniq(SplitUniqSupply)
-workersAndWrappers :: [CoreBinding Id Id] -> SplitUniqSupply -> (GlobalSwitch -> Bool) -> [CoreBinding Id Id]
-
diff --git a/ghc/compiler/stranal/WorkWrap.lhs b/ghc/compiler/stranal/WorkWrap.lhs
index a43cd72032..bda7de10b1 100644
--- a/ghc/compiler/stranal/WorkWrap.lhs
+++ b/ghc/compiler/stranal/WorkWrap.lhs
@@ -12,13 +12,12 @@ IMPORT_Trace
 import Outputable
 import Pretty
 
-import Id		( getIdUniType, addIdStrictness, getIdStrictness,
+import Id		( idType, addIdStrictness, getIdStrictness,
 			  getIdUnfolding, mkWorkerId,
 			  replaceIdInfo, getIdInfo, idWantsToBeINLINEd
 			)
 import IdInfo		-- bits and pieces
 import Maybes		( maybeToBool, Maybe(..) )
-import PlainCore
 import SaLib
 import SrcLoc		( mkUnknownSrcLoc, SrcLoc )
 import Util
@@ -38,7 +37,7 @@ info for exported values).
 \end{enumerate}
 
 \begin{code}
-workersAndWrappers :: [PlainCoreBinding] -> WwM [PlainCoreBinding]
+workersAndWrappers :: [CoreBinding] -> WwM [CoreBinding]
 
 workersAndWrappers top_binds
   = mapWw (wwBind True{-top-level-}) top_binds `thenWw` \ top_binds2 ->
@@ -47,7 +46,7 @@ workersAndWrappers top_binds
     in
     returnWw (concat top_binds3)
   where
-    make_top_binding :: WwBinding -> [PlainCoreBinding]
+    make_top_binding :: WwBinding -> [CoreBinding]
 
     make_top_binding (WwLet binds) = binds
 \end{code}
@@ -63,23 +62,23 @@ turn.  Non-recursive case first, then recursive...
 
 \begin{code}
 wwBind	:: Bool			-- True <=> top-level binding
-	-> PlainCoreBinding
+	-> CoreBinding
 	-> WwM WwBinding	-- returns a WwBinding intermediate form;
 				-- the caller will convert to Expr/Binding,
 				-- as appropriate.
 
-wwBind top_level (CoNonRec binder rhs)
+wwBind top_level (NonRec binder rhs)
   = wwExpr rhs			`thenWw` \ new_rhs ->
     tryWW binder new_rhs 	`thenWw` \ new_pairs ->
-    returnWw (WwLet [CoNonRec b e | (b,e) <- new_pairs])
+    returnWw (WwLet [NonRec b e | (b,e) <- new_pairs])
       -- Generated bindings must be non-recursive
       -- because the original binding was.
 
 ------------------------------
 
-wwBind top_level (CoRec pairs)
+wwBind top_level (Rec pairs)
   = mapWw do_one pairs		`thenWw` \ new_pairs ->
-    returnWw (WwLet [CoRec (concat new_pairs)])
+    returnWw (WwLet [Rec (concat new_pairs)])
   where
     do_one (binder, rhs) = wwExpr rhs 	`thenWw` \ new_rhs ->
 			   tryWW binder new_rhs
@@ -92,34 +91,34 @@ matching by looking for strict arguments of the correct type.
 ???????????????? ToDo
 
 \begin{code}
-wwExpr :: PlainCoreExpr -> WwM PlainCoreExpr
+wwExpr :: CoreExpr -> WwM CoreExpr
 
-wwExpr e@(CoVar _)	= returnWw e
-wwExpr e@(CoLit _)	= returnWw e
-wwExpr e@(CoCon  _ _ _) = returnWw e
-wwExpr e@(CoPrim _ _ _) = returnWw e
+wwExpr e@(Var _)	= returnWw e
+wwExpr e@(Lit _)	= returnWw e
+wwExpr e@(Con  _ _ _) = returnWw e
+wwExpr e@(Prim _ _ _) = returnWw e
 
-wwExpr (CoLam binders expr)
+wwExpr (Lam binders expr)
   = wwExpr expr			`thenWw` \ new_expr ->
-    returnWw (CoLam binders new_expr)
+    returnWw (Lam binders new_expr)
 
 wwExpr (CoTyLam ty expr)
   = wwExpr expr			`thenWw` \ new_expr ->
     returnWw (CoTyLam ty new_expr)
 
-wwExpr (CoApp e1 e2)
+wwExpr (App e1 e2)
   = wwExpr e1			`thenWw` \ new_e1 ->
-    returnWw (CoApp new_e1 e2)
+    returnWw (App new_e1 e2)
 
 wwExpr (CoTyApp expr ty)
   = wwExpr expr			`thenWw` \ new_expr ->
     returnWw (CoTyApp new_expr ty)
 
-wwExpr (CoSCC cc expr)
+wwExpr (SCC cc expr)
   = wwExpr expr			`thenWw` \ new_expr ->
-    returnWw (CoSCC cc new_expr)
+    returnWw (SCC cc new_expr)
 
-wwExpr (CoLet bind expr)
+wwExpr (Let bind expr)
   = wwBind False{-not top-level-} bind	`thenWw` \ intermediate_bind ->
     wwExpr expr				`thenWw` \ new_expr ->
     returnWw (mash_ww_bind intermediate_bind new_expr)
@@ -127,20 +126,20 @@ wwExpr (CoLet bind expr)
     mash_ww_bind (WwLet  binds)   body = mkCoLetsNoUnboxed binds body
     mash_ww_bind (WwCase case_fn) body = case_fn body
 
-wwExpr (CoCase expr alts)
+wwExpr (Case expr alts)
   = wwExpr expr				`thenWw` \ new_expr ->
     ww_alts alts			`thenWw` \ new_alts ->
-    returnWw (CoCase new_expr new_alts)
+    returnWw (Case new_expr new_alts)
   where
-    ww_alts (CoAlgAlts alts deflt)
+    ww_alts (AlgAlts alts deflt)
       = mapWw ww_alg_alt alts		`thenWw` \ new_alts ->
 	ww_deflt deflt			`thenWw` \ new_deflt ->
-	returnWw (CoAlgAlts new_alts new_deflt)
+	returnWw (AlgAlts new_alts new_deflt)
 
-    ww_alts (CoPrimAlts alts deflt)
+    ww_alts (PrimAlts alts deflt)
       = mapWw ww_prim_alt alts		`thenWw` \ new_alts ->
 	ww_deflt deflt			`thenWw` \ new_deflt ->
-	returnWw (CoPrimAlts new_alts new_deflt)
+	returnWw (PrimAlts new_alts new_deflt)
 
     ww_alg_alt (con, binders, rhs)
       =	wwExpr rhs			`thenWw` \ new_rhs ->
@@ -150,12 +149,12 @@ wwExpr (CoCase expr alts)
       = wwExpr rhs			`thenWw` \ new_rhs ->
 	returnWw (lit, new_rhs)
 
-    ww_deflt CoNoDefault
-      = returnWw CoNoDefault
+    ww_deflt NoDefault
+      = returnWw NoDefault
 
-    ww_deflt (CoBindDefault binder rhs)
+    ww_deflt (BindDefault binder rhs)
       = wwExpr rhs			`thenWw` \ new_rhs ->
-	returnWw (CoBindDefault binder new_rhs)
+	returnWw (BindDefault binder new_rhs)
 \end{code}
 
 %************************************************************************
@@ -178,9 +177,9 @@ The only reason this is monadised is for the unique supply.
 
 \begin{code}
 tryWW	:: Id				-- the fn binder
-	-> PlainCoreExpr		-- the bound rhs; its innards
+	-> CoreExpr		-- the bound rhs; its innards
 					--   are already ww'd
-	-> WwM [(Id, PlainCoreExpr)]	-- either *one* or *two* pairs;
+	-> WwM [(Id, CoreExpr)]	-- either *one* or *two* pairs;
 					-- if one, then no worker (only
 					-- the orig "wrapper" lives on);
 					-- if two, then a worker and a
@@ -207,16 +206,16 @@ tryWW fn_id rhs
 
 	-- OK, it looks as if a worker is worth a try
 	let
-	     (tyvars, args, body) = digForLambdas rhs
-	     body_ty		  = typeOfCoreExpr body
+	     (uvars, tyvars, args, body) = digForLambdas rhs
+	     body_ty			 = coreExprType body
 	in
 	uniqSMtoWwM (mkWwBodies body_ty tyvars args args_info) `thenWw` \ result ->
 	case result of
 
-	  Nothing -> 	-- Very peculiar. This can only happen if we hit an 
+	  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)
 			do_nothing
@@ -240,7 +239,7 @@ tryWW fn_id rhs
 		    -- worker Id:
 		    mkStrictnessInfo args_info (Just worker_id)
 
-	        wrapper_id  = fn_id `replaceIdInfo`
+		wrapper_id  = fn_id `replaceIdInfo`
 			      (getIdInfo fn_id		`addInfo`
 			       revised_strictness_info	`addInfo_UF`
 			       iWantToBeINLINEd UnfoldAlways)
diff --git a/ghc/compiler/stranal/WwLib.hi b/ghc/compiler/stranal/WwLib.hi
deleted file mode 100644
index e56b3cfa26..0000000000
--- a/ghc/compiler/stranal/WwLib.hi
+++ /dev/null
@@ -1,39 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface WwLib where
-import BasicLit(BasicLit)
-import CmdLineOpts(GlobalSwitch)
-import CoreSyn(CoreAtom, CoreBinding, CoreCaseAlternatives, CoreExpr)
-import CostCentre(CostCentre)
-import Id(Id)
-import IdInfo(Demand, StrictnessInfo)
-import Maybes(Labda, MaybeErr)
-import PlainCore(PlainCoreBinding(..), PlainCoreExpr(..))
-import PrimOps(PrimOp)
-import SplitUniq(SUniqSM(..), SplitUniqSupply)
-import TyVar(TyVar)
-import UniType(UniType)
-import Unique(Unique)
-infixr 9 `thenWw`
-data GlobalSwitch 
-data CoreBinding a b 
-data CoreExpr a b 
-data Id 
-data Demand 
-data MaybeErr a b 
-type PlainCoreBinding = CoreBinding Id Id
-type PlainCoreExpr = CoreExpr Id Id
-type SUniqSM a = SplitUniqSupply -> a
-data SplitUniqSupply 
-data TyVar 
-data UniType 
-data Unique 
-data WwBinding   = WwLet [CoreBinding Id Id] | WwCase (CoreExpr Id Id -> CoreExpr Id Id)
-type WwM a = SplitUniqSupply -> (GlobalSwitch -> Bool) -> a
-getUniqueWw :: SplitUniqSupply -> (GlobalSwitch -> Bool) -> Unique
-mAX_WORKER_ARGS :: Int
-mapWw :: (a -> SplitUniqSupply -> (GlobalSwitch -> Bool) -> b) -> [a] -> SplitUniqSupply -> (GlobalSwitch -> Bool) -> [b]
-mkWwBodies :: UniType -> [TyVar] -> [Id] -> [Demand] -> SplitUniqSupply -> Labda (Id -> CoreExpr Id Id, CoreExpr Id Id -> CoreExpr Id Id, StrictnessInfo, UniType -> UniType)
-returnWw :: a -> SplitUniqSupply -> (GlobalSwitch -> Bool) -> a
-thenWw :: (SplitUniqSupply -> (GlobalSwitch -> Bool) -> a) -> (a -> SplitUniqSupply -> (GlobalSwitch -> Bool) -> b) -> SplitUniqSupply -> (GlobalSwitch -> Bool) -> b
-uniqSMtoWwM :: (SplitUniqSupply -> a) -> SplitUniqSupply -> (GlobalSwitch -> Bool) -> a
-
diff --git a/ghc/compiler/stranal/WwLib.lhs b/ghc/compiler/stranal/WwLib.lhs
index 5367ecff62..b87bd4c61c 100644
--- a/ghc/compiler/stranal/WwLib.lhs
+++ b/ghc/compiler/stranal/WwLib.lhs
@@ -1,5 +1,5 @@
 %
-% (c) The GRASP/AQUA Project, Glasgow University, 1993-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1993-1996
 %
 \section[WwLib]{A library for the ``worker/wrapper'' back-end to the strictness analyser}
 
@@ -14,40 +14,33 @@ module WwLib (
 	-- our friendly worker/wrapper monad:
 	WwM(..),
 	returnWw, thenWw, mapWw,
-	getUniqueWw, uniqSMtoWwM,
+	getUniqueWw, uniqSMtoWwM
 
 	-- and to make the interface self-sufficient...
-	GlobalSwitch, CoreBinding, CoreExpr, PlainCoreBinding(..),
-	PlainCoreExpr(..), Id, Demand, MaybeErr,
-	TyVar, UniType, Unique, SplitUniqSupply, SUniqSM(..)
-
-	IF_ATTACK_PRAGMAS(COMMA splitUniqSupply COMMA getSUnique)
-	IF_ATTACK_PRAGMAS(COMMA mkUniqueGrimily)
     ) where
 
-IMPORT_Trace
-import Outputable	-- ToDo: rm (debugging)
-import Pretty
+import Ubiq{-uitous-}
 
-import AbsPrel		( aBSENT_ERROR_ID, mkFunTy )
-import AbsUniType	( mkTyVarTy, isPrimType, getUniDataTyCon_maybe,
-			  quantifyTy, TyVarTemplate
-			)
-import CmdLineOpts	( GlobalSwitch(..) )
-import Id		( mkWorkerId, mkSysLocal, getIdUniType,
+import PrelInfo		( aBSENT_ERROR_ID )
+{-
+import Id		( mkWorkerId, mkSysLocal, idType,
 			  getInstantiatedDataConSig, getIdInfo,
 			  replaceIdInfo, addIdStrictness, DataCon(..)
 			)
 import IdInfo		-- lots of things
 import Maybes		( maybeToBool, Maybe(..), MaybeErr )
-import PlainCore
 import SaLib
 import SrcLoc		( mkUnknownSrcLoc )
-import SplitUniq
-import Unique
-import Util
+import Type		( mkTyVarTy, mkFunTys, isPrimType,
+			  maybeDataTyCon, quantifyTy
+			)
+import UniqSupply
+-}
+import Util		( panic )
 
 infixr 9 `thenWw`
+
+quantifyTy = panic "WwLib.quantifyTy"
 \end{code}
 
 %************************************************************************
@@ -62,8 +55,8 @@ an ``intermediate form'' that can later be turned into a \tr{let} or
 
 \begin{code}
 data WwBinding
-  = WwLet  [PlainCoreBinding]
-  | WwCase (PlainCoreExpr -> PlainCoreExpr)
+  = WwLet  [CoreBinding]
+  | WwCase (CoreExpr -> CoreExpr)
 		-- the "case" will be a "strict let" of the form:
 		--
 		--  case rhs of
@@ -203,56 +196,54 @@ Lambdas are added on the front later.)
 
 \begin{code}
 mkWwBodies
-	:: UniType		-- Type of the *body* of the orig
+	:: Type		-- Type of the *body* of the orig
 				-- function; i.e. /\ tyvars -> \ vars -> body
 	-> [TyVar] 		-- Type lambda vars of original function
 	-> [Id]			-- Args of original function
 	-> [Demand]		-- Strictness info for those args
 
-	-> SUniqSM (Maybe 	-- Nothing iff (a) no interesting split possible
+	-> UniqSM (Maybe 	-- Nothing iff (a) no interesting split possible
 				-- 	       (b) any unpack on abstract type
-		     (Id -> PlainCoreExpr,		-- Wrapper expr w/ 
+		     (Id -> CoreExpr,		-- Wrapper expr w/
 							--   hole for worker id
-		      PlainCoreExpr -> PlainCoreExpr,	-- Worker expr w/ hole 
+		      CoreExpr -> CoreExpr,	-- Worker expr w/ hole
 	   						--   for original fn body
 		      StrictnessInfo,			-- Worker strictness info
-		      UniType -> UniType)		-- Worker type w/ hole
+		      Type -> Type)		-- Worker type w/ hole
 	   )						--   for type of original fn body
-		  
+
 
 mkWwBodies body_ty tyvars args arg_infos
   = ASSERT(length args == length arg_infos)
     -- or you can get disastrous user/definer-module mismatches
     if (all_absent_args_and_unboxed_value body_ty arg_infos)
-    then returnSUs Nothing
+    then returnUs Nothing
 
     else -- the rest...
     mk_ww_arg_processing args arg_infos (mAX_WORKER_ARGS - nonAbsentArgs arg_infos)
 		`thenUsMaybe` \ (wrap_frag, work_args_info, work_frag) ->
-    let 
+    let
 	(work_args, wrkr_demands) = unzip work_args_info
 
 	wrkr_strictness = mkStrictnessInfo wrkr_demands Nothing -- no worker-of-worker...
 
 	wrapper_w_hole = \ worker_id ->
-				mkCoTyLam tyvars (
-				mkCoLam args (
+				mkLam tyvars args (
 				wrap_frag (
-				mkCoTyApps (CoVar worker_id) (map mkTyVarTy tyvars)
-			 )))
+				mkCoTyApps (Var worker_id) (map mkTyVarTy tyvars)
+			 ))
 
 	worker_w_hole = \ orig_body ->
-				mkCoTyLam tyvars (
-				mkCoLam work_args (
+				mkLam tyvars work_args (
 				work_frag orig_body
-			))
+			)
 
 	worker_ty_w_hole = \ body_ty ->
 				snd (quantifyTy tyvars (
-				foldr mkFunTy body_ty (map getIdUniType work_args)
+				mkFunTys (map idType work_args) body_ty
 			   ))
     in
-    returnSUs (Just (wrapper_w_hole, worker_w_hole, wrkr_strictness, worker_ty_w_hole))
+    returnUs (Just (wrapper_w_hole, worker_w_hole, wrkr_strictness, worker_ty_w_hole))
   where
     -- "all_absent_args_and_unboxed_value":
     -- check for the obscure case of "\ x y z ... -> body" where
@@ -290,23 +281,23 @@ mk_ww_arg_processing
 				-- This prevents over-eager unpacking, leading
 				-- to huge-arity functions.
 
-	-> SUniqSM (Maybe 	-- Nothing iff any unpack on abstract type
-		     (PlainCoreExpr -> PlainCoreExpr,	-- Wrapper expr w/ 
+	-> UniqSM (Maybe 	-- Nothing iff any unpack on abstract type
+		     (CoreExpr -> CoreExpr,	-- Wrapper expr w/
 							--   hole for worker id
 							--   applied to types
 		      [(Id,Demand)],			-- Worker's args
-							-- and their strictness info	
-		      PlainCoreExpr -> PlainCoreExpr)	-- Worker body expr w/ hole 
+							-- and their strictness info
+		      CoreExpr -> CoreExpr)	-- Worker body expr w/ hole
 	   )						--   for original fn body
 
-mk_ww_arg_processing [] _ _ = returnSUs (Just (id, [], id))
+mk_ww_arg_processing [] _ _ = returnUs (Just (id, [], id))
 
 mk_ww_arg_processing (arg : args) (WwLazy True : infos) max_extra_args
   =  	-- Absent argument
 	-- So, finish args to the right...
     --pprTrace "Absent; num_wrkr_args=" (ppInt num_wrkr_args) (
     let
-	arg_ty = getIdUniType arg
+	arg_ty = idType arg
     in
     mk_ww_arg_processing args infos max_extra_args
 				    -- we've already discounted for absent args,
@@ -314,7 +305,7 @@ mk_ww_arg_processing (arg : args) (WwLazy True : infos) max_extra_args
 		   `thenUsMaybe` \ (wrap_rest, work_args_info, work_rest) ->
 
        		-- wrapper doesn't pass this arg to worker:
-    returnSUs (Just (
+    returnUs (Just (
 		 -- wrapper:
 		 \ hole -> wrap_rest hole,
 
@@ -326,8 +317,7 @@ mk_ww_arg_processing (arg : args) (WwLazy True : infos) max_extra_args
   where
     mk_absent_let arg arg_ty body
       = if not (isPrimType arg_ty) then
-	    CoLet (CoNonRec arg (mkCoTyApp (CoVar aBSENT_ERROR_ID) arg_ty))
-		  body
+	    Let (NonRec arg (mkCoTyApp (Var aBSENT_ERROR_ID) arg_ty)) body
 	else -- quite horrible
 	    panic "WwLib: haven't done mk_absent_let for primitives yet"
 
@@ -336,35 +326,37 @@ mk_ww_arg_processing (arg : args) (WwUnpack cmpnt_infos : infos) max_extra_args
   | new_max_extra_args > 0	-- Check that we are prepared to add arguments
   = 	-- this is the complicated one.
     --pprTrace "Unpack; num_wrkr_args=" (ppCat [ppInt num_wrkr_args, ppStr "; new_max=", ppInt new_num_wrkr_args, ppStr "; arg=", ppr PprDebug arg, ppr PprDebug (WwUnpack cmpnt_infos)]) (
-    case getUniDataTyCon_maybe arg_ty of
+    case maybeDataTyCon arg_ty of
 
 	  Nothing 	  -> 	   -- Not a data type
 				   panic "mk_ww_arg_processing: not datatype"
 
 	  Just (_, _, []) ->	   -- An abstract type
 				   -- We have to give up on the whole idea
-				   returnSUs Nothing
+				   returnUs Nothing
 	  Just (_, _, (_:_:_)) ->  -- Two or more constructors; that's odd
 				   panic "mk_ww_arg_processing: multi-constr"
 
-	  Just (arg_tycon, tycon_arg_tys, [data_con]) -> 
+	  Just (arg_tycon, tycon_arg_tys, [data_con]) ->
 			-- The main event: a single-constructor data type
 
 	    let
 		(_,inst_con_arg_tys,_)
-	          = getInstantiatedDataConSig data_con tycon_arg_tys
+		  = getInstantiatedDataConSig data_con tycon_arg_tys
 	    in
-	    getSUniques (length inst_con_arg_tys)    `thenSUs` \ uniqs ->
+	    getUniques (length inst_con_arg_tys)    `thenUs` \ uniqs ->
 
-	    let unpk_args = zipWith (\ u t -> mkSysLocal SLIT("upk") u t mkUnknownSrcLoc)
-				    uniqs inst_con_arg_tys
+	    let
+		unpk_args = zipWithEqual
+			     (\ u t -> mkSysLocal SLIT("upk") u t mkUnknownSrcLoc)
+			     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
 			`thenUsMaybe` \ (wrap_rest, work_args_info, work_rest) ->
 
-	    returnSUs (Just (
+	    returnUs (Just (
 	      -- wrapper: unpack the value
 	      \ hole -> mk_unpk_case arg unpk_args
 			    data_con arg_tycon
@@ -377,21 +369,21 @@ mk_ww_arg_processing (arg : args) (WwUnpack cmpnt_infos : infos) max_extra_args
 	    ))
     --)
   where
-    arg_ty = getIdUniType arg
+    arg_ty = idType arg
 
     new_max_extra_args
-      = max_extra_args 
+      = max_extra_args
 	+ 1			    -- We won't pass the original arg now
 	- nonAbsentArgs cmpnt_infos -- But we will pass an arg for each cmpt
 
     mk_unpk_case arg unpk_args boxing_con boxing_tycon body
-      = CoCase (CoVar arg) (
-	  CoAlgAlts [(boxing_con, unpk_args, body)]
-	  CoNoDefault
+      = Case (Var arg) (
+	  AlgAlts [(boxing_con, unpk_args, body)]
+	  NoDefault
 	)
 
     mk_pk_let arg boxing_con con_tys unpk_args body
-      = CoLet (CoNonRec arg (CoCon boxing_con con_tys [CoVarAtom a | a <- unpk_args]))
+      = Let (NonRec arg (Con boxing_con con_tys [VarArg a | a <- unpk_args]))
 	      body
 
 mk_ww_arg_processing (arg : args) (arg_demand : infos) max_extra_args
@@ -399,19 +391,19 @@ mk_ww_arg_processing (arg : args) (arg_demand : infos) max_extra_args
   = 	-- 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
 			`thenUsMaybe` \ (wrap_rest, work_args_info, work_rest) ->
-    
-    returnSUs (Just (
+
+    returnUs (Just (
 	      -- wrapper:
-	      \ hole -> wrap_rest (CoApp hole (CoVarAtom arg)),
-    
+	      \ hole -> wrap_rest (App hole (VarArg arg)),
+
 	      -- worker:
 	      (arg, arg_demand) : work_args_info,
 	      \ hole -> work_rest hole
-    )) 
+    ))
     --)
 \end{code}
 
@@ -426,14 +418,12 @@ In this monad, we thread a @UniqueSupply@, and we carry a
 
 \begin{code}
 type WwM result
-  =  SplitUniqSupply
+  =  UniqSupply
   -> (GlobalSwitch -> Bool)
   -> result
 
-#ifdef __GLASGOW_HASKELL__
 {-# INLINE thenWw #-}
 {-# INLINE returnWw #-}
-#endif
 
 returnWw :: a -> WwM a
 thenWw	 :: WwM a -> (a -> WwM b) -> WwM b
@@ -455,16 +445,16 @@ mapWw f (x:xs)
 
 \begin{code}
 getUniqueWw :: WwM Unique
-uniqSMtoWwM :: SUniqSM a -> WwM a
+uniqSMtoWwM :: UniqSM a -> WwM a
 
-getUniqueWw us sw_chk = getSUnique us
+getUniqueWw us sw_chk = getUnique us
 
 uniqSMtoWwM u_obj us sw_chk = u_obj us
 
-thenUsMaybe :: SUniqSM (Maybe a) -> (a -> SUniqSM (Maybe b)) -> SUniqSM (Maybe b)
+thenUsMaybe :: UniqSM (Maybe a) -> (a -> UniqSM (Maybe b)) -> UniqSM (Maybe b)
 thenUsMaybe m k
-  = m	`thenSUs` \ result ->
+  = m	`thenUs` \ result ->
     case result of
-      Nothing -> returnSUs Nothing
+      Nothing -> returnUs Nothing
       Just x  -> k x
 \end{code}
diff --git a/ghc/compiler/typecheck/BackSubst.hi b/ghc/compiler/typecheck/BackSubst.hi
deleted file mode 100644
index e631036fb3..0000000000
--- a/ghc/compiler/typecheck/BackSubst.hi
+++ /dev/null
@@ -1,24 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface BackSubst where
-import Bag(Bag)
-import CmdLineOpts(GlobalSwitch)
-import HsBinds(Bind, Binds, MonoBinds, Sig)
-import HsExpr(Expr)
-import HsLit(Literal)
-import HsMatches(GRHSsAndBinds, Match)
-import HsPat(TypecheckedPat)
-import Id(Id)
-import Inst(Inst)
-import Pretty(PprStyle, PrettyRep)
-import SplitUniq(SplitUniqSupply)
-import SrcLoc(SrcLoc)
-import Subst(Subst)
-import TyVar(TyVar)
-import UniType(UniType)
-data Binds a b 
-data MonoBinds a b 
-data TypecheckedPat 
-data Id 
-data Subst 
-applyTcSubstToBinds :: Binds Id TypecheckedPat -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> (Binds Id TypecheckedPat, Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep))
-
diff --git a/ghc/compiler/typecheck/BackSubst.lhs b/ghc/compiler/typecheck/BackSubst.lhs
deleted file mode 100644
index b42877b5eb..0000000000
--- a/ghc/compiler/typecheck/BackSubst.lhs
+++ /dev/null
@@ -1,451 +0,0 @@
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
-%
-\section[BackSubst]{Back substitution functions}
-
-This module applies a typechecker substitution over the whole abstract
-syntax.
-
-\begin{code}
-#include "HsVersions.h"
-
-module BackSubst (
-	 applyTcSubstToBinds,
-
-	 -- and to make the interface self-sufficient...
-	 Subst, Binds, MonoBinds, Id, TypecheckedPat
-   ) where
-
-IMPORT_Trace		-- ToDo: rm (debugging)
-import Outputable
-import Pretty
-
-import AbsSyn
-import AbsUniType	( getTyVar )
-import TcMonad
-import Util
-\end{code}
-
-%************************************************************************
-%*									*
-\subsection[BackSubst-Binds]{Running a substitution over @Binds@}
-%*									*
-%************************************************************************
-
-\begin{code}
-applyTcSubstToBinds :: TypecheckedBinds -> NF_TcM TypecheckedBinds
-
-applyTcSubstToBinds EmptyBinds = returnNF_Tc EmptyBinds
-
-applyTcSubstToBinds (ThenBinds binds1 binds2)
-  = applyTcSubstToBinds binds1  `thenNF_Tc` \ new_binds1 ->
-    applyTcSubstToBinds binds2  `thenNF_Tc` \ new_binds2 ->
-    returnNF_Tc (ThenBinds new_binds1 new_binds2)
-
-applyTcSubstToBinds (SingleBind bind)
-  = substBind bind  `thenNF_Tc` \ new_bind ->
-    returnNF_Tc (SingleBind new_bind)
-
-applyTcSubstToBinds (AbsBinds tyvars dicts locprs dict_binds val_bind)
-  = subst_tyvars tyvars 	    `thenNF_Tc` \ new_tyvars ->
-    mapNF_Tc applyTcSubstToId dicts   `thenNF_Tc` \ new_dicts ->
-    mapNF_Tc subst_pair locprs	    `thenNF_Tc` \ new_locprs ->
-    mapNF_Tc subst_bind dict_binds    `thenNF_Tc` \ new_dict_binds ->
-    substBind val_bind		    `thenNF_Tc` \ new_val_bind ->
-    returnNF_Tc (AbsBinds new_tyvars new_dicts new_locprs new_dict_binds new_val_bind)
-  where
-    subst_pair (l, g)
-      = applyTcSubstToId l	`thenNF_Tc` \ new_l ->
-	applyTcSubstToId g	`thenNF_Tc` \ new_g ->
-	returnNF_Tc (new_l, new_g)
-
-    subst_bind (v, e)
-      = applyTcSubstToInst v	`thenNF_Tc` \ new_v ->
-	substExpr e		`thenNF_Tc` \ new_e ->
-	returnNF_Tc (new_v, new_e)
-\end{code}
-
-\begin{code}
--------------------------------------------------------------------------
-substBind :: TypecheckedBind -> NF_TcM TypecheckedBind
-
-substBind (NonRecBind mbinds)
-  = applyTcSubstToMonoBinds mbinds	`thenNF_Tc` \ new_mbinds ->
-    returnNF_Tc (NonRecBind new_mbinds)
-
-substBind (RecBind mbinds)
-  = applyTcSubstToMonoBinds mbinds	`thenNF_Tc` \ new_mbinds ->
-    returnNF_Tc (RecBind new_mbinds)
-
-substBind other = returnNF_Tc other
-
--------------------------------------------------------------------------
-applyTcSubstToMonoBinds :: TypecheckedMonoBinds -> NF_TcM TypecheckedMonoBinds
-
-applyTcSubstToMonoBinds EmptyMonoBinds = returnNF_Tc EmptyMonoBinds
-
-applyTcSubstToMonoBinds (AndMonoBinds mbinds1 mbinds2)
-  = applyTcSubstToMonoBinds mbinds1  `thenNF_Tc` \ new_mbinds1 ->
-    applyTcSubstToMonoBinds mbinds2  `thenNF_Tc` \ new_mbinds2 ->
-    returnNF_Tc (AndMonoBinds new_mbinds1 new_mbinds2)
-
-applyTcSubstToMonoBinds (PatMonoBind pat grhss_w_binds locn)
-  = substPat pat	    	    	    `thenNF_Tc` \ new_pat ->
-    substGRHSsAndBinds grhss_w_binds  `thenNF_Tc` \ new_grhss_w_binds ->
-    returnNF_Tc (PatMonoBind new_pat new_grhss_w_binds locn)
-
-applyTcSubstToMonoBinds (VarMonoBind var expr)
-  = applyTcSubstToId var    `thenNF_Tc` \ new_var ->
-    substExpr expr	    `thenNF_Tc` \ new_expr ->
-    returnNF_Tc (VarMonoBind new_var new_expr)
-
-applyTcSubstToMonoBinds (FunMonoBind name ms locn)
-  = applyTcSubstToId name   `thenNF_Tc` \ new_name ->
-    mapNF_Tc substMatch ms    `thenNF_Tc` \ new_ms ->
-    returnNF_Tc (FunMonoBind new_name new_ms locn)
-\end{code}
-
-%************************************************************************
-%*									*
-\subsection[BackSubst-Match-GRHSs]{Match and GRHSsAndBinds}
-%*									*
-%************************************************************************
-
-\begin{code}
-substMatch :: TypecheckedMatch -> NF_TcM TypecheckedMatch
-
-substMatch (PatMatch pat match)
-  = substPat pat	    `thenNF_Tc` \ new_pat ->
-    substMatch match  	    `thenNF_Tc` \ new_match ->
-    returnNF_Tc (PatMatch new_pat new_match)
-
-substMatch (GRHSMatch grhss_w_binds)
-  = substGRHSsAndBinds grhss_w_binds `thenNF_Tc` \ new_grhss_w_binds ->
-    returnNF_Tc (GRHSMatch new_grhss_w_binds)
-
--------------------------------------------------------------------------
-substGRHSsAndBinds :: TypecheckedGRHSsAndBinds
-		   -> NF_TcM TypecheckedGRHSsAndBinds
-
-substGRHSsAndBinds (GRHSsAndBindsOut grhss binds ty)
-  = mapNF_Tc subst_grhs grhss 	`thenNF_Tc` \ new_grhss ->
-    applyTcSubstToBinds binds   `thenNF_Tc` \ new_binds ->
-    applyTcSubstToTy ty 	`thenNF_Tc` \ new_ty ->
-    returnNF_Tc (GRHSsAndBindsOut new_grhss new_binds new_ty)
-  where
-    subst_grhs (GRHS guard expr locn)
-      = substExpr guard  `thenNF_Tc` \ new_guard ->
-	substExpr expr   `thenNF_Tc` \ new_expr  ->
-	returnNF_Tc (GRHS new_guard new_expr locn)
-
-    subst_grhs (OtherwiseGRHS expr locn)
-      = substExpr expr   `thenNF_Tc` \ new_expr  ->
-	returnNF_Tc (OtherwiseGRHS new_expr locn)
-\end{code}
-
-%************************************************************************
-%*									*
-\subsection[BackSubst-Expr]{Running a substitution over a TypeCheckedExpr}
-%*									*
-%************************************************************************
-
-ToDo: panic on things that can't be in @TypecheckedExpr@.
-
-\begin{code}
-substExpr :: TypecheckedExpr -> NF_TcM TypecheckedExpr
-
-substExpr (Var name)
-  = applyTcSubstToId name	`thenNF_Tc` \ new_name ->
-    returnNF_Tc (Var new_name)
-
-substExpr (Lit (LitLitLit s ty))
-  = applyTcSubstToTy ty		`thenNF_Tc` \ new_ty ->
-    returnNF_Tc (Lit (LitLitLit s new_ty))
-
-substExpr other_lit@(Lit lit) = returnNF_Tc other_lit
-
-substExpr (Lam match)
-  = substMatch match	`thenNF_Tc` \ new_match ->
-    returnNF_Tc (Lam new_match)
-
-substExpr (App e1 e2)
-  = substExpr e1	`thenNF_Tc` \ new_e1 ->
-    substExpr e2	`thenNF_Tc` \ new_e2 ->
-    returnNF_Tc (App new_e1 new_e2)
-
-substExpr (OpApp e1 op e2)
-  = substExpr e1	`thenNF_Tc` \ new_e1 ->
-    substExpr op	`thenNF_Tc` \ new_op ->
-    substExpr e2	`thenNF_Tc` \ new_e2 ->
-    returnNF_Tc (OpApp new_e1 new_op new_e2)
-
-substExpr (SectionL expr op)
-  = substExpr expr	`thenNF_Tc` \ new_expr ->
-    substExpr op	`thenNF_Tc` \ new_op ->
-    returnNF_Tc (SectionL new_expr new_op)
-
-substExpr (SectionR op expr)
-  = substExpr op	`thenNF_Tc` \ new_op ->
-    substExpr expr	`thenNF_Tc` \ new_expr ->
-    returnNF_Tc (SectionR new_op new_expr)
-
-substExpr (CCall fun args may_gc is_casm result_ty)
-  = mapNF_Tc substExpr args 	`thenNF_Tc` \ new_args ->
-    applyTcSubstToTy result_ty	`thenNF_Tc` \ new_result_ty ->
-    returnNF_Tc (CCall fun new_args may_gc is_casm new_result_ty)
-
-substExpr (SCC label expr)
-  = substExpr expr	`thenNF_Tc` \ new_expr ->
-    returnNF_Tc (SCC label new_expr)
-
-substExpr (Case expr ms)
-  = substExpr expr    	    `thenNF_Tc` \ new_expr ->
-    mapNF_Tc substMatch ms    `thenNF_Tc` \ new_ms ->
-    returnNF_Tc (Case new_expr new_ms)
-
-substExpr (ListComp expr quals)
-  = substExpr expr	`thenNF_Tc` \ new_expr ->
-    substQuals quals	`thenNF_Tc` \ new_quals ->
-    returnNF_Tc (ListComp new_expr new_quals)
-
-substExpr (Let binds expr)
-  = applyTcSubstToBinds binds `thenNF_Tc` \ new_binds ->
-    substExpr expr	      `thenNF_Tc` \ new_expr ->
-    returnNF_Tc (Let new_binds new_expr)
-
---ExplicitList: not in typechecked exprs
-
-substExpr (ExplicitListOut ty exprs)
-  = applyTcSubstToTy ty	    `thenNF_Tc` \ new_ty ->
-    mapNF_Tc substExpr exprs  `thenNF_Tc` \ new_exprs ->
-    returnNF_Tc (ExplicitListOut new_ty new_exprs)
-
-substExpr (ExplicitTuple exprs)
-  = mapNF_Tc substExpr exprs  `thenNF_Tc` \ new_exprs ->
-    returnNF_Tc (ExplicitTuple new_exprs)
-
-substExpr (If e1 e2 e3)
-  = substExpr e1	`thenNF_Tc` \ new_e1 ->
-    substExpr e2	`thenNF_Tc` \ new_e2 ->
-    substExpr e3	`thenNF_Tc` \ new_e3 ->
-    returnNF_Tc (If new_e1 new_e2 new_e3)
-
-substExpr (ArithSeqOut expr info)
-  = substExpr expr	`thenNF_Tc` \ new_expr ->
-    substArithSeq info	`thenNF_Tc` \ new_info ->
-    returnNF_Tc (ArithSeqOut new_expr new_info)
-
-substExpr (TyLam tyvars expr)
-  = subst_tyvars tyvars	`thenNF_Tc` \ new_tyvars ->
-    substExpr expr	`thenNF_Tc` \ new_expr ->
-    returnNF_Tc (TyLam new_tyvars new_expr)
-
-substExpr (TyApp expr tys)
-  = substExpr expr    	    	  `thenNF_Tc` \ new_expr ->
-    mapNF_Tc (applyTcSubstToTy) tys `thenNF_Tc` \ new_tys ->
-    returnNF_Tc (TyApp new_expr new_tys)
-
-substExpr (DictLam dicts expr)
-  = mapNF_Tc applyTcSubstToId dicts `thenNF_Tc` \ new_dicts ->
-    substExpr expr    	    	  `thenNF_Tc` \ new_expr ->
-    returnNF_Tc (DictLam new_dicts new_expr)
-
-substExpr (DictApp expr dicts)
-  = substExpr expr    	    	  `thenNF_Tc` \ new_expr ->
-    mapNF_Tc applyTcSubstToId dicts `thenNF_Tc` \ new_dicts ->
-    returnNF_Tc (DictApp new_expr new_dicts)
-
-substExpr (ClassDictLam dicts methods expr)
-  = mapNF_Tc applyTcSubstToId dicts   `thenNF_Tc` \ new_dicts ->
-    mapNF_Tc applyTcSubstToId methods `thenNF_Tc` \ new_methods ->
-    substExpr expr    	    	    `thenNF_Tc` \ new_expr ->
-    returnNF_Tc (ClassDictLam new_dicts new_methods new_expr)
-
-substExpr (Dictionary dicts methods)
-  = mapNF_Tc applyTcSubstToId dicts   `thenNF_Tc` \ new_dicts ->
-    mapNF_Tc applyTcSubstToId methods `thenNF_Tc` \ new_methods ->
-    returnNF_Tc (Dictionary new_dicts new_methods)
-
-substExpr (SingleDict name)
-  = applyTcSubstToId name  	`thenNF_Tc` \ new_name ->
-    returnNF_Tc (SingleDict new_name)
-
-#ifdef DPH
-
-substExpr (ParallelZF expr quals)
-  = substExpr expr	`thenNF_Tc` \ new_expr ->
-    substParQuals quals	`thenNF_Tc` \ new_quals ->
-    returnNF_Tc (ParallelZF new_expr new_quals)
-
---substExpr (ExplicitPodIn exprs) :: not in typechecked
-
-substExpr (ExplicitPodOut ty exprs)
-  = applyTcSubstToTy ty	    `thenNF_Tc` \ new_ty ->
-    mapNF_Tc substExpr exprs  `thenNF_Tc` \ new_exprs ->
-    returnNF_Tc (ExplicitPodOut new_ty new_exprs)
-
-substExpr (ExplicitProcessor exprs expr)
-  = mapNF_Tc substExpr exprs  `thenNF_Tc` \ new_exprs ->
-    substExpr expr	    `thenNF_Tc` \ new_expr ->
-    returnNF_Tc (ExplicitProcessor new_exprs new_expr)
-
-#endif {- Data Parallel Haskell -}
-
--------------------------------------------------------------------------
-substArithSeq :: TypecheckedArithSeqInfo -> NF_TcM TypecheckedArithSeqInfo
-
-substArithSeq (From e)
-  = substExpr e		`thenNF_Tc` \ new_e ->
-    returnNF_Tc (From new_e)
-
-substArithSeq (FromThen e1 e2)
-  = substExpr e1	`thenNF_Tc` \ new_e1 ->
-    substExpr e2	`thenNF_Tc` \ new_e2 ->
-    returnNF_Tc (FromThen new_e1 new_e2)
-
-substArithSeq (FromTo e1 e2)
-  = substExpr e1	`thenNF_Tc` \ new_e1 ->
-    substExpr e2	`thenNF_Tc` \ new_e2 ->
-    returnNF_Tc (FromTo new_e1 new_e2)
-
-substArithSeq (FromThenTo e1 e2 e3)
-  = substExpr e1	`thenNF_Tc` \ new_e1 ->
-    substExpr e2	`thenNF_Tc` \ new_e2 ->
-    substExpr e3	`thenNF_Tc` \ new_e3 ->
-    returnNF_Tc (FromThenTo new_e1 new_e2 new_e3)
-
--------------------------------------------------------------------------
-substQuals :: [TypecheckedQual] -> NF_TcM [TypecheckedQual]
-
-substQuals quals
-  = mapNF_Tc subst_qual quals
-  where
-    subst_qual (GeneratorQual pat expr)
-      = substPat  pat    `thenNF_Tc` \ new_pat ->
-	substExpr expr   `thenNF_Tc` \ new_expr ->
-	returnNF_Tc (GeneratorQual new_pat new_expr)
-
-    subst_qual (FilterQual expr)
-      = substExpr expr    `thenNF_Tc` \ new_expr ->
-	returnNF_Tc (FilterQual new_expr)
-
--------------------------------------------------------------------------
-#ifdef DPH
-substParQuals :: TypecheckedParQuals -> NF_TcM TypecheckedParQuals
-
-substParQuals (AndParQuals quals1 quals2)
- = substParQuals quals1	    	`thenNF_Tc` \ new_quals1 ->
-   substParQuals quals2	    	`thenNF_Tc` \ new_quals2 ->
-   returnNF_Tc (AndParQuals new_quals1 new_quals2)
-
---substParQuals (DrawnGenIn pats pat expr) :: not in typechecked
-
-substParQuals (DrawnGenOut pats convs pat expr)
- = mapNF_Tc substPat pats	    `thenNF_Tc` \ new_pats  ->
-   mapNF_Tc substExpr convs   `thenNF_Tc` \ new_convs ->
-   substPat pat		    `thenNF_Tc` \ new_pat   -> 
-   substExpr expr	    `thenNF_Tc` \ new_expr  ->
-   returnNF_Tc (DrawnGenOut new_pats new_convs new_pat new_expr)
-
-substParQuals (IndexGen pats pat expr)
- = mapNF_Tc substExpr pats    `thenNF_Tc` \ new_pats ->
-   substPat pat		    `thenNF_Tc` \ new_pat  -> 
-   substExpr expr	    `thenNF_Tc` \ new_expr ->
-   returnNF_Tc (IndexGen new_pats new_pat new_expr)
-
-substParQuals (ParFilter expr) 
- = substExpr expr	    `thenNF_Tc` \ new_expr ->
-   returnNF_Tc (ParFilter new_expr)
-#endif {- Data Parallel Haskell -}
-\end{code}
- 
-%************************************************************************
-%*									*
-\subsection[BackSubst-Pats]{Patterns}
-%*									*
-%************************************************************************
-
-\begin{code}
-substPat :: TypecheckedPat -> NF_TcM TypecheckedPat
-
-substPat (WildPat ty)
-  = applyTcSubstToTy ty	    `thenNF_Tc` \ new_ty ->
-    returnNF_Tc (WildPat new_ty)
-
-substPat (VarPat v)
-  = applyTcSubstToId v	    `thenNF_Tc` \ new_v ->
-    returnNF_Tc (VarPat new_v)
-
-substPat (LazyPat pat)
-  = substPat pat	    `thenNF_Tc` \ new_pat ->
-    returnNF_Tc (LazyPat new_pat)
-
-substPat (AsPat n pat)
-  = applyTcSubstToId n	    `thenNF_Tc` \ new_n ->
-    substPat pat	    `thenNF_Tc` \ new_pat ->
-    returnNF_Tc (AsPat new_n new_pat)
-
-substPat (ConPat n ty pats)
-  = applyTcSubstToId n	    `thenNF_Tc` \ new_n ->
-	-- ToDo: "n"'s global, so omit?
-    applyTcSubstToTy ty	    `thenNF_Tc` \ new_ty ->
-    mapNF_Tc substPat pats    `thenNF_Tc` \ new_pats ->
-    returnNF_Tc (ConPat new_n new_ty new_pats)
-
-substPat (ConOpPat pat1 op pat2 ty)
-  = substPat pat1	    `thenNF_Tc` \ new_pat1 ->
-    applyTcSubstToId op	    `thenNF_Tc` \ new_op ->
-    substPat pat2	    `thenNF_Tc` \ new_pat2 ->
-    applyTcSubstToTy ty	    `thenNF_Tc` \ new_ty ->
-    returnNF_Tc (ConOpPat new_pat1 new_op new_pat2 new_ty)
-
-substPat (ListPat ty pats)
-  = applyTcSubstToTy ty	    `thenNF_Tc` \ new_ty ->
-    mapNF_Tc substPat pats    `thenNF_Tc` \ new_pats ->
-    returnNF_Tc (ListPat new_ty new_pats)
-
-substPat (TuplePat pats)
-  = mapNF_Tc substPat pats    `thenNF_Tc` \ new_pats ->
-    returnNF_Tc (TuplePat new_pats)
-
-substPat (LitPat lit ty)
-  = applyTcSubstToTy ty	    `thenNF_Tc` \ new_ty ->
-    returnNF_Tc (LitPat lit new_ty)
-
-substPat (NPat lit ty expr)
-  = applyTcSubstToTy ty	    `thenNF_Tc` \ new_ty ->
-    substExpr expr	    `thenNF_Tc` \ new_expr ->
-    returnNF_Tc (NPat lit new_ty new_expr)
-
-substPat (NPlusKPat n k ty e1 e2 e3)
-  = applyTcSubstToId n	    `thenNF_Tc` \ new_n ->
-    applyTcSubstToTy ty	    `thenNF_Tc` \ new_ty ->
-    substExpr e1	    `thenNF_Tc` \ new_e1 ->
-    substExpr e2	    `thenNF_Tc` \ new_e2 ->
-    substExpr e3	    `thenNF_Tc` \ new_e3 ->
-    returnNF_Tc (NPlusKPat new_n k new_ty new_e1 new_e2 new_e3)
-
-#ifdef DPH
-substPat (ProcessorPat pats convs pat)
-  = mapNF_Tc substPat pats    `thenNF_Tc` \ new_pats ->
-    mapNF_Tc substExpr convs  `thenNF_Tc` \ new_convs ->
-    substPat pat	    `thenNF_Tc` \ new_pat ->
-    returnNF_Tc (ProcessorPat new_pats new_convs new_pat)
-#endif {- Data Parallel Haskell -}
-\end{code}
-
-%************************************************************************
-%*									*
-\subsection[BackSubst-TyVar]{Running a substitution over type variables}
-%*									*
-%************************************************************************
-
-The type variables in an @AbsBinds@ or @TyLam@ may have a binding in the
-substitution as a result of a @matchTy@ call.  So we should subsitute for
-them too. The result should certainly be a type variable.
-
-\begin{code}
-subst_tyvars tyvars
-  = mapNF_Tc applyTcSubstToTyVar tyvars `thenNF_Tc` \ new_tyvar_tys ->
-    returnNF_Tc (map (getTyVar "subst_tyvars") new_tyvar_tys)
-\end{code}
diff --git a/ghc/compiler/typecheck/Disambig.hi b/ghc/compiler/typecheck/Disambig.hi
deleted file mode 100644
index 737bb61c6d..0000000000
--- a/ghc/compiler/typecheck/Disambig.hi
+++ /dev/null
@@ -1,27 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface Disambig where
-import Bag(Bag)
-import Class(Class)
-import CmdLineOpts(GlobalSwitch)
-import ErrUtils(Error(..))
-import Id(Id)
-import Inst(Inst, InstOrigin, OverloadedLit)
-import Pretty(PprStyle, Pretty(..), PrettyRep)
-import SplitUniq(SplitUniqSupply)
-import SrcLoc(SrcLoc)
-import Subst(Subst)
-import TcMonad(TcResult)
-import UniType(UniType)
-import Unique(Unique, UniqueSupply)
-data Bag a 
-type Error = PprStyle -> Int -> Bool -> PrettyRep
-data Inst 
-data PprStyle 
-type Pretty = Int -> Bool -> PrettyRep
-data PrettyRep 
-data SrcLoc 
-data Subst 
-data TcResult a 
-data UniqueSupply 
-disambiguateDicts :: [Inst] -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult ()
-
diff --git a/ghc/compiler/typecheck/Disambig.lhs b/ghc/compiler/typecheck/Disambig.lhs
deleted file mode 100644
index be33671882..0000000000
--- a/ghc/compiler/typecheck/Disambig.lhs
+++ /dev/null
@@ -1,162 +0,0 @@
-%
-% (c) The AQUA Project, Glasgow University, 1993-1995
-%
-%************************************************************************
-%*									*
-\section[Disambig]{Disambiguation of overloading}
-%*									*
-%************************************************************************
-
-\begin{code}
-#include "HsVersions.h"
-
-module Disambig (
-	disambiguateDicts,
-
-	-- and for self-sufficiency...
-	Inst, Subst, UniqueSupply, Bag, Error(..), SrcLoc,
-	TcResult, Pretty(..), PprStyle, PrettyRep
-    ) where
-
-import TcMonad
-import AbsSyn
-
-import AbsPrel		( intTyCon, intTy, {-ToDo:?voidTy,-} doubleTyCon )
-import AbsUniType	( applyTyCon, getTyVar, cmpTyVar, getClassKey,
-			  isNumericClass, isStandardClass
-			)
-import Errors		( ambigErr, defaultErr, Error(..), UnifyErrContext(..) )
-import Id		( Id, DictVar(..) )
-import Inst		--( Inst(..), InstOrigin(..), OverloadedLit  )
-import InstEnv		( lookupClassInstAtSimpleType )
-import Maybes		( Maybe(..), firstJust )
-import SrcLoc		( mkUnknownSrcLoc )
-import TcSimplify	( tcSimplifyCheckThetas )
-import Unique		( cReturnableClassKey )
-import Util
-\end{code}
-
-If a dictionary constrains a type variable which is
-\begin{itemize}
-\item
-not mentioned in the environment
-\item
-and not mentioned in the type of the expression
-\end{itemize}
-then it is ambiguous. No further information will arise to instantiate
-the type variable; nor will it be generalised and turned into an extra
-parameter to a function.
-
-It is an error for this to occur, except that Haskell provided for
-certain rules to be applied in the special case of numeric types.
-
-Specifically, if
-\begin{itemize}
-\item
-at least one of its classes is a numeric class, and
-\item
-all of its classes are numeric or standard
-\end{itemize}
-then the type variable can be defaulted to the first type in the
-default-type list which is an instance of all the offending classes.
-
-So here is the function which does the work.  It takes the ambiguous
-dictionaries and either resolves them (producing bindings) or
-complains.  It works by splitting the dictionary list by type
-variable, and using @disambigOne@ to do the real business.
-
-IMPORTANT: @disambiguate@ assumes that its argument dictionaries
-constrain only a simple type variable.
-
-\begin{code}
-type SimpleDictInfo = (Inst, Class, TyVar)
-
-disambiguateDicts :: [Inst] -> TcM ()
-
-disambiguateDicts insts
-  = mapTc disambigOne inst_infos    `thenTc` \ binds_lists ->
-    returnTc ()
-  where
-    inst_infos = equivClasses cmp_tyvars (map mk_inst_info insts)
-    (_,_,tv1) `cmp_tyvars` (_,_,tv2) = tv1 `cmpTyVar` tv2
-  
-    mk_inst_info dict@(Dict _ clas ty _)
-      = (dict, clas, getTyVar "disambiguateDicts" ty)
-\end{code}
-
-@disambigOne@ assumes that its arguments dictionaries constrain all
-the same type variable.
-
-ADR Comment 20/6/94: I've changed the @CReturnable@ case to default to
-@()@ instead of @Int@.  I reckon this is the Right Thing to do since
-the most common use of defaulting is code like:
-\begin{verbatim}
-	_ccall_ foo	`seqPrimIO` bar
-\end{verbatim}
-Since we're not using the result of @foo@, the result if (presumably)
-@void@.
-WDP Comment: no such thing as voidTy; so not quite in yet (94/07).
-
-\begin{code}
-disambigOne :: [SimpleDictInfo] -> TcM ()
-
-disambigOne dict_infos
-  | isCReturnable dict_infos
-   	-- C-returnable; just default to Void
-  =  extendSubstTc tyvar intTy{-ToDo:voidTy-} (AmbigDictCtxt dicts)
-
-  | not (isStandardNumericDefaultable dict_infos)
-  = failTc (ambigErr dicts) -- no default
-
-  | otherwise -- isStandardNumericDefaultable dict_infos
-  = 	-- THE DICTS OBEY THE DEFAULTABLE CONSTRAINT
-	-- SO, TRY DEFAULT TYPES IN ORDER
-
-	-- Failure here is caused by there being no type in the
-	-- default list which can satisfy all the ambiguous classes.
-	-- For example, if Real a is reqd, but the only type in the
-	-- default list is Int.
-    getDefaultingTys		    `thenNF_Tc` \ default_tys ->
-
-    mapNF_Tc try_default default_tys `thenNF_Tc` \ maybe_tys ->
-
-    checkMaybeTc (firstJust maybe_tys)
-		 (defaultErr dicts default_tys)
-				    `thenTc` \ chosen_default_ty ->
-
-	-- SUCCESS; COMBINE TO A BINDS, AND EXTEND SUBSTITUTION
-    extendSubstTc tyvar chosen_default_ty (AmbigDictCtxt dicts)
-
-  where
-    (_,_,tyvar) = head dict_infos		-- Should be non-empty
-    dicts = [dict | (dict,_,_) <- dict_infos]
-
-    try_default :: UniType -> NF_TcM (Maybe UniType)
-
-    try_default default_ty
-      = let
-	    thetas = [(clas, default_ty) | (_,clas,_) <- dict_infos]
-        in
-	recoverQuietlyTc Nothing ( -- if tcSimplify hates us, we get the Nothing
-
-	    tcSimplifyCheckThetas (DefaultDeclOrigin mkUnknownSrcLoc) thetas `thenTc` \ _ ->
-	    returnTc (Just default_ty)
-	)
-\end{code}
-
-@isStandardNumericDefaultable@ sees whether the dicts have the
-property required for defaulting; namely at least one is numeric, and
-all are standard.
-
-\begin{code}
-isCReturnable, isStandardNumericDefaultable :: [SimpleDictInfo] -> Bool
-
-isStandardNumericDefaultable dict_infos
-  =    (any (\ (_,c,_) -> isNumericClass c)  dict_infos)
-    && (all (\ (_,c,_) -> isStandardClass c) dict_infos)
-
-isCReturnable [(_,c,_)] = getClassKey c == cReturnableClassKey
-isCReturnable _	        = False -- duplicates will have been removed,
-				-- so we don't have to worry about
-				-- multiple copies of cReturnableClassKey...
-\end{code}
diff --git a/ghc/compiler/typecheck/GenSpecEtc.hi b/ghc/compiler/typecheck/GenSpecEtc.hi
deleted file mode 100644
index 6d6f8b3513..0000000000
--- a/ghc/compiler/typecheck/GenSpecEtc.hi
+++ /dev/null
@@ -1,53 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface GenSpecEtc where
-import Bag(Bag)
-import CharSeq(CSeq)
-import Class(Class)
-import CmdLineOpts(GlobalSwitch)
-import E(E)
-import ErrUtils(Error(..))
-import ErrsTc(UnifyErrContext)
-import HsBinds(Bind, Binds, MonoBinds, Sig)
-import HsExpr(Expr)
-import HsLit(Literal)
-import HsPat(TypecheckedPat)
-import Id(Id)
-import Inst(Inst, InstOrigin, OverloadedLit)
-import LIE(LIE)
-import Maybes(Labda)
-import Name(Name)
-import NameTypes(FullName, ShortName)
-import PreludePS(_PackedString)
-import Pretty(Delay, PprStyle, Pretty(..), PrettyRep)
-import SimplEnv(UnfoldingGuidance)
-import SplitUniq(SplitUniqSupply)
-import SrcLoc(SrcLoc)
-import Subst(Subst)
-import TcMonad(TcResult)
-import TyCon(TyCon)
-import TyVar(TyVar)
-import UniType(UniType)
-import Unique(Unique, UniqueSupply)
-data Bag a 
-data E 
-type Error = PprStyle -> Int -> Bool -> PrettyRep
-data Bind a b 
-data Binds a b 
-data TypecheckedPat 
-data Id 
-data Inst 
-data LIE 
-data Name 
-data PprStyle 
-type Pretty = Int -> Bool -> PrettyRep
-data PrettyRep 
-data SignatureInfo   = TySigInfo Id [TyVar] [Inst] UniType SrcLoc | ValSpecInfo Name UniType (Labda Name) SrcLoc | ValInlineInfo Name UnfoldingGuidance SrcLoc | ValDeforestInfo Name SrcLoc | ValMagicUnfoldingInfo Name _PackedString SrcLoc
-data SrcLoc 
-data Subst 
-data TcResult a 
-data TyVar 
-data UniType 
-data UniqueSupply 
-checkSigTyVars :: [TyVar] -> [TyVar] -> UniType -> UniType -> UnifyErrContext -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult [TyVar]
-genBinds :: Bool -> E -> Bind Id TypecheckedPat -> LIE -> [(Name, Id)] -> [SignatureInfo] -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult (Binds Id TypecheckedPat, LIE, [(Name, Id)])
-
diff --git a/ghc/compiler/typecheck/GenSpecEtc.lhs b/ghc/compiler/typecheck/GenSpecEtc.lhs
index c607157aa8..f0008df8d0 100644
--- a/ghc/compiler/typecheck/GenSpecEtc.lhs
+++ b/ghc/compiler/typecheck/GenSpecEtc.lhs
@@ -1,5 +1,5 @@
 %
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
 %
 \section[GenSpecEtc]{Code for GEN, SPEC, PRED, and REL}
 
@@ -7,73 +7,60 @@
 #include "HsVersions.h"
 
 module GenSpecEtc (
-	genBinds, SignatureInfo(..),
-	checkSigTyVars,
-
-	-- and to make the interface self-sufficient...
-	Bag, E, Bind, Binds, TypecheckedPat, Id, Inst,
-	LIE, TcResult, Name, SrcLoc, Subst, TyVar, UniType,
-	UniqueSupply, Error(..), Pretty(..), PprStyle,
-	PrettyRep
+	TcSigInfo(..), 
+	genBinds, 
+	checkSigTyVars, checkSigTyVarsGivenGlobals,
+	specTy
     ) where
 
-import TcMonad		-- typechecker monadery
-import TcMonadFns	( applyTcSubstAndCollectTyVars,
-			  mkIdsWithGivenTys
-			)
-import AbsSyn
-
-import AbsUniType
-import E		( tvOfE, E, LVE(..), TCE(..), UniqFM, CE(..) )
-			-- TCE and CE for pragmas only
-import Errors
-import Id		( getIdUniType, mkInstId, Id, DictVar(..) )
-import IdInfo
-import Inst
-import LIE		( mkLIE, unMkLIE, LIE )
+import Ubiq
+
+import TcMonad
+import Inst		( Inst, InstOrigin(..), LIE(..), plusLIE, 
+			  newDicts, tyVarsOfInst, instToId )
+import TcEnv		( tcGetGlobalTyVars, newMonoIds )
+import TcSimplify	( tcSimplify, tcSimplifyAndCheck, tcSimplifyWithExtraGlobals )
+import TcType		( TcType(..), TcThetaType(..), TcTauType(..), 
+			  TcTyVarSet(..), TcTyVar(..), tcInstType, zonkTcType )
+
+import HsSyn		( HsBinds(..), Bind(..), MonoBinds(..), HsExpr, OutPat(..), 
+			  Sig, HsLit, ArithSeqInfo, InPat, GRHSsAndBinds, Match, Fake,
+			  collectBinders )
+import TcHsSyn		( TcIdOcc(..), TcIdBndr(..), TcHsBinds(..), TcBind(..), TcExpr(..) )
+
+import Bag		( Bag, foldBag, bagToList, listToBag, isEmptyBag )
+import Class		( GenClass )
+import Id		( GenId, Id(..), mkUserId, idType )
 import ListSetOps	( minusList, unionLists, intersectLists )
-import Maybes		( assocMaybe, Maybe(..) )
-import Name		( Name(..) )	-- ToDo: a HACK
-import TcSimplify	( tcSimplify, tcSimplifyAndCheck )
+import Maybes		( Maybe(..), allMaybes )
+import Outputable	( interppSP, interpp'SP )
+import Pretty
+import PprType		( GenClass, GenType, GenTyVar )
+import Type		( mkTyVarTy, splitSigmaTy, mkForAllTys, mkFunTys,
+			  getTyVar_maybe, tyVarsOfTypes, eqSimpleTheta )
+import TyVar		( GenTyVar, TyVar(..), minusTyVarSet, emptyTyVarSet,
+			  elementOfTyVarSet, unionTyVarSets, tyVarSetToList )
+import Usage		( UVar(..) )
+import Unique		( Unique )
 import Util
-
-IMPORT_Trace		-- ToDo: rm (debugging)
-import Pretty		-- 
 \end{code}
 
 %************************************************************************
 %*									*
-\subsection[Gen-SignatureInfo]{The @SignatureInfo@ type}
+\subsection[Gen-SignatureInfo]{The @TcSigInfo@ type}
 %*									*
 %************************************************************************
 
 A type signature (or user-pragma) is typechecked to produce a
-@SignatureInfo@.
+@TcSigInfo@.  It contains @TcTypes@ because they are unified with
+the variable's type, and after that checked to see whether they've
+been instantiated.
 
 \begin{code}
-data SignatureInfo
-  = TySigInfo	    Id	-- for this value...
-		    [TyVar] [Inst] TauType
-		    SrcLoc
-
-  | ValSpecInfo	    Name	-- we'd rather have the Name than Id...
-		    UniType
-		    (Maybe Name)
-		    SrcLoc
-
-  | ValInlineInfo   Name
-		    UnfoldingGuidance
-		    SrcLoc
-
-  | ValDeforestInfo Name
-                    SrcLoc
-
-  | ValMagicUnfoldingInfo
-		    Name
-		    FAST_STRING
+data TcSigInfo s
+  = TySigInfo	    (TcIdBndr s)	-- for this value...
+		    [TcTyVar s] (TcThetaType s) (TcTauType s)
 		    SrcLoc
-
-  -- ToDo: perhaps add more (for other user pragmas)
 \end{code}
 
 
@@ -84,16 +71,13 @@ data SignatureInfo
 %************************************************************************
 
 \begin{code}
-genBinds :: Bool				-- True <=> top level
-	 -> E 
-	 -> TypecheckedBind 
-	 -> LIE 				-- LIE from typecheck of binds
-	 -> LVE					-- Local types
-	 -> [SignatureInfo]			-- Signatures, if any
-	 -> TcM (TypecheckedBinds, LIE, LVE)	-- Generalised binds, reduced LIE,
-						--	polymorphic LVE
-						-- The LVE and LIE are fixed points
-						-- of the substitution
+genBinds :: [Name]				-- Binders
+	 -> [TcIdBndr s]			-- Monomorphic binders
+	 -> TcBind s				-- Type-checked monobind
+	 -> LIE s 				-- LIE from typecheck of binds
+	 -> [TcSigInfo s]			-- Signatures, if any
+	 -> (Name -> PragmaInfo)		-- Gives pragma info for binder
+	 -> TcM s (TcHsBinds s, LIE s, [TcIdBndr s])
 \end{code}
 
 In the call $(@genBinds@~env~bind~lie~lve)$, $(bind,lie,lve)$
@@ -143,128 +127,70 @@ generate a suitable AbsBinds to enclose the bindings.
 \end{itemize}
 
 \begin{code}
-genBinds top_level e bind lie lve sigs
-  = getSrcLocTc					`thenNF_Tc` \ locn ->
-
-	-- GET TYPE VARIABLES FREE IN ENV
-    applyTcSubstAndCollectTyVars (tvOfE e)	`thenNF_Tc` \ free_tyvars ->
-
-	-- CHECK THAT THE SIGNATURES MATCH
+genBinds binder_names mono_ids bind lie sig_infos prag_info_fn
+  =	-- CHECK THAT THE SIGNATURES MATCH
 	-- Doesn't affect substitution
-    mapTc (checkSigMatch free_tyvars) sigs	`thenTc_`
-
-	 -- UNPACK THE LVE
-    let
-	(bound_var_names, bound_var_locals) = unzip lve
-	bound_var_types = map getIdUniType bound_var_locals
-    in
-    applyTcSubstToTys bound_var_types `thenNF_Tc`	\ bound_var_types' ->
+    mapTc checkSigMatch sig_infos	`thenTc_`
+
+	-- CHECK THAT ALL THE SIGNATURE CONTEXTS ARE IDENTICAL
+	-- The type signatures on a mutually-recursive group of definitions
+	-- must all have the same context (or none).
+	-- We have to zonk them first to make their type variables line up
+    mapNF_Tc get_zonked_theta sig_infos		`thenNF_Tc` \ thetas ->
+    checkTc (null thetas || all (eqSimpleTheta (head thetas)) (tail thetas)) 
+	    (sigContextsErr sig_infos)		`thenTc_`
+
+	-- COMPUTE VARIABLES OVER WHICH TO QUANTIFY, namely tyvars_to_gen
+    mapNF_Tc (zonkTcType . idType) mono_ids	`thenNF_Tc` \ mono_id_types ->
+    tcGetGlobalTyVars 				`thenNF_Tc` \ free_tyvars ->
     let
-	mentioned_tyvars' = extractTyVarsFromTys bound_var_types'
-
-	 -- COMPUTE VARIABLES OVER WHICH TO QUANTIFY, namely tyvars_to_gen
-	tyvars_to_gen = mentioned_tyvars' `minusList` free_tyvars
-
-	-- UNSCRAMBLE "sigs" INTO VARIOUS FLAVOURS
-	-- AND SNAFFLE ANY "IdInfos" FOR VARS HERE
-
-	(ty_sigs, upragmas) = partition is_tysig_info sigs
-	inline_sigs 	    = filter is_inline_info   upragmas
-	deforest_sigs 	    = filter is_deforest_info upragmas
-	magic_uf_sigs	    = filter is_magic_uf_info upragmas
-	spec_sigs   	    = filter is_spec_info     upragmas
-
-	unfold_me_fn n
-	  = case [ x | x@(ValInlineInfo v _ _) <- inline_sigs, v == n ] of
-	      (ValInlineInfo _ guide _ :_) -> iWantToBeINLINEd guide
-	      [] ->
-		case [ x | x@(ValMagicUnfoldingInfo v _ _) <- magic_uf_sigs, v == n ] of
-		  (ValMagicUnfoldingInfo _ str _:_) -> mkMagicUnfolding str
-		  []			        -> noInfo_UF
-
-        deforest_me_fn n
-          = case [ x | x@(ValDeforestInfo v _) <- deforest_sigs, v == n ] of
-            (ValDeforestInfo _ _ : _) -> DoDeforest
-            [] -> Don'tDeforest
-
-	id_info_for n
-	  = noIdInfo
-	      `addInfo_UF` (unfold_me_fn   n)
-              `addInfo`    (deforest_me_fn n)
-
-	id_infos = [ id_info_for n | n <- bound_var_names ]
+	mentioned_tyvars = tyVarsOfTypes mono_id_types
+	tyvars_to_gen    = mentioned_tyvars `minusTyVarSet` free_tyvars
     in
-    resolveOverloading top_level e free_tyvars tyvars_to_gen lie bind ty_sigs
+
+	-- DEAL WITH OVERLOADING
+    resolveOverloading tyvars_to_gen lie bind sig_infos
 		 `thenTc` \ (lie', reduced_tyvars_to_gen, dict_binds, dicts_bound) ->
 
 	 -- BUILD THE NEW LOCALS
     let
-	dict_tys = map getInstUniType dicts_bound
-
-	envs_and_new_locals_types
-	  = map (quantifyTy reduced_tyvars_to_gen . glueTyArgs dict_tys) bound_var_types'
-
-	(_, new_locals_types) = unzip envs_and_new_locals_types
-    in
-	 -- The new_locals function is passed into genBinds
-	 -- so it can generate top-level or non-top-level locals
-    let
-	lve_of_new_ids = mkIdsWithGivenTys bound_var_names new_locals_types id_infos
-	new_ids = map snd lve_of_new_ids
+	tyvars	    = tyVarSetToList reduced_tyvars_to_gen	-- Commit to a particular order
+	dict_tys    = [idType d | TcId d <- dicts_bound]	-- Slightly ugh-ish
+	poly_tys    = map (mkForAllTys tyvars . mkFunTys dict_tys) mono_id_types
+	poly_ids    = zipWithEqual mk_poly binder_names poly_tys
+	mk_poly name ty = mkUserId name ty (prag_info_fn name)
     in
 	 -- BUILD RESULTS
     returnTc (
---	pprTrace "Gen: " (ppSep [ppr PprDebug new_ids, 
---				 ppStr "; to gen ", ppr PprDebug tyvars_to_gen,
---				 ppStr "; reduced ", ppr PprDebug reduced_tyvars_to_gen
---		]) $
-	 AbsBinds reduced_tyvars_to_gen (map mkInstId dicts_bound)
-		 (bound_var_locals `zip` new_ids)
-		 dict_binds bind,
+	 AbsBinds tyvars
+		  dicts_bound
+		  (map TcId mono_ids `zip` map TcId poly_ids)
+		  dict_binds
+		  bind,
 	 lie',
-	 lve_of_new_ids
+	 poly_ids
     )
-  where
-    is_tysig_info (TySigInfo _ _ _ _ _) = True
-    is_tysig_info _ 	    	    	= False
 
-    is_inline_info (ValInlineInfo _ _ _) = True
-    is_inline_info _ = False
-
-    is_deforest_info (ValDeforestInfo _ _) = True
-    is_deforest_info _ = False
- 
-    is_magic_uf_info (ValMagicUnfoldingInfo _ _ _) = True
-    is_magic_uf_info _ = False
-
-    is_spec_info (ValSpecInfo _ _ _ _) = True
-    is_spec_info _ = False
+get_zonked_theta (TySigInfo _ _ theta _ _)
+  = mapNF_Tc (\ (c,t) -> zonkTcType t `thenNF_Tc` \ t' -> returnNF_Tc (c,t')) theta
 \end{code}
 
 
 \begin{code}
-resolveOverloading 
-	:: Bool			-- True <=> top level
-	-> E
-	-> [TyVar]		-- Tyvars free in E
-	-> [TyVar]		-- Tyvars over which we are going to generalise
-	-> LIE			-- The LIE to deal with
-	-> TypecheckedBind	-- The binding group
-	-> [SignatureInfo]	-- And its real type-signature information
-	-> TcM (LIE,			-- LIE to pass up the way; a fixed point of
-					-- the current substitution
-	    	[TyVar],		-- Revised tyvars to generalise
-	    	[(Inst, TypecheckedExpr)],-- Dict bindings
-	    	[Inst])			-- List of dicts to bind here
-		       
-resolveOverloading top_level e free_tyvars tyvars_to_gen lie bind ty_sigs
-  = let
-	dicts = unMkLIE lie
-    in
-	 -- DEAL WITH MONOMORPHISM RESTRICTION
-    if (not (isUnRestrictedGroup tysig_vars bind)) then 
-
-	-- Restricted group, so bind no dictionaries, and
+resolveOverloading
+	:: TcTyVarSet s		-- Tyvars over which we are going to generalise
+	-> LIE s		-- The LIE to deal with
+	-> TcBind s		-- The binding group
+	-> [TcSigInfo s]	-- And its real type-signature information
+	-> TcM s (LIE s,			-- LIE to pass up the way; a fixed point of
+						-- the current substitution
+	    	  TcTyVarSet s,			-- Revised tyvars to generalise
+	    	  [(TcIdOcc s, TcExpr s)],	-- Dict bindings
+	    	  [TcIdOcc s])			-- List of dicts to bind here
+
+resolveOverloading tyvars_to_gen dicts bind ty_sigs
+  | not (isUnRestrictedGroup tysig_vars bind)
+  = 	-- Restricted group, so bind no dictionaries, and
 	-- remove from tyvars_to_gen any constrained type variables
 
 	-- *Don't* simplify dicts at this point, because we aren't going
@@ -277,11 +203,11 @@ resolveOverloading top_level e free_tyvars tyvars_to_gen lie bind ty_sigs
 	-- we'll know that the literals are all Ints, and we can just produce
 	-- Int literals!
 
-	-- Find all the type variables involved in overloading 
+	-- Find all the type variables involved in overloading, the "constrained_tyvars"
 	-- These are the ones we *aren't* going to generalise.
 	-- We must be careful about doing this:
 	--  (a) If we fail to generalise a tyvar which is not actually
-	--	constrained, then it will never, ever get bound, and lands 
+	--	constrained, then it will never, ever get bound, and lands
 	--	up printed out in interface files!  Notorious example:
 	--		instance Eq a => Eq (Foo a b) where ..
 	--	Here, b is not constrained, even though it looks as if it is.
@@ -289,94 +215,62 @@ resolveOverloading top_level e free_tyvars tyvars_to_gen lie bind ty_sigs
 	--	the LIE, whose type might very well involve non-overloaded
 	--	type variables.
 	--  (b) On the other hand, we mustn't generalise tyvars which are constrained,
-	--	because we are going to pass on out the unmodified LIE, with those 
+	--	because we are going to pass on out the unmodified LIE, with those
 	--	tyvars in it.  They won't be in scope if we've generalised them.
 	--
 	-- So we are careful, and do a complete simplification just to find the
 	-- constrained tyvars. We don't use any of the results, except to
 	-- find which tyvars are constrained.
 
-	tcSimplify top_level free_tyvars tyvars_to_gen dicts
-				    `thenTc` \ (_, _, dicts_sig) ->
-
--- ASSERT: tcSimplify has already applied subst to its results
--- (WDP/SLPJ 95/07)
---	applyTcSubstToInsts dicts_sig	`thenNF_Tc` 	\ dicts_sig' ->
+	tcSimplify tyvars_to_gen dicts	    `thenTc` \ (_, _, dicts_sig) ->
 	let
-	  constrained_tyvars
-	    = foldr (unionLists . extractTyVarsFromInst) [] dicts_sig
-
-	  reduced_tyvars_to_gen = tyvars_to_gen `minusList` constrained_tyvars
-
-	  increased_free_tyvars = free_tyvars `unionLists` constrained_tyvars
+	  -- ASSERT: dicts_sig is already zonked!
+	  constrained_tyvars    = foldBag unionTyVarSets tyVarsOfInst emptyTyVarSet dicts_sig
+	  reduced_tyvars_to_gen = tyvars_to_gen `minusTyVarSet` constrained_tyvars
 	in
 
-	-- Do it again, but with increased_free_tyvars/reduced_tyvars_to_gen:
-
-	tcSimplify top_level increased_free_tyvars reduced_tyvars_to_gen dicts
+	-- Do it again, but with increased free_tyvars/reduced_tyvars_to_gen:
+	-- We still need to do this simplification, because some dictionaries 
+	-- may gratuitouslyconstrain some tyvars over which we *are* going 
+	-- to generalise. 
+	-- For example d::Eq (Foo a b), where Foo is instanced as above.
+	tcSimplifyWithExtraGlobals constrained_tyvars reduced_tyvars_to_gen dicts
 				    `thenTc` \ (dicts_free, dicts_binds, dicts_sig2) ->
---NB: still no applyTcSubstToInsts
+	ASSERT(isEmptyBag dicts_sig2)
 
---	pprTrace "resolve:" (ppCat [ppr PprDebug free_tyvars, ppr PprDebug tyvars_to_gen, ppr PprDebug constrained_tyvars, ppr PprDebug reduced_tyvars_to_gen, ppr PprDebug bind]) $
-	returnTc (mkLIE (dicts_free++dicts_sig2), -- All these are left unbound
-		  reduced_tyvars_to_gen, 
+	returnTc (dicts_free,			-- All these are left unbound
+		  reduced_tyvars_to_gen,
 		  dicts_binds, 			-- Local dict binds
 		  [])				-- No lambda-bound dicts
 
 		-- The returned LIE should be a fixed point of the substitution
 
-    else -- Unrestricted group
-       case ty_sigs of
-	 [] ->	-- NO TYPE SIGNATURES
+  | otherwise	-- An unrestricted group
+  = case ty_sigs of
+	[] ->	-- NO TYPE SIGNATURES
 
-	    tcSimplify top_level free_tyvars tyvars_to_gen dicts
-				    `thenTc` \ (dicts_free, dict_binds, dicts_sig) ->
-	    returnTc (mkLIE dicts_free, tyvars_to_gen, dict_binds, dicts_sig)
+	    tcSimplify tyvars_to_gen dicts  `thenTc` \ (dicts_free, dict_binds, dicts_sig) ->
+	    returnTc (dicts_free, tyvars_to_gen, dict_binds, 
+		      map instToId (bagToList dicts_sig))
 
-	 other -> -- TYPE SIGNATURES PRESENT!
+	(TySigInfo _ _ theta _ _ : other) -> -- TYPE SIGNATURES PRESENT!
 
-		-- Check that all the signature contexts are identical
-		-- "tysig_dicts_s" is a list (one for each id declared
-		-- in this group) of lists of dicts (the list
-		-- corresponds to the context in the sig).
-		-- "dicts_sig" is just the first such list; we match
-		-- it against all the others.
+	    tcAddErrCtxt (sigsCtxt tysig_vars) $
 
-	    mapNF_Tc applyTcSubstToInsts tysig_dicts_s
-				`thenNF_Tc` \ (dicts_sig : other_dicts_s) ->
-
-	    checkTc (not (all (same_dicts dicts_sig) other_dicts_s))
-		-- The type signatures on a mutually-recursive group of definitions
-		-- must all have the same context (or none).  See Errors.lhs.
-		(sigContextsErr ty_sigs) `thenTc_`
+	    newDicts SignatureOrigin theta	`thenNF_Tc` \ (dicts_sig, dict_ids) ->
 
 		    -- Check that the needed dicts can be expressed in
 		    -- terms of the signature ones
 	    tcSimplifyAndCheck
-		top_level
-		free_tyvars 	-- Vars free in the environment
 		tyvars_to_gen 	-- Type vars over which we will quantify
 		dicts_sig	-- Available dicts
 		dicts		-- Want bindings for these dicts
-		(BindSigCtxt tysig_vars)
 
 				    `thenTc` \ (dicts_free, dict_binds) ->
 
-	    returnTc (mkLIE dicts_free, tyvars_to_gen, dict_binds, dicts_sig)
+	    returnTc (dicts_free, tyvars_to_gen, dict_binds, dict_ids)
   where
-    tysig_dicts_s = [dicts   | (TySigInfo _       _ dicts _ _) <- ty_sigs]
-    tysig_vars    = [sig_var | (TySigInfo sig_var _ _     _ _) <- ty_sigs] 
-
-	-- same_dicts checks that (post substitution) all the type signatures
-	-- constrain the same type variables in the same way
-    same_dicts []   	[]  	 = True
-    same_dicts []   	_   	 = False
-    same_dicts _	[]  	 = False
-    same_dicts (d1:d1s) (d2:d2s) = matchesInst d1 d2 && same_dicts d1s d2s
-
-    -- don't use the old version, because zipWith will truncate
-    -- the longer one!
-    --OLD: same_dicts dicts1 dicts2 = and (zipWith matchesInst dicts1 dicts2)
+    tysig_vars   = [sig_var | (TySigInfo sig_var _ _ _ _) <- ty_sigs]
 \end{code}
 
 @checkSigMatch@ does the next step in checking signature matching.
@@ -388,20 +282,12 @@ The error message here is somewhat unsatisfactory, but it'll do for
 now (ToDo).
 
 \begin{code}
-checkSigMatch :: [TyVar]	-- Free in environment
-	      -> SignatureInfo
-	      -> TcM [TyVar]
-
-checkSigMatch env_tyvars (TySigInfo name sig_tyvars _ tau_ty src_loc)
-  = let
-	inferred_ty = getIdUniType name
-    in
-    addSrcLocTc src_loc	(
-    checkSigTyVars env_tyvars sig_tyvars tau_ty inferred_ty
-		   (SigCtxt name tau_ty)
-    )
+checkSigMatch :: TcSigInfo s -> TcM s [TcTyVar s]
 
-checkSigMatch _ other_not_really_a_sig = returnTc []
+checkSigMatch (TySigInfo id sig_tyvars _ tau_ty src_loc)
+  = tcAddSrcLoc src_loc	$
+    tcAddErrCtxt (sigCtxt id) $
+    checkSigTyVars sig_tyvars tau_ty (idType id)
 \end{code}
 
 
@@ -414,22 +300,23 @@ checkSigMatch _ other_not_really_a_sig = returnTc []
 Not exported:
 
 \begin{code}
-isUnRestrictedGroup :: [Id]		-- Signatures given for these
-		     -> TypecheckedBind
-		     -> Bool
+isUnRestrictedGroup :: [TcIdBndr s]		-- Signatures given for these
+		    -> TcBind s
+		    -> Bool
 
 isUnRestrictedGroup sigs EmptyBind              = True
 isUnRestrictedGroup sigs (NonRecBind monobinds) = isUnResMono sigs monobinds
 isUnRestrictedGroup sigs (RecBind monobinds)    = isUnResMono sigs monobinds
 
-is_elem = isIn "isUnResMono"
+is_elem v vs = isIn "isUnResMono" v vs
 
-isUnResMono sigs EmptyMonoBinds = True
-isUnResMono sigs (AndMonoBinds mb1 mb2) = isUnResMono sigs mb1 && isUnResMono sigs mb2
-isUnResMono sigs (PatMonoBind (VarPat v) _ _)	= v `is_elem` sigs
-isUnResMono sigs (PatMonoBind other      _ _)	= False
-isUnResMono sigs (VarMonoBind v _)		= v `is_elem` sigs
-isUnResMono sigs (FunMonoBind _ _ _)		= True
+isUnResMono sigs (PatMonoBind (VarPat (TcId v)) _ _)	= v `is_elem` sigs
+isUnResMono sigs (PatMonoBind other      _ _)		= False
+isUnResMono sigs (VarMonoBind (TcId v) _)		= v `is_elem` sigs
+isUnResMono sigs (FunMonoBind _ _ _)			= True
+isUnResMono sigs (AndMonoBinds mb1 mb2)			= isUnResMono sigs mb1 &&
+							  isUnResMono sigs mb2
+isUnResMono sigs EmptyMonoBinds				= True
 \end{code}
 
 
@@ -441,7 +328,7 @@ isUnResMono sigs (FunMonoBind _ _ _)		= True
 
 @checkSigTyVars@ is used after the type in a type signature has been unified with
 the actual type found.  It then checks that the type variables of the type signature
-are 
+are
 	(a) still all type variables
 		eg matching signature [a] against inferred type [(p,q)]
 		[then a will be unified to a non-type variable]
@@ -456,51 +343,119 @@ are
 			g x = ... where
 					f :: a->[a]
 					f y = [x,y]
-	
+
 		Here, f is forced to be monorphic by the free occurence of x.
 
 Before doing this, the substitution is applied to the signature type variable.
 
-It's {\em assumed} that the substitution has already been applied to the 
-environment type variables.
-
 \begin{code}
-checkSigTyVars :: [TyVar]	-- Tyvars free in environment; 
-				-- fixed points of substitution
-	       -> [TyVar]	-- The original signature type variables
-	       -> UniType	-- signature type (for err msg)
-	       -> UniType	-- inferred type (for err msg)
-	       -> UnifyErrContext -- also for error msg
-	       -> TcM [TyVar]	-- Post-substitution signature type variables
-
-checkSigTyVars env_tyvars sig_tyvars sig_tau inferred_tau err_ctxt
-  = getSrcLocTc					`thenNF_Tc` \ locn ->
-    applyTcSubstToTy inferred_tau		`thenNF_Tc` \ inferred_tau' ->
-    let
-	match_err = badMatchErr sig_tau inferred_tau' err_ctxt locn
-    in
-    applyTcSubstToTyVars sig_tyvars	`thenNF_Tc` \ sig_tys ->
-
-	 -- Check point (a) above
-    checkMaybesTc (map getTyVarMaybe sig_tys) match_err	`thenTc` \ sig_tyvars' ->
+checkSigTyVars :: [TcTyVar s]		-- The original signature type variables
+	       -> TcType s		-- signature type (for err msg)
+	       -> TcType s		-- inferred type (for err msg)
+	       -> TcM s [TcTyVar s]	-- Post-substitution signature type variables
+
+checkSigTyVars sig_tyvars sig_tau inferred_tau
+  = tcGetGlobalTyVars			`thenNF_Tc` \ env_tyvars ->
+    checkSigTyVarsGivenGlobals env_tyvars sig_tyvars sig_tau inferred_tau
+
+checkSigTyVarsGivenGlobals
+	 :: TcTyVarSet s	-- Consider these fully-zonked tyvars as global
+	 -> [TcTyVar s]		-- The original signature type variables
+	 -> TcType s		-- signature type (for err msg)
+	 -> TcType s		-- inferred type (for err msg)
+	 -> TcM s [TcTyVar s]	-- Post-substitution signature type variables
+
+checkSigTyVarsGivenGlobals globals sig_tyvars sig_tau inferred_tau
+  = 	 -- Check point (a) above
+    mapNF_Tc (zonkTcType.mkTyVarTy) sig_tyvars				`thenNF_Tc` \ sig_tys ->
+    checkMaybeTcM (allMaybes (map getTyVar_maybe sig_tys)) match_err	`thenTc` \ sig_tyvars' ->
 
 	 -- Check point (b)
-    checkTc (not (hasNoDups sig_tyvars')) match_err 	`thenTc_`
+    checkTcM (hasNoDups sig_tyvars') match_err		`thenTc_`
 
 	-- Check point (c)
-	-- We want to report errors in terms of the original signature tyvars, 
+	-- We want to report errors in terms of the original signature tyvars,
 	-- ie sig_tyvars, NOT sig_tyvars'.  sig_tys and sig_tyvars' correspond
 	-- 1-1 with sig_tyvars, so we can just map back.
     let
-	is_elem = isIn "checkSigTyVars"
-
-	mono_tyvars = [ sig_tyvar 
+	mono_tyvars = [ sig_tyvar
 		      | (sig_tyvar,sig_tyvar') <- zipEqual sig_tyvars sig_tyvars',
-			sig_tyvar' `is_elem` env_tyvars
+			sig_tyvar' `elementOfTyVarSet` globals
 		      ]
     in
-    checkTc (not (null mono_tyvars))
-	    (notAsPolyAsSigErr sig_tau mono_tyvars err_ctxt locn) `thenTc_`
+    checkTc (null mono_tyvars)
+	    (notAsPolyAsSigErr sig_tau mono_tyvars)	`thenTc_`
 
     returnTc sig_tyvars'
+  where
+    match_err = zonkTcType inferred_tau	`thenNF_Tc` \ inferred_tau' ->
+		failTc (badMatchErr sig_tau inferred_tau')
+\end{code}
+
+
+%************************************************************************
+%*									*
+\subsection[GenEtc-SpecTy]{Instantiate a type and create new dicts for it}
+%*									*
+%************************************************************************
+
+\begin{code}
+specTy :: InstOrigin s
+       -> Type
+       -> NF_TcM s ([TcTyVar s], LIE s, TcType s, [TcIdOcc s])
+
+specTy origin sigma_ty
+  = tcInstType [] sigma_ty		`thenNF_Tc` \ tc_sigma_ty ->
+    let
+	(tyvars, theta, tau) = splitSigmaTy tc_sigma_ty
+    in
+	 -- Instantiate the dictionary types
+    newDicts origin theta		`thenNF_Tc` \ (dicts, dict_ids) ->
+
+	 -- Return the list of tyvars, the list of dicts and the tau type
+    returnNF_Tc (tyvars, dicts, tau, dict_ids)
+\end{code}
+
+
+
+Contexts and errors
+~~~~~~~~~~~~~~~~~~~
+\begin{code}
+notAsPolyAsSigErr sig_tau mono_tyvars sty
+  = ppHang (ppStr "A type signature is more polymorphic than the inferred type")
+	4  (ppAboves [ppStr "(That is, one or more type variables in the inferred type can't be forall'd.)",
+		      ppHang (ppStr "Monomorphic type variable(s):")
+		   	   4 (interpp'SP sty mono_tyvars),
+		      ppStr "Possible cause: the RHS mentions something subject to the monomorphism restriction"
+		     ])
+\end{code}
+
+
+\begin{code}
+badMatchErr sig_ty inferred_ty sty
+  = ppHang (ppStr "Type signature doesn't match inferred type") 
+	 4 (ppAboves [ppHang (ppStr "Signature:") 4 (ppr sty sig_ty),
+		      ppHang (ppStr "Inferred :") 4 (ppr sty inferred_ty)
+	   ])
+
+sigCtxt id sty 
+  = ppSep [ppStr "When checking signature for", ppr sty id]
+sigsCtxt ids sty 
+  = ppSep [ppStr "When checking signature(s) for:", interpp'SP sty ids]
+\end{code}
+
+
+\begin{code}
+sigContextsErr ty_sigs sty
+  = ppHang (ppStr "A group of type signatures have mismatched contexts")
+	 4 (ppAboves (map ppr_sig_info ty_sigs))
+  where
+    ppr_sig_info (TySigInfo val tyvars theta tau_ty _)
+      = ppHang (ppBeside (ppr sty val) (ppStr " :: "))
+    	     4 (if null theta
+		then ppNil
+		else ppBesides [ppStr "(", 
+			        ppIntersperse (ppStr ", ") (map (ppr_inst sty) theta), 
+				ppStr ") => ..."])
+    ppr_inst sty (clas, ty) = ppCat [ppr sty clas, ppr sty ty]
 \end{code}
diff --git a/ghc/compiler/typecheck/Inst.lhs b/ghc/compiler/typecheck/Inst.lhs
new file mode 100644
index 0000000000..7ad462e45c
--- /dev/null
+++ b/ghc/compiler/typecheck/Inst.lhs
@@ -0,0 +1,649 @@
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+%
+\section[Inst]{The @Inst@ type: dictionaries or method instances}
+
+\begin{code}
+#include "HsVersions.h"
+
+module Inst (
+	Inst(..), 	-- Visible only to TcSimplify
+
+	InstOrigin(..), OverloadedLit(..),
+	LIE(..), emptyLIE, unitLIE, plusLIE, consLIE, zonkLIE,
+
+        InstanceMapper(..),
+
+	newDicts, newDictsAtLoc, newMethod, newMethodWithGivenTy, newOverloadedLit,
+
+	instType, tyVarsOfInst, lookupInst,
+
+	isDict, isTyVarDict, 
+
+	zonkInst, instToId,
+
+	matchesInst,
+	instBindingRequired, instCanBeGeneralised
+
+    ) where
+
+import Ubiq
+
+import HsSyn	( HsLit(..), HsExpr(..), HsBinds, 
+		  InPat, OutPat, Stmt, Qual, Match,
+		  ArithSeqInfo, PolyType, Fake )
+import RnHsSyn	( RenamedArithSeqInfo(..), RenamedHsExpr(..) )
+import TcHsSyn	( TcIdOcc(..), TcExpr(..), TcIdBndr(..),
+		  mkHsTyApp, mkHsDictApp )
+
+import TcMonad
+import TcEnv	( tcLookupGlobalValueByKey )
+import TcType	( TcType(..), TcRhoType(..), TcMaybe, TcTyVarSet(..),
+		  tcInstType, tcInstTcType, zonkTcType )
+
+import Bag	( Bag, emptyBag, unitBag, unionBags, listToBag, consBag )
+import Class	( Class(..), GenClass, ClassInstEnv(..), getClassInstEnv )
+import Id	( GenId, idType, mkInstId )
+import MatchEnv	( lookupMEnv, insertMEnv )
+import Name	( Name )
+import NameTypes( ShortName, mkShortName )
+import Outputable
+import PprType	( GenClass, TyCon, GenType, GenTyVar )	
+import PprStyle	( PprStyle(..) )
+import Pretty
+import SpecEnv	( SpecEnv(..) )
+import SrcLoc	( SrcLoc, mkUnknownSrcLoc )
+import Type	( GenType, eqSimpleTy,
+		  isTyVarTy, mkDictTy, splitForAllTy, splitSigmaTy,
+		  splitRhoTy, matchTy, tyVarsOfType, tyVarsOfTypes )
+import TyVar	( GenTyVar )
+import TysPrim	  ( intPrimTy )
+import TysWiredIn ( intDataCon )
+import Unique	( Unique, showUnique,
+		  fromRationalClassOpKey, fromIntClassOpKey, fromIntegerClassOpKey )
+import Util	( panic, zipEqual, zipWithEqual, assoc, assertPanic )
+
+\end{code}
+
+%************************************************************************
+%*									*
+\subsection[Inst-collections]{LIE: a collection of Insts}
+%*									*
+%************************************************************************
+
+\begin{code}
+type LIE s = Bag (Inst s)
+
+emptyLIE          = emptyBag
+unitLIE inst 	  = unitBag inst
+plusLIE lie1 lie2 = lie1 `unionBags` lie2
+consLIE inst lie  = inst `consBag` lie
+
+zonkLIE :: LIE s -> NF_TcM s (LIE s)
+zonkLIE lie = mapBagNF_Tc zonkInst lie
+\end{code}
+
+%************************************************************************
+%*									*
+\subsection[Inst-types]{@Inst@ types}
+%*									*
+%************************************************************************
+
+An @Inst@ is either a dictionary, an instance of an overloaded
+literal, or an instance of an overloaded value.  We call the latter a
+``method'' even though it may not correspond to a class operation.
+For example, we might have an instance of the @double@ function at
+type Int, represented by
+
+	Method 34 doubleId [Int] origin
+
+\begin{code}
+data Inst s
+  = Dict
+	Unique
+	Class		-- The type of the dict is (c t), where
+	(TcType s)	-- c is the class and t the type;
+	(InstOrigin s)
+	SrcLoc
+
+  | Method
+	Unique
+
+	(TcIdOcc s)	-- The overloaded function
+			-- This function will be a global, local, or ClassOpId;
+			--   inside instance decls (only) it can also be an InstId!
+			-- The id needn't be completely polymorphic.
+			-- You'll probably find its name (for documentation purposes)
+			--	  inside the InstOrigin
+
+	[TcType s]	-- The types to which its polymorphic tyvars
+			--	should be instantiated.
+			-- These types must saturate the Id's foralls.
+
+	(TcRhoType s)	-- Cached: (type-of-id applied to inst_tys)
+			-- If this type is (theta => tau) then the type of the Method
+			-- is tau, and the method can be built by saying 
+			--	id inst_tys dicts
+			-- where dicts are constructed from theta
+
+	(InstOrigin s)
+	SrcLoc
+
+  | LitInst
+	Unique
+	OverloadedLit
+	(TcType s)	-- The type at which the literal is used
+	(InstOrigin s)	-- Always a literal; but more convenient to carry this around
+	SrcLoc
+
+data OverloadedLit
+  = OverloadedIntegral	 Integer	-- The number
+  | OverloadedFractional Rational	-- The number
+
+getInstOrigin (Dict   u clas ty     origin loc) = origin
+getInstOrigin (Method u clas ty rho origin loc) = origin
+getInstOrigin (LitInst u lit ty     origin loc) = origin
+\end{code}
+
+Construction
+~~~~~~~~~~~~
+
+\begin{code}
+newDicts :: InstOrigin s
+	 -> [(Class, TcType s)]
+	 -> NF_TcM s (LIE s, [TcIdOcc s])
+newDicts orig theta
+ = tcGetSrcLoc				`thenNF_Tc` \ loc ->
+   tcGetUniques (length theta)		`thenNF_Tc` \ new_uniqs ->
+   let
+	mk_dict u (clas, ty) = Dict u clas ty orig loc
+	dicts = zipWithEqual mk_dict new_uniqs theta
+   in
+   returnNF_Tc (listToBag dicts, map instToId dicts)
+
+newDictsAtLoc orig loc theta	-- Local function, similar to newDicts, 
+				-- but with slightly different interface
+ = tcGetUniques (length theta)		`thenNF_Tc` \ new_uniqs ->
+   let
+	mk_dict u (clas, ty) = Dict u clas ty orig loc
+	dicts = zipWithEqual mk_dict new_uniqs theta
+   in
+   returnNF_Tc (dicts, map instToId dicts)
+
+newMethod :: InstOrigin s
+	  -> TcIdOcc s
+	  -> [TcType s]
+	  -> NF_TcM s (LIE s, TcIdOcc s)
+newMethod orig id tys
+ =   	-- Get the Id type and instantiate it at the specified types
+   (case id of
+	RealId id -> let (tyvars, rho) = splitForAllTy (idType id)
+		     in tcInstType (tyvars `zipEqual` tys) rho
+	TcId   id -> let (tyvars, rho) = splitForAllTy (idType id)
+		     in tcInstTcType (tyvars `zipEqual` tys) rho
+   )						`thenNF_Tc` \ rho_ty ->
+
+	-- Our friend does the rest
+   newMethodWithGivenTy orig id tys rho_ty
+
+
+newMethodWithGivenTy orig id tys rho_ty
+ = tcGetSrcLoc			`thenNF_Tc` \ loc ->
+   tcGetUnique 			`thenNF_Tc` \ new_uniq ->
+   let
+	meth_inst = Method new_uniq id tys rho_ty orig loc
+   in
+   returnNF_Tc (unitLIE meth_inst, instToId meth_inst)
+
+newMethodAtLoc :: InstOrigin s -> SrcLoc -> Id -> [TcType s] -> NF_TcM s (Inst s, TcIdOcc s)
+newMethodAtLoc orig loc real_id tys	-- Local function, similar to newMethod but with 
+					-- slightly different interface
+ =   	-- Get the Id type and instantiate it at the specified types
+   let
+	(tyvars,rho) = splitForAllTy (idType real_id)
+   in
+   tcInstType (tyvars `zipEqual` tys) rho	`thenNF_Tc` \ rho_ty ->
+   tcGetUnique 					`thenNF_Tc` \ new_uniq ->
+   let
+	meth_inst = Method new_uniq (RealId real_id) tys rho_ty orig loc
+   in
+   returnNF_Tc (meth_inst, instToId meth_inst)
+
+newOverloadedLit :: InstOrigin s
+		 -> OverloadedLit
+		 -> TcType s
+		 -> NF_TcM s (LIE s, TcIdOcc s)
+newOverloadedLit orig lit ty
+ = tcGetSrcLoc			`thenNF_Tc` \ loc ->
+   tcGetUnique 			`thenNF_Tc` \ new_uniq ->
+   let
+	lit_inst = LitInst new_uniq lit ty orig loc
+   in
+   returnNF_Tc (unitLIE lit_inst, instToId lit_inst)
+\end{code}
+
+
+\begin{code}
+instToId :: Inst s -> TcIdOcc s
+instToId (Dict uniq clas ty orig loc)
+  = TcId (mkInstId uniq (mkDictTy clas ty) (mkShortName SLIT("dict") loc))
+instToId (Method uniq id tys rho_ty orig loc)
+  = TcId (mkInstId uniq tau_ty (mkShortName (getOccurrenceName id) loc))
+  where
+    (_, tau_ty) = splitRhoTy rho_ty	-- NB The method Id has just the tau type
+instToId (LitInst uniq list ty orig loc)
+  = TcId (mkInstId uniq ty (mkShortName SLIT("lit") loc))
+\end{code}
+
+\begin{code}
+instType :: Inst s -> TcType s
+instType (Dict _ clas ty _ _)     = mkDictTy clas ty
+instType (LitInst _ _ ty _ _)     = ty
+instType (Method _ id tys ty _ _) = ty
+\end{code}
+
+
+Zonking
+~~~~~~~
+Zonking makes sure that the instance types are fully zonked,
+but doesn't do the same for the Id in a Method.  There's no
+need, and it's a lot of extra work.
+
+\begin{code}
+zonkInst :: Inst s -> NF_TcM s (Inst s)
+zonkInst (Dict uniq clas ty orig loc)
+  = zonkTcType	ty			`thenNF_Tc` \ new_ty ->
+    returnNF_Tc (Dict uniq clas new_ty orig loc)
+
+zonkInst (Method uniq id tys rho orig loc) 		-- Doesn't zonk the id!
+  = mapNF_Tc zonkTcType tys		`thenNF_Tc` \ new_tys ->
+    zonkTcType rho			`thenNF_Tc` \ new_rho ->
+    returnNF_Tc (Method uniq id new_tys new_rho orig loc)
+
+zonkInst (LitInst uniq lit ty orig loc)
+  = zonkTcType ty			`thenNF_Tc` \ new_ty ->
+    returnNF_Tc (LitInst uniq lit new_ty orig loc)
+\end{code}
+
+
+\begin{code}
+tyVarsOfInst :: Inst s -> TcTyVarSet s
+tyVarsOfInst (Dict _ _ ty _ _)        = tyVarsOfType  ty
+tyVarsOfInst (Method _ _ tys rho _ _) = tyVarsOfTypes tys
+tyVarsOfInst (LitInst _ _ ty _ _)     = tyVarsOfType  ty
+\end{code}
+
+@matchesInst@ checks when two @Inst@s are instances of the same
+thing at the same type, even if their uniques differ.
+
+\begin{code}
+matchesInst :: Inst s -> Inst s -> Bool
+
+matchesInst (Dict _ clas1 ty1 _ _) (Dict _ clas2 ty2 _ _)
+  = clas1 == clas2 && ty1 `eqSimpleTy` ty2
+
+matchesInst (Method _ id1 tys1 _ _ _) (Method _ id2 tys2 _ _ _)
+  =  id1 == id2
+  && and (zipWith eqSimpleTy tys1 tys2)
+  && length tys1 == length tys2
+
+matchesInst (LitInst _ lit1 ty1 _ _) (LitInst _ lit2 ty2 _ _)
+  = lit1 `eq` lit2 && ty1 `eqSimpleTy` ty2
+  where
+    (OverloadedIntegral   i1) `eq` (OverloadedIntegral   i2) = i1 == i2
+    (OverloadedFractional f1) `eq` (OverloadedFractional f2) = f1 == f2
+    _			      `eq` _			     = False
+
+matchesInst other1 other2 = False
+\end{code}
+
+
+Predicates
+~~~~~~~~~~
+\begin{code}
+isDict :: Inst s -> Bool
+isDict (Dict _ _ _ _ _) = True
+isDict other	        = False
+
+isTyVarDict :: Inst s -> Bool
+isTyVarDict (Dict _ _ ty _ _) = isTyVarTy ty
+isTyVarDict other 	      = False
+\end{code}
+
+Two predicates which deal with the case where class constraints don't
+necessarily result in bindings.  The first tells whether an @Inst@
+must be witnessed by an actual binding; the second tells whether an
+@Inst@ can be generalised over.
+
+\begin{code}
+instBindingRequired :: Inst s -> Bool
+instBindingRequired inst
+  = case getInstOrigin inst of
+	CCallOrigin _ _   -> False	-- No binding required
+	LitLitOrigin  _   -> False
+	OccurrenceOfCon _ -> False
+	other             -> True
+
+instCanBeGeneralised :: Inst s -> Bool
+instCanBeGeneralised inst
+  = case getInstOrigin inst of
+	CCallOrigin _ _ -> False	-- Can't be generalised
+	LitLitOrigin  _ -> False	-- Can't be generalised
+	other           -> True
+\end{code}
+
+
+Printing
+~~~~~~~~
+ToDo: improve these pretty-printing things.  The ``origin'' is really only
+relevant in error messages.
+
+\begin{code}
+instance Outputable (Inst s) where
+    ppr sty (LitInst uniq lit ty orig loc)
+      = ppHang (ppSep [case lit of
+			  OverloadedIntegral   i -> ppInteger i
+			  OverloadedFractional f -> ppRational f,
+		       ppStr "at",
+		       ppr sty ty,
+		       show_uniq sty uniq
+		])
+	  4 (show_origin sty orig)
+
+    ppr sty (Dict uniq clas ty orig loc)
+      = ppHang (ppSep [ppr sty clas, 
+		       ppStr "at",
+		       ppr sty ty,
+		       show_uniq sty uniq
+		])
+	  4 (show_origin sty orig)
+
+    ppr sty (Method uniq id tys rho orig loc)
+      = ppHang (ppSep [ppr sty id, 
+		       ppStr "at",
+		       ppr sty tys,
+		       show_uniq sty uniq
+		])
+	  4 (show_origin sty orig)
+
+show_uniq PprDebug uniq = ppr PprDebug uniq
+show_uniq sty	   uniq = ppNil
+
+show_origin sty orig    = ppBesides [ppLparen, pprOrigin sty orig, ppRparen]
+\end{code}
+
+Printing in error messages
+
+\begin{code}
+noInstanceErr inst sty = ppHang (ppPStr SLIT("No instance for:")) 4 (ppr sty inst)
+\end{code}
+
+%************************************************************************
+%*									*
+\subsection[InstEnv-types]{Type declarations}
+%*									*
+%************************************************************************
+
+\begin{code}
+type InstanceMapper = Class -> (ClassInstEnv, ClassOp -> SpecEnv)
+\end{code}
+
+A @ClassInstEnv@ lives inside a class, and identifies all the instances
+of that class.  The @Id@ inside a ClassInstEnv mapping is the dfun for
+that instance.  
+
+There is an important consistency constraint between the @MatchEnv@s
+in and the dfun @Id@s inside them: the free type variables of the
+@Type@ key in the @MatchEnv@ must be a subset of the universally-quantified
+type variables of the dfun.  Thus, the @ClassInstEnv@ for @Eq@ might
+contain the following entry:
+@
+	[a] ===> dfun_Eq_List :: forall a. Eq a => Eq [a]
+@
+The "a" in the pattern must be one of the forall'd variables in
+the dfun type.
+
+\begin{code}
+lookupInst :: Inst s 
+	   -> TcM s ([Inst s], 
+		     (TcIdOcc s, TcExpr s))	-- The new binding
+
+-- Dictionaries
+
+lookupInst dict@(Dict _ clas ty orig loc)
+  = case lookupMEnv matchTy (get_inst_env clas orig) ty of
+      Nothing	-> failTc (noInstanceErr dict)
+
+      Just (dfun_id, tenv) 
+	-> let
+		(tyvars, rho) = splitForAllTy (idType dfun_id)
+		ty_args	      = map (assoc "lookupInst" tenv) tyvars
+		-- tenv should bind all the tyvars
+	   in
+	   tcInstType tenv rho		`thenNF_Tc` \ dfun_rho ->
+	   let
+		(theta, tau) = splitRhoTy dfun_rho
+	   in
+	   newDictsAtLoc orig loc theta	`thenNF_Tc` \ (dicts, dict_ids) ->
+	   let 
+		rhs = mkHsDictApp (mkHsTyApp (HsVar (RealId dfun_id)) ty_args) dict_ids
+	   in
+	   returnTc (dicts, (instToId dict, rhs))
+			     
+
+-- Methods
+
+lookupInst inst@(Method _ id tys rho orig loc)
+  = newDictsAtLoc orig loc theta	`thenNF_Tc` \ (dicts, dict_ids) ->
+    returnTc (dicts, (instToId inst, mkHsDictApp (mkHsTyApp (HsVar id) tys) dict_ids))
+  where
+    (theta,_) = splitRhoTy rho
+
+-- Literals
+
+lookupInst inst@(LitInst u (OverloadedIntegral i) ty orig loc)
+  | i >= toInteger minInt && i <= toInteger maxInt
+  =	-- It's overloaded but small enough to fit into an Int
+    tcLookupGlobalValueByKey fromIntClassOpKey	`thenNF_Tc` \ from_int ->
+    newMethodAtLoc orig loc from_int [ty]		`thenNF_Tc` \ (method_inst, method_id) ->
+    returnTc ([method_inst], (instToId inst, HsApp (HsVar method_id) int_lit))
+
+  | otherwise 
+  =     -- Alas, it is overloaded and a big literal!
+    tcLookupGlobalValueByKey fromIntegerClassOpKey	`thenNF_Tc` \ from_integer ->
+    newMethodAtLoc orig loc from_integer [ty]		`thenNF_Tc` \ (method_inst, method_id) ->
+    returnTc ([method_inst], (instToId inst, HsApp (HsVar method_id) (HsLitOut (HsInt i) ty)))
+  where
+    intprim_lit    = HsLitOut (HsIntPrim i) intPrimTy
+    int_lit        = HsApp (HsVar (RealId intDataCon)) intprim_lit
+
+lookupInst inst@(LitInst u (OverloadedFractional f) ty orig loc)
+  = tcLookupGlobalValueByKey fromRationalClassOpKey	`thenNF_Tc` \ from_rational ->
+    newMethodAtLoc orig loc from_rational [ty]		`thenNF_Tc` \ (method_inst, method_id) ->
+    returnTc ([method_inst], (instToId inst, HsApp (HsVar method_id) (HsLitOut (HsFrac f) ty)))
+\end{code}
+
+There is a second, simpler interface, when you want an instance of a
+class at a given nullary type constructor.  It just returns the
+appropriate dictionary if it exists.  It is used only when resolving
+ambiguous dictionaries.
+
+\begin{code}
+lookupClassInstAtSimpleType :: Class -> Type -> Maybe Id
+
+lookupClassInstAtSimpleType clas ty
+  = case (lookupMEnv matchTy (getClassInstEnv clas) ty) of
+      Nothing	    -> Nothing
+      Just (dfun,_) -> ASSERT( null tyvars && null theta )
+		       Just dfun
+		    where
+		       (tyvars, theta, _) = splitSigmaTy (idType dfun)
+\end{code}
+
+
+@mkInstSpecEnv@ is used to construct the @SpecEnv@ for a dfun.
+It does it by filtering the class's @InstEnv@.  All pretty shady stuff.
+
+\begin{code}
+mkInstSpecEnv clas inst_ty inst_tvs inst_theta = panic "mkInstSpecEnv"
+\end{code}
+
+\begin{pseudocode}
+mkInstSpecEnv :: Class			-- class
+	      -> Type			-- instance type
+	      -> [TyVarTemplate]	-- instance tyvars
+	      -> ThetaType		-- superclasses dicts
+	      -> SpecEnv		-- specenv for dfun of instance
+
+mkInstSpecEnv clas inst_ty inst_tvs inst_theta
+  = mkSpecEnv (catMaybes (map maybe_spec_info matches))
+  where
+    matches = matchMEnv matchTy (getClassInstEnv clas) inst_ty
+
+    maybe_spec_info (_, match_info, MkInstTemplate dfun _ [])
+      = Just (SpecInfo (map (assocMaybe match_info) inst_tvs) (length inst_theta) dfun)
+    maybe_spec_info (_, match_info, _)
+      = Nothing
+\end{pseudocode}
+
+
+\begin{code}
+addClassInst
+    :: ClassInstEnv		-- Incoming envt
+    -> Type			-- The instance type: inst_ty
+    -> Id			-- Dict fun id to apply. Free tyvars of inst_ty must
+				-- be the same as the forall'd tyvars of the dfun id.
+    -> MaybeErr
+	  ClassInstEnv		-- Success
+	  (Type, Id)		-- Offending overlap
+
+addClassInst inst_env inst_ty dfun_id = insertMEnv matchTy inst_env inst_ty dfun_id
+\end{code}
+
+
+
+%************************************************************************
+%*									*
+\subsection[Inst-origin]{The @InstOrigin@ type}
+%*									*
+%************************************************************************
+
+The @InstOrigin@ type gives information about where a dictionary came from.
+This is important for decent error message reporting because dictionaries
+don't appear in the original source code.  Doubtless this type will evolve...
+
+\begin{code}
+data InstOrigin s
+  = OccurrenceOf (TcIdOcc s)	-- Occurrence of an overloaded identifier
+  | OccurrenceOfCon Id		-- Occurrence of a data constructor
+
+  | InstanceDeclOrigin		-- Typechecking an instance decl
+
+  | LiteralOrigin	HsLit	-- Occurrence of a literal
+
+  | ArithSeqOrigin	RenamedArithSeqInfo -- [x..], [x..y] etc
+
+  | SignatureOrigin		-- A dict created from a type signature
+
+  | DoOrigin			-- The monad for a do expression
+
+  | ClassDeclOrigin		-- Manufactured during a class decl
+
+  | DerivingOrigin	InstanceMapper
+			Class
+			TyCon
+
+	-- During "deriving" operations we have an ever changing
+	-- mapping of classes to instances, so we record it inside the
+	-- origin information.  This is a bit of a hack, but it works
+	-- fine.  (Simon is to blame [WDP].)
+
+  | InstanceSpecOrigin	InstanceMapper
+			Class	-- in a SPECIALIZE instance pragma
+			Type
+
+	-- When specialising instances the instance info attached to
+	-- each class is not yet ready, so we record it inside the
+	-- origin information.  This is a bit of a hack, but it works
+	-- fine.  (Patrick is to blame [WDP].)
+
+  | DefaultDeclOrigin		-- Related to a `default' declaration
+
+  | ValSpecOrigin	Name	-- in a SPECIALIZE pragma for a value
+
+	-- Argument or result of a ccall
+	-- Dictionaries with this origin aren't actually mentioned in the
+	-- translated term, and so need not be bound.  Nor should they
+	-- be abstracted over.
+
+  | CCallOrigin		String			-- CCall label
+			(Maybe RenamedHsExpr)	-- Nothing if it's the result
+						-- Just arg, for an argument
+
+  | LitLitOrigin	String	-- the litlit
+
+  | UnknownOrigin	-- Help! I give up...
+\end{code}
+
+\begin{code}
+-- During deriving and instance specialisation operations
+-- we can't get the instances of the class from inside the
+-- class, because the latter ain't ready yet.  Instead we
+-- find a mapping from classes to envts inside the dict origin.
+
+get_inst_env :: Class -> InstOrigin s -> ClassInstEnv
+get_inst_env clas (DerivingOrigin inst_mapper _ _)
+  = fst (inst_mapper clas)
+get_inst_env clas (InstanceSpecOrigin inst_mapper _ _)
+  = fst (inst_mapper clas)
+get_inst_env clas other_orig = getClassInstEnv clas
+
+
+pprOrigin :: PprStyle -> InstOrigin s -> Pretty
+
+pprOrigin sty (OccurrenceOf id)
+      = ppBesides [ppPStr SLIT("at a use of an overloaded identifier: `"),
+		   ppr sty id, ppChar '\'']
+pprOrigin sty (OccurrenceOfCon id)
+      = ppBesides [ppPStr SLIT("at a use of an overloaded constructor: `"),
+		   ppr sty id, ppChar '\'']
+pprOrigin sty (InstanceDeclOrigin)
+      = ppStr "in an instance declaration"
+pprOrigin sty (LiteralOrigin lit)
+      = ppCat [ppStr "at an overloaded literal:", ppr sty lit]
+pprOrigin sty (ArithSeqOrigin seq)
+      = ppCat [ppStr "at an arithmetic sequence:", ppr sty seq]
+pprOrigin sty (SignatureOrigin)
+      = ppStr "in a type signature"
+pprOrigin sty (DoOrigin)
+      = ppStr "in a do statement"
+pprOrigin sty (ClassDeclOrigin)
+      = ppStr "in a class declaration"
+pprOrigin sty (DerivingOrigin _ clas tycon)
+      = ppBesides [ppStr "in a `deriving' clause; class `",
+			  ppr sty clas,
+			  ppStr "'; offending type `",
+		          ppr sty tycon,
+			  ppStr "'"]
+pprOrigin sty (InstanceSpecOrigin _ clas ty)
+      = ppBesides [ppStr "in a SPECIALIZE instance pragma; class \"",
+	 	   ppr sty clas, ppStr "\" type: ", ppr sty ty]
+pprOrigin sty (DefaultDeclOrigin)
+      = ppStr "in a `default' declaration"
+pprOrigin sty (ValSpecOrigin name)
+      = ppBesides [ppStr "in a SPECIALIZE user-pragma for `",
+		   ppr sty name, ppStr "'"]
+pprOrigin sty (CCallOrigin clabel Nothing{-ccall result-})
+      = ppBesides [ppStr "in the result of the _ccall_ to `",
+		   ppStr clabel, ppStr "'"]
+pprOrigin sty (CCallOrigin clabel (Just arg_expr))
+      = ppBesides [ppStr "in an argument in the _ccall_ to `",
+		  ppStr clabel, ppStr "', namely: ", ppr sty arg_expr]
+pprOrigin sty (LitLitOrigin s)
+      = ppBesides [ppStr "in this ``literal-literal'': ", ppStr s]
+pprOrigin sty UnknownOrigin
+      = ppStr "in... oops -- I don't know where the overloading came from!"
+\end{code}
+
+
+
diff --git a/ghc/compiler/typecheck/Spec.hi b/ghc/compiler/typecheck/Spec.hi
deleted file mode 100644
index 121b12f42a..0000000000
--- a/ghc/compiler/typecheck/Spec.hi
+++ /dev/null
@@ -1,18 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface Spec where
-import Bag(Bag)
-import CmdLineOpts(GlobalSwitch)
-import HsExpr(Expr)
-import HsPat(TypecheckedPat)
-import Id(Id)
-import Inst(Inst, InstOrigin)
-import LIE(LIE)
-import Pretty(PprStyle, PrettyRep)
-import SplitUniq(SplitUniqSupply)
-import SrcLoc(SrcLoc)
-import Subst(Subst)
-import TyVar(TyVar)
-import UniType(UniType)
-specId :: Id -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> ((Expr Id TypecheckedPat, LIE, UniType), Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep))
-specTy :: InstOrigin -> UniType -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> (([TyVar], [Inst], UniType), Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep))
-
diff --git a/ghc/compiler/typecheck/Spec.lhs b/ghc/compiler/typecheck/Spec.lhs
deleted file mode 100644
index 7bee36a78d..0000000000
--- a/ghc/compiler/typecheck/Spec.lhs
+++ /dev/null
@@ -1,158 +0,0 @@
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
-%
-%************************************************************************
-%*									*
-\section[Spec]{Specialisation of variables}
-%*									*
-%************************************************************************
-
-One thing which happens {\em a lot} is the instantiation of a type scheme
-caused by the occurrence of a variable.  It is so important that it
-is written below in a very ``open-code'' fashion.  All the modular monadery
-is discarded, and we work directly in terms of the underlying representations.
-In particular, this function knows about
-
-	- the TcM monad
-	- the representation of UniTypes
-
-\begin{code}
-#include "HsVersions.h"
-
-module Spec ( specId, specTy ) where
-
-import AbsSyn
-import TcMonadFns	( copyTyVars, newDicts )
-import TcMonad
-
-import AbsUniType	{- ( instantiateTauTy, instantiateThetaTy,
-			  cloneTyVarFromTemplate, splitType
-			) -} -- pragmas want to see it all!
-import Id		( getIdUniType, mkInstId, DictVar(..) )
-import Inst		-- ( mkMethod, InstOrigin(..), Inst, InstTemplate, SpecInfo )
-import LIE
-import Subst		( getSubstTyVarUnique )
-import UniType		-- known **GRIEVOUS** violation of UniType abstractness!!!
-import SplitUniq
-import Unique
-import Util
-\end{code}
-
-%************************************************************************
-%*									*
-\subsection[Spec-specId]{Instantiating an Id}
-%*									*
-%************************************************************************
-
-@specId@ takes an @Id@ and implements the SPEC and REL rules
-returning
-	- the id applied to suitable types and dictionaries
-	- the LIE
-	- its instantiated tau type
-
-For efficiency, it knows about the TcM implementation.
-
-\begin{code}
-specId :: Id -> NF_TcM (TypecheckedExpr, LIE, TauType)
-
-specId id sw_chkr dtys subst uniq errs src_loc
-  = case (spec_sigma subst uniq src_loc id (getIdUniType id)) of
-      (result, subst2) -> (result, subst2, errs)
-\end{code}
-
-\begin{code}
-spec_sigma :: Subst		-- TyVar unique supply inside *here*
-	   -> SplitUniqSupply	-- "normal" unique supply
-	   -> SrcLoc
-	   -> Id
-	   -> UniType
-	   -> ((TypecheckedExpr, LIE, TauType), Subst)
-
-spec_sigma subst uniq src_loc id (UniSyn _ _ ty)
-  = spec_sigma subst uniq src_loc id ty
-
-spec_sigma subst uniq src_loc id ty@(UniForall _ _)
-  = collect [] [] subst ty
-  where
-    collect tenv tyvar_tys subst (UniForall tyvar ty)
-      = case (getSubstTyVarUnique subst) of
-	  (subst', u) ->
-	      collect ((tyvar, new_tyvar_ty) : tenv)
-		      (new_tyvar_ty : tyvar_tys)
-		      subst' ty
-	      where
-		new_tyvar_ty = UniTyVar (cloneTyVarFromTemplate tyvar u)
-
-    collect tenv tyvar_tys subst ty
-      = spec_rho tenv (reverse tyvar_tys) subst uniq src_loc id ty
-
-spec_sigma subst uniq src_loc id tau_ty
-	-- Not polymorphic => cannot be overloaded
-  = ((Var id, nullLIE, tau_ty), subst)
-\end{code}
-
-\begin{code}
-spec_rho :: [(TyVarTemplate, UniType)] -> [UniType]
-	 -> Subst -> SplitUniqSupply -> SrcLoc
-	 -> Id -> UniType
-	 -> ((TypecheckedExpr, LIE, TauType), Subst)
-
-spec_rho tenv tys subst uniqs src_loc id (UniSyn _ _ ty)
-  = spec_rho tenv tys subst uniqs src_loc id ty
-
-spec_rho tenv tys subst uniqs src_loc id (UniFun (UniDict _ _) ty)
-  = ((Var inst_id, unitLIE method, instantiateTauTy tenv tau_ty),
-     subst)
-  where
-    method  = mkMethod u id tys (OccurrenceOf id src_loc)
-    inst_id = mkInstId method
-    u	    = getSUnique uniqs
-    tau_ty  = discard_dicts ty
-
-    discard_dicts (UniFun (UniDict _ _) ty) = discard_dicts ty
-    discard_dicts other_ty                  = other_ty
-
-spec_rho tenv tys subst uniqs src_loc id tau_ty
-  = ((TyApp (Var id) tys, nullLIE, instantiateTauTy tenv tau_ty),
-     subst)
-\end{code}
-
-
-%************************************************************************
-%*									*
-\subsection[Spec-specTy]{Instantiating a type}
-%*									*
-%************************************************************************
-
-@specTy@ takes a polymorphic type, and instantiates it with fresh type
-variables. It strips off the context part, gets fresh dictionary
-variables for each predicate in the context.  It returns
-
-	- a list of the dictionary variables (remember they contain
-	  their types)
-	- an instantiated tau-type
-
-The returned values are fixed points of the current substitution
-though the arguments may not be.
-
-\begin{code}
-specTy :: InstOrigin -> SigmaType -> NF_TcM ([TyVar], [Inst], TauType)
-
-specTy origin sigma_ty
-  = let
-	(old_tyvars, theta, tau_ty) = splitType sigma_ty
-    in
-	 -- make new tyvars for each of the universally quantified type vars
-    copyTyVars old_tyvars	    `thenNF_Tc` \ (inst_env, new_tyvars, _) ->
-
-	 -- instantiate the tau type
-    let
-	tau_ty' = instantiateTauTy inst_env tau_ty
-    in
-	 -- instantiate the dictionary types
-    newDicts origin (instantiateThetaTy inst_env theta)	`thenNF_Tc` \ dicts ->
-
-	 -- return the list of tyvars, the list of dicts and the tau type
-    returnNF_Tc ( new_tyvars, dicts, tau_ty' )
-\end{code}
-
diff --git a/ghc/compiler/typecheck/Subst.hi b/ghc/compiler/typecheck/Subst.hi
deleted file mode 100644
index 137452c621..0000000000
--- a/ghc/compiler/typecheck/Subst.hi
+++ /dev/null
@@ -1,25 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface Subst where
-import Bag(Bag)
-import Class(Class)
-import Maybes(Labda)
-import PreludeGlaST(_MutableArray)
-import TyCon(TyCon)
-import TyVar(TyVar, TyVarTemplate)
-import UniType(UniType)
-import Unique(Unique)
-data Subst 
-data SubstResult   = SubstOK | OccursCheck TyVar UniType | AlreadyBound UniType
-data TyVar 
-data UniType 
-applySubstToThetaTy :: Subst -> [(Class, UniType)] -> (Subst, [(Class, UniType)])
-applySubstToTy :: Subst -> UniType -> (Subst, UniType)
-applySubstToTyVar :: Subst -> TyVar -> (Subst, UniType)
-combineSubstUndos :: Subst -> Subst
-extendSubst :: TyVar -> UniType -> Subst -> (Subst, SubstResult)
-getSubstTyVarUnique :: Subst -> (Subst, Unique)
-getSubstTyVarUniques :: Int -> Subst -> (Subst, [Unique])
-mkEmptySubst :: Int -> Subst
-pushSubstUndos :: Subst -> Subst
-undoSubstUndos :: Subst -> Subst
-
diff --git a/ghc/compiler/typecheck/Subst.lhs b/ghc/compiler/typecheck/Subst.lhs
deleted file mode 100644
index f5fad7fc24..0000000000
--- a/ghc/compiler/typecheck/Subst.lhs
+++ /dev/null
@@ -1,827 +0,0 @@
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
-%
-\section[Subst]{Substitutions}
-
-\begin{code}
-#include "HsVersions.h"
-
-module Subst (
-	Subst, SubstResult(..),	-- Subst is an abstract data type
-
-	mkEmptySubst, extendSubst,
-
---not exported:	applySubstToTauTy,
-	applySubstToTy,
-	applySubstToThetaTy, applySubstToTyVar, 
-
-	getSubstTyVarUniques, getSubstTyVarUnique,
-
-	pushSubstUndos, combineSubstUndos, undoSubstUndos,
-	-- pruneSubst,
-
-	-- and to make the interface self-sufficient...
-	TyVar, UniType
-    ) where
-
-import AbsUniType	-- lots of stuff, plus...
-import UniType		-- UniType(..) -- *********** YOW!!! ********
-import Bag		( emptyBag, unionBags, snocBag, 
-			  bagToList, filterBag, unitBag, Bag )
-import Maybes		( Maybe(..), maybeToBool )
-import Outputable
-import Unique
-import Util
-\end{code}
-
-%************************************************************************
-%*									*
-\subsection[Subst-magic-importst]{Funny imports to support magic implementation}
-%*									*
-%************************************************************************
-
-Or lack thereof.
-
-If we are compiling with Glasgow Haskell we can use mutable
-arrays to implement the substitution ...
-
-\begin{code}
-#ifndef __GLASGOW_HASKELL__
-
-import LiftMonad
-
-#else {- __GLASGOW_HASKELL__ -}
-
-import PreludeGlaST
-
-type STWorld = _State _RealWorld
-
-newWorld (S# real_world) = S# real_world
-
-#endif {- __GLASGOW_HASKELL__ -}
-\end{code}
-
-%************************************************************************
-%*									*
-\subsection[Subst-common]{@Subst@: common implementation-independent bits}
-%*									*
-%************************************************************************
-
-\begin{code}
-data SubstResult
-  = SubstOK		
-  | OccursCheck	    TyVar
-		    TauType
-  | AlreadyBound    TauType -- The variable is already bound
-			    -- to this type.  The type is *not*
-			    -- necessarily a fixed pt of the 
-			    -- substitution
-\end{code}
-
-Common signatures of major functions.
-
-\begin{code}
-mkEmptySubst :: Int -> Subst
-\end{code}
-
-%---------
-
-@extendSubst@: Add a single binding to the substitution. We have to:
-\begin{itemize}
-\item
-apply the existing bindings to the new one;
-\item
-check whether we are adding a trivial substitution of a type
-variable to itself (if so, do nothing);
-\item
-perform an occurs check on the right-hand side of the new binding;
-\end{itemize}
-We do not apply the new binding to all the existing ones. This is 
-delayed until the substitution is applied.
-\begin{code}
-extendSubst :: TyVar 		-- Tyvar to bind
-	    -> TauType 		-- Type to bind it to; NB can be a synonym
-	    -> SubstM SubstResult
-\end{code}
-
-%---------
-
-Apply a substitution to a given type.  
-
-	{\em The type returned is guaranteed to be 
-	a fixed point of the substitution.}
-
-Hence, we have to traverse the type determining the type mapped to
-tyvars. The type mapped must be recusively traversed as the substition
-is not stored idempotently.
-
-@applySubstToTauTy@ does not expect to meet a dict or forall type.
-@applySubstToTy@ may encounter these, but complains if the forall
-binds a variable which is in the domain of the substitution.
-
-\begin{code}
-applySubstToTy	    :: Subst -> UniType   -> (Subst, UniType)
-applySubstToTauTy   :: Subst -> TauType   -> (Subst, TauType)
-applySubstToThetaTy :: Subst -> ThetaType -> (Subst, ThetaType)
-applySubstToTyVar   :: Subst -> TyVar     -> (Subst, TauType)
-\end{code}
-
-These functions are only used by the type checker.  We know that 
-all the for-all'd type variables are fixed points of the substitution,
-so it's quite safe just to apply the substitution inside foralls.
-
-%---------
-
-Sorta obvious.
-\begin{code}
-getSubstTyVarUnique  :: Subst -> (Subst, Unique)
-getSubstTyVarUniques :: Int -> Subst -> (Subst, [Unique])
-\end{code}
-
-%---------
-
-@pushSubstUndos@ starts a new subst undo scope, saving the old scopes.
-It also saves the current unique supply so that it can be restored if
-the typecheck fails.
-
-@combineSubstUndos@ is called after a successful typecheck. It
-combines the current undos with the previos ones in case we fail in an
-outer scope. If no previous undos exist the undos are thrown away as
-we must have succeeded at the top level. The unique supply of the
-successful scope is returned to the unique supply of the current
-scope.
-
-@undoSubstUndos@ is called when a typecheck failed. The any
-substitution modifications are undone and the undo information
-discarded. The saved unique supply of the enclosing scope is restored.
-\begin{code}
-pushSubstUndos, combineSubstUndos, undoSubstUndos :: Subst -> Subst
-\end{code}
-
-%************************************************************************
-%*									*
-\subsection[Subst-Arrays]{@Subst@ with mutable @Arrays@ !!!}
-%*									*
-%************************************************************************
-
-Depends on....
-\begin{code}
-#ifdef __GLASGOW_HASKELL__
-\end{code}
-
-%************************************************************************
-%*									*
-\subsubsection{@Subst@: specification and representation}
-%*									*
-%************************************************************************
-
-{\em Specification:}
-* When new bindings are added to the substitution, an occurs check is performed.
-* The applySubst function guarantees to return a fixed point of the substitution.
-
-{\em Representation:}
-A substitution binds type variables to tau-types, that is @UniType@s without
-any @UniForall@ or @UniDict@ constructors.
-
-It is represented as an array, indexed on Int, with a world
-token, and a stack of type variables whos subst may be undone. The
-array is extended (by copying) if it overflows. The supply of
-Ints and the size of the array are linked so the substitution
-is also responsible for allocating the supply of uniques.
-
-The undo information is a stack of bags of the nested modifications to
-the substitution. If the typecheck fails the modifications to the
-substition are undone. If it succeeds the current undos are combined
-with the undos in the enclosing scope so that they would be undone if
-the enclsing scope typecheck fails.
-
-The unique supply is also stacked so that it can be restored if a
-typecheck fails.
-
-NOTE: The uniqueness of the world token, and hence the substitution,
-is critical as the 'worldSEQ' operation is unsafe if the token can be
-duplicated!!!
-
-\begin{code}
-type SubstArray = _MutableArray _RealWorld Int (Maybe TauType)
-
-type SubstArrayIndex = Int	-- Allocated within this module, single-threadedly
-
-data Subst
-  = MkSubst SubstArray		-- Mapping for allocated tyvars
-
-	    [(SubstArrayIndex, Bag (SubstArrayIndex, Maybe TauType))]
-				-- Stack to be undone if we fail, plus next free
-				-- slot when reverting.  All the undos are for
-				-- slots earlier than the corresp "next free" index.
-				--
-				-- The "bag" is a lie: it's really a sequence, with
-				-- the most recently performed write appearing first.
-
-	    STWorld 		-- State token
-
-	    SubstArrayIndex	-- Next free slot
-\end{code}
-
-Here's a local monad for threading the substitution around:
-
-\begin{code}
-type SubstM a = Subst -> (Subst,a)
-
-returnSubstM x = \s -> (s,x)
-thenSubstM m k = \s -> case m s of { (s1, r) -> k r s1 }
-
-mapSubstM f []     = returnSubstM []
-mapSubstM f (x:xs) = f x		`thenSubstM` \ r ->
-		     mapSubstM f xs	`thenSubstM` \ rs ->
-		     returnSubstM (r:rs)
-
--- Breaks the ST abstraction.  But we have to do so somewhere...
-doST :: STWorld -> ST _RealWorld a -> (a, STWorld)
-doST w st = st w
-\end{code}
-
-%********************************************************
-%*							*
-\subsubsection{@Subst@: the array}
-%*							*
-%********************************************************
-
-\begin{code}
-writeSubst  :: SubstArrayIndex -> Maybe TauType -> SubstM ()
-	-- writeSubst writes in such a way that we can undo it later
-
-writeSubst index new_val 
-	   (MkSubst arr undo_stack@((checkpoint, undos):rest_undo_stack) 
-		    world next_free)
-  | index < checkpoint	-- Record in undos
-  = let
-	(old, new_world) = doST world (
-			  readArray arr index		`thenStrictlyST` \ old_val ->
-			  writeArray arr index new_val	`seqStrictlyST`
-			  returnStrictlyST old_val
-			)
-	new_undos = unitBag (index,old) `unionBags` undos
-			-- The order is significant!  The right most thing
-			-- gets undone last
-    in
-    (MkSubst arr ((checkpoint, new_undos) : rest_undo_stack) new_world next_free, ())
-
-writeSubst index new_val (MkSubst arr undo_stack world next_free)
-  -- No need to record in undos: undo_stack is empty,
-  -- or index is after checkpoint
-  = let
-	(_, new_world) = doST world (writeArray arr index new_val)
-    in
-    (MkSubst arr undo_stack new_world next_free, ())
-
-readSubst  :: SubstArrayIndex -> SubstM (Maybe TauType)
-readSubst index (MkSubst arr undos world supplies)
-  = let
-	(result, new_world) = doST world (readArray arr index)
-    in
-    (MkSubst arr undos new_world supplies, result)
-
-tyVarToIndex :: TyVar -> SubstArrayIndex
-tyVarToIndex tyvar = unpkUnifiableTyVarUnique (getTheUnique tyvar)
-\end{code}
-
-%********************************************************
-%*							*
-\subsubsection{@Subst@: building them}
-%*							*
-%********************************************************
-
-The function @mkEmptySubst@ used to be a CAF containing a mutable
-array.  The imperative world had a name for this kind of thing:
-``global variable'' and has observed that using these ``global variables''
-leads to something they call ``side effects''.
-
-These ``side effects'' never caused a problem for @hsc@ because empty
-substitutions are only used in one place (the typechecker) and only
-used once in every program run.  In \tr{ghci} however, we might use the
-typechecker several times---in which case we'd like to have a
-different (fresh) substitution each time.  The easy way (HACK) to
-achieve this is to deCAFinate so that a fresh substitution will be
-created each time the typechecker runs.
-
-\begin{code}
-aRRAY_START :: Int
-aRRAY_START = 0
-
-mkEmptySubst aRRAY_SIZE
-  = let
-      	world = newWorld (S# realWorld#)
-	(arr, new_world) = doST world (newArray (aRRAY_START,aRRAY_SIZE) Nothing)
-    in
-    MkSubst arr [] new_world aRRAY_START
-
-extendSubstArr :: Subst
-	       -> Subst
-extendSubstArr (MkSubst old_arr undos world next_free)
-  = let
-	-- these "sizes" are really end-limits (WDP 94/11)
-	cur_size  = case (boundsOfArray old_arr) of { (_, x) -> x }
-        new_size = (cur_size * 2) + 1
-
-	(new_arr, new_world) = doST world (
-				newArray (aRRAY_START,new_size) Nothing	`thenStrictlyST` \ new_arr ->
-				let
-				    copyArr pos
-					| pos > cur_size = returnStrictlyST ()
-					| otherwise
-					  = readArray  old_arr pos	`thenStrictlyST`  \ ele ->
-					    writeArray new_arr pos ele	`seqStrictlyST`
-					    copyArr (pos + 1)
-				in
-				copyArr aRRAY_START		`seqStrictlyST`
-				returnStrictlyST new_arr
-			    )
-    in
-    MkSubst new_arr undos new_world next_free
-\end{code}
-
-\begin{code}
-extendSubst tyvar tau_ty
-  = readSubst index		`thenSubstM` \ maybe_ty ->
-
-    case maybe_ty of
-       Just exist_ty ->	-- Bound already
-		returnSubstM (AlreadyBound exist_ty)
-
-       Nothing       ->	-- Not already bound
-	  apply_rep_to_ty tau_ty `thenSubstM` \ new_tau_ty ->
-	  case expandVisibleTySyn new_tau_ty of
-		UniTyVar tv | tv `eqTyVar` tyvar ->
-		       	-- Trivial new binding of a type variable to itself; 
-			-- return old substition
-		       returnSubstM SubstOK
-
-		other | tyvar `is_elem`  (extractTyVarsFromTy new_tau_ty) ->
-			-- Occurs check finds error
-			returnSubstM (OccursCheck tyvar new_tau_ty)
-
-		      | otherwise -> 
-			-- OK to bind 
-			writeSubst index (Just new_tau_ty) `thenSubstM` \ _ ->
-			returnSubstM SubstOK
-  where
-      index   = tyVarToIndex tyvar
-      is_elem = isIn "extendSubst"
-\end{code}
-
-%********************************************************
-%*							*
-\subsubsection{@Subst@: lookup}
-%*							*
-%********************************************************
-
-All of them use the underlying function, @apply_rep_to_ty@, which
-ensures that an idempotent result is returned.
-
-\begin{code}
-applySubstToTy      subst ty       = apply_rep_to_ty ty subst
-applySubstToTauTy   subst tau_ty   = apply_rep_to_ty tau_ty subst
-applySubstToTyVar   subst tyvar    = apply_rep_to_ty (mkTyVarTy tyvar) subst
-applySubstToThetaTy subst theta_ty 
-  = let
-      do_one (clas, ty) = apply_rep_to_ty ty  `thenSubstM` \ new_ty ->
-			  returnSubstM (clas, new_ty)
-    in
-    mapSubstM do_one theta_ty subst
-\end{code}
-
-And now down to serious business...
-\begin{code}  
-apply_rep_to_ty :: UniType -> SubstM UniType
-
-apply_rep_to_ty (UniTyVar tyvar)
-  = readSubst index		`thenSubstM` \ maybe_ty ->
-    case maybe_ty of
-
-      Nothing -> -- Not found, so return a trivial type
-		 returnSubstM (mkTyVarTy tyvar)
-
-      Just ty -> -- Found, so recursively apply the subst the result to
-		 -- maintain idempotence!
-		 apply_rep_to_ty ty		`thenSubstM` \ new_ty ->
-
-		 -- The mapping for this tyvar is then updated with the
-		 -- result to reduce the number of subsequent lookups
-		 writeSubst index (Just new_ty)	`thenSubstM` \ _ ->
-
-		 returnSubstM new_ty
-  where
-    index = tyVarToIndex tyvar
-
-apply_rep_to_ty (UniFun t1 t2)
-  = apply_rep_to_ty t1		`thenSubstM` \ new_t1 ->
-    apply_rep_to_ty t2		`thenSubstM` \ new_t2 ->
-    returnSubstM (UniFun new_t1 new_t2)
-
-apply_rep_to_ty (UniData con args)
-  = mapSubstM apply_rep_to_ty args	`thenSubstM` \ new_args ->
-    returnSubstM (UniData con new_args)
-
-apply_rep_to_ty (UniSyn con args ty)
-  = mapSubstM apply_rep_to_ty args 	`thenSubstM` \ new_args ->
-    apply_rep_to_ty ty			`thenSubstM` \ new_ty ->
-    returnSubstM (UniSyn con new_args new_ty)
-
-apply_rep_to_ty (UniDict clas ty)
-  = apply_rep_to_ty ty		`thenSubstM` \ new_ty ->
-    returnSubstM (UniDict clas new_ty)
-
-apply_rep_to_ty (UniForall v ty)
-  = apply_rep_to_ty ty		`thenSubstM` \ new_ty ->
-    returnSubstM (UniForall v new_ty)
-
-apply_rep_to_ty ty@(UniTyVarTemplate v) = returnSubstM ty
-\end{code}
-
-%************************************************************************
-%*									*
-\subsubsection{Allocating @TyVarUniques@}
-%*									*
-%************************************************************************
-
-The array is extended if the allocated type variables would cause an
-out of bounds error.
-
-\begin{code}
-getSubstTyVarUnique subst@(MkSubst arr undo world next_free)
-  | next_free <= size	-- The common case; there's a spare slot
-  = (MkSubst arr undo world new_next_free, uniq)
-
-  | otherwise		-- Need more room: Extend first, then re-try
-  = getSubstTyVarUnique (extendSubstArr subst)
-
-  where
-    size       = case (boundsOfArray arr) of { (_, x) -> x  }
-    uniq       = mkUnifiableTyVarUnique next_free
-    new_next_free = next_free + 1
-    
-
-getSubstTyVarUniques n subst@(MkSubst arr undo world next_free)
-  | new_next_free - 1 <= size	-- The common case; there's a spare slot
-  = (MkSubst arr undo world new_next_free, uniqs)
-
-  | otherwise		-- Need more room: extend, then re-try
-  = getSubstTyVarUniques n (extendSubstArr subst)
-
-  where
-    size    	= case (boundsOfArray arr) of { (_, x) -> x  }
-    uniqs	= [mkUnifiableTyVarUnique (next_free + i) | i <- [0..n-1]]
-    new_next_free  = next_free + n
-\end{code}
-
-%************************************************************************
-%*									*
-\subsubsection{Undoing substitution on typechecking failure}
-%*									*
-%************************************************************************
-
-\begin{code}
-pushSubstUndos (MkSubst arr undos world next_free)
-  = MkSubst arr ((next_free,emptyBag):undos) world next_free
-
-combineSubstUndos (MkSubst arr [_] world next_free)
-  = MkSubst arr [] world next_free  -- top level undo ignored
-
-combineSubstUndos (MkSubst arr ((_,u1):(checkpoint,u2):undo_stack) 
-			   world next_free)
-  = MkSubst arr ((checkpoint, new_u1 `unionBags` u2):undo_stack) world next_free
-  where
-	-- Keep only undos which apply to indices before checkpoint
-    new_u1 = filterBag (\ (index,val) -> index < checkpoint) u1
-
-undoSubstUndos (MkSubst arr ((checkpoint,undo_now):undo_stack) world next_free)
-  = MkSubst arr undo_stack new_world checkpoint
-  where
-    (_, new_world) = doST world (perform_undo (bagToList undo_now) `seqStrictlyST`
-			      clear_block checkpoint
-			     )
-
-    perform_undo []		     = returnStrictlyST ()
-    perform_undo ((index,val):undos) = writeArray arr index val `seqStrictlyST`
-				       perform_undo undos
-
-	-- (clear_block n) clears the array from n up to next_free
-	-- This is necessary because undos beyond supp2 aren't recorded in undos
-    clear_block n | n >= next_free = returnStrictlyST ()
-		  | otherwise      = writeArray arr n Nothing `seqStrictlyST`
-				     clear_block (n+1)
-\end{code}
-
-%************************************************************************
-%*									*
-\subsubsection{Pruning a substitution}
-%*									*
-%************************************************************************
-
-ToDo: Implement with array !!  Ignore?  Restore unique supply?
-
-@pruneSubst@ prunes a substitution to a given level.
-
-This is tricky stuff.  The idea is that if we
-    (a) catch the current unique supply
-    (b) do some work
-    (c) back-substitute over the results of the work
-    (d) prune the substitution back to the level caught in (a)
-then everything will be fine.  Any *subsequent* unifications to
-these just-pruned ones will be added and not subsequently deleted.
-
-NB: this code relies on the idempotence property, otherwise discarding
-substitions might be dangerous.
-
-\begin{code} 
-{-
-pruneSubst :: TyVarUnique -> Subst -> Subst
-
-pruneSubst keep_marker (MkSubst subst_rep) 
-  = -- BSCC("pruneSubst")
-    MkSubst [(tyvar,ty) | (tyvar,ty) <- subst_rep, 
-	     getTheUnique tyvar `ltUnique` keep_marker]
-    -- ESCC
--}
-\end{code}
-
-%************************************************************************
-%*									*
-\subsection[Subst-Lists]{@Subst@ with poor list implementation}
-%*									*
-%************************************************************************
-
-If don't have Glasgow Haskell we have to revert to list implementation
-of arrays ...
-
-\begin{code}
-#else {- ! __GLASGOW_HASKELL__ -}
-\end{code}
-
-%************************************************************************
-%*									*
-\subsubsection{@Subst@: specification and representation}
-%*									*
-%************************************************************************
-
-{\em Specification:}
-* When new bindings are added to the substitution, an occurs check is performed.
-* The applySubst function guarantees to return a fixed point of the substitution.
-
-{\em Representation:}
-A substitution binds type variables to tau-types, that is @UniType@s without
-any @UniForall@ or @UniDict@ constructors.
-
-It is represented as an association list, indexed on Uniques
-with a stack of type variable unique markers indicating undo
-checkpoints.  The supply of TyVarUniques is also part of the
-aubstitution.
-
-The undo information is a stack of tyvar markers. If the typecheck
-fails all extensions to the association list subsequent to (and
-including) the marker are undone. If it succeeds the current marker is
-discarded.
-
-The unique supply is also stacked so that it can be restored if a
-typecheck fails.
-
-\begin{code}
-type SubstRep = [(Unique, TauType)]
-
-data Subst
-  = MkSubst SubstRep		-- mapping for allocated tyvars
-	    [Maybe Unique]	-- stack of markers to strip off if we fail
-	    [UniqueSupply]	-- stack of tyvar unique supplies
-
-mkEmptySubst size = MkSubst [] [] []
-\end{code}
-
-\begin{code}
-lookup_rep :: SubstRep -> TyVar -> Maybe TauType
-lookup_rep alist tyvar
-  = let
-        key = getTheUnique tyvar
-
-        lookup []	     = Nothing
-        lookup ((u,ty):rest)
-	  = case (cmpUnique key u) of { EQ_ -> Just ty; _ -> lookup rest }
-    in
-    lookup alist
-\end{code}
-
-%********************************************************
-%*							*
-\subsubsection{@Subst@: building them}
-%*							*
-%********************************************************
-
-\begin{code}
---OLD? initSubst init = MkSubst [] [] [mkUniqueSupply init]
-\end{code}
-
-\begin{code}
-extendSubst subst@(MkSubst srep undo supp) tyvar tau_ty
-  = -- BSCC("extendSubst")
-    apply_rep_to_ty srep tau_ty `thenLft` \ new_tau_ty ->
-
-    case expandVisibleTySyn new_tau_ty of
-
-	UniTyVar tv | tv `eqTyVar` tyvar ->
-	     -- Trivial new binding; return old substition
-	     (SubstOK, subst)
-
-	_ -> let
-		is_elem = isIn "extendSubst2"
-	     in
-	     if (tyvar `is_elem` (extractTyVarsFromTy new_tau_ty)) then
-	   	 (OccursCheck tyvar new_tau_ty, subst)
-	     else
-		 case lookup_rep srep tyvar of 
-		     Just exist_ty ->
-		         (AlreadyBound exist_ty, subst)
-		     Nothing       ->
-			 let
-			   new_srep = (getTheUnique tyvar, new_tau_ty) : srep
-			   new_undo = case undo of
-				      [] 		-> [] 
-					  -- top level undo ignored
-
-				      (Nothing : undos)	-> (Just (getTheUnique tyvar)) : undos
-				      (Just _ : _ ) 	-> undo
-					  -- only first undo recorded
-			 in
-		         (SubstOK, MkSubst new_srep new_undo supp)
-    -- ESCC
-\end{code}
-
-%********************************************************
-%*							*
-\subsubsection{@Subst@: lookup}
-%*							*
-%********************************************************
-
-All of them use the underlying function, @apply_rep_to_ty@, which
-ensures that an idempotent result is returned.
-
-\begin{code}
-applySubstToTy subst@(MkSubst srep undo supp) ty
-  = -- BSCC("applySubstToTy")
-    apply_rep_to_ty srep ty 		`thenLft` \ new_ty ->
-    (subst, new_ty)
-    -- ESCC
-
-applySubstToTauTy subst@(MkSubst srep undo supp) tauty
-  = -- BSCC("applySubstToTauTy")
-    apply_rep_to_ty srep tauty 		`thenLft`\ new_tauty ->
-	(subst, new_tauty)
-    -- ESCC
-
-applySubstToThetaTy subst@(MkSubst srep undo supp) theta
-  = -- BSCC("applySubstToThetaTy")
-    let
-        do_one (clas, ty) = apply_rep_to_ty srep ty  `thenLft` \ new_ty ->
-			    returnLft (clas, new_ty)
-    in
-    mapLft do_one theta		`thenLft` \ new_theta ->
-    (subst, new_theta)
-    -- ESCC
-
-applySubstToTyVar subst@(MkSubst srep undo supp) tyvar
-  = -- BSCC("applySubstToTyVar")
-    apply_rep_to_ty srep (mkTyVarTy tyvar) `thenLft` \ new_tauty ->
-    (subst, new_tauty)
-    -- ESCC
-\end{code}
-
-And now down to serious business...
-\begin{code}  
-apply_rep_to_ty :: SubstRep -> UniType -> LiftM UniType
-
-apply_rep_to_ty srep (UniTyVar tyvar)
-  = case lookup_rep srep tyvar of
-      Nothing -> -- Not found, so return a trivial type
-		 returnLft (mkTyVarTy tyvar)
-
-      Just ty -> -- Found, so recursively apply the subst the result to
-		 -- maintain idempotence!
-		 apply_rep_to_ty srep ty
-
-apply_rep_to_ty srep (UniFun t1 t2)
-  = apply_rep_to_ty srep t1		`thenLft` \ new_t1 ->
-    apply_rep_to_ty srep t2		`thenLft` \ new_t2 ->
-    returnLft (UniFun new_t1 new_t2)
-
-apply_rep_to_ty srep (UniData con args)
-  = mapLft (apply_rep_to_ty srep) args	`thenLft` \ new_args ->
-    returnLft (UniData con new_args)
-
-apply_rep_to_ty srep (UniSyn con args ty)
-  = mapLft (apply_rep_to_ty srep) args 	`thenLft` \ new_args ->
-    apply_rep_to_ty srep ty		`thenLft` \ new_ty ->
-    returnLft (UniSyn con new_args new_ty)
-
-apply_rep_to_ty srep (UniDict clas ty)
-  = apply_rep_to_ty srep ty		`thenLft` \ new_ty ->
-    returnLft (UniDict clas new_ty)
-
-apply_rep_to_ty srep (UniForall v ty)
-  = apply_rep_to_ty srep ty		`thenLft` \ new_ty ->
-    returnLft (UniForall v new_ty)
-
-apply_rep_to_ty srep ty@(UniTyVarTemplate v) = 	returnLft ty
-\end{code}
-
-%************************************************************************
-%*									*
-\subsubsection{Allocating TyVarUniques}
-%*									*
-%************************************************************************
-
-The array is extended if the allocated type variables would cause an
-out of bounds error.
-
-\begin{code}
-getSubstTyVarUnique subst@(MkSubst srep undo (supp:supps))
-  = -- BSCC("allocTyVarUniques")
-    case getUnique supp of
-      (new_supp, uniq) -> (MkSubst srep undo (new_supp:supps), uniq)
-    -- ESCC
-
-getSubstTyVarUniques n subst@(MkSubst srep undo (supp:supps))
-  = -- BSCC("allocTyVarUniques")
-    case getUniques n supp of
-      (new_supp, uniqs) -> (MkSubst srep undo (new_supp:supps), uniqs)
-    -- ESCC
-\end{code}
-
-%************************************************************************
-%*									*
-\subsubsection[Subst-undo]{Undoing substitution on typechecking failure}
-%*									*
-%************************************************************************
-
-\begin{code}
-pushSubstUndos subst@(MkSubst srep undos (supp:supps))
-  = -- BSCC("pushSubstUndos")
-    MkSubst srep (Nothing:undos) (supp:supp:supps)
-    -- ESCC
-
-combineSubstUndos subst@(MkSubst srep (u:us) (supp1:supp2:supps))
-  = -- BSCC("combineSubstUndos")
-      MkSubst srep us (supp1:supps)
-    -- ESCC
-
-undoSubstUndos subst@(MkSubst srep (u:us) (supp1:supp2:supps))
-  = -- BSCC("undoSubstUndos")
-    let 
-      strip_to []	     key = []
-      strip_to ((u,ty):srep) key
-	= case (cmpUnique u key) of { EQ_ -> srep; _ -> strip_to srep key }
-      
-      perform_undo Nothing     srep = srep
-      perform_undo (Just uniq) srep = strip_to srep uniq 
-    in
-      MkSubst (perform_undo u srep) us (supp2:supps)
-
-	-- Note: the saved unique supply is restored from the enclosing scope
-
-    -- ESCC
-\end{code}
-
-%************************************************************************
-%*									*
-\subsubsection{Pruning a substitution}
-%*									*
-%************************************************************************
-
-ToDo: Implement with list !!  Ignore?  Restore unique supply?
-
-@pruneSubst@ prunes a substitution to a given level.
-
-This is tricky stuff.  The idea is that if we
-    (a) catch the current unique supply
-    (b) do some work
-    (c) back-substitute over the results of the work
-    (d) prune the substitution back to the level caught in (a)
-then everything will be fine.  Any *subsequent* unifications to
-these just-pruned ones will be added and not subsequently deleted.
-
-NB: this code relies on the idempotence property, otherwise discarding
-substitions might be dangerous.
-
-\begin{code} 
-{-
-pruneSubst :: TyVarUnique -> Subst -> Subst
-
-pruneSubst keep_marker (MkSubst subst_rep) 
-  = -- BSCC("pruneSubst")
-    MkSubst [(tyvar,ty) | (tyvar,ty) <- subst_rep, 
-	     getTheUnique tyvar `ltUnique` keep_marker]
-    -- ESCC
--}
-\end{code}
-
-\begin{code}
-#endif {- ! __GLASGOW_HASKELL__ -}
-\end{code}
diff --git a/ghc/compiler/typecheck/TcBinds.hi b/ghc/compiler/typecheck/TcBinds.hi
deleted file mode 100644
index 5ffd1dfe8b..0000000000
--- a/ghc/compiler/typecheck/TcBinds.hi
+++ /dev/null
@@ -1,22 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface TcBinds where
-import Bag(Bag)
-import CmdLineOpts(GlobalSwitch)
-import E(E)
-import GenSpecEtc(SignatureInfo)
-import HsBinds(Binds, MonoBinds, Sig)
-import HsPat(InPat, TypecheckedPat)
-import Id(Id)
-import LIE(LIE)
-import Name(Name)
-import Pretty(PprStyle, PrettyRep)
-import SplitUniq(SplitUniqSupply)
-import SrcLoc(SrcLoc)
-import Subst(Subst)
-import TcMonad(TcResult)
-import UniType(UniType)
-doSpecPragma :: E -> (Name -> Id) -> SignatureInfo -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult (MonoBinds Id TypecheckedPat, LIE)
-tcLocalBindsAndThen :: E -> (Binds Id TypecheckedPat -> a -> a) -> Binds Name (InPat Name) -> (E -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult (a, LIE, b)) -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult (a, LIE, b)
-tcSigs :: E -> [(Name, Id)] -> [Sig Name] -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult [SignatureInfo]
-tcTopBindsAndThen :: E -> (Binds Id TypecheckedPat -> a -> a) -> Binds Name (InPat Name) -> (E -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult (a, LIE, b)) -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult (a, LIE, b)
-
diff --git a/ghc/compiler/typecheck/TcBinds.lhs b/ghc/compiler/typecheck/TcBinds.lhs
index 51b7301f03..a61b07552e 100644
--- a/ghc/compiler/typecheck/TcBinds.lhs
+++ b/ghc/compiler/typecheck/TcBinds.lhs
@@ -1,76 +1,48 @@
 %
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
 %
 \section[TcBinds]{TcBinds}
 
 \begin{code}
 #include "HsVersions.h"
 
-module TcBinds (
-	tcTopBindsAndThen, tcLocalBindsAndThen,
-	tcSigs, doSpecPragma
-    ) where
-
---IMPORT_Trace		-- ToDo:rm (debugging)
-
-import TcMonad		-- typechecking monad machinery
-import TcMonadFns	( newLocalsWithOpenTyVarTys,
-			  newLocalsWithPolyTyVarTys,
-			  newSpecPragmaId, newSpecId,
-			  applyTcSubstAndCollectTyVars
-			)
-import AbsSyn		-- the stuff being typechecked
-
-import AbsUniType	( isTyVarTy, isGroundTy, isUnboxedDataType,
-			  isGroundOrTyVarTy, extractTyVarsFromTy,
-			  UniType
-			)
-import BackSubst	( applyTcSubstToBinds )
-import E
-import Errors		( topLevelUnboxedDeclErr, specGroundnessErr,
-			  specCtxtGroundnessErr, Error(..), UnifyErrContext(..)
-			)
-import GenSpecEtc	( checkSigTyVars, genBinds, SignatureInfo(..) )
-import Id		( getIdUniType, mkInstId )
-import IdInfo		( SpecInfo(..) )
-import Inst
-import LIE		( nullLIE, mkLIE, plusLIE, LIE )
-import Maybes		( assocMaybe, catMaybes, Maybe(..) )
-import Spec		( specTy )
-import TVE		( nullTVE, TVE(..), UniqFM )
-import TcMonoBnds	( tcMonoBinds )
-import TcPolyType	( tcPolyType )
+module TcBinds ( tcBindsAndThen, tcPragmaSigs ) where
+
+import Ubiq
+
+import HsSyn		( HsBinds(..), Bind(..), Sig(..), MonoBinds(..), 
+			  HsExpr, Match, PolyType, InPat, OutPat,
+			  GRHSsAndBinds, ArithSeqInfo, HsLit, Fake,
+			  collectBinders )
+import RnHsSyn		( RenamedHsBinds(..), RenamedBind(..), RenamedSig(..), 
+			  RenamedMonoBinds(..) )
+import TcHsSyn		( TcHsBinds(..), TcBind(..), TcMonoBinds(..),
+			  TcIdOcc(..), TcIdBndr(..) )
+
+import TcMonad	
+import GenSpecEtc	( checkSigTyVars, genBinds, TcSigInfo(..) )
+import Inst		( Inst, LIE(..), emptyLIE, plusLIE, InstOrigin(..) )
+import TcEnv		( tcExtendLocalValEnv, tcLookupLocalValueOK, newMonoIds )
+import TcLoop		( tcGRHSsAndBinds )
+import TcMatches	( tcMatchesFun )
+import TcMonoType	( tcPolyType )
+import TcPat		( tcPat )
 import TcSimplify	( bindInstsOfLocalFuns )
+import TcType		( newTcTyVar, tcInstType )
 import Unify		( unifyTauTy )
-import UniqFM		( emptyUFM ) -- profiling, pragmas only
-import Util
-\end{code}
-
-%************************************************************************
-%*									*
-\subsection{Type-checking top-level bindings}
-%*									*
-%************************************************************************
-
-@tcBindsAndThen@ takes a boolean which indicates whether the binding
-group is at top level or not.  The difference from inner bindings is
-that
-\begin{enumerate}
-\item
-we zero the substitution before each group
-\item
-we back-substitute after each group.
-\end{enumerate}
-We still return an LIE, but it is sure to contain nothing but constant
-dictionaries, which we resolve at the module level.
-
-@tcTopBinds@ returns an LVE, not, as you might expect, a GVE.  Why?
-Because the monomorphism restriction means that is might return some
-monomorphic things, with free type variables.  Hence it must be an LVE.
 
-The LIE returned by @tcTopBinds@ may constrain some type variables,
-but they are guaranteed to be a subset of those free in the
-corresponding returned LVE.
+import Kind		( mkBoxedTypeKind, mkTypeKind )
+import Id		( GenId, idType, mkUserId )
+import IdInfo		( noIdInfo )
+import Name		( Name )	-- instances
+import Maybes		( assocMaybe, catMaybes, Maybe(..) )
+import Outputable	( pprNonOp )
+import PragmaInfo	( PragmaInfo(..) )
+import Pretty
+import Type		( mkTyVarTy, isTyVarTy, mkSigmaTy, splitSigmaTy,
+			  splitRhoTy, mkForAllTy, splitForAllTy )
+import Util		( panic )
+\end{code}
 
 %************************************************************************
 %*									*
@@ -78,7 +50,7 @@ corresponding returned LVE.
 %*									*
 %************************************************************************
 
-@tcBindsAndThen@ typechecks a @Binds@.  The "and then" part is because
+@tcBindsAndThen@ typechecks a @HsBinds@.  The "and then" part is because
 it needs to know something about the {\em usage} of the things bound,
 so that it can create specialisations of them.  So @tcBindsAndThen@
 takes a function which, given an extended environment, E, typechecks
@@ -100,55 +72,28 @@ to the LVE for the following reason.  When each individual binding is
 checked the type of its LHS is unified with that of its RHS; and
 type-checking the LHS of course requires that the binder is in scope.
 
+At the top-level the LIE is sure to contain nothing but constant
+dictionaries, which we resolve at the module level.
+
 \begin{code}
-tcBindsAndThen 
-	:: Bool
-	-> E 
-	-> (TypecheckedBinds -> thing -> thing)		-- Combinator
-	-> RenamedBinds
-	-> (E -> TcM (thing, LIE, thing_ty))
-	-> TcM (thing, LIE, thing_ty)
-
-tcBindsAndThen top_level e combiner EmptyBinds do_next
-  = do_next e		`thenTc` \ (thing, lie, thing_ty) ->
+tcBindsAndThen
+	:: (TcHsBinds s -> thing -> thing)		-- Combinator
+	-> RenamedHsBinds
+	-> TcM s (thing, LIE s, thing_ty)
+	-> TcM s (thing, LIE s, thing_ty)
+
+tcBindsAndThen combiner EmptyBinds do_next
+  = do_next 	`thenTc` \ (thing, lie, thing_ty) ->
     returnTc (combiner EmptyBinds thing, lie, thing_ty)
 
-tcBindsAndThen top_level e combiner (SingleBind bind) do_next
-  = tcBindAndThen top_level e combiner bind [] do_next
+tcBindsAndThen combiner (SingleBind bind) do_next
+  = tcBindAndThen combiner bind [] do_next
 
-tcBindsAndThen top_level e combiner (BindWith bind sigs) do_next
-  = tcBindAndThen top_level e combiner bind sigs do_next
-
-tcBindsAndThen top_level e combiner (ThenBinds binds1 binds2) do_next
-  = tcBindsAndThen top_level e combiner binds1 new_after
-  where
-    -- new_after :: E -> TcM (thing, LIE, thing_ty)
-    -- Can't write this signature, cos it's monomorphic in thing and
-    -- thing_ty.
-    new_after e = tcBindsAndThen top_level e combiner binds2 do_next
-\end{code}
+tcBindsAndThen combiner (BindWith bind sigs) do_next
+  = tcBindAndThen combiner bind sigs do_next
 
-Simple wrappers for export:
-\begin{code}
-tcTopBindsAndThen
-	:: E
-	-> (TypecheckedBinds -> thing -> thing)		-- Combinator
-	-> RenamedBinds 
-	-> (E -> TcM (thing, LIE, anything))
-	-> TcM (thing, LIE, anything)
-
-tcTopBindsAndThen e combiner binds do_next
-  = tcBindsAndThen True e combiner binds do_next
-
-tcLocalBindsAndThen
-	:: E 
-	-> (TypecheckedBinds -> thing -> thing)		-- Combinator
-	-> RenamedBinds 
-	-> (E -> TcM (thing, LIE, thing_ty))
-	-> TcM (thing, LIE, thing_ty)
-
-tcLocalBindsAndThen e combiner binds do_next
-  = tcBindsAndThen False e combiner  binds do_next
+tcBindsAndThen combiner (ThenBinds binds1 binds2) do_next
+  = tcBindsAndThen combiner binds1 (tcBindsAndThen combiner binds2 do_next)
 \end{code}
 
 An aside.  The original version of @tcBindsAndThen@ which lacks a
@@ -158,31 +103,26 @@ at a different type to the definition itself.  There aren't too many
 examples of this, which is why I thought it worth preserving! [SLPJ]
 
 \begin{pseudocode}
-tcBindsAndThen 
-	:: Bool -> E -> RenamedBinds
-	-> (E -> TcM (thing, LIE, thing_ty))
-	-> TcM ((TypecheckedBinds, thing), LIE, thing_ty)
+tcBindsAndThen
+	:: RenamedHsBinds
+	-> TcM s (thing, LIE s, thing_ty))
+	-> TcM s ((TcHsBinds s, thing), LIE s, thing_ty)
 
-tcBindsAndThen top_level e EmptyBinds do_next
-  = do_next e		`thenTc` \ (thing, lie, thing_ty) ->
+tcBindsAndThen EmptyBinds do_next
+  = do_next 		`thenTc` \ (thing, lie, thing_ty) ->
     returnTc ((EmptyBinds, thing), lie, thing_ty)
 
-tcBindsAndThen top_level e (SingleBind bind) do_next
-  = tcBindAndThen top_level e bind [] do_next
+tcBindsAndThen (SingleBind bind) do_next
+  = tcBindAndThen bind [] do_next
 
-tcBindsAndThen top_level e (BindWith bind sigs) do_next
-  = tcBindAndThen top_level e bind sigs do_next
+tcBindsAndThen (BindWith bind sigs) do_next
+  = tcBindAndThen bind sigs do_next
 
-tcBindsAndThen top_level e (ThenBinds binds1 binds2) do_next
-  = tcBindsAndThen top_level e binds1 new_after
+tcBindsAndThen (ThenBinds binds1 binds2) do_next
+  = tcBindsAndThen binds1 (tcBindsAndThen binds2 do_next)
 	`thenTc` \ ((binds1', (binds2', thing')), lie1, thing_ty) ->
 
     returnTc ((binds1' `ThenBinds` binds2', thing'), lie1, thing_ty)
-
-  where
-    -- new_after :: E -> TcM ((TypecheckedBinds, thing), LIE, thing_ty)
-    -- Can't write this signature, cos it's monomorphic in thing and thing_ty
-    new_after e = tcBindsAndThen top_level e binds2 do_next
 \end{pseudocode}
 
 %************************************************************************
@@ -193,351 +133,372 @@ tcBindsAndThen top_level e (ThenBinds binds1 binds2) do_next
 
 \begin{code}
 tcBindAndThen
-	:: Bool						  -- At top level
-	-> E 
-	-> (TypecheckedBinds -> thing -> thing)		  -- Combinator
+	:: (TcHsBinds s -> thing -> thing)		  -- Combinator
 	-> RenamedBind					  -- The Bind to typecheck
 	-> [RenamedSig]					  -- ...and its signatures
-	-> (E -> TcM (thing, LIE, thing_ty))		  -- Thing to type check in
+	-> TcM s (thing, LIE s, thing_ty)		  -- Thing to type check in
 							  -- augmented envt
-	-> TcM (thing, LIE, thing_ty) 			  -- Results, incl the 
+	-> TcM s (thing, LIE s, thing_ty)		  -- Results, incl the
 
-tcBindAndThen top_level e combiner bind sigs do_next
-  = 	-- Deal with the bind
-    tcBind top_level e bind sigs    `thenTc` \ (poly_binds, poly_lie, poly_lve) ->
+tcBindAndThen combiner bind sigs do_next
+  = fixTc (\ ~(prag_info_fn, _) ->
+	-- This is the usual prag_info fix; the PragmaInfo field of an Id
+	-- is not inspected till ages later in the compiler, so there
+	-- should be no black-hole problems here.
+    
+    tcBindAndSigs binder_names bind 
+		  sigs prag_info_fn	`thenTc` \ (poly_binds, poly_lie, poly_ids) ->
+
+	-- Extend the environment to bind the new polymorphic Ids
+    tcExtendLocalValEnv binder_names poly_ids $
+
+	-- Build bindings and IdInfos corresponding to user pragmas
+    tcPragmaSigs sigs			`thenTc` \ (prag_info_fn, prag_binds, prag_lie) ->
 
 	-- Now do whatever happens next, in the augmented envt
-    do_next (growE_LVE e poly_lve)  `thenTc` \ (thing, thing_lie, thing_ty) ->
+    do_next				`thenTc` \ (thing, thing_lie, thing_ty) ->
+
+	-- Create specialisations of functions bound here
+    bindInstsOfLocalFuns (prag_lie `plusLIE` thing_lie)
+			  poly_ids	`thenTc` \ (lie2, inst_mbinds) ->
+
+	-- All done
     let
-	bound_ids = map snd poly_lve
+ 	final_lie   = lie2 `plusLIE` poly_lie
+	final_binds = poly_binds `ThenBinds`
+		      SingleBind (NonRecBind inst_mbinds) `ThenBinds`
+		      prag_binds
     in
-	-- Create specialisations
-    specialiseBinds bound_ids thing_lie poly_binds poly_lie
-				    `thenNF_Tc` \ (final_binds, final_lie) ->
-	-- All done
-    returnTc (combiner final_binds thing, final_lie, thing_ty)
+    returnTc (prag_info_fn, (combiner final_binds thing, final_lie, thing_ty))
+    )					`thenTc` \ (_, result) ->
+    returnTc result
+  where
+    binder_names = collectBinders bind
+
+
+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
+	newTcTyVar Nothing mkBoxedTypeKind		`thenNF_Tc` \ alpha_tv ->
+	let
+	  forall_a_a = mkForAllTy alpha_tv (mkTyVarTy alpha_tv)
+	  poly_ids   = [ mkUserId name forall_a_a (prag_info_fn name)
+		       | name <- binder_names]
+	in
+	returnTc (EmptyBinds, emptyLIE, poly_ids)
+    ) $
+
+	-- Create a new identifier for each binder, with each being given
+	-- a type-variable type.
+    newMonoIds binder_names kind (\ mono_ids ->
+	    tcTySigs sigs		`thenTc` \ sig_info ->
+	    tc_bind bind		`thenTc` \ (bind', lie) ->
+	    returnTc (mono_ids, bind', lie, sig_info)
+    )
+	    `thenTc` \ (mono_ids, 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
+    kind = case bind of
+	  	NonRecBind _ -> mkBoxedTypeKind	-- Recursive, so no unboxed types
+		RecBind _    -> mkTypeKind	-- Non-recursive, so we permit unboxed types
 \end{code}
 
 \begin{code}
-tcBind :: Bool -> E 
-       -> RenamedBind -> [RenamedSig]
-       -> TcM (TypecheckedBinds, LIE, LVE)	-- LIE is a fixed point of substitution
+tc_bind :: RenamedBind -> TcM s (TcBind s, LIE s)
 
-tcBind False e bind sigs  			-- Not top level
-  = tcBind_help False e bind sigs
+tc_bind (NonRecBind mono_binds)
+  = tcMonoBinds mono_binds	`thenTc` \ (mono_binds2, lie) ->
+    returnTc  (NonRecBind mono_binds2, lie)
 
-tcBind True  e bind sigs			-- Top level!
-  = pruneSubstTc (tvOfE e) (
+tc_bind (RecBind mono_binds)
+  = tcMonoBinds mono_binds	`thenTc` \ (mono_binds2, lie) ->
+    returnTc  (RecBind mono_binds2, lie)
+\end{code}
 
-	 -- DO THE WORK
-    tcBind_help True e bind sigs	`thenTc` \ (new_binds, lie, lve) ->
+\begin{code}
+tcMonoBinds :: RenamedMonoBinds -> TcM s (TcMonoBinds s, LIE s)
 
-{-  Top-level unboxed values are now allowed
-    They will be lifted by the Desugarer (see CoreLift.lhs)
+tcMonoBinds EmptyMonoBinds = returnTc (EmptyMonoBinds, emptyLIE)
 
-	-- CHECK FOR PRIMITIVE TOP-LEVEL BINDS
-	listTc [ checkTc (isUnboxedDataType (getIdUniType id))
-			 (topLevelUnboxedDeclErr id (getSrcLoc id))
-	       | (_,id) <- lve ]	`thenTc_`
--}
+tcMonoBinds (AndMonoBinds mb1 mb2)
+  = tcMonoBinds mb1		`thenTc` \ (mb1a, lie1) ->
+    tcMonoBinds mb2		`thenTc` \ (mb2a, lie2) ->
+    returnTc (AndMonoBinds mb1a mb2a, lie1 `plusLIE` lie2)
 
-    -- Back-substitute over the binds, since we are about to discard
-    -- a good chunk of the substitution.
-    applyTcSubstToBinds new_binds	`thenNF_Tc` \ final_binds ->
+tcMonoBinds bind@(PatMonoBind pat grhss_and_binds locn)
+  = tcAddSrcLoc locn		 $
 
-    -- The lie is already a fixed point of the substitution; it just turns out
-    -- that almost always this happens automatically, and so we made it part of
-    -- the specification of genBinds.
-    returnTc (final_binds, lie, lve)
-    )
+	-- LEFT HAND SIDE
+    tcPat pat	     			`thenTc` \ (pat2, lie_pat, pat_ty) ->
+
+	-- BINDINGS AND GRHSS
+    tcGRHSsAndBinds grhss_and_binds	`thenTc` \ (grhss_and_binds2, lie, grhss_ty) ->
+
+	-- Unify the two sides
+    tcAddErrCtxt (patMonoBindsCtxt bind) $
+	unifyTauTy pat_ty grhss_ty			`thenTc_`
+
+	-- RETURN
+    returnTc (PatMonoBind pat2 grhss_and_binds2 locn,
+	      plusLIE lie_pat lie)
+
+tcMonoBinds (FunMonoBind name matches locn)
+  = tcAddSrcLoc locn				$
+    tcLookupLocalValueOK "tcMonoBinds" name	`thenNF_Tc` \ id ->
+    tcMatchesFun name (idType id) matches	`thenTc` \ (matches', lie) ->
+    returnTc (FunMonoBind (TcId id) matches' locn, lie)
 \end{code}
 
+%************************************************************************
+%*									*
+\subsection{Signatures}
+%*									*
+%************************************************************************
+
+@tcSigs@ checks the signatures for validity, and returns a list of
+{\em freshly-instantiated} signatures.  That is, the types are already
+split up, and have fresh type variables installed.  All non-type-signature
+"RenamedSigs" are ignored.
+
 \begin{code}
-tcBind_help top_level e bind sigs
-  = 	-- Create an LVE binding each identifier to an appropriate type variable
-    new_locals binders		`thenNF_Tc` \ bound_ids ->
-    let  lve = binders `zip` bound_ids  in
-
-	-- Now deal with type signatures, if any
-    tcSigs e lve sigs		`thenTc`    \ sig_info ->
-
-	-- Check the bindings: this is the point at which we can use
-	-- error recovery.  If checking the bind fails we just
-	-- return the empty bindings.  The variables will still be in
-	-- scope, but bound to completely free type variables, which
-	-- is just what we want to minimise subsequent error messages.
-    recoverTc (NonRecBind EmptyMonoBinds, nullLIE)
-	      (tc_bind (growE_LVE e lve) bind)	`thenNF_Tc` \ (bind', lie) ->
-
-	-- Notice that genBinds gets the old (non-extended) environment
-    genBinds top_level e bind' lie lve sig_info	`thenTc` \ (binds', lie, lve) ->
-
-	-- Add bindings corresponding to SPECIALIZE pragmas in the code
-    mapAndUnzipTc (doSpecPragma e (assoc "doSpecPragma" lve))
-		  (get_spec_pragmas sig_info)
-			`thenTc` \ (spec_binds_s, spec_lie_s) ->
-
-    returnTc (binds' `ThenBinds` (SingleBind (NonRecBind (
-		foldr AndMonoBinds EmptyMonoBinds spec_binds_s))),
-	      lie `plusLIE` (foldr plusLIE nullLIE spec_lie_s),
-	      lve)
-  where
-    binders = collectBinders bind
+tcTySigs :: [RenamedSig] -> TcM s [TcSigInfo s]
+
+tcTySigs (Sig v ty _ src_loc : other_sigs)
+ = tcAddSrcLoc src_loc (
+	tcPolyType ty			`thenTc` \ sigma_ty ->
+	tcInstType [] sigma_ty		`thenNF_Tc` \ tc_sigma_ty ->
+	let
+	    (tyvars, theta, tau_ty) = splitSigmaTy tc_sigma_ty
+	in
+	tcLookupLocalValueOK "tcSig1" v	`thenNF_Tc` \ val ->
+	unifyTauTy (idType val) tau_ty	`thenTc_`
+	returnTc (TySigInfo val tyvars theta tau_ty src_loc)
+   )		`thenTc` \ sig_info1 ->
+
+   tcTySigs other_sigs	`thenTc` \ sig_infos ->
+   returnTc (sig_info1 : sig_infos)
+
+tcTySigs (other : sigs) = tcTySigs sigs
+tcTySigs []		= returnTc []
+\end{code}
+
+
+%************************************************************************
+%*									*
+\subsection{SPECIALIZE pragmas}
+%*									*
+%************************************************************************
+
+
+@tcPragmaSigs@ munches up the "signatures" that arise through *user*
+pragmas.  It is convenient for them to appear in the @[RenamedSig]@
+part of a binding because then the same machinery can be used for
+moving them into place as is done for type signatures.
+
+\begin{code}
+tcPragmaSigs :: [RenamedSig]			-- The pragma signatures
+	     -> TcM s (Name -> PragmaInfo,	-- Maps name to the appropriate PragmaInfo
+		       TcHsBinds s,
+		       LIE s)
+
+tcPragmaSigs sigs = returnTc ( \name -> NoPragmaInfo, EmptyBinds, emptyLIE )
 
-    new_locals binders
-      = case bind of
-	  NonRecBind _ -> -- Recursive, so no unboxed types
-			  newLocalsWithOpenTyVarTys binders
+{- 
+tcPragmaSigs sigs
+  = mapAndUnzip3Tc tcPragmaSig sigs	`thenTc` \ (names_w_id_infos, binds, lies) ->
+    let
+	name_to_info name = foldr ($) noIdInfo
+				  [info_fn | (n,info_fn) <- names_w_id_infos, n==name]
+    in
+    returnTc (name_to_info,
+	      foldr ThenBinds EmptyBinds binds,
+	      foldr plusLIE emptyLIE lies)
+\end{code}
 
-	  RecBind _    -> -- Non-recursive, so we permit unboxed types
-			  newLocalsWithPolyTyVarTys binders
+Here are the easy cases for tcPragmaSigs
 
-    get_spec_pragmas sig_info
-      = catMaybes (map get_pragma_maybe sig_info)
-      where
-	get_pragma_maybe s@(ValSpecInfo _ _ _ _) = Just s
-	get_pragma_maybe _  	    	         = Nothing
+\begin{code}
+tcPragmaSig (DeforestSig name loc)
+  = returnTc ((name, addInfo DoDeforest),EmptyBinds,emptyLIE)
+tcPragmaSig (InlineSig name loc)
+  = returnTc ((name, addInfo_UF (iWantToBeINLINEd UnfoldAlways)), EmptyBinds, emptyLIE)
+tcPragmaSig (MagicUnfoldingSig name string loc)
+  = returnTc ((name, addInfo_UF (mkMagicUnfolding string)), EmptyBinds, emptyLIE)
 \end{code}
 
+The interesting case is for SPECIALISE pragmas.  There are two forms.
+Here's the first form:
 \begin{verbatim}
 	f :: Ord a => [a] -> b -> b
 	{-# SPECIALIZE f :: [Int] -> b -> b #-}
 \end{verbatim}
-We generate:
+
+For this we generate:
 \begin{verbatim}
-	f@Int = /\ b -> let d1 = ...
-			in f Int b d1
+	f* = /\ b -> let d1 = ...
+		     in f Int b d1
+\end{verbatim}
 
+where f* is a SpecPragmaId.  The **sole** purpose of SpecPragmaIds is to
+retain a right-hand-side that the simplifier will otherwise discard as
+dead code... the simplifier has a flag that tells it not to discard
+SpecPragmaId bindings.
 
-	h :: Ord a => [a] -> b -> b
-	{-# SPECIALIZE h :: [Int] -> b -> b #-}
+In this case the f* retains a call-instance of the overloaded
+function, f, (including appropriate dictionaries) so that the
+specialiser will subsequently discover that there's a call of @f@ at
+Int, and will create a specialisation for @f@.  After that, the
+binding for @f*@ can be discarded.
+
+The second form is this:
+\begin{verbatim}
+	f :: Ord a => [a] -> b -> b
+	{-# SPECIALIZE f :: [Int] -> b -> b = g #-}
+\end{verbatim}
 
-	spec_h = /\b -> h [Int] b dListOfInt
-			^^^^^^^^^^^^^^^^^^^^ This bit created by specId
+Here @g@ is specified as a function that implements the specialised
+version of @f@.  Suppose that g has type (a->b->b); that is, g's type
+is more general than that required.  For this we generate
+\begin{verbatim}
+	f@Int = /\b -> g Int b
+	f* = f@Int
 \end{verbatim}
 
+Here @f@@Int@ is a SpecId, the specialised version of @f@.  It inherits
+f's export status etc.  @f*@ is a SpecPragmaId, as before, which just serves
+to prevent @f@@Int@ from being discarded prematurely.  After specialisation,
+if @f@@Int@ is going to be used at all it will be used explicitly, so the simplifier can
+discard the f* binding.
+
+Actually, there is really only point in giving a SPECIALISE pragma on exported things,
+and the simplifer won't discard SpecIds for exporte things anyway, so maybe this is
+a bit of overkill.
+
 \begin{code}
-doSpecPragma :: E
-	     -> (Name -> Id)
-	     -> SignatureInfo
-	     -> TcM (TypecheckedMonoBinds, LIE)
-
-doSpecPragma e name_to_id (ValSpecInfo name spec_ty using src_loc)
-  = let
-	main_id = name_to_id name    -- Get the parent Id
-
-	main_id_ty = getIdUniType main_id
-	main_id_free_tyvars = extractTyVarsFromTy main_id_ty
-	origin = ValSpecOrigin name src_loc
-    	err_ctxt = ValSpecSigCtxt name spec_ty src_loc
+tcPragmaSig (SpecSig name poly_ty maybe_spec_name src_loc)
+  = tcAddSrcLoc src_loc		 		$
+    tcAddErrCtxt (valSpecSigCtxt name spec_ty)	$
+
+	-- Get and instantiate its alleged specialised type
+    tcPolyType poly_ty				`thenTc` \ sig_sigma ->
+    tcInstType [] (idType sig_sigma)		`thenNF_Tc` \ sig_ty ->
+    let
+	(sig_tyvars, sig_theta, sig_tau) = splitSigmaTy sig_ty
+	origin = ValSpecOrigin name
     in
-    addSrcLocTc src_loc		 (
-    specTy origin spec_ty `thenNF_Tc` \ (spec_tyvars, spec_dicts, spec_tau) ->
 
 	-- Check that the SPECIALIZE pragma had an empty context
-    checkTc (not (null spec_dicts))
+    checkTc (null sig_theta)
 	    (panic "SPECIALIZE non-empty context (ToDo: msg)") `thenTc_`
 
-	-- Make an instance of this id
-    specTy origin main_id_ty `thenNF_Tc` \ (main_tyvars, main_dicts, main_tau) ->
+	-- Get and instantiate the type of the id mentioned
+    tcLookupLocalValueOK "tcPragmaSig" name	`thenNF_Tc` \ main_id ->
+    tcInstType [] (idType main_id)		`thenNF_Tc` \ main_ty ->
+    let
+	(main_tyvars, main_rho) = splitForAllTy main_ty
+	(main_theta,main_tau)   = splitRhoTy main_rho
+	main_arg_tys	        = map mkTyVarTy main_tyvars
+    in
 
 	-- Check that the specialised type is indeed an instance of
-	-- the inferred type.
-	-- The unification should leave all type vars which are
-	-- currently free in the environment still free, and likewise
-	-- the signature type vars.
-	-- The only way type vars free in the envt could possibly be affected
-	-- is if main_id_ty has free type variables.  So we just extract them,
-	-- and check that they are not constrained in any way by the unification.
-    applyTcSubstAndCollectTyVars main_id_free_tyvars  `thenNF_Tc` \ free_tyvars' ->
-    unifyTauTy spec_tau main_tau err_ctxt   `thenTc_`
-    checkSigTyVars [] (spec_tyvars ++ free_tyvars')
-		   spec_tau main_tau err_ctxt `thenTc_`
+	-- the type of the main function.
+    unifyTauTy sig_tau main_tau			`thenTc_`
+    checkSigTyVars sig_tyvars sig_tau main_tau	`thenTc_`
 
 	-- Check that the type variables of the polymorphic function are
 	-- either left polymorphic, or instantiate to ground type.
 	-- Also check that the overloaded type variables are instantiated to
 	-- ground type; or equivalently that all dictionaries have ground type
-    applyTcSubstToTyVars main_tyvars	`thenNF_Tc` \ main_arg_tys ->
-    applyTcSubstToInsts  main_dicts	`thenNF_Tc` \ main_dicts' ->
-
-    checkTc (not (all isGroundOrTyVarTy main_arg_tys))
-	    (specGroundnessErr err_ctxt main_arg_tys)
-				    	`thenTc_`
+    mapTc zonkTcType main_arg_tys	`thenNF_Tc` \ main_arg_tys' ->
+    zonkTcThetaType main_theta		`thenNF_Tc` \ main_theta' ->
+    tcAddErrCtxt (specGroundnessCtxt main_arg_tys')
+	      (checkTc (all isGroundOrTyVarTy main_arg_tys'))      	`thenTc_`
+    tcAddErrCtxt (specContextGroundnessCtxt main_theta')
+	      (checkTc (and [isGroundTy ty | (_,ty) <- theta']))	`thenTc_`
 
-    checkTc (not (and [isGroundTy ty | (_,ty) <- map getDictClassAndType main_dicts']))
-	    (specCtxtGroundnessErr err_ctxt main_dicts')
-					`thenTc_`
+	-- Build the SpecPragmaId; it is the thing that makes sure we
+	-- don't prematurely dead-code-eliminate the binding we are really interested in.
+    newSpecPragmaId name sig_ty		`thenNF_Tc` \ spec_pragma_id ->
 
 	-- Build a suitable binding; depending on whether we were given
 	-- a value (Maybe Name) to be used as the specialisation.
     case using of
-      Nothing ->
+      Nothing ->		-- No implementation function specified
+
+		-- Make a Method inst for the occurrence of the overloaded function
+	newMethodWithGivenTy (OccurrenceOf name)
+		  (TcId main_id) main_arg_tys main_rho	`thenNF_Tc` \ (lie, meth_id) ->
 
-	    -- Make a specPragmaId to which to bind the new call-instance
-	newSpecPragmaId name spec_ty Nothing
-					`thenNF_Tc` \ pseudo_spec_id ->
 	let
-	    pseudo_bind = VarMonoBind pseudo_spec_id pseudo_rhs
-	    pseudo_rhs  = mkTyLam spec_tyvars (mkDictApp (mkTyApp (Var main_id) main_arg_tys)
-						         (map mkInstId main_dicts'))
+	    pseudo_bind = VarMonoBind spec_pragma_id pseudo_rhs
+	    pseudo_rhs  = mkHsTyLam sig_tyvars (HsVar (TcId meth_id))
 	in
-	returnTc (pseudo_bind, mkLIE main_dicts')
+	returnTc (pseudo_bind, lie, \ info -> info)
 
-      Just spec_name -> -- use spec_name as the specialisation value ...
-	let
-	    spec_id      = lookupE_Value e spec_name
-	    spec_id_ty   = getIdUniType spec_id
+      Just spec_name ->		-- Use spec_name as the specialisation value ...
 
-	    spec_id_free_tyvars = extractTyVarsFromTy spec_id_ty
-	    spec_id_ctxt = ValSpecSpecIdCtxt name spec_ty spec_name src_loc
+		-- Type check a simple occurrence of the specialised Id
+	tcId spec_name		`thenTc` \ (spec_body, spec_lie, spec_tau) ->
 
-	    spec_tys    = map maybe_ty main_arg_tys
-            maybe_ty ty | isTyVarTy ty = Nothing
-			| otherwise    = Just ty
-	in
-	    -- Make an instance of the spec_id
-	specTy origin spec_id_ty `thenNF_Tc` \ (spec_id_tyvars, spec_id_dicts, spec_id_tau) ->
-
-	    -- Check that the specialised type is indeed an instance of
-	    -- the type inferred for spec_id
-	    -- The unification should leave all type vars which are
-	    -- currently free in the environment still free, and likewise
-	    -- the signature type vars.
-	    -- The only way type vars free in the envt could possibly be affected
-	    -- is if spec_id_ty has free type variables.  So we just extract them,
-	    -- and check that they are not constrained in any way by the unification.
-        applyTcSubstAndCollectTyVars spec_id_free_tyvars  `thenNF_Tc` \ spec_id_free_tyvars' ->
-        unifyTauTy spec_tau spec_id_tau spec_id_ctxt   	  `thenTc_`
-        checkSigTyVars [] (spec_tyvars ++ spec_id_free_tyvars')
-		       spec_tau spec_id_tau spec_id_ctxt  `thenTc_`
-
-	    -- Check that the type variables of the explicit spec_id are
-	    -- either left polymorphic, or instantiate to ground type.
-	    -- Also check that the overloaded type variables are instantiated to
-	    -- ground type; or equivalently that all dictionaries have ground type
-    	applyTcSubstToTyVars spec_id_tyvars	`thenNF_Tc` \ spec_id_arg_tys ->
-    	applyTcSubstToInsts  spec_id_dicts	`thenNF_Tc` \ spec_id_dicts' ->
-
-    	checkTc (not (all isGroundOrTyVarTy spec_id_arg_tys))
-		(specGroundnessErr spec_id_ctxt spec_id_arg_tys)
-				    		`thenTc_`
-
-    	checkTc (not (and [isGroundTy ty | (_,ty) <- map getDictClassAndType spec_id_dicts']))
-	    	(specCtxtGroundnessErr spec_id_ctxt spec_id_dicts')
-						`thenTc_`
+		-- Check that it has the correct type, and doesn't constrain the
+		-- signature variables at all
+	unifyTauTy sig_tau spec_tau   	  		`thenTc_`
+	checkSigTyVars sig_tyvars sig_tau spec_tau	`thenTc_`
 
 	    -- Make a local SpecId to bind to applied spec_id
-	newSpecId main_id spec_tys spec_ty	`thenNF_Tc` \ local_spec_id ->
-
-	    -- Make a specPragmaId id with a spec_info for local_spec_id
-	    -- This is bound to local_spec_id
-	    -- The SpecInfo will be extracted by the specialiser and
-	    -- used to create a call instance for main_id (which is
-	    -- extracted from the spec_id)
-	    -- NB: the pseudo_local_id must stay in the scope of main_id !!!
-	let
-	    spec_info = SpecInfo spec_tys (length main_dicts') local_spec_id
-	in
-	newSpecPragmaId name spec_ty (Just spec_info)	`thenNF_Tc` \ pseudo_spec_id ->
+	newSpecId main_id main_arg_tys sig_ty	`thenNF_Tc` \ local_spec_id ->
+
 	let
-	    spec_bind   = VarMonoBind local_spec_id spec_rhs
-	    spec_rhs    = mkTyLam spec_tyvars (mkDictApp (mkTyApp (Var spec_id) spec_id_arg_tys)
-						         (map mkInstId spec_id_dicts'))
-	    pseudo_bind = VarMonoBind pseudo_spec_id (Var local_spec_id)
+	    spec_rhs   = mkHsTyLam sig_tyvars spec_body
+	    spec_binds = VarMonoBind local_spec_id spec_rhs
+			   `AndMonoBinds`
+	   		 VarMonoBind spec_pragma_id (HsVar (TcId local_spec_id))
+	    spec_info  = SpecInfo spec_tys (length main_theta) local_spec_id
 	in
-	returnTc (spec_bind `AndMonoBinds` pseudo_bind, mkLIE spec_id_dicts')
-    )
+	returnTc ((name, addInfo spec_info), spec_binds, spec_lie)
+-}
 \end{code}
 
-\begin{code}
-tc_bind :: E
-	-> RenamedBind
-	-> TcM (TypecheckedBind, LIE)
-
-tc_bind e (NonRecBind mono_binds)
-  = tcMonoBinds e mono_binds	`thenTc` \ (mono_binds2, lie) ->
-    returnTc  (NonRecBind mono_binds2, lie)
-
-tc_bind e (RecBind mono_binds)
-  = tcMonoBinds e mono_binds	`thenTc` \ (mono_binds2, lie) ->
-    returnTc  (RecBind mono_binds2, lie)
-\end{code}
 
+Error contexts and messages
+~~~~~~~~~~~~~~~~~~~~~~~~~~~
 \begin{code}
-specialiseBinds
-	:: [Id] 		-- Ids bound in this group
-	-> LIE			-- LIE of scope of these bindings
-	-> TypecheckedBinds
-	-> LIE
-	-> NF_TcM (TypecheckedBinds, LIE)
-
-specialiseBinds bound_ids lie_of_scope poly_binds poly_lie
-  = bindInstsOfLocalFuns lie_of_scope bound_ids
-					`thenNF_Tc` \ (lie2, inst_mbinds) ->
-
-    returnNF_Tc (poly_binds `ThenBinds` (SingleBind (NonRecBind inst_mbinds)),
-		 lie2 `plusLIE` poly_lie)
-\end{code}
-
-%************************************************************************
-%*									*
-\subsection{Signatures}
-%*									*
-%************************************************************************
-
-@tcSigs@ checks the signatures for validity, and returns a list of
-{\em freshly-instantiated} signatures.  That is, the types are already
-split up, and have fresh type variables (not @TyVarTemplate@s)
-installed.
-
-\begin{code}
-tcSigs :: E -> LVE
-       -> [RenamedSig] 
-       -> TcM [SignatureInfo]
-
-tcSigs e lve [] = returnTc []
-
-tcSigs e lve (s:ss)
-  = tc_sig  	 s	`thenTc` \ sig_info1 ->
-    tcSigs e lve ss	`thenTc` \ sig_info2 ->
-    returnTc (sig_info1 : sig_info2)
+patMonoBindsCtxt bind sty
+  = ppHang (ppPStr SLIT("In a pattern binding:")) 4 (ppr sty bind)
+
+--------------------------------------------
+specContextGroundnessCtxt -- err_ctxt dicts sty
+  = panic "specContextGroundnessCtxt"
+{-
+  = ppHang (
+    	ppSep [ppBesides [ppStr "In the SPECIALIZE pragma for `", ppr sty name, ppStr "'"],
+	       ppBesides [ppStr " specialised to the type `", ppr sty spec_ty,  ppStr "'"],
+	       pp_spec_id sty,
+	       ppStr "... not all overloaded type variables were instantiated",
+	       ppStr "to ground types:"])
+      4 (ppAboves [ppCat [ppr sty c, ppr sty t]
+		  | (c,t) <- map getDictClassAndType dicts])
   where
-    tc_sig (Sig v ty _ src_loc)	-- no interesting pragmas on non-iface sigs
-      = addSrcLocTc src_loc (
-
-	babyTcMtoTcM
-	  (tcPolyType (getE_CE e) (getE_TCE e) nullTVE ty) `thenTc` \ sigma_ty ->
-
-	let  val = assoc "tcSigs" lve v  in
-	    -- (The renamer/dependency-analyser should have ensured
-	    -- that there are only signatures for which there is a
-	    -- corresponding binding.)
-
-	    -- Instantiate the type, and unify with the type variable
-	    -- found in the Id.
-	specTy SignatureOrigin sigma_ty	`thenNF_Tc` \ (tyvars, dicts, tau_ty) ->
-	unifyTauTy (getIdUniType val) tau_ty
-		   (panic "ToDo: unifyTauTy(tcSigs)") `thenTc_`
-
-	returnTc (TySigInfo val tyvars dicts tau_ty src_loc)
-	)
-
-    tc_sig (SpecSig v ty using src_loc)
-      = addSrcLocTc src_loc (
-
-	babyTcMtoTcM
-	  (tcPolyType (getE_CE e) (getE_TCE e) nullTVE ty) `thenTc` \ sigma_ty ->
-
-	returnTc (ValSpecInfo v sigma_ty using src_loc)
-	)
+    (name, spec_ty, locn, pp_spec_id)
+      = case err_ctxt of
+	  ValSpecSigCtxt    n ty loc      -> (n, ty, loc, \ x -> ppNil)
+	  ValSpecSpecIdCtxt n ty spec loc ->
+	    (n, ty, loc,
+	     \ sty -> ppBesides [ppStr "... type of explicit id `", ppr sty spec, ppStr "'"])
+-}
 
-    tc_sig (InlineSig v guide locn)
-      = returnTc (ValInlineInfo v guide locn)
+-----------------------------------------------
+specGroundnessCtxt
+  = panic "specGroundnessCtxt"
 
-    tc_sig (DeforestSig v locn)
-      = returnTc (ValDeforestInfo v locn)
 
-    tc_sig (MagicUnfoldingSig v str locn)
-      = returnTc (ValMagicUnfoldingInfo v str locn)
+valSpecSigCtxt v ty sty
+  = ppHang (ppPStr SLIT("In a SPECIALIZE pragma for a value:"))
+	 4 (ppSep [ppBeside (pprNonOp sty v) (ppPStr SLIT(" ::")),
+		  ppr sty ty])
 \end{code}
+
diff --git a/ghc/compiler/typecheck/TcClassDcl.hi b/ghc/compiler/typecheck/TcClassDcl.hi
deleted file mode 100644
index 7fd45d6e71..0000000000
--- a/ghc/compiler/typecheck/TcClassDcl.hi
+++ /dev/null
@@ -1,25 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface TcClassDcl where
-import Bag(Bag)
-import Class(Class, ClassOp)
-import CmdLineOpts(GlobalSwitch)
-import E(E)
-import HsBinds(Binds, MonoBinds)
-import HsDecls(ClassDecl)
-import HsPat(InPat, TypecheckedPat)
-import Id(Id)
-import IdInfo(SpecEnv)
-import InstEnv(InstTemplate)
-import LIE(LIE)
-import Name(Name)
-import Pretty(PprStyle, PrettyRep)
-import SplitUniq(SplitUniqSupply)
-import SrcLoc(SrcLoc)
-import Subst(Subst)
-import TcMonad(TcResult)
-import UniType(UniType)
-import UniqFM(UniqFM)
-data ClassInfo 
-tcClassDecls1 :: E -> (Class -> ([(UniType, InstTemplate)], ClassOp -> SpecEnv)) -> [ClassDecl Name (InPat Name)] -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult ([ClassInfo], UniqFM Class, [(Name, Id)])
-tcClassDecls2 :: E -> [ClassInfo] -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> ((LIE, Binds Id TypecheckedPat), Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep))
-
diff --git a/ghc/compiler/typecheck/TcClassDcl.lhs b/ghc/compiler/typecheck/TcClassDcl.lhs
index a890255ed1..805fe986c8 100644
--- a/ghc/compiler/typecheck/TcClassDcl.lhs
+++ b/ghc/compiler/typecheck/TcClassDcl.lhs
@@ -7,186 +7,196 @@
 #include "HsVersions.h"
 
 module TcClassDcl (
-	tcClassDecls1, tcClassDecls2,
-	ClassInfo   -- abstract
+	tcClassDecl1, tcClassDecls2
     ) where
 
-IMPORT_Trace		-- ToDo: rm (debugging)
-import Pretty	-- add proper one below
-
-import TcMonad		-- typechecking monad machinery
-import TcMonadFns	( newDicts, newClassOpLocals, copyTyVars )
-import AbsSyn		-- the stuff being typechecked
-
-import AbsPrel		( pAT_ERROR_ID )
-import AbsUniType	( mkClass, getClassKey, getClassBigSig,
-			  getClassOpString, getClassOps, splitType,
-			  mkSuperDictSelType, InstTyEnv(..),
-			  instantiateTy, instantiateThetaTy, UniType
-			)
-import BackSubst	( applyTcSubstToBinds )
-import CE		-- ( nullCE, unitCE, plusCE, CE(..), UniqFM )
-import E		( mkE, getE_TCE, getE_CE, tvOfE, nullGVE, plusGVE, E, TCE(..), UniqFM, GVE(..) )
-import Errors		( confusedNameErr, Error(..) )
-import HsPragmas	-- ****** NEED TO SEE CONSTRUCTORS ******
-import Id		( mkSuperDictSelId, mkInstId, getIdUniType,
-			  Id, DictFun(..)
-			)
-import IdInfo
-import Inst		( InstOrigin(..), Inst )
-import InstEnv
-import LIE		( nullLIE, mkLIE, plusLIE, LIE )
-import Maybes		( Maybe(..) )
-import Name		( Name(..) )
-import PlainCore	( escErrorMsg )
-import Spec		( specTy )
-import TVE		( mkTVE, TVE(..)
-			  IF_ATTACK_PRAGMAS(COMMA u2i)
-			)
-import TcClassSig	( tcClassSigs )
-import TcContext	( tcContext )
+import Ubiq
+
+import HsSyn		( ClassDecl(..), HsBinds(..), Bind(..), MonoBinds(..),
+			  Match(..), GRHSsAndBinds(..), GRHS(..), HsExpr(..),
+			  HsLit(..), OutPat(..), Sig(..), PolyType(..), MonoType, 
+			  Stmt, Qual, ArithSeqInfo, InPat, Fake )
+import HsPragmas	( ClassPragmas(..) )
+import RnHsSyn		( RenamedClassDecl(..), RenamedClassPragmas(..),
+			  RenamedClassOpSig(..), RenamedMonoBinds(..),
+			  RenamedGenPragmas(..), RenamedContext(..) )
+import TcHsSyn		( TcIdOcc(..), TcHsBinds(..), TcMonoBinds(..), TcExpr(..),
+			  mkHsTyApp, mkHsTyLam, mkHsDictApp, mkHsDictLam, unZonkId )
+
+import TcMonad
+import GenSpecEtc	( specTy )
+import Inst		( Inst, InstOrigin(..), LIE(..), emptyLIE, plusLIE, newDicts )
+import TcEnv		( tcLookupClass, tcLookupTyVar, tcLookupTyCon, newLocalIds)
 import TcInstDcls	( processInstBinds )
-import TcPragmas	( tcGenPragmas )
+import TcKind		( unifyKind )
+import TcMonoType	( tcMonoType, tcContext )
+import TcType		( TcTyVar(..), tcInstType, tcInstTyVar )
+import TcKind		( TcKind )
+
+import Bag		( foldBag )
+import Class		( GenClass, mkClass, mkClassOp, getClassBigSig, 
+			  getClassOps, getClassOpString, getClassOpLocalType )
+import CoreUtils	( escErrorMsg )
+import Id		( mkSuperDictSelId, mkMethodSelId, mkDefaultMethodId,
+			  idType )
+import IdInfo		( noIdInfo )
+import Name		( Name, getNameFullName, getTagFromClassOpName )
+import PrelVals		( pAT_ERROR_ID )
+import PprStyle
+import Pretty
+import PprType		( GenType, GenTyVar, GenClassOp )
+import SpecEnv		( SpecEnv(..) )
+import SrcLoc		( mkGeneratedSrcLoc )
+import Type		( mkFunTy, mkTyVarTy, mkDictTy,
+			  mkForAllTy, mkSigmaTy, splitSigmaTy)
+import TysWiredIn	( stringTy )
+import TyVar		( GenTyVar )			 
+import Unique		( Unique )			 
 import Util
-\end{code}
 
-@ClassInfo@ communicates the essential information about
-locally-defined classes between passes 1 and 2.
+-- import TcPragmas	( tcGenPragmas, tcClassOpPragmas )
+tcGenPragmas ty id ps = returnNF_Tc noIdInfo
+tcClassOpPragmas ty sel def spec ps = returnNF_Tc (noIdInfo, noIdInfo)
 
-\begin{code}
-data ClassInfo
-  = ClassInfo	Class
-		RenamedMonoBinds
 \end{code}
 
+\begin{code}
+tcClassDecl1 rec_inst_mapper
+      	     (ClassDecl context class_name
+			tyvar_name class_sigs def_methods pragmas src_loc)
+  = tcAddSrcLoc src_loc	$
+    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) ->
+    let
+	(rec_class_inst_env, rec_class_op_inst_fn) = rec_inst_mapper rec_class
+    in
+
+	-- FORCE THE CLASS AND ITS TYVAR TO HAVE SAME KIND
+    unifyKind class_kind tyvar_kind	`thenTc_`
+
+	-- CHECK THE CONTEXT
+    tcClassContext rec_class rec_tyvar context pragmas	
+				`thenTc` \ (scs, sc_sel_ids) ->
+
+	-- CHECK THE CLASS SIGNATURES,
+    mapTc (tcClassSig rec_class rec_tyvar rec_class_op_inst_fn) class_sigs
+				`thenTc` \ sig_stuff ->
+
+	-- MAKE THE CLASS OBJECT ITSELF
+    tcGetUnique			`thenNF_Tc` \ uniq ->
+    let
+	(ops, op_sel_ids, defm_ids) = unzip3 sig_stuff
+	clas = mkClass uniq (getNameFullName class_name) rec_tyvar
+		       scs sc_sel_ids ops op_sel_ids defm_ids
+		       rec_class_inst_env
+    in
+    returnTc clas
+\end{code}
 
-%************************************************************************
-%*									*
-\subsection[TcClassDcl]{Does the real work (apart from default methods)}
-%*									*
-%************************************************************************
 
 \begin{code}
-tcClassDecls1
-    :: E			-- Consult the CE/TCE args only to build knots
-    -> InstanceMapper		-- Maps class name to its instances,
-				-- ...and its ops to their instances,
-    -> [RenamedClassDecl]
-    -> TcM ([ClassInfo],	-- boiled-down info related to classes
-	    CE,			-- env so we can look up classes elsewhere
-	    GVE)		-- env so we can look up class ops elsewhere
-
-tcClassDecls1 e rec_inst_mapper []
-  = returnTc ([], nullCE, nullGVE)
-
-tcClassDecls1 e rec_inst_mapper (cd:cds)
-  = tc_clas1			    cd  `thenTc` \ (cinfo1_maybe, ce1, gve1) ->
-    tcClassDecls1 e rec_inst_mapper cds `thenTc` \ (cinfo2, ce2, gve2) ->
+tcClassContext :: Class -> TyVar
+	       -> RenamedContext 	-- class context
+	       -> RenamedClassPragmas	-- pragmas for superclasses  
+	       -> TcM s ([Class],	-- the superclasses
+			 [Id])  	-- superclass selector Ids
+
+tcClassContext rec_class rec_tyvar context pragmas
+  = 	-- Check the context.
+	-- The renamer has already checked that the context mentions
+	-- only the type variable of the class decl.
+    tcContext context			`thenTc` \ theta ->
     let
-	glued_cinfos
-	  = case cinfo1_maybe of
-	      Nothing -> cinfo2
-	      Just xx -> xx : cinfo2
+      super_classes = [ supers | (supers, _) <- theta ]
     in
-    returnTc (glued_cinfos, ce1 `plusCE` ce2, gve1 `plusGVE` gve2)
+
+	-- Make super-class selector ids
+    mapTc (mk_super_id rec_class) 
+	  (super_classes `zip` maybe_pragmas)	`thenTc` \ sc_sel_ids ->
+
+	-- Done
+    returnTc (super_classes, sc_sel_ids)
+
   where
-    rec_ce  = getE_CE  e
-    rec_tce = getE_TCE e
+    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
+	      ty = mkForAllTy rec_tyvar (
+	           mkFunTy (mkDictTy rec_class   (mkTyVarTy rec_tyvar))
+		           (mkDictTy super_class (mkTyVarTy rec_tyvar))
+		   )
+	    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
+
+
+
+tcClassSig :: Class	    		-- Knot tying only!
+	   -> TyVar		 	-- The class type variable, used for error check only
+	   -> (ClassOp -> SpecEnv)	-- Ditto; the spec info for the class ops
+	   -> RenamedClassOpSig
+	   -> TcM s (ClassOp,		-- class op
+		     Id,		-- selector id
+		     Id)		-- default-method ids
+
+tcClassSig rec_clas rec_clas_tyvar rec_classop_spec_fn
+	   (ClassOpSig op_name
+		       (HsForAllTy tyvar_names context monotype)
+		       pragmas src_loc)
+  = tcAddSrcLoc src_loc $
+    fixTc ( \ ~(_, rec_sel_id, rec_defm_id) ->	-- Knot for pragmas
+
+	-- Check the type signature.  NB that the envt *already has*
+	-- bindings for the type variables; see comments in TcTyAndClassDcls.
+    tcContext context				`thenTc`    \ theta ->
+    tcMonoType monotype				`thenTc`    \ tau ->
+    mapAndUnzipNF_Tc tcLookupTyVar tyvar_names	`thenNF_Tc` \ (_,tyvars) ->
+    let
+	full_tyvars = rec_clas_tyvar : tyvars
+	full_theta  = (rec_clas, mkTyVarTy rec_clas_tyvar) : theta
+	global_ty   = mkSigmaTy full_tyvars full_theta tau
+	local_ty    = mkSigmaTy tyvars theta tau
+	class_op    = mkClassOp (getOccurrenceName op_name)
+				(getTagFromClassOpName op_name)
+				local_ty
+    in
 
-    tc_clas1 (ClassDecl context class_name
-			tyvar_name class_sigs def_methods pragmas src_loc)
+	-- 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) ->
 
-      = addSrcLocTc src_loc	(
-
-	    -- The knot is needed so that the signatures etc can point
-	    -- back to the class itself
-	fixTc (\ ~(rec_clas, _) ->
-	  let
-	     (rec_clas_inst_env, rec_class_op_inst_fn) = rec_inst_mapper rec_clas
-	  in
-	    -- Get new (template) type variables for the class
-	  let  (tve, [clas_tyvar], [alpha]) = mkTVE [tyvar_name]  in
-
-	    -- Typecheck the class context; since there is only one type
-	    -- variable in scope, we are assured that the it will be of
-	    -- the form (C1 a, C2 a...)
-	  babyTcMtoTcM (tcContext rec_ce rec_tce tve context) `thenTc` \ theta ->
-
-	    -- Make the superclass selector ids; the "class" pragmas
-	    -- may have info about the superclass dict selectors;
-	    -- so it is only tcClassPragmas that gives back the
-	    -- final Ids.
-	  getUniquesTc (length theta)		`thenNF_Tc` \ uniqs ->
-	  let
-	      super_classes = [ supers | (supers, _) <- theta ]
-	      super_tys
-	        = [ mkSuperDictSelType rec_clas super | super <- super_classes ]
-	      super_info = zip3 super_classes uniqs super_tys
-	  in
-	  (case pragmas of
-	    NoClassPragmas ->
-	      returnNF_Tc [ mk_super_id rec_clas info noIdInfo | info <- super_info ]
-
-	    SuperDictPragmas prags ->
---	      pprTrace "SuperDictPragmas:" (ppAboves (ppr PprDebug prags : map pp super_info)) (
-	      mapNF_Tc (mk_super_id_w_info rec_clas) (super_info `zipEqual` prags)
---	      )
---	      where
---		pp (sc, u, ty) = ppCat [ppr PprDebug sc, ppr PprDebug ty]
-
-	  ) `thenNF_Tc` \ super_class_sel_ids ->
-
-	    -- Typecheck the class signatures, checking that each mentions
-	    -- the class type variable somewhere, and manufacturing
-	    -- suitable Ids for selectors and default methods.
-	  babyTcMtoTcM
-	    (tcClassSigs e tve rec_clas rec_class_op_inst_fn
-			       clas_tyvar defm_names class_sigs)
-		   `thenTc` \ (ops, ops_gve, op_sel_ids, defm_ids) ->
-
-	     -- Make the class object itself, producing clas::Class
-	  let
-	     clas
-		= mkClass class_name clas_tyvar
-			  super_classes super_class_sel_ids
-			  ops op_sel_ids defm_ids
-			  rec_clas_inst_env
-	  in
-	  returnTc (clas, ops_gve)
-	)				`thenTc` \ (clas, ops_gve) ->
-
-	     -- Return the class decl for further work if it is
-	     -- local, otherwise just return the CE
-	returnTc (if (isLocallyDefined class_name) then
-		     Just (ClassInfo clas def_methods)
-		  else
-		     Nothing,
-		  unitCE (getClassKey clas) clas,
-		  ops_gve
-    	))
-      where
-	defm_names = collectMonoBinders def_methods
-
-	-----------
-	mk_super_id clas (super_clas, uniq, ty) id_info
-	  = mkSuperDictSelId uniq clas super_clas ty id_info
-
-	-----------
-	mk_super_id_w_info clas ((super_clas, uniq, ty), gen_prags)
-	  = fixNF_Tc ( \ rec_super_id ->
-		babyTcMtoNF_TcM
-		    (tcGenPragmas e{-fake_E-} Nothing{-ty unknown-} rec_super_id gen_prags)
-			`thenNF_Tc` \ id_info ->
-
-		returnNF_Tc(mkSuperDictSelId uniq clas super_clas ty id_info)
-	    )
-
-{- SOMETHING LIKE THIS NEEDED? ToDo [WDP]
-    tc_clas1 (ClassDecl _ bad_name _ _ _ _ src_loc)
-      = failTc (confusedNameErr
-		    "Bad name for a class (a type constructor, or Prelude name?)"
-		    bad_name src_loc)
--}
+	-- Build the selector id and default method id
+    tcGetUnique					`thenNF_Tc` \ d_uniq ->
+    let
+	op_uniq = getItsUnique 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
+			-- ToDo: improve the "False"
+    in
+    returnTc (class_op, sel_id, defm_id)
+    )
 \end{code}
 
 
@@ -204,69 +214,57 @@ using them to produce a complete set of default-method decls.
 (Omitted ones elicit an error message.)
 \item
 to produce a definition for the selector function for each method
+and superclass dictionary.
 \end{enumerate}
 
 Pass~2 only applies to locally-defined class declarations.
 
-The function @tcClassDecls2@ just arranges to apply
-@tcClassDecls2_help@ to each local class decl.
+The function @tcClassDecls2@ just arranges to apply @tcClassDecl2@ to
+each local class decl.
 
 \begin{code}
-tcClassDecls2 e class_info
-  = let
-	-- Get type variables free in environment. Sadly, there may be
-	-- some, because of the dreaded monomorphism restriction
-	free_tyvars = tvOfE e
-    in
-    tcClassDecls2_help e free_tyvars class_info
-
-tcClassDecls2_help
-	:: E
-	-> [TyVar]
-	-> [ClassInfo]
-	-> NF_TcM (LIE, TypecheckedBinds)
-
-tcClassDecls2_help e free_tyvars [] = returnNF_Tc (nullLIE, EmptyBinds)
-
-tcClassDecls2_help e free_tyvars ((ClassInfo clas default_binds) : rest)
-  = tcClassDecl2 e free_tyvars clas default_binds `thenNF_Tc` \ (lie1, binds1) ->
-    tcClassDecls2_help e free_tyvars rest	  `thenNF_Tc` \ (lie2, binds2) ->
-    returnNF_Tc (lie1 `plusLIE` lie2, binds1 `ThenBinds` binds2)
+tcClassDecls2 :: Bag RenamedClassDecl
+	      -> NF_TcM s (LIE s, TcHsBinds s)
+
+tcClassDecls2 decls
+  = foldBag combine
+	    tcClassDecl2
+	    (returnNF_Tc (emptyLIE, EmptyBinds))
+	    decls
+  where
+    combine tc1 tc2 = tc1 `thenNF_Tc` \ (lie1, binds1) ->
+		      tc2 `thenNF_Tc` \ (lie2, binds2) ->
+		      returnNF_Tc (lie1 `plusLIE` lie2,
+				   binds1 `ThenBinds` binds2)
 \end{code}
 
 @tcClassDecl2@ is the business end of things.
 
 \begin{code}
-tcClassDecl2 :: E
-	     -> [TyVar]			-- Free in the envt
-	     -> Class
-	     -> RenamedMonoBinds	-- The default decls
-	     -> NF_TcM (LIE, TypecheckedBinds)
-
-tcClassDecl2 e free_tyvars clas default_binds
-  = let 
-	src_loc = getSrcLoc clas
-	origin  = ClassDeclOrigin src_loc
-	(clas_tyvar_tmpl, scs, sc_sel_ids, ops, op_sel_ids, defm_ids)
+tcClassDecl2 :: RenamedClassDecl	-- The class declaration
+	     -> NF_TcM s (LIE s, TcHsBinds s)
+
+tcClassDecl2 (ClassDecl context class_name
+			tyvar_name class_sigs default_binds pragmas src_loc)
+  = recoverNF_Tc (returnNF_Tc (emptyLIE, EmptyBinds)) $
+    tcAddSrcLoc src_loc		     		      $
+
+	-- Get the relevant class
+    tcLookupClass class_name		`thenNF_Tc` \ (_, clas) ->
+    let
+	(tyvar, scs, sc_sel_ids, ops, op_sel_ids, defm_ids)
 	  = getClassBigSig clas
     in
-	 -- Prune the substitution when we are finished, and arrange error recovery
-    recoverTc (nullLIE, EmptyBinds) (
-    addSrcLocTc src_loc		    (
-    pruneSubstTc free_tyvars	    (
+    tcInstTyVar tyvar			`thenNF_Tc` \ clas_tyvar ->
 
-	 -- Generate bindings for the selector functions
-    buildSelectors origin clas clas_tyvar_tmpl scs sc_sel_ids ops op_sel_ids
+	-- Generate bindings for the selector functions
+    buildSelectors clas clas_tyvar scs sc_sel_ids ops op_sel_ids
 						`thenNF_Tc` \ sel_binds ->
-	 -- Ditto for the methods
-    buildDefaultMethodBinds e free_tyvars origin clas clas_tyvar_tmpl
-		defm_ids default_binds		`thenTc` \ (const_insts, meth_binds) ->
-
-	 -- Back-substitute through the definitions
-    applyTcSubstToInsts const_insts			   `thenNF_Tc` \ final_const_insts ->
-    applyTcSubstToBinds (sel_binds `ThenBinds` meth_binds) `thenNF_Tc` \ final_binds ->
-    returnTc (mkLIE final_const_insts, final_binds)
-    )))
+	-- Ditto for the methods
+    buildDefaultMethodBinds clas clas_tyvar defm_ids default_binds
+						`thenTc` \ (const_insts, meth_binds) ->
+
+    returnTc (const_insts, sel_binds `ThenBinds` meth_binds)
 \end{code}
 
 %************************************************************************
@@ -276,43 +274,42 @@ tcClassDecl2 e free_tyvars clas default_binds
 %************************************************************************
 
 \begin{code}
-buildSelectors :: InstOrigin
-	       -> Class			-- The class object
-	       -> TyVarTemplate		-- Class type variable
+buildSelectors :: Class			-- The class object
+	       -> TcTyVar s		-- Class type variable
 	       -> [Class] -> [Id]	-- Superclasses and selectors
 	       -> [ClassOp] -> [Id]	-- Class ops and selectors
-	       -> NF_TcM TypecheckedBinds
+	       -> NF_TcM s (TcHsBinds s)
 
-buildSelectors origin clas clas_tyvar_tmpl
-	scs sc_sel_ids
-	ops op_sel_ids
+buildSelectors clas clas_tyvar scs sc_sel_ids ops op_sel_ids
   =
-	 -- Instantiate the class variable
-    copyTyVars [clas_tyvar_tmpl] `thenNF_Tc` \ (inst_env, [clas_tyvar], [clas_tyvar_ty]) ->
-	 -- Make an Inst for each class op, and
-	 -- dicts for the superclasses.	 These are used to
-	 -- construct the selector functions
-    newClassOpLocals inst_env ops			`thenNF_Tc` \ method_ids ->
-    newDicts origin [ (super_clas, clas_tyvar_ty)
-		    | super_clas <- scs
-		    ]					`thenNF_Tc` \ dicts ->
-    let dict_ids = map mkInstId dicts  in
+	-- Make new Ids for the components of the dictionary
+    mapNF_Tc (tcInstType [] . getClassOpLocalType) ops	`thenNF_Tc` \ op_tys ->
+
+    newLocalIds (map getClassOpString ops) op_tys	`thenNF_Tc` \ method_ids ->
+
+    newDicts ClassDeclOrigin 
+	     [ (super_clas, mkTyVarTy clas_tyvar)
+	     | super_clas <- scs ]			`thenNF_Tc` \ (_,dict_ids) ->
+
+    newDicts ClassDeclOrigin 
+	     [ (clas, mkTyVarTy clas_tyvar) ]		`thenNF_Tc` \ (_,[clas_dict]) ->
 
 	 -- Make suitable bindings for the selectors
-    let mk_op_sel op sel_id method_id
-	  = mkSelExpr origin clas_tyvar dict_ids method_ids method_id	`thenNF_Tc` \ rhs ->
-	    returnNF_Tc (VarMonoBind sel_id rhs)
-	mk_sc_sel sc sel_id dict_id
-	 = mkSelExpr origin clas_tyvar dict_ids method_ids dict_id	`thenNF_Tc` \ rhs ->
-	   returnNF_Tc (VarMonoBind sel_id rhs)
+    let
+        tc_method_ids = map TcId method_ids
+
+	mk_sel sel_id method_or_dict
+	  = mkSelBind sel_id clas_tyvar clas_dict dict_ids tc_method_ids method_or_dict
     in
-    listNF_Tc (zipWith3 mk_op_sel ops op_sel_ids method_ids)	`thenNF_Tc` \ op_sel_binds ->
-    listNF_Tc (zipWith3 mk_sc_sel scs sc_sel_ids dict_ids)	`thenNF_Tc` \ sc_sel_binds ->
+    listNF_Tc (zipWithEqual mk_sel op_sel_ids tc_method_ids) `thenNF_Tc` \ op_sel_binds ->
+    listNF_Tc (zipWithEqual mk_sel sc_sel_ids dict_ids)      `thenNF_Tc` \ sc_sel_binds ->
 
     returnNF_Tc (SingleBind (
 		 NonRecBind (
-		 foldr AndMonoBinds EmptyMonoBinds (
-		 op_sel_binds ++ sc_sel_binds))))
+		 foldr AndMonoBinds
+		       (foldr AndMonoBinds EmptyMonoBinds op_sel_binds)
+		       sc_sel_binds
+		 )))
 \end{code}
 
 %************************************************************************
@@ -321,8 +318,8 @@ buildSelectors origin clas clas_tyvar_tmpl
 %*									*
 %************************************************************************
 
-Make a selector expression for @local@ from a dictionary consisting of
-@dicts@ and @op_locals@.
+Make a selector expression for @sel_id@ from a dictionary @clas_dict@
+consisting of @dicts@ and @methods@.
 
 We have to do a bit of jiggery pokery to get the type variables right.
 Suppose we have the class decl:
@@ -333,11 +330,12 @@ Suppose we have the class decl:
 \end{verbatim}
 Then the method selector for \tr{op1} is like this:
 \begin{verbatim}
-	op1_sel = /\ab -> \dFoo -> case dFoo of
-					(op1_method,op2_method) -> op1_method b
+	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} is lifted to the top big lambda, and
-\tr{op1_method} is applied to it.  This is preferable to the alternative:
+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
@@ -351,43 +349,45 @@ whereas \tr{op1_sel} (the one we use) has the decent type
 	op1_sel :: forall a b. Foo a -> Ord b -> a -> b -> a
 \end{verbatim}
 
-{\em NOTE:}
-We could do the same thing for the dictionaries, giving
-\begin{verbatim}
-	op1_sel = /\ab -> \dFoo -> \dOrd -> case dFoo of
-						(m1,m2) -> m1 b dOrd
-\end{verbatim}
-but WE ASSUME THAT DICTIONARY APPLICATION IS CURRIED, so the two are
-precisely equivalent, and have the same type, namely
-\begin{verbatim}
-	op1_sel :: forall a b. Foo a -> Ord b -> a -> b -> a
-\end{verbatim}
+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!
 
-WDP 95/03: Quite false (``DICTIONARY APPLICATION IS CURRIED'').
-Specialisation now wants to see all type- and dictionary-applications
-absolutely explicitly.
+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}
-mkSelExpr :: InstOrigin -> TyVar -> [Id] -> [Id] -> Id -> NF_TcM TypecheckedExpr
+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)
 
-mkSelExpr origin clas_tyvar dicts op_locals local
+mkSelBind sel_id clas_tyvar clas_dict dicts methods method_or_dict@(TcId op)
   = let
-	(op_tyvar_tmpls,local_theta,_) = splitType (getIdUniType local)
-    in
-    copyTyVars op_tyvar_tmpls	`thenNF_Tc` \ (inst_env, op_tyvars, tys) ->
-    let
-	inst_theta = instantiateThetaTy inst_env local_theta
-    in
-    newDicts origin inst_theta	`thenNF_Tc` \ local_dict_insts ->
-    let
-	local_dicts = map mkInstId local_dict_insts
+	(op_tyvars,op_theta,op_tau) = splitSigmaTy (idType op)
+	op_tys = map mkTyVarTy op_tyvars
     in
-    returnNF_Tc (TyLam (clas_tyvar:op_tyvars)
-		   (ClassDictLam
-		      dicts
-		      op_locals
-		      (mkDictLam local_dicts
-			(mkDictApp (mkTyApp (Var local) tys) local_dicts))))
+    newDicts ClassDeclOrigin op_theta	`thenNF_Tc` \ (_, op_dicts) ->
+
+	-- sel_id = /\ clas_tyvar op_tyvars -> \ clas_dict op_dicts ->
+	--	    case clas_dict of 
+	--		 <dicts..methods> -> method_or_dict op_tyvars op_dicts
+
+    returnNF_Tc (VarMonoBind (RealId sel_id)  (
+		 TyLam (clas_tyvar:op_tyvars) (
+		 DictLam (clas_dict:op_dicts) (
+		 HsCase
+		   (HsVar clas_dict)
+                   ([PatMatch  (DictPat dicts methods) (
+		     GRHSMatch (GRHSsAndBindsOut
+			[OtherwiseGRHS
+			   (mkHsDictApp (mkHsTyApp (HsVar method_or_dict) op_tys) op_dicts)
+		  	   mkGeneratedSrcLoc]
+			EmptyBinds
+			op_tau))])
+		    mkGeneratedSrcLoc
+		 ))))
 \end{code}
 
 
@@ -454,24 +454,21 @@ dfun.Foo.List
 
 \begin{code}
 buildDefaultMethodBinds
-	:: E
-	-> [TyVar]
-	-> InstOrigin
-	-> Class
-	-> TyVarTemplate
+	:: Class
+	-> TcTyVar s
 	-> [Id]
 	-> RenamedMonoBinds
-	-> TcM ([Inst], TypecheckedBinds)
+	-> TcM s (LIE s, TcHsBinds s)
 
-buildDefaultMethodBinds e free_tyvars origin clas clas_tyvar_tmpl
+buildDefaultMethodBinds clas clas_tyvar
 			default_method_ids default_binds
   =	-- Deal with the method declarations themselves
-    processInstBinds e
-	 free_tyvars
-	 (makeClassDeclDefaultMethodRhs clas origin default_method_ids)
-	 []	-- No tyvars in scope for "this inst decl"
-	 []	-- No insts available
-	 default_method_ids
+    mapNF_Tc unZonkId default_method_ids	`thenNF_Tc` \ tc_defm_ids ->
+    processInstBinds
+	 (makeClassDeclDefaultMethodRhs clas default_method_ids)
+	 []		-- No tyvars in scope for "this inst decl"
+	 emptyLIE 	-- No insts available
+	 (map TcId tc_defm_ids)
 	 default_binds		`thenTc` \ (dicts_needed, default_binds') ->
 
     returnTc (dicts_needed, SingleBind (NonRecBind default_binds'))
@@ -483,19 +480,20 @@ class declaration when no explicit default method is given.
 \begin{code}
 makeClassDeclDefaultMethodRhs
 	:: Class
-	-> InstOrigin
 	-> [Id]
 	-> Int
-	-> NF_TcM TypecheckedExpr
+	-> NF_TcM s (TcExpr s)
 
-makeClassDeclDefaultMethodRhs clas origin method_ids tag
-  = specTy origin (getIdUniType method_id) `thenNF_Tc` \ (tyvars, dicts, tau) ->
+makeClassDeclDefaultMethodRhs clas method_ids tag
+  = specTy ClassDeclOrigin (idType method_id) `thenNF_Tc` \ (tyvars, dicts, tau, dict_ids) ->
 
-    returnNF_Tc (mkTyLam tyvars (
-		 mkDictLam (map mkInstId dicts) (
-		 App (mkTyApp (Var pAT_ERROR_ID) [tau])
-		     (Lit (StringLit (_PK_ error_msg))))))
+    returnNF_Tc (mkHsTyLam tyvars (
+		 mkHsDictLam dict_ids (
+		 HsApp (mkHsTyApp (HsVar (RealId pAT_ERROR_ID)) [tau])
+		     (HsLitOut (HsString (_PK_ error_msg)) stringTy))))
   where
+    (clas_mod, clas_name) = getOrigName clas
+
     method_id = method_ids  !! (tag-1)
     class_op = (getClassOps clas) !! (tag-1)
 
@@ -506,6 +504,12 @@ makeClassDeclDefaultMethodRhs clas origin method_ids tag
 	_UNPK_ clas_mod ++ "." ++ _UNPK_ clas_name ++ "."
 	     ++ (ppShow 80 (ppr PprForUser class_op))
 	     ++ "\"" )
+\end{code}
 
-    (clas_mod, clas_name) = getOrigName clas
+
+Contexts
+~~~~~~~~
+\begin{code}
+classDeclCtxt class_name sty
+  = ppCat [ppStr "In the class declaration for", ppr sty class_name]
 \end{code}
diff --git a/ghc/compiler/typecheck/TcClassSig.hi b/ghc/compiler/typecheck/TcClassSig.hi
deleted file mode 100644
index c984afa922..0000000000
--- a/ghc/compiler/typecheck/TcClassSig.hi
+++ /dev/null
@@ -1,19 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface TcClassSig where
-import Bag(Bag)
-import Class(Class, ClassOp)
-import CmdLineOpts(GlobalSwitch)
-import E(E)
-import HsBinds(Sig)
-import Id(Id)
-import IdInfo(SpecEnv)
-import Name(Name)
-import Pretty(PprStyle, PrettyRep)
-import SplitUniq(SplitUniqSupply)
-import SrcLoc(SrcLoc)
-import TcMonad(Baby_TcResult)
-import TyVar(TyVarTemplate)
-import UniType(UniType)
-import UniqFM(UniqFM)
-tcClassSigs :: E -> UniqFM UniType -> Class -> (ClassOp -> SpecEnv) -> TyVarTemplate -> [Name] -> [Sig Name] -> (GlobalSwitch -> Bool) -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> Baby_TcResult ([ClassOp], [(Name, Id)], [Id], [Id])
-
diff --git a/ghc/compiler/typecheck/TcClassSig.lhs b/ghc/compiler/typecheck/TcClassSig.lhs
index e3637af46f..999bc0d580 100644
--- a/ghc/compiler/typecheck/TcClassSig.lhs
+++ b/ghc/compiler/typecheck/TcClassSig.lhs
@@ -1,5 +1,5 @@
 %
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
 %
 \section[TcClassSig]{Typecheck a class signature}
 
@@ -9,18 +9,12 @@
 module TcClassSig ( tcClassSigs ) where
 
 import TcMonad		-- typechecking monadic machinery
-import AbsSyn		-- the stuff being typechecked
+import HsSyn		-- the stuff being typechecked
 
-import AbsUniType
-import CE		( CE(..) )
-import E		( mkE, getE_TCE, getE_CE, nullGVE, unitGVE, plusGVE, GVE(..), E )
-import Errors		( methodTypeLacksTyVarErr, confusedNameErr )
+import Type
 import Id		( mkDefaultMethodId, mkClassOpId, IdInfo )
 import IdInfo
-import InstEnv		( InstTemplate )
-import TCE		( TCE(..), UniqFM )
-import TVE		( TVE(..) )
-import TcPolyType	( tcPolyType )
+import TcMonoType	( tcPolyType )
 import TcPragmas	( tcClassOpPragmas )
 import Util
 \end{code}
@@ -32,9 +26,9 @@ tcClassSigs :: E -> TVE -> Class    	-- Knot tying only!
 	    -> [Name]			-- Names with default methods
 	    -> [RenamedClassOpSig]
 	    -> Baby_TcM ([ClassOp],	-- class ops
-		         GVE,		-- env for looking up the class ops
-		         [Id],		-- selector ids
-		         [Id])		-- default-method ids
+			 GVE,		-- env for looking up the class ops
+			 [Id],		-- selector ids
+			 [Id])		-- default-method ids
 
 tcClassSigs e tve rec_clas rec_classop_spec_fn clas_tyvar defm_names sigs
   = mapB_Tc tc_sig sigs	`thenB_Tc` \ stuff ->
@@ -45,12 +39,13 @@ tcClassSigs e tve rec_clas rec_classop_spec_fn clas_tyvar defm_names sigs
   where
     rec_ce  = getE_CE  e
     rec_tce = getE_TCE e
+--FAKE:    fake_E  = mkE rec_tce rec_ce
 
-    tc_sig (ClassOpSig name@(ClassOpName op_uniq clas_name op_name tag) poly_ty pragmas src_loc)
+    tc_sig (ClassOpSig name@(ClassOpName op_uniq _ op_name tag) poly_ty pragmas src_loc)
       = addSrcLocB_Tc src_loc				 (
 	tcPolyType rec_ce rec_tce tve poly_ty	`thenB_Tc` \ local_ty ->
 	let
-	    (local_tyvar_tmpls, theta, tau) = splitType local_ty
+	    (local_tyvar_tmpls, theta, tau) = splitSigmaTy local_ty
 	    full_theta       = (rec_clas, (mkTyVarTemplateTy clas_tyvar)) : theta
 	    full_tyvar_tmpls = clas_tyvar : local_tyvar_tmpls
 	    global_ty        = mkForallTy full_tyvar_tmpls (mkRhoTy full_theta tau)
@@ -77,8 +72,8 @@ tcClassSigs e tve rec_clas rec_classop_spec_fn clas_tyvar defm_names sigs
 		-- default method code or the imported default method is bottoming.
 
 		error_defm = if isLocallyDefined clas_name then
-				 name `notElem` defm_names 
-			     else 
+				 name `notElem` defm_names
+			     else
 				 bottomIsGuaranteed (getInfo defm_info)
 	    in
 	    returnB_Tc (
diff --git a/ghc/compiler/typecheck/TcConDecls.hi b/ghc/compiler/typecheck/TcConDecls.hi
deleted file mode 100644
index fe832771ed..0000000000
--- a/ghc/compiler/typecheck/TcConDecls.hi
+++ /dev/null
@@ -1,18 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface TcConDecls where
-import Bag(Bag)
-import CmdLineOpts(GlobalSwitch)
-import HsDecls(ConDecl)
-import Id(Id)
-import IdInfo(SpecEnv)
-import Name(Name)
-import Pretty(PprStyle, PrettyRep)
-import SplitUniq(SplitUniqSupply)
-import SrcLoc(SrcLoc)
-import TcMonad(Baby_TcResult)
-import TyCon(TyCon)
-import TyVar(TyVarTemplate)
-import UniType(UniType)
-import UniqFM(UniqFM)
-tcConDecls :: UniqFM TyCon -> UniqFM UniType -> TyCon -> [TyVarTemplate] -> SpecEnv -> [ConDecl Name] -> (GlobalSwitch -> Bool) -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> Baby_TcResult [(Name, Id)]
-
diff --git a/ghc/compiler/typecheck/TcConDecls.lhs b/ghc/compiler/typecheck/TcConDecls.lhs
deleted file mode 100644
index 86519ac096..0000000000
--- a/ghc/compiler/typecheck/TcConDecls.lhs
+++ /dev/null
@@ -1,55 +0,0 @@
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
-%
-\section[TcConDecls]{Typechecking @ConDecls@}
-
-\begin{code}
-#include "HsVersions.h"
-
-module TcConDecls ( tcConDecls ) where
-
-import TcMonad		-- typechecking monadic machinery
-import AbsSyn
-
-import CE		( CE(..) )
-import E		( GVE(..), nullGVE, plusGVE )
-import Errors		( confusedNameErr )
-import Id		( mkDataCon, SpecEnv )
-import TCE		( TCE(..), UniqFM )
-import TVE		( TVE(..) )
-import TcMonoType	( tcMonoType )
-import Util
-\end{code}
-
-\begin{code}
-tcConDecls :: TCE -> TVE -> TyCon -> [TyVarTemplate] -> SpecEnv
-	   -> [RenamedConDecl] -> Baby_TcM GVE
-
-tcConDecls tce tve tycon tyvars specenv [] = returnB_Tc nullGVE
-
-tcConDecls tce tve tycon tyvars specenv (cd:cds) 
-  = tc_decl cd					`thenB_Tc` \ gve_fst ->
-    tcConDecls tce tve tycon tyvars specenv cds	`thenB_Tc` \ gve_rest ->
-    returnB_Tc (plusGVE gve_fst gve_rest)
-  where
-    tc_decl (ConDecl name@(OtherTopId uniq full_name) tys src_loc)
-      = addSrcLocB_Tc src_loc			 (
-	mapB_Tc (tcMonoType fake_CE tce tve) tys `thenB_Tc` \ arg_tys ->
-	returnB_Tc [(name, data_con arg_tys)]
-    	)
-      where
-	fake_CE = panic "tcConDecls:CE"
-
-	data_con arg_tys
-	  = mkDataCon uniq
-		      full_name
-		      tyvars
-		      [{-no context-}]
-		      arg_tys
-		      tycon
-		      specenv
-
-    tc_decl (ConDecl odd_name _ src_loc)
-      = failB_Tc (confusedNameErr "Bad name for a data constructor (a Prelude name?)"
-		    odd_name src_loc)
-\end{code}
diff --git a/ghc/compiler/typecheck/TcContext.hi b/ghc/compiler/typecheck/TcContext.hi
deleted file mode 100644
index 32583bdcf6..0000000000
--- a/ghc/compiler/typecheck/TcContext.hi
+++ /dev/null
@@ -1,15 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface TcContext where
-import Bag(Bag)
-import Class(Class)
-import CmdLineOpts(GlobalSwitch)
-import Name(Name)
-import Pretty(PprStyle, PrettyRep)
-import SplitUniq(SplitUniqSupply)
-import SrcLoc(SrcLoc)
-import TcMonad(Baby_TcResult)
-import TyCon(TyCon)
-import UniType(UniType)
-import UniqFM(UniqFM)
-tcContext :: UniqFM Class -> UniqFM TyCon -> UniqFM UniType -> [(Name, Name)] -> (GlobalSwitch -> Bool) -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> Baby_TcResult [(Class, UniType)]
-
diff --git a/ghc/compiler/typecheck/TcContext.lhs b/ghc/compiler/typecheck/TcContext.lhs
deleted file mode 100644
index fc79ae35dd..0000000000
--- a/ghc/compiler/typecheck/TcContext.lhs
+++ /dev/null
@@ -1,55 +0,0 @@
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
-%
-\section[TcContext]{Typecheck a type-class context}
-
-\begin{code}
-module TcContext ( tcContext ) where
-
-#include "HsVersions.h"
-
-import TcMonad		-- typechecking monadic machinery
-import AbsSyn		-- the stuff being typechecked
-
-import CE		( lookupCE, CE(..) )
-import Errors		( naughtyCCallContextErr )
-import TCE		( TCE(..), UniqFM )
-import TVE		( TVE(..) )
-import TcMonoType	( tcMonoType )
-import Unique		( cCallableClassKey, cReturnableClassKey )
-import Util
-
-tcContext :: CE -> TCE -> TVE -> RenamedContext -> Baby_TcM ThetaType
-
-tcContext ce tce tve context
-  = mapB_Tc (tcClassAssertion ce tce tve) context
-
-tcClassAssertion ce tce tve (class_name, tyname)
-  | canBeUsedInContext class_name
-  = tcMonoType ce tce tve (MonoTyVar tyname) `thenB_Tc` \ ty ->
-    returnB_Tc (lookupCE ce class_name, ty)
-
-  | otherwise
-  = getSrcLocB_Tc `thenB_Tc` \ locn ->
-    failB_Tc (naughtyCCallContextErr class_name locn)
-\end{code}
-
-HACK warning: Someone discovered that @_CCallable_@ and @_CReturnable@
-could be used in contexts such as:
-\begin{verbatim}
-foo :: _CCallable a => a -> PrimIO Int
-\end{verbatim}
-
-Doing this utterly wrecks the whole point of introducing these
-classes so we specifically check that this isn't being done.
-
-\begin{code}
-canBeUsedInContext :: Name -> Bool
-
-canBeUsedInContext class_name
-  = class_name /= cCallableClass && class_name /= cReturnableClass
- where
-  cCallableClass   = PreludeClass cCallableClassKey   bottom
-  cReturnableClass = PreludeClass cReturnableClassKey bottom
-  bottom	   = panic "canBeUsedInContext"
-\end{code}
diff --git a/ghc/compiler/typecheck/TcDefaults.hi b/ghc/compiler/typecheck/TcDefaults.hi
deleted file mode 100644
index 5566ab7d21..0000000000
--- a/ghc/compiler/typecheck/TcDefaults.hi
+++ /dev/null
@@ -1,15 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface TcDefaults where
-import Bag(Bag)
-import CmdLineOpts(GlobalSwitch)
-import E(E)
-import HsDecls(DefaultDecl)
-import Name(Name)
-import Pretty(PprStyle, PrettyRep)
-import SplitUniq(SplitUniqSupply)
-import SrcLoc(SrcLoc)
-import Subst(Subst)
-import TcMonad(TcResult)
-import UniType(UniType)
-tcDefaults :: E -> [DefaultDecl Name] -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult [UniType]
-
diff --git a/ghc/compiler/typecheck/TcDefaults.lhs b/ghc/compiler/typecheck/TcDefaults.lhs
index 811f04b6ad..5ea9905e60 100644
--- a/ghc/compiler/typecheck/TcDefaults.lhs
+++ b/ghc/compiler/typecheck/TcDefaults.lhs
@@ -8,60 +8,48 @@
 
 module TcDefaults ( tcDefaults ) where
 
-import TcMonad
-import AbsSyn
+import Ubiq
+
+import HsSyn		( DefaultDecl(..), MonoType,
+			  HsExpr, HsLit, ArithSeqInfo, Fake, InPat)
+import RnHsSyn		( RenamedDefaultDecl(..) )
+import TcHsSyn		( TcIdOcc )
 
-import AbsPrel		( intTy, doubleTy, unitTy )
-import AbsUniType	( UniType
-			  IF_ATTACK_PRAGMAS(COMMA cmpUniType)
-			)
-import CE		( lookupCE, CE(..) )
-import E
-import Inst
-import Name
+import TcMonad
+import Inst		( InstOrigin(..) )
+import TcEnv		( tcLookupClassByKey )
 import TcMonoType	( tcMonoType )
 import TcSimplify	( tcSimplifyCheckThetas )
-import TVE
-import Unique		( numClassKey, Unique )
+
+import PrelInfo		( intTy, doubleTy, unitTy )
+import Unique		( numClassKey )
 import Util
 \end{code}
 
 \begin{code}
-tcDefaults :: E
-	   -> [RenamedDefaultDecl]
-	   -> TcM [UniType] 	    -- defaulting types to heave
+tcDefaults :: [RenamedDefaultDecl]
+	   -> TcM s [Type] 	    -- defaulting types to heave
 				    -- into Tc monad for later use
 				    -- in Disambig.
 
-tcDefaults _ []
-  = returnTc [intTy, doubleTy] -- language-specified default `default'
+tcDefaults []
+  = returnTc [intTy, doubleTy] 	    -- language-specified default `default'
 
-tcDefaults e [DefaultDecl mono_tys locn]
-  = let
-	ce  = getE_CE  e
-	tce = getE_TCE e
-	tve = nullTVE
+tcDefaults [DefaultDecl mono_tys locn]
+  = tcAddSrcLoc locn $
+    mapTc tcMonoType mono_tys	`thenTc` \ tau_tys ->
 
-	num_clas = lookupCE ce (PreludeClass numClassKey (panic "tcDefaults"))
-    in
-    babyTcMtoTcM (mapB_Tc (tcMonoType ce tce tve) mono_tys) `thenTc` \ tau_tys ->
-
-	-- compensate for extreme parser hack: `default ()' actually
-	-- sends the *type* () through to here.  Squash it.
     case tau_tys of
-      [ty] | ty == unitTy -> returnTc []
-
-      _  -> -- (Back to your regularly scheduled programming...)
+      [] -> returnTc []		-- no defaults
 
+      _  ->
 	    -- Check that all the types are instances of Num
-
-	tcSimplifyCheckThetas (DefaultDeclOrigin locn)
-			 [ (num_clas, ty) | ty <- tau_tys ] `thenTc` \ _ ->
 	    -- We only care about whether it worked or not
 
-	returnTc tau_tys -- caller will bung them into Tc monad
+	tcLookupClassByKey numClassKey			`thenNF_Tc` \ num ->
+	tcSimplifyCheckThetas DefaultDeclOrigin
+		[ (num, ty) | ty <- tau_tys ]		`thenTc` \ _ ->
+
+	returnTc tau_tys
 
-tcDefaults _ (_:_)
-  = error "ERROR: You can only have one `default' declaration per module."
-    -- ToDo: proper error msg.
 \end{code}
diff --git a/ghc/compiler/typecheck/TcDeriv.hi b/ghc/compiler/typecheck/TcDeriv.hi
deleted file mode 100644
index e194406937..0000000000
--- a/ghc/compiler/typecheck/TcDeriv.hi
+++ /dev/null
@@ -1,29 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface TcDeriv where
-import Bag(Bag)
-import Class(Class)
-import CmdLineOpts(GlobalSwitch)
-import HsBinds(Binds)
-import HsDecls(FixityDecl)
-import HsPat(InPat)
-import Maybes(Labda)
-import Name(Name)
-import PreludePS(_PackedString)
-import Pretty(PprStyle, PrettyRep)
-import ProtoName(ProtoName)
-import SplitUniq(SplitUniqSupply)
-import SrcLoc(SrcLoc)
-import Subst(Subst)
-import TcInstDcls(InstInfo)
-import TcMonad(TcResult)
-import TyCon(TyCon)
-import TyVar(TyVar)
-import UniType(UniType)
-import UniqFM(UniqFM)
-type DerivEqn = (Class, TyCon, [TyVar], [(Class, UniType)])
-data TagThingWanted   = GenCon2Tag | GenTag2Con | GenMaxTag
-con2tag_PN :: TyCon -> ProtoName
-maxtag_PN :: TyCon -> ProtoName
-tag2con_PN :: TyCon -> ProtoName
-tcDeriving :: _PackedString -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> Bag InstInfo -> UniqFM TyCon -> [FixityDecl Name] -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult (Bag InstInfo, Binds Name (InPat Name), PprStyle -> Int -> Bool -> PrettyRep)
-
diff --git a/ghc/compiler/typecheck/TcDeriv.lhs b/ghc/compiler/typecheck/TcDeriv.lhs
index 50af23ca51..253bb98bc2 100644
--- a/ghc/compiler/typecheck/TcDeriv.lhs
+++ b/ghc/compiler/typecheck/TcDeriv.lhs
@@ -5,57 +5,56 @@
 
 Handles @deriving@ clauses on @data@ declarations.
 
-********** Don't forget
-
-Multi-instance checking in renamer should include deriving.
-
 \begin{code}
 #include "HsVersions.h"
 
 module TcDeriv (
-	tcDeriving,
-	con2tag_PN, tag2con_PN, maxtag_PN,
-	TagThingWanted(..), DerivEqn(..)
+	tcDeriving
     ) where
 
-IMPORT_Trace		-- ToDo:rm debugging
-import Outputable
-import Pretty
+import Ubiq
+
+import HsSyn		( FixityDecl, Sig, HsBinds(..), Bind(..), MonoBinds(..),
+			  GRHSsAndBinds, Match, HsExpr, HsLit, InPat,
+			  ArithSeqInfo, Fake, MonoType )
+import HsPragmas	( InstancePragmas(..) )
+import RnHsSyn		( RenamedHsBinds(..), RenamedFixityDecl(..) )
+import TcHsSyn		( TcIdOcc )
+
+import TcMonad
+import Inst		( InstOrigin(..), InstanceMapper(..) )
+import TcEnv		( getEnv_TyCons )
+import TcGenDeriv	-- Deriv stuff
+import TcInstUtil	( InstInfo(..), mkInstanceRelatedIds, buildInstanceEnvs )
+import TcSimplify	( tcSimplifyThetas )
 
-import TcMonad		-- typechecking monad machinery
-import TcMonadFns	( copyTyVars )
-import AbsSyn		-- the stuff being typechecked
-import TcGenDeriv	-- support code that generates all the grimy bindings
-			-- for derived instance decls.
-
-import AbsPrel		( mkFunTy )
-import AbsUniType
-import UniType		( UniType(..) ) -- *********** CHEATING!!! ****************
-import Bag
-import CE		( CE(..) )
-import CmdLineOpts	( GlobalSwitch(..) )
-import E		( E )
-import Errors
-import HsCore		-- ****** NEED TO SEE CONSTRUCTORS ******
-import HsPragmas	-- InstancePragmas(..)
-import Id		( getDataConSig, isNullaryDataCon, DataCon(..) )
-import IdInfo
-import Inst		( InstOrigin(..) )
-import InstEnv
+import RnMonad4
+import RnUtils		( GlobalNameMappers(..), GlobalNameMapper(..) )
+import RnBinds4		( rnMethodBinds, rnTopBinds )
+
+import Bag		( Bag, isEmptyBag, unionBags, listToBag )
+import Class		( GenClass, getClassKey )
+import ErrUtils		( pprBagOfErrors, addErrLoc, TcError(..) )
+import Id		( getDataConSig, getDataConArity )
 import Maybes		( assocMaybe, maybeToBool, Maybe(..) )
-import NameTypes	( mkFullName, mkPreludeCoreName,
-			  Provenance(..), FullName, ShortName
-			)
+import Name		( Name(..) )
+import NameTypes	( mkPreludeCoreName, Provenance(..) )
+import Outputable
+import PprType		( GenType, GenTyVar, GenClass, TyCon )
+import PprStyle
+import Pretty
 import ProtoName	( eqProtoName, ProtoName(..), Name )
-import RenameAuxFuns	-- why not? take all of it...
-import RenameBinds4	( rnMethodBinds4, rnTopBinds4 )
-import RenameMonad4	-- initRn4, etc.
 import SrcLoc		( mkGeneratedSrcLoc, mkUnknownSrcLoc, SrcLoc )
-import TCE		-- ( rngTCE, TCE(..), UniqFM )
-import TcInstDcls	( InstInfo(..), buildInstanceEnvs, mkInstanceRelatedIds )
-import TcSimplify	( tcSimplifyThetas )
-import Unique		-- *Key stuff
-import Util
+import TyCon		( getTyConTyVars, getTyConDataCons, getTyConDerivings,
+			  maybeTyConSingleCon, isEnumerationTyCon, TyCon )
+import Type		( GenType(..), TauType(..), mkTyVarTy, applyTyCon,
+			  mkSigmaTy, mkDictTy, isPrimType, instantiateTy,
+			  getAppTyCon, getAppDataTyCon )
+import TyVar		( GenTyVar )
+import UniqFM		( eltsUFM )
+import Unique		-- Keys stuff
+import Util		( zipWithEqual, zipEqual, sortLt, removeDups, 
+			  thenCmp, cmpList, panic, pprPanic, pprPanic# )
 \end{code}
 
 %************************************************************************
@@ -66,8 +65,8 @@ import Util
 
 Consider
 
-	data T a b = C1 (Foo a) (Bar b) 
-		   | C2 Int (T b a) 
+	data T a b = C1 (Foo a) (Bar b)
+		   | C2 Int (T b a)
 		   | C3 (T a a)
 		   deriving (Eq)
 
@@ -122,10 +121,10 @@ Next iteration:
 		   u Eq (T a a)			-- From C3
 
 	After simplification:
-		   = Eq a u Ping b 
+		   = Eq a u Ping b
 		   u (Eq b u Ping a)
 		   u (Eq a u Ping a)
-		
+
 		   = Eq a u Ping b u Eq b u Ping a
 
 The next iteration gives the same result, so this is the fixpoint.  We
@@ -157,25 +156,24 @@ type DerivSoln = DerivRhs
 
 \begin{code}
 tcDeriving  :: FAST_STRING		-- name of module under scrutiny
-	    -> GlobalNameFuns		-- for "renaming" bits of generated code
+	    -> GlobalNameMappers	-- for "renaming" bits of generated code
 	    -> Bag InstInfo		-- What we already know about instances
-	    -> TCE			-- All known TyCon info
-	    -> [RenamedFixityDecl]	-- Fixity info; may be used for Text
-	    -> TcM (Bag InstInfo,	-- The generated "instance decls".
-		    RenamedBinds,	-- Extra generated bindings
-		    PprStyle -> Pretty)	-- Printable derived instance decls;
-				     	-- for debugging via -ddump-derivings.
-
-tcDeriving modname renamer_name_funs inst_decl_infos_in tce fixities
-  =	-- Fish the "deriving"-related information out of the TCE,
-	-- from which we make the necessary "equations".
-    makeDerivEqns tce	    `thenTc` \ eqns ->
+	    -> [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 renamer_name_funs inst_decl_infos_in fixities
+  =	-- Fish the "deriving"-related information out of the TcEnv
+	-- and make the necessary "equations".
+    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 modname inst_decl_infos_in eqns
-			    `thenTc` \ new_inst_infos ->
+			    	`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
@@ -183,7 +181,7 @@ tcDeriving modname renamer_name_funs inst_decl_infos_in tce fixities
 	-- "con2tag" and/or "tag2con" functions.  We do these
 	-- separately.
 
-    gen_taggery_Names eqns			  `thenTc` \ nm_alist_etc ->
+    gen_taggery_Names eqns	`thenTc` \ nm_alist_etc ->
     let
 	nm_alist = [ (pn, n) | (pn,n,_,_) <- nm_alist_etc ]
 
@@ -201,8 +199,8 @@ tcDeriving modname renamer_name_funs inst_decl_infos_in tce fixities
 	deriver_name_funs = (deriv_val_gnf, rn_tc_gnf)
 
 	assoc_maybe [] _ = Nothing
-	assoc_maybe ((v,xxx) : vs) key
-	   = if v `eqProtoName` key then Just xxx else assoc_maybe vs key
+	assoc_maybe ((k,v) : vs) key
+	  = if k `eqProtoName` key then Just v else assoc_maybe vs key
     in
     gen_tag_n_con_binds deriver_name_funs nm_alist_etc `thenTc` \ extra_binds ->
 
@@ -213,14 +211,13 @@ tcDeriving modname renamer_name_funs inst_decl_infos_in tce fixities
 	      extra_binds,
 	      ddump_deriving really_new_inst_infos extra_binds)
   where
-    ddump_deriving :: [InstInfo] -> RenamedBinds -> (PprStyle -> Pretty)
+    ddump_deriving :: [InstInfo] -> RenamedHsBinds -> (PprStyle -> Pretty)
 
     ddump_deriving inst_infos extra_binds sty
-      = ppAboves ((map (pp_1 sty) inst_infos) ++ [ppr sty extra_binds])
+      = ppAboves ((map pp_info inst_infos) ++ [ppr sty extra_binds])
       where
-        pp_1 sty (InstInfo clas tv_tmpls ty inst_decl_theta _ _ _ mbinds _ _ _ _)
-	  = ppAbove (ppr sty (mkSigmaTy tv_tmpls inst_decl_theta 
-				  (UniDict clas ty)))
+	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}
 
@@ -247,20 +244,19 @@ or} has just one data constructor (e.g., tuples).
 all those.
 
 \begin{code}
-makeDerivEqns :: TCE -> TcM [DerivEqn]
+makeDerivEqns :: TcM s [DerivEqn]
 
-makeDerivEqns tce
-  = let
-	think_about_deriving = need_deriving (rngTCE tce)
+makeDerivEqns
+  = tcGetEnv `thenNF_Tc` \ env ->
+    let
+	tycons = eltsUFM (getEnv_TyCons env)
+	think_about_deriving = need_deriving tycons
     in
     mapTc (chk_out think_about_deriving) think_about_deriving `thenTc_`
-
-    let 
-	(derive_these, _) = removeDups cmp think_about_deriving 
+    let
+	(derive_these, _) = removeDups cmp_deriv think_about_deriving
+	eqns = map mk_eqn derive_these
     in
-
-    listNF_Tc (map mk_eqn derive_these)		`thenNF_Tc` \ eqns ->
-
     returnTc eqns
   where
     ------------------------------------------------------------------
@@ -273,18 +269,13 @@ makeDerivEqns tce
 		     [] -> acc
 		     cs -> [ (clas,tycon) | clas <- cs ] ++ acc
 	      )
-	      []		-- init accumulator
+	      []
 	      tycons_to_consider
 
     ------------------------------------------------------------------
-    chk_out :: [(Class, TyCon)] -> (Class, TyCon) -> TcM ()
-
+    chk_out :: [(Class, TyCon)] -> (Class, TyCon) -> TcM s ()
     chk_out whole_deriving_list this_one@(clas, tycon)
-      =	    -- Are the relevant superclasses catered for?
-	    -- E.g., for "... deriving Ord", is there an
-	    -- instance of "Eq"?
-	let
-	    (_, super_classes, _) = getClassSig clas
+      =	let
 	    clas_key = getClassKey clas
     	in
 
@@ -294,45 +285,37 @@ makeDerivEqns tce
 
 	    -- Are things OK for deriving Ix (if appropriate)?
 	checkTc (clas_key == ixClassKey
-	     && not (isEnumerationTyCon tycon
-	          || maybeToBool (maybeSingleConstructorTyCon tycon)))
+	         && not (isEnumerationTyCon tycon
+		         || maybeToBool (maybeTyConSingleCon tycon)))
 		(derivingIxErr tycon)
 
     ------------------------------------------------------------------
-    cmp :: (Class, TyCon) -> (Class, TyCon) -> TAG_
-
-    cmp (c1, t1) (c2, t2)
-      = case cmpClass c1 c2 of
-	  EQ_   -> cmpTyCon t1 t2
-	  other -> other
+    cmp_deriv :: (Class, TyCon) -> (Class, TyCon) -> TAG_
+    cmp_deriv (c1, t1) (c2, t2)
+      = (c1 `cmp` c2) `thenCmp` (t1 `cmp` t2)
 
     ------------------------------------------------------------------
-    mk_eqn :: (Class, TyCon) -> NF_TcM DerivEqn
-	-- we swizzle the tyvars, data cons, etc., out of the tycon,
+    mk_eqn :: (Class, TyCon) -> DerivEqn
+	-- we swizzle the tyvars and datacons out of the tycon
 	-- to make the rest of the equation
 
     mk_eqn (clas, tycon)
-      = let
-	    tyvar_tmpls	 = getTyConTyVarTemplates tycon
-	    data_cons	 = getTyConDataCons tycon
-        in
-	copyTyVars tyvar_tmpls	`thenNF_Tc` \ (_, tyvars, tyvar_tys) ->
-
-	let 
-	    constraints = concat [mk_constraints tyvar_tys con | con <- data_cons]
-	in
-	returnNF_Tc (clas, tycon, tyvars, constraints)
+      = (clas, tycon, tyvars, constraints)
       where
-	mk_constraints tyvar_tys data_con 
+	tyvars    = getTyConTyVars tycon	-- ToDo: Do we need new tyvars ???
+	tyvar_tys = map mkTyVarTy tyvars
+	data_cons = getTyConDataCons tycon
+	constraints = concat (map mk_constraints data_cons)
+
+	mk_constraints data_con
 	   = [ (clas, instantiateTy inst_env arg_ty)
 	     | arg_ty <- arg_tys,
 	       not (isPrimType arg_ty)	-- No constraints for primitive types
 	     ]
 	   where
-	     (con_tyvar_tmpls, _, arg_tys, _) = getDataConSig data_con
-	     inst_env = con_tyvar_tmpls `zipEqual` tyvar_tys
-			-- Type vars in data contructor should be same in number
-			-- as in the type contsructor!
+	     (con_tyvars, _, arg_tys, _) = getDataConSig data_con
+	     inst_env = con_tyvars `zipEqual` tyvar_tys
+	                -- same number of tyvars in data constr and type constr!
 \end{code}
 
 %************************************************************************
@@ -341,7 +324,7 @@ makeDerivEqns tce
 %*									*
 %************************************************************************
 
-A ``solution'' (to one of the equations) is a list of (k,UniTyVar tv)
+A ``solution'' (to one of the equations) is a list of (k,TyVarTy tv)
 terms, which is the final correct RHS for the corresponding original
 equation.
 \begin{itemize}
@@ -358,8 +341,8 @@ ordered by sorting on type varible, tv, (major key) and then class, k,
 \begin{code}
 solveDerivEqns :: FAST_STRING
 	       -> Bag InstInfo
-	       -> [DerivEqn] 
-	       -> TcM [InstInfo]	-- Solns in same order as eqns.
+	       -> [DerivEqn]
+	       -> TcM s [InstInfo]	-- Solns in same order as eqns.
 				  	-- This bunch is Absolutely minimal...
 
 solveDerivEqns modname inst_decl_infos_in orig_eqns
@@ -375,10 +358,10 @@ solveDerivEqns modname inst_decl_infos_in orig_eqns
 	-- compares it with the current one; finishes if they are the
 	-- same, otherwise recurses with the new solutions.
 
-    iterateDeriv :: [DerivSoln] ->TcM [InstInfo]
+    iterateDeriv :: [DerivSoln] ->TcM s [InstInfo]
 
     iterateDeriv current_solns
-      =	    -- Extend the inst info from the explicit instance decls 
+      =	    -- Extend the inst info from the explicit instance decls
 	    -- with the current set of solutions, giving a
 
 	add_solns modname inst_decl_infos_in orig_eqns current_solns
@@ -388,11 +371,9 @@ solveDerivEqns modname inst_decl_infos_in orig_eqns
 	    -- inst_mapper reflecting the previous solution
 	let
 	    mk_deriv_origin clas ty
-	      = DerivingOrigin inst_mapper clas is_fun_type tycon locn
+	      = DerivingOrigin inst_mapper clas tycon
 	      where
-		is_fun_type = isFunType ty
-		(tycon,_,_) = getUniDataTyCon ty
-		locn = if is_fun_type then mkUnknownSrcLoc{-sigh-} else getSrcLoc tycon
+		(tycon,_) = getAppTyCon ty
 	in
 	listTc [ tcSimplifyThetas mk_deriv_origin rhs
 	       | (_, _, _, rhs) <- orig_eqns
@@ -400,76 +381,60 @@ solveDerivEqns modname inst_decl_infos_in orig_eqns
 
 	    -- Canonicalise the solutions, so they compare nicely
 	let canonicalised_next_solns
-	      = [ sortLt less_than next_soln | next_soln <- next_solns ] in
+	      = [ sortLt lt_rhs next_soln | next_soln <- next_solns ] in
 
-	if current_solns == canonicalised_next_solns then
-	  returnTc new_inst_infos
-        else
-	  iterateDeriv canonicalised_next_solns
+	if current_solns `eq_solns` canonicalised_next_solns then
+	    returnTc new_inst_infos
+	else
+	    iterateDeriv canonicalised_next_solns
 
       where
 	------------------------------------------------------------------
-	less_than :: (Class, TauType) -> (Class, TauType) -> Bool
-
-	less_than (clas1, UniTyVar tv1) (clas2, UniTyVar tv2)
-	  = tv1 < tv2 || (tv1 == tv2 && clas1 < clas2)
+	lt_rhs    r1 r2 = case cmp_rhs   r1 r2 of { LT_ -> True; _ -> False }
+        eq_solns  s1 s2 = case cmp_solns s1 s2 of { EQ_ -> True; _ -> False }
+	cmp_solns s1 s2 = cmpList (cmpList cmp_rhs) s1 s2
+	cmp_rhs (c1, TyVarTy tv1) (c2, TyVarTy tv2)
+	  = (tv1 `cmp` tv2) `thenCmp` (c1 `cmp` c2)
 #ifdef DEBUG
-	less_than other_1 other_2
-	  = pprPanic "tcDeriv:less_than:" (ppCat [ppr PprDebug other_1, ppr PprDebug other_2])
+	cmp_rhs other_1 other_2
+	  = pprPanic# "tcDeriv:cmp_rhs:" (ppCat [ppr PprDebug other_1, ppr PprDebug other_2])
 #endif
+
 \end{code}
 
 \begin{code}
 add_solns :: FAST_STRING
 	  -> Bag InstInfo			-- The global, non-derived ones
 	  -> [DerivEqn] -> [DerivSoln]
-	  -> TcM ([InstInfo], 			-- The new, derived ones
-		  InstanceMapper)
+	  -> TcM s ([InstInfo], 		-- The new, derived ones
+		    InstanceMapper)
     -- the eqns and solns move "in lockstep"; we have the eqns
     -- because we need the LHS info for addClassInstance.
 
 add_solns modname inst_infos_in eqns solns
-  = listTc (zipWith mk_deriv_inst_info eqns solns) `thenTc` \ new_inst_infos ->
-
-    buildInstanceEnvs (inst_infos_in `unionBags` 
-		       listToBag new_inst_infos) `thenTc` \ inst_mapper ->
-
+  = buildInstanceEnvs all_inst_infos `thenTc` \ inst_mapper ->
     returnTc (new_inst_infos, inst_mapper)
   where
-    mk_deriv_inst_info (clas, tycon, tyvars, _) theta
-	-- The complication here is rather boring: InstInfos need TyVarTemplates,
-	-- and we have only TyVars in our hand.
-      = let
-	    tyvar_tmpls 	= mkTemplateTyVars tyvars
-	    tv_tmpl_tys 	= map mkTyVarTemplateTy tyvar_tmpls
-
-	    env			= tyvars `zipEqual` tv_tmpl_tys
-	   
-	    tycon_tmpl_ty	= applyTyCon tycon tv_tmpl_tys
-	    theta_tmpl		= [(clas, mapOverTyVars to_tmpl ty) | (clas,ty) <- theta]
+    new_inst_infos = zipWithEqual mk_deriv_inst_info eqns solns
 
-	    to_tmpl = assoc "mk_deriv_inst_info" env
+    all_inst_infos = inst_infos_in `unionBags` listToBag new_inst_infos
 
-	    (class_tyvar, super_classes, _, class_ops, _, _) = getClassBigSig clas
-	in
-	returnTc (
-	  InstInfo clas tyvar_tmpls tycon_tmpl_ty 
-		theta_tmpl
-		theta_tmpl		-- Blarg.  This is the dfun_theta slot,
+    mk_deriv_inst_info (clas, tycon, tyvars, _) theta
+      = InstInfo clas tyvars (applyTyCon tycon (map mkTyVarTy tyvars))
+		 theta
+		 theta			-- Blarg.  This is the dfun_theta slot,
 					-- which is needed by buildInstanceEnv;
 					-- This works ok for solving the eqns, and
-					-- gen_eqns sets it to its final value	
+					-- gen_eqns sets it to its final value
 					-- (incl super class dicts) before we
 					-- finally return it.
-#ifndef DEBUG
-		(panic "add_soln:dfun_id") (panic "add_soln:const_meth_ids")
-		(panic "add_soln:binds")   (panic "add_soln:from_here")
-		(panic "add_soln:modname") mkGeneratedSrcLoc
-		(panic "add_soln:upragmas")
-	)
+#ifdef DEBUG
+		 (panic "add_soln:dfun_id") (panic "add_soln:const_meth_ids")
+		 (panic "add_soln:binds")   (panic "add_soln:from_here")
+		 (panic "add_soln:modname") mkGeneratedSrcLoc
+		 (panic "add_soln:upragmas")
 #else
 		bottom bottom bottom bottom bottom mkGeneratedSrcLoc bottom
-	)
       where
 	bottom = panic "add_soln"
 #endif
@@ -543,68 +508,60 @@ the renamer.  What a great hack!
 gen_inst_info :: FAST_STRING		-- Module name
 	      -> [RenamedFixityDecl]	-- all known fixities;
 					-- may be needed for Text
-	      -> GlobalNameFuns		-- lookup stuff for names we may use
+	      -> GlobalNameMappers		-- lookup stuff for names we may use
 	      -> InstInfo		-- the main stuff to work on
-	      -> TcM InstInfo		-- the gen'd (filled-in) "instance decl"
+	      -> TcM s InstInfo		-- the gen'd (filled-in) "instance decl"
 
 gen_inst_info modname fixities deriver_name_funs
-    info@(InstInfo clas tyvar_tmpls ty inst_decl_theta _ _ _ _ _ _ locn _)
-  = 
+    info@(InstInfo clas tyvars ty inst_decl_theta _ _ _ _ _ _ locn _)
+  =
 	-- Generate the various instance-related Ids
     mkInstanceRelatedIds
-		(panic "add_solns:E")
-			-- These two are only needed if there are pragmas to typecheck;
-			-- but there ain't since we are generating the code right here.
-		True {-yes, from_here-}
-		modname
+		True {-from_here-} modname
 		NoInstancePragmas
-		mkGeneratedSrcLoc
-		clas
-		tyvar_tmpls ty
+		clas tyvars ty
 		inst_decl_theta
 		[{-no user pragmas-}]
 			`thenTc` \ (dfun_id, dfun_theta, const_meth_ids) ->
 
-	-- Generate the bindings for the new instance declaration, 
+	-- Generate the bindings for the new instance declaration,
 	-- rename it, and check for errors
-    getSwitchCheckerTc	`thenNF_Tc` \ sw_chkr ->
     let
-	(tycon,_,_)  = getUniDataTyCon ty
-
-	omit_readsPrec = sw_chkr OmitDerivedRead
+	(tycon,_,_)  = getAppDataTyCon ty
 
 	proto_mbinds
-	  = if	    clas_key == textClassKey	then gen_Text_binds fixities omit_readsPrec tycon
-	    else if clas_key == eqClassKey     	then gen_Eq_binds tycon
-	    else if clas_key == ordClassKey 	then gen_Ord_binds tycon
-	    else if clas_key == enumClassKey	then gen_Enum_binds tycon
-	    else if clas_key == ixClassKey	then gen_Ix_binds tycon
-	    else if clas_key == binaryClassKey  then gen_Binary_binds tycon
-	    else panic "gen_inst_info:bad derived class"
+	  | clas_key == eqClassKey     = gen_Eq_binds tycon
+	  | clas_key == showClassKey   = gen_Show_binds fixities tycon
+	  | clas_key == ordClassKey    = gen_Ord_binds tycon
+	  | clas_key == enumClassKey   = gen_Enum_binds tycon
+	  | clas_key == ixClassKey     = gen_Ix_binds tycon
+	  | clas_key == readClassKey   = gen_Read_binds fixities tycon
+	  | clas_key == binaryClassKey = gen_Binary_binds tycon
+	  | otherwise = panic "gen_inst_info:bad derived class"
     in
     rn4MtoTcM deriver_name_funs (
-	rnMethodBinds4 clas_Name proto_mbinds
+	rnMethodBinds clas_Name proto_mbinds
     )			`thenNF_Tc` \ (mbinds, errs) ->
 
     if not (isEmptyBag errs) then
-	pprPanic "gen_inst_info:renamer errs!\n" (ppAbove (pprBagOfErrors PprDebug errs) (ppr PprDebug proto_mbinds))
+	pprPanic "gen_inst_info:renamer errs!\n"
+		 (ppAbove (pprBagOfErrors PprDebug errs) (ppr PprDebug proto_mbinds))
     else
---  pprTrace "derived binds:" (ppr PprDebug proto_mbinds) $
+    --pprTrace "derived binds:" (ppr PprDebug proto_mbinds) $
 
 	-- All done
-    let 
+    let
 	from_here = isLocallyDefined tycon	-- If so, then from here
     in
-    returnTc (InstInfo clas tyvar_tmpls ty 
-		       inst_decl_theta dfun_theta dfun_id const_meth_ids
-		       -- and here comes the main point...
+    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 [])
   where
     clas_key = getClassKey clas
     clas_Name
       = let  (mod, nm) = getOrigName clas  in
-    	PreludeClass clas_key (mkPreludeCoreName mod nm)
+    	ClassName clas_key (mkPreludeCoreName mod nm) []
 \end{code}
 
 %************************************************************************
@@ -620,9 +577,9 @@ tag2con_Foo :: Int -> Foo ...	-- easier if Int, not Int#
 maxtag_Foo  :: Int		-- ditto (NB: not unboxed)
 
 \begin{code}
-gen_tag_n_con_binds :: GlobalNameFuns
+gen_tag_n_con_binds :: GlobalNameMappers
 		    -> [(ProtoName, Name, TyCon, TagThingWanted)]
-		    -> TcM RenamedBinds
+		    -> TcM s RenamedHsBinds
 
 gen_tag_n_con_binds deriver_name_funs nm_alist_etc
   = let
@@ -631,7 +588,7 @@ gen_tag_n_con_binds deriver_name_funs nm_alist_etc
     in
 
     rn4MtoTcM deriver_name_funs (
-	rnTopBinds4 (SingleBind (RecBind proto_mbinds))
+	rnTopBinds (SingleBind (RecBind proto_mbinds))
     )			`thenNF_Tc` \ (binds, errs) ->
 
     if not (isEmptyBag errs) then
@@ -665,31 +622,29 @@ We're deriving @Enum@, or @Ix@ (enum type only???)
 If we have a @tag2con@ function, we also generate a @maxtag@ constant.
 
 \begin{code}
-data TagThingWanted
-  = GenCon2Tag | GenTag2Con | GenMaxTag
-
 gen_taggery_Names :: [DerivEqn]
-		  -> TcM [(ProtoName, Name,	-- for an assoc list
-		  	   TyCon,		-- related tycon
-			   TagThingWanted)]
+		  -> TcM s [(ProtoName, Name,	-- for an assoc list
+		  	     TyCon,		-- related tycon
+			     TagThingWanted)]
 
 gen_taggery_Names eqns
-  = let all_tycons = [ tc | (_, tc, _, _) <- eqns ]
-	(tycons_of_interest, _) = removeDups cmpTyCon all_tycons
+  = let
+	all_tycons = [ tc | (_, tc, _, _) <- eqns ]
+	(tycons_of_interest, _) = removeDups cmp all_tycons
     in
 	foldlTc do_con2tag []           tycons_of_interest `thenTc` \ names_so_far ->
 	foldlTc do_tag2con names_so_far tycons_of_interest
   where
     do_con2tag acc_Names tycon
       = if (we_are_deriving eqClassKey tycon
-	    && any isNullaryDataCon (getTyConDataCons tycon))
+	    && any ( (== 0).getDataConArity ) (getTyConDataCons tycon))
 	|| (we_are_deriving ordClassKey  tycon
-	    && not (maybeToBool (maybeSingleConstructorTyCon tycon)))
+	    && not (maybeToBool (maybeTyConSingleCon tycon)))
 	|| (we_are_deriving enumClassKey tycon)
 	|| (we_are_deriving ixClassKey   tycon)
 	then
-	  getUniqueTc	`thenNF_Tc` ( \ u ->
-	  returnTc ((con2tag_PN tycon, OtherTopId u (con2tag_FN tycon), tycon, GenCon2Tag)
+	  tcGetUnique	`thenNF_Tc` ( \ u ->
+	  returnTc ((con2tag_PN tycon, ValName u (con2tag_FN tycon), tycon, GenCon2Tag)
 		   : acc_Names) )
 	else
 	  returnTc acc_Names
@@ -698,10 +653,10 @@ gen_taggery_Names eqns
       = if (we_are_deriving enumClassKey tycon)
 	|| (we_are_deriving ixClassKey   tycon)
 	then
-	  getUniqueTc	`thenNF_Tc` \ u1 ->
-	  getUniqueTc	`thenNF_Tc` \ u2 ->
-	  returnTc ( (tag2con_PN tycon, OtherTopId u1 (tag2con_FN tycon), tycon, GenTag2Con)
-		   : (maxtag_PN  tycon, OtherTopId u2 (maxtag_FN  tycon), tycon, GenMaxTag)
+	  tcGetUnique	`thenNF_Tc` \ u1 ->
+	  tcGetUnique	`thenNF_Tc` \ u2 ->
+	  returnTc ( (tag2con_PN tycon, ValName u1 (tag2con_FN tycon), tycon, GenTag2Con)
+		   : (maxtag_PN  tycon, ValName u2 (maxtag_FN  tycon), tycon, GenMaxTag)
 		   : acc_Names)
 	else
 	  returnTc acc_Names
@@ -710,46 +665,20 @@ gen_taggery_Names eqns
       = is_in_eqns clas_key tycon eqns
       where
 	is_in_eqns clas_key tycon [] = False
-	is_in_eqns clas_key tycon ((c,t,_,_):eqns) -- ToDo: InstInfo
+	is_in_eqns clas_key tycon ((c,t,_,_):eqns)
 	  =  (clas_key == getClassKey c && tycon == t)
 	  || is_in_eqns clas_key tycon eqns
 
-con2tag_PN, tag2con_PN, maxtag_PN :: TyCon -> ProtoName
-con2tag_FN, tag2con_FN, maxtag_FN :: TyCon -> FullName
-
-con2tag_PN tycon
-  = let	(mod, nm) = getOrigName tycon
-	con2tag	  = SLIT("con2tag_") _APPEND_ nm _APPEND_ SLIT("#")
-    in
-    Imp mod con2tag [mod] con2tag
-
-con2tag_FN tycon
-  = let	(mod, nm) = getOrigName tycon
-	con2tag	  = SLIT("con2tag_") _APPEND_ nm _APPEND_ SLIT("#")
-    in
-    mkFullName mod con2tag InventedInThisModule NotExported mkGeneratedSrcLoc
-
-tag2con_PN tycon
-  = let	(mod, nm) = getOrigName tycon
-	tag2con	  = SLIT("tag2con_") _APPEND_ nm _APPEND_ SLIT("#")
-    in
-    Imp mod tag2con [mod] tag2con
-
-tag2con_FN tycon
-  = let	(mod, nm) = getOrigName tycon
-	tag2con	  = SLIT("tag2con_") _APPEND_ nm _APPEND_ SLIT("#")
-    in
-    mkFullName mod tag2con InventedInThisModule NotExported mkGeneratedSrcLoc
-
-maxtag_PN tycon
-  = let	(mod, nm) = getOrigName tycon
-	maxtag	  = SLIT("maxtag_") _APPEND_ nm _APPEND_ SLIT("#")
-    in
-    Imp mod maxtag [mod] maxtag
+\end{code}
 
-maxtag_FN tycon
-  = let	(mod, nm) = getOrigName tycon
-	maxtag	  = SLIT("maxtag_") _APPEND_ nm _APPEND_ SLIT("#")
-    in
-    mkFullName mod maxtag InventedInThisModule NotExported mkGeneratedSrcLoc
+\begin{code}
+derivingEnumErr :: TyCon -> TcError
+derivingEnumErr tycon
+  = addErrLoc (getSrcLoc tycon) "Can't derive an instance of `Enum'" ( \ sty ->
+    ppBesides [ppStr "type `", ppr sty tycon, ppStr "'"] )
+
+derivingIxErr :: TyCon -> TcError
+derivingIxErr tycon
+  = addErrLoc (getSrcLoc tycon) "Can't derive an instance of `Ix'" ( \ sty ->
+    ppBesides [ppStr "type `", ppr sty tycon, ppStr "'"] )
 \end{code}
diff --git a/ghc/compiler/typecheck/TcEnv.lhs b/ghc/compiler/typecheck/TcEnv.lhs
new file mode 100644
index 0000000000..c2b831dcaa
--- /dev/null
+++ b/ghc/compiler/typecheck/TcEnv.lhs
@@ -0,0 +1,289 @@
+\begin{code}
+#include "HsVersions.h"
+
+module TcEnv(
+	TcEnv, 
+
+	initEnv, getEnv_LocalIds, getEnv_TyCons, getEnv_Classes,
+	
+	tcExtendKindEnv, tcExtendTyVarEnv, tcExtendTyConEnv, tcExtendClassEnv,
+	tcLookupTyVar, tcLookupTyCon, tcLookupClass, tcLookupClassByKey,
+
+	tcExtendGlobalValEnv, tcExtendLocalValEnv,
+	tcLookupLocalValue, tcLookupLocalValueOK,
+	tcLookupGlobalValue, tcLookupGlobalValueByKey,
+
+	tcTyVarScope, newMonoIds, newLocalIds,
+	tcGetGlobalTyVars
+  ) where
+
+
+import Ubiq
+import TcMLoop  -- for paranoia checking
+
+import Id	( Id(..), GenId, idType, mkUserLocal )
+import TcHsSyn	( TcIdBndr(..) )
+import TcKind	( TcKind, newKindVars, tcKindToKind, kindToTcKind )
+import TcType	( TcType(..), TcMaybe, TcTyVar(..), TcTyVarSet(..), newTyVarTys, zonkTcTyVars )
+import TyVar	( mkTyVar, getTyVarKind, unionTyVarSets, emptyTyVarSet )
+import Type	( tyVarsOfTypes )
+import TyCon	( TyCon, getTyConKind )
+import Class	( Class(..), GenClass, getClassSig )
+
+import TcMonad
+
+import Name	( Name(..), getNameShortName )
+import PprStyle
+import Pretty
+import Unique	( Unique )
+import UniqFM
+import Util	( zipWithEqual, zipWith3Equal, zipLazy, panic )
+\end{code}
+
+Data type declarations
+~~~~~~~~~~~~~~~~~~~~~
+
+\begin{code}
+data TcEnv s = TcEnv
+		  (TyVarEnv s)
+		  (ValueEnv Id)			-- Globals
+		  (ValueEnv (TcIdBndr s))	-- Locals
+		  (MutableVar s (TcTyVarSet s))	-- Free type variables of locals
+						-- ...why mutable? see notes with tcGetGlobalTyVars
+		  (KindEnv s) 			-- Gives TcKinds of TyCons and Classes
+		  TyConEnv
+		  ClassEnv
+
+type TyVarEnv s  = UniqFM (TcKind s, TyVar)
+type TyConEnv    = UniqFM TyCon
+type KindEnv s   = UniqFM (TcKind s)
+type ClassEnv    = UniqFM Class
+type ValueEnv id = UniqFM id
+
+initEnv :: MutableVar s (TcTyVarSet s) -> TcEnv s
+initEnv mut = TcEnv emptyUFM emptyUFM emptyUFM mut emptyUFM emptyUFM emptyUFM 
+
+getEnv_LocalIds (TcEnv _ _ ls _ _ _ _) = ls
+getEnv_TyCons   (TcEnv _ _ _ _ _ ts _) = ts
+getEnv_Classes  (TcEnv _ _ _ _ _ _ cs) = cs
+\end{code}
+
+Making new TcTyVars, with knot tying!
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+\begin{code}
+tcTyVarScope :: [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
+  = newKindVars (length tyvar_names)	`thenNF_Tc` \ tyvar_kinds ->
+
+    fixTc (\ ~(tyvars, _) ->
+		-- Ok to look at kinds, but not tyvars!
+      tcExtendTyVarEnv tyvar_names (tyvar_kinds `zipLazy` tyvars) (
+
+		-- Do the thing inside
+	thing_inside tyvars			`thenTc` \ result ->
+ 
+		-- Get the tyvar's Kinds from their TcKinds
+	mapNF_Tc tcKindToKind tyvar_kinds	`thenNF_Tc` \ tyvar_kinds' ->
+
+		-- Construct the real TyVars
+	let
+	  tyvars	     = zipWithEqual mk_tyvar tyvar_names tyvar_kinds'
+	  mk_tyvar name kind = mkTyVar (getNameShortName name) (getItsUnique name) kind
+	in
+	returnTc (tyvars, result)
+    ))					`thenTc` \ (_,result) ->
+    returnTc result
+\end{code}
+
+
+The Kind, TyVar, Class and TyCon envs
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+Extending the environments
+
+\begin{code}
+tcExtendKindEnv :: [Name] -> [TcKind s] -> TcM s r -> TcM s r
+tcExtendKindEnv names kinds scope
+  = tcGetEnv		`thenNF_Tc` \ (TcEnv tve gve lve gtvs ke tce ce) ->
+    let
+	ke' = addListToUFM ke (names `zip` kinds)
+    in
+    tcSetEnv (TcEnv tve gve lve gtvs ke' tce ce) scope
+
+tcExtendTyVarEnv :: [Name] -> [(TcKind s, TyVar)] -> TcM s r -> TcM s r
+tcExtendTyVarEnv tyvar_names kinds_w_tyvars scope
+  = tcGetEnv		`thenNF_Tc` \ (TcEnv tve gve lve gtvs ke tce ce) ->
+    let
+	tve' = addListToUFM tve (tyvar_names `zip` kinds_w_tyvars)
+    in
+    tcSetEnv (TcEnv tve' gve lve gtvs ke tce ce) scope
+
+tcExtendTyConEnv tycons scope
+  = tcGetEnv		`thenNF_Tc` \ (TcEnv tve gve lve gtvs ke tce ce) ->
+    let
+	tce' = addListToUFM_Directly tce [(getItsUnique tycon, tycon) | tycon <- tycons]
+    in
+    tcSetEnv (TcEnv tve gve lve gtvs ke tce' ce) scope
+
+tcExtendClassEnv classes scope
+  = tcGetEnv		`thenNF_Tc` \ (TcEnv tve gve lve gtvs ke tce ce) ->
+    let
+	ce' = addListToUFM_Directly ce [(getItsUnique clas, clas) | clas <- classes]
+    in
+    tcSetEnv (TcEnv tve gve lve gtvs ke tce ce') scope
+\end{code}
+
+
+Looking up in the environments
+
+\begin{code}
+tcLookupTyVar name
+  = tcGetEnv		`thenNF_Tc` \ (TcEnv tve gve lve gtvs ke tce ce) ->
+    returnNF_Tc (lookupWithDefaultUFM tve (panic "tcLookupTyVar") name)
+
+
+tcLookupTyCon (WiredInTyCon tc)		-- wired in tycons
+  = returnNF_Tc (kindToTcKind (getTyConKind tc), tc)
+
+tcLookupTyCon name
+  = tcGetEnv		`thenNF_Tc` \ (TcEnv tve gve lve gtvs ke tce ce) ->
+    let
+	tycon = lookupWithDefaultUFM tce (panic "tcLookupTyCon")	     name
+	kind  = lookupWithDefaultUFM ke  (kindToTcKind (getTyConKind tycon)) name
+		-- The KE will bind tycon in the current mutually-recursive set.
+		-- If the KE doesn't, then the tycon is already defined, and we
+		-- can safely grab the kind from the TyCon itself
+    in
+    returnNF_Tc (kind,tycon)
+
+
+tcLookupClass name
+  = tcGetEnv		`thenNF_Tc` \ (TcEnv tve gve lve gtvs ke tce ce) ->
+    let
+	clas = lookupWithDefaultUFM ce (panic "tcLookupClass")	           name
+	(tyvar, _, _) = getClassSig clas
+	kind = lookupWithDefaultUFM ke (kindToTcKind (getTyVarKind tyvar)) name
+    in
+    returnNF_Tc (kind,clas)
+
+tcLookupClassByKey uniq
+  = tcGetEnv		`thenNF_Tc` \ (TcEnv tve gve lve gtvs ke tce ce) ->
+    let
+	clas = lookupWithDefaultUFM_Directly ce (panic "tcLookupClas") uniq
+    in
+    returnNF_Tc (clas)
+\end{code}
+
+
+
+Extending and consulting the value environment
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+\begin{code}
+tcExtendGlobalValEnv ids scope
+  = tcGetEnv		`thenNF_Tc` \ (TcEnv tve gve lve gtvs ke tce ce) ->
+    let
+	gve' = addListToUFM_Directly gve [(getItsUnique id, id) | id <- ids]
+    in
+    tcSetEnv (TcEnv tve gve' lve gtvs ke tce ce) scope
+
+tcExtendLocalValEnv names ids scope
+  = tcGetEnv		`thenNF_Tc` \ (TcEnv tve gve lve gtvs ke tce ce) ->
+    tcReadMutVar gtvs	`thenNF_Tc` \ global_tvs ->
+    let
+	lve' = addListToUFM lve (names `zip` ids)
+	extra_global_tyvars = tyVarsOfTypes (map idType ids)
+	new_global_tyvars   = global_tvs `unionTyVarSets` extra_global_tyvars
+    in
+    tcNewMutVar new_global_tyvars	`thenNF_Tc` \ gtvs' ->
+
+    tcSetEnv (TcEnv tve gve lve' gtvs' ke tce ce) scope
+\end{code}
+
+@tcGetGlobalTyVars@ returns a fully-zonked set of tyvars free in the environment.
+To improve subsequent calls to the same function it writes the zonked set back into
+the environment.
+
+\begin{code}
+tcGetGlobalTyVars :: NF_TcM s (TcTyVarSet s)
+tcGetGlobalTyVars
+  = tcGetEnv 				`thenNF_Tc` \ (TcEnv tve gve lve gtvs ke tce ce) ->
+    tcReadMutVar gtvs			`thenNF_Tc` \ global_tvs ->
+    zonkTcTyVars global_tvs		`thenNF_Tc` \ global_tvs' ->
+    tcWriteMutVar gtvs global_tvs'	`thenNF_Tc_`
+    returnNF_Tc global_tvs'
+\end{code}
+
+\begin{code}
+tcLookupLocalValue :: Name -> NF_TcM s (Maybe (TcIdBndr s))
+tcLookupLocalValue name
+  = tcGetEnv 		`thenNF_Tc` \ (TcEnv tve gve lve gtvs ke tce ce) ->
+    returnNF_Tc (lookupUFM lve name)
+
+tcLookupLocalValueOK :: String -> Name -> NF_TcM s (TcIdBndr s)
+tcLookupLocalValueOK err name
+  = tcGetEnv 		`thenNF_Tc` \ (TcEnv tve gve lve gtvs ke tce ce) ->
+    returnNF_Tc (lookupWithDefaultUFM lve (panic err) name)
+
+
+tcLookupGlobalValue :: Name -> NF_TcM s Id
+
+tcLookupGlobalValue (WiredInVal id)	-- wired in ids
+  = returnNF_Tc id
+
+tcLookupGlobalValue name
+  = tcGetEnv 		`thenNF_Tc` \ (TcEnv tve gve lve gtvs ke tce ce) ->
+    returnNF_Tc (lookupWithDefaultUFM gve def name)
+  where
+#ifdef DEBUG
+    def = panic ("tcLookupGlobalValue:" ++ ppShow 1000 (ppr PprDebug name))
+#else
+    def = panic "tcLookupGlobalValue"
+#endif
+
+
+tcLookupGlobalValueByKey :: Unique -> NF_TcM s Id
+tcLookupGlobalValueByKey uniq
+  = tcGetEnv 		`thenNF_Tc` \ (TcEnv tve gve lve gtvs ke tce ce) ->
+    returnNF_Tc (lookupWithDefaultUFM_Directly gve def uniq)
+  where
+#ifdef DEBUG
+    def = panic ("tcLookupGlobalValueByKey:" ++ ppShow 1000 (ppr PprDebug uniq))
+#else
+    def = panic "tcLookupGlobalValueByKey"
+#endif
+
+\end{code}
+
+
+Constructing new Ids
+~~~~~~~~~~~~~~~~~~~~
+
+\begin{code}
+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 mk_id names uniqs tys
+	mk_id name uniq ty = mkUserLocal (getOccurrenceName name) uniq ty
+					 (getSrcLoc name)
+    in
+    tcExtendLocalValEnv names new_ids (m new_ids)
+  where
+    no_of_names = length names
+
+newLocalIds :: [FAST_STRING] -> [TcType s] -> NF_TcM s [TcIdBndr s]
+newLocalIds names tys
+  = tcGetSrcLoc			`thenNF_Tc` \ loc ->
+    tcGetUniques (length names) `thenNF_Tc` \ uniqs ->
+    let
+	new_ids            = zipWith3Equal mk_id names uniqs tys
+	mk_id name uniq ty = mkUserLocal name uniq ty loc
+    in
+    returnNF_Tc new_ids
+\end{code}
+
+
diff --git a/ghc/compiler/typecheck/TcExpr.hi b/ghc/compiler/typecheck/TcExpr.hi
deleted file mode 100644
index cdef02634b..0000000000
--- a/ghc/compiler/typecheck/TcExpr.hi
+++ /dev/null
@@ -1,18 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface TcExpr where
-import Bag(Bag)
-import CmdLineOpts(GlobalSwitch)
-import E(E)
-import HsExpr(Expr)
-import HsPat(InPat, TypecheckedPat)
-import Id(Id)
-import LIE(LIE)
-import Name(Name)
-import Pretty(PprStyle, PrettyRep)
-import SplitUniq(SplitUniqSupply)
-import SrcLoc(SrcLoc)
-import Subst(Subst)
-import TcMonad(TcResult)
-import UniType(UniType)
-tcExpr :: E -> Expr Name (InPat Name) -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult (Expr Id TypecheckedPat, LIE, UniType)
-
diff --git a/ghc/compiler/typecheck/TcExpr.lhs b/ghc/compiler/typecheck/TcExpr.lhs
index 15b67291bd..f6fc5be286 100644
--- a/ghc/compiler/typecheck/TcExpr.lhs
+++ b/ghc/compiler/typecheck/TcExpr.lhs
@@ -1,63 +1,66 @@
 %
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
 %
-\section[TcExpr]{TcExpr}
+\section[TcExpr]{Typecheck an expression}
 
 \begin{code}
 #include "HsVersions.h"
 
-module TcExpr (
-	tcExpr
-#ifdef DPH
-	, tcExprs
-#endif
-    ) where
-
-import TcMonad		-- typechecking monad machinery
-import TcMonadFns	( newPolyTyVarTy, newOpenTyVarTy,
-			  newDict, newMethod, newOverloadedLit,
-			  applyTcSubstAndCollectTyVars,
-			  mkIdsWithPolyTyVarTys
-			)
-import AbsSyn		-- the stuff being typechecked
-
-
-import AbsPrel		( intPrimTy, charPrimTy, doublePrimTy,
-			  floatPrimTy, addrPrimTy, addrTy,
-			  boolTy, charTy, stringTy, mkFunTy, mkListTy,
-			  mkTupleTy, mkPrimIoTy
-#ifdef DPH
-			 ,mkProcessorTy, mkPodTy,toPodId,
-			  processorClass,pidClass
-#endif {- Data Parallel Haskell -}
-			)
-import AbsUniType
-import E
-import CE		( lookupCE )
-
-import Errors
-import GenSpecEtc	( checkSigTyVars )
-import Id		( mkInstId, getIdUniType, Id )
-import Inst
-import LIE		( nullLIE, unitLIE, plusLIE, unMkLIE, mkLIE, LIE )
-import ListSetOps	( unionLists )
-import Maybes		( Maybe(..) )
-import TVE		( nullTVE, TVE(..) )
-import Spec		( specId, specTy )
-import TcBinds		( tcLocalBindsAndThen )
+module TcExpr ( tcExpr ) where
+
+import Ubiq
+
+import HsSyn		( HsExpr(..), Qual(..), Stmt(..),
+			  HsBinds(..), Bind(..), MonoBinds(..), 
+			  ArithSeqInfo(..), HsLit(..), Sig, GRHSsAndBinds,
+			  Match, Fake, InPat, OutPat, PolyType,
+			  irrefutablePat, collectPatBinders )
+import RnHsSyn		( RenamedHsExpr(..), RenamedQual(..), RenamedStmt(..) )
+import TcHsSyn		( TcExpr(..), TcQual(..), TcStmt(..), TcIdOcc(..) )
+
+import TcMonad
+import Inst		( Inst, InstOrigin(..), OverloadedLit(..),
+			  LIE(..), emptyLIE, plusLIE, newOverloadedLit,
+			  newMethod, newMethodWithGivenTy, newDicts )
+import TcBinds		( tcBindsAndThen )
+import TcEnv		( tcLookupLocalValue, tcLookupGlobalValue, tcLookupClassByKey,
+			  tcLookupGlobalValueByKey, newMonoIds, tcGetGlobalTyVars )
 import TcMatches	( tcMatchesCase, tcMatch )
-import TcPolyType	( tcPolyType )
-import TcQuals		( tcQuals )
+import TcMonoType	( tcPolyType )
+import TcPat		( tcPat )
 import TcSimplify	( tcSimplifyAndCheck, tcSimplifyRank2 )
-#ifdef DPH
-import TcParQuals
-#endif {- Data Parallel Haskell -}
+import TcType		( TcType(..), TcMaybe(..), tcReadTyVar,
+			  tcInstType, tcInstTcType, 
+			  tcInstTyVar, newTyVarTy, zonkTcTyVars )
+
+import Class		( Class(..), getClassSig )
+import Id		( Id(..), GenId, idType )
+import Kind		( Kind, mkBoxedTypeKind, mkTypeKind )
+import GenSpecEtc	( checkSigTyVars, checkSigTyVarsGivenGlobals, specTy )
+import PrelInfo		( intPrimTy, charPrimTy, doublePrimTy,
+			  floatPrimTy, addrPrimTy, addrTy,
+			  boolTy, charTy, stringTy, mkListTy,
+			  mkTupleTy, mkPrimIoTy )
+import Type		( mkFunTy, mkAppTy, mkTyVarTy,
+			  getTyVar_maybe, getFunTy_maybe,
+			  splitForAllTy, splitRhoTy, splitSigmaTy,
+			  isTauTy, mkFunTys, tyVarsOfType, getForAllTy_maybe )
+import TyVar		( GenTyVar, TyVarSet(..), unionTyVarSets, tyVarListToSet )
 import Unify		( unifyTauTy, unifyTauTyList, unifyTauTyLists )
-import UniqFM		( emptyUFM ) -- profiling, pragmas only
-import Unique		-- *Key stuff
+import Unique		( Unique, cCallableClassKey, cReturnableClassKey, 
+			  enumFromClassOpKey, enumFromThenClassOpKey,
+			  enumFromToClassOpKey, enumFromThenToClassOpKey,
+			  monadClassKey, monadZeroClassKey )
+
+import Name		( Name )		-- Instance 
+import PprType		( GenType, GenTyVar )	-- Instances
+import Maybes		( maybeToBool )
+import Pretty
 import Util
+\end{code}
 
-tcExpr :: E -> RenamedExpr -> TcM (TypecheckedExpr, LIE, UniType)
+\begin{code}
+tcExpr :: RenamedHsExpr -> TcM s (TcExpr s, LIE s, TcType s)
 \end{code}
 
 %************************************************************************
@@ -67,17 +70,16 @@ tcExpr :: E -> RenamedExpr -> TcM (TypecheckedExpr, LIE, UniType)
 %************************************************************************
 
 \begin{code}
-tcExpr e (Var name)
-  = specId (lookupE_Value e name) `thenNF_Tc` \ stuff@(expr, lie, ty) ->
+tcExpr (HsVar name)
+  = tcId name		`thenTc` \ (expr', lie, res_ty) ->
 
-	-- Check that there's no lurking rank-2 polymorphism
-	-- isTauTy is over-paranoid, because we don't expect
-	-- any submerged polymorphism other than rank-2 polymorphism
+    -- Check that the result type doesn't have any nested for-alls.
+    -- For example, a "build" on its own is no good; it must be
+    -- applied to something.
+    checkTc (isTauTy res_ty)
+	    (lurkingRank2Err name res_ty) `thenTc_`
 
-    getSrcLocTc			  `thenNF_Tc` \ loc ->
-    checkTc (not (isTauTy ty)) (lurkingRank2Err name ty loc) `thenTc_`
- 
-    returnTc stuff
+    returnTc (expr', lie, res_ty)
 \end{code}
 
 %************************************************************************
@@ -89,75 +91,59 @@ tcExpr e (Var name)
 Overloaded literals.
 
 \begin{code}
-tcExpr e (Lit lit@(IntLit i))
-  = getSrcLocTc			`thenNF_Tc` \ loc ->
-    newPolyTyVarTy		`thenNF_Tc` \ ty ->
-    let
-	from_int     = lookupE_ClassOpByKey e numClassKey SLIT("fromInt")
-	from_integer = lookupE_ClassOpByKey e numClassKey SLIT("fromInteger")
-    in
-    newOverloadedLit (LiteralOrigin lit loc)
-		     (OverloadedIntegral i from_int from_integer)
-		     ty
-				`thenNF_Tc` \ over_lit ->
+tcExpr (HsLit (HsInt i))
+  = newTyVarTy mkBoxedTypeKind	`thenNF_Tc` \ ty ->
 
-    returnTc (Var (mkInstId over_lit), unitLIE over_lit, ty)
+    newOverloadedLit (LiteralOrigin (HsInt i))
+		     (OverloadedIntegral i)
+		     ty					`thenNF_Tc` \ (lie, over_lit_id) ->
 
-tcExpr e (Lit lit@(FracLit f))
-  = getSrcLocTc			`thenNF_Tc` \ loc ->
-    newPolyTyVarTy		`thenNF_Tc` \ ty ->
-    let
-	from_rational = lookupE_ClassOpByKey e fractionalClassKey SLIT("fromRational")
-    in
-    newOverloadedLit (LiteralOrigin lit loc)
-		     (OverloadedFractional f from_rational)
-		     ty
-				`thenNF_Tc` \ over_lit ->
+    returnTc (HsVar over_lit_id, lie, ty)
 
-    returnTc (Var (mkInstId over_lit), unitLIE over_lit, ty)
+tcExpr (HsLit (HsFrac f))
+  = newTyVarTy mkBoxedTypeKind	`thenNF_Tc` \ ty ->
 
-tcExpr e (Lit lit@(LitLitLitIn s))
-  = getSrcLocTc			`thenNF_Tc` \ loc ->
-    let
-	-- Get the callable class.  Rather turgid and a HACK (ToDo).
-	ce 		 = getE_CE e
-	cCallableClass   = lookupCE ce (PreludeClass cCallableClassKey   bottom)
-	bottom		 = panic "tcExpr:LitLitLit"
-    in
-    newPolyTyVarTy		`thenNF_Tc` \ ty ->
-  
-    newDict (LitLitOrigin loc (_UNPK_ s)) cCallableClass ty `thenNF_Tc` \ dict ->
+    newOverloadedLit (LiteralOrigin (HsFrac f))
+		     (OverloadedFractional f)
+		     ty					`thenNF_Tc` \ (lie, over_lit_id) ->
+
+    returnTc (HsVar over_lit_id, lie, ty)
 
-    returnTc (Lit (LitLitLit s ty), mkLIE [dict], ty)
+tcExpr (HsLit lit@(HsLitLit s))
+  = tcLookupClassByKey cCallableClassKey		`thenNF_Tc` \ cCallableClass ->
+    newTyVarTy mkBoxedTypeKind				`thenNF_Tc` \ ty ->
+    newDicts (LitLitOrigin (_UNPK_ s))
+	     [(cCallableClass, ty)]			`thenNF_Tc` \ (dicts, _) ->
+    returnTc (HsLitOut lit ty, dicts, ty)
 \end{code}
 
 Primitive literals:
 
 \begin{code}
-tcExpr e (Lit (CharPrimLit c))
-  = returnTc (Lit (CharPrimLit c), nullLIE, charPrimTy)
+tcExpr (HsLit lit@(HsCharPrim c))
+  = returnTc (HsLitOut lit charPrimTy, emptyLIE, charPrimTy)
 
-tcExpr e (Lit (StringPrimLit s))
-  = returnTc (Lit (StringPrimLit s), nullLIE, addrPrimTy)
+tcExpr (HsLit lit@(HsStringPrim s))
+  = returnTc (HsLitOut lit addrPrimTy, emptyLIE, addrPrimTy)
 
-tcExpr e (Lit (IntPrimLit i))
-  = returnTc (Lit (IntPrimLit i), nullLIE, intPrimTy)
+tcExpr (HsLit lit@(HsIntPrim i))
+  = returnTc (HsLitOut lit intPrimTy, emptyLIE, intPrimTy)
 
-tcExpr e (Lit (FloatPrimLit f))
-  = returnTc (Lit (FloatPrimLit f), nullLIE, floatPrimTy)
+tcExpr (HsLit lit@(HsFloatPrim f))
+  = returnTc (HsLitOut lit floatPrimTy, emptyLIE, floatPrimTy)
 
-tcExpr e (Lit (DoublePrimLit d))
-  = returnTc (Lit (DoublePrimLit d), nullLIE, doublePrimTy)
+tcExpr (HsLit lit@(HsDoublePrim d))
+  = returnTc (HsLitOut lit doublePrimTy, emptyLIE, doublePrimTy)
 \end{code}
 
 Unoverloaded literals:
 
 \begin{code}
-tcExpr e (Lit (CharLit c))
-  = returnTc (Lit (CharLit c), nullLIE, charTy)
+tcExpr (HsLit lit@(HsChar c))
+  = returnTc (HsLitOut lit charTy, emptyLIE, charTy)
 
-tcExpr e (Lit (StringLit str))
-  = returnTc (Lit (StringLit str), nullLIE, stringTy)
+tcExpr (HsLit lit@(HsString str))
+  = returnTc (HsLitOut lit stringTy, emptyLIE, stringTy)
 \end{code}
 
 %************************************************************************
@@ -167,49 +153,63 @@ tcExpr e (Lit (StringLit str))
 %************************************************************************
 
 \begin{code}
-tcExpr e (Lam match)
-  = tcMatch e match	`thenTc` \ (match',lie,ty) ->
-    returnTc (Lam match',lie,ty)
+tcExpr (HsLam match)
+  = tcMatch match	`thenTc` \ (match',lie,ty) ->
+    returnTc (HsLam match', lie, ty)
 
-tcExpr e (App e1 e2) = accum e1 [e2]
-	where
-	  accum (App e1 e2) args = accum e1 (e2:args)
-	  accum fun         args = tcApp (foldl App) e fun args
+tcExpr (HsApp e1 e2) = accum e1 [e2]
+  where
+    accum (HsApp e1 e2) args = accum e1 (e2:args)
+    accum fun args
+      = tcApp fun args 	`thenTc` \ (fun', args', lie, res_ty) ->
+	returnTc (foldl HsApp fun' args', lie, res_ty)
 
 -- equivalent to (op e1) e2:
-tcExpr e (OpApp e1 op e2)
-  = tcApp (\fun [arg1,arg2] -> OpApp arg1 fun arg2) e op [e1,e2]
+tcExpr (OpApp arg1 op arg2)
+  = tcApp op [arg1,arg2]	`thenTc` \ (op', [arg1', arg2'], lie, res_ty) ->
+    returnTc (OpApp arg1' op' arg2', lie, res_ty)
 \end{code}
 
 Note that the operators in sections are expected to be binary, and
 a type error will occur if they aren't.
 
 \begin{code}
--- equivalent to 
---	\ x -> e op x, 
+-- Left sections, equivalent to
+--	\ x -> e op x,
 -- or
---	\ x -> op e x, 
+--	\ x -> op e x,
 -- or just
 -- 	op e
 
-tcExpr e (SectionL expr op)
-  = tcApp (\ fun [arg] -> SectionL arg fun) e op [expr]
+tcExpr in_expr@(SectionL arg op)
+  = tcApp op [arg] 		`thenTc` \ (op', [arg'], lie, res_ty) ->
+
+	-- Check that res_ty is a function type
+	-- Without this check we barf in the desugarer on
+	-- 	f op = (3 `op`)
+	-- because it tries to desugar to
+	--	f op = \r -> 3 op r
+	-- so (3 `op`) had better be a function!
+    newTyVarTy mkTypeKind		`thenNF_Tc` \ ty1 ->
+    newTyVarTy mkTypeKind		`thenNF_Tc` \ ty2 ->
+    tcAddErrCtxt (sectionLAppCtxt in_expr) $
+    unifyTauTy (mkFunTy ty1 ty2) res_ty	`thenTc_`
 
--- equivalent to \ x -> x op expr, or
+    returnTc (SectionL arg' op', lie, res_ty)
+
+-- Right sections, equivalent to \ x -> x op expr, or
 --	\ x -> op x expr
 
-tcExpr e (SectionR op expr)
-  = tcExpr e op			`thenTc`    \ (op',  lie1, op_ty) ->
-    tcExpr e expr		`thenTc`    \ (expr',lie2, expr_ty) ->
-    newOpenTyVarTy		`thenNF_Tc` \ ty1 ->
-    newOpenTyVarTy		`thenNF_Tc` \ ty2 ->
-    let
-	result_ty = mkFunTy ty1 ty2
-    in
-    unifyTauTy op_ty (mkFunTy ty1 (mkFunTy expr_ty ty2))
-		     (SectionRAppCtxt op expr) `thenTc_`
+tcExpr in_expr@(SectionR op expr)
+  = tcExpr op			`thenTc`    \ (op',  lie1, op_ty) ->
+    tcExpr expr			`thenTc`    \ (expr',lie2, expr_ty) ->
+
+    newTyVarTy mkTypeKind	`thenNF_Tc` \ ty1 ->
+    newTyVarTy mkTypeKind	`thenNF_Tc` \ ty2 ->
+    tcAddErrCtxt (sectionRAppCtxt in_expr) $
+    unifyTauTy op_ty (mkFunTys [ty1, expr_ty] ty2)     `thenTc_`
 
-    returnTc (SectionR op' expr', plusLIE lie1 lie2, result_ty)
+    returnTc (SectionR op' expr', lie1 `plusLIE` lie2, mkFunTy ty1 ty2)
 \end{code}
 
 The interesting thing about @ccall@ is that it is just a template
@@ -220,164 +220,195 @@ arg/result types); unify them with the args/result; and store them for
 later use.
 
 \begin{code}
-tcExpr e (CCall lbl args may_gc is_asm ignored_fake_result_ty)
-  = getSrcLocTc						`thenNF_Tc` \ src_loc ->
-    let
-	-- Get the callable and returnable classes.  Rather turgid (ToDo).
-	ce 		 = getE_CE e
-	cCallableClass   = lookupCE ce (PreludeClass cCallableClassKey   bottom)
-	cReturnableClass = lookupCE ce (PreludeClass cReturnableClassKey bottom)
-	bottom		 = panic "tcExpr:CCall"
+tcExpr (CCall lbl args may_gc is_asm ignored_fake_result_ty)
+  = 	-- Get the callable and returnable classes.
+    tcLookupClassByKey cCallableClassKey	`thenNF_Tc` \ cCallableClass ->
+    tcLookupClassByKey cReturnableClassKey	`thenNF_Tc` \ cReturnableClass ->
 
-	new_arg_dict (arg, arg_ty) = newDict (CCallOrigin src_loc (_UNPK_ lbl) (Just arg)) 
-					     cCallableClass arg_ty
+    let
+	new_arg_dict (arg, arg_ty)
+	  = newDicts (CCallOrigin (_UNPK_ lbl) (Just arg))
+		     [(cCallableClass, arg_ty)]		`thenNF_Tc` \ (arg_dicts, _) ->
+	    returnNF_Tc arg_dicts	-- Actually a singleton bag
 
-	result_origin = CCallOrigin src_loc (_UNPK_ lbl) Nothing {- Not an arg -}
+	result_origin = CCallOrigin (_UNPK_ lbl) Nothing {- Not an arg -}
     in
-  
+
 	-- Arguments
-    tcExprs e args			`thenTc` \ (args', args_lie, arg_tys) ->
+    tcExprs args			`thenTc` \ (args', args_lie, arg_tys) ->
 
 	-- The argument types can be unboxed or boxed; the result
-	-- type must, however, be boxed since it's an argument to the PrimIO 
+	-- type must, however, be boxed since it's an argument to the PrimIO
 	-- type constructor.
-    newPolyTyVarTy			  		`thenNF_Tc` \ result_ty ->
+    newTyVarTy mkBoxedTypeKind  		`thenNF_Tc` \ result_ty ->
 
 	-- Construct the extra insts, which encode the
 	-- constraints on the argument and result types.
-    mapNF_Tc new_arg_dict (args `zip` arg_tys)			`thenNF_Tc` \ arg_dicts ->
-    newDict result_origin cReturnableClass result_ty		`thenNF_Tc` \ res_dict ->
-	
-    returnTc (CCall lbl args' may_gc is_asm result_ty, 
-	      args_lie `plusLIE` mkLIE (res_dict : arg_dicts), 
+    mapNF_Tc new_arg_dict (args `zip` arg_tys)			`thenNF_Tc` \ ccarg_dicts_s ->
+    newDicts result_origin [(cReturnableClass, result_ty)]	`thenNF_Tc` \ (ccres_dict, _) ->
+
+    returnTc (CCall lbl args' may_gc is_asm result_ty,
+	      foldr plusLIE ccres_dict ccarg_dicts_s `plusLIE` args_lie,
 	      mkPrimIoTy result_ty)
 \end{code}
 
 \begin{code}
-tcExpr e (SCC label expr)
-  = tcExpr e expr		`thenTc` \ (expr', lie, expr_ty) ->
+tcExpr (HsSCC label expr)
+  = tcExpr expr		`thenTc` \ (expr', lie, expr_ty) ->
 	 -- No unification. Give SCC the type of expr
-    returnTc (SCC label expr', lie, expr_ty)
+    returnTc (HsSCC label expr', lie, expr_ty)
+
+tcExpr (HsLet binds expr)
+  = tcBindsAndThen
+	HsLet 			-- The combiner
+	binds 			-- Bindings to check
+	(tcExpr expr)		-- Typechecker for the expression
 
-tcExpr e (Let binds expr)
-  = tcLocalBindsAndThen e 
-	Let 				-- The combiner
-	binds 				-- Bindings to check
-	(\ e -> tcExpr e expr)		-- Typechecker for the expression
+tcExpr in_expr@(HsCase expr matches src_loc)
+  = tcAddSrcLoc src_loc	$
+    tcExpr expr			`thenTc`    \ (expr',lie1,expr_ty) ->
+    newTyVarTy mkTypeKind	`thenNF_Tc` \ result_ty ->
 
-tcExpr e (Case expr matches)
-  = tcExpr e expr		`thenTc`    \ (expr',lie1,expr_ty) ->
-    tcMatchesCase e matches	`thenTc`    \ (matches',lie2,match_ty) ->
-    newOpenTyVarTy		`thenNF_Tc` \ result_ty ->
+    tcAddErrCtxt (caseCtxt in_expr) $
+    tcMatchesCase (mkFunTy expr_ty result_ty) matches	
+				`thenTc`    \ (matches',lie2) ->
 
-    unifyTauTy (mkFunTy expr_ty result_ty) match_ty
-		(CaseCtxt expr matches)	`thenTc_`
+    returnTc (HsCase expr' matches' src_loc, plusLIE lie1 lie2, result_ty)
 
-    returnTc (Case expr' matches', plusLIE lie1 lie2, result_ty)
+tcExpr (HsIf pred b1 b2 src_loc)
+  = tcAddSrcLoc src_loc	$
+    tcExpr pred			`thenTc`    \ (pred',lie1,predTy) ->
 
-tcExpr e (If pred b1 b2)
-  = tcExpr e pred		`thenTc`    \ (pred',lie1,predTy) ->
+    tcAddErrCtxt (predCtxt pred) (
+      unifyTauTy predTy boolTy
+    )				`thenTc_`
 
-    unifyTauTy predTy boolTy (PredCtxt pred) `thenTc_`
+    tcExpr b1			`thenTc`    \ (b1',lie2,result_ty) ->
+    tcExpr b2			`thenTc`    \ (b2',lie3,b2Ty) ->
 
-    tcExpr e b1			`thenTc`    \ (b1',lie2,result_ty) ->
-    tcExpr e b2			`thenTc`    \ (b2',lie3,b2Ty) ->
+    tcAddErrCtxt (branchCtxt b1 b2) $
+    unifyTauTy result_ty b2Ty				`thenTc_`
 
-    unifyTauTy result_ty b2Ty (BranchCtxt b1 b2) `thenTc_`
+    returnTc (HsIf pred' b1' b2' src_loc, plusLIE lie1 (plusLIE lie2 lie3), result_ty)
 
-    returnTc (If pred' b1' b2', plusLIE lie1 (plusLIE lie2 lie3), result_ty)
+tcExpr (ListComp expr quals) 
+  = tcListComp expr quals	`thenTc` \ ((expr',quals'), lie, ty) ->
+    returnTc (ListComp expr' quals', lie, ty)
+\end{code}
 
-tcExpr e (ListComp expr quals)
-  = mkIdsWithPolyTyVarTys binders	`thenNF_Tc` \ lve ->
-	 -- Binders of a list comprehension must be boxed.
+\begin{code}
+tcExpr (HsDo stmts src_loc)
+  = 	-- get the Monad and MonadZero classes
+	-- create type consisting of a fresh monad tyvar
+    tcAddSrcLoc src_loc	$
+    tcLookupClassByKey monadClassKey		`thenNF_Tc` \ monadClass ->
+    tcLookupClassByKey monadZeroClassKey	`thenNF_Tc` \ monadZeroClass ->
     let
-	new_e = growE_LVE e lve
+   	(tv,_,_) = getClassSig monadClass
     in
-    tcQuals new_e quals			`thenTc` \ (quals',lie1) ->
-    tcExpr  new_e expr			`thenTc` \ (expr', lie2, ty) ->
-    returnTc (ListComp expr' quals', plusLIE lie1 lie2, mkListTy ty)
-  where
-    binders = collectQualBinders quals
+    tcInstTyVar tv				`thenNF_Tc` \ m_tyvar ->
+    let
+	m = mkTyVarTy m_tyvar
+    in
+    tcDoStmts False m stmts			`thenTc` \ ((stmts',monad,mzero), lie, do_ty) ->
+
+	-- create dictionaries for monad and possibly monadzero
+    (if monad then
+	newDicts DoOrigin [(monadClass, m)]	
+    else
+	returnNF_Tc (emptyLIE, [panic "TcExpr: MonadZero dictionary"])
+    )						`thenNF_Tc` \ (m_lie,  [m_id])  ->
+    (if mzero then
+	newDicts DoOrigin [(monadZeroClass, m)]
+     else
+        returnNF_Tc (emptyLIE, [panic "TcExpr: MonadZero dictionary"])
+    )						`thenNF_Tc` \ (mz_lie, [mz_id]) ->
+
+    returnTc (HsDoOut stmts' m_id mz_id src_loc,
+	      lie `plusLIE` m_lie `plusLIE` mz_lie,
+	      do_ty)
 \end{code}
 
 \begin{code}
-tcExpr e (ExplicitList [])
-  = newPolyTyVarTy			`thenNF_Tc` \ tyvar_ty ->
-    returnTc (ExplicitListOut tyvar_ty [], nullLIE, mkListTy tyvar_ty)
+tcExpr (ExplicitList [])
+  = newTyVarTy mkBoxedTypeKind		`thenNF_Tc` \ tyvar_ty ->
+    returnTc (ExplicitListOut tyvar_ty [], emptyLIE, mkListTy tyvar_ty)
 
 
-tcExpr e (ExplicitList exprs)		-- Non-empty list
-  = tcExprs e exprs			`thenTc` \ (exprs', lie, tys@(elt_ty:_)) ->
-    unifyTauTyList tys (ListCtxt exprs) `thenTc_`
+tcExpr in_expr@(ExplicitList exprs)	-- Non-empty list
+  = tcExprs exprs			`thenTc` \ (exprs', lie, tys@(elt_ty:_)) ->
+    tcAddErrCtxt (listCtxt in_expr) $
+    unifyTauTyList tys 			`thenTc_`
     returnTc (ExplicitListOut elt_ty exprs', lie, mkListTy elt_ty)
 
-tcExpr e (ExplicitTuple exprs)
-  = tcExprs e exprs			`thenTc` \ (exprs', lie, tys) ->
+tcExpr (ExplicitTuple exprs)
+  = tcExprs exprs			`thenTc` \ (exprs', lie, tys) ->
     returnTc (ExplicitTuple exprs', lie, mkTupleTy (length tys) tys)
 
-tcExpr e (ArithSeqIn seq@(From expr))
-  = getSrcLocTc			`thenNF_Tc` \ loc ->
-    tcExpr e expr		`thenTc`    \ (expr', lie, ty) ->
-    let
-	enum_from_id = lookupE_ClassOpByKey e enumClassKey SLIT("enumFrom")
-    in
-    newMethod (ArithSeqOrigin seq loc)
-	      enum_from_id [ty]	`thenNF_Tc` \ enum_from ->
+tcExpr (RecordCon con rbinds)
+  = panic "tcExpr:RecordCon"
+tcExpr (RecordUpd exp rbinds)
+  = panic "tcExpr:RecordUpd"
 
-    returnTc (ArithSeqOut (Var (mkInstId enum_from)) (From expr'),
-	      plusLIE (unitLIE enum_from) lie,
-	       mkListTy ty)
+tcExpr (ArithSeqIn seq@(From expr))
+  = tcExpr expr					`thenTc`    \ (expr', lie1, ty) ->
 
-tcExpr e (ArithSeqIn seq@(FromThen expr1 expr2))
-  = getSrcLocTc			`thenNF_Tc` \ loc ->
-    tcExpr e expr1		`thenTc`    \ (expr1',lie1,ty1) ->
-    tcExpr e expr2		`thenTc`    \ (expr2',lie2,ty2) ->
+    tcLookupGlobalValueByKey enumFromClassOpKey	`thenNF_Tc` \ sel_id ->
+    newMethod (ArithSeqOrigin seq)
+	      (RealId sel_id) [ty]		`thenNF_Tc` \ (lie2, enum_from_id) ->
 
-    unifyTauTyList [ty1, ty2] (ArithSeqCtxt (ArithSeqIn seq)) `thenTc_`
-    let
-	enum_from_then_id = lookupE_ClassOpByKey e enumClassKey SLIT("enumFromThen")
-    in
-    newMethod (ArithSeqOrigin seq loc)
-	      enum_from_then_id [ty1]	`thenNF_Tc` \ enum_from_then ->
+    returnTc (ArithSeqOut (HsVar enum_from_id) (From expr'),
+	      lie1 `plusLIE` lie2,
+	      mkListTy ty)
 
-    returnTc (ArithSeqOut (Var (mkInstId enum_from_then))
+tcExpr in_expr@(ArithSeqIn seq@(FromThen expr1 expr2))
+  = tcExpr expr1		`thenTc`    \ (expr1',lie1,ty1) ->
+    tcExpr expr2		`thenTc`    \ (expr2',lie2,ty2) ->
+
+    tcAddErrCtxt (arithSeqCtxt in_expr) $
+    unifyTauTyList [ty1, ty2] 				`thenTc_`
+
+    tcLookupGlobalValueByKey enumFromThenClassOpKey	`thenNF_Tc` \ sel_id ->
+    newMethod (ArithSeqOrigin seq)
+	      (RealId sel_id) [ty1]			`thenNF_Tc` \ (lie3, enum_from_then_id) ->
+
+    returnTc (ArithSeqOut (HsVar enum_from_then_id)
 			   (FromThen expr1' expr2'),
-	     (unitLIE enum_from_then) `plusLIE` lie1 `plusLIE` lie2,
+	      lie1 `plusLIE` lie2 `plusLIE` lie3,
 	      mkListTy ty1)
 
-tcExpr e (ArithSeqIn seq@(FromTo expr1 expr2))
-  = getSrcLocTc			`thenNF_Tc` \ loc ->
-    tcExpr e expr1		`thenTc`    \ (expr1',lie1,ty1) ->
-    tcExpr e expr2		`thenTc`    \ (expr2',lie2,ty2) ->
+tcExpr in_expr@(ArithSeqIn seq@(FromTo expr1 expr2))
+  = tcExpr expr1		`thenTc`    \ (expr1',lie1,ty1) ->
+    tcExpr expr2		`thenTc`    \ (expr2',lie2,ty2) ->
 
-    unifyTauTyList [ty1,ty2] (ArithSeqCtxt (ArithSeqIn seq)) `thenTc_`
-    let
-	enum_from_to_id = lookupE_ClassOpByKey e enumClassKey SLIT("enumFromTo")
-    in
-    newMethod (ArithSeqOrigin seq loc)
-	      enum_from_to_id [ty1]	 `thenNF_Tc` \ enum_from_to ->
-    returnTc (ArithSeqOut (Var (mkInstId enum_from_to))
-			   (FromTo expr1' expr2'),
-	      (unitLIE enum_from_to) `plusLIE` lie1 `plusLIE` lie2,
+    tcAddErrCtxt (arithSeqCtxt in_expr) $
+    unifyTauTyList [ty1,ty2]	`thenTc_`
+
+    tcLookupGlobalValueByKey enumFromToClassOpKey	`thenNF_Tc` \ sel_id ->
+    newMethod (ArithSeqOrigin seq)
+	      (RealId sel_id) [ty1] 		`thenNF_Tc` \ (lie3, enum_from_to_id) ->
+
+    returnTc (ArithSeqOut (HsVar enum_from_to_id)
+			  (FromTo expr1' expr2'),
+	      lie1 `plusLIE` lie2 `plusLIE` lie3,
 	       mkListTy ty1)
 
-tcExpr e (ArithSeqIn seq@(FromThenTo expr1 expr2 expr3))
-  = getSrcLocTc			`thenNF_Tc` \ loc ->
-    tcExpr e expr1		`thenTc`    \ (expr1',lie1,ty1) ->
-    tcExpr e expr2		`thenTc`    \ (expr2',lie2,ty2) ->
-    tcExpr e expr3		`thenTc`    \ (expr3',lie3,ty3) ->
+tcExpr in_expr@(ArithSeqIn seq@(FromThenTo expr1 expr2 expr3))
+  = tcExpr expr1		`thenTc`    \ (expr1',lie1,ty1) ->
+    tcExpr expr2		`thenTc`    \ (expr2',lie2,ty2) ->
+    tcExpr expr3		`thenTc`    \ (expr3',lie3,ty3) ->
 
-    unifyTauTyList [ty1,ty2,ty3] (ArithSeqCtxt (ArithSeqIn seq)) `thenTc_`
-    let
-	enum_from_then_to_id = lookupE_ClassOpByKey e enumClassKey SLIT("enumFromThenTo")
-    in
-    newMethod (ArithSeqOrigin seq loc)
-	      enum_from_then_to_id [ty1] `thenNF_Tc` \ enum_from_then_to ->
+    tcAddErrCtxt  (arithSeqCtxt in_expr) $
+    unifyTauTyList [ty1,ty2,ty3]			`thenTc_`
 
-    returnTc (ArithSeqOut (Var (mkInstId enum_from_then_to))
+    tcLookupGlobalValueByKey enumFromThenToClassOpKey	`thenNF_Tc` \ sel_id ->
+    newMethod (ArithSeqOrigin seq)
+	      (RealId sel_id) [ty1]			`thenNF_Tc` \ (lie4, eft_id) ->
+
+    returnTc (ArithSeqOut (HsVar eft_id)
 			   (FromThenTo expr1' expr2' expr3'),
-	      (unitLIE enum_from_then_to) `plusLIE` lie1 `plusLIE` lie2 `plusLIE` lie3,
-	       mkListTy ty1)
+	      lie1 `plusLIE` lie2 `plusLIE` lie3 `plusLIE` lie4,
+	      mkListTy ty1)
 \end{code}
 
 %************************************************************************
@@ -387,25 +418,22 @@ tcExpr e (ArithSeqIn seq@(FromThenTo expr1 expr2 expr3))
 %************************************************************************
 
 \begin{code}
-tcExpr e (ExprWithTySig expr poly_ty)
- = tcExpr e expr					`thenTc` \ (texpr, lie, tau_ty) ->
-   babyTcMtoTcM (tcPolyType (getE_CE e) (getE_TCE e) nullTVE poly_ty)	`thenTc` \ sigma_sig ->
+tcExpr in_expr@(ExprWithTySig expr poly_ty)
+ = tcExpr expr			`thenTc` \ (texpr, lie, tau_ty) ->
+   tcPolyType  poly_ty		`thenTc` \ sigma_sig ->
 
 	-- Check the tau-type part
-   specTy SignatureOrigin sigma_sig	`thenNF_Tc` \ (sig_tyvars, sig_dicts, sig_tau) ->
-   unifyTauTy tau_ty sig_tau (ExprSigCtxt expr sig_tau) `thenTc_`
+   tcSetErrCtxt (exprSigCtxt in_expr)	$
+   specTy SignatureOrigin sigma_sig	`thenNF_Tc` \ (sig_tyvars, sig_dicts, sig_tau, _) ->
+   unifyTauTy tau_ty sig_tau		`thenTc_`
 
 	-- Check the type variables of the signature
-   applyTcSubstAndCollectTyVars (tvOfE e) `thenNF_Tc` \ env_tyvars ->
-   checkSigTyVars env_tyvars sig_tyvars sig_tau tau_ty (ExprSigCtxt expr sig_tau)
-					`thenTc`    \ sig_tyvars' ->
+   checkSigTyVars sig_tyvars sig_tau tau_ty	`thenTc`    \ sig_tyvars' ->
 
 	-- Check overloading constraints
    tcSimplifyAndCheck
-	False {- Not top level -}
-	env_tyvars sig_tyvars'
-	sig_dicts (unMkLIE lie)
-	(ExprSigCtxt expr sigma_sig)		`thenTc_`
+	(tyVarListToSet sig_tyvars')
+	sig_dicts lie				`thenTc_`
 
 	-- If everything is ok, return the stuff unchanged, except for
 	-- the effect of any substutions etc.  We simply discard the
@@ -417,228 +445,115 @@ tcExpr e (ExprWithTySig expr poly_ty)
 
 %************************************************************************
 %*									*
-\subsection{Data Parallel Expressions (DPH only)}
+\subsection{@tcApp@ typchecks an application}
 %*									*
 %************************************************************************
 
-Constraints enforced by the Static semantics for ParallelZF
-$exp_1$ = << $exp_2$ | quals >>
+\begin{code}
+tcApp :: RenamedHsExpr -> [RenamedHsExpr]   -- Function and args
+      -> TcM s (TcExpr s, [TcExpr s],	    -- Translated fun and args
+		LIE s,
+		TcType s)		    -- Type of the application
 
-\begin{enumerate}
-\item The type of the expression $exp_1$ is <<$exp_2$>>
-\item The type of $exp_2$ must be in the class {\tt Processor}
-\end{enumerate}
+tcApp fun args
+  = 	-- First type-check the function
+	-- In the HsVar case we go straight to tcId to avoid hitting the
+	-- rank-2 check, which we check later here anyway
+    (case fun of
+	HsVar name -> tcId name
+	other	   -> tcExpr fun
+    )					`thenTc` \ (fun', lie_fun, fun_ty) ->
 
-\begin{code}
-#ifdef DPH
-tcExpr e (ParallelZF expr quals)
- = let binders = collectParQualBinders quals	    in
-   mkIdsWithPolyTyVarTys binders	`thenNF_Tc` (\ lve		->
-   let e'      = growE_LVE e lve		    in
-   tcParQuals e' quals			`thenTc`    (\ (quals',lie1)	->
-   tcExpr e' expr			`thenTc`    (\ (expr', lie2,ty) ->
-   getSrcLocTc				`thenNF_Tc` (\ src_loc		->
-   if (isProcessorTy ty) then
-      returnTc (ParallelZF expr' quals',
-		 plusLIE lie1 lie2 ,
-		 mkPodTy ty)
-   else
-      failTc (podCompLhsError ty src_loc)
-   ))))
-#endif {- Data Parallel Haskell -}
-\end{code}
+    tcApp_help fun 1 fun_ty args	`thenTc` \ (args', lie_args, res_ty) ->
 
-Constraints enforced by the Static semantics for Explicit Pods
-exp = << $exp_1$ ... $exp_n$>>	(where $n >= 0$)
+    -- Check that the result type doesn't have any nested for-alls.
+    -- For example, a "build" on its own is no good; it must be applied to something.
+    checkTc (isTauTy res_ty)
+	    (lurkingRank2Err fun fun_ty) `thenTc_`
 
-\begin{enumerate}
-\item The type of the all the expressions in the Pod must be the same.
-\item The type of an expression in a POD must be in class {\tt Processor}
-\end{enumerate}
+    returnTc (fun', args', lie_fun `plusLIE` lie_args, res_ty)
 
-\begin{code}
-#ifdef DPH
-tcExpr e (ExplicitPodIn exprs)
- = panic "Ignoring explicit PODs for the time being"
-{-
- = tcExprs e exprs			`thenTc`    (\ (exprs',lie,tys) ->
-   newPolyTyVarTy			`thenNF_Tc` (\ elt_ty ->
-   newDict processorClass elt_ty 	`thenNF_Tc` (\ procDict ->
-   let
-      procLie = mkLIEFromDicts procDict
-   in
-   unifyTauTyList (elt_ty:tys) (PodCtxt exprs) `thenTc_`
-
-   returnTc ((App
-		(DictApp
-		   (TyApp (Var toPodId) [elt_ty])
-		   procDict)
-		(ExplicitListOut elt_ty exprs')),
-	     plusLIE procLie lie,
-	     mkPodTy elt_ty)
-   ))) -}
-#endif {- Data Parallel Haskell -}
-\end{code}
 
-\begin{code}
-#ifdef DPH
-tcExpr e (ExplicitProcessor exprs expr)
- = tcPidExprs e exprs		`thenTc`	(\ (exprs',lie1,tys) ->
-   tcExpr  e expr		`thenTc`	(\ (expr',lie2,ty)   ->
-   returnTc (ExplicitProcessor exprs' expr',
-	     plusLIE lie1 lie2,
-	     mkProcessorTy tys ty)
-   ))
-#endif {- Data Parallel Haskell -}
-\end{code}
+tcApp_help :: RenamedHsExpr -> Int	-- Function and arg position, used in error message(s)
+	   -> TcType s			-- The type of the function
+	   -> [RenamedHsExpr]		-- Arguments
+	   -> TcM s ([TcExpr s],		-- Typechecked args
+		     LIE s,
+		     TcType s)		-- Result type of the application
 
-%************************************************************************
-%*									*
-\subsection{@tcExprs@ typechecks a {\em list} of expressions}
-%*									*
-%************************************************************************
+tcApp_help orig_fun arg_no fun_ty []
+  = returnTc ([], emptyLIE, fun_ty)
 
-ToDo: Possibly find a version of a listTc TcM which would pass the
-appropriate functions for the LIE.
+tcApp_help orig_fun arg_no fun_ty (arg:args)
+  | maybeToBool maybe_arrow_ty
+  = 	-- The function's type is A->B
+    tcAddErrCtxt (funAppCtxt orig_fun arg_no arg) (
+	tcArg expected_arg_ty arg
+    )					 	`thenTc` \ (arg', lie_arg) ->
 
-\begin{code}
-tcExprs :: E -> [RenamedExpr] -> TcM ([TypecheckedExpr],LIE,[TauType])
+    tcApp_help orig_fun (arg_no+1) result_ty args	`thenTc` \ (args', lie_args, res_ty) ->
+    returnTc (arg':args', lie_arg `plusLIE` lie_args, res_ty)
 
-tcExprs e [] = returnTc ([], nullLIE, [])
-tcExprs e (expr:exprs)
- = tcExpr e expr			`thenTc` \ (expr',  lie1, ty) ->
-   tcExprs e exprs			`thenTc` \ (exprs', lie2, tys) ->
-   returnTc (expr':exprs', plusLIE lie1 lie2, ty:tys)
-\end{code}
+  | maybeToBool maybe_tyvar_ty
+  = 	-- The function's type is just a type variable
+    tcReadTyVar fun_tyvar			`thenNF_Tc` \ maybe_fun_ty ->
+    case maybe_fun_ty of
 
+	BoundTo new_fun_ty -> 	-- The tyvar in the corner of the function is bound
+				-- to something ... so carry on ....
+		tcApp_help orig_fun arg_no new_fun_ty (arg:args)
 
-%************************************************************************
-%*									*
-\subsection{@tcApp@ typchecks an application}
-%*									*
-%************************************************************************
+	UnBound ->	-- Extra args match against an unbound type
+			-- variable as the final result type, so unify the tyvar.
+		newTyVarTy mkTypeKind	`thenNF_Tc` \ result_ty ->
+		tcExprs args		`thenTc`    \ (args', lie_args, arg_tys) ->
 
-\begin{code}
-tcApp	:: (TypecheckedExpr -> [TypecheckedExpr] -> TypecheckedExpr)	-- Result builder
-	-> E
-	-> RenamedExpr
-	-> [RenamedExpr]
-	-> TcM (TypecheckedExpr, LIE, UniType)
-
-tcApp build_result_expression e orig_fun arg_exprs
-  = tcExpr' e orig_fun (length arg_exprs)
-			`thenTc` \ (fun', lie_fun, fun_ty) ->
-    unify_fun 1 fun' lie_fun arg_exprs fun_ty
- where
-    -- Used only in the error message
-    maybe_fun_id = case orig_fun of
-			Var name -> Just (lookupE_Value e name)
-			other	 -> Nothing
-
-    unify_args	:: Int			-- Current argument number
-		-> TypecheckedExpr	-- Current rebuilt expression
-		-> LIE			-- Corresponding LIE
-		-> [RenamedExpr]	-- Remaining args
-		-> [TauType]		-- Remaining arg types
-		-> TauType		-- result type
-		-> TcM (TypecheckedExpr, LIE, UniType)
-
-    unify_args arg_no fun lie (arg:args) (arg_ty:arg_tys) fun_res_ty
-      = tcExpr e arg		`thenTc` \ (arg', lie_arg, actual_arg_ty) ->
-
-	-- These applyTcSubstToTy's are just to improve the error message...
-	applyTcSubstToTy actual_arg_ty	`thenNF_Tc` \ actual_arg_ty' -> 
-	applyTcSubstToTy arg_ty		`thenNF_Tc` \ arg_ty' -> 
-	let
-	    err_ctxt = FunAppCtxt orig_fun maybe_fun_id arg arg_ty' actual_arg_ty' arg_no
-	in
-	matchArgTy e arg_ty' arg' lie_arg actual_arg_ty' err_ctxt
-					`thenTc` \ (arg'', lie_arg') ->
-
-	unify_args (arg_no+1) (App fun arg'') (lie `plusLIE` lie_arg') args arg_tys fun_res_ty
-
-    unify_args arg_no fun lie [] arg_tys fun_res_ty
-      = -- We've run out of actual arguments.  Check that none of
-	-- arg_tys has a for-all at the top. For example, "build" on
-	-- its own is no good; it must be applied to something.
-	let
-	   result_ty = glueTyArgs arg_tys fun_res_ty
-	in
-	getSrcLocTc	`thenNF_Tc` \ loc ->
-	checkTc (not (isTauTy result_ty))
-		(underAppliedTyErr result_ty loc) `thenTc_`
-	returnTc (fun, lie, result_ty)
-
-    -- When we run out of arg_tys we go back to unify_fun in the hope
-    -- that our unification work may have shown up some more arguments
-    unify_args arg_no fun lie args [] fun_res_ty
-      = unify_fun arg_no fun lie args fun_res_ty
-
-
-    unify_fun	:: Int			-- Current argument number
-		-> TypecheckedExpr	-- Current rebuilt expression
-		-> LIE			-- Corresponding LIE
-		-> [RenamedExpr]	-- Remaining args
-		-> TauType		-- Remaining function type
-		-> TcM (TypecheckedExpr, LIE, UniType)
-
-    unify_fun arg_no fun lie args fun_ty
-      =		-- Find out as much as possible about the function
-	applyTcSubstToTy fun_ty		`thenNF_Tc` \ fun_ty' ->
-
-		-- Now see whether it has any arguments
-	case (splitTyArgs fun_ty') of
-
-	  ([], _) ->		-- Function has no arguments left
-
-		newOpenTyVarTy		`thenNF_Tc` \ result_ty ->
-		tcExprs e args		`thenTc`    \ (args', lie_args, arg_tys) ->
-
-		-- At this point, a unification error must mean the function is
-		-- being applied to too many arguments.
-		unifyTauTy fun_ty' (glueTyArgs arg_tys result_ty)
-				(TooManyArgsCtxt orig_fun) `thenTc_`
-
-		returnTc (build_result_expression fun args',
-			  lie `plusLIE` lie_args,
-			  result_ty)
-
-	  (fun_arg_tys, fun_res_ty) ->	-- Function has non-empty list of argument types
-
-		unify_args arg_no fun lie args fun_arg_tys fun_res_ty
+		-- Unification can't fail, since we're unifying against a tyvar
+		unifyTauTy fun_ty (mkFunTys arg_tys result_ty)	`thenTc_`
+
+		returnTc (args', lie_args, result_ty)
+
+  | otherwise
+  =	-- Must be an error: a lurking for-all, or (more commonly)
+	-- a TyConTy... we've applied the function to too many args
+    failTc (tooManyArgs orig_fun)
+
+  where
+    maybe_arrow_ty 		      = getFunTy_maybe fun_ty
+    Just (expected_arg_ty, result_ty) = maybe_arrow_ty
+
+    maybe_tyvar_ty = getTyVar_maybe fun_ty
+    Just fun_tyvar = maybe_tyvar_ty
 \end{code}
 
 \begin{code}
-matchArgTy :: E
-	 -> UniType		-- Expected argument type
-	 -> TypecheckedExpr	-- Type checked argument
-	 -> LIE			-- Actual argument LIE
-	 -> UniType		-- Actual argument type
-	 -> UnifyErrContext  
-	 -> TcM (TypecheckedExpr,	-- The incoming type checked arg,
-					--  possibly wrapped in a big lambda
-		 LIE)			-- Possibly reduced somewhat
-
-matchArgTy e expected_arg_ty arg_expr actual_arg_lie actual_arg_ty err_ctxt 
-  | isForAllTy expected_arg_ty
-  = -- Ha!  The argument type of the function is a for-all type,
-    -- An example of rank-2 polymorphism.
-
-    -- This applyTcSubstToTy is just to improve the error message..
-
-    applyTcSubstToTy actual_arg_ty		`thenNF_Tc` \ actual_arg_ty' ->
-
-    -- Instantiate the argument type
-    -- ToDo: give this a real origin
-    specTy UnknownOrigin expected_arg_ty	`thenNF_Tc` \ (arg_tyvars, arg_lie, arg_tau) ->
-
-    if not (null arg_lie) then
-	    -- Paranoia check
-	    panic "Non-null overloading in tcApp"
-    else
-	    -- Assert: arg_lie = []
+tcArg :: TcType s			-- Expected arg type
+      -> RenamedHsExpr			-- Actual argument
+      -> TcM s (TcExpr s, LIE s)	-- Resulting argument and LIE
+
+tcArg expected_arg_ty arg
+  | not (maybeToBool (getForAllTy_maybe expected_arg_ty))
+  = 	-- The ordinary, non-rank-2 polymorphic case
+    tcExpr arg					`thenTc` \ (arg', lie_arg, actual_arg_ty) ->
+    unifyTauTy expected_arg_ty actual_arg_ty	`thenTc_`
+    returnTc (arg', lie_arg)
+
+  | otherwise
+  = 	-- Ha!  The argument type of the function is a for-all type,
+	-- An example of rank-2 polymorphism.
 
-    unifyTauTy arg_tau actual_arg_ty' err_ctxt	`thenTc_`
+	-- No need to instantiate the argument type... it's must be the result
+	-- of instantiating a function involving rank-2 polymorphism, so there
+	-- isn't any danger of using the same tyvars twice
+	-- The argument type shouldn't be overloaded type (hence ASSERT)
+    let
+	(expected_tyvars, expected_theta, expected_tau) = splitSigmaTy expected_arg_ty
+    in
+    ASSERT( null expected_theta )
+
+	-- Type-check the arg and unify with expected type
+    tcExpr arg					`thenTc` \ (arg', lie_arg, actual_arg_ty) ->
+    unifyTauTy expected_tau actual_arg_ty	`thenTc_`  (
 
 	-- Check that the arg_tyvars havn't been constrained
 	-- The interesting bit here is that we must include the free variables
@@ -650,48 +565,273 @@ matchArgTy e expected_arg_ty arg_expr actual_arg_lie actual_arg_ty err_ctxt
 	-- So now s' isn't unconstrained because it's linked to a.
 	-- Conclusion: include the free vars of the expected arg type in the
 	-- list of "free vars" for the signature check.
-    applyTcSubstAndCollectTyVars 
-	(tvOfE e 	`unionLists`
-	 extractTyVarsFromTy expected_arg_ty)    `thenNF_Tc` \ free_tyvars ->
-    checkSigTyVars free_tyvars arg_tyvars arg_tau actual_arg_ty rank2_err_ctxt
-					    `thenTc` \ arg_tyvars' ->
+    tcAddErrCtxt (rank2ArgCtxt arg expected_arg_ty) $
+    tcGetGlobalTyVars						`thenNF_Tc` \ env_tyvars ->
+    zonkTcTyVars (tyVarsOfType expected_arg_ty)			`thenNF_Tc` \ free_tyvars ->
+    checkSigTyVarsGivenGlobals
+	(env_tyvars `unionTyVarSets` free_tyvars)
+	expected_tyvars expected_tau actual_arg_ty		`thenTc` \ arg_tyvars' ->
 
 	-- Check that there's no overloading involved
 	-- Even if there isn't, there may be some Insts which mention the arg_tyvars,
 	-- but which, on simplification, don't actually need a dictionary involving
 	-- the tyvar.  So we have to do a proper simplification right here.
-    let insts = unMkLIE actual_arg_lie
+    tcSimplifyRank2 (tyVarListToSet arg_tyvars') 
+		    lie_arg				`thenTc` \ (free_insts, inst_binds) ->
+
+	-- This HsLet binds any Insts which came out of the simplification.
+	-- It's a bit out of place here, but using AbsBind involves inventing
+	-- a couple of new names which seems worse.
+    returnTc (TyLam arg_tyvars' (HsLet (mk_binds inst_binds) arg'), free_insts)
+    )
+  where
+
+    mk_binds []
+	= EmptyBinds
+    mk_binds ((inst,rhs):inst_binds)
+	= (SingleBind (NonRecBind (VarMonoBind inst rhs)))
+		`ThenBinds`
+	  mk_binds inst_binds
+\end{code}
+
+%************************************************************************
+%*									*
+\subsection{@tcId@ typchecks an identifier occurrence}
+%*									*
+%************************************************************************
+
+\begin{code}
+tcId :: Name -> TcM s (TcExpr s, LIE s, TcType s)
+tcId name
+  = 	-- Look up the Id and instantiate its type
+    (tcLookupLocalValue name	`thenNF_Tc` \ maybe_local ->
+     case maybe_local of
+	Just tc_id -> tcInstTcType [] (idType tc_id)	`thenNF_Tc` \ ty ->
+		      returnNF_Tc (TcId tc_id, ty)
+
+	Nothing ->    tcLookupGlobalValue name		`thenNF_Tc` \ id ->
+		      tcInstType [] (idType id)		`thenNF_Tc` \ ty ->
+		      returnNF_Tc (RealId id, ty)
+    )							`thenNF_Tc` \ (tc_id_occ, ty) ->
+    let
+	(tyvars, rho) = splitForAllTy ty
+	(theta,tau)   = splitRhoTy rho
+	arg_tys	      = map mkTyVarTy tyvars
     in
-    applyTcSubstToInsts insts		 `thenNF_Tc` \ insts' ->
+	-- Is it overloaded?
+    case theta of
+      [] -> 	-- Not overloaded, so just make a type application
+	    returnTc (TyApp (HsVar tc_id_occ) arg_tys, emptyLIE, tau)
+
+      _  ->	-- Overloaded, so make a Method inst
+	    newMethodWithGivenTy (OccurrenceOf tc_id_occ)
+			tc_id_occ arg_tys rho		`thenNF_Tc` \ (lie, meth_id) ->
+	    returnTc (HsVar meth_id, lie, tau)
+\end{code}
 
-    tcSimplifyRank2 arg_tyvars' insts' rank2_err_ctxt	`thenTc` \ (free_insts, inst_binds) ->
 
-	-- This Let binds any Insts which came out of the simplification.
-	-- It's a bit out of place here, but using AbsBind involves inventing 
-	-- a couple of new names which seems worse. 
-    returnTc (TyLam arg_tyvars' (Let (mk_binds inst_binds) arg_expr), mkLIE free_insts)
 
-  | otherwise
-  = 	-- The ordinary, non-rank-2 polymorphic case
-    unifyTauTy expected_arg_ty actual_arg_ty err_ctxt	`thenTc_`
-    returnTc (arg_expr, actual_arg_lie)
+%************************************************************************
+%*									*
+\subsection{@tcQuals@ typchecks list comprehension qualifiers}
+%*									*
+%************************************************************************
+
+\begin{code}
+tcListComp expr []
+  = tcExpr expr		`thenTc` \ (expr', lie, ty) ->
+    returnTc ((expr',[]), lie, mkListTy ty)
+
+tcListComp expr (qual@(FilterQual filter) : quals)
+  = tcAddErrCtxt (qualCtxt qual) (
+	tcExpr filter			`thenTc` \ (filter', filter_lie, filter_ty) ->
+	unifyTauTy boolTy filter_ty	`thenTc_`
+	returnTc (FilterQual filter', filter_lie)
+    )					`thenTc` \ (qual', qual_lie) ->
+
+    tcListComp expr quals	`thenTc` \ ((expr',quals'), rest_lie, res_ty) ->
+
+    returnTc ((expr', qual' : quals'), 
+	      qual_lie `plusLIE` rest_lie,
+	      res_ty)
+
+tcListComp expr (qual@(GeneratorQual pat rhs) : quals)
+  = newMonoIds binder_names mkBoxedTypeKind (\ ids ->
+
+      tcAddErrCtxt (qualCtxt qual) (
+        tcPat pat				`thenTc` \ (pat',  lie_pat,  pat_ty)  ->
+        tcExpr rhs				`thenTc` \ (rhs', lie_rhs, rhs_ty) ->
+        unifyTauTy (mkListTy pat_ty) rhs_ty	`thenTc_`
+	returnTc (GeneratorQual pat' rhs', 
+		  lie_pat `plusLIE` lie_rhs) 
+      )						`thenTc` \ (qual', lie_qual) ->
+
+      tcListComp expr quals 			`thenTc` \ ((expr',quals'), lie_rest, res_ty) ->
+
+      returnTc ((expr', qual' : quals'), 
+		lie_qual `plusLIE` lie_rest,
+	        res_ty)
+    )
+  where
+    binder_names = collectPatBinders pat
 
+tcListComp expr (LetQual binds : quals)
+  = tcBindsAndThen		-- No error context, but a binding group is
+	combine			-- rather a large thing for an error context anyway
+	binds
+	(tcListComp expr quals)
   where
-    rank2_err_ctxt = Rank2ArgCtxt arg_expr expected_arg_ty
+    combine binds' (expr',quals') = (expr', LetQual binds' : quals')
+\end{code}
+
+
+%************************************************************************
+%*									*
+\subsection{@tcDoStmts@ typechecks a {\em list} of do statements}
+%*									*
+%************************************************************************
+
+\begin{code}
+tcDoStmts :: Bool			-- True => require a monad
+	  -> TcType s			-- m
+	  -> [RenamedStmt]	
+	  -> TcM s (([TcStmt s],
+		     Bool,		-- True => Monad
+		     Bool), 		-- True => MonadZero
+		    LIE s,
+		    TcType s)
+					
+tcDoStmts monad m [stmt@(ExprStmt exp src_loc)]
+  = tcAddSrcLoc src_loc $
+    tcSetErrCtxt (stmtCtxt stmt) $
+    tcExpr exp			 	`thenTc`    \ (exp', exp_lie, exp_ty) ->
+    (if monad then
+	newTyVarTy mkTypeKind		`thenNF_Tc` \ a ->
+	unifyTauTy (mkAppTy m a) exp_ty
+     else
+	returnTc ()
+    )					`thenTc_`
+    returnTc (([ExprStmt exp' src_loc], monad, False), exp_lie, exp_ty)
+
+tcDoStmts _ m (stmt@(ExprStmt exp src_loc) : stmts)
+  = tcAddSrcLoc src_loc 		(
+    tcSetErrCtxt (stmtCtxt stmt)	(
+    	tcExpr exp			`thenTc`    \ (exp', exp_lie, exp_ty) ->
+	newTyVarTy mkTypeKind		`thenNF_Tc` \ a ->
+    	unifyTauTy (mkAppTy m a) exp_ty	`thenTc_`
+	returnTc (ExprStmt exp' src_loc, exp_lie)
+    ))					`thenTc` \ (stmt',  stmt_lie) -> 
+    tcDoStmts True m stmts		`thenTc` \ ((stmts', _, mzero), stmts_lie, stmts_ty) ->
+    returnTc ((stmt':stmts', True, mzero),
+	      stmt_lie `plusLIE` stmts_lie,
+	      stmts_ty)
+
+tcDoStmts _ m (stmt@(BindStmt pat exp src_loc) : stmts)
+  = tcAddSrcLoc src_loc			(
+    tcSetErrCtxt (stmtCtxt stmt)	(
+	tcPat pat			`thenTc`    \ (pat', pat_lie, pat_ty) ->  
+    	tcExpr exp			`thenTc`    \ (exp', exp_lie, exp_ty) ->
+	newTyVarTy mkTypeKind		`thenNF_Tc` \ a ->
+	unifyTauTy a pat_ty		`thenTc_`
+	unifyTauTy (mkAppTy m a) exp_ty	`thenTc_`
+	returnTc (BindStmt pat' exp' src_loc, pat_lie `plusLIE` exp_lie, irrefutablePat pat')
+    ))					`thenTc` \ (stmt', stmt_lie, failure_free) -> 
+    tcDoStmts True m stmts		`thenTc` \ ((stmts', _, mzero), stmts_lie, stmts_ty) ->
+    returnTc ((stmt':stmts', True, mzero || not failure_free),
+	      stmt_lie `plusLIE` stmts_lie,
+	      stmts_ty)
+
+tcDoStmts monad m (LetStmt binds : stmts)
+   = tcBindsAndThen		-- No error context, but a binding group is
+	combine			-- rather a large thing for an error context anyway
+	binds
+	(tcDoStmts monad m stmts)
+   where
+     combine binds' (stmts', monad, mzero) = ((LetStmt binds' : stmts'), monad, mzero)
 
-    mk_binds [] 		     = EmptyBinds
-    mk_binds ((inst,rhs):inst_binds) = (SingleBind (NonRecBind (VarMonoBind (mkInstId inst) rhs)))
-					    `ThenBinds`
-					    mk_binds inst_binds
 \end{code}
 
-This version only does not check for 2nd order if it is applied.
+%************************************************************************
+%*									*
+\subsection{@tcExprs@ typechecks a {\em list} of expressions}
+%*									*
+%************************************************************************
 
 \begin{code}
-tcExpr' :: E -> RenamedExpr -> Int -> TcM (TypecheckedExpr,LIE,UniType)
+tcExprs :: [RenamedHsExpr] -> TcM s ([TcExpr s], LIE s, [TcType s])
+
+tcExprs [] = returnTc ([], emptyLIE, [])
+tcExprs (expr:exprs)
+ = tcExpr  expr			`thenTc` \ (expr',  lie1, ty) ->
+   tcExprs exprs		`thenTc` \ (exprs', lie2, tys) ->
+   returnTc (expr':exprs', lie1 `plusLIE` lie2, ty:tys)
+\end{code}
 
-tcExpr' e v@(Var name) n 
-      | n > 0 = specId (lookupE_Value e name)	`thenNF_Tc` \ (expr, lie, ty) ->
-    returnTc (expr, lie, ty)
-tcExpr' e exp n = tcExpr e exp
+
+% =================================================
+
+Errors and contexts
+~~~~~~~~~~~~~~~~~~~
+
+Mini-utils:
+\begin{code}
+pp_nest_hang :: String -> Pretty -> Pretty
+pp_nest_hang label stuff = ppNest 2 (ppHang (ppStr label) 4 stuff)
 \end{code}
+
+Boring and alphabetical:
+\begin{code}
+arithSeqCtxt expr sty
+  = ppHang (ppStr "In an arithmetic sequence:") 4 (ppr sty expr)
+
+branchCtxt b1 b2 sty
+  = ppSep [ppStr "In the branches of a conditional:",
+	   pp_nest_hang "`then' branch:" (ppr sty b1),
+	   pp_nest_hang "`else' branch:" (ppr sty b2)]
+
+caseCtxt expr sty
+  = ppHang (ppStr "In a case expression:") 4 (ppr sty expr)
+
+exprSigCtxt expr sty
+  = ppHang (ppStr "In an expression with a type signature:")
+	 4 (ppr sty expr)
+
+listCtxt expr sty
+  = ppHang (ppStr "In a list expression:") 4 (ppr sty expr)
+
+predCtxt expr sty
+  = ppHang (ppStr "In a predicate expression:") 4 (ppr sty expr)
+
+sectionRAppCtxt expr sty
+  = ppHang (ppStr "In a right section:") 4 (ppr sty expr)
+
+sectionLAppCtxt expr sty
+  = ppHang (ppStr "In a left section:") 4 (ppr sty expr)
+
+funAppCtxt fun arg_no arg sty
+  = ppHang (ppCat [ ppStr "In the", speakNth arg_no, ppStr "argument of", ppr sty fun])
+	 4 (ppCat [ppStr "namely", ppr sty arg])
+
+qualCtxt qual sty
+  = ppHang (ppStr "In a list-comprehension qualifer:") 
+         4 (ppr sty qual)
+
+stmtCtxt stmt sty
+  = ppHang (ppStr "In a do statement:") 
+         4 (ppr sty stmt)
+
+tooManyArgs f sty
+  = ppHang (ppStr "Too many arguments in an application of the function")
+	 4 (ppr sty f)
+
+lurkingRank2Err fun fun_ty sty
+  = ppHang (ppCat [ppStr "Illegal use of", ppr sty fun])
+	 4 (ppAboves [ppStr "It is applied to too few arguments,", 
+		      ppStr "so that the result type has for-alls in it"])
+
+rank2ArgCtxt arg expected_arg_ty sty
+  = ppHang (ppStr "In a polymorphic function argument:")
+	 4 (ppSep [ppBeside (ppr sty arg) (ppStr " ::"),
+		   ppr sty expected_arg_ty])
+\end{code}
+
diff --git a/ghc/compiler/typecheck/TcGRHSs.hi b/ghc/compiler/typecheck/TcGRHSs.hi
deleted file mode 100644
index 35dc01d1d1..0000000000
--- a/ghc/compiler/typecheck/TcGRHSs.hi
+++ /dev/null
@@ -1,18 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface TcGRHSs where
-import Bag(Bag)
-import CmdLineOpts(GlobalSwitch)
-import E(E)
-import HsMatches(GRHSsAndBinds)
-import HsPat(InPat, TypecheckedPat)
-import Id(Id)
-import LIE(LIE)
-import Name(Name)
-import Pretty(PprStyle, PrettyRep)
-import SplitUniq(SplitUniqSupply)
-import SrcLoc(SrcLoc)
-import Subst(Subst)
-import TcMonad(TcResult)
-import UniType(UniType)
-tcGRHSsAndBinds :: E -> GRHSsAndBinds Name (InPat Name) -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult (GRHSsAndBinds Id TypecheckedPat, LIE, UniType)
-
diff --git a/ghc/compiler/typecheck/TcGRHSs.lhs b/ghc/compiler/typecheck/TcGRHSs.lhs
index a66c33af73..a5d1fc06d7 100644
--- a/ghc/compiler/typecheck/TcGRHSs.lhs
+++ b/ghc/compiler/typecheck/TcGRHSs.lhs
@@ -6,52 +6,49 @@
 \begin{code}
 module TcGRHSs ( tcGRHSsAndBinds ) where
 
-import TcMonad		-- typechecking monad machinery
-import AbsSyn		-- the stuff being typechecked
+import Ubiq{-uitous-}
+import TcLoop -- for paranoia checking
 
-import AbsPrel		( boolTy )
-import E		( growE_LVE, E, LVE(..), TCE(..), UniqFM, CE(..) )
-			-- TCE and CE for pragmas only
-import Errors		( UnifyErrContext(..) )
-import LIE		( plusLIE, LIE )
-import TcBinds		( tcLocalBindsAndThen )
+import HsSyn		( GRHSsAndBinds(..), GRHS(..),
+			  HsExpr, HsBinds(..), InPat, OutPat, Bind, Sig, Fake )
+import RnHsSyn		( RenamedGRHSsAndBinds(..), RenamedGRHS(..) )
+import TcHsSyn		( TcGRHSsAndBinds(..), TcGRHS(..), TcIdOcc(..) )
+
+import TcMonad
+import Inst		( Inst, LIE(..), plusLIE )
+import TcBinds		( tcBindsAndThen )
 import TcExpr		( tcExpr )
+import TcType		( TcType(..) ) 
 import Unify		( unifyTauTy )
-import Util		-- pragmas only
+
+import PrelInfo		( boolTy )
 \end{code}
 
 \begin{code}
-tcGRHSs :: E -> [RenamedGRHS] -> TcM ([TypecheckedGRHS], LIE, UniType)
+tcGRHSs :: [RenamedGRHS] -> TcM s ([TcGRHS s], LIE s, TcType s)
 
-tcGRHSs e [grhs]
-  = tcGRHS e grhs	`thenTc` \ (grhs', lie, ty) ->
+tcGRHSs [grhs]
+  = tcGRHS grhs		`thenTc` \ (grhs', lie, ty) ->
     returnTc ([grhs'], lie, ty)
 
-tcGRHSs e gs@(grhs:grhss)
-  = tcGRHS  e grhs	`thenTc` \ (grhs',  lie1, ty1) ->
-    tcGRHSs e grhss	`thenTc` \ (grhss', lie2, ty2) ->
-
-    unifyTauTy ty1 ty2 (GRHSsBranchCtxt gs) `thenTc_`
-
+tcGRHSs (grhs:grhss)
+  = tcGRHS  grhs	`thenTc` \ (grhs',  lie1, ty1) ->
+    tcGRHSs grhss	`thenTc` \ (grhss', lie2, ty2) ->
+    unifyTauTy ty1 ty2	`thenTc_`
     returnTc (grhs' : grhss', lie1 `plusLIE` lie2, ty1)
 
 
-tcGRHS e (OtherwiseGRHS expr locn)
-  = addSrcLocTc locn	 (
-    tcExpr e expr	`thenTc` \ (expr, lie, ty) ->
+tcGRHS (OtherwiseGRHS expr locn)
+  = tcAddSrcLoc locn	 $
+    tcExpr expr	`thenTc` \ (expr, lie, ty) ->
     returnTc (OtherwiseGRHS expr locn, lie, ty)
-    )
-
-tcGRHS e (GRHS guard expr locn)
-  = addSrcLocTc locn		 (
-    tcExpr e guard		`thenTc` \ (guard2, guard_lie, guard_ty) ->
-
-    unifyTauTy guard_ty boolTy (GRHSsGuardCtxt guard) `thenTc_`
-
-    tcExpr e expr		`thenTc` \ (expr2, expr_lie, expr_ty) ->
 
+tcGRHS (GRHS guard expr locn)
+  = tcAddSrcLoc locn		$
+    tcExpr guard		`thenTc` \ (guard2, guard_lie, guard_ty) ->
+    unifyTauTy boolTy guard_ty	`thenTc_`
+    tcExpr expr			`thenTc` \ (expr2, expr_lie, expr_ty) ->
     returnTc (GRHS guard2 expr2 locn, plusLIE guard_lie expr_lie, expr_ty)
-    )
 \end{code}
 
 
@@ -59,18 +56,16 @@ tcGRHS e (GRHS guard expr locn)
 pieces.
 
 \begin{code}
-tcGRHSsAndBinds :: E 
-		-> RenamedGRHSsAndBinds
-		-> TcM (TypecheckedGRHSsAndBinds, LIE, UniType)
-
-tcGRHSsAndBinds e (GRHSsAndBindsIn grhss binds)
-  = tcLocalBindsAndThen e 
-	 combiner binds 
-	 (\e -> tcGRHSs e grhss		`thenTc` (\ (grhss', lie, ty) ->
-		returnTc (GRHSsAndBindsOut grhss' EmptyBinds ty, lie, ty) 
-		)
+tcGRHSsAndBinds :: RenamedGRHSsAndBinds
+		-> TcM s (TcGRHSsAndBinds s, LIE s, TcType s)
+
+tcGRHSsAndBinds (GRHSsAndBindsIn grhss binds)
+  = tcBindsAndThen
+	 combiner binds
+	 (tcGRHSs grhss		`thenTc` \ (grhss', lie, ty) ->
+	  returnTc (GRHSsAndBindsOut grhss' EmptyBinds ty, lie, ty)
 	 )
   where
-    combiner binds1 (GRHSsAndBindsOut grhss binds2 ty)
-	= GRHSsAndBindsOut grhss (binds1 `ThenBinds` binds2) ty
+    combiner binds1 (GRHSsAndBindsOut grhss binds2 ty) 
+ 	= GRHSsAndBindsOut grhss (binds1 `ThenBinds` binds2) ty
 \end{code}
diff --git a/ghc/compiler/typecheck/TcGenDeriv.hi b/ghc/compiler/typecheck/TcGenDeriv.hi
deleted file mode 100644
index ea99ed7218..0000000000
--- a/ghc/compiler/typecheck/TcGenDeriv.hi
+++ /dev/null
@@ -1,53 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface TcGenDeriv where
-import HsBinds(MonoBinds)
-import HsDecls(FixityDecl)
-import HsExpr(Expr)
-import HsPat(InPat)
-import Name(Name)
-import ProtoName(ProtoName)
-import TcDeriv(TagThingWanted)
-import TyCon(TyCon)
-a_Expr :: Expr ProtoName a
-a_PN :: ProtoName
-a_Pat :: InPat ProtoName
-ah_PN :: ProtoName
-b_Expr :: Expr ProtoName a
-b_PN :: ProtoName
-b_Pat :: InPat ProtoName
-bh_PN :: ProtoName
-c_Expr :: Expr ProtoName a
-c_PN :: ProtoName
-c_Pat :: InPat ProtoName
-ch_PN :: ProtoName
-cmp_eq_PN :: ProtoName
-d_Expr :: Expr ProtoName a
-d_PN :: ProtoName
-d_Pat :: InPat ProtoName
-dh_PN :: ProtoName
-eqH_PN :: ProtoName
-eq_TAG_Expr :: Expr ProtoName a
-eq_TAG_PN :: ProtoName
-error_PN :: ProtoName
-false_Expr :: Expr ProtoName a
-false_PN :: ProtoName
-geH_PN :: ProtoName
-gen_Binary_binds :: TyCon -> MonoBinds ProtoName (InPat ProtoName)
-gen_Enum_binds :: TyCon -> MonoBinds ProtoName (InPat ProtoName)
-gen_Eq_binds :: TyCon -> MonoBinds ProtoName (InPat ProtoName)
-gen_Ix_binds :: TyCon -> MonoBinds ProtoName (InPat ProtoName)
-gen_Ord_binds :: TyCon -> MonoBinds ProtoName (InPat ProtoName)
-gen_Text_binds :: [FixityDecl Name] -> Bool -> TyCon -> MonoBinds ProtoName (InPat ProtoName)
-gen_tag_n_con_monobind :: (ProtoName, Name, TyCon, TagThingWanted) -> MonoBinds ProtoName (InPat ProtoName)
-gt_TAG_Expr :: Expr ProtoName a
-gt_TAG_PN :: ProtoName
-leH_PN :: ProtoName
-ltH_PN :: ProtoName
-lt_TAG_Expr :: Expr ProtoName a
-lt_TAG_PN :: ProtoName
-minusH_PN :: ProtoName
-mkInt_PN :: ProtoName
-rangeSize_PN :: ProtoName
-true_Expr :: Expr ProtoName a
-true_PN :: ProtoName
-
diff --git a/ghc/compiler/typecheck/TcGenDeriv.lhs b/ghc/compiler/typecheck/TcGenDeriv.lhs
index c22ae5bbf4..6a701272ef 100644
--- a/ghc/compiler/typecheck/TcGenDeriv.lhs
+++ b/ghc/compiler/typecheck/TcGenDeriv.lhs
@@ -30,8 +30,8 @@ module TcGenDeriv (
 	d_Pat,
 	dh_PN,
 	eqH_PN,
-	eq_TAG_Expr,
-	eq_TAG_PN,
+	eqTag_Expr,
+	eq_PN,
 	error_PN,
 	false_Expr,
 	false_PN,
@@ -41,51 +41,54 @@ module TcGenDeriv (
 	gen_Eq_binds,
 	gen_Ix_binds,
 	gen_Ord_binds,
-	gen_Text_binds,
+	gen_Read_binds,
+	gen_Show_binds,
 	gen_tag_n_con_monobind,
-	gt_TAG_Expr,
-	gt_TAG_PN,
+	gtTag_Expr,
+	gt_PN,
 	leH_PN,
 	ltH_PN,
-	lt_TAG_Expr,
-	lt_TAG_PN,
+	ltTag_Expr,
+	lt_PN,
 	minusH_PN,
 	mkInt_PN,
 	rangeSize_PN,
 	true_Expr,
-	true_PN
+	true_PN,
+
+	con2tag_FN, tag2con_FN, maxtag_FN,
+	con2tag_PN, tag2con_PN, maxtag_PN,
+
+	TagThingWanted(..)
     ) where
 
-IMPORT_Trace		-- ToDo:rm debugging
-import Outputable
-import Pretty
+import Ubiq
 
-import AbsSyn		-- the stuff being typechecked
-
-import AbsPrel
-import PrimOps
-
-import AbsUniType	( getTyConDataCons, isEnumerationTyCon,
-			  maybeSingleConstructorTyCon, --UNUSED: preludeClassDerivedFor,
-			  -- UNUSED: isEnumerationTyConMostly,
-			  isPrimType, UniType,
-			  TauType(..), TyVarTemplate, ThetaType(..)
-			  IF_ATTACK_PRAGMAS(COMMA cmpUniType)
-			)
-import Id		( getDataConArity, getDataConTag,
-			  getDataConSig, isNullaryDataCon, fIRST_TAG,
-			  isDataCon, DataCon(..), ConTag(..), Id
-			)
-import Maybes		( maybeToBool, Maybe(..) )
+import HsSyn		( HsBinds(..), Bind(..), MonoBinds(..), Match(..), GRHSsAndBinds(..),
+			  GRHS(..), HsExpr(..), HsLit(..), InPat(..), Qual(..), Stmt,
+			  ArithSeqInfo, Sig, PolyType, FixityDecl, Fake )
+import RdrHsSyn		( ProtoNameMonoBinds(..), ProtoNameHsExpr(..), ProtoNamePat(..) )
+import RnHsSyn		( RenamedFixityDecl(..) )
+
+import RnMonad4		-- initRn4, etc.
+import RnUtils
+
+import Id		( GenId, getDataConArity, getDataConTag,
+			  getDataConSig, fIRST_TAG,
+			  isDataCon, DataCon(..), ConTag(..) )
+import IdUtils		( primOpId )
+import Maybes		( maybeToBool )
 import Name		( Name(..) )
+import NameTypes	( mkFullName, Provenance(..) )
+import Outputable
+import PrimOp
+import PrelInfo
+import Pretty
 import ProtoName	( ProtoName(..) )
-import RenameAuxFuns	-- why not? take all of it...
-import RenameMonad4	-- initRn4, etc.
 import SrcLoc		( mkGeneratedSrcLoc )
-import TcDeriv		( con2tag_PN, tag2con_PN, maxtag_PN,
-			  TagThingWanted(..), DerivEqn(..)
-			)
-import Unique		-- some ClassKey stuff
+import TyCon		( TyCon, getTyConDataCons, isEnumerationTyCon, maybeTyConSingleCon )
+import Type		( eqTy, isPrimType )
+import Unique
 import Util
 \end{code}
 
@@ -160,8 +163,8 @@ case (a1 `eqFloat#` a2) of
   tycon, we generate:
 \begin{verbatim}
 instance ... Eq (Foo ...) where
-  (==) a b  = case (tagCmp a b) of { _LT -> False; _EQ -> True ; _GT -> False}
-  (/=) a b  = case (tagCmp a b) of { _LT -> True ; _EQ -> False; _GT -> True }
+  (==) a b  = case (compare a b) of { _LT -> False; _EQ -> True ; _GT -> False}
+  (/=) a b  = case (compare a b) of { _LT -> True ; _EQ -> False; _GT -> True }
 \begin{verbatim}
   However, that requires that \tr{Ord <whatever>} was put in the context
   for the instance decl, which it probably wasn't, so the decls
@@ -172,24 +175,25 @@ instance ... Eq (Foo ...) where
 gen_Eq_binds :: TyCon -> ProtoNameMonoBinds
 
 gen_Eq_binds tycon
-  = case (partition isNullaryDataCon (getTyConDataCons tycon))
-				of { (nullary_cons, nonnullary_cons) ->
+  = case (partition (\ con -> getDataConArity con == 0)
+		    (getTyConDataCons tycon))
+    of { (nullary_cons, nonnullary_cons) ->
     let
 	rest
 	  = if null nullary_cons then
-		case maybeSingleConstructorTyCon tycon of
+		case maybeTyConSingleCon tycon of
 		  Just _ -> []
 		  Nothing -> -- if cons don't match, then False
 		     [([a_Pat, b_Pat], false_Expr)]
 	    else -- calc. and compare the tags
-		 [([a_Pat, b_Pat], 
+		 [([a_Pat, b_Pat],
 		    untag_Expr tycon [(a_PN,ah_PN), (b_PN,bh_PN)]
 		      (cmp_tags_Expr eqH_PN ah_PN bh_PN true_Expr false_Expr))]
     in
     mk_FunMonoBind eq_PN ((map pats_etc nonnullary_cons) ++ rest)
     `AndMonoBinds` boring_ne_method
     }
-  where    
+  where
     ------------------------------------------------------------------
     pats_etc data_con
       = let
@@ -201,20 +205,20 @@ gen_Eq_binds tycon
 	    bs_needed   = take (getDataConArity data_con) bs_PNs
 	    tys_needed  = case (getDataConSig data_con) of
 			    (_,_, arg_tys, _) -> arg_tys
-        in
+	in
 	([con1_pat, con2_pat], nested_eq_expr tys_needed as_needed bs_needed)
       where
 	nested_eq_expr []     []     []  = true_Expr
-	nested_eq_expr [ty]   [a]    [b] = eq_Expr ty (Var a) (Var b)
+	nested_eq_expr [ty]   [a]    [b] = eq_Expr ty (HsVar a) (HsVar b)
 	nested_eq_expr (t:ts) (a:as) (b:bs)
 	  = let
 		rest_expr = nested_eq_expr ts as bs
 	    in
-	    and_Expr (eq_Expr t (Var a) (Var b)) rest_expr
+	    and_Expr (eq_Expr t (HsVar a) (HsVar b)) rest_expr
 
 boring_ne_method
   = mk_easy_FunMonoBind ne_PN [a_Pat, b_Pat] [] (
-	App (Var not_PN) (App (App (Var eq_PN) a_Expr) b_Expr)
+	HsApp (HsVar not_PN) (HsApp (HsApp (HsVar eq_PN) a_Expr) b_Expr)
 	)
 \end{code}
 
@@ -224,19 +228,12 @@ boring_ne_method
 %*									*
 %************************************************************************
 
-For a derived @Ord@, we concentrate our attentions on the non-standard
-@_tagCmp@ method, which type:
+For a derived @Ord@, we concentrate our attentions on @compare@
 \begin{verbatim}
-_tagCmp :: a -> a -> _CMP_TAG
-
--- and the builtin tag type is:
-
-data _CMP_TAG = _LT | _EQ | _GT deriving ()
+compare :: a -> a -> Ordering
+data Ordering = LT | EQ | GT deriving ()
 \end{verbatim}
 
-(All this @_tagCmp@ stuff is due to the sterling analysis by Julian
-Seward.)
-
 We will use the same example data type as above:
 \begin{verbatim}
 data Foo ... = N1 | N2 ... | Nn | O1 a b | O2 Int | O3 Double b b | ...
@@ -244,33 +241,33 @@ data Foo ... = N1 | N2 ... | Nn | O1 a b | O2 Int | O3 Double b b | ...
 
 \begin{itemize}
 \item
-  We do all the other @Ord@ methods with calls to @_tagCmp@:
+  We do all the other @Ord@ methods with calls to @compare@:
 \begin{verbatim}
 instance ... (Ord <wurble> <wurble>) where
-    a <  b  = case _tagCmp a b of { _LT -> True;  _EQ -> False; _GT -> False }
-    a <= b  = case _tagCmp a b of { _LT -> True;  _EQ -> True;  _GT -> False }
-    a >= b  = case _tagCmp a b of { _LT -> False; _EQ -> True;  _GT -> True  }
-    a >  b  = case _tagCmp a b of { _LT -> False; _EQ -> False; _GT -> True  }
+    a <  b  = case compare a b of { LT -> True;  EQ -> False; GT -> False }
+    a <= b  = case compare a b of { LT -> True;  EQ -> True;  GT -> False }
+    a >= b  = case compare a b of { LT -> False; EQ -> True;  GT -> True  }
+    a >  b  = case compare a b of { LT -> False; EQ -> False; GT -> True  }
 
-    max a b = case _tagCmp a b of { _LT -> b; _EQ -> a;  _GT -> a }
-    min a b = case _tagCmp a b of { _LT -> a; _EQ -> a;  _GT -> b }
+    max a b = case compare a b of { LT -> b; EQ -> a;  GT -> a }
+    min a b = case compare a b of { LT -> a; EQ -> b;  GT -> b }
 
-    -- _tagCmp to come...
+    -- compare to come...
 \end{verbatim}
 
 \item
-  @_tagCmp@ always has two parts.  First, we use the compared
+  @compare@ always has two parts.  First, we use the compared
   data-constructors' tags to deal with the case of different
   constructors:
 \begin{verbatim}
-_tagCmp a b = case (con2tag_Foo a) of { a# ->
-	     case (con2tag_Foo b) of { b# ->
-	     case (a# ==# b#)  	 of {
+compare a b = case (con2tag_Foo a) of { a# ->
+	      case (con2tag_Foo b) of { b# ->
+	      case (a# ==# b#)  	 of {
 	       True  -> cmp_eq a b
 	       False -> case (a# <# b#) of
 			 True  -> _LT
 			 False -> _GT
-	     }}}
+	      }}}
   where
     cmp_eq = ... to come ...
 \end{verbatim}
@@ -280,23 +277,23 @@ _tagCmp a b = case (con2tag_Foo a) of { a# ->
   comparing data constructors with the same tag.
 
   For the ordinary constructors (if any), we emit the sorta-obvious
-  tagCmp-style stuff; for our example:
+  compare-style stuff; for our example:
 \begin{verbatim}
 cmp_eq (O1 a1 b1) (O1 a2 b2)
-  = case (_tagCmp a1 a2) of { _LT -> _LT; _EQ -> _tagCmp b1 b2; _GT -> _GT }
+  = case (compare a1 a2) of { LT -> LT; EQ -> compare b1 b2; GT -> GT }
 
 cmp_eq (O2 a1) (O2 a2)
-  = _tagCmp a1 a2
+  = compare a1 a2
 
 cmp_eq (O3 a1 b1 c1) (O3 a2 b2 c2)
-  = case (_tagCmp a1 a2) of {
-      _LT -> _LT;
-      _GT -> _GT;
-      _EQ -> case _tagCmp b1 b2 of {
-		  _LT -> _LT;
-		  _GT -> _GT;
-		  _EQ -> _tagCmp c1 c2
-		}
+  = case (compare a1 a2) of {
+      LT -> LT;
+      GT -> GT;
+      EQ -> case compare b1 b2 of {
+	      LT -> LT;
+	      GT -> GT;
+	      EQ -> compare c1 c2
+	    }
     }
 \end{verbatim}
 
@@ -305,7 +302,7 @@ cmp_eq (O3 a1 b1 c1) (O3 a2 b2 c2)
   generate:
 \begin{verbatim}
 cmp_eq lt eq gt (O2 a1) (O2 a2)
-  = tagCmpInt# a1 a2
+  = compareInt# a1 a2
   -- or maybe the unfolded equivalent
 \end{verbatim}
 
@@ -313,7 +310,7 @@ cmp_eq lt eq gt (O2 a1) (O2 a2)
   For the remaining nullary constructors, we already know that the
   tags are equal so:
 \begin{verbatim}
-cmp_eq _ _ = _EQ
+cmp_eq _ _ = EQ
 \end{verbatim}
 \end{itemize}
 
@@ -321,14 +318,14 @@ cmp_eq _ _ = _EQ
 gen_Ord_binds :: TyCon -> ProtoNameMonoBinds
 
 gen_Ord_binds tycon
-  = defaulted `AndMonoBinds` tagCmp
+  = defaulted `AndMonoBinds` compare
   where
     --------------------------------------------------------------------
-    tagCmp = mk_easy_FunMonoBind tagCmp_PN
+    compare = mk_easy_FunMonoBind compare_PN
 		[a_Pat, b_Pat]
 		[cmp_eq]
-	    (if maybeToBool (maybeSingleConstructorTyCon tycon) then
-		cmp_eq_Expr lt_TAG_Expr eq_TAG_Expr gt_TAG_Expr a_Expr b_Expr
+	    (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_PN ah_PN bh_PN
@@ -336,23 +333,23 @@ gen_Ord_binds tycon
 			-- If an enumeration type we are done; else
 			-- recursively compare their components
 		    (if isEnumerationTyCon tycon then
-			eq_TAG_Expr
+			eqTag_Expr
 		     else
-			cmp_eq_Expr lt_TAG_Expr eq_TAG_Expr gt_TAG_Expr a_Expr b_Expr
+			cmp_eq_Expr ltTag_Expr eqTag_Expr gtTag_Expr a_Expr b_Expr
 		    )
 			-- False case; they aren't equal
 			-- So we need to do a less-than comparison on the tags
-		    (cmp_tags_Expr ltH_PN ah_PN bh_PN lt_TAG_Expr gt_TAG_Expr)))
+		    (cmp_tags_Expr ltH_PN ah_PN bh_PN ltTag_Expr gtTag_Expr)))
 
     (nullary_cons, nonnullary_cons)
-      = partition isNullaryDataCon (getTyConDataCons tycon)
+      = partition (\ con -> getDataConArity con == 0) (getTyConDataCons tycon)
 
     cmp_eq
       = mk_FunMonoBind cmp_eq_PN (map pats_etc nonnullary_cons ++ deflt_pats_etc)
       where
 	pats_etc data_con
 	  = ([con1_pat, con2_pat],
-	     nested_tagCmp_expr tys_needed as_needed bs_needed)
+	     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)
@@ -363,34 +360,34 @@ gen_Ord_binds tycon
 	    tys_needed  = case (getDataConSig data_con) of
 			    (_,_, arg_tys, _) -> arg_tys
 
-	    nested_tagCmp_expr [ty] [a] [b]
-	      = careful_tagCmp_Case ty lt_TAG_Expr eq_TAG_Expr gt_TAG_Expr (Var a) (Var b)
+	    nested_compare_expr [ty] [a] [b]
+	      = careful_compare_Case ty ltTag_Expr eqTag_Expr gtTag_Expr (HsVar a) (HsVar b)
 
-	    nested_tagCmp_expr (ty:tys) (a:as) (b:bs)
-	      = let eq_expr = nested_tagCmp_expr tys as bs
-	        in  careful_tagCmp_Case ty lt_TAG_Expr eq_expr gt_TAG_Expr (Var a) (Var b)
+	    nested_compare_expr (ty:tys) (a:as) (b:bs)
+	      = let eq_expr = nested_compare_expr tys as bs
+		in  careful_compare_Case ty ltTag_Expr eq_expr gtTag_Expr (HsVar a) (HsVar b)
 
 	deflt_pats_etc
 	  = if null nullary_cons
 	    then []
-	    else [([a_Pat, b_Pat], eq_TAG_Expr)]
+	    else [([a_Pat, b_Pat], eqTag_Expr)]
     --------------------------------------------------------------------
 
 defaulted = foldr1 AndMonoBinds [lt, le, ge, gt, max_, min_]
 
 lt = mk_easy_FunMonoBind lt_PN [a_Pat, b_Pat] [] (
-	    tagCmp_Case true_Expr  false_Expr false_Expr a_Expr b_Expr)
+	    compare_Case true_Expr  false_Expr false_Expr a_Expr b_Expr)
 le = mk_easy_FunMonoBind le_PN [a_Pat, b_Pat] [] (
-	    tagCmp_Case true_Expr  true_Expr  false_Expr a_Expr b_Expr)
+	    compare_Case true_Expr  true_Expr  false_Expr a_Expr b_Expr)
 ge = mk_easy_FunMonoBind ge_PN [a_Pat, b_Pat] [] (
-	    tagCmp_Case false_Expr true_Expr  true_Expr  a_Expr b_Expr)
+	    compare_Case false_Expr true_Expr  true_Expr  a_Expr b_Expr)
 gt = mk_easy_FunMonoBind gt_PN [a_Pat, b_Pat] [] (
-	    tagCmp_Case false_Expr false_Expr true_Expr  a_Expr b_Expr)
+	    compare_Case false_Expr false_Expr true_Expr  a_Expr b_Expr)
 
 max_ = mk_easy_FunMonoBind max_PN [a_Pat, b_Pat] [] (
-	    tagCmp_Case b_Expr a_Expr a_Expr a_Expr b_Expr)
+	    compare_Case b_Expr a_Expr a_Expr a_Expr b_Expr)
 min_ = mk_easy_FunMonoBind min_PN [a_Pat, b_Pat] [] (
-	    tagCmp_Case a_Expr a_Expr b_Expr a_Expr b_Expr)
+	    compare_Case a_Expr b_Expr b_Expr a_Expr b_Expr)
 \end{code}
 
 %************************************************************************
@@ -438,19 +435,19 @@ gen_Enum_binds tycon
     enum_from
       = mk_easy_FunMonoBind enumFrom_PN [a_Pat] [] (
 	  untag_Expr tycon [(a_PN, ah_PN)] (
-	  App (App (Var map_PN) (Var (tag2con_PN tycon))) (
+	  HsApp (HsApp (HsVar map_PN) (HsVar (tag2con_PN tycon))) (
 	      enum_from_to_Expr
-		(App (Var mkInt_PN) (Var ah_PN))
-		(Var (maxtag_PN tycon)))))
+		(HsApp (HsVar mkInt_PN) (HsVar ah_PN))
+		(HsVar (maxtag_PN tycon)))))
 
     enum_from_then
       = mk_easy_FunMonoBind enumFromThen_PN [a_Pat, b_Pat] [] (
 	  untag_Expr tycon [(a_PN, ah_PN), (b_PN, bh_PN)] (
-	  App (App (Var map_PN) (Var (tag2con_PN tycon))) (
+	  HsApp (HsApp (HsVar map_PN) (HsVar (tag2con_PN tycon))) (
 	      enum_from_then_to_Expr
-		(App (Var mkInt_PN) (Var ah_PN))
-		(App (Var mkInt_PN) (Var bh_PN))
-		(Var (maxtag_PN tycon)))))
+		(HsApp (HsVar mkInt_PN) (HsVar ah_PN))
+		(HsApp (HsVar mkInt_PN) (HsVar bh_PN))
+		(HsVar (maxtag_PN tycon)))))
 \end{code}
 
 %************************************************************************
@@ -475,7 +472,7 @@ instance ... Ix (Foo ...) where
     -- or, really...
     range (a, b)
       = case (con2tag_Foo a) of { a# ->
-        case (con2tag_Foo b) of { b# ->
+	case (con2tag_Foo b) of { b# ->
 	map tag2con_Foo (enumFromTo (I# a#) (I# b#))
 	}}
 
@@ -529,46 +526,48 @@ gen_Ix_binds tycon
       = mk_easy_FunMonoBind range_PN [TuplePatIn [a_Pat, b_Pat]] [] (
 	  untag_Expr tycon [(a_PN, ah_PN)] (
 	  untag_Expr tycon [(b_PN, bh_PN)] (
-	  App (App (Var map_PN) (Var (tag2con_PN tycon))) (
+	  HsApp (HsApp (HsVar map_PN) (HsVar (tag2con_PN tycon))) (
 	      enum_from_to_Expr
-		(App (Var mkInt_PN) (Var ah_PN))
-		(App (Var mkInt_PN) (Var bh_PN))
+		(HsApp (HsVar mkInt_PN) (HsVar ah_PN))
+		(HsApp (HsVar mkInt_PN) (HsVar bh_PN))
 	))))
 
     enum_index
       = mk_easy_FunMonoBind index_PN [AsPatIn c_PN (TuplePatIn [a_Pat, b_Pat]), d_Pat] [] (
-	If (App (App (Var inRange_PN) c_Expr) d_Expr) (
+	HsIf (HsApp (HsApp (HsVar inRange_PN) c_Expr) d_Expr) (
 	   untag_Expr tycon [(a_PN, ah_PN)] (
 	   untag_Expr tycon [(d_PN, dh_PN)] (
 	   let
-		grhs = [OtherwiseGRHS (App (Var mkInt_PN) (Var c_PN)) mkGeneratedSrcLoc]
+		grhs = [OtherwiseGRHS (HsApp (HsVar mkInt_PN) (HsVar c_PN)) mkGeneratedSrcLoc]
 	   in
-	   Case (OpApp (Var dh_PN) (Var minusH_PN) (Var ah_PN)) {-of-}
+	   HsCase
+	     (OpApp (HsVar dh_PN) (HsVar minusH_PN) (HsVar ah_PN))
 	     [PatMatch (VarPatIn c_PN)
 				(GRHSMatch (GRHSsAndBindsIn grhs EmptyBinds))]
+	     mkGeneratedSrcLoc
 	   ))
 	) {-else-} (
-	   App (Var error_PN) (Lit (StringLit (_PK_ ("Ix."++tycon_str++".index: out of range\n"))))
-	)
+	   HsApp (HsVar error_PN) (HsLit (HsString (_PK_ ("Ix."++tycon_str++".index: out of range\n"))))
 	)
+	mkGeneratedSrcLoc)
 
     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)] (
-	  If (OpApp (Var ch_PN) (Var geH_PN) (Var ah_PN)) (
-	     (OpApp (Var ch_PN) (Var leH_PN) (Var bh_PN))
+	  HsIf (OpApp (HsVar ch_PN) (HsVar geH_PN) (HsVar ah_PN)) (
+	     (OpApp (HsVar ch_PN) (HsVar leH_PN) (HsVar bh_PN))
 	  ) {-else-} (
 	     false_Expr
-	  )))))
+	  ) mkGeneratedSrcLoc))))
 
     --------------------------------------------------------------
     single_con_ixes = single_con_range `AndMonoBinds`
     	    	single_con_index `AndMonoBinds` single_con_inRange
 
     data_con
-      =	case maybeSingleConstructorTyCon tycon of -- just checking...
+      =	case maybeTyConSingleCon tycon of -- just checking...
 	  Nothing -> panic "get_Ix_binds"
 	  Just dc -> let
 			 (_, _, arg_tys, _) = getDataConSig dc
@@ -581,7 +580,7 @@ gen_Ix_binds tycon
     con_arity   = getDataConArity data_con
     data_con_PN = Prel (WiredInVal data_con)
     con_pat  xs = ConPatIn data_con_PN (map VarPatIn xs)
-    con_expr xs = foldl App (Var data_con_PN) (map Var xs)
+    con_expr xs = foldl HsApp (HsVar data_con_PN) (map HsVar xs)
 
     as_needed = take (getDataConArity data_con) as_PNs
     bs_needed = take (getDataConArity data_con) bs_PNs
@@ -590,112 +589,60 @@ gen_Ix_binds tycon
     --------------------------------------------------------------
     single_con_range
       = mk_easy_FunMonoBind range_PN [TuplePatIn [con_pat as_needed, con_pat bs_needed]] [] (
-	  ListComp (con_expr cs_needed) (zipWith3 mk_qual as_needed bs_needed cs_needed)
+	  ListComp (con_expr cs_needed) (zipWith3Equal mk_qual as_needed bs_needed cs_needed)
 	)
       where
 	mk_qual a b c = GeneratorQual (VarPatIn c)
-			    (App (Var range_PN) (ExplicitTuple [Var a, Var b]))
+			    (HsApp (HsVar range_PN) (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] (
-	foldl mk_index (Lit (IntLit 0)) (zip3 as_needed bs_needed cs_needed))
+	foldl mk_index (HsLit (HsInt 0)) (zip3 as_needed bs_needed cs_needed))
       where
 	mk_index multiply_by (l, u, i)
 	  =OpApp (
-		(App (App (Var index_PN) (ExplicitTuple [Var l, Var u])) (Var i))
-	   ) (Var plus_PN) (
+		(HsApp (HsApp (HsVar index_PN) (ExplicitTuple [HsVar l, HsVar u])) (HsVar i))
+	   ) (HsVar plus_PN) (
 		OpApp (
-		    (App (Var rangeSize_PN) (ExplicitTuple [Var l, Var u]))
-		) (Var times_PN) multiply_by
+		    (HsApp (HsVar rangeSize_PN) (ExplicitTuple [HsVar l, HsVar u]))
+		) (HsVar times_PN) multiply_by
 	   )
 
 	range_size
 	  = mk_easy_FunMonoBind rangeSize_PN [TuplePatIn [a_Pat, b_Pat]] [] (
 		OpApp (
-		    (App (App (Var index_PN) (ExplicitTuple [a_Expr, b_Expr])) b_Expr) 
-		) (Var plus_PN) (Lit (IntLit 1)))
+		    (HsApp (HsApp (HsVar index_PN) (ExplicitTuple [a_Expr, b_Expr])) b_Expr)
+		) (HsVar plus_PN) (HsLit (HsInt 1)))
 
     ------------------
     single_con_inRange
       = mk_easy_FunMonoBind inRange_PN [TuplePatIn [con_pat as_needed, con_pat bs_needed], con_pat cs_needed] [] (
-	  foldl1 and_Expr (zipWith3 in_range as_needed bs_needed cs_needed))
+	  foldl1 and_Expr (zipWith3Equal in_range as_needed bs_needed cs_needed))
       where
-    	in_range a b c = App (App (Var inRange_PN) (ExplicitTuple [Var a, Var b])) (Var c)
+    	in_range a b c = HsApp (HsApp (HsVar inRange_PN) (ExplicitTuple [HsVar a, HsVar b])) (HsVar c)
 \end{code}
 
 %************************************************************************
 %*									*
-\subsubsection[TcGenDeriv-Text]{Generating @Text@ instance declarations}
+\subsubsection[TcGenDeriv-Text]{Generating @Show@ and @Read@ instance declarations}
 %*									*
 %************************************************************************
 
-Deriving @Text@ is a pain.  @show@ is commonly used; @read@ is rarely
-used---but we're supposed to generate massive amounts of code for it
-anyway.  We provide a command-line flag to say ``Don't bother''
-(@OmitDerivedRead@).
-
-Also: ignoring all the infix-ery mumbo jumbo (ToDo)
-
-The part of the Haskell report that deals with this (pages~147--151,
-1.2~version) is an adequate guide to what needs to be done.  Note that
-this is where we may (eventually) use the fixity info that's been
-passed around.
+Ignoring all the infix-ery mumbo jumbo (ToDo)
 
 \begin{code}
-gen_Text_binds :: [RenamedFixityDecl] -> Bool -> TyCon -> ProtoNameMonoBinds
-
-gen_Text_binds fixities omit_derived_read tycon
-  = if omit_derived_read
-    then shows_prec `AndMonoBinds` show_list
-    else shows_prec `AndMonoBinds` show_list
-	   `AndMonoBinds`
-	 reads_prec `AndMonoBinds` read_list
+gen_Read_binds :: [RenamedFixityDecl] -> TyCon -> ProtoNameMonoBinds
+gen_Show_binds :: [RenamedFixityDecl] -> TyCon -> ProtoNameMonoBinds
+
+gen_Read_binds fixities tycon
+  = reads_prec `AndMonoBinds` read_list
   where
     -----------------------------------------------------------------------
-    show_list = mk_easy_FunMonoBind showList_PN [] []
-		  (App (Var _showList_PN) (App (Var showsPrec_PN) (Lit (IntLit 0))))
-
     read_list = mk_easy_FunMonoBind readList_PN [] []
-		  (App (Var _readList_PN) (App (Var readsPrec_PN) (Lit (IntLit 0))))
-
-    -----------------------------------------------------------------------
-    shows_prec
-      = mk_FunMonoBind showsPrec_PN (map pats_etc (getTyConDataCons tycon))
-      where
-	pats_etc data_con
-	  = let
-		data_con_PN = Prel (WiredInVal data_con)
-		bs_needed   = take (getDataConArity data_con) bs_PNs
-		con_pat     = ConPatIn data_con_PN (map VarPatIn bs_needed)
-		is_nullary_con = isNullaryDataCon data_con
-
-		show_con
-		  = let (mod, nm)   = getOrigName data_con
-			space_maybe = if is_nullary_con then _NIL_ else SLIT(" ")
-		    in
-			App (Var showString_PN) (Lit (StringLit (nm _APPEND_ space_maybe)))
-
-		show_thingies = show_con : (spacified real_show_thingies)
-
-		real_show_thingies
-		  = [ App (App (Var showsPrec_PN) (Lit (IntLit 10))) (Var b)
-		  | b <- bs_needed ]
-	    in
-	    if is_nullary_con then  -- skip the showParen junk...
-		ASSERT(null bs_needed)
-		([a_Pat, con_pat], show_con)
-	    else
-		([a_Pat, con_pat],
-		    showParen_Expr (OpApp a_Expr (Var ge_PN) (Lit (IntLit 10)))
-				   (nested_compose_Expr show_thingies))
-	  where
-	    spacified []     = []
-	    spacified [x]    = [x]
-	    spacified (x:xs) = (x : (Var showSpace_PN) : spacified xs)
-
+		  (HsApp (HsVar _readList_PN) (HsApp (HsVar readsPrec_PN) (HsLit (HsInt 0))))
     -----------------------------------------------------------------------
-    reads_prec	-- ignore the infix game altogether
+    reads_prec
       = let
 	    read_con_comprehensions
 	      = map read_con (getTyConDataCons tycon)
@@ -710,35 +657,77 @@ gen_Text_binds fixities omit_derived_read tycon
 		data_con_str= snd  (getOrigName data_con)
 		as_needed   = take (getDataConArity data_con) as_PNs
 		bs_needed   = take (getDataConArity data_con) bs_PNs
-		con_expr    = foldl App (Var data_con_PN) (map Var as_needed)
-		is_nullary_con = isNullaryDataCon data_con
+		con_expr    = foldl HsApp (HsVar data_con_PN) (map HsVar as_needed)
+		nullary_con = getDataConArity data_con == 0
 
 		con_qual
 		  = GeneratorQual
-		      (TuplePatIn [LitPatIn (StringLit data_con_str), d_Pat])
-		      (App (Var lex_PN) c_Expr)
+		      (TuplePatIn [LitPatIn (HsString data_con_str), d_Pat])
+		      (HsApp (HsVar lex_PN) c_Expr)
 
 		field_quals = snd (mapAccumL mk_qual d_Expr (as_needed `zip` bs_needed))
 
 		read_paren_arg
-		  = if is_nullary_con then -- must be False (parens are surely optional)
+		  = if nullary_con then -- must be False (parens are surely optional)
 		       false_Expr
 		    else -- parens depend on precedence...
-		       OpApp a_Expr (Var gt_PN) (Lit (IntLit 9))
+		       OpApp a_Expr (HsVar gt_PN) (HsLit (HsInt 9))
 	    in
-	    App (
+	    HsApp (
 	      readParen_Expr read_paren_arg (
-		 Lam (mk_easy_Match [c_Pat] []  (
+		 HsLam (mk_easy_Match [c_Pat] []  (
 		   ListComp (ExplicitTuple [con_expr,
-			    if null bs_needed then d_Expr else Var (last bs_needed)])
+			    if null bs_needed then d_Expr else HsVar (last bs_needed)])
 		    (con_qual : field_quals)))
-	    )) (Var b_PN)
+	    )) (HsVar b_PN)
 	  where
 	    mk_qual draw_from (con_field, str_left)
-	      = (Var str_left,	-- what to draw from down the line...
+	      = (HsVar str_left,	-- what to draw from down the line...
 		 GeneratorQual
 		  (TuplePatIn [VarPatIn con_field, VarPatIn str_left])
-		  (App (App (Var readsPrec_PN) (Lit (IntLit 10))) draw_from))
+		  (HsApp (HsApp (HsVar readsPrec_PN) (HsLit (HsInt 10))) draw_from))
+
+
+gen_Show_binds fixities tycon
+  = shows_prec `AndMonoBinds` show_list
+  where
+    -----------------------------------------------------------------------
+    show_list = mk_easy_FunMonoBind showList_PN [] []
+		  (HsApp (HsVar _showList_PN) (HsApp (HsVar showsPrec_PN) (HsLit (HsInt 0))))
+    -----------------------------------------------------------------------
+    shows_prec
+      = mk_FunMonoBind showsPrec_PN (map pats_etc (getTyConDataCons tycon))
+      where
+	pats_etc data_con
+	  = let
+		data_con_PN = Prel (WiredInVal data_con)
+		bs_needed   = take (getDataConArity data_con) bs_PNs
+		con_pat     = ConPatIn data_con_PN (map VarPatIn bs_needed)
+		nullary_con = getDataConArity data_con == 0
+
+		show_con
+		  = let (mod, nm)   = getOrigName data_con
+			space_maybe = if nullary_con then _NIL_ else SLIT(" ")
+		    in
+			HsApp (HsVar showString_PN) (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)
+		  | b <- bs_needed ]
+	    in
+	    if nullary_con then  -- skip the showParen junk...
+		ASSERT(null bs_needed)
+		([a_Pat, con_pat], show_con)
+	    else
+		([a_Pat, con_pat],
+		    showParen_Expr (OpApp a_Expr (HsVar ge_PN) (HsLit (HsInt 10)))
+				   (nested_compose_Expr show_thingies))
+	  where
+	    spacified []     = []
+	    spacified [x]    = [x]
+	    spacified (x:xs) = (x : (HsVar showSpace_PN) : spacified xs)
 \end{code}
 
 %************************************************************************
@@ -774,6 +763,9 @@ The `tags' here start at zero, hence the @fIRST_TAG@ (currently one)
 fiddling around.
 
 \begin{code}
+data TagThingWanted
+  = GenCon2Tag | GenTag2Con | GenMaxTag
+
 gen_tag_n_con_monobind
     :: (ProtoName, Name,    -- (proto)Name for the thing in question
 	TyCon,		    -- tycon in question
@@ -783,11 +775,11 @@ gen_tag_n_con_monobind
 gen_tag_n_con_monobind (pn, _, tycon, GenCon2Tag)
   = mk_FunMonoBind pn (map mk_stuff (getTyConDataCons tycon))
   where
-    mk_stuff :: DataCon -> ([ProtoNamePat], ProtoNameExpr)
+    mk_stuff :: DataCon -> ([ProtoNamePat], ProtoNameHsExpr)
 
     mk_stuff var
       = ASSERT(isDataCon var)
-	([pat], Lit (IntPrimLit (toInteger ((getDataConTag var) - fIRST_TAG))))
+	([pat], HsLit (HsIntPrim (toInteger ((getDataConTag var) - fIRST_TAG))))
       where
 	pat    = ConPatIn var_PN (nOfThem (getDataConArity var) WildPatIn)
 	var_PN = Prel (WiredInVal var)
@@ -795,17 +787,17 @@ gen_tag_n_con_monobind (pn, _, tycon, GenCon2Tag)
 gen_tag_n_con_monobind (pn, _, tycon, GenTag2Con)
   = mk_FunMonoBind pn (map mk_stuff (getTyConDataCons tycon))
   where
-    mk_stuff :: DataCon -> ([ProtoNamePat], ProtoNameExpr)
+    mk_stuff :: DataCon -> ([ProtoNamePat], ProtoNameHsExpr)
 
     mk_stuff var
       = ASSERT(isDataCon var)
-	([lit_pat], Var var_PN)
+	([lit_pat], HsVar var_PN)
       where
-	lit_pat = ConPatIn mkInt_PN [LitPatIn (IntPrimLit (toInteger ((getDataConTag var) - fIRST_TAG)))]
+	lit_pat = ConPatIn mkInt_PN [LitPatIn (HsIntPrim (toInteger ((getDataConTag var) - fIRST_TAG)))]
 	var_PN  = Prel (WiredInVal var)
 
 gen_tag_n_con_monobind (pn, _, tycon, GenMaxTag)
-  = mk_easy_FunMonoBind pn [] [] (App (Var mkInt_PN) (Lit (IntPrimLit max_tag)))
+  = mk_easy_FunMonoBind pn [] [] (HsApp (HsVar mkInt_PN) (HsLit (HsIntPrim max_tag)))
   where
     max_tag =  case (getTyConDataCons tycon) of
 		 data_cons -> toInteger ((length data_cons) - fIRST_TAG)
@@ -833,7 +825,7 @@ multi-clause definitions; it generates:
 
 \begin{code}
 mk_easy_FunMonoBind :: ProtoName -> [ProtoNamePat]
-		    -> [ProtoNameMonoBinds] -> ProtoNameExpr
+		    -> [ProtoNameMonoBinds] -> ProtoNameHsExpr
 		    -> ProtoNameMonoBinds
 
 mk_easy_FunMonoBind fun pats binds expr
@@ -844,14 +836,14 @@ mk_easy_Match pats binds expr
 	  (GRHSMatch (GRHSsAndBindsIn [OtherwiseGRHS expr mkGeneratedSrcLoc] (mkbind binds)))
 	  pats
   where
-    mkbind [] = EmptyBinds 
+    mkbind [] = EmptyBinds
     mkbind bs = SingleBind (RecBind (foldr1 AndMonoBinds bs))
 	-- The renamer expects everything in its input to be a
 	-- "recursive" MonoBinds, and it is its job to sort things out
 	-- from there.
 
 mk_FunMonoBind	:: ProtoName
-		-> [([ProtoNamePat], ProtoNameExpr)]
+		-> [([ProtoNamePat], ProtoNameHsExpr)]
 		-> ProtoNameMonoBinds
 
 mk_FunMonoBind fun [] = panic "TcGenDeriv:mk_FunMonoBind"
@@ -865,46 +857,54 @@ mk_FunMonoBind fun pats_and_exprs
 \end{code}
 
 \begin{code}
-tagCmp_Case, cmp_eq_Expr ::
-	  ProtoNameExpr -> ProtoNameExpr -> ProtoNameExpr
-	  -> ProtoNameExpr -> ProtoNameExpr
-	  -> ProtoNameExpr
-tagCmp_gen_Case :: 
+compare_Case, cmp_eq_Expr ::
+	  ProtoNameHsExpr -> ProtoNameHsExpr -> ProtoNameHsExpr
+	  -> ProtoNameHsExpr -> ProtoNameHsExpr
+	  -> ProtoNameHsExpr
+compare_gen_Case ::
 	  ProtoName
-	  -> ProtoNameExpr -> ProtoNameExpr -> ProtoNameExpr
-	  -> ProtoNameExpr -> ProtoNameExpr
-	  -> ProtoNameExpr
-careful_tagCmp_Case :: -- checks for primitive types...
-	  UniType
-	  -> ProtoNameExpr -> ProtoNameExpr -> ProtoNameExpr
-	  -> ProtoNameExpr -> ProtoNameExpr
-	  -> ProtoNameExpr
-
-tagCmp_Case = tagCmp_gen_Case tagCmp_PN
-cmp_eq_Expr = tagCmp_gen_Case cmp_eq_PN
-
-tagCmp_gen_Case fun lt eq gt a b
-  = Case (App (App (Var fun) a) b) {-of-}
-      [PatMatch (ConPatIn lt_TAG_PN [])
+	  -> ProtoNameHsExpr -> ProtoNameHsExpr -> ProtoNameHsExpr
+	  -> ProtoNameHsExpr -> ProtoNameHsExpr
+	  -> ProtoNameHsExpr
+careful_compare_Case :: -- checks for primitive types...
+	  Type
+	  -> ProtoNameHsExpr -> ProtoNameHsExpr -> ProtoNameHsExpr
+	  -> ProtoNameHsExpr -> ProtoNameHsExpr
+	  -> ProtoNameHsExpr
+
+compare_Case = compare_gen_Case compare_PN
+cmp_eq_Expr = compare_gen_Case cmp_eq_PN
+
+compare_gen_Case fun lt eq gt a b
+  = HsCase (HsApp (HsApp (HsVar fun) a) b) {-of-}
+      [PatMatch (ConPatIn ltTag_PN [])
 	  (GRHSMatch (GRHSsAndBindsIn [OtherwiseGRHS lt mkGeneratedSrcLoc] EmptyBinds)),
 
-       PatMatch (ConPatIn eq_TAG_PN [])
+       PatMatch (ConPatIn eqTag_PN [])
 	  (GRHSMatch (GRHSsAndBindsIn [OtherwiseGRHS eq mkGeneratedSrcLoc] EmptyBinds)),
 
-       PatMatch (ConPatIn gt_TAG_PN [])
+       PatMatch (ConPatIn gtTag_PN [])
 	  (GRHSMatch (GRHSsAndBindsIn [OtherwiseGRHS gt mkGeneratedSrcLoc] EmptyBinds))]
+       mkGeneratedSrcLoc
 
-careful_tagCmp_Case ty lt eq gt a b
+careful_compare_Case ty lt eq gt a b
   = if not (isPrimType ty) then
-       tagCmp_gen_Case tagCmp_PN lt eq gt a b
+       compare_gen_Case compare_PN lt eq gt a b
 
     else -- we have to do something special for primitive things...
-       If (OpApp a (Var relevant_eq_op) b)
-	  eq
-	  (If (OpApp a (Var relevant_lt_op) b) lt gt)
+       HsIf (OpApp a (HsVar relevant_eq_op) b)
+	    eq
+	    (HsIf (OpApp a (HsVar relevant_lt_op) b) lt gt mkGeneratedSrcLoc)
+	    mkGeneratedSrcLoc
   where
-    relevant_eq_op = assoc "careful_tagCmp_Case" eq_op_tbl ty
-    relevant_lt_op = assoc "careful_tagCmp_Case" lt_op_tbl ty
+    relevant_eq_op = assoc_ty_id eq_op_tbl ty
+    relevant_lt_op = assoc_ty_id lt_op_tbl ty
+
+assoc_ty_id tyids ty 
+  = if null res then panic "assoc_ty"
+    else head res
+  where
+    res = [id | (ty',id) <- tyids, eqTy ty ty']
 
 eq_op_tbl = [
     (charPrimTy,	Prel (WiredInVal (primOpId CharEqOp))),
@@ -924,64 +924,65 @@ lt_op_tbl = [
 
 -----------------------------------------------------------------------
 
-and_Expr, append_Expr :: ProtoNameExpr -> ProtoNameExpr -> ProtoNameExpr
+and_Expr, append_Expr :: ProtoNameHsExpr -> ProtoNameHsExpr -> ProtoNameHsExpr
 
-and_Expr    a b = OpApp a (Var and_PN)    b
-append_Expr a b = OpApp a (Var append_PN) b
+and_Expr    a b = OpApp a (HsVar and_PN)    b
+append_Expr a b = OpApp a (HsVar append_PN) b
 
 -----------------------------------------------------------------------
 
-eq_Expr  :: UniType -> ProtoNameExpr -> ProtoNameExpr -> ProtoNameExpr
+eq_Expr  :: Type -> ProtoNameHsExpr -> ProtoNameHsExpr -> ProtoNameHsExpr
 eq_Expr ty a b
   = if not (isPrimType ty) then
-       OpApp a (Var eq_PN)  b
+       OpApp a (HsVar eq_PN)  b
     else -- we have to do something special for primitive things...
-       OpApp a (Var relevant_eq_op) b
+       OpApp a (HsVar relevant_eq_op) b
   where
-    relevant_eq_op = assoc "eq_Expr" eq_op_tbl ty
+    relevant_eq_op = assoc_ty_id eq_op_tbl ty
 \end{code}
 
 \begin{code}
-untag_Expr :: TyCon -> [(ProtoName, ProtoName)] -> ProtoNameExpr -> ProtoNameExpr
+untag_Expr :: TyCon -> [(ProtoName, ProtoName)] -> ProtoNameHsExpr -> ProtoNameHsExpr
 untag_Expr tycon [] expr = expr
 untag_Expr tycon ((untag_this, put_tag_here) : more) expr
-  = Case (App (con2tag_Expr tycon) (Var untag_this)) {-of-}
+  = HsCase (HsApp (con2tag_Expr tycon) (HsVar untag_this)) {-of-}
       [PatMatch (VarPatIn put_tag_here)
 			(GRHSMatch (GRHSsAndBindsIn grhs EmptyBinds))]
+      mkGeneratedSrcLoc
   where
     grhs = [OtherwiseGRHS (untag_Expr tycon more expr) mkGeneratedSrcLoc]
 
 cmp_tags_Expr :: ProtoName 			-- Comparison op
 	     -> ProtoName -> ProtoName		-- Things to compare
-	     -> ProtoNameExpr 			-- What to return if true
-	     -> ProtoNameExpr			-- What to return if false
-	     -> ProtoNameExpr
+	     -> ProtoNameHsExpr 		-- What to return if true
+	     -> ProtoNameHsExpr			-- What to return if false
+	     -> ProtoNameHsExpr
 
-cmp_tags_Expr op a b true_case false_case 
-  = If (OpApp (Var a) (Var op) (Var b)) true_case false_case
+cmp_tags_Expr op a b true_case false_case
+  = HsIf (OpApp (HsVar a) (HsVar op) (HsVar b)) true_case false_case mkGeneratedSrcLoc
 
 enum_from_to_Expr
-	:: ProtoNameExpr -> ProtoNameExpr
-	-> ProtoNameExpr
+	:: ProtoNameHsExpr -> ProtoNameHsExpr
+	-> ProtoNameHsExpr
 enum_from_then_to_Expr
-	:: ProtoNameExpr -> ProtoNameExpr -> ProtoNameExpr
-	-> ProtoNameExpr
+	:: ProtoNameHsExpr -> ProtoNameHsExpr -> ProtoNameHsExpr
+	-> ProtoNameHsExpr
 
-enum_from_to_Expr      f   t2 = App (App (Var enumFromTo_PN) f) t2
-enum_from_then_to_Expr f t t2 = App (App (App (Var enumFromThenTo_PN) f) t) t2
+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
 
 showParen_Expr, readParen_Expr
-	:: ProtoNameExpr -> ProtoNameExpr
-	-> ProtoNameExpr
+	:: ProtoNameHsExpr -> ProtoNameHsExpr
+	-> ProtoNameHsExpr
 
-showParen_Expr e1 e2 = App (App (Var showParen_PN) e1) e2
-readParen_Expr e1 e2 = App (App (Var readParen_PN) e1) e2
+showParen_Expr e1 e2 = HsApp (HsApp (HsVar showParen_PN) e1) e2
+readParen_Expr e1 e2 = HsApp (HsApp (HsVar readParen_PN) e1) e2
 
-nested_compose_Expr :: [ProtoNameExpr] -> ProtoNameExpr
+nested_compose_Expr :: [ProtoNameHsExpr] -> ProtoNameHsExpr
 
 nested_compose_Expr [e] = e
 nested_compose_Expr (e:es)
-  = App (App (Var compose_PN) e) (nested_compose_Expr es)
+  = HsApp (HsApp (HsVar compose_PN) e) (nested_compose_Expr es)
 \end{code}
 
 \begin{code}
@@ -1008,10 +1009,10 @@ ge_PN		= prelude_method SLIT("Ord") SLIT(">=")
 gt_PN		= prelude_method SLIT("Ord") SLIT(">")
 max_PN		= prelude_method SLIT("Ord") SLIT("max")
 min_PN		= prelude_method SLIT("Ord") SLIT("min")
-tagCmp_PN	= prelude_method SLIT("Ord") SLIT("_tagCmp")
-lt_TAG_PN	= Prel (WiredInVal ltPrimDataCon)
-eq_TAG_PN	= Prel (WiredInVal eqPrimDataCon)
-gt_TAG_PN	= Prel (WiredInVal gtPrimDataCon)
+compare_PN	= prelude_method SLIT("Ord") SLIT("compare")
+ltTag_PN	= Prel (WiredInVal ltDataCon)
+eqTag_PN	= Prel (WiredInVal eqDataCon)
+gtTag_PN	= Prel (WiredInVal gtDataCon)
 enumFrom_PN	 = prelude_method SLIT("Enum") SLIT("enumFrom")
 enumFromTo_PN	 = prelude_method SLIT("Enum") SLIT("enumFromTo")
 enumFromThen_PN	 = prelude_method SLIT("Enum") SLIT("enumFromThen")
@@ -1019,10 +1020,10 @@ enumFromThenTo_PN= prelude_method SLIT("Enum") SLIT("enumFromThenTo")
 range_PN	 = prelude_method SLIT("Ix")   SLIT("range")
 index_PN	 = prelude_method SLIT("Ix")   SLIT("index")
 inRange_PN	 = prelude_method SLIT("Ix")   SLIT("inRange")
-readsPrec_PN	 = prelude_method SLIT("Text") SLIT("readsPrec")
-showsPrec_PN	 = prelude_method SLIT("Text") SLIT("showsPrec")
-readList_PN	 = prelude_method SLIT("Text") SLIT("readList")
-showList_PN	 = prelude_method SLIT("Text") SLIT("showList")
+readsPrec_PN	 = prelude_method SLIT("Read") SLIT("readsPrec")
+readList_PN	 = prelude_method SLIT("Read") SLIT("readList")
+showsPrec_PN	 = prelude_method SLIT("Show") SLIT("showsPrec")
+showList_PN	 = prelude_method SLIT("Show") SLIT("showList")
 plus_PN		 = prelude_method SLIT("Num")  SLIT("+")
 times_PN	 = prelude_method SLIT("Num")  SLIT("*")
 
@@ -1051,41 +1052,63 @@ _readList_PN    = prelude_val pRELUDE_CORE SLIT("_readList")
 prelude_val    m s = Imp m s [m] s
 prelude_method c o = Imp pRELUDE_CORE o [pRELUDE_CORE] o -- class not used...
 
-a_Expr		= Var a_PN
-b_Expr		= Var b_PN
-c_Expr		= Var c_PN
-d_Expr		= Var d_PN
-lt_TAG_Expr	= Var lt_TAG_PN
-eq_TAG_Expr	= Var eq_TAG_PN
-gt_TAG_Expr	= Var gt_TAG_PN
-false_Expr	= Var false_PN
-true_Expr	= Var true_PN
+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 = Var (con2tag_PN tycon)
+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
-\end{code}
 
-%************************************************************************
-%*									*
-\subsection[TcGenDeriv-misc-utils]{Miscellaneous utility bits for deriving}
-%*									*
-%************************************************************************
 
-\begin{code}
-{- UNUSED:
-hasCon2TagFun :: TyCon -> Bool
-hasCon2TagFun tycon
-  =  preludeClassDerivedFor ordClassKey tycon
-  || isEnumerationTyConMostly tycon
-
-hasTag2ConFun :: TyCon -> Bool
-hasTag2ConFun tycon
-  =  isEnumerationTyCon tycon
-  && (preludeClassDerivedFor ixClassKey   tycon
-   || preludeClassDerivedFor enumClassKey tycon)
--}
+con2tag_PN, tag2con_PN, maxtag_PN :: TyCon -> ProtoName
+
+con2tag_PN tycon
+  = let	(mod, nm) = getOrigName tycon
+	con2tag	  = SLIT("con2tag_") _APPEND_ nm _APPEND_ SLIT("#")
+    in
+    Imp mod con2tag [mod] con2tag
+
+tag2con_PN tycon
+  = let	(mod, nm) = getOrigName tycon
+	tag2con	  = SLIT("tag2con_") _APPEND_ nm _APPEND_ SLIT("#")
+    in
+    Imp mod tag2con [mod] tag2con
+
+maxtag_PN tycon
+  = let	(mod, nm) = getOrigName tycon
+	maxtag	  = SLIT("maxtag_") _APPEND_ nm _APPEND_ SLIT("#")
+    in
+    Imp mod maxtag [mod] maxtag
+
+
+con2tag_FN, tag2con_FN, maxtag_FN :: TyCon -> FullName
+
+tag2con_FN tycon
+  = let	(mod, nm) = getOrigName tycon
+	tag2con	  = SLIT("tag2con_") _APPEND_ nm _APPEND_ SLIT("#")
+    in
+    mkFullName mod tag2con InventedInThisModule NotExported mkGeneratedSrcLoc
+
+maxtag_FN tycon
+  = let	(mod, nm) = getOrigName tycon
+	maxtag	  = SLIT("maxtag_") _APPEND_ nm _APPEND_ SLIT("#")
+    in
+    mkFullName mod maxtag InventedInThisModule NotExported mkGeneratedSrcLoc
+
+con2tag_FN tycon
+  = let	(mod, nm) = getOrigName tycon
+	con2tag	  = SLIT("con2tag_") _APPEND_ nm _APPEND_ SLIT("#")
+    in
+    mkFullName mod con2tag InventedInThisModule NotExported mkGeneratedSrcLoc
+
 \end{code}
diff --git a/ghc/compiler/typecheck/TcHsSyn.lhs b/ghc/compiler/typecheck/TcHsSyn.lhs
new file mode 100644
index 0000000000..005fec5b70
--- /dev/null
+++ b/ghc/compiler/typecheck/TcHsSyn.lhs
@@ -0,0 +1,525 @@
+%
+% (c) The AQUA Project, Glasgow University, 1996
+%
+\section[TcHsSyn]{Specialisations of the @HsSyn@ syntax for the typechecker}
+
+This module is an extension of @HsSyn@ syntax, for use in the type
+checker.
+
+\begin{code}
+module TcHsSyn (
+	TcIdBndr(..), TcIdOcc(..),
+	
+	TcMonoBinds(..), TcHsBinds(..), TcBind(..), TcPat(..), TcExpr(..), TcGRHSsAndBinds(..),
+	TcGRHS(..), TcMatch(..), TcQual(..), TcStmt(..), TcArithSeqInfo(..), TcHsModule(..),
+	
+	TypecheckedHsBinds(..),	TypecheckedBind(..), TypecheckedMonoBinds(..),
+	TypecheckedPat(..), TypecheckedHsExpr(..), TypecheckedArithSeqInfo(..),
+	TypecheckedQual(..), TypecheckedStmt(..), TypecheckedMatch(..), 
+	TypecheckedHsModule(..), TypecheckedGRHSsAndBinds(..), TypecheckedGRHS(..),
+
+	mkHsTyApp, mkHsDictApp,
+	mkHsTyLam, mkHsDictLam,
+
+	zonkBinds,
+	zonkInst,
+	zonkId,	    -- TcIdBndr s -> NF_TcM s Id
+	unZonkId    -- Id         -> NF_TcM s (TcIdBndr s)
+  ) where
+
+import Ubiq{-uitous-}
+
+-- friends:
+import HsSyn	-- oodles of it
+import Id	( GenId(..), IdDetails, PragmaInfo,	-- Can meddle modestly with Ids
+		  DictVar(..)
+		)
+
+-- others:
+import TcMonad
+import TcType	( TcType(..), TcMaybe, TcTyVar(..),
+		  zonkTcTypeToType, zonkTcTyVarToTyVar,
+		  tcInstType
+		)
+import Usage	( UVar(..) )
+import Util	( panic )
+
+import PprType  ( GenType, GenTyVar ) 	-- instances
+import TyVar	( GenTyVar )		-- instances
+import Unique	( Unique )		-- instances
+\end{code}
+
+
+Type definitions
+~~~~~~~~~~~~~~~~
+
+The @Tc...@ datatypes are the ones that apply {\em during} type checking.
+All the types in @Tc...@ things have mutable type-variables in them for
+unification.
+
+At the end of type checking we zonk everything to @Typechecked...@ datatypes,
+which have immutable type variables in them.
+
+\begin{code}
+type TcIdBndr s = GenId  (TcType s)	-- Binders are all TcTypes
+data TcIdOcc  s = TcId   (TcIdBndr s)	-- Bindees may be either
+		| RealId Id
+
+type TcHsBinds s     	= HsBinds (TcTyVar s) UVar (TcIdOcc s) (TcPat s)
+type TcBind s	     	= Bind (TcTyVar s) UVar (TcIdOcc s) (TcPat s)
+type TcMonoBinds s	= MonoBinds (TcTyVar s) UVar (TcIdOcc s) (TcPat s)
+type TcPat s	     	= OutPat (TcTyVar s) UVar (TcIdOcc s)
+type TcExpr s	     	= HsExpr (TcTyVar s) UVar (TcIdOcc s) (TcPat s)
+type TcGRHSsAndBinds s	= GRHSsAndBinds (TcTyVar s) UVar (TcIdOcc s) (TcPat s)
+type TcGRHS s		= GRHS (TcTyVar s) UVar (TcIdOcc s) (TcPat s)
+type TcMatch s		= Match (TcTyVar s) UVar (TcIdOcc s) (TcPat s)
+type TcQual s		= Qual (TcTyVar s) UVar (TcIdOcc s) (TcPat s)
+type TcStmt s		= Stmt (TcTyVar s) UVar (TcIdOcc s) (TcPat s)
+type TcArithSeqInfo s	= ArithSeqInfo (TcTyVar s) UVar (TcIdOcc s) (TcPat s)
+type TcHsModule s	= HsModule (TcTyVar s) UVar (TcIdOcc s) (TcPat s)
+
+type TypecheckedPat		= OutPat	TyVar UVar Id
+type TypecheckedMonoBinds 	= MonoBinds	TyVar UVar Id TypecheckedPat
+type TypecheckedHsBinds		= HsBinds	TyVar UVar Id TypecheckedPat
+type TypecheckedBind		= Bind		TyVar UVar Id TypecheckedPat
+type TypecheckedHsExpr		= HsExpr	TyVar UVar Id TypecheckedPat
+type TypecheckedArithSeqInfo	= ArithSeqInfo	TyVar UVar Id TypecheckedPat
+type TypecheckedQual		= Qual		TyVar UVar Id TypecheckedPat
+type TypecheckedStmt		= Stmt		TyVar UVar Id TypecheckedPat
+type TypecheckedMatch		= Match		TyVar UVar Id TypecheckedPat
+type TypecheckedGRHSsAndBinds	= GRHSsAndBinds TyVar UVar Id TypecheckedPat
+type TypecheckedGRHS		= GRHS		TyVar UVar Id TypecheckedPat
+type TypecheckedHsModule	= HsModule	TyVar UVar Id TypecheckedPat
+\end{code}
+
+\begin{code}
+mkHsTyApp expr []  = expr
+mkHsTyApp expr tys = TyApp expr tys
+
+mkHsDictApp expr []	 = expr
+mkHsDictApp expr dict_vars = DictApp expr dict_vars
+
+mkHsTyLam []     expr = expr
+mkHsTyLam tyvars expr = TyLam tyvars expr
+
+mkHsDictLam []    expr = expr
+mkHsDictLam dicts expr = DictLam dicts expr
+\end{code}
+
+
+
+\begin{code}
+instance Eq (TcIdOcc s) where
+  (TcId id1)   == (TcId id2)   = id1 == id2
+  (RealId id1) == (RealId id2) = id1 == id2
+
+instance Outputable (TcIdOcc s) where
+  ppr sty (TcId id)   = ppr sty id
+  ppr sty (RealId id) = ppr sty id
+
+instance NamedThing (TcIdOcc s) where
+  getOccurrenceName (TcId id)   = getOccurrenceName id
+  getOccurrenceName (RealId id) = getOccurrenceName id
+\end{code}
+
+
+%************************************************************************
+%*									*
+\subsection[BackSubst-HsBinds]{Running a substitution over @HsBinds@}
+%*									*
+%************************************************************************
+
+\begin{code}
+zonkId   :: TcIdOcc s -> NF_TcM s Id
+unZonkId :: Id	      -> NF_TcM s (TcIdBndr s)
+
+zonkId (RealId id) = returnNF_Tc id
+
+zonkId (TcId (Id u ty details prags info))
+  = zonkTcTypeToType ty	`thenNF_Tc` \ ty' ->
+    returnNF_Tc (Id u ty' details prags info)
+
+unZonkId (Id u ty details prags info)
+  = tcInstType [] ty 	`thenNF_Tc` \ ty' ->
+    returnNF_Tc (Id u ty' details prags info)
+\end{code}
+
+\begin{code}
+zonkInst :: (TcIdOcc s, TcExpr s) -> NF_TcM s (Id, TypecheckedHsExpr)
+zonkInst (id, expr)
+  = zonkId id		`thenNF_Tc` \ id' ->
+    zonkExpr expr	`thenNF_Tc` \ expr' ->
+    returnNF_Tc (id', expr') 
+\end{code}
+
+\begin{code}
+zonkBinds :: TcHsBinds s -> NF_TcM s TypecheckedHsBinds
+
+zonkBinds EmptyBinds = returnNF_Tc EmptyBinds
+
+zonkBinds (ThenBinds binds1 binds2)
+  = zonkBinds binds1  `thenNF_Tc` \ new_binds1 ->
+    zonkBinds binds2  `thenNF_Tc` \ new_binds2 ->
+    returnNF_Tc (ThenBinds new_binds1 new_binds2)
+
+zonkBinds (SingleBind bind)
+  = zonkBind bind  `thenNF_Tc` \ new_bind ->
+    returnNF_Tc (SingleBind new_bind)
+
+zonkBinds (AbsBinds tyvars dicts locprs dict_binds val_bind)
+  = mapNF_Tc zonkTcTyVarToTyVar tyvars	`thenNF_Tc` \ new_tyvars ->
+    mapNF_Tc zonkId dicts		`thenNF_Tc` \ new_dicts ->
+    mapNF_Tc subst_pair locprs		`thenNF_Tc` \ new_locprs ->
+    mapNF_Tc subst_bind dict_binds	`thenNF_Tc` \ new_dict_binds ->
+    zonkBind val_bind			`thenNF_Tc` \ new_val_bind ->
+    returnNF_Tc (AbsBinds new_tyvars new_dicts new_locprs new_dict_binds new_val_bind)
+  where
+    subst_pair (l, g)
+      = zonkId l	`thenNF_Tc` \ new_l ->
+	zonkId g	`thenNF_Tc` \ new_g ->
+	returnNF_Tc (new_l, new_g)
+
+    subst_bind (v, e)
+      = zonkId v	`thenNF_Tc` \ new_v ->
+	zonkExpr e	`thenNF_Tc` \ new_e ->
+	returnNF_Tc (new_v, new_e)
+\end{code}
+
+\begin{code}
+-------------------------------------------------------------------------
+zonkBind :: TcBind s -> NF_TcM s TypecheckedBind
+
+zonkBind EmptyBind = returnNF_Tc EmptyBind
+
+zonkBind (NonRecBind mbinds)
+  = zonkMonoBinds mbinds	`thenNF_Tc` \ new_mbinds ->
+    returnNF_Tc (NonRecBind new_mbinds)
+
+zonkBind (RecBind mbinds)
+  = zonkMonoBinds mbinds	`thenNF_Tc` \ new_mbinds ->
+    returnNF_Tc (RecBind new_mbinds)
+
+-------------------------------------------------------------------------
+zonkMonoBinds :: TcMonoBinds s -> NF_TcM s TypecheckedMonoBinds
+
+zonkMonoBinds EmptyMonoBinds = returnNF_Tc EmptyMonoBinds
+
+zonkMonoBinds (AndMonoBinds mbinds1 mbinds2)
+  = zonkMonoBinds mbinds1  `thenNF_Tc` \ new_mbinds1 ->
+    zonkMonoBinds mbinds2  `thenNF_Tc` \ new_mbinds2 ->
+    returnNF_Tc (AndMonoBinds new_mbinds1 new_mbinds2)
+
+zonkMonoBinds (PatMonoBind pat grhss_w_binds locn)
+  = zonkPat pat	    	   		`thenNF_Tc` \ new_pat ->
+    zonkGRHSsAndBinds grhss_w_binds	`thenNF_Tc` \ new_grhss_w_binds ->
+    returnNF_Tc (PatMonoBind new_pat new_grhss_w_binds locn)
+
+zonkMonoBinds (VarMonoBind var expr)
+  = zonkId var    	`thenNF_Tc` \ new_var ->
+    zonkExpr expr	`thenNF_Tc` \ new_expr ->
+    returnNF_Tc (VarMonoBind new_var new_expr)
+
+zonkMonoBinds (FunMonoBind name ms locn)
+  = zonkId name			`thenNF_Tc` \ new_name ->
+    mapNF_Tc zonkMatch ms	`thenNF_Tc` \ new_ms ->
+    returnNF_Tc (FunMonoBind new_name new_ms locn)
+\end{code}
+
+%************************************************************************
+%*									*
+\subsection[BackSubst-Match-GRHSs]{Match and GRHSsAndBinds}
+%*									*
+%************************************************************************
+
+\begin{code}
+zonkMatch :: TcMatch s -> NF_TcM s TypecheckedMatch
+
+zonkMatch (PatMatch pat match)
+  = zonkPat pat	    	`thenNF_Tc` \ new_pat ->
+    zonkMatch match  	`thenNF_Tc` \ new_match ->
+    returnNF_Tc (PatMatch new_pat new_match)
+
+zonkMatch (GRHSMatch grhss_w_binds)
+  = zonkGRHSsAndBinds grhss_w_binds `thenNF_Tc` \ new_grhss_w_binds ->
+    returnNF_Tc (GRHSMatch new_grhss_w_binds)
+
+-------------------------------------------------------------------------
+zonkGRHSsAndBinds :: TcGRHSsAndBinds s
+		   -> NF_TcM s TypecheckedGRHSsAndBinds
+
+zonkGRHSsAndBinds (GRHSsAndBindsOut grhss binds ty)
+  = mapNF_Tc zonk_grhs grhss 	`thenNF_Tc` \ new_grhss ->
+    zonkBinds binds   		`thenNF_Tc` \ new_binds ->
+    zonkTcTypeToType ty 	`thenNF_Tc` \ new_ty ->
+    returnNF_Tc (GRHSsAndBindsOut new_grhss new_binds new_ty)
+  where
+    zonk_grhs (GRHS guard expr locn)
+      = zonkExpr guard  `thenNF_Tc` \ new_guard ->
+	zonkExpr expr   `thenNF_Tc` \ new_expr  ->
+	returnNF_Tc (GRHS new_guard new_expr locn)
+
+    zonk_grhs (OtherwiseGRHS expr locn)
+      = zonkExpr expr   `thenNF_Tc` \ new_expr  ->
+	returnNF_Tc (OtherwiseGRHS new_expr locn)
+\end{code}
+
+%************************************************************************
+%*									*
+\subsection[BackSubst-HsExpr]{Running a zonkitution over a TypeCheckedExpr}
+%*									*
+%************************************************************************
+
+ToDo: panic on things that can't be in @TypecheckedHsExpr@.
+
+\begin{code}
+zonkExpr :: TcExpr s -> NF_TcM s TypecheckedHsExpr
+
+zonkExpr (HsVar name)
+  = zonkId name	`thenNF_Tc` \ new_name ->
+    returnNF_Tc (HsVar new_name)
+
+zonkExpr (HsLitOut lit ty)
+  = zonkTcTypeToType ty	    `thenNF_Tc` \ new_ty  ->
+    returnNF_Tc (HsLitOut lit new_ty)
+
+zonkExpr (HsLam match)
+  = zonkMatch match	`thenNF_Tc` \ new_match ->
+    returnNF_Tc (HsLam new_match)
+
+zonkExpr (HsApp e1 e2)
+  = zonkExpr e1	`thenNF_Tc` \ new_e1 ->
+    zonkExpr e2	`thenNF_Tc` \ new_e2 ->
+    returnNF_Tc (HsApp new_e1 new_e2)
+
+zonkExpr (OpApp e1 op e2)
+  = zonkExpr e1	`thenNF_Tc` \ new_e1 ->
+    zonkExpr op	`thenNF_Tc` \ new_op ->
+    zonkExpr e2	`thenNF_Tc` \ new_e2 ->
+    returnNF_Tc (OpApp new_e1 new_op new_e2)
+
+zonkExpr (SectionL expr op)
+  = zonkExpr expr	`thenNF_Tc` \ new_expr ->
+    zonkExpr op		`thenNF_Tc` \ new_op ->
+    returnNF_Tc (SectionL new_expr new_op)
+
+zonkExpr (SectionR op expr)
+  = zonkExpr op		`thenNF_Tc` \ new_op ->
+    zonkExpr expr	`thenNF_Tc` \ new_expr ->
+    returnNF_Tc (SectionR new_op new_expr)
+
+zonkExpr (CCall fun args may_gc is_casm result_ty)
+  = mapNF_Tc zonkExpr args 	`thenNF_Tc` \ new_args ->
+    zonkTcTypeToType result_ty	`thenNF_Tc` \ new_result_ty ->
+    returnNF_Tc (CCall fun new_args may_gc is_casm new_result_ty)
+
+zonkExpr (HsSCC label expr)
+  = zonkExpr expr	`thenNF_Tc` \ new_expr ->
+    returnNF_Tc (HsSCC label new_expr)
+
+zonkExpr (HsCase expr ms src_loc)
+  = zonkExpr expr    	    `thenNF_Tc` \ new_expr ->
+    mapNF_Tc zonkMatch ms   `thenNF_Tc` \ new_ms ->
+    returnNF_Tc (HsCase new_expr new_ms src_loc)
+
+zonkExpr (HsLet binds expr)
+  = zonkBinds binds	`thenNF_Tc` \ new_binds ->
+    zonkExpr expr	`thenNF_Tc` \ new_expr ->
+    returnNF_Tc (HsLet new_binds new_expr)
+
+zonkExpr (HsDoOut stmts m_id mz_id src_loc)
+  = zonkStmts stmts 	`thenNF_Tc` \ new_stmts ->
+    zonkId m_id		`thenNF_Tc` \ m_new ->
+    zonkId mz_id	`thenNF_Tc` \ mz_new ->
+    returnNF_Tc (HsDoOut new_stmts m_new mz_new src_loc)
+
+zonkExpr (ListComp expr quals)
+  = zonkExpr expr	`thenNF_Tc` \ new_expr ->
+    zonkQuals quals	`thenNF_Tc` \ new_quals ->
+    returnNF_Tc (ListComp new_expr new_quals)
+
+--ExplicitList: not in typechecked exprs
+
+zonkExpr (ExplicitListOut ty exprs)
+  = zonkTcTypeToType  ty	`thenNF_Tc` \ new_ty ->
+    mapNF_Tc zonkExpr exprs	`thenNF_Tc` \ new_exprs ->
+    returnNF_Tc (ExplicitListOut new_ty new_exprs)
+
+zonkExpr (ExplicitTuple exprs)
+  = mapNF_Tc zonkExpr exprs  `thenNF_Tc` \ new_exprs ->
+    returnNF_Tc (ExplicitTuple new_exprs)
+
+zonkExpr (RecordCon con rbinds)
+  = panic "zonkExpr:RecordCon"
+zonkExpr (RecordUpd exp rbinds)
+  = panic "zonkExpr:RecordUpd"
+
+zonkExpr (HsIf e1 e2 e3 src_loc)
+  = zonkExpr e1	`thenNF_Tc` \ new_e1 ->
+    zonkExpr e2	`thenNF_Tc` \ new_e2 ->
+    zonkExpr e3	`thenNF_Tc` \ new_e3 ->
+    returnNF_Tc (HsIf new_e1 new_e2 new_e3 src_loc)
+
+zonkExpr (ArithSeqOut expr info)
+  = zonkExpr expr	`thenNF_Tc` \ new_expr ->
+    zonkArithSeq info	`thenNF_Tc` \ new_info ->
+    returnNF_Tc (ArithSeqOut new_expr new_info)
+
+zonkExpr (TyLam tyvars expr)
+  = mapNF_Tc zonkTcTyVarToTyVar tyvars	`thenNF_Tc` \ new_tyvars ->
+    zonkExpr expr			`thenNF_Tc` \ new_expr ->
+    returnNF_Tc (TyLam new_tyvars new_expr)
+
+zonkExpr (TyApp expr tys)
+  = zonkExpr expr    	    	  `thenNF_Tc` \ new_expr ->
+    mapNF_Tc zonkTcTypeToType tys `thenNF_Tc` \ new_tys ->
+    returnNF_Tc (TyApp new_expr new_tys)
+
+zonkExpr (DictLam dicts expr)
+  = mapNF_Tc zonkId dicts	`thenNF_Tc` \ new_dicts ->
+    zonkExpr expr    	    	`thenNF_Tc` \ new_expr ->
+    returnNF_Tc (DictLam new_dicts new_expr)
+
+zonkExpr (DictApp expr dicts)
+  = zonkExpr expr    	    	`thenNF_Tc` \ new_expr ->
+    mapNF_Tc zonkId dicts	`thenNF_Tc` \ new_dicts ->
+    returnNF_Tc (DictApp new_expr new_dicts)
+
+zonkExpr (ClassDictLam dicts methods expr)
+  = mapNF_Tc zonkId dicts   `thenNF_Tc` \ new_dicts ->
+    mapNF_Tc zonkId methods `thenNF_Tc` \ new_methods ->
+    zonkExpr expr    	    `thenNF_Tc` \ new_expr ->
+    returnNF_Tc (ClassDictLam new_dicts new_methods new_expr)
+
+zonkExpr (Dictionary dicts methods)
+  = mapNF_Tc zonkId dicts   `thenNF_Tc` \ new_dicts ->
+    mapNF_Tc zonkId methods `thenNF_Tc` \ new_methods ->
+    returnNF_Tc (Dictionary new_dicts new_methods)
+
+zonkExpr (SingleDict name)
+  = zonkId name  	`thenNF_Tc` \ new_name ->
+    returnNF_Tc (SingleDict new_name)
+
+-------------------------------------------------------------------------
+zonkArithSeq :: TcArithSeqInfo s -> NF_TcM s TypecheckedArithSeqInfo
+
+zonkArithSeq (From e)
+  = zonkExpr e		`thenNF_Tc` \ new_e ->
+    returnNF_Tc (From new_e)
+
+zonkArithSeq (FromThen e1 e2)
+  = zonkExpr e1	`thenNF_Tc` \ new_e1 ->
+    zonkExpr e2	`thenNF_Tc` \ new_e2 ->
+    returnNF_Tc (FromThen new_e1 new_e2)
+
+zonkArithSeq (FromTo e1 e2)
+  = zonkExpr e1	`thenNF_Tc` \ new_e1 ->
+    zonkExpr e2	`thenNF_Tc` \ new_e2 ->
+    returnNF_Tc (FromTo new_e1 new_e2)
+
+zonkArithSeq (FromThenTo e1 e2 e3)
+  = zonkExpr e1	`thenNF_Tc` \ new_e1 ->
+    zonkExpr e2	`thenNF_Tc` \ new_e2 ->
+    zonkExpr e3	`thenNF_Tc` \ new_e3 ->
+    returnNF_Tc (FromThenTo new_e1 new_e2 new_e3)
+
+-------------------------------------------------------------------------
+zonkQuals :: [TcQual s] -> NF_TcM s [TypecheckedQual]
+
+zonkQuals quals
+  = mapNF_Tc zonk_qual quals
+  where
+    zonk_qual (GeneratorQual pat expr)
+      = zonkPat  pat    `thenNF_Tc` \ new_pat ->
+	zonkExpr expr   `thenNF_Tc` \ new_expr ->
+	returnNF_Tc (GeneratorQual new_pat new_expr)
+
+    zonk_qual (FilterQual expr)
+      = zonkExpr expr    `thenNF_Tc` \ new_expr ->
+	returnNF_Tc (FilterQual new_expr)
+
+    zonk_qual (LetQual binds)
+      = zonkBinds binds	 `thenNF_Tc` \ new_binds ->
+	returnNF_Tc (LetQual new_binds)
+
+-------------------------------------------------------------------------
+zonkStmts :: [TcStmt s] -> NF_TcM s [TypecheckedStmt]
+
+zonkStmts stmts
+  = mapNF_Tc zonk_stmt stmts
+  where
+    zonk_stmt (BindStmt pat expr src_loc)
+      = zonkPat  pat    `thenNF_Tc` \ new_pat ->
+	zonkExpr expr   `thenNF_Tc` \ new_expr ->
+	returnNF_Tc (BindStmt new_pat new_expr src_loc)
+
+    zonk_stmt (ExprStmt expr src_loc)
+      = zonkExpr expr    `thenNF_Tc` \ new_expr ->
+	returnNF_Tc (ExprStmt new_expr src_loc)
+
+    zonk_stmt (LetStmt binds)
+      = zonkBinds binds	 `thenNF_Tc` \ new_binds ->
+	returnNF_Tc (LetStmt new_binds)
+\end{code}
+
+%************************************************************************
+%*									*
+\subsection[BackSubst-Pats]{Patterns}
+%*									*
+%************************************************************************
+
+\begin{code}
+zonkPat :: TcPat s -> NF_TcM s TypecheckedPat
+
+zonkPat (WildPat ty)
+  = zonkTcTypeToType ty	    `thenNF_Tc` \ new_ty ->
+    returnNF_Tc (WildPat new_ty)
+
+zonkPat (VarPat v)
+  = zonkId v	    `thenNF_Tc` \ new_v ->
+    returnNF_Tc (VarPat new_v)
+
+zonkPat (LazyPat pat)
+  = zonkPat pat	    `thenNF_Tc` \ new_pat ->
+    returnNF_Tc (LazyPat new_pat)
+
+zonkPat (AsPat n pat)
+  = zonkId n	    `thenNF_Tc` \ new_n ->
+    zonkPat pat	    `thenNF_Tc` \ new_pat ->
+    returnNF_Tc (AsPat new_n new_pat)
+
+zonkPat (ConPat n ty pats)
+  = zonkTcTypeToType ty	     `thenNF_Tc` \ new_ty ->
+    mapNF_Tc zonkPat pats    `thenNF_Tc` \ new_pats ->
+    returnNF_Tc (ConPat n new_ty new_pats)
+
+zonkPat (ConOpPat pat1 op pat2 ty)
+  = zonkPat pat1	    `thenNF_Tc` \ new_pat1 ->
+    zonkPat pat2	    `thenNF_Tc` \ new_pat2 ->
+    zonkTcTypeToType ty	    `thenNF_Tc` \ new_ty ->
+    returnNF_Tc (ConOpPat new_pat1 op new_pat2 new_ty)
+
+zonkPat (ListPat ty pats)
+  = zonkTcTypeToType ty	    `thenNF_Tc` \ new_ty ->
+    mapNF_Tc zonkPat pats   `thenNF_Tc` \ new_pats ->
+    returnNF_Tc (ListPat new_ty new_pats)
+
+zonkPat (TuplePat pats)
+  = mapNF_Tc zonkPat pats    `thenNF_Tc` \ new_pats ->
+    returnNF_Tc (TuplePat new_pats)
+
+zonkPat (LitPat lit ty)
+  = zonkTcTypeToType ty	    `thenNF_Tc` \ new_ty  ->
+    returnNF_Tc (LitPat lit new_ty)
+
+zonkPat (NPat lit ty expr)
+  = zonkTcTypeToType ty	    `thenNF_Tc` \ new_ty   ->
+    zonkExpr expr	    `thenNF_Tc` \ new_expr ->
+    returnNF_Tc (NPat lit new_ty new_expr)
+
+zonkPat (DictPat ds ms)
+  = mapNF_Tc zonkId ds    `thenNF_Tc` \ new_ds ->
+    mapNF_Tc zonkId ms    `thenNF_Tc` \ new_ms ->
+    returnNF_Tc (DictPat new_ds new_ms)
+\end{code}
+
+
diff --git a/ghc/compiler/typecheck/TcIfaceSig.hi b/ghc/compiler/typecheck/TcIfaceSig.hi
deleted file mode 100644
index 4f71aba87c..0000000000
--- a/ghc/compiler/typecheck/TcIfaceSig.hi
+++ /dev/null
@@ -1,14 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface TcIfaceSig where
-import Bag(Bag)
-import CmdLineOpts(GlobalSwitch)
-import E(E)
-import HsBinds(Sig)
-import Id(Id)
-import Name(Name)
-import Pretty(PprStyle, PrettyRep)
-import SplitUniq(SplitUniqSupply)
-import SrcLoc(SrcLoc)
-import TcMonad(Baby_TcResult)
-tcInterfaceSigs :: E -> [Sig Name] -> (GlobalSwitch -> Bool) -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> Baby_TcResult [(Name, Id)]
-
diff --git a/ghc/compiler/typecheck/TcIfaceSig.lhs b/ghc/compiler/typecheck/TcIfaceSig.lhs
index a8cea955b5..114d1ff31f 100644
--- a/ghc/compiler/typecheck/TcIfaceSig.lhs
+++ b/ghc/compiler/typecheck/TcIfaceSig.lhs
@@ -1,5 +1,5 @@
 %
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1994
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
 %
 \section[TcIfaceSig]{Type checking of type signatures in interface files}
 
@@ -8,29 +8,25 @@
 
 module TcIfaceSig ( tcInterfaceSigs ) where
 
-IMPORT_Trace		-- ToDo: rm (debugging)
-import Outputable
+import Ubiq
+
+import TcMonad
+import TcMonoType	( tcPolyType )
+
+import HsSyn		( Sig(..), PolyType )
+import RnHsSyn		( RenamedSig(..) )
+
+import CmdLineOpts	( opt_CompilingPrelude )
+import Id		( mkImported )
+import Name		( Name(..) )
 import Pretty
+import Util		( panic )
+
+
+--import TcPragmas	( tcGenPragmas )
+import IdInfo		( noIdInfo )
+tcGenPragmas ty id ps = returnNF_Tc noIdInfo
 
-import TcMonad		-- typechecking monadic machinery
-import AbsSyn		-- the stuff being typechecked
-
-import AbsUniType	( splitType, splitTyArgs )
-import CmdLineOpts	( GlobalSwitch(..) )
-import E		( getE_CE, getE_TCE, nullGVE, unitGVE,
-			  plusGVE, GVE(..), E, CE(..), TCE(..), UniqFM
-			)
-import Errors		( confusedNameErr )
-import Id		-- mkImported
-#if USE_ATTACK_PRAGMAS
-import IdInfo		( workerExists )
-#endif
-import Maybes		( Maybe(..) )
-import TcPragmas	( tcGenPragmas )
-import TVE		( nullTVE, TVE(..) )
-import TcPolyType	( tcPolyType )
-import UniqFM		( emptyUFM ) -- profiling, pragmas only
-import Util
 \end{code}
 
 Ultimately, type signatures in interfaces will have pragmatic
@@ -41,37 +37,30 @@ As always, we do not have to worry about user-pragmas in interface
 signatures.
 
 \begin{code}
-tcInterfaceSigs :: E -> [RenamedSig] -> Baby_TcM GVE
-
-tcInterfaceSigs e [] = returnB_Tc nullGVE
-
-tcInterfaceSigs e (sig:sigs)
-  = tc_sig	      sig  `thenB_Tc` \ gve1 ->
-    tcInterfaceSigs e sigs `thenB_Tc` \ gve2 ->
-    returnB_Tc (plusGVE gve1 gve2)
-  where
-    ce  = getE_CE  e
-    tce = getE_TCE e
-
-    tc_sig (Sig name@(OtherTopId uniq full_name) ty pragmas src_loc)
-      = addSrcLocB_Tc src_loc			 (
-	tcPolyType ce tce nullTVE ty	`thenB_Tc` \ sigma_ty ->
-
-	fixB_Tc ( \ rec_imported_id ->
-	    tcGenPragmas e (Just sigma_ty) rec_imported_id pragmas
-				`thenB_Tc` \ id_info ->
-
-	    returnB_Tc (mkImported uniq full_name sigma_ty id_info)
-	) `thenB_Tc` \ final_id ->
-
-	returnB_Tc (unitGVE name final_id)
-	)
-
-    tc_sig (Sig odd_name _ _ src_loc)
-      = getSwitchCheckerB_Tc	`thenB_Tc` \ sw_chkr ->
-	case odd_name of
-	  WiredInVal _ | sw_chkr CompilingPrelude -- OK, that's cool; ignore
-	    -> returnB_Tc nullGVE
-	  _ -> failB_Tc (confusedNameErr "Bad name on a type signature (a Prelude name?)"
-		        	odd_name src_loc)
+tcInterfaceSigs :: [RenamedSig] -> TcM s [Id]
+
+tcInterfaceSigs [] = returnTc []
+
+tcInterfaceSigs (Sig name@(ValName uniq full_name) ty pragmas src_loc : sigs)
+  = tcAddSrcLoc src_loc		(
+    tcPolyType ty		`thenTc` \ sigma_ty ->
+    fixTc ( \ rec_id ->
+	tcGenPragmas (Just sigma_ty) rec_id pragmas
+				`thenNF_Tc` \ id_info ->
+        returnTc (mkImported uniq full_name sigma_ty id_info)
+    ))				`thenTc` \ id ->
+    tcInterfaceSigs sigs	`thenTc` \ sigs' ->
+    returnTc (id:sigs')
+
+
+tcInterfaceSigs (Sig odd_name _ _ src_loc : sigs)
+  = case odd_name of
+      WiredInVal _ | opt_CompilingPrelude
+        -> tcInterfaceSigs sigs
+      _ -> tcAddSrcLoc src_loc	$
+	   failTc (ifaceSigNameErr odd_name)
+
+ifaceSigNameErr name sty
+  = ppHang (ppStr "Bad name in an interface type signature (a Prelude name?)")
+	 4 (ppr sty name)
 \end{code}
diff --git a/ghc/compiler/typecheck/TcInstDcls.hi b/ghc/compiler/typecheck/TcInstDcls.hi
deleted file mode 100644
index cd1b033e32..0000000000
--- a/ghc/compiler/typecheck/TcInstDcls.hi
+++ /dev/null
@@ -1,35 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface TcInstDcls where
-import Bag(Bag)
-import Class(Class, ClassOp)
-import CmdLineOpts(GlobalSwitch)
-import E(E)
-import HsBinds(Binds, MonoBinds, Sig)
-import HsDecls(InstDecl, SpecialisedInstanceSig)
-import HsExpr(Expr)
-import HsPat(InPat, TypecheckedPat)
-import HsPragmas(InstancePragmas)
-import Id(Id)
-import IdInfo(SpecEnv)
-import Inst(Inst)
-import InstEnv(InstTemplate)
-import LIE(LIE)
-import Name(Name)
-import PreludePS(_PackedString)
-import Pretty(PprStyle, PrettyRep)
-import SplitUniq(SplitUniqSupply)
-import SrcLoc(SrcLoc)
-import Subst(Subst)
-import TcMonad(TcResult)
-import TyCon(TyCon)
-import TyVar(TyVar, TyVarTemplate)
-import UniType(UniType)
-import UniqFM(UniqFM)
-data InstInfo   = InstInfo Class [TyVarTemplate] UniType [(Class, UniType)] [(Class, UniType)] Id [Id] (MonoBinds Name (InPat Name)) Bool _PackedString SrcLoc [Sig Name]
-buildInstanceEnvs :: Bag InstInfo -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult (Class -> ([(UniType, InstTemplate)], ClassOp -> SpecEnv))
-mkInstanceRelatedIds :: E -> Bool -> _PackedString -> InstancePragmas Name -> a -> Class -> [TyVarTemplate] -> UniType -> [(Class, UniType)] -> [Sig Name] -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult (Id, [(Class, UniType)], [Id])
-processInstBinds :: E -> [TyVar] -> (Int -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> (Expr Id TypecheckedPat, Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep))) -> [TyVar] -> [Inst] -> [Id] -> MonoBinds Name (InPat Name) -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult ([Inst], MonoBinds Id TypecheckedPat)
-tcInstDecls1 :: E -> UniqFM Class -> UniqFM TyCon -> [InstDecl Name (InPat Name)] -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> (Bag InstInfo, Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep))
-tcInstDecls2 :: E -> Bag InstInfo -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> ((LIE, Binds Id TypecheckedPat), Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep))
-tcSpecInstSigs :: E -> UniqFM Class -> UniqFM TyCon -> Bag InstInfo -> [SpecialisedInstanceSig Name] -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult (Bag InstInfo)
-
diff --git a/ghc/compiler/typecheck/TcInstDcls.lhs b/ghc/compiler/typecheck/TcInstDcls.lhs
index dffbe4b1e0..2f75b9d0c4 100644
--- a/ghc/compiler/typecheck/TcInstDcls.lhs
+++ b/ghc/compiler/typecheck/TcInstDcls.lhs
@@ -1,5 +1,5 @@
 %
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
 %
 \section[TcInstDecls]{Typechecking instance declarations}
 
@@ -7,65 +7,81 @@
 #include "HsVersions.h"
 
 module TcInstDcls (
-	tcInstDecls1, tcInstDecls2,
-	tcSpecInstSigs,
-	buildInstanceEnvs, processInstBinds,
-	mkInstanceRelatedIds,
-	InstInfo(..)
+	tcInstDecls1,
+	tcInstDecls2,
+	processInstBinds
     ) where
 
-IMPORT_Trace		-- ToDo:rm debugging
-import Outputable
-import Pretty
 
-import TcMonad		-- typechecking monad machinery
-import TcMonadFns	( newDicts, newMethod, newLocalWithGivenTy,
-			  newClassOpLocals, copyTyVars,
-			  applyTcSubstAndCollectTyVars
-			)
-import AbsSyn		-- the stuff being typechecked
-import AbsPrel		( pAT_ERROR_ID )
-import AbsUniType
-import BackSubst	( applyTcSubstToBinds )
-import Bag		( emptyBag, unitBag, unionBags, bagToList )
-import CE		( lookupCE, CE(..) )
-import CmdLineOpts	( GlobalSwitch(..) )
-import GenSpecEtc	( checkSigTyVars, SignatureInfo )
-import E		( mkE, getE_CE, getE_TCE, growE_LVE, tvOfE, LVE(..), E )
-import Errors		( dupInstErr, derivingWhenInstanceExistsErr,
-			  preludeInstanceErr, nonBoxedPrimCCallErr,
-			  specInstUnspecInstNotFoundErr,
-			  Error(..), UnifyErrContext(..)
-			)
-import HsPragmas	-- ****** NEED TO SEE CONSTRUCTORS ******
-import Id		-- lots of things
-import IdInfo		-- ditto
-import Inst		( Inst, InstOrigin(..) )
-import InstEnv
-import Maybes		( catMaybes, mkLookupFun, maybeToBool, Maybe(..) )
-import Name		( getTagFromClassOpName )
-import NameTypes	( fromPrelude )
-import PlainCore	( escErrorMsg )
-import LIE		( nullLIE, mkLIE, unMkLIE, plusLIE, LIE )
-import ListSetOps	( minusList )
-import TCE		( TCE(..), UniqFM )
-import TVE		( mkTVE, TVE(..) )
-import Spec		( specTy )
-import TcContext	( tcContext )
-import TcBinds		( tcSigs, doSpecPragma )
+import Ubiq
+
+import HsSyn		( InstDecl(..), FixityDecl, Sig(..),
+			  SpecInstSig(..), HsBinds(..), Bind(..),
+			  MonoBinds(..), GRHSsAndBinds, Match, 
+			  InPat(..), OutPat(..), HsExpr(..), HsLit(..),
+			  Stmt, Qual, ArithSeqInfo, Fake,
+			  PolyType(..), MonoType )
+import RnHsSyn		( RenamedHsBinds(..), RenamedMonoBinds(..),
+			  RenamedInstDecl(..), RenamedFixityDecl(..),
+			  RenamedSig(..), RenamedSpecInstSig(..) )
+import TcHsSyn		( TcIdOcc(..), TcHsBinds(..),
+			  TcMonoBinds(..), TcExpr(..),
+			  mkHsTyLam, mkHsTyApp,
+			  mkHsDictLam, mkHsDictApp )
+
+
+import TcMonad
+import GenSpecEtc	( checkSigTyVars, specTy )
+import Inst		( Inst, InstOrigin(..), InstanceMapper(..),
+			  newDicts, newMethod, LIE(..), emptyLIE, plusLIE )
+import TcBinds		( tcPragmaSigs )
+import TcDeriv		( tcDeriving )
+import TcEnv		( tcLookupClass, tcTyVarScope, newLocalIds )
 import TcGRHSs		( tcGRHSsAndBinds )
+import TcInstUtil	( InstInfo(..), mkInstanceRelatedIds, buildInstanceEnvs )
+import TcKind		( TcKind, unifyKind )
 import TcMatches	( tcMatchesFun )
-import TcMonoType	( tcInstanceType )
-import TcPragmas	( tcDictFunPragmas, tcGenPragmas )
+import TcMonoType	( tcContext, tcMonoTypeKind )
 import TcSimplify	( tcSimplifyAndCheck, tcSimplifyThetas )
+import TcType		( TcType(..), TcTyVar(..),
+			  tcInstTyVar, tcInstType, tcInstTheta )
 import Unify		( unifyTauTy )
-import Unique		( cCallableClassKey, cReturnableClassKey )
-import Util
+
+
+import Bag		( emptyBag, unitBag, unionBags, unionManyBags,
+			  concatBag, foldBag, bagToList )
+import CmdLineOpts	( opt_GlasgowExts, opt_CompilingPrelude,
+			  opt_OmitDefaultInstanceMethods,
+			  opt_SpecialiseOverloaded )
+import Class		( GenClass, GenClassOp, 
+			  isCcallishClass, getClassBigSig,
+			  getClassOps, getClassOpLocalType )
+import CoreUtils	( escErrorMsg )
+import Id		( idType, isDefaultMethodId_maybe )
+import ListSetOps	( minusList )
+import Maybes 		( maybeToBool, expectJust )
+import Name		( Name, getTagFromClassOpName )
+import Outputable
+import PrelInfo		( pAT_ERROR_ID )
+import PprType		( GenType, GenTyVar, GenClass, GenClassOp, TyCon,
+			  pprParendType )
+import PprStyle
+import Pretty
+import RnUtils		( GlobalNameMappers(..), GlobalNameMapper(..) )
+import TyCon		( derivedFor )
+import Type		( GenType(..),  ThetaType(..), mkTyVarTy,
+			  splitSigmaTy, splitAppTy, isTyVarTy, matchTy,
+			  getTyCon_maybe, maybeBoxedPrimType )
+import TyVar		( GenTyVar, tyVarListToSet )
+import TysWiredIn	( stringTy )
+import Unique		( Unique )
+import Util		( panic )
+
 \end{code}
 
 Typechecking instance declarations is done in two passes. The first
-pass, made by @tcInstDecls1@,
-collects information to be used in the second pass.
+pass, made by @tcInstDecls1@, collects information to be used in the
+second pass.
 
 This pre-processed info includes the as-yet-unprocessed bindings
 inside the instance declaration.  These are type-checked in the second
@@ -73,33 +89,11 @@ pass, when the class-instance envs and GVE contain all the info from
 all the instance and value decls.  Indeed that's the reason we need
 two passes over the instance decls.
 
-    instance c => k (t tvs) where b
-
-\begin{code}
-data InstInfo
-  = InstInfo
-      Class	        -- Class, k
-      [TyVarTemplate]	-- Type variables, tvs
-      UniType		-- The type at which the class is being
-			--   instantiated
-      ThetaType		-- inst_decl_theta: the original context from the
-			--   instance declaration.  It constrains (some of)
-			--   the TyVarTemplates above
-      ThetaType		-- dfun_theta: the inst_decl_theta, plus one
-			--   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
-      FAST_STRING	-- Name of module where this instance was
-			-- defined.
-      SrcLoc		-- Source location assoc'd with this instance's defn
-      [RenamedSig]	-- User pragmas recorded for generating specialised methods
-\end{code}
 
+Here is the overall algorithm.
+Assume that we have an instance declaration
 
-Here is the overall algorithm.	Assume that
+    instance c => k (t tvs) where b
 
 \begin{enumerate}
 \item
@@ -159,312 +153,96 @@ and $dbinds_super$ bind the superclass dictionaries sd1 \ldots sdm.
 \end{enumerate}
 
 \begin{code}
-tcInstDecls1 :: E -> CE -> TCE -> [RenamedInstDecl] -> NF_TcM (Bag InstInfo)
-
-tcInstDecls1 e ce tce [] = returnNF_Tc emptyBag
-
-tcInstDecls1 e ce tce (inst_decl : rest)
-  = tc_inst_1 inst_decl 	`thenNF_Tc` \ infos1 ->
-    tcInstDecls1 e ce tce rest	`thenNF_Tc` \ infos2 ->
-    returnNF_Tc (infos1 `unionBags` infos2)
-  where
-    tc_inst_1 (InstDecl context class_name ty binds from_here modname imod uprags pragmas src_loc)
-      =
-	    -- Prime error recovery and substitution pruning
-	recoverTc emptyBag			(
-	addSrcLocTc src_loc			(
-
-	let
-	    clas = lookupCE ce class_name -- Renamer ensures this can't fail
-
-	    for_ccallable_or_creturnable
-	      = class_name == cCallableClass || class_name == cReturnableClass
-	      where
-	       cCallableClass   = PreludeClass cCallableClassKey   bottom
-	       cReturnableClass = PreludeClass cReturnableClassKey bottom
-	       bottom		= panic "for_ccallable_etc"
-
-	    -- Make some new type variables, named as in the instance type
-	    ty_names	    	= extractMonoTyNames (==) ty
-	    (tve,inst_tyvars,_) = mkTVE ty_names
-	in
-	    -- Check the instance type, including its syntactic constraints
-	babyTcMtoTcM (tcInstanceType ce tce tve from_here src_loc ty)
-		`thenTc` \ inst_ty ->
-
-	    -- DEAL WITH THE INSTANCE CONTEXT
-	babyTcMtoTcM (tcContext ce tce tve context) `thenTc` \ theta ->
-
-	    -- SOME BORING AND TURGID CHECKING:
-	let
-	    inst_for_function_type = isFunType inst_ty
-		-- sigh; it happens; must avoid tickling inst_tycon
-
-	    inst_tycon_maybe = getUniDataTyCon_maybe inst_ty
-
-	    inst_tycon = case inst_tycon_maybe of
-			   Just (xx,_,_) -> xx
-			   Nothing 	 -> panic "tcInstDecls1:inst_tycon"
-	in
-	    -------------------------------------------------------------
-	    -- It is illegal for a normal user's module to declare an
-	    -- instance for a Prelude-class/Prelude-type instance:
-	checkTc (from_here	    	      -- really an inst decl in this module
-		 && fromPreludeCore clas      -- prelude class
-		 && (inst_for_function_type   -- prelude type
-		     || fromPreludeCore inst_tycon)
-		 && not (fromPrelude modname) -- we aren't compiling a Prelude mod
-		)
-		(preludeInstanceErr clas inst_ty src_loc) `thenTc_`
-
-	    -------------------------------------------------------------
-	    -- It is obviously illegal to have an explicit instance
-	    -- for something that we are also planning to `derive'.
-	    -- Note that an instance decl coming in from outside
-	    -- is probably just telling us about the derived instance
-	    -- (ToDo: actually check, if possible), so we mustn't flag
-	    -- it as an error.
-	checkTc (from_here
-		 && not inst_for_function_type
-		 && clas `derivedFor` inst_tycon)
-		(derivingWhenInstanceExistsErr clas inst_tycon) `thenTc_`
-
-	    -------------------------------------------------------------
-	    -- A user declaration of a _CCallable/_CReturnable instance
-	    -- must be for a "boxed primitive" type.
-        getSwitchCheckerTc	`thenNF_Tc` \ sw_chkr ->
-	checkTc (for_ccallable_or_creturnable
-		 && from_here			    -- instance defined here
-		 && not (sw_chkr CompilingPrelude)  -- which allows anything
-		 && (inst_for_function_type ||	    -- a *function*??? hah!
-		  not (maybeToBool (maybeBoxedPrimType inst_ty))))   -- naughty, naughty
-		(nonBoxedPrimCCallErr clas inst_ty src_loc) `thenTc_`
-
-	    -- END OF TURGIDITY; back to real fun
-	    -------------------------------------------------------------
-
-	if (not inst_for_function_type && clas `derivedFor` inst_tycon) then
-	    -- Don't use this InstDecl; tcDeriv will make the
-	    -- InstInfo to be used in later processing.
-	    returnTc emptyBag
-
-	else
-		-- Make the dfun id and constant-method ids
-	    mkInstanceRelatedIds e
-			from_here modname pragmas src_loc
-			clas inst_tyvars inst_ty theta uprags
-				`thenTc` \ (dfun_id, dfun_theta, const_meth_ids) ->
-
-	    returnTc ( unitBag (
-	      InstInfo clas inst_tyvars inst_ty theta
-		       dfun_theta dfun_id const_meth_ids 
-		       binds from_here modname src_loc uprags
-	    ))
-	))
-\end{code}
-
-
-Common bit of code shared with @tcDeriving@:
-\begin{code}
-mkInstanceRelatedIds e
-		from_here modname inst_pragmas locn
-		clas 
-		inst_tyvars inst_ty inst_decl_theta uprags
-  = getUniqueTc 			`thenNF_Tc` \ uniq -> 
-    let     
-	(class_tyvar, super_classes, _, class_ops, _, _) = getClassBigSig 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.
-
-			other -> inst_decl_theta ++ super_class_theta
-					-- 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
-    fixNF_Tc ( \ rec_dfun_id ->
-	babyTcMtoNF_TcM (
-	    tcDictFunPragmas e dfun_ty rec_dfun_id inst_pragmas
-	)			`thenNF_Tc` \ dfun_pragma_info ->
-	let
-	    dfun_specenv = mkInstSpecEnv clas inst_ty inst_tyvars dfun_theta
-	    dfun_info = dfun_pragma_info `addInfo` dfun_specenv
-	in
-	returnNF_Tc (mkDictFunId uniq clas inst_ty dfun_ty from_here modname dfun_info)
-    ) `thenNF_Tc` \ dfun_id ->
-
-	-- Make the constant-method ids, if there are no type variables involved
-    (if not (null inst_tyvars)	-- ToDo: could also do this if theta is null...
-     then
-	returnNF_Tc []
-     else
-	let
-	    inline_mes = [ getTagFromClassOpName v | (InlineSig v _ _) <- uprags ]
-
-            mk_const_meth op uniq
-              = mkConstMethodId 
-                        uniq
-                        clas op inst_ty
-                        meth_ty from_here modname info
-              where
-		is_elem = isIn "mkInstanceRelatedIds"
-
-		info	= if tag `is_elem` inline_mes
-			  then noIdInfo `addInfo_UF` (iWantToBeINLINEd UnfoldAlways)
-			  else noIdInfo
-
-                tenv    = [(class_tyvar, inst_ty)]
-		tag 	= getClassOpTag op
-                op_ty   = getClassOpLocalType op
-                meth_ty = instantiateTy tenv op_ty
-                          -- If you move to a null-theta version, you need a 
-                          -- mkForallTy inst_tyvars here
-
-	    mk_constm_w_info (op, u, (name, prags)) -- ToDo: chk name?
-	      = fixNF_Tc ( \ rec_constm_id ->
-
-		    babyTcMtoNF_TcM (tcGenPragmas e (Just meth_ty) rec_constm_id prags)
-				`thenNF_Tc` \ id_info ->
-
-		    returnNF_Tc (mkConstMethodId u clas op inst_ty meth_ty
-					from_here modname id_info)
-		)
-	      where
-		tenv    = [(class_tyvar, inst_ty)]
-		op_ty   = getClassOpLocalType op
-		meth_ty = instantiateTy tenv op_ty
-
-	in
-	getUniquesTc (length class_ops)	`thenNF_Tc` \ constm_uniqs ->
-	(case inst_pragmas of
-	   ConstantInstancePragma _ name_pragma_pairs ->
-	     mapNF_Tc mk_constm_w_info (zip3 class_ops constm_uniqs name_pragma_pairs)
-
-	   other_inst_pragmas ->
-	     returnNF_Tc (zipWith mk_const_meth class_ops constm_uniqs)
-	)
-    )		`thenNF_Tc` \ const_meth_ids ->
-
-    returnTc (dfun_id, dfun_theta, const_meth_ids)
-\end{code}
-
-
-%************************************************************************
-%*									*
-\subsection{Converting instance info into suitable InstEnvs}
-%*									*
-%************************************************************************
-
-\begin{code}
-buildInstanceEnvs :: Bag InstInfo 
-	          -> TcM InstanceMapper
-
-buildInstanceEnvs info
-  = let
-    	cmp :: InstInfo -> InstInfo -> TAG_
-    	(InstInfo c1 _ _ _ _ _ _ _ _ _ _ _) `cmp` (InstInfo c2 _ _ _ _ _ _ _ _ _ _ _)
-	  = if c1 == c2 then EQ_ else if c1 < c2 then LT_ else GT_
-
-	info_by_class = equivClasses cmp (bagToList info)
-    in
-    mapTc buildInstanceEnv info_by_class    `thenTc` \ inst_env_entries ->
+tcInstDecls1 :: Bag RenamedInstDecl
+	     -> [RenamedSpecInstSig]
+	     -> FAST_STRING		-- module name for deriving
+	     -> GlobalNameMappers	-- renamer fns for deriving
+	     -> [RenamedFixityDecl]	-- fixities for deriving
+	     -> TcM s (Bag InstInfo,
+		       RenamedHsBinds,
+		       PprStyle -> Pretty)
+
+tcInstDecls1 inst_decls specinst_sigs mod_name renamer_name_funs fixities
+  = 	-- Do the ordinary instance declarations
+    mapBagNF_Tc (tcInstDecl1 mod_name) inst_decls
+			`thenNF_Tc` \ inst_info_bags ->
     let
-	class_lookup_maybe_fn
-	    :: Class
-	    -> Maybe (ClassInstEnv, (ClassOp -> SpecEnv))
-	class_lookup_fn
-	    :: InstanceMapper
-
-	class_lookup_maybe_fn = mkLookupFun (==) inst_env_entries
-
-    	class_lookup_fn c
-	  = case class_lookup_maybe_fn c of
-	      Nothing -> (nullMEnv, \ o -> nullSpecEnv)
-	      Just xx -> xx
+	decl_inst_info = concatBag inst_info_bags
     in
-    returnTc class_lookup_fn
-\end{code}
+	-- 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 renamer_name_funs decl_inst_info fixities
+		    	`thenTc` \ (deriv_inst_info, deriv_binds, ddump_deriv) ->
 
-\begin{code}
-buildInstanceEnv :: [InstInfo]		-- Non-empty, and all for same class
-	         -> TcM (Class, (ClassInstEnv, (ClassOp -> SpecEnv)))
-
-buildInstanceEnv inst_infos@(info_for_one@(InstInfo clas _ _ _ _ _ _ _ _ _ _ _) : rest)
-  = let
-	ops	  = getClassOps clas
-	no_of_ops = length ops
+    let
+	inst_info = deriv_inst_info `unionBags` decl_inst_info
     in
-    foldlTc addClassInstance
-	    (nullMEnv, nOfThem no_of_ops nullSpecEnv)
-	    inst_infos	    `thenTc` \ (class_inst_env, op_inst_envs) ->
+{- LATER
+	-- Handle specialise instance pragmas
+    tcSpecInstSigs inst_info specinst_sigs
+			`thenTc` \ spec_inst_info ->
+-}
     let
-	class_op_maybe_fn :: ClassOp -> Maybe SpecEnv
-	class_op_fn	  :: ClassOp -> SpecEnv
-
-	class_op_maybe_fn = mkLookupFun (==) (ops `zip` op_inst_envs)
-			-- They compare by ClassOp tags
-    	class_op_fn op
-	  = case class_op_maybe_fn op of
-	      Nothing -> nullSpecEnv
-	      Just xx -> xx
+	spec_inst_info = emptyBag	-- For now
+
+	full_inst_info = inst_info `unionBags` spec_inst_info
     in
-    returnTc (clas, (class_inst_env, class_op_fn))
+    returnTc (full_inst_info, deriv_binds, ddump_deriv)
+
+
+tcInstDecl1 :: FAST_STRING -> 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)
+  = 	-- 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) ->
+
+	-- Typecheck the context and instance type
+    tcTyVarScope tyvar_names (\ tyvars ->
+	tcContext context		`thenTc` \ theta ->
+	tcMonoTypeKind 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
+					`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 inst_mod pragmas
+		         clas inst_tyvars inst_tau inst_theta uprags
+					`thenTc` \ (dfun_id, dfun_theta, const_meth_ids) ->
+
+    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))
 \end{code}
 
-\begin{code}
-addClassInstance
-    :: (ClassInstEnv, [SpecEnv])
-    -> InstInfo
-    -> TcM (ClassInstEnv, [SpecEnv])	-- One SpecEnv for each class op
-
-addClassInstance
-    (class_inst_env, op_spec_envs) 
-    (InstInfo clas inst_tyvars inst_ty inst_decl_theta dfun_theta dfun_id const_meth_ids _ _ _ src_loc _)
-  = getSwitchCheckerTc		`thenNF_Tc` \ sw_chkr ->
-	-- We anly add specialised/overlapped instances
-	-- if we are specialising the overloading
---
--- ToDo ... This causes getConstMethodId errors!
---
---    if is_plain_instance inst_ty || sw_chkr SpecialiseOverloaded
---    then
-
-	-- Insert into the class_inst_env first
-	checkMaybeErrTc (addClassInst clas class_inst_env inst_ty dfun_id inst_tyvars dfun_theta src_loc)
-		        dupInstErr		`thenTc` \ class_inst_env' ->
-	let 
-		-- Adding the classop instances can't fail if the class instance itself didn't
-	    op_spec_envs' = case const_meth_ids of
-			      []    -> op_spec_envs
-			      other -> zipWith add_const_meth op_spec_envs const_meth_ids
-    	in
-    	returnTc (class_inst_env', op_spec_envs')
-
---    else
---	-- Drop this specialised/overlapped instance
---	returnTc (class_inst_env, op_spec_envs) 
-
-  where
-    add_const_meth spec_env meth_id
-      = addOneToSpecEnv spec_env (SpecInfo (Just inst_ty:nothings) 1 meth_id)
-      where
-	(const_meth_tyvars,_) = splitForalls (getIdUniType meth_id)
-	nothings = [Nothing | _ <- const_meth_tyvars]
-	-- This only works if the constant method id only has its local polymorphism.
-	-- If you want to have constant methods for
-	-- 				instance Foo (a,b,c) where
-	--					op x = ...
-	-- then the constant method will be polymorphic in a,b,c, and
-	-- the SpecInfo will need to be elaborated.
-
-\end{code}
 
 %************************************************************************
 %*									*
@@ -473,30 +251,22 @@ addClassInstance
 %************************************************************************
 
 \begin{code}
-tcInstDecls2 :: E 
-	     -> Bag InstInfo
-	     -> NF_TcM (LIE, TypecheckedBinds)
-
-tcInstDecls2 e inst_decls 
-  = let
-	-- Get type variables free in environment. Sadly, there may be
-	-- some, because of the dreaded monomorphism restriction
-	free_tyvars = tvOfE e
-    in
-    tcInstDecls2_help e free_tyvars (bagToList inst_decls)
+tcInstDecls2 :: Bag InstInfo
+	     -> NF_TcM s (LIE s, TcHsBinds s)
 
-tcInstDecls2_help e free_tyvars [] = returnNF_Tc (nullLIE, EmptyBinds)
-
-tcInstDecls2_help e free_tyvars (inst_decl:inst_decls)
- = tcInstDecl2       e free_tyvars inst_decl	`thenNF_Tc` \ (lie1, binds1) ->
-   tcInstDecls2_help e free_tyvars inst_decls	`thenNF_Tc` \ (lie2, binds2) ->
-   returnNF_Tc (lie1 `plusLIE` lie2, binds1 `ThenBinds` binds2)
+tcInstDecls2 inst_decls
+  = foldBag combine tcInstDecl2 (returnNF_Tc (emptyLIE, EmptyBinds)) inst_decls
+  where
+    combine tc1 tc2 = tc1 	`thenNF_Tc` \ (lie1, binds1) ->
+		      tc2	`thenNF_Tc` \ (lie2, binds2) ->
+		      returnNF_Tc (lie1 `plusLIE` lie2,
+				   binds1 `ThenBinds` binds2)
 \end{code}
 
 
 ======= New documentation starts here (Sept 92)	 ==============
 
-The main purpose of @tcInstDecl2@ is to return a @Binds@ which defines
+The main purpose of @tcInstDecl2@ is to return a @HsBinds@ which defines
 the dictionary function for this instance declaration.	For example
 \begin{verbatim}
 	instance Foo a => Foo [a] where
@@ -511,41 +281,40 @@ might generate something like
 				   Dict [op1, op2]
 \end{verbatim}
 
-HOWEVER, if the instance decl has no type variables, then it returns a
-bigger @Binds@ with declarations for each method.  For example
+HOWEVER, if the instance decl has no context, then it returns a
+bigger @HsBinds@ with declarations for each method.  For example
 \begin{verbatim}
-	instance Foo Int where
+	instance Foo [a] where
 		op1 x = ...
 		op2 y = ...
 \end{verbatim}
 might produce
 \begin{verbatim}
-	dfun.Foo.Int = Dict [Foo.op1.Int, Foo.op2.Int]
-	Foo.op1.Int x = ...
-	Foo.op2.Int y = ...
+	dfun.Foo.List a = Dict [Foo.op1.List a, Foo.op2.List a]
+	const.Foo.op1.List a x = ...
+	const.Foo.op2.List a y = ...
 \end{verbatim}
 This group may be mutually recursive, because (for example) there may
 be no method supplied for op2 in which case we'll get
 \begin{verbatim}
-	Foo.op2.Int = default.Foo.op2 dfun.Foo.Int
+	const.Foo.op2.List a = default.Foo.op2 (dfun.Foo.List a)
 \end{verbatim}
 that is, the default method applied to the dictionary at this type.
 
-\begin{code}
-tcInstDecl2 :: E
-	    -> [TyVar]		-- Free in the environment
-	    -> InstInfo 
-	    -> NF_TcM (LIE, TypecheckedBinds)
-\end{code}
+What we actually produce in either case is:
 
-First comes the easy case of a non-local instance decl.
+	AbsBinds [a] [dfun_theta_dicts]
+		 [(dfun.Foo.List, d)] ++ (maybe) [(const.Foo.op1.List, op1), ...]
+		 { d = (sd1,sd2, ..., op1, op2, ...)
+		   op1 = ...
+		   op2 = ...
+	 	 }
 
-\begin{code}
-tcInstDecl2 e free_tyvars (InstInfo _ _ _ _ _ _ _ _ False{-not this module-} _ _ _)
-  = returnNF_Tc (nullLIE, EmptyBinds)
-\end{code}
+The "maybe" says that we only ask AbsBinds to make global constant methods
+if the dfun_theta is empty.
 
-Now the case of a general local instance.  For an instance declaration, say,
+		
+For an instance declaration, say,
 
 	instance (C1 a, C2 b) => C (T a b) where
 		...
@@ -559,193 +328,115 @@ Notice that we pass it the superclass dictionaries at the instance type; this
 is the ``Mark Jones optimisation''.  The stuff before the "=>" here
 is the @dfun_theta@ below.
 
+First comes the easy case of a non-local instance decl.
+
 \begin{code}
-tcInstDecl2
-    e free_tyvars 
-    (InstInfo clas template_tyvars inst_ty_tmpl inst_decl_theta dfun_theta
-	      dfun_id const_meth_ids monobinds True{-from here-} inst_mod locn uprags)
-  = let
-	origin = InstanceDeclOrigin locn
-    in
-    recoverTc (nullLIE, EmptyBinds) 	(
-    addSrcLocTc locn			(
-    pruneSubstTc free_tyvars 		(
+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)
+  =	 -- Prime error recovery
+    recoverNF_Tc (returnNF_Tc (emptyLIE, EmptyBinds)) 	$
+    tcAddSrcLoc locn					$
 
 	-- Get the class signature
-    let (class_tyvar, 
-	 super_classes, sc_sel_ids,
-	 class_ops, op_sel_ids, defm_ids) = getClassBigSig clas
-    in
-	 -- Prime error recovery and substitution pruning. Instantiate
-	 -- dictionaries from the specified instance context. These
-	 -- dicts will be passed into the dictionary-construction
-	 -- function.
-    copyTyVars template_tyvars	`thenNF_Tc` \ (inst_env, inst_tyvars, inst_tyvar_tys) ->
+    mapNF_Tc tcInstTyVar inst_tyvars	`thenNF_Tc` \ inst_tyvars' ->
     let 
-	inst_ty 	 = instantiateTy inst_env inst_ty_tmpl
+	tenv = inst_tyvars `zip` (map mkTyVarTy inst_tyvars')
 
-	inst_decl_theta' = instantiateThetaTy inst_env inst_decl_theta
-	dfun_theta'	 = instantiateThetaTy inst_env dfun_theta
-	sc_theta' 	 = super_classes `zip` (repeat inst_ty)
-    in
-    newDicts origin sc_theta'			`thenNF_Tc` \ sc_dicts' ->
-    newDicts origin dfun_theta'			`thenNF_Tc` \ dfun_arg_dicts' ->
-    newDicts origin inst_decl_theta'		`thenNF_Tc` \ inst_decl_dicts' ->
-    let
-	sc_dicts'_ids       = map mkInstId sc_dicts'
-	dfun_arg_dicts'_ids = map mkInstId dfun_arg_dicts'
+        (class_tyvar,
+	 super_classes, sc_sel_ids,
+	 class_ops, op_sel_ids, defm_ids) = getClassBigSig clas
     in
-	-- Instantiate the dictionary being constructed 
-	-- and the dictionary-construction function
-    newDicts origin [(clas,inst_ty)]		`thenNF_Tc` \ [this_dict] ->
+    tcInstType tenv inst_ty		`thenNF_Tc` \ inst_ty' ->
+    tcInstTheta tenv dfun_theta		`thenNF_Tc` \ dfun_theta' ->
+    tcInstTheta tenv inst_decl_theta	`thenNF_Tc` \ inst_decl_theta' ->
     let
-	this_dict_id = mkInstId this_dict
-    in
-	 -- Instantiate method variables
-    listNF_Tc [ newMethodId sel_id inst_ty origin locn
-	      |	sel_id <- op_sel_ids
-	      ]					`thenNF_Tc` \ method_ids ->
-    let 
-	method_insts = catMaybes (map isInstId_maybe method_ids)
-	-- Extract Insts from those method ids which have them (most do)
-	-- See notes on newMethodId
-    in
-	 -- Collect available dictionaries
-    let avail_insts =	 -- These insts are in scope; quite a few, eh?
-	    [this_dict]		++
-	    method_insts	++
-	    dfun_arg_dicts'
+	sc_theta'        = super_classes `zip` (repeat inst_ty')
+ 	origin    	 = InstanceDeclOrigin
+	mk_method sel_id = newMethod origin (RealId sel_id) [inst_ty']
     in
-    getSwitchCheckerTc			`thenNF_Tc` \ sw_chkr ->
+	 -- Create dictionary Ids from the specified instance contexts.
+    newDicts origin sc_theta'		`thenNF_Tc` \ (sc_dicts,        sc_dict_ids) ->
+    newDicts origin dfun_theta'		`thenNF_Tc` \ (dfun_arg_dicts,  dfun_arg_dicts_ids)  ->
+    newDicts origin inst_decl_theta'	`thenNF_Tc` \ (inst_decl_dicts, _) ->
+    newDicts origin [(clas,inst_ty')]	`thenNF_Tc` \ (this_dict,       [this_dict_id]) ->
+
+	 -- Create method variables
+    mapAndUnzipNF_Tc mk_method op_sel_ids	`thenNF_Tc` \ (meth_insts_s, meth_ids) ->
+
+	 -- Collect available Insts
     let
+	avail_insts	 -- These insts are in scope; quite a few, eh?
+	  = unionManyBags (this_dict : dfun_arg_dicts : meth_insts_s) 
+
 	mk_method_expr
-	  = if sw_chkr OmitDefaultInstanceMethods then
-		makeInstanceDeclNoDefaultExpr origin clas method_ids defm_ids inst_mod inst_ty
+	  = if opt_OmitDefaultInstanceMethods then
+		makeInstanceDeclNoDefaultExpr origin clas meth_ids defm_ids inst_mod inst_ty'
 	    else
-		makeInstanceDeclDefaultMethodExpr origin this_dict_id class_ops defm_ids inst_ty
+		makeInstanceDeclDefaultMethodExpr origin this_dict_id class_ops defm_ids inst_ty'
     in
-    processInstBinds e free_tyvars mk_method_expr
-	inst_tyvars avail_insts method_ids monobinds
-					 `thenTc` \ (insts_needed, method_mbinds) ->
+    processInstBinds mk_method_expr inst_tyvars' avail_insts meth_ids monobinds
+					 	`thenTc` \ (insts_needed, method_mbinds) ->
     let
 	-- Create the dict and method binds
 	dict_bind
-	    = VarMonoBind this_dict_id (Dictionary sc_dicts'_ids method_ids)
+	    = VarMonoBind this_dict_id (Dictionary sc_dict_ids meth_ids)
 
 	dict_and_method_binds
 	    = dict_bind `AndMonoBinds` method_mbinds
+
+	inst_tyvars_set' = tyVarListToSet inst_tyvars'
     in
 	-- Check the overloading constraints of the methods and superclasses
-	-- The global tyvars must be a fixed point of the substitution
-    applyTcSubstAndCollectTyVars free_tyvars  `thenNF_Tc` \ real_free_tyvars ->
-    tcSimplifyAndCheck
-		 True				-- Top level
-		 real_free_tyvars		-- Global tyvars
-		 inst_tyvars			-- Local tyvars
+    tcAddErrCtxt (bindSigCtxt meth_ids) (
+	tcSimplifyAndCheck
+		 inst_tyvars_set'			-- Local tyvars
 		 avail_insts
-		 (sc_dicts' ++ insts_needed)	-- Need to get defns for all these
-		 (BindSigCtxt method_ids)
-					 `thenTc` \ (const_insts, super_binds) ->
+		 (sc_dicts `unionBags` insts_needed)	-- Need to get defns for all these
+    )					 `thenTc` \ (const_lie, super_binds) ->
 
 	-- Check that we *could* construct the superclass dictionaries,
 	-- even though we are *actually* going to pass the superclass dicts in;
 	-- the check ensures that the caller will never have a problem building
 	-- them.
+    tcAddErrCtxt superClassSigCtxt (
     tcSimplifyAndCheck
-		 False				-- Doesn't matter; more efficient this way
-		 real_free_tyvars		-- Global tyvars
-		 inst_tyvars			-- Local tyvars
-		 inst_decl_dicts'		-- The instance dictionaries available
-		 sc_dicts'			-- The superclass dicationaries reqd
-		 SuperClassSigCtxt
-						 `thenTc_`
+		 inst_tyvars_set'		-- Local tyvars
+		 inst_decl_dicts		-- The instance dictionaries available
+		 sc_dicts			-- The superclass dicationaries reqd
+    )					`thenTc_`
 						-- Ignore the result; we're only doing
 						-- this to make sure it can be done.
 
 	-- Now process any SPECIALIZE pragmas for the methods
     let
 	spec_sigs = [ s | s@(SpecSig _ _ _ _) <- uprags ]
-
-	get_const_method_id name
-	  = const_meth_ids !! ((getTagFromClassOpName name) - 1)
     in
-    tcSigs e [] spec_sigs		`thenTc` \ sig_info ->
-
-    mapAndUnzipTc (doSpecPragma e get_const_method_id) sig_info
-					`thenTc` \ (spec_binds_s, spec_lie_s) ->
-    let 
-	spec_lie   = foldr plusLIE nullLIE spec_lie_s
-	spec_binds = foldr AndMonoBinds EmptyMonoBinds spec_binds_s
-
+    tcPragmaSigs spec_sigs		`thenTc` \ (_, spec_binds, spec_lie) ->
+    let
 	-- Complete the binding group, adding any spec_binds
-        inst_binds
-	  = AbsBinds 
-		 inst_tyvars
-		 dfun_arg_dicts'_ids
-		 ((this_dict_id,dfun_id) : (method_ids `zip` const_meth_ids))
+	inst_binds
+	  = AbsBinds
+		 inst_tyvars'
+		 dfun_arg_dicts_ids
+		 ((this_dict_id, RealId dfun_id) 
+		  : (meth_ids `zip` (map RealId const_meth_ids)))
 			-- const_meth_ids will often be empty
 		 super_binds
 		 (RecBind dict_and_method_binds)
-	    
+
 	    `ThenBinds`
-	    SingleBind (NonRecBind spec_binds)
+	    spec_binds
     in
-	 -- Back-substitute
-    applyTcSubstToBinds inst_binds `thenNF_Tc` \ final_inst_binds ->
-
-    returnTc (mkLIE const_insts `plusLIE` spec_lie,
-	      final_inst_binds)
-    )))
-\end{code}
-
-@mkMethodId@ manufactures an id for a local method.
-It's rather turgid stuff, because there are two cases:
-
-  (a) For methods with no local polymorphism, we can make an Inst of the 
-      class-op selector function and a corresp InstId; 
-      which is good because then other methods which call
-      this one will do so directly.
 
-  (b) For methods with local polymorphism, we can't do this.  For example,
-
-	 class Foo a where
-		op :: (Num b) => a -> b -> a
-
-      Here the type of the class-op-selector is
-
-	forall a b. (Foo a, Num b) => a -> b -> a
-
-      The locally defined method at (say) type Float will have type
-
-	forall b. (Num b) => Float -> b -> Float
-
-      and the one is not an instance of the other.
-
-      So for these we just make a local (non-Inst) id with a suitable type.
-
-How disgusting.
-
-\begin{code}
-newMethodId sel_id inst_ty origin loc
-  = let (sel_tyvars,sel_theta,sel_tau) = splitType (getIdUniType sel_id)
-	(_:meth_theta) = sel_theta	-- The local theta is all except the
-					-- first element of the context
-    in 
-       case sel_tyvars of
-	-- Ah! a selector for a class op with no local polymorphism
-	-- Build an Inst for this
-	[clas_tyvar] -> newMethod origin sel_id [inst_ty]	`thenNF_Tc` \ inst ->
-			returnNF_Tc (mkInstId inst)
-
-	-- Ho! a selector for a class op with local polymorphism.
-	-- Just make a suitably typed local id for this
-	(clas_tyvar:local_tyvars) -> 
-		let
-		    method_ty = instantiateTy [(clas_tyvar,inst_ty)]
-				    (mkSigmaTy local_tyvars meth_theta sel_tau)
-		in
-		getUniqueTc		`thenNF_Tc` \ uniq -> 
-		returnNF_Tc (mkUserLocal (getOccurrenceName sel_id) uniq method_ty loc)
+    returnTc (const_lie `plusLIE` spec_lie, inst_binds)
 \end{code}
 
 This function makes a default method which calls the global default method, at
@@ -755,71 +446,66 @@ See the notes under default decls in TcClassDcl.lhs.
 
 \begin{code}
 makeInstanceDeclDefaultMethodExpr
-	:: InstOrigin
-	-> Id
+	:: InstOrigin s
+	-> TcIdOcc s
 	-> [ClassOp]
 	-> [Id]
-	-> UniType
+	-> TcType s
 	-> Int
-	-> NF_TcM TypecheckedExpr
-	
-makeInstanceDeclDefaultMethodExpr origin this_dict_id class_ops defm_ids inst_ty tag
-  = let
-	(tyvar_tmpls, local_theta, _) = splitType (getClassOpLocalType class_op)
-    in
-    copyTyVars tyvar_tmpls	`thenNF_Tc` \ (inst_env, tyvars, tys) ->
-    let
-	inst_theta = instantiateThetaTy inst_env local_theta
-    in
-    newDicts origin inst_theta	`thenNF_Tc` \ local_dict_insts ->
-    let
-	local_dicts = map mkInstId local_dict_insts
-    in
+	-> NF_TcM s (TcExpr s)
+
+makeInstanceDeclDefaultMethodExpr origin this_dict class_ops defm_ids inst_ty tag
+  = specTy origin (getClassOpLocalType class_op)
+				`thenNF_Tc` \ (op_tyvars, op_lie, op_tau, op_dicts) ->
+
+	-- def_op_id = /\ op_tyvars -> \ op_dicts ->
+	--		  defm_id inst_ty op_tyvars this_dict op_dicts
+
     returnNF_Tc (
-      mkTyLam tyvars (
-	mkDictLam local_dicts (
-	  mkDictApp (mkTyApp (Var defm_id)
-			     (inst_ty : tys))
-		    (this_dict_id:local_dicts)))
-    )
+      mkHsTyLam op_tyvars (
+      mkHsDictLam op_dicts (
+      mkHsDictApp (mkHsTyApp (HsVar (RealId defm_id))
+			     (inst_ty :  map mkTyVarTy op_tyvars))
+		  (this_dict : op_dicts)
+      )))
  where
     idx	     = tag - 1
     class_op = class_ops !! idx
     defm_id  = defm_ids  !! idx
 
-
 makeInstanceDeclNoDefaultExpr
-	:: InstOrigin
+	:: InstOrigin s
 	-> Class
-	-> [Id]
+	-> [TcIdOcc s]
 	-> [Id]
 	-> FAST_STRING
-	-> UniType
+	-> TcType s
 	-> Int
-	-> NF_TcM TypecheckedExpr
-	
-makeInstanceDeclNoDefaultExpr origin clas method_ids defm_ids inst_mod inst_ty tag
-  = specTy origin (getIdUniType method_id) `thenNF_Tc` \ (tyvars, dicts, tau) ->
-
-    (if not err_defm then
-	 pprTrace "Warning: "
-	 (ppCat [ppStr "Omitted default method for",
-		 ppr PprForUser clas_op, ppStr "in instance",
-		 ppPStr clas_name, pprParendUniType PprForUser inst_ty])
-    else id) (
+	-> NF_TcM s (TcExpr s)
 
-    returnNF_Tc (mkTyLam tyvars (
-		 mkDictLam (map mkInstId dicts) (
-		 App (mkTyApp (Var pAT_ERROR_ID) [tau])
-		     (Lit (StringLit (_PK_ error_msg))))))
-    )
+makeInstanceDeclNoDefaultExpr origin clas method_occs defm_ids inst_mod inst_ty tag
+  = let
+	(op_tyvars,op_theta,op_tau) = splitSigmaTy (idType method_id)
+    in
+    newDicts origin op_theta		`thenNF_Tc` \ (op_lie,op_dicts) ->
+
+	-- 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)
+					`thenNF_Tc_`
+    returnNF_Tc (mkHsTyLam op_tyvars (
+		 mkHsDictLam op_dicts (
+		 HsApp (mkHsTyApp (HsVar (RealId pAT_ERROR_ID)) [op_tau])
+		     (HsLitOut (HsString (_PK_ error_msg)) stringTy))))
   where
-    idx	      = tag - 1
-    clas_op   = (getClassOps clas) !! idx
-    method_id = method_ids  !! idx
-    defm_id   = defm_ids  !! idx
+    idx	           = tag - 1
+    method_occ     = method_occs  !! idx
+    clas_op        = (getClassOps clas) !! idx
+    defm_id        = defm_ids  !! idx
 
-    Just (_, _, err_defm) = isDefaultMethodId_maybe defm_id
+    TcId method_id = method_occ
+    Just (_, _, err_defm_ok) = isDefaultMethodId_maybe defm_id
 
     error_msg = "%E" 	-- => No explicit method for \"
 	     	++ escErrorMsg error_str
@@ -838,84 +524,75 @@ makeInstanceDeclNoDefaultExpr origin clas method_ids defm_ids inst_mod inst_ty t
 %*									*
 %************************************************************************
 
-@processInstBinds@ returns a @MonoBinds@ which binds 
+@processInstBinds@ returns a @MonoBinds@ which binds
 all the method ids (which are passed in).  It is used
-	- both for instance decls, 
+	- both for instance decls,
 	- and to compile the default-method declarations in a class decl.
 
-Any method ids which don't have a binding have a suitable default 
-binding created for them. The actual right-hand side used is 
+Any method ids which don't have a binding have a suitable default
+binding created for them. The actual right-hand side used is
 created using a function which is passed in, because the right thing to
 do differs between instance and class decls.
 
 \begin{code}
 processInstBinds
-	:: E
-	-> [TyVar]			   -- Free in envt
-
-	-> (Int -> NF_TcM TypecheckedExpr) -- Function to make
-					   -- default method
-
-	-> [TyVar]			   -- Tyvars for this instance decl
-
-	-> [Inst]			   -- available Insts
-
-	-> [Id]				   -- Local method ids 
-					   --	(instance tyvars are free 
-					   --	in their types),
-					   --	in tag order
+	:: (Int -> NF_TcM s (TcExpr s))    -- Function to make default method
+	-> [TcTyVar s]			   -- Tyvars for this instance decl
+	-> LIE s			   -- available Insts
+	-> [TcIdOcc s]			   -- Local method ids in tag order
+					   --	(instance tyvars are free in their types)
 	-> RenamedMonoBinds
+	-> TcM s (LIE s,		   -- These are required
+		  TcMonoBinds s)
 
-	-> TcM ([Inst],			-- These are required
-		TypecheckedMonoBinds)
-
-processInstBinds e free_tyvars mk_method_expr inst_tyvars
-		 avail_insts method_ids monobinds
-  = 
+processInstBinds mk_default_method_rhs inst_tyvars avail_insts method_ids monobinds
+  =
 	 -- Process the explicitly-given method bindings
-    processInstBinds1 e free_tyvars inst_tyvars avail_insts method_ids monobinds
-	 `thenTc` (\ (tags, insts_needed_in_methods, method_binds) ->
+    processInstBinds1 inst_tyvars avail_insts method_ids monobinds
+	 		`thenTc` \ (tags, insts_needed_in_methods, method_binds) ->
 
 	 -- Find the methods not handled, and make default method bindings for them.
-    let unmentioned_tags = [1.. length method_ids] `minusList` tags
+    let
+	unmentioned_tags = [1.. length method_ids] `minusList` tags
     in
-    makeDefaultMethods mk_method_expr unmentioned_tags method_ids
-					 `thenNF_Tc`	(\ default_monobinds ->
+    mapNF_Tc mk_default_method unmentioned_tags
+			`thenNF_Tc` \ default_bind_list ->
 
-    returnTc (insts_needed_in_methods, 
-	      method_binds `AndMonoBinds` default_monobinds)
-    ))
+    returnTc (insts_needed_in_methods,
+	      foldr AndMonoBinds method_binds default_bind_list)
+  where
+	-- From a tag construct us the passed-in function to construct
+	-- the binding for the default method
+    mk_default_method tag = mk_default_method_rhs tag 	`thenNF_Tc` \ rhs ->
+			    returnNF_Tc (VarMonoBind (method_ids !! (tag-1)) rhs)
 \end{code}
 
 \begin{code}
 processInstBinds1
-	:: E
-	-> [TyVar]		-- Global free tyvars
-	-> [TyVar]		-- Tyvars for this instance decl
-	-> [Inst]		-- available Insts
-	-> [Id]			-- Local method ids (instance tyvars are free),
-				--	in tag order
-	-> RenamedMonoBinds 
-	-> TcM ([Int],		-- Class-op tags accounted for
-		[Inst],		-- These are required
-		TypecheckedMonoBinds)
-
-processInstBinds1 e free_tyvars inst_tyvars avail_insts method_ids EmptyMonoBinds
-  = returnTc ([], [], EmptyMonoBinds)
-
-processInstBinds1 e free_tyvars inst_tyvars avail_insts method_ids (AndMonoBinds mb1 mb2)
-  = processInstBinds1 e free_tyvars inst_tyvars avail_insts method_ids mb1
+	:: [TcTyVar s]		-- Tyvars for this instance decl
+	-> LIE s		-- available Insts
+	-> [TcIdOcc s]		-- Local method ids in tag order (instance tyvars are free),
+	-> RenamedMonoBinds
+	-> TcM s ([Int],	-- Class-op tags accounted for
+		  LIE s,	-- These are required
+		  TcMonoBinds s)
+
+processInstBinds1 inst_tyvars avail_insts method_ids EmptyMonoBinds
+  = returnTc ([], emptyLIE, EmptyMonoBinds)
+
+processInstBinds1 inst_tyvars avail_insts method_ids (AndMonoBinds mb1 mb2)
+  = processInstBinds1 inst_tyvars avail_insts method_ids mb1
 				 `thenTc`	\ (op_tags1,dicts1,method_binds1) ->
-    processInstBinds1 e free_tyvars inst_tyvars avail_insts method_ids mb2
+    processInstBinds1 inst_tyvars avail_insts method_ids mb2
 				 `thenTc`	\ (op_tags2,dicts2,method_binds2) ->
     returnTc (op_tags1 ++ op_tags2,
-	      dicts1 ++ dicts2,
+	      dicts1 `unionBags` dicts2,
 	      AndMonoBinds method_binds1 method_binds2)
 \end{code}
 
 \begin{code}
-processInstBinds1 e free_tyvars inst_tyvars avail_insts method_ids mbind
-  = 
+processInstBinds1 inst_tyvars avail_insts method_ids mbind
+  =
     -- Find what class op is being defined here.  The complication is
     -- that we could have a PatMonoBind or a FunMonoBind.  If the
     -- former, it should only bind a single variable, or else we're in
@@ -926,53 +603,56 @@ processInstBinds1 e free_tyvars inst_tyvars avail_insts method_ids mbind
 	(op,locn) = case mbind of
 		      FunMonoBind op _ locn	       -> (op, locn)
 		      PatMonoBind (VarPatIn op) _ locn -> (op, locn)
-    
-	origin = InstanceDeclOrigin locn
+
+        occ    = getOccurrenceName op
+	origin = InstanceDeclOrigin
     in
-    addSrcLocTc locn			 (
+    tcAddSrcLoc locn			 $
 
     -- Make a method id for the method
     let tag       = getTagFromClassOpName op
-        method_id = method_ids !! (tag-1)
-	method_ty = getIdUniType method_id
+	method_id = method_ids !! (tag-1)
+
+	TcId method_bndr = method_id
+	method_ty = idType method_bndr
+	(method_tyvars, method_theta, method_tau) = splitSigmaTy method_ty
     in
-    specTy origin method_ty  `thenNF_Tc` \ (method_tyvars, method_dicts, method_tau) ->
+    newDicts origin method_theta		`thenNF_Tc` \ (method_dicts,method_dict_ids) ->
 
-	-- Build the result
-    case (method_tyvars, method_dicts) of
+    case (method_tyvars, method_dict_ids) of
 
       ([],[]) -> -- The simple case; no local polymorphism or overloading in the method
 
 		-- Type check the method itself
-	tcMethodBind e method_id method_tau mbind    `thenTc` \ (mbind', lieIop) ->
+	tcMethodBind method_id method_tau mbind	`thenTc` \ (mbind', lieIop) ->
 
 		-- Make sure that the instance tyvars havn't been
 		-- unified with each other or with the method tyvars.
-		-- The global tyvars must be a fixed point of the substitution
-	applyTcSubstAndCollectTyVars free_tyvars `thenNF_Tc` \ real_free_tyvars ->
-	checkSigTyVars real_free_tyvars inst_tyvars method_tau method_tau
-			      (MethodSigCtxt op method_tau) `thenTc_`
-
-	returnTc ([tag], unMkLIE lieIop, mbind')
+	tcSetErrCtxt (methodSigCtxt op method_tau) (
+	  checkSigTyVars inst_tyvars method_tau method_tau
+	)					`thenTc_`
+	returnTc ([tag], lieIop, mbind')
 
       other ->	-- It's a locally-polymorphic and/or overloaded method; UGH!
 
-		 -- Make a new id for (a) the local, non-overloaded method
-		 -- and		      (b) the locally-overloaded method
-		 -- The latter is needed just so we can return an AbsBinds wrapped
-		 -- up inside a MonoBinds.
-	newLocalWithGivenTy op method_tau	`thenNF_Tc` \ local_meth_id ->
-	newLocalWithGivenTy op method_ty	`thenNF_Tc` \ copy_meth_id ->
+		-- Make a new id for (a) the local, non-overloaded method
+		-- and		     (b) the locally-overloaded method
+		-- The latter is needed just so we can return an AbsBinds wrapped
+		-- up inside a MonoBinds.
 
+	newLocalIds [occ,occ] [method_tau,method_ty] `thenNF_Tc` \ new_ids ->
+	let
+	    [local_id, copy_id] = map TcId new_ids
+	    inst_method_tyvars = inst_tyvars ++ method_tyvars
+	in
 		-- Typecheck the method
-	tcMethodBind e local_meth_id method_tau mbind `thenTc` \ (mbind', lieIop) ->
+	tcMethodBind local_id method_tau mbind `thenTc` \ (mbind', lieIop) ->
 
 		-- Make sure that the instance tyvars haven't been
 		-- unified with each other or with the method tyvars.
-		-- The global tyvars must be a fixed point of the substitution
-	applyTcSubstAndCollectTyVars free_tyvars `thenNF_Tc` \ real_free_tyvars ->
-	checkSigTyVars real_free_tyvars (method_tyvars ++ inst_tyvars) method_tau method_tau
-			      (MethodSigCtxt op method_tau) `thenTc_`
+	tcAddErrCtxt (methodSigCtxt op method_tau) (
+	  checkSigTyVars inst_method_tyvars method_tau method_tau
+	)				        `thenTc_`
 
 		-- Check the overloading part of the signature.
 		-- Simplify everything fully, even though some
@@ -983,72 +663,43 @@ processInstBinds1 e free_tyvars inst_tyvars avail_insts method_ids mbind
 		--
 		-- Here we must simplify constraints on "a" to catch all
 		-- the Bar-ish things.
-	tcSimplifyAndCheck
-		False			-- Not top level
-		real_free_tyvars 
-		(inst_tyvars ++ method_tyvars)
-		(method_dicts ++ avail_insts)
-		(unMkLIE lieIop)	
-		(MethodSigCtxt op method_ty) 	`thenTc` \ (f_dicts, dict_binds) ->
+	tcAddErrCtxt (methodSigCtxt op method_ty) (
+	  tcSimplifyAndCheck
+		(tyVarListToSet inst_method_tyvars)
+		(method_dicts `plusLIE` avail_insts)
+		lieIop
+	) 					 `thenTc` \ (f_dicts, dict_binds) ->
 
 	returnTc ([tag],
 		  f_dicts,
 		  VarMonoBind method_id
-			 (Let
+			 (HsLet
 			     (AbsBinds
 				method_tyvars
-				(map mkInstId method_dicts)
-				[(local_meth_id, copy_meth_id)]
+				method_dict_ids
+				[(local_id, copy_id)]
 				dict_binds
 				(NonRecBind mbind'))
-			     (Var copy_meth_id)))
-    )
+			     (HsVar copy_id)))
 \end{code}
 
 \begin{code}
-tcMethodBind :: E -> Id -> UniType -> RenamedMonoBinds 
-	    -> TcM (TypecheckedMonoBinds, LIE)
+tcMethodBind :: TcIdOcc s -> TcType s -> RenamedMonoBinds
+	     -> TcM s (TcMonoBinds s, LIE s)
 
-tcMethodBind e meth_id meth_ty (FunMonoBind name matches locn)
-  = addSrcLocTc locn				 (
-    tcMatchesFun e name meth_ty matches `thenTc` \ (rhs', lie) ->
+tcMethodBind meth_id meth_ty (FunMonoBind name matches locn)
+  = tcMatchesFun name meth_ty matches `thenTc` \ (rhs', lie) ->
     returnTc (FunMonoBind meth_id rhs' locn, lie)
-    )
 
-tcMethodBind e meth_id meth_ty (PatMonoBind pat grhss_and_binds locn)
+tcMethodBind meth_id meth_ty pbind@(PatMonoBind pat grhss_and_binds locn)
   -- pat is sure to be a (VarPatIn op)
-  = addSrcLocTc locn				 (
-    tcGRHSsAndBinds e grhss_and_binds 	`thenTc` \ (grhss_and_binds', lie, rhs_ty) ->
-    unifyTauTy meth_ty rhs_ty (PatMonoBindsCtxt pat grhss_and_binds) `thenTc_`
+  = tcAddErrCtxt (patMonoBindsCtxt pbind) $
+    tcGRHSsAndBinds grhss_and_binds 	`thenTc` \ (grhss_and_binds', lie, rhs_ty) ->
+    unifyTauTy meth_ty rhs_ty 		`thenTc_`
     returnTc (PatMonoBind (VarPat meth_id) grhss_and_binds' locn, lie)
-    )
 \end{code}
 
 
-Creates bindings for the default methods, being the application of the
-appropriate global default method to the type of this instance decl.
-
-\begin{code}
-makeDefaultMethods 
-	:: (Int -> NF_TcM TypecheckedExpr)	-- Function to make
-						-- default method
-	-> [Int]				-- Tags for methods required
-	-> [Id]					-- Method names to bind, in tag order
-	-> NF_TcM TypecheckedMonoBinds
-
-	
-makeDefaultMethods mk_method_expr [] method_ids
-  = returnNF_Tc EmptyMonoBinds
-
-makeDefaultMethods mk_method_expr (tag:tags) method_ids
-  = mk_method_expr tag				      `thenNF_Tc` \ rhs ->
-    makeDefaultMethods mk_method_expr tags method_ids `thenNF_Tc` \ meth_binds ->
-
-    returnNF_Tc ((VarMonoBind method_id rhs) `AndMonoBinds` meth_binds)
-  where
-    method_id = method_ids !! (tag-1)
-\end{code}
-
 %************************************************************************
 %*									*
 \subsection{Type-checking specialise instance pragmas}
@@ -1056,10 +707,11 @@ makeDefaultMethods mk_method_expr (tag:tags) method_ids
 %************************************************************************
 
 \begin{code}
+{- LATER
 tcSpecInstSigs :: E -> CE -> TCE
-	       -> Bag InstInfo				-- inst decls seen (declared and derived)
-	       -> [RenamedSpecialisedInstanceSig]	-- specialise instance upragmas
-	       -> TcM (Bag InstInfo)			-- new, overlapped, inst decls
+	       -> Bag InstInfo		-- inst decls seen (declared and derived)
+	       -> [RenamedSpecInstSig]	-- specialise instance upragmas
+	       -> TcM (Bag InstInfo)	-- new, overlapped, inst decls
 
 tcSpecInstSigs e ce tce inst_infos []
   = returnTc emptyBag
@@ -1073,18 +725,18 @@ tcSpecInstSigs e ce tce inst_infos sigs
       = returnNF_Tc emptyBag
     tc_inst_spec_sigs inst_mapper (sig:sigs)
       = tcSpecInstSig e ce tce inst_infos inst_mapper sig	`thenNF_Tc` \ info_sig ->
-        tc_inst_spec_sigs inst_mapper sigs			`thenNF_Tc` \ info_sigs ->
-        returnNF_Tc (info_sig `unionBags` info_sigs)
+	tc_inst_spec_sigs inst_mapper sigs			`thenNF_Tc` \ info_sigs ->
+	returnNF_Tc (info_sig `unionBags` info_sigs)
 
 tcSpecInstSig :: E -> CE -> TCE
 	      -> Bag InstInfo
 	      -> InstanceMapper
-	      -> RenamedSpecialisedInstanceSig
+	      -> RenamedSpecInstSig
 	      -> NF_TcM (Bag InstInfo)
 
-tcSpecInstSig e ce tce inst_infos inst_mapper (InstSpecSig class_name ty src_loc)
+tcSpecInstSig e ce tce inst_infos inst_mapper (SpecInstSig class_name ty src_loc)
   = recoverTc emptyBag			(
-    addSrcLocTc src_loc			(
+    tcAddSrcLoc src_loc			(
     let
 	clas = lookupCE ce class_name -- Renamer ensures this can't fail
 
@@ -1095,11 +747,11 @@ tcSpecInstSig e ce tce inst_infos inst_mapper (InstSpecSig class_name ty src_loc
     babyTcMtoTcM (tcInstanceType ce tce tmpl_e True src_loc ty)
 				`thenTc` \ inst_ty ->
     let
-	maybe_tycon = case getUniDataTyCon_maybe inst_ty of 
-		         Just (tc,_,_) -> Just tc
-		         Nothing       -> Nothing
+	maybe_tycon = case maybeDataTyCon inst_ty of
+			 Just (tc,_,_) -> Just tc
+			 Nothing       -> Nothing
 
-	maybe_unspec_inst = lookup_unspec_inst clas maybe_tycon inst_infos 
+	maybe_unspec_inst = lookup_unspec_inst clas maybe_tycon inst_infos
     in
 	-- Check that we have a local instance declaration to specialise
     checkMaybeTc maybe_unspec_inst
@@ -1109,17 +761,17 @@ tcSpecInstSig e ce tce inst_infos inst_mapper (InstSpecSig 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 True{-from here-} mod _ uprag) = maybe_unspec_inst
 
     	subst = case matchTy unspec_inst_ty inst_ty of
 		     Just subst -> subst
 		     Nothing    -> panic "tcSpecInstSig:matchTy"
 
 	subst_theta    = instantiateThetaTy subst unspec_theta
-        subst_tv_theta = instantiateThetaTy tv_e subst_theta
+	subst_tv_theta = instantiateThetaTy tv_e subst_theta
 
 	mk_spec_origin clas ty
-          = InstanceSpecOrigin inst_mapper clas ty src_loc
+	  = InstanceSpecOrigin inst_mapper clas ty src_loc
     in
     tcSimplifyThetas mk_spec_origin subst_tv_theta
 				`thenTc` \ simpl_tv_theta ->
@@ -1139,17 +791,17 @@ tcSpecInstSig e ce tce inst_infos inst_mapper (InstSpecSig class_name ty src_loc
 	(ppAboves [ppCat [if null simpl_theta then ppNil else ppr PprDebug simpl_theta,
 			  if null simpl_theta then ppNil else ppStr "=>",
 			  ppr PprDebug clas,
-			  pprParendUniType PprDebug inst_ty],
+			  pprParendType PprDebug inst_ty],
 		   ppCat [ppStr "        derived from:",
 			  if null unspec_theta then ppNil else ppr PprDebug unspec_theta,
 			  if null unspec_theta then ppNil else ppStr "=>",
 			  ppr PprDebug clas,
-			  pprParendUniType PprDebug unspec_inst_ty]])
+			  pprParendType PprDebug unspec_inst_ty]])
     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 const_meth_ids
+				binds True{-from here-} mod src_loc uprag))
     )))
 
 
@@ -1160,13 +812,13 @@ lookup_unspec_inst clas maybe_tycon inst_infos
   where
     match_info match_ty (InstInfo inst_clas _ inst_ty _ _ _ _ _ from_here _ _ _)
       = from_here && clas == inst_clas &&
-        match_ty inst_ty && is_plain_instance inst_ty
+	match_ty inst_ty && is_plain_instance inst_ty
 
     match_inst_ty = case maybe_tycon of
 		      Just tycon -> match_tycon tycon
 		      Nothing    -> match_fun
 
-    match_tycon tycon inst_ty = case (getUniDataTyCon_maybe inst_ty) of
+    match_tycon tycon inst_ty = case (maybeDataTyCon inst_ty) of
 	  Just (inst_tc,_,_) -> tycon == inst_tc
 	  Nothing            -> False
 
@@ -1174,9 +826,111 @@ lookup_unspec_inst clas maybe_tycon inst_infos
 
 
 is_plain_instance inst_ty
-  = case (getUniDataTyCon_maybe inst_ty) of
+  = case (maybeDataTyCon inst_ty) of
       Just (_,tys,_) -> all isTyVarTemplateTy tys
       Nothing	     -> case maybeUnpackFunTy inst_ty of
 			  Just (arg, res) -> isTyVarTemplateTy arg && isTyVarTemplateTy res
 			  Nothing	  -> error "TcInstDecls:is_plain_instance"
+-}
+\end{code}
+
+
+Checking for a decent instance type
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+@scrutiniseInstanceType@ checks the type {\em and} its syntactic constraints:
+it must normally look like: @instance Foo (Tycon a b c ...) ...@
+
+The exceptions to this syntactic checking: (1)~if the @GlasgowExts@
+flag is on, or (2)~the instance is imported (they must have been
+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
+	-- TYCON CHECK
+  | not (maybeToBool inst_tycon_maybe)
+  = failTc (instTypeErr inst_tau)
+
+  	-- IMPORTED INSTANCES ARE OK (but see tcInstDecl1)
+  | from_here
+  = returnTc (inst_tycon,arg_tys)
+
+	-- TYVARS CHECK
+  | not (all isTyVarTy arg_tys ||
+         not from_here	       ||
+	 opt_GlasgowExts)
+  = failTc (instTypeErr inst_tau)
+
+  	-- DERIVING CHECK
+	-- It is obviously illegal to have an explicit instance
+	-- for something that we are also planning to `derive'
+	-- Though we can have an explicit instance which is more
+	-- specific than the derived instance
+  | clas `derivedFor` inst_tycon
+    && all isTyVarTy arg_tys
+  = failTc (derivingWhenInstanceExistsErr clas inst_tycon)
+
+  |	-- CCALL CHECK
+	-- A user declaration of a _CCallable/_CReturnable instance
+	-- must be for a "boxed primitive" type.
+    isCcallishClass clas
+    && not opt_CompilingPrelude		-- which allows anything
+    && maybeToBool (maybeBoxedPrimType inst_tau)
+  = failTc (nonBoxedPrimCCallErr clas inst_tau)
+
+  | otherwise
+  = returnTc (inst_tycon,arg_tys)
+
+  where
+    (possible_tycon, arg_tys) = splitAppTy inst_tau
+    inst_tycon_maybe	      = getTyCon_maybe possible_tycon
+    inst_tycon 		      = expectJust "tcInstDecls1:inst_tycon" inst_tycon_maybe
+\end{code}
+
+\begin{code}
+
+instTypeErr ty sty
+  = case ty of
+      SynTy tc _ _ -> ppBesides [ppStr "The type synonym `", ppr sty tc, rest_of_msg]
+      TyVarTy tv   -> ppBesides [ppStr "The type variable `", ppr sty tv, rest_of_msg]
+      other	   -> ppBesides [ppStr "The type `", ppr sty ty, rest_of_msg]
+  where
+    rest_of_msg = ppStr "' cannot be used as an instance type."
+
+derivingWhenInstanceExistsErr clas tycon sty
+  = ppHang (ppBesides [ppStr "Deriving class `", ppr sty clas, ppStr "' type `", ppr sty tycon, ppStr "'"])
+         4 (ppStr "when an explicit instance exists")
+
+derivingWhenInstanceImportedErr inst_mod clas tycon sty
+  = ppHang (ppBesides [ppStr "Deriving class `", ppr sty clas, ppStr "' type `", ppr sty tycon, ppStr "'"])
+         4 (ppBesides [ppStr "when an instance declared in module `", ppPStr inst_mod, ppStr "' has been imported"])
+
+nonBoxedPrimCCallErr clas inst_ty sty
+  = ppHang (ppStr "Instance isn't for a `boxed-primitive' type")
+	 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, pprParendType sty inst_ty]
+
+
+patMonoBindsCtxt pbind sty
+  = ppHang (ppStr "In a pattern binding:")
+	 4 (ppr sty pbind)
+
+methodSigCtxt name ty sty
+  = ppHang (ppBesides [ppStr "When matching the definition of class method `",
+	               ppr sty name, ppStr "' to its signature :" ])
+	 4 (ppr sty ty)
+
+bindSigCtxt method_ids sty
+  = ppHang (ppStr "When checking type signatures for: ")
+	 4 (ppInterleave (ppStr ", ") (map (ppr sty) method_ids))
+
+superClassSigCtxt sty
+  = ppStr "When checking superclass constraints on instance declaration"
+
 \end{code}
diff --git a/ghc/compiler/typecheck/TcInstUtil.lhs b/ghc/compiler/typecheck/TcInstUtil.lhs
new file mode 100644
index 0000000000..4e6b72dc65
--- /dev/null
+++ b/ghc/compiler/typecheck/TcInstUtil.lhs
@@ -0,0 +1,294 @@
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+%
+\section[TcInstUtil]{Utilities for typechecking instance declarations}
+
+The bits common to TcInstDcls and TcDeriv.
+
+\begin{code}
+#include "HsVersions.h"
+
+module TcInstUtil (
+	InstInfo(..),
+	mkInstanceRelatedIds,
+	buildInstanceEnvs
+    ) where
+
+import Ubiq
+
+import HsSyn		( MonoBinds, Fake, InPat, Sig )
+import RnHsSyn		( RenamedMonoBinds(..), RenamedSig(..), 
+			  RenamedInstancePragmas(..) )
+
+import TcMonad
+import Inst		( InstanceMapper(..) )
+
+import Bag		( bagToList )
+import Class		( GenClass, GenClassOp, ClassInstEnv(..),
+			  getClassBigSig, getClassOps, getClassOpLocalType )
+import CoreSyn		( GenCoreExpr(..), mkValLam, mkTyApp )
+import Id		( GenId, mkDictFunId, mkConstMethodId, mkSysLocal )
+import MatchEnv		( nullMEnv, insertMEnv )
+import Maybes		( MaybeErr(..), mkLookupFunDef )
+import PprType		( GenClass, GenType, GenTyVar )
+import Pretty
+import SpecEnv		( SpecEnv(..), nullSpecEnv, addOneToSpecEnv )
+import SrcLoc		( SrcLoc )
+import Type		( mkSigmaTy, mkForAllTys, mkDictTy, mkTyVarTy,
+			  splitForAllTy, instantiateTy, matchTy, ThetaType(..) )
+import TyVar		( GenTyVar )
+import Unique		( Unique )
+import Util		( equivClasses, zipWithEqual, panic )
+
+
+import IdInfo		( noIdInfo )
+--import TcPragmas	( tcDictFunPragmas, tcGenPragmas )
+\end{code}
+
+    instance c => k (t tvs) where b
+
+\begin{code}
+data InstInfo
+  = InstInfo
+      Class	        -- Class, k
+      [TyVar]		-- Type variables, tvs
+      Type		-- The type at which the class is being instantiated
+      ThetaType		-- inst_decl_theta: the original context, c, from the
+			--   instance declaration.  It constrains (some of)
+			--   the TyVars above
+      ThetaType		-- dfun_theta: the inst_decl_theta, plus one
+			--   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
+      FAST_STRING	-- Name of module where this instance was
+			-- defined.
+      SrcLoc		-- Source location assoc'd with this instance's defn
+      [RenamedSig]	-- User pragmas recorded for generating specialised instances
+\end{code}
+
+%************************************************************************
+%*									*
+\subsection{Creating instance related Ids}
+%*									*
+%************************************************************************
+
+\begin{code}
+mkInstanceRelatedIds :: Bool -> FAST_STRING
+                     -> RenamedInstancePragmas
+		     -> Class 
+		     -> [TyVar]
+		     -> Type
+		     -> ThetaType
+		     -> [RenamedSig]
+		     -> TcM s (Id, ThetaType, [Id])
+
+mkInstanceRelatedIds from_here inst_mod inst_pragmas
+		     clas inst_tyvars inst_ty inst_decl_theta uprags
+  = 	-- MAKE THE DFUN ID
+    let
+	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.
+
+			other -> inst_decl_theta ++ super_class_theta
+					-- 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 inst_mod dfun_id_info)
+    ) `thenTc` \ dfun_id ->
+
+	-- MAKE THE CONSTANT-METHOD IDS
+	-- if there are no type variables involved
+    (if not (null inst_decl_theta)
+     then
+	returnTc []
+     else
+	mapTc mk_const_meth_id class_ops
+    )					`thenTc` \ const_meth_ids ->
+
+    returnTc (dfun_id, dfun_theta, const_meth_ids)
+  where
+    (class_tyvar, super_classes, _, class_ops, _, _) = getClassBigSig clas
+    tenv = [(class_tyvar, inst_ty)]
+  
+    super_class_theta = super_classes `zip` (repeat 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 inst_mod id_info)
+	  )
+	where
+	  op_ty       = getClassOpLocalType 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]
+-}
+\end{code}
+
+
+%************************************************************************
+%*									*
+\subsection{Converting instance info into suitable InstEnvs}
+%*									*
+%************************************************************************
+
+\begin{code}
+buildInstanceEnvs :: Bag InstInfo
+		  -> TcM s InstanceMapper
+
+buildInstanceEnvs info
+  = let
+    	icmp :: InstInfo -> InstInfo -> TAG_
+    	(InstInfo c1 _ _ _ _ _ _ _ _ _ _ _) `icmp` (InstInfo c2 _ _ _ _ _ _ _ _ _ _ _)
+	  = c1 `cmp` c2
+
+	info_by_class = equivClasses icmp (bagToList info)
+    in
+    mapTc buildInstanceEnv info_by_class    `thenTc` \ inst_env_entries ->
+    let
+	class_lookup_fn = mkLookupFunDef (==) inst_env_entries 
+					 (nullMEnv, \ o -> nullSpecEnv)
+    in
+    returnTc class_lookup_fn
+\end{code}
+
+\begin{code}
+buildInstanceEnv :: [InstInfo]		-- Non-empty, and all for same class
+		 -> TcM s (Class, (ClassInstEnv, (ClassOp -> SpecEnv)))
+
+buildInstanceEnv inst_infos@((InstInfo clas _ _ _ _ _ _ _ _ _ _ _) : _)
+  = foldlTc addClassInstance
+	    (nullMEnv, [(op, nullSpecEnv) | op <- getClassOps clas])
+	    inst_infos
+					`thenTc` \ (class_inst_env, op_inst_envs) ->
+    returnTc (clas, (class_inst_env,
+		     mkLookupFunDef (==) op_inst_envs
+				    (panic "buildInstanceEnv")))
+\end{code}
+
+@addClassInstance@ adds the appropriate stuff to the @ClassInstEnv@
+based on information from a single instance declaration.  It complains
+about any overlap with an existing instance.
+
+\begin{code}
+addClassInstance
+    :: (ClassInstEnv, [(ClassOp,SpecEnv)])
+    -> InstInfo
+    -> TcM s (ClassInstEnv, [(ClassOp,SpecEnv)])
+
+addClassInstance
+    (class_inst_env, op_spec_envs)
+    (InstInfo clas inst_tyvars inst_ty inst_decl_theta dfun_theta
+	      dfun_id const_meth_ids _ _ _ src_loc _)
+  = 
+
+-- We only add specialised/overlapped instances
+-- if we are specialising the overloading
+-- ToDo ... This causes getConstMethodId errors!
+--
+--    if not (is_plain_instance inst_ty) && not opt_SpecialiseOverloaded
+--    then
+--	-- Drop this specialised/overlapped instance
+--	returnTc (class_inst_env, op_spec_envs)
+--    else	
+
+	-- Add the instance to the class's instance environment
+    case insertMEnv matchTy class_inst_env inst_ty dfun_id of {
+	Failed (ty', dfun_id')    -> failTc (dupInstErr clas (inst_ty, src_loc) 
+							     (ty', getSrcLoc dfun_id'));
+	Succeeded class_inst_env' -> 
+
+	-- If there are any constant methods, then add them to 
+	-- the SpecEnv of each class op (ie selector)
+	--
+	-- Example.  class    Foo a     where { op :: Baz b => a -> b }
+	--	     instance Foo (p,q) where { op (x,y) = ... }
+	--
+	-- The constant method from the instance decl will be:
+	--	op_Pair :: forall p q b. Baz b => (p,q) -> b
+	--
+	-- What we put in op's SpecEnv is
+	--	(p,q) b	 |-->  (\d::Foo (p,q) -> op_Pair p q b)
+	--
+	-- Here, [p,q] are the inst_tyvars, and d is a dict whose only
+	-- purpose is to cancel with the dict to which op is applied.
+	-- 
+	-- NOTE THAT this correctly deals with the case where there are
+	-- constant methods even though there are type variables in the
+	-- instance declaration.
+
+    tcGetUnique				`thenNF_Tc` \ uniq ->
+    let 
+      dict = mkSysLocal SLIT("dict_tpl") uniq (mkDictTy clas inst_ty) src_loc
+		-- Slightly disgusting, but it's only a placeholder for
+		-- a dictionary to be chucked away.
+
+      op_spec_envs' | null const_meth_ids = op_spec_envs
+		    | otherwise		  = zipWithEqual add_const_meth op_spec_envs const_meth_ids
+
+      add_const_meth (op,spec_env) meth_id
+        = (op, case addOneToSpecEnv spec_env (inst_ty : local_tyvar_tys) rhs of
+		 Failed (tys', rhs') -> panic "TcInstDecls:add_const_meth"
+	         Succeeded spec_env' -> spec_env' )
+        where
+	  (local_tyvars, _) = splitForAllTy (getClassOpLocalType op)
+	  local_tyvar_tys   = map mkTyVarTy local_tyvars
+	  rhs = mkValLam [dict] (mkTyApp (mkTyApp (Var meth_id) 
+						  (map mkTyVarTy inst_tyvars)) 
+				         local_tyvar_tys)
+    in
+    returnTc (class_inst_env', op_spec_envs')
+    }
+\end{code}
+
+\begin{code}
+dupInstErr clas info1@(ty1, locn1) info2@(ty2, locn2) sty
+	-- Overlapping/duplicate instances for given class; msg could be more glamourous
+  = ppHang (ppBesides [ppStr "Duplicate/overlapping instances: class `", ppr sty clas, ppStr "'"])
+	 4 (showOverlap sty info1 info2)
+
+showOverlap sty (ty1,loc1) (ty2,loc2)
+  = ppSep [ppBesides [ppStr "type `", ppr sty ty1, ppStr "'"],
+	   ppBesides [ppStr "at ", ppr sty loc1],
+	   ppBesides [ppStr "and ", ppr sty loc2]]
+\end{code}
diff --git a/ghc/compiler/typecheck/TcKind.lhs b/ghc/compiler/typecheck/TcKind.lhs
new file mode 100644
index 0000000000..a23362306d
--- /dev/null
+++ b/ghc/compiler/typecheck/TcKind.lhs
@@ -0,0 +1,205 @@
+\begin{code}
+module TcKind (
+
+	Kind, mkTypeKind, mkBoxedTypeKind, mkUnboxedTypeKind, mkArrowKind, 
+	isSubKindOf,	-- Kind -> Kind -> Bool
+	resultKind,	-- Kind -> Kind
+
+	TcKind, mkTcTypeKind, mkTcArrowKind, mkTcVarKind,
+	newKindVar,	-- NF_TcM s (TcKind s)
+	newKindVars,	-- Int -> NF_TcM s [TcKind s]
+	unifyKind, 	-- TcKind s -> TcKind s -> TcM s ()
+
+	kindToTcKind,	-- Kind     -> TcKind s
+	tcKindToKind	-- TcKind s -> NF_TcM s Kind
+  ) where
+
+import Kind
+import TcMonad
+
+import Ubiq
+import Unique	( Unique, pprUnique10 )
+import Pretty
+\end{code}
+
+
+\begin{code}
+data TcKind s		-- Used for kind inference
+  = TcTypeKind
+  | TcArrowKind (TcKind s) (TcKind s)
+  | TcVarKind Unique (MutableVar s (Maybe (TcKind s)))
+
+mkTcTypeKind  = TcTypeKind
+mkTcArrowKind = TcArrowKind
+mkTcVarKind   = TcVarKind
+
+newKindVar :: NF_TcM s (TcKind s)
+newKindVar = tcGetUnique		`thenNF_Tc` \ uniq ->
+	     tcNewMutVar Nothing	`thenNF_Tc` \ box ->
+	     returnNF_Tc (TcVarKind uniq box)
+
+newKindVars :: Int -> NF_TcM s [TcKind s]
+newKindVars n = mapNF_Tc (\_->newKindVar) (take n (repeat ()))
+\end{code}
+
+
+Kind unification
+~~~~~~~~~~~~~~~~
+\begin{code}
+unifyKind :: TcKind s -> TcKind s -> TcM s ()
+unifyKind kind1 kind2
+  = tcAddErrCtxtM ctxt (unify_kind kind1 kind2)
+  where
+    ctxt = zonkTcKind kind1	`thenNF_Tc` \ kind1' ->
+	   zonkTcKind kind2	`thenNF_Tc` \ kind2' ->
+	   returnNF_Tc (unifyKindCtxt kind1' kind2')
+		 
+
+unify_kind TcTypeKind TcTypeKind = returnTc ()
+
+unify_kind (TcArrowKind fun1 arg1)
+	   (TcArrowKind fun2 arg2)
+
+  = unify_kind fun1 fun2	`thenTc_`
+    unify_kind arg1 arg2
+
+unify_kind (TcVarKind uniq box) kind = unify_var uniq box kind
+unify_kind kind (TcVarKind uniq box) = unify_var uniq box kind
+
+unify_kind kind1 kind2
+  = failTc (kindMisMatchErr kind1 kind2)
+\end{code}
+
+We could probably do some "shorting out" in unifyVarKind, but
+I'm not convinced it would save time, and it's a little tricky to get right.
+
+\begin{code}
+unify_var uniq1 box1 kind2
+  = tcReadMutVar box1	`thenNF_Tc` \ maybe_kind1 ->
+    case maybe_kind1 of
+      Just kind1 -> unify_kind kind1 kind1
+      Nothing    -> unify_unbound_var uniq1 box1 kind2
+
+unify_unbound_var uniq1 box1 kind2@(TcVarKind uniq2 box2)
+  | uniq1 == uniq2	-- Binding to self is a no-op
+  = returnTc ()
+
+  | otherwise		-- Distinct variables
+  = tcReadMutVar box2	`thenNF_Tc` \ maybe_kind2 ->
+    case maybe_kind2 of
+	Just kind2' -> unify_unbound_var uniq1 box1 kind2'
+	Nothing     -> tcWriteMutVar box1 (Just kind2)	`thenNF_Tc_`	
+				-- No need for occurs check here
+		       returnTc ()
+
+unify_unbound_var uniq1 box1 non_var_kind2
+  = occur_check non_var_kind2			`thenTc_`
+    tcWriteMutVar box1 (Just non_var_kind2)	`thenNF_Tc_`
+    returnTc ()
+  where
+    occur_check TcTypeKind  	      = returnTc ()
+    occur_check (TcArrowKind fun arg) = occur_check fun `thenTc_` occur_check arg
+    occur_check kind1@(TcVarKind uniq' box)
+	| uniq1 == uniq'
+	= failTc (kindOccurCheck kind1 non_var_kind2)
+
+	| otherwise	-- Different variable
+	=  tcReadMutVar box		`thenNF_Tc` \ maybe_kind ->
+	   case maybe_kind of
+		Nothing   -> returnTc ()
+		Just kind -> occur_check kind
+\end{code}
+
+The "occurs check" is necessary to catch situation like
+
+	type T k = k k
+
+
+Kind flattening
+~~~~~~~~~~~~~~~
+Coercions between TcKind and Kind
+
+\begin{code}
+kindToTcKind :: Kind -> TcKind s
+kindToTcKind TypeKind          = TcTypeKind
+kindToTcKind BoxedTypeKind     = TcTypeKind
+kindToTcKind UnboxedTypeKind   = TcTypeKind
+kindToTcKind (ArrowKind k1 k2) = TcArrowKind (kindToTcKind k1) (kindToTcKind k2)
+
+
+tcKindToKind :: TcKind s -> NF_TcM s Kind
+
+tcKindToKind TcTypeKind
+  = returnNF_Tc TypeKind
+
+tcKindToKind (TcArrowKind kind1 kind2)
+  = tcKindToKind kind1	`thenNF_Tc` \ k1 ->
+    tcKindToKind kind2	`thenNF_Tc` \ k2 ->
+    returnNF_Tc (ArrowKind k1 k2)
+
+	-- Here's where we "default" unbound kinds to BoxedTypeKind
+tcKindToKind (TcVarKind uniq box)
+  = tcReadMutVar box	`thenNF_Tc` \ maybe_kind ->
+    case maybe_kind of
+	Nothing   -> returnNF_Tc BoxedTypeKind	-- Default is kind Type for unbound
+	Just kind -> tcKindToKind kind
+
+zonkTcKind :: TcKind s -> NF_TcM s (TcKind s)
+-- Removes variables that have now been bound.
+-- Mainly used just before an error message is printed,
+-- so that we don't need to follow through bound variables 
+-- during error message construction.
+
+zonkTcKind TcTypeKind = returnNF_Tc TcTypeKind
+
+zonkTcKind (TcArrowKind kind1 kind2)
+  = zonkTcKind kind1	`thenNF_Tc` \ k1 ->
+    zonkTcKind kind2	`thenNF_Tc` \ k2 ->
+    returnNF_Tc (TcArrowKind k1 k2)
+
+zonkTcKind kind@(TcVarKind uniq box)
+  = tcReadMutVar box	`thenNF_Tc` \ maybe_kind ->
+    case maybe_kind of
+	Nothing    -> returnNF_Tc kind
+	Just kind' -> zonkTcKind kind'
+\end{code}
+
+
+\begin{code}
+instance Outputable (TcKind s) where
+  ppr sty kind = ppr_kind sty kind
+
+ppr_kind sty TcTypeKind 
+  = ppStr "*"
+ppr_kind sty (TcArrowKind kind1 kind2) 
+  = ppSep [ppr_parend sty kind1, ppStr "->", ppr_kind sty kind2]
+ppr_kind sty (TcVarKind uniq box) 
+  = ppBesides [ppStr "k", pprUnique10 uniq]
+
+ppr_parend sty kind@(TcArrowKind _ _) = ppBesides [ppChar '(', ppr_kind sty kind, ppChar ')']
+ppr_parend sty other_kind	      = ppr_kind sty other_kind
+\end{code}
+
+
+
+Errors and contexts
+~~~~~~~~~~~~~~~~~~~
+\begin{code}
+unifyKindCtxt kind1 kind2 sty
+  = ppHang (ppStr "When unifying two kinds") 4
+	   (ppSep [ppr sty kind1, ppStr "and", ppr sty kind2])
+
+kindOccurCheck kind1 kind2 sty
+  = ppHang (ppStr "Cannot construct the infinite kind:") 4
+	(ppSep [ppBesides [ppStr "`", ppr sty kind1, ppStr "'"],
+		ppStr "=",
+		ppBesides [ppStr "`", ppr sty kind1, ppStr "'"],
+		ppStr "(\"occurs check\")"])
+
+kindMisMatchErr kind1 kind2 sty
+ = ppHang (ppStr "Couldn't match the kind") 4
+	(ppSep [ppBesides [ppStr "`", ppr sty kind1, ppStr "'"],
+		ppStr "against",
+		ppBesides [ppStr "`", ppr sty kind1, ppStr "'"]
+	])
+\end{code}
diff --git a/ghc/compiler/typecheck/TcLoop.lhi b/ghc/compiler/typecheck/TcLoop.lhi
new file mode 100644
index 0000000000..3eb8d36614
--- /dev/null
+++ b/ghc/compiler/typecheck/TcLoop.lhi
@@ -0,0 +1,38 @@
+This module breaks the loops among the typechecker modules
+TcExpr, TcBinds, TcMonoBnds, TcQuals, TcGRHSs, TcMatches.
+
+\begin{code}
+interface TcLoop where
+
+import TcGRHSs( tcGRHSsAndBinds )
+import HsMatches(GRHSsAndBinds)
+import HsPat(InPat, OutPat)
+import HsSyn(Fake)
+import TcHsSyn(TcIdOcc)
+import Name(Name)
+import TcType(TcMaybe)
+import SST(FSST_R)
+import Unique(Unique)
+import TyVar(GenTyVar)
+import TcEnv(TcEnv)
+import TcMonad(TcDown)
+import PreludeGlaST(_MutableArray)
+import Bag(Bag)
+import Type(GenType)
+import Inst(Inst)
+
+tcGRHSsAndBinds :: GRHSsAndBinds Fake Fake Name (InPat Name) 
+	        -> TcDown a 
+		-> TcEnv a 
+		-> State# a 
+		-> FSST_R a (GRHSsAndBinds (GenTyVar (_MutableArray a Int (TcMaybe a))) 
+					   Unique 
+					   (TcIdOcc a)
+					   (OutPat (GenTyVar (_MutableArray a Int (TcMaybe a))) 
+						   Unique 
+						   (TcIdOcc a)),
+			     Bag (Inst a),
+			     GenType (GenTyVar (_MutableArray a Int (TcMaybe a))) Unique
+			    )
+			    ()
+\end{code}
diff --git a/ghc/compiler/typecheck/TcLoop.lhs b/ghc/compiler/typecheck/TcLoop.lhs
new file mode 100644
index 0000000000..39cf96c150
--- /dev/null
+++ b/ghc/compiler/typecheck/TcLoop.lhs
@@ -0,0 +1,7 @@
+This module breaks the loops among the typechecker modules
+TcExpr, TcBinds, TcMonoBnds, TcQuals, TcGRHSs, TcMatches.
+
+\begin{code}
+module TcLoop( tcGRHSsAndBinds )
+import TcGRHSs( tcGRHSsAndBinds )
+\end{code}
diff --git a/ghc/compiler/typecheck/TcMLoop.lhi b/ghc/compiler/typecheck/TcMLoop.lhi
new file mode 100644
index 0000000000..14a6ede64d
--- /dev/null
+++ b/ghc/compiler/typecheck/TcMLoop.lhi
@@ -0,0 +1,13 @@
+\begin{code}
+interface TcMLoop where
+
+import PreludeGlaST(_MutableArray)
+import TcEnv(TcEnv,initEnv)
+import TcType(TcMaybe)
+import TyVar(GenTyVar)
+import UniqFM(UniqFM)
+
+data TcEnv a
+data TcMaybe a
+initEnv :: _MutableArray a Int (UniqFM (GenTyVar (_MutableArray a Int (TcMaybe a)))) -> TcEnv a
+\end{code}
diff --git a/ghc/compiler/typecheck/TcMatches.hi b/ghc/compiler/typecheck/TcMatches.hi
deleted file mode 100644
index 045238cfa8..0000000000
--- a/ghc/compiler/typecheck/TcMatches.hi
+++ /dev/null
@@ -1,20 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface TcMatches where
-import Bag(Bag)
-import CmdLineOpts(GlobalSwitch)
-import E(E)
-import HsMatches(Match)
-import HsPat(InPat, TypecheckedPat)
-import Id(Id)
-import LIE(LIE)
-import Name(Name)
-import Pretty(PprStyle, PrettyRep)
-import SplitUniq(SplitUniqSupply)
-import SrcLoc(SrcLoc)
-import Subst(Subst)
-import TcMonad(TcResult)
-import UniType(UniType)
-tcMatch :: E -> Match Name (InPat Name) -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult (Match Id TypecheckedPat, LIE, UniType)
-tcMatchesCase :: E -> [Match Name (InPat Name)] -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult ([Match Id TypecheckedPat], LIE, UniType)
-tcMatchesFun :: E -> Name -> UniType -> [Match Name (InPat Name)] -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult ([Match Id TypecheckedPat], LIE)
-
diff --git a/ghc/compiler/typecheck/TcMatches.lhs b/ghc/compiler/typecheck/TcMatches.lhs
index b7037aadbe..31a31501a0 100644
--- a/ghc/compiler/typecheck/TcMatches.lhs
+++ b/ghc/compiler/typecheck/TcMatches.lhs
@@ -8,23 +8,26 @@
 
 module TcMatches ( tcMatchesFun, tcMatchesCase, tcMatch ) where
 
-import TcMonad		-- typechecking monad machinery
-import TcMonadFns	( mkIdsWithOpenTyVarTys )
-import AbsSyn		-- the stuff being typechecked
-
-import AbsPrel		( mkFunTy )
-import AbsUniType	( isTyVarTy, maybeUnpackFunTy )
-import E		( E, growE_LVE, LVE(..), GVE(..) )
-#if USE_ATTACK_PRAGMAS
-import CE
-import TCE
-#endif
-import Errors		( varyingArgsErr, Error(..), UnifyErrContext(..) )
-import LIE		( LIE, plusLIE )
-import Maybes		( Maybe(..) )
-import TcGRHSs		( tcGRHSsAndBinds )
+import Ubiq
+
+import HsSyn		( Match(..), GRHSsAndBinds(..), GRHS(..), InPat,
+			  HsExpr, HsBinds, OutPat, Fake,
+			  collectPatBinders, pprMatch )
+import RnHsSyn		( RenamedMatch(..) )
+import TcHsSyn		( TcIdOcc(..), TcMatch(..) )
+
+import TcMonad
+import Inst		( Inst, LIE(..), plusLIE )
+import TcEnv		( newMonoIds )
+import TcLoop		( tcGRHSsAndBinds )
 import TcPat		( tcPat )
+import TcType		( TcType(..), TcMaybe, zonkTcType )
 import Unify		( unifyTauTy, unifyTauTyList )
+
+import Kind		( Kind, mkTypeKind )
+import Name		( Name )
+import Pretty
+import Type		( isTyVarTy, mkFunTy, getFunTy_maybe )
 import Util
 \end{code}
 
@@ -34,22 +37,22 @@ 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 :: E -> Name 
-	     -> UniType 		-- Expected type
+tcMatchesFun :: Name
+	     -> TcType s 		-- Expected type
 	     -> [RenamedMatch]
-	     -> TcM ([TypecheckedMatch], LIE)
+	     -> TcM s ([TcMatch s], LIE s)
 
-tcMatchesFun e fun_name expected_ty matches@(first_match:_)
+tcMatchesFun fun_name expected_ty matches@(first_match:_)
   =	 -- Set the location to that of the first equation, so that
 	 -- any inter-equation error messages get some vaguely
 	 -- sensible location.	Note: we have to do this odd
 	 -- ann-grabbing, because we don't always have annotations in
 	 -- hand when we call tcMatchesFun...
 
-    addSrcLocTc (get_Match_loc first_match)	 (
+    tcAddSrcLoc (get_Match_loc first_match)	 (
 
 	 -- Check that they all have the same no of arguments
-    checkTc (not (all_same (noOfArgs matches)))
+    checkTc (all_same (noOfArgs matches))
 	    (varyingArgsErr fun_name matches) `thenTc_`
 
 	-- ToDo: Don't use "expected" stuff if there ain't a type signature
@@ -57,8 +60,8 @@ tcMatchesFun e fun_name expected_ty matches@(first_match:_)
 	-- may show up as something wrong with the (non-existent) type signature
 
 	-- We need to substitute so that we can see as much about the type as possible
-    applyTcSubstToTy expected_ty	`thenNF_Tc` \ expected_ty' ->
-    tcMatchesExpected e expected_ty' (\ m -> FunMonoBindsCtxt fun_name [m]) matches
+    zonkTcType expected_ty		`thenNF_Tc` \ expected_ty' ->
+    tcMatchesExpected expected_ty' (MFun fun_name) matches
 
     )
   where
@@ -72,120 +75,98 @@ tcMatchesFun e fun_name expected_ty matches@(first_match:_)
 parser guarantees that each equation has exactly one argument.
 
 \begin{code}
-tcMatchesCase :: E -> [RenamedMatch]
-	      -> TcM ([TypecheckedMatch], LIE, UniType)
-
-tcMatchesCase e matches
-  =
-
-	 -- Typecheck them
-    tcMatches e matches			`thenTc` \ (matches', lie, tys@(first_ty:_)) ->
-
-	-- Set the location to that of the first equation, so that
-	-- any inter-equation error messages get some vaguely sensible location
-    addSrcLocTc (get_Match_loc (head matches)) (
-	    unifyTauTyList tys (CaseBranchesCtxt matches)
-    )					 `thenTc_`
-
-    returnTc (matches', lie, first_ty)
+tcMatchesCase :: TcType s -> [RenamedMatch] -> TcM s ([TcMatch s], LIE s)
+tcMatchesCase expected_ty matches = tcMatchesExpected expected_ty MCase matches
 \end{code}
 
 
 \begin{code}
-tcMatchesExpected :: E 
-		  -> UniType 
-		  -> (RenamedMatch -> UnifyErrContext)
-		  -> [RenamedMatch] 
-		  -> TcM ([TypecheckedMatch], LIE)
-
-tcMatchesExpected e expected_ty err_ctxt_fn [match]
-  = addSrcLocTc (get_Match_loc match) (
-  	tcMatchExpected e expected_ty (err_ctxt_fn match) match
-    )						`thenTc` \ (match',  lie) ->
+data FunOrCase = MCase | MFun Name	-- Records whether doing  fun or case rhss;
+					-- used to produced better error messages
+
+tcMatchesExpected :: TcType s
+		  -> FunOrCase
+		  -> [RenamedMatch]
+		  -> TcM s ([TcMatch s], LIE s)
+
+tcMatchesExpected expected_ty fun_or_case [match]
+  = tcAddSrcLoc (get_Match_loc match)		$
+    tcAddErrCtxt (matchCtxt fun_or_case match)	$
+    tcMatchExpected expected_ty match	`thenTc` \ (match',  lie) ->
     returnTc ([match'], lie)
 
-tcMatchesExpected e expected_ty err_ctxt_fn ms@(match1 : matches)
-  = addSrcLocTc (get_Match_loc match1) (
-  	tcMatchExpected e expected_ty (err_ctxt_fn match1) match1
+tcMatchesExpected expected_ty fun_or_case (match1 : matches)
+  = tcAddSrcLoc (get_Match_loc match1)	(
+	tcAddErrCtxt (matchCtxt fun_or_case match1)	$
+  	tcMatchExpected expected_ty  match1
     )						    	`thenTc` \ (match1',  lie1) ->
-    tcMatchesExpected e expected_ty err_ctxt_fn matches	`thenTc` \ (matches', lie2) ->
+    tcMatchesExpected expected_ty fun_or_case matches	`thenTc` \ (matches', lie2) ->
     returnTc (match1' : matches', plusLIE lie1 lie2)
 
-tcMatches :: E -> [RenamedMatch] -> TcM ([TypecheckedMatch], LIE, [UniType])
+tcMatches :: [RenamedMatch] -> TcM s ([TcMatch s], LIE s, [TcType s])
 
-tcMatches e [match]
-  = tcMatch e match		`thenTc` \ (match', lie, ty) ->
+tcMatches [match]
+  = tcAddSrcLoc (get_Match_loc match) $
+    tcMatch match		`thenTc` \ (match', lie, ty) ->
     returnTc ([match'], lie, [ty])
 
-tcMatches e ms@(match1 : matches)
-  = addSrcLocTc (get_Match_loc match1) (
-	tcMatch e match1
+tcMatches (match1 : matches)
+  = tcAddSrcLoc (get_Match_loc match1) (
+	tcMatch match1
     )				`thenTc` \ (match1',  lie1, match1_ty) ->
-    tcMatches e matches		`thenTc` \ (matches', lie2, matches_ty) ->
+    tcMatches matches		`thenTc` \ (matches', lie2, matches_ty) ->
     returnTc (match1' : matches', plusLIE lie1 lie2, match1_ty : matches_ty)
 \end{code}
 
 \begin{code}
-tcMatchExpected 
-	:: E 
-	-> UniType 		-- This gives the expected
+tcMatchExpected
+	:: TcType s 		-- This gives the expected
 				-- result-type of the Match.  Early unification
 				-- with this guy gives better error messages
-	-> UnifyErrContext 
-	-> RenamedMatch 	
-	-> TcM (TypecheckedMatch,LIE)
-				-- NB No type returned, because it was passed
-				-- in instead!
+	-> RenamedMatch
+	-> TcM s (TcMatch s,LIE s)	-- NB No type returned, because it was passed
+					-- in instead!
 
-tcMatchExpected e expected_ty err_ctxt the_match@(PatMatch pat match)
-  = case maybeUnpackFunTy expected_ty of
+tcMatchExpected expected_ty the_match@(PatMatch pat match)
+  = case getFunTy_maybe expected_ty of
 
 	Nothing ->			-- Not a function type (eg type variable)
 					-- So use tcMatch instead
-	    tcMatch e the_match				`thenTc`   \ (match', lie_match, match_ty) ->
-	    unifyTauTy match_ty expected_ty err_ctxt	`thenTc_`
+	    tcMatch the_match			`thenTc`   \ (match', lie_match, match_ty) ->
+	    unifyTauTy match_ty expected_ty 	`thenTc_`
 	    returnTc (match', lie_match)
 
 	Just (arg_ty,rest_ty) ->	-- It's a function type!
 	    let binders = collectPatBinders pat
 	    in
-	    mkIdsWithOpenTyVarTys binders    `thenNF_Tc` \ lve ->
-	    let e' = growE_LVE e lve
-	    in
-	    tcPat e' pat		`thenTc`   \ (pat',   lie_pat,   pat_ty) ->
-
-    	    unifyTauTy arg_ty pat_ty err_ctxt	      `thenTc_`
-	    tcMatchExpected e' rest_ty err_ctxt match `thenTc` \ (match', lie_match) ->
-	    returnTc (PatMatch pat' match',
+	    newMonoIds binders mkTypeKind (\ _ ->
+		tcPat pat			`thenTc` \ (pat', lie_pat, pat_ty) ->
+		unifyTauTy arg_ty pat_ty	`thenTc_`
+		tcMatchExpected rest_ty  match	`thenTc` \ (match', lie_match) ->
+		returnTc (PatMatch pat' match',
 			  plusLIE lie_pat lie_match)
+	    )
 
-tcMatchExpected e expected_ty err_ctxt (GRHSMatch grhss_and_binds)
-  = tcGRHSsAndBinds e grhss_and_binds   	`thenTc` \ (grhss_and_binds', lie, grhss_ty) ->
-    unifyTauTy grhss_ty expected_ty err_ctxt	`thenTc_`
+tcMatchExpected expected_ty (GRHSMatch grhss_and_binds)
+  = tcGRHSsAndBinds grhss_and_binds   	`thenTc` \ (grhss_and_binds', lie, grhss_ty) ->
+    unifyTauTy grhss_ty expected_ty 	`thenTc_`
     returnTc (GRHSMatch grhss_and_binds', lie)
 
-tcMatch	:: E 
-	-> RenamedMatch 	
-	-> TcM (TypecheckedMatch,LIE,UniType)
+tcMatch	:: RenamedMatch -> TcM s (TcMatch s, LIE s, TcType s)
 
-tcMatch e (PatMatch pat match)
+tcMatch (PatMatch pat match)
   = let binders = collectPatBinders pat
     in
-    mkIdsWithOpenTyVarTys binders    `thenNF_Tc` \ lve ->
-    let e' = growE_LVE e lve
-    in
-    tcPat e' pat		`thenTc`   \ (pat',   lie_pat,   pat_ty) ->
-    tcMatch e' match		`thenTc`   \ (match', lie_match, match_ty) ->
-
---    We don't do this any more, do we?
---    applyTcSubstToTy pat_ty	`thenNF_Tc`\ pat_ty' ->
-
-    returnTc (PatMatch pat' match',
-	      plusLIE lie_pat lie_match,
-	      mkFunTy pat_ty match_ty)
+    newMonoIds binders mkTypeKind (\ _ -> 
+	tcPat pat		`thenTc`   \ (pat',   lie_pat,   pat_ty) ->
+	tcMatch match		`thenTc`   \ (match', lie_match, match_ty) ->
+	returnTc (PatMatch pat' match',
+		  plusLIE lie_pat lie_match,
+		  mkFunTy pat_ty match_ty)
+    )
 
-tcMatch e (GRHSMatch grhss_and_binds)
-  = tcGRHSsAndBinds e grhss_and_binds   `thenTc` \ (grhss_and_binds', lie, grhss_ty) ->
+tcMatch (GRHSMatch grhss_and_binds)
+  = tcGRHSsAndBinds grhss_and_binds   `thenTc` \ (grhss_and_binds', lie, grhss_ty) ->
     returnTc (GRHSMatch grhss_and_binds', lie, grhss_ty)
 \end{code}
 
@@ -219,3 +200,21 @@ get_Match_loc (GRHSMatch (GRHSsAndBindsIn (g:_) _))
 	get_GRHS_loc (OtherwiseGRHS _ locn) = locn
 	get_GRHS_loc (GRHS _ _ locn)	    = locn
 \end{code}
+
+Errors and contexts
+~~~~~~~~~~~~~~~~~~~
+\begin{code}
+matchCtxt MCase match sty
+  = ppHang (ppStr "In a \"case\" branch:")
+	 4 (pprMatch sty True{-is_case-} match)
+
+matchCtxt (MFun fun) match sty
+  = ppHang (ppBesides [ppStr "In an equation for function ", ppr sty fun, ppChar ':'])
+	 4 (ppBesides [ppr sty fun, pprMatch sty False{-not case-} match])
+\end{code}
+
+
+\begin{code}
+varyingArgsErr name matches sty
+  = ppSep [ppStr "Varying number of arguments for function", ppr sty name]
+\end{code}
diff --git a/ghc/compiler/typecheck/TcModule.hi b/ghc/compiler/typecheck/TcModule.hi
deleted file mode 100644
index f86d85b34f..0000000000
--- a/ghc/compiler/typecheck/TcModule.hi
+++ /dev/null
@@ -1,65 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface TcModule where
-import AbsSyn(Module)
-import Bag(Bag)
-import CE(CE(..))
-import CharSeq(CSeq)
-import Class(Class)
-import CmdLineOpts(GlobalSwitch)
-import E(E)
-import ErrUtils(Error(..))
-import FiniteMap(FiniteMap)
-import HsBinds(Bind, Binds, MonoBinds, Sig)
-import HsDecls(ClassDecl, DataTypeSig, DefaultDecl, FixityDecl, InstDecl, SpecialisedInstanceSig, TyDecl)
-import HsExpr(ArithSeqInfo, Expr, Qual)
-import HsImpExp(IE, ImportedInterface)
-import HsLit(Literal)
-import HsMatches(Match)
-import HsPat(InPat, RenamedPat(..), TypecheckedPat)
-import HsTypes(PolyType)
-import Id(Id)
-import Inst(Inst)
-import Maybes(Labda)
-import Name(Name)
-import NameTypes(FullName, ShortName)
-import PreludePS(_PackedString)
-import Pretty(Delay, PprStyle, Pretty(..), PrettyRep)
-import ProtoName(ProtoName)
-import SplitUniq(SplitUniqSupply)
-import SrcLoc(SrcLoc)
-import Subst(Subst)
-import TCE(TCE(..))
-import TcInstDcls(InstInfo)
-import TcMonad(TcResult)
-import TyCon(TyCon)
-import TyVar(TyVar, TyVarTemplate)
-import UniType(UniType)
-import UniqFM(UniqFM)
-import Unique(Unique)
-data Module a b 
-data Bag a 
-type CE = UniqFM Class
-data E 
-type Error = PprStyle -> Int -> Bool -> PrettyRep
-data Binds a b 
-data FixityDecl a 
-data Expr a b 
-data InPat a 
-type RenamedPat = InPat Name
-data TypecheckedPat 
-data Id 
-data Inst 
-data Labda a 
-data Name 
-data PprStyle 
-type Pretty = Int -> Bool -> PrettyRep
-data PrettyRep 
-data ProtoName 
-data SrcLoc 
-data Subst 
-type TCE = UniqFM TyCon
-data InstInfo 
-data TcResult a 
-data UniqFM a 
-tcModule :: E -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> Module Name (InPat Name) -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult ((Binds Id TypecheckedPat, Binds Id TypecheckedPat, Binds Id TypecheckedPat, [(Inst, Expr Id TypecheckedPat)]), ([FixityDecl Name], [Id], UniqFM Class, UniqFM TyCon, Bag InstInfo), FiniteMap TyCon [(Bool, [Labda UniType])], E, PprStyle -> Int -> Bool -> PrettyRep)
-
diff --git a/ghc/compiler/typecheck/TcModule.lhs b/ghc/compiler/typecheck/TcModule.lhs
index d0c43c120a..46668beb82 100644
--- a/ghc/compiler/typecheck/TcModule.lhs
+++ b/ghc/compiler/typecheck/TcModule.lhs
@@ -1,5 +1,5 @@
 %
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
 %
 \section[TcModule]{Typechecking a whole module}
 
@@ -7,232 +7,155 @@
 #include "HsVersions.h"
 
 module TcModule (
-	tcModule,
-
-	-- to make the interface self-sufficient...
-	Module, Bag, CE(..), E, Binds, FixityDecl, Expr, InPat,
-	RenamedPat(..), TypecheckedPat, Id, Inst, Maybe, TcResult,
-	Name, ProtoName, SrcLoc, Subst, TCE(..), UniqFM,
-	Error(..), Pretty(..), PprStyle, PrettyRep, InstInfo
+	tcModule
     ) where
 
-import TcMonad		-- typechecking monad machinery
-import AbsSyn		-- the stuff being typechecked
-
--- OLD:
---import AbsPrel	( stringTy,
---			  eqStringId, neStringId, ltStringId,
---			  leStringId, geStringId, gtStringId,
---			  maxStringId, minStringId, tagCmpStringId,
---			  dfunEqStringId, dfunOrdStringId,
---			  pRELUDE_CORE
---			  IF_ATTACK_PRAGMAS(COMMA mkListTy COMMA charTy)
---			)
---#if USE_ATTACK_PRAGMAS
---import PrelVals	( string_cmp_id ) -- shouldn't even be visible, really
---#endif
-import BackSubst	( applyTcSubstToBinds )
-import Bag		( unionBags, bagToList, emptyBag, listToBag )
-import CE		( nullCE, checkClassCycles, lookupCE, CE(..) )
-import CmdLineOpts	( GlobalSwitch(..) )
-import E
-import HsCore		-- ****** NEED TO SEE CONSTRUCTORS ******
-import HsPragmas	-- ****** NEED TO SEE CONSTRUCTORS ******
-import InstEnv
-import LIE		( unMkLIE, plusLIE, LIE )
-import Name		( Name(..) )
-import RenameAuxFuns	( GlobalNameFuns(..), GlobalNameFun(..), ProtoName, Maybe )
-import SrcLoc		( mkBuiltinSrcLoc, SrcLoc )
-import TCE		( checkTypeCycles, TCE(..), UniqFM )
-import TcBinds		( tcTopBindsAndThen )
-import TcClassDcl	( tcClassDecls1, tcClassDecls2, ClassInfo )
+import Ubiq
+
+import HsSyn		( HsModule(..), HsBinds(..), Bind, HsExpr,
+			  TyDecl, SpecDataSig, ClassDecl, InstDecl,
+			  SpecInstSig, DefaultDecl, Sig, Fake, InPat,
+ 			  FixityDecl, IE, ImportedInterface )
+import RnHsSyn		( RenamedHsModule(..), RenamedFixityDecl(..) )
+import TcHsSyn		( TypecheckedHsBinds(..), TypecheckedHsExpr(..),
+			  TcIdOcc(..), zonkBinds, zonkInst, zonkId )
+
+import TcMonad
+import Inst		( Inst, plusLIE )
+import TcBinds		( tcBindsAndThen )
+import TcClassDcl	( tcClassDecls2 )
 import TcDefaults	( tcDefaults )
-import TcDeriv		( tcDeriving )
+import TcEnv		( tcExtendGlobalValEnv, getEnv_LocalIds,
+			  getEnv_TyCons, getEnv_Classes)
 import TcIfaceSig	( tcInterfaceSigs )
-import TcInstDcls	( tcInstDecls1, tcInstDecls2, tcSpecInstSigs, buildInstanceEnvs, InstInfo(..) )
+import TcInstDcls	( tcInstDecls1, tcInstDecls2 )
+import TcInstUtil	( buildInstanceEnvs, InstInfo )
 import TcSimplify	( tcSimplifyTop )
-import TcTyDecls	( tcTyDecls )
-import Unique		-- some ClassKey stuff
-import UniqFM		( emptyUFM ) -- profiling, pragmas only
+import TcTyClsDecls	( tcTyAndClassDecls1 )
+
+import Bag		( listToBag )
+import Class		( GenClass )
+import Id		( GenId, isDataCon, isMethodSelId, idType )
+import Maybes		( catMaybes )
+import Name		( Name(..) )
+import Outputable	( isExported )
+import PrelInfo		( unitTy, mkPrimIoTy )
+import Pretty
+import RnUtils		( GlobalNameMappers(..), GlobalNameMapper(..) )
+import TyCon		( TyCon )
+import Type		( applyTyCon )
+import Unify		( unifyTauTy )
+import UniqFM		( lookupUFM_Directly, lookupWithDefaultUFM_Directly,
+		          filterUFM, eltsUFM )
+import Unique		( iOTyConKey, mainIdKey, mainPrimIOIdKey )
 import Util
 
-import Pretty		-- Debugging
+
+import FiniteMap	( emptyFM )
+tycon_specs = emptyFM
+
+
 \end{code}
 
 \begin{code}
-tcModule :: E				-- initial typechecker environment
-	 -> GlobalNameFuns		-- final renamer info (to do derivings)
-	 -> RenamedModule		-- input
-	 -> TcM ((TypecheckedBinds,	-- binds from class decls; does NOT
+tcModule :: GlobalNameMappers		-- final renamer info for derivings
+	 -> RenamedHsModule		-- input
+	 -> TcM s ((TypecheckedHsBinds,	-- binds from class decls; does NOT
 					-- include default-methods bindings
-		  TypecheckedBinds,	-- binds from instance decls; INCLUDES
+		    TypecheckedHsBinds,	-- binds from instance decls; INCLUDES
 					-- class default-methods binds
-		  TypecheckedBinds,	-- binds from value decls
-		  [(Inst, TypecheckedExpr)]),
+		    TypecheckedHsBinds,	-- binds from value decls
+
+		    [(Id, TypecheckedHsExpr)]), -- constant instance binds
 
-		 ([RenamedFixityDecl],	-- things for the interface generator
-		  [Id],			-- to look at...
-		  CE,
-		  TCE,
-		  Bag InstInfo),
+		   ([RenamedFixityDecl], [Id], UniqFM TyCon, UniqFM Class, Bag InstInfo),
+					-- things for the interface generator
 
-		 FiniteMap TyCon [(Bool, [Maybe UniType])],
+		   (UniqFM TyCon, UniqFM Class),
+					-- environments of info from this module only
+
+		   FiniteMap TyCon [(Bool, [Maybe Type])],
 					-- source tycon specialisation requests
 
---UNUSED:	 E,			-- environment of total accumulated info
-		 E,			-- environment of info due to this module only
-		 PprStyle -> Pretty)	-- -ddump-deriving info (passed upwards)
+		   PprStyle -> Pretty)	-- -ddump-deriving info
+
+tcModule renamer_name_funs
+	(HsModule mod_name exports imports fixities
+		  ty_decls specdata_sigs cls_decls inst_decls specinst_sigs
+		  default_decls val_decls sigs src_loc)
 
-tcModule e1 renamer_name_funs
-	(Module mod_name exports imports_should_be_empty fixities
-	     tydecls ty_sigs classdecls instdecls specinst_sigs
-	     default_decls valdecls sigs src_loc)
+  = ASSERT(null imports)
 
-  = addSrcLocTc src_loc (	-- record where we're starting
+    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
 	-- pragmas, which is done lazily [ie failure just drops the pragma
 	-- without having any global-failure effect].
 
-    fixTc (\ ~(rec_gve_sigs, _, _, _, _, _, _, _, _, _) ->
-    let
-	e2 = plusE_GVE e1 rec_gve_sigs
-    in
+    fixTc (\ ~(_, _, _, _, _, sig_ids) ->
+	tcExtendGlobalValEnv sig_ids (
 
 	-- The knot for instance information.  This isn't used at all
-	-- till we type-check value declarations.
-	fixTc ( \ ~(rec_inst_mapper, _, _, _, _, _, _, _, _) ->
-
-	     -- The knot for TyCons and Classes
-	    fixTc ( \ ~(_, rec_tce, rec_ce, rec_datacons_gve, rec_ops_gve, _, _) ->
-		let
-		    e3 = e2
-			 `plusE_GVE` rec_datacons_gve
-			 `plusE_GVE` rec_ops_gve
-			 `plusE_TCE` rec_tce
-			 `plusE_CE`  rec_ce
-		in
-		    -- DO THE TYPE DECLS
-		    -- Including the pragmas: {-# ABSTRACT TypeSyn #-}
-		    --			      {-# SPECIALIZE data DataType ... #-}
-		let
-		    (absty_sigs, specdata_sigs) = partition is_absty_sig ty_sigs
-		    is_absty_sig (AbstractTypeSig _ _) = True
-		    is_absty_sig (SpecDataSig _ _ _)   = False
-
-		    is_abs_syn :: Name -> Bool  -- a lookup fn for abs synonyms
-		    is_abs_syn n
-		      = n `is_elem` [ tc | (AbstractTypeSig tc _) <- absty_sigs ]
-		      where
-		        is_elem = isIn "tcModule"
-
-		    get_spec_sigs :: Name -> [RenamedDataTypeSig]
-		    get_spec_sigs n
-		      = [ sig | sig@(SpecDataSig tc _ _) <- specdata_sigs, n == tc]
-		in
-		babyTcMtoTcM (tcTyDecls e3 is_abs_syn get_spec_sigs tydecls)
-			`thenTc` \ (tce, datacons_gve, tycon_specs) ->
-
-		    -- DO THE CLASS DECLS
-		tcClassDecls1 e3 rec_inst_mapper classdecls
-			`thenTc` \ (class_info, ce, ops_gve) ->
-
-		    -- End of TyCon/Class knot
-		    -- Augment whatever TCE/GVE/CE stuff was in orig_e
-		returnTc (e3, tce, ce, datacons_gve, ops_gve, class_info, tycon_specs)
-
-		   -- End of inner fixTc
-	    )   `thenTc` ( \ (e3, tce_here, ce_here, _, _, class_info, tycon_specs) ->
-			     -- The "here" things are the extra decls defined in this
-			     -- module or its imports; but not including whatever was
-			     -- in the incoming e.
-
-		    -- Grab completed tce/ce and check for type/class cycles
-		    -- The tce/ce are now stable and lookable-at, with the
-		    -- exception of the instance information inside classes
-	    let
-		ce3  = getE_CE e3
-		tce3 = getE_TCE e3
-	    in
-	    checkMaybeErrTc (checkTypeCycles tce3) id    `thenTc_`
-	    checkMaybeErrTc (checkClassCycles ce3) id    `thenTc_`
-
-		    -- Now instance declarations
-	    tcInstDecls1 e3 ce3 tce3 instdecls		`thenNF_Tc` \ decl_inst_info ->
-
-		    -- 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
-		    -- doing Text.
-
-	    tcDeriving mod_name renamer_name_funs decl_inst_info tce3 fixities
-		    `thenTc` \ (deriv_inst_info, extra_deriv_binds, ddump_deriv) ->
-
-	    let
-		inst_info = deriv_inst_info `unionBags` decl_inst_info 
-	    in
-		    -- Handle specialise instance pragmas
-	    getSwitchCheckerTc			`thenNF_Tc` \ sw_chkr ->
-	    (if sw_chkr SpecialiseOverloaded then
-	         tcSpecInstSigs e3 ce3 tce3 inst_info specinst_sigs
-	     else
-		 returnTc emptyBag)
-		    				`thenTc` \ spec_inst_info ->
-	    let
-		full_inst_info = inst_info `unionBags` spec_inst_info 
-	    in
-		    -- OK, now do the inst-mapper stuff
-	    buildInstanceEnvs full_inst_info	`thenTc` \ all_insts_mapper ->
-
-	    returnTc (all_insts_mapper, e3, ce_here, tce_here, class_info, tycon_specs,
-		      full_inst_info, extra_deriv_binds, ddump_deriv)
-
-		    -- End of outer fixTc
-	)) `thenTc` ( \ (_, e3, ce_here, tce_here, class_info, tycon_specs,
-			full_inst_info, extra_deriv_binds, ddump_deriv) ->
-
-    -- Default declarations
-    tcDefaults e3 default_decls	`thenTc` \ defaulting_tys ->
-    setDefaultingTys defaulting_tys ( -- for the iface sigs...
-
-    -- Interface type signatures
-
-    -- We tie a knot so that the Ids read out of interfaces are in scope
-    --   when we read their pragmas.
-    -- 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
-
-    babyTcMtoTcM (tcInterfaceSigs e3 sigs)	`thenTc` \ gve_sigs ->
-
-    returnTc (gve_sigs, e3, ce_here, tce_here, class_info, tycon_specs, defaulting_tys,
-  	      full_inst_info, extra_deriv_binds, ddump_deriv)
-
-    -- End of extremely outer fixTc
-    )))	`thenTc` \ (_, e3, ce_here, tce_here, class_info, tycon_specs, defaulting_tys,
-		    full_inst_info, extra_deriv_binds, ddump_deriv) ->
-
-    setDefaultingTys defaulting_tys ( -- to the end...
+	-- till we type-check value declarations
+	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 ->
+
+		-- Typecheck the instance decls, includes deriving
+	    tcSetEnv env (
+	    trace "tcInstDecls:"	$
+	    tcInstDecls1 inst_decls_bag specinst_sigs
+			 mod_name renamer_name_funs fixities 
+	    )				`thenTc` \ (inst_info, deriv_binds, ddump_deriv) ->
+
+	    buildInstanceEnvs inst_info	`thenTc` \ inst_mapper ->
+
+	    returnTc (inst_mapper, env, inst_info, deriv_binds, ddump_deriv)
+
+	) `thenTc` \ (_, env, inst_info, deriv_binds, ddump_deriv) ->
+	tcSetEnv env (
+
+	    -- Default declarations
+	tcDefaults default_decls	`thenTc` \ defaulting_tys ->
+	tcSetDefaultTys defaulting_tys 	( -- for the iface sigs...
+
+	    -- Interface type signatures
+	    -- We tie a knot so that the Ids read out of interfaces are in scope
+	    --   when we read their pragmas.
+	    -- 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 ->
+
+	returnTc (env, inst_info, deriv_binds, ddump_deriv, defaulting_tys, sig_ids)
+
+    )))) `thenTc` \ (env, inst_info, deriv_binds, ddump_deriv, defaulting_tys, _) ->
+
+    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
-	-- Nota bene
-    tcTopBindsAndThen
-	e3
+    trace "tcBinds:"			$
+    tcBindsAndThen
 	(\ binds1 (binds2, thing) -> (binds1 `ThenBinds` binds2, thing))
-	(valdecls `ThenBinds` extra_deriv_binds)
-	(\ e4 ->
-		-- Second pass over instance declarations,
+	(val_decls `ThenBinds` deriv_binds)
+	(	-- Second pass over instance declarations,
 		-- to compile the bindings themselves.
-	    tcInstDecls2  e4 full_inst_info `thenNF_Tc` \ (lie_instdecls, inst_binds) ->
-	    tcClassDecls2 e4 class_info	    `thenNF_Tc` \ (lie_clasdecls, class_binds) ->
-	    returnTc ( (EmptyBinds, (inst_binds, class_binds, e4)),
+	    tcInstDecls2  inst_info	`thenNF_Tc` \ (lie_instdecls, inst_binds) ->
+	    tcClassDecls2 cls_decls_bag	`thenNF_Tc` \ (lie_clasdecls, cls_binds) ->
+	    tcGetEnv			`thenNF_Tc` \ env ->
+	    returnTc ( (EmptyBinds, (inst_binds, cls_binds, env)),
 		       lie_instdecls `plusLIE` lie_clasdecls,
-		       () )
-	)
+		       () ))
+
+	`thenTc` \ ((val_binds, (inst_binds, cls_binds, final_env)), lie_alldecls, _) ->
 
-	`thenTc` \ ((val_binds, (inst_binds, class_binds, e4)), lie_alldecls, _) ->
+    checkTopLevelIds mod_name final_env	`thenTc_`
 
 	-- Deal with constant or ambiguous InstIds.  How could
 	-- there be ambiguous ones?  They can only arise if a
@@ -240,40 +163,95 @@ tcModule e1 renamer_name_funs
 	-- restriction, and no subsequent decl instantiates its
 	-- type.  (Usually, ambiguous type variables are resolved
 	-- during the generalisation step.)
+    tcSimplifyTop lie_alldecls			`thenTc` \ const_insts ->
+    let
+        localids = getEnv_LocalIds final_env
+	tycons   = getEnv_TyCons final_env
+	classes  = getEnv_Classes final_env
 
-    tcSimplifyTop (unMkLIE lie_alldecls)    `thenTc` \ const_inst_binds ->
+	local_tycons  = filterUFM isLocallyDefined tycons
+	local_classes = filterUFM isLocallyDefined classes
 
+	exported_ids = [v | v <- eltsUFM localids,
+		        isExported v && not (isDataCon v) && not (isMethodSelId v)]
+    in
 	-- Backsubstitution.  Monomorphic top-level decls may have
 	-- been instantiated by subsequent decls, and the final
 	-- simplification step may have instantiated some
 	-- ambiguous types.  So, sadly, we need to back-substitute
 	-- over the whole bunch of bindings.
-
-    applyTcSubstToBinds val_binds	    `thenNF_Tc` \ val_binds' ->
-    applyTcSubstToBinds inst_binds	    `thenNF_Tc` \ inst_binds' ->
-    applyTcSubstToBinds class_binds	    `thenNF_Tc` \ class_binds' ->
-
-	-- ToDo: probably need to back-substitute over all
-	-- stuff in 'e4'; we do so here over the Ids,
-	-- which is probably enough.  WDP 95/06
-    mapNF_Tc applyTcSubstToId (getE_GlobalVals e4)
-					    `thenNF_Tc` \ if_global_ids ->
+    zonkBinds val_binds		 	`thenNF_Tc` \ val_binds' ->
+    zonkBinds inst_binds	 	`thenNF_Tc` \ inst_binds' ->
+    zonkBinds cls_binds	 		`thenNF_Tc` \ cls_binds' ->
+    mapNF_Tc zonkInst const_insts 	`thenNF_Tc` \ const_insts' ->
+    mapNF_Tc (zonkId.TcId) exported_ids	`thenNF_Tc` \ exported_ids' ->
 
 	-- FINISHED AT LAST
     returnTc (
-	(class_binds', inst_binds', val_binds', const_inst_binds),
+	(cls_binds', inst_binds', val_binds', const_insts'),
 
 	     -- the next collection is just for mkInterface
-	(fixities, if_global_ids, ce_here, tce_here, full_inst_info),
+	(fixities, exported_ids', tycons, classes, inst_info),
 
-	tycon_specs,
+	(local_tycons, local_classes),
 
---UNUSED: e4,
+	tycon_specs,
 
-	  -- and... TCE needed for code generation; rest needed for interpreter.
-	  -- ToDo: still wrong: needs isLocallyDeclared run over everything
-	mkE tce_here {-gve_here lve-} ce_here,
-	     -- NB: interpreter would probably need the gve_here stuff
 	ddump_deriv
     )))
+  where
+    ty_decls_bag   = listToBag ty_decls
+    cls_decls_bag  = listToBag cls_decls
+    inst_decls_bag = listToBag inst_decls
+
+\end{code}
+
+
+%************************************************************************
+%*									*
+\subsection{Error checking code}
+%*									*
+%************************************************************************
+
+
+checkTopLevelIds checks that Main.main or Main.mainPrimIO has correct type.
+
+\begin{code}
+checkTopLevelIds :: FAST_STRING -> TcEnv s -> TcM s ()
+checkTopLevelIds mod final_env
+  = if (mod /= SLIT("Main")) then
+	returnTc ()
+    else
+	case (lookupUFM_Directly localids mainIdKey,
+	      lookupUFM_Directly localids mainPrimIOIdKey) of 
+	  (Just main, Nothing) -> tcAddErrCtxt mainCtxt $
+		                  unifyTauTy ty_main (idType main)
+	  (Nothing, Just prim) -> tcAddErrCtxt primCtxt $
+		                  unifyTauTy ty_prim (idType prim)
+	  (Just _ , Just _ )   -> failTc mainBothIdErr
+	  (Nothing, Nothing)   -> failTc mainNoneIdErr
+    where
+      localids = getEnv_LocalIds final_env
+      tycons   = getEnv_TyCons final_env
+
+      io_tc    = lookupWithDefaultUFM_Directly tycons io_panic iOTyConKey
+      io_panic = panic "TcModule: type IO not in scope"
+
+      ty_main  = applyTyCon io_tc [unitTy]
+      ty_prim  = mkPrimIoTy unitTy
+
+
+mainCtxt sty
+  = ppStr "main should have type IO ()"
+
+primCtxt sty
+  = ppStr "mainPrimIO should have type PrimIO ()"
+
+mainBothIdErr sty
+  = ppStr "module Main contains definitions for both main and mainPrimIO"
+
+mainNoneIdErr sty
+  = panic "ToDo: sort out mainIdKey"
+ -- ppStr "module Main does not contain a definition for main (or mainPrimIO)"
+
 \end{code}
diff --git a/ghc/compiler/typecheck/TcMonad.hi b/ghc/compiler/typecheck/TcMonad.hi
deleted file mode 100644
index b90935d03b..0000000000
--- a/ghc/compiler/typecheck/TcMonad.hi
+++ /dev/null
@@ -1,137 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface TcMonad where
-import Bag(Bag)
-import CharSeq(CSeq)
-import Class(Class)
-import CmdLineOpts(GlobalSwitch)
-import ErrUtils(Error(..))
-import ErrsTc(UnifyErrContext)
-import FiniteMap(FiniteMap)
-import HsBinds(Binds)
-import HsExpr(ArithSeqInfo, Expr, Qual, TypecheckedExpr(..))
-import HsLit(Literal)
-import HsMatches(GRHS, GRHSsAndBinds, Match)
-import HsPat(InPat, TypecheckedPat)
-import HsTypes(PolyType)
-import Id(Id)
-import IdInfo(IdInfo)
-import Inst(Inst)
-import Maybes(Labda, MaybeErr)
-import Name(Name)
-import NameTypes(FullName, ShortName)
-import PreludePS(_PackedString)
-import Pretty(Delay, PprStyle, Pretty(..), PrettyRep)
-import ProtoName(ProtoName)
-import RenameAuxFuns(GlobalNameFun(..), GlobalNameFuns(..))
-import RenameMonad4(Rn4M(..))
-import SplitUniq(SUniqSM(..), SplitUniqSupply)
-import SrcLoc(SrcLoc)
-import Subst(Subst)
-import TyCon(TyCon)
-import TyVar(TyVar, TyVarTemplate)
-import UniType(SigmaType(..), TauType(..), ThetaType(..), UniType)
-import Unique(Unique, UniqueSupply)
-infixr 9 `thenLazilyNF_Tc`
-infixr 9 `thenNF_Tc`
-infixr 9 `thenTc`
-infixr 9 `thenTc_`
-type Baby_TcM a = (GlobalSwitch -> Bool) -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> Baby_TcResult a
-data Baby_TcResult a 
-data Bag a 
-data Class 
-data GlobalSwitch 
-type Error = PprStyle -> Int -> Bool -> PrettyRep
-data Expr a b 
-type NF_TcM a = (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> (a, Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep))
-type TcM a = (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult a
-data TcResult a 
-data UnifyErrContext 
-type TypecheckedExpr = Expr Id TypecheckedPat
-data TypecheckedPat 
-data Id 
-data IdInfo 
-data Inst 
-data Labda a 
-data MaybeErr a b 
-data Name 
-data PprStyle 
-type Pretty = Int -> Bool -> PrettyRep
-data PrettyRep 
-data ProtoName 
-type GlobalNameFun = ProtoName -> Labda Name
-type GlobalNameFuns = (ProtoName -> Labda Name, ProtoName -> Labda Name)
-type Rn4M a = (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (a, Bag (PprStyle -> Int -> Bool -> PrettyRep))
-type SUniqSM a = SplitUniqSupply -> a
-data SplitUniqSupply 
-data SrcLoc 
-data Subst 
-data TyCon 
-data TyVar 
-data TyVarTemplate 
-type SigmaType = UniType
-type TauType = UniType
-type ThetaType = [(Class, UniType)]
-data UniType 
-data Unique 
-data UniqueSupply 
-addSrcLocB_Tc :: SrcLoc -> ((GlobalSwitch -> Bool) -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> Baby_TcResult a) -> (GlobalSwitch -> Bool) -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> Baby_TcResult a
-addSrcLocTc :: SrcLoc -> ((GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult a) -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult a
-applyTcSubstToId :: Id -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> (Id, Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep))
-applyTcSubstToInst :: Inst -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> (Inst, Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep))
-applyTcSubstToInsts :: [Inst] -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> ([Inst], Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep))
-applyTcSubstToTy :: UniType -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> (UniType, Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep))
-applyTcSubstToTyVar :: TyVar -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> (UniType, Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep))
-applyTcSubstToTyVars :: [TyVar] -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> ([UniType], Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep))
-applyTcSubstToTys :: [UniType] -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> ([UniType], Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep))
-babyTcMtoNF_TcM :: ((GlobalSwitch -> Bool) -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> Baby_TcResult a) -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> (a, Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep))
-babyTcMtoTcM :: ((GlobalSwitch -> Bool) -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> Baby_TcResult a) -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult a
-checkB_Tc :: Bool -> (PprStyle -> Int -> Bool -> PrettyRep) -> (GlobalSwitch -> Bool) -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> Baby_TcResult ()
-checkMaybeErrTc :: MaybeErr b a -> (a -> PprStyle -> Int -> Bool -> PrettyRep) -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult b
-checkMaybeTc :: Labda a -> (PprStyle -> Int -> Bool -> PrettyRep) -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult a
-checkMaybesTc :: [Labda a] -> (PprStyle -> Int -> Bool -> PrettyRep) -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult [a]
-checkTc :: Bool -> (PprStyle -> Int -> Bool -> PrettyRep) -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult ()
-extendSubstTc :: TyVar -> UniType -> UnifyErrContext -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult ()
-failB_Tc :: (PprStyle -> Int -> Bool -> PrettyRep) -> a -> b -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> c -> Baby_TcResult d
-failTc :: (PprStyle -> Int -> Bool -> PrettyRep) -> a -> b -> Subst -> c -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> d -> TcResult e
-fixB_Tc :: (a -> (GlobalSwitch -> Bool) -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> Baby_TcResult a) -> (GlobalSwitch -> Bool) -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> Baby_TcResult a
-fixNF_Tc :: (a -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> (a, Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep))) -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> (a, Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep))
-fixTc :: (a -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult a) -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult a
-foldlTc :: (b -> a -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult b) -> b -> [a] -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult b
-getDefaultingTys :: (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> ([UniType], Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep))
-getSrcLocB_Tc :: a -> b -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> c -> Baby_TcResult c
-getSrcLocTc :: (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> (SrcLoc, Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep))
-getSwitchCheckerB_Tc :: (GlobalSwitch -> Bool) -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> Baby_TcResult (GlobalSwitch -> Bool)
-getSwitchCheckerTc :: (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> (GlobalSwitch -> Bool, Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep))
-getTyVarUniqueTc :: (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> (Unique, Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep))
-getTyVarUniquesTc :: Int -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> ([Unique], Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep))
-getUniqueB_Tc :: (GlobalSwitch -> Bool) -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> Baby_TcResult Unique
-getUniqueTc :: (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> (Unique, Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep))
-getUniquesB_Tc :: Int -> (GlobalSwitch -> Bool) -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> Baby_TcResult [Unique]
-getUniquesTc :: Int -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> ([Unique], Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep))
-initTc :: (GlobalSwitch -> Bool) -> SplitUniqSupply -> ((GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult a) -> MaybeErr a (Bag (PprStyle -> Int -> Bool -> PrettyRep))
-listNF_Tc :: [(GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> (a, Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep))] -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> ([a], Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep))
-listTc :: [(GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult a] -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult [a]
-lookupInst_Tc :: Inst -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult (Expr Id TypecheckedPat, [Inst])
-lookupNoBindInst_Tc :: Inst -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult [Inst]
-mapAndUnzipTc :: (a -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult (b, c)) -> [a] -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult ([b], [c])
-mapB_Tc :: (a -> (GlobalSwitch -> Bool) -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> Baby_TcResult b) -> [a] -> (GlobalSwitch -> Bool) -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> Baby_TcResult [b]
-mapNF_Tc :: (a -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> (b, Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep))) -> [a] -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> ([b], Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep))
-mapTc :: (a -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult b) -> [a] -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult [b]
-noFailTc :: ((GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult a) -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> (a, Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep))
-pruneSubstTc :: [TyVar] -> ((GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult a) -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult a
-recoverIgnoreErrorsB_Tc :: e -> (b -> c -> Bag a -> d -> Baby_TcResult e) -> b -> c -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> d -> Baby_TcResult e
-recoverQuietlyTc :: a -> ((GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult a) -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> (a, Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep))
-recoverTc :: a -> ((GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult a) -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> (a, Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep))
-returnB_Tc :: a -> (GlobalSwitch -> Bool) -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> Baby_TcResult a
-returnNF_Tc :: a -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> (a, Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep))
-returnTc :: a -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult a
-rn4MtoTcM :: (ProtoName -> Labda Name, ProtoName -> Labda Name) -> ((GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (a, Bag (PprStyle -> Int -> Bool -> PrettyRep))) -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> ((a, Bag (PprStyle -> Int -> Bool -> PrettyRep)), Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep))
-setDefaultingTys :: [UniType] -> ((GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult a) -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult a
-thenB_Tc :: ((GlobalSwitch -> Bool) -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> Baby_TcResult a) -> (a -> (GlobalSwitch -> Bool) -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> Baby_TcResult b) -> (GlobalSwitch -> Bool) -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> Baby_TcResult b
-thenB_Tc_ :: ((GlobalSwitch -> Bool) -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> Baby_TcResult a) -> ((GlobalSwitch -> Bool) -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> Baby_TcResult b) -> (GlobalSwitch -> Bool) -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> Baby_TcResult b
-thenLazilyNF_Tc :: ((GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> (a, Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep))) -> (a -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> b) -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> b
-thenNF_Tc :: ((GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> (a, Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep))) -> (a -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> b) -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> b
-thenTc :: ((GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult a) -> (a -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult b) -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult b
-thenTc_ :: ((GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult a) -> ((GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult b) -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult b
-uniqSMtoBabyTcM :: (SplitUniqSupply -> a) -> (GlobalSwitch -> Bool) -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> Baby_TcResult a
-
diff --git a/ghc/compiler/typecheck/TcMonad.lhs b/ghc/compiler/typecheck/TcMonad.lhs
index dc947dce3b..59b9967710 100644
--- a/ghc/compiler/typecheck/TcMonad.lhs
+++ b/ghc/compiler/typecheck/TcMonad.lhs
@@ -1,729 +1,444 @@
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
-%
-\section[TcMonad]{@TcMonad@: monad machinery for the typechecker}
-
 \begin{code}
-#include "HsVersions.h"
-
-module TcMonad (
-	TcM(..), TcResult{-abstract-},
-	thenTc, thenTc_, returnTc, failTc, checkTc,
-	listTc, mapTc, mapAndUnzipTc,
-	fixTc, foldlTc, initTc,
-	recoverTc, recoverQuietlyTc,
-
-	NF_TcM(..),
-	thenNF_Tc, thenLazilyNF_Tc, returnNF_Tc, listNF_Tc, mapNF_Tc,
-	fixNF_Tc, noFailTc,
-
-	Baby_TcM(..), Baby_TcResult{-abstract-},
-	returnB_Tc, thenB_Tc, thenB_Tc_,
-	failB_Tc, recoverIgnoreErrorsB_Tc,
-	fixB_Tc, mapB_Tc,
-	babyTcMtoTcM, babyTcMtoNF_TcM,
-	getUniqueB_Tc, getUniquesB_Tc,
-	addSrcLocB_Tc, getSrcLocB_Tc,
-	getSwitchCheckerB_Tc, checkB_Tc,
-	uniqSMtoBabyTcM,
-
-	getSwitchCheckerTc,
-	getDefaultingTys, setDefaultingTys,
-	getUniquesTc, getUniqueTc,
-	rn4MtoTcM,
-
-	getTyVarUniquesTc, getTyVarUniqueTc,
-
-	applyTcSubstToTy, applyTcSubstToTys,
---UNUSED:	applyTcSubstToThetaTy,
-	applyTcSubstToTyVar, applyTcSubstToTyVars,
-	applyTcSubstToId,
-	applyTcSubstToInst, applyTcSubstToInsts,
-	extendSubstTc, pruneSubstTc,
-
-	addSrcLocTc, getSrcLocTc,
-	checkMaybeTc,	 checkMaybesTc,
-	checkMaybeErrTc, -- UNUSED: checkMaybeErrsTc,
-
-	lookupInst_Tc, lookupNoBindInst_Tc,
-
-	-- and to make the interface self-sufficient ...
-	UniqueSupply, SplitUniqSupply,
-	Bag, Maybe, MaybeErr, Error(..), PprStyle, Pretty(..),
-	PrettyRep, SrcLoc, Subst, TyVar, TyVarTemplate, TyCon,
-	Class, UniType, TauType(..), ThetaType(..), SigmaType(..),
-	UnifyErrContext, Unique, Expr,
-	TypecheckedExpr(..), TypecheckedPat, Id, IdInfo, Inst,
-	GlobalSwitch, SUniqSM(..), Rn4M(..), GlobalNameFuns(..),
-	GlobalNameFun(..), Name, ProtoName
-
-	IF_ATTACK_PRAGMAS(COMMA getSUnique COMMA getSUniques)
-	IF_ATTACK_PRAGMAS(COMMA splitUniqSupply COMMA mkUniqueGrimily)
-	IF_ATTACK_PRAGMAS(COMMA applySubstToId)
-	IF_ATTACK_PRAGMAS(COMMA applySubstToInst)
-	IF_ATTACK_PRAGMAS(COMMA applySubstToThetaTy)
-	IF_ATTACK_PRAGMAS(COMMA applySubstToTy)
-	IF_ATTACK_PRAGMAS(COMMA applySubstToTyVar)
-    ) where
-
-import AbsSyn
-import AbsUniType	( TyVar, TyVarTemplate, TyCon, Class, UniType,
-			  TauType(..), ThetaType(..), SigmaType(..)
-			  IF_ATTACK_PRAGMAS(COMMA cmpUniType)
-			)
-import Bag		( Bag, snocBag, emptyBag, isEmptyBag )
-import CmdLineOpts	( GlobalSwitch )
-import Errors		( noInstanceErr, unifyErr, pprBagOfErrors,
-			  Error(..), UnifyErrInfo(..), UnifyErrContext(..)
-			)
-import FiniteMap	( emptyFM, FiniteMap )
-import Id		( applySubstToId )
-import Inst		( applySubstToInst )
-import InstEnv		( lookupInst, lookupNoBindInst, Inst )
-import Maybes		( Maybe(..), MaybeErr(..) )
-import Pretty
-import RenameMonad4	( Rn4M(..), GlobalNameFuns(..), GlobalNameFun(..) )
-import SrcLoc		( mkUnknownSrcLoc )
-import Subst
-import Unify
-import SplitUniq
-import Unique
-import Util
-
-infixr 9 `thenTc`, `thenTc_`, `thenNF_Tc`, `thenLazilyNF_Tc`
-\end{code}
+module TcMonad(
+	TcM(..), NF_TcM(..), TcDown, TcEnv, 
+	SST_R, FSST_R,
 
-%************************************************************************
-%*									*
-\subsection[TcM-TcM]{Plain @TcM@ monadery}
-%*									*
-%************************************************************************
+	initTc,
+	returnTc, thenTc, thenTc_, mapTc, listTc,
+	foldrTc, foldlTc, mapAndUnzipTc, mapAndUnzip3Tc,
+	mapBagTc, fixTc, tryTc,
 
-The following @TcM@ is of the garden variety which can fail, and does
-as soon as possible.
+	returnNF_Tc, thenNF_Tc, thenNF_Tc_, mapNF_Tc, 
+	listNF_Tc, mapAndUnzipNF_Tc, mapBagNF_Tc,
 
-\begin{code}
--- internal use only...
-type InTcM output
-	=  (GlobalSwitch -> Bool)	-- so we can chk cmd-line switches
-	-> [UniType]			-- types used for defaulting; down only
-	-> Subst			-- substitution; threaded
-	-> SplitUniqSupply		-- threaded
-	-> Bag Error			-- threaded
-	-> SrcLoc			-- only passed downwards
-	-> output
-
-data TcResult result
-  = TcSucceeded result
-		Subst
-		(Bag Error)
-  | TcFailed	Subst
-		(Bag Error)
-
-type TcM result
-	= InTcM (TcResult result)
-
-#ifdef __GLASGOW_HASKELL__
-{-# INLINE thenTc #-}
-{-# INLINE thenTc_ #-}
-{-# INLINE returnTc #-}
-#endif
-
-thenTc  :: TcM a -> (a -> TcM b) -> TcM b
-thenTc_ :: TcM a -> TcM b -> TcM b
-
-thenTc expr cont sw_chkr dtys subst us errs src_loc
-  = case splitUniqSupply us	    of { (s1, s2) ->
-    case (expr sw_chkr dtys subst s1 errs src_loc) of
-      TcFailed subst errs -> TcFailed subst errs
-      TcSucceeded result subst2 errs2
-	-> cont result sw_chkr dtys subst2 s2 errs2 src_loc
-    }
-
-thenTc_ expr cont sw_chkr dtys subst us errs src_loc
-  = case splitUniqSupply us	    of { (s1, s2) ->
-    case (expr sw_chkr dtys subst s1 errs src_loc) of
-      TcFailed subst errs -> TcFailed subst errs
-      TcSucceeded _ subst2 errs2
-	-> cont sw_chkr dtys subst2 s2 errs2 src_loc
-    }
-
-returnTc :: a -> TcM a
-returnTc result sw_chkr dtys subst us errs src_loc
-  = TcSucceeded result subst errs
-
-failTc err sw_chkr dtys subst us errs src_loc
-  = TcFailed subst (errs `snocBag` err)
-\end{code}
+	checkTc, checkTcM, checkMaybeTc, checkMaybeTcM, 
+	failTc, warnTc, recoverTc, recoverNF_Tc,
 
-@recoverTc@ recovers from an error, by providing a value to use
-instead.  It is also lazy, in that it always succeeds immediately; the
-thing inside is only even looked at when you pull on the errors, or on
-the value returned.
+	tcGetEnv, tcSetEnv,
+	tcGetDefaultTys, tcSetDefaultTys,
+	tcGetUnique, tcGetUniques,
 
-@recoverQuietlyTc@ doesn't even report the errors found---it is used
-when looking at pragmas.
+	tcAddSrcLoc, tcGetSrcLoc,
+	tcAddErrCtxtM, tcSetErrCtxtM,
+	tcAddErrCtxt, tcSetErrCtxt,
 
-\begin{code}
-recoverTc, recoverQuietlyTc :: a -> TcM a -> NF_TcM a
+	tcNewMutVar, tcReadMutVar, tcWriteMutVar,
 
-recoverTc use_this_if_err expr sw_chkr dtys subst uniqs_in errs_in src_loc
-  = case (expr sw_chkr dtys (pushSubstUndos subst) uniqs_in errs_in src_loc) of
-      TcSucceeded result subst_out errs_out -> 
-	(result, combineSubstUndos subst_out, errs_out)
+	rn4MtoTcM,
 
-      TcFailed subst_out errs_out ->
-	(use_this_if_err, undoSubstUndos subst_out, errs_out)
-	  -- Note that we return the *undone* substitution
-	  -- and the *incoming* UniqueSupply
+	-- For closure
+	MutableVar(..), _MutableArray
+  ) where
+
+
+import TcMLoop		( TcEnv, initEnv, TcMaybe )  -- We need the type TcEnv and an initial Env
+
+import Type		( Type(..), GenType )
+import TyVar		( TyVar(..), GenTyVar )
+import Usage		( Usage(..), GenUsage )
+import ErrUtils		( Error(..), Message(..), ErrCtxt(..),
+			  TcWarning(..), TcError(..), mkTcErr )
+
+import SST
+import RnMonad4
+import RnUtils		( GlobalNameMappers(..), GlobalNameMapper(..) )
+
+import Bag		( Bag, emptyBag, isEmptyBag,
+			  foldBag, unitBag, unionBags, snocBag )
+import FiniteMap	( FiniteMap, emptyFM )
+import Pretty		( Pretty(..), PrettyRep )
+import PprStyle		( PprStyle )
+import Outputable	( Outputable(..), NamedThing(..), ExportFlag )
+import Maybes		( MaybeErr(..) )
+import Name		( Name )
+import ProtoName	( ProtoName )
+import SrcLoc		( SrcLoc, mkUnknownSrcLoc )
+import UniqFM		( UniqFM, emptyUFM )
+import UniqSupply	( UniqSupply, getUnique, getUniques, splitUniqSupply )
+import Unique		( Unique )
+import Util
 
-recoverQuietlyTc use_this_if_err expr sw_chkr dtys subst uniqs_in errs_in src_loc
-  = (r2, s2, e2)
-  where
-    (r2, s2, e2)
-      = case (expr sw_chkr dtys (pushSubstUndos subst) uniqs_in errs_in src_loc) of
-          TcSucceeded result subst_out errs_out -> 
-	    (result, combineSubstUndos subst_out, errs_out)
-
-          TcFailed subst_out errs_out ->
-	    (use_this_if_err, undoSubstUndos subst_out, errs_in)
-	  -- Note that we return the *undone* substitution,
-	  -- the *incoming* UniqueSupply, and the *incoming* errors
+infixr 9 `thenTc`, `thenTc_`, `thenNF_Tc`, `thenNF_Tc_` 
 \end{code}
 
-The following @TcM@ checks a condition and fails with the given error
-message.
 
-\begin{code}
-checkTc :: Bool -> Error -> TcM ()
-
-checkTc True  err = failTc err
-checkTc False err = returnTc ()
-
-listTc :: [TcM a] -> TcM [a]
-
-listTc [] = returnTc []
-listTc (x:xs)
- = x		`thenTc` \ r ->
-   listTc xs	`thenTc` \ rs ->
-   returnTc (r:rs)
-
-mapTc :: (a -> TcM b) -> [a] -> TcM [b]
-mapTc f [] = returnTc []
-mapTc f (x:xs)
- = f x		`thenTc` \ r ->
-   mapTc f xs	`thenTc` \ rs ->
-   returnTc (r:rs)
-
-mapAndUnzipTc :: (a -> TcM (b, c)) -> [a] -> TcM ([b], [c])
-
-mapAndUnzipTc f [] = returnTc ([], [])
-mapAndUnzipTc f (x:xs)
- = f x			`thenTc` \ (r1,  r2)  ->
-   mapAndUnzipTc f xs	`thenTc` \ (rs1, rs2) ->
-   returnTc (r1:rs1, r2:rs2)
-
-foldlTc :: (a -> b -> TcM a) -> a -> [b] -> TcM a
-foldlTc f a []	   = returnTc a
-foldlTc f a (b:bs) = f a b	`thenTc` \ a2 ->
-		     foldlTc f a2 bs
-
-fixTc :: (x -> TcM x) -> TcM x
-fixTc m sw_chkr dtys subst us errs src_loc
-  = lim
-  where
-    lim    = m result sw_chkr dtys subst us errs src_loc
-    result = case lim of
-	       TcSucceeded result _ _ -> result
-#ifdef DEBUG
-	       TcFailed _ errs -> pprPanic "Failed in fixTc:\n" (pprBagOfErrors PprDebug errs)
-#endif
-\end{code}
-
-And the machinery to start things up:
+\section{TcM, NF_TcM: the type checker monads}
+%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 
 \begin{code}
-aRRAY_SIZE :: Int
-aRRAY_SIZE  = 511
-
-initTc	:: (GlobalSwitch -> Bool)
-	-> SplitUniqSupply
-	-> TcM result
-	-> MaybeErr result (Bag Error)
-
-initTc sw_chkr us tc
-  = case (tc sw_chkr [{-no defaults-}] init_subst us emptyBag mkUnknownSrcLoc) of
-      TcFailed _ errs -> Failed errs
-      TcSucceeded result subst2 errs
-	-> if isEmptyBag errs then
-	      Succeeded result
-	   else
-	      Failed errs
-
-init_subst = mkEmptySubst aRRAY_SIZE -- out here to avoid initTc CAF...sigh
+type NF_TcM s r =  TcDown s -> TcEnv s -> SST s r
+type TcM    s r =  TcDown s -> TcEnv s -> FSST s r ()
 \end{code}
 
-
-%************************************************************************
-%*									*
-\subsection[TcM-NF_TcM]{No-fail @NF_TcM@ monadery}
-%*									*
-%************************************************************************
-
-This is a no-fail version of a TcM.
-
 \begin{code}
--- ToDo: re-order fields to match TcM?
-type NF_TcM result = InTcM (result, Subst, Bag Error)
-
-#ifdef __GLASGOW_HASKELL__
-{-# INLINE thenNF_Tc #-}
-{-# INLINE thenLazilyNF_Tc #-}
-{-# INLINE returnNF_Tc #-}
-#endif
-
-thenNF_Tc, thenLazilyNF_Tc :: NF_TcM a -> (a -> InTcM b) -> InTcM b
--- ...Lazily... is purely a performance thing (WDP 95/09)
+-- With a builtin polymorphic type for _runSST the type for
+-- initTc should use  TcM s r  instead of  TcM _RealWorld r 
+
+initTc :: UniqSupply
+       -> TcM _RealWorld r
+       -> MaybeErr (r, Bag TcWarning)
+		   (Bag TcError, Bag  TcWarning)
+
+initTc us do_this
+  = _runSST (
+      newMutVarSST us 			`thenSST` \ us_var ->
+      newMutVarSST (emptyBag,emptyBag)	`thenSST` \ errs_var ->
+      newMutVarSST emptyUFM		`thenSST` \ tvs_var ->
+      let
+          init_down = TcDown [] us_var
+			     mkUnknownSrcLoc
+			     [] errs_var
+	  init_env  = initEnv tvs_var
+      in
+      recoverSST
+	(\_ -> returnSST Nothing)
+        (do_this init_down init_env `thenFSST` \ res ->
+	 returnFSST (Just res))
+      					`thenSST` \ maybe_res ->
+      readMutVarSST errs_var 		`thenSST` \ (warns,errs) ->
+      case (maybe_res, isEmptyBag errs) of
+        (Just res, True) -> returnSST (Succeeded (res, warns))
+	_ 		 -> returnSST (Failed (errs, warns))
+    )
+
+thenNF_Tc :: NF_TcM s a
+	  -> (a -> TcDown s -> TcEnv s -> State# s -> b)
+	  -> TcDown s -> TcEnv s -> State# s -> b
+-- thenNF_Tc :: NF_TcM s a -> (a -> NF_TcM s b) -> NF_TcM s b
+-- thenNF_Tc :: NF_TcM s a -> (a -> TcM s b)    -> TcM s b
+
+thenNF_Tc m k down env
+  = m down env	`thenSST` \ r ->
+    k r down env
+
+thenNF_Tc_ :: NF_TcM s a
+	   -> (TcDown s -> TcEnv s -> State# s -> b)
+	   -> TcDown s -> TcEnv s -> State# s -> b
+-- thenNF_Tc :: NF_TcM s a -> NF_TcM s b -> NF_TcM s b
+-- thenNF_Tc :: NF_TcM s a -> TcM s b    -> TcM s b
+
+thenNF_Tc_ m k down env
+  = m down env	`thenSST_` k down env
+
+returnNF_Tc :: a -> NF_TcM s a
+returnNF_Tc v down env = returnSST v
+
+mapNF_Tc    :: (a -> NF_TcM s b) -> [a] -> NF_TcM s [b]
+mapNF_Tc f []     = returnNF_Tc []
+mapNF_Tc f (x:xs) = f x			`thenNF_Tc` \ r ->
+		    mapNF_Tc f xs	`thenNF_Tc` \ rs ->
+		    returnNF_Tc (r:rs)
+
+listNF_Tc    :: [NF_TcM s a] -> NF_TcM s [a]
+listNF_Tc []     = returnNF_Tc []
+listNF_Tc (x:xs) = x			`thenNF_Tc` \ r ->
+		   listNF_Tc xs		`thenNF_Tc` \ rs ->
+		   returnNF_Tc (r:rs)
+
+mapBagNF_Tc :: (a -> NF_TcM s b) -> Bag a -> NF_TcM s (Bag b)
+mapBagNF_Tc f bag
+  = foldBag (\ b1 b2 -> b1 `thenNF_Tc` \ r1 -> 
+		        b2 `thenNF_Tc` \ r2 -> 
+		        returnNF_Tc (unionBags r1 r2))
+	    (\ a -> f a `thenNF_Tc` \ r -> returnNF_Tc (unitBag r))
+	    (returnNF_Tc emptyBag)
+	    bag
+
+mapAndUnzipNF_Tc    :: (a -> NF_TcM s (b,c)) -> [a]   -> NF_TcM s ([b],[c])
+mapAndUnzipNF_Tc f []     = returnNF_Tc ([],[])
+mapAndUnzipNF_Tc f (x:xs) = f x				`thenNF_Tc` \ (r1,r2) ->
+			    mapAndUnzipNF_Tc f xs	`thenNF_Tc` \ (rs1,rs2) ->
+			    returnNF_Tc (r1:rs1, r2:rs2)
+
+thenTc :: TcM s a -> (a -> TcM s b) -> TcM s b
+thenTc m k down env
+  = m down env	`thenFSST` \ r ->
+    k r down env
+
+thenTc_ :: TcM s a -> TcM s b -> TcM s b
+thenTc_ m k down env
+  = m down env	`thenFSST_`  k down env
+
+returnTc :: a -> TcM s a
+returnTc val down env = returnFSST val
+
+mapTc    :: (a -> TcM s b) -> [a]   -> TcM s [b]
+mapTc f []     = returnTc []
+mapTc f (x:xs) = f x		`thenTc` \ r ->
+		 mapTc f xs	`thenTc` \ rs ->
+		 returnTc (r:rs)
+
+listTc    :: [TcM s a] -> TcM s [a]
+listTc []     = returnTc []
+listTc (x:xs) = x			`thenTc` \ r ->
+		listTc xs		`thenTc` \ rs ->
+		returnTc (r:rs)
+
+foldrTc :: (a -> b -> TcM s b) -> b -> [a] -> TcM s b
+foldrTc k z []     = returnTc z
+foldrTc k z (x:xs) = foldrTc k z xs	`thenTc` \r ->
+		     k x r
+
+foldlTc :: (a -> b -> TcM s a) -> a -> [b] -> TcM s a
+foldlTc k z []     = returnTc z
+foldlTc k z (x:xs) = k z x		`thenTc` \r ->
+		     foldlTc k r xs
+
+mapAndUnzipTc    :: (a -> TcM s (b,c)) -> [a]   -> TcM s ([b],[c])
+mapAndUnzipTc f []     = returnTc ([],[])
+mapAndUnzipTc f (x:xs) = f x			`thenTc` \ (r1,r2) ->
+			 mapAndUnzipTc f xs	`thenTc` \ (rs1,rs2) ->
+			 returnTc (r1:rs1, r2:rs2)
+
+mapAndUnzip3Tc    :: (a -> TcM s (b,c,d)) -> [a] -> TcM s ([b],[c],[d])
+mapAndUnzip3Tc f []     = returnTc ([],[],[])
+mapAndUnzip3Tc f (x:xs) = f x			`thenTc` \ (r1,r2,r3) ->
+			  mapAndUnzip3Tc f xs	`thenTc` \ (rs1,rs2,rs3) ->
+			  returnTc (r1:rs1, r2:rs2, r3:rs3)
+
+mapBagTc :: (a -> TcM s b) -> Bag a -> TcM s (Bag b)
+mapBagTc f bag
+  = foldBag (\ b1 b2 -> b1 `thenTc` \ r1 -> 
+		        b2 `thenTc` \ r2 -> 
+		        returnTc (unionBags r1 r2))
+	    (\ a -> f a `thenTc` \ r -> returnTc (unitBag r))
+	    (returnTc emptyBag)
+	    bag
+
+fixTc :: (a -> TcM s a) -> TcM s a
+fixTc m env down = fixFSST (\ loop -> m loop env down)
 \end{code}
 
-In particular, @thenNF_Tc@ has all of these types:
+@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!
+
 \begin{pseudocode}
-thenNF_Tc :: NF_TcM a -> (a -> TcM b)	 -> TcM b
-thenNF_Tc :: NF_TcM a -> (a -> NF_TcM b) -> NF_TcM b
+forkNF_Tc :: NF_TcM s r -> NF_TcM s r
+forkNF_Tc m down env
+  = forkTcDown down	`thenSST` \ down' ->
+    returnSST (_runSST (m down' (forkTcEnv env)))
 \end{pseudocode}
 
-\begin{code}
-thenNF_Tc expr cont sw_chkr dtys subst us errs src_loc
-  = case splitUniqSupply us	    of { (s1, s2) ->
-    case (expr sw_chkr dtys subst s1 errs src_loc) of
-     (result, subst2, errs2)
-       -> cont result sw_chkr dtys subst2 s2 errs2 src_loc
-    }
-
-thenLazilyNF_Tc expr cont sw_chkr dtys subst us errs src_loc
-  = let
-	(s1, s2) = splitUniqSupply us
-    in
-    case (expr sw_chkr dtys subst s1 errs src_loc) of {
-     (result, subst2, errs2)
-       -> cont result sw_chkr dtys subst2 s2 errs2 src_loc
-    }
-
-returnNF_Tc :: a -> NF_TcM a
-returnNF_Tc result sw_chkr dtys subst us errs src_loc
-  = (result, subst, errs)
-
-listNF_Tc :: [NF_TcM a] -> NF_TcM [a]
-listNF_Tc [] = returnNF_Tc []
-listNF_Tc (x:xs)
-  = x			`thenNF_Tc` \ r ->
-    listNF_Tc xs	`thenNF_Tc` \ rs ->
-    returnNF_Tc (r:rs)
-
-mapNF_Tc :: (a -> NF_TcM b) -> [a] -> NF_TcM [b]
-mapNF_Tc f [] = returnNF_Tc []
-mapNF_Tc f (x:xs)
-  = f x			`thenNF_Tc` \ r ->
-    mapNF_Tc f xs	`thenNF_Tc` \ rs ->
-    returnNF_Tc (r:rs)
-
-fixNF_Tc :: (a -> NF_TcM a) -> NF_TcM a
-fixNF_Tc m sw_chkr dtys subst us errs src_loc
-  = lim
-  where
-    lim = m result sw_chkr dtys subst us errs src_loc
-    (result, _, _) = lim
-\end{code}
-
-@noFailTc@ takes a \tr{TcM a} and returns a \tr{NF_TcM a}.  You use it
-when you are darn sure that the TcM won't actually fail!
-
-\begin{code}
-noFailTc :: TcM a -> NF_TcM a
-
-noFailTc expr sw_chkr dtys subst us errs src_loc
-  = case (expr sw_chkr dtys subst us errs src_loc) of
-      TcFailed _ _ -> panic "Failure in noFailTc!"
-      TcSucceeded result subst errs
-    	-> (result, subst, errs)
-\end{code}
-
-%************************************************************************
-%*									*
-\subsection[TcM-uniq-extract]{Extractings Uniques from the monad}
-%*									*
-%************************************************************************
-
-These functions extract uniques from the monad. There are two unique
-supplies embedded in the monad.
-\begin{itemize}
-\item
-normal unique supply
-\item
-special unique supply for TyVars (these index the substitution)
-\end{itemize}
 
+Error handling
+~~~~~~~~~~~~~~
 \begin{code}
-getUniquesTc :: Int -> NF_TcM [Unique]
-getUniquesTc n sw_chkr dtys subst us errs src_loc
-  = case (getSUniques n us) of { uniques ->
-    (uniques, subst, errs) }
-
--- This simpler version is often adequate:
-
-getUniqueTc :: NF_TcM Unique
-getUniqueTc sw_chkr dtys subst us errs src_loc
-  = case (getSUnique us) of { unique ->
-    (unique, subst, errs) }
-
-rn4MtoTcM :: GlobalNameFuns -> Rn4M a -> NF_TcM (a, Bag Error)
-
-rn4MtoTcM name_funs rn_action sw_chkr dtys subst us errs src_loc
-  = let
-	(rn_result, rn_errs)
-	  = rn_action sw_chkr name_funs emptyFM emptyBag us mkUnknownSrcLoc
-	    -- laziness may be good for you (see below)
+failTc :: Message -> TcM s a
+failTc err_msg down env
+  = readMutVarSST errs_var				`thenSST` \ (warns,errs) ->
+    foldr thenNF_Tc_ (returnNF_Tc []) ctxt down env	`thenSST` \ ctxt_msgs ->
+    let
+	err = mkTcErr loc ctxt_msgs err_msg
     in
-    ((rn_result, rn_errs), subst, errs)
-
--- Special uniques for TyVars extracted from the substitution
-
-getTyVarUniquesTc :: Int -> NF_TcM [Unique]
-getTyVarUniquesTc n sw_chkr dtys subst us errs src_loc
-  = returnNF_Tc uniques sw_chkr dtys subst2 us errs src_loc
+    writeMutVarSST errs_var (warns, errs `snocBag` err)	`thenSST_`
+    failFSST ()
   where
-    (subst2, uniques) = getSubstTyVarUniques n subst
-
-getTyVarUniqueTc :: NF_TcM Unique
-getTyVarUniqueTc sw_chkr dtys subst us errs src_loc
-  = returnNF_Tc unique sw_chkr dtys subst2 us errs src_loc
+    errs_var = getTcErrs down
+    ctxt     = getErrCtxt down
+    loc      = getLoc down
+
+warnTc :: Bool -> Message -> NF_TcM s ()
+warnTc warn_if_true warn down env
+  = if warn_if_true then
+	readMutVarSST errs_var					`thenSST` \ (warns,errs) ->
+	writeMutVarSST errs_var (warns `snocBag` warn, errs) 	`thenSST_`
+    	returnSST ()
+    else
+	returnSST ()
   where
-    (subst2, unique) = getSubstTyVarUnique subst
+    errs_var = getTcErrs down
+
+recoverTc :: TcM s r -> TcM s r -> TcM s r
+recoverTc recover m down env
+  = recoverFSST (\ _ -> recover down env) (m down env)
+
+recoverNF_Tc :: NF_TcM s r -> TcM s r -> NF_TcM s r
+recoverNF_Tc recover m down env
+  = recoverSST (\ _ -> recover down env) (m down env)
+
+-- (tryTc r m) tries m; if it succeeds it returns it,
+-- otherwise it returns r.  Any error messages added by m are discarded,
+-- whether or not m succeeds.
+tryTc :: TcM s r -> TcM s r -> TcM s r
+tryTc recover m down env
+  = recoverFSST (\ _ -> recover down env) $
+    newMutVarSST (emptyBag,emptyBag)	`thenSST` \ new_errs_var ->
+    m (setTcErrs down new_errs_var) env
+
+checkTc :: Bool -> Message -> TcM s ()		-- Check that the boolean is true
+checkTc True  err = returnTc ()
+checkTc False err = failTc err
+
+checkTcM :: Bool -> TcM s () -> TcM s ()	-- Check that the boolean is true
+checkTcM True  err = returnTc ()
+checkTcM False err = err
+
+checkMaybeTc :: Maybe val -> Message -> TcM s val
+checkMaybeTc (Just val) err = returnTc val
+checkMaybeTc Nothing    err = failTc err
+
+checkMaybeTcM :: Maybe val -> TcM s val -> TcM s val
+checkMaybeTcM (Just val) err = returnTc val
+checkMaybeTcM Nothing    err = err
 \end{code}
 
-%************************************************************************
-%*									*
-\subsection[TcM-extract]{Extractings other things from the monad}
-%*									*
-%************************************************************************
-
-These are functions which extract things from the monad.
-
-Extending and applying the substitution.
-
-ToDo: Unify.lhs BackSubst.lhs Id.lhs Inst.lhs: The TcMonad is used in
-a number of places where only the sequenced substitution is required.
-A lighter weight sequence substitution monad would be more appropriate
-with TcMonad interface functions defined here.
-
+Mutable variables
+~~~~~~~~~~~~~~~~~
 \begin{code}
-getTcSubst  	      ::	      NF_TcM Subst
-applyTcSubstToTy      :: TauType   -> NF_TcM TauType     
---UNUSED:applyTcSubstToThetaTy :: ThetaType -> NF_TcM ThetaType 
-applyTcSubstToTyVar   :: TyVar     -> NF_TcM TauType
-applyTcSubstToId      :: Id	   -> NF_TcM Id
-applyTcSubstToInst    :: Inst	   -> NF_TcM Inst
-
-getTcSubst sw_chkr dtys subst us errs src_loc
-  = returnNF_Tc subst sw_chkr dtys subst us errs src_loc
-
-applyTcSubstToTy ty sw_chkr dtys subst us errs src_loc
-  = case (applySubstToTy subst ty) of { (subst2, new_tau_ty) ->
-    returnNF_Tc new_tau_ty sw_chkr dtys subst2 us errs src_loc
-    }
-
-{- UNUSED:
-applyTcSubstToThetaTy theta_ty sw_chkr dtys subst us errs src_loc
-  = case (applySubstToThetaTy subst theta_ty) of { (subst2, new_theta_ty) ->
-    returnNF_Tc new_theta_ty sw_chkr dtys subst2 us errs src_loc
-    }
--}
-
-applyTcSubstToTyVar tyvar sw_chkr dtys subst us errs src_loc
-  = case (applySubstToTyVar subst tyvar) of { (subst2, new_tau_ty) ->
-    returnNF_Tc new_tau_ty sw_chkr dtys subst2 us errs src_loc
-    }
-
-applyTcSubstToId tyvar sw_chkr dtys subst us errs src_loc
-  = case (applySubstToId subst tyvar) of { (subst2, new_tau_ty) ->
-    returnNF_Tc new_tau_ty sw_chkr dtys subst2 us errs src_loc
-    }
-
-applyTcSubstToInst inst sw_chkr dtys subst us errs src_loc
-  = case (applySubstToInst subst inst) of { (subst2, new_inst) ->
-    returnNF_Tc new_inst sw_chkr dtys subst2 us errs src_loc
-    }
-
-applyTcSubstToTyVars :: [TyVar]   -> NF_TcM [UniType]
-applyTcSubstToTys    :: [TauType] -> NF_TcM [TauType]
-
-applyTcSubstToTyVars tyvars = mapNF_Tc applyTcSubstToTyVar tyvars
-applyTcSubstToTys    tys    = mapNF_Tc applyTcSubstToTy    tys
-applyTcSubstToInsts  insts  = mapNF_Tc applyTcSubstToInst  insts
-\end{code}
+tcNewMutVar :: a -> NF_TcM s (MutableVar s a)
+tcNewMutVar val down env = newMutVarSST val
 
-\begin{code}
-extendSubstTc :: TyVar -> UniType -> UnifyErrContext -> TcM ()
-
-extendSubstTc tyvar ty err_ctxt sw_chkr dtys subst us errs src_loc
-  = case (extendSubst tyvar ty subst) of { (new_subst, extend_result) ->
-    case extend_result of
-      SubstOK ->
-	TcSucceeded () new_subst errs
-
-      OccursCheck tyvar ty ->
-	TcFailed new_subst
-		 (errs `snocBag` (unifyErr (TypeRec tyvar ty) err_ctxt src_loc))
-
-      AlreadyBound ty1 ->
-	    -- This should only happen in the case of a call to
-	    -- extendSubstTc from the unifier!  The way things are now
-	    -- we can't check for the AlreadyBound case in other calls
-	    -- to extendSubstTc, but we're confident it never shows up.
-	    -- Ugh!
-	unifyTauTy ty1 ty err_ctxt sw_chkr dtys new_subst us errs src_loc
-    }
+tcWriteMutVar :: MutableVar s a -> a -> NF_TcM s ()
+tcWriteMutVar var val down env = writeMutVarSST var val
+
+tcReadMutVar :: MutableVar s a -> NF_TcM s a
+tcReadMutVar var down env = readMutVarSST var
 \end{code}
 
 
-@pruneSubstTc@ does nothing with an array substitution implementation!!!
+Environment
+~~~~~~~~~~~
 \begin{code}
-pruneSubstTc :: [TyVar] -- Type vars whose substitutions should be kept
-	     -> TcM a	-- Type-check this
-	     -> TcM a	-- Return same result but pruned subst
+tcGetEnv :: NF_TcM s (TcEnv s)
+tcGetEnv down env = returnSST env
 
-pruneSubstTc keep_tyvars m sw_chkr dtys subst uniqs errs src_loc
-  = m sw_chkr dtys subst uniqs errs src_loc
+tcSetEnv :: TcEnv s -> TcM s a -> TcM s a
+tcSetEnv new_env m down old_env = m down new_env
 \end{code}
 
-\begin{code}
-getSwitchCheckerTc :: NF_TcM (GlobalSwitch -> Bool)
-getSwitchCheckerTc sw_chkr = returnNF_Tc sw_chkr sw_chkr
-\end{code}
 
+Source location
+~~~~~~~~~~~~~~~
 \begin{code}
-getDefaultingTys :: NF_TcM [UniType]
-getDefaultingTys sw_chkr dtys = returnNF_Tc dtys sw_chkr dtys
+tcGetDefaultTys :: NF_TcM s [Type]
+tcGetDefaultTys down env = returnSST (getDefaultTys down)
 
-setDefaultingTys :: [UniType] -> TcM a -> TcM a
-setDefaultingTys dtys action sw_chkr _ subst us errs src_loc
-  = action sw_chkr dtys subst us errs src_loc
-\end{code}
-
-\begin{code}
-addSrcLocTc :: SrcLoc -> TcM a -> TcM a
-addSrcLocTc new_locn expr sw_chkr dtys subst us errs src_loc
-  = expr sw_chkr dtys subst us errs new_locn
+tcSetDefaultTys :: [Type] -> TcM s r -> TcM s r
+tcSetDefaultTys tys m down env = m (setDefaultTys down tys) env
 
-getSrcLocTc :: NF_TcM SrcLoc
-getSrcLocTc sw_chkr dtys subst us errs src_loc
-  = (src_loc, subst, errs)
-\end{code}
+tcAddSrcLoc :: SrcLoc -> TcM s a -> TcM s a
+tcAddSrcLoc loc m down env = m (setLoc down loc) env
 
-%************************************************************************
-%*									*
-\subsection[TcM-check]{Error-detecting functions}
-%*									*
-%************************************************************************
+tcGetSrcLoc :: NF_TcM s SrcLoc
+tcGetSrcLoc down env = returnSST (getLoc down)
 
-The following TcM checks a Maybe type and fails with the given
-error message.
+tcSetErrCtxtM, tcAddErrCtxtM :: NF_TcM s Message -> TcM s a -> TcM s a
+tcSetErrCtxtM msg m down env = m (setErrCtxt down msg) env
+tcAddErrCtxtM msg m down env = m (addErrCtxt down msg) env
 
-\begin{code}
-checkMaybeTc :: Maybe val -> Error -> TcM val
-checkMaybeTc (Just result) err = returnTc result
-checkMaybeTc Nothing	   err = failTc	  err
-
-checkMaybesTc :: [Maybe val] -> Error -> TcM [val]
-checkMaybesTc []	    err = returnTc []
-checkMaybesTc (Nothing:xs)  err = failTc   err
-checkMaybesTc ((Just v):xs) err
-  = checkMaybesTc xs err `thenTc` \ xs2 ->
-    returnTc (v:xs2)
-
-checkMaybeErrTc :: MaybeErr val err -> (err -> Error) -> TcM val
-checkMaybeErrTc (Succeeded result) errfun = returnTc result
-checkMaybeErrTc (Failed err)	   errfun = failTc (errfun err)
-
-{- UNUSED:
-checkMaybeErrsTc :: [MaybeErr val err] -> (err -> Error) -> TcM [val]
-
-checkMaybeErrsTc []		    err_fun = returnTc []
-checkMaybeErrsTc ((Failed err) :xs) err_fun = failTc (err_fun err)
-checkMaybeErrsTc ((Succeeded v):xs) err_fun
-  = checkMaybeErrsTc xs err_fun `thenTc` \ xs2 ->
-    returnTc (v:xs2)
--}
+tcSetErrCtxt, tcAddErrCtxt :: Message -> TcM s a -> TcM s a
+tcSetErrCtxt msg m down env = m (setErrCtxt down (returnNF_Tc msg)) env
+tcAddErrCtxt msg m down env = m (addErrCtxt down (returnNF_Tc msg)) env
 \end{code}
 
-%************************************************************************
-%*									*
-\subsection[TcM-Insts]{Looking up instances}
-%*									*
-%************************************************************************
 
+Unique supply
+~~~~~~~~~~~~~
 \begin{code}
-lookupInst_Tc :: Inst -> TcM (TypecheckedExpr, [Inst])
-
-lookupInst_Tc inst sw_chkr dtys subst uniqs errs src_loc
-  = case (lookupInst uniqs inst) of
-      Nothing -> TcFailed subst (errs `snocBag` (noInstanceErr inst))
-
-      Just (expr, insts) -> TcSucceeded (expr, insts) subst errs
-
-lookupNoBindInst_Tc :: Inst -> TcM [Inst]
-
-lookupNoBindInst_Tc inst sw_chkr dtys subst uniqs errs src_loc
-  = case (lookupNoBindInst uniqs inst) of
-      Nothing -> TcFailed subst (errs `snocBag` (noInstanceErr inst))
-
-      Just insts -> TcSucceeded insts subst errs
+tcGetUnique :: NF_TcM s Unique
+tcGetUnique down env
+  = readMutVarSST u_var				`thenSST` \ uniq_supply ->
+    let
+      (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply
+      uniq			= getUnique uniq_s
+    in
+    writeMutVarSST u_var new_uniq_supply		`thenSST_`
+    returnSST uniq
+  where
+    u_var = getUniqSupplyVar down
+
+tcGetUniques :: Int -> NF_TcM s [Unique]
+tcGetUniques n down env
+  = readMutVarSST u_var				`thenSST` \ uniq_supply ->
+    let
+      (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply
+      uniqs			= getUniques n uniq_s
+    in
+    writeMutVarSST u_var new_uniq_supply		`thenSST_`
+    returnSST uniqs
+  where
+    u_var = getUniqSupplyVar down
 \end{code}
 
 
-
-
-
-
-
-%************************************************************************
-%*									*
-\subsection[Baby_TcM]{``Baby'' @TcM@ monadery---when we don't need the full bang}
-%*									*
-%************************************************************************
-
-The "baby" Tc monad doesn't pass around the substitution.
-That means you can't use it to type-check bindings, but you can use
-if for everything else (interfaces, type decls, first pass of class and
-instance decls etc).
-
-Less importantly, it doesn't pass around the list of default decls either.
-
-
-Type declarations
-~~~~~~~~~~~~~~~~~
+\section{TcDown}
+%~~~~~~~~~~~~~~~
 
 \begin{code}
-type Baby_TcM result
-	=  (GlobalSwitch -> Bool)
-	-> SplitUniqSupply
-	-> Bag Error			-- threaded
-	-> SrcLoc			-- only passed downwards
-	-> Baby_TcResult result
+data TcDown s
+  = TcDown
+	[Type]				-- Types used for defaulting
 
-data Baby_TcResult result
-  = BabyTcFailed    (Bag Error)
+	(MutableVar s UniqSupply)	-- Unique supply
 
-  | BabyTcSucceeded result (Bag Error)
-\end{code}
+	SrcLoc				-- Source location
+	(ErrCtxt s)			-- Error context
+	(MutableVar s (Bag TcWarning, 
+		       Bag TcError))
 
+type ErrCtxt s = [NF_TcM s Message]	-- Innermost first.  Monadic so that we have a chance
+					-- to deal with bound type variables just before error
+					-- message construction
+\end{code}
 
-Standard plumbing
-~~~~~~~~~~~~~~~~~
+-- These selectors are *local* to TcMonad.lhs
 
 \begin{code}
-thenB_Tc   :: Baby_TcM a -> (a -> Baby_TcM b) -> Baby_TcM b
-returnB_Tc :: a -> Baby_TcM a
-
-#ifdef __GLASGOW_HASKELL__
-{-# INLINE thenB_Tc #-}
-{-# INLINE returnB_Tc #-}
-#endif
-
-thenB_Tc a b sw us errs loc
-  = case (splitUniqSupply us) of { (s1, s2) ->
-    case (a sw s1 errs loc) of
-      BabyTcFailed errs2          -> BabyTcFailed errs2
-      BabyTcSucceeded a_res errs2 -> b a_res sw s2 errs2 loc
-    }
-
-returnB_Tc result sw us errs loc = BabyTcSucceeded result errs
-failB_Tc   err    sw us errs loc = BabyTcFailed (errs `snocBag` err)
-
-recoverIgnoreErrorsB_Tc return_on_failure try_this sw us errs loc
-  = BabyTcSucceeded result errs
-  where
-    result = case try_this sw us emptyBag loc of
-		BabyTcSucceeded result errs_from_branch -> result
-		BabyTcFailed errs_from_branch 	        -> return_on_failure
+getTcErrs (TcDown def us loc ctxt errs)      = errs
+setTcErrs (TcDown def us loc ctxt _   ) errs = TcDown def us loc ctxt errs
 
-fixB_Tc :: (a -> Baby_TcM a) -> Baby_TcM a
-fixB_Tc k sw us errs loc
-  = result
-  where
-    result = k val sw us errs loc
-    val = case result of
-	    BabyTcSucceeded val errs -> val
-	    BabyTcFailed errs	     -> panic "fixB_Tc failed"
-
-babyTcMtoTcM :: Baby_TcM a -> TcM a
-babyTcMtoTcM m sw_chkr dtys subst us errs src_loc
-  = case m sw_chkr us errs src_loc of
-	BabyTcSucceeded result errs2 -> TcSucceeded result subst errs2
-	BabyTcFailed errs2	     -> TcFailed subst errs2
-
-babyTcMtoNF_TcM :: Baby_TcM a -> NF_TcM a
-babyTcMtoNF_TcM m sw_chkr dtys subst us errs src_loc
-  = case m sw_chkr us errs src_loc of
-	BabyTcSucceeded result errs2 -> (result, subst, errs2)
-	BabyTcFailed errs2	     -> panic "babyTcMtoNF_TcM"
-\end{code}
+getDefaultTys (TcDown def us loc ctxt errs)     = def
+setDefaultTys (TcDown _   us loc ctxt errs) def = TcDown def us loc ctxt errs
 
-\begin{code}
-uniqSMtoBabyTcM :: SUniqSM a -> Baby_TcM a
+getLoc (TcDown def us loc ctxt errs)     = loc
+setLoc (TcDown def us _   ctxt errs) loc = TcDown def us loc ctxt errs
 
-uniqSMtoBabyTcM u_action sw us errs loc
-  = let
-	u_result = u_action us
-	-- at least one use *needs* this laziness
-    in
-    BabyTcSucceeded u_result errs
-\end{code}
+getUniqSupplyVar (TcDown def us loc ctxt errs) = us
 
-\begin{code}
-thenB_Tc_ m k = m `thenB_Tc` \ _ -> 
-		k
-
-mapB_Tc :: (a -> Baby_TcM b) -> [a] -> Baby_TcM [b]
-mapB_Tc f []     = returnB_Tc []
-mapB_Tc f (x:xs) = f x		`thenB_Tc` \ fx -> 
-		   mapB_Tc f xs	`thenB_Tc` \ fxs -> 
-		   returnB_Tc (fx:fxs)
+setErrCtxt (TcDown def us loc ctxt errs) msg = TcDown def us loc [msg]      errs
+addErrCtxt (TcDown def us loc ctxt errs) msg = TcDown def us loc (msg:ctxt) errs
+getErrCtxt (TcDown def us loc ctxt errs)     = ctxt
 \end{code}
 
-
-Primitives
-~~~~~~~~~~
+@forkTcDown@ makes a new "down" blob for a lazily-computed fork
+of the type checker.
 
 \begin{code}
-getUniqueB_Tc  :: Baby_TcM Unique
-getUniquesB_Tc :: Int -> Baby_TcM [Unique]
-
-getUniqueB_Tc sw us errs loc
-  = case (getSUnique us) of { unique ->
-    BabyTcSucceeded unique errs }
-
-getUniquesB_Tc n sw us errs loc
-  = case (getSUniques n us) of { uniques ->
-    BabyTcSucceeded uniques errs }
-
-addSrcLocB_Tc :: SrcLoc -> Baby_TcM a -> Baby_TcM a
-addSrcLocB_Tc new_locn m sw us errs loc
-  = m sw us errs new_locn
+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_`
 
-getSrcLocB_Tc sw us errs loc = BabyTcSucceeded loc errs
+	-- Make fresh MutVars for the unique supply and errors
+    newMutVarSST us2			`thenSST` \ u_var' ->
+    newMutVarSST (emptyBag, emptyBag)	`thenSST` \ err_var' ->
 
-getSwitchCheckerB_Tc :: Baby_TcM (GlobalSwitch -> Bool)
-getSwitchCheckerB_Tc sw_chkr us errs loc = BabyTcSucceeded sw_chkr errs
+	-- Done
+    returnSST (TcDown deflts u_var' src_loc err_cxt err_var')
 \end{code}
 
 
-Useful functions
-~~~~~~~~~~~~~~~~
+\section{rn4MtoTcM}
+%~~~~~~~~~~~~~~~~~~
 
 \begin{code}
-checkB_Tc :: Bool -> Error -> Baby_TcM ()
+rn4MtoTcM :: GlobalNameMappers -> Rn4M a -> NF_TcM s (a, Bag Error)
 
-checkB_Tc True  err = failB_Tc err
-checkB_Tc False err = returnB_Tc ()
+rn4MtoTcM name_funs 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_action name_funs emptyFM emptyBag uniq_s mkUnknownSrcLoc
+    in
+    returnSST (rn_result, rn_errs)
+  where
+    u_var = getUniqSupplyVar down
 \end{code}
diff --git a/ghc/compiler/typecheck/TcMonadFns.hi b/ghc/compiler/typecheck/TcMonadFns.hi
deleted file mode 100644
index 4786266f97..0000000000
--- a/ghc/compiler/typecheck/TcMonadFns.hi
+++ /dev/null
@@ -1,73 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface TcMonadFns where
-import Bag(Bag)
-import Class(Class, ClassOp)
-import CmdLineOpts(GlobalSwitch)
-import ErrUtils(Error(..))
-import ErrsTc(UnifyErrContext)
-import HsBinds(Bind, Binds, MonoBinds, Sig)
-import HsExpr(ArithSeqInfo, Expr)
-import HsLit(Literal)
-import HsMatches(GRHSsAndBinds, Match)
-import HsPat(InPat, TypecheckedPat)
-import Id(Id)
-import IdInfo(IdInfo, SpecEnv, SpecInfo)
-import Inst(Inst, InstOrigin, OverloadedLit)
-import InstEnv(InstTemplate)
-import Maybes(Labda)
-import Name(Name)
-import NameTypes(FullName, ShortName)
-import PreludePS(_PackedString)
-import PreludeRatio(Ratio(..))
-import Pretty(PprStyle, Pretty(..), PrettyRep)
-import SplitUniq(SplitUniqSupply)
-import SrcLoc(SrcLoc)
-import Subst(Subst)
-import TcMonad(TcResult)
-import TyCon(TyCon)
-import TyVar(TyVar, TyVarTemplate)
-import UniType(UniType)
-import Unique(Unique, UniqueSupply)
-data Bag a 
-data Class 
-type Error = PprStyle -> Int -> Bool -> PrettyRep
-data UnifyErrContext 
-data Binds a b 
-data MonoBinds a b 
-data TypecheckedPat 
-data Id 
-data SpecInfo 
-data Inst 
-data InstOrigin 
-data OverloadedLit 
-data Labda a 
-data Name 
-data PprStyle 
-type Pretty = Int -> Bool -> PrettyRep
-data PrettyRep 
-data SrcLoc 
-data Subst 
-data TcResult a 
-data TyVar 
-data UniType 
-data UniqueSupply 
-applyTcSubstAndCollectTyVars :: [TyVar] -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> ([TyVar], Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep))
-applyTcSubstAndExpectTyVars :: [TyVar] -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> ([TyVar], Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep))
-copyTyVars :: [TyVarTemplate] -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> (([(TyVarTemplate, UniType)], [TyVar], [UniType]), Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep))
-mkIdsWithGivenTys :: [Name] -> [UniType] -> [IdInfo] -> [(Name, Id)]
-mkIdsWithOpenTyVarTys :: [Name] -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> ([(Name, Id)], Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep))
-mkIdsWithPolyTyVarTys :: [Name] -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> ([(Name, Id)], Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep))
-newClassOpLocals :: [(TyVarTemplate, UniType)] -> [ClassOp] -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> ([Id], Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep))
-newDict :: InstOrigin -> Class -> UniType -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> (Inst, Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep))
-newDicts :: InstOrigin -> [(Class, UniType)] -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> ([Inst], Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep))
-newLocalWithGivenTy :: Name -> UniType -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> (Id, Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep))
-newLocalsWithOpenTyVarTys :: [Name] -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> ([Id], Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep))
-newLocalsWithPolyTyVarTys :: [Name] -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> ([Id], Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep))
-newMethod :: InstOrigin -> Id -> [UniType] -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> (Inst, Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep))
-newOpenTyVarTy :: (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> (UniType, Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep))
-newOverloadedLit :: InstOrigin -> OverloadedLit -> UniType -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> (Inst, Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep))
-newPolyTyVarTy :: (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> (UniType, Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep))
-newPolyTyVarTys :: Int -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> ([UniType], Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep))
-newSpecId :: Id -> [Labda UniType] -> UniType -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> (Id, Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep))
-newSpecPragmaId :: Name -> UniType -> Labda SpecInfo -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> (Id, Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep))
-
diff --git a/ghc/compiler/typecheck/TcMonadFns.lhs b/ghc/compiler/typecheck/TcMonadFns.lhs
deleted file mode 100644
index a15f7c6857..0000000000
--- a/ghc/compiler/typecheck/TcMonadFns.lhs
+++ /dev/null
@@ -1,244 +0,0 @@
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
-%
-\section[TcMonadFns]{Auxilliary functions for typechecker monad}
-
-\begin{code}
-#include "HsVersions.h"
-
-module TcMonadFns (
-	newDict, newDicts, newMethod, newOverloadedLit,
-
-	copyTyVars,
-	newOpenTyVarTy, newPolyTyVarTy,
-	newPolyTyVarTys,
-
---UNUSED:	newLocalWithOpenTyVarTy, newLocalWithPolyTyVarTy,
-	newLocalWithGivenTy,
-	newSpecPragmaId, newSpecId,
-	newClassOpLocals,
-	newLocalsWithOpenTyVarTys, newLocalsWithPolyTyVarTys,
-
-	mkIdsWithOpenTyVarTys, mkIdsWithPolyTyVarTys,
-	mkIdsWithGivenTys,
-
-	applyTcSubstAndCollectTyVars,
-	applyTcSubstAndExpectTyVars,
-
-	-- and to make the interface self-sufficient...
-	Bag, Class, Binds, MonoBinds, TypecheckedPat, Id, Inst, SpecInfo,
-	OverloadedLit, InstOrigin, TcResult, Name, SrcLoc, Subst, Maybe,
-	Error(..), TyVar, UniType, UnifyErrContext, UniqueSupply,
-	PprStyle, Pretty(..), PrettyRep
-    ) where
-
-import TcMonad		-- the underlying monadery
-import AbsSyn
-
-import AbsUniType
-import Id		( mkId, mkUserLocal, mkSpecPragmaId, mkSpecId,
-			  selectIdInfoForSpecId, Id, DictVar(..) )
-import IdInfo
-import Inst		( mkDict, mkMethod, mkLitInst,
-			  Inst(..), -- .. for pragmas
-			  OverloadedLit, InstOrigin
-			)
-import Maybes		( Maybe(..) )
-import E		( LVE(..) )
-import Errors		( Error(..), UnifyErrInfo )
-import Unique		( Unique, UniqueSupply )
-import Util
-\end{code}
-
-%************************************************************************
-%*									*
-\subsection[TcMonadFns-newNameThings]{Making new things from the name supply}
-%*									*
-%************************************************************************
-
-@newPolyTyVars@ takes list of ``old'' template type vars, and manufactures 
-a list of freshly-uniqued type vars.
-
-\begin{code}
-copyTyVars :: [TyVarTemplate]		-- Old type vars
-	   -> NF_TcM
-		([(TyVarTemplate,TauType)],--Old-to-new assoc list
-		 [TyVar],		-- New type vars
-		 [TauType])		-- New type vars wrapped in a UniTyVar
-
-copyTyVars old_tyvars
-  = getTyVarUniquesTc (length old_tyvars) `thenNF_Tc` \ new_uniqs ->
-    returnNF_Tc (instantiateTyVarTemplates old_tyvars new_uniqs)
-
-newOpenTyVarTys :: Int -> NF_TcM [UniType]
-newOpenTyVarTys n
-  = getTyVarUniquesTc n	`thenLazilyNF_Tc` \ new_uniqs ->
-    returnNF_Tc [mkTyVarTy (mkOpenSysTyVar u) | u <- new_uniqs]
-
-newPolyTyVarTys :: Int -> NF_TcM [UniType]
-newPolyTyVarTys n
-  = getTyVarUniquesTc n	`thenLazilyNF_Tc` \ new_uniqs ->
-    returnNF_Tc [mkTyVarTy (mkPolySysTyVar u) | u <- new_uniqs]
-
-newOpenTyVarTy, newPolyTyVarTy :: NF_TcM UniType
-newOpenTyVarTy
-  = getTyVarUniqueTc `thenLazilyNF_Tc` \ new_uniq ->
-    returnNF_Tc (mkTyVarTy (mkOpenSysTyVar new_uniq))
-
-newPolyTyVarTy
-  = getTyVarUniqueTc `thenLazilyNF_Tc` \ new_uniq ->
-    returnNF_Tc (mkTyVarTy (mkPolySysTyVar new_uniq))
-\end{code}
-
-The functions @newDicts@, @newMethod@, and @newOverloadedLit@ build
-new @Inst@s.
-  
-\begin{code}
-newDicts :: InstOrigin -> ThetaType -> NF_TcM [Inst]
-newDicts orig theta
- = getUniquesTc (length theta)		`thenNF_Tc` \ new_uniqs ->
-   returnNF_Tc (zipWith mk_dict_var new_uniqs theta) 
- where
-   mk_dict_var u (clas, ty) = mkDict u clas ty orig
-
-newDict :: InstOrigin -> Class -> UniType -> NF_TcM Inst
-newDict orig clas ty
- = getUniqueTc 		`thenNF_Tc` \ new_uniq ->
-   returnNF_Tc (mkDict new_uniq clas ty orig)
-
-newMethod :: InstOrigin -> Id -> [UniType] -> NF_TcM Inst
-newMethod orig id tys
- = getUniqueTc 			`thenNF_Tc` \ new_uniq ->
-   returnNF_Tc (mkMethod new_uniq id tys orig)
-
-newOverloadedLit :: InstOrigin -> OverloadedLit -> UniType -> NF_TcM Inst
-newOverloadedLit orig lit ty
- = getUniqueTc 			`thenNF_Tc` \ new_uniq ->
-   returnNF_Tc (mkLitInst new_uniq lit ty orig)
-\end{code}
-
-Make a fresh batch of locals, derived from name, each typed with a fresh
-type variable, and return an LVE of them. 
-\begin{itemize}
-
-\item	@mkIdsWithTyVarTys@ uses the supplied names directly (including their
-	uniques), and generates a @TopId@ or @Local@ depending on whether
-	the name is a @FullName@ or not.
-
-\item	@mkIdsWithGivenTys@ does as above, but the types are supplied.
-\end{itemize}
-
-\begin{code}
-mkIdsWithPolyTyVarTys, mkIdsWithOpenTyVarTys :: [Name] -> NF_TcM LVE
-mkIdsWithPolyTyVarTys names
-  = let
-	no_of_names = length names
-    in
-    newPolyTyVarTys no_of_names  `thenNF_Tc` \ tys ->
-    returnNF_Tc (mkIdsWithGivenTys names tys (nOfThem no_of_names noIdInfo))
-
-mkIdsWithOpenTyVarTys names
-  = let
-	no_of_names = length names
-    in
-    newOpenTyVarTys no_of_names  `thenNF_Tc` \ tys ->
-    returnNF_Tc (mkIdsWithGivenTys names tys (nOfThem no_of_names noIdInfo))
-
-mkIdsWithGivenTys :: [Name] -> [UniType] -> [IdInfo] -> LVE
-    -- not monadic any more (WDP 94/05)
-    -- Not done w/ zips/etc for "efficiency" (?)
-mkIdsWithGivenTys [] [] _ = []
-mkIdsWithGivenTys (name:names) (ty:tys) (id_info:id_infos)
-  = (name, mkId name ty id_info) : mkIdsWithGivenTys names tys id_infos
-
-newLocalsWithOpenTyVarTys, newLocalsWithPolyTyVarTys  :: [Name] -> NF_TcM [Id]
-newLocalsWithOpenTyVarTys = new_locals_given_tyvar_fun newOpenTyVarTys
-newLocalsWithPolyTyVarTys = new_locals_given_tyvar_fun newPolyTyVarTys
-
-new_locals_given_tyvar_fun new_tyvar_fun names
-  = new_tyvar_fun no_of_names		`thenNF_Tc` \ tys ->
-    getUniquesTc no_of_names		`thenNF_Tc` \ uniqs ->
-    let  ids = zipWith3 mk_local names uniqs tys  in
-    returnNF_Tc ids
-  where
-    no_of_names = length names
-    mk_local name uniq ty = mkUserLocal (getOccurrenceName name) uniq ty 
-					(getSrcLoc name)
-\end{code}
-
-@newLocal*@ creates a new unique local variable with the given
-string and type. @newLocals@ is similar, but works on lists of strings
-and types.
-
-\begin{code}
-{- UNUSED:
-newLocalWithOpenTyVarTy, newLocalWithPolyTyVarTy  :: Name -> NF_TcM Id
-
-newLocalWithOpenTyVarTy name
-  = newOpenTyVarTy 	`thenNF_Tc` \ ty ->
-    newLocalWithGivenTy name ty
-
-newLocalWithPolyTyVarTy name
-  = newPolyTyVarTy 	`thenNF_Tc` \ ty ->
-    newLocalWithGivenTy name ty
--}
-
-newLocalWithGivenTy :: Name -> UniType -> NF_TcM Id
-newLocalWithGivenTy name ty 
-  = getUniqueTc 	`thenNF_Tc` \ uniq ->
-    returnNF_Tc (mkUserLocal (getOccurrenceName name) uniq ty (getSrcLoc name))
-
-newSpecPragmaId :: Name -> UniType -> Maybe SpecInfo -> NF_TcM Id
-newSpecPragmaId name ty specinfo
-  = getUniqueTc 	`thenNF_Tc` \ uniq ->
-    returnNF_Tc (mkSpecPragmaId (getOccurrenceName name) uniq ty specinfo (getSrcLoc name))
-
-newSpecId :: Id -> [Maybe UniType] -> UniType -> NF_TcM Id
-newSpecId unspec spec_tys ty
-  = getUniqueTc 	`thenNF_Tc` \ uniq ->
-    returnNF_Tc (mkSpecId uniq unspec spec_tys ty (selectIdInfoForSpecId unspec))
-\end{code}
-
-ToDo: This @newClassOpLocals@ is used only to make new ClassOps.  Pretty yukky.
-
-\begin{code}
-newClassOpLocals :: [(TyVarTemplate, TauType)]
-					-- The class type variable mapped to 
-					-- the instance type (an InstTyEnv)
-		 -> [ClassOp] 		-- The class ops
-		 -> NF_TcM [Id]		-- Suitable Ids for the polymorphic
-					-- methods
-newClassOpLocals inst_env ops
-  = getSrcLocTc				`thenNF_Tc` \ src_loc ->
-    getUniquesTc (length ops)		`thenNF_Tc` \ uniqs ->
-    returnNF_Tc (zipWith (new_local src_loc) ops uniqs)
-  where
-    new_local src_loc op uniq
-      = mkUserLocal (getClassOpString op)
-		    uniq
-		    (instantiateTy inst_env (getClassOpLocalType op))
-		    src_loc
-\end{code}
-
-%************************************************************************
-%*									*
-Back-substitution functions.  These just apply the current
-substitution to their argument(s).
-%*									*
-%************************************************************************
-
-@applyTcSubstAndCollectTyVars@ applies a substitution to a list of type
-variables, takes the free type vars of the resulting types, and
-returns all of them as list without duplications.
-
-\begin{code}
-applyTcSubstAndCollectTyVars :: [TyVar] -> NF_TcM [TyVar]
-applyTcSubstAndCollectTyVars tyvars
-  = applyTcSubstToTyVars tyvars	`thenNF_Tc` \ tys ->
-    returnNF_Tc (extractTyVarsFromTys tys)
-
-applyTcSubstAndExpectTyVars :: [TyVar] -> NF_TcM [TyVar]
-applyTcSubstAndExpectTyVars tyvars
-  = applyTcSubstToTyVars tyvars	`thenNF_Tc` \ tys ->
-    returnNF_Tc (map (getTyVar "applyTcSubstAndExpectTyVars") tys)
-\end{code}
diff --git a/ghc/compiler/typecheck/TcMonoBnds.hi b/ghc/compiler/typecheck/TcMonoBnds.hi
deleted file mode 100644
index 640843d6d9..0000000000
--- a/ghc/compiler/typecheck/TcMonoBnds.hi
+++ /dev/null
@@ -1,18 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface TcMonoBnds where
-import Bag(Bag)
-import CmdLineOpts(GlobalSwitch)
-import E(E)
-import HsBinds(MonoBinds)
-import HsPat(InPat, TypecheckedPat)
-import Id(Id)
-import LIE(LIE)
-import Name(Name)
-import Pretty(PprStyle, PrettyRep)
-import SplitUniq(SplitUniqSupply)
-import SrcLoc(SrcLoc)
-import Subst(Subst)
-import TcMonad(TcResult)
-import UniType(UniType)
-tcMonoBinds :: E -> MonoBinds Name (InPat Name) -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult (MonoBinds Id TypecheckedPat, LIE)
-
diff --git a/ghc/compiler/typecheck/TcMonoBnds.lhs b/ghc/compiler/typecheck/TcMonoBnds.lhs
deleted file mode 100644
index c5bb5ba8ec..0000000000
--- a/ghc/compiler/typecheck/TcMonoBnds.lhs
+++ /dev/null
@@ -1,130 +0,0 @@
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
-%
-\section[TcMonoBinds]{TcMonoBinds}
-
-\begin{code}
-#include "HsVersions.h"
-
-module TcMonoBnds ( tcMonoBinds ) where
-
-import TcMonad		-- typechecking monad machinery
-import AbsSyn		-- the stuff being typechecked
-
-import AbsPrel		( mkPrimIoTy, unitTy, mkListTy, mkFunTy )
-import AbsUniType	( applyNonSynTyCon, applySynTyCon )
-import CmdLineOpts	( GlobalSwitch(..) )
-import E		( growE_LVE, lookupE_Binder, getE_TCE, E, GVE(..), LVE(..) )
-#if USE_ATTACK_PRAGMAS
-import CE
-#endif
-import TCE
-import Errors		( UnifyErrContext(..) ) -- notably PatMonoBindsCtxt
-import Id		( getIdUniType, Id )
-import LIE		( nullLIE, plusLIE, LIE )
-import NameTypes	( FullName )
-import TcGRHSs		( tcGRHSsAndBinds )
-import TcMatches	( tcMatchesFun )
-import TcPat		( tcPat )
-import Unify		( unifyTauTy )
-import Unique		( dialogueTyConKey, iOTyConKey )
-import Util
-\end{code}
-
-\begin{code}
-tcMonoBinds :: E -> RenamedMonoBinds -> TcM (TypecheckedMonoBinds, LIE)
-
-tcMonoBinds e EmptyMonoBinds = returnTc (EmptyMonoBinds, nullLIE)
-
-tcMonoBinds e (AndMonoBinds mb1 mb2)
-  = tcMonoBinds e mb1		`thenTc` \ (mb1a, lie1) ->
-    tcMonoBinds e mb2		`thenTc` \ (mb2a, lie2) ->
-    returnTc (AndMonoBinds mb1a mb2a, plusLIE lie1 lie2)
-
-tcMonoBinds e (PatMonoBind pat grhss_and_binds locn)
-	 -- much like tcMatches of GRHSMatch
-  = addSrcLocTc locn		 (
-
-	 -- LEFT HAND SIDE
-    tcPat e pat	     	`thenTc` \ (pat2, lie_pat, pat_ty) ->
-
-	 -- BINDINGS AND THEN GRHSS
-    tcGRHSsAndBinds e grhss_and_binds `thenTc` \ (grhss_and_binds2, lie, grhss_ty) ->
-
-    unifyTauTy pat_ty grhss_ty (PatMonoBindsCtxt pat grhss_and_binds) `thenTc_`
-
-    (case pat of
-      VarPatIn fun -> chk_main_or_mainIOish_type e fun pat_ty
-      _		   -> returnTc (panic "chk_main_or_mainIOish_type (pat)")
-    )				      `thenTc_`
-
-	-- Check for primitive types in the pattern (no can do)
-{- does not work here
-    checkTc (any_con_w_prim_arg pat2)
-	    (error "Can't have primitive type in a pattern binding") `thenTc_`
--}
-
-	-- RETURN
-    returnTc (PatMonoBind pat2 grhss_and_binds2 locn,
-	      plusLIE lie_pat lie)
-    )
-
-tcMonoBinds e (FunMonoBind name matches locn)
-  = addSrcLocTc locn			(
-    let  id = lookupE_Binder e name  in
-
-    tcMatchesFun e name (getIdUniType id) matches   `thenTc` \ (matches', lie) ->
-
-    chk_main_or_mainIOish_type e name (getIdUniType id)  `thenTc_`
-
-    returnTc (FunMonoBind id matches' locn, lie)
-    )
-
-chk_main_or_mainIOish_type :: E -> Name -> UniType -> TcM ()
-
-    -- profoundly ugly checking that ...
-    --	Main.main	:: Dialogue -- Haskell 1.2
-    --  Main.main	:: IO ()    -- Haskell 1.3
-    --  Main.mainPrimIO :: PrimIO () -- Glasgow extension
-
-chk_main_or_mainIOish_type e name chk_ty
-  = getSwitchCheckerTc	`thenNF_Tc` \ sw_chkr ->
-    let
-	tce	    = getE_TCE e
-	haskell_1_3 = sw_chkr Haskell_1_3
-
-{-OLD:	response_tc = lookupTCE tce (PreludeTyCon responseTyConKey bottom 0 True)
-	request_tc  = lookupTCE tce (PreludeTyCon requestTyConKey  bottom 0 True)
-	response_ty = applyNonSynTyCon response_tc []
-	request_ty  = applyNonSynTyCon request_tc  []
-	dialogue_ty = (mkListTy response_ty) `mkFunTy` (mkListTy request_ty)
--}
-	dialogue_tc = lookupTCE tce (PreludeTyCon dialogueTyConKey bottom 0 False)
-	dialogue_ty = applySynTyCon dialogue_tc []
-
-	io_tc	    = lookupTCE tce (PreludeTyCon iOTyConKey bottom 1 False)
-	io_tup0_ty  = applySynTyCon io_tc [unitTy]
-
-	bottom	    = panic "chk_main_or..."
-    in
-    if is_a_particular_thing SLIT("Main") SLIT("main") name then
-	if haskell_1_3 then
-	    unifyTauTy io_tup0_ty  chk_ty (MatchCtxt io_tup0_ty  chk_ty)
-	else
-	    unifyTauTy dialogue_ty chk_ty (MatchCtxt dialogue_ty chk_ty)
-
-    else if is_a_particular_thing SLIT("Main") SLIT("mainPrimIO") name then
-       let
-	    ioprim_ty = mkPrimIoTy unitTy
-       in
-       unifyTauTy ioprim_ty chk_ty (MatchCtxt ioprim_ty chk_ty)
-    else
-       returnTc bottom
-  where
-    is_a_particular_thing :: FAST_STRING -> FAST_STRING -> Name -> Bool
-
-    is_a_particular_thing mod_wanted nm_wanted (OtherTopId _ full_name)
-      = let (mod, nm) = getOrigName full_name
-        in  mod == mod_wanted && nm == nm_wanted
-    is_a_particular_thing _ _ _ = False
-\end{code}
diff --git a/ghc/compiler/typecheck/TcMonoType.hi b/ghc/compiler/typecheck/TcMonoType.hi
deleted file mode 100644
index a31c3d94ec..0000000000
--- a/ghc/compiler/typecheck/TcMonoType.hi
+++ /dev/null
@@ -1,17 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface TcMonoType where
-import Bag(Bag)
-import Class(Class)
-import CmdLineOpts(GlobalSwitch)
-import HsTypes(MonoType)
-import Name(Name)
-import Pretty(PprStyle, PrettyRep)
-import SplitUniq(SplitUniqSupply)
-import SrcLoc(SrcLoc)
-import TcMonad(Baby_TcResult)
-import TyCon(TyCon)
-import UniType(UniType)
-import UniqFM(UniqFM)
-tcInstanceType :: UniqFM Class -> UniqFM TyCon -> UniqFM UniType -> Bool -> SrcLoc -> MonoType Name -> (GlobalSwitch -> Bool) -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> Baby_TcResult UniType
-tcMonoType :: UniqFM Class -> UniqFM TyCon -> UniqFM UniType -> MonoType Name -> (GlobalSwitch -> Bool) -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> Baby_TcResult UniType
-
diff --git a/ghc/compiler/typecheck/TcMonoType.lhs b/ghc/compiler/typecheck/TcMonoType.lhs
index 9c68a7d2f9..4ed8e502c0 100644
--- a/ghc/compiler/typecheck/TcMonoType.lhs
+++ b/ghc/compiler/typecheck/TcMonoType.lhs
@@ -1,186 +1,195 @@
 %
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
 %
 \section[TcMonoType]{Typechecking user-specified @MonoTypes@}
 
 \begin{code}
 #include "HsVersions.h"
 
-module TcMonoType ( tcMonoType, tcInstanceType ) where
+module TcMonoType ( tcPolyType, tcMonoType, tcMonoTypeKind, tcContext ) where
 
-IMPORT_Trace		-- ToDo: rm (debugging)
-import Outputable
-import Pretty
+import Ubiq{-uitous-}
 
-import TcMonad		-- typechecking monad machinery
-import AbsSyn		-- the stuff being typechecked
-
-#ifndef DPH
-import AbsPrel		( mkListTy, mkTupleTy, mkFunTy )
-#else
-import AbsPrel		( mkListTy, mkTupleTy, mkFunTy, mkProcessorTy, mkPodTy )
-#endif {- Data Parallel Haskell -}
-import AbsUniType	( applySynTyCon, applyNonSynTyCon, mkDictTy,
-			  getTyConArity, isSynTyCon, isTyVarTemplateTy,
-			  getUniDataTyCon_maybe, maybeUnpackFunTy
-			  IF_ATTACK_PRAGMAS(COMMA pprTyCon COMMA pprUniType)
-			  IF_ATTACK_PRAGMAS(COMMA cmpUniType)
+import HsSyn		( PolyType(..), MonoType(..), Fake )
+import RnHsSyn		( RenamedPolyType(..), RenamedMonoType(..), 
+			  RenamedContext(..)
 			)
-import UniType		( UniType(..) ) -- ******** CHEATING **** could be undone
-import TyCon		--( TyCon(..) ) -- ditto, only more so
 
-import CE		( lookupCE, CE(..) )
-import CmdLineOpts	( GlobalSwitch(..) )
-import Errors		( confusedNameErr, tyConArityErr, instTypeErr,
-			  Error(..)
+
+import TcMonad
+import TcEnv		( tcLookupTyVar, tcLookupClass, tcLookupTyCon, 
+			  tcExtendTyVarEnv, tcTyVarScope
+			)
+import TcKind		( TcKind, mkTcTypeKind, mkBoxedTypeKind,
+			  mkTcArrowKind, unifyKind, newKindVar,
+			  kindToTcKind
 			)
-import Maybes		( Maybe(..) )
-import TcPolyType	( tcPolyType )
-import TCE		( lookupTCE, TCE(..), UniqFM )
-import TVE		( lookupTVE, TVE(..) )
-import Util
+import ErrUtils		( arityErr )
+import Type		( GenType, Type(..), ThetaType(..), 
+			  mkTyVarTy, mkTyConTy, mkFunTy, mkAppTy,
+			  mkSigmaTy
+			)
+import TyVar		( GenTyVar, TyVar(..), mkTyVar )
+import PrelInfo		( mkListTy, mkTupleTy )
+import Type		( mkDictTy )
+import Class		( cCallishClassKeys )
+import Unique		( Unique )
+import Name		( Name(..), getNameShortName, isTyConName, getSynNameArity )
+import PprStyle
+import Pretty
+import Util		( zipWithEqual, panic )
 \end{code}
 
+
+tcMonoType and tcMonoTypeKind
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+tcMonoType checks that the type really is of kind Type!
+
 \begin{code}
-tcMonoType :: CE -> TCE -> TVE -> RenamedMonoType -> Baby_TcM UniType
-
-tcMonoType rec_ce rec_tce tve (MonoTyVar name)
-  = returnB_Tc (lookupTVE tve name)
-
-tcMonoType rec_ce rec_tce tve (ListMonoTy ty)
-  = tcMonoType	rec_ce rec_tce tve ty	`thenB_Tc` \ tau_ty ->
-    returnB_Tc (mkListTy tau_ty)
-
-tcMonoType rec_ce rec_tce tve (TupleMonoTy tys)
-  = mapB_Tc (tcPolyType rec_ce rec_tce tve) tys	`thenB_Tc` \ tau_tys ->
-    returnB_Tc (mkTupleTy (length tau_tys) tau_tys)
-
-tcMonoType rec_ce rec_tce tve (FunMonoTy ty1 ty2)
-  = tcMonoType rec_ce rec_tce tve ty1	`thenB_Tc` \ tau_ty1 ->
-    tcMonoType rec_ce rec_tce tve ty2	`thenB_Tc` \ tau_ty2 ->
-    returnB_Tc (mkFunTy tau_ty1 tau_ty2)
-
-tcMonoType rec_ce rec_tce tve (MonoTyCon name@(WiredInTyCon tycon) tys)
-  = let 
-	arity	     = getTyConArity tycon
-	is_syn_tycon = isSynTyCon tycon
-    in
-    tcMonoType_help rec_ce rec_tce tve name tycon arity is_syn_tycon tys
-
-tcMonoType rec_ce rec_tce tve (MonoTyCon name@(PreludeTyCon _ _ arity is_data_tycon) tys)
-  = tcMonoType_help rec_ce rec_tce tve name
-		    (lookupTCE rec_tce name)
-		    arity (not is_data_tycon) tys
-
-
-tcMonoType rec_ce rec_tce tve (MonoTyCon name@(OtherTyCon _ _ arity is_data_tycon _) tys)
-  = tcMonoType_help rec_ce rec_tce tve name
-		    (lookupTCE rec_tce name)
-		    arity (not is_data_tycon) tys
-
-tcMonoType rec_ce rec_tce tve (MonoTyCon bad_name tys)
-  = getSrcLocB_Tc		`thenB_Tc` \ locn ->
-    failB_Tc (confusedNameErr
-		"Bad name for a type constructor (a class, or a Prelude name?)"
-		bad_name locn)
-
--- two for unfoldings only:
-tcMonoType rec_ce rec_tce tve (MonoDict c ty)
-  = tcMonoType rec_ce rec_tce tve ty	`thenB_Tc` \ new_ty ->
-    let
-	clas = lookupCE rec_ce c
-    in
-    returnB_Tc (mkDictTy clas new_ty)
-
-tcMonoType rec_ce rec_tce tve (MonoTyVarTemplate tv_tmpl)
-  = returnB_Tc (lookupTVE tve tv_tmpl)
-
-#ifdef DPH
-tcMonoType ce tce tve (MonoTyProc tys ty)
-  = tcMonoTypes ce tce tve tys	`thenB_Tc` \ tau_tys ->
-    tcMonoType	ce tce tve ty	`thenB_Tc` \ tau_ty  ->
-    returnB_Tc (mkProcessorTy tau_tys tau_ty)
-
-tcMonoType ce tce tve (MonoTyPod ty)
-  = tcMonoType ce tce tve ty	`thenB_Tc` \ tau_ty  ->
-    returnB_Tc (mkPodTy tau_ty)
-#endif {- Data Parallel Haskell -}
-
-#ifdef DEBUG
-tcMonoType rec_ce rec_tce tve bad_ty
-  = pprPanic "tcMonoType:" (ppr PprShowAll bad_ty)
-#endif
+tcMonoType :: RenamedMonoType -> TcM s Type
+
+tcMonoType ty
+  = tcMonoTypeKind ty			`thenTc` \ (kind,ty) ->
+    unifyKind kind mkTcTypeKind		`thenTc_`
+    returnTc ty
 \end{code}
 
+tcMonoTypeKind does the real work.  It returns a kind and a type.
+
 \begin{code}
-tcMonoType_help rec_ce rec_tce tve name tycon arity is_syn_tycon tys
-  = tcMonoTypes rec_ce rec_tce tve tys	`thenB_Tc`    \ tau_tys ->
-    let	 cur_arity = length tys	 in
-    getSrcLocB_Tc			`thenB_Tc` \ loc ->
-
-    checkB_Tc (arity /= cur_arity)
-	   (tyConArityErr name arity cur_arity loc) `thenB_Tc_`
-
-    returnB_Tc (if is_syn_tycon then
-		 applySynTyCon	tycon tau_tys
-	      else
-		 applyNonSynTyCon tycon tau_tys)
-
--- also not exported
-tcMonoTypes rec_ce rec_tce tve monotypes
-   = mapB_Tc (tcMonoType rec_ce rec_tce tve) monotypes
+tcMonoTypeKind :: RenamedMonoType -> TcM s (TcKind s, Type)
+
+tcMonoTypeKind (MonoTyVar name)
+  = tcLookupTyVar name	`thenNF_Tc` \ (kind,tyvar) ->
+    returnTc (kind, mkTyVarTy tyvar)
+    
+
+tcMonoTypeKind (MonoListTy ty)
+  = tcMonoType ty	`thenTc` \ tau_ty ->
+    returnTc (mkTcTypeKind, mkListTy tau_ty)
+
+tcMonoTypeKind (MonoTupleTy tys)
+  = mapTc tcMonoType  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 ->
+    returnTc (mkTcTypeKind, mkFunTy tau_ty1 tau_ty2)
+
+tcMonoTypeKind (MonoTyApp name tys)
+  = mapAndUnzipTc tcMonoTypeKind tys	`thenTc`    \ (arg_kinds, arg_tys) ->
+
+    tc_mono_name name			`thenNF_Tc` \ (fun_kind, fun_ty) ->
+
+    newKindVar				`thenNF_Tc` \ result_kind ->
+    unifyKind fun_kind (foldr mkTcArrowKind result_kind arg_kinds)	`thenTc_`
+
+	-- Check for saturated application in the special case of
+	-- type synoyms.  Here the renamer has kindly attached the
+	-- arity to the Name.
+    synArityCheck name (length tys)	`thenTc_`
+
+    returnTc (result_kind, foldl mkAppTy fun_ty arg_tys)
+
+-- for unfoldings only:
+tcMonoTypeKind (MonoForAllTy tyvars_w_kinds ty)
+  = tcExtendTyVarEnv tyvar_names (tc_kinds `zip` tyvars) (
+	tcMonoTypeKind ty		`thenTc` \ (kind, ty') ->
+	unifyKind kind mkTcTypeKind	`thenTc_`
+	returnTc (mkTcTypeKind, ty')
+    )
+  where
+    (tyvar_names, kinds) = unzip tyvars_w_kinds
+    tyvars   = zipWithEqual mk_tyvar tyvar_names kinds
+    tc_kinds = map kindToTcKind kinds
+    mk_tyvar name kind = mkTyVar (getNameShortName name) (getItsUnique name) kind
+
+-- for unfoldings only:
+tcMonoTypeKind (MonoDictTy class_name ty)
+  = tcMonoTypeKind ty			`thenTc` \ (arg_kind, arg_ty) ->
+    tcLookupClass class_name		`thenNF_Tc` \ (class_kind, clas) ->
+    unifyKind class_kind arg_kind	`thenTc_`
+    returnTc (mkTcTypeKind, mkDictTy clas arg_ty)
+
+
+tc_mono_name :: Name -> NF_TcM s (TcKind s, Type)
+tc_mono_name name@(Short _ _) 		-- Must be a type variable
+  = tcLookupTyVar name			`thenNF_Tc` \ (kind,tyvar) ->
+    returnNF_Tc (kind, mkTyVarTy tyvar)
+
+tc_mono_name name | isTyConName name 	-- Must be a type constructor
+  = tcLookupTyCon name			`thenNF_Tc` \ (kind,tycon) ->
+    returnNF_Tc (kind, mkTyConTy tycon)
+	
+tc_mono_name name 			-- Renamer should have got it right
+  = panic ("tc_mono_name:" ++ ppShow 1000 (ppr PprDebug name))
 \end{code}
 
-@tcInstanceType@ checks the type {\em and} its syntactic constraints:
-it must normally look like: @instance Foo (Tycon a b c ...) ...@
-(We're checking the @Tycon a b c ...@ part here...)
 
-The exceptions to this syntactic checking: (1)~if the @GlasgowExts@
-flag is on, or (2)~the instance is imported (they must have been
-compiled elsewhere).  In these cases, we let them go through anyway.
+Contexts
+~~~~~~~~
+\begin{code}
+
+tcContext :: RenamedContext -> TcM s ThetaType
+tcContext context = mapTc tcClassAssertion context
+
+tcClassAssertion (class_name, tyvar_name)
+  = checkTc (canBeUsedInContext class_name)
+	    (naughtyCCallContextErr class_name)	`thenTc_`
+
+    tcLookupClass class_name		`thenNF_Tc` \ (class_kind, clas) ->
+    tcLookupTyVar tyvar_name		`thenNF_Tc` \ (tyvar_kind, tyvar) ->
 
-We can also have instances for functions: @instance Foo (a -> b) ...@.
+    unifyKind class_kind tyvar_kind	`thenTc_`
+
+    returnTc (clas, mkTyVarTy tyvar)
+\end{code}
+
+HACK warning: Someone discovered that @_CCallable@ and @_CReturnable@
+could be used in contexts such as:
+\begin{verbatim}
+foo :: _CCallable a => a -> PrimIO Int
+\end{verbatim}
+
+Doing this utterly wrecks the whole point of introducing these
+classes so we specifically check that this isn't being done.
 
 \begin{code}
-tcInstanceType :: CE -> TCE -> TVE
-	       -> Bool{-True <=> from this module-} -> SrcLoc
-	       -> RenamedMonoType
-	       -> Baby_TcM UniType
-
-tcInstanceType ce tce tve from_here locn mono_ty
-  = tcMonoType ce tce tve mono_ty	`thenB_Tc` \ tau_ty  ->
-    let
-	(naughty, unkosher) = bad_shape tau_ty
-    in
-    getSwitchCheckerB_Tc		`thenB_Tc` \ sw_chkr ->
-    checkB_Tc
-	(if not from_here || sw_chkr GlasgowExts then -- no "shape" checking
-	    naughty
-	 else
-	    naughty || unkosher
-	)
-	(instTypeErr tau_ty locn)	`thenB_Tc_`
-    returnB_Tc tau_ty
+canBeUsedInContext :: Name -> Bool
+canBeUsedInContext (ClassName uniq _ _) = not (uniq `elem` cCallishClassKeys)
+canBeUsedInContext other 	        = True
+\end{code}
+
+
+Polytypes
+~~~~~~~~~
+\begin{code}
+tcPolyType :: RenamedPolyType -> TcM s Type
+tcPolyType (HsForAllTy tyvar_names context ty)
+  = tcTyVarScope tyvar_names (\ tyvars ->
+	tcContext context	`thenTc` \ theta ->
+	tcMonoType ty		`thenTc` \ tau ->
+	returnTc (mkSigmaTy tyvars theta tau)
+    )
+\end{code}
+
+Auxilliary functions
+~~~~~~~~~~~~~~~~~~~~
+\begin{code}
+synArityCheck :: Name -> Int -> TcM s ()
+synArityCheck name n_args
+  = case getSynNameArity name of
+	Just arity | arity /= n_args -> failTc (err arity)
+	other			     -> returnTc ()
   where
-    -- "naughty" if the type is really unacceptable, no
-    -- matter what (e.g., a type synonym); "unkosher" if
-    -- the Haskell report forbids it, but we allow it through
-    -- under -fglasgow-exts.
-
-    bad_shape ty
-      = if (is_syn_type ty) then
-	   (True, bottom)
-	else case (getUniDataTyCon_maybe ty) of
-	  Just (_,tys,_) -> (False, not (all isTyVarTemplateTy tys))
-	  Nothing        -> case maybeUnpackFunTy ty of
-	   		      Just (t1, t2) -> (False,
-						not (all isTyVarTemplateTy [t1, t2]))
-			      Nothing       -> (True, bottom)
-      where
-	bottom = panic "bad_shape"
-
-	is_syn_type ty -- ToDo: move to AbsUniType (or friend)?
-	  = case ty of
-	      UniSyn _ _ _ -> True
-	      _ -> False
+    err arity = arityErr "Type synonym constructor" name arity n_args
+\end{code}
+
+Errors and contexts
+~~~~~~~~~~~~~~~~~~~
+\begin{code}
+naughtyCCallContextErr clas_name sty
+  = ppSep [ppStr "Can't use class", ppr sty clas_name, ppStr "in a context"]
 \end{code}
diff --git a/ghc/compiler/typecheck/TcParQuals.lhs b/ghc/compiler/typecheck/TcParQuals.lhs
deleted file mode 100644
index 7c284720c9..0000000000
--- a/ghc/compiler/typecheck/TcParQuals.lhs
+++ /dev/null
@@ -1,97 +0,0 @@
-%               Filename:  %M%
-%               Version :  %I%
-%               Date    :  %G%
-%
-\section[TcParQuals]{TcParQuals}
-
-\begin{code}
-module TcParQuals ( tcParQuals , tcPidPats , tcPidExprs ) where
-
-#include "HsVersions.h"
-
-import TcMonad		-- typechecking monad machinery
-import TcMonadFns		
-import AbsSyn		-- the stuff being typechecked
-
-import AbsPrel		( boolTy, mkProcessorTy, mkPodTy , 
-			  toDomainId, fromDomainId
-			)
-import AbsUniType
-import Id		( mkInstId )
-import Inst		( InstOrigin(..) )
-import E		
-import LIE		
-import TcExpr		( tcExpr , tcExprs )
-import TcPat		( tcPat , tcPats )
-import Unify
-import Util
-\end{code}
-
-
-\begin{code}
-tcParQuals :: E -> RenamedParQuals -> TcM (TypecheckedParQuals,LIE)
-tcParQuals e (AndParQuals quals1 quals2)
- = (tcParQuals e quals1)		   `thenTc` (\ (quals1',lie1) ->
-   (tcParQuals e quals2)  		   `thenTc` (\ (quals2',lie2) ->
-   returnTc (AndParQuals quals1' quals2', lie1 `plusLIE` lie2) ))
-
-tcParQuals e (ParFilter expr)
- = (tcExpr e expr)			        `thenTc`  (\ (expr',lie,ty) ->
-   (unifyTauTy ty boolTy (ParFilterCtxt expr))  `thenTc_`  
-   returnTc (ParFilter expr',lie) )
-
-tcParQuals e (DrawnGenIn pats pat expr)
- = (tcPidPats e pats)       	    `thenTc` (\ (pats',convs,lie1,patsTy) ->
-   (tcPat     e pat)	    	    `thenTc` (\ (pat' ,patTy, lie2) ->
-   (tcExpr e expr)		    `thenTc` (\ (expr',lie3,exprTy) ->
-   (unifyTauTy exprTy 
-	       (mkPodTy (mkProcessorTy patsTy patTy)) 
-	       (DrawnCtxt pats pat expr))	`thenTc_`	
-   returnTc (DrawnGenOut pats' convs pat' expr',
-	    plusLIE (plusLIE lie1 lie2) lie3 ) )))
-
-tcParQuals e (IndexGen exprs pat expr)
- = (tcPidExprs e exprs)         	`thenTc` (\ (exprs',lie1,exprsTy) ->
-   (tcPat      e pat)			`thenTc` (\ (pat',patTy,  lie2) ->
-   (tcExpr e expr)			`thenTc` (\ (expr',lie3,exprTy) ->
-   (unifyTauTy exprTy 
-	       (mkPodTy (mkProcessorTy exprsTy patTy))
-	       (IndexCtxt exprs pat expr))	`thenTc_`
-   returnTc (IndexGen exprs' pat' expr',	
-	     plusLIE (plusLIE lie1 lie2) lie3) )))
-
-\end{code}
-
-\begin{code}
-tcPidExprs:: E -> [RenamedExpr] -> TcM ([TypecheckedExpr],LIE,[TauType])
-tcPidExprs e exprs
-  = tcExprs e exprs			     `thenTc`     (\ (exprs',lie,tys)->
-    getSrcLocTc				     `thenNF_Tc`  (\ loc             ->
-    listNF_Tc (map (getFromDomain loc) tys)  `thenNF_Tc`  (\ fromDomains     ->
-    returnTc (zipWith mkConversion fromDomains exprs',
-	      mkLIE fromDomains `plusLIE` lie,tys) 
-    )))
-  where
-    getFromDomain loc ty
-      = newMethod (OccurrenceOf toDomainId loc) fromDomainId [ty]
-
-    mkConversion fromDom expr 
-      = App (Var (mkInstId fromDom)) expr  
-\end{code}
-
-\begin{code}
-tcPidPats ::E ->[RenamedPat]->TcM ([TypecheckedPat],   -- Expression
-				   [TypecheckedExpr],  -- Conversion fns
-				   LIE,
-				   [UniType])
-tcPidPats e pats 
-  = tcPats e pats		           `thenTc`       (\ (pats',tys,lie)->
-    getSrcLocTc				   `thenNF_Tc`    (\ loc            ->
-    listNF_Tc (map (getToDomain loc) tys)  `thenNF_Tc`    (\ toDomains      ->
-    returnTc (pats',map mkConversion toDomains,
-	      mkLIE toDomains `plusLIE` lie,tys) 
-    )))
-  where
-    getToDomain loc ty= newMethod (OccurrenceOf toDomainId loc) toDomainId [ty]
-    mkConversion toDom= Var (mkInstId toDom)
-\end{code}
diff --git a/ghc/compiler/typecheck/TcPat.hi b/ghc/compiler/typecheck/TcPat.hi
deleted file mode 100644
index 2f13f7fca3..0000000000
--- a/ghc/compiler/typecheck/TcPat.hi
+++ /dev/null
@@ -1,16 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface TcPat where
-import Bag(Bag)
-import CmdLineOpts(GlobalSwitch)
-import E(E)
-import HsPat(InPat, TypecheckedPat)
-import LIE(LIE)
-import Name(Name)
-import Pretty(PprStyle, PrettyRep)
-import SplitUniq(SplitUniqSupply)
-import SrcLoc(SrcLoc)
-import Subst(Subst)
-import TcMonad(TcResult)
-import UniType(UniType)
-tcPat :: E -> InPat Name -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult (TypecheckedPat, LIE, UniType)
-
diff --git a/ghc/compiler/typecheck/TcPat.lhs b/ghc/compiler/typecheck/TcPat.lhs
index 0bf3c314c4..52e9f05e94 100644
--- a/ghc/compiler/typecheck/TcPat.lhs
+++ b/ghc/compiler/typecheck/TcPat.lhs
@@ -1,66 +1,48 @@
 %
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
 %
 \section[TcPat]{Typechecking patterns}
 
 \begin{code}
 #include "HsVersions.h"
 
-module TcPat (
-	tcPat
-#ifdef DPH
-	, tcPats
-#endif
-    ) where
-
-import TcMonad		-- typechecking monad machinery
-import TcMonadFns	( newOpenTyVarTy, newPolyTyVarTy,
-			  newPolyTyVarTys, copyTyVars, newMethod,
-			  newOverloadedLit
-			)
-import AbsSyn		-- the stuff being typechecked
-
-import AbsPrel		( charPrimTy, intPrimTy, floatPrimTy,
+module TcPat ( tcPat ) where
+
+import Ubiq{-uitous-}
+
+import HsSyn		( InPat(..), OutPat(..), HsExpr(..), HsLit(..),
+			  Match, HsBinds, Qual, PolyType,
+			  ArithSeqInfo, Stmt, Fake )
+import RnHsSyn		( RenamedPat(..) )
+import TcHsSyn		( TcPat(..), TcIdOcc(..) )
+
+import TcMonad
+import Inst		( Inst, OverloadedLit(..), InstOrigin(..), LIE(..),
+			  emptyLIE, plusLIE, newMethod, newOverloadedLit )
+import TcEnv		( tcLookupGlobalValue, tcLookupGlobalValueByKey, 
+			  tcLookupLocalValueOK )
+import TcType 		( TcType(..), TcMaybe, tcInstType, newTyVarTy, newTyVarTys )
+import Unify 		( unifyTauTy, unifyTauTyList, unifyTauTyLists )
+
+import Bag		( Bag )
+import CmdLineOpts	( opt_IrrefutableTuples )
+import ErrUtils		( arityErr )
+import Id		( GenId, idType )
+import Kind		( Kind, mkBoxedTypeKind, mkTypeKind )
+import Name		( Name )
+import PprType		( GenType, GenTyVar )
+import PrelInfo		( charPrimTy, intPrimTy, floatPrimTy,
 			  doublePrimTy, charTy, stringTy, mkListTy,
-			  mkTupleTy, addrTy, addrPrimTy, --OLD: eqStringId
-			  PrimOp
-			  IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
-			  IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
-#ifdef DPH
-			  ,mkProcessorTy, toDomainId
-#endif {- Data Parallel Haskell -}
-			)
-import AbsUniType	( instantiateTauTy, applyTyCon, InstTyEnv(..)
-			  IF_ATTACK_PRAGMAS(COMMA instantiateTy)
-			)
-import CmdLineOpts	( GlobalSwitch(..) )
-import Id		( mkInstId, getIdUniType, getDataConSig,
-			  getInstantiatedDataConSig, Id, DataCon(..)
-			)
-import Inst
-import E		( lookupE_Binder, lookupE_Value,
-			  lookupE_ClassOpByKey, E,
-			  LVE(..), TCE(..), UniqFM, CE(..)
-			-- TCE and CE for pragmas only
-			)
-import Errors		( dataConArityErr, Error(..), UnifyErrContext(..)
-			)
-import LIE		( nullLIE, plusLIE, mkLIE, LIE )
-import Unify
-import Unique		-- some ClassKey stuff
-import Util
-
-#ifdef DPH
-import TcParQuals
-#endif {- Data Parallel Haskell -}
-\end{code}
+			  mkTupleTy, addrTy, addrPrimTy )
+import Pretty
+import Type		( Type(..), GenType, splitFunTy, splitSigmaTy )
+import TyVar		( GenTyVar )
+import Unique		( Unique, eqClassOpKey )
 
-The E passed in already contains bindings for all the variables in
-the pattern, usually to fresh type variables (but maybe not, if there
-were type signatures present).
+\end{code}
 
 \begin{code}
-tcPat :: E -> RenamedPat -> TcM (TypecheckedPat, LIE, UniType)
+tcPat :: RenamedPat -> TcM s (TcPat s, LIE s, TcType s)
 \end{code}
 
 %************************************************************************
@@ -70,27 +52,24 @@ tcPat :: E -> RenamedPat -> TcM (TypecheckedPat, LIE, UniType)
 %************************************************************************
 
 \begin{code}
-tcPat e (VarPatIn name)
-  = let
-	id = lookupE_Binder e name
-    in
-    returnTc (VarPat id, nullLIE, getIdUniType id)
+tcPat (VarPatIn name)
+  = tcLookupLocalValueOK "tcPat1" name	`thenNF_Tc` \ id ->
+    returnTc (VarPat (TcId id), emptyLIE, idType id)
 
-tcPat e (LazyPatIn pat)
-  = tcPat e pat		`thenTc` \ (pat', lie, ty) ->
+tcPat (LazyPatIn pat)
+  = tcPat pat		`thenTc` \ (pat', lie, ty) ->
     returnTc (LazyPat pat', lie, ty)
 
-tcPat e pat_in@(AsPatIn name pat)
-  = let
-	id = lookupE_Binder e name
-    in
-    tcPat e pat				`thenTc` \ (pat', lie, ty) ->
-    unifyTauTy (getIdUniType id) ty (PatCtxt pat_in) `thenTc_`
-    returnTc (AsPat id pat', lie, ty)
+tcPat pat_in@(AsPatIn name pat)
+  = tcLookupLocalValueOK "tcPat2"  name	`thenNF_Tc` \ id ->
+    tcPat pat				`thenTc` \ (pat', lie, ty) ->
+    tcAddErrCtxt (patCtxt pat_in) 	$
+    unifyTauTy (idType id) ty		`thenTc_`
+    returnTc (AsPat (TcId id) pat', lie, ty)
 
-tcPat e (WildPatIn)
-  = newOpenTyVarTy    `thenNF_Tc` \ tyvar_ty ->
-    returnTc (WildPat tyvar_ty, nullLIE, tyvar_ty)
+tcPat (WildPatIn)
+  = newTyVarTy mkTypeKind	`thenNF_Tc` \ tyvar_ty ->
+    returnTc (WildPat tyvar_ty, emptyLIE, tyvar_ty)
 \end{code}
 
 %************************************************************************
@@ -100,29 +79,27 @@ tcPat e (WildPatIn)
 %************************************************************************
 
 \begin{code}
-tcPat e pat_in@(ListPatIn pats)
-  = tcPats e pats	`thenTc`    \ (pats', lie, tys) ->
-    newPolyTyVarTy	`thenNF_Tc` \ tyvar_ty ->
-
-    unifyTauTyList (tyvar_ty:tys) (PatCtxt pat_in) `thenTc_`
+tcPat pat_in@(ListPatIn pats)
+  = tcPats pats				`thenTc`    \ (pats', lie, tys) ->
+    newTyVarTy mkBoxedTypeKind		`thenNF_Tc` \ tyvar_ty ->
+    tcAddErrCtxt (patCtxt pat_in)	$
+    unifyTauTyList (tyvar_ty:tys)	`thenTc_`
 
     returnTc (ListPat tyvar_ty pats', lie, mkListTy tyvar_ty)
 
-tcPat e pat_in@(TuplePatIn pats)
+tcPat pat_in@(TuplePatIn pats)
   = let
 	arity = length pats
     in
-    tcPats e pats   `thenTc` \ (pats', lie, tys) ->
+    tcPats pats   			`thenTc` \ (pats', lie, tys) ->
 
-	-- We have to unify with fresh polymorphic type variables, to
-	-- make sure we record that the tuples can only contain boxed
-	-- types.
-    newPolyTyVarTys arity   `thenNF_Tc` \ tyvar_tys ->
+	-- Make sure we record that the tuples can only contain boxed types
+    newTyVarTys arity mkBoxedTypeKind  	`thenNF_Tc` \ tyvar_tys ->
 
-    unifyTauTyLists tyvar_tys tys (PatCtxt pat_in) `thenTc_`
+    tcAddErrCtxt (patCtxt pat_in)	$
+    unifyTauTyLists tyvar_tys tys	`thenTc_`
 
 	-- possibly do the "make all tuple-pats irrefutable" test:
-    getSwitchCheckerTc	`thenNF_Tc` \ sw_chkr ->
     let
 	unmangled_result = TuplePat pats'
 
@@ -130,8 +107,9 @@ tcPat e pat_in@(TuplePatIn pats)
 	-- so that we can experiment with lazy tuple-matching.
 	-- This is a pretty odd place to make the switch, but
 	-- it was easy to do.
+
 	possibly_mangled_result
-	  = if sw_chkr IrrefutableTuples
+	  = if opt_IrrefutableTuples
 	    then LazyPat unmangled_result
 	    else unmangled_result
 
@@ -168,26 +146,30 @@ ToDo: exploit new representation of constructors to make this more
 efficient?
 
 \begin{code}
-tcPat e pat_in@(ConPatIn name pats)
-  = let
-	con_id = lookupE_Value e name
-    in
-    tcPats e pats `thenTc` \ (pats', lie, tys) ->
+tcPat pat_in@(ConPatIn name pats)
+  = tcLookupGlobalValue name		`thenNF_Tc` \ con_id ->
 
-    matchConArgTys con_id tys (\ ty -> PatCtxt pat_in) `thenTc` \ data_ty ->
+    tcPats pats				`thenTc` \ (pats', lie, tys) ->
 
-    returnTc (ConPat con_id data_ty pats', lie, data_ty)
+    tcAddErrCtxt (patCtxt pat_in)	$
+    matchConArgTys con_id tys 		`thenTc` \ data_ty ->
 
-tcPat e pat_in@(ConOpPatIn pat1 op pat2) -- & in binary-op form...
-  = let
-	con_id = lookupE_Value e op
-    in
-    tcPats e [pat1, pat2]   `thenTc`	\ ([pat1',pat2'], lie, tys) ->
-	 -- ToDo: there exists a less ugly way, no doubt...
+    returnTc (ConPat con_id data_ty pats', 
+	      lie, 
+	      data_ty)
+
+tcPat pat_in@(ConOpPatIn pat1 op pat2) -- & in binary-op form...
+  = tcLookupGlobalValue op		`thenNF_Tc` \ con_id ->
 
-    matchConArgTys con_id tys (\ ty -> PatCtxt pat_in) `thenTc` \ data_ty ->
+    tcPat pat1				`thenTc` \ (pat1', lie1, ty1) ->
+    tcPat pat2				`thenTc` \ (pat2', lie2, ty2) ->
 
-    returnTc (ConOpPat pat1' con_id pat2' data_ty, lie, data_ty)
+    tcAddErrCtxt (patCtxt pat_in)	$
+    matchConArgTys con_id [ty1,ty2]	`thenTc` \ data_ty ->
+
+    returnTc (ConOpPat pat1' con_id pat2' data_ty, 
+	      lie1 `plusLIE` lie2, 
+	      data_ty)
 \end{code}
 
 %************************************************************************
@@ -197,38 +179,28 @@ tcPat e pat_in@(ConOpPatIn pat1 op pat2) -- & in binary-op form...
 %************************************************************************
 
 \begin{code}
-tcPat e (LitPatIn lit@(CharLit str))
-  = returnTc (LitPat lit charTy, nullLIE, charTy)
+tcPat (LitPatIn lit@(HsChar str))
+  = returnTc (LitPat lit charTy, emptyLIE, charTy)
 
-tcPat e (LitPatIn lit@(StringLit str))
-  = getSrcLocTc				`thenNF_Tc` \ loc ->
-    let
-	origin = LiteralOrigin lit loc
-	eq_id  = lookupE_ClassOpByKey e eqClassKey  SLIT("==")
-    in
-    newMethod origin eq_id [stringTy]	`thenNF_Tc` \ eq ->
+tcPat (LitPatIn lit@(HsString str))
+  = tcLookupGlobalValueByKey eqClassOpKey	`thenNF_Tc` \ sel_id ->
+    newMethod (LiteralOrigin lit) 
+	      (RealId sel_id) [stringTy]	`thenNF_Tc` \ (lie, eq_id) ->
     let
-	comp_op = App (Var (mkInstId eq)) (Lit lit)
+	comp_op = HsApp (HsVar eq_id) (HsLitOut lit stringTy)
     in
-    returnTc (NPat lit stringTy comp_op, mkLIE [eq], stringTy)
-
-{- OLD:
-tcPat e (LitPatIn lit@(StringLit str))
-  = returnTc (NPat lit stringTy comp_op, nullLIE, stringTy)
-  where
-    comp_op   = App (Var eqStringId) (Lit lit)
--}
-
-tcPat e (LitPatIn lit@(IntPrimLit _))
-  = returnTc (LitPat lit intPrimTy, nullLIE, intPrimTy)
-tcPat e (LitPatIn lit@(CharPrimLit _))
-  = returnTc (LitPat lit charPrimTy, nullLIE, charPrimTy)
-tcPat e (LitPatIn lit@(StringPrimLit _))
-  = returnTc (LitPat lit addrPrimTy, nullLIE, addrPrimTy)
-tcPat e (LitPatIn lit@(FloatPrimLit _))
-  = returnTc (LitPat lit floatPrimTy, nullLIE, floatPrimTy)
-tcPat e (LitPatIn lit@(DoublePrimLit _))
-  = returnTc (LitPat lit doublePrimTy, nullLIE, doublePrimTy)
+    returnTc (NPat lit stringTy comp_op, lie, stringTy)
+
+tcPat (LitPatIn lit@(HsIntPrim _))
+  = returnTc (LitPat lit intPrimTy, emptyLIE, intPrimTy)
+tcPat (LitPatIn lit@(HsCharPrim _))
+  = returnTc (LitPat lit charPrimTy, emptyLIE, charPrimTy)
+tcPat (LitPatIn lit@(HsStringPrim _))
+  = returnTc (LitPat lit addrPrimTy, emptyLIE, addrPrimTy)
+tcPat (LitPatIn lit@(HsFloatPrim _))
+  = returnTc (LitPat lit floatPrimTy, emptyLIE, floatPrimTy)
+tcPat (LitPatIn lit@(HsDoublePrim _))
+  = returnTc (LitPat lit doublePrimTy, emptyLIE, doublePrimTy)
 \end{code}
 
 %************************************************************************
@@ -238,109 +210,38 @@ tcPat e (LitPatIn lit@(DoublePrimLit _))
 %************************************************************************
 
 \begin{code}
-tcPat e (LitPatIn lit@(IntLit i))
-  = getSrcLocTc				`thenNF_Tc` \ loc ->
-    let
-	origin = LiteralOrigin lit loc
-    in
-    newPolyTyVarTy			`thenNF_Tc` \ tyvar_ty ->
-    let
-	from_int     = lookupE_ClassOpByKey e numClassKey SLIT("fromInt")
-	from_integer = lookupE_ClassOpByKey e numClassKey SLIT("fromInteger")
-	eq_id	     = lookupE_ClassOpByKey e eqClassKey  SLIT("==")
-    in
-    newOverloadedLit origin
-		     (OverloadedIntegral i from_int from_integer)
-		     tyvar_ty		`thenNF_Tc` \ over_lit ->
+tcPat (LitPatIn lit@(HsInt i))
+  = newTyVarTy mkBoxedTypeKind				`thenNF_Tc` \ tyvar_ty ->
+    newOverloadedLit origin  
+		     (OverloadedIntegral i) tyvar_ty	`thenNF_Tc` \ (lie1, over_lit_id) ->
 
-    newMethod origin eq_id [tyvar_ty]	`thenNF_Tc` \ eq ->
+    tcLookupGlobalValueByKey eqClassOpKey		`thenNF_Tc` \ eq_sel_id ->
+    newMethod origin (RealId eq_sel_id) [tyvar_ty]	`thenNF_Tc` \ (lie2, eq_id) ->
 
-    returnTc (NPat lit tyvar_ty (App (Var (mkInstId eq))
-				     (Var (mkInstId over_lit))),
-	      mkLIE [over_lit, eq],
+    returnTc (NPat lit tyvar_ty (HsApp (HsVar eq_id)
+				       (HsVar over_lit_id)),
+	      lie1 `plusLIE` lie2,
 	      tyvar_ty)
+  where
+    origin = LiteralOrigin lit
 
-tcPat e (LitPatIn lit@(FracLit f))
-  = getSrcLocTc				`thenNF_Tc` \ loc ->
-    let
-	origin = LiteralOrigin lit loc
-    in
-    newPolyTyVarTy			`thenNF_Tc` \ tyvar_ty ->
-    let
-	eq_id	      = lookupE_ClassOpByKey e eqClassKey   	  SLIT("==")
-	from_rational = lookupE_ClassOpByKey e fractionalClassKey SLIT("fromRational")
-    in
+tcPat (LitPatIn lit@(HsFrac f))
+  = newTyVarTy mkBoxedTypeKind				`thenNF_Tc` \ tyvar_ty ->
     newOverloadedLit origin
-		     (OverloadedFractional f from_rational)
-		     tyvar_ty		`thenNF_Tc` \ over_lit ->
+		     (OverloadedFractional f) tyvar_ty	`thenNF_Tc` \ (lie1, over_lit_id) ->
 
-    newMethod origin eq_id [tyvar_ty]	`thenNF_Tc` \ eq ->
+    tcLookupGlobalValueByKey eqClassOpKey		`thenNF_Tc` \ eq_sel_id ->
+    newMethod origin (RealId eq_sel_id) [tyvar_ty]	`thenNF_Tc` \ (lie2, eq_id) ->
 
-    returnTc (NPat lit tyvar_ty (App (Var (mkInstId eq))
-			             (Var (mkInstId over_lit))),
-	      mkLIE [over_lit, eq],
+    returnTc (NPat lit tyvar_ty (HsApp (HsVar eq_id)
+				       (HsVar over_lit_id)),
+	      lie1 `plusLIE` lie2,
 	      tyvar_ty)
+  where
+    origin = LiteralOrigin lit
 
-tcPat e (LitPatIn lit@(LitLitLitIn s))
+tcPat (LitPatIn lit@(HsLitLit s))
   = error "tcPat: can't handle ``literal-literal'' patterns"
-{-
-  = getSrcLocTc				`thenNF_Tc` \ loc ->
-    let
-	origin = LiteralOrigin lit loc
-    in
-    newPolyTyVarTy			`thenNF_Tc` \ tyvar_ty ->
-    let
-	eq_id = lookupE_ClassOpByKey e eqClassKey "=="
-    in
-    newOverloadedLit origin
-		     (OverloadedLitLit s)
-		     tyvar_ty		`thenNF_Tc` \ over_lit ->
-
-    newMethod origin eq_id [tyvar_ty]	`thenNF_Tc` \ eq ->
-
-    returnTc (NPat lit tyvar_ty (App (Var (mkInstId eq))
-			             (Var (mkInstId over_lit))),
-	      mkLIE [over_lit, eq],
-	      tyvar_ty)
--}
-
-tcPat e (NPlusKPatIn name lit@(IntLit k))
-  = getSrcLocTc				`thenNF_Tc` \ loc ->
-    let
-	origin 	 = LiteralOrigin lit loc
-
-	local	 = lookupE_Binder e name
-	local_ty = getIdUniType local
-
-	ge_id        = lookupE_ClassOpByKey e ordClassKey SLIT(">=")
-	minus_id     = lookupE_ClassOpByKey e numClassKey SLIT("-")
-	from_int     = lookupE_ClassOpByKey e numClassKey SLIT("fromInt")
-	from_integer = lookupE_ClassOpByKey e numClassKey SLIT("fromInteger")
-    in
-    newOverloadedLit origin
-		     (OverloadedIntegral k from_int from_integer)
-		     local_ty		   `thenNF_Tc` \ over_lit ->
-
-    newMethod origin ge_id  	[local_ty] `thenNF_Tc` \ ge ->
-    newMethod origin minus_id	[local_ty] `thenNF_Tc` \ minus ->
-
-    returnTc (NPlusKPat local lit local_ty
-			(Var (mkInstId over_lit))
-			(Var (mkInstId ge))
-			(Var (mkInstId minus)),
-	      mkLIE [over_lit, ge, minus],
-	      local_ty)
-
-tcPat e (NPlusKPatIn pat other) = panic "TcPat:NPlusKPat: not an IntLit"
-
-#ifdef DPH
-tcPat e (ProcessorPatIn pats pat)
-  = tcPidPats e pats		`thenTc` \ (pats',convs, lie, tys)->
-    tcPat e pat 		`thenTc` \ (pat', ty, lie') ->
-    returnTc (ProcessorPat pats' convs pat',
-	      plusLIE lie lie',
-	      mkProcessorTy tys ty)
-#endif {- Data Parallel Haskell -}
 \end{code}
 
 %************************************************************************
@@ -350,13 +251,13 @@ tcPat e (ProcessorPatIn pats pat)
 %************************************************************************
 
 \begin{code}
-tcPats :: E -> [RenamedPat] -> TcM ([TypecheckedPat], LIE, [UniType])
+tcPats :: [RenamedPat] -> TcM s ([TcPat s], LIE s, [TcType s])
 
-tcPats e [] = returnTc ([], nullLIE, [])
+tcPats [] = returnTc ([], emptyLIE, [])
 
-tcPats e (pat:pats)
-  = tcPat e pat			`thenTc` \ (pat',  lie,  ty)  ->
-    tcPats e pats		`thenTc` \ (pats', lie', tys) ->
+tcPats (pat:pats)
+  = tcPat pat		`thenTc` \ (pat',  lie,  ty)  ->
+    tcPats pats		`thenTc` \ (pats', lie', tys) ->
 
     returnTc (pat':pats', plusLIE lie lie', ty:tys)
 \end{code}
@@ -365,25 +266,31 @@ tcPats e (pat:pats)
 unifies the actual args against the expected ones.
 
 \begin{code}
-matchConArgTys :: Id -> [UniType] -> (UniType -> UnifyErrContext) -> TcM UniType
+matchConArgTys :: Id -> [TcType s] -> TcM s (TcType s)
 
-matchConArgTys con_id arg_tys err_ctxt
-  = let
+matchConArgTys con_id arg_tys
+  = tcInstType [] (idType con_id)		`thenNF_Tc` \ con_ty ->
+    let
 	no_of_args = length arg_tys
-	(sig_tyvars, sig_theta, sig_tys, _) = getDataConSig con_id
+	(con_tyvars, con_theta, con_tau) = splitSigmaTy con_ty
 	     -- Ignore the sig_theta; overloaded constructors only
 	     -- behave differently when called, not when used for
 	     -- matching.
-	con_arity  = length sig_tys
+	(con_args, con_result) = splitFunTy con_tau
+	con_arity  = length con_args
     in
-    getSrcLocTc				`thenNF_Tc` \ loc ->
-    checkTc (con_arity /= no_of_args) 
-	    (dataConArityErr con_id con_arity no_of_args loc) `thenTc_`
+    checkTc (con_arity == no_of_args)
+	    (arityErr "Constructor" con_id con_arity no_of_args)	`thenTc_`
 
-    copyTyVars sig_tyvars	      	`thenNF_Tc` \ (inst_env, _, new_tyvar_tys) ->
-    let 
-	(_,inst_arg_tys,inst_result_ty) = getInstantiatedDataConSig con_id new_tyvar_tys
-    in
-    unifyTauTyLists arg_tys inst_arg_tys (err_ctxt inst_result_ty)  `thenTc_`
-    returnTc inst_result_ty
+    unifyTauTyLists arg_tys con_args	 				`thenTc_`
+    returnTc con_result
+\end{code}
+
+
+% =================================================
+
+Errors and contexts
+~~~~~~~~~~~~~~~~~~~
+\begin{code}
+patCtxt pat sty = ppHang (ppStr "In the pattern:") 4 (ppr sty pat)
 \end{code}
diff --git a/ghc/compiler/typecheck/TcPolyType.hi b/ghc/compiler/typecheck/TcPolyType.hi
deleted file mode 100644
index c7a6a78c6b..0000000000
--- a/ghc/compiler/typecheck/TcPolyType.hi
+++ /dev/null
@@ -1,16 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface TcPolyType where
-import Bag(Bag)
-import Class(Class)
-import CmdLineOpts(GlobalSwitch)
-import HsTypes(PolyType)
-import Name(Name)
-import Pretty(PprStyle, PrettyRep)
-import SplitUniq(SplitUniqSupply)
-import SrcLoc(SrcLoc)
-import TcMonad(Baby_TcResult)
-import TyCon(TyCon)
-import UniType(UniType)
-import UniqFM(UniqFM)
-tcPolyType :: UniqFM Class -> UniqFM TyCon -> UniqFM UniType -> PolyType Name -> (GlobalSwitch -> Bool) -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> Baby_TcResult UniType
-
diff --git a/ghc/compiler/typecheck/TcPolyType.lhs b/ghc/compiler/typecheck/TcPolyType.lhs
deleted file mode 100644
index 7dd397391e..0000000000
--- a/ghc/compiler/typecheck/TcPolyType.lhs
+++ /dev/null
@@ -1,110 +0,0 @@
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1994
-%
-\section[TcPolyType]{Typechecking user-specified @PolyTypes@}
-
-\begin{code}
-module TcPolyType ( tcPolyType ) where
-
-#include "HsVersions.h"
-
-import TcMonad		-- typechecking monad machinery
-import AbsSyn		-- the stuff being typechecked
-
-import AbsUniType	( mkTyVarTemplateTy, mkSysTyVarTemplate, mkSigmaTy,
-			  mkForallTy, SigmaType(..)
-			)
-import CE		( CE(..) )
-import Maybes		( Maybe(..) )
-import TCE		( TCE(..), UniqFM )
-import TVE		-- ( mkTVE, plusTVE, unitTVE, lookupTVE_NoFail, TVE(..) )
-import TcContext	( tcContext )
-import TcMonoType	( tcMonoType )
-import Util
-\end{code}
-
-The TVE passed into @tcPolyType@ binds type variables which are
-in scope; in practice this is always either empty (ordinary type sigs)
-or a singleton (class signatures).  @tcPolyType@ generates a type which
-is polymorphic in all the {\em other} type varaibles mentioned in the
-type.
-
-Very Important Note: when we have a type signature in an interface, say
-\begin{verbatim}
-	f :: a -> b -> a
-\end{verbatim}
-which of the following polytypes do we return?
-\begin{verbatim}
-	forall a b. a -> b -> a
---or
-	forall b a. a -> b -> a
-\end{verbatim}
-
-It makes a difference, because it affects the order in which f takes
-its type arguments.  Now this makes a difference in two ways:
-\begin{itemize}
-\item
-It's essential to get it right if an inlining for f is also exported
-by the interface.
-\item
-It's essential to get it right if the interface tells that there's a specialised
-version of f, because specialisations are known by their function-name/type-arg 
-combinations.
-\end{itemize}
-
-By convention, the foralls on a type read in from somewhere (notably interfaces)
-are 
-	{\em in alphabetical order of their type variables}
-
-When printing types we make sure that we assign print-names to the forall'd type
-variables which are also in alphabetical order.
-
-\begin{code}
-tcPolyType :: CE -> TCE -> TVE  -> RenamedPolyType -> Baby_TcM UniType
-
-tcPolyType ce tce tve (ForAllTy tvs ty)
-  = let
-	new_tv_tmpls_w_uniqs = map tc_uf_tyvar_template tvs
-	new_tv_tmpls	     = map snd new_tv_tmpls_w_uniqs
-	new_tve
-	  = foldr plusTVE tve
-	    [ unitTVE u (mkTyVarTemplateTy tv)
-	    | (u, tv) <- new_tv_tmpls_w_uniqs ]
-    in
-    tcMonoType ce tce new_tve ty	`thenB_Tc` \ new_ty ->
-    returnB_Tc (mkForallTy new_tv_tmpls new_ty)
-  where
-    tc_uf_tyvar_template (Short u _) = (u, mkSysTyVarTemplate u SLIT("a"))
-
-tcPolyType ce tce tve (OverloadedTy   ctxt ty) = tc_poly ce tce tve ctxt ty
-tcPolyType ce tce tve (UnoverloadedTy ty)      = tc_poly ce tce tve []   ty
-
-tc_poly ce tce tve ctxt ty
-  = let	-- BUILD THE NEW TVE
-	used_tyvar_names	= extractMonoTyNames (==) ty
-	poly_tyvar_names	= drop_tyvars_if_in_TVE used_tyvar_names
-
-	-- Sort them into alphabetical order; see notes above.
-	sorted_tyvar_names	= sortLt lt_by_string poly_tyvar_names
-
-	(local_tve, tyvars, _)	= mkTVE sorted_tyvar_names
-	new_tve			= plusTVE tve local_tve
-    in
-	 -- TYPE CHECK THE CONTEXT AND MONOTYPE
-    tcContext ce tce new_tve ctxt	`thenB_Tc` \ theta ->
-    tcMonoType ce tce new_tve ty	`thenB_Tc` \ tau_ty ->
-
-	 -- BUILD THE POLYTYPE AND RETURN
-    returnB_Tc (mkSigmaTy tyvars theta tau_ty)
- where
-    drop_tyvars_if_in_TVE [] = []
-    drop_tyvars_if_in_TVE (n:ns)
-      = let rest = drop_tyvars_if_in_TVE ns
-	in
-      	case (lookupTVE_NoFail tve n) of
-	  Just _    -> rest	-- drop it
-	  Nothing   -> n : rest
-
-    lt_by_string :: Name -> Name -> Bool
-    lt_by_string a b = getOccurrenceName a < getOccurrenceName b
-\end{code}
diff --git a/ghc/compiler/typecheck/TcPragmas.hi b/ghc/compiler/typecheck/TcPragmas.hi
deleted file mode 100644
index bfb87a5a27..0000000000
--- a/ghc/compiler/typecheck/TcPragmas.hi
+++ /dev/null
@@ -1,25 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface TcPragmas where
-import Bag(Bag)
-import CmdLineOpts(GlobalSwitch)
-import E(E)
-import HsDecls(ConDecl)
-import HsPragmas(ClassOpPragmas, DataPragmas, GenPragmas, InstancePragmas, TypePragmas)
-import Id(Id)
-import IdInfo(IdInfo, SpecEnv, SpecInfo)
-import Maybes(Labda)
-import Name(Name)
-import Pretty(PprStyle, PrettyRep)
-import SplitUniq(SplitUniqSupply)
-import SrcLoc(SrcLoc)
-import TcMonad(Baby_TcResult)
-import TyCon(TyCon)
-import TyVar(TyVarTemplate)
-import UniType(UniType)
-import UniqFM(UniqFM)
-tcClassOpPragmas :: E -> UniType -> Id -> Id -> SpecEnv -> ClassOpPragmas Name -> (GlobalSwitch -> Bool) -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> Baby_TcResult (IdInfo, IdInfo)
-tcDataPragmas :: UniqFM TyCon -> UniqFM UniType -> TyCon -> [TyVarTemplate] -> DataPragmas Name -> (GlobalSwitch -> Bool) -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> Baby_TcResult ([ConDecl Name], [SpecInfo])
-tcDictFunPragmas :: E -> UniType -> Id -> InstancePragmas Name -> (GlobalSwitch -> Bool) -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> Baby_TcResult IdInfo
-tcGenPragmas :: E -> Labda UniType -> Id -> GenPragmas Name -> (GlobalSwitch -> Bool) -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> Baby_TcResult IdInfo
-tcTypePragmas :: TypePragmas -> Bool
-
diff --git a/ghc/compiler/typecheck/TcPragmas.lhs b/ghc/compiler/typecheck/TcPragmas.lhs
index b7831fdb41..12b7009214 100644
--- a/ghc/compiler/typecheck/TcPragmas.lhs
+++ b/ghc/compiler/typecheck/TcPragmas.lhs
@@ -1,5 +1,5 @@
 %
-% (c) The GRASP/AQUA Project, Glasgow University, 1993-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1993-1996
 %
 \section[TcPragmas]{Typecheck ``pragmas'' of various kinds}
 
@@ -10,41 +10,27 @@ module TcPragmas (
 	tcClassOpPragmas,
 	tcDataPragmas,
 	tcDictFunPragmas,
-	tcGenPragmas,
-	tcTypePragmas
+	tcGenPragmas
     ) where
 
-IMPORT_Trace	-- ToDo: rm (debugging)
-import Pretty
-import Outputable
-
 import TcMonad		-- typechecking monadic machinery
-import TcMonadFns	( mkIdsWithGivenTys )
-import AbsSyn		-- the stuff being typechecked
+import HsSyn		-- the stuff being typechecked
 
-import AbsPrel		( PrimOp(..)	-- to see CCallOp
+import PrelInfo		( PrimOp(..)	-- to see CCallOp
 			  IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
 			  IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
 			)
-import AbsUniType
-import CE		( lookupCE, nullCE, CE(..) )
+import Type
 import CmdLineOpts
 import CostCentre
-import E
-import Errors
 import HsCore		-- ****** NEED TO SEE CONSTRUCTORS ******
 import HsPragmas	-- ****** NEED TO SEE CONSTRUCTORS ******
 import Id
 import IdInfo
-import WwLib		( mkWwBodies )
-import InstEnv		( lookupClassInstAtSimpleType )
+--import WwLib		( mkWwBodies )
 import Maybes		( assocMaybe, catMaybes, Maybe(..) )
-import CoreLint		( lintUnfolding )
-import PlainCore
-import TCE		( TCE(..), UniqFM )
-import TVE
-import TcMonoType	( tcMonoType )
-import TcPolyType	( tcPolyType )
+--import CoreLint		( lintUnfolding )
+import TcMonoType	( tcMonoType, tcPolyType )
 import Util
 import SrcLoc
 \end{code}
@@ -63,7 +49,7 @@ Of course, the pragmas also need to be checked.
 
 \begin{code}
 tcClassOpPragmas :: E			-- Class/TyCon lookup tables
-	     -> UniType			-- global type of the class method
+	     -> Type			-- global type of the class method
 	     -> Id			-- *final* ClassOpId
 	     -> Id			-- *final* DefaultMethodId
 	     -> SpecEnv			-- Instance info for this class op
@@ -74,7 +60,7 @@ tcClassOpPragmas _ _ rec_classop_id rec_defm_id spec_infos NoClassOpPragmas
   = returnB_Tc (noIdInfo `addInfo` spec_infos, noIdInfo)
 
 tcClassOpPragmas e global_ty
-		 rec_classop_id rec_defm_id 
+		 rec_classop_id rec_defm_id
 		 spec_infos
 		 (ClassOpPragmas classop_pragmas defm_pragmas)
   = tcGenPragmas e
@@ -101,7 +87,7 @@ convey information about a DictFunId.
 \begin{code}
 tcDictFunPragmas
 	:: E 			    -- Class/TyCon lookup tables
-	-> UniType		    -- DictFunId type
+	-> Type		    -- DictFunId type
 	-> Id			    -- final DictFunId (don't touch)
 	-> RenamedInstancePragmas   -- info w/ which to complete, giving...
 	-> Baby_TcM IdInfo	    -- ... final DictFun IdInfo
@@ -132,7 +118,7 @@ a problem, it just returns @noIdInfo@.
 \begin{code}
 tcGenPragmas
 	:: E			-- lookup table
-	-> Maybe UniType	-- of Id, if we have it (for convenience)
+	-> Maybe Type	-- of Id, if we have it (for convenience)
 	-> Id			-- *incomplete* Id (do not *touch*!)
 	-> RenamedGenPragmas	-- info w/ which to complete, giving...
 	-> Baby_TcM IdInfo	-- IdInfo for this Id
@@ -162,7 +148,7 @@ tcGenPragmas e ty_maybe rec_final_id
 	-- Same as unfolding; if we fail, don't junk all IdInfo
     recoverIgnoreErrorsB_Tc nullSpecEnv (
 	tc_specs e rec_final_id ty_maybe specs
-    )				`thenB_Tc` \ spec_env -> 
+    )				`thenB_Tc` \ spec_env ->
 
     returnB_Tc (
 	noIdInfo
@@ -192,7 +178,7 @@ Don't use the strictness info if a flag set.
 \begin{code}
 tc_strictness
 	:: E
-	-> Maybe UniType
+	-> Maybe Type
 	-> Id		-- final Id (do not *touch*)
 	-> ImpStrictness Name
 	-> Baby_TcM (StrictnessInfo, UnfoldingDetails)
@@ -250,15 +236,15 @@ do_strictness e (Just wrapper_ty) rec_final_id
     -- go wrong if there's an abstract type involved, mind you.
     let
 	(tv_tmpls, arg_tys, ret_ty) = splitTypeWithDictsAsArgs wrapper_ty
-	n_wrapper_args		    = length wrap_arg_info	
-		-- Don't have more args than this, else you risk 
+	n_wrapper_args		    = length wrap_arg_info
+		-- Don't have more args than this, else you risk
 		-- losing laziness!!
     in
     getUniquesB_Tc (length tv_tmpls)	`thenB_Tc` \ tyvar_uniqs ->
     getUniquesB_Tc n_wrapper_args	`thenB_Tc` \ arg_uniqs ->
-    
+
     let
-        (inst_env, tyvars, tyvar_tys) = instantiateTyVarTemplates tv_tmpls tyvar_uniqs
+	(inst_env, tyvars, tyvar_tys) = instantiateTyVarTemplates tv_tmpls tyvar_uniqs
 
 	inst_arg_tys = map (instantiateTy inst_env) arg_tys
 	(undropped_inst_arg_tys, dropped_inst_arg_tys)
@@ -267,7 +253,7 @@ do_strictness e (Just wrapper_ty) rec_final_id
 	inst_ret_ty  = glueTyArgs dropped_inst_arg_tys
 				  (instantiateTy inst_env ret_ty)
 
-	args         = zipWith mk_arg arg_uniqs	undropped_inst_arg_tys
+	args         = zipWithEqual mk_arg arg_uniqs	undropped_inst_arg_tys
 	mk_arg uniq ty = mkSysLocal SLIT("wrap") uniq ty mkUnknownSrcLoc
 	-- ASSERT: length args = n_wrapper_args
     in
@@ -281,7 +267,7 @@ do_strictness e (Just wrapper_ty) rec_final_id
 
 	Just (wrapper_w_hole, worker_w_hole, worker_strictness, worker_ty_w_hole) ->
 
-	    let 
+	    let
 		worker_ty   = worker_ty_w_hole inst_ret_ty
 	    in
 	    getUniqueB_Tc `thenB_Tc` \ uniq ->
@@ -304,7 +290,7 @@ do_strictness e (Just wrapper_ty) rec_final_id
 		wrapper_rhs = wrapper_w_hole worker_id
 		n_tyvars    = length tyvars
 		arity	    = length args
-	
+
 	    in
 	    returnB_Tc (
 		mkStrictnessInfo wrap_arg_info (Just worker_id),
@@ -316,7 +302,7 @@ do_strictness e (Just wrapper_ty) rec_final_id
 \begin{code}
 tc_specs :: E
 	 -> Id -- final Id for which these are specialisations (do not *touch*)
-	 -> Maybe UniType
+	 -> Maybe Type
 	 -> [([Maybe RenamedMonoType], Int, RenamedGenPragmas)]
 	 -> Baby_TcM SpecEnv
 
@@ -328,7 +314,7 @@ tc_specs e rec_main_id (Just main_ty) spec_pragmas
     returnB_Tc (mkSpecEnv spec_infos)
   where
     (main_tyvars, _) = splitForalls main_ty
- 
+
     rec_ce  = getE_CE  e
     rec_tce = getE_TCE e
 
@@ -342,7 +328,7 @@ tc_specs e rec_main_id (Just main_ty) spec_pragmas
 		(badSpecialisationErr "value" "wrong number of specialising types"
 				      (length main_tyvars) maybe_tys locn)
 				`thenB_Tc_`
-	let 
+	let
 	    spec_ty = specialiseTy main_ty maybe_tys dicts_to_ignore
 	in
 	fixB_Tc ( \ rec_spec_id ->
@@ -381,7 +367,7 @@ tc_unfolding e (ImpUnfolding guidance uf_core)
 
 	(lint_guidance, lint_expr) = case maybe_lint_expr of
 	  Just lint_expr -> (guidance, lint_expr)
-          Nothing        -> (BadUnfolding, panic_expr) 
+	  Nothing        -> (BadUnfolding, panic_expr)
     in
     returnB_Tc (mkUnfolding lint_guidance lint_expr)
   where
@@ -394,73 +380,60 @@ tc_unfolding e (ImpUnfolding guidance uf_core)
 			    -- (others: we hope we can figure them out)
 	       -> TVE	    -- lookup table for tyvars
 	       -> UnfoldingCoreExpr Name
-	       -> Baby_TcM PlainCoreExpr
+	       -> Baby_TcM CoreExpr
 
-    tc_uf_core lve tve (UfCoVar v)
+    tc_uf_core lve tve (UfVar v)
       = tc_uf_Id lve v		`thenB_Tc` \ id ->
-	returnB_Tc (CoVar id)
+	returnB_Tc (Var id)
 
-    tc_uf_core lve tve (UfCoLit l)
-      = returnB_Tc (CoLit l)
+    tc_uf_core lve tve (UfLit l)
+      = returnB_Tc (Lit l)
 
-    tc_uf_core lve tve (UfCoCon con tys as)
+    tc_uf_core lve tve (UfCon con tys as)
       = tc_uf_Id lve (BoringUfId con)	`thenB_Tc` \ con_id ->
 	mapB_Tc (tc_uf_type tve) tys	`thenB_Tc` \ core_tys ->
 	mapB_Tc (tc_uf_atom lve tve) as	`thenB_Tc` \ core_atoms ->
-	returnB_Tc (CoCon con_id core_tys core_atoms)
+	returnB_Tc (Con con_id core_tys core_atoms)
 
     --  If a ccall, we have to patch in the types read from the pragma.
 
-    tc_uf_core lve tve (UfCoPrim (UfCCallOp str is_casm may_gc arg_tys res_ty) app_tys as)
+    tc_uf_core lve tve (UfPrim (UfCCallOp str is_casm may_gc arg_tys res_ty) app_tys as)
       = ASSERT(null app_tys)
     	mapB_Tc (tc_uf_type tve) arg_tys	`thenB_Tc` \ core_arg_tys ->
-        tc_uf_type tve res_ty		`thenB_Tc` \ core_res_ty ->
-        mapB_Tc (tc_uf_type tve) app_tys	`thenB_Tc` \ core_app_tys ->
+	tc_uf_type tve res_ty		`thenB_Tc` \ core_res_ty ->
+	mapB_Tc (tc_uf_type tve) app_tys	`thenB_Tc` \ core_app_tys ->
 	mapB_Tc (tc_uf_atom lve tve) as	`thenB_Tc` \ core_atoms ->
-	returnB_Tc (CoPrim (CCallOp str is_casm may_gc core_arg_tys core_res_ty)
+	returnB_Tc (Prim (CCallOp str is_casm may_gc core_arg_tys core_res_ty)
 			 core_app_tys core_atoms)
 
-    tc_uf_core lve tve (UfCoPrim (UfOtherOp op) tys as)
+    tc_uf_core lve tve (UfPrim (UfOtherOp op) tys as)
       = mapB_Tc (tc_uf_type tve) tys	`thenB_Tc` \ core_tys ->
 	mapB_Tc (tc_uf_atom lve tve) as	`thenB_Tc` \ core_atoms ->
-	returnB_Tc (CoPrim op core_tys core_atoms)
+	returnB_Tc (Prim op core_tys core_atoms)
 
-    tc_uf_core lve tve (UfCoLam binders body)
-      = tc_uf_binders tve binders `thenB_Tc` \ lve2 ->
+    tc_uf_core lve tve (UfLam binder body)
+      = tc_uf_binders tve [binder] `thenB_Tc` \ lve2 ->
 	let
-	    new_binders = map snd lve2
+	    [new_binder] = map snd lve2
 	    new_lve     = lve2 `plusLVE` lve
 	in
 	tc_uf_core new_lve tve body	 `thenB_Tc` \ new_body ->
-	returnB_Tc (CoLam new_binders new_body)
-
-    tc_uf_core lve tve (UfCoTyLam tv body)
-      = let
-	    (new_tv, uniq, new_tv_ty) = tc_uf_tyvar tv
-	    new_tve = tve `plusTVE` (unitTVE uniq new_tv_ty)
-	in
-	tc_uf_core lve new_tve body	 `thenB_Tc` \ new_body ->
-	returnB_Tc (CoTyLam new_tv new_body)
+	returnB_Tc (Lam new_binder new_body)
 
-    tc_uf_core lve tve (UfCoApp fun arg)
+    tc_uf_core lve tve (UfApp fun arg)
       = tc_uf_core lve tve fun	`thenB_Tc` \ new_fun ->
-        tc_uf_atom lve tve arg	`thenB_Tc` \ new_arg ->
-	returnB_Tc (CoApp new_fun new_arg)
-
-    tc_uf_core lve tve (UfCoTyApp expr ty)
-      = tc_uf_core lve tve expr	`thenB_Tc` \ new_expr ->
-        tc_uf_type tve ty	`thenB_Tc` \ new_ty ->
-	returnB_Tc (mkCoTyApp new_expr new_ty)
+	tc_uf_atom lve tve arg	`thenB_Tc` \ new_arg ->
+	returnB_Tc (App new_fun new_arg)
 
-    tc_uf_core lve tve (UfCoCase scrut alts)
+    tc_uf_core lve tve (UfCase scrut alts)
       = tc_uf_core lve tve scrut `thenB_Tc` \ new_scrut ->
 	tc_alts alts		 `thenB_Tc` \ new_alts ->
-	returnB_Tc (CoCase new_scrut new_alts)
+	returnB_Tc (Case new_scrut new_alts)
       where
 	tc_alts (UfCoAlgAlts alts deflt)
 	  = mapB_Tc tc_alg_alt alts   `thenB_Tc` \ new_alts ->
 	    tc_deflt deflt  	    `thenB_Tc` \ new_deflt ->
-	    returnB_Tc (CoAlgAlts new_alts new_deflt)
+	    returnB_Tc (AlgAlts new_alts new_deflt)
 	  where
 	    tc_alg_alt (con, params, rhs)
 	      = tc_uf_Id lve (BoringUfId con)	`thenB_Tc` \ con_id ->
@@ -475,13 +448,13 @@ tc_unfolding e (ImpUnfolding guidance uf_core)
 	tc_alts (UfCoPrimAlts alts deflt)
 	  = mapB_Tc tc_prim_alt alts  `thenB_Tc` \ new_alts ->
 	    tc_deflt deflt  	    `thenB_Tc` \ new_deflt ->
-	    returnB_Tc (CoPrimAlts new_alts new_deflt)
+	    returnB_Tc (PrimAlts new_alts new_deflt)
 	  where
 	    tc_prim_alt (lit, rhs)
 	      = tc_uf_core lve tve rhs	`thenB_Tc` \ new_rhs ->
 		returnB_Tc (lit, new_rhs)
 
-	tc_deflt UfCoNoDefault = returnB_Tc CoNoDefault
+	tc_deflt UfCoNoDefault = returnB_Tc NoDefault
 	tc_deflt (UfCoBindDefault b rhs)
 	  = tc_uf_binders tve [b]	`thenB_Tc` \ lve2 ->
 	    let
@@ -489,9 +462,9 @@ tc_unfolding e (ImpUnfolding guidance uf_core)
 		new_lve = lve2 `plusLVE` lve
 	    in
 	    tc_uf_core new_lve tve rhs	`thenB_Tc` \ new_rhs ->
-	    returnB_Tc (CoBindDefault new_b new_rhs)
+	    returnB_Tc (BindDefault new_b new_rhs)
 
-    tc_uf_core lve tve (UfCoLet (UfCoNonRec b rhs) body)
+    tc_uf_core lve tve (UfLet (UfCoNonRec b rhs) body)
       = tc_uf_core lve tve rhs	`thenB_Tc` \ new_rhs ->
 	tc_uf_binders tve [b]	`thenB_Tc` \ lve2 ->
 	let
@@ -499,9 +472,9 @@ tc_unfolding e (ImpUnfolding guidance uf_core)
 	    new_lve = lve2 `plusLVE` lve
 	in
 	tc_uf_core new_lve tve body `thenB_Tc` \ new_body ->
-	returnB_Tc (CoLet (CoNonRec new_b new_rhs) new_body)
+	returnB_Tc (Let (NonRec new_b new_rhs) new_body)
 
-    tc_uf_core lve tve (UfCoLet (UfCoRec pairs) body)
+    tc_uf_core lve tve (UfLet (UfCoRec pairs) body)
       = let
 	    (binders, rhss) = unzip pairs
 	in
@@ -512,12 +485,12 @@ tc_unfolding e (ImpUnfolding guidance uf_core)
 	in
 	mapB_Tc (tc_uf_core new_lve tve) rhss `thenB_Tc` \ new_rhss ->
 	tc_uf_core new_lve tve         body `thenB_Tc` \ new_body ->
-	returnB_Tc (CoLet (CoRec (new_binders `zip` new_rhss)) new_body)
+	returnB_Tc (Let (Rec (new_binders `zip` new_rhss)) new_body)
 
-    tc_uf_core lve tve (UfCoSCC uf_cc body)
+    tc_uf_core lve tve (UfSCC uf_cc body)
       = tc_uf_cc   uf_cc	    `thenB_Tc` \ new_cc ->
 	tc_uf_core lve tve body     `thenB_Tc` \ new_body ->
-	returnB_Tc (CoSCC new_cc new_body)
+	returnB_Tc (SCC new_cc new_body)
       where
 	tc_uf_cc (UfAutoCC id m g is_dupd is_caf)
 	  = tc_uf_Id lve id	`thenB_Tc` \ new_id ->
@@ -527,10 +500,10 @@ tc_unfolding e (ImpUnfolding guidance uf_core)
 	  = tc_uf_Id lve id	`thenB_Tc` \ new_id ->
 	    returnB_Tc (adjust is_caf is_dupd (mkDictCC new_id m g IsNotCafCC))
 
-        tc_uf_cc (UfUserCC n m g d c) = returnB_Tc (adjust c d (mkUserCC n m g))
+	tc_uf_cc (UfUserCC n m g d c) = returnB_Tc (adjust c d (mkUserCC n m g))
 
-        tc_uf_cc (UfPreludeDictsCC d) = returnB_Tc (preludeDictsCostCentre d)
-        tc_uf_cc (UfAllDictsCC m g d) = returnB_Tc (mkAllDictsCC m g d)
+	tc_uf_cc (UfPreludeDictsCC d) = returnB_Tc (preludeDictsCostCentre d)
+	tc_uf_cc (UfAllDictsCC m g d) = returnB_Tc (mkAllDictsCC m g d)
 
 	--------
 	adjust is_caf is_dupd cc
@@ -542,11 +515,11 @@ tc_unfolding e (ImpUnfolding guidance uf_core)
 
     ---------------
     tc_uf_atom lve tve (UfCoLitAtom l)
-      = returnB_Tc (CoLitAtom l)
+      = returnB_Tc (LitArg l)
 
     tc_uf_atom lve tve (UfCoVarAtom v)
       = tc_uf_Id lve v			`thenB_Tc` \ new_v ->
-	returnB_Tc (CoVarAtom new_v)
+	returnB_Tc (VarArg new_v)
 
     ---------------
     tc_uf_binders tve ids_and_tys
@@ -607,7 +580,7 @@ tc_unfolding e (ImpUnfolding guidance uf_core)
 	    dfun_id = case (lookupClassInstAtSimpleType clas new_ty) of
 			  Just id -> id
 			  Nothing -> pprPanic "tc_uf_Id:DictFunUfId:"
-					(ppr PprDebug (UfCoVar uf_id))
+					(ppr PprDebug (UfVar uf_id))
 					-- The class and type are both
 					-- visible, so the instance should
 					-- jolly well be too!
@@ -626,14 +599,14 @@ tc_unfolding e (ImpUnfolding guidance uf_core)
       = tc_uf_Id lve unspec 	    `thenB_Tc` \ unspec_id ->
 	mapB_Tc (tc_ty_maybe rec_ce rec_tce) ty_maybes
 				    `thenB_Tc` \ maybe_tys ->
-        let
+	let
 	   spec_id = lookupSpecId unspec_id maybe_tys
 	in
 	returnB_Tc spec_id
 
     tc_uf_Id lve (WorkerUfId unwrkr)
       = tc_uf_Id lve unwrkr 	`thenB_Tc` \ unwrkr_id ->
-        let
+	let
 	    strictness_info = getIdStrictness unwrkr_id
  	in
 	if isLocallyDefined unwrkr_id
@@ -641,7 +614,7 @@ tc_unfolding e (ImpUnfolding guidance uf_core)
 	    -- A locally defined value will not have any strictness info (yet),
 	    -- so we can't extract the locally defined worker Id from it :-(
 
-            pprTrace "WARNING: Discarded bad unfolding from interface:\n"
+	    pprTrace "WARNING: Discarded bad unfolding from interface:\n"
 		     (ppCat [ppStr "Worker Id in unfolding is defined locally:",
 			     ppr PprDebug unwrkr_id])
 	    (failB_Tc (panic "tc_uf_Id:WorkerUfId: locally defined"))
@@ -654,7 +627,7 @@ tc_unfolding e (ImpUnfolding guidance uf_core)
       = getClassOps clas !! (tag - 1)
 
     ---------------------------------------------------------------------
-    tc_uf_type :: TVE -> UnfoldingType Name -> Baby_TcM UniType
+    tc_uf_type :: TVE -> UnfoldingType Name -> Baby_TcM Type
 
     tc_uf_type tve ty = tcPolyType rec_ce rec_tce tve ty
 \end{code}
@@ -697,23 +670,5 @@ tcDataPragmas rec_tce tve rec_tycon new_tyvars (DataPragmas con_decls specs)
 				      (length new_tyvars) maybe_tys locn)
 				`thenB_Tc_`
 
-        returnB_Tc (SpecInfo maybe_tys 0 (panic "DataPragma:SpecInfo:SpecId"))
-\end{code}
-
-%************************************************************************
-%*									*
-\subsection[tcTypePragmas]{@type@ synonym pragmas}
-%*									*
-%************************************************************************
-
-The purpose of a @type@ pragma is to say that the synonym's
-representation should not be used by the user.
-
-\begin{code}
-tcTypePragmas :: TypePragmas
-	      -> Bool		-- True <=> abstract synonym, please
-
-tcTypePragmas NoTypePragmas     = False
-tcTypePragmas AbstractTySynonym = True
+	returnB_Tc (SpecInfo maybe_tys 0 (panic "DataPragma:SpecInfo:SpecId"))
 \end{code}
-
diff --git a/ghc/compiler/typecheck/TcQuals.hi b/ghc/compiler/typecheck/TcQuals.hi
deleted file mode 100644
index 135792c48d..0000000000
--- a/ghc/compiler/typecheck/TcQuals.hi
+++ /dev/null
@@ -1,18 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface TcQuals where
-import Bag(Bag)
-import CmdLineOpts(GlobalSwitch)
-import E(E)
-import HsExpr(Qual)
-import HsPat(InPat, TypecheckedPat)
-import Id(Id)
-import LIE(LIE)
-import Name(Name)
-import Pretty(PprStyle, PrettyRep)
-import SplitUniq(SplitUniqSupply)
-import SrcLoc(SrcLoc)
-import Subst(Subst)
-import TcMonad(TcResult)
-import UniType(UniType)
-tcQuals :: E -> [Qual Name (InPat Name)] -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult ([Qual Id TypecheckedPat], LIE)
-
diff --git a/ghc/compiler/typecheck/TcQuals.lhs b/ghc/compiler/typecheck/TcQuals.lhs
deleted file mode 100644
index e66d06ab20..0000000000
--- a/ghc/compiler/typecheck/TcQuals.lhs
+++ /dev/null
@@ -1,55 +0,0 @@
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1994
-%
-\section[TcQuals]{TcQuals}
-
-\begin{code}
-#include "HsVersions.h"
-
-module TcQuals ( tcQuals ) where
-
-import TcMonad		-- typechecking monad machinery
-import AbsSyn		-- the stuff being typechecked
-
-import AbsPrel		( boolTy, mkListTy )
-import E		( E, TCE(..), UniqFM, CE(..) )
-			-- TCE and CE for pragmas only
-import Errors		( UnifyErrContext(..) )
-import LIE		( LIE, plusLIE )
-import TcExpr		( tcExpr )
-import TcPat		( tcPat )
-import Unify		( unifyTauTy )
-import Util
-\end{code}
-
-There will be at least one @Qual@.
-
-\begin{code}
-tcQuals :: E -> [RenamedQual] -> TcM ([TypecheckedQual], LIE)
-
-tcQuals e [qual]
-  = tcQual e qual   `thenTc` \ (new_qual, lie) ->
-    returnTc ([new_qual], lie)
-
-tcQuals e (qual:quals)
-  = tcQual  e qual  `thenTc` \ (new_qual,  lie1) ->
-    tcQuals e quals `thenTc` \ (new_quals, lie2) ->
-    returnTc (new_qual : new_quals, lie1 `plusLIE` lie2)
-
----
-
-tcQual e (FilterQual expr)
-  = tcExpr e expr			   `thenTc` \ (expr', lie, ty) ->
-    unifyTauTy ty boolTy (FilterCtxt expr) `thenTc_`
-    returnTc (FilterQual expr', lie)
-
-tcQual e (GeneratorQual pat expr)
-  = tcPat e pat			`thenTc` \ (pat',  lie_pat,  pat_ty)  ->
-    tcExpr e expr		`thenTc` \ (expr', lie_expr, expr_ty) ->
-
-    unifyTauTy expr_ty (mkListTy pat_ty) (GeneratorCtxt pat expr) `thenTc_`
-
-    returnTc (GeneratorQual pat' expr', lie_pat `plusLIE` lie_expr)
-\end{code}
-
-
diff --git a/ghc/compiler/typecheck/TcSimplify.hi b/ghc/compiler/typecheck/TcSimplify.hi
deleted file mode 100644
index 79735bc59d..0000000000
--- a/ghc/compiler/typecheck/TcSimplify.hi
+++ /dev/null
@@ -1,27 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface TcSimplify where
-import Bag(Bag)
-import Class(Class)
-import CmdLineOpts(GlobalSwitch)
-import ErrsTc(UnifyErrContext)
-import HsBinds(MonoBinds)
-import HsExpr(Expr)
-import HsPat(TypecheckedPat)
-import Id(Id)
-import Inst(Inst, InstOrigin)
-import LIE(LIE)
-import Pretty(PprStyle, PrettyRep)
-import SplitUniq(SplitUniqSupply)
-import SrcLoc(SrcLoc)
-import Subst(Subst)
-import TcMonad(TcResult)
-import TyVar(TyVar)
-import UniType(UniType)
-bindInstsOfLocalFuns :: LIE -> [Id] -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> ((LIE, MonoBinds Id TypecheckedPat), Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep))
-tcSimplify :: Bool -> [TyVar] -> [TyVar] -> [Inst] -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult ([Inst], [(Inst, Expr Id TypecheckedPat)], [Inst])
-tcSimplifyAndCheck :: Bool -> [TyVar] -> [TyVar] -> [Inst] -> [Inst] -> UnifyErrContext -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult ([Inst], [(Inst, Expr Id TypecheckedPat)])
-tcSimplifyCheckThetas :: InstOrigin -> [(Class, UniType)] -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult ()
-tcSimplifyRank2 :: [TyVar] -> [Inst] -> UnifyErrContext -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult ([Inst], [(Inst, Expr Id TypecheckedPat)])
-tcSimplifyThetas :: (Class -> UniType -> InstOrigin) -> [(Class, UniType)] -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult [(Class, UniType)]
-tcSimplifyTop :: [Inst] -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult [(Inst, Expr Id TypecheckedPat)]
-
diff --git a/ghc/compiler/typecheck/TcSimplify.lhs b/ghc/compiler/typecheck/TcSimplify.lhs
index 126109ab75..7962527daa 100644
--- a/ghc/compiler/typecheck/TcSimplify.lhs
+++ b/ghc/compiler/typecheck/TcSimplify.lhs
@@ -7,41 +7,44 @@
 #include "HsVersions.h"
 
 module TcSimplify (
-	tcSimplify, tcSimplifyAndCheck,
+	tcSimplify, tcSimplifyAndCheck, tcSimplifyWithExtraGlobals,
 	tcSimplifyTop, tcSimplifyThetas, tcSimplifyCheckThetas, tcSimplifyRank2,
 	bindInstsOfLocalFuns
     ) where
 
-IMPORT_Trace		-- ToDo: rm (debugging)
-import Outputable
+import Ubiq
+
+import HsSyn		( MonoBinds(..), HsExpr(..), InPat, OutPat, HsLit, 
+			  Match, HsBinds, Qual, PolyType, ArithSeqInfo,
+			  GRHSsAndBinds, Stmt, Fake )
+import TcHsSyn		( TcIdOcc(..), TcIdBndr(..), TcExpr(..), TcMonoBinds(..) )
+
+import TcMonad
+import Inst		( lookupInst, tyVarsOfInst, isTyVarDict, isDict, matchesInst,
+			  instToId, instBindingRequired, instCanBeGeneralised, newDictsAtLoc,
+			  Inst(..), LIE(..), zonkLIE, emptyLIE, plusLIE, unitLIE, consLIE,
+			  InstOrigin(..), OverloadedLit	)
+import TcEnv		( tcGetGlobalTyVars )
+import TcType		( TcType(..), TcTyVar(..), TcTyVarSet(..), TcMaybe, tcInstType )
+import Unify		( unifyTauTy )
+
+import Bag		( Bag, unitBag, listToBag, foldBag, filterBag, emptyBag, bagToList, 
+			  snocBag, consBag, unionBags, isEmptyBag )
+import Class		( isNumericClass, isStandardClass, isCcallishClass,
+			  isSuperClassOf, getSuperDictSelId )
+import Id		( GenId )
+import Maybes		( expectJust, firstJust, catMaybes, seqMaybe, maybeToBool, Maybe(..) )
+import Outputable	( Outputable(..) )
+import PprType		( GenType, GenTyVar )
 import Pretty
-
-import TcMonad		-- typechecking monadic machinery
-import TcMonadFns	( newDicts, applyTcSubstAndExpectTyVars )
-import AbsSyn		-- the stuff being typechecked
-
-import AbsUniType	( isSuperClassOf, getTyVar, eqTyVar, ltTyVar,
-			  instantiateThetaTy, isFunType, getUniDataTyCon,
-			  getSuperDictSelId, InstTyEnv(..)
-			  IF_ATTACK_PRAGMAS(COMMA isTyVarTy COMMA pprUniType)
-			  IF_ATTACK_PRAGMAS(COMMA assocMaybe)
-			)
-import UniType		( UniType(..) ) -- ******* CHEATING ************
-import Disambig		( disambiguateDicts )
-import Errors		( reduceErr, genCantGenErr, Error(..) )
-import Id		( mkInstId )
-import Inst		( extractTyVarsFromInst, isTyVarDict, matchesInst,
-			  instBindingRequired, instCanBeGeneralised,
-			  Inst(..),	-- We import the CONCRETE type, because
-					-- TcSimplify is allowed to see the rep
-					-- of Insts
-			  InstOrigin, OverloadedLit, InstTemplate
-			)
-import InstEnv
-import LIE
-import ListSetOps	( minusList )
-import Maybes		( catMaybes, maybeToBool, Maybe(..) )
+import SrcLoc		( mkUnknownSrcLoc )
 import Util
+import Type		( GenType, Type(..), TauType(..), mkTyVarTy, getTyVar, eqSimpleTy )
+import TysWiredIn	( intTy )
+import TyVar		( GenTyVar, GenTyVarSet(..), 
+			  elementOfTyVarSet, emptyTyVarSet, unionTyVarSets,
+			  isEmptyTyVarSet, tyVarSetToList )
+import Unique		( Unique )
 \end{code}
 
 
@@ -68,46 +71,32 @@ OTHERWISE
 
 
 \begin{code}
-tcSimpl :: Bool				-- True <=> Don't simplify const insts
-	-> [TyVar]			-- ``Global'' type variables
-	-> [TyVar]			-- ``Local''  type variables
-	-> [Inst]			-- Given; these constrain only local tyvars
-	-> [Inst]			-- Wanted
-	-> TcM ([Inst],			-- Free
-		[(Inst,TypecheckedExpr)],-- Bindings
-		[Inst])			-- Remaining wanteds; no dups
-
-tcSimpl dont_squash_consts global_tvs local_tvs givens wanteds
-  =
-	 -- Make sure the insts and type variables are fixed points of the substitution
-    applyTcSubstAndExpectTyVars global_tvs `thenNF_Tc` \ global_tvs ->
-    applyTcSubstAndExpectTyVars local_tvs  `thenNF_Tc` \ local_tvs ->
-    applyTcSubstToInsts givens		 `thenNF_Tc` \ givens ->
-    applyTcSubstToInsts wanteds		 `thenNF_Tc` \ wanteds ->
-    let
-	is_elem1 = isIn "tcSimpl1"
-	is_elem2 = isIn "tcSimpl2"
-    in
+tcSimpl :: Bool				-- True <=> simplify const insts
+	-> TcTyVarSet s			-- ``Global'' type variables
+	-> TcTyVarSet s			-- ``Local''  type variables
+					-- ASSERT: both these tyvar sets are already zonked
+	-> LIE s			-- Given; these constrain only local tyvars
+	-> LIE s			-- Wanted
+	-> TcM s (LIE s,			-- Free
+		  [(TcIdOcc s,TcExpr s)],	-- Bindings
+		  LIE s)			-- Remaining wanteds; no dups
+
+tcSimpl squash_consts global_tvs local_tvs givens wanteds
+  =	-- ASSSERT: global_tvs and local_tvs are already zonked
+	-- Make sure the insts fixed points of the substitution
+    zonkLIE givens		 	`thenNF_Tc` \ givens ->
+    zonkLIE wanteds		 	`thenNF_Tc` \ wanteds ->
+
 	-- Deal with duplicates and type constructors
     elimTyCons
-	 dont_squash_consts (\tv -> tv `is_elem1` global_tvs)
+	 squash_consts (\tv -> tv `elementOfTyVarSet` global_tvs)
 	 givens wanteds		`thenTc` \ (globals, tycon_binds, locals_and_ambigs) ->
 
-	-- Now disambiguate if necessary
+   	-- Now disambiguate if necessary
     let
-	(ambigs, unambigs) = partition (is_ambiguous local_tvs) locals_and_ambigs
-	(locals, cant_generalise) = partition instCanBeGeneralised unambigs
+	ambigs = filterBag is_ambiguous locals_and_ambigs
     in
-    checkTc (not (null cant_generalise)) (genCantGenErr cant_generalise) 	`thenTc_`
-
-    (if (null ambigs) then
-
-	-- No ambiguous dictionaries.  Just bash on with the results
-	-- of the elimTyCons
-	returnTc (globals, tycon_binds, locals_and_ambigs)
-
-    else
-
+    if not (isEmptyBag ambigs) then
 	-- Some ambiguous dictionaries.	 We now disambiguate them,
 	-- which binds the offending type variables to suitable types in the
 	-- substitution, and then we retry the whole process.  This
@@ -119,25 +108,30 @@ tcSimpl dont_squash_consts global_tvs local_tvs givens wanteds
 	-- to a particular type might enable a short-cut simplification which
 	-- elimTyCons will have missed the first time.
 
-	disambiguateDicts ambigs	`thenTc_`
-	applyTcSubstToInsts givens	`thenNF_Tc` \ givens ->
-	applyTcSubstToInsts wanteds	`thenNF_Tc` \ wanteds ->
-	elimTyCons
-		dont_squash_consts (\tv -> tv `is_elem2` global_tvs)
-		givens wanteds
+	disambiguateDicts ambigs		`thenTc_`
+	tcSimpl squash_consts global_tvs local_tvs givens wanteds
+
+    else
+	-- No ambiguous dictionaries.  Just bash on with the results
+	-- of the elimTyCons
+
+	-- Check for non-generalisable insts
+    let
+  	locals		= locals_and_ambigs	-- ambigs is empty
+	cant_generalise = filterBag (not . instCanBeGeneralised) locals
+    in
+    checkTc (isEmptyBag cant_generalise)
+	    (genCantGenErr cant_generalise)	`thenTc_`
 
-    ) {- End of the "if" -} `thenTc` \ (globals, tycon_binds, locals) ->
 
 	-- Deal with superclass relationships
     elimSCs givens locals		`thenNF_Tc` \ (sc_binds, locals2) ->
 
 	 -- Finished
-    returnTc (globals, sc_binds ++ tycon_binds, locals2)
+    returnTc (globals, bagToList (sc_binds `unionBags` tycon_binds), locals2)
   where
-    is_ambiguous local_tvs (Dict _ _ ty _)
-      = getTyVar "is_ambiguous" ty `not_elem` local_tvs
-      where
-	not_elem = isn'tIn "is_ambiguous"
+    is_ambiguous (Dict _ _ ty _ _)
+	= not (getTyVar "is_ambiguous" ty `elementOfTyVarSet` local_tvs)
 \end{code}
 
 The main wrapper is @tcSimplify@.  It just calls @tcSimpl@, but with
@@ -149,77 +143,91 @@ float them out if poss, after inlinings are sorted out.
 
 \begin{code}
 tcSimplify
-	:: Bool				-- True <=> top level
-	-> [TyVar]			-- ``Global'' type variables
-	-> [TyVar]			-- ``Local''  type variables
-	-> [Inst]			-- Wanted
-	-> TcM ([Inst],			-- Free
-		[(Inst, TypecheckedExpr)],-- Bindings
-		[Inst])			-- Remaining wanteds; no dups
-
-tcSimplify top_level global_tvs local_tvs wanteds
-  = tcSimpl (not top_level) global_tvs local_tvs [] wanteds
+	:: TcTyVarSet s			-- ``Local''  type variables
+	-> LIE s			-- Wanted
+	-> TcM s (LIE s,			-- Free
+		  [(TcIdOcc s,TcExpr s)],	-- Bindings
+		  LIE s)			-- Remaining wanteds; no dups
+
+tcSimplify local_tvs wanteds
+  = tcGetGlobalTyVars			`thenNF_Tc` \ global_tvs ->
+    tcSimpl False global_tvs local_tvs emptyBag wanteds
 \end{code}
 
-@tcSimplifyAndCheck@ is similar to the above, except that it checks
-that there is an empty wanted-set at the end.
+@tcSimplifyWithExtraGlobals@ is just like @tcSimplify@ except that you get
+to specify some extra global type variables that the simplifer will treat
+as free in the environment.
 
-It may still return some of constant insts, which have
-to be resolved finally at the end.
+\begin{code}
+tcSimplifyWithExtraGlobals
+	:: TcTyVarSet s			-- Extra ``Global'' type variables
+	-> TcTyVarSet s			-- ``Local''  type variables
+	-> LIE s			-- Wanted
+	-> TcM s (LIE s,			-- Free
+		  [(TcIdOcc s,TcExpr s)],	-- Bindings
+		  LIE s)			-- Remaining wanteds; no dups
+
+tcSimplifyWithExtraGlobals extra_global_tvs local_tvs wanteds
+  = tcGetGlobalTyVars			`thenNF_Tc` \ global_tvs ->
+    tcSimpl False
+	    (global_tvs `unionTyVarSets` extra_global_tvs)
+	    local_tvs emptyBag wanteds
+\end{code}
+
+@tcSimplifyAndCheck@ is similar to the above, except that it checks
+that there is an empty wanted-set at the end.  It may still return
+some of constant insts, which have to be resolved finally at the end.
 
 \begin{code}
 tcSimplifyAndCheck
-	 :: Bool				-- True <=> top level
-	 -> [TyVar]				-- ``Global''  type variables
-	 -> [TyVar]				-- ``Local''  type variables
-	 -> [Inst]				-- Given
-	 -> [Inst]				-- Wanted
-	 -> UnifyErrContext			-- Context info for error 
-	 -> TcM ([Inst],			-- Free
-		 [(Inst, TypecheckedExpr)])	-- Bindings
-
-tcSimplifyAndCheck top_level global_tvs local_tvs givens wanteds err_ctxt
-  = tcSimpl (not top_level) global_tvs local_tvs givens wanteds
-			`thenTc` \ (free_insts, binds, wanteds') ->
-    checkTc (not (null wanteds')) (reduceErr wanteds' err_ctxt)
-			`thenTc_`
+	 :: TcTyVarSet s		-- ``Local''  type variables; ASSERT is fixpoint
+	 -> LIE s			-- Given
+	 -> LIE s			-- Wanted
+	 -> TcM s (LIE s,			-- Free
+		   [(TcIdOcc s,TcExpr s)])	-- Bindings
+
+tcSimplifyAndCheck local_tvs givens wanteds
+  = tcGetGlobalTyVars			`thenNF_Tc` \ global_tvs ->
+    tcSimpl False global_tvs local_tvs
+	    givens wanteds		`thenTc` \ (free_insts, binds, wanteds') ->
+    checkTc (isEmptyBag wanteds')
+	    (reduceErr wanteds')	`thenTc_`
     returnTc (free_insts, binds)
 \end{code}
 
 @tcSimplifyRank2@ checks that the argument of a rank-2 polymorphic function
-is not overloaded.  
+is not overloaded.
 
 \begin{code}
-tcSimplifyRank2 :: [TyVar]		-- ``Local'' type variables; guaranteed fixpoint of subst
-		-> [Inst]		-- Given
-		-> UnifyErrContext
-		-> TcM ([Inst],				-- Free
-			[(Inst, TypecheckedExpr)])	-- Bindings
-
-tcSimplifyRank2 local_tvs givens err_ctxt
-  = applyTcSubstToInsts givens		 `thenNF_Tc` \ givens' ->
-    elimTyCons False 
-	       (\tv -> not (tv `is_elem` local_tvs))
+tcSimplifyRank2 :: TcTyVarSet s		-- ``Local'' type variables; ASSERT is fixpoint
+		-> LIE s		-- Given
+		-> TcM s (LIE s,			-- Free
+			  [(TcIdOcc s,TcExpr s)])	-- Bindings
+
+
+tcSimplifyRank2 local_tvs givens
+  = zonkLIE givens			`thenNF_Tc` \ givens' ->
+    elimTyCons True
+	       (\tv -> not (tv `elementOfTyVarSet` local_tvs))
 		-- This predicate claims that all
 		-- any non-local tyvars are global,
 		-- thereby postponing dealing with
 		-- ambiguity until the enclosing Gen
-	       [] givens'	`thenTc` \ (free, dict_binds, wanteds) ->
+	       emptyLIE givens'	`thenTc` \ (free, dict_binds, wanteds) ->
 
-    checkTc (not (null wanteds)) (reduceErr wanteds err_ctxt)	`thenTc_`
+    checkTc (isEmptyBag wanteds) (reduceErr wanteds)	`thenTc_`
 
-    returnTc (free, dict_binds)
-  where
-    is_elem = isIn "tcSimplifyRank2"
+    returnTc (free, bagToList dict_binds)
 \end{code}
 
 @tcSimplifyTop@ deals with constant @Insts@, using the standard simplification
 mechansim with the extra flag to say ``beat out constant insts''.
 
 \begin{code}
-tcSimplifyTop :: [Inst] -> TcM [(Inst, TypecheckedExpr)]
+tcSimplifyTop :: LIE s -> TcM s [(TcIdOcc s, TcExpr s)]
 tcSimplifyTop dicts
-  = tcSimpl False [] [] [] dicts    `thenTc` \ (_, binds, _) ->
+  = tcGetGlobalTyVars						`thenNF_Tc` \ global_tvs ->
+    tcSimpl True emptyTyVarSet emptyTyVarSet emptyBag dicts	`thenTc` \ (_, binds, _) ->
     returnTc binds
 \end{code}
 
@@ -228,28 +236,30 @@ tcSimplifyTop dicts
 only interested in the simplified bunch of class/type constraints.
 
 \begin{code}
-tcSimplifyThetas :: (Class -> TauType -> InstOrigin)  -- Creates an origin for the dummy dicts
+tcSimplifyThetas :: (Class -> TauType -> InstOrigin s)  -- Creates an origin for the dummy dicts
 	       	 -> [(Class, TauType)]		      -- Simplify this
-	       	 -> TcM [(Class, TauType)]  	      -- Result
+	       	 -> TcM s [(Class, TauType)]  	      -- Result
 
+tcSimplifyThetas = panic "tcSimplifyThetas"
+
+{- 	LATER
 tcSimplifyThetas mk_inst_origin theta
   = let
-	dicts = map mk_dummy_dict theta
+	dicts = listToBag (map mk_dummy_dict theta)
     in
 	 -- Do the business (this is just the heart of "tcSimpl")
-    elimTyCons False (\tv -> False) [] dicts    `thenTc`	\ (_, _, dicts2) ->
+    elimTyCons True (\tv -> False) emptyLIE dicts    `thenTc`	\ (_, _, dicts2) ->
 
 	  -- Deal with superclass relationships
     elimSCs [] dicts2		    `thenNF_Tc` \ (_, dicts3) ->
 
-    returnTc (map unmk_dummy_dict dicts3)
+    returnTc (map unmk_dummy_dict (bagToList dicts3))
   where
-    mk_dummy_dict (clas, ty)
-      = Dict uniq clas ty (mk_inst_origin clas ty)
+    mk_dummy_dict (clas, ty) = Dict uniq clas ty (mk_inst_origin clas ty) mkUnknownSrcLoc
+    uniq 		     = panic "tcSimplifyThetas:uniq"
 
-    uniq = panic "tcSimplifyThetas:uniq"
-
-    unmk_dummy_dict (Dict _ clas ty _) = (clas, ty)
+    unmk_dummy_dict (Dict _ clas ty _ _) = (clas, ty)
+-}
 \end{code}
 
 @tcSimplifyCheckThetas@ just checks class-type constraints, essentially;
@@ -257,23 +267,27 @@ used with \tr{default} declarations.  We are only interested in
 whether it worked or not.
 
 \begin{code}
-tcSimplifyCheckThetas :: InstOrigin		-- context; for error msg
-		-> [(Class, TauType)]	-- Simplify this
-		-> TcM ()
+tcSimplifyCheckThetas :: InstOrigin s		-- context; for error msg
+		      -> [(Class, TauType)]	-- Simplify this
+		      -> TcM s ()
+
+tcSimplifyCheckThetas = panic "tcSimplifyCheckThetas"
 
+{- 	LATER
 tcSimplifyCheckThetas origin theta
   = let
 	dicts = map mk_dummy_dict theta
     in
 	 -- Do the business (this is just the heart of "tcSimpl")
-    elimTyCons False (\tv -> False) [] dicts    `thenTc`	\ _ ->
+    elimTyCons True (\tv -> False) emptyLIE dicts    `thenTc`	\ _ ->
 
     returnTc ()
   where
     mk_dummy_dict (clas, ty)
-      = Dict uniq clas ty origin
+      = Dict uniq clas ty origin mkUnknownSrcLoc
 
     uniq = panic "tcSimplifyCheckThetas:uniq"
+-}
 \end{code}
 
 
@@ -284,13 +298,13 @@ tcSimplifyCheckThetas origin theta
 %************************************************************************
 
 \begin{code}
-elimTyCons :: Bool				-- True <=> Don't simplify const insts
-	   -> (TyVar -> Bool)			-- Free tyvar predicate
-	   -> [Inst]				-- Given
-	   -> [Inst]				-- Wanted
-	   -> TcM ([Inst],			-- Free
-		   [(Inst, TypecheckedExpr)],	-- Bindings
-		   [Inst]			-- Remaining wanteds; no dups;
+elimTyCons :: Bool				-- True <=> Simplify const insts
+	   -> (TcTyVar s -> Bool)		-- Free tyvar predicate
+	   -> LIE s				-- Given
+	   -> LIE s				-- Wanted
+	   -> TcM s (LIE s,			-- Free
+		     Bag (TcIdOcc s, TcExpr s),	-- Bindings
+		     LIE s			-- Remaining wanteds; no dups;
 						-- dicts only (no Methods)
 	       )
 \end{code}
@@ -318,114 +332,102 @@ The final arrangement of the {\em non-recursive} bindings is
     let <yet-more-bindings> ...
 
 \begin{code}
-elimTyCons dont_squash_consts is_free_tv givens wanteds
-  = eTC givens wanteds
+elimTyCons squash_consts is_free_tv givens wanteds
+  = eTC givens (bagToList wanteds)	`thenTc` \ (_, free, binds, irreds) ->
+    returnTc (free,binds,irreds)
   where
-    eTC :: [Inst] -> [Inst]
-	-> TcM ([Inst], [(Inst, TypecheckedExpr)], [Inst])
-
-    eTC _ [] = returnTc ([], [], [])
-
-    eTC givens (wanted:wanteds) = try givens wanted wanteds
-				      (extractTyVarsFromInst wanted)
-				      (find_equiv givens wanted)
-	-- find_equiv looks in "givens" for an inst equivalent to "wanted"
-	-- This is used only in Case 2 below; it's like a guard which also
-	-- returns a result.
+--    eTC :: LIE s -> [Inst s]
+--	  -> TcM s (LIE s, LIE s, Bag (TcIdOcc s, TcExpr s), LIE s)
 
-    try :: [Inst] -> Inst -> [Inst] -> [TyVar] -> (Maybe Inst)
-	-> TcM ([Inst], [(Inst, TypecheckedExpr)], [Inst])
+    eTC givens [] = returnTc (givens, emptyBag, emptyBag, emptyBag)
 
-    -- Case 0: same as existing dict, so build a simple binding
-    try givens wanted wanteds tvs_of_wanted (Just this)
-     = eTC givens wanteds	`thenTc` \ (frees, binds, wanteds') ->
-       let 
+    eTC givens (wanted:wanteds)
+    -- Case 0: same as an existing inst
+      | maybeToBool maybe_equiv
+      = eTC givens wanteds	`thenTc` \ (givens1, frees, binds, irreds) ->
+	let
 	  -- Create a new binding iff it's needed
-	  new_binds | instBindingRequired wanted = (wanted, Var (mkInstId this)):binds
-	            | otherwise			 = binds
-       in
-       returnTc (frees, new_binds, wanteds')
+	  this = expectJust "eTC" maybe_equiv
+	  new_binds | instBindingRequired wanted = (instToId wanted, HsVar (instToId this))
+						   `consBag` binds
+		    | otherwise			 = binds
+	in
+	returnTc (givens1, frees, new_binds, irreds)
 
     -- Case 1: constrains no type variables at all
     -- In this case we have a quick go to see if it has an
     -- instance which requires no inputs (ie a constant); if so we use
     -- it; if not, we give up on the instance and just heave it out the
     -- top in the free result
-    try givens wanted wanteds tvs_of_wanted _ | null tvs_of_wanted
-      = simplify_it dont_squash_consts {- If dont_squash_consts is true,
-					  simplify only if trival -}
+      | isEmptyTyVarSet tvs_of_wanted
+      = simplify_it squash_consts	{- If squash_consts is false,
+					   simplify only if trival -}
 		    givens wanted wanteds
 
     -- Case 2: constrains free vars only, so fling it out the top in free_ids
-    try givens wanted wanteds tvs_of_wanted _
-      | all is_free_tv tvs_of_wanted
-      = eTC (wanted:givens) wanteds	`thenTc` \ (frees, binds, wanteds') ->
-	returnTc (wanted:frees, binds, wanteds')
+      | all is_free_tv (tyVarSetToList tvs_of_wanted)
+      = eTC (wanted `consBag` givens) wanteds	`thenTc` \ (givens1, frees, binds, irreds) ->
+	returnTc (givens1, wanted `consBag` frees, binds, irreds)
 
     -- Case 3: is a dict constraining only a tyvar,
     -- so return it as part of the "wanteds" result
-    try givens wanted wanteds tvs_of_wanted _
       | isTyVarDict wanted
-      = eTC (wanted:givens) wanteds	`thenTc` \ (frees, binds, wanteds') ->
-	returnTc (frees, binds, wanted:wanteds')
+      = eTC (wanted `consBag` givens) wanteds	`thenTc` \ (givens1, frees, binds, irreds) ->
+	returnTc (givens1, frees, binds, wanted `consBag` irreds)
 
     -- Case 4: is not a simple dict, so look up in instance environment
-    try givens wanted wanteds tvs_of_wanted _
-      = simplify_it False {- Simplify even if not trivial -}
+      | otherwise
+      = simplify_it True {- Simplify even if not trivial -}
 		    givens wanted wanteds
-
-    simplify_it only_if_trivial givens wanted wanteds
-      = if not (instBindingRequired wanted) then
-		-- No binding required for this chap, so squash right away
-	   lookupNoBindInst_Tc wanted	`thenTc` \ simpler_wanteds ->
-
-	   eTC givens simpler_wanteds	`thenTc` \ (frees1, binds1, wanteds1) ->
-	   let
-	       new_givens = [new_given | (new_given,rhs) <- binds1]
-		-- Typically binds1 is empty
-	   in
-	   eTC givens wanteds		`thenTc` \ (frees2, binds2, wanteds2) ->
-
-	   returnTc (frees1 ++ frees2,
-		     binds1 ++ binds2,
-		     wanteds1 ++ wanteds2)
-
-	else	-- An binding is required for this inst
-	lookupInst_Tc wanted	`thenTc` \ (rhs, simpler_wanteds) ->
-
-        if (only_if_trivial && not_var rhs) then
+      where
+	tvs_of_wanted  = tyVarsOfInst wanted
+
+	-- Look for something in "givens" that matches "wanted"
+	Just the_equiv = maybe_equiv
+	maybe_equiv    = foldBag seqMaybe try Nothing givens
+	try given | wanted `matchesInst` given = Just given
+		  | otherwise		       = Nothing
+
+
+    simplify_it simplify_always givens wanted wanteds
+	-- Recover immediately on no-such-instance errors
+      = recoverTc (returnTc (wanted `consBag` givens, emptyLIE, emptyBag, emptyLIE)) 
+		  (simplify_one simplify_always givens wanted)
+				`thenTc` \ (givens1, frees1, binds1, irreds1) ->
+	eTC givens1 wanteds	`thenTc` \ (givens2, frees2, binds2, irreds2) ->
+	returnTc (givens2, frees1 `plusLIE` frees2,
+			   binds1 `unionBags` binds2,
+		  	   irreds1 `plusLIE` irreds2)
+
+
+    simplify_one simplify_always givens wanted
+     | not (instBindingRequired wanted)
+     = 		-- No binding required for this chap, so squash right away
+	   lookupInst wanted		`thenTc` \ (simpler_wanteds, _) ->
+	   eTC givens simpler_wanteds	`thenTc` \ (givens1, frees1, binds1, irreds1) ->
+	   returnTc (wanted `consBag` givens1, frees1, binds1, irreds1)
+
+     | otherwise
+     = 		-- An binding is required for this inst
+	lookupInst wanted		`thenTc` \ (simpler_wanteds, bind@(_,rhs)) ->
+
+	if (not_var rhs && not simplify_always) then
 	   -- Ho ho!  It isn't trivial to simplify "wanted",
-	   -- because the rhs isn't a simple variable.	The flag
-	   -- dont_squash_consts tells us to give up now and
+	   -- because the rhs isn't a simple variable.	Unless the flag
+	   -- simplify_always is set, just give up now and
 	   -- just fling it out the top.
-	   eTC (wanted:givens) wanteds	`thenTc` \ (frees, binds, wanteds') ->
-	   returnTc (wanted:frees, binds, wanteds')
+	   returnTc (wanted `consLIE` givens, unitLIE wanted, emptyBag, emptyLIE)
 	else
-	   -- Aha! Either it's easy, or dont_squash_consts is
-	   -- False, so we must do it right here.
-
-	   eTC givens simpler_wanteds	`thenTc` \ (frees1, binds1, wanteds1) ->
-	   let
-	       new_givens = [new_given | (new_given,rhs) <- binds1]
-	   in
-	   eTC (new_givens ++ [wanted] ++ wanteds1 ++ givens) wanteds
-				   `thenTc` \ (frees2, binds2, wanteds2) ->
-	   returnTc (frees1 ++ frees2,
-		     binds1 ++ [(wanted, rhs)] ++ binds2,
-		     wanteds1 ++ wanteds2)
-      where
-	not_var :: TypecheckedExpr -> Bool
-	not_var (Var _) = False
-	not_var other	= True
-
-    find_equiv :: [Inst] -> Inst -> Maybe Inst
-	-- Look through the argument list for an inst which is
-	-- equivalent to the second arg.
-
-    find_equiv []	      wanted = Nothing
-    find_equiv (given:givens) wanted
-      | wanted `matchesInst` given = Just given
-      | otherwise		   = find_equiv givens wanted
+	   -- Aha! Either it's easy, or simplify_always is True
+	   -- so we must do it right here.
+	   eTC givens simpler_wanteds	`thenTc` \ (givens1, frees1, binds1, irreds1) ->
+	   returnTc (wanted `consLIE` givens1, frees1,
+		     binds1 `snocBag` bind,
+		     irreds1)
+
+    not_var :: TcExpr s -> Bool
+    not_var (HsVar _) = False
+    not_var other     = True
 \end{code}
 
 
@@ -436,88 +438,78 @@ elimTyCons dont_squash_consts is_free_tv givens wanteds
 %************************************************************************
 
 \begin{code}
-elimSCs :: [Inst]				-- Given; no dups
-	-> [Inst]				-- Wanted; no dups; all dictionaries, all
+elimSCs :: LIE s				-- Given; no dups
+	-> LIE s				-- Wanted; no dups; all dictionaries, all
 						-- constraining just a type variable
-	-> NF_TcM ([(Inst,TypecheckedExpr)],	-- Bindings
-		   [Inst])			-- Minimal wanted set
+	-> NF_TcM s (Bag (TcIdOcc s,TcExpr s),	-- Bindings
+		     LIE s)			-- Minimal wanted set
 
 elimSCs givens wanteds
   = -- Sort the wanteds so that subclasses occur before superclasses
     elimSCs_help
-	[dict | dict@(Dict _ _ _ _) <- givens]	-- Filter out non-dictionaries
+	(filterBag isDict givens)	-- Filter out non-dictionaries
 	(sortSC wanteds)
 
-elimSCs_help :: [Inst]				-- Given; no dups
-	     -> [Inst]				-- Wanted; no dups;
-	     -> NF_TcM ([(Inst,TypecheckedExpr)],-- Bindings
-			[Inst])			-- Minimal wanted set
+elimSCs_help :: LIE s					-- Given; no dups
+	     -> [Inst s]				-- Wanted; no dups;
+	     -> NF_TcM s (Bag (TcIdOcc s, TcExpr s),	-- Bindings
+		    	  LIE s)			-- Minimal wanted set
 
-elimSCs_help given [] = returnNF_Tc ([], [])
+elimSCs_help given [] = returnNF_Tc (emptyBag, emptyLIE)
 
-elimSCs_help givens (wanted@(Dict _ wanted_class wanted_ty wanted_orig):wanteds)
-  = case (trySC givens wanted_class wanted_ty) of
+elimSCs_help givens (wanted:wanteds)
+  = trySC givens wanted 		`thenNF_Tc` \ (givens1, binds1, irreds1) ->
+    elimSCs_help givens1 wanteds	`thenNF_Tc` \ (binds2, irreds2) ->
+    returnNF_Tc (binds1 `unionBags` binds2, irreds1 `plusLIE` irreds2)
 
-      Nothing -> -- No superclass relnship found
-		 elimSCs_help (wanted:givens) wanteds `thenNF_Tc` \ (binds, wanteds') ->
-		 returnNF_Tc (binds, wanted:wanteds')
 
-      Just (given, classes) ->	-- Aha! There's a superclass relnship
+trySC :: LIE s				-- Givens
+      -> Inst s				-- Wanted
+      -> NF_TcM s (LIE s,			-- New givens,
+		   Bag (TcIdOcc s,TcExpr s),	-- Bindings
+		   LIE s)			-- Irreducible wanted set
 
-	-- Build intermediate dictionaries
-	let
-	    theta = [ (clas, wanted_ty) | clas <- classes ]
-	in
-	newDicts wanted_orig theta		`thenNF_Tc` \ intermediates ->
+trySC givens wanted@(Dict _ wanted_class wanted_ty wanted_orig loc)
+  | not (maybeToBool maybe_best_subclass_chain)
+  = 	-- No superclass relationship
+    returnNF_Tc (givens, emptyBag, unitLIE wanted)
 
-	-- Deal with the recursive call
-	elimSCs_help (wanted : (intermediates ++ givens)) wanteds
-						`thenNF_Tc` \ (binds, wanteds') ->
+  | otherwise
+  = 	-- There's a subclass relationship with a "given"
+	-- Build intermediate dictionaries
+    let
+	theta = [ (clas, wanted_ty) | clas <- reverse classes ]
+	-- The reverse is because the list comes back in the "wrong" order I think
+    in
+    newDictsAtLoc wanted_orig loc theta		`thenNF_Tc` \ (intermediates, _) ->
 
 	-- Create bindings for the wanted dictionary and the intermediates.
 	-- Later binds may depend on earlier ones, so each new binding is pushed
 	-- on the front of the accumulating parameter list of bindings
-	let
-	    new_binds = mk_binds wanted wanted_class (intermediates ++ [given]) []
-	in
-	returnNF_Tc (new_binds ++ binds, wanteds')
-  where
-    mk_binds :: Inst				-- Define this
-	     -> Class				-- ...whose class is this
-	     -> [Inst]				-- In terms of this sub-class chain
-	     -> [(Inst, TypecheckedExpr)]	-- Push the binding on front of these
-	     -> [(Inst, TypecheckedExpr)]
-
-    mk_binds dict clas [] binds_so_far = binds_so_far
-    mk_binds dict clas (dict_sub@(Dict _ dict_sub_class ty _):dicts_sub) binds_so_far
-      = mk_binds dict_sub dict_sub_class dicts_sub (new_bind:binds_so_far)
-      where
-	new_bind = (dict, DictApp (TyApp (Var (getSuperDictSelId dict_sub_class clas))
-					 [ty])
-				  [mkInstId dict_sub])
-
-
-trySC :: [Inst]				-- Givens
-      -> Class -> UniType		-- Wanted
-      -> Maybe (Inst, [Class])		-- Nothing if no link; Just (given, classes)
-					-- if wanted can be given in terms of given, with
-					-- intermediate classes specified
-trySC givens wanted_class wanted_ty
-  = case subclass_relns of
-	 [] -> Nothing
-	 ((given, classes, _): _) -> Just (given, classes)
+    let
+	mk_bind (dict,clas) dict_sub@(Dict _ dict_sub_class ty _ _)
+	  = ((dict_sub, dict_sub_class),
+	     (instToId dict, DictApp (TyApp (HsVar (RealId (getSuperDictSelId dict_sub_class 
+									      clas)))
+					    [ty])
+				     [instToId dict_sub]))
+	(_, new_binds) = mapAccumR mk_bind (wanted,wanted_class) (given : intermediates)
+    in
+    returnNF_Tc (wanted `consLIE` givens `plusLIE` listToBag intermediates,
+	         listToBag new_binds,
+	         emptyLIE)
+
   where
-    subclass_relns :: [(Inst, [Class], Int)]	-- Subclass of wanted,
-						 -- intervening classes,
-						 -- and number of intervening classes
-						 -- Sorted with shortest link first
-    subclass_relns = sortLt reln_lt (catMaybes (map find_subclass_reln givens))
+    maybe_best_subclass_chain = foldBag choose_best find_subclass_chain Nothing givens
+    Just (given, classes, _) = maybe_best_subclass_chain
 
-    reln_lt :: (Inst, [Class], Int) -> (Inst, [Class], Int) -> Bool
-    (_,_,n1) `reln_lt` (_,_,n2) = n1 < n2
+    choose_best c1@(Just (_,_,n1)) c2@(Just (_,_,n2)) | n1 <= n2  = c1
+						      | otherwise = c2
+    choose_best Nothing		   c2				  = c2
+    choose_best c1		   Nothing		  	  = c1
 
-    find_subclass_reln given@(Dict _ given_class given_ty _)
-	 | wanted_ty == given_ty
+    find_subclass_chain given@(Dict _ given_class given_ty _ _)
+	 | wanted_ty `eqSimpleTy` given_ty
 	 = case (wanted_class `isSuperClassOf` given_class) of
 
 		 Just classes -> Just (given,
@@ -529,18 +521,18 @@ trySC givens wanted_class wanted_ty
 	 | otherwise = Nothing
 
 
-sortSC :: [Inst]    -- Expected to be all dicts (no MethodIds), all of
+sortSC :: LIE s     -- Expected to be all dicts (no MethodIds), all of
 		    -- which constrain type variables
-       -> [Inst]    -- Sorted with subclasses before superclasses
+       -> [Inst s]  -- Sorted with subclasses before superclasses
 
-sortSC dicts = sortLt lt dicts
+sortSC dicts = sortLt lt (bagToList dicts)
   where
-    (Dict _ c1 ty1 _) `lt` (Dict _ c2 ty2 _)
-       = tv1 `ltTyVar` tv2 ||
-	(tv1 `eqTyVar` tv2 && maybeToBool (c2 `isSuperClassOf` c1))
-       where
-	tv1 = getTyVar "sortSC" ty1
-	tv2 = getTyVar "sortSC" ty2
+    (Dict _ c1 ty1 _ _) `lt` (Dict _ c2 ty2 _ _)
+       = if ty1 `eqSimpleTy` ty2 then
+		maybeToBool (c2 `isSuperClassOf` c1)
+	 else
+		-- order is immaterial, I think...
+		False
 \end{code}
 
 
@@ -567,36 +559,195 @@ there, they would have unresolvable references to @f@.
 We pass in an @init_lie@ of @Insts@ and a list of locally-bound @Ids@.
 For each method @Inst@ in the @init_lie@ that mentions one of the
 @Ids@, we create a binding.  We return the remaining @Insts@ (in an
-@LIE@), as well as the @Binds@ generated.
+@LIE@), as well as the @HsBinds@ generated.
 
 \begin{code}
-bindInstsOfLocalFuns ::	LIE -> [Id] -> NF_TcM (LIE, TypecheckedMonoBinds)
+bindInstsOfLocalFuns ::	LIE s -> [TcIdBndr s] -> TcM s (LIE s, TcMonoBinds s)
 
 bindInstsOfLocalFuns init_lie local_ids
-  = let
-	insts = unMkLIE init_lie
-    in
-    bind_insts insts [] EmptyMonoBinds
+  = foldrTc bind_inst (emptyBag, EmptyMonoBinds) (bagToList init_lie)
   where
-    bind_insts	:: [Inst]		-- Insts to mangle
-		-> [Inst]		-- accum. Insts to return
-		-> TypecheckedMonoBinds -- accum. Binds to return
-		-> NF_TcM (LIE, TypecheckedMonoBinds)
-
-    bind_insts [] acc_insts acc_binds
-      = returnNF_Tc (mkLIE acc_insts, acc_binds)
-
-    bind_insts (inst@(Method uniq id tys orig):insts) acc_insts acc_binds
+    bind_inst inst@(Method uniq (TcId id) tys rho orig loc) (insts, binds)
       | id `is_elem` local_ids
-      = noFailTc (lookupInst_Tc inst)	`thenNF_Tc` \ (expr, dict_insts) ->
-	let
-	    bind =  VarMonoBind (mkInstId inst) expr
-	in
-	bind_insts insts (dict_insts ++ acc_insts) (bind `AndMonoBinds` acc_binds)
+      = lookupInst inst		`thenTc` \ (dict_insts, (id,rhs)) ->
+	returnTc (listToBag dict_insts `plusLIE` insts, 
+		  VarMonoBind id rhs `AndMonoBinds` binds)
 
-    bind_insts (some_other_inst:insts) acc_insts acc_binds
+    bind_inst some_other_inst (insts, binds)
 	-- Either not a method, or a method instance for an id not in local_ids
-      = bind_insts insts (some_other_inst:acc_insts) acc_binds
+      = returnTc (some_other_inst `consBag` insts, binds)
 
     is_elem = isIn "bindInstsOfLocalFuns"
 \end{code}
+
+
+%************************************************************************
+%*									*
+\section[Disambig]{Disambiguation of overloading}
+%*									*
+%************************************************************************
+
+
+If a dictionary constrains a type variable which is
+\begin{itemize}
+\item
+not mentioned in the environment
+\item
+and not mentioned in the type of the expression
+\end{itemize}
+then it is ambiguous. No further information will arise to instantiate
+the type variable; nor will it be generalised and turned into an extra
+parameter to a function.
+
+It is an error for this to occur, except that Haskell provided for
+certain rules to be applied in the special case of numeric types.
+
+Specifically, if
+\begin{itemize}
+\item
+at least one of its classes is a numeric class, and
+\item
+all of its classes are numeric or standard
+\end{itemize}
+then the type variable can be defaulted to the first type in the
+default-type list which is an instance of all the offending classes.
+
+So here is the function which does the work.  It takes the ambiguous
+dictionaries and either resolves them (producing bindings) or
+complains.  It works by splitting the dictionary list by type
+variable, and using @disambigOne@ to do the real business.
+
+IMPORTANT: @disambiguate@ assumes that its argument dictionaries
+constrain only a simple type variable.
+
+\begin{code}
+type SimpleDictInfo s = (Inst s, Class, TcTyVar s)
+
+disambiguateDicts :: LIE s -> TcM s ()
+
+disambiguateDicts insts
+  = mapTc disambigOne inst_infos    `thenTc` \ binds_lists ->
+    returnTc ()
+  where
+    inst_infos = equivClasses cmp_tyvars (map mk_inst_info (bagToList insts))
+    (_,_,tv1) `cmp_tyvars` (_,_,tv2) = tv1 `cmp` tv2
+
+    mk_inst_info dict@(Dict _ clas ty _ _)
+      = (dict, clas, getTyVar "disambiguateDicts" ty)
+\end{code}
+
+@disambigOne@ assumes that its arguments dictionaries constrain all
+the same type variable.
+
+ADR Comment 20/6/94: I've changed the @CReturnable@ case to default to
+@()@ instead of @Int@.  I reckon this is the Right Thing to do since
+the most common use of defaulting is code like:
+\begin{verbatim}
+	_ccall_ foo	`seqPrimIO` bar
+\end{verbatim}
+Since we're not using the result of @foo@, the result if (presumably)
+@void@.
+WDP Comment: no such thing as voidTy; so not quite in yet (94/07).
+SLPJ comment: since 
+
+\begin{code}
+disambigOne :: [SimpleDictInfo s] -> TcM s ()
+
+disambigOne dict_infos
+  | not (isStandardNumericDefaultable classes)
+  = failTc (ambigErr dicts) -- no default
+
+  | otherwise -- isStandardNumericDefaultable dict_infos
+  = 	-- THE DICTS OBEY THE DEFAULTABLE CONSTRAINT
+	-- SO, TRY DEFAULT TYPES IN ORDER
+
+	-- Failure here is caused by there being no type in the
+	-- default list which can satisfy all the ambiguous classes.
+	-- For example, if Real a is reqd, but the only type in the
+	-- default list is Int.
+    tcGetDefaultTys			`thenNF_Tc` \ default_tys ->
+    let
+      try_default [] 	-- No defaults work, so fail
+	= failTc (defaultErr dicts default_tys) 
+
+      try_default (default_ty : default_tys)
+	= tryTc (try_default default_tys) $	-- If default_ty fails, we try
+						-- default_tys instead
+	  tcSimplifyCheckThetas DefaultDeclOrigin thetas	`thenTc` \ _ ->
+	  returnTc default_ty
+        where
+	  thetas = classes `zip` repeat default_ty
+    in
+	-- See if any default works, and if so bind the type variable to it
+    try_default default_tys		`thenTc` \ chosen_default_ty ->
+    tcInstType [] chosen_default_ty	`thenNF_Tc` \ chosen_default_tc_ty ->	-- Tiresome!
+    unifyTauTy (mkTyVarTy tyvar) chosen_default_tc_ty
+
+  where
+    (_,_,tyvar) = head dict_infos		-- Should be non-empty
+    dicts   = [dict | (dict,_,_) <- dict_infos]
+    classes = [clas | (_,clas,_) <- 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
+  | any isNumericClass classes && all isStandardClass classes
+  = True
+
+isStandardNumericDefaultable classes
+  | all isCcallishClass classes
+  = True
+
+isStandardNumericDefaultable classes
+  = False
+\end{code}
+
+
+
+Errors and contexts
+~~~~~~~~~~~~~~~~~~~
+ToDo: for these error messages, should we note the location as coming
+from the insts, or just whatever seems to be around in the monad just
+now?
+
+\begin{code}
+genCantGenErr insts sty	-- Can't generalise these Insts
+  = ppHang (ppStr "Cannot generalise these overloadings (in a _ccall_):") 
+	   4  (ppAboves (map (ppr sty) (bagToList insts)))
+\end{code}
+
+\begin{code}
+ambigErr insts sty
+  = ppHang (ppStr "Ambiguous overloading")
+	4 (ppAboves (map (ppr sty) insts))
+\end{code}
+
+@reduceErr@ complains if we can't express required dictionaries in
+terms of the signature.
+
+\begin{code}
+reduceErr insts sty
+  = ppHang (ppStr "Type signature lacks context required by inferred type")
+	 4 (ppHang (ppStr "Context reqd: ")
+	         4 (ppAboves (map (ppr 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 (ppr 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
new file mode 100644
index 0000000000..4e91011ba4
--- /dev/null
+++ b/ghc/compiler/typecheck/TcTyClsDecls.lhs
@@ -0,0 +1,308 @@
+%
+% (c) The AQUA Project, Glasgow University, 1996
+%
+\section[TcTyClsDecls]{Typecheck type and class declarations}
+
+\begin{code}
+#include "HsVersions.h"
+
+module TcTyClsDecls (
+	tcTyAndClassDecls1
+    ) where
+
+import Ubiq{-uitous-}
+
+import HsSyn		( TyDecl(..),  ConDecl(..), BangType(..),
+			  ClassDecl(..), MonoType(..), PolyType(..),
+			  Sig(..), MonoBinds, Fake, InPat )
+import RnHsSyn		( RenamedTyDecl(..), RenamedClassDecl(..) )
+
+import TcMonad
+import Inst		( InstanceMapper(..) )
+import TcClassDcl	( tcClassDecl1 )
+import TcEnv		( tcExtendTyConEnv, tcExtendClassEnv,
+			  tcExtendGlobalValEnv, tcExtendKindEnv,
+			  tcTyVarScope, tcGetEnv )
+import TcKind		( TcKind, newKindVars )
+import TcTyDecls	( tcTyDecl )
+
+import Bag	
+import Class		( Class(..), getClassSelIds )
+import Digraph		( findSCCs, SCC(..) )
+import Name		( Name, isTyConName )
+import PprStyle
+import Pretty
+import UniqSet		( UniqSet(..), emptyUniqSet,
+			  singletonUniqSet, unionUniqSets, 
+			  unionManyUniqSets, uniqSetToList ) 
+import SrcLoc		( SrcLoc )
+import TyCon		( TyCon, getTyConDataCons )
+import Unique		( Unique )
+import Util		( panic, pprTrace )
+
+\end{code}
+
+The main function
+~~~~~~~~~~~~~~~~~
+\begin{code}
+data Decl = TyD RenamedTyDecl | ClD RenamedClassDecl
+
+tcTyAndClassDecls1 :: InstanceMapper
+		   -> Bag RenamedTyDecl -> Bag RenamedClassDecl
+		   -> TcM s (TcEnv s)
+
+tcTyAndClassDecls1 inst_mapper rnty_decls rncls_decls
+  = sortByDependency syn_decls cls_decls 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 ->
+    returnTc env
+
+tcGroups inst_mapper (group:groups)
+  = tcGroup inst_mapper group	`thenTc` \ new_env ->
+
+	-- Extend the environment using the new tycons and classes
+    tcSetEnv new_env $
+
+	-- Do the remaining groups
+    tcGroups inst_mapper groups
+\end{code}
+
+Dealing with a group
+~~~~~~~~~~~~~~~~~~~~
+\begin{code}
+tcGroup :: InstanceMapper -> Bag Decl -> TcM s (TcEnv s)
+tcGroup inst_mapper decls
+  = fixTc ( \ ~(tycons,classes,_) ->
+
+      pprTrace "tcGroup: " (ppCat (map (fst.fmt_decl) (bagToList decls))) $
+
+		-- EXTEND TYPE AND CLASS ENVIRONMENTS
+		-- including their data constructors and class operations
+      tcExtendTyConEnv tycons					  $
+      tcExtendClassEnv classes					  $
+      tcExtendGlobalValEnv (concat (map getTyConDataCons tycons)) $
+      tcExtendGlobalValEnv (concat (map getClassSelIds classes))  $
+
+		-- SNAFFLE ENV TO RETURN
+      tcGetEnv					`thenNF_Tc` \ final_env ->
+
+		-- DEAL WITH TYPE VARIABLES
+      tcTyVarScope tyvar_names 			( \ tyvars ->
+
+		-- MANUFACTURE NEW KINDS, AND EXTEND KIND ENV
+	newKindVars (length tycon_names)	`thenNF_Tc` \ tycon_kinds ->
+	newKindVars (length class_names)	`thenNF_Tc` \ class_kinds ->
+	tcExtendKindEnv tycon_names tycon_kinds		$
+	tcExtendKindEnv class_names class_kinds		$
+
+
+		-- DEAL WITH THE DEFINITIONS THEMSELVES
+	foldBag combine (tcDecl inst_mapper)
+		(returnTc (emptyBag, emptyBag))
+		decls
+      )						`thenTc` \ (tycons,classes) ->
+
+      returnTc (bagToList tycons, bagToList classes, final_env)
+    ) `thenTc` \ (_, _, final_env) ->
+    returnTc final_env
+
+  where
+    (tyvar_names, tycon_names, class_names) = get_binders decls
+
+    combine do_a do_b
+      = do_a `thenTc` \ (a1,a2) ->
+        do_b `thenTc` \ (b1,b2) ->
+	returnTc (a1 `unionBags` b1, a2 `unionBags` b2)
+\end{code}
+
+Dealing with one decl
+~~~~~~~~~~~~~~~~~~~~~
+\begin{code}
+tcDecl  :: InstanceMapper
+	-> Decl
+	-> TcM s (Bag TyCon, Bag Class)
+
+tcDecl inst_mapper (TyD decl)
+  = tcTyDecl decl	`thenTc` \ tycon ->
+    returnTc (unitBag tycon, emptyBag)
+
+tcDecl inst_mapper (ClD decl)
+  = tcClassDecl1 inst_mapper decl   `thenTc` \ clas ->
+    returnTc (emptyBag, unitBag clas)
+\end{code}
+
+Dependency analysis
+~~~~~~~~~~~~~~~~~~~
+\begin{code}
+sortByDependency :: Bag Decl -> Bag Decl -> Bag Decl -> TcM s [Bag Decl]
+sortByDependency syn_decls cls_decls decls
+  = let		-- CHECK FOR SYNONYM CYCLES
+	syn_sccs   = findSCCs mk_edges syn_decls
+	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]
+
+    in
+    checkTc (null cls_cycles) (classCycleErr cls_cycles)	`thenTc_`
+
+		-- DO THE MAIN DEPENDENCY ANALYSIS
+    let
+	decl_sccs  = findSCCs mk_edges decls
+	scc_bags   = map bag_acyclic decl_sccs
+    in
+    returnTc (scc_bags)
+    
+  where
+   bag_acyclic (AcyclicSCC scc) = unitBag scc
+   bag_acyclic (CyclicSCC sccs) = sccs
+
+fmt_decl (TyD (TySynonym name _ _ _))       = (ppr PprForUser name, getSrcLoc name)
+fmt_decl (ClD (ClassDecl _ name _ _ _ _ _)) = (ppr PprForUser name, getSrcLoc name)
+\end{code}
+
+Edges in Type/Class decls
+~~~~~~~~~~~~~~~~~~~~~~~~~
+\begin{code}
+mk_edges (TyD (TyData ctxt name _ condecls _ _ _))
+  = (getItsUnique name, set_to_bag (get_ctxt ctxt `unionUniqSets` get_cons condecls))
+mk_edges (TyD (TyNew  ctxt name _ condecl _ _ _))
+  = (getItsUnique name, set_to_bag (get_ctxt ctxt `unionUniqSets` get_cons condecl))
+mk_edges (TyD (TySynonym name _ rhs _))
+  = (getItsUnique name, set_to_bag (get_ty rhs))
+mk_edges (ClD (ClassDecl ctxt name _ sigs _ _ _))
+  = (getItsUnique name, set_to_bag (get_ctxt ctxt `unionUniqSets` get_sigs sigs))
+
+get_ctxt ctxt
+  = unionManyUniqSets (map (set_name.fst) ctxt)
+
+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_ty ty
+    get_bty (Unbanged ty) = get_ty ty
+
+get_ty (MonoTyVar tv)
+  = emptyUniqSet
+get_ty (MonoTyApp name tys)
+  = (if isTyConName name then set_name name else emptyUniqSet)
+    `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_ctxt ctxt `unionUniqSets` get_ty mty
+get_pty other = panic "TcTyClsDecls:get_pty"
+
+get_tys tys
+  = unionManyUniqSets (map get_ty tys)
+
+get_sigs sigs
+  = unionManyUniqSets (map get_sig sigs)
+  where 
+    get_sig (ClassOpSig _ ty _ _) = get_pty ty
+    get_sig other = panic "TcTyClsDecls:get_sig"
+
+set_name name = singletonUniqSet (getItsUnique name)
+
+set_to_bag set = listToBag (uniqSetToList set)
+\end{code}
+
+Extract *binding* names from type and class decls.  Type variables are
+bound in type, data, newtype and class declarations and the polytypes
+in the class op sigs.
+
+Why do we need to grab all these type variables at once, including
+those locally-quantified type variables in class op signatures?
+Because we can only commit to the final kind of a type variable when
+we've completed the mutually recursive group. For example:
+
+class C a where
+   op :: D b => a -> b -> b
+
+class D c where
+   bop :: (Monad c) => ...
+
+Here, the kind of the locally-polymorphic type variable "b"
+depends on *all the uses of class D*.  For example, the use of
+Monad c in bop's type signature means that D must have kind Type->Type.
+
+
+\begin{code}
+get_binders :: Bag Decl
+	    -> ([Name],	-- TyVars;  no dups
+		[Name],	-- Tycons;  no dups
+		[Name])	-- Classes; no dups
+
+get_binders decls = (bagToList tyvars, bagToList tycons, bagToList classes)
+  where
+    (tyvars, tycons, classes) = foldBag union3 get_binders1
+					(emptyBag,emptyBag,emptyBag)
+					decls
+
+    union3 (a1,a2,a3) (b1,b2,b3)
+      = (a1 `unionBags` b1, a2 `unionBags` b2, a3 `unionBags` b3)
+
+get_binders1 (TyD (TyData _ name tyvars _ _ _ _))
+ = (listToBag tyvars, unitBag name, emptyBag)
+get_binders1 (TyD (TyNew _ name tyvars _ _ _ _))
+ = (listToBag tyvars, unitBag name, emptyBag)
+get_binders1 (TyD (TySynonym name tyvars _ _))
+ = (listToBag tyvars, unitBag name, emptyBag)
+get_binders1 (ClD (ClassDecl _ name tyvar sigs _ _ _))
+ = (unitBag tyvar `unionBags` sigs_tvs sigs,
+    emptyBag, unitBag name)
+
+-- ToDo: will this duplicate the class tyvar
+
+sigs_tvs sigs = unionManyBags (map sig_tvs sigs)
+  where 
+    sig_tvs (ClassOpSig _ ty  _ _) = pty_tvs ty
+    pty_tvs (HsForAllTy tvs _ _)   = listToBag tvs 
+\end{code}
+
+
+\begin{code}
+typeCycleErr syn_cycles sty
+  = ppAboves (map (pp_cycle sty "Cycle in type declarations ...") syn_cycles)
+
+classCycleErr cls_cycles sty
+  = ppAboves (map (pp_cycle sty "Cycle in class declarations ...") cls_cycles)
+
+pp_cycle sty str things
+  = ppHang (ppStr str)
+	 4 (ppAboves (map pp_thing things))
+  where
+    pp_thing (pp_name, loc)
+      = ppCat [pp_name, ppr sty loc]
+\end{code}
diff --git a/ghc/compiler/typecheck/TcTyDecls.hi b/ghc/compiler/typecheck/TcTyDecls.hi
deleted file mode 100644
index 0d0c07b125..0000000000
--- a/ghc/compiler/typecheck/TcTyDecls.hi
+++ /dev/null
@@ -1,19 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface TcTyDecls where
-import Bag(Bag)
-import CmdLineOpts(GlobalSwitch)
-import E(E)
-import FiniteMap(FiniteMap)
-import HsDecls(DataTypeSig, TyDecl)
-import Id(Id)
-import Maybes(Labda)
-import Name(Name)
-import Pretty(PprStyle, PrettyRep)
-import SplitUniq(SplitUniqSupply)
-import SrcLoc(SrcLoc)
-import TcMonad(Baby_TcResult)
-import TyCon(TyCon)
-import UniType(UniType)
-import UniqFM(UniqFM)
-tcTyDecls :: E -> (Name -> Bool) -> (Name -> [DataTypeSig Name]) -> [TyDecl Name] -> (GlobalSwitch -> Bool) -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> Baby_TcResult (UniqFM TyCon, [(Name, Id)], FiniteMap TyCon [(Bool, [Labda UniType])])
-
diff --git a/ghc/compiler/typecheck/TcTyDecls.lhs b/ghc/compiler/typecheck/TcTyDecls.lhs
index 3ad7b060b7..83a4c96732 100644
--- a/ghc/compiler/typecheck/TcTyDecls.lhs
+++ b/ghc/compiler/typecheck/TcTyDecls.lhs
@@ -1,280 +1,211 @@
 %
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The AQUA Project, Glasgow University, 1996
 %
-\section[TcTyDecls]{Typecheck algebraic datatypes and type synonyms}
+\section[TcTyDecls]{Typecheck type declarations}
 
 \begin{code}
 #include "HsVersions.h"
 
-module TcTyDecls ( tcTyDecls ) where
-
-import TcMonad		-- typechecking monad machinery
-import AbsSyn		-- the stuff being typechecked
-
-import AbsUniType	( applyTyCon, mkDataTyCon, mkSynonymTyCon,
-			  getUniDataTyCon, isUnboxedDataType,
-			  isTyVarTemplateTy, cmpUniTypeMaybeList,
-			  pprMaybeTy
-			)
-import CE		( lookupCE, CE(..) )
-import CmdLineOpts	( GlobalSwitch(..) )
-import E		( getE_TCE, getE_CE, plusGVE, nullGVE, GVE(..), E )
-import ErrUtils		( addShortErrLocLine )
-import Errors		( confusedNameErr, specDataNoSpecErr, specDataUnboxedErr )
-import FiniteMap	( FiniteMap, emptyFM, plusFM, singletonFM )
-import IdInfo		( SpecEnv, mkSpecEnv, SpecInfo(..) )
+module TcTyDecls (
+	tcTyDecl,
+	tcConDecl
+    ) where
+
+import Ubiq{-uitous-}
+
+import HsSyn		( TyDecl(..), ConDecl(..), BangType(..), MonoType )
+import RnHsSyn		( RenamedTyDecl(..), RenamedConDecl(..) )
+
+import TcMonoType	( tcMonoTypeKind, tcMonoType, tcContext )
+import TcEnv		( tcLookupTyCon, tcLookupTyVar, tcLookupClass )
+import TcMonad
+import TcKind		( TcKind, unifyKind, mkTcArrowKind, mkTcTypeKind )
+
+import Id		( mkDataCon, StrictnessMark(..) )
+import Kind		( Kind, mkArrowKind, mkBoxedTypeKind )
+import SpecEnv		( SpecEnv(..), nullSpecEnv )
+import Name		( getNameFullName, Name(..) )
 import Pretty
-import SpecTyFuns	( specialiseConstrTys )
-import TCE		-- ( nullTCE, unitTCE, lookupTCE, plusTCE, TCE(..), UniqFM )
-import TVE		( mkTVE, TVE(..) )
-import TcConDecls	( tcConDecls )
-import TcMonoType	( tcMonoType )
-import TcPragmas	( tcDataPragmas, tcTypePragmas )
-import Util
+import TyCon		( TyCon, ConsVisible(..), NewOrData(..), mkSynTyCon, mkDataTyCon )
+import Type		( getTypeKind )
+import TyVar		( getTyVarKind )
+import Util		( panic )
+
 \end{code}
 
-We consult the @CE@/@TCE@ arguments {\em only} to build knots!
+\begin{code}
+tcTyDecl :: RenamedTyDecl -> TcM s TyCon
+\end{code}
 
-The resulting @TCE@ has info about the type constructors in it; the
-@GVE@ has info about their data constructors.
+Type synonym decls
+~~~~~~~~~~~~~~~~~~
 
 \begin{code}
-tcTyDecls :: E
-	  -> (Name -> Bool)			-- given Name, is it an abstract synonym?
-	  -> (Name -> [RenamedDataTypeSig])	-- given Name, get specialisation pragmas
-	  -> [RenamedTyDecl]
-	  -> Baby_TcM (TCE, GVE, 
-		       FiniteMap TyCon [(Bool, [Maybe UniType])])
-						-- specialisations:
-						--   True  => imported data types i.e. from interface file
-						--   False => local data types i.e. requsted by source pragmas
-
-tcTyDecls e _ _ [] = returnB_Tc (nullTCE, nullGVE, emptyFM)
-
-tcTyDecls e is_abs_syn get_spec_sigs (tyd: tyds)
-  = tc_decl   tyd	    `thenB_Tc` \ (tce1, gve1, specs1) ->
-    tcTyDecls e is_abs_syn get_spec_sigs tyds
-			    `thenB_Tc` \ (tce2, gve2, specs2) ->
+tcTyDecl (TySynonym tycon_name tyvar_names rhs src_loc)
+  = tcAddSrcLoc 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) ->
+
+	-- Look at the rhs
+    tcMonoTypeKind rhs				`thenTc` \ (rhs_kind, rhs_ty) ->
+
+	-- Unify tycon kind with (k1->...->kn->rhs)
+    unifyKind tycon_kind
+	(foldr mkTcArrowKind rhs_kind tyvar_kinds)
+						`thenTc_`
     let
-	tce3   = tce1 `plusTCE` tce2
-	gve3   = gve1 `plusGVE` gve2
-	specs3 = specs1 `plusFM` specs2
+	-- Construct the tycon
+	result_kind, final_tycon_kind :: Kind 	-- NB not TcKind!
+	result_kind      = getTypeKind rhs_ty
+	final_tycon_kind = foldr (mkArrowKind . getTyVarKind) result_kind rec_tyvars
+
+	tycon = mkSynTyCon (getItsUnique tycon_name)
+			   (getNameFullName tycon_name)
+			   final_tycon_kind
+			   (length tyvar_names)
+			   rec_tyvars
+			   rhs_ty
     in
-    returnB_Tc (tce3, gve3, specs3)
-  where
-    rec_ce  = getE_CE  e
-    rec_tce = getE_TCE e
-
-    -- continued...
+    returnTc tycon
 \end{code}
 
-We don't need to substitute here, because the @TCE@s
-(which are at the top level) cannot contain free type variables.
+Algebraic data and newtype decls
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 
-Gather relevant info:
 \begin{code}
-    tc_decl (TyData context name@(PreludeTyCon uniq full_name arity True{-"data"-})
-		    tyvars con_decls derivings pragmas src_loc)
-			    -- ToDo: context
-      = tc_data_decl uniq name full_name arity tyvars con_decls
-		     derivings pragmas src_loc
-
-    tc_decl (TyData context name@(OtherTyCon uniq full_name arity True{-"data"-} _)
-		    tyvars con_decls derivings pragmas src_loc)
-			    -- ToDo: context
-      = tc_data_decl uniq name full_name arity tyvars con_decls
-		     derivings pragmas src_loc
-
-    tc_decl (TyData _ bad_name _ _ _ _ src_loc)
-      = failB_Tc (confusedNameErr "Bad name on a datatype constructor (a Prelude name?)"
-		    bad_name src_loc)
-
-    tc_decl (TySynonym name@(PreludeTyCon uniq full_name arity False{-"type"-})
-			tyvars mono_ty pragmas src_loc)
-      = tc_syn_decl uniq name full_name arity tyvars mono_ty pragmas src_loc
-
-    tc_decl (TySynonym name@(OtherTyCon uniq full_name arity False{-"type"-} _)
-			tyvars mono_ty pragmas src_loc)
-      = tc_syn_decl uniq name full_name arity tyvars mono_ty pragmas src_loc
-
-    tc_decl (TySynonym bad_name _ _ _ src_loc)
-      = failB_Tc (confusedNameErr "Bad name on a type-synonym constructor (a Prelude name?)"
-		    bad_name src_loc)
-\end{code}
+tcTyDecl (TyData context tycon_name tyvar_names con_decls derivings pragmas src_loc)
+  = tcTyDataOrNew DataType context tycon_name tyvar_names con_decls derivings pragmas src_loc
 
-Real work for @data@ declarations:
-\begin{code}
-    tc_data_decl uniq name full_name arity tyvars con_decls derivings pragmas src_loc
-      = addSrcLocB_Tc src_loc (
-	let
-	    (tve, new_tyvars, _) = mkTVE tyvars
-	    rec_tycon		 = lookupTCE rec_tce name
-		-- We know the lookup will succeed, because we are just
-		-- about to put it in the outgoing TCE!
-
-	    spec_sigs = get_spec_sigs name
-	in
-	tcSpecDataSigs rec_tce spec_sigs []	`thenB_Tc` \ user_spec_infos ->
-
-	recoverIgnoreErrorsB_Tc ([], []) (
-	    tcDataPragmas rec_tce tve rec_tycon new_tyvars pragmas
-	)		`thenB_Tc` \ (pragma_con_decls, pragma_spec_infos) ->
-	let
-	    (condecls_to_use, ignore_condecl_errors_if_pragma)
-	      = if null pragma_con_decls then
-	            (con_decls, id)
-	        else
-		    if null con_decls
-		    then (pragma_con_decls, recoverIgnoreErrorsB_Tc nullGVE)
-		    else panic "tcTyDecls:data: user and pragma condecls!"
-
-	    (imported_specs, specinfos_to_use)
-	      = if null pragma_spec_infos then
-		    (False, user_spec_infos)
-		else
-		    if null user_spec_infos
-		    then (True, pragma_spec_infos)
-		    else panic "tcTyDecls:data: user and pragma specinfos!"
-
-	    specenv_to_use = mkSpecEnv specinfos_to_use
-	in
-	ignore_condecl_errors_if_pragma
-	(tcConDecls rec_tce tve rec_tycon new_tyvars specenv_to_use condecls_to_use)
-							`thenB_Tc` \ gve ->
-	let
-	    condecls = map snd gve
-
-	    derived_classes = map (lookupCE rec_ce) derivings
-
-	    new_tycon
-	      = mkDataTyCon uniq
-			    full_name arity new_tyvars condecls
+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 data_or_new context tycon_name tyvar_names con_decls derivings pragmas src_loc
+  = tcAddSrcLoc src_loc $
+    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 ->
+
+	-- Typecheck the context
+    tcContext context				`thenTc` \ ctxt ->
+
+	-- Unify tycon kind with (k1->...->kn->Type)
+    unifyKind tycon_kind
+	(foldr mkTcArrowKind mkTcTypeKind tyvar_kinds)
+						`thenTc_`
+	-- Walk the condecls
+    mapTc (tcConDecl rec_tycon rec_tyvars ctxt) con_decls
+						`thenTc` \ con_ids ->
+    let
+	-- Construct the tycon
+	final_tycon_kind :: Kind 		-- NB not TcKind!
+	final_tycon_kind = foldr (mkArrowKind . getTyVarKind) mkBoxedTypeKind rec_tyvars
+
+	tycon = mkDataTyCon (getItsUnique tycon_name)
+			    final_tycon_kind
+			    (getNameFullName tycon_name)
+			    rec_tyvars
+			    ctxt
+			    con_ids
 			    derived_classes
-			    (null pragma_con_decls)
-			    -- if constrs are from pragma we are *abstract*
-
-	    spec_list
-	      = [(imported_specs, maybe_tys) | (SpecInfo maybe_tys _ _) <- specinfos_to_use]
-
-	    spec_map
-	      = if null spec_list then
-		    emptyFM
-		else
-		    singletonFM rec_tycon spec_list
-	in
-	returnB_Tc (unitTCE uniq new_tycon, gve, spec_map)
-	    -- It's OK to return pragma condecls in gve, even
-	    -- though some of those names should be "invisible",
-	    -- because the *renamer* is supposed to have dealt with
-	    -- naming/scope issues already.
-	)
+			    ConsVisible		-- For now; if constrs are from pragma we are *abstract*
+			    data_or_new
+    in
+    returnTc tycon
+  where
+    tc_derivs Nothing   = returnNF_Tc []
+    tc_derivs (Just ds) = mapNF_Tc tc_deriv ds
+
+    tc_deriv name
+      = tcLookupClass name `thenNF_Tc` \ (_, clas) ->
+	returnNF_Tc clas
 \end{code}
 
-Real work for @type@ (synonym) declarations:
+
+Constructors
+~~~~~~~~~~~~
 \begin{code}
-    tc_syn_decl uniq name full_name arity tyvars mono_ty pragmas src_loc
-      = addSrcLocB_Tc src_loc (
-
-	let (tve, new_tyvars, _) = mkTVE tyvars
-	in
-	tcMonoType rec_ce rec_tce tve mono_ty	`thenB_Tc` \ expansion ->
-	let
-	    -- abstractness info either comes from the interface pragmas
-	    -- (tcTypePragmas) or from a user-pragma in this module
-	    -- (is_abs_syn)
-	    abstract = tcTypePragmas pragmas
-		    || is_abs_syn name
-
-	    new_tycon = mkSynonymTyCon uniq full_name
-			    arity new_tyvars expansion (not abstract)
-	in
-	returnB_Tc (unitTCE uniq new_tycon, nullGVE, emptyFM)
-	)
-\end{code}
+tcConDecl :: TyCon -> [TyVar] -> [(Class,Type)] -> RenamedConDecl -> TcM s Id
 
-%************************************************************************
-%*									*
-\subsection{Specialisation Signatures for Data Type declarations}
-%*									*
-%************************************************************************
+tcConDecl tycon tyvars ctxt (ConDecl name btys src_loc)
+  = tcAddSrcLoc src_loc	$
+    let
+	(stricts, tys) = sep_bangs btys
+    in
+    mapTc tcMonoType tys `thenTc` \ arg_tys ->
+    let
+      data_con = mkDataCon (getItsUnique name)
+			   (getNameFullName name)
+			   stricts
+		      	   tyvars
+		      	   [] -- ToDo: ctxt; limited to tyvars in arg_tys
+		      	   arg_tys
+		      	   tycon
+			-- nullSpecEnv
+    in
+    returnTc data_con
 
-@tcSpecDataSigs@ checks data type specialisation signatures for
-validity, and returns the list of specialisation requests.
+tcConDecl tycon tyvars ctxt (ConOpDecl bty1 op bty2 src_loc)
+  = tcAddSrcLoc src_loc	$
+    let
+	(stricts, tys) = sep_bangs [bty1, bty2]
+    in
+    mapTc tcMonoType tys `thenTc` \ arg_tys ->
+    let
+      data_con = mkDataCon (getItsUnique op)
+			   (getNameFullName op)
+			   stricts
+		      	   tyvars
+		      	   [] -- ToDo: ctxt
+		      	   arg_tys
+		      	   tycon
+			-- nullSpecEnv
+    in
+    returnTc data_con
 
-\begin{code}
-tcSpecDataSigs :: TCE
-	       -> [RenamedDataTypeSig]
-	       -> [(RenamedDataTypeSig,SpecInfo)]
-	       -> Baby_TcM [SpecInfo]
-
-tcSpecDataSigs tce (s:ss) accum
-  = tc_sig s			`thenB_Tc` \ info  ->
-    tcSpecDataSigs tce ss ((s,info):accum)
-  where
-    tc_sig (SpecDataSig n ty src_loc)
-      = addSrcLocB_Tc src_loc (
-	let 
-	    ty_names  = extractMonoTyNames (==) ty
-	    (tve,_,_) = mkTVE ty_names
-	    fake_CE   = panic "tcSpecDataSigs:CE"
-	in
-	    -- Typecheck specialising type (includes arity check)
-	tcMonoType fake_CE tce tve ty			`thenB_Tc` \ tau_ty ->
-	let
-	    (_,ty_args,_) = getUniDataTyCon tau_ty
-	    is_unboxed_or_tyvar ty = isUnboxedDataType ty || isTyVarTemplateTy ty
-	in
-	    -- Check at least one unboxed type in specialisation
-	checkB_Tc (not (any isUnboxedDataType ty_args))
-		  (specDataNoSpecErr n ty_args src_loc) `thenB_Tc_`
-
-	    -- Check all types are unboxed or tyvars
-	    -- (specific boxed types are redundant)
-	checkB_Tc (not (all is_unboxed_or_tyvar ty_args))
-		  (specDataUnboxedErr n ty_args src_loc) `thenB_Tc_`
-
-	let
-	    maybe_tys     = specialiseConstrTys ty_args
-	in
-	returnB_Tc (SpecInfo maybe_tys 0 (panic "SpecData:SpecInfo:SpecId"))
-	)
-
-tcSpecDataSigs tce [] accum
-  = -- Remove any duplicates from accumulated specinfos
-    getSwitchCheckerB_Tc		`thenB_Tc` \ sw_chkr ->
-    
-    (if sw_chkr SpecialiseTrace && not (null duplicates) then
-	 pprTrace "Duplicate SPECIALIZE data pragmas:\n"
-	          (ppAboves (map specmsg sep_dups))
-     else id)(
-
-    (if sw_chkr SpecialiseTrace && not (null spec_infos) then
-	 pprTrace "Specialising "
-	          (ppHang (ppCat [ppr PprDebug name, ppStr "at types:"])
-			4 (ppAboves (map pp_spec spec_infos)))
-
-    else id) (
-
-    returnB_Tc (spec_infos)
-    ))
-  where
-    spec_infos = map (snd . head) equiv
+tcConDecl tycon tyvars ctxt (NewConDecl name ty src_loc)
+  = tcAddSrcLoc src_loc	$
+    tcMonoType ty `thenTc` \ arg_ty ->
+    let
+      data_con = mkDataCon (getItsUnique name)
+			   (getNameFullName name)
+			   [NotMarkedStrict]
+		      	   tyvars
+		      	   [] -- ToDo: ctxt
+		      	   [arg_ty]
+		      	   tycon
+			-- nullSpecEnv
+    in
+    returnTc data_con
 
-    equiv      = equivClasses cmp_info accum
-    duplicates = filter (not . singleton) equiv
+tcConDecl tycon tyvars ctxt (RecConDecl con fields src_loc)
+  = panic "tcConDecls:RecConDecl"
 
-    cmp_info (_, SpecInfo tys1 _ _) (_, SpecInfo tys2 _ _)
-      = cmpUniTypeMaybeList tys1 tys2
 
-    singleton [_] = True
-    singleton _   = False
+sep_bangs btys
+  = unzip (map sep_bang btys)
+  where 
+    sep_bang (Banged ty)   = (MarkedStrict, ty)
+    sep_bang (Unbanged ty) = (NotMarkedStrict, ty)
+\end{code}
+
+
+
+Errors and contexts
+~~~~~~~~~~~~~~~~~~~
+\begin{code}
+tySynCtxt tycon_name sty
+  = ppCat [ppStr "In the type declaration for", ppr sty tycon_name]
 
-    sep_dups = tail (concat (map ((:) Nothing . map Just) duplicates))
-    specmsg (Just (SpecDataSig _ ty locn, _))
-      = addShortErrLocLine locn ( \ sty -> ppr sty ty ) PprDebug
-    specmsg Nothing
-      = ppStr "***"
+tyDataCtxt tycon_name sty
+  = ppCat [ppStr "In the data declaration for", ppr sty tycon_name]
 
-    ((SpecDataSig name _ _, _):_) = accum    
-    pp_spec (SpecInfo tys _ _) = ppInterleave ppNil [pprMaybeTy PprDebug ty | ty <- tys]
+tyNewCtxt tycon_name sty
+  = ppCat [ppStr "In the newtype declaration for", ppr sty tycon_name]
 \end{code}
diff --git a/ghc/compiler/typecheck/TcType.lhs b/ghc/compiler/typecheck/TcType.lhs
new file mode 100644
index 0000000000..ed2794dc17
--- /dev/null
+++ b/ghc/compiler/typecheck/TcType.lhs
@@ -0,0 +1,322 @@
+\begin{code}
+module TcType (
+
+  TcTyVar(..),
+  newTcTyVar,
+  newTyVarTy,	-- Kind -> NF_TcM s (TcType s)
+  newTyVarTys,	-- Int -> Kind -> NF_TcM s [TcType s]
+
+
+  TcTyVarSet(..),
+
+  -----------------------------------------
+  TcType(..), TcMaybe(..),
+  TcTauType(..), TcThetaType(..), TcRhoType(..),
+
+	-- Find the type to which a type variable is bound
+  tcWriteTyVar,		-- :: TcTyVar s -> TcType s -> NF_TcM (TcType s)
+  tcReadTyVar,		-- :: TcTyVar s -> NF_TcM (TcMaybe s)
+
+
+  tcInstTyVar,    -- TyVar -> NF_TcM s (TcTyVar s)
+  tcInstType, tcInstTcType, tcInstTheta,
+
+--  zonkTcType,		-- TcType s     -> NF_TcM s (TcType s)
+--  zonkTcTheta,	-- TcThetaType s -> NF_TcM s (TcThetaType s)
+
+    zonkTcTyVars,	-- TcTyVarSet s -> NF_TcM s (TcTyVarSet s)
+    zonkTcType,		-- TcType s -> NF_TcM s (TcType s)
+    zonkTcTypeToType,	-- TcType s -> NF_TcM s Type
+    zonkTcTyVarToTyVar	-- TcTyVar s -> NF_TcM s TyVar
+
+  ) where
+
+
+
+-- friends:
+import Type	( Type(..), ThetaType(..), GenType(..), tyVarsOfTypes, getTyVar_maybe )
+import TyVar	( TyVar(..), GenTyVar(..), TyVarSet(..), GenTyVarSet(..), 
+		  tyVarSetToList
+		)
+
+-- others:
+import Kind	( Kind )
+import Usage	( Usage(..), GenUsage, UVar(..), duffUsage )
+import Class	( GenClass )
+import TcKind	( TcKind )
+import TcMonad
+
+import Ubiq
+import Unique		( Unique )
+import UniqFM		( UniqFM )
+import Name		( getNameShortName )
+import Maybes		( assocMaybe )
+import Util		( panic )
+\end{code}
+
+
+
+Data types
+~~~~~~~~~~
+
+\begin{code}
+type TcType s = GenType (TcTyVar s) UVar	-- Used during typechecker
+	-- Invariant on ForAllTy in TcTypes:
+	-- 	forall a. T
+	-- a cannot occur inside a MutTyVar in T; that is,
+	-- T is "flattened" before quantifying over a
+
+type TcThetaType s = [(Class, TcType s)]
+type TcRhoType s   = TcType s		-- No ForAllTys
+type TcTauType s   = TcType s		-- No DictTys or ForAllTys
+
+type Box s = MutableVar s (TcMaybe s)
+
+data TcMaybe s = UnBound
+	       | BoundTo (TcType s)
+
+-- Interestingly, you can't use (Maybe (TcType s)) instead of (TcMaybe s),
+-- because you get a synonym loop if you do!
+
+type TcTyVar s    = GenTyVar (Box s)
+type TcTyVarSet s = GenTyVarSet (Box s)
+\end{code}
+
+\begin{code}
+tcTyVarToTyVar :: TcTyVar s -> TyVar
+tcTyVarToTyVar (TyVar uniq kind name _) = TyVar uniq kind name duffUsage
+\end{code}
+
+Type instantiation
+~~~~~~~~~~~~~~~~~~
+
+\begin{code}
+newTcTyVar :: Maybe ShortName -> Kind -> NF_TcM s (TcTyVar s)
+newTcTyVar name kind
+  = tcGetUnique 	`thenNF_Tc` \ uniq ->
+    tcNewMutVar UnBound	`thenNF_Tc` \ box ->
+    returnNF_Tc (TyVar uniq kind name box)
+
+newTyVarTy  :: Kind -> NF_TcM s (TcType s)
+newTyVarTy kind
+  = newTcTyVar Nothing kind	`thenNF_Tc` \ tc_tyvar ->
+    returnNF_Tc (TyVarTy tc_tyvar)
+
+newTyVarTys :: Int -> Kind -> NF_TcM s [TcType s]
+newTyVarTys n kind = mapNF_Tc newTyVarTy (take n (repeat kind))
+
+tcInstTyVar :: TyVar -> NF_TcM s (TcTyVar s)
+tcInstTyVar tyvar@(TyVar uniq kind name _)
+  = newTcTyVar name kind
+\end{code}
+
+@tcInstType@ and @tcInstTcType@ both create a fresh instance of a
+type, returning a @TcType@. All inner for-alls are instantiated with
+fresh TcTyVars.
+
+There are two versions, one for instantiating a @Type@, and one for a @TcType@.
+The former must instantiate everything; all tyvars must be bound either
+by a forall or by an environment passed in.  The latter can do some sharing,
+and is happy with free tyvars (which is vital when instantiating the type
+of local functions).  In the future @tcInstType@ may try to be clever about not
+instantiating constant sub-parts.
+
+\begin{code}
+tcInstType :: [(TyVar,TcType s)] -> Type  -> NF_TcM s (TcType s)
+tcInstType tenv ty_to_inst
+  = do [(uniq,ty) | (TyVar uniq _ _ _, ty) <- tenv] ty_to_inst
+  where
+    do env (TyConTy tycon usage) = returnNF_Tc (TyConTy tycon usage)
+
+    do env (SynTy tycon tys ty)  = mapNF_Tc (do env) tys	`thenNF_Tc` \ tys' ->
+				   do env ty			`thenNF_Tc` \ ty' ->
+				   returnNF_Tc (SynTy tycon tys' ty')
+
+    do env (FunTy arg res usage)  = do env arg		`thenNF_Tc` \ arg' ->
+				    do env res		`thenNF_Tc` \ res' ->
+				    returnNF_Tc (FunTy arg' res' usage)
+
+    do env (AppTy fun arg)	  = do env fun		`thenNF_Tc` \ fun' ->
+				    do env arg		`thenNF_Tc` \ arg' ->
+				    returnNF_Tc (AppTy fun' arg')
+
+    do env (DictTy clas ty usage)= do env ty		`thenNF_Tc` \ ty' ->
+				   returnNF_Tc (DictTy clas ty' usage)
+
+    do env (TyVarTy (TyVar uniq kind name _))
+	= case assocMaybe env uniq of
+		Just tc_ty -> returnNF_Tc tc_ty
+		Nothing    -> panic "tcInstType"
+
+    do env (ForAllTy (TyVar uniq kind name _) ty)
+	= newTcTyVar name kind	`thenNF_Tc` \ tc_tyvar ->
+	  let
+		new_env = (uniq, TyVarTy tc_tyvar) : env
+	  in
+	  do new_env ty	`thenNF_Tc` \ ty' ->
+	  returnNF_Tc (ForAllTy tc_tyvar ty')
+
+   -- ForAllUsage impossible
+
+
+tcInstTheta :: [(TyVar,TcType s)] -> ThetaType -> NF_TcM s (TcThetaType s)
+tcInstTheta tenv theta
+  = mapNF_Tc go theta
+  where
+    go (clas,ty) = tcInstType tenv ty 	`thenNF_Tc` \ tc_ty ->
+		   returnNF_Tc (clas, tc_ty)
+
+tcInstTcType ::  [(TcTyVar s,TcType s)] -> TcType s -> NF_TcM s (TcType s)
+tcInstTcType tenv ty_to_inst
+  = do [(uniq,ty) | (TyVar uniq _ _ _, ty) <- tenv] ty_to_inst
+  where
+    do env ty@(TyConTy tycon usage) = returnNF_Tc ty
+
+-- Could do clever stuff here to avoid instantiating constant types
+    do env (SynTy tycon tys ty)  = mapNF_Tc (do env) tys	`thenNF_Tc` \ tys' ->
+				   do env ty			`thenNF_Tc` \ ty' ->
+				   returnNF_Tc (SynTy tycon tys' ty')
+
+    do env (FunTy arg res usage)  = do env arg		`thenNF_Tc` \ arg' ->
+				    do env res		`thenNF_Tc` \ res' ->
+				    returnNF_Tc (FunTy arg' res' usage)
+
+    do env (AppTy fun arg)	  = do env fun		`thenNF_Tc` \ fun' ->
+				    do env arg		`thenNF_Tc` \ arg' ->
+				    returnNF_Tc (AppTy fun' arg')
+
+    do env (DictTy clas ty usage)= do env ty		`thenNF_Tc` \ ty' ->
+				   returnNF_Tc (DictTy clas ty' usage)
+
+    do env ty@(TyVarTy (TyVar uniq kind name _))
+	= case assocMaybe env uniq of
+		Just tc_ty -> returnNF_Tc tc_ty
+		Nothing    -> returnNF_Tc ty
+
+    do env (ForAllTy (TyVar uniq kind name _) ty)
+	= newTcTyVar name kind	`thenNF_Tc` \ tc_tyvar ->
+	  let
+		new_env = (uniq, TyVarTy tc_tyvar) : env
+	  in
+	  do new_env ty	`thenNF_Tc` \ ty' ->
+	  returnNF_Tc (ForAllTy tc_tyvar ty')
+
+   -- ForAllUsage impossible
+\end{code}
+
+Reading and writing TcTyVars
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+\begin{code}
+tcWriteTyVar :: TcTyVar s -> TcType s -> NF_TcM s ()
+tcReadTyVar  :: TcTyVar s -> NF_TcM s (TcMaybe s)
+\end{code}
+
+Writing is easy:
+
+\begin{code}
+tcWriteTyVar (TyVar uniq kind name box) ty = tcWriteMutVar box (BoundTo ty)
+\end{code}
+
+Reading is more interesting.  The easy thing to do is just to read, thus:
+\begin{verbatim}
+tcReadTyVar (TyVar uniq kind name box) = tcReadMutVar box
+\end{verbatim}
+
+But it's more fun to short out indirections on the way: If this
+version returns a TyVar, then that TyVar is unbound.  If it returns
+any other type, then there might be bound TyVars embedded inside it.
+
+We return Nothing iff the original box was unbound.
+
+\begin{code}
+tcReadTyVar (TyVar uniq kind name box)
+  = tcReadMutVar box	`thenNF_Tc` \ maybe_ty ->
+    case maybe_ty of
+	UnBound    -> returnNF_Tc UnBound
+	BoundTo ty -> short_out ty			`thenNF_Tc` \ ty' ->
+		      tcWriteMutVar box (BoundTo ty')	`thenNF_Tc_`
+		      returnNF_Tc (BoundTo ty')
+
+short_out :: TcType s -> NF_TcM s (TcType s)
+short_out ty@(TyVarTy (TyVar uniq kind name box))
+  = tcReadMutVar box	`thenNF_Tc` \ maybe_ty ->
+    case maybe_ty of
+	UnBound     -> returnNF_Tc ty
+	BoundTo ty' -> short_out ty' 			`thenNF_Tc` \ ty' ->
+		       tcWriteMutVar box (BoundTo ty')	`thenNF_Tc_`
+		       returnNF_Tc ty'
+
+short_out other_ty = returnNF_Tc other_ty
+\end{code}
+
+
+Zonking
+~~~~~~~
+@zonkTcTypeToType@ converts from @TcType@ to @Type@.  It follows through all
+the substitutions of course.
+
+\begin{code}
+zonkTcTypeToType :: TcType s -> NF_TcM s Type
+zonkTcTypeToType ty = zonk tcTyVarToTyVar ty
+
+zonkTcType :: TcType s -> NF_TcM s (TcType s)
+zonkTcType ty = zonk (\tyvar -> tyvar) ty
+
+zonkTcTyVars :: TcTyVarSet s -> NF_TcM s (TcTyVarSet s)
+zonkTcTyVars tyvars
+  = mapNF_Tc (zonk_tv (\tyvar -> tyvar)) 
+	     (tyVarSetToList tyvars)		`thenNF_Tc` \ tys ->
+    returnNF_Tc (tyVarsOfTypes tys)
+
+zonkTcTyVarToTyVar :: TcTyVar s -> NF_TcM s TyVar
+zonkTcTyVarToTyVar tyvar
+  = zonk_tv_to_tv tcTyVarToTyVar tyvar
+
+
+zonk tyvar_fn (TyVarTy tyvar)
+  = zonk_tv tyvar_fn tyvar
+
+zonk tyvar_fn (AppTy ty1 ty2)
+  = zonk tyvar_fn ty1		`thenNF_Tc` \ ty1' ->
+    zonk tyvar_fn ty2		`thenNF_Tc` \ ty2' ->
+    returnNF_Tc (AppTy ty1' ty2')
+
+zonk tyvar_fn (TyConTy tc u)
+  = returnNF_Tc (TyConTy tc u)
+
+zonk tyvar_fn (SynTy tc tys ty)
+  = mapNF_Tc (zonk tyvar_fn) tys `thenNF_Tc` \ tys' ->
+    zonk tyvar_fn ty 		 `thenNF_Tc` \ ty' ->
+    returnNF_Tc (SynTy tc tys' ty')
+
+zonk tyvar_fn (ForAllTy tv ty)
+  = zonk_tv_to_tv tyvar_fn tv	`thenNF_Tc` \ tv' ->
+    zonk tyvar_fn ty 		`thenNF_Tc` \ ty' ->
+    returnNF_Tc (ForAllTy tv' ty')
+
+zonk tyvar_fn (ForAllUsageTy uv uvs ty)
+  = panic "zonk:ForAllUsageTy"
+
+zonk tyvar_fn (FunTy ty1 ty2 u)
+  = zonk tyvar_fn ty1 		`thenNF_Tc` \ ty1' ->
+    zonk tyvar_fn ty2 		`thenNF_Tc` \ ty2' ->
+    returnNF_Tc (FunTy ty1' ty2' u)
+
+zonk tyvar_fn (DictTy c ty u)
+  = zonk tyvar_fn ty 		`thenNF_Tc` \ ty' ->
+    returnNF_Tc (DictTy c ty' u)
+
+
+zonk_tv tyvar_fn tyvar
+  = tcReadTyVar tyvar		`thenNF_Tc` \ maybe_ty ->
+    case maybe_ty of
+	UnBound    -> returnNF_Tc (TyVarTy (tyvar_fn tyvar))
+	BoundTo ty -> zonk tyvar_fn ty
+
+
+zonk_tv_to_tv tyvar_fn tyvar
+  = zonk_tv tyvar_fn tyvar	`thenNF_Tc` \ ty ->
+    case getTyVar_maybe ty of
+	Nothing    -> panic "zonk_tv_to_tv"
+	Just tyvar -> returnNF_Tc tyvar
+\end{code}
diff --git a/ghc/compiler/typecheck/Typecheck.hi b/ghc/compiler/typecheck/Typecheck.hi
deleted file mode 100644
index dc666f2768..0000000000
--- a/ghc/compiler/typecheck/Typecheck.hi
+++ /dev/null
@@ -1,60 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface Typecheck where
-import AbsSyn(Module)
-import Bag(Bag)
-import CE(CE(..))
-import Class(Class)
-import CmdLineOpts(GlobalSwitch)
-import E(E)
-import ErrUtils(Error(..))
-import FiniteMap(FiniteMap)
-import HsBinds(Bind, Binds, Sig)
-import HsDecls(ClassDecl, DataTypeSig, DefaultDecl, FixityDecl, InstDecl, SpecialisedInstanceSig, TyDecl)
-import HsExpr(ArithSeqInfo, Expr, Qual)
-import HsImpExp(IE, ImportedInterface)
-import HsLit(Literal)
-import HsMatches(Match)
-import HsPat(InPat, RenamedPat(..), TypecheckedPat)
-import HsTypes(PolyType)
-import Id(Id)
-import Inst(Inst)
-import Maybes(Labda, MaybeErr)
-import Name(Name)
-import NameTypes(FullName, ShortName)
-import PreludePS(_PackedString)
-import Pretty(PprStyle, Pretty(..), PrettyRep)
-import ProtoName(ProtoName)
-import SplitUniq(SplitUniqSupply)
-import SrcLoc(SrcLoc)
-import TcInstDcls(InstInfo)
-import TyCon(TyCon)
-import TyVar(TyVar)
-import UniType(UniType)
-import UniqFM(UniqFM)
-import Unique(Unique)
-data Module a b 
-data Bag a 
-type CE = UniqFM Class
-data GlobalSwitch 
-data E 
-type Error = PprStyle -> Int -> Bool -> PrettyRep
-data Binds a b 
-data FixityDecl a 
-data Expr a b 
-data InPat a 
-type RenamedPat = InPat Name
-data TypecheckedPat 
-data Id 
-data Inst 
-data Labda a 
-data MaybeErr a b 
-data Name 
-data PprStyle 
-type Pretty = Int -> Bool -> PrettyRep
-data PrettyRep 
-data ProtoName 
-data SplitUniqSupply 
-data InstInfo 
-data UniqFM a 
-typecheckModule :: (GlobalSwitch -> Bool) -> SplitUniqSupply -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> Module Name (InPat Name) -> MaybeErr ((Binds Id TypecheckedPat, Binds Id TypecheckedPat, Binds Id TypecheckedPat, [(Inst, Expr Id TypecheckedPat)]), ([FixityDecl Name], [Id], UniqFM Class, UniqFM TyCon, Bag InstInfo), FiniteMap TyCon [(Bool, [Labda UniType])], E, PprStyle -> Int -> Bool -> PrettyRep) (Bag (PprStyle -> Int -> Bool -> PrettyRep))
-
diff --git a/ghc/compiler/typecheck/Typecheck.lhs b/ghc/compiler/typecheck/Typecheck.lhs
index 57a2dd657a..f86c7dee49 100644
--- a/ghc/compiler/typecheck/Typecheck.lhs
+++ b/ghc/compiler/typecheck/Typecheck.lhs
@@ -1,5 +1,5 @@
 %
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
 %
 \section[Typecheck]{Outside-world interfaces to the typechecker}
 
@@ -7,77 +7,66 @@
 #include "HsVersions.h"
 
 module Typecheck (
-	typecheckModule,
-
-	-- and to make the interface self-sufficient...
-	Module, Bag, CE(..), Binds, FixityDecl, E, Expr, InPat,
-	RenamedPat(..), TypecheckedPat, Id, Inst, Maybe, MaybeErr,
-	Name, PprStyle, PrettyRep, ProtoName, Error(..), Pretty(..),
-	InstInfo, SplitUniqSupply, GlobalSwitch, UniqFM
+	typecheckModule, InstInfo
     ) where
 
-import TcMonad		-- typechecking monad machinery
-import AbsSyn		-- the stuff being typechecked
+import Ubiq
+import TcMonad
+import TcModule		( tcModule )
+import TcInstUtil	( InstInfo )
+
+import HsSyn
+import RnHsSyn
+import TcHsSyn
 
-import E		( nullE, E )
+import ErrUtils		( TcWarning(..), TcError(..) )
+import Pretty
+import RnUtils		( GlobalNameMappers(..), GlobalNameMapper(..) )
 import Maybes		( MaybeErr(..) )
-import SrcLoc		( mkUnknownSrcLoc, SrcLoc )
-import TcModule		-- tcModule, and associated stuff
-import Util		-- for pragmas only
 \end{code}
 
 The typechecker stuff lives inside a complicated world of @TcM@
-monadery.  This module provides three interfaces into that world, one
-for typechecking a module, another for typechecking an expression, and
-one for typechecking an interface.  This last one works as if
-@typecheckModule@ was applied to the very simple module:
-\begin{verbatim}
-module EmptyModule where
-
-import InterfaceOfInterest
-\end{verbatim}
-This is used when we want to augment an @E@ with information from an
-interface.  (Used in the interpreter.)
+monadery. 
+
+ToDo: Interfaces for interpreter ...
+	Typecheck an expression
+	Typecheck an interface
 
 \begin{code}
-typecheckModule ::
-       (GlobalSwitch -> Bool)	-- cmd-line switch checker
-    -> SplitUniqSupply		-- name supply in
-    -> GlobalNameFuns		-- renamer info (for doing derivings)
-    -> RenamedModule		-- input module
-	
-    ->	------- OUTPUTS -----------
-	-- depends v much on whether typechecking succeeds or not!
+typecheckModule
+    :: UniqSupply		-- name supply in
+    -> GlobalNameMappers	-- renamer info (for doing derivings)
+    -> RenamedHsModule		-- input module
+
+    -> -- OUTPUTS ...
     MaybeErr
        -- SUCCESS ...
-       (((TypecheckedBinds,	-- binds from class decls; does NOT
-				--    include default-methods bindings
-	 TypecheckedBinds,	-- binds from instance decls; INCLUDES
-				--    class default-methods binds
-	 TypecheckedBinds,	-- binds from value decls
-	 [(Inst, TypecheckedExpr)]),
-
-	([RenamedFixityDecl],	-- things for the interface generator
-	 [Id],			-- to look at...
-	 CE,
-	 TCE,
-	 Bag InstInfo),
-
-	FiniteMap TyCon [(Bool, [Maybe UniType])],
+      (((TypecheckedHsBinds,	   -- binds from class decls; does NOT
+				   --    include default-methods bindings
+	 TypecheckedHsBinds,	   -- binds from instance decls; INCLUDES
+				   --    class default-methods binds
+	 TypecheckedHsBinds,	   -- binds from value decls
+
+	 [(Id, TypecheckedHsExpr)] -- constant instance binds
+	),
+
+        ([RenamedFixityDecl], [Id], UniqFM TyCon, UniqFM Class, Bag InstInfo),
+				-- things for the interface generator
+
+        (UniqFM TyCon, UniqFM Class),
+				-- environments of info from this module only
+
+	FiniteMap TyCon [(Bool, [Maybe Type])],
 				-- source tycon specialisation requests
 
---UNUSED:	E,			-- new cumulative E (with everything)
-	E,			-- E just for stuff from THIS module
-		-- NB: if you want the diff between two prev Es: i.e.,
-		-- things in cumulative E that were added because of
-		-- this module's import-ery, just do:
-		--	bigE `minusE` thisModuleE
+    	PprStyle->Pretty),	-- stuff to print for -ddump-deriving
 
-    	PprStyle->Pretty))	-- stuff to print for -ddump-deriving
+       Bag TcWarning)		-- pretty-print this to get warnings
 
        -- FAILURE ...
-       (Bag Error)		-- pretty-print this to find out what went wrong
+      (Bag TcError,		-- pretty-print this to get errors
+       Bag TcWarning)		-- pretty-print this to get warnings
 
-typecheckModule sw_chkr us renamer_name_funs modyule
-  = initTc sw_chkr us (tcModule nullE renamer_name_funs modyule)
+typecheckModule us renamer_name_funs mod
+  = initTc us (tcModule renamer_name_funs mod)
 \end{code}
diff --git a/ghc/compiler/typecheck/Unify.hi b/ghc/compiler/typecheck/Unify.hi
deleted file mode 100644
index a0e98d3779..0000000000
--- a/ghc/compiler/typecheck/Unify.hi
+++ /dev/null
@@ -1,15 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface Unify where
-import Bag(Bag)
-import CmdLineOpts(GlobalSwitch)
-import ErrsTc(UnifyErrContext)
-import Pretty(PprStyle, PrettyRep)
-import SplitUniq(SplitUniqSupply)
-import SrcLoc(SrcLoc)
-import Subst(Subst)
-import TcMonad(TcResult)
-import UniType(UniType)
-unifyTauTy :: UniType -> UniType -> UnifyErrContext -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult ()
-unifyTauTyList :: [UniType] -> UnifyErrContext -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult ()
-unifyTauTyLists :: [UniType] -> [UniType] -> UnifyErrContext -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult ()
-
diff --git a/ghc/compiler/typecheck/Unify.lhs b/ghc/compiler/typecheck/Unify.lhs
index e97f59d61e..74c2755854 100644
--- a/ghc/compiler/typecheck/Unify.lhs
+++ b/ghc/compiler/typecheck/Unify.lhs
@@ -1,5 +1,5 @@
 %
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
 %
 \section[Unify]{Unifier}
 
@@ -11,44 +11,24 @@ updatable substitution).
 
 module Unify ( unifyTauTy, unifyTauTyList, unifyTauTyLists ) where
 
-IMPORT_Trace		-- ToDo: rm (debugging only)
-import Outputable
-import Pretty
+import Ubiq
 
-import AbsSyn
+-- friends: 
 import TcMonad
-
-import CmdLineOpts	( GlobalSwitch(..) )
-import CoreLift		( isUnboxedButNotState )
-import Errors		( unifyErr, UnifyErrInfo(..), UnifyErrContext  )
-import Id		( Id, DataCon(..), Inst )
-import Maybes		( Maybe(..) )
-import Subst		( extendSubst, SubstResult(..), Subst )
-#if USE_ATTACK_PRAGMAS
-import Class		( Class(..), cmpClass ) -- .. for pragmas only
-import TyCon		( TyCon(..), isBoxedTyCon, isVisibleSynTyCon, cmpTyCon )
-			-- .. on TyCon is for pragmas only
-import TyVar		-- make all visible for pragmas
-import UniTyFuns	( pprUniType, pprTyCon ) 
-#else
-import Class		( Class )
-import TyVar		( TyVar(..), TyVarTemplate )
-import TyCon		( TyCon, isBoxedTyCon, isVisibleSynTyCon )
-#endif
-import UniType		( UniType(..), TauType(..)
-			  IF_ATTACK_PRAGMAS(COMMA cmpUniType)
-			)
+import Type	( GenType(..), getTypeKind )
+import TyCon	( TyCon(..), ConsVisible, NewOrData )
+import TyVar	( GenTyVar(..), TyVar(..) )
+import TcType	( TcType(..), TcMaybe(..), TcTauType(..), TcTyVar(..),
+		  tcReadTyVar, tcWriteTyVar
+		)
+-- others:
+import Kind	( Kind, isSubKindOf )
+import PprType	( GenTyVar, GenType )	-- instances
+import Pretty
+import Unique	( Unique )		-- instances
 import Util
 \end{code}
 
-%************************************************************************
-%*									*
-\subsection[Unify-spec]{Specification}
-%*									*
-%************************************************************************
-
-CLAIM: the unifier works correctly even if the types to be unified are not
-fixed points of the substitution.
 
 %************************************************************************
 %*									*
@@ -62,18 +42,23 @@ non-exported generic functions.
 Unify two @TauType@s.  Dead straightforward.
 
 \begin{code}
-unifyTauTy :: TauType -> TauType -> UnifyErrContext -> TcM ()
-
-unifyTauTy ty1 ty2 err_ctxt = uTys ty1 ty1 ty2 ty2 err_ctxt
+unifyTauTy :: TcTauType s -> TcTauType s -> TcM s ()
+unifyTauTy ty1 ty2 
+  = tcAddErrCtxt (unifyCtxt ty1 ty2) $
+    uTys ty1 ty1 ty2 ty2
 \end{code}
 
-@unifyTauTyLists@ unifies corresponding elements of its two list
-arguments.  The lists should be of equal length.
+@unifyTauTyList@ unifies corresponding elements of two lists of
+@TauType@s.  It uses @uTys@ to do the real work.  The lists should be
+of equal length.  We charge down the list explicitly so that we can
+complain if their lengths differ.
 
 \begin{code}
-unifyTauTyLists :: [TauType] -> [TauType] -> UnifyErrContext -> TcM ()
-
-unifyTauTyLists tys1 tys2 err_ctxt = uList tys1 tys2 err_ctxt
+unifyTauTyLists :: [TcTauType s] -> [TcTauType s] ->  TcM s ()
+unifyTauTyLists [] 	     []	        = returnTc ()
+unifyTauTyLists (ty1:tys1) (ty2:tys2) = uTys ty1 ty1 ty2 ty2   `thenTc_`
+					unifyTauTyLists tys1 tys2
+unifyTauTypeLists ty1s ty2s = panic "Unify.unifyTauTypeLists: mismatched type lists!"
 \end{code}
 
 @unifyTauTyList@ takes a single list of @TauType@s and unifies them
@@ -81,38 +66,11 @@ all together.  It is used, for example, when typechecking explicit
 lists, when all the elts should be of the same type.
 
 \begin{code}
-unifyTauTyList :: [TauType] -> UnifyErrContext -> TcM ()
-
-unifyTauTyList []   _ = returnTc ()
-unifyTauTyList [ty] _ = returnTc ()
-
-unifyTauTyList (ty1:tys@(ty2:_)) err_ctxt
-  = unifyTauTy ty1 ty2 err_ctxt	`thenTc_`
-    unifyTauTyList tys err_ctxt
-\end{code}
-
-%************************************************************************
-%*									*
-\subsection[Unify-lists-of-types]{@uList@}
-%*									*
-%************************************************************************
-
-@uList@ unifies corresponding elements of two lists of @TauType@s.  It
-uses @uTys@ to do the real work.  We charge down the list explicitly
-so that we can complain if their lengths differ.
-
-\begin{code}
-uList :: [TauType] -> [TauType]
-      -> UnifyErrContext
-      -> TcM ()
-
-uList [] [] _ = returnTc ()
-
-uList (ty1:tys1) (ty2:tys2) err_ctxt
-  = uTys ty1 ty1 ty2 ty2 err_ctxt   `thenTc_`
-    uList tys1 tys2 err_ctxt
-
-uList ty1s ty2s _ = panic "Unify.uList: mismatched type lists!"
+unifyTauTyList :: [TcTauType s] -> TcM s ()
+unifyTauTyList []		 = returnTc ()
+unifyTauTyList [ty]		 = returnTc ()
+unifyTauTyList (ty1:tys@(ty2:_)) = unifyTauTy ty1 ty2	`thenTc_`
+				   unifyTauTyList tys
 \end{code}
 
 %************************************************************************
@@ -130,96 +88,126 @@ de-synonym'd version.  This way we get better error messages.
 We call the first one \tr{ps_ty1}, \tr{ps_ty2} for ``possible synomym''.
 
 \begin{code}
-uTys :: TauType -> TauType	-- Error reporting ty1 and real ty1
-     -> TauType -> TauType	-- Error reporting ty2 and real ty2
-     -> UnifyErrContext
-     -> TcM ()
+uTys :: TcTauType s -> TcTauType s	-- Error reporting ty1 and real ty1
+     -> TcTauType s -> TcTauType s	-- Error reporting ty2 and real ty2
+     -> TcM s ()
+
+	-- Variables; go for uVar
+uTys ps_ty1 (TyVarTy tyvar1) ps_ty2 ty2 = uVar tyvar1 ps_ty2 ty2
+uTys ps_ty1 ty1 ps_ty2 (TyVarTy tyvar2) = uVar tyvar2 ps_ty1 ty1
+
+	-- Applications and functions; just check the two parts
+uTys _ (FunTy fun1 arg1 _) _ (FunTy fun2 arg2 _)
+  = uTys fun1 fun1 fun2 fun2	`thenTc_`    uTys arg1 arg1 arg2 arg2
+uTys _ (AppTy fun1 arg1) _ (AppTy fun2 arg2)
+  = uTys fun1 fun1 fun2 fun2	`thenTc_`    uTys arg1 arg1 arg2 arg2
+
+	-- Type constructors must match
+uTys ps_ty1 (TyConTy con1 _) ps_ty2 (TyConTy con2 _)
+  = checkTc (con1 == con2) (unifyMisMatch ps_ty1 ps_ty2)
+
+	-- Always expand synonyms (see notes at end)
+uTys ps_ty1 (SynTy con1 args1 ty1) ps_ty2 ty2 = uTys ps_ty1 ty1 ps_ty2 ty2
+uTys ps_ty1 ty1 ps_ty2 (SynTy con2 args2 ty2) = uTys ps_ty1 ty1 ps_ty2 ty2
+
+	-- Special case: converts  (->) a b  to  a -> b
+uTys ps_ty1 (AppTy (AppTy (TyConTy FunTyCon u) fun) arg) ps_ty2 ty2
+  = uTys ps_ty1 (FunTy fun arg u) ps_ty2 ty2
+uTys ps_ty1 ty1 ps_ty2 (AppTy (AppTy (TyConTy FunTyCon u) fun) arg)
+  = uTys ps_ty1 ty1 ps_ty2 (FunTy fun arg u)
+
+	-- Anything else fails
+uTys ps_ty1 ty1 ps_ty2 ty2  = failTc (unifyMisMatch ps_ty1 ps_ty2)
 \end{code}
 
-%********************************************************
-%*							*
-Sanity check: should never find a UniTyVarTemplate
-%*							*
-%********************************************************
-
-\begin{code}
-#ifdef DEBUG
-
-uTys ps_ty1 ty1@(UniTyVarTemplate tv1) ps_ty2 ty2 err_ctxt
-  = pprPanic "Unify:uTys:unifying w/ UniTyVarTemplate(1):" (ppCat [ppr PprDebug tv1, ppr PprDebug ty2])
-
-uTys ps_ty1 ty1 ps_ty2 ty2@(UniTyVarTemplate tv2) err_ctxt
-  = pprPanic "Unify:uTys:unifying w/ UniTyVarTemplate(2):" (ppCat [ppr PprDebug ty1, ppr PprDebug tv2])
-
-#endif {-DEBUG-}
-\end{code}
-
-%********************************************************
-%*							*
-Both variables:
-%*							*
-%********************************************************
-
-\begin{code}
-uTys ps_ty1 (UniTyVar tyvar1) ps_ty2 ty2 err_ctxt = uVar tyvar1 ps_ty2 ty2 err_ctxt
-uTys ps_ty1 ty1 ps_ty2 (UniTyVar tyvar2) err_ctxt = uVar tyvar2 ps_ty1 ty1 err_ctxt
-\end{code}
-
-%********************************************************
-%*							*
-Both function constructors:
-%*							*
-%********************************************************
+%************************************************************************
+%*									*
+\subsection[Unify-uVar]{@uVar@: unifying with a type variable}
+%*									*
+%************************************************************************
 
-\begin{code}
-uTys _ (UniFun fun1 arg1) _ (UniFun fun2 arg2) err_ctxt
-  = uList [fun1, arg1] [fun2, arg2] err_ctxt
-\end{code}
+@uVar@ is called when at least one of the types being unified is a
+variable.  It does {\em not} assume that the variable is a fixed point
+of the substitution; rather, notice that @bindTo@ (defined below) nips
+back into @uTys@ if it turns out that the variable is already bound.
 
-%********************************************************
-%*							*
-Both datatype constructors:
-%*							*
-%********************************************************
+There is a slight worry that one might try to @bindTo@ a (say) Poly
+tyvar (as tv1) with an Open tyvar (as ty2) which is already unified to
+an unboxed type.  In fact this can't happen, because the Open ones are
+always the ones which are unified away.
 
 \begin{code}
-uTys ps_ty1 ty1@(UniData con1 args1) ps_ty2 ty2@(UniData con2 args2) err_ctxt
-  = if (con1 == con2) then
-	-- Same constructors, just unify the arguments
-	uList args1 args2 err_ctxt
-    else
-	-- Different constructors: disaster
-	getSrcLocTc		`thenNF_Tc` \ src_loc ->
-	failTc (unifyErr (UnifyMisMatch ps_ty1 ps_ty2) err_ctxt src_loc)
-\end{code}
-
-%********************************************************
-%*							*
-Type synonyms:
-%*							*
-%********************************************************
+uVar :: TcTyVar s
+     -> TcTauType s -> TcTauType s	-- printing and real versions
+     -> TcM s ()
 
-If just one or the other is a synonym, just expand it.
+uVar tv1 ps_ty2 ty2
+  = tcReadTyVar tv1	`thenNF_Tc` \ maybe_ty1 ->
+    case maybe_ty1 of
+	BoundTo ty1 -> uTys ty1 ty1 ps_ty2 ty2
+	UnBound  -> uUnboundVar tv1 ps_ty2 ty2
 
-\begin{code}
-uTys ps_ty1 (UniSyn con1 args1 ty1) ps_ty2 ty2 err_ctxt
- | isVisibleSynTyCon con1
- = uTys ps_ty1 ty1 ps_ty2 ty2 err_ctxt
-
-uTys ps_ty1 ty1 ps_ty2 (UniSyn con2 args2 ty2) err_ctxt
- | isVisibleSynTyCon con2
- = uTys ps_ty1 ty1 ps_ty2 ty2 err_ctxt
+	-- Expand synonyms
+uUnboundVar tv1 ps_ty2 (SynTy _ _ ty2) = uUnboundVar tv1 ps_ty2 ty2
+
+
+	-- The both-type-variable case
+uUnboundVar tv1@(TyVar uniq1 kind1 name1 box1)
+	    ps_ty2
+	    ty2@(TyVarTy tv2@(TyVar uniq2 kind2 name2 box2))
+
+	-- Same type variable => no-op
+  | uniq1 == uniq2
+  = returnTc ()
+
+	-- Distinct type variables
+  | otherwise
+  = tcReadTyVar tv2	`thenNF_Tc` \ maybe_ty2 ->
+    case maybe_ty2 of
+	BoundTo ty2' -> uUnboundVar tv1 ty2' ty2'
+	UnBound   -> if kind2 `isSubKindOf` kind1 then
+			tcWriteTyVar tv1 ty2		`thenNF_Tc_` returnTc ()
+		     else if kind1 `isSubKindOf` kind2 then
+			tcWriteTyVar tv2 (TyVarTy tv1)	`thenNF_Tc_` returnTc ()
+		     else
+			failTc (unifyKindErr tv1 ps_ty2)
+
+	-- Second one isn't a type variable
+uUnboundVar tv1@(TyVar uniq1 kind1 name1 box1) ps_ty2 non_var_ty2
+  = occur_check non_var_ty2			`thenTc_`
+    checkTc (getTypeKind non_var_ty2 `isSubKindOf` kind1)
+	    (unifyKindErr tv1 ps_ty2)		`thenTc_`
+    tcWriteTyVar tv1 non_var_ty2		`thenNF_Tc_`
+    returnTc ()
+  where
+    occur_check (TyVarTy tv2@(TyVar uniq2 _ _ box2))
+       | uniq1 == uniq2		-- Same tyvar; fail
+       = failTc (unifyOccurCheck tv1 ps_ty2)
+
+       | otherwise		-- A different tyvar
+       = tcReadTyVar tv2	`thenNF_Tc` \ maybe_ty2 ->
+	 case maybe_ty2 of
+		BoundTo ty2' -> occur_check ty2'
+		UnBound   -> returnTc ()
+
+    occur_check (AppTy fun arg)   = occur_check fun `thenTc_` occur_check arg
+    occur_check (FunTy fun arg _) = occur_check fun `thenTc_` occur_check arg
+    occur_check (TyConTy _ _)	  = returnTc ()
+    occur_check (SynTy _ _ ty2)   = occur_check ty2
+    occur_check other		  = panic "Unexpected Dict or ForAll in occurCheck"
 \end{code}
 
+Notes on synonyms
+~~~~~~~~~~~~~~~~~
 If you are tempted to make a short cut on synonyms, as in this
 pseudocode...
 
 \begin{verbatim}
-uTys (UniSyn con1 args1 ty1) (UniSyn con2 args2 ty2)
+uTys (SynTy con1 args1 ty1) (SynTy con2 args2 ty2)
   = if (con1 == con2) then
 	-- Good news!  Same synonym constructors, so we can shortcut
 	-- by unifying their arguments and ignoring their expansions.
-	uList args1 args2
+	unifyTauTypeLists args1 args2
     else
 	-- Never mind.  Just expand them and try again
 	uTys ty1 ty2
@@ -260,102 +248,27 @@ somehow as needing expansion, perhaps also issuing a warning to the
 user.
 \end{quotation}
 
-Still, if the synonym is abstract, we can only just go ahead and try!
-
-\begin{code}
-uTys ps_ty1 (UniSyn con1 args1 ty1) ps_ty2 (UniSyn con2 args2 ty2) err_ctxt
-  -- Both must be abstract (i.e., non "visible" -- not done yet)
-  = if (con1 == con2) then
-	-- Good news!  Same synonym constructors, so we can shortcut
-	-- by unifying their arguments and ignoring their expansions.
-	uList args1 args2 err_ctxt
-    else
-	-- Bad news; mis-matched type constructors
-	getSrcLocTc		`thenNF_Tc` \ src_loc ->
-	failTc (unifyErr (UnifyMisMatch ps_ty1 ps_ty2) err_ctxt src_loc)
-\end{code}
 
-%********************************************************
-%*							*
-Catch-all case---just fails:
-%*							*
-%********************************************************
+Errors
+~~~~~~
 
-Anything else fails. For example, matching a @UniFun@ against
-a @UniData@.
 \begin{code}
-uTys ps_ty1 ty1 ps_ty2 ty2 err_ctxt
-  = getSrcLocTc		`thenNF_Tc` \ src_loc ->
-    failTc (unifyErr (UnifyMisMatch ps_ty1 ps_ty2) err_ctxt src_loc)
+unifyCtxt ty1 ty2 sty
+  = ppAboves [
+	ppCat [ppStr "Expected:", ppr sty ty1],
+	ppCat [ppStr "  Actual:", ppr sty ty2]
+    ]
+
+unifyMisMatch ty1 ty2 sty
+  = ppHang (ppStr "Couldn't match the type")
+	 4 (ppSep [ppr sty ty1, ppStr "against", ppr sty ty2])
+
+unifyKindErr tyvar ty sty
+  = ppHang (ppStr "Kind mis-match between")
+	 4 (ppSep [ppr sty tyvar, ppStr "and", ppr sty ty])
+
+unifyOccurCheck tyvar ty sty
+  = ppHang (ppStr "Occur check: cannot construct the infinite type")
+	 4 (ppSep [ppr sty tyvar, ppStr "=", ppr sty ty])
 \end{code}
 
-%************************************************************************
-%*									*
-\subsection[Unify-uVar]{@uVar@: unifying with a type variable}
-%*									*
-%************************************************************************
-
-@uVar@ is called when at least one of the types being unified is a
-variable.  It does {\em not} assume that the variable is a fixed point
-of the substitution; rather, notice that @bindTo@ (defined below) nips
-back into @uTys@ if it turns out that the variable is already bound.
-
-There is a slight worry that one might try to @bindTo@ a (say) Poly
-tyvar (as tv1) with an Open tyvar (as ty2) which is already unified to
-an unboxed type.  In fact this can't happen, because the Open ones are
-always the ones which are unified away.
-
-\begin{code}
-uVar :: TyVar
-     -> UniType -> UniType	-- printing and real versions
-     -> UnifyErrContext
-     -> TcM ()
-
-uVar tv1 ps_ty2 ty2 err_ctxt
-  = do tv1 ty2
-  where
-	-- Expand synonyms
-    do _ (UniSyn _ _ ty2) = do tv1 ty2
-
-	-- Commit any open type variable
-    do (OpenSysTyVar _) ty2				    = tv1 `bindTo` ps_ty2
-    do _ 	        ty2@(UniTyVar tv2@(OpenSysTyVar _)) = tv2 `bindTo` ty1
-
-	-- Eliminate Poly in favour of User
-    do (PolySysTyVar _) ty2@(UniTyVar (UserTyVar _ _))      = tv1 `bindTo` ps_ty2
-    do (PolySysTyVar _) ty2@(UniTyVar (PolySysTyVar _))     = tv1 `bindTo` ps_ty2
-    do (UserTyVar _ _)  ty2@(UniTyVar tv2@(PolySysTyVar _)) = tv2 `bindTo` ty1
-    do (UserTyVar _ _)  ty2@(UniTyVar (UserTyVar _ _))      = tv1 `bindTo` ps_ty2
-
-    	-- Matching for boxed data types
-    do (PolySysTyVar _) ty2@(UniData con _) | isBoxedTyCon con  = tv1 `bindTo` ps_ty2
-    do (UserTyVar _ _)  ty2@(UniData con _) | isBoxedTyCon con  = tv1 `bindTo` ps_ty2
-
-	-- Matching for unboxed data types:
-	--   requires specialisation w.r.t. the unboxed type
-    do (PolySysTyVar _) ty2@(UniData con _)  = tv1 `bindToUnboxed` ps_ty2
-    do (UserTyVar _ _)  ty2@(UniData con _)  = tv1 `bindToUnboxed` ps_ty2
-
-	-- Matching for function types
-    do (PolySysTyVar _) ty2@(UniFun _ _)     = tv1 `bindTo` ps_ty2
-    do (UserTyVar _ _)  ty2@(UniFun _ _)     = tv1 `bindTo` ps_ty2
-
-	-- Default
-    do _ _ = getSrcLocTc `thenNF_Tc` \ src_loc ->
-             failTc (unifyErr (UnifyMisMatch ty1 ps_ty2) err_ctxt src_loc)
-
-	----------- END OF CASES ---------------
-
-    ty1 = UniTyVar tv1
-
-    tyvar1 `bindTo` ty2 
-	= extendSubstTc tyvar1 ty2 err_ctxt
-
-    tyvar1 `bindToUnboxed` ty2 
-	= getSwitchCheckerTc 	`thenNF_Tc` \ sw_chkr ->
-	  if sw_chkr SpecialiseUnboxed && isUnboxedButNotState ty2 then
-	      extendSubstTc tyvar1 ty2 err_ctxt
-	  else
-	      getSrcLocTc 	`thenNF_Tc` \ src_loc ->
-              failTc (unifyErr (UnifyUnboxedMisMatch ty1 ps_ty2) err_ctxt src_loc)
-\end{code}
diff --git a/ghc/compiler/types/Class.lhs b/ghc/compiler/types/Class.lhs
new file mode 100644
index 0000000000..9045886a2d
--- /dev/null
+++ b/ghc/compiler/types/Class.lhs
@@ -0,0 +1,338 @@
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+%
+\section[Class]{The @Class@ datatype}
+
+\begin{code}
+#include "HsVersions.h"
+
+module Class (
+	GenClass(..), Class(..),
+
+	mkClass,
+	getClassKey, getClassOps, getClassSelIds,
+	getSuperDictSelId, getClassOpId, getDefaultMethodId,
+	getClassSig, getClassBigSig, getClassInstEnv,
+	isSuperClassOf,
+
+	derivableClassKeys, cCallishClassKeys,
+	isNumericClass, isStandardClass, isCcallishClass,
+
+	GenClassOp(..), ClassOp(..),
+	mkClassOp,
+	getClassOpTag, getClassOpString,
+	getClassOpLocalType,
+
+	ClassInstEnv(..)
+
+	-- and to make the interface self-sufficient...
+    ) where
+
+CHK_Ubiq() -- debugging consistency check
+
+import TyLoop
+
+import TyCon		( TyCon )
+import TyVar		( TyVar(..), GenTyVar )
+import Usage		( GenUsage, Usage(..), UVar(..) )
+
+import Maybes		( assocMaybe, Maybe )
+import NameTypes	( FullName, ShortName )
+import Unique		-- Keys for built-in classes
+import Outputable	( Outputable(..), NamedThing(..), ExportFlag )
+import Pretty		( Pretty(..), PrettyRep )
+import PprStyle		( PprStyle )
+import SrcLoc		( SrcLoc )
+import Util
+\end{code}
+
+%************************************************************************
+%*									*
+\subsection[Class-basic]{@Class@: basic definition}
+%*									*
+%************************************************************************
+
+A @Class@ corresponds to a Greek kappa in the static semantics:
+
+The parameterisation wrt tyvar and uvar is only necessary to
+get appropriately general instances of Ord3 for GenType.
+
+\begin{code}
+data GenClassOp ty
+  = ClassOp	FAST_STRING -- The operation name
+
+		Int	-- Unique within a class; starts at 1
+
+		ty	-- Type; the class tyvar is free (you can find
+			-- it from the class). This means that a
+			-- ClassOp doesn't make much sense outside the
+			-- context of its parent class.
+
+data GenClass tyvar uvar
+  = Class
+	Unique		-- Key for fast comparison
+	FullName
+
+	tyvar	  	-- The class type variable
+
+	[GenClass tyvar uvar] 	-- Immediate superclasses, and the
+	[Id]			-- corresponding selector functions to
+				-- extract them from a dictionary of this
+			  	-- class
+
+	[GenClassOp (GenType tyvar uvar)] -- The * class operations
+	[Id]			 	  --	 * selector functions
+	[Id]				  --	 * default methods
+			  -- They are all ordered by tag.  The
+			  -- selector ids are less innocent than they
+			  -- look, because their IdInfos contains
+			  -- suitable specialisation information.  In
+			  -- particular, constant methods are
+			  -- instances of selectors at suitably simple
+			  -- types.
+
+	ClassInstEnv	  -- Gives details of all the instances of this class
+
+	[(GenClass tyvar uvar, [GenClass tyvar uvar])]
+			  -- Indirect superclasses;
+			  --   (k,[k1,...,kn]) means that
+			  --   k is an immediate superclass of k1
+			  --   k1 is an immediate superclass of k2
+			  --   ... and kn is an immediate superclass
+			  -- of this class.  (This is all redundant
+			  -- information, since it can be derived from
+			  -- the superclass information above.)
+
+type Class        = GenClass TyVar UVar
+type ClassOp      = GenClassOp Type
+
+type ClassInstEnv = MatchEnv Type Id		-- The Ids are dfuns
+\end{code}
+
+The @mkClass@ function fills in the indirect superclasses.
+
+\begin{code}
+mkClass :: Unique -> FullName -> TyVar
+	-> [Class] -> [Id]
+	-> [ClassOp] -> [Id] -> [Id]
+	-> ClassInstEnv
+	-> Class
+
+mkClass uniq full_name tyvar super_classes superdict_sels
+	class_ops dict_sels defms class_insts
+  = Class uniq full_name tyvar
+		super_classes superdict_sels
+		class_ops dict_sels defms
+		class_insts
+		trans_clos
+  where
+    trans_clos :: [(Class,[Class])]
+    trans_clos = transitiveClosure succ (==) [ (clas, []) | clas <- super_classes ]
+
+    succ (clas@(Class _ _ _ super_classes _ _ _ _ _ _), links)
+      = [(super, (clas:links)) | super <- super_classes]
+\end{code}
+
+%************************************************************************
+%*									*
+\subsection[Class-selectors]{@Class@: simple selectors}
+%*									*
+%************************************************************************
+
+The rest of these functions are just simple selectors.
+
+\begin{code}
+getClassKey (Class key _ _ _ _ _ _ _ _ _) = key
+getClassOps (Class _ _ _ _ _ ops _ _ _ _) = ops
+getClassSelIds (Class _ _ _ _ _ _ sels _ _ _) = sels
+
+getClassOpId (Class _ _ _ _ _ ops op_ids _ _ _) op
+  = op_ids !! (getClassOpTag op - 1)
+getDefaultMethodId (Class _ _ _ _ _ ops _ defm_ids _ _) op
+  = defm_ids !! (getClassOpTag op - 1)
+getSuperDictSelId (Class _ _ _ scs scsel_ids _ _ _ _ _) super_clas
+  = assoc "getSuperDictSelId" (scs `zip` scsel_ids) super_clas
+
+getClassSig :: GenClass t u -> (t, [GenClass t u], [GenClassOp (GenType t u)])
+getClassSig (Class _ _ tyvar super_classes _ ops _ _ _ _)
+  = (tyvar, super_classes, ops)
+
+getClassBigSig (Class _ _ tyvar super_classes sdsels ops sels defms _ _)
+  = (tyvar, super_classes, sdsels, ops, sels, defms)
+
+getClassInstEnv (Class _ _ _ _ _ _ _ _ inst_env _) = inst_env
+\end{code}
+
+@a `isSuperClassOf` b@ returns @Nothing@ if @a@ is not a superclass of
+@b@, but if it is, it returns $@Just@~[k_1,\ldots,k_n]$, where the
+$k_1,\ldots,k_n$ are exactly as described in the definition of the
+@GenClass@ constructor above.
+
+\begin{code}
+isSuperClassOf :: Class -> Class -> Maybe [Class]
+clas `isSuperClassOf` (Class _ _ _ _ _ _ _ _ _ links) = assocMaybe links clas
+\end{code}
+
+%************************************************************************
+%*									*
+\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 _ _ _ _ _ _ _ _ _) = key `is_elem` numericClassKeys
+isStandardClass  (Class key _ _ _ _ _ _ _ _ _) = key `is_elem` standardClassKeys
+isCcallishClass	 (Class key _ _ _ _ _ _ _ _ _) = key `is_elem` cCallishClassKeys
+is_elem = isIn "is_X_Class"
+
+numericClassKeys
+  = [ numClassKey,
+      realClassKey,
+      integralClassKey,
+      fractionalClassKey,
+      floatingClassKey,
+      realFracClassKey,
+      realFloatClassKey ]
+
+derivableClassKeys
+  = [ eqClassKey,
+      showClassKey,
+      ordClassKey,
+      enumClassKey,
+      ixClassKey,
+      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.
+\end{code}
+
+%************************************************************************
+%*									*
+\subsection[Class-instances]{Instance declarations for @Class@}
+%*									*
+%************************************************************************
+
+We compare @Classes@ by their keys (which include @Uniques@).
+
+\begin{code}
+instance Ord3 (GenClass tyvar uvar) where
+  cmp (Class k1 _ _ _ _ _ _ _ _ _) (Class k2 _ _ _ _ _ _ _ _ _)
+    = cmp k1 k2
+
+instance Eq (GenClass tyvar uvar) where
+    (Class k1 _ _ _ _ _ _ _ _ _) == (Class k2 _ _ _ _ _ _ _ _ _) = k1 == k2
+    (Class k1 _ _ _ _ _ _ _ _ _) /= (Class k2 _ _ _ _ _ _ _ _ _) = k1 /= k2
+
+instance Ord (GenClass tyvar uvar) where
+    (Class k1 _ _ _ _ _ _ _ _ _) <= (Class k2 _ _ _ _ _ _ _ _ _) = k1 <= k2
+    (Class k1 _ _ _ _ _ _ _ _ _) <  (Class k2 _ _ _ _ _ _ _ _ _) = k1 <  k2
+    (Class k1 _ _ _ _ _ _ _ _ _) >= (Class k2 _ _ _ _ _ _ _ _ _) = k1 >= k2
+    (Class k1 _ _ _ _ _ _ _ _ _) >  (Class k2 _ _ _ _ _ _ _ _ _) = k1 >  k2
+    _tagCmp a b = case cmp a b of { LT_ -> _LT; EQ_ -> _EQ; GT__ -> _GT }
+\end{code}
+
+\begin{code}
+instance NamedThing (GenClass tyvar uvar) where
+    getExportFlag 	(Class _ n _ _ _ _ _ _ _ _) = getExportFlag n
+    isLocallyDefined	(Class _ n _ _ _ _ _ _ _ _) = isLocallyDefined n
+    getOrigName		(Class _ n _ _ _ _ _ _ _ _) = getOrigName n
+    getOccurrenceName	(Class _ n _ _ _ _ _ _ _ _) = getOccurrenceName n
+    getInformingModules	(Class _ n _ _ _ _ _ _ _ _) = getInformingModules n
+    getSrcLoc		(Class _ n _ _ _ _ _ _ _ _) = getSrcLoc n
+    fromPreludeCore	(Class _ n _ _ _ _ _ _ _ _) = fromPreludeCore n
+
+    getItsUnique (Class key _ _ _ _ _ _ _ _ _) = key
+\end{code}
+
+
+%************************************************************************
+%*									*
+\subsection[ClassOp-basic]{@ClassOp@: type and basic functions}
+%*									*
+%************************************************************************
+
+A @ClassOp@ represents a a class operation.  From it and its parent
+class we can construct the dictionary-selector @Id@ for the
+operation/superclass dictionary, and the @Id@ for its default method.
+It appears in a list inside the @Class@ object.
+
+The type of a method in a @ClassOp@ object is its local type; that is,
+without the overloading of the class itself.  For example, in the
+declaration
+\begin{pseudocode}
+	class Foo a where
+		op :: Ord b => a -> b -> a
+\end{pseudocode}
+the type recorded for @op@ in the @ClassOp@ list of the @Class@ object is
+just
+	$\forall \beta.~
+		@Ord@~\beta \Rightarrow
+		\alpha \rightarrow \beta \rightarrow alpha$
+
+(where $\alpha$ is the class type variable recorded in the @Class@
+object).  Of course, the type of @op@ recorded in the GVE will be its
+``full'' type
+
+	$\forall \alpha \forall \beta.~
+		@Foo@~\alpha \Rightarrow
+		~@Ord@~\beta \Rightarrow \alpha
+		\rightarrow \beta \rightarrow alpha$
+
+******************************************************************
+**** That is, the type variables of a class op selector
+***  are all at the outer level.
+******************************************************************
+
+\begin{code}
+mkClassOp :: FAST_STRING -> Int -> ty -> GenClassOp ty
+mkClassOp name tag ty = ClassOp name tag ty
+
+getClassOpTag :: GenClassOp ty -> Int
+getClassOpTag    (ClassOp _ tag _) = tag
+
+getClassOpString :: GenClassOp ty -> FAST_STRING
+getClassOpString (ClassOp str _ _) = str
+
+getClassOpLocalType :: GenClassOp ty -> ty {-SigmaType-}
+getClassOpLocalType (ClassOp _ _ ty) = ty
+\end{code}
+
+%************************************************************************
+%*									*
+\subsection[ClassOp-instances]{Instance declarations for @ClassOp@}
+%*									*
+%************************************************************************
+
+@ClassOps@ are compared by their tags.
+
+\begin{code}
+instance Eq (GenClassOp ty) where
+    (ClassOp _ i1 _) == (ClassOp _ i2 _) = i1 == i2
+    (ClassOp _ i1 _) /= (ClassOp _ i2 _) = i1 == i2
+
+instance Ord (GenClassOp ty) where
+    (ClassOp _ i1 _) <= (ClassOp _ i2 _) = i1 <= i2
+    (ClassOp _ i1 _) <  (ClassOp _ i2 _) = i1 <  i2
+    (ClassOp _ i1 _) >= (ClassOp _ i2 _) = i1 >= i2
+    (ClassOp _ i1 _) >  (ClassOp _ i2 _) = i1 >  i2
+    -- ToDo: something for _tagCmp? (WDP 94/10)
+\end{code}
+
diff --git a/ghc/compiler/types/Kind.lhs b/ghc/compiler/types/Kind.lhs
new file mode 100644
index 0000000000..0b247e4171
--- /dev/null
+++ b/ghc/compiler/types/Kind.lhs
@@ -0,0 +1,50 @@
+%
+% (c) The AQUA Project, Glasgow University, 1996
+%
+\section[Kind]{The @Kind@ datatype}
+
+\begin{code}
+module Kind (
+	Kind(..),		-- Only visible to friends: TcKind
+
+	mkArrowKind,
+	mkTypeKind,
+	mkUnboxedTypeKind,
+	mkBoxedTypeKind,
+
+	isSubKindOf,
+	resultKind, argKind
+    ) where
+
+import Ubiq{-uitous-}
+
+import Util		( panic )
+\end{code}
+
+\begin{code}
+data Kind
+  = TypeKind		-- Any type (incl unboxed types)
+  | BoxedTypeKind	-- Any boxed type
+  | UnboxedTypeKind	-- Any unboxed type
+  | ArrowKind Kind Kind
+  deriving Eq
+
+mkArrowKind 	  = ArrowKind
+mkTypeKind  	  = TypeKind
+mkUnboxedTypeKind = UnboxedTypeKind
+mkBoxedTypeKind   = BoxedTypeKind
+
+isSubKindOf :: Kind -> Kind -> Bool
+
+BoxedTypeKind   `isSubKindOf` TypeKind = True
+UnboxedTypeKind `isSubKindOf` TypeKind = True
+kind1		`isSubKindOf` kind2    = kind1 == kind2
+
+resultKind :: Kind -> Kind	-- Get result from arrow kind
+resultKind (ArrowKind _ res_kind) = res_kind
+resultKind other_kind 		  = panic "resultKind"
+
+argKind :: Kind -> Kind		-- Get argument from arrow kind
+argKind (ArrowKind arg_kind _) = arg_kind
+argKind other_kind 	       = panic "argKind"
+\end{code}
diff --git a/ghc/compiler/types/PprType.lhs b/ghc/compiler/types/PprType.lhs
new file mode 100644
index 0000000000..1c2c08925b
--- /dev/null
+++ b/ghc/compiler/types/PprType.lhs
@@ -0,0 +1,595 @@
+%
+% (c) The AQUA Project, Glasgow University, 1996
+%
+\section[PprType]{Printing Types, TyVars, Classes, ClassOps, TyCons}
+
+\begin{code}
+#include "HsVersions.h"
+
+module PprType(
+	GenTyVar, pprTyVar,
+	TyCon, pprTyCon,
+	GenType, pprType, pprParendType,
+	pprType_Internal,
+	getTypeString,
+	typeMaybeString,
+	specMaybeTysSuffix,
+	GenClass, 
+	GenClassOp, pprClassOp
+ ) where
+
+import Ubiq
+import IdLoop 	-- for paranoia checking
+import TyLoop 	-- for paranoia checking
+import NameLoop	-- for paranoia checking
+
+-- friends:
+-- (PprType can see all the representations it's trying to print)
+import Type		( GenType(..), maybeAppTyCon,
+			  splitForAllTy, splitSigmaTy, splitRhoTy, splitAppTy )
+import TyVar		( GenTyVar(..) )
+import TyCon		( TyCon(..), ConsVisible, NewOrData )
+import Class		( Class(..), GenClass(..),
+			  ClassOp(..), GenClassOp(..) )
+import Kind		( Kind(..) )
+
+-- others:
+import CStrings		( identToC )
+import CmdLineOpts	( opt_OmitInterfacePragmas )
+import Maybes		( maybeToBool )
+import NameTypes	( ShortName, FullName )
+import Outputable	( ifPprShowAll, isAvarop, interpp'SP )
+import PprStyle		( PprStyle(..), codeStyle )
+import Pretty
+import TysWiredIn	( listTyCon )
+import Unique		( pprUnique10, pprUnique )
+import Usage		( UVar(..), pprUVar )
+import Util
+\end{code}
+
+\begin{code}
+instance (Eq tyvar, Outputable tyvar,
+	  Eq uvar,  Outputable uvar  ) => Outputable (GenType tyvar uvar) where
+    ppr sty ty = pprType sty ty
+
+instance Outputable TyCon where
+    ppr sty tycon = pprTyCon sty tycon
+
+instance Outputable (GenClass tyvar uvar) where
+    -- we use pprIfaceClass for printing in interfaces
+    ppr sty (Class u n _ _ _ _ _ _ _ _) = ppr sty n
+
+instance Outputable ty => Outputable (GenClassOp ty) where
+    ppr sty clsop = pprClassOp sty clsop
+
+instance Outputable (GenTyVar flexi) where
+    ppr sty tv = pprTyVar sty tv
+\end{code}
+
+%************************************************************************
+%*									*
+\subsection[Type]{@Type@}
+%*									*
+%************************************************************************
+
+@pprType@ is the std @Type@ printer; the overloaded @ppr@ function is
+defined to use this.  @pprParendType@ is the same, except it puts
+parens around the type, except for the atomic cases.  @pprParendType@
+works just by setting the initial context precedence very high.
+
+\begin{code}
+pprType, pprParendType :: (Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar)
+		       => PprStyle -> GenType tyvar uvar -> Pretty
+
+pprType       sty ty = ppr_ty sty (initial_ve sty) tOP_PREC   ty
+pprParendType sty ty = ppr_ty sty (initial_ve sty) tYCON_PREC ty
+
+pprMaybeTy :: (Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar)
+           => PprStyle -> Maybe (GenType tyvar uvar) -> Pretty
+pprMaybeTy sty Nothing   = ppChar '*'
+pprMaybeTy sty (Just ty) = pprParendType sty ty
+\end{code}
+
+This somewhat sleazy interface is used when printing out Core syntax
+(see PprCore):
+\begin{code}
+pprType_Internal sty tvs ppr_tv uvs ppr_uv ty
+  = ppr_ty sty (VE tvs ppr_tv uvs ppr_uv) tOP_PREC ty
+\end{code}
+
+\begin{code}
+ppr_ty :: (Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar)
+       => PprStyle -> VarEnv tyvar uvar -> Int
+       -> GenType tyvar uvar
+       -> Pretty
+
+ppr_ty sty env ctxt_prec (TyVarTy tyvar)
+  = ppr_tyvar env tyvar
+
+ppr_ty sty env ctxt_prec (TyConTy tycon usage)
+  = ppr sty 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
+		      ]
+  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)
+  = 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 [ppBesides [ppLparen, 
+	   	      ppIntersperse pp'SP (map (ppr_dict sty env tOP_PREC) theta),
+		      ppRparen],
+	   ppPStr SLIT("=>"),
+	   ppr_ty sty env ctxt_prec body_ty
+    ]
+  where
+    (theta, body_ty) = splitRhoTy ty
+
+ppr_ty sty 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,
+		ppPStr SLIT("->"),
+		ppr_ty sty env tOP_PREC ty2])
+
+ppr_ty sty env ctxt_prec ty@(AppTy _ _)
+  = ppr_corner sty env ctxt_prec fun_ty arg_tys
+  where
+    (fun_ty, arg_tys) = splitAppTy ty
+
+ppr_ty PprInterface env ctxt_prec (SynTy tycon tys expansion)
+  -- always expand types in an interface
+  = ppr_ty PprInterface env ctxt_prec expansion
+
+ppr_ty sty env ctxt_prec (SynTy tycon tys expansion)
+  = 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_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
+  = ASSERT(length arg_tys == 2)
+    ppr_ty sty env ctxt_prec (FunTy ty1 ty2 usage)
+  where
+    (ty1:ty2:_) = arg_tys
+
+ppr_corner sty env ctxt_prec (TyConTy (TupleTyCon a) usage) arg_tys
+  = ASSERT(length arg_tys == a)
+    ppBesides [ppLparen, arg_tys_w_commas, ppRparen]
+  where
+    arg_tys_w_commas = ppIntersperse pp'SP (map (ppr_ty sty env tOP_PREC) arg_tys)
+
+ppr_corner sty env ctxt_prec (TyConTy tycon usage) arg_tys
+  | tycon == listTyCon
+  = ASSERT(length arg_tys == 1)
+    ppBesides [ppLbrack, ppr_ty sty 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 sty env ctxt_prec (TyVarTy tyvar) arg_tys
+  = ppr_app sty env ctxt_prec (ppr_tyvar env tyvar) arg_tys
+   
+
+ppr_app sty env ctxt_prec pp_fun []      
+  = pp_fun
+ppr_app sty 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)
+
+
+ppr_dict sty env ctxt_prec (clas, ty)
+  = maybeParen ctxt_prec tYCON_PREC
+	(ppCat [ppr sty clas, ppr_ty sty env tYCON_PREC ty]) 
+\end{code}
+
+Nota Bene: we must assign print-names to the forall'd type variables
+alphabetically, with the first forall'd variable having the alphabetically
+first name.  Reason: so anyone reading the type signature printed without
+explicit forall's will be able to reconstruct them in the right order.
+
+\begin{code}
+-- Entirely local to this module
+data VarEnv tyvar uvar
+  = VE	[Pretty] 		-- Tyvar pretty names
+	(tyvar -> Pretty)	-- Tyvar lookup function
+        [Pretty]		-- Uvar  pretty names
+	(uvar -> Pretty)	-- Uvar  lookup function
+
+initial_ve PprForC = VE [] (\tv -> ppChar '*')
+			[] (\tv -> ppChar '#')
+
+initial_ve sty = VE tv_pretties (ppr sty)
+		    uv_pretties (ppr sty)
+  where
+    tv_pretties = map (\ c -> ppChar c ) ['a' .. 'h']
+		  ++
+		  map (\ n -> ppBeside (ppChar 'a') (ppInt n))
+		      ([0 .. ] :: [Int])	-- a0 ... aN
+    
+    uv_pretties = map (\ c -> ppChar c ) ['u' .. 'y']
+		  ++
+		  map (\ n -> ppBeside (ppChar 'u') (ppInt n))
+		      ([0 .. ] :: [Int])	-- u0 ... uN
+    
+
+ppr_tyvar (VE _ ppr _ _) tyvar = ppr tyvar
+ppr_uvar  (VE _ _ _ ppr) uvar  = ppr uvar
+
+add_tyvar ve@(VE [] _ _ _) tyvar = ve
+add_tyvar (VE (tv_pp:tv_supply') tv_ppr uv_supply uv_ppr) tyvar
+  = VE tv_supply' tv_ppr' uv_supply uv_ppr
+  where
+    tv_ppr' tv | tv==tyvar = tv_pp
+	       | otherwise = tv_ppr tv
+
+add_uvar ve@(VE _ _ [] _) uvar = ve
+add_uvar (VE tv_supply tv_ppr (uv_pp:uv_supply') uv_ppr) uvar
+  = VE tv_supply tv_ppr uv_supply' uv_ppr'
+  where
+    uv_ppr' uv | uv==uvar = uv_pp
+	       | otherwise = uv_ppr uv
+\end{code}
+
+@ppr_ty@ takes an @Int@ that is the precedence of the context.
+The precedence levels are:
+\begin{description}
+\item[0:] What we start with.
+\item[1:] Function application (@FunTys@).
+\item[2:] Type constructors.
+\end{description}
+
+
+\begin{code}
+tOP_PREC    = (0 :: Int)
+fUN_PREC    = (1 :: Int)
+tYCON_PREC  = (2 :: Int)
+
+maybeParen ctxt_prec inner_prec pretty
+  | ctxt_prec < inner_prec = pretty
+  | otherwise		   = ppParens pretty
+
+
+-- 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}
+
+
+
+%************************************************************************
+%*									*
+\subsection[TyVar]{@TyVar@}
+%*									*
+%************************************************************************
+
+\begin{code}
+pprTyVar sty (TyVar uniq kind name usage)
+  = ppBesides [pp_name, pprUnique10 uniq]
+  where
+    pp_name = case name of
+		Just n  -> ppr sty n
+		Nothing -> case kind of
+				TypeKind        -> ppChar 'o'
+				BoxedTypeKind   -> ppChar 't'
+				UnboxedTypeKind -> ppChar 'u'
+				ArrowKind _ _   -> ppChar 'a'
+\end{code}
+
+%************************************************************************
+%*									*
+\subsection[TyCon]{@TyCon@}
+%*									*
+%************************************************************************
+
+ToDo; all this is suspiciously like getOccurrenceName!
+
+\begin{code}
+showTyCon :: PprStyle -> TyCon -> String
+showTyCon sty tycon = ppShow 80 (pprTyCon sty tycon)
+
+pprTyCon :: PprStyle -> TyCon -> Pretty
+
+pprTyCon sty FunTyCon 		        = ppStr "(->)"
+pprTyCon sty (TupleTyCon arity)	        = ppBeside (ppPStr SLIT("Tuple")) (ppInt arity)
+pprTyCon sty (PrimTyCon uniq name kind) = ppr sty name
+
+pprTyCon sty tycon@(DataTyCon uniq kind name tyvars ctxt cons derivings cv nd)
+  = case sty of
+      PprDebug   -> pp_tycon_and_uniq
+      PprShowAll -> pp_tycon_and_uniq
+      _	    	 -> pp_tycon
+  where
+    pp_tycon_and_uniq = ppBesides [pp_tycon, ppChar '.', pprUnique uniq]
+    pp_tycon 	      = ppr sty name
+
+pprTyCon sty (SpecTyCon tc ty_maybes)
+  = ppBeside (pprTyCon sty tc)
+	     (if (codeStyle sty)
+	      then identToC tys_stuff
+	      else ppPStr   tys_stuff)
+  where
+    tys_stuff = specMaybeTysSuffix ty_maybes
+
+pprTyCon sty (SynTyCon uniq name kind arity tyvars expansion)
+  = ppBeside (ppr sty name)
+	     (ifPprShowAll sty
+		(ppCat [ ppStr " {-", 
+			 ppInt arity, 
+			 interpp'SP sty tyvars,
+			 pprParendType sty expansion,
+			 ppStr "-}"]))
+\end{code}
+
+
+%************************************************************************
+%*									*
+\subsection[Class]{@Class@}
+%*									*
+%************************************************************************
+
+\begin{code}
+pprClassOp :: Outputable ty => PprStyle -> GenClassOp ty -> Pretty
+
+pprClassOp sty op = ppr_class_op sty [] op
+
+ppr_class_op sty tyvars (ClassOp op_name i ty)
+  = case sty of
+      PprForC 	    -> pp_C
+      PprForAsm _ _ -> pp_C
+      PprInterface  -> ppCat [pp_user, ppPStr SLIT("::"), ppr sty ty]
+      PprShowAll    -> ppCat [pp_user, ppPStr SLIT("::"), ppr sty ty]
+      _		    -> pp_user
+  where
+    pp_C    = ppPStr op_name
+    pp_user = if isAvarop op_name
+	      then ppBesides [ppLparen, pp_C, ppRparen]
+	      else pp_C
+\end{code}
+
+
+%************************************************************************
+%*									*
+\subsection[]{Mumbo jumbo}
+%*									*
+%************************************************************************
+
+\begin{code}
+    -- Shallowly magical; converts a type into something
+    -- vaguely close to what can be used in C identifier.
+    -- Don't forget to include the module name!!!
+getTypeString :: Type -> [FAST_STRING]
+getTypeString ty
+  | is_prelude_ty = [string]
+  | otherwise     = [mod, string]
+  where
+    string = _PK_ (tidy (ppShow 1000 ppr_t))
+    ppr_t  = pprType PprForC ty
+			-- PprForC expands type synonyms as it goes
+
+    (is_prelude_ty, mod)
+      = case (maybeAppTyCon ty) of
+	  Nothing -> true_bottom
+	  Just (tycon,_) ->
+	    if fromPreludeCore tycon
+	    then true_bottom
+	    else (False, fst (getOrigName tycon))
+
+    true_bottom = (True, panic "getTypeString")
+
+    --------------------------------------------------
+    -- 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 -> [FAST_STRING]
+typeMaybeString Nothing  = [SLIT("!")]
+typeMaybeString (Just t) = getTypeString t
+
+specMaybeTysSuffix :: [Maybe Type] -> FAST_STRING
+specMaybeTysSuffix ty_maybes
+  = let
+	ty_strs  = concat (map typeMaybeString ty_maybes)
+	dotted_tys = [ _CONS_ '.' str | str <- ty_strs ]
+    in
+    _CONCAT_ dotted_tys
+\end{code}
+
+========================================================
+	INTERFACE STUFF; move it out
+
+
+\begin{pseudocode}
+pprTyCon sty@PprInterface (SynonymTyCon k n a vs exp unabstract) specs
+  = ASSERT (null specs)
+    let
+	lookup_fn   = mk_lookup_tyvar_fn sty vs
+	pp_tyvars   = map lookup_fn vs
+    in
+    ppCat [ppPStr SLIT("type"), ppr sty n, ppIntersperse ppSP pp_tyvars,
+	   ppEquals, ppr_ty sty lookup_fn tOP_PREC exp]
+
+pprTyCon sty@PprInterface this_tycon@(DataTyCon k n a vs ctxt cons derivings unabstract data_or_new) specs
+  = ppHang (ppCat [pp_data_or_new,
+		   pprContext sty ctxt,
+		   ppr sty n,
+		   ppIntersperse ppSP (map lookup_fn vs)])
+	   4
+	   (ppCat [pp_unabstract_condecls,
+		   pp_pragma])
+	   -- NB: we do not print deriving info in interfaces
+  where
+    lookup_fn = mk_lookup_tyvar_fn sty vs
+
+    pp_data_or_new = case data_or_new of
+		      DataType -> ppPStr SLIT("data")
+		      NewType  -> ppPStr SLIT("newtype")
+
+    yes_we_print_condecls
+      = unabstract
+    	&& not (null cons)	-- we know what they are
+	&& (case (getExportFlag n) of
+	      ExportAbs -> False
+	      other 	-> True)
+
+    yes_we_print_pragma_condecls
+      = not yes_we_print_condecls
+	&& not opt_OmitInterfacePragmas
+	&& not (null cons)
+	&& not (maybeToBool (maybePurelyLocalTyCon this_tycon))
+	{- && not (any (dataConMentionsNonPreludeTyCon this_tycon) cons) -}
+
+    yes_we_print_pragma_specs
+      = not (null specs)
+
+    pp_unabstract_condecls
+      = if yes_we_print_condecls
+	then ppCat [ppSP, ppEquals, pp_condecls]
+	else ppNil
+
+    pp_pragma_condecls
+      = if yes_we_print_pragma_condecls
+	then pp_condecls
+	else ppNil
+
+    pp_pragma_specs
+      = if yes_we_print_pragma_specs
+	then pp_specs
+	else ppNil
+
+    pp_pragma
+      = if (yes_we_print_pragma_condecls || yes_we_print_pragma_specs)
+	then ppCat [ppStr "\t{-# GHC_PRAGMA", pp_pragma_condecls, pp_pragma_specs, ppStr "#-}"]
+	else ppNil
+
+    pp_condecls
+      = let
+	    (c:cs) = cons
+	in
+	ppCat ((ppr_con c) : (map ppr_next_con cs))
+      where
+	ppr_con con
+	  = let
+		(_, _, con_arg_tys, _) = getDataConSig con
+	    in
+	    ppCat [pprNonOp PprForUser con, -- the data con's name...
+		   ppIntersperse ppSP (map (ppr_ty sty lookup_fn tYCON_PREC) con_arg_tys)]
+
+    	ppr_next_con con = ppCat [ppChar '|', ppr_con con]
+
+    pp_specs
+      = ppBesides [ppPStr SLIT("_SPECIALIZE_ "), pp_the_list [
+	  ppCat [ppLbrack, ppInterleave ppComma (map pp_maybe ty_maybes), ppRbrack]
+	  | ty_maybes <- specs ]]
+
+    pp_the_list [p]    = p
+    pp_the_list (p:ps) = ppAbove (ppBeside p ppComma) (pp_the_list ps)
+
+    pp_maybe Nothing   = pp_NONE
+    pp_maybe (Just ty) = pprParendType sty ty
+
+    pp_NONE = ppPStr SLIT("_N_")
+
+pprTyCon PprInterface (TupleTyCon a) specs
+  = ASSERT (null specs)
+    ppCat [ ppStr "{- Tuple", ppInt a, ppStr "-}" ]
+
+pprTyCon PprInterface (PrimTyCon k n a kind_fn) specs
+  = ASSERT (null specs)
+    ppCat [ ppStr "{- data", ppr PprForUser n, ppStr " *built-in* -}" ]
+
+
+
+
+
+pprIfaceClass :: (Id -> Id) -> IdEnv UnfoldingDetails -> Class -> Pretty
+
+pprIfaceClass better_id_fn inline_env
+	(Class k n tyvar super_classes sdsels ops sels defms insts links)
+  = let
+	sdsel_infos = map (getIdInfo . better_id_fn) sdsels
+    in
+    ppAboves [ ppCat [ppPStr SLIT("class"), ppr_theta tyvar super_classes,
+		      ppr sty n, lookup_fn tyvar,
+		      if null sdsel_infos
+		      || opt_OmitInterfacePragmas
+		      || (any boringIdInfo sdsel_infos)
+			-- ToDo: really should be "all bor..."
+			-- but then parsing is more tedious,
+			-- and this is really as good in practice.
+		      then ppNil
+		      else pp_sdsel_pragmas (sdsels `zip` sdsel_infos),
+		      if (null ops)
+		      then ppNil
+		      else ppPStr SLIT("where")],
+	       ppNest 8  (ppAboves
+		 [ ppr_op op (better_id_fn sel) (better_id_fn defm)
+		 | (op,sel,defm) <- zip3 ops sels defms]) ]
+  where
+    lookup_fn = mk_lookup_tyvar_fn sty [tyvar]
+
+    ppr_theta :: TyVar -> [Class] -> Pretty
+    ppr_theta tv [] = ppNil
+    ppr_theta tv super_classes
+      = ppBesides [ppLparen,
+		   ppIntersperse pp'SP{-'-} (map ppr_assert super_classes),
+		   ppStr ") =>"]
+      where
+	ppr_assert (Class _ n _ _ _ _ _ _ _ _) = ppCat [ppr sty n, lookup_fn tv]
+
+    pp_sdsel_pragmas sdsels_and_infos
+      = ppCat [ppStr "{-# GHC_PRAGMA {-superdicts-}",
+	       ppIntersperse pp'SP{-'-}
+		 [ppIdInfo sty sdsel False{-NO specs-} better_id_fn inline_env info
+		 | (sdsel, info) <- sdsels_and_infos ],
+	       ppStr "#-}"]
+
+    ppr_op op opsel_id defm_id
+      = let
+	    stuff = ppBeside (ppChar '\t') (ppr_class_op sty [tyvar] op)
+	in
+	if opt_OmitInterfacePragmas
+	then stuff
+	else ppAbove stuff
+		(ppCat [ppStr "\t {-# GHC_PRAGMA", ppAbove pp_opsel pp_defm, ppStr "#-}"])
+      where
+	pp_opsel = ppCat [ppPStr SLIT("{-meth-}"), ppIdInfo sty opsel_id False{-no specs-} better_id_fn inline_env (getIdInfo opsel_id)]
+	pp_defm  = ppCat [ppPStr SLIT("\t\t{-defm-}"), ppIdInfo sty defm_id False{-no specs-} better_id_fn inline_env (getIdInfo defm_id)]
+\end{pseudocode}
diff --git a/ghc/compiler/types/TyCon.lhs b/ghc/compiler/types/TyCon.lhs
new file mode 100644
index 0000000000..79dae8e00d
--- /dev/null
+++ b/ghc/compiler/types/TyCon.lhs
@@ -0,0 +1,324 @@
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+%
+\section[TyCon]{The @TyCon@ datatype}
+
+\begin{code}
+#include "HsVersions.h"
+
+module TyCon(
+	TyCon(..), 	-- NB: some pals need to see representation
+
+	Arity(..), ConsVisible(..), NewOrData(..),
+
+	isFunTyCon, isPrimTyCon, isVisibleDataTyCon,
+
+	mkDataTyCon,
+	mkFunTyCon,
+	mkPrimTyCon,
+	mkSpecTyCon,
+	mkTupleTyCon,
+
+	mkSynTyCon,
+
+	getTyConKind,
+	getTyConUnique,
+	getTyConTyVars,
+	getTyConDataCons,
+	getTyConDerivings,
+	getSynTyConArity,
+
+        maybeTyConSingleCon,
+	isEnumerationTyCon,
+	derivedFor
+) where
+
+CHK_Ubiq()	-- debugging consistency check
+import NameLoop	-- for paranoia checking
+
+import TyLoop		( Type(..), GenType,
+			  Class(..), GenClass,
+			  Id(..), GenId,
+			  mkTupleCon, getDataConSig,
+			  specMaybeTysSuffix
+			)
+
+import TyVar		( GenTyVar, alphaTyVars, alphaTyVar, betaTyVar )
+import Usage		( GenUsage, Usage(..) )
+import Kind		( Kind, mkBoxedTypeKind, mkArrowKind, resultKind, argKind )
+import PrelMods		( pRELUDE_BUILTIN )
+
+import Maybes
+import NameTypes	( FullName )
+import Unique		( Unique, funTyConKey, mkTupleTyConUnique )
+import Outputable
+import Pretty		( Pretty(..), PrettyRep )
+import PprStyle		( PprStyle )
+import SrcLoc		( SrcLoc, mkBuiltinSrcLoc )
+import Util		( panic, panic#, nOfThem, isIn, Ord3(..) )
+\end{code}
+
+\begin{code}
+type Arity = Int
+
+data TyCon
+  = FunTyCon		-- Kind = Type -> Type -> Type
+
+  | DataTyCon	Unique{-TyConKey-}
+		Kind
+		FullName
+		[TyVar]
+		[(Class,Type)]	-- Its context
+		[Id]		-- Its data constructors, with fully polymorphic types
+		[Class]		-- Classes which have derived instances
+		ConsVisible
+		NewOrData
+
+  | TupleTyCon	Arity	-- just a special case of DataTyCon
+			-- Kind = BoxedTypeKind
+			--      -> ... (n times) ...
+			--	-> BoxedTypeKind
+			--      -> BoxedTypeKind
+
+  | PrimTyCon		-- Primitive types; cannot be defined in Haskell
+	Unique		-- Always unboxed; hence never represented by a closure
+	FullName	-- Often represented by a bit-pattern for the thing
+	Kind		-- itself (eg Int#), but sometimes by a pointer to
+
+  | SpecTyCon		-- A specialised TyCon; eg (Arr# Int#), or (List Int#)
+	TyCon
+	[Maybe Type]	-- Specialising types
+
+	-- 	OLD STUFF ABOUT Array types.  Use SpecTyCon instead
+	-- ([PrimRep] -> PrimRep) -- a heap-allocated object (eg ArrInt#).
+	-- The primitive types Arr# and StablePtr# have
+	-- parameters (hence arity /= 0); but the rest don't.
+	-- Only arrays use the list in a non-trivial way.
+	-- Length of that list must == arity.
+
+  | SynTyCon
+	Unique
+	FullName
+	Kind
+	Arity
+	[TyVar]		-- Argument type variables
+	Type		-- Right-hand side, mentioning these type vars.
+			-- Acts as a template for the expansion when
+			-- the tycon is applied to some types.
+
+data ConsVisible
+  = ConsVisible	    -- whether or not data constructors are visible
+  | ConsInvisible   -- outside their TyCon's defining module.
+
+data NewOrData
+  = NewType	    -- "newtype Blah ..."
+  | DataType	    -- "data Blah ..."
+\end{code}
+
+\begin{code}
+mkFunTyCon	= FunTyCon
+mkDataTyCon	= DataTyCon
+mkTupleTyCon	= TupleTyCon
+mkPrimTyCon	= PrimTyCon
+mkSpecTyCon	= SpecTyCon
+mkSynTyCon	= SynTyCon
+
+isFunTyCon FunTyCon = True
+isFunTyCon _ = False
+
+isPrimTyCon (PrimTyCon _ _ _) = True
+isPrimTyCon _ = False
+
+isVisibleDataTyCon (DataTyCon _ _ _ _ _ _ _ ConsVisible _) = True
+isVisibleDataTyCon _ = False
+\end{code}
+
+\begin{code}
+-- Special cases to avoid reconstructing lots of kinds
+kind1 = mkBoxedTypeKind `mkArrowKind` mkBoxedTypeKind
+kind2 = mkBoxedTypeKind `mkArrowKind` kind1
+
+getTyConKind :: TyCon -> Kind
+getTyConKind FunTyCon 			      = kind2
+getTyConKind (DataTyCon _ kind _ _ _ _ _ _ _) = kind
+getTyConKind (PrimTyCon _ _ kind) 	      = kind
+
+getTyConKind (SpecTyCon tc tys)
+  = spec (getTyConKind tc) tys
+   where
+    spec kind []	      = kind
+    spec kind (Just _  : tys) = spec (resultKind kind) tys
+    spec kind (Nothing : tys) =
+      argKind kind `mkArrowKind` spec (resultKind kind) tys
+
+getTyConKind (TupleTyCon n)
+  = mkArrow n
+   where
+    mkArrow 0 = mkBoxedTypeKind
+    mkArrow 1 = kind1
+    mkArrow 2 = kind2
+    mkArrow n = mkBoxedTypeKind `mkArrowKind` mkArrow (n-1)
+\end{code}
+
+\begin{code}
+getTyConUnique :: TyCon -> Unique
+getTyConUnique FunTyCon			        = funTyConKey
+getTyConUnique (DataTyCon uniq _ _ _ _ _ _ _ _) = uniq
+getTyConUnique (TupleTyCon a) 			= mkTupleTyConUnique a
+getTyConUnique (PrimTyCon uniq _ _) 	        = uniq
+getTyConUnique (SynTyCon uniq _ _ _ _ _)        = uniq
+getTyConUnique (SpecTyCon _ _ ) 	        = panic "getTyConUnique:SpecTyCon"
+\end{code}
+
+\begin{code}
+getTyConTyVars :: TyCon -> [TyVar]
+getTyConTyVars FunTyCon			       = [alphaTyVar,betaTyVar]
+getTyConTyVars (DataTyCon _ _ _ tvs _ _ _ _ _) = tvs
+getTyConTyVars (TupleTyCon arity) 	       = take arity alphaTyVars
+getTyConTyVars (SynTyCon _ _ _ _ tvs _)        = tvs
+getTyConTyVars (PrimTyCon _ _ _) 	       = panic "getTyConTyVars:PrimTyCon"
+getTyConTyVars (SpecTyCon _ _ ) 	       = panic "getTyConTyVars:SpecTyCon"
+\end{code}
+
+\begin{code}
+getTyConDataCons :: TyCon -> [Id]
+getTyConDataCons (DataTyCon _ _ _ _ _ data_cons _ _ _) = data_cons
+getTyConDataCons (TupleTyCon a)			       = [mkTupleCon a]
+\end{code}
+
+\begin{code}
+getTyConDerivings :: TyCon -> [Class]
+getTyConDerivings (DataTyCon _ _ _ _ _ _ derivs _ _) = derivs
+\end{code}
+
+\begin{code}
+getSynTyConArity :: TyCon -> Maybe Arity
+getSynTyConArity (SynTyCon _ _ _ arity _ _) = Just arity
+getSynTyConArity other			    = Nothing
+\end{code}
+
+\begin{code}
+maybeTyConSingleCon :: TyCon -> Maybe Id
+maybeTyConSingleCon (TupleTyCon arity)	             = Just (mkTupleCon arity)
+maybeTyConSingleCon (DataTyCon _ _ _ _ _ [c] _ _ _)  = Just c
+maybeTyConSingleCon (DataTyCon _ _ _ _ _ _   _ _ _)  = Nothing
+maybeTyConSingleCon (PrimTyCon _ _ _)	             = Nothing
+maybeTyConSingleCon (SpecTyCon tc tys)               = panic "maybeTyConSingleCon:SpecTyCon"
+						     -- requires DataCons of TyCon
+
+isEnumerationTyCon (TupleTyCon arity)
+  = arity == 0
+isEnumerationTyCon (DataTyCon _ _ _ _ _ data_cons _ _ _)
+  = not (null data_cons) && all is_nullary data_cons
+  where
+    is_nullary con = case (getDataConSig con) of { (_,_, arg_tys, _) ->
+		     null arg_tys }
+\end{code}
+
+@derivedFor@ reports if we have an {\em obviously}-derived instance
+for the given class/tycon.  Of course, you might be deriving something
+because it a superclass of some other obviously-derived class --- this
+function doesn't deal with that.
+
+ToDo: what about derivings for specialised tycons !!!
+
+\begin{code}
+derivedFor :: Class -> TyCon -> Bool
+derivedFor clas (DataTyCon _ _ _ _ _ _ derivs _ _) = isIn "derivedFor" clas derivs
+derivedFor clas something_weird		           = False
+\end{code}
+
+%************************************************************************
+%*									*
+\subsection[TyCon-instances]{Instance declarations for @TyCon@}
+%*									*
+%************************************************************************
+
+@TyCon@s are compared by comparing their @Unique@s.
+
+The strictness analyser needs @Ord@. It is a lexicographic order with
+the property @(a<=b) || (b<=a)@.
+
+\begin{code}
+instance Ord3 TyCon where
+  cmp FunTyCon		            FunTyCon		          = EQ_
+  cmp (DataTyCon a _ _ _ _ _ _ _ _) (DataTyCon b _ _ _ _ _ _ _ _) = a `cmp` b
+  cmp (SynTyCon a _ _ _ _ _)        (SynTyCon b _ _ _ _ _)        = a `cmp` b
+  cmp (TupleTyCon a)	            (TupleTyCon b)	          = a `cmp` b
+  cmp (PrimTyCon a _ _)		    (PrimTyCon b _ _)	          = a `cmp` b
+  cmp (SpecTyCon tc1 mtys1)	    (SpecTyCon tc2 mtys2)
+    = panic# "cmp on SpecTyCons" -- case (tc1 `cmp` tc2) of { EQ_ -> mtys1 `cmp` mtys2; xxx -> xxx }
+
+    -- now we *know* the tags are different, so...
+  cmp other_1 other_2
+    | tag1 _LT_ tag2 = LT_
+    | otherwise      = GT_
+    where
+      tag1 = tag_TyCon other_1
+      tag2 = tag_TyCon other_2
+      tag_TyCon FunTyCon    		      = ILIT(1)
+      tag_TyCon (DataTyCon _ _ _ _ _ _ _ _ _) = ILIT(2)
+      tag_TyCon (TupleTyCon _)		      = ILIT(3)
+      tag_TyCon (PrimTyCon  _ _ _)	      = ILIT(4)
+      tag_TyCon (SpecTyCon  _ _) 	      = ILIT(5)
+
+instance Eq TyCon where
+    a == b = case (a `cmp` b) of { EQ_ -> True;   _ -> False }
+    a /= b = case (a `cmp` b) of { EQ_ -> False;  _ -> True  }
+
+instance Ord TyCon 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  }
+    _tagCmp a b = case (a `cmp` b) of { LT_ -> _LT; EQ_ -> _EQ; GT__ -> _GT }
+\end{code}
+
+\begin{code}
+instance NamedThing TyCon where
+    getExportFlag tc = case get_name tc of
+			 Nothing   -> NotExported
+			 Just name -> getExportFlag name
+
+
+    isLocallyDefined tc = case get_name tc of
+			    Nothing   -> False
+			    Just name -> isLocallyDefined name
+
+    getOrigName FunTyCon		= (pRELUDE_BUILTIN, SLIT("(->)"))
+    getOrigName (TupleTyCon a)		= (pRELUDE_BUILTIN, _PK_ ("Tuple" ++ show a))
+    getOrigName (SpecTyCon tc tys)	= let (m,n) = getOrigName tc in
+					  (m, n _APPEND_ specMaybeTysSuffix tys)
+    getOrigName	other_tc           	= getOrigName (expectJust "tycon1" (get_name other_tc))
+
+    getOccurrenceName  FunTyCon		= SLIT("(->)")
+    getOccurrenceName (TupleTyCon 0)	= SLIT("()")
+    getOccurrenceName (TupleTyCon a)	= _PK_ ( "(" ++ nOfThem (a-1) ',' ++ ")" )
+    getOccurrenceName (SpecTyCon tc tys)= getOccurrenceName tc _APPEND_ specMaybeTysSuffix tys
+    getOccurrenceName other_tc          = getOccurrenceName (expectJust "tycon2" (get_name other_tc))
+
+    getInformingModules	tc = case get_name tc of
+				Nothing   -> panic "getInformingModule:TyCon"
+				Just name -> getInformingModules name
+
+    getSrcLoc tc = case get_name tc of
+		     Nothing   -> mkBuiltinSrcLoc
+		     Just name -> getSrcLoc name
+
+    getItsUnique tycon = getTyConUnique tycon
+
+    fromPreludeCore tc = case get_name tc of
+			   Nothing   -> True
+			   Just name -> fromPreludeCore name
+\end{code}
+
+Emphatically un-exported:
+
+\begin{code}
+get_name (DataTyCon _ _ n _ _ _ _ _ _) = Just n
+get_name (PrimTyCon _ n _)	       = Just n
+get_name (SpecTyCon tc _)	       = get_name tc
+get_name (SynTyCon _ n _ _ _ _)	       = Just n
+get_name other			       = Nothing
+\end{code}
+
diff --git a/ghc/compiler/types/TyLoop.lhi b/ghc/compiler/types/TyLoop.lhi
new file mode 100644
index 0000000000..ac76205d1a
--- /dev/null
+++ b/ghc/compiler/types/TyLoop.lhi
@@ -0,0 +1,45 @@
+Breaks the TyCon/types loop and the types/Id loop.
+
+\begin{code}
+interface TyLoop where
+
+import PreludePS(_PackedString)
+import PreludeStdIO ( Maybe )
+import Unique ( Unique )
+
+import Id      ( Id, GenId, StrictnessMark, mkTupleCon, mkDataCon,
+		 getDataConSig, getInstantiatedDataConSig )
+import PprType ( specMaybeTysSuffix )
+import NameTypes ( FullName )
+import TyCon   ( TyCon )
+import TyVar   ( GenTyVar, TyVar )
+import Type    ( GenType, Type )
+import Usage   ( GenUsage )
+import Class   ( Class, GenClass )
+
+data GenId    ty
+data GenType  tyvar uvar
+data GenTyVar uvar
+data GenClass tyvar uvar
+data GenUsage u
+
+type Type  = GenType (GenTyVar (GenUsage Unique)) Unique
+type TyVar = GenTyVar (GenUsage Unique)
+type Class = GenClass (GenTyVar (GenUsage Unique)) Unique
+type Id	   = GenId (GenType (GenTyVar (GenUsage Unique)) Unique)
+
+-- Needed in TyCon
+mkTupleCon :: Int -> Id
+getDataConSig :: Id -> ([TyVar], [(Class, Type)], [Type], TyCon)
+specMaybeTysSuffix :: [Maybe Type] -> _PackedString
+instance Eq (GenClass a b)
+
+-- Needed in Type
+getInstantiatedDataConSig :: Id -> [Type] -> ([Type],[Type],Type)
+
+-- Needed in TysWiredIn
+data StrictnessMark = MarkedStrict | NotMarkedStrict
+mkDataCon :: Unique -> FullName -> [StrictnessMark]
+	  -> [TyVar] -> [(Class,Type)] -> [Type] -> TyCon
+	  -> Id
+\end{code}
diff --git a/ghc/compiler/types/TyLoop.lhs b/ghc/compiler/types/TyLoop.lhs
new file mode 100644
index 0000000000..e7ba125bd8
--- /dev/null
+++ b/ghc/compiler/types/TyLoop.lhs
@@ -0,0 +1,23 @@
+
+\begin{code}
+module AllTypes(
+	TyCon, Arity(..),
+	Class, ClassOp,
+	GenTyVar, GenType, Type,
+	Id,
+
+	-- Functions which are, alas, necessary to break loops
+	mkTupleCon,	-- Used in TyCon
+
+
+	Kind,		-- Not necessary to break loops, but useful
+	GenUsage	-- to get when importing AllTypes
+) where
+
+import TyCon	( TyCon, Arity(..) )
+import Type	( GenTyVar, TyVar(..), GenType, Type(..) )
+import Class	( Class,ClassOp )
+import Id	( Id, mkTupleCon )
+import Kind	( Kind )
+import Usage	( GenUsage, Usage(..) )
+\end{code}
diff --git a/ghc/compiler/types/TyVar.lhs b/ghc/compiler/types/TyVar.lhs
new file mode 100644
index 0000000000..a448f565b4
--- /dev/null
+++ b/ghc/compiler/types/TyVar.lhs
@@ -0,0 +1,153 @@
+\begin{code}
+#include "HsVersions.h"
+
+module TyVar (
+	GenTyVar(..), TyVar(..),
+	mkTyVar,
+	getTyVarKind,		-- TyVar -> Kind
+
+	alphaTyVars, alphaTyVar, betaTyVar, gammaTyVar, deltaTyVar,
+
+	-- We also export "environments" keyed off of
+	-- TyVars and "sets" containing TyVars:
+	TyVarEnv(..),
+	nullTyVarEnv, mkTyVarEnv, addOneToTyVarEnv,
+	growTyVarEnvList, isNullTyVarEnv, lookupTyVarEnv,
+
+	GenTyVarSet(..), TyVarSet(..),
+	emptyTyVarSet, singletonTyVarSet, unionTyVarSets, tyVarListToSet,
+	tyVarSetToList, elementOfTyVarSet, minusTyVarSet, isEmptyTyVarSet
+  ) where
+
+CHK_Ubiq() 	-- debugging consistency check
+import IdLoop 	-- for paranoia checking
+
+-- friends
+import Usage		( GenUsage, Usage(..), usageOmega )
+import Kind		( Kind, mkBoxedTypeKind )
+
+-- others
+import UniqSet		( uniqSetToList, emptyUniqSet, singletonUniqSet, minusUniqSet,
+			  unionUniqSets, elementOfUniqSet, isEmptyUniqSet, mkUniqSet,
+			  UniqSet(..) )
+import UniqFM		( emptyUFM, listToUFM, addToUFM, lookupUFM,
+			  plusUFM, sizeUFM, UniqFM )
+import Maybes		( Maybe(..) )
+import NameTypes	( ShortName )
+import Pretty		( Pretty(..), PrettyRep, ppBeside, ppPStr )
+import PprStyle		( PprStyle )
+import Outputable	( Outputable(..), NamedThing(..), ExportFlag(..) )
+import SrcLoc		( mkUnknownSrcLoc, SrcLoc )
+import Unique		( showUnique, mkAlphaTyVarUnique, Unique )
+import Util		( panic, Ord3(..) )
+\end{code}
+
+\begin{code}
+data GenTyVar flexi_slot
+  = TyVar
+	Unique
+	Kind
+	(Maybe ShortName)	-- User name (if any)
+	flexi_slot		-- Extra slot used during type and usage
+				-- inference, and to contain usages.
+
+type TyVar = GenTyVar Usage	-- Usage slot makes sense only if Kind = Type
+\end{code}
+
+
+Simple construction and analysis functions
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+\begin{code}
+mkTyVar :: ShortName -> Unique -> Kind -> TyVar
+mkTyVar name uniq kind = TyVar  uniq
+				kind
+				(Just name)
+				usageOmega
+
+getTyVarKind :: GenTyVar flexi -> Kind
+getTyVarKind (TyVar _ kind _ _) = kind
+\end{code}
+
+
+Fixed collection of type variables
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+\begin{code}
+alphaTyVars = [ TyVar u mkBoxedTypeKind Nothing usageOmega
+	      | u <- map mkAlphaTyVarUnique [1..] ]
+
+(alphaTyVar:betaTyVar:gammaTyVar:deltaTyVar:_) = alphaTyVars
+\end{code}
+
+
+Environments
+~~~~~~~~~~~~
+\begin{code}
+type TyVarEnv elt = UniqFM elt
+
+nullTyVarEnv	 :: TyVarEnv a
+mkTyVarEnv	 :: [(GenTyVar flexi, a)] -> TyVarEnv a
+addOneToTyVarEnv :: TyVarEnv a -> GenTyVar flexi -> a -> TyVarEnv a
+growTyVarEnvList :: TyVarEnv a -> [(GenTyVar flexi, a)] -> TyVarEnv a
+isNullTyVarEnv	 :: TyVarEnv a -> Bool
+lookupTyVarEnv	 :: TyVarEnv a -> GenTyVar flexi -> Maybe a
+
+nullTyVarEnv	 = emptyUFM
+mkTyVarEnv	 = listToUFM
+addOneToTyVarEnv = addToUFM
+lookupTyVarEnv   = lookupUFM
+
+growTyVarEnvList env pairs = plusUFM env (listToUFM pairs)
+isNullTyVarEnv   env	   = sizeUFM env == 0
+\end{code}
+
+Sets
+~~~~
+\begin{code}
+type GenTyVarSet flexi	= UniqSet (GenTyVar flexi)
+type TyVarSet		= UniqSet TyVar
+
+emptyTyVarSet     :: GenTyVarSet flexi
+unionTyVarSets    :: GenTyVarSet flexi -> GenTyVarSet flexi -> GenTyVarSet flexi
+tyVarSetToList    :: GenTyVarSet flexi -> [GenTyVar flexi]
+singletonTyVarSet :: GenTyVar flexi -> GenTyVarSet flexi
+elementOfTyVarSet :: GenTyVar flexi -> GenTyVarSet flexi -> Bool
+minusTyVarSet	  :: GenTyVarSet flexi -> GenTyVarSet flexi -> GenTyVarSet flexi
+isEmptyTyVarSet   :: GenTyVarSet flexi -> Bool
+tyVarListToSet	  :: [GenTyVar flexi] -> GenTyVarSet flexi
+
+emptyTyVarSet  	  = emptyUniqSet
+singletonTyVarSet = singletonUniqSet
+unionTyVarSets 	  = unionUniqSets
+tyVarSetToList 	  = uniqSetToList
+elementOfTyVarSet = elementOfUniqSet
+minusTyVarSet	  = minusUniqSet
+isEmptyTyVarSet   = isEmptyUniqSet
+tyVarListToSet	  = mkUniqSet
+\end{code}
+
+Instance delarations
+~~~~~~~~~~~~~~~~~~~~
+\begin{code}
+instance Eq (GenTyVar a) where
+    (TyVar u1 _ _ _) == (TyVar u2 _ _ _) = u1 == u2
+
+instance Ord3 (GenTyVar a) where
+    cmp (TyVar u1 _ _ _) (TyVar u2 _ _ _) = u1 `cmp` u2
+
+instance NamedThing (GenTyVar a) where
+    getExportFlag 	(TyVar _ _ _ _) = NotExported
+    isLocallyDefined	(TyVar _ _ _ _) = True
+
+    getOrigName		(TyVar _ _ (Just n) _) = getOrigName n
+    getOrigName		(TyVar u _ _        _) = (panic "getOrigName:TyVar",
+						  showUnique u)
+    getOccurrenceName	(TyVar _ _ (Just n) _) = getOccurrenceName n
+    getOccurrenceName	(TyVar u _ _        _) = showUnique u
+
+    getSrcLoc		(TyVar _ _ (Just n) _) = getSrcLoc n
+    getSrcLoc		(TyVar _ _ _        _) = mkUnknownSrcLoc
+    fromPreludeCore	(TyVar _ _ _ _)	       = False
+
+    getItsUnique	(TyVar u _ _ _)	       = u
+
+\end{code}
diff --git a/ghc/compiler/types/Type.lhs b/ghc/compiler/types/Type.lhs
new file mode 100644
index 0000000000..a6a6d679cd
--- /dev/null
+++ b/ghc/compiler/types/Type.lhs
@@ -0,0 +1,637 @@
+\begin{code}
+#include "HsVersions.h"
+
+module Type (
+	GenType(..), Type(..), TauType(..),
+	mkTyVarTy, getTyVar, getTyVar_maybe, isTyVarTy,
+	mkAppTy, mkAppTys, splitAppTy,
+	mkFunTy, mkFunTys, splitFunTy, getFunTy_maybe,
+	mkTyConTy, getTyCon_maybe, applyTyCon,
+	mkSynTy,
+	mkForAllTy, mkForAllTys, getForAllTy_maybe, splitForAllTy,
+	mkForAllUsageTy, getForAllUsageTy,
+	applyTy,
+
+	isPrimType,
+
+	RhoType(..), SigmaType(..), ThetaType(..),
+	mkDictTy,
+	mkRhoTy, splitRhoTy,
+	mkSigmaTy, splitSigmaTy,
+
+	maybeAppTyCon, getAppTyCon,
+	maybeAppDataTyCon, getAppDataTyCon,
+	maybeBoxedPrimType,
+
+	matchTy, matchTys, eqTy, eqSimpleTy, eqSimpleTheta,
+
+	instantiateTy,instantiateUsage,
+
+	isTauTy,
+
+	tyVarsOfType, tyVarsOfTypes, getTypeKind
+
+
+) where
+
+import Ubiq
+import IdLoop	 -- for paranoia checking
+import TyLoop	 -- for paranoia checking
+import PrelLoop  -- for paranoia checking
+
+-- friends:
+import Class	( getClassSig, getClassOpLocalType, GenClass{-instances-} )
+import Kind	( mkBoxedTypeKind, resultKind )
+import TyCon	( mkFunTyCon, mkTupleTyCon, isFunTyCon, isPrimTyCon,
+		  getTyConKind, getTyConDataCons, TyCon )
+import TyVar	( getTyVarKind, GenTyVar{-instances-}, GenTyVarSet(..),
+		  emptyTyVarSet, unionTyVarSets, minusTyVarSet,
+		  singletonTyVarSet, nullTyVarEnv, lookupTyVarEnv,
+		  addOneToTyVarEnv, TyVarEnv(..) )
+import Usage	( usageOmega, GenUsage, Usage(..), UVar(..), UVarEnv(..),
+		  nullUVarEnv, addOneToUVarEnv, lookupUVarEnv, eqUVar,
+		  eqUsage )
+
+-- others
+import Util	( thenCmp, zipEqual, panic, panic#, assertPanic,
+		  Ord3(..){-instances-}
+		)
+\end{code}
+
+Data types
+~~~~~~~~~~
+
+\begin{code}
+type Type  = GenType TyVar UVar	-- Used after typechecker
+
+data GenType tyvar uvar	-- Parameterised over type and usage variables
+  = TyVarTy tyvar
+
+  | AppTy
+	(GenType tyvar uvar)
+	(GenType tyvar uvar)
+
+  | TyConTy 	-- Constants of a specified kind
+	TyCon 
+	(GenUsage uvar)	-- Usage gives uvar of the full application,
+			-- iff the full application is of kind Type
+			-- c.f. the Usage field in TyVars
+
+  | SynTy 	-- Synonyms must be saturated, and contain their expansion
+	TyCon	-- Must be a SynTyCon
+	[GenType tyvar uvar]
+	(GenType tyvar uvar)	-- Expansion!
+
+  | ForAllTy
+	tyvar
+	(GenType tyvar uvar)	-- TypeKind
+
+  | ForAllUsageTy
+	uvar			-- Quantify over this
+	[uvar]			-- Bounds; the quantified var must be
+				-- less than or equal to all these
+	(GenType tyvar uvar)
+
+	-- Two special cases that save a *lot* of administrative
+	-- overhead:
+
+  | FunTy			-- BoxedTypeKind
+	(GenType tyvar uvar)	-- Both args are of TypeKind
+	(GenType tyvar uvar)
+	(GenUsage uvar)
+
+  | DictTy			-- TypeKind
+	Class			-- Class
+	(GenType tyvar uvar)	-- Arg has kind TypeKind
+	(GenUsage uvar)
+\end{code}
+
+\begin{code}
+type RhoType   = Type
+type TauType   = Type
+type ThetaType = [(Class, Type)]
+type SigmaType = Type
+\end{code}
+
+
+Expand abbreviations
+~~~~~~~~~~~~~~~~~~~~
+Removes just the top level of any abbreviations.
+
+\begin{code}
+expandTy :: Type -> Type	-- Restricted to Type due to Dict expansion
+
+expandTy (FunTy t1 t2 u) = AppTy (AppTy (TyConTy mkFunTyCon u) t1) t2
+expandTy (SynTy _  _  t) = expandTy t
+expandTy (DictTy clas ty u)
+  = case all_arg_tys of
+
+	[arg_ty] -> expandTy arg_ty	-- just the <whatever> itself
+
+		-- The extra expandTy is to make sure that
+		-- the result isn't still a dict, which it might be
+		-- if the original guy was a dict with one superdict and
+		-- no methods!
+
+	other -> ASSERT(not (null all_arg_tys))
+	    	foldl AppTy (TyConTy (mkTupleTyCon (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
+		--       _CCallable, _CReturnable (and anything else
+		--       *really weird* that the user writes).
+  where
+    (tyvar, super_classes, ops) = getClassSig clas
+    super_dict_tys = map mk_super_ty super_classes
+    class_op_tys   = map mk_op_ty ops
+    all_arg_tys    = super_dict_tys ++ class_op_tys
+    mk_super_ty sc = DictTy sc ty usageOmega
+    mk_op_ty	op = instantiateTy [(tyvar,ty)] (getClassOpLocalType op)
+
+expandTy ty = ty
+\end{code}
+
+Simple construction and analysis functions
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+\begin{code}
+mkTyVarTy :: t -> GenType t u
+mkTyVarTy = TyVarTy
+-- could we use something for (map mkTyVarTy blahs) ?? WDP
+
+getTyVar :: String -> GenType t u -> t
+getTyVar msg (TyVarTy tv) = tv
+getTyVar msg (SynTy _ _ t) = getTyVar msg t
+getTyVar msg other = error ("getTyVar" ++ msg)
+
+getTyVar_maybe :: GenType t u -> Maybe t
+getTyVar_maybe (TyVarTy tv) = Just tv
+getTyVar_maybe (SynTy _ _ t) = getTyVar_maybe t
+getTyVar_maybe other = Nothing
+
+isTyVarTy :: GenType t u -> Bool
+isTyVarTy (TyVarTy tv)  = True
+isTyVarTy (SynTy _ _ t) = isTyVarTy t
+isTyVarTy other = False
+\end{code}
+
+\begin{code}
+mkAppTy = AppTy
+
+mkAppTys :: GenType t u -> [GenType t u] -> GenType t u
+mkAppTys t ts = foldl AppTy t ts
+
+splitAppTy :: GenType t u -> (GenType t u, [GenType t u])
+splitAppTy t = go t []
+  where
+    go (AppTy t arg)     ts = go t (arg:ts)
+    go (FunTy fun arg u) ts = (TyConTy mkFunTyCon u, fun:arg:ts)
+    go (SynTy _ _ t)     ts = go t ts
+    go t		 ts = (t,ts)
+\end{code}
+
+\begin{code}
+-- NB mkFunTy, mkFunTys puts in Omega usages, for now at least
+mkFunTy arg res = FunTy arg res usageOmega
+
+mkFunTys :: [GenType t u] -> GenType t u -> GenType t u
+mkFunTys ts t = foldr (\ f a -> FunTy f a usageOmega) t ts
+
+getFunTy_maybe :: GenType t u -> Maybe (GenType t u, GenType t u)
+getFunTy_maybe (FunTy arg result _) = Just (arg,result)
+getFunTy_maybe (AppTy (AppTy (TyConTy tycon _) arg) res)
+	       	 | isFunTyCon tycon = Just (arg, res)
+getFunTy_maybe (SynTy _ _ t)        = getFunTy_maybe t
+getFunTy_maybe other		    = Nothing
+
+splitFunTy :: GenType t u -> ([GenType t u], GenType t u)
+splitFunTy t = go t []
+  where
+    go (FunTy arg res _) ts = go res (arg:ts)
+    go (AppTy (AppTy (TyConTy tycon _) arg) res) ts
+	| isFunTyCon tycon
+	= go res (arg:ts)
+    go (SynTy _ _ t) ts
+	= go t ts
+    go t ts
+	= (reverse ts, t)
+\end{code}
+
+\begin{code}
+-- NB applyTyCon puts in usageOmega, for now at least
+mkTyConTy tycon = TyConTy tycon usageOmega
+
+applyTyCon :: TyCon -> [GenType t u] -> GenType t u
+applyTyCon tycon tys = foldl AppTy (TyConTy tycon usageOmega) tys
+
+getTyCon_maybe :: GenType t u -> Maybe TyCon
+getTyCon_maybe (TyConTy tycon _) = Just tycon
+getTyCon_maybe (SynTy _ _ t)     = getTyCon_maybe t
+getTyCon_maybe other_ty		 = Nothing
+\end{code}
+
+\begin{code}
+mkSynTy syn_tycon tys
+  = SynTy syn_tycon tys (panic "Type.mkSynTy:expansion")
+\end{code}
+
+Tau stuff
+~~~~~~~~~
+\begin{code}
+isTauTy :: GenType t u -> Bool
+isTauTy (TyVarTy v)        = True
+isTauTy (TyConTy _ _)      = True
+isTauTy (AppTy a b)        = isTauTy a && isTauTy b
+isTauTy (FunTy a b _)      = isTauTy a && isTauTy b
+isTauTy (SynTy _ _ ty)     = isTauTy ty
+isTauTy other		   = False
+\end{code}
+
+Rho stuff
+~~~~~~~~~
+NB mkRhoTy and mkDictTy put in usageOmega, for now at least
+
+\begin{code}
+mkDictTy :: Class -> GenType t u -> GenType t u
+mkDictTy clas ty = DictTy clas ty usageOmega
+
+mkRhoTy :: [(Class, GenType t u)] -> GenType t u -> GenType t u
+mkRhoTy theta ty =
+  foldr (\(c,t) r -> FunTy (DictTy c t usageOmega) r usageOmega) ty theta
+
+splitRhoTy :: GenType t u -> ([(Class,GenType t u)], GenType t u)
+splitRhoTy t =
+  go t []
+ where
+  go (FunTy (DictTy c t _) r _) ts = go r ((c,t):ts)
+  go (AppTy (AppTy (TyConTy tycon _) (DictTy c t _)) r) ts
+	| isFunTyCon tycon
+	= go r ((c,t):ts)
+  go (SynTy _ _ t) ts = go t ts
+  go t ts = (reverse ts, t)
+\end{code}
+
+
+Forall stuff
+~~~~~~~~~~~~
+\begin{code}
+mkForAllTy = ForAllTy
+
+mkForAllTys :: [t] -> GenType t u -> GenType t u
+mkForAllTys tyvars ty = foldr ForAllTy ty tyvars
+
+getForAllTy_maybe :: GenType t u -> Maybe (t,GenType t u)
+getForAllTy_maybe (SynTy _ _ t)	     = getForAllTy_maybe t
+getForAllTy_maybe (ForAllTy tyvar t) = Just(tyvar,t)
+getForAllTy_maybe _		     = Nothing
+
+splitForAllTy :: GenType t u-> ([t], GenType t u)
+splitForAllTy t = go t []
+	       where
+		    go (ForAllTy tv t) tvs = go t (tv:tvs)
+		    go (SynTy _ _ t)   tvs = go t tvs
+		    go t	       tvs = (reverse tvs, t)
+\end{code}
+
+\begin{code}
+mkForAllUsageTy :: u -> [u] -> GenType t u -> GenType t u
+mkForAllUsageTy = ForAllUsageTy
+
+getForAllUsageTy :: GenType t u -> Maybe (u,[u],GenType t u)
+getForAllUsageTy (ForAllUsageTy uvar bounds t) = Just(uvar,bounds,t)
+getForAllUsageTy (SynTy _ _ t) = getForAllUsageTy t
+getForAllUsageTy _ = Nothing
+\end{code}
+
+Applied tycons (includes FunTyCons)
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+\begin{code}
+maybeAppTyCon
+	:: GenType tyvar uvar
+	-> Maybe (TyCon,		-- the type constructor
+		  [GenType tyvar uvar])	-- types to which it is applied
+
+maybeAppTyCon ty
+  = case (getTyCon_maybe app_ty) of
+	Nothing    -> Nothing
+	Just tycon -> Just (tycon, arg_tys)
+  where
+    (app_ty, arg_tys) = splitAppTy ty
+
+
+getAppTyCon
+	:: GenType tyvar uvar
+	-> (TyCon,			-- the type constructor
+	    [GenType tyvar uvar])	-- types to which it is applied
+
+getAppTyCon ty
+  = case maybeAppTyCon ty of
+      Just stuff -> stuff
+#ifdef DEBUG
+      Nothing    -> panic "Type.getAppTyCon" -- (ppr PprShowAll ty)
+#endif
+\end{code}
+
+Applied data tycons (give back constrs)
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+\begin{code}
+maybeAppDataTyCon
+	:: GenType tyvar uvar
+	-> Maybe (TyCon,		-- the type constructor
+		  [GenType tyvar uvar],	-- types to which it is applied
+		  [Id])			-- its family of data-constructors
+
+maybeAppDataTyCon ty
+  = case (getTyCon_maybe app_ty) of
+	Nothing    -> Nothing
+	Just tycon | isFunTyCon tycon
+		   -> Nothing
+		   | otherwise
+		   -> Just (tycon, arg_tys, getTyConDataCons tycon)
+  where
+    (app_ty, arg_tys) = splitAppTy ty
+
+
+getAppDataTyCon
+	:: GenType tyvar uvar
+	-> (TyCon,			-- the type constructor
+	    [GenType tyvar uvar],	-- types to which it is applied
+	    [Id])			-- its family of data-constructors
+
+getAppDataTyCon ty
+  = case maybeAppDataTyCon ty of
+      Just stuff -> stuff
+#ifdef DEBUG
+      Nothing    -> panic "Type.getAppDataTyCon" -- (ppr PprShowAll ty)
+#endif
+
+
+maybeBoxedPrimType :: Type -> Maybe (Id, Type)
+
+maybeBoxedPrimType ty
+  = case (maybeAppDataTyCon ty) of		-- Data type,
+      Just (tycon, tys_applied, [data_con]) 	-- with exactly one constructor
+        -> case (getInstantiatedDataConSig data_con tys_applied) of
+	     (_, [data_con_arg_ty], _)	    	-- Applied to exactly one type,
+	        | isPrimType data_con_arg_ty 	-- which is primitive
+	        -> Just (data_con, data_con_arg_ty)
+	     other_cases -> Nothing
+      other_cases -> Nothing
+\end{code}
+
+\begin{code}
+splitSigmaTy :: GenType t u -> ([t], [(Class,GenType t u)], GenType t u)
+splitSigmaTy ty =
+  (tyvars, theta, tau)
+ where
+  (tyvars,rho) = splitForAllTy ty
+  (theta,tau)  = splitRhoTy rho
+
+mkSigmaTy tyvars theta tau = mkForAllTys tyvars (mkRhoTy theta tau)
+\end{code}
+
+
+Finding the kind of a type
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+\begin{code}
+getTypeKind :: GenType (GenTyVar any) u -> Kind
+getTypeKind (TyVarTy tyvar) 		= getTyVarKind tyvar
+getTypeKind (TyConTy tycon usage)	= getTyConKind tycon
+getTypeKind (SynTy _ _ ty)		= getTypeKind ty
+getTypeKind (FunTy fun arg _)		= mkBoxedTypeKind
+getTypeKind (DictTy clas arg _)	 	= mkBoxedTypeKind
+getTypeKind (AppTy fun arg)		= resultKind (getTypeKind fun)
+getTypeKind (ForAllTy _ _)		= mkBoxedTypeKind
+getTypeKind (ForAllUsageTy _ _ _)	= mkBoxedTypeKind
+\end{code}
+
+
+Free variables of a type
+~~~~~~~~~~~~~~~~~~~~~~~~
+\begin{code}
+tyVarsOfType :: GenType (GenTyVar flexi) uvar -> GenTyVarSet flexi
+
+tyVarsOfType (TyVarTy tv)		= singletonTyVarSet tv
+tyVarsOfType (TyConTy tycon usage)	= emptyTyVarSet
+tyVarsOfType (SynTy _ tys ty)		= tyVarsOfTypes tys
+tyVarsOfType (FunTy arg res _)		= tyVarsOfType arg `unionTyVarSets` tyVarsOfType res
+tyVarsOfType (AppTy fun arg)		= tyVarsOfType fun `unionTyVarSets` tyVarsOfType arg
+tyVarsOfType (DictTy clas ty _)		= tyVarsOfType ty
+tyVarsOfType (ForAllTy tyvar ty)	= tyVarsOfType ty `minusTyVarSet` singletonTyVarSet tyvar
+tyVarsOfType (ForAllUsageTy _ _ ty)	= tyVarsOfType ty
+
+tyVarsOfTypes :: [GenType (GenTyVar flexi) uvar] -> GenTyVarSet flexi
+tyVarsOfTypes tys = foldr (unionTyVarSets.tyVarsOfType) emptyTyVarSet tys
+\end{code}
+
+
+Instantiating a type
+~~~~~~~~~~~~~~~~~~~~
+\begin{code}
+applyTy :: Eq t => GenType t u -> GenType t u -> GenType t u
+applyTy (SynTy _ _ fun)  arg = applyTy fun arg
+applyTy (ForAllTy tv ty) arg = instantiateTy [(tv,arg)] ty
+applyTy other		 arg = panic "applyTy"
+
+instantiateTy :: Eq t => [(t, GenType t u)] -> GenType t u -> GenType t u
+instantiateTy tenv ty 
+  = go ty
+  where
+    go (TyVarTy tv)		= case [ty | (tv',ty) <- tenv, tv==tv'] of
+				  []     -> TyVarTy tv
+				  (ty:_) -> ty
+    go ty@(TyConTy tycon usage) = ty
+    go (SynTy tycon tys ty)	= SynTy tycon (map go tys) (go ty)
+    go (FunTy arg res usage)	= FunTy (go arg) (go res) usage
+    go (AppTy fun arg)		= AppTy (go fun) (go arg)
+    go (DictTy clas ty usage)	= DictTy clas (go ty) usage
+    go (ForAllTy tv ty)		= ASSERT(null tv_bound)
+				  ForAllTy tv (go ty)
+				where
+				  tv_bound = [() | (tv',_) <- tenv, tv==tv']
+
+    go (ForAllUsageTy uvar bds ty) = ForAllUsageTy uvar bds (go ty)
+
+instantiateUsage
+	:: Ord3 u => [(u, GenType t u')] -> GenType t u -> GenType t u'
+instantiateUsage = error "instantiateUsage: not implemented"
+\end{code}
+
+\begin{code}
+isPrimType :: GenType tyvar uvar -> Bool
+isPrimType (AppTy ty _)      = isPrimType ty
+isPrimType (SynTy _ _ ty)    = isPrimType ty
+isPrimType (TyConTy tycon _) = isPrimTyCon tycon
+isPrimType _ 		     = False
+\end{code}
+
+%************************************************************************
+%*									*
+\subsection{Matching on types}
+%*									*
+%************************************************************************
+
+Matching is a {\em unidirectional} process, matching a type against a
+template (which is just a type with type variables in it).  The
+matcher assumes that there are no repeated type variables in the
+template, so that it simply returns a mapping of type variables to
+types.  It also fails on nested foralls.
+
+@matchTys@ matches corresponding elements of a list of templates and
+types.
+
+\begin{code}
+matchTy :: GenType t1 u1		-- Template
+	-> GenType t2 u2		-- Proposed instance of template
+	-> Maybe [(t1,GenType t2 u2)]	-- Matching substitution
+
+matchTys :: [GenType t1 u1]		-- Templates
+	 -> [GenType t2 u2]		-- Proposed instance of template
+	 -> Maybe [(t1,GenType t2 u2)]	-- Matching substitution
+
+matchTy  ty1  ty2  = match  [] [] ty1 ty2
+matchTys tys1 tys2 = match' [] (zipEqual tys1 tys2)
+\end{code}
+
+@match@ is the main function.
+
+\begin{code}
+match :: [(t1, GenType t2 u2)]			-- r, the accumulating result
+      -> [(GenType t1 u1, GenType t2 u2)]	-- w, the work list
+      -> GenType t1 u1 -> GenType t2 u2		-- Current match pair
+      -> Maybe [(t1, GenType t2 u2)]
+
+match r w (TyVarTy v) 	       ty		    = match' ((v,ty) : r) w
+match r w (FunTy fun1 arg1 _)  (FunTy fun2 arg2 _)  = match r ((fun1,fun2):w) arg1 arg2
+match r w (AppTy fun1 arg1)  (AppTy fun2 arg2)      = match r ((fun1,fun2):w) arg1 arg2
+match r w (TyConTy con1 _)     (TyConTy con2 _)     | con1  == con2  = match' r w
+match r w (DictTy clas1 ty1 _) (DictTy clas2 ty2 _) | clas1 == clas2 = match r w ty1 ty2
+match r w (SynTy _ _ ty1)      ty2		    = match r w ty1 ty2
+match r w ty1		       (SynTy _ _ ty2)      = match r w ty1 ty2
+
+	-- With type synonyms, we have to be careful for the exact
+	-- same reasons as in the unifier.  Please see the
+	-- considerable commentary there before changing anything
+	-- here! (WDP 95/05)
+
+-- Catch-all fails
+match _ _ _ _ = Nothing
+
+match' r [] 	       = Just r
+match' r ((ty1,ty2):w) = match r w ty1 ty2
+\end{code}
+
+%************************************************************************
+%*									*
+\subsection{Equality on types}
+%*									*
+%************************************************************************
+
+The functions eqSimpleTy and eqSimpleTheta are polymorphic in the types t
+and u, but ONLY WORK FOR SIMPLE TYPES (ie. they panic if they see
+dictionaries or polymorphic types).  The function eqTy has a more
+specific type, but does the `right thing' for all types.
+
+\begin{code}
+eqSimpleTheta :: (Eq t,Eq u) =>
+    [(Class,GenType t u)] -> [(Class,GenType t u)] -> Bool
+
+eqSimpleTheta [] [] = True
+eqSimpleTheta ((c1,t1):th1) ((c2,t2):th2) =
+  c1==c2 && t1 `eqSimpleTy` t2 && th1 `eqSimpleTheta` th2
+eqSimpleTheta other1 other2 = False
+\end{code}
+
+\begin{code}
+eqSimpleTy :: (Eq t,Eq u) => GenType t u -> GenType t u -> Bool
+
+(TyVarTy tv1) `eqSimpleTy` (TyVarTy tv2) =
+  tv1 == tv2
+(AppTy f1 a1)  `eqSimpleTy` (AppTy f2 a2) =
+  f1 `eqSimpleTy` f2 && a1 `eqSimpleTy` a2
+(TyConTy tc1 u1) `eqSimpleTy` (TyConTy tc2 u2) =
+  tc1 == tc2 && u1 == u2
+
+(FunTy f1 a1 u1) `eqSimpleTy` (FunTy f2 a2 u2) =
+  f1 `eqSimpleTy` f2 && a1 `eqSimpleTy` a2 && u1 == u2
+(FunTy f1 a1 u1) `eqSimpleTy` t2 =
+  -- Expand t1 just in case t2 matches that version
+  (AppTy (AppTy (TyConTy mkFunTyCon u1) f1) a1) `eqSimpleTy` t2
+t1 `eqSimpleTy` (FunTy f2 a2 u2) =
+  -- Expand t2 just in case t1 matches that version
+  t1 `eqSimpleTy` (AppTy (AppTy (TyConTy mkFunTyCon u2) f2) a2)
+
+(SynTy tc1 ts1 t1) `eqSimpleTy` (SynTy tc2 ts2 t2) =
+  (tc1 == tc2 && and (zipWith eqSimpleTy ts1 ts2) && length ts1 == length ts2)
+  || t1 `eqSimpleTy` t2
+(SynTy _ _ t1) `eqSimpleTy` t2 =
+  t1 `eqSimpleTy` t2  -- Expand the abbrevation and try again
+t1 `eqSimpleTy` (SynTy _ _ t2) =
+  t1 `eqSimpleTy` t2  -- Expand the abbrevation and try again
+
+(DictTy _ _ _) `eqSimpleTy` _ = panic "eqSimpleTy: got DictTy"
+_ `eqSimpleTy` (DictTy _ _ _) = panic "eqSimpleTy: got DictTy"
+
+(ForAllTy _ _) `eqSimpleTy` _ = panic "eqSimpleTy: got ForAllTy"
+_ `eqSimpleTy` (ForAllTy _ _) = panic "eqSimpleTy: got ForAllTy"
+
+(ForAllUsageTy _ _ _) `eqSimpleTy` _ = panic "eqSimpleTy: got ForAllUsageTy"
+_ `eqSimpleTy` (ForAllUsageTy _ _ _) = panic "eqSimpleTy: got ForAllUsageTy"
+
+_ `eqSimpleTy` _ = False
+\end{code}
+
+Types are ordered so we can sort on types in the renamer etc.  DNT: Since
+this class is also used in CoreLint and other such places, we DO expand out
+Fun/Syn/Dict types (if necessary).
+
+\begin{code}
+eqTy :: Type -> Type -> Bool
+
+eqTy t1 t2 =
+  eq nullTyVarEnv nullUVarEnv t1 t2
+ where
+  eq tve uve (TyVarTy tv1) (TyVarTy tv2) =
+    tv1 == tv2 ||
+    case (lookupTyVarEnv tve tv1) of
+      Just tv -> tv == tv2
+      Nothing -> False
+  eq tve uve (AppTy f1 a1) (AppTy f2 a2) =
+    eq tve uve f1 f2 && eq tve uve a1 a2
+  eq tve uve (TyConTy tc1 u1) (TyConTy tc2 u2) =
+    tc1 == tc2 && eqUsage uve u1 u2
+
+  eq tve uve (FunTy f1 a1 u1) (FunTy f2 a2 u2) =
+    eq tve uve f1 f2 && eq tve uve a1 a2 && eqUsage uve u1 u2
+  eq tve uve (FunTy f1 a1 u1) t2 =
+    -- Expand t1 just in case t2 matches that version
+    eq tve uve (AppTy (AppTy (TyConTy mkFunTyCon u1) f1) a1) t2
+  eq tve uve t1 (FunTy f2 a2 u2) =
+    -- Expand t2 just in case t1 matches that version
+    eq tve uve t1 (AppTy (AppTy (TyConTy mkFunTyCon u2) f2) a2)
+
+  eq tve uve (DictTy c1 t1 u1) (DictTy c2 t2 u2) =
+    c1 == c2 && eq tve uve t1 t2 && eqUsage uve u1 u2
+  eq tve uve t1@(DictTy _ _ _) t2 =
+    eq tve uve (expandTy t1) t2  -- Expand the dictionary and try again
+  eq tve uve t1 t2@(DictTy _ _ _) =
+    eq tve uve t1 (expandTy t2)  -- Expand the dictionary and try again
+
+  eq tve uve (SynTy tc1 ts1 t1) (SynTy tc2 ts2 t2) =
+    (tc1 == tc2 && and (zipWith (eq tve uve) ts1 ts2) && length ts1 == length ts2)
+    || eq tve uve t1 t2
+  eq tve uve (SynTy _ _ t1) t2 =
+    eq tve uve t1 t2  -- Expand the abbrevation and try again
+  eq tve uve t1 (SynTy _ _ t2) =
+    eq tve uve t1 t2  -- Expand the abbrevation and try again
+
+  eq tve uve (ForAllTy tv1 t1) (ForAllTy tv2 t2) =
+    eq (addOneToTyVarEnv tve tv1 tv2) uve t1 t2
+  eq tve uve (ForAllUsageTy u1 b1 t1) (ForAllUsageTy u2 b2 t2) =
+    eqBounds uve b1 b2 && eq tve (addOneToUVarEnv uve u1 u2) t1 t2
+
+  eq _ _ _ _ = False
+
+  eqBounds uve [] [] = True
+  eqBounds uve (u1:b1) (u2:b2) = eqUVar uve u1 u2 && eqBounds uve b1 b2
+  eqBounds uve _ _ = False
+\end{code}
diff --git a/ghc/compiler/types/Usage.lhs b/ghc/compiler/types/Usage.lhs
new file mode 100644
index 0000000000..ff1fbd4c2f
--- /dev/null
+++ b/ghc/compiler/types/Usage.lhs
@@ -0,0 +1,109 @@
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+%
+\section[Usage]{The @Usage@ datatype}
+
+\begin{code}
+#include "HsVersions.h"
+
+module Usage (
+	GenUsage, Usage(..), UVar(..), UVarEnv(..),
+	usageOmega, pprUVar, duffUsage,
+	nullUVarEnv, mkUVarEnv, addOneToUVarEnv,
+	growUVarEnvList, isNullUVarEnv, lookupUVarEnv,
+	eqUVar, eqUsage
+) where
+
+import Ubiq
+import Pretty	( Pretty(..), PrettyRep, ppPStr, ppBeside )
+import UniqFM	( emptyUFM, listToUFM, addToUFM, lookupUFM,
+		  plusUFM, sizeUFM, UniqFM )
+import Unique	( Unique{-instances-} )
+\end{code}
+
+\begin{code}
+data GenUsage uvar
+  = UsageVar uvar
+  | UsageOne
+  | UsageOmega
+
+type UVar  = Unique
+type Usage = GenUsage UVar
+
+usageOmega = UsageOmega
+
+duffUsage :: GenUsage uvar
+duffUsage = error "Usage of non-Type kind doesn't make sense"
+\end{code}
+
+%************************************************************************
+%*									*
+\subsection{Environments}
+%*									*
+%************************************************************************
+
+\begin{code}
+type UVarEnv a = UniqFM a
+
+nullUVarEnv	:: UVarEnv a
+mkUVarEnv	:: [(UVar, a)] -> UVarEnv a
+addOneToUVarEnv :: UVarEnv a -> UVar -> a -> UVarEnv a
+growUVarEnvList :: UVarEnv a -> [(UVar, a)] -> UVarEnv a
+isNullUVarEnv   :: UVarEnv a -> Bool
+lookupUVarEnv   :: UVarEnv a -> UVar -> Maybe a
+
+nullUVarEnv	= emptyUFM
+mkUVarEnv	= listToUFM
+addOneToUVarEnv = addToUFM
+lookupUVarEnv   = lookupUFM
+
+growUVarEnvList env pairs = plusUFM env (listToUFM pairs)
+isNullUVarEnv   env       = sizeUFM env == 0
+\end{code}
+
+%************************************************************************
+%*									*
+\subsection{Equality on usages}
+%*									*
+%************************************************************************
+
+Equaltity (with respect to an environment mapping usage variables
+to equivalent usage variables).
+
+\begin{code}
+eqUVar :: UVarEnv UVar -> UVar -> UVar -> Bool
+eqUVar uve u1 u2 =
+  u1 == u2 ||
+  case lookupUVarEnv uve u1 of
+    Just u -> u == u2
+    Nothing -> False
+
+eqUsage :: UVarEnv UVar -> Usage -> Usage -> Bool
+eqUsage uve (UsageVar u1) (UsageVar u2) = eqUVar uve u1 u2
+eqUsage uve UsageOne      UsageOne   = True
+eqUsage uve UsageOmega    UsageOmega = True
+eqUsage _ _ _ = False
+\end{code}
+
+%************************************************************************
+%*									*
+\subsection{Instances}
+%*									*
+%************************************************************************
+
+\begin{code}
+instance Eq u => Eq (GenUsage u) where
+  (UsageVar u1) == (UsageVar u2) = u1 == u2
+  UsageOne      == UsageOne	 = True
+  UsageOmega    == UsageOmega	 = True
+  _		== _		 = False
+\end{code}
+
+\begin{code}
+instance Outputable uvar => Outputable (GenUsage uvar) where
+    ppr sty UsageOne	 = ppPStr SLIT("UsageOne")
+    ppr sty UsageOmega	 = ppPStr SLIT("UsageOmega")
+    ppr sty (UsageVar u) = pprUVar sty u
+
+pprUVar sty u = ppBeside (ppPStr SLIT("u")) (ppr sty u)
+\end{code}
diff --git a/ghc/compiler/utils/Argv.lhs b/ghc/compiler/utils/Argv.lhs
new file mode 100644
index 0000000000..58926a8957
--- /dev/null
+++ b/ghc/compiler/utils/Argv.lhs
@@ -0,0 +1,29 @@
+%
+% (c) The AQUA Project, Glasgow University, 1996
+%
+\section[Argv]{@Argv@: direct (non-standard) access to command-line arguments}
+
+\begin{code}
+#include "HsVersions.h"
+
+module Argv ( argv ) where
+
+import PreludeGlaST	( indexAddrOffAddr )
+
+CHK_Ubiq() -- debugging consistency check
+
+argv :: [FAST_STRING]
+argv = unpackArgv ``prog_argv'' (``prog_argc''::Int)
+
+unpackArgv :: _Addr -> Int -> [FAST_STRING] -- argv[1 .. argc-1]
+
+unpackArgv argv argc = unpack 1
+  where
+    unpack :: Int -> [FAST_STRING]
+    unpack n
+      = if (n >= argc)
+	then ([] :: [FAST_STRING])
+	else case (indexAddrOffAddr argv n) of { item ->
+	     _packCString item : unpack (n + 1)
+	     }
+\end{code}
diff --git a/ghc/compiler/utils/Bag.hi b/ghc/compiler/utils/Bag.hi
deleted file mode 100644
index 69c68e10c7..0000000000
--- a/ghc/compiler/utils/Bag.hi
+++ /dev/null
@@ -1,16 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface Bag where
-import Outputable(Outputable)
-data Bag a 
-bagToList :: Bag a -> [a]
-emptyBag :: Bag a
-filterBag :: (a -> Bool) -> Bag a -> Bag a
-isEmptyBag :: Bag a -> Bool
-listToBag :: [a] -> Bag a
-partitionBag :: (a -> Bool) -> Bag a -> (Bag a, Bag a)
-snocBag :: Bag a -> a -> Bag a
-unionBags :: Bag a -> Bag a -> Bag a
-unionManyBags :: [Bag a] -> Bag a
-unitBag :: a -> Bag a
-instance Outputable a => Outputable (Bag a)
-
diff --git a/ghc/compiler/utils/Bag.lhs b/ghc/compiler/utils/Bag.lhs
index 3734df5886..857dda2c97 100644
--- a/ghc/compiler/utils/Bag.lhs
+++ b/ghc/compiler/utils/Bag.lhs
@@ -1,5 +1,5 @@
 %
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
 %
 \section[Bags]{@Bag@: an unordered collection with duplicates}
 
@@ -8,56 +8,57 @@ module Bag (
 	Bag,	-- abstract type
 
 	emptyBag, unitBag, unionBags, unionManyBags,
-#if ! defined(COMPILING_GHC)
-	elemBag,
-#endif
-	filterBag, partitionBag,
-	isEmptyBag, snocBag, listToBag, bagToList
+	elemBag, mapBag,
+	filterBag, partitionBag, concatBag, foldBag,
+	isEmptyBag, consBag, snocBag,
+	listToBag, bagToList, bagToList_append
     ) where
 
-#if defined(COMPILING_GHC)
-import Id		( Id )
-import Outputable
+#ifdef COMPILING_GHC
+import Ubiq{-uitous-}
+
+import Outputable	( interpp'SP )
 import Pretty
-import Util
 #endif
 
 data Bag a
   = EmptyBag
   | UnitBag	a
   | TwoBags	(Bag a) (Bag a)	-- The ADT guarantees that at least
-				-- one branch is non-empty.
+				-- one branch is non-empty
+  | ListBag	[a]		-- The list is non-empty
   | ListOfBags	[Bag a]		-- The list is non-empty
 
 emptyBag = EmptyBag
 unitBag  = UnitBag
 
-#if ! defined(COMPILING_GHC)
--- not used in GHC
 elemBag :: Eq a => a -> Bag a -> Bool
+
 elemBag x EmptyBag        = False
 elemBag x (UnitBag y)     = x==y
 elemBag x (TwoBags b1 b2) = x `elemBag` b1 || x `elemBag` b2
+elemBag x (ListBag ys)    = any (x ==) ys
 elemBag x (ListOfBags bs) = any (x `elemBag`) bs
-#endif
 
 unionManyBags [] = EmptyBag
 unionManyBags xs = ListOfBags xs
 
 -- This one is a bit stricter! The bag will get completely evaluated.
 
-
 unionBags EmptyBag b = b
 unionBags b EmptyBag = b
 unionBags b1 b2      = TwoBags b1 b2
 
+consBag :: a -> Bag a -> Bag a
+consBag elt bag = (unitBag elt) `unionBags` bag
 snocBag :: Bag a -> a -> Bag a
 snocBag bag elt = bag `unionBags` (unitBag elt)
 
 isEmptyBag EmptyBag	    = True
+isEmptyBag (UnitBag x)	    = False
 isEmptyBag (TwoBags b1 b2)  = isEmptyBag b1 && isEmptyBag b2	-- Paranoid, but safe
+isEmptyBag (ListBag xs)     = null xs				-- Paranoid, but safe
 isEmptyBag (ListOfBags bs)  = all isEmptyBag bs
-isEmptyBag other	    = False
 
 filterBag :: (a -> Bool) -> Bag a -> Bag a
 filterBag pred EmptyBag = EmptyBag
@@ -66,12 +67,20 @@ filterBag pred (TwoBags b1 b2) = sat1 `unionBags` sat2
 			       where
 				 sat1 = filterBag pred b1
 				 sat2 = filterBag pred b2
+filterBag pred (ListBag vs)    = listToBag (filter pred vs)
 filterBag pred (ListOfBags bs) = ListOfBags sats
-			        where
+				where
 				 sats = [filterBag pred b | b <- bs]
 
+concatBag :: Bag (Bag a) -> Bag a
+
+concatBag EmptyBag 	    = EmptyBag
+concatBag (UnitBag b)       = b
+concatBag (TwoBags b1 b2)   = concatBag b1 `TwoBags` concatBag b2
+concatBag (ListBag bs)	    = ListOfBags bs
+concatBag (ListOfBags bbs)  = ListOfBags (map concatBag bbs)
 
-partitionBag :: (a -> Bool) -> Bag a -> (Bag a {- Satisfy predictate -}, 
+partitionBag :: (a -> Bool) -> Bag a -> (Bag a {- Satisfy predictate -},
 					 Bag a {- Don't -})
 partitionBag pred EmptyBag = (EmptyBag, EmptyBag)
 partitionBag pred b@(UnitBag val) = if pred val then (b, EmptyBag) else (EmptyBag, b)
@@ -79,31 +88,69 @@ partitionBag pred (TwoBags b1 b2) = (sat1 `unionBags` sat2, fail1 `unionBags` fa
 				  where
 				    (sat1,fail1) = partitionBag pred b1
 				    (sat2,fail2) = partitionBag pred b2
+partitionBag pred (ListBag vs)	  = (listToBag sats, listToBag fails)
+				  where
+				    (sats,fails) = partition pred vs
 partitionBag pred (ListOfBags bs) = (ListOfBags sats, ListOfBags fails)
 				  where
 				    (sats, fails) = unzip [partitionBag pred b | b <- bs]
 
 
+foldBag :: (r -> r -> r)	-- Replace TwoBags with this; should be associative
+	-> (a -> r)		-- Replace UnitBag with this
+	-> r			-- Replace EmptyBag with this
+	-> Bag a
+	-> r
+
+{- Standard definition
+foldBag t u e EmptyBag        = e
+foldBag t u e (UnitBag x)     = u x
+foldBag t u e (TwoBags b1 b2) = (foldBag t u e b1) `t` (foldBag t u e b2)
+foldBag t u e (ListBag xs)    = foldr (t.u) e xs
+foldBag t u e (ListOfBags bs) = foldr (\b r -> foldBag e u t b `t` r) e bs
+-}
+
+-- More tail-recursive definition, exploiting associativity of "t"
+foldBag t u e EmptyBag        = e
+foldBag t u e (UnitBag x)     = u x `t` e
+foldBag t u e (TwoBags b1 b2) = foldBag t u (foldBag t u e b2) b1
+foldBag t u e (ListBag xs)    = foldr (t.u) e xs
+foldBag t u e (ListOfBags bs) = foldr (\b r -> foldBag t u r b) e bs
+
+
+mapBag :: (a -> b) -> Bag a -> Bag b
+mapBag f EmptyBag 	 = EmptyBag
+mapBag f (UnitBag x)     = UnitBag (f x)
+mapBag f (TwoBags b1 b2) = TwoBags (mapBag f b1) (mapBag f b2) 
+mapBag f (ListBag xs)    = ListBag (map f xs)
+mapBag f (ListOfBags bs) = ListOfBags (map (mapBag f) bs)
+
+
 listToBag :: [a] -> Bag a
-listToBag lst = foldr TwoBags EmptyBag (map UnitBag lst)
+listToBag [] = EmptyBag
+listToBag vs = ListBag vs
 
 bagToList :: Bag a -> [a]
-bagToList b = b_to_l b []
-  where
-    -- (b_to_l b xs) flattens b and puts xs on the end.
-    b_to_l EmptyBag 	   xs = xs
-    b_to_l (UnitBag x)	   xs = x:xs
-    b_to_l (TwoBags b1 b2) xs = b_to_l b1 (b_to_l b2 xs)
-    b_to_l (ListOfBags bs) xs = foldr b_to_l xs bs 
+bagToList EmptyBag     = []
+bagToList (ListBag vs) = vs
+bagToList b = bagToList_append b []
+
+    -- (bagToList_append b xs) flattens b and puts xs on the end.
+bagToList_append EmptyBag 	 xs = xs
+bagToList_append (UnitBag x)	 xs = x:xs
+bagToList_append (TwoBags b1 b2) xs = bagToList_append b1 (bagToList_append b2 xs)
+bagToList_append (ListBag xx)    xs = xx++xs
+bagToList_append (ListOfBags bs) xs = foldr bagToList_append xs bs
 \end{code}
 
 \begin{code}
-#if defined(COMPILING_GHC)
+#ifdef COMPILING_GHC
 
 instance (Outputable a) => Outputable (Bag a) where
     ppr sty EmptyBag	    = ppStr "emptyBag"
     ppr sty (UnitBag a)     = ppr sty a
     ppr sty (TwoBags b1 b2) = ppCat [ppr sty b1, pp'SP, ppr sty b2]
+    ppr sty (ListBag as)    = interpp'SP sty as
     ppr sty (ListOfBags bs) = ppCat [ppLbrack, interpp'SP sty bs, ppRbrack]
 
 #endif {- COMPILING_GHC -}
diff --git a/ghc/compiler/utils/BitSet.hi b/ghc/compiler/utils/BitSet.hi
deleted file mode 100644
index 1882ac11bb..0000000000
--- a/ghc/compiler/utils/BitSet.hi
+++ /dev/null
@@ -1,10 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface BitSet where
-data BitSet 
-emptyBS :: BitSet
-listBS :: BitSet -> [Int]
-minusBS :: BitSet -> BitSet -> BitSet
-mkBS :: [Int] -> BitSet
-singletonBS :: Int -> BitSet
-unionBS :: BitSet -> BitSet -> BitSet
-
diff --git a/ghc/compiler/utils/BitSet.lhs b/ghc/compiler/utils/BitSet.lhs
index eb6b52396f..fcd837d2d4 100644
--- a/ghc/compiler/utils/BitSet.lhs
+++ b/ghc/compiler/utils/BitSet.lhs
@@ -30,7 +30,7 @@ module BitSet (
 #elif defined(__YALE_HASKELL__)
 {-hide import from mkdependHS-}
 import
-        LogOpPrims
+	LogOpPrims
 #else
 {-hide import from mkdependHS-}
 import
@@ -41,7 +41,7 @@ import
 
 data BitSet = MkBS Word#
 
-emptyBS :: BitSet 
+emptyBS :: BitSet
 emptyBS = MkBS (int2Word# 0#)
 
 mkBS :: [Int] -> BitSet
@@ -60,7 +60,7 @@ minusBS (MkBS x#) (MkBS y#) = MkBS (x# `and#` (not# y#))
 #if ! defined(COMPILING_GHC)
 -- not used in GHC
 isEmptyBS :: BitSet -> Bool
-isEmptyBS (MkBS s#) = 
+isEmptyBS (MkBS s#) =
     case word2Int# s# of
     	0# -> True
     	_  -> False
@@ -77,7 +77,7 @@ elementBS x (MkBS s#) = case x of
 
 listBS :: BitSet -> [Int]
 listBS s = listify s 0
-    where listify (MkBS s#) n = 
+    where listify (MkBS s#) n =
     	    case word2Int# s# of
     	        0# -> []
     	        _  -> let s' = (MkBS (s# `shiftr` 1#))
@@ -85,17 +85,13 @@ listBS s = listify s 0
     	    	      in case word2Int# (s# `and#` (int2Word# 1#)) of
     	    	    	  0# -> more
     	    	    	  _  -> n : more
-# if __GLASGOW_HASKELL__ >= 23
 	  shiftr x y = shiftRL# x y
-# else
-	  shiftr x y = shiftR#  x y
-# endif
 
 #elif defined(__YALE_HASKELL__)
 
 data BitSet = MkBS Int
 
-emptyBS :: BitSet 
+emptyBS :: BitSet
 emptyBS = MkBS 0
 
 mkBS :: [Int] -> BitSet
@@ -110,7 +106,7 @@ unionBS (MkBS x) (MkBS y) = MkBS (x `logiorInt` y)
 #if ! defined(COMPILING_GHC)
 -- not used in GHC
 isEmptyBS :: BitSet -> Bool
-isEmptyBS (MkBS s) = 
+isEmptyBS (MkBS s) =
     case s of
     	0 -> True
     	_ -> False
@@ -119,7 +115,7 @@ intersectBS :: BitSet -> BitSet -> BitSet
 intersectBS (MkBS x) (MkBS y) = MkBS (x `logandInt` y)
 
 elementBS :: Int -> BitSet -> Bool
-elementBS x (MkBS s) = 
+elementBS x (MkBS s) =
     case logbitpInt x s of
     	0 -> False
     	_ -> True
@@ -128,23 +124,23 @@ elementBS x (MkBS s) =
 minusBS :: BitSet -> BitSet -> BitSet
 minusBS (MkBS x) (MkBS y) = MkBS (x `logandc2Int` y)
 
--- rewritten to avoid right shifts (which would give nonsense on negative 
+-- rewritten to avoid right shifts (which would give nonsense on negative
 -- values.
 listBS :: BitSet -> [Int]
 listBS (MkBS s) = listify s 0 1
-    where listify s n m = 
+    where listify s n m =
     	    case s of
     	        0 -> []
     	        _ -> let n' = n+1; m' = m+m in
-                     case logbitpInt s m of
+		     case logbitpInt s m of
 		     0 -> listify s n' m'
 		     _ -> n : listify (s `logandc2Int` m) n' m'
 
-#else	/* HBC, perhaps? */    
+#else	/* HBC, perhaps? */
 
 data BitSet = MkBS Word
 
-emptyBS :: BitSet 
+emptyBS :: BitSet
 emptyBS = MkBS 0
 
 mkBS :: [Int] -> BitSet
@@ -159,7 +155,7 @@ unionBS (MkBS x) (MkBS y) = MkBS (x `bitOr` y)
 #if ! defined(COMPILING_GHC)
 -- not used in GHC
 isEmptyBS :: BitSet -> Bool
-isEmptyBS (MkBS s) = 
+isEmptyBS (MkBS s) =
     case s of
     	0 -> True
     	_ -> False
@@ -168,7 +164,7 @@ intersectBS :: BitSet -> BitSet -> BitSet
 intersectBS (MkBS x) (MkBS y) = MkBS (x `bitAnd` y)
 
 elementBS :: Int -> BitSet -> Bool
-elementBS x (MkBS s) = 
+elementBS x (MkBS s) =
     case (1 `bitLsh` x) `bitAnd` s of
     	0 -> False
     	_ -> True
@@ -179,7 +175,7 @@ minusBS (MkBS x) (MkBS y) = MkBS (x `bitAnd` (bitCompl y))
 
 listBS :: BitSet -> [Int]
 listBS (MkBS s) = listify s 0
-    where listify s n = 
+    where listify s n =
     	    case s of
     	        0 -> []
     	        _ -> let s' = s `bitRsh` 1
diff --git a/ghc/compiler/utils/CharSeq.hi b/ghc/compiler/utils/CharSeq.hi
deleted file mode 100644
index 15bcebb488..0000000000
--- a/ghc/compiler/utils/CharSeq.hi
+++ /dev/null
@@ -1,16 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface CharSeq where
-import PreludePS(_PackedString)
-import Stdio(_FILE)
-data CSeq 
-cAppend :: CSeq -> CSeq -> CSeq
-cAppendFile :: _FILE -> CSeq -> _State _RealWorld -> ((), _State _RealWorld)
-cCh :: Char -> CSeq
-cIndent :: Int -> CSeq -> CSeq
-cInt :: Int -> CSeq
-cNL :: CSeq
-cNil :: CSeq
-cPStr :: _PackedString -> CSeq
-cShow :: CSeq -> [Char]
-cStr :: [Char] -> CSeq
-
diff --git a/ghc/compiler/utils/CharSeq.lhs b/ghc/compiler/utils/CharSeq.lhs
index d5520272fc..daa865ae4d 100644
--- a/ghc/compiler/utils/CharSeq.lhs
+++ b/ghc/compiler/utils/CharSeq.lhs
@@ -28,17 +28,15 @@ module CharSeq (
 #endif
 	cShow
 
-#if defined(COMPILING_GHC) && __GLASGOW_HASKELL__ >= 22
+#if ! defined(COMPILING_GHC)
+   ) where
+#else
 	, cAppendFile
    ) where
 
-#if __GLASGOW_HASKELL__ < 26
-import PreludePrimIO
-#endif
-import PreludeGlaST
+CHK_Ubiq() -- debugging consistency check
 
-#else
-   ) where
+import PreludeGlaST
 #endif
 \end{code}
 
@@ -66,12 +64,7 @@ cPStr	:: FAST_STRING -> CSeq
 cCh 	:: Char -> CSeq
 cInt	:: Int -> CSeq
 
-#if defined(COMPILING_GHC) && __GLASGOW_HASKELL__ >= 22
-
-# if __GLASGOW_HASKELL__ < 23
-#  define _FILE _Addr
-# endif
-
+#if defined(COMPILING_GHC)
 cAppendFile :: _FILE -> CSeq -> PrimIO ()
 #endif
 \end{code}
@@ -92,7 +85,7 @@ data CSeq
   | CStr	[Char]
   | CCh		Char
   | CInt	Int	-- equiv to "CStr (show the_int)"
-#if defined(COMPILING_GHC) && __GLASGOW_HASKELL__ >= 23
+#if defined(COMPILING_GHC)
   | CPStr	_PackedString
 #endif
 \end{code}
@@ -120,7 +113,7 @@ cStr	= CStr
 cCh	= CCh
 cInt	= CInt
 
-#if defined(COMPILING_GHC) && __GLASGOW_HASKELL__ >= 23
+#if defined(COMPILING_GHC)
 cPStr	= CPStr
 #else
 cPStr	= CStr
@@ -133,7 +126,7 @@ cShows seq rest = cShow seq ++ rest
 cLength seq = length (cShow seq) -- *not* the best way to do this!
 #endif
 
-#if defined(COMPILING_GHC) && __GLASGOW_HASKELL__ >= 22
+#if defined(COMPILING_GHC)
 cAppendFile file_star seq
   = flattenIO file_star seq
 #endif
@@ -162,14 +155,14 @@ flatten n _TRUE_  CNewline seqs = flattenS _TRUE_ seqs	-- Already at start of li
 flatten n _FALSE_ (CStr s) seqs = s ++ flattenS _FALSE_ seqs
 flatten n _FALSE_ (CCh  c) seqs = c :  flattenS _FALSE_ seqs
 flatten n _FALSE_ (CInt i) seqs = show i ++ flattenS _FALSE_ seqs
-#if defined(COMPILING_GHC) && __GLASGOW_HASKELL__ >= 23
+#if defined(COMPILING_GHC)
 flatten n _FALSE_ (CPStr s) seqs = _unpackPS s ++ flattenS _FALSE_ seqs
 #endif
 
 flatten n _TRUE_  (CStr s) seqs = mkIndent n (s ++ flattenS _FALSE_ seqs)
 flatten n _TRUE_  (CCh  c) seqs = mkIndent n (c :  flattenS _FALSE_ seqs)
 flatten n _TRUE_  (CInt i) seqs = mkIndent n (show i ++ flattenS _FALSE_ seqs)
-#if defined(COMPILING_GHC) && __GLASGOW_HASKELL__ >= 23
+#if defined(COMPILING_GHC)
 flatten n _TRUE_ (CPStr s) seqs = mkIndent n (_unpackPS s ++ flattenS _FALSE_ seqs)
 #endif
 \end{code}
@@ -195,39 +188,25 @@ This code is massively {\em hammered}.
 It {\em ignores} indentation.
 
 \begin{code}
-#if defined(COMPILING_GHC) && __GLASGOW_HASKELL__ >= 22
+#if defined(COMPILING_GHC)
 
 flattenIO :: _FILE	-- file we are writing to
 	  -> CSeq	-- Seq to print
 	  -> PrimIO ()
 
 flattenIO file sq
-# if __GLASGOW_HASKELL__ >= 23
   | file == ``NULL'' = error "panic:flattenIO" -- really just to force eval :-)
   | otherwise
-# endif
   = flat sq
   where
-    flat CNil = BSCC("flatCNil") returnPrimIO () ESCC
-
-    flat (CIndent n2 seq) = BSCC("flatCIndent") flat seq ESCC
-
-    flat (CAppend seq1 seq2)
-      = BSCC("flatCAppend")
-	flat seq1 `seqPrimIO` flat seq2
-	ESCC
-
-    flat CNewline = BSCC("flatCNL") _ccall_ stg_putc '\n' file ESCC
-
-    flat (CCh c) = BSCC("flatCCh") _ccall_ stg_putc c file ESCC
-
-    flat (CInt i) = BSCC("flatCInt") _ccall_ fprintf file percent_d i ESCC
-
-    flat (CStr s) = BSCC("flatCStr") put_str s ESCC
-
-# if defined(COMPILING_GHC) && __GLASGOW_HASKELL__ >= 23
-    flat (CPStr s) = BSCC("flatCPStr") put_pstr s ESCC
-# endif
+    flat CNil		  = returnPrimIO ()
+    flat (CIndent n2 seq) = flat seq
+    flat (CAppend s1 s2)  = flat s1 `seqPrimIO` flat s2
+    flat CNewline  	  = _ccall_ stg_putc '\n' file
+    flat (CCh c)   	  = _ccall_ stg_putc c file
+    flat (CInt i)  	  = _ccall_ fprintf file percent_d i
+    flat (CStr s)  	  = put_str s
+    flat (CPStr s) 	  = put_pstr s
 
     -----
     put_str, put_str2 :: String -> PrimIO ()
@@ -236,47 +215,33 @@ flattenIO file sq
       = --put_str2 ``stderr'' (str ++ "\n") `seqPrimIO`
 	put_str2		str
 
-    put_str2 [] = BSCC("putNil") returnPrimIO () ESCC
+    put_str2 [] = returnPrimIO ()
 
     put_str2 (c1@(C# _) : c2@(C# _) : c3@(C# _) : c4@(C# _) : cs)
-      = BSCC("put4")
-	_ccall_ stg_putc  c1 file	`seqPrimIO`
+      = _ccall_ stg_putc  c1 file	`seqPrimIO`
 	_ccall_ stg_putc  c2 file	`seqPrimIO`
 	_ccall_ stg_putc  c3 file	`seqPrimIO`
 	_ccall_ stg_putc  c4 file	`seqPrimIO`
 	put_str2 cs	-- efficiency hack?  who knows... (WDP 94/10)
-	ESCC
 
     put_str2 (c1@(C# _) : c2@(C# _) : c3@(C# _) : cs)
-      = BSCC("put3")
-	_ccall_ stg_putc  c1 file	`seqPrimIO`
+      = _ccall_ stg_putc  c1 file	`seqPrimIO`
 	_ccall_ stg_putc  c2 file	`seqPrimIO`
 	_ccall_ stg_putc  c3 file	`seqPrimIO`
 	put_str2 cs	-- efficiency hack?  who knows... (WDP 94/10)
-	ESCC
 
     put_str2 (c1@(C# _) : c2@(C# _) : cs)
-      = BSCC("put2")
-	_ccall_ stg_putc  c1 file	`seqPrimIO`
+      = _ccall_ stg_putc  c1 file	`seqPrimIO`
 	_ccall_ stg_putc  c2 file	`seqPrimIO`
 	put_str2 cs	-- efficiency hack?  who knows... (WDP 94/10)
-	ESCC
 
     put_str2 (c1@(C# _) : cs)
-      = BSCC("put1")
-	_ccall_ stg_putc  c1 file	`seqPrimIO`
+      = _ccall_ stg_putc  c1 file	`seqPrimIO`
 	put_str2 cs	-- efficiency hack?  who knows... (WDP 94/10)
-	ESCC
 
-# if __GLASGOW_HASKELL__ >= 23
     put_pstr ps = _putPS file ps
-# endif
 
-# if __GLASGOW_HASKELL__ >= 23
 percent_d = _psToByteArray SLIT("%d")
-# else
-percent_d = "%d"
-# endif
 
-#endif {- __GLASGOW_HASKELL__ >= 22 -}
+#endif {- COMPILING_GHC -}
 \end{code}
diff --git a/ghc/compiler/utils/Digraph.hi b/ghc/compiler/utils/Digraph.hi
deleted file mode 100644
index f5e37f9bb5..0000000000
--- a/ghc/compiler/utils/Digraph.hi
+++ /dev/null
@@ -1,8 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface Digraph where
-import Maybes(MaybeErr)
-data MaybeErr a b 
-dfs :: (a -> a -> Bool) -> (a -> [a]) -> ([a], [a]) -> [a] -> ([a], [a])
-stronglyConnComp :: (a -> a -> Bool) -> [(a, a)] -> [a] -> [[a]]
-topologicalSort :: (a -> a -> Bool) -> [(a, a)] -> [a] -> MaybeErr [a] [[a]]
-
diff --git a/ghc/compiler/utils/Digraph.lhs b/ghc/compiler/utils/Digraph.lhs
index 84cf220919..2e8b03287f 100644
--- a/ghc/compiler/utils/Digraph.lhs
+++ b/ghc/compiler/utils/Digraph.lhs
@@ -1,18 +1,26 @@
 %
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
 %
 \section[Digraph]{An implementation of directed graphs}
 
 \begin{code}
+#include "HsVersions.h"
+
 module Digraph (
 	 stronglyConnComp,
---OLD:	 whichCycle, -- MOVED: isCyclic,
 	 topologicalSort,
-	 dfs, -- deforester
-	 MaybeErr
+	 dfs,
+	 MaybeErr,
+
+	 -- alternative interface
+	 findSCCs, SCC(..), Bag
     ) where
 
-import Maybes		( MaybeErr(..) )
+CHK_Ubiq() -- debugging consistency check
+
+import Maybes		( Maybe, MaybeErr(..), maybeToBool )
+import Bag		( Bag, filterBag, bagToList, listToBag )
+import FiniteMap	( FiniteMap, listToFM, lookupFM, lookupWithDefaultFM )
 import Util
 \end{code}
 
@@ -42,12 +50,12 @@ stronglyConnComp :: (vertex->vertex->Bool) -> [Edge vertex] -> [vertex] -> [[ver
 stronglyConnComp eq edges vertices
   = snd (span_tree (new_range reversed_edges)
 		    ([],[])
-                   ( snd (dfs (new_range edges) ([],[]) vertices) )
+		   ( snd (dfs (new_range edges) ([],[]) vertices) )
 	)
   where
     reversed_edges = map swap edges
 
-    swap (x,y) = (y, x)
+    swap (x,y) = (y,x)
 
     -- new_range :: Eq v => [Edge v] -> v -> [v]
 
@@ -61,20 +69,20 @@ stronglyConnComp eq edges vertices
     elem x (y:ys) = x `eq` y || x `elem` ys
 
 {-  span_tree :: Eq v => (v -> [v])
-		       -> ([v], [[v]])
-		       -> [v]
-		       -> ([v], [[v]])
+		      -> ([v], [[v]])
+		      -> [v]
+		      -> ([v], [[v]])
 -}
     span_tree r (vs,ns) []   = (vs,ns)
     span_tree r (vs,ns) (x:xs)
 	 | x `elem` vs = span_tree r (vs,ns) xs
 	 | True	       = case (dfs r (x:vs,[]) (r x)) of { (vs',ns') ->
 			 span_tree r (vs',(x:ns'):ns) xs }
-	     
+
 {-  dfs :: Eq v => (v -> [v])
-		 -> ([v], [v])
-		 -> [v]
-		 -> ([v], [v])
+		-> ([v], [v])
+		-> [v]
+		-> ([v], [v])
 -}
     dfs r (vs,ns)   []   = (vs,ns)
     dfs r (vs,ns) (x:xs) | x `elem` vs = dfs r (vs,ns) xs
@@ -90,41 +98,56 @@ dfs :: (v -> v -> Bool)
     -> ([v], [v])
 
 dfs eq r (vs,ns)   []   = (vs,ns)
-dfs eq r (vs,ns) (x:xs) 
+dfs eq r (vs,ns) (x:xs)
     	| any (eq x) vs = dfs eq r (vs,ns) xs
-	| True          = case (dfs eq r (x:vs,[]) (r x)) of 
+	| True          = case (dfs eq r (x:vs,[]) (r x)) of
 				(vs',ns') -> dfs eq r (vs',(x:ns')++ns) xs
-
 \end{code}
-  
-
-@isCyclic@ expects to be applied to an element of the result of a
-stronglyConnComp; it tells whether such an element is a cycle.  The
-answer is True if it is not a singleton, of course, but if it is a
-singleton we have to look up in the edges to see if it refers to
-itself.
 
 \begin{code}
-{- MOVED TO POINT OF SINGLE USE: RenameBinds4 (WDP 95/02)
+findSCCs :: Ord key
+	 => (vertex -> (key, Bag key))	-- Give key of vertex, and keys of thing's
+					-- immediate neighbours.  It's ok for the
+					-- list to contain keys which don't correspond
+					-- to any vertex; they are ignored.
+	 -> Bag vertex		-- Stuff to be SCC'd
+	 -> [SCC vertex]	-- The union of all these is the original bag
 
-isCyclic :: Eq vertex => [Edge vertex] -> [vertex] -> Bool
+data SCC thing = AcyclicSCC thing
+	       | CyclicSCC  (Bag thing)
 
-isCyclic edges [] = panic "isCyclic: empty component"
-isCyclic edges [v] = (v,v) `is_elem` edges where { is_elem = isIn "isCyclic" }
-isCyclic edges vs = True
--}
-\end{code}
+findSCCs v_info vs
+  = let
+        (keys, keys_of, edgess) = unzip3 (map do_vertex (bagToList vs))
+	key_map = listToFM keys_of
+	edges   = concat edgess
 
-OLD: The following @whichCycle@ should be called only when the given
-@vertex@ is known to be in one of the cycles. This isn't difficult to
-achieve if the call follows the creation of the list of components by
-@cycles@ (NB: strictness analyser) with all vertices of interest in
-them.
+	do_vertex v = (k, (k, (v, ok_ns)), ok_edges)
+	  where
+	    (k, ns)  = v_info v
+	    ok_ns    = filter key_in_graph (bagToList ns)
+	    ok_edges = map (\n->(k,n)) ok_ns
 
->{- UNUSED:
->whichCycle :: Eq vertex => [Cycle vertex] -> vertex -> (Cycle vertex)
->whichCycle vss v = head [vs | vs <-vss, v `is_elem` vs] where { is_elem = isIn "whichCycle" }
->-}
+	key_in_graph n = maybeToBool (lookupFM key_map n)
+
+	the_sccs = stronglyConnComp (==) edges keys 
+
+	cnv_sccs = map cnv_scc the_sccs 
+
+	cnv_scc []  = panic "findSCCs: empty component"
+	cnv_scc [k] | singlecycle k
+		    = AcyclicSCC (get_vertex k)
+        cnv_scc ks  = CyclicSCC (listToBag (map get_vertex ks))
+
+	singlecycle k = not (isIn "cycle" k (get_neighs k))
+
+	get_vertex k = fst (lookupWithDefaultFM key_map vpanic k)
+	get_neighs k = snd (lookupWithDefaultFM key_map vpanic k)
+
+	vpanic = panic "Digraph: vertix not found from key"
+    in
+    cnv_sccs
+\end{code}
 
 %************************************************************************
 %*									*
diff --git a/ghc/compiler/utils/FiniteMap.hi b/ghc/compiler/utils/FiniteMap.hi
deleted file mode 100644
index e70c039935..0000000000
--- a/ghc/compiler/utils/FiniteMap.hi
+++ /dev/null
@@ -1,33 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface FiniteMap where
-import Maybes(Labda)
-import Outputable(Outputable)
-data FiniteMap a b 
-type FiniteSet a = FiniteMap a ()
-data Labda a 
-addListToFM :: Ord a => FiniteMap a b -> [(a, b)] -> FiniteMap a b
-addListToFM_C :: Ord a => (b -> b -> b) -> FiniteMap a b -> [(a, b)] -> FiniteMap a b
-addToFM :: Ord a => FiniteMap a b -> a -> b -> FiniteMap a b
-delListFromFM :: Ord a => FiniteMap a b -> [a] -> FiniteMap a b
-elemFM :: Ord a => a -> FiniteMap a b -> Bool
-elementOf :: Ord a => a -> FiniteMap a () -> Bool
-eltsFM :: FiniteMap a b -> [b]
-emptyFM :: FiniteMap a b
-emptySet :: FiniteMap a ()
-fmToList :: FiniteMap a b -> [(a, b)]
-isEmptyFM :: FiniteMap a b -> Bool
-isEmptySet :: FiniteMap a () -> Bool
-keysFM :: FiniteMap b a -> [b]
-listToFM :: Ord a => [(a, b)] -> FiniteMap a b
-lookupFM :: Ord a => FiniteMap a b -> a -> Labda b
-lookupWithDefaultFM :: Ord a => FiniteMap a b -> b -> a -> b
-minusFM :: Ord a => FiniteMap a b -> FiniteMap a b -> FiniteMap a b
-minusSet :: Ord a => FiniteMap a () -> FiniteMap a () -> FiniteMap a ()
-mkSet :: Ord a => [a] -> FiniteMap a ()
-plusFM :: Ord a => FiniteMap a b -> FiniteMap a b -> FiniteMap a b
-plusFM_C :: Ord a => (b -> b -> b) -> FiniteMap a b -> FiniteMap a b -> FiniteMap a b
-setToList :: FiniteMap a () -> [a]
-singletonFM :: a -> b -> FiniteMap a b
-union :: Ord a => FiniteMap a () -> FiniteMap a () -> FiniteMap a ()
-instance Outputable a => Outputable (FiniteMap a b)
-
diff --git a/ghc/compiler/utils/FiniteMap.lhs b/ghc/compiler/utils/FiniteMap.lhs
index 56caa587ea..0308820f63 100644
--- a/ghc/compiler/utils/FiniteMap.lhs
+++ b/ghc/compiler/utils/FiniteMap.lhs
@@ -1,5 +1,5 @@
 %
-% (c) The AQUA Project, Glasgow University, 1994-1995
+% (c) The AQUA Project, Glasgow University, 1994-1996
 %
 \section[FiniteMap]{An implementation of finite maps}
 
@@ -18,7 +18,7 @@ The code is SPECIALIZEd to various highly-desirable types (e.g., Id)
 near the end (only \tr{#ifdef COMPILING_GHC}).
 
 \begin{code}
-#if defined(COMPILING_GHC)
+#ifdef COMPILING_GHC
 #include "HsVersions.h"
 #define IF_NOT_GHC(a) {--}
 #else
@@ -52,10 +52,10 @@ module FiniteMap (
 
 	IF_NOT_GHC(sizeFM COMMA)
 	isEmptyFM, elemFM, lookupFM, lookupWithDefaultFM,
-	
+
 	fmToList, keysFM, eltsFM{-used in GHCI-}
 
-#if defined(COMPILING_GHC)
+#ifdef COMPILING_GHC
 	, FiniteSet(..), emptySet, mkSet, isEmptySet
 	, elementOf, setToList, union, minusSet{-exported for GHCI-}
 #endif
@@ -68,14 +68,12 @@ module FiniteMap (
 
 import Maybes
 
-#if defined(COMPILING_GHC)
-import AbsUniType
+#ifdef COMPILING_GHC
+import Ubiq{-uitous-}
+# ifdef DEBUG
 import Pretty
-import Outputable
-import Util
-import CLabelInfo	( CLabel )  -- for specialising
+# endif
 #if ! OMIT_NATIVE_CODEGEN
-import AsmRegAlloc	( Reg )	    -- ditto
 #define IF_NCG(a) a
 #else
 #define IF_NCG(a) {--}
@@ -113,10 +111,10 @@ addListToFM	:: (Ord key OUTPUTABLE_key) => FiniteMap key elt -> [(key,elt)] -> F
 
 		   -- Combines with previous binding
 addToFM_C	:: (Ord key OUTPUTABLE_key) => (elt -> elt -> elt)
-			   -> FiniteMap key elt -> key -> elt  
+			   -> FiniteMap key elt -> key -> elt
 			   -> FiniteMap key elt
 addListToFM_C	:: (Ord key OUTPUTABLE_key) => (elt -> elt -> elt)
-			   -> FiniteMap key elt -> [(key,elt)] 
+			   -> FiniteMap key elt -> [(key,elt)]
 			   -> FiniteMap key elt
 
 		   -- Deletion doesn't complain if you try to delete something
@@ -130,20 +128,20 @@ plusFM		:: (Ord key OUTPUTABLE_key) => FiniteMap key elt -> FiniteMap key elt
 			   -> FiniteMap key elt
 
 		   -- Combines bindings for the same thing with the given function
-plusFM_C	:: (Ord key OUTPUTABLE_key) => (elt -> elt -> elt) 
+plusFM_C	:: (Ord key OUTPUTABLE_key) => (elt -> elt -> elt)
 			   -> FiniteMap key elt -> FiniteMap key elt -> FiniteMap key elt
 
 minusFM		:: (Ord key OUTPUTABLE_key) => FiniteMap key elt -> 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	:: (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 
+			   -> FiniteMap key elt -> FiniteMap key elt -> FiniteMap key elt
 
 --	MAPPING, FOLDING, FILTERING
 foldFM		:: (key -> elt -> a -> a) -> a -> FiniteMap key elt -> a
 mapFM		:: (key -> elt1 -> elt2) -> FiniteMap key elt1 -> FiniteMap key elt2
-filterFM	:: (Ord key OUTPUTABLE_key) => (key -> elt -> Bool) 
+filterFM	:: (Ord key OUTPUTABLE_key) => (key -> elt -> Bool)
 			   -> FiniteMap key elt -> FiniteMap key elt
 
 --	INTERROGATING
@@ -185,7 +183,7 @@ factor of at most \tr{sIZE_RATIO}
 
 \begin{code}
 data FiniteMap key elt
-  = EmptyFM 
+  = EmptyFM
   | Branch key elt	    	-- Key and elt stored here
     IF_GHC(Int#,Int{-STRICT-})	-- Size >= 1
     (FiniteMap key elt)	    	-- Children
@@ -246,7 +244,7 @@ delFromFM (Branch key elt size fm_l fm_r) del_key
 	_GT -> mkBalBranch key elt fm_l (delFromFM fm_r del_key)
 	_LT -> mkBalBranch key elt (delFromFM fm_l del_key) fm_r
 	_EQ -> glueBal fm_l fm_r
-#else	
+#else
   | del_key > key
   = mkBalBranch key elt fm_l (delFromFM fm_r del_key)
 
@@ -270,7 +268,7 @@ delListFromFM fm keys = foldl delFromFM fm keys
 plusFM_C combiner EmptyFM fm2 = fm2
 plusFM_C combiner fm1 EmptyFM = fm1
 plusFM_C combiner fm1 (Branch split_key elt2 _ left right)
-  = mkVBalBranch split_key new_elt 
+  = mkVBalBranch split_key new_elt
 		 (plusFM_C combiner lts left)
 		 (plusFM_C combiner gts right)
   where
@@ -308,7 +306,7 @@ intersectFM_C combiner fm1 (Branch split_key elt2 _ left right)
 
   | maybeToBool maybe_elt1	-- split_elt *is* in intersection
   = mkVBalBranch split_key (combiner elt1 elt2) (intersectFM_C combiner lts left)
-					        (intersectFM_C combiner gts right)
+						(intersectFM_C combiner gts right)
 
   | otherwise			-- split_elt is *not* in intersection
   = glueVBal (intersectFM_C combiner lts left) (intersectFM_C combiner gts right)
@@ -333,7 +331,7 @@ foldFM k z (Branch key elt _ fm_l fm_r)
   = foldFM k (k key elt (foldFM k z fm_r)) fm_l
 
 mapFM f EmptyFM = emptyFM
-mapFM f (Branch key elt size fm_l fm_r) 
+mapFM f (Branch key elt size fm_l fm_r)
   = Branch key (f key elt) size (mapFM f fm_l) (mapFM f fm_r)
 
 filterFM p EmptyFM = emptyFM
@@ -364,7 +362,7 @@ lookupFM (Branch key elt _ fm_l fm_r) key_to_find
   = case _tagCmp key_to_find key of
 	_LT -> lookupFM fm_l key_to_find
 	_GT -> lookupFM fm_r key_to_find
-        _EQ -> Just elt
+	_EQ -> Just elt
 #else
   | key_to_find < key = lookupFM fm_l key_to_find
   | key_to_find > key = lookupFM fm_r key_to_find
@@ -414,7 +412,7 @@ sIZE_RATIO = 5
 
 mkBranch :: (Ord key OUTPUTABLE_key) 		-- Used for the assertion checking only
 	 => Int
-	 -> key -> elt 
+	 -> key -> elt
 	 -> FiniteMap key elt -> FiniteMap key elt
 	 -> FiniteMap key elt
 
@@ -486,41 +484,41 @@ out of whack.
 
 \begin{code}
 mkBalBranch :: (Ord key OUTPUTABLE_key)
-	    => key -> elt 
+	    => key -> elt
 	    -> FiniteMap key elt -> FiniteMap key elt
 	    -> FiniteMap key elt
 
 mkBalBranch key elt fm_L fm_R
 
-  | size_l + size_r < 2 
+  | size_l + size_r < 2
   = mkBranch 1{-which-} key elt fm_L fm_R
 
   | size_r > sIZE_RATIO * size_l	-- Right tree too big
   = case fm_R of
-	Branch _ _ _ fm_rl fm_rr 
+	Branch _ _ _ fm_rl fm_rr
 		| sizeFM fm_rl < 2 * sizeFM fm_rr -> single_L fm_L fm_R
 		| otherwise	   	          -> double_L fm_L fm_R
 	-- Other case impossible
 
   | size_l > sIZE_RATIO * size_r	-- Left tree too big
   = case fm_L of
-	Branch _ _ _ fm_ll fm_lr 
+	Branch _ _ _ fm_ll fm_lr
 		| sizeFM fm_lr < 2 * sizeFM fm_ll -> single_R fm_L fm_R
 		| otherwise		          -> double_R fm_L fm_R
 	-- Other case impossible
 
   | otherwise				-- No imbalance
   = mkBranch 2{-which-} key elt fm_L fm_R
-  
+
   where
     size_l   = sizeFM fm_L
     size_r   = sizeFM fm_R
 
-    single_L fm_l (Branch key_r elt_r _ fm_rl fm_rr) 
+    single_L fm_l (Branch key_r elt_r _ fm_rl fm_rr)
 	= mkBranch 3{-which-} key_r elt_r (mkBranch 4{-which-} key elt fm_l fm_rl) fm_rr
 
     double_L fm_l (Branch key_r elt_r _ (Branch key_rl elt_rl _ fm_rll fm_rlr) fm_rr)
-	= mkBranch 5{-which-} key_rl elt_rl (mkBranch 6{-which-} key   elt   fm_l   fm_rll) 
+	= mkBranch 5{-which-} key_rl elt_rl (mkBranch 6{-which-} key   elt   fm_l   fm_rll)
 				 (mkBranch 7{-which-} key_r elt_r fm_rlr fm_rr)
 
     single_R (Branch key_l elt_l _ fm_ll fm_lr) fm_r
@@ -534,7 +532,7 @@ mkBalBranch key elt fm_L fm_R
 
 \begin{code}
 mkVBalBranch :: (Ord key OUTPUTABLE_key)
-	     => key -> elt 
+	     => key -> elt
 	     -> FiniteMap key elt -> FiniteMap key elt
 	     -> FiniteMap key elt
 
@@ -557,7 +555,7 @@ mkVBalBranch key elt fm_l@(Branch key_l elt_l _ fm_ll fm_lr)
   | otherwise
   = mkBranch 13{-which-} key elt fm_l fm_r
 
-  where 
+  where
     size_l = sizeFM fm_l
     size_r = sizeFM fm_r
 \end{code}
@@ -579,13 +577,13 @@ glueBal :: (Ord key OUTPUTABLE_key)
 
 glueBal EmptyFM fm2 = fm2
 glueBal fm1 EmptyFM = fm1
-glueBal fm1 fm2 
+glueBal fm1 fm2
 	-- The case analysis here (absent in Adams' program) is really to deal
 	-- with the case where fm2 is a singleton. Then deleting the minimum means
 	-- we pass an empty tree to mkBalBranch, which breaks its invariant.
   | sizeFM fm2 > sizeFM fm1
   = mkBalBranch mid_key2 mid_elt2 fm1 (deleteMin fm2)
-	
+
   | otherwise
   = mkBalBranch mid_key1 mid_elt1 (deleteMax fm1) fm2
   where
@@ -604,7 +602,7 @@ glueVBal :: (Ord key OUTPUTABLE_key)
 glueVBal EmptyFM fm2 = fm2
 glueVBal fm1 EmptyFM = fm1
 glueVBal fm_l@(Branch key_l elt_l _ fm_ll fm_lr)
-         fm_r@(Branch key_r elt_r _ fm_rl fm_rr)
+	 fm_r@(Branch key_r elt_r _ fm_rl fm_rr)
   | sIZE_RATIO * size_l < size_r
   = mkBalBranch key_r elt_r (glueVBal fm_l fm_rl) fm_rr
 
@@ -630,7 +628,6 @@ glueVBal fm_l@(Branch key_l elt_l _ fm_ll fm_lr)
 splitLT, splitGT :: (Ord key OUTPUTABLE_key) => FiniteMap key elt -> key -> FiniteMap key elt
 
 -- splitLT fm split_key  =  fm restricted to keys <  split_key
--- splitGE fm split_key  =  fm restricted to keys >= split_key (UNUSED)
 -- splitGT fm split_key  =  fm restricted to keys >  split_key
 
 splitLT EmptyFM split_key = emptyFM
@@ -646,21 +643,6 @@ splitLT (Branch key elt _ fm_l fm_r) split_key
   | otherwise	    = fm_l
 #endif
 
-{- UNUSED:
-splitGE EmptyFM split_key = emptyFM
-splitGE (Branch key elt _ fm_l fm_r) split_key
-#ifdef __GLASGOW_HASKELL__
-  = case _tagCmp split_key key of
-	_GT -> splitGE fm_r split_key
-	_LT -> mkVBalBranch key elt (splitGE fm_l split_key) fm_r
-	_EQ -> mkVBalBranch key elt emptyFM fm_r
-#else
-  | split_key > key = splitGE fm_r split_key
-  | split_key < key = mkVBalBranch key elt (splitGE fm_l split_key) fm_r
-  | otherwise	    = mkVBalBranch key elt emptyFM fm_r
-#endif
--}
-
 splitGT EmptyFM split_key = emptyFM
 splitGT (Branch key elt _ fm_l fm_r) split_key
 #ifdef __GLASGOW_HASKELL__
@@ -698,14 +680,8 @@ deleteMax (Branch key elt _ fm_l    fm_r) = mkBalBranch key elt fm_l (deleteMax
 %************************************************************************
 
 \begin{code}
-#if defined(COMPILING_GHC)
-
-{- this is the real one actually...
-instance (Outputable key, Outputable elt) => Outputable (FiniteMap key elt) where
-    ppr sty fm = ppr sty (fmToList fm)
--}
+#if defined(COMPILING_GHC) && defined(DEBUG_FINITEMAPS)
 
--- temp debugging (ToDo: rm)
 instance (Outputable key) => Outputable (FiniteMap key elt) where
     ppr sty fm = pprX sty fm
 
@@ -716,15 +692,15 @@ pprX sty (Branch key elt sz fm_l fm_r)
 	      pprX sty fm_r, ppRparen]
 #endif
 
-#if !defined(COMPILING_GHC)
+#ifndef COMPILING_GHC
 instance (Eq key, Eq elt) => Eq (FiniteMap key elt) where
   fm_1 == fm_2 = (sizeFM   fm_1 == sizeFM   fm_2) &&   -- quick test
-                 (fmToList fm_1 == fmToList fm_2)
+		 (fmToList fm_1 == fmToList fm_2)
 
 {- NO: not clear what The Right Thing to do is:
 instance (Ord key, Ord elt) => Ord (FiniteMap key elt) where
   fm_1 <= fm_2 = (sizeFM   fm_1 <= sizeFM   fm_2) &&   -- quick test
-                 (fmToList fm_1 <= fmToList fm_2)
+		 (fmToList fm_1 <= fmToList fm_2)
 -}
 #endif
 \end{code}
@@ -736,7 +712,7 @@ instance (Ord key, Ord elt) => Ord (FiniteMap key elt) where
 %************************************************************************
 
 \begin{code}
-#if defined(COMPILING_GHC)
+#ifdef COMPILING_GHC
 
 type FiniteSet key = FiniteMap key ()
 emptySet	:: FiniteSet key
@@ -768,8 +744,8 @@ When the FiniteMap module is used in GHC, we specialise it for
 \tr{Uniques}, for dastardly efficiency reasons.
 
 \begin{code}
+#if 0
 #if defined(COMPILING_GHC) && __GLASGOW_HASKELL__
-    -- the __GLASGOW_HASKELL__ chk avoids an hbc 0.999.7 bug
 
 {-# SPECIALIZE listToFM
 		:: [(Int,elt)] -> FiniteMap Int elt,
@@ -860,4 +836,5 @@ When the FiniteMap module is used in GHC, we specialise it for
     #-}
 
 #endif {- compiling for GHC -}
+#endif {- 0 -}
 \end{code}
diff --git a/ghc/compiler/utils/LiftMonad.hi b/ghc/compiler/utils/LiftMonad.hi
deleted file mode 100644
index 22b0a2a9b9..0000000000
--- a/ghc/compiler/utils/LiftMonad.hi
+++ /dev/null
@@ -1,4 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface LiftMonad where
-bogusLiftMonadThing :: Bool
-
diff --git a/ghc/compiler/utils/LiftMonad.lhs b/ghc/compiler/utils/LiftMonad.lhs
deleted file mode 100644
index 40a84e5802..0000000000
--- a/ghc/compiler/utils/LiftMonad.lhs
+++ /dev/null
@@ -1,39 +0,0 @@
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
-%
-\section[LiftMonad]{A lifting monad}
-
-\begin{code}
-#if defined(__GLASGOW_HASKELL__)
-module LiftMonad where { bogusLiftMonadThing = True }
-
-#else
-module LiftMonad (
-	LiftM,	-- abstract
-	thenLft, returnLft, mapLft
-    ) where
-
-infixr 9 `thenLft`
-
-data LiftM a = MkLiftM a
-	-- Just add a bottom element under the domain
-\end{code}
-
-Notice that @thenLft@ is strict in its first argument.
-
-\begin{code}
-thenLft :: LiftM a -> (a -> b) -> b
-(MkLiftM x) `thenLft` cont = cont x
-
-returnLft :: a -> LiftM a
-returnLft a = MkLiftM a
-
-mapLft :: (a -> LiftM b) -> [a] -> LiftM [b]
-mapLft f []  	 = returnLft []
-mapLft f (x:xs)
-  = f x		  `thenLft` \ x2 ->
-    mapLft f xs   `thenLft` \ xs2 ->
-    returnLft (x2 : xs2)
-
-#endif
-\end{code}
diff --git a/ghc/compiler/utils/ListSetOps.hi b/ghc/compiler/utils/ListSetOps.hi
deleted file mode 100644
index f4502fdbed..0000000000
--- a/ghc/compiler/utils/ListSetOps.hi
+++ /dev/null
@@ -1,6 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface ListSetOps where
-intersectLists :: Eq a => [a] -> [a] -> [a]
-minusList :: Eq a => [a] -> [a] -> [a]
-unionLists :: Eq a => [a] -> [a] -> [a]
-
diff --git a/ghc/compiler/utils/ListSetOps.lhs b/ghc/compiler/utils/ListSetOps.lhs
index dbc749c2e2..fe9dcca7fe 100644
--- a/ghc/compiler/utils/ListSetOps.lhs
+++ b/ghc/compiler/utils/ListSetOps.lhs
@@ -16,7 +16,7 @@ module ListSetOps (
 #if defined(COMPILING_GHC)
 import Util
 # ifdef USE_ATTACK_PRAGMAS
-import AbsUniType
+import Type
 import Id		( Id )
 # endif
 #endif
diff --git a/ghc/compiler/utils/MatchEnv.lhs b/ghc/compiler/utils/MatchEnv.lhs
new file mode 100644
index 0000000000..28b8ad2e3d
--- /dev/null
+++ b/ghc/compiler/utils/MatchEnv.lhs
@@ -0,0 +1,112 @@
+%************************************************************************
+%*									*
+\subsection[MatchEnv]{Matching environments}
+%*									*
+%************************************************************************
+
+\begin{code}
+#include "HsVersions.h"
+
+module MatchEnv (
+	MatchEnv, nullMEnv, mkMEnv,
+	lookupMEnv, insertMEnv,
+	mEnvToList
+) where
+
+CHK_Ubiq() -- debugging consistency check
+
+import Maybes	( MaybeErr(..), returnMaB, thenMaB, failMaB )
+\end{code}
+
+``Matching'' environments allow you to bind a template to a value;
+when you look up in it, you supply a value which is matched against
+the template.
+
+\begin{code}
+data MatchEnv key value 
+  = EmptyME			-- Common, so special-cased
+  | ME [(key, value)]
+\end{code}
+
+For now we just use association lists. The list is maintained sorted
+in order of {\em decreasing specificness} of @key@, so that the first
+match will be the most specific.
+
+\begin{code}
+nullMEnv :: MatchEnv a b
+nullMEnv = EmptyME
+
+mkMEnv :: [(key, value)] -> MatchEnv key value
+mkMEnv stuff = ME stuff
+
+mEnvToList :: MatchEnv key value -> [(key, value)]
+mEnvToList EmptyME = []
+mEnvToList (ME stuff) = stuff
+\end{code}
+
+@lookupMEnv@ looks up in a @MatchEnv@.  It simply takes the first
+match, which should be the most specific.
+
+\begin{code}
+lookupMEnv :: (key1 {- template -} ->	-- Matching function
+	       key2 {- instance -} ->
+	       Maybe match_info)
+	   -> MatchEnv key1 value	-- The envt
+	   -> key2			-- Key
+	   -> Maybe (value,		-- Value
+		     match_info)	-- Match info returned by matching fn
+		     
+
+lookupMEnv key_match EmptyME    key = Nothing
+lookupMEnv key_match (ME alist) key
+  = find alist
+  where
+    find [] = Nothing
+    find ((tpl, val) : rest)
+      = case (key_match tpl key) of
+	  Nothing	  -> find rest
+	  Just match_info -> Just (val,match_info)
+\end{code}
+
+@insertMEnv@ extends a match environment, checking for overlaps.
+
+\begin{code}
+insertMEnv :: (key {- template -} ->		-- Matching function
+	       key {- instance -} ->
+	       Maybe match_info)
+	   -> MatchEnv key value		-- Envt
+	   -> key -> value			-- New item
+	   -> MaybeErr (MatchEnv key value)	-- Success...
+		       (key, value)		-- Failure: Offending overlap
+
+insertMEnv match_fn EmptyME    key value = returnMaB (ME [(key, value)])
+insertMEnv match_fn (ME alist) key value
+  = insert alist
+  where
+    -- insertMEnv has to put the new item in BEFORE any keys which are
+    -- LESS SPECIFIC than the new key, and AFTER any keys which are
+    -- MORE SPECIFIC The list is maintained in specific-ness order, so
+    -- we just stick it in either last, or just before the first key
+    -- of which the new key is an instance.  We check for overlap at
+    -- that point.
+
+    insert [] = returnMaB (ME [(key, value)])
+    insert ((t,v) : rest)
+      = case (match_fn t key) of
+	  Nothing ->
+	    -- New key is not an instance of this existing one, so
+	    -- continue down the list.
+	    insert rest			`thenMaB` \ (ME rest') ->
+	    returnMaB (ME((t,v):rest'))
+
+	  Just match_info ->
+	    -- New key *is* an instance of the old one, so check the
+	    -- other way round in case of identity.
+
+	    case (match_fn key t) of
+	      Just _  -> failMaB (t,v)
+			 -- Oops; overlap
+
+	      Nothing -> returnMaB (ME ((key,value):(t,v):rest))
+			 -- All ok; insert here
+\end{code}
diff --git a/ghc/compiler/utils/Maybes.hi b/ghc/compiler/utils/Maybes.hi
deleted file mode 100644
index 0a96c2b91a..0000000000
--- a/ghc/compiler/utils/Maybes.hi
+++ /dev/null
@@ -1,18 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface Maybes where
-data Labda a   = Hamna | Ni a
-data MaybeErr a b   = Succeeded a | Failed b
-allMaybes :: [Labda a] -> Labda [a]
-assocMaybe :: Eq a => [(a, b)] -> a -> Labda b
-catMaybes :: [Labda a] -> [a]
-failMaB :: b -> MaybeErr a b
-failMaybe :: Labda a
-firstJust :: [Labda a] -> Labda a
-mapMaybe :: (a -> Labda b) -> [a] -> Labda [b]
-maybeToBool :: Labda a -> Bool
-mkLookupFun :: (a -> a -> Bool) -> [(a, b)] -> a -> Labda b
-returnMaB :: a -> MaybeErr a b
-returnMaybe :: a -> Labda a
-thenMaB :: MaybeErr a c -> (a -> MaybeErr b c) -> MaybeErr b c
-thenMaybe :: Labda a -> (a -> Labda b) -> Labda b
-
diff --git a/ghc/compiler/utils/Maybes.lhs b/ghc/compiler/utils/Maybes.lhs
index 66c12797bc..146553409f 100644
--- a/ghc/compiler/utils/Maybes.lhs
+++ b/ghc/compiler/utils/Maybes.lhs
@@ -1,5 +1,5 @@
 %
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
 %
 \section[Maybes]{The `Maybe' types and associated utility functions}
 
@@ -9,17 +9,22 @@
 #endif
 
 module Maybes (
-	Maybe(..), MaybeErr(..),
+--	Maybe(..), -- no, it's in 1.3
+	MaybeErr(..),
 
 	allMaybes,	-- GHCI only
-	assocMaybe,
 	catMaybes,
+	firstJust,
+	expectJust,
+	maybeToBool,
+
+	assocMaybe,
+	mkLookupFun, mkLookupFunDef,
+
 	failMaB,
 	failMaybe,
-	firstJust,
+	seqMaybe,
 	mapMaybe,	-- GHCI only
-	maybeToBool,
-	mkLookupFun,
 	returnMaB,
 	returnMaybe,	-- GHCI only
 	thenMaB,
@@ -33,11 +38,9 @@ module Maybes (
     ) where
 
 #if defined(COMPILING_GHC)
-import AbsUniType
-import Id
-import IdInfo
-import Name
-import Outputable
+
+CHK_Ubiq() -- debugging consistency check
+
 #if USE_ATTACK_PRAGMAS
 import Util
 #endif
@@ -65,7 +68,7 @@ maybeToBool Nothing  = False
 maybeToBool (Just x) = True
 \end{code}
 
-@catMaybes@ takes a list of @Maybe@s and returns a list of 
+@catMaybes@ takes a list of @Maybe@s and returns a list of
 the contents of all the @Just@s in it.	@allMaybes@ collects
 a list of @Justs@ into a single @Just@, returning @Nothing@ if there
 are any @Nothings@.
@@ -102,6 +105,43 @@ findJust f (a:as) = case f a of
 		      b	 -> b
 \end{code}
 
+\begin{code}
+expectJust :: String -> Maybe a -> a
+{-# INLINE expectJust #-}
+expectJust err (Just x) = x
+expectJust err Nothing  = error ("expectJust " ++ err)
+\end{code}
+
+The Maybe monad
+~~~~~~~~~~~~~~~
+\begin{code}
+#if __HASKELL1__ < 3
+thenMaybe :: Maybe a -> (a -> Maybe b) -> Maybe b
+m `thenMaybe` k = case m of
+		  Nothing -> Nothing
+		  Just a  -> k a
+#endif
+
+seqMaybe :: Maybe a -> Maybe a -> Maybe a
+seqMaybe (Just x) _  = Just x
+seqMaybe Nothing  my = my
+
+returnMaybe :: a -> Maybe a
+returnMaybe = Just
+
+failMaybe :: Maybe a
+failMaybe = Nothing
+
+mapMaybe :: (a -> Maybe b) -> [a] -> Maybe [b]
+mapMaybe f []	  = returnMaybe []
+mapMaybe f (x:xs) = f x			`thenMaybe` \ x' ->
+		    mapMaybe f xs	`thenMaybe` \ xs' ->
+		    returnMaybe (x':xs')
+\end{code}
+
+Lookup functions
+~~~~~~~~~~~~~~~~
+
 @assocMaybe@ looks up in an assocation list, returning
 @Nothing@ if it fails.
 
@@ -115,7 +155,7 @@ assocMaybe alist key
     lookup ((tv,ty):rest) = if key == tv then Just ty else lookup rest
 
 #if defined(COMPILING_GHC)
-{-# SPECIALIZE assocMaybe
+{-? SPECIALIZE assocMaybe
 	:: [(String,        b)] -> String        -> Maybe b,
 	   [(Id,            b)] -> Id            -> Maybe b,
 	   [(Class,         b)] -> Class         -> Maybe b,
@@ -127,8 +167,10 @@ assocMaybe alist key
 #endif
 \end{code}
 
-@mkLookupFun alist s@ is a function which looks up
-@s@ in the association list @alist@, returning a Maybe type.
+@mkLookupFun eq alist@ is a function which looks up
+its argument in the association list @alist@, returning a Maybe type.
+@mkLookupFunDef@ is similar except that it is given a value to return
+on failure.
 
 \begin{code}
 mkLookupFun :: (key -> key -> Bool)	-- Equality predicate
@@ -140,26 +182,17 @@ mkLookupFun eq alist s
   = case [a | (s',a) <- alist, s' `eq` s] of
       []    -> Nothing
       (a:_) -> Just a
-\end{code}
 
-\begin{code}
-#if __HASKELL1__ < 3
-thenMaybe :: Maybe a -> (a -> Maybe b) -> Maybe b
-m `thenMaybe` k = case m of
-		  Nothing -> Nothing
-		  Just a  -> k a
-#endif
-returnMaybe :: a -> Maybe a
-returnMaybe = Just 
+mkLookupFunDef :: (key -> key -> Bool)	-- Equality predicate
+	       -> [(key,val)] 		-- The assoc list
+	       -> val 			-- Value to return on failure
+	       -> key 			-- The key
+	       -> val			-- The corresponding value
 
-failMaybe :: Maybe a
-failMaybe = Nothing
-
-mapMaybe :: (a -> Maybe b) -> [a] -> Maybe [b]
-mapMaybe f []	  = returnMaybe []
-mapMaybe f (x:xs) = f x				`thenMaybe` (\ x' ->
-		    mapMaybe f xs		`thenMaybe` (\ xs' ->
-		    returnMaybe (x':xs')		     ))
+mkLookupFunDef eq alist deflt s
+  = case [a | (s',a) <- alist, s' `eq` s] of
+      []    -> deflt
+      (a:_) -> a
 \end{code}
 
 %************************************************************************
@@ -194,7 +227,7 @@ a @Succeeded@ of a list of their values.  If any fail, it returns a
 \begin{code}
 listMaybeErrs :: [MaybeErr val err] -> MaybeErr [val] [err]
 listMaybeErrs
-  = foldr combine (Succeeded []) 
+  = foldr combine (Succeeded [])
   where
     combine (Succeeded v) (Succeeded vs) = Succeeded (v:vs)
     combine (Failed err)  (Succeeded _)	 = Failed [err]
diff --git a/ghc/compiler/utils/OrdList.lhs b/ghc/compiler/utils/OrdList.lhs
new file mode 100644
index 0000000000..223ff88422
--- /dev/null
+++ b/ghc/compiler/utils/OrdList.lhs
@@ -0,0 +1,59 @@
+%
+% (c) The AQUA Project, Glasgow University, 1993-1996
+%
+
+This is useful, general stuff for the Native Code Generator.
+
+\begin{code}
+module OrdList (
+	OrdList,
+
+    	mkParList, mkSeqList, mkEmptyList, mkUnitList,
+
+    	flattenOrdList
+    ) where
+
+import Util	( mapAccumB, mapAccumL, mapAccumR )
+\end{code}
+
+This section provides an ordering list that allows fine grain
+parallelism to be expressed.  This is used (ultimately) for scheduling
+of assembly language instructions.
+
+\begin{code}
+data OrdList a
+  = SeqList (OrdList a) (OrdList a)
+  | ParList (OrdList a) (OrdList a)
+  | OrdObj a
+  | NoObj
+  deriving ()
+
+mkSeqList a b = SeqList a b
+mkParList a b = ParList a b
+mkEmptyList   = NoObj
+mkUnitList    = OrdObj
+\end{code}
+
+%------------------------------------------------------------------------
+
+Notice this this throws away all potential expression of parallelism.
+
+\begin{code}
+flattenOrdList :: OrdList a -> [a]
+
+flattenOrdList ol
+  = flat ol []
+  where
+    flat NoObj         rest = rest
+    flat (OrdObj x)    rest = x:rest
+    flat (ParList a b) rest = flat a (flat b rest)
+    flat (SeqList a b) rest = flat a (flat b rest)
+
+{- DEBUGGING ONLY:
+instance Text (OrdList a) where
+    showsPrec _ NoObj	= showString "_N_"
+    showsPrec _ (OrdObj _) = showString "_O_"
+    showsPrec _ (ParList a b) = showString "(PAR " . shows a . showChar ')'
+    showsPrec _ (SeqList a b) = showString "(SEQ " . shows a . showChar ')'
+-}
+\end{code}
diff --git a/ghc/compiler/utils/Outputable.hi b/ghc/compiler/utils/Outputable.hi
deleted file mode 100644
index d28717d94e..0000000000
--- a/ghc/compiler/utils/Outputable.hi
+++ /dev/null
@@ -1,52 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface Outputable where
-import CharSeq(CSeq)
-import CmdLineOpts(GlobalSwitch)
-import PreludePS(_PackedString)
-import Pretty(Delay, PprStyle(..), Pretty(..), PrettyRep)
-import SrcLoc(SrcLoc)
-import UniType(UniType)
-import Unique(Unique)
-class NamedThing a where
-	getExportFlag :: a -> ExportFlag
-	isLocallyDefined :: a -> Bool
-	getOrigName :: a -> (_PackedString, _PackedString)
-	getOccurrenceName :: a -> _PackedString
-	getInformingModules :: a -> [_PackedString]
-	getSrcLoc :: a -> SrcLoc
-	getTheUnique :: a -> Unique
-	hasType :: a -> Bool
-	getType :: a -> UniType
-	fromPreludeCore :: a -> Bool
-class Outputable a where
-	ppr :: PprStyle -> a -> Int -> Bool -> PrettyRep
-data ExportFlag   = ExportAll | ExportAbs | NotExported
-data GlobalSwitch 
-data PprStyle   = PprForUser | PprDebug | PprShowAll | PprInterface (GlobalSwitch -> Bool) | PprForC (GlobalSwitch -> Bool) | PprUnfolding (GlobalSwitch -> Bool) | PprForAsm (GlobalSwitch -> Bool) Bool ([Char] -> [Char])
-type Pretty = Int -> Bool -> PrettyRep
-data PrettyRep 
-data SrcLoc 
-data UniType 
-data Unique 
-getLocalName :: NamedThing a => a -> _PackedString
-ifPprDebug :: PprStyle -> (Int -> Bool -> PrettyRep) -> Int -> Bool -> PrettyRep
-ifPprInterface :: PprStyle -> (Int -> Bool -> PrettyRep) -> Int -> Bool -> PrettyRep
-ifPprShowAll :: PprStyle -> (Int -> Bool -> PrettyRep) -> Int -> Bool -> PrettyRep
-ifnotPprForUser :: PprStyle -> (Int -> Bool -> PrettyRep) -> Int -> Bool -> PrettyRep
-ifnotPprShowAll :: PprStyle -> (Int -> Bool -> PrettyRep) -> Int -> Bool -> PrettyRep
-interpp'SP :: Outputable a => PprStyle -> [a] -> Int -> Bool -> PrettyRep
-interppSP :: Outputable a => PprStyle -> [a] -> Int -> Bool -> PrettyRep
-isAconop :: _PackedString -> Bool
-isAvarid :: _PackedString -> Bool
-isAvarop :: _PackedString -> Bool
-isConop :: _PackedString -> Bool
-isExported :: NamedThing a => a -> Bool
-isOpLexeme :: NamedThing a => a -> Bool
-ltLexical :: (NamedThing a, NamedThing b) => a -> b -> Bool
-pprNonOp :: (NamedThing a, Outputable a) => PprStyle -> a -> Int -> Bool -> PrettyRep
-pprOp :: (NamedThing a, Outputable a) => PprStyle -> a -> Int -> Bool -> PrettyRep
-instance (Outputable a, Outputable b) => Outputable (a, b)
-instance (Outputable a, Outputable b, Outputable c) => Outputable (a, b, c)
-instance Outputable Bool
-instance Outputable a => Outputable [a]
-
diff --git a/ghc/compiler/utils/Outputable.lhs b/ghc/compiler/utils/Outputable.lhs
index 2e9a382fad..3ba5f55b73 100644
--- a/ghc/compiler/utils/Outputable.lhs
+++ b/ghc/compiler/utils/Outputable.lhs
@@ -1,5 +1,5 @@
 %
-% (c) The GRASP Project, Glasgow University, 1992-1995
+% (c) The GRASP Project, Glasgow University, 1992-1996
 %
 \section[Outputable]{Classes for pretty-printing}
 
@@ -17,38 +17,24 @@ module Outputable (
 
 	-- PRINTERY AND FORCERY
 	Outputable(..), 	-- class
-	PprStyle(..),		-- style-ry (re-exported)
 
 	interppSP, interpp'SP,
---UNUSED: ifPprForUser,
 	ifnotPprForUser,
-	ifPprDebug, --UNUSED: ifnotPprDebug,
+	ifPprDebug,
 	ifPprShowAll, ifnotPprShowAll,
-	ifPprInterface, --UNUSED: ifnotPprInterface,
---UNUSED: ifPprForC, ifnotPprForC,
---UNUSED: ifPprUnfolding, ifnotPprUnfolding,
+	ifPprInterface,
 
 	isOpLexeme, pprOp, pprNonOp,
-	isConop, isAconop, isAvarid, isAvarop, --UNUSED: isAconid,
+	isConop, isAconop, isAvarid, isAvarop
 
 	-- and to make the interface self-sufficient...
-	Pretty(..), GlobalSwitch,
-	PrettyRep, UniType, Unique, SrcLoc
     ) where
 
-import AbsUniType	( UniType,
-			  TyCon, Class, TyVar, TyVarTemplate -- for SPECIALIZing
-			  IF_ATTACK_PRAGMAS(COMMA cmpUniType)
-			  IF_ATTACK_PRAGMAS(COMMA cmpTyVar)
-			  IF_ATTACK_PRAGMAS(COMMA cmpTyCon)
-			)
-import Id		( Id ) -- for specialising
-import NameTypes	-- for specialising
-import ProtoName	-- for specialising
+import Ubiq{-uitous-}
+
+import PprStyle		( PprStyle(..) )
 import Pretty
-import SrcLoc		( SrcLoc )
-import Unique		( Unique )
-import Util
+import Util		( cmpPString )
 \end{code}
 
 %************************************************************************
@@ -65,9 +51,7 @@ class NamedThing a where
     getOccurrenceName	:: a -> FAST_STRING
     getInformingModules	:: a -> [FAST_STRING]
     getSrcLoc		:: a -> SrcLoc
-    getTheUnique	:: a -> Unique
-    hasType		:: a -> Bool
-    getType		:: a -> UniType
+    getItsUnique	:: a -> Unique
     fromPreludeCore	:: a -> Bool
     -- see also friendly functions that follow...
 \end{code}
@@ -92,11 +76,6 @@ Gets the name of the modules that told me about this @NamedThing@.
 \item[@getSrcLoc@:]
 Obvious.
 
-\item[@hasType@ and @getType@:]
-In pretty-printing @AbsSyntax@, we need to query if a datatype has
-types attached yet or not.  We use @hasType@ to see if there are types
-available; and @getType@ if we want to grab one...  (Ugly but effective)
-
 \item[@fromPreludeCore@:]
 Tests a quite-delicate property: it is \tr{True} iff the entity is
 actually defined in \tr{PreludeCore} (or \tr{PreludeBuiltin}), or if
@@ -205,24 +184,17 @@ interpp'SP sty xs
 {-# SPECIALIZE interpp'SP :: PprStyle -> [ProtoName] -> Pretty #-}
 {-# SPECIALIZE interpp'SP :: PprStyle -> [TyVarTemplate] -> Pretty #-}
 {-# SPECIALIZE interpp'SP :: PprStyle -> [TyVar] -> Pretty #-}
-{-# SPECIALIZE interpp'SP :: PprStyle -> [UniType] -> Pretty #-}
+{-# SPECIALIZE interpp'SP :: PprStyle -> [Type] -> Pretty #-}
 #endif
 \end{code}
 
 \begin{code}
---UNUSED: ifPprForUser	sty p = case sty of PprForUser	 -> p ; _ -> ppNil
 ifPprDebug	sty p = case sty of PprDebug	 -> p ; _ -> ppNil
 ifPprShowAll	sty p = case sty of PprShowAll	 -> p ; _ -> ppNil
-ifPprInterface  sty p = case sty of PprInterface _ -> p ; _ -> ppNil
---UNUSED: ifPprForC   	sty p = case sty of PprForC      _ -> p ; _ -> ppNil
---UNUSED: ifPprUnfolding  sty p = case sty of PprUnfolding _ -> p ; _ -> ppNil
-
-ifnotPprForUser	  sty p = case sty of PprForUser    -> ppNil ; _ -> p
---UNUSED: ifnotPprDebug	  sty p = case sty of PprDebug	    -> ppNil ; _ -> p
-ifnotPprShowAll	  sty p = case sty of PprShowAll    -> ppNil ; _ -> p
---UNUSED: ifnotPprInterface sty p = case sty of PprInterface _ -> ppNil; _ -> p
---UNUSED: ifnotPprForC   	  sty p = case sty of PprForC      _ -> ppNil; _ -> p
---UNUSED: ifnotPprUnfolding sty p = case sty of PprUnfolding _ -> ppNil; _ -> p
+ifPprInterface  sty p = case sty of PprInterface -> p ; _ -> ppNil
+
+ifnotPprForUser	  sty p = case sty of PprForUser -> ppNil ; _ -> p
+ifnotPprShowAll	  sty p = case sty of PprShowAll -> ppNil ; _ -> p
 \end{code}
 
 These functions test strings to see if they fit the lexical categories
@@ -234,17 +206,13 @@ isConop, isAconop, isAvarid, isAvarop :: FAST_STRING -> Bool
 
 isConop cs
   | _NULL_ cs	= False
-  | c == '_'	= isConop (_TAIL_ cs)	-- allow for leading _'s
-  | otherwise	= isUpper c || c == ':'
-  where
+  | c == '_'	= isConop (_TAIL_ cs)		-- allow for leading _'s
+  | otherwise	= isUpper c || c == ':' 
+		  || c == '[' || c == '('	-- [] () and (,,) come is as Conop strings !!!
+		  || isUpperISO c
+  where					
     c = _HEAD_ cs
 
-{- UNUSED:
-isAconid []       = False
-isAconid ('_':cs) = isAconid cs
-isAconid (c:cs)   = isUpper c
--}
-
 isAconop cs
   | _NULL_ cs	= False
   | otherwise	= c == ':'
@@ -252,19 +220,27 @@ isAconop cs
     c = _HEAD_ cs
 
 isAvarid cs
-  | _NULL_ cs	= False
-  | c == '_'	= isAvarid (_TAIL_ cs)	-- allow for leading _'s
-  | otherwise	= isLower c
+  | _NULL_ cs	 = False
+  | c == '_'	 = isAvarid (_TAIL_ cs)	-- allow for leading _'s
+  | isLower c	 = True
+  | isLowerISO c = True
+  | otherwise    = False
   where
     c = _HEAD_ cs
 
 isAvarop cs
-  | _NULL_ cs	= False
-  | isLower c	= False -- shortcut
-  | isUpper c	= False -- ditto
-  | otherwise	= c `elem` "!#$%&*+./<=>?@\\^|~-" -- symbol or minus
+  | _NULL_ cs	 		    = False
+  | isLower c    		    = False
+  | isUpper c    		    = False
+  | c `elem` "!#$%&*+./<=>?@\\^|~-" = True
+  | isSymbolISO c		    = True
+  | otherwise			    = False
   where
     c = _HEAD_ cs
+
+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:
diff --git a/ghc/compiler/utils/PprStyle.lhs b/ghc/compiler/utils/PprStyle.lhs
new file mode 100644
index 0000000000..5c3e339b68
--- /dev/null
+++ b/ghc/compiler/utils/PprStyle.lhs
@@ -0,0 +1,49 @@
+%
+% (c) The AQUA Project, Glasgow University, 1996
+%
+\section[PprStyle]{Pretty-printing `styles'}
+
+\begin{code}
+#include "HsVersions.h"
+
+module PprStyle (
+	PprStyle(..),
+	codeStyle
+    ) where
+
+CHK_Ubiq() -- debugging consistency check
+
+data PprStyle
+  = PprForUser	 		-- Pretty-print in a way that will
+				-- make sense to the ordinary user;
+				-- must be very close to Haskell
+				-- syntax, etc.  ToDo: how diff is
+				-- this from what pprInterface must
+				-- do?
+  | PprDebug			-- Standard debugging output
+  | PprShowAll			-- Debugging output which leaves
+				-- nothing to the imagination
+  | PprInterface		-- Interface generation
+  | PprForC			-- must print out C-acceptable names
+  | PprUnfolding		-- for non-interface intermodule info
+				-- the compiler writes/reads
+  | PprForAsm			-- must print out assembler-acceptable names
+	Bool	        	-- prefix CLabel with underscore?
+	(String -> String)    	-- format AsmTempLabel
+\end{code}
+
+Orthogonal to the above printing styles are (possibly) some
+command-line flags that affect printing (often carried with the
+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).
+\begin{code}
+codeStyle :: PprStyle -> Bool
+
+codeStyle PprForC	  = True
+codeStyle (PprForAsm _ _) = True
+codeStyle _		  = False
+\end{code}
+
diff --git a/ghc/compiler/utils/Pretty.hi b/ghc/compiler/utils/Pretty.hi
deleted file mode 100644
index 6a05ebe92a..0000000000
--- a/ghc/compiler/utils/Pretty.hi
+++ /dev/null
@@ -1,48 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface Pretty where
-import CharSeq(CSeq)
-import CmdLineOpts(GlobalSwitch)
-import PreludePS(_PackedString)
-import PreludeRatio(Ratio(..))
-import Stdio(_FILE)
-import Unpretty(Unpretty(..))
-data CSeq 
-data Delay a 
-data GlobalSwitch 
-data PprStyle   = PprForUser | PprDebug | PprShowAll | PprInterface (GlobalSwitch -> Bool) | PprForC (GlobalSwitch -> Bool) | PprUnfolding (GlobalSwitch -> Bool) | PprForAsm (GlobalSwitch -> Bool) Bool ([Char] -> [Char])
-type Pretty = Int -> Bool -> PrettyRep
-data PrettyRep   = MkPrettyRep CSeq (Delay Int) Bool Bool
-type Unpretty = CSeq
-codeStyle :: PprStyle -> Bool
-pp'SP :: Int -> Bool -> PrettyRep
-ppAbove :: (Int -> Bool -> PrettyRep) -> (Int -> Bool -> PrettyRep) -> Int -> Bool -> PrettyRep
-ppAboves :: [Int -> Bool -> PrettyRep] -> Int -> Bool -> PrettyRep
-ppAppendFile :: _FILE -> Int -> (Int -> Bool -> PrettyRep) -> _State _RealWorld -> ((), _State _RealWorld)
-ppBeside :: (Int -> Bool -> PrettyRep) -> (Int -> Bool -> PrettyRep) -> Int -> Bool -> PrettyRep
-ppBesides :: [Int -> Bool -> PrettyRep] -> Int -> Bool -> PrettyRep
-ppCat :: [Int -> Bool -> PrettyRep] -> Int -> Bool -> PrettyRep
-ppChar :: Char -> Int -> Bool -> PrettyRep
-ppComma :: Int -> Bool -> PrettyRep
-ppDouble :: Double -> Int -> Bool -> PrettyRep
-ppEquals :: Int -> Bool -> PrettyRep
-ppFloat :: Float -> Int -> Bool -> PrettyRep
-ppHang :: (Int -> Bool -> PrettyRep) -> Int -> (Int -> Bool -> PrettyRep) -> Int -> Bool -> PrettyRep
-ppInt :: Int -> Int -> Bool -> PrettyRep
-ppInteger :: Integer -> Int -> Bool -> PrettyRep
-ppInterleave :: (Int -> Bool -> PrettyRep) -> [Int -> Bool -> PrettyRep] -> Int -> Bool -> PrettyRep
-ppIntersperse :: (Int -> Bool -> PrettyRep) -> [Int -> Bool -> PrettyRep] -> Int -> Bool -> PrettyRep
-ppLbrack :: Int -> Bool -> PrettyRep
-ppLparen :: Int -> Bool -> PrettyRep
-ppNest :: Int -> (Int -> Bool -> PrettyRep) -> Int -> Bool -> PrettyRep
-ppNil :: Int -> Bool -> PrettyRep
-ppPStr :: _PackedString -> Int -> Bool -> PrettyRep
-ppRational :: Ratio Integer -> Int -> Bool -> PrettyRep
-ppRbrack :: Int -> Bool -> PrettyRep
-ppRparen :: Int -> Bool -> PrettyRep
-ppSP :: Int -> Bool -> PrettyRep
-ppSemi :: Int -> Bool -> PrettyRep
-ppSep :: [Int -> Bool -> PrettyRep] -> Int -> Bool -> PrettyRep
-ppShow :: Int -> (Int -> Bool -> PrettyRep) -> [Char]
-ppStr :: [Char] -> Int -> Bool -> PrettyRep
-prettyToUn :: (Int -> Bool -> PrettyRep) -> CSeq
-
diff --git a/ghc/compiler/utils/Pretty.lhs b/ghc/compiler/utils/Pretty.lhs
index f4169255ce..5875f039cb 100644
--- a/ghc/compiler/utils/Pretty.lhs
+++ b/ghc/compiler/utils/Pretty.lhs
@@ -1,5 +1,5 @@
 %
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
 %
 \section[Pretty]{Pretty-printing data type}
 
@@ -15,42 +15,45 @@ module Pretty (
 	Pretty(..),
 
 #if defined(COMPILING_GHC)
-	PprStyle(..),
 	prettyToUn,
-	codeStyle, -- UNUSED: stySwitch,
 #endif
 	ppNil, ppStr, ppPStr, ppChar, ppInt, ppInteger,
 	ppFloat, ppDouble,
-#if __GLASGOW_HASKELL__ >= 23
+#if __GLASGOW_HASKELL__
 	-- may be able to *replace* ppDouble
 	ppRational,
 #endif
 	ppSP, pp'SP, ppLbrack, ppRbrack, ppLparen, ppRparen,
 	ppSemi, ppComma, ppEquals,
+	ppBracket, ppParens,
 
 	ppCat, ppBeside, ppBesides, ppAbove, ppAboves,
 	ppNest, ppSep, ppHang, ppInterleave, ppIntersperse,
-	ppShow,
-#if defined(COMPILING_GHC) && __GLASGOW_HASKELL__ >= 22
+	ppShow, speakNth,
+
+#if defined(COMPILING_GHC)
 	ppAppendFile,
 #endif
 
 	-- abstract type, to complete the interface...
 	PrettyRep(..), CSeq, Delay
 #if defined(COMPILING_GHC)
-	, GlobalSwitch, Unpretty(..)
+	, Unpretty(..)
 #endif
    ) where
 
-import CharSeq
 #if defined(COMPILING_GHC)
+
+CHK_Ubiq() -- debugging consistency check
+
 import Unpretty		( Unpretty(..) )
-import CmdLineOpts	( GlobalSwitch )
 #endif
+
+import CharSeq
 \end{code}
 
-Based on John Hughes's pretty-printing library.  For now, that code
-and notes for it are in files \tr{pp-rjmh*} (ToDo: rm).
+Based on John Hughes's pretty-printing library.  Loosely.  Very
+loosely.
 
 %************************************************
 %*						*
@@ -69,9 +72,10 @@ ppInt		:: Int	   -> Pretty
 ppInteger	:: Integer -> Pretty
 ppDouble	:: Double  -> Pretty
 ppFloat		:: Float   -> Pretty
-#if __GLASGOW_HASKELL__ >= 23
 ppRational	:: Rational -> Pretty
-#endif
+
+ppBracket	:: Pretty -> Pretty -- put brackets around it
+ppParens	:: Pretty -> Pretty -- put parens   around it
 
 ppBeside	:: Pretty -> Pretty -> Pretty
 ppBesides	:: [Pretty] -> Pretty
@@ -89,10 +93,7 @@ ppNest		:: Int -> Pretty -> Pretty
 
 ppShow		:: Int -> Pretty -> [Char]
 
-#if defined(COMPILING_GHC) && __GLASGOW_HASKELL__ >= 22
-# if __GLASGOW_HASKELL__ < 23
-#  define _FILE _Addr
-# endif
+#if defined(COMPILING_GHC)
 ppAppendFile	:: _FILE -> Int -> Pretty -> PrimIO ()
 #endif
 \end{code}
@@ -127,7 +128,7 @@ ppShow width p
   = case (p width False) of
       MkPrettyRep seq ll emp sl -> cShow seq
 
-#if defined(COMPILING_GHC) && __GLASGOW_HASKELL__ >= 22
+#if defined(COMPILING_GHC)
 ppAppendFile f width p
   = case (p width False) of
       MkPrettyRep seq ll emp sl -> cAppendFile f seq
@@ -149,10 +150,7 @@ ppInt  n width is_vert = MkPrettyRep (cStr s) (MkDelay ls) False (width >= ls)
 ppInteger n  = ppStr (show n)
 ppDouble  n  = ppStr (show n)
 ppFloat   n  = ppStr (show n)
-#if __GLASGOW_HASKELL__ >= 23
---ppRational n = ppStr (_showRational 30 n)
 ppRational n = ppStr (show (fromRationalX n)) -- _showRational 30 n)
-#endif
 
 ppSP	  = ppChar ' '
 pp'SP	  = ppStr ", "
@@ -164,6 +162,9 @@ ppSemi    = ppChar ';'
 ppComma   = ppChar ','
 ppEquals  = ppChar '='
 
+ppBracket p = ppBeside ppLbrack (ppBeside p ppRbrack)
+ppParens  p = ppBeside ppLparen (ppBeside p ppRparen)
+
 ppInterleave sep ps = ppSep (pi ps)
   where
    pi []	= []
@@ -272,7 +273,7 @@ ppHang p1 n p2 width is_vert	-- This is a little bit stricter than it could
       MkPrettyRep seq1 (MkDelay ll1) emp1 sl1 ->
 	  if emp1 then
 	      p2 width is_vert
-	  else 
+	  else
 	  if (ll1 <= n) || sl2 then	-- very ppBesideSP'ish
 	      -- Hang it if p1 shorter than indent or if it doesn't fit
 	      MkPrettyRep (seq1 `cAppend` ((cCh ' ') `cAppend` (cIndent (ll1+1) seq2)))
@@ -312,64 +313,40 @@ ppSep ps  width is_vert
 	   ppAboves ps width is_vert	-- Takes several lines
 \end{code}
 
+
+@speakNth@ converts an integer to a verbal index; eg 1 maps to
+``first'' etc.
+
+\begin{code}
+speakNth :: Int -> Pretty
+
+speakNth 1 = ppStr "first"
+speakNth 2 = ppStr "second"
+speakNth 3 = ppStr "third"
+speakNth 4 = ppStr "fourth"
+speakNth 5 = ppStr "fifth"
+speakNth 6 = ppStr "sixth"
+speakNth n = ppBesides [ ppInt n, ppStr st_nd_rd_th ]
+  where
+    st_nd_rd_th | n_rem_10 == 1 = "st"
+		| n_rem_10 == 2 = "nd"
+		| n_rem_10 == 3 = "rd"
+		| otherwise     = "th"
+
+    n_rem_10 = n `rem` 10
+\end{code}
+
+
 %************************************************************************
 %*									*
 \subsection[Outputable-print]{Pretty-printing stuff}
 %*									*
 %************************************************************************
 
-ToDo: this is here for no-original-name reasons (mv?).
-
-There is no clearly definitive list of @PprStyles@; I suggest the
-following:
-
 \begin{code}
 #if defined(COMPILING_GHC)
     -- to the end of file
 
-data PprStyle
-  = PprForUser	 		-- Pretty-print in a way that will
-				-- make sense to the ordinary user;
-				-- must be very close to Haskell
-				-- syntax, etc.  ToDo: how diff is
-				-- this from what pprInterface must
-				-- do?
-  | PprDebug			-- Standard debugging output
-  | PprShowAll			-- Debugging output which leaves
-				-- nothing to the imagination
-  | PprInterface		-- Interface generation
-	(GlobalSwitch -> Bool)	--  (we can look at cmd-line flags)
-  | PprForC			-- must print out C-acceptable names
-	(GlobalSwitch -> Bool)	--  (ditto)
-  | PprUnfolding		-- for non-interface intermodule info
-	(GlobalSwitch -> Bool)	-- the compiler writes/reads
-  | PprForAsm			-- must print out assembler-acceptable names
-	(GlobalSwitch -> Bool)	--  (ditto)
-        Bool	        	-- prefix CLabel with underscore?
-        (String -> String)    	-- format AsmTempLabel
-\end{code}
-
-The following test decides whether or not we are actually generating
-code (either C or assembly).
-\begin{code}
-codeStyle :: PprStyle -> Bool
-codeStyle (PprForC _) = True
-codeStyle (PprForAsm _ _ _) = True
-codeStyle _ = False
-
-{- UNUSED:
-stySwitch :: PprStyle -> GlobalSwitch -> Bool
-stySwitch (PprInterface sw) = sw
-stySwitch (PprForC sw) = sw
-stySwitch (PprForAsm sw _ _) = sw
--}
-\end{code}
-
-Orthogonal to these printing styles are (possibly) some command-line
-flags that affect printing (often carried with the style).  The most
-likely ones are variations on how much type info is shown.
-
-\begin{code}
 prettyToUn :: Pretty -> Unpretty
 
 prettyToUn p
@@ -385,14 +362,14 @@ prettyToUn p
 fromRationalX :: (RealFloat a) => Rational -> a
 
 fromRationalX r =
-	let 
+	let
 	    h = ceiling (huge `asTypeOf` x)
 	    b = toInteger (floatRadix x)
 	    x = fromRat 0 r
 	    fromRat e0 r' =
 		let d = denominator r'
 		    n = numerator r'
-	        in  if d > h then
+		in  if d > h then
 		       let e = integerLogBase b (d `div` h) + 1
 		       in  fromRat (e0-e) (n % (d `div` (b^e)))
 		    else if abs n > h then
@@ -408,10 +385,10 @@ fromRationalX r =
 integerLogBase :: Integer -> Integer -> Int
 integerLogBase b i =
      if i < b then
-        0
+	0
      else
 	-- Try squaring the base first to cut down the number of divisions.
-        let l = 2 * integerLogBase (b*b) i
+	let l = 2 * integerLogBase (b*b) i
 
 	    doDiv :: Integer -> Int -> Int
 	    doDiv j k = if j < b then k else doDiv (j `div` b) (k+1)
diff --git a/ghc/compiler/utils/SST.lhs b/ghc/compiler/utils/SST.lhs
new file mode 100644
index 0000000000..de9c036910
--- /dev/null
+++ b/ghc/compiler/utils/SST.lhs
@@ -0,0 +1,135 @@
+\section{SST: the strict state transformer monad}
+%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+\begin{code}
+#include "HsVersions.h"
+
+module SST(
+	SST(..), SST_R, FSST(..), FSST_R,
+
+	_runSST,
+	thenSST, thenSST_, returnSST,
+	thenFSST, thenFSST_, returnFSST, failFSST,
+	recoverFSST, recoverSST, fixFSST,
+
+	MutableVar(..), _MutableArray, 
+	newMutVarSST, readMutVarSST, writeMutVarSST
+  ) where
+
+import PreludeGlaST( MutableVar(..), _MutableArray(..) )
+
+CHK_Ubiq() -- debugging consistency check
+\end{code}
+
+\begin{code}
+data SST_R s r = SST_R r (State# s)
+type SST   s r = State# s -> SST_R s r
+\end{code}
+
+\begin{code}
+-- Type of runSST should be builtin ...
+-- runSST :: forall r. (forall s. SST s r) -> r
+
+_runSST :: SST _RealWorld r -> r
+_runSST m = case m realWorld# of SST_R r s -> r
+
+
+thenSST :: SST s r -> (r -> State# s -> b) -> State# s -> b
+{-# INLINE thenSST #-}
+-- Hence:
+--	thenSST :: SST s r -> (r -> SST  s r')     -> SST  s r'
+-- and  thenSST :: SST s r -> (r -> FSST s r' err) -> FSST s r' err
+
+thenSST m k s = case m s of { SST_R r s' -> k r s' }
+
+thenSST_ :: SST s r -> (State# s -> b) -> State# s -> b
+{-# INLINE thenSST_ #-}
+-- Hence:
+--	thenSST_ :: SST s r -> SST  s r'     -> SST  s r'
+-- and  thenSST_ :: SST s r -> FSST s r' err -> FSST s r' err
+
+thenSST_ m k s = case m s of { SST_R r s' -> k s' }
+
+returnSST :: r -> SST s r
+{-# INLINE returnSST #-}
+returnSST r s = SST_R r s
+\end{code}
+
+
+\section{FSST: the failable strict state transformer monad}
+%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+\begin{code}
+data FSST_R s r err = FSST_R_OK   r   (State# s)
+		    | FSST_R_Fail err (State# s)
+
+type FSST   s r err = State# s -> FSST_R s r err
+\end{code}
+
+\begin{code}
+thenFSST :: FSST s r err -> (r -> FSST s r' err) -> FSST s r' err
+{-# INLINE thenFSST #-}
+thenFSST m k s = case m s of
+		   FSST_R_OK r s'     -> k r s'
+		   FSST_R_Fail err s' -> FSST_R_Fail err s'
+
+thenFSST_ :: FSST s r err -> FSST s r' err -> FSST s r' err
+{-# INLINE thenFSST_ #-}
+thenFSST_ m k s = case m s of
+		    FSST_R_OK r s'     -> k s'
+		    FSST_R_Fail err s' -> FSST_R_Fail err s'
+
+returnFSST :: r -> FSST s r err
+{-# INLINE returnFSST #-}
+returnFSST r s = FSST_R_OK r s
+
+failFSST    :: err -> FSST s r err
+{-# INLINE failFSST #-}
+failFSST err s = FSST_R_Fail err s
+
+recoverFSST :: (err -> FSST s r err)
+	    -> FSST s r err
+	    -> FSST s r err
+recoverFSST recovery_fn m s
+  = case m s of 
+	FSST_R_OK r s'     -> FSST_R_OK r s'
+	FSST_R_Fail err s' -> recovery_fn err s'
+
+recoverSST :: (err -> SST s r)
+	    -> FSST s r err
+	    -> SST s r
+recoverSST recovery_fn m s
+  = case m s of 
+	FSST_R_OK r s'     -> SST_R r s'
+	FSST_R_Fail err s' -> recovery_fn err s'
+
+fixFSST :: (r -> FSST s r err) -> FSST s r err
+fixFSST m s = result
+	    where
+	      result 	       = m loop s
+	      FSST_R_OK loop _ = result
+\end{code}
+
+Mutables
+~~~~~~~~
+Here we implement mutable variables.  ToDo: get rid of the array impl.
+
+\begin{code}
+newMutVarSST :: a -> SST s (MutableVar s a)
+newMutVarSST init s#
+  = case (newArray# 1# init s#)     of { StateAndMutableArray# s2# arr# ->
+    SST_R (_MutableArray vAR_IXS arr#) s2# }
+  where
+    vAR_IXS = error "Shouldn't access `bounds' of a MutableVar\n"
+
+readMutVarSST :: MutableVar s a -> SST s a
+readMutVarSST (_MutableArray _ var#) s#
+  = case readArray# var# 0# s#	of { StateAndPtr# s2# r ->
+    SST_R r s2# }
+
+writeMutVarSST :: MutableVar s a -> a -> SST s ()
+writeMutVarSST (_MutableArray _ var#) val s#
+  = case writeArray# var# 0# val s# of { s2# ->
+    SST_R () s2# }
+\end{code}
+
diff --git a/ghc/compiler/utils/Ubiq.lhi b/ghc/compiler/utils/Ubiq.lhi
new file mode 100644
index 0000000000..20e54b347d
--- /dev/null
+++ b/ghc/compiler/utils/Ubiq.lhi
@@ -0,0 +1,138 @@
+Things which are ubiquitous in the GHC compiler.
+
+\begin{code}
+interface Ubiq where
+
+import PreludePS(_PackedString)
+
+import Bag		( Bag )
+import BinderInfo	( BinderInfo )
+import Class		( GenClass, GenClassOp, Class(..), ClassOp )
+import CmdLineOpts	( SimplifierSwitch, SwitchResult )
+import CoreSyn		( GenCoreArg, GenCoreBinder, GenCoreBinding, GenCoreExpr,
+			  GenCoreCaseAlts, GenCoreCaseDefault
+			)
+import CoreUnfold	( UnfoldingDetails, UnfoldingGuidance )
+import CostCentre	( CostCentre )
+import FiniteMap	( FiniteMap )
+import HsCore		( UnfoldingCoreExpr )
+import HsPat		( OutPat )
+import HsPragmas	( ClassOpPragmas, ClassPragmas, DataPragmas, GenPragmas,
+			  InstancePragmas
+			)
+import Id		( StrictnessMark, GenId, Id(..) )
+import IdInfo		( IdInfo, OptIdInfo(..), DeforestInfo, Demand, StrictnessInfo, UpdateInfo )
+import Kind		( Kind )
+import Literal		( Literal )
+import Maybes		( MaybeErr )
+import MatchEnv 	( MatchEnv )
+import Name		( Name )
+import NameTypes	( FullName, ShortName )
+import Outputable	( ExportFlag, NamedThing(..), Outputable(..) )
+import PprStyle		( PprStyle )
+import PragmaInfo	( PragmaInfo )
+import Pretty		( PrettyRep )
+import PrimOp		( PrimOp )
+import PrimRep		( PrimRep )
+import ProtoName	( ProtoName )
+import SrcLoc		( SrcLoc )
+import TcType		( TcMaybe )
+import TyCon		( TyCon, Arity(..) )
+import TyVar		( GenTyVar, TyVar(..) )
+import Type		( GenType, Type(..) )
+import UniqFM		( UniqFM )
+import UniqSupply	( UniqSupply )
+import Unique		( Unique )
+import Usage		( GenUsage, Usage(..) )
+import Util		( Ord3(..) )
+
+-- All the classes in GHC go; life is just too short
+-- to try to contain their visibility.
+
+class NamedThing a where
+	getExportFlag :: a -> ExportFlag
+	isLocallyDefined :: a -> Bool
+	getOrigName :: a -> (_PackedString, _PackedString)
+	getOccurrenceName :: a -> _PackedString
+	getInformingModules :: a -> [_PackedString]
+	getSrcLoc :: a -> SrcLoc
+	getItsUnique :: a -> Unique
+	fromPreludeCore :: a -> Bool
+class OptIdInfo a where
+	noInfo	:: a
+	getInfo	:: IdInfo -> a
+	addInfo	:: IdInfo -> a -> IdInfo
+	ppInfo	:: PprStyle -> (Id -> Id) -> a -> Int -> Bool -> PrettyRep
+class Ord3 a where
+	cmp :: a -> a -> Int#
+class Outputable a where
+	ppr :: PprStyle -> a -> Int -> Bool -> PrettyRep
+
+-- For datatypes, we ubiquitize those types that (a) are
+-- used everywhere and (b) the compiler doesn't lose much
+-- optimisation-wise by not seeing their pragma-gunk.
+
+data Bag a
+data BinderInfo
+data ClassOpPragmas a
+data ClassPragmas a
+data CostCentre
+data DataPragmas a
+data DeforestInfo
+data Demand
+data ExportFlag
+data FiniteMap a b
+data FullName	-- NB: fails the optimisation criterion
+data GenClass a b
+data GenClassOp a
+data GenCoreArg a b c
+data GenCoreBinder a b c
+data GenCoreBinding a b c d
+data GenCoreCaseAlts a b c d
+data GenCoreCaseDefault a b c d
+data GenCoreExpr a b c d
+data GenId a	-- NB: fails the optimisation criterion
+data GenPragmas a
+data GenTyVar a	-- NB: fails the optimisation criterion
+data GenType  a b
+data GenUsage a
+data IdInfo
+data InstancePragmas a
+data Kind
+data Literal
+data MaybeErr a b
+data MatchEnv a b
+data Name
+data OutPat a b c
+data PprStyle
+data PragmaInfo
+data PrettyRep
+data PrimOp
+data PrimRep	-- NB: an enumeration
+data ProtoName
+data ShortName	-- NB: fails the optimisation criterion
+data SimplifierSwitch
+data SrcLoc
+data StrictnessInfo
+data StrictnessMark
+data SwitchResult
+data TcMaybe s
+data TyCon
+data UnfoldingCoreExpr a
+data UniqFM a
+data UpdateInfo
+data UniqSupply
+data UnfoldingDetails
+data UnfoldingGuidance
+data Unique	-- NB: fails the optimisation criterion
+
+-- don't get clever and unexpand some of these synonyms
+-- (GHC 0.26 will barf)
+type Arity = Int
+type Class = GenClass (GenTyVar (GenUsage Unique)) Unique
+type ClassOp = GenClassOp (GenType (GenTyVar (GenUsage Unique)) Unique)
+type Id	   = GenId (GenType (GenTyVar (GenUsage Unique)) Unique)
+type Type  = GenType (GenTyVar (GenUsage Unique)) Unique
+type TyVar = GenTyVar (GenUsage Unique)
+type Usage = GenUsage Unique
+\end{code}
diff --git a/ghc/compiler/utils/UniqFM.hi b/ghc/compiler/utils/UniqFM.hi
deleted file mode 100644
index b57b529585..0000000000
--- a/ghc/compiler/utils/UniqFM.hi
+++ /dev/null
@@ -1,33 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface UniqFM where
-import Id(Id)
-import Maybes(Labda)
-import Outputable(NamedThing)
-import TyVar(TyVar)
-import Unique(Unique)
-data Id 
-data TyVar 
-data UniqFM a 
-data Unique 
-addToUFM :: NamedThing a => UniqFM b -> a -> b -> UniqFM b
-addToUFM_Directly :: UniqFM a -> Unique -> a -> UniqFM a
-delFromUFM :: NamedThing a => UniqFM b -> a -> UniqFM b
-delListFromUFM :: NamedThing a => UniqFM b -> [a] -> UniqFM b
-eltsUFM :: UniqFM a -> [a]
-emptyUFM :: UniqFM a
-filterUFM :: (a -> Bool) -> UniqFM a -> UniqFM a
-intersectUFM :: UniqFM a -> UniqFM a -> UniqFM a
-isNullUFM :: UniqFM a -> Bool
-listToUFM :: NamedThing a => [(a, b)] -> UniqFM b
-listToUFM_Directly :: [(Unique, a)] -> UniqFM a
-lookupDirectlyUFM :: UniqFM a -> Unique -> Labda a
-lookupUFM :: NamedThing a => UniqFM b -> a -> Labda b
-mapUFM :: (a -> b) -> UniqFM a -> UniqFM b
-minusUFM :: UniqFM a -> UniqFM a -> UniqFM a
-plusUFM :: UniqFM a -> UniqFM a -> UniqFM a
-plusUFM_C :: (a -> a -> a) -> UniqFM a -> UniqFM a -> UniqFM a
-singletonDirectlyUFM :: Unique -> a -> UniqFM a
-singletonUFM :: NamedThing a => a -> b -> UniqFM b
-sizeUFM :: UniqFM a -> Int
-ufmToList :: UniqFM a -> [(Unique, a)]
-
diff --git a/ghc/compiler/utils/UniqFM.lhs b/ghc/compiler/utils/UniqFM.lhs
index 92839cbdb6..b9fc0dd74a 100644
--- a/ghc/compiler/utils/UniqFM.lhs
+++ b/ghc/compiler/utils/UniqFM.lhs
@@ -1,18 +1,15 @@
 %
-% (c) The AQUA Project, Glasgow University, 1994-1995
+% (c) The AQUA Project, Glasgow University, 1994-1996
 %
 \section[UniqFM]{Specialised finite maps, for things with @Uniques@}
 
 Based on @FiniteMaps@ (as you would expect).
 
 Basically, the things need to be in class @NamedThing@, and we use the
-@getTheUnique@ method to grab their @Uniques@.
+@getItsUnique@ method to grab their @Uniques@.
 
 (A similar thing to @UniqSet@, as opposed to @Set@.)
 
-@IdEnv@ and @TyVarEnv@ are the (backward-compatible?) specialisations
-of this stuff for Ids and TyVars, respectively.
-
 \begin{code}
 #if defined(COMPILING_GHC)
 #include "HsVersions.h"
@@ -31,8 +28,9 @@ module UniqFM (
 	listToUFM,
 	listToUFM_Directly,
 	addToUFM,
-	IF_NOT_GHC(addListToUFM COMMA)
+	addListToUFM,
 	addToUFM_Directly,
+	addListToUFM_Directly,
 	IF_NOT_GHC(addToUFM_C COMMA)
 	IF_NOT_GHC(addListToUFM_C COMMA)
 	delFromUFM,
@@ -47,27 +45,26 @@ module UniqFM (
 	filterUFM,
 	sizeUFM,
 	isNullUFM,
-	lookupUFM,
-	lookupDirectlyUFM,
-	IF_NOT_GHC(lookupWithDefaultUFM COMMA)
+	lookupUFM, lookupUFM_Directly,
+	lookupWithDefaultUFM, lookupWithDefaultUFM_Directly,
 	eltsUFM,
-	ufmToList,
+	ufmToList
 
 	-- to make the interface self-sufficient
-	Id, TyVar, Unique
-	IF_ATTACK_PRAGMAS(COMMA u2i)	-- profiling
     ) where
 
-import AbsUniType	-- for specialisation to TyVars
-import Id		-- for specialisation to Ids
-import IdInfo		-- sigh
-import Maybes		( maybeToBool, Maybe(..) )
-import Name
-import Outputable
-import Unique		( u2i, mkUniqueGrimily, Unique )
+#if defined(COMPILING_GHC)
+CHK_Ubiq() -- debugging consistency check
+#endif
+
+import Unique		( Unique, u2i, mkUniqueGrimily )
 import Util
+import Outputable	( Outputable(..), NamedThing(..), ExportFlag )
+import Pretty		( Pretty(..), PrettyRep )
+import PprStyle		( PprStyle )
+import SrcLoc		( SrcLoc )
+
 #if ! OMIT_NATIVE_CODEGEN
-import AsmRegAlloc	( Reg )
 #define IF_NCG(a) a
 #else
 #define IF_NCG(a) {--}
@@ -80,7 +77,7 @@ import AsmRegAlloc	( Reg )
 %*									*
 %************************************************************************
 
-We use @FiniteMaps@, with a (@getTheUnique@-able) @Unique@ as ``key''.
+We use @FiniteMaps@, with a (@getItsUnique@-able) @Unique@ as ``key''.
 
 \begin{code}
 emptyUFM	:: UniqFM elt
@@ -123,10 +120,12 @@ filterUFM	:: (elt -> Bool) -> UniqFM elt -> UniqFM elt
 sizeUFM		:: UniqFM elt -> Int
 
 lookupUFM	:: NamedThing key => UniqFM elt -> key -> Maybe elt
-lookupDirectlyUFM  -- when you've got the Unique already
+lookupUFM_Directly  -- when you've got the Unique already
 		:: UniqFM elt -> Unique -> Maybe elt
 lookupWithDefaultUFM
 		:: NamedThing key => UniqFM elt -> elt -> key -> elt
+lookupWithDefaultUFM_Directly
+		:: UniqFM elt -> elt -> Unique -> elt
 
 eltsUFM		:: UniqFM elt -> [elt]
 ufmToList	:: UniqFM elt -> [(Unique, elt)]
@@ -139,13 +138,13 @@ ufmToList	:: UniqFM elt -> [(Unique, elt)]
 %************************************************************************
 
 \begin{code}
+#if 0
+
 type IdFinMap	 elt = UniqFM elt
 type TyVarFinMap elt = UniqFM elt
 type NameFinMap  elt = UniqFM elt
 type RegFinMap   elt = UniqFM elt
-\end{code}
 
-\begin{code}
 #ifdef __GLASGOW_HASKELL__
 -- I don't think HBC was too happy about this (WDP 94/10)
 
@@ -221,6 +220,7 @@ type RegFinMap   elt = UniqFM elt
   #-}
 
 #endif {- __GLASGOW_HASKELL__ -}
+#endif {- 0 -}
 \end{code}
 
 %************************************************************************
@@ -285,7 +285,7 @@ First the ways of building a UniqFM.
 
 \begin{code}
 emptyUFM		     = EmptyUFM
-singletonUFM	     key elt = mkLeafUFM (u2i (getTheUnique key)) elt
+singletonUFM	     key elt = mkLeafUFM (u2i (getItsUnique key)) elt
 singletonDirectlyUFM key elt = mkLeafUFM (u2i key) elt
 
 listToUFM key_elt_pairs
@@ -308,12 +308,13 @@ addToUFM fm key elt = addToUFM_C use_snd fm key elt
 addToUFM_Directly fm u elt = insert_ele use_snd fm (u2i u) elt
 
 addToUFM_C combiner fm key elt
-  = insert_ele combiner fm (u2i (getTheUnique key)) elt
+  = insert_ele combiner fm (u2i (getItsUnique key)) elt
 
 addListToUFM fm key_elt_pairs = addListToUFM_C use_snd fm key_elt_pairs
+addListToUFM_Directly fm uniq_elt_pairs = addListToUFM_directly_C use_snd fm uniq_elt_pairs
 
 addListToUFM_C combiner fm key_elt_pairs
- = foldl (\ fm (k, e) -> insert_ele combiner fm (u2i (getTheUnique k)) e)
+ = foldl (\ fm (k, e) -> insert_ele combiner fm (u2i (getItsUnique k)) e)
 	 fm key_elt_pairs
 
 addListToUFM_directly_C combiner fm uniq_elt_pairs
@@ -326,7 +327,7 @@ Now ways of removing things from UniqFM.
 \begin{code}
 delListFromUFM fm lst = foldl delFromUFM fm lst
 
-delFromUFM fm key = delete fm (u2i (getTheUnique key))
+delFromUFM fm key = delete fm (u2i (getItsUnique key))
 
 delete EmptyUFM _   = EmptyUFM
 delete fm       key = del_ele fm
@@ -340,7 +341,7 @@ delete fm       key = del_ele fm
     del_ele nd@(NodeUFM j p t1 t2)
       | j _GT_ key
       = mkSLNodeUFM (NodeUFMData j p) (del_ele t1) t2
-      | otherwise	
+      | otherwise
       = mkLSNodeUFM (NodeUFMData j p) t1 (del_ele t2)
 
     del_ele _ = panic "Found EmptyUFM FM when rec-deleting"
@@ -383,7 +384,7 @@ plusUFM_C f fm1 fm2	= mix_trees fm1 fm2
 		--	  j		j'			 j
 		--	 / \	+      / \	==>		/ \
 		--     t1   t2	    t1'	  t2'		t1 + t1'   t2 + t2'
-		--	
+		--
 	  mix_branches (SameRoot)
 		= mkSSNodeUFM (NodeUFMData j p)
 			(mix_trees t1 t1')
@@ -397,29 +398,29 @@ plusUFM_C f fm1 fm2	= mix_trees fm1 fm2
 		--     t1   t2	    t1'	  t2'		      t1   t2 + j'
 		--						       / \
 		--						     t1'  t2'
-	  mix_branches (LeftRoot Left) -- | trace "LL" True
+	  mix_branches (LeftRoot Leftt) -- | trace "LL" True
 	    = mkSLNodeUFM
 		(NodeUFMData j p)
-		(mix_trees t1 right_t)	
+		(mix_trees t1 right_t)
 		t2
 
-	  mix_branches (LeftRoot Right) -- | trace "LR" True
+	  mix_branches (LeftRoot Rightt) -- | trace "LR" True
 	    = mkLSNodeUFM
 		(NodeUFMData j p)
 		t1
-		(mix_trees t2 right_t)	
+		(mix_trees t2 right_t)
 
-	  mix_branches (RightRoot Left) -- | trace "RL" True
+	  mix_branches (RightRoot Leftt) -- | trace "RL" True
 	    = mkSLNodeUFM
 		(NodeUFMData j' p')
-		(mix_trees left_t t1')	
+		(mix_trees left_t t1')
 		t2'
 
-	  mix_branches (RightRoot Right) -- | trace "RR" True
+	  mix_branches (RightRoot Rightt) -- | trace "RR" True
 	    = mkLSNodeUFM
 		(NodeUFMData j' p')
 		t1'
-		(mix_trees left_t t2')	
+		(mix_trees left_t t2')
 
 	mix_trees _ _ = panic "EmptyUFM found when inserting into plusInt"
 \end{code}
@@ -453,8 +454,8 @@ minusUFM fm1 fm2     = minus_trees fm1 fm2
 		--	  j		j'		   j
 		--	 / \	+      / \	==>	  / \
 		--     t1   t2	    t1'	  t2'		 t1  t2
-		--				
-		--				
+		--
+		--
 		-- Fast, Ehh !
 		--
 	  minus_branches (NewRoot nd _) = left_t
@@ -464,7 +465,7 @@ minusUFM fm1 fm2     = minus_trees fm1 fm2
 		--	  j		j'			 j
 		--	 / \	+      / \	==>		/ \
 		--     t1   t2	    t1'	  t2'		t1 + t1'   t2 + t2'
-		--	
+		--
 	  minus_branches (SameRoot)
 		= mkSSNodeUFM (NodeUFMData j p)
 			(minus_trees t1 t1')
@@ -475,23 +476,23 @@ minusUFM fm1 fm2     = minus_trees fm1 fm2
 		--
 		-- The left is above the right
 		--
-	  minus_branches (LeftRoot Left)
+	  minus_branches (LeftRoot Leftt)
 	    = mkSLNodeUFM
 		(NodeUFMData j p)
-		(minus_trees t1 right_t)	
+		(minus_trees t1 right_t)
 		t2
-	  minus_branches (LeftRoot Right)
+	  minus_branches (LeftRoot Rightt)
 	    = mkLSNodeUFM
 		(NodeUFMData j p)
 		t1
-		(minus_trees t2 right_t)	
+		(minus_trees t2 right_t)
 
 		--
 		-- The right is above the left
 		--
-	  minus_branches (RightRoot Left)
+	  minus_branches (RightRoot Leftt)
 	    = minus_trees left_t t1'
-	  minus_branches (RightRoot Right)
+	  minus_branches (RightRoot Rightt)
 	    = minus_trees left_t t2'
 
 	minus_trees _ _ = panic "EmptyUFM found when insering into plusInt"
@@ -524,10 +525,10 @@ intersectUFM_C f fm1 fm2    = intersect_trees fm1 fm2
 	  where
 		-- Given a disjoint j,j' (p >^ p' && p' >^ p):
 		--
-		--	  j		j'		
+		--	  j		j'
 		--	 / \	+      / \	==>		EmptyUFM
-		--     t1   t2	    t1'	  t2'		
-		--					
+		--     t1   t2	    t1'	  t2'
+		--
 		-- Fast, Ehh !
 		--
 	  intersect_branches (NewRoot nd _) = EmptyUFM
@@ -537,7 +538,7 @@ intersectUFM_C f fm1 fm2    = intersect_trees fm1 fm2
 		--	  j		j'			 j
 		--	 / \	+      / \	==>		/ \
 		--     t1   t2	    t1'	  t2'		t1 x t1'   t2 x t2'
-		--	
+		--
 	  intersect_branches (SameRoot)
 		= mkSSNodeUFM (NodeUFMData j p)
 			(intersect_trees t1 t1')
@@ -549,16 +550,16 @@ intersectUFM_C f fm1 fm2    = intersect_trees fm1 fm2
 		--	  j		j'		       t2 + j'
 		--	 / \	+      / \	==>		   / \
 		--     t1   t2	    t1'	  t2'			 t1'  t2'
-		--						
+		--
 		-- This does cut down the search space quite a bit.
-					
-	  intersect_branches (LeftRoot Left)
+
+	  intersect_branches (LeftRoot Leftt)
 	    = intersect_trees t1 right_t
-	  intersect_branches (LeftRoot Right)
+	  intersect_branches (LeftRoot Rightt)
 	    = intersect_trees t2 right_t
-	  intersect_branches (RightRoot Left)
+	  intersect_branches (RightRoot Leftt)
 	    = intersect_trees left_t t1'
-	  intersect_branches (RightRoot Right)
+	  intersect_branches (RightRoot Rightt)
 	    = intersect_trees left_t t2'
 
 	intersect_trees x y = panic ("EmptyUFM found when intersecting trees")
@@ -595,11 +596,16 @@ looking up in a hurry is the {\em whole point} of this binary tree lark.
 Lookup up a binary tree is easy (and fast).
 
 \begin{code}
-lookupUFM	  fm key = lookup fm (u2i (getTheUnique key))
-lookupDirectlyUFM fm key = lookup fm (u2i key)
+lookupUFM	  fm key = lookup fm (u2i (getItsUnique key))
+lookupUFM_Directly fm key = lookup fm (u2i key)
 
 lookupWithDefaultUFM fm deflt key
-  = case lookup fm (u2i (getTheUnique key)) of
+  = case lookup fm (u2i (getItsUnique key)) of
+      Nothing  -> deflt
+      Just elt -> elt
+
+lookupWithDefaultUFM_Directly fm deflt key
+  = case lookup fm (u2i key) of
       Nothing  -> deflt
       Just elt -> elt
 
@@ -763,7 +769,7 @@ map_tree f _ = panic "map_tree failed"
 filter_tree f nd@(NodeUFM j p t1 t2)
   = mkSSNodeUFM (NodeUFMData j p) (filter_tree f t1) (filter_tree f t2)
 
-filter_tree f lf@(LeafUFM i obj)	
+filter_tree f lf@(LeafUFM i obj)
   | f obj = lf
   | otherwise = EmptyUFM
 \end{code}
@@ -788,7 +794,7 @@ data NodeUFMData
 This is the information used when computing new NodeUFMs.
 
 \begin{code}
-data Side = Left | Right
+data Side = Leftt | Rightt -- NB: avoid 1.3 names "Left" and "Right"
 data CommonRoot
   = LeftRoot  Side	-- which side is the right down ?
   | RightRoot Side	-- which side is the left down ?
@@ -839,8 +845,8 @@ ask_about_common_ancestor x@(NodeUFMData j p) y@(NodeUFMData j2 p2)
 	| otherwise   -> NewRoot nd (j _GT_ j2)
     where
 	decideSide :: Bool -> Side
-	decideSide True	 = Left
-	decideSide False = Right
+	decideSide True	 = Leftt
+	decideSide False = Rightt
 \end{code}
 
 This might be better in Util.lhs ?
@@ -856,12 +862,8 @@ shiftR_ :: FAST_INT -> FAST_INT -> FAST_INT
 {-# INLINE shiftR_ #-}
 shiftL_ n p = word2Int#((int2Word# n) `shiftL#` p)
 shiftR_ n p = word2Int#((int2Word# n) `shiftr` p)
-# if __GLASGOW_HASKELL__ >= 23
   where
     shiftr x y = shiftRA# x y
-# else
-    shiftr x y = shiftR#  x y
-# endif
 
 #else {- not GHC -}
 shiftL_ n p = n * (2 ^ p)
diff --git a/ghc/compiler/utils/UniqSet.hi b/ghc/compiler/utils/UniqSet.hi
deleted file mode 100644
index 0a5b62967b..0000000000
--- a/ghc/compiler/utils/UniqSet.hi
+++ /dev/null
@@ -1,32 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface UniqSet where
-import Id(Id)
-import Name(Name)
-import NameTypes(FullName, ShortName)
-import Outputable(NamedThing)
-import PreludePS(_PackedString)
-import TyCon(TyCon)
-import TyVar(TyVar)
-import UniqFM(UniqFM)
-import Unique(Unique)
-data Id 
-type IdSet = UniqFM Id
-data Name 
-type NameSet = UniqFM Name
-data TyVar 
-type TyVarSet = UniqFM TyVar
-data UniqFM a 
-type UniqSet a = UniqFM a
-data Unique 
-elementOfUniqSet :: NamedThing a => a -> UniqFM a -> Bool
-emptyUniqSet :: UniqFM a
-intersectUniqSets :: UniqFM a -> UniqFM a -> UniqFM a
-isEmptyUniqSet :: UniqFM a -> Bool
-mapUniqSet :: NamedThing b => (a -> b) -> UniqFM a -> UniqFM b
-minusUniqSet :: UniqFM a -> UniqFM a -> UniqFM a
-mkUniqSet :: NamedThing a => [a] -> UniqFM a
-singletonUniqSet :: NamedThing a => a -> UniqFM a
-unionManyUniqSets :: [UniqFM a] -> UniqFM a
-unionUniqSets :: UniqFM a -> UniqFM a -> UniqFM a
-uniqSetToList :: UniqFM a -> [a]
-
diff --git a/ghc/compiler/utils/UniqSet.lhs b/ghc/compiler/utils/UniqSet.lhs
index 3adc33b174..6882e683e2 100644
--- a/ghc/compiler/utils/UniqSet.lhs
+++ b/ghc/compiler/utils/UniqSet.lhs
@@ -1,5 +1,5 @@
 %
-% (c) The AQUA Project, Glasgow University, 1994-1995
+% (c) The AQUA Project, Glasgow University, 1994-1996
 %
 \section[UniqSet]{Specialised sets, for things with @Uniques@}
 
@@ -7,8 +7,6 @@ Based on @UniqFMs@ (as you would expect).
 
 Basically, the things need to be in class @NamedThing@.
 
-We also export specialisations for @Ids@ and @TyVars@.
-
 \begin{code}
 #include "HsVersions.h"
 
@@ -17,41 +15,22 @@ module UniqSet (
 
 	mkUniqSet, uniqSetToList, emptyUniqSet, singletonUniqSet,
 	unionUniqSets, unionManyUniqSets, minusUniqSet,
-	elementOfUniqSet, mapUniqSet,
-	intersectUniqSets, isEmptyUniqSet,
-	
-	-- specalised for Ids:
-	IdSet(..),
-
-	-- specalised for TyVars:
-	TyVarSet(..),
-
-	-- specalised for Names:
-	NameSet(..),
-
-	-- to make the interface self-sufficient
-	Id, TyVar, Name,
-
-	UniqFM, Unique
-
-	-- and to be pragma friendly
-#ifdef USE_ATTACK_PRAGMAS
-	, emptyUFM, intersectUFM, isNullUFM, minusUFM, singletonUFM,
-	plusUFM, eltsUFM,
-	u2i
-#endif
+	elementOfUniqSet, mapUniqSet, intersectUniqSets,
+	isEmptyUniqSet
     ) where
 
+CHK_Ubiq() -- debugging consistency check
+
+import Maybes		( maybeToBool, Maybe )
 import UniqFM
-import Id		-- for specialisation to Ids
-import IdInfo		-- sigh
-import Maybes		( maybeToBool, Maybe(..) )
-import Name
-import Outputable
-import AbsUniType	-- for specialisation to TyVars
-import Util
+import Unique		( Unique )
+import Outputable	( Outputable(..), NamedThing(..), ExportFlag )
+import SrcLoc		( SrcLoc )
+import Pretty		( Pretty(..), PrettyRep )
+import PprStyle		( PprStyle )
+import Util		( Ord3(..) )
+
 #if ! OMIT_NATIVE_CODEGEN
-import AsmRegAlloc	( Reg )
 #define IF_NCG(a) a
 #else
 #define IF_NCG(a) {--}
@@ -64,7 +43,7 @@ import AsmRegAlloc	( Reg )
 %*									*
 %************************************************************************
 
-We use @UniqFM@, with a (@getTheUnique@-able) @Unique@ as ``key''
+We use @UniqFM@, with a (@getItsUnique@-able) @Unique@ as ``key''
 and the thing itself as the ``value'' (for later retrieval).
 
 \begin{code}
@@ -80,7 +59,7 @@ singletonUniqSet :: NamedThing a => a -> UniqSet a
 singletonUniqSet x = MkUniqSet (singletonUFM x x)
 
 uniqSetToList :: UniqSet a -> [a]
-uniqSetToList (MkUniqSet set) = BSCC("uniqSetToList") eltsUFM set ESCC
+uniqSetToList (MkUniqSet set) = eltsUFM set
 
 mkUniqSet :: NamedThing a => [a]  -> UniqSet a
 mkUniqSet xs = MkUniqSet (listToUFM [ (x, x) | x <- xs])
@@ -124,41 +103,43 @@ mapUniqSet f (MkUniqSet set)
 @IdSet@ is a specialised version, optimised for sets of Ids.
 
 \begin{code}
-type IdSet    = UniqSet Id
-type TyVarSet = UniqSet TyVar
-type NameSet  = UniqSet Name
+--type NameSet           = UniqSet Name
+--type GenTyVarSet flexi = UniqSet (GenTyVar flexi)
+--type GenIdSet ty       = UniqSet (GenId ty)
+
 #if ! OMIT_NATIVE_CODEGEN
-type RegSet   = UniqSet Reg
+--type RegSet   = UniqSet Reg
 #endif
 
+#if 0
 #if __GLASGOW_HASKELL__
-    -- avoid hbc bug (0.999.7)
 {-# SPECIALIZE
-    singletonUniqSet :: Id    -> IdSet,
-			TyVar -> TyVarSet,
+    singletonUniqSet :: GenId ty       -> GenIdSet ty,
+			GenTyVar flexi -> GenTyVarSet flexi,
 			Name  -> NameSet
     IF_NCG(COMMA	Reg   -> RegSet)
     #-}
 
 {-# SPECIALIZE
-    mkUniqSet :: [Id]    -> IdSet,
-		 [TyVar] -> TyVarSet,
+    mkUniqSet :: [GenId ty]    -> GenIdSet ty,
+		 [GenTyVar flexi] -> GenTyVarSet flexi,
 		 [Name]  -> NameSet
     IF_NCG(COMMA [Reg]   -> RegSet)
     #-}
 
 {-# SPECIALIZE
-    elementOfUniqSet :: Id    -> IdSet    -> Bool,
-		    	TyVar -> TyVarSet -> Bool,
+    elementOfUniqSet :: GenId ty       -> GenIdSet ty       -> Bool,
+		    	GenTyVar flexi -> GenTyVarSet flexi -> Bool,
 			Name  -> NameSet  -> Bool
     IF_NCG(COMMA	Reg   -> RegSet   -> Bool)
     #-}
 
 {-# SPECIALIZE
-    mapUniqSet :: (Id    -> Id)    -> IdSet    -> IdSet,
-		  (TyVar -> TyVar) -> TyVarSet -> TyVarSet,
+    mapUniqSet :: (GenId ty       -> GenId ty)       -> GenIdSet ty        -> GenIdSet ty,
+		  (GenTyVar flexi -> GenTyVar flexi) -> GenTyVarSet flexi -> GenTyVarSet flexi,
 		  (Name  -> Name)  -> NameSet  -> NameSet
     IF_NCG(COMMA  (Reg  -> Reg)    -> RegSet   -> RegSet)
     #-}
 #endif
+#endif
 \end{code}
diff --git a/ghc/compiler/utils/Unpretty.hi b/ghc/compiler/utils/Unpretty.hi
deleted file mode 100644
index f90bd8503a..0000000000
--- a/ghc/compiler/utils/Unpretty.hi
+++ /dev/null
@@ -1,37 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface Unpretty where
-import CharSeq(CSeq)
-import CmdLineOpts(GlobalSwitch)
-import PreludePS(_PackedString)
-import Pretty(PprStyle(..))
-import Stdio(_FILE)
-data CSeq 
-data GlobalSwitch 
-data PprStyle   = PprForUser | PprDebug | PprShowAll | PprInterface (GlobalSwitch -> Bool) | PprForC (GlobalSwitch -> Bool) | PprUnfolding (GlobalSwitch -> Bool) | PprForAsm (GlobalSwitch -> Bool) Bool ([Char] -> [Char])
-type Unpretty = CSeq
-uppAbove :: CSeq -> CSeq -> CSeq
-uppAboves :: [CSeq] -> CSeq
-uppAppendFile :: _FILE -> Int -> CSeq -> _State _RealWorld -> ((), _State _RealWorld)
-uppBeside :: CSeq -> CSeq -> CSeq
-uppBesides :: [CSeq] -> CSeq
-uppCat :: [CSeq] -> CSeq
-uppChar :: Char -> CSeq
-uppComma :: CSeq
-uppEquals :: CSeq
-uppInt :: Int -> CSeq
-uppInteger :: Integer -> CSeq
-uppInterleave :: CSeq -> [CSeq] -> CSeq
-uppIntersperse :: CSeq -> [CSeq] -> CSeq
-uppLbrack :: CSeq
-uppLparen :: CSeq
-uppNest :: Int -> CSeq -> CSeq
-uppNil :: CSeq
-uppPStr :: _PackedString -> CSeq
-uppRbrack :: CSeq
-uppRparen :: CSeq
-uppSP :: CSeq
-uppSemi :: CSeq
-uppSep :: [CSeq] -> CSeq
-uppShow :: Int -> CSeq -> [Char]
-uppStr :: [Char] -> CSeq
-
diff --git a/ghc/compiler/utils/Unpretty.lhs b/ghc/compiler/utils/Unpretty.lhs
index 2cdf8d4cad..6b27379818 100644
--- a/ghc/compiler/utils/Unpretty.lhs
+++ b/ghc/compiler/utils/Unpretty.lhs
@@ -1,5 +1,5 @@
 %
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
 %
 \section[Unpretty]{Unpretty-printing data type}
 
@@ -8,31 +8,23 @@
 
 module Unpretty (
 	Unpretty(..),
-	PprStyle(..),	-- re-exported from Pretty
-	uppNil, uppStr, uppPStr, uppChar, uppInt, uppInteger, --UNUSED: uppDouble,
-	uppSP, uppLbrack, uppRbrack, uppLparen, uppRparen, -- UNUSED: upp'SP,
+
+	uppNil, uppStr, uppPStr, uppChar, uppInt, uppInteger,
+	uppSP, uppLbrack, uppRbrack, uppLparen, uppRparen,
 	uppSemi, uppComma, uppEquals,
 
 	uppCat, uppBeside, uppBesides, uppAbove, uppAboves,
-	uppNest, uppSep, uppInterleave, uppIntersperse, --UNUSED: uppHang,
+	uppNest, uppSep, uppInterleave, uppIntersperse,
 	uppShow,
-#ifdef __GLASGOW_HASKELL__
 	uppAppendFile,
-	IF_ATTACK_PRAGMAS(cAppendFile COMMA)
-	IF_ATTACK_PRAGMAS(cInt COMMA)
-#endif
-#ifdef DPH
-	unprettyToStr,
-#endif {- Data Parallel Haskell -}
 
 	-- abstract type, to complete the interface...
-	CSeq, GlobalSwitch
+	CSeq
    ) where
 
+CHK_Ubiq() -- debugging consistency check
+
 import CharSeq
-import Outputable
-import Pretty		( PprStyle(..), Pretty(..), GlobalSwitch )
-import Util
 \end{code}
 
 Same interface as @Pretty@, but doesn't do anything.
@@ -51,14 +43,12 @@ type Unpretty = CSeq
 \begin{code}
 uppNil		:: Unpretty
 uppSP, uppLbrack, uppRbrack, uppLparen, uppRparen, uppSemi, uppComma, uppEquals :: Unpretty
---UNUSED: upp'SP :: Unpretty
 
 uppStr		:: [Char] -> Unpretty
 uppPStr		:: FAST_STRING -> Unpretty
 uppChar		:: Char -> Unpretty
 uppInt		:: Int -> Unpretty
 uppInteger	:: Integer -> Unpretty
---UNUSED:uppDouble	:: Double -> Unpretty
 
 uppBeside	:: Unpretty -> Unpretty -> Unpretty
 uppBesides	:: [Unpretty] -> Unpretty
@@ -71,14 +61,11 @@ uppAboves	:: [Unpretty] -> Unpretty
 uppInterleave	:: Unpretty -> [Unpretty] -> Unpretty
 uppIntersperse	:: Unpretty -> [Unpretty] -> Unpretty	-- no spaces between
 uppSep		:: [Unpretty] -> Unpretty
---UNUSED:uppHang		:: Unpretty -> Int -> Unpretty -> Unpretty
 uppNest		:: Int -> Unpretty -> Unpretty
 
 uppShow		:: Int -> Unpretty -> [Char]
 
-#ifdef __GLASGOW_HASKELL__
 uppAppendFile	:: _FILE -> Int -> Unpretty -> PrimIO ()
-#endif
 \end{code}
 
 %************************************************
@@ -90,9 +77,7 @@ uppAppendFile	:: _FILE -> Int -> Unpretty -> PrimIO ()
 \begin{code}
 uppShow _ p	= cShow p
 
-#ifdef __GLASGOW_HASKELL__
 uppAppendFile f _ p = cAppendFile f p
-#endif
 
 uppNil		= cNil
 uppStr s	= cStr s
@@ -101,10 +86,8 @@ uppChar c	= cCh c
 uppInt n	= cInt n
 
 uppInteger n	= cStr (show n)
---UNUSED:uppDouble  n	= cStr (show n)
 
 uppSP		= cCh ' '
---UNUSED:upp'SP		= cStr  ", "
 uppLbrack	= cCh '['
 uppRbrack	= cCh ']'
 uppLparen	= cCh '('
@@ -154,17 +137,6 @@ uppAboves [p]	 = p
 uppAboves (p:ps) = p `cAppend` (cCh '\n') `cAppend` (uppAboves ps)
 
 uppNest n p = p
-\end{code}
-
-\begin{code}
---UNUSED: uppHang p1 n p2 = ppBesideSP p1 p2
 
 uppSep ps = uppBesides ps
 \end{code}
-
-\begin{code}
-#ifdef DPH
-unprettyToStr:: Unpretty -> String
-unprettyToStr thing = uppShow 80 thing
-#endif {- Data Parallel Haskell -}
-\end{code}
diff --git a/ghc/compiler/utils/Util.hi b/ghc/compiler/utils/Util.hi
deleted file mode 100644
index 20b36502d3..0000000000
--- a/ghc/compiler/utils/Util.hi
+++ /dev/null
@@ -1,33 +0,0 @@
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface Util where
-import CharSeq(CSeq)
-import Maybes(Labda(..))
-import PreludePS(_PackedString)
-import Pretty(Delay, Pretty(..), PrettyRep)
-data Labda a   = Hamna | Ni a
-type Pretty = Int -> Bool -> PrettyRep
-data PrettyRep 
-assertPanic :: [Char] -> Int -> a
-assoc :: Eq a => [Char] -> [(a, b)] -> a -> b
-cmpPString :: _PackedString -> _PackedString -> Int#
-equivClasses :: (a -> a -> Int#) -> [a] -> [[a]]
-hasNoDups :: Eq a => [a] -> Bool
-isIn :: Eq a => [Char] -> a -> [a] -> Bool
-isSingleton :: [a] -> Bool
-isn'tIn :: Eq a => [Char] -> a -> [a] -> Bool
-lengthExceeds :: [a] -> Int -> Bool
-mapAccumB :: (b -> c -> a -> (b, c, d)) -> b -> c -> [a] -> (b, c, [d])
-mapAccumL :: (b -> a -> (b, c)) -> b -> [a] -> (b, [c])
-mapAccumR :: (b -> a -> (b, c)) -> b -> [a] -> (b, [c])
-nOfThem :: Int -> a -> [a]
-naturalMergeSortLe :: (a -> a -> Bool) -> [a] -> [a]
-panic :: [Char] -> a
-pprPanic :: [Char] -> (Int -> Bool -> PrettyRep) -> a
-pprTrace :: [Char] -> (Int -> Bool -> PrettyRep) -> a -> a
-removeDups :: (a -> a -> Int#) -> [a] -> ([a], [[a]])
-runs :: (a -> a -> Bool) -> [a] -> [[a]]
-sortLt :: (a -> a -> Bool) -> [a] -> [a]
-transitiveClosure :: (a -> [a]) -> (a -> a -> Bool) -> [a] -> [a]
-unzipWith :: (a -> b -> c) -> [(a, b)] -> [c]
-zipEqual :: [a] -> [b] -> [(a, b)]
-
diff --git a/ghc/compiler/utils/Util.lhs b/ghc/compiler/utils/Util.lhs
index 4b00e9219c..e59113e385 100644
--- a/ghc/compiler/utils/Util.lhs
+++ b/ghc/compiler/utils/Util.lhs
@@ -1,5 +1,5 @@
 %
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
 %
 \section[Util]{Highly random utility functions}
 
@@ -37,16 +37,15 @@ module Util (
 #endif
 	-- general list processing
 	IF_NOT_GHC(forall COMMA exists COMMA)
-	zipEqual, nOfThem, lengthExceeds, isSingleton,
+	zipEqual, zipWithEqual, zipWith3Equal, zipWith4Equal,
+        zipLazy,
+	nOfThem, lengthExceeds, isSingleton,
 #if defined(COMPILING_GHC)
 	isIn, isn'tIn,
 #endif
 
 	-- association lists
 	assoc,
-#ifdef USE_SEMANTIQUE_STRANAL
-	clookup, clookrepl, elemIndex, (\\\),
-#endif
 
 	-- duplicate handling
 	hasNoDups, equivClasses, runs, removeDups,
@@ -64,6 +63,7 @@ module Util (
 	mapAccumL, mapAccumR, mapAccumB,
 
 	-- comparisons
+	Ord3(..), thenCmp, cmpList,
 	IF_NOT_GHC(cmpString COMMA)
 #ifdef USE_FAST_STRINGS
 	cmpPString,
@@ -77,7 +77,7 @@ module Util (
 
 	-- error handling
 #if defined(COMPILING_GHC)
-	, panic, pprPanic, pprTrace
+	, panic, panic#, pprPanic, pprPanic#, pprTrace
 # ifdef DEBUG
 	, assertPanic
 # endif
@@ -92,272 +92,16 @@ module Util (
 # endif
 #endif
 
-#ifdef USE_ATTACK_PRAGMAS
-	-- as more-or-less of a *HACK*, Util exports
-	-- many types abstractly, so that pragmas will be
-	-- able to see them (given that most modules
-	-- import Util).
-	,
-	AbstractC,
-	ArgUsage,
-	ArgUsageInfo,
-	ArithSeqInfo,
-	ArityInfo,
-	Bag,
-	BasicLit,
-	Bind,
-	BinderInfo,
-	Binds,
-	CAddrMode,
-	CExprMacro,
-	CLabel,
-	CSeq,
-	CStmtMacro,
-	CcKind,
-	Class,
-	ClassDecl,
-	ClassOp,
-	ClassOpPragmas,
-	ClassPragmas,
-	ClosureInfo,
-	ConDecl,
-	CoreArg,
-	CoreAtom,
-	CoreBinding,
-	CoreCaseAlternatives,
-	CoreCaseDefault,
-	CoreExpr,
-	CostCentre,
-	DataPragmas,
-	DataTypeSig,
-	DefaultDecl,
-	DeforestInfo,
-	Delay,
-	Demand,
-	DemandInfo,
-	DuplicationDanger,
-	EnclosingCcDetails,
-	EndOfBlockInfo,
-	ExportFlag,
-	Expr,
-	FBConsum,
-	FBProd,
-	FBType,
-	FBTypeInfo,
-	FiniteMap,
-	FixityDecl,
-	FormSummary,
-	FullName,
-	FunOrArg,
-	GRHS,
-	GRHSsAndBinds,
-	GenPragmas,
-	GlobalSwitch,
-	HeapOffset,
-	IE,
-	Id,
-	IdDetails,
-	IdEnv(..), -- UGH
-	IdInfo,
-	IdVal,
-	IfaceImportDecl,
-	ImpStrictness,
-	ImpUnfolding,
-	ImportedInterface,
-	InPat,
-	InsideSCC,
-	Inst,
-	InstDecl,
-	InstOrigin,
-	InstTemplate,
-	InstTy,
-	InstancePragmas,
-	Interface,
-	IsDupdCC, IsCafCC,
-	LambdaFormInfo,
-	Literal,
-	MagicId,
-	MagicUnfoldingFun,
-	Match,
-	Module,
-	MonoBinds,
-	MonoType,
-	Name,
-	NamedThing(..), -- SIGH
-	OptIdInfo(..), -- SIGH
-	OrdList,
-	Outputable(..), -- SIGH
-	OverloadedLit,
-	PolyType,
-	PprStyle,
-	PrimKind,
-	PrimOp,
-	ProtoName,
-	Provenance,
-	Qual,
-	RegRelative,
-	Renaming,
-	ReturnInfo,
-	SMRep,
-	SMSpecRepKind,
-	SMUpdateKind,
-	Sequel,
-	ShortName,
-	Sig,
-	SimplCount,
-	SimplEnv,
-	SimplifierSwitch,
-	SpecEnv,
-	SpecInfo,
-	SpecialisedInstanceSig,
-	SplitUniqSupply,
-	SrcLoc,
-	StableLoc,
-	StandardFormInfo,
-	StgAtom,
-	StgBinderInfo,
-	StgBinding,
-	StgCaseAlternatives,
-	StgCaseDefault,
-	StgExpr,
-	StgRhs,
-	StrictnessInfo,
-	StubFlag,
-	SwitchResult,
-	TickType,
-	TyCon,
-	TyDecl,
-	TyVar,
-	TyVarEnv(..),
-	TyVarTemplate,
-	TypePragmas,
-	TypecheckedPat,
-	UfCostCentre,
-	UfId,
-	UnfoldEnv,
-	UnfoldItem,
-	UnfoldConApp,
-	UnfoldingCoreAlts,
-	UnfoldingCoreAtom,
-	UnfoldingCoreBinding,
-	UnfoldingCoreDefault,
-	UnfoldingCoreExpr,
-	UnfoldingDetails,
-	UnfoldingGuidance,
-	UnfoldingPrimOp,
-	UniType,
-	UniqFM,
-	Unique,
-	UniqueSupply,
-	UpdateFlag,
-	UpdateInfo,
-	VolatileLoc,
-
-#if ! OMIT_NATIVE_CODEGEN
-	Reg,
-	CodeSegment,
-	RegLoc,
-	StixReg,
-	StixTree,
-#endif
-
-	getIdUniType, typeOfBasicLit, typeOfPat,
-	getIdKind, kindOfBasicLit,
-	kindFromType,
-
-	eqId, cmpId,
-	eqName, cmpName,
-	cmpProtoName, eqProtoName,
-	cmpByLocalName, eqByLocalName,
-	eqUnique, cmpUnique,
-	showUnique,
-
-	switchIsOn,
-
-	ppNil, ppStr, ppInt, ppInteger, ppDouble,
-#if __GLASGOW_HASKELL__ >= 23
-	ppRational, --- ???
-#endif
-	cNil, cStr, cAppend, cCh, cShow,
-#if __GLASGOW_HASKELL__ >= 23
-	cPStr,
-#endif
-
---	mkBlackHoleCLabel,
-
-	emptyBag, snocBag,
-	emptyFM,
---OLD:	emptySet,
-	nullSpecEnv,
-	
-	mkUnknownSrcLoc,
-	
-	pprCoreBinding, pprCoreExpr, pprTyCon, pprUniType,
-
-	tagOf_PrimOp,
-	pprPrimOp
-
-#endif {-USE_ATTACK_PRAGMAS-}
     ) where
 
 #if defined(COMPILING_GHC)
-IMPORT_Trace
+
+CHK_Ubiq() -- debugging consistency check
+
 import Pretty
 #endif
 #if __HASKELL1__ < 3
 import Maybes		( Maybe(..) )
-#endif
-
-#if defined(COMPILING_GHC)
-import Id
-import IdInfo
-import Outputable
-
-# ifdef USE_ATTACK_PRAGMAS
-
-import AbsCSyn
-import AbsSyn
-import AbsUniType
-import Bag
-import BasicLit
-import BinderInfo
-import CLabelInfo
-import CgBindery
-import CgMonad
-import CharSeq
-import ClosureInfo
-import CmdLineOpts
-import CoreSyn
-import FiniteMap
-import HsCore
-import HsPragmas
-import Inst
-import InstEnv
-import Name
-import NameTypes
-import OrdList
-import PlainCore
-import PrimOps
-import ProtoName
-import CostCentre
-import SMRep
-import SimplEnv
-import SimplMonad
-import SplitUniq
-import SrcLoc
-import StgSyn
-import TyVarEnv
-import UniqFM
-import Unique
-
-#  if ! OMIT_NATIVE_CODEGEN
-import AsmRegAlloc	( Reg )
-import MachDesc
-import Stix
-#  endif
-
-# endif {-USE_ATTACK_PRAGMAS-}
-
 #endif
 \end{code}
 
@@ -395,22 +139,50 @@ exists pred []     = False
 exists pred (x:xs) = pred x || exists pred xs
 \end{code}
 
-A paranoid @zip@ that checks the lists are of equal length.
-Alastair Reid thinks this should only happen if DEBUGging on;
-hey, why not?
+A paranoid @zip@ (and some @zipWith@ friends) that checks the lists
+are of equal length.  Alastair Reid thinks this should only happen if
+DEBUGging on; hey, why not?
 
 \begin{code}
-zipEqual :: [a] -> [b] -> [(a,b)]
+zipEqual	:: [a] -> [b] -> [(a,b)]
+zipWithEqual	:: (a->b->c) -> [a]->[b]->[c]
+zipWith3Equal	:: (a->b->c->d) -> [a]->[b]->[c]->[d]
+zipWith4Equal	:: (a->b->c->d->e) -> [a]->[b]->[c]->[d]->[e]
 
 #ifndef DEBUG
-zipEqual a b = zip a b
+zipEqual      = zip
+zipWithEqual  = zipWith
+zipWith3Equal = zipWith3
+zipWith4Equal = zipWith4
 #else
 zipEqual []     []     = []
 zipEqual (a:as) (b:bs) = (a,b) : zipEqual as bs
 zipEqual as     bs     = panic "zipEqual: unequal lists"
+
+zipWithEqual z (a:as) (b:bs)	=  z a b : zipWithEqual z as bs
+zipWithEqual _ [] []		=  []
+zipWithEqual _ _ _		=  panic "zipWithEqual: unequal lists"
+
+zipWith3Equal z (a:as) (b:bs) (c:cs)
+				=  z a b c : zipWith3Equal z as bs cs
+zipWith3Equal _ [] []  []	=  []
+zipWith3Equal _ _  _   _	=  panic "zipWith3Equal: unequal lists"
+
+zipWith4Equal z (a:as) (b:bs) (c:cs) (d:ds)
+				=  z a b c d : zipWith4Equal z as bs cs ds
+zipWith4Equal _ [] [] [] []	=  []
+zipWith4Equal _ _  _  _  _	=  panic "zipWith4Equal: unequal lists"
 #endif
 \end{code}
 
+\begin{code}
+-- zipLazy is lazy in the second list (observe the ~)
+
+zipLazy :: [a] -> [b] -> [(a,b)]
+zipLazy [] ys = []
+zipLazy (x:xs) ~(y:ys) = (x,y) : zipLazy xs ys
+\end{code}
+
 \begin{code}
 nOfThem :: Int -> a -> [a]
 nOfThem n thing = take n (repeat thing)
@@ -462,7 +234,7 @@ isn'tIn msg x ys
 # endif {- DEBUG -}
 
 # ifdef USE_ATTACK_PRAGMAS
-{-# SPECIALIZE isIn :: String -> BasicLit -> [BasicLit] -> Bool #-}
+{-# SPECIALIZE isIn :: String -> Literal -> [Literal] -> Bool #-}
 {-# SPECIALIZE isIn :: String -> Class -> [Class] -> Bool #-}
 {-# SPECIALIZE isIn :: String -> Id -> [Id] -> Bool #-}
 {-# SPECIALIZE isIn :: String -> Int -> [Int] -> Bool #-}
@@ -507,99 +279,26 @@ assoc crash_msg lst key
 {-# SPECIALIZE assoc :: String -> [(Id,            a)] -> Id		-> a #-}
 {-# SPECIALIZE assoc :: String -> [(Class,         a)] -> Class		-> a #-}
 {-# SPECIALIZE assoc :: String -> [(Name,          a)] -> Name		-> a #-}
-{-# SPECIALIZE assoc :: String -> [(PrimKind,      a)] -> PrimKind	-> a #-}
+{-# SPECIALIZE assoc :: String -> [(PrimRep,      a)] -> PrimRep	-> a #-}
 {-# SPECIALIZE assoc :: String -> [(String,        a)] -> String        -> a #-}
 {-# SPECIALIZE assoc :: String -> [(TyCon,         a)] -> TyCon		-> a #-}
 {-# SPECIALIZE assoc :: String -> [(TyVar,         a)] -> TyVar		-> a #-}
 {-# SPECIALIZE assoc :: String -> [(TyVarTemplate, a)] -> TyVarTemplate -> a #-}
-{-# SPECIALIZE assoc :: String -> [(UniType,       a)] -> UniType	-> a #-}
+{-# SPECIALIZE assoc :: String -> [(Type,          a)] -> Type		-> a #-}
 {-# SPECIALIZE assoc :: String -> [(_PackedString, a)] -> _PackedString -> a #-}
 # endif
 #endif
 \end{code}
 
-Given a list of associations one wants to look for the most recent
-association for a given key. A couple of functions follow that cover
-the simple lookup, the lookup with a default value when the key not
-found, and two corresponding functions operating on unzipped lists
-of associations.
-
-\begin{code}
-#ifdef USE_SEMANTIQUE_STRANAL
-
-clookup :: (Eq a) => [a] -> [b] -> a -> b
-clookup = clookupElse (panic "clookup")
-  where
-   -- clookupElse :: (Eq a) => b -> [a] -> [b] -> a -> b
-   clookupElse d [] [] a = d
-   clookupElse d (x:xs) (y:ys) a
-                | a==x = y
-                | True = clookupElse d xs ys a
-#endif
-\end{code}
-
-The following routine given a curried environment replaces the entry
-labelled with a given name with a new value given. The new value is
-given in the form of a function that allows to transform the old entry.
-
-Assumption is that the list of labels contains the given one and that
-the two lists of the curried environment are of equal lengths.
-
-\begin{code}
-#ifdef USE_SEMANTIQUE_STRANAL
-clookrepl :: Eq a => [a] -> [b] -> a -> (b -> b) -> [b]
-clookrepl (a:as) (b:bs) x f
-   = if x == a then  (f b:bs)  else  (b:clookrepl as bs x f)
-#endif
-\end{code}
-
-The following returns the index of an element in a list.
-
-\begin{code}
-#ifdef USE_SEMANTIQUE_STRANAL
-
-elemIndex :: Eq a => [a] -> a -> Int
-elemIndex as x = indx as x 0
-   where
-     indx :: Eq a => [a] -> a -> Int -> Int
-     indx (a:as) x n = if a==x then n else indx as x ((n+1)::Int)
-# if defined(COMPILING_GHC)
-     indx [] x n     = pprPanic "element not in list in elemIndex" ppNil
-# else
-     indx [] x n     = error "element not in list in elemIndex"
-# endif
-#endif
-\end{code}
-
 %************************************************************************
 %*									*
 \subsection[Utils-dups]{Duplicate-handling}
 %*									*
 %************************************************************************
 
-List difference (non-associative). In the result of @xs \\\ ys@, the
-first occurrence of each element of ys in turn (if any) has been
-removed from xs.  Thus, @(xs ++ ys) \\\ xs == ys@.  This function is
-a copy of @\\@ from report 1.1 and is added to overshade the buggy
-version from the 1.0 version of Haskell.
-
-This routine can be removed after the compiler bootstraps itself and
-a proper @\\@ is can be applied.
-
-\begin{code}
-#ifdef USE_SEMANTIQUE_STRANAL
-(\\\) :: (Eq a) => [a] -> [a] -> [a]
-(\\\) =  foldl del
-   where
-    []     `del` _ = []
-    (x:xs) `del` y
-	| x == y    = xs
-	| otherwise = x : xs `del` y
-#endif
-\end{code}
-
 \begin{code}
 hasNoDups :: (Eq a) => [a] -> Bool
+
 hasNoDups xs = f [] xs
   where
     f seen_so_far []     = True
@@ -622,7 +321,7 @@ hasNoDups xs = f [] xs
 
 \begin{code}
 equivClasses :: (a -> a -> TAG_) 	-- Comparison
-	     -> [a] 
+	     -> [a]
 	     -> [[a]]
 
 equivClasses cmp stuff@[]     = []
@@ -642,8 +341,8 @@ identical elements of the input list. It is passed a predicate @p@ which
 tells when two elements are equal.
 
 \begin{code}
-runs :: (a -> a -> Bool) 	-- Equality 
-     -> [a] 
+runs :: (a -> a -> Bool) 	-- Equality
+     -> [a]
      -> [[a]]
 
 runs p []     = []
@@ -718,7 +417,7 @@ qsort lt [x]    r = x:r
 qsort lt (x:xs) r = qpart lt x xs [] [] r
 
 -- qpart partitions and sorts the sublists
--- rlt contains things less than x, 
+-- rlt contains things less than x,
 -- rge contains the ones greater than or equal to x.
 -- Both have equal elements reversed with respect to the original list.
 
@@ -731,7 +430,7 @@ qpart lt x (y:ys) rlt rge r =
     if lt y x then
 	-- y < x
 	qpart lt x ys (y:rlt) rge r
-    else	
+    else
 	-- y >= x
 	qpart lt x ys rlt (y:rge) r
 
@@ -797,15 +496,15 @@ From: Carsten Kehler Holst <kehler@cs.chalmers.se>
 To: partain@dcs.gla.ac.uk
 Subject: natural merge sort beats quick sort [ and it is prettier ]
 
-Here a piece of Haskell code that I'm rather fond of. See it as an
+Here is a piece of Haskell code that I'm rather fond of. See it as an
 attempt to get rid of the ridiculous quick-sort routine. group is
 quite useful by itself I think it was John's idea originally though I
 believe the lazy version is due to me [surprisingly complicated].
 gamma [used to be called] is called gamma because I got inspired by
 the Gamma calculus. It is not very close to the calculus but does
-behave less sequentially than both foldr and foldl. One could imagine a
-version of gamma that took a unit element as well thereby avoiding the
-problem with empty lists.
+behave less sequentially than both foldr and foldl. One could imagine
+a version of gamma that took a unit element as well thereby avoiding
+the problem with empty lists.
 
 I've tried this code against
 
@@ -822,26 +521,46 @@ consumption of merge sort is a bit worse than Lennart's quick sort
 approx a factor of 2. And a lot worse if Sparud's bug-fix [see his
 fpca article ] isn't used because of group.
 
-have fun 
+have fun
 Carsten
 \end{display}
 
 \begin{code}
 group :: (a -> a -> Bool) -> [a] -> [[a]]
 
+{-
+Date: Mon, 12 Feb 1996 15:09:41 +0000
+From: Andy Gill <andy@dcs.gla.ac.uk>
+
+Here is a `better' definition of group.
+-}
+group p []     = []
+group p (x:xs) = group' xs x x (x :)
+  where
+    group' []     _     _     s  = [s []]
+    group' (x:xs) x_min x_max s 
+	| not (x `p` x_max) = group' xs x_min x (s . (x :)) 
+	| x `p` x_min       = group' xs x x_max ((x :) . s) 
+	| otherwise         = s [] : group' xs x x (x :) 
+
+-- This one works forwards *and* backwards, as well as also being
+-- faster that the one in Util.lhs.
+
+{- ORIG:
 group p [] = [[]]
-group p (x:xs) = 
+group p (x:xs) =
    let ((h1:t1):tt1) = group p xs
        (t,tt) = if null xs then ([],[]) else
-                if x `p` h1 then (h1:t1,tt1) else 
-                   ([], (h1:t1):tt1)
+		if x `p` h1 then (h1:t1,tt1) else
+		   ([], (h1:t1):tt1)
    in ((x:t):tt)
+-}
 
 generalMerge :: (a -> a -> Bool) -> [a] -> [a] -> [a]
 generalMerge p xs [] = xs
 generalMerge p [] ys = ys
 generalMerge p (x:xs) (y:ys) | x `p` y   = x : generalMerge p xs (y:ys)
-                             | otherwise = y : generalMerge p (x:xs) ys
+			     | otherwise = y : generalMerge p (x:xs) ys
 
 -- gamma is now called balancedFold
 
@@ -880,7 +599,7 @@ This algorithm for transitive closure is straightforward, albeit quadratic.
 \begin{code}
 transitiveClosure :: (a -> [a])		-- Successor function
 		  -> (a -> a -> Bool)	-- Equality predicate
-		  -> [a] 
+		  -> [a]
 		  -> [a]		-- The transitive closure
 
 transitiveClosure succ eq xs
@@ -945,10 +664,10 @@ mapAccumB :: (accl -> accr -> x -> (accl, accr,y))
       				-- Function of elt of input list
       				-- and accumulator, returning new
       				-- accumulator and elt of result list
-          -> accl 			-- Initial accumulator from left
-          -> accr 			-- Initial accumulator from right
-          -> [x] 			-- Input list
-          -> (accl, accr, [y])	-- Final accumulators and result list
+	  -> accl 			-- Initial accumulator from left
+	  -> accr 			-- Initial accumulator from right
+	  -> [x] 			-- Input list
+	  -> (accl, accr, [y])	-- Final accumulators and result list
 
 mapAccumB f a b []     = (a,b,[])
 mapAccumB f a b (x:xs) = (a'',b'',y:ys)
@@ -965,6 +684,46 @@ mapAccumB f a b (x:xs) = (a'',b'',y:ys)
 
 See also @tagCmp_@ near the versions-compatibility section.
 
+The Ord3 class will be subsumed into Ord in Haskell 1.3.
+
+\begin{code}
+class Ord3 a where
+  cmp :: a -> a -> TAG_
+
+thenCmp :: TAG_ -> TAG_ -> TAG_
+{-# INLINE thenCmp #-}
+thenCmp EQ_   any = any
+thenCmp other any = other
+
+cmpList :: (a -> a -> TAG_) -> [a] -> [a] -> TAG_
+    -- `cmpList' uses a user-specified comparer
+
+cmpList cmp []     [] = EQ_
+cmpList cmp []     _  = LT_
+cmpList cmp _      [] = GT_
+cmpList cmp (a:as) (b:bs)
+  = case cmp a b of { EQ_ -> cmpList cmp as bs; xxx -> xxx }
+\end{code}
+
+\begin{code}
+instance Ord3 a => Ord3 [a] where
+  cmp []     []     = EQ_
+  cmp (x:xs) []     = GT_
+  cmp []     (y:ys) = LT_
+  cmp (x:xs) (y:ys) = (x `cmp` y) `thenCmp` (xs `cmp` ys)
+
+instance Ord3 a => Ord3 (Maybe a) where
+  cmp Nothing  Nothing  = EQ_
+  cmp Nothing  (Just y) = LT_
+  cmp (Just x) Nothing  = GT_
+  cmp (Just x) (Just y) = x `cmp` y
+
+instance Ord3 Int where
+  cmp a b | a < b     = LT_
+ 	  | a > b     = GT_
+	  | otherwise = EQ_
+\end{code}
+
 \begin{code}
 cmpString :: String -> String -> TAG_
 
@@ -975,9 +734,7 @@ cmpString (x:xs) (y:ys) = if	  x == y then cmpString xs ys
 cmpString []     ys	= LT_
 cmpString xs     []	= GT_
 
-cmpString _ _ = case (panic "cmpString") of { s -> -- BUG avoidance: never get here
-		cmpString s "" -- will never get here
-		}
+cmpString _ _ = panic# "cmpString"
 \end{code}
 
 \begin{code}
@@ -1028,7 +785,7 @@ applyToSnd f (x,y) = (x,f y)
 foldPair :: (a->a->a,b->b->b) -> (a,b) -> [(a,b)] -> (a,b)
 foldPair fg ab [] = ab
 foldPair fg@(f,g) ab ((a,b):abs) = (f a u,g b v)
-                       where (u,v) = foldPair fg ab abs
+		       where (u,v) = foldPair fg ab abs
 \end{code}
 
 \begin{code}
@@ -1050,9 +807,17 @@ panic x = error ("panic! (the `impossible' happened):\n\t"
 	      ++ "to glasgow-haskell-bugs@dcs.glasgow.ac.uk.\n\n" )
 
 pprPanic heading pretty_msg = panic (heading++(ppShow 80 pretty_msg))
-
 pprTrace heading pretty_msg = trace (heading++(ppShow 80 pretty_msg))
 
+-- #-versions because panic can't return an unboxed int, and that's
+-- what TAG_ is with GHC at the moment.  Ugh. (Simon)
+-- No, man -- Too Beautiful! (Will)
+
+panic# :: String -> TAG_
+panic# s = case (panic s) of () -> EQ_
+
+pprPanic# heading pretty_msg = panic# (heading++(ppShow 80 pretty_msg))
+
 # ifdef DEBUG
 assertPanic :: String -> Int -> a
 assertPanic file line = panic ("ASSERT failed! file "++file++", line "++show line)
-- 
cgit v1.2.1