Commit bfbdbcb9 authored by Simon Marlow's avatar Simon Marlow

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

parent 3f0afaba
...@@ -15,7 +15,7 @@ import Outputable ...@@ -15,7 +15,7 @@ import Outputable
import Unique import Unique
import Compiler.Hoopl as Hoopl hiding (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 --- Block Ids, their environments, and their sets
......
...@@ -32,9 +32,9 @@ module Cmm ( ...@@ -32,9 +32,9 @@ module Cmm (
import CLabel import CLabel
import BlockId import BlockId
import CmmNode import CmmNode
import OptimizationFuel as F
import SMRep import SMRep
import CmmExpr import CmmExpr
import UniqSupply
import Compiler.Hoopl import Compiler.Hoopl
import Data.Word ( Word8 ) import Data.Word ( Word8 )
...@@ -93,9 +93,9 @@ data GenCmmGraph n = CmmGraph { g_entry :: BlockId, g_graph :: Graph n C C } ...@@ -93,9 +93,9 @@ data GenCmmGraph n = CmmGraph { g_entry :: BlockId, g_graph :: Graph n C C }
type CmmBlock = Block CmmNode C C type CmmBlock = Block CmmNode C C
type CmmReplGraph e x = GenCmmReplGraph CmmNode e x type CmmReplGraph e x = GenCmmReplGraph CmmNode e x
type GenCmmReplGraph n e x = FuelUniqSM (Maybe (Graph n e x)) type GenCmmReplGraph n e x = UniqSM (Maybe (Graph n e x))
type CmmFwdRewrite f = FwdRewrite FuelUniqSM CmmNode f type CmmFwdRewrite f = FwdRewrite UniqSM CmmNode f
type CmmBwdRewrite f = BwdRewrite FuelUniqSM CmmNode f type CmmBwdRewrite f = BwdRewrite UniqSM CmmNode f
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
-- Info Tables -- Info Tables
......
...@@ -38,7 +38,6 @@ import IdInfo ...@@ -38,7 +38,6 @@ import IdInfo
import Data.List import Data.List
import Maybes import Maybes
import Name import Name
import OptimizationFuel
import Outputable import Outputable
import SMRep import SMRep
import UniqSupply import UniqSupply
...@@ -149,7 +148,7 @@ srtToData srt = [CmmData RelocatableReadOnlyData (Statics (lbl srt) tbl)] ...@@ -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 -- 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. -- bitmap will be able to cover all of them.
buildSRTs :: TopSRT -> Map CLabel CAFSet -> CAFSet -> buildSRTs :: TopSRT -> Map CLabel CAFSet -> CAFSet ->
FuelUniqSM (TopSRT, Maybe CmmDecl, C_SRT) UniqSM (TopSRT, Maybe CmmDecl, C_SRT)
buildSRTs topSRT topCAFMap cafs = buildSRTs topSRT topCAFMap cafs =
do let liftCAF lbl z = -- get CAFs for functions without static closures do let liftCAF lbl z = -- get CAFs for functions without static closures
case Map.lookup lbl topCAFMap of Just cafs -> z `Set.union` cafs case Map.lookup lbl topCAFMap of Just cafs -> z `Set.union` cafs
...@@ -192,7 +191,7 @@ buildSRTs topSRT topCAFMap cafs = ...@@ -192,7 +191,7 @@ buildSRTs topSRT topCAFMap cafs =
-- Construct an SRT bitmap. -- Construct an SRT bitmap.
-- Adapted from simpleStg/SRT.lhs, which expects Id's. -- Adapted from simpleStg/SRT.lhs, which expects Id's.
procpointSRT :: CLabel -> Map CLabel Int -> [CLabel] -> procpointSRT :: CLabel -> Map CLabel Int -> [CLabel] ->
FuelUniqSM (Maybe CmmDecl, C_SRT) UniqSM (Maybe CmmDecl, C_SRT)
procpointSRT _ _ [] = procpointSRT _ _ [] =
return (Nothing, NoC_SRT) return (Nothing, NoC_SRT)
procpointSRT top_srt top_table entries = procpointSRT top_srt top_table entries =
...@@ -210,7 +209,7 @@ maxBmpSize :: Int ...@@ -210,7 +209,7 @@ maxBmpSize :: Int
maxBmpSize = widthInBits wordWidth `div` 2 maxBmpSize = widthInBits wordWidth `div` 2
-- Adapted from codeGen/StgCmmUtils, which converts from SRT to C_SRT. -- 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 to_SRT top_srt off len bmp
| len > maxBmpSize || bmp == [fromIntegral srt_escape] | len > maxBmpSize || bmp == [fromIntegral srt_escape]
= do id <- getUniqueM = do id <- getUniqueM
...@@ -276,12 +275,12 @@ bundleCAFs _ t = (Set.empty, t) ...@@ -276,12 +275,12 @@ bundleCAFs _ t = (Set.empty, t)
-- Construct the SRTs for the given procedure. -- Construct the SRTs for the given procedure.
setInfoTableSRT :: Map CLabel CAFSet -> TopSRT -> (CAFSet, CmmDecl) -> setInfoTableSRT :: Map CLabel CAFSet -> TopSRT -> (CAFSet, CmmDecl) ->
FuelUniqSM (TopSRT, [CmmDecl]) UniqSM (TopSRT, [CmmDecl])
setInfoTableSRT topCAFMap topSRT (cafs, t) = setInfoTableSRT topCAFMap topSRT (cafs, t) =
setSRT cafs topCAFMap topSRT t setSRT cafs topCAFMap topSRT t
setSRT :: CAFSet -> Map CLabel CAFSet -> TopSRT -> setSRT :: CAFSet -> Map CLabel CAFSet -> TopSRT ->
CmmDecl -> FuelUniqSM (TopSRT, [CmmDecl]) CmmDecl -> UniqSM (TopSRT, [CmmDecl])
setSRT cafs topCAFMap topSRT t = setSRT cafs topCAFMap topSRT t =
do (topSRT, cafTable, srt) <- buildSRTs topSRT topCAFMap cafs do (topSRT, cafTable, srt) <- buildSRTs topSRT topCAFMap cafs
let t' = updInfo id (const srt) t let t' = updInfo id (const srt) t
......
...@@ -53,7 +53,6 @@ assignArgumentsPos conv arg_ty reps = assignments ...@@ -53,7 +53,6 @@ assignArgumentsPos conv arg_ty reps = assignments
([_], PrimOpReturn) -> allRegs ([_], PrimOpReturn) -> allRegs
(_, PrimOpReturn) -> getRegsWithNode (_, PrimOpReturn) -> getRegsWithNode
(_, Slow) -> noRegs (_, Slow) -> noRegs
_ -> pprPanic "Unknown calling convention" (ppr conv)
-- The calling conventions first assign arguments to registers, -- The calling conventions first assign arguments to registers,
-- then switch to the stack when we first run out of 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). -- (even if there are still available registers for args of a different type).
......
...@@ -20,7 +20,6 @@ import Hoopl hiding (ChangeFlag) ...@@ -20,7 +20,6 @@ import Hoopl hiding (ChangeFlag)
import Data.Bits import Data.Bits
import qualified Data.List as List import qualified Data.List as List
import Data.Word import Data.Word
import FastString
import Outputable import Outputable
import UniqFM import UniqFM
...@@ -95,7 +94,7 @@ hash_block block = ...@@ -95,7 +94,7 @@ hash_block block =
hash_lst m h = hash_node m + h `shiftL` 1 hash_lst m h = hash_node m + h `shiftL` 1
hash_node :: CmmNode O x -> Word32 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 (CmmAssign r e) = hash_reg r + hash_e e
hash_node (CmmStore e e') = hash_e e + 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 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 ...@@ -148,7 +147,7 @@ lookupBid subst bid = case mapLookup bid subst of
-- --
eqMiddleWith :: (BlockId -> BlockId -> Bool) eqMiddleWith :: (BlockId -> BlockId -> Bool)
-> CmmNode O O -> CmmNode O O -> 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) eqMiddleWith eqBid (CmmAssign r1 e1) (CmmAssign r2 e2)
= r1 == r2 && eqExprWith eqBid e1 e2 = r1 == r2 && eqExprWith eqBid e1 e2
eqMiddleWith eqBid (CmmStore l1 r1) (CmmStore l2 r2) eqMiddleWith eqBid (CmmStore l1 r1) (CmmStore l2 r2)
......
...@@ -97,7 +97,7 @@ blockConcat g@CmmGraph { g_entry = entry_id } ...@@ -97,7 +97,7 @@ blockConcat g@CmmGraph { g_entry = entry_id }
maybe_concat :: CmmBlock maybe_concat :: CmmBlock
-> (BlockEnv CmmBlock, BlockEnv BlockId) -> (BlockEnv CmmBlock, BlockEnv BlockId)
-> (BlockEnv CmmBlock, BlockEnv BlockId) -> (BlockEnv CmmBlock, BlockEnv BlockId)
maybe_concat block unchanged@(blocks, shortcut_map) maybe_concat block (blocks, shortcut_map)
| CmmBranch b' <- last | CmmBranch b' <- last
, Just blk' <- mapLookup b' blocks , Just blk' <- mapLookup b' blocks
, shouldConcatWith b' blk' , shouldConcatWith b' blk'
......
...@@ -32,7 +32,6 @@ import BlockId ...@@ -32,7 +32,6 @@ import BlockId
import CLabel import CLabel
import Unique import Unique
import Data.Map (Map)
import Data.Set (Set) import Data.Set (Set)
import qualified Data.Set as Set import qualified Data.Set as Set
......
...@@ -17,7 +17,6 @@ import CmmLive ...@@ -17,7 +17,6 @@ import CmmLive
import CmmProcPoint import CmmProcPoint
import SMRep import SMRep
import Hoopl hiding ((<*>), mkLast, mkMiddle) import Hoopl hiding ((<*>), mkLast, mkMiddle)
import OptimizationFuel
import Constants import Constants
import UniqSupply import UniqSupply
import Maybes import Maybes
...@@ -105,7 +104,7 @@ instance Outputable StackMap where ...@@ -105,7 +104,7 @@ instance Outputable StackMap where
cmmLayoutStack :: ProcPointSet -> ByteOff -> CmmGraph cmmLayoutStack :: ProcPointSet -> ByteOff -> CmmGraph
-> FuelUniqSM (CmmGraph, BlockEnv StackMap) -> UniqSM (CmmGraph, BlockEnv StackMap)
cmmLayoutStack procpoints entry_args cmmLayoutStack procpoints entry_args
graph0@(CmmGraph { g_entry = entry }) graph0@(CmmGraph { g_entry = entry })
= do = do
...@@ -114,12 +113,12 @@ cmmLayoutStack procpoints entry_args ...@@ -114,12 +113,12 @@ cmmLayoutStack procpoints entry_args
pprTrace "liveness" (ppr liveness) $ return () pprTrace "liveness" (ppr liveness) $ return ()
let blocks = postorderDfs graph 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) -> mfix $ \ ~(rec_stackmaps, rec_high_sp, _new_blocks) ->
layout procpoints liveness entry entry_args layout procpoints liveness entry entry_args
rec_stackmaps rec_high_sp blocks 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) $ pprTrace ("Sp HWM") (ppr final_high_sp) $
return (ofBlockList entry new_blocks', final_stackmaps) return (ofBlockList entry new_blocks', final_stackmaps)
...@@ -248,7 +247,7 @@ collectContInfo blocks ...@@ -248,7 +247,7 @@ collectContInfo blocks
-- Updating the StackMap from middle nodes -- Updating the StackMap from middle nodes
-- Look for loads from stack slots, and update the StackMap. This is -- 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 -- variable back to a different stack slot if it is already on the
-- stack. -- stack.
-- --
...@@ -361,6 +360,7 @@ handleLastNode procpoints liveness cont_info stackmaps ...@@ -361,6 +360,7 @@ handleLastNode procpoints liveness cont_info stackmaps
= setupStackFrame lbl liveness cml_ret_off cml_ret_args stack0 = 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 -- proc point, we have to set up the stack to match what the proc
-- point is expecting. -- point is expecting.
-- --
...@@ -701,7 +701,7 @@ manifestSp stackmaps stack0 sp0 sp_high ...@@ -701,7 +701,7 @@ manifestSp stackmaps stack0 sp0 sp_high
final_block = blockJoin first final_middle final_last 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) getAreaOff :: BlockEnv StackMap -> (Area -> StackLoc)
...@@ -982,7 +982,7 @@ stackSlotRegs sm = eltsUFM (sm_regs sm) ...@@ -982,7 +982,7 @@ stackSlotRegs sm = eltsUFM (sm_regs sm)
-- *but*, that will invalidate the liveness analysis, and we'll have -- *but*, that will invalidate the liveness analysis, and we'll have
-- to re-do it. -- to re-do it.
cmmSink :: CmmGraph -> FuelUniqSM CmmGraph cmmSink :: CmmGraph -> UniqSM CmmGraph
cmmSink graph = do cmmSink graph = do
let liveness = cmmLiveness graph let liveness = cmmLiveness graph
return $ cmmSink' liveness graph return $ cmmSink' liveness graph
......
...@@ -16,7 +16,6 @@ import CmmUtils ...@@ -16,7 +16,6 @@ import CmmUtils
import PprCmm () import PprCmm ()
import BlockId import BlockId
import FastString import FastString
import CLabel
import Outputable import Outputable
import Constants import Constants
......
...@@ -11,11 +11,10 @@ module CmmLive ...@@ -11,11 +11,10 @@ module CmmLive
) )
where where
import UniqSupply
import BlockId import BlockId
import Cmm import Cmm
import CmmUtils import CmmUtils
import Control.Monad
import OptimizationFuel
import PprCmmExpr () import PprCmmExpr ()
import Hoopl import Hoopl
...@@ -81,7 +80,7 @@ xferLive = mkBTransfer3 fst mid lst ...@@ -81,7 +80,7 @@ xferLive = mkBTransfer3 fst mid lst
-- Removing assignments to dead variables -- Removing assignments to dead variables
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
removeDeadAssignments :: CmmGraph -> FuelUniqSM (CmmGraph, BlockEnv CmmLive) removeDeadAssignments :: CmmGraph -> UniqSM (CmmGraph, BlockEnv CmmLive)
removeDeadAssignments g = removeDeadAssignments g =
dataflowPassBwd g [] $ analRewBwd liveLattice xferLive rewrites dataflowPassBwd g [] $ analRewBwd liveLattice xferLive rewrites
where rewrites = mkBRewrite3 nothing middle nothing where rewrites = mkBRewrite3 nothing middle nothing
......
...@@ -400,5 +400,5 @@ mapSuccessors :: (Label -> Label) -> CmmNode O C -> CmmNode O C ...@@ -400,5 +400,5 @@ mapSuccessors :: (Label -> Label) -> CmmNode O C -> CmmNode O C
mapSuccessors f (CmmBranch bid) = CmmBranch (f bid) mapSuccessors f (CmmBranch bid) = CmmBranch (f bid)
mapSuccessors f (CmmCondBranch p y n) = CmmCondBranch p (f y) (f n) 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 (CmmSwitch e arms) = CmmSwitch e (map (fmap f) arms)
mapSuccessors f n = n mapSuccessors _ n = n
...@@ -16,9 +16,9 @@ import CmmBuildInfoTables ...@@ -16,9 +16,9 @@ import CmmBuildInfoTables
import CmmCommonBlockElim import CmmCommonBlockElim
import CmmProcPoint import CmmProcPoint
import CmmContFlowOpt import CmmContFlowOpt
import OptimizationFuel
import CmmLayoutStack import CmmLayoutStack
import UniqSupply
import DynFlags import DynFlags
import ErrUtils import ErrUtils
import HscTypes import HscTypes
...@@ -65,7 +65,7 @@ cmmPipeline hsc_env topSRT prog = ...@@ -65,7 +65,7 @@ cmmPipeline hsc_env topSRT prog =
let topCAFEnv = {-# SCC "topCAFEnv" #-} mkTopCAFInfo (concat cafEnvs) let topCAFEnv = {-# SCC "topCAFEnv" #-} mkTopCAFInfo (concat cafEnvs)
-- folding over the groups -- 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 let cmms :: CmmGroup
cmms = reverse (concat tops) cmms = reverse (concat tops)
...@@ -101,17 +101,17 @@ cpsTop hsc_env (CmmProc h@(TopInfo {stack_info=StackInfo {arg_space=entry_off}}) ...@@ -101,17 +101,17 @@ cpsTop hsc_env (CmmProc h@(TopInfo {stack_info=StackInfo {arg_space=entry_off}})
----------- Proc points ------------------- ----------- Proc points -------------------
let callPPs = {-# SCC "callProcPoints" #-} callProcPoints g let callPPs = {-# SCC "callProcPoints" #-} callProcPoints g
procPoints <- {-# SCC "minimalProcPointSet" #-} run $ procPoints <- {-# SCC "minimalProcPointSet" #-} runUniqSM $
minimalProcPointSet (targetPlatform dflags) callPPs g minimalProcPointSet (targetPlatform dflags) callPPs g
----------- Layout the stack and manifest Sp --------------- ----------- Layout the stack and manifest Sp ---------------
-- (also does: removeDeadAssignments, and lowerSafeForeignCalls) -- (also does: removeDeadAssignments, and lowerSafeForeignCalls)
(g, stackmaps) <- {-# SCC "layoutStack" #-} (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 dump Opt_D_dump_cmmz_sp "Layout Stack" g
g <- {-# SCC "sink" #-} run $ cmmSink g -- g <- {-# SCC "sink" #-} runUniqSM $ cmmSink g
dump Opt_D_dump_cmmz_rewrite "Sink assignments" g -- dump Opt_D_dump_cmmz_rewrite "Sink assignments" g
-- ----------- Sink and inline assignments ------------------- -- ----------- Sink and inline assignments -------------------
-- g <- {-# SCC "rewriteAssignments" #-} runOptimization $ -- g <- {-# SCC "rewriteAssignments" #-} runOptimization $
...@@ -119,10 +119,10 @@ cpsTop hsc_env (CmmProc h@(TopInfo {stack_info=StackInfo {arg_space=entry_off}}) ...@@ -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 -- dump Opt_D_dump_cmmz_rewrite "Post rewrite assignments" g
------------- Split into separate procedures ------------ ------------- Split into separate procedures ------------
procPointMap <- {-# SCC "procPointAnalysis" #-} run $ procPointMap <- {-# SCC "procPointAnalysis" #-} runUniqSM $
procPointAnalysis procPoints g procPointAnalysis procPoints g
dumpWith dflags Opt_D_dump_cmmz_procmap "procpoint map" procPointMap 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) splitAtProcPoints l callPPs procPoints procPointMap (CmmProc h l g)
dumps Opt_D_dump_cmmz_split "Post splitting" gs 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}}) ...@@ -156,8 +156,10 @@ cpsTop hsc_env (CmmProc h@(TopInfo {stack_info=StackInfo {arg_space=entry_off}})
dumps flag name dumps flag name
= mapM_ (dumpWith dflags flag name) = mapM_ (dumpWith dflags flag name)
-- Runs a required transformation/analysis runUniqSM :: UniqSM a -> IO a
run = runInfiniteFuelIO (hsc_OptFuel hsc_env) runUniqSM m = do
us <- mkSplitUniqSupply 'u'
return (initUs_ us m)
dumpGraph :: DynFlags -> DynFlag -> String -> CmmGraph -> IO () dumpGraph :: DynFlags -> DynFlag -> String -> CmmGraph -> IO ()
...@@ -183,11 +185,11 @@ dumpWith dflags flag txt g = do ...@@ -183,11 +185,11 @@ dumpWith dflags flag txt g = do
-- This probably belongs in CmmBuildInfoTables? -- This probably belongs in CmmBuildInfoTables?
-- We're just finishing the job here: once we know what CAFs are defined -- We're just finishing the job here: once we know what CAFs are defined
-- in non-static closures, we can build the SRTs. -- in non-static closures, we can build the SRTs.
toTops :: HscEnv -> Map CLabel CAFSet -> (TopSRT, [[CmmDecl]]) toTops :: Map CLabel CAFSet -> (TopSRT, [[CmmDecl]])
-> [(CAFSet, CmmDecl)] -> IO (TopSRT, [[CmmDecl]]) -> [(CAFSet, CmmDecl)] -> IO (TopSRT, [[CmmDecl]])
toTops hsc_env topCAFEnv (topSRT, tops) gs = toTops topCAFEnv (topSRT, tops) gs =
do let setSRT (topSRT, rst) g = do let setSRT (topSRT, rst) g =
do (topSRT, gs) <- setInfoTableSRT topCAFEnv topSRT g do (topSRT, gs) <- setInfoTableSRT topCAFEnv topSRT g
return (topSRT, gs : rst) 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) return (topSRT, concat gs' : tops)
...@@ -13,19 +13,14 @@ import Prelude hiding (last, unzip, succ, zip) ...@@ -13,19 +13,14 @@ import Prelude hiding (last, unzip, succ, zip)
import BlockId import BlockId
import CLabel import CLabel
import Cmm import Cmm
import PprCmm ()
import CmmUtils import CmmUtils
import CmmContFlowOpt
import CmmInfo import CmmInfo
import CmmLive
import Constants
import Data.List (sortBy) import Data.List (sortBy)
import Maybes import Maybes
import MkGraph
import Control.Monad import Control.Monad
import OptimizationFuel
import Outputable import Outputable
import Platform import Platform
import UniqSet
import UniqSupply import UniqSupply
import Hoopl import Hoopl
...@@ -106,7 +101,7 @@ instance Outputable Status where ...@@ -106,7 +101,7 @@ instance Outputable Status where
-------------------------------------------------- --------------------------------------------------
-- Proc point analysis -- 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 -- Once you know what the proc-points are, figure out
-- what proc-points each block is reachable from -- what proc-points each block is reachable from
procPointAnalysis procPoints g = procPointAnalysis procPoints g =
...@@ -156,13 +151,13 @@ callProcPoints g = foldGraphBlocks add (setSingleton (g_entry g)) g ...@@ -156,13 +151,13 @@ callProcPoints g = foldGraphBlocks add (setSingleton (g_entry g)) g
_ -> set _ -> set
minimalProcPointSet :: Platform -> ProcPointSet -> CmmGraph minimalProcPointSet :: Platform -> ProcPointSet -> CmmGraph
-> FuelUniqSM ProcPointSet -> UniqSM ProcPointSet
-- Given the set of successors of calls (which must be proc-points) -- Given the set of successors of calls (which must be proc-points)
-- figure out the minimal set of necessary proc-points -- figure out the minimal set of necessary proc-points
minimalProcPointSet platform callProcPoints g minimalProcPointSet platform callProcPoints g
= extendPPSet platform g (postorderDfs g) callProcPoints = 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 = extendPPSet platform g blocks procPoints =
do env <- procPointAnalysis procPoints g do env <- procPointAnalysis procPoints g
-- pprTrace "extensPPSet" (ppr env) $ return () -- pprTrace "extensPPSet" (ppr env) $ return ()
...@@ -212,10 +207,9 @@ extendPPSet platform g blocks procPoints = ...@@ -212,10 +207,9 @@ extendPPSet platform g blocks procPoints =
-- ToDo: use the _ret naming convention that the old code generator -- ToDo: use the _ret naming convention that the old code generator
-- used. -- EZY -- used. -- EZY
splitAtProcPoints :: CLabel -> ProcPointSet-> ProcPointSet -> BlockEnv Status -> splitAtProcPoints :: CLabel -> ProcPointSet-> ProcPointSet -> BlockEnv Status ->
CmmDecl -> FuelUniqSM [CmmDecl] CmmDecl -> UniqSM [CmmDecl]
splitAtProcPoints entry_label callPPs procPoints procMap splitAtProcPoints entry_label callPPs procPoints procMap
(CmmProc (TopInfo {info_tbl=info_tbl, (CmmProc (TopInfo {info_tbl=info_tbl})
stack_info=stack_info})
top_l g@(CmmGraph {g_entry=entry})) = top_l g@(CmmGraph {g_entry=entry})) =
do -- Build a map from procpoints to the blocks they reach do -- Build a map from procpoints to the blocks they reach
let addBlock b graphEnv = let addBlock b graphEnv =
......
...@@ -18,10 +18,9 @@ module CmmRewriteAssignments ...@@ -18,10 +18,9 @@ module CmmRewriteAssignments
import Cmm import Cmm
import CmmUtils import CmmUtils
import CmmOpt import CmmOpt
import OptimizationFuel
import StgCmmUtils import StgCmmUtils
import Control.Monad import UniqSupply
import Platform import Platform
import UniqFM import UniqFM
import Unique import Unique
...@@ -29,12 +28,13 @@ import BlockId ...@@ -29,12 +28,13 @@ import BlockId
import Hoopl import Hoopl
import Data.Maybe import Data.Maybe
import Control.Monad
import Prelude hiding (succ, zip) import Prelude hiding (succ, zip)
---------------------------------------------------------------- ----------------------------------------------------------------
--- Main function --- Main function
rewriteAssignments :: Platform -> CmmGraph -> FuelUniqSM CmmGraph rewriteAssignments :: Platform -> CmmGraph -> UniqSM CmmGraph
rewriteAssignments platform g = do rewriteAssignments platform g = do
-- Because we need to act on forwards and backwards information, we -- Because we need to act on forwards and backwards information, we
-- first perform usage analysis and bake this information into the -- first perform usage analysis and bake this information into the
...@@ -213,7 +213,7 @@ usageTransfer = mkBTransfer3 first middle last ...@@ -213,7 +213,7 @@ usageTransfer = mkBTransfer3 first middle last
increaseUsage f r = addToUFM_C combine f r SingleUse increaseUsage f r = addToUFM_C combine f r SingleUse
where combine _ _ = ManyUse where combine _ _ = ManyUse
usageRewrite :: BwdRewrite FuelUniqSM (WithRegUsage CmmNode) UsageMap usageRewrite :: BwdRewrite UniqSM (WithRegUsage CmmNode) UsageMap
usageRewrite = mkBRewrite3 first middle last usageRewrite = mkBRewrite3 first middle last
where first _ _ = return Nothing where first _ _ = return Nothing
middle :: Monad m => WithRegUsage CmmNode O O -> UsageMap -> m (Maybe (Graph (WithRegUsage CmmNode) O O)) middle :: Monad m => WithRegUsage CmmNode O O -> UsageMap -> m (Maybe (Graph (WithRegUsage CmmNode) O O))
...@@ -226,7 +226,7 @@ usageRewrite = mkBRewrite3 first middle last ...@@ -226,7 +226,7 @@ usageRewrite = mkBRewrite3 first middle last
last _ _ = return Nothing last _ _ = return Nothing
type CmmGraphWithRegUsage = GenCmmGraph (WithRegUsage CmmNode) type CmmGraphWithRegUsage = GenCmmGraph (WithRegUsage CmmNode)
annotateUsage :: CmmGraph -> FuelUniqSM (CmmGraphWithRegUsage) annotateUsage :: CmmGraph -> UniqSM (CmmGraphWithRegUsage)
annotateUsage vanilla_g = annotateUsage vanilla_g =
let g = modifyGraph liftRegUsage vanilla_g let g = modifyGraph liftRegUsage vanilla_g
in liftM fst $ dataflowPassBwd g [(g_entry g, fact_bot usageLattice)] $ in liftM fst $ dataflowPassBwd g [(g_entry g, fact_bot usageLattice)] $
...@@ -524,7 +524,7 @@ assignmentTransfer = mkFTransfer3 (flip const) middleAssignment ((mkFactBase ass ...@@ -524,7 +524,7 @@ assignmentTransfer = mkFTransfer3 (flip const) middleAssignment ((mkFactBase ass
-- values from the assignment map, due to reassignment of the local -- values from the assignment map, due to reassignment of the local
-- register.) This is probably not locally sound. -- register.) This is probably not locally sound.
assignmentRewrite :: FwdRewrite FuelUniqSM (WithRegUsage CmmNode) AssignmentMap assignmentRewrite :: FwdRewrite UniqSM (WithRegUsage CmmNode) AssignmentMap
assignmentRewrite = mkFRewrite3 first middle last assignmentRewrite = mkFRewrite3 first middle last
where where
first _ _ = return Nothing first _ _ = return Nothing
...@@ -605,7 +605,7 @@ assignmentRewrite = mkFRewrite3 first middle last ...@@ -605,7 +605,7 @@ assignmentRewrite = mkFRewrite3 first middle last
-- in literals, which we can inline more aggressively, and inlining -- in literals, which we can inline more aggressively, and inlining
-- gives us opportunities for more folding. However, we don't need any -- gives us opportunities for more folding. However, we don't need any
-- facts to do MachOp folding. -- facts to do MachOp folding.
machOpFoldRewrite :: Platform -> FwdRewrite FuelUniqSM (WithRegUsage CmmNode) a machOpFoldRewrite :: Platform -> FwdRewrite UniqSM (WithRegUsage CmmNode) a
machOpFoldRewrite platform = mkFRewrite3 first middle last machOpFoldRewrite platform = mkFRewrite3 first middle last
where first _ _ = return Nothing where first _ _ = return Nothing
middle :: WithRegUsage CmmNode O O -> a -> GenCmmReplGraph (WithRegUsage CmmNode) O O middle :: WithRegUsage CmmNode O O -> a -> GenCmmReplGraph (WithRegUsage CmmNode) O O
......
...@@ -35,7 +35,6 @@ import CmmProcPoint ...@@ -35,7 +35,6 @@ import CmmProcPoint
import Maybes import Maybes
import MkGraph (stackStubExpr) import MkGraph (stackStubExpr)
import Control.Monad import Control.Monad
import OptimizationFuel
import Outputable import Outputable
import SMRep (ByteOff) import SMRep (ByteOff)
......
...@@ -80,7 +80,6 @@ import Cmm ...@@ -80,7 +80,6 @@ import Cmm
import BlockId import BlockId
import CLabel import CLabel
import Outputable import Outputable
import OptimizationFuel as F
import Unique import Unique
import UniqSupply import UniqSupply
import Constants( wORD_SIZE, tAG_MASK ) import Constants( wORD_SIZE, tAG_MASK )
...@@ -89,7 +88,6 @@ import Util ...@@ -89,7 +88,6 @@ import Util
import Data.Word import Data.Word
import Data.Maybe import Data.Maybe
import Data.Bits import Data.Bits
import Control.Monad
import Hoopl import Hoopl
--------------------------------------------------- ---------------------------------------------------
...@@ -431,10 +429,10 @@ mapGraphNodes :: ( CmmNode C O -> CmmNode C O ...@@ -431,10 +429,10 @@ mapGraphNodes :: ( CmmNode C O -> CmmNode C O
, CmmNode O C