adding simplistic procedure-level profiler

Makefile

@@ -120,7 +120,7 @@ COMPILED_LIBS := lib/srfi/18/threads$(SO) lib/srfi/27/rand$(SO) \
 	lib/chibi/filesystem$(SO) lib/chibi/process$(SO) lib/chibi/time$(SO) \
 	lib/chibi/system$(SO) lib/chibi/io/io$(SO) lib/chibi/stty$(SO) \
 	lib/chibi/weak$(SO) lib/chibi/heap-stats$(SO) lib/chibi/disasm$(SO) \
-	lib/chibi/optimize/rest$(SO)
+	lib/chibi/optimize/rest$(SO) lib/chibi/optimize/profile$(SO)
 
 libs: $(COMPILED_LIBS)
 

lib/chibi/optimize/profile.c

@@ -0,0 +1,16 @@
+/*  profile.c -- low-level utilities for VM profiling         */
+/*  Copyright (c) 2011 Alex Shinn.  All rights reserved.      */
+/*  BSD-style license: http://synthcode.com/license.txt       */
+
+#include <chibi/eval.h>
+
+static sexp sexp_increment_cdr (sexp ctx sexp_api_params(self, n), sexp pair) {
+  sexp_assert_type(ctx, sexp_pairp, SEXP_PAIR, pair);
+  sexp_cdr(pair) = sexp_make_fixnum(1 + sexp_unbox_fixnum(sexp_cdr(pair)));
+  return SEXP_VOID;
+}
+
+sexp sexp_init_library (sexp ctx sexp_api_params(self, n), sexp env) {
+  sexp_define_foreign(ctx, env, "increment-cdr!", 1, sexp_increment_cdr);
+  return SEXP_VOID;
+}

lib/chibi/optimize/profile.module

@@ -0,0 +1,7 @@
+
+(module (chibi optimize profile)
+  (export optimize-profile increment-cdr! profile-reset profile-report)
+  (import (scheme) (srfi 1) (srfi 69) (srfi 95)
+          (chibi ast) (chibi match) (chibi optimize))
+  (include-shared "profile")
+  (include "profile.scm"))

lib/chibi/optimize/profile.scm

@@ -0,0 +1,65 @@
+
+(define (ref=? a b)
+  (or (eq? a b)
+      (and (ref? a) (ref? b)
+           (eq? (ref-name a) (ref-name b))
+           (eq? (car (ref-cell a)) (car (ref-cell b)))
+           (eq? (cdr (ref-cell a)) (cdr (ref-cell b))))))
+
+(define profile-cells '())
+
+(define (profile-get-cell f)
+  (or (assoc f profile-cells ref=?)
+      (let ((cell (cons f 0)))
+        (set! profile-cells (cons cell profile-cells))
+        cell)))
+
+(define (profile-reset)
+  (for-each (lambda (x) (set-cdr! x 0)) profile-cells))
+
+(define (profile-report)
+  (define (report-op op)
+    (match op
+      (($ Ref name (p . (and ($ Lam lam-name) f)))
+       (write name)
+       (cond
+        ((not (eq? p name))
+         (display " ")
+         (write p)))
+       (cond
+        ((lambda-source f)
+         (display " [") (write (lambda-source f)) (display "]"))))
+      (($ Ref name (_ . f))
+       (write name) (display " (") (write f) (display ")"))
+      (else
+       (write op))))
+  (let ((ls (filter (lambda (x) (> (cdr x) 0))
+                    profile-cells)))
+    (for-each (lambda (x)
+                (write (cdr x)) (display ": ")
+                (report-op (car x)) (newline))
+              (sort ls > cdr))))
+
+(define (optimize-profile ast)
+  (let-syntax ((opt (syntax-rules () ((opt x) (optimize-profile x)))))
+    (match ast
+      (($ Set ref value)
+       (set-value-set! ast (opt value))
+       ast)
+      (($ Cnd test pass fail)
+       (make-cnd (opt test) (opt pass) (opt fail)))
+      (($ Seq ls)
+       (make-seq (map optimize-profile ls)))
+      (($ Lam name params body)
+       (lambda-body-set! ast (opt body))
+       ast)
+      ((($ Ref name cell) args ...)
+       (make-seq (list (list increment-cdr!
+                             (make-lit (profile-get-cell (car ast))))
+                       (cons (car ast) (map optimize-profile args)))))
+      ((app ...)
+       (map optimize-profile app))
+      (else
+       ast))))
+
+(register-lambda-optimization! optimize-profile)

lib/init.scm

@@ -398,12 +398,12 @@
 
 (define memv member)
 
-(define (assoc obj ls)
-  (if (null? ls)
-      #f
-      (if (equal? obj (caar ls))
-          (car ls)
-          (assoc obj (cdr ls)))))
+(define (assoc obj ls . o)
+  (let ((eq (if (pair? o) (car o) equal?)))
+    (let assoc ((ls ls))
+      (cond ((null? ls) #f)
+            ((eq obj (caar ls)) (car ls))
+            (else (assoc (cdr ls)))))))
 
 (define assv assoc)