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

Add block length to memory header (joining the refcount), add read & write monand impls. Big todo: typechecks in monad impl, length checks for compiled functions, compiling calls, then all the stdlib.

Browse Source
This commit is contained in:
Nathan Braswell
2021-12-27 01:35:15 -05:00
parent 021cae4eea
commit 481cac5070
1 changed files with 137 additions and 37 deletions
Download Patch File Download Diff File Expand all files Collapse all files

174
partial_eval.csc
View File

@@ -1233,30 +1233,49 @@
(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))))))
(i64_le_hexify (lambda (x) ((rec-lambda recurse (x i) (if (= i 0) "" (le_hexify_helper (rec-lambda recurse (x i) (if (= i 0) ""
(concat "\\" (to_hex_digit (remainder (quotient x 16) 16)) (to_hex_digit (remainder x 16)) (recurse (quotient x 256) (- i 1))))) x 8))) (concat "\\" (to_hex_digit (remainder (quotient x 16) 16)) (to_hex_digit (remainder x 16)) (recurse (quotient x 256) (- i 1))))))
(i64_le_hexify (lambda (x) (le_hexify_helper x 8)))
(i32_le_hexify (lambda (x) (le_hexify_helper x 4)))
(compile (lambda (marked_code) (wasm_to_binary (module (compile (lambda (marked_code) (wasm_to_binary (module
(import "wasi_unstable" "fd_read"
'(func $fd_read (param i32 i32 i32 i32)
(result i32)))
(import "wasi_unstable" "fd_write" (import "wasi_unstable" "fd_write"
'(func $fd_write (param i32 i32 i32 i32) '(func $fd_write (param i32 i32 i32 i32)
(result i32))) (result i32)))
(memory '$mem 1) (memory '$mem 1)
(global '$last_base '(mut i32) (i32.const 0)) (global '$last_base '(mut i32) (i32.const 0))
(dlet ( (dlet (
(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))))))) (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 (i32_le_hexify size) "\\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)))
) )
)) ))
(datasi (array 8 (array))) ; We won't use 0 because some impls seem to consider that NULL and crash on reading/writing?
(iov_tmp 8) ; <32bit len><32bit ptr> + <32bit numwitten>
(datasi (array (+ iov_tmp 16) (array)))
((true_loc true_length datasi) (alloc_data "true" datasi)) ((true_loc true_length datasi) (alloc_data "true" datasi))
((false_loc false_length datasi) (alloc_data "false" datasi)) ((false_loc false_length datasi) (alloc_data "false" datasi))
; 0 is fd_write ; 0 is fd_read, 1 is fd_write
((func_idx funcs) (array 1 (array))) ((func_idx funcs) (array 2 (array)))
; malloc allocates with size and refcount in header
((k_malloc func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$malloc '(param $bytes i32) '(result i32) ((k_malloc func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$malloc '(param $bytes i32) '(result i32)
(global.set '$last_base (i32.shl (memory.grow (i32.add (i32.const 1) (i32.shr_u (local.get '$bytes) (i32.const 16)))) (i32.const 16))) (global.set '$last_base (i32.shl (memory.grow (i32.add (i32.const 1)
(global.get '$last_base) (i32.shr_u (i32.add (i32.const 8) (local.get '$bytes)) (i32.const 16))))
(i32.const 16)))
; write count
(i32.store 0 (global.get '$last_base) (local.get '$bytes))
(i32.store 4 (global.get '$last_base) (i32.const 1))
(i32.add (global.get '$last_base) (i32.const 8))
)))) ))))
((k_free func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$free '(param bytes i32) ((k_free func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$free '(param bytes i32)
)))) ))))
@@ -1266,20 +1285,24 @@
; 0..0<env_ptr32 but still aligned>01001 ; 0..0<env_ptr32 but still aligned>01001
((k_env_alloc func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$env_alloc '(param $keys i64) '(param $vals i64) '(param $upper i64) '(result i64) '(local $tmp i32) ((k_env_alloc func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$env_alloc '(param $keys i64) '(param $vals i64) '(param $upper i64) '(result i64) '(local $tmp i32)
(local.set '$tmp (call '$malloc (i32.const (* 8 4)))) (local.set '$tmp (call '$malloc (i32.const (* 8 3))))
(i64.store 0 (local.get '$tmp) (i64.const 0)) (i64.store 0 (local.get '$tmp) (local.get '$keys))
(i64.store 8 (local.get '$tmp) (local.get '$keys)) (i64.store 8 (local.get '$tmp) (local.get '$vals))
(i64.store 16 (local.get '$tmp) (local.get '$vals)) (i64.store 16 (local.get '$tmp) (local.get '$upper))
(i64.store 24 (local.get '$tmp) (local.get '$upper)) (i64.or (i64.shl (i64.extend_i32_u (local.get '$tmp)) (i64.const 5)) (i64.const #b01001))
(i64.or (i64.shl (i64.extend_i32_u (i32.add (i32.const 8) (local.get '$tmp))) (i64.const 5)) (i64.const #b01001))
)))) ))))
; <array_size32><array_ptr29>101 / 0..0 101 ; <array_size32><array_ptr29>101 / 0..0 101
((k_array1_alloc func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$array1_alloc '(param $item i64) '(result i64) '(local $tmp i32) ((k_array1_alloc func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$array1_alloc '(param $item i64) '(result i64) '(local $tmp i32)
(local.set '$tmp (call '$malloc (i32.const (* 8 2)))) (local.set '$tmp (call '$malloc (i32.const 8)))
(i64.store 0 (local.get '$tmp) (i64.const 0)) (i64.store 0 (local.get '$tmp) (local.get '$item))
(i64.store 8 (local.get '$tmp) (local.get '$item)) (i64.or (i64.extend_i32_u (local.get '$tmp)) (i64.const #x0000000100000005))
(i64.or (i64.extend_i32_u (i32.add (i32.const 8) (local.get '$tmp))) (i64.const #x0000000100000005)) ))))
((k_array2_alloc func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$array2_alloc '(param $a i64) '(param $b i64) '(result i64) '(local $tmp i32)
(local.set '$tmp (call '$malloc (i32.const 16)))
(i64.store 0 (local.get '$tmp) (local.get '$a))
(i64.store 8 (local.get '$tmp) (local.get '$b))
(i64.or (i64.extend_i32_u (local.get '$tmp)) (i64.const #x0000000200000005))
)))) ))))
((k_int_digits func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$int_digits '(param $int i64) '(result i32) '(local $tmp i32) ((k_int_digits func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$int_digits '(param $int i64) '(result i32) '(local $tmp i32)
@@ -1754,7 +1777,7 @@
(result (lookup_helper (.env_marked env) (.marked_symbol_value c) 0 (local.get '$s_env))) (result (lookup_helper (.env_marked env) (.marked_symbol_value c) 0 (local.get '$s_env)))
) (array result datasi funcs memo)))) ) (array result datasi funcs memo))))
((marked_array? c) (if (.marked_array_is_val c) (map_val (recurse-value datasi funcs memo c) (lambda (v) (i64.const v))) ((marked_array? c) (if (.marked_array_is_val c) (map_val (recurse-value datasi funcs memo c) (lambda (v) (i64.const v)))
(error "call cuz array in code"))) (error (str "call cuz array in code" c))))
((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) (error "can't compile code comb right now")) ((comb? c) (error "can't compile code comb right now"))
(true (error (str "can't compile-code " c " right now"))) (true (error (str "can't compile-code " c " right now")))
@@ -1762,8 +1785,8 @@
((inner_env setup_code datasi funcs memo) (if (= 0 (len params)) (array se (array) datasi funcs memo) ((inner_env setup_code datasi funcs memo) (if (= 0 (len params)) (array se (array) datasi funcs memo)
(dlet ( (dlet (
((params_vec datasi funcs memo) (recurse-value datasi funcs memo (marked_array true params))) ((params_vec datasi funcs memo) (recurse-value datasi funcs memo (marked_array true (map (lambda (k) (marked_symbol true k)) params))))
) (array (marked_env false 0 (concat (map (lambda (k) (array k 0)) params) (array se))) ) (array (marked_env false 0 (concat (map (lambda (k) (array k (marked_val 0))) params) (array se)))
(local.set '$s_env (call '$env_alloc (i64.const params_vec) (local.get '$params) (local.get '$s_env))) (local.set '$s_env (call '$env_alloc (i64.const params_vec) (local.get '$params) (local.get '$s_env)))
datasi funcs memo datasi funcs memo
) )
@@ -1780,11 +1803,14 @@
) )
))) )))
((inner_code datasi funcs memo) (compile_code datasi funcs memo inner_env body)) ((inner_code datasi funcs memo) (compile_code datasi funcs memo inner_env body))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; We have to emit code that checks the length of the passed params
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(our_func (func '$len '(param $d_env i64) '(param $s_env i64) '(param $params i64) '(result i64) (our_func (func '$len '(param $d_env i64) '(param $s_env i64) '(param $params i64) '(result i64)
(concat setup_code inner_code) (concat setup_code inner_code)
)) ))
(funcs (concat funcs our_func)) (funcs (concat funcs our_func))
(our_func_idx (- (len funcs) k_len)) (our_func_idx (- (len funcs) k_len -1))
; also insert env here ; also insert env here
(result (bor (<< our_func_idx 35) located_env_ptr (<< wrap_level 4) #b0001)) (result (bor (<< our_func_idx 35) located_env_ptr (<< wrap_level 4) #b0001))
(memo (put memo (.hash c) result)) (memo (put memo (.hash c) result))
@@ -1795,19 +1821,20 @@
(_ (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))) ((exit_val datasi funcs memo) (compile_value datasi funcs memo (marked_symbol true 'exit)))
((print_val datasi funcs memo) (compile_value datasi funcs memo (marked_symbol true 'print))) ((read_val datasi funcs memo) (compile_value datasi funcs memo (marked_symbol true 'read)))
((error_msg_val datasi funcs memo) (compile_value datasi funcs memo (marked_val "Not a legal monad (slurp/write_file/get_line/print/exit)"))) ((write_val datasi funcs memo) (compile_value datasi funcs memo (marked_symbol true 'write)))
((error_msg_val datasi funcs memo) (compile_value datasi funcs memo (marked_val "Not a legal monad (read/write/exit)")))
((bad_read_val datasi funcs memo) (compile_value datasi funcs memo (marked_val "<error with read>")))
((exit_msg_val datasi funcs memo) (compile_value datasi funcs memo (marked_val "Exiting with code:"))) ((exit_msg_val datasi funcs memo) (compile_value datasi funcs memo (marked_val "Exiting with code:")))
((root_marked_env_val datasi funcs memo) (compile_value datasi funcs memo root_marked_env)) ((root_marked_env_val datasi funcs memo) (compile_value datasi funcs memo root_marked_env))
((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))
; Ok, so the outer loop handles the IO monads ; Ok, so the outer loop handles the IO monads
; ('slurp "path" <cont (data)>)
; ('write_file "path" "data" <cont ()>)
; ('get_line <cont (data)>)
; ('print "data" <cont ()>)
; ('exit code) ; ('exit code)
(start (func '$start '(local $it i64) '(local $ptr i32) '(local $monad_name i64) ; ('read fd len <cont (data/error?)>)
; ('write fd "data" <cont (num_written/error?)>)
(start (func '$start '(local $it i64) '(local $ptr i32) '(local $monad_name i64) '(local $len i32) '(local $buf i32) '(local $code i32) '(local $str i64) '(local $result i64)
(local.set '$it (i64.const compiled_value_ptr)) (local.set '$it (i64.const compiled_value_ptr))
(block '$exit_block (block '$exit_block
(block '$error_block (block '$error_block
@@ -1818,6 +1845,8 @@
(br_if '$error_block (i64.lt_u (i64.shr_u (local.get '$it) (i64.const 32)) (i64.const 2))) (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 '$ptr (i32.wrap_i64 (i64.and (local.get '$it) (i64.const -8))))
(local.set '$monad_name (i64.load (local.get '$ptr))) (local.set '$monad_name (i64.load (local.get '$ptr)))
; ('exit code)
(_if '$is_exit (_if '$is_exit
(i64.eq (i64.const exit_val) (local.get '$monad_name)) (i64.eq (i64.const exit_val) (local.get '$monad_name))
(then (then
@@ -1827,11 +1856,37 @@
) )
) )
(br_if '$error_block (i64.lt_u (i64.shr_u (local.get '$it) (i64.const 32)) (i64.const 3))) (br_if '$error_block (i64.lt_u (i64.shr_u (local.get '$it) (i64.const 32)) (i64.const 3)))
(_if '$is_print
(i64.eq (i64.const print_val) (local.get '$monad_name)) ; ('read fd len <cont (data error_code)>)
(_if '$is_read
(i64.eq (i64.const read_val) (local.get '$monad_name))
(then (then
(call '$print (i64.load 8 (local.get '$ptr))) ; iov <32bit len><32bit addr> + <32bit num written>
(local.set '$it (i64.load 16 (local.get '$ptr))) (i32.store 0 (i32.const iov_tmp) (local.tee '$buf (call '$malloc (local.get '$len))))
(i32.store 4 (i32.const iov_tmp) (local.tee '$len (i32.wrap_i64 (i64.shr_u (i64.load 16 (local.get '$ptr)) (i64.const 1)))))
(local.set '$code (call '$fd_read
(i32.wrap_i64 (i64.shr_u (i64.load 8 (local.get '$ptr)) (i64.const 1))) ;; file descriptor
(i32.const iov_tmp) ;; *iovs
(i32.const 1) ;; iovs_len
(i32.const (+ 8 iov_tmp)) ;; nwritten
))
; <string_size32><string_ptr29>011
(local.set '$str (i64.or (i64.shl (i64.extend_i32_u (i32.load 8 (i32.const iov_tmp))) (i64.const 32))
(i64.extend_i32_u (i32.or (local.get '$buf) (i32.const #b011)))))
(_if '$is_error
(i32.eqz (local.get '$code))
(then
(local.set '$result (call '$array2_alloc (local.get '$str)
(i64.const 0)))
)
(else
(call '$drop (local.get '$str))
(local.set '$result (call '$array2_alloc (i64.const bad_read_val)
(i64.shl (i64.extend_i32_u (local.get '$code)) (i64.const 1))))
)
)
(local.set '$it (i64.load 24 (local.get '$ptr)))
(local.set '$it (call_indirect (local.set '$it (call_indirect
;type ;type
k_vau k_vau
@@ -1842,7 +1897,46 @@
; static env ; static env
(i64.or (i64.shl (i64.and (local.get '$it) (i64.const #x3FFFFFFC0)) (i64.const 2)) (i64.const #b01001)) (i64.or (i64.shl (i64.and (local.get '$it) (i64.const #x3FFFFFFC0)) (i64.const 2)) (i64.const #b01001))
;params ;params
(i64.const nil_array_value) (local.get '$result)
;func_idx
(i32.wrap_i64 (i64.shr_u (local.get '$it) (i64.const 35)))
))
(br '$l)
)
)
; ('write fd "data" <cont (num_written error_code)>)
(_if '$is_write
(i64.eq (i64.const write_val) (local.get '$monad_name))
(then
; <string_size32><string_ptr29>011
(local.set '$str (i64.load 16 (local.get '$ptr)))
; iov <32bit len><32bit addr> + <32bit num written>
(i32.store 0 (i32.const iov_tmp) (i32.wrap_i64 (i64.and (local.get '$str) (i64.const #xFFFFFFF8))))
(i32.store 4 (i32.const iov_tmp) (i32.wrap_i64 (i64.shr_u (local.get '$str) (i64.const 32))))
(local.set '$code (call '$fd_write
(i32.wrap_i64 (i64.shr_u (i64.load 8 (local.get '$ptr)) (i64.const 1))) ;; file descriptor
(i32.const iov_tmp) ;; *iovs
(i32.const 1) ;; iovs_len
(i32.const (+ 8 iov_tmp)) ;; nwritten
))
(local.set '$result (call '$array2_alloc (i64.shl (i64.extend_i32_u (i32.load (i32.const (+ 8 iov_tmp)))) (i64.const 1))
(i64.shl (i64.extend_i32_u (local.get '$code)) (i64.const 1))))
(local.set '$it (i64.load 24 (local.get '$ptr)))
(local.set '$it (call_indirect
;type
k_vau
;table
0
;top_env
(i64.const root_marked_env_val)
; static env
(i64.or (i64.shl (i64.and (local.get '$it) (i64.const #x3FFFFFFC0)) (i64.const 2)) (i64.const #b01001))
;params
(local.get '$result)
;func_idx ;func_idx
(i32.wrap_i64 (i64.shr_u (local.get '$it) (i64.const 35))) (i32.wrap_i64 (i64.shr_u (local.get '$it) (i64.const 35)))
)) ))
@@ -1861,7 +1955,7 @@
(global '$data_end '(mut i32) (i32.const watermark)) (global '$data_end '(mut i32) (i32.const watermark))
datas funcs start datas funcs start
(table '$tab (len funcs) 'funcref) (table '$tab (len funcs) 'funcref)
(apply elem (cons (i32.const 0) (range k_len (+ 1 (len funcs))))) (apply elem (cons (i32.const 0) (range k_len (+ 2 (len funcs)))))
)) ))
(export "memory" '(memory $mem)) (export "memory" '(memory $mem))
(export "_start" '(func $start)) (export "_start" '(func $start))
@@ -2102,8 +2196,14 @@
;(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 "(array ((vau (x) x) exit) 1)"))))
;(output3 (compile (partial_eval (read-string "(array ((vau (x) x) print) \"waa\" (vau () (array ((vau (x) x) exit) 1)))"))))
(output3 (compile (partial_eval (read-string "(array ((vau (x) x) print) \"waa\" (vau e () e))")))) ;(output3 (compile (partial_eval (read-string "(array ((vau (x) x) write) 1 \"waa\" (vau (written code) (array ((vau (x) x) exit) 1)))"))))
;(output3 (compile (partial_eval (read-string "(array ((vau (x) x) write) 1 \"waa\" (vau (written code) written))"))))
;(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) read) 0 10 (vau (data code) data))"))))
;(output3 (compile (partial_eval (read-string "(array ((vau (x) x) print) \"waa\" (vau e () e))"))))
;(output3 (compile (partial_eval (read-string "(array ((vau (x) x) get_line) (vau (input) input))")))) ;(output3 (compile (partial_eval (read-string "(array ((vau (x) x) get_line) (vau (input) input))"))))
;(output3 (compile (partial_eval (read-string "(wrap (vau (x) x))")))) ;(output3 (compile (partial_eval (read-string "(wrap (vau (x) x))"))))