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

First vau-involved partial evals working!

Browse Source
This commit is contained in:
Nathan Braswell
2021-08-15 01:27:53 -04:00
parent b3c02c82b3
commit 05092cba76
4 changed files with 62 additions and 12 deletions
Download Patch File Download Diff File Expand all files Collapse all files

3
collections.kp
View File

@@ -8,6 +8,7 @@
(lapply f (cons (recurse f z vs (+ i 1)) (map (lambda (x) (idx x i)) vs)))))) (lapply f (cons (recurse f z vs (+ i 1)) (map (lambda (x) (idx x i)) vs))))))
(lambda (f z & vs) (helper f z vs 0))) (lambda (f z & vs) (helper f z vs 0)))
reverse (lambda (x) (foldl (lambda (acc i) (cons i acc)) [] x)) reverse (lambda (x) (foldl (lambda (acc i) (cons i acc)) [] x))
zip (lambda (& xs) (lapply foldr (concat [(lambda (a & ys) (cons ys a)) []] xs)))
empty_dict [] empty_dict []
put (lambda (m k v) (cons [k v] m)) put (lambda (m k v) (cons [k v] m))
get-value-helper (rec-lambda recurse (dict key i) (if (>= i (len dict)) get-value-helper (rec-lambda recurse (dict key i) (if (>= i (len dict))
@@ -21,6 +22,6 @@
(recurse (eval [ [vau '_ [(idx (idx dict i) 0)] [ [vau 'inner [] 'inner] ] ] (idx (idx dict i) 1) ] env) dict (+ i 1))))) (recurse (eval [ [vau '_ [(idx (idx dict i) 0)] [ [vau 'inner [] 'inner] ] ] (idx (idx dict i) 1) ] env) dict (+ i 1)))))
(lambda (env dict) (helper env dict 0))) (lambda (env dict) (helper env dict 0)))
) )
(provide foldl foldr reverse empty_dict put get-value add-dict-to-env) (provide foldl foldr reverse zip empty_dict put get-value add-dict-to-env)
) )

2
k_prime.krak
View File

@@ -890,7 +890,7 @@ fun main(argc: int, argv: **char): int {
// cond uses TCO // cond uses TCO
env->set(str("cond"), make_builtin_combiner(str("cond"), 0, true, fun(params: vec<KPValue>, dynamic_env: *KPEnv): pair<*KPEnv, KPResult> { env->set(str("cond"), make_builtin_combiner(str("cond"), 0, true, fun(params: vec<KPValue>, dynamic_env: *KPEnv): pair<*KPEnv, KPResult> {
if (params.size % 2) != 0 { if (params.size % 2) != 0 {
return make_pair(null<KPEnv>(), KPResult::Err(kpString(str("Need even number of params to cond")))) return make_pair(null<KPEnv>(), KPResult::Err(kpString(str("Need even number of params to cond, have: ") + params.size + " last is " + pr_str(params[params.size-1], true))))
} }
for (var i = 0; i < params.size; i+=2;) { for (var i = 0; i < params.size; i+=2;) {
var ip = EVAL(dynamic_env, params[i]) var ip = EVAL(dynamic_env, params[i])

60
partial_eval.kp
View File

@@ -47,6 +47,12 @@
.env_marked (lambda (x) (idx x 1)) .env_marked (lambda (x) (idx x 1))
.env_real (lambda (x) (idx x 2)) .env_real (lambda (x) (idx x 2))
env-lookup-helper (rec-lambda recurse (dict key i fail success) (cond (and (= i (- (len dict)) 1) (= nil (idx dict i))) (fail)
(= i (- (len dict) 1)) (recurse (idx (idx dict i) 1) key 0 fail success)
(= key (idx (idx dict i) 0)) (success (idx (idx dict i) 1))
true (recurse dict key (+ i 1) fail success)))
env-lookup (lambda (env key) (env-lookup-helper (idx env 1) key 0 (lambda () (error (str key " not found in env " dict))) (lambda (x) x)))
strip (rec-lambda recurse (x) strip (rec-lambda recurse (x)
(cond (val? x) (.val x) (cond (val? x) (.val x)
(later? x) (.later x) (later? x) (.later x)
@@ -65,8 +71,7 @@
; partial_eval_helper always takes in unmarked expressions and makes marked ones, maintaining marked envs ; partial_eval_helper always takes in unmarked expressions and makes marked ones, maintaining marked envs
; ;
; If indeed we have to keep track of non-primitive combinator values (which I think makes sense for stripping), ; If indeed we have to keep track of non-primitive combinator values (which I think makes sense for stripping),
; we'll have to continually keep a map ; we'll have to continually keep a map of values to their definition (we do this now!).
; of values to their definition.
partial_eval_helper (rec-lambda recurse (x env comb_to_mark_map) partial_eval_helper (rec-lambda recurse (x env comb_to_mark_map)
(cond (= x true) [comb_to_mark_map ['val true ]] (cond (= x true) [comb_to_mark_map ['val true ]]
@@ -74,18 +79,32 @@
(env? x) (error "called partial_eval with an env " x) (env? x) (error "called partial_eval with an env " x)
(combiner? x) (error "called partial_eval with a combiner, not yet supported (assuming just parsed symbols etc) " x) (combiner? x) (error "called partial_eval with a combiner, not yet supported (assuming just parsed symbols etc) " x)
(string? x) [comb_to_mark_map ['val x]] (string? x) [comb_to_mark_map ['val x]]
(symbol? x) [comb_to_mark_map (get-value (.env_marked env) x)] (symbol? x) [comb_to_mark_map (env-lookup env x)]
(int? x) [comb_to_mark_map ['val x]] (int? x) [comb_to_mark_map ['val x]]
(and (array? x) (= 0 (len x))) (error "Partial eval on empty array") (and (array? x) (= 0 (len x))) (error "Partial eval on empty array")
(array? x) (let ( [comb_to_mark_map comb] (recurse (idx x 0) env comb_to_mark_map) ) (array? x) (let ( [comb_to_mark_map comb] (recurse (idx x 0) env comb_to_mark_map) )
; it seems like even if it's later we should be able to eval some?
; Maybe there should be something between 'later and 'comb made in vau
; for those sorts of cases, but maybe it doesn't matter?
(cond (later? comb) [comb_to_mark_map ['later x]] (cond (later? comb) [comb_to_mark_map ['later x]]
(prim_comb? comb) ((.prim_comb comb) env comb_to_mark_map (slice x 1 -1)) (prim_comb? comb) ((.prim_comb comb) env comb_to_mark_map (slice x 1 -1))
(comb? comb) (let ( (comb? comb) (let (
[wrap_level de? se params body actual_function] (.comb comb) [wrap_level de? se params body actual_function] (.comb comb)
; Env will need special checking for escaping, including when contained inside of an array or other combinator [comb_to_mark_map appropriatly_evaled_params] ((rec-lambda param-recurse (wrap params comb_to_mark_map)
; Actually, that extends to checking escaping for combinators in general, since they may close over laters (if (!= 0 wrap)
;subs (map (lambda (y) (recurse y env comb_to_mark_map)) x) (let ([comb_to_mark_map evaled_params]
) [comb_to_mark_map ['later x]]) (foldl (lambda ([comb_to_mark_map ac] p)
(let ([comb_to_mark_map p] (recurse p env comb_to_mark_map))
[comb_to_mark_map (concat ac [p])]))
[comb_to_mark_map []]
params))
(param-recurse (- wrap 1) evaled_params comb_to_mark_map))
[comb_to_mark_map params])
) wrap_level params comb_to_mark_map)
de_entry (if (!= nil de?) [ [de? env] ]
[])
inner_env ['env (concat (zip params appropriatly_evaled_params) de_entry [se]) nil]
) (recurse body inner_env comb_to_mark_map))
true (error (str "Partial eval noticed that you will likely call not a function " x)))) true (error (str "Partial eval noticed that you will likely call not a function " x))))
(nil? x) [comb_to_mark_map ['val x]] (nil? x) [comb_to_mark_map ['val x]]
@@ -107,13 +126,38 @@
handler (lambda (de comb_to_mark_map params) [comb_to_mark_map ['later (cons actual_function params)]]) handler (lambda (de comb_to_mark_map params) [comb_to_mark_map ['later (cons actual_function params)]])
) [f_sym ['prim_comb handler actual_function]])) ) [f_sym ['prim_comb handler actual_function]]))
; Our job is made a lot easier by the fact that these will
; all be stripped and we only care about symbols and things that could contain symbols,
; namely arrays
;
; This is a conservative analysis, since we can't always tell what constructs introduce
; a new binding scope & would be shadowing... we should at least be able to implement it for
; vau/lambda, but we won't at first
closes_over_outside_vars (rec-lambda recurse (env body) (cond
(symbol? body) (env-lookup-helper (idx env 1) body 0 (lambda () false) (lambda (x) true))
(array? body) (foldl (lambda (a x) (or a (recurse env x))) false body)
true false))
root_marked_env ['env [ root_marked_env ['env [
; Ok, so for combinators, it should partial eval the body. ; Ok, so for combinators, it should partial eval the body.
; It should then check to see if the partial-evaled body has closed over ; 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 ; 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. ; 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. ; Note that this 'later may be re-evaluated later if the parent function is called.
(give_up vau) ;(give_up vau)
['vau ['prim_comb (lambda (de comb_to_mark_map params) (let (
de? (if (= 3 (len params)) (idx params 0))
vau_de? (if (= nil de?) [] [de])
vau_params (if (= nil de?) (idx params 0) (idx params 1))
body (if (= nil de?) (idx params 1) (idx params 2))
inner_env ['env (concat (map (lambda (p) [p ['later p]]) vau_params) (if (= nil de?) [] [ [de? ['later de?]] ]) [de]) nil]
[comb_to_mark_map pe_body] (partial_eval_helper body inner_env comb_to_mark_map)
spe_body (strip pe_body)
) (if (or (= nil (.env_real de)) (closes_over_outside_vars de spe_body)) [comb_to_mark_map ['later (concat [vau] vau_de? [vau_params spe_body])]]
[comb_to_mark_map ['comb 0 de? de vau_params spe_body
(do (println "evaling (eval " (str (concat [vau] vau_de? [vau_params spe_body]) (.env_real de)) ")" ) (eval (concat [vau] vau_de? [vau_params spe_body]) (.env_real de)))]]))
) vau]]
; eval should have it's parameters partially -evaled, then partially-eval e again. ; eval should have it's parameters partially -evaled, then partially-eval e again.
; failure can 'later at either point ; failure can 'later at either point

9
partial_eval_test.kp
View File

@@ -8,17 +8,22 @@
_ (println "Stripped: " stripped) _ (println "Stripped: " stripped)
fully_evaled (eval stripped) fully_evaled (eval stripped)
_ (println "Fully evaled: " fully_evaled) _ (println "Fully evaled: " fully_evaled)
_ (if (combiner? fully_evaled) (println "..and called " (fully_evaled 1337)))
_ (println) _ (println)
) fully_evaled)) ) fully_evaled))
simple_add (read-string "(+ 1 2)") simple_add (read-string "(+ 1 2)")
vau_with_add (read-string "(vau (x) (+ 1 2))") vau_with_add (read-string "(vau (x) (+ 1 2))")
vau_with_add_called (read-string "((vau (x) (+ 1 2)) 4)") vau_with_add_called (read-string "((vau (x) (+ 1 2)) 4)")
vau_with_passthrough (read-string "((vau (x) x) 4)")
vau_with_no_eval_add (read-string "((vau (x) (+ 1 2 x)) 4)")
vau_with_add_p (read-string "(vau de (x) (+ (eval x de) (+ 1 2)))") vau_with_add_p (read-string "(vau de (x) (+ (eval x de) (+ 1 2)))")
vau_with_add_p_called (read-string "((vau de (x) (+ (eval x de) (+ 1 2))) 4)") vau_with_add_p_called (read-string "((vau de (x) (+ (eval x de) (+ 1 2))) 4)")
_ (test-case simple_add) _ (test-case simple_add)
_ (test-case vau_with_add) _ (test-case vau_with_add)
_ (test-case vau_with_add_p)
_ (test-case vau_with_add_called) _ (test-case vau_with_add_called)
_ (test-case vau_with_add_p_called) _ (test-case vau_with_passthrough)
_ (test-case vau_with_no_eval_add)
;_ (test-case vau_with_add_p)
;_ (test-case vau_with_add_p_called)
) nil)) ) nil))