summaryrefslogtreecommitdiff
path: root/optimiser.hs
blob: 61096b4786a92f05c19a35e1bb46a39f5edea64b (plain)
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
module Optimiser(optimise) where

import Data.List

-- import Debug.Trace

import AST


type Optimisation = [Instruction] -> [Instruction]


optimisations :: [Optimisation]
optimisations =
    [collectSimilar, nullOps, collectAdds, propagateKnowns, firstSets, propagateSlides, uselessEnd, specialLoops, normaliseOrder, deduplicateSets]

composedOpts :: Optimisation
composedOpts = foldl1 (.) (reverse optimisations)
-- composedOpts = foldl1 (.) (map (traceShowId .) $ 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 (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 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 (ISet v off : rest) =
    let pre = takeWhile (\ins -> isIAdd ins || isISet ins || isIMove ins) rest
        post = drop (length pre) rest
        relevant = filter ((== off) . offsetOf) pre
        irrelevant = filter ((/= off) . offsetOf) pre
        (res, resins) = accumSetAddMove v relevant
    in ISet res off : resins ++ propagateKnowns (irrelevant ++ post)
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
    | gcd v 2 == 1 = ISet 0 off1 : specialLoops rest
specialLoops (ILoop inss off : rest)
    | all isIAdd inss,
      sum (map (\(IAdd v _) -> v) $ filter ((== off) . offsetOf) inss) == -1 =
        let others = map (\(IAdd v o) -> (v, o)) $ filter ((/= off) . offsetOf) inss
            dests = nub $ map snd others
            tos = [(d, sum $ map fst $ filter ((== d) . snd) others) | d <- dests]
        in IMove off tos : specialLoops rest
specialLoops (ILoop inss off : rest) = ILoop (specialLoops inss) off : specialLoops rest
specialLoops (ins : rest) = ins : specialLoops rest

normaliseOrder :: Optimisation
normaliseOrder [] = []
normaliseOrder inss =
    let pre = takeWhile (\ins -> isIAdd ins || isISet ins) inss
        post = drop (length pre) inss
    in if null pre
           then head inss : normaliseOrder (tail inss)
           else filter isISet pre ++ filter isIAdd pre ++ normaliseOrder post

deduplicateSets :: Optimisation
deduplicateSets [] = []
deduplicateSets (IStart : ISet 0 _ : rest) = IStart : deduplicateSets rest
deduplicateSets (ISet _ o1 : ISet v o2 : rest) | o1 == o2 = deduplicateSets $ ISet v o1 : rest
deduplicateSets (ins : rest) = ins : deduplicateSets 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 (IMove from tos : rest) = IMove (from + inc) [(o+inc,m) | (o,m) <- tos] : 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

accumSetAddMove :: Byte -> [Instruction] -> (Byte, [Instruction])
accumSetAddMove acc [] = (acc, [])
accumSetAddMove _ (ISet v' _ : rest) = accumSetAddMove v' rest
accumSetAddMove acc (IAdd v' _ : rest) = accumSetAddMove (acc + v') rest
accumSetAddMove acc (IMove _ tos : rest) =
    let (res, resins) = accumSetAddMove 0 rest
    in (res, [IAdd (m * acc) o | (o,m) <- tos] ++ resins)
accumSetAddMove _ _ = unreachable

unreachable :: a
unreachable = error "Unreachable"