From cfe8a2a44473bd06a3784dd0292065f973c75e7a Mon Sep 17 00:00:00 2001 From: Vincent St-Amour Date: Fri, 29 May 2009 11:31:38 -0400 Subject: [PATCH] Forgot to add the profiler. --- profiler.scm | 275 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 275 insertions(+) create mode 100644 profiler.scm diff --git a/profiler.scm b/profiler.scm new file mode 100644 index 0000000..8530a8f --- /dev/null +++ b/profiler.scm @@ -0,0 +1,275 @@ +;; basic profiler for SIXPIC's pic18 simulator +;; basically, just reports the execution count for each instruction that is +;; kept by the simulator + +;; this is mostly taken from Guillaume Germain's statprof statistical profiler +;; for Gambit-C, hence is distributed with the same licence as Gambit-C + +;; TODO this is not yet working, it has not been completely adapted. a temporary solution is being used instead + +;; ---------------------------------------------------------------------------- +;; Text formatting + +(define (pad-left s l c) + (let loop ((s (string->list s))) + (if (< (length s) l) + (loop (cons c s)) + (list->string s)))) + + +;; ---------------------------------------------------------------------------- +;; Palette generation & color formatting + +(define (gradient from to step) + (let ((inc (map (lambda (x) (/ x step)) + (map - to from)))) + + (let loop ((i 0) + (acc '())) + (if (= i step) + (reverse acc) + (loop (+ i 1) + (cons (map + (lambda (x o) + (round (+ x (* i o)))) + from + inc) + acc)))))) + +(define (as-rgb col) + (apply string-append + (map + (lambda (x) + (pad-left (number->string x 16) 2 #\0)) + col))) + +(define palette + (list->vector + (cons '(255 255 255) + (gradient '(127 127 255) + '(255 127 127) + 16)))) + + +;; ---------------------------------------------------------------------------- +;; Functions to generate the report + +(define (write-profile-report profile-name . sources) + + (define (iota1 n) + (let loop ((n n) + (l '())) + (if (>= n 1) + (loop (- n 1) (cons n l)) + l))) + + (define directory-name (string-append (current-directory) + profile-name + "/")) + (with-exception-catcher + (lambda (e) + ;; ignore the exception, it probably means that the directory + ;; already existed. If there's another problem it will be + ;; signaled later. + #f) + (lambda () + (create-directory (list path: directory-name + permissions: #o755)))) + + (let ((max-intensity 0)) + (for-each (lambda (x) (let ((new (vector-ref instrs-counts x))) + (if (> new max-intensity) + (set! max-intensity new)))) + (iota (vector-length instrs-counts))) + (map + (lambda (adr) + (let ((file (car bucket)) ;; TODO know which file we're coming from + (data (cdr bucket))) + + (define (get-color n) + (let ((i (vector-ref data n))) + (if (= i 0) + (as-rgb (vector-ref palette 0)) + (let ((x (* (/ (log (+ 1. i)) + (max (ceiling (log max-intensity)) 1)) + (- (vector-length palette) 1)))) + (as-rgb (vector-ref palette + (inexact->exact (ceiling x)))))))) + + (with-output-to-file (string-append + directory-name + (path-strip-directory file) + ".html") + (let ((lines (call-with-input-file file + (lambda (p) (read-all p read-line))))) + (lambda () + (print + (sexp->html + `(html + (body + (table + cellspacing: 0 + cellpadding: 0 + border: 0 + style: "font-size: 12px;" + ,@(map + (lambda (line line#) + `(tr + (td ,(string-append + (number->string line#) + ": ")) + ;; (td + ;; align: center + ;; ,(let ((n (vector-ref data line#))) + ;; (if (= n 0) + ;; "" + ;; (string-append "[" + ;; (number->string n) + ;; "/" + ;; (number->string *total*) + ;; "]")))) + + (td + align: center + ,(let ((n (vector-ref data line#))) + (if (= n 0) + "" + (string-append + (number->string + (round% (/ n *total*))) + "% ")))) + + (td (pre style: ,(string-append + "background-color:#" + (get-color line#)) + ,line)))) + lines + (iota1 (length lines))))))))))))) + + (iota (vector-length instrs-counts)))) + + (with-output-to-file (string-append directory-name "index.html") + (lambda () + (print + (sexp->html + `(html + (body + ,@(map (lambda (bucket) + (let ((file-path (string-append + directory-name + (path-strip-directory (car bucket)) + ".html"))) + `(p (a href: ,file-path ,file-path) + " [" + ,(round% + (/ (apply + (vector->list (cdr bucket))) + *total*)) + " %]"))) + *buckets*)))))))) + +(define (round% n) + (/ (round + (* 10000 n)) + 100.)) + + +;; ---------------------------------------------------------------------------- +;; Included file "html.scm" +;; ---------------------------------------------------------------------------- + +;; html.scm -- A simple html generator for Gambit-C 4.0 + +;; Written by Guillaume Germain (germaing@iro.umontreal.ca) +;; This code is released in the public domain. + + +(define (stringify x) + (with-output-to-string "" + (lambda () + (print x)))) + +(define (to-escaped-string x) + (stringify + (map (lambda (c) + (case c + ((#\<) "<") + ((#\>) ">") + ((#\&) "&") + (else c))) + (string->list + (stringify x))))) + +;; Quick and dirty conversion of s-expressions to html +(define (sexp->html exp) + + ;; write the opening tag + (define (open-tag exp) + (cond + ;; null tag isn't valid + ((null? exp) + (error "null tag")) + + ;; a tag must be a list beginning with a symbol + ((and (pair? exp) + (symbol? (car exp))) + (list "<" + (car exp) + " " + (maybe-args (car exp) (cdr exp)))) + + (else + (error "invalid tag" exp)))) + + ;; take care of the keywords / arguments + (define (maybe-args tag exp) + + (cond + ;; does the rest of the list begins with a keyword + ((and (pair? exp) + (keyword? (car exp))) + + ;; does the keyword has an associated value? + (if (or (null? (cdr exp)) + (keyword? (cadr exp))) + ;; no, we don't put an associated value + (list (keyword->string (car exp)) + " " + (maybe-args tag (cdr exp))) + ;; yes, we take the next element in the list as the value + (list (keyword->string (car exp)) + "=\"" + (cadr exp) + "\" " + (maybe-args tag (cddr exp))))) + + ;; must just be some content + (else + (content tag exp)))) + + ;; handle the content of the tag and closing it + (define (content tag exp) + (cond + ;; no content... + ((null? exp) + ;;(list ">")) ; close as "

" + (list "/>")) ; close as "
" + + ;; write the content, handle tags inside + ((pair? exp) + (list ">" + (map (lambda (e) + (if (pair? e) + (open-tag e) + (to-escaped-string e))) + exp) + "")) + + ;; non-null terminated list? + (else + (error "strange content...")))) + + (with-output-to-string "" + (lambda () + (print (open-tag exp))))) -- 2.11.4.GIT