Today I implemented a rudimentary statistical profiler for MIT Scheme.
In the process, I found a bug in the stack parser whereby it would
fail to parse stack frames that occur in the infrequent situation of
interrupting an internal compiled procedure that LIAR compiled with a
dynamic link; of course, while it is unlikely for a human to type C-c
C-b at precisely the right time, a statistical profiler sampling every
millisecond is quite likely to do that. I have thrown together two
responses to this bug, one of them a workaround and one of them an
attempt at a fix.
The statistical profiler is at
<http://mumble.net/~campbell/scheme/mit-profile.scm>,
with brief instructions on its use at the top. I have attached two
patches to this message: one that works around the problem, but which
causes the stack parser and thus the profiler to generate less useful
information; and one that attempts to fix the problem kludgily by
parsing two stack frames at once based on a guess about how the
dynamic link stored in a COMPILER-INTERRUPT-RESTART continuation is
interpreted, but which is complicated enough that I am hesitant to
call this a fix with certainty.
If you want to use the profiler, you need to apply either one of these
patches before the profiler will work on pretty much any code that has
internal procedures which LIAR decides to compile with dynamic links,
which, though rare, do turn up from time to time (e.g., in the
runtime's merge-sort implementation).
Comments, on the profiler or on the stack parser hacks?
diff --git a/src/runtime/conpar.scm b/src/runtime/conpar.scm
index e37438f..731f637 100644
--- a/src/runtime/conpar.scm
+++ b/src/runtime/conpar.scm
@@ -200,14 +200,7 @@ USA.
(define (parse-one-frame state)
(let ((handle-ordinary
(lambda (stream)
- (let ((type
- (return-address->stack-frame-type
- (stream-car stream)
- (let ((type (parser-state/previous-type state)))
- (and type
- (1d-table/get (stack-frame-type/properties type)
- allow-extended?-tag
- #f))))))
+ (let ((type (return-address->stack-frame-type (stream-car stream))))
(let ((length
(let ((length (stack-frame-type/length type)))
(if (exact-nonnegative-integer? length)
@@ -314,7 +307,7 @@ USA.
type elements state
(let ((stream (parser-state/element-stream state)))
(and (stream-pair? stream)
- (eq? (return-address->stack-frame-type (stream-car stream) #t)
+ (eq? (return-address->stack-frame-type (stream-car stream))
stack-frame-type/return-to-interpreter)))
#f))
@@ -542,6 +535,24 @@ USA.
(loop (stream-cdr s)))))
offset)))))
+(define (length/interrupt-compiled-procedure stream offset)
+ offset ; ignored
+ (fix:+ (compiled-procedure-frame-size (stream-car stream)) 1))
+
+(define (length/compiler-interrupt-restart stream offset)
+ (or (let ((entry (stream-ref stream 3)))
+ (and (compiled-internal-procedure? entry)
+ (let ((dynamic-link (stream-ref stream 2)))
+ (and (stack-address? dynamic-link)
+ (stack-address->index dynamic-link offset)))))
+ 3))
+
+(define (compiled-internal-procedure? object)
+ (and (object-type? (ucode-type compiled-entry) object)
+ (fix:= 3
+ (system-hunk3-cxr0
+ ((ucode-primitive compiled-entry-kind 1) object)))))
+
(define (length/special-compiled stream offset)
;; return address is reflect-to-interface
offset
@@ -587,10 +598,6 @@ USA.
(fix:- 10 1))
(else
(lose)))))
-
-(define (length/interrupt-compiled-procedure stream offset)
- offset ; ignored
- (fix:+ (compiled-procedure-frame-size (stream-car stream)) 1))
(define (compiled-code-address/frame-size cc-address)
(let ((lose (lambda () (error "Unexpected object:" cc-address))))
@@ -609,7 +616,7 @@ USA.
(define (verify paranoia-index stream offset)
(if (or (= paranoia-index 0) (stream-null? stream))
#t
- (let* ((type (return-address->stack-frame-type (stream-car stream) #f))
+ (let* ((type (return-address->stack-frame-type (stream-car stream)))
(length
(let ((length (stack-frame-type/length type)))
(if (exact-nonnegative-integer? length)
@@ -644,9 +651,6 @@ USA.
(parser #f read-only #t)
(properties (make-1d-table) read-only #t))
-(define allow-extended?-tag
- (list 'ALLOW-EXTENDED?))
-
(define (microcode-return/code->type code)
(if (not (fix:< code (vector-length stack-frame-types)))
(error:bad-range-argument code 'MICROCODE-RETURN/CODE->TYPE))
@@ -655,8 +659,7 @@ USA.
(define (microcode-return/name->type name)
(microcode-return/code->type (microcode-return name)))
-(define (return-address->stack-frame-type return-address allow-extended?)
- allow-extended? ; ignored
+(define (return-address->stack-frame-type return-address)
(cond ((interpreter-return-address? return-address)
(let ((code (return-address/code return-address)))
(let ((type (microcode-return/code->type code)))
@@ -793,10 +796,8 @@ USA.
(compiler-subproblem 'COMPILER-LOOKUP-APPLY-TRAP-RESTART length)
(compiler-subproblem 'COMPILER-OPERATOR-LOOKUP-TRAP-RESTART length))
- (let ((type (compiler-frame 'COMPILER-INTERRUPT-RESTART 3)))
- (1d-table/put! (stack-frame-type/properties type)
- allow-extended?-tag
- #t))
+ (compiler-frame 'COMPILER-INTERRUPT-RESTART
+ length/compiler-interrupt-restart)
(compiler-frame 'COMPILER-LINK-CACHES-RESTART 8)
(compiler-frame 'REENTER-COMPILED-CODE 2)
diff --git a/src/runtime/conpar.scm b/src/runtime/conpar.scm
index e37438f..a6a6bec 100644
--- a/src/runtime/conpar.scm
+++ b/src/runtime/conpar.scm
@@ -200,14 +200,7 @@ USA.
(define (parse-one-frame state)
(let ((handle-ordinary
(lambda (stream)
- (let ((type
- (return-address->stack-frame-type
- (stream-car stream)
- (let ((type (parser-state/previous-type state)))
- (and type
- (1d-table/get (stack-frame-type/properties type)
- allow-extended?-tag
- #f))))))
+ (let ((type (return-address->stack-frame-type (stream-car stream))))
(let ((length
(let ((length (stack-frame-type/length type)))
(if (exact-nonnegative-integer? length)
@@ -314,7 +307,7 @@ USA.
type elements state
(let ((stream (parser-state/element-stream state)))
(and (stream-pair? stream)
- (eq? (return-address->stack-frame-type (stream-car stream) #t)
+ (eq? (return-address->stack-frame-type (stream-car stream))
stack-frame-type/return-to-interpreter)))
#f))
@@ -385,6 +378,54 @@ USA.
(else
(error "Unknown special compiled frame code:" code)))))
+(define (parser/compiler-interrupt-restart type elements state)
+ (if (= 3 (vector-length elements))
+ (parser/standard type elements state)
+ ;; This is a hairy mongrel of PARSE/STANDARD-NEXT and
+ ;; PARSER/STANDARD, because it makes two stack frames at once,
+ ;; which we must do because the first stack frame tells us
+ ;; information not in the parser state that is needed in order
+ ;; to parse the second frame: the interrupt frame contains the
+ ;; dynamic link, which is all that we know about the size of the
+ ;; next frame.
+ (let ((history?
+ (and (stack-frame-type/history-subproblem? type)
+ (stack-frame-type/subproblem? type))))
+ (let ((n-elements (parser-state/n-elements state))
+ (history-subproblem?
+ (stack-frame-type/history-subproblem? type))
+ (history (parser-state/history state))
+ (previous-history-offset
+ (parser-state/previous-history-offset state))
+ (previous-history-control-point
+ (parser-state/previous-history-control-point state)))
+ (make-stack-frame
+ type
+ (vector-head elements 3)
+ (parser-state/dynamic-state state)
+ (parser-state/block-thread-events? state)
+ (parser-state/interrupt-mask state)
+ (if history? history undefined-history)
+ previous-history-offset
+ previous-history-control-point
+ (fix:+ 3 n-elements)
+ (parser-state/previous-type state)
+ (parser/standard
+ stack-frame-type/interrupt-compiled-procedure
+ (vector-tail elements 3)
+ (make-parser-state (parser-state/dynamic-state state)
+ (parser-state/block-thread-events? state)
+ (parser-state/interrupt-mask state)
+ (if history-subproblem?
+ (history-superproblem history)
+ history)
+ previous-history-offset
+ previous-history-control-point
+ (parser-state/element-stream state)
+ n-elements
+ (parser-state/next-control-point state)
+ type)))))))
+
(define (parser/stack-marker type elements state)
(call-with-values
(lambda ()
@@ -542,6 +583,24 @@ USA.
(loop (stream-cdr s)))))
offset)))))
+(define (length/interrupt-compiled-procedure stream offset)
+ offset ; ignored
+ (fix:+ (compiled-procedure-frame-size (stream-car stream)) 1))
+
+(define (length/compiler-interrupt-restart stream offset)
+ (or (let ((entry (stream-ref stream 3)))
+ (and (compiled-internal-procedure? entry)
+ (let ((dynamic-link (stream-ref stream 2)))
+ (and (stack-address? dynamic-link)
+ (stack-address->index dynamic-link offset)))))
+ 3))
+
+(define (compiled-internal-procedure? object)
+ (and (object-type? (ucode-type compiled-entry) object)
+ (fix:= 3
+ (system-hunk3-cxr0
+ ((ucode-primitive compiled-entry-kind 1) object)))))
+
(define (length/special-compiled stream offset)
;; return address is reflect-to-interface
offset
@@ -587,10 +646,6 @@ USA.
(fix:- 10 1))
(else
(lose)))))
-
-(define (length/interrupt-compiled-procedure stream offset)
- offset ; ignored
- (fix:+ (compiled-procedure-frame-size (stream-car stream)) 1))
(define (compiled-code-address/frame-size cc-address)
(let ((lose (lambda () (error "Unexpected object:" cc-address))))
@@ -609,7 +664,7 @@ USA.
(define (verify paranoia-index stream offset)
(if (or (= paranoia-index 0) (stream-null? stream))
#t
- (let* ((type (return-address->stack-frame-type (stream-car stream) #f))
+ (let* ((type (return-address->stack-frame-type (stream-car stream)))
(length
(let ((length (stack-frame-type/length type)))
(if (exact-nonnegative-integer? length)
@@ -644,9 +699,6 @@ USA.
(parser #f read-only #t)
(properties (make-1d-table) read-only #t))
-(define allow-extended?-tag
- (list 'ALLOW-EXTENDED?))
-
(define (microcode-return/code->type code)
(if (not (fix:< code (vector-length stack-frame-types)))
(error:bad-range-argument code 'MICROCODE-RETURN/CODE->TYPE))
@@ -655,8 +707,7 @@ USA.
(define (microcode-return/name->type name)
(microcode-return/code->type (microcode-return name)))
-(define (return-address->stack-frame-type return-address allow-extended?)
- allow-extended? ; ignored
+(define (return-address->stack-frame-type return-address)
(cond ((interpreter-return-address? return-address)
(let ((code (return-address/code return-address)))
(let ((type (microcode-return/code->type code)))
@@ -793,10 +844,9 @@ USA.
(compiler-subproblem 'COMPILER-LOOKUP-APPLY-TRAP-RESTART length)
(compiler-subproblem 'COMPILER-OPERATOR-LOOKUP-TRAP-RESTART length))
- (let ((type (compiler-frame 'COMPILER-INTERRUPT-RESTART 3)))
- (1d-table/put! (stack-frame-type/properties type)
- allow-extended?-tag
- #t))
+ (stack-frame-type 'COMPILER-INTERRUPT-RESTART #f #t
+ length/compiler-interrupt-restart
+ parser/compiler-interrupt-restart)
(compiler-frame 'COMPILER-LINK-CACHES-RESTART 8)
(compiler-frame 'REENTER-COMPILED-CODE 2)
_______________________________________________
MIT-Scheme-devel mailing list
[email protected]
http://lists.gnu.org/mailman/listinfo/mit-scheme-devel
