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

check_for_env_id_in_result fixed, I had accidentally left it unimplemented. Bug with envs escaping when they weren't real fixed, and most everything works, but compiling lapply fails now

Browse Source
This commit is contained in:
Nathan Braswell
2022-01-22 00:19:10 -05:00
parent 8a1e92cd70
commit 99926cdb7c
2 changed files with 34 additions and 17 deletions
Download Patch File Download Diff File Expand all files Collapse all files

37
partial_eval.csc
View File

@@ -440,12 +440,27 @@
((marked_env? x) (let ((inner (.env_marked x))) ((marked_env? x) (let ((inner (.env_marked x)))
(cond ((in_array (.marked_env_idx x) stop_envs) false) (cond ((in_array (.marked_env_idx x) stop_envs) false)
((foldl (lambda (a x) (or a (recurse stop_envs symbols (idx x 1)))) false (slice inner 0 -2)) true) ((foldl (lambda (a x) (or a (recurse stop_envs symbols (idx x 1)))) false (slice inner 0 -2)) true)
((idx inner -1) (recurse stop_envs symbols (idx inner -1))) ((!= nil (idx inner -1)) (recurse stop_envs symbols (idx inner -1)))
(true false)))) (true false))))
(true (error (str "Something odd passed to contains_symbols " x))) (true (error (str "Something odd passed to contains_symbols " x)))
))) )))
(check_for_env_id_in_result (rec-lambda check_for_env_id_in_result (env_id tmp_func_result) true)) (check_for_env_id_in_result (rec-lambda check_for_env_id_in_result (env_id x) (cond
((val? x) false)
((marked_symbol? x) false)
((marked_array? x) (foldl (lambda (a x) (or a (check_for_env_id_in_result env_id x))) false (.marked_array_values x)))
((comb? x) (dlet (((wrap_level env_id de? se variadic params body) (.comb x)))
(or (check_for_env_id_in_result env_id se) (check_for_env_id_in_result env_id body))))
((prim_comb? x) false)
((marked_env? x) (let ((inner (.env_marked x)))
(cond ((and (not (marked_env_real? x)) (= env_id (.marked_env_idx x))) true)
((foldl (lambda (a x) (or a (check_for_env_id_in_result env_id (idx x 1))))
false (slice inner 0 -2)) true)
((!= nil (idx inner -1)) (check_for_env_id_in_result env_id (idx inner -1)))
(true false))))
(true (error (str "Something odd passed to check_for_env_id_in_result " x)))
)))
; TODO: instead of returning the later symbols, we could create a new value of a new type ; TODO: instead of returning the later symbols, we could create a new value of a new type
; ['ref de_bruijn_index_of_env index_into_env] or somesuch. Could really simplify ; ['ref de_bruijn_index_of_env index_into_env] or somesuch. Could really simplify
@@ -506,7 +521,6 @@
(_ (println (indent_str indent) "Going to do an array call!")) (_ (println (indent_str indent) "Going to do an array call!"))
(indent (+ 1 indent)) (indent (+ 1 indent))
(_ (print_strip (indent_str indent) "total is " x)) (_ (print_strip (indent_str indent) "total is " x))
(_ (print_strip (indent_str indent) "evaled comb is " comb))
) )
(mif err (array env_counter err nil) (mif err (array env_counter err nil)
(cond ((prim_comb? comb) ((.prim_comb comb) only_head env env_stack env_counter literal_params (+ 1 indent))) (cond ((prim_comb? comb) ((.prim_comb comb) only_head env env_stack env_counter literal_params (+ 1 indent)))
@@ -555,7 +569,7 @@
((env_counter func_err func_result) (partial_eval_helper body only_head inner_env (cons inner_env env_stack) env_counter (+ 1 indent))) ((env_counter func_err func_result) (partial_eval_helper body only_head inner_env (cons inner_env env_stack) env_counter (+ 1 indent)))
) (mif func_err (array env_counter func_err nil) (dlet ( ) (mif func_err (array env_counter func_err nil) (dlet (
(_ (print_strip (indent_str indent) "evaled result of function call is " func_result)) (_ (print_strip (indent_str indent) "evaled result of function call is " func_result))
(able_to_sub_env (check_for_env_id_in_result env_id func_result)) (able_to_sub_env (not (check_for_env_id_in_result env_id func_result)))
(result_is_later (later_head? func_result)) (result_is_later (later_head? func_result))
(_ (print (indent_str indent) "success? " able_to_sub_env)) (_ (print (indent_str indent) "success? " able_to_sub_env))
(stop_envs ((rec-lambda ser (a e) (mif e (ser (cons (.marked_env_idx e) a) (idx (.env_marked e) -1)) a)) (array) se)) (stop_envs ((rec-lambda ser (a e) (mif e (ser (cons (.marked_env_idx e) a) (idx (.env_marked e) -1)) a)) (array) se))
@@ -3087,6 +3101,7 @@
((val err) (lookup_helper (.env_marked env) (.marked_symbol_value c) 0 (local.get '$s_env))) ((val err) (lookup_helper (.env_marked env) (.marked_symbol_value c) 0 (local.get '$s_env)))
(err (mif err (str "got " err ", started searching in " (str_strip env)) err))
(result (mif val (call '$dup val))) (result (mif val (call '$dup val)))
) (array nil result err (array datasi funcs memo env env_counter)))))) ) (array nil result err (array datasi funcs memo env env_counter))))))
((marked_array? c) (if (.marked_array_is_val c) (or (get_passthrough (.hash c) ctx) ((marked_array? c) (if (.marked_array_is_val c) (or (get_passthrough (.hash c) ctx)
@@ -3120,13 +3135,15 @@
(array c (mif er er e) (concat ds (array d))))) (array c (mif er er e) (concat ds (array d)))))
(array env_counter nil (array)) (array env_counter nil (array))
(slice func_param_values 1 -1))) (slice func_param_values 1 -1)))
; TODO: This might fail because we don't have the real env stack, which we *should*!
; In the mean time, if it does, just fall back to the non-more-evaled ones.
(to_code_params (mif err (slice func_param_values 1 -1) evaled_params))
(ctx (array datasi funcs memo env env_counter)) (ctx (array datasi funcs memo env env_counter))
((param_codes err ctx) (mif err (array nil err ctx) ((param_codes err ctx) (foldr (dlambda (x (a err ctx))
(foldr (dlambda (x (a err ctx)) (mif err (array a err ctx)
(mif err (array a err ctx)
(dlet (((val code new_err ctx) (compile-inner ctx x))) (dlet (((val code new_err ctx) (compile-inner ctx x)))
(array (cons (mif code code (i64.const val)) a) (or (mif err err false) new_err) ctx)))) (array (cons (mif code code (i64.const val)) a) (or (mif err err false) new_err) ctx))))
(array (array) nil ctx) evaled_params))) (array (array) nil ctx) to_code_params))
(func_value (idx func_param_values 0)) (func_value (idx func_param_values 0))
((func_val func_code func_err ctx) (compile-inner ctx func_value)) ((func_val func_code func_err ctx) (compile-inner ctx func_value))
;(_ (mif err (error err))) ;(_ (mif err (error err)))
@@ -3206,7 +3223,7 @@
(generate_env_access (dlambda ((datasi funcs memo env env_counter) env_id) ((rec-lambda recurse (code this_env) (generate_env_access (dlambda ((datasi funcs memo env env_counter) env_id) ((rec-lambda recurse (code this_env)
(cond (cond
((= env_id (.marked_env_idx this_env)) (array nil (call '$dup code) nil (array datasi funcs memo env env_counter))) ((= env_id (.marked_env_idx this_env)) (array nil (call '$dup code) nil (array datasi funcs memo env env_counter)))
((= nil (.marked_env_upper this_env)) (array nil nil "bad env" (array datasi funcs memo env env_counter))) ((= nil (.marked_env_upper this_env)) (array nil nil (str "bad env, upper is nil and we haven't found " env_id ", maxing out at " (str_strip this_env)) (array datasi funcs memo env env_counter)))
(true (recurse (i64.load 16 (i32.wrap_i64 (i64.shr_u code (i64.const 5)))) (true (recurse (i64.load 16 (i32.wrap_i64 (i64.shr_u code (i64.const 5))))
(.marked_env_upper this_env))) (.marked_env_upper this_env)))
) )
@@ -3390,7 +3407,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
) (mif env_val (array (bor (band #x7FFFFFFC0 (>> env_val 2)) func_value) nil (or func_err env_err) ctx) ) (mif env_val (array (bor (band #x7FFFFFFC0 (>> env_val 2)) func_value) nil (mif func_err func_err env_err) ctx)
(array nil (i64.or (i64.const func_value) (i64.and (i64.const #x7FFFFFFC0) (i64.shr_u env_code (i64.const 2)))) (mif func_err func_err env_err) ctx)) (array nil (i64.or (i64.const func_value) (i64.and (i64.const #x7FFFFFFC0) (i64.shr_u env_code (i64.const 2)))) (mif func_err func_err env_err) ctx))
)) ))

14
to_compile.kp
View File

@@ -7,11 +7,11 @@
(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 (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 (x1) (x1 x1)) ; ((lambda (x1) (x1 x1))
(lambda (x2) (f (lambda (& y) (lapply (x2 x2) y)))))) ; (lambda (x2) (f (lambda (& y) (lapply (x2 x2) y))))))
;(let1 vY (lambda (f) ;(let1 vY (lambda (f)
; ((lambda (x3) (x3 x3)) ; ((lambda (x3) (x3 x3))
; (lambda (x4) (f (vau de (& y) (vapply (x4 x4) y de)))))) ; (lambda (x4) (f (vau de (& y) (vapply (x4 x4) y de))))))
@@ -20,14 +20,14 @@
(array 'open 3 "test_self_out" (lambda (fd code) (array 'open 3 "test_self_out" (lambda (fd code)
(array 'write fd "wabcdefge" (lambda (written code) (array 'write fd "wabcdefgh" (lambda (written code)
(array 'exit written))))) (array 'exit written)))))
;(array 'write 1 "test_self_out2" (vau (written code) 1)) ;(array 'write 1 "test_self_out2" (vau (written code) 1))
; end of all lets ; end of all lets
)))));)) ));)))))
) )
; impl of let1 ; impl of let1