diff options
| -rw-r--r-- | BuildIR.hs | 66 | ||||
| -rw-r--r-- | CodeGen.hs | 86 | ||||
| -rw-r--r-- | Intermediate.hs | 34 | ||||
| -rw-r--r-- | Main.hs | 3 | ||||
| -rw-r--r-- | Optimiser.hs | 329 | ||||
| -rw-r--r-- | RegAlloc.hs | 3 | ||||
| -rw-r--r-- | ReplaceRefs.hs | 7 | ||||
| -rw-r--r-- | X64.hs | 7 | ||||
| -rw-r--r-- | X64Optimiser.hs | 15 | ||||
| -rw-r--r-- | bf.lang | 1 | ||||
| -rw-r--r-- | chaincond.lang | 14 | ||||
| -rw-r--r-- | putstr.lang | 39 | ||||
| -rw-r--r-- | strlen.lang | 11 |
13 files changed, 462 insertions, 153 deletions
@@ -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 @@ -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 @@ -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) @@ -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] @@ -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;} |