add configurable flisp 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))))