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

Clean up strip, have default memory allocation scale based on constants, added more until the next bug found, map seems not to be partially evaluating properly

Browse Source
This commit is contained in:
Nathan Braswell
2022-01-28 00:26:46 -05:00
parent 90750933fc
commit 315ae20698
2 changed files with 41 additions and 41 deletions
Download Patch File Download Diff File Expand all files Collapse all files

36
partial_eval.csc
View File

@@ -118,7 +118,7 @@
(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))))
(true_print print) (true_print print)
(print (lambda x 0)) ;(print (lambda x 0))
;(true_print print) ;(true_print print)
(println print) (println print)
@@ -349,7 +349,7 @@
) )
) (idx args -1) (array)) 0)))))) ) (idx args -1) (array)) 0))))))
(true_str_strip str_strip) (true_str_strip str_strip)
(str_strip (lambda args 0)) ;(str_strip (lambda args 0))
;(true_str_strip str_strip) ;(true_str_strip str_strip)
(print_strip (lambda args (println (apply str_strip args)))) (print_strip (lambda args (println (apply str_strip args))))
@@ -362,30 +362,15 @@
(strip (let ((helper (rec-lambda recurse (x need_value) (strip (let ((helper (rec-lambda recurse (x need_value)
(cond ((val? x) (.val x)) (cond ((val? x) (.val x))
((marked_array? x) (let ((stripped_values (map (lambda (x) (recurse x need_value)) (.marked_array_values x)))) ((marked_array? x) (let ((stripped_values (map (lambda (x) (recurse x need_value)) (.marked_array_values x))))
(mif (.marked_array_is_val x) (mif need_value (error (str "needed value for this strip but got" x)) (cons array stripped_values)) (mif (.marked_array_is_val x) stripped_values
stripped_values))) (error (str "needed value for this strip but got" x)))))
((marked_symbol? x) (mif (.marked_symbol_is_val x) (mif need_value (error (str "needed value for this strip but got" x)) (array quote (.marked_symbol_value x))) ((marked_symbol? x) (mif (.marked_symbol_is_val x) (mif need_value (error (str "needed value for this strip but got" x)) (array quote (.marked_symbol_value x)))
(.marked_symbol_value x))) (.marked_symbol_value x)))
((comb? x) (dlet (((wrap_level env_id de? se variadic params body) (.comb x)) ((comb? x) (error "got comb for strip, won't work"))
(de_entry (mif de? (array de?) (array)))
(final_params (mif variadic (concat (slice params 0 -2) '& (array (idx params -1))) params))
; Honestly, could trim down the env to match what could be evaluated in the comb
; Also mif this isn't real, lower to a call to vau
(se_env (mif (marked_env_real? se) (recurse se true) nil))
(body_v (recurse body false))
(ve (concat (array vau) de_entry (array final_params) (array body_v)))
(fe ((rec-lambda recurse (x i) (mif (= i 0) x (recurse (array wrap x) (- i 1)))) ve wrap_level))
) (mif se_env (eval fe se_env) fe)))
((prim_comb? x) (idx x 2)) ((prim_comb? x) (idx x 2))
; env emitting doesn't pay attention to real value right now, not sure mif that makes sense ; env emitting doesn't pay attention to real value right now, not sure mif that makes sense
; TODO: properly handle de Bruijn indexed envs ; TODO: properly handle de Bruijn indexed envs
((marked_env? x) (cond ((and (not need_value) (= 0 (.marked_env_idx x))) (array current-env)) ((marked_env? x) (error "got env for strip, won't work"))
(true (let ((_ (mif (not (marked_env_real? x)) (error (str_strip "trying to emit fake env!" x)))))
(upper (idx (.env_marked x) -1))
(upper_env (mif upper (recurse upper true) empty_env))
(just_entries (slice (.env_marked x) 0 -2))
(vdict (map (dlambda ((k v)) (array k (recurse v true))) just_entries))
) (add-dict-to-env upper_env vdict))))
(true (error (str "some other strip? " x))) (true (error (str "some other strip? " x)))
) )
))) (lambda (x) (let* ((_ (print_strip "stripping: " x)) (r (helper x false)) (_ (println "result of strip " r))) r)))) ))) (lambda (x) (let* ((_ (print_strip "stripping: " x)) (r (helper x false)) (_ (println "result of strip " r))) r))))
@@ -1451,7 +1436,6 @@
(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)
(global '$malloc_head '(mut i32) (i32.const 0)) (global '$malloc_head '(mut i32) (i32.const 0))
(global '$phs '(mut i32) (i32.const 0)) (global '$phs '(mut i32) (i32.const 0))
(global '$phl '(mut i32) (i32.const 0)) (global '$phl '(mut i32) (i32.const 0))
@@ -3685,6 +3669,7 @@
datas funcs start datas funcs start
(table '$tab (len funcs) 'funcref) (table '$tab (len funcs) 'funcref)
(apply elem (cons (i32.const 0) (range dyn_start (+ num_pre_functions (len funcs))))) (apply elem (cons (i32.const 0) (range dyn_start (+ num_pre_functions (len funcs)))))
(memory '$mem (+ 1 (>> watermark 16)))
)) ))
(export "memory" '(memory $mem)) (export "memory" '(memory $mem))
(export "_start" '(func $start)) (export "_start" '(func $start))
@@ -3767,6 +3752,11 @@
(print (run_partial_eval_test "((wrap (vau (let1) (let1 a 12 (wrap (vau (x) (+ x a 1)))))) (vau de (s v b) (eval (array (array vau (array s) b) (eval v de)) de)))")) (print (run_partial_eval_test "((wrap (vau (let1) (let1 a 12 (wrap (vau (x) (+ x a 1)))))) (vau de (s v b) (eval (array (array vau (array s) b) (eval v de)) de)))"))
(print (run_partial_eval_test "((wrap (vau (let1) (let1 a 12 (wrap (vau (x) (let1 y (+ a 1) (+ y x a))))))) (vau de (s v b) (eval (array (array vau (array s) b) (eval v de)) de)))")) (print (run_partial_eval_test "((wrap (vau (let1) (let1 a 12 (wrap (vau (x) (let1 y (+ a 1) (+ y x a))))))) (vau de (s v b) (eval (array (array vau (array s) b) (eval v de)) de)))"))
(print "\n\nnil test\n")
(print (run_partial_eval_test "nil"))
(print (run_partial_eval_test "(nil? 1)"))
(print (run_partial_eval_test "(nil? nil)"))
(print "\n\nlet 4.3\n\n") (print "\n\nlet 4.3\n\n")
(print (run_partial_eval_test "((wrap (vau (let1) (print (run_partial_eval_test "((wrap (vau (let1)
(let1 a 12 (wrap (vau (x) (let1 y (+ a 1) (+ y x a)))) (let1 a 12 (wrap (vau (x) (let1 y (+ a 1) (+ y x a))))
@@ -4004,6 +3994,8 @@
true 1 )) written))) true 1 )) written)))
))) (vau de (s v b) (eval (array (array vau (array s) b) (eval v de)) de)))")))) ))) (vau de (s v b) (eval (array (array vau (array s) b) (eval v de)) de)))"))))
(_ (write_file "./csc_out.wasm" output3)) (_ (write_file "./csc_out.wasm" output3))
(output3 (compile (partial_eval (read-string "(nil? 1)"))))
(output3 (compile (partial_eval (read-string "(nil? nil)"))))
) (void)) ) (void))
))) )))

46
to_compile.kp
View File

@@ -5,14 +5,14 @@
(let1 lambda (vau se (p b1) (wrap (eval (array vau p b1) se))) (let1 lambda (vau se (p b1) (wrap (eval (array vau p b1) se)))
;(let1 current-env (vau de () de) (let1 current-env (vau de () de)
(let1 cons (lambda (h t) (concat (array h) t)) (let1 cons (lambda (h t) (concat (array h) t))
;(let1 lapply (lambda (f1 p) (eval (cons (unwrap f1) p) (current-env))) (let1 lapply (lambda (f1 p) (eval (cons (unwrap f1) p) (current-env)))
(let1 vapply (lambda (f2 p ede) (eval (cons f2 p) ede)) (let1 vapply (lambda (f2 p ede) (eval (cons f2 p) ede))
;(let1 Y (lambda (f3) (let1 Y (lambda (f3)
; ((lambda (x1) (x1 x1)) ((lambda (x1) (x1 x1))
; (lambda (x2) (f3 (lambda (& y) (lapply (x2 x2) y)))))) (lambda (x2) (f3 (lambda (& y) (lapply (x2 x2) y))))))
(let1 vY (lambda (f) (let1 vY (lambda (f)
((lambda (x3) (x3 x3)) ((lambda (x3) (x3 x3))
@@ -21,25 +21,33 @@
true (vapply let1 (array (idx vs 0) (idx vs 1) (array recurse (slice vs 2 -1) b)) de))))) true (vapply let1 (array (idx vs 0) (idx vs 1) (array recurse (slice vs 2 -1) b)) de)))))
(let ( (let (
;lcompose (lambda (g f) (lambda (& args) (lapply g (array (lapply f args))))) a 1
;monad (array 'write 1 "test_self_out3" (vau (written code) 1)) lcompose (lambda (g f) (lambda (& args) (lapply g (array (lapply f args)))))
a 3 rec-lambda (vau se (n p b) (eval (array Y (array lambda (array n) (array lambda p b))) se))
b 4 if (vau de (con than & else) (cond (eval con de) (eval than de)
(> (len else) 0) (eval (idx else 0) de)
;a 123 true false))
map (lambda (f l)
(let (helper (rec-lambda recurse (f l n i)
(cond (= i (len l)) n
(<= i (- (len l) 4)) (recurse f l (concat n (array
(f (idx l (+ i 0)))
(f (idx l (+ i 1)))
(f (idx l (+ i 2)))
(f (idx l (+ i 3)))
)) (+ i 4))
true (recurse f l (concat n (array (f (idx l i)))) (+ i 1)))))
(helper f l (array) 0)))
test (map (lambda (x) (+ x 1)) (array 1 2))
monad (array 'open 3 "test_self_out" (lambda (fd code) monad (array 'open 3 "test_self_out" (lambda (fd code)
(array 'write fd "wabcdefghijk" (lambda (written code) (array 'write fd "wabcdefghijklmnopqrstuvwx" (lambda (written code)
(array 'exit (+ a b written)))))) (array 'exit (if (= 0 written) 12 14))))))
) )
;(+ b a)
monad monad
;(array 'write 1 "test_self_out2" (vau (written code) 1)) ;(array 'write 1 "test_self_out2" (vau (written code) 14))
) )
; end of all lets ; end of all lets
))));))) )))))))
) )
; impl of let1 ; impl of let1