profiler.scm

   1 ;; basic profiler for SIXPIC's pic18 simulator
   2 ;; basically, just reports the execution count for each instruction that is
   3 ;; kept by the simulator
   4
   5 ;; this is mostly taken from Guillaume Germain's statprof statistical profiler
   6 ;; for Gambit-C, hence is distributed with the same licence as Gambit-C
   7
   8 ;; TODO this is not yet working, it has not been completely adapted. a temporary solution is being used instead
   9
  10 ;; ----------------------------------------------------------------------------
  11 ;; Text formatting
  12
  13 (define (pad-left s l c)
  14   (let loop ((s (string->list s)))
  15     (if (< (length s) l)
  16         (loop (cons c s))
  17         (list->string s))))
  18
  19
  20 ;; ----------------------------------------------------------------------------
  21 ;; Palette generation & color formatting
  22
  23 (define (gradient from to step)
  24   (let ((inc (map (lambda (x) (/ x step))
  25                   (map - to from))))
  26
  27     (let loop ((i 0)
  28                (acc '()))
  29       (if (= i step)
  30           (reverse acc)
  31           (loop (+ i 1)
  32                 (cons (map
  33                        (lambda (x o)
  34                          (round (+ x (* i o))))
  35                        from
  36                        inc)
  37                       acc))))))
  38
  39 (define (as-rgb col)
  40   (apply string-append
  41          (map
  42           (lambda (x)
  43             (pad-left (number->string x 16) 2 #\0))
  44           col)))
  45
  46 (define palette
  47   (list->vector
  48    (cons '(255 255 255)
  49          (gradient '(127 127 255)
  50                    '(255 127 127)
  51                    16))))
  52
  53
  54 ;; ----------------------------------------------------------------------------
  55 ;; Functions to generate the report
  56
  57 (define (write-profile-report profile-name . sources)
  58
  59   (define (iota1 n)
  60     (let loop ((n n)
  61                (l '()))
  62       (if (>= n 1)
  63           (loop (- n 1) (cons n l))
  64           l)))
  65
  66   (define directory-name (string-append (current-directory)
  67                                         profile-name
  68                                         "/"))
  69   (with-exception-catcher
  70    (lambda (e)
  71      ;; ignore the exception, it probably means that the directory
  72      ;; already existed.  If there's another problem it will be
  73      ;; signaled later.
  74      #f)
  75    (lambda ()
  76      (create-directory (list path: directory-name
  77                              permissions: #o755))))
  78
  79   (let ((max-intensity 0))
  80     (for-each (lambda (x) (let ((new (vector-ref instrs-counts x)))
  81                             (if (> new max-intensity)
  82                                 (set! max-intensity new))))
  83               (iota (vector-length instrs-counts)))
  84     (map
  85      (lambda (adr)
  86        (let ((file (car bucket)) ;; TODO know which file we're coming from
  87              (data (cdr bucket)))
  88
  89          (define (get-color n)
  90            (let ((i (vector-ref data n)))
  91              (if (= i 0)
  92                  (as-rgb (vector-ref palette 0))
  93                  (let ((x (* (/ (log (+ 1. i))
  94                                 (max (ceiling (log max-intensity)) 1))
  95                              (- (vector-length palette) 1))))
  96                    (as-rgb (vector-ref palette
  97                                        (inexact->exact (ceiling x))))))))
  98
  99          (with-output-to-file (string-append
 100                                directory-name
 101                                (path-strip-directory file)
 102                                ".html")
 103            (let ((lines (call-with-input-file file
 104                           (lambda (p) (read-all p read-line)))))
 105              (lambda ()
 106                (print
 107                 (sexp->html
 108                  `(html
 109                    (body
 110                     (table
 111                      cellspacing: 0
 112                      cellpadding: 0
 113                      border: 0
 114                      style: "font-size: 12px;"
 115                      ,@(map
 116                         (lambda (line line#)
 117                           `(tr
 118                             (td ,(string-append
 119                                   (number->string line#)
 120                                   ": "))
 121                             ;; (td
 122                             ;;  align: center
 123                             ;;  ,(let ((n (vector-ref data line#)))
 124                             ;;     (if (= n 0)
 125                             ;;         ""
 126                             ;;         (string-append "["
 127                             ;;                        (number->string n)
 128                             ;;                        "/"
 129                             ;;                        (number->string *total*)
 130                             ;;                        "]"))))
 131
 132                             (td
 133                              align: center
 134                              ,(let ((n (vector-ref data line#)))
 135                                 (if (= n 0)
 136                                     ""
 137                                     (string-append
 138                                      (number->string
 139                                       (round% (/ n *total*)))
 140                                      "% "))))
 141
 142                             (td (pre style: ,(string-append
 143                                               "background-color:#"
 144                                               (get-color line#))
 145                                      ,line))))
 146                         lines
 147                         (iota1 (length lines)))))))))))))
 148
 149      (iota (vector-length instrs-counts))))
 150
 151   (with-output-to-file (string-append directory-name "index.html")
 152     (lambda ()
 153       (print
 154        (sexp->html
 155         `(html
 156           (body
 157            ,@(map (lambda (bucket)
 158                     (let ((file-path (string-append
 159                                       directory-name
 160                                       (path-strip-directory (car bucket))
 161                                       ".html")))
 162                       `(p (a href: ,file-path ,file-path)
 163                           " ["
 164                           ,(round%
 165                             (/ (apply + (vector->list (cdr bucket)))
 166                                *total*))
 167                           " %]")))
 168                   *buckets*))))))))
 169
 170 (define (round% n)
 171   (/ (round
 172       (* 10000 n))
 173      100.))
 174
 175
 176 ;; ----------------------------------------------------------------------------
 177 ;; Included file "html.scm"
 178 ;; ----------------------------------------------------------------------------
 179
 180 ;; html.scm -- A simple html generator for Gambit-C 4.0
 181
 182 ;; Written by Guillaume Germain (germaing@iro.umontreal.ca)
 183 ;; This code is released in the public domain.
 184
 185
 186 (define (stringify x)
 187   (with-output-to-string ""
 188     (lambda ()
 189       (print x))))
 190
 191 (define (to-escaped-string x)
 192   (stringify
 193    (map (lambda (c)
 194           (case c
 195             ((#\<) "&lt;")
 196             ((#\>) "&gt;")
 197             ((#\&) "&amp;")
 198             (else c)))
 199         (string->list
 200          (stringify x)))))
 201
 202 ;; Quick and dirty conversion of s-expressions to html
 203 (define (sexp->html exp)
 204
 205   ;; write the opening tag
 206   (define (open-tag exp)
 207     (cond
 208      ;; null tag isn't valid
 209      ((null? exp)
 210       (error "null tag"))
 211
 212      ;; a tag must be a list beginning with a symbol
 213      ((and (pair? exp)
 214            (symbol? (car exp)))
 215       (list "<"
 216             (car exp)
 217             " "
 218             (maybe-args (car exp) (cdr exp))))
 219
 220      (else
 221       (error "invalid tag" exp))))
 222
 223   ;; take care of the keywords / arguments
 224   (define (maybe-args tag exp)
 225
 226     (cond
 227      ;; does the rest of the list begins with a keyword
 228      ((and (pair? exp)
 229            (keyword? (car exp)))
 230
 231       ;; does the keyword has an associated value?
 232       (if (or (null? (cdr exp))
 233               (keyword? (cadr exp)))
 234           ;; no, we don't put an associated value
 235           (list (keyword->string (car exp))
 236                 " "
 237                 (maybe-args tag (cdr exp)))
 238           ;; yes, we take the next element in the list as the value
 239           (list (keyword->string (car exp))
 240                 "=\""
 241                 (cadr exp)
 242                 "\" "
 243                 (maybe-args tag (cddr exp)))))
 244
 245      ;; must just be some content
 246      (else
 247       (content tag exp))))
 248
 249   ;; handle the content of the tag and closing it
 250   (define (content tag exp)
 251     (cond
 252      ;; no content...
 253      ((null? exp)
 254       ;;(list "></" tag ">"))           ; close as "<br></br>"
 255       (list "/>"))                      ; close as "<br/>"
 256
 257      ;; write the content, handle tags inside
 258      ((pair? exp)
 259       (list ">"
 260             (map (lambda (e)
 261                    (if (pair? e)
 262                        (open-tag e)
 263                        (to-escaped-string e)))
 264                  exp)
 265             "</"
 266             tag
 267             ">"))
 268
 269      ;; non-null terminated list?
 270      (else
 271       (error "strange content..."))))
 272
 273   (with-output-to-string ""
 274                          (lambda ()
 275                            (print (open-tag exp)))))