From 18db8085427334e01af74aa8e1afe46b0d7eca9b Mon Sep 17 00:00:00 2001
From: Chris Hanson <org/chris-hanson/cph>
Date: Sat, 29 Apr 2017 01:00:17 -0700
Subject: [PATCH] Refactor compressor/decompressor to use bytevectors and
 binary ports.

---
 src/runtime/cpress.scm  | 115 ++++++++-------
 src/runtime/infutl.scm  | 317 ++++++++++++++++++++--------------------
 src/runtime/runtime.pkg |   3 +-
 3 files changed, 221 insertions(+), 214 deletions(-)

diff --git a/src/runtime/cpress.scm b/src/runtime/cpress.scm
index b40a87f9c..3e99f5527 100644
--- a/src/runtime/cpress.scm
+++ b/src/runtime/cpress.scm
@@ -86,11 +86,11 @@ USA.
 ;;; determines the algorithm.
 
 (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
@@ -118,11 +118,11 @@ USA.
   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)
@@ -240,7 +240,7 @@ USA.
   (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)
@@ -251,7 +251,7 @@ USA.
 	  (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)
@@ -267,25 +267,25 @@ USA.
 		  (replace-child state node parent)
 		  (add-child state parent byte* node)
 		  (add-child state parent byte (make-node state 0)))
-		false))))))
+		#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.
@@ -293,8 +293,8 @@ USA.
 
   ;; 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
@@ -322,7 +322,7 @@ USA.
 	  (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)
@@ -362,7 +362,7 @@ USA.
 	     ((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
@@ -373,15 +373,15 @@ USA.
 	  ;; 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)
@@ -415,7 +415,7 @@ USA.
 ;;; 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
@@ -423,16 +423,16 @@ USA.
 (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
@@ -454,8 +454,8 @@ USA.
 
 (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
@@ -480,11 +480,11 @@ USA.
 
 (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)))))
 
 (define (guarantee-buffer-data state bb probe?)
   ;; We have read all of the bytes in the buffer, so it's time to get
@@ -493,7 +493,7 @@ USA.
   ;; 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)))
@@ -504,34 +504,32 @@ USA.
 	;; 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
@@ -665,7 +663,7 @@ USA.
 	 (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)
@@ -676,15 +674,15 @@ USA.
 	(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))))))
 
@@ -698,18 +696,19 @@ USA.
 		(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
diff --git a/src/runtime/infutl.scm b/src/runtime/infutl.scm
index 3e50b8aeb..1727522d5 100644
--- a/src/runtime/infutl.scm
+++ b/src/runtime/infutl.scm
@@ -30,16 +30,6 @@ USA.
 (declare (usual-integrations))
 (declare (integrate-external "infstr" "char"))
 
-(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
@@ -82,6 +72,15 @@ USA.
 		    (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 ()
@@ -94,7 +93,12 @@ USA.
 			 (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!)))
 
 (define (compiled-entry/dbg-object entry #!optional demand-load?)
   (let ((block (compiled-entry/block entry))
@@ -139,7 +143,7 @@ USA.
   (if (compiled-closure? entry)
       (compiled-entry/offset (compiled-closure->entry entry))
       (compiled-code-address->offset entry)))
-
+
 (define (compiled-entry/filename-and-index entry)
   (compiled-code-block/filename-and-index (compiled-entry/block entry)))
 
@@ -209,7 +213,8 @@ USA.
 		 (pathname=? (debugging-wrapper/pathname wrapper) pathname))
 	    (set-debugging-wrapper/pathname! wrapper pathname*))))))
 
-(define directory-rewriting-rules)
+(define-deferred directory-rewriting-rules
+  (make-settable-parameter '()))
 
 (define (with-directory-rewriting-rule match replace thunk)
   (parameterize*
@@ -341,7 +346,11 @@ USA.
     (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)))
@@ -396,7 +405,7 @@ USA.
 	 (if (equal? "bcs" (pathname-type pathname))
 	     (compressed-loader pathname)
 	     (fasload-loader pathname)))))
-
+
 ;;;; Splitting of info structures
 
 (define (inf->bif/bsm inffile)
@@ -434,29 +443,44 @@ USA.
 ;;;; 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"))
 
 ;; 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:
 ;;
@@ -490,130 +514,113 @@ USA.
 ;;    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)))
+
+(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)))))))
-
-(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
diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 4040dcaa8..f313c27bb 100644
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -1464,7 +1464,8 @@ USA.
 	  dbg-procedure/source-code
 	  dbg-expression?)
   (export (runtime compress)
-	  uncompress-internal)
+	  uncompress-internal
+	  write-compressed-file-marker)
   (export (runtime options)
 	  with-directory-rewriting-rule)
   (initialization (initialize-package!)))
-- 
2.25.1