cs: sync with revised fasl compression for code

Sync with changes from cisco/ChezScheme. The specific code fragments
that are compressed and the chunks that are used for compression
remain essentially the same as before for Racket CS, but a different
organization at the Chez Scheme level takes over some of the work that
was on the Racket CS linklet layer, and load times may improve
slightly.

pkgs/base/info.rkt

@@ -12,7 +12,7 @@
 
 (define collection 'multi)
 
-(define version "7.8.0.2")
+(define version "7.8.0.3")
 
 (define deps `("racket-lib"
                ["racket" #:version ,version]))

racket/src/cs/c/adjust-compress.rkt

@@ -2,7 +2,8 @@
 (require racket/file
          racket/system
          file/gzip
-         file/gunzip)
+         file/gunzip
+         ffi/unsafe)
 
 (provide enable-compress!
          compress-enabled?
@@ -36,52 +37,155 @@
         (loop)))
     (get-output-bytes o)))
 
-(define (lz4 flag bstr)
+(define (lz4-d result-size bstr)
-  (define o (open-output-bytes))
+  (define lz4 (ffi-lib "liblz4"))
-  (unless (parameterize ([current-input-port (open-input-bytes bstr)]
+  (define LZ4_decompress_safe (get-ffi-obj 'LZ4_decompress_safe lz4 (_fun _pointer _pointer _int _int -> _int)))
-                         [current-output-port o])
+  (define r-bstr (make-bytes result-size))
-            (define lz4 (or (find-executable-path "lz4")
+  (when (negative? (LZ4_decompress_safe bstr r-bstr (bytes-length bstr) (bytes-length r-bstr)))
-                            (error 'adjust-compress "could not find `lz4` executable, which is needed to adjust bootfile compression")))
+    (error 'lz4 "decompression failed"))
-            (system* lz4 flag))
+  r-bstr)
-    (error "lz4 failed"))
+
-  (get-output-bytes o))
+(define (lz4-z bstr)
+  (define lz4 (ffi-lib "liblz4"))
+  (define LZ4_compressBound (get-ffi-obj 'LZ4_compressBound lz4 (_fun _int -> _int)))
+  (define LZ4_compress_default (get-ffi-obj 'LZ4_compress_default lz4 (_fun _pointer _pointer _int _int -> _int)))
+  (define max-len (LZ4_compressBound (bytes-length bstr)))
+  (define r-bstr (make-bytes max-len))
+  (define len (LZ4_compress_default bstr r-bstr (bytes-length bstr) (bytes-length r-bstr)))
+  (subbytes r-bstr 0 len))
+
+(define (adler32 bstr)
+  (define BASE 65521)
+  (define-values (s1 s2)
+    (for/fold ([prev-s1 1] [s2 0]) ([b (in-bytes bstr)])
+      (define s1 (modulo (+ prev-s1 b) BASE))
+      (values s1 (modulo (+ s2 s1) BASE))))
+  (integer->integer-bytes (+ s1 (arithmetic-shift s2 16)) 4 #f #t))
+
+(define fasl-type-uncompressed 43)
+(define fasl-type-gzip         44)
+(define fasl-type-lz4          45)
+
+(define (read-byte/not-eof in)
+  (define b (read-byte in))
+  (when (eof-object? b)
+    (error "unexpected eof"))
+  b)
+
+(define (read-uptr in)
+  (let ([k (read-byte/not-eof in)])
+    (let loop ([k k] [n 0])
+      (let ([n (bitwise-ior n (bitwise-and k #x7F))])
+        (if (zero? (bitwise-and k #x80))
+            n
+            (loop (read-byte/not-eof in) (arithmetic-shift n 7)))))))
+
+(define (write-uptr n out)
+  (let loop ([n n] [cbit 0])
+    (unless (n . <= . #x7F)
+      (loop (arithmetic-shift n -7) #x80))
+    (write-byte (bitwise-ior (bitwise-and n #x7F) cbit) out)))
+
+(define (uptr-bytes n)
+  (if (n . <= . #x7F)
+      1
+      (add1 (uptr-bytes (arithmetic-shift n -7)))))
 
 (define (adjust-compress bstr)
-  (cond
+  (define in (open-input-bytes bstr))
-    [(bytes=? #"\0\0\0\0chez" (subbytes bstr 0 8))
+  (define out (open-output-bytes bstr))
-     ;; source is not compressed
+  (let loop ([saw-header? #f])
-     (cond
+    (cond
-       [(and compress? (eq? compress-format 'gzip))
+      [(regexp-try-match #"^\0\0\0\0chez" in)
-        (reencode bstr (lambda (i o) (gzip-through-ports i o #f 0)))]
+       ;; copy header
-       [(and compress? (eq? compress-format 'lz4))
+       (define vers (read-uptr in))
-        (lz4 "-z" bstr)]
+       (define mach (read-uptr in))
-       [else bstr])]
+       (define s (regexp-try-match	#rx"^[(][^)]*[)]" in))
-    [(bytes=? #"\4\"M\30" (subbytes bstr 0 4))
+       (unless s
-     ;; source is LZ4
+         (error 'adjust-compress "did not find (...)" (file-position in)))
-     (cond
+       (write-bytes #"\0\0\0\0chez" out)
-       [(and compress? (eq? compress-format 'gzip))
+       (write-uptr vers out)
-        (reencode (lz4 "-d" bstr) (lambda (i o) (gzip-through-ports i o #f 0)))]
+       (write-uptr mach out)
-       [(and compress? (eq? compress-format 'lz4))
+       (write-bytes (car s) out)
-        bstr]
+       (loop #t)]
-       [else (lz4 "-d" bstr)])]
+      [(not saw-header?)
-    [(bytes=? #"\37\213\b" (subbytes bstr 0 3))
+       (error 'adjust-compress "did not find leading header")]
-     ;; source is gzip
+      [else
-     (cond
+       (let ([situation (read-byte in)])
-       [(and compress? (eq? compress-format 'gzip))
+         (unless (eof-object? situation)
-        bstr]
+           (let ([size (- (read-uptr in) 2)] ; size in fasl includes compression + kind
-       [(and compress? (eq? compress-format 'lz4))
+                 [compression (read-byte/not-eof in)]
-        (lz4 "-z" (reencode bstr gunzip-through-ports))]
+                 [kind (read-byte/not-eof in)])
-       [else
+             (define-values (bstr compressed dest-size)
-        (reencode bstr gunzip-through-ports)])]
+               (cond
-    [else (error 'adjust-compress "unrecognized format ~s" (subbytes bstr 0 3))]))
+                 [(eqv? compression fasl-type-uncompressed)
+                  ;; source is not compressed
+                  (values (read-bytes size in) #f #f)]
+                 [else
+                  (define dest-size (read-uptr in))
+                  (define c-bstr (read-bytes (- size (uptr-bytes dest-size)) in))
+                  (cond
+                    [(eqv? compression fasl-type-gzip)
+                     (if (and compress? (eq? compress-format 'gzip))
+                         (values c-bstr 'gzip dest-size)
+                         (let ([c-bstr (subbytes c-bstr 2 (- (bytes-length c-bstr 4)))])
+                           (values (reencode c-bstr inflate) #f #f)))]
+                    [(eqv? compression fasl-type-lz4)
+                     (if (and compress? (eq? compress-format 'lz4))
+                         (values c-bstr 'lz4 dest-size)
+                         (values (lz4-d dest-size c-bstr) #f #f))]
+                    [else
+                     (error 'adjust-compress "unrecognized compression ~s" compression)])]))
+             (cond
+               [(or (not compress?)
+                    (and (not compressed)
+                         ((bytes-length bstr) . < . 100)))
+                (write-byte situation out)
+                (write-uptr (+ (bytes-length bstr) 2) out)
+                (write-byte fasl-type-uncompressed out)
+                (write-byte kind out)
+                (write-bytes bstr out)]
+               [else
+                (define d-size (or dest-size
+                                    (bytes-length bstr)))
+                (define c-bstr
+                  (if compressed
+                      bstr
+                      (cond
+                        [(eq? compress-format 'gzip)
+                         (bytes-append #"\x78\x5e"
+                                       (reencode bstr (lambda (i o) (deflate i o)))
+                                       (adler32 bstr))]
+                        [(eq? compress-format 'lz4)
+                         (lz4-z bstr)]
+                        [else
+                         (error 'adjust-compress "unsupported ~s" compress-format)])))
+                (write-byte situation out)
+                (write-uptr (+ (bytes-length c-bstr) (uptr-bytes d-size) 2) out)
+                (write-byte (cond
+                              [(eq? compress-format 'gzip) fasl-type-gzip]
+                              [(eq? compress-format 'lz4) fasl-type-lz4]
+                              [else (error 'adjust-compress "unsupported ~s" compress-format)])
+                            out)
+                (write-byte kind out)
+                (write-uptr d-size out)
+                (write-bytes c-bstr out)]))
+           (loop #t)))]))
+  (get-output-bytes out))
        
 (module+ main
   (require racket/cmdline)
       
   (command-line
-   #:once-each
+   #:once-any
-   [("--compress") "Leave compiled code files as compressed"
+   [("--uncompressed") "Uncompress compiled code"
-    (enable-compress!)]
+                       (void)]
+   [("--gzip") "Compress using gzip"
+               (enable-compress!)
+               (set-compress-format! 'gzip)]
+   [("--lz4") "Compress using lz4"
+              (enable-compress!)
+              (set-compress-format! 'lz4)]
    #:args path
    (for ([path (in-list path)])
      (define bstr (file->bytes path))

racket/src/cs/c/convert-to-boot.ss

@@ -1,11 +1,11 @@
-(compile-compressed #f)
+(fasl-compressed #f)
 
 (define-values (src dest machine)
   (let loop ([args (command-line-arguments)])
     (cond
       [(and (pair? args)
             (equal? (car args) "--compress"))
-       (compile-compressed #t)
+       (fasl-compressed #t)
        (loop (cdr args))]
       [(and (pair? args)
             (equal? (car args) "--xpatch")

racket/src/cs/c/embed-boot.rkt

@@ -45,11 +45,8 @@
                            (delete-file dest-file))
                          (raise x))])
    (define terminator
-     (if (compress-enabled?)
+     ;; A 127 byte teriminates a fasl-read sequence
-         ;; zero byte stops a gzip-read sequence
+     #"\177")
-         #"\0"
-         ;; A 127 byte teriminates a fasl-read sequence
-         #"\177"))
    (define data
      (bytes-append bstr1 terminator
                    bstr2 terminator

racket/src/cs/c/to-vfasl.ss

@@ -1,4 +1,4 @@
-(compile-compressed #f)
+(fasl-compressed #f)
 (define compile-cross? #f)
 
 (define-values (src dest deps)
@@ -6,7 +6,7 @@
     (cond
       [(and (pair? args)
             (equal? (car args) "--compress"))
-       (compile-compressed #t)
+       (fasl-compressed #t)
        (loop (cdr args))]
       [(and (pair? args)
             (equal? (car args) "--cross"))

racket/src/cs/compile-file.ss

@@ -2,7 +2,7 @@
 ;; Check to make we're using a build of Chez Scheme
 ;; that has all the features we need.
 (define-values (need-maj need-min need-sub need-dev)
-  (values 9 5 3 32))
+  (values 9 5 3 33))
 
 (unless (guard (x [else #f]) (eval 'scheme-fork-version-number))
   (error 'compile-file
@@ -42,7 +42,7 @@
 (define whole-program? #f)
 (generate-inspector-information #f)
 (generate-procedure-source-information #f)
-(compile-compressed #f)
+(fasl-compressed #f)
 (enable-arithmetic-left-associative #t)
 (define build-dir "")
 (define xpatch-path #f)
@@ -64,7 +64,7 @@
            (loop args))]
      [(get-opt args "--compress" 0)
       => (lambda (args)
-           (compile-compressed #t)
+           (fasl-compressed #t)
            (putenv "PLT_CS_MAKE_COMPRESSED" "y") ; for "linklet.sls"
            (loop args))]
      [(get-opt args "--whole-program" 0)

racket/src/cs/linklet.sls

@@ -235,8 +235,14 @@
     (call-with-system-wind (lambda () (interpret e))))
   (define (fasl-write* s o)
     (call-with-system-wind (lambda () (fasl-write s o))))
+  (define (fasl-write-code* s o)
+    (call-with-system-wind (lambda ()
+                             (parameterize ([fasl-compressed compress-code?])
+                               (fasl-write s o)))))
   (define (compile-to-port* s o)
-    (call-with-system-wind (lambda () (compile-to-port s o))))
+    (call-with-system-wind (lambda ()
+                             (parameterize ([fasl-compressed compress-code?])
+                               (compile-to-port s o)))))
 
   (define (eval/foreign e mode)
     (performance-region
@@ -275,49 +281,36 @@
       (get)))
 
   (define (compile-to-bytevector s paths format)
-    (let ([bv (cond
+    (cond
-               [(eq? format 'interpret)
+      [(eq? format 'interpret)
-                (let-values ([(o get) (open-bytevector-output-port)])
+       (let-values ([(o get) (open-bytevector-output-port)])
-                  (fasl-write* s o)
+         (fasl-write-code* s o)
-                  (get))]
+         (get))]
-               [else (compile*-to-bytevector s)])])
+      [else (compile*-to-bytevector s)]))
-      (if compress-code?
-          (bytevector-compress bv)
-          bv)))
 
   (define (make-cross-compile-to-bytevector machine)
     (lambda (s paths format)
-      (let ([bv (cond
-                 [(eq? format 'interpret) (cross-fasl-to-string machine s)]
-                 [else (cross-compile machine s)])])
-        (if compress-code?
-            (bytevector-compress bv)
-            bv))))
-
-  (define (eval-from-bytevector c-bv paths format)
-    (let ([bv (if (bytevector-uncompressed-fasl? c-bv)
-                  c-bv
-                  (begin
-                    (add-performance-memory! 'uncompress (bytevector-length c-bv))
-                    (performance-region
-                     'uncompress
-                     (bytevector-uncompress c-bv))))])
-      (add-performance-memory! 'faslin-code (bytevector-length bv))
       (cond
-       [(eq? format 'interpret)
+        [(eq? format 'interpret) (cross-fasl-to-string machine s)]
-        (let ([r (performance-region
+        [else (cross-compile machine s)])))
-                  'faslin-code
+
-                  (fasl-read (open-bytevector-input-port bv)))])
+  (define (eval-from-bytevector bv paths format)
-          (performance-region
+    (add-performance-memory! 'faslin-code (bytevector-length bv))
-           'outer
+    (cond
-           (run-interpret r paths)))]
+      [(eq? format 'interpret)
-       [else
+       (let ([r (performance-region
-        (let ([proc (performance-region
+                 'faslin-code
-                     'faslin-code
+                 (fasl-read (open-bytevector-input-port bv)))])
-                     (code-from-bytevector bv))])
+         (performance-region
-          (if (null? paths)
+          'outer
-              proc
+          (run-interpret r paths)))]
-              (#%apply proc paths)))])))
+      [else
+       (let ([proc (performance-region
+                    'faslin-code
+                    (code-from-bytevector bv))])
+         (if (null? paths)
+             proc
+             (#%apply proc paths)))]))
 
   (define (code-from-bytevector bv)
     (let ([i (open-bytevector-input-port bv)])
@@ -326,21 +319,6 @@
          'outer
          (r)))))
 
-  (define (bytevector-uncompressed-fasl? bv)
-    ;; There's not actually a way to distinguish a fasl header from a
-    ;; compression header, but the fasl header as a compression header
-    ;; would mean a > 1GB uncompressed bytevector, so we can safely
-    ;; assume that it's a fasl stream in that case.
-    (and (> (bytevector-length bv) 8)
-         (fx= 0 (bytevector-u8-ref bv 0))
-         (fx= 0 (bytevector-u8-ref bv 1))
-         (fx= 0 (bytevector-u8-ref bv 2))
-         (fx= 0 (bytevector-u8-ref bv 3))
-         (fx= (char->integer #\c) (bytevector-u8-ref bv 4))
-         (fx= (char->integer #\h) (bytevector-u8-ref bv 5))
-         (fx= (char->integer #\e) (bytevector-u8-ref bv 6))
-         (fx= (char->integer #\z) (bytevector-u8-ref bv 7))))
-
   (define-record-type wrapped-code
     (fields (mutable content) ; bytevector for 'lambda mode; annotation or (vector hash annotation) for 'jit mode
             arity-mask
@@ -1231,6 +1209,8 @@
   (enable-arithmetic-left-associative #t)
   (expand-omit-library-invocations #t)
   (enable-error-source-expression #f)
+  (fasl-compressed #f)
+  (compile-omit-concatenate-support #t)
 
   ;; Avoid gensyms for generated record-tyope UIDs. Otherwise,
   ;; printing one of those gensyms --- perhaps when producing a trace

racket/src/cs/linklet/write.ss

@@ -46,19 +46,10 @@
 
 ;; Before fasl conversion, change 'cross or 'faslable-unsafe to 'faslable
 (define (adjust-cross-perparation l)
-  (adjust-linklet-compress
+  (let ([p (linklet-preparation l)])
-   (let ([p (linklet-preparation l)])
+    (if (or (pair? p) (eq? p 'faslable-unsafe))
-     (if (or (pair? p) (eq? p 'faslable-unsafe))
+        (set-linklet-preparation l 'faslable)
-         (set-linklet-preparation l 'faslable)
+        l)))
-         l))))
-
-(define (adjust-linklet-compress l)
-  (if (or compress-code?
-          (bytevector-uncompressed-fasl? (linklet-code l)))
-      l
-      (set-linklet-code l
-                        (bytevector-uncompress (linklet-code l))
-                        (linklet-preparation l))))
 
 (define (check-fasl-preparation l)
   (case (linklet-preparation l)

racket/src/racket/src/schvers.h

@@ -16,7 +16,7 @@
 #define MZSCHEME_VERSION_X 7
 #define MZSCHEME_VERSION_Y 8
 #define MZSCHEME_VERSION_Z 0
-#define MZSCHEME_VERSION_W 2
+#define MZSCHEME_VERSION_W 3
 
 /* A level of indirection makes `#` work as needed: */
 #define AS_a_STR_HELPER(x) #x