From: Matt Birkholz Date: Tue, 23 Jun 2015 23:01:51 +0000 (-0700) Subject: Remove without-interrupts from runtime/infutl.scm. X-Git-Tag: mit-scheme-pucked-9.2.12~376^2~38 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=62d4101f22ec3d992c8b498f3b0f08ebdf99305f;p=mit-scheme.git Remove without-interrupts from runtime/infutl.scm. Without-interrupts was used to make atomic accesses to the uncompressed-files cache and the wrappers-with-memoized-debugging-info population. To replace it, a serial population is used and the uncompressed-files cache is punted. The latter is hopefully unnecessary on modern machinery. --- diff --git a/doc/user-manual/user.texinfo b/doc/user-manual/user.texinfo index 262293064..7ddc5f3b8 100644 --- a/doc/user-manual/user.texinfo +++ b/doc/user-manual/user.texinfo @@ -1786,60 +1786,6 @@ compiled code from that file, it attempts to find the @file{.bci} file 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 diff --git a/src/runtime/infutl.scm b/src/runtime/infutl.scm index 75b387900..6d7bcfd12 100644 --- a/src/runtime/infutl.scm +++ b/src/runtime/infutl.scm @@ -38,11 +38,8 @@ USA. (,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-serial-population)) + (add-secondary-gc-daemon! discard-debugging-info!)) (define (compiled-code-block/dbg-info block demand-load?) (let ((wrapper (compiled-code-block/debugging-wrapper block))) @@ -71,7 +68,7 @@ USA. (find-alternate-file-type pathname `(("inf" . ,fasload-loader) ("bif" . ,fasload-loader) - ("bci" . ,(compressed-loader "bif"))))))) + ("bci" . ,compressed-loader)))))) (define (find-alternate-file-type base-pathname alist) (let loop ((left alist) (time 0) (file #f) (receiver (lambda (x) x))) @@ -87,25 +84,18 @@ USA. (loop (cdr left) time file receiver)))))))) (define (memoize-debugging-info! wrapper info) - (without-interrupts + (without-interruption (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)))) (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) + (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 (compiled-entry/dbg-object entry #!optional demand-load?) (let ((block (compiled-entry/block entry)) @@ -404,7 +394,7 @@ USA. (loop (cdr types)))))))))) (and pathname (if (equal? "bcs" (pathname-type pathname)) - ((compressed-loader "bsm") pathname) + (compressed-loader pathname) (fasload-loader pathname))))) ;;;; Splitting of info structures @@ -463,84 +453,6 @@ USA. (string-set! buffer i char) (loop (fix:1+ i)))))))) -;; 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)))))))))) -|# - ;; 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 @@ -678,51 +590,17 @@ USA. (lambda (condition) condition (if-fail #f)) (lambda () (fasload filename #t)))))) -(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 (compressed-loader compressed-file) + (call-with-temporary-file-pathname + (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)))))) (define (uncompress-internal ifile ofile if-fail) (call-with-binary-input-file (merge-pathnames ifile) @@ -738,81 +616,4 @@ USA. (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)))))) - -(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