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

Bigfix error infinite recursion, error printing, wrap_level not being in hash_comb, extend to_compile.kp a bit

Browse Source
This commit is contained in:
Nathan Braswell
2022-03-02 01:44:20 -05:00
parent dd0463d059
commit 4a273c9ba2
2 changed files with 83 additions and 29 deletions
Download Patch File Download Diff File Expand all files Collapse all files

88
partial_eval.scm
View File

@@ -40,7 +40,15 @@
((_ con then ) (if (let ((x con)) (and (not (equal? (list) x)) x)) then '()))
((_ con then else) (if (let ((x con)) (and (not (equal? (list) x)) x)) then else))))
(define error (lambda args (apply error args)))
(define str (lambda args (begin
(define mp (open-output-string))
((rec-lambda recurse (x) (if (and x (not (equal? '() x))) (begin (display (car x) mp) (recurse (cdr x))) '())) args)
(get-output-string mp))))
(define true_error error)
(define error (lambda args (begin (print "ERROR! About to Error! args are\n") (print (str args)) (apply true_error args))))
; Adapted from https://stackoverflow.com/questions/16335454/reading-from-file-using-scheme WTH
(define (slurp path)
@@ -88,13 +96,14 @@
(empty_dict (array))
(put (lambda (m k v) (cons (array k v) m)))
;(my-alist-ref alist-ref)
(my-alist-ref (lambda (k d) ((rec-lambda recurse (d k i) (cond ((= (len d) i) false)
((= k (idx (idx d i) 0)) (array (idx (idx d i) 1)))
(true (recurse d k (+ 1 i)))))
d k 0)))
(get-value (lambda (d k) (let ((result (my-alist-ref k d)))
(if (array? result) (idx result 0)
(error (print "could not find " k " in " d))))))
(error (str "could not find " k " in " d))))))
(get-value-or-false (lambda (d k) (let ((result (my-alist-ref k d)))
(if (array? result) (idx result 0)
false))))
@@ -126,10 +135,6 @@
((equal? '() l) '())
(#t (append (f (car l)) (recurse f (cdr l)))))
)) f l)))
(str (lambda args (begin
(define mp (open-output-string))
((rec-lambda recurse (x) (if (and x (!= nil x)) (begin (display (car x) mp) (recurse (cdr x))) nil)) args)
(get-output-string mp))))
(print (lambda args (print (apply str args))))
(true_print print)
@@ -233,12 +238,13 @@
) (combine_hash inner_hash end_hash)))))
(hash_comb (lambda (wrap_level env_id de? se variadic params body)
(combine_hash 43
(combine_hash wrap_level
(combine_hash env_id
(combine_hash (mif de? (hash_symbol true de?) 47)
(combine_hash (.hash se)
(combine_hash (hash_bool variadic)
(combine_hash (foldl (lambda (c x) (combine_hash c (hash_symbol true x))) 53 params)
(.hash body)))))))))
(.hash body))))))))))
(hash_prim_comb (lambda (handler_fun real_or_name wrap_level val_head_ok) (combine_hash (combine_hash 59 (hash_symbol true real_or_name))
(combine_hash (if val_head_ok 89 97) wrap_level))))
(hash_val (lambda (x) (cond ((bool? x) (hash_bool x))
@@ -358,7 +364,7 @@
)
) (idx args -1) (array)) 0))))))
(true_str_strip str_strip)
(str_strip (lambda args 0))
;(str_strip (lambda args 0))
;(true_str_strip str_strip)
(print_strip (lambda args (println (apply str_strip args))))
@@ -366,7 +372,7 @@
((= i (- (len dict) 1)) (recurse (.env_marked (idx dict i)) key 0 fail success))
((= key (idx (idx dict i) 0)) (success (idx (idx dict i) 1)))
(true (recurse dict key (+ i 1) fail success)))))
(env-lookup (lambda (env key) (env-lookup-helper (.env_marked env) key 0 (lambda () (error (print_strip key " not found in env " env))) (lambda (x) x))))
(env-lookup (lambda (env key) (env-lookup-helper (.env_marked env) key 0 (lambda () (error (str key " not found in env " (str_strip env)))) (lambda (x) x))))
(strip (let ((helper (rec-lambda recurse (x need_value)
(cond ((val? x) (.val x))
@@ -2159,11 +2165,6 @@
(call '$drop (local.get '$p))
(call '$drop (local.get '$d))))
((bad_not_vau_loc bad_not_vau_length datasi) (alloc_data "\nError: Trying to call a function (not vau) but the parameters caused a compile error\n" datasi))
(bad_not_vau_msg_val (bor (<< bad_not_vau_length 32) bad_not_vau_loc #b011))
((k_log_loc k_log_length datasi) (alloc_data "k_log" datasi))
(k_log_msg_val (bor (<< k_log_length 32) k_log_loc #b011))
((k_log func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$log '(param $p i64) '(param $d i64) '(param $s i64) '(result i64)
@@ -3417,7 +3418,7 @@
((marked_array? c) (if (.marked_array_is_val c) (or (get_passthrough (.hash c) ctx)
(let ((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)))
(dlet ( ((comp_values err ctx) (foldr (dlambda (x (a err ctx)) (dlet (((v c e ctx) (compile-inner ctx x need_value)))
(array (cons 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) ctx)
@@ -3437,6 +3438,7 @@
((datasi funcs memo env pectx) ctx)
(hit_recursion (= 'RECURSE_FAIL (get-value-or-false memo (.hash c))))
;(_ (true_print "hit recursion? " hit_recursion))
(compile_params (lambda (unval_and_eval ctx params)
(foldr (dlambda (x (a err ctx)) (dlet (
@@ -3473,21 +3475,40 @@
(num_params (- (len func_param_values) 1))
(params (slice func_param_values 1 -1))
(func_value (idx func_param_values 0))
((param_codes err ctx) (compile_params false ctx params))
(wrap_level (if (or (comb? func_value) (prim_comb? func_value)) (.any_comb_wrap_level func_value) nil))
; I don't think it makes any sense for a function literal to have wrap > 0
(_ (if (and (!= nil wrap_level) (> wrap_level 0)) (error "call to function literal has wrap >0")))
;; Insert test for the function being a constant to inline
;; Namely, vcond
;; Test for the function being a constant to inline
;; Namely, vcond (also veval!)
) (cond
((!= nil err) (array nil nil (str err " from function params (non-unval-evaled) in call " (str_strip c)) ctx))
((and (prim_comb? func_value) (= (.prim_comb_sym func_value) 'veval)) (dlet (
(_ (if (!= 2 (len params)) (error "call to veval has != 2 params!")))
((datasi funcs memo env pectx) ctx)
((val code err (datasi funcs memo ienv pectx)) (compile-inner (array datasi funcs memo (idx params 1) pectx) (idx params 0) false))
(ctx (array datasi funcs memo env pectx))
; 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))
(full_code (concat (local.get '$s_env)
(local.set '$s_env (mif env_val (i64.const env_val) env_code))
code
(local.set '$tmp)
(local.set '$s_env)
(local.get '$tmp)))
) (array full_code env_err ctx))
(array code nil ctx)))
) (array val code (mif err err env_err) ctx)))
((and (prim_comb? func_value) (= (.prim_comb_sym func_value) 'vcond))
(mif err (array nil nil (str err " from function params in call to comb " (str_strip c)) ctx)
(dlet (
((datasi funcs memo env pectx) ctx)
) (array nil ((rec-lambda recurse (codes i) (cond
((param_codes err ctx) (compile_params false ctx params))
)
(mif err (array nil nil (str err " from function params in call to comb " (str_strip c)) ctx)
(array nil ((rec-lambda recurse (codes i) (cond
((< i (- (len codes) 1)) (_if '_cond_flat '(result i64)
(truthy_test (idx codes i))
(then (idx codes (+ i 1)))
@@ -3497,6 +3518,7 @@
(true (unreachable))
)) param_codes 0) err ctx))))
(true (dlet (
((param_codes first_params_err ctx) (compile_params false ctx params))
((func_val func_code func_err ctx) (compile-inner ctx func_value false))
;(_ (print_strip "func val " func_val " func code " func_code " func err " func_err " param_codes " param_codes " err " err " from " func_value))
(func_code (mif func_val (i64.const func_val) func_code))
@@ -3527,6 +3549,7 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(mif err (concat (call '$print (i64.const bad_not_vau_msg_val))
(call '$print (i64.const bad_unval_params_msg_val))
(call '$print (i64.shl (local.get '$tmp) (i64.const 1)))
(unreachable))
(concat
(local.get '$tmp) ; saving ito restore it
@@ -3561,7 +3584,7 @@
;func_idx
(i32.wrap_i64 (i64.shr_u (local.get '$tmp) (i64.const 35)))
)))
) (array nil result_code func_err ctx)))
) (array nil result_code (mif func_err func_err first_params_err) ctx)))
))))))
((marked_env? c) (or (get_passthrough (.hash c) ctx) (dlet ((e (.env_marked c))
@@ -3590,7 +3613,6 @@
(array (cons kv ka) (cons vv va) ctx)))))
(array (array) (array) ctx)
(slice e 0 -2)))
((uv ucode err ctx) (mif (idx e -1) (compile-inner ctx (idx e -1) need_value)
(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) (if need_value (array nil nil (str "had to generate env access (course " need_value ") for " (str_strip c) "vvs is " vvs " err was " err) ctx) (generate_env_access ctx (.marked_env_idx c) (str " vvs " vvs " uv " uv " or err " err " based off of " (str_strip c)))))
@@ -3651,7 +3673,7 @@
((= 'vapply (.prim_comb_sym c)) (array (bor (<< (- k_vapply dyn_start) 35) (<< (.prim_comb_wrap_level c) 4) #b0001) nil nil ctx))
((= 'lapply (.prim_comb_sym c)) (array (bor (<< (- k_lapply dyn_start) 35) (<< (.prim_comb_wrap_level c) 4) #b0001) nil nil ctx))
((= 'wrap (.prim_comb_sym c)) (array (bor (<< (- k_wrap dyn_start) 35) (<< (.prim_comb_wrap_level c) 4) #b0001) nil nil ctx))
(true (error (str "Can't compile prim comb " (.prim_comb_sym c) " right now")))))
(error (str "Can't compile prim comb " (.prim_comb_sym c) " right now"))))
@@ -4058,7 +4080,7 @@
(print "zip " (zip '(1 2 3) '(4 5 6) '(7 8 9)))
(print (run_partial_eval_test "(+ 1 2)"))
(print) (print)
;(print) (print)
(print (run_partial_eval_test "(cond false 1 true 2)"))
(print (run_partial_eval_test "(log 1)"))
(print (run_partial_eval_test "((vau (x) (+ x 1)) 2)"))
@@ -4391,13 +4413,23 @@
) void)))
(run-compiler (lambda ()
(write_file "./csc_out.wasm" (compile (partial_eval (read-string (slurp "to_compile.kp")))))
(let* (
(_ (true_print "reading in!"))
(read_in (read-string (slurp "to_compile.kp")))
(_ (true_print "read in, now evaluating"))
(evaled (partial_eval read_in))
(_ (true_print "done partialy evaling, now compiling"))
(bytes (compile evaled))
(_ (true_print "compiled, writng out"))
(_ (write_file "./csc_out.wasm" bytes))
(_ (true_print "written out"))
) (void))
))
)
(begin
; (test-most)
; (single-test)
;(test-most)
;(single-test)
(run-compiler)
(profile-dump-html)
;(profile-dump-list)

24
to_compile.kp
View File

@@ -126,6 +126,20 @@
rec-lambda (vau se (n p b) (eval (array Y (array lambda (array n) (array lambda p b))) 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)))
foldr (let (helper (rec-lambda recurse (f z vs i) (if (= i (len (idx vs 0))) z
(lapply f (cons (recurse f z vs (+ i 1)) (map (lambda (x) (idx x i)) vs))))))
(lambda (f z & vs) (helper f z vs 0)))
reverse (lambda (x) (foldl (lambda (acc i) (cons i acc)) (array) x))
zip (lambda (& xs) (lapply foldr (concat (array (lambda (a & ys) (cons ys a)) (array)) xs)))
test0 (map (lambda (x) (+ x 1)) (array 1 2))
test1 (map_i (lambda (i x) (+ x i 1)) (array 1 2))
test2 (filter_i (lambda (i x) (> i 0)) (array 1 2))
@@ -138,6 +152,8 @@
true (* n (recurse (- n 1))))) 5)
test8 ((lambda (a b c) (+ a b c)) 1 13 14)
test9 ((lambda (a (b c)) (+ a b c)) 1 (array 13 14))
test10 (foldl + 0 (array 1 2 3 4 1337))
;monad (array 'open 3 "test_self_out" (lambda (fd code)
; (array 'write fd "wabcdefghijklmnopqrstuvwx" (lambda (written code)
; (array 'exit (if (= 0 written) 12 14))))))
@@ -152,7 +168,13 @@
;monad (array 'write 1 "test_self_out2" (vau (written code) (flat_map (lambda (x) (array 1 x 2)) (array written code))))
;monad (array 'write 1 "test_self_out2" (vau (written code) (flat_map_i (lambda (i x) (array i x 2)) (array written code))))
;monad (array 'write 1 "test_self_out2" (vau (written code) (let ( (a b) (array written code) c (+ a b test8 test9)) c)))
monad (array 'write 1 "test_self_out2" (vau (written code) ((lambda (a (b c)) (+ a b c)) 1 (array written code))))
;monad (array 'write 1 "test_self_out2" (vau (written code) ((lambda (a (b c)) (+ a b c)) 1 (array written code))))
;monad (array 'write 1 "test_self_out2" (vau (written code) test10))
monad (array 'write 1 "test_self_out2" (vau (written code) (foldl + 0 (array written code 1337))))
;monad (array 'write 1 "test_self_out2" (vau (written code) 7))
)
monad
)