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

I belive I fixed the bug revealed by the let definition - it was a similar thing where <comb>s were counted as values even if there were fake envs inside, and then thouse fake envs could be moved inside another env_stack and then later resolve to a wrong env, or at lest I think that's what was happening. The let test takes too long to run now - I killed it at 20 minutes and 48GB of RAM taken. Given that, it's now time to move on towards optimization

Browse Source
This commit is contained in:
Nathan Braswell
2022-01-07 22:08:29 -05:00
parent b559bfdf90
commit 6ef60c4cc6
2 changed files with 48 additions and 27 deletions
Download Patch File Download Diff File Expand all files Collapse all files

58
partial_eval.csc
View File

@@ -180,10 +180,12 @@
(.marked_symbol_is_val (lambda (x) (idx x 2))) (.marked_symbol_is_val (lambda (x) (idx x 2)))
(.marked_symbol_value (lambda (x) (idx x 3))) (.marked_symbol_value (lambda (x) (idx x 3)))
(.comb (lambda (x) (slice x 2 -1))) (.comb (lambda (x) (slice x 2 -1)))
(.comb_env (lambda (x) (idx x 4)))
(.prim_comb_sym (lambda (x) (idx x 3))) (.prim_comb_sym (lambda (x) (idx x 3)))
(.prim_comb (lambda (x) (idx x 2))) (.prim_comb (lambda (x) (idx x 2)))
(.marked_env (lambda (x) (slice x 2 -1))) (.marked_env (lambda (x) (slice x 2 -1)))
(.marked_env_idx (lambda (x) (idx x 3))) (.marked_env_idx (lambda (x) (idx x 3)))
(.marked_env_upper (lambda (x) (idx (idx x 4) -1)))
(.env_marked (lambda (x) (idx x 4))) (.env_marked (lambda (x) (idx x 4)))
(.hash (lambda (x) (idx x 1))) (.hash (lambda (x) (idx x 1)))
@@ -224,20 +226,28 @@
(later? (rec-lambda recurse (x) (or (and (marked_array? x) (or (= false (.marked_array_is_val x)) (foldl (lambda (a x) (or a (recurse x))) false (.marked_array_values x)))) (later_head? (rec-lambda recurse (x) (or (and (marked_array? x) (or (= false (.marked_array_is_val x)) (foldl (lambda (a x) (or a (recurse x))) false (.marked_array_values x))))
(and (marked_symbol? x) (= false (.marked_symbol_is_val x))) (and (marked_symbol? x) (= false (.marked_symbol_is_val x)))
))) )))
(total_value? (rec-lambda recurse_total_value? (x) (begin (print "checking if " x " is total_value") (cond ((and (marked_array? x) (= false (.marked_array_is_val x))) false)
((and (marked_array? x) (= true (.marked_array_is_val x))) ((rec-lambda recurse-list (a i) (cond ((= i (len a)) true) ((not (recurse_total_value? (idx a i))) false) (true (recurse-list a (+ i 1))))) (.marked_array_values x) 0))
((marked_symbol? x) (.marked_symbol_is_val x))
((marked_env? x) (and (marked_env_real? x) (or (= nil (.marked_env_upper x)) (recurse_total_value? (.marked_env_upper x)))))
((comb? x) (or (= nil (.comb_env x)) (recurse_total_value? (.comb_env x))))
((prim_comb? x) true)
((val? x) true)
(true (error "what is this?"))))))
(is_all_values (lambda (evaled_params) (foldl (lambda (a x) (and a (total_value? x))) true evaled_params)))
;(is_all_head_values (lambda (evaled_params) (foldl (lambda (a x) (and a (not (later_head? x)))) true evaled_params)))
(false? (lambda (x) (cond ((and (marked_array? x) (= false (.marked_array_is_val x))) (error "got a later marked_array passed to false? " x)) (false? (lambda (x) (cond ((and (marked_array? x) (= false (.marked_array_is_val x))) (error "got a later marked_array passed to false? " x))
((and (marked_symbol? x) (= false (.marked_symbol_is_val x))) (error "got a later marked_symbol passed to false? " x)) ((and (marked_symbol? x) (= false (.marked_symbol_is_val x))) (error "got a later marked_symbol passed to false? " x))
((val? x) (not (.val x))) ((val? x) (not (.val x)))
(true false)))) (true false))))
(env-lookup-helper (rec-lambda recurse (dict key i fail success) (cond ((and (= i (- (len dict) 1)) (= nil (idx dict i))) (fail))
((= i (- (len dict) 1)) (recurse (.env_marked (idx dict i)) key 0 fail success))
((= key (idx (idx dict i) 0)) (success (idx (idx dict i) 1)))
(true (recurse dict key (+ i 1) fail success)))))
(env-lookup (lambda (env key) (env-lookup-helper (.env_marked env) key 0 (lambda () (error key " not found in env " (.env_marked env))) (lambda (x) x))))
(mark (rec-lambda recurse (x) (cond ((env? x) (error "called mark with an env " x)) (mark (rec-lambda recurse (x) (cond ((env? x) (error "called mark with an env " x))
((combiner? x) (error "called mark with a combiner " x)) ((combiner? x) (error "called mark with a combiner " x))
@@ -270,6 +280,12 @@
) (idx args -1))))))) ) (idx args -1)))))))
(print_strip (lambda args (println (apply str_strip args)))) (print_strip (lambda args (println (apply str_strip args))))
(env-lookup-helper (rec-lambda recurse (dict key i fail success) (cond ((and (= i (- (len dict) 1)) (= nil (idx dict i))) (fail))
((= i (- (len dict) 1)) (recurse (.env_marked (idx dict i)) key 0 fail success))
((= key (idx (idx dict i) 0)) (success (idx (idx dict i) 1)))
(true (recurse dict key (+ i 1) fail success)))))
(env-lookup (lambda (env key) (env-lookup-helper (.env_marked env) key 0 (lambda () (error (print_strip key " not found in env " env))) (lambda (x) x))))
(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))))
@@ -353,8 +369,6 @@
(true (error (str "Something odd passed to contains_symbols " x))) (true (error (str "Something odd passed to contains_symbols " x)))
))) )))
(is_all_values (lambda (evaled_params) (foldl (lambda (a x) (and a (not (later? x)))) true evaled_params)))
; * TODO: allowing envs to be shead mif they're not used. ; * TODO: allowing envs to be shead mif they're not used.
(shift_envs (rec-lambda recurse (cutoff d x) (cond (shift_envs (rec-lambda recurse (cutoff d x) (cond
((val? x) (array true x)) ((val? x) (array true x))
@@ -389,7 +403,8 @@
(cond ((val? x) x) (cond ((val? x) x)
((marked_env? x) (let ((dbi (.marked_env_idx x))) ((marked_env? x) (let ((dbi (.marked_env_idx x)))
; compiler calls with empty env stack ; compiler calls with empty env stack
(mif (and dbi (>= dbi 0) (!= 0 (len env_stack))) (let* ((new_env (idx env_stack dbi)) (mif (and dbi (>= dbi 0) (!= 0 (len env_stack))) (let* (
(new_env (idx env_stack dbi))
(ndbi (.marked_env_idx new_env)) (ndbi (.marked_env_idx new_env))
(_ (mif (!= 0 ndbi) (error (str_strip "new env with non-zero dbis " x)))) (_ (mif (!= 0 ndbi) (error (str_strip "new env with non-zero dbis " x))))
(_ (println (str_strip "replacing " x) (str_strip " with " new_env))) (_ (println (str_strip "replacing " x) (str_strip " with " new_env)))
@@ -449,11 +464,11 @@
(tmp_func_result (recurse body inner_env (cons inner_env env_stack) (+ 1 indent))) (tmp_func_result (recurse body inner_env (cons inner_env env_stack) (+ 1 indent)))
(_ (print_strip (indent_str indent) "evaled result of function call is " tmp_func_result)) (_ (print_strip (indent_str indent) "evaled result of function call is " tmp_func_result))
((able_to_sub_env func_result) (decrement_envs tmp_func_result)) ((able_to_sub_env func_result) (decrement_envs tmp_func_result))
(result_is_later (later? func_result)) (result_is_later (later_head? func_result))
(_ (print_strip (indent_str indent) "success? " able_to_sub_env " decremented result of function call is " tmp_func_result)) (_ (print_strip (indent_str indent) "success? " able_to_sub_env " decremented result of function call is " tmp_func_result))
(stop_envs ((rec-lambda ser (a e) (mif e (ser (cons e a) (idx (.env_marked e) -1)) a)) (array) se)) (stop_envs ((rec-lambda ser (a e) (mif e (ser (cons e a) (idx (.env_marked e) -1)) a)) (array) se))
(result_closes_over (contains_symbols stop_envs (concat params (mif de? (array de?) (array))) func_result)) (result_closes_over (contains_symbols stop_envs (concat params (mif de? (array de?) (array))) func_result))
(_ (println (indent_str indent) "func call able_to_sub: " able_to_sub_env " result is later? " result_is_later " and result_closes_over " result_closes_over)) (_ (println (indent_str indent) "func call able_to_sub: " able_to_sub_env " result is later_head? " result_is_later " and result_closes_over " result_closes_over))
; This could be improved to a specialized version of the function ; This could be improved to a specialized version of the function
; just by re-wrapping it in a comb instead mif we wanted. ; just by re-wrapping it in a comb instead mif we wanted.
; Something to think about! ; Something to think about!
@@ -462,7 +477,7 @@
literal_params))) literal_params)))
func_result)) func_result))
) result)))) ) result))))
((later? comb) (marked_array false (cons comb literal_params))) ((later_head? comb) (marked_array false (cons comb literal_params)))
(true (error (str "impossible comb value " x)))))))) (true (error (str "impossible comb value " x))))))))
(true (error (str "impossible partial_eval value " x))) (true (error (str "impossible partial_eval value " x)))
) )
@@ -484,6 +499,7 @@
;_ (println "partial_evaling params in need_params_val_lambda for " f_sym " is " params) ;_ (println "partial_evaling params in need_params_val_lambda for " f_sym " is " params)
(evaled_params (map (lambda (p) (partial_eval_helper p de env_stack (+ 1 indent))) params)) (evaled_params (map (lambda (p) (partial_eval_helper p de env_stack (+ 1 indent))) params))
) )
; TODO: Should this be is_all_head_values?
(mif (is_all_values evaled_params) (mark (apply actual_function (map strip evaled_params))) (mif (is_all_values evaled_params) (mark (apply actual_function (map strip evaled_params)))
(marked_array false (cons (marked_prim_comb recurse f_sym) evaled_params)))))) (marked_array false (cons (marked_prim_comb recurse f_sym) evaled_params))))))
) (array f_sym (marked_prim_comb handler f_sym))))) ) (array f_sym (marked_prim_comb handler f_sym)))))
@@ -560,7 +576,7 @@
((rec-lambda recurse_inner (i so_far) ((rec-lambda recurse_inner (i so_far)
(let* ((evaled_cond (partial_eval_helper (idx params i) de env_stack (+ 1 indent))) (let* ((evaled_cond (partial_eval_helper (idx params i) de env_stack (+ 1 indent)))
(_ (print (indent_str indent) "in cond cond " (idx params i) " evaluated to " evaled_cond))) (_ (print (indent_str indent) "in cond cond " (idx params i) " evaluated to " evaled_cond)))
(cond ((later? evaled_cond) (recurse_inner (+ 2 i) (concat so_far (array evaled_cond (cond ((later_head? evaled_cond) (recurse_inner (+ 2 i) (concat so_far (array evaled_cond
(partial_eval_helper (idx params (+ i 1)) de env_stack (+ 1 indent)))))) (partial_eval_helper (idx params (+ i 1)) de env_stack (+ 1 indent))))))
((false? evaled_cond) (recurse_inner (+ 2 i) so_far)) ((false? evaled_cond) (recurse_inner (+ 2 i) so_far))
((= (len params) i) (marked_array false (cons (marked_prim_comb recurse 'cond) so_far))) ((= (len params) i) (marked_array false (cons (marked_prim_comb recurse 'cond) so_far)))
@@ -578,13 +594,13 @@
(array 'combiner? (marked_prim_comb (parameters_evaled_proxy nil (dlambda (recurse de env_stack (evaled_param) indent) (array 'combiner? (marked_prim_comb (parameters_evaled_proxy nil (dlambda (recurse de env_stack (evaled_param) indent)
(cond ((comb? evaled_param) (marked_val true)) (cond ((comb? evaled_param) (marked_val true))
((prim_comb? evaled_param) (marked_val true)) ((prim_comb? evaled_param) (marked_val true))
((later? evaled_param) (marked_array false (array (marked_prim_comb recurse 'combiner?) evaled_param))) ((later_head? evaled_param) (marked_array false (array (marked_prim_comb recurse 'combiner?) evaled_param)))
(true (marked_val false)) (true (marked_val false))
) )
)) 'combiner?)) )) 'combiner?))
(array 'env? (marked_prim_comb (parameters_evaled_proxy nil (dlambda (recurse de env_stack (evaled_param) indent) (array 'env? (marked_prim_comb (parameters_evaled_proxy nil (dlambda (recurse de env_stack (evaled_param) indent)
(cond ((marked_env? evaled_param) (marked_val true)) (cond ((marked_env? evaled_param) (marked_val true))
((later? evaled_param) (marked_array false (array (marked_prim_comb recurse 'env?) evaled_param))) ((later_head? evaled_param) (marked_array false (array (marked_prim_comb recurse 'env?) evaled_param)))
(true (marked_val false)) (true (marked_val false))
) )
)) 'env?)) )) 'env?))
@@ -595,7 +611,7 @@
(array 'array? (marked_prim_comb (parameters_evaled_proxy nil (dlambda (recurse de env_stack (evaled_param) indent) (array 'array? (marked_prim_comb (parameters_evaled_proxy nil (dlambda (recurse de env_stack (evaled_param) indent)
(cond (cond
((later? evaled_param) (marked_array false (array (marked_prim_comb recurse 'array?) evaled_param))) ((later_head? evaled_param) (marked_array false (array (marked_prim_comb recurse 'array?) evaled_param)))
((marked_array? evaled_param) (marked_val true)) ((marked_array? evaled_param) (marked_val true))
(true (marked_val false)) (true (marked_val false))
) )
@@ -609,7 +625,7 @@
(marked_array false (cons (marked_prim_comb recurse 'array) evaled_params))) (marked_array false (cons (marked_prim_comb recurse 'array) evaled_params)))
)) 'array)) )) 'array))
(array 'len (marked_prim_comb (parameters_evaled_proxy nil (dlambda (recurse de env_stack (evaled_param) indent) (array 'len (marked_prim_comb (parameters_evaled_proxy nil (dlambda (recurse de env_stack (evaled_param) indent)
(cond ((later? evaled_param) (marked_array false (array (marked_prim_comb recurse 'len) evaled_param))) (cond ((later_head? evaled_param) (marked_array false (array (marked_prim_comb recurse 'len) evaled_param)))
((marked_array? evaled_param) (marked_val (len (.marked_array_values evaled_param)))) ((marked_array? evaled_param) (marked_val (len (.marked_array_values evaled_param))))
(true (error (str "bad type to len " evaled_param))) (true (error (str "bad type to len " evaled_param)))
) )
@@ -3114,7 +3130,7 @@
((and (= 1 (len params)) variadic) (dlet ( ((and (= 1 (len params)) variadic) (dlet (
((params_vec datasi funcs memo) (recurse-value datasi funcs memo false ((params_vec datasi funcs memo) (recurse-value datasi funcs memo false
(marked_array true (array (marked_symbol true (idx params 0)))))) (marked_array true (array (marked_symbol true (idx params 0))))))
) (array (marked_env false 0 (concat (array (array (idx params 0) (marked_symbol false (idx params 0)))) (array se))) ) (array (marked_env false 0 (concat (array (array (idx params 0) (marked_symbol false (idx params 0)))) (array (increment_envs se)))) ; TODO: This should probs be a call to make_tmp_inner_env, but will need combination with below
(local.set '$s_env (call '$env_alloc (i64.const params_vec) (local.set '$s_env (call '$env_alloc (i64.const params_vec)
(call '$array1_alloc (local.get '$params)) (call '$array1_alloc (local.get '$params))
(local.get '$s_env))) (local.get '$s_env)))
@@ -3123,7 +3139,7 @@
(true (dlet ( (true (dlet (
((params_vec datasi funcs memo) (recurse-value datasi funcs memo false ((params_vec datasi funcs memo) (recurse-value datasi funcs memo false
(marked_array true (map (lambda (k) (marked_symbol true k)) params)))) (marked_array true (map (lambda (k) (marked_symbol true k)) params))))
(new_env (marked_env false 0 (concat (map (lambda (k) (array k (marked_symbol false k))) params) (array se)))) (new_env (marked_env false 0 (concat (map (lambda (k) (array k (marked_symbol false k))) params) (array (increment_envs se)))))
(params_code (if variadic (concat (params_code (if variadic (concat
(local.set '$param_ptr (i32.wrap_i64 (i64.and (i64.const -8) (local.get '$params)))) (local.set '$param_ptr (i32.wrap_i64 (i64.and (i64.const -8) (local.get '$params))))
(local.set '$tmp_ptr (call '$malloc (i32.const (* 8 (len params))))) (local.set '$tmp_ptr (call '$malloc (i32.const (* 8 (len params)))))

17
to_compile.kp
View File

@@ -8,27 +8,32 @@
(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 (f p) (eval (cons (unwrap f) p) (current-env))) (let1 lapply (lambda (f p) (eval (cons (unwrap f) p) (current-env)))
;(let1 vapply (lambda (f p ede) (eval (cons f p) ede)) (let1 vapply (lambda (f p ede) (eval (cons f p) ede))
(let1 Y (lambda (f) (let1 Y (lambda (f)
((lambda (x) (x x)) ((lambda (x1) (x1 x1))
(lambda (x) (f (lambda (& y) (lapply (x x) y)))))) (lambda (x2) (f (lambda (& y) (lapply (x2 x2) y))))))
(let1 vY (lambda (f)
((lambda (x3) (x3 x3))
(lambda (x4) (f (vau de (& y) (vapply (x4 x4) y de))))))
;(let1 let (vY (lambda (recurse) (vau de (vs b) (cond (= (len vs) 0) (eval b de)
; true (vapply let1 (array (idx vs 0) (idx vs 1) (array recurse (slice vs 2 -1) b)) de)))))
(array 'open 3 "test_self_out" (lambda (fd code) (array 'open 3 "test_self_out" (lambda (fd code)
(array 'write fd "waab" (lambda (written code) (array 'write fd "wabcde" (lambda (written code)
(array 'exit written))))) (array 'exit written)))))
; end of all lets ; end of all lets
) )
;) ;)
)))) ))))))
; impl of let1 ; impl of let1
; this would be the macro style version (((;)) (vau de (s v b) (eval (array (array wrap (array vau (array s) b)) v) de))) ; this would be the macro style version (((;)) (vau de (s v b) (eval (array (array wrap (array vau (array s) b)) v) de)))
)) (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)))
; impl of quote ; impl of quote
)) (vau (x) x)) )) (vau (x5) x5))