X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fcmm%2FOptimizationFuel.hs;h=f624c1c7b6c42c7719832842bc82fdd9cf03d9fe;hp=6e05cdc68bb23f2939856a6bd9c3f80bf57f8b20;hb=e5c3b478b3cd1707cf122833822f44b2ac09b8e9;hpb=206b4dec78250efef3cd927d64dc6cbc54a16c3d diff --git a/compiler/cmm/OptimizationFuel.hs b/compiler/cmm/OptimizationFuel.hs index 6e05cdc..f624c1c 100644 --- a/compiler/cmm/OptimizationFuel.hs +++ b/compiler/cmm/OptimizationFuel.hs @@ -1,124 +1,141 @@ +{-# 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 - , tankFilledTo, diffFuel - , FuelConsumer - , FuelUsingMonad, FuelState - , lastFuelPass, fuelExhausted, fuelRemaining, fuelDecrement - , lastFuelPassInState, fuelExhaustedInState, fuelRemainingInState - , fuelDecrementState - , runFuel, runFuelIO, runFuelWithLastPass, 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 ) where ---import GHC.Exts (State#) +import Data.IORef +import Control.Monad +import StaticFlags (opt_Fuel) +import UniqSupply import Panic -import Data.IORef +import Compiler.Hoopl +import Compiler.Hoopl.GHC (getFuel, setFuel) #include "HsVersions.h" + +-- We limit the number of transactions executed using a record of flags +-- stored in an HscEnv. The flags store the name of the last optimization +-- pass and the amount of optimization fuel remaining. +data OptFuelState = + OptFuelState { pass_ref :: IORef String + , fuel_ref :: IORef OptimizationFuel + } +initOptFuelState :: IO OptFuelState +initOptFuelState = + do pass_ref' <- newIORef "unoptimized program" + fuel_ref' <- newIORef (tankFilledTo opt_Fuel) + return OptFuelState {pass_ref = pass_ref', fuel_ref = fuel_ref'} + 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 -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 _ = undefined -- should be impossible to evaluate - -- realWorld# might come in handy, too... -canRewriteWithFuel OptimizationFuel = True -maybeRewriteWithFuel _ ma = ma -oneLessFuel f = f -diffFuel _ _ = 0 -#endif - --- stop warnings about things that aren't used -_unused :: {-State#-} () -> FS.FastString -_unused = undefined panic +amountOfFuel (OptimizationFuel f) = f +anyFuelLeft (OptimizationFuel f) = f > 0 +oneLessFuel (OptimizationFuel f) = ASSERT (f > 0) (OptimizationFuel (f - 1)) +unlimitedFuel = OptimizationFuel infiniteFuel -data FuelState = FuelState { fs_fuellimit :: OptimizationFuel, fs_lastpass :: String } -newtype FuelMonad a = FuelMonad (FuelState -> (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 -runFuel :: FuelMonad a -> FuelConsumer a -runFuelWithLastPass :: FuelMonad a -> FuelConsumer (a, String) - -runFuelIO :: IORef String -> IORef OptimizationFuel -> FuelMonad a -> IO a -runFuelIO pass_ref fuel_ref (FuelMonad f) = - do { pass <- readIORef pass_ref - ; fuel <- readIORef fuel_ref - ; let (a, FuelState fuel' pass') = f (FuelState fuel pass) - ; writeIORef pass_ref pass' - ; writeIORef fuel_ref fuel' - ; return a - } - -initialFuelState :: OptimizationFuel -> FuelState -initialFuelState fuel = FuelState fuel "unoptimized program" - -runFuel (FuelMonad f) fuel = let (a, s) = f $ initialFuelState fuel - in (a, fs_fuellimit s) -runFuelWithLastPass (FuelMonad f) fuel = let (a, s) = f $ initialFuelState fuel - in ((a, fs_lastpass s), fs_fuellimit s) - -lastFuelPassInState :: FuelState -> String -lastFuelPassInState = fs_lastpass - -fuelExhaustedInState :: FuelState -> Bool -fuelExhaustedInState = canRewriteWithFuel . fs_fuellimit - -fuelRemainingInState :: FuelState -> OptimizationFuel -fuelRemainingInState = fs_fuellimit - -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 +runFuelIO :: OptFuelState -> FuelUniqSM a -> IO a +runFuelIO fs (FUSM f) = + do pass <- readIORef (pass_ref fs) + fuel <- readIORef (fuel_ref fs) + u <- mkSplitUniqSupply 'u' + let (a, FuelState fuel' pass') = initUs_ u $ f (FuelState fuel pass) + writeIORef (pass_ref fs) pass' + writeIORef (fuel_ref fs) fuel' + return a + +-- 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 FuelUniqSM where + getUniqueSupplyM = liftUniq getUniqueSupplyM + getUniqueM = liftUniq getUniqueM + getUniquesM = liftUniq getUniquesM + +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 () - fuelExhausted :: m Bool - lastFuelPass :: m String - - -instance Monad FuelMonad where - FuelMonad f >>= k = FuelMonad (\s -> let (a, s') = f s - FuelMonad f' = k a - in f' s') - return a = FuelMonad (\s -> (a, s)) - -instance FuelUsingMonad FuelMonad where - fuelRemaining = extract fuelRemainingInState - lastFuelPass = extract lastFuelPassInState - fuelExhausted = extract fuelExhaustedInState - fuelDecrement p f f' = FuelMonad (\s -> ((), fuelDecrementState p f f' s)) - -extract :: (FuelState -> a) -> FuelMonad a -extract f = FuelMonad (\s -> (f s, s)) + 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) +