compiler/cmm/OptimizationFuel.hs

   1 {-# LANGUAGE TypeFamilies #-}
   2 -- | Optimisation fuel is used to control the amount of work the optimiser does.
   3 --
   4 -- Every optimisation step consumes a certain amount of fuel and stops when
   5 -- it runs out of fuel.  This can be used e.g. to debug optimiser bugs: Run
   6 -- the optimiser with varying amount of fuel to find out the exact number of
   7 -- steps where a bug is introduced in the output.
   8 module OptimizationFuel
   9     ( OptimizationFuel, amountOfFuel, tankFilledTo, unlimitedFuel, anyFuelLeft, oneLessFuel
  10     , OptFuelState, initOptFuelState
  11     , FuelConsumer, FuelUsingMonad, FuelState
  12     , fuelGet, fuelSet, lastFuelPass, setFuelPass
  13     , fuelExhausted, fuelDec1, tryWithFuel
  14     , runFuelIO, runInfiniteFuelIO, fuelConsumingPass
  15     , FuelUniqSM
  16     , liftUniq
  17     )
  18 where
  19
  20 import Data.IORef
  21 import Control.Monad
  22 import StaticFlags (opt_Fuel)
  23 import UniqSupply
  24 #ifdef DEBUG
  25 import Panic
  26 #endif
  27
  28 import Compiler.Hoopl
  29 import Compiler.Hoopl.GHC (getFuel, setFuel)
  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 tankFilledTo :: Int -> OptimizationFuel
  50 amountOfFuel :: OptimizationFuel -> Int
  51
  52 anyFuelLeft :: OptimizationFuel -> Bool
  53 oneLessFuel :: OptimizationFuel -> OptimizationFuel
  54 unlimitedFuel :: OptimizationFuel
  55
  56 #ifdef DEBUG
  57 newtype OptimizationFuel = OptimizationFuel Int
  58   deriving Show
  59
  60 tankFilledTo = OptimizationFuel
  61 amountOfFuel (OptimizationFuel f) = f
  62
  63 anyFuelLeft (OptimizationFuel f) = f > 0
  64 oneLessFuel (OptimizationFuel f) = ASSERT (f > 0) (OptimizationFuel (f - 1))
  65 unlimitedFuel = OptimizationFuel infiniteFuel
  66 #else
  67 -- type OptimizationFuel = State# () -- would like this, but it won't work
  68 data OptimizationFuel = OptimizationFuel
  69   deriving Show
  70 tankFilledTo _ = OptimizationFuel
  71 amountOfFuel _ = maxBound
  72
  73 anyFuelLeft _ = True
  74 oneLessFuel _ = OptimizationFuel
  75 unlimitedFuel = OptimizationFuel
  76 #endif
  77
  78 data FuelState = FuelState { fs_fuel :: OptimizationFuel, fs_lastpass :: String }
  79 newtype FuelUniqSM a = FUSM { unFUSM :: FuelState -> UniqSM (a, FuelState) }
  80
  81 fuelConsumingPass :: String -> FuelConsumer a -> FuelUniqSM a
  82 fuelConsumingPass name f = do setFuelPass name
  83                               fuel <- fuelGet
  84                               let (a, fuel') = f fuel
  85                               fuelSet fuel'
  86                               return a
  87
  88 runFuelIO :: OptFuelState -> FuelUniqSM a -> IO a
  89 runFuelIO fs (FUSM f) =
  90     do pass <- readIORef (pass_ref fs)
  91        fuel <- readIORef (fuel_ref fs)
  92        u    <- mkSplitUniqSupply 'u'
  93        let (a, FuelState fuel' pass') = initUs_ u $ f (FuelState fuel pass)
  94        writeIORef (pass_ref fs) pass'
  95        writeIORef (fuel_ref fs) fuel'
  96        return a
  97
  98 -- ToDo: Do we need the pass_ref when we are doing infinite fueld
  99 -- transformations?
 100 runInfiniteFuelIO :: OptFuelState -> FuelUniqSM a -> IO a
 101 runInfiniteFuelIO fs (FUSM f) =
 102     do pass <- readIORef (pass_ref fs)
 103        u <- mkSplitUniqSupply 'u'
 104        let (a, FuelState _ pass') = initUs_ u $ f (FuelState unlimitedFuel pass)
 105        writeIORef (pass_ref fs) pass'
 106        return a
 107
 108 instance Monad FuelUniqSM where
 109   FUSM f >>= k = FUSM (\s -> f s >>= \(a, s') -> unFUSM (k a) s')
 110   return a     = FUSM (\s -> return (a, s))
 111
 112 instance MonadUnique FuelUniqSM where
 113     getUniqueSupplyM = liftUniq getUniqueSupplyM
 114     getUniqueM       = liftUniq getUniqueM
 115     getUniquesM      = liftUniq getUniquesM
 116
 117 liftUniq :: UniqSM x -> FuelUniqSM x
 118 liftUniq x = FUSM (\s -> x >>= (\u -> return (u, s)))
 119
 120 class Monad m => FuelUsingMonad m where
 121   fuelGet      :: m OptimizationFuel
 122   fuelSet      :: OptimizationFuel -> m ()
 123   lastFuelPass :: m String
 124   setFuelPass  :: String -> m ()
 125
 126 fuelExhausted :: FuelUsingMonad m => m Bool
 127 fuelExhausted = fuelGet >>= return . anyFuelLeft
 128
 129 fuelDec1 :: FuelUsingMonad m => m ()
 130 fuelDec1 = fuelGet >>= fuelSet . oneLessFuel
 131
 132 tryWithFuel :: FuelUsingMonad m => a -> m (Maybe a)
 133 tryWithFuel r = do f <- fuelGet
 134                    if anyFuelLeft f then fuelSet (oneLessFuel f) >> return (Just r)
 135                                     else return Nothing
 136
 137 instance FuelUsingMonad FuelUniqSM where
 138   fuelGet          = extract fs_fuel
 139   lastFuelPass     = extract fs_lastpass
 140   fuelSet fuel     = FUSM (\s -> return ((), s { fs_fuel     = fuel }))
 141   setFuelPass pass = FUSM (\s -> return ((), s { fs_lastpass = pass }))
 142
 143 extract :: (FuelState -> a) -> FuelUniqSM a
 144 extract f = FUSM (\s -> return (f s, s))
 145
 146 instance FuelMonad FuelUniqSM where
 147   getFuel = liftM amountOfFuel fuelGet
 148   setFuel = fuelSet . tankFilledTo
 149
 150 -- Don't bother to checkpoint the unique supply; it doesn't matter
 151 instance CheckpointMonad FuelUniqSM where
 152     type Checkpoint FuelUniqSM = FuelState
 153     checkpoint = FUSM $ \fuel -> return (fuel, fuel)
 154     restart fuel = FUSM $ \_ -> return ((), fuel)
 155