diff options
Diffstat (limited to 'Optimiser.hs')
| -rw-r--r-- | Optimiser.hs | 67 |
1 files changed, 63 insertions, 4 deletions
diff --git a/Optimiser.hs b/Optimiser.hs index 59396b2..c31b6dd 100644 --- a/Optimiser.hs +++ b/Optimiser.hs @@ -18,7 +18,7 @@ type FuncOptimisation = IRFunc -> IRFunc optimise :: IRProgram -> Error IRProgram optimise prog = - let optlist = [trace "-- OPT PASS --" , \p -> trace (pretty p) p] ++ optimisations + let optlist = [trace "-- OPT PASS --" {-, \p -> trace (pretty p) p-}] ++ optimisations reslist = scanl (flip ($)) prog $ cycle optlist passreslist = map fst $ filter (\(_, i) -> i `mod` length optlist == 0) $ zip reslist [0..] applyFinalOpts p = foldl (flip ($)) p finaloptimisations @@ -33,10 +33,9 @@ optimise prog = identityOps, constantPropagate, movPush, arithPush False, removeUnusedInstructions, - evaluateInstructions, evaluateTerminators, - flipJccs] + evaluateInstructions, evaluateTerminators] finaloptimisations = map funcopt - [arithPush True] + [arithPush True, reorderBlocks, flipJccs, invertJccs] funcopt :: FuncOptimisation -> Optimisation @@ -61,6 +60,7 @@ chainJumps (IRFunc rt name al bbs sid) = IRFunc rt name al bbs' sid where hasJmpTo :: Id -> BB -> Bool hasJmpTo i (BB _ _ (IJmp i')) = i == i' + hasJmpTo i (BB _ _ (IJcc _ _ _ i1 i2)) = i == i1 || i == i2 hasJmpTo _ _ = False isSuitable :: BB -> Bool @@ -368,6 +368,65 @@ flipJccs (IRFunc rt name al bbs sid) = IRFunc rt name al (map goBB bbs) sid goT (IJcc ct r1@(Constant _ _) r2 i1 i2) = IJcc (flipCmpType ct) r2 r1 i1 i2 goT term = term +reorderBlocks :: FuncOptimisation +reorderBlocks (IRFunc rt name al bbs sid) = IRFunc rt name al bbs' sid + where + bbs' = uncurry (buildResult [] (foldl foldfunc Map.empty bbs)) $ takeBlock sid bbs + + foldfunc m (BB bid _ _) = + let candidates = map blockIdOf $ flip filter bbs $ \(BB bid' _ term') -> + term' `canJumpTo` bid && isNothing (Map.lookup bid' m) + in case candidates of + [cand] -> let m' = Map.insert cand bid m + in if hasCycle m' cand then m else m' + _ -> m + + buildResult :: [BB] -> Map.Map Id Id -> BB -> [BB] -> [BB] + buildResult pre _ bb [] = pre ++ [bb] + buildResult pre succmap bb@(BB bid _ _) rest = case Map.lookup bid succmap of + Nothing -> buildResult (pre ++ [bb]) succmap hbb hrest + where i = fromMaybe (blockIdOf (head rest)) $ findChainHead succmap + (hbb, hrest) = takeBlock i rest + Just next -> buildResult (pre ++ [bb]) (Map.delete bid succmap) hbb hrest + where (hbb, hrest) = takeBlock next rest + + takeBlock :: Id -> [BB] -> (BB, [BB]) + takeBlock _ [] = undefined + takeBlock target (bb@(BB bid _ _) : rest) + | bid == target = (bb, rest) + | otherwise = fmap (bb :) $ takeBlock target rest + + findChainHead :: Ord a => Map.Map a a -> Maybe a + findChainHead mp = case Map.keys mp \\ Map.elems mp of + [] -> Nothing + (x:_) -> Just x + + hasCycle :: (Show a, Ord a) => Map.Map a a -> a -> Bool + hasCycle mp from = + let values = map fromJust $ takeWhile isJust $ iterate (>>= (\x -> Map.lookup x mp)) (Just from) + in go [] values + where + go _ [] = False + go l (x:xs) | l `contains` x = True + | otherwise = go (x:l) xs + + canJumpTo :: IRTerm -> Id -> Bool + canJumpTo (IJcc _ _ _ i1 i2) i = i1 == i || i2 == i + canJumpTo (IJmp i') i = i' == i + canJumpTo _ _ = False + +invertJccs :: FuncOptimisation +invertJccs (IRFunc rt name al bbs sid) = IRFunc rt name al bbs' sid + where + bbs' = map goBB (zip bbs (tail bbs)) ++ [last bbs] + + goBB :: (BB, BB) -> BB + goBB (BB bid inss term, BB nextbid _ _) = BB bid inss (goT term nextbid) + + goT :: IRTerm -> Id -> IRTerm + goT (IJcc ct r1 r2 i1 i2) next | i1 == next = IJcc (invertCmpType ct) r1 r2 i2 i1 + goT term _ = term + insAt :: [BB] -> (Int, Int) -> IRIns insAt bbs (i, j) = |