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

56
partial_eval.scm
View File

@@ -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 "<nil>" done_envs))
((string? x) (array (str "<raw string " x ">") done_envs))
((val? x) (array (str (.val x)) done_envs))
((string? x) (array (true_str "<raw string " 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)))
(array (array) done_envs) (.marked_array_values x))))
(mif (.marked_array_is_val x) (array (str "[" stripped_values "]") done_envs)
(array (str "<a" (.marked_array_is_attempted x) ",r" (needed_for_progress x) ">" 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 "<a" (.marked_array_is_attempted x) ",r" (needed_for_progress x) ">" 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 "<n" (needed_for_progress_slim x) "(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))
(array (true_str "<n (comb " wrap_level " " env_id " " de? " " se_s " " params " " body_s ")>") 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))
(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 <cont(data error_no)>] / ['write fd data <cont(num_written error_no)>] / ['open fd path <cont(new_fd error_no)>] /['exit exit_code])") true))
((bad_read_val _ _ ctx) (compile-inner ctx (marked_val "<error with read>") 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)

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