compiler/cmm/OptimizationFuel.hs

   1 -- | Optimisation fuel is used to control the amount of work the optimiser does.
   2 --
   3 -- Every optimisation step consumes a certain amount of fuel and stops when
   4 -- it runs out of fuel.  This can be used e.g. to debug optimiser bugs: Run
   5 -- the optimiser with varying amount of fuel to find out the exact number of
   6 -- steps where a bug is introduced in the output.
   7 module OptimizationFuel
   8     ( OptimizationFuel,  canRewriteWithFuel, maybeRewriteWithFuel, oneLessFuel
   9     , OptFuelState, initOptFuelState --, setTotalFuel
  10     , tankFilledTo, diffFuel
  11     , FuelConsumer
  12     , FuelUsingMonad, FuelState
  13     , lastFuelPass, fuelExhausted, fuelRemaining, fuelDecrement, fuelDec1
  14     , runFuelIO, fuelConsumingPass
  15     , FuelMonad
  16     , liftUniq
  17     , lGraphOfGraph -- needs to be able to create a unique ID...
  18     )
  19 where
  20
  21 import BlockId
  22 import ZipCfg
  23 --import GHC.Exts (State#)
  24 import Panic
  25 import Data.IORef
  26 import Control.Monad
  27 import StaticFlags (opt_Fuel)
  28 import UniqSupply
  29
  30 #include "HsVersions.h"
  31
  32
  33 -- We limit the number of transactions executed using a record of flags
  34 -- stored in an HscEnv. The flags store the name of the last optimization
  35 -- pass and the amount of optimization fuel remaining.
  36 data OptFuelState =
  37   OptFuelState { pass_ref :: IORef String
  38                , fuel_ref :: IORef OptimizationFuel
  39                }
  40 initOptFuelState :: IO OptFuelState
  41 initOptFuelState =
  42   do pass_ref' <- newIORef "unoptimized program"
  43      fuel_ref' <- newIORef (tankFilledTo opt_Fuel)
  44      return OptFuelState {pass_ref = pass_ref', fuel_ref = fuel_ref'}
  45
  46 type FuelConsumer a = OptimizationFuel -> (a, OptimizationFuel)
  47
  48 canRewriteWithFuel :: OptimizationFuel -> Bool
  49 oneLessFuel :: OptimizationFuel -> OptimizationFuel
  50 maybeRewriteWithFuel :: OptimizationFuel -> Maybe a -> Maybe a
  51 diffFuel :: OptimizationFuel -> OptimizationFuel -> Int
  52    -- to measure consumption during compilation
  53 tankFilledTo :: Int -> OptimizationFuel
  54
  55 #ifdef DEBUG
  56 newtype OptimizationFuel = OptimizationFuel Int
  57   deriving Show
  58
  59 tankFilledTo = OptimizationFuel
  60 canRewriteWithFuel (OptimizationFuel f) = f > 0
  61 maybeRewriteWithFuel fuel ma = if canRewriteWithFuel fuel then ma else Nothing
  62 oneLessFuel (OptimizationFuel f) = ASSERT (f > 0) (OptimizationFuel (f - 1))
  63 diffFuel (OptimizationFuel f) (OptimizationFuel f') = f - f'
  64 #else
  65 -- type OptimizationFuel = State# () -- would like this, but it won't work
  66 data OptimizationFuel = OptimizationFuel
  67   deriving Show
  68 tankFilledTo _ = panic "tankFilledTo" -- should be impossible to evaluate
  69   -- realWorld# might come in handy, too...
  70 canRewriteWithFuel OptimizationFuel = True
  71 maybeRewriteWithFuel _ ma = ma
  72 oneLessFuel f = f
  73 diffFuel _ _ = 0
  74 #endif
  75
  76 data FuelState = FuelState { fs_fuellimit :: OptimizationFuel, fs_lastpass :: String }
  77 newtype FuelMonad a = FuelMonad (FuelState -> UniqSM (a, FuelState))
  78
  79 fuelConsumingPass :: String -> FuelConsumer a -> FuelMonad a
  80 fuelConsumingPass name f = do fuel <- fuelRemaining
  81                               let (a, fuel') = f fuel
  82                               fuelDecrement name fuel fuel'
  83                               return a
  84
  85 runFuelIO :: OptFuelState -> FuelMonad a -> IO a
  86 runFuelIO fs (FuelMonad f) =
  87     do pass <- readIORef (pass_ref fs)
  88        fuel <- readIORef (fuel_ref fs)
  89        u    <- mkSplitUniqSupply 'u'
  90        let (a, FuelState fuel' pass') = initUs_ u $ f (FuelState fuel pass)
  91        writeIORef (pass_ref fs) pass'
  92        writeIORef (fuel_ref fs) fuel'
  93        return a
  94
  95 instance Monad FuelMonad where
  96   FuelMonad f >>= k = FuelMonad (\s -> do (a, s') <- f s
  97                                           let FuelMonad f' = k a in (f' s'))
  98   return a = FuelMonad (\s -> return (a, s))
  99
 100 instance MonadUnique FuelMonad where
 101     getUniqueSupplyM = liftUniq getUniqueSupplyM
 102     getUniqueM       = liftUniq getUniqueM
 103     getUniquesM      = liftUniq getUniquesM
 104 liftUniq :: UniqSM x -> FuelMonad x
 105 liftUniq x = FuelMonad (\s -> x >>= (\u -> return (u, s)))
 106
 107 class Monad m => FuelUsingMonad m where
 108   fuelRemaining :: m OptimizationFuel
 109   fuelDecrement :: String -> OptimizationFuel -> OptimizationFuel -> m ()
 110   fuelDec1      :: m ()
 111   fuelExhausted :: m Bool
 112   lastFuelPass  :: m String
 113
 114 instance FuelUsingMonad FuelMonad where
 115   fuelRemaining = extract fs_fuellimit
 116   lastFuelPass  = extract fs_lastpass
 117   fuelExhausted = extract $ not . canRewriteWithFuel . fs_fuellimit
 118   fuelDecrement p f f' = FuelMonad (\s -> return ((), fuelDecrementState p f f' s))
 119   fuelDec1      = FuelMonad f
 120      where f s = if canRewriteWithFuel (fs_fuellimit s) then
 121                     return ((), s { fs_fuellimit = oneLessFuel (fs_fuellimit s) })
 122                  else panic "Tried to use exhausted fuel supply"
 123
 124 extract :: (FuelState -> a) -> FuelMonad a
 125 extract f = FuelMonad (\s -> return (f s, s))
 126
 127 fuelDecrementState
 128     :: String -> OptimizationFuel -> OptimizationFuel -> FuelState -> FuelState
 129 fuelDecrementState new_optimizer old new s =
 130     FuelState { fs_fuellimit = lim, fs_lastpass = optimizer }
 131   where lim = if diffFuel old (fs_fuellimit s) == 0 then new
 132               else panic $
 133                    concat ["lost track of ", new_optimizer, "'s transactions"]
 134         optimizer = if diffFuel old new > 0 then new_optimizer else fs_lastpass s
 135
 136 -- lGraphOfGraph is here because we need uniques to implement it.
 137 lGraphOfGraph :: Graph m l -> FuelMonad (LGraph m l)
 138 lGraphOfGraph (Graph tail blocks) =
 139   do entry <- liftM BlockId $ getUniqueM
 140      return $ LGraph entry (insertBlock (Block entry tail) blocks)