1 module OptimizationFuel
2 ( OptimizationFuel, canRewriteWithFuel, maybeRewriteWithFuel, oneLessFuel
3 , tankFilledTo, diffFuel
5 , FuelUsingMonad, FuelState
6 , lastFuelPass, fuelExhausted, fuelRemaining, fuelDecrement
7 , lastFuelPassInState, fuelExhaustedInState, fuelRemainingInState
9 , runFuel, runFuelIO, runFuelWithLastPass, fuelConsumingPass
19 #include "HsVersions.h"
21 type FuelConsumer a = OptimizationFuel -> (a, OptimizationFuel)
23 canRewriteWithFuel :: OptimizationFuel -> Bool
24 oneLessFuel :: OptimizationFuel -> OptimizationFuel
25 maybeRewriteWithFuel :: OptimizationFuel -> Maybe a -> Maybe a
26 diffFuel :: OptimizationFuel -> OptimizationFuel -> Int
27 -- to measure consumption during compilation
28 tankFilledTo :: Int -> OptimizationFuel
31 newtype OptimizationFuel = OptimizationFuel Int
34 tankFilledTo = OptimizationFuel
35 canRewriteWithFuel (OptimizationFuel f) = f > 0
36 maybeRewriteWithFuel fuel ma = if canRewriteWithFuel fuel then ma else Nothing
37 oneLessFuel (OptimizationFuel f) = ASSERT (f > 0) (OptimizationFuel (f - 1))
38 diffFuel (OptimizationFuel f) (OptimizationFuel f') = f - f'
40 -- type OptimizationFuel = State# () -- would like this, but it won't work
41 data OptimizationFuel = OptimizationFuel
43 tankFilledTo _ = undefined -- should be impossible to evaluate
44 -- realWorld# might come in handy, too...
45 canRewriteWithFuel OptimizationFuel = True
46 maybeRewriteWithFuel _ ma = ma
51 -- stop warnings about things that aren't used
52 _unused :: State# () -> FS.FastString
53 _unused = undefined panic
56 data FuelState = FuelState { fs_fuellimit :: OptimizationFuel, fs_lastpass :: String }
57 newtype FuelMonad a = FuelMonad (FuelState -> (a, FuelState))
59 fuelConsumingPass :: String -> FuelConsumer a -> FuelMonad a
60 fuelConsumingPass name f = do fuel <- fuelRemaining
61 let (a, fuel') = f fuel
62 fuelDecrement name fuel fuel'
65 runFuel :: FuelMonad a -> FuelConsumer a
66 runFuelWithLastPass :: FuelMonad a -> FuelConsumer (a, String)
68 runFuelIO :: IORef String -> IORef OptimizationFuel -> FuelMonad a -> IO a
69 runFuelIO pass_ref fuel_ref (FuelMonad f) =
70 do { pass <- readIORef pass_ref
71 ; fuel <- readIORef fuel_ref
72 ; let (a, FuelState fuel' pass') = f (FuelState fuel pass)
73 ; writeIORef pass_ref pass'
74 ; writeIORef fuel_ref fuel'
78 initialFuelState :: OptimizationFuel -> FuelState
79 initialFuelState fuel = FuelState fuel "unoptimized program"
81 runFuel (FuelMonad f) fuel = let (a, s) = f $ initialFuelState fuel
82 in (a, fs_fuellimit s)
83 runFuelWithLastPass (FuelMonad f) fuel = let (a, s) = f $ initialFuelState fuel
84 in ((a, fs_lastpass s), fs_fuellimit s)
86 lastFuelPassInState :: FuelState -> String
87 lastFuelPassInState = fs_lastpass
89 fuelExhaustedInState :: FuelState -> Bool
90 fuelExhaustedInState = canRewriteWithFuel . fs_fuellimit
92 fuelRemainingInState :: FuelState -> OptimizationFuel
93 fuelRemainingInState = fs_fuellimit
96 :: String -> OptimizationFuel -> OptimizationFuel -> FuelState -> FuelState
97 fuelDecrementState new_optimizer old new s =
98 FuelState { fs_fuellimit = lim, fs_lastpass = optimizer }
99 where lim = if diffFuel old (fs_fuellimit s) == 0 then new
101 concat ["lost track of ", new_optimizer, "'s transactions"]
102 optimizer = if diffFuel old new > 0 then new_optimizer else fs_lastpass s
104 class Monad m => FuelUsingMonad m where
105 fuelRemaining :: m OptimizationFuel
106 fuelDecrement :: String -> OptimizationFuel -> OptimizationFuel -> m ()
107 fuelExhausted :: m Bool
108 lastFuelPass :: m String
111 instance Monad FuelMonad where
112 FuelMonad f >>= k = FuelMonad (\s -> let (a, s') = f s
115 return a = FuelMonad (\s -> (a, s))
117 instance FuelUsingMonad FuelMonad where
118 fuelRemaining = extract fuelRemainingInState
119 lastFuelPass = extract lastFuelPassInState
120 fuelExhausted = extract fuelExhaustedInState
121 fuelDecrement p f f' = FuelMonad (\s -> ((), fuelDecrementState p f f' s))
123 extract :: (FuelState -> a) -> FuelMonad a
124 extract f = FuelMonad (\s -> (f s, s))