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 data FuelState = FuelState { fs_fuellimit :: OptimizationFuel, fs_lastpass :: String }
  52 newtype FuelMonad a = FuelMonad (FuelState -> (a, FuelState))
  53
  54 fuelConsumingPass :: String -> FuelConsumer a -> FuelMonad a
  55 fuelConsumingPass name f = do fuel <- fuelRemaining
  56                               let (a, fuel') = f fuel
  57                               fuelDecrement name fuel fuel'
  58                               return a
  59
  60 runFuel             :: FuelMonad a -> FuelConsumer a
  61 runFuelWithLastPass :: FuelMonad a -> FuelConsumer (a, String)
  62
  63 runFuelIO :: IORef String -> IORef OptimizationFuel -> FuelMonad a -> IO a
  64 runFuelIO pass_ref fuel_ref (FuelMonad f) =
  65     do { pass <- readIORef pass_ref
  66        ; fuel <- readIORef fuel_ref
  67        ; let (a, FuelState fuel' pass') = f (FuelState fuel pass)
  68        ; writeIORef pass_ref pass'
  69        ; writeIORef fuel_ref fuel'
  70        ; return a
  71        }
  72
  73 initialFuelState :: OptimizationFuel -> FuelState
  74 initialFuelState fuel = FuelState fuel "unoptimized program"
  75
  76 runFuel             (FuelMonad f) fuel = let (a, s) = f $ initialFuelState fuel
  77                                          in (a, fs_fuellimit s)
  78 runFuelWithLastPass (FuelMonad f) fuel = let (a, s) = f $ initialFuelState fuel
  79                                          in ((a, fs_lastpass s), fs_fuellimit s)
  80
  81 lastFuelPassInState :: FuelState -> String
  82 lastFuelPassInState = fs_lastpass
  83
  84 fuelExhaustedInState :: FuelState -> Bool
  85 fuelExhaustedInState = canRewriteWithFuel . fs_fuellimit
  86
  87 fuelRemainingInState :: FuelState -> OptimizationFuel
  88 fuelRemainingInState = fs_fuellimit
  89
  90 fuelDecrementState
  91     :: String -> OptimizationFuel -> OptimizationFuel -> FuelState -> FuelState
  92 fuelDecrementState new_optimizer old new s =
  93     FuelState { fs_fuellimit = lim, fs_lastpass = optimizer }
  94   where lim = if diffFuel old (fs_fuellimit s) == 0 then new
  95               else panic $
  96                    concat ["lost track of ", new_optimizer, "'s transactions"]
  97         optimizer = if diffFuel old new > 0 then new_optimizer else fs_lastpass s
  98
  99 class Monad m => FuelUsingMonad m where
 100   fuelRemaining :: m OptimizationFuel
 101   fuelDecrement :: String -> OptimizationFuel -> OptimizationFuel -> m ()
 102   fuelExhausted :: m Bool
 103   lastFuelPass  :: m String
 104
 105
 106 instance Monad FuelMonad where
 107   FuelMonad f >>= k = FuelMonad (\s -> let (a, s') = f s
 108                                            FuelMonad f' = k a
 109                                        in  f' s')
 110   return a = FuelMonad (\s -> (a, s))
 111
 112 instance FuelUsingMonad FuelMonad where
 113   fuelRemaining = extract fuelRemainingInState
 114   lastFuelPass  = extract lastFuelPassInState
 115   fuelExhausted = extract fuelExhaustedInState
 116   fuelDecrement p f f' = FuelMonad (\s -> ((), fuelDecrementState p f f' s))
 117
 118 extract :: (FuelState -> a) -> FuelMonad a
 119 extract f = FuelMonad (\s -> (f s, s))