Finally correct again, but with the latest safety fixes no longer even evaluates the easier lets. The issue is that we're not executing combiners that use de if we don't have a real de (normally the enclosing function's se) because that's subject to the alpha-renaming problem. de is essentially a parameter, which is subtle and easy to miss when looking at the safety conditions, and indeed I did miss it earlier
This commit is contained in:
Nathan Braswell
320
partial_eval.kp
320
partial_eval.kp
@@ -21,26 +21,17 @@
|
||||
; 1) meta...
|
||||
; Honestly, I'm tempted to get rid of it
|
||||
|
||||
; !!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
; ! To avoid exponential blowup due to evaluating function, then params, then function with params, etc etc
|
||||
; ! Should probabally implement some form of evaluating to head-normal form controlled by boolean
|
||||
; ! that quits as soon as it has any sort of value (I suppose the real change is only to combinators and arrays)
|
||||
; ! so that we don't waste time re-trying etc. Anything in parameter position would be fully evaluated, so I don't think
|
||||
; ! we'd waste overmuch, but it could make things less efficient I suppose...
|
||||
; ! Maybe it's a bad idea - food for thought! Might need a better cacheing strategy
|
||||
; !!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
; Possible marked values
|
||||
; ['val v] - v is a value that evaluates to itself, and not a combiner or env, as those have their own metadata. Not an array or symbol
|
||||
; That means it's true/false/a string/ an int/nil
|
||||
; ['marked_array is_val a] - a contains marked values. if is_val, then it's the value version, and must be stripped back into (array ...),
|
||||
; otherwise it's a calling form, and should be lowered back to (...). Also, if it's is_val, partial_eval won't perform a call, etc
|
||||
; ['marked_symbol is_val s] - a symbol. is_val has the same meaning as in marked_array
|
||||
; ['comb wrap_level de? se variadic params body <actual_function>] - A combiner. Contains the static env and the actual function, if possible.
|
||||
; ['comb wrap_level de? se variadic params body] - A combiner. Contains the static env and the actual function, if possible.
|
||||
; It is possible to have a combiner without an actual function, but that's only generated when
|
||||
; we know it's about to be called and we won't have to strip-lower it
|
||||
; ['prim_comb <handler_function> <actual_function>] - A primitive combiner! It has it's own special handler function to partial eval
|
||||
; ['env [ ['symbol marked_value ]... <upper_marked_env> ] <actual_env>] - A marked env
|
||||
; ['prim_comb <handler_function>] - A primitive combiner! It has it's own special handler function to partial eval
|
||||
; ['env is_real [ ['symbol marked_value ]... <upper_marked_env> ]] - A marked env
|
||||
|
||||
|
||||
val? (lambda (x) (= 'val (idx x 0)))
|
||||
@@ -51,25 +42,34 @@
|
||||
marked_symbol? (lambda (x) (= 'marked_symbol (idx x 0)))
|
||||
.marked_symbol_is_val (lambda (x) (idx x 1))
|
||||
.marked_symbol_value (lambda (x) (idx x 2))
|
||||
later? (lambda (x) (or (and (marked_array? x) (= false (.marked_array_is_val x)))
|
||||
(and (marked_symbol? x) (= false (.marked_symbol_is_val x)))))
|
||||
false? (lambda (x) (cond (and (marked_array? x) (= false (.marked_array_is_val x))) (error (str "got a later marked_array passed to false? " x))
|
||||
(and (marked_symbol? x) (= false (.marked_symbol_is_val x))) (error (str "got a later marked_symbol passed to false? " x))
|
||||
(val? x) (not (.val x))
|
||||
true false))
|
||||
comb? (lambda (x) (= 'comb (idx x 0)))
|
||||
.comb (lambda (x) (slice x 1 -1))
|
||||
prim_comb? (lambda (x) (= 'prim_comb (idx x 0)))
|
||||
.prim_comb (lambda (x) (idx x 1))
|
||||
marked_env? (lambda (x) (= 'env (idx x 0)))
|
||||
.env_marked (lambda (x) (idx x 1))
|
||||
.env_real (lambda (x) (idx x 2))
|
||||
marked_env_real? (lambda (x) (idx x 1))
|
||||
.env_marked (lambda (x) (idx x 2))
|
||||
|
||||
later? (rec-lambda recurse (x) (or (and (marked_array? x) (= false (.marked_array_is_val x)))
|
||||
(and (marked_symbol? x) (= false (.marked_symbol_is_val x)))
|
||||
(and (marked_env? x) (not (marked_env_real? x)))
|
||||
(and (comb? x) (let ([wrap_level de? se variadic params body] (.comb x)
|
||||
; this is the complex bit - we should do something like check if
|
||||
; se is fake check to see if there are symbols or eval that could use it
|
||||
; or a sub-comb's se, or if de is non-nil and used in some sub-call.
|
||||
comb_is_later (recurse se)
|
||||
) comb_is_later))
|
||||
))
|
||||
false? (lambda (x) (cond (and (marked_array? x) (= false (.marked_array_is_val x))) (error (str "got a later marked_array passed to false? " x))
|
||||
(and (marked_symbol? x) (= false (.marked_symbol_is_val x))) (error (str "got a later marked_symbol passed to false? " x))
|
||||
(val? x) (not (.val x))
|
||||
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 (idx (idx dict i) 1) key 0 fail success)
|
||||
(= 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 (idx env 1) key 0 (lambda () (error (str key " not found in env " (idx env 1)))) (lambda (x) x)))
|
||||
env-lookup (lambda (env key) (env-lookup-helper (.env_marked env) key 0 (lambda () (error (str key " not found in env " (.env_marked env)))) (lambda (x) x)))
|
||||
|
||||
mark (rec-lambda recurse (x) (cond (env? x) (error (str "called mark with an env " x))
|
||||
(combiner? x) (error (str "called mark with a combiner " x))
|
||||
@@ -77,39 +77,59 @@
|
||||
(array? x) ['marked_array false (map recurse x)]
|
||||
true ['val x]))
|
||||
|
||||
strip (rec-lambda recurse (x)
|
||||
(cond (val? x) (.val x)
|
||||
(marked_array? x) (let (stripped_values (map recurse (.marked_array_values x)))
|
||||
(if (.marked_array_is_val x) (cons array stripped_values)
|
||||
stripped_values))
|
||||
(marked_symbol? x) (if (.marked_symbol_is_val x) [quote (.marked_symbol_value x)]
|
||||
(.marked_symbol_value x))
|
||||
(comb? x) (let (c (idx x 7))
|
||||
(if (= nil c) (error (str "partial eval failed: regular stripping a combinator without a real combinator (due to nil enviornment, no doubt, but how?)" x))
|
||||
c))
|
||||
(prim_comb? x) (idx x 2)
|
||||
(marked_env? x) (error "Env escaped to strip!")
|
||||
true (error (str "some other strip? " x))
|
||||
)
|
||||
)
|
||||
indent_str (rec-lambda recurse (i) (if (= i 0) ""
|
||||
(str " " (recurse (- i 1)))))
|
||||
|
||||
print_strip (lambda (x) (println ((rec-lambda recurse (x)
|
||||
str_strip (lambda (& args) (lapply str (concat (slice args 0 -2) [((rec-lambda recurse (x)
|
||||
(cond (val? x) (.val x)
|
||||
(marked_array? x) (let (stripped_values (map recurse (.marked_array_values x)))
|
||||
(if (.marked_array_is_val x) (cons array stripped_values)
|
||||
stripped_values))
|
||||
(marked_symbol? x) (if (.marked_symbol_is_val x) [quote (.marked_symbol_value x)]
|
||||
(marked_symbol? x) (if (.marked_symbol_is_val x) ['quote (.marked_symbol_value x)]
|
||||
(.marked_symbol_value x))
|
||||
(comb? x) (let ([wrap_level de? se variadic params body actual_function] (.comb x)) (str "<comb " wrap_level " " params " " (recurse body) ">"))
|
||||
(comb? x) (let ([wrap_level de? se variadic params body] (.comb x)) (str "<comb " wrap_level " " de? " <se " (recurse se) "> " params " " (recurse body) ">"))
|
||||
(prim_comb? x) (idx x 2)
|
||||
(marked_env? x) (error "Env escaped to strip!")
|
||||
(marked_env? x) (let (e (.env_marked x)
|
||||
u (idx e -1)
|
||||
) (if u (str "<" (if (marked_env_real? x) "real" "fake") " ENV " (map (lambda ([k v]) [k (recurse v)]) (slice e 0 -2)) " upper: " (recurse u) ">")
|
||||
"<no_upper_likely_root_env>"))
|
||||
true (error (str "some other str_strip? |" x "|"))
|
||||
)
|
||||
) (idx args -1))])))
|
||||
print_strip (lambda (& args) (println (lapply str_strip args)))
|
||||
|
||||
strip (let (helper (rec-lambda recurse (x need_value)
|
||||
(cond (val? x) (.val x)
|
||||
(marked_array? x) (let (stripped_values (map (lambda (x) (recurse x need_value)) (.marked_array_values x)))
|
||||
(if (.marked_array_is_val x) (if need_value (error (str "needed value for this strip but got" x)) (cons array stripped_values))
|
||||
stripped_values))
|
||||
(marked_symbol? x) (if (.marked_symbol_is_val x) (if need_value (error (str "needed value for this strip but got" x)) [quote (.marked_symbol_value x)])
|
||||
(.marked_symbol_value x))
|
||||
(comb? x) (let ([wrap_level de? se variadic params body] (.comb x)
|
||||
de_entry (if de? [de?] [])
|
||||
final_params (if variadic (concat (slice params 0 -2) '& [(idx params -1)]) params)
|
||||
; Honestly, could trim down the env to match what could be evaluated in the comb
|
||||
; Also if this isn't real, lower to a call to vau
|
||||
se_env (if (marked_env_real? se) (recurse se true) nil)
|
||||
body_v (recurse body false)
|
||||
ve (concat [vau] de_entry [final_params] [body_v])
|
||||
fe ((rec-lambda recurse (x i) (if (= i 0) x (recurse [wrap x] (- i 1)))) ve wrap_level)
|
||||
) (if se_env (eval fe se_env) fe))
|
||||
(prim_comb? x) (idx x 2)
|
||||
; env emitting doesn't pay attention to real value right now, not sure if that makes sense
|
||||
(marked_env? x) (let (_ (if (not (marked_env_real? x)) (error (str_strip "trying to emit fake env!" x)))
|
||||
upper (idx (.env_marked x) -1)
|
||||
upper_env (if upper (recurse upper true) empty_env)
|
||||
just_entries (slice (.env_marked x) 0 -2)
|
||||
vdict (map (lambda ([k v]) [k (recurse v true)]) just_entries)
|
||||
) (add-dict-to-env upper_env vdict))
|
||||
true (error (str "some other strip? " x))
|
||||
)
|
||||
) x)))
|
||||
)) (lambda (x) (let (_ (print_strip "stripping: " x) r (helper x false) _ (println "result of strip " r)) r)))
|
||||
|
||||
; A bit wild, but what if instead of is_value we had an evaluation level integer, kinda like wrap?
|
||||
; when lowering, it could just turn into multiple evals or somesuch, though we'd have to be careful of envs...
|
||||
try_unval (rec-lambda recurse (x fail_f) (let (_ (println "try_unvaling " x) r
|
||||
try_unval (rec-lambda recurse (x fail_f)
|
||||
(cond (marked_array? x) (if (not (.marked_array_is_val x)) [false (fail_f x)]
|
||||
(let ([sub_ok subs] (foldl (lambda ([ok a] x) (let ([nok p] (recurse x fail_f))
|
||||
[(and ok nok) (concat a [p])]))
|
||||
@@ -119,18 +139,18 @@
|
||||
(marked_symbol? x) (if (.marked_symbol_is_val x) [true ['marked_symbol false (.marked_symbol_value x)]]
|
||||
[false (fail_f x)])
|
||||
true [true x]
|
||||
) _ (println "\tresult was " r)) r)
|
||||
)
|
||||
)
|
||||
try_unval_array (lambda (x) (foldl (lambda ([ok a] x) (let ([nok p] (try_unval x (lambda (_) nil)))
|
||||
[(and ok nok) (concat a [p])]))
|
||||
[true []]
|
||||
x))
|
||||
|
||||
ensure_val (rec-lambda recurse (x) (let (_ (println "ensure_valing " x) r
|
||||
ensure_val (rec-lambda recurse (x)
|
||||
(cond (marked_array? x) ['marked_array true (map recurse (.marked_array_values x))]
|
||||
(marked_symbol? x) ['marked_symbol true (.marked_symbol_value x)]
|
||||
true x
|
||||
) _ (println "\tresult was " r)) r)
|
||||
)
|
||||
)
|
||||
|
||||
; This is a conservative analysis, since we can't always tell what constructs introduce
|
||||
@@ -142,55 +162,68 @@
|
||||
(lambda (x a) (helper x a 0)))
|
||||
contains_symbols (rec-lambda recurse (stop_envs symbols x) (cond
|
||||
(val? x) false
|
||||
(marked_symbol? x) (in_array (.marked_symbol_value x) symbols)
|
||||
(marked_symbol? x) (let (r (in_array (.marked_symbol_value x) symbols)
|
||||
_ (if r (println "!!! contains symbols found " x " in symbols " symbols)))
|
||||
r)
|
||||
(marked_array? x) (foldl (lambda (a x) (or a (recurse stop_envs symbols x))) false (.marked_array_values x))
|
||||
(comb? x) (let ([wrap_level de? se variadic params body actual_function] (.comb x))
|
||||
(or (recurse stop_envs symbols se) (recurse stop_envs (filter (lambda (y) (not (in_array y params))) symbols) body)))
|
||||
(comb? x) (let ([wrap_level de? se variadic params body] (.comb x))
|
||||
(or (recurse stop_envs symbols se) (recurse stop_envs (filter (lambda (y) (not (or (= de? y) (in_array y params)))) symbols) body)))
|
||||
|
||||
(prim_comb? x) false
|
||||
(marked_env? x) (let (inner (.env_marked x))
|
||||
(cond (in_array x stop_envs) false
|
||||
(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))
|
||||
(idx inner -1) (recurse stop_envs symbols (idx inner -1))
|
||||
true false))
|
||||
true (error (str "Something odd passed to contains_symbols " x))
|
||||
))
|
||||
|
||||
indent_str (rec-lambda recurse (i) (if (= i 0) ""
|
||||
(str " " (recurse (- i 1)))))
|
||||
is_all_values (lambda (evaled_params) (foldl (lambda (a x) (and a (not (later? x)))) true evaled_params))
|
||||
|
||||
make_tmp_inner_env (lambda (params de? de)
|
||||
['env false (concat (map (lambda (p) [p ['marked_symbol false p]]) params) (if (= nil de?) [] [ [de? ['marked_symbol false de?]] ]) [de])])
|
||||
|
||||
|
||||
|
||||
partial_eval_helper (rec-lambda recurse (x env imm_eval indent)
|
||||
partial_eval_helper (rec-lambda recurse (x env indent)
|
||||
(cond (val? x) x
|
||||
(marked_env? x) x
|
||||
(comb? x) x
|
||||
;(comb? x) x
|
||||
; ? this is legal because we don't allow expressions that close over symbols from outer envs to escape those envs,
|
||||
; so by necessity this is being partially-evaled again in the same environment or sub-environment.
|
||||
; GAH how do we make sure to avoid capture substitution stuff?
|
||||
; Need to prevent evaluating calls where parameters close over symbols of the function being called
|
||||
; or any user-input eval calls, note that we're replacing se below!
|
||||
; honestly, it seems like we need a way to differentiate between re-partial-evaluating a vau in it's same context but
|
||||
; with a more accurate environment, and passing around a partially-evaluated comb and calling it
|
||||
(comb? x) (let ([wrap_level de? se variadic params body] (.comb x))
|
||||
(if (or (and (not (marked_env_real? env)) (not (marked_env_real? se))) ; both aren't real, re-evaluation of creation site
|
||||
(and (marked_env_real? env) (not (marked_env_real? se)))) ; new env real, but se isn't - creation!
|
||||
['comb wrap_level de? env variadic params (recurse body (make_tmp_inner_env params de? env) (+ indent 1))]
|
||||
x))
|
||||
(prim_comb? x) x
|
||||
(marked_symbol? x) (if (.marked_symbol_is_val x) x
|
||||
(env-lookup env (.marked_symbol_value x)))
|
||||
(marked_array? x) (cond (.marked_array_is_val x) x
|
||||
(= 0 (len (.marked_array_values x))) (error "Partial eval on empty array")
|
||||
true (let (values (.marked_array_values x)
|
||||
_ (println (indent_str indent) "partial_evaling comb " (idx values 0))
|
||||
comb (recurse (idx values 0) env true (+ 1 indent))
|
||||
;_ (println (indent_str indent) "partial_evaling comb " (idx values 0))
|
||||
_ (print_strip (indent_str indent) "partial_evaling comb " (idx values 0))
|
||||
comb (recurse (idx values 0) env (+ 1 indent))
|
||||
literal_params (slice values 1 -1)
|
||||
_ (println (indent_str indent) "Going to do an array call!")
|
||||
_ (println (indent_str indent) " total is " x)
|
||||
_ (println (indent_str indent) " evaled comb is " comb)
|
||||
_ (print_strip (indent_str indent) " total is " x)
|
||||
_ (print_strip (indent_str indent) " evaled comb is " comb)
|
||||
ident (+ 1 indent)
|
||||
)
|
||||
; Replacing the old note here with one that mentions that
|
||||
; we use the imm_eval to know if it's ok to generate
|
||||
; comb's without a real combiner (because it doesn't have a real env)
|
||||
; because in the imm_eval case we don't need a real combiner since
|
||||
; we're about to partial eval the call away
|
||||
;;!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
;; With our new definition of later?, this prevents combiners without full se's from being called
|
||||
;;!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
(cond (later? comb) ['marked_array false (cons comb literal_params)]
|
||||
(prim_comb? comb) ((.prim_comb comb) env literal_params imm_eval (+ 1 indent))
|
||||
(prim_comb? comb) ((.prim_comb comb) env literal_params (+ 1 indent))
|
||||
(comb? comb) (let (
|
||||
rp_eval (lambda (p) (recurse p env false (+ 1 indent)))
|
||||
[wrap_level de? se variadic params body actual_function] (.comb comb)
|
||||
rp_eval (lambda (p) (recurse p env (+ 1 indent)))
|
||||
[wrap_level de? se variadic params body] (.comb comb)
|
||||
ensure_val_params (map ensure_val literal_params)
|
||||
_ (println (indent_str indent) "partial_evaling params with wrap level " wrap_level " " ensure_val_params)
|
||||
[ok appropriatly_evaled_params] ((rec-lambda param-recurse (wrap cparams)
|
||||
(if (!= 0 wrap)
|
||||
(let (pre_evaled (map rp_eval cparams)
|
||||
@@ -200,73 +233,56 @@
|
||||
(param-recurse (- wrap 1) evaled_params))))
|
||||
[true cparams])
|
||||
) wrap_level ensure_val_params)
|
||||
) (if (not ok) ['marked_array false (cons comb (if (> wrap_level 0) (map rp_eval literal_params)
|
||||
ok_and_non_later (and ok (is_all_values appropriatly_evaled_params))
|
||||
) (if (not ok_and_non_later) ['marked_array false (cons comb (if (> wrap_level 0) (map rp_eval literal_params)
|
||||
literal_params))]
|
||||
(let (
|
||||
final_params (if variadic (concat (slice appropriatly_evaled_params 0 (- (len params) 1))
|
||||
[['marked_array true (slice appropriatly_evaled_params (- (len params) 1) -1)]])
|
||||
appropriatly_evaled_params)
|
||||
de_entry (if (!= nil de?) [ [de? env] ] [])
|
||||
_ (println (indent_str indent) "final_params params " final_params)
|
||||
de_real_entry (if (!= nil de?) [ [de? (.env_real env)] ] [])
|
||||
se_real_env (.env_real se)
|
||||
inner_real_env (if (and se_real_env (or (not de?) (.env_real env)))
|
||||
(add-dict-to-env se_real_env
|
||||
(concat (zip params (map strip final_params))
|
||||
de_real_entry))
|
||||
nil)
|
||||
_ (println (indent_str indent) "Inner_real_env is " inner_real_env " because de_real " de_real_entry " se_real_env " se_real_env)
|
||||
inner_env ['env (concat (zip params final_params) de_entry [se]) inner_real_env]
|
||||
_ (println (indent_str indent) "going to eval " body " with inner_env is " inner_env)
|
||||
de_entry (if (!= nil de?) [ [de? (if (marked_env_real? env) env
|
||||
['marked_symbol false de?])] ]
|
||||
[])
|
||||
;_ (println (indent_str indent) "final_params params " final_params)
|
||||
inner_env ['env (marked_env_real? se) (concat (zip params final_params) de_entry [se])]
|
||||
;_ (println (indent_str indent) "going to eval " body " with inner_env is " inner_env)
|
||||
_ (print_strip (indent_str indent) " with inner_env is " inner_env)
|
||||
_ (print_strip (indent_str indent) "going to eval " body)
|
||||
|
||||
|
||||
; Ok, this might be a later with un-evaled references to parameter symbols,
|
||||
; in which case we need to re-wrap up in a vau, since
|
||||
; if they're used as parameters to a 'later value that might be a vau,
|
||||
; since we don't know if they have to be evaluated and thus
|
||||
; can't partially evaluate them.
|
||||
; !!! I belive this can be modified to wrap up into a specialized version of the func though
|
||||
; !!! and indeed that might be the right option for vaus
|
||||
; !!! something like (if (= 0 wrap_level) ['marked_array false (cons ['comb wrap_level de? se variadic params func_result nil] literal_params)]
|
||||
; !!! but have to be careful about what real_function should be
|
||||
func_result (recurse body inner_env (+ 1 indent))
|
||||
|
||||
_ (println (indent_str indent) "partial_evaling body " body)
|
||||
func_result (recurse body inner_env imm_eval (+ 1 indent))
|
||||
|
||||
_ (println (indent_str indent) "evaled result of function call (imm_eval was " imm_eval ") is " func_result)
|
||||
_ (print_strip (indent_str indent) "evaled result of function call is " func_result)
|
||||
result_is_later (later? func_result)
|
||||
stop_envs ((rec-lambda ser (a e) (if e (ser (cons e a) (idx (.env_marked e) -1)) a)) [] se)
|
||||
result_closes_over (contains_symbols stop_envs (concat params (if de? [de?] [])) func_result)
|
||||
_ (println (indent_str indent) "func call result is later? " result_is_later " and result_closes_over " result_closes_over)
|
||||
; This could be improved to a specialized version of the function
|
||||
; just by re-wrapping it in a comb instead if we wanted.
|
||||
; Something to think about!
|
||||
result (if (and result_is_later result_closes_over)
|
||||
; this is exponential-y - we retry without imm to see if we can
|
||||
; have a better partial eval'd later instead of giving up entirely
|
||||
(let (
|
||||
_ (println (indent_str indent) "partial_evaling retrying comb and parameters after fail b/c result_is_later and result_closes_over " (idx values 0) " with wrap_level " wrap_level " and params " literal_params)
|
||||
comb (recurse (idx values 0) env false (+ 1 indent)))
|
||||
['marked_array false (cons comb (if (> wrap_level 0) (map rp_eval ensure_val_params)
|
||||
literal_params))])
|
||||
['marked_array false (cons comb (if (> wrap_level 0) (map rp_eval ensure_val_params)
|
||||
literal_params))]
|
||||
func_result)
|
||||
) result)))
|
||||
true (error (str "Partial eval noticed that you will likely call not a function " comb " total is " x)))))
|
||||
true (error (str "impossible partial_eval value " x))
|
||||
)
|
||||
)
|
||||
is_all_values (lambda (evaled_params) (foldl (lambda (a x) (and a (not (later? x)))) true evaled_params))
|
||||
needs_params_val_lambda (vau de (f_sym) (let (
|
||||
actual_function (eval f_sym de)
|
||||
handler (rec-lambda recurse (de params imm_eval indent) (let (
|
||||
handler (rec-lambda recurse (de params indent) (let (
|
||||
_ (println "partial_evaling params in need_params_val_lambda for " f_sym " is " params)
|
||||
evaled_params (map (lambda (p) (partial_eval_helper p de false (+ 1 indent))) params)
|
||||
evaled_params (map (lambda (p) (partial_eval_helper p de (+ 1 indent))) params)
|
||||
)
|
||||
(if (is_all_values evaled_params) (mark (lapply actual_function (map strip evaled_params)))
|
||||
['marked_array false (cons ['prim_comb recurse actual_function] evaled_params)])))
|
||||
) [f_sym ['prim_comb handler actual_function]]))
|
||||
give_up_eval_params (vau de (f_sym) (let (
|
||||
actual_function (eval f_sym de)
|
||||
handler (rec-lambda recurse (de params imm_eval indent) (let (
|
||||
handler (rec-lambda recurse (de params indent) (let (
|
||||
_ (println "partial_evaling params in give_up_eval_params for " f_sym " is " params)
|
||||
evaled_params (map (lambda (p) (partial_eval_helper p de false (+ 1 indent))) params)
|
||||
evaled_params (map (lambda (p) (partial_eval_helper p de (+ 1 indent))) params)
|
||||
)
|
||||
['marked_array false (cons ['prim_comb recurse actual_function] evaled_params)]))
|
||||
) [f_sym ['prim_comb handler actual_function]]))
|
||||
@@ -274,21 +290,21 @@
|
||||
; !!!!!!
|
||||
; ! I think needs_params_val_lambda should be combined with parameters_evaled_proxy
|
||||
; !!!!!!
|
||||
parameters_evaled_proxy (rec-lambda recurse (pasthr_ie inner_f) (lambda (de params imm_eval indent) (let (
|
||||
parameters_evaled_proxy (rec-lambda recurse (pasthr_ie inner_f) (lambda (de params indent) (let (
|
||||
_ (println "partial_evaling params in parameters_evaled_proxy is " params)
|
||||
[evaled_params l] (foldl (lambda ([ac i] p) (let (p (partial_eval_helper p de (if (= i pasthr_ie) imm_eval false) (+ 1 indent)))
|
||||
[evaled_params l] (foldl (lambda ([ac i] p) (let (p (partial_eval_helper p de (+ 1 indent)))
|
||||
[(concat ac [p]) (+ i 1)]))
|
||||
[[] 0]
|
||||
params)
|
||||
) (inner_f (lambda (& args) (lapply (recurse pasthr_ie inner_f) args)) de evaled_params imm_eval indent))))
|
||||
) (inner_f (lambda (& args) (lapply (recurse pasthr_ie inner_f) args)) de evaled_params indent))))
|
||||
|
||||
root_marked_env ['env [
|
||||
root_marked_env ['env true [
|
||||
; Ok, so for combinators, it should partial eval the body.
|
||||
; It should then check to see if the partial-evaled body has closed over
|
||||
; any 'later values from above the combinator. If so, the combinator should
|
||||
; evaluate to a ['later [vau de? params (strip partially_evaled_body)]], otherwise it can evaluate to a 'comb.
|
||||
; Note that this 'later may be re-evaluated later if the parent function is called.
|
||||
['vau ['prim_comb (rec-lambda recurse (de params imm_eval indent) (let (
|
||||
['vau ['prim_comb (rec-lambda recurse (de params indent) (let (
|
||||
mde? (if (= 3 (len params)) (idx params 0))
|
||||
vau_mde? (if (= nil mde?) [] [mde?])
|
||||
de? (if mde? (.marked_symbol_value mde?))
|
||||
@@ -298,66 +314,52 @@
|
||||
(.marked_symbol_value x))) (.marked_array_values raw_marked_params))
|
||||
[variadic vau_params] (foldl (lambda ([v a] x) (if (= x '&) [true a] [v (concat a [x])])) [false []] raw_params)
|
||||
body (if (= nil de?) (idx params 1) (idx params 2))
|
||||
inner_env ['env (concat (map (lambda (p) [p ['marked_symbol false p]]) vau_params) (if (= nil de?) [] [ [de? ['marked_symbol false de?]] ]) [de]) nil]
|
||||
_ (println (indent_str indent) "in vau, evaluating body with 'later params - " body)
|
||||
pe_body (partial_eval_helper body inner_env false (+ 1 indent))
|
||||
_ (println (indent_str indent) "in vau, result of evaluating body was " pe_body " stripping")
|
||||
for_later (= nil (.env_real de))
|
||||
_ (println (indent_str indent) "imm_eval is " imm_eval " and for_later is " for_later " for " params " because of env being null " de)
|
||||
) (if for_later (if (not imm_eval) ['marked_array false (concat [['prim_comb recurse vau]] vau_mde? [raw_marked_params pe_body])]
|
||||
['comb 0 de? de variadic vau_params pe_body nil])
|
||||
(let (real_func (eval (concat [vau] vau_de? [raw_params (strip pe_body)]) (.env_real de))
|
||||
marked_func ['comb 0 de? de variadic vau_params pe_body real_func]
|
||||
_ (println (indent_str indent) "Marked func is " marked_func)
|
||||
_ (println (indent_str indent) "Raw func was made with body " (strip pe_body))
|
||||
) marked_func)))
|
||||
) vau]]
|
||||
inner_env (make_tmp_inner_env vau_params de? de)
|
||||
_ (print_strip (indent_str indent) "in vau, evaluating body with 'later params - " body)
|
||||
pe_body (partial_eval_helper body inner_env (+ 1 indent))
|
||||
_ (print_strip (indent_str indent) "in vau, result of evaluating body was " pe_body)
|
||||
_ (print_strip pe_body)
|
||||
) ['comb 0 de? de variadic vau_params pe_body]
|
||||
)) vau]]
|
||||
|
||||
['wrap ['prim_comb (parameters_evaled_proxy 0 (lambda (recurse de [evaled] imm_eval indent)
|
||||
(if (comb? evaled) (let ([wrap_level de? se variadic params body actual_function] (.comb evaled)
|
||||
wrapped_actual_fun (if (= nil actual_function) nil (wrap actual_function))
|
||||
wrapped_marked_fun ['comb (+ 1 wrap_level) de? se variadic params body wrapped_actual_fun]
|
||||
['wrap ['prim_comb (parameters_evaled_proxy 0 (lambda (recurse de [evaled] indent)
|
||||
(if (comb? evaled) (let ([wrap_level de? se variadic params body] (.comb evaled)
|
||||
wrapped_marked_fun ['comb (+ 1 wrap_level) de? se variadic params body]
|
||||
) wrapped_marked_fun)
|
||||
['marked_array false [['prim_comb recurse wrap] evaled]]))
|
||||
) wrap]]
|
||||
['unwrap ['prim_comb (parameters_evaled_proxy 0 (lambda (recurse de [evaled] imm_eval indent)
|
||||
(if (comb? evaled) (let ([wrap_level de? se variadic params body actual_function] (.comb evaled)
|
||||
unwrapped_actual_fun (if (= nil actual_function) nil (unwrap actual_function))
|
||||
unwrapped_marked_fun ['comb (- wrap_level 1) de? se variadic params body unwrapped_actual_fun]
|
||||
['unwrap ['prim_comb (parameters_evaled_proxy 0 (lambda (recurse de [evaled] indent)
|
||||
(if (comb? evaled) (let ([wrap_level de? se variadic params body] (.comb evaled)
|
||||
unwrapped_marked_fun ['comb (- wrap_level 1) de? se variadic params body]
|
||||
) unwrapped_marked_fun)
|
||||
['marked_array false [['prim_comb recurse wrap] evaled]]))
|
||||
) unwrap]]
|
||||
|
||||
['eval ['prim_comb (rec-lambda recurse (de params imm_eval indent) (let (
|
||||
['eval ['prim_comb (rec-lambda recurse (de params indent) (let (
|
||||
self ['prim_comb recurse eval]
|
||||
_ (println "partial_evaling param 1 maybe in eval is (if it exists) " (if (= 2 (len params)) (idx params 1)))
|
||||
eval_env (if (= 2 (len params)) (partial_eval_helper (idx params 1) de false (+ 1 indent))
|
||||
eval_env (if (= 2 (len params)) (partial_eval_helper (idx params 1) de (+ 1 indent))
|
||||
de)
|
||||
eval_env_v (if (= 2 (len params)) [eval_env] [])
|
||||
) (if (not (marked_env? eval_env)) ['marked_array false (cons self params)]
|
||||
(let (
|
||||
_ (println (indent_str indent) "ok, env was " eval_env " partial_evaling_body the first time")
|
||||
body1 (partial_eval_helper (idx params 0) de imm_eval (+ 1 indent))
|
||||
_ (println (indent_str indent) "after first eval of param " body1)
|
||||
_ (print_strip (indent_str indent) " partial_evaling_body the first time " (idx params 0))
|
||||
body1 (partial_eval_helper (idx params 0) de (+ 1 indent))
|
||||
_ (print_strip (indent_str indent) "after first eval of param " body1)
|
||||
|
||||
; With this, we don't actually fail as this is always a legitimate uneval
|
||||
fail_handler (lambda (failed) ['marked_array false (concat [self failed] eval_env_v)])
|
||||
[ok unval_body] (try_unval body1 fail_handler)
|
||||
self_fallback (fail_handler body1)
|
||||
_ (println "partial_evaling body for the second time in eval " unval_body)
|
||||
body2 (if (= self_fallback unval_body) self_fallback (partial_eval_helper unval_body eval_env imm_eval (+ 1 indent)))
|
||||
;[ok unval_body] (try_unval body1 (lambda (failed) nil))
|
||||
;body2 (if ok (partial_eval_helper unval_body eval_env imm_eval (+ 1 indent))
|
||||
; self_fallback)
|
||||
|
||||
_ (println (indent_str indent) "and body2 is " body2)
|
||||
_ (print_strip "partial_evaling body for the second time in eval " unval_body)
|
||||
body2 (if (= self_fallback unval_body) self_fallback (partial_eval_helper unval_body eval_env (+ 1 indent)))
|
||||
_ (print_strip (indent_str indent) "and body2 is " body2)
|
||||
) body2))
|
||||
)) eval]]
|
||||
|
||||
;TODO: This could go a lot farther, not stopping after the first 'later, etc
|
||||
; Also, GAH on odd params - but only one by one - a later odd param can't be imm_eval cuz it will
|
||||
; be frozen if an earlier cond is 'later....
|
||||
['cond ['prim_comb (parameters_evaled_proxy nil (lambda (recurse de evaled_params imm_eval indent)
|
||||
['cond ['prim_comb (parameters_evaled_proxy nil (lambda (recurse de evaled_params indent)
|
||||
(if (!= 0 (% (len evaled_params) 2)) (error (str "partial eval cond with odd evaled_params " evaled_params))
|
||||
((rec-lambda recurse_inner (i)
|
||||
(cond (later? (idx evaled_params i)) ['marked_array false (cons ['prim_comb recurse cond] (slice evaled_params i -1))]
|
||||
@@ -371,7 +373,7 @@
|
||||
(needs_params_val_lambda int?)
|
||||
(needs_params_val_lambda string?)
|
||||
; not even a gah, but kinda!
|
||||
['combiner? ['prim_comb (parameters_evaled_proxy nil (lambda (recurse de [evaled_param] imm_eval indent)
|
||||
['combiner? ['prim_comb (parameters_evaled_proxy nil (lambda (recurse de [evaled_param] indent)
|
||||
(cond (comb? evaled_param) ['val true]
|
||||
(prim_comb? evaled_param) ['val true]
|
||||
(later? evaled_param) ['marked_array false [['prim_comb recurse combiner?] evaled_param]]
|
||||
@@ -379,7 +381,7 @@
|
||||
)
|
||||
)) combiner?]]
|
||||
; not even a gah, but kinda!
|
||||
['env? ['prim_comb (parameters_evaled_proxy nil (lambda (recurse de [evaled_param] imm_eval indent)
|
||||
['env? ['prim_comb (parameters_evaled_proxy nil (lambda (recurse de [evaled_param] indent)
|
||||
(cond (marked_env? evaled_param) ['val true]
|
||||
(later? evaled_param) ['marked_array false [['prim_comb recurse env?] evaled_param]]
|
||||
true ['val false]
|
||||
@@ -389,34 +391,34 @@
|
||||
(needs_params_val_lambda bool?)
|
||||
(needs_params_val_lambda str-to-symbol)
|
||||
(needs_params_val_lambda get-text)
|
||||
['array? ['prim_comb (parameters_evaled_proxy nil (lambda (recurse de [evaled_param] imm_eval indent)
|
||||
['array? ['prim_comb (parameters_evaled_proxy nil (lambda (recurse de [evaled_param] indent)
|
||||
(cond
|
||||
(later? evaled_param) ['marked_array false [['prim_comb recurse array?] evaled_param]]
|
||||
(marked_array? evaled_param) ['val true]
|
||||
true ['val false]
|
||||
)
|
||||
)) array?]]
|
||||
['array ['prim_comb (parameters_evaled_proxy nil (lambda (recurse de evaled_params imm_eval indent)
|
||||
['array ['prim_comb (parameters_evaled_proxy nil (lambda (recurse de evaled_params indent)
|
||||
['marked_array true evaled_params]
|
||||
)) array]]
|
||||
['len ['prim_comb (parameters_evaled_proxy nil (lambda (recurse de [evaled_param] imm_eval indent)
|
||||
['len ['prim_comb (parameters_evaled_proxy nil (lambda (recurse de [evaled_param] indent)
|
||||
(cond (later? evaled_param) ['marked_array false [['prim_comb recurse len] evaled_param]]
|
||||
(marked_array? evaled_param) ['val (len (.marked_array_values evaled_param))]
|
||||
true (error (str "bad type to len " evaled_param))
|
||||
)
|
||||
)) len]]
|
||||
['idx ['prim_comb (parameters_evaled_proxy nil (lambda (recurse de [evaled_array evaled_idx] imm_eval indent)
|
||||
['idx ['prim_comb (parameters_evaled_proxy nil (lambda (recurse de [evaled_array evaled_idx] indent)
|
||||
(cond (and (val? evaled_idx) (marked_array? evaled_array) (.marked_array_is_val evaled_array)) (idx (.marked_array_values evaled_array) (.val evaled_idx))
|
||||
true ['marked_array false [['prim_comb recurse idx] evaled_array evaled_idx]]
|
||||
)
|
||||
)) idx]]
|
||||
['slice ['prim_comb (parameters_evaled_proxy nil (lambda (recurse de [evaled_array evaled_begin evaled_end] imm_eval indent)
|
||||
['slice ['prim_comb (parameters_evaled_proxy nil (lambda (recurse de [evaled_array evaled_begin evaled_end] indent)
|
||||
(cond (and (val? evaled_begin) (val? evaled_end) (marked_array? evaled_array) (.marked_array_is_val evaled_array))
|
||||
['marked_array true (slice (.marked_array_values evaled_array) (.val evaled_begin) (.val evaled_end))]
|
||||
true ['marked_array false [['prim_comb recurse slice] evaled_array evaled_idx evaled_begin evaled_end]]
|
||||
)
|
||||
)) slice]]
|
||||
['concat ['prim_comb (parameters_evaled_proxy nil (lambda (recurse de evaled_params imm_eval indent)
|
||||
['concat ['prim_comb (parameters_evaled_proxy nil (lambda (recurse de evaled_params indent)
|
||||
(cond (foldl (lambda (a x) (and a (and (marked_array? x) (.marked_array_is_val x))) true evaled_params) ['marked_array true (lapply concat (map (lambda (x)
|
||||
(.marked_array_values x))
|
||||
evaled_params))]
|
||||
@@ -440,7 +442,7 @@
|
||||
(needs_params_val_lambda >=)
|
||||
|
||||
; these could both be extended to eliminate other known true values except for the end and vice-versa
|
||||
['and ['prim_comb (parameters_evaled_proxy nil (lambda (recurse de evaled_params imm_eval indent)
|
||||
['and ['prim_comb (parameters_evaled_proxy nil (lambda (recurse de evaled_params indent)
|
||||
((rec-lambda inner_recurse (i)
|
||||
(cond (= i (- (len evaled_params) 1)) (idx evaled_params i)
|
||||
(later? (idx evaled_params i)) ['marked_array false (cons ['prim_comb recurse and] (slice evaled_params i -1))]
|
||||
@@ -449,7 +451,7 @@
|
||||
) 0)
|
||||
)) and]]
|
||||
; see above for improvement
|
||||
['or ['prim_comb (parameters_evaled_proxy nil (lambda (recurse de evaled_params imm_eval indent)
|
||||
['or ['prim_comb (parameters_evaled_proxy nil (lambda (recurse de evaled_params indent)
|
||||
((rec-lambda inner_recurse (i)
|
||||
(cond (= i (- (len evaled_params) 1)) (idx evaled_params i)
|
||||
(later? (idx evaled_params i)) ['marked_array false (cons ['prim_comb recurse or] (slice evaled_params i -1))]
|
||||
@@ -474,11 +476,11 @@
|
||||
(give_up_eval_params slurp)
|
||||
(give_up_eval_params get_line)
|
||||
(give_up_eval_params write_file)
|
||||
['empty_env ['env [] empty_env]]
|
||||
['empty_env ['env true [nil]]]
|
||||
nil
|
||||
] root_env]
|
||||
|
||||
partial_eval (lambda (x) (partial_eval_helper (mark x) root_marked_env false 0))
|
||||
partial_eval (lambda (x) (partial_eval_helper (mark x) root_marked_env 0))
|
||||
)
|
||||
(provide partial_eval strip print_strip)
|
||||
))
|
||||
|
||||
Reference in New Issue
Block a user