From 325afd773e567daf7455a63b3d85b1dd577c146b Mon Sep 17 00:00:00 2001 From: Nathan Braswell Date: Wed, 9 Feb 2022 22:49:06 -0500 Subject: [PATCH] Added partial_evaling to drop_redundent_veval (a bit hacky, have to pass partial_eval to it to break mutual recursion & had to add a 'force' option to partial_eval to force re-evaluation for situations where drop_rdundent_veval has changed something but the needed_for_progress wouldn't pick up on it.) This theme continues with the current problem with the Y combiner test, which is that recursion protection trips on the partial eval of the recursive application (x x) in the Y combiner, but it doesn't actually need any other external values, so when the time comes that it is actually needed as a value it skips it and ends up only evaluating a single level even for a value-only top level recursive invocation. Finally, still need to figure out a better situation for cond/vcond to partially evaluate itself without triggering even more infinate recursion (that's truely value-only, without a cond to stop it). --- partial_eval.csc | 109 ++++++++++++++++++++++++++--------------------- 1 file changed, 60 insertions(+), 49 deletions(-) diff --git a/partial_eval.csc b/partial_eval.csc index 7308d26..9f5e456 100644 --- a/partial_eval.csc +++ b/partial_eval.csc @@ -231,7 +231,7 @@ ))) ((prim_comb? x) nil) ((val? x) nil) - (true (error "what is this? in need for progress"))))) + (true (error (str "what is this? in need for progress" x)))))) (combine_hash (lambda (a b) (+ (* 37 a) b))) (hash_bool (lambda (b) (if b 2 3))) @@ -505,35 +505,38 @@ (true false) ) )) - - (drop_redundent_veval (rec-lambda drop_redundent_veval (env_id x) (dlet ((r (if + (drop_redundent_veval (rec-lambda drop_redundent_veval (partial_eval_helper x de env_stack pectx indent) (dlet ( + (env_id (.marked_env_idx de)) + (r (if (and (marked_array? x) (not (.marked_array_is_val x))) (if (and (prim_comb? (idx (.marked_array_values x) 0)) (= 'veval (.prim_comb_sym (idx (.marked_array_values x) 0))) (= 3 (len (.marked_array_values x))) (not (marked_env_real? (idx (.marked_array_values x) 2))) - (= env_id (.marked_env_idx (idx (.marked_array_values x) 2)))) (drop_redundent_veval env_id (idx (.marked_array_values x) 1)) - (marked_array false - (.marked_array_is_attempted x) - (map (lambda (it) (drop_redundent_veval env_id it)) - (.marked_array_values x)))) - x))) + (= env_id (.marked_env_idx (idx (.marked_array_values x) 2)))) (drop_redundent_veval partial_eval_helper (idx (.marked_array_values x) 1) de env_stack pectx (+ 1 indent)) + ; wait, can it do this? will this mess with eval? + ; basically making sure that this comb's params are still good to eval + (if (and (or (prim_comb? (idx (.marked_array_values x) 0)) (comb? (idx (.marked_array_values x) 0))) + (!= -1 (.any_comb_wrap_level (idx (.marked_array_values x) 0)))) + (dlet (((pectx err ress changed) (foldl (dlambda ((c er ds changed) p) (dlet ( + (pre_hash (.hash p)) + ((c e d) (drop_redundent_veval partial_eval_helper p de env_stack c (+ 1 indent))) + (err (mif er er e)) + (changed (mif err false (or (!= pre_hash (.hash d)) changed))) + ) (array c err (concat ds (array d)) changed))) + (array pectx nil (array) false) + (.marked_array_values x))) + (new_array (marked_array false (.marked_array_is_attempted x) ress)) + ((pectx err new_array) (if (or (!= nil err) (not changed)) + (array pectx err new_array) + (partial_eval_helper new_array false de env_stack pectx (+ indent 1) true))) + ) (array pectx err new_array)) + (array pectx nil x)) + ) (array pectx nil x)))) - (begin (error "if we do a drop_redundent_veval and it does, we need to re-evaluate because the veval might have been blocking") - (print_strip "result of drop_redundent_veval (with " env_id ") (problem was " (cond - ((not (marked_array? x)) "(marked_array? x)") - ((not (not (.marked_array_is_val x))) "(not (.marked_array_is_val x))") - ((not (prim_comb? (idx (.marked_array_values x) 0))) "(prim_comb? (idx (.marked_array_values x) 0))") - ((not (= 'veval (.prim_comb_sym (idx (.marked_array_values x) 0)))) "(= 'veval (.prim_comb_sym (idx (.marked_array_values x) 0)))") - ((not (= 3 (len (.marked_array_values x)))) "(= 3 (len (.marked_array_values x)))") - ((not (not (marked_env_real? (idx (.marked_array_values x) 2)))) "(not (marked_env_real? (idx (.marked_array_values x) 2)))") - ((not (= env_id (.marked_env_idx (idx (.marked_array_values x) 2)))) "(= env_id (.marked_env_idx (idx (.marked_array_values x) 2)))") - (true "no problem!")) x) r) - ;r - - ))) + r))) ; TODO: instead of returning the later symbols, we could create a new value of a new type ; ['ref de_bruijn_index_of_env index_into_env] or somesuch. Could really simplify @@ -545,7 +548,7 @@ ) (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 pectx indent) + (partial_eval_helper (rec-lambda partial_eval_helper (x only_head env env_stack pectx indent force) (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 @@ -561,7 +564,7 @@ ) (if this_now this_now (rr (+ i 1)))) )) 0))) ) - (if progress_now + (if (or force progress_now) (cond ((val? x) (array pectx nil x)) ((marked_env? x) (let ((dbi (.marked_env_idx x))) ; compiler calls with empty env stack @@ -578,7 +581,7 @@ (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! (dlet ((inner_env (make_tmp_inner_env params de? env env_id)) - ((pectx err evaled_body) (partial_eval_helper body false inner_env (cons inner_env env_stack) pectx (+ indent 1)))) + ((pectx err evaled_body) (partial_eval_helper body false inner_env (cons inner_env env_stack) pectx (+ indent 1) false))) (array pectx err (mif err nil (marked_comb wrap_level env_id de? env variadic params evaled_body)))) (array pectx nil x)))) ((prim_comb? x) (array pectx nil x)) @@ -586,7 +589,7 @@ (env-lookup-helper (.env_marked env) (.marked_symbol_value x) 0 (lambda () (array pectx (str "could't find " (str_strip x) " in " (str_strip env)) nil)) (lambda (x) (array pectx nil x))))) - ((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))))) + ((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) false))) (array c (mif er er e) (concat ds (array d))))) (array pectx nil (array)) (.marked_array_values x))) ) (array pectx err (mif err nil (marked_array true false inner_arr))))) @@ -595,7 +598,7 @@ (_ (print_strip (indent_str indent) "partial_evaling comb " (idx values 0))) (literal_params (slice values 1 -1)) - ((pectx err comb) (partial_eval_helper (idx values 0) true env env_stack pectx (+ 1 indent))) + ((pectx err comb) (partial_eval_helper (idx values 0) true env env_stack pectx (+ 1 indent) false)) ) (cond ((!= nil err) (array pectx err nil)) ((later_head? comb) (array pectx nil (marked_array false true (cons comb literal_params)))) ((not (or (comb? comb) (prim_comb? comb))) (array pectx (str "impossible comb value " x) nil)) @@ -603,15 +606,20 @@ ; 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?) ((pectx comb_err comb) (if (and (= nil err) (= true (needed_for_progress comb))) - (partial_eval_helper comb false env env_stack pectx (+ 1 indent)) + (partial_eval_helper comb false env env_stack pectx (+ 1 indent) false) (array pectx err comb))) (_ (println (indent_str indent) "Going to do an array call!")) (indent (+ 1 indent)) ;(_ (print_strip (indent_str indent) "total (in env " (.marked_env_idx env) ") is (proceeding err " err ") " x)) - (map_rp_eval (lambda (pectx ps) (foldl (dlambda ((c er ds) p) (dlet ((_ (print_strip (indent_str indent) "rp_evaling " p)) ((c e d) (partial_eval_helper p false env env_stack c (+ 1 indent))) (_ (print_strip (indent_str indent) "result of rp_eval was err " e " and value " d))) (array c (mif er er e) (concat ds (array d))))) + (map_rp_eval (lambda (pectx ps) (foldl (dlambda ((c er ds) p) (dlet ((_ (print_strip (indent_str indent) "rp_evaling " p)) ((c e d) (partial_eval_helper p false env env_stack c (+ 1 indent) false)) (_ (print_strip (indent_str indent) "result of rp_eval was err " e " and value " d))) (array c (mif er er e) (concat ds (array d))))) (array pectx nil (array)) ps))) - ((remaining_wrap param_err evaled_params pectx) ((rec-lambda param-recurse (wrap cparams pectx) + (wrap_level (.any_comb_wrap_level comb)) + ; -1 is a minor hack for veval to prevent re-eval + ; in the wrong env + ((remaining_wrap param_err evaled_params pectx) (if (= -1 wrap_level) + (array 0 nil literal_params pectx) + ((rec-lambda param-recurse (wrap cparams pectx) (dlet ( (_ (print (indent_str indent) "For initial rp_eval:")) (_ (map (lambda (x) (print_strip (indent_str indent) "item " x)) cparams)) @@ -624,7 +632,7 @@ (mif (not ok) (array wrap nil pre_evaled pectx) (param-recurse (- wrap 1) unval_params pectx))) (array wrap nil pre_evaled pectx))))) - (.any_comb_wrap_level comb) literal_params pectx)) + wrap_level literal_params pectx))) (_ (println (indent_str indent) "Done evaluating parameters")) (later_call_array (marked_array false true (cons (with_wrap_level comb remaining_wrap) evaled_params))) @@ -660,22 +668,22 @@ (hash (combine_hash (.hash body) (.hash inner_env))) ((env_counter memo) pectx) ((pectx func_err func_result rec_stop) (if (!= false (get-value-or-false memo hash)) - (array pectx nil "stoping for rec" true) + (array pectx nil "stopping for rec" true) (dlet ( (new_memo (put memo hash nil)) (pectx (array env_counter new_memo)) ((pectx func_err func_result) (partial_eval_helper body only_head inner_env (cons inner_env env_stack) - pectx (+ 1 indent))) + pectx (+ 1 indent) false)) ((env_counter new_memo) pectx) (pectx (array env_counter memo)) ) (array pectx func_err func_result false)))) (_ (print_strip (indent_str indent) "evaled result of function call (in env " (.marked_env_idx env) ", with inner " env_id ") and err " func_err " is " func_result)) ) (if (!= nil func_err) (array pectx func_err nil) - (array pectx nil (if (or rec_stop (not (combiner_return_ok func_result env_id))) - (marked_array false true (cons (with_wrap_level comb remaining_wrap) evaled_params)) - (drop_redundent_veval (.marked_env_idx env) func_result)))))) + (if (or rec_stop (not (combiner_return_ok func_result env_id))) + (array pectx nil (marked_array false true (cons (with_wrap_level comb remaining_wrap) evaled_params))) + (drop_redundent_veval partial_eval_helper func_result env env_stack pectx indent))))) ))) ))))) @@ -684,7 +692,7 @@ ; 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 pectx nil (drop_redundent_veval (.marked_env_idx env) x))))) + (drop_redundent_veval partial_eval_helper x env env_stack pectx indent)))) )) (needs_params_val_lambda_inner (lambda (f_sym actual_function) (let* ( @@ -722,7 +730,7 @@ (dlet ( (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)) - ((pectx err pe_body) (partial_eval_helper body false inner_env (cons inner_env env_stack) pectx (+ 1 indent))) + ((pectx err pe_body) (partial_eval_helper body false inner_env (cons inner_env env_stack) pectx (+ 1 indent) false)) (_ (print_strip (indent_str indent) "in vau, result of evaluating body was " pe_body)) ) (array pectx err pe_body)))) ) (mif err (array pectx err nil) (array pectx nil (marked_comb 0 new_id de? de variadic vau_params pe_body))) @@ -757,17 +765,16 @@ (implicit_env (!= 2 (len params))) (eval_env (if implicit_env de (idx params 1))) ((pectx err eval_env) (if implicit_env (array pectx nil de) - (partial_eval_helper (idx params 1) only_head de env_stack pectx (+ 1 indent)))) + (partial_eval_helper (idx params 1) only_head de env_stack pectx (+ 1 indent) false))) ((pectx err ebody) (if (or (!= nil err) (not (marked_env? eval_env))) (array pectx err body) - (partial_eval_helper body only_head eval_env env_stack pectx (+ 1 indent)))) + (partial_eval_helper body only_head eval_env env_stack pectx (+ 1 indent) false))) ) (cond ((!= nil err) (begin (print (indent_str indent) "got err " err) (array pectx err nil))) ; If our env was implicit, then our unval'd code can be inlined directly in our caller - (implicit_env (array pectx nil (drop_redundent_veval (.marked_env_idx de) ebody))) - ((combiner_return_ok ebody (.marked_env_idx eval_env)) (array pectx nil (drop_redundent_veval (.marked_env_idx de) ebody))) - (true (error "FIXME - veval needs to re-val it's body, including? somehow? any env references or the main call will re-partial-eval them in the wrong env")) - (true (array pectx nil (drop_redundent_veval (.marked_env_idx de) (marked_array false true (array (marked_prim_comb recurse 'veval 0 true) ebody eval_env))))) + (implicit_env (drop_redundent_veval partial_eval_helper ebody de env_stack pectx indent)) + ((combiner_return_ok ebody (.marked_env_idx eval_env)) (drop_redundent_veval partial_eval_helper ebody de env_stack pectx indent)) + (true (drop_redundent_veval partial_eval_helper (marked_array false true (array (marked_prim_comb recurse 'veval -1 true) ebody eval_env)) de env_stack pectx indent)) )))) ) (veval_inner only_head de env_stack pectx (if implicit_env (array unval_body) (array unval_body eval_env)) indent)))) @@ -776,12 +783,12 @@ (array 'cond (marked_prim_comb ((rec-lambda recurse (first_evaled_already) (lambda (only_head de env_stack pectx params indent) (mif (!= 0 (% (len params) 2)) (array pectx (str "partial eval cond with odd params " params) nil) (dlet ( - (_ (error "This will have to evaluate the other sides? Also, if we figure out veval re-val, maybe this can collapse back into cond")) + ;(_ (error "This will have to evaluate the other sides? Also, if we figure out veval re-val, maybe this can collapse back into cond")) (eval_helper (lambda (to_eval pectx) (dlet (((ok unvald) (try_unval to_eval (lambda (_) nil)))) (mif (not ok) (array pectx "bad unval in cond" nil) - (partial_eval_helper unvald false de env_stack pectx (+ 1 indent)))))) + (partial_eval_helper unvald false de env_stack pectx (+ 1 indent) false))))) ) ((rec-lambda recurse_inner (i so_far pectx) (dlet (((pectx err pred) (if (and (= i 0) first_evaled_already) (array pectx nil (idx params 0)) @@ -892,7 +899,7 @@ ))) - (partial_eval (lambda (x) (partial_eval_helper (mark true x) false root_marked_env (array) (array 0 (array)) 0))) + (partial_eval (lambda (x) (partial_eval_helper (mark true x) false root_marked_env (array) (array 0 (array)) 0 false))) ;; WASM ; Vectors and Values @@ -3157,7 +3164,7 @@ ; ctx is (datasi funcs memo env pectx) ; return is (value? code? error? (datasi funcs memo env pectx)) (compile-inner (rec-lambda compile-inner (ctx c need_value) (cond - (true (_ (error "The entire compiler needs to support our new value-default thing, esp for cond and unval'ing function call params"))) + (true (error "The entire compiler needs to support our new value-default thing, esp for cond and unval'ing function call params")) ((val? c) (let ((v (.val c))) (cond ((int? v) (array (<< v 1) nil nil ctx)) ((= true v) (array true_val nil nil ctx)) @@ -3232,7 +3239,7 @@ ((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))) + (foldl (dlambda ((c er ds) p) (dlet (((c e d) (partial_eval_helper p false env (array) c 1 false))) (array c (mif er er e) (concat ds (array d))))) (array pectx nil (array)) (slice func_param_values 1 -1)))) @@ -3883,6 +3890,10 @@ true 1 )) n)) ))) (vau de (s v b) (eval (array (array wrap (array vau (array s) b)) v) de)))")) + ; The issue with this one is that (x2 x2) trips the infinate recursion protector, but then + ; that array gets marked as attempted & needing no more evaluation, and is frozen forever. + ; Then, when the recursion is actually being used, it won't keep going and you only get + ; the first level. (print "\n\nlambda recursion Y combiner test\n\n") (print (run_partial_eval_test "((wrap (vau (let1) (let1 lambda (vau se (p b) (wrap (eval (array vau p b) se)))