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