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.

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

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

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

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

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]
 
 ----------------------------------------------------------------

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)]

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

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
 

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')

compiler/cmm/OptimizationFuel.hs

 module OptimizationFuel
-    ( OptimizationFuel ,  canRewriteWithFuel, maybeRewriteWithFuel, oneLessFuel
+    ( OptimizationFuel,  canRewriteWithFuel, maybeRewriteWithFuel, oneLessFuel
     , OptFuelState, initOptFuelState --, setTotalFuel
     , tankFilledTo, diffFuel
     , FuelConsumer

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

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)

compiler/codeGen/StgCmmBind.hs

@@ -84,7 +84,7 @@ cgTopRhsClosure id ccs _ upd_flag srt args body = do
 	(_, _, fv_details) = mkVirtHeapOffsets (isLFThunk lf_info) 
 				               (addIdReps [])
   -- Don't drop the non-void args until the closure info has been made
-  ; forkClosureBody (closureCodeBody True id closure_info ccs srt_info
+  ; forkClosureBody (closureCodeBody True id closure_info ccs
                                      (nonVoidIds args) (length args) body fv_details)
 
   ; pprTrace "arity for" (ppr id <+> ppr (length args) <+> ppr args) $
@@ -293,7 +293,7 @@ mkRhsClosure bndr cc _ fvs upd_flag srt args body
 		-- forkClosureBody: (a) ensure that bindings in here are not seen elsewhere
 		-- 		    (b) ignore Sequel from context; use empty Sequel
 		-- And compile the body
-		closureCodeBody False bndr closure_info cc c_srt (nonVoidIds args)
+		closureCodeBody False bndr closure_info cc (nonVoidIds args)
                                 (length args) body fv_details
 
 	-- BUILD THE OBJECT
@@ -361,7 +361,6 @@ closureCodeBody :: Bool            -- whether this is a top-level binding
                 -> Id              -- the closure's name
 		-> ClosureInfo	   -- Lots of information about this closure
 		-> CostCentreStack -- Optional cost centre attached to closure
-		-> C_SRT
 	 	-> [NonVoid Id]    -- incoming args to the closure
 	 	-> Int             -- arity, including void args
 		-> StgExpr
@@ -381,12 +380,12 @@ closureCodeBody :: Bool            -- whether this is a top-level binding
   argSatisfactionCheck (by calling fetchAndReschedule).  
   There info if Node points to closure is available. -- HWL -}
 
-closureCodeBody top_lvl bndr cl_info cc srt args arity body fv_details
+closureCodeBody top_lvl bndr cl_info cc args arity body fv_details
   | length args == 0 -- No args i.e. thunk
   = emitClosureProcAndInfoTable top_lvl bndr cl_info [] $
-      (\ (node, _) -> thunkCode cl_info fv_details cc srt node arity body)
+      (\ (node, _) -> thunkCode cl_info fv_details cc node arity body)
 
-closureCodeBody top_lvl bndr cl_info cc srt args arity body fv_details
+closureCodeBody top_lvl bndr cl_info cc args arity body fv_details
   = ASSERT( length args > 0 )
     do	{ 	-- Allocate the global ticky counter,
 	   	-- and establish the ticky-counter 
@@ -407,7 +406,7 @@ closureCodeBody top_lvl bndr cl_info cc srt args arity body fv_details
 		; granYield arg_regs node_points
 
 			-- Main payload
-		; entryHeapCheck node arity arg_regs srt $ do
+		; entryHeapCheck node arity arg_regs $ do
 		{ enterCostCentre cl_info cc body
                 ; fv_bindings <- mapM bind_fv fv_details
 		; load_fvs node lf_info fv_bindings -- Load free vars out of closure *after*
@@ -454,15 +453,15 @@ mkSlowEntryCode _ [] = panic "entering a closure with no arguments?"
 
 -----------------------------------------
 thunkCode :: ClosureInfo -> [(NonVoid Id, VirtualHpOffset)] -> CostCentreStack ->
-             C_SRT -> LocalReg -> Int -> StgExpr -> FCode ()
-thunkCode cl_info fv_details cc srt node arity body 
+             LocalReg -> Int -> StgExpr -> FCode ()
+thunkCode cl_info fv_details cc node arity body 
   = do	{ let node_points = nodeMustPointToIt (closureLFInfo cl_info)
    	; tickyEnterThunk cl_info
 	; ldvEnterClosure cl_info  -- NB: Node always points when profiling
 	; granThunk node_points
 
         -- Heap overflow check
-	; entryHeapCheck node arity [] srt $ do
+	; entryHeapCheck node arity [] $ do
       	{	-- Overwrite with black hole if necessary
 		-- but *after* the heap-overflow check
 	  whenC (blackHoleOnEntry cl_info && node_points)

compiler/codeGen/StgCmmExpr.hs

@@ -115,10 +115,10 @@ cgLetNoEscapeRhs local_cc bndr rhs =
      ; return info
      }
 
-cgLetNoEscapeRhsBody local_cc bndr (StgRhsClosure cc _bi _ _upd srt args body)
-  = cgLetNoEscapeClosure bndr local_cc cc srt (nonVoidIds args) body
+cgLetNoEscapeRhsBody local_cc bndr (StgRhsClosure cc _bi _ _upd _ args body)
+  = cgLetNoEscapeClosure bndr local_cc cc (nonVoidIds args) body
 cgLetNoEscapeRhsBody local_cc bndr (StgRhsCon cc con args)
-  = cgLetNoEscapeClosure bndr local_cc cc NoSRT [] (StgConApp con args)
+  = cgLetNoEscapeClosure bndr local_cc cc [] (StgConApp con args)
 	-- For a constructor RHS we want to generate a single chunk of 
 	-- code which can be jumped to from many places, which will 
 	-- return the constructor. It's easy; just behave as if it 
@@ -129,17 +129,15 @@ cgLetNoEscapeClosure
 	:: Id			-- binder
 	-> Maybe LocalReg	-- Slot for saved current cost centre
 	-> CostCentreStack   	-- XXX: *** NOT USED *** why not?
-	-> SRT
 	-> [NonVoid Id]		-- Args (as in \ args -> body)
     	-> StgExpr		-- Body (as in above)
 	-> FCode CgIdInfo
 
-cgLetNoEscapeClosure bndr cc_slot _unused_cc srt args body
+cgLetNoEscapeClosure bndr cc_slot _unused_cc args body
   = do  { arg_regs <- forkProc $ do	
 		{ restoreCurrentCostCentre cc_slot
 		; arg_regs <- bindArgsToRegs args
-		; c_srt <- getSRTInfo srt
-		; altHeapCheck arg_regs c_srt (cgExpr body)
+		; altHeapCheck arg_regs (cgExpr body)
 			-- Using altHeapCheck just reduces
 			-- instructions to save on stack
 		; return arg_regs }
@@ -262,11 +260,14 @@ data GcPlan
 			-- of the case alternative(s) into the upstream check
 
 -------------------------------------
+-- See Note [case on Bool]
 cgCase :: StgExpr -> Id -> SRT -> AltType -> [StgAlt] -> FCode ()
--- cgCase (OpApp ) bndr srt AlgAlt [(DataAlt flase, a2]
-  -- | isBoolTy (idType bndr)
-  -- , isDeadBndr bndr
-  -- = 
+{-
+cgCase (OpApp ) bndr srt AlgAlt [(DataAlt flase, a2]
+  | isBoolTy (idType bndr)
+  , isDeadBndr bndr
+  = 
+-}
 
 cgCase scrut bndr srt alt_type alts 
   = do	{ up_hp_usg <- getVirtHp	-- Upstream heap usage
@@ -280,10 +281,10 @@ cgCase scrut bndr srt alt_type alts
               gc_plan = if gcInAlts then GcInAlts alt_regs srt else NoGcInAlts
 
 	; mb_cc <- maybeSaveCostCentre simple_scrut
-	; c_srt <- getSRTInfo srt
 	; withSequel (AssignTo alt_regs gcInAlts) (cgExpr scrut)
 	; restoreCurrentCostCentre mb_cc
 
+  -- JD: We need Note: [Better Alt Heap Checks]
 	; bindArgsToRegs ret_bndrs
 	; cgAlts gc_plan (NonVoid bndr) alt_type alts }
 
@@ -402,9 +403,8 @@ cgAltRhss gc_plan bndr alts
 maybeAltHeapCheck :: GcPlan -> FCode a -> FCode a
 maybeAltHeapCheck NoGcInAlts code
   = code
-maybeAltHeapCheck (GcInAlts regs srt) code
-  = do 	{ c_srt <- getSRTInfo srt
-	; altHeapCheck regs c_srt code }
+maybeAltHeapCheck (GcInAlts regs _) code
+  = altHeapCheck regs code
 
 -----------------------------------------------------------------------------
 -- 	Tail calls
@@ -482,4 +482,77 @@ cgTailCall fun_id fun_info args
     node_points = nodeMustPointToIt lf_info
 
 
+{- Note [case on Bool]
+   ~~~~~~~~~~~~~~~~~~~
+A case on a Boolean value does two things:
+  1. It looks up the Boolean in a closure table and assigns the
+     result to the binder.
+  2. It branches to the True or False case through analysis
+     of the closure assigned to the binder.
+But the indirection through the closure table is unnecessary
+if the assignment to the binder will be dead code (use isDeadBndr).
+
+The following example illustrates how badly the code turns out:
+  STG:
+    case <=## [ww_s7Hx y_s7HD] of wild2_sbH8 {
+      GHC.Bool.False -> <true  code> // sbH8 dead
+      GHC.Bool.True  -> <false code> // sbH8 dead
+    };
+  Cmm:
+    _s7HD::F64 = F64[_sbH7::I64 + 7];  // MidAssign
+    _ccsW::I64 = %MO_F_Le_W64(_s7Hx::F64, _s7HD::F64);  // MidAssign
+    // emitReturn  // MidComment
+    _sbH8::I64 = I64[ghczmprim_GHCziBool_Bool_closure_tbl + (_ccsW::I64 << 3)];  // MidAssign
+    _ccsX::I64 = _sbH8::I64 & 7;  // MidAssign
+    if (_ccsX::I64 >= 2) goto ccsH; else goto ccsI;  // LastCondBranch
+
+The assignments to _sbH8 and _ccsX are completely unnecessary.
+Instead, we should branch based on the value of _ccsW.
+-}
 
+{- Note [Better Alt Heap Checks]
+If two function calls can share a return point, then they will also
+get the same info table. Therefore, it's worth our effort to make
+those opportunities appear as frequently as possible.
+
+Here are a few examples of how it should work:
+
+  STG:
+    case f x of
+      True  -> <True code -- including allocation>
+      False -> <False code>
+  Cmm:
+      r = call f(x) returns to L;
+   L:
+      if r & 7 >= 2 goto L1 else goto L2;
+   L1:
+      if Hp > HpLim then
+        r = gc(r);
+        goto L;
+      <True code -- including allocation>
+   L2:
+      <False code>
+Note that the code following both the call to f(x) and the code to gc(r)
+should be the same, which will allow the common blockifier to discover
+that they are the same. Therefore, both function calls will return to the same
+block, and they will use the same info table.        
+
+Here's an example of the Cmm code we want from a primOp.
+The primOp doesn't produce an info table for us to reuse, but that's okay:
+we should still generate the same code:
+  STG:
+    case f x of
+      0 -> <0-case code -- including allocation>
+      _ -> <default-case code>
+  Cmm:
+      r = a +# b;
+   L:
+      if r == 0 then goto L1 else goto L2;
+   L1:
+      if Hp > HpLim then
+        r = gc(r);
+        goto L;
+      <0-case code -- including allocation>