From c36fd5a174ab74465b8562c5fb4fa69a25dfca79 Mon Sep 17 00:00:00 2001 From: tomsmeding Date: Sun, 20 Aug 2017 14:47:15 +0200 Subject: Fourth --- BuildIR.hs | 1 + CodeGen.hs | 2 +- Intermediate.hs | 25 +++++++++++--------- LifetimeAnalysis.hs | 6 ++--- Main.hs | 10 ++++---- Makefile | 2 +- Optimiser.hs | 67 +++++++++++++++++++++++++++++++++++++++++++++++++---- Utils.hs | 6 +++++ X64.hs | 4 +++- X64Optimiser.hs | 24 +++++++++++++++++-- compare.lang | 10 ++++++++ dupifs.lang | 8 +++++++ 12 files changed, 136 insertions(+), 29 deletions(-) create mode 100644 compare.lang create mode 100644 dupifs.lang diff --git a/BuildIR.hs b/BuildIR.hs index 3d7b6c2..665dd33 100644 --- a/BuildIR.hs +++ b/BuildIR.hs @@ -321,6 +321,7 @@ convertExpression (ENew t sze) nextnext = do addIns $ IAri AMul argref' szref (Constant (sizeof TInt) (fromIntegral $ sizeof t)) addIns $ IAri AAdd argref argref' (Constant (sizeof TInt) (fromIntegral $ sizeof TInt)) addIns $ ICallr ref "_builtin_malloc" [argref] + addIns $ IStore ref szref setTerm $ IJmp nextnext return ref diff --git a/CodeGen.hs b/CodeGen.hs index 764a900..905bee5 100644 --- a/CodeGen.hs +++ b/CodeGen.hs @@ -61,7 +61,7 @@ setSpillSize sz = modify $ \s -> s {spillSize = sz} codegen :: IRProgram -> Error String codegen (IRProgram vars funcs) = do x64 <- execCGMonad $ mapM_ codegenFunc funcs - traceShowM x64 + -- traceShowM x64 X64.verify x64 varcg <- liftM unlines $ mapM codegenVar vars x64opt <- x64Optimise x64 diff --git a/Intermediate.hs b/Intermediate.hs index f97d407..ad3cb89 100644 --- a/Intermediate.hs +++ b/Intermediate.hs @@ -50,17 +50,6 @@ data CmpType deriving (Show, Eq) -refSize :: Ref -> Size -refSize (Temp sz _) = sz -refSize (Argument sz _) = sz -refSize (Global sz _) = sz -refSize (Constant sz _) = sz - -isConstant :: Ref -> Bool -isConstant (Constant _ _) = True -isConstant _ = False - - instance Pretty BB where prettyI i (BB bid inss term) = "{{{(" ++ show bid ++ ")\n" ++ indent (i+1) ++ @@ -151,6 +140,20 @@ instance Pretty CmpType where prettyI _ CLeq = "jle" +blockIdOf :: BB -> Id +blockIdOf (BB bid _ _) = bid + +refSize :: Ref -> Size +refSize (Temp sz _) = sz +refSize (Argument sz _) = sz +refSize (Global sz _) = sz +refSize (Constant sz _) = sz + +isConstant :: Ref -> Bool +isConstant (Constant _ _) = True +isConstant _ = False + + evaluateArith :: ArithType -> Value -> Value -> Value evaluateArith at a b = case at of AAdd -> a + b diff --git a/LifetimeAnalysis.hs b/LifetimeAnalysis.hs index a590862..0921a8a 100644 --- a/LifetimeAnalysis.hs +++ b/LifetimeAnalysis.hs @@ -1,8 +1,9 @@ module LifetimeAnalysis(lifetimeAnalysis, Access(..), unAccess) where -import Data.List import Data.Maybe +import Utils + data Access a = Write a | Read a deriving (Show, Eq) @@ -54,9 +55,6 @@ successors bbs (i, j) = then [(i, j + 1)] else [(n, 0) | n <- nexts] -contains :: Eq a => [a] -> a -> Bool -contains l v = isJust $ find (== v) l - modifyAt2 :: [[a]] -> (Int, Int) -> (a -> a) -> [[a]] modifyAt2 l (i, j) f = modifyAt l i $ \li -> modifyAt li j f diff --git a/Main.hs b/Main.hs index dd07952..b8c50e6 100644 --- a/Main.hs +++ b/Main.hs @@ -28,11 +28,8 @@ tracePrettyId x = trace (pretty x) x eitherToIO :: Either String a -> IO a eitherToIO = either die return - -main :: IO () -main = do - source <- getContents - +performCompile :: String -> IO () +performCompile source = do let eres = return source >>= parseProgram "Parse error" >>= typeCheck "Type error" @@ -53,3 +50,6 @@ main = do hPutStrLn stderr "Linking with ld..." callCommand "ld z_output.o liblang.o -o z_output" + +main :: IO () +main = getContents >>= performCompile diff --git a/Makefile b/Makefile index 0c27b69..ee0c6fb 100644 --- a/Makefile +++ b/Makefile @@ -1,5 +1,5 @@ RUNFLAGS = -GHCFLAGS = -Wall -Widentities -odir obj -hidir obj +GHCFLAGS = -Wall -Widentities -Wno-unused-imports -odir obj -hidir obj ifneq ($(PROFILE),) RUNFLAGS += +RTS -xc GHCFLAGS += -prof -fprof-auto 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) = diff --git a/Utils.hs b/Utils.hs index 65bb651..60f8ff5 100644 --- a/Utils.hs +++ b/Utils.hs @@ -1,7 +1,13 @@ module Utils where +import Data.List +import Data.Maybe + uniq :: Eq a => [a] -> [a] uniq (a:b:cs) | a == b = uniq (b:cs) | otherwise = a : uniq (b:cs) uniq l = l + +contains :: Eq a => [a] -> a -> Bool +contains l v = isJust $ find (== v) l diff --git a/X64.hs b/X64.hs index 66a9605..42a8857 100644 --- a/X64.hs +++ b/X64.hs @@ -49,7 +49,9 @@ data Ins | RET deriving (Show, Eq) -data Asm = Asm [(String, [Ins])] +type Func = (String, [Ins]) + +data Asm = Asm [Func] deriving (Show, Eq) diff --git a/X64Optimiser.hs b/X64Optimiser.hs index 9cae96d..746d88f 100644 --- a/X64Optimiser.hs +++ b/X64Optimiser.hs @@ -5,11 +5,31 @@ import X64 x64Optimise :: Asm -> Error Asm -x64Optimise (Asm funcs) = return $ Asm [(name, concat $ map goI inss) | (name, inss) <- funcs] +x64Optimise asm = + return $ + optUnnecessaryJumps $ + funcopt optSimpleInstructions $ + asm + +funcopt :: (Func -> Func) -> Asm -> Asm +funcopt f (Asm funcs) = Asm (map f funcs) + +optUnnecessaryJumps :: Asm -> Asm +optUnnecessaryJumps (Asm funcs) = Asm $ map goF (zip funcs (tail funcs)) ++ [last funcs] + where + goF :: (Func, Func) -> Func + goF (f1@(_, f1i), (f2n, _)) = case last f1i of + JMP n | n == f2n -> fmap init f1 + _ -> f1 + +optSimpleInstructions :: Func -> Func +optSimpleInstructions (name, inss) = (name, concat $ map goI inss) where goI :: Ins -> [Ins] goI (MOV (RegMem a) (RegMem b)) | a == b = [] - goI (MOVi (RegMem a) (Imm (XImm 0))) | isXReg a = [XOR (RegMem a) (RegMemImm a)] + goI (MOVi (RegMem (XReg 8 r)) (Imm (XImm 0))) = [XOR (RegMem (XReg 4 r)) (RegMemImm (XReg 4 r))] + goI (MOVi (RegMem a@(XReg _ _)) (Imm (XImm 0))) = [XOR (RegMem a) (RegMemImm a)] + goI (MOVi64 (Reg (XReg 8 r)) (Imm (XImm 0))) = [XOR (RegMem (XReg 4 r)) (RegMemImm (XReg 4 r))] goI (MOVi64 (Reg a) (Imm (XImm 0))) = [XOR (RegMem a) (RegMemImm a)] goI (MOVSX (Reg a) (RegMem b)) | a == b = [] goI ins = [ins] diff --git a/compare.lang b/compare.lang new file mode 100644 index 0000000..1de9a70 --- /dev/null +++ b/compare.lang @@ -0,0 +1,10 @@ +func int main() { + int i := 0; + while (i != 10) { + if (i == 5) { + i = i + 2; + } + i = i + 1; + } + return 0; +} diff --git a/dupifs.lang b/dupifs.lang new file mode 100644 index 0000000..91e7ca4 --- /dev/null +++ b/dupifs.lang @@ -0,0 +1,8 @@ +func int main() { + int c := getc(); + int i := 0; + if (c == 97) {i = 1;} + if (c == 98) {i = 2;} + putint(i); + return 0; +} -- cgit v1.2.3-54-g00ecf