~ chicken-core (chicken-5) ce0ce0c4f175ce05cdcae86843a1382bf7389758

commit ce0ce0c4f175ce05cdcae86843a1382bf7389758
Author:     felix <felix@call-with-current-continuation.org>
AuthorDate: Mon Aug 1 12:27:09 2011 +0200
Commit:     felix <felix@call-with-current-continuation.org>
CommitDate: Mon Aug 1 12:27:09 2011 +0200

    profiler uses flonum ms values

diff --git a/chicken-profile.scm b/chicken-profile.scm
index e5f65c1b..257591ed 100644
--- a/chicken-profile.scm
+++ b/chicken-profile.scm
@@ -203,7 +203,6 @@ EOF
     (if (< 0 top (length data))
 	(set! data (take data top)))
     (set! data (map (lambda (entry)
-		      (pp entry)
 		      (let ([c (second entry)]
 			    [t (third entry)]
 			    [a (fourth entry)]
diff --git a/chicken.h b/chicken.h
index 15bd9cd3..c706491e 100644
--- a/chicken.h
+++ b/chicken.h
@@ -1449,12 +1449,6 @@ extern double trunc(double);
 
 #define C_a_i_current_milliseconds(ptr, c, dummy) C_flonum(ptr, C_milliseconds())
 
-/* this is of course silly, but only used for profiling, where we can assume that
-   the process doesn't run for more than a week.
-
-   (now someone will do exactly that ...) */
-#define C_i_current_cpu_milliseconds_as_fixnum(dummy) C_fix(C_cpu_milliseconds())
-
 
 /* Variables: */
 
diff --git a/profiler.scm b/profiler.scm
index 81e4c8e2..1879b461 100644
--- a/profiler.scm
+++ b/profiler.scm
@@ -27,9 +27,8 @@
 
 (declare
   (unit profiler)
-  (hide ##sys#profile-name ##sys#profile-vector-list)
-  (disable-interrupts)
-  (fixnum) )
+  (hide ##sys#profile-name ##sys#profile-vector-list cpu-ms)
+  (disable-interrupts))
 
 (foreign-declare #<<EOF
 #include <unistd.h>
@@ -49,71 +48,70 @@ EOF
 (define ##sys#profile-name #f)
 (define ##sys#profile-append-mode #f)
 
+
 ;;; Initialize profile counter vector:
 
 (define ##sys#register-profile-info
-  (let ((make-vector make-vector))
-    (lambda (size filename)
-      (when filename
-	(set! ##sys#profile-name 
-	  (if (string? filename)
-	      filename
-	      (string-append "PROFILE." (number->string profile-id))))
-	(let ([oldeh (##sys#exit-handler)]
-	      [oldieh (##sys#implicit-exit-handler)] )
-	  (##sys#exit-handler
-	   (lambda args
-	     (##sys#finish-profile)
-	     (apply oldeh args) ) )
-	  (##sys#implicit-exit-handler
-	   (lambda ()
-	     (##sys#finish-profile)
-	     (oldieh) ) ) ) )
-      ;; entry: [name, count, time0, total, pending]
-      (let ((vec (make-vector (* size profile-info-entry-size) 0)))
-	(set! ##sys#profile-vector-list (cons vec ##sys#profile-vector-list))
-	vec) ) ) )
+  (lambda (size filename)
+    (when filename
+      (set! ##sys#profile-name 
+	(if (string? filename)
+	    filename
+	    (string-append "PROFILE." (number->string profile-id))))
+      (let ([oldeh (##sys#exit-handler)]
+	    [oldieh (##sys#implicit-exit-handler)] )
+	(##sys#exit-handler
+	 (lambda args
+	   (##sys#finish-profile)
+	   (apply oldeh args) ) )
+	(##sys#implicit-exit-handler
+	 (lambda ()
+	   (##sys#finish-profile)
+	   (oldieh) ) ) ) )
+    ;; entry: [name, count, time0, total, pending]
+    (let ((vec (make-vector (fx* size profile-info-entry-size) 0)))
+      (set! ##sys#profile-vector-list (cons vec ##sys#profile-vector-list))
+      vec) ) )
 
 (define (##sys#set-profile-info-vector! vec i x)
-  (##sys#setslot vec (* i profile-info-entry-size) x) )
+  (##sys#setslot vec (fx* i profile-info-entry-size) x) )
 
 
 ;;; Entry and exit into/out of profiled lambda:
 
+(define cpu-ms (foreign-lambda double "C_cpu_milliseconds"))
+
 (define ##sys#profile-entry 
-  (let ((maxfix (##sys#fudge 21)))
+  (let ((maxfix most-positive-fixnum))
     (lambda (index vec)
-      (let* ([i (* index profile-info-entry-size)]
-	     [ic (add1 i)]
+      (let* ([i (fx* index profile-info-entry-size)]
+	     [ic (fx+ i 1)]
 	     [count (##sys#slot vec ic)]
-	     [it0 (+ i 2)] 
-	     [ip (+ i 4)] 
+	     [it0 (fx+ i 2)] 
+	     [ip (fx+ i 4)] 
 	     [ipc (##sys#slot vec ip)] )
 	(##sys#setislot 
 	 vec ic
 	 (cond ((not count) #f)
 	       ((eq? maxfix count) #f)
-	       (else (add1 count))))
-	(when (zero? ipc)
-	  (##sys#setislot 
-	   vec it0
-	   (##core#inline "C_i_current_cpu_milliseconds_as_fixnum" #f)))
-	(##sys#setislot vec ip (add1 ipc)) ) ) ) )
+	       (else (fx+ count 1))))
+	(when (eq? 0 ipc)
+	  (##sys#setslot vec it0 (cpu-ms)))
+	(##sys#setislot vec ip (fx+ ipc 1)) ) ) ) )
 
 (define (##sys#profile-exit index vec)
   (let* ([i (fx* index profile-info-entry-size)]
 	 [it0 (fx+ i 2)] 
 	 [it (fx+ i 3)] 
 	 [ip (fx+ i 4)] 
-	 [ipc (sub1 (##sys#slot vec ip))] )
+	 [ipc (fx- (##sys#slot vec ip) 1)] )
     (##sys#setislot vec ip ipc)
-    (when (zero? ipc)
-      (##sys#setislot
-       vec it 
-       (fx+ (##sys#slot vec it)
-	    (fx- (##core#inline "C_i_current_cpu_milliseconds_as_fixnum" #f)
-		 (##sys#slot vec it0)))))
-    (##sys#setislot vec it0 0) ) )
+    (when (eq? 0 ipc)
+      (let ((t (##sys#slot vec it)))
+	(##sys#setslot
+	 vec it 
+	 (fp+ (if (eq? t 0) 0.0 t)
+	      (fp- (cpu-ms) (##sys#slot vec it0))))))))
 
 
 ;;; Generate profile:
@@ -124,7 +122,7 @@ EOF
 	[write write] )
     (lambda ()
       (when (##sys#fudge 13)
-	(##sys#print "[debug] writing profile...\n" #f ##sys#standard-output) )
+	(##sys#print "[debug] writing profile...\n" #f ##sys#standard-error) )
       (apply
        with-output-to-file ##sys#profile-name
        (lambda ()