From a8f8f9df896f87fef314886efd1e17fc1c68cf71 Mon Sep 17 00:00:00 2001 From: Nathan Braswell Date: Thu, 3 Feb 2022 02:41:14 -0500 Subject: [PATCH] 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. 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 --- partial_eval.csc | 127 +++++++++++++++++++++++++++-------------------- to_compile.kp | 65 ++++++++++++------------ 2 files changed, 104 insertions(+), 88 deletions(-) diff --git a/partial_eval.csc b/partial_eval.csc index 008c92c..d33aaca 100644 --- a/partial_eval.csc +++ b/partial_eval.csc @@ -375,8 +375,6 @@ ) ))) (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) (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))) @@ -400,29 +398,9 @@ (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) - ((marked_env? x) (let ((inner (.env_marked x))) - (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)) + ; TODO: memoize! + (check_for_env_id_in_result (rec-lambda check_for_env_id_in_result (s_env_id x) (cond ((val? 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))) @@ -437,7 +415,20 @@ ((!= nil (idx inner -1)) (check_for_env_id_in_result s_env_id (idx inner -1))) (true false)))) (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 ; ['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)) (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) (dlet ( (_ (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 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 (later_head? func_result)) (array false "")) - (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")) + ((not (combiner_return_ok func_result env_id)) (array true "combiner return not ok")) + (true (array false "wooo")) )) (_ (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))))) ) 'unwrap)) - (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 ( - ; 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))))) + (array 'eval (marked_prim_comb (parameters_evaled_proxy 0 (lambda (recurse only_head de env_stack pectx evaled_params indent) + (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))) + (dlet ( + (body (idx evaled_params 0)) + (implicit_env (!= 2 (len evaled_params))) + (eval_env (if implicit_env de (idx evaled_params 1))) + ((ok unval_body) (try_unval body (lambda (_) nil))) + (_ (if (not ok) (error "actually impossible eval unval"))) + ((pectx err body2) (partial_eval_helper unval_body only_head eval_env env_stack pectx (+ 1 indent))) + ) (cond ((!= nil err) (array pectx err nil)) + ; If our env was implicit, then our unval'd code can be inlined directly in our caller + (implicit_env (array pectx nil body2)) + ((combiner_return_ok body2 (.marked_env_idx eval_env)) (array pectx nil body2)) + ; TODO: Could replace this with (veval ) + (true (array pectx nil (marked_array false true (cons (marked_prim_comb recurse 'eval) evaled_params)))) + )))) )) '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) (mif (!= 0 (% (len params) 2)) (array pectx (str "partial eval cond with odd params " params) nil) ((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)) ((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))) + (_ (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 @@ -4033,8 +4052,8 @@ (write_file "./csc_out.wasm" (compile (partial_eval (read-string (slurp "to_compile.kp"))))) )) -;) (test-most)) -) (run-compiler)) +) (test-most)) +;) (run-compiler)) ;) (single-test)) ) diff --git a/to_compile.kp b/to_compile.kp index d26f40d..b14208b 100644 --- a/to_compile.kp +++ b/to_compile.kp @@ -1,60 +1,57 @@ - - ((wrap (vau root_env (quote) ((wrap (vau (let1) - - (let1 lambda (vau se (p b1) (wrap (eval (array vau p b1) se))) (let1 current-env (vau de () de) (let1 cons (lambda (h t) (concat (array h) t)) (let1 lapply (lambda (f1 p) (eval (cons (unwrap f1) p) (current-env))) (let1 vapply (lambda (f2 p ede) (eval (cons f2 p) ede)) - (let1 Y (lambda (f3) ((lambda (x1) (x1 x1)) (lambda (x2) (f3 (lambda (& y) (lapply (x2 x2) y)))))) - (let1 vY (lambda (f) ((lambda (x3) (x3 x3)) - (lambda (x4) (f (vau de (& y) (vapply (x4 x4) y de)))))) -(let1 let (vY (lambda (recurse) (vau de (vs b) (cond (= (len vs) 0) (eval b de) - true (vapply let1 (array (idx vs 0) (idx vs 1) (array recurse (slice vs 2 -1) b)) de))))) - + (lambda (x4) (f (vau de1 (& y) (vapply (x4 x4) y de1)))))) +(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)) de2))))) (let ( - a 1 - lcompose (lambda (g f) (lambda (& args) (lapply g (array (lapply f args))))) + ;a 1 + ;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)) - if (vau de (con than & else) (cond (eval con de) (eval than de) - (> (len else) 0) (eval (idx else 0) de) - true false)) - map (lambda (f l) - (let (helper (rec-lambda recurse (f l n i) - (cond (= i (len l)) n - (<= i (- (len l) 4)) (recurse f l (concat n (array - (f (idx l (+ i 0))) - (f (idx l (+ i 1))) - (f (idx l (+ i 2))) - (f (idx l (+ i 3))) - )) (+ i 4)) - true (recurse f l (concat n (array (f (idx l i)))) (+ i 1))))) - (helper f l (array) 0))) + ;if (vau de (con than & else) (cond (eval con de) (eval than de) + ; (> (len else) 0) (eval (idx else 0) de) + ; true false)) + + ; 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 + ; Although, without that, it now runs 60x longer and then still has the same compiles to call problem. + ; - Is it due to failure to compile cuasing re-attempts in an exponential way? + ; - Nope, contains-symbols has come home to roost + map (lambda (f5 l5) + ; now maybe errors on can't find helper? + (let (helper (rec-lambda recurse (f4 l4 n4 i4) + (cond (= i4 (len l4)) n4 + ;(<= i (- (len l) 4)) (recurse f l (concat n (array + ; (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)) - monad (array 'open 3 "test_self_out" (lambda (fd code) - (array 'write fd "wabcdefghijklmnopqrstuvwx" (lambda (written code) - (array 'exit (if (= 0 written) 12 14)))))) + ;test ((rec-lambda recurse (n) (cond (= 0 n) 1 + ; true (* n (recurse (- n 1))))) 5) + ;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 -;(array 'write 1 "test_self_out2" (vau (written code) 14)) ) ; end of all lets ))))))) ) - ; 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))) )) (vau de (s v b) (eval (array (array vau (array s) b) (eval v de)) de))) ; impl of quote )) (vau (x5) x5)) - - -