Merge remote branch 'origin/master' into monad-comp

Conflicts:
	compiler/main/HscMain.lhs

47 files changed, 726 insertions, 571 deletions

diff --git a/compiler/Makefile.local b/compiler/Makefile.local
deleted file mode 100644
index 1d5345114b..0000000000
--- a/compiler/Makefile.local
+++ /dev/null
@@ -1,75 +0,0 @@
-# Local GHC-build-tree customization for Cabal makefiles.  We want to build
-# libraries using flags that the user has put in build.mk/validate.mk and
-# appropriate flags for Mac OS X deployment targets.
-
-# Careful here: including boilerplate.mk breaks things, because paths.mk and
-# opts.mk overrides some of the variable settings in the Cabal Makefile, so
-# we just include config.mk and custom-settings.mk.
-TOP=..
-SAVE_GHC := $(GHC)
-SAVE_AR  := $(AR)
-SAVE_LD  := $(LD)
-include $(TOP)/mk/config.mk
-include $(TOP)/mk/custom-settings.mk
-GHC := $(SAVE_GHC)
-AR  := $(SAVE_AR)
-LD  := $(SAVE_LD)
-
-# Now add flags from the GHC build system to the Cabal build:
-GHC_CC_OPTS += $(addprefix -optc, $(MACOSX_DEPLOYMENT_CC_OPTS))
-GHC_OPTS    += $(SRC_HC_OPTS)
-GHC_OPTS    += $(GhcHcOpts)
-GHC_OPTS    += $(GhcStage$(stage)HcOpts)
-GHC_OPTS    += $(addprefix -optc, $(MACOSX_DEPLOYMENT_CC_OPTS))
-LIB_LD_OPTS += $(addprefix -optl, $(MACOSX_DEPLOYMENT_LD_OPTS))
-
-# XXX These didn't work in the old build system, according to the
-# comment at least. We should actually handle them properly at some
-# point:
-
-# Some .hs files #include other source files, but since ghc -M doesn't spit out
-# these dependencies we have to include them manually.
-
-# We don't add dependencies on HsVersions.h, ghcautoconf.h, or ghc_boot_platform.h,
-# because then modifying one of these files would force recompilation of everything,
-# which is probably not what you want.  However, it does mean you have to be
-# careful to recompile stuff you need if you reconfigure or change HsVersions.h.
-
-# Aargh, these don't work properly anyway, because GHC's recompilation checker
-# just reports "compilation NOT required".  Do we have to add -fforce-recomp for each
-# of these .hs files?  I haven't done anything about this yet.
-
-# $(odir)/codeGen/Bitmap.$(way_)o     :  ../includes/MachDeps.h
-# $(odir)/codeGen/CgCallConv.$(way_)o :  ../includes/StgFun.h
-# $(odir)/codeGen/CgProf.$(way_)o     :  ../includes/MachDeps.h
-# $(odir)/codeGen/CgProf.$(way_)o     :  ../includes/Constants.h
-# $(odir)/codeGen/CgProf.$(way_)o     :  ../includes/DerivedConstants.h
-# $(odir)/codeGen/CgTicky.$(way_)o    :  ../includes/DerivedConstants.h
-# $(odir)/codeGen/ClosureInfo.$(way_)o    :  ../includes/MachDeps.h
-# $(odir)/codeGen/SMRep.$(way_)o      :  ../includes/MachDeps.h
-# $(odir)/codeGen/SMRep.$(way_)o      :  ../includes/ClosureTypes.h
-# $(odir)/ghci/ByteCodeAsm.$(way_)o   :  ../includes/Bytecodes.h
-# $(odir)/ghci/ByteCodeFFI.$(way_)o   :  nativeGen/NCG.h
-# $(odir)/ghci/ByteCodeInstr.$(way_)o :  ../includes/MachDeps.h
-# $(odir)/ghci/ByteCodeItbls.$(way_)o :  ../includes/ClosureTypes.h
-# $(odir)/ghci/ByteCodeItbls.$(way_)o :  nativeGen/NCG.h
-# $(odir)/main/Constants.$(way_)o     :  ../includes/MachRegs.h
-# $(odir)/main/Constants.$(way_)o     :  ../includes/Constants.h
-# $(odir)/main/Constants.$(way_)o     :  ../includes/MachDeps.h
-# $(odir)/main/Constants.$(way_)o     :  ../includes/DerivedConstants.h
-# $(odir)/main/Constants.$(way_)o     :  ../includes/GHCConstants.h
-# $(odir)/nativeGen/AsmCodeGen.$(way_)o   :  nativeGen/NCG.h
-# $(odir)/nativeGen/MachCodeGen.$(way_)o  :  nativeGen/NCG.h
-# $(odir)/nativeGen/MachCodeGen.$(way_)o  : ../includes/MachDeps.h
-# $(odir)/nativeGen/MachInstrs.$(way_)o   :  nativeGen/NCG.h
-# $(odir)/nativeGen/MachRegs.$(way_)o :  nativeGen/NCG.h
-# $(odir)/nativeGen/MachRegs.$(way_)o :  ../includes/MachRegs.h
-# $(odir)/nativeGen/PositionIndependentCode.$(way_)o :  nativeGen/NCG.h
-# $(odir)/nativeGen/PprMach.$(way_)o  :  nativeGen/NCG.h
-# $(odir)/nativeGen/RegAllocInfo.$(way_)o :  nativeGen/NCG.h
-# $(odir)/typecheck/TcForeign.$(way_)o    :  nativeGen/NCG.h
-# $(odir)/utils/Binary.$(way_)o       :  ../includes/MachDeps.h
-# $(odir)/utils/FastMutInt.$(way_)o   :  ../includes/MachDeps.h
-# $(PRIMOP_BITS) is defined in Makefile
-# $(odir)/prelude/PrimOp.o: $(PRIMOP_BITS)
-
diff --git a/compiler/basicTypes/Module.lhs b/compiler/basicTypes/Module.lhs
index c4bdba209c..03f541e505 100644
--- a/compiler/basicTypes/Module.lhs
+++ b/compiler/basicTypes/Module.lhs
@@ -155,6 +155,7 @@ addBootSuffixLocn locn
 \begin{code}
 -- | A ModuleName is essentially a simple string, e.g. @Data.List@.
 newtype ModuleName = ModuleName FastString
+    deriving Typeable
 
 instance Uniquable ModuleName where
   getUnique (ModuleName nm) = getUnique nm
@@ -175,8 +176,6 @@ instance Binary ModuleName where
   put_ bh (ModuleName fs) = put_ bh fs
   get bh = do fs <- get bh; return (ModuleName fs)
 
-INSTANCE_TYPEABLE0(ModuleName,moduleNameTc,"ModuleName")
-
 instance Data ModuleName where
   -- don't traverse?
   toConstr _   = abstractConstr "ModuleName"
@@ -224,7 +223,7 @@ data Module = Module {
    modulePackageId :: !PackageId,  -- pkg-1.0
    moduleName      :: !ModuleName  -- A.B.C
   }
-  deriving (Eq, Ord)
+  deriving (Eq, Ord, Typeable)
 
 instance Uniquable Module where
   getUnique (Module p n) = getUnique (packageIdFS p `appendFS` moduleNameFS n)
@@ -236,8 +235,6 @@ instance Binary Module where
   put_ bh (Module p n) = put_ bh p >> put_ bh n
   get bh = do p <- get bh; n <- get bh; return (Module p n)
 
-INSTANCE_TYPEABLE0(Module,moduleTc,"Module")
-
 instance Data Module where
   -- don't traverse?
   toConstr _   = abstractConstr "Module"
@@ -280,7 +277,7 @@ pprPackagePrefix p mod = getPprStyle doc
 
 \begin{code}
 -- | Essentially just a string identifying a package, including the version: e.g. parsec-1.0
-newtype PackageId = PId FastString deriving( Eq )
+newtype PackageId = PId FastString deriving( Eq, Typeable )
     -- here to avoid module loops with PackageConfig
 
 instance Uniquable PackageId where
@@ -291,8 +288,6 @@ instance Uniquable PackageId where
 instance Ord PackageId where
   nm1 `compare` nm2 = getUnique nm1 `compare` getUnique nm2
 
-INSTANCE_TYPEABLE0(PackageId,packageIdTc,"PackageId")
-
 instance Data PackageId where
   -- don't traverse?
   toConstr _   = abstractConstr "PackageId"
diff --git a/compiler/basicTypes/Name.lhs b/compiler/basicTypes/Name.lhs
index 70cf298a4f..f2ae963891 100644
--- a/compiler/basicTypes/Name.lhs
+++ b/compiler/basicTypes/Name.lhs
@@ -106,6 +106,7 @@ data Name = Name {
 --(note later when changing Int# -> FastInt: is that still true about UNPACK?)
 		n_loc  :: !SrcSpan	-- Definition site
 	    }
+    deriving Typeable
 
 -- NOTE: we make the n_loc field strict to eliminate some potential
 -- (and real!) space leaks, due to the fact that we don't look at
@@ -363,8 +364,6 @@ instance Uniquable Name where
 instance NamedThing Name where
     getName n = n
 
-INSTANCE_TYPEABLE0(Name,nameTc,"Name")
-
 instance Data Name where
   -- don't traverse?
   toConstr _   = abstractConstr "Name"
diff --git a/compiler/basicTypes/NameSet.lhs b/compiler/basicTypes/NameSet.lhs
index e2acaf7109..bef9e928fd 100644
--- a/compiler/basicTypes/NameSet.lhs
+++ b/compiler/basicTypes/NameSet.lhs
@@ -48,7 +48,12 @@ import Data.Data
 \begin{code}
 type NameSet = UniqSet Name
 
-INSTANCE_TYPEABLE0(NameSet,nameSetTc,"NameSet")
+-- TODO: These Data/Typeable instances look very dubious. Surely either
+-- UniqFM should have the instances, or this should be a newtype?
+
+nameSetTc :: TyCon
+nameSetTc = mkTyCon "NameSet"
+instance Typeable NameSet where { typeOf _ = mkTyConApp nameSetTc [] }
 
 instance Data NameSet where
   gfoldl k z s = z mkNameSet `k` nameSetToList s -- traverse abstractly
@@ -176,7 +181,7 @@ duDefs dus = foldr get emptyNameSet dus
     get (Just d1, _u1) d2 = d1 `unionNameSets` d2
 
 allUses :: DefUses -> Uses
--- ^ Just like 'allUses', but 'Defs' are not eliminated from the 'Uses' returned
+-- ^ Just like 'duUses', but 'Defs' are not eliminated from the 'Uses' returned
 allUses dus = foldr get emptyNameSet dus
   where
     get (_d1, u1) u2 = u1 `unionNameSets` u2
@@ -184,8 +189,7 @@ allUses dus = foldr get emptyNameSet dus
 duUses :: DefUses -> Uses
 -- ^ Collect all 'Uses', regardless of whether the group is itself used,
 -- but remove 'Defs' on the way
-duUses dus
-  = foldr get emptyNameSet dus
+duUses dus = foldr get emptyNameSet dus
   where
     get (Nothing,   rhs_uses) uses = rhs_uses `unionNameSets` uses
     get (Just defs, rhs_uses) uses = (rhs_uses `unionNameSets` uses)
diff --git a/compiler/basicTypes/OccName.lhs b/compiler/basicTypes/OccName.lhs
index f02ae8d0da..5489ea7e26 100644
--- a/compiler/basicTypes/OccName.lhs
+++ b/compiler/basicTypes/OccName.lhs
@@ -209,6 +209,7 @@ data OccName = OccName
     { occNameSpace  :: !NameSpace
     , occNameFS     :: !FastString
     }
+    deriving Typeable
 \end{code}
 
 
@@ -221,8 +222,6 @@ instance Ord OccName where
     compare (OccName sp1 s1) (OccName sp2 s2) 
 	= (s1  `compare` s2) `thenCmp` (sp1 `compare` sp2)
 
-INSTANCE_TYPEABLE0(OccName,occNameTc,"OccName")
-
 instance Data OccName where
   -- don't traverse?
   toConstr _   = abstractConstr "OccName"
diff --git a/compiler/basicTypes/SrcLoc.lhs b/compiler/basicTypes/SrcLoc.lhs
index 5dcdabe605..d2cbd7f07c 100644
--- a/compiler/basicTypes/SrcLoc.lhs
+++ b/compiler/basicTypes/SrcLoc.lhs
@@ -185,8 +185,6 @@ instance Outputable SrcLoc where
 
     ppr (UnhelpfulLoc s)  = ftext s
 
-INSTANCE_TYPEABLE0(SrcSpan,srcSpanTc,"SrcSpan")
-
 instance Data SrcSpan where
   -- don't traverse?
   toConstr _   = abstractConstr "SrcSpan"
@@ -237,10 +235,10 @@ data SrcSpan
 				-- also used to indicate an empty span
 
 #ifdef DEBUG
-  deriving (Eq, Show)	-- Show is used by Lexer.x, becuase we
-			-- derive Show for Token
+  deriving (Eq, Typeable, Show) -- Show is used by Lexer.x, becuase we
+                                -- derive Show for Token
 #else
-  deriving Eq
+  deriving (Eq, Typeable)
 #endif
 
 -- | Built-in "bad" 'SrcSpan's for common sources of location uncertainty
diff --git a/compiler/basicTypes/Var.lhs b/compiler/basicTypes/Var.lhs
index ec83494bb2..bca185f7e6 100644
--- a/compiler/basicTypes/Var.lhs
+++ b/compiler/basicTypes/Var.lhs
@@ -155,6 +155,7 @@ data Var
 	idScope    :: IdScope,
 	id_details :: IdDetails,	-- Stable, doesn't change
 	id_info    :: IdInfo }		-- Unstable, updated by simplifier
+    deriving Typeable
 
 data IdScope	-- See Note [GlobalId/LocalId]
   = GlobalId 
@@ -216,8 +217,6 @@ instance Ord Var where
     a >	 b = realUnique a >#  realUnique b
     a `compare` b = varUnique a `compare` varUnique b
 
-INSTANCE_TYPEABLE0(Var,varTc,"Var")
-
 instance Data Var where
   -- don't traverse?
   toConstr _   = abstractConstr "Var"
diff --git a/compiler/cmm/CmmCPS.hs b/compiler/cmm/CmmCPS.hs
index b9f6db3982..aad00371a1 100644
--- a/compiler/cmm/CmmCPS.hs
+++ b/compiler/cmm/CmmCPS.hs
@@ -112,12 +112,13 @@ cpsTop hsc_env (CmmProc h@(TopInfo {stack_info=StackInfo {arg_space=entry_off}})
 
        --------------- Stack layout ----------------
        slotEnv <- run $ liveSlotAnal g
+       let spEntryMap = getSpEntryMap entry_off g
        mbpprTrace "live slot analysis results: " (ppr slotEnv) $ return ()
-       let areaMap = layout procPoints slotEnv entry_off g
+       let areaMap = layout procPoints spEntryMap slotEnv entry_off g
        mbpprTrace "areaMap" (ppr areaMap) $ return ()
 
        ------------  Manifest the stack pointer --------
-       g  <- run $ manifestSP areaMap entry_off g
+       g  <- run $ manifestSP spEntryMap areaMap entry_off g
        dump Opt_D_dump_cmmz "after manifestSP" g
        -- UGH... manifestSP can require updates to the procPointMap.
        -- We can probably do something quicker here for the update...
diff --git a/compiler/cmm/CmmLint.hs b/compiler/cmm/CmmLint.hs
index c14ad65788..32fead337e 100644
--- a/compiler/cmm/CmmLint.hs
+++ b/compiler/cmm/CmmLint.hs
@@ -153,6 +153,7 @@ lintTarget (CmmPrim {})    = return ()
 
 checkCond :: CmmExpr -> CmmLint ()
 checkCond (CmmMachOp mop _) | isComparisonMachOp mop = return ()
+checkCond (CmmLit (CmmInt x t)) | x == 0 || x == 1, t == wordWidth = return () -- constant values
 checkCond expr = cmmLintErr (hang (text "expression is not a conditional:") 2
 				    (ppr expr))
 
diff --git a/compiler/cmm/CmmParse.y b/compiler/cmm/CmmParse.y
index 8c2498e5f8..4dc7e3214f 100644
--- a/compiler/cmm/CmmParse.y
+++ b/compiler/cmm/CmmParse.y
@@ -396,13 +396,15 @@ stmt	:: { ExtCode }
 	| NAME '(' exprs0 ')' ';'
 		{% stmtMacro $1 $3  }
 	| 'switch' maybe_range expr '{' arms default '}'
-		{ doSwitch $2 $3 $5 $6 }
+		{ do as <- sequence $5; doSwitch $2 $3 as $6 }
 	| 'goto' NAME ';'
 		{ do l <- lookupLabel $2; stmtEC (CmmBranch l) }
 	| 'jump' expr maybe_actuals ';'
 		{ do e1 <- $2; e2 <- sequence $3; stmtEC (CmmJump e1 e2) }
         | 'return' maybe_actuals ';'
 		{ do e <- sequence $2; stmtEC (CmmReturn e) }
+	| 'if' bool_expr 'goto' NAME
+		{ do l <- lookupLabel $4; cmmRawIf $2 l }
 	| 'if' bool_expr '{' body '}' else 	
 		{ cmmIfThenElse $2 $4 $6 }
 
@@ -441,12 +443,16 @@ maybe_range :: { Maybe (Int,Int) }
 	: '[' INT '..' INT ']'	{ Just (fromIntegral $2, fromIntegral $4) }
 	| {- empty -}		{ Nothing }
 
-arms	:: { [([Int],ExtCode)] }
+arms	:: { [ExtFCode ([Int],Either BlockId ExtCode)] }
 	: {- empty -}			{ [] }
 	| arm arms			{ $1 : $2 }
 
-arm	:: { ([Int],ExtCode) }
-	: 'case' ints ':' '{' body '}'	{ ($2, $5) }
+arm	:: { ExtFCode ([Int],Either BlockId ExtCode) }
+	: 'case' ints ':' arm_body	{ do b <- $4; return ($2, b) }
+
+arm_body :: { ExtFCode (Either BlockId ExtCode) }
+	: '{' body '}'			{ return (Right $2) }
+	| 'goto' NAME ';'		{ do l <- lookupLabel $2; return (Left l) }
 
 ints	:: { [Int] }
 	: INT				{ [ fromIntegral $1 ] }
@@ -458,6 +464,8 @@ default :: { Maybe ExtCode }
 	-- 'default' branches
 	| {- empty -}			{ Nothing }
 
+-- Note: OldCmm doesn't support a first class 'else' statement, though
+-- CmmNode does.
 else 	:: { ExtCode }
 	: {- empty -}			{ nopEC }
 	| 'else' '{' body '}'		{ $3 }
@@ -952,6 +960,10 @@ cmmIfThenElse cond then_part else_part = do
      -- fall through to join
      code (labelC join_id)
 
+cmmRawIf cond then_id = do
+    c <- cond
+    emitCond c then_id
+
 -- 'emitCond cond true_id'  emits code to test whether the cond is true,
 -- branching to true_id if so, and falling through otherwise.
 emitCond (BoolTest e) then_id = do
@@ -991,7 +1003,7 @@ emitCond (e1 `BoolAnd` e2) then_id = do
 -- optional range on the switch (eg. switch [0..7] {...}), or by
 -- the minimum/maximum values from the branches.
 
-doSwitch :: Maybe (Int,Int) -> ExtFCode CmmExpr -> [([Int],ExtCode)]
+doSwitch :: Maybe (Int,Int) -> ExtFCode CmmExpr -> [([Int],Either BlockId ExtCode)]
          -> Maybe ExtCode -> ExtCode
 doSwitch mb_range scrut arms deflt
    = do 
@@ -1018,12 +1030,12 @@ doSwitch mb_range scrut arms deflt
 	-- ToDo: check for out of range and jump to default if necessary
         stmtEC (CmmSwitch expr entries)
    where
-	emitArm :: ([Int],ExtCode) -> ExtFCode [(Int,BlockId)]
-	emitArm (ints,code) = do
+	emitArm :: ([Int],Either BlockId ExtCode) -> ExtFCode [(Int,BlockId)]
+	emitArm (ints,Left blockid) = return [ (i,blockid) | i <- ints ]
+	emitArm (ints,Right code) = do
 	   blockid <- forkLabelledCodeEC code
 	   return [ (i,blockid) | i <- ints ]
 
-
 -- -----------------------------------------------------------------------------
 -- Putting it all together
 
diff --git a/compiler/cmm/CmmProcPoint.hs b/compiler/cmm/CmmProcPoint.hs
index d0d54d909d..fbe979b9ab 100644
--- a/compiler/cmm/CmmProcPoint.hs
+++ b/compiler/cmm/CmmProcPoint.hs
@@ -378,6 +378,8 @@ add_CopyOuts protos procPoints g = foldGraphBlocks mb_copy_out (return mapEmpty)
 -- 4. build info tables for the procedures -- and update the info table for
 --    the SRTs in the entry procedure as well.
 -- Input invariant: A block should only be reachable from a single ProcPoint.
+-- ToDo: use the _ret naming convention that the old code generator
+-- used. -- EZY
 splitAtProcPoints :: CLabel -> ProcPointSet-> ProcPointSet -> BlockEnv Status ->
                      CmmTop -> FuelUniqSM [CmmTop]
 splitAtProcPoints entry_label callPPs procPoints procMap
diff --git a/compiler/cmm/CmmStackLayout.hs b/compiler/cmm/CmmStackLayout.hs
index 01543c444e..c0fb6af037 100644
--- a/compiler/cmm/CmmStackLayout.hs
+++ b/compiler/cmm/CmmStackLayout.hs
@@ -13,7 +13,7 @@
 
 module CmmStackLayout
     ( SlotEnv, liveSlotAnal, liveSlotTransfers, removeLiveSlotDefs
-    , layout, manifestSP, igraph, areaBuilder
+    , getSpEntryMap, layout, manifestSP, igraph, areaBuilder
     , stubSlotsOnDeath ) -- to help crash early during debugging
 where
 
@@ -195,7 +195,7 @@ liveLastOut env l =
 type Set x = Map x ()
 data IGraphBuilder n =
   Builder { foldNodes     :: forall z. SubArea -> (n -> z -> z) -> z -> z
-          , _wordsOccupied :: AreaMap -> AreaMap -> n -> [Int]
+          , _wordsOccupied :: AreaSizeMap -> AreaMap -> n -> [Int]
           }
 
 areaBuilder :: IGraphBuilder Area
@@ -242,10 +242,13 @@ igraph builder env g = foldr interfere Map.empty (postorderDfs g)
 -- what's the highest offset (in bytes) used in each Area?
 -- We'll need to allocate that much space for each Area.
 
+-- Mapping of areas to area sizes (not offsets!)
+type AreaSizeMap = AreaMap
+
 -- JD: WHY CAN'T THIS COME FROM THE slot-liveness info?
-getAreaSize :: ByteOff -> CmmGraph -> AreaMap
+getAreaSize :: ByteOff -> CmmGraph -> AreaSizeMap
   -- The domain of the returned mapping consists only of Areas
-  -- used for (a) variable spill slots, and (b) parameter passing ares for calls
+  -- used for (a) variable spill slots, and (b) parameter passing areas for calls
 getAreaSize entry_off g =
   foldGraphBlocks (foldBlockNodesF3 (first, add_regslots, last))
               (Map.singleton (CallArea Old) entry_off) g
@@ -266,10 +269,11 @@ getAreaSize entry_off g =
 	-- The 'max' is important.  Two calls, to f and g, might share a common
 	-- continuation (and hence a common CallArea), but their number of overflow
 	-- parameters might differ.
+        -- EZY: Ought to use insert with combining function...
 
 
 -- Find the Stack slots occupied by the subarea's conflicts
-conflictSlots :: Ord x => IGPair x -> AreaMap -> AreaMap -> SubArea -> Set Int
+conflictSlots :: Ord x => IGPair x -> AreaSizeMap -> AreaMap -> SubArea -> Set Int
 conflictSlots (ig, Builder foldNodes wordsOccupied) areaSize areaMap subarea =
   foldNodes subarea foldNode Map.empty
   where foldNode n set = Map.foldRightWithKey conflict set $ Map.findWithDefault Map.empty n ig
@@ -278,10 +282,10 @@ conflictSlots (ig, Builder foldNodes wordsOccupied) areaSize areaMap subarea =
         liveInSlots areaMap n set = foldr setAdd set (wordsOccupied areaSize areaMap n)
         setAdd w s = Map.insert w () s
 
--- Find any open space on the stack, starting from the offset.
--- If the area is a CallArea or a spill slot for a pointer, then it must
--- be word-aligned.
-freeSlotFrom :: Ord x => IGPair x -> AreaMap -> Int -> AreaMap -> Area -> Int
+-- Find any open space for 'area' on the stack, starting from the
+-- 'offset'.  If the area is a CallArea or a spill slot for a pointer,
+-- then it must be word-aligned.
+freeSlotFrom :: Ord x => IGPair x -> AreaSizeMap -> Int -> AreaMap -> Area -> Int
 freeSlotFrom ig areaSize offset areaMap area =
   let size = Map.lookup area areaSize `orElse` 0
       conflicts = conflictSlots ig areaSize areaMap (area, size, size)
@@ -299,11 +303,24 @@ freeSlotFrom ig areaSize offset areaMap area =
   in findSpace (align (offset + size)) size
 
 -- Find an open space on the stack, and assign it to the area.
-allocSlotFrom :: Ord x => IGPair x -> AreaMap -> Int -> AreaMap -> Area -> AreaMap
+allocSlotFrom :: Ord x => IGPair x -> AreaSizeMap -> Int -> AreaMap -> Area -> AreaMap
 allocSlotFrom ig areaSize from areaMap area =
   if Map.member area areaMap then areaMap
   else Map.insert area (freeSlotFrom ig areaSize from areaMap area) areaMap
 
+-- Figure out all of the offsets from the slot location; this will be
+-- non-zero for procpoints.
+type SpEntryMap = BlockEnv Int
+getSpEntryMap :: Int -> CmmGraph -> SpEntryMap
+getSpEntryMap entry_off g@(CmmGraph {g_entry = entry})
+    = foldGraphBlocks add_sp_off (mapInsert entry entry_off emptyBlockMap) g
+  where add_sp_off :: CmmBlock -> BlockEnv Int -> BlockEnv Int
+        add_sp_off b env =
+          case lastNode b of
+            CmmCall {cml_cont=Just succ, cml_ret_args=off} -> mapInsert succ off env
+            CmmForeignCall {succ=succ}                     -> mapInsert succ wORD_SIZE env
+            _                                              -> env
+
 -- | Greedy stack layout.
 -- Compute liveness, build the interference graph, and allocate slots for the areas.
 -- We visit each basic block in a (generally) forward order.
@@ -326,12 +343,16 @@ allocSlotFrom ig areaSize from areaMap area =
 -- Note: The stack pointer only has to be younger than the youngest live stack slot
 -- at proc points. Otherwise, the stack pointer can point anywhere.
 
-layout :: ProcPointSet -> SlotEnv -> ByteOff -> CmmGraph -> AreaMap
+layout :: ProcPointSet -> SpEntryMap -> SlotEnv -> ByteOff -> CmmGraph -> AreaMap
 -- The domain of the returned map includes an Area for EVERY block
 -- including each block that is not the successor of a call (ie is not a proc-point)
--- That's how we return the info of what the SP should be at the entry of every block
+-- That's how we return the info of what the SP should be at the entry of every non
+-- procpoint block.  However, note that procpoint blocks have their
+-- /slot/ stored, which is not necessarily the value of the SP on entry
+-- to the block (in fact, it probably isn't, due to argument passing).
+-- See [Procpoint Sp offset]
 
-layout procPoints env entry_off g =
+layout procPoints spEntryMap env entry_off g =
   let ig = (igraph areaBuilder env g, areaBuilder)
       env' bid = mapLookup bid env `orElse` panic "unknown blockId in igraph"
       areaSize = getAreaSize entry_off g
@@ -370,21 +391,87 @@ layout procPoints env entry_off g =
       allocMid m areaMap = foldSlotsDefd alloc' (foldSlotsUsed alloc' areaMap m) m
       allocLast bid l areaMap =
         foldr (setSuccSPs inSp) areaMap' (successors l)
-        where inSp = expectJust "sp in" $ Map.lookup (CallArea (Young bid)) areaMap
+        where inSp = slot + spOffset -- [Procpoint Sp offset]
+              -- If it's not in the map, we should use our previous
+              -- calculation unchanged.
+              spOffset = mapLookup bid spEntryMap `orElse` 0
+              slot = expectJust "slot in" $ Map.lookup (CallArea (Young bid)) areaMap
               areaMap' = foldSlotsDefd alloc' (foldSlotsUsed alloc' areaMap l) l
       alloc' areaMap (a@(RegSlot _), _, _) = allocVarSlot areaMap a
       alloc' areaMap _ = areaMap
 
-      initMap = Map.insert (CallArea (Young (g_entry g))) 0 $
-                  Map.insert (CallArea Old) 0 Map.empty
-                        
+      initMap = Map.insert (CallArea (Young (g_entry g))) 0
+              . Map.insert (CallArea Old)                 0
+              $ Map.empty
+
       areaMap = foldl layoutAreas initMap (postorderDfs g)
   in -- pprTrace "ProcPoints" (ppr procPoints) $
-        -- pprTrace "Area SizeMap" (ppr areaSize) $
-         -- pprTrace "Entry SP" (ppr entrySp) $
-           -- pprTrace "Area Map" (ppr areaMap) $
+     -- pprTrace "Area SizeMap" (ppr areaSize) $
+     -- pprTrace "Entry offset" (ppr entry_off) $
+     -- pprTrace "Area Map" (ppr areaMap) $
      areaMap
 
+{- Note [Procpoint Sp offset]
+
+The calculation of inSp is a little tricky.  (Un)fortunately, if you get
+it wrong, you will get inefficient but correct code.  You know you've
+got it wrong if the generated stack pointer bounces up and down for no
+good reason.
+
+Why can't we just set inSp to the location of the slot?  (This is what
+the code used to do.)  The trouble is when we actually hit the proc
+point the start of the slot will not be the same as the actual Sp due
+to argument passing:
+
+  a:
+      I32[(young<b> + 4)] = cde;
+      // Stack pointer is moved to young end (bottom) of young<b> for call
+      // +-------+
+      // | arg 1 |
+      // +-------+ <- Sp
+      call (I32[foobar::I32])(...) returns to Just b (4) (4) with update frame 4;
+  b:
+      // After call, stack pointer is above the old end (top) of
+      // young<b> (the difference is spOffset)
+      // +-------+ <- Sp
+      // | arg 1 |
+      // +-------+
+
+If we blithely set the Sp to be the same as the slot (the young end of
+young<b>), an adjustment will be necessary when we go to the next block.
+This is wasteful.  So, instead, for the next block after a procpoint,
+the actual Sp should be set to the same as the true Sp when we just
+entered the procpoint.  Then manifestSP will automatically do the right
+thing.
+
+Questions you may ask:
+
+1. Why don't we need to change the mapping for the procpoint itself?
+   Because manifestSP does its own calculation of the true stack value,
+   manifestSP will notice the discrepancy between the actual stack
+   pointer and the slot start, and adjust all of its memory accesses
+   accordingly.  So the only problem is when we adjust the Sp in
+   preparation for the successor block; that's why this code is here and
+   not in setSuccSPs.
+
+2. Why don't we make the procpoint call area and the true offset match
+   up?  If we did that, we would never use memory above the true value
+   of the stack pointer, thus wasting all of the stack we used to store
+   arguments.  You might think that some clever changes to the slot
+   offsets, using negative offsets, might fix it, but this does not make
+   semantic sense.
+
+3. If manifestSP is already calculating the true stack value, why we can't
+   do this trick inside manifestSP itself?  The reason is that if two
+   branches join with inconsistent SPs, one of them has to be fixed: we
+   can't know what the fix should be without already knowing what the
+   chosen location of SP is on the next successor.  (This is
+   the "succ already knows incoming SP" case), This calculation cannot
+   be easily done in manifestSP, since it processes the nodes
+   /backwards/.  So we need to have figured this out before we hit
+   manifestSP.
+-}
+
 -- After determining the stack layout, we can:
 -- 1. Replace references to stack Areas with addresses relative to the stack
 --    pointer.
@@ -394,8 +481,8 @@ layout procPoints env entry_off g =
 --    stack pointer to be younger than the live values on the stack at proc points.
 -- 3. Compute the maximum stack offset used in the procedure and replace
 --    the stack high-water mark with that offset.
-manifestSP :: AreaMap -> ByteOff -> CmmGraph -> FuelUniqSM CmmGraph
-manifestSP areaMap entry_off g@(CmmGraph {g_entry=entry}) =
+manifestSP :: SpEntryMap -> AreaMap -> ByteOff -> CmmGraph -> FuelUniqSM CmmGraph
+manifestSP spEntryMap areaMap entry_off g@(CmmGraph {g_entry=entry}) =
   ofBlockMap entry `liftM` foldl replB (return mapEmpty) (postorderDfs g)
   where slot a = -- pprTrace "slot" (ppr a) $
                    Map.lookup a areaMap `orElse` panic "unallocated Area"
@@ -404,13 +491,6 @@ manifestSP areaMap entry_off g@(CmmGraph {g_entry=entry}) =
         sp_high = maxSlot slot g
         proc_entry_sp = slot (CallArea Old) + entry_off
 
-        add_sp_off :: CmmBlock -> BlockEnv Int -> BlockEnv Int
-        add_sp_off b env =
-          case lastNode b of
-            CmmCall {cml_cont=Just succ, cml_ret_args=off} -> mapInsert succ off env
-            CmmForeignCall {succ=succ}                     -> mapInsert succ wORD_SIZE env
-            _                                              -> env
-        spEntryMap = foldGraphBlocks add_sp_off (mapInsert entry entry_off emptyBlockMap) g
         spOffset id = mapLookup id spEntryMap `orElse` 0
 
         sp_on_entry id | id == entry = proc_entry_sp
@@ -427,10 +507,26 @@ manifestSP areaMap entry_off g@(CmmGraph {g_entry=entry}) =
           where spIn = sp_on_entry (entryLabel block)
 
                 middle spOff m = mapExpDeep (replSlot spOff) m
+                -- XXX there shouldn't be any global registers in the
+                -- CmmCall, so there shouldn't be any slots in
+                -- CmmCall... check that...
                 last   spOff l = mapExpDeep (replSlot spOff) l
                 replSlot spOff (CmmStackSlot a i) = CmmRegOff (CmmGlobal Sp) (spOff - (slot a + i))
                 replSlot _ (CmmLit CmmHighStackMark) = -- replacing the high water mark
                   CmmLit (CmmInt (toInteger (max 0 (sp_high - proc_entry_sp))) (typeWidth bWord))
+                -- Invariant: Sp is always greater than SpLim.  Thus, if
+                -- the high water mark is zero, we can optimize away the
+                -- conditional branch.  Relies on dead code elimination
+                -- to get rid of the dead GC blocks.
+                -- EZY: Maybe turn this into a guard that checks if a
+                -- statement is stack-check ish?  Maybe we should make
+                -- an actual mach-op for it, so there's no chance of
+                -- mixing this up with something else...
+                replSlot _ (CmmMachOp (MO_U_Lt _)
+                              [CmmMachOp (MO_Sub _)
+                                         [ CmmReg (CmmGlobal Sp)
+                                         , CmmLit (CmmInt 0 _)],
+                               CmmReg (CmmGlobal SpLim)]) = CmmLit (CmmInt 0 wordWidth)
                 replSlot _ e = e
 
                 replLast :: MaybeC C (CmmNode C O) -> [CmmNode O O] -> CmmNode O C -> FuelUniqSM [CmmBlock]
diff --git a/compiler/cmm/cmm-notes b/compiler/cmm/cmm-notes
index 0852711f96..e787f18b17 100644
--- a/compiler/cmm/cmm-notes
+++ b/compiler/cmm/cmm-notes
@@ -15,14 +15,11 @@ Things to do:
 	This will fix the spill before stack check problem but only really as a side

 	effect. A 'real fix' probably requires making the spiller know about sp checks.

 

- - There is some silly stuff happening with the Sp. We end up with code like:

-   Sp = Sp + 8; R1 = _vwf::I64; Sp = Sp -8

-	Seems to be perhaps caused by the issue above but also maybe a optimisation

-	pass needed?

+   EZY: I don't understand this comment. David Terei, can you clarify?

 

- - Proc pass all arguments on the stack, adding more code and slowing down things

-   a lot. We either need to fix this or even better would be to get rid of

-	proc points.

+ - Proc points pass all arguments on the stack, adding more code and

+   slowing down things a lot. We either need to fix this or even better

+   would be to get rid of proc points.

 

  - CmmInfo.cmmToRawCmm uses Old.Cmm, so it is called after converting Cmm.Cmm to

    Old.Cmm. We should abstract it to work on both representations, it needs only to

@@ -32,7 +29,7 @@ Things to do:
    we could convert codeGen/StgCmm* clients to the Hoopl's semantics?

    It's all deeply unsatisfactory.

 

- - Improve preformance of Hoopl.

+ - Improve performance of Hoopl.

 

    A nofib comparison of -fasm vs -fnewcodegen nofib compilation parameters

    (using the same ghc-cmm branch +libraries compiled by the old codegenerator)

@@ -50,6 +47,9 @@ Things to do:
 

    So we generate a bit better code, but it takes us longer!

 

+   EZY: Also importantly, Hoopl uses dramatically more memory than the

+   old code generator.

+

  - Are all blockToNodeList and blockOfNodeList really needed? Maybe we could

    splice blocks instead?

 

@@ -57,7 +57,7 @@ Things to do:
    a block catenation function would be probably nicer than blockToNodeList

    / blockOfNodeList combo.

 

- - loweSafeForeignCall seems too lowlevel. Just use Dataflow. After that

+ - lowerSafeForeignCall seems too lowlevel. Just use Dataflow. After that

    delete splitEntrySeq from HooplUtils.

 

  - manifestSP seems to touch a lot of the graph representation. It is

@@ -76,6 +76,9 @@ Things to do:
    calling convention, and the code for calling foreign calls is generated

 

  - AsmCodeGen has a generic Cmm optimiser; move this into new pipeline

+   EZY (2011-04-16): The mini-inliner has been generalized and ported,

+   but the constant folding and other optimizations need to still be

+   ported.

 

  - AsmCodeGen has post-native-cg branch eliminator (shortCutBranches);

    we ultimately want to share this with the Cmm branch eliminator.

@@ -113,7 +116,7 @@ Things to do:
  - See "CAFs" below; we want to totally refactor the way SRTs are calculated

 

  - Pull out Areas into its own module

-   Parameterise AreaMap

+   Parameterise AreaMap (note there are type synonyms in CmmStackLayout!)

    Add ByteWidth = Int

    type SubArea    = (Area, ByteOff, ByteWidth) 

    ByteOff should not be defined in SMRep -- that is too high up the hierarchy

@@ -293,8 +296,8 @@ cpsTop:
        insert spills/reloads across 

 	   LastCalls, and 

 	   Branches to proc-points

-     Now sink those reloads:

-     - CmmSpillReload.insertLateReloads

+     Now sink those reloads (and other instructions):

+     - CmmSpillReload.rewriteAssignments

      - CmmSpillReload.removeDeadAssignmentsAndReloads

 

   * CmmStackLayout.stubSlotsOnDeath

@@ -344,7 +347,7 @@ to J that way. This is an awkward choice.  (We think that we currently
 never pass variables to join points via arguments.)

 

 Furthermore, there is *no way* to pass q to J in a register (other

-than a paramter register).

+than a parameter register).

 

 What we want is to do register allocation across the whole caboodle.

 Then we could drop all the code that deals with the above awkward

diff --git a/compiler/ghc.mk b/compiler/ghc.mk
index a7a353d66e..76b393f04b 100644
--- a/compiler/ghc.mk
+++ b/compiler/ghc.mk
@@ -134,8 +134,6 @@ compiler/stage%/build/Config.hs : mk/config.mk mk/project.mk | $$(dir $$@)/.
 	@echo 'cLeadingUnderscore    = "$(LeadingUnderscore)"'              >> $@
 	@echo 'cRAWCPP_FLAGS         :: String'                             >> $@
 	@echo 'cRAWCPP_FLAGS         = "$(RAWCPP_FLAGS)"'                   >> $@
-	@echo 'cGCC                  :: String'                             >> $@
-	@echo 'cGCC                  = "$(WhatGccIsCalled)"'                >> $@
 	@echo 'cMKDLL                :: String'                             >> $@
 	@echo 'cMKDLL                = "$(BLD_DLL)"'                        >> $@
 	@echo 'cLdIsGNULd            :: String'                             >> $@
@@ -162,8 +160,6 @@ compiler/stage%/build/Config.hs : mk/config.mk mk/project.mk | $$(dir $$@)/.
 	@echo 'cGHC_SYSMAN_PGM       = "$(GHC_SYSMAN)"'                     >> $@
 	@echo 'cGHC_SYSMAN_DIR       :: String'                             >> $@
 	@echo 'cGHC_SYSMAN_DIR       = "$(GHC_SYSMAN_DIR)"'                 >> $@
-	@echo 'cGHC_PERL             :: String'                             >> $@
-	@echo 'cGHC_PERL             = "$(GHC_PERL)"'                       >> $@
 	@echo 'cDEFAULT_TMPDIR       :: String'                             >> $@
 	@echo 'cDEFAULT_TMPDIR       = "$(DEFAULT_TMPDIR)"'                 >> $@
 	@echo 'cRelocatableBuild     :: Bool'                               >> $@
diff --git a/compiler/hsSyn/HsDecls.lhs b/compiler/hsSyn/HsDecls.lhs
index 345ec32ef3..53d2949aab 100644
--- a/compiler/hsSyn/HsDecls.lhs
+++ b/compiler/hsSyn/HsDecls.lhs
@@ -3,15 +3,7 @@
 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
 %
 
-
-
 \begin{code}
-{-# OPTIONS -fno-warn-incomplete-patterns #-}
--- The above warning supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and fix
--- any warnings in the module. See
---     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
--- for details
 {-# LANGUAGE DeriveDataTypeable #-}
 
 -- | Abstract syntax of global declarations.
@@ -630,15 +622,15 @@ instance OutputableBndr name
                   (ppr new_or_data <+> 
 		   (if isJust typats then ptext (sLit "instance") else empty) <+>
 		   pp_decl_head (unLoc context) ltycon tyvars typats <+> 
-		   ppr_sig mb_sig)
+		   ppr_sigx mb_sig)
 		  (pp_condecls condecls)
 		  derivings
       where
-	ppr_sig Nothing = empty
-	ppr_sig (Just kind) = dcolon <+> pprKind kind
+	ppr_sigx Nothing     = empty
+	ppr_sigx (Just kind) = dcolon <+> pprKind kind
 
     ppr (ClassDecl {tcdCtxt = context, tcdLName = lclas, tcdTyVars = tyvars, 
-		    tcdFDs = fds, 
+		    tcdFDs  = fds, 
 		    tcdSigs = sigs, tcdMeths = methods, tcdATs = ats})
       | null sigs && null ats  -- No "where" part
       = top_matter
@@ -773,14 +765,14 @@ instance (OutputableBndr name) => Outputable (ConDecl name) where
     ppr = pprConDecl
 
 pprConDecl :: OutputableBndr name => ConDecl name -> SDoc
-pprConDecl (ConDecl { con_name =con, con_explicit = expl, con_qvars = tvs
+pprConDecl (ConDecl { con_name = con, con_explicit = expl, con_qvars = tvs
                     , con_cxt = cxt, con_details = details
                     , con_res = ResTyH98, con_doc = doc })
-  = sep [ppr_mbDoc doc, pprHsForAll expl tvs cxt, ppr_details con details]
+  = sep [ppr_mbDoc doc, pprHsForAll expl tvs cxt, ppr_details details]
   where
-    ppr_details con (InfixCon t1 t2) = hsep [ppr t1, pprHsInfix con, ppr t2]
-    ppr_details con (PrefixCon tys)  = hsep (pprHsVar con : map ppr tys)
-    ppr_details con (RecCon fields)  = ppr con <+> pprConDeclFields fields
+    ppr_details (InfixCon t1 t2) = hsep [ppr t1, pprHsInfix con, ppr t2]
+    ppr_details (PrefixCon tys)  = hsep (pprHsVar con : map ppr tys)
+    ppr_details (RecCon fields)  = ppr con <+> pprConDeclFields fields
 
 pprConDecl (ConDecl { con_name = con, con_explicit = expl, con_qvars = tvs
                     , con_cxt = cxt, con_details = PrefixCon arg_tys
@@ -802,7 +794,7 @@ pprConDecl (ConDecl {con_name = con, con_details = InfixCon {}, con_res = ResTyG
 
 %************************************************************************
 %*									*
-\subsection[InstDecl]{An instance declaration
+\subsection[InstDecl]{An instance declaration}
 %*									*
 %************************************************************************
 
@@ -835,7 +827,7 @@ instDeclATs inst_decls = [at | L _ (InstDecl _ _ _ ats) <- inst_decls, at <- ats
 
 %************************************************************************
 %*									*
-\subsection[DerivDecl]{A stand-alone instance deriving declaration
+\subsection[DerivDecl]{A stand-alone instance deriving declaration}
 %*									*
 %************************************************************************
 
diff --git a/compiler/hsSyn/HsImpExp.lhs b/compiler/hsSyn/HsImpExp.lhs
index dd24aedb2b..501599993c 100644
--- a/compiler/hsSyn/HsImpExp.lhs
+++ b/compiler/hsSyn/HsImpExp.lhs
@@ -6,12 +6,6 @@
 HsImpExp: Abstract syntax: imports, exports, interfaces
 
 \begin{code}
-{-# OPTIONS -fno-warn-incomplete-patterns #-}
--- The above warning supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and fix
--- any warnings in the module. See
---     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
--- for details
 {-# LANGUAGE DeriveDataTypeable #-}
 
 module HsImpExp where
@@ -103,6 +97,7 @@ ieName (IEVar n) 	 = n
 ieName (IEThingAbs  n)   = n
 ieName (IEThingWith n _) = n
 ieName (IEThingAll  n)   = n
+ieName _ = panic "ieName failed pattern match!"
 
 ieNames :: IE a -> [a]
 ieNames (IEVar            n   ) = [n]
@@ -122,8 +117,8 @@ instance (Outputable name) => Outputable (IE name) where
     ppr (IEThingAll	thing)	= hcat [ppr thing, text "(..)"]
     ppr (IEThingWith thing withs)
 	= ppr thing <> parens (fsep (punctuate comma (map pprHsVar withs)))
-    ppr (IEModuleContents mod)
-	= ptext (sLit "module") <+> ppr mod
+    ppr (IEModuleContents mod')
+	= ptext (sLit "module") <+> ppr mod'
     ppr (IEGroup n _)           = text ("<IEGroup: " ++ (show n) ++ ">")
     ppr (IEDoc doc)             = ppr doc
     ppr (IEDocNamed string)     = text ("<IEDocNamed: " ++ string ++ ">")
diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs
index b940cb15a7..c3270062c2 100644
--- a/compiler/iface/MkIface.lhs
+++ b/compiler/iface/MkIface.lhs
@@ -900,8 +900,8 @@ mk_usage_info pit hsc_env this_mod direct_imports used_names
 	finsts_mod   = mi_finsts    iface
         hash_env     = mi_hash_fn   iface
         mod_hash     = mi_mod_hash  iface
-        export_hash | depend_on_exports mod = Just (mi_exp_hash iface)
-    		    | otherwise 	    = Nothing
+        export_hash | depend_on_exports = Just (mi_exp_hash iface)
+    		    | otherwise         = Nothing
     
         used_occs = lookupModuleEnv ent_map mod `orElse` []
 
@@ -918,21 +918,21 @@ mk_usage_info pit hsc_env this_mod direct_imports used_names
                 Nothing -> pprPanic "mkUsage" (ppr mod <+> ppr occ <+> ppr used_names)
                 Just r  -> r
 
-        depend_on_exports mod = 
-           case lookupModuleEnv direct_imports mod of
-    	        Just _ -> True
-                  -- Even if we used 'import M ()', we have to register a
-                  -- usage on the export list because we are sensitive to
-                  -- changes in orphan instances/rules.
-	    	Nothing -> False
-                  -- In GHC 6.8.x the above line read "True", and in
-                  -- fact it recorded a dependency on *all* the
-                  -- modules underneath in the dependency tree.  This
-                  -- happens to make orphans work right, but is too
-                  -- expensive: it'll read too many interface files.
-                  -- The 'isNothing maybe_iface' check above saved us
-                  -- from generating many of these usages (at least in
-                  -- one-shot mode), but that's even more bogus!
+        depend_on_exports = is_direct_import
+        {- True
+              Even if we used 'import M ()', we have to register a
+              usage on the export list because we are sensitive to
+              changes in orphan instances/rules.
+           False
+              In GHC 6.8.x we always returned true, and in
+              fact it recorded a dependency on *all* the
+              modules underneath in the dependency tree.  This
+              happens to make orphans work right, but is too
+              expensive: it'll read too many interface files.
+              The 'isNothing maybe_iface' check above saved us
+              from generating many of these usages (at least in
+              one-shot mode), but that's even more bogus!
+        -}
 \end{code}
 
 \begin{code}
diff --git a/compiler/main/DriverMkDepend.hs b/compiler/main/DriverMkDepend.hs
index e430c6e269..1694aba9b8 100644
--- a/compiler/main/DriverMkDepend.hs
+++ b/compiler/main/DriverMkDepend.hs
@@ -16,7 +16,6 @@ module DriverMkDepend (
 #include "HsVersions.h"
 
 import qualified GHC
--- import GHC              ( ModSummary(..), GhcMonad )
 import GhcMonad
 import HsSyn            ( ImportDecl(..) )
 import DynFlags
@@ -35,7 +34,6 @@ import FastString
 
 import Exception
 import ErrUtils
--- import MonadUtils       ( liftIO )
 
 import System.Directory
 import System.FilePath
diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs
index 9dd9cc7b65..f92a4110b9 100644
--- a/compiler/main/DriverPipeline.hs
+++ b/compiler/main/DriverPipeline.hs
@@ -779,9 +779,9 @@ runPhase (Cpp sf) input_fn dflags0
             src_opts <- io $ getOptionsFromFile dflags0 output_fn
             (dflags2, unhandled_flags, warns)
                 <- io $ parseDynamicNoPackageFlags dflags0 src_opts
+            io $ checkProcessArgsResult unhandled_flags
             unless (dopt Opt_Pp dflags2) $ io $ handleFlagWarnings dflags2 warns
             -- the HsPp pass below will emit warnings
-            io $ checkProcessArgsResult unhandled_flags
 
             setDynFlags dflags2
 
@@ -814,8 +814,8 @@ runPhase (HsPp sf) input_fn dflags
             (dflags1, unhandled_flags, warns)
                 <- io $ parseDynamicNoPackageFlags dflags src_opts
             setDynFlags dflags1
-            io $ handleFlagWarnings dflags1 warns
             io $ checkProcessArgsResult unhandled_flags
+            io $ handleFlagWarnings dflags1 warns
 
             return (Hsc sf, output_fn)
 
@@ -1028,7 +1028,7 @@ runPhase cc_phase input_fn dflags
                               (cmdline_include_paths ++ pkg_include_dirs)
 
         let md_c_flags = machdepCCOpts dflags
-        gcc_extra_viac_flags <- io $ getExtraViaCOpts dflags
+        let gcc_extra_viac_flags = extraGccViaCFlags dflags
         let pic_c_flags = picCCOpts dflags
 
         let verbFlags = getVerbFlags dflags
diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index 0914c32e64..ba862c5430 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -1,6 +1,3 @@
-{-# OPTIONS_GHC -w #-}
--- Temporary, until rtsIsProfiled is fixed
-
 -- |
 -- Dynamic flags
 --
@@ -35,8 +32,17 @@ module DynFlags (
         DPHBackend(..), dphPackageMaybe,
         wayNames,
 
+        Settings(..),
+        ghcUsagePath, ghciUsagePath, topDir, tmpDir, rawSettings,
+        extraGccViaCFlags, systemPackageConfig,
+        pgm_L, pgm_P, pgm_F, pgm_c, pgm_s, pgm_a, pgm_l, pgm_dll, pgm_T,
+        pgm_sysman, pgm_windres, pgm_lo, pgm_lc,
+        opt_L, opt_P, opt_F, opt_c, opt_m, opt_a, opt_l,
+        opt_windres, opt_lo, opt_lc,
+
+
         -- ** Manipulating DynFlags
-        defaultDynFlags,                -- DynFlags
+        defaultDynFlags,                -- Settings -> DynFlags
         initDynFlags,                   -- DynFlags -> IO DynFlags
 
         getOpts,                        -- DynFlags -> (DynFlags -> [a]) -> [a]
@@ -61,7 +67,6 @@ module DynFlags (
         getStgToDo,
 
         -- * Compiler configuration suitable for display to the user
-        Printable(..),
         compilerInfo
 #ifdef GHCI
 -- Only in stage 2 can we be sure that the RTS 
@@ -90,10 +95,14 @@ import Maybes           ( orElse )
 import SrcLoc
 import FastString
 import Outputable
+#ifdef GHCI
 import Foreign.C	( CInt )
+#endif
 import {-# SOURCE #-} ErrUtils ( Severity(..), Message, mkLocMessage )
 
+#ifdef GHCI
 import System.IO.Unsafe	( unsafePerformIO )
+#endif
 import Data.IORef
 import Control.Monad    ( when )
 
@@ -101,7 +110,7 @@ import Data.Char
 import Data.List
 import Data.Map (Map)
 import qualified Data.Map as Map
-import Data.Maybe
+-- import Data.Maybe
 import System.FilePath
 import System.IO        ( stderr, hPutChar )
 
@@ -441,41 +450,13 @@ data DynFlags = DynFlags {
   libraryPaths          :: [String],
   frameworkPaths        :: [String],    -- used on darwin only
   cmdlineFrameworks     :: [String],    -- ditto
-  tmpDir                :: String,      -- no trailing '/'
 
-  ghcUsagePath          :: FilePath,    -- Filled in by SysTools
-  ghciUsagePath         :: FilePath,    -- ditto
   rtsOpts               :: Maybe String,
   rtsOptsEnabled        :: RtsOptsEnabled,
 
   hpcDir                :: String,      -- ^ Path to store the .mix files
 
-  -- options for particular phases
-  opt_L                 :: [String],
-  opt_P                 :: [String],
-  opt_F                 :: [String],
-  opt_c                 :: [String],
-  opt_m                 :: [String],
-  opt_a                 :: [String],
-  opt_l                 :: [String],
-  opt_windres           :: [String],
-  opt_lo                :: [String], -- LLVM: llvm optimiser
-  opt_lc                :: [String], -- LLVM: llc static compiler
-
-  -- commands for particular phases
-  pgm_L                 :: String,
-  pgm_P                 :: (String,[Option]),
-  pgm_F                 :: String,
-  pgm_c                 :: (String,[Option]),
-  pgm_s                 :: (String,[Option]),
-  pgm_a                 :: (String,[Option]),
-  pgm_l                 :: (String,[Option]),
-  pgm_dll               :: (String,[Option]),
-  pgm_T                 :: String,
-  pgm_sysman            :: String,
-  pgm_windres           :: String,
-  pgm_lo                :: (String,[Option]), -- LLVM: opt llvm optimiser
-  pgm_lc                :: (String,[Option]), -- LLVM: llc static compiler
+  settings              :: Settings,
 
   --  For ghc -M
   depMakefile           :: FilePath,
@@ -485,8 +466,6 @@ data DynFlags = DynFlags {
 
   --  Package flags
   extraPkgConfs         :: [FilePath],
-  topDir                :: FilePath,    -- filled in by SysTools
-  systemPackageConfig   :: FilePath,    -- ditto
         -- ^ The @-package-conf@ flags given on the command line, in the order
         -- they appeared.
 
@@ -521,6 +500,105 @@ data DynFlags = DynFlags {
   haddockOptions :: Maybe String
  }
 
+data Settings = Settings {
+  sGhcUsagePath          :: FilePath,    -- Filled in by SysTools
+  sGhciUsagePath         :: FilePath,    -- ditto
+  sTopDir                :: FilePath,
+  sTmpDir                :: String,      -- no trailing '/'
+  -- You shouldn't need to look things up in rawSettings directly.
+  -- They should have their own fields instead.
+  sRawSettings           :: [(String, String)],
+  sExtraGccViaCFlags     :: [String],
+  sSystemPackageConfig   :: FilePath,
+  -- commands for particular phases
+  sPgm_L                 :: String,
+  sPgm_P                 :: (String,[Option]),
+  sPgm_F                 :: String,
+  sPgm_c                 :: (String,[Option]),
+  sPgm_s                 :: (String,[Option]),
+  sPgm_a                 :: (String,[Option]),
+  sPgm_l                 :: (String,[Option]),
+  sPgm_dll               :: (String,[Option]),
+  sPgm_T                 :: String,
+  sPgm_sysman            :: String,
+  sPgm_windres           :: String,
+  sPgm_lo                :: (String,[Option]), -- LLVM: opt llvm optimiser
+  sPgm_lc                :: (String,[Option]), -- LLVM: llc static compiler
+  -- options for particular phases
+  sOpt_L                 :: [String],
+  sOpt_P                 :: [String],
+  sOpt_F                 :: [String],
+  sOpt_c                 :: [String],
+  sOpt_m                 :: [String],
+  sOpt_a                 :: [String],
+  sOpt_l                 :: [String],
+  sOpt_windres           :: [String],
+  sOpt_lo                :: [String], -- LLVM: llvm optimiser
+  sOpt_lc                :: [String]  -- LLVM: llc static compiler
+
+ }
+
+ghcUsagePath          :: DynFlags -> FilePath
+ghcUsagePath dflags = sGhcUsagePath (settings dflags)
+ghciUsagePath         :: DynFlags -> FilePath
+ghciUsagePath dflags = sGhciUsagePath (settings dflags)
+topDir                :: DynFlags -> FilePath
+topDir dflags = sTopDir (settings dflags)
+tmpDir                :: DynFlags -> String
+tmpDir dflags = sTmpDir (settings dflags)
+rawSettings           :: DynFlags -> [(String, String)]
+rawSettings dflags = sRawSettings (settings dflags)
+extraGccViaCFlags     :: DynFlags -> [String]
+extraGccViaCFlags dflags = sExtraGccViaCFlags (settings dflags)
+systemPackageConfig   :: DynFlags -> FilePath
+systemPackageConfig dflags = sSystemPackageConfig (settings dflags)
+pgm_L                 :: DynFlags -> String
+pgm_L dflags = sPgm_L (settings dflags)
+pgm_P                 :: DynFlags -> (String,[Option])
+pgm_P dflags = sPgm_P (settings dflags)
+pgm_F                 :: DynFlags -> String
+pgm_F dflags = sPgm_F (settings dflags)
+pgm_c                 :: DynFlags -> (String,[Option])
+pgm_c dflags = sPgm_c (settings dflags)
+pgm_s                 :: DynFlags -> (String,[Option])
+pgm_s dflags = sPgm_s (settings dflags)
+pgm_a                 :: DynFlags -> (String,[Option])
+pgm_a dflags = sPgm_a (settings dflags)
+pgm_l                 :: DynFlags -> (String,[Option])
+pgm_l dflags = sPgm_l (settings dflags)
+pgm_dll               :: DynFlags -> (String,[Option])
+pgm_dll dflags = sPgm_dll (settings dflags)
+pgm_T                 :: DynFlags -> String
+pgm_T dflags = sPgm_T (settings dflags)
+pgm_sysman            :: DynFlags -> String
+pgm_sysman dflags = sPgm_sysman (settings dflags)
+pgm_windres           :: DynFlags -> String
+pgm_windres dflags = sPgm_windres (settings dflags)
+pgm_lo                :: DynFlags -> (String,[Option])
+pgm_lo dflags = sPgm_lo (settings dflags)
+pgm_lc                :: DynFlags -> (String,[Option])
+pgm_lc dflags = sPgm_lc (settings dflags)
+opt_L                 :: DynFlags -> [String]
+opt_L dflags = sOpt_L (settings dflags)
+opt_P                 :: DynFlags -> [String]
+opt_P dflags = sOpt_P (settings dflags)
+opt_F                 :: DynFlags -> [String]
+opt_F dflags = sOpt_F (settings dflags)
+opt_c                 :: DynFlags -> [String]
+opt_c dflags = sOpt_c (settings dflags)
+opt_m                 :: DynFlags -> [String]
+opt_m dflags = sOpt_m (settings dflags)
+opt_a                 :: DynFlags -> [String]
+opt_a dflags = sOpt_a (settings dflags)
+opt_l                 :: DynFlags -> [String]
+opt_l dflags = sOpt_l (settings dflags)
+opt_windres           :: DynFlags -> [String]
+opt_windres dflags = sOpt_windres (settings dflags)
+opt_lo                :: DynFlags -> [String]
+opt_lo dflags = sOpt_lo (settings dflags)
+opt_lc                :: DynFlags -> [String]
+opt_lc dflags = sOpt_lc (settings dflags)
+
 wayNames :: DynFlags -> [WayName]
 wayNames = map wayName . ways
 
@@ -643,8 +721,8 @@ initDynFlags dflags = do
 
 -- | The normal 'DynFlags'. Note that they is not suitable for use in this form
 -- and must be fully initialized by 'GHC.newSession' first.
-defaultDynFlags :: DynFlags
-defaultDynFlags =
+defaultDynFlags :: Settings -> DynFlags
+defaultDynFlags mySettings =
      DynFlags {
         ghcMode                 = CompManager,
         ghcLink                 = LinkBinary,
@@ -694,25 +772,11 @@ defaultDynFlags =
         libraryPaths            = [],
         frameworkPaths          = [],
         cmdlineFrameworks       = [],
-        tmpDir                  = cDEFAULT_TMPDIR,
         rtsOpts                 = Nothing,
         rtsOptsEnabled          = RtsOptsSafeOnly,
 
         hpcDir                  = ".hpc",
 
-        opt_L                   = [],
-        opt_P                   = (if opt_PIC
-                                   then ["-D__PIC__", "-U __PIC__"] -- this list is reversed
-                                   else []),
-        opt_F                   = [],
-        opt_c                   = [],
-        opt_a                   = [],
-        opt_m                   = [],
-        opt_l                   = [],
-        opt_windres             = [],
-        opt_lo                  = [],
-        opt_lc                  = [],
-
         extraPkgConfs           = [],
         packageFlags            = [],
         pkgDatabase             = Nothing,
@@ -721,25 +785,7 @@ defaultDynFlags =
         buildTag                = panic "defaultDynFlags: No buildTag",
         rtsBuildTag             = panic "defaultDynFlags: No rtsBuildTag",
         splitInfo               = Nothing,
-        -- initSysTools fills all these in
-        ghcUsagePath            = panic "defaultDynFlags: No ghciUsagePath",
-        ghciUsagePath           = panic "defaultDynFlags: No ghciUsagePath",
-        topDir                  = panic "defaultDynFlags: No topDir",
-        systemPackageConfig     = panic  "no systemPackageConfig: call GHC.setSessionDynFlags",
-        pgm_L                   = panic "defaultDynFlags: No pgm_L",
-        pgm_P                   = panic "defaultDynFlags: No pgm_P",
-        pgm_F                   = panic "defaultDynFlags: No pgm_F",
-        pgm_c                   = panic "defaultDynFlags: No pgm_c",
-        pgm_s                   = panic "defaultDynFlags: No pgm_s",
-        pgm_a                   = panic "defaultDynFlags: No pgm_a",
-        pgm_l                   = panic "defaultDynFlags: No pgm_l",
-        pgm_dll                 = panic "defaultDynFlags: No pgm_dll",
-        pgm_T                   = panic "defaultDynFlags: No pgm_T",
-        pgm_sysman              = panic "defaultDynFlags: No pgm_sysman",
-        pgm_windres             = panic "defaultDynFlags: No pgm_windres",
-        pgm_lo                  = panic "defaultDynFlags: No pgm_lo",
-        pgm_lc                  = panic "defaultDynFlags: No pgm_lc",
-        -- end of initSysTools values
+        settings                = mySettings,
         -- ghc -M values
         depMakefile       = "Makefile",
         depIncludePkgDeps = False,
@@ -913,9 +959,9 @@ setDumpPrefixForce f d = d { dumpPrefixForce = f}
 
 -- XXX HACK: Prelude> words "'does not' work" ===> ["'does","not'","work"]
 -- Config.hs should really use Option.
-setPgmP   f d = let (pgm:args) = words f in d{ pgm_P   = (pgm, map Option args)}
-addOptl   f d = d{ opt_l   = f : opt_l d}
-addOptP   f d = d{ opt_P   = f : opt_P d}
+setPgmP   f = let (pgm:args) = words f in alterSettings (\s -> s { sPgm_P   = (pgm, map Option args)})
+addOptl   f = alterSettings (\s -> s { sOpt_l   = f : sOpt_l s})
+addOptP   f = alterSettings (\s -> s { sOpt_P   = f : sOpt_P s})
 
 
 setDepMakefile :: FilePath -> DynFlags -> DynFlags
@@ -1096,30 +1142,30 @@ dynamic_flags = [
 
         ------- Specific phases  --------------------------------------------
     -- need to appear before -pgmL to be parsed as LLVM flags.
-  , Flag "pgmlo"          (hasArg (\f d -> d{ pgm_lo  = (f,[])}))
-  , Flag "pgmlc"          (hasArg (\f d -> d{ pgm_lc  = (f,[])}))
-  , Flag "pgmL"           (hasArg (\f d -> d{ pgm_L   = f}))
+  , Flag "pgmlo"          (hasArg (\f -> alterSettings (\s -> s { sPgm_lo  = (f,[])})))
+  , Flag "pgmlc"          (hasArg (\f -> alterSettings (\s -> s { sPgm_lc  = (f,[])})))
+  , Flag "pgmL"           (hasArg (\f -> alterSettings (\s -> s { sPgm_L   = f})))
   , Flag "pgmP"           (hasArg setPgmP)
-  , Flag "pgmF"           (hasArg (\f d -> d{ pgm_F   = f}))
-  , Flag "pgmc"           (hasArg (\f d -> d{ pgm_c   = (f,[])}))
+  , Flag "pgmF"           (hasArg (\f -> alterSettings (\s -> s { sPgm_F   = f})))
+  , Flag "pgmc"           (hasArg (\f -> alterSettings (\s -> s { sPgm_c   = (f,[])})))
   , Flag "pgmm"           (HasArg (\_ -> addWarn "The -keep-raw-s-files flag does nothing; it will be removed in a future GHC release"))
-  , Flag "pgms"           (hasArg (\f d -> d{ pgm_s   = (f,[])}))
-  , Flag "pgma"           (hasArg (\f d -> d{ pgm_a   = (f,[])}))
-  , Flag "pgml"           (hasArg (\f d -> d{ pgm_l   = (f,[])}))
-  , Flag "pgmdll"         (hasArg (\f d -> d{ pgm_dll = (f,[])}))
-  , Flag "pgmwindres"     (hasArg (\f d -> d{ pgm_windres = f}))
+  , Flag "pgms"           (hasArg (\f -> alterSettings (\s -> s { sPgm_s   = (f,[])})))
+  , Flag "pgma"           (hasArg (\f -> alterSettings (\s -> s { sPgm_a   = (f,[])})))
+  , Flag "pgml"           (hasArg (\f -> alterSettings (\s -> s { sPgm_l   = (f,[])})))
+  , Flag "pgmdll"         (hasArg (\f -> alterSettings (\s -> s { sPgm_dll = (f,[])})))
+  , Flag "pgmwindres"     (hasArg (\f -> alterSettings (\s -> s { sPgm_windres = f})))
 
     -- need to appear before -optl/-opta to be parsed as LLVM flags.
-  , Flag "optlo"          (hasArg (\f d -> d{ opt_lo  = f : opt_lo d}))
-  , Flag "optlc"          (hasArg (\f d -> d{ opt_lc  = f : opt_lc d}))
-  , Flag "optL"           (hasArg (\f d -> d{ opt_L   = f : opt_L d}))
+  , Flag "optlo"          (hasArg (\f -> alterSettings (\s -> s { sOpt_lo  = f : sOpt_lo s})))
+  , Flag "optlc"          (hasArg (\f -> alterSettings (\s -> s { sOpt_lc  = f : sOpt_lc s})))
+  , Flag "optL"           (hasArg (\f -> alterSettings (\s -> s { sOpt_L   = f : sOpt_L s})))
   , Flag "optP"           (hasArg addOptP)
-  , Flag "optF"           (hasArg (\f d -> d{ opt_F   = f : opt_F d}))
-  , Flag "optc"           (hasArg (\f d -> d{ opt_c   = f : opt_c d}))
-  , Flag "optm"           (hasArg (\f d -> d{ opt_m   = f : opt_m d}))
-  , Flag "opta"           (hasArg (\f d -> d{ opt_a   = f : opt_a d}))
+  , Flag "optF"           (hasArg (\f -> alterSettings (\s -> s { sOpt_F   = f : sOpt_F s})))
+  , Flag "optc"           (hasArg (\f -> alterSettings (\s -> s { sOpt_c   = f : sOpt_c s})))
+  , Flag "optm"           (hasArg (\f -> alterSettings (\s -> s { sOpt_m   = f : sOpt_m s})))
+  , Flag "opta"           (hasArg (\f -> alterSettings (\s -> s { sOpt_a   = f : sOpt_a s})))
   , Flag "optl"           (hasArg addOptl)
-  , Flag "optwindres"     (hasArg (\f d -> d{ opt_windres = f : opt_windres d}))
+  , Flag "optwindres"     (hasArg (\f -> alterSettings (\s -> s { sOpt_windres = f : sOpt_windres s})))
 
   , Flag "split-objs"
          (NoArg (if can_split 
@@ -1318,7 +1364,7 @@ dynamic_flags = [
   , Flag "fcontext-stack"              (intSuffix (\n d -> d{ ctxtStkDepth = n }))
   , Flag "fstrictness-before"          (intSuffix (\n d -> d{ strictnessBefore = n : strictnessBefore d }))
   , Flag "ffloat-lam-args"             (intSuffix (\n d -> d{ floatLamArgs = Just n }))
-  , Flag "ffloat-all-lams"             (intSuffix (\n d -> d{ floatLamArgs = Nothing }))
+  , Flag "ffloat-all-lams"             (noArg (\d -> d{ floatLamArgs = Nothing }))
 
         ------ Profiling ----------------------------------------------------
 
@@ -1835,18 +1881,20 @@ foreign import ccall unsafe "rts_isProfiled" rtsIsProfiledIO :: IO CInt
 
 rtsIsProfiled :: Bool
 rtsIsProfiled = unsafePerformIO rtsIsProfiledIO /= 0
+#endif
 
 checkTemplateHaskellOk :: Bool -> DynP ()
-checkTemplateHaskellOk turn_on 
+#ifdef GHCI
+checkTemplateHaskellOk turn_on
   | turn_on && rtsIsProfiled
   = addErr "You can't use Template Haskell with a profiled compiler"
   | otherwise
   = return ()
 #else
--- In stage 1 we don't know that the RTS has rts_isProfiled, 
+-- In stage 1 we don't know that the RTS has rts_isProfiled,
 -- so we simply say "ok".  It doesn't matter because TH isn't
 -- available in stage 1 anyway.
-checkTemplateHaskellOk turn_on = return ()
+checkTemplateHaskellOk _ = return ()
 #endif
 
 {- **********************************************************************
@@ -1903,6 +1951,10 @@ unSetExtensionFlag f = upd (\dfs -> xopt_unset dfs f)
    --      (except for -fno-glasgow-exts, which is treated specially)
 
 --------------------------
+alterSettings :: (Settings -> Settings) -> DynFlags -> DynFlags
+alterSettings f dflags = dflags { settings = f (settings dflags) }
+
+--------------------------
 setDumpFlag' :: DynFlag -> DynP ()
 setDumpFlag' dump_flag
   = do { setDynFlag dump_flag
@@ -2117,7 +2169,7 @@ splitPathList s = filter notNull (splitUp s)
 -- tmpDir, where we store temporary files.
 
 setTmpDir :: FilePath -> DynFlags -> DynFlags
-setTmpDir dir dflags = dflags{ tmpDir = normalise dir }
+setTmpDir dir = alterSettings (\s -> s { sTmpDir = normalise dir })
   -- we used to fix /cygdrive/c/.. on Windows, but this doesn't
   -- seem necessary now --SDM 7/2/2008
 
@@ -2142,17 +2194,16 @@ setOptHpcDir arg  = upd $ \ d -> d{hpcDir = arg}
 -- There are some options that we need to pass to gcc when compiling
 -- Haskell code via C, but are only supported by recent versions of
 -- gcc.  The configure script decides which of these options we need,
--- and puts them in the file "extra-gcc-opts" in $topdir, which is
--- read before each via-C compilation.  The advantage of having these
--- in a separate file is that the file can be created at install-time
--- depending on the available gcc version, and even re-generated  later
--- if gcc is upgraded.
+-- and puts them in the "settings" file in $topdir. The advantage of
+-- having these in a separate file is that the file can be created at
+-- install-time depending on the available gcc version, and even
+-- re-generated later if gcc is upgraded.
 --
 -- The options below are not dependent on the version of gcc, only the
 -- platform.
 
 machdepCCOpts :: DynFlags -> [String] -- flags for all C compilations
-machdepCCOpts dflags = cCcOpts ++ machdepCCOpts'
+machdepCCOpts _ = cCcOpts ++ machdepCCOpts'
 
 machdepCCOpts' :: [String] -- flags for all C compilations
 machdepCCOpts'
@@ -2224,30 +2275,35 @@ can_split = cSupportsSplitObjs == "YES"
 -- -----------------------------------------------------------------------------
 -- Compiler Info
 
-data Printable = String String
-               | FromDynFlags (DynFlags -> String)
-
-compilerInfo :: [(String, Printable)]
-compilerInfo = [("Project name",                String cProjectName),
-                ("Project version",             String cProjectVersion),
-                ("Booter version",              String cBooterVersion),
-                ("Stage",                       String cStage),
-                ("Build platform",              String cBuildPlatformString),
-                ("Host platform",               String cHostPlatformString),
-                ("Target platform",             String cTargetPlatformString),
-                ("Have interpreter",            String cGhcWithInterpreter),
-                ("Object splitting supported",  String cSupportsSplitObjs),
-                ("Have native code generator",  String cGhcWithNativeCodeGen),
-                ("Support SMP",                 String cGhcWithSMP),
-                ("Unregisterised",              String cGhcUnregisterised),
-                ("Tables next to code",         String cGhcEnableTablesNextToCode),
-                ("RTS ways",                    String cGhcRTSWays),
-                ("Leading underscore",          String cLeadingUnderscore),
-                ("Debug on",                    String (show debugIsOn)),
-                ("LibDir",                      FromDynFlags topDir),
-                ("Global Package DB",           FromDynFlags systemPackageConfig),
-                ("C compiler flags",            String (show cCcOpts)),
-                ("Gcc Linker flags",            String (show cGccLinkerOpts)),
-                ("Ld Linker flags",             String (show cLdLinkerOpts))
-               ]
+compilerInfo :: DynFlags -> [(String, String)]
+compilerInfo dflags
+    = -- We always make "Project name" be first to keep parsing in
+      -- other languages simple, i.e. when looking for other fields,
+      -- you don't have to worry whether there is a leading '[' or not
+      ("Project name",                 cProjectName)
+      -- Next come the settings, so anything else can be overridden
+      -- in the settings file (as "lookup" uses the first match for the
+      -- key)
+    : rawSettings dflags
+   ++ [("Project version",             cProjectVersion),
+       ("Booter version",              cBooterVersion),
+       ("Stage",                       cStage),
+       ("Build platform",              cBuildPlatformString),
+       ("Host platform",               cHostPlatformString),
+       ("Target platform",             cTargetPlatformString),
+       ("Have interpreter",            cGhcWithInterpreter),
+       ("Object splitting supported",  cSupportsSplitObjs),
+       ("Have native code generator",  cGhcWithNativeCodeGen),
+       ("Support SMP",                 cGhcWithSMP),
+       ("Unregisterised",              cGhcUnregisterised),
+       ("Tables next to code",         cGhcEnableTablesNextToCode),
+       ("RTS ways",                    cGhcRTSWays),
+       ("Leading underscore",          cLeadingUnderscore),
+       ("Debug on",                    show debugIsOn),
+       ("LibDir",                      topDir dflags),
+       ("Global Package DB",           systemPackageConfig dflags),
+       ("C compiler flags",            show cCcOpts),
+       ("Gcc Linker flags",            show cGccLinkerOpts),
+       ("Ld Linker flags",             show cLdLinkerOpts)
+      ]
 
diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs
index ca2e14cee2..a9e652d01f 100644
--- a/compiler/main/GHC.hs
+++ b/compiler/main/GHC.hs
@@ -431,8 +431,8 @@ initGhcMonad mb_top_dir = do
 
   liftIO $ StaticFlags.initStaticOpts
 
-  dflags0 <- liftIO $ initDynFlags defaultDynFlags
-  dflags <- liftIO $ initSysTools mb_top_dir dflags0
+  mySettings <- liftIO $ initSysTools mb_top_dir
+  dflags <- liftIO $ initDynFlags (defaultDynFlags mySettings)
   env <- liftIO $ newHscEnv dflags
   setSession env
 
diff --git a/compiler/main/GhcMake.hs b/compiler/main/GhcMake.hs
index 0d4143560f..ab658942ac 100644
--- a/compiler/main/GhcMake.hs
+++ b/compiler/main/GhcMake.hs
@@ -1405,17 +1405,14 @@ preprocessFile hsc_env src_fn mb_phase Nothing
 preprocessFile hsc_env src_fn mb_phase (Just (buf, _time))
   = do
         let dflags = hsc_dflags hsc_env
-	-- case we bypass the preprocessing stage?
-	let 
-	    local_opts = getOptions dflags buf src_fn
-	--
+	let local_opts = getOptions dflags buf src_fn
+
 	(dflags', leftovers, warns)
             <- parseDynamicNoPackageFlags dflags local_opts
         checkProcessArgsResult leftovers
         handleFlagWarnings dflags' warns
 
-	let
-	    needs_preprocessing
+	let needs_preprocessing
 		| Just (Unlit _) <- mb_phase    = True
 	        | Nothing <- mb_phase, Unlit _ <- startPhase src_fn  = True
 		  -- note: local_opts is only required if there's no Unlit phase
diff --git a/compiler/main/HscMain.lhs b/compiler/main/HscMain.lhs
index f0c1111898..6a5552f5df 100644
--- a/compiler/main/HscMain.lhs
+++ b/compiler/main/HscMain.lhs
@@ -1132,12 +1132,11 @@ hscTcExpr	-- Typecheck an expression (but don't run it)
 hscTcExpr hsc_env expr = runHsc hsc_env $ do
     maybe_stmt <- hscParseStmt expr
     case maybe_stmt of
-      Just (L _ (ExprStmt expr _ _ _)) ->
-          ioMsgMaybe $ tcRnExpr hsc_env (hsc_IC hsc_env) expr
-      _ -> 
-          liftIO $ throwIO $ mkSrcErr $ unitBag $ 
-              mkPlainErrMsg noSrcSpan
-                            (text "not an expression:" <+> quotes (text expr))
+        Just (L _ (ExprStmt expr _ _ _)) ->
+            ioMsgMaybe $ tcRnExpr hsc_env (hsc_IC hsc_env) expr
+        _ ->
+            liftIO $ throwIO $ mkSrcErr $ unitBag $ mkPlainErrMsg noSrcSpan
+                (text "not an expression:" <+> quotes (text expr))
 
 -- | Find the kind of a type
 hscKcType
diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs
index e59c2239a7..11f1a8bd8a 100644
--- a/compiler/main/HscTypes.lhs
+++ b/compiler/main/HscTypes.lhs
@@ -717,7 +717,7 @@ type ImportedMods = ModuleEnv [(ModuleName, Bool, SrcSpan)]
 -- | A ModGuts is carried through the compiler, accumulating stuff as it goes
 -- There is only one ModGuts at any time, the one for the module
 -- being compiled right now.  Once it is compiled, a 'ModIface' and 
--- 'ModDetails' are extracted and the ModGuts is dicarded.
+-- 'ModDetails' are extracted and the ModGuts is discarded.
 data ModGuts
   = ModGuts {
         mg_module    :: !Module,         -- ^ Module being compiled
diff --git a/compiler/main/Packages.lhs b/compiler/main/Packages.lhs
index 5e265e8599..451f78d24e 100644
--- a/compiler/main/Packages.lhs
+++ b/compiler/main/Packages.lhs
@@ -36,7 +36,7 @@ where
 #include "HsVersions.h"
 
 import PackageConfig	
-import DynFlags		( dopt, DynFlag(..), DynFlags(..), PackageFlag(..), DPHBackend(..) )
+import DynFlags
 import StaticFlags
 import Config		( cProjectVersion )
 import Name		( Name, nameModule_maybe )
diff --git a/compiler/main/StaticFlags.hs b/compiler/main/StaticFlags.hs
index 049b61fedb..732224b9f9 100644
--- a/compiler/main/StaticFlags.hs
+++ b/compiler/main/StaticFlags.hs
@@ -167,7 +167,7 @@ try_read sw str
   = case reads str of
 	((x,_):_) -> x	-- Be forgiving: ignore trailing goop, and alternative parses
 	[]	  -> ghcError (UsageError ("Malformed argument " ++ str ++ " for flag " ++ sw))
-			-- ToDo: hack alert. We should really parse the arugments
+			-- ToDo: hack alert. We should really parse the arguments
 			-- 	 and announce errors in a more civilised way.
 
 
@@ -192,16 +192,12 @@ opt_IgnoreDotGhci		= lookUp (fsLit "-ignore-dot-ghci")
 
 -- debugging options
 -- | Suppress all that is suppressable in core dumps.
+--   Except for uniques, as some simplifier phases introduce new varibles that
+--   have otherwise identical names.
 opt_SuppressAll :: Bool
 opt_SuppressAll	
 	= lookUp  (fsLit "-dsuppress-all")
 
--- | Suppress unique ids on variables.
-opt_SuppressUniques :: Bool
-opt_SuppressUniques
-	=  lookUp  (fsLit "-dsuppress-all")
-	|| lookUp  (fsLit "-dsuppress-uniques")
-
 -- | Suppress all coercions, them replacing with '...'
 opt_SuppressCoercions :: Bool
 opt_SuppressCoercions
@@ -232,10 +228,16 @@ opt_SuppressTypeSignatures
 	=  lookUp  (fsLit "-dsuppress-all")
 	|| lookUp  (fsLit "-dsuppress-type-signatures")
 
+-- | Suppress unique ids on variables.
+--   Except for uniques, as some simplifier phases introduce new variables that
+--   have otherwise identical names.
+opt_SuppressUniques :: Bool
+opt_SuppressUniques
+	=  lookUp  (fsLit "-dsuppress-uniques")
 
 -- | Display case expressions with a single alternative as strict let bindings
 opt_PprCaseAsLet :: Bool
-opt_PprCaseAsLet		= lookUp   (fsLit "-dppr-case-as-let")
+opt_PprCaseAsLet	= lookUp   (fsLit "-dppr-case-as-let")
 
 -- | Set the maximum width of the dumps
 --   If GHC's command line options are bad then the options parser uses the
diff --git a/compiler/main/SysTools.lhs b/compiler/main/SysTools.lhs
index 5c64a34650..2529dbff48 100644
--- a/compiler/main/SysTools.lhs
+++ b/compiler/main/SysTools.lhs
@@ -26,7 +26,6 @@ module SysTools (
         touch,                  -- String -> String -> IO ()
         copy,
         copyWithHeader,
-        getExtraViaCOpts,
 
         -- Temporary-file management
         setTmpDir,
@@ -47,6 +46,7 @@ import ErrUtils
 import Panic
 import Util
 import DynFlags
+import StaticFlags
 import Exception
 
 import Data.IORef
@@ -148,25 +148,44 @@ stuff.
 
 \begin{code}
 initSysTools :: Maybe String    -- Maybe TopDir path (without the '-B' prefix)
-
-             -> DynFlags
-             -> IO DynFlags     -- Set all the mutable variables above, holding
+             -> IO Settings     -- Set all the mutable variables above, holding
                                 --      (a) the system programs
                                 --      (b) the package-config file
                                 --      (c) the GHC usage message
-
-
-initSysTools mbMinusB dflags0
+initSysTools mbMinusB
   = do  { top_dir <- findTopDir mbMinusB
                 -- see [Note topdir]
                 -- NB: top_dir is assumed to be in standard Unix
                 -- format, '/' separated
 
-        ; let installed :: FilePath -> FilePath
+        ; let settingsFile = top_dir </> "settings"
+              installed :: FilePath -> FilePath
               installed file = top_dir </> file
               installed_mingw_bin file = top_dir </> ".." </> "mingw" </> "bin" </> file
               installed_perl_bin file = top_dir </> ".." </> "perl" </> file
 
+        ; settingsStr <- readFile settingsFile
+        ; mySettings <- case maybeReadFuzzy settingsStr of
+                        Just s ->
+                            return s
+                        Nothing ->
+                            pgmError ("Can't parse " ++ show settingsFile)
+        ; let getSetting key = case lookup key mySettings of
+                               Just xs ->
+                                   return xs
+                               Nothing -> pgmError ("No entry for " ++ show key ++ " in " ++ show settingsFile)
+        ; myExtraGccViaCFlags <- getSetting "GCC extra via C opts"
+        -- On Windows, mingw is distributed with GHC,
+        -- so we look in TopDir/../mingw/bin
+        -- It would perhaps be nice to be able to override this
+        -- with the settings file, but it would be a little fiddly
+        -- to make that possible, so for now you can't.
+        ; gcc_prog <- if isWindowsHost then return $ installed_mingw_bin "gcc"
+                                       else getSetting "C compiler command"
+        ; perl_path <- if isWindowsHost
+                       then return $ installed_perl_bin "perl"
+                       else getSetting "perl command"
+
         ; let pkgconfig_path = installed "package.conf.d"
               ghc_usage_msg_path  = installed "ghc-usage.txt"
               ghci_usage_msg_path = installed "ghci-usage.txt"
@@ -181,17 +200,8 @@ initSysTools mbMinusB dflags0
               windres_path  = installed_mingw_bin "windres"
 
         ; tmpdir <- getTemporaryDirectory
-        ; let dflags1 = setTmpDir tmpdir dflags0
 
-        -- On Windows, mingw is distributed with GHC,
-        --      so we look in TopDir/../mingw/bin
         ; let
-              gcc_prog
-                | isWindowsHost = installed_mingw_bin "gcc"
-                | otherwise     = cGCC
-              perl_path
-                | isWindowsHost = installed_perl_bin cGHC_PERL
-                | otherwise     = cGHC_PERL
               -- 'touch' is a GHC util for Windows
               touch_path
                 | isWindowsHost = installed cGHC_TOUCHY_PGM
@@ -225,26 +235,42 @@ initSysTools mbMinusB dflags0
         ; let lc_prog = "llc"
               lo_prog = "opt"
 
-        ; return dflags1{
-                        ghcUsagePath = ghc_usage_msg_path,
-                        ghciUsagePath = ghci_usage_msg_path,
-                        topDir  = top_dir,
-                        systemPackageConfig = pkgconfig_path,
-                        pgm_L   = unlit_path,
-                        pgm_P   = cpp_path,
-                        pgm_F   = "",
-                        pgm_c   = (gcc_prog,[]),
-                        pgm_s   = (split_prog,split_args),
-                        pgm_a   = (as_prog,[]),
-                        pgm_l   = (ld_prog,[]),
-                        pgm_dll = (mkdll_prog,mkdll_args),
-                        pgm_T   = touch_path,
-                        pgm_sysman = top_dir ++ "/ghc/rts/parallel/SysMan",
-                        pgm_windres = windres_path,
-                        pgm_lo  = (lo_prog,[]),
-                        pgm_lc  = (lc_prog,[])
+        ; return $ Settings {
+                        sTmpDir = normalise tmpdir,
+                        sGhcUsagePath = ghc_usage_msg_path,
+                        sGhciUsagePath = ghci_usage_msg_path,
+                        sTopDir  = top_dir,
+                        sRawSettings = mySettings,
+                        sExtraGccViaCFlags = words myExtraGccViaCFlags,
+                        sSystemPackageConfig = pkgconfig_path,
+                        sPgm_L   = unlit_path,
+                        sPgm_P   = cpp_path,
+                        sPgm_F   = "",
+                        sPgm_c   = (gcc_prog,[]),
+                        sPgm_s   = (split_prog,split_args),
+                        sPgm_a   = (as_prog,[]),
+                        sPgm_l   = (ld_prog,[]),
+                        sPgm_dll = (mkdll_prog,mkdll_args),
+                        sPgm_T   = touch_path,
+                        sPgm_sysman = top_dir ++ "/ghc/rts/parallel/SysMan",
+                        sPgm_windres = windres_path,
+                        sPgm_lo  = (lo_prog,[]),
+                        sPgm_lc  = (lc_prog,[]),
                         -- Hans: this isn't right in general, but you can
                         -- elaborate it in the same way as the others
+                        sOpt_L       = [],
+                        sOpt_P       = (if opt_PIC
+                                        then -- this list gets reversed
+                                             ["-D__PIC__", "-U __PIC__"]
+                                        else []),
+                        sOpt_F       = [],
+                        sOpt_c       = [],
+                        sOpt_a       = [],
+                        sOpt_m       = [],
+                        sOpt_l       = [],
+                        sOpt_windres = [],
+                        sOpt_lo      = [],
+                        sOpt_lc      = []
                 }
         }
 \end{code}
@@ -448,11 +474,6 @@ copyWithHeader dflags purpose maybe_header from to = do
   hClose hout
   hClose hin
 
-getExtraViaCOpts :: DynFlags -> IO [String]
-getExtraViaCOpts dflags = do
-  f <- readFile (topDir dflags </> "extra-gcc-opts")
-  return (words f)
-
 -- | read the contents of the named section in an ELF object as a
 -- String.
 readElfSection :: DynFlags -> String -> FilePath -> IO (Maybe String)
@@ -527,8 +548,9 @@ newTempName dflags extn
 -- return our temporary directory within tmp_dir, creating one if we
 -- don't have one yet
 getTempDir :: DynFlags -> IO FilePath
-getTempDir dflags@(DynFlags{tmpDir=tmp_dir})
+getTempDir dflags
   = do let ref = dirsToClean dflags
+           tmp_dir = tmpDir dflags
        mapping <- readIORef ref
        case Map.lookup tmp_dir mapping of
            Nothing ->
diff --git a/compiler/nativeGen/AsmCodeGen.lhs b/compiler/nativeGen/AsmCodeGen.lhs
index 7a38540baa..767dc99f61 100644
--- a/compiler/nativeGen/AsmCodeGen.lhs
+++ b/compiler/nativeGen/AsmCodeGen.lhs
@@ -378,10 +378,15 @@ cmmNativeGen dflags us cmm count
 			, Nothing
 			, mPprStats)
 
+	---- generate jump tables
+	let tabled	=
+		{-# SCC "generateJumpTables" #-}
+		alloced ++ generateJumpTables alloced
+
 	---- shortcut branches
 	let shorted	=
 	 	{-# SCC "shortcutBranches" #-}
-	 	shortcutBranches dflags alloced
+	 	shortcutBranches dflags tabled
 
 	---- sequence blocks
 	let sequenced	=
@@ -609,6 +614,18 @@ makeFarBranches = id
 #endif
 
 -- -----------------------------------------------------------------------------
+-- Generate jump tables
+
+-- Analyzes all native code and generates data sections for all jump
+-- table instructions.
+generateJumpTables
+	:: [NatCmmTop Instr] -> [NatCmmTop Instr]
+generateJumpTables xs = concatMap f xs
+    where f (CmmProc _ _ (ListGraph xs)) = concatMap g xs
+          f _ = []
+          g (BasicBlock _ xs) = catMaybes (map generateJumpTableForInstr xs)
+
+-- -----------------------------------------------------------------------------
 -- Shortcut branches
 
 shortcutBranches 
diff --git a/compiler/nativeGen/PPC/CodeGen.hs b/compiler/nativeGen/PPC/CodeGen.hs
index 29b9a54d49..c96baddca1 100644
--- a/compiler/nativeGen/PPC/CodeGen.hs
+++ b/compiler/nativeGen/PPC/CodeGen.hs
@@ -15,6 +15,7 @@
 
 module PPC.CodeGen ( 
 	cmmTopCodeGen, 
+	generateJumpTableForInstr,
 	InstrBlock 
 ) 
 
@@ -798,7 +799,7 @@ genJump (CmmLit (CmmLabel lbl))
 genJump tree
   = do
         (target,code) <- getSomeReg tree
-        return (code `snocOL` MTCTR target `snocOL` BCTR [])
+        return (code `snocOL` MTCTR target `snocOL` BCTR [] Nothing)
 
 
 -- -----------------------------------------------------------------------------
@@ -1126,22 +1127,12 @@ genSwitch expr ids
         dflags <- getDynFlagsNat
         dynRef <- cmmMakeDynamicReference dflags addImportNat DataReference lbl
         (tableReg,t_code) <- getSomeReg $ dynRef
-        let
-            jumpTable = map jumpTableEntryRel ids
-            
-            jumpTableEntryRel Nothing
-                = CmmStaticLit (CmmInt 0 wordWidth)
-            jumpTableEntryRel (Just blockid)
-                = CmmStaticLit (CmmLabelDiffOff blockLabel lbl 0)
-                where blockLabel = mkAsmTempLabel (getUnique blockid)
-
-            code = e_code `appOL` t_code `appOL` toOL [
-                            LDATA ReadOnlyData (CmmDataLabel lbl : jumpTable),
+        let code = e_code `appOL` t_code `appOL` toOL [
                             SLW tmp reg (RIImm (ImmInt 2)),
                             LD II32 tmp (AddrRegReg tableReg tmp),
                             ADD tmp tmp (RIReg tableReg),
                             MTCTR tmp,
-                            BCTR [ id | Just id <- ids ]
+                            BCTR ids (Just lbl)
                     ]
         return code
   | otherwise
@@ -1149,19 +1140,27 @@ genSwitch expr ids
         (reg,e_code) <- getSomeReg expr
         tmp <- getNewRegNat II32
         lbl <- getNewLabelNat
-        let
-            jumpTable = map jumpTableEntry ids
-        
-            code = e_code `appOL` toOL [
-                            LDATA ReadOnlyData (CmmDataLabel lbl : jumpTable),
+        let code = e_code `appOL` toOL [
                             SLW tmp reg (RIImm (ImmInt 2)),
                             ADDIS tmp tmp (HA (ImmCLbl lbl)),
                             LD II32 tmp (AddrRegImm tmp (LO (ImmCLbl lbl))),
                             MTCTR tmp,
-                            BCTR [ id | Just id <- ids ]
+                            BCTR ids (Just lbl)
                     ]
         return code
 
+generateJumpTableForInstr :: Instr -> Maybe (NatCmmTop Instr)
+generateJumpTableForInstr (BCTR ids (Just lbl)) =
+    let jumpTable
+            | opt_PIC   = map jumpTableEntryRel ids
+            | otherwise = map jumpTableEntry ids
+                where jumpTableEntryRel Nothing
+                        = CmmStaticLit (CmmInt 0 wordWidth)
+                      jumpTableEntryRel (Just blockid)
+                        = CmmStaticLit (CmmLabelDiffOff blockLabel lbl 0)
+                            where blockLabel = mkAsmTempLabel (getUnique blockid)
+    in Just (CmmData ReadOnlyData (CmmDataLabel lbl : jumpTable))
+generateJumpTableForInstr _ = Nothing
 
 -- -----------------------------------------------------------------------------
 -- 'condIntReg' and 'condFltReg': condition codes into registers
diff --git a/compiler/nativeGen/PPC/Instr.hs b/compiler/nativeGen/PPC/Instr.hs
index 6aeccd3a87..0288f1bf02 100644
--- a/compiler/nativeGen/PPC/Instr.hs
+++ b/compiler/nativeGen/PPC/Instr.hs
@@ -104,7 +104,7 @@ data Instr
 	| JMP     CLabel          	-- same as branch,
                                         -- but with CLabel instead of block ID
 	| MTCTR	Reg
-	| BCTR    [BlockId]       	-- with list of local destinations
+	| BCTR [Maybe BlockId] (Maybe CLabel) -- with list of local destinations, and jump table location if necessary
 	| BL	CLabel [Reg]		-- with list of argument regs
 	| BCTRL	[Reg]
 	      
@@ -184,7 +184,7 @@ ppc_regUsageOfInstr instr
     BCC	   _ _		-> noUsage
     BCCFAR _ _		-> noUsage
     MTCTR reg		-> usage ([reg],[])
-    BCTR  _		-> noUsage
+    BCTR  _ _		-> noUsage
     BL    _ params	-> usage (params, callClobberedRegs)
     BCTRL params	-> usage (params, callClobberedRegs)
     ADD	  reg1 reg2 ri  -> usage (reg2 : regRI ri, [reg1])
@@ -257,7 +257,7 @@ ppc_patchRegsOfInstr instr env
     BCC	  cond lbl	-> BCC cond lbl
     BCCFAR cond lbl	-> BCCFAR cond lbl
     MTCTR reg		-> MTCTR (env reg)
-    BCTR  targets	-> BCTR targets
+    BCTR  targets lbl	-> BCTR targets lbl
     BL    imm argRegs	-> BL imm argRegs	-- argument regs
     BCTRL argRegs	-> BCTRL argRegs 	-- cannot be remapped
     ADD	  reg1 reg2 ri	-> ADD (env reg1) (env reg2) (fixRI ri)
@@ -326,7 +326,7 @@ ppc_jumpDestsOfInstr insn
   = case insn of
         BCC _ id        -> [id]
         BCCFAR _ id     -> [id]
-        BCTR targets    -> targets
+        BCTR targets _  -> [id | Just id <- targets]
 	_		-> []
 	
 	
@@ -338,7 +338,7 @@ ppc_patchJumpInstr insn patchF
   = case insn of
         BCC cc id 	-> BCC cc (patchF id)
         BCCFAR cc id 	-> BCCFAR cc (patchF id)
-        BCTR _	 	-> error "Cannot patch BCTR"
+        BCTR ids lbl	-> BCTR (map (fmap patchF) ids) lbl
 	_		-> insn
 
 
diff --git a/compiler/nativeGen/PPC/Ppr.hs b/compiler/nativeGen/PPC/Ppr.hs
index 9fb86c013e..44a6a7ce46 100644
--- a/compiler/nativeGen/PPC/Ppr.hs
+++ b/compiler/nativeGen/PPC/Ppr.hs
@@ -545,7 +545,7 @@ pprInstr (MTCTR reg) = hcat [
 	char '\t',
 	pprReg reg
     ]
-pprInstr (BCTR _) = hcat [
+pprInstr (BCTR _ _) = hcat [
 	char '\t',
 	ptext (sLit "bctr")
     ]
diff --git a/compiler/nativeGen/RegAlloc/Linear/JoinToTargets.hs b/compiler/nativeGen/RegAlloc/Linear/JoinToTargets.hs
index 903082fc26..ef6ae9bc3a 100644
--- a/compiler/nativeGen/RegAlloc/Linear/JoinToTargets.hs
+++ b/compiler/nativeGen/RegAlloc/Linear/JoinToTargets.hs
@@ -190,7 +190,7 @@ joinToTargets_again
 		 _	-> let	instr'	=  patchJumpInstr instr 
 		 				(\bid -> if bid == dest 
 								then mkBlockId fixup_block_id 
-								else dest)
+								else bid) -- no change!
 						
 		 	   in	joinToTargets' block_live (block : new_blocks) block_id instr' dests
 
diff --git a/compiler/nativeGen/SPARC/CodeGen.hs b/compiler/nativeGen/SPARC/CodeGen.hs
index d08d10d437..beb48d6656 100644
--- a/compiler/nativeGen/SPARC/CodeGen.hs
+++ b/compiler/nativeGen/SPARC/CodeGen.hs
@@ -8,6 +8,7 @@
 
 module SPARC.CodeGen ( 
 	cmmTopCodeGen, 
+	generateJumpTableForInstr,
 	InstrBlock 
 ) 
 
@@ -299,15 +300,11 @@ genSwitch expr ids
 		dst		<- getNewRegNat II32
 
 		label 		<- getNewLabelNat
-		let jumpTable	= map jumpTableEntry ids
 
 		return $ e_code `appOL`
 		 toOL	
-		 	-- the jump table
-			[ LDATA ReadOnlyData (CmmDataLabel label : jumpTable)
-
-			-- load base of jump table
-			, SETHI (HI (ImmCLbl label)) base_reg
+			[ -- load base of jump table
+			  SETHI (HI (ImmCLbl label)) base_reg
 			, OR    False base_reg (RIImm $ LO $ ImmCLbl label) base_reg
 			
 			-- the addrs in the table are 32 bits wide..
@@ -315,6 +312,11 @@ genSwitch expr ids
 
 			-- load and jump to the destination
 			, LD 	  II32 (AddrRegReg base_reg offset_reg) dst
-			, JMP_TBL (AddrRegImm dst (ImmInt 0)) [i | Just i <- ids]
+			, JMP_TBL (AddrRegImm dst (ImmInt 0)) ids label
 			, NOP ]
 
+generateJumpTableForInstr :: Instr -> Maybe (NatCmmTop Instr)
+generateJumpTableForInstr (JMP_TBL _ ids label) =
+	let jumpTable = map jumpTableEntry ids
+	in Just (CmmData ReadOnlyData (CmmDataLabel label : jumpTable))
+generateJumpTableForInstr _ = Nothing
diff --git a/compiler/nativeGen/SPARC/Instr.hs b/compiler/nativeGen/SPARC/Instr.hs
index 79b4629e54..93f4d27444 100644
--- a/compiler/nativeGen/SPARC/Instr.hs
+++ b/compiler/nativeGen/SPARC/Instr.hs
@@ -37,6 +37,7 @@ import RegClass
 import Reg
 import Size
 
+import CLabel
 import BlockId
 import OldCmm
 import FastString
@@ -194,7 +195,7 @@ data Instr
 	-- With a tabled jump we know all the possible destinations.
 	-- We also need this info so we can work out what regs are live across the jump.
 	-- 
-	| JMP_TBL	AddrMode [BlockId]
+	| JMP_TBL	AddrMode [Maybe BlockId] CLabel
 
 	| CALL		(Either Imm Reg) Int Bool 	-- target, args, terminal
 
@@ -247,7 +248,7 @@ sparc_regUsageOfInstr instr
     FxTOy   _ _  r1 r2 		-> usage ([r1], 		[r2])
 
     JMP     addr 		-> usage (regAddr addr, [])
-    JMP_TBL addr _      	-> usage (regAddr addr, [])
+    JMP_TBL addr _ _    	-> usage (regAddr addr, [])
 
     CALL  (Left _  )  _ True  	-> noUsage
     CALL  (Left _  )  n False 	-> usage (argRegs n, callClobberedRegs)
@@ -315,7 +316,7 @@ sparc_patchRegsOfInstr instr env = case instr of
     FxTOy s1 s2 r1 r2   	-> FxTOy s1 s2 (env r1) (env r2)
 
     JMP     addr        	-> JMP     (fixAddr addr)
-    JMP_TBL addr ids    	-> JMP_TBL (fixAddr addr) ids
+    JMP_TBL addr ids l  	-> JMP_TBL (fixAddr addr) ids l
 
     CALL  (Left i) n t  	-> CALL (Left i) n t
     CALL  (Right r) n t 	-> CALL (Right (env r)) n t
@@ -345,7 +346,7 @@ sparc_jumpDestsOfInstr insn
   = case insn of
 	BI   _ _ id	-> [id]
 	BF   _ _ id	-> [id]
-	JMP_TBL _ ids	-> ids
+	JMP_TBL _ ids _	-> [id | Just id <- ids]
 	_		-> []
 
 
@@ -354,6 +355,7 @@ sparc_patchJumpInstr insn patchF
   = case insn of
 	BI cc annul id	-> BI cc annul (patchF id)
 	BF cc annul id	-> BF cc annul (patchF id)
+	JMP_TBL n ids l	-> JMP_TBL n (map (fmap patchF) ids) l
 	_		-> insn
 
 
diff --git a/compiler/nativeGen/SPARC/Ppr.hs b/compiler/nativeGen/SPARC/Ppr.hs
index a63661f145..0139680dcc 100644
--- a/compiler/nativeGen/SPARC/Ppr.hs
+++ b/compiler/nativeGen/SPARC/Ppr.hs
@@ -543,7 +543,7 @@ pprInstr (BF cond b blockid)
     ]
 
 pprInstr (JMP addr) = (<>) (ptext (sLit "\tjmp\t")) (pprAddr addr)
-pprInstr (JMP_TBL op _)  = pprInstr (JMP op)
+pprInstr (JMP_TBL op _ _)  = pprInstr (JMP op)
 
 pprInstr (CALL (Left imm) n _)
   = hcat [ ptext (sLit "\tcall\t"), pprImm imm, comma, int n ]
diff --git a/compiler/nativeGen/X86/CodeGen.hs b/compiler/nativeGen/X86/CodeGen.hs
index 5df8f7777e..74f4073469 100644
--- a/compiler/nativeGen/X86/CodeGen.hs
+++ b/compiler/nativeGen/X86/CodeGen.hs
@@ -20,6 +20,7 @@
 
 module X86.CodeGen ( 
 	cmmTopCodeGen, 
+	generateJumpTableForInstr,
 	InstrBlock 
 ) 
 
@@ -1932,16 +1933,7 @@ genSwitch expr ids
         dflags <- getDynFlagsNat
         dynRef <- cmmMakeDynamicReference dflags addImportNat DataReference lbl
         (tableReg,t_code) <- getSomeReg $ dynRef
-        let
-            jumpTable = map jumpTableEntryRel ids
-            
-            jumpTableEntryRel Nothing
-                = CmmStaticLit (CmmInt 0 wordWidth)
-            jumpTableEntryRel (Just blockid)
-                = CmmStaticLit (CmmLabelDiffOff blockLabel lbl 0)
-                where blockLabel = mkAsmTempLabel (getUnique blockid)
-
-            op = OpAddr (AddrBaseIndex (EABaseReg tableReg)
+        let op = OpAddr (AddrBaseIndex (EABaseReg tableReg)
                                        (EAIndex reg wORD_SIZE) (ImmInt 0))
 
 #if x86_64_TARGET_ARCH
@@ -1954,8 +1946,7 @@ genSwitch expr ids
     
             code = e_code `appOL` t_code `appOL` toOL [
                             ADD (intSize wordWidth) op (OpReg tableReg),
-                            JMP_TBL (OpReg tableReg) [ id | Just id <- ids ],
-                            LDATA Text (CmmDataLabel lbl : jumpTable)
+                            JMP_TBL (OpReg tableReg) ids Text lbl,
                     ]
 #else
     -- HACK: On x86_64 binutils<2.17 is only able to generate PC32
@@ -1965,20 +1956,18 @@ genSwitch expr ids
     -- conjunction with the hack in PprMach.hs/pprDataItem once
     -- binutils 2.17 is standard.
             code = e_code `appOL` t_code `appOL` toOL [
-			    LDATA ReadOnlyData (CmmDataLabel lbl : jumpTable),
 			    MOVSxL II32
 				   (OpAddr (AddrBaseIndex (EABaseReg tableReg)
 							  (EAIndex reg wORD_SIZE) (ImmInt 0)))
 				   (OpReg reg),
 			    ADD (intSize wordWidth) (OpReg reg) (OpReg tableReg),
-			    JMP_TBL (OpReg tableReg) [ id | Just id <- ids ]
+			    JMP_TBL (OpReg tableReg) ids ReadOnlyData lbl
 		   ]
 #endif
 #else
             code = e_code `appOL` t_code `appOL` toOL [
-                            LDATA ReadOnlyData (CmmDataLabel lbl : jumpTable),
                             ADD (intSize wordWidth) op (OpReg tableReg),
-                            JMP_TBL (OpReg tableReg) [ id | Just id <- ids ]
+                            JMP_TBL (OpReg tableReg) ids ReadOnlyData lbl
                     ]
 #endif
         return code
@@ -1987,15 +1976,28 @@ genSwitch expr ids
         (reg,e_code) <- getSomeReg expr
         lbl <- getNewLabelNat
         let
-            jumpTable = map jumpTableEntry ids
             op = OpAddr (AddrBaseIndex EABaseNone (EAIndex reg wORD_SIZE) (ImmCLbl lbl))
             code = e_code `appOL` toOL [
-                    LDATA ReadOnlyData (CmmDataLabel lbl : jumpTable),
-                    JMP_TBL op [ id | Just id <- ids ]
+                    JMP_TBL op ids ReadOnlyData lbl
                  ]
         -- in
         return code
 
+generateJumpTableForInstr :: Instr -> Maybe (NatCmmTop Instr)
+generateJumpTableForInstr (JMP_TBL _ ids section lbl) = Just (createJumpTable ids section lbl)
+generateJumpTableForInstr _ = Nothing
+
+createJumpTable ids section lbl
+    = let jumpTable
+            | opt_PIC =
+                  let jumpTableEntryRel Nothing
+                          = CmmStaticLit (CmmInt 0 wordWidth)
+                      jumpTableEntryRel (Just blockid)
+                          = CmmStaticLit (CmmLabelDiffOff blockLabel lbl 0)
+                          where blockLabel = mkAsmTempLabel (getUnique blockid)
+                  in map jumpTableEntryRel ids
+            | otherwise = map jumpTableEntry ids
+      in CmmData section (CmmDataLabel lbl : jumpTable)
 
 -- -----------------------------------------------------------------------------
 -- 'condIntReg' and 'condFltReg': condition codes into registers
diff --git a/compiler/nativeGen/X86/Instr.hs b/compiler/nativeGen/X86/Instr.hs
index a96452b9f1..e934a6d4ef 100644
--- a/compiler/nativeGen/X86/Instr.hs
+++ b/compiler/nativeGen/X86/Instr.hs
@@ -289,7 +289,11 @@ data Instr
 	| JMP	      Operand
 	| JXX	      Cond BlockId  -- includes unconditional branches
 	| JXX_GBL     Cond Imm      -- non-local version of JXX
-	| JMP_TBL     Operand [BlockId]  -- table jump
+	-- Table jump
+	| JMP_TBL     Operand   -- Address to jump to
+	              [Maybe BlockId] -- Blocks in the jump table
+	              Section   -- Data section jump table should be put in
+	              CLabel    -- Label of jump table
 	| CALL	      (Either Imm Reg) [Reg]
 
 	-- Other things.
@@ -350,7 +354,7 @@ x86_regUsageOfInstr instr
     JXX    _ _		-> mkRU [] []
     JXX_GBL _ _		-> mkRU [] []
     JMP     op		-> mkRUR (use_R op)
-    JMP_TBL op _        -> mkRUR (use_R op)
+    JMP_TBL op _ _ _    -> mkRUR (use_R op)
     CALL (Left _)  params   -> mkRU params callClobberedRegs
     CALL (Right reg) params -> mkRU (reg:params) callClobberedRegs
     CLTD   _		-> mkRU [eax] [edx]
@@ -482,7 +486,7 @@ x86_patchRegsOfInstr instr env
     POP  sz op		-> patch1 (POP  sz) op
     SETCC cond op	-> patch1 (SETCC cond) op
     JMP op		-> patch1 JMP op
-    JMP_TBL op ids      -> patch1 JMP_TBL op $ ids
+    JMP_TBL op ids s lbl-> JMP_TBL (patchOp op) ids s lbl
 
     GMOV src dst	-> GMOV (env src) (env dst)
     GLD  sz src dst	-> GLD sz (lookupAddr src) (env dst)
@@ -579,7 +583,7 @@ x86_jumpDestsOfInstr
 x86_jumpDestsOfInstr insn 
   = case insn of
 	JXX _ id	-> [id]
-	JMP_TBL _ ids	-> ids
+	JMP_TBL _ ids _ _ -> [id | Just id <- ids]
 	_		-> []
 
 
@@ -589,7 +593,8 @@ x86_patchJumpInstr
 x86_patchJumpInstr insn patchF
   = case insn of
 	JXX cc id 	-> JXX cc (patchF id)
-	JMP_TBL _ _     -> error "Cannot patch JMP_TBL"
+	JMP_TBL op ids section lbl
+	  -> JMP_TBL op (map (fmap patchF) ids) section lbl
 	_		-> insn
 
 
diff --git a/compiler/nativeGen/X86/Ppr.hs b/compiler/nativeGen/X86/Ppr.hs
index 5fe78e1014..4c3454d43b 100644
--- a/compiler/nativeGen/X86/Ppr.hs
+++ b/compiler/nativeGen/X86/Ppr.hs
@@ -87,7 +87,17 @@ pprNatCmmTop (CmmProc info lbl (ListGraph blocks)) =
                       <+> pprCLabel_asm (mkDeadStripPreventer $ entryLblToInfoLbl lbl)
                     else empty
 #endif
+   $$ pprSizeDecl (if null info then lbl else entryLblToInfoLbl lbl)
 
+-- | Output the ELF .size directive.
+pprSizeDecl :: CLabel -> Doc
+#if elf_OBJ_FORMAT
+pprSizeDecl lbl =
+    ptext (sLit "\t.size") <+> pprCLabel_asm lbl
+    <> ptext (sLit ", .-") <> pprCLabel_asm lbl
+#else
+pprSizeDecl _ = empty
+#endif
 
 pprBasicBlock :: NatBasicBlock Instr -> Doc
 pprBasicBlock (BasicBlock blockid instrs) =
@@ -626,7 +636,7 @@ pprInstr (JXX_GBL cond imm) = pprCondInstr (sLit "j") cond (pprImm imm)
 
 pprInstr (JMP (OpImm imm)) = (<>) (ptext (sLit "\tjmp ")) (pprImm imm)
 pprInstr (JMP op)          = (<>) (ptext (sLit "\tjmp *")) (pprOperand archWordSize op)
-pprInstr (JMP_TBL op _)  = pprInstr (JMP op)
+pprInstr (JMP_TBL op _ _ _)  = pprInstr (JMP op)
 pprInstr (CALL (Left imm) _)    = (<>) (ptext (sLit "\tcall ")) (pprImm imm)
 pprInstr (CALL (Right reg) _)   = (<>) (ptext (sLit "\tcall *")) (pprReg archWordSize reg)
 
diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x
index 61019b3214..46f7488dcc 100644
--- a/compiler/parser/Lexer.x
+++ b/compiler/parser/Lexer.x
@@ -1856,7 +1856,7 @@ pragState dynflags buf loc = (mkPState dynflags buf loc) {
 mkPState :: DynFlags -> StringBuffer -> SrcLoc -> PState
 mkPState flags buf loc =
   PState {
-      buffer	      = buf,
+      buffer        = buf,
       dflags        = flags,
       messages      = emptyMessages,
       last_loc      = mkSrcSpan loc loc,
@@ -1873,35 +1873,35 @@ mkPState flags buf loc =
       alr_justClosedExplicitLetBlock = False
     }
     where
-      bitmap = genericsBit `setBitIf` xopt Opt_Generics flags
-	       .|. ffiBit            `setBitIf` xopt Opt_ForeignFunctionInterface flags
-	       .|. parrBit           `setBitIf` xopt Opt_ParallelArrays  flags
-	       .|. arrowsBit         `setBitIf` xopt Opt_Arrows          flags
-	       .|. thBit             `setBitIf` xopt Opt_TemplateHaskell flags
-	       .|. qqBit             `setBitIf` xopt Opt_QuasiQuotes	 flags
-	       .|. ipBit             `setBitIf` xopt Opt_ImplicitParams	 flags
-	       .|. explicitForallBit `setBitIf` xopt Opt_ExplicitForAll  flags
-	       .|. bangPatBit        `setBitIf` xopt Opt_BangPatterns flags
-	       .|. tyFamBit          `setBitIf` xopt Opt_TypeFamilies flags
-	       .|. haddockBit        `setBitIf` dopt Opt_Haddock      flags
-	       .|. magicHashBit      `setBitIf` xopt Opt_MagicHash    flags
-	       .|. kindSigsBit       `setBitIf` xopt Opt_KindSignatures flags
-	       .|. recursiveDoBit    `setBitIf` xopt Opt_RecursiveDo flags
-	       .|. recBit 	     `setBitIf` xopt Opt_DoRec  flags
-	       .|. recBit 	     `setBitIf` xopt Opt_Arrows flags
-	       .|. unicodeSyntaxBit  `setBitIf` xopt Opt_UnicodeSyntax flags
-	       .|. unboxedTuplesBit  `setBitIf` xopt Opt_UnboxedTuples flags
+      bitmap =     genericsBit       `setBitIf` xopt Opt_Generics flags
+               .|. ffiBit            `setBitIf` xopt Opt_ForeignFunctionInterface flags
+               .|. parrBit           `setBitIf` xopt Opt_ParallelArrays  flags
+               .|. arrowsBit         `setBitIf` xopt Opt_Arrows          flags
+               .|. thBit             `setBitIf` xopt Opt_TemplateHaskell flags
+               .|. qqBit             `setBitIf` xopt Opt_QuasiQuotes     flags
+               .|. ipBit             `setBitIf` xopt Opt_ImplicitParams  flags
+               .|. explicitForallBit `setBitIf` xopt Opt_ExplicitForAll  flags
+               .|. bangPatBit        `setBitIf` xopt Opt_BangPatterns    flags
+               .|. tyFamBit          `setBitIf` xopt Opt_TypeFamilies    flags
+               .|. haddockBit        `setBitIf` dopt Opt_Haddock         flags
+               .|. magicHashBit      `setBitIf` xopt Opt_MagicHash       flags
+               .|. kindSigsBit       `setBitIf` xopt Opt_KindSignatures  flags
+               .|. recursiveDoBit    `setBitIf` xopt Opt_RecursiveDo     flags
+               .|. recBit            `setBitIf` xopt Opt_DoRec           flags
+               .|. recBit            `setBitIf` xopt Opt_Arrows          flags
+               .|. unicodeSyntaxBit  `setBitIf` xopt Opt_UnicodeSyntax   flags
+               .|. unboxedTuplesBit  `setBitIf` xopt Opt_UnboxedTuples   flags
                .|. datatypeContextsBit `setBitIf` xopt Opt_DatatypeContexts flags
                .|. transformComprehensionsBit `setBitIf` xopt Opt_TransformListComp flags
                .|. transformComprehensionsBit `setBitIf` xopt Opt_MonadComprehensions flags
                .|. rawTokenStreamBit `setBitIf` dopt Opt_KeepRawTokenStream flags
                .|. alternativeLayoutRuleBit `setBitIf` xopt Opt_AlternativeLayoutRule flags
-               .|. relaxedLayoutBit `setBitIf` xopt Opt_RelaxedLayout flags
+               .|. relaxedLayoutBit  `setBitIf` xopt Opt_RelaxedLayout flags
                .|. nondecreasingIndentationBit `setBitIf` xopt Opt_NondecreasingIndentation flags
       --
       setBitIf :: Int -> Bool -> Int
       b `setBitIf` cond | cond      = bit b
-			| otherwise = 0
+                        | otherwise = 0
 
 addWarning :: DynFlag -> SrcSpan -> SDoc -> P ()
 addWarning option srcspan warning
diff --git a/compiler/prelude/PrelRules.lhs b/compiler/prelude/PrelRules.lhs
index b37556be12..8f2d21f364 100644
--- a/compiler/prelude/PrelRules.lhs
+++ b/compiler/prelude/PrelRules.lhs
@@ -54,7 +54,7 @@ Well, of course you'd need a lot of rules if you did it
 like that, so we use a BuiltinRule instead, so that we
 can match in any two literal values.  So the rule is really
 more like
-        (Lit 4) +# (Lit y) = Lit (x+#y)
+        (Lit x) +# (Lit y) = Lit (x+#y)
 where the (+#) on the rhs is done at compile time
 
 That is why these rules are built in here.  Other rules
diff --git a/compiler/rename/RnSource.lhs b/compiler/rename/RnSource.lhs
index 725baeb04f..18c2dfd7ae 100644
--- a/compiler/rename/RnSource.lhs
+++ b/compiler/rename/RnSource.lhs
@@ -1252,4 +1252,4 @@ add_bind _ (ValBindsOut {})     = panic "RdrHsSyn:add_bind"
 add_sig :: LSig a -> HsValBinds a -> HsValBinds a
 add_sig s (ValBindsIn bs sigs) = ValBindsIn bs (s:sigs) 
 add_sig _ (ValBindsOut {})     = panic "RdrHsSyn:add_sig"
-\end{code}
\ No newline at end of file
+\end{code}
diff --git a/compiler/simplCore/CoreMonad.lhs b/compiler/simplCore/CoreMonad.lhs
index c527d820c5..6ddcff2b26 100644
--- a/compiler/simplCore/CoreMonad.lhs
+++ b/compiler/simplCore/CoreMonad.lhs
@@ -370,13 +370,21 @@ getCoreToDo dflags
 
     simpl_phase phase names iter
       = CoreDoPasses
-          [ maybe_strictness_before phase
+      $   [ maybe_strictness_before phase
           , CoreDoSimplify iter
                 (base_mode { sm_phase = Phase phase
                            , sm_names = names })
 
-          , maybe_rule_check (Phase phase)
-          ]
+          , maybe_rule_check (Phase phase) ]
+
+          -- Vectorisation can introduce a fair few common sub expressions involving 
+          --  DPH primitives. For example, see the Reverse test from dph-examples.
+          --  We need to eliminate these common sub expressions before their definitions
+          --  are inlined in phase 2. The CSE introduces lots of  v1 = v2 bindings, 
+          --  so we also run simpl_gently to inline them.
+      ++  (if dopt Opt_Vectorise dflags && phase == 3
+	    then [CoreCSE, simpl_gently]
+	    else [])
 
     vectorisation
       = runWhen (dopt Opt_Vectorise dflags) $
diff --git a/compiler/typecheck/TcForeign.lhs b/compiler/typecheck/TcForeign.lhs
index 73fd449d32..8f53d6e7b8 100644
--- a/compiler/typecheck/TcForeign.lhs
+++ b/compiler/typecheck/TcForeign.lhs
@@ -12,11 +12,11 @@ is restricted to what the outside world understands (read C), and this
 module checks to see if a foreign declaration has got a legal type.
 
 \begin{code}
-module TcForeign 
-	( 
-	  tcForeignImports
+module TcForeign
+        (
+          tcForeignImports
         , tcForeignExports
-	) where
+        ) where
 
 #include "HsVersions.h"
 
@@ -43,18 +43,18 @@ import FastString
 -- Defines a binding
 isForeignImport :: LForeignDecl name -> Bool
 isForeignImport (L _ (ForeignImport _ _ _)) = True
-isForeignImport _			      = False
+isForeignImport _                           = False
 
 -- Exports a binding
 isForeignExport :: LForeignDecl name -> Bool
 isForeignExport (L _ (ForeignExport _ _ _)) = True
-isForeignExport _	  	              = False
+isForeignExport _                           = False
 \end{code}
 
 %************************************************************************
-%*									*
+%*                                                                      *
 \subsection{Imports}
-%*									*
+%*                                                                      *
 %************************************************************************
 
 \begin{code}
@@ -64,22 +64,22 @@ tcForeignImports decls
 
 tcFImport :: ForeignDecl Name -> TcM (Id, ForeignDecl Id)
 tcFImport fo@(ForeignImport (L loc nm) hs_ty imp_decl)
- = addErrCtxt (foreignDeclCtxt fo)  $ 
-   do { sig_ty <- tcHsSigType (ForSigCtxt nm) hs_ty
-      ; let 
-          -- Drop the foralls before inspecting the
-          -- structure of the foreign type.
-	    (_, t_ty)	      = tcSplitForAllTys sig_ty
-	    (arg_tys, res_ty) = tcSplitFunTys t_ty
-	    id  	      = mkLocalId nm sig_ty
- 		-- Use a LocalId to obey the invariant that locally-defined 
-		-- things are LocalIds.  However, it does not need zonking,
-		-- (so TcHsSyn.zonkForeignExports ignores it).
-   
-      ; imp_decl' <- tcCheckFIType sig_ty arg_tys res_ty imp_decl
-         -- Can't use sig_ty here because sig_ty :: Type and 
-	 -- we need HsType Id hence the undefined
-      ; return (id, ForeignImport (L loc id) undefined imp_decl') }
+  = addErrCtxt (foreignDeclCtxt fo)  $
+    do { sig_ty <- tcHsSigType (ForSigCtxt nm) hs_ty
+       ; let
+           -- Drop the foralls before inspecting the
+           -- structure of the foreign type.
+             (_, t_ty)         = tcSplitForAllTys sig_ty
+             (arg_tys, res_ty) = tcSplitFunTys t_ty
+             id                = mkLocalId nm sig_ty
+                 -- Use a LocalId to obey the invariant that locally-defined
+                 -- things are LocalIds.  However, it does not need zonking,
+                 -- (so TcHsSyn.zonkForeignExports ignores it).
+
+       ; imp_decl' <- tcCheckFIType sig_ty arg_tys res_ty imp_decl
+          -- Can't use sig_ty here because sig_ty :: Type and
+          -- we need HsType Id hence the undefined
+       ; return (id, ForeignImport (L loc id) undefined imp_decl') }
 tcFImport d = pprPanic "tcFImport" (ppr d)
 \end{code}
 
@@ -93,15 +93,15 @@ tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport _ safety _ (CLabel _))
     do { checkCg checkCOrAsmOrLlvmOrInterp
        ; checkSafety safety
        ; check (isFFILabelTy res_ty) (illegalForeignTyErr empty sig_ty)
-       ; return idecl }	     -- NB check res_ty not sig_ty!
-       	 	      	     --    In case sig_ty is (forall a. ForeignPtr a)
+       ; return idecl }      -- NB check res_ty not sig_ty!
+                             --    In case sig_ty is (forall a. ForeignPtr a)
 
 tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv safety _ CWrapper) = do
-   	-- Foreign wrapper (former f.e.d.)
-   	-- The type must be of the form ft -> IO (FunPtr ft), where ft is a
-   	-- valid foreign type.  For legacy reasons ft -> IO (Ptr ft) as well
-   	-- as ft -> IO Addr is accepted, too.  The use of the latter two forms
-   	-- is DEPRECATED, though.
+        -- Foreign wrapper (former f.e.d.)
+        -- The type must be of the form ft -> IO (FunPtr ft), where ft is a
+        -- valid foreign type.  For legacy reasons ft -> IO (Ptr ft) as well
+        -- as ft -> IO Addr is accepted, too.  The use of the latter two forms
+        -- is DEPRECATED, though.
     checkCg checkCOrAsmOrLlvmOrInterp
     checkCConv cconv
     checkSafety safety
@@ -174,14 +174,14 @@ checkMissingAmpersand dflags arg_tys res_ty
 \end{code}
 
 %************************************************************************
-%*									*
+%*                                                                      *
 \subsection{Exports}
-%*									*
+%*                                                                      *
 %************************************************************************
 
 \begin{code}
-tcForeignExports :: [LForeignDecl Name] 
-    		 -> TcM (LHsBinds TcId, [LForeignDecl TcId])
+tcForeignExports :: [LForeignDecl Name]
+                 -> TcM (LHsBinds TcId, [LForeignDecl TcId])
 tcForeignExports decls
   = foldlM combine (emptyLHsBinds, []) (filter isForeignExport decls)
   where
@@ -190,25 +190,25 @@ tcForeignExports decls
        return (b `consBag` binds, f:fs)
 
 tcFExport :: ForeignDecl Name -> TcM (LHsBind Id, ForeignDecl Id)
-tcFExport fo@(ForeignExport (L loc nm) hs_ty spec) =
-   addErrCtxt (foreignDeclCtxt fo)      $ do
+tcFExport fo@(ForeignExport (L loc nm) hs_ty spec)
+  = addErrCtxt (foreignDeclCtxt fo) $ do
 
-   sig_ty <- tcHsSigType (ForSigCtxt nm) hs_ty
-   rhs <- tcPolyExpr (nlHsVar nm) sig_ty
+    sig_ty <- tcHsSigType (ForSigCtxt nm) hs_ty
+    rhs <- tcPolyExpr (nlHsVar nm) sig_ty
 
-   tcCheckFEType sig_ty spec
+    tcCheckFEType sig_ty spec
 
-	  -- we're exporting a function, but at a type possibly more
-	  -- constrained than its declared/inferred type. Hence the need
-	  -- to create a local binding which will call the exported function
-	  -- at a particular type (and, maybe, overloading).
+           -- we're exporting a function, but at a type possibly more
+           -- constrained than its declared/inferred type. Hence the need
+           -- to create a local binding which will call the exported function
+           -- at a particular type (and, maybe, overloading).
 
 
-   -- We need to give a name to the new top-level binding that
-   -- is *stable* (i.e. the compiler won't change it later),
-   -- because this name will be referred to by the C code stub.
-   id  <- mkStableIdFromName nm sig_ty loc mkForeignExportOcc
-   return (mkVarBind id rhs, ForeignExport (L loc id) undefined spec)
+    -- We need to give a name to the new top-level binding that
+    -- is *stable* (i.e. the compiler won't change it later),
+    -- because this name will be referred to by the C code stub.
+    id  <- mkStableIdFromName nm sig_ty loc mkForeignExportOcc
+    return (mkVarBind id rhs, ForeignExport (L loc id) undefined spec)
 tcFExport d = pprPanic "tcFExport" (ppr d)
 \end{code}
 
@@ -232,9 +232,9 @@ tcCheckFEType sig_ty (CExport (CExportStatic str cconv)) = do
 
 
 %************************************************************************
-%*									*
+%*                                                                      *
 \subsection{Miscellaneous}
-%*									*
+%*                                                                      *
 %************************************************************************
 
 \begin{code}
@@ -246,7 +246,7 @@ checkForeignArgs pred tys
     go ty = check (pred ty) (illegalForeignTyErr argument ty)
 
 ------------ Checking result types for foreign calls ----------------------
--- Check that the type has the form 
+-- Check that the type has the form
 --    (IO t) or (t) , and that t satisfies the given predicate.
 --
 checkForeignRes :: Bool -> (Type -> Bool) -> Type -> TcM ()
@@ -256,14 +256,14 @@ nonIOok  = True
 mustBeIO = False
 
 checkForeignRes non_io_result_ok pred_res_ty ty
-	-- (IO t) is ok, and so is any newtype wrapping thereof
+        -- (IO t) is ok, and so is any newtype wrapping thereof
   | Just (_, res_ty, _) <- tcSplitIOType_maybe ty,
     pred_res_ty res_ty
   = return ()
- 
+
   | otherwise
-  = check (non_io_result_ok && pred_res_ty ty) 
-	  (illegalForeignTyErr result ty)
+  = check (non_io_result_ok && pred_res_ty ty)
+          (illegalForeignTyErr result ty)
 \end{code}
 
 \begin{code}
@@ -272,7 +272,7 @@ checkCOrAsmOrLlvm HscC    = Nothing
 checkCOrAsmOrLlvm HscAsm  = Nothing
 checkCOrAsmOrLlvm HscLlvm = Nothing
 checkCOrAsmOrLlvm _
-   = Just (text "requires via-C, llvm (-fllvm) or native code generation (-fvia-C)")
+  = Just (text "requires via-C, llvm (-fllvm) or native code generation (-fvia-C)")
 
 checkCOrAsmOrLlvmOrInterp :: HscTarget -> Maybe SDoc
 checkCOrAsmOrLlvmOrInterp HscC           = Nothing
@@ -280,7 +280,7 @@ checkCOrAsmOrLlvmOrInterp HscAsm         = Nothing
 checkCOrAsmOrLlvmOrInterp HscLlvm        = Nothing
 checkCOrAsmOrLlvmOrInterp HscInterpreted = Nothing
 checkCOrAsmOrLlvmOrInterp _
-   = Just (text "requires interpreted, C, Llvm or native code generation")
+  = Just (text "requires interpreted, C, Llvm or native code generation")
 
 checkCOrAsmOrLlvmOrDotNetOrInterp :: HscTarget -> Maybe SDoc
 checkCOrAsmOrLlvmOrDotNetOrInterp HscC           = Nothing
@@ -288,33 +288,33 @@ checkCOrAsmOrLlvmOrDotNetOrInterp HscAsm         = Nothing
 checkCOrAsmOrLlvmOrDotNetOrInterp HscLlvm        = Nothing
 checkCOrAsmOrLlvmOrDotNetOrInterp HscInterpreted = Nothing
 checkCOrAsmOrLlvmOrDotNetOrInterp _
-   = Just (text "requires interpreted, C, Llvm or native code generation")
+  = Just (text "requires interpreted, C, Llvm or native code generation")
 
 checkCg :: (HscTarget -> Maybe SDoc) -> TcM ()
 checkCg check = do
-   dflags <- getDOpts
-   let target = hscTarget dflags
-   case target of
-     HscNothing -> return ()
-     _ ->
-       case check target of
-	 Nothing  -> return ()
-	 Just err -> addErrTc (text "Illegal foreign declaration:" <+> err)
+    dflags <- getDOpts
+    let target = hscTarget dflags
+    case target of
+      HscNothing -> return ()
+      _ ->
+        case check target of
+          Nothing  -> return ()
+          Just err -> addErrTc (text "Illegal foreign declaration:" <+> err)
 \end{code}
-			   
+
 Calling conventions
 
 \begin{code}
 checkCConv :: CCallConv -> TcM ()
-checkCConv CCallConv  = return ()
+checkCConv CCallConv    = return ()
 #if i386_TARGET_ARCH
-checkCConv StdCallConv = return ()
+checkCConv StdCallConv  = return ()
 #else
 -- This is a warning, not an error. see #3336
-checkCConv StdCallConv = addWarnTc (text "the 'stdcall' calling convention is unsupported on this platform,"$$ text "treating as ccall")
+checkCConv StdCallConv  = addWarnTc (text "the 'stdcall' calling convention is unsupported on this platform," $$ text "treating as ccall")
 #endif
 checkCConv PrimCallConv = addErrTc (text "The `prim' calling convention can only be used with `foreign import'")
-checkCConv CmmCallConv = panic "checkCConv CmmCallConv"
+checkCConv CmmCallConv  = panic "checkCConv CmmCallConv"
 \end{code}
 
 Deprecated "threadsafe" calls
@@ -329,12 +329,12 @@ Warnings
 
 \begin{code}
 check :: Bool -> Message -> TcM ()
-check True _	   = return ()
+check True _       = return ()
 check _    the_err = addErrTc the_err
 
 illegalForeignTyErr :: SDoc -> Type -> SDoc
 illegalForeignTyErr arg_or_res ty
-  = hang (hsep [ptext (sLit "Unacceptable"), arg_or_res, 
+  = hang (hsep [ptext (sLit "Unacceptable"), arg_or_res,
                 ptext (sLit "type in foreign declaration:")])
        2 (hsep [ppr ty])
 
@@ -344,12 +344,11 @@ argument = text "argument"
 result   = text "result"
 
 badCName :: CLabelString -> Message
-badCName target 
-   = sep [quotes (ppr target) <+> ptext (sLit "is not a valid C identifier")]
+badCName target
+  = sep [quotes (ppr target) <+> ptext (sLit "is not a valid C identifier")]
 
 foreignDeclCtxt :: ForeignDecl Name -> SDoc
 foreignDeclCtxt fo
   = hang (ptext (sLit "When checking declaration:"))
        2 (ppr fo)
 \end{code}
-
diff --git a/compiler/typecheck/TcInteract.lhs b/compiler/typecheck/TcInteract.lhs
index 4a049aa3ee..fb6929ae45 100644
--- a/compiler/typecheck/TcInteract.lhs
+++ b/compiler/typecheck/TcInteract.lhs
@@ -1049,9 +1049,16 @@ doInteractWithInert (CIPCan { cc_id = id1, cc_flavor = ifl, cc_ip_nm = nm1, cc_i
   | nm1 == nm2
   =  	-- See Note [When improvement happens]
     do { co_var <- newCoVar ty2 ty1 -- See Note [Efficient Orientation]
-       ; let flav = Wanted (combineCtLoc ifl wfl) 
-       ; cans <- mkCanonical flav co_var 
-       ; mkIRContinue "IP/IP fundep" workItem KeepInert cans }
+       ; let flav = Wanted (combineCtLoc ifl wfl)
+       ; cans <- mkCanonical flav co_var
+       ; case wfl of
+           Given   {} -> pprPanic "Unexpected given IP" (ppr workItem)
+           Derived {} -> pprPanic "Unexpected derived IP" (ppr workItem)
+           Wanted  {} ->
+               do { setIPBind (cc_id workItem) $
+                    EvCast id1 (mkSymCoercion (mkCoVarCoercion co_var))
+                  ; mkIRStopK "IP/IP interaction (solved)" cans }
+       }
 
 -- Never rewrite a given with a wanted equality, and a type function
 -- equality can never rewrite an equality. We rewrite LHS *and* RHS 
diff --git a/compiler/typecheck/TcRnTypes.lhs b/compiler/typecheck/TcRnTypes.lhs
index 4b174e5a64..e511532650 100644
--- a/compiler/typecheck/TcRnTypes.lhs
+++ b/compiler/typecheck/TcRnTypes.lhs
@@ -639,7 +639,7 @@ plusImportAvails
   (ImportAvails { imp_mods = mods2,
 		  imp_dep_mods = dmods2, imp_dep_pkgs = dpkgs2,
                   imp_orphs = orphs2, imp_finsts = finsts2 })
-  = ImportAvails { imp_mods     = plusModuleEnv_C (++) mods1 mods2,	
+  = ImportAvails { imp_mods     = plusModuleEnv_C (++) mods1 mods2,
 		   imp_dep_mods = plusUFM_C plus_mod_dep dmods1 dmods2,	
 		   imp_dep_pkgs = dpkgs1 `unionLists` dpkgs2,
 		   imp_orphs    = orphs1 `unionLists` orphs2,
diff --git a/compiler/utils/Bag.lhs b/compiler/utils/Bag.lhs
index 097a112359..700878aea6 100644
--- a/compiler/utils/Bag.lhs
+++ b/compiler/utils/Bag.lhs
@@ -41,6 +41,7 @@ data Bag a
   | UnitBag a
   | TwoBags (Bag a) (Bag a) -- INVARIANT: neither branch is empty
   | ListBag [a]             -- INVARIANT: the list is non-empty
+    deriving Typeable
 
 emptyBag :: Bag a
 emptyBag = EmptyBag
@@ -262,8 +263,6 @@ bagToList b = foldrBag (:) [] b
 instance (Outputable a) => Outputable (Bag a) where
     ppr bag = braces (pprWithCommas ppr (bagToList bag))
 
-INSTANCE_TYPEABLE1(Bag,bagTc,"Bag")
-
 instance Data a => Data (Bag a) where
   gfoldl k z b = z listToBag `k` bagToList b -- traverse abstract type abstractly
   toConstr _   = abstractConstr $ "Bag("++show (typeOf (undefined::a))++")"
diff --git a/compiler/utils/Util.lhs b/compiler/utils/Util.lhs
index 0e46889ec5..dc4f32ec5e 100644
--- a/compiler/utils/Util.lhs
+++ b/compiler/utils/Util.lhs
@@ -66,6 +66,9 @@ module Util (
         -- * Floating point
         readRational,
 
+        -- * read helpers
+        maybeReadFuzzy,
+
         -- * IO-ish utilities
         createDirectoryHierarchy,
         doesDirNameExist,
@@ -966,6 +969,17 @@ readRational top_s
 
 
 -----------------------------------------------------------------------------
+-- read helpers
+
+maybeReadFuzzy :: Read a => String -> Maybe a
+maybeReadFuzzy str = case reads str of
+                     [(x, s)]
+                      | all isSpace s ->
+                         Just x
+                     _ ->
+                         Nothing
+
+-----------------------------------------------------------------------------
 -- Create a hierarchy of directories
 
 createDirectoryHierarchy :: FilePath -> IO ()