#| -*-Scheme-*-
-$Id: infstr.scm,v 1.8 1992/12/03 03:18:37 cph Exp $
+$Id: infstr.scm,v 1.9 1995/07/27 20:59:16 adams Exp $
-Copyright (c) 1988-1992 Massachusetts Institute of Technology
+Copyright (c) 1988-1995 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
(declare (usual-integrations))
\f
-(define-integrable (make-dbg-info-vector info-vector)
- (cons dbg-info-vector-tag info-vector))
+;;;; Compiled files
+;;
+;; A COMPILED-MODULE structure is the thing that lives in a .com file.
+;; It contains everything that the system needs to know to load and
+;; execute the file. Note that having a data structure rather than an
+;; scode expression complicates the boot process as make.scm must be
+;; an scode (or compiled) expression. This can be fixed by editing
+;; the make.com file or by -fasl-ing a .bin file that evals the
+;; module's expression.
+
+(define-structure
+ (compiled-module
+ (type vector)
+ (named
+ ((ucode-primitive string->symbol)
+ "#[(runtime compiler-info)compiled-module]"))
+ (conc-name compiled-module/)
+ (constructor make-compiled-module
+ (expression all-compiled-code-blocks
+ dbg-locator purification-root)))
+ (version compiled-module-format:current-version read-only true)
+ (expression false read-only true) ;top level expression of file
+ (all-compiled-code-blocks false) ;in a vector
+ (dbg-locator false) ;how to find debugging info
+ (purification-root false) ;what should be purified?
+ (linkage 'EXECUTE) ;How to link it? (not used yet)
+ (extra false))
+
+(define compiled-module-format:current-version 0)
+(define compiled-module-format:oldest-acceptable-version 0)
+
+;; A compiled code block's debugging-info slot contains one of
+;; (1) A DBG-INFO object.
+;; (1) A pair (dbg-locator . recursive-compilation-number-or-0). This pair
+;; is called a `descriptor' in infutl.scm.
+;; (2) A pair of a (dbg-info . `(2)'), while the dbg info is in core.
+;; (3) something else => no info
+;; All of the compiled code blocks in a compiled file structurally share
+;; the same DBG-LOCATOR which is also accessible from the COMPILED-MODULE.
+
+(define-structure
+ (dbg-locator
+ (type vector)
+ (named
+ ((ucode-primitive string->symbol)
+ "#[(runtime compiler-info)dbg-locator]"))
+ (constructor make-dbg-locator (file timestamp))
+ (conc-name dbg-locator/)
+ (print-procedure
+ (standard-unparser-method 'DBG-LOCATOR
+ (lambda (locator port)
+ (write-char #\space port)
+ (write (->namestring (dbg-locator/file locator)) port)))))
+
+ (file false) ;pathname or canonicalized string
+ (timestamp false read-only true)
+ (status false)) ;for system bookkeeping
+
+
+;; Any debugging information that is fasdumped to a file has a
+;; DBG-WRAPPER around it. The purpose of this is to ensure that
+;; debugging information comes from the same compilation as the
+;; dbg-locator (EQUAL? timestamps), and is in an acceptable format.
+
+(define-structure (dbg-wrapper
+ (type vector)
+ (named
+ ((ucode-primitive string->symbol)
+ "#[(runtime compiler-info)dbg-wrapper]"))
+ (constructor make-dbg-wrapper (objects timestamp))
+ (conc-name dbg-wrapper/))
+ (objects false read-only true) ;a vector indexed by
+ (timestamp false read-only true)
+ (format-version dbg-format:current-version read-only true))
-(define (dbg-info-vector? object)
- (and (pair? object) (eq? (car object) dbg-info-vector-tag)))
-(define-integrable (dbg-info-vector/items info-vector)
- (cdr info-vector))
+;; Change these when the format of any DBG-* object changes, or the path
+;; language is extended.
-(define-integrable dbg-info-vector-tag
- ((ucode-primitive string->symbol)
- "#[(runtime compiler-info)dbg-info-vector-tag]"))
+(define dbg-format:current-version 0)
+(define dbg-format:oldest-acceptable-version 0)
+\f
+;; A DBG-INFO holds the information pertaining to a single compiled code
+;; block.
(define-structure (dbg-info
(type vector)
(expression false read-only true) ;dbg-expression
(procedures false read-only true) ;vector of dbg-procedure
(continuations false read-only true) ;vector of dbg-continuation
- (labels/desc false read-only false) ;vector of dbg-label, sorted by offset
- )
-
-(define (dbg-info/labels dbg-info)
- (let ((labels/desc (dbg-info/labels/desc dbg-info)))
- (if (vector? labels/desc)
- labels/desc
- (let ((labels (read-labels labels/desc)))
- (and labels
- (begin
- (set-dbg-info/labels/desc! dbg-info labels)
- labels))))))
+ ;; vector of dbg-label, sorted by offset, or 'DUMPED-SEPARATELY, or #F if
+ ;; not dumped at all.
+ (labels/desc false read-only false))
(define-structure (dbg-expression
(type vector)
(named
((ucode-primitive string->symbol)
- "#[(runtime compiler-info)dbg-expression]"))
+ "#[(runtime compiler-info)new-dbg-expression]"))
(conc-name dbg-expression/))
- (block false read-only true) ;dbg-block
+ (block false) ;dbg-block
(label false) ;dbg-label
- )
+ (source-code false))
(define-integrable (dbg-expression/label-offset expression)
(dbg-label/offset (dbg-expression/label expression)))
+
(define-structure (dbg-procedure
(type vector)
(named
((ucode-primitive string->symbol)
- "#[(runtime compiler-info)dbg-procedure]"))
- (constructor
- make-dbg-procedure
- (block label type name required optional rest auxiliary
- source-code))
- (conc-name dbg-procedure/))
- (block false read-only true) ;dbg-block
- (label false) ;dbg-label
- (type false read-only true)
- (name false read-only true) ;procedure's name
- (required false read-only true) ;names of required arguments
- (optional false read-only true) ;names of optional arguments
- (rest false read-only true) ;name of rest argument, or #F
- (auxiliary false read-only true) ;names of internal definitions
- (external-label false) ;for closure, external entry
- (source-code false read-only true) ;SCode
- )
+ "#[(runtime compiler-info)new-dbg-procedure]"))
+ (conc-name dbg-procedure/)
+ (constructor make-dbg-procedure (source-code))
+ (constructor %make-dbg-procedure))
+ (block false read-only false)
+ (label false read-only false)
+ (source-code false read-only true))
+
+(define (dbg-procedure/name dbg-procedure)
+ (let ((scode (dbg-procedure/source-code dbg-procedure)))
+ (lambda-name scode)))
(define (dbg-procedure/label-offset procedure)
(dbg-label/offset
- (or (dbg-procedure/external-label procedure)
+ (or ;;(dbg-procedure/external-label procedure)
(dbg-procedure/label procedure))))
(define-integrable (dbg-procedure<? x y)
(type vector)
(named
((ucode-primitive string->symbol)
- "#[(runtime compiler-info)dbg-continuation]"))
+ "#[(runtime compiler-info)new-dbg-continuation]"))
(conc-name dbg-continuation/))
- (block false read-only true) ;dbg-block
+ (block false) ;dbg-block
(label false) ;dbg-label
(type false read-only true)
- (offset false read-only true) ;difference between sp and block
- (source-code false read-only true)
+ (outer false) ; source code
+ (inner false) ; source code
)
(define-integrable (dbg-continuation/label-offset continuation)
(type vector)
(named
((ucode-primitive string->symbol)
- "#[(runtime compiler-info)dbg-block]"))
- (constructor
- make-dbg-block
- (type parent original-parent layout stack-link))
+ "#[(runtime compiler-info)new-dbg-block]"))
+ (constructor make-dbg-block (type parent variables))
(conc-name dbg-block/))
(type false read-only true) ;continuation, stack, closure, ic
(parent false read-only true) ;parent block, or #F
- (original-parent false read-only true) ;for closures, closing block
- (layout false read-only true) ;vector of names, except #F for ic
- (stack-link false read-only true) ;next block on stack, or #F
- (procedure false) ;procedure which this is block of
- )
-
-(define-structure (dbg-variable
- (type vector)
- (named
- ((ucode-primitive string->symbol)
- "#[(runtime compiler-info)dbg-variable]"))
- (conc-name dbg-variable/))
- (name false read-only true) ;symbol
- (type false read-only true) ;normal, cell, integrated
- value ;for integrated, the value
+ (parent-path-prefix false) ;
+ (variables false read-only true) ;vector of variables, except #F for ic
+ (procedure false) ;procedure/entry which this is block of
)
-(let-syntax
- ((dbg-block-name
- (macro (name)
- (let ((symbol (symbol-append 'DBG-BLOCK-NAME/ name)))
- `(DEFINE-INTEGRABLE ,symbol
- ',((ucode-primitive string->symbol)
- (string-append "#[(runtime compiler-info)"
- (string-downcase (symbol->string symbol))
- "]")))))))
- ;; Various names used in `layout' to identify things that wouldn't
- ;; otherwise have names.
- (dbg-block-name dynamic-link)
- (dbg-block-name ic-parent)
- (dbg-block-name normal-closure)
- (dbg-block-name return-address)
- (dbg-block-name static-link))
+;;(define-structure (dbg-variable
+;; (type vector)
+;; (named
+;; ((ucode-primitive string->symbol)
+;; "#[(runtime compiler-info)new-dbg-variable]"))
+;; (conc-name dbg-variable/))
+;; (name false read-only true) ;symbol
+;; (path false read-only true))
+
+;; Pairs are more compact
+(define (dbg-variable? object)
+ (and (pair? object) (symbol? (car object))))
+
+(define-integrable (dbg-variable/make name) (cons name #F))
+(define-integrable (dbg-variable/name var) (car var))
+(define-integrable (dbg-variable/path var) (cdr var))
\f
-(define (dbg-label/name label)
- (cond ((dbg-label-2? label) (dbg-label-2/name label))
- ((dbg-label-1? label) (dbg-label-1/name label))
- (else
- (error:wrong-type-argument label "debugging label" 'DBG-LABEL/NAME))))
+(define-integrable (guarantee-dbg-label object procedure)
+ (if (not (pair? object))
+ (error:wrong-type-argument object "debugging label" procedure)))
+
+(define (make-dbg-label name offset)
+ (cons name offset))
-(define (set-dbg-label/name! label name)
- (cond ((dbg-label-1? label) (set-dbg-label-1/name! label name))
- (else
- (error:wrong-type-argument label "debugging label"
- 'SET-DBG-LABEL/NAME!))))
+(define (dbg-label/name label)
+ (guarantee-dbg-label label 'DBG-LABEL/NAME)
+ (car label))
(define (dbg-label/offset label)
- (cond ((dbg-label-2? label) (dbg-label-2/offset label))
- ((dbg-label-1? label) (dbg-label-1/offset label))
- (else
- (error:wrong-type-argument label "debugging label"
- 'DBG-LABEL/OFFSET))))
+ (guarantee-dbg-label label 'DBG-LABEL/OFFSET)
+ (abs (cdr label)))
(define (dbg-label/external? label)
- (cond ((dbg-label-2? label) (dbg-label-2/external? label))
- ((dbg-label-1? label) (dbg-label-1/external? label))
- (else
- (error:wrong-type-argument label "debugging label"
- 'DBG-LABEL/EXTERNAL?))))
+ (guarantee-dbg-label label DBG-LABEL/EXTERNAL?)
+ (negative? (cdr label)))
(define (set-dbg-label/external?! label external?)
- (cond ((dbg-label-2? label) (set-dbg-label-2/external?! label external?))
- ((dbg-label-1? label) (set-dbg-label-1/external?! label external?))
- (else
- (error:wrong-type-argument label "debugging label"
- 'SET-DBG-LABEL/EXTERNAL?!))))
-
-(define (dbg-label/names label)
- (cond ((dbg-label-2? label) (dbg-label-2/names label))
- ((dbg-label-1? label) (dbg-label-1/names label))
- (else
- (error:wrong-type-argument label "debugging label"
- 'DBG-LABEL/NAMES))))
-
-(define (set-dbg-label/names! label names)
- (cond ((dbg-label-1? label) (set-dbg-label-1/names! label names))
- (else
- (error:wrong-type-argument label "debugging label"
- 'SET-DBG-LABEL/NAMES!))))
-
-(define-structure (dbg-label-1
- (type vector)
- (named
- ((ucode-primitive string->symbol)
- "#[(runtime compiler-info)dbg-label]"))
- (constructor make-dbg-label (name offset))
- (conc-name dbg-label-1/))
- (name false) ;a string, primary name
- (offset false read-only true) ;mach. dependent offset into code block
- (external? false) ;if true, can have pointer to this
- (names (list name)) ;names of all labels at this offset
- )
-
-(define-integrable make-dbg-label-2 cons)
-(define-integrable dbg-label-2? pair?)
-(define-integrable dbg-label-2/name car)
-(define-integrable (dbg-label-2/offset label) (abs (cdr label)))
-(define-integrable (dbg-label-2/external? label) (negative? (cdr label)))
-(define-integrable (dbg-label-2/names label) (list (car label)))
-
-(define (set-dbg-label-2/external?! label external?)
- (let ((offset (cdr label)))
- (if (if external?
- (not (negative? offset))
- (negative? offset))
- (set-cdr! label (- offset))))
+ (guarantee-dbg-label label 'SET-DBG-LABEL/EXTERNAL?!)
+ (let ((offset (abs (cdr label))))
+ (if external?
+ (set-cdr! label (- offset))
+ (set-cdr! label offset)))
unspecific)
\ No newline at end of file
#| -*-Scheme-*-
-$Id: infutl.scm,v 1.58 1995/07/17 20:10:43 adams Exp $
+$Id: infutl.scm,v 1.59 1995/07/27 21:01:09 adams Exp $
-Copyright (c) 1988-94 Massachusetts Institute of Technology
+Copyright (c) 1988-95 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
(,lambda-tag:make-environment . MAKE-ENVIRONMENT)))
(set! blocks-with-memoized-debugging-info (make-population))
(add-secondary-gc-daemon! discard-debugging-info!)
+ (let ((fasload-loader (cached-loader fasload-loader)))
+ (set! inf-load-types
+ `(("inf" . ,fasload-loader)
+ ("bif" . ,fasload-loader)
+ ("bci" . ,(compressed-loader "bif" fasload-loader))))
+ (set! bsm-load-types
+ `(("bsm" . ,fasload-loader)
+ ("bcs" . ,(compressed-loader "bsm" fasload-loader)))))
+ (initialize-cached-files!)
(initialize-uncompressed-files!)
(add-event-receiver! event:after-restore initialize-uncompressed-files!)
(add-event-receiver! event:before-exit delete-uncompressed-files!)
- (add-gc-daemon! clean-uncompressed-files!))
+ (add-gc-daemon! clean-uncompressed-files!)
+ (add-gc-daemon! clean-cached-files!))
+
+(define inf-load-types)
+(define bsm-load-types)
+
+
+(define (compiled-code-block/dbg-descriptor block)
+ (let ((info (compiled-code-block/debugging-info block)))
+ (cond ((valid-dbg-descriptor? info)
+ info)
+ ((dbg-locator? info)
+ (cons info 0))
+ ((not (pair? info))
+ false)
+ ((valid-dbg-descriptor? (cdr info))
+ (cdr info))
+ ((dbg-locator? (cdr info))
+ (cons (cdr info) 0))
+ (else false))))
(define (compiled-code-block/dbg-info block demand-load?)
(let ((old-info (compiled-code-block/debugging-info block)))
((and (pair? old-info) (dbg-info? (car old-info)))
(car old-info))
(demand-load?
- (let ((dbg-info (read-debugging-info old-info)))
+ (let ((dbg-info (read-debugging-info
+ (compiled-code-block/dbg-descriptor block))))
(if dbg-info (memoize-debugging-info! block dbg-info))
dbg-info))
(else
false))))
+(define (compiled-code-block/labels block demand-load?)
+ (let ((info (compiled-code-block/dbg-info block demand-load?)))
+ (and info
+ (let ((labels/desc (dbg-info/labels/desc info)))
+ (if (vector? labels/desc)
+ labels/desc
+ (let ((labels
+ (read-labels (compiled-code-block/dbg-descriptor block))))
+ (and labels
+ (begin
+ (set-dbg-info/labels/desc! info labels)
+ labels))))))))
+
+
(define (discard-debugging-info!)
(without-interrupts
(lambda ()
(set! blocks-with-memoized-debugging-info (make-population))
unspecific)))
+(define (valid-dbg-descriptor? object)
+ (and (pair? object)
+ (dbg-locator? (car object))
+ (index-fixnum? (cdr object))))
+
(define (read-debugging-info descriptor)
- (cond ((string? descriptor)
- (let ((binf (read-binf-file descriptor)))
- (and binf
- (if (dbg-info? binf)
- binf
- (and (vector? binf)
- (not (zero? (vector-length binf)))
- (vector-ref binf 0))))))
- ((and (pair? descriptor)
- (string? (car descriptor))
- (exact-nonnegative-integer? (cdr descriptor)))
- (let ((binf (read-binf-file (car descriptor))))
- (and binf
- (vector? binf)
- (< (cdr descriptor) (vector-length binf))
- (vector-ref binf (cdr descriptor)))))
- (else
- false)))
+ (and (valid-dbg-descriptor? descriptor)
+ (let ((binf (read-dbg-file (car descriptor) inf-load-types)))
+ (select-dbg-info descriptor binf))))
+
+(define (read-labels descriptor)
+ (and (valid-dbg-descriptor? descriptor)
+ (let ((binf (read-dbg-file (car descriptor) bsm-load-types)))
+ (select-dbg-info descriptor binf))))
+
+(define (select-dbg-info descriptor dbg-file-contents)
+ (let ((locator (car descriptor))
+ (index (cdr descriptor)))
+
+ (define (complain message . other-irritants)
+ (if (not (dbg-locator/status locator))
+ (begin
+ (apply warn
+ (string-append "Bad debugging information: " message ":")
+ locator
+ other-irritants)
+ (set-dbg-locator/status! locator 'BAD)))
+ #F)
+
+ (if (dbg-wrapper? dbg-file-contents)
+ (let ((compile-time (dbg-locator/timestamp locator))
+ (dbg-time (dbg-wrapper/timestamp dbg-file-contents))
+ (objects (dbg-wrapper/objects dbg-file-contents))
+ (version (dbg-wrapper/format-version dbg-file-contents)))
+ (cond ((not (equal? compile-time dbg-time))
+ (complain "mismatched timestamps" compile-time dbg-time))
+ ((< version dbg-format:oldest-acceptable-version)
+ (complain "obsolete format version" version))
+ ((> version dbg-format:current-version)
+ (complain "future format version!" version))
+ ((or (not (vector? objects))
+ (>= index (vector-length objects)))
+ (complain "vector problem" index))
+ (else
+ (vector-ref objects index))))
+ (complain "not `wrapped'"))))
+
+(define (read-dbg-file locator load-types)
+ (let ((pathname
+ (canonicalize-debug-info-pathname (dbg-locator/file locator))))
+ (find-alternate-file-type pathname load-types)))
-(define (read-binf-file pathname)
- (let ((pathname (canonicalize-debug-info-pathname pathname)))
- (if (file-exists? pathname)
- (fasload-loader (->namestring pathname))
- (find-alternate-file-type pathname
- `(("inf" . ,fasload-loader)
- ("bif" . ,fasload-loader)
- ("bci" . ,(compressed-loader "bif")))))))
(define (find-alternate-file-type base-pathname alist)
- (let loop ((left alist) (time 0) (file #f) (receiver (lambda (x) x)))
+ (let loop ((left alist) (time 0) (file #f) (receiver (lambda (x t) t x)))
(if (null? left)
- (receiver file)
+ (receiver file time)
(let ((file* (pathname-new-type base-pathname (caar left)))
(receiver* (cdar left)))
(if (not (file-exists? file*))
(find-procedure)))
(lambda ()
(let ((expression (dbg-info/expression dbg-info)))
- (if (= offset (dbg-expression/label-offset expression))
+ (if (and expression
+ (= offset (dbg-expression/label-offset expression)))
expression
(find-procedure))))
(lambda ()
(compiled-entry/offset (compiled-closure->entry entry))
(compiled-code-address->offset entry)))
-(define (compiled-entry/filename entry)
- (compiled-code-block/filename (compiled-entry/block entry)))
+(define (compiled-code-block/filename-and-index block)
+ ;; Values (filename block-number), either may be #F. For the unparser.
+ (let ((descriptor (compiled-code-block/dbg-descriptor block)))
+ (if descriptor
+ (values (canonicalize-debug-info-pathname
+ (dbg-locator/file (car descriptor)))
+ (cdr descriptor))
+ (values false false))))
-(define (compiled-code-block/filename block)
- (let loop ((info (compiled-code-block/debugging-info block)))
- (cond ((string? info) (values (canonicalize-debug-info-filename info) #f))
- ((not (pair? info)) (values false false))
- ((dbg-info? (car info)) (loop (cdr info)))
- ((string? (car info))
- (values (canonicalize-debug-info-filename (car info))
- (and (exact-nonnegative-integer? (cdr info))
- (cdr info))))
- (else (values false false)))))
+(define (compiled-entry/filename-and-index entry)
+ (compiled-code-block/filename-and-index (compiled-entry/block entry)))
(define (dbg-labels/find-offset labels offset)
(vector-binary-search labels < dbg-label/offset offset))
-
-(define (dbg-info-vector/blocks-vector info)
- (let ((items (dbg-info-vector/items info)))
- (cond ((vector? items) items)
- ((and (pair? items)
- (pair? (cdr items))
- (vector? (cadr items)))
- (cadr items))
- (else (error "Illegal dbg-info-vector" info)))))
-
-(define (dbg-info-vector/purification-root info)
- (let ((items (dbg-info-vector/items info)))
- (cond ((vector? items) false)
- ((and (pair? items)
- (eq? (car items) 'COMPILED-BY-PROCEDURES)
- (pair? (cdr items))
- (pair? (cddr items)))
- (caddr items))
- (else (error "Illegal dbg-info-vector" info)))))
\f
(define (fasload/update-debugging-info! value com-pathname)
- (let ((process-block
- (lambda (block)
- (let ((binf-filename
- (process-binf-filename
- (compiled-code-block/debugging-info block)
- com-pathname)))
- (set-compiled-code-block/debugging-info! block binf-filename)
- binf-filename)))
- (process-subblocks
- (lambda (blocks start binf-filename)
- (let ((end (vector-length blocks)))
- (let loop ((index start))
- (if (< index end)
- (begin
- (set-car! (compiled-code-block/debugging-info
- (vector-ref blocks index))
- binf-filename)
- (loop (1+ index)))))))))
-
- (cond ((compiled-code-address? value)
- (let ((binf-filename
- (process-block (compiled-code-address->block value)))
- (blocks (load/purification-root value)))
- (if (vector? blocks)
- (process-subblocks blocks 0 binf-filename))))
- ((and (comment? value)
- (dbg-info-vector? (comment-text value)))
- (let ((blocks (dbg-info-vector/blocks-vector (comment-text value))))
- (process-subblocks blocks
- 1
- (process-block (vector-ref blocks 0))))))))
+ (cond ((or (compiled-code-address? value)
+ (and (comment? value)
+ (compiled-code-address? (comment-expression value))))
+ (warn "Recompile " com-pathname))
+ ((compiled-module? value)
+ (let* ((locator (compiled-module/dbg-locator value))
+ (pathname (dbg-locator/file locator)))
+ (set-dbg-locator/file!
+ locator
+ (process-binf-filename pathname com-pathname))))
+ (else unspecific)))
(define (process-binf-filename binf-filename com-pathname)
(and binf-filename
(pathname-version com-pathname)))
(pathname-new-type com-pathname (pathname-type binf-pathname))
binf-pathname)))))
-\f
+
(define directory-rewriting-rules
'())
(if value
(pathname-as-directory value)
(system-library-directory-pathname "SRC"))))))
-\f
-(define-integrable (dbg-block/layout-first-offset block)
- (let ((layout (dbg-block/layout block)))
- (and (pair? layout) (car layout))))
-
-(define-integrable (dbg-block/layout-vector block)
- (let ((layout (dbg-block/layout block)))
- (if (pair? layout)
- (cdr layout)
- layout)))
-
-(define (dbg-block/dynamic-link-index block)
- (vector-find-next-element (dbg-block/layout-vector block)
- dbg-block-name/dynamic-link))
-
-(define (dbg-block/ic-parent-index block)
- (vector-find-next-element (dbg-block/layout-vector block)
- dbg-block-name/ic-parent))
-
-(define (dbg-block/normal-closure-index block)
- (vector-find-next-element (dbg-block/layout-vector block)
- dbg-block-name/normal-closure))
-
-(define (dbg-block/return-address-index block)
- (vector-find-next-element (dbg-block/layout-vector block)
- dbg-block-name/return-address))
-
-(define (dbg-block/static-link-index block)
- (vector-find-next-element (dbg-block/layout-vector block)
- dbg-block-name/static-link))
-
-(define (dbg-block/find-name block name)
- (let ((layout (dbg-block/layout-vector block)))
+
+(define (dbg-block/find-variable block name)
+ (let ((layout (dbg-block/variables block)))
(let ((end (vector-length layout)))
(let loop ((index 0))
(and (< index end)
- (if (let ((item (vector-ref layout index)))
- (and (dbg-variable? item)
- (eq? name (dbg-variable/name item))))
- index
- (loop (1+ index))))))))
+ (let ((item (vector-ref layout index)))
+ (if (and (dbg-variable? item)
+ (eq? name (dbg-variable/name item)))
+ item
+ (loop (+ index 1)))))))))
(define (compiled-procedure/name entry)
(let ((procedure
(and scode
(lambda-body scode))))
entry)))
-\f
-;;; Support of BSM files
-(define (read-labels descriptor)
- (cond ((string? descriptor)
- (let ((bsm (read-bsm-file descriptor)))
- (and bsm ;; bsm are either vectors of pairs or vectors of vectors
- (if (vector? bsm)
- (let ((first (and (not (zero? (vector-length bsm)))
- (vector-ref bsm 0))))
- (cond ((pair? first) bsm)
- ((vector? first) first)
- (else false)))))))
- ((and (pair? descriptor)
- (string? (car descriptor))
- (exact-nonnegative-integer? (cdr descriptor)))
- (let ((bsm (read-bsm-file (car descriptor))))
- (and bsm
- (vector? bsm)
- (< (cdr descriptor) (vector-length bsm))
- (vector-ref bsm (cdr descriptor)))))
- (else
- false)))
-
-(define (read-bsm-file name)
- (let ((pathname
- (let ((pathname
- (canonicalize-debug-info-pathname
- (rewrite-directory (merge-pathnames name)))))
- (if (file-exists? pathname)
- pathname
- (let loop ((types '("bsm" "bcs")))
- (and (not (null? types))
- (let ((pathname
- (pathname-new-type pathname (car types))))
- (if (file-exists? pathname)
- pathname
- (loop (cdr types))))))))))
- (and pathname
- (if (equal? "bcs" (pathname-type pathname))
- ((compressed-loader "bsm") pathname)
- (fasload-loader pathname)))))
-\f
;;;; Splitting of info structures
(define (inf->bif/bsm inffile)
(inf-structure->bif/bsm binf bifpath bsmpath))))
(define (inf-structure->bif/bsm binf bifpath bsmpath)
+ (error "Needs fixing")
(let ((bifpath (merge-pathnames bifpath))
(bsmpath (and bsmpath (merge-pathnames bsmpath))))
(let ((bsm (split-inf-structure! binf bsmpath)))
(if bsmpath
(fasdump bsm bsmpath true)))))
-(define (split-inf-structure! binf bsmpath)
- (let ((bsmname (and bsmpath (->namestring bsmpath))))
- (cond ((dbg-info? binf)
- (let ((labels (dbg-info/labels/desc binf)))
- (set-dbg-info/labels/desc! binf bsmname)
- labels))
- ((vector? binf)
- (let ((n (vector-length binf)))
- (let ((bsm (make-vector n)))
- (do ((i 0 (fix:+ i 1)))
- ((fix:= i n))
- (let ((dbg-info (vector-ref binf i)))
- (let ((labels (dbg-info/labels/desc dbg-info)))
- (vector-set! bsm i labels)
- (set-dbg-info/labels/desc!
- dbg-info
- (and bsmname (cons bsmname i))))))
- bsm)))
- (else
- (error "Unknown inf format:" binf)))))
-\f
+(define (split-inf-structure! binf replacement)
+ (cond ((vector? binf)
+ (let ((n (vector-length binf)))
+ (let ((bsm (make-vector n)))
+ (do ((i 0 (fix:+ i 1)))
+ ((fix:= i n))
+ (let ((dbg-info (vector-ref binf i)))
+ (let ((labels (dbg-info/labels/desc dbg-info)))
+ (vector-set! bsm i labels)
+ (set-dbg-info/labels/desc! dbg-info replacement))))
+ bsm)))
+ (else
+ (error "Unknown inf format:" binf))))
+
;;;; UNCOMPRESS
;;; A simple extractor for compressed binary info files.
(begin
(string-set! buffer i char)
(loop (fix:1+ i))))))))
+
\f
;; General version.
;;
(literal-command byte)
(copy-command byte)))))))
\f
-(define (fasload-loader filename)
+(define (fasload-without-errors filename)
(call-with-current-continuation
(lambda (if-fail)
(bind-condition-handler (list condition-type:fasload-band)
- (lambda (condition) condition (if-fail false))
+ (lambda (condition) condition (if-fail false))
(lambda () (fasload filename true))))))
-(define (compressed-loader uncompressed-type)
- (lambda (compressed-file)
- (lookup-uncompressed-file compressed-file fasload-loader
- (lambda ()
- (let ((load-compressed
- (lambda (temporary-file)
- (call-with-current-continuation
- (lambda (k)
- (uncompress-internal compressed-file
- temporary-file
- (lambda (message . irritants)
- message irritants
- (k #f)))
- (fasload-loader temporary-file))))))
- (case *save-uncompressed-files?*
- ((#F)
- (call-with-temporary-file-pathname load-compressed))
- ((AUTOMATIC)
- (call-with-uncompressed-file-pathname compressed-file
- load-compressed))
- (else
- (call-with-temporary-file-pathname
- (lambda (temporary-file)
- (let ((result (load-compressed temporary-file))
- (uncompressed-file
- (pathname-new-type compressed-file uncompressed-type)))
- (delete-file-no-errors uncompressed-file)
- (if (call-with-current-continuation
- (lambda (k)
- (bind-condition-handler
- (list condition-type:file-error
- condition-type:port-error)
- (lambda (condition) condition (k #t))
- (lambda ()
- (rename-file temporary-file uncompressed-file)
- #f))))
- (call-with-current-continuation
- (lambda (k)
- (bind-condition-handler
- (list condition-type:file-error
- condition-type:port-error)
- (lambda (condition) condition (k unspecific))
- (lambda ()
- (copy-file temporary-file uncompressed-file))))))
- result))))))))))
+(define (fasload-loader filename file-time)
+ file-time ; ignored
+ (fasload-without-errors filename))
+
+(define (compressed-loader uncompressed-type uncompressed-loader)
+ (lambda (compressed-file compressed-time)
+ (lookup-uncompressed-file
+ compressed-file compressed-time uncompressed-loader
+ (lambda ()
+ (define (load-compressed temporary-file)
+ (call-with-current-continuation
+ (lambda (k)
+ (uncompress-internal compressed-file
+ temporary-file
+ (lambda (message . irritants)
+ message irritants
+ (k #f)))
+ (uncompressed-loader
+ temporary-file
+ (file-modification-time-direct temporary-file)))))
+ (case *save-uncompressed-files?*
+ ((#F)
+ (call-with-temporary-file-pathname load-compressed))
+ ((AUTOMATIC)
+ (call-with-uncompressed-file-pathname compressed-file
+ compressed-time
+ load-compressed))
+ (else
+ (call-with-temporary-file-pathname
+ (lambda (temporary-file)
+ (let ((result (load-compressed temporary-file))
+ (uncompressed-file
+ (pathname-new-type compressed-file uncompressed-type)))
+ (delete-file-no-errors uncompressed-file)
+ (if (call-with-current-continuation
+ (lambda (k)
+ (bind-condition-handler
+ (list condition-type:file-error
+ condition-type:port-error)
+ (lambda (condition) condition (k #t))
+ (lambda ()
+ (rename-file temporary-file uncompressed-file)
+ #f))))
+ (call-with-current-continuation
+ (lambda (k)
+ (bind-condition-handler
+ (list condition-type:file-error
+ condition-type:port-error)
+ (lambda (condition) condition (k unspecific))
+ (lambda ()
+ (copy-file temporary-file uncompressed-file))))))
+ result)))))))))
(define (uncompress-internal ifile ofile if-fail)
(call-with-binary-input-file (merge-pathnames ifile)
(uncompress-ports input output (fix:* (file-length ifile) 2))))
(if-fail "Not a recognized compressed file:" ifile))))))
\f
-(define (lookup-uncompressed-file compressed-file if-found if-not-found)
+(define-structure (file-entry
+ (type vector)
+ (conc-name file-entry/))
+ compressed-name
+ compressed-time
+ uncompressed-name
+ uncompressed-time
+ last-use-time)
+
+(define (lookup-uncompressed-file compressed-file compressed-time
+ if-found if-not-found)
(dynamic-wind
(lambda ()
(set-car! uncompressed-files (+ (car uncompressed-files) 1)))
(lambda ()
(let loop ((entries (cdr uncompressed-files)))
- (cond ((null? entries)
- (if-not-found))
- ((and (pathname=? (caar entries) compressed-file)
- (cddar entries)
- (or (file-exists? (cadar entries))
- (begin
- (set-cdr! (cdar entries) #f)
- #f)))
- (dynamic-wind
- (lambda () unspecific)
- (lambda () (if-found (cadar entries)))
- (lambda () (set-cdr! (cdar entries) (real-time-clock)))))
- (else
- (loop (cdr entries))))))
+ (if (null? entries)
+ (if-not-found)
+ (let ((entry (car entries)))
+ (if (and (pathname=? (file-entry/compressed-name entry)
+ compressed-file)
+ (file-entry/uncompressed-name entry)
+ (= (file-entry/compressed-time entry) compressed-time)
+ (or (file-exists? (file-entry/uncompressed-name entry))
+ (begin
+ (set-file-entry/uncompressed-name! entry #F)
+ #f)))
+ (dynamic-wind
+ (lambda () unspecific)
+ (lambda () (if-found (file-entry/uncompressed-name entry)
+ (file-entry/uncompressed-time entry)))
+ (lambda ()
+ (set-file-entry/last-use-time! entry (real-time-clock))))
+ (loop (cdr entries)))))))
(lambda ()
(set-car! uncompressed-files (- (car uncompressed-files) 1)))))
-(define (call-with-uncompressed-file-pathname compressed-file receiver)
+(define (call-with-uncompressed-file-pathname compressed-file compressed-time
+ receiver)
(let ((temporary-file (temporary-file-pathname)))
(let ((entry
- (cons compressed-file
- (cons temporary-file (real-time-clock)))))
+ (make-file-entry
+ compressed-file compressed-time
+ temporary-file (file-modification-time-direct temporary-file)
+ (real-time-clock))))
(dynamic-wind
(lambda () unspecific)
(lambda ()
(cons entry (cdr uncompressed-files)))))
(receiver temporary-file))
(lambda ()
- (set-cdr! (cdr entry) (real-time-clock)))))))
+ (set-file-entry/last-use-time! entry (real-time-clock)))))))
(define (delete-uncompressed-files!)
(do ((entries (cdr uncompressed-files) (cdr entries)))
((null? entries) unspecific)
- (deallocate-temporary-file (cadar entries))))
+ (let ((name (file-entry/uncompressed-name (car entries))))
+ (if name
+ (deallocate-temporary-file name)))))
(define (clean-uncompressed-files!)
(if (= 0 (car uncompressed-files))
(let ((time (real-time-clock)))
(let loop
((entries (cdr uncompressed-files))
- (prev uncompressed-files))
- (if (not (null? entries))
- (if (or (not (cddar entries))
- (< (- time (cddar entries))
- *uncompressed-file-lifetime*))
- (loop (cdr entries) entries)
- (begin
- (set-cdr! prev (cdr entries))
- (deallocate-temporary-file (cadar entries))
- (loop (cdr entries) prev))))))))
+ (prev uncompressed-files))
+ (if (pair? entries)
+ (let ((entry (car entries)))
+ (if (or (not (file-entry/uncompressed-name entry))
+ (< (- time (file-entry/last-use-time entry))
+ *uncompressed-file-lifetime*))
+ (loop (cdr entries) entries)
+ (begin
+ (set-cdr! prev (cdr entries))
+ (deallocate-temporary-file
+ (file-entry/uncompressed-name entry))
+ (loop (cdr entries) prev)))))))))
(define (initialize-uncompressed-files!)
(set! uncompressed-files (list 0))
(define *save-uncompressed-files?* 'AUTOMATIC)
(define *uncompressed-file-lifetime* 300000)
-(define uncompressed-files)
\ No newline at end of file
+(define uncompressed-files)
+\f
+(define ((cached-loader loader) filename time)
+ (define (reload)
+ (let ((object (loader filename time)))
+ (set-cdr! cached-files
+ (cons (cons filename (weak-cons object time))
+ (cdr cached-files)))
+ object))
+ (if cached-files
+ (let ((entry (assoc filename (cdr cached-files))))
+ (if entry
+ (let ((object (weak-car (cdr entry)))
+ (time* (weak-cdr (cdr entry))))
+ (if (and object (= time time*))
+ object
+ (reload)))
+ (reload)))
+ (loader filename time)))
+
+(define (clean-cached-files!)
+ (let loop ((items (cdr cached-files))
+ (prev cached-files))
+ (cond ((null? items))
+ ((or (not (caar items))
+ (not (weak-car (cdar items))))
+ (set-cdr! prev (cdr items))
+ (loop (cdr items) prev))
+ (else
+ (loop (cdr items) (cdr prev))))))
+
+(define (initialize-cached-files!)
+ (set! cached-files (list #F)))
+
+(define cached-files #F)
\ No newline at end of file
projects / mit-scheme.git / commitdiff