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!
This commit is contained in:
Nathan Braswell
@@ -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"
|
||||
|
||||
@@ -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)
|
||||
|
||||
12
koka_bench/newlisp/newlisp-builtin-rbtree.nl
Executable file
12
koka_bench/newlisp/newlisp-builtin-rbtree.nl
Executable file
@@ -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)
|
||||
103
koka_bench/newlisp/newlisp-macro-rbtree.nl
Executable file
103
koka_bench/newlisp/newlisp-macro-rbtree.nl
Executable file
@@ -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)
|
||||
97
koka_bench/newlisp/newlisp-slow-fexpr-rbtree.nl
Executable file
97
koka_bench/newlisp/newlisp-slow-fexpr-rbtree.nl
Executable file
@@ -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)
|
||||
@@ -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
|
||||
|
||||
@@ -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))
|
||||
|
||||
Reference in New Issue
Block a user