From 923c4565fbc7222adfa4a4225063b11b14d73c4d Mon Sep 17 00:00:00 2001 From: Nathan Braswell Date: Sun, 17 Oct 2021 17:39:38 -0400 Subject: [PATCH] prep for useing de bruijn --- partial_eval.kp | 145 +++++++++++++++++++++++++++--------------------- 1 file changed, 83 insertions(+), 62 deletions(-) diff --git a/partial_eval.kp b/partial_eval.kp index a4cb4b6..0fe6b5b 100644 --- a/partial_eval.kp +++ b/partial_eval.kp @@ -31,7 +31,7 @@ ; It is possible to have a combiner without an actual function, but that's only generated when ; we know it's about to be called and we won't have to strip-lower it ; ['prim_comb ] - A primitive combiner! It has it's own special handler function to partial eval - ; ['env is_real [ ['symbol marked_value ]... ]] - A marked env + ; ['env is_real de_bruijn_idx_or_nil [ ['symbol marked_value ]... ]] - A marked env val? (lambda (x) (= 'val (idx x 0))) @@ -48,9 +48,10 @@ .prim_comb (lambda (x) (idx x 1)) marked_env? (lambda (x) (= 'env (idx x 0))) marked_env_real? (lambda (x) (idx x 1)) - .env_marked (lambda (x) (idx x 2)) + .marked_env_idx (lambda (x) (idx x 2)) + .env_marked (lambda (x) (idx x 3)) - later? (rec-lambda recurse (x) (or (and (marked_array? x) (= false (.marked_array_is_val x))) + later? (rec-lambda recurse (x) (or (and (marked_array? x) (or (= false (.marked_array_is_val x)) (foldl (lambda (a x) (or a (recurse x))) false (.marked_array_values x)))) (and (marked_symbol? x) (= false (.marked_symbol_is_val x))) (and (marked_env? x) (not (marked_env_real? x))) (and (comb? x) (let ([wrap_level de? se variadic params body] (.comb x) @@ -87,11 +88,14 @@ stripped_values)) (marked_symbol? x) (if (.marked_symbol_is_val x) ['quote (.marked_symbol_value x)] (.marked_symbol_value x)) - (comb? x) (let ([wrap_level de? se variadic params body] (.comb x)) (str " " params " " (recurse body) ">")) + (comb? x) (let ([wrap_level de? se variadic params body] (.comb x)) + (str " " params " " (recurse body) ">")) + ;(str " " params " " (recurse body) ">")) (prim_comb? x) (idx x 2) (marked_env? x) (let (e (.env_marked x) + index (.marked_env_idx x) u (idx e -1) - ) (if u (str "<" (if (marked_env_real? x) "real" "fake") " ENV " (map (lambda ([k v]) [k (recurse v)]) (slice e 0 -2)) " upper: " (recurse u) ">") + ) (if u (str "<" (if (marked_env_real? x) "real" "fake") " ENV idx: " (str index) ", " (map (lambda ([k v]) [k (recurse v)]) (slice e 0 -2)) " upper: " (recurse u) ">") "")) true (error (str "some other str_strip? |" x "|")) ) @@ -117,6 +121,7 @@ ) (if se_env (eval fe se_env) fe)) (prim_comb? x) (idx x 2) ; env emitting doesn't pay attention to real value right now, not sure if that makes sense + ; TODO: properly handle de Bruijn indexed envs (marked_env? x) (let (_ (if (not (marked_env_real? x)) (error (str_strip "trying to emit fake env!" x))) upper (idx (.env_marked x) -1) upper_env (if upper (recurse upper true) empty_env) @@ -160,6 +165,7 @@ (= x (idx a i)) true true (recurse x a (+ i 1))))) (lambda (x a) (helper x a 0))) + ; TODO: make this check for stop envs using de Bruijn indicies contains_symbols (rec-lambda recurse (stop_envs symbols x) (cond (val? x) false (marked_symbol? x) (let (r (in_array (.marked_symbol_value x) symbols) @@ -180,25 +186,46 @@ is_all_values (lambda (evaled_params) (foldl (lambda (a x) (and a (not (later? x)))) true evaled_params)) + shift_envs (rec-lambda recurse (cutoff d x) (cond + (val? x) [true x] + (marked_env? x) (let ([_env is_real dbi meat] x + [nmeat_ok nmeat] (foldl (lambda ([ok r] [k v]) (let ([tok tv] (recurse cutoff d v)) [(and ok tok) (concat r [[k tv]])])) [true []] (slice meat 0 -2)) + [nupper_ok nupper] (if (idx meat -1) (recurse cutoff d (idx meat -1)) [true nil]) + ndbi (if (>= cutoff dbi) (+ dbi d) dbi) + ) [(and nmeat_ok nupper_ok (>= ndbi 0)) ['env is_real ndbi (concat nmeat [nupper])]]) + (comb? x) (let ([wrap_level de? se variadic params body] (.comb x) + [se_ok nse] (recurse cutoff d se) + [body_ok nbody] (recurse (+ cutoff 1) d body) + ) [(and se_ok body_ok) ['comb wrap_level de? nse variadic params nbody]]) + (prim_comb? x) [true x] + (marked_symbol? x) [true x] + (marked_array? x) (let ([insides_ok insides] (foldl (lambda ([ok r] tx) (let ([tok tr] (recurse cutoff d tx)) [(and ok tok) (concat r [tr])])) [true []] (.marked_array_values x))) + [insides_ok ['marked_array (.marked_array_is_val x) insides]]) + true (error (str "impossible shift_envs value " x)) + )) + increment_envs (lambda (x) (idx (shift_envs 0 1 x) 1)) + decrement_envs (lambda (x) (shift_envs 0 -1 x)) + + ; 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 + ; compiling, and I think make partial-eval more efficient. More accurate closes_over analysis too, I think make_tmp_inner_env (lambda (params de? de) - ['env false (concat (map (lambda (p) [p ['marked_symbol false p]]) params) (if (= nil de?) [] [ [de? ['marked_symbol false de?]] ]) [de])]) + ; TODO: our de Bruijn index is 0, increment de's index + ['env false 0 (concat (map (lambda (p) [p ['marked_symbol false p]]) params) (if (= nil de?) [] [ [de? ['marked_symbol false de?]] ]) [(increment_envs de)])]) - partial_eval_helper (rec-lambda recurse (x env indent) + partial_eval_helper (rec-lambda recurse (x env env_stack indent) (cond (val? x) x + ; TODO: update from current environment stack based on de Bruijn index + ; Note that we need to normalize indicies, I think - incrementing or decrmenting values in the env from env_stack + ; to match what we have here, which can be calculated by the difference between the level the env thinks it is verses what it is + ; note we do have to make sure that index is copied over as well. (marked_env? x) x - ;(comb? x) x - ; ? this is legal because we don't allow expressions that close over symbols from outer envs to escape those envs, - ; so by necessity this is being partially-evaled again in the same environment or sub-environment. - ; GAH how do we make sure to avoid capture substitution stuff? - ; Need to prevent evaluating calls where parameters close over symbols of the function being called - ; or any user-input eval calls, note that we're replacing se below! - ; honestly, it seems like we need a way to differentiate between re-partial-evaluating a vau in it's same context but - ; with a more accurate environment, and passing around a partially-evaluated comb and calling it (comb? x) (let ([wrap_level de? se variadic params body] (.comb x)) (if (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! - ['comb wrap_level de? env variadic params (recurse body (make_tmp_inner_env params de? env) (+ indent 1))] + (let (inner_env (make_tmp_inner_env params de? env)) + ['comb wrap_level de? env variadic params (recurse body inner_env (cons inner_env env_stack) (+ indent 1))]) x)) (prim_comb? x) x (marked_symbol? x) (if (.marked_symbol_is_val x) x @@ -208,20 +235,16 @@ true (let (values (.marked_array_values x) ;_ (println (indent_str indent) "partial_evaling comb " (idx values 0)) _ (print_strip (indent_str indent) "partial_evaling comb " (idx values 0)) - comb (recurse (idx values 0) env (+ 1 indent)) + comb (recurse (idx values 0) env env_stack (+ 1 indent)) literal_params (slice values 1 -1) _ (println (indent_str indent) "Going to do an array call!") _ (print_strip (indent_str indent) " total is " x) _ (print_strip (indent_str indent) " evaled comb is " comb) ident (+ 1 indent) ) - ;;!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ;; With our new definition of later?, this prevents combiners without full se's from being called - ;;!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - (cond (later? comb) ['marked_array false (cons comb literal_params)] - (prim_comb? comb) ((.prim_comb comb) env literal_params (+ 1 indent)) + (cond (prim_comb? comb) ((.prim_comb comb) env env_stack literal_params (+ 1 indent)) (comb? comb) (let ( - rp_eval (lambda (p) (recurse p env (+ 1 indent))) + rp_eval (lambda (p) (recurse p env env_stack (+ 1 indent))) [wrap_level de? se variadic params body] (.comb comb) ensure_val_params (map ensure_val literal_params) [ok appropriatly_evaled_params] ((rec-lambda param-recurse (wrap cparams) @@ -244,45 +267,43 @@ ['marked_symbol false de?])] ] []) ;_ (println (indent_str indent) "final_params params " final_params) - inner_env ['env (marked_env_real? se) (concat (zip params final_params) de_entry [se])] - ;_ (println (indent_str indent) "going to eval " body " with inner_env is " inner_env) + inner_env ['env (marked_env_real? se) 0 (concat (zip params (map (lambda (x) (increment_envs x)) final_params)) de_entry [(increment_envs se)])] _ (print_strip (indent_str indent) " with inner_env is " inner_env) _ (print_strip (indent_str indent) "going to eval " body) - - func_result (recurse body inner_env (+ 1 indent)) - - _ (print_strip (indent_str indent) "evaled result of function call is " func_result) + tmp_func_result (recurse body inner_env (cons inner_env env_stack) (+ 1 indent)) + _ (print_strip (indent_str indent) "evaled result of function call is " tmp_func_result) + [able_to_sub_env func_result] (decrement_envs tmp_func_result) result_is_later (later? func_result) stop_envs ((rec-lambda ser (a e) (if e (ser (cons e a) (idx (.env_marked e) -1)) a)) [] se) result_closes_over (contains_symbols stop_envs (concat params (if de? [de?] [])) func_result) - _ (println (indent_str indent) "func call result is later? " result_is_later " and result_closes_over " result_closes_over) + _ (println (indent_str indent) "func call able_to_sub: " able_to_sub_env " result is later? " result_is_later " and result_closes_over " result_closes_over) ; This could be improved to a specialized version of the function ; just by re-wrapping it in a comb instead if we wanted. ; Something to think about! - result (if (and result_is_later result_closes_over) - ['marked_array false (cons comb (if (> wrap_level 0) (map rp_eval ensure_val_params) + result (if (or (not able_to_sub_env) (and result_is_later result_closes_over)) + ['marked_array false (cons comb (if (> wrap_level 0) (map rp_eval literal_params) literal_params))] func_result) ) result))) - true (error (str "Partial eval noticed that you will likely call not a function " comb " total is " x))))) + (later? comb) ['marked_array false (cons comb literal_params)]))) true (error (str "impossible partial_eval value " x)) ) ) needs_params_val_lambda (vau de (f_sym) (let ( actual_function (eval f_sym de) - handler (rec-lambda recurse (de params indent) (let ( + handler (rec-lambda recurse (de env_stack params indent) (let ( _ (println "partial_evaling params in need_params_val_lambda for " f_sym " is " params) - evaled_params (map (lambda (p) (partial_eval_helper p de (+ 1 indent))) params) + evaled_params (map (lambda (p) (partial_eval_helper p de env_stack (+ 1 indent))) params) ) (if (is_all_values evaled_params) (mark (lapply actual_function (map strip evaled_params))) ['marked_array false (cons ['prim_comb recurse actual_function] evaled_params)]))) ) [f_sym ['prim_comb handler actual_function]])) give_up_eval_params (vau de (f_sym) (let ( actual_function (eval f_sym de) - handler (rec-lambda recurse (de params indent) (let ( + handler (rec-lambda recurse (de env_stack params indent) (let ( _ (println "partial_evaling params in give_up_eval_params for " f_sym " is " params) - evaled_params (map (lambda (p) (partial_eval_helper p de (+ 1 indent))) params) + evaled_params (map (lambda (p) (partial_eval_helper p de env_stack (+ 1 indent))) params) ) ['marked_array false (cons ['prim_comb recurse actual_function] evaled_params)])) ) [f_sym ['prim_comb handler actual_function]])) @@ -290,21 +311,21 @@ ; !!!!!! ; ! I think needs_params_val_lambda should be combined with parameters_evaled_proxy ; !!!!!! - parameters_evaled_proxy (rec-lambda recurse (pasthr_ie inner_f) (lambda (de params indent) (let ( + parameters_evaled_proxy (rec-lambda recurse (pasthr_ie inner_f) (lambda (de env_stack params indent) (let ( _ (println "partial_evaling params in parameters_evaled_proxy is " params) - [evaled_params l] (foldl (lambda ([ac i] p) (let (p (partial_eval_helper p de (+ 1 indent))) + [evaled_params l] (foldl (lambda ([ac i] p) (let (p (partial_eval_helper p de env_stack (+ 1 indent))) [(concat ac [p]) (+ i 1)])) [[] 0] params) - ) (inner_f (lambda (& args) (lapply (recurse pasthr_ie inner_f) args)) de evaled_params indent)))) + ) (inner_f (lambda (& args) (lapply (recurse pasthr_ie inner_f) args)) de env_stack evaled_params indent)))) - root_marked_env ['env true [ + root_marked_env ['env true nil [ ; Ok, so for combinators, it should partial eval the body. ; It should then check to see if the partial-evaled body has closed over ; any 'later values from above the combinator. If so, the combinator should ; evaluate to a ['later [vau de? params (strip partially_evaled_body)]], otherwise it can evaluate to a 'comb. ; Note that this 'later may be re-evaluated later if the parent function is called. - ['vau ['prim_comb (rec-lambda recurse (de params indent) (let ( + ['vau ['prim_comb (rec-lambda recurse (de env_stack params indent) (let ( mde? (if (= 3 (len params)) (idx params 0)) vau_mde? (if (= nil mde?) [] [mde?]) de? (if mde? (.marked_symbol_value mde?)) @@ -316,34 +337,34 @@ body (if (= nil de?) (idx params 1) (idx params 2)) inner_env (make_tmp_inner_env vau_params de? de) _ (print_strip (indent_str indent) "in vau, evaluating body with 'later params - " body) - pe_body (partial_eval_helper body inner_env (+ 1 indent)) + pe_body (partial_eval_helper body inner_env (cons inner_env env_stack) (+ 1 indent)) _ (print_strip (indent_str indent) "in vau, result of evaluating body was " pe_body) _ (print_strip pe_body) ) ['comb 0 de? de variadic vau_params pe_body] )) vau]] - ['wrap ['prim_comb (parameters_evaled_proxy 0 (lambda (recurse de [evaled] indent) + ['wrap ['prim_comb (parameters_evaled_proxy 0 (lambda (recurse de env_stack [evaled] indent) (if (comb? evaled) (let ([wrap_level de? se variadic params body] (.comb evaled) wrapped_marked_fun ['comb (+ 1 wrap_level) de? se variadic params body] ) wrapped_marked_fun) ['marked_array false [['prim_comb recurse wrap] evaled]])) ) wrap]] - ['unwrap ['prim_comb (parameters_evaled_proxy 0 (lambda (recurse de [evaled] indent) + ['unwrap ['prim_comb (parameters_evaled_proxy 0 (lambda (recurse de env_stack [evaled] indent) (if (comb? evaled) (let ([wrap_level de? se variadic params body] (.comb evaled) unwrapped_marked_fun ['comb (- wrap_level 1) de? se variadic params body] ) unwrapped_marked_fun) ['marked_array false [['prim_comb recurse wrap] evaled]])) ) unwrap]] - ['eval ['prim_comb (rec-lambda recurse (de params indent) (let ( + ['eval ['prim_comb (rec-lambda recurse (de env_stack params indent) (let ( self ['prim_comb recurse eval] - eval_env (if (= 2 (len params)) (partial_eval_helper (idx params 1) de (+ 1 indent)) + eval_env (if (= 2 (len params)) (partial_eval_helper (idx params 1) de env_stack (+ 1 indent)) de) eval_env_v (if (= 2 (len params)) [eval_env] []) ) (if (not (marked_env? eval_env)) ['marked_array false (cons self params)] (let ( _ (print_strip (indent_str indent) " partial_evaling_body the first time " (idx params 0)) - body1 (partial_eval_helper (idx params 0) de (+ 1 indent)) + body1 (partial_eval_helper (idx params 0) de env_stack (+ 1 indent)) _ (print_strip (indent_str indent) "after first eval of param " body1) ; With this, we don't actually fail as this is always a legitimate uneval @@ -351,7 +372,7 @@ [ok unval_body] (try_unval body1 fail_handler) self_fallback (fail_handler body1) _ (print_strip "partial_evaling body for the second time in eval " unval_body) - body2 (if (= self_fallback unval_body) self_fallback (partial_eval_helper unval_body eval_env (+ 1 indent))) + body2 (if (= self_fallback unval_body) self_fallback (partial_eval_helper unval_body eval_env env_stack (+ 1 indent))) _ (print_strip (indent_str indent) "and body2 is " body2) ) body2)) )) eval]] @@ -359,7 +380,7 @@ ;TODO: This could go a lot farther, not stopping after the first 'later, etc ; Also, GAH on odd params - but only one by one - a later odd param can't be imm_eval cuz it will ; be frozen if an earlier cond is 'later.... - ['cond ['prim_comb (parameters_evaled_proxy nil (lambda (recurse de evaled_params indent) + ['cond ['prim_comb (parameters_evaled_proxy nil (lambda (recurse de env_stack evaled_params indent) (if (!= 0 (% (len evaled_params) 2)) (error (str "partial eval cond with odd evaled_params " evaled_params)) ((rec-lambda recurse_inner (i) (cond (later? (idx evaled_params i)) ['marked_array false (cons ['prim_comb recurse cond] (slice evaled_params i -1))] @@ -373,7 +394,7 @@ (needs_params_val_lambda int?) (needs_params_val_lambda string?) ; not even a gah, but kinda! - ['combiner? ['prim_comb (parameters_evaled_proxy nil (lambda (recurse de [evaled_param] indent) + ['combiner? ['prim_comb (parameters_evaled_proxy nil (lambda (recurse de env_stack [evaled_param] indent) (cond (comb? evaled_param) ['val true] (prim_comb? evaled_param) ['val true] (later? evaled_param) ['marked_array false [['prim_comb recurse combiner?] evaled_param]] @@ -381,7 +402,7 @@ ) )) combiner?]] ; not even a gah, but kinda! - ['env? ['prim_comb (parameters_evaled_proxy nil (lambda (recurse de [evaled_param] indent) + ['env? ['prim_comb (parameters_evaled_proxy nil (lambda (recurse de env_stack [evaled_param] indent) (cond (marked_env? evaled_param) ['val true] (later? evaled_param) ['marked_array false [['prim_comb recurse env?] evaled_param]] true ['val false] @@ -391,34 +412,34 @@ (needs_params_val_lambda bool?) (needs_params_val_lambda str-to-symbol) (needs_params_val_lambda get-text) - ['array? ['prim_comb (parameters_evaled_proxy nil (lambda (recurse de [evaled_param] indent) + ['array? ['prim_comb (parameters_evaled_proxy nil (lambda (recurse de env_stack [evaled_param] indent) (cond (later? evaled_param) ['marked_array false [['prim_comb recurse array?] evaled_param]] (marked_array? evaled_param) ['val true] true ['val false] ) )) array?]] - ['array ['prim_comb (parameters_evaled_proxy nil (lambda (recurse de evaled_params indent) + ['array ['prim_comb (parameters_evaled_proxy nil (lambda (recurse de env_stack evaled_params indent) ['marked_array true evaled_params] )) array]] - ['len ['prim_comb (parameters_evaled_proxy nil (lambda (recurse de [evaled_param] indent) + ['len ['prim_comb (parameters_evaled_proxy nil (lambda (recurse de env_stack [evaled_param] indent) (cond (later? evaled_param) ['marked_array false [['prim_comb recurse len] evaled_param]] (marked_array? evaled_param) ['val (len (.marked_array_values evaled_param))] true (error (str "bad type to len " evaled_param)) ) )) len]] - ['idx ['prim_comb (parameters_evaled_proxy nil (lambda (recurse de [evaled_array evaled_idx] indent) + ['idx ['prim_comb (parameters_evaled_proxy nil (lambda (recurse de env_stack [evaled_array evaled_idx] indent) (cond (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 [['prim_comb recurse idx] evaled_array evaled_idx]] ) )) idx]] - ['slice ['prim_comb (parameters_evaled_proxy nil (lambda (recurse de [evaled_array evaled_begin evaled_end] indent) + ['slice ['prim_comb (parameters_evaled_proxy nil (lambda (recurse de env_stack [evaled_array evaled_begin evaled_end] indent) (cond (and (val? evaled_begin) (val? evaled_end) (marked_array? evaled_array) (.marked_array_is_val evaled_array)) ['marked_array true (slice (.marked_array_values evaled_array) (.val evaled_begin) (.val evaled_end))] true ['marked_array false [['prim_comb recurse slice] evaled_array evaled_idx evaled_begin evaled_end]] ) )) slice]] - ['concat ['prim_comb (parameters_evaled_proxy nil (lambda (recurse de evaled_params indent) + ['concat ['prim_comb (parameters_evaled_proxy nil (lambda (recurse de env_stack evaled_params indent) (cond (foldl (lambda (a x) (and a (and (marked_array? x) (.marked_array_is_val x))) true evaled_params) ['marked_array true (lapply concat (map (lambda (x) (.marked_array_values x)) evaled_params))] @@ -442,7 +463,7 @@ (needs_params_val_lambda >=) ; these could both be extended to eliminate other known true values except for the end and vice-versa - ['and ['prim_comb (parameters_evaled_proxy nil (lambda (recurse de evaled_params indent) + ['and ['prim_comb (parameters_evaled_proxy nil (lambda (recurse de env_stack evaled_params indent) ((rec-lambda inner_recurse (i) (cond (= i (- (len evaled_params) 1)) (idx evaled_params i) (later? (idx evaled_params i)) ['marked_array false (cons ['prim_comb recurse and] (slice evaled_params i -1))] @@ -451,7 +472,7 @@ ) 0) )) and]] ; see above for improvement - ['or ['prim_comb (parameters_evaled_proxy nil (lambda (recurse de evaled_params indent) + ['or ['prim_comb (parameters_evaled_proxy nil (lambda (recurse de env_stack evaled_params indent) ((rec-lambda inner_recurse (i) (cond (= i (- (len evaled_params) 1)) (idx evaled_params i) (later? (idx evaled_params i)) ['marked_array false (cons ['prim_comb recurse or] (slice evaled_params i -1))] @@ -476,11 +497,11 @@ (give_up_eval_params slurp) (give_up_eval_params get_line) (give_up_eval_params write_file) - ['empty_env ['env true [nil]]] + ['empty_env ['env true nil [nil]]] nil ] root_env] - partial_eval (lambda (x) (partial_eval_helper (mark x) root_marked_env 0)) + partial_eval (lambda (x) (partial_eval_helper (mark x) root_marked_env [] 0)) ) (provide partial_eval strip print_strip) ))