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

Add missing funcs, add offset support to wasm load/store, start in on monad impl

Browse Source
This commit is contained in:
Nathan Braswell
2021-12-25 21:01:58 -05:00
parent f376a75f4c
commit 8dadf07759
1 changed files with 125 additions and 75 deletions
Download Patch File Download Diff File Expand all files Collapse all files

200
partial_eval.csc
View File

@@ -99,6 +99,12 @@
(str-to-symbol string->symbol) (str-to-symbol string->symbol)
(get-text symbol->string) (get-text symbol->string)
(bor bitwise-ior)
(& bitwise-and)
(<< arithmetic-shift)
(>> (lambda (a b) (arithmetic-shift a (- b))))
(nil? (lambda (x) (= nil x))) (nil? (lambda (x) (= nil x)))
(bool? (lambda (x) (or (= #t x) (= #f x)))) (bool? (lambda (x) (or (= #t x) (= #f x))))
(println print) (println print)
@@ -615,10 +621,11 @@
(needs_params_val_lambda *) (needs_params_val_lambda *)
(needs_params_val_lambda /) (needs_params_val_lambda /)
(needs_params_val_lambda %) (needs_params_val_lambda %)
;(needs_params_val_lambda &) (needs_params_val_lambda &)
;(needs_params_val_lambda |) ;(needs_params_val_lambda |)
;(needs_params_val_lambda <<) (needs_params_val_lambda bor)
;(needs_params_val_lambda >>) (needs_params_val_lambda <<)
(needs_params_val_lambda >>)
(needs_params_val_lambda =) (needs_params_val_lambda =)
(needs_params_val_lambda !=) (needs_params_val_lambda !=)
(needs_params_val_lambda <) (needs_params_val_lambda <)
@@ -650,17 +657,14 @@
;(needs_params_val_lambda pr-str) ;(needs_params_val_lambda pr-str)
(needs_params_val_lambda str) (needs_params_val_lambda str)
;(needs_params_val_lambda prn) ;(needs_params_val_lambda prn)
(give_up_eval_params println) (give_up_eval_params log)
; really do need to figure out mif we want to keep meta, and add it mif so ; really do need to figure out mif we want to keep meta, and add it mif so
;(give_up_eval_params meta) ;(give_up_eval_params meta)
;(give_up_eval_params with-meta) ;(give_up_eval_params with-meta)
; mif we want to get fancy, we could do error/recover too ; mif we want to get fancy, we could do error/recover too
;(give_up_eval_params error) (give_up_eval_params error)
;(give_up_eval_params recover) ;(give_up_eval_params recover)
(needs_params_val_lambda read-string) (needs_params_val_lambda read-string)
;(give_up_eval_params slurp)
;(give_up_eval_params get_line)
;(give_up_eval_params write_file)
(array 'empty_env (marked_env true nil (array nil))) (array 'empty_env (marked_env true nil (array nil)))
nil nil
@@ -671,20 +675,15 @@
;; WASM ;; WASM
(bor bitwise-ior)
(band bitwise-and)
(<< arithmetic-shift)
(>> (lambda (a b) (arithmetic-shift a (- b))))
; Vectors and Values ; Vectors and Values
; Bytes encode themselves ; Bytes encode themselves
; Note that the shift must be arithmatic ; Note that the shift must be arithmatic
(encode_LEB128 (rec-lambda recurse (x) (encode_LEB128 (rec-lambda recurse (x)
(let ((b (band #x7F x)) (let ((b (& #x7F x))
(v (>> x 7))) (v (>> x 7)))
(cond ((or (and (= v 0) (= (band b #x40) 0)) (and (= v -1) (!= (band b #x40) 0))) (array b)) (cond ((or (and (= v 0) (= (& b #x40) 0)) (and (= v -1) (!= (& b #x40) 0))) (array b))
(true (cons (bor b #x80) (recurse v))))) (true (cons (bor b #x80) (recurse v)))))
)) ))
(encode_vector (lambda (enc v) (encode_vector (lambda (enc v)
@@ -1098,14 +1097,20 @@
(i64.ge_s (lambda flatten (concat (apply concat flatten) (array (lambda (name_dict) (array 'i64.ge_s)))))) (i64.ge_s (lambda flatten (concat (apply concat flatten) (array (lambda (name_dict) (array 'i64.ge_s))))))
(i64.ge_u (lambda flatten (concat (apply concat flatten) (array (lambda (name_dict) (array 'i64.ge_u)))))) (i64.ge_u (lambda flatten (concat (apply concat flatten) (array (lambda (name_dict) (array 'i64.ge_u))))))
(i32.load (lambda flatten (concat (apply concat flatten) (array (lambda (name_dict) (array 'i32.load 2 0)))))) (mem_load (lambda (op align) (lambda flatten (dlet (
(i64.load (lambda flatten (concat (apply concat flatten) (array (lambda (name_dict) (array 'i64.load 3 0)))))) (offset (if (int? (idx flatten 0)) (idx flatten 0) 0))
(i32.store (lambda flatten (concat (apply concat flatten) (array (lambda (name_dict) (array 'i32.store 2 0)))))) (flatten_rest (if (= 0 offset) flatten (slice flatten 1 -1)))
(i64.store (lambda flatten (concat (apply concat flatten) (array (lambda (name_dict) (array 'i64.store 3 0)))))) ) (concat (apply concat flatten_rest) (array (lambda (name_dict) (array op align offset))))))))
(i32.store8 (lambda flatten (concat (apply concat flatten) (array (lambda (name_dict) (array 'i32.store8 0 0))))))
(i32.store16 (lambda flatten (concat (apply concat flatten) (array (lambda (name_dict) (array 'i32.store16 1 0)))))) (i32.load (mem_load 'i32.load 2))
(i64.store8 (lambda flatten (concat (apply concat flatten) (array (lambda (name_dict) (array 'i64.store8 0 0)))))) (i64.load (mem_load 'i64.load 3))
(i64.store16 (lambda flatten (concat (apply concat flatten) (array (lambda (name_dict) (array 'i64.store16 1 0)))))) (i32.store (mem_load 'i32.store 2))
(i64.store (mem_load 'i64.store 3))
(i32.store8 (mem_load 'i32.store8 0))
(i32.store16 (mem_load 'i32.store16 1))
(i64.store8 (mem_load 'i64.store8 0))
(i64.store16 (mem_load 'i64.store16 1))
(memory.grow (lambda flatten (concat (apply concat flatten) (array (lambda (name_dict) (array 'memory.grow)))))) (memory.grow (lambda flatten (concat (apply concat flatten) (array (lambda (name_dict) (array 'memory.grow))))))
(i32.shl (lambda flatten (concat (apply concat flatten) (array (lambda (name_dict) (array 'i32.shl)))))) (i32.shl (lambda flatten (concat (apply concat flatten) (array (lambda (name_dict) (array 'i32.shl))))))
(i32.shr_u (lambda flatten (concat (apply concat flatten) (array (lambda (name_dict) (array 'i32.shr_u)))))) (i32.shr_u (lambda flatten (concat (apply concat flatten) (array (lambda (name_dict) (array 'i32.shr_u))))))
@@ -1232,7 +1237,7 @@
(func '$drop '(param bytes i64) (func '$drop '(param bytes i64)
) )
(dlet ( (dlet (
(alloc_data (dlambda (d (watermark datas)) (cond ((str? d) (let ((size (+ 8 (band (len d) -8)))) (array (+ watermark 8) (len d) (array (+ watermark 8 size) (concat datas (data (i32.const watermark) (concat "\\00\\00\\00\\00\\00\\00\\00\\80" d))))))) (alloc_data (dlambda (d (watermark datas)) (cond ((str? d) (let ((size (+ 8 (& (len d) -8)))) (array (+ watermark 8) (len d) (array (+ watermark 8 size) (concat datas (data (i32.const watermark) (concat "\\00\\00\\00\\00\\00\\00\\00\\80" d)))))))
(true (error (str "can't alloc_data for anything else besides strings yet" d))) (true (error (str "can't alloc_data for anything else besides strings yet" d)))
) )
)) ))
@@ -1309,7 +1314,7 @@
; ptr to start of array of symbols ; ptr to start of array of symbols
(local.set '$x_tmp (i32.wrap_i64 (i64.and (i64.load (local.get '$ptr_tmp)) (i64.const -8)))) (local.set '$x_tmp (i32.wrap_i64 (i64.and (i64.load (local.get '$ptr_tmp)) (i64.const -8))))
; ptr to start of array of values ; ptr to start of array of values
(local.set '$y_tmp (i32.wrap_i64 (i64.and (i64.load (i32.add (i32.const 8) (local.get '$ptr_tmp))) (i64.const -8)))) (local.set '$y_tmp (i32.wrap_i64 (i64.and (i64.load 8 (local.get '$ptr_tmp)) (i64.const -8))))
; lenght of both arrays, pulled from array encoding of x ; lenght of both arrays, pulled from array encoding of x
(local.set '$i_tmp (i32.wrap_i64 (i64.shr_u (i64.load (local.get '$ptr_tmp)) (i64.const 32)))) (local.set '$i_tmp (i32.wrap_i64 (i64.shr_u (i64.load (local.get '$ptr_tmp)) (i64.const 32))))
@@ -1332,7 +1337,7 @@
) )
) )
;; deal with upper ;; deal with upper
(local.set '$item (i64.load (i32.add (i32.const 16) (local.get '$ptr_tmp)))) (local.set '$item (i64.load 16 (local.get '$ptr_tmp)))
(_if '$is_upper_env (_if '$is_upper_env
(i64.eq (i64.const #b01001) (i64.and (i64.const #b11111) (local.get '$item))) (i64.eq (i64.const #b01001) (i64.and (i64.const #b11111) (local.get '$item)))
(then (then
@@ -1389,7 +1394,7 @@
(memory.copy (i32.add (i32.const 1) (local.get '$buf)) (memory.copy (i32.add (i32.const 1) (local.get '$buf))
(i32.wrap_i64 (i64.and (i64.const -8) (local.get '$to_str))) (i32.wrap_i64 (i64.and (i64.const -8) (local.get '$to_str)))
(local.tee '$len_tmp (i32.wrap_i64 (i64.shr_u (local.get '$to_str) (i64.const 32))))) (local.tee '$len_tmp (i32.wrap_i64 (i64.shr_u (local.get '$to_str) (i64.const 32)))))
(i32.store8 (i32.add (local.get '$buf) (i32.add (i32.const 1) (local.get '$len_tmp))) (i32.const #x22)) (i32.store8 1 (i32.add (local.get '$buf) (local.get '$len_tmp)) (i32.const #x22))
(i32.add (i32.const 2) (local.get '$len_tmp)) (i32.add (i32.const 2) (local.get '$len_tmp))
) )
(else (else
@@ -1433,7 +1438,7 @@
; ptr to start of array of symbols ; ptr to start of array of symbols
(local.set '$x_tmp (i32.wrap_i64 (i64.and (i64.load (local.get '$ptr_tmp)) (i64.const -8)))) (local.set '$x_tmp (i32.wrap_i64 (i64.and (i64.load (local.get '$ptr_tmp)) (i64.const -8))))
; ptr to start of array of values ; ptr to start of array of values
(local.set '$y_tmp (i32.wrap_i64 (i64.and (i64.load (i32.add (i32.const 8) (local.get '$ptr_tmp))) (i64.const -8)))) (local.set '$y_tmp (i32.wrap_i64 (i64.and (i64.load 8 (local.get '$ptr_tmp)) (i64.const -8))))
; lenght of both arrays, pulled from array encoding of x ; lenght of both arrays, pulled from array encoding of x
(local.set '$i_tmp (i32.wrap_i64 (i64.shr_u (i64.load (local.get '$ptr_tmp)) (i64.const 32)))) (local.set '$i_tmp (i32.wrap_i64 (i64.shr_u (i64.load (local.get '$ptr_tmp)) (i64.const 32))))
@@ -1460,12 +1465,12 @@
) )
) )
;; deal with upper ;; deal with upper
(local.set '$item (i64.load (i32.add (i32.const 16) (local.get '$ptr_tmp)))) (local.set '$item (i64.load 16 (local.get '$ptr_tmp)))
(_if '$is_upper_env (_if '$is_upper_env
(i64.eq (i64.const #b01001) (i64.and (i64.const #b11111) (local.get '$item))) (i64.eq (i64.const #b01001) (i64.and (i64.const #b11111) (local.get '$item)))
(then (then
(i32.store8 (i32.add (local.get '$buf) (i32.sub (local.get '$len_tmp) (i32.const 2))) (i32.const #x20)) (i32.store8 -2 (i32.add (local.get '$buf) (local.get '$len_tmp)) (i32.const #x20))
(i32.store8 (i32.add (local.get '$buf) (i32.sub (local.get '$len_tmp) (i32.const 1))) (i32.const #x7C)) (i32.store8 -1 (i32.add (local.get '$buf) (local.get '$len_tmp)) (i32.const #x7C))
(i32.store8 (i32.add (local.get '$len_tmp) (local.get '$buf)) (i32.const #x20)) (i32.store8 (i32.add (local.get '$len_tmp) (local.get '$buf)) (i32.const #x20))
(local.set '$len_tmp (i32.add (local.get '$len_tmp) (i32.const 1))) (local.set '$len_tmp (i32.add (local.get '$len_tmp) (i32.const 1)))
(local.set '$len_tmp (i32.add (local.get '$len_tmp) (call '$str_helper (local.get '$item) (i32.add (local.get '$buf) (local.get '$len_tmp))))) (local.set '$len_tmp (i32.add (local.get '$len_tmp) (call '$str_helper (local.get '$item) (i32.add (local.get '$buf) (local.get '$len_tmp)))))
@@ -1481,7 +1486,7 @@
(i64.eq (i64.const #b0001) (i64.and (i64.const #b1111) (local.get '$to_str))) (i64.eq (i64.const #b0001) (i64.and (i64.const #b1111) (local.get '$to_str)))
(then (then
(i32.store (local.get '$buf) (i32.const #x626D6F63)) (i32.store (local.get '$buf) (i32.const #x626D6F63))
(i32.store8 (i32.add (local.get '$buf) (i32.const 4)) (i32.store8 4 (local.get '$buf)
(i32.add (i32.const #x30) (i32.add (i32.const #x30)
(i32.and (i32.const #b11) (i32.and (i32.const #b11)
(i32.wrap_i64 (i64.shr_u (local.get '$to_str) (i64.const 4)))))) (i32.wrap_i64 (i64.shr_u (local.get '$to_str) (i64.const 4))))))
@@ -1530,7 +1535,7 @@
(local.tee '$data_size (call '$str_len (local.get '$to_print)))))) (local.tee '$data_size (call '$str_len (local.get '$to_print))))))
(drop (call '$str_helper (local.get '$to_print) (i32.add (i32.const 8) (local.get '$iov)))) (drop (call '$str_helper (local.get '$to_print) (i32.add (i32.const 8) (local.get '$iov))))
(i32.store (local.get '$iov) (i32.add (i32.const 8) (local.get '$iov))) ;; adder of data (i32.store (local.get '$iov) (i32.add (i32.const 8) (local.get '$iov))) ;; adder of data
(i32.store (i32.add (local.get '$iov) (i32.const 4)) (local.get '$data_size)) ;; len of data (i32.store 4 (local.get '$iov) (local.get '$data_size)) ;; len of data
(drop (call '$fd_write (drop (call '$fd_write
(i32.const 1) ;; file descriptor (i32.const 1) ;; file descriptor
(local.get '$iov) ;; *iovs (local.get '$iov) ;; *iovs
@@ -1545,41 +1550,46 @@
(i64.and (i64.shr_u (local.get '$it) (i64.const 31)) (i64.const -2)) (i64.and (i64.shr_u (local.get '$it) (i64.const 31)) (i64.const -2))
)))) ))))
((k_vau func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$vau (unreachable))))) ((k_vau func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$vau '(param $d i64) '(param $s i64) '(param $p i64) '(result i64) (unreachable)))))
((k_read-string func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$read-string (unreachable))))) ((k_read-string func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$read-string '(param $d i64) '(param $s i64) '(param $p i64) '(result i64) (unreachable)))))
((k_println func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$read-string (unreachable))))) ((k_log func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$log '(param $d i64) '(param $s i64) '(param $p i64) '(result i64) (unreachable)))))
((k_str func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$str (unreachable))))) ((k_error func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$error '(param $d i64) '(param $s i64) '(param $p i64) '(result i64) (unreachable)))))
((k_or func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$or (unreachable))))) ((k_str func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$str '(param $d i64) '(param $s i64) '(param $p i64) '(result i64) (unreachable)))))
((k_and func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$and (unreachable))))) ((k_or func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$or '(param $d i64) '(param $s i64) '(param $p i64) '(result i64) (unreachable)))))
((k_geq func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$geq (unreachable))))) ((k_and func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$and '(param $d i64) '(param $s i64) '(param $p i64) '(result i64) (unreachable)))))
((k_gt func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$gt (unreachable))))) ((k_geq func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$geq '(param $d i64) '(param $s i64) '(param $p i64) '(result i64) (unreachable)))))
((k_leq func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$leq (unreachable))))) ((k_gt func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$gt '(param $d i64) '(param $s i64) '(param $p i64) '(result i64) (unreachable)))))
((k_lt func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$lt (unreachable))))) ((k_leq func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$leq '(param $d i64) '(param $s i64) '(param $p i64) '(result i64) (unreachable)))))
((k_neq func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$neq (unreachable))))) ((k_lt func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$lt '(param $d i64) '(param $s i64) '(param $p i64) '(result i64) (unreachable)))))
((k_eq func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$eq (unreachable))))) ((k_neq func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$neq '(param $d i64) '(param $s i64) '(param $p i64) '(result i64) (unreachable)))))
((k_mod func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$mod (unreachable))))) ((k_eq func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$eq '(param $d i64) '(param $s i64) '(param $p i64) '(result i64) (unreachable)))))
((k_div func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$div (unreachable))))) ((k_mod func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$mod '(param $d i64) '(param $s i64) '(param $p i64) '(result i64) (unreachable)))))
((k_mul func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$mul (unreachable))))) ((k_div func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$div '(param $d i64) '(param $s i64) '(param $p i64) '(result i64) (unreachable)))))
((k_add func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$add (unreachable))))) ((k_mul func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$mul '(param $d i64) '(param $s i64) '(param $p i64) '(result i64) (unreachable)))))
((k_sub func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$sub (unreachable))))) ((k_add func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$add '(param $d i64) '(param $s i64) '(param $p i64) '(result i64) (unreachable)))))
((k_concat func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$concat (unreachable))))) ((k_sub func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$sub '(param $d i64) '(param $s i64) '(param $p i64) '(result i64) (unreachable)))))
((k_slice func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$slice (unreachable))))) ((k_band func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$band '(param $d i64) '(param $s i64) '(param $p i64) '(result i64) (unreachable)))))
((k_idx func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$idx (unreachable))))) ((k_bor func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$bor '(param $d i64) '(param $s i64) '(param $p i64) '(result i64) (unreachable)))))
((k_array func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$array (unreachable))))) ((k_ls func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$ls '(param $d i64) '(param $s i64) '(param $p i64) '(result i64) (unreachable)))))
((k_arrayp func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$arrayp (unreachable))))) ((k_rs func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$rs '(param $d i64) '(param $s i64) '(param $p i64) '(result i64) (unreachable)))))
((k_get-text func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$get-text (unreachable))))) ((k_concat func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$concat '(param $d i64) '(param $s i64) '(param $p i64) '(result i64) (unreachable)))))
((k_str-to-symbol func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$str-to-symbol (unreachable))))) ((k_slice func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$slice '(param $d i64) '(param $s i64) '(param $p i64) '(result i64) (unreachable)))))
((k_bool? func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$bool? (unreachable))))) ((k_idx func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$idx '(param $d i64) '(param $s i64) '(param $p i64) '(result i64) (unreachable)))))
((k_nil? func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$nil? (unreachable))))) ((k_array func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$array '(param $d i64) '(param $s i64) '(param $p i64) '(result i64) (unreachable)))))
((k_env? func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$env? (unreachable))))) ((k_arrayp func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$arrayp '(param $d i64) '(param $s i64) '(param $p i64) '(result i64) (unreachable)))))
((k_combiner? func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$combiner? (unreachable))))) ((k_get-text func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$get-text '(param $d i64) '(param $s i64) '(param $p i64) '(result i64) (unreachable)))))
((k_string? func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$string? (unreachable))))) ((k_str-to-symbol func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$str-to-symbol '(param $d i64) '(param $s i64) '(param $p i64) '(result i64) (unreachable)))))
((k_int? func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$int? (unreachable))))) ((k_bool? func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$bool? '(param $d i64) '(param $s i64) '(param $p i64) '(result i64) (unreachable)))))
((k_symbol? func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$symbol? (unreachable))))) ((k_nil? func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$nil? '(param $d i64) '(param $s i64) '(param $p i64) '(result i64) (unreachable)))))
((k_cond func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$cond (unreachable))))) ((k_env? func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$env? '(param $d i64) '(param $s i64) '(param $p i64) '(result i64) (unreachable)))))
((k_eval func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$eval (unreachable))))) ((k_combiner? func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$combiner? '(param $d i64) '(param $s i64) '(param $p i64) '(result i64) (unreachable)))))
((k_unwrap func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$unwrap (unreachable))))) ((k_string? func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$string? '(param $d i64) '(param $s i64) '(param $p i64) '(result i64) (unreachable)))))
((k_wrap func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$wrap (unreachable))))) ((k_int? func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$int? '(param $d i64) '(param $s i64) '(param $p i64) '(result i64) (unreachable)))))
((k_symbol? func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$symbol? '(param $d i64) '(param $s i64) '(param $p i64) '(result i64) (unreachable)))))
((k_cond func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$cond '(param $d i64) '(param $s i64) '(param $p i64) '(result i64) (unreachable)))))
((k_eval func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$eval '(param $d i64) '(param $s i64) '(param $p i64) '(result i64) (unreachable)))))
((k_unwrap func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$unwrap '(param $d i64) '(param $s i64) '(param $p i64) '(result i64) (unreachable)))))
((k_wrap func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$wrap '(param $d i64) '(param $s i64) '(param $p i64) '(result i64) (unreachable)))))
(get_passthrough (lambda (hash datasi funcs memo) (let ((r (get-value-or-false memo hash))) (get_passthrough (lambda (hash datasi funcs memo) (let ((r (get-value-or-false memo hash)))
(if r (array r datasi funcs memo) #f)))) (if r (array r datasi funcs memo) #f))))
@@ -1634,7 +1644,8 @@
((= 'and_fake_real (.prim_comb_sym c)) (array (bor (<< k_and 35) (<< 0 4) #b0001) datasi funcs memo)) ((= 'and_fake_real (.prim_comb_sym c)) (array (bor (<< k_and 35) (<< 0 4) #b0001) datasi funcs memo))
((= 'len_fake_real (.prim_comb_sym c)) (array (bor (<< k_len 35) (<< 1 4) #b0001) datasi funcs memo)) ((= 'len_fake_real (.prim_comb_sym c)) (array (bor (<< k_len 35) (<< 1 4) #b0001) datasi funcs memo))
((= 'read-string (.prim_comb_sym c)) (array (bor (<< k_read-string 35) (<< 1 4) #b0001) datasi funcs memo)) ((= 'read-string (.prim_comb_sym c)) (array (bor (<< k_read-string 35) (<< 1 4) #b0001) datasi funcs memo))
((= 'println (.prim_comb_sym c)) (array (bor (<< k_println 35) (<< 1 4) #b0001) datasi funcs memo)) ((= 'log (.prim_comb_sym c)) (array (bor (<< k_log 35) (<< 1 4) #b0001) datasi funcs memo))
((= 'error (.prim_comb_sym c)) (array (bor (<< k_error 35) (<< 1 4) #b0001) datasi funcs memo))
((= 'str (.prim_comb_sym c)) (array (bor (<< k_str 35) (<< 1 4) #b0001) datasi funcs memo)) ((= 'str (.prim_comb_sym c)) (array (bor (<< k_str 35) (<< 1 4) #b0001) datasi funcs memo))
((= '>= (.prim_comb_sym c)) (array (bor (<< k_geq 35) (<< 1 4) #b0001) datasi funcs memo)) ((= '>= (.prim_comb_sym c)) (array (bor (<< k_geq 35) (<< 1 4) #b0001) datasi funcs memo))
((= '> (.prim_comb_sym c)) (array (bor (<< k_gt 35) (<< 1 4) #b0001) datasi funcs memo)) ((= '> (.prim_comb_sym c)) (array (bor (<< k_gt 35) (<< 1 4) #b0001) datasi funcs memo))
@@ -1647,6 +1658,10 @@
((= '* (.prim_comb_sym c)) (array (bor (<< k_mul 35) (<< 1 4) #b0001) datasi funcs memo)) ((= '* (.prim_comb_sym c)) (array (bor (<< k_mul 35) (<< 1 4) #b0001) datasi funcs memo))
((= '+ (.prim_comb_sym c)) (array (bor (<< k_add 35) (<< 1 4) #b0001) datasi funcs memo)) ((= '+ (.prim_comb_sym c)) (array (bor (<< k_add 35) (<< 1 4) #b0001) datasi funcs memo))
((= '- (.prim_comb_sym c)) (array (bor (<< k_sub 35) (<< 1 4) #b0001) datasi funcs memo)) ((= '- (.prim_comb_sym c)) (array (bor (<< k_sub 35) (<< 1 4) #b0001) datasi funcs memo))
((= '& (.prim_comb_sym c)) (array (bor (<< k_band 35) (<< 1 4) #b0001) datasi funcs memo))
((= 'bor (.prim_comb_sym c)) (array (bor (<< k_bor 35) (<< 1 4) #b0001) datasi funcs memo))
((= '<< (.prim_comb_sym c)) (array (bor (<< k_ls 35) (<< 1 4) #b0001) datasi funcs memo))
((= '>> (.prim_comb_sym c)) (array (bor (<< k_rs 35) (<< 1 4) #b0001) datasi funcs memo))
((= 'concat_fake_real (.prim_comb_sym c)) (array (bor (<< k_concat 35) (<< 1 4) #b0001) datasi funcs memo)) ((= 'concat_fake_real (.prim_comb_sym c)) (array (bor (<< k_concat 35) (<< 1 4) #b0001) datasi funcs memo))
((= 'slice_fake_real (.prim_comb_sym c)) (array (bor (<< k_slice 35) (<< 1 4) #b0001) datasi funcs memo)) ((= 'slice_fake_real (.prim_comb_sym c)) (array (bor (<< k_slice 35) (<< 1 4) #b0001) datasi funcs memo))
((= 'idx_fake_real (.prim_comb_sym c)) (array (bor (<< k_idx 35) (<< 1 4) #b0001) datasi funcs memo)) ((= 'idx_fake_real (.prim_comb_sym c)) (array (bor (<< k_idx 35) (<< 1 4) #b0001) datasi funcs memo))
@@ -1682,7 +1697,7 @@
; x+2+4 = y + 3 + 5 ; x+2+4 = y + 3 + 5
; x + 6 = y + 8 ; x + 6 = y + 8
; x - 2 = y ; x - 2 = y
(located_env_ptr (band #x7FFFFFFC0 (>> our_env_val 2))) (located_env_ptr (& #x7FFFFFFC0 (>> our_env_val 2)))
(map_val (dlambda ((v datasi funcs memo) f) (array (f v) datasi funcs memo))) (map_val (dlambda ((v datasi funcs memo) f) (array (f v) datasi funcs memo)))
@@ -1700,7 +1715,7 @@
; have to figure out how to communicate envs... ; have to figure out how to communicate envs...
((inner_code datasi funcs memo) (compile_code datasi funcs memo body)) ((inner_code datasi funcs memo) (compile_code datasi funcs memo body))
(our_func (func '$len '(param $it i64) '(result i64) (our_func (func '$len '(param $d_env i64) '(param $s_env i64) '(param $params i64) '(result i64)
inner_code inner_code
)) ))
(funcs (concat funcs our_func)) (funcs (concat funcs our_func))
@@ -1714,10 +1729,44 @@
(_ (println "compiling partial evaled " (str_strip marked_code))) (_ (println "compiling partial evaled " (str_strip marked_code)))
(memo empty_dict) (memo empty_dict)
((exit_val datasi funcs memo) (compile_value datasi funcs memo (marked_symbol true 'exit)))
((error_msg_val datasi funcs memo) (compile_value datasi funcs memo (marked_val "Not a legal monad (slurp/write_file/get_line/print/exit)")))
((exit_msg_val datasi funcs memo) (compile_value datasi funcs memo (marked_val "Exiting with code:")))
((compiled_value_ptr datasi funcs memo) (compile_value datasi funcs memo marked_code)) ((compiled_value_ptr datasi funcs memo) (compile_value datasi funcs memo marked_code))
(_ (println "compiled it to " compiled_value_ptr)) (_ (println "compiled it to " compiled_value_ptr))
(start (func '$start ; Ok, so the outer loop handles the IO monads
(call '$print (i64.const compiled_value_ptr)) ; ('slurp "path" <cont (data)>)
; ('write_file "path" "data" <cont ()>)
; ('get_line <cont (data)>)
; ('print "data" <cont ()>)
; ('exit code)
(start (func '$start '(local $it i64) '(local $ptr i32) '(local $monad_name i64)
(local.set '$it (i64.const compiled_value_ptr))
(block '$exit_block
(block '$error_block
(_loop '$l
; Not array -> out
(br_if '$error_block (i64.ne (i64.const #b101) (i64.and (i64.const #b101) (local.get '$it))))
; less than len 2 -> out
(br_if '$error_block (i64.lt_u (i64.shr_u (local.get '$it) (i64.const 32)) (i64.const 2)))
(local.set '$ptr (i32.wrap_i64 (i64.and (local.get '$it) (i64.const -8))))
(local.set '$monad_name (i64.load (local.get '$ptr)))
(_if '$is_exit
(i64.eq (i64.const exit_val) (local.get '$monad_name))
(then
; Exit
(call '$print (i64.const exit_msg_val))
(call '$print (i64.load 8 (local.get '$ptr)))
(br '$exit_block)
)
)
;(br '$l)
)
)
; print error
(call '$print (i64.const error_msg_val))
(call '$print (local.get '$it))
)
)) ))
((watermark datas) datasi) ((watermark datas) datasi)
) (concat (global '$data_end '(mut i32) (i32.const watermark)) datas funcs start )) ) (concat (global '$data_end '(mut i32) (i32.const watermark)) datas funcs start ))
@@ -1770,7 +1819,7 @@
(print (run_test "(+ 1 2)")) (print (run_test "(+ 1 2)"))
(print) (print) (print) (print)
(print (run_test "(cond false 1 true 2)")) (print (run_test "(cond false 1 true 2)"))
(print (run_test "(println 1)")) (print (run_test "(log 1)"))
(print (run_test "((vau (x) (+ x 1)) 2)")) (print (run_test "((vau (x) (+ x 1)) 2)"))
@@ -1958,7 +2007,8 @@
;(output3 (compile (partial_eval (read-string "(eval (array (array vau ((vau (x) x) (a b)) (array (array vau ((vau (x) x) x) (array) ((vau (x) x) x)))) empty_env 2) empty_env)")))) ;(output3 (compile (partial_eval (read-string "(eval (array (array vau ((vau (x) x) (a b)) (array (array vau ((vau (x) x) x) (array) ((vau (x) x) x)))) empty_env 2) empty_env)"))))
;(output3 (compile (partial_eval (read-string "(eval (array (array vau ((vau (x) x) x) (array) ((vau (x) x) x))))")))) ;(output3 (compile (partial_eval (read-string "(eval (array (array vau ((vau (x) x) x) (array) ((vau (x) x) x))))"))))
;(output3 (compile (partial_eval (read-string "(vau (x) x)")))) ;(output3 (compile (partial_eval (read-string "(vau (x) x)"))))
(output3 (compile (partial_eval (read-string "(vau (x) 1)")))) ;(output3 (compile (partial_eval (read-string "(vau (x) 1)"))))
(output3 (compile (partial_eval (read-string "(array ((vau (x) x) exit) 1)"))))
;(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"))))
;(output3 (compile (partial_eval (read-string "vau")))) ;(output3 (compile (partial_eval (read-string "vau"))))