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

Add inlining of cond, which sould be the only non-wrapped vau left in normal programs currently. Started implementation of = to test cond (just ptr equality for now) and it works!

Browse Source
This commit is contained in:
Nathan Braswell
2021-12-30 17:23:15 -05:00
parent 7b7bccb5dd
commit ad38628915
1 changed files with 167 additions and 114 deletions
Download Patch File Download Diff File Expand all files Collapse all files

163
partial_eval.csc
View File

@@ -505,24 +505,24 @@
(pe_body (partial_eval_helper body inner_env (cons inner_env env_stack) (+ 1 indent))) (pe_body (partial_eval_helper body inner_env (cons inner_env env_stack) (+ 1 indent)))
(_ (print_strip (indent_str indent) "in vau, result of evaluating body was " pe_body)) (_ (print_strip (indent_str indent) "in vau, result of evaluating body was " pe_body))
) (marked_comb 0 de? de variadic vau_params pe_body) ) (marked_comb 0 de? de variadic vau_params pe_body)
)) 'vau_fake_real)) )) 'vau))
(array 'wrap (marked_prim_comb (parameters_evaled_proxy 0 (dlambda (recurse de env_stack (evaled) indent) (array 'wrap (marked_prim_comb (parameters_evaled_proxy 0 (dlambda (recurse de env_stack (evaled) indent)
(mif (comb? evaled) (dlet (((wrap_level de? se variadic params body) (.comb evaled)) (mif (comb? evaled) (dlet (((wrap_level de? se variadic params body) (.comb evaled))
(wrapped_marked_fun (marked_comb (+ 1 wrap_level) de? se variadic params body)) (wrapped_marked_fun (marked_comb (+ 1 wrap_level) de? se variadic params body))
) wrapped_marked_fun) ) wrapped_marked_fun)
(marked_array false (array (marked_prim_comb recurse 'wrap_fake_real) evaled)))) (marked_array false (array (marked_prim_comb recurse 'wrap) evaled))))
) 'wrap_fake_real)) ) 'wrap))
(array 'unwrap (marked_prim_comb (parameters_evaled_proxy 0 (dlambda (recurse de env_stack (evaled) indent) (array 'unwrap (marked_prim_comb (parameters_evaled_proxy 0 (dlambda (recurse de env_stack (evaled) indent)
(mif (comb? evaled) (dlet (((wrap_level de? se variadic params body) (.comb evaled)) (mif (comb? evaled) (dlet (((wrap_level de? se variadic params body) (.comb evaled))
(unwrapped_marked_fun (marked_comb (- wrap_level 1) de? se variadic params body)) (unwrapped_marked_fun (marked_comb (- wrap_level 1) de? se variadic params body))
) unwrapped_marked_fun) ) unwrapped_marked_fun)
(marked_array false (array (marked_prim_comb recurse 'unwrap_fake_real) evaled)))) (marked_array false (array (marked_prim_comb recurse 'unwrap) evaled))))
) 'unwrap_fake_real)) ) 'unwrap))
(array 'eval (marked_prim_comb (rec-lambda recurse (de env_stack params indent) (dlet ( (array 'eval (marked_prim_comb (rec-lambda recurse (de env_stack params indent) (dlet (
(self (marked_prim_comb recurse 'eval_fake_real)) (self (marked_prim_comb recurse 'eval))
(eval_env (mif (= 2 (len params)) (partial_eval_helper (idx params 1) de env_stack (+ 1 indent)) (eval_env (mif (= 2 (len params)) (partial_eval_helper (idx params 1) de env_stack (+ 1 indent))
de)) de))
(eval_env_v (mif (= 2 (len params)) (array eval_env) (array))) (eval_env_v (mif (= 2 (len params)) (array eval_env) (array)))
@@ -540,7 +540,7 @@
(body2 (mif (= self_fallback unval_body) self_fallback (partial_eval_helper unval_body eval_env env_stack (+ 1 indent)))) (body2 (mif (= self_fallback unval_body) self_fallback (partial_eval_helper unval_body eval_env env_stack (+ 1 indent))))
(_ (print_strip (indent_str indent) "and body2 is " body2)) (_ (print_strip (indent_str indent) "and body2 is " body2))
) body2)) ) body2))
)) 'eval_fake_real)) )) 'eval))
(array 'cond (marked_prim_comb (rec-lambda recurse (de env_stack params indent) (array 'cond (marked_prim_comb (rec-lambda recurse (de env_stack params indent)
(mif (!= 0 (% (len params) 2)) (error (str "partial eval cond with odd params " params)) (mif (!= 0 (% (len params) 2)) (error (str "partial eval cond with odd params " params))
@@ -550,13 +550,13 @@
(cond ((later? evaled_cond) (recurse_inner (+ 2 i) (concat so_far (array evaled_cond (cond ((later? evaled_cond) (recurse_inner (+ 2 i) (concat so_far (array evaled_cond
(partial_eval_helper (idx params (+ i 1)) de env_stack (+ 1 indent)))))) (partial_eval_helper (idx params (+ i 1)) de env_stack (+ 1 indent))))))
((false? evaled_cond) (recurse_inner (+ 2 i) so_far)) ((false? evaled_cond) (recurse_inner (+ 2 i) so_far))
((= (len params) i) (marked_array false (cons (marked_prim_comb recurse 'cond_fake_real) so_far))) ((= (len params) i) (marked_array false (cons (marked_prim_comb recurse 'cond) so_far)))
(true (let ((evaled_body (partial_eval_helper (idx params (+ 1 i)) de env_stack (+ 1 indent)))) (true (let ((evaled_body (partial_eval_helper (idx params (+ 1 i)) de env_stack (+ 1 indent))))
(mif (!= (len so_far) 0) (marked_array false (cons (marked_prim_comb recurse 'cond_fake_real) (concat so_far (array evaled_cond evaled_body)))) (mif (!= (len so_far) 0) (marked_array false (cons (marked_prim_comb recurse 'cond) (concat so_far (array evaled_cond evaled_body))))
evaled_body))) evaled_body)))
))) 0 (array)) ))) 0 (array))
) )
) 'cond_fake_real)) ) 'cond))
(needs_params_val_lambda symbol?) (needs_params_val_lambda symbol?)
(needs_params_val_lambda int?) (needs_params_val_lambda int?)
@@ -565,16 +565,16 @@
(array 'combiner? (marked_prim_comb (parameters_evaled_proxy nil (dlambda (recurse de env_stack (evaled_param) indent) (array 'combiner? (marked_prim_comb (parameters_evaled_proxy nil (dlambda (recurse de env_stack (evaled_param) indent)
(cond ((comb? evaled_param) (marked_val true)) (cond ((comb? evaled_param) (marked_val true))
((prim_comb? evaled_param) (marked_val true)) ((prim_comb? evaled_param) (marked_val true))
((later? evaled_param) (marked_array false (array (marked_prim_comb recurse 'combinerp_fake_real) evaled_param))) ((later? evaled_param) (marked_array false (array (marked_prim_comb recurse 'combinerp) evaled_param)))
(true (marked_val false)) (true (marked_val false))
) )
)) 'combinerp_fake_real)) )) 'combinerp))
(array 'env? (marked_prim_comb (parameters_evaled_proxy nil (dlambda (recurse de env_stack (evaled_param) indent) (array 'env? (marked_prim_comb (parameters_evaled_proxy nil (dlambda (recurse de env_stack (evaled_param) indent)
(cond ((marked_env? evaled_param) (marked_val true)) (cond ((marked_env? evaled_param) (marked_val true))
((later? evaled_param) (marked_array false (array (marked_prim_comb recurse 'envp_fake_real) evaled_param))) ((later? evaled_param) (marked_array false (array (marked_prim_comb recurse 'envp) evaled_param)))
(true (marked_val false)) (true (marked_val false))
) )
)) 'envp_fake_real)) )) 'envp))
(needs_params_val_lambda nil?) (needs_params_val_lambda nil?)
(needs_params_val_lambda bool?) (needs_params_val_lambda bool?)
(needs_params_val_lambda str-to-symbol) (needs_params_val_lambda str-to-symbol)
@@ -582,43 +582,43 @@
(array 'array? (marked_prim_comb (parameters_evaled_proxy nil (dlambda (recurse de env_stack (evaled_param) indent) (array 'array? (marked_prim_comb (parameters_evaled_proxy nil (dlambda (recurse de env_stack (evaled_param) indent)
(cond (cond
((later? evaled_param) (marked_array false (array (marked_prim_comb recurse 'arrayp_fake_real) evaled_param))) ((later? evaled_param) (marked_array false (array (marked_prim_comb recurse 'arrayp) evaled_param)))
((marked_array? evaled_param) (marked_val true)) ((marked_array? evaled_param) (marked_val true))
(true (marked_val false)) (true (marked_val false))
) )
)) 'arrayp_fake_real)) )) 'arrayp))
; This one's sad, might need to come back to it. ; This one's sad, might need to come back to it.
; We need to be able to differentiate between half-and-half arrays ; We need to be able to differentiate between half-and-half arrays
; for when we ensure_params_values or whatever, because that's super wrong ; for when we ensure_params_values or whatever, because that's super wrong
(array 'array (marked_prim_comb (parameters_evaled_proxy nil (lambda (recurse de env_stack evaled_params indent) (array 'array (marked_prim_comb (parameters_evaled_proxy nil (lambda (recurse de env_stack evaled_params indent)
(mif (is_all_values evaled_params) (marked_array true evaled_params) (mif (is_all_values evaled_params) (marked_array true evaled_params)
(marked_array false (cons (marked_prim_comb recurse 'array_fake_real) evaled_params))) (marked_array false (cons (marked_prim_comb recurse 'array) evaled_params)))
)) 'array_fake_real)) )) 'array))
(array 'len (marked_prim_comb (parameters_evaled_proxy nil (dlambda (recurse de env_stack (evaled_param) indent) (array 'len (marked_prim_comb (parameters_evaled_proxy nil (dlambda (recurse de env_stack (evaled_param) indent)
(cond ((later? evaled_param) (marked_array false (array (marked_prim_comb recurse 'len_fake_real) evaled_param))) (cond ((later? evaled_param) (marked_array false (array (marked_prim_comb recurse 'len) evaled_param)))
((marked_array? evaled_param) (marked_val (len (.marked_array_values evaled_param)))) ((marked_array? evaled_param) (marked_val (len (.marked_array_values evaled_param))))
(true (error (str "bad type to len " evaled_param))) (true (error (str "bad type to len " evaled_param)))
) )
)) 'len_fake_real)) )) 'len))
(array 'idx (marked_prim_comb (parameters_evaled_proxy nil (dlambda (recurse de env_stack (evaled_array evaled_idx) indent) (array 'idx (marked_prim_comb (parameters_evaled_proxy nil (dlambda (recurse de env_stack (evaled_array evaled_idx) indent)
(cond ((and (val? evaled_idx) (marked_array? evaled_array) (.marked_array_is_val evaled_array)) (idx (.marked_array_values evaled_array) (.val evaled_idx))) (cond ((and (val? evaled_idx) (marked_array? evaled_array) (.marked_array_is_val evaled_array)) (idx (.marked_array_values evaled_array) (.val evaled_idx)))
(true (marked_array false (array (marked_prim_comb recurse 'idx_fake_real) evaled_array evaled_idx))) (true (marked_array false (array (marked_prim_comb recurse 'idx) evaled_array evaled_idx)))
) )
)) 'idx_fake_real)) )) 'idx))
(array 'slice (marked_prim_comb (parameters_evaled_proxy nil (dlambda (recurse de env_stack (evaled_array evaled_begin evaled_end) indent) (array 'slice (marked_prim_comb (parameters_evaled_proxy nil (dlambda (recurse de env_stack (evaled_array evaled_begin evaled_end) indent)
(cond ((and (val? evaled_begin) (val? evaled_end) (marked_array? evaled_array) (.marked_array_is_val evaled_array)) (cond ((and (val? evaled_begin) (val? evaled_end) (marked_array? evaled_array) (.marked_array_is_val evaled_array))
(marked_array true (slice (.marked_array_values evaled_array) (.val evaled_begin) (.val evaled_end)))) (marked_array true (slice (.marked_array_values evaled_array) (.val evaled_begin) (.val evaled_end))))
(true (marked_array false (array (marked_prim_comb recurse 'slice_fake_real) evaled_array evaled_idx evaled_begin evaled_end))) (true (marked_array false (array (marked_prim_comb recurse 'slice) evaled_array evaled_idx evaled_begin evaled_end)))
) )
)) 'slice_fake_real)) )) 'slice))
(array 'concat (marked_prim_comb (parameters_evaled_proxy nil (lambda (recurse de env_stack evaled_params indent) (array 'concat (marked_prim_comb (parameters_evaled_proxy nil (lambda (recurse de env_stack evaled_params indent)
(cond ((foldl (lambda (a x) (and a (and (marked_array? x) (.marked_array_is_val x)))) true evaled_params) (marked_array true (lapply concat (map (lambda (x) (cond ((foldl (lambda (a x) (and a (and (marked_array? x) (.marked_array_is_val x)))) true evaled_params) (marked_array true (lapply concat (map (lambda (x)
(.marked_array_values x)) (.marked_array_values x))
evaled_params)))) evaled_params))))
(true (marked_array false (cons (marked_prim_comb recurse 'concat_fake_real) evaled_params))) (true (marked_array false (cons (marked_prim_comb recurse 'concat) evaled_params)))
) )
)) 'concat_fake_real)) )) 'concat))
(needs_params_val_lambda +) (needs_params_val_lambda +)
(needs_params_val_lambda -) (needs_params_val_lambda -)
@@ -641,20 +641,20 @@
(array 'and (marked_prim_comb (parameters_evaled_proxy nil (lambda (recurse de env_stack evaled_params indent) (array 'and (marked_prim_comb (parameters_evaled_proxy nil (lambda (recurse de env_stack evaled_params indent)
((rec-lambda inner_recurse (i) ((rec-lambda inner_recurse (i)
(cond ((= i (- (len evaled_params) 1)) (idx evaled_params i)) (cond ((= i (- (len evaled_params) 1)) (idx evaled_params i))
((later? (idx evaled_params i)) (marked_array false (cons (marked_prim_comb recurse 'and_fake_real) (slice evaled_params i -1)))) ((later? (idx evaled_params i)) (marked_array false (cons (marked_prim_comb recurse 'and) (slice evaled_params i -1))))
((false? (idx evaled_params i)) (idx evaled_params i)) ((false? (idx evaled_params i)) (idx evaled_params i))
(true (inner_recurse (+ 1 i)))) (true (inner_recurse (+ 1 i))))
) 0) ) 0)
)) 'and_fake_real)) )) 'and))
; see above for improvement ; see above for improvement
(array 'or (marked_prim_comb (parameters_evaled_proxy nil (lambda (recurse de env_stack evaled_params indent) (array 'or (marked_prim_comb (parameters_evaled_proxy nil (lambda (recurse de env_stack evaled_params indent)
((rec-lambda inner_recurse (i) ((rec-lambda inner_recurse (i)
(cond ((= i (- (len evaled_params) 1)) (idx evaled_params i)) (cond ((= i (- (len evaled_params) 1)) (idx evaled_params i))
((later? (idx evaled_params i)) (marked_array false (cons (marked_prim_comb recurse 'or_fake_real) (slice evaled_params i -1)))) ((later? (idx evaled_params i)) (marked_array false (cons (marked_prim_comb recurse 'or) (slice evaled_params i -1))))
((false? (idx evaled_params i)) (recurse (+ 1 i))) ((false? (idx evaled_params i)) (recurse (+ 1 i)))
(true (idx evaled_params i))) (true (idx evaled_params i)))
) 0) ) 0)
)) 'or_fake_real)) )) 'or))
; should make not a built in and then do here ; should make not a built in and then do here
; OR not - I think it will actually lower correctly partially evaled ; OR not - I think it will actually lower correctly partially evaled
@@ -1230,6 +1230,7 @@
; True / False ; True / False
; 0..0 111001 / 0..0 011001 ; 0..0 111001 / 0..0 011001
(nil_array_value #b0101) (nil_array_value #b0101)
(to_hex_digit (lambda (x) (string (integer->char (if (< x 10) (+ x #x30) (to_hex_digit (lambda (x) (string (integer->char (if (< x 10) (+ x #x30)
(+ x #x37)))))) (+ x #x37))))))
@@ -1248,6 +1249,8 @@
(memory '$mem 1) (memory '$mem 1)
(global '$malloc_head '(mut i32) (i32.const 0)) (global '$malloc_head '(mut i32) (i32.const 0))
(dlet ( (dlet (
(true_val #b00111101)
(false_val #b00011101)
(alloc_data (dlambda (d (watermark datas)) (cond ((str? d) (let ((size (+ 8 (& (len d) -8)))) (alloc_data (dlambda (d (watermark datas)) (cond ((str? d) (let ((size (+ 8 (& (len d) -8))))
(array (+ watermark 8) (array (+ watermark 8)
(len d) (len d)
@@ -1265,6 +1268,8 @@
((false_loc false_length datasi) (alloc_data "false" datasi)) ((false_loc false_length datasi) (alloc_data "false" datasi))
((bad_params_loc bad_params_length datasi) (alloc_data "\nError: passed a bad number of parameters\n" datasi)) ((bad_params_loc bad_params_length datasi) (alloc_data "\nError: passed a bad number of parameters\n" datasi))
(bad_params_msg_val (bor (<< bad_params_length 32) bad_params_loc #b011)) (bad_params_msg_val (bor (<< bad_params_length 32) bad_params_loc #b011))
((remaining_vau_loc remaining_vau_length datasi) (alloc_data "\nError: trying to call a remainin vau\n" datasi))
(remaining_vau_msg_val (bor (<< remaining_vau_length 32) remaining_vau_loc #b011))
; 0 is fd_read, 1 is fd_write ; 0 is fd_read, 1 is fd_write
((func_idx funcs) (array 2 (array))) ((func_idx funcs) (array 2 (array)))
@@ -1773,6 +1778,16 @@
; static env is 0 by construction ; static env is 0 by construction
)))) ))))
(ensure_2_params_set_ptr (concat (_if '$is_2_params
(i64.ne (i64.shr_u (local.get '$p) (i64.const 32)) (i64.const 2))
(then
(call '$print (i64.const bad_params_msg_val))
(unreachable)
)
)
(local.set '$ptr (i32.wrap_i64 (i64.and (local.get '$p) (i64.const -8))))
))
((k_vau func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$vau '(param $p i64) '(param $d i64) '(param $s i64) '(result i64) (unreachable))))) ((k_vau func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$vau '(param $p i64) '(param $d i64) '(param $s i64) '(result i64) (unreachable)))))
((k_read-string func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$read-string '(param $p i64) '(param $d i64) '(param $s i64) '(result i64) (unreachable))))) ((k_read-string func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$read-string '(param $p i64) '(param $d i64) '(param $s i64) '(result i64) (unreachable)))))
((k_log func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$log '(param $p i64) '(param $d i64) '(param $s i64) '(result i64) (unreachable))))) ((k_log func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$log '(param $p i64) '(param $d i64) '(param $s i64) '(result i64) (unreachable)))))
@@ -1785,7 +1800,15 @@
((k_leq func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$leq '(param $p i64) '(param $d i64) '(param $s i64) '(result i64) (unreachable))))) ((k_leq func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$leq '(param $p i64) '(param $d i64) '(param $s i64) '(result i64) (unreachable)))))
((k_lt func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$lt '(param $p i64) '(param $d i64) '(param $s i64) '(result i64) (unreachable))))) ((k_lt func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$lt '(param $p i64) '(param $d i64) '(param $s i64) '(result i64) (unreachable)))))
((k_neq func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$neq '(param $p i64) '(param $d i64) '(param $s i64) '(result i64) (unreachable))))) ((k_neq func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$neq '(param $p i64) '(param $d i64) '(param $s i64) '(result i64) (unreachable)))))
((k_eq func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$eq '(param $p i64) '(param $d i64) '(param $s i64) '(result i64) (unreachable))))) ((k_eq func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$eq '(param $p i64) '(param $d i64) '(param $s i64) '(result i64) '(local $ptr i32)
ensure_2_params_set_ptr
(_if '$eq '(result i64)
; TODO: BAD BAD BAD this is ptr equality
(i64.eq (i64.load 0 (local.get '$ptr)) (i64.load 8 (local.get '$ptr)))
(then (i64.const true_val))
(else (i64.const false_val))
)
))))
((k_mod func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$mod '(param $p i64) '(param $d i64) '(param $s i64) '(result i64) (unreachable))))) ((k_mod func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$mod '(param $p i64) '(param $d i64) '(param $s i64) '(result i64) (unreachable)))))
((k_div func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$div '(param $p i64) '(param $d i64) '(param $s i64) '(result i64) (unreachable))))) ((k_div func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$div '(param $p i64) '(param $d i64) '(param $s i64) '(result i64) (unreachable)))))
((k_mul func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$mul '(param $p i64) '(param $d i64) '(param $s i64) '(result i64) (unreachable))))) ((k_mul func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$mul '(param $p i64) '(param $d i64) '(param $s i64) '(result i64) (unreachable)))))
@@ -1824,8 +1847,8 @@
(compile_value (rec-lambda recurse-value (datasi funcs memo c) (cond (compile_value (rec-lambda recurse-value (datasi funcs memo c) (cond
((val? c) (let ((v (.val c))) ((val? c) (let ((v (.val c)))
(cond ((int? v) (array (<< v 1) datasi funcs memo)) (cond ((int? v) (array (<< v 1) datasi funcs memo))
((= true v) (array #b00111101 datasi funcs memo)) ((= true v) (array true_val datasi funcs memo))
((= false v) (array #b00011101 datasi funcs memo)) ((= false v) (array false_val datasi funcs memo))
((str? v) (dlet (((c_loc c_len datasi) (alloc_data v datasi)) ((str? v) (dlet (((c_loc c_len datasi) (alloc_data v datasi))
(a (bor (<< c_len 32) c_loc #b011)) (a (bor (<< c_len 32) c_loc #b011))
) (array a datasi funcs memo))) ) (array a datasi funcs memo)))
@@ -1865,11 +1888,11 @@
(result (bor (<< c_loc 5) #b01001)) (result (bor (<< c_loc 5) #b01001))
(memo (put memo (.hash c) result)) (memo (put memo (.hash c) result))
) (array result datasi funcs memo)))) ) (array result datasi funcs memo))))
((prim_comb? c) (cond ((= 'vau_fake_real (.prim_comb_sym c)) (array (bor (<< (- k_vau k_len) 35) (<< 0 4) #b0001) datasi funcs memo)) ((prim_comb? c) (cond ((= 'vau (.prim_comb_sym c)) (array (bor (<< (- k_vau k_len) 35) (<< 0 4) #b0001) datasi funcs memo))
((= 'cond_fake_real (.prim_comb_sym c)) (array (bor (<< (- k_cond k_len) 35) (<< 0 4) #b0001) datasi funcs memo)) ((= 'cond (.prim_comb_sym c)) (array (bor (<< (- k_cond k_len) 35) (<< 0 4) #b0001) datasi funcs memo))
((= 'or_fake_real (.prim_comb_sym c)) (array (bor (<< (- k_or k_len) 35) (<< 0 4) #b0001) datasi funcs memo)) ((= 'or (.prim_comb_sym c)) (array (bor (<< (- k_or k_len) 35) (<< 0 4) #b0001) datasi funcs memo))
((= 'and_fake_real (.prim_comb_sym c)) (array (bor (<< (- k_and k_len) 35) (<< 0 4) #b0001) datasi funcs memo)) ((= 'and (.prim_comb_sym c)) (array (bor (<< (- k_and k_len) 35) (<< 0 4) #b0001) datasi funcs memo))
((= 'len_fake_real (.prim_comb_sym c)) (array (bor (<< (- k_len k_len) 35) (<< 1 4) #b0001) datasi funcs memo)) ((= 'len (.prim_comb_sym c)) (array (bor (<< (- k_len k_len) 35) (<< 1 4) #b0001) datasi funcs memo))
((= 'read-string (.prim_comb_sym c)) (array (bor (<< (- k_read-string k_len) 35) (<< 1 4) #b0001) datasi funcs memo)) ((= 'read-string (.prim_comb_sym c)) (array (bor (<< (- k_read-string k_len) 35) (<< 1 4) #b0001) datasi funcs memo))
((= 'log (.prim_comb_sym c)) (array (bor (<< (- k_log k_len) 35) (<< 1 4) #b0001) datasi funcs memo)) ((= 'log (.prim_comb_sym c)) (array (bor (<< (- k_log k_len) 35) (<< 1 4) #b0001) datasi funcs memo))
((= 'error (.prim_comb_sym c)) (array (bor (<< (- k_error k_len) 35) (<< 1 4) #b0001) datasi funcs memo)) ((= 'error (.prim_comb_sym c)) (array (bor (<< (- k_error k_len) 35) (<< 1 4) #b0001) datasi funcs memo))
@@ -1889,23 +1912,23 @@
((= 'bor (.prim_comb_sym c)) (array (bor (<< (- k_bor k_len) 35) (<< 1 4) #b0001) datasi funcs memo)) ((= 'bor (.prim_comb_sym c)) (array (bor (<< (- k_bor k_len) 35) (<< 1 4) #b0001) datasi funcs memo))
((= '<< (.prim_comb_sym c)) (array (bor (<< (- k_ls k_len) 35) (<< 1 4) #b0001) datasi funcs memo)) ((= '<< (.prim_comb_sym c)) (array (bor (<< (- k_ls k_len) 35) (<< 1 4) #b0001) datasi funcs memo))
((= '>> (.prim_comb_sym c)) (array (bor (<< (- k_rs k_len) 35) (<< 1 4) #b0001) datasi funcs memo)) ((= '>> (.prim_comb_sym c)) (array (bor (<< (- k_rs k_len) 35) (<< 1 4) #b0001) datasi funcs memo))
((= 'concat_fake_real (.prim_comb_sym c)) (array (bor (<< (- k_concat k_len) 35) (<< 1 4) #b0001) datasi funcs memo)) ((= 'concat (.prim_comb_sym c)) (array (bor (<< (- k_concat k_len) 35) (<< 1 4) #b0001) datasi funcs memo))
((= 'slice_fake_real (.prim_comb_sym c)) (array (bor (<< (- k_slice k_len) 35) (<< 1 4) #b0001) datasi funcs memo)) ((= 'slice (.prim_comb_sym c)) (array (bor (<< (- k_slice k_len) 35) (<< 1 4) #b0001) datasi funcs memo))
((= 'idx_fake_real (.prim_comb_sym c)) (array (bor (<< (- k_idx k_len) 35) (<< 1 4) #b0001) datasi funcs memo)) ((= 'idx (.prim_comb_sym c)) (array (bor (<< (- k_idx k_len) 35) (<< 1 4) #b0001) datasi funcs memo))
((= 'array_fake_real (.prim_comb_sym c)) (array (bor (<< (- k_array k_len) 35) (<< 1 4) #b0001) datasi funcs memo)) ((= 'array (.prim_comb_sym c)) (array (bor (<< (- k_array k_len) 35) (<< 1 4) #b0001) datasi funcs memo))
((= 'arrayp_fake_real (.prim_comb_sym c)) (array (bor (<< (- k_arrayp k_len) 35) (<< 1 4) #b0001) datasi funcs memo)) ((= 'arrayp (.prim_comb_sym c)) (array (bor (<< (- k_arrayp k_len) 35) (<< 1 4) #b0001) datasi funcs memo))
((= 'get-text (.prim_comb_sym c)) (array (bor (<< (- k_get-text k_len) 35) (<< 1 4) #b0001) datasi funcs memo)) ((= 'get-text (.prim_comb_sym c)) (array (bor (<< (- k_get-text k_len) 35) (<< 1 4) #b0001) datasi funcs memo))
((= 'str-to-symbol (.prim_comb_sym c)) (array (bor (<< (- k_str-to-symbol k_len) 35) (<< 1 4) #b0001) datasi funcs memo)) ((= 'str-to-symbol (.prim_comb_sym c)) (array (bor (<< (- k_str-to-symbol k_len) 35) (<< 1 4) #b0001) datasi funcs memo))
((= 'bool? (.prim_comb_sym c)) (array (bor (<< (- k_bool? k_len) 35) (<< 1 4) #b0001) datasi funcs memo)) ((= 'bool? (.prim_comb_sym c)) (array (bor (<< (- k_bool? k_len) 35) (<< 1 4) #b0001) datasi funcs memo))
((= 'nil? (.prim_comb_sym c)) (array (bor (<< (- k_nil? k_len) 35) (<< 1 4) #b0001) datasi funcs memo)) ((= 'nil? (.prim_comb_sym c)) (array (bor (<< (- k_nil? k_len) 35) (<< 1 4) #b0001) datasi funcs memo))
((= 'envp_fake_real (.prim_comb_sym c)) (array (bor (<< (- k_env? k_len) 35) (<< 1 4) #b0001) datasi funcs memo)) ((= 'envp (.prim_comb_sym c)) (array (bor (<< (- k_env? k_len) 35) (<< 1 4) #b0001) datasi funcs memo))
((= 'combinerp_fake_real (.prim_comb_sym c)) (array (bor (<< (- k_combiner? k_len) 35) (<< 1 4) #b0001) datasi funcs memo)) ((= 'combinerp (.prim_comb_sym c)) (array (bor (<< (- k_combiner? k_len) 35) (<< 1 4) #b0001) datasi funcs memo))
((= 'string? (.prim_comb_sym c)) (array (bor (<< (- k_string? k_len) 35) (<< 1 4) #b0001) datasi funcs memo)) ((= 'string? (.prim_comb_sym c)) (array (bor (<< (- k_string? k_len) 35) (<< 1 4) #b0001) datasi funcs memo))
((= 'int? (.prim_comb_sym c)) (array (bor (<< (- k_int? k_len) 35) (<< 1 4) #b0001) datasi funcs memo)) ((= 'int? (.prim_comb_sym c)) (array (bor (<< (- k_int? k_len) 35) (<< 1 4) #b0001) datasi funcs memo))
((= 'symbol? (.prim_comb_sym c)) (array (bor (<< (- k_symbol? k_len) 35) (<< 1 4) #b0001) datasi funcs memo)) ((= 'symbol? (.prim_comb_sym c)) (array (bor (<< (- k_symbol? k_len) 35) (<< 1 4) #b0001) datasi funcs memo))
((= 'eval_fake_real (.prim_comb_sym c)) (array (bor (<< (- k_eval k_len) 35) (<< 1 4) #b0001) datasi funcs memo)) ((= 'eval (.prim_comb_sym c)) (array (bor (<< (- k_eval k_len) 35) (<< 1 4) #b0001) datasi funcs memo))
((= 'unwrap_fake_real (.prim_comb_sym c)) (array (bor (<< (- k_unwrap k_len) 35) (<< 1 4) #b0001) datasi funcs memo)) ((= 'unwrap (.prim_comb_sym c)) (array (bor (<< (- k_unwrap k_len) 35) (<< 1 4) #b0001) datasi funcs memo))
((= 'wrap_fake_real (.prim_comb_sym c)) (array (bor (<< (- k_wrap k_len) 35) (<< 1 4) #b0001) datasi funcs memo)) ((= 'wrap (.prim_comb_sym c)) (array (bor (<< (- k_wrap k_len) 35) (<< 1 4) #b0001) datasi funcs memo))
(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")))))
((comb? c) (or (get_passthrough (.hash c) datasi funcs memo) (dlet ( ((comb? c) (or (get_passthrough (.hash c) datasi funcs memo) (dlet (
((wrap_level de? se variadic params body) (.comb c)) ((wrap_level de? se variadic params body) (.comb c))
@@ -1945,11 +1968,37 @@
(dlet ( (dlet (
(func_param_values (.marked_array_values c)) (func_param_values (.marked_array_values c))
(num_params (- (len func_param_values) 1)) (num_params (- (len func_param_values) 1))
((func_code datasi funcs memo) (recurse-code datasi funcs memo env (idx func_param_values 0))) ((param_codes datasi funcs memo) (foldr (dlambda (x (a datasi funcs memo))
((param_code datasi funcs memo) (foldr (dlambda (x (a datasi funcs memo))
(dlet (((code datasi funcs memo) (recurse-code datasi funcs memo env x))) (dlet (((code datasi funcs memo) (recurse-code datasi funcs memo env x)))
(array (concat code a) datasi funcs memo))) (array (cons code a) datasi funcs memo)))
(array (array) datasi funcs memo) (slice func_param_values 1 -1))) (array (array) datasi funcs memo) (slice func_param_values 1 -1)))
;; Insert test for the function being a constant to inline
;; Namely, cond
(func_value (idx func_param_values 0))
) (cond
((and (prim_comb? func_value) (= (.prim_comb_sym func_value) 'cond)) (array
((rec-lambda recurse (codes i) (cond
((< i (- (len codes) 1)) (_if '_cond_flat '(result i64)
(i64.ne (i64.const #b01)
; This and is 1111100011
; The end ensuring 01 makes only
; array comb env and bool apply
; catching only 0array and false
; and a comb with func idx 0
; and null env. If we prevent
; this from happening, it's
; exactly what we want
(i64.and (i64.const -29)
(idx codes i)))
(then (idx codes (+ i 1)))
(else (recurse codes (+ i 2)))
))
((= i (- (len codes) 1)) (error "compiling bad length comb"))
(true (unreachable))
)) param_codes 0)
datasi funcs memo))
(true (dlet (
((func_code datasi funcs memo) (recurse-code datasi funcs memo env func_value))
(result_code (concat (result_code (concat
func_code func_code
(local.set '$tmp) (local.set '$tmp)
@@ -1957,7 +2006,7 @@
(i64.eq (i64.const #x10) (i64.and (local.get '$tmp) (i64.const #x30))) (i64.eq (i64.const #x10) (i64.and (local.get '$tmp) (i64.const #x30)))
(then (then
(local.get '$tmp) ; saving ito restore it (local.get '$tmp) ; saving ito restore it
param_code (apply concat param_codes)
(local.set '$param_ptr (call '$malloc (i32.const (* 8 num_params)))) (local.set '$param_ptr (call '$malloc (i32.const (* 8 num_params))))
(flat_map (lambda (i) (i64.store (* i 8) (local.set '$tmp) (local.get '$param_ptr) (local.get '$tmp))) (flat_map (lambda (i) (i64.store (* i 8) (local.set '$tmp) (local.get '$param_ptr) (local.get '$tmp)))
(range (- num_params 1) -1)) (range (- num_params 1) -1))
@@ -1965,6 +2014,7 @@
) )
(else (else
; TODO: Handle other wrap levels ; TODO: Handle other wrap levels
(call '$print (i64.const remaining_vau_msg_val))
(unreachable) (unreachable)
) )
) )
@@ -1983,8 +2033,9 @@
(i64.const 2)) (i64.const #b01001)) (i64.const 2)) (i64.const #b01001))
;func_idx ;func_idx
(i32.wrap_i64 (i64.shr_u (local.get '$tmp) (i64.const 35))) (i32.wrap_i64 (i64.shr_u (local.get '$tmp) (i64.const 35)))
) )))
))) (array result_code datasi funcs memo)))) ) (array result_code datasi funcs memo)))
))))
((prim_comb? c) (map_val (recurse-value datasi funcs memo c) (lambda (v) (i64.const v)))) ((prim_comb? c) (map_val (recurse-value datasi funcs memo c) (lambda (v) (i64.const v))))
((comb? c) (map_val (recurse-value datasi funcs memo c) (lambda (v) (i64.or (i64.const v) ((comb? c) (map_val (recurse-value datasi funcs memo c) (lambda (v) (i64.or (i64.const v)
(i64.and (i64.const #x7FFFFFFC0) (i64.shr_u (call '$dup (local.get '$s_env)) (i64.and (i64.const #x7FFFFFFC0) (i64.shr_u (call '$dup (local.get '$s_env))
@@ -2463,12 +2514,14 @@
;(output3 (compile (partial_eval (read-string "(array ((vau (x) x) write) 1 \"waa\" (vau (written code) code))")))) ;(output3 (compile (partial_eval (read-string "(array ((vau (x) x) write) 1 \"waa\" (vau (written code) code))"))))
;(output3 (compile (partial_eval (read-string "(array ((vau (x) x) write) 1 \"waa\" (vau (written code) (array 1337 written 1338 code 1339)))")))) ;(output3 (compile (partial_eval (read-string "(array ((vau (x) x) write) 1 \"waa\" (vau (written code) (array 1337 written 1338 code 1339)))"))))
(output3 (compile (partial_eval (read-string "(array ((vau (x) x) write) 1 \"waa\" (vau (written code) (cond (= 0 code) written true code)))"))))
;(output3 (compile (partial_eval (read-string "(array ((vau (x) x) write) 1 \"waa\" (vau (& args) args))")))) ;(output3 (compile (partial_eval (read-string "(array ((vau (x) x) write) 1 \"waa\" (vau (& args) args))"))))
;(output3 (compile (partial_eval (read-string "(array ((vau (x) x) write) 1 \"waa\" (vau (a & args) a))")))) ;(output3 (compile (partial_eval (read-string "(array ((vau (x) x) write) 1 \"waa\" (vau (a & args) a))"))))
;(output3 (compile (partial_eval (read-string "(array ((vau (x) x) write) 1 \"waa\" (vau (a & args) args))")))) ;(output3 (compile (partial_eval (read-string "(array ((vau (x) x) write) 1 \"waa\" (vau (a & args) args))"))))
;(output3 (compile (partial_eval (read-string "(array ((vau (x) x) read) 0 10 (vau (data code) data))")))) ;(output3 (compile (partial_eval (read-string "(array ((vau (x) x) read) 0 10 (vau (data code) data))"))))
(output3 (compile (partial_eval (read-string "(array ((vau (x) x) read) 0 10 (vau (data code) (array ((vau (x) x) write) 1 data (vau (written code) (array written code)))))")))) ;(output3 (compile (partial_eval (read-string "(array ((vau (x) x) read) 0 10 (vau (data code) (array ((vau (x) x) write) 1 data (vau (written code) (array written code)))))"))))
;(output3 (compile (partial_eval (read-string "(wrap (vau (x) x))")))) ;(output3 (compile (partial_eval (read-string "(wrap (vau (x) x))"))))
;(output3 (compile (partial_eval (read-string "len")))) ;(output3 (compile (partial_eval (read-string "len"))))