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~
.HTF/
.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 `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
### Building
@ -41,7 +45,7 @@ Main repo: https://git.sudoer.ch/me/really-bad-compiler-in-haskell
- Language: Haskell
- 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
- IDE: VSCodium
- 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
-- import Compiler.ExeGen
import Compiler.LLVMGen
import Data.ByteString.Char8 qualified as B
import Data.Text.Lazy.IO qualified as T
import Eval.Expr
import LLVMGen.Expr
import Parser.Expr
import System.Environment
import System.Process
import Types.Expr
getRight :: ParseResult -> Expr
getRight (Right r) = r
getResult :: String -> Int
getResult str = evalExpr (getRight (parseExpr str)) -- TODO: add error messages
main :: IO ()
main = do
fileName <- fmap head getArgs
contents <- readFile fileName
let result = getResult contents
print result
T.putStrLn (getLLVMStr (getRight (parseExpr contents)))
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."

View File

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

View File

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

View File

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

View File

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

View File

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

View File

@ -28,6 +28,19 @@ packages:
original:
subdir: llvm-hs-pure
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:
- completed:
sha256: 5a59b2a405b3aba3c00188453be172b85893cab8ebc352b1ef58b0eae5d248a2