X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fcmm%2FOptimizationFuel.hs;h=f624c1c7b6c42c7719832842bc82fdd9cf03d9fe;hp=5e400c4009f14916d7318a485a2840685cf11fcc;hb=e5c3b478b3cd1707cf122833822f44b2ac09b8e9;hpb=31a9d04804d9cacda35695c5397590516b964964 diff --git a/compiler/cmm/OptimizationFuel.hs b/compiler/cmm/OptimizationFuel.hs index 5e400c4..f624c1c 100644 --- a/compiler/cmm/OptimizationFuel.hs +++ b/compiler/cmm/OptimizationFuel.hs @@ -1,25 +1,30 @@ +{-# 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 +-- it runs out of fuel. This can be used e.g. to debug optimiser bugs: Run +-- 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 - , runFuelIO, fuelConsumingPass - , FuelMonad + ( OptimizationFuel, amountOfFuel, tankFilledTo, unlimitedFuel, anyFuelLeft, oneLessFuel + , OptFuelState, initOptFuelState + , FuelConsumer, FuelUsingMonad, FuelState + , fuelGet, fuelSet, lastFuelPass, setFuelPass + , fuelExhausted, fuelDec1, tryWithFuel + , runFuelIO, runInfiniteFuelIO, fuelConsumingPass + , 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 Monad +import Control.Monad import StaticFlags (opt_Fuel) import UniqSupply +import Panic + +import Compiler.Hoopl +import Compiler.Hoopl.GHC (getFuel, setFuel) #include "HsVersions.h" @@ -39,45 +44,35 @@ 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 +unlimitedFuel :: 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 -#endif - -data FuelState = FuelState { fs_fuellimit :: OptimizationFuel, fs_lastpass :: String } -newtype FuelMonad a = FuelMonad (FuelState -> UniqSM (a, FuelState)) - -fuelConsumingPass :: String -> FuelConsumer a -> FuelMonad a -fuelConsumingPass name f = do fuel <- fuelRemaining +unlimitedFuel = OptimizationFuel infiniteFuel + +data FuelState = FuelState { fs_fuel :: OptimizationFuel, fs_lastpass :: String } +newtype FuelUniqSM a = FUSM { unFUSM :: FuelState -> UniqSM (a, FuelState) } + +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' @@ -86,49 +81,61 @@ 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)) +-- ToDo: Do we need the pass_ref when we are doing infinite fueld +-- transformations? +runInfiniteFuelIO :: OptFuelState -> FuelUniqSM a -> IO a +runInfiniteFuelIO fs (FUSM f) = + do pass <- readIORef (pass_ref fs) + u <- mkSplitUniqSupply 'u' + let (a, FuelState _ pass') = initUs_ u $ f (FuelState unlimitedFuel pass) + writeIORef (pass_ref fs) pass' + return a + +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) +