Merge pull request #19321 from JuliaLang/jn/time-flisp

add configurable flisp profiling / timing code

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)) \

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));

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*)))))
+

src/jlfrontend.scm

@@ -1,11 +1,13 @@
 (load "./flisp/aliases.scm")
+(load "./flisp/profile.scm")
 (load "utils.scm")
 (load "ast.scm")
 (load "match.scm")
 (load "macroexpand.scm")
 (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))))