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
|
module OptimizationFuel
( OptimizationFuel, canRewriteWithFuel, maybeRewriteWithFuel, oneLessFuel
, OptFuelState, initOptFuelState --, setTotalFuel
, tankFilledTo, diffFuel
, FuelConsumer
, FuelUsingMonad, FuelState
, lastFuelPass, fuelExhausted, fuelRemaining, fuelDecrement, fuelDec1
, runFuelIO, fuelConsumingPass
, FuelMonad
, liftUniq
, lGraphOfGraph -- needs to be able to create a unique ID...
)
where
import BlockId
import ZipCfg
--import GHC.Exts (State#)
import Panic
import Data.IORef
import Monad
import StaticFlags (opt_Fuel)
import UniqSupply
#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)
canRewriteWithFuel :: OptimizationFuel -> Bool
oneLessFuel :: OptimizationFuel -> OptimizationFuel
maybeRewriteWithFuel :: OptimizationFuel -> Maybe a -> Maybe a
diffFuel :: OptimizationFuel -> OptimizationFuel -> Int
-- to measure consumption during compilation
tankFilledTo :: Int -> OptimizationFuel
#ifdef DEBUG
newtype OptimizationFuel = OptimizationFuel Int
deriving Show
tankFilledTo = OptimizationFuel
canRewriteWithFuel (OptimizationFuel f) = f > 0
maybeRewriteWithFuel fuel ma = if canRewriteWithFuel fuel then ma else Nothing
oneLessFuel (OptimizationFuel f) = ASSERT (f > 0) (OptimizationFuel (f - 1))
diffFuel (OptimizationFuel f) (OptimizationFuel f') = f - f'
#else
-- type OptimizationFuel = State# () -- would like this, but it won't work
data OptimizationFuel = OptimizationFuel
deriving Show
tankFilledTo _ = panic "tankFilledTo" -- should be impossible to evaluate
-- realWorld# might come in handy, too...
canRewriteWithFuel OptimizationFuel = True
maybeRewriteWithFuel _ ma = ma
oneLessFuel f = f
diffFuel _ _ = 0
#endif
data FuelState = FuelState { fs_fuellimit :: OptimizationFuel, fs_lastpass :: String }
newtype FuelMonad a = FuelMonad (FuelState -> UniqSM (a, FuelState))
fuelConsumingPass :: String -> FuelConsumer a -> FuelMonad a
fuelConsumingPass name f = do fuel <- fuelRemaining
let (a, fuel') = f fuel
fuelDecrement name fuel fuel'
return a
runFuelIO :: OptFuelState -> FuelMonad a -> IO a
runFuelIO fs (FuelMonad f) =
do pass <- readIORef (pass_ref fs)
fuel <- readIORef (fuel_ref fs)
u <- mkSplitUniqSupply 'u'
let (a, FuelState fuel' pass') = initUs_ u $ f (FuelState fuel pass)
writeIORef (pass_ref fs) pass'
writeIORef (fuel_ref fs) fuel'
return a
instance Monad FuelMonad where
FuelMonad f >>= k = FuelMonad (\s -> do (a, s') <- f s
let FuelMonad f' = k a in (f' s'))
return a = FuelMonad (\s -> return (a, s))
instance MonadUnique FuelMonad where
getUniqueSupplyM = liftUniq getUniqueSupplyM
getUniqueM = liftUniq getUniqueM
getUniquesM = liftUniq getUniquesM
liftUniq :: UniqSM x -> FuelMonad x
liftUniq x = FuelMonad (\s -> x >>= (\u -> return (u, s)))
class Monad m => FuelUsingMonad m where
fuelRemaining :: m OptimizationFuel
fuelDecrement :: String -> OptimizationFuel -> OptimizationFuel -> m ()
fuelDec1 :: m ()
fuelExhausted :: m Bool
lastFuelPass :: m String
instance FuelUsingMonad FuelMonad where
fuelRemaining = extract fs_fuellimit
lastFuelPass = extract fs_lastpass
fuelExhausted = extract $ not . canRewriteWithFuel . fs_fuellimit
fuelDecrement p f f' = FuelMonad (\s -> return ((), fuelDecrementState p f f' s))
fuelDec1 = FuelMonad f
where f s = if canRewriteWithFuel (fs_fuellimit s) then
return ((), s { fs_fuellimit = oneLessFuel (fs_fuellimit s) })
else panic "Tried to use exhausted fuel supply"
extract :: (FuelState -> a) -> FuelMonad a
extract f = FuelMonad (\s -> return (f s, s))
fuelDecrementState
:: String -> OptimizationFuel -> OptimizationFuel -> FuelState -> FuelState
fuelDecrementState new_optimizer old new s =
FuelState { fs_fuellimit = lim, fs_lastpass = optimizer }
where lim = if diffFuel old (fs_fuellimit s) == 0 then new
else panic $
concat ["lost track of ", new_optimizer, "'s transactions"]
optimizer = if diffFuel old new > 0 then new_optimizer else fs_lastpass s
-- lGraphOfGraph is here because we need uniques to implement it.
lGraphOfGraph :: Graph m l -> Int -> FuelMonad (LGraph m l)
lGraphOfGraph (Graph tail blocks) args =
do entry <- liftM BlockId $ getUniqueM
return $ LGraph entry args
(insertBlock (Block entry emptyStackInfo tail) blocks)
|
