compiler/cmm/OptimizationFuel.hs

   1 module OptimizationFuel
   2     ( OptimizationFuel, canRewriteWithFuel, maybeRewriteWithFuel, oneLessFuel
   3     , tankFilledTo, diffFuel
   4     , FuelConsumer
   5     , FuelUsingMonad, FuelState
   6     , lastFuelPass, fuelExhausted, fuelRemaining, fuelDecrement
   7     , lastFuelPassInState, fuelExhaustedInState, fuelRemainingInState
   8     , fuelDecrementState
   9     , runFuel, runFuelIO, runFuelWithLastPass, fuelConsumingPass
  10     , FuelMonad(..)
  11     )
  12 where
  13
  14 --import GHC.Exts (State#)
  15 import Panic
  16
  17 import Data.IORef
  18
  19 #include "HsVersions.h"
  20
  21 type FuelConsumer a = OptimizationFuel -> (a, OptimizationFuel)
  22
  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
  29
  30 #ifdef DEBUG
  31 newtype OptimizationFuel = OptimizationFuel Int
  32   deriving Show
  33
  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'
  39 #else
  40 -- type OptimizationFuel = State# () -- would like this, but it won't work
  41 data OptimizationFuel = OptimizationFuel
  42   deriving Show
  43 tankFilledTo _ = undefined -- should be impossible to evaluate
  44   -- realWorld# might come in handy, too...
  45 canRewriteWithFuel OptimizationFuel = True
  46 maybeRewriteWithFuel _ ma = ma
  47 oneLessFuel f = f
  48 diffFuel _ _ = 0
  49 #endif
  50
  51 -- stop warnings about things that aren't used
  52 _unused :: {-State#-} () -> FS.FastString
  53 _unused = undefined panic
  54
  55
  56 data FuelState = FuelState { fs_fuellimit :: OptimizationFuel, fs_lastpass :: String }
  57 newtype FuelMonad a = FuelMonad (FuelState -> (a, FuelState))
  58
  59 fuelConsumingPass :: String -> FuelConsumer a -> FuelMonad a
  60 fuelConsumingPass name f = do fuel <- fuelRemaining
  61                               let (a, fuel') = f fuel
  62                               fuelDecrement name fuel fuel'
  63                               return a
  64
  65 runFuel             :: FuelMonad a -> FuelConsumer a
  66 runFuelWithLastPass :: FuelMonad a -> FuelConsumer (a, String)
  67
  68 runFuelIO :: IORef String -> IORef OptimizationFuel -> FuelMonad a -> IO a
  69 runFuelIO pass_ref fuel_ref (FuelMonad f) =
  70     do { pass <- readIORef pass_ref
  71        ; fuel <- readIORef fuel_ref
  72        ; let (a, FuelState fuel' pass') = f (FuelState fuel pass)
  73        ; writeIORef pass_ref pass'
  74        ; writeIORef fuel_ref fuel'
  75        ; return a
  76        }
  77
  78 initialFuelState :: OptimizationFuel -> FuelState
  79 initialFuelState fuel = FuelState fuel "unoptimized program"
  80
  81 runFuel             (FuelMonad f) fuel = let (a, s) = f $ initialFuelState fuel
  82                                          in (a, fs_fuellimit s)
  83 runFuelWithLastPass (FuelMonad f) fuel = let (a, s) = f $ initialFuelState fuel
  84                                          in ((a, fs_lastpass s), fs_fuellimit s)
  85
  86 lastFuelPassInState :: FuelState -> String
  87 lastFuelPassInState = fs_lastpass
  88
  89 fuelExhaustedInState :: FuelState -> Bool
  90 fuelExhaustedInState = canRewriteWithFuel . fs_fuellimit
  91
  92 fuelRemainingInState :: FuelState -> OptimizationFuel
  93 fuelRemainingInState = fs_fuellimit
  94
  95 fuelDecrementState
  96     :: String -> OptimizationFuel -> OptimizationFuel -> FuelState -> FuelState
  97 fuelDecrementState new_optimizer old new s =
  98     FuelState { fs_fuellimit = lim, fs_lastpass = optimizer }
  99   where lim = if diffFuel old (fs_fuellimit s) == 0 then new
 100               else panic $
 101                    concat ["lost track of ", new_optimizer, "'s transactions"]
 102         optimizer = if diffFuel old new > 0 then new_optimizer else fs_lastpass s
 103
 104 class Monad m => FuelUsingMonad m where
 105   fuelRemaining :: m OptimizationFuel
 106   fuelDecrement :: String -> OptimizationFuel -> OptimizationFuel -> m ()
 107   fuelExhausted :: m Bool
 108   lastFuelPass  :: m String
 109
 110
 111 instance Monad FuelMonad where
 112   FuelMonad f >>= k = FuelMonad (\s -> let (a, s') = f s
 113                                            FuelMonad f' = k a
 114                                        in  f' s')
 115   return a = FuelMonad (\s -> (a, s))
 116
 117 instance FuelUsingMonad FuelMonad where
 118   fuelRemaining = extract fuelRemainingInState
 119   lastFuelPass  = extract lastFuelPassInState
 120   fuelExhausted = extract fuelExhaustedInState
 121   fuelDecrement p f f' = FuelMonad (\s -> ((), fuelDecrementState p f f' s))
 122
 123 extract :: (FuelState -> a) -> FuelMonad a
 124 extract f = FuelMonad (\s -> (f s, s))