480 - trying to speed up chessboard

Computing length of a 32-long list takes 2x a 16-long list.
But 64-long takes 3x 32-long.
Why? No idea yet. No insights from counting calls.

3 files changed, 211 insertions, 37 deletions

diff --git a/chessboard-rawterm.mu b/chessboard-rawterm.mu
index 4e923a89..bf87b829 100644
--- a/chessboard-rawterm.mu
+++ b/chessboard-rawterm.mu
@@ -5,32 +5,33 @@
                                               N:literal P:literal _:literal _:literal _:literal _:literal p:literal n:literal
                                               B:literal P:literal _:literal _:literal _:literal _:literal p:literal b:literal
                                               Q:literal P:literal _:literal _:literal _:literal _:literal p:literal q:literal
-                                              K:literal P:literal _:literal _:literal _:literal _:literal p:literal k:literal
-                                              B:literal P:literal _:literal _:literal _:literal _:literal p:literal b:literal
-                                              N:literal P:literal _:literal _:literal _:literal _:literal p:literal n:literal
-                                              R:literal P:literal _:literal _:literal _:literal _:literal p:literal r:literal)
+                                              )
+;?                                               K:literal P:literal _:literal _:literal _:literal _:literal p:literal k:literal
+;?                                               B:literal P:literal _:literal _:literal _:literal _:literal p:literal b:literal
+;?                                               N:literal P:literal _:literal _:literal _:literal _:literal p:literal n:literal
+;?                                               R:literal P:literal _:literal _:literal _:literal _:literal p:literal r:literal)
   ; assert(length(initial-position) == 64)
 ;?   (print-primitive (("list-length\n" literal)))
   (len:integer <- list-length initial-position:list-address)
-  (correct-length?:boolean <- equal len:integer 64:literal)
-;?   (correct-length?:boolean <- equal len:integer 4:literal)
-  (assert correct-length?:boolean (("chessboard had incorrect size" literal)))
-  (b:board-address <- new board:literal 8:literal)
-;?   (b:board-address <- new board:literal 2:literal)
-  (col:integer <- copy 0:literal)
-  (curr:list-address <- copy initial-position:list-address)
-  { begin
-    (done?:boolean <- equal col:integer 8:literal)
-;?     (done?:boolean <- equal col:integer 2:literal)
-    (break-if done?:boolean)
-;?     (print-primitive col:integer)
-;?     (print-primitive (("\n" literal)))
-    (file:file-address-address <- index-address b:board-address/deref col:integer)
-    (file:file-address-address/deref curr:list-address <- read-file curr:list-address)
-    (col:integer <- add col:integer 1:literal)
-    (loop)
-  }
-  (reply b:board-address)
+;?   (correct-length?:boolean <- equal len:integer 64:literal)
+;? ;?   (correct-length?:boolean <- equal len:integer 4:literal)
+;?   (assert correct-length?:boolean (("chessboard had incorrect size" literal)))
+;?   (b:board-address <- new board:literal 8:literal)
+;? ;?   (b:board-address <- new board:literal 2:literal)
+;?   (col:integer <- copy 0:literal)
+;?   (curr:list-address <- copy initial-position:list-address)
+;?   { begin
+;?     (done?:boolean <- equal col:integer 8:literal)
+;? ;?     (done?:boolean <- equal col:integer 2:literal)
+;?     (break-if done?:boolean)
+;? ;?     (print-primitive col:integer)
+;? ;?     (print-primitive (("\n" literal)))
+;?     (file:file-address-address <- index-address b:board-address/deref col:integer)
+;?     (file:file-address-address/deref curr:list-address <- read-file curr:list-address)
+;?     (col:integer <- add col:integer 1:literal)
+;?     (loop)
+;?   }
+;?   (reply b:board-address)
 ])
 
 (function read-file [
@@ -194,14 +195,14 @@
 ;?   (print-primitive (("\u2654 \u265a" literal)))
   (default-scope:scope-address <- new scope:literal 30:literal)
   (b:board-address <- read-board)
-  (console-on)
-  { begin
-    (clear-screen)
-    (print-board b:board-address)
-    (print-primitive (("? " literal)))
-    (m:move-address <- read-move)
-    (b:board-address <- make-move b:board-address m:move-address)
-    (loop)
-  }
-  (console-off)
+;?   (console-on)
+;?   { begin
+;?     (clear-screen)
+;?     (print-board b:board-address)
+;?     (print-primitive (("? " literal)))
+;?     (m:move-address <- read-move)
+;?     (b:board-address <- make-move b:board-address m:move-address)
+;?     (loop)
+;?   }
+;?   (console-off)
 ])
diff --git a/mu.arc b/mu.arc
index f7f8d43d..c033815c 100644
--- a/mu.arc
+++ b/mu.arc
@@ -1740,21 +1740,53 @@
 (freeze system-function*)
 )  ; section 100 for system software
 
+(load "profiler.arc")
+
 ;; load all provided files and start at 'main'
 (reset)
 ;? (new-trace "main")
 ;? (set dump-trace*)
 (awhen (pos "--" argv)
   (map add-code:readfile (cut argv (+ it 1)))
-;?   (= dump-trace* (obj whitelist '("run" "schedule" "add")))
+;?   (= dump-trace* (obj whitelist '("run")))
+;?   (= dump-trace* (obj whitelist '("schedule")))
 ;?   (= dump-trace* (obj whitelist '("cn0")))
 ;?   (set dump-trace*)
 ;?   (freeze function*)
 ;?   (prn function*!factorial)
+;? (profile run)
+;? (profile run-for-time-slice)
+;? (profile make-routine)
+;? (profile empty)
+;? (profile stack)
+;? (profile top)
+;? (profile body)
+;? (profile parse-instr)
+;? (profile metadata)
+;? (profile ty)
+;? (profile literal?)
+;? (profile typeinfo)
+;? (profile m)
+;? (profile setm)
+;? (profile addr)
+;? (profile addrs)
+;? (profile canonize)
+;? (profile array-len)
+;? (profile sizeof)
+;? (profile absolutize)
+;? (profile lookup-space)
+;? (profile deref)
+;? (profile drop-one)
+;? (profile new-scalar)
+;? (profile new-array)
+;? (profile new-string)
+;? (profile convert-braces)
+;? (profile convert-names)
   (run 'main)
-  (if ($.current-charterm) ($.close-charterm))
-  (prn "\nmemory: " int-canon.memory*)
+;?   (if ($.current-charterm) ($.close-charterm))
+;?   (prn "\nmemory: " int-canon.memory*)
   (each routine completed-routines*
     (aif rep.routine!error (prn "error - " it)))
 )
-(reset)
+;? (reset)
+(profiles)
diff --git a/profiler.arc b/profiler.arc
new file mode 100644
index 00000000..928e16f7
--- /dev/null
+++ b/profiler.arc
@@ -0,0 +1,141 @@
+; A simple call-counting profiler.
+; https://bitbucket.org/fallintothis/profiler
+
+(= profiles* (table) originals* (table))
+
+; avoid infinite loops & other badness in profiled fn, e.g. (profile +)
+(with (orig-+ +
+       orig-is is
+       orig-err err
+       orig-type type
+       orig-sref sref
+       orig-apply apply
+       orig-atomic-invoke atomic-invoke)
+
+(mac profiled (f)
+  ; (= (profiles* f) 0)
+  `(profiled-as ',f ,f))
+
+; Not sure I like the order of the arguments, but probably rarely use this.
+
+(def profiled-as (name f (o profile-data profiles*))
+  (if (orig-is (orig-is (orig-type f) 'fn) nil)
+      (orig-err "Can only profile functions:" f))
+  (fn args
+    (orig-atomic-invoke
+      (fn () (orig-sref profile-data
+                        (orig-+ (profile-data name 0) 1)
+                        name)))
+    (orig-apply f args)))
+
+; Have to be careful here.  (= profiles* (table)) won't work, since profiled-as
+; has the table passed in as an arg: after a (= ...), old closed-over
+; references from profiled-as will fail to update the profiles* table.
+;   (= glob* (table))
+;   (def foo ((o y glob*)) (fn (x) (= (y x) t)))
+;   (= bar (foo))
+;   (bar 5)           ; glob* = #hash((5 . t))
+;   (= glob* (table)) ; glob* = #hash()
+;   (bar 5)           ; glob* = #hash(), still
+
+(def reset-profiles ((o fns))
+  (each f (or fns (keys profiles*))
+    (orig-atomic-invoke
+      (fn () (orig-sref profiles*
+                        nil
+                        f))))
+  'ok)
+
+)
+
+(mac profile (f)
+  `(do
+     (= (originals* ',f) ,f)
+     (= ,f (profiled ,f))
+     (warn (+ ,(string f)
+              " is being profiled; "
+              "do not redefine it until you (unprofile " ,(string f) ")"))
+     t))
+
+(mac unprofile (f)
+  `(= ,f (originals* ',f ,f)
+      (originals* ',f) nil
+      (profiles* ',f) nil))
+
+(def profiles ((o profiler-data profiles*))
+  (withs (data   ; avoid counting stuff from the current call to (profiles)
+                 (with (atomic-invokes (profiler-data 'atomic-invoke)
+                        tables (profiler-data 'table)
+                        srefs (profiler-data 'sref)
+                        new (table))
+                   (maptable (fn (k v) (= (new k) v)) profiler-data)
+                   (= (new 'atomic-invoke) atomic-invokes
+                      (new 'table) tables
+                      (new 'sref) srefs)
+                   new)
+          lhead  "Function"
+          rhead  "Call Count"
+          lwidth (apply max (map len:tostring:disp (cons lhead (keys data))))
+          prnrow (fn (l r) 
+                   (w/bars
+                     (do (pr l) (sp (- lwidth (len l))))
+                     (prn r))))
+    (prn)
+    (prnrow lhead rhead)
+    (each (f call-count) (sortable data)
+      (prnrow (tostring:disp f) call-count))
+    (prn)))
+
+(mac profiling-just (fns . bod)
+  (unless (acons fns)
+    (zap list fns))
+  (w/uniq (profiles profiled)
+    (let originals (map [uniq] fns)
+      `(with (,profiles (table)
+              ,profiled profiled-as
+              ,@(mappend list originals fns))
+         ; ,@(map (fn (f) `(= (,profiles ',f) 0)) fns)
+         ,@(map (fn (f o) `(= ,f (,profiled ',f ,o ,profiles)))
+                fns
+                originals)
+         (after (do ,@bod)
+           (= ,@(apply + nil (map list fns originals)))
+           (if (> (,profiles 'protect 0) 1) ; from (after ...)
+               (-- (,profiles 'protect))
+               (wipe (,profiles 'protect)))
+           (profiles ,profiles))))))
+
+(def all-fns ()
+  (let xdefs '(apply cons car cdr is err + - * / mod expt sqrt > < len annotate
+               type rep uniq ccc infile outfile instring outstring inside
+               stdout stdin stderr call-w/stdout call-w/stdin readc readb peekc
+               writec writeb write disp sread coerce open-socket socket-accept
+               setuid new-thread kill-thread break-thread current-thread sleep
+               system pipe-from table protect rand dir file-exists dir-exists
+               rmfile mvfile macex macex1 eval on-err details scar scdr sref
+               bound newstring trunc exact msec current-process-milliseconds
+               current-gc-milliseconds seconds client-ip atomic-invoke dead
+               flushout ssyntax ssexpand quit close force-close memory declare
+               timedate sin cos tan asin acos atan log)
+    (+ xdefs (keep [isa (eval _) 'fn] (keys sig*)))))
+
+(mac profile-all ()
+  (with (fns (all-fns) orig-atomic-invoke (uniq) orig-sref (uniq))
+    `(with (,orig-sref sref
+            ,orig-atomic-invoke atomic-invoke)
+       (do ,@(map (fn (f) `(profile ,f)) fns)
+           ,@(map (fn (f) `(,orig-atomic-invoke
+                             (fn () (,orig-sref profiles* nil ',f))))
+                  fns)
+           t))))
+
+(mac unprofile-all ()
+  `(do ,@(map (fn (f) `(unprofile ,f)) (keys originals*))))
+
+(mac profiling code
+  `(profiling-just ,(all-fns) ,@code))
+
+(mac profile-here (marker . code)
+  ; (= (profiles* marker) 0)
+  `(do1 (do ,@code)
+        (++ (profiles* ',marker 0))))