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

prep for useing de bruijn

Browse Source
This commit is contained in:
Nathan Braswell
2021-10-17 17:39:38 -04:00
parent e322fc7cd7
commit 923c4565fb
1 changed files with 83 additions and 62 deletions
Download Patch File Download Diff File Expand all files Collapse all files

145
partial_eval.kp
View File

@@ -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 <handler_function>] - A primitive combiner! It has it's own special handler function to partial eval
; ['env is_real [ ['symbol marked_value ]... <upper_marked_env> ]] - A marked env
; ['env is_real de_bruijn_idx_or_nil [ ['symbol marked_value ]... <upper_marked_env> ]] - 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 "<comb " wrap_level " " de? " <se " (recurse se) "> " params " " (recurse body) ">"))
(comb? x) (let ([wrap_level de? se variadic params body] (.comb x))
(str "<comb " wrap_level " " de? " <se> " params " " (recurse body) ">"))
;(str "<comb " wrap_level " " de? " <se " (recurse se) "> " 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) ">")
"<no_upper_likely_root_env>"))
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)
))