Compare commits
23 Commits
Author | SHA1 | Date |
---|---|---|
Ethan Reece | 6953e77467 | |
Ethan Reece | 1fbacda21b | |
Ethan Reece | b1d2f65992 | |
Ethan Reece | 20c20b58b7 | |
Ethan Reece | f436c6bc71 | |
Ethan Reece | a75b0df9bc | |
Ethan Reece | 6e2031f715 | |
Ethan Reece | d64ad9aeda | |
Ethan Reece | a7547dd670 | |
Ethan Reece | 2f790d6e55 | |
Ethan Reece | e145e91074 | |
Ethan Reece | bdbe823bc3 | |
Ethan Reece | b52fe34667 | |
Ethan Reece | f7e64faed5 | |
Ethan Reece | 5325a845f2 | |
Ethan Reece | 7e9d8b434a | |
Ethan Reece | 7f9e3c3509 | |
Ethan Reece | e162d55439 | |
Ethan Reece | d40467bc00 | |
Ethan Reece | d14c5ace00 | |
Ethan Reece | 01ff098530 | |
Ethan Reece | e7083c1c40 | |
Ethan Reece | 7f588ec561 |
26
README.md
26
README.md
|
@ -1,6 +1,8 @@
|
||||||
# Really Bad Compiler in Haskell
|
# HEAR Compiler in Haskell
|
||||||
|
|
||||||
A compiler written in Haskell which can currently perform basic arithmetic. Currently using the megaparsec and llvm-hs-\* libraries, but I may reimplement certain libraries myself. Built for the Introduction to Compiler Design class at The University of Texas at Dallas.
|
A compiler for HEAR, a language for when you cannot C.
|
||||||
|
|
||||||
|
Written in Haskell, and currently using the megaparsec and llvm-hs-\* libraries, but I plan to eventually rewrite the lexar/parser from scratch. Built for the Introduction to Compiler Design class at The University of Texas at Dallas.
|
||||||
|
|
||||||
Main repo: https://git.sudoer.ch/me/really-bad-compiler-in-haskell
|
Main repo: https://git.sudoer.ch/me/really-bad-compiler-in-haskell
|
||||||
|
|
||||||
|
@ -8,13 +10,19 @@ Main repo: https://git.sudoer.ch/me/really-bad-compiler-in-haskell
|
||||||
|
|
||||||
- Install `ghcup` (for managing Haskell tools) and `nix` (for managing external dependencies).
|
- Install `ghcup` (for managing Haskell tools) and `nix` (for managing external dependencies).
|
||||||
- Clone the repo.
|
- Clone the repo.
|
||||||
- Use `ghcup` to install `stack 2.9.3`, `HLS 2.2.0.0`, `GHC 9.2.8`, and `cabal 3.6.2.0`.
|
- Use `ghcup` to install `stack 2.11.1`, `HLS 2.3.0.0`, and `cabal 3.8.1.0`.
|
||||||
|
|
||||||
## Run Instructions
|
## Run Instructions
|
||||||
|
|
||||||
- Use `stack run <file>` to run the program (for example, `stack run example/1`).
|
- Use `stack run <file>` to run the program (for example, `stack run example/1.hear`).
|
||||||
- The LLVM will be generated as `a.out.ll`, and the executable will be generated as `a.out`.
|
- The LLVM will be generated as `a.out.ll`, and the executable will be generated as `a.out`.
|
||||||
|
|
||||||
|
## Currently Supported functionality
|
||||||
|
|
||||||
|
- Arithmetic
|
||||||
|
- Parenthesis
|
||||||
|
- print() statement
|
||||||
|
|
||||||
## To edit
|
## To edit
|
||||||
|
|
||||||
I recommend using VSCodium, which is preconfigured to have syntax highlighting and (currently broken) debugging features and will automatically suggest the Haskell extensions to install.
|
I recommend using VSCodium, which is preconfigured to have syntax highlighting and (currently broken) debugging features and will automatically suggest the Haskell extensions to install.
|
||||||
|
@ -27,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
|
||||||
|
@ -44,12 +52,16 @@ I recommend using VSCodium, which is preconfigured to have syntax highlighting a
|
||||||
- https://danieljharvey.github.io/posts/2023-02-08-llvm-compiler-part-1.html (for help using llvm-hs-pure)
|
- https://danieljharvey.github.io/posts/2023-02-08-llvm-compiler-part-1.html (for help using llvm-hs-pure)
|
||||||
- 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)
|
||||||
|
- 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
|
||||||
|
|
||||||
- Language: Haskell
|
- Language: Haskell
|
||||||
- Haskell tools: GHCup, Stack, Cabal, GHC 9.2
|
- Haskell/management tools: GHCup, Stack, Cabal, GHC 9.2, Nix
|
||||||
- Libraries: megaparsec, parser-combinators, text, process, llvm-hs 15, llvm-hs-pure 15,
|
- Libraries: See `package.yaml`
|
||||||
- Dependencies: llvm 15, clang 15
|
- Dependencies: llvm 15, clang 15
|
||||||
- IDE: VSCodium
|
- IDE: VSCodium
|
||||||
- Git platform: Forgejo
|
- Git platform: Forgejo
|
||||||
|
|
|
@ -0,0 +1,13 @@
|
||||||
|
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));
|
|
@ -0,0 +1,2 @@
|
||||||
|
print(6+8/3);
|
||||||
|
print(5000);
|
|
@ -1,67 +0,0 @@
|
||||||
{-# LANGUAGE ImportQualifiedPost #-}
|
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
|
||||||
{-# LANGUAGE RecursiveDo #-}
|
|
||||||
|
|
||||||
-- see https://gh.sudoer.ch/danieljharvey/mimsa/blob/trunk/llvm-calc/src/Calc/Compile/ToLLVM.hs
|
|
||||||
|
|
||||||
module Compiler.LLVMGen (llvmGen) where
|
|
||||||
|
|
||||||
-- import LLVM.Pretty
|
|
||||||
|
|
||||||
import Data.ByteString (ByteString)
|
|
||||||
import Debug.Trace
|
|
||||||
import LLVM (moduleLLVMAssembly, withModuleFromAST, writeLLVMAssemblyToFile)
|
|
||||||
import LLVM.AST hiding (function)
|
|
||||||
import LLVM.AST.Type
|
|
||||||
import LLVM.Context
|
|
||||||
import LLVM.IRBuilder.Constant
|
|
||||||
import LLVM.IRBuilder.Instruction
|
|
||||||
import LLVM.IRBuilder.Module
|
|
||||||
import LLVM.IRBuilder.Monad
|
|
||||||
import Types.Expr as Expr
|
|
||||||
|
|
||||||
getLLVM :: Expr -> Module
|
|
||||||
getLLVM expr =
|
|
||||||
buildModule "program" $ mdo
|
|
||||||
-- TODO: better module name
|
|
||||||
printf <- externVarArgs "printf" [ptr] i32
|
|
||||||
function "main" [] i32 $ \_ -> mdo
|
|
||||||
numFormatStr <- globalStringPtr "%d\n" (mkName "str")
|
|
||||||
ourExpression <- exprToLLVM expr
|
|
||||||
_ <- call (FunctionType i32 [ptr] True) printf [(ConstantOperand numFormatStr, []), (ourExpression, [])]
|
|
||||||
ret (int32 0)
|
|
||||||
|
|
||||||
exprToLLVM ::
|
|
||||||
( MonadIRBuilder m,
|
|
||||||
MonadModuleBuilder m
|
|
||||||
) =>
|
|
||||||
Expr ->
|
|
||||||
m Operand
|
|
||||||
exprToLLVM (Lit prim) = pure $ primToLLVM prim
|
|
||||||
exprToLLVM (Expr.Add a b) = mdo
|
|
||||||
lhs <- exprToLLVM a
|
|
||||||
rhs <- exprToLLVM b
|
|
||||||
add lhs rhs
|
|
||||||
exprToLLVM (Expr.Sub a b) = mdo
|
|
||||||
lhs <- exprToLLVM a
|
|
||||||
rhs <- exprToLLVM b
|
|
||||||
sub lhs rhs
|
|
||||||
exprToLLVM (Expr.Mul a b) = mdo
|
|
||||||
lhs <- exprToLLVM a
|
|
||||||
rhs <- exprToLLVM b
|
|
||||||
mul lhs rhs
|
|
||||||
exprToLLVM (Expr.Div a b) = mdo
|
|
||||||
lhs <- exprToLLVM a
|
|
||||||
rhs <- exprToLLVM b
|
|
||||||
sdiv lhs rhs
|
|
||||||
|
|
||||||
primToLLVM :: Int -> Operand
|
|
||||||
primToLLVM i = int32 (fromIntegral i)
|
|
||||||
|
|
||||||
llvmGen :: Expr -> IO ByteString
|
|
||||||
llvmGen expr = do
|
|
||||||
let l = getLLVM expr
|
|
||||||
withContext
|
|
||||||
( \c ->
|
|
||||||
withModuleFromAST c l moduleLLVMAssembly
|
|
||||||
)
|
|
28
main/Main.hs
28
main/Main.hs
|
@ -1,28 +0,0 @@
|
||||||
{-# LANGUAGE ImportQualifiedPost #-}
|
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
|
||||||
|
|
||||||
module Main (main) where
|
|
||||||
|
|
||||||
-- import Compiler.ExeGen
|
|
||||||
import Compiler.LLVMGen
|
|
||||||
import Data.ByteString.Char8 qualified as B
|
|
||||||
import Data.Text.Lazy.IO qualified as T
|
|
||||||
import Parser.Expr
|
|
||||||
import System.Environment
|
|
||||||
import System.Process
|
|
||||||
import Types.Expr
|
|
||||||
|
|
||||||
getRight :: ParseResult -> Expr
|
|
||||||
getRight (Right r) = r
|
|
||||||
|
|
||||||
main :: IO ()
|
|
||||||
main = do
|
|
||||||
fileName <- fmap head getArgs
|
|
||||||
contents <- readFile fileName
|
|
||||||
T.putStrLn "- Parsing file..."
|
|
||||||
let parsed = getRight (parseExpr contents)
|
|
||||||
T.putStrLn "- Generating LLVM to './a.out.ll'..."
|
|
||||||
llvmGen parsed >>= B.writeFile "a.out.ll"
|
|
||||||
T.putStrLn "- Compiling to executable './a.out'..."
|
|
||||||
callCommand "clang a.out.ll"
|
|
||||||
T.putStrLn "- Done."
|
|
|
@ -1,49 +0,0 @@
|
||||||
-- see https://markkarpov.com/tutorial/megaparsec.html
|
|
||||||
{-# LANGUAGE ImportQualifiedPost #-}
|
|
||||||
|
|
||||||
module Parser.Expr (parseExpr, ParseResult) where
|
|
||||||
|
|
||||||
import Control.Monad.Combinators.Expr
|
|
||||||
import Data.Functor.Identity qualified
|
|
||||||
import Data.Void (Void)
|
|
||||||
import Text.Megaparsec as MP
|
|
||||||
import Text.Megaparsec.Char as C
|
|
||||||
import Text.Megaparsec.Char.Lexer as L
|
|
||||||
import Types.Expr
|
|
||||||
|
|
||||||
type Parser = Parsec Void String
|
|
||||||
|
|
||||||
lexemeParser :: Parser a -> Parser a
|
|
||||||
lexemeParser = L.lexeme C.space
|
|
||||||
|
|
||||||
symbolParser :: String -> Parser String
|
|
||||||
symbolParser = L.symbol C.space
|
|
||||||
|
|
||||||
intParser :: Parser Int
|
|
||||||
intParser = lexemeParser L.decimal
|
|
||||||
|
|
||||||
term :: Parser Expr
|
|
||||||
term = Lit <$> intParser
|
|
||||||
|
|
||||||
table :: [[Operator Parser Expr]]
|
|
||||||
table =
|
|
||||||
[ [ binaryOp "*" Mul,
|
|
||||||
binaryOp "/" Div
|
|
||||||
],
|
|
||||||
[ binaryOp "+" Add,
|
|
||||||
binaryOp "-" Sub
|
|
||||||
]
|
|
||||||
]
|
|
||||||
|
|
||||||
binaryOp :: String -> (a -> a -> a) -> Operator (ParsecT Void String Data.Functor.Identity.Identity) a
|
|
||||||
binaryOp name f = InfixL (f <$ symbolParser name)
|
|
||||||
|
|
||||||
expr :: Parser Expr
|
|
||||||
expr = makeExprParser term table
|
|
||||||
|
|
||||||
type ParseResult = Either (ParseErrorBundle String Void) Expr
|
|
||||||
|
|
||||||
parseExpr :: String -> ParseResult
|
|
||||||
parseExpr = MP.parse (C.space *> expr <* eof) ""
|
|
||||||
|
|
||||||
-- parseE = parseExpr
|
|
|
@ -1,11 +0,0 @@
|
||||||
module Types.Expr (Expr (..)) where
|
|
||||||
|
|
||||||
data Expr
|
|
||||||
= Lit Int
|
|
||||||
| Add Expr Expr
|
|
||||||
| Sub Expr Expr
|
|
||||||
| Mul Expr Expr
|
|
||||||
| Div Expr Expr
|
|
||||||
deriving
|
|
||||||
( Show
|
|
||||||
)
|
|
|
@ -7,9 +7,14 @@ dependencies:
|
||||||
- parser-combinators
|
- parser-combinators
|
||||||
- text
|
- text
|
||||||
- process
|
- process
|
||||||
|
- mtl
|
||||||
|
- containers
|
||||||
- llvm-hs >= 15 && < 16
|
- llvm-hs >= 15 && < 16
|
||||||
- llvm-hs-pure >= 15 && < 16
|
- llvm-hs-pure >= 15 && < 16
|
||||||
- bytestring
|
- bytestring
|
||||||
|
- string-conversions
|
||||||
|
- transformers
|
||||||
|
- optparse-applicative >= 0.17 && < 1
|
||||||
tested-with: GHC == 9.2.8
|
tested-with: GHC == 9.2.8
|
||||||
category: Compilers/Interpreters
|
category: Compilers/Interpreters
|
||||||
|
|
||||||
|
@ -19,7 +24,7 @@ ghc-options: -threaded -Wall -j8 +RTS -A64M -RTS -fllvm
|
||||||
# source-dirs: src
|
# source-dirs: src
|
||||||
|
|
||||||
executable:
|
executable:
|
||||||
source-dirs: main
|
source-dirs: src
|
||||||
main: Main.hs
|
main: Main.hs
|
||||||
# tests:
|
# tests:
|
||||||
# testall:
|
# testall:
|
||||||
|
|
|
@ -1,6 +1,6 @@
|
||||||
cabal-version: 1.12
|
cabal-version: 1.12
|
||||||
|
|
||||||
-- This file has been generated from package.yaml by hpack version 0.35.1.
|
-- This file has been generated from package.yaml by hpack version 0.35.2.
|
||||||
--
|
--
|
||||||
-- see: https://github.com/sol/hpack
|
-- see: https://github.com/sol/hpack
|
||||||
|
|
||||||
|
@ -16,22 +16,27 @@ tested-with:
|
||||||
executable really-bad-compiler-in-haskell
|
executable really-bad-compiler-in-haskell
|
||||||
main-is: Main.hs
|
main-is: Main.hs
|
||||||
other-modules:
|
other-modules:
|
||||||
Compiler.LLVMGen
|
Main.LLVMGen
|
||||||
Parser.Expr
|
Main.Parser.Megaparsec
|
||||||
Types.Expr
|
Main.Types
|
||||||
Paths_really_bad_compiler_in_haskell
|
Paths_really_bad_compiler_in_haskell
|
||||||
hs-source-dirs:
|
hs-source-dirs:
|
||||||
main
|
src
|
||||||
default-extensions:
|
default-extensions:
|
||||||
OverloadedStrings, LambdaCase
|
OverloadedStrings, LambdaCase
|
||||||
ghc-options: -threaded -Wall -j8 +RTS -A64M -RTS -fllvm
|
ghc-options: -threaded -Wall -j8 +RTS -A64M -RTS -fllvm
|
||||||
build-depends:
|
build-depends:
|
||||||
base >=4.14.3 && <5
|
base >=4.14.3 && <5
|
||||||
, bytestring
|
, bytestring
|
||||||
|
, containers
|
||||||
, llvm-hs ==15.*
|
, llvm-hs ==15.*
|
||||||
, llvm-hs-pure ==15.*
|
, llvm-hs-pure ==15.*
|
||||||
, megaparsec >=9.0.1 && <10
|
, megaparsec >=9.0.1 && <10
|
||||||
|
, mtl
|
||||||
|
, optparse-applicative >=0.17 && <1
|
||||||
, parser-combinators
|
, parser-combinators
|
||||||
, process
|
, process
|
||||||
|
, string-conversions
|
||||||
, text
|
, text
|
||||||
|
, transformers
|
||||||
default-language: Haskell2010
|
default-language: Haskell2010
|
||||||
|
|
|
@ -0,0 +1,51 @@
|
||||||
|
{-# LANGUAGE ImportQualifiedPost #-}
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
|
module Main (main) where
|
||||||
|
|
||||||
|
import Data.ByteString.Char8 qualified as B
|
||||||
|
import Data.Text.IO qualified as T
|
||||||
|
import Main.LLVMGen
|
||||||
|
import Main.Parser.Megaparsec
|
||||||
|
import Options.Applicative
|
||||||
|
import System.Environment
|
||||||
|
import System.Process (callCommand)
|
||||||
|
|
||||||
|
data Opt = Opt
|
||||||
|
{ filePath :: String,
|
||||||
|
showLLVM :: Bool,
|
||||||
|
showDebug :: Bool
|
||||||
|
}
|
||||||
|
|
||||||
|
run :: Opt -> IO ()
|
||||||
|
run opts = do
|
||||||
|
let fileName = filePath opts
|
||||||
|
contents <- T.readFile fileName
|
||||||
|
T.putStrLn "- Generating LLVM to './a.out.ll'..."
|
||||||
|
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
|
||||||
|
where
|
||||||
|
parser =
|
||||||
|
Opt
|
||||||
|
<$> argument str (metavar "FILE_PATH")
|
||||||
|
<*> switch
|
||||||
|
( short 'l'
|
||||||
|
<> long "showLLVM"
|
||||||
|
<> help "Create <file>.ll with LLVM used to compile the binary"
|
||||||
|
)
|
||||||
|
<*> switch
|
||||||
|
( short 'd'
|
||||||
|
<> long "showDebug"
|
||||||
|
<> help "Show debug output"
|
||||||
|
)
|
||||||
|
opts = info parser mempty
|
|
@ -0,0 +1,181 @@
|
||||||
|
{-# LANGUAGE FlexibleContexts #-}
|
||||||
|
{-# LANGUAGE ImportQualifiedPost #-}
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
{-# LANGUAGE RecursiveDo #-}
|
||||||
|
|
||||||
|
-- see https://gh.sudoer.ch/danieljharvey/mimsa/blob/trunk/llvm-calc/src/Calc/Compile/ToLLVM.hs
|
||||||
|
-- see https://blog.josephmorag.com/posts/mcc3/
|
||||||
|
|
||||||
|
module Main.LLVMGen (llvmGen) where
|
||||||
|
|
||||||
|
import Control.Monad.State
|
||||||
|
import Control.Monad.Trans.Class (lift)
|
||||||
|
import Data.ByteString (ByteString)
|
||||||
|
import Data.Map qualified as M
|
||||||
|
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.Types qualified as T
|
||||||
|
|
||||||
|
data Env = Env
|
||||||
|
{ operands :: M.Map Text Operand,
|
||||||
|
strings :: M.Map Text Operand
|
||||||
|
}
|
||||||
|
deriving (Eq, Show)
|
||||||
|
|
||||||
|
registerOperand :: (MonadState Env m) => Text -> Operand -> m ()
|
||||||
|
registerOperand name op =
|
||||||
|
modify $ \env -> env {operands = M.insert name op (operands env)}
|
||||||
|
|
||||||
|
registerString :: (MonadState Env m) => Text -> Operand -> m ()
|
||||||
|
registerString name op =
|
||||||
|
modify $ \env -> env {strings = M.insert name op (operands env)}
|
||||||
|
|
||||||
|
getOperand :: (MonadState Env m, MonadModuleBuilder m, MonadIRBuilder m) => Text -> m Operand
|
||||||
|
getOperand name = do
|
||||||
|
env <- get
|
||||||
|
case M.lookup name (operands env) of
|
||||||
|
Just op -> return op
|
||||||
|
Nothing -> error $ "Unknown operand: " ++ show name
|
||||||
|
|
||||||
|
getString :: (MonadState Env m, MonadModuleBuilder m, MonadIRBuilder m) => Text -> m Operand
|
||||||
|
getString str = do
|
||||||
|
env <- get
|
||||||
|
case M.lookup str (strings env) of
|
||||||
|
Just s -> return s
|
||||||
|
Nothing -> do
|
||||||
|
s <- globalStringPtr (unpack str) (mkName "str")
|
||||||
|
let operand = ConstantOperand s
|
||||||
|
modify $ \env -> env {strings = M.insert str operand (strings env)}
|
||||||
|
return operand
|
||||||
|
|
||||||
|
getLLVM :: [T.Statement] -> Module
|
||||||
|
getLLVM statement =
|
||||||
|
flip evalState (Env {operands = M.empty, strings = M.empty}) $
|
||||||
|
buildModuleT "program" $ mdo
|
||||||
|
-- TODO: better module name
|
||||||
|
printf <- externVarArgs "printf" [ptr] i32
|
||||||
|
lift $ registerOperand "printf" printf
|
||||||
|
function "main" [] i32 $ \_ -> mdo
|
||||||
|
printNumStr <- globalStringPtr "%d\n" (mkName "str")
|
||||||
|
lift $ registerString "%d\n" $ ConstantOperand printNumStr
|
||||||
|
_ <- forM_ statement statementToLLVM
|
||||||
|
ret $ int32 0
|
||||||
|
|
||||||
|
--
|
||||||
|
-- ourExpression <- exprToLLVM expr
|
||||||
|
-- _ <- call (FunctionType i32 [ptr] True) printf [(ConstantOperand numFormatStr, []), (ourExpression, [])]
|
||||||
|
-- ret $ int32 0
|
||||||
|
|
||||||
|
statementToLLVM ::
|
||||||
|
( MonadIRBuilder m,
|
||||||
|
MonadModuleBuilder m,
|
||||||
|
MonadState Env m
|
||||||
|
) =>
|
||||||
|
T.Statement ->
|
||||||
|
m Operand
|
||||||
|
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
|
||||||
|
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
|
||||||
|
intExprToLLVM (T.IntArith T.Sub a b) = mdo
|
||||||
|
lhs <- intExprToLLVM a
|
||||||
|
rhs <- intExprToLLVM b
|
||||||
|
sub lhs rhs
|
||||||
|
intExprToLLVM (T.IntArith T.Mul a b) = mdo
|
||||||
|
lhs <- intExprToLLVM a
|
||||||
|
rhs <- intExprToLLVM b
|
||||||
|
mul lhs rhs
|
||||||
|
intExprToLLVM (T.IntArith T.Div a b) = mdo
|
||||||
|
lhs <- intExprToLLVM a
|
||||||
|
rhs <- intExprToLLVM b
|
||||||
|
sdiv lhs rhs
|
||||||
|
|
||||||
|
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 :: [T.Statement] -> IO ByteString
|
||||||
|
llvmGen expr = do
|
||||||
|
let l = getLLVM expr
|
||||||
|
withContext $ \c -> withModuleFromAST c l moduleLLVMAssembly
|
|
@ -0,0 +1,145 @@
|
||||||
|
-- see https://markkarpov.com/tutorial/megaparsec.html
|
||||||
|
{-# LANGUAGE ImportQualifiedPost #-}
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
|
module Main.Parser.Megaparsec (parse) where
|
||||||
|
|
||||||
|
import Control.Monad.Combinators.Expr
|
||||||
|
import Data.Functor.Identity qualified
|
||||||
|
import Data.Text
|
||||||
|
import Data.Void (Void)
|
||||||
|
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
|
||||||
|
import Text.Megaparsec.Char.Lexer qualified as L
|
||||||
|
|
||||||
|
type Parser = Parsec Void Text
|
||||||
|
|
||||||
|
lexeme :: Parser a -> Parser a
|
||||||
|
lexeme = L.lexeme C.space
|
||||||
|
|
||||||
|
symbol :: Text -> Parser Text
|
||||||
|
symbol = L.symbol C.space
|
||||||
|
|
||||||
|
int :: Parser Int
|
||||||
|
int = lexeme $ L.signed (return ()) L.decimal
|
||||||
|
|
||||||
|
string :: Text -> Parser Text
|
||||||
|
string = C.string
|
||||||
|
|
||||||
|
container :: Text -> Text -> Parser a -> Parser a
|
||||||
|
container b e = between (symbol b) (symbol e)
|
||||||
|
|
||||||
|
parens :: Parser a -> Parser a
|
||||||
|
parens = container "(" ")"
|
||||||
|
|
||||||
|
intExprTerm :: ParsecT Void Text Data.Functor.Identity.Identity M.Int
|
||||||
|
intExprTerm =
|
||||||
|
choice
|
||||||
|
[ M.Int <$> int,
|
||||||
|
parens intExpr
|
||||||
|
]
|
||||||
|
|
||||||
|
intExprTable :: [[Operator Parser M.Int]]
|
||||||
|
intExprTable =
|
||||||
|
[ [ binaryOp "*" (M.IntArith M.Mul),
|
||||||
|
binaryOp "/" (M.IntArith M.Div)
|
||||||
|
],
|
||||||
|
[ 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 <$ string name <* C.space
|
||||||
|
|
||||||
|
prefixOp :: Text -> (a -> a) -> Operator (ParsecT Void Text Data.Functor.Identity.Identity) a
|
||||||
|
prefixOp name f = Prefix $ f <$ symbol name
|
||||||
|
|
||||||
|
statement :: Parser M.Statement
|
||||||
|
statement =
|
||||||
|
choice
|
||||||
|
[ string "printInt" *> (M.PrintInt <$> parens intExpr),
|
||||||
|
string "printBool" *> (M.PrintBool <$> parens boolExpr)
|
||||||
|
]
|
||||||
|
<* symbol ";"
|
||||||
|
|
||||||
|
parseStatements :: Text -> Either (ParseErrorBundle Text Void) [M.Statement]
|
||||||
|
parseStatements = MP.parse (C.space *> many statement <* eof) ""
|
||||||
|
|
||||||
|
parse :: Text -> Either String [M.Statement]
|
||||||
|
parse t =
|
||||||
|
case parseStatements t of
|
||||||
|
Right r -> Right r
|
||||||
|
Left e -> Left (errorBundlePretty e)
|
||||||
|
|
||||||
|
-- TODO: add error handling
|
|
@ -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)
|
|
@ -1,4 +1,11 @@
|
||||||
resolver: lts-20.26
|
resolver: lts-20.26
|
||||||
|
compiler: ghc-9.2.8
|
||||||
|
# setup-info:
|
||||||
|
# ghc:
|
||||||
|
# aarch64:
|
||||||
|
# 9.4.6:
|
||||||
|
# url: "https://downloads.haskell.org/~ghc/9.4.6/ghc-9.4.6-aarch64-deb10-linux.tar.xz"
|
||||||
|
# sha256: "05896fc4bc52c117d281eac9c621c6c3a0b14f9f9eed5e42cce5e1c4485c7623"
|
||||||
|
|
||||||
packages:
|
packages:
|
||||||
- .
|
- .
|
||||||
|
@ -12,4 +19,4 @@ nix:
|
||||||
enable: true
|
enable: true
|
||||||
packages: [llvm_15, clang_15, libxml2]
|
packages: [llvm_15, clang_15, libxml2]
|
||||||
system-ghc: true
|
system-ghc: true
|
||||||
install-ghc: true
|
install-ghc: false
|
||||||
|
|
Reference in New Issue