aboutsummaryrefslogtreecommitdiff
path: root/Optimiser.hs
diff options
context:
space:
mode:
Diffstat (limited to 'Optimiser.hs')
-rw-r--r--Optimiser.hs155
1 files changed, 110 insertions, 45 deletions
diff --git a/Optimiser.hs b/Optimiser.hs
index 2923af6..61834f8 100644
--- a/Optimiser.hs
+++ b/Optimiser.hs
@@ -33,10 +33,10 @@ optimise prog =
removeUnusedBlocks, removeDuplicateBlocks,
identityOps,
constantPropagate, movPush,
- arithPush False, removeUnusedInstructions,
+ arithPush, removeUnusedInstructions,
evaluateInstructions, evaluateTerminators]
finaloptimisations = map funcopt
- [arithPush True, reorderBlocks, flipJccs, invertJccs]
+ [reorderBlocks, flipJccs, invertJccs]
funcopt :: FuncOptimisation -> Optimisation
@@ -153,7 +153,10 @@ constantPropagate (IRFunc rt name al bbs sid) = IRFunc rt name al bbs' sid
let locs = findMutations' bbs ref
loc = head locs
ins = insAt bbs loc
- in if length locs == 1 && isIMov ins
+ readlocs = findMentions' bbs ref \\ locs
+ readinss = map (insAt' bbs) readlocs
+ allimov = all (maybe False isIMov) readinss
+ in if length locs == 1 && (isIMov ins || ((isILoad ins || isIAri ins || isIResize ins) && allimov))
then Just (loc, ins)
else Nothing
@@ -161,8 +164,21 @@ constantPropagate (IRFunc rt name al bbs sid) = IRFunc rt name al bbs' sid
[] -> bbs
((loc, IMov ref value) : _) ->
replaceRefsBBList ref value (nopifyInsAt bbs loc)
+ ((loc, ILoad ref s) : _) ->
+ replaceMovs ref (\r' -> ILoad r' s) (nopifyInsAt bbs loc)
+ ((loc, IAri at ref s1 s2) : _) ->
+ replaceMovs ref (\r' -> IAri at r' s1 s2) (nopifyInsAt bbs loc)
+ ((loc, IResize ref s) : _) ->
+ replaceMovs ref (\r' -> IResize r' s) (nopifyInsAt bbs loc)
_ -> undefined
+ replaceMovs :: Ref -> (Ref -> IRIns) -> [BB] -> [BB]
+ replaceMovs srcref insb = map $ \(BB bid inss term) -> BB bid (map go inss) term
+ where
+ go :: IRIns -> IRIns
+ go (IMov d src) | src == srcref = insb d
+ go ins = ins
+
movPush :: FuncOptimisation
movPush (IRFunc rt name al bbs sid) = IRFunc rt name al (map goBB bbs) sid
where
@@ -212,46 +228,80 @@ movPush (IRFunc rt name al bbs sid) = IRFunc rt name al (map goBB bbs) sid
pushT (IMov d s) term = replaceRefsTerm d s term
pushT _ term = term
-arithPush :: Bool -> FuncOptimisation
-arithPush ariari (IRFunc rt name al bbs sid) = IRFunc rt name al (map goBB bbs) sid
+arithPush :: FuncOptimisation
+arithPush (IRFunc rt name al allbbs sid) = IRFunc rt name al resbbs sid
where
- goBB :: BB -> BB
- goBB (BB bid inss term) =
- let (inss', [Right term']) = span isLeft $ go (map Left inss ++ [Right term])
- in BB bid (map (fromLeft undefined) inss') term'
-
- go :: [Either IRIns IRTerm] -> [Either IRIns IRTerm]
- go [] = []
- go (Left ari@(IAri _ _ _ _) : rest) = Left ari : go (propagate ari rest)
- go (ins : rest) = ins : go rest
-
- propagate :: IRIns -> [Either IRIns IRTerm] -> [Either IRIns IRTerm]
- propagate _ [] = []
- propagate ari@(IAri at d s1 s2) (Left ins@(IMov md ms) : rest)
- | d == ms = Left (IAri at md s1 s2) : (if d /= md then propagate ari rest else rest)
- | d /= md && md /= s1 && md /= s2 = Left ins : propagate ari rest
- | otherwise = Left ins : rest
- propagate ari@(IAri _ d _ _) (Left ins@(IStore md ms) : rest)
- | null (intersect [d] [md,ms]) = Left ins : propagate ari rest
- | otherwise = Left ins : rest
- propagate ari@(IAri _ d s1 s2) (Left ins@(ILoad md ms) : rest)
- | null (intersect [d] [md,ms] ++ intersect [s1,s2] [md]) = Left ins : propagate ari rest
- | otherwise = Left ins : rest
+ resbbs = foldl (\bbs i -> goBB (blockById i bbs) bbs) allbbs (map blockIdOf allbbs)
+
+ goBB :: BB -> [BB] -> [BB]
+ goBB bb@(BB bid _ _) bbs =
+ let (mari, (inss', [Right term'])) = fmap (span isLeft) $ go (bbToList bb)
+ resbbs1 = replaceBlock bid (BB bid (map (fromLeft undefined) inss') term') bbs
+ in case mari of
+ Nothing -> resbbs1
+ Just ari ->
+ let tgs = map (flip blockById bbs) $
+ filter (\b -> length (originBlocks b) == 1) $ jumpTargets term'
+ 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)
+ 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
+
+ blockById :: Id -> [BB] -> BB
+ blockById i bbs = head $ filter (\(BB bid _ _) -> bid == i) bbs
+
+ originBlocks :: Id -> [BB]
+ originBlocks i = filter (\(BB _ _ term) -> i `elem` jumpTargets term) allbbs
+
+ replaceBlock :: Id -> BB -> [BB] -> [BB]
+ replaceBlock _ _ [] = []
+ replaceBlock bid bb (bb'@(BB bid' _ _) : rest)
+ | bid' == bid = bb : rest
+ | otherwise = bb' : replaceBlock bid bb rest
+
+ go :: [Either IRIns IRTerm] -> (Maybe IRIns, [Either IRIns IRTerm])
+ go [] = (Nothing, [])
+ go (Left ari@(IAri _ _ _ _) : rest) = case propagate ari rest of
+ (False, res) -> fmap (Left ari :) $ go res
+ (True, res) -> (Just ari, Left ari : res)
+ go (ins : rest) = fmap (ins :) $ go rest
+
+ bbToList :: BB -> [Either IRIns IRTerm]
+ bbToList (BB _ inss term) = map Left inss ++ [Right term]
+
+ propagate :: IRIns -> [Either IRIns IRTerm] -> (Bool, [Either IRIns IRTerm])
+ propagate _ [] = (True, [])
+ propagate ari@(IAri _ 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) =
+ fmap (Left ins :) $ propagate ari rest
+ propagate ari@(IAri _ 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)
- | ariari && d /= md && (at, s1, s2) == (mat, ms1, ms2) = Left (IMov md d) : propagate ari rest
- | null (intersect [d] [md,ms1,ms2] ++ intersect [s1,s2] [md]) = Left ins : propagate ari rest
- | otherwise = Left ins : propagate ins 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
-- 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)
- -- | null (intersect [d] mal) = Left ins : propagate ari rest
- -- | otherwise = Left ins : 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)
- -- | null (intersect [d,s1,s2] (md : mal)) = Left ins : propagate ari rest
- -- | otherwise = Left ins : rest
- propagate ari@(IAri _ d s1 s2) (Left ins@(IResize md ms) : rest)
- | null (intersect [d] [md,ms] ++ intersect [s1,s2] [md]) = Left ins : propagate ari rest
- | otherwise = Left ins : 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)
+ | 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)
| (r1 == d || r2 == d) &&
@@ -283,9 +333,9 @@ arithPush ariari (IRFunc rt name al bbs sid) = IRFunc rt name al (map goBB bbs)
(CNeq, 1) -> IJcc (invertCmpType (arithTypeToCmpType at)) s1 s2 i1 i2
(CNeq, _) -> IJmp i1
_ -> undefined
- in Right resterm : rest
- | otherwise = Right term : rest
- propagate _ l = l
+ in (True, Right resterm : rest)
+ | otherwise = (True, Right term : rest)
+ propagate _ l = (False, l)
flipCmpType :: CmpType -> CmpType
flipCmpType CEq = CEq
@@ -403,11 +453,6 @@ reorderBlocks (IRFunc rt name al allbbs sid) = IRFunc rt name al resbbs sid
| bid == target = (bb, rest)
| otherwise = fmap (bb :) $ takeBlock target rest
- jumpTargets :: IRTerm -> [Id]
- jumpTargets (IJcc _ _ _ i2 i1) = [i1, i2]
- jumpTargets (IJmp i) = [i]
- jumpTargets _ = []
-
invertJccs :: FuncOptimisation
invertJccs (IRFunc rt name al bbs sid) = IRFunc rt name al bbs' sid
where
@@ -426,6 +471,11 @@ insAt bbs (i, j) =
let (BB _ inss _) = bbs !! i
in inss !! j
+insAt' :: [BB] -> (Int, Int) -> Maybe IRIns
+insAt' bbs (i, j) = do
+ (BB _ inss _) <- if i >= length bbs then Nothing else Just (bbs !! i)
+ if j >= length inss then Nothing else Just (inss !! j)
+
nopifyInsAt :: [BB] -> (Int, Int) -> [BB]
nopifyInsAt bbs (i, j) =
let (pre, BB bid inss term : post) = splitAt i bbs
@@ -436,6 +486,7 @@ findMutations :: BB -> Ref -> [Int]
findMutations (BB _ inss _) ref =
catMaybes $ flip map (zip inss [0..]) $ \(ins, idx) -> case ins of
(IMov r _) | r == ref -> Just idx
+ (ILoad r _) | r == ref -> Just idx
(IAri _ r _ _) | r == ref -> Just idx
(ICallr r _ _) | r == ref -> Just idx
(IResize r _) | r == ref -> Just idx
@@ -460,6 +511,20 @@ findMentions' :: [BB] -> Ref -> [(Int, Int)]
findMentions' bbs ref =
[(i, j) | (bb, i) <- zip bbs [0..], j <- findMentions bb ref]
+-- findMentionsIns :: BB -> Ref -> [IRIns]
+-- findMentionsIns (BB _ inss term) ref = insres ++ termres
+-- where
+-- insres = catMaybes $ flip map (zip inss [0..]) $ \(ins, idx) ->
+-- if ref `elem` findAllRefsIns ins
+-- then Just ins
+-- else Nothing
+-- termres = if ref `elem` findAllRefsTerm term
+-- then [term]
+-- else []
+
+-- findMentionsIns' :: [BB] -> Ref -> [IRIns]
+-- findMentionsIns' bbs ref = concatMap (flip findMentionsIns ref) bbs
+
findAllRefs :: BB -> [Ref]
findAllRefs (BB _ inss _) = findAllRefsInss inss
generated by cgit v1.2.3-54-g00ecf (git 2.45.0) at 2024-05-19 01:05:24 +0200