Dario48/bfhs
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Interpreter 1.0 Compiler 1.0 JIT 0.0

Browse source
This commit is contained in:
Dario48 2026-03-02 15:53:52 +01:00
commit ac4f235592
14 changed files with 674 additions and 0 deletions
Download patch file Download diff file Expand all files Collapse all files

3
.envrc Normal file
View file

@ -0,0 +1,3 @@
#!/bin/bash
use flake

3
.gitignore vendored Normal file
View file

@ -0,0 +1,3 @@
result
dist-newstyle/
.direnv/

46
IR/IR.hs Normal file
View file

@ -0,0 +1,46 @@
{-# LANGUAGE TemplateHaskell #-}
module IR (setup, main_start, index_inc, index_dec, val_inc, val_dec, point, comma, paren_opening, paren_close, main_end) where
import Data.FileEmbed (embedStringFile)
import Data.String (IsString)
setup :: (IsString a) => a
setup = $(embedStringFile "IR/setup.ll")
main_start :: String
main_start = "define void @main() {\n"
index_inc :: String
index_inc = "call void @index_inc()\n"
index_dec :: String
index_dec = "call void @index_dec()\n"
val_inc :: String
val_inc = "call void @val_inc()\n"
val_dec :: String
val_dec = "call void @val_dec()\n"
point :: String
point = "call void @point()\n"
comma :: String
comma = "call void @comma()\n"
paren :: String
paren = "call i1 @paren()\n"
paren_opening :: (Num a, Show a) => a -> String
paren_opening n = "br label %paren.start" ++ num ++ "\nparen.start" ++ num ++ ":\n%paren.cond" ++ num ++ " = " ++ paren ++ "\nbr i1 %paren.cond" ++ num ++ ", label %paren.body" ++ num ++ ", label %paren.end" ++ num ++ "\nparen.body" ++ num ++ ":\n"
where
num = show n
paren_close :: (Num a, Show a) => a -> String
paren_close n = "br label %paren.start" ++ num ++ "\nparen.end" ++ num ++ ":\n"
where
num = show n
main_end :: String
main_end = "ret void\n}\n"

127
IR/setup.ll Normal file
View file

@ -0,0 +1,127 @@
define i64 @syscall(i64 %call, i64 %rdi, i64 %rsi, i64 %rdx, i64 %r10, i64 %r8, i64 %r9) alwaysinline {
%rax = call i64 asm sideeffect inteldialect
"syscall",
"={rax},{rax},{rdi},{rsi},{rdx},{r10},{r8},{r9},~{rcx},~{r11},~{memory}"
(i64 %call, i64 %rdi, i64 %rsi, i64 %rdx, i64 %r10, i64 %r8, i64 %r9)
ret i64 %rax
}
define void @exit(i64 %exitcode) alwaysinline noreturn {
call i64 @syscall(i64 60, i64 %exitcode, i64 undef,i64 undef,i64 undef,i64 undef,i64 undef)
call void asm sideeffect "hlt", ""() noreturn
unreachable
}
define i8 @read() alwaysinline{
%buf = alloca i8
%ret = call i64 @syscall(i64 0, i64 0, ptr %buf, i64 1, i64 undef,i64 undef,i64 undef)
%ret.bool = trunc i64 %ret to i1
br i1 %ret.bool, label %normal, label %error
error:
call void @exit(i64 1)
ret i8 0
normal:
%char = load i8, ptr %buf
ret i8 %char
}
define i1 @write(i8 %char) alwaysinline {
%buf = alloca i8
store i8 %char, ptr %buf
%nwrite = call i64 @syscall(i64 1, i64 1, ptr %buf, i64 1, i64 undef,i64 undef,i64 undef)
%wrote = trunc i64 %nwrite to i1
ret i1 %wrote
}
define void @_start() naked {
; clear %rbp
call void asm sideeffect "", "{rbp}"(i64 0)
; read rsp
%rsp = call ptr asm "", "={rsp},{rsp}"(ptr undef)
call void @main()
call void @exit(i64 0)
ret void
}
@arr = global [30000 x i16] zeroinitializer
@index = global i16 0
define void @index_inc() alwaysinline {
%i = load i16, ptr @index
%i.i = add i16 %i, 1
%i.final = urem i16 %i.i, 30000
store i16 %i.final, ptr @index
ret void
}
define void @index_dec() alwaysinline {
%i = load i16, ptr @index
%i.i = sub i16 %i, 1
%i.final = urem i16 %i.i, 30000
store i16 %i.final, ptr @index
ret void
}
define void @val_inc() alwaysinline {
%index = load i16, ptr @index
%index.ext = sext i16 %index to i64
%val.ptr = getelementptr inbounds [30000 x i8], ptr @arr, i64 0, i64 %index.ext
%val = load i8, ptr %val.ptr
%val.final = add i8 %val, 1
store i8 %val.final, ptr %val.ptr
ret void
}
define void @val_dec() alwaysinline {
%index = load i16, ptr @index
%index.ext = sext i16 %index to i64
%val.ptr = getelementptr inbounds [30000 x i8], ptr @arr, i64 0, i64 %index.ext
%val = load i8, ptr %val.ptr
%val.final = sub i8 %val, 1
store i8 %val.final, ptr %val.ptr
ret void
}
define void @point() alwaysinline {
%index = load i16, ptr @index
%index.ext = sext i16 %index to i64
%char.ptr = getelementptr inbounds [30000 x i8], ptr @arr, i64 0, i64 %index.ext
%char = load i8, ptr %char.ptr
br label %loop
loop:
%wrote = call i1 @write(i8 %char)
%res = xor i1 %wrote, true
br i1 %res, label %loop, label %exit
exit:
ret void
}
define void @comma() alwaysinline {
%char = call i8 @read()
%index = load i16, ptr @index
%index.ext = sext i16 %index to i64
%char.dest = getelementptr inbounds [30000 x i8], ptr @arr, i64 0, i64 %index.ext
store i8 %char, ptr %char.dest
ret void
}
define i1 @paren() alwaysinline {
%index = load i16, ptr @index
%index.ext = sext i16 %index to i64
%val.ptr = getelementptr inbounds [30000 x i8], ptr @arr, i64 0, i64 %index.ext
%val = load i8, ptr %val.ptr
%eql = icmp ne i8 %val, 0
ret i1 %eql
}

45
brainfuckhs.cabal Normal file
View file

@ -0,0 +1,45 @@
cabal-version: 3.4
name: brainfuckhs
version: 0.1.0.0
license: GPL-3.0-or-later
author: Dario48
maintainer: dario48true@proton.me
build-type: Simple
common warnings
ghc-options: -Wall
library bfhsIR
import: warnings
extra-source-files:
IR/setup.ll
exposed-modules:
IR
build-depends: base, file-embed
hs-source-dirs: IR
default-language: Haskell2010
library backend
import: warnings
exposed-modules:
Backend
Backend.Compiler
Backend.Interpreter
Backend.JIT
build-depends: base, array, unix, process, brainfuckhs:bfhsIR
hs-source-dirs: lib
default-language: Haskell2010
executable bfhs
import: warnings
main-is: bhfs.hs
build-depends: base, array, brainfuckhs:backend
hs-source-dirs: src
default-language: Haskell2010
executable bfhsc
import: warnings
main-is: bhfsc.hs
build-depends: base, array, brainfuckhs:backend
hs-source-dirs: src
default-language: Haskell2010

1
cabal.project.local Normal file
View file

@ -0,0 +1 @@
ignore-project: False

76
flake.lock generated Normal file
View file

@ -0,0 +1,76 @@
{
"nodes": {
"flake-parts": {
"inputs": {
"nixpkgs-lib": "nixpkgs-lib"
},
"locked": {
"lastModified": 1769996383,
"narHash": "sha256-AnYjnFWgS49RlqX7LrC4uA+sCCDBj0Ry/WOJ5XWAsa0=",
"owner": "hercules-ci",
"repo": "flake-parts",
"rev": "57928607ea566b5db3ad13af0e57e921e6b12381",
"type": "github"
},
"original": {
"id": "flake-parts",
"type": "indirect"
}
},
"haskell-flake": {
"locked": {
"lastModified": 1770936528,
"narHash": "sha256-prklSEWoFyaIHo2jxq7BPw/LyTPBLR/em5C3h5lGXqg=",
"owner": "srid",
"repo": "haskell-flake",
"rev": "96d901fb45a33fe65c74f5b03f75e1195a2cd81b",
"type": "github"
},
"original": {
"owner": "srid",
"repo": "haskell-flake",
"type": "github"
}
},
"nixpkgs": {
"locked": {
"lastModified": 1770843696,
"narHash": "sha256-LovWTGDwXhkfCOmbgLVA10bvsi/P8eDDpRudgk68HA8=",
"owner": "nixos",
"repo": "nixpkgs",
"rev": "2343bbb58f99267223bc2aac4fc9ea301a155a16",
"type": "github"
},
"original": {
"owner": "nixos",
"ref": "nixpkgs-unstable",
"repo": "nixpkgs",
"type": "github"
}
},
"nixpkgs-lib": {
"locked": {
"lastModified": 1769909678,
"narHash": "sha256-cBEymOf4/o3FD5AZnzC3J9hLbiZ+QDT/KDuyHXVJOpM=",
"owner": "nix-community",
"repo": "nixpkgs.lib",
"rev": "72716169fe93074c333e8d0173151350670b824c",
"type": "github"
},
"original": {
"owner": "nix-community",
"repo": "nixpkgs.lib",
"type": "github"
}
},
"root": {
"inputs": {
"flake-parts": "flake-parts",
"haskell-flake": "haskell-flake",
"nixpkgs": "nixpkgs"
}
}
},
"root": "root",
"version": 7
}

36
flake.nix Normal file
View file

@ -0,0 +1,36 @@
{
inputs = {
nixpkgs.url = "github:nixos/nixpkgs/nixpkgs-unstable";
haskell-flake.url = "github:srid/haskell-flake";
};
outputs =
inputs@{
self,
nixpkgs,
flake-parts,
...
}:
flake-parts.lib.mkFlake { inherit inputs; } {
systems = nixpkgs.lib.systems.flakeExposed;
imports = [ ];
perSystem =
{ self', pkgs, ... }:
{
packages.default = pkgs.haskellPackages.developPackage {
root = ./.;
};
devShells.default = pkgs.mkShell {
buildInputs = with pkgs; [
ghc
(with haskellPackages; [
hoogle
haskell-language-server
])
];
shellHook = "";
# hoogle generate
};
};
};
}

5
lib/Backend.hs Normal file
View file

@ -0,0 +1,5 @@
module Backend (BFExecutor (exec, execStr)) where
class BFExecutor a where
exec :: a -> Char -> IO a
execStr :: a -> String -> IO a

103
lib/Backend/Compiler.hs Normal file
View file

@ -0,0 +1,103 @@
module Backend.Compiler (Compiler (Compiler), Optimization (Zero, One, Two, Three, Size, SizeSize)) where
import Backend
import Data.Bifoldable (bimapM_)
import Data.List (singleton)
import qualified IR
import System.IO (Handle, hClose, hFlush, hPutStr, openTempFile, stdout)
import System.Posix (getProcessID, rename)
import System.Process (callProcess)
type File = String
type Compile = Bool
data Optimization = Zero | One | Two | Three | Size | SizeSize deriving (Eq, Show)
data Step = Opt | Llc | LdLLd
getFlag :: Step -> Optimization -> String
getFlag step = case (step) of
Opt -> getFlagOpt
Llc -> getFlagLlc
LdLLd -> getFlagLdLLd
where
getFlagOpt level = case (level) of
Zero -> "--O0"
One -> "--O1"
Two -> "--O2"
Three -> "--O3"
Size -> "--Os"
SizeSize -> "--Oz"
getFlagLlc level = case (level) of
Zero -> "-O0"
One -> "-O1"
Two -> "-O2"
Three -> "-O3"
Size -> "-O2"
SizeSize -> "-O2"
getFlagLdLLd level = case (level) of
Zero -> "-O0"
One -> "-O1"
Two -> "-O2"
Three -> "-O2"
Size -> "-O2"
SizeSize -> "-O2"
data Compiler = Compiler File Compile Optimization
instance BFExecutor Compiler where
exec c = execStr c . singleton
execStr (Compiler out comp optLevel) code =
print out
>> ( openTempFile "./" (out ++ ".ll")
>>> (\(_, f) -> return f >>> append IR.setup >>> append IR.main_start >>> compile code >>> append IR.main_end >>> hFlush)
>>= bimapM_
( if (comp)
then (\f -> opt f >>= llc >>= ldLld >>= flip rename out)
else flip rename out
)
hClose
)
>> return (Compiler out comp optLevel)
where
opt unopt = file >>= (\r -> callProcess "opt" [getFlag Opt optLevel, "-o", r, "-S", unopt]) >> file
where
file = getProcessID >>= (\r -> return $ "./" ++ out ++ (show r) ++ ".opt")
llc uncomp = file >>= (\r -> callProcess "llc" [getFlag Llc optLevel, "-o", r, uncomp, "--filetype=obj"]) >> file
where
file = getProcessID >>= (\r -> return $ "./" ++ out ++ (show r) ++ ".o")
ldLld unlinked = file >>= (\r -> callProcess "ld.lld" [getFlag Llc optLevel, "-o", r, unlinked]) >> file
where
file = getProcessID >>= (\r -> return $ "./" ++ out ++ (show r))
compile :: String -> Handle -> IO ()
compile s h = putStr s >> (() <$ _compile s (1, []) h)
(>>>) :: (Monad m) => m a -> (a -> m b) -> m a
v >>> f = v >>= \x -> f x >> return x
-- +[-]
-- append val_inc
-- append paren_opening 1
-- append val_dec
-- append paren_close 1
_compile :: String -> (Int, [Int]) -> Handle -> IO String
_compile (x : xs) loop_counter file =
putStr [x]
>> case (x) of
'>' -> use file >>> append IR.index_inc >>= _compile xs loop_counter
'<' -> use file >>> append IR.index_dec >>= _compile xs loop_counter
'+' -> use file >>> append IR.val_inc >>= _compile xs loop_counter
'-' -> use file >>> append IR.val_dec >>= _compile xs loop_counter
'.' -> use file >>> append IR.point >>= _compile xs loop_counter
',' -> use file >>> append IR.comma >>= _compile xs loop_counter
'[' -> use file >>> append (IR.paren_opening (fst loop_counter)) >>= _compile xs (fst loop_counter + 1, [fst loop_counter] ++ snd loop_counter)
']' -> use file >>> append (IR.paren_close (_head $ snd loop_counter)) >>= _compile xs (fst loop_counter, _drop 1 $ snd loop_counter)
_ -> _compile xs loop_counter file
where
use = return
_head a = if (length a > 0) then a !! 0 else error "unmatched closed parenthesis"
_drop n a = if (length a > 0) then drop n a else error "unmatched closed parenthesis"
_compile [] _ _ = return ""
append :: String -> Handle -> IO ()
append = flip hPutStr

64
lib/Backend/Interpreter.hs Normal file
View file

@ -0,0 +1,64 @@
module Backend.Interpreter (defaultInterpreter, Interpreter (Interpreter), Index, Size, getArray, modArray, getIndex, modIndex, getSize) where
import Backend
import Data.Array.Base (UArray, array, (!), (//))
import Data.List (singleton)
import Data.Word (Word16, Word8)
import Text.Printf (printf)
type Index = Word16
type Size = Word16
data Interpreter = Interpreter (UArray Index Word8) Index Size
instance BFExecutor Interpreter where
exec i = execStr i . singleton
execStr i str = _execStr (i, str)
where
_execStr (interpreter, (x : xs)) =
let (arr, index) = (getArray interpreter, getIndex interpreter)
in case (x) of
'>' -> _execStr (interpreter `modIndex` (flip mod 30000 . (+) 1), xs)
'<' -> _execStr (interpreter `modIndex` (flip mod 30000 . subtract 1), xs)
'+' -> _execStr (interpreter `modArray` (\a -> a // [(index, (arr ! index) + 1)]), xs)
'-' -> _execStr (interpreter `modArray` (\a -> a // [(index, (arr ! index) - 1)]), xs)
'.' -> (printf "%c" (word8ToChar (arr ! index))) >> _execStr (interpreter, xs)
',' -> getChar >>= (\c -> _execStr (interpreter `modArray` (\a -> a // [(index, charToWord8 c)]), xs))
'[' ->
if ((arr ! index) == 0)
then _execStr (interpreter, findMatching xs)
else _execStr (interpreter, xs) >>= (\inter -> _execStr (inter, x : xs))
']' -> return interpreter
_ -> _execStr (interpreter, xs)
_execStr (interpreter, []) = return interpreter
findMatching (x : xs) = case x of
'[' -> findMatching $ findMatching xs
']' -> xs
_ -> findMatching xs
findMatching [] = error "unclosed loop"
defaultInterpreter :: Interpreter
defaultInterpreter = Interpreter (array (0, 30000 - 1) [(i, 0) | i <- [0 .. 30000 - 1]]) (0 :: Index) (30000 :: Size)
charToWord8 :: Char -> Word8
charToWord8 = toEnum . fromEnum
word8ToChar :: Word8 -> Char
word8ToChar = toEnum . fromEnum
modArray :: Interpreter -> (UArray Index Word8 -> UArray Index Word8) -> Interpreter
modArray (Interpreter a b c) f = Interpreter (f a) b c
modIndex :: Interpreter -> (Index -> Index) -> Interpreter
modIndex (Interpreter a b c) f = Interpreter a (f b) c
getArray :: Interpreter -> UArray Index Word8
{-# INLINE getArray #-}
getArray (Interpreter arr _ _) = arr
getIndex :: Interpreter -> Index
{-# INLINE getIndex #-}
getIndex (Interpreter _ i _) = i
getSize :: Interpreter -> Size
{-# INLINE getSize #-}
getSize (Interpreter _ _ s) = s

4
lib/Backend/JIT.hs Normal file
View file

@ -0,0 +1,4 @@
module Backend.JIT () where
i :: Integer
i = 0

58
src/bhfs.hs Normal file
View file

@ -0,0 +1,58 @@
module Main where
import Data.Array.Base ((!))
import qualified Data.List.NonEmpty as NonEmpty (fromList, head, (!!))
import GHC.Environment (getFullArgs)
import System.IO (hFlush, stdout)
import Text.Printf (printf)
import Backend
import Backend.Interpreter
repl :: Interpreter -> IO ()
repl interpreter = do
putStr "bfhs> "
hFlush stdout
line <- getLine
case line of
":h" -> do
putStrLn "Commands:"
putStrLn " :h = this text"
putStrLn " :q = quit"
putStrLn " :d = print the state of the array around the index"
repl interpreter
":q" -> return ()
":d" ->
let (arr, size) = (getArray interpreter, getSize interpreter - 1)
in case getIndex interpreter of
0 -> printf "[ |%u| %u %u ...\n" (arr ! 0) (arr ! 1) (arr ! 2)
1 -> printf "[ %u |%u| %u %u ...\n" (arr ! 0) (arr ! 1) (arr ! 2) (arr ! 3)
2 -> printf "[ %u %u |%u| %u %u ...\n" (arr ! 0) (arr ! 1) (arr ! 2) (arr ! 3) (arr ! 4)
other -> case () of
_
| other == size - 2 -> printf "... %u %u |%u| %u %u ]\n" (arr ! (size - 4)) (arr ! (size - 3)) (arr ! (size - 2)) (arr ! (size - 1)) (arr ! size)
| other == size - 1 -> printf "... %u %u |%u| %u ]\n" (arr ! (size - 3)) (arr ! (size - 2)) (arr ! (size - 1)) (arr ! size)
| other == size - 0 -> printf "... %u %u |%u| ]\n" (arr ! (size - 2)) (arr ! (size - 1)) (arr ! size)
| otherwise -> printf "... %u %u |%u| %u %u ...\n" (arr ! (other - 2)) (arr ! (other - 1)) (arr ! other) (arr ! (other + 1)) (arr ! (other + 2))
>> repl interpreter
brainfuck -> interpreter `execStr` brainfuck >>= repl
main :: IO ()
main = do
args <- NonEmpty.fromList <$> getFullArgs
if length args == 1
then putStrLn "repl mode initialized, this mode adds a bunch of utilities using the character :, to list them instert just :h" >> repl defaultInterpreter
else do
if "-h" `elem` args
then do
putStrLn $ "usage: " ++ (NonEmpty.head args) ++ " [OPTIONS] [file]"
putStrLn "if file is not provided the program will enter repl mode"
putStrLn "OPTIONS:"
putStrLn " -h: this text"
return ()
else do
code <- readFile $ args NonEmpty.!! 1
_ <- defaultInterpreter `execStr` code
return ()

103
src/bhfsc.hs Normal file
View file

@ -0,0 +1,103 @@
module Main where
import Backend
import Backend.Compiler
import Data.List (isInfixOf)
import qualified Data.List.NonEmpty as NonEmpty
import GHC.Environment (getFullArgs)
import System.IO.Unsafe (unsafePerformIO)
main :: IO ()
main = do
args <- NonEmpty.fromList <$> getFullArgs
if length args == 1
then error $ "usage: " ++ NonEmpty.head args ++ " file [OPTIONS]"
else do
if "-h" `elem` args
then do
putStrLn $ "usage: " ++ (NonEmpty.head args) ++ " file [OPTIONS]"
putStrLn "OPTIONS:"
putStrLn " -h: this text"
putStrLn " -On: optimization level [0, 1, 2, 3, s, z]"
putStrLn " -o: output file"
return ()
else do
let parsedArgs = foldl handle_Args (Args None_ None Nothing True) (NonEmpty.drop 1 args)
case (getInput parsedArgs) of
Just file ->
readFile file
>>= execStr
( Compiler
( case (getOutput parsedArgs) of
None -> file ++ ".out"
Next -> error "you need to pass an output file if you specify the -o flag"
Value out -> out
)
(getBuild parsedArgs)
( case (getOptLevel parsedArgs) of
None_ -> Two
Next_ -> error "you need to pass a level if you use the -O flag"
Value_ lvl -> lvl
)
)
>> return ()
Nothing -> error "needed input file"
data Arg = None | Next | Value String deriving (Eq, Show)
data OptLevel = None_ | Next_ | Value_ Optimization deriving (Eq, Show)
type Output = Arg
type Input = Maybe String
type Build = Bool
data Args = Args OptLevel Output Input Build deriving (Show)
getOptLevel :: Args -> OptLevel
getOptLevel (Args optLevel _ _ _) = optLevel
getOutput :: Args -> Output
getOutput (Args _ file _ _) = file
getInput :: Args -> Input
getInput (Args _ _ file _) = file
getBuild :: Args -> Bool
getBuild (Args _ _ _ b) = b
handle_Args :: Args -> String -> Args
handle_Args (Args optLevel out input build) str =
unsafePerformIO (putStr (str ++ "|") >> print (Args optLevel out input build)) `seq`
if (optLevel == Next_)
then Args (Value_ $ parseOpt (str !! 0)) out input build
else
if (out == Next)
then Args optLevel (Value str) input build
else
if ("-O" `isInfixOf` str)
then
Args (Value_ $ parseOpt (str !! 2)) out input build
else
if ("-o" `isInfixOf` str)
then
if ((length str) > 2)
then Args optLevel (Value $ drop 2 str) input build
else Args optLevel Next input build
else
if (length "-emit-llvm" == length str)
then
if (any (uncurry (/=)) (zip "-emit-llvm" str))
then
Args optLevel out (Just str) build
else
Args optLevel out input False
else
Args optLevel out (Just str) build
where
parseOpt char = case (char) of
'0' -> Zero
'1' -> One
'2' -> Two
'3' -> Three
's' -> Size
'z' -> SizeSize
c -> error $ "Error: unrecognised optimization level " ++ [c]