in the same directory from which the @file{.com} file was loaded. Thus
it is a good idea to leave these files together.
-@file{.bci} files are stored in a compressed format. The debugger has
-to uncompress the files when it looks at them, and on a slow machine
-this can take a noticeable time. The system takes steps to reduce the
-impact of this behavior: debugging information is cached in memory, and
-uncompressed versions of @file{.bci} files are kept around. The default
-behavior is that a temporary file is created and the @file{.bci} file is
-uncompressed into it. The temporary file is kept around for a while
-afterwards, and during that time if the uncompressed @file{.bci} file is
-needed the temporary file is used. Each such reference updates an
-`access time' that is associated with the temporary file. The garbage
-collector checks the access times of all such temporary files, and
-deletes any that have not been accessed in five minutes or more. All of
-the temporaries are deleted automatically when the Scheme process is
-killed.
-
-Two other behaviors are available. One of them uncompresses the
-@file{.bci} file each time it is referenced, and the other uncompresses
-the @file{.bci} file and writes it back out as a @file{.bif} file. The
-@file{.bif} file remains after Scheme exits. The time interval and the
-behavior are controlled by the following variables.
-
-@defvr variable *save-uncompressed-files?*
-This variable affects what happens when @file{.bci} files are
-uncompressed. It allows a trade-off between performance and disk space.
-There are three possible values:
-
-@table @code
-@item #f
-The uncompressed versions of @file{.bci} files are never saved. Each
-time the information is needed the @file{.bci} file is uncompressed.
-This option requires the minimum amount of disk space and is the
-slowest.
-
-@item automatic
-Uncompressed versions of @file{.bci} files are kept as temporary files.
-The temporary files are deleted when Scheme exits, or if they have not
-been used for a while. This is the default.
-
-@item #t
-The @file{.bci} files are uncompressed to permanent @file{.bif} files.
-These files remain on disk after Scheme exits, and are rather
-large---about twice the size of the corresponding @file{.bci} files. If
-you choose this option and you are running out of disk space you may
-delete the @file{.bif} files. They will be regenerated as needed.
-@end table
-@end defvr
-
-@defvr variable *uncompressed-file-lifetime*
-The minimum length of time that a temporary uncompressed version of
-a @file{.bci} file will stay on disk after it is last used.
-The time is in milliseconds; the default is @samp{300000} (five
-minutes).
-@end defvr
-
@defvr variable load-debugging-info-on-demand?
If this variable is @code{#f}, then printing a compiled procedure
will print the procedure's name only if the debugging information for
(,lambda-tag:let . LET)
(,lambda-tag:fluid-let . FLUID-LET)))
(set! directory-rewriting-rules (make-fluid '()))
- (add-secondary-gc-daemon! discard-debugging-info!)
- (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!))
+ (set! wrappers-with-memoized-debugging-info (make-population))
+ (set! wrappers-with-memoized-debugging-info-mutex (make-thread-mutex))
+ (add-secondary-gc-daemon! discard-debugging-info!))
(define (compiled-code-block/dbg-info block demand-load?)
(let ((wrapper (compiled-code-block/debugging-wrapper block)))
(loop (cdr left) time file receiver))))))))
(define (memoize-debugging-info! wrapper info)
- (without-interrupts
- (lambda ()
- (set-debugging-wrapper/info! wrapper info)
- (if (not wrappers-with-memoized-debugging-info)
- (set! wrappers-with-memoized-debugging-info (make-population)))
- (add-to-population! wrappers-with-memoized-debugging-info wrapper))))
+ (with-thread-mutex-locked wrappers-with-memoized-debugging-info-mutex
+ (lambda ()
+ (without-interruption
+ (lambda ()
+ (set-debugging-wrapper/info! wrapper info)
+ (add-to-population! wrappers-with-memoized-debugging-info wrapper))))))
(define (discard-debugging-info!)
- (without-interrupts
- (lambda ()
- (if wrappers-with-memoized-debugging-info
- (begin
- (map-over-population! wrappers-with-memoized-debugging-info
- (lambda (wrapper)
- (set-debugging-wrapper/info! wrapper #f)))
- (set! wrappers-with-memoized-debugging-info #f)))
- unspecific)))
-
-(define wrappers-with-memoized-debugging-info #f)
+ (with-thread-mutex-locked wrappers-with-memoized-debugging-info-mutex
+ (lambda ()
+ (for-each-inhabitant wrappers-with-memoized-debugging-info
+ (lambda (wrapper)
+ (set-debugging-wrapper/info! wrapper #f)))
+ (empty-population! wrappers-with-memoized-debugging-info))))
+
+(define wrappers-with-memoized-debugging-info)
+(define wrappers-with-memoized-debugging-info-mutex)
\f
(define (compiled-entry/dbg-object entry #!optional demand-load?)
(let ((block (compiled-entry/block entry))
(string-set! buffer i char)
(loop (fix:1+ i))))))))
\f
-;; General version.
-;;
-;; . This version will uncompress any input that can be read a character at
-;; a time by applying parameter READ-CHAR to INPUT-PORT. These do not
-;; necesarily have to be a port and a port operation, but that is
-;; the expected use.
-;; . The EOF indicator returned by READ-CHAR must not be a character, which
-;; implies that EOF-OBJECT? and CHAR? are disjoint.
-
-#|
-(define (uncompress-kernel-by-chars input-port output-port buffer-size
- read-char)
- (let ((buffer (make-string buffer-size))
- (cp-table (make-vector window-size)))
-
- (define (displacement->cp-index displacement cp)
- (let ((index (fix:- cp displacement)))
- (if (fix:< index 0) (fix:+ window-size index) index)))
-
- (define-integrable (cp:+ cp n)
- (fix:remainder (fix:+ cp n) window-size))
-
- (define-integrable (read-substring! start end)
- (let loop ((i start))
- (if (fix:>= i end)
- (fix:- i start)
- (begin
- (string-set! buffer i (read-char input-port))
- (loop (fix:1+ i))))))
-
- (define (grow-buffer!)
- (let* ((new-size (fix:+ buffer-size (fix:quotient buffer-size 4)))
- (nbuffer (make-string new-size)))
- (substring-move! buffer 0 buffer-size nbuffer 0)
- (set! buffer-size new-size)
- (set! buffer nbuffer)
- unspecific))
-
- (define-integrable (guarantee-buffer nbp)
- (if (fix:> nbp buffer-size)
- (grow-buffer!)))
-
- (let loop ((bp 0) (cp 0))
- (let ((char (read-char input-port)))
- (if (not (char? char)) ; Assume EOF
- (begin
- (output-port/write-substring output-port buffer 0 bp)
- bp)
- (let ((byte (char->integer char)))
- (if (fix:< byte 16)
- (let ((length (fix:+ byte 1)))
- (let ((nbp (fix:+ bp length))
- (ncp (cp:+ cp length)))
- (guarantee-buffer nbp)
- (read-substring! bp nbp)
- (do ((bp bp (fix:+ bp 1)) (cp cp (cp:+ cp 1)))
- ((fix:= bp nbp))
- (vector-set! cp-table cp bp))
- (loop nbp ncp)))
- (let ((cpi (displacement->cp-index
- (fix:+ (fix:* (fix:remainder byte 16) 256)
- (char->integer (read-char input-port)))
- cp))
- (length (fix:+ (fix:quotient byte 16) 1)))
- (let ((bp* (vector-ref cp-table cpi))
- (nbp (fix:+ bp length))
- (ncp (cp:+ cp 1)))
- (guarantee-buffer nbp)
- (let ((end-bp* (fix:+ bp* length)))
- (do ((bp* bp* (fix:+ bp* 1))
- (bp bp (fix:+ bp 1)))
- ((not (fix:< bp* end-bp*)))
- (vector-8b-set! buffer bp
- (vector-8b-ref buffer bp*))))
- (vector-set! cp-table cp bp)
- (loop nbp ncp))))))))))
-|#
-\f
;; This version will uncompress any input that can be read in chunks by
;; applying parameter READ-SUBSTRING to INPUT-PORT and a substring
;; reference. These do not necesarily have to be a port and a port
(define (compressed-loader uncompressed-type)
(lambda (compressed-file)
- (lookup-uncompressed-file compressed-file fasload-loader
- (lambda ()
- (let ((load-compressed
- (lambda (temporary-file)
+ (call-with-temporary-file-pathname
+ (lambda (temporary-file)
(call-with-current-continuation
(lambda (k)
(uncompress-internal compressed-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))))))))))
+ (fasload-loader temporary-file)))))))
(define (uncompress-internal ifile ofile if-fail)
(call-with-binary-input-file (merge-pathnames ifile)
(call-with-binary-output-file (merge-pathnames ofile)
(lambda (output)
(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)
- (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-modification-time<? compressed-file
- (cadar entries))
- (begin
- (set-cdr! (cdar entries) #f)
- #f)))
- (dynamic-wind
- (lambda () unspecific)
- (lambda ()
- (or (if-found (cadar entries))
- (begin
- (set-cdr! (cdar entries) #f)
- (loop (cdr entries)))))
- (lambda ()
- (if (cddar entries)
- (set-cdr! (cdar entries) (real-time-clock))))))
- (else
- (loop (cdr entries))))))
- (lambda ()
- (set-car! uncompressed-files (- (car uncompressed-files) 1)))))
-
-(define (call-with-uncompressed-file-pathname compressed-file receiver)
- (let ((temporary-file (temporary-file-pathname)))
- (let ((entry
- (cons compressed-file
- (cons temporary-file (real-time-clock)))))
- (dynamic-wind
- (lambda () unspecific)
- (lambda ()
- (let ((value (receiver temporary-file)))
- (without-interrupts
- (lambda ()
- (set-cdr! uncompressed-files
- (cons entry (cdr uncompressed-files)))))
- value))
- (lambda ()
- (set-cdr! (cdr entry) (real-time-clock)))))))
-
-(define (delete-uncompressed-files!)
- (do ((entries (cdr uncompressed-files) (cdr entries)))
- ((null? entries) unspecific)
- (deallocate-temporary-file (cadar entries))))
-
-(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))
- (set-cdr! (cdar entries) #f)
- (deallocate-temporary-file (cadar entries))
- (loop (cdr entries) prev))))))))
-
-(define (initialize-uncompressed-files!)
- (set! uncompressed-files (list 0))
- unspecific)
-
-(define *save-uncompressed-files?* 'AUTOMATIC)
-(define *uncompressed-file-lifetime* 300000)
-(define uncompressed-files)
\ No newline at end of file
+ (if-fail "Not a recognized compressed file:" ifile))))))
\ No newline at end of file
projects / mit-scheme.git / commitdiff