diff --git a/partial_eval.csc b/partial_eval.csc index ceb7a97..70c9de4 100644 --- a/partial_eval.csc +++ b/partial_eval.csc @@ -448,7 +448,8 @@ ((and (= (.prim_comb_sym x) 'eval) (= 1 l)) true) ((and (= (.prim_comb_sym x) 'veval) (= 1 l)) true) (true false))) - ((and (marked_array? x) (not (.marked_array_is_val x))) true) + ((and (marked_array? x) (not (.marked_array_is_val x))) true) + ((and (marked_symbol? x) (not (.marked_symbol_is_val x))) true) (true (error (str "illegal comb_takes_de? param " x))) ))) @@ -495,6 +496,30 @@ ) )) + (drop_redundent_veval (rec-lambda drop_redundent_veval (env_id x) (dlet ((r (if + (and (marked_array? x) + (not (.marked_array_is_val x)) + (prim_comb? (idx (.marked_array_values x) 0)) + (= 'veval (.prim_comb_sym (idx (.marked_array_values x) 0))) + (= 3 (len (.marked_array_values x))) + (not (marked_env_real? (idx (.marked_array_values x) 2))) + (= env_id (.marked_env_idx (idx (.marked_array_values x) 2)))) (drop_redundent_veval env_id (idx (.marked_array_values x) 1)) + x))) + ;(begin (print_strip "result of drop_redundent_veval (with " env_id ") (problem was " + ; (cond + ; ((not (marked_array? x)) "(marked_array? x)") + ; ((not (not (.marked_array_is_val x))) "(not (.marked_array_is_val x))") + ; ((not (prim_comb? (idx (.marked_array_values x) 0))) "(prim_comb? (idx (.marked_array_values x) 0))") + ; ((not (= 'veval (.prim_comb_sym (idx (.marked_array_values x) 0)))) "(= 'veval (.prim_comb_sym (idx (.marked_array_values x) 0)))") + ; ((not (= 3 (len (.marked_array_values x)))) "(= 3 (len (.marked_array_values x)))") + ; ((not (not (marked_env_real? (idx (.marked_array_values x) 2)))) "(not (marked_env_real? (idx (.marked_array_values x) 2)))") + ; ((not (= env_id (.marked_env_idx (idx (.marked_array_values x) 2)))) "(= env_id (.marked_env_idx (idx (.marked_array_values x) 2)))") + ; (true "no problem!") + ; ) ") " + ; r) r) + r + ))) + ; 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 ; compiling, and I think make partial-eval more efficient. More accurate closes_over analysis too, I think @@ -564,11 +589,14 @@ (_ (println (indent_str indent) "Going to do an array call!")) ;(_ (true_print (indent_str indent) "Going to do an array call!")) (indent (+ 1 indent)) - (_ (print_strip (indent_str indent) "total is " x)) + (_ (print_strip (indent_str indent) "total (in env " (.marked_env_idx env) ") is (proceeding err " err ") " x)) + ; would need to handle err if we want it(_ (print_strip (indent_str indent) "total (in env " (.marked_env_idx env) ") is (proceeding err " err ") " (str_strip x) ", that is " (marked_array false true (cons comb literal_params)))) ;(_ (true_print (indent_str indent) "total is " (true_str_strip x))) ) (mif err (array pectx err nil) - (cond ((prim_comb? comb) ((.prim_comb comb) only_head env env_stack pectx literal_params (+ 1 indent))) + (cond ((prim_comb? comb) (begin (if (= 'wrap (.prim_comb_sym comb)) (print_strip (indent_str indent) "calling wrap in " x)) + ((.prim_comb comb) only_head env env_stack pectx literal_params (+ 1 indent)) + )) ((comb? comb) (dlet ( (map_rp_eval (lambda (pectx ps) (foldl (dlambda ((c er ds) p) (dlet ((_ (print_strip (indent_str indent) "rp_evaling " p)) ((c e d) (partial_eval_helper p false env env_stack c (+ 1 indent))) (_ (print_strip (indent_str indent) "result of rp_eval was err " e " and value " d))) (array c (mif er er e) (concat ds (array d))))) @@ -642,12 +670,12 @@ ;((pectx func_err func_result) (partial_eval_helper body only_head inner_env (cons inner_env env_stack) pectx (+ 1 indent))) + (_ (print_strip (indent_str indent) "evaled result of function call (in env " (.marked_env_idx env) ", with inner " env_id ") and err " func_err " is " func_result)) ) (mif func_err (array pectx func_err nil) (dlet ( - (_ (print_strip (indent_str indent) "evaled result of function call is " func_result)) ;(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")) - ((not (combiner_return_ok func_result env_id)) (array true "combiner return not ok")) + ((not (combiner_return_ok func_result env_id)) (array true (str "combiner return not ok (was looking for env_id " env_id ")"))) (true (array false "wooo")) )) @@ -657,7 +685,7 @@ ; just by re-wrapping it in a comb instead mif we wanted. ; Something to think about! (result (mif failed (marked_array false true (cons comb correct_fail_params)) - func_result)) + (drop_redundent_veval (.marked_env_idx env) func_result))) ) (array pectx nil result)))))))) ((later_head? comb) (array pectx nil (marked_array false true (cons comb literal_params)))) (true (array pectx (str "impossible comb value " x) nil)))))))) @@ -666,7 +694,7 @@ ; otherwise, we can't make progress yet (begin (print_strip (indent_str indent) "Not evaluating " x) ;(print (indent_str indent) "comparing to env stack " env_stack) - (array pectx nil x)))) + (array pectx nil (drop_redundent_veval (.marked_env_idx env) x))))) )) ; !!!!!! @@ -737,10 +765,11 @@ )) 'vau)) (array 'wrap (marked_prim_comb (parameters_evaled_proxy 0 (dlambda (recurse only_head de env_stack pectx (evaled) indent) + (begin (print_strip (indent_str indent) "calling wrap with " evaled) (array pectx nil (mif (comb? evaled) (dlet (((wrap_level env_id de? se variadic params body) (.comb evaled)) (wrapped_marked_fun (marked_comb (+ 1 wrap_level) env_id de? se variadic params body)) ) wrapped_marked_fun) - (marked_array false true (array (marked_prim_comb recurse 'wrap) evaled))))) + (marked_array false true (array (marked_prim_comb recurse 'wrap) evaled)))))) ) 'wrap)) (array 'unwrap (marked_prim_comb (parameters_evaled_proxy 0 (dlambda (recurse only_head de env_stack pectx (evaled) indent) @@ -764,12 +793,17 @@ (body (idx params 0)) (implicit_env (!= 2 (len params))) (eval_env (if implicit_env de (idx params 1))) - ((pectx err ebody) (partial_eval_helper body only_head eval_env env_stack pectx (+ 1 indent))) - ) (cond ((!= nil err) (array pectx err nil)) + ((pectx err eval_env) (if implicit_env (array pectx nil de) + (partial_eval_helper (idx params 1) only_head de env_stack pectx (+ 1 indent)))) + ((pectx err ebody) (if (or (!= nil err) (not (marked_env? eval_env))) + (array pectx err body) + (partial_eval_helper body only_head eval_env env_stack pectx (+ 1 indent)))) + ) (cond + ((!= nil err) (begin (print (indent_str indent) "got err " 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 ebody)) - ((combiner_return_ok ebody (.marked_env_idx eval_env)) (array pectx nil ebody)) - (true (array pectx nil (marked_array false true (array (marked_prim_comb recurse 'veval) ebody eval_env)))) + (implicit_env (array pectx nil (drop_redundent_veval (.marked_env_idx de) ebody))) + ((combiner_return_ok ebody (.marked_env_idx eval_env)) (array pectx nil (drop_redundent_veval (.marked_env_idx de) ebody))) + (true (array pectx nil (drop_redundent_veval (.marked_env_idx de) (marked_array false true (array (marked_prim_comb recurse 'veval) ebody eval_env))))) )))) ) (venv_inner only_head de env_stack pectx (if implicit_env (array unval_body) (array unval_body eval_env)) indent)))) @@ -3868,6 +3902,21 @@ (lambda (n) ((lambda (x n) (x x n)) (lambda (recurse n) (cond (!= 0 n) (* n (recurse recurse (- n 1))) true 1 )) n)) ))) (vau de (s v b) (eval (array (array vau (array s) b) (eval v de)) de)))")) + + (print "\n\nlambda recursion Y combiner test\n\n") + (print (run_partial_eval_test "((wrap (vau (let1) + (let1 lambda (vau se (p b) (wrap (eval (array vau p b) se))) + (let1 lapply (lambda (f1 p) (eval (concat (array (unwrap f1)) p))) + (let1 Y (lambda (f3) + ((lambda (x1) (x1 x1)) + (lambda (x2) (f3 (lambda (& y) (lapply (x2 x2) y)))))) + ((Y (lambda (recurse) (lambda (n) (cond (!= 0 n) (* n (recurse (- n 1))) + true 1)))) + 5) + ))))) (vau de (s v b) (eval (array (array vau (array s) b) (eval v de)) de)))")) + + + (print "ok, hex of 0 is " (hex_digit #\0)) (print "ok, hex of 1 is " (hex_digit #\1)) (print "ok, hex of a is " (hex_digit #\a)) diff --git a/to_compile.kp b/to_compile.kp index 2ac5628..68e550d 100644 --- a/to_compile.kp +++ b/to_compile.kp @@ -13,43 +13,42 @@ (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))))) - 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)) + (let ( + ;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)) - ; 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)) - ;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 -) + 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)) + ;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)))))) + ;old 4 + ;test (+ old 4) + ;test 4 + monad (array 'write 1 "test_self_out2" (vau (written code) test)) + ) + monad + ) + ;(array 'write 1 "test_self_out2" (vau (written code) 7)) ; 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)))