Remove "fuel", adapt to Hoopl changes, fix warnings

compiler/cmm/BlockId.hs

@@ -15,7 +15,7 @@ import Outputable
 import Unique
 
 import Compiler.Hoopl as Hoopl hiding (Unique)
-import Compiler.Hoopl.GHC (uniqueToInt, uniqueToLbl, lblToUnique)
+import Compiler.Hoopl.Internals (uniqueToLbl)
 
 ----------------------------------------------------------------
 --- Block Ids, their environments, and their sets

compiler/cmm/Cmm.hs

@@ -32,9 +32,9 @@ module Cmm (
 import CLabel
 import BlockId
 import CmmNode
-import OptimizationFuel as F
 import SMRep
 import CmmExpr
+import UniqSupply
 import Compiler.Hoopl
 
 import Data.Word        ( Word8 )
@@ -93,9 +93,9 @@ data GenCmmGraph n = CmmGraph { g_entry :: BlockId, g_graph :: Graph n C C }
 type CmmBlock = Block CmmNode C C
 
 type CmmReplGraph e x = GenCmmReplGraph CmmNode e x
-type GenCmmReplGraph n e x = FuelUniqSM (Maybe (Graph n e x))
-type CmmFwdRewrite f = FwdRewrite FuelUniqSM CmmNode f
-type CmmBwdRewrite f = BwdRewrite FuelUniqSM CmmNode f
+type GenCmmReplGraph n e x = UniqSM (Maybe (Graph n e x))
+type CmmFwdRewrite f = FwdRewrite UniqSM CmmNode f
+type CmmBwdRewrite f = BwdRewrite UniqSM CmmNode f
 
 -----------------------------------------------------------------------------
 --     Info Tables

compiler/cmm/CmmBuildInfoTables.hs

@@ -38,7 +38,6 @@ import IdInfo
 import Data.List
 import Maybes
 import Name
-import OptimizationFuel
 import Outputable
 import SMRep
 import UniqSupply
@@ -149,7 +148,7 @@ srtToData srt = [CmmData RelocatableReadOnlyData (Statics (lbl srt) tbl)]
 -- we make sure they're all close enough to the bottom of the table that the
 -- bitmap will be able to cover all of them.
 buildSRTs :: TopSRT -> Map CLabel CAFSet -> CAFSet ->
-             FuelUniqSM (TopSRT, Maybe CmmDecl, C_SRT)
+             UniqSM (TopSRT, Maybe CmmDecl, C_SRT)
 buildSRTs topSRT topCAFMap cafs =
   do let liftCAF lbl z = -- get CAFs for functions without static closures
            case Map.lookup lbl topCAFMap of Just cafs -> z `Set.union` cafs
@@ -192,7 +191,7 @@ buildSRTs topSRT topCAFMap cafs =
 -- Construct an SRT bitmap.
 -- Adapted from simpleStg/SRT.lhs, which expects Id's.
 procpointSRT :: CLabel -> Map CLabel Int -> [CLabel] ->
-                FuelUniqSM (Maybe CmmDecl, C_SRT)
+                UniqSM (Maybe CmmDecl, C_SRT)
 procpointSRT _ _ [] =
  return (Nothing, NoC_SRT)
 procpointSRT top_srt top_table entries =
@@ -210,7 +209,7 @@ maxBmpSize :: Int
 maxBmpSize = widthInBits wordWidth `div` 2
 
 -- Adapted from codeGen/StgCmmUtils, which converts from SRT to C_SRT.
-to_SRT :: CLabel -> Int -> Int -> Bitmap -> FuelUniqSM (Maybe CmmDecl, C_SRT)
+to_SRT :: CLabel -> Int -> Int -> Bitmap -> UniqSM (Maybe CmmDecl, C_SRT)
 to_SRT top_srt off len bmp
   | len > maxBmpSize || bmp == [fromIntegral srt_escape]
   = do id <- getUniqueM
@@ -276,12 +275,12 @@ bundleCAFs _ t = (Set.empty, t)
 
 -- Construct the SRTs for the given procedure.
 setInfoTableSRT :: Map CLabel CAFSet -> TopSRT -> (CAFSet, CmmDecl) ->
-                   FuelUniqSM (TopSRT, [CmmDecl])
+                   UniqSM (TopSRT, [CmmDecl])
 setInfoTableSRT topCAFMap topSRT (cafs, t) =
   setSRT cafs topCAFMap topSRT t
 
 setSRT :: CAFSet -> Map CLabel CAFSet -> TopSRT ->
-          CmmDecl -> FuelUniqSM (TopSRT, [CmmDecl])
+          CmmDecl -> UniqSM (TopSRT, [CmmDecl])
 setSRT cafs topCAFMap topSRT t =
   do (topSRT, cafTable, srt) <- buildSRTs topSRT topCAFMap cafs
      let t' = updInfo id (const srt) t

compiler/cmm/CmmCallConv.hs

@@ -53,7 +53,6 @@ assignArgumentsPos conv arg_ty reps = assignments
                ([_], PrimOpReturn)     -> allRegs
                (_,   PrimOpReturn)     -> getRegsWithNode
                (_,   Slow)             -> noRegs
-               _ -> pprPanic "Unknown calling convention" (ppr conv)
       -- The calling conventions first assign arguments to registers,
       -- then switch to the stack when we first run out of registers
       -- (even if there are still available registers for args of a different type).

compiler/cmm/CmmCommonBlockElim.hs

@@ -20,7 +20,6 @@ import Hoopl hiding (ChangeFlag)
 import Data.Bits
 import qualified Data.List as List
 import Data.Word
-import FastString
 import Outputable
 import UniqFM
 
@@ -95,7 +94,7 @@ hash_block block =
         hash_lst m h = hash_node m + h `shiftL` 1
 
         hash_node :: CmmNode O x -> Word32
-        hash_node (CmmComment (FastString u _ _ _ _)) = 0 -- don't care
+        hash_node (CmmComment _) = 0 -- don't care
         hash_node (CmmAssign r e) = hash_reg r + hash_e e
         hash_node (CmmStore e e') = hash_e e + hash_e e'
         hash_node (CmmUnsafeForeignCall t _ as) = hash_tgt t + hash_list hash_e as
@@ -148,7 +147,7 @@ lookupBid subst bid = case mapLookup bid subst of
 --
 eqMiddleWith :: (BlockId -> BlockId -> Bool)
              -> CmmNode O O -> CmmNode O O -> Bool
-eqMiddleWith eqBid (CmmComment _) (CmmComment _) = True
+eqMiddleWith _ (CmmComment _) (CmmComment _) = True
 eqMiddleWith eqBid (CmmAssign r1 e1) (CmmAssign r2 e2)
   = r1 == r2 && eqExprWith eqBid e1 e2
 eqMiddleWith eqBid (CmmStore l1 r1) (CmmStore l2 r2)

compiler/cmm/CmmContFlowOpt.hs

@@ -97,7 +97,7 @@ blockConcat g@CmmGraph { g_entry = entry_id }
      maybe_concat :: CmmBlock
                   -> (BlockEnv CmmBlock, BlockEnv BlockId)
                   -> (BlockEnv CmmBlock, BlockEnv BlockId)
-     maybe_concat block unchanged@(blocks, shortcut_map)
+     maybe_concat block (blocks, shortcut_map)
         | CmmBranch b' <- last
         , Just blk' <- mapLookup b' blocks
         , shouldConcatWith b' blk'

compiler/cmm/CmmExpr.hs

@@ -32,7 +32,6 @@ import BlockId
 import CLabel
 import Unique
 
-import Data.Map (Map)
 import Data.Set (Set)
 import qualified Data.Set as Set
 

compiler/cmm/CmmLayoutStack.hs

@@ -17,7 +17,6 @@ import CmmLive
 import CmmProcPoint
 import SMRep
 import Hoopl hiding ((<*>), mkLast, mkMiddle)
-import OptimizationFuel
 import Constants
 import UniqSupply
 import Maybes
@@ -105,7 +104,7 @@ instance Outputable StackMap where
 
 
 cmmLayoutStack :: ProcPointSet -> ByteOff -> CmmGraph
-               -> FuelUniqSM (CmmGraph, BlockEnv StackMap)
+               -> UniqSM (CmmGraph, BlockEnv StackMap)
 cmmLayoutStack procpoints entry_args
                graph0@(CmmGraph { g_entry = entry })
   = do
@@ -114,12 +113,12 @@ cmmLayoutStack procpoints entry_args
     pprTrace "liveness" (ppr liveness) $ return ()
     let blocks = postorderDfs graph
 
-    (final_stackmaps, final_high_sp, new_blocks) <- liftUniq $
+    (final_stackmaps, final_high_sp, new_blocks) <-
           mfix $ \ ~(rec_stackmaps, rec_high_sp, _new_blocks) ->
             layout procpoints liveness entry entry_args
                    rec_stackmaps rec_high_sp blocks
 
-    new_blocks' <- liftUniq $ mapM lowerSafeForeignCall new_blocks
+    new_blocks' <- mapM lowerSafeForeignCall new_blocks
 
     pprTrace ("Sp HWM") (ppr final_high_sp) $
        return (ofBlockList entry new_blocks', final_stackmaps)
@@ -248,7 +247,7 @@ collectContInfo blocks
 -- Updating the StackMap from middle nodes
 
 -- Look for loads from stack slots, and update the StackMap.  This is
--- purelyu for optimisation reasons, so that we can avoid saving a
+-- purely for optimisation reasons, so that we can avoid saving a
 -- variable back to a different stack slot if it is already on the
 -- stack.
 --
@@ -361,6 +360,7 @@ handleLastNode procpoints liveness cont_info stackmaps
            = setupStackFrame lbl liveness cml_ret_off cml_ret_args stack0
 
 
+     -- For other last nodes (branches), if any of the targets is a
      -- proc point, we have to set up the stack to match what the proc
      -- point is expecting.
      --
@@ -701,7 +701,7 @@ manifestSp stackmaps stack0 sp0 sp_high
 
     final_block   = blockJoin first final_middle final_last
 
-    fixup_blocks' = map (blockMapNodes3 (id, adj_post_sp, id)) fixup_blocks
+    fixup_blocks' = map (mapBlock3' (id, adj_post_sp, id)) fixup_blocks
 
 
 getAreaOff :: BlockEnv StackMap -> (Area -> StackLoc)
@@ -982,7 +982,7 @@ stackSlotRegs sm = eltsUFM (sm_regs sm)
 -- *but*, that will invalidate the liveness analysis, and we'll have
 -- to re-do it.
 
-cmmSink :: CmmGraph -> FuelUniqSM CmmGraph
+cmmSink :: CmmGraph -> UniqSM CmmGraph
 cmmSink graph = do
   let liveness = cmmLiveness graph
   return $ cmmSink' liveness graph

compiler/cmm/CmmLint.hs

@@ -16,7 +16,6 @@ import CmmUtils
 import PprCmm ()
 import BlockId
 import FastString
-import CLabel
 import Outputable
 import Constants
 

compiler/cmm/CmmLive.hs

@@ -11,11 +11,10 @@ module CmmLive
     )
 where
 
+import UniqSupply
 import BlockId
 import Cmm
 import CmmUtils
-import Control.Monad
-import OptimizationFuel
 import PprCmmExpr ()
 
 import Hoopl
@@ -81,7 +80,7 @@ xferLive = mkBTransfer3 fst mid lst
 -- Removing assignments to dead variables
 -----------------------------------------------------------------------------
 
-removeDeadAssignments :: CmmGraph -> FuelUniqSM (CmmGraph, BlockEnv CmmLive)
+removeDeadAssignments :: CmmGraph -> UniqSM (CmmGraph, BlockEnv CmmLive)
 removeDeadAssignments g =
    dataflowPassBwd g [] $ analRewBwd liveLattice xferLive rewrites
    where rewrites = mkBRewrite3 nothing middle nothing

compiler/cmm/CmmNode.hs

@@ -400,5 +400,5 @@ mapSuccessors :: (Label -> Label) -> CmmNode O C -> CmmNode O C
 mapSuccessors f (CmmBranch bid)        = CmmBranch (f bid)
 mapSuccessors f (CmmCondBranch p y n)  = CmmCondBranch p (f y) (f n)
 mapSuccessors f (CmmSwitch e arms)     = CmmSwitch e (map (fmap f) arms)
-mapSuccessors f n = n
+mapSuccessors _ n = n
 

compiler/cmm/CmmPipeline.hs

@@ -16,9 +16,9 @@ import CmmBuildInfoTables
 import CmmCommonBlockElim
 import CmmProcPoint
 import CmmContFlowOpt
-import OptimizationFuel
 import CmmLayoutStack
 
+import UniqSupply
 import DynFlags
 import ErrUtils
 import HscTypes
@@ -65,7 +65,7 @@ cmmPipeline hsc_env topSRT prog =
      let topCAFEnv = {-# SCC "topCAFEnv" #-} mkTopCAFInfo (concat cafEnvs)
 
      -- folding over the groups
-     (topSRT, tops) <- {-# SCC "toTops" #-} foldM (toTops hsc_env topCAFEnv) (topSRT, []) tops
+     (topSRT, tops) <- {-# SCC "toTops" #-} foldM (toTops topCAFEnv) (topSRT, []) tops
 
      let cmms :: CmmGroup
          cmms = reverse (concat tops)
@@ -101,17 +101,17 @@ cpsTop hsc_env (CmmProc h@(TopInfo {stack_info=StackInfo {arg_space=entry_off}})
 
        ----------- Proc points -------------------
        let callPPs = {-# SCC "callProcPoints" #-} callProcPoints g
-       procPoints <- {-# SCC "minimalProcPointSet" #-} run $
+       procPoints <- {-# SCC "minimalProcPointSet" #-} runUniqSM $
                      minimalProcPointSet (targetPlatform dflags) callPPs g
 
        ----------- Layout the stack and manifest Sp ---------------
        -- (also does: removeDeadAssignments, and lowerSafeForeignCalls)
        (g, stackmaps) <- {-# SCC "layoutStack" #-}
-                         run $ cmmLayoutStack procPoints entry_off g
+                         runUniqSM $ cmmLayoutStack procPoints entry_off g
        dump Opt_D_dump_cmmz_sp "Layout Stack" g
 
-       g <- {-# SCC "sink" #-} run $ cmmSink g
-       dump Opt_D_dump_cmmz_rewrite "Sink assignments" g
+--       g <- {-# SCC "sink" #-} runUniqSM $ cmmSink g
+--       dump Opt_D_dump_cmmz_rewrite "Sink assignments" g
 
 --       ----------- Sink and inline assignments -------------------
 --       g <- {-# SCC "rewriteAssignments" #-} runOptimization $
@@ -119,10 +119,10 @@ cpsTop hsc_env (CmmProc h@(TopInfo {stack_info=StackInfo {arg_space=entry_off}})
 --       dump Opt_D_dump_cmmz_rewrite "Post rewrite assignments" g
 
        ------------- Split into separate procedures ------------
-       procPointMap  <- {-# SCC "procPointAnalysis" #-} run $
+       procPointMap  <- {-# SCC "procPointAnalysis" #-} runUniqSM $
                         procPointAnalysis procPoints g
        dumpWith dflags Opt_D_dump_cmmz_procmap "procpoint map" procPointMap
-       gs <- {-# SCC "splitAtProcPoints" #-} run $
+       gs <- {-# SCC "splitAtProcPoints" #-} runUniqSM $
              splitAtProcPoints l callPPs procPoints procPointMap (CmmProc h l g)
        dumps Opt_D_dump_cmmz_split "Post splitting" gs
 
@@ -156,8 +156,10 @@ cpsTop hsc_env (CmmProc h@(TopInfo {stack_info=StackInfo {arg_space=entry_off}})
         dumps flag name
            = mapM_ (dumpWith dflags flag name)
 
-        -- Runs a required transformation/analysis
-        run = runInfiniteFuelIO (hsc_OptFuel hsc_env)
+runUniqSM :: UniqSM a -> IO a
+runUniqSM m = do
+  us <- mkSplitUniqSupply 'u'
+  return (initUs_ us m)
 
 
 dumpGraph :: DynFlags -> DynFlag -> String -> CmmGraph -> IO ()
@@ -183,11 +185,11 @@ dumpWith dflags flag txt g = do
 -- This probably belongs in CmmBuildInfoTables?
 -- We're just finishing the job here: once we know what CAFs are defined
 -- in non-static closures, we can build the SRTs.
-toTops :: HscEnv -> Map CLabel CAFSet -> (TopSRT, [[CmmDecl]])
-                 -> [(CAFSet, CmmDecl)] -> IO (TopSRT, [[CmmDecl]])
-toTops hsc_env topCAFEnv (topSRT, tops) gs =
+toTops :: Map CLabel CAFSet -> (TopSRT, [[CmmDecl]])
+       -> [(CAFSet, CmmDecl)] -> IO (TopSRT, [[CmmDecl]])
+toTops topCAFEnv (topSRT, tops) gs =
   do let setSRT (topSRT, rst) g =
            do (topSRT, gs) <- setInfoTableSRT topCAFEnv topSRT g
               return (topSRT, gs : rst)
-     (topSRT, gs') <- runFuelIO (hsc_OptFuel hsc_env) $ foldM setSRT (topSRT, []) gs
+     (topSRT, gs') <- runUniqSM $ foldM setSRT (topSRT, []) gs
      return (topSRT, concat gs' : tops)

compiler/cmm/CmmProcPoint.hs

@@ -13,19 +13,14 @@ import Prelude hiding (last, unzip, succ, zip)
 import BlockId
 import CLabel
 import Cmm
+import PprCmm ()
 import CmmUtils
-import CmmContFlowOpt
 import CmmInfo
-import CmmLive
-import Constants
 import Data.List (sortBy)
 import Maybes
-import MkGraph
 import Control.Monad
-import OptimizationFuel
 import Outputable
 import Platform
-import UniqSet
 import UniqSupply
 
 import Hoopl
@@ -106,7 +101,7 @@ instance Outputable Status where
 --------------------------------------------------
 -- Proc point analysis
 
-procPointAnalysis :: ProcPointSet -> CmmGraph -> FuelUniqSM (BlockEnv Status)
+procPointAnalysis :: ProcPointSet -> CmmGraph -> UniqSM (BlockEnv Status)
 -- Once you know what the proc-points are, figure out
 -- what proc-points each block is reachable from
 procPointAnalysis procPoints g =
@@ -156,13 +151,13 @@ callProcPoints g = foldGraphBlocks add (setSingleton (g_entry g)) g
                       _ -> set
 
 minimalProcPointSet :: Platform -> ProcPointSet -> CmmGraph
-                    -> FuelUniqSM ProcPointSet
+                    -> UniqSM ProcPointSet
 -- Given the set of successors of calls (which must be proc-points)
 -- figure out the minimal set of necessary proc-points
 minimalProcPointSet platform callProcPoints g
   = extendPPSet platform g (postorderDfs g) callProcPoints
 
-extendPPSet :: Platform -> CmmGraph -> [CmmBlock] -> ProcPointSet -> FuelUniqSM ProcPointSet
+extendPPSet :: Platform -> CmmGraph -> [CmmBlock] -> ProcPointSet -> UniqSM ProcPointSet
 extendPPSet platform g blocks procPoints =
     do env <- procPointAnalysis procPoints g
        -- pprTrace "extensPPSet" (ppr env) $ return ()
@@ -212,10 +207,9 @@ extendPPSet platform g blocks procPoints =
 -- ToDo: use the _ret naming convention that the old code generator
 -- used. -- EZY
 splitAtProcPoints :: CLabel -> ProcPointSet-> ProcPointSet -> BlockEnv Status ->
-                     CmmDecl -> FuelUniqSM [CmmDecl]
+                     CmmDecl -> UniqSM [CmmDecl]
 splitAtProcPoints entry_label callPPs procPoints procMap
-                  (CmmProc (TopInfo {info_tbl=info_tbl,
-                                     stack_info=stack_info})
+                  (CmmProc (TopInfo {info_tbl=info_tbl})
                            top_l g@(CmmGraph {g_entry=entry})) =
   do -- Build a map from procpoints to the blocks they reach
      let addBlock b graphEnv =

compiler/cmm/CmmRewriteAssignments.hs

@@ -18,10 +18,9 @@ module CmmRewriteAssignments
 import Cmm
 import CmmUtils
 import CmmOpt
-import OptimizationFuel
 import StgCmmUtils
 
-import Control.Monad
+import UniqSupply
 import Platform
 import UniqFM
 import Unique
@@ -29,12 +28,13 @@ import BlockId
 
 import Hoopl
 import Data.Maybe
+import Control.Monad
 import Prelude hiding (succ, zip)
 
 ----------------------------------------------------------------
 --- Main function
 
-rewriteAssignments :: Platform -> CmmGraph -> FuelUniqSM CmmGraph
+rewriteAssignments :: Platform -> CmmGraph -> UniqSM CmmGraph
 rewriteAssignments platform g = do
   -- Because we need to act on forwards and backwards information, we
   -- first perform usage analysis and bake this information into the
@@ -213,7 +213,7 @@ usageTransfer = mkBTransfer3 first middle last
           increaseUsage f r = addToUFM_C combine f r SingleUse
             where combine _ _ = ManyUse
 
-usageRewrite :: BwdRewrite FuelUniqSM (WithRegUsage CmmNode) UsageMap
+usageRewrite :: BwdRewrite UniqSM (WithRegUsage CmmNode) UsageMap
 usageRewrite = mkBRewrite3 first middle last
     where first  _ _ = return Nothing
           middle :: Monad m => WithRegUsage CmmNode O O -> UsageMap -> m (Maybe (Graph (WithRegUsage CmmNode) O O))
@@ -226,7 +226,7 @@ usageRewrite = mkBRewrite3 first middle last
           last   _ _ = return Nothing