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

Implemented wasm eval and fixed slice

Browse Source
This commit is contained in:
Nathan Braswell
2022-03-13 22:56:04 -04:00
parent 1b220023bc
commit 31ee20be7b
1 changed files with 195 additions and 45 deletions
Download Patch File Download Diff File Expand all files Collapse all files

240
partial_eval.scm
View File

@@ -1727,6 +1727,9 @@
((remaining_eval_loc remaining_eval_length datasi) (alloc_data "\nError: trying to call remainin eval\n" datasi)) ((remaining_eval_loc remaining_eval_length datasi) (alloc_data "\nError: trying to call remainin eval\n" datasi))
(remaining_eval_msg_val (bor (<< remaining_eval_length 32) remaining_eval_loc #b011)) (remaining_eval_msg_val (bor (<< remaining_eval_length 32) remaining_eval_loc #b011))
((hit_upper_in_eval_loc hit_upper_in_eval_length datasi) (alloc_data "\nError: hit nil upper env when looking up symbol in remaining eval: " datasi))
(hit_upper_in_eval_msg_val (bor (<< hit_upper_in_eval_length 32) hit_upper_in_eval_loc #b011))
((remaining_vau_loc remaining_vau_length datasi) (alloc_data "\nError: trying to call remainin vau (primitive)\n" datasi)) ((remaining_vau_loc remaining_vau_length datasi) (alloc_data "\nError: trying to call remainin vau (primitive)\n" datasi))
(remaining_vau_msg_val (bor (<< remaining_vau_length 32) remaining_vau_loc #b011)) (remaining_vau_msg_val (bor (<< remaining_vau_length 32) remaining_vau_loc #b011))
@@ -2286,45 +2289,45 @@
(_if '$new_size_0 '(result i64) (_if '$new_size_0 '(result i64)
(i32.eqz (local.get '$new_size)) (i32.eqz (local.get '$new_size))
(then (then
(typecheck 0 (array '(result i64)) (call '$drop (local.get '$array))
i64.eq type_array (_if '$is_array '(result i64)
(array (then (i64.const nil_val))) (i64.eq (i64.const #b101) (i64.and (i64.const #b111) (local.get '$array)))
(array (else (i64.const emptystr_val))) (then (i64.const nil_val))
) (else (i64.const emptystr_val)))
) )
(else (else
(typecheck 0 (array '(result i64)) (_if '$is_array '(result i64)
i64.eq type_array (i64.eq (i64.const #b101) (i64.and (i64.const #b111) (local.get '$array)))
(array (then (then
(local.set '$new_ptr (call '$malloc (i32.shl (local.get '$new_size) (i32.const 3)))) ; malloc(size*8) (local.set '$new_ptr (call '$malloc (i32.shl (local.get '$new_size) (i32.const 3)))) ; malloc(size*8)
(local.set '$i (i32.const 0)) (local.set '$i (i32.const 0))
(block '$exit_loop (block '$exit_loop
(_loop '$l (_loop '$l
(br_if '$exit_loop (i32.eq (local.get '$i) (local.get '$new_size))) (br_if '$exit_loop (i32.eq (local.get '$i) (local.get '$new_size)))
(i64.store (i32.add (i32.shl (local.get '$i) (i32.const 3)) (local.get '$new_ptr)) (i64.store (i32.add (i32.shl (local.get '$i) (i32.const 3)) (local.get '$new_ptr))
(call '$dup (i64.load (i32.add (i32.shl (i32.add (local.get '$s) (local.get '$i)) (i32.const 3)) (call '$dup (i64.load (i32.add (i32.shl (i32.add (local.get '$s) (local.get '$i)) (i32.const 3))
(local.get '$ptr))))) ; n[i] = dup(o[i+s]) (local.get '$ptr))))) ; n[i] = dup(o[i+s])
(local.set '$i (i32.add (i32.const 1) (local.get '$i))) (local.set '$i (i32.add (i32.const 1) (local.get '$i)))
(br '$l) (br '$l)
) )
) )
(call '$drop (local.get '$array)) (call '$drop (local.get '$array))
(i64.or (i64.or (i64.extend_i32_u (local.get '$new_ptr)) (i64.const #b101)) (i64.or (i64.or (i64.extend_i32_u (local.get '$new_ptr)) (i64.const #b101))
(i64.shl (i64.extend_i32_u (local.get '$new_size)) (i64.const 32))) (i64.shl (i64.extend_i32_u (local.get '$new_size)) (i64.const 32)))
)) )
(array (else (else
(local.set '$new_ptr (call '$malloc (local.get '$new_size))) ; malloc(size) (local.set '$new_ptr (call '$malloc (local.get '$new_size))) ; malloc(size)
(memory.copy (local.get '$new_ptr) (memory.copy (local.get '$new_ptr)
(i32.add (local.get '$ptr) (local.get '$s)) (i32.add (local.get '$ptr) (local.get '$s))
(local.get '$new_size)) (local.get '$new_size))
(call '$drop (local.get '$array)) (call '$drop (local.get '$array))
(i64.or (i64.or (i64.extend_i32_u (local.get '$new_ptr)) (i64.const #b011)) (i64.or (i64.or (i64.extend_i32_u (local.get '$new_ptr)) (i64.const #b011))
(i64.shl (i64.extend_i32_u (local.get '$new_size)) (i64.const 32))) (i64.shl (i64.extend_i32_u (local.get '$new_size)) (i64.const 32)))
)) )
) )
) )
) )
@@ -3134,7 +3137,7 @@
(_loop '$l (_loop '$l
(br_if '$b2 (i32.eqz (global.get '$phl))) (br_if '$b2 (i32.eqz (global.get '$phl)))
(local.set '$tmp (i32.load8_u (global.get '$phs))) (local.set '$tmp (i32.load8_u (global.get '$phs)))
(call '$print (i64.shl (i64.extend_i32_u (local.get '$tmp)) (i64.const 1))) ;(call '$print (i64.shl (i64.extend_i32_u (local.get '$tmp)) (i64.const 1)))
(_if '$whitespace (i32.or (i32.or (i32.eq (i32.const #x9) (local.get '$tmp)) ; tab (_if '$whitespace (i32.or (i32.or (i32.eq (i32.const #x9) (local.get '$tmp)) ; tab
(i32.eq (i32.const #xA) (local.get '$tmp))) ; newline (i32.eq (i32.const #xA) (local.get '$tmp))) ; newline
(i32.or (i32.eq (i32.const #xD) (local.get '$tmp)) ; carrige return (i32.or (i32.eq (i32.const #xD) (local.get '$tmp)) ; carrige return
@@ -3528,7 +3531,7 @@
(ensure_not_op_n_params_set_ptr_len i32.ne 1) (ensure_not_op_n_params_set_ptr_len i32.ne 1)
(type_assert 0 type_string k_read_msg_val) (type_assert 0 type_string k_read_msg_val)
(local.set '$str (i64.load (local.get '$ptr))) (local.set '$str (i64.load (local.get '$ptr)))
(call '$print (local.get '$str)) ;(call '$print (local.get '$str))
(global.set '$phl (i32.wrap_i64 (i64.shr_u (local.get '$str) (i64.const 32)))) (global.set '$phl (i32.wrap_i64 (i64.shr_u (local.get '$str) (i64.const 32))))
(global.set '$phs (i32.wrap_i64 (i64.and (local.get '$str) (i64.const #xFFFFFFF8)))) (global.set '$phs (i32.wrap_i64 (i64.and (local.get '$str) (i64.const #xFFFFFFF8))))
(local.set '$result (call '$parse_helper)) (local.set '$result (call '$parse_helper))
@@ -3564,12 +3567,150 @@
(local.get '$result) (local.get '$result)
drop_p_d drop_p_d
)))) ))))
; Helper method, doesn't refcount consume parameters
; but does properly refcount internally / dup returns
((k_eval_helper func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$eval_helper '(param $it i64) '(param $env i64) '(result i64) '(local $len i32) '(local $ptr i32) '(local $current_env i64) '(local $res i64) '(local $env_ptr i32) '(local $i i32) '(local $comb i64) '(local $params i64) '(local $wrap i32)
; The cool thing about Vau calculus / Kernel / Kraken
; is that everything is a value that evaluates to itself except symbols
; and arrays.
(_if '$is_value '(result i64)
(i64.ne (i64.const #b101) (i64.and (i64.const #b101) (local.get '$it)))
(then
; it's a value, we can just return it!
(call '$dup (local.get '$it))
)
(else
(_if '$is_symbol '(result i64)
(i64.eq (i64.const #b111) (i64.and (i64.const #b111) (local.get '$it)))
(then
; look it up in the environment
; 0..0<env_ptr32 but still aligned>01001
; Env object is <key_array_value><value_array_value><upper_env_value>
; each being the full 64 bit objects.
(local.set '$current_env (local.get '$env))
(block '$outer_loop_break
(_loop '$outer_loop
(local.set '$env_ptr (i32.wrap_i64 (i64.shr_u (local.get '$current_env) (i64.const 5))))
(local.set '$len (i32.wrap_i64 (i64.shr_u (i64.load 0 (local.get '$env_ptr)) (i64.const 32))))
(local.set '$ptr (i32.wrap_i64 (i64.and (i64.load 0 (local.get '$env_ptr)) (i64.const -8))))
(local.set '$i (i32.const 0))
(block '$inner_loop_break
(_loop '$inner_loop
(br_if '$inner_loop_break (i32.eqz (local.get '$len)))
(_if '$found_it
; We should intern symbols so we can do this
;(i64.eq (local.get '$it) (i64.load (local.get '$ptr)))
(i64.eq (i64.const 1)
(call '$str_sym_comp (local.get '$it) (i64.load (local.get '$ptr)) (i64.const 0) (i64.const 1) (i64.const 0)))
(then
(local.set '$res (i64.load (i32.add (i32.wrap_i64 (i64.and (i64.load 8 (local.get '$env_ptr)) (i64.const -8)))
(i32.shl (local.get '$i) (i32.const 3)))))
(br '$outer_loop_break)
)
)
(local.set '$len (i32.sub (local.get '$len) (i32.const 1)))
(local.set '$ptr (i32.add (local.get '$ptr) (i32.const 8)))
(local.set '$i (i32.add (local.get '$i) (i32.const 1)))
(br '$inner_loop)
)
)
; try in upper
(local.set '$current_env (i64.load 16 (local.get '$env_ptr)))
(br_if '$outer_loop (i64.ne (i64.const nil_val) (local.get '$current_env)))
)
; Ended at upper case
(call '$print (i64.const hit_upper_in_eval_msg_val))
(call '$print (local.get '$it))
(call '$print (i64.const newline_msg_val))
(unreachable)
)
(call '$dup (local.get '$res))
)
(else
; <array_size32><array_ptr29>101 / 0..0 101
(local.set '$len (i32.wrap_i64 (i64.shr_u (local.get '$it) (i64.const 32))))
(local.set '$ptr (i32.wrap_i64 (i64.and (local.get '$it) (i64.const -8))))
(_if '$zero_length
(i32.eqz (local.get '$len))
(then (unreachable)))
; its a call, evaluate combiner first then
(local.set '$comb (call '$eval_helper (i64.load 0 (local.get '$ptr)) (local.get '$env)))
; check to make sure it's a combiner <func_idx29>|<env_ptr29><wrap2>0001
(_if '$isnt_function
(i64.ne (i64.const #b0001) (i64.and (i64.const #b1111) (local.get '$comb)))
(then (unreachable))
)
(local.set '$wrap (i32.wrap_i64 (i64.and (i64.const #b11) (i64.shr_u (local.get '$comb) (i64.const 4)))))
(local.set '$params (call '$slice_impl (call '$dup (local.get '$it)) (i32.const 1) (local.get '$len)))
; we'll reuse len and ptr now for params
(local.set '$len (i32.wrap_i64 (i64.shr_u (local.get '$params) (i64.const 32))))
(local.set '$ptr (i32.wrap_i64 (i64.and (local.get '$params) (i64.const -8))))
; then evaluate parameters wrap times
(block '$wrap_loop_break
(_loop '$wrap_loop
(br_if '$wrap_loop_break (i32.eqz (local.get '$wrap)))
(local.set '$i (i32.const 0))
(block '$inner_eval_loop_break
(_loop '$inner_eval_loop
(br_if '$inner_eval_loop_break (i32.eq (local.get '$len) (local.get '$i)))
(i64.store (i32.add (local.get '$ptr) (i32.shl (local.get '$i) (i32.const 3)))
(call '$eval_helper (i64.load (i32.add (local.get '$ptr) (i32.shl (local.get '$i) (i32.const 3))))
(local.get '$env)))
(local.set '$i (i32.add (local.get '$i) (i32.const 1)))
(br '$inner_eval_loop)
)
)
(local.set '$wrap (i32.sub (local.get '$wrap) (i32.const 1)))
(br '$wrap_loop)
)
)
(call_indirect
;type
k_wrap
;table
0
;params
(local.get '$params)
; dynamic env
(call '$dup (local.get '$env))
; static env
(i64.or (i64.shl (i64.and (call '$dup (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)))
)
; Also, this really should tail-call when we support it
)
)
)
)
))))
((k_eval_loc k_eval_length datasi) (alloc_data "k_eval" datasi)) ((k_eval_loc k_eval_length datasi) (alloc_data "k_eval" datasi))
(k_eval_msg_val (bor (<< k_eval_length 32) k_eval_loc #b011)) (k_eval_msg_val (bor (<< k_eval_length 32) k_eval_loc #b011))
((k_eval func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$eval '(param $p i64) '(param $d i64) '(param $s i64) '(result i64) ((k_eval func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$eval '(param $p i64) '(param $d i64) '(param $s i64) '(result i64) '(local $len i32) '(local $ptr i32)
(call '$print (i64.const remaining_eval_msg_val)) (ensure_not_op_n_params_set_ptr_len i32.lt_u 1)
(unreachable) (_if '$using_d_env '(result i64)
(i32.eq (i32.const 1) (local.get '$len))
(then
(call '$eval_helper (i64.load 0 (local.get '$ptr)) (local.get '$d))
)
(else
(type_assert 1 type_env k_eval_msg_val)
(call '$eval_helper (i64.load 0 (local.get '$ptr)) (i64.load 8 (local.get '$ptr)))
)
)
drop_p_d
)))) ))))
((k_vau_loc k_vau_length datasi) (alloc_data "k_vau" datasi)) ((k_vau_loc k_vau_length datasi) (alloc_data "k_vau" datasi))
(k_vau_msg_val (bor (<< k_vau_length 32) k_vau_loc #b011)) (k_vau_msg_val (bor (<< k_vau_length 32) k_vau_loc #b011))
@@ -4413,6 +4554,11 @@
))))) (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)))"))
(print (run_partial_eval_test "(len \"asdf\")"))
(print (run_partial_eval_test "(idx \"asdf\" 1)"))
(print (run_partial_eval_test "(slice \"asdf\" 1 3)"))
(print (run_partial_eval_test "(concat \"asdf\" \";lkj\")"))
(print "ok, hex of 0 is " (hex_digit #\0)) (print "ok, hex of 0 is " (hex_digit #\0))
(print "ok, hex of 1 is " (hex_digit #\1)) (print "ok, hex of 1 is " (hex_digit #\1))
@@ -4636,11 +4782,6 @@
; )) (vau (x5) x5))")))) ; )) (vau (x5) x5))"))))
;(_ (write_file "./csc_out.wasm" output3)) ;(_ (write_file "./csc_out.wasm" output3))
(print (run_partial_eval_test "(len \"asdf\")"))
(print (run_partial_eval_test "(idx \"asdf\" 1)"))
(print (run_partial_eval_test "(slice \"asdf\" 1 3)"))
(print (run_partial_eval_test "(concat \"asdf\" \";lkj\")"))
;(_ (write_file "./csc_out.wasm" (compile (partial_eval (read-string ;(_ (write_file "./csc_out.wasm" (compile (partial_eval (read-string
; "(array ((vau (x5) x5) write) 1 \"written\" (vau (written code) (len (cond (= 0 written) \"asdf\" true \"sdf\"))))"))))) ; "(array ((vau (x5) x5) write) 1 \"written\" (vau (written code) (len (cond (= 0 written) \"asdf\" true \"sdf\"))))")))))
@@ -4650,9 +4791,18 @@
;(_ (write_file "./csc_out.wasm" (compile (partial_eval (read-string ;(_ (write_file "./csc_out.wasm" (compile (partial_eval (read-string
; "(array ((vau (x5) x5) write) 1 \"written\" (vau (written code) (slice (cond (= 0 written) \"asdf\" true \"abcdefghi\") 1 3)))"))))) ; "(array ((vau (x5) x5) write) 1 \"written\" (vau (written code) (slice (cond (= 0 written) \"asdf\" true \"abcdefghi\") 1 3)))")))))
(_ (write_file "./csc_out.wasm" (compile (partial_eval (read-string ;(_ (write_file "./csc_out.wasm" (compile (partial_eval (read-string
"(array ((vau (x5) x5) write) 1 \"written\" (vau (written code) (concat \"hehe\" (cond (= 0 written) \"asdf\" true \"abcdefghi\"))))"))))) ; "(array ((vau (x5) x5) write) 1 \"written\" (vau (written code) (concat \"hehe\" (cond (= 0 written) \"asdf\" true \"abcdefghi\"))))")))))
(_ (write_file "./csc_out.wasm" (compile (partial_eval (read-string
"(array ((vau (x) x) write) 1 \"enter form: \" (vau (written code)
(array ((vau (x) x) read) 0 20 (vau (data code)
(array ((vau (x) x) exit) (eval (read-string data)))
))
))")))))
(output3 (compile (partial_eval (read-string "(array ((vau (x) x) read) 0 10 (vau (data code) data))"))))
) void))) ) void)))