;;; determines the algorithm.
\f
(define (compress ifile ofile)
- (call-with-legacy-binary-input-file (merge-pathnames ifile)
+ (call-with-binary-input-file (merge-pathnames ifile)
(lambda (input)
- (call-with-legacy-binary-output-file (merge-pathnames ofile)
+ (call-with-binary-output-file (merge-pathnames ofile)
(lambda (output)
- (write-string "Compressed-B1-1.00" output)
+ (write-compressed-file-marker output)
(compress-ports input output))))))
(define-structure (compression-state
output-port)
(define (compress-ports input output)
- (let ((state (make-compression-state
- (make-vector 256 false)
- (make-byte-buffer)
- (make-output-buffer)
- input output)))
+ (let ((state
+ (make-compression-state (make-vector 256 #f)
+ (make-byte-buffer)
+ (make-output-buffer)
+ input output)))
(call-with-current-continuation
(lambda (continuation)
(set-compress-continuation! state continuation)
(let ((byte (read-byte state)))
(let ((node (vector-ref (root-nodes state) byte)))
(if (not node)
- (add-child state false byte (make-node state 0)))
+ (add-child state #f byte (make-node state 0)))
node)))
(define (match-next state node nb)
(let loop ((child (node-children node)))
(cond ((not child)
(add-child state node byte (make-node state 0))
- false)
+ #f)
((fix:= byte (node-byte child))
(discard-byte state)
child)
(replace-child state node parent)
(add-child state parent byte* node)
(add-child state parent byte (make-node state 0)))
- false))))))
+ #f))))))
\f
;;;; PATRICIA Tree Database
(define-structure (node (constructor %make-node (nb older pointer bp)))
;; The parent of this node, or #F for a root node.
- (parent false)
+ (parent #f)
;; The children of this node. Either #F for no children, or the
;; first child. The remaining children are accessed through the
;; NODE-NEXT fields. A node will never have exactly one child.
- (children false)
+ (children #f)
;; The adjacent siblings of this node, or #F if none.
- (previous false)
- (next false)
+ (previous #f)
+ (next #f)
;; The first byte of the substring between the parent and this node.
- (byte false)
+ (byte #f)
;; The number of bytes in the string represented by this node,
;; counting down from the root of the tree.
;; The adjacent nodes in the node pointer ordering. The OLDER node
;; has less recent POINTER and BP, while the newer node has more recent.
- (older false)
- (newer false)
+ (older #f)
+ (newer #f)
;; The command pointer for this node.
pointer
(if older
(set-node-newer! older newer)
(set-oldest-node! state newer))
- (set-node-newer! node false)
+ (set-node-newer! node #f)
(set-node-older! node (newest-node state))
(set-node-newer! (newest-node state) node)
(set-newest-node! state node)
((not (fix:= (node-pointer node) pointer)) node))))
(if (not (eq? node oldest-node))
(let ((older (node-older node)))
- (set-node-older! node false)
+ (set-node-older! node #f)
(set-oldest-node! state node)
;; We don't have to do anything complicated to delete a node.
;; If the node has any children, we know that they are also
;; only do the deletion if the parent is not marked.
(do ((node older (node-older node)))
((not node))
- (set-node-nb! node false))
+ (set-node-nb! node #f))
(do ((node older (node-older node)))
((not node))
(let ((parent (node-parent node)))
(cond ((not parent)
- (vector-set! (root-nodes state) (node-byte node) false))
+ (vector-set! (root-nodes state) (node-byte node) #f))
((node-nb parent)
(delete-child state parent node))))
- (set-node-nb! node true))
+ (set-node-nb! node #t))
unspecific))))
(define (delete-child state parent child)
;;; The optimal size for this buffer is
;;; (+ (* COPY-MAX POINTER-MAX) BUFFER-READ)
(define-integrable buffer-size 69632)
-(define-integrable buffer-size-optimal? true)
+(define-integrable buffer-size-optimal? #t)
;;; When input is needed from the input port, we attempt to read this
;;; many bytes all at once. It is assumed that BUFFER-SIZE is an
(define-integrable buffer-read 4096)
(define-structure (bb (constructor make-byte-buffer ()))
- (vector (make-legacy-string buffer-size) read-only true)
+ (vector (make-bytevector buffer-size) read-only #t)
(ptr 0)
(end 0)
- (eof? false))
+ (eof? #f))
(define (byte-ready? state)
(let ((bb (byte-buffer state)))
(if (fix:= (bb-ptr bb) (bb-end bb))
- (guarantee-buffer-data state bb true)
- true)))
+ (guarantee-buffer-data state bb #t)
+ #t)))
(define (read-byte state)
;; Get a byte from the byte buffer. If we are reading bytes in the
(define (%peek-byte state bb)
(if (fix:= (bb-ptr bb) (bb-end bb))
- (guarantee-buffer-data state bb false))
- (vector-8b-ref (bb-vector bb) (bb-ptr bb)))
+ (guarantee-buffer-data state bb #f))
+ (bytevector-u8-ref (bb-vector bb) (bb-ptr bb)))
(define (%discard-byte bb)
(set-bb-ptr! bb
(define (node-ref node nb state)
;; Read byte NB in the string for NODE.
- (vector-8b-ref (bb-vector (byte-buffer state))
- (let ((bp (fix:+ (node-bp node) nb)))
- (if (fix:< bp buffer-size)
- bp
- (fix:- bp buffer-size)))))
+ (bytevector-u8-ref (bb-vector (byte-buffer state))
+ (let ((bp (fix:+ (node-bp node) nb)))
+ (if (fix:< bp buffer-size)
+ bp
+ (fix:- bp buffer-size)))))
\f
(define (guarantee-buffer-data state bb probe?)
;; We have read all of the bytes in the buffer, so it's time to get
;; means we are now at EOF.
(if (bb-eof? bb)
(if probe?
- false
+ #f
(compress-finished state))
(let* ((end (bb-end bb))
(end* (fix:+ end buffer-read)))
;; couldn't be sure that any nodes we were holding were valid
;; across a call to READ-BYTE.
(let ((nb
- (input-port/read-substring! (input-port state)
- (bb-vector bb) end end*)))
+ (read-bytevector! (bb-vector bb) (input-port state) end end*)))
(cond ((not nb)
(error "Input port must be in blocking mode:"
(input-port state))
- false)
- ((fix:= nb buffer-read)
- ;; A full block was read.
- (set-bb-end! bb (if (fix:= end* buffer-size) 0 end*))
- true)
- ((fix:= nb 0)
- ;; We're at EOF.
+ #f)
+ ((eof-object? nb)
(if probe?
(begin
- (set-bb-eof?! bb true)
- false)
+ (set-bb-eof?! bb #t)
+ #f)
(compress-finished state)))
+ ((fix:= nb buffer-read)
+ ;; A full block was read.
+ (set-bb-end! bb (if (fix:= end* buffer-size) 0 end*))
+ #t)
((and (fix:< 0 nb) (fix:< nb buffer-read))
;; A partial block was read, meaning that
;; this is the last block. Set BB-EOF? to
;; indicate that there is no more data after
;; this block is exhausted.
- (set-bb-eof?! bb true)
+ (set-bb-eof?! bb #t)
(set-bb-end! bb (fix:+ end nb))
- true)
+ #t)
(else
(error "Illegal result from read:" nb buffer-read)
- false))))))
+ #f))))))
(define (compress-finished state)
;; This is called from GUARANTEE-BUFFER-DATA when EOF is
(let ((pointer (fix:+ (current-pointer state) 1)))
(if (fix:= pointer pointer-max)
(begin
- (set-window-filled?! state true)
+ (set-window-filled?! state #t)
0)
pointer))))
(set-current-pointer! state pointer)
(set-oldest state (oldest-node state) pointer))))
(define (make-output-buffer)
- (cons 0 (make-legacy-string 4096)))
+ (cons 0 (make-bytevector 4096)))
(define (write-byte state byte)
(let ((ob (output-buffer state)))
(let ((index (car ob)))
- (vector-8b-set! (cdr ob) index byte)
+ (bytevector-u8-set! (cdr ob) index byte)
(if (fix:= index 4095)
(begin
- (output-port/write-string (output-port state) (cdr ob))
+ (write-bytevector (cdr ob) (output-port state))
(set-car! ob 0))
(set-car! ob (fix:+ index 1))))))
(do ((start start (fix:+ start 1))
(index index (fix:+ index 1)))
((fix:= start end))
- (vector-8b-set! buffer index (vector-8b-ref string start))))
+ (bytevector-u8-set! buffer index
+ (bytevector-u8-ref string start))))
(set-car! ob new-index))
(do ((start start (fix:+ start 1)))
((fix:= start end))
- (write-byte state (vector-8b-ref string start))))))))
+ (write-byte state (bytevector-u8-ref string start))))))))
(define (flush-output-buffer state)
(let ((ob (output-buffer state))
(op (output-port state)))
(if (fix:< 0 (car ob))
- (output-port/write-substring op (cdr ob) 0 (car ob)))
- (output-port/flush-output op)))
+ (write-bytevector (cdr ob) op 0 (car ob)))
+ (flush-output-port op)))
(define (uncompress ifile ofile)
(uncompress-internal ifile ofile
(declare (usual-integrations))
(declare (integrate-external "infstr" "char"))
\f
-(define (initialize-package!)
- (set! special-form-procedure-names
- `((,lambda-tag:unnamed . LAMBDA)
- (,lambda-tag:internal-lambda . LAMBDA)
- (,lambda-tag:let . LET)
- (,lambda-tag:fluid-let . FLUID-LET)))
- (set! directory-rewriting-rules (make-settable-parameter '()))
- (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)))
(and wrapper
(loop (cdr left) time* file* receiver*)
(loop (cdr left) time file receiver))))))))
+(define (fasload-loader filename)
+ (call-with-current-continuation
+ (lambda (if-fail)
+ (bind-condition-handler (list condition-type:fasload-error
+ condition-type:file-error
+ condition-type:bad-range-argument)
+ (lambda (condition) condition (if-fail #f))
+ (lambda () (fasload filename #t))))))
+
(define (memoize-debugging-info! wrapper info)
(without-interruption
(lambda ()
(set-debugging-wrapper/info! wrapper #f)))
(empty-population! wrappers-with-memoized-debugging-info))
-(define wrappers-with-memoized-debugging-info)
+(define-deferred wrappers-with-memoized-debugging-info
+ (make-serial-population))
+
+(add-boot-init!
+ (lambda ()
+ (add-secondary-gc-daemon! discard-debugging-info!)))
\f
(define (compiled-entry/dbg-object entry #!optional demand-load?)
(let ((block (compiled-entry/block entry))
(if (compiled-closure? entry)
(compiled-entry/offset (compiled-closure->entry entry))
(compiled-code-address->offset entry)))
-\f
+
(define (compiled-entry/filename-and-index entry)
(compiled-code-block/filename-and-index (compiled-entry/block entry)))
(pathname=? (debugging-wrapper/pathname wrapper) pathname))
(set-debugging-wrapper/pathname! wrapper pathname*))))))
\f
-(define directory-rewriting-rules)
+(define-deferred directory-rewriting-rules
+ (make-settable-parameter '()))
(define (with-directory-rewriting-rule match replace thunk)
(parameterize*
(and association
(symbol->string (cdr association)))))
-(define special-form-procedure-names)
+(define-deferred special-form-procedure-names
+ `((,lambda-tag:unnamed . LAMBDA)
+ (,lambda-tag:internal-lambda . LAMBDA)
+ (,lambda-tag:let . LET)
+ (,lambda-tag:fluid-let . FLUID-LET)))
(define (compiled-procedure/lambda entry)
(let ((procedure (compiled-entry/dbg-object entry)))
(if (equal? "bcs" (pathname-type pathname))
(compressed-loader pathname)
(fasload-loader pathname)))))
-\f
+
;;;; Splitting of info structures
(define (inf->bif/bsm inffile)
;;;; UNCOMPRESS
;;; A simple extractor for compressed binary info files.
-(define-integrable window-size 4096)
+(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-ports input-port output-port #!optional buffer-size)
- (uncompress-kernel-by-blocks
- input-port output-port
- (if (default-object? buffer-size) 4096 buffer-size)
- input-port/read-substring!))
-
-(define (uncompress-read-substring port buffer start end)
- (let loop ((i start))
- (if (fix:>= i end)
- (fix:- i start)
- (let ((char (read-char port)))
- (if (not (char? char))
- (fix:- i start)
- (begin
- (string-set! buffer i char)
- (loop (fix:1+ i))))))))
+(define (uncompress-internal ifile ofile if-fail)
+ (call-with-binary-input-file (merge-pathnames ifile)
+ (lambda (input)
+ ;; This may get more hairy as we up versions
+ (if (read-compressed-file-marker input)
+ (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 (read-compressed-file-marker input)
+ (let ((n (bytevector-length compressed-file-marker)))
+ (let ((marker (read-bytevector n input)))
+ (and marker
+ (not (eof-object? marker))
+ (bytevector=? marker compressed-file-marker)))))
+
+(define (write-compressed-file-marker output)
+ (write-bytevector compressed-file-marker output))
+
+(define-deferred compressed-file-marker
+ (string->utf8 "Compressed-B1-1.00"))
\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
-;; operation, but that is the expected use.
+;; calling SOURCE on a bytevector range.
;;
;; This version is written for speed:
;;
;; is no unprocessed input, in which case we just tail out of the
;; loop.
-(define (uncompress-kernel-by-blocks input-port output-port buffer-size
- read-substring)
- (define-integrable input-size 4096)
- (let ((cp-table (make-vector window-size))
- (input-buffer (make-legacy-string input-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 (short-substring-move! s1 start1 end1 s2 start2)
- (do ((i1 start1 (fix:+ i1 1))
- (i2 start2 (fix:+ i2 1)))
- ((fix:= i1 end1))
- (string-set! s2 i2 (string-ref s1 i1))))
+(define (uncompress-ports input-port output-port #!optional buffer-size)
+ (uncompress-kernel-by-blocks
+ (lambda (bytes start end)
+ (let ((n (read-bytevector! bytes input-port start end)))
+ (if (or (not n) (eof-object? n))
+ 0
+ n)))
+ (lambda (bytes start end)
+ (write-bytevector bytes output-port start end))
+ (if (default-object? buffer-size) 4096 buffer-size)))
+\f
+(define (uncompress-kernel-by-blocks source sink output-size)
+ (define-integrable window-size #x1000)
+ (define-integrable input-size #x1000)
- (let parse-command ((bp 0) (cp 0) (ip 0) (ip-end 0)
- (buffer (make-legacy-string buffer-size))
- (buffer-size buffer-size))
- ;; Invariant: (SUBTRING BUFFER IP IP-END) is unprocessed input.
+ (let ((cp-table (make-vector window-size))
+ (input-buffer (make-bytevector input-size)))
+
+ (define-integrable (cp:++ cp)
+ (fix:and (fix:+ cp 1)
+ (fix:- window-size 1)))
+
+ (define-integrable (cp:- cp n)
+ (fix:and (fix:+ (fix:- cp n) window-size)
+ (fix:- window-size 1)))
+
+ (define (short-copy! to at from start end)
+ (do ((i start (fix:+ i 1))
+ (j at (fix:+ j 1)))
+ ((not (fix:< i end)) j)
+ (bytevector-u8-set! to j (bytevector-u8-ref from i))))
+
+ (let parse-command
+ ((ip 0)
+ (ip-end 0)
+ (cp 0)
+ (output-buffer (make-bytevector output-size))
+ (op 0)
+ (output-size output-size))
+
+ ;; Invariant:
+ ;; (BYTEVECTOR-COPY OUTPUT-BUFFER IP IP-END) is unprocessed input.
(define (retry-with-bigger-output-buffer)
- (let* ((new-size (fix:+ buffer-size (fix:quotient buffer-size 4)))
- (nbuffer (make-legacy-string new-size)))
- (string-copy! nbuffer 0 buffer)
- (parse-command bp cp ip ip-end nbuffer new-size)))
+ (let* ((new-size (fix:+ output-size (fix:lsh output-size -2)))
+ (output-buffer* (make-bytevector new-size)))
+ (bytevector-copy! output-buffer* 0 output-buffer)
+ (parse-command ip ip-end cp
+ output-buffer* op new-size)))
(define (refill-input-buffer-and-retry needed)
- (short-substring-move! input-buffer ip ip-end input-buffer 0)
- (let* ((left (fix:- ip-end ip))
- (count (read-substring input-port input-buffer
- left input-size))
- (total (fix:+ count left)))
- (if (fix:= count 0)
- (if (fix:< total needed)
- (error "Compressed input ends too soon"
- input-port 'UNCOMPRESS-KERNEL-BY-BLOCKS)
- (finished))
- (parse-command bp cp 0 total buffer buffer-size))))
-
- (define (finished)
- (output-port/write-substring output-port buffer 0 bp)
- bp)
-
+ (let* ((ip-end* (short-copy! input-buffer 0 input-buffer ip ip-end))
+ (n (source input-buffer ip-end* input-size)))
+ (if (fix:> n 0)
+ (parse-command 0 (fix:+ ip-end* n) cp
+ output-buffer op output-size)
+ (begin
+ (if (fix:< ip-end* needed)
+ (error "Compressed input ends too soon"
+ 'uncompress-kernel-by-blocks))
+ (sink output-buffer 0 op)
+ op))))
+
+ ;; Copy BYTE+1 bytes from input to output, and update CP-TABLE with their
+ ;; indices in the output buffer.
(define (literal-command byte)
- (let ((length (fix:+ byte 1))
- (ip* (fix:+ ip 1)))
- (let ((nbp (fix:+ bp length))
- (ncp (cp:+ cp length))
- (nip (fix:+ ip* length)))
- (if (fix:> nbp buffer-size)
- (retry-with-bigger-output-buffer)
- (if (fix:> nip ip-end)
- (refill-input-buffer-and-retry (fix:+ length 1))
- (begin
- (short-substring-move! input-buffer ip* nip buffer bp)
- (do ((bp bp (fix:+ bp 1)) (cp cp (cp:+ cp 1)))
- ((fix:= bp nbp))
- (vector-set! cp-table cp bp))
- (parse-command nbp ncp nip ip-end buffer
- buffer-size)))))))
-
+ (let* ((ip (fix:+ ip 1))
+ (ip* (fix:+ ip (fix:+ byte 1)))
+ (op* (fix:+ op (fix:+ byte 1))))
+ (if (fix:<= op* output-size)
+ (if (fix:<= ip* ip-end)
+ (begin
+ (short-copy! output-buffer op input-buffer ip ip*)
+ (do ((op op (fix:+ op 1))
+ (cp cp (cp:++ cp)))
+ ((not (fix:< op op*))
+ (parse-command ip* ip-end cp
+ output-buffer op* output-size))
+ (vector-set! cp-table cp op)))
+ (refill-input-buffer-and-retry (fix:+ byte 2)))
+ (retry-with-bigger-output-buffer))))
+
+ ;; Copy bytes from earlier in the output to here. Start and length are
+ ;; encoded in BYTE and the next input byte.
(define (copy-command byte)
- (let ((ip* (fix:+ ip 1)))
- (if (fix:>= ip* ip-end)
- (refill-input-buffer-and-retry 2)
- (let ((cpi (displacement->cp-index
- (fix:+ (fix:* (fix:remainder byte 16) 256)
- (vector-8b-ref input-buffer ip*))
- cp))
- (length (fix:+ (fix:quotient byte 16) 1)))
- (let ((bp* (vector-ref cp-table cpi))
- (nbp (fix:+ bp length))
- (ncp (cp:+ cp 1)))
- (if (fix:> nbp buffer-size)
- (retry-with-bigger-output-buffer)
- (let ((end-bp* (fix:+ bp* length)))
- (short-substring-move! buffer bp* end-bp* buffer bp)
- (vector-set! cp-table cp bp)
- (parse-command nbp ncp (fix:+ ip 2) ip-end
- buffer buffer-size))))))))
-
- (if (fix:>= ip ip-end)
- (refill-input-buffer-and-retry 0)
- (let ((byte (vector-8b-ref input-buffer ip)))
- (if (fix:< byte 16)
+ (let ((ip (fix:+ ip 1)))
+ (if (fix:< ip ip-end)
+ (let ((ostart
+ (vector-ref cp-table
+ (cp:- cp
+ (fix:or (fix:lsh (fix:and byte #x0F) 8)
+ (bytevector-u8-ref input-buffer
+ ip)))))
+ (length (fix:+ (fix:lsh byte -4) 1)))
+ (let ((op* (fix:+ op length)))
+ (if (fix:<= op* output-size)
+ (begin
+ (short-copy! output-buffer op
+ output-buffer ostart (fix:+ ostart length))
+ (vector-set! cp-table cp op)
+ (parse-command (fix:+ ip 1) ip-end (cp:++ cp)
+ output-buffer op* output-size))
+ (retry-with-bigger-output-buffer))))
+ (refill-input-buffer-and-retry 2))))
+
+ (if (fix:< ip ip-end)
+ (let ((byte (bytevector-u8-ref input-buffer ip)))
+ (if (fix:< byte #x10)
(literal-command byte)
- (copy-command byte)))))))
-\f
-(define (fasload-loader filename)
- (call-with-current-continuation
- (lambda (if-fail)
- (bind-condition-handler (list condition-type:fasload-error
- condition-type:file-error
- condition-type:bad-range-argument)
- (lambda (condition) condition (if-fail #f))
- (lambda () (fasload filename #t))))))
-
-(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-legacy-binary-input-file (merge-pathnames ifile)
- (lambda (input)
- (let* ((file-marker "Compressed-B1-1.00")
- (marker-size (string-length file-marker))
- (actual-marker (make-legacy-string marker-size)))
- ;; This may get more hairy as we up versions
- (if (and (fix:= (uncompress-read-substring input
- actual-marker 0 marker-size)
- marker-size)
- (string=? file-marker actual-marker))
- (call-with-legacy-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))))))
\ No newline at end of file
+ (copy-command byte)))
+ (refill-input-buffer-and-retry 0)))))
\ No newline at end of file
projects / mit-scheme.git / commitdiff