From 3cf8a418e76daa67c645d00a1b69f422b98c8858 Mon Sep 17 00:00:00 2001
From: Jameson Nash <vtjnash@gmail.com>
Date: Wed, 9 Nov 2016 11:25:39 -0500
Subject: [PATCH] add configurable flisp timing code

---
 src/Makefile          |  2 +-
 src/ast.c             | 25 +++++++++++++++
 src/flisp/profile.scm | 72 +++++++++++++++++++++++++++++++++++++++++++
 src/jlfrontend.scm    |  9 ++++++
 4 files changed, 107 insertions(+), 1 deletion(-)
 create mode 100644 src/flisp/profile.scm

diff --git a/src/Makefile b/src/Makefile
index 2eca88779aa27..60cb2a16f43a1 100644
--- a/src/Makefile
+++ b/src/Makefile
@@ -181,7 +181,7 @@ julia_flisp.boot.inc.phony: $(BUILDDIR)/julia_flisp.boot.inc
 $(BUILDDIR)/julia_flisp.boot.inc: $(BUILDDIR)/julia_flisp.boot $(FLISP_EXECUTABLE_release)
 	@$(call PRINT_FLISP, $(call spawn,$(FLISP_EXECUTABLE_release)) $(call cygpath_w,$(SRCDIR)/bin2hex.scm) < $< > $@)
 
-$(BUILDDIR)/julia_flisp.boot: $(addprefix $(SRCDIR)/,jlfrontend.scm \
+$(BUILDDIR)/julia_flisp.boot: $(addprefix $(SRCDIR)/,jlfrontend.scm flisp/aliases.scm flisp/profile.scm \
 		julia-parser.scm julia-syntax.scm match.scm utils.scm ast.scm macroexpand.scm mk_julia_flisp_boot.scm) \
 		$(FLISP_EXECUTABLE_release)
 	@$(call PRINT_FLISP, $(call spawn,$(FLISP_EXECUTABLE_release)) \
diff --git a/src/ast.c b/src/ast.c
index f895029980991..b43ce6e418d54 100644
--- a/src/ast.c
+++ b/src/ast.c
@@ -429,6 +429,31 @@ JL_DLLEXPORT void jl_lisp_prompt(void)
     jl_ast_ctx_leave(ctx);
 }
 
+JL_DLLEXPORT void fl_show_profile(void)
+{
+    jl_ast_context_t *ctx = jl_ast_ctx_enter();
+    fl_context_t *fl_ctx = &ctx->fl;
+    fl_applyn(fl_ctx, 0, symbol_value(symbol(fl_ctx, "show-profiles")));
+    jl_ast_ctx_leave(ctx);
+}
+
+JL_DLLEXPORT void fl_clear_profile(void)
+{
+    jl_ast_context_t *ctx = jl_ast_ctx_enter();
+    fl_context_t *fl_ctx = &ctx->fl;
+    fl_applyn(fl_ctx, 0, symbol_value(symbol(fl_ctx, "clear-profiles")));
+    jl_ast_ctx_leave(ctx);
+}
+
+JL_DLLEXPORT void fl_profile(const char *fname)
+{
+    jl_ast_context_t *ctx = jl_ast_ctx_enter();
+    fl_context_t *fl_ctx = &ctx->fl;
+    fl_applyn(fl_ctx, 1, symbol_value(symbol(fl_ctx, "profile-e")), symbol(fl_ctx, fname));
+    jl_ast_ctx_leave(ctx);
+}
+
+
 static jl_sym_t *scmsym_to_julia(fl_context_t *fl_ctx, value_t s)
 {
     assert(issymbol(s));
diff --git a/src/flisp/profile.scm b/src/flisp/profile.scm
new file mode 100644
index 0000000000000..f5486996703cf
--- /dev/null
+++ b/src/flisp/profile.scm
@@ -0,0 +1,72 @@
+(define (string.rpad s n c) (string s (string.rep c (- n (string.count s)))))
+
+(define (string.rep s k)
+  (cond ((< k 4)
+         (cond ((<= k 0) "")
+               ((=  k 1) (string s))
+               ((=  k 2) (string s s))
+               (else     (string s s s))))
+        ((odd? k) (string s (string.rep s (- k 1))))
+        (else     (string.rep (string s s) (/ k 2)))))
+
+(let ((*profiles* (table))
+      (running #f))
+  (set! profile
+        (lambda (s)
+          (let ((f (top-level-value s)))
+            (put! *profiles* s (cons 0 (cons 0 0))) ; count, self, total
+            (set-top-level-value! s
+             (lambda args
+               (define tt (get *profiles* s))
+               (define last-tt running)
+               (define last-t0 (cddr tt))
+               (define t0 (time.now))
+               (set! running tt)
+               (define v (apply f args))
+               (set! running last-tt)
+               (define t1 (time.now))
+               (define tdelta (- t1 t0))
+               (if last-tt (set-car! (cdr last-tt) (- (cadr last-tt) tdelta)))
+               (set-car! (cdr tt) (+ (cadr tt) tdelta))
+               (set-cdr! (cdr tt) (+ last-t0 tdelta))
+               (set-car! tt (+ (car tt) 1))
+               v)))))
+  (set! show-profiles
+        (lambda ()
+          (define total 0)
+          (define pr (filter (lambda (x) (> (cadr x) 0))
+                             (table.pairs *profiles*)))
+          (define width (+ 4
+                           (apply max
+                                  (map (lambda (x)
+                                         (length (string x)))
+                                       (cons 'Function
+                                             (map car pr))))))
+          (princ (string.rpad "Function" width #\ )
+                 "#Calls     Total Time (seconds)    Self Time (seconds)")
+          (newline)
+          (princ (string.rpad "--------" width #\ )
+                 "------     --------------------    -------------------")
+          (newline)
+          (for-each
+           (lambda (p)
+         (set! total (+ total (cadr p)))
+             (princ (string.rpad (string (cadddr p)) width #\ )
+                    (string.rpad (string (caddr p)) 11 #\ )
+                    (string.rpad (string (car p)) 24 #\ )
+            (cadr p))
+             (newline))
+           (reverse (simple-sort (map (lambda (l) (reverse (to-proper l)))
+                                      pr))))
+       (princ (string.rpad "--------" width #\ )
+                 "------     --------------------    -------------------")
+       (newline)
+       (princ (string.rpad "Total   " width #\ )
+                 "           " (string total))
+       (newline)))
+  (set! clear-profiles
+        (lambda ()
+          (for-each (lambda (k)
+                      (put! *profiles* k (cons 0 (cons 0 0))))
+                    (table.keys *profiles*)))))
+
diff --git a/src/jlfrontend.scm b/src/jlfrontend.scm
index 715be820b4084..5c973bacd83f0 100644
--- a/src/jlfrontend.scm
+++ b/src/jlfrontend.scm
@@ -1,4 +1,5 @@
 (load "./flisp/aliases.scm")
+(load "./flisp/profile.scm")
 (load "utils.scm")
 (load "ast.scm")
 (load "match.scm")
@@ -6,6 +7,7 @@
 (load "julia-parser.scm")
 (load "julia-syntax.scm")
 
+
 ;; exception handler for parser. turns known errors into special expressions,
 ;; and prevents throwing an exception past a C caller.
 (define (parser-wrap thk)
@@ -223,3 +225,10 @@
 ; run whole frontend on a string. useful for testing.
 (define (fe str)
   (expand-toplevel-expr (julia-parse str)))
+
+(define (profile-e s)
+  (with-exception-catcher
+   (lambda (e)
+           (newline)
+           (prn e))
+   (lambda () (profile s))))