diff options
author | tomsmeding <tom.smeding@gmail.com> | 2017-08-21 15:02:54 +0200 |
---|---|---|
committer | tomsmeding <tom.smeding@gmail.com> | 2017-08-21 15:02:54 +0200 |
commit | 3fd304ea2272432a435e6c877ce002ff3d4c77df (patch) | |
tree | 495a88524998d1353ff528bb99cd369fc7fc4bc9 /Optimiser.hs | |
parent | 5aea0d2034c47380bbdd588806efbd5c9c85d765 (diff) |
Seventh
Diffstat (limited to 'Optimiser.hs')
-rw-r--r-- | Optimiser.hs | 155 |
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 |