477698d4a8
Check both the beginning file pointer (bfp) and end file pointer (efp)
of the source location associated with a profile counter when updating
its count.
Assuming that each expression has a unique bfp with respect to profiling
seems to give accurate execution counts for s-expression-based source
locations as in Scheme, but causes problems when targeting other kinds
of syntax. For instance, a C-style function call, referencing the called
function by name, such as "fn(arg)", can logically have profile counters
associated with 1) the function name reference ("fn") and 2) the entire
function call expression ("fn(arg)"), both of which begin at the same
source location. Only the bfp is checked when updating profile counters,
so the two source locations are conflated, and only one counter is
incremented, which gives inaccurate execution counts for both locations;
approximately twice as many for one, and zero for the other.
original commit: d364b05c3c9cd2b299fc20a6f5ec255ab7bd6718
1206 lines
53 KiB
Scheme
1206 lines
53 KiB
Scheme
"pdhtml.ss"
|
|
;;; pdhtml.ss
|
|
;;; Copyright 1984-2016 Cisco Systems, Inc.
|
|
;;;
|
|
;;; Licensed under the Apache License, Version 2.0 (the "License");
|
|
;;; you may not use this file except in compliance with the License.
|
|
;;; You may obtain a copy of the License at
|
|
;;;
|
|
;;; http://www.apache.org/licenses/LICENSE-2.0
|
|
;;;
|
|
;;; Unless required by applicable law or agreed to in writing, software
|
|
;;; distributed under the License is distributed on an "AS IS" BASIS,
|
|
;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
|
|
;;; See the License for the specific language governing permissions and
|
|
;;; limitations under the License.
|
|
|
|
;;; NOTES:
|
|
;;; - fixed bug in define-tags: moved (void) end of text ... to start
|
|
;;;
|
|
;;; - to change palette to use white background with colorized text:
|
|
;;; (profile-palette
|
|
;;; (vector-map
|
|
;;; (lambda (p) (cons "white" (car p)))
|
|
;;; (profile-palette)))
|
|
|
|
;;; profile-dump-html suggestions from Oscar:
|
|
;;;
|
|
;;; We could probably build a table mapping source regions to procedure names
|
|
;;; in enough cases to actually be useful. If so, showing procedure name instead
|
|
;;; of line/char position would help the user get a high-level perspective on the
|
|
;;; profile results. Right now the user has to synthesize that perspective by
|
|
;;; remembering where each link led.
|
|
;;;
|
|
;;; Within the file view window, it would be nice to have a way to scan quickly
|
|
;;; through the hot spots within that file (we have some obscenely large source
|
|
;;; files at work). Perhaps you could reprise the profile spectrum horizontally
|
|
;;; in a short frame at the top of the window and rig it so that dragging, scroll
|
|
;;; wheel, or clicking on a color cycles through the regions tagged with that col>
|
|
;;;
|
|
;;; With a large range of profile counts to compress into a fairly small
|
|
;;; spectrum, it might be nice if there were a way to zoom into a range by
|
|
;;; clicking on the legend, either in the overview window or the file window.
|
|
;;; Reallocating the color map could be confusing with multiple windows open,
|
|
;;; but perhaps there's some javascript way to rig all the other colors to
|
|
;;; desaturate when you zoom into a range in one window. Perhaps intensity
|
|
;;; could be used to show the sub-ranges in varying shades of the main legend
|
|
;;; color.
|
|
;;;
|
|
;;; I notice that the profile annotations on the when expressions start at the te>
|
|
;;; expression rather than the start of the when. Yet the if expression annotati>
|
|
;;; starts at the beginning of the if expression and extends to the closing paren.
|
|
;;; Not sure if that made any sense, basically I'm trying to say that the "(when"
|
|
;;; itself (and closing paren) isn't colored the same as the test part.
|
|
;;; I don't remember exactly how we handled source annotations during wrapping and
|
|
;;; unwrapping, but it seems offhand that it might make sense to wrap the input
|
|
;;; source annotation around the transformer output so that the source info for t>
|
|
;;; when expression is transferred to the generated if expression.
|
|
|
|
(let ()
|
|
(include "types.ss")
|
|
(define op+ car)
|
|
(define op- cdr)
|
|
(define find-pcode
|
|
(foreign-procedure "(cs)find_pcode" () scheme-object))
|
|
(define find-pinfo
|
|
(lambda (x who)
|
|
(cond
|
|
[(procedure? x) ($code-pinfo* ($closure-code x))]
|
|
[($code? x) ($code-pinfo* x)]
|
|
[else ($oops who "could not find profiling info in ~s" x)])))
|
|
(set-who! profile-clear
|
|
(lambda ()
|
|
(define clear-links
|
|
(lambda (op)
|
|
(if (profile-counter? op)
|
|
(profile-counter-count-set! op 0)
|
|
(begin
|
|
(for-each clear-links (op+ op))
|
|
(for-each clear-links (op- op))))))
|
|
(for-each
|
|
(lambda (x)
|
|
(for-each (lambda (node) (clear-links (rblock-op node)))
|
|
(find-pinfo x who)))
|
|
(find-pcode))))
|
|
(set-who! profile-dump
|
|
(lambda ()
|
|
(define rblock-count
|
|
(lambda (rblock)
|
|
(let sum ((op (rblock-op rblock)))
|
|
; using #3%apply and #3%map in case the #2% versions are profiled,
|
|
; to avoid possible negative counts
|
|
(if (profile-counter? op)
|
|
(profile-counter-count op)
|
|
(- (#3%apply + (#3%map sum (op+ op)))
|
|
(#3%apply + (#3%map sum (op- op))))))))
|
|
(fold-left
|
|
(lambda (r code)
|
|
(fold-left
|
|
(lambda (r rblock)
|
|
(fold-left
|
|
(let ([count (rblock-count rblock)])
|
|
(lambda (r inst)
|
|
(cons (cons inst count) r)))
|
|
r (rblock-srecs rblock)))
|
|
r (find-pinfo code who)))
|
|
'() (find-pcode)))))
|
|
|
|
(let ()
|
|
(include "types.ss")
|
|
|
|
(define check-dump
|
|
(lambda (who x)
|
|
(unless (and (list? x)
|
|
(andmap (lambda (x)
|
|
(and (pair? x)
|
|
(source-object? (car x))
|
|
(let ([x (cdr x)])
|
|
(and (integer? x) (exact? x)))))
|
|
x))
|
|
($oops who "invalid dump ~s" x))))
|
|
|
|
(define-record-type filedata
|
|
(fields
|
|
(immutable sfd)
|
|
(immutable ip)
|
|
(mutable entry*)
|
|
; remaining fields are ignored by profile-dump-list
|
|
(mutable max-count)
|
|
(mutable ci)
|
|
(mutable htmlpath)
|
|
(mutable htmlfn)
|
|
(mutable winid))
|
|
(nongenerative)
|
|
(sealed #t)
|
|
(protocol
|
|
(lambda (new)
|
|
(lambda (sfd ip)
|
|
(new sfd ip '() #f #f #f #f #f)))))
|
|
|
|
(define-record-type entrydata
|
|
(fields
|
|
(immutable fdata)
|
|
(immutable bfp)
|
|
(immutable efp)
|
|
(mutable count)
|
|
(mutable line)
|
|
(mutable char)
|
|
; ci is ignored by profile-dump-list
|
|
(mutable ci))
|
|
(nongenerative)
|
|
(sealed #t)
|
|
(protocol
|
|
(lambda (new)
|
|
(lambda (fdata bfp efp count)
|
|
(new fdata bfp efp count #f #f #f)))))
|
|
|
|
(define (gather-filedata who warn? dumpit*)
|
|
; returns list of fdata records, each holding a list of entries
|
|
; the entries are sorted based on their (unique) bfps
|
|
(let ([fdata-ht (make-hashtable
|
|
(lambda (x) (source-file-descriptor-crc x))
|
|
(lambda (x y)
|
|
; there's no way to make this foolproof, so we identify paths with
|
|
; same crc, length, and last component. this can cause problems
|
|
; only if two copies of the same file are loaded and used.
|
|
(or (eq? x y)
|
|
(and (= (source-file-descriptor-crc x)
|
|
(source-file-descriptor-crc y))
|
|
(= (source-file-descriptor-length x)
|
|
(source-file-descriptor-length y))
|
|
(string=?
|
|
(path-last (source-file-descriptor-name x))
|
|
(path-last (source-file-descriptor-name y)))))))])
|
|
(define (open-source sfd)
|
|
(cond
|
|
[(hashtable-ref fdata-ht sfd #f)]
|
|
[($open-source-file sfd) =>
|
|
(lambda (ip)
|
|
(let ([fdata (make-filedata sfd ip)])
|
|
(hashtable-set! fdata-ht sfd fdata)
|
|
fdata))]
|
|
[else
|
|
(when warn?
|
|
(warningf who
|
|
"unmodified source file ~s not found in source directories"
|
|
(source-file-descriptor-name sfd)))
|
|
(let ([fdata (make-filedata sfd #f)])
|
|
(hashtable-set! fdata-ht sfd fdata)
|
|
fdata)]))
|
|
(for-each
|
|
(lambda (dumpit)
|
|
(let ([source (car dumpit)])
|
|
(assert (source? source))
|
|
(let ([bfp (source-bfp source)])
|
|
(when (>= bfp 0) ; weed out block-profiling entries, whose bfps are negative
|
|
(let ([fdata (open-source (source-sfd source))])
|
|
(filedata-entry*-set! fdata
|
|
(cons (make-entrydata fdata bfp (source-efp source) (cdr dumpit))
|
|
(filedata-entry* fdata))))))))
|
|
dumpit*)
|
|
(let ([fdatav (hashtable-values fdata-ht)])
|
|
(vector-for-each
|
|
(lambda (fdata)
|
|
(let ([entry* (sort (lambda (x y)
|
|
(or (> (entrydata-bfp x) (entrydata-bfp y))
|
|
(and (= (entrydata-bfp x) (entrydata-bfp y))
|
|
(> (entrydata-efp x) (entrydata-efp y)))))
|
|
(filedata-entry* fdata))])
|
|
#;(assert (not (null? entry*)))
|
|
(let loop ([entry (car entry*)] [entry* (cdr entry*)] [new-entry* '()])
|
|
(if (null? entry*)
|
|
(filedata-entry*-set! fdata (cons entry new-entry*))
|
|
(if (and (= (entrydata-bfp (car entry*)) (entrydata-bfp entry))
|
|
(= (entrydata-efp (car entry*)) (entrydata-efp entry)))
|
|
(begin
|
|
(entrydata-count-set! entry
|
|
(+ (entrydata-count entry)
|
|
(entrydata-count (car entry*))))
|
|
(loop entry (cdr entry*) new-entry*))
|
|
(loop (car entry*) (cdr entry*) (cons entry new-entry*)))))))
|
|
fdatav)
|
|
(vector->list fdatav))))
|
|
|
|
(let ()
|
|
(define (scan-file fdata)
|
|
(let ([ip (filedata-ip fdata)] [line 1] [char 1])
|
|
(define (read-until bfp next)
|
|
(let loop ([bfp bfp])
|
|
(unless (= bfp next)
|
|
(cond
|
|
[(eqv? (read-char ip) #\newline)
|
|
(set! line (+ line 1))
|
|
(set! char 1)]
|
|
[else (set! char (+ char 1))])
|
|
(loop (+ bfp 1)))))
|
|
(let ([entry* (filedata-entry* fdata)]) ; already sorted by gather-filedata
|
|
(let f ([bfp 0] [entry* entry*])
|
|
(unless (null? entry*)
|
|
(let ([entry (car entry*)] [entry* (cdr entry*)])
|
|
(let ([next (entrydata-bfp entry)])
|
|
(read-until bfp next)
|
|
(entrydata-line-set! entry line)
|
|
(entrydata-char-set! entry char)
|
|
(f next entry*))))))))
|
|
|
|
(set-who! profile-dump-list
|
|
; return list of lists of:
|
|
; - count
|
|
; - path ; current if line and char are not #f
|
|
; - bfp
|
|
; - efp
|
|
; - line ; may be #f
|
|
; - char ; may be #f
|
|
(rec profile-dump-list
|
|
(case-lambda
|
|
[() (profile-dump-list #t)]
|
|
[(warn?) (profile-dump-list warn? (profile-dump))]
|
|
[(warn? dumpit*)
|
|
(check-dump who dumpit*)
|
|
(let ([fdata* (gather-filedata who warn? dumpit*)])
|
|
(for-each scan-file (remp (lambda (x) (not (filedata-ip x))) fdata*))
|
|
(let ([ls (map (lambda (entry)
|
|
(let ([fdata (entrydata-fdata entry)])
|
|
(list
|
|
(entrydata-count entry)
|
|
(cond
|
|
[(filedata-ip fdata) => port-name]
|
|
[else (source-file-descriptor-name
|
|
(filedata-sfd fdata))])
|
|
(entrydata-bfp entry)
|
|
(entrydata-efp entry)
|
|
(entrydata-line entry)
|
|
(entrydata-char entry))))
|
|
(sort
|
|
(lambda (x y) (> (entrydata-count x) (entrydata-count y)))
|
|
(apply append (map filedata-entry* fdata*))))])
|
|
(for-each
|
|
(lambda (fdata) (cond [(filedata-ip fdata) => close-input-port]))
|
|
fdata*)
|
|
ls))]))))
|
|
|
|
(let ()
|
|
(define-record-type profilit
|
|
(nongenerative #{profilit iw9f7z5ovg4jjetsvw5m0-2})
|
|
(sealed #t)
|
|
(fields sfd bfp efp weight))
|
|
(define make-profile-database
|
|
(lambda ()
|
|
(make-hashtable
|
|
source-file-descriptor-crc
|
|
(lambda (x y)
|
|
(or (eq? x y)
|
|
(and (= (source-file-descriptor-crc x)
|
|
(source-file-descriptor-crc y))
|
|
(= (source-file-descriptor-length x)
|
|
(source-file-descriptor-length y))
|
|
(string=?
|
|
(path-last (source-file-descriptor-name x))
|
|
(path-last (source-file-descriptor-name y)))))))))
|
|
|
|
(define profile-database #f)
|
|
(define profile-source-data? #f)
|
|
(define profile-block-data? #f)
|
|
(define update-sfd!
|
|
(lambda (cell sfd)
|
|
; if the recorded sfd is the same but not eq, it's likely from an earlier session.
|
|
; overwrite so remaining hashtable equality-procedure checks are more likely to
|
|
; succeed at the eq? check
|
|
(unless (eq? (car cell) sfd)
|
|
(set-car! cell sfd))))
|
|
(set-who! profile-clear-database
|
|
(lambda ()
|
|
(set! profile-database #f)))
|
|
(set-who! profile-dump-data
|
|
(rec profile-dump-data
|
|
(case-lambda
|
|
[(ofn) (profile-dump-data ofn (profile-dump))]
|
|
[(ofn dumpit*)
|
|
(check-dump who dumpit*)
|
|
(let ([op ($open-file-output-port who ofn (file-options replace))])
|
|
(on-reset (delete-file ofn #f)
|
|
(on-reset (close-port op)
|
|
(let* ([dump dumpit*] [max-count (inexact (fold-left max 1 (map cdr dump)))])
|
|
(for-each
|
|
(lambda (dumpit)
|
|
(let ([source (car dumpit)] [count (cdr dumpit)])
|
|
(fasl-write
|
|
(make-profilit (source-sfd source) (source-bfp source) (source-efp source)
|
|
; compute weight as % of max count
|
|
(fl/ (inexact count) max-count))
|
|
op)))
|
|
dump)))
|
|
(close-port op)))])))
|
|
(set! $profile-source-data? (lambda () profile-source-data?))
|
|
(set! $profile-block-data? (lambda () profile-block-data?))
|
|
(set-who! profile-load-data
|
|
(lambda ifn*
|
|
(define populate!
|
|
(lambda (x)
|
|
(unless (profilit? x) ($oops who "invalid profile data element ~s" x))
|
|
(unless profile-database (set! profile-database (make-profile-database)))
|
|
(let ([ht (let* ([sfd (profilit-sfd x)]
|
|
[cell (hashtable-cell profile-database sfd #f)])
|
|
(update-sfd! cell sfd)
|
|
(or (cdr cell)
|
|
(let ([ht (make-hashtable values =)])
|
|
(set-cdr! cell ht)
|
|
ht)))])
|
|
; each ht entry is an alist mapping efp -> (weight . n) where n is
|
|
; the number of contributing entries so far for this sfd, bfp, and efp.
|
|
; n is used to compute the average weight of the contributing entries.
|
|
(let ([bfp.alist (hashtable-cell ht (profilit-bfp x) '())])
|
|
(cond
|
|
[(assv (profilit-efp x) (cdr bfp.alist)) =>
|
|
(lambda (a)
|
|
(let ([weight.n (cdr a)])
|
|
(let ([weight (car weight.n)] [n (cdr weight.n)])
|
|
(let ([new-n (fl+ n 1.0)])
|
|
(set-car! weight.n (fl/ (fl+ (* weight n) (profilit-weight x)) new-n))
|
|
(set-cdr! weight.n new-n)))))]
|
|
[else (set-cdr! bfp.alist (cons (cons* (profilit-efp x) (profilit-weight x) 1.0) (cdr bfp.alist)))])))
|
|
(if (fxnegative? (profilit-bfp x))
|
|
(set! profile-block-data? #t)
|
|
(set! profile-source-data? #t))))
|
|
(define (load-file ifn)
|
|
(let ([ip ($open-file-input-port who ifn)])
|
|
(on-reset (close-port ip)
|
|
(let f ()
|
|
(let ([x (fasl-read ip)])
|
|
(unless (eof-object? x)
|
|
(with-tc-mutex (populate! x))
|
|
(f)))))
|
|
(close-port ip)))
|
|
(for-each load-file ifn*)))
|
|
(set! $profile-show-database
|
|
(lambda ()
|
|
(when profile-database
|
|
(let-values ([(sfd* ht*) (hashtable-entries profile-database)])
|
|
(vector-for-each
|
|
(lambda (sfd ht)
|
|
(printf "~a:\n" (source-file-descriptor-name sfd))
|
|
(let-values ([(bfp* alist*) (hashtable-entries ht)])
|
|
(vector-for-each
|
|
(lambda (bfp alist)
|
|
(for-each
|
|
(lambda (a) (printf " ~s, ~s: ~s\n" bfp (car a) (cadr a)))
|
|
alist))
|
|
bfp* alist*)))
|
|
sfd* ht*)))))
|
|
(set! profile-query-weight
|
|
(lambda (x)
|
|
(define src->weight
|
|
(lambda (src)
|
|
(cond
|
|
[(and profile-database
|
|
(let* ([sfd (source-object-sfd src)]
|
|
[ht (hashtable-ref profile-database sfd #f)])
|
|
(and ht
|
|
(begin
|
|
; could do just one lookup if we had a nondestructive variant of
|
|
; hashtable-cell to call above
|
|
(update-sfd! (hashtable-cell profile-database sfd #f) sfd)
|
|
ht)))) =>
|
|
(lambda (ht)
|
|
(let ([alist (hashtable-ref ht (source-object-bfp src) '())])
|
|
(cond
|
|
[(assv (source-object-efp src) alist) => cadr]
|
|
[(and (fxnegative? (source-object-bfp src)) (not (null? alist)))
|
|
($oops #f "block-profiling info is out-of-date for ~s"
|
|
(source-file-descriptor-name (source-object-sfd src)))]
|
|
; no info for given bfp, efp...assume dead code and return 0
|
|
[else 0.0])))]
|
|
; no info for given sfd...assume not profiled and return #f
|
|
[else #f])))
|
|
(if (source? x)
|
|
(src->weight x)
|
|
(let ([x (syntax->annotation x)])
|
|
(if (annotation? x)
|
|
(src->weight (annotation-source x))
|
|
#f))))))
|
|
|
|
(let ()
|
|
;;; The following copyright notice goes with the %html module.
|
|
|
|
;;; Copyright (c) 2005 R. Kent Dybvig
|
|
|
|
;;; Permission is hereby granted, free of charge, to any person obtaining a
|
|
;;; copy of this software and associated documentation files (the "Software"),
|
|
;;; to deal in the Software without restriction, including without limitation
|
|
;;; the rights to use, copy, modify, merge, publish, distribute, sublicense,
|
|
;;; and/or sell copies of the Software, and to permit persons to whom the
|
|
;;; Software is furnished to do so, subject to the following conditions:
|
|
|
|
;;; The above copyright notice and this permission notice shall be included in
|
|
;;; all copies or substantial portions of the Software.
|
|
|
|
;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
|
|
;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
|
|
;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
|
|
;;; THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
|
|
;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
|
|
;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
|
|
;;; DEALINGS IN THE SOFTWARE.
|
|
|
|
(module %html ((<html> <*> attribute $tag)
|
|
(<head> <*> attribute $tag)
|
|
(<body> <*> attribute $tag)
|
|
(<script> <*> attribute $tag)
|
|
(<style> <*> attribute $tag)
|
|
(<title> <*> attribute $tag)
|
|
(<base> <*> attribute $tag)
|
|
(<link> <*> attribute $tag)
|
|
(<meta> <*> attribute $tag)
|
|
(<address> <*> attribute $tag)
|
|
(<blockquote> <*> attribute $tag)
|
|
(<del> <*> attribute $tag)
|
|
(<div> <*> attribute $tag)
|
|
(<h1> <*> attribute $tag)
|
|
(<h2> <*> attribute $tag)
|
|
(<h3> <*> attribute $tag)
|
|
(<h4> <*> attribute $tag)
|
|
(<h5> <*> attribute $tag)
|
|
(<h6> <*> attribute $tag)
|
|
(<ins> <*> attribute $tag)
|
|
(<noscript> <*> attribute $tag)
|
|
(<p> <*> attribute $tag)
|
|
(<pre> <*> attribute $tag)
|
|
(<hr> <*> attribute $tag)
|
|
(<dd> <*> attribute $tag)
|
|
(<dl> <*> attribute $tag)
|
|
(<dt> <*> attribute $tag)
|
|
(<li> <*> attribute $tag)
|
|
(<ol> <*> attribute $tag)
|
|
(<ul> <*> attribute $tag)
|
|
(<table> <*> attribute $tag)
|
|
(<caption> <*> attribute $tag)
|
|
(<colgroup> <*> attribute $tag)
|
|
(<thead> <*> attribute $tag)
|
|
(<tfoot> <*> attribute $tag)
|
|
(<tbody> <*> attribute $tag)
|
|
(<tr> <*> attribute $tag)
|
|
(<td> <*> attribute $tag)
|
|
(<th> <*> attribute $tag)
|
|
(<col> <*> attribute $tag)
|
|
(<form> <*> attribute $tag)
|
|
(<button> <*> attribute $tag)
|
|
(<fieldset> <*> attribute $tag)
|
|
(<legend> <*> attribute $tag)
|
|
(<label> <*> attribute $tag)
|
|
(<select> <*> attribute $tag)
|
|
(<optgroup> <*> attribute $tag)
|
|
(<option> <*> attribute $tag)
|
|
(<textarea> <*> attribute $tag)
|
|
(<input> <*> attribute $tag)
|
|
(<a> <*> attribute $tag)
|
|
(<bdo> <*> attribute $tag)
|
|
(<map> <*> attribute $tag)
|
|
(<object> <*> attribute $tag)
|
|
(<q> <*> attribute $tag)
|
|
(<span> <*> attribute $tag)
|
|
(<sub> <*> attribute $tag)
|
|
(<sup> <*> attribute $tag)
|
|
(<br> <*> attribute $tag)
|
|
(<img> <*> attribute $tag)
|
|
(<area> <*> attribute $tag)
|
|
(<param> <*> attribute $tag)
|
|
(<abbr> <*> attribute $tag)
|
|
(<acronym> <*> attribute $tag)
|
|
(<cite> <*> attribute $tag)
|
|
(<code> <*> attribute $tag)
|
|
(<dfn> <*> attribute $tag)
|
|
(<em> <*> attribute $tag)
|
|
(<kbd> <*> attribute $tag)
|
|
(<samp> <*> attribute $tag)
|
|
(<strong> <*> attribute $tag)
|
|
(<var> <*> attribute $tag)
|
|
(<b> <*> attribute $tag)
|
|
(<big> <*> attribute $tag)
|
|
(<i> <*> attribute $tag)
|
|
(<small> <*> attribute $tag)
|
|
(<tt> <*> attribute $tag)
|
|
<doctype>
|
|
html-text nbsp encode-url-parameter flush-html-output)
|
|
(define $tag
|
|
(lambda (tag attributes text end-tag)
|
|
(define (simple-value? s)
|
|
(define (simple-char? c)
|
|
(or (char<=? #\0 c #\9)
|
|
(char<=? #\a c #\z)
|
|
(char<=? #\A c #\Z)
|
|
(char=? c #\-)
|
|
(char=? c #\.)))
|
|
(let ([n (string-length s)])
|
|
(and (fx> n 0)
|
|
(let f ([i (fx- n 1)])
|
|
(and (simple-char? (string-ref s i))
|
|
(or (fx= i 0) (f (fx- i 1))))))))
|
|
(printf "<~a" tag)
|
|
(for-each
|
|
(lambda (a)
|
|
(if (pair? a)
|
|
(let ([value (let ([s (cdr a)])
|
|
(if (string? s)
|
|
s
|
|
(format "~a" (cdr a))))])
|
|
(if (simple-value? value)
|
|
(printf " ~a=~a" (car a) value)
|
|
(let ([n (string-length value)])
|
|
(printf " ~a=\"" (car a))
|
|
(do ([i 0 (fx+ i 1)])
|
|
((fx= i n) (write-char #\"))
|
|
(display
|
|
(let ([c (string-ref value i)])
|
|
(if (char=? c #\")
|
|
"""
|
|
(html-text-char c))))))))
|
|
(printf " ~a" a)))
|
|
attributes)
|
|
(printf ">")
|
|
(cond
|
|
[end-tag (let-values ([v* (text)])
|
|
(printf "</~a>" tag)
|
|
(apply values v*))]
|
|
[else (text)])))
|
|
(meta define <*>
|
|
(lambda (id)
|
|
(datum->syntax-object id
|
|
(string->symbol
|
|
(string-append "<" (symbol->string (syntax-object->datum id)) ">")))))
|
|
(meta define (attribute x)
|
|
(syntax-case x ()
|
|
[(a v) (identifier? #'a) #'(cons 'a v)]
|
|
[a (identifier? #'a) #''a]
|
|
[else (syntax-error x "improper attribute")]))
|
|
(define-syntax define-tags
|
|
(lambda (x)
|
|
(syntax-case x ()
|
|
[(_ tag ...)
|
|
(with-syntax ([(<tag> ...) (map <*> (syntax->list #'(tag ...)))])
|
|
#'(begin
|
|
(define-syntax <tag>
|
|
(lambda (x)
|
|
(syntax-case x ()
|
|
[(_ (attr (... ...)) text (... ...))
|
|
(with-syntax ([(attr (... ...))
|
|
(map attribute
|
|
(syntax->list #'(attr (... ...))))])
|
|
#'($tag 'tag (list attr (... ...))
|
|
(lambda () (void) text (... ...)) #t))])))
|
|
...))])))
|
|
(define-syntax define-endless-tags
|
|
(lambda (x)
|
|
(syntax-case x ()
|
|
[(_ tag ...)
|
|
(with-syntax ([(<tag> ...) (map <*> (syntax->list #'(tag ...)))])
|
|
#'(begin
|
|
(define-syntax <tag>
|
|
(lambda (x)
|
|
(syntax-case x ()
|
|
[(_) #'($tag 'tag '() (lambda () "") #f)]
|
|
[(_ (attr (... ...)))
|
|
(with-syntax ([(attr (... ...))
|
|
(map attribute
|
|
(syntax->list #'(attr (... ...))))])
|
|
#'($tag 'tag (list attr (... ...))
|
|
(lambda () "") #f))])))
|
|
...))])))
|
|
|
|
; top-level
|
|
(define-tags html head body)
|
|
|
|
; head
|
|
(define-tags script style title) ; script also special inline
|
|
(define-endless-tags base link meta)
|
|
|
|
; block-level generic
|
|
; del and ins are also phrase
|
|
(define-tags address blockquote del div h1 h2 h3 h4 h5 h6 ins noscript p pre)
|
|
(define-endless-tags hr)
|
|
|
|
; lists
|
|
(define-tags dd dl dt li ol ul)
|
|
|
|
; tables
|
|
(define-tags table caption colgroup thead tfoot tbody tr td th)
|
|
(define-endless-tags col)
|
|
|
|
; forms
|
|
(define-tags form button fieldset legend label select optgroup option textarea)
|
|
(define-endless-tags input)
|
|
|
|
; special inline
|
|
(define-tags a bdo map object q span sub sup)
|
|
(define-endless-tags br img area param)
|
|
|
|
; phrase
|
|
(define-tags abbr acronym cite code dfn em kbd samp strong var)
|
|
|
|
; font-style
|
|
(define-tags b big i small tt)
|
|
|
|
; pseudo tags
|
|
(define (<doctype>)
|
|
(printf "<!DOCTYPE html>\n"))
|
|
|
|
;;; other helpers
|
|
(define (html-text-char c)
|
|
(case c
|
|
[(#\<) "<"]
|
|
[(#\>) ">"]
|
|
[(#\&) "&"]
|
|
[(#\return) ""]
|
|
[else c]))
|
|
|
|
(define (html-text fmt . args)
|
|
(let ([s (apply format fmt args)])
|
|
(let ([n (string-length s)])
|
|
(do ([i 0 (fx+ i 1)])
|
|
((fx= i n))
|
|
(display (html-text-char (string-ref s i)))))))
|
|
|
|
(define (nbsp) (display-string " "))
|
|
|
|
(define encode-url-parameter
|
|
(let ()
|
|
(define get-encoding
|
|
(let ([encoding (make-vector 256)])
|
|
(do ([i 0 (fx+ i 1)])
|
|
((fx= i 256))
|
|
(let ([c (integer->char i)])
|
|
(cond
|
|
[(or (char<=? #\a c #\z)
|
|
(char<=? #\A c #\Z)
|
|
(char<=? #\0 c #\9)
|
|
(memv c '(#\$ #\- #\_ #\. #\+ #\! #\* #\' #\( #\) #\,)))
|
|
(vector-set! encoding i c)]
|
|
[(char=? c #\space) (vector-set! encoding i #\+)]
|
|
[else (vector-set! encoding i (format "%~(~2,'0x~)" i))])))
|
|
(lambda (c)
|
|
(let ([n (char->integer c)])
|
|
(if (fx< n 256)
|
|
(vector-ref encoding c)
|
|
($oops 'encode-url-parameter "cannot encode non-latin-1 character ~s" c))))))
|
|
(lambda (s)
|
|
(define (string-insert! s1 i1 s2 n2)
|
|
(do ([i2 0 (fx+ i2 1)] [i1 i1 (fx+ i1 1)])
|
|
((fx= i2 n2))
|
|
(string-set! s1 i1 (string-ref s2 i2))))
|
|
(let ([n (string-length s)])
|
|
(let f ([i 0] [j 0])
|
|
(if (fx= i n)
|
|
(make-string j)
|
|
(let ([x (get-encoding (string-ref s i))])
|
|
(if (char? x)
|
|
(let ([s (f (fx+ i 1) (fx+ j 1))])
|
|
(string-set! s j x)
|
|
s)
|
|
(let ([xn (string-length x)])
|
|
(let ([s (f (fx+ i 1) (fx+ j xn))])
|
|
(string-insert! s j x xn)
|
|
s))))))))))
|
|
|
|
(define (flush-html-output) (flush-output-port))
|
|
)
|
|
(import %html)
|
|
|
|
(define (assign-colors ncolors fdata*)
|
|
; assign highest color to entries whose counts are within X% of maximum
|
|
; count, where X = 100/ncolors, then recur without assigned color or
|
|
; entries to which it is assigned
|
|
; NB: color 0 is for unprofiled code, and color 1 is for unexecuted code
|
|
(let loop ([entry* (sort (lambda (x y)
|
|
(> (entrydata-count x) (entrydata-count y)))
|
|
(apply append (map filedata-entry* fdata*)))]
|
|
[ci (- ncolors 1)])
|
|
(unless (null? entry*)
|
|
(let ([limit (if (= ci 1)
|
|
-1
|
|
(let ([max-count (entrydata-count (car entry*))])
|
|
(truncate (* max-count (- 1 (/ 1 (- ci 1)))))))])
|
|
(let loop2 ([entry* entry*])
|
|
(unless (null? entry*)
|
|
(let ([entry (car entry*)])
|
|
(if (<= (entrydata-count entry) limit)
|
|
(loop entry* (- ci 1))
|
|
(let ([fdata (entrydata-fdata entry)])
|
|
(unless (filedata-ci fdata)
|
|
(filedata-ci-set! fdata ci))
|
|
(entrydata-ci-set! entry ci)
|
|
(loop2 (cdr entry*)))))))))))
|
|
|
|
(define-syntax with-html-file
|
|
(syntax-rules ()
|
|
[(_ who palette ?path title body1 body2 ...)
|
|
(let ([path ?path])
|
|
(let ([op ($open-file-output-port who path
|
|
(file-options replace)
|
|
(buffer-mode block)
|
|
(current-transcoder))])
|
|
(on-reset (delete-file path #f)
|
|
(on-reset (close-port op)
|
|
(parameterize ([current-output-port op])
|
|
(<doctype>)
|
|
(<html> ()
|
|
(newline)
|
|
(<head> ()
|
|
(newline)
|
|
(<meta> ([http-equiv "Content-Type"]
|
|
[content "text/html;charset=utf-8"]))
|
|
(newline)
|
|
(<title> () (html-text "~a" title))
|
|
(newline)
|
|
(display-style-with-palette palette)
|
|
(newline))
|
|
(newline)
|
|
(let () body1 body2 ...)
|
|
(newline))))
|
|
(close-port op))))]))
|
|
|
|
(define (display-file who palette fdata)
|
|
(let ([ip (filedata-ip fdata)] [line 1] [char 1])
|
|
(define (copy-all)
|
|
(html-text "~a"
|
|
(with-output-to-string
|
|
(rec f
|
|
(lambda ()
|
|
(let ([c (read-char ip)])
|
|
(unless (eof-object? c)
|
|
(write-char c)
|
|
(f))))))))
|
|
(define (read-space imax)
|
|
(with-output-to-string
|
|
(lambda ()
|
|
(let f ([imax imax])
|
|
(unless (= imax 0)
|
|
(let ([c (peek-char ip)])
|
|
(when (memv c '(#\space #\tab))
|
|
(read-char ip)
|
|
(set! char (+ char 1))
|
|
(write-char c)
|
|
(f (- imax 1)))))))))
|
|
(define (read-to-eol imax)
|
|
(with-output-to-string
|
|
(lambda ()
|
|
(let f ([imax imax])
|
|
(unless (= imax 0)
|
|
(let ([c (peek-char ip)])
|
|
(unless (or (eof-object? c) (char=? c #\newline))
|
|
(read-char ip)
|
|
(set! char (+ char 1))
|
|
(write-char c)
|
|
(f (- imax 1)))))))))
|
|
(define (copy-until bfp next ci title)
|
|
(let loop ([bfp bfp])
|
|
(unless (= bfp next)
|
|
(let ([s (read-to-eol (- next bfp))])
|
|
(let ([n (string-length s)])
|
|
(when (> n 0)
|
|
(if ci
|
|
(<span> ([class (color-class ci)] [title title])
|
|
(html-text "~a" s))
|
|
(html-text "~a" s)))
|
|
(let ([bfp (+ bfp n)])
|
|
(unless (= bfp next)
|
|
; next character must be newline, if not eof
|
|
(when (eof-object? (read-char ip))
|
|
($oops who
|
|
"unexpected end-of-file on ~s"
|
|
ip))
|
|
(let ([bfp (+ bfp 1)])
|
|
(newline)
|
|
(set! line (+ line 1))
|
|
(set! char 1)
|
|
(let ([s (read-space (- next bfp))])
|
|
(let ([n (string-length s)])
|
|
(when (> n 0) (display s))
|
|
(loop (+ bfp n))))))))))))
|
|
(define-syntax with-line-numbers
|
|
(syntax-rules ()
|
|
[(_ e1 e2 ...)
|
|
(let ([th (lambda () e1 e2 ...)])
|
|
(cond
|
|
[(profile-line-number-color) =>
|
|
(lambda (color)
|
|
(define line-count
|
|
(let loop ([n 0] [bol? #t])
|
|
(let ([c (read-char ip)])
|
|
(if (eof-object? c)
|
|
(begin (set-port-position! ip 0) n)
|
|
(loop (if bol? (+ n 1) n) (char=? c #\newline))))))
|
|
(<table> ()
|
|
(<tr> ()
|
|
(<td> ([style (format "color: ~a; font-weight: bold; padding-right: 1rem; text-align: right" color)])
|
|
(<pre> ()
|
|
(unless (fx= line-count 0)
|
|
(newline)
|
|
(let loop ([i 1])
|
|
(<span> ([id (format "line~d" i)]) (html-text "~s\n" i))
|
|
(unless (fx= i line-count) (loop (fx+ i 1)))))))
|
|
(<td> () (th)))))]
|
|
[else (th)]))]))
|
|
(with-html-file who palette (filedata-htmlpath fdata) (port-name ip)
|
|
(<body> ([class (color-class 0)])
|
|
(newline)
|
|
(<h1> ([style "margin-bottom: 1rem"])
|
|
(html-text "~a" (port-name ip)) (<span> ([style "opacity: 0.5"]) (html-text " on ~a" (date-and-time))))
|
|
(newline)
|
|
(with-line-numbers
|
|
(<pre> ()
|
|
(newline)
|
|
(let ([entry* (filedata-entry* fdata)]) ; already sorted by gather-filedata
|
|
(let f ([bfp 0] [entry* entry*] [efp #f] [ci #f] [title ""])
|
|
(cond
|
|
[(and (null? entry*) (not efp)) (copy-all)]
|
|
[(and (not (null? entry*))
|
|
(or (not efp) (< (entrydata-bfp (car entry*)) efp)))
|
|
(let ([entry (car entry*)] [entry* (cdr entry*)])
|
|
(let ([next (entrydata-bfp entry)])
|
|
(copy-until bfp next ci title)
|
|
(entrydata-line-set! entry line)
|
|
(entrydata-char-set! entry char)
|
|
(let-values ([(bfp entry*)
|
|
(f next entry*
|
|
(entrydata-efp entry)
|
|
(entrydata-ci entry)
|
|
(format "line ~d char ~d count ~:d" line char (entrydata-count entry)))])
|
|
(f bfp entry* efp ci title))))]
|
|
[else
|
|
(copy-until bfp efp ci title)
|
|
(values efp entry*)])))))
|
|
(newline)))))
|
|
|
|
(define color-class
|
|
(lambda (ci)
|
|
(format "pc~s" ci)))
|
|
|
|
(define (display-style-with-palette palette)
|
|
(<style> ([type "text/css"])
|
|
(newline)
|
|
|
|
;; CSS Reset Styling
|
|
|
|
;; See https://perishablepress.com/a-killer-collection-of-global-css-reset-styles/ for an overview
|
|
;; of CSS resets.
|
|
;;
|
|
;; See http://code.stephenmorley.org/html-and-css/fixing-browsers-broken-monospace-font-handling/
|
|
;; for an explanation of "font-family: monospace, monospace;" and the following "font-size: 1rem;".
|
|
;;
|
|
(printf "* {")
|
|
(printf " border: 0;")
|
|
(printf " margin: 0;")
|
|
(printf " outline: 0;")
|
|
(printf " padding: 0;")
|
|
(printf " vertical-align: baseline;")
|
|
(printf " }\n")
|
|
(printf "code, kbd, pre, samp {")
|
|
(printf " font-family: monospace, monospace;")
|
|
(printf " font-size: 1rem;")
|
|
(printf " }\n")
|
|
(printf "html {")
|
|
(printf " -moz-osx-font-smoothing: grayscale;")
|
|
(printf " -webkit-font-smoothing: antialiased;")
|
|
(printf " }\n")
|
|
(printf "table {")
|
|
(printf " border-collapse: collapse;")
|
|
(printf " border-spacing: 0;")
|
|
(printf " }\n")
|
|
|
|
;; CSS Base Styling
|
|
|
|
(printf "body {")
|
|
(printf " padding: 1rem;")
|
|
(printf " }\n")
|
|
(printf "h1, h2, h3, h4 {")
|
|
(printf " line-height: 1.25;")
|
|
(printf " margin-bottom: 0.5rem;")
|
|
(printf " }\n")
|
|
(printf "h1 {")
|
|
(printf " font-size: 1.296rem;")
|
|
(printf " }\n")
|
|
(printf "h2 {")
|
|
(printf " font-size: 1.215rem;")
|
|
(printf " }\n")
|
|
(printf "h3 {")
|
|
(printf " font-size: 1.138rem;")
|
|
(printf " }\n")
|
|
(printf "h4 {")
|
|
(printf " font-size: 1.067rem;")
|
|
(printf " }\n")
|
|
(printf "html {")
|
|
(printf " font-family: monospace, monospace;")
|
|
(printf " font-size: 1rem;")
|
|
(printf " }\n")
|
|
(printf "p {")
|
|
(printf " margin-bottom: 1.25rem;")
|
|
(printf " }\n")
|
|
|
|
;; CSS Profile Styling
|
|
|
|
(do ([ci 0 (fx+ ci 1)])
|
|
((fx= ci (vector-length palette)))
|
|
(let ([color (vector-ref palette ci)])
|
|
(printf ".~a { background-color: ~a; color: ~a; white-space: nowrap; }\n"
|
|
(color-class ci) (car color) (cdr color))))))
|
|
|
|
(define (safe-prefix name name*)
|
|
(define (prefix? prefix str)
|
|
(let ([n (string-length prefix)])
|
|
(and (fx<= n (string-length str))
|
|
(string=? prefix (substring str 0 n)))))
|
|
(define (digit+? s i n)
|
|
(and (fx< i n)
|
|
(let ([n (fx- n 1)])
|
|
(let loop ([i i])
|
|
(and (char-numeric? (string-ref s i))
|
|
(or (fx= i n) (loop (fx+ i 1))))))))
|
|
(define (okay? prefix)
|
|
(let loop ([name* name*])
|
|
(or (null? name*)
|
|
(let ([next-name (car name*)])
|
|
(or (not (prefix? name next-name))
|
|
(and (or (not (prefix? prefix next-name))
|
|
(not (digit+? next-name
|
|
(string-length prefix)
|
|
(string-length next-name))))
|
|
(loop (cdr name*))))))))
|
|
(let try ([prefix name])
|
|
(let ([prefix (format "~a-" prefix)])
|
|
(if (okay? prefix)
|
|
prefix
|
|
(try prefix)))))
|
|
|
|
(define (readable-number n)
|
|
(cond
|
|
[(>= n 1000000000) (format "~~~sB" (quotient n 1000000000))]
|
|
[(>= n 1000000) (format "~~~sM" (quotient n 1000000))]
|
|
[(>= n 1000) (format "~~~sK" (quotient n 1000))]
|
|
[else (format "~a" n)]))
|
|
|
|
(set-who! profile-dump-html
|
|
(rec profile-dump-html
|
|
(case-lambda
|
|
[() (profile-dump-html "")]
|
|
[(path-prefix) (profile-dump-html path-prefix (profile-dump))]
|
|
[(path-prefix dumpit*)
|
|
(unless (string? path-prefix)
|
|
($oops who "~s is not a string" path-prefix))
|
|
(check-dump who dumpit*)
|
|
(let ([palette (profile-palette)])
|
|
(let ([fdata* (gather-filedata who #f dumpit*)])
|
|
(when (null? fdata*)
|
|
($oops who "no profiled code found"))
|
|
(for-each
|
|
(lambda (fdata)
|
|
(filedata-max-count-set! fdata
|
|
(apply max
|
|
(map entrydata-count
|
|
(filedata-entry* fdata)))))
|
|
fdata*)
|
|
; assign unique html pathnames to fdatas with ips
|
|
(let ([fdata*
|
|
(sort
|
|
(lambda (x y)
|
|
(let ([xpath (path-last (port-name (filedata-ip x)))]
|
|
[ypath (path-last (port-name (filedata-ip y)))])
|
|
(or (string<? xpath ypath)
|
|
(and (string=? xpath ypath)
|
|
(< (source-file-descriptor-crc (filedata-sfd x))
|
|
(source-file-descriptor-crc (filedata-sfd x)))))))
|
|
(remp (lambda (x) (not (filedata-ip x))) fdata*))])
|
|
(for-each
|
|
(lambda (fdata i htmlpath)
|
|
(filedata-htmlpath-set! fdata htmlpath)
|
|
(filedata-htmlfn-set! fdata (path-last htmlpath))
|
|
(filedata-winid-set! fdata (format "win~s" i)))
|
|
fdata*
|
|
(enumerate fdata*)
|
|
(let f ([name* (map (lambda (fdata)
|
|
(path-last (port-name (filedata-ip fdata))))
|
|
fdata*)]
|
|
[last-name #f])
|
|
(if (null? name*)
|
|
'()
|
|
(let ([name (car name*)])
|
|
(if (equal? name last-name)
|
|
(let ([prefix (safe-prefix name name*)])
|
|
(let g ([name* (cdr name*)] [i 0])
|
|
(cons (format "~a~a~s.html" path-prefix prefix i)
|
|
(if (and (not (null? name*))
|
|
(string=? (car name*) name))
|
|
(g (cdr name*) (+ i 1))
|
|
(f name* name)))))
|
|
(cons (format "~a~a.html" path-prefix name)
|
|
(f (cdr name*) name))))))))
|
|
(assign-colors (vector-length palette) fdata*)
|
|
(with-html-file who palette (format "~aprofile.html" path-prefix) "Profile Output"
|
|
(<body> ([class (color-class 0)])
|
|
(newline)
|
|
(<h1> ([style "margin-bottom: 1rem"])
|
|
(html-text "Profile Output") (<span> ([style "opacity: 0.5"]) (html-text " on ~a" (date-and-time))))
|
|
(newline)
|
|
(<table> ()
|
|
(<tr> ()
|
|
(newline)
|
|
(<td> ([style "vertical-align: top"])
|
|
(<h2> ([style "margin-bottom: 0.25rem"])
|
|
(html-text "Legend"))
|
|
(newline)
|
|
(<table> ([style "margin-bottom: 1rem"])
|
|
(newline)
|
|
(let* ([n (vector-length palette)] [v (make-vector n #f)])
|
|
(for-each
|
|
(lambda (fdata)
|
|
(for-each
|
|
(lambda (entry)
|
|
(let ([ci (entrydata-ci entry)]
|
|
[count (entrydata-count entry)])
|
|
(vector-set! v ci
|
|
(let ([p (vector-ref v ci)])
|
|
(if p
|
|
(cons (min (car p) count)
|
|
(max (cdr p) count))
|
|
(cons count count))))))
|
|
(filedata-entry* fdata)))
|
|
fdata*)
|
|
(do ([ci (- n 1) (- ci 1)])
|
|
((= ci 0))
|
|
(let ([p (vector-ref v ci)])
|
|
(when p
|
|
(<tr> ()
|
|
(<td> ([class (color-class ci)]
|
|
[style "padding: 0.5rem"])
|
|
(let ([smin (readable-number (car p))]
|
|
[smax (readable-number (cdr p))])
|
|
(if (string=? smin smax)
|
|
(html-text "executed ~a time~p"
|
|
smin (car p))
|
|
(html-text "executed ~a-~a times"
|
|
smin smax)))))
|
|
(newline))))))
|
|
(newline)
|
|
(<h2> ([style "margin-bottom: 0.25rem"])
|
|
(html-text "Files"))
|
|
(newline)
|
|
(<table> ([style "margin-bottom: 1rem"])
|
|
(newline)
|
|
(for-each
|
|
(lambda (fdata)
|
|
(let ([ip (filedata-ip fdata)])
|
|
(<tr> ()
|
|
(<td> ([class (color-class (filedata-ci fdata))]
|
|
[style "padding: 0.5rem"])
|
|
(if ip
|
|
(<a> ([href (filedata-htmlfn fdata)]
|
|
[target (filedata-winid fdata)]
|
|
[class (color-class (filedata-ci fdata))])
|
|
(html-text "~a" (port-name (filedata-ip fdata))))
|
|
(html-text "~a"
|
|
(source-file-descriptor-name (filedata-sfd fdata))))))
|
|
(newline)
|
|
(when ip (display-file who palette fdata))))
|
|
(sort
|
|
(lambda (x y)
|
|
(> (filedata-max-count x)
|
|
(filedata-max-count y)))
|
|
fdata*))))
|
|
(newline)
|
|
(<td> ([style "width: 10rem"]))
|
|
(newline)
|
|
(<td> ([style "vertical-align: top"])
|
|
(<h2> ([style "margin-bottom: 0.25rem"])
|
|
(html-text "Hot Spots"))
|
|
(newline)
|
|
(<table> ([style "margin-bottom: 1rem"])
|
|
(newline)
|
|
(let loop ([entry*
|
|
(sort
|
|
(lambda (x y)
|
|
(or (> (entrydata-count x) (entrydata-count y))
|
|
(and (= (entrydata-count x) (entrydata-count y))
|
|
(let ([fn1 (filedata-htmlfn (entrydata-fdata x))]
|
|
[fn2 (filedata-htmlfn (entrydata-fdata y))])
|
|
(and fn1 fn2
|
|
(or (string<? fn1 fn2)
|
|
(and (string=? fn1 fn2)
|
|
(let ([line1 (entrydata-line x)]
|
|
[line2 (entrydata-line y)])
|
|
(and line1 line2 (< line1 line2))))))))))
|
|
(apply append (map filedata-entry* fdata*)))]
|
|
[last-htmlfn #f]
|
|
[last-count #f]
|
|
[last-line #f])
|
|
(unless (or (null? entry*) (= (entrydata-count (car entry*)) 0))
|
|
(let* ([entry (car entry*)]
|
|
[count (entrydata-count entry)]
|
|
[line (entrydata-line entry)]
|
|
[fdata (entrydata-fdata entry)]
|
|
[htmlfn (filedata-htmlfn fdata)])
|
|
(unless (and htmlfn last-htmlfn
|
|
(string=? htmlfn last-htmlfn)
|
|
(= count last-count)
|
|
(= line last-line))
|
|
(<tr> ()
|
|
(<td> ([class (color-class (entrydata-ci entry))]
|
|
[style "padding: 0.5rem"])
|
|
(cond
|
|
[(filedata-ip fdata) =>
|
|
(lambda (ip)
|
|
(let ([url (format "~a#line~d"
|
|
(filedata-htmlfn fdata)
|
|
line)])
|
|
(<a> ([href url]
|
|
[target (filedata-winid fdata)]
|
|
[style "text-decoration: underline"]
|
|
[class (color-class (entrydata-ci entry))])
|
|
(html-text "~a line ~s (~:d)"
|
|
(port-name ip) (entrydata-line entry)
|
|
(entrydata-count entry)))))]
|
|
[else
|
|
(html-text "~a char ~s (~:d)"
|
|
(source-file-descriptor-name (filedata-sfd fdata))
|
|
(entrydata-bfp entry)
|
|
(entrydata-count entry))])))
|
|
(newline))
|
|
(loop (cdr entry*) htmlfn count line)))))
|
|
(newline))
|
|
(newline)))
|
|
(newline)))
|
|
(for-each
|
|
(lambda (fdata) (cond [(filedata-ip fdata) => close-input-port]))
|
|
fdata*)))]))))
|
|
|
|
(set-who! profile-palette
|
|
(make-parameter
|
|
; color background with appropriate white or black foreground
|
|
'#(("#111111" . "white") ; black (for unprofiled code)
|
|
("#607D8B" . "white") ; gray (for unexecuted code)
|
|
("#9C27B0" . "black") ; purple
|
|
("#673AB7" . "white") ; dark purple
|
|
("#3F51B5" . "white") ; dark blue
|
|
("#2196F3" . "black") ; medium blue
|
|
("#00BCD4" . "black") ; aqua
|
|
("#4CAF50" . "black") ; green
|
|
("#CDDC39" . "black") ; yellow green
|
|
("#FFEB3B" . "black") ; yellow
|
|
("#FFC107" . "black") ; dark yellow
|
|
("#FF9800" . "black") ; orange
|
|
("#F44336" . "white")) ; red
|
|
(lambda (palette)
|
|
(unless (and (vector? palette)
|
|
(andmap
|
|
(lambda (x)
|
|
(and (pair? x) (string? (car x)) (string? (cdr x))))
|
|
(vector->list palette)))
|
|
($oops who "invalid palette ~s" palette))
|
|
(unless (fx> (vector-length palette) 2)
|
|
($oops who "palette ~s has too few entries" palette))
|
|
palette)))
|
|
|
|
(set-who! profile-line-number-color
|
|
(make-parameter "#666666"
|
|
(lambda (color)
|
|
(unless (or (eq? color #f) (string? color)) ($oops who "~s is not a string or #f" color))
|
|
color)))
|
|
)
|