Fourth

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;
+}