From e95feb9309f06afcf77d0da9d6b2ae02dcc170ca Mon Sep 17 00:00:00 2001 From: Nathan Braswell Date: Wed, 6 Jul 2022 02:34:48 -0400 Subject: [PATCH] tiny perceus fix, but mostly wrote match+rb-tree f-expr/macro for newLisp and benchmarked it. kraken 5-15x faster than newlisp-rbtree-macro, 137x faster than newlisp-rbtree-fexpr. I was suprised at first that the macro and fexpr versions were so close at 8.7x (while interpreted kraken rbtree is 50,000x slower), but after thinking about it it makes sense - the Kraken version has slowdown exponential in the multiple levels of f-exprs ('match' is an fexpr, but then so is 'let' and 'and' and 'lambda'), whereas the newLisp f-expr runtime expands to fast builtins ('let', 'and', etc). And all that exponential f-expr slowdown gets compiled away in Kraken! --- koka_bench/kraken_wrapper.sh | 4 +- koka_bench/newlisp/CMakeLists.txt | 2 +- koka_bench/newlisp/newlisp-builtin-rbtree.nl | 12 ++ koka_bench/newlisp/newlisp-macro-rbtree.nl | 103 ++++++++++++++++++ .../newlisp/newlisp-slow-fexpr-rbtree.nl | 97 +++++++++++++++++ koka_bench/test.sh | 26 +++-- partial_eval.scm | 9 +- 7 files changed, 235 insertions(+), 18 deletions(-) create mode 100755 koka_bench/newlisp/newlisp-builtin-rbtree.nl create mode 100755 koka_bench/newlisp/newlisp-macro-rbtree.nl create mode 100755 koka_bench/newlisp/newlisp-slow-fexpr-rbtree.nl diff --git a/koka_bench/kraken_wrapper.sh b/koka_bench/kraken_wrapper.sh index a3540ec..9334f60 100755 --- a/koka_bench/kraken_wrapper.sh +++ b/koka_bench/kraken_wrapper.sh @@ -16,8 +16,8 @@ chmod 755 "$OUT_DIR/$OUT_NAME-wavm" scheme --script "$OUR_DIR/../partial_eval.scm" $SOURCE no_compile mv ./csc_out.wasm "$OUT_DIR/$OUT_NAME-slow.wasm" -printf '#!/usr/bin/env bash\nwasmtime "$(dirname $(readlink -f $0))/'"$OUT_NAME-slow"'.wasm" $@' > "$OUT_DIR/$OUT_NAME-slow" -chmod 755 "$OUT_DIR/$OUT_NAME-slow" +#printf '#!/usr/bin/env bash\nwasmtime "$(dirname $(readlink -f $0))/'"$OUT_NAME-slow"'.wasm" $@' > "$OUT_DIR/$OUT_NAME-slow" +#chmod 755 "$OUT_DIR/$OUT_NAME-slow" printf '#!/usr/bin/env bash\nWAVM_OBJECT_CACHE_DIR=$(pwd) wavm run "$(dirname $(readlink -f $0))/'"$OUT_NAME-slow"'.wasm" $@' > "$OUT_DIR/$OUT_NAME-slow-wavm" chmod 755 "$OUT_DIR/$OUT_NAME-slow-wavm" diff --git a/koka_bench/newlisp/CMakeLists.txt b/koka_bench/newlisp/CMakeLists.txt index 01e7fe4..fe4499f 100644 --- a/koka_bench/newlisp/CMakeLists.txt +++ b/koka_bench/newlisp/CMakeLists.txt @@ -1,7 +1,7 @@ set(copy_wrapper "../../copy_wrapper.sh") -set(sources newlisp-fib.nl newlisp-fib-let.nl) +set(sources newlisp-fib.nl newlisp-fib-let.nl newlisp-builtin-rbtree.nl newlisp-slow-fexpr-rbtree.nl newlisp-macro-rbtree.nl ) foreach (source IN LISTS sources) get_filename_component(name "${source}" NAME_WE) diff --git a/koka_bench/newlisp/newlisp-builtin-rbtree.nl b/koka_bench/newlisp/newlisp-builtin-rbtree.nl new file mode 100755 index 0000000..268ba37 --- /dev/null +++ b/koka_bench/newlisp/newlisp-builtin-rbtree.nl @@ -0,0 +1,12 @@ +#!/usr/bin/env newlisp + +(new Tree 'Foo) + +(define (make-test-tree n t) (cond ((<= n 0) t) + (true (make-test-tree (- n 1) (begin (t n (= 0 (% n 10))) t))))) +(define (reduce-test-tree t) (let ((sum 0)) (dolist (item (t)) (if (item 1) (setq sum (+ sum 1)))))) + + +(println (reduce-test-tree (make-test-tree (integer (main-args 2)) Foo))) + +(exit) diff --git a/koka_bench/newlisp/newlisp-macro-rbtree.nl b/koka_bench/newlisp/newlisp-macro-rbtree.nl new file mode 100755 index 0000000..ad9b9af --- /dev/null +++ b/koka_bench/newlisp/newlisp-macro-rbtree.nl @@ -0,0 +1,103 @@ +#!/usr/bin/env newlisp + +(define cont list) +(define cont? list?) +;(define cont (lambda (l) (array (length l) l))) +;(define cont? array?) + +; Sigh, newLisp doesn't seem to be expand 'a to (quote a) so we can't look for it, and +; it doesn't support unquoting or splice-unquoting at all. As a hack, we instead +; do some string manipulation on symbols starting with the special characters ~ or @ + +; OH WAIT NO WE DON'T +; we just write it out explicitly +; ugly, but fair + +(define (evaluate_case access c) (cond + ((and (list? c) (= 2 (length c)) (= 'unquote (c 0))) (list (list = access (c 1)) (lambda (b) b))) + ((symbol? c) (list true (expand (lambda (b) (list let (list 'c 'access) b)) 'c 'access))) + ((list? c) (letn ( + tests (list and (list list? access) (list = (length c) (list length access))) + tests__body_func (local (recurse) (setq recurse (lambda (tests body_func i) (if (= i (length c)) + (list tests body_func) + (letn ( inner_test__inner_body_func (evaluate_case (list access i) (c i)) + inner_test (inner_test__inner_body_func 0) + inner_body_func (inner_test__inner_body_func 1) + ) + (recurse (append tests (list inner_test)) + (expand (lambda (b) (body_func (inner_body_func b))) 'body_func 'inner_body_func) + (+ i 1)))))) + (recurse tests (lambda (b) b) 0)) + ) tests__body_func)) + (true (list (list = access c) (lambda (b) b))) + )) + +(define (my-match-helper x_sym cases i) (cond ((< i (- (length cases) 1)) (let (test__body_func (evaluate_case x_sym (cases i))) + (append (list (list (test__body_func 0) ((test__body_func 1) (cases (+ i 1))))) (my-match-helper x_sym cases (+ i 2))))) + (true '((true ("none matched")))))) + +(macro (my-match X) X) +(constant 'my-match (lambda-macro (X) (expand (list let (list '__MATCH_SYM 'X) (cons cond (my-match-helper '__MATCH_SYM (args) 0))) 'X))) +;(define-macro (my-match x) (eval (list let (list '__MATCH_SYM x) (cons cond (my-match-helper '__MATCH_SYM (args) 0))))) +;(define-macro (my-match x) (list let (list '__MATCH_SYM x) (cons cond (my-match-helper '__MATCH_SYM (args) 0)))) + +;(println "Hodwy!") +;(define myvar1 (list 'ASDF 1 2 3)) +;(define myvar myvar1) +;(define searche (list 'ASDF 1 2 3)) +;(println "match result " (my-match searche +; 1 2 +; (1 a) (string "list!" a) +; (unquote myvar) (list searche "oooh fancy" searche) +; 'a "haha" +; 2 3)) +;(println "blacken test " (my-match (list 'R 1 2 3) +; (unquote myvar) "oooh fancy" +; (c a x b) (list 'B c a x b) +; t t)) +;(println "done") + +(define empty (list 'B nil nil nil)) +(define E empty) +(define EE (list 'BB nil nil nil)) + +(define (map-foldl f z t) (my-match t + (unquote E) z + + (c a x b) (letn (new_left_result (map-foldl f z a) + folded (f new_left_result x) + ) (map-foldl f folded b)))) + ;(c a x b) (map-foldl f (f (map-foldl f z a) x) b))) + +(define (blacken t) (my-match t + ('R a x b) (list 'B a x b) + t t)) +(define (balance t) (my-match t + ; figures 1 and 2 + ('B ('R ('R a x b) y c) z d) (list 'R (list 'B a x b) y (list 'B c z d)) + ('B ('R a x ('R b y c)) z d) (list 'R (list 'B a x b) y (list 'B c z d)) + ('B a x ('R ('R b y c) z d)) (list 'R (list 'B a x b) y (list 'B c z d)) + ('B a x ('R b y ('R c z d))) (list 'R (list 'B a x b) y (list 'B c z d)) + ; figure 8, double black cases + ('BB ('R a x ('R b y c)) z d) (list 'B (list 'B a x b) y (list 'B c z d)) + ('BB a x ('R ('R b y c) z d)) (list 'B (list 'B a x b) y (list 'B c z d)) + ; already balenced + t t)) + +(define (map-insert-helper t k v) (my-match t + (unquote E) (list 'R t (list k v) t) + (c a x b) (cond ((< k (x 0)) (balance (list c (map-insert-helper a k v) x b))) + ((= k (x 0)) (list c a (list k v) b)) + (true (balance (list c a x (map-insert-helper b k v))))))) +(define (map-insert t k v) (blacken (map-insert-helper t k v))) + +(define map-empty empty) + +(define (make-test-tree n t) (cond ((<= n 0) t) + (true (make-test-tree (- n 1) (map-insert t n (= 0 (% n 10))))))) +(define (reduce-test-tree t) (map-foldl (lambda (a x) (if (x 1) (+ a 1) a)) 0 t)) + + +(println (reduce-test-tree (make-test-tree (integer (main-args 2)) map-empty))) + +(exit) diff --git a/koka_bench/newlisp/newlisp-slow-fexpr-rbtree.nl b/koka_bench/newlisp/newlisp-slow-fexpr-rbtree.nl new file mode 100755 index 0000000..ba3422f --- /dev/null +++ b/koka_bench/newlisp/newlisp-slow-fexpr-rbtree.nl @@ -0,0 +1,97 @@ +#!/usr/bin/env newlisp + +(define cont list) +(define cont? list?) +;(define cont (lambda (l) (array (length l) l))) +;(define cont? array?) + +; Sigh, newLisp doesn't seem to be expand 'a to (quote a) so we can't look for it, and +; it doesn't support unquoting or splice-unquoting at all. As a hack, we instead +; do some string manipulation on symbols starting with the special characters ~ or @ + +; OH WAIT NO WE DON'T +; we just write it out explicitly +; ugly, but fair + +(define (evaluate_case access c) (cond + ((and (list? c) (= 2 (length c)) (= 'unquote (c 0))) (list (list = access (c 1)) (lambda (b) b))) + ((symbol? c) (list true (expand (lambda (b) (list let (list 'c 'access) b)) 'c 'access))) + ((list? c) (letn ( + tests (list and (list list? access) (list = (length c) (list length access))) + tests__body_func (local (recurse) (setq recurse (lambda (tests body_func i) (if (= i (length c)) + (list tests body_func) + (letn ( inner_test__inner_body_func (evaluate_case (list access i) (c i)) + inner_test (inner_test__inner_body_func 0) + inner_body_func (inner_test__inner_body_func 1) + ) + (recurse (append tests (list inner_test)) + (expand (lambda (b) (body_func (inner_body_func b))) 'body_func 'inner_body_func) + (+ i 1)))))) + (recurse tests (lambda (b) b) 0)) + ) tests__body_func)) + (true (list (list = access c) (lambda (b) b))) + )) + +(define (my-match-helper x_sym cases i) (cond ((< i (- (length cases) 1)) (let (test__body_func (evaluate_case x_sym (cases i))) + (append (list (list (test__body_func 0) ((test__body_func 1) (cases (+ i 1))))) (my-match-helper x_sym cases (+ i 2))))) + (true '((true ("none matched")))))) +(define-macro (my-match x) (eval (list let (list '__MATCH_SYM x) (cons cond (my-match-helper '__MATCH_SYM (args) 0))))) +;(define-macro (my-match x) (list let (list '__MATCH_SYM x) (cons cond (my-match-helper '__MATCH_SYM (args) 0)))) + +;(println "Hodwy!") +;(define myvar 4) +;(println "match result " (my-match 4 +; 1 2 +; (1 2) "list!" +; 'a "haha" +; (unquote myvar) "oooh fancy" +; 2 3)) +;(println "blacken test " (my-match (list 'R 1 2 3) +; (c a x b) (list 'B c a x b) +; t t)) +;(println "done") + +(define empty (list 'B nil nil nil)) +(define E empty) +(define EE (list 'BB nil nil nil)) + +(define (map-foldl f z t) (my-match t + (unquote E) z + + (c a x b) (letn (new_left_result (map-foldl f z a) + folded (f new_left_result x) + ) (map-foldl f folded b)))) + ;(c a x b) (map-foldl f (f (map-foldl f z a) x) b))) + +(define (blacken t) (my-match t + ('R a x b) (list 'B a x b) + t t)) +(define (balance t) (my-match t + ; figures 1 and 2 + ('B ('R ('R a x b) y c) z d) (list 'R (list 'B a x b) y (list 'B c z d)) + ('B ('R a x ('R b y c)) z d) (list 'R (list 'B a x b) y (list 'B c z d)) + ('B a x ('R ('R b y c) z d)) (list 'R (list 'B a x b) y (list 'B c z d)) + ('B a x ('R b y ('R c z d))) (list 'R (list 'B a x b) y (list 'B c z d)) + ; figure 8, double black cases + ('BB ('R a x ('R b y c)) z d) (list 'B (list 'B a x b) y (list 'B c z d)) + ('BB a x ('R ('R b y c) z d)) (list 'B (list 'B a x b) y (list 'B c z d)) + ; already balenced + t t)) + +(define (map-insert-helper t k v) (my-match t + (unquote E) (list 'R t (list k v) t) + (c a x b) (cond ((< k (x 0)) (balance (list c (map-insert-helper a k v) x b))) + ((= k (x 0)) (list c a (list k v) b)) + (true (balance (list c a x (map-insert-helper b k v))))))) +(define (map-insert t k v) (blacken (map-insert-helper t k v))) + +(define map-empty empty) + +(define (make-test-tree n t) (cond ((<= n 0) t) + (true (make-test-tree (- n 1) (map-insert t n (= 0 (% n 10))))))) +(define (reduce-test-tree t) (map-foldl (lambda (a x) (if (x 1) (+ a 1) a)) 0 t)) + + +(println (reduce-test-tree (make-test-tree (integer (main-args 2)) map-empty))) + +(exit) diff --git a/koka_bench/test.sh b/koka_bench/test.sh index fceb09c..a81e3bd 100755 --- a/koka_bench/test.sh +++ b/koka_bench/test.sh @@ -15,29 +15,31 @@ popd mkdir -p slow find build -type f -name \*slow\* -exec mv {} slow \; cp ./build/kraken/out/bench/kraken-* ./slow +cp ./build/newlisp/out/bench/newlisp-macro-rbtree ./slow + nix develop -i -c bash -c 'ulimit -s unlimited && find build -type f -executable -name \*fib\* -printf "\"%p 30\"\n" | xargs hyperfine --ignore-failure --warmup 2 --export-markdown fib_table.md --export-csv fib_table.csv' -nix develop -i -c bash -c 'ulimit -s unlimited && find build -type f -executable -name \*nqueens\* -printf "\"%p 10\"\n" | xargs hyperfine --ignore-failure --warmup 2 --export-markdown nqueens_table.md --export-csv nqueens_table.csv' +#nix develop -i -c bash -c 'ulimit -s unlimited && find build -type f -executable -name \*nqueens\* -printf "\"%p 10\"\n" | xargs hyperfine --ignore-failure --warmup 2 --export-markdown nqueens_table.md --export-csv nqueens_table.csv' nix develop -i -c bash -c 'ulimit -s unlimited && find build -type f -executable -name \*rbtree\* -printf "\"%p 42000\"\n" | xargs hyperfine --ignore-failure --warmup 2 --export-markdown rbtree_table.md --export-csv rbtree_table.csv' -nix develop -i -c bash -c 'ulimit -s unlimited && find build -type f -executable -name \*cfold\* -printf "\"%p 5\"\n" | xargs hyperfine --ignore-failure --warmup 2 --export-markdown cfold_table.md --export-csv cfold_table.csv' -nix develop -i -c bash -c 'ulimit -s unlimited && find build -type f -executable -name \*deriv\* -printf "\"%p 8\"\n" | xargs hyperfine --ignore-failure --warmup 2 --export-markdown deriv_table.md --export-csv deriv_table.csv' +#nix develop -i -c bash -c 'ulimit -s unlimited && find build -type f -executable -name \*cfold\* -printf "\"%p 5\"\n" | xargs hyperfine --ignore-failure --warmup 2 --export-markdown cfold_table.md --export-csv cfold_table.csv' +#nix develop -i -c bash -c 'ulimit -s unlimited && find build -type f -executable -name \*deriv\* -printf "\"%p 8\"\n" | xargs hyperfine --ignore-failure --warmup 2 --export-markdown deriv_table.md --export-csv deriv_table.csv' -nix develop -i -c bash -c 'ulimit -s unlimited && find slow -type f -executable -name \*nqueens\* -printf "\"%p 7\"\n" | xargs hyperfine --ignore-failure --warmup 2 --export-markdown slow_nqueens_table.md --export-csv slow_nqueens_table.csv' -nix develop -i -c bash -c 'ulimit -s unlimited && find slow -type f -executable -name \*cfold\* -printf "\"%p 5\"\n" | xargs hyperfine --ignore-failure --warmup 2 --export-markdown slow_cfold_table.md --export-csv slow_cfold_table.csv' -nix develop -i -c bash -c 'ulimit -s unlimited && find slow -type f -executable -name \*deriv\* -printf "\"%p 3\"\n" | xargs hyperfine --ignore-failure --warmup 2 --export-markdown slow_deriv_table.md --export-csv slow_deriv_table.csv' -nix develop -i -c bash -c 'ulimit -s unlimited && find slow -type f -executable -name \*rbtree\* -printf "\"%p 100\"\n" | xargs hyperfine --ignore-failure --warmup 2 --export-markdown slow_rbtree_table.md --export-csv slow_rbtree_table.csv' -nix develop -i -c bash -c 'ulimit -s unlimited && find slow -type f -executable -name \*fib\* -printf "\"%p 30\"\n" | xargs hyperfine --ignore-failure --warmup 2 --export-markdown slow_fib_table.md --export-csv slow_fib_table.csv' +#nix develop -i -c bash -c 'ulimit -s unlimited && find slow -type f -executable -name \*nqueens\* -printf "\"%p 7\"\n" | xargs hyperfine --ignore-failure --warmup 2 --export-markdown slow_nqueens_table.md --export-csv slow_nqueens_table.csv' +#nix develop -i -c bash -c 'ulimit -s unlimited && find slow -type f -executable -name \*cfold\* -printf "\"%p 5\"\n" | xargs hyperfine --ignore-failure --warmup 2 --export-markdown slow_cfold_table.md --export-csv slow_cfold_table.csv' +#nix develop -i -c bash -c 'ulimit -s unlimited && find slow -type f -executable -name \*deriv\* -printf "\"%p 3\"\n" | xargs hyperfine --ignore-failure --warmup 2 --export-markdown slow_deriv_table.md --export-csv slow_deriv_table.csv' +nix develop -i -c bash -c 'ulimit -s unlimited && find slow -type f -executable -name \*rbtree\* -printf "\"%p 600\"\n" | xargs hyperfine --ignore-failure --warmup 2 --export-markdown slow_rbtree_table.md --export-csv slow_rbtree_table.csv' +#nix develop -i -c bash -c 'ulimit -s unlimited && find slow -type f -executable -name \*fib\* -printf "\"%p 30\"\n" | xargs hyperfine --ignore-failure --warmup 2 --export-markdown slow_fib_table.md --export-csv slow_fib_table.csv' for x in *_table.csv do ./relative.py $x done -printf "# Benchmarks\n\n" > benchmarks_table.md +printf "# Benchmarks\n\n" > benchmarks.md for x in *_table.md do - printf "## $x\n\n" >> benchmarks_table.md - cat "$x" >> benchmarks_table.md - printf "\n\n\n" >> benchmarks_table.md + printf "## $x\n\n" >> benchmarks.md + cat "$x" >> benchmarks.md + printf "\n\n\n" >> benchmarks.md done diff --git a/partial_eval.scm b/partial_eval.scm index 60f4b0d..92d92f8 100644 --- a/partial_eval.scm +++ b/partial_eval.scm @@ -4846,7 +4846,8 @@ (dlet ((r (get-list (idx used_map 0) s))) (mif r (idx r 1) (get_used_map (idx used_map 1) s)))) - (error "get bad s in used_map")))) + ; we treat not-found as true, as it must be inside an env, and persistent env's are cached and "used" till the end of the scope + true))) (combine_used_maps (rec-lambda combine_used_maps (a b) (cond ((not a) b) ((not b) a) ((or (= true (idx a 0)) @@ -4856,7 +4857,9 @@ (idx a 0) (idx b 0)) (combine_used_maps (idx a 1) (idx b 1))))))) - (pseudo_perceus (rec-lambda pseudo_perceus (c env_id knot_memo used_map_after) (cond + (pseudo_perceus (rec-lambda pseudo_perceus (c env_id knot_memo used_map_after) (dlet ( + ;(_ (true_print "pseudo_perceus " (true_str_strip c) " " used_map_after)) + ) (cond ((val? c) (array used_map_after (array used_map_after))) ((prim_comb? c) (array used_map_after (array used_map_after))) ((and (marked_symbol? c) (.marked_symbol_is_val c)) (array used_map_after (array used_map_after))) @@ -4963,7 +4966,7 @@ ; fallthrough (true (array (error "Shouldn't happen, missing case for pseudo_perceus: " (true_str_strip c)))) - ))) + )))) (cached_pseudo_perceus_idx (lambda (c env_id cache i) (dlet ( ;(_ (true_print "doing cached-pseudo-perceus-idx for " (true_str_strip c))) (_ (true_print "doing cached-pseudo-perceus-idx i " i))