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
14 --import GHC.Exts (State#)
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 data FuelState = FuelState { fs_fuellimit :: OptimizationFuel, fs_lastpass :: String }
52 newtype FuelMonad a = FuelMonad (FuelState -> (a, FuelState))
54 fuelConsumingPass :: String -> FuelConsumer a -> FuelMonad a
55 fuelConsumingPass name f = do fuel <- fuelRemaining
56 let (a, fuel') = f fuel
57 fuelDecrement name fuel fuel'
60 runFuel :: FuelMonad a -> FuelConsumer a
61 runFuelWithLastPass :: FuelMonad a -> FuelConsumer (a, String)
63 runFuelIO :: IORef String -> IORef OptimizationFuel -> FuelMonad a -> IO a
64 runFuelIO pass_ref fuel_ref (FuelMonad f) =
65 do { pass <- readIORef pass_ref
66 ; fuel <- readIORef fuel_ref
67 ; let (a, FuelState fuel' pass') = f (FuelState fuel pass)
68 ; writeIORef pass_ref pass'
69 ; writeIORef fuel_ref fuel'
73 initialFuelState :: OptimizationFuel -> FuelState
74 initialFuelState fuel = FuelState fuel "unoptimized program"
76 runFuel (FuelMonad f) fuel = let (a, s) = f $ initialFuelState fuel
77 in (a, fs_fuellimit s)
78 runFuelWithLastPass (FuelMonad f) fuel = let (a, s) = f $ initialFuelState fuel
79 in ((a, fs_lastpass s), fs_fuellimit s)
81 lastFuelPassInState :: FuelState -> String
82 lastFuelPassInState = fs_lastpass
84 fuelExhaustedInState :: FuelState -> Bool
85 fuelExhaustedInState = canRewriteWithFuel . fs_fuellimit
87 fuelRemainingInState :: FuelState -> OptimizationFuel
88 fuelRemainingInState = fs_fuellimit
91 :: String -> OptimizationFuel -> OptimizationFuel -> FuelState -> FuelState
92 fuelDecrementState new_optimizer old new s =
93 FuelState { fs_fuellimit = lim, fs_lastpass = optimizer }
94 where lim = if diffFuel old (fs_fuellimit s) == 0 then new
96 concat ["lost track of ", new_optimizer, "'s transactions"]
97 optimizer = if diffFuel old new > 0 then new_optimizer else fs_lastpass s
99 class Monad m => FuelUsingMonad m where
100 fuelRemaining :: m OptimizationFuel
101 fuelDecrement :: String -> OptimizationFuel -> OptimizationFuel -> m ()
102 fuelExhausted :: m Bool
103 lastFuelPass :: m String
106 instance Monad FuelMonad where
107 FuelMonad f >>= k = FuelMonad (\s -> let (a, s') = f s
110 return a = FuelMonad (\s -> (a, s))
112 instance FuelUsingMonad FuelMonad where
113 fuelRemaining = extract fuelRemainingInState
114 lastFuelPass = extract lastFuelPassInState
115 fuelExhausted = extract fuelExhaustedInState
116 fuelDecrement p f f' = FuelMonad (\s -> ((), fuelDecrementState p f f' s))
118 extract :: (FuelState -> a) -> FuelMonad a
119 extract f = FuelMonad (\s -> (f s, s))