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

Ah, found additional infinate recursion. In the process of fixing the second, trickier one, caused by compile & partial eval together. Should be fixed? but there's a nil coming out somewhere

Browse Source
This commit is contained in:
Nathan Braswell
2022-01-26 01:55:38 -05:00
parent d4752eddb4
commit 9bc658a1a4
2 changed files with 202 additions and 154 deletions
Download Patch File Download Diff File Expand all files Collapse all files

344
partial_eval.csc
View File

@@ -116,7 +116,9 @@
(nil? (lambda (x) (= nil x))) (nil? (lambda (x) (= nil x)))
(bool? (lambda (x) (or (= #t x) (= #f x)))) (bool? (lambda (x) (or (= #t x) (= #f x))))
(true_print print)
(print (lambda x 0)) (print (lambda x 0))
;(true_print print)
(println print) (println print)
(read-string (lambda (s) (read (open-input-string s)))) (read-string (lambda (s) (read (open-input-string s))))
@@ -254,7 +256,7 @@
((string? x) (hash_string x)) ((string? x) (hash_string x))
((int? x) (hash_num x)) ((int? x) (hash_num x))
(true (error (str "bad thing to hash_val " x)))))) (true (error (str "bad thing to hash_val " x))))))
; 67 71 ; 89 97 101 103 107 109 113 127 131 137 139 149 151 157 163 167 173
(marked_symbol (lambda (progress_idxs x) (array 'marked_symbol (hash_symbol progress_idxs x) progress_idxs x))) (marked_symbol (lambda (progress_idxs x) (array 'marked_symbol (hash_symbol progress_idxs x) progress_idxs x)))
(marked_array (lambda (is_val attempted x) (dlet ( (marked_array (lambda (is_val attempted x) (dlet (
@@ -333,7 +335,9 @@
(true (error (str "some other str_strip? |" x "|"))) (true (error (str "some other str_strip? |" x "|")))
) )
) (idx args -1))))))) ) (idx args -1)))))))
(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)))) (print_strip (lambda args (println (apply str_strip args))))
(env-lookup-helper (rec-lambda recurse (dict key i fail success) (cond ((and (= i (- (len dict) 1)) (= nil (idx dict i))) (fail)) (env-lookup-helper (rec-lambda recurse (dict key i fail success) (cond ((and (= i (- (len dict) 1)) (= nil (idx dict i))) (fail))
@@ -451,20 +455,37 @@
) (marked_env false progress_idxs env_id (concat param_entries possible_de_entry (array de)))))) ) (marked_env false progress_idxs env_id (concat param_entries possible_de_entry (array de))))))
(partial_eval_helper (rec-lambda partial_eval_helper (x only_head env env_stack env_counter indent) (pe_memo_hash (lambda (x only_head progress_now) (combine_hash (.hash x)
(dlet ((for_progress (needed_for_progress x)) (_ (print_strip (indent_str indent) "for_progress " for_progress " for " x))) (combine_hash (if only_head 67
(if (or (= for_progress true) ((rec-lambda rr (i) (cond ((= i (len for_progress)) false) 71)
(if (= true progress_now) 79
(* 83 progress_now))
))))
(get_pe_passthrough (dlambda (hash (env_counter memo) x) (let ((r (get-value-or-false memo hash)))
(cond ((= r false) false)
((= r nil) (array (array env_counter memo) nil x)) ; Nil is for preventing infinite recursion
(true (array (array env_counter memo) nil r))))))
(partial_eval_helper (rec-lambda partial_eval_helper (x only_head env env_stack pectx indent)
(dlet ((for_progress (needed_for_progress x))
(_ (print_strip (indent_str indent) "for_progress " for_progress " for " x))
(progress_now (or (= for_progress true) ((rec-lambda rr (i) (if (= i (len for_progress)) false
(dlet (
; possible if called from a value context in the compiler ; possible if called from a value context in the compiler
; TODO: I think this should be removed and instead the value/code compilers should ; TODO: I think this should be removed and instead the value/code compilers should
; keep track of actual env stacks ; keep track of actual env stacks
((and ((rec-lambda ir (j) (cond ((= j (len env_stack)) false) (this_now ((rec-lambda ir (j) (cond ((= j (len env_stack)) false)
((and (= (idx for_progress i) (.marked_env_idx (idx env_stack j)))
((and (= (idx for_progress i) (.marked_env_idx (idx env_stack j))) (.marked_env_has_vals (idx env_stack j))) true) (.marked_env_has_vals (idx env_stack j))) (idx for_progress i))
(true (ir (+ j 1))))) 0) (true (ir (+ j 1))))
) true) ) 0))
(true (rr (+ i 1))) ) (if this_now this_now (rr (+ i 1))))
)) 0)) )) 0)))
(cond ((val? x) (array env_counter nil x)) )
(if progress_now
; Man this like doubles the interpret length
(or (get_pe_passthrough (pe_memo_hash x only_head progress_now) pectx x)
(cond ((val? x) (array pectx nil x))
((marked_env? x) (let ((dbi (.marked_env_idx x))) ((marked_env? x) (let ((dbi (.marked_env_idx x)))
; compiler calls with empty env stack ; compiler calls with empty env stack
(mif dbi (let* ( (new_env ((rec-lambda rec (i) (cond ((= i (len env_stack)) nil) (mif dbi (let* ( (new_env ((rec-lambda rec (i) (cond ((= i (len env_stack)) nil)
@@ -473,72 +494,74 @@
0)) 0))
(_ (println (str_strip "replacing " x) (str_strip " with (if nonnil) " new_env))) (_ (println (str_strip "replacing " x) (str_strip " with (if nonnil) " new_env)))
) )
(array env_counter nil (if (!= nil new_env) new_env x))) (array pectx nil (if (!= nil new_env) new_env x)))
(array env_counter nil x)))) (array pectx nil x))))
((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)))
(mif (or (and (not (marked_env_real? env)) (not (marked_env_real? se))) ; both aren't real, re-evaluation of creation site (mif (or (and (not (marked_env_real? env)) (not (marked_env_real? se))) ; both aren't real, re-evaluation of creation site
(and (marked_env_real? env) (not (marked_env_real? se)))) ; new env real, but se isn't - creation! (and (marked_env_real? env) (not (marked_env_real? se)))) ; new env real, but se isn't - creation!
(dlet ((inner_env (make_tmp_inner_env params de? env env_id)) (dlet ((inner_env (make_tmp_inner_env params de? env env_id))
((env_counter err evaled_body) (partial_eval_helper body false inner_env (cons inner_env env_stack) env_counter (+ indent 1)))) ((pectx err evaled_body) (partial_eval_helper body false inner_env (cons inner_env env_stack) pectx (+ indent 1))))
(array env_counter err (mif err nil (marked_comb wrap_level env_id de? env variadic params evaled_body)))) (array pectx err (mif err nil (marked_comb wrap_level env_id de? env variadic params evaled_body))))
(array env_counter nil x)))) (array pectx nil x))))
((prim_comb? x) (array env_counter nil x)) ((prim_comb? x) (array pectx nil x))
((marked_symbol? x) (mif (.marked_symbol_is_val x) x ((marked_symbol? x) (mif (.marked_symbol_is_val x) x
(env-lookup-helper (.env_marked env) (.marked_symbol_value x) 0 (env-lookup-helper (.env_marked env) (.marked_symbol_value x) 0
(lambda () (array env_counter (str "could't find " (str_strip x) " in " (str_strip env)) nil)) (lambda () (array pectx (str "could't find " (str_strip x) " in " (str_strip env)) nil))
(lambda (x) (array env_counter nil x))))) (lambda (x) (array pectx nil x)))))
((marked_array? x) (cond ((.marked_array_is_val x) (dlet ( ((env_counter err inner_arr) (foldl (dlambda ((c er ds) p) (dlet (((c e d) (partial_eval_helper p false env env_stack c (+ 1 indent)))) (array c (mif er er e) (concat ds (array d))))) ((marked_array? x) (cond ((.marked_array_is_val x) (dlet ( ((pectx err inner_arr) (foldl (dlambda ((c er ds) p) (dlet (((c e d) (partial_eval_helper p false env env_stack c (+ 1 indent)))) (array c (mif er er e) (concat ds (array d)))))
(array env_counter nil (array)) (array pectx nil (array))
(.marked_array_values x))) (.marked_array_values x)))
) (array env_counter err (mif err nil (marked_array true false inner_arr))))) ) (array pectx err (mif err nil (marked_array true false inner_arr)))))
((= 0 (len (.marked_array_values x))) (array env_counter "Partial eval on empty array" nil)) ((= 0 (len (.marked_array_values x))) (array pectx "Partial eval on empty array" nil))
(true (dlet ((values (.marked_array_values x)) (true (dlet ((values (.marked_array_values x))
(_ (print_strip (indent_str indent) "partial_evaling comb " (idx values 0))) (_ (print_strip (indent_str indent) "partial_evaling comb " (idx values 0)))
((env_counter err comb) (partial_eval_helper (idx values 0) true env env_stack env_counter (+ 1 indent))) ((pectx err comb) (partial_eval_helper (idx values 0) true env env_stack pectx (+ 1 indent)))
; If we haven't evaluated the function before at all, we would like to partially evaluate it so we know ; If we haven't evaluated the function before at all, we would like to partially evaluate it so we know
; what it needs. We'll see if this re-introduces exponentail (I think this should limit it to twice?) ; what it needs. We'll see if this re-introduces exponentail (I think this should limit it to twice?)
((env_counter err comb) (if (and (= nil err) (= true (needed_for_progress comb))) ((pectx err comb) (if (and (= nil err) (= true (needed_for_progress comb)))
(partial_eval_helper comb false env env_stack env_counter (+ 1 indent)) (partial_eval_helper comb false env env_stack pectx (+ 1 indent))
(array env_counter err comb))) (array pectx err comb)))
(literal_params (slice values 1 -1)) (literal_params (slice values 1 -1))
(_ (println (indent_str indent) "Going to do an array call!")) (_ (println (indent_str indent) "Going to do an array call!"))
;(_ (true_print (indent_str indent) "Going to do an array call!"))
(indent (+ 1 indent)) (indent (+ 1 indent))
(_ (print_strip (indent_str indent) "total is " x)) (_ (print_strip (indent_str indent) "total is " x))
;(_ (true_print (indent_str indent) "total is " (true_str_strip x)))
) )
(mif err (array env_counter err nil) (mif err (array pectx err nil)
(cond ((prim_comb? comb) ((.prim_comb comb) only_head env env_stack env_counter literal_params (+ 1 indent))) (cond ((prim_comb? comb) ((.prim_comb comb) only_head env env_stack pectx literal_params (+ 1 indent)))
((comb? comb) (dlet ( ((comb? comb) (dlet (
(map_rp_eval (lambda (env_counter ps) (foldl (dlambda ((c er ds) p) (dlet (((c e d) (partial_eval_helper p false env env_stack c (+ 1 indent)))) (array c (mif er er e) (concat ds (array d))))) (map_rp_eval (lambda (pectx ps) (foldl (dlambda ((c er ds) p) (dlet (((c e d) (partial_eval_helper p false env env_stack c (+ 1 indent)))) (array c (mif er er e) (concat ds (array d)))))
(array env_counter nil (array)) (array pectx nil (array))
ps))) ps)))
((wrap_level env_id de? se variadic params body) (.comb comb)) ((wrap_level env_id de? se variadic params body) (.comb comb))
(ensure_val_params (map ensure_val literal_params)) (ensure_val_params (map ensure_val literal_params))
((ok env_counter err single_eval_params_if_appropriate appropriatly_evaled_params) ((rec-lambda param-recurse (wrap cparams env_counter single_eval_params_if_appropriate) ((ok pectx err single_eval_params_if_appropriate appropriatly_evaled_params) ((rec-lambda param-recurse (wrap cparams pectx single_eval_params_if_appropriate)
(dlet (((env_counter er pre_evaled) (map_rp_eval env_counter cparams))) (dlet (((pectx er pre_evaled) (map_rp_eval pectx cparams)))
(mif er (array false env_counter er nil nil) (mif er (array false pectx er nil nil)
(mif (!= 0 wrap) (mif (!= 0 wrap)
(dlet (((ok unval_params) (try_unval_array pre_evaled))) (dlet (((ok unval_params) (try_unval_array pre_evaled)))
(mif (not ok) (array ok env_counter nil single_eval_params_if_appropriate nil) (mif (not ok) (array ok pectx nil single_eval_params_if_appropriate nil)
(dlet (((env_counter err evaled_params) (map_rp_eval env_counter unval_params))) (dlet (((pectx err evaled_params) (map_rp_eval pectx unval_params)))
(param-recurse (- wrap 1) evaled_params env_counter (param-recurse (- wrap 1) evaled_params pectx
(cond ((= nil single_eval_params_if_appropriate) 1) (cond ((= nil single_eval_params_if_appropriate) 1)
((= 1 single_eval_params_if_appropriate) pre_evaled) ((= 1 single_eval_params_if_appropriate) pre_evaled)
(true single_eval_params_if_appropriate)) (true single_eval_params_if_appropriate))
)))) ))))
(array true env_counter nil (if (= 1 single_eval_params_if_appropriate) pre_evaled single_eval_params_if_appropriate) pre_evaled)))) (array true pectx nil (if (= 1 single_eval_params_if_appropriate) pre_evaled single_eval_params_if_appropriate) pre_evaled))))
) wrap_level ensure_val_params env_counter nil)) ) wrap_level ensure_val_params pectx nil))
(correct_fail_params (if (!= nil single_eval_params_if_appropriate) single_eval_params_if_appropriate (correct_fail_params (if (!= nil single_eval_params_if_appropriate) single_eval_params_if_appropriate
literal_params)) literal_params))
(ok_and_non_later (and ok (is_all_values appropriatly_evaled_params))) (ok_and_non_later (and ok (is_all_values appropriatly_evaled_params)))
) (mif err (array env_counter err nil) ) (mif err (array pectx err nil)
(mif (not ok_and_non_later) (begin (print_strip (indent_str indent) "Can't evaluate params properly, delying" x) (mif (not ok_and_non_later) (begin (print_strip (indent_str indent) "Can't evaluate params properly, delying" x)
(print_strip (indent_str indent) "so returning with " (marked_array false true (cons comb correct_fail_params))) (print_strip (indent_str indent) "so returning with " (marked_array false true (cons comb correct_fail_params)))
(array env_counter nil (marked_array false true (cons comb correct_fail_params)))) (array pectx nil (marked_array false true (cons comb correct_fail_params))))
(dlet ( (dlet (
(final_params (mif variadic (concat (slice appropriatly_evaled_params 0 (- (len params) 1)) (final_params (mif variadic (concat (slice appropriatly_evaled_params 0 (- (len params) 1))
(array (marked_array true false (slice appropriatly_evaled_params (- (len params) 1) -1)))) (array (marked_array true false (slice appropriatly_evaled_params (- (len params) 1) -1))))
@@ -552,8 +575,14 @@
(_ (print_strip (indent_str indent) " with inner_env is " inner_env)) (_ (print_strip (indent_str indent) " with inner_env is " inner_env))
(_ (print_strip (indent_str indent) "going to eval " body)) (_ (print_strip (indent_str indent) "going to eval " body))
((env_counter func_err func_result) (partial_eval_helper body only_head inner_env (cons inner_env env_stack) env_counter (+ 1 indent))) ; prevent infinite recursion
) (mif func_err (array env_counter func_err nil) (dlet ( ((env_counter memo) pectx)
(this_hash (pe_memo_hash x only_head progress_now))
(memo (put memo this_hash nil))
(pectx (array env_counter memo))
((pectx func_err func_result) (partial_eval_helper body only_head inner_env (cons inner_env env_stack) pectx (+ 1 indent)))
) (mif func_err (array pectx func_err nil) (dlet (
(_ (print_strip (indent_str indent) "evaled result of function call is " func_result)) (_ (print_strip (indent_str indent) "evaled result of function call is " func_result))
(able_to_sub_env (not (check_for_env_id_in_result env_id func_result))) (able_to_sub_env (not (check_for_env_id_in_result env_id func_result)))
(result_is_later (later_head? func_result)) (result_is_later (later_head? func_result))
@@ -567,55 +596,58 @@
(result (mif (or (not able_to_sub_env) (and result_is_later result_closes_over)) (result (mif (or (not able_to_sub_env) (and result_is_later result_closes_over))
(marked_array false true (cons comb correct_fail_params)) (marked_array false true (cons comb correct_fail_params))
func_result)) func_result))
) (array env_counter nil result)))))))) ((env_counter memo) pectx)
((later_head? comb) (array env_counter nil (marked_array false true (cons comb literal_params)))) (memo (put memo this_hash result))
(true (array env_counter (str "impossible comb value " x) nil)))))))) (pectx (array env_counter memo))
(true (array env_counter (str "impossible partial_eval value " x) nil)) ) (array pectx nil result))))))))
) ((later_head? comb) (array pectx nil (marked_array false true (cons comb literal_params))))
(true (array pectx (str "impossible comb value " x) nil))))))))
(true (array pectx (str "impossible partial_eval value " x) nil))
))
; otherwise, we can't make progress yet ; otherwise, we can't make progress yet
(begin (print_strip (indent_str indent) "Not evaluating " x) (print (indent_str indent) "comparing to env stack " env_stack) (array env_counter nil x)))) (begin (print_strip (indent_str indent) "Not evaluating " x) (print (indent_str indent) "comparing to env stack " env_stack) (array pectx nil x))))
)) ))
; !!!!!! ; !!!!!!
; ! I think needs_params_val_lambda should be combined with parameters_evaled_proxy ; ! I think needs_params_val_lambda should be combined with parameters_evaled_proxy
; !!!!!! ; !!!!!!
(parameters_evaled_proxy (rec-lambda recurse (pasthr_ie inner_f) (lambda (only_head de env_stack env_counter params indent) (dlet ( (parameters_evaled_proxy (rec-lambda recurse (pasthr_ie inner_f) (lambda (only_head de env_stack pectx params indent) (dlet (
;(_ (println "partial_evaling params in parameters_evaled_proxy is " params)) ;(_ (println "partial_evaling params in parameters_evaled_proxy is " params))
((evaled_params l err env_counter) (foldl (dlambda ((ac i err env_counter) p) (dlet (((env_counter er p) (partial_eval_helper p (if (and only_head (= i pasthr_ie)) only_head false) de env_stack env_counter (+ 1 indent)))) ((evaled_params l err pectx) (foldl (dlambda ((ac i err pectx) p) (dlet (((pectx er p) (partial_eval_helper p (if (and only_head (= i pasthr_ie)) only_head false) de env_stack pectx (+ 1 indent))))
(array (concat ac (array p)) (+ i 1) (mif err err er) env_counter))) (array (concat ac (array p)) (+ i 1) (mif err err er) pectx)))
(array (array) 0 nil env_counter) (array (array) 0 nil pectx)
params)) params))
) (mif err (array env_counter err nil) ) (mif err (array pectx err nil)
(inner_f (lambda args (apply (recurse pasthr_ie inner_f) args)) only_head de env_stack env_counter evaled_params indent)))))) (inner_f (lambda args (apply (recurse pasthr_ie inner_f) args)) only_head de env_stack pectx evaled_params indent))))))
(needs_params_val_lambda_inner (lambda (f_sym actual_function) (let* ( (needs_params_val_lambda_inner (lambda (f_sym actual_function) (let* (
(handler (rec-lambda recurse (only_head de env_stack env_counter params indent) (dlet ( (handler (rec-lambda recurse (only_head de env_stack pectx params indent) (dlet (
;_ (println "partial_evaling params in need_params_val_lambda for " f_sym " is " params) ;_ (println "partial_evaling params in need_params_val_lambda for " f_sym " is " params)
((env_counter err evaled_params) (foldl (dlambda ((c err ds) p) (dlet (((c er d) (partial_eval_helper p false de env_stack c (+ 1 indent)))) ((pectx err evaled_params) (foldl (dlambda ((c err ds) p) (dlet (((c er d) (partial_eval_helper p false de env_stack c (+ 1 indent))))
(array c (mif err err er) (concat ds (array d))))) (array c (mif err err er) (concat ds (array d)))))
(array env_counter nil (array)) params)) (array pectx nil (array)) params))
) )
; TODO: Should this be is_all_head_values? ; TODO: Should this be is_all_head_values?
(mif err (array env_counter err nil) (mif err (array pectx err nil)
(array env_counter nil (mif (is_all_values evaled_params) (mark (apply actual_function (map strip evaled_params))) (array pectx nil (mif (is_all_values evaled_params) (mark (apply actual_function (map strip evaled_params)))
(marked_array false true (cons (marked_prim_comb recurse f_sym) evaled_params)))))))) (marked_array false true (cons (marked_prim_comb recurse f_sym) evaled_params))))))))
) (array f_sym (marked_prim_comb handler f_sym))))) ) (array f_sym (marked_prim_comb handler f_sym)))))
(give_up_eval_params_inner (lambda (f_sym actual_function) (let* ( (give_up_eval_params_inner (lambda (f_sym actual_function) (let* (
(handler (rec-lambda recurse (only_head de env_stack env_counter params indent) (dlet ( (handler (rec-lambda recurse (only_head de env_stack pectx params indent) (dlet (
;_ (println "partial_evaling params in give_up_eval_params for " f_sym " is " params) ;_ (println "partial_evaling params in give_up_eval_params for " f_sym " is " params)
((env_counter err evaled_params) (foldl (dlambda ((c err ds) p) (dlet (((c er d) (partial_eval_helper p only_head de env_stack c (+ 1 indent)))) ((pectx err evaled_params) (foldl (dlambda ((c err ds) p) (dlet (((c er d) (partial_eval_helper p only_head de env_stack c (+ 1 indent))))
(array c (mif err err er) (concat ds (array d))))) (array c (mif err err er) (concat ds (array d)))))
(array env_counter nil (array)) params)) (array pectx nil (array)) params))
) )
(mif err (array env_counter err nil) (mif err (array pectx err nil)
(array env_counter nil (marked_array false true (cons (marked_prim_comb recurse f_sym) evaled_params))))))) (array pectx nil (marked_array false true (cons (marked_prim_comb recurse f_sym) evaled_params)))))))
) (array f_sym (marked_prim_comb handler f_sym))))) ) (array f_sym (marked_prim_comb handler f_sym)))))
(root_marked_env (marked_env true nil nil (array (root_marked_env (marked_env true nil nil (array
(array 'vau (marked_prim_comb (rec-lambda recurse (only_head de env_stack env_counter params indent) (dlet ( (array 'vau (marked_prim_comb (rec-lambda recurse (only_head de env_stack pectx params indent) (dlet (
(mde? (mif (= 3 (len params)) (idx params 0) nil)) (mde? (mif (= 3 (len params)) (idx params 0) nil))
(vau_mde? (mif (= nil mde?) (array) (array mde?))) (vau_mde? (mif (= nil mde?) (array) (array mde?)))
(_ (print (indent_str indent) "mde? is " mde?)) (_ (print (indent_str indent) "mde? is " mde?))
@@ -629,44 +661,46 @@
((variadic vau_params) (foldl (dlambda ((v a) x) (mif (= x '&) (array true a) (array v (concat a (array x))))) (array false (array)) raw_params)) ((variadic vau_params) (foldl (dlambda ((v a) x) (mif (= x '&) (array true a) (array v (concat a (array x))))) (array false (array)) raw_params))
(body (mif (= nil de?) (idx params 1) (idx params 2))) (body (mif (= nil de?) (idx params 1) (idx params 2)))
((env_counter memo) pectx)
(new_id env_counter) (new_id env_counter)
(env_counter (+ 1 env_counter)) (env_counter (+ 1 env_counter))
((env_counter err pe_body) (if only_head (begin (print "skipping inner eval cuz only_head") (array env_counter nil body)) (pectx (array env_counter memo))
((pectx err pe_body) (if only_head (begin (print "skipping inner eval cuz only_head") (array pectx nil body))
(dlet ( (dlet (
(inner_env (make_tmp_inner_env vau_params de? de new_id)) (inner_env (make_tmp_inner_env vau_params de? de new_id))
(_ (print_strip (indent_str indent) "in vau, evaluating body with 'later params - " body)) (_ (print_strip (indent_str indent) "in vau, evaluating body with 'later params - " body))
((env_counter err pe_body) (partial_eval_helper body false inner_env (cons inner_env env_stack) env_counter (+ 1 indent))) ((pectx err pe_body) (partial_eval_helper body false inner_env (cons inner_env env_stack) pectx (+ 1 indent)))
(_ (print_strip (indent_str indent) "in vau, result of evaluating body was " pe_body)) (_ (print_strip (indent_str indent) "in vau, result of evaluating body was " pe_body))
) (array env_counter err pe_body)))) ) (array pectx err pe_body))))
) (mif err (array env_counter err nil) (array env_counter nil (marked_comb 0 new_id de? de variadic vau_params pe_body))) ) (mif err (array pectx err nil) (array pectx nil (marked_comb 0 new_id de? de variadic vau_params pe_body)))
)) 'vau)) )) 'vau))
(array 'wrap (marked_prim_comb (parameters_evaled_proxy 0 (dlambda (recurse only_head de env_stack env_counter (evaled) indent) (array 'wrap (marked_prim_comb (parameters_evaled_proxy 0 (dlambda (recurse only_head de env_stack pectx (evaled) indent)
(array env_counter nil (mif (comb? evaled) (dlet (((wrap_level env_id de? se variadic params body) (.comb evaled)) (array pectx nil (mif (comb? evaled) (dlet (((wrap_level env_id de? se variadic params body) (.comb evaled))
(wrapped_marked_fun (marked_comb (+ 1 wrap_level) env_id de? se variadic params body)) (wrapped_marked_fun (marked_comb (+ 1 wrap_level) env_id de? se variadic params body))
) wrapped_marked_fun) ) wrapped_marked_fun)
(marked_array false true (array (marked_prim_comb recurse 'wrap) evaled))))) (marked_array false true (array (marked_prim_comb recurse 'wrap) evaled)))))
) 'wrap)) ) 'wrap))
(array 'unwrap (marked_prim_comb (parameters_evaled_proxy 0 (dlambda (recurse only_head de env_stack env_counter (evaled) indent) (array 'unwrap (marked_prim_comb (parameters_evaled_proxy 0 (dlambda (recurse only_head de env_stack pectx (evaled) indent)
(array env_counter nil (mif (comb? evaled) (dlet (((wrap_level env_id de? se variadic params body) (.comb evaled)) (array pectx nil (mif (comb? evaled) (dlet (((wrap_level env_id de? se variadic params body) (.comb evaled))
(unwrapped_marked_fun (marked_comb (- wrap_level 1) env_id de? se variadic params body)) (unwrapped_marked_fun (marked_comb (- wrap_level 1) env_id de? se variadic params body))
) unwrapped_marked_fun) ) unwrapped_marked_fun)
(marked_array false true (array (marked_prim_comb recurse 'unwrap) evaled))))) (marked_array false true (array (marked_prim_comb recurse 'unwrap) evaled)))))
) 'unwrap)) ) 'unwrap))
(array 'eval (marked_prim_comb (rec-lambda recurse (only_head de env_stack env_counter params indent) (dlet ( (array 'eval (marked_prim_comb (rec-lambda recurse (only_head de env_stack pectx params indent) (dlet (
(self (marked_prim_comb recurse 'eval)) (self (marked_prim_comb recurse 'eval))
(_ (print_strip (indent_str indent) " partial_evaling_body the first time " (idx params 0))) (_ (print_strip (indent_str indent) " partial_evaling_body the first time " (idx params 0)))
((env_counter body_err body1) (partial_eval_helper (idx params 0) false de env_stack env_counter (+ 1 indent))) ((pectx body_err body1) (partial_eval_helper (idx params 0) false de env_stack pectx (+ 1 indent)))
(_ (print_strip (indent_str indent) "after first eval of param " body1)) (_ (print_strip (indent_str indent) "after first eval of param " body1))
((env_counter env_err eval_env) (mif (= 2 (len params)) (partial_eval_helper (idx params 1) false de env_stack env_counter (+ 1 indent)) ((pectx env_err eval_env) (mif (= 2 (len params)) (partial_eval_helper (idx params 1) false de env_stack pectx (+ 1 indent))
(array env_counter nil de))) (array pectx nil de)))
(eval_env_v (mif (= 2 (len params)) (array eval_env) (array))) (eval_env_v (mif (= 2 (len params)) (array eval_env) (array)))
) (mif (or (!= nil body_err) (!= nil env_err)) (array env_counter (mif body_err body_err env_err) nil) ) (mif (or (!= nil body_err) (!= nil env_err)) (array pectx (mif body_err body_err env_err) nil)
(mif (not (marked_env? eval_env)) (array env_counter (mif body_err body_err env_err) (marked_array false true (concat (array self body1) eval_env_v))) (mif (not (marked_env? eval_env)) (array pectx (mif body_err body_err env_err) (marked_array false true (concat (array self body1) eval_env_v)))
(dlet ( (dlet (
; Is this safe? Could this not move eval_env_v inside a comb? ; Is this safe? Could this not move eval_env_v inside a comb?
; With this, we don't actually fail as this is always a legitimate uneval ; With this, we don't actually fail as this is always a legitimate uneval
@@ -674,28 +708,28 @@
((ok unval_body) (try_unval body1 fail_handler)) ((ok unval_body) (try_unval body1 fail_handler))
(self_fallback (fail_handler body1)) (self_fallback (fail_handler body1))
(_ (print_strip (indent_str indent) "partial_evaling body for the second time in eval " unval_body)) (_ (print_strip (indent_str indent) "partial_evaling body for the second time in eval " unval_body))
((env_counter err body2) (mif (= self_fallback unval_body) (array env_counter nil self_fallback) ((pectx err body2) (mif (= self_fallback unval_body) (array pectx nil self_fallback)
(partial_eval_helper unval_body only_head eval_env env_stack env_counter (+ 1 indent)))) (partial_eval_helper unval_body only_head eval_env env_stack pectx (+ 1 indent))))
(_ (print_strip (indent_str indent) "and body2 is " body2)) (_ (print_strip (indent_str indent) "and body2 is " body2))
) (mif err (array env_counter err nil) (array env_counter nil body2))))) ) (mif err (array pectx err nil) (array pectx nil body2)))))
)) 'eval)) )) 'eval))
(array 'cond (marked_prim_comb (rec-lambda recurse (only_head de env_stack env_counter params indent) (array 'cond (marked_prim_comb (rec-lambda recurse (only_head de env_stack pectx params indent)
(mif (!= 0 (% (len params) 2)) (array env_counter (str "partial eval cond with odd params " params) nil) (mif (!= 0 (% (len params) 2)) (array pectx (str "partial eval cond with odd params " params) nil)
((rec-lambda recurse_inner (i so_far env_counter) ((rec-lambda recurse_inner (i so_far pectx)
(dlet (((env_counter err evaled_cond) (partial_eval_helper (idx params i) false de env_stack env_counter (+ 1 indent))) (dlet (((pectx err evaled_cond) (partial_eval_helper (idx params i) false de env_stack pectx (+ 1 indent)))
(_ (print (indent_str indent) "in cond cond " (idx params i) " evaluated to " evaled_cond))) (_ (print (indent_str indent) "in cond cond " (idx params i) " evaluated to " evaled_cond)))
(cond ((!= nil err) (array env_counter err nil)) (cond ((!= nil err) (array pectx err nil))
((later_head? evaled_cond) (dlet ( ((env_counter err arm) (if only_head (array env_counter nil (idx params (+ i 1))) ((later_head? evaled_cond) (dlet ( ((pectx err arm) (if only_head (array pectx nil (idx params (+ i 1)))
(partial_eval_helper (idx params (+ i 1)) false de env_stack env_counter (+ 1 indent)))) (partial_eval_helper (idx params (+ i 1)) false de env_stack pectx (+ 1 indent))))
) (mif err (array env_counter err nil) ) (mif err (array pectx err nil)
(recurse_inner (+ 2 i) (concat so_far (array evaled_cond arm)) env_counter)))) (recurse_inner (+ 2 i) (concat so_far (array evaled_cond arm)) pectx))))
((false? evaled_cond) (recurse_inner (+ 2 i) so_far env_counter)) ((false? evaled_cond) (recurse_inner (+ 2 i) so_far pectx))
((= (len params) i) (array env_counter nil (marked_array false true (cons (marked_prim_comb recurse 'cond) so_far)))) ((= (len params) i) (array pectx nil (marked_array false true (cons (marked_prim_comb recurse 'cond) so_far))))
(true (dlet (((env_counter err evaled_body) (partial_eval_helper (idx params (+ 1 i)) only_head de env_stack env_counter (+ 1 indent)))) (true (dlet (((pectx err evaled_body) (partial_eval_helper (idx params (+ 1 i)) only_head de env_stack pectx (+ 1 indent))))
(mif err (array env_counter err nil) (array env_counter nil (mif (!= (len so_far) 0) (marked_array false true (cons (marked_prim_comb recurse 'cond) (concat so_far (array evaled_cond evaled_body)))) (mif err (array pectx err nil) (array pectx nil (mif (!= (len so_far) 0) (marked_array false true (cons (marked_prim_comb recurse 'cond) (concat so_far (array evaled_cond evaled_body))))
evaled_body))))) evaled_body)))))
))) 0 (array) env_counter) ))) 0 (array) pectx)
) )
) 'cond)) ) 'cond))
@@ -703,16 +737,16 @@
(needs_params_val_lambda int?) (needs_params_val_lambda int?)
(needs_params_val_lambda string?) (needs_params_val_lambda string?)
(array 'combiner? (marked_prim_comb (parameters_evaled_proxy nil (dlambda (recurse only_head de env_stack env_counter (evaled_param) indent) (array 'combiner? (marked_prim_comb (parameters_evaled_proxy nil (dlambda (recurse only_head de env_stack pectx (evaled_param) indent)
(array env_counter nil (cond (array pectx nil (cond
((comb? evaled_param) (marked_val true)) ((comb? evaled_param) (marked_val true))
((prim_comb? evaled_param) (marked_val true)) ((prim_comb? evaled_param) (marked_val true))
((later_head? evaled_param) (marked_array false true (array (marked_prim_comb recurse 'combiner?) evaled_param))) ((later_head? evaled_param) (marked_array false true (array (marked_prim_comb recurse 'combiner?) evaled_param)))
(true (marked_val false)) (true (marked_val false))
)) ))
)) 'combiner?)) )) 'combiner?))
(array 'env? (marked_prim_comb (parameters_evaled_proxy nil (dlambda (recurse only_head de env_stack env_counter (evaled_param) indent) (array 'env? (marked_prim_comb (parameters_evaled_proxy nil (dlambda (recurse only_head de env_stack pectx (evaled_param) indent)
(array env_counter nil (cond (array pectx nil (cond
((marked_env? evaled_param) (marked_val true)) ((marked_env? evaled_param) (marked_val true))
((later_head? evaled_param) (marked_array false true (array (marked_prim_comb recurse 'env?) evaled_param))) ((later_head? evaled_param) (marked_array false true (array (marked_prim_comb recurse 'env?) evaled_param)))
(true (marked_val false)) (true (marked_val false))
@@ -723,8 +757,8 @@
(needs_params_val_lambda str-to-symbol) (needs_params_val_lambda str-to-symbol)
(needs_params_val_lambda get-text) (needs_params_val_lambda get-text)
(array 'array? (marked_prim_comb (parameters_evaled_proxy nil (dlambda (recurse only_head de env_stack env_counter (evaled_param) indent) (array 'array? (marked_prim_comb (parameters_evaled_proxy nil (dlambda (recurse only_head de env_stack pectx (evaled_param) indent)
(array env_counter nil (cond (array pectx nil (cond
((later_head? evaled_param) (marked_array false true (array (marked_prim_comb recurse 'array?) evaled_param))) ((later_head? evaled_param) (marked_array false true (array (marked_prim_comb recurse 'array?) evaled_param)))
((marked_array? evaled_param) (marked_val true)) ((marked_array? evaled_param) (marked_val true))
(true (marked_val false)) (true (marked_val false))
@@ -735,32 +769,32 @@
; We need to be able to differentiate between half-and-half arrays ; We need to be able to differentiate between half-and-half arrays
; for when we ensure_params_values or whatever, because that's super wrong ; for when we ensure_params_values or whatever, because that's super wrong
; Maybe we can now with progress_idxs? ; Maybe we can now with progress_idxs?
(array 'array (marked_prim_comb (parameters_evaled_proxy nil (lambda (recurse only_head de env_stack env_counter evaled_params indent) (array 'array (marked_prim_comb (parameters_evaled_proxy nil (lambda (recurse only_head de env_stack pectx evaled_params indent)
(array env_counter nil (mif (is_all_values evaled_params) (marked_array true false evaled_params) (array pectx nil (mif (is_all_values evaled_params) (marked_array true false evaled_params)
(marked_array false true (cons (marked_prim_comb recurse 'array) evaled_params)))) (marked_array false true (cons (marked_prim_comb recurse 'array) evaled_params))))
)) 'array)) )) 'array))
(array 'len (marked_prim_comb (parameters_evaled_proxy nil (dlambda (recurse only_head de env_stack env_counter (evaled_param) indent) (array 'len (marked_prim_comb (parameters_evaled_proxy nil (dlambda (recurse only_head de env_stack pectx (evaled_param) indent)
(array env_counter nil (cond (array pectx nil (cond
((later_head? evaled_param) (marked_array false true (array (marked_prim_comb recurse 'len) evaled_param))) ((later_head? evaled_param) (marked_array false true (array (marked_prim_comb recurse 'len) evaled_param)))
((marked_array? evaled_param) (marked_val (len (.marked_array_values evaled_param)))) ((marked_array? evaled_param) (marked_val (len (.marked_array_values evaled_param))))
(true (error (str "bad type to len " evaled_param))) (true (error (str "bad type to len " evaled_param)))
)) ))
)) 'len)) )) 'len))
(array 'idx (marked_prim_comb (parameters_evaled_proxy nil (dlambda (recurse only_head de env_stack env_counter (evaled_array evaled_idx) indent) (array 'idx (marked_prim_comb (parameters_evaled_proxy nil (dlambda (recurse only_head de env_stack pectx (evaled_array evaled_idx) indent)
(array env_counter nil (cond (array pectx nil (cond
((and (val? evaled_idx) (marked_array? evaled_array) (.marked_array_is_val evaled_array)) (idx (.marked_array_values evaled_array) (.val evaled_idx))) ((and (val? evaled_idx) (marked_array? evaled_array) (.marked_array_is_val evaled_array)) (idx (.marked_array_values evaled_array) (.val evaled_idx)))
(true (marked_array false true (array (marked_prim_comb recurse 'idx) evaled_array evaled_idx))) (true (marked_array false true (array (marked_prim_comb recurse 'idx) evaled_array evaled_idx)))
)) ))
)) 'idx)) )) 'idx))
(array 'slice (marked_prim_comb (parameters_evaled_proxy nil (dlambda (recurse only_head de env_stack env_counter (evaled_array evaled_begin evaled_end) indent) (array 'slice (marked_prim_comb (parameters_evaled_proxy nil (dlambda (recurse only_head de env_stack pectx (evaled_array evaled_begin evaled_end) indent)
(array env_counter nil (cond (array pectx nil (cond
((and (val? evaled_begin) (val? evaled_end) (marked_array? evaled_array) (.marked_array_is_val evaled_array)) ((and (val? evaled_begin) (val? evaled_end) (marked_array? evaled_array) (.marked_array_is_val evaled_array))
(marked_array true false (slice (.marked_array_values evaled_array) (.val evaled_begin) (.val evaled_end)))) (marked_array true false (slice (.marked_array_values evaled_array) (.val evaled_begin) (.val evaled_end))))
(true (marked_array false true (array (marked_prim_comb recurse 'slice) evaled_array evaled_begin evaled_end))) (true (marked_array false true (array (marked_prim_comb recurse 'slice) evaled_array evaled_begin evaled_end)))
)) ))
)) 'slice)) )) 'slice))
(array 'concat (marked_prim_comb (parameters_evaled_proxy nil (lambda (recurse only_head de env_stack env_counter evaled_params indent) (array 'concat (marked_prim_comb (parameters_evaled_proxy nil (lambda (recurse only_head de env_stack pectx evaled_params indent)
(array env_counter nil (cond (array pectx nil (cond
((foldl (lambda (a x) (and a (and (marked_array? x) (.marked_array_is_val x)))) true evaled_params) (marked_array true false (lapply concat (map (lambda (x) ((foldl (lambda (a x) (and a (and (marked_array? x) (.marked_array_is_val x)))) true evaled_params) (marked_array true false (lapply concat (map (lambda (x)
(.marked_array_values x)) (.marked_array_values x))
evaled_params)))) evaled_params))))
@@ -802,7 +836,7 @@
))) )))
(partial_eval (lambda (x) (partial_eval_helper (mark x) false root_marked_env (array) 0 0))) (partial_eval (lambda (x) (partial_eval_helper (mark x) false root_marked_env (array) (array 0 (array)) 0)))
;; WASM ;; WASM
; Vectors and Values ; Vectors and Values
@@ -1387,7 +1421,7 @@
(i64_le_hexify (lambda (x) (le_hexify_helper x 8))) (i64_le_hexify (lambda (x) (le_hexify_helper x 8)))
(i32_le_hexify (lambda (x) (le_hexify_helper x 4))) (i32_le_hexify (lambda (x) (le_hexify_helper x 4)))
(compile (dlambda ((env_counter partial_eval_err marked_code)) (mif partial_eval_err (error partial_eval_err) (wasm_to_binary (module (compile (dlambda ((pectx partial_eval_err marked_code)) (mif partial_eval_err (error partial_eval_err) (wasm_to_binary (module
(import "wasi_unstable" "path_open" (import "wasi_unstable" "path_open"
'(func $path_open (param i32 i32 i32 i32 i32 i64 i64 i32 i32) '(func $path_open (param i32 i32 i32 i32 i32 i64 i64 i32 i32)
(result i32))) (result i32)))
@@ -3039,8 +3073,8 @@
(unreachable) (unreachable)
)))) ))))
(get_passthrough (dlambda (hash (datasi funcs memo env env_counter)) (let ((r (get-value-or-false memo hash))) (get_passthrough (dlambda (hash (datasi funcs memo env pectx)) (let ((r (get-value-or-false memo hash)))
(if r (array r nil nil (array datasi funcs memo env env_counter)) #f)))) (if r (array r nil nil (array datasi funcs memo env pectx)) #f))))
; This is the second run at this, and is a little interesting ; This is the second run at this, and is a little interesting
; It can return a value OR code OR an error string. An error string should be propegated, ; It can return a value OR code OR an error string. An error string should be propegated,
@@ -3048,32 +3082,32 @@
; may not be a Vau. When it recurses, if the thing you're currently compiling could be a value ; may not be a Vau. When it recurses, if the thing you're currently compiling could be a value
; but your recursive calls return code, you will likely have to swap back to code. ; but your recursive calls return code, you will likely have to swap back to code.
; ctx is (datasi funcs memo env env_counter) ; ctx is (datasi funcs memo env pectx)
; return is (value? code? error? (datasi funcs memo env env_counter)) ; return is (value? code? error? (datasi funcs memo env pectx))
(compile-inner (rec-lambda compile-inner (ctx c) (cond (compile-inner (rec-lambda compile-inner (ctx c) (cond
((val? c) (let ((v (.val c))) ((val? c) (let ((v (.val c)))
(cond ((int? v) (array (<< v 1) nil nil ctx)) (cond ((int? v) (array (<< v 1) nil nil ctx))
((= true v) (array true_val nil nil ctx)) ((= true v) (array true_val nil nil ctx))
((= false v) (array false_val nil nil ctx)) ((= false v) (array false_val nil nil ctx))
((str? v) (or (get_passthrough (.hash c) ctx) ((str? v) (or (get_passthrough (.hash c) ctx)
(dlet ( ((datasi funcs memo env env_counter) ctx) (dlet ( ((datasi funcs memo env pectx) ctx)
((c_loc c_len datasi) (alloc_data v datasi)) ((c_loc c_len datasi) (alloc_data v datasi))
(a (bor (<< c_len 32) c_loc #b011)) (a (bor (<< c_len 32) c_loc #b011))
(memo (put memo (.hash c) a)) (memo (put memo (.hash c) a))
) (array a nil nil (array datasi funcs memo env env_counter))))) ) (array a nil nil (array datasi funcs memo env pectx)))))
(true (error (str "Can't compile impossible value " v)))))) (true (error (str "Can't compile impossible value " v))))))
((marked_symbol? c) (cond ((.marked_symbol_is_val c) (or ;(begin (print "pre get_passthrough " (.hash c) "ctx is " ctx ) ((marked_symbol? c) (cond ((.marked_symbol_is_val c) (or ;(begin (print "pre get_passthrough " (.hash c) "ctx is " ctx )
(get_passthrough (.hash c) ctx) (get_passthrough (.hash c) ctx)
;) ;)
(dlet ( ((datasi funcs memo env env_counter) ctx) (dlet ( ((datasi funcs memo env pectx) ctx)
((c_loc c_len datasi) (alloc_data (symbol->string (.marked_symbol_value c)) datasi)) ((c_loc c_len datasi) (alloc_data (symbol->string (.marked_symbol_value c)) datasi))
(result (bor (<< c_len 32) c_loc #b111)) (result (bor (<< c_len 32) c_loc #b111))
(memo (put memo (.hash c) result)) (memo (put memo (.hash c) result))
) (array result nil nil (array datasi funcs memo env env_counter))))) ) (array result nil nil (array datasi funcs memo env pectx)))))
(true (dlet ( ((datasi funcs memo env env_counter) ctx) (true (dlet ( ((datasi funcs memo env pectx) ctx)
; not a recoverable error, so just do here ; not a recoverable error, so just do here
(_ (if (= nil env) (error "nil env when trying to compile a non-value symbol"))) (_ (if (= nil env) (error "nil env when trying to compile a non-value symbol")))
(lookup_helper (rec-lambda lookup-recurse (dict key i code) (cond (lookup_helper (rec-lambda lookup-recurse (dict key i code) (cond
@@ -3089,14 +3123,14 @@
((val err) (lookup_helper (.env_marked env) (.marked_symbol_value c) 0 (local.get '$s_env))) ((val err) (lookup_helper (.env_marked env) (.marked_symbol_value c) 0 (local.get '$s_env)))
(err (mif err (str "got " err ", started searching in " (str_strip env)) err)) (err (mif err (str "got " err ", started searching in " (str_strip env)) err))
(result (mif val (call '$dup val))) (result (mif val (call '$dup val)))
) (array nil result err (array datasi funcs memo env env_counter)))))) ) (array nil result err (array datasi funcs memo env pectx))))))
((marked_array? c) (if (.marked_array_is_val c) (or (get_passthrough (.hash c) ctx) ((marked_array? c) (if (.marked_array_is_val c) (or (get_passthrough (.hash c) ctx)
(let ((actual_len (len (.marked_array_values c)))) (let ((actual_len (len (.marked_array_values c))))
(if (= 0 actual_len) (array nil_val nil nil ctx) (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))) (dlet (((comp_values err ctx) (foldr (dlambda (x (a err ctx)) (dlet (((v c e ctx) (compile-inner ctx x)))
(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))) (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 ( ) (mif err (array nil nil (str err ", from an array value compile " (str_strip c)) ctx) (dlet (
((datasi funcs memo env env_counter) ctx) ((datasi funcs memo env pectx) ctx)
;(_ (print_strip "made from " c)) ;(_ (print_strip "made from " c))
;(_ (print "pre le_hexify " comp_values)) ;(_ (print "pre le_hexify " comp_values))
;(_ (print "pre le_hexify, err was " err)) ;(_ (print "pre le_hexify, err was " err))
@@ -3104,7 +3138,7 @@
((c_loc c_len datasi) (alloc_data (apply concat (map i64_le_hexify comp_values)) datasi)) ((c_loc c_len datasi) (alloc_data (apply concat (map i64_le_hexify comp_values)) datasi))
(result (bor (<< actual_len 32) c_loc #b101)) (result (bor (<< actual_len 32) c_loc #b101))
(memo (put memo (.hash c) result)) (memo (put memo (.hash c) result))
) (array result nil nil (array datasi funcs memo env env_counter)))))))) ) (array result nil nil (array datasi funcs memo env pectx))))))))
(dlet ( (dlet (
@@ -3113,23 +3147,36 @@
; In the paths where this is used, we know we can partial_evaluate the parameters ; In the paths where this is used, we know we can partial_evaluate the parameters
((datasi funcs memo env env_counter) ctx)
; This really should be able to recover from errors... ;(_ (print_strip "doing further partial eval for " c))
(_ (print_strip "doing further partial eval for " c)) (_ (true_print "doing further partial eval for "))
((env_counter err evaled_params) (foldl (dlambda ((c er ds) p) (dlet (((c e d) (partial_eval_helper p false env (array) c 1))) (_ (true_print "\t" (true_str_strip c)))
; This can weirdly cause infinate recursion on the compile side, if partial_eval
; returns something that, when compiled, will cause partial eval to return that thing again.
; Partial eval won't recurse infinately, since it has memo, but it can return something of that
; shape in that case which will cause compile to keep stepping.
((datasi funcs memo env pectx) ctx)
((pectx err evaled_params) (if (= 'RECURSE_FAIL (get-value-or-false memo (.hash c))) (begin (true_print "got a recurse, stoping") (array pectx "RECURSE FAIL" nil))
(foldl (dlambda ((c er ds) p) (dlet (((c e d) (partial_eval_helper p false env (array) c 1)))
(array c (mif er er e) (concat ds (array d))))) (array c (mif er er e) (concat ds (array d)))))
(array env_counter nil (array)) (array pectx nil (array))
(slice func_param_values 1 -1))) (slice func_param_values 1 -1))))
(_ (true_print "DONE further partial eval for "))
(_ (true_print "\t" (true_str_strip c)))
; TODO: This might fail because we don't have the real env stack, which we *should*! ; TODO: This might fail because we don't have the real env stack, which we *should*!
; In the mean time, if it does, just fall back to the non-more-evaled ones. ; In the mean time, if it does, just fall back to the non-more-evaled ones.
(to_code_params (mif err (slice func_param_values 1 -1) evaled_params)) (to_code_params (mif err (slice func_param_values 1 -1) evaled_params))
(ctx (array datasi funcs memo env env_counter))
(memo (put memo (.hash c) 'RECURSE_FAIL))
(ctx (array datasi funcs memo env pectx))
((param_codes err ctx) (foldr (dlambda (x (a err ctx)) ((param_codes err ctx) (foldr (dlambda (x (a err ctx))
(mif err (array a err ctx) (mif err (array a err ctx)
(dlet (((val code new_err ctx) (compile-inner ctx x))) (dlet (((val code new_err ctx) (compile-inner ctx x)))
(array (cons (mif code code (i64.const val)) a) (or (mif err err false) new_err) ctx)))) (array (cons (mif code code (i64.const val)) a) (or (mif err err false) new_err) ctx))))
(array (array) nil ctx) to_code_params)) (array (array) nil ctx) to_code_params))
((datasi funcs memo env pectx) ctx)
(memo (put memo (.hash c) 'RECURSE_OK))
(ctx (array datasi funcs memo env pectx))
(func_value (idx func_param_values 0)) (func_value (idx func_param_values 0))
((func_val func_code func_err ctx) (compile-inner ctx func_value)) ((func_val func_code func_err ctx) (compile-inner ctx func_value))
;(_ (mif err (error err))) ;(_ (mif err (error err)))
@@ -3143,7 +3190,7 @@
((or (!= nil err) (!= nil func_err)) (array nil nil (mif err (str err " from function params in call " (str_strip c)) (str func_err " from function itself in call " (str_strip c))) ctx)) ((or (!= nil err) (!= nil func_err)) (array nil nil (mif err (str err " from function params in call " (str_strip c)) (str func_err " from function itself in call " (str_strip c))) ctx))
((and (prim_comb? func_value) (= (.prim_comb_sym func_value) 'cond)) ((and (prim_comb? func_value) (= (.prim_comb_sym func_value) 'cond))
(dlet ( (dlet (
((datasi funcs memo env env_counter) ctx) ((datasi funcs memo env pectx) ctx)
) (array nil ((rec-lambda recurse (codes i) (cond ) (array nil ((rec-lambda recurse (codes i) (cond
((< i (- (len codes) 1)) (_if '_cond_flat '(result i64) ((< i (- (len codes) 1)) (_if '_cond_flat '(result i64)
(truthy_test (idx codes i)) (truthy_test (idx codes i))
@@ -3206,10 +3253,10 @@
((marked_env? c) (or (get_passthrough (.hash c) ctx) (dlet ((e (.env_marked c)) ((marked_env? c) (or (get_passthrough (.hash c) ctx) (dlet ((e (.env_marked c))
(generate_env_access (dlambda ((datasi funcs memo env env_counter) env_id) ((rec-lambda recurse (code this_env) (generate_env_access (dlambda ((datasi funcs memo env pectx) env_id) ((rec-lambda recurse (code this_env)
(cond (cond
((= env_id (.marked_env_idx this_env)) (array nil (call '$dup code) nil (array datasi funcs memo env env_counter))) ((= env_id (.marked_env_idx this_env)) (array nil (call '$dup code) nil (array datasi funcs memo env pectx)))
((= nil (.marked_env_upper this_env)) (array nil nil (str "bad env, upper is nil and we haven't found " env_id ", maxing out at " (str_strip this_env)) (array datasi funcs memo env env_counter))) ((= nil (.marked_env_upper this_env)) (array nil nil (str "bad env, upper is nil and we haven't found " env_id ", maxing out at " (str_strip this_env)) (array datasi funcs memo env pectx)))
(true (recurse (i64.load 16 (i32.wrap_i64 (i64.shr_u code (i64.const 5)))) (true (recurse (i64.load 16 (i32.wrap_i64 (i64.shr_u code (i64.const 5))))
(.marked_env_upper this_env))) (.marked_env_upper this_env)))
) )
@@ -3234,7 +3281,7 @@
(array nil_val nil nil ctx))) (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) (generate_env_access ctx (.marked_env_idx c))) ) (mif (or (= false kvs) (= nil uv) (!= nil err)) (begin (print_strip "kvs " kvs " vvs " vvs " uv " uv " or err " err " based off of " c) (generate_env_access ctx (.marked_env_idx c)))
(dlet ( (dlet (
((datasi funcs memo env env_counter) ctx) ((datasi funcs memo env pectx) ctx)
((kvs_array datasi) (if (= 0 (len kvs)) (array nil_val datasi) ((kvs_array datasi) (if (= 0 (len kvs)) (array nil_val datasi)
(dlet (((kvs_loc kvs_len datasi) (alloc_data (apply concat (map i64_le_hexify kvs)) datasi))) (dlet (((kvs_loc kvs_len datasi) (alloc_data (apply concat (map i64_le_hexify kvs)) datasi)))
(array (bor (<< (len kvs) 32) kvs_loc #b101) datasi)))) (array (bor (<< (len kvs) 32) kvs_loc #b101) datasi))))
@@ -3245,7 +3292,7 @@
((c_loc c_len datasi) (alloc_data (apply concat all_hex) datasi)) ((c_loc c_len datasi) (alloc_data (apply concat all_hex) datasi))
(result (bor (<< c_loc 5) #b01001)) (result (bor (<< c_loc 5) #b01001))
(memo (put memo (.hash c) result)) (memo (put memo (.hash c) result))
) (array result nil nil (array datasi funcs memo env env_counter))))))))) ) (array result nil nil (array datasi funcs memo env pectx)))))))))
((prim_comb? c) (cond ((= 'vau (.prim_comb_sym c)) (array (bor (<< (- k_vau dyn_start) 35) (<< 0 4) #b0001) nil nil ctx)) ((prim_comb? c) (cond ((= 'vau (.prim_comb_sym c)) (array (bor (<< (- k_vau dyn_start) 35) (<< 0 4) #b0001) nil nil ctx))
((= 'cond (.prim_comb_sym c)) (array (bor (<< (- k_cond dyn_start) 35) (<< 0 4) #b0001) nil nil ctx)) ((= 'cond (.prim_comb_sym c)) (array (bor (<< (- k_cond dyn_start) 35) (<< 0 4) #b0001) nil nil ctx))
@@ -3362,10 +3409,10 @@
) setup_code ) setup_code
)) ))
((datasi funcs memo env env_counter) ctx) ((datasi funcs memo env pectx) ctx)
((inner_value inner_code err ctx) (compile-inner (array datasi funcs memo inner_env env_counter) body)) ((inner_value inner_code err ctx) (compile-inner (array datasi funcs memo inner_env pectx) body))
; Don't overwrite env with what was our inner env! Env is returned as part of context to our caller! ; Don't overwrite env with what was our inner env! Env is returned as part of context to our caller!
((datasi funcs memo _was_inner_env env_counter) ctx) ((datasi funcs memo _was_inner_env pectx) ctx)
;(_ (print_strip "inner_value for maybe const is " inner_value " inner_code is " inner_code " err is " err " this was for " body)) ;(_ (print_strip "inner_value for maybe const is " inner_value " inner_code is " inner_code " err is " err " this was for " body))
(inner_code (mif inner_value (i64.const inner_value) inner_code)) (inner_code (mif inner_value (i64.const inner_value) inner_code))
(end_code (call '$drop (local.get '$s_env))) (end_code (call '$drop (local.get '$s_env)))
@@ -3378,7 +3425,7 @@
(memo (put memo (.hash c) func_value)) (memo (put memo (.hash c) func_value))
(_ (print_strip "the hash " (.hash c) " with value " func_value " corresponds to " c)) (_ (print_strip "the hash " (.hash c) " with value " func_value " corresponds to " c))
) (array func_value nil err (array datasi funcs memo env env_counter))) ) (array func_value nil err (array datasi funcs memo env pectx)))
)) ))
(_ (print_strip "returning " func_value " for " c)) (_ (print_strip "returning " func_value " for " c))
(_ (if (not (int? func_value)) (error "BADBADBADfunc"))) (_ (if (not (int? func_value)) (error "BADBADBADfunc")))
@@ -3404,8 +3451,9 @@
))) )))
(_ (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)))
(memo empty_dict) (memo empty_dict)
(ctx (array datasi funcs memo root_marked_env env_counter)) (ctx (array datasi funcs memo root_marked_env pectx))
((exit_val _ _ ctx) (compile-inner ctx (marked_symbol nil 'exit))) ((exit_val _ _ ctx) (compile-inner ctx (marked_symbol nil 'exit)))
((read_val _ _ ctx) (compile-inner ctx (marked_symbol nil 'read))) ((read_val _ _ ctx) (compile-inner ctx (marked_symbol nil 'read)))
@@ -3418,7 +3466,7 @@
((compiled_value_ptr compiled_value_code compiled_value_error ctx) (compile-inner ctx marked_code)) ((compiled_value_ptr compiled_value_code compiled_value_error ctx) (compile-inner ctx marked_code))
((datasi funcs memo root_marked_env env_counter) ctx) ((datasi funcs memo root_marked_env pectx) ctx)
(_ (mif compiled_value_error (error compiled_value_error))) (_ (mif compiled_value_error (error compiled_value_error)))
(_ (if (= nil compiled_value_ptr) (error (str "compiled top-level to code for some reason!? have code " compiled_value_code)))) (_ (if (= nil compiled_value_ptr) (error (str "compiled top-level to code for some reason!? have code " compiled_value_code))))
@@ -3621,7 +3669,7 @@
(run_partial_eval_test (lambda (s) (dlet ( (run_partial_eval_test (lambda (s) (dlet (
(_ (print "\n\ngoing to partial eval " s)) (_ (print "\n\ngoing to partial eval " s))
((env_counter err result) (partial_eval (read-string s))) ((pectx err result) (partial_eval (read-string s)))
(_ (print "result of test \"" s "\" => " (str_strip result) " and err " err)) (_ (print "result of test \"" s "\" => " (str_strip result) " and err " err))
(_ (print "with a hash of " (.hash result))) (_ (print "with a hash of " (.hash result)))
) nil))) ) nil)))

12
to_compile.kp
View File

@@ -14,11 +14,11 @@
((lambda (x1) (x1 x1)) ((lambda (x1) (x1 x1))
(lambda (x2) (f3 (lambda (& y) (lapply (x2 x2) y)))))) (lambda (x2) (f3 (lambda (& y) (lapply (x2 x2) y))))))
;(let1 vY (lambda (f) (let1 vY (lambda (f)
; ((lambda (x3) (x3 x3)) ((lambda (x3) (x3 x3))
; (lambda (x4) (f (vau de (& y) (vapply (x4 x4) y de)))))) (lambda (x4) (f (vau de (& y) (vapply (x4 x4) y de))))))
;(let1 let (vY (lambda (recurse) (vau de (vs b) (cond (= (len vs) 0) (eval b de) ;(let1 let (vY (lambda (recurse) (vau de (vs b) (cond (= (len vs) 0) (eval b de)
; true (vapply let1 (array (idx vs 0) (idx vs 1) (array recurse (slice vs 2 -1) b)) de))))) ; true (vapply let1 (array (idx vs 0) (idx vs 1) (array recurse (slice vs 2 -1) b)) de)))))
(array 'open 3 "test_self_out" (lambda (fd code) (array 'open 3 "test_self_out" (lambda (fd code)
@@ -29,8 +29,8 @@
; end of all lets ; end of all lets
)))));)) )))))))
) ;)
; impl of let1 ; 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))) ; this would be the macro style version (((;)) (vau de (s v b) (eval (array (array wrap (array vau (array s) b)) v) de)))