From dd2191f75d6c67cb69e3f05d0c80d4065da4e25a Mon Sep 17 00:00:00 2001 From: Nathan Braswell Date: Tue, 15 Feb 2022 23:16:27 -0500 Subject: [PATCH] Made vapply and lapply primitives for efficiency/partial eval reasons. It means they can exist in emitted code without calling out to eval, which is good. to_compile.kp now both compiles and runs! Now to add more --- partial_eval.csc | 145 ++++++++++++++++++++++++++++++++++------------- to_compile.kp | 18 +++--- 2 files changed, 115 insertions(+), 48 deletions(-) diff --git a/partial_eval.csc b/partial_eval.csc index 7e02ced..82992de 100644 --- a/partial_eval.csc +++ b/partial_eval.csc @@ -464,6 +464,8 @@ ((prim_comb? x) (cond ( (= (.prim_comb_sym x) 'vau) true) ((and (= (.prim_comb_sym x) 'eval) (= 1 l)) true) ((and (= (.prim_comb_sym x) 'veval) (= 1 l)) true) + ( (= (.prim_comb_sym x) 'lapply) true) + ( (= (.prim_comb_sym x) 'vapply) true) ( (= (.prim_comb_sym x) 'cond) true) ; but not vcond (true false))) ((and (marked_array? x) (not (.marked_array_is_val x))) true) @@ -716,9 +718,46 @@ (handler (lambda (only_head de env_stack pectx params indent) (array pectx 'LATER nil))) ) (array f_sym (marked_prim_comb handler f_sym 1 false))))) + (veval_inner (rec-lambda recurse (only_head de env_stack pectx params indent) (dlet ( + (body (idx params 0)) + (implicit_env (!= 2 (len params))) + (eval_env (if implicit_env de (idx params 1))) + ((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) false))) + ((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) false))) + ) (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 (drop_redundent_veval partial_eval_helper ebody de env_stack pectx indent)) + ((combiner_return_ok ebody (.marked_env_idx eval_env)) (drop_redundent_veval partial_eval_helper ebody de env_stack pectx indent)) + (true (drop_redundent_veval partial_eval_helper (marked_array false true nil (array (marked_prim_comb recurse 'veval -1 true) ebody eval_env)) de env_stack pectx indent)) + )))) (root_marked_env (marked_env true nil nil (array + (array 'eval (marked_prim_comb (rec-lambda recurse (only_head de env_stack pectx evaled_params indent) + (if (not (total_value? (idx evaled_params 0))) (array pectx nil (marked_array false true nil (cons (marked_prim_comb recurse 'eval 0 true) evaled_params))) + (if (and (= 2 (len evaled_params)) (not (marked_env? (idx evaled_params 1)))) (array pectx nil (marked_array false true nil (cons (marked_prim_comb recurse 'eval 0 true) 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"))) + + + ) (veval_inner only_head de env_stack pectx (if implicit_env (array unval_body) (array unval_body eval_env)) indent)))) + ) 'eval 1 true)) + + (array 'vapply (marked_prim_comb (dlambda (only_head de env_stack pectx (f ps ide) indent) + (veval_inner only_head de env_stack pectx (array (marked_array false false nil (cons f (.marked_array_values ps))) ide) (+ 1 indent)) + ) 'vapply 1 true)) + (array 'lapply (marked_prim_comb (dlambda (only_head de env_stack pectx (f ps) indent) + (veval_inner only_head de env_stack pectx (array (marked_array false false nil (cons (with_wrap_level f (- (.any_comb_wrap_level f) 1)) (.marked_array_values ps)))) (+ 1 indent)) + ) 'lapply 1 true)) + (array 'vau (marked_prim_comb (lambda (only_head de env_stack pectx params indent) (dlet ( (mde? (mif (= 3 (len params)) (idx params 0) nil)) (vau_mde? (mif (= nil mde?) (array) (array mde?))) @@ -749,49 +788,15 @@ )) 'vau 0 true)) (array 'wrap (marked_prim_comb (dlambda (only_head de env_stack pectx (evaled) indent) - (mif (comb? evaled) (array pectx nil (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)) - (array pectx "bad passed to wrap" nil)) + (if (comb? evaled) (array pectx nil (with_wrap_level evaled (+ (.any_comb_wrap_level evaled) 1))) + (array pectx "bad passed to wrap" nil)) ) 'wrap 1 true)) (array 'unwrap (marked_prim_comb (dlambda (only_head de env_stack pectx (evaled) indent) - (mif (comb? evaled) (array pectx nil (dlet (((wrap_level env_id de? se variadic params body) (.comb evaled)) - (wrapped_marked_fun (marked_comb (- wrap_level 1) env_id de? se variadic params body)) - ) wrapped_marked_fun)) - (array pectx "bad passed to unwrap" nil)) + (if (comb? evaled) (array pectx nil (with_wrap_level evaled (- (.any_comb_wrap_level evaled) 1))) + (array pectx "bad passed to unwrap" nil)) ) 'unwrap 1 true)) - (array 'eval (marked_prim_comb (rec-lambda recurse (only_head de env_stack pectx evaled_params indent) - (if (not (total_value? (idx evaled_params 0))) (array pectx nil (marked_array false true nil (cons (marked_prim_comb recurse 'eval 0 true) evaled_params))) - (if (and (= 2 (len evaled_params)) (not (marked_env? (idx evaled_params 1)))) (array pectx nil (marked_array false true nil (cons (marked_prim_comb recurse 'eval 0 true) 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"))) - - (veval_inner (rec-lambda recurse (only_head de env_stack pectx params indent) (dlet ( - (body (idx params 0)) - (implicit_env (!= 2 (len params))) - (eval_env (if implicit_env de (idx params 1))) - ((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) false))) - ((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) false))) - ) (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 (drop_redundent_veval partial_eval_helper ebody de env_stack pectx indent)) - ((combiner_return_ok ebody (.marked_env_idx eval_env)) (drop_redundent_veval partial_eval_helper ebody de env_stack pectx indent)) - (true (drop_redundent_veval partial_eval_helper (marked_array false true nil (array (marked_prim_comb recurse 'veval -1 true) ebody eval_env)) de env_stack pectx indent)) - )))) - - ) (veval_inner only_head de env_stack pectx (if implicit_env (array unval_body) (array unval_body eval_env)) indent)))) - ) 'eval 1 true)) - (array 'cond (marked_prim_comb ((rec-lambda recurse (already_stripped) (lambda (only_head de env_stack pectx params indent) (mif (!= 0 (% (len params) 2)) (array pectx (str "partial eval cond with odd params " params) nil) (dlet ( @@ -2717,6 +2722,68 @@ drop_p_d )))) + ((k_lapply func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$lapply '(param $p i64) '(param $d i64) '(param $s i64) '(result i64) '(local $ptr i32) '(local $len i32) '(local $comb i64) '(local $params i64) '(local $wrap_level i64) + (ensure_not_op_n_params_set_ptr_len i32.ne 2) + (type_assert 0 type_combiner) + (type_assert 1 type_array) + (local.set '$comb (call '$dup (i64.load 0 (local.get '$ptr)))) + (local.set '$params (call '$dup (i64.load 8 (local.get '$ptr)))) + (call '$drop (local.get '$d)) + (local.set '$wrap_level (i64.and (i64.shr_u (local.get '$comb) (i64.const 4)) (i64.const #b11))) + (_if '$wrap_level_ne_1 + (i64.ne (i64.const 1) (local.get '$wrap_level)) + (then (unreachable)) + ) + + (call_indirect + ;type + k_wrap + ;table + 0 + ;params + (local.get '$params) + ; pass through d env + (local.get '$d) + ; static env + (i64.or (i64.shl (i64.and (local.get '$comb) (i64.const #x3FFFFFFC0)) + (i64.const 2)) (i64.const #b01001)) + ;func_idx + (i32.wrap_i64 (i64.shr_u (local.get '$comb) (i64.const 35))) + ) + )))) + + ((k_vapply func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$vapply '(param $p i64) '(param $d i64) '(param $s i64) '(result i64) '(local $ptr i32) '(local $len i32) '(local $comb i64) '(local $params i64) '(local $wrap_level i64) '(local $denv i64) + (ensure_not_op_n_params_set_ptr_len i32.ne 3) + (type_assert 0 type_combiner) + (type_assert 1 type_array) + (type_assert 2 type_env) + (local.set '$comb (call '$dup (i64.load 0 (local.get '$ptr)))) + (local.set '$params (call '$dup (i64.load 8 (local.get '$ptr)))) + (local.set '$denv (call '$dup (i64.load 16 (local.get '$ptr)))) + drop_p_d + (local.set '$wrap_level (i64.and (i64.shr_u (local.get '$comb) (i64.const 4)) (i64.const #b11))) + (_if '$wrap_level_ne_0 + (i64.ne (i64.const 0) (local.get '$wrap_level)) + (then (unreachable)) + ) + + (call_indirect + ;type + k_wrap + ;table + 0 + ;params + (local.get '$params) + ; passed in denv, not our $d env + (local.get '$denv) + ; static env + (i64.or (i64.shl (i64.and (local.get '$comb) (i64.const #x3FFFFFFC0)) + (i64.const 2)) (i64.const #b01001)) + ;func_idx + (i32.wrap_i64 (i64.shr_u (local.get '$comb) (i64.const 35))) + ) + )))) + ;true_val #b000111001 ;false_val #b00001100) (empty_parse_value #b00101100) @@ -3456,6 +3523,8 @@ ((= 'int? (.prim_comb_sym c)) (array (bor (<< (- k_int? dyn_start) 35) (<< (.prim_comb_wrap_level c) 4) #b0001) nil nil ctx)) ((= 'symbol? (.prim_comb_sym c)) (array (bor (<< (- k_symbol? dyn_start) 35) (<< (.prim_comb_wrap_level c) 4) #b0001) nil nil ctx)) ((= 'unwrap (.prim_comb_sym c)) (array (bor (<< (- k_unwrap dyn_start) 35) (<< (.prim_comb_wrap_level c) 4) #b0001) nil nil ctx)) + ((= 'vapply (.prim_comb_sym c)) (array (bor (<< (- k_vapply dyn_start) 35) (<< (.prim_comb_wrap_level c) 4) #b0001) nil nil ctx)) + ((= 'lapply (.prim_comb_sym c)) (array (bor (<< (- k_lapply dyn_start) 35) (<< (.prim_comb_wrap_level c) 4) #b0001) nil nil ctx)) ((= 'wrap (.prim_comb_sym c)) (array (bor (<< (- k_wrap dyn_start) 35) (<< (.prim_comb_wrap_level c) 4) #b0001) nil nil ctx)) (true (error (str "Can't compile prim comb " (.prim_comb_sym c) " right now"))))) diff --git a/to_compile.kp b/to_compile.kp index 68e550d..103c410 100644 --- a/to_compile.kp +++ b/to_compile.kp @@ -3,8 +3,6 @@ (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)))))) @@ -25,12 +23,12 @@ ; 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)) + (<= i4 (- (len l4) 4)) (recurse f4 l4 (concat n4 (array + (f4 (idx l4 (+ i4 0))) + (f4 (idx l4 (+ i4 1))) + (f4 (idx l4 (+ i4 2))) + (f4 (idx l4 (+ i4 3))) + )) (+ i4 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)) @@ -42,13 +40,13 @@ ;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) (map (lambda (x) (+ x 133)) (array written code)))) ) 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)))