suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

cs: faster continuation trace

Browse Source 
Reduce the cost of getting a source backtrace for a continuation mark
set (especially as recorded in an exception).
This commit is contained in:
Matthew Flatt 2018-08-14 06:59:51 -07:00
parent eb73837baf
commit bbde12991c
5 changed files with 80 additions and 46 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
pkgs/racket-benchmarks/tests/racket/benchmarks/shootout/auto.rkt
View File

@ -34,17 +34,19 @@ exec racket -qu "$0" ${1+"$@"}
(load script)))
(define (mk-racket bm)
(unless (directory-exists? "compiled")
(make-directory "compiled"))
(define compiled (car (use-compiled-file-paths)))
(unless (directory-exists? compiled)
(make-directory* compiled))
(parameterize ([current-namespace (make-base-namespace)]
[read-accept-reader #t])
(let ([name (format "~a.rkt" bm)])
(compile-file name
"compiled/current-bm_rkt.zo"))))
(build-path compiled "current-bm_rkt.zo")))))
(define (clean-up-zo bm)
(when (file-exists? "compiled/current-bm_rkt.zo")
(delete-file "compiled/current-bm_rkt.zo")))
(define compiled (car (use-compiled-file-paths)))
(when (file-exists? (build-path compiled "current-bm_rkt.zo"))
(delete-file (build-path compiled "current-bm_rkt.zo"))))
(define (mk-typed-racket-non-optimizing bm)
(unless (directory-exists? "typed/compiled")

1
racket/src/cs/Makefile
View File

@ -247,6 +247,7 @@ RUMBLE_SRCS = rumble/define.ss \
rumble/control.ss \
rumble/interrupt.ss \
rumble/engine.ss \
rumble/source.ss \
rumble/error.ss \
rumble/srcloc.ss \
rumble/boolean.ss \

1
racket/src/cs/rumble.sls
View File

@ -700,6 +700,7 @@
(include "rumble/interrupt.ss")
(include "rumble/parameter.ss")
(include "rumble/engine.ss")
(include "rumble/source.ss")
(include "rumble/error.ss")
(include "rumble/srcloc.ss")
(include "rumble/boolean.ss")

82
racket/src/cs/rumble/error.ss
View File

@ -452,47 +452,47 @@
;; traversal, so that it's amortized constant time.
(define cached-traces (make-ephemeron-eq-hashtable))
(define (continuation->trace k)
(let ([i (inspect/object k)])
(call-with-values
(lambda ()
(let loop ([i i] [slow-i i] [move? #f])
(cond
[(not (eq? (i 'type) 'continuation))
(values (slow-i 'value) '())]
[else
(let ([k (i 'value)])
(cond
[(hashtable-ref cached-traces k #f)
=> (lambda (l)
(values slow-i l))]
[else
(let* ([name (or (let ([n (hashtable-ref link-instantiate-continuations
k
#f)])
(and n
(string->symbol (format "body of ~a" n))))
(let* ([c (i 'code)]
[n (c 'name)])
n))]
[desc
(let* ([src (or
;; when per-expression inspector info is available:
(i 'source-object)
;; when only per-function source location is available:
((i 'code) 'source-object))])
(and (or name src)
(cons name src)))])
(call-with-values
(lambda () (loop (i 'link) (if move? (slow-i 'link) slow-i) (not move?)))
(lambda (slow-k l)
(let ([l (if desc
(cons desc l)
l)])
(when (eq? k slow-k)
(hashtable-set! cached-traces (i 'value) l))
(values slow-k l)))))]))])))
(lambda (slow-k l)
l))))
(call-with-values
(lambda ()
(let loop ([k k] [slow-k k] [move? #f])
(cond
[(or (not (#%$continuation? k))
(eq? k #%$null-continuation))
(values slow-k '())]
[(hashtable-ref cached-traces k #f)
=> (lambda (l)
(values slow-k l))]
[else
(let* ([name (or (let ([n (hashtable-ref link-instantiate-continuations
k
#f)])
(and n
(string->symbol (format "body of ~a" n))))
(let* ([c (#%$continuation-return-code k)]
[n (#%$code-name c)])
n))]
[desc
(let* ([ci (#%$code-info (#%$continuation-return-code k))]
[src (and
(code-info? ci)
(or
;; when per-expression inspector info is available:
(find-rpi (#%$continuation-return-offset k) (code-info-rpis ci))
;; when only per-function source location is available:
(code-info-src ci)))])
(and (or name src)
(cons name src)))])
(call-with-values
(lambda () (loop (#%$continuation-link k) (if move? (#%$continuation-link slow-k) slow-k) (not move?)))
(lambda (slow-k l)
(let ([l (if desc
(cons desc l)
l)])
(when (eq? k slow-k)
(hashtable-set! cached-traces k l))
(values slow-k l)))))])))
(lambda (slow-k l)
l)))
(define (traces->context ls)
(let loop ([l '()] [ls ls])

30
racket/src/cs/rumble/source.ss Normal file
View File

@ -0,0 +1,30 @@
;; Duplicating internal definitions from Chez Scheme, which is not a
;; good idea. A better alternative is to extend Chez Scheme to provide
;; something like `continuation->trace`).
(define-record-type code-info
(fields (immutable src) (immutable sexpr) (immutable free) (immutable live) (immutable rpis))
(nongenerative #{code-info gr886ae7iuw4wt9ft4vxym-2})
(sealed #t))
(define-record-type rp-info
(fields (immutable offset) (immutable src) (immutable sexpr) (immutable mask))
(nongenerative #{rp-info gr886ae7iuw4wt9ft4vxym-1})
(sealed #t))
(define (find-rpi offset rpis)
(and
rpis
(let loop ([start 0] [end (fx1- (vector-length rpis))])
(cond
[(fx< end start)
#f]
[else
(let* ([curr (fx+ (fx/ (fx- end start) 2) start)]
[rpi (vector-ref rpis curr)]
[rpi-offset (rp-info-offset rpi)])
(cond
[(fx= offset rpi-offset) rpi]
[(fx< offset rpi-offset) (loop start (fx1- curr))]
[else (loop (fx1+ curr) end)]))]))))