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

Removed check_for_symbols, which was a bad idea generally. Simplify into combiner_return_ok, and fix *eval bug* - it didn't check for any sort of combiner_return_ok like thing, even though it's doing the same thing as a function call basically, by changing the env something is evaluated in.

Browse Source 
Also just re-write eval using the parital_eval wrapper, enforce it taking in total-values.

In the future, can allow more partial eval
        1) veval, returned from eval and posssibly others, essentailly (unwrap eval), which allows embedding partially-complete evals places without having to do something ugly like (eval (ensure_val partially_evaluated))
        2) Relax paramter is total-value to head-value and check for env_id inside it

Immediatly: Debug bad partial evaluation on main test cases & crash with list index out of range
This commit is contained in:
Nathan Braswell
2022-02-03 02:41:14 -05:00
parent dd28087818
commit a8f8f9df89
2 changed files with 104 additions and 88 deletions
Download Patch File Download Diff File Expand all files Collapse all files

127
partial_eval.csc
View File

@@ -375,8 +375,6 @@
) )
))) (lambda (x) (let* ((_ (print_strip "stripping: " x)) (r (helper x false)) (_ (println "result of strip " r))) r)))) ))) (lambda (x) (let* ((_ (print_strip "stripping: " x)) (r (helper x false)) (_ (println "result of strip " r))) r))))
; 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...
(try_unval (rec-lambda recurse (x fail_f) (try_unval (rec-lambda recurse (x fail_f)
(cond ((marked_array? x) (mif (not (.marked_array_is_val x)) (array false (fail_f x)) (cond ((marked_array? x) (mif (not (.marked_array_is_val x)) (array false (fail_f x))
(dlet (((sub_ok subs) (foldl (dlambda ((ok a) x) (dlet (((nok p) (recurse x fail_f))) (dlet (((sub_ok subs) (foldl (dlambda ((ok a) x) (dlet (((nok p) (recurse x fail_f)))
@@ -400,29 +398,9 @@
(true x) (true x)
) )
)) ))
(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))
(_ (if r (println "!!! contains symbols found " x " in symbols " symbols))))
r))
((marked_array? x) (foldl (lambda (a x) (or a (recurse stop_envs symbols x))) false (.marked_array_values x)))
((comb? x) (dlet (((wrap_level env_id de? se variadic params body) (.comb x)))
(or (recurse stop_envs symbols se) (recurse stop_envs (filter (lambda (y) (not (or (= de? y) (in_array y params)))) symbols) body))))
((prim_comb? x) false) ; TODO: memoize!
((marked_env? x) (let ((inner (.env_marked x))) (check_for_env_id_in_result (rec-lambda check_for_env_id_in_result (s_env_id x) (cond
(cond ((in_array (.marked_env_idx x) stop_envs) false)
((foldl (lambda (a x) (or a (recurse stop_envs symbols (idx x 1)))) false (slice inner 0 -2)) true)
((!= nil (idx inner -1)) (recurse stop_envs symbols (idx inner -1)))
(true false))))
(true (error (str "Something odd passed to contains_symbols " x)))
)))
(check_for_env_id_in_result (rec-lambda check_for_env_id_in_result (s_env_id x) (dlet (
(fp (needed_for_progress x))
) (cond
((= nil fp) false)
((!= true fp) (in_array s_env_id fp))
((val? x) false) ((val? x) false)
((marked_symbol? x) false) ((marked_symbol? x) false)
((marked_array? x) (foldl (lambda (a x) (or a (check_for_env_id_in_result s_env_id x))) false (.marked_array_values x))) ((marked_array? x) (foldl (lambda (a x) (or a (check_for_env_id_in_result s_env_id x))) false (.marked_array_values x)))
@@ -437,7 +415,20 @@
((!= nil (idx inner -1)) (check_for_env_id_in_result s_env_id (idx inner -1))) ((!= nil (idx inner -1)) (check_for_env_id_in_result s_env_id (idx inner -1)))
(true false)))) (true false))))
(true (error (str "Something odd passed to check_for_env_id_in_result " x))) (true (error (str "Something odd passed to check_for_env_id_in_result " x)))
)))) )))
(combiner_return_ok (rec-lambda combiner_return_ok (func_result env_id)
(if (not (later_head? func_result)) (check_for_env_id_in_result env_id func_result)
; special cases now
; *(veval body {env}) => (combiner_return_ok {env})
; The reason we don't have to check body is that this form is only creatable via function call, so body *has* to either be or have-been a value and only need {env}
; Either it's created by eval, in which case it's fine, or it's created by something like (eval (array veval x de) de2) and the array has checked it, etc
; Might be easier to check for (eval body env) where (and (combiner_return_ok body) (combiner_return_ok {env}))
; NOTE: if we later allow calling combiners with head-vals, then veval makes more sense again
; (func ...params) => (and (doesn't take de func) (foldl combiner_return_ok (cons func params)))
false
)
))
; TODO: instead of returning the later symbols, we could create a new value of a new type ; 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 ; ['ref de_bruijn_index_of_env index_into_env] or somesuch. Could really simplify
@@ -522,6 +513,8 @@
((wrap_level env_id de? se variadic params body) (.comb comb)) ((wrap_level env_id de? se variadic params body) (.comb comb))
(ensure_val_params (map ensure_val literal_params)) (ensure_val_params (map ensure_val literal_params))
; TODO: If I checked for is val before each part of the loop, try_unval
; wouldn't have to be falliable
((ok pectx err single_eval_params_if_appropriate appropriatly_evaled_params) ((rec-lambda param-recurse (wrap cparams pectx single_eval_params_if_appropriate) ((ok pectx err single_eval_params_if_appropriate appropriatly_evaled_params) ((rec-lambda param-recurse (wrap cparams pectx single_eval_params_if_appropriate)
(dlet ( (dlet (
(_ (print (indent_str indent) "For initial rp_eval:")) (_ (print (indent_str indent) "For initial rp_eval:"))
@@ -589,10 +582,8 @@
;(failed (or rec_stop (not able_to_sub_env) (and result_is_later result_closes_over))) ;(failed (or rec_stop (not able_to_sub_env) (and result_is_later result_closes_over)))
((failed reason) (cond (rec_stop (array true "infinite recursion")) ((failed reason) (cond (rec_stop (array true "infinite recursion"))
((check_for_env_id_in_result env_id func_result) (array true "has env id in result")) ((not (combiner_return_ok func_result env_id)) (array true "combiner return not ok"))
((not (later_head? func_result)) (array false "")) (true (array false "wooo"))
(true (array (dlet ((stop_envs ((rec-lambda ser (a e) (mif e (ser (cons (.marked_env_idx e) a) (idx (.env_marked e) -1)) a)) (array) se)))
(contains_symbols stop_envs (concat params (mif de? (array de?) (array))) func_result)) "both later and contains symbols"))
)) ))
(_ (println (indent_str indent) (if failed (str "failed because " reason) (_ (println (indent_str indent) (if failed (str "failed because " reason)
@@ -694,31 +685,55 @@
(marked_array false true (array (marked_prim_comb recurse 'unwrap) evaled))))) (marked_array false true (array (marked_prim_comb recurse 'unwrap) evaled)))))
) 'unwrap)) ) 'unwrap))
(array 'eval (marked_prim_comb (rec-lambda recurse (only_head de env_stack pectx params indent) (dlet ( (array 'eval (marked_prim_comb (parameters_evaled_proxy 0 (lambda (recurse only_head de env_stack pectx evaled_params indent)
(self (marked_prim_comb recurse 'eval)) (if (not (is_all_values evaled_params)) (array pectx nil (marked_array false true (cons (marked_prim_comb recurse 'eval) evaled_params)))
(if (and (= 2 (len evaled_params)) (not (marked_env? (idx evaled_params 1)))) (array pectx nil (marked_array false true (cons (marked_prim_comb recurse 'eval) evaled_params)))
(_ (print_strip (indent_str indent) " partial_evaling_body the first time " (idx params 0))) (dlet (
((pectx body_err body1) (partial_eval_helper (idx params 0) false de env_stack pectx (+ 1 indent))) (body (idx evaled_params 0))
(_ (print_strip (indent_str indent) "after first eval of param " body1)) (implicit_env (!= 2 (len evaled_params)))
(eval_env (if implicit_env de (idx evaled_params 1)))
((pectx env_err eval_env) (mif (= 2 (len params)) (partial_eval_helper (idx params 1) false de env_stack pectx (+ 1 indent)) ((ok unval_body) (try_unval body (lambda (_) nil)))
(array pectx nil de))) (_ (if (not ok) (error "actually impossible eval unval")))
(eval_env_v (mif (= 2 (len params)) (array eval_env) (array))) ((pectx err body2) (partial_eval_helper unval_body only_head eval_env env_stack pectx (+ 1 indent)))
) (mif (or (!= nil body_err) (!= nil env_err)) (array pectx (mif body_err body_err env_err) nil) ) (cond ((!= nil err) (array pectx err nil))
(mif (not (marked_env? eval_env)) (array pectx (mif body_err body_err env_err) (marked_array false true (concat (array self body1) eval_env_v))) ; If our env was implicit, then our unval'd code can be inlined directly in our caller
(dlet ( (implicit_env (array pectx nil body2))
; Is this safe? Could this not move eval_env_v inside a comb? ((combiner_return_ok body2 (.marked_env_idx eval_env)) (array pectx nil body2))
; With this, we don't actually fail as this is always a legitimate uneval ; TODO: Could replace this with (veval <body2> <eval_env>)
(fail_handler (lambda (failed) (marked_array false true (concat (array self failed) eval_env_v)))) (true (array pectx nil (marked_array false true (cons (marked_prim_comb recurse 'eval) evaled_params))))
((ok unval_body) (try_unval body1 fail_handler)) ))))
(self_fallback (fail_handler body1))
(_ (print_strip (indent_str indent) "partial_evaling body for the second time in eval " unval_body))
((pectx err body2) (mif (= self_fallback unval_body) (array pectx nil self_fallback)
(partial_eval_helper unval_body only_head eval_env env_stack pectx (+ 1 indent))))
(_ (print_strip (indent_str indent) "and body2 is " body2))
) (mif err (array pectx err nil) (array pectx nil body2)))))
)) 'eval)) )) 'eval))
;(array 'eval (marked_prim_comb (rec-lambda recurse (only_head de env_stack pectx params indent) (dlet (
; (self (marked_prim_comb recurse 'eval))
; (_ (print_strip (indent_str indent) " partial_evaling_body the first time " (idx params 0)))
; ((pectx body_err body1) (partial_eval_helper (idx params 0) false de env_stack pectx (+ 1 indent)))
; (_ (print_strip (indent_str indent) "after first eval of param " body1))
; ((pectx env_err eval_env) (mif (= 2 (len params)) (partial_eval_helper (idx params 1) false de env_stack pectx (+ 1 indent))
; (array pectx nil de)))
; (eval_env_v (mif (= 2 (len params)) (array eval_env) (array)))
; ) (mif (or (!= nil body_err) (!= nil env_err)) (array pectx (mif body_err body_err env_err) nil)
; (mif (not (marked_env? eval_env)) (array pectx (mif body_err body_err env_err) (marked_array false true (concat (array self body1) eval_env_v)))
; (dlet (
; ; WAIT, this doesn't enforce that the parameter is a value pre-uneval!
; ; That means that it could have fake envs that will now change parent chain
; ; Is this safe? Could this not move eval_env_v inside a comb?
; ; With this, we don't actually fail as this is always a legitimate uneval
; (fail_handler (lambda (failed) (marked_array false true (concat (array self failed) eval_env_v))))
; ((ok unval_body) (try_unval body1 fail_handler))
; (self_fallback (fail_handler body1))
; (_ (print_strip (indent_str indent) "partial_evaling body for the second time in eval " unval_body))
; ((pectx err body2) (mif (= self_fallback unval_body) (array pectx nil self_fallback)
; (partial_eval_helper unval_body only_head eval_env env_stack pectx (+ 1 indent))))
; (_ (print_strip (indent_str indent) "and body2 is " body2))
; ) (mif err (array pectx err nil) (array pectx nil body2)))))
;)) 'eval))
(array 'cond (marked_prim_comb (rec-lambda recurse (only_head de env_stack pectx params indent) (array 'cond (marked_prim_comb (rec-lambda recurse (only_head de env_stack pectx params indent)
(mif (!= 0 (% (len params) 2)) (array pectx (str "partial eval cond with odd params " params) nil) (mif (!= 0 (% (len params) 2)) (array pectx (str "partial eval cond with odd params " params) nil)
((rec-lambda recurse_inner (i so_far pectx) ((rec-lambda recurse_inner (i so_far pectx)
@@ -3475,7 +3490,11 @@
((compiled_value_ptr compiled_value_code compiled_value_error ctx) (compile-inner ctx marked_code true)) ((compiled_value_ptr compiled_value_code compiled_value_error ctx) (compile-inner ctx marked_code true))
((datasi funcs memo root_marked_env pectx) ctx) ((datasi funcs memo root_marked_env pectx) ctx)
; Swap for when need to profile what would be an error
;(compiled_value_ptr (mif compiled_value_error 0 compiled_value_ptr))
(_ (mif compiled_value_error (error compiled_value_error))) (_ (mif compiled_value_error (error compiled_value_error)))
(_ (if (= nil compiled_value_ptr) (error (str "compiled top-level to code for some reason!? have code " compiled_value_code)))) (_ (if (= nil compiled_value_ptr) (error (str "compiled top-level to code for some reason!? have code " compiled_value_code))))
; Ok, so the outer loop handles the IO monads ; Ok, so the outer loop handles the IO monads
@@ -4033,8 +4052,8 @@
(write_file "./csc_out.wasm" (compile (partial_eval (read-string (slurp "to_compile.kp"))))) (write_file "./csc_out.wasm" (compile (partial_eval (read-string (slurp "to_compile.kp")))))
)) ))
;) (test-most)) ) (test-most))
) (run-compiler)) ;) (run-compiler))
;) (single-test)) ;) (single-test))
) )

65
to_compile.kp
View File

@@ -1,60 +1,57 @@
((wrap (vau root_env (quote) ((wrap (vau root_env (quote)
((wrap (vau (let1) ((wrap (vau (let1)
(let1 lambda (vau se (p b1) (wrap (eval (array vau p b1) se))) (let1 lambda (vau se (p b1) (wrap (eval (array vau p b1) se)))
(let1 current-env (vau de () de) (let1 current-env (vau de () de)
(let1 cons (lambda (h t) (concat (array h) t)) (let1 cons (lambda (h t) (concat (array h) t))
(let1 lapply (lambda (f1 p) (eval (cons (unwrap f1) p) (current-env))) (let1 lapply (lambda (f1 p) (eval (cons (unwrap f1) p) (current-env)))
(let1 vapply (lambda (f2 p ede) (eval (cons f2 p) ede)) (let1 vapply (lambda (f2 p ede) (eval (cons f2 p) ede))
(let1 Y (lambda (f3) (let1 Y (lambda (f3)
((lambda (x1) (x1 x1)) ((lambda (x1) (x1 x1))
(lambda (x2) (f3 (lambda (& y) (lapply (x2 x2) y)))))) (lambda (x2) (f3 (lambda (& y) (lapply (x2 x2) y))))))
(let1 vY (lambda (f) (let1 vY (lambda (f)
((lambda (x3) (x3 x3)) ((lambda (x3) (x3 x3))
(lambda (x4) (f (vau de (& y) (vapply (x4 x4) y de)))))) (lambda (x4) (f (vau de1 (& y) (vapply (x4 x4) y de1))))))
(let1 let (vY (lambda (recurse) (vau de (vs b) (cond (= (len vs) 0) (eval b de) (let1 let (vY (lambda (recurse) (vau de2 (vs b) (cond (= (len vs) 0) (eval b de2)
true (vapply let1 (array (idx vs 0) (idx vs 1) (array recurse (slice vs 2 -1) b)) de))))) true (vapply let1 (array (idx vs 0) (idx vs 1) (array recurse (slice vs 2 -1) b)) de2)))))
(let ( (let (
a 1 ;a 1
lcompose (lambda (g f) (lambda (& args) (lapply g (array (lapply f args))))) ;lcompose (lambda (g f) (lambda (& args) (lapply g (array (lapply f args)))))
rec-lambda (vau se (n p b) (eval (array Y (array lambda (array n) (array lambda p b))) se)) rec-lambda (vau se (n p b) (eval (array Y (array lambda (array n) (array lambda p b))) se))
if (vau de (con than & else) (cond (eval con de) (eval than de) ;if (vau de (con than & else) (cond (eval con de) (eval than de)
(> (len else) 0) (eval (idx else 0) de) ; (> (len else) 0) (eval (idx else 0) de)
true false)) ; true false))
map (lambda (f l)
(let (helper (rec-lambda recurse (f l n i) ; The sticking point for map seemed to be a mis-step with being over conservitive finding de, so renaming de's to be unique lets it procede
(cond (= i (len l)) n ; Although, without that, it now runs 60x longer and then still has the same compiles to call problem.
(<= i (- (len l) 4)) (recurse f l (concat n (array ; - Is it due to failure to compile cuasing re-attempts in an exponential way?
(f (idx l (+ i 0))) ; - Nope, contains-symbols has come home to roost
(f (idx l (+ i 1))) map (lambda (f5 l5)
(f (idx l (+ i 2))) ; now maybe errors on can't find helper?
(f (idx l (+ i 3))) (let (helper (rec-lambda recurse (f4 l4 n4 i4)
)) (+ i 4)) (cond (= i4 (len l4)) n4
true (recurse f l (concat n (array (f (idx l i)))) (+ i 1))))) ;(<= i (- (len l) 4)) (recurse f l (concat n (array
(helper f l (array) 0))) ; (f (idx l (+ i 0)))
; (f (idx l (+ i 1)))
; (f (idx l (+ i 2)))
; (f (idx l (+ i 3)))
; )) (+ i 4))
true (recurse f4 l4 (concat n4 (array (f4 (idx l4 i4)))) (+ i4 1)))))
(helper f5 l5 (array) 0)))
test (map (lambda (x) (+ x 1)) (array 1 2)) test (map (lambda (x) (+ x 1)) (array 1 2))
monad (array 'open 3 "test_self_out" (lambda (fd code) ;test ((rec-lambda recurse (n) (cond (= 0 n) 1
(array 'write fd "wabcdefghijklmnopqrstuvwx" (lambda (written code) ; true (* n (recurse (- n 1))))) 5)
(array 'exit (if (= 0 written) 12 14)))))) ;monad (array 'open 3 "test_self_out" (lambda (fd code)
; (array 'write fd "wabcdefghijklmnopqrstuvwx" (lambda (written code)
; (array 'exit (if (= 0 written) 12 14))))))
monad (array 'write 1 "test_self_out2" (vau (written code) test))
) )
monad monad
;(array 'write 1 "test_self_out2" (vau (written code) 14))
) )
; end of all lets ; end of all lets
))))))) )))))))
) )
; impl of let1 ; impl of let1
; this would be the macro style version (((;)) (vau de (s v b) (eval (array (array wrap (array vau (array s) b)) v) de))) ; this would be the macro style version (((;)) (vau de (s v b) (eval (array (array wrap (array vau (array s) b)) v) de)))
)) (vau de (s v b) (eval (array (array vau (array s) b) (eval v de)) de))) )) (vau de (s v b) (eval (array (array vau (array s) b) (eval v de)) de)))
; impl of quote ; impl of quote
)) (vau (x5) x5)) )) (vau (x5) x5))