diff options
Diffstat (limited to 'optimiser.hs')
| -rw-r--r-- | optimiser.hs | 82 |
1 files changed, 48 insertions, 34 deletions
diff --git a/optimiser.hs b/optimiser.hs index 61096b4..2a27a5e 100644 --- a/optimiser.hs +++ b/optimiser.hs @@ -1,8 +1,10 @@ module Optimiser(optimise) where import Data.List +import Data.Function +import qualified Data.Map.Strict as Map --- import Debug.Trace +import Debug.Trace import AST @@ -12,11 +14,12 @@ type Optimisation = [Instruction] -> [Instruction] optimisations :: [Optimisation] optimisations = - [collectSimilar, nullOps, collectAdds, propagateKnowns, firstSets, propagateSlides, uselessEnd, specialLoops, normaliseOrder, deduplicateSets] + [collectSimilar, nullOps, collectAdds, propagateKnowns, firstSets, propagateSlides, uselessEnd, specialLoops, normaliseOrder] composedOpts :: Optimisation -composedOpts = foldl1 (.) (reverse optimisations) +-- 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) = @@ -35,12 +38,15 @@ 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 @@ -53,13 +59,38 @@ collectAdds inss = 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 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 @@ -99,25 +130,17 @@ specialLoops (ILoop inss off : rest) 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 + 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 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 +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 @@ -128,7 +151,7 @@ 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 (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 @@ -141,14 +164,5 @@ 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" |