#| -*-Scheme-*-
-$Id: conpar.scm,v 14.45 2005/02/08 03:28:02 cph Exp $
+$Id: conpar.scm,v 14.46 2005/02/08 04:19:40 cph Exp $
Copyright 1988,1989,1990,1991,1992,1993 Massachusetts Institute of Technology
Copyright 1994,1999,2001,2003,2004,2005 Massachusetts Institute of Technology
(history-reductions history))))
(define undefined-history
- (list 'undefined-history))
+ (list 'UNDEFINED-HISTORY))
(define (stack-frame/next stack-frame)
(let ((next (stack-frame/%next stack-frame)))
(define (stack-frame/ref stack-frame index)
(let ((elements (stack-frame/elements stack-frame)))
(let ((length (vector-length elements)))
- (if (< index length)
+ (if (fix:< index length)
(vector-ref elements index)
- (stack-frame/ref (stack-frame/next stack-frame) (- index length))))))
+ (stack-frame/ref (stack-frame/next stack-frame)
+ (fix:- index length))))))
(define-integrable (stack-frame/return-address stack-frame)
(stack-frame/ref stack-frame 0))
((frame frame)
(offset (stack-address->index address (stack-frame/offset frame))))
(let ((length (stack-frame/length frame)))
- (if (< offset length)
+ (if (fix:< offset length)
(values frame offset)
- (loop (stack-frame/next frame) (- offset length))))))
+ (loop (stack-frame/next frame) (fix:- offset length))))))
(define (stack-frame/skip-non-subproblems stack-frame)
(let ((type (stack-frame/type stack-frame)))
type))))
(define (parse-one-frame state)
- (define (handle-ordinary 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 ((length
- (let ((length (stack-frame-type/length type)))
- (if (exact-nonnegative-integer? length)
- length
- (length stream (parser-state/n-elements state))))))
- ((stack-frame-type/parser type)
- type
- (list->vector (stream-head stream length))
- (make-intermediate-state state length (stream-tail stream length))))))
-
- (let ((the-stream (parser-state/element-stream 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 ((length
+ (let ((length (stack-frame-type/length type)))
+ (if (exact-nonnegative-integer? length)
+ length
+ (length stream (parser-state/n-elements state))))))
+ ((stack-frame-type/parser type)
+ type
+ (list->vector (stream-head stream length))
+ (make-intermediate-state state
+ length
+ (stream-tail stream length)))))))
+ (the-stream (parser-state/element-stream state)))
(if (stream-pair? the-stream)
(handle-ordinary the-stream)
(let ((control-point (parser-state/next-control-point state)))
(and control-point
- (if (> (parser-state/n-elements state) 0)
+ (if (fix:> (parser-state/n-elements state) 0)
;; Construct invisible join-stacklets frame.
(handle-ordinary
(stream return-address/join-stacklets control-point))
(parser-state/block-thread-events? state)
(parser-state/previous-type state))))))))
\f
-;;; `make-intermediate-state' is used to construct an intermediate
+;;; MAKE-INTERMEDIATE-STATE is used to construct an intermediate
;;; parser state that is passed to the frame parser. This
-;;; intermediate state is identical to `state' except that it shows
-;;; `length' items having been removed from the stream.
+;;; intermediate state is identical to STATE except that it shows
+;;; LENGTH items having been removed from the stream.
(define (make-intermediate-state state length stream)
(let ((previous-history-control-point
(parser-state/previous-history-control-point state))
(new-length
- (- (parser-state/n-elements state) length)))
+ (fix:- (parser-state/n-elements state) length)))
(make-parser-state
(parser-state/dynamic-state state)
(parser-state/block-thread-events? state)
(parser-state/history state)
(let ((previous (parser-state/previous-history-offset state)))
(if (or previous-history-control-point
- (>= new-length previous))
+ (fix:>= new-length previous))
previous
0))
previous-history-control-point
(parser-state/previous-type state))))
;;; After each frame parser is done, it either tail recurses into the
-;;; parsing loop, or it calls `parser/standard' to produces a new
-;;; output frame. The argument `state' is usually what was passed to
+;;; parsing loop, or it calls PARSE/STANDARD-NEXT to produces a new
+;;; output frame. The argument STATE is usually what was passed to
;;; the frame parser (i.e. the state that was returned by the previous
-;;; call to `make-intermediate-state'). However, several of the
-;;; parsers change the values of some of the components of `state'
-;;; before calling `parser/standard' -- for example,
-;;; RESTORE-INTERRUPT-MASK changes the `interrupt-mask' component.
+;;; call to MAKE-INTERMEDIATE-STATE). However, several of the parsers
+;;; change the values of some of the components of STATE before
+;;; calling PARSE/STANDARD-NEXT -- for example, RESTORE-INTERRUPT-MASK
+;;; changes the INTERRUPT-MASK component.
(define (parse/standard-next type elements state history? force-pop?)
(let ((n-elements (parser-state/n-elements state))
undefined-history)
previous-history-offset
previous-history-control-point
- (+ (vector-length elements) n-elements)
+ (fix:+ (vector-length elements) n-elements)
(parser-state/previous-type state)
(make-parser-state (parser-state/dynamic-state state)
(parser-state/block-thread-events? state)
(fix:= code code/continue-linking))
(parse/standard-next type elements state #f #f))
(else
- (error "Unknown special compiled frame" code)))))
+ (error "Unknown special compiled frame code:" code)))))
\f
(define (parser/stack-marker type elements state)
(call-with-values
(let ((elements (stack-frame/elements stack-frame)))
(let ((length (vector-length elements)))
(let loop ((index 0))
- (if (< index length)
+ (if (fix:< index length)
(cons-stream (vector-ref elements index)
- (loop (+ index 1)))
+ (loop (fix:+ index 1)))
element-stream))))
next-control-point)))))
(define (length/combination-save-value stream offset)
offset
- (+ 3 (system-vector-length (stream-ref stream 1))))
+ (fix:+ 3 (system-vector-length (stream-ref stream 1))))
(define ((length/application-frame index missing) stream offset)
offset
- (+ index 1 (- (object-datum (stream-ref stream index)) missing)))
+ (fix:+ (fix:+ index 1)
+ (fix:- (object-datum (stream-ref stream index)) missing)))
(define (length/compiled-return-address stream offset)
(let ((entry (stream-car stream)))
(let ((frame-size (compiled-continuation/next-continuation-offset entry)))
(if frame-size
- (+ frame-size 1)
+ (fix:+ frame-size 1)
(stack-address->index
;; Search for the dynamic link. This heuristic compensates
;; for the compiler omitting its location in the object
(define (length/special-compiled stream offset)
;; return address is reflect-to-interface
offset
- (let ((code (stream-ref stream 1)))
- (define (default)
- (error "length/special-compiled: Unknown code" code))
-
+ (let* ((code (stream-ref stream 1))
+ (lose
+ (lambda () (error "Unknown special compiled frame code:" code))))
(cond ((not (fix:fixnum? code))
- (default))
+ (lose))
((fix:= code code/special-compiled/internal-apply)
;; Very infrequent!
(fix:+ 3 (object-datum (stream-ref stream 2))))
(fix:+ 3 (object-datum (stream-ref stream 2))))
((fix:= code code/apply-compiled)
;; Stream[2] is code entry point, [3] is frame size
- (+ 3 (object-datum (stream-ref stream 3))))
+ (fix:+ 3 (object-datum (stream-ref stream 3))))
((fix:= code code/continue-linking)
;; return code, reflect code, entry size, original count,
;; block, environment, offset, last header offset,sections,
;; return address
(fix:- 10 1))
(else
- (default)))))
+ (lose)))))
(define (length/interrupt-compiled-procedure stream offset)
offset ; ignored
- (+ (compiled-procedure-frame-size (stream-car stream)) 1))
+ (fix:+ (compiled-procedure-frame-size (stream-car stream)) 1))
\f
(define (compiled-code-address/frame-size cc-address)
- (cond ((not (compiled-code-address? cc-address))
- (error "compiled-code-address/frame-size: Unexpected object"
- cc-address))
- ((compiled-return-address? cc-address)
- (let ((offset
- (compiled-continuation/next-continuation-offset cc-address)))
- (and offset
- (fix:+ offset 1))))
- ((compiled-procedure? cc-address)
- (fix:+ (compiled-procedure-frame-size cc-address) 1))
- (else
- (error "compiled-code-address/frame-size: Unexpected object"
- cc-address))))
+ (let ((lose (lambda () (error "Unexpected object:" cc-address))))
+ (cond ((not (compiled-code-address? cc-address))
+ (lose))
+ ((compiled-return-address? cc-address)
+ (let ((offset
+ (compiled-continuation/next-continuation-offset cc-address)))
+ (and offset
+ (fix:+ offset 1))))
+ ((compiled-procedure? cc-address)
+ (fix:+ (compiled-procedure-frame-size cc-address) 1))
+ (else
+ (lose)))))
(define (verify paranoia-index stream offset)
- (or (= paranoia-index 0)
- (stream-null? stream)
+ (if (or (= paranoia-index 0) (stream-null? stream))
+ #t
(let* ((type (return-address->stack-frame-type (stream-car stream) #f))
(length
(let ((length (stack-frame-type/length type)))
(return-address? (stream-car ltail))
(verify (- paranoia-index 1)
ltail
- (+ offset length))))))
+ (fix:+ offset length))))))
(define (stream-tail* stream n)
- (cond ((or (= n 0) (stream-null? stream))
- stream)
- ((stream-pair? stream)
- (stream-tail* (stream-cdr stream) (- n 1)))
- (else
- (error "stream-tail*: not a proper stream" stream))))
+ (if (or (fix:= n 0) (stream-null? stream))
+ stream
+ (begin
+ (if (not (stream-pair? stream))
+ (error:wrong-type-argument stream "stream" 'STREAM-TAIL*))
+ (stream-tail* (stream-cdr stream) (fix:- n 1)))))
\f
;;;; Stack Frame Types
(define-structure (stack-frame-type
(constructor make-stack-frame-type
- (code subproblem? history-subproblem?
- length parser))
+ (code subproblem? history-subproblem? length
+ parser))
(conc-name stack-frame-type/))
(code #f read-only #t)
(subproblem? #f read-only #t)
(history-subproblem? #f read-only #t)
- (properties (make-1d-table) read-only #t)
(length #f read-only #t)
- (parser #f read-only #t))
+ (parser #f read-only #t)
+ (properties (make-1d-table) read-only #t))
-(define allow-extended?-tag "stack-frame-type/allow-extended?")
+(define allow-extended?-tag
+ (list 'ALLOW-EXTENDED?))
(define (microcode-return/code->type code)
- (if (not (< code (vector-length stack-frame-types)))
- (error "return-code too large" code))
+ (if (not (fix:< code (vector-length stack-frame-types)))
+ (error:bad-range-argument code 'MICROCODE-RETURN/CODE->TYPE))
(vector-ref stack-frame-types code))
(define (microcode-return/name->type name)
(define (return-address->stack-frame-type return-address allow-extended?)
allow-extended? ; ignored
- (let ((allow-extended? #t))
- (cond ((interpreter-return-address? return-address)
- (let ((code (return-address/code return-address)))
- (let ((type (microcode-return/code->type code)))
- (if (not type)
- (error "return-code has no type" code))
- type)))
- ((compiled-return-address? return-address)
- (cond ((compiled-continuation/return-to-interpreter? return-address)
- stack-frame-type/return-to-interpreter)
- ((compiled-continuation/reflect-to-interface? return-address)
- stack-frame-type/special-compiled)
- (else stack-frame-type/compiled-return-address)))
- ((and allow-extended? (compiled-procedure? return-address))
- stack-frame-type/interrupt-compiled-procedure)
- ((and allow-extended? (compiled-expression? return-address))
- stack-frame-type/interrupt-compiled-expression)
- (else (error "illegal return address" return-address)))))
+ (cond ((interpreter-return-address? return-address)
+ (let ((code (return-address/code return-address)))
+ (let ((type (microcode-return/code->type code)))
+ (if (not type)
+ (error "Return code has no type:" code))
+ type)))
+ ((compiled-return-address? return-address)
+ (cond ((compiled-continuation/return-to-interpreter? return-address)
+ stack-frame-type/return-to-interpreter)
+ ((compiled-continuation/reflect-to-interface? return-address)
+ stack-frame-type/special-compiled)
+ (else stack-frame-type/compiled-return-address)))
+ ((compiled-procedure? return-address)
+ stack-frame-type/interrupt-compiled-procedure)
+ ((compiled-expression? return-address)
+ stack-frame-type/interrupt-compiled-expression)
+ (else
+ (error:bad-range-argument return-address
+ 'RETURN-ADDRESS->STACK-FRAME-TYPE))))
(define (initialize-package!)
(set! return-address/join-stacklets
(set! stack-frame-type/stack-marker
(microcode-return/name->type 'STACK-MARKER))
(set! stack-frame-type/compiled-return-address
- (make-stack-frame-type #f #t #f
- length/compiled-return-address
+ (make-stack-frame-type #f #t #f length/compiled-return-address
parser/standard-compiled))
(set! stack-frame-type/return-to-interpreter
(make-stack-frame-type #f #f #t 1 parser/standard))
(set! stack-frame-type/special-compiled
- (make-stack-frame-type #f #t #f
- length/special-compiled
+ (make-stack-frame-type #f #t #f length/special-compiled
parser/special-compiled))
(set! stack-frame-type/interrupt-compiled-procedure
- (make-stack-frame-type #f #t #f
- length/interrupt-compiled-procedure
+ (make-stack-frame-type #f #t #f length/interrupt-compiled-procedure
parser/standard))
(set! stack-frame-type/interrupt-compiled-expression
(make-stack-frame-type #f #t #f 1 parser/standard))
(set! word-size
- (let ((initial (system-vector-length (make-bit-string 1 #f))))
+ (let ((b1 (system-vector-length (make-bit-string 1 #f))))
(let loop ((size 2))
- (if (= (system-vector-length (make-bit-string size #f)) initial)
- (loop (+ size 1))
- (- size 1)))))
+ (if (fix:= (system-vector-length (make-bit-string size #f)) b1)
+ (loop (fix:+ size 1))
+ (fix:- size 1)))))
(set! continuation-return-address #f)
unspecific)
\f
(define (make-stack-frame-types)
(let ((types (make-vector (microcode-return/code-limit) #f)))
- (define (stack-frame-type name subproblem?
- history-subproblem?
- length parser)
+ (define (stack-frame-type name subproblem? history-subproblem? length
+ parser)
(let ((code (microcode-return name)))
- (let ((type (make-stack-frame-type code subproblem?
- history-subproblem?
- length parser)))
+ (let ((type
+ (make-stack-frame-type code subproblem? history-subproblem?
+ length parser)))
(vector-set! types code type)
type)))
(define (standard-frame name length #!optional parser)
- (stack-frame-type name
- #f
- #f
- length
- (if (default-object? parser)
- parser/standard
- parser)))
+ (stack-frame-type name #f #f length
+ (if (default-object? parser) parser/standard parser)))
(define (standard-subproblem name length)
- (stack-frame-type name
- #t
- #t
- length
- parser/standard))
+ (stack-frame-type name #t #t length parser/standard))
(define (non-history-subproblem name length #!optional parser)
- (stack-frame-type name
- #t
- #f
- length
- (if (default-object? parser)
- parser/standard
- parser)))
+ (stack-frame-type name #t #f length
+ (if (default-object? parser) parser/standard parser)))
(standard-frame 'RESTORE-INTERRUPT-MASK 2 parser/restore-interrupt-mask)
(standard-frame 'RESTORE-HISTORY 4 parser/restore-history)
(- (heuristic after-header (+ hardware-trap/frame-size offset))
offset))
(else
- (error "length/hardware-trap: Unknown state" state)))))))
+ (error "Unknown state:" state)))))))
(define (heuristic stream offset)
(if (or (stream-null? stream)
(eq? (stack-frame/type frame)
stack-frame-type/hardware-trap)))
+(define-guarantee hardware-trap-frame "hardware-trap frame")
+
(define (hardware-trap-frame/code frame)
(guarantee-hardware-trap-frame frame)
(let ((code (stack-frame/ref frame hardware-trap/code-index)))
(cond ((pair? code) (cdr code))
((string? code) code)
(else #f))))
-
-(define (guarantee-hardware-trap-frame frame)
- (if (not (hardware-trap-frame? frame))
- (error "guarantee-hardware-trap-frame: invalid" frame)))
\f
(define (hardware-trap-frame/print-registers frame)
(guarantee-hardware-trap-frame frame)
(write-string " in unknown compiled-code utility ")
(write-hex index)))))
(else
- (error "hardware-trap/describe: Unknown state" state))))))
\ No newline at end of file
+ (error "Unknown state:" state))))))
\ No newline at end of file
#| -*-Scheme-*-
-$Id: cpoint.scm,v 14.8 2005/02/08 03:28:13 cph Exp $
+$Id: cpoint.scm,v 14.9 2005/02/08 04:17:06 cph Exp $
Copyright 1988,1991,2005 Massachusetts Institute of Technology
(system-vector-ref control-point (control-point-index control-point index)))
(define-integrable (control-point-index control-point index)
- (+ (control-point/unused-length control-point) (+ 2 index)))
+ (+ (control-point/unused-length control-point) (fix:+ 2 index)))
(define-integrable (control-point/first-element-index control-point)
(control-point-index control-point 6))
#|
-;; Disabled because some procedures in conpar.scm and uenvir.scm
-;; depend on the actual length for finding compiled code variables,
-;; etc.
+;;; Disabled because some procedures in conpar.scm and uenvir.scm
+;;; depend on the actual length for finding compiled code variables,
+;;; etc.
(define (control-point/n-elements control-point)
- (let ((real-length (- (system-vector-length control-point)
- (control-point/first-element-index control-point))))
+ (let ((real-length
+ (fix:- (system-vector-length control-point)
+ (control-point/first-element-index control-point))))
(if (control-point/next-control-point? control-point)
- (- real-length 2)
+ (fix:- real-length 2)
real-length)))
|#
(define (control-point/n-elements control-point)
- (- (system-vector-length control-point)
- (control-point/first-element-index control-point)))
+ (fix:- (system-vector-length control-point)
+ (control-point/first-element-index control-point)))
(define (control-point/element-stream control-point)
- (let ((end (let ((end (system-vector-length control-point)))
- (if (control-point/next-control-point? control-point)
- (- end 2)
- end))))
+ (let ((end
+ (let ((end (system-vector-length control-point)))
+ (if (control-point/next-control-point? control-point)
+ (fix:- end 2)
+ end))))
(let loop ((index (control-point/first-element-index control-point)))
- (cond ((= index end) '())
- (((ucode-primitive primitive-object-type? 2)
- (ucode-type manifest-nm-vector)
- (system-vector-ref control-point index))
- (let ((n-skips
- (object-datum (system-vector-ref control-point index))))
- (cons-stream
- (make-non-pointer-object n-skips)
- (let skip-loop ((n n-skips) (index (1+ index)))
- (if (zero? n)
- (loop index)
- (cons-stream false (skip-loop (-1+ n) (1+ index))))))))
- (else
- (cons-stream (map-reference-trap
- (lambda ()
- (system-vector-ref control-point index)))
- (loop (1+ index))))))))
+ (if (fix:< index end)
+ (if ((ucode-primitive primitive-object-type? 2)
+ (ucode-type manifest-nm-vector)
+ (system-vector-ref control-point index))
+ (let ((n-skips
+ (object-datum (system-vector-ref control-point index))))
+ (cons-stream
+ (make-non-pointer-object n-skips)
+ (let skip-loop ((n n-skips) (index (fix:+ index 1)))
+ (if (fix:> n 0)
+ (cons-stream #f (skip-loop (fix:- n 1) (fix:+ index 1)))
+ (loop index)))))
+ (cons-stream (map-reference-trap
+ (lambda ()
+ (system-vector-ref control-point index)))
+ (loop (fix:+ index 1))))
+ '()))))
(define (control-point/next-control-point control-point)
(and (control-point/next-control-point? control-point)
(system-vector-ref control-point
- (-1+ (system-vector-length control-point)))))
+ (fix:- (system-vector-length control-point) 1))))
\f
(define (make-control-point reusable?
unused-length
next-control-point)
(let ((unused-length
(if (eq? microcode-id/stack-type 'STACKLETS)
- (max unused-length 7)
+ (fix:max unused-length 7)
unused-length)))
- (let ((result (make-vector (+ 8
- unused-length
- (stream-length element-stream)
- (if next-control-point 2 0)))))
- (vector-set! result 0 reusable?)
- (vector-set! result 1 (make-non-pointer-object unused-length))
- (vector-set! result (+ 2 unused-length)
- (ucode-return-address restore-interrupt-mask))
- (vector-set! result (+ 3 unused-length) interrupt-mask)
- (vector-set! result (+ 4 unused-length)
- (ucode-return-address restore-history))
- (vector-set! result (+ 5 unused-length) history)
- (vector-set! result (+ 6 unused-length) previous-history-offset)
- (vector-set! result (+ 7 unused-length) previous-history-control-point)
- (let loop ((stream element-stream) (index (+ 8 unused-length)))
- (cond ((stream-pair? stream)
- (vector-set! result index
- (unmap-reference-trap (stream-car stream)))
- (loop (stream-cdr stream) (1+ index)))
- (next-control-point
- (vector-set! result index (ucode-return-address join-stacklets))
- (vector-set! result (1+ index) next-control-point))))
+ (let ((result
+ (make-vector (+ 8
+ unused-length
+ (stream-length element-stream)
+ (if next-control-point 2 0))))
+ (index 0))
+ (let ((assign
+ (lambda (value)
+ (vector-set! result index value)
+ (set! index (fix:+ index 1))
+ unspecific)))
+ (assign reusable?)
+ (assign (make-non-pointer-object unused-length))
+ (set! index (fix:+ index unused-length))
+ (assign (ucode-return-address restore-interrupt-mask))
+ (assign interrupt-mask)
+ (assign (ucode-return-address restore-history))
+ (assign history)
+ (assign previous-history-offset)
+ (assign previous-history-control-point)
+ (stream-for-each (lambda (element)
+ (assign (unmap-reference-trap element)))
+ element-stream)
+ (if next-control-point
+ (begin
+ (assign (ucode-return-address join-stacklets))
+ (assign next-control-point))))
(object-new-type (ucode-type control-point) result))))
(define (control-point/next-control-point? control-point)
((ucode-primitive primitive-object-eq? 2)
- (system-vector-ref control-point (- (system-vector-length control-point) 2))
+ (system-vector-ref control-point
+ (fix:- (system-vector-length control-point) 2))
(ucode-return-address join-stacklets)))
\ No newline at end of file
projects / mit-scheme.git / commitdiff