aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--BuildIR.hs66
-rw-r--r--CodeGen.hs86
-rw-r--r--Intermediate.hs34
-rw-r--r--Main.hs3
-rw-r--r--Optimiser.hs329
-rw-r--r--RegAlloc.hs3
-rw-r--r--ReplaceRefs.hs7
-rw-r--r--X64.hs7
-rw-r--r--X64Optimiser.hs15
-rw-r--r--bf.lang1
-rw-r--r--chaincond.lang14
-rw-r--r--putstr.lang39
-rw-r--r--strlen.lang11
13 files changed, 462 insertions, 153 deletions
diff --git a/BuildIR.hs b/BuildIR.hs
index 28cbf5e..3d7b6c2 100644
--- a/BuildIR.hs
+++ b/BuildIR.hs
@@ -258,21 +258,20 @@ convertExpression (EBin bo e1 e2 _) nextnext = do
switchBlock bl3
ref <- genTemp (sizeof $ fromJust $ retTypeBO bo (fromJust $ typeof e1) (fromJust $ typeof e2))
case bo of
- BOAdd -> addIns $ IAri AAdd ref1 ref2
- BOSub -> addIns $ IAri ASub ref1 ref2
- BOMul -> addIns $ IAri AMul ref1 ref2
- BODiv -> addIns $ IAri ADiv ref1 ref2
- BOMod -> addIns $ IAri AMod ref1 ref2
- BOEq -> addIns $ IAri AEq ref1 ref2
- BONeq -> addIns $ IAri ANeq ref1 ref2
- BOGt -> addIns $ IAri AGt ref1 ref2
- BOLt -> addIns $ IAri ALt ref1 ref2
- BOGeq -> addIns $ IAri AGeq ref1 ref2
- BOLeq -> addIns $ IAri ALeq ref1 ref2
+ BOAdd -> addIns $ IAri AAdd ref ref1 ref2
+ BOSub -> addIns $ IAri ASub ref ref1 ref2
+ BOMul -> addIns $ IAri AMul ref ref1 ref2
+ BODiv -> addIns $ IAri ADiv ref ref1 ref2
+ BOMod -> addIns $ IAri AMod ref ref1 ref2
+ BOEq -> addIns $ IAri AEq ref ref1 ref2
+ BONeq -> addIns $ IAri ANeq ref ref1 ref2
+ BOGt -> addIns $ IAri AGt ref ref1 ref2
+ BOLt -> addIns $ IAri ALt ref ref1 ref2
+ BOGeq -> addIns $ IAri AGeq ref ref1 ref2
+ BOLeq -> addIns $ IAri ALeq ref ref1 ref2
BOPow -> error $ "Pow operator not implemented"
BOAnd -> undefined
BOOr -> undefined
- addIns $ IMov ref ref1
setTerm $ IJmp nextnext
return ref
convertExpression (EUn UONot e mt) nextnext =
@@ -287,11 +286,14 @@ convertExpression (ESubscript arr sub t) nextnext = do
bl3 <- newBlockNoSwitch
subref <- convertExpression sub bl3
switchBlock bl3
- addIns $ IAri AMul subref (Constant (refSize subref) (fromIntegral elemsz))
- addIns $ IAri AAdd subref (Constant (refSize subref) (fromIntegral $ sizeof TInt))
- addIns $ IAri AAdd arrref subref
+ offref <- genTemp (refSize subref)
+ off8ref <- genTemp (refSize subref)
+ elemptr <- genTemp (refSize arrref)
+ addIns $ IAri AMul offref subref (Constant (refSize subref) (fromIntegral elemsz))
+ addIns $ IAri AAdd off8ref offref (Constant (refSize subref) (fromIntegral $ sizeof TInt))
+ addIns $ IAri AAdd elemptr arrref off8ref
ref <- genTemp elemsz
- addIns $ ILoad ref arrref
+ addIns $ ILoad ref elemptr
setTerm $ IJmp nextnext
return ref
convertExpression (ECast dt e) nextnext = do
@@ -314,9 +316,11 @@ convertExpression (ENew t sze) nextnext = do
szref <- convertExpression sze bl2
switchBlock bl2
ref <- genTemp (sizeof $ TArr t Nothing)
- addIns $ IAri AMul szref (Constant (sizeof TInt) (fromIntegral $ sizeof t))
- addIns $ IAri AAdd szref (Constant (sizeof TInt) (fromIntegral $ sizeof TInt))
- addIns $ ICallr ref "_builtin_malloc" [szref]
+ argref' <- genTemp (sizeof TInt)
+ argref <- genTemp (sizeof TInt)
+ 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]
setTerm $ IJmp nextnext
return ref
@@ -333,13 +337,16 @@ convertAsExpression (AESubscript ae2 expr mrt) valueref nextnext = do
let elemsz = sizeof $ fromJust mrt
ae2ref <- goLoad ae2
bl2 <- newBlockNoSwitch
- offref <- convertExpression expr bl2
+ subref <- convertExpression expr bl2
switchBlock bl2
+ offref' <- genTemp (sizeof TInt)
+ offref <- genTemp (sizeof TInt)
+ elemptr <- genTemp (sizeof TInt)
-- TODO: do bounds checking
- addIns $ IAri AMul offref (Constant (sizeof TInt) (fromIntegral elemsz))
- addIns $ IAri AAdd offref (Constant (sizeof TInt) (fromIntegral $ sizeof TInt))
- addIns $ IAri AAdd ae2ref offref
- addIns $ IStore ae2ref valueref
+ addIns $ IAri AMul offref' subref (Constant (sizeof TInt) (fromIntegral elemsz))
+ addIns $ IAri AAdd offref offref' (Constant (sizeof TInt) (fromIntegral $ sizeof TInt))
+ addIns $ IAri AAdd elemptr ae2ref offref
+ addIns $ IStore elemptr valueref
setTerm $ IJmp nextnext
where
goLoad :: AsExpression -> BuildM Ref
@@ -358,10 +365,13 @@ convertAsExpression (AESubscript ae2 expr mrt) valueref nextnext = do
bl2 <- newBlockNoSwitch
eref <- convertExpression expr' bl2
switchBlock bl2
+ offref' <- genTemp (sizeof TInt)
+ offref <- genTemp (sizeof TInt)
+ elemptr <- genTemp (sizeof TInt)
-- TODO: do bounds checking
- addIns $ IAri AMul eref (Constant (sizeof TInt) (fromIntegral elemsz))
- addIns $ IAri AAdd eref (Constant (sizeof TInt) (fromIntegral $ sizeof TInt))
- addIns $ IAri AAdd ref eref
+ addIns $ IAri AMul offref' eref (Constant (sizeof TInt) (fromIntegral elemsz))
+ addIns $ IAri AAdd offref offref' (Constant (sizeof TInt) (fromIntegral $ sizeof TInt))
+ addIns $ IAri AAdd elemptr ref offref
dstref <- genTemp elemsz
- addIns $ ILoad dstref ref
+ addIns $ ILoad dstref elemptr
return dstref
diff --git a/CodeGen.hs b/CodeGen.hs
index d4c9439..774696f 100644
--- a/CodeGen.hs
+++ b/CodeGen.hs
@@ -20,6 +20,7 @@ import RegAlloc
import Utils
import X64 (Register(..), CondCode(..), XRef(..), Ins(..), xref)
import qualified X64 as X64
+import X64Optimiser
data CGState = CGState
@@ -61,10 +62,11 @@ 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
- return $ [there|prologue.asm|] ++ "\n" ++ X64.stringify x64 ++
+ x64opt <- x64Optimise x64
+ return $ [there|prologue.asm|] ++ "\n" ++ X64.stringify x64opt ++
"\nsection .data\n" ++ (if length vars > 0 then varcg else "db 0 ; keep dyld happy\n")
@@ -96,9 +98,9 @@ codegenFunc (IRFunc _ name al bbs sid) = do
AllocReg reg -> Just reg
AllocMem -> Nothing
- traceShowM temprefsperbb
- traceShowM lifespans
- -- traceM $ "ALLOCATION: " ++ show allocation
+ -- traceShowM temprefsperbb
+ -- traceShowM lifespans
+ traceM $ "ALLOCATION: " ++ show allocation
let nsaves = length usedregs
allocationXref = flip Map.mapWithKey allocation $ \ref alloc -> case alloc of
@@ -133,6 +135,9 @@ findAliasCandidates = concatMap (\(BB _ inss _) -> concatMap goI inss)
where
goI :: IRIns -> [(Ref, Ref)]
goI (IMov d s) = [(d, s)]
+ goI (IAri at d s1 s2)
+ | isCommutative at = [(d, s1), (d, s2)]
+ | otherwise = [(d, s1)]
goI _ = []
findFirstLast :: forall a. (a -> Bool) -> [a] -> Maybe (Int, Int)
@@ -174,7 +179,8 @@ mkmov a@(XReg _ _) b@(XMem _ _ _ _ _) = MOV (xref a) (xref b)
mkmov a@(XReg _ _) b@(XImm _) = MOVi64 (xref a) (xref b)
mkmov a@(XMem _ _ _ _ _) b@(XReg _ _) = MOV (xref a) (xref b)
mkmov a@(XMem _ _ _ _ _) b@(XImm v) | v < 2 ^ (32 :: Int) = MOVi (xref a) (xref b)
-mkmov a b = error $ "Invalid mkmov: " ++ show a ++ "; " ++ show b
+mkmov a b = CALL $ "Invalid mkmov: " ++ show a ++ "; " ++ show b
+-- mkmov a b = error $ "Invalid mkmov: " ++ show a ++ "; " ++ show b
mkcmp :: XRef -> XRef -> X64.Ins
mkcmp a b@(XImm _) = CMPi (xref a) (xref b)
@@ -221,45 +227,56 @@ codegenIns m (ILoad d s) = do
where dm = mkxref d m
sm = mkxref s m
sz = fromIntegral $ refSize d
-codegenIns m (IAri AMul d s) = do
+codegenIns m (IAri AMul d s1 s2) = do
let sz = fromIntegral $ refSize d
- addIns $ mkmov (XReg sz RAX) (mkxref d m)
- addIns $ mkmov (XReg sz RBX) (mkxref s m)
+ addIns $ mkmov (XReg sz RAX) (mkxref s1 m)
+ addIns $ mkmov (XReg sz RBX) (mkxref s2 m)
addIns $ IMULDA (xref $ XReg sz RBX)
addIns $ mkmov (mkxref d m) (XReg sz RAX)
-codegenIns m (IAri ADiv d s) = do
+codegenIns m (IAri ADiv d s1 s2) = do
let sz = fromIntegral $ refSize d
addIns $ XOR (xref $ XReg 4 RDX) (xref $ XReg 4 RDX)
- addIns $ mkmov (XReg sz RAX) (mkxref d m)
- addIns $ mkmov (XReg sz RBX) (mkxref s m)
+ addIns $ mkmov (XReg sz RAX) (mkxref s1 m)
+ addIns $ mkmov (XReg sz RBX) (mkxref s2 m)
addIns $ IDIVDA (xref $ XReg sz RBX)
addIns $ mkmov (mkxref d m) (XReg sz RAX)
-codegenIns m (IAri AMod d s) = do
+codegenIns m (IAri AMod d s1 s2) = do
let sz = fromIntegral $ refSize d
addIns $ XOR (xref $ XReg 4 RDX) (xref $ XReg 4 RDX)
- addIns $ mkmov (XReg sz RAX) (mkxref d m)
- addIns $ mkmov (XReg sz RBX) (mkxref s m)
+ addIns $ mkmov (XReg sz RAX) (mkxref s1 m)
+ addIns $ mkmov (XReg sz RBX) (mkxref s2 m)
addIns $ IDIVDA (xref $ XReg sz RBX)
addIns $ mkmov (mkxref d m) (XReg sz RDX)
-codegenIns m (IAri at d s) = case arithTypeToCondCode at of
+codegenIns m (IAri at d s1 s2) = case arithTypeToCondCode at of
Just cc -> do
- arg2 <- if X64.isXMem dm && X64.isXMem sm
+ arg2 <- if X64.isXMem s1m && X64.isXMem s2m
then do
- addIns $ mkmov (XReg (fromIntegral $ refSize s) RAX) sm
- return $ XReg (fromIntegral $ refSize s) RAX
- else return sm
- addIns $ mkcmp dm arg2
- addIns $ MOVi (xref dm) (xref $ XImm 0)
+ addIns $ mkmov (XReg (fromIntegral $ refSize s2) RAX) s2m
+ return $ XReg (fromIntegral $ refSize s2) RAX
+ else return s2m
+ addIns $ mkcmp s1m arg2
addIns $ SETCC cc (xref $ X64.xrefSetSize 1 dm)
+ addIns $ AND (xref $ X64.xrefSetSize 4 dm) (xref $ XImm 0xff)
Nothing -> do
- arg2 <- if X64.isXMem dm && X64.isXMem sm
+ (_, s1m', s2', s2m') <-
+ if dm == s2m
+ then if dm == s1m
+ then return (s1, s1m, s2, s2m)
+ else if isCommutative at
+ then return (s2, s2m, s1, s1m)
+ else throwError "Noncommutative op with d==s2/=s1"
+ else return (s1, s1m, s2, s2m)
+
+ arg2 <- if X64.isXMem s1m' && X64.isXMem s2m'
then do
- addIns $ mkmov (XReg (fromIntegral $ refSize s) RAX) sm
- return $ XReg (fromIntegral $ refSize s) RAX
- else return sm
+ addIns $ mkmov (XReg (fromIntegral $ refSize s2') RAX) s2m'
+ return $ XReg (fromIntegral $ refSize s2') RAX
+ else return s2m'
+ when (dm /= s1m') $ addIns $ mkmov dm s1m'
addIns $ fromJust (arithTypeToIns at) dm arg2
where dm = mkxref d m
- sm = mkxref s m
+ s1m = mkxref s1 m
+ s2m = mkxref s2 m
codegenIns m (ICall n rs) = do
forM_ (zip (reverse rs) [1::Int ..]) $ \(r, i) ->
let sz = fromIntegral $ refSize r
@@ -328,9 +345,17 @@ arithTypeToIns _ = Nothing
codegenTerm :: AllocMap -> IRTerm -> CGMonad ()
codegenTerm m (IJcc ct a b t e) = do
- addIns $ mkcmp (mkxref a m) (mkxref b m)
+ if X64.isXMem am && X64.isXMem bm
+ then do
+ addIns $ mkmov (XReg (fromIntegral $ refSize b) RAX) bm
+ addIns $ mkcmp am (XReg (fromIntegral $ refSize b) RAX)
+ else do
+ addIns $ mkcmp am bm
addIns $ JCC (cmpTypeToCondCode ct) (".bb" ++ show t)
addIns $ JMP (".bb" ++ show e)
+ where
+ am = mkxref a m
+ bm = mkxref b m
codegenTerm _ (IJmp i) = addIns $ JMP (".bb" ++ show i)
codegenTerm _ IRet = do
spillsz <- gets spillSize
@@ -363,7 +388,10 @@ collectTempRefs bbs =
listRefsIns (IMov a b) = [[LA.Read b], [LA.Write a]]
listRefsIns (IStore a b) = [[LA.Read a, LA.Read b]]
listRefsIns (ILoad a b) = [[LA.Read b], [LA.Write a]]
- listRefsIns (IAri _ a b) = [[LA.Write a, LA.Read b]]
+ listRefsIns (IAri at a b c)
+ -- if not commutative, we don't want to have to xchg the operands
+ | isCommutative at = [[LA.Read b, LA.Read c], [LA.Write a]]
+ | otherwise = [[LA.Read b], [LA.Read c, LA.Write a]]
listRefsIns (ICall _ l) = [map LA.Read l]
listRefsIns (ICallr a _ l) = [LA.Write a : map LA.Read l]
listRefsIns (IResize a b) = [[LA.Read b], [LA.Write a]]
diff --git a/Intermediate.hs b/Intermediate.hs
index 5f3a9f2..f97d407 100644
--- a/Intermediate.hs
+++ b/Intermediate.hs
@@ -24,7 +24,7 @@ data IRIns
= IMov Ref Ref
| IStore Ref Ref
| ILoad Ref Ref
- | IAri ArithType Ref Ref
+ | IAri ArithType Ref Ref Ref -- destination, operand 1, operand 2
| ICall Name [Ref]
| ICallr Ref Name [Ref]
| IResize Ref Ref
@@ -56,6 +56,10 @@ 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) =
@@ -105,8 +109,8 @@ instance Pretty IRIns where
prettyI _ (IMov d s) = "mov " ++ pretty d ++ " <- " ++ pretty s
prettyI _ (IStore d s) = "store *" ++ pretty d ++ " <- " ++ pretty s
prettyI _ (ILoad d s) = "load " ++ pretty d ++ " <- *" ++ pretty s
- prettyI _ (IAri at d s) =
- pretty at ++ " " ++ pretty d ++ ", " ++ pretty s
+ prettyI _ (IAri at d s1 s2) =
+ pretty at ++ " " ++ pretty d ++ " <- " ++ pretty s1 ++ ", " ++ pretty s2
prettyI _ (ICall n al) =
"call " ++ n ++ " (" ++ intercalate ", " (map pretty al) ++ ")"
prettyI _ (ICallr d n al) =
@@ -172,3 +176,27 @@ evaluateCmp ct a b = case ct of
CLt -> a < b
CGeq -> a >= b
CLeq -> a <= b
+
+isCommutative :: ArithType -> Bool
+isCommutative AAdd = True
+isCommutative AMul = True
+isCommutative AAnd = True
+isCommutative AOr = True
+isCommutative AXor = True
+isCommutative AEq = True
+isCommutative ANeq = True
+isCommutative ASub = False
+isCommutative ADiv = False
+isCommutative AMod = False
+isCommutative AGt = False
+isCommutative ALt = False
+isCommutative AGeq = False
+isCommutative ALeq = False
+
+isIMov :: IRIns -> Bool
+isIMov (IMov _ _) = True
+isIMov _ = False
+
+isIAri :: IRIns -> Bool
+isIAri (IAri _ _ _ _) = True
+isIAri _ = False
diff --git a/Main.hs b/Main.hs
index f1307c7..4c0f68d 100644
--- a/Main.hs
+++ b/Main.hs
@@ -35,11 +35,10 @@ main = do
let eres = return source
>>= parseProgram <?> "Parse error"
- -- >>= return . traceShowId
>>= typeCheck <?> "Type error"
>>= buildIR <?> "IR building error"
- -- >>= return . tracePrettyId
>>= optimise <?> "Error while optimising"
+ >>= return . traceShowId
>>= verify <?> "Verify error"
>>= return . tracePrettyId
>>= codegen <?> "Codegen error"
diff --git a/Optimiser.hs b/Optimiser.hs
index 6e6227c..59396b2 100644
--- a/Optimiser.hs
+++ b/Optimiser.hs
@@ -1,5 +1,6 @@
module Optimiser(optimise) where
+import Data.Either
import Data.List
import Data.Maybe
import qualified Data.Map.Strict as Map
@@ -7,6 +8,7 @@ import Debug.Trace
import Defs
import Intermediate
+import Pretty
import ReplaceRefs
import Utils
@@ -16,15 +18,25 @@ type FuncOptimisation = IRFunc -> IRFunc
optimise :: IRProgram -> Error IRProgram
optimise prog =
- let master = foldl1 (.) (reverse optimisations) {-. trace "-- OPT PASS --"-}
- reslist = iterate master prog
- pairs = zip reslist (tail reslist)
- in Right $ fst $ fromJust $ find (uncurry (==)) pairs
+ 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
+ in if True
+ then return $ applyFinalOpts $
+ fst $ fromJust $ find (uncurry (==)) $ zip passreslist (tail passreslist)
+ else return $ reslist !! 5
where
- optimisations = map funcopt $
- -- [chainJumps, removeUnusedBlocks]
- [chainJumps, mergeTerminators, looseJumps, removeUnusedBlocks, identityOps,
- constantPropagate, removeNops, movPush, evaluateInstructions, evaluateTerminators]
+ optimisations = map funcopt
+ [chainJumps, mergeTerminators, looseJumps,
+ removeUnusedBlocks, removeDuplicateBlocks,
+ identityOps,
+ constantPropagate, movPush,
+ arithPush False, removeUnusedInstructions,
+ evaluateInstructions, evaluateTerminators,
+ flipJccs]
+ finaloptimisations = map funcopt
+ [arithPush True]
funcopt :: FuncOptimisation -> Optimisation
@@ -93,6 +105,29 @@ removeUnusedBlocks (IRFunc rt name al bbs sid) = IRFunc rt name al bbs' sid
IJmp i -> i == bid
_ -> False
+removeDuplicateBlocks :: FuncOptimisation
+removeDuplicateBlocks (IRFunc rt name al bbs sid) = IRFunc rt name al bbs' sid
+ where
+ bbs' = let (bbspre, repls) = foldr foldfunc ([], []) bbs
+ in foldl (\l (from, to) -> replaceBBIds from to l) bbspre repls
+
+ foldfunc bb@(BB bid inss term) (l, repls) =
+ case find (\(BB _ inss' term') -> inss == inss' && term == term') l of
+ Nothing -> (bb : l, repls)
+ Just (BB bid' _ _) -> (l, (bid, bid') : repls)
+
+ replaceBBIds :: Id -> Id -> [BB] -> [BB]
+ replaceBBIds from to = map $ \(BB bid inss term) -> BB bid inss $ case term of
+ IJcc ct r1 r2 i1 i2 -> IJcc ct r1 r2 (trans from to i1) (trans from to i2)
+ IJmp i -> IJmp (trans from to i)
+ IRet -> IRet
+ IRetr r -> IRetr r
+ ITermNone -> undefined
+
+ trans :: (Eq a) => a -> a -> a -> a
+ trans a b c | a == c = b
+ | otherwise = c
+
identityOps :: FuncOptimisation
identityOps (IRFunc rt name al bbs sid) = IRFunc rt name al (map go bbs) sid
where
@@ -100,10 +135,13 @@ identityOps (IRFunc rt name al bbs sid) = IRFunc rt name al (map go bbs) sid
go (BB bid inss term) = BB bid (catMaybes $ map goI inss) term
goI :: IRIns -> Maybe IRIns
- goI (IAri AAdd _ (Constant _ 0)) = Nothing
- goI (IAri ASub _ (Constant _ 0)) = Nothing
- goI (IAri AMul _ (Constant _ 1)) = Nothing
- goI (IAri ADiv _ (Constant _ 1)) = Nothing
+ goI (IAri AAdd d s (Constant _ 0)) = Just $ IMov d s
+ goI (IAri AAdd d (Constant _ 0) s) = Just $ IMov d s
+ goI (IAri ASub d s (Constant _ 0)) = Just $ IMov d s
+ goI (IAri AMul d s (Constant _ 1)) = Just $ IMov d s
+ goI (IAri AMul d (Constant _ 1) s) = Just $ IMov d s
+ goI (IAri ADiv d s (Constant _ 1)) = Just $ IMov d s
+ goI (IMov d s) | d == s = Nothing
goI i = Just i
constantPropagate :: FuncOptimisation
@@ -114,12 +152,7 @@ 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
-
- isIMov (IMov _ _) = True
- isIMov _ = False
- in {-trace ("Muts of " ++ show ref ++ ": " ++ show locs ++ ": " ++
- show (map (insAt bbs) locs)) $-}
- if length locs == 1 && isIMov ins
+ in if length locs == 1 && isIMov ins
then Just (loc, ins)
else Nothing
@@ -129,52 +162,173 @@ constantPropagate (IRFunc rt name al bbs sid) = IRFunc rt name al bbs' sid
replaceRefsBBList ref value (nopifyInsAt bbs loc)
_ -> undefined
-removeNops :: FuncOptimisation
-removeNops (IRFunc rt name al bbs sid) =
- IRFunc rt name al (map go bbs) sid
- where
- go (BB bid inss term) = BB bid (filter (not . isNop) inss) term
- isNop INop = True
- isNop _ = False
-
movPush :: FuncOptimisation
-movPush (IRFunc rt name al bbs sid) = IRFunc rt name al bbs' sid
+movPush (IRFunc rt name al bbs sid) = IRFunc rt name al (map goBB bbs) sid
+ where
+ goBB :: BB -> BB
+ goBB (BB bid inss term) =
+ let inss' = go inss term
+ term' = if null inss' then term else pushT (last inss) term
+ in BB bid inss' term'
+
+ go :: [IRIns] -> IRTerm -> [IRIns]
+ go [] _ = []
+ go (ins@(IMov d _) : rest) term
+ | isJust (find (== d) (findAllRefsInss rest ++ findAllRefsTerm term)) =
+ push ins rest term
+ go (ins : rest) term = ins : go rest term
+
+ push :: IRIns -> [IRIns] -> IRTerm -> [IRIns]
+ push mov [] _ = [mov]
+ push (IMov d s) l _ | d == s = l
+ push mov@(IMov d s) (ins@(IMov d' s') : rest) term
+ | d' == d = if d' == s' then push mov rest term else push ins rest term
+ | d' == s = mov : push (IMov d' (replaceRef d s s')) rest term
+ | otherwise = IMov d' (replaceRef d s s') : push mov rest term
+ push mov@(IMov d s) (IResize d' s' : rest) term
+ | d' == d = IResize d' (replaceRef d s s') : go rest term
+ | d' == s = mov : IResize d' (replaceRef d s s') : go rest term
+ | otherwise = IResize d' (replaceRef d s s') : push mov rest term
+ push mov@(IMov d s) (ILoad d' s' : rest) term
+ | d' == d = ILoad d' (replaceRef d s s') : go rest term
+ | d' == s = mov : ILoad d' (replaceRef d s s') : go rest term
+ | otherwise = ILoad d' (replaceRef d s s') : push mov rest term
+ push mov@(IMov d s) (IAri at d' s1' s2' : rest) term
+ | d' == d = IAri at d' (replaceRef d s s1') (replaceRef d s s2') : go rest term
+ | d' == s = mov : IAri at d' (replaceRef d s s1') (replaceRef d s s2') : go rest term
+ | otherwise = IAri at d' (replaceRef d s s1') (replaceRef d s s2') : push mov rest term
+ -- 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.
+ -- push mov@(IMov d s) (ins@(ICallr d' _ _) : rest) term
+ -- | d' == d = mov : ins : go rest term
+ -- | otherwise = replaceRefsIns d s ins : push mov rest term
+ -- push mov@(IMov d s) (ins@(ICall _ _) : rest) term = replaceRefsIns d s ins : push mov rest term
+ push mov@(IMov d s) (ins@(IStore _ _) : rest) term = replaceRefsIns d s ins : push mov rest term
+ push mov (INop : rest) term = push mov rest term
+ push mov l term = mov : go l term
+
+ pushT :: IRIns -> IRTerm -> IRTerm
+ 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
where
- bbs' = map goBB bbs
-
goBB :: BB -> BB
- goBB (BB bid inss term) = BB bid (go inss) term
+ 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 :: [IRIns] -> [IRIns]
+ go :: [Either IRIns IRTerm] -> [Either IRIns IRTerm]
go [] = []
- go (ins@(IMov d _) : rest) | isJust (find (== d) (findAllRefsInss rest)) = push ins rest
+ go (Left ari@(IAri _ _ _ _) : rest) = Left ari : go (propagate ari rest)
go (ins : rest) = ins : go rest
- push :: IRIns -> [IRIns] -> [IRIns]
- push mov [] = [mov]
- push mov@(IMov d s) (ins@(IMov d' s') : rest)
- | d' == d = if s' == d then push mov rest else push ins rest
- | otherwise = replaceRefsIns d s ins : push mov rest
- push mov@(IMov d s) (ins@(IResize d' s') : rest)
- | d' == d = if s' == d then push mov rest else push ins rest
- | otherwise = replaceRefsIns d s ins : push mov rest
- push mov@(IMov d s) (ins@(ILoad d' _) : rest)
- | d' == d = mov : ins : go rest
- | otherwise = replaceRefsIns d s ins : push mov rest
- push mov@(IMov d s) (ins@(IAri at d' s') : rest)
- | d' == d = case (s, s') of
- (Constant sza a, Constant szb b)
- | sza == szb -> push (IMov d (Constant sza $ evaluateArith at a b)) rest
- | otherwise -> error $ "Inconsistent sizes in " ++ show mov ++ "; " ++ show ins
- _ -> mov : ins : go rest
- | otherwise = replaceRefsIns d s ins : push mov rest
- push mov@(IMov d s) (ins@(ICallr d' _ _) : rest)
- | d' == d = mov : ins : go rest
- | otherwise = replaceRefsIns d s ins : push mov rest
- push mov@(IMov d s) (ins@(IStore _ _) : rest) = replaceRefsIns d s ins : push mov rest
- push mov@(IMov d s) (ins@(ICall _ _) : rest) = replaceRefsIns d s ins : push mov rest
- push mov (ins@INop : rest) = ins : push mov rest
- push _ _ = undefined
+ 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
+ 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
+ -- 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
+ -- 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
+ 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) &&
+ (isConstant r1 || isConstant r2) &&
+ at `elem` [AEq, ANeq, AGt, ALt, AGeq, ALeq] =
+ let ct' = if isConstant r2 then ct else flipCmpType ct
+ conref = if isConstant r2 then r2 else r1
+ (ct'', con) = case (ct', conref) of
+ (CEq, Constant _ c) -> (CEq, if c `elem` [0, 1] then c else (-1))
+ (CNeq, Constant _ c) -> (CNeq, if c `elem` [0, 1] then c else (-1))
+ (CGt, Constant _ c) | c < 0 -> (CNeq, (-1))
+ | c == 0 -> (CEq, 1)
+ | otherwise -> (CEq, (-1))
+ (CLt, Constant _ c) | c > 1 -> (CNeq, (-1))
+ | c == 1 -> (CEq, 0)
+ | otherwise -> (CEq, (-1))
+ (CGeq, Constant _ c) | c <= 0 -> (CNeq, (-1))
+ | c == 1 -> (CEq, 1)
+ | otherwise -> (CEq, (-1))
+ (CLeq, Constant _ c) | c >= 1 -> (CNeq, (-1))
+ | c == 0 -> (CEq, 0)
+ | otherwise -> (CEq, (-1))
+ _ -> undefined
+ resterm = case (ct'', con) of
+ (CEq, 0) -> IJcc (invertCmpType (arithTypeToCmpType at)) s1 s2 i1 i2
+ (CEq, 1) -> IJcc (arithTypeToCmpType at) s1 s2 i1 i2
+ (CEq, _) -> IJmp i2
+ (CNeq, 0) -> IJcc (arithTypeToCmpType at) s1 s2 i1 i2
+ (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
+
+flipCmpType :: CmpType -> CmpType
+flipCmpType CEq = CEq
+flipCmpType CNeq = CNeq
+flipCmpType CGt = CLt
+flipCmpType CLt = CGt
+flipCmpType CGeq = CLeq
+flipCmpType CLeq = CGeq
+
+invertCmpType :: CmpType -> CmpType
+invertCmpType CEq = CNeq
+invertCmpType CNeq = CEq
+invertCmpType CGt = CLeq
+invertCmpType CLt = CGeq
+invertCmpType CGeq = CLt
+invertCmpType CLeq = CGt
+
+arithTypeToCmpType :: ArithType -> CmpType
+arithTypeToCmpType AEq = CEq
+arithTypeToCmpType ANeq = CNeq
+arithTypeToCmpType AGt = CGt
+arithTypeToCmpType ALt = CLt
+arithTypeToCmpType AGeq = CGeq
+arithTypeToCmpType ALeq = CLeq
+arithTypeToCmpType _ = undefined
+
+removeUnusedInstructions :: FuncOptimisation
+removeUnusedInstructions (IRFunc rt name al bbs sid) = IRFunc rt name al (map goBB bbs) sid
+ where
+ goBB :: BB -> BB
+ goBB (BB bid inss term) = BB bid (catMaybes $ map goI inss) term
+
+ goI :: IRIns -> Maybe IRIns
+ goI ins@(IMov d _) = pureInstruction d ins
+ goI ins@(IStore _ _) = Just ins
+ goI ins@(ILoad d _) = pureInstruction d ins
+ goI ins@(IAri _ d _ _) = pureInstruction d ins
+ goI ins@(ICall _ _) = Just ins
+ goI ins@(ICallr _ _ _) = Just ins
+ goI ins@(IResize d _) = pureInstruction d ins
+ goI INop = Nothing
+
+ pureInstruction :: Ref -> IRIns -> Maybe IRIns
+ pureInstruction d ins = if length (findMentions' bbs d) == 1 then Nothing else Just ins
evaluateInstructions :: FuncOptimisation
evaluateInstructions (IRFunc rt name al bbs sid) = IRFunc rt name al (map goBB bbs) sid
@@ -183,7 +337,10 @@ evaluateInstructions (IRFunc rt name al bbs sid) = IRFunc rt name al (map goBB b
goBB (BB bid inss term) = BB bid (map goI inss) term
goI :: IRIns -> IRIns
- goI (IResize ref (Constant _ v)) = IMov ref $ Constant (refSize ref) $ truncValue (refSize ref) v
+ goI (IAri at ref (Constant _ v1) (Constant _ v2)) =
+ IMov ref $ Constant (refSize ref) $ truncValue (refSize ref) $ evaluateArith at v1 v2
+ goI (IResize ref (Constant _ v)) =
+ IMov ref $ Constant (refSize ref) $ truncValue (refSize ref) v
goI ins = ins
truncValue :: Size -> Value -> Value
@@ -201,6 +358,16 @@ evaluateTerminators (IRFunc rt name al bbs sid) = IRFunc rt name al bbs' sid
| otherwise = IJmp i2
go term = term
+flipJccs :: FuncOptimisation
+flipJccs (IRFunc rt name al bbs sid) = IRFunc rt name al (map goBB bbs) sid
+ where
+ goBB :: BB -> BB
+ goBB (BB bid inss term) = BB bid inss (goT term)
+
+ goT :: IRTerm -> IRTerm
+ goT (IJcc ct r1@(Constant _ _) r2 i1 i2) = IJcc (flipCmpType ct) r2 r1 i1 i2
+ goT term = term
+
insAt :: [BB] -> (Int, Int) -> IRIns
insAt bbs (i, j) =
@@ -217,28 +384,52 @@ 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
- (IAri _ r _) | r == ref -> Just idx
+ (IAri _ r _ _) | r == ref -> Just idx
(ICallr r _ _) | r == ref -> Just idx
+ (IResize r _) | r == ref -> Just idx
_ -> Nothing
findMutations' :: [BB] -> Ref -> [(Int, Int)]
findMutations' bbs ref =
[(i, j) | (bb, i) <- zip bbs [0..], j <- findMutations bb ref]
+findMentions :: BB -> Ref -> [Int]
+findMentions (BB _ inss term) ref = insres ++ termres
+ where
+ insres = catMaybes $ flip map (zip inss [0..]) $ \(ins, idx) ->
+ if ref `elem` findAllRefsIns ins
+ then Just idx
+ else Nothing
+ termres = if ref `elem` findAllRefsTerm term
+ then [length inss]
+ else []
+
+findMentions' :: [BB] -> Ref -> [(Int, Int)]
+findMentions' bbs ref =
+ [(i, j) | (bb, i) <- zip bbs [0..], j <- findMentions bb ref]
+
findAllRefs :: BB -> [Ref]
findAllRefs (BB _ inss _) = findAllRefsInss inss
findAllRefsInss :: [IRIns] -> [Ref]
-findAllRefsInss inss = uniq $ sort $ concatMap go inss
- where
- go (IMov a b) = [a, b]
- go (IStore a b) = [a, b]
- go (ILoad a b) = [a, b]
- go (IAri _ a b) = [a, b]
- go (ICall _ al) = al
- go (ICallr a _ al) = a : al
- go (IResize a b) = [a, b]
- go INop = []
+findAllRefsInss inss = uniq $ sort $ concatMap findAllRefsIns inss
+
+findAllRefsIns :: IRIns -> [Ref]
+findAllRefsIns (IMov a b) = [a, b]
+findAllRefsIns (IStore a b) = [a, b]
+findAllRefsIns (ILoad a b) = [a, b]
+findAllRefsIns (IAri _ a b c) = [a, b, c]
+findAllRefsIns (ICall _ al) = al
+findAllRefsIns (ICallr a _ al) = a : al
+findAllRefsIns (IResize a b) = [a, b]
+findAllRefsIns INop = []
+
+findAllRefsTerm :: IRTerm -> [Ref]
+findAllRefsTerm (IJcc _ a b _ _) = [a, b]
+findAllRefsTerm (IJmp _) = []
+findAllRefsTerm IRet = []
+findAllRefsTerm (IRetr a) = [a]
+findAllRefsTerm ITermNone = undefined
-- findAllRefs' :: [BB] -> [Ref]
-- findAllRefs' = uniq . sort . concatMap findAllRefs
diff --git a/RegAlloc.hs b/RegAlloc.hs
index d2b1717..3a41aac 100644
--- a/RegAlloc.hs
+++ b/RegAlloc.hs
@@ -42,8 +42,7 @@ regalloc vars' regs aliaspairs =
AllocReg r -> Just r
in if length (stActive st) == length regs
then spillAtInterval st index
- else let -- ([regchoice], fr) = splitAt 1 (stFreeRegs st)
- (regchoice, fr) = case find (`elem` wantedregs) (stFreeRegs st) of
+ else let (regchoice, fr) = case find (`elem` wantedregs) (stFreeRegs st) of
Nothing -> (head (stFreeRegs st), tail (stFreeRegs st))
Just wr -> trace ("Pair-allocated " ++ show name ++ " in " ++ show wr) $
(wr, stFreeRegs st \\ [wr])
diff --git a/ReplaceRefs.hs b/ReplaceRefs.hs
index 3ab73c3..821952b 100644
--- a/ReplaceRefs.hs
+++ b/ReplaceRefs.hs
@@ -1,15 +1,18 @@
module ReplaceRefs
- (replaceRefsIns, replaceRefsTerm, replaceRefsBB, replaceRefsBBList)
+ (replaceRef, replaceRefsIns, replaceRefsTerm, replaceRefsBB, replaceRefsBBList)
where
import Intermediate
+replaceRef :: Ref -> Ref -> Ref -> Ref
+replaceRef = trans
+
replaceRefsIns :: Ref -> Ref -> IRIns -> IRIns
replaceRefsIns from to (IMov a b) = IMov (trans from to a) (trans from to b)
replaceRefsIns from to (IStore a b) = IStore (trans from to a) (trans from to b)
replaceRefsIns from to (ILoad a b) = ILoad (trans from to a) (trans from to b)
-replaceRefsIns from to (IAri at a b) = IAri at (trans from to a) (trans from to b)
+replaceRefsIns from to (IAri at a b c) = IAri at (trans from to a) (trans from to b) (trans from to c)
replaceRefsIns from to (ICall n al) = ICall n (map (trans from to) al)
replaceRefsIns from to (ICallr a n al) = ICallr (trans from to a) n (map (trans from to) al)
replaceRefsIns from to (IResize a b) = IResize (trans from to a) (trans from to b)
diff --git a/X64.hs b/X64.hs
index a2d63aa..66a9605 100644
--- a/X64.hs
+++ b/X64.hs
@@ -68,7 +68,8 @@ instance XRefSub Imm where
instance XRefSub RegMem where
xref x@(XReg _ _) = RegMem x
xref x@(XMem _ _ _ _ _) = RegMem x
- xref _ = undefined
+ xref x = RegMem x
+ -- xref _ = undefined
instance XRefSub RegMemImm where
xref x = RegMemImm x
@@ -266,6 +267,10 @@ xrefSetSize sz (XReg _ r) = XReg sz r
xrefSetSize sz (XMem _ a b c d) = XMem sz a b c d
xrefSetSize _ x@(XImm _) = x
+isXReg :: XRef -> Bool
+isXReg (XReg _ _) = True
+isXReg _ = False
+
isXMem :: XRef -> Bool
isXMem (XMem _ _ _ _ _) = True
isXMem _ = False
diff --git a/X64Optimiser.hs b/X64Optimiser.hs
new file mode 100644
index 0000000..9cae96d
--- /dev/null
+++ b/X64Optimiser.hs
@@ -0,0 +1,15 @@
+module X64Optimiser(x64Optimise) where
+
+import Defs
+import X64
+
+
+x64Optimise :: Asm -> Error Asm
+x64Optimise (Asm funcs) = return $ Asm [(name, concat $ map goI inss) | (name, inss) <- funcs]
+ 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 (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/bf.lang b/bf.lang
index d9366fb..71a5d8a 100644
--- a/bf.lang
+++ b/bf.lang
@@ -88,6 +88,7 @@ func int main() {
int done := 0;
while (done != 1) {
int c := getc();
+ // putc(char(c));
if (c < 0) {
done = 1;
} else {
diff --git a/chaincond.lang b/chaincond.lang
new file mode 100644
index 0000000..542cae9
--- /dev/null
+++ b/chaincond.lang
@@ -0,0 +1,14 @@
+func int main() {
+ int a := 0;
+ if (a == 0) {
+ a = 1;
+ } else {
+ a = 2;
+ }
+ if (a > 0) {
+ a = 10;
+ } else {
+ a = 20;
+ }
+ return a;
+} \ No newline at end of file
diff --git a/putstr.lang b/putstr.lang
index b13e2c5..7485d8f 100644
--- a/putstr.lang
+++ b/putstr.lang
@@ -6,7 +6,17 @@ func putstr(char[] str) {
}
}
-func int main() {return 0;}
+func int main() {
+ char[] str := new char[100];
+ str[0] = 'k';
+ str[1] = 'a';
+ str[2] = str[1];
+ str[3] = 's';
+ str[4] = '\n';
+ str[5] = '\0';
+ putstr(str);
+ return 0;
+}
@@ -17,24 +27,19 @@ irfunc putstr(char[] str)
jmp 7
}}}
{{{(7)
- mov t15Q <- t5Q
- add t15Q, 8Q
- mov t13Q <- astrQ
- add t13Q, t15Q
- load t16B <- *t13Q
- neq t16B, 0B
- jne t16B, 0Q -> 9 | 6
+ add t17Q <- t5Q, 8Q
+ add t18Q <- astrQ, t17Q
+ load t19B <- *t18Q
+ neq t22Q <- t19B, 0B
+ jne t22Q, 0Q -> 9 | 6
}}}
{{{(9)
- mov t25Q <- t5Q
- add t25Q, 8Q
- mov t23Q <- astrQ
- add t23Q, t25Q
- load t26B <- *t23Q
- call putc (t26B)
- mov t30Q <- t5Q
- add t30Q, 1Q
- mov t5Q <- t30Q
+ add t30Q <- t5Q, 8Q
+ add t31Q <- astrQ, t30Q
+ load t32B <- *t31Q
+ call putc (t32B)
+ add t39Q <- t5Q, 1Q
+ mov t5Q <- t39Q
jmp 7
}}}
{{{(6)
diff --git a/strlen.lang b/strlen.lang
new file mode 100644
index 0000000..27c23a3
--- /dev/null
+++ b/strlen.lang
@@ -0,0 +1,11 @@
+func int strlen(char[] str) {
+ int i := 0;
+ char c := str[i];
+ while (c != '\0') {
+ i = i + 1;
+ c = str[i];
+ }
+ return i;
+}
+
+func int main() {return 0;}