+{-# 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
- --, lastFuelPassInState , fuelExhaustedInState, fuelRemainingInState
- --, fuelDecrementState
- --, runFuel
- , runFuelIO
- --, runFuelWithLastPass
- , fuelConsumingPass
- , FuelMonad
+ ( OptimizationFuel, amountOfFuel, tankFilledTo, anyFuelLeft, oneLessFuel
+ , OptFuelState, initOptFuelState
+ , FuelConsumer, FuelUsingMonad, FuelState
+ , fuelGet, fuelSet, lastFuelPass, setFuelPass
+ , fuelExhausted, fuelDec1, tryWithFuel
+ , runFuelIO, fuelConsumingPass
+ , FuelUniqSM
, liftUniq
- , lGraphOfGraph -- needs to be able to create a unique ID...
)
where
-import StackSlot
-import ZipCfg
-
---import GHC.Exts (State#)
-import Panic
-
import Data.IORef
-import Monad
+import Control.Monad
import StaticFlags (opt_Fuel)
import UniqSupply
+#ifdef DEBUG
+import Panic
+#endif
+
+import Compiler.Hoopl
+import Compiler.Hoopl.GHC (getFuel, setFuel)
#include "HsVersions.h"
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 _ = undefined -- 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'
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)
-
-
--- JD: I'm not sure what NR's plans are for the following code.
--- Perhaps these functions will be useful in the future, or perhaps I've made
--- them obsoltete.
-
---initialFuelState :: OptimizationFuel -> FuelState
---initialFuelState fuel = FuelState fuel "unoptimized program"
---runFuel :: FuelMonad a -> FuelConsumer a
---runFuelWithLastPass :: FuelMonad a -> FuelConsumer (a, String)
-
---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
+ 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)