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

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)