1: 
;; statprof.scm -- A statistical profiler for Gambit-C 4.0
2: 
3: 
;; See the README file for license and usage information.
4: 
5: 
;; $Id: statprof.scm,v 1.9 2005/03/14 07:35:49 guillaume Exp $
6: 
7: 
8: 
;; ----------------------------------------------------------------------------
9: 
;; Profiling & interruption handling
10: 
11: 
(define *buckets* #f)
12: 
(define *total* 0)
13: 
14: 
(define (profile-start!)
15: 
  (set! *buckets* '())
16: 
  (set! *total* 0)
17: 
  (##interrupt-vector-set! 1 profile-heartbeat!))
18: 
19: 
(define (profile-stop!)
20: 
  (##interrupt-vector-set! 1 ##thread-heartbeat!))
21: 
22: 
;; (define (identify-continuation cont) ; first version
23: 
;;   (or (##continuation-creator cont)
24: 
;;       'unknown))
25: 
26: 
(define (identify-continuation cont) ; second version
27: 
  (let ((locat (##continuation-locat cont)))
28: 
    (if locat
29: 
        (let* ((container (##locat-container locat))
30: 
               (file (##container->file container)))
31: 
          (if file
32: 
              (let* ((filepos (##position->filepos (##locat-position locat)))
33: 
                     (line (##fixnum.+ (##filepos-line filepos) 1))
34: 0% 
                     (col (##fixnum.+ (##filepos-col filepos) 1)))
35: 
                (list file line col))
36: 
              'unknown))
37: 
        'unknown)))
38: 
39: 
(define (profile-heartbeat!)
40: 0% 
  (##continuation-capture
41: 0% 
   (lambda (cont)
42: 0% 
     (##thread-heartbeat!)
43: 0% 
     (let ((id (identify-continuation cont)))
44: 0% 
       (if (not (eq? id 'unknown))
45: 
           (let ((bucket (assoc (car id) *buckets*)))
46: 
             (set! *total* (+ *total* 1))
47: 
             (if (not bucket)
48: 
                 (begin
49: 
                   (set! *buckets* (cons 
50: 
                                    (cons (car id) 
51: 
                                          ;; fixme: arbitrary hard limit
52: 
                                          ;; on the length of source
53: 
                                          ;; files
54: 
                                          (make-vector 5000 0)) 
55: 
                                    *buckets*))
56: 
                   (set! bucket (car *buckets*))))
57: 
58: 0% 
             (vector-set! (cdr bucket)
59: 
                          (cadr id) 
60: 
                          (+ (vector-ref (cdr bucket) 
61: 
                                         (cadr id))
62: 
                             1))))))))
63: 
64: 
65: 
;; ----------------------------------------------------------------------------
66: 
;; Text formatting
67: 
68: 
(define (pad-left s l c)
69: 
  (let loop ((s (string->list s)))
70: 
    (if (< (length s) l)
71: 
        (loop (cons c s))
72: 
        (list->string s))))
73: 
74: 
75: 
;; ----------------------------------------------------------------------------
76: 
;; Palette generation & color formatting
77: 
78: 
(define (gradient from to step)
79: 
  (let ((inc (map (lambda (x) (/ x step))
80: 
                  (map - to from))))
81: 
    
82: 
    (let loop ((i 0)
83: 
               (acc '()))
84: 
      (if (= i step) 
85: 
          (reverse acc)
86: 
          (loop (+ i 1)
87: 
                (cons (map 
88: 
                       (lambda (x o) 
89: 
                         (round (+ x (* i o))))
90: 
                       from
91: 
                       inc)
92: 
                      acc))))))
93: 
94: 
(define (as-rgb col)
95: 
  (apply string-append
96: 
         (map
97: 
          (lambda (x)
98: 
            (pad-left (number->string x 16) 2 #\0))
99: 
          col)))
100: 
101: 
(define palette
102: 
  (list->vector 
103: 
   (cons '(255 255 255) 
104: 
         (gradient '(127 127 255) 
105: 
                   '(255 127 127)
106: 
                   16))))
107: 
108: 
109: 
;; ----------------------------------------------------------------------------
110: 
;; Functions to generate the report
111: 
112: 
(define (write-profile-report profile-name)
113: 
114: 
  (define (iota1 n)
115: 
    (let loop ((n n)
116: 
               (l '()))
117: 
      (if (>= n 1) 
118: 
          (loop (- n 1) (cons n l))
119: 
          l)))
120: 
  
121: 
  (define directory-name (string-append (current-directory)
122: 
                                        profile-name
123: 
                                        "/"))
124: 
  (with-exception-catcher
125: 
   (lambda (e)
126: 
     ;; ignore the exception, it probably means that the directory
127: 
     ;; already existed.  If there's another problem it will be
128: 
     ;; signaled later.
129: 
     #f) 
130: 
   (lambda ()
131: 
     (create-directory (list path: directory-name
132: 
                             permissions: #o755))))
133: 
  
134: 
  (let ((max-intensity 
135: 
         (apply max
136: 
                (map
137: 
                 (lambda (data)
138: 
                   (apply max 
139: 
                          (vector->list data)))
140: 
                 (map cdr *buckets*)))))
141: 
142: 
    (map 
143: 
     (lambda (bucket)
144: 
       (let ((file (car bucket))
145: 
             (data (cdr bucket)))
146: 
       
147: 
         (define (get-color n)
148: 
           (let ((i (vector-ref data n)))
149: 
             (if (= i 0)
150: 
                 (as-rgb (vector-ref palette 0))
151: 
                 (let ((x (* (/ (log (+ 1. i))
152: 
                                (ceiling (log max-intensity)))
153: 
                             (- (vector-length palette) 1))))
154: 
                   (as-rgb (vector-ref palette 
155: 
                                       (inexact->exact (ceiling x))))))))
156: 
157: 
         (with-output-to-file (string-append 
158: 
                               directory-name
159: 
                               (path-strip-directory file)
160: 
                               ".html")
161: 
           (let ((lines (call-with-input-file file 
162: 
                          (lambda (p) (read-all p read-line)))))
163: 
             (lambda ()
164: 
               (display
165: 
                (sexp->html
166: 
                 `(html 
167: 
                   (body
168: 
                    (table 
169: 
                     cellspacing: 0 
170: 
                     cellpadding: 0
171: 
                     border: 0
172: 
                     style: "font-size: 12px;"
173: 
                     ,@(map
174: 
                        (lambda (line line#)
175: 
                          `(tr 
176: 
                            (td ,(string-append 
177: 
                                  (number->string line#)
178: 
                                  ": "))
179: 
                            ;; (td 
180: 
                            ;;  align: center
181: 
                            ;;  ,(let ((n (vector-ref data line#)))
182: 
                            ;;     (if (= n 0)
183: 
                            ;;         ""
184: 
                            ;;         (string-append "[" 
185: 
                            ;;                        (number->string n)
186: 
                            ;;                        "/"
187: 
                            ;;                        (number->string *total*)
188: 
                            ;;                        "]"))))
189: 
                            
190: 
                            (td 
191: 
                             align: center
192: 
                             ,(let ((n (vector-ref data line#)))
193: 
                                (if (= n 0)
194: 
                                    ""
195: 
                                    (string-append
196: 
                                     (number->string
197: 
                                      (round% (/ n *total*)))
198: 
                                     "% "))))
199: 
                               
200: 
                            (td (pre style: ,(string-append     
201: 
                                              "background-color:#"
202: 
                                              (get-color line#))
203: 
                                     ,line))))
204: 
                        lines
205: 
                        (iota1 (length lines)))))))))))))
206: 
     
207: 
     *buckets*))
208: 
209: 
  (with-output-to-file (string-append directory-name "index.html")
210: 
    (lambda ()
211: 
      (display
212: 
       (sexp->html
213: 
        `(html
214: 
          (body
215: 
           ,@(map (lambda (bucket)
216: 
                    (let ((file-path (string-append 
217: 
                                      directory-name
218: 
                                      (path-strip-directory (car bucket)) 
219: 
                                      ".html")))
220: 
                      `(p (a href: ,file-path ,file-path)
221: 
                          " ["
222: 
                          ,(round%
223: 
                            (/ (apply + (vector->list (cdr bucket)))
224: 
                               *total*)) 
225: 
                          " %]")))
226: 
                  *buckets*))))))))
227: 
228: 
(define (round% n)
229: 
  (/ (round
230: 
      (* 10000 n))
231: 
     100.))
232: 
233: 
234: 
;; ----------------------------------------------------------------------------
235: 
;; Included file "html.scm"
236: 
;; ----------------------------------------------------------------------------
237: 
238: 
;; html.scm -- A simple html generator for Gambit-C 4.0
239: 
240: 
;; Written by Guillaume Germain (germaing@iro.umontreal.ca)
241: 
;; This code is released in the public domain.
242: 
243: 
244: 
(define (stringify x)
245: 
  (with-output-to-string ""
246: 
    (lambda ()
247: 
      (display x))))
248: 
249: 
(define (to-escaped-string x)
250: 
  (stringify 
251: 
   (map (lambda (c)
252: 
          (case c
253: 
            ((#\<) "&lt;")
254: 
            ((#\>) "&gt;")
255: 
            ((#\&) "&amp;")
256: 
            (else c)))
257: 
        (string->list 
258: 
         (stringify x)))))
259: 
260: 
;; Quick and dirty conversion of s-expressions to html
261: 
(define (sexp->html exp)
262: 
  
263: 
  ;; write the opening tag
264: 
  (define (open-tag exp)
265: 
    (cond
266: 
     ;; null tag isn't valid
267: 
     ((null? exp) 
268: 
      (error "null tag"))
269: 
     
270: 
     ;; a tag must be a list beginning with a symbol
271: 
     ((and (pair? exp)
272: 
           (symbol? (car exp)))
273: 
      (list "<" 
274: 
            (car exp)
275: 
            " " 
276: 
            (maybe-args (car exp) (cdr exp))))
277: 
     
278: 
     (else
279: 
      (error "invalid tag" exp))))
280: 
281: 
  ;; take care of the keywords / arguments
282: 
  (define (maybe-args tag exp)
283: 
284: 
    (cond
285: 
     ;; does the rest of the list begins with a keyword
286: 
     ((and (pair? exp)
287: 
           (keyword? (car exp)))
288: 
289: 
      ;; does the keyword has an associated value?
290: 
      (if (or (null? (cdr exp))
291: 
              (keyword? (cadr exp)))
292: 
          ;; no, we don't put an associated value
293: 
          (list (keyword->string (car exp))
294: 
                " "
295: 
                (maybe-args tag (cdr exp)))
296: 
          ;; yes, we take the next element in the list as the value
297: 
          (list (keyword->string (car exp))
298: 
                "=\""
299: 
                (cadr exp)
300: 
                "\" "
301: 
                (maybe-args tag (cddr exp)))))
302: 
303: 
     ;; must just be some content
304: 
     (else
305: 
      (content tag exp))))
306: 
307: 
  ;; handle the content of the tag and closing it
308: 
  (define (content tag exp)
309: 
    (cond
310: 
     ;; no content...
311: 
     ((null? exp)
312: 
      ;;(list "></" tag ">"))           ; close as "<br></br>"
313: 
      (list "/>"))                      ; close as "<br/>"
314: 
315: 
     ;; write the content, handle tags inside
316: 
     ((pair? exp)
317: 
      (list ">"
318: 
            (map (lambda (e)
319: 
                   (if (pair? e)
320: 
                       (open-tag e)
321: 
                       (to-escaped-string e)))
322: 
                 exp)
323: 
            "</"
324: 
            tag
325: 
            ">"))
326: 
327: 
     ;; non-null terminated list?
328: 
     (else
329: 
      (error "strange content..."))))
330: 
331: 
  ;; we rely on Gambit's flattening of list when printed with DISPLAY
332: 
  (with-output-to-string ""
333: 
                         (lambda ()
334: 
                           (display (open-tag exp)))))