aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--BuildIR.hs1
-rw-r--r--CodeGen.hs2
-rw-r--r--Intermediate.hs25
-rw-r--r--LifetimeAnalysis.hs6
-rw-r--r--Main.hs10
-rw-r--r--Makefile2
-rw-r--r--Optimiser.hs67
-rw-r--r--Utils.hs6
-rw-r--r--X64.hs4
-rw-r--r--X64Optimiser.hs24
-rw-r--r--compare.lang10
-rw-r--r--dupifs.lang8
12 files changed, 136 insertions, 29 deletions
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;
+}
generated by cgit v1.2.3-70-g09d2 (git 2.47.0) at 2024-11-21 21:47:01 +0100