compiler/cmm/OptimizationFuel.hs

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