diff --git a/README.md b/README.md index 3f59fd2..36b09d7 100644 --- a/README.md +++ b/README.md @@ -35,7 +35,7 @@ I recommend using VSCodium, which is preconfigured to have syntax highlighting a ## File structure -- `app` - contains the compiler program +- `src` - contains the compiler program - `example` - contains example programs that can be compiled ## Credits @@ -53,6 +53,9 @@ I recommend using VSCodium, which is preconfigured to have syntax highlighting a - https://gh.sudoer.ch/danieljharvey/mimsa/blob/trunk/llvm-calc/src/Calc/Compile/ToLLVM.hs (source code for above resource) - https://9to5tutorial.com/homebrew-compiler-made-with-haskell-llvm-configuration (for help using llvm-hs-pure) - https://blog.ocharles.org.uk/blog/posts/2012-12-17-24-days-of-hackage-optparse-applicative.html (for help parsing command line arguments with optparse-applicative) +- http://learnyouahaskell.com/making-our-own-types-and-typeclasses (for help defining types) +- https://llvm.org/docs/LangRef.html (LLVM documentation) +- https://hackage.haskell.org/package/llvm-hs-pure-9.0.0/docs/ (llvm-hs documentation) ### Tools diff --git a/example/1.hear b/example/1.hear index 62b1f81..8c60c2a 100644 --- a/example/1.hear +++ b/example/1.hear @@ -1 +1,13 @@ -print(5*(3-2)+-4-4); \ No newline at end of file +printInt(5*(3-2)+-4-4); +printBool(true); +printBool(false); +printBool(5 * 3 >= 5 + 9); +printBool(5*(3-2)+-4-4 < -3); +printBool(5 == 5); +printBool(5 == 6); +printBool(5 != 5); +printBool(true == true); +printBool(true && true); +printBool(true && false); +printBool(!true); +printBool(!(5 == 5)); \ No newline at end of file diff --git a/really-bad-compiler-in-haskell.cabal b/really-bad-compiler-in-haskell.cabal index 0b1bace..18fcdd1 100644 --- a/really-bad-compiler-in-haskell.cabal +++ b/really-bad-compiler-in-haskell.cabal @@ -18,7 +18,7 @@ executable really-bad-compiler-in-haskell other-modules: Main.LLVMGen Main.Parser.Megaparsec - Main.Type + Main.Types Paths_really_bad_compiler_in_haskell hs-source-dirs: src diff --git a/src/Main.hs b/src/Main.hs index dee11e3..3030c5d 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -22,11 +22,15 @@ run opts = do let fileName = filePath opts contents <- T.readFile fileName T.putStrLn "- Generating LLVM to './a.out.ll'..." - result <- (llvmGen . parse) contents - B.writeFile "a.out.ll" result - T.putStrLn "- Compiling to executable './a.out'..." - callCommand "clang a.out.ll" - T.putStrLn "- Done." + let parseResult = parse contents + case parseResult of + Right r -> do + result <- llvmGen r + B.writeFile "a.out.ll" result + T.putStrLn "- Compiling to executable './a.out'..." + callCommand "clang a.out.ll" + T.putStrLn "- Done." + Left l -> putStrLn l main :: IO () main = execParser opts >>= run diff --git a/src/Main/LLVMGen.hs b/src/Main/LLVMGen.hs index 620e168..c4f00e2 100644 --- a/src/Main/LLVMGen.hs +++ b/src/Main/LLVMGen.hs @@ -16,13 +16,15 @@ import Data.String.Conversions import Data.Text import LLVM (moduleLLVMAssembly, withModuleFromAST) import LLVM.AST hiding (function) +import LLVM.AST.IntegerPredicate import LLVM.AST.Type +import LLVM.AST.Type qualified as AST import LLVM.Context import LLVM.IRBuilder.Constant import LLVM.IRBuilder.Instruction import LLVM.IRBuilder.Module import LLVM.IRBuilder.Monad -import Main.Type as Expr +import Main.Types qualified as T data Env = Env { operands :: M.Map Text Operand, @@ -56,8 +58,8 @@ getString str = do modify $ \env -> env {strings = M.insert str operand (strings env)} return operand -getLLVM :: [Expr] -> Module -getLLVM expr = +getLLVM :: [T.Statement] -> Module +getLLVM statement = flip evalState (Env {operands = M.empty, strings = M.empty}) $ buildModuleT "program" $ mdo -- TODO: better module name @@ -66,7 +68,7 @@ getLLVM expr = function "main" [] i32 $ \_ -> mdo printNumStr <- globalStringPtr "%d\n" (mkName "str") lift $ registerString "%d\n" $ ConstantOperand printNumStr - _ <- forM_ expr exprToLLVM + _ <- forM_ statement statementToLLVM ret $ int32 0 -- @@ -74,42 +76,106 @@ getLLVM expr = -- _ <- call (FunctionType i32 [ptr] True) printf [(ConstantOperand numFormatStr, []), (ourExpression, [])] -- ret $ int32 0 -exprToLLVM :: +statementToLLVM :: ( MonadIRBuilder m, MonadModuleBuilder m, MonadState Env m ) => - Expr -> + T.Statement -> m Operand -exprToLLVM (Lit prim) = pure $ primToLLVM prim -exprToLLVM (Paren e) = exprToLLVM e -exprToLLVM (Print e) = mdo - val <- exprToLLVM e +statementToLLVM (T.PrintInt e) = mdo + val <- intExprToLLVM e printf <- getOperand "printf" formatStr <- getString "%d\n" _ <- call (FunctionType i32 [ptr] True) printf [(formatStr, []), (val, [])] pure val -exprToLLVM (Expr.Add a b) = mdo - lhs <- exprToLLVM a - rhs <- exprToLLVM b +statementToLLVM (T.PrintBool e) = mdo + val <- boolExprToLLVM e + val32 <- zext val i32 + printf <- getOperand "printf" + formatStr <- getString "%d\n" + _ <- call (FunctionType i32 [ptr] True) printf [(formatStr, []), (val32, [])] + pure val + +intExprToLLVM :: + ( MonadIRBuilder m, + MonadModuleBuilder m, + MonadState Env m + ) => + T.Int -> + m Operand +intExprToLLVM (T.Int prim) = pure $ int32 $ fromIntegral prim +intExprToLLVM (T.IntArith T.Add a b) = mdo + lhs <- intExprToLLVM a + rhs <- intExprToLLVM b add lhs rhs -exprToLLVM (Expr.Sub a b) = mdo - lhs <- exprToLLVM a - rhs <- exprToLLVM b +intExprToLLVM (T.IntArith T.Sub a b) = mdo + lhs <- intExprToLLVM a + rhs <- intExprToLLVM b sub lhs rhs -exprToLLVM (Expr.Mul a b) = mdo - lhs <- exprToLLVM a - rhs <- exprToLLVM b +intExprToLLVM (T.IntArith T.Mul a b) = mdo + lhs <- intExprToLLVM a + rhs <- intExprToLLVM b mul lhs rhs -exprToLLVM (Expr.Div a b) = mdo - lhs <- exprToLLVM a - rhs <- exprToLLVM b +intExprToLLVM (T.IntArith T.Div a b) = mdo + lhs <- intExprToLLVM a + rhs <- intExprToLLVM b sdiv lhs rhs -primToLLVM :: Int -> Operand -primToLLVM i = int32 $ fromIntegral i +boolExprToLLVM :: + ( MonadIRBuilder m, + MonadModuleBuilder m, + MonadState Env m + ) => + T.Bool -> + m Operand +boolExprToLLVM (T.Bool prim) = + if prim then pure $ bit 1 else pure $ bit 0 +boolExprToLLVM (T.IntOrdCmp T.GT a b) = mdo + lhs <- intExprToLLVM a + rhs <- intExprToLLVM b + icmp SGT lhs rhs +boolExprToLLVM (T.IntOrdCmp T.GTE a b) = mdo + lhs <- intExprToLLVM a + rhs <- intExprToLLVM b + icmp SGE lhs rhs +boolExprToLLVM (T.IntOrdCmp T.LT a b) = mdo + lhs <- intExprToLLVM a + rhs <- intExprToLLVM b + icmp SLT lhs rhs +boolExprToLLVM (T.IntOrdCmp T.LTE a b) = mdo + lhs <- intExprToLLVM a + rhs <- intExprToLLVM b + icmp SLE lhs rhs +boolExprToLLVM (T.IntEq T.EQ a b) = mdo + lhs <- intExprToLLVM a + rhs <- intExprToLLVM b + icmp LLVM.AST.IntegerPredicate.EQ lhs rhs +boolExprToLLVM (T.IntEq T.NE a b) = mdo + lhs <- intExprToLLVM a + rhs <- intExprToLLVM b + icmp LLVM.AST.IntegerPredicate.NE lhs rhs +boolExprToLLVM (T.BoolEq T.EQ a b) = mdo + lhs <- boolExprToLLVM a + rhs <- boolExprToLLVM b + icmp LLVM.AST.IntegerPredicate.EQ lhs rhs +boolExprToLLVM (T.BoolEq T.NE a b) = mdo + lhs <- boolExprToLLVM a + rhs <- boolExprToLLVM b + icmp LLVM.AST.IntegerPredicate.NE lhs rhs +boolExprToLLVM (T.BoolLogic T.AND a b) = mdo + lhs <- boolExprToLLVM a + rhs <- boolExprToLLVM b + LLVM.IRBuilder.Instruction.and lhs rhs +boolExprToLLVM (T.BoolLogic T.OR a b) = mdo + lhs <- boolExprToLLVM a + rhs <- boolExprToLLVM b + LLVM.IRBuilder.Instruction.or lhs rhs +boolExprToLLVM (T.BoolNeg a) = mdo + l <- boolExprToLLVM a + LLVM.IRBuilder.Instruction.xor l $ bit 1 -llvmGen :: [Expr] -> IO ByteString +llvmGen :: [T.Statement] -> IO ByteString llvmGen expr = do let l = getLLVM expr withContext $ \c -> withModuleFromAST c l moduleLLVMAssembly \ No newline at end of file diff --git a/src/Main/Parser/Megaparsec.hs b/src/Main/Parser/Megaparsec.hs index aa1ea72..17c7117 100644 --- a/src/Main/Parser/Megaparsec.hs +++ b/src/Main/Parser/Megaparsec.hs @@ -8,7 +8,7 @@ import Control.Monad.Combinators.Expr import Data.Functor.Identity qualified import Data.Text import Data.Void (Void) -import Main.Type +import Main.Types qualified as M import Text.Megaparsec as MP hiding (parse) import Text.Megaparsec qualified as MP import Text.Megaparsec.Char qualified as C @@ -31,48 +31,115 @@ string = C.string container :: Text -> Text -> Parser a -> Parser a container b e = between (symbol b) (symbol e) -term :: Parser Expr -term = +parens :: Parser a -> Parser a +parens = container "(" ")" + +intExprTerm :: ParsecT Void Text Data.Functor.Identity.Identity M.Int +intExprTerm = choice - [ Lit <$> int, - container "(" ")" expr + [ M.Int <$> int, + parens intExpr ] -table :: [[Operator Parser Expr]] -table = - [ [methodOp "print" Print], - [ binaryOp "*" Mul, - binaryOp "/" Div +intExprTable :: [[Operator Parser M.Int]] +intExprTable = + [ [ binaryOp "*" (M.IntArith M.Mul), + binaryOp "/" (M.IntArith M.Div) ], - [ binaryOp "+" Add, - binaryOp "-" Sub + [ binaryOp "+" (M.IntArith M.Add), + binaryOp "-" (M.IntArith M.Sub) ] ] +intExpr :: Parser M.Int +intExpr = makeExprParser intExprTerm intExprTable + +intOrdCmpExpr :: ParsecT Void Text Data.Functor.Identity.Identity (M.OrdCmpOp, M.Int, M.Int) +intOrdCmpExpr = do + b <- intExpr + a <- + choice + [ M.GTE <$ string ">=" <* C.space, + M.LTE <$ string "<=" <* C.space, + M.GT <$ string ">" <* C.space, + M.LT <$ string "<" <* C.space + ] + c <- intExpr + return (a, b, c) + +intEqExpr :: ParsecT Void Text Data.Functor.Identity.Identity (M.EqOp, M.Int, M.Int) +intEqExpr = do + b <- intExpr + a <- + choice + [ M.EQ <$ string "==" <* C.space, + M.NE <$ string "!=" <* C.space + ] + c <- intExpr + return (a, b, c) + +boolExprTable :: [[Operator Parser M.Bool]] +boolExprTable = + [ [ binaryOp "==" (M.BoolEq M.EQ), + binaryOp "!=" (M.BoolEq M.NE) + ], + [prefixOp "!" M.BoolNeg], + [binaryOp "&&" (M.BoolLogic M.AND)], + [binaryOp "||" (M.BoolLogic M.OR)] + ] + +-- boolEqExpr :: ParsecT Void Text Data.Functor.Identity.Identity (M.EqOp, M.Bool, M.Bool) +-- boolEqExpr = do +-- b <- +-- choice +-- [ + +-- ] +-- a <- +-- choice +-- [ M.EQ <$ string "==" <* C.space, +-- M.NE <$ string "!=" <* C.space +-- ] +-- c <- intExpr +-- return (a, b, c) + +uncurry3 :: (a -> b -> c -> d) -> (a, b, c) -> d +uncurry3 f (x, y, z) = f x y z + +boolExprTerm :: ParsecT Void Text Data.Functor.Identity.Identity M.Bool +boolExprTerm = + choice + [ try (uncurry3 M.IntOrdCmp <$> intOrdCmpExpr), + parens boolExpr, + uncurry3 M.IntEq <$> intEqExpr, + M.Bool True <$ string "true" <* C.space, + M.Bool False <$ string "false" <* C.space + ] + +boolExpr :: ParsecT Void Text Data.Functor.Identity.Identity M.Bool +boolExpr = makeExprParser boolExprTerm boolExprTable + binaryOp :: Text -> (a -> a -> a) -> Operator (ParsecT Void Text Data.Functor.Identity.Identity) a -binaryOp name f = InfixL $ f <$ symbol name +binaryOp name f = InfixL $ f <$ string name <* C.space --- prefixOp :: Text -> (a -> a) -> Operator (ParsecT Void Text Data.Functor.Identity.Identity) a --- prefixOp name f = Prefix (f <$ symbol name) +prefixOp :: Text -> (a -> a) -> Operator (ParsecT Void Text Data.Functor.Identity.Identity) a +prefixOp name f = Prefix $ f <$ symbol name -methodOp :: Text -> (a -> a) -> Operator (ParsecT Void Text Data.Functor.Identity.Identity) a -methodOp name f = Prefix $ f <$ (string name <* C.space) +statement :: Parser M.Statement +statement = + choice + [ string "printInt" *> (M.PrintInt <$> parens intExpr), + string "printBool" *> (M.PrintBool <$> parens boolExpr) + ] + <* symbol ";" --- postfixOp :: Text -> (a -> a) -> Operator (ParsecT Void Text Data.Functor.Identity.Identity) a --- postfixOp name f = Postfix (f <$ symbol name) +parseStatements :: Text -> Either (ParseErrorBundle Text Void) [M.Statement] +parseStatements = MP.parse (C.space *> many statement <* eof) "" -expr :: Parser Expr -expr = makeExprParser term table - -statement :: Parser Expr -statement = expr <* symbol ";" - -parseExpr :: Text -> Either (ParseErrorBundle Text Void) [Expr] -parseExpr = MP.parse (C.space *> many statement <* eof) "" - -parse :: Text -> [Expr] +parse :: Text -> Either String [M.Statement] parse t = - case parseExpr t of - Right r -> r + case parseStatements t of + Right r -> Right r + Left e -> Left (errorBundlePretty e) -- TODO: add error handling \ No newline at end of file diff --git a/src/Main/Type.hs b/src/Main/Type.hs deleted file mode 100644 index 23178b8..0000000 --- a/src/Main/Type.hs +++ /dev/null @@ -1,30 +0,0 @@ -module Main.Type - ( Expr (..), - -- AST (..) - ) -where - -import Data.Graph (Tree (Node)) - -data Expr - = Lit Int - | Paren Expr - | Add Expr Expr - | Sub Expr Expr - | Mul Expr Expr - | Div Expr Expr - | Print Expr - deriving - ( Show - ) - --- data AST = AST Node - --- data Node --- = Reg --- { cur :: Expr, --- next :: Node --- } --- | End --- { cur :: Expr --- } \ No newline at end of file diff --git a/src/Main/Types.hs b/src/Main/Types.hs new file mode 100644 index 0000000..3061817 --- /dev/null +++ b/src/Main/Types.hs @@ -0,0 +1,42 @@ +module Main.Types + ( ArithOp (..), + EqOp (..), + OrdCmpOp (..), + LogicOp (..), + -- BinExpr (..), + Int (..), + Bool (..), + Statement (..), + ) +where + +import qualified Prelude as P + +data ArithOp = Add | Sub | Mul | Div deriving (P.Show) + +data EqOp = EQ | NE deriving (P.Show) + +data OrdCmpOp = GT | GTE | LT | LTE deriving (P.Show) + +data LogicOp = AND | OR deriving (P.Show) + +-- newtype BinExpr op i o = BinExpr (op -> i -> i -> o) + +data Int + = Int P.Int + | IntArith ArithOp Int Int -- (BinExpr ArithOp Int Int) + deriving (P.Show) + +data Bool + = Bool P.Bool + | BoolNeg Bool + | IntEq EqOp Int Int -- (BinExpr EqOp Int Bool) + | IntOrdCmp OrdCmpOp Int Int -- (BinExpr OrdCmpOp Int Bool) + | BoolEq EqOp Bool Bool -- (BinExpr EqOp Bool Bool) + | BoolLogic LogicOp Bool Bool + deriving (P.Show) + +data Statement + = PrintInt Int + | PrintBool Bool + deriving (P.Show) \ No newline at end of file