From: Chris Hanson Date: Sat, 8 Feb 1992 15:08:47 +0000 (+0000) Subject: This version of the runtime system requires the following X-Git-Tag: 20090517-FFI~9845 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=e04a300b45b9a7f1865b005ab41cb53588e1f2da;p=mit-scheme.git This version of the runtime system requires the following corresponding versions: Microcode 11.108 SF 4.23 Edwin 3.66 Implement multiple control threads. * Use new reentrant directory-reading primitives. * Reimplement DYNAMIC-WIND and FLUID-LET. The dynamic state is split into a global part, which FLUID-LET bindings, and a local part, which DYNAMIC-WIND binds. The local part is different for each thread, and the global part is shared. The new dynamic state code is all written in Scheme, except for the primitive WITH-STACK-MARKER, which is used to inform the continuation parser about the state changes. * The continuation parser has been modified to hide the stack frames made by CALL-WITH-CURRENT-CONTINUATION from the debugger. * The variable TIMER-INTERRUPT has been removed. Chances are, you don't need this now, and this will prevent people from running programs that will screw thread preemption. * Keyboard interrupts are delivered to a specific thread, which can be accessed with KEYBOARD-INTERRUPT-THREAD and modified by SET-KEYBOARD-INTERRUPT-THREAD!. --- diff --git a/v7/src/runtime/conpar.scm b/v7/src/runtime/conpar.scm index 8a9a2e6fc..3923d8011 100644 --- a/v7/src/runtime/conpar.scm +++ b/v7/src/runtime/conpar.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/conpar.scm,v 14.24 1991/08/27 08:00:17 jinx Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/conpar.scm,v 14.25 1992/02/08 15:08:18 cph Exp $ -Copyright (c) 1988-1991 Massachusetts Institute of Technology +Copyright (c) 1988-92 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -41,7 +41,7 @@ MIT in each case. |# (define-structure (stack-frame (constructor make-stack-frame - (type elements dynamic-state fluid-bindings + (type elements dynamic-state interrupt-mask history previous-history-offset previous-history-control-point @@ -50,7 +50,6 @@ MIT in each case. |# (type false read-only true) (elements false read-only true) (dynamic-state false read-only true) - (fluid-bindings false read-only true) (interrupt-mask false read-only true) (history false read-only true) (previous-history-offset false read-only true) @@ -92,13 +91,6 @@ MIT in each case. |# (stack-frame/skip-non-subproblems stack-frame))) (stack-frame/skip-non-subproblems stack-frame))) -(define (stack-frame/skip-non-subproblems stack-frame) - (if (stack-frame/subproblem? stack-frame) - stack-frame - (let ((stack-frame (stack-frame/next stack-frame))) - (and stack-frame - (stack-frame/skip-non-subproblems stack-frame))))) - (define-integrable (stack-frame/length stack-frame) (vector-length (stack-frame/elements stack-frame))) @@ -117,12 +109,12 @@ MIT in each case. |# (and (interpreter-return-address? return-address) (return-address/code return-address)))) -(define-integrable (stack-frame/subproblem? stack-frame) +(define (stack-frame/subproblem? stack-frame) (stack-frame-type/subproblem? (stack-frame/type stack-frame))) (define-integrable (stack-frame/compiled-code? stack-frame) (compiled-return-address? (stack-frame/return-address stack-frame))) - + (define (stack-frame/resolve-stack-address frame address) (let loop ((frame frame) @@ -131,13 +123,46 @@ MIT in each case. |# (if (< offset length) (values frame offset) (loop (stack-frame/next frame) (- offset length)))))) + +(define (stack-frame/skip-non-subproblems stack-frame) + (let ((type (stack-frame/type stack-frame))) + (cond ((eq? type stack-frame-type/stack-marker) + (let loop ((stack-frame stack-frame)) + (let ((stack-frame (stack-frame/next stack-frame))) + (and stack-frame + (if (stack-frame/subproblem? stack-frame) + (stack-frame/next-subproblem stack-frame) + (loop stack-frame)))))) + ((and (stack-frame/subproblem? stack-frame) + (not (and (eq? type stack-frame-type/compiled-return-address) + (eq? (stack-frame/return-address stack-frame) + continuation-return-address)))) + stack-frame) + (else + (let ((stack-frame (stack-frame/next stack-frame))) + (and stack-frame + (stack-frame/skip-non-subproblems stack-frame))))))) + +(define continuation-return-address) + +(define (initialize-special-frames!) + (set! continuation-return-address + (let ((stack-frame + (call-with-current-continuation + (lambda (k) + k + (call-with-current-continuation + continuation/first-subproblem))))) + (and (eq? (stack-frame/type stack-frame) + stack-frame-type/compiled-return-address) + (stack-frame/return-address stack-frame)))) + unspecific) ;;;; Parser (define-structure (parser-state (constructor make-parser-state) (conc-name parser-state/)) (dynamic-state false read-only true) - (fluid-bindings false read-only true) (interrupt-mask false read-only true) (history false read-only true) (previous-history-offset false read-only true) @@ -150,15 +175,13 @@ MIT in each case. |# (define (continuation->stack-frame continuation) (parse-control-point (continuation/control-point continuation) (continuation/dynamic-state continuation) - (continuation/fluid-bindings continuation) false)) -(define (parse-control-point control-point dynamic-state fluid-bindings type) +(define (parse-control-point control-point dynamic-state type) (let ((element-stream (control-point/element-stream control-point))) (parse-one-frame (make-parser-state dynamic-state - fluid-bindings (control-point/interrupt-mask control-point) (let ((history (history-transform (control-point/history control-point)))) @@ -209,7 +232,6 @@ MIT in each case. |# (parse-control-point control-point (parser-state/dynamic-state state) - (parser-state/fluid-bindings state) (parser-state/previous-type state)))))))) ;;; `make-intermediate-state' is used to construct an intermediate @@ -224,7 +246,6 @@ MIT in each case. |# (- (parser-state/n-elements state) length))) (make-parser-state (parser-state/dynamic-state state) - (parser-state/fluid-bindings state) (parser-state/interrupt-mask state) (parser-state/history state) (let ((previous (parser-state/previous-history-offset state))) @@ -245,7 +266,7 @@ MIT in each case. |# ;;; 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-TO-STATE-POINT changes the `dynamic-state' component. +;;; 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)) @@ -259,7 +280,6 @@ MIT in each case. |# type elements (parser-state/dynamic-state state) - (parser-state/fluid-bindings state) (parser-state/interrupt-mask state) (if history? history @@ -269,7 +289,6 @@ MIT in each case. |# (+ (vector-length elements) n-elements) (parser-state/previous-type state) (make-parser-state (parser-state/dynamic-state state) - (parser-state/fluid-bindings state) (parser-state/interrupt-mask state) (if (or force-pop? history-subproblem?) (history-superproblem history) @@ -307,49 +326,39 @@ MIT in each case. |# (parse/standard-next type elements state valid-history? valid-history?))) -(define (parser/restore-dynamic-state type elements state) - ;; Possible problem: the dynamic state really consists of all of the - ;; state spaces in existence. Probably we should have some - ;; mechanism for keeping track of them all. - (parser/standard - type - elements - (make-parser-state (let ((dynamic-state (vector-ref elements 1))) - (if (eq? system-state-space - (state-point/space dynamic-state)) - dynamic-state - (parser-state/dynamic-state state))) - (parser-state/fluid-bindings state) - (parser-state/interrupt-mask state) - (parser-state/history state) - (parser-state/previous-history-offset state) - (parser-state/previous-history-control-point state) - (parser-state/element-stream state) - (parser-state/n-elements state) - (parser-state/next-control-point state) - (parser-state/previous-type state)))) - -(define (parser/restore-fluid-bindings type elements state) - (parser/standard - type - elements - (make-parser-state (parser-state/dynamic-state state) - (vector-ref elements 1) - (parser-state/interrupt-mask state) - (parser-state/history state) - (parser-state/previous-history-offset state) - (parser-state/previous-history-control-point state) - (parser-state/element-stream state) - (parser-state/n-elements state) - (parser-state/next-control-point state) - (parser-state/previous-type state)))) +(define (parser/stack-marker type elements state) + (let ((marker (vector-ref elements 1)) + (continue + (lambda (dynamic-state interrupt-mask) + (parser/standard + type + elements + (make-parser-state + dynamic-state + interrupt-mask + (parser-state/history state) + (parser-state/previous-history-offset state) + (parser-state/previous-history-control-point state) + (parser-state/element-stream state) + (parser-state/n-elements state) + (parser-state/next-control-point state) + (parser-state/previous-type state)))))) + (cond ((eq? marker %translate-to-state-point) + (continue (merge-dynamic-state (parser-state/dynamic-state state) + (vector-ref elements 2)) + (parser-state/interrupt-mask state))) + ((eq? marker set-interrupt-enables!) + (continue (parser-state/dynamic-state state) + (vector-ref elements 2))) + (else + (continue (parser-state/dynamic-state state) + (parser-state/interrupt-mask state)))))) (define (parser/restore-interrupt-mask type elements state) (parser/standard type elements (make-parser-state (parser-state/dynamic-state state) - (parser-state/fluid-bindings state) (vector-ref elements 1) (parser-state/history state) (parser-state/previous-history-offset state) @@ -364,7 +373,6 @@ MIT in each case. |# type elements (make-parser-state (parser-state/dynamic-state state) - (parser-state/fluid-bindings state) (parser-state/interrupt-mask state) (history-transform (vector-ref elements 1)) (vector-ref elements 2) @@ -379,8 +387,7 @@ MIT in each case. |# (define (stack-frame->continuation stack-frame) (make-continuation 'REENTRANT (stack-frame->control-point stack-frame) - (stack-frame/dynamic-state stack-frame) - (stack-frame/fluid-bindings stack-frame))) + (stack-frame/dynamic-state stack-frame))) (define (stack-frame->control-point stack-frame) (with-values (lambda () (unparse/stack-frame stack-frame)) @@ -439,10 +446,6 @@ MIT in each case. |# offset (+ index 1 (- (object-datum (element-stream/ref stream index)) missing))) -(define (length/repeat-primitive stream offset) - offset - (primitive-procedure-arity (element-stream/ref stream 1))) - (define (length/compiled-return-address stream offset) (let ((entry (element-stream/head stream))) (let ((frame-size (compiled-continuation/next-continuation-offset entry))) @@ -537,6 +540,8 @@ MIT in each case. |# (set! stack-frame-types (make-stack-frame-types)) (set! stack-frame-type/hardware-trap (microcode-return/name->type 'HARDWARE-TRAP)) + (set! stack-frame-type/stack-marker + (microcode-return/name->type 'STACK-MARKER)) (set! stack-frame-type/compiled-return-address (make-stack-frame-type false true false length/compiled-return-address @@ -553,19 +558,20 @@ MIT in each case. |# (make-stack-frame-type false true false 1 parser/standard)) - (set! word-size (let ((initial (system-vector-length (make-bit-string 1 #f)))) (let loop ((size 2)) (if (= (system-vector-length (make-bit-string size #f)) initial) (loop (1+ size)) (-1+ size))))) + (set! continuation-return-address false) unspecific) (define stack-frame-types) (define stack-frame-type/compiled-return-address) (define stack-frame-type/return-to-interpreter) (define stack-frame-type/hardware-trap) +(define stack-frame-type/stack-marker) (define stack-frame-type/interrupt-compiled-procedure) (define stack-frame-type/interrupt-compiled-expression) @@ -607,11 +613,10 @@ MIT in each case. |# parser/standard parser))) - (standard-frame 'RESTORE-TO-STATE-POINT 2 parser/restore-dynamic-state) - (standard-frame 'RESTORE-FLUIDS 2 parser/restore-fluid-bindings) (standard-frame 'RESTORE-INTERRUPT-MASK 2 parser/restore-interrupt-mask) (standard-frame 'RESTORE-HISTORY 4 parser/restore-history) (standard-frame 'RESTORE-DONT-COPY-HISTORY 4 parser/restore-history) + (standard-frame 'STACK-MARKER 3 parser/stack-marker) (standard-frame 'NON-EXISTENT-CONTINUATION 2) (standard-frame 'HALT 2) @@ -643,7 +648,6 @@ MIT in each case. |# (standard-subproblem 'PRIMITIVE-COMBINATION-3-APPLY 4) (standard-subproblem 'MOVE-TO-ADJACENT-POINT 6) (standard-subproblem 'COMBINATION-SAVE-VALUE length/combination-save-value) - (standard-subproblem 'REPEAT-PRIMITIVE length/repeat-primitive) (let ((length (length/application-frame 2 0))) (standard-subproblem 'COMBINATION-APPLY length) diff --git a/v7/src/runtime/contin.scm b/v7/src/runtime/contin.scm index 14e12e2d1..c7c6d8bb8 100644 --- a/v7/src/runtime/contin.scm +++ b/v7/src/runtime/contin.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/contin.scm,v 14.5 1991/02/15 18:04:39 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/contin.scm,v 14.6 1992/02/08 15:08:20 cph Exp $ -Copyright (c) 1988-91 Massachusetts Institute of Technology +Copyright (c) 1988-92 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -51,30 +51,23 @@ MIT in each case. |# (primitive (lambda (control-point) (let ((continuation - (make-continuation type - control-point - (current-dynamic-state) - (get-fluid-bindings)))) + (make-continuation type control-point (get-dynamic-state)))) (continuation (receiver continuation)))))) -(define (%within-continuation continuation thunk) +(define (%within-continuation continuation thread-switch? thunk) ((ucode-primitive within-control-point 2) (continuation/control-point continuation) - (let ((dynamic-state (continuation/dynamic-state continuation)) - (fluid-bindings (continuation/fluid-bindings continuation))) + (let ((dynamic-state (continuation/dynamic-state continuation))) (lambda () - (set-fluid-bindings! fluid-bindings) - (translate-to-state-point dynamic-state) + (set-dynamic-state! dynamic-state thread-switch?) (thunk))))) (define (invocation-method/reentrant continuation value) ((ucode-primitive within-control-point 2) (continuation/control-point continuation) - (let ((dynamic-state (continuation/dynamic-state continuation)) - (fluid-bindings (continuation/fluid-bindings continuation))) + (let ((dynamic-state (continuation/dynamic-state continuation))) (lambda () - (set-fluid-bindings! fluid-bindings) - (translate-to-state-point dynamic-state) + (set-dynamic-state! dynamic-state false) value)))) ;; These two are correctly locked for multiprocessing, but not for @@ -95,7 +88,7 @@ MIT in each case. |# continuation invocation-method/used) true)))))) - (%within-continuation continuation thunk) + (%within-continuation continuation false thunk) (error "Reentering used continuation" continuation))) (define (invocation-method/unused continuation value) @@ -113,14 +106,14 @@ MIT in each case. |# value (error "Reentering used continuation" continuation)) -(define (make-continuation type control-point dynamic-state fluid-bindings) +(define (make-continuation type control-point dynamic-state) (make-entity (case type ((REENTRANT) invocation-method/reentrant) ((UNUSED) invocation-method/unused) ((USED) invocation-method/used) (else (error "Illegal continuation type" type))) - (make-%continuation control-point dynamic-state fluid-bindings))) + (make-%continuation control-point dynamic-state))) (define (continuation/type continuation) (let ((invocation-method (continuation/invocation-method continuation))) @@ -152,11 +145,7 @@ MIT in each case. |# (define-integrable (continuation/dynamic-state continuation) (%continuation/dynamic-state (entity-extra continuation))) -(define-integrable (continuation/fluid-bindings continuation) - (%continuation/fluid-bindings (entity-extra continuation))) - (define-structure (%continuation (constructor make-%continuation) (conc-name %continuation/)) (control-point false read-only true) - (dynamic-state false read-only true) - (fluid-bindings false read-only true)) \ No newline at end of file + (dynamic-state false read-only true)) \ No newline at end of file diff --git a/v7/src/runtime/ed-ffi.scm b/v7/src/runtime/ed-ffi.scm index 230136fde..3b81fcae8 100644 --- a/v7/src/runtime/ed-ffi.scm +++ b/v7/src/runtime/ed-ffi.scm @@ -176,6 +176,8 @@ syntax-table/system-internal) ("system" (runtime system) syntax-table/system-internal) + ("thread" (runtime thread) + syntax-table/system-internal) ("tscript" (runtime transcript) syntax-table/system-internal) ("ttyio" (runtime console-i/o-port) diff --git a/v7/src/runtime/emacs.scm b/v7/src/runtime/emacs.scm index 9cf35aaa3..4b37c4286 100644 --- a/v7/src/runtime/emacs.scm +++ b/v7/src/runtime/emacs.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/emacs.scm,v 14.10 1991/11/26 07:05:34 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/emacs.scm,v 14.11 1992/02/08 15:08:23 cph Exp $ -Copyright (c) 1988-91 Massachusetts Institute of Technology +Copyright (c) 1988-92 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -140,8 +140,7 @@ MIT in each case. |# (loop))) true) -(define (emacs/^G-interrupt interrupt-mask) - interrupt-mask +(define (emacs/^G-interrupt) (transmit-signal the-console-port #\g)) ;;;; Miscellaneous Hooks diff --git a/v7/src/runtime/framex.scm b/v7/src/runtime/framex.scm index 3dcef5b9b..308ca5c72 100644 --- a/v7/src/runtime/framex.scm +++ b/v7/src/runtime/framex.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/framex.scm,v 14.15 1991/06/14 03:02:57 jinx Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/framex.scm,v 14.16 1992/02/08 15:08:24 cph Exp $ -Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology +Copyright (c) 1988-92 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -324,7 +324,6 @@ MIT in each case. |# (let ((method (method/application-frame 3))) (record-method 'INTERNAL-APPLY method) (record-method 'INTERNAL-APPLY-VAL method)) - (record-method 'REPEAT-PRIMITIVE (method/application-frame 1)) (let ((method (method/compiler-reference identity-procedure))) (record-method 'COMPILER-REFERENCE-RESTART method) (record-method 'COMPILER-SAFE-REFERENCE-RESTART method)) diff --git a/v7/src/runtime/global.scm b/v7/src/runtime/global.scm index 0143af997..bf85b7efb 100644 --- a/v7/src/runtime/global.scm +++ b/v7/src/runtime/global.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/global.scm,v 14.34 1991/11/26 07:06:16 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/global.scm,v 14.35 1992/02/08 15:08:26 cph Exp $ -Copyright (c) 1988-91 Massachusetts Institute of Technology +Copyright (c) 1988-92 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -110,17 +110,36 @@ MIT in each case. |# (define-integrable (system-hunk3-cons type cxr0 cxr1 cxr2) (object-new-type type (hunk3-cons cxr0 cxr1 cxr2))) +(define (object-component-binder get-component set-component!) + (lambda (object new-value thunk) + (let ((old-value)) + (shallow-fluid-bind + (lambda () + (set! old-value (get-component object)) + (set-component! object new-value) + (set! new-value false) + unspecific) + thunk + (lambda () + (set! new-value (get-component object)) + (set-component! object old-value) + (set! old-value false) + unspecific))))) + (define (bind-cell-contents! cell new-value thunk) (let ((old-value)) - (dynamic-wind (lambda () - (set! old-value (cell-contents cell)) - (set-cell-contents! cell new-value) - (set! new-value)) - thunk - (lambda () - (set! new-value (cell-contents cell)) - (set-cell-contents! cell old-value) - (set! old-value))))) + (shallow-fluid-bind + (lambda () + (set! old-value (cell-contents cell)) + (set-cell-contents! cell new-value) + (set! new-value) + unspecific) + thunk + (lambda () + (set! new-value (cell-contents cell)) + (set-cell-contents! cell old-value) + (set! old-value) + unspecific)))) (define (values . objects) (lambda (receiver) @@ -138,7 +157,7 @@ MIT in each case. |# (with-output-to-truncated-string max (lambda () (write object))))) - + (define (pa procedure) (if (not (procedure? procedure)) (error "Must be a procedure" procedure)) @@ -153,7 +172,7 @@ MIT in each case. |# ;; Compatibility. (define %pwd pwd) (define %cd cd) - + (define (show-time thunk) (let ((process-start (process-time-clock)) (real-start (real-time-clock))) @@ -210,7 +229,7 @@ MIT in each case. |# (define-integrable (object-pointer? object) (not (object-non-pointer? object))) - + (define (impurify object) (if (and (object-pointer? object) (object-pure? object)) ((ucode-primitive primitive-impurify) object)) @@ -225,7 +244,7 @@ MIT in each case. |# (if (not ((ucode-primitive primitive-fasdump) object filename false)) (error "FASDUMP: Object is too large to be dumped:" object)) (write-string " -- done" port))) - + (define (undefined-value? object) ;; Note: the unparser takes advantage of the fact that objects ;; satisfying this predicate also satisfy: diff --git a/v7/src/runtime/intrpt.scm b/v7/src/runtime/intrpt.scm index 6d087a90d..d433430a0 100644 --- a/v7/src/runtime/intrpt.scm +++ b/v7/src/runtime/intrpt.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/intrpt.scm,v 14.8 1991/11/26 07:06:25 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/intrpt.scm,v 14.9 1992/02/08 15:08:27 cph Exp $ -Copyright (c) 1988-91 Massachusetts Institute of Technology +Copyright (c) 1988-92 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -42,24 +42,23 @@ MIT in each case. |# (fixed-objects-vector-slot 'SYSTEM-INTERRUPT-VECTOR)) (set! index:termination-vector (fixed-objects-vector-slot 'MICROCODE-TERMINATIONS-PROCEDURES)) + (set! keyboard-thread false) (set! hook/clean-input/flush-typeahead false) (set! hook/clean-input/keep-typeahead false) (set! hook/^B-interrupt false) (set! hook/^G-interrupt false) (set! hook/^U-interrupt false) (set! hook/^X-interrupt false) - (set! timer-interrupt default/timer-interrupt) - (set! external-interrupt default/external-interrupt) - (set! keyboard-interrupts - (let ((table (make-vector 256 losing-keyboard-interrupt))) + (set! keyboard-interrupt-vector + (let ((table (make-vector 256 false))) (for-each (lambda (entry) (vector-set! table (char->ascii (car entry)) (cadr entry))) - `((#\B ,(keep-typeahead ^B-interrupt-handler)) - (#\G ,(flush-typeahead ^G-interrupt-handler)) - (#\U ,(flush-typeahead ^U-interrupt-handler)) - (#\X ,(flush-typeahead ^X-interrupt-handler)))) + `((#\B ,^B-interrupt-handler) + (#\G ,^G-interrupt-handler) + (#\U ,^U-interrupt-handler) + (#\X ,^X-interrupt-handler))) table)) (install)) @@ -85,13 +84,7 @@ MIT in each case. |# (define (timer-interrupt-handler interrupt-code interrupt-enables) interrupt-code interrupt-enables (clear-interrupts! interrupt-bit/timer) - (timer-interrupt)) - -(define timer-interrupt) -(define (default/timer-interrupt) - (process-timer-clear) - (real-timer-clear) - (error "Unhandled Timer interrupt received")) + (thread-timer-interrupt-handler)) (define (suspend-interrupt-handler interrupt-code interrupt-enables) interrupt-code interrupt-enables @@ -123,25 +116,8 @@ MIT in each case. |# ;;;; Keyboard Interrupts -(define (external-interrupt-handler interrupt-code interrupt-enables) - interrupt-code - (clear-interrupts! interrupt-bit/kbd) - (external-interrupt (tty-next-interrupt-char) interrupt-enables)) - -(define (with-external-interrupts-handler handler thunk) - (fluid-let ((external-interrupt (flush-typeahead handler))) - (thunk))) - -(define external-interrupt) -(define (default/external-interrupt character interrupt-enables) - ((vector-ref keyboard-interrupts character) character interrupt-enables)) - -(define (losing-keyboard-interrupt character interrupt-enables) - interrupt-enables - (error "Bad interrupt character" character)) - -(define keyboard-interrupts) - +(define keyboard-interrupt-vector) +(define keyboard-thread) (define hook/clean-input/flush-typeahead) (define hook/clean-input/keep-typeahead) (define hook/^B-interrupt) @@ -149,39 +125,57 @@ MIT in each case. |# (define hook/^U-interrupt) (define hook/^X-interrupt) -(define ((flush-typeahead kernel) char interrupt-enables) - (if (or (not hook/clean-input/flush-typeahead) - (hook/clean-input/flush-typeahead char)) - (kernel char interrupt-enables))) +(define (keyboard-interrupt-thread) + keyboard-thread) -(define ((keep-typeahead kernel) char interrupt-enables) - (if (or (not hook/clean-input/keep-typeahead) - (hook/clean-input/keep-typeahead char)) - (kernel char interrupt-enables))) +(define (set-keyboard-interrupt-thread! thread) + (if (not (or (not thread) (thread? thread))) + (error:wrong-type-argument thread + "thread or #f" + set-keyboard-interrupt-thread!)) + (set! keyboard-thread thread) + unspecific) + +(define (external-interrupt-handler interrupt-code interrupt-mask) + interrupt-code interrupt-mask + (clear-interrupts! interrupt-bit/kbd) + (let ((char (tty-next-interrupt-char))) + (let ((handler (vector-ref keyboard-interrupt-vector char))) + (if (not handler) + (error "Bad interrupt character:" char)) + (handler char)))) -(define (^B-interrupt-handler char interrupt-mask) - char +(define (^B-interrupt-handler char) (if hook/^B-interrupt - (hook/^B-interrupt interrupt-mask)) - (cmdl-interrupt/breakpoint)) + (hook/^B-interrupt)) + (if (and (or (not hook/clean-input/keep-typeahead) + (hook/clean-input/keep-typeahead char)) + keyboard-thread) + (signal-thread-event keyboard-thread cmdl-interrupt/breakpoint))) -(define (^G-interrupt-handler char interrupt-mask) - char +(define (^G-interrupt-handler char) (if hook/^G-interrupt - (hook/^G-interrupt interrupt-mask)) - (cmdl-interrupt/abort-top-level)) + (hook/^G-interrupt)) + (if (and (or (not hook/clean-input/flush-typeahead) + (hook/clean-input/flush-typeahead char)) + keyboard-thread) + (signal-thread-event keyboard-thread cmdl-interrupt/abort-top-level))) -(define (^U-interrupt-handler char interrupt-mask) - char +(define (^U-interrupt-handler char) (if hook/^U-interrupt - (hook/^U-interrupt interrupt-mask)) - (cmdl-interrupt/abort-previous)) + (hook/^U-interrupt)) + (if (and (or (not hook/clean-input/flush-typeahead) + (hook/clean-input/flush-typeahead char)) + keyboard-thread) + (signal-thread-event keyboard-thread cmdl-interrupt/abort-previous))) -(define (^X-interrupt-handler char interrupt-mask) - char +(define (^X-interrupt-handler char) (if hook/^X-interrupt - (hook/^X-interrupt interrupt-mask)) - (cmdl-interrupt/abort-nearest)) + (hook/^X-interrupt)) + (if (and (or (not hook/clean-input/flush-typeahead) + (hook/clean-input/flush-typeahead char)) + keyboard-thread) + (signal-thread-event keyboard-thread cmdl-interrupt/abort-nearest))) (define (install) (without-interrupts diff --git a/v7/src/runtime/io.scm b/v7/src/runtime/io.scm index aaedaeb31..5753722dd 100644 --- a/v7/src/runtime/io.scm +++ b/v7/src/runtime/io.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/io.scm,v 14.28 1991/11/04 20:29:14 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/io.scm,v 14.29 1992/02/08 15:08:29 cph Exp $ -Copyright (c) 1988-91 Massachusetts Institute of Technology +Copyright (c) 1988-92 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -39,11 +39,14 @@ MIT in each case. |# (define open-channels-list) (define traversing?) +(define open-directories-list) (define (initialize-package!) (set! open-channels-list (list 'OPEN-CHANNELS-LIST)) (set! traversing? false) (add-gc-daemon! close-lost-open-files-daemon) + (set! open-directories-list (make-protection-list)) + (add-gc-daemon! close-lost-open-directories-daemon) (add-event-receiver! event:after-restore primitive-io/reset!)) (define-structure (channel (constructor %make-channel)) @@ -433,6 +436,84 @@ MIT in each case. |# (define (pty-master-hangup channel) ((ucode-primitive pty-master-hangup 1) (channel-descriptor channel))) +;;;; Directory Primitives + +(define-structure (directory-channel (conc-name directory-channel/)) + descriptor) + +(define (directory-channel-open name) + (without-interrupts + (lambda () + (let ((descriptor ((ucode-primitive new-directory-open 1) name))) + (let ((channel (make-directory-channel descriptor))) + (add-to-protection-list! open-directories-list channel descriptor) + channel))))) + +(define (directory-channel-close channel) + (without-interrupts + (lambda () + (let ((descriptor (directory-channel/descriptor channel))) + (if descriptor + (begin + ((ucode-primitive new-directory-close 1) descriptor) + (set-directory-channel/descriptor! channel false) + (remove-from-protection-list! open-directories-list channel))))))) + +(define (close-lost-open-directories-daemon) + (clean-lost-protected-objects open-directories-list + (ucode-primitive new-directory-close 1))) + +(define (directory-channel-read channel) + ((ucode-primitive new-directory-read 1) + (directory-channel/descriptor channel))) + +(define (directory-channel-read-matching channel prefix) + ((ucode-primitive new-directory-read-matching 2) + (directory-channel/descriptor channel) + prefix)) + +;;;; Protection lists + +;;; These will cause problems on interpreted systems, due to the +;;; consing of the interpreter. For now we'll only run this compiled. + +(define (make-protection-list) + (list 'PROTECTION-LIST)) + +(define (add-to-protection-list! list scheme-object microcode-object) + (with-absolutely-no-interrupts + (lambda () + (set-cdr! list + (cons (weak-cons scheme-object microcode-object) + (cdr list)))))) + +(define (remove-from-protection-list! list scheme-object) + (with-absolutely-no-interrupts + (lambda () + (let loop ((associations (cdr list)) (previous list)) + (if (not (null? associations)) + (if (eq? scheme-object (weak-pair/car? (car associations))) + (set-cdr! previous (cdr associations)) + (loop (cdr associations) associations))))))) + +(define (clean-lost-protected-objects list cleaner) + (let loop ((associations (cdr list)) (previous list)) + (if (not (null? associations)) + (if (weak-pair/car? (car associations)) + (loop (cdr associations) associations) + (begin + (cleaner (weak-cdr (car associations))) + (let ((next (cdr associations))) + (set-cdr! previous next) + (loop next previous))))))) + +(define (search-protection-list list microcode-object) + (let loop ((associations (cdr list))) + (and (not (null? associations)) + (if (eq? microcode-object (system-pair-cdr (car associations))) + (system-pair-car (car associations)) + (loop (cdr associations)))))) + ;;;; Buffered Output (define-structure (output-buffer diff --git a/v7/src/runtime/make.scm b/v7/src/runtime/make.scm index 588035831..8c830bd11 100644 --- a/v7/src/runtime/make.scm +++ b/v7/src/runtime/make.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/make.scm,v 14.32 1992/02/07 19:47:32 jinx Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/make.scm,v 14.33 1992/02/08 15:08:31 cph Exp $ -Copyright (c) 1988-1992 Massachusetts Institute of Technology +Copyright (c) 1988-92 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -348,6 +348,7 @@ MIT in each case. |# (RUNTIME INTERRUPT-HANDLER) (RUNTIME GC-STATISTICS) (RUNTIME REP) + (RUNTIME THREAD) ;; Debugging (RUNTIME COMPILER-INFO) (RUNTIME ADVICE) @@ -362,6 +363,8 @@ MIT in each case. |# ;; Emacs -- last because it grabs the kitchen sink. (RUNTIME EMACS-INTERFACE))) +(package-initialize '(RUNTIME CONTINUATION-PARSER) 'INITIALIZE-SPECIAL-FRAMES!) + (let ((filename (map-filename "site"))) (if (file-exists? filename) (eval (fasload filename #t) system-global-environment))) @@ -397,4 +400,6 @@ MIT in each case. |# ) (package/add-child! system-global-package 'USER user-initial-environment) +(set-keyboard-interrupt-thread! (current-thread)) +(start-thread-timer) (initial-top-level-repl) \ No newline at end of file diff --git a/v7/src/runtime/rep.scm b/v7/src/runtime/rep.scm index 41e594a17..96df33f16 100644 --- a/v7/src/runtime/rep.scm +++ b/v7/src/runtime/rep.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/rep.scm,v 14.22 1991/11/26 07:06:53 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/rep.scm,v 14.23 1992/02/08 15:08:33 cph Exp $ -Copyright (c) 1988-91 Massachusetts Institute of Technology +Copyright (c) 1988-92 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -135,6 +135,7 @@ MIT in each case. |# (with-interrupt-mask interrupt-mask/all (lambda (interrupt-mask) interrupt-mask + (unblock-thread-events) (message cmdl) ((cmdl/driver cmdl) cmdl))))))))))))) (if operation diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg index 61cee6ddb..760bdd3ed 100644 --- a/v7/src/runtime/runtime.pkg +++ b/v7/src/runtime/runtime.pkg @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/runtime.pkg,v 14.132 1992/02/04 23:59:37 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/runtime.pkg,v 14.133 1992/02/08 15:08:35 cph Exp $ Copyright (c) 1988-92 Massachusetts Institute of Technology @@ -287,13 +287,14 @@ MIT in each case. |# call-with-current-continuation continuation/control-point continuation/dynamic-state - continuation/fluid-bindings continuation/type continuation? guarantee-continuation make-continuation non-reentrant-call-with-current-continuation - within-continuation)) + within-continuation) + (export (runtime thread) + %within-continuation)) (define-package (runtime continuation-parser) (files "conpar") @@ -316,7 +317,6 @@ MIT in each case. |# stack-frame-type? stack-frame/dynamic-state stack-frame/elements - stack-frame/fluid-bindings stack-frame/interrupt-mask stack-frame/length stack-frame/next @@ -987,8 +987,8 @@ MIT in each case. |# (files "intrpt") (parent ()) (export () - timer-interrupt - with-external-interrupts-handler) + keyboard-interrupt-thread + set-keyboard-interrupt-thread!) (export (runtime emacs-interface) hook/^G-interrupt hook/clean-input/flush-typeahead) @@ -1511,6 +1511,11 @@ MIT in each case. |# channel-write-string-block channel? close-all-open-files + directory-channel-close + directory-channel-open + directory-channel-read + directory-channel-read-matching + directory-channel? file-length file-open-append-channel file-open-input-channel @@ -2078,18 +2083,17 @@ MIT in each case. |# (files "wind") (parent ()) (export () - current-dynamic-state dynamic-wind - execute-at-new-state-point - get-fluid-bindings - make-state-space - object-component-binder - set-current-dynamic-state! - set-fluid-bindings! - translate-to-state-point) + shallow-fluid-bind) + (export (runtime continuation) + get-dynamic-state + set-dynamic-state!) (export (runtime continuation-parser) - state-point/space - system-state-space) + %translate-to-state-point + merge-dynamic-state) + (export (runtime thread) + make-state-space + state-space:local) (initialization (initialize-package!))) (define-package (runtime stream) @@ -2292,4 +2296,39 @@ MIT in each case. |# port/gc-start) (export (runtime emacs-interface) port/read-finish - port/read-start)) \ No newline at end of file + port/read-start)) + +(define-package (runtime thread) + (files "thread") + (parent ()) + (export () + block-thread-events + condition-type:thread-deadlock + condition-type:thread-detached + condition-type:thread-error + create-thread + current-thread + detach-thread + exit-current-thread + join-thread + lock-thread-mutex + make-thread-mutex + other-running-threads? + set-thread-timer-interval! + signal-thread-event + sleep-current-thread + start-thread-timer + stop-thread-timer + suspend-current-thread + thread-continuation + thread-dead? + thread-mutex? + thread-timer-interval + thread? + try-lock-thread-mutex + unblock-thread-events + unlock-thread-mutex + yield-current-thread) + (export (runtime interrupt-handler) + thread-timer-interrupt-handler) + (initialization (initialize-package!))) \ No newline at end of file diff --git a/v7/src/runtime/savres.scm b/v7/src/runtime/savres.scm index 817abf988..a4a413393 100644 --- a/v7/src/runtime/savres.scm +++ b/v7/src/runtime/savres.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/savres.scm,v 14.23 1991/11/26 07:07:07 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/savres.scm,v 14.24 1992/02/08 15:08:37 cph Exp $ -Copyright (c) 1988-91 Massachusetts Institute of Technology +Copyright (c) 1988-92 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -51,7 +51,8 @@ MIT in each case. |# (define (initialize-package!) (set! disk-save (setup-image disk-save/kernel)) - (set! dump-world (setup-image dump-world/kernel))) + (set! dump-world (setup-image dump-world/kernel)) + unspecific) (define disk-save) (define dump-world) @@ -70,6 +71,7 @@ MIT in each case. |# (lambda () (set! time-world-saved time) (event-distributor/invoke! event:after-restore) + (start-thread-timer) (cond ((string? identify) (set! world-identification identify) (clear console-output-port) @@ -89,21 +91,18 @@ MIT in each case. |# (call-with-current-continuation (lambda (continuation) (let ((fixed-objects (get-fixed-objects-vector)) - (dynamic-state (current-dynamic-state)) (filename (->namestring (merge-pathnames filename)))) - (fluid-let () - ((ucode-primitive call-with-current-continuation) - (lambda (restart) - (gc-flip) - (do () (((ucode-primitive dump-band) restart filename)) - (with-simple-restart 'RETRY "Try again." - (lambda () - (error "Disk save failed:" filename)))) - (continuation after-suspend))) - ((ucode-primitive set-fixed-objects-vector!) fixed-objects) - (set-current-dynamic-state! dynamic-state) - (read-microcode-tables!) - after-restore)))))))) + ((ucode-primitive call-with-current-continuation) + (lambda (restart) + (gc-flip) + (do () (((ucode-primitive dump-band) restart filename)) + (with-simple-restart 'RETRY "Try again." + (lambda () + (error "Disk save failed:" filename)))) + (continuation after-suspend))) + ((ucode-primitive set-fixed-objects-vector!) fixed-objects) + (read-microcode-tables!) + after-restore))))))) (define (dump-world/kernel filename after-suspend after-restore) ((with-absolutely-no-interrupts diff --git a/v7/src/runtime/syntax.scm b/v7/src/runtime/syntax.scm index 6f9d96e3c..e57ff8e4c 100644 --- a/v7/src/runtime/syntax.scm +++ b/v7/src/runtime/syntax.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/Attic/syntax.scm,v 14.16 1991/04/18 22:35:21 markf Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/Attic/syntax.scm,v 14.17 1992/02/08 15:08:39 cph Exp $ -Copyright (c) 1988-91 Massachusetts Institute of Technology +Copyright (c) 1988-92 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -474,7 +474,7 @@ MIT in each case. |# (lambda (names values transfers-in transfers-out) (make-closed-block lambda-tag:fluid-let names values (make-combination* - (make-absolute-reference 'DYNAMIC-WIND) + (make-absolute-reference 'SHALLOW-FLUID-BIND) (make-thunk (make-scode-sequence transfers-in)) (make-thunk (syntax-sequence body)) (make-thunk (make-scode-sequence transfers-out)))))))) @@ -548,19 +548,6 @@ MIT in each case. |# (else (syntax-error "binding name illegal" (car binding))))) (syntax-error "binding not a pair" binding))) - -(define (syntax/dynamic-state-let state-space bindings . body) - (if (null? bindings) - (syntax-sequence body) - (syntax-fluid-bindings/shallow bindings - (lambda (names values transfers-in transfers-out) - (make-closed-block lambda-tag:dynamic-state-let names values - (make-combination* - (make-absolute-reference 'EXECUTE-AT-NEW-STATE-POINT) - (syntax-expression state-space) - (make-thunk (make-scode-sequence transfers-in)) - (make-thunk (syntax-sequence body)) - (make-thunk (make-scode-sequence transfers-out)))))))) ;;;; Extended Assignment Syntax @@ -663,9 +650,6 @@ MIT in each case. |# (define-integrable lambda-tag:let (string->symbol "#[let-procedure]")) -(define-integrable lambda-tag:dynamic-state-let - (string->symbol "#[dynamic-state-let-procedure]")) - (define-integrable lambda-tag:fluid-let (string->symbol "#[fluid-let-procedure]")) diff --git a/v7/src/runtime/uerror.scm b/v7/src/runtime/uerror.scm index c3c290be4..a89c12f48 100644 --- a/v7/src/runtime/uerror.scm +++ b/v7/src/runtime/uerror.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/uerror.scm,v 14.30 1991/11/26 06:53:41 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/uerror.scm,v 14.31 1992/02/08 15:08:40 cph Exp $ -Copyright (c) 1988-91 Massachusetts Institute of Technology +Copyright (c) 1988-92 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -339,7 +339,8 @@ MIT in each case. |# (eq? primitive (ucode-primitive file-open-output-channel 1))) (values "open" "file")) ((or (eq? primitive (ucode-primitive directory-open 1)) - (eq? primitive (ucode-primitive directory-open-noread 1))) + (eq? primitive (ucode-primitive directory-open-noread 1)) + (eq? primitive (ucode-primitive new-directory-open 1))) (values "open" "directory")) ((or (eq? primitive (ucode-primitive file-modes 1)) (eq? primitive (ucode-primitive file-access 2))) diff --git a/v7/src/runtime/unsyn.scm b/v7/src/runtime/unsyn.scm index 149a204d9..c15a9925e 100644 --- a/v7/src/runtime/unsyn.scm +++ b/v7/src/runtime/unsyn.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/unsyn.scm,v 14.11 1991/02/15 18:07:27 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/unsyn.scm,v 14.12 1992/02/08 15:08:42 cph Exp $ -Copyright (c) 1988-91 Massachusetts Institute of Technology +Copyright (c) 1988-92 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -442,9 +442,9 @@ MIT in each case. |# ;; substitutions. (cond ((not (null? substitutions)) (if-malformed)) - ((and (or (absolute-reference-to? operator 'DYNAMIC-WIND) + ((and (or (absolute-reference-to? operator 'SHALLOW-FLUID-BIND) (and (variable? operator) - (eq? (variable-name operator) 'DYNAMIC-WIND))) + (eq? (variable-name operator) 'SHALLOW-FLUID-BIND))) (pair? operands) (lambda? (car operands)) (pair? (cdr operands)) diff --git a/v7/src/runtime/unxdir.scm b/v7/src/runtime/unxdir.scm index a67e84e48..bff51d86f 100644 --- a/v7/src/runtime/unxdir.scm +++ b/v7/src/runtime/unxdir.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/unxdir.scm,v 14.8 1991/11/04 20:30:16 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/unxdir.scm,v 14.9 1992/02/08 15:08:44 cph Exp $ -Copyright (c) 1988-91 Massachusetts Institute of Technology +Copyright (c) 1988-92 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -72,16 +72,14 @@ MIT in each case. |# (pathname-type instance))))))))))) (define (generate-directory-pathnames pathname) - (dynamic-wind - (lambda () unspecific) - (lambda () - ((ucode-primitive directory-open-noread 1) (->namestring pathname)) - (let loop ((result '())) - (let ((name ((ucode-primitive directory-read 0)))) - (if name - (loop (cons name result)) - result)))) - (ucode-primitive directory-close 0))) + (let ((channel (directory-channel-open (->namestring pathname)))) + (let loop ((result '())) + (let ((name (directory-channel-read channel))) + (if name + (loop (cons name result)) + (begin + (directory-channel-close channel) + result)))))) (define (match-component pattern instance) (or (eq? pattern 'WILD) diff --git a/v7/src/runtime/version.scm b/v7/src/runtime/version.scm index 1aa535637..42694877e 100644 --- a/v7/src/runtime/version.scm +++ b/v7/src/runtime/version.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/version.scm,v 14.145 1992/02/07 19:47:41 jinx Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/version.scm,v 14.146 1992/02/08 15:08:45 cph Exp $ -Copyright (c) 1988-1992 Massachusetts Institute of Technology +Copyright (c) 1988-92 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -45,7 +45,7 @@ MIT in each case. |# '())) (add-system! microcode-system) (add-event-receiver! event:after-restore snarf-microcode-version!) - (add-identification! "Runtime" 14 145)) + (add-identification! "Runtime" 14 146)) (define microcode-system) diff --git a/v7/src/runtime/wind.scm b/v7/src/runtime/wind.scm index 0cbc7e5ce..e23fd2215 100644 --- a/v7/src/runtime/wind.scm +++ b/v7/src/runtime/wind.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/wind.scm,v 14.3 1989/03/06 19:59:05 cph Rel $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/wind.scm,v 14.4 1992/02/08 15:08:46 cph Exp $ -Copyright (c) 1988, 1989 Massachusetts Institute of Technology +Copyright (c) 1988-92 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -36,78 +36,180 @@ MIT in each case. |# ;;; package: (runtime state-space) (declare (usual-integrations)) + +;;; A STATE-SPACE is a tree of STATE-POINTs, except that the pointers +;;; in the tree point towards the root of the tree rather than its +;;; leaves. These pointers are the NEARER-POINT of each point. + +;;; Each point in the space has two procedures, TO-NEARER and +;;; FROM-NEARER. To move the root of the space to an adjacent point, +;;; one executes the FROM-NEARER of that point, then makes the +;;; TO-NEARER and FROM-NEARER of the old root be the FROM-NEARER and +;;; TO-NEARER of the new root, respectively. + +(define-integrable with-stack-marker + (ucode-primitive with-stack-marker 3)) -(define (initialize-package!) - (let ((fixed-objects (get-fixed-objects-vector)) - (state-space-tag "State Space") - (state-point-tag "State Point")) - (unparser/set-tagged-vector-method! - state-space-tag - (unparser/standard-method 'STATE-SPACE)) - (unparser/set-tagged-vector-method! - state-point-tag - (unparser/standard-method 'STATE-POINT)) - (vector-set! fixed-objects - (fixed-objects-vector-slot 'STATE-SPACE-TAG) - state-space-tag) - (vector-set! fixed-objects - (fixed-objects-vector-slot 'STATE-POINT-TAG) - state-point-tag) - (set! system-state-space (make-state-space false)) - (vector-set! fixed-objects - (fixed-objects-vector-slot 'STATE-SPACE-ROOT) - (current-dynamic-state)) - ((ucode-primitive set-fixed-objects-vector!) fixed-objects))) - -(define-structure (state-point (type vector) - (initial-offset 1) - (constructor false) - (conc-name state-point/)) - (before-thunk false read-only true) - (after-thunk false read-only true) - (nearer-point false read-only true) - (distance-to-root false read-only true)) +(define-structure (state-space + (conc-name state-space/) + (constructor %make-state-space)) + nearest-point) + +(define (make-state-space) + (let ((space (%make-state-space '()))) + ;; Save the state space in the TO-NEARER field of the root point, + ;; because it is needed by %TRANSLATE-TO-STATE-POINT. + (set-state-space/nearest-point! space (make-state-point false space false)) + space)) + +(define-structure (state-point (conc-name state-point/)) + nearer-point + to-nearer + from-nearer) + +(define (%execute-at-new-state-point space before during after) + (let ((old-root + (without-interrupts + (lambda () + (let ((old-root (state-space/nearest-point space))) + (let ((new-point (make-state-point false space false))) + (set-state-point/nearer-point! old-root new-point) + (set-state-point/to-nearer! old-root before) + (set-state-point/from-nearer! old-root after) + (set-state-space/nearest-point! space new-point)) + (before) + old-root))))) + (let ((value + (with-stack-marker during %translate-to-state-point old-root))) + (%translate-to-state-point old-root) + value))) + +(define (%translate-to-state-point point) + (without-interrupts + (lambda () + (let find-nearest ((point point) (chain '())) + (let ((nearer-point (state-point/nearer-point point))) + (if nearer-point + (find-nearest nearer-point (cons point chain)) + (let ((space (state-point/to-nearer point))) + (let traverse-chain ((old-root point) (chain chain)) + (if (not (null? chain)) + (let ((new-root (car chain))) + ;; Move to NEW-ROOT. + (let ((to-nearer (state-point/to-nearer new-root)) + (from-nearer (state-point/from-nearer new-root))) + (set-state-point/nearer-point! old-root new-root) + (set-state-point/to-nearer! old-root from-nearer) + (set-state-point/from-nearer! old-root to-nearer) + (set-state-point/nearer-point! new-root false) + (set-state-point/to-nearer! new-root space) + (set-state-point/from-nearer! new-root false) + (set-state-space/nearest-point! space new-root) + (with-stack-marker from-nearer + set-interrupt-enables! interrupt-mask/gc-ok)) + ;; Disable interrupts again in case FROM-NEARER + ;; re-enabled them. + (set-interrupt-enables! interrupt-mask/gc-ok) + ;; Make sure that NEW-ROOT is still the root, + ;; because FROM-NEARER might have moved it. If + ;; it has been moved, find the new root, and + ;; adjust CHAIN as needed. + (let find-root ((chain chain)) + (let ((nearer-point + (state-point/nearer-point (car chain)))) + (cond ((not nearer-point) + ;; (CAR CHAIN) is the root. + (traverse-chain (car chain) (cdr chain))) + ((and (not (null? (cdr chain))) + (eq? nearer-point (cadr chain))) + ;; The root has moved along CHAIN. + (find-root (cdr chain))) + (else + ;; The root has moved elsewhere. + (find-nearest nearer-point + chain))))))))))))))) + +(define-integrable (guarantee-state-space space procedure) + (if (not (state-space? space)) + (error:wrong-type-argument space "state space" procedure))) -(define (state-point/space point) - (let ((next (state-point/nearer-point point))) - (if (positive? (state-point/distance-to-root point)) - (state-point/space next) - next))) +(define-integrable (guarantee-state-point point procedure) + (if (not (state-point? point)) + (error:wrong-type-argument point "state point" procedure))) -(define-primitives - execute-at-new-state-point - translate-to-state-point - set-current-dynamic-state! - (get-fluid-bindings 0) - (set-fluid-bindings! 1)) +(define (current-state-point space) + (guarantee-state-space space current-state-point) + (state-space/nearest-point space)) -(define (make-state-space #!optional mutable?) - ((ucode-primitive make-state-space) - (if (default-object? mutable?) true mutable?))) +(define (execute-at-new-state-point space before during after) + (guarantee-state-space space execute-at-new-state-point) + (%execute-at-new-state-point space before during after)) -(define system-state-space) +(define (translate-to-state-point point) + (guarantee-state-point point translate-to-state-point) + (%translate-to-state-point point)) -(define (current-dynamic-state #!optional state-space) - ((ucode-primitive current-dynamic-state) - (if (default-object? state-space) system-state-space state-space))) +(define (state-point/space point) + (guarantee-state-point point state-point/space) + (let ((interrupt-mask (set-interrupt-enables! interrupt-mask/gc-ok))) + (let loop ((point point)) + (let ((nearer-point (state-point/nearer-point point))) + (if nearer-point + (loop nearer-point) + (begin + (set-interrupt-enables! interrupt-mask) + point)))))) + +(define state-space:global) +(define state-space:local) + +(define (shallow-fluid-bind before during after) + (%execute-at-new-state-point state-space:global before during after)) (define (dynamic-wind before during after) - ;; NOTE: the "before" thunk is executed IN THE NEW STATE, the - ;; "after" thunk is executed IN THE OLD STATE. Your programs should - ;; not depend on this if it can be avoided. - (execute-at-new-state-point system-state-space before during after)) - -(define (object-component-binder get-component set-component!) - (lambda (object new-value thunk) - (let ((old-value)) - (dynamic-wind (lambda () - (set! old-value (get-component object)) - (set-component! object new-value) - (set! new-value false) - unspecific) - thunk - (lambda () - (set! new-value (get-component object)) - (set-component! object old-value) - (set! old-value false) - unspecific))))) \ No newline at end of file + (let ((fluid-bindings (state-space/nearest-point state-space:global))) + (%execute-at-new-state-point + state-space:local + (lambda () + (%translate-to-state-point fluid-bindings) + (before)) + during + (lambda () + (%translate-to-state-point fluid-bindings) + (after))))) + +(define (initialize-package!) + (set! state-space:global (make-state-space)) + (set! state-space:local (make-state-space)) + unspecific) + +(define-structure (dynamic-state (conc-name dynamic-state/)) + (global false read-only true) + (local false read-only true)) + +(define (get-dynamic-state) + (let ((interrupt-mask (set-interrupt-enables! interrupt-mask/gc-ok))) + (let ((state + (make-dynamic-state + (state-space/nearest-point state-space:global) + (state-space/nearest-point state-space:local)))) + (set-interrupt-enables! interrupt-mask) + state))) + +(define (set-dynamic-state! state global-only?) + (if (not (dynamic-state? state)) + (error:wrong-type-argument state "dynamic state" set-dynamic-state!)) + (if (not global-only?) + (%translate-to-state-point (dynamic-state/local state))) + (%translate-to-state-point (dynamic-state/global state))) + +(define (merge-dynamic-state state point) + (let ((space (state-point/space point)) + (global (dynamic-state/global state)) + (local (dynamic-state/local state))) + (cond ((eq? space (state-point/space global)) + (make-dynamic-state point local)) + ((eq? space (state-point/space local)) + (make-dynamic-state global point)) + (else + state)))) \ No newline at end of file diff --git a/v7/src/runtime/wrkdir.scm b/v7/src/runtime/wrkdir.scm index db5fde9ab..483afc94e 100644 --- a/v7/src/runtime/wrkdir.scm +++ b/v7/src/runtime/wrkdir.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/wrkdir.scm,v 14.5 1991/11/26 07:07:31 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/wrkdir.scm,v 14.6 1992/02/08 15:08:47 cph Exp $ -Copyright (c) 1988-91 Massachusetts Institute of Technology +Copyright (c) 1988-92 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -55,31 +55,29 @@ MIT in each case. |# (define (working-directory-pathname) *working-directory-pathname*) -(define (%set-working-directory-pathname! name) +(define (set-working-directory-pathname! name) (let ((pathname (pathname-as-directory (merge-pathnames name *working-directory-pathname*)))) (if (not (file-directory? pathname)) (error "Not a valid directory:" pathname)) (let ((pathname (pathname-simplify pathname))) - (if (eq? *default-pathname-defaults* *working-directory-pathname*) - (set! *default-pathname-defaults* pathname)) (set! *working-directory-pathname* pathname) + (set! *default-pathname-defaults* + (merge-pathnames pathname *default-pathname-defaults*)) ((ucode-primitive set-working-directory-pathname! 1) (->namestring pathname)) + (port/set-default-directory (nearest-cmdl/port) pathname) pathname))) -(define (set-working-directory-pathname! name) - (let ((pathname (%set-working-directory-pathname! name))) - (port/set-default-directory (nearest-cmdl/port) pathname) - pathname)) - (define (with-working-directory-pathname name thunk) - (let ((old-pathname)) - (dynamic-wind (lambda () - (set! old-pathname (working-directory-pathname)) - (%set-working-directory-pathname! name)) - thunk - (lambda () - (set! name (working-directory-pathname)) - (%set-working-directory-pathname! old-pathname))))) \ No newline at end of file + (let ((pathname + (pathname-as-directory + (merge-pathnames name *working-directory-pathname*)))) + (if (not (file-directory? pathname)) + (error "Not a valid directory:" pathname)) + (let ((pathname (pathname-simplify pathname))) + (fluid-let ((*working-directory-pathname* pathname) + (*default-pathname-defaults* + (merge-pathnames pathname *default-pathname-defaults*))) + (thunk))))) \ No newline at end of file diff --git a/v8/src/runtime/conpar.scm b/v8/src/runtime/conpar.scm index 1d702f4f7..9dd3d9a28 100644 --- a/v8/src/runtime/conpar.scm +++ b/v8/src/runtime/conpar.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/conpar.scm,v 14.24 1991/08/27 08:00:17 jinx Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/conpar.scm,v 14.25 1992/02/08 15:08:18 cph Exp $ -Copyright (c) 1988-1991 Massachusetts Institute of Technology +Copyright (c) 1988-92 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -41,7 +41,7 @@ MIT in each case. |# (define-structure (stack-frame (constructor make-stack-frame - (type elements dynamic-state fluid-bindings + (type elements dynamic-state interrupt-mask history previous-history-offset previous-history-control-point @@ -50,7 +50,6 @@ MIT in each case. |# (type false read-only true) (elements false read-only true) (dynamic-state false read-only true) - (fluid-bindings false read-only true) (interrupt-mask false read-only true) (history false read-only true) (previous-history-offset false read-only true) @@ -92,13 +91,6 @@ MIT in each case. |# (stack-frame/skip-non-subproblems stack-frame))) (stack-frame/skip-non-subproblems stack-frame))) -(define (stack-frame/skip-non-subproblems stack-frame) - (if (stack-frame/subproblem? stack-frame) - stack-frame - (let ((stack-frame (stack-frame/next stack-frame))) - (and stack-frame - (stack-frame/skip-non-subproblems stack-frame))))) - (define-integrable (stack-frame/length stack-frame) (vector-length (stack-frame/elements stack-frame))) @@ -117,12 +109,12 @@ MIT in each case. |# (and (interpreter-return-address? return-address) (return-address/code return-address)))) -(define-integrable (stack-frame/subproblem? stack-frame) +(define (stack-frame/subproblem? stack-frame) (stack-frame-type/subproblem? (stack-frame/type stack-frame))) (define-integrable (stack-frame/compiled-code? stack-frame) (compiled-return-address? (stack-frame/return-address stack-frame))) - + (define (stack-frame/resolve-stack-address frame address) (let loop ((frame frame) @@ -131,13 +123,46 @@ MIT in each case. |# (if (< offset length) (values frame offset) (loop (stack-frame/next frame) (- offset length)))))) + +(define (stack-frame/skip-non-subproblems stack-frame) + (let ((type (stack-frame/type stack-frame))) + (cond ((eq? type stack-frame-type/stack-marker) + (let loop ((stack-frame stack-frame)) + (let ((stack-frame (stack-frame/next stack-frame))) + (and stack-frame + (if (stack-frame/subproblem? stack-frame) + (stack-frame/next-subproblem stack-frame) + (loop stack-frame)))))) + ((and (stack-frame/subproblem? stack-frame) + (not (and (eq? type stack-frame-type/compiled-return-address) + (eq? (stack-frame/return-address stack-frame) + continuation-return-address)))) + stack-frame) + (else + (let ((stack-frame (stack-frame/next stack-frame))) + (and stack-frame + (stack-frame/skip-non-subproblems stack-frame))))))) + +(define continuation-return-address) + +(define (initialize-special-frames!) + (set! continuation-return-address + (let ((stack-frame + (call-with-current-continuation + (lambda (k) + k + (call-with-current-continuation + continuation/first-subproblem))))) + (and (eq? (stack-frame/type stack-frame) + stack-frame-type/compiled-return-address) + (stack-frame/return-address stack-frame)))) + unspecific) ;;;; Parser (define-structure (parser-state (constructor make-parser-state) (conc-name parser-state/)) (dynamic-state false read-only true) - (fluid-bindings false read-only true) (interrupt-mask false read-only true) (history false read-only true) (previous-history-offset false read-only true) @@ -150,15 +175,13 @@ MIT in each case. |# (define (continuation->stack-frame continuation) (parse-control-point (continuation/control-point continuation) (continuation/dynamic-state continuation) - (continuation/fluid-bindings continuation) false)) -(define (parse-control-point control-point dynamic-state fluid-bindings type) +(define (parse-control-point control-point dynamic-state type) (let ((element-stream (control-point/element-stream control-point))) (parse-one-frame (make-parser-state dynamic-state - fluid-bindings (control-point/interrupt-mask control-point) (let ((history (history-transform (control-point/history control-point)))) @@ -209,7 +232,6 @@ MIT in each case. |# (parse-control-point control-point (parser-state/dynamic-state state) - (parser-state/fluid-bindings state) (parser-state/previous-type state)))))))) ;;; `make-intermediate-state' is used to construct an intermediate @@ -224,7 +246,6 @@ MIT in each case. |# (- (parser-state/n-elements state) length))) (make-parser-state (parser-state/dynamic-state state) - (parser-state/fluid-bindings state) (parser-state/interrupt-mask state) (parser-state/history state) (let ((previous (parser-state/previous-history-offset state))) @@ -245,7 +266,7 @@ MIT in each case. |# ;;; 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-TO-STATE-POINT changes the `dynamic-state' component. +;;; 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)) @@ -259,7 +280,6 @@ MIT in each case. |# type elements (parser-state/dynamic-state state) - (parser-state/fluid-bindings state) (parser-state/interrupt-mask state) (if history? history @@ -269,7 +289,6 @@ MIT in each case. |# (+ (vector-length elements) n-elements) (parser-state/previous-type state) (make-parser-state (parser-state/dynamic-state state) - (parser-state/fluid-bindings state) (parser-state/interrupt-mask state) (if (or force-pop? history-subproblem?) (history-superproblem history) @@ -307,49 +326,39 @@ MIT in each case. |# (parse/standard-next type elements state valid-history? valid-history?))) -(define (parser/restore-dynamic-state type elements state) - ;; Possible problem: the dynamic state really consists of all of the - ;; state spaces in existence. Probably we should have some - ;; mechanism for keeping track of them all. - (parser/standard - type - elements - (make-parser-state (let ((dynamic-state (vector-ref elements 1))) - (if (eq? system-state-space - (state-point/space dynamic-state)) - dynamic-state - (parser-state/dynamic-state state))) - (parser-state/fluid-bindings state) - (parser-state/interrupt-mask state) - (parser-state/history state) - (parser-state/previous-history-offset state) - (parser-state/previous-history-control-point state) - (parser-state/element-stream state) - (parser-state/n-elements state) - (parser-state/next-control-point state) - (parser-state/previous-type state)))) - -(define (parser/restore-fluid-bindings type elements state) - (parser/standard - type - elements - (make-parser-state (parser-state/dynamic-state state) - (vector-ref elements 1) - (parser-state/interrupt-mask state) - (parser-state/history state) - (parser-state/previous-history-offset state) - (parser-state/previous-history-control-point state) - (parser-state/element-stream state) - (parser-state/n-elements state) - (parser-state/next-control-point state) - (parser-state/previous-type state)))) +(define (parser/stack-marker type elements state) + (let ((marker (vector-ref elements 1)) + (continue + (lambda (dynamic-state interrupt-mask) + (parser/standard + type + elements + (make-parser-state + dynamic-state + interrupt-mask + (parser-state/history state) + (parser-state/previous-history-offset state) + (parser-state/previous-history-control-point state) + (parser-state/element-stream state) + (parser-state/n-elements state) + (parser-state/next-control-point state) + (parser-state/previous-type state)))))) + (cond ((eq? marker %translate-to-state-point) + (continue (merge-dynamic-state (parser-state/dynamic-state state) + (vector-ref elements 2)) + (parser-state/interrupt-mask state))) + ((eq? marker set-interrupt-enables!) + (continue (parser-state/dynamic-state state) + (vector-ref elements 2))) + (else + (continue (parser-state/dynamic-state state) + (parser-state/interrupt-mask state)))))) (define (parser/restore-interrupt-mask type elements state) (parser/standard type elements (make-parser-state (parser-state/dynamic-state state) - (parser-state/fluid-bindings state) (vector-ref elements 1) (parser-state/history state) (parser-state/previous-history-offset state) @@ -364,7 +373,6 @@ MIT in each case. |# type elements (make-parser-state (parser-state/dynamic-state state) - (parser-state/fluid-bindings state) (parser-state/interrupt-mask state) (history-transform (vector-ref elements 1)) (vector-ref elements 2) @@ -379,8 +387,7 @@ MIT in each case. |# (define (stack-frame->continuation stack-frame) (make-continuation 'REENTRANT (stack-frame->control-point stack-frame) - (stack-frame/dynamic-state stack-frame) - (stack-frame/fluid-bindings stack-frame))) + (stack-frame/dynamic-state stack-frame))) (define (stack-frame->control-point stack-frame) (with-values (lambda () (unparse/stack-frame stack-frame)) @@ -439,10 +446,6 @@ MIT in each case. |# offset (+ index 1 (- (object-datum (element-stream/ref stream index)) missing))) -(define (length/repeat-primitive stream offset) - offset - (primitive-procedure-arity (element-stream/ref stream 1))) - (define (length/compiled-return-address stream offset) (let ((entry (element-stream/head stream))) (let ((frame-size (compiled-continuation/next-continuation-offset entry))) @@ -537,6 +540,8 @@ MIT in each case. |# (set! stack-frame-types (make-stack-frame-types)) (set! stack-frame-type/hardware-trap (microcode-return/name->type 'HARDWARE-TRAP)) + (set! stack-frame-type/stack-marker + (microcode-return/name->type 'STACK-MARKER)) (set! stack-frame-type/compiled-return-address (make-stack-frame-type false true false length/compiled-return-address @@ -553,19 +558,20 @@ MIT in each case. |# (make-stack-frame-type false true false 1 parser/standard)) - (set! word-size (let ((initial (system-vector-length (make-bit-string 1 #f)))) (let loop ((size 2)) (if (= (system-vector-length (make-bit-string size #f)) initial) (loop (1+ size)) (-1+ size))))) + (set! continuation-return-address false) unspecific) (define stack-frame-types) (define stack-frame-type/compiled-return-address) (define stack-frame-type/return-to-interpreter) (define stack-frame-type/hardware-trap) +(define stack-frame-type/stack-marker) (define stack-frame-type/interrupt-compiled-procedure) (define stack-frame-type/interrupt-compiled-expression) @@ -607,11 +613,10 @@ MIT in each case. |# parser/standard parser))) - (standard-frame 'RESTORE-TO-STATE-POINT 2 parser/restore-dynamic-state) - (standard-frame 'RESTORE-FLUIDS 2 parser/restore-fluid-bindings) (standard-frame 'RESTORE-INTERRUPT-MASK 2 parser/restore-interrupt-mask) (standard-frame 'RESTORE-HISTORY 4 parser/restore-history) (standard-frame 'RESTORE-DONT-COPY-HISTORY 4 parser/restore-history) + (standard-frame 'STACK-MARKER 3 parser/stack-marker) (standard-frame 'NON-EXISTENT-CONTINUATION 2) (standard-frame 'HALT 2) @@ -643,7 +648,6 @@ MIT in each case. |# (standard-subproblem 'PRIMITIVE-COMBINATION-3-APPLY 4) (standard-subproblem 'MOVE-TO-ADJACENT-POINT 6) (standard-subproblem 'COMBINATION-SAVE-VALUE length/combination-save-value) - (standard-subproblem 'REPEAT-PRIMITIVE length/repeat-primitive) (let ((length (length/application-frame 2 0))) (standard-subproblem 'COMBINATION-APPLY length) diff --git a/v8/src/runtime/framex.scm b/v8/src/runtime/framex.scm index 765d0657b..efa84f524 100644 --- a/v8/src/runtime/framex.scm +++ b/v8/src/runtime/framex.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/framex.scm,v 14.15 1991/06/14 03:02:57 jinx Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/framex.scm,v 14.16 1992/02/08 15:08:24 cph Exp $ -Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology +Copyright (c) 1988-92 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -324,7 +324,6 @@ MIT in each case. |# (let ((method (method/application-frame 3))) (record-method 'INTERNAL-APPLY method) (record-method 'INTERNAL-APPLY-VAL method)) - (record-method 'REPEAT-PRIMITIVE (method/application-frame 1)) (let ((method (method/compiler-reference identity-procedure))) (record-method 'COMPILER-REFERENCE-RESTART method) (record-method 'COMPILER-SAFE-REFERENCE-RESTART method)) diff --git a/v8/src/runtime/global.scm b/v8/src/runtime/global.scm index 99752fbd0..305713bf6 100644 --- a/v8/src/runtime/global.scm +++ b/v8/src/runtime/global.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/global.scm,v 14.34 1991/11/26 07:06:16 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/global.scm,v 14.35 1992/02/08 15:08:26 cph Exp $ -Copyright (c) 1988-91 Massachusetts Institute of Technology +Copyright (c) 1988-92 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -110,17 +110,36 @@ MIT in each case. |# (define-integrable (system-hunk3-cons type cxr0 cxr1 cxr2) (object-new-type type (hunk3-cons cxr0 cxr1 cxr2))) +(define (object-component-binder get-component set-component!) + (lambda (object new-value thunk) + (let ((old-value)) + (shallow-fluid-bind + (lambda () + (set! old-value (get-component object)) + (set-component! object new-value) + (set! new-value false) + unspecific) + thunk + (lambda () + (set! new-value (get-component object)) + (set-component! object old-value) + (set! old-value false) + unspecific))))) + (define (bind-cell-contents! cell new-value thunk) (let ((old-value)) - (dynamic-wind (lambda () - (set! old-value (cell-contents cell)) - (set-cell-contents! cell new-value) - (set! new-value)) - thunk - (lambda () - (set! new-value (cell-contents cell)) - (set-cell-contents! cell old-value) - (set! old-value))))) + (shallow-fluid-bind + (lambda () + (set! old-value (cell-contents cell)) + (set-cell-contents! cell new-value) + (set! new-value) + unspecific) + thunk + (lambda () + (set! new-value (cell-contents cell)) + (set-cell-contents! cell old-value) + (set! old-value) + unspecific)))) (define (values . objects) (lambda (receiver) @@ -138,7 +157,7 @@ MIT in each case. |# (with-output-to-truncated-string max (lambda () (write object))))) - + (define (pa procedure) (if (not (procedure? procedure)) (error "Must be a procedure" procedure)) @@ -153,7 +172,7 @@ MIT in each case. |# ;; Compatibility. (define %pwd pwd) (define %cd cd) - + (define (show-time thunk) (let ((process-start (process-time-clock)) (real-start (real-time-clock))) @@ -210,7 +229,7 @@ MIT in each case. |# (define-integrable (object-pointer? object) (not (object-non-pointer? object))) - + (define (impurify object) (if (and (object-pointer? object) (object-pure? object)) ((ucode-primitive primitive-impurify) object)) @@ -225,7 +244,7 @@ MIT in each case. |# (if (not ((ucode-primitive primitive-fasdump) object filename false)) (error "FASDUMP: Object is too large to be dumped:" object)) (write-string " -- done" port))) - + (define (undefined-value? object) ;; Note: the unparser takes advantage of the fact that objects ;; satisfying this predicate also satisfy: diff --git a/v8/src/runtime/make.scm b/v8/src/runtime/make.scm index c7f301bdd..7fa71ab90 100644 --- a/v8/src/runtime/make.scm +++ b/v8/src/runtime/make.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/make.scm,v 14.32 1992/02/07 19:47:32 jinx Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/make.scm,v 14.33 1992/02/08 15:08:31 cph Exp $ -Copyright (c) 1988-1992 Massachusetts Institute of Technology +Copyright (c) 1988-92 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -348,6 +348,7 @@ MIT in each case. |# (RUNTIME INTERRUPT-HANDLER) (RUNTIME GC-STATISTICS) (RUNTIME REP) + (RUNTIME THREAD) ;; Debugging (RUNTIME COMPILER-INFO) (RUNTIME ADVICE) @@ -362,6 +363,8 @@ MIT in each case. |# ;; Emacs -- last because it grabs the kitchen sink. (RUNTIME EMACS-INTERFACE))) +(package-initialize '(RUNTIME CONTINUATION-PARSER) 'INITIALIZE-SPECIAL-FRAMES!) + (let ((filename (map-filename "site"))) (if (file-exists? filename) (eval (fasload filename #t) system-global-environment))) @@ -397,4 +400,6 @@ MIT in each case. |# ) (package/add-child! system-global-package 'USER user-initial-environment) +(set-keyboard-interrupt-thread! (current-thread)) +(start-thread-timer) (initial-top-level-repl) \ No newline at end of file diff --git a/v8/src/runtime/runtime.pkg b/v8/src/runtime/runtime.pkg index 0f83cc56d..7b0fafafc 100644 --- a/v8/src/runtime/runtime.pkg +++ b/v8/src/runtime/runtime.pkg @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/runtime.pkg,v 14.132 1992/02/04 23:59:37 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/runtime.pkg,v 14.133 1992/02/08 15:08:35 cph Exp $ Copyright (c) 1988-92 Massachusetts Institute of Technology @@ -287,13 +287,14 @@ MIT in each case. |# call-with-current-continuation continuation/control-point continuation/dynamic-state - continuation/fluid-bindings continuation/type continuation? guarantee-continuation make-continuation non-reentrant-call-with-current-continuation - within-continuation)) + within-continuation) + (export (runtime thread) + %within-continuation)) (define-package (runtime continuation-parser) (files "conpar") @@ -316,7 +317,6 @@ MIT in each case. |# stack-frame-type? stack-frame/dynamic-state stack-frame/elements - stack-frame/fluid-bindings stack-frame/interrupt-mask stack-frame/length stack-frame/next @@ -987,8 +987,8 @@ MIT in each case. |# (files "intrpt") (parent ()) (export () - timer-interrupt - with-external-interrupts-handler) + keyboard-interrupt-thread + set-keyboard-interrupt-thread!) (export (runtime emacs-interface) hook/^G-interrupt hook/clean-input/flush-typeahead) @@ -1511,6 +1511,11 @@ MIT in each case. |# channel-write-string-block channel? close-all-open-files + directory-channel-close + directory-channel-open + directory-channel-read + directory-channel-read-matching + directory-channel? file-length file-open-append-channel file-open-input-channel @@ -2078,18 +2083,17 @@ MIT in each case. |# (files "wind") (parent ()) (export () - current-dynamic-state dynamic-wind - execute-at-new-state-point - get-fluid-bindings - make-state-space - object-component-binder - set-current-dynamic-state! - set-fluid-bindings! - translate-to-state-point) + shallow-fluid-bind) + (export (runtime continuation) + get-dynamic-state + set-dynamic-state!) (export (runtime continuation-parser) - state-point/space - system-state-space) + %translate-to-state-point + merge-dynamic-state) + (export (runtime thread) + make-state-space + state-space:local) (initialization (initialize-package!))) (define-package (runtime stream) @@ -2292,4 +2296,39 @@ MIT in each case. |# port/gc-start) (export (runtime emacs-interface) port/read-finish - port/read-start)) \ No newline at end of file + port/read-start)) + +(define-package (runtime thread) + (files "thread") + (parent ()) + (export () + block-thread-events + condition-type:thread-deadlock + condition-type:thread-detached + condition-type:thread-error + create-thread + current-thread + detach-thread + exit-current-thread + join-thread + lock-thread-mutex + make-thread-mutex + other-running-threads? + set-thread-timer-interval! + signal-thread-event + sleep-current-thread + start-thread-timer + stop-thread-timer + suspend-current-thread + thread-continuation + thread-dead? + thread-mutex? + thread-timer-interval + thread? + try-lock-thread-mutex + unblock-thread-events + unlock-thread-mutex + yield-current-thread) + (export (runtime interrupt-handler) + thread-timer-interrupt-handler) + (initialization (initialize-package!))) \ No newline at end of file