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     --, lastFuelPassInState , fuelExhaustedInState, fuelRemainingInState
   9     --, fuelDecrementState
  10     --, runFuel
  11     , runFuelIO
  12     --, runFuelWithLastPass
  13     , fuelConsumingPass
  14     , FuelMonad
  15     , liftUniq
  16     , lGraphOfGraph -- needs to be able to create a unique ID...
  17     )
  18 where
  19
  20 import StackSlot
  21 import ZipCfg
  22
  23 --import GHC.Exts (State#)
  24 import Panic
  25
  26 import Data.IORef
  27 import Monad
  28 import StaticFlags (opt_Fuel)
  29 import UniqSupply
  30
  31 #include "HsVersions.h"
  32
  33
  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.
  37 data OptFuelState =
  38   OptFuelState { pass_ref :: IORef String
  39                , fuel_ref :: IORef OptimizationFuel
  40                }
  41 initOptFuelState :: IO OptFuelState
  42 initOptFuelState =
  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'}
  46
  47 type FuelConsumer a = OptimizationFuel -> (a, OptimizationFuel)
  48
  49 canRewriteWithFuel :: OptimizationFuel -> Bool
  50 oneLessFuel :: OptimizationFuel -> OptimizationFuel
  51 maybeRewriteWithFuel :: OptimizationFuel -> Maybe a -> Maybe a
  52 diffFuel :: OptimizationFuel -> OptimizationFuel -> Int
  53    -- to measure consumption during compilation
  54 tankFilledTo :: Int -> OptimizationFuel
  55
  56 #ifdef DEBUG
  57 newtype OptimizationFuel = OptimizationFuel Int
  58   deriving Show
  59
  60 tankFilledTo = OptimizationFuel
  61 canRewriteWithFuel (OptimizationFuel f) = f > 0
  62 maybeRewriteWithFuel fuel ma = if canRewriteWithFuel fuel then ma else Nothing
  63 oneLessFuel (OptimizationFuel f) = ASSERT (f > 0) (OptimizationFuel (f - 1))
  64 diffFuel (OptimizationFuel f) (OptimizationFuel f') = f - f'
  65 #else
  66 -- type OptimizationFuel = State# () -- would like this, but it won't work
  67 data OptimizationFuel = OptimizationFuel
  68   deriving Show
  69 tankFilledTo _ = undefined -- should be impossible to evaluate
  70   -- realWorld# might come in handy, too...
  71 canRewriteWithFuel OptimizationFuel = True
  72 maybeRewriteWithFuel _ ma = ma
  73 oneLessFuel f = f
  74 diffFuel _ _ = 0
  75 #endif
  76
  77 data FuelState = FuelState { fs_fuellimit :: OptimizationFuel, fs_lastpass :: String }
  78 newtype FuelMonad a = FuelMonad (FuelState -> UniqSM (a, FuelState))
  79
  80 fuelConsumingPass :: String -> FuelConsumer a -> FuelMonad a
  81 fuelConsumingPass name f = do fuel <- fuelRemaining
  82                               let (a, fuel') = f fuel
  83                               fuelDecrement name fuel fuel'
  84                               return a
  85
  86 runFuelIO :: OptFuelState -> FuelMonad a -> IO a
  87 runFuelIO fs (FuelMonad f) =
  88     do pass <- readIORef (pass_ref fs)
  89        fuel <- readIORef (fuel_ref fs)
  90        u    <- mkSplitUniqSupply 'u'
  91        let (a, FuelState fuel' pass') = initUs_ u $ f (FuelState fuel pass)
  92        writeIORef (pass_ref fs) pass'
  93        writeIORef (fuel_ref fs) fuel'
  94        return a
  95
  96 instance Monad FuelMonad where
  97   FuelMonad f >>= k = FuelMonad (\s -> do (a, s') <- f s
  98                                           let FuelMonad f' = k a in (f' s'))
  99   return a = FuelMonad (\s -> return (a, s))
 100
 101 instance MonadUnique FuelMonad where
 102     getUniqueSupplyM = liftUniq getUniqueSupplyM
 103     getUniqueM       = liftUniq getUniqueM
 104     getUniquesM      = liftUniq getUniquesM
 105 liftUniq :: UniqSM x -> FuelMonad x
 106 liftUniq x = FuelMonad (\s -> x >>= (\u -> return (u, s)))
 107
 108 class Monad m => FuelUsingMonad m where
 109   fuelRemaining :: m OptimizationFuel
 110   fuelDecrement :: String -> OptimizationFuel -> OptimizationFuel -> m ()
 111   fuelDec1      :: m ()
 112   fuelExhausted :: m Bool
 113   lastFuelPass  :: m String
 114
 115 instance FuelUsingMonad FuelMonad where
 116   fuelRemaining = extract fs_fuellimit
 117   lastFuelPass  = extract fs_lastpass
 118   fuelExhausted = extract $ not . canRewriteWithFuel . fs_fuellimit
 119   fuelDecrement p f f' = FuelMonad (\s -> return ((), fuelDecrementState p f f' s))
 120   fuelDec1      = FuelMonad f
 121      where f s = if canRewriteWithFuel (fs_fuellimit s) then
 122                     return ((), s { fs_fuellimit = oneLessFuel (fs_fuellimit s) })
 123                  else panic "Tried to use exhausted fuel supply"
 124
 125 extract :: (FuelState -> a) -> FuelMonad a
 126 extract f = FuelMonad (\s -> return (f s, s))
 127
 128 fuelDecrementState
 129     :: String -> OptimizationFuel -> OptimizationFuel -> FuelState -> FuelState
 130 fuelDecrementState new_optimizer old new s =
 131     FuelState { fs_fuellimit = lim, fs_lastpass = optimizer }
 132   where lim = if diffFuel old (fs_fuellimit s) == 0 then new
 133               else panic $
 134                    concat ["lost track of ", new_optimizer, "'s transactions"]
 135         optimizer = if diffFuel old new > 0 then new_optimizer else fs_lastpass s
 136
 137 -- lGraphOfGraph is here because we need uniques to implement it.
 138 lGraphOfGraph :: Graph m l -> FuelMonad (LGraph m l)
 139 lGraphOfGraph (Graph tail blocks) =
 140   do entry <- liftM BlockId $ getUniqueM
 141      return $ LGraph entry (insertBlock (Block entry tail) blocks)
 142
 143
 144 -- JD: I'm not sure what NR's plans are for the following code.
 145 -- Perhaps these functions will be useful in the future, or perhaps I've made
 146 -- them obsoltete.
 147
 148 --initialFuelState :: OptimizationFuel -> FuelState
 149 --initialFuelState fuel = FuelState fuel "unoptimized program"
 150 --runFuel             :: FuelMonad a -> FuelConsumer a
 151 --runFuelWithLastPass :: FuelMonad a -> FuelConsumer (a, String)
 152
 153 --runFuel             (FuelMonad f) fuel = let (a, s) = f $ initialFuelState fuel
 154 --                                         in (a, fs_fuellimit s)
 155 --runFuelWithLastPass (FuelMonad f) fuel = let (a, s) = f $ initialFuelState fuel
 156 --                                         in ((a, fs_lastpass s), fs_fuellimit s)
 157
 158 -- lastFuelPassInState :: FuelState -> String
 159 -- lastFuelPassInState = fs_lastpass
 160
 161 -- fuelExhaustedInState :: FuelState -> Bool
 162 -- fuelExhaustedInState = canRewriteWithFuel . fs_fuellimit
 163
 164 -- fuelRemainingInState :: FuelState -> OptimizationFuel
 165 -- fuelRemainingInState = fs_fuellimit
 166