diff --git a/partial_eval.csc b/partial_eval.csc index 60b35e6..ebdf1cd 100644 --- a/partial_eval.csc +++ b/partial_eval.csc @@ -112,6 +112,9 @@ (get-value (lambda (d k) (let ((result (alist-ref k d))) (if (array? result) (idx result 0) (error (print "could not find " k " in " d)))))) + (get-value-or-false (lambda (d k) (let ((result (alist-ref k d))) + (if (array? result) (idx result 0) + false)))) (% modulo) (int? integer?) @@ -1196,7 +1199,7 @@ ; 101 / 0..0 101 ; Combiner - a double of func index and closure (which could just be the env, actually, even if we trim...) - ; |0001 + ; |0001 ; Env ; 0..001001 @@ -1344,7 +1347,7 @@ (_if '$is_comb '(result i32) (i64.eq (i64.const #b0001) (i64.and (i64.const #b1111) (local.get '$to_str_len))) (then - (i32.const 4) + (i32.const 5) ) (else ;; must be int @@ -1478,7 +1481,11 @@ (i64.eq (i64.const #b0001) (i64.and (i64.const #b1111) (local.get '$to_str))) (then (i32.store (local.get '$buf) (i32.const #x626D6F63)) - (i32.const 4) + (i32.store8 (i32.add (local.get '$buf) (i32.const 4)) + (i32.add (i32.const #x30) + (i32.and (i32.const #b11) + (i32.wrap_i64 (i64.shr_u (local.get '$to_str) (i64.const 4)))))) + (i32.const 5) ) (else ;; must be int @@ -1538,31 +1545,73 @@ (i64.and (i64.shr_u (local.get '$it) (i64.const 31)) (i64.const -2)) )))) - (compile_helper (rec-lambda recurse (datasi funcs c) (cond + ((k_vau func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$vau (unreachable))))) + ((k_read-string func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$read-string (unreachable))))) + ((k_println func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$read-string (unreachable))))) + ((k_str func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$str (unreachable))))) + ((k_or func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$or (unreachable))))) + ((k_and func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$and (unreachable))))) + ((k_geq func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$geq (unreachable))))) + ((k_gt func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$gt (unreachable))))) + ((k_leq func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$leq (unreachable))))) + ((k_lt func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$lt (unreachable))))) + ((k_neq func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$neq (unreachable))))) + ((k_eq func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$eq (unreachable))))) + ((k_mod func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$mod (unreachable))))) + ((k_div func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$div (unreachable))))) + ((k_mul func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$mul (unreachable))))) + ((k_add func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$add (unreachable))))) + ((k_sub func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$sub (unreachable))))) + ((k_concat func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$concat (unreachable))))) + ((k_slice func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$slice (unreachable))))) + ((k_idx func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$idx (unreachable))))) + ((k_array func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$array (unreachable))))) + ((k_arrayp func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$arrayp (unreachable))))) + ((k_get-text func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$get-text (unreachable))))) + ((k_str-to-symbol func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$str-to-symbol (unreachable))))) + ((k_bool? func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$bool? (unreachable))))) + ((k_nil? func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$nil? (unreachable))))) + ((k_env? func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$env? (unreachable))))) + ((k_combiner? func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$combiner? (unreachable))))) + ((k_string? func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$string? (unreachable))))) + ((k_int? func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$int? (unreachable))))) + ((k_symbol? func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$symbol? (unreachable))))) + ((k_cond func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$cond (unreachable))))) + ((k_eval func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$eval (unreachable))))) + ((k_unwrap func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$unwrap (unreachable))))) + ((k_wrap func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$wrap (unreachable))))) + + (get_passthrough (lambda (hash datasi funcs memo) (let ((r (get-value-or-false memo hash))) + (if r (array r datasi funcs memo) #f)))) + + (compile_value (rec-lambda recurse (datasi funcs memo c) (cond ((val? c) (let ((v (.val c))) - (cond ((int? v) (array (<< v 1) datasi funcs)) - ((= true v) (array #b00111101 datasi funcs)) - ((= false v) (array #b00011101 datasi funcs)) + (cond ((int? v) (array (<< v 1) datasi funcs memo)) + ((= true v) (array #b00111101 datasi funcs memo)) + ((= false v) (array #b00011101 datasi funcs memo)) ((str? v) (dlet (((c_loc c_len datasi) (alloc_data v datasi)) (a (bor (<< c_len 32) c_loc #b011)) - ) (array a datasi funcs))) + ) (array a datasi funcs memo))) (true (error (str "Can't compile value " v " right now")))))) - ((marked_symbol? c) (cond ((.marked_symbol_is_val c) (dlet (((c_loc c_len datasi) (alloc_data (symbol->string (.marked_symbol_value c)) datasi)) - (a (bor (<< c_len 32) c_loc #b111)) - ) (array a datasi funcs))) + ((marked_symbol? c) (cond ((.marked_symbol_is_val c) (or (get_passthrough (.hash c) datasi funcs memo) (dlet (((c_loc c_len datasi) (alloc_data (symbol->string (.marked_symbol_value c)) datasi)) + (result (bor (<< c_len 32) c_loc #b111)) + (memo (put memo (.hash c) result)) + ) (array result datasi funcs memo)))) (true (error (str "can't compile non-val symbols " c " right now"))))) - ((marked_array? c) (if (.marked_array_is_val c) (let ((actual_len (len (.marked_array_values c)))) - (if (= 0 actual_len) (array nil_array_value datasi funcs) - (dlet (((comp_values datasi funcs) (foldr (dlambda (x (a datasi funcs)) (dlet (((v datasi funcs) (recurse datasi funcs x))) - (array (cons v a) datasi funcs))) (array (array) datasi funcs) (.marked_array_values c))) - ((c_loc c_len datasi) (alloc_data (apply concat (map i64_le_hexify comp_values)) datasi))) - (array (bor (<< actual_len 32) c_loc #b101) datasi funcs)))) + ((marked_array? c) (if (.marked_array_is_val c) (or (get_passthrough (.hash c) datasi funcs memo) (let ((actual_len (len (.marked_array_values c)))) + (if (= 0 actual_len) (array nil_array_value datasi funcs memo) + (dlet (((comp_values datasi funcs memo) (foldr (dlambda (x (a datasi funcs memo)) (dlet (((v datasi funcs memo) (recurse datasi funcs memo x))) + (array (cons v a) datasi funcs memo))) (array (array) datasi funcs memo) (.marked_array_values c))) + ((c_loc c_len datasi) (alloc_data (apply concat (map i64_le_hexify comp_values)) datasi)) + (result (bor (<< actual_len 32) c_loc #b101)) + (memo (put memo (.hash c) result)) + ) (array result datasi funcs memo))))) (error (str "can't compile call right now " c)))) - ((marked_env? c) (dlet ((e (.env_marked c)) - ((kvs vvs datasi funcs) (foldr (dlambda ((k v) (ka va datasi funcs)) (dlet (((kv datasi funcs) (recurse datasi funcs (marked_symbol true k))) - ((vv datasi funcs) (recurse datasi funcs v))) - (array (cons kv ka) (cons vv va) datasi funcs))) (array (array) (array) datasi funcs) (slice e 0 -2))) + ((marked_env? c) (or (get_passthrough (.hash c) datasi funcs memo) (dlet ((e (.env_marked c)) + ((kvs vvs datasi funcs memo) (foldr (dlambda ((k v) (ka va datasi funcs memo)) (dlet (((kv datasi funcs memo) (recurse datasi funcs memo (marked_symbol true k))) + ((vv datasi funcs memo) (recurse datasi funcs memo v))) + (array (cons kv ka) (cons vv va) datasi funcs memo))) (array (array) (array) datasi funcs memo) (slice e 0 -2))) (u (idx e -1)) (_ (print "comp values are " kvs " and " vvs)) ((kvs_array datasi) (if (= 0 (len kvs)) (array nil_array_value datasi) @@ -1571,29 +1620,78 @@ ((vvs_array datasi) (if (= 0 (len vvs)) (array nil_array_value datasi) (dlet (((vvs_loc vvs_len datasi) (alloc_data (apply concat (map i64_le_hexify vvs)) datasi))) (array (bor (<< (len vvs) 32) vvs_loc #b101) datasi)))) - ((uv datasi funcs) (mif u (begin (print "turns out " u " did exist") (recurse datasi funcs (idx e -1))) - (begin (print "turns out " u " didn't exist, returning nil_array value") (array nil_array_value datasi funcs)))) + ((uv datasi funcs memo) (mif u (begin (print "turns out " u " did exist") (recurse datasi funcs memo (idx e -1))) + (begin (print "turns out " u " didn't exist, returning nil_array value") (array nil_array_value datasi funcs memo)))) (all_hex (map i64_le_hexify (array kvs_array vvs_array uv))) (_ (print "all_hex " all_hex)) - ((c_loc c_len datasi) (alloc_data (apply concat all_hex) datasi))) - (array (bor (<< c_loc 5) #b01001) datasi funcs))) - ((prim_comb? c) (cond ((= 'len_fake_real (.prim_comb_sym c)) (array (bor 1 (<< k_len 33)) datasi funcs)) + ((c_loc c_len datasi) (alloc_data (apply concat all_hex) datasi)) + (result (bor (<< c_loc 5) #b01001)) + (memo (put memo (.hash c) result)) + ) (array result datasi funcs memo)))) + ((prim_comb? c) (cond ((= 'vau_fake_real (.prim_comb_sym c)) (array (bor (<< k_vau 35) (<< 0 4) #b0001) datasi funcs memo)) + ((= 'cond_fake_real (.prim_comb_sym c)) (array (bor (<< k_cond 35) (<< 0 4) #b0001) datasi funcs memo)) + ((= 'or_fake_real (.prim_comb_sym c)) (array (bor (<< k_or 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)) + ((= '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)) + ((= '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_gt 35) (<< 1 4) #b0001) datasi funcs memo)) + ((= '<= (.prim_comb_sym c)) (array (bor (<< k_leq 35) (<< 1 4) #b0001) datasi funcs memo)) + ((= '< (.prim_comb_sym c)) (array (bor (<< k_lt 35) (<< 1 4) #b0001) datasi funcs memo)) + ((= '!= (.prim_comb_sym c)) (array (bor (<< k_neq 35) (<< 1 4) #b0001) datasi funcs memo)) + ((= '= (.prim_comb_sym c)) (array (bor (<< k_eq 35) (<< 1 4) #b0001) datasi funcs memo)) + ((= '% (.prim_comb_sym c)) (array (bor (<< k_mod 35) (<< 1 4) #b0001) datasi funcs memo)) + ((= '/ (.prim_comb_sym c)) (array (bor (<< k_div 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_sub 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)) + ((= 'idx_fake_real (.prim_comb_sym c)) (array (bor (<< k_idx 35) (<< 1 4) #b0001) datasi funcs memo)) + ((= 'array_fake_real (.prim_comb_sym c)) (array (bor (<< k_array 35) (<< 1 4) #b0001) datasi funcs memo)) + ((= 'arrayp_fake_real (.prim_comb_sym c)) (array (bor (<< k_arrayp 35) (<< 1 4) #b0001) datasi funcs memo)) + ((= 'get-text (.prim_comb_sym c)) (array (bor (<< k_get-text 35) (<< 1 4) #b0001) datasi funcs memo)) + ((= 'str-to-symbol (.prim_comb_sym c)) (array (bor (<< k_str-to-symbol 35) (<< 1 4) #b0001) datasi funcs memo)) + ((= 'bool? (.prim_comb_sym c)) (array (bor (<< k_bool? 35) (<< 1 4) #b0001) datasi funcs memo)) + ((= 'nil? (.prim_comb_sym c)) (array (bor (<< k_nil? 35) (<< 1 4) #b0001) datasi funcs memo)) + ((= 'envp_fake_real (.prim_comb_sym c)) (array (bor (<< k_env? 35) (<< 1 4) #b0001) datasi funcs memo)) + ((= 'combinerp_fake_real (.prim_comb_sym c)) (array (bor (<< k_combiner? 35) (<< 1 4) #b0001) datasi funcs memo)) + ((= 'string? (.prim_comb_sym c)) (array (bor (<< k_string? 35) (<< 1 4) #b0001) datasi funcs memo)) + ((= 'int? (.prim_comb_sym c)) (array (bor (<< k_int? 35) (<< 1 4) #b0001) datasi funcs memo)) + ((= 'symbol? (.prim_comb_sym c)) (array (bor (<< k_symbol? 35) (<< 1 4) #b0001) datasi funcs memo)) + ((= 'eval_fake_real (.prim_comb_sym c)) (array (bor (<< k_eval 35) (<< 1 4) #b0001) datasi funcs memo)) + ((= 'unwrap_fake_real (.prim_comb_sym c)) (array (bor (<< k_unwrap 35) (<< 1 4) #b0001) datasi funcs memo)) + ((= 'wrap_fake_real (.prim_comb_sym c)) (array (bor (<< k_wrap 35) (<< 1 4) #b0001) datasi funcs memo)) (true (error (str "Can't compile prim comb " (.prim_comb_sym c) " right now"))))) - ((comb? c) (dlet ( - + ((comb? c) (or (get_passthrough (.hash c) datasi funcs memo) (dlet ( + ((wrap_level de? se variadic params body) (.comb c)) + ((our_env_val datasi funcs memo) (recurse datasi funcs memo se)) + ; |0001 + ; e29><2><4> = 6 + ; 0..0<3 bits>01001 + ; e29><3><5> = 8 + ; 0..001001 + ; x+2+4 = y + 3 + 5 + ; x + 6 = y + 8 + ; x - 2 = y + (located_env_ptr (band #x7FFFFFFC0 (>> our_env_val 2))) (our_func (func '$len '(param $it i64) '(result i64) (i64.and (i64.shr_u (local.get '$it) (i64.const 31)) (i64.const -2)) )) (funcs (concat funcs our_func)) (our_func_idx (len funcs)) ; also insert env here - (result (bor 1 (<< our_func_idx 33))) - ) (array result datasi funcs))) + (result (bor (<< our_func_idx 35) located_env_ptr (<< wrap_level 4) #b0001)) + (memo (put memo (.hash c) result)) + ) (array result datasi funcs memo)))) (true (error (str "can't compile " c " right now"))) ))) (_ (println "compiling partial evaled " (str_strip marked_code))) - ((compiled_value_ptr datasi funcs) (compile_helper datasi funcs marked_code)) + (memo empty_dict) + ((compiled_value_ptr datasi funcs memo) (compile_value datasi funcs memo marked_code)) (_ (println "compiled it to " compiled_value_ptr)) (start (func '$start (call '$print (i64.const compiled_value_ptr)) @@ -1831,11 +1929,15 @@ ; (export "_start" '(func $start)) ;))) ;(output3 (compile (partial_eval (read-string "(array 1 (array ((vau (x) x) a) (array \"asdf\")) 2)")))) + (output3 (compile (partial_eval (read-string "(array 1 (array 1 2 3 4) 2 (array 1 2 3 4))")))) ;(output3 (compile (partial_eval (read-string "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)))) 1 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) (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 "(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 "vau")))) ;(output3 (compile (partial_eval (read-string "(array len 3 len)")))) ;(output3 (compile (partial_eval (read-string "(+ 1 1337 (+ 1 2))")))) ;(output3 (compile (partial_eval (read-string "\"hello world\""))))