diff options
| -rw-r--r-- | AST.hs | 6 | ||||
| -rw-r--r-- | BuildIR.hs | 49 | ||||
| -rw-r--r-- | CodeGen.hs | 12 | ||||
| -rw-r--r-- | Intermediate.hs | 15 | ||||
| -rw-r--r-- | Makefile | 6 | ||||
| -rw-r--r-- | Optimiser.hs | 101 | ||||
| -rw-r--r-- | ProgramParser.hs | 27 | ||||
| -rw-r--r-- | ReplaceRefs.hs | 2 | ||||
| -rw-r--r-- | TypeCheck.hs | 2 | ||||
| -rw-r--r-- | TypeRules.hs | 2 | ||||
| -rw-r--r-- | X64.hs | 4 | ||||
| -rw-r--r-- | bf.lang | 14 | ||||
| -rw-r--r-- | liblang.asm | 22 |
13 files changed, 210 insertions, 52 deletions
@@ -30,6 +30,7 @@ data Statement | SBreak Int | SReturn (Maybe Expression) | SExpr Expression + | SDebugger deriving (Show, Eq) data AsExpression @@ -49,6 +50,7 @@ data Expression data BinaryOp = BOAdd | BOSub | BOMul | BODiv | BOMod | BOPow | BOAnd | BOOr + | BOBitAnd | BOBitOr | BOBitXor | BOEq | BONeq | BOGt | BOLt | BOGeq | BOLeq deriving (Show, Eq) @@ -121,6 +123,7 @@ instance Pretty Statement where prettyI i (SReturn (Just e)) = "return " ++ prettyI i e ++ ";" prettyI i (SExpr e) = prettyI i e ++ ";" + prettyI _ SDebugger = "debugger;" instance Pretty Expression where prettyI i (EBin bo a b (Just t)) = @@ -164,6 +167,9 @@ instance Pretty BinaryOp where prettyI _ BOLt = "<" prettyI _ BOGeq = ">=" prettyI _ BOLeq = "<=" + prettyI _ BOBitAnd = "&" + prettyI _ BOBitOr = "|" + prettyI _ BOBitXor = "^" instance Pretty UnaryOp where @@ -23,6 +23,7 @@ data BuildState = BuildState scopeStack :: [Scope], loopStack :: [Id], currentBlock :: Id, + errorBlock :: Id, blockMap :: Map.Map Id BB } initBuildState :: BuildState @@ -31,6 +32,7 @@ initBuildState = BuildState scopeStack = [], loopStack = [], currentBlock = undefined, + errorBlock = undefined, blockMap = Map.empty } newtype BuildM a = BuildM {unBuildM :: StateT BuildState (Except String) a} @@ -56,6 +58,9 @@ newBlockNoSwitch = do modify $ \s -> s {blockMap = Map.insert i block (blockMap s)} return i +setErrorBlock :: Id -> BuildM () +setErrorBlock i = modify $ \s -> s {errorBlock = i} + addIns :: IRIns -> BuildM () addIns ins = modify $ \s -> s { @@ -121,6 +126,8 @@ buildIR (Program vars funcs) = clearBlockMap firstid <- newBlock lastid <- newBlockNoSwitch + makeErrorBlock >>= setErrorBlock + switchBlock firstid withScope $ do forM_ al $ \(at, an) -> scopeInsert an (Argument (sizeof at) an) at convertBlock bl lastid @@ -129,6 +136,13 @@ buildIR (Program vars funcs) = bblist <- getAllBlocks return $ IRFunc rt n al bblist firstid + makeErrorBlock :: BuildM Id + makeErrorBlock = do + bl <- newBlock + addIns $ ICall "_builtin_outofbounds" [] + setTerm IUnreachable + return bl + result :: BuildM IRProgram result = do withScope $ do @@ -196,6 +210,9 @@ convertStatement (SReturn (Just e)) _ = do setTerm $ IRetr ref convertStatement (SExpr e) nextnext = do void $ convertExpression e nextnext +convertStatement SDebugger nextnext = do + addIns IDebugger + setTerm $ IJmp nextnext convertExpression :: Expression -> Id -> BuildM Ref convertExpression (ELit (LInt n) _) nextnext = do @@ -282,6 +299,9 @@ convertExpression (EBin bo e1 e2 _) nextnext = do BOGeq -> addIns $ IAri AGeq ref ref1 ref2 BOLeq -> addIns $ IAri ALeq ref ref1 ref2 BOPow -> error $ "Pow operator not implemented" + BOBitAnd -> addIns $ IAri AAnd ref ref1 ref2 + BOBitOr -> addIns $ IAri AOr ref ref1 ref2 + BOBitXor -> addIns $ IAri AXor ref ref1 ref2 BOAnd -> undefined BOOr -> undefined setTerm $ IJmp nextnext @@ -301,6 +321,15 @@ convertExpression (ESubscript arr sub t) nextnext = do offref <- genTemp (refSize subref) off8ref <- genTemp (refSize subref) elemptr <- genTemp (refSize arrref) + arrsz <- genTemp (sizeof TInt) + + errbl <- gets errorBlock + + addIns $ ILoad arrsz arrref + bl4 <- newBlockNoSwitch + setTerm $ IJcc CUGeq subref arrsz errbl bl4 + + switchBlock bl4 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 @@ -355,7 +384,15 @@ convertAsExpression (AESubscript ae2 expr mrt) valueref nextnext = do offref' <- genTemp (sizeof TInt) offref <- genTemp (sizeof TInt) elemptr <- genTemp (sizeof TInt) - -- TODO: do bounds checking + arrsz <- genTemp (sizeof TInt) + + errbl <- gets errorBlock + + addIns $ ILoad arrsz ae2ref + bl3 <- newBlockNoSwitch + setTerm $ IJcc CUGeq subref arrsz errbl bl3 + + switchBlock bl3 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 @@ -381,7 +418,15 @@ convertAsExpression (AESubscript ae2 expr mrt) valueref nextnext = do offref' <- genTemp (sizeof TInt) offref <- genTemp (sizeof TInt) elemptr <- genTemp (sizeof TInt) - -- TODO: do bounds checking + arrsz <- genTemp (sizeof TInt) + + errbl <- gets errorBlock + + addIns $ ILoad arrsz ref + bl3 <- newBlockNoSwitch + setTerm $ IJcc CUGeq eref arrsz errbl bl3 + + switchBlock bl3 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 @@ -65,7 +65,7 @@ codegen (IRProgram vars funcs) = do X64.verify x64 varcg <- liftM unlines $ mapM codegenVar vars x64opt <- x64Optimise x64 - return $ "extern putc, putint, getc, _builtin_malloc\n" ++ + return $ "extern putc, putint, getc, exit, _builtin_malloc, _builtin_outofbounds\n" ++ "global main\ndefault rel\nsection .text\n" ++ X64.stringify x64opt ++ "\nsection .data\n" ++ varcg @@ -317,6 +317,8 @@ codegenIns m fullins@(IResize d s) = do addIns $ mkmov dm (XReg dsz RAX) else do addIns $ mkmov dm (X64.xrefSetSize dsz sm) +codegenIns _ IDebugger = do + addIns $ INT3 codegenIns _ INop = return () arithTypeToCondCode :: ArithType -> Maybe X64.CondCode @@ -335,6 +337,10 @@ cmpTypeToCondCode CGt = CCG cmpTypeToCondCode CLt = CCL cmpTypeToCondCode CGeq = CCGE cmpTypeToCondCode CLeq = CCLE +cmpTypeToCondCode CUGt = CCA +cmpTypeToCondCode CULt = CCB +cmpTypeToCondCode CUGeq = CCAE +cmpTypeToCondCode CULeq = CCBE arithTypeToIns :: ArithType -> Maybe (XRef -> XRef -> X64.Ins) arithTypeToIns AAdd = Just $ \a b -> ADD (xref a) (xref b) @@ -375,6 +381,7 @@ codegenTerm m (IRetr r) = do addIns $ mkmov (XReg 8 RSP) (XReg 8 RBP) addIns $ POP (xref $ XReg 8 RBP) addIns RET +codegenTerm _ IUnreachable = return () codegenTerm _ ITermNone = undefined @@ -396,6 +403,7 @@ collectTempRefs bbs = 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]] + listRefsIns IDebugger = [[]] listRefsIns INop = [[]] listRefsTerm :: IRTerm -> [[LA.Access Ref]] @@ -403,6 +411,7 @@ collectTempRefs bbs = listRefsTerm (IJmp _) = [[]] listRefsTerm IRet = [[]] listRefsTerm (IRetr a) = [[LA.Read a]] + listRefsTerm IUnreachable = [] listRefsTerm ITermNone = undefined listNextIds :: IRTerm -> [Id] @@ -410,6 +419,7 @@ collectTempRefs bbs = listNextIds (IJmp a) = [a] listNextIds IRet = [] listNextIds (IRetr _) = [] + listNextIds IUnreachable = [] listNextIds ITermNone = undefined isTemp :: Ref -> Bool diff --git a/Intermediate.hs b/Intermediate.hs index c395f55..6cbccda 100644 --- a/Intermediate.hs +++ b/Intermediate.hs @@ -2,6 +2,7 @@ module Intermediate where import Data.Bits import Data.List +import Data.Word import AST import Defs @@ -28,6 +29,7 @@ data IRIns | ICall Name [Ref] | ICallr Ref Name [Ref] | IResize Ref Ref + | IDebugger | INop deriving (Show, Eq) @@ -36,6 +38,7 @@ data IRTerm | IJmp Id | IRet | IRetr Ref + | IUnreachable | ITermNone deriving (Show, Eq) @@ -46,7 +49,7 @@ data ArithType deriving (Show, Eq) data CmpType - = CEq | CNeq | CGt | CLt | CGeq | CLeq + = CEq | CNeq | CGt | CLt | CGeq | CLeq | CUGt | CULt | CUGeq | CULeq deriving (Show, Eq) @@ -105,6 +108,7 @@ instance Pretty IRIns where prettyI _ (ICallr d n al) = "call " ++ pretty d ++ " <- " ++ n ++ " (" ++ intercalate ", " (map pretty al) ++ ")" prettyI _ (IResize d s) = "resize " ++ pretty d ++ " <- " ++ pretty s + prettyI _ IDebugger = "debugger" prettyI _ INop = "nop" instance Pretty IRTerm where @@ -113,6 +117,7 @@ instance Pretty IRTerm where prettyI _ (IJmp did) = "jmp " ++ show did prettyI _ IRet = "ret" prettyI _ (IRetr ref) = "retr " ++ pretty ref + prettyI _ IUnreachable = "unreachable" prettyI _ ITermNone = "?NONE?" instance Pretty ArithType where @@ -138,6 +143,10 @@ instance Pretty CmpType where prettyI _ CLt = "jl" prettyI _ CGeq = "jge" prettyI _ CLeq = "jle" + prettyI _ CUGt = "jug" + prettyI _ CULt = "jul" + prettyI _ CUGeq = "juge" + prettyI _ CULeq = "jule" blockIdOf :: BB -> Id @@ -179,6 +188,10 @@ evaluateCmp ct a b = case ct of CLt -> a < b CGeq -> a >= b CLeq -> a <= b + CUGt -> (fromIntegral a :: Word64) > (fromIntegral b :: Word64) + CULt -> (fromIntegral a :: Word64) < (fromIntegral b :: Word64) + CUGeq -> (fromIntegral a :: Word64) >= (fromIntegral b :: Word64) + CULeq -> (fromIntegral a :: Word64) <= (fromIntegral b :: Word64) isCommutative :: ArithType -> Bool isCommutative AAdd = True @@ -1,5 +1,5 @@ RUNFLAGS = -GHCFLAGS = -Wall -Widentities -Wno-unused-imports -odir obj -hidir obj +GHCFLAGS = -Wall -Widentities -Wno-unused-imports -odir obj -hidir obj -j2 ifneq ($(PROFILE),) RUNFLAGS += +RTS -xc GHCFLAGS += -prof -fprof-auto @@ -11,7 +11,7 @@ TARGET = main .PHONY: all clean run -all: $(TARGET) +all: $(TARGET) liblang.o clean: rm -f $(TARGET) @@ -21,7 +21,7 @@ run: $(TARGET) ./$(TARGET) $(RUNFLAGS) -$(TARGET): $(wildcard *.hs) liblang.o +$(TARGET): $(wildcard *.hs) @mkdir -p obj ghc $(GHCFLAGS) Main.hs -o $@ diff --git a/Optimiser.hs b/Optimiser.hs index 61834f8..531bc7d 100644 --- a/Optimiser.hs +++ b/Optimiser.hs @@ -123,6 +123,7 @@ removeDuplicateBlocks (IRFunc rt name al bbs sid) = IRFunc rt name al bbs' sid IJmp i -> IJmp (trans from to i) IRet -> IRet IRetr r -> IRetr r + IUnreachable -> IUnreachable ITermNone -> undefined trans :: (Eq a) => a -> a -> a -> a @@ -190,39 +191,41 @@ movPush (IRFunc rt name al bbs sid) = IRFunc rt name al (map goBB bbs) sid go :: [IRIns] -> IRTerm -> [IRIns] go [] _ = [] - go (ins@(IMov d _) : rest) term + go (IMov d s : rest) term | isJust (find (== d) (findAllRefsInss rest ++ findAllRefsTerm term)) = - push ins rest term + push (d, s) 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 + push :: (Ref, Ref) -> [IRIns] -> IRTerm -> [IRIns] + push (d, s) [] _ = [IMov d s] + push (d, s) l _ | d == s = l + push mov@(d, s) (IMov d' s' : rest) term + | d' == d = if d' == s' then push mov rest term else push (d', s') rest term + | d' == s = IMov d s : push (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 + push mov@(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 + | d' == s = IMov d s : 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 + push mov@(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 + | d' == s = IMov d s : 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 + push mov@(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 + | d' == s = IMov d s : 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 + -- push mov@(d, s) (ins@(ICallr d' _ _) : rest) term + -- | d' == d = IMov d s : 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@(d, s) (ins@(ICall _ _) : rest) term = replaceRefsIns d s ins : push mov rest term + push (d, s) l@(ICallr _ _ _ : _) term = IMov d s : go l term + push (d, s) l@(ICall _ _ : _) term = IMov d s : go l term + push mov@(d, s) (ins@(IStore _ _) : rest) term = replaceRefsIns d s ins : push mov rest term + push (d, s) l@(IDebugger : _) term = IMov d s : go l 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 @@ -245,15 +248,16 @@ arithPush (IRFunc rt name al allbbs sid) = IRFunc rt name al resbbs sid in foldl (\bbs' tg -> propagateContinue ari tg bbs') resbbs1 tgs propagateContinue :: IRIns -> BB -> [BB] -> [BB] - propagateContinue ari bb _ | traceShow (ari, bb) False = undefined - propagateContinue ari bb@(BB bid _ _) bbs = - let (cont, (inss', [Right term'])) = fmap (span isLeft) $ propagate ari (bbToList bb) + -- propagateContinue ari bb _ | traceShow (ari, bb) False = undefined + propagateContinue ari@(IAri at d s1 s2) bb@(BB bid _ _) bbs = + let (cont, (inss', [Right term'])) = fmap (span isLeft) $ propagate (at, d, s1, s2) (bbToList bb) resbbs1 = replaceBlock bid (BB bid (map (fromLeft undefined) inss') term') bbs in if cont then let tgs = map (flip blockById bbs) $ filter (\b -> length (originBlocks b) == 1) $ jumpTargets term' in foldl (\bbs' tg -> propagateContinue ari tg bbs') resbbs1 tgs else resbbs1 + propagateContinue _ _ _ = undefined blockById :: Id -> [BB] -> BB blockById i bbs = head $ filter (\(BB bid _ _) -> bid == i) bbs @@ -269,7 +273,7 @@ arithPush (IRFunc rt name al allbbs sid) = IRFunc rt name al resbbs sid go :: [Either IRIns IRTerm] -> (Maybe IRIns, [Either IRIns IRTerm]) go [] = (Nothing, []) - go (Left ari@(IAri _ _ _ _) : rest) = case propagate ari rest of + go (Left ari@(IAri at d s1 s2) : rest) = case propagate (at, d, s1, s2) rest of (False, res) -> fmap (Left ari :) $ go res (True, res) -> (Just ari, Left ari : res) go (ins : rest) = fmap (ins :) $ go rest @@ -277,33 +281,33 @@ arithPush (IRFunc rt name al allbbs sid) = IRFunc rt name al resbbs sid bbToList :: BB -> [Either IRIns IRTerm] bbToList (BB _ inss term) = map Left inss ++ [Right term] - propagate :: IRIns -> [Either IRIns IRTerm] -> (Bool, [Either IRIns IRTerm]) + propagate :: (ArithType, Ref, Ref, Ref) -> [Either IRIns IRTerm] -> (Bool, [Either IRIns IRTerm]) propagate _ [] = (True, []) - propagate ari@(IAri _ d s1 s2) (Left ins@(IMov md _) : rest) + propagate ari@(_, d, s1, s2) (Left ins@(IMov md _) : rest) | d /= md && md /= s1 && md /= s2 = fmap (Left ins :) $ propagate ari rest | otherwise = (False, Left ins : rest) - propagate ari@(IAri _ _ _ _) (Left ins@(IStore _ _) : rest) = + propagate ari (Left ins@(IStore _ _) : rest) = fmap (Left ins :) $ propagate ari rest - propagate ari@(IAri _ d s1 s2) (Left ins@(ILoad md _) : rest) + propagate ari@(_, d, s1, s2) (Left ins@(ILoad md _) : rest) | d /= md && md /= s1 && md /= s2 = fmap (Left ins :) $ propagate ari rest | otherwise = (False, Left ins : rest) - propagate ari@(IAri at d s1 s2) (Left ins@(IAri mat md ms1 ms2) : rest) + propagate ari@(at, d, s1, s2) (Left ins@(IAri mat md ms1 ms2) : rest) | d /= md && (at, s1, s2) == (mat, ms1, ms2) = fmap (Left (IMov md d) :) $ propagate ari rest | d /= md && md /= s1 && md /= s2 = fmap (Left ins :) $ propagate ari rest - | otherwise = fmap (Left ins :) $ propagate ins rest + | otherwise = fmap (Left ins :) $ propagate (mat, md, ms1, ms2) 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) + -- propagate ari@(_, d, s1, s2) (Left ins@(ICall _ mal) : rest) -- | null (intersect [d] mal) = fmap (Left ins :) $ propagate ari rest -- | otherwise = (False, Left ins : rest) - -- propagate ari@(IAri _ d s1 s2) (Left ins@(ICallr md _ mal) : rest) + -- propagate ari@(_, d, s1, s2) (Left ins@(ICallr md _ mal) : rest) -- | null (intersect [d,s1,s2] (md : mal)) = fmap (Left ins :) $ propagate ari rest -- | otherwise = (False, Left ins : rest) - propagate ari@(IAri _ d s1 s2) (Left ins@(IResize md _) : rest) + propagate ari@(_, d, s1, s2) (Left ins@(IResize md _) : rest) | d /= md && md /= s1 && md /= s2 = fmap (Left ins :) $ propagate ari rest | otherwise = (False, 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) + propagate ari (Left INop : rest) = propagate ari rest + propagate (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] = @@ -335,7 +339,14 @@ arithPush (IRFunc rt name al allbbs sid) = IRFunc rt name al resbbs sid _ -> undefined in (True, Right resterm : rest) | otherwise = (True, Right term : rest) - propagate _ l = (False, l) + propagate _ l@(Left (ICall _ _) : _) = (False, l) + propagate _ l@(Left (ICallr _ _ _) : _) = (False, l) + propagate _ l@(Left IDebugger : _) = (False, l) + propagate _ l@(Right (IJmp _) : _) = (True, l) + propagate _ l@(Right IRet : _) = (False, l) + propagate _ l@(Right (IRetr _) : _) = (False, l) + propagate _ l@(Right IUnreachable : _) = (False, l) + propagate _ (Right ITermNone : _) = undefined flipCmpType :: CmpType -> CmpType flipCmpType CEq = CEq @@ -344,6 +355,10 @@ flipCmpType CGt = CLt flipCmpType CLt = CGt flipCmpType CGeq = CLeq flipCmpType CLeq = CGeq +flipCmpType CUGt = CULt +flipCmpType CULt = CUGt +flipCmpType CUGeq = CULeq +flipCmpType CULeq = CUGeq invertCmpType :: CmpType -> CmpType invertCmpType CEq = CNeq @@ -352,6 +367,10 @@ invertCmpType CGt = CLeq invertCmpType CLt = CGeq invertCmpType CGeq = CLt invertCmpType CLeq = CGt +invertCmpType CUGt = CULeq +invertCmpType CULt = CUGeq +invertCmpType CUGeq = CULt +invertCmpType CULeq = CUGt arithTypeToCmpType :: ArithType -> CmpType arithTypeToCmpType AEq = CEq @@ -376,6 +395,7 @@ removeUnusedInstructions (IRFunc rt name al bbs sid) = IRFunc rt name al (map go goI ins@(ICall _ _) = Just ins goI ins@(ICallr _ _ _) = Just ins goI ins@(IResize d _) = pureInstruction d ins + goI IDebugger = Just IDebugger goI INop = Nothing pureInstruction :: Ref -> IRIns -> Maybe IRIns @@ -436,7 +456,10 @@ reorderBlocks (IRFunc rt name al allbbs sid) = IRFunc rt name al resbbs sid chain' = chain ++ [at] in case intersect (jumpTargets term) (map blockIdOf rest) of [] -> [chain'] - tgs -> concatMap (go rest chain') tgs + tgs -> flip concatMap tgs $ \tg -> + if hasUnreachable (fst $ takeBlock tg bbs) + then [] + else go rest chain' tg buildResult :: [[Id]] -> [BB] -> [BB] buildResult _ [] = [] @@ -453,6 +476,10 @@ reorderBlocks (IRFunc rt name al allbbs sid) = IRFunc rt name al resbbs sid | bid == target = (bb, rest) | otherwise = fmap (bb :) $ takeBlock target rest + hasUnreachable :: BB -> Bool + hasUnreachable (BB _ _ IUnreachable) = True + hasUnreachable _ = False + invertJccs :: FuncOptimisation invertJccs (IRFunc rt name al bbs sid) = IRFunc rt name al bbs' sid where @@ -539,6 +566,7 @@ 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 IDebugger = [] findAllRefsIns INop = [] findAllRefsTerm :: IRTerm -> [Ref] @@ -546,6 +574,7 @@ findAllRefsTerm (IJcc _ a b _ _) = [a, b] findAllRefsTerm (IJmp _) = [] findAllRefsTerm IRet = [] findAllRefsTerm (IRetr a) = [a] +findAllRefsTerm IUnreachable = [] findAllRefsTerm ITermNone = undefined -- findAllRefs' :: [BB] -> [Ref] diff --git a/ProgramParser.hs b/ProgramParser.hs index 38da21f..34b5ce7 100644 --- a/ProgramParser.hs +++ b/ProgramParser.hs @@ -71,7 +71,7 @@ pBlock = do return $ Block body pStatement :: Parser Statement -pStatement = pSIf <|> pSWhile <|> pSReturn <|> pSBreak <|> pSDecl <|> pSAs <|> pSExpr +pStatement = pSIf <|> pSWhile <|> pSReturn <|> pSBreak <|> pSDebugger <|> pSDecl <|> pSAs <|> pSExpr pSDecl :: Parser Statement pSDecl = do @@ -124,6 +124,9 @@ pSBreak = do symbol ";" return $ SBreak (fromMaybe 0 m) +pSDebugger :: Parser Statement +pSDebugger = symbol "debugger" >> symbol ";" >> return SDebugger + pSExpr :: Parser Statement pSExpr = do e <- pExpression @@ -138,6 +141,9 @@ pExpression = E.buildExpressionParser optable litparser [E.Infix (symbol "*" >> return (mkEBin BOMul)) E.AssocLeft, E.Infix (symbol "/" >> return (mkEBin BODiv)) E.AssocLeft, E.Infix (symbol "%" >> return (mkEBin BOMod)) E.AssocLeft], + [E.Infix (symbol "^" >> return (mkEBin BOBitXor)) E.AssocLeft], + [E.Infix (symbol "&" >> return (mkEBin BOBitAnd)) E.AssocLeft], + [E.Infix (symbol "|" >> return (mkEBin BOBitOr)) E.AssocLeft], [E.Infix (symbol "+" >> return (mkEBin BOAdd)) E.AssocLeft, E.Infix (symbol "-" >> return (mkEBin BOSub)) E.AssocLeft], [E.Infix (symbol ">=" >> return (mkEBin BOGeq)) E.AssocNone, @@ -238,7 +244,20 @@ pName = do return $ c0 : cr pInteger :: Parser Integer -pInteger = read <$> many1 (satisfy isDigit) <* pWhiteComment +pInteger = bareint <* pWhiteComment + where + bareint = + (try (string "0x") >> many1 (satisfy isHexDigit) >>= return . read . ("0x" ++)) <|> + (try (string "0b") >> many1 (oneOf "01") >>= return . bin2int) <|> + (many1 (satisfy isDigit) >>= return . read) + + bin2int :: String -> Integer + bin2int s = go (reverse s) + where + go "" = 0 + go ('0':s') = 2 * go s' + go ('1':s') = 2 * go s' + 1 + go (_:_) = undefined pIntegerInt :: Parser Int pIntegerInt = do @@ -255,8 +274,12 @@ symbol s = try $ do void $ string s when (isAlpha (last s)) $ void $ notFollowedBy (satisfy isAlpha) when (isDigit (last s)) $ void $ notFollowedBy (satisfy isDigit) + when (isOperatorChar (last s)) $ void $ notFollowedBy (satisfy isOperatorChar) pWhiteComment +isOperatorChar :: Char -> Bool +isOperatorChar = (`elem` "*/%^&|+-><=!") + pWhiteComment :: Parser () pWhiteComment = void $ pWhite >> endBy pComment pWhite diff --git a/ReplaceRefs.hs b/ReplaceRefs.hs index 821952b..f9490ef 100644 --- a/ReplaceRefs.hs +++ b/ReplaceRefs.hs @@ -16,6 +16,7 @@ replaceRefsIns from to (IAri at a b c) = IAri at (trans from to a) (trans from t 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) +replaceRefsIns _ _ IDebugger = IDebugger replaceRefsIns _ _ INop = INop replaceRefsTerm :: Ref -> Ref -> IRTerm -> IRTerm @@ -23,6 +24,7 @@ replaceRefsTerm from to (IJcc ct a b i1 i2) = IJcc ct (trans from to a) (trans f replaceRefsTerm _ _ (IJmp i) = IJmp i replaceRefsTerm _ _ IRet = IRet replaceRefsTerm from to (IRetr a) = IRetr (trans from to a) +replaceRefsTerm _ _ IUnreachable = IUnreachable replaceRefsTerm _ _ ITermNone = ITermNone replaceRefsBB :: Ref -> Ref -> BB -> BB diff --git a/TypeCheck.hs b/TypeCheck.hs index 13d33c9..66affa4 100644 --- a/TypeCheck.hs +++ b/TypeCheck.hs @@ -33,6 +33,7 @@ emptyDB = [Map.fromList [("putc", DBFunc Nothing [TChar]), ("putint", DBFunc Nothing [TInt]), ("getc", DBFunc (Just TInt) []), + ("exit", DBFunc Nothing [TInt]), ("_builtin_malloc", DBFunc (Just $ TArr TChar Nothing) [TInt])]] withScope :: TypeDB -> (TypeDB -> a) -> a @@ -152,6 +153,7 @@ annotateStatement (State {stDfunc = DFunc mrt _ _ _}) db (SReturn (Just expr)) = " in 'return'" return (db, SReturn (Just expr')) annotateStatement _ db (SExpr expr) = (\expr' -> (db, SExpr expr')) <$> annotateExpr db expr +annotateStatement _ db SDebugger = return (db, SDebugger) annotateExpr :: TypeDB -> Expression -> Error Expression annotateExpr db (EBin bo e1 e2 _) = do diff --git a/TypeRules.hs b/TypeRules.hs index a3e7678..2bafe63 100644 --- a/TypeRules.hs +++ b/TypeRules.hs @@ -22,7 +22,7 @@ isIntegralType TChar = True isIntegralType _ = False isSimpleArithBO :: BinaryOp -> Bool -isSimpleArithBO = flip elem [BOAdd, BOSub, BOMul, BODiv, BOMod] +isSimpleArithBO = flip elem [BOAdd, BOSub, BOMul, BODiv, BOMod, BOBitAnd, BOBitOr, BOBitXor] isBoolBO :: BinaryOp -> Bool isBoolBO = flip elem [BOAnd, BOOr] @@ -48,6 +48,7 @@ data Ins | JMP String | JCC CondCode String | RET + | INT3 deriving (Show, Eq) type Func = (String, [Ins]) @@ -104,6 +105,7 @@ verify (Asm funcs) = mapM_ (\(_, inss) -> mapM_ goI inss) funcs goI (JMP s) = when (null s) $ Left "Empty jump target" goI (JCC _ s) = when (null s) $ Left "Empty jcc target" goI RET = return () + goI INT3 = return () ckReg (XReg _ _) = return () ckReg _ = Left "Argument is not a Reg" @@ -252,6 +254,7 @@ instance Stringifiable Ins where stringify (JMP s) = "jmp " ++ s stringify (JCC cc s) = "j" ++ stringify cc ++ " " ++ s stringify RET = "ret" + stringify INT3 = "int3" instance Stringifiable Asm where stringify (Asm funcs) = intercalate "\n" $ map goF funcs @@ -305,6 +308,7 @@ xrefMapM f (POP (RegMem x)) = POP <$> (RegMem <$> f x) xrefMapM _ i@(JMP _) = return i xrefMapM _ i@(JCC _ _) = return i xrefMapM _ i@RET = return i +xrefMapM _ i@INT3 = return i xrefMap :: (XRef -> XRef) -> Ins -> Ins xrefMap f i = runIdentity $ xrefMapM (return . f) i @@ -22,7 +22,7 @@ func int[] makejumpmap(char[] src, int srclen) { int stkp := 0; int i := 0; while (i < srclen) { - putint(i); putc(' '); putint(stkp); putc(' '); putc(src[i]); putc('\n'); + // putint(i); putc(' '); putint(stkp); putc(' '); putc(src[i]); putc('\n'); if (src[i] == '[') { stack[stkp] = i; stkp = stkp + 1; @@ -35,6 +35,9 @@ func int[] makejumpmap(char[] src, int srclen) { } i = i + 1; } + if (stkp != 0) { + exit(1); + } /*i = 0; while (i < srclen) { putint(jm[i]); @@ -72,17 +75,20 @@ func interpret(char[] src, int srclen) { ip = ip + 1; } + // debugger; + + putc('\n'); memp = 0; while (memp < 10) { - putint(int(mem[memp])); putc(' '); + putint(int(mem[memp]) & 0xff); putc(' '); memp = memp + 1; } putc('\n'); } func int main() { - int bufsize := 4088; - char[] source := new char[4088]; + int bufsize := 12280; + char[] source := new char[12280]; int sourcelen := 0; while (1) { diff --git a/liblang.asm b/liblang.asm index 52a68cc..3ae345d 100644 --- a/liblang.asm +++ b/liblang.asm @@ -4,7 +4,7 @@ SYS_READ equ 0x2000003 ;fd, buf, len SYS_WRITE equ 0x2000004 ;fd, buf, len SYS_MMAP equ 0x20000C5 ;addr, len, prot, flags, fd, offset -global start, putc, putint, getc, _builtin_malloc +global start, putc, putint, getc, exit, _builtin_malloc, _builtin_outofbounds default rel extern main @@ -109,6 +109,12 @@ getc: mov rax, -1 jmp .finish +exit: + mov rdi, [rsp+8] + mov eax, SYS_EXIT + syscall + jmp $ + _builtin_malloc: push rdi push rsi @@ -136,6 +142,18 @@ _builtin_malloc: pop rdi ret +_builtin_outofbounds: + mov edi, 2 + lea rsi, [outofbounds_msg] + mov rdx, outofbounds_msg.len + mov eax, SYS_WRITE + syscall + mov edi, 255 + mov eax, SYS_EXIT + syscall + jmp $ + section .data -db 0 ; for dyld +outofbounds_msg: db "Runtime Error: Out-of-bounds array access detected", 10 +.len: equ $ - outofbounds_msg |