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

Bunch of optimization that took us from 3:50 to 0:04 for the current to_compile.kp. Mainly pulling len out of hot loops and using a naive binary tree instead of alists for maps

Browse Source
This commit is contained in:
Nathan Braswell
2022-03-07 02:10:42 -05:00
parent c8c9bba429
commit 90fe8e1bfa
1 changed files with 79 additions and 41 deletions
Download Patch File Download Diff File Expand all files Collapse all files

120
partial_eval.scm
View File

@@ -88,6 +88,13 @@
(<< arithmetic-shift) (<< arithmetic-shift)
(>> (lambda (a b) (arithmetic-shift a (- b)))) (>> (lambda (a b) (arithmetic-shift a (- b))))
(print (lambda args (print (apply str args))))
(str (if speed_hack (lambda args "") str))
(true_print print)
(print (if speed_hack (lambda x 0) print))
;(true_print print)
(println print)
(nil? (lambda (x) (= nil x))) (nil? (lambda (x) (= nil x)))
(bool? (lambda (x) (or (= #t x) (= #f x)))) (bool? (lambda (x) (or (= #t x) (= #f x))))
@@ -96,19 +103,61 @@
(zip (lambda args (apply map list args))) (zip (lambda args (apply map list args)))
(empty_dict (array))
(put (lambda (m k v) (cons (array k v) m)))
;(my-alist-ref alist-ref) ;(my-alist-ref alist-ref)
(my-alist-ref (lambda (k d) ((rec-lambda recurse (d k i) (cond ((= (len d) i) false)
((= k (idx (idx d i) 0)) (array (idx (idx d i) 1))) (empty_dict-list (array))
(true (recurse d k (+ 1 i))))) (put-list (lambda (m k v) (cons (array k v) m)))
d k 0))) (get-list (lambda (d k) ((rec-lambda recurse (k d len_d i) (cond ((= len_d i) false)
(get-value (lambda (d k) (let ((result (my-alist-ref k d))) ((= k (idx (idx d i) 0)) (idx d i))
(if (array? result) (idx result 0) (true (recurse k d len_d (+ 1 i)))))
(error (str "could not find " k " in " d)))))) k d (len d) 0)))
(get-value-or-false (lambda (d k) (let ((result (my-alist-ref k d)))
(if (array? result) (idx result 0)
false)))) ;(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) (% modulo)
(int? integer?) (int? integer?)
@@ -138,21 +187,12 @@
(#t (append (f (car l)) (recurse f (cdr l))))) (#t (append (f (car l)) (recurse f (cdr l)))))
)) f l))) )) f l)))
(str (if speed_hack (lambda args "") str))
(print (lambda args (print (apply str args))))
(true_print print)
(print (if speed_hack (lambda x 0) print))
;(true_print print)
(println print)
; Ok, actual definitions ; Ok, actual definitions
(in_array (dlet ((helper (rec-lambda recurse (x a i) (cond ((= i (len a)) false) (in_array (dlet ((helper (rec-lambda recurse (x a len_a i) (cond ((= i len_a) false)
((= x (idx a i)) true) ((= x (idx a i)) true)
(true (recurse x a (+ i 1))))))) (true (recurse x a len_a (+ i 1)))))))
(lambda (x a) (helper x a 0)))) (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_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 (lambda (a b) (foldl array_item_union a b)))
(array_union_without (lambda (wo a b) (array_union_without (lambda (wo a b)
@@ -223,11 +263,6 @@
((val? x) (array nil nil nil)) ((val? x) (array nil nil nil))
(true (error (str "what is this? in need for progress" x)))))) (true (error (str "what is this? in need for progress" x))))))
(needed_for_progress_slim (lambda (x) (idx (needed_for_progress x) 0))) (needed_for_progress_slim (lambda (x) (idx (needed_for_progress x) 0)))
(combine_hash (lambda (a b) (+ (* 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_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_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_array (lambda (is_val attempted a) (foldl combine_hash (if is_val 17 (cond ((int? attempted) (combine_hash attempted 19)) (hash_array (lambda (is_val attempted a) (foldl combine_hash (if is_val 17 (cond ((int? attempted) (combine_hash attempted 19))
@@ -439,8 +474,9 @@
(hash (.hash x)) (hash (.hash x))
;(result (if (or (comb? x) (marked_env? x)) (alist-ref hash memo) false)) ;(result (if (or (comb? x) (marked_env? x)) (alist-ref hash memo) false))
;(result (if (or (marked_array? x) (marked_env? x)) (alist-ref hash memo) false)) ;(result (if (or (marked_array? x) (marked_env? x)) (alist-ref hash memo) false))
(result (if (marked_env? x) (my-alist-ref hash memo) false)) ;(result (if (marked_env? x) (my-alist-ref hash memo) false))
) (if (array? result) (array memo (idx result 0)) (cond (result (if (marked_env? x) (get memo hash) false))
) (if (array? result) (array memo (idx result 1)) (cond
((marked_symbol? x) (array memo false)) ((marked_symbol? x) (array memo false))
((marked_array? x) (dlet ( ((marked_array? x) (dlet (
(values (.marked_array_values x)) (values (.marked_array_values x))
@@ -582,27 +618,28 @@
(_ (print_strip (indent_str indent) "for_progress " for_progress ", for_progress_hashes " for_progress_hashes " for " x)) (_ (print_strip (indent_str indent) "for_progress " for_progress ", for_progress_hashes " for_progress_hashes " for " x))
((env_counter memo) pectx) ((env_counter memo) pectx)
(hashes_now (foldl (lambda (a hash) (or a (= false (get-value-or-false memo hash)))) false for_progress_hashes)) (hashes_now (foldl (lambda (a hash) (or a (= false (get-value-or-false memo hash)))) false for_progress_hashes))
(progress_now (or (= for_progress true) ((rec-lambda rr (i) (if (= i (len for_progress)) false (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 ( (dlet (
; possible if called from a value context in the compiler ; possible if called from a value context in the compiler
; TODO: I think this should be removed and instead the value/code compilers should ; TODO: I think this should be removed and instead the value/code compilers should
; keep track of actual env stacks ; keep track of actual env stacks
(this_now ((rec-lambda ir (j) (cond ((= j (len env_stack)) false) (this_now ((rec-lambda ir (j) (cond ((= j len_env_stack) false)
((and (= (idx for_progress i) (.marked_env_idx (idx env_stack j))) ((and (= (idx for_progress i) (.marked_env_idx (idx env_stack j)))
(.marked_env_has_vals (idx env_stack j))) (idx for_progress i)) (.marked_env_has_vals (idx env_stack j))) (idx for_progress i))
(true (ir (+ j 1)))) (true (ir (+ j 1))))
) 0)) ) 0))
) (if this_now this_now (rr (+ i 1)))) ) (if this_now this_now (rr (+ i 1) len_env_stack)))
)) 0))) )) 0 (len env_stack))))
) )
(if (or force hashes_now progress_now) (if (or force hashes_now progress_now)
(cond ((val? x) (array pectx nil x)) (cond ((val? x) (array pectx nil x))
((marked_env? x) (dlet ((dbi (.marked_env_idx x))) ((marked_env? x) (dlet ((dbi (.marked_env_idx x)))
; compiler calls with empty env stack ; compiler calls with empty env stack
(mif dbi (dlet ( (new_env ((rec-lambda rec (i) (cond ((= i (len env_stack)) nil) (mif dbi (dlet ( (new_env ((rec-lambda rec (i len_env_stack) (cond ((= i len_env_stack) nil)
((= dbi (.marked_env_idx (idx env_stack i))) (idx env_stack i)) ((= dbi (.marked_env_idx (idx env_stack i))) (idx env_stack i))
(true (rec (+ i 1))))) (true (rec (+ i 1) len_env_stack))))
0)) 0 (len env_stack)))
(_ (println (str_strip "replacing " x) (str_strip " with (if nonnil) " new_env))) (_ (println (str_strip "replacing " x) (str_strip " with (if nonnil) " new_env)))
) )
(array pectx nil (if (!= nil new_env) new_env x))) (array pectx nil (if (!= nil new_env) new_env x)))
@@ -953,7 +990,7 @@
(array 'empty_env (marked_env true nil nil nil nil nil)) (array 'empty_env (marked_env true nil nil nil nil nil))
))) )))
(partial_eval (lambda (x) (partial_eval_helper (mark true x) false root_marked_env (array) (array 0 (array)) 0 false))) (partial_eval (lambda (x) (partial_eval_helper (mark true x) false root_marked_env (array) (array 0 empty_dict) 0 false)))
;; WASM ;; WASM
@@ -1319,6 +1356,7 @@
(our_code (flat_map (lambda (inss) (map (lambda (ins) (ins inner_name_dict_with_depth)) inss)) (our_code (flat_map (lambda (inss) (map (lambda (ins) (ins inner_name_dict_with_depth)) inss))
body)) body))
;(_ (println "resulting code " our_code)) ;(_ (println "resulting code " our_code))
(final_code (concat code (array (array compressed_locals our_code ) )))
) (array ) (array
outer_name_dict outer_name_dict
; type ; type
@@ -1340,7 +1378,7 @@
; element ; element
elem elem
; code ; code
(concat code (array (array compressed_locals our_code ) )) final_code
; data ; data
data data
)) ))