Compare commits

..

4 Commits

16 changed files with 212 additions and 163 deletions

2
.gitignore vendored
View File

@ -21,3 +21,5 @@ cabal.project.local
cabal.project.local~ cabal.project.local~
.HTF/ .HTF/
.ghc.environment.* .ghc.environment.*
a.out
a.out.ll

7
.vscode/extensions.json vendored 100644
View File

@ -0,0 +1,7 @@
{
"recommendations": [
"gattytto.phoityne-vscode",
"haskell.haskell",
"justusadam.language-haskell"
]
}

46
.vscode/launch.json vendored 100644
View File

@ -0,0 +1,46 @@
{
// Use IntelliSense to learn about possible attributes.
// Hover to view descriptions of existing attributes.
// For more information, visit: https://go.microsoft.com/fwlink/?linkid=830387
"version": "0.2.0",
"configurations": [
{
"type": "ghc",
"request": "launch",
"name": "haskell(stack)",
"internalConsoleOptions": "openOnSessionStart",
"workspace": "${workspaceFolder}",
"startup": "${workspaceFolder}/test/Spec.hs",
"startupFunc": "",
"startupArgs": "",
"stopOnEntry": false,
"mainArgs": "",
"ghciPrompt": "H>>= ",
"ghciInitialPrompt": "Prelude>",
"ghciCmd": "stack ghci --test --no-load --no-build --main-is TARGET",
"ghciEnv": {},
"logFile": "${workspaceFolder}/.vscode/phoityne.log",
"logLevel": "WARNING",
"forceInspect": false
},
{
"type": "ghc",
"request": "launch",
"name": "haskell(cabal)",
"internalConsoleOptions": "openOnSessionStart",
"workspace": "${workspaceFolder}",
"startup": "${workspaceFolder}/Main.hs",
"startupFunc": "",
"startupArgs": "",
"stopOnEntry": false,
"mainArgs": "",
"ghciPrompt": "H>>= ",
"ghciInitialPrompt": "Prelude>",
"ghciCmd": "cabal exec -- ghci-dap --interactive -i -i${workspaceFolder}",
"ghciEnv": {},
"logFile": "${workspaceFolder}/.vscode/phoityne.log",
"logLevel": "WARNING",
"forceInspect": false
}
]
}

50
.vscode/tasks.json vendored 100644
View File

@ -0,0 +1,50 @@
{
// Automatically created by phoityne-vscode extension.
"version": "2.0.0",
"presentation": {
"reveal": "always",
"panel": "new"
},
"tasks": [
{
// F7
"group": {
"kind": "build",
"isDefault": true
},
"label": "haskell build",
"type": "shell",
//"command": "cabal configure && cabal build"
"command": "stack build"
},
{
// F6
"group": "build",
"type": "shell",
"label": "haskell clean & build",
//"command": "cabal clean && cabal configure && cabal build"
"command": "stack clean && stack build"
//"command": "stack clean ; stack build" // for powershell
},
{
// F8
"group": {
"kind": "test",
"isDefault": true
},
"type": "shell",
"label": "haskell test",
//"command": "cabal test"
"command": "stack test"
},
{
// F6
"isBackground": true,
"type": "shell",
"label": "haskell watch",
"command": "stack build --test --no-run-tests --file-watch"
}
]
}

View File

@ -11,6 +11,10 @@ Main repo: https://git.sudoer.ch/me/really-bad-compiler-in-haskell
- 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.9.3`, `HLS 2.2.0.0`, `GHC 9.2.8`, and `cabal 3.6.2.0`.
- 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`).
## 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.
## Known bugs ## Known bugs
### Building ### Building
@ -41,7 +45,7 @@ Main repo: https://git.sudoer.ch/me/really-bad-compiler-in-haskell
- Language: Haskell - Language: Haskell
- Haskell tools: GHCup, Stack, Cabal, GHC 9.2 - Haskell tools: GHCup, Stack, Cabal, GHC 9.2
- Libraries: megaparsec, parser-combinators, text, llvm-hs-pure 15, llvm-hs-pretty-15 - Libraries: megaparsec, parser-combinators, text, process, llvm-hs-pure 15, llvm-hs-pretty-15
- Dependencies: llvm 15, clang 15 - Dependencies: llvm 15, clang 15
- IDE: VSCodium - IDE: VSCodium
- Git platform: Forgejo - Git platform: Forgejo

View File

@ -0,0 +1,65 @@
{-# 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")
traceShow numFormatStr $ pure ()
ourExpression <- exprToLLVM expr
-- _ <- call (FunctionType i32 [i32])
_ <- 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
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
)

View File

@ -1,13 +0,0 @@
module Eval.Expr (evalExpr) where
import Types.Expr
eval :: Expr -> Int
eval (Lit x) = x
eval (Add x y) = eval x + eval y
eval (Sub x y) = eval x - eval y
eval (Mul x y) = eval x * eval y
eval (Div x y) = eval x `div` eval y
evalExpr :: Expr -> Int
evalExpr = eval

View File

@ -1,57 +0,0 @@
{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE OverloadedStrings #-}
-- see https://gh.sudoer.ch/danieljharvey/mimsa/blob/trunk/llvm-calc/src/Calc/Compile/ToLLVM.hs
module LLVMGen.Expr (getLLVMStr) where
import Data.Text.Lazy
import LLVM.AST hiding (function)
import LLVM.AST.Type
import LLVM.IRBuilder.Constant
import LLVM.IRBuilder.Instruction
import LLVM.IRBuilder.Module
import LLVM.IRBuilder.Monad
import LLVM.Pretty
import Types.Expr as Expr
-- charStar :: LLVM.Type
-- charStar = LLVM.ptr LLVM.i8
getLLVM :: Expr -> Module
getLLVM expr =
buildModule "program" $ do
-- TODO: better naming
printf <- externVarArgs "printf" [ptr] i32 -- or LLVM.ptr LLVM.i8
let numFormatStr = globalStringPtr "%d\n" (mkName "str")
function "main" [] i32 $ \_ -> do
ourExpression <- exprToLLVM expr
nfs <- numFormatStr
_ <- call i32 printf [(ConstantOperand nfs, []), (ourExpression, [])]
ret (int32 0)
exprToLLVM ::
( MonadIRBuilder m,
MonadModuleBuilder m
) =>
Expr ->
m Operand
exprToLLVM (Lit prim) = pure $ primToLLVM prim
exprToLLVM (Expr.Add a b) = do
lhs <- exprToLLVM a
rhs <- exprToLLVM b
add lhs rhs
exprToLLVM (Expr.Sub a b) = do
lhs <- exprToLLVM a
rhs <- exprToLLVM b
sub lhs rhs
exprToLLVM (Expr.Mul a b) = do
lhs <- exprToLLVM a
rhs <- exprToLLVM b
mul lhs rhs
primToLLVM :: Int -> Operand
primToLLVM i = int32 (fromIntegral i)
getLLVMStr :: Expr -> Text
getLLVMStr expr = ppllvm (getLLVM expr)

View File

@ -1,74 +0,0 @@
module LLVMGen.Expr (getLLVM) where
import qualified Objects.Expr as Expr
import LLVM.AST
import qualified LLVM.AST as AST
import LLVM.AST.Global
import LLVM.AST.Constant
import LLVM.AST.Type
import LLVM.AST.Name
import LLVM.Context
import LLVM.Module
import Data.ByteString.Char8 as BS
int :: Type
int = IntegerType 32
defMain :: Definition
defMain = GlobalDefinition functionDefaults
{ name = Name "main"
, parameters =
( []
, False )
, returnType = int
, basicBlocks = [body]
}
where
body = BasicBlock
(Name "entry")
[ Name "calltmp" :=
Call
{ tailCallKind = Nothing
, function = Right (ConstantOperand (GlobalReference (PointerType (FunctionType int [int, int] False) defaultAddrSpace) (Name "add")))
, arguments = [ (ConstantOperand (Int 32 10), []), (ConstantOperand (Int 32 20), []) ]
}
]
(Do $ Ret (Just (ConstantOperand (Int 32 0))) [])
defAdd :: Definition
defAdd = GlobalDefinition functionDefaults
{ name = Name "add"
, parameters =
( [ Parameter int (Name "a") []
, Parameter int (Name "b") [] ]
, False )
, returnType = int
, basicBlocks = [body]
}
where
body = BasicBlock
(Name "entry")
[ Name "result" :=
AST.Add False -- no signed wrap
False -- no unsigned wrap
(LocalReference int (Name "a"))
(LocalReference int (Name "b"))
[]]
(Do $ Ret (Just (LocalReference int (Name "result"))) [])
module_ :: AST.Module
module_ = defaultModule
{ moduleName = "basic"
, moduleDefinitions = [defMain, defAdd]
}
toLLVM :: AST.Module -> IO ()
toLLVM modul = withContext $ \ctx -> do
llvm <- withModuleFromAST ctx modul moduleLLVMAssembly
BS.putStrLn llvm
getLLVM :: IO ()
getLLVM = toLLVM module_

View File

@ -3,23 +3,26 @@
module Main (main) where 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 Data.Text.Lazy.IO qualified as T
import Eval.Expr
import LLVMGen.Expr
import Parser.Expr import Parser.Expr
import System.Environment import System.Environment
import System.Process
import Types.Expr import Types.Expr
getRight :: ParseResult -> Expr getRight :: ParseResult -> Expr
getRight (Right r) = r getRight (Right r) = r
getResult :: String -> Int
getResult str = evalExpr (getRight (parseExpr str)) -- TODO: add error messages
main :: IO () main :: IO ()
main = do main = do
fileName <- fmap head getArgs fileName <- fmap head getArgs
contents <- readFile fileName contents <- readFile fileName
let result = getResult contents T.putStrLn "- Parsing file..."
print result let parsed = getRight (parseExpr contents)
T.putStrLn (getLLVMStr (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."

View File

@ -27,8 +27,8 @@ term = Lit <$> intParser
table :: [[Operator Parser Expr]] table :: [[Operator Parser Expr]]
table = table =
[ [ binaryOp "*" Mul, [ [ binaryOp "*" Mul
binaryOp "/" Div -- binaryOp "/" Div
], ],
[ binaryOp "+" Add, [ binaryOp "+" Add,
binaryOp "-" Sub binaryOp "-" Sub

View File

@ -5,5 +5,7 @@ data Expr
| Add Expr Expr | Add Expr Expr
| Sub Expr Expr | Sub Expr Expr
| Mul Expr Expr | Mul Expr Expr
| Div Expr Expr deriving
deriving (Show) ( -- | Div Expr Expr
Show
)

View File

@ -6,9 +6,10 @@ dependencies:
- megaparsec >= 9.0.1 && < 10 - megaparsec >= 9.0.1 && < 10
- parser-combinators - parser-combinators
- text - text
# - llvm-hs >= 15 && < 16 - process
- llvm-hs >= 15 && < 16
- llvm-hs-pure >= 15 && < 16 - llvm-hs-pure >= 15 && < 16
- llvm-hs-pretty >= 15 && < 16 # - llvm-hs-pretty >= 15 && < 16
- bytestring - bytestring
tested-with: GHC == 9.2.8 tested-with: GHC == 9.2.8
category: Compilers/Interpreters category: Compilers/Interpreters

View File

@ -16,8 +16,7 @@ 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:
Eval.Expr Compiler.LLVMGen
LLVMGen.Expr
Parser.Expr Parser.Expr
Types.Expr Types.Expr
Paths_really_bad_compiler_in_haskell Paths_really_bad_compiler_in_haskell
@ -29,9 +28,10 @@ executable really-bad-compiler-in-haskell
build-depends: build-depends:
base >=4.14.3 && <5 base >=4.14.3 && <5
, bytestring , bytestring
, llvm-hs-pretty ==15.* , llvm-hs ==15.*
, llvm-hs-pure ==15.* , llvm-hs-pure ==15.*
, megaparsec >=9.0.1 && <10 , megaparsec >=9.0.1 && <10
, parser-combinators , parser-combinators
, process
, text , text
default-language: Haskell2010 default-language: Haskell2010

View File

@ -9,7 +9,7 @@ extra-deps:
commit: 5bca2c1a2a3aa98ecfb19181e7a5ebbf3e212b76 commit: 5bca2c1a2a3aa98ecfb19181e7a5ebbf3e212b76
subdirs: subdirs:
- llvm-hs-pure - llvm-hs-pure
# - llvm-hs - llvm-hs
nix: nix:
enable: true enable: true
packages: [llvm_15, clang_15, libxml2] packages: [llvm_15, clang_15, libxml2]

View File

@ -28,6 +28,19 @@ packages:
original: original:
subdir: llvm-hs-pure subdir: llvm-hs-pure
url: https://github.com/llvm-hs/llvm-hs/archive/5bca2c1a2a3aa98ecfb19181e7a5ebbf3e212b76.tar.gz url: https://github.com/llvm-hs/llvm-hs/archive/5bca2c1a2a3aa98ecfb19181e7a5ebbf3e212b76.tar.gz
- completed:
name: llvm-hs
pantry-tree:
sha256: 21f74a6f51fae6c0a0fcf3e6620a59f341289ac743998b41ed3276fd1b7d8862
size: 12716
sha256: 526b67e2da9ce25b3856c221b6772e699a7593dbb5ba38e7ee2436349de70966
size: 9802209
subdir: llvm-hs
url: https://github.com/llvm-hs/llvm-hs/archive/5bca2c1a2a3aa98ecfb19181e7a5ebbf3e212b76.tar.gz
version: 15.0.0
original:
subdir: llvm-hs
url: https://github.com/llvm-hs/llvm-hs/archive/5bca2c1a2a3aa98ecfb19181e7a5ebbf3e212b76.tar.gz
snapshots: snapshots:
- completed: - completed:
sha256: 5a59b2a405b3aba3c00188453be172b85893cab8ebc352b1ef58b0eae5d248a2 sha256: 5a59b2a405b3aba3c00188453be172b85893cab8ebc352b1ef58b0eae5d248a2