From 8638086480b367f84a23badb033b601a409583a5 Mon Sep 17 00:00:00 2001 From: Nathan Braswell Date: Thu, 10 Nov 2022 02:10:56 -0500 Subject: [PATCH] Added ability to turn off 4 major optimizations, integrated into benchmarks now focused only on Kraken (and NewLisp) --- koka_bench/CMakeLists.txt | 12 +-- koka_bench/kraken/rbtree-opt.kp | 5 +- koka_bench/kraken/rbtree.kp | 3 +- koka_bench/kraken_wrapper.sh | 32 +++---- koka_bench/relative.py | 9 +- koka_bench/test.sh | 28 +++--- partial_eval.scm | 148 +++++++++++++++++++------------- 7 files changed, 143 insertions(+), 94 deletions(-) diff --git a/koka_bench/CMakeLists.txt b/koka_bench/CMakeLists.txt index abd6ae7..7567401 100644 --- a/koka_bench/CMakeLists.txt +++ b/koka_bench/CMakeLists.txt @@ -9,12 +9,12 @@ endif () enable_testing() add_subdirectory(kraken) -add_subdirectory(koka) -add_subdirectory(cpp) -add_subdirectory(haskell) -add_subdirectory(java) -add_subdirectory(ocaml) -add_subdirectory(swift) +#add_subdirectory(koka) +#add_subdirectory(cpp) +#add_subdirectory(haskell) +#add_subdirectory(java) +#add_subdirectory(ocaml) +#add_subdirectory(swift) add_subdirectory(python) add_subdirectory(scheme) diff --git a/koka_bench/kraken/rbtree-opt.kp b/koka_bench/kraken/rbtree-opt.kp index 6a44fd4..6ee8068 100644 --- a/koka_bench/kraken/rbtree-opt.kp +++ b/koka_bench/kraken/rbtree-opt.kp @@ -206,7 +206,10 @@ monad (array 'write 1 (str "running tree test") (vau (written code) (array 'args (vau (args code) - (array 'exit (log (reduce-test-tree (make-test-tree (read-string (idx args 1)) map-empty)))) + ;(array 'exit (log (reduce-test-tree (make-test-tree (read-string (idx args 1)) map-empty)))) + + (array 'exit (let (a (log (reduce-test-tree (make-test-tree (read-string (idx args 1)) map-empty)))) 0)) + ;(array 'exit (log (let (t (make-test-tree (read-string (idx args 1)) map-empty) ; _ (log "swapping to reduce") ; ) (reduce-test-tree t)))) diff --git a/koka_bench/kraken/rbtree.kp b/koka_bench/kraken/rbtree.kp index 33808e1..b570383 100644 --- a/koka_bench/kraken/rbtree.kp +++ b/koka_bench/kraken/rbtree.kp @@ -296,7 +296,8 @@ monad (array 'write 1 (str "running tree test") (vau (written code) (array 'args (vau (args code) - (array 'exit (log (reduce-test-tree (make-test-tree (read-string (idx args 1)) map-empty)))) + ;(array 'exit (log (reduce-test-tree (make-test-tree (read-string (idx args 1)) map-empty)))) + (array 'exit (let (a (log (reduce-test-tree (make-test-tree (read-string (idx args 1)) map-empty)))) 0)) )) )) diff --git a/koka_bench/kraken_wrapper.sh b/koka_bench/kraken_wrapper.sh index 9334f60..aaf0eba 100755 --- a/koka_bench/kraken_wrapper.sh +++ b/koka_bench/kraken_wrapper.sh @@ -4,20 +4,22 @@ SOURCE="$1" OUT_DIR="$2" OUT_NAME="$3" -scheme --script "$OUR_DIR/../partial_eval.scm" $SOURCE -mkdir -p "$OUT_DIR" -mv ./csc_out.wasm "$OUT_DIR/$OUT_NAME.wasm" -printf '#!/usr/bin/env bash\nwasmtime "$(dirname $(readlink -f $0))/'"$OUT_NAME"'.wasm" $@' > "$OUT_DIR/$OUT_NAME" -chmod 755 "$OUT_DIR/$OUT_NAME" +doit() { + TAG=$1 + OPTION=$2 + scheme --script "$OUR_DIR/../partial_eval.scm" $SOURCE $OPTION + mkdir -p "$OUT_DIR" + mv ./csc_out.wasm "$OUT_DIR/$OUT_NAME$TAG.wasm" + printf '#!/usr/bin/env bash\nwasmtime "$(dirname $(readlink -f $0))/'"$OUT_NAME$TAG"'.wasm" $@' > "$OUT_DIR/$OUT_NAME$TAG" + chmod 755 "$OUT_DIR/$OUT_NAME$TAG" -printf '#!/usr/bin/env bash\nWAVM_OBJECT_CACHE_DIR=$(pwd) wavm run "$(dirname $(readlink -f $0))/'"$OUT_NAME"'.wasm" $@' > "$OUT_DIR/$OUT_NAME-wavm" -chmod 755 "$OUT_DIR/$OUT_NAME-wavm" + printf '#!/usr/bin/env bash\nWAVM_OBJECT_CACHE_DIR=$(pwd) wavm run "$(dirname $(readlink -f $0))/'"$OUT_NAME$TAG"'.wasm" $@' > "$OUT_DIR/$OUT_NAME$TAG-wavm" + chmod 755 "$OUT_DIR/$OUT_NAME$TAG-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\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" +doit "-n" "" +doit -slow no_compile +doit -no_lazy_env no_lazy_env +doit -no_y_comb no_y_comb +doit -no_prim_inline no_prim_inline +doit -no_closure_inline no_closure_inline diff --git a/koka_bench/relative.py b/koka_bench/relative.py index 6482401..bc8cad4 100755 --- a/koka_bench/relative.py +++ b/koka_bench/relative.py @@ -65,10 +65,13 @@ for do_log in [False, True]: plt.legend() plt.tight_layout() - plt.xticks(rotation = 45) + #plt.xticks(rotation = 45) + plt.xticks(rotation = 90) if do_log: - plt.subplots_adjust(left=0.10) + #plt.subplots_adjust(left=0.10) + plt.subplots_adjust(left=0.15) plt.semilogy() - plt.subplots_adjust(bottom=0.32) + #plt.subplots_adjust(bottom=0.32) + plt.subplots_adjust(bottom=0.65) plt.savefig(f"{sys.argv[1]}_{'log' if do_log else ''}.png", dpi = 96 * 2 * 2) #plt.show() diff --git a/koka_bench/test.sh b/koka_bench/test.sh index b403e4c..4bd8596 100755 --- a/koka_bench/test.sh +++ b/koka_bench/test.sh @@ -14,24 +14,30 @@ popd mkdir -p slow find build -type f -name \*slow\* -exec mv {} slow \; -cp ./build/kraken/out/bench/kraken-* ./slow -mv ./build/kraken/out/bench/kraken-cfold ./slow -mv ./build/newlisp/out/bench/* ./slow +cp ./slow/newlisp-slow-fexpr-rbtree ./build/newlisp/out/bench/ +#cp ./build/kraken/out/bench/kraken-* ./slow +cp ./build/kraken/out/bench/kraken-*-n* ./slow +mv ./build/kraken/out/bench/kraken-cfold-n ./slow +#mv ./build/newlisp/out/bench/* ./slow +nix develop -i -c bash -c 'ulimit -s unlimited && find build -type f -executable -name \*rbtree\* -printf "\"%p 880\"\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 \*rbtree\* -printf "\"%p 420000\"\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 \*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 \*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 8\"\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 \*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 \*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 7\"\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 \*cfold\* -printf "\"%p 20\"\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 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 \*rbtree\* -printf "\"%p 10\"\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 \*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 \*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 \*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 \*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 && hyperfine --ignore-failure --warmup 2 --export-markdown slow_ish_rbtree_table.md --export-csv slow_ish_rbtree_table.csv "./slow/kraken-rbtree-opt 890" "./slow/kraken-rbtree-opt-wavm 890" "./slow/newlisp-slow-fexpr-rbtree 890" "./slow/newlisp-macro-rbtree 890"' #nix develop -i -c bash -c 'ulimit -s unlimited && hyperfine --ignore-failure --warmup 2 --export-markdown slow_rbtree_table.md --export-csv slow_rbtree_table.csv "./slow/kraken-rbtree-opt 100" "./slow/kraken-rbtree-opt-wavm 100" "./slow/newlisp-slow-fexpr-rbtree 100" "./slow/newlisp-macro-rbtree 100" "./slow/kraken-rbtree-slow-wavm 100"' @@ -47,3 +53,5 @@ do cat "$x" >> benchmarks.md printf "\n\n\n" >> benchmarks.md done +cp *.png ~/school/vau_partial_eval_paper/images/ +cp *.cssv ~/school/vau_partial_eval_paper/ diff --git a/partial_eval.scm b/partial_eval.scm index 177b59a..c3f66bb 100644 --- a/partial_eval.scm +++ b/partial_eval.scm @@ -1823,7 +1823,12 @@ (nil_val array_tag) ; automatically 0 ptr, 0 size, 0 ref-counted (emptystr_val string_tag); ^ ditto - (compile (dlambda ((pectx partial_eval_err marked_code) needs_runtime_eval) (mif partial_eval_err (error partial_eval_err) (wasm_to_binary (module + (compile (dlambda ((pectx partial_eval_err marked_code) needs_runtime_eval + dont_lazy_env + dont_y_comb + dont_prim_inline + dont_closure_inline) + (mif partial_eval_err (error partial_eval_err) (wasm_to_binary (module (import "wasi_unstable" "args_sizes_get" '(func $args_sizes_get (param i32 i32) (result i32))) @@ -4622,6 +4627,7 @@ ; ; the cache data structure is just what it returned. Sub-calls should pass in the extra data indexed appropriately (type_data_nil nil) + (analysis_nil nil) (get-list-or (lambda (d k o) (dlet ((x (get-list d k))) (mif x (idx x 1) o)))) @@ -4654,10 +4660,11 @@ ;(_ (true_print " which is " (idx total j))) ;(_ (true_print " combined currently is " combined)) (r (mif (= (idx combined 0) (idx (idx total j) 0)) - (mif (> i j ) (array) + (mif (> i j ) + (array) (array (array (idx combined 0) (mf (idx combined 1) (idx (idx total j) 1))))) - (array combined))) + (array combined))) ;(_ (true_print " r was " r)) ) r))) (array (idx total i)) @@ -4805,7 +4812,7 @@ ( r (mif cache (idx (idx cache 3) i) (infer_types (idx (.marked_array_values c) i) env_id empty_dict-list empty_dict-list))) ;(_ (true_print "done infer-types-idx")) ) r))) - (just_type (lambda (type_data) (idx type_data 0))) + (just_type (lambda (analysis_data) (idx (idx analysis_data 0) 0))) (word_value_type? (lambda (x) (or (= 'int (idx x 0)) (= 'bool (idx x 0)) (= 'sym (idx x 0))))) ; @@ -5051,6 +5058,9 @@ ;(_ (true_print " doing a borrow inline!")) (body (borrow? (.comb_body func) b (.comb_id func) (pseudo_perceus_just_inline_data used_map_sub_data))) ;(_ (true_print " did body!")) + ; TODO: + ; Check perceus to see if params are ever used, if not, get rid early + (param_subs (map (lambda (i) (borrow? (idx (.marked_array_values c) i) false env_id (pseudo_perceus_just_sub_idx used_map_sub_data i))) (range 1 (len (.marked_array_values c))))) ;(_ (true_print " did params")) ) (array (idx body 0) (cons body param_subs))) @@ -5062,8 +5072,17 @@ ;(_ (true_print "done borrow!")) ) r))) + (cached_analysis_idx (lambda (c env_id cache i) (dlet ( + ;(_ (true_print "doing infer-types-idx for " (true_str_strip c))) + ;(_ (true_print "doing infer-types-idx i " i)) + ;(_ (true_print "doing infer-types-idx with " cache)) + ;(_ (true_print "doing infer-types-idx, cache is real? " (mif cache true false))) + ( r (cached_infer_types_idx c env_id (mif cache (idx cache 0) type_data_nil) i)) + ;(_ (true_print "done infer-types-idx")) + ) (array r)))) - (compile-inner (rec-lambda compile-inner (ctx c need_value inside_veval outer_s_env_access_code s_env_access_code inline_level tce_data type_data used_data) (cond + + (compile-inner (rec-lambda compile-inner (ctx c need_value inside_veval outer_s_env_access_code s_env_access_code inline_level tce_data analysis_data) (cond ((val? c) (dlet ((v (.val c))) (cond ((int? v) (array (mk_int_value v) nil nil ctx)) ((= true v) (array true_val nil nil ctx)) @@ -5105,7 +5124,7 @@ ((marked_array? c) (if (.marked_array_is_val c) (or (get_passthrough (.hash c) ctx) (dlet ((actual_len (len (.marked_array_values c)))) (if (= 0 actual_len) (array nil_val nil nil ctx) - (dlet ( ((comp_values err ctx) (foldr (dlambda (x (a err ctx)) (dlet (((v c e ctx) (compile-inner ctx x need_value inside_veval outer_s_env_access_code s_env_access_code inline_level nil type_data_nil used_data_nil))) + (dlet ( ((comp_values err ctx) (foldr (dlambda (x (a err ctx)) (dlet (((v c e ctx) (compile-inner ctx x need_value inside_veval outer_s_env_access_code s_env_access_code inline_level nil analysis_nil))) (array (cons (mod_fval_to_wrap v) a) (or (mif err err false) (mif e e false) (mif c (str "got code " c) false)) ctx))) (array (array) nil ctx) (.marked_array_values c))) ) (mif err (array nil nil (str err ", from an array value compile " (str_strip c)) ctx) (dlet ( ((datasi funcs memo env pectx inline_locals) ctx) @@ -5116,7 +5135,7 @@ ; This is the other half of where we notice & tie up recursion based on partial eval's noted rec-stops ; Other half is below in comb compilation - (or (and (!= nil (.marked_array_this_rec_stop c)) (get_passthrough (idx (.marked_array_this_rec_stop c) 0) ctx)) + (or (and (not dont_y_comb) (!= nil (.marked_array_this_rec_stop c)) (get_passthrough (idx (.marked_array_this_rec_stop c) 0) ctx)) (if need_value (array nil nil (str "errr, needed value and was call " (str_strip c)) ctx) (if (= 0 (len (.marked_array_values c))) (array nil nil (str "errr, empty call array" (str_strip c)) ctx) (dlet ( @@ -5134,8 +5153,8 @@ (params (slice func_param_values 1 -1)) (func_value (idx func_param_values 0)) (_ (true_print "about to get cached_infer_types_idx for call before checking for 'idx")) - (_ (true_print " cache is " type_data)) - (parameter_subs (map (lambda (i) (cached_infer_types_idx c (.marked_env_idx env) type_data i)) (range 1 (len func_param_values)))) + ;(_ (true_print " cache is " type_data)) + (parameter_subs (map (lambda (i) (cached_analysis_idx c (.marked_env_idx env) analysis_data i)) (range 1 (len func_param_values)))) (parameter_types (map just_type parameter_subs)) ; used_data HERE @@ -5172,10 +5191,9 @@ nil) ; if we're unvaling, our old cache for type data is bad ; TODO - we should be able to recover for this - (mif unval_and_eval type_data_nil + (mif unval_and_eval analysis_nil (idx parameter_subs (- num_params i 1))) - ; if it's a dynamic call, everything used anyway - used_data_nil))) + ))) ((datasi funcs memo env pectx inline_locals) ctx) (memo (put memo (.hash c) 'RECURSE_OK)) ) (array (cons (mif val (i64.const (mod_fval_to_wrap val)) code) a) err ctx (+ i 1)))) @@ -5257,11 +5275,11 @@ (_ (if (!= 2 (len params)) (error "call to veval has != 2 params!"))) ((datasi funcs memo env pectx inline_locals) ctx) - ((val code err (datasi funcs memo ienv pectx inline_locals)) (compile-inner (array datasi funcs memo (idx params 1) pectx inline_locals) (idx params 0) false true (local.get '$s_env) (local.get '$s_env) 0 nil type_data_nil used_data_nil)) + ((val code err (datasi funcs memo ienv pectx inline_locals)) (compile-inner (array datasi funcs memo (idx params 1) pectx inline_locals) (idx params 0) false true (local.get '$s_env) (local.get '$s_env) 0 nil analysis_nil)) (ctx (array datasi funcs memo env pectx inline_locals)) ; If it's actual code, we have to set and reset s_env ((code env_err ctx) (mif code (dlet ( - ((env_val env_code env_err ctx) (compile-inner ctx (idx params 1) false inside_veval outer_s_env_access_code s_env_access_code inline_level nil type_data_nil used_data_nil)) + ((env_val env_code env_err ctx) (compile-inner ctx (idx params 1) false inside_veval outer_s_env_access_code s_env_access_code inline_level nil analysis_nil)) (full_code (concat (local.get '$s_env) (local.set '$s_env (mif env_val (i64.const env_val) env_code)) code @@ -5289,9 +5307,9 @@ )) param_codes 0) err ctx)))) - ((and (prim_comb? func_value) (= (.prim_comb_sym func_value) '+)) (gen_numeric_impl i64.add)) - ((and (prim_comb? func_value) (= (.prim_comb_sym func_value) '-)) (gen_numeric_impl i64.sub)) - ((and (prim_comb? func_value) (= (.prim_comb_sym func_value) '=)) (mif (any_in_array word_value_type? parameter_types) + ((and (not dont_prim_inline) (prim_comb? func_value) (= (.prim_comb_sym func_value) '+)) (gen_numeric_impl i64.add)) + ((and (not dont_prim_inline) (prim_comb? func_value) (= (.prim_comb_sym func_value) '-)) (gen_numeric_impl i64.sub)) + ((and (not dont_prim_inline) (prim_comb? func_value) (= (.prim_comb_sym func_value) '=)) (mif (any_in_array word_value_type? parameter_types) (dlet (((param_codes err ctx _) (compile_params false ctx false))) (mif err (array nil nil (str err " from function params in call to comb " (str_strip c)) ctx) (dlet ( @@ -5326,10 +5344,10 @@ ) (array nil eq_code nil ctx)))) (dlet ((_ (true_print "missed better = " parameter_types))) (gen_cmp_impl false_val true_val false_val)))) - ((and (prim_comb? func_value) (= (.prim_comb_sym func_value) 'array?) (= 1 num_params)) (gen_pred_impl array_tag true)) + ((and (not dont_prim_inline) (prim_comb? func_value) (= (.prim_comb_sym func_value) 'array?) (= 1 num_params)) (gen_pred_impl array_tag true)) ; inline array pretty much always - array does nothing but return it's parameter array anyway! - ((and (prim_comb? func_value) (= (.prim_comb_sym func_value) 'array)) (dlet ( + ((and (not dont_prim_inline) (prim_comb? func_value) (= (.prim_comb_sym func_value) 'array)) (dlet ( (_ (true_print "inlining array ARRAY!!!")) ((param_codes err ctx _) (compile_params false ctx false)) (code (mif err nil @@ -5338,7 +5356,7 @@ ) (array nil code err ctx))) ; inline idx if we have the type+len of array and idx is a constant - ((and (prim_comb? func_value) (= (.prim_comb_sym func_value) 'idx) (= 2 num_params) + ((and (not dont_prim_inline) (prim_comb? func_value) (= (.prim_comb_sym func_value) 'idx) (= 2 num_params) (idx parameter_types 0) (= 'arr (idx (idx parameter_types 0) 0)) (idx (idx parameter_types 0) 2) (idx parameter_types 1) (= 'int (idx (idx parameter_types 1) 0))) (val? (idx params 1)) (dlet ( @@ -5355,7 +5373,7 @@ (array nil (true_str "bad constant offset into typed array")))) ) (array nil code err ctx))) ; inline len if we have the type of array - ((and (prim_comb? func_value) (= (.prim_comb_sym func_value) 'len) (= 1 num_params) + ((and (not dont_prim_inline) (prim_comb? func_value) (= (.prim_comb_sym func_value) 'len) (= 1 num_params) (idx parameter_types 0) (= 'arr (idx (idx parameter_types 0) 0))) (dlet ( (_ (true_print "inlining len LEN!!!")) ((param_codes err ctx _) (compile_params false ctx false)) @@ -5368,7 +5386,7 @@ ; User inline - ((let_like_inline_closure func_value (.marked_env_idx env)) (dlet ( + ((and (not dont_closure_inline) (let_like_inline_closure func_value (.marked_env_idx env))) (dlet ( ; To inline, we add all of the parameters + inline_level + 1 to the current functions additional symbols ; as well as a new se + inline_level + 1 symbol ; fill them with the result of evaling the parameters now @@ -5386,7 +5404,7 @@ ((param_codes first_params_err ctx _) (compile_params false ctx false)) (inner_env (make_tmp_inner_env comb_params (.comb_des func_value) (.comb_env func_value) (.comb_id func_value))) - ((params_vec _ _ ctx) (compile-inner ctx (marked_array true false nil (map (lambda (k) (marked_symbol nil k)) comb_params) nil) true false outer_s_env_access_code s_env_access_code 0 nil type_data_nil used_data_nil)) + ((params_vec _ _ ctx) (compile-inner ctx (marked_array true false nil (map (lambda (k) (marked_symbol nil k)) comb_params) nil) true false outer_s_env_access_code s_env_access_code 0 nil analysis_nil)) (new_get_s_env_code (_if '$have_s_env '(result i64) (i64.ne (i64.const nil_val) (local.get new_s_env_symbol)) (then (local.get new_s_env_symbol)) @@ -5403,8 +5421,8 @@ (_ (true_print "Doing inline compile-inner " comb_params)) ((inner_value inner_code err ctx) (compile-inner (array datasi funcs memo inner_env pectx inline_locals) (.comb_body func_value) false false outer_s_env_access_code new_get_s_env_code new_inline_level tce_data - (cached_infer_types_idx c (.comb_id func_value) type_data 0) - used_data_nil)) + (cached_analysis_idx c (.comb_id func_value) analysis_data 0) + )) (_ (true_print "Done inline compile-inner " comb_params)) (inner_code (mif inner_value (i64.const inner_value) inner_code)) (result_code (concat @@ -5432,11 +5450,11 @@ ; + d_de/d_no_de & d_wrap=1/d_wrap=2 (true (dlet ( ((param_codes first_params_err ctx _) (compile_params false ctx false)) - ((func_val func_code func_err ctx) (compile-inner ctx func_value false inside_veval outer_s_env_access_code s_env_access_code inline_level nil type_data_nil used_data_nil)) + ((func_val func_code func_err ctx) (compile-inner ctx func_value false inside_veval outer_s_env_access_code s_env_access_code inline_level nil analysis_nil)) ((unval_param_codes err ctx _) (compile_params true ctx false)) ; Generates *tons* of text, needs to be different. Made a 200KB binary 80MB - ;((bad_unval_params_msg_val _ _ ctx) (compile-inner ctx (marked_val (str "error was with unval-evaling parameters of " (true_str_strip c) " " err)) true inside_veval outer_s_env_access_code s_env_access_code inline_level type_data_nil used_data_nil)) - ((bad_unval_params_msg_val _ _ ctx) (compile-inner ctx (marked_val "error was with unval-evaling parameters of ") true inside_veval outer_s_env_access_code s_env_access_code inline_level nil type_data_nil used_data_nil)) + ;((bad_unval_params_msg_val _ _ ctx) (compile-inner ctx (marked_val (str "error was with unval-evaling parameters of " (true_str_strip c) " " err)) true inside_veval outer_s_env_access_code s_env_access_code inline_level analysis_nil)) + ((bad_unval_params_msg_val _ _ ctx) (compile-inner ctx (marked_val "error was with unval-evaling parameters of ") true inside_veval outer_s_env_access_code s_env_access_code inline_level nil analysis_nil)) (wrap_0_inner_code (apply concat param_codes)) (wrap_0_param_code (wrap_param_codes param_codes)) (wrap_1_inner_code @@ -5457,7 +5475,7 @@ (call '$print (i64.const weird_wrap_msg_val)) (unreachable))) - ((source_code ctx) (mif (.marked_array_source c) (dlet (((code _ _ ctx) (compile-inner ctx (.marked_array_source c) true inside_veval outer_s_env_access_code s_env_access_code inline_level nil type_data_nil used_data_nil)) + ((source_code ctx) (mif (.marked_array_source c) (dlet (((code _ _ ctx) (compile-inner ctx (.marked_array_source c) true inside_veval outer_s_env_access_code s_env_access_code inline_level nil analysis_nil)) ) (array code ctx)) (array k_cond_msg_val ctx))) ((result_code ctx) (mif func_val @@ -5587,8 +5605,8 @@ ;(_ (true_print "gonna compile kvs vvs")) - ((kvs vvs ctx) (foldr (dlambda ((k v) (ka va ctx)) (dlet (((kv _ _ ctx) (compile-inner ctx (marked_symbol nil k) true inside_veval outer_s_env_access_code s_env_access_code inline_level nil type_data_nil used_data_nil)) - ((vv code err ctx) (compile-inner ctx v need_value inside_veval outer_s_env_access_code s_env_access_code inline_level nil type_data_nil used_data_nil)) + ((kvs vvs ctx) (foldr (dlambda ((k v) (ka va ctx)) (dlet (((kv _ _ ctx) (compile-inner ctx (marked_symbol nil k) true inside_veval outer_s_env_access_code s_env_access_code inline_level nil analysis_nil)) + ((vv code err ctx) (compile-inner ctx v need_value inside_veval outer_s_env_access_code s_env_access_code inline_level nil analysis_nil)) ) (if (= false ka) (array false va ctx) (if (or (= nil vv) (!= nil err)) (array false (str "vv was " vv " err is " err " and we needed_value? " need_value " based on v " (str_strip v)) ctx) @@ -5596,7 +5614,7 @@ (array (array) (array) ctx) (slice e 0 -2))) ;(_ (true_print "gonna compile upper_value")) - ((uv ucode err ctx) (mif (idx e -1) (compile-inner ctx (idx e -1) need_value inside_veval outer_s_env_access_code s_env_access_code inline_level nil type_data_nil used_data_nil) + ((uv ucode err ctx) (mif (idx e -1) (compile-inner ctx (idx e -1) need_value inside_veval outer_s_env_access_code s_env_access_code inline_level nil analysis_nil) (array nil_val nil nil ctx))) ) (mif (or (= false kvs) (= nil uv) (!= nil err)) (begin (print_strip "kvs " kvs " vvs " vvs " uv " uv " or err " err " based off of " c) @@ -5685,6 +5703,7 @@ ; and perform the eta reduction. (attempt_reduction (and + (not dont_y_comb) variadic (= 1 (len params)) (marked_array? body) @@ -5704,11 +5723,9 @@ (compile_body_part (lambda (ctx body_part new_tce_data) (dlet ( (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 type_data_nil used_data_nil)) - (new_get_s_env_code (_if '$have_s_env '(result i64) - (i64.ne (i64.const nil_val) (local.get '$s_env)) - (then (local.get '$s_env)) - (else (local.tee '$s_env (call '$env_alloc (i64.const params_vec) + ((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)) + (basic_get_s_env_code (local.get '$s_env)) + (generate_get_s_env_code (local.tee '$s_env (call '$env_alloc (i64.const params_vec) (local.set '$tmp_ptr (call '$malloc (i32.const (* 8 (len full_params))))) (flat_map (lambda (i) (i64.store (* i 8) (local.get '$tmp_ptr) @@ -5716,11 +5733,16 @@ (range 0 (len full_params))) (mk_array_code_rc_const_len (len full_params) (local.get '$tmp_ptr)) - (generate_dup (local.get '$outer_s_env)))) + (generate_dup (local.get '$outer_s_env))))) + (lazy_get_s_env_code (_if '$have_s_env '(result i64) + (i64.ne (i64.const nil_val) (local.get '$s_env)) + (then basic_get_s_env_code) + (else generate_get_s_env_code ;(call '$print (i64.const params_vec)) ;(call '$print (i64.const newline_msg_val)) ;(local.set '$outer_s_env (i64.const nil_val)) ))) + (new_get_s_env_code (if dont_lazy_env basic_get_s_env_code lazy_get_s_env_code)) ((datasi funcs memo env pectx inline_locals) ctx) (inner_ctx (array datasi funcs memo inner_env pectx inline_locals)) (_ (true_print "Doing infer_types for body part for " full_params)) @@ -5731,15 +5753,16 @@ ((borrowed borrow_sub_data) (borrow? body_part false (.marked_env_idx inner_env) used_map_sub_data)) (_ (mif borrowed (error "body hast to be borrowed? " borrowed " " (true_str_strip body_part)))) (_ (true_print "done pseudo_perceus, Doing compile_body_part func def compile-inner " full_params)) - ((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_type_data used_data_nil)) + (inner_analysis_data (array inner_type_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)) (_ (true_print "Done compile_body_part 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! ((datasi funcs memo _was_inner_env pectx inline_locals) ctx) - ) (array inner_value inner_code err (array datasi funcs memo env pectx inline_locals))))) + ) (array inner_value inner_code err (array datasi funcs memo env pectx inline_locals) generate_get_s_env_code)))) ((early_quit err ctx) (mif attempt_reduction (dlet ( - ((inner_value inner_code err ctx) (compile_body_part ctx (idx (.marked_array_values body) 1) nil)) + ((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)) @@ -5752,7 +5775,7 @@ ((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 type_data_nil used_data_nil))) + (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 @@ -5768,6 +5791,7 @@ (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)) + ; Is this the vau-tieer? (memo (mif env_val (foldl (dlambda (memo (hash wrap)) (put memo hash (combine_env_comb_val env_val (calculate_func_val wrap)))) memo rec_hashes) memo)) @@ -5775,7 +5799,7 @@ (new_inline_locals (array)) (ctx (array datasi funcs memo env pectx new_inline_locals)) - ((inner_value inner_code err ctx) (compile_body_part ctx body (array our_func_idx full_params))) + ((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)) (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 @@ -5806,7 +5830,9 @@ (our_func (apply func (concat (array '$userfunc) parameter_symbols (array '(param $outer_s_env i64) '(result i64) '(local $param_ptr i32) '(local $s_env i64) '(local $tmp_ptr i32) '(local $tmp i64) '(local $prim_tmp_a i64) '(local $prim_tmp_b i64) '(local $prim_tmp_c i64) '(local $prim_tmp_d i32) '(local $rc_bytes i64) '(local $rc_ptr i32) '(local $rc_tmp i32)) our_inline_locals (array - (local.set '$s_env (i64.const nil_val)) + ;(local.set '$s_env (i64.const nil_val)) + (if dont_lazy_env (_drop generate_get_s_env_code) + (local.set '$s_env (i64.const nil_val))) (mif (in_array '___TCE___ inline_locals) (concat (_loop '___TCE___ @@ -5848,24 +5874,24 @@ (_ (true_print "About to compile a bunch of symbols & strings")) - ((exit_val _ _ ctx) (compile-inner ctx (marked_symbol nil 'exit) true false (array) (array) 0 nil type_data_nil used_data_nil)) - ((args_val _ _ ctx) (compile-inner ctx (marked_symbol nil 'args) true false (array) (array) 0 nil type_data_nil used_data_nil)) - ((read_val _ _ ctx) (compile-inner ctx (marked_symbol nil 'read) true false (array) (array) 0 nil type_data_nil used_data_nil)) - ((write_val _ _ ctx) (compile-inner ctx (marked_symbol nil 'write) true false (array) (array) 0 nil type_data_nil used_data_nil)) - ((open_val _ _ ctx) (compile-inner ctx (marked_symbol nil 'open) true false (array) (array) 0 nil type_data_nil used_data_nil)) - ((monad_error_msg_val _ _ ctx) (compile-inner ctx (marked_val "Not a legal monad ( ['args ] / ['read fd len ] / ['write fd data ] / ['open fd path ] /['exit exit_code])") true false (array) (array) 0 nil type_data_nil used_data_nil)) - ((bad_args_val _ _ ctx) (compile-inner ctx (marked_val "") true false (array) (array) 0 nil type_data_nil used_data_nil)) - ((bad_read_val _ _ ctx) (compile-inner ctx (marked_val "") true false (array) (array) 0 nil type_data_nil used_data_nil)) - ((exit_msg_val _ _ ctx) (compile-inner ctx (marked_val "Exiting with code: ") true false (array) (array) 0 nil type_data_nil used_data_nil)) + ((exit_val _ _ ctx) (compile-inner ctx (marked_symbol nil 'exit) true false (array) (array) 0 nil analysis_nil)) + ((args_val _ _ ctx) (compile-inner ctx (marked_symbol nil 'args) true false (array) (array) 0 nil analysis_nil)) + ((read_val _ _ ctx) (compile-inner ctx (marked_symbol nil 'read) true false (array) (array) 0 nil analysis_nil)) + ((write_val _ _ ctx) (compile-inner ctx (marked_symbol nil 'write) true false (array) (array) 0 nil analysis_nil)) + ((open_val _ _ ctx) (compile-inner ctx (marked_symbol nil 'open) true false (array) (array) 0 nil analysis_nil)) + ((monad_error_msg_val _ _ ctx) (compile-inner ctx (marked_val "Not a legal monad ( ['args ] / ['read fd len ] / ['write fd data ] / ['open fd path ] /['exit exit_code])") true false (array) (array) 0 nil analysis_nil)) + ((bad_args_val _ _ ctx) (compile-inner ctx (marked_val "") true false (array) (array) 0 nil analysis_nil)) + ((bad_read_val _ _ ctx) (compile-inner ctx (marked_val "") true false (array) (array) 0 nil analysis_nil)) + ((exit_msg_val _ _ ctx) (compile-inner ctx (marked_val "Exiting with code: ") true false (array) (array) 0 nil analysis_nil)) (_ (true_print "about ot compile the root_marked_env")) - ((root_marked_env_val _ _ ctx) (compile-inner ctx root_marked_env true false (array) (array) 0 nil type_data_nil used_data_nil)) + ((root_marked_env_val _ _ ctx) (compile-inner ctx root_marked_env true false (array) (array) 0 nil analysis_nil)) (_ (true_print "made the vals")) (_ (true_print "gonna compile")) - ((compiled_value_ptr compiled_value_code compiled_value_error ctx) (compile-inner ctx marked_code true false (array) (array) 0 nil type_data_nil used_data_nil)) + ((compiled_value_ptr compiled_value_code compiled_value_error ctx) (compile-inner ctx marked_code true false (array) (array) 0 nil analysis_nil)) ((datasi funcs memo root_marked_env pectx inline_locals) ctx) (compiled_value_code (mif compiled_value_ptr (i64.const (mod_fval_to_wrap compiled_value_ptr)) compiled_value_code)) @@ -6660,7 +6686,7 @@ ) void))) - (run-compiler (lambda (dont_compile f) + (run-compiler (lambda (dont_compile dont_lazy_env dont_y_comb dont_prim_inline dont_closure_inline f) (dlet ( (_ (true_print "reading in!")) (read_in (read-string (slurp f))) @@ -6668,7 +6694,7 @@ (evaled (if dont_compile (array (array 0 empty_dict) nil (mark read_in)) (partial_eval read_in))) ;(_ (true_print "done partialy evaling, now compiling")) - (bytes (compile evaled dont_compile)) + (bytes (compile evaled dont_compile dont_lazy_env dont_y_comb dont_prim_inline dont_closure_inline)) ;(_ (true_print "compiled, writng out")) (_ (write_file "./csc_out.wasm" bytes)) ;(_ (true_print "written out")) @@ -6685,7 +6711,13 @@ (dlet ( (com (if (> (len args) 0) (idx args 0) "")) ) (cond ((= "test" com) (test-most)) ((= "single" com) (single-test)) - (true (run-compiler (and (>= (len args) 2) (= "no_compile" (idx args 1))) com)))) + (true (run-compiler + (and (>= (len args) 2) (= "no_compile" (idx args 1))) + (and (>= (len args) 2) (= "no_lazy_env" (idx args 1))) + (and (>= (len args) 2) (= "no_y_comb" (idx args 1))) + (and (>= (len args) 2) (= "no_prim_inline" (idx args 1))) + (and (>= (len args) 2) (= "no_closure_inline" (idx args 1))) + com)))) ;(true_print "GLOBAL_MAX was " GLOBAL_MAX) ;(profile-dump-html)