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

Fixed the recursion! Memo has moved to just being the infinite recursion detector based on body and inner-env

Browse Source
This commit is contained in:
Nathan Braswell
2022-01-27 21:54:15 -05:00
parent 2746e1ca75
commit 90750933fc
2 changed files with 50 additions and 53 deletions
Download Patch File Download Diff File Expand all files Collapse all files

72
partial_eval.csc
View File

@@ -244,14 +244,13 @@
(end_hash (mif end (.hash end) 41)) (end_hash (mif end (.hash end) 41))
) (combine_hash inner_hash end_hash))))) ) (combine_hash inner_hash end_hash)))))
(hash_comb (lambda (wrap_level env_id de? se variadic params body) (hash_comb (lambda (wrap_level env_id de? se variadic params body)
(combine_hash 43 env_id))) (combine_hash 43
;(combine_hash 43 (combine_hash env_id
;(combine_hash env_id (combine_hash (mif de? (hash_symbol true de?) 47)
;(combine_hash (mif de? (hash_symbol true de?) 47) (combine_hash (.hash se)
;(combine_hash (.hash se) (combine_hash (hash_bool variadic)
;(combine_hash (hash_bool variadic) (combine_hash (foldl (lambda (c x) (combine_hash c (hash_symbol true x))) 53 params)
;(combine_hash (foldl (lambda (c x) (combine_hash c (hash_symbol true x))) 53 params) (.hash body)))))))))
;(.hash body)))))))))
(hash_prim_comb (lambda (handler_fun real_or_name) (combine_hash 59 (hash_symbol true real_or_name)))) (hash_prim_comb (lambda (handler_fun real_or_name) (combine_hash 59 (hash_symbol true real_or_name))))
(hash_val (lambda (x) (cond ((bool? x) (hash_bool x)) (hash_val (lambda (x) (cond ((bool? x) (hash_bool x))
((string? x) (hash_string x)) ((string? x) (hash_string x))
@@ -319,6 +318,7 @@
(str_strip (lambda args (apply str (concat (slice args 0 -2) (array (idx ((rec-lambda recurse (x done_envs) (str_strip (lambda args (apply str (concat (slice args 0 -2) (array (idx ((rec-lambda recurse (x done_envs)
(cond ((= nil x) (array "<nil>" done_envs)) (cond ((= nil x) (array "<nil>" done_envs))
((string? x) (array (str "<raw string " x ">") done_envs))
((val? x) (array (str (.val x)) done_envs)) ((val? x) (array (str (.val x)) done_envs))
((marked_array? x) (dlet (((stripped_values done_envs) (foldl (dlambda ((vs de) x) (dlet (((v de) (recurse x de))) (array (concat vs (array v)) de))) ((marked_array? x) (dlet (((stripped_values done_envs) (foldl (dlambda ((vs de) x) (dlet (((v de) (recurse x de))) (array (concat vs (array v)) de)))
(array (array) done_envs) (.marked_array_values x)))) (array (array) done_envs) (.marked_array_values x))))
@@ -464,21 +464,6 @@
) (marked_env false progress_idxs env_id (concat param_entries possible_de_entry (array de)))))) ) (marked_env false progress_idxs env_id (concat param_entries possible_de_entry (array de))))))
(pe_memo_hash (lambda (x only_head progress_now) (combine_hash (.hash x)
(combine_hash (if only_head 67
71)
(if (= true progress_now) 79
(* 83 progress_now))
))))
(get_pe_passthrough (dlambda (hash (env_counter memo) x) (let ((r (get-value-or-false memo hash)))
(cond ((= r false) false)
((= r nil) (array (array env_counter memo) nil x)) ; Nil is for preventing infinite recursion
(true false)
; This is causing bad compiles!
; Temporarily disabled. Somehow is re-introducing fake envs that aren't in scope or somesuch
;(true (array (array env_counter memo) nil r))
))))
(partial_eval_helper (rec-lambda partial_eval_helper (x only_head env env_stack pectx indent) (partial_eval_helper (rec-lambda partial_eval_helper (x only_head env env_stack pectx indent)
(dlet ((for_progress (needed_for_progress x)) (dlet ((for_progress (needed_for_progress x))
(_ (print_strip (indent_str indent) "for_progress " for_progress " for " x)) (_ (print_strip (indent_str indent) "for_progress " for_progress " for " x))
@@ -496,8 +481,6 @@
)) 0))) )) 0)))
) )
(if progress_now (if progress_now
; Man this like doubles the interpret length
(or (get_pe_passthrough (pe_memo_hash x only_head progress_now) pectx x)
(cond ((val? x) (array pectx nil x)) (cond ((val? x) (array pectx nil 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
@@ -601,37 +584,44 @@
(_ (print_strip (indent_str indent) "going to eval " body)) (_ (print_strip (indent_str indent) "going to eval " body))
; prevent infinite recursion ; prevent infinite recursion
(hash (combine_hash (.hash body) (.hash inner_env)))
((env_counter memo) pectx) ((env_counter memo) pectx)
(this_hash (pe_memo_hash x only_head progress_now)) ((pectx func_err func_result rec_stop) (if (!= false (get-value-or-false memo hash)) (array pectx nil "stoping for rec" true)
(memo (put memo this_hash nil)) (dlet (
(pectx (array env_counter memo)) (new_memo (put memo hash nil))
(pectx (array env_counter new_memo))
((pectx func_err func_result) (partial_eval_helper body only_head inner_env
(cons inner_env env_stack)
pectx (+ 1 indent)))
((env_counter new_memo) pectx)
(pectx (array env_counter memo))
) (array pectx func_err func_result false))))
;((pectx func_err func_result) (partial_eval_helper body only_head inner_env (cons inner_env env_stack) pectx (+ 1 indent)))
((pectx func_err func_result) (partial_eval_helper body only_head inner_env (cons inner_env env_stack) pectx (+ 1 indent)))
) (mif func_err (array pectx func_err nil) (dlet ( ) (mif func_err (array pectx 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))
;(failed (or (not able_to_sub_env) (and result_is_later result_closes_over))) ;(failed (or rec_stop (not able_to_sub_env) (and result_is_later result_closes_over)))
((failed reason) (cond ((check_for_env_id_in_result env_id func_result) (array true "has env id in result")) ((failed reason) (cond (rec_stop (array true "infinite recursion"))
((check_for_env_id_in_result env_id func_result) (array true "has env id in result"))
((not (later_head? func_result)) (array false "")) ((not (later_head? func_result)) (array false ""))
(true (array (dlet ((stop_envs ((rec-lambda ser (a e) (mif e (ser (cons (.marked_env_idx e) a) (idx (.env_marked e) -1)) a)) (array) se))) (true (array (dlet ((stop_envs ((rec-lambda ser (a e) (mif e (ser (cons (.marked_env_idx e) a) (idx (.env_marked e) -1)) a)) (array) se)))
(contains_symbols stop_envs (concat params (mif de? (array de?) (array))) func_result)) "both later and contains symbols")) (contains_symbols stop_envs (concat params (mif de? (array de?) (array))) func_result)) "both later and contains symbols"))
)) ))
(_ (println (indent_str indent) (if failed (str "failed because ") (_ (println (indent_str indent) (if failed (str "failed because " reason)
"function succeded!"))) "function succeded!")))
; 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!
(result (mif failed (marked_array false true (cons comb correct_fail_params)) (result (mif failed (marked_array false true (cons comb correct_fail_params))
func_result)) func_result))
((env_counter memo) pectx)
(memo (put memo this_hash result))
(pectx (array env_counter memo))
) (array pectx nil result)))))))) ) (array pectx nil result))))))))
((later_head? comb) (array pectx nil (marked_array false true (cons comb literal_params)))) ((later_head? comb) (array pectx nil (marked_array false true (cons comb literal_params))))
(true (array pectx (str "impossible comb value " x) nil)))))))) (true (array pectx (str "impossible comb value " x) nil))))))))
(true (array pectx (str "impossible partial_eval value " x) nil)) (true (array pectx (str "impossible partial_eval value " x) nil))
)) )
; otherwise, we can't make progress yet ; otherwise, we can't make progress yet
(begin (print_strip (indent_str indent) "Not evaluating " x) (begin (print_strip (indent_str indent) "Not evaluating " x)
;(print (indent_str indent) "comparing to env stack " env_stack) ;(print (indent_str indent) "comparing to env stack " env_stack)
@@ -3170,7 +3160,7 @@
(memo (put memo (.hash c) result)) (memo (put memo (.hash c) result))
) (array result nil nil (array datasi funcs memo env pectx)))))))) ) (array result nil nil (array datasi funcs memo env pectx))))))))
(if need_value (array nil nil "errr, needed value and was call" ctx) (if need_value (array nil nil (str "errr, needed value and was call " (str_strip c)) ctx)
(dlet ( (dlet (
(func_param_values (.marked_array_values c)) (func_param_values (.marked_array_values c))
@@ -3300,9 +3290,9 @@
((kvs vvs ctx) (foldr (dlambda ((k v) (ka va ctx)) (dlet (((kv _ _ ctx) (compile-inner ctx (marked_symbol nil k) true)) ((kvs vvs ctx) (foldr (dlambda ((k v) (ka va ctx)) (dlet (((kv _ _ ctx) (compile-inner ctx (marked_symbol nil k) true))
((vv code err ctx) (compile-inner ctx v need_value)) ((vv code err ctx) (compile-inner ctx v need_value))
(_ (print_strip "result of (kv is " kv ") v compile-inner vv " vv " code " code " err " err ", based on " v)) ;(_ (print_strip "result of (kv is " kv ") v compile-inner vv " vv " code " code " err " err ", based on " v))
(_ (if (= nil vv) (print_strip "VAL NIL CODE IN ENV B/C " k " = " v) nil)) ;(_ (if (= nil vv) (print_strip "VAL NIL CODE IN ENV B/C " k " = " v) nil))
(_ (if (!= nil err) (print_strip "ERRR IN ENV B/C " err " " k " = " v) nil)) ;(_ (if (!= nil err) (print_strip "ERRR IN ENV B/C " err " " k " = " v) nil))
) )
(if (= false ka) (array false va ctx) (if (= false ka) (array false va ctx)
(if (or (= nil vv) (!= nil err)) (array false (str "vv was " vv " err is " err " and we needed_value? " need_value " based on v " (str_strip v)) ctx) (if (or (= nil vv) (!= nil err)) (array false (str "vv was " vv " err is " err " and we needed_value? " need_value " based on v " (str_strip v)) ctx)
@@ -3484,7 +3474,7 @@
(true (error (str "Can't compile-inner impossible " c))) (true (error (str "Can't compile-inner impossible " c)))
))) )))
(_ (println "compiling partial evaled " (str_strip marked_code))) ;(_ (println "compiling partial evaled " (str_strip marked_code)))
(_ (true_print "compiling partial evaled " (true_str_strip marked_code))) (_ (true_print "compiling partial evaled " (true_str_strip marked_code)))
(memo empty_dict) (memo empty_dict)
(ctx (array datasi funcs memo root_marked_env pectx)) (ctx (array datasi funcs memo root_marked_env pectx))

31
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))
@@ -20,18 +20,26 @@
(let1 let (vY (lambda (recurse) (vau de (vs b) (cond (= (len vs) 0) (eval b 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))))) true (vapply let1 (array (idx vs 0) (idx vs 1) (array recurse (slice vs 2 -1) b)) de)))))
(let (a 1337) (let (
;lcompose (lambda (g f) (lambda (& args) (lapply g (array (lapply f args)))))
;monad (array 'write 1 "test_self_out3" (vau (written code) 1))
a 3
b 4
(array 'open 3 "test_self_out" (lambda (fd code) ;a 123
(array 'write fd "wabcdefghijk" (lambda (written code) monad (array 'open 3 "test_self_out" (lambda (fd code)
(array 'exit (+ a written)))))) (array 'write fd "wabcdefghijk" (lambda (written code)
(array 'exit (+ a b written))))))
)
;(+ b a)
monad
;(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
@@ -42,4 +50,3 @@
;(array 'write 1 "test_self_out2" (vau (written code) 1))