1 module OptimizationFuel
2 ( OptimizationFuel , canRewriteWithFuel, maybeRewriteWithFuel, oneLessFuel
3 , OptFuelState, initOptFuelState --, setTotalFuel
4 , tankFilledTo, diffFuel
6 , FuelUsingMonad, FuelState
7 , lastFuelPass, fuelExhausted, fuelRemaining, fuelDecrement, fuelDec1
8 --, lastFuelPassInState , fuelExhaustedInState, fuelRemainingInState
12 --, runFuelWithLastPass
16 , lGraphOfGraph -- needs to be able to create a unique ID...
23 --import GHC.Exts (State#)
28 import StaticFlags (opt_Fuel)
31 #include "HsVersions.h"
34 -- We limit the number of transactions executed using a record of flags
35 -- stored in an HscEnv. The flags store the name of the last optimization
36 -- pass and the amount of optimization fuel remaining.
38 OptFuelState { pass_ref :: IORef String
39 , fuel_ref :: IORef OptimizationFuel
41 initOptFuelState :: IO OptFuelState
43 do pass_ref' <- newIORef "unoptimized program"
44 fuel_ref' <- newIORef (tankFilledTo opt_Fuel)
45 return OptFuelState {pass_ref = pass_ref', fuel_ref = fuel_ref'}
47 type FuelConsumer a = OptimizationFuel -> (a, OptimizationFuel)
49 canRewriteWithFuel :: OptimizationFuel -> Bool
50 oneLessFuel :: OptimizationFuel -> OptimizationFuel
51 maybeRewriteWithFuel :: OptimizationFuel -> Maybe a -> Maybe a
52 diffFuel :: OptimizationFuel -> OptimizationFuel -> Int
53 -- to measure consumption during compilation
54 tankFilledTo :: Int -> OptimizationFuel
57 newtype OptimizationFuel = OptimizationFuel Int
60 tankFilledTo = OptimizationFuel
61 canRewriteWithFuel (OptimizationFuel f) = f > 0
62 maybeRewriteWithFuel fuel ma = if canRewriteWithFuel fuel then ma else Nothing
63 oneLessFuel (OptimizationFuel f) = ASSERT (f > 0) (OptimizationFuel (f - 1))
64 diffFuel (OptimizationFuel f) (OptimizationFuel f') = f - f'
66 -- type OptimizationFuel = State# () -- would like this, but it won't work
67 data OptimizationFuel = OptimizationFuel
69 tankFilledTo _ = undefined -- should be impossible to evaluate
70 -- realWorld# might come in handy, too...
71 canRewriteWithFuel OptimizationFuel = True
72 maybeRewriteWithFuel _ ma = ma
77 data FuelState = FuelState { fs_fuellimit :: OptimizationFuel, fs_lastpass :: String }
78 newtype FuelMonad a = FuelMonad (FuelState -> UniqSM (a, FuelState))
80 fuelConsumingPass :: String -> FuelConsumer a -> FuelMonad a
81 fuelConsumingPass name f = do fuel <- fuelRemaining
82 let (a, fuel') = f fuel
83 fuelDecrement name fuel fuel'
86 runFuelIO :: OptFuelState -> FuelMonad a -> IO a
87 runFuelIO fs (FuelMonad f) =
88 do pass <- readIORef (pass_ref fs)
89 fuel <- readIORef (fuel_ref fs)
90 u <- mkSplitUniqSupply 'u'
91 let (a, FuelState fuel' pass') = initUs_ u $ f (FuelState fuel pass)
92 writeIORef (pass_ref fs) pass'
93 writeIORef (fuel_ref fs) fuel'
96 instance Monad FuelMonad where
97 FuelMonad f >>= k = FuelMonad (\s -> do (a, s') <- f s
98 let FuelMonad f' = k a in (f' s'))
99 return a = FuelMonad (\s -> return (a, s))
101 instance MonadUnique FuelMonad where
102 getUniqueSupplyM = liftUniq getUniqueSupplyM
103 getUniqueM = liftUniq getUniqueM
104 getUniquesM = liftUniq getUniquesM
105 liftUniq :: UniqSM x -> FuelMonad x
106 liftUniq x = FuelMonad (\s -> x >>= (\u -> return (u, s)))
108 class Monad m => FuelUsingMonad m where
109 fuelRemaining :: m OptimizationFuel
110 fuelDecrement :: String -> OptimizationFuel -> OptimizationFuel -> m ()
112 fuelExhausted :: m Bool
113 lastFuelPass :: m String
115 instance FuelUsingMonad FuelMonad where
116 fuelRemaining = extract fs_fuellimit
117 lastFuelPass = extract fs_lastpass
118 fuelExhausted = extract $ not . canRewriteWithFuel . fs_fuellimit
119 fuelDecrement p f f' = FuelMonad (\s -> return ((), fuelDecrementState p f f' s))
120 fuelDec1 = FuelMonad f
121 where f s = if canRewriteWithFuel (fs_fuellimit s) then
122 return ((), s { fs_fuellimit = oneLessFuel (fs_fuellimit s) })
123 else panic "Tried to use exhausted fuel supply"
125 extract :: (FuelState -> a) -> FuelMonad a
126 extract f = FuelMonad (\s -> return (f s, s))
129 :: String -> OptimizationFuel -> OptimizationFuel -> FuelState -> FuelState
130 fuelDecrementState new_optimizer old new s =
131 FuelState { fs_fuellimit = lim, fs_lastpass = optimizer }
132 where lim = if diffFuel old (fs_fuellimit s) == 0 then new
134 concat ["lost track of ", new_optimizer, "'s transactions"]
135 optimizer = if diffFuel old new > 0 then new_optimizer else fs_lastpass s
137 -- lGraphOfGraph is here because we need uniques to implement it.
138 lGraphOfGraph :: Graph m l -> FuelMonad (LGraph m l)
139 lGraphOfGraph (Graph tail blocks) =
140 do entry <- liftM BlockId $ getUniqueM
141 return $ LGraph entry (insertBlock (Block entry tail) blocks)
144 -- JD: I'm not sure what NR's plans are for the following code.
145 -- Perhaps these functions will be useful in the future, or perhaps I've made
148 --initialFuelState :: OptimizationFuel -> FuelState
149 --initialFuelState fuel = FuelState fuel "unoptimized program"
150 --runFuel :: FuelMonad a -> FuelConsumer a
151 --runFuelWithLastPass :: FuelMonad a -> FuelConsumer (a, String)
153 --runFuel (FuelMonad f) fuel = let (a, s) = f $ initialFuelState fuel
154 -- in (a, fs_fuellimit s)
155 --runFuelWithLastPass (FuelMonad f) fuel = let (a, s) = f $ initialFuelState fuel
156 -- in ((a, fs_lastpass s), fs_fuellimit s)
158 -- lastFuelPassInState :: FuelState -> String
159 -- lastFuelPassInState = fs_lastpass
161 -- fuelExhaustedInState :: FuelState -> Bool
162 -- fuelExhaustedInState = canRewriteWithFuel . fs_fuellimit
164 -- fuelRemainingInState :: FuelState -> OptimizationFuel
165 -- fuelRemainingInState = fs_fuellimit