From 7fed3a58f536c77eb0edab317360cee55891d4a0 Mon Sep 17 00:00:00 2001 From: Nathan Braswell Date: Tue, 8 Mar 2022 02:54:26 -0500 Subject: [PATCH] Added more to to_compile.kp and runtime started growing again - main bottleneck was the silly using lists as sets thing, changed the small-int uses of these to a new custom bitset and brought the time from 47s back down to 6s. There is a remaining hotspot where partial_eval_helper matches needed_for_progress vs the bitset, but that'll have to wait for tomorrow. Thinking of maintaining a env_stack bitset and adding a bitset_union_nonempty function. Note the new bitset does use some cons/car/cdr operations that'll be a bit different in Kraken, which I'll need to look at. Maybe when porting I can just use indexing if there's not a great way to unify them. --- partial_eval.scm | 260 ++++++++++++++++++++++++++++++----------------- to_compile.kp | 252 +++++++++++++++++++++++++++------------------ 2 files changed, 317 insertions(+), 195 deletions(-) diff --git a/partial_eval.scm b/partial_eval.scm index 6722771..2cc8625 100644 --- a/partial_eval.scm +++ b/partial_eval.scm @@ -7,7 +7,7 @@ ; Chez (define print pretty-print) (define arithmetic-shift bitwise-arithmetic-shift) (define foldl fold-left) (define foldr fold-right) (define write_file (lambda (file bytes) (let* ( (port (open-file-output-port file)) (_ (foldl (lambda (_ o) (put-u8 port o)) (void) bytes)) (_ (close-port port))) '()))) -(compile-profile 'source) +;(compile-profile 'source) ; Gambit - Gambit also has a problem with the dlet definition (somehow recursing and making (cdr nil) for (cdr ls)?), even if using the unstable one that didn't break syntax-rules ;(define print pretty-print) @@ -60,6 +60,7 @@ (#t (begin (cons x (loop (read-char input-port))))))))))) (define speed_hack #t) +;(define GLOBAL_MAX 0) (let* ( (lapply apply) @@ -103,62 +104,6 @@ (zip (lambda args (apply map list args))) - ;(my-alist-ref alist-ref) - - (empty_dict-list (array)) - (put-list (lambda (m k v) (cons (array k v) m))) - (get-list (lambda (d k) ((rec-lambda recurse (k d len_d i) (cond ((= len_d i) false) - ((= k (idx (idx d i) 0)) (idx d i)) - (true (recurse k d len_d (+ 1 i))))) - k d (len d) 0))) - - - ;(combine_hash (lambda (a b) (+ (* 37 a) b))) - (combine_hash (lambda (a b) (bitwise-and #xFFFFFFFFFFFFFF (+ (* 37 a) b)))) - (hash_bool (lambda (b) (if b 2 3))) - (hash_num (lambda (n) (combine_hash 5 n))) - (hash_string (lambda (s) (foldl combine_hash 7 (map char->integer (string->list s))))) - ;(hash_string (lambda (s) (foldl combine_hash 102233 (map char->integer (string->list s))))) - - (empty_dict-tree nil) - (trans-key (lambda (k) (cond ((string? k) (cons (hash_string k) k)) - ((symbol? k) (cons (hash_string (symbol->string k)) k)) - (true (cons k k))))) - (put-helper (rec-lambda put-helper (m k v) (cond ((nil? m) (cons (list k v) (cons nil nil))) - ((and (= (car k) (caaar m)) - (= (cdr k) (cdaar m))) (cons (list k v) (cons (cadr m) (cddr m)))) - ((< (car k) (caaar m)) (cons (car m) (cons (put-helper (cadr m) k v) (cddr m)))) - (true (cons (car m) (cons (cadr m) (put-helper (cddr m) k v))))))) - (put-tree (lambda (m k v) (put-helper m (trans-key k) v))) - (get-helper (rec-lambda get-helper (m k) (cond ((nil? m) false) - ((and (= (car k) (caaar m)) - (= (cdr k) (cdaar m))) (car m)) - ((< (car k) (caaar m)) (get-helper (cadr m) k)) - (true (get-helper (cddr m) k))))) - (get-tree (lambda (m k) (get-helper m (trans-key k)))) - - ;(empty_dict empty_dict-list) - ;(put put-list) - ;(get get-list) - (empty_dict empty_dict-tree) - (put put-tree) - (get get-tree) - - ;(empty_dict (list empty_dict-list empty_dict-tree)) - ;(put (lambda (m k v) (list (put-list (idx m 0) k v) (put-tree (idx m 1) k v)))) - ;(get (lambda (m k) (dlet ( ;(_ (true_print "doing a get " m " " k)) - ; (list-result (get-list (idx m 0) k)) - ; (tree-result (get-tree (idx m 1) k)) - ; (_ (if (and (!= list-result tree-result) (!= (idx list-result 1) (idx tree-result 1))) (error "BAD GET " list-result " vs " tree-result))) - ; ) tree-result))) - - (get-value (lambda (d k) (let ((result (get d k))) - (if (pair? result) (cadr result) - (error (str "could not find " k " in " d)))))) - (get-value-or-false (lambda (d k) (let ((result (get d k))) - (if (pair? result) (cadr result) - false)))) - (% modulo) (int? integer?) (str? string?) @@ -187,17 +132,142 @@ (#t (append (f (car l)) (recurse f (cdr l))))) )) f l))) + ;;;;;;;;;;;;;;;;;; + ; End kludges + ;;;;;;;;;;;;;;;;;; + + + (empty_dict-list (array)) + (put-list (lambda (m k v) (cons (array k v) m))) + (get-list (lambda (d k) ((rec-lambda recurse (k d len_d i) (cond ((= len_d i) false) + ((= k (idx (idx d i) 0)) (idx d i)) + (true (recurse k d len_d (+ 1 i))))) + k d (len d) 0))) + + ;(combine_hash (lambda (a b) (+ (* 37 a) b))) + (combine_hash (lambda (a b) (band #xFFFFFFFFFFFFFF (+ (* 37 a) b)))) + (hash_bool (lambda (b) (if b 2 3))) + (hash_num (lambda (n) (combine_hash 5 n))) + (hash_string (lambda (s) (foldl combine_hash 7 (map char->integer (string->list s))))) + ;(hash_string (lambda (s) (foldl combine_hash 7 s))) + ;(hash_string (lambda (s) (foldl combine_hash 102233 (map char->integer (string->list s))))) + + (empty_dict-tree nil) + ;(trans-key (lambda (k) (cond ((string? k) (cons (hash_string k) k)) + ; ((symbol? k) (cons (hash_string (symbol->string k)) k)) + ; (true (cons k k))))) + ;(put-helper (rec-lambda put-helper (m k v) (cond ((nil? m) (cons (list k v) (cons nil nil))) + ; ((and (= (car k) (caaar m)) + ; (= (cdr k) (cdaar m))) (cons (list k v) (cons (cadr m) (cddr m)))) + ; ((< (car k) (caaar m)) (cons (car m) (cons (put-helper (cadr m) k v) (cddr m)))) + ; (true (cons (car m) (cons (cadr m) (put-helper (cddr m) k v))))))) + ;(put-tree (lambda (m k v) (put-helper m (trans-key k) v))) + ;(get-helper (rec-lambda get-helper (m k) (cond ((nil? m) false) + ; ((and (= (car k) (caaar m)) + ; (= (cdr k) (cdaar m))) (car m)) + ; ((< (car k) (caaar m)) (get-helper (cadr m) k)) + ; (true (get-helper (cddr m) k))))) + (trans-key (lambda (k) (cond ((string? k) (hash_string k)) + ((symbol? k) (hash_string (get-text k))) + (true k)))) + (put-helper (rec-lambda put-helper (m hk k v) (cond ((nil? m) (array hk k v nil nil)) + ((and (= hk (idx m 0)) + (= k (idx m 1))) (array hk k v (idx m 3) (idx m 4))) + ((< hk (idx m 0)) (array (idx m 0) (idx m 1) (idx m 2) (put-helper (idx m 3) hk k v) (idx m 4))) + (true (array (idx m 0) (idx m 1) (idx m 2) (idx m 3) (put-helper (idx m 4) hk k v)))))) + (put-tree (lambda (m k v) (put-helper m (trans-key k) k v))) + (get-helper (rec-lambda get-helper (m hk k) (cond ((nil? m) false) + ((and (= hk (idx m 0)) + (= k (idx m 1))) (array k (idx m 2))) + ((< hk (idx m 0)) (get-helper (idx m 3) hk k)) + (true (get-helper (idx m 4) hk k))))) + (get-tree (lambda (m k) (get-helper m (trans-key k) k))) + + ;(empty_dict empty_dict-list) + ;(put put-list) + ;(get get-list) + (empty_dict empty_dict-tree) + (put put-tree) + (get get-tree) + + ;(empty_dict (list empty_dict-list empty_dict-tree)) + ;(put (lambda (m k v) (list (put-list (idx m 0) k v) (put-tree (idx m 1) k v)))) + ;(get (lambda (m k) (dlet ( ;(_ (true_print "doing a get " m " " k)) + ; (list-result (get-list (idx m 0) k)) + ; (tree-result (get-tree (idx m 1) k)) + ; (_ (if (and (!= list-result tree-result) (!= (idx list-result 1) (idx tree-result 1))) (error "BAD GET " list-result " vs " tree-result))) + ; ) tree-result))) + + (get-value (lambda (d k) (dlet ((result (get d k))) + (if (array? result) (idx result 1) + (error (str "could not find " k " in " d)))))) + (get-value-or-false (lambda (d k) (dlet ((result (get d k))) + (if (array? result) (idx result 1) + false)))) - ; Ok, actual definitions (in_array (dlet ((helper (rec-lambda recurse (x a len_a i) (cond ((= i len_a) false) ((= x (idx a i)) true) (true (recurse x a len_a (+ i 1))))))) (lambda (x a) (helper x a (len a) 0)))) (array_item_union (lambda (a bi) (if (in_array bi a) a (cons bi a)))) (array_union (lambda (a b) (foldl array_item_union a b))) - (array_union_without (lambda (wo a b) - (foldl (lambda (o xi) (if (or (= wo xi) (in_array xi o)) o (cons xi o))) - (array) (concat a b)))) + + + (intset_word_size 64) + (in_intset (rec-lambda in_intset (x a) (cond ((nil? a) false) + ((>= x intset_word_size) (in_intset (- x intset_word_size) (cdr a))) + (true (!= (band (>> (car a) x) 1) 0))))) + (intset_item_union (rec-lambda intset_item_union (a bi) (cond ((nil? a) (intset_item_union (list 0) bi)) + ((>= bi intset_word_size) (cons (car a) (intset_item_union (cdr a) (- bi intset_word_size)))) + (true (cons (bor (car a) (<< 1 bi)) (cdr a)))))) + (intset_item_remove (rec-lambda intset_item_remove (a bi) (cond ((nil? a) nil) + ((>= bi intset_word_size) (dlet ((new_tail (intset_item_remove (cdr a) (- bi intset_word_size)))) + (if (and (nil? new_tail) (= 0 (car a))) nil + (cons (car a) new_tail)))) + (true (dlet ((new_int (band (car a) (bnot (<< 1 bi))))) + (if (and (nil? (cdr a)) (= 0 new_int)) nil + (cons new_int (cdr a)))))))) + (intset_union (rec-lambda intset_union (a b) (cond ((and (nil? a) (nil? b)) nil) + ((nil? a) b) + ((nil? b) a) + (true (cons (bor (car a) (car b)) (intset_union (cdr a) (cdr b))))))) + + ;(_ (true_print "of 1 " (intset_item_union nil 1))) + ;(_ (true_print "of 1 and 2 " (intset_item_union (intset_item_union nil 1) 2))) + ;(_ (true_print "of 1 and 2 union 3 4" (intset_union (intset_item_union (intset_item_union nil 1) 2) (intset_item_union (intset_item_union nil 3) 4)))) + + ;(_ (true_print "of 100 " (intset_item_union nil 100))) + ;(_ (true_print "of 100 and 200 " (intset_item_union (intset_item_union nil 100) 200))) + ;(_ (true_print "of 100 and 200 union 300 400" (intset_union (intset_item_union (intset_item_union nil 100) 200) (intset_item_union (intset_item_union nil 300) 400)))) + + ;(_ (true_print "1 in 1 " (in_intset 1 (intset_item_union nil 1)))) + ;(_ (true_print "1 in 1 and 2 " (in_intset 1 (intset_item_union (intset_item_union nil 1) 2)))) + ;(_ (true_print "1 in 1 and 2 union 3 4" (in_intset 1 (intset_union (intset_item_union (intset_item_union nil 1) 2) (intset_item_union (intset_item_union nil 3) 4))))) + + ;(_ (true_print "1 in 1 " (in_intset 1 (intset_item_union nil 1)))) + ;(_ (true_print "1 in 1 and 2 " (in_intset 1 (intset_item_union (intset_item_union nil 1) 2)))) + ;(_ (true_print "1 in 1 and 2 union 3 4" (in_intset 1 (intset_union (intset_item_union (intset_item_union nil 1) 2) (intset_item_union (intset_item_union nil 3) 4))))) + + ;(_ (true_print "5 in 1 " (in_intset 5 (intset_item_union nil 1)))) + ;(_ (true_print "5 in 1 and 2 " (in_intset 5 (intset_item_union (intset_item_union nil 1) 2)))) + ;(_ (true_print "5 in 1 and 2 union 3 4" (in_intset 5 (intset_union (intset_item_union (intset_item_union nil 1) 2) (intset_item_union (intset_item_union nil 3) 4))))) + + ;(_ (true_print "1 in 100 " (in_intset 1 (intset_item_union nil 100)))) + ;(_ (true_print "1 in 100 and 200 " (in_intset 1 (intset_item_union (intset_item_union nil 100) 200)))) + ;(_ (true_print "1 in 100 and 200 union 300 400" (in_intset 1 (intset_union (intset_item_union (intset_item_union nil 100) 200) (intset_item_union (intset_item_union nil 300) 400))))) + ;(_ (true_print "5 in 100 " (in_intset 5 (intset_item_union nil 100)))) + ;(_ (true_print "5 in 100 and 200 " (in_intset 5 (intset_item_union (intset_item_union nil 100) 200)))) + ;(_ (true_print "5 in 100 and 200 union 300 400" (in_intset 5 (intset_union (intset_item_union (intset_item_union nil 100) 200) (intset_item_union (intset_item_union nil 300) 400))))) + ;(_ (true_print "100 in 100 " (in_intset 100 (intset_item_union nil 100)))) + ;(_ (true_print "100 in 100 and 200 " (in_intset 100 (intset_item_union (intset_item_union nil 100) 200)))) + ;(_ (true_print "100 in 100 and 200 union 300 400" (in_intset 100 (intset_union (intset_item_union (intset_item_union nil 100) 200) (intset_item_union (intset_item_union nil 300) 400))))) + ;(_ (true_print "500 in 100 " (in_intset 500 (intset_item_union nil 100)))) + ;(_ (true_print "500 in 100 and 200 " (in_intset 500 (intset_item_union (intset_item_union nil 100) 200)))) + ;(_ (true_print "500 in 100 and 200 union 300 400" (in_intset 500 (intset_union (intset_item_union (intset_item_union nil 100) 200) (intset_item_union (intset_item_union nil 300) 400))))) + + ;(_ (true_print "all removed in 100 and 200 union 300 400" (intset_item_remove (intset_item_remove (intset_item_remove (intset_item_remove (intset_union (intset_item_union (intset_item_union nil 100) 200) (intset_item_union (intset_item_union nil 300) 400)) 100) 200) 300) 400))) + + (intset_union_without (lambda (wo a b) (intset_item_remove (intset_union a b) wo))) (val? (lambda (x) (= 'val (idx x 0)))) (marked_array? (lambda (x) (= 'marked_array (idx x 0)))) @@ -250,20 +320,22 @@ ; of an evaluation of, then it could progress futher. These are all caused by ; the infinite recursion stopper. (needed_for_progress (rec-lambda needed_for_progress (x) (cond ((marked_array? x) (.marked_array_needed_for_progress x)) - ((marked_symbol? x) (array (.marked_symbol_needed_for_progress x) nil nil)) + ((marked_symbol? x) (dlet ((n (.marked_symbol_needed_for_progress x))) (array (if (int? n) (intset_item_union nil n) n) nil nil))) ((marked_env? x) (.marked_env_needed_for_progress x)) ((comb? x) (dlet ((id (.comb_id x)) ((body_needed _hashes extra1) (needed_for_progress (.comb_body x))) ((se_needed _hashes extra2) (needed_for_progress (.comb_env x)))) (if (or (= true body_needed) (= true se_needed)) (array true nil nil) - (array (array_union_without id body_needed se_needed) - nil (array_union_without id extra1 extra2)) + (array (intset_union_without id body_needed se_needed) + nil (intset_union_without id extra1 extra2)) ))) ((prim_comb? x) (array nil nil nil)) ((val? x) (array nil nil nil)) (true (error (str "what is this? in need for progress" x)))))) (needed_for_progress_slim (lambda (x) (idx (needed_for_progress x) 0))) - (hash_symbol (lambda (progress_idxs s) (combine_hash (if (= true progress_idxs) 11 (foldl combine_hash 13 (map (lambda (x) (if (= true x) 13 (+ 1 x))) progress_idxs))) (hash_string (symbol->string s))))) + (hash_symbol (lambda (progress_idx s) (combine_hash (cond ((= true progress_idx) 11) + ((int? progress_idx) (combine_hash 13 progress_idx)) + (true 113)) (hash_string (get-text s))))) (hash_array (lambda (is_val attempted a) (foldl combine_hash (if is_val 17 (cond ((int? attempted) (combine_hash attempted 19)) (attempted 61) @@ -295,21 +367,21 @@ ((string? x) (hash_string x)) ((int? x) (hash_num x)) (true (error (str "bad thing to hash_val " x)))))) - ; 113 127 131 137 139 149 151 157 163 167 173 + ; 127 131 137 139 149 151 157 163 167 173 - (marked_symbol (lambda (progress_idxs x) (array 'marked_symbol (hash_symbol progress_idxs x) progress_idxs x))) + (marked_symbol (lambda (progress_idx x) (array 'marked_symbol (hash_symbol progress_idx x) progress_idx x))) (marked_array (lambda (is_val attempted resume_hashes x) (dlet ( ((sub_progress_idxs hashes extra) (foldl (dlambda ((a ahs aeei) (x xhs x_extra_env_ids)) (array (cond ((or (= true a) (= true x)) true) - (true (array_union a x))) + (true (intset_union a x))) (array_union ahs xhs) - (array_union aeei x_extra_env_ids)) + (intset_union aeei x_extra_env_ids)) ) (array (array) resume_hashes (array)) (map needed_for_progress x))) (progress_idxs (cond ((and (= nil sub_progress_idxs) (not is_val) (= true attempted)) nil) ((and (= nil sub_progress_idxs) (not is_val) (= false attempted)) true) ((and (= nil sub_progress_idxs) (not is_val) (int? attempted)) (array attempted)) (true (if (int? attempted) - (array_item_union sub_progress_idxs attempted) + (intset_item_union sub_progress_idxs attempted) sub_progress_idxs)))) ) (array 'marked_array (hash_array is_val attempted x) is_val attempted (array progress_idxs hashes extra) x)))) @@ -319,10 +391,10 @@ (full_arrs (concat arrs de_entry (array ue))) ((progress_idxs1 _hashes extra1) (mif ue (needed_for_progress ue) (array nil nil nil))) ((progress_idxs2 _hashes extra2) (mif de? (needed_for_progress de) (array nil nil nil))) - (progress_idxs (array_union progress_idxs1 progress_idxs2)) - (extra (array_union extra1 extra2)) - (progress_idxs (if (not has_vals) (cons dbi progress_idxs) progress_idxs)) - (extra (if (!= nil progress_idxs) (cons dbi extra) extra)) + (progress_idxs (intset_union progress_idxs1 progress_idxs2)) + (extra (intset_union extra1 extra2)) + (progress_idxs (if (not has_vals) (intset_item_union progress_idxs dbi) progress_idxs)) + (extra (if (!= nil progress_idxs) (intset_item_union extra dbi) extra)) ) (array 'env (hash_env has_vals progress_idxs dbi full_arrs) has_vals (array progress_idxs nil extra) dbi full_arrs)))) @@ -337,6 +409,9 @@ (true (error "bad with_wrap_level"))))) + + + (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))) ))) @@ -462,8 +537,8 @@ (check_for_env_id_in_result (lambda (s_env_id x) (idx ((rec-lambda check_for_env_id_in_result (memo s_env_id x) (dlet ( ((need _hashes extra) (needed_for_progress x)) - (in_need (if (!= true need) (in_array s_env_id need) false)) - (in_extra (in_array s_env_id extra)) + (in_need (if (!= true need) (in_intset s_env_id need) false)) + (in_extra (in_intset s_env_id extra)) ;(or in_need in_extra) (array memo true) ;(!= true need) (array memo false) ) (cond ((or in_need in_extra) (array memo true)) @@ -608,8 +683,8 @@ r))) (make_tmp_inner_env (lambda (params de? ue env_id) - (dlet ((param_entries (map (lambda (p) (array p (marked_symbol (array env_id) p))) params)) - (possible_de (mif (= nil de?) (array) (marked_symbol (array env_id) de?))) + (dlet ((param_entries (map (lambda (p) (array p (marked_symbol env_id p))) params)) + (possible_de (mif (= nil de?) (array) (marked_symbol env_id de?))) ) (marked_env false de? possible_de ue env_id param_entries)))) @@ -619,18 +694,11 @@ ((env_counter memo) pectx) (hashes_now (foldl (lambda (a hash) (or a (= false (get-value-or-false memo hash)))) false for_progress_hashes)) (len_for_progress (if (!= true for_progress) (len for_progress) 0)) - (progress_now (or (= for_progress true) ((rec-lambda rr (i len_env_stack) (if (= i len_for_progress) false - (dlet ( - ; possible if called from a value context in the compiler - ; TODO: I think this should be removed and instead the value/code compilers should - ; keep track of actual env stacks - (this_now ((rec-lambda ir (j) (cond ((= j len_env_stack) false) - ((and (= (idx for_progress i) (.marked_env_idx (idx env_stack j))) - (.marked_env_has_vals (idx env_stack j))) (idx for_progress i)) - (true (ir (+ j 1)))) - ) 0)) - ) (if this_now this_now (rr (+ i 1) len_env_stack))) - )) 0 (len env_stack)))) + (progress_now (or (= for_progress true) ((rec-lambda rr (i len_env_stack) (cond ((= i len_env_stack) false) + ((and (.marked_env_has_vals (idx env_stack i)) + (in_intset (.marked_env_idx (idx env_stack i)) for_progress)) true) + (true (rr (+ i 1) len_env_stack)))) + 0 (len env_stack)))) ) (if (or force hashes_now progress_now) (cond ((val? x) (array pectx nil x)) @@ -747,9 +815,10 @@ ) (array pectx func_err func_result false)))) (_ (print_strip (indent_str indent) "evaled result of function call (in env " (.marked_env_idx env) ", with inner " env_id ") and err " func_err " is " func_result)) - (must_stop_maybe_id (or rec_stop (if (not (combiner_return_ok func_result env_id)) - (if (!= nil de?) (.marked_env_idx env) true) - false))) + (must_stop_maybe_id (and (= nil func_err) + (or rec_stop (if (not (combiner_return_ok func_result env_id)) + (if (!= nil de?) (.marked_env_idx env) true) + false)))) ) (if (!= nil func_err) (array pectx func_err nil) (if must_stop_maybe_id (array pectx nil (marked_array false must_stop_maybe_id (if rec_stop (array hash) nil) (cons (with_wrap_level comb remaining_wrap) evaled_params))) @@ -3437,7 +3506,7 @@ (get_passthrough (.hash c) ctx) ;) (dlet ( ((datasi funcs memo env pectx) ctx) - ((c_loc c_len datasi) (alloc_data (symbol->string (.marked_symbol_value c)) datasi)) + ((c_loc c_len datasi) (alloc_data (get-text (.marked_symbol_value c)) datasi)) (result (bor (<< c_len 32) c_loc #b111)) (memo (put memo (.hash c) result)) ) (array result nil nil (array datasi funcs memo env pectx))))) @@ -4483,7 +4552,8 @@ ;(single-test) ;(run-compiler "small_test.kp") (run-compiler "to_compile.kp") - (profile-dump-html) + ;(true_print "GLOBAL_MAX was " GLOBAL_MAX) + ;(profile-dump-html) ;(profile-dump-list) ) ) diff --git a/to_compile.kp b/to_compile.kp index 15da312..bc5f063 100644 --- a/to_compile.kp +++ b/to_compile.kp @@ -145,96 +145,78 @@ reverse (lambda (x) (foldl (lambda (acc i) (cons i acc)) (array) x)) zip (lambda (& xs) (lapply foldr (concat (array (lambda (a & ys) (cons ys a)) (array)) xs))) - id (lambda (x) x) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ; Begin kludges to align with Scheme kludges + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; dlet (vau se (inners body) (vapply let (array (lapply concat inners) body) se)) - - test7 ((rec-lambda recurse (n) (cond (= 0 n) 1 - true (* n (recurse (- n 1))))) 5) - - cond (vau se (& inners) (vapply cond (lapply concat inners) se)) + print log + println log + dlambda lambda + mif (vau de (c & bs) (vapply if (cons (array let (array 'tmp c) (array and (array != 'tmp) 'tmp)) bs) de)) + ;mif (vau de (c & bs) (eval (concat (array if (array let (array 'tmp c) (array and (array != 'tmp) 'tmp))) bs) de)) - test18 ((rec-lambda recurse (n) (cond ((= 0 n) 1) - (true (* n (recurse (- n 1)))))) 5) - - - - ;test0 (map (lambda (x) (+ x 1)) (array 1 2)) - ;test1 (map_i (lambda (i x) (+ x i 1)) (array 1 2)) - ;test2 (filter_i (lambda (i x) (> i 0)) (array 1 2)) - ;test2 (filter (lambda ( x) (> x 1)) (array 1 2)) - ;test3 (not 1) - ;test4 (flat_map (lambda (x) (array 1 x 2)) (array 1 2)) - ;test5 (flat_map_i (lambda (i x) (array i x 2)) (array 1 2)) - ;test6 (let ( (a b) (array 1 2) c (+ a b) ) c) - ;test8 ((lambda (a b c) (+ a b c)) 1 13 14) - ;test9 ((lambda (a (b c)) (+ a b c)) 1 (array 13 14)) - - ;test10 (foldl + 0 (array 1 2 3 4 1337 6 4 4 4 1337 1 2 3 4 1337 6 4 4 4 1337 1 2 3 4 1337 6 4 4 4 1337 1 2 3 4 1337 6 4 4 4 13371 2 3 4 1337 6 4 4 4 1337 1 2 3 4 1337 6 4 4 4 1337 1 2 3 4 1337 6 4 4 4 1337 1 2 3 4 1337 6 4 4 4 1337)) - ;test11 (foldl + 0 (array 1 2 3 4 1337 1 2 3 4 1337 1 2 3 4 1337 1 2 3 4 1337 1 2 3 4 1337 1 2 3 4 1337 1 2 3 4 1337 1 2 3 4 13371 2 3 4 1337 1 2 3 4 1337 1 2 3 4 1337 1 2 3 4 1337 1 2 3 4 1337 1 2 3 4 1337 1 2 3 4 1337 1 2 3 4 1337)) - ;test12 (foldl + 0 (array 1 2 3 4 1337 6 4 4 4 1337 1 2 3 4 1337 6 4 4 4 1337 1 2 3 4 1337 6 4 4 4 1337 1 2 3 4 1337 6 4 4 4 13371 2 3 4 1337 6 4 4 4 1337 1 2 3 4 1337 6 4 4 4 1337 1 2 3 4 1337 6 4 4 4 1337 1 2 3 4 1337 6 4 4 4 1337)) - ;test13 (foldl + 0 (array 1 2 3 4 1337 1 2 3 4 1337 1 2 3 4 1337 1 2 3 4 1337 1 2 3 4 1337 1 2 3 4 1337 1 2 3 4 1337 1 2 3 4 13371 2 3 4 1337 1 2 3 4 1337 1 2 3 4 1337 1 2 3 4 1337 1 2 3 4 1337 1 2 3 4 1337 1 2 3 4 1337 1 2 3 4 1337)) - - ;test10 (foldl + 0 (array 1 2 3 4 1337 6 4 4 4 1337 1 2 3 4 1337 6 4 4 4 1337 1 2 3 4 1337 6 4 4 4 1337 1 2 3 4 1337 6 4 4 4 1337)) - ;test11 (foldl + 0 (array 1 2 3 4 1337 1 2 3 4 1337 1 2 3 4 1337 1 2 3 4 1337 1 2 3 4 1337 1 2 3 4 1337 1 2 3 4 1337 1 2 3 4 1337)) - - ;test10 (foldl + 0 (array 1 2 3 4 1337 6 4 4 4 1337 1 2 3 4 1337 6 4 4 4 1337)) - ;test11 (foldl + 0 (array 1 2 3 4 1337 1 2 3 4 1337 1 2 3 4 1337 1 2 3 4 1337)) - ;test12 (foldl + 0 (array 1 2 3 4 1337 1 2 3 4 1337 1 2 3 4 1337 1 2 3 4 1337)) - ;test13 (foldl + 0 (array 1 2 3 4 1337 1 2 3 4 1337 1 2 3 4 1337 1 2 3 4 1337)) - - ;test14 (foldr + 0 (array 1 2 3 4 1337 1 2 3 4 1337 1 2 3 4 1337 1 2 3 4 1337)) - ;test15 (reverse (array 1 2 3 4 1337 1 2 3 4 1337 1 2 3 4 1337 1 2 3 4 1337)) - ;test16 (zip (array 1 2 3 4 1337 1 2 3 4 1337 1 2 3 4 1337 1 2 3 4 1337) (array 2 3 4 5 1338 2 3 4 5 1338 2 3 4 5 1338 2 3 4 5 1338)) - - ;monad (array 'open 3 "test_self_out" (lambda (fd code) - ; (array 'write fd "wabcdefghijklmnopqrstuvwx" (lambda (written code) - ; (array 'exit (if (= 0 written) 12 14)))))) - ;old 4 - ;test (+ old 4) - ;test 4 - ;monad (array 'write 1 "test_self_out2" (vau (written code) (map (lambda (x) (+ x 133)) (array written code)))) - ;monad (array 'write 1 "test_self_out2" (vau (written code) (map_i (lambda (i x) (+ x i 133)) (array written code)))) - ;monad (array 'write 1 "test_self_out2" (vau (written code) (filter_i (lambda (i x) (> i 0)) (array written code)))) - ;monad (array 'write 1 "test_self_out2" (vau (written code) (filter (lambda (x) (> x 0)) (array written code)))) - ;monad (array 'write 1 "test_self_out2" (vau (written code) (not (array written code)))) - ;monad (array 'write 1 "test_self_out2" (vau (written code) (flat_map (lambda (x) (array 1 x 2)) (array written code)))) - ;monad (array 'write 1 "test_self_out2" (vau (written code) (flat_map_i (lambda (i x) (array i x 2)) (array written code)))) - ;monad (array 'write 1 "test_self_out2" (vau (written code) (let ( (a b) (array written code) c (+ a b test8 test9)) c))) - ;monad (array 'write 1 "test_self_out2" (vau (written code) ((lambda (a (b c)) (+ a b c)) 1 (array written code)))) - - - ;monad (array 'write 1 "test_self_out2" (vau (written code) test10)) - - ;monad (array 'write 1 "test_self_out2" (vau (written code) (foldl + 0 (array written code 1337)))) - ;monad (array 'write 1 "test_self_out2" (vau (written code) test14)) - ;monad (array 'write 1 "test_self_out2" (vau (written code) (foldr + 0 (array written code 1337)))) - - ;monad (array 'write 1 "test_self_out2" (vau (written code) test15)) - ;monad (array 'write 1 "test_self_out2" (vau (written code) (reverse (array written code 1337)))) - - ;monad (array 'write 1 "test_self_out2" (vau (written code) test16)) - monad (array 'write 1 "test_self_out2" (vau (written code) (zip (array 1 2 3) (array written code 1337)))) - - - ;test17 (dlet ( (a 1) (b 2) ((c d) (array 3 4)) ) (+ a b c d)) - - ;monad (array 'write 1 "test_self_out2" (vau (written code) test17)) - ;monad (array 'write 1 "test_self_out2" (vau (written code) (+ test7 test18))) - - ;monad (array 'write 1 "test_self_out2" (vau (written code) 7)) - - print log - println log - ) -; monad (dlet ( - (in_array (dlet ((helper (rec-lambda recurse (x a i) (cond ((= i (len a)) false) - ((= x (idx a i)) true) - (true (recurse x a (+ i 1))))))) - (lambda (x a) (helper x a 0)))) + + (empty_dict-list (array)) + (put-list (lambda (m k v) (cons (array k v) m))) + (get-list (lambda (d k) ((rec-lambda recurse (k d len_d i) (cond ((= len_d i) false) + ((= k (idx (idx d i) 0)) (idx d i)) + (true (recurse k d len_d (+ 1 i))))) + k d (len d) 0))) + + ;(combine_hash (lambda (a b) (+ (* 37 a) b))) + (combine_hash (lambda (a b) (band #xFFFFFFFFFFFFFF (+ (* 37 a) b)))) + (hash_bool (lambda (b) (if b 2 3))) + (hash_num (lambda (n) (combine_hash 5 n))) + ;(hash_string (lambda (s) (foldl combine_hash 7 (map char->integer (string->list s))))) + (hash_string (lambda (s) (foldl combine_hash 7 s))) + ;(hash_string (lambda (s) (foldl combine_hash 102233 (map char->integer (string->list s))))) + + (empty_dict-tree nil) + (trans-key (lambda (k) (cond ((string? k) (hash_string k)) + ((symbol? k) (hash_string (get-text k))) + (true k)))) + (put-helper (rec-lambda put-helper (m hk k v) (cond ((nil? m) (array hk k v nil nil)) + ((and (= hk (idx m 0)) + (= k (idx m 1))) (array hk k v (idx m 3) (idx m 4))) + ((< hk (idx m 0)) (array (idx m 0) (idx m 1) (idx m 2) (put-helper (idx m 3) hk k v) (idx m 4))) + (true (array (idx m 0) (idx m 1) (idx m 2) (idx m 3) (put-helper (idx m 4) hk k v)))))) + (put-tree (lambda (m k v) (put-helper m (trans-key k) k v))) + (get-helper (rec-lambda get-helper (m hk k) (cond ((nil? m) false) + ((and (= hk (idx m 0)) + (= k (idx m 1))) (array k (idx m 2))) + ((< hk (idx m 0)) (get-helper (idx m 3) hk k)) + (true (get-helper (idx m 4) hk k))))) + (get-tree (lambda (m k) (get-helper m (trans-key k) k))) + + ;(empty_dict empty_dict-list) + ;(put put-list) + ;(get get-list) + (empty_dict empty_dict-tree) + (put put-tree) + (get get-tree) + + (get-value (lambda (d k) (dlet ((result (get d k))) + (if (array? result) (idx result 1) + (error (str "could not find " k " in " d)))))) + (get-value-or-false (lambda (d k) (dlet ((result (get d k))) + (if (array? result) (idx result 1) + false)))) + + + + (in_array (dlet ((helper (rec-lambda recurse (x a len_a i) (cond ((= i len_a) false) + ((= x (idx a i)) true) + (true (recurse x a len_a (+ i 1))))))) + (lambda (x a) (helper x a (len a) 0)))) + (array_item_union (lambda (a bi) (if (in_array bi a) a (cons bi a)))) + (array_union (lambda (a b) (foldl array_item_union a b))) + (array_union_without (lambda (wo a b) + (foldl (lambda (o xi) (if (or (= wo xi) (in_array xi o)) o (cons xi o))) + (array) (concat a b)))) (val? (lambda (x) (= 'val (idx x 0)))) (marked_array? (lambda (x) (= 'marked_array (idx x 0)))) @@ -273,11 +255,10 @@ (.marked_env_idx (lambda (x) (idx x 4))) (.marked_env_upper (lambda (x) (idx (idx x 5) -1))) (.env_marked (lambda (x) (idx x 5))) - (marked_env_real? (lambda (x) (= nil (.marked_env_needed_for_progress x)))) + (marked_env_real? (lambda (x) (= nil (idx (.marked_env_needed_for_progress x) 0)))) (.any_comb_wrap_level (lambda (x) (cond ((prim_comb? x) (.prim_comb_wrap_level x)) ((comb? x) (.comb_wrap_level x)) (true (error "bad .any_comb_level"))))) - ; The actual needed_for_progress values are either ; #t - any eval will do something ; nil - is a value, no eval will do anything @@ -286,32 +267,103 @@ ; of an evaluation of, then it could progress futher. These are all caused by ; the infinite recursion stopper. (needed_for_progress (rec-lambda needed_for_progress (x) (cond ((marked_array? x) (.marked_array_needed_for_progress x)) - ((marked_symbol? x) (array (.marked_symbol_needed_for_progress x) nil)) - ((marked_env? x) (array (.marked_env_needed_for_progress x) nil)) + ((marked_symbol? x) (array (.marked_symbol_needed_for_progress x) nil nil)) + ((marked_env? x) (.marked_env_needed_for_progress x)) ((comb? x) (dlet ((id (.comb_id x)) - (body_needed (idx (needed_for_progress (.comb_body x)) 0)) - (se_needed (idx (needed_for_progress (.comb_env x)) 0))) - (if (or (= true body_needed) (= true se_needed)) (array true nil) - (array (foldl (lambda (a xi) (if (or (= id xi) (in_array xi a)) a (cons xi a))) - (array) (concat body_needed se_needed)) nil) + ((body_needed _hashes extra1) (needed_for_progress (.comb_body x))) + ((se_needed _hashes extra2) (needed_for_progress (.comb_env x)))) + (if (or (= true body_needed) (= true se_needed)) (array true nil nil) + (array (array_union_without id body_needed se_needed) + nil (array_union_without id extra1 extra2)) ))) - ((prim_comb? x) (array nil nil)) - ((val? x) (array nil nil)) + ((prim_comb? x) (array nil nil nil)) + ((val? x) (array nil nil nil)) (true (error (str "what is this? in need for progress" x)))))) (needed_for_progress_slim (lambda (x) (idx (needed_for_progress x) 0))) + (hash_symbol (lambda (progress_idxs s) (combine_hash (if (= true progress_idxs) 11 (foldl combine_hash 13 (map (lambda (x) (if (= true x) 13 (+ 1 x))) progress_idxs))) (hash_string (get-text s))))) + (hash_array (lambda (is_val attempted a) (foldl combine_hash (if is_val 17 (cond ((int? attempted) (combine_hash attempted 19)) + (attempted 61) + (true 107))) (map .hash a)))) + + (hash_env (lambda (has_vals progress_idxs dbi arrs) (combine_hash (if has_vals 107 109) + (combine_hash (mif dbi (hash_num dbi) 59) (dlet ( + ;(_ (begin (true_print "pre slice " (slice arrs 0 -2)) 0)) + ;(_ (begin (true_print "about to do a fold " progress_idxs " and " (slice arrs 0 -2)) 0)) + (inner_hash (foldl (dlambda (c (s v)) (combine_hash c (combine_hash (hash_symbol true s) (.hash v)))) + (cond ((= nil progress_idxs) 23) + ((= true progress_idxs) 29) + (true (foldl combine_hash 31 progress_idxs))) + (slice arrs 0 -2))) + (end (idx arrs -1)) + (end_hash (mif end (.hash end) 41)) + ) (combine_hash inner_hash end_hash)))))) + + (hash_comb (lambda (wrap_level env_id de? se variadic params body) + (combine_hash 43 + (combine_hash wrap_level + (combine_hash env_id + (combine_hash (mif de? (hash_symbol true de?) 47) + (combine_hash (.hash se) + (combine_hash (hash_bool variadic) + (combine_hash (foldl (lambda (c x) (combine_hash c (hash_symbol true x))) 53 params) + (.hash body)))))))))) + + (hash_prim_comb (lambda (handler_fun real_or_name wrap_level val_head_ok) (combine_hash (combine_hash 59 (hash_symbol true real_or_name)) + (combine_hash (if val_head_ok 89 97) wrap_level)))) + (hash_val (lambda (x) (cond ((bool? x) (hash_bool x)) + ((string? x) (hash_string x)) + ((int? x) (hash_num x)) + (true (error (str "bad thing to hash_val " x)))))) + ; 113 127 131 137 139 149 151 157 163 167 173 + + (marked_symbol (lambda (progress_idxs x) (array 'marked_symbol (hash_symbol progress_idxs x) progress_idxs x))) + (marked_array (lambda (is_val attempted resume_hashes x) (dlet ( + ((sub_progress_idxs hashes extra) (foldl (dlambda ((a ahs aeei) (x xhs x_extra_env_ids)) + (array (cond ((or (= true a) (= true x)) true) + (true (array_union a x))) + (array_union ahs xhs) + (array_union aeei x_extra_env_ids)) + ) (array (array) resume_hashes (array)) (map needed_for_progress x))) + (progress_idxs (cond ((and (= nil sub_progress_idxs) (not is_val) (= true attempted)) nil) + ((and (= nil sub_progress_idxs) (not is_val) (= false attempted)) true) + ((and (= nil sub_progress_idxs) (not is_val) (int? attempted)) (array attempted)) + (true (if (int? attempted) + (array_item_union sub_progress_idxs attempted) + sub_progress_idxs)))) + ) (array 'marked_array (hash_array is_val attempted x) is_val attempted (array progress_idxs hashes extra) x)))) + (marked_env (lambda (has_vals de? de ue dbi arrs) (dlet ( + (de_entry (mif de? (array (array de? de)) (array))) + (full_arrs (concat arrs de_entry (array ue))) + ((progress_idxs1 _hashes extra1) (mif ue (needed_for_progress ue) (array nil nil nil))) + ((progress_idxs2 _hashes extra2) (mif de? (needed_for_progress de) (array nil nil nil))) + (progress_idxs (array_union progress_idxs1 progress_idxs2)) + (extra (array_union extra1 extra2)) + (progress_idxs (if (not has_vals) (cons dbi progress_idxs) progress_idxs)) + (extra (if (!= nil progress_idxs) (cons dbi extra) extra)) + ) (array 'env (hash_env has_vals progress_idxs dbi full_arrs) has_vals (array progress_idxs nil extra) dbi full_arrs)))) + + + (marked_val (lambda (x) (array 'val (hash_val x) x))) + (marked_comb (lambda (wrap_level env_id de? se variadic params body) (array 'comb (hash_comb wrap_level env_id de? se variadic params body) wrap_level env_id de? se variadic params body))) + (marked_prim_comb (lambda (handler_fun real_or_name wrap_level val_head_ok) (array 'prim_comb (hash_prim_comb handler_fun real_or_name wrap_level val_head_ok) handler_fun real_or_name wrap_level val_head_ok))) + + (with_wrap_level (lambda (x new_wrap) (cond ((prim_comb? x) (dlet (((handler_fun real_or_name wrap_level val_head_ok) (.prim_comb x))) + (marked_prim_comb handler_fun real_or_name new_wrap val_head_ok))) + ((comb? x) (dlet (((wrap_level env_id de? se variadic params body) (.comb x))) + (marked_comb new_wrap env_id de? se variadic params body))) + (true (error "bad with_wrap_level"))))) - (test17 (or false 1 "a" true)) - (test18 (and 1 "a" nil true)) - (monad (array 'write 1 "test_self_out2" (vau (written code) (array (or written code) test17 (or false nil 0) (and written code) test18 (and nil 0 false))))) - ;(monad (array 'write 1 "test_self_out2" (vau (written code) (dlet ((_ (print 1234))) (in_array 0 (array written code)))))) + + + (and_fold (foldl and true '(true true false true))) + (monad (array 'write 1 "test_self_out2" (vau (written code) and_fold))) ) monad) ) - ;(array 'write 1 "test_self_out2" (vau (written code) 7)) ; end of all lets )))))) ; impl of let1