From bbde12991cb713bc2dc229f7ac87b041ad35f690 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 14 Aug 2018 06:59:51 -0700 Subject: [PATCH] cs: faster continuation trace Reduce the cost of getting a source backtrace for a continuation mark set (especially as recorded in an exception). --- .../tests/racket/benchmarks/shootout/auto.rkt | 12 +-- racket/src/cs/Makefile | 1 + racket/src/cs/rumble.sls | 1 + racket/src/cs/rumble/error.ss | 82 +++++++++---------- racket/src/cs/rumble/source.ss | 30 +++++++ 5 files changed, 80 insertions(+), 46 deletions(-) create mode 100644 racket/src/cs/rumble/source.ss diff --git a/pkgs/racket-benchmarks/tests/racket/benchmarks/shootout/auto.rkt b/pkgs/racket-benchmarks/tests/racket/benchmarks/shootout/auto.rkt index 5f6c395ede..50c5f0767f 100755 --- a/pkgs/racket-benchmarks/tests/racket/benchmarks/shootout/auto.rkt +++ b/pkgs/racket-benchmarks/tests/racket/benchmarks/shootout/auto.rkt @@ -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") diff --git a/racket/src/cs/Makefile b/racket/src/cs/Makefile index 3a42f141ff..d76f5a5b3c 100644 --- a/racket/src/cs/Makefile +++ b/racket/src/cs/Makefile @@ -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 \ diff --git a/racket/src/cs/rumble.sls b/racket/src/cs/rumble.sls index 1de0534f7f..a404ebd003 100644 --- a/racket/src/cs/rumble.sls +++ b/racket/src/cs/rumble.sls @@ -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") diff --git a/racket/src/cs/rumble/error.ss b/racket/src/cs/rumble/error.ss index ce9e697d8b..c6d6081fb6 100644 --- a/racket/src/cs/rumble/error.ss +++ b/racket/src/cs/rumble/error.ss @@ -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]) diff --git a/racket/src/cs/rumble/source.ss b/racket/src/cs/rumble/source.ss new file mode 100644 index 0000000000..d96f291b4b --- /dev/null +++ b/racket/src/cs/rumble/source.ss @@ -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)]))]))))