tmtt
/
chez-openbsd
Archived
1
0
Fork 0
Code Issues Pull Requests Releases 1 Activity
You cannot select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
This repo is archived. You can view files and clone it, but cannot push or open issues/pull-requests.
main
v9.5.9
Branches Tags
${ item.name }
Create tag ${ searchTerm }
Create branch ${ searchTerm }
from 'main'
${ noResults }
chez-openbsd/mats/profile.ms

1001 lines
38 KiB
Scheme
Raw Permalink Blame History

(mat compile-profile
(error? ; invalid argument
(compile-profile 'src))
(eqv?
(parameterize ([compile-profile #t])
(compile-profile))
'source)
(eqv?
(parameterize ([compile-profile 'source])
(compile-profile))
'source)
(eqv?
(parameterize ([compile-profile 'block])
(compile-profile))
'block)
(error? ; incorrect argument count
(profile-dump '()))
(error? ; incorrect argument count
(profile-clear '()))
(error? ; incorrect argument count
(profile-dump-list #t '() 3))
(error? ; invalid dump
(profile-dump-list #f 17))
(error? ; invalid dump
(profile-dump-list #f '(17)))
(error? ; invalid dump
(profile-dump-list #f '((a . 17))))
(error? ; invalid dump
(profile-dump-list #f `((,(make-source-object (source-file-descriptor "abc" 34) 0 3) . q))))
(error? ; incorrect argument count
(profile-dump-html "" '() 3))
(error? ; not a string
(profile-dump-html '(prefix)))
(error? ; invalid dump
(profile-dump-html "profile" 17))
(error? ; invalid dump
(profile-dump-html "profile" '(17)))
(error? ; invalid dump
(profile-dump-html "profile" '((a . 17))))
(error? ; invalid dump
(profile-dump-html "profile" `((,(make-source-object (source-file-descriptor "abc" 34) 0 3) . q))))
(error? ; incorrect argument count
(profile-dump-data))
(error? ; incorrect argument count
(profile-dump-data "profile.data" '() 'q))
(error? ; not a string
(profile-dump-data #t))
(error? ; invalid dump
(profile-dump-data "profile.data" 17))
(error? ; invalid dump
(profile-dump-data "profile.data" '(17)))
(error? ; invalid dump
(profile-dump-data "profile.data" '((a . 17))))
(error? ; invalid dump
(profile-dump-data "profile.data" `((,(make-source-object (source-file-descriptor "abc" 34) 0 3) . q))))
(error? ; not a string
(profile-load-data 'what?))
(eqv? (parameterize ([compile-profile #t])
(compile
'(let ()
(define (f x) (if (= x 0) 1 (* x (f (- x 1)))))
(f 3))))
6)
(eqv? (parameterize ([compile-profile #t])
(compile
'(let ()
(define fat+
(lambda (x y)
(if (zero? y)
x
(fat+ (1+ x) (1- y)))))
(define fatfib
(lambda (x)
(if (< x 2)
1
(fat+ (fatfib (1- x)) (fatfib (1- (1- x)))))))
(fatfib 20))))
10946)
(equal?
(parameterize ([compile-profile #t])
(compile
'(let ()
(define $values (lambda (n) (lambda () (apply values (make-list n)))))
(define foo
(lambda (n)
(call/cc
(lambda (k)
(with-exception-handler
(lambda (c) (collect) (k 'okay))
(lambda ()
(define f (case-lambda))
(let ([x (random 10)])
(call-with-values ($values n) f))))))))
(list (foo 0) (foo 1) (foo 3) (foo 10) (foo 100) (foo 1000)))))
'(okay okay okay okay okay okay))
; no longer recording (useless) profiling information when source file & position aren't available
#;(let ([ls (profile-dump)])
(and (list? ls)
(not (null? ls))))
(eqv? (profile-clear) (void))
(or (eq? (compile-profile) 'source) (andmap zero? (map cdr (remp preexisting-profile-dump-entry? (profile-dump)))))
(begin (set! cp-fatfib (void)) #t) ; release fatfib
(begin (define $old-cp (compile-profile)) #t)
; this collect is here to make it more likely that we won't get a generation 1
; collection cementing in place the code that defines cp-fact
(begin (collect 1) #t)
(mat/cf (testfile "testfile")
(eval-when (compile) (compile-profile 'source))
(define (cp-fact x) (if (= x 0) 1 (* x (cp-fact (- x 1))))))
(eq? (compile-profile) $old-cp)
; drop code that defines cp-fact so it won't show up in profile-dump-list in
; hopes of resolving potential issue with comparison to pdl further down
(begin (collect (collect-maximum-generation)) #t)
(= (cp-fact 10) 3628800)
(begin
(define (prefix=? prefix s)
(let ([n (string-length prefix)])
(and (>= (string-length s) n) (string=? (substring s 0 n) prefix))))
(define (sdir? x) (or (prefix=? "../s" (cadr x)) (prefix=? "../unicode" (cadr x))))
(define-values (pdl pdl2)
(with-interrupts-disabled
(parameterize ([source-directories (cons* "../s" "../unicode" (source-directories))])
(values
(remp sdir? (profile-dump-list #t (profile-dump)))
(remp sdir? (profile-dump-list))))))
#t)
(equal? pdl pdl2)
(not (null? pdl))
(begin
(rm-rf "testdir")
(mkdir "testdir")
(parameterize ([gensym-prefix 0]) (profile-dump-html "testdir/" (profile-dump)))
#t)
(file-exists? "testdir/profile.html")
(file-exists? "testdir/testfile.ss.html")
(begin (define $old-cp (compile-profile)) #t)
(mat/cf (testfile "testfile-block")
(eval-when (compile) (compile-profile 'block))
(define (cp-fact-block x) (if (= x 0) 1 (* x (cp-fact-block (- x 1))))))
(eq? (compile-profile) $old-cp)
(= (cp-fact-block 10) 3628800)
(or (equal? (compile-profile) 'source)
(equal?
(parameterize ([source-directories (cons* "../s" "../unicode" (source-directories))])
(remp sdir? (profile-dump-list)))
pdl))
(begin
(parameterize ([source-directories (cons* "../s" "../unicode" (source-directories))])
(profile-dump-html))
#t)
(file-exists? "profile.html")
(file-exists? "testfile.ss.html")
(not (file-exists? "testfile2.ss.html"))
(eqv? (profile-clear) (void))
(mat/cf (testfile "testfile")
(eval-when (compile) (compile-profile #t))
(define (cp-fact x) (if (= x 0) 1 (* x (cp-fact (- x 1))))))
(= (cp-fact 10) 3628800)
(eqv? (profile-dump-data "testfile1.pd" (remp preexisting-profile-dump-entry? (profile-dump))) (void))
(file-exists? "testfile1.pd")
(eqv? (profile-load-data) (void))
(eqv? (profile-load-data "testfile1.pd") (void))
(begin
(define $cp-ip (open-file-input-port "testfile.ss"))
(define $cp-sfd (make-source-file-descriptor "testfile.ss" $cp-ip))
(define $qw (lambda (bfp efp) (profile-query-weight (make-source-object $cp-sfd bfp efp))))
#t)
(eqv? (close-port $cp-ip) (void))
(eqv? ($qw 0 0) 0.0) ; bfp, efp combination not in database
(eqv? ; file not in database
(let* ([fn (format "~a/Mf-base" *mats-dir*)]
[ip (open-file-input-port fn)]
[sfd (make-source-file-descriptor fn ip)])
(close-port ip)
(profile-query-weight (make-source-object sfd 0 0)))
#f)
((lambda (x) (and (memv x (list 0.0 (/ 1.0 11.0))) #t)) ($qw 0 42))
((lambda (x) (and (memv x (list 0.0 (/ 1.0 11.0))) #t)) ($qw 43 102))
(eqv? ($qw 63 101) 1.0)
(eqv? ($qw 75 76) (fl/ 1.0 11.0))
(eqv? ($qw 77 100) (fl/ 10.0 11.0))
((lambda (x) (and (memv x (list 0.0 (/ 1.0 11.0))) #t)) ($qw 103 127))
(eqv? ($qw 119 126) 0.0)
(eqv? ($qw 120 125) 0.0)
(eqv? (profile-clear) (void))
(= (cp-fact 5) 120)
(eqv? (profile-dump-data "testfile2.pd" (remp preexisting-profile-dump-entry? (profile-dump))) (void))
(eqv? (profile-load-data "testfile2.pd") (void))
((lambda (x) (and (memv x (list 0.0 (/ 1.0 11.0) (fl/ (/ 1.0 11.0) 2.0))) #t)) ($qw 0 42))
(eqv? ($qw 21 40) 0.0)
((lambda (x) (and (memv x (list 0.0 (/ 1.0 11.0) (fl/ (/ 1.0 11.0) 2.0))) #t)) ($qw 43 102))
(eqv? ($qw 63 101) 1.0)
(eqv? ($qw 75 76) (fl/ (fl+ (/ 1.0 11.0) (fl/ 1.0 6.0)) 2.0))
(eqv? ($qw 77 100) (fl/ (fl+ (fl/ 10.0 11.0) (fl/ 5.0 6.0)) 2.0))
((lambda (x) (and (memv x (list 0.0 (/ 1.0 11.0) (fl/ (/ 1.0 11.0) 2.0))) #t)) ($qw 103 127))
(eqv? ($qw 119 126) 0.0)
(eqv? ($qw 120 125) 0.0)
(eqv? (profile-clear) (void))
; make sure all is well when compiled with source profile info
(mat/cf (testfile "testfile")
(eval-when (compile) (compile-profile 'block))
(define (cp-fact x) (if (= x 0) 1 (* x (cp-fact (- x 1))))))
(eqv? (profile-dump-data "testfile3.pd" (remp preexisting-profile-dump-entry? (profile-dump))) (void))
(file-exists? "testfile3.pd")
(eqv? (profile-load-data "testfile3.pd") (void))
; and again with block profile info
(mat/cf (testfile "testfile")
(eval-when (compile) (compile-profile #f))
(define (cp-fact x) (if (= x 0) 1 (* x (cp-fact (- x 1))))))
(= (cp-fact 5) 120)
(eqv? (profile-clear-database) (void))
(eqv? ($qw 0 42) #f)
(eqv? ($qw 77 100) #f)
; make sure record-ref, record-type, and record-cd are properly handled by
; find-source in pdhtml
(mat/cf
(eval-when (compile) (compile-profile #t))
(library (A) (export make-foo foo? foo-x) (import (chezscheme)) (define-record-type foo (fields x)))
(let ()
(import (A))
(define add-foo-xs
(lambda ls
(let f ([ls ls] [sum 0])
(if (null? ls) sum (f (cdr ls) (+ (foo-x (car ls)) sum))))))
; make sure this is still around when we call profile-dump-list
(set! $add-foo-xs add-foo-xs)
(pretty-print (add-foo-xs (make-foo 1) (make-foo 2) (make-foo 3)))))
(not (null? (profile-dump-list)))
(eqv? (profile-clear) (void))
(begin (set! $add-foo-xs #f) #t)
(vector? (profile-palette))
(vector?
(parameterize ([profile-palette (vector-map
(lambda (p) (cons "white" (car p)))
(profile-palette))])
(profile-palette)))
(parameterize ([profile-palette
'#(("black" . "white")
("red" . "white")
("blue" . "black"))])
(= (vector-length (profile-palette)) 3))
(error? (profile-palette '#()))
(error? (profile-palette '#(("black" . "white"))))
(error? (profile-palette '#(("black" . "white") ("red" . "white"))))
(error?
(profile-palette
'#(("black" . "white")
#("red" "white")
("blue" . "black"))))
(error?
(profile-palette
'#(("black" . "white")
("red" . "white")
("blue" . black))))
(error?
(profile-palette
'#(("black" . "white")
("red" . "white")
(#x0000ff . "black"))))
; test for proper counts in the presence of control operators
(begin
(define $return)
(define $retry)
(with-output-to-file "testfile-cp1.ss"
(lambda ()
(display-string "\
(define $frumble
(lambda (ls)
(if (null? ls)
1
(let ([n (car ls)])
(if (eqv? n 0)
(call/cc (lambda (k) (set! $retry k) ($return 0)))
(let ([q ($frumble (cdr ls))])
(add1 (* q n))))))))
"))
'replace)
(profile-clear)
(parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f] [optimize-level 2] [compile-profile #t])
(load "testfile-cp1.ss" compile))
#t)
(eqv?
($frumble (make-list 100 5))
9860761315262647567646607066034827870915080438862787559628486633300781)
(equal?
(filter (lambda (x) (equal? (cadr x) "testfile-cp1.ss")) (profile-dump-list))
'((101 "testfile-cp1.ss" 36 258 3 5)
(101 "testfile-cp1.ss" 40 50 3 9)
(101 "testfile-cp1.ss" 41 46 3 10)
(101 "testfile-cp1.ss" 47 49 3 16)
(100 "testfile-cp1.ss" 69 257 5 9)
(100 "testfile-cp1.ss" 78 86 5 18)
(100 "testfile-cp1.ss" 79 82 5 19)
(100 "testfile-cp1.ss" 83 85 5 23)
(100 "testfile-cp1.ss" 99 256 6 11)
(100 "testfile-cp1.ss" 103 113 6 15)
(100 "testfile-cp1.ss" 104 108 6 16)
(100 "testfile-cp1.ss" 109 110 6 21)
(100 "testfile-cp1.ss" 111 112 6 23)
(100 "testfile-cp1.ss" 193 255 8 15)
(100 "testfile-cp1.ss" 202 221 8 24)
(100 "testfile-cp1.ss" 203 211 8 25)
(100 "testfile-cp1.ss" 212 220 8 34)
(100 "testfile-cp1.ss" 213 216 8 35)
(100 "testfile-cp1.ss" 217 219 8 39)
(100 "testfile-cp1.ss" 240 254 9 17)
(100 "testfile-cp1.ss" 241 245 9 18)
(100 "testfile-cp1.ss" 246 253 9 23)
(100 "testfile-cp1.ss" 247 248 9 24)
(100 "testfile-cp1.ss" 249 250 9 26)
(100 "testfile-cp1.ss" 251 252 9 28)
(1 "testfile-cp1.ss" 0 260 1 1)
(1 "testfile-cp1.ss" 19 259 2 3)
(1 "testfile-cp1.ss" 59 60 4 9)
(0 "testfile-cp1.ss" 128 178 7 15)
(0 "testfile-cp1.ss" 129 136 7 16)
(0 "testfile-cp1.ss" 137 177 7 24)
(0 "testfile-cp1.ss" 149 164 7 36)
(0 "testfile-cp1.ss" 162 163 7 49)
(0 "testfile-cp1.ss" 165 176 7 52)
(0 "testfile-cp1.ss" 166 173 7 53)
(0 "testfile-cp1.ss" 174 175 7 61)))
(eqv?
(call/cc
(lambda (k)
(set! $return k)
(let ([ans ($frumble (append (make-list 50 5) (list 0) (make-list 50 7)))])
($return ans))))
0)
(equal?
(filter (lambda (x) (equal? (cadr x) "testfile-cp1.ss")) (profile-dump-list))
'((152 "testfile-cp1.ss" 36 258 3 5)
(152 "testfile-cp1.ss" 40 50 3 9)
(152 "testfile-cp1.ss" 41 46 3 10)
(152 "testfile-cp1.ss" 47 49 3 16)
(151 "testfile-cp1.ss" 69 257 5 9)
(151 "testfile-cp1.ss" 78 86 5 18)
(151 "testfile-cp1.ss" 79 82 5 19)
(151 "testfile-cp1.ss" 83 85 5 23)
(151 "testfile-cp1.ss" 99 256 6 11)
(151 "testfile-cp1.ss" 103 113 6 15)
(151 "testfile-cp1.ss" 104 108 6 16)
(151 "testfile-cp1.ss" 109 110 6 21)
(151 "testfile-cp1.ss" 111 112 6 23)
(150 "testfile-cp1.ss" 193 255 8 15)
(150 "testfile-cp1.ss" 202 221 8 24)
(150 "testfile-cp1.ss" 203 211 8 25)
(150 "testfile-cp1.ss" 212 220 8 34)
(150 "testfile-cp1.ss" 213 216 8 35)
(150 "testfile-cp1.ss" 217 219 8 39)
(100 "testfile-cp1.ss" 240 254 9 17)
(100 "testfile-cp1.ss" 241 245 9 18)
(100 "testfile-cp1.ss" 246 253 9 23)
(100 "testfile-cp1.ss" 247 248 9 24)
(100 "testfile-cp1.ss" 249 250 9 26)
(100 "testfile-cp1.ss" 251 252 9 28)
(1 "testfile-cp1.ss" 0 260 1 1)
(1 "testfile-cp1.ss" 19 259 2 3)
(1 "testfile-cp1.ss" 59 60 4 9)
(1 "testfile-cp1.ss" 128 178 7 15)
(1 "testfile-cp1.ss" 129 136 7 16)
(1 "testfile-cp1.ss" 137 177 7 24)
(1 "testfile-cp1.ss" 149 164 7 36)
(1 "testfile-cp1.ss" 162 163 7 49)
(1 "testfile-cp1.ss" 165 176 7 52)
(1 "testfile-cp1.ss" 166 173 7 53)
(1 "testfile-cp1.ss" 174 175 7 61)))
(eqv?
(call/cc
(lambda (k)
(set! $return k)
($retry 1)))
111022302462515654042363166809082031)
(equal?
(filter (lambda (x) (equal? (cadr x) "testfile-cp1.ss")) (profile-dump-list))
'((152 "testfile-cp1.ss" 36 258 3 5)
(152 "testfile-cp1.ss" 40 50 3 9)
(152 "testfile-cp1.ss" 41 46 3 10)
(152 "testfile-cp1.ss" 47 49 3 16)
(151 "testfile-cp1.ss" 69 257 5 9)
(151 "testfile-cp1.ss" 78 86 5 18)
(151 "testfile-cp1.ss" 79 82 5 19)
(151 "testfile-cp1.ss" 83 85 5 23)
(151 "testfile-cp1.ss" 99 256 6 11)
(151 "testfile-cp1.ss" 103 113 6 15)
(151 "testfile-cp1.ss" 104 108 6 16)
(151 "testfile-cp1.ss" 109 110 6 21)
(151 "testfile-cp1.ss" 111 112 6 23)
(150 "testfile-cp1.ss" 193 255 8 15)
(150 "testfile-cp1.ss" 202 221 8 24)
(150 "testfile-cp1.ss" 203 211 8 25)
(150 "testfile-cp1.ss" 212 220 8 34)
(150 "testfile-cp1.ss" 213 216 8 35)
(150 "testfile-cp1.ss" 217 219 8 39)
(150 "testfile-cp1.ss" 240 254 9 17)
(150 "testfile-cp1.ss" 241 245 9 18)
(150 "testfile-cp1.ss" 246 253 9 23)
(150 "testfile-cp1.ss" 247 248 9 24)
(150 "testfile-cp1.ss" 249 250 9 26)
(150 "testfile-cp1.ss" 251 252 9 28)
(1 "testfile-cp1.ss" 0 260 1 1)
(1 "testfile-cp1.ss" 19 259 2 3)
(1 "testfile-cp1.ss" 59 60 4 9)
(1 "testfile-cp1.ss" 128 178 7 15)
(1 "testfile-cp1.ss" 129 136 7 16)
(1 "testfile-cp1.ss" 137 177 7 24)
(1 "testfile-cp1.ss" 149 164 7 36)
(1 "testfile-cp1.ss" 162 163 7 49)
(1 "testfile-cp1.ss" 165 176 7 52)
(1 "testfile-cp1.ss" 166 173 7 53)
(1 "testfile-cp1.ss" 174 175 7 61)))
(begin
(collect (collect-maximum-generation)) ; drop code object for the define and lambda
(profile-release-counters) ; drop proile information for the dropped code object
#t)
(equal?
(filter (lambda (x) (equal? (cadr x) "testfile-cp1.ss")) (profile-dump-list))
'((152 "testfile-cp1.ss" 36 258 3 5)
(152 "testfile-cp1.ss" 40 50 3 9)
(152 "testfile-cp1.ss" 41 46 3 10)
(152 "testfile-cp1.ss" 47 49 3 16)
(151 "testfile-cp1.ss" 69 257 5 9)
(151 "testfile-cp1.ss" 78 86 5 18)
(151 "testfile-cp1.ss" 79 82 5 19)
(151 "testfile-cp1.ss" 83 85 5 23)
(151 "testfile-cp1.ss" 99 256 6 11)
(151 "testfile-cp1.ss" 103 113 6 15)
(151 "testfile-cp1.ss" 104 108 6 16)
(151 "testfile-cp1.ss" 109 110 6 21)
(151 "testfile-cp1.ss" 111 112 6 23)
(150 "testfile-cp1.ss" 193 255 8 15)
(150 "testfile-cp1.ss" 202 221 8 24)
(150 "testfile-cp1.ss" 203 211 8 25)
(150 "testfile-cp1.ss" 212 220 8 34)
(150 "testfile-cp1.ss" 213 216 8 35)
(150 "testfile-cp1.ss" 217 219 8 39)
(150 "testfile-cp1.ss" 240 254 9 17)
(150 "testfile-cp1.ss" 241 245 9 18)
(150 "testfile-cp1.ss" 246 253 9 23)
(150 "testfile-cp1.ss" 247 248 9 24)
(150 "testfile-cp1.ss" 249 250 9 26)
(150 "testfile-cp1.ss" 251 252 9 28)
(1 "testfile-cp1.ss" 59 60 4 9)
(1 "testfile-cp1.ss" 128 178 7 15)
(1 "testfile-cp1.ss" 129 136 7 16)
(1 "testfile-cp1.ss" 137 177 7 24)
(1 "testfile-cp1.ss" 149 164 7 36)
(1 "testfile-cp1.ss" 162 163 7 49)
(1 "testfile-cp1.ss" 165 176 7 52)
(1 "testfile-cp1.ss" 166 173 7 53)
(1 "testfile-cp1.ss" 174 175 7 61)))
; test profiling with compiled files
(begin
(with-output-to-file "testfile-cp2.ss"
(lambda ()
(display-string "\
(define cp2-fib
(rec fib
(lambda (n)
(cond
[(fx= n 0) 1]
[(fx= n 1) 1]
[else (+ (fib (- n 1)) (fib (- n 2)))]))))
"))
'replace)
(parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f] [optimize-level 2] [compile-profile #t])
(compile-file "testfile-cp2"))
(profile-clear)
(load "testfile-cp2.so")
#t)
(eqv? (cp2-fib 10) 89)
(equal?
(filter (lambda (x) (equal? (cadr x) "testfile-cp2.ss")) (profile-dump-list))
'((177 "testfile-cp2.ss" 49 146 4 7)
(177 "testfile-cp2.ss" 64 73 5 10)
(177 "testfile-cp2.ss" 65 68 5 11)
(177 "testfile-cp2.ss" 69 70 5 15)
(177 "testfile-cp2.ss" 71 72 5 17)
(143 "testfile-cp2.ss" 86 95 6 10)
(143 "testfile-cp2.ss" 87 90 6 11)
(143 "testfile-cp2.ss" 91 92 6 15)
(143 "testfile-cp2.ss" 93 94 6 17)
(88 "testfile-cp2.ss" 113 144 7 15)
(88 "testfile-cp2.ss" 114 115 7 16)
(88 "testfile-cp2.ss" 116 129 7 18)
(88 "testfile-cp2.ss" 117 120 7 19)
(88 "testfile-cp2.ss" 121 128 7 23)
(88 "testfile-cp2.ss" 122 123 7 24)
(88 "testfile-cp2.ss" 124 125 7 26)
(88 "testfile-cp2.ss" 126 127 7 28)
(88 "testfile-cp2.ss" 130 143 7 32)
(88 "testfile-cp2.ss" 131 134 7 33)
(88 "testfile-cp2.ss" 135 142 7 37)
(88 "testfile-cp2.ss" 136 137 7 38)
(88 "testfile-cp2.ss" 138 139 7 40)
(88 "testfile-cp2.ss" 140 141 7 42)
(55 "testfile-cp2.ss" 96 97 6 20)
(34 "testfile-cp2.ss" 74 75 5 20)
(1 "testfile-cp2.ss" 0 149 1 1)
(1 "testfile-cp2.ss" 18 148 2 3)
(1 "testfile-cp2.ss" 23 26 2 8)
(1 "testfile-cp2.ss" 31 147 3 5)))
(begin
(collect (collect-maximum-generation)) ; drop code object for the define and lambda
(profile-release-counters) ; drop proile information for the dropped code object
#t)
(equal?
(filter (lambda (x) (equal? (cadr x) "testfile-cp2.ss")) (profile-dump-list))
'((177 "testfile-cp2.ss" 49 146 4 7)
(177 "testfile-cp2.ss" 64 73 5 10)
(177 "testfile-cp2.ss" 65 68 5 11)
(177 "testfile-cp2.ss" 69 70 5 15)
(177 "testfile-cp2.ss" 71 72 5 17)
(143 "testfile-cp2.ss" 86 95 6 10)
(143 "testfile-cp2.ss" 87 90 6 11)
(143 "testfile-cp2.ss" 91 92 6 15)
(143 "testfile-cp2.ss" 93 94 6 17)
(88 "testfile-cp2.ss" 113 144 7 15)
(88 "testfile-cp2.ss" 114 115 7 16)
(88 "testfile-cp2.ss" 116 129 7 18)
(88 "testfile-cp2.ss" 117 120 7 19)
(88 "testfile-cp2.ss" 121 128 7 23)
(88 "testfile-cp2.ss" 122 123 7 24)
(88 "testfile-cp2.ss" 124 125 7 26)
(88 "testfile-cp2.ss" 126 127 7 28)
(88 "testfile-cp2.ss" 130 143 7 32)
(88 "testfile-cp2.ss" 131 134 7 33)
(88 "testfile-cp2.ss" 135 142 7 37)
(88 "testfile-cp2.ss" 136 137 7 38)
(88 "testfile-cp2.ss" 138 139 7 40)
(88 "testfile-cp2.ss" 140 141 7 42)
(55 "testfile-cp2.ss" 96 97 6 20)
(34 "testfile-cp2.ss" 74 75 5 20)))
(eqv? (profile-clear) (void))
(begin
(with-output-to-file "testfile.ss"
(lambda ()
(pretty-print
'(define f (lambda () 0))))
'replace)
(parameterize ([compile-profile #t]) (load "testfile.ss" compile))
#t)
(begin
(with-output-to-file "testfile.ss"
(lambda ()
(pretty-print
'(define f (lambda () 1))))
'replace)
#t)
(eqv? (f) 0)
(warning? ; unmodified source file not found
(parameterize ([source-directories (cons* "../s" "../unicode" (source-directories))])
(profile-dump-list)))
(warning? ; unmodified source file not found
(parameterize ([source-directories (cons* "../s" "../unicode" (source-directories))])
(profile-dump-list #t)))
(warning? ; unmodified source file not found
(parameterize ([source-directories (cons* "../s" "../unicode" (source-directories))])
(profile-dump-list #t (profile-dump))))
(warning? ; unmodified source file not found
(parameterize ([source-directories (cons* "../s" "../unicode" (source-directories))])
(profile-dump-list #t (profile-dump))))
(guard (c [else #f])
(profile-dump-list #f)
#t)
(guard (c [else #f])
(profile-dump-list #f (profile-dump))
#t)
(eqv? (profile-clear) (void))
; verify that annotations are preserved within syntax objects when
; profiling is enabled even when generation of inspector information
; is disabled.
(begin
(mkfile "testfile-ca3.ss"
'(library (testfile-ca3) (export a) (import (chezscheme))
(define-syntax a (lambda (x) #'(cons 0 1)))))
(mkfile "testfile-cp3.ss"
'(import (chezscheme) (testfile-ca3))
'(do ([i 123 (fx- i 1)] [q #f a]) ((fx= i 0) (pretty-print q)))
'(profile-dump-html))
(separate-compile
'(lambda (x)
(parameterize ([generate-inspector-information #f]
[compile-profile #t])
(compile-library x)))
'ca3)
(separate-compile
'(lambda (x)
(parameterize ([compile-profile #t])
(compile-program x)))
'cp3)
#t)
(equal?
(separate-eval
'(load-program "testfile-cp3.so")
'(cdr (find (lambda (x) (equal? (source-file-descriptor-path (source-object-sfd (car x))) "testfile-ca3.ss")) (profile-dump))))
"(0 . 1)\n123\n")
; verify that we get profiling information for local macro transformers
(begin
(call-with-port (open-output-file "testfile-cp4.ss" 'replace)
(lambda (op)
(put-string op "\
(let ()
(define-syntax a
(lambda (q)
(define square
(lambda (n)
(* n n)))
(syntax-case q ()
[(_ x (d ...) e)
#`(let ([x (quote #,(map square (datum (d ...))))])
e)])))
(pretty-print (list (a b (8 6 7) b) (a b (5 3 0 9) (list b)))))")))
(delete-file "testfile-cp4.so")
(parameterize ([print-gensym #f] [current-eval compile] [compile-profile #t])
(compile-file "testfile-cp4"))
#t)
(equal?
(sort (lambda (x y) (< (list-ref x 2) (list-ref y 2)))
(filter (lambda (x) (equal? (list-ref x 1) "testfile-cp4.ss"))
(profile-dump-list)))
'((1 "testfile-cp4.ss" 31 232 3 5) ; first transformer count ...
(2 "testfile-cp4.ss" 72 102 5 9)
(7 "testfile-cp4.ss" 94 101 6 11)
(7 "testfile-cp4.ss" 95 96 6 12)
(7 "testfile-cp4.ss" 97 98 6 14)
(7 "testfile-cp4.ss" 99 100 6 16)
(2 "testfile-cp4.ss" 110 231 7 7)
(2 "testfile-cp4.ss" 123 124 7 20)
(2 "testfile-cp4.ss" 162 229 9 10)
(2 "testfile-cp4.ss" 182 210 9 30)
(2 "testfile-cp4.ss" 183 186 9 31)
(2 "testfile-cp4.ss" 187 193 9 35)
(2 "testfile-cp4.ss" 194 209 9 42) ; ... last transformer count
))
(begin
(collect (collect-maximum-generation))
(profile-release-counters)
#t)
(equal?
(with-output-to-string
(lambda ()
(revisit "testfile-cp4.so")))
"((64 36 49) ((25 9 0 81)))\n")
(equal?
(sort (lambda (x y) (< (list-ref x 2) (list-ref y 2)))
(filter (lambda (x) (equal? (list-ref x 1) "testfile-cp4.ss"))
(profile-dump-list)))
'((1 "testfile-cp4.ss" 0 299 1 1) ; top-level let
(1 "testfile-cp4.ss" 236 298 11 3) ; pretty-print call ...
(1 "testfile-cp4.ss" 237 249 11 4) ; ... and subforms
(1 "testfile-cp4.ss" 250 297 11 17)
(1 "testfile-cp4.ss" 251 255 11 18)
(1 "testfile-cp4.ss" 256 271 11 23)
(1 "testfile-cp4.ss" 269 270 11 36)
(1 "testfile-cp4.ss" 272 296 11 39)
(1 "testfile-cp4.ss" 287 295 11 54)
(1 "testfile-cp4.ss" 288 292 11 55)
(1 "testfile-cp4.ss" 293 294 11 60)
))
)
(mat profile-form
(error? ; invalid syntax
(profile))
(error? ; invalid syntax
(profile 1 2 3))
(error? ; not a source object
(profile 3))
(begin
(define str "(ugh (if \x3b2;))")
(define bv (string->utf8 str))
(define ip (open-bytevector-input-port bv))
(define sfd (make-source-file-descriptor "foo" ip #t))
#t)
(eq? (eval `(profile ,(make-source-object sfd 2 3))) (void))
(begin
(define compile-triv-file
(lambda (ifn ofn)
(define insert-profile-forms
(lambda (x)
(unless (annotation? x) (errorf 'compile-triv-file "expected an annotation, got ~s" x))
(let ([src (annotation-source x)] [exp (annotation-expression x)])
`(begin (profile ,src)
,(syntax-case exp ()
[(?do-times n e)
(eq? (annotation-expression #'?do-times) 'do-times)
(let ([n (annotation-expression #'n)])
`(do ([i ,n (fx- i 1)]) ((fx= i 0)) ,(insert-profile-forms #'e)))]
[(?print string)
(eq? (annotation-expression #'?print) 'print)
`(printf "~a\n" ,(annotation-expression #'string))]
[else (syntax-error exp)])))))
(define parse
(lambda (ifn)
(let ([ip (open-file-input-port ifn)])
(let ([sfd (make-source-file-descriptor ifn ip #t)])
(let ([ip (transcoded-port ip (native-transcoder))])
(let f ([bfp 0])
(let-values ([(x bfp) (get-datum/annotations ip sfd bfp)])
(if (eof-object? x)
(begin (close-port ip) '())
(cons x (f bfp))))))))))
(parameterize ([compile-profile 'source] [generate-profile-forms #f])
(compile-to-file (list `(define (triv) ,@(map insert-profile-forms (parse ifn)))) ofn))))
#t)
(begin
(with-output-to-file "testfile-triv.ss"
(lambda ()
(pretty-print '(do-times 10 (print "hello")))
(pretty-print '(do-times 5 (print "goodbye"))))
'replace)
(compile-triv-file "testfile-triv.ss" "testfile-triv.so")
(load "testfile-triv.so")
#t)
(equal?
(with-output-to-string triv)
"hello\nhello\nhello\nhello\nhello\nhello\nhello\nhello\nhello\nhello\ngoodbye\ngoodbye\ngoodbye\ngoodbye\ngoodbye\n")
(equal?
(sort
; sort by bfp
(lambda (x y) (< (list-ref x 2) (list-ref y 2)))
(filter (lambda (x) (equal? (list-ref x 1) "testfile-triv.ss")) (profile-dump-list)))
'((1 "testfile-triv.ss" 0 29 1 1)
(10 "testfile-triv.ss" 13 28 1 14)
(1 "testfile-triv.ss" 30 60 2 1)
(5 "testfile-triv.ss" 42 59 2 13)))
(eqv? (profile-clear) (void))
)
(mat coverage
(begin
(mkfile "testfile.ss" '(printf "hello\n"))
(define $ct0 (make-source-table))
(define $ct0-src1
(make-source-object
(call-with-port (open-file-input-port "testfile.ss")
(lambda (ip)
(make-source-file-descriptor "testfile.ss" ip #t)))
3 7))
(define $ct0-src2
(make-source-object
(call-with-port (open-file-input-port "testfile.ss")
(lambda (ip)
(make-source-file-descriptor "testfile.ss" ip #t)))
5 11))
(define $ct0-src3
(make-source-object
(call-with-port (open-file-input-port "testfile.ss")
(lambda (ip)
(make-source-file-descriptor "not-testfile.ss" ip #t)))
17 19))
#t)
(source-table? $ct0)
(= (source-table-size $ct0) 0)
(not (source-table-contains? $ct0 $ct0-src1))
(eq? (source-table-ref $ct0 $ct0-src2 'q) 'q)
(begin
(source-table-set! $ct0 $ct0-src1 17)
#t)
(= (source-table-size $ct0) 1)
(source-table-contains? $ct0 $ct0-src1)
(not (source-table-contains? $ct0 $ct0-src2))
(eq? (source-table-ref $ct0 $ct0-src3 'q) 'q)
(begin
(source-table-set! $ct0 $ct0-src2 37)
(source-table-set! $ct0 $ct0-src3 43)
#t)
(= (source-table-size $ct0) 3)
(source-table-contains? $ct0 $ct0-src1)
(source-table-contains? $ct0 $ct0-src2)
(source-table-contains? $ct0 $ct0-src3)
(eqv? (source-table-ref $ct0 $ct0-src1 'q) 17)
(eqv? (source-table-ref $ct0 $ct0-src2 'q) 37)
(eqv? (source-table-ref $ct0 $ct0-src3 'q) 43)
(let ([a (source-table-cell $ct0 $ct0-src1 #f)])
(and (eqv? (cdr a) 17)
(begin
(set-cdr! a 23)
#t)))
(= (source-table-size $ct0) 3)
(source-table-contains? $ct0 $ct0-src1)
(source-table-contains? $ct0 $ct0-src2)
(source-table-contains? $ct0 $ct0-src3)
(eqv? (source-table-ref $ct0 $ct0-src1 'q) 23)
(eqv? (source-table-ref $ct0 $ct0-src2 'q) 37)
(eqv? (source-table-ref $ct0 $ct0-src3 'q) 43)
(eqv? (source-table-delete! $ct0 $ct0-src1) (void))
(= (source-table-size $ct0) 2)
(not (source-table-contains? $ct0 $ct0-src1))
(source-table-contains? $ct0 $ct0-src2)
(source-table-contains? $ct0 $ct0-src3)
(eqv? (source-table-delete! $ct0 $ct0-src3) (void))
(= (source-table-size $ct0) 1)
(not (source-table-contains? $ct0 $ct0-src1))
(source-table-contains? $ct0 $ct0-src2)
(not (source-table-contains? $ct0 $ct0-src3))
(eqv? (source-table-delete! $ct0 $ct0-src2) (void))
(= (source-table-size $ct0) 0)
(not (source-table-contains? $ct0 $ct0-src1))
(not (source-table-contains? $ct0 $ct0-src2))
(not (source-table-contains? $ct0 $ct0-src3))
(begin
(define $source-table-filter
(lambda (universe-ct ct)
(let ([new-ct (make-source-table)])
(for-each
(lambda (p)
(let ([src (car p)] [count (cdr p)])
(when (source-table-contains? universe-ct src)
(source-table-set! new-ct src count))))
(source-table-dump ct))
new-ct)))
(begin
(mkfile "testfile-coverage1a.ss"
'(library (testfile-coverage1a) (export a f) (import (chezscheme))
(define-syntax a (lambda (x) #'(cons 0 1)))
(define f (lambda (x) (if (= x 0) 1 (* x (f (- x 1))))))))
(parameterize ([generate-covin-files #t] [compile-profile #t])
(compile-library "testfile-coverage1a")))
(begin
(mkfile "testfile-coverage1b.ss"
`(top-level-program
(import (chezscheme) (testfile-coverage1a))
(do ([i 3 (fx- i 1)])
((fx= i 0) (printf "~s\n" (f 3)))
(printf "a = ~s\n" a))))
(call-with-port (open-file-input-port "testfile-coverage1b.ss")
(lambda (ip)
(let ([sfd (make-source-file-descriptor "testfile-coverage1b.ss" ip #t)])
(call-with-port (transcoded-port ip (native-transcoder))
(lambda (ip)
(call-with-port (open-file-output-port "testfile-coverage1b.so" (file-options replace))
(lambda (op)
(call-with-port (open-output-file "testfile-coverage1b.covin" 'replace)
(lambda (covop)
(parameterize ([compile-profile #t])
(compile-port ip op sfd #f covop))))))))))))
(begin
(mkfile "testfile-coverage1c.ss"
'(top-level-program
(import (chezscheme) (testfile-coverage1a))
(do ([i 4 (fx- i 1)])
((fx= i 0) (printf "~s\n" (f 4)))
(printf "a = ~s\n" a))))
(call-with-port (open-file-input-port "testfile-coverage1c.ss")
(lambda (ip)
(let ([sfd (make-source-file-descriptor "testfile-coverage1c.ss" ip #t)])
(call-with-port (transcoded-port ip (native-transcoder))
(lambda (ip)
(call-with-port (open-file-output-port "testfile-coverage1c.so" (file-options replace))
(lambda (op)
(call-with-port (open-output-file "testfile-coverage1c.covin" 'replace)
(lambda (covop)
(parameterize ([compile-profile #t])
(let-values ([(x fp) (get-datum/annotations ip sfd 0)])
(compile-to-port (list x) op sfd #f covop)))))))))))))
(begin
(mkfile "testfile-coverage1d.ss"
'(import (chezscheme) (testfile-coverage1a))
'(do ([i 3 (fx- i 1)])
((fx= i 0) (printf "~s\n" (f 5)))
(printf "a = ~s\n" a)))
(parameterize ([generate-covin-files #t] [compile-profile #t])
(compile-program "testfile-coverage1d")))
(define $ct0
(let ()
(define (with-source-input-port path p)
(call-with-port
(open-file-input-port path
(file-options compressed)
(buffer-mode block)
(current-transcoder))
p))
(let ([ct (make-source-table)])
(with-source-input-port "testfile-coverage1b.covin" (lambda (ip) (get-source-table! ip ct)))
(with-source-input-port "testfile-coverage1c.covin" (lambda (ip) (get-source-table! ip ct (lambda (x y) (assert (= x y 0)) x))))
ct)))
#t)
(source-table? $ct0)
(andmap zero? (map cdr (source-table-dump $ct0)))
(call-with-values
(lambda ()
(with-profile-tracker
(lambda ()
(call/cc
(lambda (k)
(values k
(with-output-to-string
(lambda ()
(load-program "testfile-coverage1b.so")
(load-program "testfile-coverage1c.so")
(load-program "testfile-coverage1d.so")))))))))
(lambda (ct k s)
(let* ([ct ($source-table-filter $ct0 ct)])
(if k
(and (string=? s "a = (0 . 1)\na = (0 . 1)\na = (0 . 1)\n6\na = (0 . 1)\na = (0 . 1)\na = (0 . 1)\na = (0 . 1)\n24\na = (0 . 1)\na = (0 . 1)\na = (0 . 1)\n120\n")
(procedure? k)
(begin
(set! $ct1 ct)
(k #f "yup.")))
(and (string=? s "yup.")
(begin
(set! $ct2 ct)
#t))))))
(source-table? $ct1)
(source-table? $ct2)
(and
(andmap
(lambda (dumpit)
(and (source-table-contains? $ct2 (car dumpit))
(>= (source-table-ref $ct2 (car dumpit) #f) (cdr dumpit))))
(source-table-dump $ct1))
(andmap
(lambda (dumpit)
(and (source-table-contains? $ct1 (car dumpit))
(<= (source-table-ref $ct1 (car dumpit) #f) (cdr dumpit))))
(source-table-dump $ct2)))
(not (ormap zero? (map cdr (source-table-dump $ct1))))
(let ([dump (source-table-dump $ct1)])
(define (file-found? path)
(ormap
(lambda (dumpit)
(string=? (source-file-descriptor-path (source-object-sfd (car dumpit))) path))
dump))
(and (file-found? "testfile-coverage1a.ss")
(file-found? "testfile-coverage1b.ss")
(file-found? "testfile-coverage1c.ss")
(not (file-found? "testfile-coverage1d.ss"))))
(string=?
(with-output-to-string
(lambda ()
; shouldn't matter whether this is before or after the with-profile-tracker call
(load-program "testfile-coverage1b.so")
(let-values ([(ct . ignore) (with-profile-tracker #t
(lambda ()
(load-program "testfile-coverage1c.so")
(load-program "testfile-coverage1d.so")))])
(let ([ct ($source-table-filter $ct0 ct)])
(set! $ct3 ct)))))
"a = (0 . 1)\na = (0 . 1)\na = (0 . 1)\n6\na = (0 . 1)\na = (0 . 1)\na = (0 . 1)\na = (0 . 1)\n24\na = (0 . 1)\na = (0 . 1)\na = (0 . 1)\n120\n")
(source-table? $ct3)
(let ([dump (source-table-dump $ct3)])
(define (file-found? path)
(ormap
(lambda (dumpit)
(string=? (source-file-descriptor-path (source-object-sfd (car dumpit))) path))
dump))
(and (file-found? "testfile-coverage1a.ss")
(file-found? "testfile-coverage1b.ss")
(file-found? "testfile-coverage1c.ss")
(not (file-found? "testfile-coverage1d.ss"))))
; the coverage table retrieved should include counts for both sets of load-program calls
(and
(andmap
(lambda (dumpit)
(>= (source-table-ref $ct3 (car dumpit) #f) (* 2 (cdr dumpit))))
(source-table-dump $ct1))
(andmap
(lambda (dumpit)
(<= (* 2 (source-table-ref $ct1 (car dumpit) #f)) (cdr dumpit)))
(source-table-dump $ct3)))
(begin
(call-with-output-file "testfile.covout"
(lambda (op)
(put-source-table op $ct3))
'replace)
(define $ct5
(let ([ct (make-source-table)])
(call-with-input-file "testfile.covout" (lambda (ip) (get-source-table! ip ct)))
ct))
#t)
(andmap
(lambda (dumpit)
(= (source-table-ref $ct5 (car dumpit) #f) (cdr dumpit)))
(source-table-dump $ct3))
(andmap
(lambda (dumpit)
(= (source-table-ref $ct3 (car dumpit) #f) (cdr dumpit)))
(source-table-dump $ct5))
(begin
(call-with-input-file "testfile.covout" (lambda (ip) (get-source-table! ip $ct5 (lambda (x y) (- (* x y))))))
#t)
(andmap
(lambda (dumpit)
(= (source-table-ref $ct5 (car dumpit) #f) (- (expt (cdr dumpit) 2))))
(source-table-dump $ct3))
)
Reference in New Issue View Git Blame Copy Permalink