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

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

Browse Source
This commit is contained in:
Nathan Braswell
2022-02-15 23:16:27 -05:00
parent fd37fa9b00
commit dd2191f75d
2 changed files with 115 additions and 48 deletions
Download Patch File Download Diff File Expand all files Collapse all files

141
partial_eval.csc
View File

@@ -464,6 +464,8 @@
((prim_comb? x) (cond ( (= (.prim_comb_sym x) 'vau) true) ((prim_comb? x) (cond ( (= (.prim_comb_sym x) 'vau) true)
((and (= (.prim_comb_sym x) 'eval) (= 1 l)) true) ((and (= (.prim_comb_sym x) 'eval) (= 1 l)) true)
((and (= (.prim_comb_sym x) 'veval) (= 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 ( (= (.prim_comb_sym x) 'cond) true) ; but not vcond
(true false))) (true false)))
((and (marked_array? x) (not (.marked_array_is_val x))) true) ((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))) (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))))) ) (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 (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 ( (array 'vau (marked_prim_comb (lambda (only_head de env_stack pectx params indent) (dlet (
(mde? (mif (= 3 (len params)) (idx params 0) nil)) (mde? (mif (= 3 (len params)) (idx params 0) nil))
(vau_mde? (mif (= nil mde?) (array) (array mde?))) (vau_mde? (mif (= nil mde?) (array) (array mde?)))
@@ -749,49 +788,15 @@
)) 'vau 0 true)) )) 'vau 0 true))
(array 'wrap (marked_prim_comb (dlambda (only_head de env_stack pectx (evaled) indent) (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)) (if (comb? evaled) (array pectx nil (with_wrap_level evaled (+ (.any_comb_wrap_level evaled) 1)))
(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)) (array pectx "bad passed to wrap" nil))
) 'wrap 1 true)) ) 'wrap 1 true))
(array 'unwrap (marked_prim_comb (dlambda (only_head de env_stack pectx (evaled) indent) (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)) (if (comb? evaled) (array pectx nil (with_wrap_level evaled (- (.any_comb_wrap_level evaled) 1)))
(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)) (array pectx "bad passed to unwrap" nil))
) 'unwrap 1 true)) ) '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) (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) (mif (!= 0 (% (len params) 2)) (array pectx (str "partial eval cond with odd params " params) nil)
(dlet ( (dlet (
@@ -2717,6 +2722,68 @@
drop_p_d 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 ;true_val #b000111001
;false_val #b00001100) ;false_val #b00001100)
(empty_parse_value #b00101100) (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)) ((= '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)) ((= '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)) ((= '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)) ((= '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"))))) (true (error (str "Can't compile prim comb " (.prim_comb_sym c) " right now")))))

18
to_compile.kp
View File

@@ -3,8 +3,6 @@
(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 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))))))
@@ -25,12 +23,12 @@
; now maybe errors on can't find helper? ; now maybe errors on can't find helper?
(let (helper (rec-lambda recurse (f4 l4 n4 i4) (let (helper (rec-lambda recurse (f4 l4 n4 i4)
(cond (= i4 (len l4)) n4 (cond (= i4 (len l4)) n4
;(<= i (- (len l) 4)) (recurse f l (concat n (array (<= i4 (- (len l4) 4)) (recurse f4 l4 (concat n4 (array
; (f (idx l (+ i 0))) (f4 (idx l4 (+ i4 0)))
; (f (idx l (+ i 1))) (f4 (idx l4 (+ i4 1)))
; (f (idx l (+ i 2))) (f4 (idx l4 (+ i4 2)))
; (f (idx l (+ i 3))) (f4 (idx l4 (+ i4 3)))
; )) (+ i 4)) )) (+ i4 4))
true (recurse f4 l4 (concat n4 (array (f4 (idx l4 i4)))) (+ i4 1))))) true (recurse f4 l4 (concat n4 (array (f4 (idx l4 i4)))) (+ i4 1)))))
(helper f5 l5 (array) 0))) (helper f5 l5 (array) 0)))
test (map (lambda (x) (+ x 1)) (array 1 2)) test (map (lambda (x) (+ x 1)) (array 1 2))
@@ -42,13 +40,13 @@
;old 4 ;old 4
;test (+ old 4) ;test (+ old 4)
;test 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 monad
) )
;(array 'write 1 "test_self_out2" (vau (written code) 7)) ;(array 'write 1 "test_self_out2" (vau (written code) 7))
; end of all lets ; end of all lets
)))))))) ))))))
; impl of let1 ; impl of let1
; this would be the macro style version ((( ; 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 wrap (array vau (array s) b)) v) de)))