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
155
156
157
158
159
160
161
162
163
164
165
166
167
|
module Optimiser(optimise) where
import Data.List
import qualified Data.Map.Strict as Map
-- import Debug.Trace
import AST
type Optimisation = [Instruction] -> [Instruction]
optimisations :: [Optimisation]
optimisations =
[collectSimilar, nullOps, collectAdds, propagateKnowns, firstSets, propagateSlides, uselessEnd, specialLoops, normaliseOrder]
composedOpts :: Optimisation
composedOpts = foldl1 (.) (reverse optimisations)
-- composedOpts = foldl1 (.) (map (traceShowId .) $ reverse optimisations)
-- composedOpts = foldl1 (.) (map ((\r -> traceShow (take 7 r) r) .) $ reverse optimisations)
optimise :: Program -> Program
optimise (Program inss) =
Program $ repeated composedOpts inss
collectSimilar :: Optimisation
collectSimilar [] = []
collectSimilar (IAdd x off1 : IAdd y off2 : rest) | off1 == off2 =
collectSimilar $ IAdd (x + y) off1 : rest
collectSimilar (ISlide off1 : ISlide off2 : rest) =
collectSimilar $ ISlide (off1 + off2) : rest
collectSimilar (ILoop inss off : rest) = ILoop (collectSimilar inss) off : collectSimilar rest
collectSimilar (ins : rest) = ins : collectSimilar rest
nullOps :: Optimisation
nullOps [] = []
nullOps (IAdd 0 _ : rest) = nullOps rest
nullOps (ICopy _ _ 0 : rest) = nullOps rest
nullOps (ISlide 0 : rest) = nullOps rest
nullOps (ILoop inss off : rest) = ILoop (nullOps inss) off : nullOps rest
nullOps (ins : rest) = ins : nullOps rest
collectAdds :: Optimisation
collectAdds [] = []
collectAdds (ICopy from1 to1 m1 : ICopy from2 to2 m2 : rest)
| from1 == from2, m1 == m2 = ICopy from1 to1 m1 : collectAdds (ICopy to1 to2 1 : rest)
collectAdds inss =
let adds = map (\(IAdd v o) -> (v, o)) $ takeWhile isIAdd inss
dests = nub $ map snd adds
collected = [(sum $ map fst $ filter ((== d) . snd) adds, d) | d <- dests]
rest = drop (length adds) inss
rest' = case rest of
[] -> []
(i:is) -> i : collectAdds is
in map (uncurry IAdd) collected ++ rest'
propagateKnowns :: Optimisation
propagateKnowns [] = []
propagateKnowns allinss@(ins : _) | isISet ins || isIStart ins =
let defaultZero = isIStart ins
go :: [Instruction] -> Map.Map Offset Byte -> ([Instruction], Map.Map Offset Byte)
go (IStart : rest) mp = go rest mp
go (ISet val off : rest) mp = go rest $ Map.insert off val mp
go inss@(IAdd val off : rest) mp = case Map.lookup off mp of
Nothing -> (inss, mp)
Just origval -> go rest $ Map.insert off (origval + val) mp
go inss@(ICopy from to mult : rest) mp =
if defaultZero
then let fromval = maybe 0 id $ Map.lookup from mp
toval = maybe 0 id $ Map.lookup to mp
in go rest $ Map.insert to (toval + mult * fromval) mp
else case (Map.lookup from mp, Map.lookup to mp) of
(Nothing, _) -> (inss, mp)
(_, Nothing) -> (inss, mp)
(Just fromval, Just toval) ->
go rest $ Map.insert to (toval + mult * fromval) mp
go inss mp = (inss, mp)
compareSetAdd :: Instruction -> Instruction -> Ordering
compareSetAdd (ISet _ _) (IAdd _ _) = LT
compareSetAdd (IAdd _ _) (ISet _ _) = GT
compareSetAdd i1 i2 = compare (offsetOf i1) (offsetOf i2)
(after, valuemap) = go allinss Map.empty
sets = sortBy compareSetAdd
$ Map.foldlWithKey
(\l off val -> if not defaultZero || val /= 0 then ISet val off : l else l)
[] valuemap
in if isIStart ins then IStart : sets ++ propagateKnowns after else sets ++ propagateKnowns after
propagateKnowns (ILoop inss off : rest) = ILoop (propagateKnowns inss) off : propagateKnowns rest
propagateKnowns (ins : rest) = ins : propagateKnowns rest
firstSets :: Optimisation
firstSets [] = []
firstSets (IStart : rest) =
let pre = takeWhile (\ins -> isIAdd ins || isISet ins) rest
post = drop (length pre) rest
dests = nub $ map offsetOf pre
collected = [ISet (accumSetAdd 0 (filter ((== d) . offsetOf) pre)) d | d <- dests]
in IStart : collected ++ post
firstSets inss = inss
propagateSlides :: Optimisation
propagateSlides [] = []
propagateSlides (ISlide off : rest) = propagateSlides (incOffsets off rest) ++ [ISlide off]
propagateSlides (ILoop inss off : rest) = ILoop (propagateSlides inss) off : propagateSlides rest
propagateSlides (ins : rest) = ins : propagateSlides rest
uselessEnd :: Optimisation
uselessEnd [] = []
uselessEnd inss = reverse $ dropWhile isUseless $ reverse inss
where
isUseless :: Instruction -> Bool
isUseless (IInput _) = False
isUseless (IOutput _) = False
isUseless (ILoop lp _) = all isUseless lp
isUseless _ = True
specialLoops :: Optimisation
specialLoops [] = []
specialLoops (ILoop [IAdd v off2] off1 : rest)
| off1 /= off2 = ILoop [] off1 : specialLoops rest
| odd v = ISet 0 off1 : specialLoops rest
specialLoops (ILoop inss off : rest)
| all isIAdd inss,
sum (map (\(IAdd v _) -> v) $ filter ((== off) . offsetOf) inss) == negate 1 =
let others = map (\(IAdd v o) -> (v, o)) $ filter ((/= off) . offsetOf) inss
dests = nub $ map snd others
copies = [ICopy off d (sum $ map fst $ filter ((== d) . snd) others) | d <- dests]
in copies ++ ISet 0 off : specialLoops rest
specialLoops (ILoop inss off : rest) = ILoop (specialLoops inss) off : specialLoops rest
specialLoops (ins : rest) = ins : specialLoops rest
normaliseOrder :: Optimisation
normaliseOrder [] = []
normaliseOrder (ICopy from1 to1 m1 : ICopy from2 to2 m2 : rest)
| m2 < m1, to1 /= from2, to2 /= from1 = ICopy from2 to2 m2 : normaliseOrder (ICopy from1 to1 m1 : rest)
normaliseOrder (ILoop inss off : rest) = ILoop (normaliseOrder inss) off : normaliseOrder rest
normaliseOrder (ins : rest) = ins : normaliseOrder rest
repeated :: Optimisation -> Optimisation
repeated opt = \inss -> let inss' = opt inss
in if inss == inss' then inss else repeated opt inss'
incOffsets :: Offset -> [Instruction] -> [Instruction]
incOffsets _ [] = []
incOffsets inc (IAdd v off : rest) = IAdd v (off + inc) : incOffsets inc rest
incOffsets inc (ISet v off : rest) = ISet v (off + inc) : incOffsets inc rest
incOffsets inc (ICopy from to mult : rest) = ICopy (from + inc) (to + inc) mult : incOffsets inc rest
incOffsets inc (ISlide off : rest) = ISlide off : incOffsets inc rest
incOffsets inc (ILoop inss off : rest) = ILoop (incOffsets inc inss) (off + inc) : incOffsets inc rest
incOffsets inc (IInput off : rest) = IInput (off + inc) : incOffsets inc rest
incOffsets inc (IOutput off : rest) = IOutput (off + inc) : incOffsets inc rest
incOffsets inc (IStart : rest) = IStart : incOffsets inc rest
accumSetAdd :: Byte -> [Instruction] -> Byte
accumSetAdd acc [] = acc
accumSetAdd _ (ISet v' _ : rest) = accumSetAdd v' rest
accumSetAdd acc (IAdd v' _ : rest) = accumSetAdd (acc + v') rest
accumSetAdd _ _ = unreachable
unreachable :: a
unreachable = error "Unreachable"
|