aboutsummaryrefslogtreecommitdiff
path: root/Optimiser.hs
diff options
context:
space:
mode:
Diffstat (limited to 'Optimiser.hs')
-rw-r--r--Optimiser.hs101
1 files changed, 65 insertions, 36 deletions
diff --git a/Optimiser.hs b/Optimiser.hs
index 61834f8..531bc7d 100644
--- a/Optimiser.hs
+++ b/Optimiser.hs
@@ -123,6 +123,7 @@ removeDuplicateBlocks (IRFunc rt name al bbs sid) = IRFunc rt name al bbs' sid
IJmp i -> IJmp (trans from to i)
IRet -> IRet
IRetr r -> IRetr r
+ IUnreachable -> IUnreachable
ITermNone -> undefined
trans :: (Eq a) => a -> a -> a -> a
@@ -190,39 +191,41 @@ movPush (IRFunc rt name al bbs sid) = IRFunc rt name al (map goBB bbs) sid
go :: [IRIns] -> IRTerm -> [IRIns]
go [] _ = []
- go (ins@(IMov d _) : rest) term
+ go (IMov d s : rest) term
| isJust (find (== d) (findAllRefsInss rest ++ findAllRefsTerm term)) =
- push ins rest term
+ push (d, s) rest term
go (ins : rest) term = ins : go rest term
- push :: IRIns -> [IRIns] -> IRTerm -> [IRIns]
- push mov [] _ = [mov]
- push (IMov d s) l _ | d == s = l
- push mov@(IMov d s) (ins@(IMov d' s') : rest) term
- | d' == d = if d' == s' then push mov rest term else push ins rest term
- | d' == s = mov : push (IMov d' (replaceRef d s s')) rest term
+ push :: (Ref, Ref) -> [IRIns] -> IRTerm -> [IRIns]
+ push (d, s) [] _ = [IMov d s]
+ push (d, s) l _ | d == s = l
+ push mov@(d, s) (IMov d' s' : rest) term
+ | d' == d = if d' == s' then push mov rest term else push (d', s') rest term
+ | d' == s = IMov d s : push (d', replaceRef d s s') rest term
| otherwise = IMov d' (replaceRef d s s') : push mov rest term
- push mov@(IMov d s) (IResize d' s' : rest) term
+ push mov@(d, s) (IResize d' s' : rest) term
| d' == d = IResize d' (replaceRef d s s') : go rest term
- | d' == s = mov : IResize d' (replaceRef d s s') : go rest term
+ | d' == s = IMov d s : IResize d' (replaceRef d s s') : go rest term
| otherwise = IResize d' (replaceRef d s s') : push mov rest term
- push mov@(IMov d s) (ILoad d' s' : rest) term
+ push mov@(d, s) (ILoad d' s' : rest) term
| d' == d = ILoad d' (replaceRef d s s') : go rest term
- | d' == s = mov : ILoad d' (replaceRef d s s') : go rest term
+ | d' == s = IMov d s : ILoad d' (replaceRef d s s') : go rest term
| otherwise = ILoad d' (replaceRef d s s') : push mov rest term
- push mov@(IMov d s) (IAri at d' s1' s2' : rest) term
+ push mov@(d, s) (IAri at d' s1' s2' : rest) term
| d' == d = IAri at d' (replaceRef d s s1') (replaceRef d s s2') : go rest term
- | d' == s = mov : IAri at d' (replaceRef d s s1') (replaceRef d s s2') : go rest term
+ | d' == s = IMov d s : IAri at d' (replaceRef d s s1') (replaceRef d s s2') : go rest term
| otherwise = IAri at d' (replaceRef d s s1') (replaceRef d s s2') : push mov rest term
-- I don't trust going past calls because globals might change. Might be able to
-- catch that case, but that will go wrong when more stuff gets added.
- -- push mov@(IMov d s) (ins@(ICallr d' _ _) : rest) term
- -- | d' == d = mov : ins : go rest term
+ -- push mov@(d, s) (ins@(ICallr d' _ _) : rest) term
+ -- | d' == d = IMov d s : ins : go rest term
-- | otherwise = replaceRefsIns d s ins : push mov rest term
- -- push mov@(IMov d s) (ins@(ICall _ _) : rest) term = replaceRefsIns d s ins : push mov rest term
- push mov@(IMov d s) (ins@(IStore _ _) : rest) term = replaceRefsIns d s ins : push mov rest term
+ -- push mov@(d, s) (ins@(ICall _ _) : rest) term = replaceRefsIns d s ins : push mov rest term
+ push (d, s) l@(ICallr _ _ _ : _) term = IMov d s : go l term
+ push (d, s) l@(ICall _ _ : _) term = IMov d s : go l term
+ push mov@(d, s) (ins@(IStore _ _) : rest) term = replaceRefsIns d s ins : push mov rest term
+ push (d, s) l@(IDebugger : _) term = IMov d s : go l term
push mov (INop : rest) term = push mov rest term
- push mov l term = mov : go l term
pushT :: IRIns -> IRTerm -> IRTerm
pushT (IMov d s) term = replaceRefsTerm d s term
@@ -245,15 +248,16 @@ arithPush (IRFunc rt name al allbbs sid) = IRFunc rt name al resbbs sid
in foldl (\bbs' tg -> propagateContinue ari tg bbs') resbbs1 tgs
propagateContinue :: IRIns -> BB -> [BB] -> [BB]
- propagateContinue ari bb _ | traceShow (ari, bb) False = undefined
- propagateContinue ari bb@(BB bid _ _) bbs =
- let (cont, (inss', [Right term'])) = fmap (span isLeft) $ propagate ari (bbToList bb)
+ -- propagateContinue ari bb _ | traceShow (ari, bb) False = undefined
+ propagateContinue ari@(IAri at d s1 s2) bb@(BB bid _ _) bbs =
+ let (cont, (inss', [Right term'])) = fmap (span isLeft) $ propagate (at, d, s1, s2) (bbToList bb)
resbbs1 = replaceBlock bid (BB bid (map (fromLeft undefined) inss') term') bbs
in if cont
then let tgs = map (flip blockById bbs) $
filter (\b -> length (originBlocks b) == 1) $ jumpTargets term'
in foldl (\bbs' tg -> propagateContinue ari tg bbs') resbbs1 tgs
else resbbs1
+ propagateContinue _ _ _ = undefined
blockById :: Id -> [BB] -> BB
blockById i bbs = head $ filter (\(BB bid _ _) -> bid == i) bbs
@@ -269,7 +273,7 @@ arithPush (IRFunc rt name al allbbs sid) = IRFunc rt name al resbbs sid
go :: [Either IRIns IRTerm] -> (Maybe IRIns, [Either IRIns IRTerm])
go [] = (Nothing, [])
- go (Left ari@(IAri _ _ _ _) : rest) = case propagate ari rest of
+ go (Left ari@(IAri at d s1 s2) : rest) = case propagate (at, d, s1, s2) rest of
(False, res) -> fmap (Left ari :) $ go res
(True, res) -> (Just ari, Left ari : res)
go (ins : rest) = fmap (ins :) $ go rest
@@ -277,33 +281,33 @@ arithPush (IRFunc rt name al allbbs sid) = IRFunc rt name al resbbs sid
bbToList :: BB -> [Either IRIns IRTerm]
bbToList (BB _ inss term) = map Left inss ++ [Right term]
- propagate :: IRIns -> [Either IRIns IRTerm] -> (Bool, [Either IRIns IRTerm])
+ propagate :: (ArithType, Ref, Ref, Ref) -> [Either IRIns IRTerm] -> (Bool, [Either IRIns IRTerm])
propagate _ [] = (True, [])
- propagate ari@(IAri _ d s1 s2) (Left ins@(IMov md _) : rest)
+ propagate ari@(_, d, s1, s2) (Left ins@(IMov md _) : rest)
| d /= md && md /= s1 && md /= s2 = fmap (Left ins :) $ propagate ari rest
| otherwise = (False, Left ins : rest)
- propagate ari@(IAri _ _ _ _) (Left ins@(IStore _ _) : rest) =
+ propagate ari (Left ins@(IStore _ _) : rest) =
fmap (Left ins :) $ propagate ari rest
- propagate ari@(IAri _ d s1 s2) (Left ins@(ILoad md _) : rest)
+ propagate ari@(_, d, s1, s2) (Left ins@(ILoad md _) : rest)
| d /= md && md /= s1 && md /= s2 = fmap (Left ins :) $ propagate ari rest
| otherwise = (False, Left ins : rest)
- propagate ari@(IAri at d s1 s2) (Left ins@(IAri mat md ms1 ms2) : rest)
+ propagate ari@(at, d, s1, s2) (Left ins@(IAri mat md ms1 ms2) : rest)
| d /= md && (at, s1, s2) == (mat, ms1, ms2) = fmap (Left (IMov md d) :) $ propagate ari rest
| d /= md && md /= s1 && md /= s2 = fmap (Left ins :) $ propagate ari rest
- | otherwise = fmap (Left ins :) $ propagate ins rest
+ | otherwise = fmap (Left ins :) $ propagate (mat, md, ms1, ms2) rest
-- I don't trust going past calls because globals might change. Might be able to
-- catch that case, but that will go wrong when more stuff gets added.
- -- propagate ari@(IAri _ d s1 s2) (Left ins@(ICall _ mal) : rest)
+ -- propagate ari@(_, d, s1, s2) (Left ins@(ICall _ mal) : rest)
-- | null (intersect [d] mal) = fmap (Left ins :) $ propagate ari rest
-- | otherwise = (False, Left ins : rest)
- -- propagate ari@(IAri _ d s1 s2) (Left ins@(ICallr md _ mal) : rest)
+ -- propagate ari@(_, d, s1, s2) (Left ins@(ICallr md _ mal) : rest)
-- | null (intersect [d,s1,s2] (md : mal)) = fmap (Left ins :) $ propagate ari rest
-- | otherwise = (False, Left ins : rest)
- propagate ari@(IAri _ d s1 s2) (Left ins@(IResize md _) : rest)
+ propagate ari@(_, d, s1, s2) (Left ins@(IResize md _) : rest)
| d /= md && md /= s1 && md /= s2 = fmap (Left ins :) $ propagate ari rest
| otherwise = (False, Left ins : rest)
- propagate ari@(IAri _ _ _ _) (Left INop : rest) = propagate ari rest
- propagate (IAri at d s1 s2) (Right term@(IJcc ct r1 r2 i1 i2) : rest)
+ propagate ari (Left INop : rest) = propagate ari rest
+ propagate (at, d, s1, s2) (Right term@(IJcc ct r1 r2 i1 i2) : rest)
| (r1 == d || r2 == d) &&
(isConstant r1 || isConstant r2) &&
at `elem` [AEq, ANeq, AGt, ALt, AGeq, ALeq] =
@@ -335,7 +339,14 @@ arithPush (IRFunc rt name al allbbs sid) = IRFunc rt name al resbbs sid
_ -> undefined
in (True, Right resterm : rest)
| otherwise = (True, Right term : rest)
- propagate _ l = (False, l)
+ propagate _ l@(Left (ICall _ _) : _) = (False, l)
+ propagate _ l@(Left (ICallr _ _ _) : _) = (False, l)
+ propagate _ l@(Left IDebugger : _) = (False, l)
+ propagate _ l@(Right (IJmp _) : _) = (True, l)
+ propagate _ l@(Right IRet : _) = (False, l)
+ propagate _ l@(Right (IRetr _) : _) = (False, l)
+ propagate _ l@(Right IUnreachable : _) = (False, l)
+ propagate _ (Right ITermNone : _) = undefined
flipCmpType :: CmpType -> CmpType
flipCmpType CEq = CEq
@@ -344,6 +355,10 @@ flipCmpType CGt = CLt
flipCmpType CLt = CGt
flipCmpType CGeq = CLeq
flipCmpType CLeq = CGeq
+flipCmpType CUGt = CULt
+flipCmpType CULt = CUGt
+flipCmpType CUGeq = CULeq
+flipCmpType CULeq = CUGeq
invertCmpType :: CmpType -> CmpType
invertCmpType CEq = CNeq
@@ -352,6 +367,10 @@ invertCmpType CGt = CLeq
invertCmpType CLt = CGeq
invertCmpType CGeq = CLt
invertCmpType CLeq = CGt
+invertCmpType CUGt = CULeq
+invertCmpType CULt = CUGeq
+invertCmpType CUGeq = CULt
+invertCmpType CULeq = CUGt
arithTypeToCmpType :: ArithType -> CmpType
arithTypeToCmpType AEq = CEq
@@ -376,6 +395,7 @@ removeUnusedInstructions (IRFunc rt name al bbs sid) = IRFunc rt name al (map go
goI ins@(ICall _ _) = Just ins
goI ins@(ICallr _ _ _) = Just ins
goI ins@(IResize d _) = pureInstruction d ins
+ goI IDebugger = Just IDebugger
goI INop = Nothing
pureInstruction :: Ref -> IRIns -> Maybe IRIns
@@ -436,7 +456,10 @@ reorderBlocks (IRFunc rt name al allbbs sid) = IRFunc rt name al resbbs sid
chain' = chain ++ [at]
in case intersect (jumpTargets term) (map blockIdOf rest) of
[] -> [chain']
- tgs -> concatMap (go rest chain') tgs
+ tgs -> flip concatMap tgs $ \tg ->
+ if hasUnreachable (fst $ takeBlock tg bbs)
+ then []
+ else go rest chain' tg
buildResult :: [[Id]] -> [BB] -> [BB]
buildResult _ [] = []
@@ -453,6 +476,10 @@ reorderBlocks (IRFunc rt name al allbbs sid) = IRFunc rt name al resbbs sid
| bid == target = (bb, rest)
| otherwise = fmap (bb :) $ takeBlock target rest
+ hasUnreachable :: BB -> Bool
+ hasUnreachable (BB _ _ IUnreachable) = True
+ hasUnreachable _ = False
+
invertJccs :: FuncOptimisation
invertJccs (IRFunc rt name al bbs sid) = IRFunc rt name al bbs' sid
where
@@ -539,6 +566,7 @@ findAllRefsIns (IAri _ a b c) = [a, b, c]
findAllRefsIns (ICall _ al) = al
findAllRefsIns (ICallr a _ al) = a : al
findAllRefsIns (IResize a b) = [a, b]
+findAllRefsIns IDebugger = []
findAllRefsIns INop = []
findAllRefsTerm :: IRTerm -> [Ref]
@@ -546,6 +574,7 @@ findAllRefsTerm (IJcc _ a b _ _) = [a, b]
findAllRefsTerm (IJmp _) = []
findAllRefsTerm IRet = []
findAllRefsTerm (IRetr a) = [a]
+findAllRefsTerm IUnreachable = []
findAllRefsTerm ITermNone = undefined
-- findAllRefs' :: [BB] -> [Ref]
generated by cgit v1.2.3-54-g00ecf (git 2.45.0) at 2024-05-18 23:01:49 +0200