ref: 7f9059470afbb7ee5e3bca0cbf4c2b86a095a18a
parent: d358ecc4a4ebf2febbb5dc00172004fd3d50fbfb
author: Lennart Augustsson <lennart@augustsson.net>
date: Mon Aug 28 14:45:54 EDT 2023
Make it possible to make standalone binaries.
--- a/Makefile
+++ b/Makefile
@@ -10,6 +10,7 @@
# $(CURDIR) might not be quite right
GHCE=$(GHC) $(EXTS) -package mtl -F -pgmF ./convertX.sh -outputdir $(OUTDIR)
GCC=gcc
+UPX=upx
ALLSRC=src/*/*.hs lib/*.hs lib/*/*.hs ghc/*.hs ghc/*/*.hs
MHS=mhs
COMB=comb/
@@ -84,7 +85,7 @@
# Compare version compiled with GHC, and bootstrapped combinator version
bootcombtest: $(BIN)/$(MHS) $(BIN)/eval $(COMB)$(MHS).comb
$(BIN)/$(MHS) -ilib -isrc -omain-$(MHS).comb MicroHs.Main
- $(BIN)/eval -v -H50M -r$(COMB)$(MHS).comb -- -ilib -isrc -omain-comb.comb MicroHs.Main
+ $(BIN)/eval +RTS -v -r$(COMB)$(MHS).comb -RTS -ilib -isrc -omain-comb.comb MicroHs.Main
cmp main-$(MHS).comb main-comb.comb
# Test normal Haskell version
@@ -95,7 +96,7 @@
$(BIN)/$(MHS) -ilib -isrc -o$(COMB)$(MHS).comb MicroHs.Main
$(MHS)comp: $(BIN)/eval $(COMB)$(MHS).comb
- $(BIN)/eval -H1M -v -r$(COMB)$(MHS).comb -- $(ARG)
+ $(BIN)/eval +RTS -v -r$(COMB)$(MHS).comb -RTS $(ARG)
time: $(BIN)/eval $(BIN)/$(MHS) tests/*.hs
cd tests; make time
@@ -108,8 +109,23 @@
$(BIN)/boot$(MHS) -r -ilib Example && $(BIN)/eval
examplecomb: $(BIN)/eval $(COMB)$(MHS).comb Example.hs
- $(BIN)/eval -H5M -r$(COMB)$(MHS).comb -- -r -ilib Example
+ $(BIN)/eval +RTS -r$(COMB)$(MHS).comb -RTS -r -ilib Example
clean:
- rm -rf src/*/*.hi src/*/*.o eval Main *.comb *.tmp *~ $(BIN)/* a.out $(BOOTDIR) $(OUTDIR)
+ rm -rf src/*/*.hi src/*/*.o eval Main *.comb *.tmp *~ $(BIN)/* a.out $(BOOTDIR) $(OUTDIR) tmp/eval.c
cd tests; make clean
+
+$(BIN)/addcombs: Tools/Addcombs.hs
+ $(GHC) Tools/Addcombs.hs -o $(BIN)/addcombs
+
+tmp/eval.c: src/runtime/eval.c $(COMB)$(MHS).comb $(BIN)/addcombs
+ @mkdir -p tmp
+ cp src/runtime/eval.c tmp/eval.c
+ $(BIN)/addcombs $(COMB)$(MHS).comb >> tmp/eval.c
+
+$(BIN)/cmhs: tmp/eval.c
+ $(GCC) -Wall -O3 tmp/eval.c -o $(BIN)/cmhs
+ strip $(BIN)/cmhs
+
+$(BIN)/umhs: $(BIN)/cmhs
+ $(UPX) -o$(BIN)/umhs $(BIN)/cmhs
--- a/TODO
+++ b/TODO
@@ -3,6 +3,4 @@
- Parse as a string of atom oper atom oper ... atom
- Resolve fixity in type checker
- Add fixity table to TModule
-* Read entire combinator file in evaluator.
- - Use this to package evaluator with code.
* Put on hackage
--- /dev/null
+++ b/Tools/Addcombs.hs
@@ -1,0 +1,22 @@
+module Main where
+import System.Environment
+
+chunkify :: Int -> [Char] -> [[Char]]
+chunkify n [] = []
+chunkify n xs =
+ let (as, bs) = splitAt n xs
+ in as : chunkify n bs
+
+showChunk :: [Char] -> String
+showChunk = concatMap (\ c -> show (fromEnum c) ++ ",")
+
+main :: IO ()
+main = do
+ args <- getArgs
+ file <- readFile (head args)
+ let size = length file
+ chunks = chunkify 20 file
+ putStrLn $ "struct { size_t b_size; size_t b_pos; uint8_t b_buffer[]; } combs = { " ++ show size ++ ", 0, {"+ mapM_ (putStrLn . showChunk) chunks
+ putStrLn "}};"
+ putStrLn "BFILE *comb_internal = (BFILE*)&combs;"
\ No newline at end of file
--- a/ghc/Primitives.hs
+++ b/ghc/Primitives.hs
@@ -8,6 +8,7 @@
import Control.Exception(try)
import Data.Time
import Data.Time.Clock.POSIX
+import Data.Word
import System.IO
import System.IO.Unsafe
import System.Environment
@@ -84,6 +85,21 @@
primSeq :: a -> b -> b
primSeq = seq
+
+primWordAdd :: Word -> Word -> Word
+primWordAdd = (+)
+
+primWordSub :: Word -> Word -> Word
+primWordSub = (-)
+
+primWordMul :: Word -> Word -> Word
+primWordMul = (*)
+
+primWordQuot :: Word -> Word -> Word
+primWordQuot = quot
+
+primWordRem :: Word -> Word -> Word
+primIntRem = rem
------
--- a/lib/Primitives.hs
+++ b/lib/Primitives.hs
@@ -16,6 +16,17 @@
primIntSubR :: Int -> Int -> Int
primIntSubR = primitive "subtract"
+primWordAdd :: Word -> Word -> Word
+primWordAdd = primitive "+"
+primWordSub :: Word -> Word -> Word
+primWordSub = primitive "-"
+primWordMul :: Word -> Word -> Word
+primWordMul = primitive "*"
+primWordQuot :: Word -> Word -> Word
+primWordQuot = primitive "uquot"
+primWordRem :: Word -> Word -> Word
+primWordRem = primitive "urem"
+
primIntEQ :: Int -> Int -> Bool
primIntEQ = primitive "=="
primIntNE :: Int -> Int -> Bool
--- a/src/MicroHs/Translate.hs
+++ b/src/MicroHs/Translate.hs
@@ -57,6 +57,8 @@
("*", primitive "*"), ("quot", primitive "quot"), ("rem", primitive "rem"),+ ("uquot", primitive "uquot"),+ ("urem", primitive "urem"), ("subtract", primitive "subtract"), ("==", primitive "=="), ("/=", primitive "/="),--- a/src/runtime/eval.c
+++ b/src/runtime/eval.c
@@ -76,19 +76,19 @@
#define LOW_INT (-10)
#define HIGH_INT 128
-#define HEAP_CELLS 100000
-#define STACK_SIZE 10000
+#define HEAP_CELLS 50000000
+#define STACK_SIZE 100000
#define ERR(s) do { fprintf(stderr, "ERR: %s\n", s); exit(1); } while(0)-enum node_tag { T_FREE, T_IND, T_AP, T_INT, T_HDL, T_S, T_K, T_I, T_B, T_C, /* 0 - 9 */- T_A, T_Y, T_SS, T_BB, T_CC, T_P, T_O, T_T, T_BK, T_ADD, T_SUB, T_MUL, /* 10 - 21 */
- T_QUOT, T_REM, T_SUBR, T_EQ, T_NE, T_LT, T_LE, T_GT, T_GE, T_ERROR, T_SEQ, /* 22 - 32 */
- T_IO_BIND, T_IO_THEN, T_IO_RETURN, T_IO_GETCHAR, T_IO_PUTCHAR, /* 33 - 37 */
- T_IO_SERIALIZE, T_IO_DESERIALIZE, T_IO_OPEN, T_IO_CLOSE, T_IO_ISNULLHANDLE, /* 38 - 42 */
- T_IO_STDIN, T_IO_STDOUT, T_IO_STDERR, T_IO_GETARGS, T_IO_PERFORMIO, /* 43 - 47 */
- T_IO_GETTIMEMILLI, T_IO_PRINT, /* 48 - 49 */
- T_STR, /* 50 */
+enum node_tag { T_FREE, T_IND, T_AP, T_INT, T_HDL, T_S, T_K, T_I, T_B, T_C,+ T_A, T_Y, T_SS, T_BB, T_CC, T_P, T_O, T_T, T_BK, T_ADD, T_SUB, T_MUL,
+ T_QUOT, T_REM, T_SUBR, T_UQUOT, T_UREM, T_EQ, T_NE, T_LT, T_LE, T_GT, T_GE, T_ERROR, T_SEQ,
+ T_IO_BIND, T_IO_THEN, T_IO_RETURN, T_IO_GETCHAR, T_IO_PUTCHAR,
+ T_IO_SERIALIZE, T_IO_DESERIALIZE, T_IO_OPEN, T_IO_CLOSE, T_IO_ISNULLHANDLE,
+ T_IO_STDIN, T_IO_STDOUT, T_IO_STDERR, T_IO_GETARGS, T_IO_PERFORMIO,
+ T_IO_GETTIMEMILLI, T_IO_PRINT,
+ T_STR,
T_LAST_TAG,
};
@@ -355,6 +355,8 @@
{ "*", T_MUL }, { "quot", T_QUOT }, { "rem", T_REM },+ { "uquot", T_UQUOT },+ { "urem", T_UREM }, { "subtract", T_SUBR }, { "==", T_EQ }, { "/=", T_NE },@@ -969,6 +971,8 @@
case T_MUL: fprintf(f, "$*"); break;
case T_QUOT: fprintf(f, "$quot"); break;
case T_REM: fprintf(f, "$rem"); break;
+ case T_UQUOT: fprintf(f, "$uquot"); break;
+ case T_UREM: fprintf(f, "$urem"); break;
case T_SUBR: fprintf(f, "$subtract"); break;
case T_EQ: fprintf(f, "$=="); break;
case T_NE: fprintf(f, "$/="); break;
@@ -1216,10 +1220,11 @@
/* Alloc a possible GC action, e, between setting x and popping */
#define CHKARGEV1(e) do { CHECK(1); x = ARG(TOP(0)); e; POP(1); n = TOP(-1); } while(0)-#define SETINT(n,r) do { SETTAG((n), T_INT); SETVALUE((n), (r)); } while(0)-#define OPINT2(e) do { CHECK(2); xi = evalint(ARG(TOP(0))); yi = evalint(ARG(TOP(1))); e; POP(2); n = TOP(-1); } while(0);-#define ARITHBIN(op) do { OPINT2(r = xi op yi); SETINT(n, r); RET; } while(0)-#define CMP(op) do { OPINT2(r = xi op yi); GOIND(r ? comTrue : combFalse); } while(0)+#define SETINT(n,r) do { SETTAG((n), T_INT); SETVALUE((n), (r)); } while(0)+#define OPINT2(e) do { CHECK(2); xi = evalint(ARG(TOP(0))); yi = evalint(ARG(TOP(1))); e; POP(2); n = TOP(-1); } while(0);+#define ARITHBIN(op) do { OPINT2(r = xi op yi); SETINT(n, r); RET; } while(0)+#define ARITHBINU(op) do { OPINT2(r = (int64_t)((uint64_t)xi op (uint64_t)yi)); SETINT(n, r); RET; } while(0)+#define CMP(op) do { OPINT2(r = xi op yi); GOIND(r ? comTrue : combFalse); } while(0) for(;;) {num_reductions++;
@@ -1270,6 +1275,8 @@
case T_QUOT: ARITHBIN(/);
case T_REM: ARITHBIN(%);
case T_SUBR: OPINT2(r = yi - xi); SETINT(n, r); RET;
+ case T_UQUOT: ARITHBINU(/);
+ case T_UREM: ARITHBINU(%);
case T_EQ: CMP(==);
case T_NE: CMP(!=);
@@ -1482,11 +1489,16 @@
return n;
}
+BFILE *comb_internal;
+
int
main(int argc, char **argv)
{char *fn = 0;
+ char **av;
size_t file_size;
+ NODEPTR prog;
+ int inrts;
/* MINGW doesn't do buffering right */
setvbuf(stdout, NULL, _IOLBF, BUFSIZ);
@@ -1493,24 +1505,33 @@
setvbuf(stderr, NULL, _IONBF, BUFSIZ);
argc--, argv++;
- while (argc > 0 && argv[0][0] == '-') {- argc--;
- argv++;
- if (strcmp(argv[-1], "-v") == 0)
- verbose++;
- else if (strncmp(argv[-1], "-H", 2) == 0)
- heap_size = memsize(&argv[-1][2]);
- else if (strncmp(argv[-1], "-K", 2) == 0)
- stack_size = memsize(&argv[-1][2]);
- else if (strncmp(argv[-1], "-r", 2) == 0)
- fn = &argv[-1][2];
- else if (strcmp(argv[-1], "--") == 0)
- break;
- else
- ERR("Usage: eval [-v] [-Hheap-size] [-Kstack-size] [-rFILE] [-- arg ...]");- }
- glob_argc = argc;
glob_argv = argv;
+ for (av = argv, inrts = 0; argc--; argv++) {+ char *p = *argv;
+ if (inrts) {+ if (strcmp(p, "-RTS") == 0) {+ inrts = 0;
+ } else {+ if (strcmp(p, "-v") == 0)
+ verbose++;
+ else if (strncmp(p, "-H", 2) == 0)
+ heap_size = memsize(&p[2]);
+ else if (strncmp(p, "-K", 2) == 0)
+ stack_size = memsize(&p[2]);
+ else if (strncmp(p, "-r", 2) == 0)
+ fn = &p[2];
+ else
+ ERR("Usage: eval [+RTS [-v] [-Hheap-size] [-Kstack-size] [-rFILE] -RTS] arg ...");+ }
+ } else {+ if (strcmp(p, "+RTS") == 0) {+ inrts = 1;
+ } else {+ *av++ = p;
+ }
+ }
+ }
+ glob_argc = av - glob_argv;
if (fn == 0)
fn = "out.comb";
@@ -1519,7 +1540,13 @@
stack = malloc(sizeof(NODEPTR) * stack_size);
if (!stack)
memerr();
- NODEPTR prog = parse_file(fn, &file_size);
+
+ if (comb_internal) {+ prog = parse_top(comb_internal);
+ } else {+ prog = parse_file(fn, &file_size);
+ }
+
PUSH(prog); gc(); prog = TOP(0); POP(1);
uint64_t start_size = num_marked;
if (verbose > 2) {--- a/tests/Makefile
+++ b/tests/Makefile
@@ -3,7 +3,7 @@
.PHONY: test time clean
test:
- $(MHS) IOTest && (echo q | $(EVAL) -- a bb ccc | sed 's/^.ms/1ms/' > IOTest.out) && diff IOTest.ref IOTest.out
+ $(MHS) IOTest && (echo q | $(EVAL) a bb ccc | sed 's/^.ms/1ms/' > IOTest.out) && diff IOTest.ref IOTest.out
$(MHS) StringTest && $(EVAL) > StringTest.out && diff StringTest.ref StringTest.out
$(MHS) ListTest && $(EVAL) > ListTest.out && diff ListTest.ref ListTest.out
$(MHS) Fac && $(EVAL) > Fac.out && diff Fac.ref Fac.out
--
⑨