Added libtimers.ss:

(time-it proc) runs proc and reports the time.
  (time-it proc message) runs proc and reports the time, with message.
  (time <expr>) evaluates expr and prints the running time.

bin/ikarus-runtime.c

@@ -11,6 +11,8 @@
 #include <unistd.h>
 #include <sys/mman.h>
 #include <assert.h>
+#include <sys/time.h>
+#include <sys/resource.h>
 
 #include <uuid/uuid.h>
 
@@ -858,3 +860,23 @@ ikrt_register_guardian(ikp tc, ikp obj, ikpcb* pcb){
   g->count++;
   return 0;
 }
+
+
+ikp 
+ikrt_stats_now(ikp t, ikpcb* pcb){
+  struct rusage r;
+  struct timeval s;
+
+  gettimeofday(&s, 0);
+  getrusage(RUSAGE_SELF, &r);
+  ref(t, off_record_data)                = fix(r.ru_utime.tv_sec);
+  ref(t, off_record_data + wordsize)     = fix(r.ru_utime.tv_usec);
+  ref(t, off_record_data + 2 * wordsize) = fix(r.ru_stime.tv_sec);
+  ref(t, off_record_data + 3 * wordsize) = fix(r.ru_stime.tv_usec);
+  ref(t, off_record_data + 4 * wordsize) = fix(s.tv_sec);
+  ref(t, off_record_data + 5 * wordsize) = fix(s.tv_usec);
+  return void_object;
+}
+
+
+

src/libtimers.ss

@@ -0,0 +1,58 @@
+
+(let ()
+  (define-record stats 
+    (user-secs user-usecs sys-secs sys-usecs real-secs real-usecs))
+
+  (define (mk-stats)
+    (make-stats #f #f #f #f #f #f))
+
+  (define (set-stats! t)
+    (foreign-call "ikrt_stats_now" t))
+
+  (define (print-stats message t1 t0)
+    (define (print-time msg secs usecs)
+      (if (fx< usecs 0)
+          (print-time msg (fx- secs 1) (fx+ usecs 1000000))
+          (printf "    ~a.~a~a~as ~a time\n"
+                  secs
+                  (fxremainder (fxquotient usecs 100000) 10)
+                  (fxremainder (fxquotient usecs 10000) 10)
+                  (fxremainder (fxquotient usecs 1000) 10)
+                  msg)))
+    (if message
+        (printf "running stats for ~a:\n" message)
+        (printf "running stats:\n"))
+    (print-time "user" 
+        (fx- (stats-user-secs t1) (stats-user-secs t0))
+        (fx- (stats-user-usecs t1) (stats-user-usecs t0)))
+    (print-time "system" 
+        (fx- (stats-sys-secs t1) (stats-sys-secs t0))
+        (fx- (stats-sys-usecs t1) (stats-sys-usecs t0)))
+    (print-time "real" 
+        (fx- (stats-real-secs t1) (stats-real-secs t0))
+        (fx- (stats-real-usecs t1) (stats-real-usecs t0))))
+
+  (define time-it
+    (case-lambda
+      [(proc) 
+       (time-it proc #f)]
+      [(proc message)
+       (unless (procedure? proc)
+         (error 'time-it "~s is not a procedure" proc))
+       (let* ([t1 (mk-stats)]
+              [t0 (mk-stats)])
+         (set-stats! t0)
+         (call-with-values proc
+           (case-lambda
+             [(v)
+              (set-stats! t1)
+              (print-stats message t1 t0)
+              v]
+             [v*
+              (set-stats! t1)
+              (print-stats message t1 t0)
+              (apply values v*)])))]))
+
+  (primitive-set! 'time-it time-it)
+  
+)

src/makefile.ss

@@ -25,7 +25,8 @@
     syntax-case syntax-rules module $module import $import import-only
     syntax quasisyntax unsyntax unsyntax-splicing datum
     let let* let-values cond case define-record or and when unless do
-    include parameterize trace untrace trace-lambda trace-define))
+    include parameterize trace untrace trace-lambda trace-define
+    time))
 
 
 
@@ -84,6 +85,7 @@
     negative? zero? number->string logand = < > <= >=
     make-guardian weak-cons collect 
     interrupt-handler
+    time-it
     ))
 
 (define system-primitives
@@ -230,6 +232,7 @@
     ["libcafe.ss"       "libcafe.fasl"]
     ["libtrace.ss"      "libtrace.fasl"]
     ["libposix.ss"      "libposix.fasl"]
+    ["libtimers.ss"     "libtimers.fasl"]
     ["libtoplevel.ss"   "libtoplevel.fasl"]
     ))
 

src/psyntax-7.1.ss

@@ -4669,3 +4669,9 @@
        #'(define id
            (make-traced-procedure 'id value))])))
 
+(define-syntax time
+  (lambda (x)
+    (syntax-case x ()
+      [(_ expr)
+       #'(time-it (lambda () expr) 'expr)])))
+