added mini-profiler, a minimalistic profiler for scheme48 and scsh

NEWS

@@ -1,4 +1,5 @@
 version 0.6
+* New s48 library: mini-profiler
 * New s48 library: reinitializer
 * New scsh libraries: file-mode
 * New s48 libraries: SRFI-34/SRFI-35 exceptions and conditions, SRFI-10

s48/profile/AUTHORS

@@ -0,0 +1 @@
+Matthias Neubauer, Eric Knauel

s48/profile/BLURB

@@ -0,0 +1 @@
+mini-profiler: a minimalistic profiler

s48/profile/README

@@ -0,0 +1,41 @@
+The structure MINI-PROFILER implements a minimalist profiler for
+Scheme48 and scsh.  Time is measuered using Scheme48's RUN-TIME
+function from TIME.
+
+Functions
+=========
+
+  (profile-init!) -> unspecific
+
+  Initialize or reset the profiler.  Calling this function will delete
+  all information collected during previous runs of the compiler.
+
+  (display-profile . port) -> unspecific
+
+  Print the profiling information acquired to PORT.  If PORT is not
+  specified use CURRENT-OUTPUT-PORT.
+
+Syntax
+======
+
+  (account-for name body)
+
+  Evaluate BODY and stop the time needed for doing so.  Account the
+  time needed for NAME.  Especially useful for profiling code that
+  makes heavy use of high-order functions or lazy evaluation.  Example:
+
+  (define (compile-funcall exp)
+    (account-for compile-funcall
+      (let ((op  (compile (funcall-op exp)))
+            (arg (compile (funcall-arg exp))))
+        (lambda (env)
+           (account-for eval-funcall
+              (op (arg env stop-k)))))))
+
+  define-prof
+
+  DEFINE-PROF is a substitute for Scheme's DEFINE. Mini-profiler
+  accounts the time needed to evaluate the procedure bound with DEFINE
+  for DEFINE name.
+  
+

s48/profile/interfaces.scm

@@ -0,0 +1,6 @@
+(define-interface mini-profiler-interface
+  (export
+   profile-init!
+   display-profile
+   (define-prof :syntax)
+   (account-for :syntax)))

s48/profile/packages.scm

@@ -0,0 +1,8 @@
+(define-structure mini-profiler mini-profiler-interface
+  (open scheme
+	table
+	formats
+	extended-ports
+	time)
+  (files profile))
+   

s48/profile/profile.scm

@@ -0,0 +1,89 @@
+;;; This file is part of the Scheme Untergrund Library.
+;;;
+;;; Copyright (c) 2000 by Matthias Neubauer
+;;; Copyright (c) 2004 by Eric Knauel
+;;;
+;;; For copyright information, see the file COPYING which comes with
+;;; the distribution.
+;;;
+;;;
+;;; ,open table formats extended-ports time
+
+(define *profile-table*
+  (make-symbol-table))
+
+(define (profile-init!)
+  (set! *profile-table* (make-symbol-table)))
+
+(define (account-time! name run-time)
+  (cond
+   ((table-ref *profile-table* name)
+    => (lambda (count.time)
+	 (table-set! *profile-table* name 
+		     (cons (+ 1 (car count.time))
+			   (+ run-time (cdr count.time))))))
+   (else
+    (table-set! *profile-table* name (cons name run-time)))))
+
+(define (hundredths n) 
+  (let ((n (round (quotient n 10))))
+    (string-append
+     (number->string (quotient n 100))
+     "."
+     (let ((r (remainder n 100)))
+       (if (< r 10)
+	   "0"
+	   (number->string r))))))
+
+(define (table->string table)
+  (let ((port (make-string-output-port)))
+    (table-walk
+     (lambda (key count.time)
+       (format port "~A: ~A ~A~%"
+	       key (car count.time) 
+	       (hundredths (cdr count.time))))
+     table)
+    (string-output-port-output port)))
+
+(define (display-profile . port)
+  (let ((port (if (null? port) (current-output-port) port)))
+    (format port
+	    (string-append
+	     "Profile summary~%"
+	     "---------------~%"
+	     "~A~%~%")
+	    (table->string *profile-table*))))
+
+(define-syntax define-prof
+  (syntax-rules
+   ()
+   ((_ (?name . ?arg) ?body ...)
+    (define (?name . ?arg)
+      (define-prof "body" ?name ?body ...)))
+   ((_ (?name ?args ...) ?body ...)
+    (define (?name ?args ...)
+      (define-prof "body" ?name ?body ...)))
+   ((_ "body" ?name ?body ...)
+    (let ((start-run-time (run-time))) 
+      (call-with-values 
+       (lambda ()
+	 ?body ...)
+       (lambda results
+	 (let* ((stop-run-time (run-time))
+		(run-time (- stop-run-time start-run-time)))
+	   (account-time! (quote ?name) run-time)
+	   (apply values results))))))))
+
+(define-syntax account-for
+  (syntax-rules
+      ()
+    ((account-for ?account ?body ...)
+     (let ((start-run-time (run-time)))
+       (call-with-values 
+	(lambda ()
+	  ?body ...)
+	(lambda results
+	  (let* ((stop-run-time (run-time))
+		 (run-time (- stop-run-time start-run-time)))
+	    (account-time! (quote ?account) run-time)
+	    (apply values results))))))))