1 {-# LANGUAGE TypeFamilies #-}
2 -- | Optimisation fuel is used to control the amount of work the optimiser does.
4 -- Every optimisation step consumes a certain amount of fuel and stops when
5 -- it runs out of fuel. This can be used e.g. to debug optimiser bugs: Run
6 -- the optimiser with varying amount of fuel to find out the exact number of
7 -- steps where a bug is introduced in the output.
8 module OptimizationFuel
9 ( OptimizationFuel, amountOfFuel, tankFilledTo, unlimitedFuel, anyFuelLeft, oneLessFuel
10 , OptFuelState, initOptFuelState
11 , FuelConsumer, FuelUsingMonad, FuelState
12 , fuelGet, fuelSet, lastFuelPass, setFuelPass
13 , fuelExhausted, fuelDec1, tryWithFuel
14 , runFuelIO, runInfiniteFuelIO, fuelConsumingPass
22 import StaticFlags (opt_Fuel)
29 import Compiler.Hoopl.GHC (getFuel, setFuel)
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 tankFilledTo :: Int -> OptimizationFuel
50 amountOfFuel :: OptimizationFuel -> Int
52 anyFuelLeft :: OptimizationFuel -> Bool
53 oneLessFuel :: OptimizationFuel -> OptimizationFuel
54 unlimitedFuel :: OptimizationFuel
57 newtype OptimizationFuel = OptimizationFuel Int
60 tankFilledTo = OptimizationFuel
61 amountOfFuel (OptimizationFuel f) = f
63 anyFuelLeft (OptimizationFuel f) = f > 0
64 oneLessFuel (OptimizationFuel f) = ASSERT (f > 0) (OptimizationFuel (f - 1))
65 unlimitedFuel = OptimizationFuel infiniteFuel
67 -- type OptimizationFuel = State# () -- would like this, but it won't work
68 data OptimizationFuel = OptimizationFuel
70 tankFilledTo _ = OptimizationFuel
71 amountOfFuel _ = maxBound
74 oneLessFuel _ = OptimizationFuel
75 unlimitedFuel = OptimizationFuel
78 data FuelState = FuelState { fs_fuel :: OptimizationFuel, fs_lastpass :: String }
79 newtype FuelUniqSM a = FUSM { unFUSM :: FuelState -> UniqSM (a, FuelState) }
81 fuelConsumingPass :: String -> FuelConsumer a -> FuelUniqSM a
82 fuelConsumingPass name f = do setFuelPass name
84 let (a, fuel') = f fuel
88 runFuelIO :: OptFuelState -> FuelUniqSM a -> IO a
89 runFuelIO fs (FUSM f) =
90 do pass <- readIORef (pass_ref fs)
91 fuel <- readIORef (fuel_ref fs)
92 u <- mkSplitUniqSupply 'u'
93 let (a, FuelState fuel' pass') = initUs_ u $ f (FuelState fuel pass)
94 writeIORef (pass_ref fs) pass'
95 writeIORef (fuel_ref fs) fuel'
98 -- ToDo: Do we need the pass_ref when we are doing infinite fueld
100 runInfiniteFuelIO :: OptFuelState -> FuelUniqSM a -> IO a
101 runInfiniteFuelIO fs (FUSM f) =
102 do pass <- readIORef (pass_ref fs)
103 u <- mkSplitUniqSupply 'u'
104 let (a, FuelState _ pass') = initUs_ u $ f (FuelState unlimitedFuel pass)
105 writeIORef (pass_ref fs) pass'
108 instance Monad FuelUniqSM where
109 FUSM f >>= k = FUSM (\s -> f s >>= \(a, s') -> unFUSM (k a) s')
110 return a = FUSM (\s -> return (a, s))
112 instance MonadUnique FuelUniqSM where
113 getUniqueSupplyM = liftUniq getUniqueSupplyM
114 getUniqueM = liftUniq getUniqueM
115 getUniquesM = liftUniq getUniquesM
117 liftUniq :: UniqSM x -> FuelUniqSM x
118 liftUniq x = FUSM (\s -> x >>= (\u -> return (u, s)))
120 class Monad m => FuelUsingMonad m where
121 fuelGet :: m OptimizationFuel
122 fuelSet :: OptimizationFuel -> m ()
123 lastFuelPass :: m String
124 setFuelPass :: String -> m ()
126 fuelExhausted :: FuelUsingMonad m => m Bool
127 fuelExhausted = fuelGet >>= return . anyFuelLeft
129 fuelDec1 :: FuelUsingMonad m => m ()
130 fuelDec1 = fuelGet >>= fuelSet . oneLessFuel
132 tryWithFuel :: FuelUsingMonad m => a -> m (Maybe a)
133 tryWithFuel r = do f <- fuelGet
134 if anyFuelLeft f then fuelSet (oneLessFuel f) >> return (Just r)
137 instance FuelUsingMonad FuelUniqSM where
138 fuelGet = extract fs_fuel
139 lastFuelPass = extract fs_lastpass
140 fuelSet fuel = FUSM (\s -> return ((), s { fs_fuel = fuel }))
141 setFuelPass pass = FUSM (\s -> return ((), s { fs_lastpass = pass }))
143 extract :: (FuelState -> a) -> FuelUniqSM a
144 extract f = FUSM (\s -> return (f s, s))
146 instance FuelMonad FuelUniqSM where
147 getFuel = liftM amountOfFuel fuelGet
148 setFuel = fuelSet . tankFilledTo
150 -- Don't bother to checkpoint the unique supply; it doesn't matter
151 instance CheckpointMonad FuelUniqSM where
152 type Checkpoint FuelUniqSM = FuelState
153 checkpoint = FUSM $ \fuel -> return (fuel, fuel)
154 restart fuel = FUSM $ \_ -> return ((), fuel)