Removed warnings, made Haddock happy, added examples in documentation

The interesting examples talk about our story with heap checks in
case alternatives and our story with the case scrutinee as a Boolean.

12 files changed, 79 insertions, 56 deletions

diff --git a/compiler/cmm/CmmBuildInfoTables.hs b/compiler/cmm/CmmBuildInfoTables.hs
index 173b79971c..e3d2ded59e 100644
--- a/compiler/cmm/CmmBuildInfoTables.hs
+++ b/compiler/cmm/CmmBuildInfoTables.hs
@@ -109,10 +109,10 @@ live_ptrs oldByte slotEnv areaMap bid =
           if off == w && widthInBytes (typeWidth ty) == w then
             (expectJust "add_slot" (lookupFM areaMap a), r, w) : rst
           else panic "live_ptrs: only part of a variable live at a proc point"
-        add_slot rst (CallArea Old, off, w) =
+        add_slot rst (CallArea Old, _, _) =
           rst -- the update frame (or return infotable) should be live
               -- would be nice to check that only that part of the callarea is live...
-        add_slot rst c@((CallArea _), _, _) =
+        add_slot rst ((CallArea _), _, _) =
           rst
           -- JD: THIS ISN'T CURRENTLY A CORRECTNESS PROBLEM, BUT WE SHOULD REALLY
           -- MAKE LIVENESS INFO AROUND CALLS MORE PRECISE -- FOR NOW, A 32-BIT
@@ -127,10 +127,10 @@ live_ptrs oldByte slotEnv areaMap bid =
 -- Construct the stack maps for the given procedure.
 setInfoTableStackMap :: SlotEnv -> AreaMap -> CmmTopForInfoTables -> CmmTopForInfoTables 
 setInfoTableStackMap _ _ t@(NoInfoTable _) = t
-setInfoTableStackMap slotEnv areaMap t@(FloatingInfoTable info bid updfr_off) =
+setInfoTableStackMap slotEnv areaMap t@(FloatingInfoTable _ bid updfr_off) =
   updInfo (const (live_ptrs updfr_off slotEnv areaMap bid)) id t
 setInfoTableStackMap slotEnv areaMap
-     t@(ProcInfoTable (CmmProc (CmmInfo _ _ infoTbl) _ _ g@(LGraph entry _ blocks))
+     t@(ProcInfoTable (CmmProc (CmmInfo _ _ infoTbl) _ _ g@(LGraph _ _ blocks))
                       procpoints) =
   case blockSetToList procpoints of
     [bid] ->
@@ -250,9 +250,7 @@ srtToData srt = Cmm [CmmData RelocatableReadOnlyData (CmmDataLabel (lbl srt) : t
 buildSRTs :: TopSRT -> FiniteMap CLabel CAFSet -> CAFSet ->
              FuelMonad (TopSRT, Maybe CmmTopZ, C_SRT)
 buildSRTs topSRT topCAFMap cafs =
-  -- This is surely the wrong way to get names, as in BlockId
-  do top_lbl <- getUniqueM >>= \ u -> return $ mkSRTLabel (mkFCallName u "srt") NoCafRefs
-     let liftCAF lbl () z = -- get CAFs for functions without static closures
+  do let liftCAF lbl () z = -- get CAFs for functions without static closures
            case lookupFM topCAFMap lbl of Just cafs -> z `plusFM` cafs
                                           Nothing   -> addToFM z lbl ()
          sub_srt topSRT localCafs =
@@ -292,7 +290,7 @@ buildSRTs topSRT topCAFMap cafs =
 -- Adapted from simpleStg/SRT.lhs, which expects Id's.
 procpointSRT :: CLabel -> FiniteMap CLabel Int -> [CLabel] ->
                 FuelMonad (Maybe CmmTopZ, C_SRT)
-procpointSRT top_srt top_table [] =
+procpointSRT _ _ [] =
  return (Nothing, NoC_SRT)
 procpointSRT top_srt top_table entries =
  do (top, srt) <- bitmap `seq` to_SRT top_srt offset len bitmap
@@ -331,7 +329,7 @@ to_SRT top_srt off len bmp
 -- Any procedure referring to a non-static CAF c must keep live the
 -- any CAF that is reachable from c.
 localCAFInfo :: CAFEnv -> CmmTopZ -> Maybe (CLabel, CAFSet)
-localCAFInfo _    t@(CmmData _ _) = Nothing
+localCAFInfo _      (CmmData _ _) = Nothing
 localCAFInfo cafEnv (CmmProc (CmmInfo _ _ infoTbl) top_l _ (LGraph entry _ _)) =
   case infoTbl of
     CmmInfoTable False _ _ _ ->
@@ -382,12 +380,12 @@ bundleCAFs _ t@(NoInfoTable _) = (emptyFM, t)
 -- Construct the SRTs for the given procedure.
 setInfoTableSRT :: FiniteMap CLabel CAFSet -> TopSRT -> (CAFSet, CmmTopForInfoTables) ->
                    FuelMonad (TopSRT, [CmmTopForInfoTables])
-setInfoTableSRT topCAFMap topSRT (cafs, t@(ProcInfoTable p procpoints)) =
+setInfoTableSRT topCAFMap topSRT (cafs, t@(ProcInfoTable _ procpoints)) =
   case blockSetToList procpoints of
-    [bid] -> setSRT cafs topCAFMap topSRT t
-    _     -> panic "setInfoTableStackMap: unexpect number of procpoints"
-             -- until we stop splitting the graphs at procpoints in the native path
-setInfoTableSRT topCAFMap topSRT (cafs, t@(FloatingInfoTable info bid _)) =
+    [_] -> setSRT cafs topCAFMap topSRT t
+    _   -> panic "setInfoTableStackMap: unexpect number of procpoints"
+           -- until we stop splitting the graphs at procpoints in the native path
+setInfoTableSRT topCAFMap topSRT (cafs, t@(FloatingInfoTable _ _ _)) =
   setSRT cafs topCAFMap topSRT t
 setInfoTableSRT _ topSRT (_, t@(NoInfoTable _)) = return (topSRT, [t])
 
@@ -406,7 +404,7 @@ updInfo toVars toSrt (ProcInfoTable (CmmProc info top_l top_args g) procpoints)
   ProcInfoTable (CmmProc (updInfoTbl toVars toSrt info) top_l top_args g) procpoints
 updInfo toVars toSrt (FloatingInfoTable info bid updfr_off) =
   FloatingInfoTable (updInfoTbl toVars toSrt info) bid updfr_off
-updInfo toVars toSrt (NoInfoTable _) = panic "can't update NoInfoTable"
+updInfo _ _ (NoInfoTable _) = panic "can't update NoInfoTable"
 updInfo _ _ _ = panic "unexpected arg to updInfo"
 
 updInfoTbl :: (StackLayout -> StackLayout) -> (C_SRT -> C_SRT) -> CmmInfo -> CmmInfo 
@@ -418,7 +416,7 @@ updInfoTbl toVars toSrt (CmmInfo gc upd_fr (CmmInfoTable s p t typeinfo))
             (ThunkInfo  c s)        -> ThunkInfo c (toSrt s)
             (ThunkSelectorInfo x s) -> ThunkSelectorInfo x (toSrt s)
             (ContInfo v s)          -> ContInfo (toVars v) (toSrt s)
-updInfoTbl toVars toSrt t@(CmmInfo _ _ CmmNonInfoTable) = t
+updInfoTbl _ _ t@(CmmInfo _ _ CmmNonInfoTable) = t
   
 -- Lower the CmmTopForInfoTables type down to good old CmmTopZ
 -- by emitting info tables as data where necessary.
@@ -437,16 +435,16 @@ finishInfoTables (FloatingInfoTable (CmmInfo _ _ infotbl) bid _) =
 extendEnvsForSafeForeignCalls :: CAFEnv -> SlotEnv -> CmmGraph -> (CAFEnv, SlotEnv)
 extendEnvsForSafeForeignCalls cafEnv slotEnv g =
   fold_blocks block (cafEnv, slotEnv) g
-    where block b@(Block _ _ t) z =
+    where block b z =
             tail ( bt_last_in cafTransfers      (lookupFn cafEnv)  l
                  , bt_last_in liveSlotTransfers (lookupFn slotEnv) l)
                  z head
              where (head, last) = goto_end (G.unzip b)
                    l = case last of LastOther l -> l
                                     LastExit -> panic "extendEnvs lastExit"
-          tail lives z (ZFirst _ _) = z
+          tail _ z (ZFirst _ _) = z
           tail lives@(cafs, slots) (cafEnv, slotEnv)
-               (ZHead h m@(MidForeignCall (Safe bid updfr_off) _ _ _)) =
+               (ZHead h m@(MidForeignCall (Safe bid _) _ _ _)) =
             let slots'   = removeLiveSlotDefs slots m
                 slotEnv' = extendBlockEnv slotEnv bid slots'
                 cafEnv'  = extendBlockEnv cafEnv  bid cafs
@@ -489,11 +487,9 @@ data SafeState = State { s_blocks    :: BlockEnv CmmBlock
                        , s_safeCalls :: [CmmTopForInfoTables]}
 
 lowerSafeForeignCalls
-  :: ProcPointSet ->           [[CmmTopForInfoTables]] ->
-          CmmTopZ -> FuelMonad [[CmmTopForInfoTables]]
-lowerSafeForeignCalls _ rst t@(CmmData _ _) = return $ [NoInfoTable t] : rst
-lowerSafeForeignCalls procpoints rst
-                      t@(CmmProc info l args g@(LGraph entry off blocks)) = do
+  :: [[CmmTopForInfoTables]] -> CmmTopZ -> FuelMonad [[CmmTopForInfoTables]]
+lowerSafeForeignCalls rst t@(CmmData _ _) = return $ [NoInfoTable t] : rst
+lowerSafeForeignCalls rst (CmmProc info l args g@(LGraph entry off _)) = do
   let init = return $ State emptyBlockEnv emptyBlockSet []
   let block b@(Block bid _ _) z = do
         state@(State {s_pps = ppset, s_blocks = blocks}) <- z
@@ -510,7 +506,7 @@ lowerSafeForeignCalls procpoints rst
 -- Check for foreign calls -- if none, then we can avoid copying the block.
 hasSafeForeignCall :: CmmBlock -> Bool
 hasSafeForeignCall (Block _ _ t) = tail t
-  where tail (ZTail (MidForeignCall (Safe _ _) _ _ _) t) = True
+  where tail (ZTail (MidForeignCall (Safe _ _) _ _ _) _) = True
         tail (ZTail _ t) = tail t
         tail (ZLast _)   = False
 
@@ -536,7 +532,7 @@ lowerSafeCallBlock state b = tail (return state) (ZBlock head (ZLast last))
 -- to lower a safe foreign call to a sequence of unsafe calls.
 lowerSafeForeignCall ::
   SafeState -> Middle -> ZTail Middle Last -> FuelMonad (SafeState, ZTail Middle Last)
-lowerSafeForeignCall state m@(MidForeignCall (Safe infotable updfr) _ _ _) tail = do
+lowerSafeForeignCall state m@(MidForeignCall (Safe infotable _) _ _ _) tail = do
     let newTemp rep = getUniqueM >>= \u -> return (LocalReg u rep)
     -- Both 'id' and 'new_base' are KindNonPtr because they're
     -- RTS-only objects and are not subject to garbage collection
diff --git a/compiler/cmm/CmmCPSZ.hs b/compiler/cmm/CmmCPSZ.hs
index 03051f7575..008fa5d46c 100644
--- a/compiler/cmm/CmmCPSZ.hs
+++ b/compiler/cmm/CmmCPSZ.hs
@@ -116,7 +116,7 @@ cpsTop hsc_env (CmmProc h l args g) =
        mapM (dump Opt_D_dump_cmmz "after splitting") gs
        let localCAFs = catMaybes $ map (localCAFInfo cafEnv) gs
        mbpprTrace "localCAFs" (ppr localCAFs) $ return ()
-       gs <- liftM concat $ run $ foldM (lowerSafeForeignCalls procPoints) [] gs
+       gs <- liftM concat $ run $ foldM lowerSafeForeignCalls [] gs
        mapM (dump Opt_D_dump_cmmz "after lowerSafeForeignCalls") gs
 
        -- NO MORE GRAPH TRANSFORMATION AFTER HERE -- JUST MAKING INFOTABLES
diff --git a/compiler/cmm/CmmCommonBlockElimZ.hs b/compiler/cmm/CmmCommonBlockElimZ.hs
index df15845f1e..c4d612e337 100644
--- a/compiler/cmm/CmmCommonBlockElimZ.hs
+++ b/compiler/cmm/CmmCommonBlockElimZ.hs
@@ -111,7 +111,7 @@ hash_block (Block _ _ t) =
         hash_lit (CmmLabel _) = 119 -- ugh
         hash_lit (CmmLabelOff _ i) = cvt $ 199 + i
         hash_lit (CmmLabelDiffOff _ _ i) = cvt $ 299 + i
-        hash_lit (CmmBlock id) = 191 -- ugh
+        hash_lit (CmmBlock _) = 191 -- ugh
         hash_lit (CmmHighStackMark) = cvt 313
         hash_tgt (ForeignTarget e _) = hash_e e
         hash_tgt (PrimTarget _) = 31 -- lots of these
diff --git a/compiler/cmm/CmmCvt.hs b/compiler/cmm/CmmCvt.hs
index 3484ed61de..f3c05b8b7b 100644
--- a/compiler/cmm/CmmCvt.hs
+++ b/compiler/cmm/CmmCvt.hs
@@ -44,7 +44,7 @@ toZgraph fun_name args g@(ListGraph (BasicBlock id ss : other_blocks)) =
         mkStmts (CmmComment s  : ss)  = mkComment s  <*> mkStmts ss
         mkStmts (CmmAssign l r : ss)  = mkAssign l r <*> mkStmts ss
         mkStmts (CmmStore  l r : ss)  = mkStore  l r <*> mkStmts ss
-        mkStmts (CmmCall (CmmCallee f conv) res args (CmmSafe srt) CmmMayReturn : ss) =
+        mkStmts (CmmCall (CmmCallee f conv) res args (CmmSafe _) CmmMayReturn : ss) =
             mkCall f conv' (map hintlessCmm res) (map hintlessCmm args) updfr_sz
             <*> mkStmts ss 
               where conv' = Foreign (ForeignConvention conv [] []) -- JD: DUBIOUS
diff --git a/compiler/cmm/CmmProcPointZ.hs b/compiler/cmm/CmmProcPointZ.hs
index 5eaac7472f..712461db85 100644
--- a/compiler/cmm/CmmProcPointZ.hs
+++ b/compiler/cmm/CmmProcPointZ.hs
@@ -385,7 +385,7 @@ add_CopyOuts protos procPoints g = fold_blocks mb_copy_out (return emptyBlockEnv
 -- Input invariant: A block should only be reachable from a single ProcPoint.
 splitAtProcPoints :: CLabel -> ProcPointSet-> ProcPointSet -> BlockEnv Status ->
                      AreaMap -> CmmTopZ -> FuelMonad [CmmTopZ]
-splitAtProcPoints entry_label callPPs procPoints procMap areaMap
+splitAtProcPoints entry_label callPPs procPoints procMap _areaMap
                   (CmmProc (CmmInfo gc upd_fr info_tbl) top_l top_args
                            g@(LGraph entry e_off blocks)) =
   do -- Build a map from procpoints to the blocks they reach
@@ -402,7 +402,7 @@ splitAtProcPoints entry_label callPPs procPoints procMap areaMap
                where graph  = lookupBlockEnv graphEnv procId `orElse` emptyBlockEnv
                      graph' = extendBlockEnv graph bid b
      graphEnv_pre <- return $ fold_blocks addBlock emptyBlockEnv g
-     graphEnv <- return {- $ pprTrace "graphEnv" (ppr graphEnv_pre) -} graphEnv_pre
+     graphEnv <- {- pprTrace "graphEnv" (ppr graphEnv_pre) -} return graphEnv_pre
      -- Build a map from proc point BlockId to labels for their new procedures
      let add_label map pp = return $ addToFM map pp lbl
            where lbl = if pp == entry then entry_label else blockLbl pp
@@ -459,7 +459,7 @@ splitAtProcPoints entry_label callPPs procPoints procMap areaMap
      graphEnv_pre <- foldM add_jumps emptyBlockEnv $ blockEnvToList graphEnv
      graphEnv <- return $ -- pprTrace "graphEnv with jump blocks" (ppr graphEnv_pre)
                                          graphEnv_pre
-     let to_proc (bid, g@(LGraph g_entry _ blocks)) | elemBlockSet bid callPPs =
+     let to_proc (bid, g) | elemBlockSet bid callPPs =
            if bid == entry then 
              CmmProc (CmmInfo gc upd_fr info_tbl) top_l top_args g
            else
@@ -476,9 +476,9 @@ splitAtProcPoints entry_label callPPs procPoints procMap areaMap
            compare (expectJust "block_order" $ lookupBlockEnv block_order bid)
                    (expectJust "block_order" $ lookupBlockEnv block_order bid')
      procs <- return $ map to_proc $ sortBy sort_fn $ blockEnvToList graphEnv
-     return -- $ pprTrace "procLabels" (ppr procLabels)
-            -- $ pprTrace "splitting graphs" (ppr procs)
-            $ procs
+     return -- pprTrace "procLabels" (ppr procLabels)
+            -- pprTrace "splitting graphs" (ppr procs)
+            procs
 splitAtProcPoints _ _ _ _ _ t@(CmmData _ _) = return [t]
 
 ----------------------------------------------------------------
diff --git a/compiler/cmm/CmmSpillReload.hs b/compiler/cmm/CmmSpillReload.hs
index dcbde33722..be570f2bcc 100644
--- a/compiler/cmm/CmmSpillReload.hs
+++ b/compiler/cmm/CmmSpillReload.hs
@@ -119,17 +119,17 @@ middleDualLiveness live m =
 lastDualLiveness :: (BlockId -> DualLive) -> Last -> DualLive
 lastDualLiveness env l = last l
   where last (LastBranch id)          = env id
-        last l@(LastCall tgt Nothing  _ _) = changeRegs (gen l . kill l) empty
-        last l@(LastCall tgt (Just k) _ _) = 
+        last l@(LastCall _ Nothing  _ _) = changeRegs (gen l . kill l) empty
+        last l@(LastCall _ (Just k) _ _) = 
             -- nothing can be live in registers at this point, unless safe foreign call
             let live = env k
                 live_in = DualLive (on_stack live) (gen l emptyRegSet)
             in if isEmptyUniqSet (in_regs live) then live_in
                else pprTrace "Offending party:" (ppr k <+> ppr live) $
                     panic "live values in registers at call continuation"
-        last l@(LastCondBranch e t f)   =
+        last l@(LastCondBranch _ t f)   =
             changeRegs (gen l . kill l) $ dualUnion (env t) (env f)
-        last l@(LastSwitch e tbl)       = changeRegs (gen l . kill l) $ dualUnionList $
+        last l@(LastSwitch _ tbl)       = changeRegs (gen l . kill l) $ dualUnionList $
                                                              map env (catMaybes tbl)
         empty = fact_bot dualLiveLattice
                       
@@ -254,10 +254,10 @@ akill a live = foldRegsUsed deleteFromAvail live a
 middleAvail :: Middle -> AvailRegs -> AvailRegs
 middleAvail m = middle m
   where middle m live = middle' m $ foldRegsUsed deleteFromAvail live m
-        middle' (MidComment {})                 live = live
-        middle' (MidAssign lhs _expr)           live = akill lhs live
-        middle' (MidStore {})                   live = live
-        middle' (MidForeignCall _ _tgt ress _args) _ = AvailRegs emptyRegSet
+        middle' (MidComment {})       live = live
+        middle' (MidAssign lhs _expr) live = akill lhs live
+        middle' (MidStore {})         live = live
+        middle' (MidForeignCall {})   _    = AvailRegs emptyRegSet
 
 lastAvail :: AvailRegs -> Last -> LastOutFacts AvailRegs
 lastAvail _ (LastCall _ (Just k) _ _) = LastOutFacts [(k, AvailRegs emptyRegSet)]
diff --git a/compiler/cmm/CmmStackLayout.hs b/compiler/cmm/CmmStackLayout.hs
index 3518df8dc6..17a819f927 100644
--- a/compiler/cmm/CmmStackLayout.hs
+++ b/compiler/cmm/CmmStackLayout.hs
@@ -147,7 +147,7 @@ liveLastOut env l =
   case l of
     LastCall _ Nothing n _ -> 
       add_area (CallArea Old) n out -- add outgoing args (includes upd frame)
-    LastCall _ (Just k) n (Just upd_n) ->
+    LastCall _ (Just k) n (Just _) ->
       add_area (CallArea Old) n (add_area (CallArea (Young k)) n out)
     LastCall _ (Just k) n Nothing ->
       add_area (CallArea (Young k)) n out
@@ -286,7 +286,7 @@ 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 -> LGraph Middle Last -> AreaMap
-layout procPoints env g@(LGraph _ entrySp _) =
+layout procPoints env g =
   let builder = areaBuilder
       ig = (igraph builder env g, builder)
       env' bid = lookupBlockEnv env bid `orElse` panic "unknown blockId in igraph"
@@ -386,7 +386,7 @@ manifestSP procPoints procMap areaMap g@(LGraph entry args blocks) =
         middle spOff m = mapExpDeepMiddle (replSlot spOff) m
         last   spOff l = mapExpDeepLast   (replSlot spOff) l
         replSlot spOff (CmmStackSlot a i) = CmmRegOff (CmmGlobal Sp) (spOff - (slot a + i))
-        replSlot spOff (CmmLit CmmHighStackMark) = -- replacing the high water mark
+        replSlot _ (CmmLit CmmHighStackMark) = -- replacing the high water mark
           CmmLit (CmmInt (toInteger (max 0 (sp_high - proc_entry_sp))) (typeWidth bWord))
         replSlot _ e = e
         -- The block must establish the SP expected at each successsor.
@@ -419,7 +419,7 @@ manifestSP procPoints procMap areaMap g@(LGraph entry args blocks) =
 maxSlot :: (Area -> Int) -> CmmGraph -> Int
 maxSlot slotOff g = fold_blocks (fold_fwd_block (\ _ _ x -> x) highSlot highSlot) 0 g
   where highSlot i z = foldSlotsUsed add (foldSlotsDefd add z i) i
-        add z (a, i, w) = max z (slotOff a + i)
+        add z (a, i, _) = max z (slotOff a + i)
 
 -----------------------------------------------------------------------------
 -- | Sanity check: stub pointers immediately after they die
diff --git a/compiler/cmm/CmmUtils.hs b/compiler/cmm/CmmUtils.hs
index 841f65b7fa..3057712a3a 100644
--- a/compiler/cmm/CmmUtils.hs
+++ b/compiler/cmm/CmmUtils.hs
@@ -70,7 +70,7 @@ primRepForeignHint IntRep	= SignedHint
 primRepForeignHint WordRep	= NoHint
 primRepForeignHint Int64Rep	= SignedHint
 primRepForeignHint Word64Rep	= NoHint
-primRepForeignHint AddrRep     = AddrHint -- NB! AddrHint, but NonPtrArg
+primRepForeignHint AddrRep      = AddrHint -- NB! AddrHint, but NonPtrArg
 primRepForeignHint FloatRep	= NoHint
 primRepForeignHint DoubleRep	= NoHint
 
diff --git a/compiler/cmm/MkZipCfg.hs b/compiler/cmm/MkZipCfg.hs
index 332b464adb..59d50d5e56 100644
--- a/compiler/cmm/MkZipCfg.hs
+++ b/compiler/cmm/MkZipCfg.hs
@@ -310,7 +310,7 @@ withUnique ofU = AGraph f
                  f' g
 
 outOfLine (AGraph f) = AGraph f'
-    where f' g@(Graph tail' blocks') =
+    where f' (Graph tail' blocks') =
             do Graph emptyEntrance blocks <- f emptyGraph
                note_this_code_becomes_unreachable "outOfLine" (ppr tail') emptyEntrance
                return $ Graph tail' (blocks `plusBlockEnv` blocks')
diff --git a/compiler/cmm/OptimizationFuel.hs b/compiler/cmm/OptimizationFuel.hs
index 7de398acfa..a5d8fa3c09 100644
--- a/compiler/cmm/OptimizationFuel.hs
+++ b/compiler/cmm/OptimizationFuel.hs
@@ -1,5 +1,5 @@
 module OptimizationFuel
-    ( OptimizationFuel ,  canRewriteWithFuel, maybeRewriteWithFuel, oneLessFuel
+    ( OptimizationFuel,  canRewriteWithFuel, maybeRewriteWithFuel, oneLessFuel
     , OptFuelState, initOptFuelState --, setTotalFuel
     , tankFilledTo, diffFuel
     , FuelConsumer
diff --git a/compiler/cmm/ZipCfgCmmRep.hs b/compiler/cmm/ZipCfgCmmRep.hs
index b289fdccc4..43e310c80c 100644
--- a/compiler/cmm/ZipCfgCmmRep.hs
+++ b/compiler/cmm/ZipCfgCmmRep.hs
@@ -64,7 +64,7 @@ data Middle
   | MidStore  CmmExpr CmmExpr    -- Assign to memory location.  Size is
                                  -- given by cmmExprType of the rhs.
 
-  | MidForeignCall               -- A foreign call;
+  | MidForeignCall               -- A foreign call; see Note [Foreign calls]
      ForeignSafety               -- Is it a safe or unsafe call?
      MidCallTarget               -- call target and convention
      CmmFormals                  -- zero or more results
@@ -142,6 +142,33 @@ data ValueDirection = Arguments | Results
   -- Arguments go with procedure definitions, jumps, and arguments to calls
   -- Results go with returns and with results of calls.
   deriving Eq
+ 
+{- Note [Foreign calls]
+~~~~~~~~~~~~~~~~~~~~~~~
+A MidForeign call is used *all* foreign calls, both *unsafe* and *safe*.
+Unsafe ones are easy: think of them as a "fat machine instruction".
+
+Safe ones are trickier.  A safe foreign call 
+     r = f(x)
+ultimately expands to
+     push "return address"	-- Never used to return to; 
+     	  	  		-- just points an info table
+     save registers into TSO
+     call suspendThread
+     r = f(x)			-- Make the call
+     call resumeThread
+     restore registers
+     pop "return address"
+We cannot "lower" a safe foreign call to this sequence of Cmms, because
+after we've saved Sp all the Cmm optimiser's assumptions are broken.
+Furthermore, currently the smart Cmm constructors know the calling
+conventions for Haskell, the garbage collector, etc, and "lower" them
+so that a LastCall passes no parameters or results.  But the smart 
+constructors do *not* (currently) know the foreign call conventions.
+
+For these reasons use MidForeignCall for all calls. The only annoying thing
+is that a safe foreign call needs an info table.
+-}
 
 ----------------------------------------------------------------------
 ----- Splicing between blocks
diff --git a/compiler/cmm/ZipDataflow.hs b/compiler/cmm/ZipDataflow.hs
index 88117550d3..9b18c7730f 100644
--- a/compiler/cmm/ZipDataflow.hs
+++ b/compiler/cmm/ZipDataflow.hs
@@ -900,7 +900,7 @@ backward_rew check_maybe = back
           rewrite start g exit_fact fuel =
            let Graph entry blockenv = g
                blocks = reverse $ G.postorder_dfs_from blockenv entry
-           in do { (FP env in_fact _ _ _, _) <-    -- don't drop the entry fact!
+           in do { (FP _ in_fact _ _ _, _) <-    -- don't drop the entry fact!
                      solve depth name start transfers rewrites g exit_fact fuel
                  --; env <- getAllFacts
                  -- ; my_trace "facts after solving" (ppr env) $ return ()
@@ -1070,11 +1070,11 @@ subAnalysis' :: (Monad (m f), DataflowAnalysis m, Outputable f) =>
                 m f a -> m f a
 subAnalysis' m =
     do { a <- subAnalysis $
-               do { a <- m; facts <- getAllFacts
+               do { a <- m; -- facts <- getAllFacts
                   ; -- my_trace "after sub-analysis facts are" (pprFacts facts) $
                     return a }
-       ; facts <- getAllFacts
+       -- ; facts <- getAllFacts
        ; -- my_trace "in parent analysis facts are" (pprFacts facts) $
          return a }
-  where pprFacts env = nest 2 $ vcat $ map pprFact $ blockEnvToList env
-        pprFact (id, a) = hang (ppr id <> colon) 4 (ppr a)
+  -- where pprFacts env = nest 2 $ vcat $ map pprFact $ blockEnvToList env
+        -- pprFact (id, a) = hang (ppr id <> colon) 4 (ppr a)