X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fcmm%2FOptimizationFuel.hs;h=e1f1e3c39e5c8440169d763a347c61e1f8cd1500;hp=175dcd09b18a4c602cb9531796d0f4b7abf89673;hb=889c084e943779e76d19f2ef5e970ff655f511eb;hpb=f1a90f54590e5a7a32a9c3ef2950740922b1f425 diff --git a/compiler/cmm/OptimizationFuel.hs b/compiler/cmm/OptimizationFuel.hs index 175dcd0..e1f1e3c 100644 --- a/compiler/cmm/OptimizationFuel.hs +++ b/compiler/cmm/OptimizationFuel.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE TypeFamilies #-} -- | Optimisation fuel is used to control the amount of work the optimiser does. -- -- Every optimisation step consumes a certain amount of fuel and stops when @@ -5,27 +6,25 @@ -- the optimiser with varying amount of fuel to find out the exact number of -- steps where a bug is introduced in the output. module OptimizationFuel - ( OptimizationFuel, canRewriteWithFuel, maybeRewriteWithFuel, oneLessFuel - , OptFuelState, initOptFuelState --, setTotalFuel - , tankFilledTo, diffFuel - , FuelConsumer - , FuelUsingMonad, FuelState - , lastFuelPass, fuelExhausted, fuelRemaining, fuelDecrement, fuelDec1 + ( OptimizationFuel, amountOfFuel, tankFilledTo, anyFuelLeft, oneLessFuel + , OptFuelState, initOptFuelState + , FuelConsumer, FuelUsingMonad, FuelState + , fuelGet, fuelSet, lastFuelPass, setFuelPass + , fuelExhausted, fuelDec1, tryWithFuel , runFuelIO, fuelConsumingPass - , FuelMonad + , FuelUniqSM , liftUniq - , lGraphOfGraph -- needs to be able to create a unique ID... ) where -import BlockId -import ZipCfg ---import GHC.Exts (State#) -import Panic import Data.IORef import Control.Monad import StaticFlags (opt_Fuel) import UniqSupply +import Panic () + +import Compiler.Hoopl +import Compiler.Hoopl.GHC (getFuel, setFuel) #include "HsVersions.h" @@ -45,45 +44,44 @@ initOptFuelState = type FuelConsumer a = OptimizationFuel -> (a, OptimizationFuel) -canRewriteWithFuel :: OptimizationFuel -> Bool -oneLessFuel :: OptimizationFuel -> OptimizationFuel -maybeRewriteWithFuel :: OptimizationFuel -> Maybe a -> Maybe a -diffFuel :: OptimizationFuel -> OptimizationFuel -> Int - -- to measure consumption during compilation tankFilledTo :: Int -> OptimizationFuel +amountOfFuel :: OptimizationFuel -> Int + +anyFuelLeft :: OptimizationFuel -> Bool +oneLessFuel :: OptimizationFuel -> OptimizationFuel #ifdef DEBUG newtype OptimizationFuel = OptimizationFuel Int deriving Show tankFilledTo = OptimizationFuel -canRewriteWithFuel (OptimizationFuel f) = f > 0 -maybeRewriteWithFuel fuel ma = if canRewriteWithFuel fuel then ma else Nothing +amountOfFuel (OptimizationFuel f) = f + +anyFuelLeft (OptimizationFuel f) = f > 0 oneLessFuel (OptimizationFuel f) = ASSERT (f > 0) (OptimizationFuel (f - 1)) -diffFuel (OptimizationFuel f) (OptimizationFuel f') = f - f' #else -- type OptimizationFuel = State# () -- would like this, but it won't work data OptimizationFuel = OptimizationFuel deriving Show -tankFilledTo _ = panic "tankFilledTo" -- should be impossible to evaluate - -- realWorld# might come in handy, too... -canRewriteWithFuel OptimizationFuel = True -maybeRewriteWithFuel _ ma = ma -oneLessFuel f = f -diffFuel _ _ = 0 +tankFilledTo _ = OptimizationFuel +amountOfFuel _ = maxBound + +anyFuelLeft _ = True +oneLessFuel _ = OptimizationFuel #endif -data FuelState = FuelState { fs_fuellimit :: OptimizationFuel, fs_lastpass :: String } -newtype FuelMonad a = FuelMonad (FuelState -> UniqSM (a, FuelState)) +data FuelState = FuelState { fs_fuel :: OptimizationFuel, fs_lastpass :: String } +newtype FuelUniqSM a = FUSM { unFUSM :: FuelState -> UniqSM (a, FuelState) } -fuelConsumingPass :: String -> FuelConsumer a -> FuelMonad a -fuelConsumingPass name f = do fuel <- fuelRemaining +fuelConsumingPass :: String -> FuelConsumer a -> FuelUniqSM a +fuelConsumingPass name f = do setFuelPass name + fuel <- fuelGet let (a, fuel') = f fuel - fuelDecrement name fuel fuel' + fuelSet fuel' return a -runFuelIO :: OptFuelState -> FuelMonad a -> IO a -runFuelIO fs (FuelMonad f) = +runFuelIO :: OptFuelState -> FuelUniqSM a -> IO a +runFuelIO fs (FUSM f) = do pass <- readIORef (pass_ref fs) fuel <- readIORef (fuel_ref fs) u <- mkSplitUniqSupply 'u' @@ -92,49 +90,51 @@ runFuelIO fs (FuelMonad f) = writeIORef (fuel_ref fs) fuel' return a -instance Monad FuelMonad where - FuelMonad f >>= k = FuelMonad (\s -> do (a, s') <- f s - let FuelMonad f' = k a in (f' s')) - return a = FuelMonad (\s -> return (a, s)) +instance Monad FuelUniqSM where + FUSM f >>= k = FUSM (\s -> f s >>= \(a, s') -> unFUSM (k a) s') + return a = FUSM (\s -> return (a, s)) -instance MonadUnique FuelMonad where +instance MonadUnique FuelUniqSM where getUniqueSupplyM = liftUniq getUniqueSupplyM getUniqueM = liftUniq getUniqueM getUniquesM = liftUniq getUniquesM -liftUniq :: UniqSM x -> FuelMonad x -liftUniq x = FuelMonad (\s -> x >>= (\u -> return (u, s))) + +liftUniq :: UniqSM x -> FuelUniqSM x +liftUniq x = FUSM (\s -> x >>= (\u -> return (u, s))) class Monad m => FuelUsingMonad m where - fuelRemaining :: m OptimizationFuel - fuelDecrement :: String -> OptimizationFuel -> OptimizationFuel -> m () - fuelDec1 :: m () - fuelExhausted :: m Bool - lastFuelPass :: m String - -instance FuelUsingMonad FuelMonad where - fuelRemaining = extract fs_fuellimit - lastFuelPass = extract fs_lastpass - fuelExhausted = extract $ not . canRewriteWithFuel . fs_fuellimit - fuelDecrement p f f' = FuelMonad (\s -> return ((), fuelDecrementState p f f' s)) - fuelDec1 = FuelMonad f - where f s = if canRewriteWithFuel (fs_fuellimit s) then - return ((), s { fs_fuellimit = oneLessFuel (fs_fuellimit s) }) - else panic "Tried to use exhausted fuel supply" - -extract :: (FuelState -> a) -> FuelMonad a -extract f = FuelMonad (\s -> return (f s, s)) - -fuelDecrementState - :: String -> OptimizationFuel -> OptimizationFuel -> FuelState -> FuelState -fuelDecrementState new_optimizer old new s = - FuelState { fs_fuellimit = lim, fs_lastpass = optimizer } - where lim = if diffFuel old (fs_fuellimit s) == 0 then new - else panic $ - concat ["lost track of ", new_optimizer, "'s transactions"] - optimizer = if diffFuel old new > 0 then new_optimizer else fs_lastpass s - --- lGraphOfGraph is here because we need uniques to implement it. -lGraphOfGraph :: Graph m l -> FuelMonad (LGraph m l) -lGraphOfGraph (Graph tail blocks) = - do entry <- liftM BlockId $ getUniqueM - return $ LGraph entry (insertBlock (Block entry tail) blocks) + fuelGet :: m OptimizationFuel + fuelSet :: OptimizationFuel -> m () + lastFuelPass :: m String + setFuelPass :: String -> m () + +fuelExhausted :: FuelUsingMonad m => m Bool +fuelExhausted = fuelGet >>= return . anyFuelLeft + +fuelDec1 :: FuelUsingMonad m => m () +fuelDec1 = fuelGet >>= fuelSet . oneLessFuel + +tryWithFuel :: FuelUsingMonad m => a -> m (Maybe a) +tryWithFuel r = do f <- fuelGet + if anyFuelLeft f then fuelSet (oneLessFuel f) >> return (Just r) + else return Nothing + +instance FuelUsingMonad FuelUniqSM where + fuelGet = extract fs_fuel + lastFuelPass = extract fs_lastpass + fuelSet fuel = FUSM (\s -> return ((), s { fs_fuel = fuel })) + setFuelPass pass = FUSM (\s -> return ((), s { fs_lastpass = pass })) + +extract :: (FuelState -> a) -> FuelUniqSM a +extract f = FUSM (\s -> return (f s, s)) + +instance FuelMonad FuelUniqSM where + getFuel = liftM amountOfFuel fuelGet + setFuel = fuelSet . tankFilledTo + +-- Don't bother to checkpoint the unique supply; it doesn't matter +instance CheckpointMonad FuelUniqSM where + type Checkpoint FuelUniqSM = FuelState + checkpoint = FUSM $ \fuel -> return (fuel, fuel) + restart fuel = FUSM $ \_ -> return ((), fuel) +