summaryrefslogtreecommitdiff
path: root/Optimiser.hs
diff options
context:
space:
mode:
authorTom Smeding <tom.smeding@gmail.com>2019-11-21 20:45:27 +0100
committerTom Smeding <tom.smeding@gmail.com>2019-11-21 20:55:13 +0100
commitcf7b7db0e4040c17e05f851fd0e9d79bc173aafd (patch)
treee4ce52409bf1217fcc40d4701af249a90641916a /Optimiser.hs
parent141b46dc4273cdbccf34f449109ec9df7f01705b (diff)
Tail call optimisation
Diffstat (limited to 'Optimiser.hs')
-rw-r--r--Optimiser.hs140
1 files changed, 139 insertions, 1 deletions
diff --git a/Optimiser.hs b/Optimiser.hs
index c4c60cb..a349803 100644
--- a/Optimiser.hs
+++ b/Optimiser.hs
@@ -1,12 +1,23 @@
+{-# LANGUAGE TupleSections #-}
module Optimiser(optimise) where
import Data.List
+import qualified Data.Map.Strict as Map
+import Data.Maybe
+import qualified Data.Set as Set
+import AST (Name)
import Intermediate
optimise :: IRProgram -> IRProgram
-optimise (IRProgram bbs gfds datas) = IRProgram (mergeBlocks bbs) gfds datas
+optimise (IRProgram bbs gfds datas) =
+ let optf = foldl (.) id
+ [ tailCallIntro
+ , deadStoreElim, deadBBElim gfds
+ , map propAssigns
+ , mergeRets, mergeBlocks]
+ in IRProgram (optf bbs) gfds datas
mergeBlocks :: [BB] -> [BB]
mergeBlocks [] = []
@@ -22,3 +33,130 @@ mergeBlocks allbbs@(BB startb _ _ : _) =
hasJumpTo bid (IJmp a) = a == bid
hasJumpTo _ _ = False
+
+mergeRets :: [BB] -> [BB]
+mergeRets bbs =
+ let rets = Map.fromList [(bid, ret) | BB bid [] ret@(IRet _) <- bbs]
+ in [case bb of
+ BB bid inss (IJmp target) | Just ret <- Map.lookup target rets ->
+ BB bid inss ret
+ _ ->
+ bb
+ | bb <- bbs]
+
+propAssigns :: BB -> BB
+propAssigns (BB bid inss term) =
+ let (state, inss') = mapFoldl propagateI Map.empty inss
+ term' = propagateT state term
+ in BB bid inss' term'
+ where
+ propagateI mp (d@(RTemp i), IAssign r) = let r' = propR mp r
+ in (Map.insert i r' mp, (d, IAssign r'))
+ propagateI mp (d, IAssign r) = (mp, (d, IAssign (propR mp r)))
+ propagateI mp ins@(_, IParam _) = (mp, ins)
+ propagateI mp ins@(_, IClosure _) = (mp, ins)
+ propagateI mp ins@(_, IData _) = (mp, ins)
+ propagateI mp (d, ICallC r rs) = (Map.empty, (d, ICallC (propR mp r) (map (propR mp) rs)))
+ propagateI mp (d, IAllocClo n rs) = (mp, (d, IAllocClo n (map (propR mp) rs)))
+ propagateI mp (d, IDiscard r) = (mp, (d, IDiscard (propR mp r)))
+
+ propagateT mp (IBr r a b) = IBr (propR mp r) a b
+ propagateT _ t@(IJmp _) = t
+ propagateT mp (IRet r) = IRet (propR mp r)
+ propagateT mp (ITailC r rs) = ITailC (propR mp r) (map (propR mp) rs)
+ propagateT _ t@IExit = t
+ propagateT _ t@IUnknown = t
+
+ propR mp ref@(RTemp i) = fromMaybe ref (Map.lookup i mp)
+ propR _ ref = ref
+
+deadBBElim :: Map.Map Name GlobFuncDef -> [BB] -> [BB]
+deadBBElim gfds bbs =
+ let callable = 0 : [bid | GlobFuncDef bid _ _ <- Map.elems gfds]
+ jumpable = concatMap outEdges bbs
+ reachable = Set.fromList (jumpable ++ callable)
+ in filter (\bb -> bidOf bb `Set.member` reachable) bbs
+
+deadStoreElim :: [BB] -> [BB]
+deadStoreElim bbs = [BB bid (filter (not . shouldRemove) inss) term | BB bid inss term <- bbs]
+ where
+ readtemps = Set.fromList (concatMap readTempsBB bbs)
+ alltemps = readtemps <> Set.fromList (concatMap writtenTempsBB bbs)
+ elim = alltemps Set.\\ readtemps
+
+ shouldRemove :: Instruction -> Bool
+ shouldRemove (RNone, IDiscard RNone) = True
+ shouldRemove (RNone, IDiscard (RTemp i)) = i `Set.member` elim
+ shouldRemove (RTemp i, ins) = pureIC ins && i `Set.member` elim
+ shouldRemove _ = False
+
+ pureIC :: InsCode -> Bool
+ pureIC (IAssign _) = True
+ pureIC (IParam _) = True
+ pureIC (IClosure _) = True
+ pureIC (IData _) = True
+ pureIC (IAllocClo _ _) = True
+ pureIC (ICallC _ _) = False
+ pureIC (IDiscard _) = False
+
+tailCallIntro :: [BB] -> [BB]
+tailCallIntro bbs = map introduce bbs
+ where
+ readInBB = map (Set.fromList . readTempsBB) bbs
+ readBefore = init $ scanl (<>) Set.empty readInBB
+ readAfter = tail $ scanr (<>) Set.empty readInBB
+ readInOthers = Map.fromList [(bid, before <> after)
+ | (BB bid _ _, before, after) <- zip3 bbs readBefore readAfter]
+
+ introduce orig@(BB _ [] _) = orig
+ introduce orig@(BB bid inss@(_:_) term) =
+ case (last inss, term) of
+ ((RTemp i1, ICallC cl as), IRet (RTemp i2))
+ | i1 == i2
+ , i1 `Set.notMember` (readInOthers Map.! bid)
+ , i1 `notElem` concatMap (readTempsIC . snd) (init inss) ->
+ BB bid (init inss) (ITailC cl as)
+ _ -> orig
+
+outEdges :: BB -> [Int]
+outEdges (BB _ _ term) = outEdgesT term
+
+outEdgesT :: Terminator -> [Int]
+outEdgesT (IBr _ a b) = [a, b]
+outEdgesT (IJmp a) = [a]
+outEdgesT (IRet _) = []
+outEdgesT (ITailC _ _) = []
+outEdgesT IExit = []
+outEdgesT IUnknown = []
+
+readTempsBB :: BB -> [Int]
+readTempsBB (BB _ inss term) = concatMap (readTempsIC . snd) inss ++ readTempsT term
+
+writtenTempsBB :: BB -> [Int]
+writtenTempsBB (BB _ inss _) = concatMap (readTempsR . fst) inss
+
+readTempsIC :: InsCode -> [Int]
+readTempsIC (IAssign r) = readTempsR r
+readTempsIC (IParam _) = []
+readTempsIC (IClosure _) = []
+readTempsIC (IData _) = []
+readTempsIC (ICallC r rs) = readTempsR r ++ concatMap readTempsR rs
+readTempsIC (IAllocClo _ rs) = concatMap readTempsR rs
+readTempsIC (IDiscard _) = []
+
+readTempsT :: Terminator -> [Int]
+readTempsT (IBr r _ _) = readTempsR r
+readTempsT (IJmp _) = []
+readTempsT (IRet r) = readTempsR r
+readTempsT (ITailC r rs) = readTempsR r ++ concatMap readTempsR rs
+readTempsT IExit = []
+readTempsT IUnknown = []
+
+readTempsR :: Ref -> [Int]
+readTempsR (RConst _) = []
+readTempsR (RTemp i) = [i]
+readTempsR (RSClo _) = []
+readTempsR RNone = []
+
+mapFoldl :: (s -> a -> (s, b)) -> s -> [a] -> (s, [b])
+mapFoldl f s = fmap reverse . foldl' (\(s', yet) x -> fmap (: yet) (f s' x)) (s, [])