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
This commit is contained in:
Nathan Braswell
127
partial_eval.csc
127
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 <body2> <eval_env>)
|
||||
(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))
|
||||
)
|
||||
|
||||
|
||||
@@ -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))
|
||||
|
||||
|
||||
|
||||
|
||||
Reference in New Issue
Block a user