From a08415e1e6ebfece1bbee62a8df95ab3a004468b Mon Sep 17 00:00:00 2001 From: Nathan Braswell Date: Tue, 8 Mar 2022 15:55:59 -0500 Subject: [PATCH] Cleanup & some demo code for presentation --- demo.sh | 14 +++++++++++ foldl_demo.kp | 53 +++++++++++++++++++++++++++++++++++++++++ partial_eval.scm | 56 +++++++++++++++++++++++++------------------- small_demo.kp | 1 + small_lambda_demo.kp | 1 + small_macro_demo.kp | 8 +++++++ small_vau_demo.kp | 1 + to_compile.kp | 2 +- 8 files changed, 111 insertions(+), 25 deletions(-) create mode 100755 demo.sh create mode 100644 foldl_demo.kp create mode 100644 small_demo.kp create mode 100644 small_lambda_demo.kp create mode 100644 small_macro_demo.kp create mode 100644 small_vau_demo.kp diff --git a/demo.sh b/demo.sh new file mode 100755 index 0000000..b2a8727 --- /dev/null +++ b/demo.sh @@ -0,0 +1,14 @@ +#!/usr/bin/env bash + +echo +echo "Partially Evaluating & compiling " $@ +echo "Source is" +cat $@ +echo +touch csc_out.wasm && rm csc_out.wasm && time scheme --script ./partial_eval.scm $@ +echo +echo "Running" +echo +wasmtime ./csc_out.wasm +echo +echo diff --git a/foldl_demo.kp b/foldl_demo.kp new file mode 100644 index 0000000..ca48b8f --- /dev/null +++ b/foldl_demo.kp @@ -0,0 +1,53 @@ +((wrap (vau root_env (quote) +((wrap (vau (let1) +(let1 lambda (vau se (p b1) (wrap (eval (array vau p b1) se))) +(let1 current-env (vau de () de) +(let1 cons (lambda (h t) (concat (array h) t)) +(let1 Y (lambda (f3) + ((lambda (x1) (x1 x1)) + (lambda (x2) (f3 (lambda (& y) (lapply (x2 x2) y)))))) +(let1 vY (lambda (f) + ((lambda (x3) (x3 x3)) + (lambda (x4) (f (vau de1 (& y) (vapply (x4 x4) y de1)))))) +(let1 let (vY (lambda (recurse) (vau de2 (vs b) (cond (= (len vs) 0) (eval b de2) + true (vapply let1 (array (idx vs 0) (idx vs 1) (array recurse (slice vs 2 -1) b)) de2))))) + (let ( + rec-lambda (vau se (n p b) (eval (array Y (array lambda (array n) (array lambda p b))) se)) + if (vau de (con than & else) (cond (eval con de) (eval than de) + (> (len else) 0) (eval (idx else 0) de) + true false)) + map (lambda (f5 l5) + ; now maybe errors on can't find helper? + (let (helper (rec-lambda recurse (f4 l4 n4 i4) + (cond (= i4 (len l4)) n4 + (<= i4 (- (len l4) 4)) (recurse f4 l4 (concat n4 (array + (f4 (idx l4 (+ i4 0))) + (f4 (idx l4 (+ i4 1))) + (f4 (idx l4 (+ i4 2))) + (f4 (idx l4 (+ i4 3))) + )) (+ i4 4)) + true (recurse f4 l4 (concat n4 (array (f4 (idx l4 i4)))) (+ i4 1))))) + (helper f5 l5 (array) 0))) + and (let (macro_helper (rec-lambda recurse (bs i) (cond (= i (len bs)) true + (= (+ 1 i) (len bs)) (idx bs i) + true (array let (array 'tmp (idx bs i)) (array if 'tmp (recurse bs (+ i 1)) 'tmp))))) + (vau se (& bs) (eval (macro_helper bs 0) se))) + + foldl (let (helper (rec-lambda recurse (f z vs i) (if (= i (len (idx vs 0))) z + (recurse f (lapply f (cons z (map (lambda (x) (idx x i)) vs))) vs (+ i 1))))) + (lambda (f z & vs) (helper f z vs 0))) + zip (lambda (& xs) (lapply foldl (concat (array (lambda (a & ys) (cons ys a)) (array)) xs))) + + and_fold (foldl and true '(true true false true)) + monad (array 'write 1 (str "Hello from compiled code! " and_fold "\n") (vau (written code) (array 'exit 0))) + ) + monad + ) +; end of all lets +)))))) +; impl of let1 +; this would be the macro style version ((( +)) (vau de (s v b) (eval (array (array wrap (array vau (array s) b)) v) de))) +;)) (vau de (s v b) (eval (array (array vau (array s) b) (eval v de)) de))) +; impl of quote +)) (vau (x5) x5)) diff --git a/partial_eval.scm b/partial_eval.scm index 2cc8625..c7f11f0 100644 --- a/partial_eval.scm +++ b/partial_eval.scm @@ -7,6 +7,7 @@ ; Chez (define print pretty-print) (define arithmetic-shift bitwise-arithmetic-shift) (define foldl fold-left) (define foldr fold-right) (define write_file (lambda (file bytes) (let* ( (port (open-file-output-port file)) (_ (foldl (lambda (_ o) (put-u8 port o)) (void) bytes)) (_ (close-port port))) '()))) +(define args (command-line)) ;(compile-profile 'source) ; Gambit - Gambit also has a problem with the dlet definition (somehow recursing and making (cdr nil) for (cdr ls)?), even if using the unstable one that didn't break syntax-rules @@ -90,6 +91,7 @@ (>> (lambda (a b) (arithmetic-shift a (- b)))) (print (lambda args (print (apply str args)))) + (true_str str) (str (if speed_hack (lambda args "") str)) (true_print print) (print (if speed_hack (lambda x 0) print)) @@ -454,36 +456,37 @@ (str " " (recurse (- i 1)))))) (indent_str (if speed_hack (lambda (i) "") indent_str)) - (str_strip (lambda args (apply str (concat (slice args 0 -2) (array (idx ((rec-lambda recurse (x done_envs) + (str_strip (lambda args (apply true_str (concat (slice args 0 -2) (array (idx ((rec-lambda recurse (x done_envs) (cond ((= nil x) (array "" done_envs)) - ((string? x) (array (str "") done_envs)) - ((val? x) (array (str (.val x)) done_envs)) + ((string? x) (array (true_str "") done_envs)) + ((val? x) (array (true_str (.val x)) done_envs)) ((marked_array? x) (dlet (((stripped_values done_envs) (foldl (dlambda ((vs de) x) (dlet (((v de) (recurse x de))) (array (concat vs (array v)) de))) (array (array) done_envs) (.marked_array_values x)))) - (mif (.marked_array_is_val x) (array (str "[" stripped_values "]") done_envs) - (array (str "" stripped_values) done_envs)))) - ((marked_symbol? x) (mif (.marked_symbol_is_val x) (array (str "'" (.marked_symbol_value x)) done_envs) - (array (str (.marked_symbol_needed_for_progress x) "#" (.marked_symbol_value x)) done_envs))) + (mif (.marked_array_is_val x) (array (true_str "[" stripped_values "]") done_envs) + (array (true_str stripped_values) done_envs)))) + ;(array (true_str "" stripped_values) done_envs)))) + ((marked_symbol? x) (mif (.marked_symbol_is_val x) (array (true_str "'" (.marked_symbol_value x)) done_envs) + (array (true_str (.marked_symbol_needed_for_progress x) "#" (.marked_symbol_value x)) done_envs))) ((comb? x) (dlet (((wrap_level env_id de? se variadic params body) (.comb x)) ((se_s done_envs) (recurse se done_envs)) ((body_s done_envs) (recurse body done_envs))) - (array (str "") done_envs))) - ((prim_comb? x) (array (str "") done_envs)) + (array (true_str "") done_envs))) + ((prim_comb? x) (array (true_str "") done_envs)) ((marked_env? x) (dlet ((e (.env_marked x)) (index (.marked_env_idx x)) (u (idx e -1)) (already (in_array index done_envs)) - (opening (str "{" (mif (marked_env_real? x) "real" "fake") (mif (.marked_env_has_vals x) " real vals" " fake vals") " ENV idx: " (str index) ", ")) + (opening (true_str "{" (mif (marked_env_real? x) "real" "fake") (mif (.marked_env_has_vals x) " real vals" " fake vals") " ENV idx: " (true_str index) ", ")) ((middle done_envs) (if already (array "" done_envs) (foldl (dlambda ((vs de) (k v)) (dlet (((x de) (recurse v de))) (array (concat vs (array (array k x))) de))) (array (array) done_envs) (slice e 0 -2)))) ((upper done_envs) (if already (array "" done_envs) (mif u (recurse u done_envs) (array "no_upper_likely_root_env" done_envs)))) (done_envs (if already done_envs (cons index done_envs))) - ) (array (if already (str opening "omitted}") - (if (> (len e) 30) (str "{" (len e) "env}") - (str opening middle " upper: " upper "}"))) done_envs) + ) (array (if already (true_str opening "omitted}") + (if (> (len e) 30) (true_str "{" (len e) "env}") + (true_str opening middle " upper: " upper "}"))) done_envs) )) - (true (error (str "some other str_strip? |" x "|"))) + (true (error (true_str "some other str_strip? |" x "|"))) ) ) (idx args -1) (array)) 0)))))) (true_str_strip str_strip) @@ -1045,7 +1048,7 @@ (needs_params_val_lambda '<= <=) (needs_params_val_lambda '> >) (needs_params_val_lambda '>= >=) - (needs_params_val_lambda 'str str) + (needs_params_val_lambda 'str true_str) ;(needs_params_val_lambda 'pr-str pr-str) ;(needs_params_val_lambda 'prn prn) (give_up_eval_params 'log log) @@ -3914,8 +3917,8 @@ ))) ;(_ (println "compiling partial evaled " (str_strip marked_code))) - ;(_ (true_print "compiling partial evaled " (true_str_strip marked_code))) - (_ (true_print "compiling partial evaled ")) + (_ (true_print "compiling partial evaled " (true_str_strip marked_code))) + ;(_ (true_print "compiling partial evaled ")) (memo empty_dict) (ctx (array datasi funcs memo root_marked_env pectx)) @@ -3925,7 +3928,7 @@ ((open_val _ _ ctx) (compile-inner ctx (marked_symbol nil 'open) true)) ((monad_error_msg_val _ _ ctx) (compile-inner ctx (marked_val "Not a legal monad ( ['read fd len ] / ['write fd data ] / ['open fd path ] /['exit exit_code])") true)) ((bad_read_val _ _ ctx) (compile-inner ctx (marked_val "") true)) - ((exit_msg_val _ _ ctx) (compile-inner ctx (marked_val "Exiting with code:") true)) + ((exit_msg_val _ _ ctx) (compile-inner ctx (marked_val "Exiting with code: ") true)) ((root_marked_env_val _ _ ctx) (compile-inner ctx root_marked_env true)) @@ -4534,15 +4537,15 @@ (run-compiler (lambda (f) (dlet ( - (_ (true_print "reading in!")) + ;(_ (true_print "reading in!")) (read_in (read-string (slurp f))) - (_ (true_print "read in, now evaluating")) + ;(_ (true_print "read in, now evaluating")) (evaled (partial_eval read_in)) - (_ (true_print "done partialy evaling, now compiling")) + ;(_ (true_print "done partialy evaling, now compiling")) (bytes (compile evaled)) - (_ (true_print "compiled, writng out")) + ;(_ (true_print "compiled, writng out")) (_ (write_file "./csc_out.wasm" bytes)) - (_ (true_print "written out")) + ;(_ (true_print "written out")) ) (void)) )) @@ -4551,7 +4554,12 @@ ;(test-most) ;(single-test) ;(run-compiler "small_test.kp") - (run-compiler "to_compile.kp") + ;(run-compiler "to_compile.kp") + + (dlet ( (com (if (> (len args) 1) (idx args 1) "")) ) + (if (= "test" com) (test-most) + (run-compiler com))) + ;(true_print "GLOBAL_MAX was " GLOBAL_MAX) ;(profile-dump-html) ;(profile-dump-list) diff --git a/small_demo.kp b/small_demo.kp new file mode 100644 index 0000000..4d956a6 --- /dev/null +++ b/small_demo.kp @@ -0,0 +1 @@ +(+ 1 2) diff --git a/small_lambda_demo.kp b/small_lambda_demo.kp new file mode 100644 index 0000000..ea4a9e5 --- /dev/null +++ b/small_lambda_demo.kp @@ -0,0 +1 @@ +(wrap (vau () (+ 1 2))) diff --git a/small_macro_demo.kp b/small_macro_demo.kp new file mode 100644 index 0000000..6f4a4cd --- /dev/null +++ b/small_macro_demo.kp @@ -0,0 +1,8 @@ + +((wrap (vau (quote) + + +(vau () (array (quote a) (+ 1 2))) + +; impl of quote +)) (vau (x5) x5)) diff --git a/small_vau_demo.kp b/small_vau_demo.kp new file mode 100644 index 0000000..078dcbd --- /dev/null +++ b/small_vau_demo.kp @@ -0,0 +1 @@ +(vau () (+ 1 2)) diff --git a/to_compile.kp b/to_compile.kp index bc5f063..d31cf62 100644 --- a/to_compile.kp +++ b/to_compile.kp @@ -360,7 +360,7 @@ (and_fold (foldl and true '(true true false true))) - (monad (array 'write 1 "test_self_out2" (vau (written code) and_fold))) + (monad (array 'write 1 (str "Hello from compiled code! " and_fold "\n") (vau (written code) (array 'exit 0)))) ) monad) )