+{-# 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.Prim
+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)
+
projects / ghc-hetmet.git / blobdiff