feature/comparisons #29

Merged
me merged 8 commits from feature/comparisons into main 2023-10-23 17:31:28 +00:00
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 ## File structure
- `app` - contains the compiler program - `src` - contains the compiler program
- `example` - contains example programs that can be compiled - `example` - contains example programs that can be compiled
## Credits ## 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://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://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) - 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 ### 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: other-modules:
Main.LLVMGen Main.LLVMGen
Main.Parser.Megaparsec Main.Parser.Megaparsec
Main.Type Main.Types
Paths_really_bad_compiler_in_haskell Paths_really_bad_compiler_in_haskell
hs-source-dirs: hs-source-dirs:
src src

View File

@ -22,11 +22,15 @@ run opts = do
let fileName = filePath opts let fileName = filePath opts
contents <- T.readFile fileName contents <- T.readFile fileName
T.putStrLn "- Generating LLVM to './a.out.ll'..." T.putStrLn "- Generating LLVM to './a.out.ll'..."
result <- (llvmGen . parse) contents let parseResult = parse contents
B.writeFile "a.out.ll" result case parseResult of
T.putStrLn "- Compiling to executable './a.out'..." Right r -> do
callCommand "clang a.out.ll" result <- llvmGen r
T.putStrLn "- Done." 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 :: IO ()
main = execParser opts >>= run main = execParser opts >>= run

View File

@ -16,13 +16,15 @@ import Data.String.Conversions
import Data.Text import Data.Text
import LLVM (moduleLLVMAssembly, withModuleFromAST) import LLVM (moduleLLVMAssembly, withModuleFromAST)
import LLVM.AST hiding (function) import LLVM.AST hiding (function)
import LLVM.AST.IntegerPredicate
import LLVM.AST.Type import LLVM.AST.Type
import LLVM.AST.Type qualified as AST
import LLVM.Context import LLVM.Context
import LLVM.IRBuilder.Constant import LLVM.IRBuilder.Constant
import LLVM.IRBuilder.Instruction import LLVM.IRBuilder.Instruction
import LLVM.IRBuilder.Module import LLVM.IRBuilder.Module
import LLVM.IRBuilder.Monad import LLVM.IRBuilder.Monad
import Main.Type as Expr import Main.Types qualified as T
data Env = Env data Env = Env
{ operands :: M.Map Text Operand, { operands :: M.Map Text Operand,
@ -56,8 +58,8 @@ getString str = do
modify $ \env -> env {strings = M.insert str operand (strings env)} modify $ \env -> env {strings = M.insert str operand (strings env)}
return operand return operand
getLLVM :: [Expr] -> Module getLLVM :: [T.Statement] -> Module
getLLVM expr = getLLVM statement =
flip evalState (Env {operands = M.empty, strings = M.empty}) $ flip evalState (Env {operands = M.empty, strings = M.empty}) $
buildModuleT "program" $ mdo buildModuleT "program" $ mdo
-- TODO: better module name -- TODO: better module name
@ -66,7 +68,7 @@ getLLVM expr =
function "main" [] i32 $ \_ -> mdo function "main" [] i32 $ \_ -> mdo
printNumStr <- globalStringPtr "%d\n" (mkName "str") printNumStr <- globalStringPtr "%d\n" (mkName "str")
lift $ registerString "%d\n" $ ConstantOperand printNumStr lift $ registerString "%d\n" $ ConstantOperand printNumStr
_ <- forM_ expr exprToLLVM _ <- forM_ statement statementToLLVM
ret $ int32 0 ret $ int32 0
-- --
@ -74,42 +76,106 @@ getLLVM expr =
-- _ <- call (FunctionType i32 [ptr] True) printf [(ConstantOperand numFormatStr, []), (ourExpression, [])] -- _ <- call (FunctionType i32 [ptr] True) printf [(ConstantOperand numFormatStr, []), (ourExpression, [])]
-- ret $ int32 0 -- ret $ int32 0
exprToLLVM :: statementToLLVM ::
( MonadIRBuilder m, ( MonadIRBuilder m,
MonadModuleBuilder m, MonadModuleBuilder m,
MonadState Env m MonadState Env m
) => ) =>
Expr -> T.Statement ->
m Operand m Operand
exprToLLVM (Lit prim) = pure $ primToLLVM prim statementToLLVM (T.PrintInt e) = mdo
exprToLLVM (Paren e) = exprToLLVM e val <- intExprToLLVM e
exprToLLVM (Print e) = mdo
val <- exprToLLVM e
printf <- getOperand "printf" printf <- getOperand "printf"
formatStr <- getString "%d\n" formatStr <- getString "%d\n"
_ <- call (FunctionType i32 [ptr] True) printf [(formatStr, []), (val, [])] _ <- call (FunctionType i32 [ptr] True) printf [(formatStr, []), (val, [])]
pure val pure val
exprToLLVM (Expr.Add a b) = mdo statementToLLVM (T.PrintBool e) = mdo
lhs <- exprToLLVM a val <- boolExprToLLVM e
rhs <- exprToLLVM b 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 add lhs rhs
exprToLLVM (Expr.Sub a b) = mdo intExprToLLVM (T.IntArith T.Sub a b) = mdo
lhs <- exprToLLVM a lhs <- intExprToLLVM a
rhs <- exprToLLVM b rhs <- intExprToLLVM b
sub lhs rhs sub lhs rhs
exprToLLVM (Expr.Mul a b) = mdo intExprToLLVM (T.IntArith T.Mul a b) = mdo
lhs <- exprToLLVM a lhs <- intExprToLLVM a
rhs <- exprToLLVM b rhs <- intExprToLLVM b
mul lhs rhs mul lhs rhs
exprToLLVM (Expr.Div a b) = mdo intExprToLLVM (T.IntArith T.Div a b) = mdo
lhs <- exprToLLVM a lhs <- intExprToLLVM a
rhs <- exprToLLVM b rhs <- intExprToLLVM b
sdiv lhs rhs sdiv lhs rhs
primToLLVM :: Int -> Operand boolExprToLLVM ::
primToLLVM i = int32 $ fromIntegral i ( 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 llvmGen expr = do
let l = getLLVM expr let l = getLLVM expr
withContext $ \c -> withModuleFromAST c l moduleLLVMAssembly withContext $ \c -> withModuleFromAST c l moduleLLVMAssembly

View File

@ -8,7 +8,7 @@ import Control.Monad.Combinators.Expr
import Data.Functor.Identity qualified import Data.Functor.Identity qualified
import Data.Text import Data.Text
import Data.Void (Void) import Data.Void (Void)
import Main.Type import Main.Types qualified as M
import Text.Megaparsec as MP hiding (parse) import Text.Megaparsec as MP hiding (parse)
import Text.Megaparsec qualified as MP import Text.Megaparsec qualified as MP
import Text.Megaparsec.Char qualified as C import Text.Megaparsec.Char qualified as C
@ -31,48 +31,115 @@ string = C.string
container :: Text -> Text -> Parser a -> Parser a container :: Text -> Text -> Parser a -> Parser a
container b e = between (symbol b) (symbol e) container b e = between (symbol b) (symbol e)
term :: Parser Expr parens :: Parser a -> Parser a
term = parens = container "(" ")"
intExprTerm :: ParsecT Void Text Data.Functor.Identity.Identity M.Int
intExprTerm =
choice choice
[ Lit <$> int, [ M.Int <$> int,
container "(" ")" expr parens intExpr
] ]
table :: [[Operator Parser Expr]] intExprTable :: [[Operator Parser M.Int]]
table = intExprTable =
[ [methodOp "print" Print], [ [ binaryOp "*" (M.IntArith M.Mul),
[ binaryOp "*" Mul, binaryOp "/" (M.IntArith M.Div)
binaryOp "/" Div
], ],
[ binaryOp "+" Add, [ binaryOp "+" (M.IntArith M.Add),
binaryOp "-" Sub 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 :: 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 :: Text -> (a -> a) -> Operator (ParsecT Void Text Data.Functor.Identity.Identity) a
-- prefixOp name f = Prefix (f <$ symbol name) prefixOp name f = Prefix $ f <$ symbol name
methodOp :: Text -> (a -> a) -> Operator (ParsecT Void Text Data.Functor.Identity.Identity) a statement :: Parser M.Statement
methodOp name f = Prefix $ f <$ (string name <* C.space) 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 parseStatements :: Text -> Either (ParseErrorBundle Text Void) [M.Statement]
-- postfixOp name f = Postfix (f <$ symbol name) parseStatements = MP.parse (C.space *> many statement <* eof) ""
expr :: Parser Expr parse :: Text -> Either String [M.Statement]
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 t = parse t =
case parseExpr t of case parseStatements t of
Right r -> r Right r -> Right r
Left e -> Left (errorBundlePretty e)
-- TODO: add error handling -- 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)