mycroft.lsp

#!/usr/bin/env newlisp

;; @module mycroft
;; @author cormullion at mac dot com
;; @description newLISP script profiler
;; @location somewhere on github
;; @version 0.0.2 of 2011-09-20 13:02:56
;; Use Mycroft to profile the performance of a single newLISP script. 
;; Use at the command line:
;; newlisp mycroft.lsp file-to-profile
;; or
;; mycroft.lsp file-to-profile
;;
;; Your script should (exit) when it's finished, so that Mycroft can report.
;; Only functions defined with 'define' are profiled... :(
;;
;; This was my entry in the Christmas 2008 newLISP programming competition. 
;; I was the only entrant. :( I think I won an imaginary T shirt. :)
;; I don't know how to profile this script.

(unless unicode (println "using a non-Unicode version of newLISP; things may go wrong..."))
(global '*file*)
(unless (set '*file* (main-args 2)) (println "specify a newLISP script to profile\n" (exit)))
(unless (file? *file*) (println "...that file doesn't exist\n" (exit)))

;; The script is disorganized and a bit long. It's divided into about 5 sections.
;; Stage 1: First, we load the newlisp-parser and add some functions for html output
;; Stage 2: we define some HTML output functions and CSS styles
;; Stage 3: we define our analysis routines, then redefine some newLISP primitives so that execution timings are recorded.
;; Stage 4: we run the script, and hope it exits when it's finished. Otherwise we're stuffed.
;; Stage 5: we analyse the timings and produce an HTML report.

; Stage 1: load parser and add some more definitions to Nlex
(context 'Nlex)
(load (string (env {HOME}) {/projects/programming/newlisp-projects/newlisp-parser.lsp}))
(define (set-up-syntax)
  (set 'built-in-functions (map string  (symbols 'MAIN)))
  (set 'obsolete-functions (map string '(write-buffer read-buffer name parse-date assoc-set nth-set ref-set replace-assoc set-assoc set-nth)))
  (set 'newlisp-variables  (map string '(ostype $0 $1 $2 $3 $4 $5 $6 $7 $8 $9 $10 $11 $12 $13 $14 $15 $args $idx $it $main-args)))
  (set 'parenlevel 0))

(define (nlx-to-html nlx (depth 0))
   (when (= depth 0) 
         (set 'buff {}) ; if first pass, initialize a buffer
         (set-up-syntax))
   (dolist (i nlx)
       (set 'token-type (first i) 'token-value (last i))
       (if  (atom? token-type)
            (cond 
               ((= token-type 'LeftParen)  
                    (inc paren-level)
                    (write buff (format {<span class="open-paren%d">(<span class="plain">} paren-level )))
               ((= token-type 'RightParen)
                    (write buff (format {</span>)</span>}))
                    (dec paren-level))
               ((= token-type 'Symbol)
                    (cond
                      ((find token-value newlisp-variables)
                          (write buff (string {<span class="variable">} (Html:escape-html token-value) {</span>})))
                      ((find token-value obsolete-functions)
                          (write buff (string {<span class="obsolete">} (Html:escape-html token-value) {</span>})))
                      ((find token-value built-in-functions)
                          (write buff (string {<span class="built-in">} (Html:escape-html token-value) {</span>})))
                      (true
                          (write buff (string {<span class="symbol">}   (Html:escape-html token-value) {</span>})))))
               ((= token-type 'WhiteSpace)  
                    (write buff {<span class="white-space">})
                    (dostring (s (base64-dec (string token-value))) 
                        (write buff (char s)))
                    (write buff {</span>}))
               ((= token-type 'BracedString)  
                    (write buff (string {<span class="braced-string">} "{" (Html:escape-html token-value) "}" {</span>})))
               ((= token-type 'QuotedString)  
                    (write buff (string {<span class="quoted-string">} {"} (Html:escape-html token-value) {"} {</span>})))
               ((= token-type 'BracketedText)  
                    (write buff (string {<span class="bracketed-string">} {[text]} (Html:escape-html  token-value) {[/text]} {</span>})))        
               ((= token-type 'Quote)
                    (write buff (string {<span class="quote">'</span>})))
               ((= token-type 'Comment)  
                    (write buff (string {<span class="comment">} (Html:escape-html token-value) {</span>} )))
               ((= token-type 'Integer)  
                    (write buff (string {<span class="integer">} (int token-value) {</span>})))
               ((= token-type 'Float)  
                    (write buff (string {<span class="float">} (Html:escape-html token-value) {</span>})))
               ((= token-type 'Scientific)  
                    (write buff (string {<span class="scientific">} (Html:escape-html token-value) {</span>})))
               ((= token-type 'Hex)  
                    (write buff (string {<span class="hex-string">} (Html:escape-html token-value) {</span>})))                
               ((= token-type 'BracketedCommand)  
                    (write buff (string {<span class="bracketed-command">} token-value  {</span>})))                
               ((= token-type 'NaN) ; not a number
                    (write buff (string {<span class="NaN">} token-value  {</span>})))
               ((= token-type 'Octal)
                    (write buff (string {<span class="octal">}  token-value {</span>})))
               ((= token-type 'BracketedIdentifier) ; bracketed identifier
                    (write buff (string {<span class="octal">[}  token-value {]</span>}))))                    
            ; not an atom, so recurse but don't initialize buffer
            (nlx-to-html i 1)))
   buff)

;  Stage 2 Define some HTML routines
;  HTML 

(define (Html:Html str)
  (if (not Html:html-page)
    (set 'Html:html-page str)
    (write-line Html:html-page str)))

(context 'Html)

(define (Html:escape-html txt)
 (if txt
  (begin
   (replace {&} txt {&amp;} 0)
   (replace {<} txt {&lt;} 0)
   (replace {>} txt {&gt;} 0)))
 txt)

(define (Html:header)
  (Html [text]<!DOCTYPE html PUBLIC "-//W3C//DTD HTML 4.01//EN"
  "http://www.w3.org/TR/html4/strict.dtd">
<html lang="en">
<head>
  <meta http-equiv="Content-Type" content="text/html; charset=utf-8">
  <title>[/text])
 (Html "Mycroft: report") ; To-Do: title to include file name
 (Html [text]</title>
 <style type="text/css" media="screen">
* { margin: 0;
	padding: 0;
	list-style-type: none; }
body {
	font-family: Helvetica, Arial, sans-serif;
	color: #222; }
a {
	color: #555;
	text-decoration: none;
	font-weight: bold; }
/* hovering */
a:hover { color: #000; }
a span { display: none; }
a:hover span {
	display: block;
	float: right;
	z-index: 100;
	border: 0px dotted #c0c0c0;
	color: #282; }
h2, h3, h4 { clear: both; }
h2, h3 {
	border-bottom: 1px solid #555;
	margin-bottom: .9em; }
h3 { padding-top: 1em; }
h4 {
	font-weight: normal;
	font-size: 0.9em;
	color: #900000;
	margin-left: 1em; }
.main {
	float: left;
	clear: left;
	padding: 1em 2em; }
.section {
	float: left;
	clear: left; }
.main .key {
	clear: left;
	float: left;
	display: block;
	width: 230px;
	text-align: left;
	color: #111;
	font-weight: bold;}
.main .value {
	float: left;
	display: block;
	text-align: left;
	color: #222;
	font-weight: normal;}
.chartlist {
	float: left;
	border-top: 1px solid #ccc;
	width: 800px; }
.chartlist li {
	position: relative;
	display: block;
	border-bottom: 1px solid #fff;
	_zoom: 1; }
.chartlist li a {
	display: block;
	padding: 0.4em 4.5em 0.4em 0.5em;
	position: relative;
	z-index: 2; }
/* text at right of bar */
.chartlist .count {
	display: block;
	position: absolute;
	top: 0;
	right: 0;
	margin: 0 0.3em;
	text-align: right;
	color: #333;
	font-weight: bold;
	font-size: 0.875em;
	line-height: 2em;
	z-index: 2; }
/* the bar */
.chartlist .index {
	display: block;
	position: absolute;
	top: 0;
	left: 0;
	height: 100%;
	background: #9f9;
	text-indent: -9999px;
	overflow: hidden;
	line-height: 2em; }
.chartlist li:hover { background: #dddddd; }
p {
	font-size: 0.7 em;
	margin: 1em 0 1em 0;
	color: #444; }
blockquote { margin-left: 2em; }
p span { display: normal; }
pre, code {
	font-family: Monaco, 'Andale Mono', 'Lucida Console', monospace;
	font-size: 10pt;
	/* http://users.tkk.fi/~tkarvine/pre-wrap-css3-mozilla-opera-ie.html */
	/* css-3 */
	/* Mozilla, since 1999 */
	/* Opera 4-6 */
	white-space: -o-pre-wrap;
	/* Opera 7 */
	word-wrap: break-word;
	/* Internet Explorer 5.5+ */ }
.symbol { color: #dd3333; background: #ffffff;}
.built-in {color: #550000; font-weight: bold;}
.obsolete {color: #ffff00; background: #000;}
.variable { color: #ff8888; background: #eeffff;}
.braced-string {color: #226666; background: #eeffff;}
.quoted-string {color: #226666; background: #eeffff;}
.bracketed-string {color: #226666; background: #eeffff;}
.quote { color: #224400; background: #eeffff;}
.comment
{
	color: #666666;
	font-family: serif;
	background: #eeffee;
}
.integer { color: #113366; background: #eeffbb; }
.float { color: #335533; background: #eeffcd;}
.hex { color: #336633;  background: #eeffdc;}
.octal { color: #336699; background: #ffffff;}
.white-space {background: #ffffff;}
.plain {background-color: #fff}

span.open-paren1 {
	color:  #666; }
span.open-paren1:hover {
   -webkit-transition: background-color 0.7s linear; 
	color: #000;
	background-color: #f90; }

span.open-paren2 {
	color:  #666; }
span.open-paren2:hover {
 -webkit-transition: background-color 0.7s linear; 
    color: #111;
	background-color: #f20; }

span.open-paren3 {
	color:  #666; }
span.open-paren3:hover {
 -webkit-transition: background-color 0.7s linear; 
    color: #222;
	background-color: #59f; }

span.open-paren4 {
	color:  #666; }
span.open-paren4:hover {
 -webkit-transition: background-color 0.7s linear; 
    color: #333;
	background-color: #FFA3CF; }

span.open-paren5 {
	color:  #666; }
span.open-paren5:hover {
 -webkit-transition: background-color 0.7s linear; 
	background-color: #BCA9FF; }

span.open-paren6 {
	color:  #666; }
span.open-paren6:hover {
 -webkit-transition: background-color 0.7s linear; 
	background-color: #FFDCA1; }

span.open-paren7 {
	color:  #666; }
span.open-paren7:hover {
 -webkit-transition: background-color 0.7s linear; 
	background-color: #9DFFAA; }
	
span.open-paren8 {
	color:  #666; }
span.open-paren8:hover {
 -webkit-transition: background-color 0.7s linear; 
	background-color: #ACD2FF; }

span.open-paren9 {
	color:  #666; }
span.open-paren9:hover {
    -webkit-transition: background-color 0.7s linear; 
	background-color: #AFFFFB; }

span.open-paren10 {
	color:  #666; }
    span.open-paren10:hover {
 -webkit-transition: background-color 0.7s linear; 
	background-color: #EBFFD6; }
</style>
</head>
[/text]))

(define (Html:body)
  (Html {<body>
  <div class="main">
  }))
  
(define (Html:heading level text)
   (Html (string {<h} level {><a name="} text {">} text {</a></h} level {>})))

(define (Html:para text)
   (Html (string {<p>} text {</p>})))

(define (Html:key-value key value)
   (Html (string {<p><span class="key">} key {</span>} {<span class="value">} value {</span></p>})))

(define (Html:start-bar-chart title title2)
  (Html {<div class="section">
  })
  (heading 3 title)
  (heading 4 title2)
  (Html {  <ul class="chartlist">}))

(define (Html:add-bar item count-value unit-string index-value hover-text link-text)
; hover text shows additional info
; could really do with named parameters for passing values to this function :)
  (Html (string {
    <li> 
      <a href="} (Html:escape-html link-text) {">} (Html:escape-html item) {<span>} hover-text {</span>}{</a>
      <span class="count">} count-value unit-string {</span>
      <span class="index" style="width: } index-value {%">} index-value {"</span>
    </li>})))

(define (Html:end-bar-chart)
   (Html [text]
   </ul>
   </div>
   [/text]))

(define (Html:end-page)
   (Html [text]
</div>
</body>
</html>
[/text]))

; Stage 3 Analysis functions and redefine newLISP primitives for profiling
(context 'Call-list) ; hold timings for each user-defined function
(context 'Mycroft)
(set 'version {0.0.1})
(set 'built-in-functions (map string (symbols 'MAIN)))
(set 'function-data '())
(set 'results '())

(define (start)
    (set 'results (list (list 'start (time-of-day)))))

(define (stop)
    (push (list 'stop (time-of-day)) results -1))

(define (crunch-numbers)
   (println {started crunching numbers }) 
   (let ((time-taken (sub (last (last results)) (last (first results)))))
    ; for each entry in results, find elapsed time for that call
    ; by subtracting it from the previous one
    ; quicker: build new list then swap     
      (set 'previous (first results))
      (for (i 0 (dec (length results) 2))
           (set 'current (results i))
           (push (list (first previous) (sub (last current) (last previous))) results1 -1)
           (set 'previous current))
      (set 'results results1)
      (pop results) ; but don't do last one
      ; results now contains every call to each function in the order it was called, with time taken each call  
      ; gather into new dictionary Call-list, one entry per function
      (dolist (t results)
         (if (set 'tm (Call-list (string (first t))))
             (Call-list  (string (first t)) (inc (last t) tm))
             (Call-list  (string (first t)) (last t))))
      ; to tidy output, remove the ones we added
      ; no longer need these in the list
      (Call-list "start" nil)
      (Call-list "stop" nil)
      (set 'total-function-calls (length results))
      ; functions are sorted by name and have accumulated duration totals
      ; add up durations - another view of total elapsed time  
      (set 'total-function-call-time 0)
      (map (fn (pr) (inc total-function-call-time (last pr))) (Call-list))
      ; add extra data to the list
      ; don't need to copy - the generated assoc list is an on-the-fly copy, not the original
      (set 'function-data (Call-list))
      (replace
        '(+ +)
        function-data
        (begin
            (set 'fname (first $it))
            (set 'total-time (last $it))
        (list fname ; function-name
               (mul 100 (div (last $it) total-function-call-time))   ; time as percentage of total time
              ; number of times function was called
              ; results holds symbols but function-data (call-list) holds strings...
              ; read-expr translates string to symbol in context but does not evaluate it
              (length (find-all (list (read-expr fname) '+) results))
              ; total microseconds for this function
              total-time))
        match)))

; add a time stamp to each function defined with 'define'
(define-macro (Mycroft:define farg)
    (if (list? farg)
        (set  (farg 0)
              (letex (@fn (farg 0)
                      arg (rest farg)
                      @arg-p (cons 'list
                          (map
                              (fn   (x) (if (list? x) (first x) x))
                              (rest farg)))
                      body (cons 'begin (args)))
                  (lambda arg 
                    (push (list '@fn (time-of-day)) Mycroft:results -1) body)))
        (if (args) (set farg (eval (first (args)))) (set farg nil))))

(define (Mycroft:exit)
   (println "(exit) - program exited"))

(context MAIN)

; switch over some functions

(constant (global 'newLISP-define) define)
(constant (global 'define) Mycroft:define)
(constant (global 'newLISP-exit) exit)
(constant (global 'exit) Mycroft:exit)

; Stage 4: run the script, wait till exit.

(context Mycroft)
(println "...loaded profiling code")
(println "...loading file " *file*)
(println "...starting execution")
; run the file
(set 'start-timing (time-of-day))
(start)
(unless (catch (load *file*) 'error) 
        (println (string "sorry the file didn't load and execute correctly:\n\t" error))
        (newLISP-exit))
(stop)
(set 'finish-timing (sub (time-of-day) start-timing))

; Stage 5: analyse data and produce report 

(println "...file has finished executing")
(println "...analysing results")

(crunch-numbers)

(println "...preparing report")
(Html:header)
(Html:body)
(Html:heading 2 (string {Mycroft: report: } *file*))
(Html:key-value {file:} (Html:escape-html (real-path *file*)))
(Html:key-value {date:} (date))
(Html:key-value {time:} (string (round total-function-call-time 0) {ms, } (div total-function-call-time 1000)  " seconds"))
(Html:key-value {function calls:} (string total-function-calls))
(Html:key-value {operating system:} ostype)
(Html:key-value {newLISP version} (sys-info -2))
(Html:key-value {mycroft version} version)
(Html:heading 3 {Contents})

(Html:para {<a href="#Timings">Timings</a> <a href="#Calls">Calls</a> <a href="#Symbols">Symbols</a> 
 <a href="#Source">Source</a> <a href="#Trivia">Trivia</a>})

(Html:start-bar-chart "Timings" " % of total execution time")
(dolist (f-data (sort function-data (fn (a b) (> (last a) (last b)))))
 ; f-data is: function-name | time as % of total time | number of times function was called | total microseconds
 ;                  0                   1                               2                               3
  (set 'avg-time (round (div (f-data 3) (f-data 2)) -2))
  (Html:add-bar 
       (f-data 0)                   ; item
       (round (f-data 1) -1)        ; count-value
       "%"                          ; unit-string 
       (f-data 1)                   ; index-value
      ; hover-text
      (string 
        (f-data 2) (if (= (f-data 2) 1) { call; (} { calls; (}) ; shouldn't have "1 calls" ! :)
        (round (mul (div (f-data 2) total-function-calls) 100) -2) {% of total);}
        { average: } avg-time { ms; }
        { total: } (round (f-data 3) -1) { ms }) 
      "#Source"))
(Html:end-bar-chart)

(Html:start-bar-chart "Calls" "the number of times each function was called")
(dolist (f-data (sort function-data (fn (a b) (> (a 2) (b 2)))))
  (Html:add-bar 
         (f-data 0)        ; item
         (f-data 2)        ; count-value
         " x"              ; unit-string 
         (mul 100 (div (f-data 2) ((first function-data) 2))) ; index-value
         (string { (} (round (mul (div (f-data 2) total-function-calls) 100) 0) {%)}) ; hover-text
         "#Source"         ; link-text
         ))
(Html:end-bar-chart)

(println {... analyzing source})

(define Symbol-list:Symbol-list)

(set 'nlx (Nlex:parse-newlisp (read-file *file*)))

(set-ref-all '(Nlex:Symbol +) (copy nlx) 
  (begin
    (if (set 'total (Symbol-list (last $it)))
        (Symbol-list (last $it) (inc total))
        (Symbol-list (last $it) 1))
    $it)
  match)

(Html:start-bar-chart "Symbols" (string "the number of occurrences of a symbol in " *file*))

(dolist (symbl (sort (Symbol-list) (fn (a b) (> (a 1) (b 1)))))
  (Html:add-bar 
   (first symbl)   ; item
   (symbl 1)       ; count-value
   " x"            ; unit-string 
   (symbl 1)       ; index-value   
   {}              ; hover-text
   "#Source"       ; link-text
   ))

(Html:end-bar-chart)

(println "...formatting source")

(Html:heading 3 {Source})

(Html (format "<pre><code>%s</code></pre>" (Nlex:nlx-to-html nlx)))

(println {...formatting succeeded, now generating trivia})

(Html:heading 3 {Trivia})

; source trivia now, just to fill up the page :)
(println {...symbols})

; symbol counting
(set 'user-syms '())
; symbols in parsed source have to be prefixed from here
(set-ref-all '(Nlex:Symbol +) (copy nlx) (push (last $it) user-syms -1) match)

(Html:key-value {user-defined symbols} (string (length (difference user-syms built-in-functions))))
(Html:key-value {built-in primitives}  (string (length (intersect  user-syms built-in-functions))))

; parenthesis counting
(println {...parentheses})
(set-ref-all '(Nlex:LeftParen +) (copy nlx) (push (last $it) open-parens -1) match)
(Html:key-value {number of open parentheses} (length open-parens))
(set-ref-all '(Nlex:RightParen +) (copy nlx) (push (last $it) close-parens -1) match)
(Html:key-value {number of close parentheses} (length close-parens))

; the number of characters...
(println {...character count})
(set 'file-char-count (if unicode (utf8len (read-file *file*)) (length (read-file *file*))))
(Html:key-value {characters} (string file-char-count))

; white space characters
(println {...white space})
(set 'white-stuff "")
(set-ref-all '(Nlex:WhiteSpace +) (copy nlx)  (push (last $it) white-space -1) match)
(map (fn (c) (push (base64-dec c) white-stuff -1)) white-space)
(Html:key-value {whitespace characters} (format {%d spaces, %d returns, and %d tabs} (count '({ } "\n" "\t") (explode white-stuff))))

; comments
(println {...comments})
(set-ref-all '(Nlex:Comment +) (copy nlx) (push (last $it) comments -1) match)
(map (fn (c) (inc comment-chars (if unicode (utf8len c) (length c)))) comments)
(Html:key-value {comments} 
  (format {%d characters in %d comment%s} comment-chars (length comments) (if (= (length comments) 1) {} {s})))

(Html:end-page)
(println "saving report as " (set 'report-file (string "/tmp/" *file* (date (date-value) 0 {%Y%m%d%H%M%S}) "-my.html")))

(write-file report-file Html:html-page)

; open the report file ...?
(cond
  ((= ostype "OSX")     (exec (string "open " report-file)))
  ((= ostype "Win32")   (exec (string "c:/" report-file)))
  (true                 (println {report file is } report-file)))

(newLISP-exit)