home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / mitsch75.zip / scheme-7_5_17-src.zip / scheme-7.5.17 / src / runtime / infutl.scm < prev    next >
Text File  |  2001-03-21  |  29KB  |  840 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: infutl.scm,v 1.64 2001/03/21 19:15:12 cph Exp $
  4.  
  5. Copyright (c) 1988-2001 Massachusetts Institute of Technology
  6.  
  7. This program is free software; you can redistribute it and/or modify
  8. it under the terms of the GNU General Public License as published by
  9. the Free Software Foundation; either version 2 of the License, or (at
  10. your option) any later version.
  11.  
  12. This program is distributed in the hope that it will be useful, but
  13. WITHOUT ANY WARRANTY; without even the implied warranty of
  14. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  15. General Public License for more details.
  16.  
  17. You should have received a copy of the GNU General Public License
  18. along with this program; if not, write to the Free Software
  19. Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
  20. 02111-1307, USA.
  21. |#
  22.  
  23. ;;;; Compiled Code Information: Utilities
  24. ;;; package: (runtime compiler-info)
  25.  
  26. (declare (usual-integrations))
  27. (declare (integrate-external "infstr" "char"))
  28.  
  29. (define (initialize-package!)
  30.   (set! special-form-procedure-names
  31.     `((,lambda-tag:unnamed . LAMBDA)
  32.       (,lambda-tag:internal-lambda . LAMBDA)
  33.       (,lambda-tag:internal-lexpr . LAMBDA)
  34.       (,lambda-tag:let . LET)
  35.       (,lambda-tag:fluid-let . FLUID-LET)
  36.       (,lambda-tag:make-environment . MAKE-ENVIRONMENT)))
  37.   (set! blocks-with-memoized-debugging-info (make-population))
  38.   (add-secondary-gc-daemon! discard-debugging-info!)
  39.   (initialize-uncompressed-files!)
  40.   (add-event-receiver! event:after-restore initialize-uncompressed-files!)
  41.   (add-event-receiver! event:before-exit delete-uncompressed-files!)
  42.   (add-gc-daemon! clean-uncompressed-files!))
  43.  
  44. (define (compiled-code-block/dbg-info block demand-load?)
  45.   (let ((old-info (compiled-code-block/debugging-info block)))
  46.     (cond ((dbg-info? old-info)
  47.        old-info)
  48.       ((and (pair? old-info) (dbg-info? (car old-info)))
  49.        (car old-info))
  50.       (demand-load?
  51.        (let ((dbg-info (read-debugging-info old-info)))
  52.          (if dbg-info (memoize-debugging-info! block dbg-info))
  53.          dbg-info))
  54.       (else #f))))
  55.  
  56. (define (discard-debugging-info!)
  57.   (without-interrupts
  58.    (lambda ()
  59.      (map-over-population! blocks-with-memoized-debugging-info
  60.                discard-block-debugging-info!)
  61.      (set! blocks-with-memoized-debugging-info (make-population))
  62.      unspecific)))
  63.  
  64. (define (read-debugging-info descriptor)
  65.   (cond ((debug-info-pathname? descriptor)
  66.      (let ((binf (read-binf-file descriptor)))
  67.        (and binf
  68.         (if (dbg-info? binf)
  69.             binf
  70.             (and (vector? binf)
  71.              (not (zero? (vector-length binf)))
  72.              (vector-ref binf 0))))))
  73.     ((and (pair? descriptor)
  74.           (debug-info-pathname? (car descriptor))
  75.           (exact-nonnegative-integer? (cdr descriptor)))
  76.      (let ((binf (read-binf-file (car descriptor))))
  77.        (and binf
  78.         (vector? binf)
  79.         (< (cdr descriptor) (vector-length binf))
  80.         (vector-ref binf (cdr descriptor)))))
  81.     (else #f)))
  82.  
  83. (define (read-binf-file pathname)
  84.   (let ((pathname (canonicalize-debug-info-pathname pathname)))
  85.     (if (file-exists? pathname)
  86.     (fasload-loader (->namestring pathname))
  87.     (find-alternate-file-type pathname
  88.                   `(("inf" . ,fasload-loader)
  89.                     ("bif" . ,fasload-loader)
  90.                     ("bci" . ,(compressed-loader "bif")))))))
  91.  
  92. (define (find-alternate-file-type base-pathname alist)
  93.   (let loop ((left alist) (time 0) (file #f) (receiver (lambda (x) x)))
  94.     (if (null? left)
  95.     (receiver file)
  96.     (let ((file* (pathname-new-type base-pathname (caar left)))
  97.           (receiver* (cdar left)))
  98.       (if (not (file-exists? file*))
  99.           (loop (cdr left) time file receiver)
  100.           (let ((time* (file-modification-time-direct file*)))
  101.         (if (> time* time)
  102.             (loop (cdr left) time* file* receiver*)
  103.             (loop (cdr left) time file receiver))))))))
  104.  
  105. (define (memoize-debugging-info! block dbg-info)
  106.   (without-interrupts
  107.    (lambda ()
  108.      (let ((old-info (compiled-code-block/debugging-info block)))
  109.        (if (not (and (pair? old-info) (dbg-info? (car old-info))))
  110.        (begin
  111.          (set-compiled-code-block/debugging-info! block
  112.                               (cons dbg-info old-info))
  113.          (add-to-population! blocks-with-memoized-debugging-info
  114.                  block)))))))
  115.  
  116. (define (un-memoize-debugging-info! block)
  117.   (without-interrupts
  118.    (lambda ()
  119.      (discard-block-debugging-info! block)
  120.      (remove-from-population! blocks-with-memoized-debugging-info block))))
  121.  
  122. (define (discard-block-debugging-info! block)
  123.   (let ((old-info (compiled-code-block/debugging-info block)))
  124.     (if (and (pair? old-info) (dbg-info? (car old-info)))
  125.     (set-compiled-code-block/debugging-info! block (cdr old-info)))))
  126.  
  127. (define blocks-with-memoized-debugging-info)
  128.  
  129. (define (compiled-entry/dbg-object entry #!optional demand-load?)
  130.   (let ((block (compiled-entry/block entry))
  131.     (offset (compiled-entry/offset entry)))
  132.     (let ((dbg-info
  133.        (compiled-code-block/dbg-info block
  134.                      (if (default-object? demand-load?)
  135.                          #t
  136.                          demand-load?))))
  137.       (and dbg-info
  138.        (let ((find-procedure
  139.           (lambda ()
  140.             (vector-binary-search (dbg-info/procedures dbg-info)
  141.                       <
  142.                       dbg-procedure/label-offset
  143.                       offset))))
  144.          (discriminate-compiled-entry entry
  145.            find-procedure
  146.            (lambda ()
  147.          (or (vector-binary-search (dbg-info/continuations dbg-info)
  148.                        <
  149.                        dbg-continuation/label-offset
  150.                        offset)
  151.              (find-procedure)))
  152.            (lambda ()
  153.          (let ((expression (dbg-info/expression dbg-info)))
  154.            (if (= offset (dbg-expression/label-offset expression))
  155.                expression
  156.                (find-procedure))))
  157.            (lambda ()
  158.          (find-procedure))))))))
  159.  
  160. (define (compiled-entry/block entry)
  161.   (cond ((compiled-code-block? entry)
  162.      entry)
  163.     ((compiled-closure? entry)
  164.      (compiled-entry/block (compiled-closure->entry entry)))
  165.     (else
  166.      (compiled-code-address->block entry))))
  167.  
  168. (define (compiled-entry/offset entry)
  169.   (if (compiled-closure? entry)
  170.       (compiled-entry/offset (compiled-closure->entry entry))
  171.       (compiled-code-address->offset entry)))
  172.  
  173. (define (compiled-entry/filename-and-index entry)
  174.   (compiled-code-block/filename-and-index (compiled-entry/block entry)))
  175.  
  176. (define (compiled-code-block/filename-and-index block)
  177.   (let loop ((info (compiled-code-block/debugging-info block)))
  178.     (cond ((debug-info-pathname? info)
  179.        (values (canonicalize-debug-info-filename info) #f))
  180.       ((not (pair? info)) (values #f #f))
  181.       ((dbg-info? (car info)) (loop (cdr info)))
  182.       ((debug-info-pathname? (car info))
  183.        (values (canonicalize-debug-info-filename (car info))
  184.            (and (exact-nonnegative-integer? (cdr info))
  185.             (cdr info))))
  186.       (else (values #f #f)))))
  187.  
  188. (define (dbg-labels/find-offset labels offset)
  189.   (vector-binary-search labels < dbg-label/offset offset))
  190.  
  191. (define (dbg-info-vector/blocks-vector info)
  192.   (let ((items (dbg-info-vector/items info)))
  193.     (cond ((vector? items) items)
  194.       ((and (pair? items)
  195.         (pair? (cdr items))
  196.         (vector? (cadr items)))
  197.        (cadr items))
  198.       (else (error "Illegal dbg-info-vector" info)))))
  199.  
  200. (define (dbg-info-vector/purification-root info)
  201.   (let ((items (dbg-info-vector/items info)))
  202.     (cond ((vector? items) #f)
  203.       ((and (pair? items)
  204.         (eq? (car items) 'COMPILED-BY-PROCEDURES)
  205.         (pair? (cdr items))
  206.         (pair? (cddr items)))
  207.        (caddr items))
  208.       (else (error "Illegal dbg-info-vector" info)))))
  209.  
  210. (define (fasload/update-debugging-info! value com-pathname)
  211.   (let ((process-block
  212.      (lambda (block)
  213.        (let ((binf-filename
  214.           (process-binf-filename
  215.            (compiled-code-block/debugging-info block)
  216.            com-pathname)))
  217.          (set-compiled-code-block/debugging-info! block binf-filename)
  218.          binf-filename)))
  219.     (process-subblocks
  220.      (lambda (blocks start binf-filename)
  221.        (let ((end (vector-length blocks)))
  222.          (let loop ((index start))
  223.            (if (< index end)
  224.            (begin
  225.              (set-car! (compiled-code-block/debugging-info
  226.                 (vector-ref blocks index))
  227.                    binf-filename)
  228.              (loop (1+ index)))))))))
  229.  
  230.     (cond ((compiled-code-address? value)
  231.        (let ((binf-filename
  232.           (process-block (compiled-code-address->block value)))
  233.          (blocks (load/purification-root value)))
  234.          (if (vector? blocks)
  235.          (process-subblocks blocks 0 binf-filename))))
  236.       ((and (comment? value)
  237.         (dbg-info-vector? (comment-text value)))
  238.        (let ((blocks (dbg-info-vector/blocks-vector (comment-text value))))
  239.          (process-subblocks blocks
  240.                 1
  241.                 (process-block (vector-ref blocks 0))))))))
  242.  
  243. (define (process-binf-filename binf-filename com-pathname)
  244.   (and binf-filename
  245.        (rewrite-directory
  246.     (let ((binf-pathname (merge-pathnames binf-filename))
  247.           (com-pathname (merge-pathnames com-pathname)))
  248.       (if (and (equal? (pathname-name binf-pathname)
  249.                (pathname-name com-pathname))
  250.            (not (equal? (pathname-type binf-pathname)
  251.                 (pathname-type com-pathname)))
  252.            (equal? (pathname-version binf-pathname)
  253.                (pathname-version com-pathname)))
  254.           (pathname-new-type com-pathname (pathname-type binf-pathname))
  255.           binf-pathname)))))
  256.  
  257. (define (debug-info-pathname? object)
  258.   (or (pathname? object)
  259.       (string? object)))
  260.  
  261. (define directory-rewriting-rules
  262.   '())
  263.  
  264. (define (with-directory-rewriting-rule match replace thunk)
  265.   (fluid-let ((directory-rewriting-rules
  266.            (cons (cons (pathname-as-directory (merge-pathnames match))
  267.                replace)
  268.              directory-rewriting-rules)))
  269.     (thunk)))
  270.  
  271. (define (add-directory-rewriting-rule! match replace)
  272.   (let ((match (pathname-as-directory (merge-pathnames match))))
  273.     (let ((rule
  274.        (list-search-positive directory-rewriting-rules
  275.          (lambda (rule)
  276.            (equal? (pathname-directory (car rule))
  277.                (pathname-directory match))))))
  278.       (if rule
  279.       (set-cdr! rule replace)
  280.       (set! directory-rewriting-rules
  281.         (cons (cons match replace)
  282.               directory-rewriting-rules)))))
  283.   unspecific)
  284.  
  285. (define (rewrite-directory pathname)
  286.   (let ((rule
  287.      (list-search-positive directory-rewriting-rules
  288.        (lambda (rule)
  289.          (directory-prefix? (pathname-directory pathname)
  290.                 (pathname-directory (car rule)))))))
  291.     (->namestring
  292.      (if rule
  293.      (merge-pathnames
  294.       (pathname-new-directory
  295.        (file-pathname pathname)
  296.        (cons 'RELATIVE
  297.          (list-tail (pathname-directory pathname)
  298.                 (length (pathname-directory (car rule))))))
  299.       (cdr rule))
  300.      pathname))))
  301.  
  302. (define (directory-prefix? x y)
  303.   (and (pair? x)
  304.        (pair? y)
  305.        (eq? (car x) (car y))
  306.        (let loop ((x (cdr x)) (y (cdr y)))
  307.      (or (null? y)
  308.          (and (not (null? x))
  309.           (equal? (car x) (car y))
  310.           (loop (cdr x) (cdr y)))))))
  311.  
  312. (define (canonicalize-debug-info-filename filename)
  313.   (->namestring (canonicalize-debug-info-pathname filename)))
  314.  
  315. (define (canonicalize-debug-info-pathname pathname)
  316.   (if (pathname-absolute? pathname)
  317.       pathname
  318.       (merge-pathnames
  319.        pathname
  320.        (let ((value
  321.           (get-environment-variable "MITSCHEME_INF_DIRECTORY")))
  322.      (if value
  323.          (pathname-as-directory value)
  324.          (system-library-directory-pathname "SRC"))))))
  325.  
  326. (define-integrable (dbg-block/layout-first-offset block)
  327.   (let ((layout (dbg-block/layout block)))
  328.     (and (pair? layout) (car layout))))
  329.  
  330. (define-integrable (dbg-block/layout-vector block)
  331.   (let ((layout (dbg-block/layout block)))
  332.     (if (pair? layout)
  333.     (cdr layout)
  334.     layout)))
  335.  
  336. (define (dbg-block/dynamic-link-index block)
  337.   (vector-find-next-element (dbg-block/layout-vector block)
  338.                 dbg-block-name/dynamic-link))
  339.  
  340. (define (dbg-block/ic-parent-index block)
  341.   (vector-find-next-element (dbg-block/layout-vector block)
  342.                 dbg-block-name/ic-parent))
  343.  
  344. (define (dbg-block/normal-closure-index block)
  345.   (vector-find-next-element (dbg-block/layout-vector block)
  346.                 dbg-block-name/normal-closure))
  347.  
  348. (define (dbg-block/return-address-index block)
  349.   (vector-find-next-element (dbg-block/layout-vector block)
  350.                 dbg-block-name/return-address))
  351.  
  352. (define (dbg-block/static-link-index block)
  353.   (vector-find-next-element (dbg-block/layout-vector block)
  354.                 dbg-block-name/static-link))
  355.  
  356. (define (dbg-block/find-name block name)
  357.   (let ((layout (dbg-block/layout-vector block)))
  358.     (let ((end (vector-length layout)))
  359.       (let loop ((index 0))
  360.     (and (< index end)
  361.          (if (let ((item (vector-ref layout index)))
  362.            (and (dbg-variable? item)
  363.             (eq? name (dbg-variable/name item))))
  364.          index
  365.          (loop (1+ index))))))))
  366.  
  367. (define (compiled-procedure/name entry)
  368.   (let ((procedure
  369.      (compiled-entry/dbg-object entry load-debugging-info-on-demand?)))
  370.     (and procedure
  371.      (let ((name (dbg-procedure/name procedure)))
  372.        (or (special-form-procedure-name? name)
  373.            (symbol-name name))))))
  374.  
  375. (define load-debugging-info-on-demand?
  376.   #f)
  377.  
  378. (define (special-form-procedure-name? name)
  379.   (let ((association (assq name special-form-procedure-names)))
  380.     (and association
  381.      (symbol-name (cdr association)))))
  382.  
  383. (define special-form-procedure-names)
  384.  
  385. (define (compiled-procedure/lambda entry)
  386.   (let ((procedure (compiled-entry/dbg-object entry)))
  387.     (and procedure
  388.      (dbg-procedure/source-code procedure))))
  389.  
  390. (define (compiled-expression/scode entry)
  391.   (let ((object (compiled-entry/dbg-object entry)))
  392.     (or (and (dbg-procedure? object)
  393.          (let ((scode (dbg-procedure/source-code object)))
  394.            (and scode
  395.             (lambda-body scode))))
  396.     entry)))
  397.  
  398. ;;; Support of BSM files
  399.  
  400. (define (read-labels descriptor)
  401.   (cond ((debug-info-pathname? descriptor)
  402.      (let ((bsm (read-bsm-file descriptor)))
  403.        (and bsm ;; bsm are either vectors of pairs or vectors of vectors
  404.         (if (vector? bsm)
  405.             (let ((first (and (not (zero? (vector-length bsm)))
  406.                       (vector-ref bsm 0))))
  407.               (cond ((pair? first) bsm)
  408.                 ((vector? first) first)
  409.                 (else #f)))))))
  410.     ((and (pair? descriptor)
  411.           (debug-info-pathname? (car descriptor))
  412.           (exact-nonnegative-integer? (cdr descriptor)))
  413.      (let ((bsm (read-bsm-file (car descriptor))))
  414.        (and bsm
  415.         (vector? bsm)
  416.         (< (cdr descriptor) (vector-length bsm))
  417.         (vector-ref bsm (cdr descriptor)))))
  418.     (else #f)))
  419.  
  420. (define (read-bsm-file name)
  421.   (let ((pathname
  422.      (let ((pathname
  423.         (canonicalize-debug-info-pathname
  424.          (rewrite-directory (merge-pathnames name)))))
  425.        (if (file-exists? pathname)
  426.            pathname
  427.            (let loop ((types '("bsm" "bcs")))
  428.          (and (not (null? types))
  429.               (let ((pathname
  430.                  (pathname-new-type pathname (car types))))
  431.             (if (file-exists? pathname)
  432.                 pathname
  433.                 (loop (cdr types))))))))))
  434.     (and pathname
  435.      (if (equal? "bcs" (pathname-type pathname))
  436.          ((compressed-loader "bsm") pathname)
  437.          (fasload-loader pathname)))))
  438.  
  439. ;;;; Splitting of info structures
  440.  
  441. (define (inf->bif/bsm inffile)
  442.   (let* ((infpath (merge-pathnames inffile))
  443.      (bifpath (pathname-new-type infpath "bif"))
  444.      (bsmpath (pathname-new-type infpath "bsm")))
  445.     (let ((binf (fasload infpath)))
  446.       (inf-structure->bif/bsm binf bifpath bsmpath))))
  447.  
  448. (define (inf-structure->bif/bsm binf bifpath bsmpath)
  449.   (let ((bifpath (merge-pathnames bifpath))
  450.     (bsmpath (and bsmpath (merge-pathnames bsmpath))))
  451.     (let ((bsm (split-inf-structure! binf bsmpath)))
  452.       (fasdump binf bifpath #t)
  453.       (if bsmpath
  454.       (fasdump bsm bsmpath #t)))))
  455.  
  456. (define (split-inf-structure! binf bsmpath)
  457.   (let ((bsmname (and bsmpath (->namestring bsmpath))))
  458.     (cond ((dbg-info? binf)
  459.        (let ((labels (dbg-info/labels/desc binf)))
  460.          (set-dbg-info/labels/desc! binf bsmname)
  461.          labels))
  462.       ((vector? binf)
  463.        (let ((n (vector-length binf)))
  464.          (let ((bsm (make-vector n)))
  465.            (do ((i 0 (fix:+ i 1)))
  466.            ((fix:= i n))
  467.          (let ((dbg-info (vector-ref binf i)))
  468.            (let ((labels (dbg-info/labels/desc dbg-info)))
  469.              (vector-set! bsm i labels)
  470.              (set-dbg-info/labels/desc!
  471.               dbg-info
  472.               (and bsmname (cons bsmname i))))))
  473.            bsm)))
  474.       (else 
  475.        (error "Unknown inf format:" binf)))))
  476.  
  477. ;;;; UNCOMPRESS
  478. ;;;  A simple extractor for compressed binary info files.
  479.  
  480. (define-integrable window-size 4096)
  481.  
  482. (define (uncompress-ports input-port output-port #!optional buffer-size)
  483.   (uncompress-kernel-by-blocks
  484.    input-port output-port
  485.    (if (default-object? buffer-size) 4096 buffer-size)
  486.    (input-port/operation input-port 'READ-SUBSTRING)))
  487.  
  488. (define (uncompress-read-substring port buffer start end)
  489.   (let loop ((i start))
  490.     (if (fix:>= i end)
  491.     (fix:- i start)
  492.     (let ((char (read-char port)))
  493.       (if (not (char? char))
  494.           (fix:- i start)
  495.           (begin
  496.         (string-set! buffer i char)
  497.         (loop (fix:1+ i))))))))
  498.  
  499. ;;  General version.
  500. ;;
  501. ;; . This version will uncompress any input that can be read a character at
  502. ;;   a time by applying parameter READ-CHAR to INPUT-PORT.  These do not
  503. ;;   necesarily have to be a port and a port operation, but that is
  504. ;;   the expected use.
  505. ;; . The EOF indicator returned by READ-CHAR must not be a character, which
  506. ;;   implies that EOF-OBJECT? and CHAR? are disjoint.
  507.  
  508. #|
  509. (define (uncompress-kernel-by-chars input-port output-port buffer-size
  510.                     read-char)
  511.   (let ((buffer (make-string buffer-size))
  512.     (cp-table (make-vector window-size)))
  513.  
  514.     (define (displacement->cp-index displacement cp)
  515.       (let ((index (fix:- cp displacement)))
  516.     (if (fix:< index 0) (fix:+ window-size index) index)))
  517.  
  518.     (define-integrable (cp:+ cp n)
  519.       (fix:remainder (fix:+ cp n) window-size))
  520.  
  521.     (define-integrable (read-substring! start end)
  522.       (let loop ((i start))
  523.     (if (fix:>= i end)
  524.         (fix:- i start)
  525.         (begin
  526.           (string-set! buffer i (read-char input-port))
  527.           (loop (fix:1+ i))))))
  528.  
  529.     (define (grow-buffer!)
  530.       (let* ((new-size (fix:+ buffer-size (fix:quotient buffer-size 4)))
  531.          (nbuffer (make-string new-size)))
  532.     (substring-move! buffer 0 buffer-size nbuffer 0)
  533.     (set! buffer-size new-size)
  534.     (set! buffer nbuffer)
  535.     unspecific))
  536.  
  537.     (define-integrable (guarantee-buffer nbp)
  538.       (if (fix:> nbp buffer-size)
  539.       (grow-buffer!)))
  540.  
  541.     (let loop ((bp 0) (cp 0))
  542.       (let ((char (read-char input-port)))
  543.     (if (not (char? char))        ; Assume EOF
  544.         (begin
  545.           (output-port/write-substring output-port buffer 0 bp)
  546.           bp)
  547.         (let ((byte (char->integer char)))
  548.           (if (fix:< byte 16)
  549.           (let ((length (fix:+ byte 1)))
  550.             (let ((nbp (fix:+ bp length))
  551.               (ncp (cp:+ cp length)))
  552.               (guarantee-buffer nbp)
  553.               (read-substring! bp nbp)
  554.               (do ((bp bp (fix:+ bp 1)) (cp cp (cp:+ cp 1)))
  555.               ((fix:= bp nbp))
  556.             (vector-set! cp-table cp bp))
  557.               (loop nbp ncp)))
  558.           (let ((cpi (displacement->cp-index
  559.                   (fix:+ (fix:* (fix:remainder byte 16) 256)
  560.                      (char->integer (read-char input-port)))
  561.                   cp))
  562.             (length (fix:+ (fix:quotient byte 16) 1)))
  563.             (let ((bp* (vector-ref cp-table cpi))
  564.               (nbp (fix:+ bp length))
  565.               (ncp (cp:+ cp 1)))
  566.               (guarantee-buffer nbp)
  567.               (let ((end-bp* (fix:+ bp* length)))
  568.             (do ((bp* bp* (fix:+ bp* 1))
  569.                  (bp bp (fix:+ bp 1)))
  570.                 ((not (fix:< bp* end-bp*)))
  571.               (vector-8b-set! buffer bp
  572.                       (vector-8b-ref buffer bp*))))
  573.               (vector-set! cp-table cp bp)
  574.               (loop nbp ncp))))))))))
  575. |#
  576.  
  577. ;; This version will uncompress any input that can be read in chunks by
  578. ;; applying parameter READ-SUBSTRING to INPUT-PORT and a substring
  579. ;; reference.  These do not necesarily have to be a port and a port
  580. ;; operation, but that is the expected use.
  581. ;;
  582. ;; This version is written for speed:
  583. ;;
  584. ;;  . The main speed gain is from is by buffering the input.  This version
  585. ;;    is about 10 times faster than the above version on files, and about
  586. ;;    1.5 times faster than the above version called on custom input
  587. ;;    operations.
  588. ;;
  589. ;;  . PARSE-COMMAND interprets one `command' of compressed information.
  590. ;;
  591. ;;  . There is no assignment to local variables.  Instead the changeable
  592. ;;    state is passed as explicit state variables (a kind of functional
  593. ;;    style) and the procedures are tail-recursive so that the state
  594. ;;    is `single-threaded'.  This prevents the compiler from
  595. ;;    cellifying the variables.
  596. ;;
  597. ;;  . Some of the drudge in passing all of the state is handed over to the
  598. ;;    compiler by making the procedures internal to PARSE-COMMAND.
  599. ;;
  600. ;;  . The main loop (PARSE-COMMAND) is `restartable'.  This allows the
  601. ;;    parsing operation to determine if enough input or output buffer is
  602. ;;    available before doing any copying, and if there is a problem it
  603. ;;    can tail-call into the handler (RETRY-WITH-BIGGER-OUTPUT-BUFFER
  604. ;;    and REFILL-INPUT-BUFFER-AND-RETRY) and that can tail call back
  605. ;;    into PARSE-COMMAND.
  606. ;;
  607. ;;  . Refilling the input buffer and testing for EOF is a bit funky.
  608. ;;    It relies on the fact that when we demand a refill we know how many
  609. ;;    bytes we require to (re)parse the command.  We are at EOF when
  610. ;;    we try to read some more data and there is none, and also there
  611. ;;    is no unprocessed input, in which case we just tail out of the
  612. ;;    loop.
  613.  
  614. (define (uncompress-kernel-by-blocks input-port output-port buffer-size
  615.                      read-substring)
  616.   (define-integrable input-size 4096)
  617.   (let ((cp-table (make-vector window-size))
  618.     (input-buffer (make-string input-size)))
  619.  
  620.     (define (displacement->cp-index displacement cp)
  621.       (let ((index (fix:- cp displacement)))
  622.     (if (fix:< index 0) (fix:+ window-size index) index)))
  623.  
  624.     (define-integrable (cp:+ cp n)
  625.       (fix:remainder (fix:+ cp n) window-size))
  626.  
  627.     (define (short-substring-move! s1 start1 end1 s2 start2)
  628.       (do ((i1 start1 (fix:+ i1 1))
  629.            (i2 start2 (fix:+ i2 1)))
  630.           ((fix:= i1 end1))
  631.         (string-set! s2 i2 (string-ref s1 i1))))
  632.  
  633.     (let parse-command ((bp 0) (cp 0) (ip 0) (ip-end 0)
  634.                    (buffer (make-string buffer-size))
  635.                    (buffer-size buffer-size))
  636.       ;; Invariant: (SUBTRING BUFFER IP IP-END) is unprocessed input.
  637.       (define (retry-with-bigger-output-buffer)
  638.     (let* ((new-size (fix:+ buffer-size (fix:quotient buffer-size 4)))
  639.            (nbuffer (make-string new-size)))
  640.       (substring-move! buffer 0 buffer-size nbuffer 0)
  641.       (parse-command bp cp ip ip-end nbuffer new-size)))
  642.  
  643.       (define (refill-input-buffer-and-retry needed)
  644.     (short-substring-move! input-buffer ip ip-end input-buffer 0)
  645.     (let* ((left (fix:- ip-end ip))
  646.            (count (read-substring input-port input-buffer 
  647.                       left input-size))
  648.            (total (fix:+ count left)))
  649.       (if (fix:= count 0)
  650.           (if (fix:< total needed)
  651.           (error "Compressed input ends too soon"
  652.              input-port 'UNCOMPRESS-KERNEL-BY-BLOCKS)
  653.           (finished))
  654.           (parse-command bp cp 0  total buffer buffer-size))))
  655.  
  656.       (define (finished)
  657.     (output-port/write-substring output-port buffer 0 bp)
  658.     bp)
  659.   
  660.       (define (literal-command byte)
  661.     (let ((length (fix:+ byte 1))
  662.           (ip*    (fix:+ ip 1)))
  663.       (let ((nbp (fix:+ bp length))
  664.         (ncp (cp:+ cp length))
  665.         (nip (fix:+ ip* length)))
  666.         (if (fix:> nbp buffer-size)
  667.         (retry-with-bigger-output-buffer)
  668.         (if (fix:> nip ip-end)
  669.             (refill-input-buffer-and-retry (fix:+ length 1))
  670.             (begin
  671.               (short-substring-move! input-buffer ip* nip buffer bp)
  672.               (do ((bp bp (fix:+ bp 1)) (cp cp (cp:+ cp 1)))
  673.               ((fix:= bp nbp))
  674.             (vector-set! cp-table cp bp))
  675.               (parse-command nbp ncp nip ip-end buffer
  676.                      buffer-size)))))))
  677.  
  678.       (define (copy-command byte)
  679.     (let ((ip* (fix:+ ip 1)))
  680.       (if (fix:>= ip* ip-end)
  681.           (refill-input-buffer-and-retry 2)
  682.           (let ((cpi (displacement->cp-index
  683.               (fix:+ (fix:* (fix:remainder byte 16) 256)
  684.                  (vector-8b-ref input-buffer ip*))
  685.               cp))
  686.             (length (fix:+ (fix:quotient byte 16) 1)))
  687.         (let ((bp* (vector-ref cp-table cpi))
  688.               (nbp (fix:+ bp length))
  689.               (ncp (cp:+ cp 1)))
  690.           (if (fix:> nbp buffer-size)
  691.               (retry-with-bigger-output-buffer)
  692.               (let ((end-bp* (fix:+ bp* length)))
  693.             (short-substring-move! buffer bp* end-bp* buffer bp)
  694.             (vector-set! cp-table cp bp)
  695.             (parse-command nbp ncp (fix:+ ip 2) ip-end
  696.                        buffer buffer-size))))))))
  697.  
  698.       (if (fix:>= ip ip-end)
  699.       (refill-input-buffer-and-retry 0)
  700.       (let ((byte  (vector-8b-ref input-buffer ip)))
  701.         (if (fix:< byte 16)
  702.         (literal-command byte)
  703.         (copy-command byte)))))))
  704.  
  705. (define (fasload-loader filename)
  706.   (call-with-current-continuation
  707.     (lambda (if-fail)
  708.       (bind-condition-handler (list condition-type:fasload-band)
  709.         (lambda (condition) condition (if-fail #f))
  710.         (lambda () (fasload filename #t))))))
  711.  
  712. (define (compressed-loader uncompressed-type)
  713.   (lambda (compressed-file)
  714.     (lookup-uncompressed-file compressed-file fasload-loader
  715.       (lambda ()
  716.     (let ((load-compressed
  717.            (lambda (temporary-file)
  718.          (call-with-current-continuation
  719.           (lambda (k)
  720.             (uncompress-internal compressed-file
  721.                      temporary-file
  722.                      (lambda (message . irritants)
  723.                        message irritants
  724.                        (k #f)))
  725.             (fasload-loader temporary-file))))))
  726.       (case *save-uncompressed-files?*
  727.         ((#F)
  728.          (call-with-temporary-file-pathname load-compressed))
  729.         ((AUTOMATIC)
  730.          (call-with-uncompressed-file-pathname compressed-file
  731.                            load-compressed))
  732.         (else
  733.          (call-with-temporary-file-pathname
  734.           (lambda (temporary-file)
  735.         (let ((result (load-compressed temporary-file))
  736.               (uncompressed-file
  737.                (pathname-new-type compressed-file uncompressed-type)))
  738.           (delete-file-no-errors uncompressed-file)
  739.           (if (call-with-current-continuation
  740.                (lambda (k)
  741.              (bind-condition-handler
  742.                  (list condition-type:file-error
  743.                    condition-type:port-error)
  744.                  (lambda (condition) condition (k #t))
  745.                (lambda ()
  746.                  (rename-file temporary-file uncompressed-file)
  747.                  #f))))
  748.               (call-with-current-continuation
  749.                (lambda (k)
  750.              (bind-condition-handler
  751.                  (list condition-type:file-error
  752.                    condition-type:port-error)
  753.                  (lambda (condition) condition (k unspecific))
  754.                (lambda ()
  755.                  (copy-file temporary-file uncompressed-file))))))
  756.           result))))))))))
  757.  
  758. (define (uncompress-internal ifile ofile if-fail)
  759.   (call-with-binary-input-file (merge-pathnames ifile)
  760.     (lambda (input)                   
  761.       (let* ((file-marker "Compressed-B1-1.00")
  762.          (marker-size (string-length file-marker))
  763.          (actual-marker (make-string marker-size)))
  764.     ;; This may get more hairy as we up versions
  765.     (if (and (fix:= (uncompress-read-substring input
  766.                            actual-marker 0 marker-size)
  767.             marker-size)
  768.          (string=? file-marker actual-marker))
  769.         (call-with-binary-output-file (merge-pathnames ofile)
  770.              (lambda (output)                      
  771.         (uncompress-ports input output (fix:* (file-length ifile) 2))))
  772.         (if-fail "Not a recognized compressed file:" ifile))))))
  773.  
  774. (define (lookup-uncompressed-file compressed-file if-found if-not-found)
  775.   (dynamic-wind
  776.    (lambda ()
  777.      (set-car! uncompressed-files (+ (car uncompressed-files) 1)))
  778.    (lambda ()
  779.      (let loop ((entries (cdr uncompressed-files)))
  780.        (cond ((null? entries)
  781.           (if-not-found))
  782.          ((and (pathname=? (caar entries) compressed-file)
  783.            (cddar entries)
  784.            (or (file-exists? (cadar entries))
  785.                (begin
  786.              (set-cdr! (cdar entries) #f)
  787.              #f)))
  788.           (dynamic-wind
  789.            (lambda () unspecific)
  790.            (lambda () (if-found (cadar entries)))
  791.            (lambda () (set-cdr! (cdar entries) (real-time-clock)))))
  792.          (else
  793.           (loop (cdr entries))))))
  794.    (lambda ()
  795.      (set-car! uncompressed-files (- (car uncompressed-files) 1)))))
  796.  
  797. (define (call-with-uncompressed-file-pathname compressed-file receiver)
  798.   (let ((temporary-file (temporary-file-pathname)))
  799.     (let ((entry
  800.        (cons compressed-file
  801.          (cons temporary-file (real-time-clock)))))
  802.       (dynamic-wind
  803.        (lambda () unspecific)
  804.        (lambda ()
  805.      (without-interrupts
  806.       (lambda ()
  807.         (set-cdr! uncompressed-files
  808.               (cons entry (cdr uncompressed-files)))))
  809.      (receiver temporary-file))
  810.        (lambda ()
  811.      (set-cdr! (cdr entry) (real-time-clock)))))))
  812.  
  813. (define (delete-uncompressed-files!)
  814.   (do ((entries (cdr uncompressed-files) (cdr entries)))
  815.       ((null? entries) unspecific)
  816.     (deallocate-temporary-file (cadar entries))))
  817.  
  818. (define (clean-uncompressed-files!)
  819.   (if (= 0 (car uncompressed-files))
  820.       (let ((time (real-time-clock)))
  821.     (let loop
  822.         ((entries (cdr uncompressed-files))
  823.          (prev uncompressed-files))
  824.       (if (not (null? entries))
  825.           (if (or (not (cddar entries))
  826.               (< (- time (cddar entries))
  827.              *uncompressed-file-lifetime*))
  828.           (loop (cdr entries) entries)
  829.           (begin
  830.             (set-cdr! prev (cdr entries))
  831.             (deallocate-temporary-file (cadar entries))
  832.             (loop (cdr entries) prev))))))))
  833.  
  834. (define (initialize-uncompressed-files!)
  835.   (set! uncompressed-files (list 0))
  836.   unspecific)
  837.  
  838. (define *save-uncompressed-files?* 'AUTOMATIC)
  839. (define *uncompressed-file-lifetime* 300000)
  840. (define uncompressed-files)