aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--AST.hs6
-rw-r--r--BuildIR.hs49
-rw-r--r--CodeGen.hs12
-rw-r--r--Intermediate.hs15
-rw-r--r--Makefile6
-rw-r--r--Optimiser.hs101
-rw-r--r--ProgramParser.hs27
-rw-r--r--ReplaceRefs.hs2
-rw-r--r--TypeCheck.hs2
-rw-r--r--TypeRules.hs2
-rw-r--r--X64.hs4
-rw-r--r--bf.lang14
-rw-r--r--liblang.asm22
13 files changed, 210 insertions, 52 deletions
diff --git a/AST.hs b/AST.hs
index 5217d46..197edf9 100644
--- a/AST.hs
+++ b/AST.hs
@@ -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
diff --git a/BuildIR.hs b/BuildIR.hs
index a4be797..c64adb1 100644
--- a/BuildIR.hs
+++ b/BuildIR.hs
@@ -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
diff --git a/CodeGen.hs b/CodeGen.hs
index 8d7cb78..9a46af7 100644
--- a/CodeGen.hs
+++ b/CodeGen.hs
@@ -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
diff --git a/Makefile b/Makefile
index ee0c6fb..0d7bf09 100644
--- a/Makefile
+++ b/Makefile
@@ -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]
diff --git a/X64.hs b/X64.hs
index 222d1cd..a577a75 100644
--- a/X64.hs
+++ b/X64.hs
@@ -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
diff --git a/bf.lang b/bf.lang
index e2f6788..6f7426b 100644
--- a/bf.lang
+++ b/bf.lang
@@ -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