Compare commits

..

7 Commits

8 changed files with 258 additions and 94 deletions

View File

@ -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

View File

@ -1 +1,13 @@
print(5*(3-2)+-4-4);
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));

View File

@ -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

View File

@ -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

View File

@ -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

View File

@ -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),
uncurry3 M.IntEq <$> intEqExpr,
M.Bool True <$ string "true" <* C.space,
M.Bool False <$ string "false" <* C.space,
parens boolExpr
]
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

View File

@ -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
-- }

42
src/Main/Types.hs 100644
View File

@ -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)