~ chicken-core (chicken-5) /profiler.scm

  1;;;; profiler.scm - Support code for profiling applications
  2;
  3; Copyright (c) 2008-2022, The CHICKEN Team
  4; Copyright (c) 2000-2007, Felix L. Winkelmann
  5; All rights reserved.
  6;
  7; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
  8; conditions are met:
  9;
 10;   Redistributions of source code must retain the above copyright notice, this list of conditions and the following
 11;     disclaimer. 
 12;   Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following
 13;     disclaimer in the documentation and/or other materials provided with the distribution. 
 14;   Neither the name of the author nor the names of its contributors may be used to endorse or promote
 15;     products derived from this software without specific prior written permission. 
 16;
 17; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
 18; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
 19; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
 20; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
 21; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
 22; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
 23; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
 24; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
 25; POSSIBILITY OF SUCH DAMAGE.
 26
 27
 28(declare
 29  (unit profiler)
 30  (hide ##sys#profile-name ##sys#profile-vector-list cpu-ms empty-file?)
 31  (unsafe)
 32  (disable-interrupts))
 33
 34(import chicken.base chicken.fixnum scheme)
 35
 36(include "common-declarations.scm")
 37
 38(define-foreign-variable profile-id int "C_getpid()")
 39
 40(define-constant profile-info-entry-size 5)
 41
 42(define empty-file?
 43  (foreign-lambda* bool ((scheme-object p))
 44    "C_return(ftell(C_port_file(p)) == 0);"))
 45
 46
 47;;; Globals:
 48
 49(define ##sys#profile-vector-list '())
 50(define ##sys#profile-name #f)
 51(define ##sys#profile-append-mode #f)
 52
 53
 54;;; Initialize profile counter vector:
 55
 56(define ##sys#register-profile-info
 57  (lambda (size filename)
 58    (when filename
 59      (set! ##sys#profile-name 
 60	(if (string? filename)
 61	    filename
 62	    (string-append "PROFILE." (number->string profile-id))))
 63      (let ((oldeh (exit-handler))
 64	    (oldieh (implicit-exit-handler)))
 65	(exit-handler
 66	 (lambda args
 67	   (##sys#finish-profile)
 68	   (apply oldeh args) ) )
 69	(implicit-exit-handler
 70	 (lambda ()
 71	   (##sys#finish-profile)
 72	   (oldieh) ) ) ) )
 73    ;; entry: [name, count, time0, total, pending]
 74    (let ((vec (make-vector (fx* size profile-info-entry-size) 0)))
 75      (set! ##sys#profile-vector-list (cons vec ##sys#profile-vector-list))
 76      vec) ) )
 77
 78(define (##sys#set-profile-info-vector! vec i x)
 79  (##sys#setslot vec (fx* i profile-info-entry-size) x) )
 80
 81
 82;;; Entry and exit into/out of profiled lambda:
 83
 84(define cpu-ms (foreign-lambda unsigned-integer64 "C_cpu_milliseconds"))
 85
 86(define ##sys#profile-entry 
 87  (let ((maxfix most-positive-fixnum))
 88    (lambda (index vec)
 89      (let* ([i (fx* index profile-info-entry-size)]
 90	     [ic (fx+ i 1)]
 91	     [count (##sys#slot vec ic)]
 92	     [it0 (fx+ i 2)] 
 93	     [ip (fx+ i 4)] 
 94	     [ipc (##sys#slot vec ip)] )
 95	(##sys#setislot 
 96	 vec ic
 97	 (cond ((not count) #f)
 98	       ((eq? maxfix count) #f)
 99	       (else (fx+ count 1))))
100	(when (eq? 0 ipc)
101	  (##sys#setslot vec it0 (cpu-ms)))
102	(##sys#setislot vec ip (fx+ ipc 1)) ) ) ) )
103
104(define (##sys#profile-exit index vec)
105  (let* ([i (fx* index profile-info-entry-size)]
106	 [it0 (fx+ i 2)] 
107	 [it (fx+ i 3)] 
108	 [ip (fx+ i 4)] 
109	 [ipc (fx- (##sys#slot vec ip) 1)] )
110    (##sys#setislot vec ip ipc)
111    (when (eq? 0 ipc)
112      (let ((t (##sys#slot vec it)))
113	(##sys#setslot
114	 vec it 
115	 (+ (if (eq? t 0) 0 t)
116	    (- (cpu-ms) (##sys#slot vec it0))))))))
117
118
119;;; Generate profile:
120
121(define ##sys#finish-profile 
122  (let ([with-output-to-file with-output-to-file]
123	[write-char write-char]
124	[write write] )
125    (lambda ()
126      (when (##sys#debug-mode?)
127	(##sys#print "[debug] writing profile...\n" #f ##sys#standard-error) )
128      (apply
129       with-output-to-file ##sys#profile-name
130       (lambda ()
131	 (when (empty-file? (current-output-port)) ; header needed?
132	   (write 'instrumented)
133	   (write-char #\newline))
134	 (for-each
135	  (lambda (vec)
136	    (let ([len (##sys#size vec)])
137	      (do ([i 0 (fx+ i profile-info-entry-size)])
138		  ((fx>= i len))
139		(write-char #\()
140		(write (##sys#slot vec i))
141		(write-char #\space)
142		(write (##sys#slot vec (fx+ i 1)))
143		(write-char #\space)
144		(write (##sys#slot vec (fx+ i 3)))
145		(write-char #\))
146		(write-char #\newline) ) ) ) 
147	  ##sys#profile-vector-list) )
148       (if ##sys#profile-append-mode
149	   '(#:append)
150	   '() ) ) ) ) )