miloignis/kraken
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

clean up compile more, going straight to pulling out of memo, removing compile-body-part, removing now-unecessary recursion checking (for ping-pong between partial-eval and compile-inner because of how we now check memo and normalize), and finally add all tests to new_test.sh

Browse Source
This commit is contained in:
Nathan Braswell
2023-01-25 02:22:10 -05:00
parent 7f9f419a23
commit c20ba09179
2 changed files with 101 additions and 105 deletions
Download Patch File Download Diff File Expand all files Collapse all files

40
koka_bench/new_test.sh
View File

@@ -15,22 +15,52 @@ pushd "$SCRIPT_DIR"
echo "Inside flake, running!" echo "Inside flake, running!"
fi fi
ITERS=420000
rm -rf build || true rm -rf build || true
mkdir build mkdir build
pushd build pushd build
# workaround thanks to https://github.com/NixOS/nixpkgs/issues/139943 # workaround thanks to https://github.com/NixOS/nixpkgs/issues/139943
cp -r "$(dirname $(dirname $(which emcc)))/share/emscripten/cache" ./emcache cp -r "$(dirname $(dirname $(which emcc)))/share/emscripten/cache" ./emcache
chmod u+rwX -R emcache chmod u+rwX -R emcache
export EM_CACHE="$(pwd)/emcache" export EM_CACHE="$(pwd)/emcache"
#no_compile
#no_lazy_env
#no_y_comb
#no_prim_inline
#no_closure_inline
echo "RB-Tree"
ITERS=420000
scheme --script ../../partial_eval.scm ../kraken/rbtree-opt.kp && mv csc_out.wasm kraken-rbtree-opt.wasm scheme --script ../../partial_eval.scm ../kraken/rbtree-opt.kp && mv csc_out.wasm kraken-rbtree-opt.wasm
koka --target=wasm -v -O2 ../koka/rbtree.kk && mv ./.koka/v*/emcc-wasm32-drelease/koka_rbtree.wasm ./ koka --target=wasm -v -O2 ../koka/rbtree.kk && mv ./.koka/v*/emcc-wasm32-drelease/koka_rbtree.wasm ./
koka --target=c -v -O2 ../koka/rbtree.kk && mv ./.koka/v*/cc-drelease/koka_rbtree ./ #koka --target=c -v -O2 ../koka/rbtree.kk && mv ./.koka/v*/cc-drelease/koka_rbtree ./
hyperfine --warmup 2 "./koka_rbtree $ITERS" "wasmtime ./koka_rbtree.wasm $ITERS" "wasmtime ./kraken-rbtree-opt.wasm $ITERS" hyperfine --warmup 2 "wasmtime ./koka_rbtree.wasm $ITERS" "wasmtime ./kraken-rbtree-opt.wasm $ITERS" --export-markdown rbtree_table.md --export-csv rbtree_table.csv
echo "Fib"
ITERS=40
scheme --script ../../partial_eval.scm ../kraken/fib.kp && mv csc_out.wasm kraken-fib.wasm
koka --target=wasm -v -O2 ../koka/fib.kk && mv ./.koka/v*/emcc-wasm32-drelease/koka_fib.wasm ./
hyperfine --warmup 2 "wasmtime ./koka_fib.wasm $ITERS" "wasmtime ./kraken-fib.wasm $ITERS" --export-markdown fib_table.md --export-csv fib_table.csv
echo "CFold"
ITERS=9
scheme --script ../../partial_eval.scm ../kraken/cfold.kp && mv csc_out.wasm kraken-cfold.wasm
koka --target=wasm -v -O2 ../koka/cfold.kk && mv ./.koka/v*/emcc-wasm32-drelease/koka_cfold.wasm ./
hyperfine --warmup 2 "wasmtime ./koka_cfold.wasm $ITERS" "wasmtime ./kraken-cfold.wasm $ITERS" --export-markdown cfold_table.md --export-csv cfold_table.csv
echo "N-Queens"
ITERS=10
scheme --script ../../partial_eval.scm ../kraken/nqueens.kp && mv csc_out.wasm kraken-nqueens.wasm
koka --target=wasm -v -O2 ../koka/nqueens.kk && mv ./.koka/v*/emcc-wasm32-drelease/koka_nqueens.wasm ./
hyperfine --warmup 2 "wasmtime ./koka_nqueens.wasm $ITERS" "wasmtime ./kraken-nqueens.wasm $ITERS" --export-markdown nqueens_table.md --export-csv nqueens_table.csv
echo "Deriv"
ITERS=9
scheme --script ../../partial_eval.scm ../kraken/deriv.kp && mv csc_out.wasm kraken-deriv.wasm
koka --target=wasm -v -O2 ../koka/deriv.kk && mv ./.koka/v*/emcc-wasm32-drelease/koka_deriv.wasm ./
hyperfine --warmup 2 "wasmtime ./koka_deriv.wasm $ITERS" "wasmtime ./kraken-deriv.wasm $ITERS" --export-markdown deriv_table.md --export-csv deriv_table.csv
popd popd
popd popd

116
partial_eval.scm
View File

@@ -4646,23 +4646,6 @@
((comb? c) (dlet ( ((comb? c) (dlet (
((wrap_level env_id de? se variadic params body) (.comb c)) ((wrap_level env_id de? se variadic params body) (.comb c))
(_ (mif (> wrap_level 1) (error "wrap level TOO DARN HIGH"))) (_ (mif (> wrap_level 1) (error "wrap level TOO DARN HIGH")))
(attempt_reduction (and
(not dont_y_comb)
variadic
(= 1 (len params))
(marked_array? body)
(= 4 (len (.marked_array_values body)))
(prim_comb? (idx (.marked_array_values body) 0))
(= 'lapply (.prim_comb_sym (idx (.marked_array_values body) 0)))
(marked_symbol? (idx (.marked_array_values body) 2))
(not (.marked_symbol_is_val (idx (.marked_array_values body) 2)))
(= (idx params 0) (.marked_symbol_value (idx (.marked_array_values body) 2)))
(marked_symbol? (idx (.marked_array_values body) 3))
(not (.marked_symbol_is_val (idx (.marked_array_values body) 3)))
(= de? (.marked_symbol_value (idx (.marked_array_values body) 3)))
))
; new tce data
; new env_id
) nil) ) nil)
((prim_comb? c) nil) ((prim_comb? c) nil)
@@ -4681,12 +4664,10 @@
(and (not dont_y_comb) (!= nil (.marked_array_this_rec_stop c)) (get_passthrough (idx (.marked_array_this_rec_stop c) 0) ctx)) (and (not dont_y_comb) (!= nil (.marked_array_this_rec_stop c)) (get_passthrough (idx (.marked_array_this_rec_stop c) 0) ctx))
(hit_recursion (= 'RECURSE_FAIL (get-value-or-false memo (.hash c))))
((ok x) (try_unval x (lambda (_) nil))) ((ok x) (try_unval x (lambda (_) nil)))
(err (if (not ok) "couldn't unval in compile" err)) (err (if (not ok) "couldn't unval in compile" err))
((pectx e pex) (cond ((!= nil err) (array pectx err nil)) ((pectx e pex) (cond ((!= nil err) (array pectx err nil))
(hit_recursion (array pectx "blockrecursion" nil))
(true (partial_eval_helper x false env (array nil nil) pectx 1 false)))) (true (partial_eval_helper x false env (array nil nil) pectx 1 false))))
((tce_idx tce_full_params) (mif tce_data tce_data (array nil nil))) ((tce_idx tce_full_params) (mif tce_data tce_data (array nil nil)))
@@ -5241,7 +5222,6 @@
; shape in that case which will cause compile to keep stepping. ; shape in that case which will cause compile to keep stepping.
((datasi funcs memo env pectx inline_locals) ctx) ((datasi funcs memo env pectx inline_locals) ctx)
(hit_recursion (= 'RECURSE_FAIL (get-value-or-false memo (.hash c))))
(func_param_values (.marked_array_values c)) (func_param_values (.marked_array_values c))
(num_params (- (len func_param_values) 1)) (num_params (- (len func_param_values) 1))
@@ -5269,7 +5249,6 @@
(err (if (not ok) "couldn't unval in compile" err)) (err (if (not ok) "couldn't unval in compile" err))
((pectx e pex) (cond ((!= nil err) (array pectx err nil)) ((pectx e pex) (cond ((!= nil err) (array pectx err nil))
(hit_recursion (array pectx "blockrecursion" nil))
(true (partial_eval_helper x false env (array nil nil) pectx 1 false)))) (true (partial_eval_helper x false env (array nil nil) pectx 1 false))))
(ctx (array datasi funcs memo env pectx inline_locals)) (ctx (array datasi funcs memo env pectx inline_locals))
@@ -5812,7 +5791,7 @@
; and so we can only tell here weather or not it will be safe to remove the level of lazyness (because we get a func value back instead of code) ; and so we can only tell here weather or not it will be safe to remove the level of lazyness (because we get a func value back instead of code)
; and perform the eta reduction. ; and perform the eta reduction.
(attempt_reduction (and ) (mif (and
(not dont_y_comb) (not dont_y_comb)
variadic variadic
(= 1 (len params)) (= 1 (len params))
@@ -5820,22 +5799,46 @@
(= 4 (len (.marked_array_values body))) (= 4 (len (.marked_array_values body)))
(prim_comb? (idx (.marked_array_values body) 0)) (prim_comb? (idx (.marked_array_values body) 0))
(= 'lapply (.prim_comb_sym (idx (.marked_array_values body) 0))) (= 'lapply (.prim_comb_sym (idx (.marked_array_values body) 0)))
(int? (get-value-or-false memo (.hash (idx (.marked_array_values body) 1))))
; since we partial eval before now, instead of checking for the rec hash stopped thing itself, we use normal memo to tie the knot
; Check to see if it even needs it now
(get-value-or-false memo (.hash (idx (.marked_array_values body) 1)))
(marked_symbol? (idx (.marked_array_values body) 2)) (marked_symbol? (idx (.marked_array_values body) 2))
(not (.marked_symbol_is_val (idx (.marked_array_values body) 2))) (not (.marked_symbol_is_val (idx (.marked_array_values body) 2)))
(= (idx params 0) (.marked_symbol_value (idx (.marked_array_values body) 2))) (= (idx params 0) (.marked_symbol_value (idx (.marked_array_values body) 2)))
(marked_symbol? (idx (.marked_array_values body) 3)) (marked_symbol? (idx (.marked_array_values body) 3))
(not (.marked_symbol_is_val (idx (.marked_array_values body) 3))) (not (.marked_symbol_is_val (idx (.marked_array_values body) 3)))
(= de? (.marked_symbol_value (idx (.marked_array_values body) 3))) (= de? (.marked_symbol_value (idx (.marked_array_values body) 3)))
)) )
(array (set_wrap_val wrap_level (get-value-or-false memo (.hash (idx (.marked_array_values body) 1)))) nil err ctx)
(dlet (
(full_params (concat params (mif de? (array de?) (array)))) (full_params (concat params (mif de? (array de?) (array))))
(normal_params_length (if variadic (- (len params) 1) (len params))) (normal_params_length (if variadic (- (len params) 1) (len params)))
(compile_body_part (lambda (ctx body_part new_tce_data) (dlet (
((env_val env_code env_err ctx) (if (and need_value (not (marked_env_real? se)))
(array nil nil "Env wasn't real when compiling comb, but need value" ctx)
(compile-inner ctx se need_value inside_veval outer_s_env_access_code s_env_access_code inline_level nil analysis_nil)))
(_ (if (not (or (= nil env_val) (int? env_val))) (error "BADBADBADenv_val")))
(maybe_func (get_passthrough (.hash c) ctx))
((func_value _ func_err ctx) (mif maybe_func maybe_func
(dlet (
((datasi funcs memo env pectx outer_inline_locals) ctx)
(old_funcs funcs)
(funcs (concat funcs (array nil)))
(our_wrap_func_idx (+ (len funcs) func_id_dynamic_ofset))
(funcs (concat funcs (array nil)))
(our_func_idx (+ (len funcs) func_id_dynamic_ofset))
(calculate_func_val (lambda (wrap) (mk_comb_val_nil_env our_func_idx (mif de? 1 0) wrap)))
(func_value (calculate_func_val wrap_level))
; if variadic, we just use the wrapper func and don't expect callers to know that we're varidic
(func_value (mif variadic (mod_fval_to_wrap func_value) func_value))
(memo (put memo (.hash c) func_value))
(new_inline_locals (array))
(ctx (array datasi funcs memo env pectx new_inline_locals))
(new_tce_data (array our_func_idx full_params))
(inner_env (make_tmp_inner_env params de? se env_id)) (inner_env (make_tmp_inner_env params de? se env_id))
((params_vec _ _ ctx) (compile-inner ctx (marked_array true false nil (map (lambda (k) (marked_symbol nil k)) full_params) nil) true false outer_s_env_access_code s_env_access_code 0 nil analysis_nil)) ((params_vec _ _ ctx) (compile-inner ctx (marked_array true false nil (map (lambda (k) (marked_symbol nil k)) full_params) nil) true false outer_s_env_access_code s_env_access_code 0 nil analysis_nil))
@@ -5861,62 +5864,25 @@
((datasi funcs memo env pectx inline_locals) ctx) ((datasi funcs memo env pectx inline_locals) ctx)
(inner_ctx (array datasi funcs memo inner_env pectx inline_locals)) (inner_ctx (array datasi funcs memo inner_env pectx inline_locals))
;------------- ;-------------
(_ (true_print "Doing call-info" full_params)) ;(_ (true_print "Doing call-info" full_params))
;(call_info (call-info c env_id)) ;(call_info (call-info c env_id))
;------------- ;-------------
(_ (true_print "Doing infer_types for body part for " full_params)) (_ (true_print "Doing infer_types for body part for " full_params))
(inner_type_data (infer_types body_part (.marked_env_idx inner_env) empty_dict-list empty_dict-list)) (inner_type_data (infer_types body (.marked_env_idx inner_env) empty_dict-list empty_dict-list))
(_ (true_print "done infer_types, Doing pseudo perceus " full_params)) (_ (true_print "done infer_types, Doing pseudo perceus " full_params))
((used_map_before used_map_sub_data) (pseudo_perceus body_part (.marked_env_idx inner_env) memo (push_used_map empty_use_map full_params))) ((used_map_before used_map_sub_data) (pseudo_perceus body (.marked_env_idx inner_env) memo (push_used_map empty_use_map full_params)))
(_ (true_print "done pseudo_perceus, Doing borrow? " full_params)) (_ (true_print "done pseudo_perceus, Doing borrow? " full_params))
((borrowed borrow_sub_data) (borrow? body_part false (.marked_env_idx inner_env) used_map_sub_data)) ((borrowed borrow_sub_data) (borrow? body false (.marked_env_idx inner_env) used_map_sub_data))
(_ (mif borrowed (error "body hast to be borrowed? " borrowed " " (true_str_strip body_part)))) (_ (mif borrowed (error "body hast to be borrowed? " borrowed " " (true_str_strip body))))
(_ (true_print "done pseudo_perceus, Doing compile_body_part func def compile-inner " full_params)) (_ (true_print "done pseudo_perceus, Doing compile_body func def compile-inner " full_params))
(inner_analysis_data (array inner_type_data used_map_sub_data)) (inner_analysis_data (array inner_type_data used_map_sub_data))
((inner_value inner_code err ctx) (compile-inner inner_ctx body_part false false (local.get '$outer_s_env) new_get_s_env_code 0 new_tce_data inner_analysis_data)) ((inner_value inner_code err ctx) (compile-inner inner_ctx body false false (local.get '$outer_s_env) new_get_s_env_code 0 new_tce_data inner_analysis_data))
(_ (true_print "Done compile_body_part func def compile-inner " full_params)) (_ (true_print "Done compile_body func def compile-inner " full_params))
; Don't overwrite env with what was our inner env! Env is returned as part of context to our caller! ; Don't overwrite env with what was our inner env! Env is returned as part of context to our caller!
((datasi funcs memo _was_inner_env pectx inline_locals) ctx) ((datasi funcs memo _was_inner_env pectx inline_locals) ctx)
) (array inner_value inner_code err (array datasi funcs memo env pectx inline_locals) generate_get_s_env_code)))) (ctx (array datasi funcs memo env pectx inline_locals))
((early_quit err ctx) (mif attempt_reduction
(dlet (
(_ (true_print "Attempting reduction!"))
((inner_value inner_code err ctx generate_get_s_env_code) (compile_body_part ctx (idx (.marked_array_values body) 1) nil))
; set it's wrap level to our wrap level
(inner_value (mif inner_value (set_wrap_val wrap_level inner_value)))
) (array inner_value err ctx))
(array nil nil ctx)))
) (mif (and (!= nil early_quit) (= nil err)) (array ;(mod_fval_to_wrap early_quit)
early_quit
nil nil ctx)
(dlet (
((env_val env_code env_err ctx) (if (and need_value (not (marked_env_real? se)))
(array nil nil "Env wasn't real when compiling comb, but need value" ctx)
(compile-inner ctx se need_value inside_veval outer_s_env_access_code s_env_access_code inline_level nil analysis_nil)))
(_ (if (not (or (= nil env_val) (int? env_val))) (error "BADBADBADenv_val")))
(maybe_func (get_passthrough (.hash c) ctx))
((func_value _ func_err ctx) (mif maybe_func maybe_func
(dlet (
((datasi funcs memo env pectx outer_inline_locals) ctx)
(old_funcs funcs)
(funcs (concat funcs (array nil)))
(our_wrap_func_idx (+ (len funcs) func_id_dynamic_ofset))
(funcs (concat funcs (array nil)))
(our_func_idx (+ (len funcs) func_id_dynamic_ofset))
(calculate_func_val (lambda (wrap) (mk_comb_val_nil_env our_func_idx (mif de? 1 0) wrap)))
(func_value (calculate_func_val wrap_level))
; if variadic, we just use the wrapper func and don't expect callers to know that we're varidic
(func_value (mif variadic (mod_fval_to_wrap func_value) func_value))
(memo (put memo (.hash c) func_value))
(new_inline_locals (array))
(ctx (array datasi funcs memo env pectx new_inline_locals))
((inner_value inner_code err ctx generate_get_s_env_code) (compile_body_part ctx body (array our_func_idx full_params)))
(inner_code (mif inner_value (i64.const (mod_fval_to_wrap inner_value)) inner_code)) (inner_code (mif inner_value (i64.const (mod_fval_to_wrap inner_value)) inner_code))
(wrapper_func (func '$wrapper_func '(param $params i64) '(param $d_env i64) '(param $outer_s_env i64) '(result i64) '(local $param_ptr i32) '(local $rc_bytes i64) '(local $rc_ptr i32) '(local $rc_tmp i32) (wrapper_func (func '$wrapper_func '(param $params i64) '(param $d_env i64) '(param $outer_s_env i64) '(result i64) '(local $param_ptr i32) '(local $rc_bytes i64) '(local $rc_ptr i32) '(local $rc_tmp i32)
(_if '$params_len_good (_if '$params_len_good