Interpreter 1.0 Compiler 1.0 JIT 0.0
This commit is contained in:
commit
ac4f235592
14 changed files with 674 additions and 0 deletions
3
.envrc
Normal file
3
.envrc
Normal file
|
|
@ -0,0 +1,3 @@
|
||||||
|
#!/bin/bash
|
||||||
|
|
||||||
|
use flake
|
||||||
3
.gitignore
vendored
Normal file
3
.gitignore
vendored
Normal file
|
|
@ -0,0 +1,3 @@
|
||||||
|
result
|
||||||
|
dist-newstyle/
|
||||||
|
.direnv/
|
||||||
46
IR/IR.hs
Normal file
46
IR/IR.hs
Normal 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
127
IR/setup.ll
Normal 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
45
brainfuckhs.cabal
Normal 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
1
cabal.project.local
Normal file
|
|
@ -0,0 +1 @@
|
||||||
|
ignore-project: False
|
||||||
76
flake.lock
generated
Normal file
76
flake.lock
generated
Normal 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
36
flake.nix
Normal 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
5
lib/Backend.hs
Normal 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
103
lib/Backend/Compiler.hs
Normal 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
64
lib/Backend/Interpreter.hs
Normal 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
4
lib/Backend/JIT.hs
Normal file
|
|
@ -0,0 +1,4 @@
|
||||||
|
module Backend.JIT () where
|
||||||
|
|
||||||
|
i :: Integer
|
||||||
|
i = 0
|
||||||
58
src/bhfs.hs
Normal file
58
src/bhfs.hs
Normal 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
103
src/bhfsc.hs
Normal 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]
|
||||||
Loading…
Add table
Add a link
Reference in a new issue