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.
#| -*-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
(set-fluid-bindings! fluid-bindings)
(translate-to-state-point dynamic-state)
value))))
-\f
+
;; These two are correctly locked for multiprocessing, but not for
;; multiprocessors.
(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!
(error "Reentering used continuation" continuation))
\f
(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)
(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))
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)
#| -*-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
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"))
\f
(define pure-space-queue)
(define constant-space-queue)
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)))))))
\f
;;;; 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.
#| -*-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
(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
#| -*-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
((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 ()
#| -*-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
(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))
#| -*-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
(declare (integrate-external "infstr"))
\f
(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)
(,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)))
(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)
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
#| -*-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
(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))
(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))))
\f
;;; This is careful to do the minimum number of file existence probes
;;; before opening the input file.
(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))))))\f
+ (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))))))))))
+\f
(define (find-true-pathname pathname default-types)
(or (let ((try
(lambda (pathname)
#| -*-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
(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)
#| -*-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
object)
((package? object)
(package/environment object))
- ((compound-procedure? object) (procedure-environment object))
+ ((procedure? object)
+ (procedure-environment object))
((promise? object)
(promise-environment object))
(else
#| -*-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
package/system-loader
package?
system-global-package)
+ (export (runtime environment)
+ package-name-tag)
(initialization (initialize-package!)))
(define-package (runtime)
(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?)
(files "uenvir")
(parent ())
(export ()
+ compiled-procedure/environment
environment-arguments
environment-assign!
environment-assignable?
(export ()
add-gc-daemon!
add-secondary-gc-daemon!
+ gc-clean
trigger-secondary-gc-daemons!)
(initialization (initialize-package!)))
(export ()
gc-statistic->string
print-gc-statistics
- toggle-gc-notification!))
+ toggle-gc-notification!
+ with-gc-notification!))
+
(define-package (runtime gc-statistics)
(files "gcstat")
(parent ())
#| -*-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
(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)
(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)
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)))\f
+ ;; 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))))\f
(define world-identification "Scheme")
(define time-world-saved)
#| -*-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
(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
#| -*-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
(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)))
;; 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))
- '())
\f
;;;; Compiled Code Blocks
(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)
\f
(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)
#| -*-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
(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))
(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)))
\f
(define (ic-environment/arguments environment)
(lambda-components* (select-lambda (ic-environment->external environment))
(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))
(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))
(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)))))))
+\f
+(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))))))
+\f
+(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))
+\f
+(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)))
+\f
+(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))
+\f
+(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)))
+\f
+(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
#| -*-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
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))
;;;; 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))))
`(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)
#| -*-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
'()))
(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!)
#| -*-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
(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))
#| -*-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
(declare (integrate-external "infstr"))
\f
(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)
(,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)))
(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)
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
#| -*-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
(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))
(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))))
\f
;;; This is careful to do the minimum number of file existence probes
;;; before opening the input file.
(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))))))\f
+ (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))))))))))
+\f
(define (find-true-pathname pathname default-types)
(or (let ((try
(lambda (pathname)
#| -*-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
package/system-loader
package?
system-global-package)
+ (export (runtime environment)
+ package-name-tag)
(initialization (initialize-package!)))
(define-package (runtime)
(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?)
(files "uenvir")
(parent ())
(export ()
+ compiled-procedure/environment
environment-arguments
environment-assign!
environment-assignable?
(export ()
add-gc-daemon!
add-secondary-gc-daemon!
+ gc-clean
trigger-secondary-gc-daemons!)
(initialization (initialize-package!)))
(export ()
gc-statistic->string
print-gc-statistics
- toggle-gc-notification!))
+ toggle-gc-notification!
+ with-gc-notification!))
+
(define-package (runtime gc-statistics)
(files "gcstat")
(parent ())
#| -*-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
(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))
(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)))
\f
(define (ic-environment/arguments environment)
(lambda-components* (select-lambda (ic-environment->external environment))
(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))
(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))
(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)))))))
+\f
+(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))))))
+\f
+(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))
+\f
+(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)))
+\f
+(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))
+\f
+(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)))
+\f
+(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
projects / mit-scheme.git / commitdiff