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

Fixed bug with y, but still not partially evaluating the lets with later :/

Browse Source
This commit is contained in:
Nathan Braswell
2021-09-12 01:37:07 -04:00
parent f89b21420a
commit ec9083a958
2 changed files with 58 additions and 26 deletions
Download Patch File Download Diff File Expand all files Collapse all files

83
partial_eval.kp
View File

@@ -78,7 +78,6 @@
true ['val x])) true ['val x]))
strip (rec-lambda recurse (x) strip (rec-lambda recurse (x)
(do (println "calling strip with " x)
(cond (val? x) (.val x) (cond (val? x) (.val x)
(marked_array? x) (let (stripped_values (map recurse (.marked_array_values x))) (marked_array? x) (let (stripped_values (map recurse (.marked_array_values x)))
(if (.marked_array_is_val x) (cons array stripped_values) (if (.marked_array_is_val x) (cons array stripped_values)
@@ -91,25 +90,38 @@
(prim_comb? x) (idx x 2) (prim_comb? x) (idx x 2)
(marked_env? x) (error "Env escaped to strip!") (marked_env? x) (error "Env escaped to strip!")
true (error (str "some other strip? " x)) true (error (str "some other strip? " x))
)) )
) )
print_strip (lambda (x) (println ((rec-lambda recurse (x)
(cond (val? x) (.val x)
(marked_array? x) (let (stripped_values (map recurse (.marked_array_values x)))
(if (.marked_array_is_val x) (cons array stripped_values)
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 actual_function] (.comb x)) (str "<comb " wrap_level " " params " " (recurse body) ">"))
(prim_comb? x) (idx x 2)
(marked_env? x) (error "Env escaped to strip!")
true (error (str "some other strip? " x))
)
) x)))
; A bit wild, but what if instead of is_value we had an evaluation level integer, kinda like wrap? ; A bit wild, but what if instead of is_value we had an evaluation level integer, kinda like wrap?
; when lowering, it could just turn into multiple evals or somesuch, though we'd have to be careful of envs... ; when lowering, it could just turn into multiple evals or somesuch, though we'd have to be careful of envs...
try_unval (rec-lambda recurse (x) (let (_ (println "try_unvaling " x) r try_unval (rec-lambda recurse (x fail_f) (let (_ (println "try_unvaling " x) r
(cond (marked_array? x) (if (not (.marked_array_is_val x)) [false nil] (cond (marked_array? x) (if (not (.marked_array_is_val x)) [false (fail_f x)]
(let ([sub_ok subs] (foldl (lambda ([ok a] x) (let ([nok p] (recurse x)) (let ([sub_ok subs] (foldl (lambda ([ok a] x) (let ([nok p] (recurse x fail_f))
[(and ok nok) (concat a [p])])) [(and ok nok) (concat a [p])]))
[true []] [true []]
(.marked_array_values x))) (.marked_array_values x)))
(if sub_ok [true ['marked_array false subs]] [sub_ok ['marked_array false subs]]))
[false nil])))
(marked_symbol? x) (if (.marked_symbol_is_val x) [true ['marked_symbol false (.marked_symbol_value x)]] (marked_symbol? x) (if (.marked_symbol_is_val x) [true ['marked_symbol false (.marked_symbol_value x)]]
[false nil]) [false (fail_f x)])
true [true x] true [true x]
) _ (println "\tresult was " r)) r) ) _ (println "\tresult was " r)) r)
) )
try_unval_array (lambda (x) (foldl (lambda ([ok a] x) (let ([nok p] (try_unval x)) try_unval_array (lambda (x) (foldl (lambda ([ok a] x) (let ([nok p] (try_unval x (lambda (_) nil)))
[(and ok nok) (concat a [p])])) [(and ok nok) (concat a [p])]))
[true []] [true []]
x)) x))
@@ -153,11 +165,13 @@
(marked_array? x) (cond (.marked_array_is_val x) x (marked_array? x) (cond (.marked_array_is_val x) x
(= 0 (len (.marked_array_values x))) (error "Partial eval on empty array") (= 0 (len (.marked_array_values x))) (error "Partial eval on empty array")
true (let (values (.marked_array_values x) true (let (values (.marked_array_values x)
_ (println (indent_str indent) "partial_evaling comb " (idx values 0))
comb (recurse (idx values 0) env true (+ 1 indent)) comb (recurse (idx values 0) env true (+ 1 indent))
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!")
_ (println (indent_str indent) " total is " x) _ (println (indent_str indent) " total is " x)
_ (println (indent_str indent) " evaled comb is " comb) _ (println (indent_str indent) " evaled comb is " comb)
ident (+ 1 indent)
) )
; Replacing the old note here with one that mentions that ; Replacing the old note here with one that mentions that
; we use the imm_eval to know if it's ok to generate ; we use the imm_eval to know if it's ok to generate
@@ -167,18 +181,21 @@
(cond (later? comb) ['marked_array false (cons comb literal_params)] (cond (later? comb) ['marked_array false (cons comb literal_params)]
(prim_comb? comb) ((.prim_comb comb) env literal_params imm_eval (+ 1 indent)) (prim_comb? comb) ((.prim_comb comb) env literal_params imm_eval (+ 1 indent))
(comb? comb) (let ( (comb? comb) (let (
rp_eval (lambda (p) (recurse p env false (+ 1 indent)))
[wrap_level de? se variadic params body actual_function] (.comb comb) [wrap_level de? se variadic params body actual_function] (.comb comb)
[ok appropriatly_evaled_params] ((rec-lambda param-recurse (wrap params) ensure_val_params (map ensure_val literal_params)
_ (println (indent_str indent) "partial_evaling params with wrap level " wrap_level " " ensure_val_params)
[ok appropriatly_evaled_params] ((rec-lambda param-recurse (wrap cparams)
(if (!= 0 wrap) (if (!= 0 wrap)
(let (rp_eval (lambda (p) (recurse p env false (+ 1 indent))) (let (pre_evaled (map rp_eval cparams)
pre_evaled (map rp_eval params)
[ok unval_params] (try_unval_array pre_evaled)) [ok unval_params] (try_unval_array pre_evaled))
(if (not ok) [ok nil] (if (not ok) [ok nil]
(let (evaled_params (map rp_eval unval_params)) (let (evaled_params (map rp_eval unval_params))
(param-recurse (- wrap 1) evaled_params)))) (param-recurse (- wrap 1) evaled_params))))
[true params]) [true cparams])
) wrap_level (map ensure_val literal_params)) ) wrap_level ensure_val_params)
) (if (not ok) ['marked_array false (cons comb literal_params)] ) (if (not ok) ['marked_array false (cons comb (if (> wrap_level 0) (map rp_eval literal_params)
literal_params))]
(let ( (let (
final_params (if variadic (concat (slice appropriatly_evaled_params 0 (- (len params) 1)) final_params (if variadic (concat (slice appropriatly_evaled_params 0 (- (len params) 1))
[['marked_array true (slice appropriatly_evaled_params (- (len params) 1) -1)]]) [['marked_array true (slice appropriatly_evaled_params (- (len params) 1) -1)]])
@@ -205,6 +222,7 @@
; We check with closes_over_var_from_this_env_marked, which can be made more ; We check with closes_over_var_from_this_env_marked, which can be made more
; sophisticated, see its definition ; sophisticated, see its definition
_ (println (indent_str indent) "partial_evaling body " body)
func_result (recurse body inner_env imm_eval (+ 1 indent)) func_result (recurse body inner_env imm_eval (+ 1 indent))
_ (println (indent_str indent) "evaled result of function call (imm_eval was " imm_eval ") is " func_result) _ (println (indent_str indent) "evaled result of function call (imm_eval was " imm_eval ") is " func_result)
@@ -212,11 +230,14 @@
result_closes_over (closes_over_var_from_this_env_marked inner_env func_result) result_closes_over (closes_over_var_from_this_env_marked inner_env 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 result is later? " result_is_later " and result_closes_over " result_closes_over)
result (if (and result_is_later result_closes_over) result (if (and result_is_later result_closes_over)
; this is exponential-y - we retry without imm to see if we can ; this is exponential-y - we retry without imm to see if we can
; have a better partial eval'd later instead of giving up entirely ; have a better partial eval'd later instead of giving up entirely
(let (comb (recurse (idx values 0) env false (+ 1 indent))) (let (
['marked_array false (cons comb literal_params)]) _ (println (indent_str indent) "partial_evaling retrying comb and parameters after fail b/c result_is_later and result_closes_over " (idx values 0) " with wrap_level " wrap_level " and params " literal_params)
func_result) comb (recurse (idx values 0) env false (+ 1 indent)))
['marked_array false (cons comb (if (> wrap_level 0) (map rp_eval ensure_val_params)
literal_params))])
func_result)
) result))) ) result)))
true (error (str "Partial eval noticed that you will likely call not a function " comb " total is " x))))) true (error (str "Partial eval noticed that you will likely call not a function " comb " total is " x)))))
true (error (str "impossible partial_eval value " x)) true (error (str "impossible partial_eval value " x))
@@ -226,6 +247,7 @@
needs_params_val_lambda (vau de (f_sym) (let ( needs_params_val_lambda (vau de (f_sym) (let (
actual_function (eval f_sym de) actual_function (eval f_sym de)
handler (rec-lambda recurse (de params imm_eval indent) (let ( handler (rec-lambda recurse (de params imm_eval 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 false (+ 1 indent))) params) evaled_params (map (lambda (p) (partial_eval_helper p de false (+ 1 indent))) params)
) )
(if (is_all_values evaled_params) (mark (lapply actual_function (map strip evaled_params))) (if (is_all_values evaled_params) (mark (lapply actual_function (map strip evaled_params)))
@@ -234,6 +256,7 @@
give_up_eval_params (vau de (f_sym) (let ( give_up_eval_params (vau de (f_sym) (let (
actual_function (eval f_sym de) actual_function (eval f_sym de)
handler (rec-lambda recurse (de params imm_eval indent) (let ( handler (rec-lambda recurse (de params imm_eval 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 false (+ 1 indent))) params) evaled_params (map (lambda (p) (partial_eval_helper p de false (+ 1 indent))) params)
) )
['marked_array false (cons ['prim_comb recurse actual_function] evaled_params)])) ['marked_array false (cons ['prim_comb recurse actual_function] evaled_params)]))
@@ -243,6 +266,7 @@
; ! 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 (de params imm_eval indent) (let ( parameters_evaled_proxy (rec-lambda recurse (pasthr_ie inner_f) (lambda (de params imm_eval 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 (if (= i pasthr_ie) imm_eval false) (+ 1 indent))) [evaled_params l] (foldl (lambda ([ac i] p) (let (p (partial_eval_helper p de (if (= i pasthr_ie) imm_eval false) (+ 1 indent)))
[(concat ac [p]) (+ i 1)])) [(concat ac [p]) (+ i 1)]))
[[] 0] [[] 0]
@@ -297,18 +321,25 @@
['eval ['prim_comb (rec-lambda recurse (de params imm_eval indent) (let ( ['eval ['prim_comb (rec-lambda recurse (de params imm_eval indent) (let (
self ['prim_comb recurse eval] self ['prim_comb recurse eval]
_ (println "partial_evaling param 1 maybe in eval is (if it exists) " (if (= 2 (len params)) (idx params 1)))
eval_env (if (= 2 (len params)) (partial_eval_helper (idx params 1) de false (+ 1 indent)) eval_env (if (= 2 (len params)) (partial_eval_helper (idx params 1) de false (+ 1 indent))
de) de)
eval_env_v (if (= 2 (len params)) [eval_env] [])
) (if (not (marked_env? eval_env)) ['marked_array false (cons self params)] ) (if (not (marked_env? eval_env)) ['marked_array false (cons self params)]
(let ( (let (
_ (println (indent_str indent) "ok, env was " eval_env) _ (println (indent_str indent) "ok, env was " eval_env " partial_evaling_body the first time")
body1 (partial_eval_helper (idx params 0) de imm_eval (+ 1 indent)) body1 (partial_eval_helper (idx params 0) de imm_eval (+ 1 indent))
_ (println (indent_str indent) "after first eval of param " body1) _ (println (indent_str indent) "after first eval of param " body1)
[ok unval_body] (try_unval body1) ; With this, we don't actually fail as this is always a legitimate uneval
body2 (if ok (partial_eval_helper unval_body eval_env imm_eval (+ 1 indent)) fail_handler (lambda (failed) ['marked_array false (concat [self failed] eval_env_v)])
['marked_array false (cons self (if (= 2 (len params)) [body1 eval_env] [ok unval_body] (try_unval body1 fail_handler)
[body1]))]) self_fallback (fail_handler body1)
_ (println "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 imm_eval (+ 1 indent)))
;[ok unval_body] (try_unval body1 (lambda (failed) nil))
;body2 (if ok (partial_eval_helper unval_body eval_env imm_eval (+ 1 indent))
; self_fallback)
_ (println (indent_str indent) "and body2 is " body2) _ (println (indent_str indent) "and body2 is " body2)
) body2)) ) body2))
@@ -440,5 +471,5 @@
partial_eval (lambda (x) (partial_eval_helper (mark x) root_marked_env false 0)) partial_eval (lambda (x) (partial_eval_helper (mark x) root_marked_env false 0))
) )
(provide partial_eval strip) (provide partial_eval strip print_strip)
)) ))

1
partial_eval_test.kp
View File

@@ -7,6 +7,7 @@
; is the root_env, or if what we look up in whatever env is passed in matches something in the root env ; is the root_env, or if what we look up in whatever env is passed in matches something in the root env
partially_evaled (partial_eval code) partially_evaled (partial_eval code)
_ (println "Partially evaled: " partially_evaled) _ (println "Partially evaled: " partially_evaled)
_ (print_strip partially_evaled)
stripped (strip partially_evaled) stripped (strip partially_evaled)
_ (println "Stripped: " stripped) _ (println "Stripped: " stripped)
fully_evaled (eval stripped root_env) fully_evaled (eval stripped root_env)