From 1a0c81f24b3a76f49466522414063628b7a6bc8c Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Tue, 15 Aug 1989 13:20:46 +0000 Subject: [PATCH] * Implement `entity' data abstraction to manipulate the microcode's data type of that name. Change everything to use it. * Implement new procedure `gc-clean' that interleaves `gc-flip' and `trigger-secondary-gc-daemons!' until everything is reclaimed. Change `disk-save' to use it. Cause this operation to be invoked when running out of memory. * Add secondary GC daemons to clean up debugging info, and to reset `prime-number-stream'. * Extend the procedures `procedure-lambda' and `procedure-environment' to handle compiled procedures by using debugging information if it is available. * Extend all the procedure operations to handle entities. * Change `pp', `pa', and `->environment' to accept any procedure as an argument; previously these only accepted compound procedures. * Change the unsyntaxer to handle compiled expressions by using their debugging source code if it is available. * Change name of `*compiler-info/load-on-demand?*' to `load-debugging-info-on-demand?', and make it be #T by default. * Change `load' to print "loading..." message for source files as well as binary files. These messages are controlled by `load/suppress-loading-message?'. * Change `environment-bound-names' to ignore the binding which is used to hold an environment's package. * Fix bug in `make-null-interpreter-environment' which prevented it from being called more than once. --- v7/src/runtime/contin.scm | 29 ++-- v7/src/runtime/gc.scm | 24 +-- v7/src/runtime/gcdemn.scm | 28 +++- v7/src/runtime/gcnote.scm | 8 +- v7/src/runtime/global.scm | 7 +- v7/src/runtime/infutl.scm | 73 ++++++---- v7/src/runtime/load.scm | 73 +++++----- v7/src/runtime/pp.scm | 27 ++-- v7/src/runtime/rep.scm | 5 +- v7/src/runtime/runtime.pkg | 16 +- v7/src/runtime/savres.scm | 24 +-- v7/src/runtime/stream.scm | 11 +- v7/src/runtime/udata.scm | 126 ++++++++++------ v7/src/runtime/uenvir.scm | 292 ++++++++++++++++++++++++++++++++++++- v7/src/runtime/unsyn.scm | 21 +-- v7/src/runtime/version.scm | 4 +- v8/src/runtime/global.scm | 7 +- v8/src/runtime/infutl.scm | 73 ++++++---- v8/src/runtime/load.scm | 73 +++++----- v8/src/runtime/runtime.pkg | 16 +- v8/src/runtime/uenvir.scm | 292 ++++++++++++++++++++++++++++++++++++- 21 files changed, 961 insertions(+), 268 deletions(-) diff --git a/v7/src/runtime/contin.scm b/v7/src/runtime/contin.scm index 8f984678c..dfb8e3e61 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.3 1989/02/10 23:37:59 jinx Rel $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/contin.scm,v 14.4 1989/08/15 13:19:35 cph Rel $ -Copyright (c) 1988 Massachusetts Institute of Technology +Copyright (c) 1988, 1989 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -76,7 +76,7 @@ MIT in each case. |# (set-fluid-bindings! fluid-bindings) (translate-to-state-point dynamic-state) value)))) - + ;; These two are correctly locked for multiprocessing, but not for ;; multiprocessors. @@ -85,7 +85,8 @@ MIT in each case. |# (if (without-interrupts (lambda () (let ((method (continuation/invocation-method continuation))) - (or (eq? method invocation-method/reentrant) + (if (eq? method invocation-method/reentrant) + true (and (eq? method invocation-method/unused) (begin (set-continuation/invocation-method! @@ -111,8 +112,7 @@ MIT in each case. |# (error "Reentering used continuation" continuation)) (define (make-continuation type control-point dynamic-state fluid-bindings) - (system-pair-cons - (ucode-type entity) + (make-entity (case type ((REENTRANT) invocation-method/reentrant) ((UNUSED) invocation-method/unused) @@ -128,8 +128,10 @@ MIT in each case. |# (else (error "Illegal invocation-method" invocation-method))))) (define (continuation? object) - (and (object-type? (ucode-type entity) object) - (%continuation? (system-pair-cdr object)))) + (and (entity? object) + (if (%continuation? (entity-extra object)) + true + (continuation? (entity-procedure object))))) (define (guarantee-continuation continuation) (if (not (continuation? continuation)) @@ -137,19 +139,20 @@ MIT in each case. |# continuation) (define-integrable (continuation/invocation-method continuation) - (system-pair-car continuation)) + (entity-procedure continuation)) (define-integrable (set-continuation/invocation-method! continuation method) - (system-pair-set-car! continuation method)) + (set-entity-procedure! continuation method)) (define-integrable (continuation/control-point continuation) - (%continuation/control-point (system-pair-cdr continuation))) + (%continuation/control-point (entity-extra continuation))) (define-integrable (continuation/dynamic-state continuation) - (%continuation/dynamic-state (system-pair-cdr continuation))) + (%continuation/dynamic-state (entity-extra continuation))) (define-integrable (continuation/fluid-bindings continuation) - (%continuation/fluid-bindings (system-pair-cdr continuation))) + (%continuation/fluid-bindings (entity-extra continuation))) + (define-structure (%continuation (constructor make-%continuation) (conc-name %continuation/)) (control-point false read-only true) diff --git a/v7/src/runtime/gc.scm b/v7/src/runtime/gc.scm index ae0d2d25a..642779edb 100644 --- a/v7/src/runtime/gc.scm +++ b/v7/src/runtime/gc.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/gc.scm,v 14.3 1989/08/11 02:59:14 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/gc.scm,v 14.4 1989/08/15 13:19:40 cph Exp $ Copyright (c) 1988, 1989 Massachusetts Institute of Technology @@ -117,11 +117,11 @@ MIT in each case. |# unspecific)))))) (define (default/stack-overflow) - (abort "maximum recursion depth exceeded")) + (abort-to-nearest-driver "Aborting!: maximum recursion depth exceeded")) (define (default/hardware-trap escape-code) escape-code - (abort "the hardware trapped")) + (abort-to-nearest-driver "Aborting!: the hardware trapped")) (define pure-space-queue) (define constant-space-queue) @@ -152,19 +152,23 @@ MIT in each case. |# start-value space-remaining false) -(define-integrable (gc-abort-test space-remaining) +(define (gc-abort-test space-remaining) (if (< space-remaining 4096) - (abort "out of memory"))) - -(define (abort message) - (abort-to-nearest-driver (string-append "Aborting!: " message))) + (abort->nearest + (cmdl-message/append + (cmdl-message/standard "Aborting!: out of memory") + ;; Clean up whatever possible to avoid a reoccurrence. + (cmdl-message/active + (lambda () (with-gc-notification! true gc-clean))))))) ;;;; User Primitives (define (set-gc-safety-margin! #!optional safety-margin) (if (not (or (default-object? safety-margin) (not safety-margin))) - (begin (set! default-safety-margin safety-margin) - (gc-flip safety-margin))) default-safety-margin) + (begin + (set! default-safety-margin safety-margin) + (gc-flip safety-margin))) + default-safety-margin) (define (gc-flip #!optional safety-margin) ;; Optionally overrides the GC safety margin for this flip only. diff --git a/v7/src/runtime/gcdemn.scm b/v7/src/runtime/gcdemn.scm index 50036fbf2..5a6daf676 100644 --- a/v7/src/runtime/gcdemn.scm +++ b/v7/src/runtime/gcdemn.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/gcdemn.scm,v 14.2 1988/06/13 11:45:08 cph Rel $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/gcdemn.scm,v 14.3 1989/08/15 13:19:44 cph Rel $ -Copyright (c) 1988 Massachusetts Institute of Technology +Copyright (c) 1988, 1989 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -56,11 +56,27 @@ MIT in each case. |# (define (trigger-daemons daemons . extra-args) (let loop ((daemons daemons)) (if (not (null? daemons)) - (begin (apply (car daemons) extra-args) - (loop (cdr daemons)))))) + (begin + (apply (car daemons) extra-args) + (loop (cdr daemons)))))) (define (add-gc-daemon! daemon) - (set! gc-daemons (cons daemon gc-daemons))) + (set! gc-daemons (cons daemon gc-daemons)) + unspecific) (define (add-secondary-gc-daemon! daemon) - (set! secondary-gc-daemons (cons daemon secondary-gc-daemons))) \ No newline at end of file + (set! secondary-gc-daemons (cons daemon secondary-gc-daemons)) + unspecific) + +(define (gc-clean #!optional threshold) + (let ((threshold + (cond ((default-object? threshold) 100) + ((not (negative? threshold)) threshold) + (else (error "threshold must be non-negative" threshold))))) + (let loop ((previous-free (gc-flip))) + (trigger-secondary-gc-daemons!) + (let ((this-free (gc-flip))) + ;; Don't bother to continue if the savings starts getting small. + (if (<= (- this-free previous-free) threshold) + this-free + (loop this-free)))))) \ No newline at end of file diff --git a/v7/src/runtime/gcnote.scm b/v7/src/runtime/gcnote.scm index 139f203b3..96787642a 100644 --- a/v7/src/runtime/gcnote.scm +++ b/v7/src/runtime/gcnote.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/gcnote.scm,v 14.4 1989/08/03 23:05:29 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/gcnote.scm,v 14.5 1989/08/15 13:19:47 cph Exp $ Copyright (c) 1988, 1989 Massachusetts Institute of Technology @@ -44,6 +44,12 @@ MIT in each case. |# ((eq? current default/record-statistic!) gc-notification) (else (error "Can't grab GC statistics hook"))))) unspecific) + +(define (with-gc-notification! notify? thunk) + (fluid-let ((hook/record-statistic! + (if notify? gc-notification default/record-statistic!))) + (thunk))) + (define (gc-notification statistic) (with-output-to-port (cmdl/output-port (nearest-cmdl)) (lambda () diff --git a/v7/src/runtime/global.scm b/v7/src/runtime/global.scm index b8e8f6123..ccb55c197 100644 --- a/v7/src/runtime/global.scm +++ b/v7/src/runtime/global.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/global.scm,v 14.12 1989/08/12 08:18:06 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/global.scm,v 14.13 1989/08/15 13:19:51 cph Exp $ Copyright (c) 1988, 1989 Massachusetts Institute of Technology @@ -134,8 +134,9 @@ MIT in each case. |# (write object))))) (define (pa procedure) - (if (not (compound-procedure? procedure)) - (error "Must be a compound procedure" procedure)) (pp (unsyntax-lambda-list (procedure-lambda procedure)))) + (if (not (procedure? procedure)) + (error "Must be a procedure" procedure)) + (pp (unsyntax-lambda-list (procedure-lambda procedure)))) (define (pwd) (working-directory-pathname)) diff --git a/v7/src/runtime/infutl.scm b/v7/src/runtime/infutl.scm index 58401a77d..35f2c526b 100644 --- a/v7/src/runtime/infutl.scm +++ b/v7/src/runtime/infutl.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/infutl.scm,v 1.8 1989/08/12 08:18:14 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/infutl.scm,v 1.9 1989/08/15 13:19:54 cph Exp $ -Copyright (c) 1988 Massachusetts Institute of Technology +Copyright (c) 1988, 1989 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -39,7 +39,6 @@ MIT in each case. |# (declare (integrate-external "infstr")) (define (initialize-package!) - (set! blocks-with-memoized-debugging-info (make-population)) (set! special-form-procedure-names `((,lambda-tag:unnamed . LAMBDA) (,lambda-tag:internal-lambda . LAMBDA) @@ -47,7 +46,8 @@ MIT in each case. |# (,lambda-tag:let . LET) (,lambda-tag:fluid-let . FLUID-LET) (,lambda-tag:make-environment . MAKE-ENVIRONMENT))) - unspecific) + (set! blocks-with-memoized-debugging-info (make-population)) + (add-secondary-gc-daemon! discard-debugging-info!)) (define (compiled-code-block/dbg-info block demand-load?) (let ((old-info (compiled-code-block/debugging-info block))) @@ -113,26 +113,31 @@ MIT in each case. |# (let ((dbg-info (compiled-code-block/dbg-info block (if (default-object? demand-load?) - true + load-debugging-info-on-demand? demand-load?)))) (and dbg-info - (discriminate-compiled-entry entry - (lambda () - (vector-binary-search (dbg-info/procedures dbg-info) - < - dbg-procedure/label-offset - offset)) - (lambda () - (vector-binary-search (dbg-info/continuations dbg-info) - < - dbg-continuation/label-offset - offset)) - (lambda () - (let ((expression (dbg-info/expression dbg-info))) - (and (= offset (dbg-expression/label-offset expression)) - expression))) - (lambda () - false)))))) + (let ((find-procedure + (lambda () + (vector-binary-search (dbg-info/procedures dbg-info) + < + dbg-procedure/label-offset + offset)))) + (discriminate-compiled-entry entry + find-procedure + (lambda () + (vector-binary-search (dbg-info/continuations dbg-info) + < + dbg-continuation/label-offset + offset)) (lambda () + (let ((expression (dbg-info/expression dbg-info))) + (if (= offset (dbg-expression/label-offset expression)) + expression + (find-procedure)))) + (lambda () + false))))))) + +(define load-debugging-info-on-demand? + true) (define (compiled-entry/block entry) (if (compiled-closure? entry) @@ -264,18 +269,28 @@ MIT in each case. |# index (loop (1+ index)))))))) - (let ((procedure - (compiled-entry/dbg-object entry *compiler-info/load-on-demand?*))) +(define (compiled-procedure/name entry) (let ((procedure (compiled-entry/dbg-object entry))) (and procedure (let ((name (dbg-procedure/name procedure))) (or (special-form-procedure-name? name) - (symbol->string name))))))(define *compiler-info/load-on-demand?* - false) - - + (symbol->string name)))))) (define (special-form-procedure-name? name) (let ((association (assq name special-form-procedure-names))) (and association (symbol->string (cdr association))))) -(define special-form-procedure-names) entry))) \ No newline at end of file + +(define special-form-procedure-names) + +(define (compiled-procedure/lambda entry) + (let ((procedure (compiled-entry/dbg-object entry))) + (and procedure + (dbg-procedure/source-code procedure)))) + +(define (compiled-expression/scode entry) + (let ((object (compiled-entry/dbg-object entry))) + (or (and (dbg-procedure? object) + (let ((scode (dbg-procedure/source-code object))) + (and scode + (lambda-body scode)))) + entry))) \ No newline at end of file diff --git a/v7/src/runtime/load.scm b/v7/src/runtime/load.scm index d9d96c40d..9277f0057 100644 --- a/v7/src/runtime/load.scm +++ b/v7/src/runtime/load.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/load.scm,v 14.6 1989/08/12 08:18:19 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/load.scm,v 14.7 1989/08/15 13:19:59 cph Exp $ -Copyright (c) 1988 Massachusetts Institute of Technology +Copyright (c) 1988, 1989 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -65,18 +65,9 @@ MIT in each case. |# (define (fasload/internal true-pathname suppress-loading-message?) (let ((value (let ((true-filename (pathname->string true-pathname))) - (let ((do-it - (lambda () - ((ucode-primitive binary-fasload) true-filename)))) - (if suppress-loading-message? - (do-it) - (let ((port (cmdl/output-port (nearest-cmdl)))) - (newline port) - (write-string "FASLoading " port) - (write true-filename port) - (let ((value (do-it))) - (write-string " -- done" port) - value))))))) + (loading-message suppress-loading-message? true-filename + (lambda () + ((ucode-primitive binary-fasload) true-filename)))))) (fasload/update-debugging-info! value true-pathname) value)) @@ -95,6 +86,17 @@ MIT in each case. |# (if truename (load truename user-initial-environment))) unspecific) + +(define (loading-message suppress-loading-message? true-filename do-it) + (if suppress-loading-message? + (do-it) + (let ((port (cmdl/output-port (nearest-cmdl)))) + (newline port) + (write-string "Loading " port) + (write true-filename port) + (let ((value (do-it))) + (write-string " -- done" port) + value)))) ;;; This is careful to do the minimum number of file existence probes ;;; before opening the input file. @@ -144,25 +146,30 @@ MIT in each case. |# (define (load/internal pathname true-pathname environment syntax-table purify? load-noisily?) - (let ((port - (open-input-file/internal pathname (pathname->string true-pathname)))) - (if (= 250 (char->ascii (peek-char port))) - (begin - (close-input-port port) - (scode-eval - (let ((scode - (fasload/internal true-pathname - load/suppress-loading-message?))) - (if purify? (purify scode)) - scode) - (if (eq? environment default-object) - (nearest-repl/environment) - environment))) - (write-stream (eval-stream (read-stream port) environment syntax-table) - (if load-noisily? - (lambda (value) - (hook/repl-write (nearest-repl) value)) - (lambda (value) value false)))))) + (let ((true-filename (pathname->string true-pathname))) + (let ((port (open-input-file/internal pathname true-filename))) + (if (= 250 (char->ascii (peek-char port))) + (begin + (close-input-port port) + (scode-eval + (let ((scode + (fasload/internal true-pathname + load/suppress-loading-message?))) + (if purify? (purify scode)) scode) + (if (eq? environment default-object) + (nearest-repl/environment) + environment))) + (let ((value-stream + (eval-stream (read-stream port) environment syntax-table))) + (if load-noisily? + (write-stream value-stream + (lambda (value) + (hook/repl-write (nearest-repl) value))) + (loading-message load/suppress-loading-message? true-filename + (lambda () + (write-stream value-stream + (lambda (value) value false)))))))))) + (define (find-true-pathname pathname default-types) (or (let ((try (lambda (pathname) diff --git a/v7/src/runtime/pp.scm b/v7/src/runtime/pp.scm index 11cea9f2f..974ccc5cb 100644 --- a/v7/src/runtime/pp.scm +++ b/v7/src/runtime/pp.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/pp.scm,v 14.7 1989/08/07 07:36:48 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/pp.scm,v 14.8 1989/08/15 13:20:02 cph Exp $ Copyright (c) 1988, 1989 Massachusetts Institute of Technology @@ -66,17 +66,20 @@ MIT in each case. |# (not (negative? object)) (unhash object)) object)) - (port (if (default-object? port) (current-output-port) port))) (newline port) - (cond ((named-structure? object) - (pretty-print object port) - (for-each (lambda (element) - (newline port) - (pretty-print element port)) - (named-structure/description object))) - ((compound-procedure? object) - (pretty-print (procedure-lambda object) port)) - (else - (apply pretty-print object port rest))))) + (port (if (default-object? port) (current-output-port) port))) (let ((pretty-print + (lambda (object) (apply pretty-print object port rest)))) + (newline port) + (if (named-structure? object) + (begin + (pretty-print object) + (for-each (lambda (element) + (newline port) + (pretty-print element)) + (named-structure/description object))) + (pretty-print + (or (and (procedure? object) (procedure-lambda object)) + object)))))) + (define (pretty-print object #!optional port as-code?) (let ((port (if (default-object? port) (current-output-port) port))) (if (scode-constant? object) diff --git a/v7/src/runtime/rep.scm b/v7/src/runtime/rep.scm index 6180b78f1..035ff0dbe 100644 --- a/v7/src/runtime/rep.scm +++ b/v7/src/runtime/rep.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/rep.scm,v 14.11 1989/08/07 07:36:52 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/rep.scm,v 14.12 1989/08/15 13:20:07 cph Exp $ Copyright (c) 1988, 1989 Massachusetts Institute of Technology @@ -484,7 +484,8 @@ MIT in each case. |# object) ((package? object) (package/environment object)) - ((compound-procedure? object) (procedure-environment object)) + ((procedure? object) + (procedure-environment object)) ((promise? object) (promise-environment object)) (else diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg index 1bf147954..62310ed8d 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.48 1989/08/12 08:18:31 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/runtime.pkg,v 14.49 1989/08/15 13:20:12 cph Exp $ Copyright (c) 1988, 1989 Massachusetts Institute of Technology @@ -76,6 +76,8 @@ MIT in each case. |# package/system-loader package? system-global-package) + (export (runtime environment) + package-name-tag) (initialization (initialize-package!))) (define-package (runtime) @@ -212,13 +214,15 @@ MIT in each case. |# (files "infstr" "infutl") (parent ()) (export () - *compiler-info/load-on-demand?* compiled-entry/block compiled-entry/dbg-object compiled-entry/filename compiled-entry/offset + compiled-expression/scode compiled-procedure/name - discard-debugging-info!) + compiled-procedure/lambda + discard-debugging-info! + load-debugging-info-on-demand?) (export (runtime load) fasload/update-debugging-info!) (export (runtime debugger-command-loop) special-form-procedure-name?) @@ -421,6 +425,7 @@ MIT in each case. |# (files "uenvir") (parent ()) (export () + compiled-procedure/environment environment-arguments environment-assign! environment-assignable? @@ -571,6 +576,7 @@ MIT in each case. |# (export () add-gc-daemon! add-secondary-gc-daemon! + gc-clean trigger-secondary-gc-daemons!) (initialization (initialize-package!))) @@ -580,7 +586,9 @@ MIT in each case. |# (export () gc-statistic->string print-gc-statistics - toggle-gc-notification!)) + toggle-gc-notification! + with-gc-notification!)) + (define-package (runtime gc-statistics) (files "gcstat") (parent ()) diff --git a/v7/src/runtime/savres.scm b/v7/src/runtime/savres.scm index b67de4ee5..dac527501 100644 --- a/v7/src/runtime/savres.scm +++ b/v7/src/runtime/savres.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/savres.scm,v 14.9 1989/06/09 16:51:40 cph Rel $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/savres.scm,v 14.10 1989/08/15 13:20:21 cph Exp $ Copyright (c) 1988, 1989 Massachusetts Institute of Technology @@ -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) @@ -61,9 +62,7 @@ MIT in each case. |# (let ((identify (if (default-object? identify) world-identification identify)) (time (get-decoded-time))) - (discard-debugging-info!) - (gc-flip) - (trigger-secondary-gc-daemons!) + (gc-clean) (save-image filename (lambda () (set! time-world-saved time) @@ -119,12 +118,15 @@ MIT in each case. |# after-suspend))))) (define (disk-restore #!optional filename) - (if (default-object? filename) - (set! filename - (or ((ucode-primitive reload-band-name)) - (error "DISK-RESTORE: No default band name available")))) - (event-distributor/invoke! event:before-exit) - ((ucode-primitive load-band) (canonicalize-input-filename filename))) + ;; Force order of events -- no need to run event:before-exit if + ;; there's an error here. + (let ((filename + (if (default-object? filename) + (or ((ucode-primitive reload-band-name)) + (error "DISK-RESTORE: No default band name available")) + filename))) + (event-distributor/invoke! event:before-exit) + ((ucode-primitive load-band) (canonicalize-input-filename filename)))) (define world-identification "Scheme") (define time-world-saved) diff --git a/v7/src/runtime/stream.scm b/v7/src/runtime/stream.scm index dac91c94b..ddf29d088 100644 --- a/v7/src/runtime/stream.scm +++ b/v7/src/runtime/stream.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/stream.scm,v 14.3 1989/05/10 08:51:11 jinx Rel $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/stream.scm,v 14.4 1989/08/15 13:20:25 cph Exp $ -Copyright (c) 1988 Massachusetts Institute of Technology +Copyright (c) 1988, 1989 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -145,4 +145,9 @@ MIT in each case. |# (cons-stream (car (stream-car primes)) (loop (stream-cdr primes)))))) (define (initialize-package!) - (set! prime-numbers-stream (make-prime-numbers-stream))) \ No newline at end of file + (let ((reset-primes! + (lambda () + (set! prime-numbers-stream (make-prime-numbers-stream)) + unspecific))) + (reset-primes!) + (add-secondary-gc-daemon! reset-primes!))) \ No newline at end of file diff --git a/v7/src/runtime/udata.scm b/v7/src/runtime/udata.scm index e390fae44..a8fbd3566 100644 --- a/v7/src/runtime/udata.scm +++ b/v7/src/runtime/udata.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/udata.scm,v 14.10 1989/08/03 23:07:15 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/udata.scm,v 14.11 1989/08/15 13:20:30 cph Exp $ Copyright (c) 1988, 1989 Massachusetts Institute of Technology @@ -79,6 +79,10 @@ MIT in each case. |# (define-integrable (stack-address? object) (object-type? (ucode-type stack-environment) object)) +(define (compiled-expression? object) + (and (compiled-code-address? object) + (eq? (compiled-entry-type object) 'COMPILED-EXPRESSION))) + (define (compiled-procedure? object) (and (compiled-code-address? object) (eq? (compiled-entry-type object) 'COMPILED-PROCEDURE))) @@ -149,18 +153,6 @@ MIT in each case. |# ;; 68020 specific -- must be rewritten in compiler interface. ((ucode-primitive primitive-object-set! 3) closure (+ 2 index) value) unspecific) - -;;; These are now pretty useless. - -(define (compiled-procedure-entry procedure) - (if (not (compiled-procedure? procedure)) - (error "Not a compiled procedure" procedure)) - procedure) - -(define (compiled-procedure-environment procedure) - (if (not (compiled-procedure? procedure)) - (error "Not a compiled procedure" procedure)) - '()) ;;;; Compiled Code Blocks @@ -338,43 +330,87 @@ that you cannot just vector-ref into. (define-integrable (compound-procedure-environment procedure) (system-pair-cdr procedure)) + +(define-integrable (make-entity procedure extra) + (system-pair-cons (ucode-type entity) procedure extra)) + +(define-integrable (entity? object) + (object-type? (ucode-type entity) object)) + +(define-integrable (entity-procedure entity) + (system-pair-car entity)) + +(define-integrable (entity-extra entity) + (system-pair-cdr entity)) + +(define-integrable (set-entity-procedure! entity procedure) + (system-pair-set-car! entity procedure) + unspecific) + +(define-integrable (set-entity-extra! entity extra) + (system-pair-set-car! entity extra) + unspecific) (define (procedure? object) (or (compound-procedure? object) (primitive-procedure? object) (compiled-procedure? object) - (and (object-type? (ucode-type entity) object) - (procedure? (system-pair-car object))))) - -(define-integrable (procedure-lambda procedure) - (compound-procedure-lambda (guarantee-compound-procedure procedure))) - -(define-integrable (procedure-environment procedure) - (compound-procedure-environment (guarantee-compound-procedure procedure))) - -(define (procedure-components procedure receiver) - (guarantee-compound-procedure procedure) - (receiver (compound-procedure-lambda procedure) - (compound-procedure-environment procedure))) - -(define (procedure-arity procedure) - (cond ((primitive-procedure? procedure) - (let ((arity (primitive-procedure-arity procedure))) - (if (negative? arity) - (cons 0 false) - (cons arity arity)))) - ((compound-procedure? procedure) - (lambda-components (compound-procedure-lambda procedure) - (lambda (name required optional rest auxiliary decl body) - name auxiliary decl body - (let ((r (length required))) - (cons r - (and (not rest) - (+ r (length optional)))))))) - ((compiled-procedure? procedure) - (compiled-procedure-arity procedure)) - (else - (error "PROCEDURE-ARITY: not a procedure" procedure)))) + (and (entity? object) + (procedure? (entity-procedure object))))) + +(define (discriminate-procedure object if-primitive if-compound if-compiled) + (let loop ((procedure object)) + (cond ((primitive-procedure? procedure) (if-primitive procedure)) + ((compound-procedure? procedure) (if-compound procedure)) + ((compiled-procedure? procedure) (if-compiled procedure)) + ((entity? procedure) (loop (entity-procedure procedure))) + (else (error "Not a procedure" object))))) + +(define (procedure-lambda object) + (discriminate-procedure + object + (lambda (procedure) procedure false) + compound-procedure-lambda + compiled-procedure/lambda)) + +(define (procedure-environment object) + (discriminate-procedure + object + (lambda (procedure) + (error "Primitive procedures have no closing environment" procedure)) + compound-procedure-environment + compiled-procedure/environment)) + +(define (procedure-components object receiver) + (discriminate-procedure + object + (lambda (procedure) + (error "Primitive procedures have no components" procedure)) + (lambda (procedure) + (receiver (compound-procedure-lambda procedure) + (compound-procedure-environment procedure))) + (lambda (procedure) + (receiver (compiled-procedure/lambda procedure) + (compiled-procedure/environment procedure))))) + +(define (procedure-arity object) + (discriminate-procedure + object + (lambda (procedure) + (let ((arity (primitive-procedure-arity procedure))) + (if (negative? arity) + (cons 0 false) + (cons arity arity)))) + (lambda (procedure) + (lambda-components (compound-procedure-lambda procedure) + (lambda (name required optional rest auxiliary decl body) + name auxiliary decl body + (let ((r (length required))) + (cons r + (and (not rest) + (+ r (length optional)))))))) + compiled-procedure-arity)) + (define (procedure-arity-valid? procedure n-arguments) (let ((arity (procedure-arity procedure))) (and (<= (car arity) n-arguments) diff --git a/v7/src/runtime/uenvir.scm b/v7/src/runtime/uenvir.scm index 700f046bd..ef452c6d6 100644 --- a/v7/src/runtime/uenvir.scm +++ b/v7/src/runtime/uenvir.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/uenvir.scm,v 14.11 1989/08/08 02:02:39 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/uenvir.scm,v 14.12 1989/08/15 13:20:35 cph Exp $ Copyright (c) 1988, 1989 Massachusetts Institute of Technology @@ -171,7 +171,7 @@ MIT in each case. |# (define (system-global-environment/bound-names environment) (list-transform-negative (obarray->list (fixed-objects-item 'OBARRAY)) (lambda (symbol) - (lexical-unbound? environment symbol)))) + (unbound-name? environment symbol)))) (define-integrable (ic-environment? object) (object-type? (ucode-type environment) object)) @@ -197,7 +197,12 @@ MIT in each case. |# (environment-extension-aux-list extension) '()))) (lambda (name) - (lexical-unbound? environment name)))) + (unbound-name? environment name)))) + +(define (unbound-name? environment name) + (if (eq? name package-name-tag) + true + (lexical-unbound? environment name))) (define (ic-environment/arguments environment) (lambda-components* (select-lambda (ic-environment->external environment)) @@ -222,8 +227,9 @@ MIT in each case. |# (system-pair-set-cdr! (let ((extension (ic-environment/extension environment))) (if (environment-extension? extension) - (begin (set-environment-extension-parent! extension parent) - (environment-extension-procedure extension)) + (begin + (set-environment-extension-parent! extension parent) + (environment-extension-procedure extension)) extension)) parent)) @@ -234,7 +240,7 @@ MIT in each case. |# (object-new-type (ucode-type null) 1)) (define (make-null-interpreter-environment) - (let ((environment (the-environment))) + (let ((environment (let () (the-environment)))) (ic-environment/remove-parent! environment) environment)) @@ -290,5 +296,275 @@ MIT in each case. |# (guarantee-ic-environment (stack-frame/ref frame index)) default))) (else - (error "Illegal continuation parent" parent))))) - default))) \ No newline at end of file + (error "Illegal continuation parent block" parent))))) + default))) +(define (compiled-procedure/environment entry) + (let ((procedure (compiled-entry/dbg-object entry))) + (if (not procedure) + (error "Unable to obtain closing environment" entry)) + (let ((block (dbg-procedure/block procedure))) + (let ((parent (dbg-block/parent block))) + (case (dbg-block/type parent) + ((CLOSURE) + (make-closure-ccenv (dbg-block/original-parent block) + parent + entry)) + ((IC) + (guarantee-ic-environment + (compiled-code-block/environment + (compiled-code-address->block entry)))) + (else + (error "Illegal procedure parent block" parent))))))) + +(define (stack-ccenv/has-parent? environment) + (dbg-block/parent (stack-ccenv/block environment))) + +(define (stack-ccenv/parent environment) + (let ((block (stack-ccenv/block environment))) + (let ((parent (dbg-block/parent block))) + (case (dbg-block/type parent) + ((STACK) + (let loop + ((block block) + (frame (stack-ccenv/frame environment)) + (index + (+ (stack-ccenv/start-index environment) + (vector-length (dbg-block/layout block))))) + (let ((stack-link (dbg-block/stack-link block))) + (cond ((not stack-link) + (with-values + (lambda () + (stack-frame/resolve-stack-address + frame + (stack-ccenv/static-link environment))) + (lambda (frame index) + (let ((block (dbg-block/parent block))) + (if (eq? block parent) + (make-stack-ccenv parent frame index) + (loop block frame index)))))) + ((eq? stack-link parent) + (make-stack-ccenv parent frame index)) + (else + (loop stack-link frame index)))))) ((CLOSURE) + (make-closure-ccenv (dbg-block/original-parent block) + parent + (stack-ccenv/normal-closure environment))) + ((IC) + (guarantee-ic-environment + (if (dbg-block/static-link-index block) + (stack-ccenv/static-link environment) + (compiled-code-block/environment + (compiled-code-address->block + (stack-frame/return-address + (stack-ccenv/frame environment))))))) + (else + (error "illegal parent block" parent)))))) + +(define (stack-ccenv/lambda environment) + (dbg-block/source-code (stack-ccenv/block environment))) + +(define (stack-ccenv/arguments environment) + (let ((procedure (dbg-block/procedure (stack-ccenv/block environment)))) + (if procedure + (let ((lookup + (lambda (variable) + (if (eq? (dbg-variable/type variable) 'INTEGRATED) + (dbg-variable/value variable) + (stack-ccenv/lookup environment + (dbg-variable/name variable)))))) + (map* (map* (let ((rest (dbg-procedure/rest procedure))) + (if rest (lookup rest) '())) + lookup + (dbg-procedure/optional procedure)) + lookup + (dbg-procedure/required procedure))) + 'UNKNOWN))) + +(define (stack-ccenv/bound-names environment) + (map dbg-variable/name + (list-transform-positive + (vector->list (dbg-block/layout (stack-ccenv/block environment))) + dbg-variable?))) + +(define (stack-ccenv/bound? environment name) + (dbg-block/find-name (stack-ccenv/block environment) name)) + +(define (stack-ccenv/lookup environment name) + (lookup-dbg-variable (stack-ccenv/block environment) + name + (stack-ccenv/get-value environment))) + +(define (stack-ccenv/assignable? environment name) + (assignable-dbg-variable? (stack-ccenv/block environment) name)) + +(define (stack-ccenv/assign! environment name value) + (assign-dbg-variable! (stack-ccenv/block environment) + name + (stack-ccenv/get-value environment) + value)) + +(define (stack-ccenv/get-value environment) + (lambda (index) + (stack-frame/ref (stack-ccenv/frame environment) + (+ (stack-ccenv/start-index environment) index)))) + +(define (stack-ccenv/static-link environment) + (let ((static-link + (stack-frame/ref + (stack-ccenv/frame environment) + (+ (stack-ccenv/start-index environment) + (let ((index + (dbg-block/static-link-index + (stack-ccenv/block environment)))) + (if (not index) + (error "unable to find static link" environment)) + index))))) + (if (not (or (stack-address? static-link) + (interpreter-environment? static-link))) + (error "illegal static link in frame" static-link environment)) + static-link)) + +(define (stack-ccenv/normal-closure environment) + (let ((block (stack-ccenv/block environment))) + (let ((closure + (stack-frame/ref + (stack-ccenv/frame environment) + (+ (stack-ccenv/start-index environment) + (let ((index (dbg-block/normal-closure-index block))) + (if (not index) + (error "unable to find closure" environment)) + index))))) + (if (not (compiled-closure? closure)) + (error "frame missing closure" closure environment)) + (if (not (eq? (compiled-entry/dbg-object closure) + (dbg-block/procedure block))) + (error "wrong closure in frame" closure environment)) closure))) + +(define-structure (closure-ccenv + (named + (string->symbol "#[(runtime environment)closure-ccenv]")) + (conc-name closure-ccenv/)) + (stack-block false read-only true) + (closure-block false read-only true) + (closure false read-only true)) + +(define (closure-ccenv/bound-names environment) + (map dbg-variable/name + (list-transform-positive + (vector->list + (dbg-block/layout (closure-ccenv/stack-block environment))) + (lambda (variable) + (and (dbg-variable? variable) + (closure-ccenv/variable-bound? environment variable)))))) + +(define (closure-ccenv/bound? environment name) + (let ((block (closure-ccenv/stack-block environment))) + (let ((index (dbg-block/find-name block name))) + (and index + (closure-ccenv/variable-bound? + environment + (vector-ref (dbg-block/layout block) index)))))) + +(define (closure-ccenv/variable-bound? environment variable) + (or (eq? (dbg-variable/type variable) 'INTEGRATED) + (vector-find-next-element + (dbg-block/layout (closure-ccenv/closure-block environment)) + variable))) + +(define (closure-ccenv/lookup environment name) + (lookup-dbg-variable (closure-ccenv/closure-block environment) + name + (closure-ccenv/get-value environment))) + +(define (closure-ccenv/assignable? environment name) + (assignable-dbg-variable? (closure-ccenv/closure-block environment) name)) + +(define (closure-ccenv/assign! environment name value) + (assign-dbg-variable! (closure-ccenv/closure-block environment) + name + (closure-ccenv/get-value environment) + value)) + +(define (closure-ccenv/get-value environment) + (lambda (index) + (compiled-closure/ref (closure-ccenv/closure environment) index))) + +(define (closure-ccenv/has-parent? environment) + (let ((stack-block (closure-ccenv/stack-block environment))) + (let ((parent (dbg-block/parent stack-block))) + (and parent + (case (dbg-block/type parent) + ((CLOSURE) (dbg-block/original-parent stack-block)) + ((STACK IC) true) + (else (error "Illegal parent block" parent))))))) + +(define (closure-ccenv/parent environment) + (let ((stack-block (closure-ccenv/stack-block environment)) + (closure-block (closure-ccenv/closure-block environment)) + (closure (closure-ccenv/closure environment))) + (let ((parent (dbg-block/parent stack-block))) + (case (dbg-block/type parent) + ((STACK) + (make-closure-ccenv parent closure-block closure)) + ((CLOSURE) + (make-closure-ccenv (dbg-block/original-parent stack-block) + closure-block + closure)) + ((IC) + (guarantee-ic-environment + (let ((index (dbg-block/ic-parent-index closure-block))) + (if index + (compiled-closure/ref closure index) + (compiled-code-block/environment + (compiled-entry/block closure)))))) + (else + (error "Illegal parent block" parent)))))) + +(define (closure-ccenv/lambda environment) + (dbg-block/source-code (closure-ccenv/stack-block environment))) + +(define (lookup-dbg-variable block name get-value) + (let ((index (dbg-block/find-name block name))) + (let ((variable (vector-ref (dbg-block/layout block) index))) + (case (dbg-variable/type variable) + ((NORMAL) + (get-value index)) + ((CELL) + (let ((value (get-value index))) + (if (not (cell? value)) + (error "Value of variable should be in cell" variable value)) + (cell-contents value))) + ((INTEGRATED) + (dbg-variable/value variable)) + (else + (error "Unknown variable type" variable)))))) + +(define (assignable-dbg-variable? block name) + (eq? 'CELL + (dbg-variable/type + (vector-ref (dbg-block/layout block) + (dbg-block/find-name block name))))) + +(define (assign-dbg-variable! block name get-value value) + (let ((index (dbg-block/find-name block name))) + (let ((variable (vector-ref (dbg-block/layout block) index))) + (case (dbg-variable/type variable) + ((CELL) + (let ((cell (get-value index))) + (if (not (cell? cell)) + (error "Value of variable should be in cell" name cell)) + (set-cell-contents! cell value) + unspecific)) + ((NORMAL INTEGRATED) (error "Variable cannot be side-effected" variable)) + (else + (error "Unknown variable type" variable)))))) + +(define (dbg-block/name block) + (let ((procedure (dbg-block/procedure block))) + (and procedure + (dbg-procedure/name procedure)))) + +(define (dbg-block/source-code block) + (let ((procedure (dbg-block/procedure block))) + (and procedure + (dbg-procedure/source-code procedure)))) \ No newline at end of file diff --git a/v7/src/runtime/unsyn.scm b/v7/src/runtime/unsyn.scm index d5a97cb6a..35c60eb00 100644 --- a/v7/src/runtime/unsyn.scm +++ b/v7/src/runtime/unsyn.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/unsyn.scm,v 14.4 1989/08/04 02:38:19 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/unsyn.scm,v 14.5 1989/08/15 13:20:41 cph Exp $ Copyright (c) 1988, 1989 Massachusetts Institute of Technology @@ -62,8 +62,7 @@ MIT in each case. |# unspecific) (define (unsyntax scode) - (unsyntax-object - (if (compound-procedure? scode) (procedure-lambda scode) scode))) + (unsyntax-object (if (procedure? scode) (procedure-lambda scode) scode))) (define (unsyntax-object object) ((scode-walk unsyntaxer/scode-walker object) object)) @@ -85,9 +84,15 @@ MIT in each case. |# ;;;; Unsyntax Quanta (define (unsyntax-constant object) - (if (or (pair? object) (symbol? object)) - `(QUOTE ,object) - object)) + (cond ((or (pair? object) (symbol? object)) + `(QUOTE ,object)) + ((compiled-expression? object) + (let ((scode (compiled-expression/scode object))) + (if (eq? scode object) + `(SCODE-QUOTE object) + (unsyntax-object scode)))) + (else + object))) (define (unsyntax-QUOTATION quotation) `(SCODE-QUOTE ,(unsyntax-object (quotation-expression quotation)))) @@ -132,9 +137,7 @@ MIT in each case. |# `(UNASSIGNED? ,(unassigned?-name unassigned?))) (define (unsyntax-COMMENT-object comment) - (comment-components comment - (lambda (text expression) - `(COMMENT ,text ,(unsyntax-object expression))))) + (unsyntax-object (comment-expression comment))) (define (unsyntax-DECLARATION-object declaration) (declaration-components declaration (lambda (text expression) diff --git a/v7/src/runtime/version.scm b/v7/src/runtime/version.scm index 337516466..0055eb45b 100644 --- a/v7/src/runtime/version.scm +++ b/v7/src/runtime/version.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/version.scm,v 14.53 1989/08/12 08:17:45 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/version.scm,v 14.54 1989/08/15 13:20:46 cph Exp $ Copyright (c) 1988, 1989 Massachusetts Institute of Technology @@ -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 53)) + (add-identification! "Runtime" 14 54)) (define microcode-system) (define (snarf-microcode-version!) diff --git a/v8/src/runtime/global.scm b/v8/src/runtime/global.scm index a296b0cf7..8d926520d 100644 --- a/v8/src/runtime/global.scm +++ b/v8/src/runtime/global.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/global.scm,v 14.12 1989/08/12 08:18:06 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/global.scm,v 14.13 1989/08/15 13:19:51 cph Exp $ Copyright (c) 1988, 1989 Massachusetts Institute of Technology @@ -134,8 +134,9 @@ MIT in each case. |# (write object))))) (define (pa procedure) - (if (not (compound-procedure? procedure)) - (error "Must be a compound procedure" procedure)) (pp (unsyntax-lambda-list (procedure-lambda procedure)))) + (if (not (procedure? procedure)) + (error "Must be a procedure" procedure)) + (pp (unsyntax-lambda-list (procedure-lambda procedure)))) (define (pwd) (working-directory-pathname)) diff --git a/v8/src/runtime/infutl.scm b/v8/src/runtime/infutl.scm index a6a88a9c2..b6ed3a272 100644 --- a/v8/src/runtime/infutl.scm +++ b/v8/src/runtime/infutl.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/infutl.scm,v 1.8 1989/08/12 08:18:14 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/infutl.scm,v 1.9 1989/08/15 13:19:54 cph Exp $ -Copyright (c) 1988 Massachusetts Institute of Technology +Copyright (c) 1988, 1989 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -39,7 +39,6 @@ MIT in each case. |# (declare (integrate-external "infstr")) (define (initialize-package!) - (set! blocks-with-memoized-debugging-info (make-population)) (set! special-form-procedure-names `((,lambda-tag:unnamed . LAMBDA) (,lambda-tag:internal-lambda . LAMBDA) @@ -47,7 +46,8 @@ MIT in each case. |# (,lambda-tag:let . LET) (,lambda-tag:fluid-let . FLUID-LET) (,lambda-tag:make-environment . MAKE-ENVIRONMENT))) - unspecific) + (set! blocks-with-memoized-debugging-info (make-population)) + (add-secondary-gc-daemon! discard-debugging-info!)) (define (compiled-code-block/dbg-info block demand-load?) (let ((old-info (compiled-code-block/debugging-info block))) @@ -113,26 +113,31 @@ MIT in each case. |# (let ((dbg-info (compiled-code-block/dbg-info block (if (default-object? demand-load?) - true + load-debugging-info-on-demand? demand-load?)))) (and dbg-info - (discriminate-compiled-entry entry - (lambda () - (vector-binary-search (dbg-info/procedures dbg-info) - < - dbg-procedure/label-offset - offset)) - (lambda () - (vector-binary-search (dbg-info/continuations dbg-info) - < - dbg-continuation/label-offset - offset)) - (lambda () - (let ((expression (dbg-info/expression dbg-info))) - (and (= offset (dbg-expression/label-offset expression)) - expression))) - (lambda () - false)))))) + (let ((find-procedure + (lambda () + (vector-binary-search (dbg-info/procedures dbg-info) + < + dbg-procedure/label-offset + offset)))) + (discriminate-compiled-entry entry + find-procedure + (lambda () + (vector-binary-search (dbg-info/continuations dbg-info) + < + dbg-continuation/label-offset + offset)) (lambda () + (let ((expression (dbg-info/expression dbg-info))) + (if (= offset (dbg-expression/label-offset expression)) + expression + (find-procedure)))) + (lambda () + false))))))) + +(define load-debugging-info-on-demand? + true) (define (compiled-entry/block entry) (if (compiled-closure? entry) @@ -264,18 +269,28 @@ MIT in each case. |# index (loop (1+ index)))))))) - (let ((procedure - (compiled-entry/dbg-object entry *compiler-info/load-on-demand?*))) +(define (compiled-procedure/name entry) (let ((procedure (compiled-entry/dbg-object entry))) (and procedure (let ((name (dbg-procedure/name procedure))) (or (special-form-procedure-name? name) - (symbol->string name))))))(define *compiler-info/load-on-demand?* - false) - - + (symbol->string name)))))) (define (special-form-procedure-name? name) (let ((association (assq name special-form-procedure-names))) (and association (symbol->string (cdr association))))) -(define special-form-procedure-names) entry))) \ No newline at end of file + +(define special-form-procedure-names) + +(define (compiled-procedure/lambda entry) + (let ((procedure (compiled-entry/dbg-object entry))) + (and procedure + (dbg-procedure/source-code procedure)))) + +(define (compiled-expression/scode entry) + (let ((object (compiled-entry/dbg-object entry))) + (or (and (dbg-procedure? object) + (let ((scode (dbg-procedure/source-code object))) + (and scode + (lambda-body scode)))) + entry))) \ No newline at end of file diff --git a/v8/src/runtime/load.scm b/v8/src/runtime/load.scm index f82ad9a68..778a2a259 100644 --- a/v8/src/runtime/load.scm +++ b/v8/src/runtime/load.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/load.scm,v 14.6 1989/08/12 08:18:19 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/load.scm,v 14.7 1989/08/15 13:19:59 cph Exp $ -Copyright (c) 1988 Massachusetts Institute of Technology +Copyright (c) 1988, 1989 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -65,18 +65,9 @@ MIT in each case. |# (define (fasload/internal true-pathname suppress-loading-message?) (let ((value (let ((true-filename (pathname->string true-pathname))) - (let ((do-it - (lambda () - ((ucode-primitive binary-fasload) true-filename)))) - (if suppress-loading-message? - (do-it) - (let ((port (cmdl/output-port (nearest-cmdl)))) - (newline port) - (write-string "FASLoading " port) - (write true-filename port) - (let ((value (do-it))) - (write-string " -- done" port) - value))))))) + (loading-message suppress-loading-message? true-filename + (lambda () + ((ucode-primitive binary-fasload) true-filename)))))) (fasload/update-debugging-info! value true-pathname) value)) @@ -95,6 +86,17 @@ MIT in each case. |# (if truename (load truename user-initial-environment))) unspecific) + +(define (loading-message suppress-loading-message? true-filename do-it) + (if suppress-loading-message? + (do-it) + (let ((port (cmdl/output-port (nearest-cmdl)))) + (newline port) + (write-string "Loading " port) + (write true-filename port) + (let ((value (do-it))) + (write-string " -- done" port) + value)))) ;;; This is careful to do the minimum number of file existence probes ;;; before opening the input file. @@ -144,25 +146,30 @@ MIT in each case. |# (define (load/internal pathname true-pathname environment syntax-table purify? load-noisily?) - (let ((port - (open-input-file/internal pathname (pathname->string true-pathname)))) - (if (= 250 (char->ascii (peek-char port))) - (begin - (close-input-port port) - (scode-eval - (let ((scode - (fasload/internal true-pathname - load/suppress-loading-message?))) - (if purify? (purify scode)) - scode) - (if (eq? environment default-object) - (nearest-repl/environment) - environment))) - (write-stream (eval-stream (read-stream port) environment syntax-table) - (if load-noisily? - (lambda (value) - (hook/repl-write (nearest-repl) value)) - (lambda (value) value false)))))) + (let ((true-filename (pathname->string true-pathname))) + (let ((port (open-input-file/internal pathname true-filename))) + (if (= 250 (char->ascii (peek-char port))) + (begin + (close-input-port port) + (scode-eval + (let ((scode + (fasload/internal true-pathname + load/suppress-loading-message?))) + (if purify? (purify scode)) scode) + (if (eq? environment default-object) + (nearest-repl/environment) + environment))) + (let ((value-stream + (eval-stream (read-stream port) environment syntax-table))) + (if load-noisily? + (write-stream value-stream + (lambda (value) + (hook/repl-write (nearest-repl) value))) + (loading-message load/suppress-loading-message? true-filename + (lambda () + (write-stream value-stream + (lambda (value) value false)))))))))) + (define (find-true-pathname pathname default-types) (or (let ((try (lambda (pathname) diff --git a/v8/src/runtime/runtime.pkg b/v8/src/runtime/runtime.pkg index 7e92cc2b2..064e1404d 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.48 1989/08/12 08:18:31 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/runtime.pkg,v 14.49 1989/08/15 13:20:12 cph Exp $ Copyright (c) 1988, 1989 Massachusetts Institute of Technology @@ -76,6 +76,8 @@ MIT in each case. |# package/system-loader package? system-global-package) + (export (runtime environment) + package-name-tag) (initialization (initialize-package!))) (define-package (runtime) @@ -212,13 +214,15 @@ MIT in each case. |# (files "infstr" "infutl") (parent ()) (export () - *compiler-info/load-on-demand?* compiled-entry/block compiled-entry/dbg-object compiled-entry/filename compiled-entry/offset + compiled-expression/scode compiled-procedure/name - discard-debugging-info!) + compiled-procedure/lambda + discard-debugging-info! + load-debugging-info-on-demand?) (export (runtime load) fasload/update-debugging-info!) (export (runtime debugger-command-loop) special-form-procedure-name?) @@ -421,6 +425,7 @@ MIT in each case. |# (files "uenvir") (parent ()) (export () + compiled-procedure/environment environment-arguments environment-assign! environment-assignable? @@ -571,6 +576,7 @@ MIT in each case. |# (export () add-gc-daemon! add-secondary-gc-daemon! + gc-clean trigger-secondary-gc-daemons!) (initialization (initialize-package!))) @@ -580,7 +586,9 @@ MIT in each case. |# (export () gc-statistic->string print-gc-statistics - toggle-gc-notification!)) + toggle-gc-notification! + with-gc-notification!)) + (define-package (runtime gc-statistics) (files "gcstat") (parent ()) diff --git a/v8/src/runtime/uenvir.scm b/v8/src/runtime/uenvir.scm index 37f209317..a1290a579 100644 --- a/v8/src/runtime/uenvir.scm +++ b/v8/src/runtime/uenvir.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/uenvir.scm,v 14.11 1989/08/08 02:02:39 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/uenvir.scm,v 14.12 1989/08/15 13:20:35 cph Exp $ Copyright (c) 1988, 1989 Massachusetts Institute of Technology @@ -171,7 +171,7 @@ MIT in each case. |# (define (system-global-environment/bound-names environment) (list-transform-negative (obarray->list (fixed-objects-item 'OBARRAY)) (lambda (symbol) - (lexical-unbound? environment symbol)))) + (unbound-name? environment symbol)))) (define-integrable (ic-environment? object) (object-type? (ucode-type environment) object)) @@ -197,7 +197,12 @@ MIT in each case. |# (environment-extension-aux-list extension) '()))) (lambda (name) - (lexical-unbound? environment name)))) + (unbound-name? environment name)))) + +(define (unbound-name? environment name) + (if (eq? name package-name-tag) + true + (lexical-unbound? environment name))) (define (ic-environment/arguments environment) (lambda-components* (select-lambda (ic-environment->external environment)) @@ -222,8 +227,9 @@ MIT in each case. |# (system-pair-set-cdr! (let ((extension (ic-environment/extension environment))) (if (environment-extension? extension) - (begin (set-environment-extension-parent! extension parent) - (environment-extension-procedure extension)) + (begin + (set-environment-extension-parent! extension parent) + (environment-extension-procedure extension)) extension)) parent)) @@ -234,7 +240,7 @@ MIT in each case. |# (object-new-type (ucode-type null) 1)) (define (make-null-interpreter-environment) - (let ((environment (the-environment))) + (let ((environment (let () (the-environment)))) (ic-environment/remove-parent! environment) environment)) @@ -290,5 +296,275 @@ MIT in each case. |# (guarantee-ic-environment (stack-frame/ref frame index)) default))) (else - (error "Illegal continuation parent" parent))))) - default))) \ No newline at end of file + (error "Illegal continuation parent block" parent))))) + default))) +(define (compiled-procedure/environment entry) + (let ((procedure (compiled-entry/dbg-object entry))) + (if (not procedure) + (error "Unable to obtain closing environment" entry)) + (let ((block (dbg-procedure/block procedure))) + (let ((parent (dbg-block/parent block))) + (case (dbg-block/type parent) + ((CLOSURE) + (make-closure-ccenv (dbg-block/original-parent block) + parent + entry)) + ((IC) + (guarantee-ic-environment + (compiled-code-block/environment + (compiled-code-address->block entry)))) + (else + (error "Illegal procedure parent block" parent))))))) + +(define (stack-ccenv/has-parent? environment) + (dbg-block/parent (stack-ccenv/block environment))) + +(define (stack-ccenv/parent environment) + (let ((block (stack-ccenv/block environment))) + (let ((parent (dbg-block/parent block))) + (case (dbg-block/type parent) + ((STACK) + (let loop + ((block block) + (frame (stack-ccenv/frame environment)) + (index + (+ (stack-ccenv/start-index environment) + (vector-length (dbg-block/layout block))))) + (let ((stack-link (dbg-block/stack-link block))) + (cond ((not stack-link) + (with-values + (lambda () + (stack-frame/resolve-stack-address + frame + (stack-ccenv/static-link environment))) + (lambda (frame index) + (let ((block (dbg-block/parent block))) + (if (eq? block parent) + (make-stack-ccenv parent frame index) + (loop block frame index)))))) + ((eq? stack-link parent) + (make-stack-ccenv parent frame index)) + (else + (loop stack-link frame index)))))) ((CLOSURE) + (make-closure-ccenv (dbg-block/original-parent block) + parent + (stack-ccenv/normal-closure environment))) + ((IC) + (guarantee-ic-environment + (if (dbg-block/static-link-index block) + (stack-ccenv/static-link environment) + (compiled-code-block/environment + (compiled-code-address->block + (stack-frame/return-address + (stack-ccenv/frame environment))))))) + (else + (error "illegal parent block" parent)))))) + +(define (stack-ccenv/lambda environment) + (dbg-block/source-code (stack-ccenv/block environment))) + +(define (stack-ccenv/arguments environment) + (let ((procedure (dbg-block/procedure (stack-ccenv/block environment)))) + (if procedure + (let ((lookup + (lambda (variable) + (if (eq? (dbg-variable/type variable) 'INTEGRATED) + (dbg-variable/value variable) + (stack-ccenv/lookup environment + (dbg-variable/name variable)))))) + (map* (map* (let ((rest (dbg-procedure/rest procedure))) + (if rest (lookup rest) '())) + lookup + (dbg-procedure/optional procedure)) + lookup + (dbg-procedure/required procedure))) + 'UNKNOWN))) + +(define (stack-ccenv/bound-names environment) + (map dbg-variable/name + (list-transform-positive + (vector->list (dbg-block/layout (stack-ccenv/block environment))) + dbg-variable?))) + +(define (stack-ccenv/bound? environment name) + (dbg-block/find-name (stack-ccenv/block environment) name)) + +(define (stack-ccenv/lookup environment name) + (lookup-dbg-variable (stack-ccenv/block environment) + name + (stack-ccenv/get-value environment))) + +(define (stack-ccenv/assignable? environment name) + (assignable-dbg-variable? (stack-ccenv/block environment) name)) + +(define (stack-ccenv/assign! environment name value) + (assign-dbg-variable! (stack-ccenv/block environment) + name + (stack-ccenv/get-value environment) + value)) + +(define (stack-ccenv/get-value environment) + (lambda (index) + (stack-frame/ref (stack-ccenv/frame environment) + (+ (stack-ccenv/start-index environment) index)))) + +(define (stack-ccenv/static-link environment) + (let ((static-link + (stack-frame/ref + (stack-ccenv/frame environment) + (+ (stack-ccenv/start-index environment) + (let ((index + (dbg-block/static-link-index + (stack-ccenv/block environment)))) + (if (not index) + (error "unable to find static link" environment)) + index))))) + (if (not (or (stack-address? static-link) + (interpreter-environment? static-link))) + (error "illegal static link in frame" static-link environment)) + static-link)) + +(define (stack-ccenv/normal-closure environment) + (let ((block (stack-ccenv/block environment))) + (let ((closure + (stack-frame/ref + (stack-ccenv/frame environment) + (+ (stack-ccenv/start-index environment) + (let ((index (dbg-block/normal-closure-index block))) + (if (not index) + (error "unable to find closure" environment)) + index))))) + (if (not (compiled-closure? closure)) + (error "frame missing closure" closure environment)) + (if (not (eq? (compiled-entry/dbg-object closure) + (dbg-block/procedure block))) + (error "wrong closure in frame" closure environment)) closure))) + +(define-structure (closure-ccenv + (named + (string->symbol "#[(runtime environment)closure-ccenv]")) + (conc-name closure-ccenv/)) + (stack-block false read-only true) + (closure-block false read-only true) + (closure false read-only true)) + +(define (closure-ccenv/bound-names environment) + (map dbg-variable/name + (list-transform-positive + (vector->list + (dbg-block/layout (closure-ccenv/stack-block environment))) + (lambda (variable) + (and (dbg-variable? variable) + (closure-ccenv/variable-bound? environment variable)))))) + +(define (closure-ccenv/bound? environment name) + (let ((block (closure-ccenv/stack-block environment))) + (let ((index (dbg-block/find-name block name))) + (and index + (closure-ccenv/variable-bound? + environment + (vector-ref (dbg-block/layout block) index)))))) + +(define (closure-ccenv/variable-bound? environment variable) + (or (eq? (dbg-variable/type variable) 'INTEGRATED) + (vector-find-next-element + (dbg-block/layout (closure-ccenv/closure-block environment)) + variable))) + +(define (closure-ccenv/lookup environment name) + (lookup-dbg-variable (closure-ccenv/closure-block environment) + name + (closure-ccenv/get-value environment))) + +(define (closure-ccenv/assignable? environment name) + (assignable-dbg-variable? (closure-ccenv/closure-block environment) name)) + +(define (closure-ccenv/assign! environment name value) + (assign-dbg-variable! (closure-ccenv/closure-block environment) + name + (closure-ccenv/get-value environment) + value)) + +(define (closure-ccenv/get-value environment) + (lambda (index) + (compiled-closure/ref (closure-ccenv/closure environment) index))) + +(define (closure-ccenv/has-parent? environment) + (let ((stack-block (closure-ccenv/stack-block environment))) + (let ((parent (dbg-block/parent stack-block))) + (and parent + (case (dbg-block/type parent) + ((CLOSURE) (dbg-block/original-parent stack-block)) + ((STACK IC) true) + (else (error "Illegal parent block" parent))))))) + +(define (closure-ccenv/parent environment) + (let ((stack-block (closure-ccenv/stack-block environment)) + (closure-block (closure-ccenv/closure-block environment)) + (closure (closure-ccenv/closure environment))) + (let ((parent (dbg-block/parent stack-block))) + (case (dbg-block/type parent) + ((STACK) + (make-closure-ccenv parent closure-block closure)) + ((CLOSURE) + (make-closure-ccenv (dbg-block/original-parent stack-block) + closure-block + closure)) + ((IC) + (guarantee-ic-environment + (let ((index (dbg-block/ic-parent-index closure-block))) + (if index + (compiled-closure/ref closure index) + (compiled-code-block/environment + (compiled-entry/block closure)))))) + (else + (error "Illegal parent block" parent)))))) + +(define (closure-ccenv/lambda environment) + (dbg-block/source-code (closure-ccenv/stack-block environment))) + +(define (lookup-dbg-variable block name get-value) + (let ((index (dbg-block/find-name block name))) + (let ((variable (vector-ref (dbg-block/layout block) index))) + (case (dbg-variable/type variable) + ((NORMAL) + (get-value index)) + ((CELL) + (let ((value (get-value index))) + (if (not (cell? value)) + (error "Value of variable should be in cell" variable value)) + (cell-contents value))) + ((INTEGRATED) + (dbg-variable/value variable)) + (else + (error "Unknown variable type" variable)))))) + +(define (assignable-dbg-variable? block name) + (eq? 'CELL + (dbg-variable/type + (vector-ref (dbg-block/layout block) + (dbg-block/find-name block name))))) + +(define (assign-dbg-variable! block name get-value value) + (let ((index (dbg-block/find-name block name))) + (let ((variable (vector-ref (dbg-block/layout block) index))) + (case (dbg-variable/type variable) + ((CELL) + (let ((cell (get-value index))) + (if (not (cell? cell)) + (error "Value of variable should be in cell" name cell)) + (set-cell-contents! cell value) + unspecific)) + ((NORMAL INTEGRATED) (error "Variable cannot be side-effected" variable)) + (else + (error "Unknown variable type" variable)))))) + +(define (dbg-block/name block) + (let ((procedure (dbg-block/procedure block))) + (and procedure + (dbg-procedure/name procedure)))) + +(define (dbg-block/source-code block) + (let ((procedure (dbg-block/procedure block))) + (and procedure + (dbg-procedure/source-code procedure)))) \ No newline at end of file -- 2.25.1