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

Cleanup & some demo code for presentation

Browse Source
This commit is contained in:
Nathan Braswell
2022-03-08 15:55:59 -05:00
parent 7fed3a58f5
commit a08415e1e6
8 changed files with 111 additions and 25 deletions
Download Patch File Download Diff File Expand all files Collapse all files

14
demo.sh Executable file
View File

@@ -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

53
foldl_demo.kp Normal file
View File

@@ -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))

54
partial_eval.scm
View File

@@ -7,6 +7,7 @@
; Chez ; 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 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) ;(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 ; 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)))) (>> (lambda (a b) (arithmetic-shift a (- b))))
(print (lambda args (print (apply str args)))) (print (lambda args (print (apply str args))))
(true_str str)
(str (if speed_hack (lambda args "") str)) (str (if speed_hack (lambda args "") str))
(true_print print) (true_print print)
(print (if speed_hack (lambda x 0) print)) (print (if speed_hack (lambda x 0) print))
@@ -454,36 +456,37 @@
(str " " (recurse (- i 1)))))) (str " " (recurse (- i 1))))))
(indent_str (if speed_hack (lambda (i) "") indent_str)) (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 "<nil>" done_envs)) (cond ((= nil x) (array "<nil>" done_envs))
((string? x) (array (str "<raw string " x ">") done_envs)) ((string? x) (array (true_str "<raw string " x ">") done_envs))
((val? x) (array (str (.val x)) 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))) ((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)))) (array (array) done_envs) (.marked_array_values x))))
(mif (.marked_array_is_val x) (array (str "[" stripped_values "]") done_envs) (mif (.marked_array_is_val x) (array (true_str "[" stripped_values "]") done_envs)
(array (str "<a" (.marked_array_is_attempted x) ",r" (needed_for_progress x) ">" stripped_values) done_envs)))) (array (true_str stripped_values) done_envs))))
((marked_symbol? x) (mif (.marked_symbol_is_val x) (array (str "'" (.marked_symbol_value x)) done_envs) ;(array (true_str "<a" (.marked_array_is_attempted x) ",r" (needed_for_progress x) ">" stripped_values) done_envs))))
(array (str (.marked_symbol_needed_for_progress x) "#" (.marked_symbol_value x)) 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)) ((comb? x) (dlet (((wrap_level env_id de? se variadic params body) (.comb x))
((se_s done_envs) (recurse se done_envs)) ((se_s done_envs) (recurse se done_envs))
((body_s done_envs) (recurse body done_envs))) ((body_s done_envs) (recurse body done_envs)))
(array (str "<n" (needed_for_progress_slim x) "(comb " wrap_level " " env_id " " de? " " se_s " " params " " body_s ")>") done_envs))) (array (true_str "<n (comb " wrap_level " " env_id " " de? " " se_s " " params " " body_s ")>") done_envs)))
((prim_comb? x) (array (str "<wl=" (.prim_comb_wrap_level x) " " (.prim_comb_sym x) ">") done_envs)) ((prim_comb? x) (array (true_str "<wl=" (.prim_comb_wrap_level x) " " (.prim_comb_sym x) ">") done_envs))
((marked_env? x) (dlet ((e (.env_marked x)) ((marked_env? x) (dlet ((e (.env_marked x))
(index (.marked_env_idx x)) (index (.marked_env_idx x))
(u (idx e -1)) (u (idx e -1))
(already (in_array index done_envs)) (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))) ((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) (array (array) done_envs)
(slice e 0 -2)))) (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)))) ((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))) (done_envs (if already done_envs (cons index done_envs)))
) (array (if already (str opening "omitted}") ) (array (if already (true_str opening "omitted}")
(if (> (len e) 30) (str "{" (len e) "env}") (if (> (len e) 30) (true_str "{" (len e) "env}")
(str opening middle " upper: " upper "}"))) done_envs) (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)))))) ) (idx args -1) (array)) 0))))))
(true_str_strip str_strip) (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 '> >)
(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 'pr-str pr-str)
;(needs_params_val_lambda 'prn prn) ;(needs_params_val_lambda 'prn prn)
(give_up_eval_params 'log log) (give_up_eval_params 'log log)
@@ -3914,8 +3917,8 @@
))) )))
;(_ (println "compiling partial evaled " (str_strip marked_code))) ;(_ (println "compiling partial evaled " (str_strip marked_code)))
;(_ (true_print "compiling partial evaled " (true_str_strip marked_code))) (_ (true_print "compiling partial evaled " (true_str_strip marked_code)))
(_ (true_print "compiling partial evaled ")) ;(_ (true_print "compiling partial evaled "))
(memo empty_dict) (memo empty_dict)
(ctx (array datasi funcs memo root_marked_env pectx)) (ctx (array datasi funcs memo root_marked_env pectx))
@@ -4534,15 +4537,15 @@
(run-compiler (lambda (f) (run-compiler (lambda (f)
(dlet ( (dlet (
(_ (true_print "reading in!")) ;(_ (true_print "reading in!"))
(read_in (read-string (slurp f))) (read_in (read-string (slurp f)))
(_ (true_print "read in, now evaluating")) ;(_ (true_print "read in, now evaluating"))
(evaled (partial_eval read_in)) (evaled (partial_eval read_in))
(_ (true_print "done partialy evaling, now compiling")) ;(_ (true_print "done partialy evaling, now compiling"))
(bytes (compile evaled)) (bytes (compile evaled))
(_ (true_print "compiled, writng out")) ;(_ (true_print "compiled, writng out"))
(_ (write_file "./csc_out.wasm" bytes)) (_ (write_file "./csc_out.wasm" bytes))
(_ (true_print "written out")) ;(_ (true_print "written out"))
) (void)) ) (void))
)) ))
@@ -4551,7 +4554,12 @@
;(test-most) ;(test-most)
;(single-test) ;(single-test)
;(run-compiler "small_test.kp") ;(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) ;(true_print "GLOBAL_MAX was " GLOBAL_MAX)
;(profile-dump-html) ;(profile-dump-html)
;(profile-dump-list) ;(profile-dump-list)

1
small_demo.kp Normal file
View File

@@ -0,0 +1 @@
(+ 1 2)

1
small_lambda_demo.kp Normal file
View File

@@ -0,0 +1 @@
(wrap (vau () (+ 1 2)))

8
small_macro_demo.kp Normal file
View File

@@ -0,0 +1,8 @@
((wrap (vau (quote)
(vau () (array (quote a) (+ 1 2)))
; impl of quote
)) (vau (x5) x5))

1
small_vau_demo.kp Normal file
View File

@@ -0,0 +1 @@
(vau () (+ 1 2))

2
to_compile.kp
View File

@@ -360,7 +360,7 @@
(and_fold (foldl and true '(true true false true))) (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) ) monad)
) )