racket/s/strip.ss

;;; strip.ss
;;; Copyright 1984-2017 Cisco Systems, Inc.
;;; 
;;; Licensed under the Apache License, Version 2.0 (the "License");
;;; you may not use this file except in compliance with the License.
;;; You may obtain a copy of the License at
;;; 
;;; http://www.apache.org/licenses/LICENSE-2.0
;;; 
;;; Unless required by applicable law or agreed to in writing, software
;;; distributed under the License is distributed on an "AS IS" BASIS,
;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
;;; See the License for the specific language governing permissions and
;;; limitations under the License.

(let ()
  ; per file
  (define-threaded fasl-who)
  (define-threaded fasl-count)

  (define-datatype fasl
    (entry fasl)
    (header version machine dependencies)
    (pair vfasl)
    (tuple ty vfasl)
    (string ty string)
    (gensym pname uname)
    (vector ty vfasl)
    (fxvector ty viptr)
    (bytevector ty bv)
    (record maybe-uid size nflds rtd pad-ty* fld*) ; maybe-uid => rtd
    (closure offset c)
    (flonum high low)
    (small-integer iptr)
    (large-integer sign vuptr)
    (eq-hashtable mutable? subtype minlen veclen vpfasl)
    (symbol-hashtable mutable? minlen equiv veclen vpfasl)
    (code flags free name arity-mask info pinfo* bytes m vreloc)
    (atom ty uptr)
    (reloc type-etc code-offset item-offset fasl)
    (indirect g i)
    (group vfasl)
    (visit fasl)
    (revisit fasl))

  (define-datatype field
    (ptr fasl)
    (byte n)
    (iptr n)
    (single n)
    (double high low))

  (define follow-indirect
    (lambda (x)
      (fasl-case x
        [indirect (g i) (follow-indirect (vector-ref g i))]
        [else x])))

  (define-syntax bogus
    (lambda (x)
      (syntax-case x ()
        [(_ msg arg ...)
         (string? (datum msg))
         #`($oops fasl-who #,(string-append (datum msg) " within fasl entry ~d") arg ... fasl-count)])))

  (define-syntax sorry!
    (syntax-rules ()
      [(_ str arg ...) ($oops 'fasl-internal str arg ...)]))

  (module (read-entry)
    (define-syntax fasl-type-case
      (syntax-rules (else)
        [(_ e0 [(k ...) e1 e2 ...] ... [else ee1 ee2 ...])
         (let ([x e0])
           (cond
             [(memv x (list (constant k) ...)) e1 e2 ...]
             ...
             [else ee1 ee2 ...]))]))
    (define read-iptr
      (lambda (p)
        (let ([k0 (read-byte p)])
          (let f ([k k0] [n (fxsrl (fxlogand k0 #x7f) 1)])
            (if (fxlogbit? 0 k)
                (let ([k (read-byte p)])
                  (f k (logor (ash n 7) (fxsrl k 1))))
                (if (fxlogbit? 7 k0) (- n) n))))))
    (define read-uptr
      (lambda (p)
        (let ([k (read-byte p)])
          (let f ([k k] [n (fxsrl k 1)])
            (if (fxlogbit? 0 k)
                (let ([k (read-byte p)])
                  (f k (logor (ash n 7) (fxsrl k 1))))
                n)))))
    (define read-byte-or-eof
      (lambda (p)
        (get-u8 p)))
    (define read-byte
      (lambda (p)
        (let ([b (get-u8 p)])
          (when (eof-object? b) (bogus "unexpected eof in ~a" (port-name p)))
          b)))
    (define (read-byte! x p)
      (let ([y (read-byte p)])
        (unless (eqv? y x)
          (bogus "expected byte ~s, got ~s from ~a" x y (port-name p)))))
    (define read-string
      (lambda (p)
        (let ([n (read-uptr p)])
          (let ([s (make-string n)])
            (do ([i 0 (+ i 1)])
                ((= i n))
              (string-set! s i (integer->char (read-uptr p))))
            s))))
    (define (read-entry p)
      (let ([ty (read-byte-or-eof p)])
        (if (eof-object? ty)
            ty
            (fasl-type-case ty
              [(fasl-type-header) (read-header p)]
              [(fasl-type-fasl-size)
               (let ([size (read-uptr p)])
                 (fasl-entry (read-fasl p #f)))]
              [else (bogus "expected header or entry in ~a" (port-name p))]))))
    (define (read-header p)
      (let* ([bv (constant fasl-header)] [n (bytevector-length bv)])
        (do ([i 1 (fx+ i 1)])
            ((fx= i n))
          (read-byte! (bytevector-u8-ref bv i) p)))
      (let* ([version (read-uptr p)]
             [machine (read-uptr p)])
        (unless (eqv? version (constant scheme-version))
          (bogus "expected version ~a, but found ~a in ~a"
            ($format-scheme-version (constant scheme-version))
            ($format-scheme-version version)
            (port-name p)))
        (read-byte! (char->integer #\() p) ;)
        (fasl-header version machine
          (let f () ;(
            (let ([c (read-byte p)])
              (if (eqv? c (char->integer #\)))
                  '()
                  (cons c (f))))))))
    (define (read-fld p g ty)
      (define (read-double p)
        (let* ([high (read-uptr p)]
               [low (read-uptr p)])
          (field-double high low)))
      (fasl-type-case ty
        [(fasl-fld-ptr) (field-ptr (read-fasl p g))]
        [(fasl-fld-u8) (field-byte (read-byte p))]
        [(fasl-fld-i16) (field-iptr (read-iptr p))]
        [(fasl-fld-i24) (field-iptr (read-iptr p))]
        [(fasl-fld-i32) (field-iptr (read-iptr p))]
        [(fasl-fld-i40) (field-iptr (read-iptr p))]
        [(fasl-fld-i48) (field-iptr (read-iptr p))]
        [(fasl-fld-i56) (field-iptr (read-iptr p))]
        [(fasl-fld-i64) (field-iptr (read-iptr p))]
        [(fasl-fld-single) (field-single (read-uptr p))]
        [(fasl-fld-double) (read-double p)]
        [else (bogus "unexpected record fld type ~s in ~a" ty (port-name p))]))
    (define (read-vfasl p g n)
      (let ([v (make-vector n)])
        (do ([i 0 (fx+ i 1)])
          ((fx= i n) v)
          (vector-set! v i (read-fasl p g)))))
    (define (read-vpfasl p g)
      (let ([n (read-uptr p)])
        (let ([v (make-vector n)])
          (do ([i 0 (fx+ i 1)])
            ((fx= i n) v)
            (vector-set! v i
              (let ([key (read-fasl p g)])
                (cons key (read-fasl p g))))))))
    (define (read-record p g maybe-uid)
      (let* ([size (read-uptr p)] [nflds (read-uptr p)] [rtd (read-fasl p g)])
        (let loop ([n nflds] [rpad-ty* '()] [rfld* '()])
          (if (fx= n 0)
              (fasl-record maybe-uid size nflds rtd (reverse rpad-ty*) (reverse rfld*))
              (let* ([pad-ty (read-byte p)] [fld (read-fld p g (fxlogand pad-ty #x0f))])
                (loop (fx- n 1) (cons pad-ty rpad-ty*) (cons fld rfld*)))))))
    (define (read-fasl p g)
      (let ([ty (read-byte p)])
        (fasl-type-case ty
          [(fasl-type-pair) (fasl-pair (read-vfasl p g (+ (read-uptr p) 1)))]
          [(fasl-type-box fasl-type-immutable-box) (fasl-tuple ty (vector (read-fasl p g)))]
          [(fasl-type-symbol) (fasl-string ty (read-string p))]
          [(fasl-type-gensym)
           (let* ([pname (read-string p)] [uname (read-string p)])
             (fasl-gensym pname uname))]
          [(fasl-type-ratnum fasl-type-exactnum fasl-type-inexactnum fasl-type-weak-pair)
           (let ([first (read-fasl p g)])
             (fasl-tuple ty (vector first (read-fasl p g))))]
          [(fasl-type-vector fasl-type-immutable-vector) (fasl-vector ty (read-vfasl p g (read-uptr p)))]
          [(fasl-type-fxvector fasl-type-immutable-fxvector)
           (fasl-fxvector
             ty
             (let ([n (read-uptr p)])
               (let ([v (make-vector n)])
                 (do ([i 0 (fx+ i 1)])
                     ((fx= i n) v)
                   (vector-set! v i (read-iptr p))))))]
          [(fasl-type-bytevector fasl-type-immutable-bytevector)
           (fasl-bytevector
             ty
             (let ([n (read-uptr p)])
               (let ([bv (make-bytevector n)])
                 (do ([i 0 (fx+ i 1)])
                     ((fx= i n) bv)
                   (bytevector-u8-set! bv i (read-byte p))))))]
          [(fasl-type-base-rtd) (fasl-tuple ty '#())]
          [(fasl-type-rtd) (read-record p g (read-fasl p g))]
          [(fasl-type-record) (read-record p g #f)]
          [(fasl-type-closure)
           (let* ([offset (read-uptr p)]
                  [c (read-fasl p g)])
             (fasl-closure offset c))]
          [(fasl-type-flonum)
           (let* ([high (read-uptr p)]
                  [low (read-uptr p)])
             (fasl-flonum high low))]
          [(fasl-type-string fasl-type-immutable-string) (fasl-string ty (read-string p))]
          [(fasl-type-small-integer) (fasl-small-integer (read-iptr p))]
          [(fasl-type-large-integer)
           (let* ([sign (read-byte p)]
                  [n (read-uptr p)])
             (fasl-large-integer sign
               (let ([v (make-vector n)])
                 (do ([i 0 (fx+ i 1)])
                     ((fx= i n) v)
                   (vector-set! v i (read-uptr p))))))]
          [(fasl-type-eq-hashtable)
           (let* ([mutable? (read-byte p)]
                  [subtype (read-byte p)]
                  [minlen (read-uptr p)]
                  [veclen (read-uptr p)]
                  [v (read-vpfasl p g)])
             (fasl-eq-hashtable mutable? subtype minlen veclen v))]
          [(fasl-type-symbol-hashtable)
           (let* ([mutable? (read-byte p)]
                  [minlen (read-uptr p)]
                  [equiv (read-byte p)]
                  [veclen (read-uptr p)]
                  [v (read-vpfasl p g)])
             (fasl-symbol-hashtable mutable? minlen equiv veclen v))]
          [(fasl-type-code)
           (let* ([flags (read-byte p)]
                  [free (read-uptr p)]
                  [nbytes (read-uptr p)]
                  [name (read-fasl p g)]
                  [arity-mask (read-fasl p g)]
                  [info (read-fasl p g)]
                  [pinfo* (read-fasl p g)]
                  [bytes (let ([bv (make-bytevector nbytes)])
                           (do ([i 0 (fx+ i 1)])
                             ((fx= i nbytes) bv)
                             (bytevector-u8-set! bv i (read-byte p))))]
                  [m (read-uptr p)]
                  [vreloc (let loop ([n 0] [rls '()])
                            (if (fx= n m)
                                (list->vector (reverse rls))
                                (let* ([type-etc (read-byte p)]
                                       [code-offset (read-uptr p)]
                                       [item-offset (if (fxlogtest type-etc 2) (read-uptr p) 0)])
                                  (loop
                                    (fx+ n (if (fxlogtest type-etc 1) 3 1))
                                    (cons (fasl-reloc type-etc code-offset item-offset (read-fasl p g)) rls)))))])
             (fasl-code flags free name arity-mask info pinfo* bytes m vreloc))]
          [(fasl-type-immediate fasl-type-entry fasl-type-library fasl-type-library-code)
           (fasl-atom ty (read-uptr p))]
          [(fasl-type-graph) (read-fasl p (make-vector (read-uptr p) #f))]
          [(fasl-type-graph-def)
           (let ([n (read-uptr p)])
             (let ([x (read-fasl p g)])
               (when (vector-ref g n) (bogus "duplicate definition for graph element ~s in ~a" n (port-name p)))
               (vector-set! g n x)
               x))]
          [(fasl-type-graph-ref)
           (let ([n (read-uptr p)])
             (or (vector-ref g n)
                 (fasl-indirect g n)))]
          [(fasl-type-group) (fasl-group (read-vfasl p g (read-uptr p)))]
          [(fasl-type-visit) (fasl-visit (read-fasl p g))]
          [(fasl-type-revisit) (fasl-revisit (read-fasl p g))]
          [else (bogus "unexpected fasl code ~s in ~a" ty (port-name p))]))))

  (define read-script-header
    (lambda (ip)
      (let-values ([(bvop extract) (open-bytevector-output-port)])
        (define get
          (lambda ()
            (let ([b (get-u8 ip)])
              (put-u8 bvop b)
              b)))
        (if (and (eqv? (get) (char->integer #\#))
                 (eqv? (get) (char->integer #\!))
                 (let ([b (get)])
                   (or (eqv? b (char->integer #\/))
                       (eqv? b (char->integer #\space)))))
            (let f ()
              (let ([b (get)])
                (if (eof-object? b)
                    (bogus "unexpected eof reading #! line in ~a" (port-name ip))
                    (if (eqv? b (char->integer #\newline))
                        (extract)
                        (f)))))
            (begin (set-port-position! ip 0) #f)))))

  (let ()
    (define-threaded strip-inspector-information?)
    (define-threaded strip-profile-information?)
    (define-threaded strip-source-annotations?)
    (define-threaded strip-compile-time-information?)

    (module (fasl-record-predicate fasl-record-accessor)
      (define field-index
        (lambda (rtd field-name)
          (let ([v (record-type-field-names rtd)])
            (let loop ([i 0] [index #f])
              (if (fx= i (vector-length v))
                  (or index (sorry! "field ~s not found for ~s" field-name rtd))
                  (if (eq? (vector-ref v i) field-name)
                      (if index
                          (sorry! "duplicate field ~s found for ~s" field-name rtd)
                          (loop (fx+ i 1) i))
                      (loop (fx+ i 1) index)))))))
      (define uid-index (field-index #!base-rtd 'uid))
      (define fasl-record?
        (lambda (uname x)
          (fasl-case (follow-indirect x)
            [record (maybe-uid size nflds rtd pad-ty* fld*)
              (fasl-case (follow-indirect rtd)
                [record (rtd-uid rtd-size rtd-nflds rtd-rtd rtd-pad-ty* rtd-fld*)
                  (and (> (length rtd-fld*) uid-index)
                       (field-case (list-ref rtd-fld* uid-index)
                         [ptr (fasl)
                          (fasl-case (follow-indirect fasl)
                            [gensym (pname2 uname2) (string=? uname2 uname)]
                            [else #f])]
                         [else #f]))]
                [else #f])]
            [else #f])))
      (define fasl-record-predicate
        (lambda (rtd)
          (let ([uname (gensym->unique-string (record-type-uid rtd))])
            (lambda (x)
              (fasl-record? uname x)))))
      (define fasl-record-accessor
        (lambda (rtd field-name)
          (let ([uname (gensym->unique-string (record-type-uid rtd))]
                [index (field-index rtd field-name)])
            (lambda (x)
              (unless (fasl-record? uname x)
                (sorry! "unexpected type of object ~s" x))
              (fasl-case (follow-indirect x)
                [record (maybe-uid size nflds rtd pad-ty* fld*)
                  (unless (> (length fld*) index)
                    (sorry! "fewer fields than expected for ~s" x))
                  (let ([fld (list-ref fld* index)])
                    (field-case fld
                      [ptr (fasl) fasl]
                      [else (sorry! "unexpected type of field ~s" fld)]))]
                [else (sorry! "~s should have been a fasl record" x)]))))))

    (module (fasl-annotation? fasl-annotation-stripped)
      (include "types.ss")
      (define fasl-annotation? (fasl-record-predicate (record-type-descriptor annotation)))
      (define fasl-annotation-stripped (fasl-record-accessor (record-type-descriptor annotation) 'stripped)))

    (define-record-type table
      (nongenerative)
      (sealed #t)
      (fields (mutable count) (immutable ht))
      (protocol
        (lambda (new)
          (lambda ()
            (new 0 (make-eq-hashtable))))))

    (define build-graph!
      (lambda (x t th)
        (let ([a (eq-hashtable-cell (table-ht t) x 'first)])
          (let ([p (cdr a)])
            (cond
              [(eq? p 'first) (set-cdr! a #f) (th)]
              [(not p)
               (let ([n (table-count t)])
                 (set-cdr! a (cons n #t))
                 (table-count-set! t (fx+ n 1)))])))))

    (define build!
      (lambda (x t)
        (define build-vfasl!
          (lambda (vfasl)
            (lambda ()
              (vector-for-each (lambda (fasl) (build! fasl t)) vfasl))))
        (fasl-case x
          [entry (fasl) (sorry! "unexpected fasl-record-type entry")]
          [header (version machine dependencies) (sorry! "unexpected fasl-record-type header")]
          [pair (vfasl) (build-graph! x t (build-vfasl! vfasl))]
          [tuple (ty vfasl) (build-graph! x t (build-vfasl! vfasl))]
          [string (ty string) (build-graph! x t void)]
          [gensym (pname uname) (build-graph! x t void)]
          [vector (ty vfasl) (build-graph! x t (build-vfasl! vfasl))]
          [fxvector (ty viptr) (build-graph! x t void)]
          [bytevector (ty viptr) (build-graph! x t void)]
          [record (maybe-uid size nflds rtd pad-ty* fld*)
           (if (and strip-source-annotations? (fasl-annotation? x))
               (build! (fasl-annotation-stripped x) t)
               (build-graph! x t
                 (lambda ()
                   (when maybe-uid (build! maybe-uid t))
                   (build! rtd t)
                   (for-each (lambda (fld)
                               (field-case fld
                                 [ptr (fasl) (build! fasl t)]
                                 [else (void)]))
                     fld*))))]
          [closure (offset c) (build-graph! x t (lambda () (build! c t)))]
          [flonum (high low) (build-graph! x t void)]
          [small-integer (iptr) (void)]
          [large-integer (sign vuptr) (build-graph! x t void)]
          [eq-hashtable (mutable? subtype minlen veclen vpfasl)
           (build-graph! x t
             (lambda ()
               (vector-for-each
                 (lambda (pfasl)
                   (build! (car pfasl) t)
                   (build! (cdr pfasl) t))
                 vpfasl)))]
          [symbol-hashtable (mutable? minlen equiv veclen vpfasl)
           (build-graph! x t
             (lambda ()
               (vector-for-each
                 (lambda (pfasl)
                   (build! (car pfasl) t)
                   (build! (cdr pfasl) t))
                 vpfasl)))]
          [code (flags free name arity-mask info pinfo* bytes m vreloc)
           (build-graph! x t
             (lambda ()
               (build! name t)
               (build! arity-mask t)
               (unless strip-inspector-information? (build! info t))
               (unless strip-profile-information? (build! pinfo* t))
               (vector-for-each (lambda (reloc) (build! reloc t)) vreloc)))]
          [atom (ty uptr) (void)]
          [reloc (type-etc code-offset item-offset fasl) (build! fasl t)]
          [indirect (g i) (build! (vector-ref g i) t)]
          [group (vfasl) ((build-vfasl! vfasl))]
          [visit (fasl) (build! fasl t)]
          [revisit (fasl) (build! fasl t)])))

    (define write-entry
      (lambda (p x)
        (fasl-case x
          [header (version machine dependencies)
           (write-header p version machine dependencies)]
          [entry (fasl)
           (let ([t (make-table)])
             (build! fasl t)
             (let ([bv (call-with-bytevector-output-port
                         (lambda (p)
                           (let ([n (table-count t)])
                             (unless (fx= n 0)
                               (write-byte p (constant fasl-type-graph))
                               (write-uptr p n)))
                           (write-fasl p t fasl)))])
               (write-byte p (constant fasl-type-fasl-size))
               (write-uptr p (bytevector-length bv))
               (put-bytevector p bv)))]
          [else (sorry! "unrecognized top-level fasl-record-type ~s" x)])))

    (define write-header
      (lambda (p version machine dependencies)
        (put-bytevector p (constant fasl-header))
        (write-uptr p version)
        (write-uptr p machine)
        (write-byte p (char->integer #\())
        (let f ([dependencies dependencies])
          (unless (null? dependencies)
            (write-byte p (car dependencies))
            (f (cdr dependencies))))
        (write-byte p (char->integer #\)))))

    (define write-graph
      (lambda (p t x th)
        (let ([a (eq-hashtable-ref (table-ht t) x #f)])
          (cond
            [(not a) (th)]
            [(cdr a)
             (write-byte p (constant fasl-type-graph-def))
             (write-uptr p (car a))
             (set-cdr! a #f)
             (th)]
            [else
             (write-byte p (constant fasl-type-graph-ref))
             (write-uptr p (car a))]))))

    (define write-fasl
      (lambda (p t x)
        (fasl-case x
          [entry (fasl) (sorry! "unexpected fasl-record-type entry")]
          [header (version machine dependencies) (sorry! "unexpected fasl-record-type header")]
          [pair (vfasl)
           (write-graph p t x
             (lambda ()
               (write-byte p (constant fasl-type-pair))
               (write-uptr p (fx- (vector-length vfasl) 1))
               (vector-for-each (lambda (fasl) (write-fasl p t fasl)) vfasl)))]
          [tuple (ty vfasl)
           (write-graph p t x
             (lambda ()
               (write-byte p ty)
               (vector-for-each (lambda (fasl) (write-fasl p t fasl)) vfasl)))]
          [string (ty string)
           (write-graph p t x
             (lambda ()
               (write-byte p ty)
               (write-string p string)))]
          [gensym (pname uname)
           (write-graph p t x
             (lambda ()
               (write-byte p (constant fasl-type-gensym))
               (write-string p pname)
               (write-string p uname)))]
          [vector (ty vfasl)
           (write-graph p t x
             (lambda ()
               (write-byte p ty)
               (write-uptr p (vector-length vfasl))
               (vector-for-each (lambda (fasl) (write-fasl p t fasl)) vfasl)))]
          [fxvector (ty viptr)
           (write-graph p t x
             (lambda ()
               (write-byte p ty)
               (write-uptr p (vector-length viptr))
               (vector-for-each (lambda (iptr) (write-iptr p iptr)) viptr)))]
          [bytevector (ty bv)
           (write-graph p t x
             (lambda ()
               (write-byte p ty)
               (write-uptr p (bytevector-length bv))
               (put-bytevector p bv)))]
          [record (maybe-uid size nflds rtd pad-ty* fld*)
           (if (and strip-source-annotations? (fasl-annotation? x))
               (write-fasl p t (fasl-annotation-stripped x))
               (write-graph p t x
                 (lambda ()
                   (if maybe-uid
                       (begin
                         (write-byte p (constant fasl-type-rtd))
                         (write-fasl p t maybe-uid))
                       (write-byte p (constant fasl-type-record)))
                   (write-uptr p size)
                   (write-uptr p nflds)
                   (write-fasl p t rtd)
                   (for-each (lambda (pad-ty fld)
                               (write-byte p pad-ty)
                               (field-case fld
                                 [ptr (fasl) (write-fasl p t fasl)]
                                 [byte (n) (write-byte p n)]
                                 [iptr (n) (write-iptr p n)]
                                 [single (n) (write-uptr p n)]
                                 [double (high low)
                                  (write-uptr p high)
                                  (write-uptr p low)]))
                     pad-ty* fld*))))]
          [closure (offset c)
           (write-graph p t x
             (lambda ()
               (write-byte p (constant fasl-type-closure))
               (write-uptr p offset)
               (write-fasl p t c)))]
          [flonum (high low)
           (write-graph p t x
             (lambda ()
               (write-byte p (constant fasl-type-flonum))
               (write-uptr p high)
               (write-uptr p low)))]
          [large-integer (sign vuptr)
           (write-graph p t x
             (lambda ()
               (write-byte p (constant fasl-type-large-integer))
               (write-byte p sign)
               (write-uptr p (vector-length vuptr))
               (vector-for-each (lambda (uptr) (write-uptr p uptr)) vuptr)))]
          [eq-hashtable (mutable? subtype minlen veclen vpfasl)
           (write-graph p t x
             (lambda ()
               (write-byte p (constant fasl-type-eq-hashtable))
               (write-byte p mutable?)
               (write-byte p subtype)
               (write-uptr p minlen)
               (write-uptr p veclen)
               (write-uptr p (vector-length vpfasl))
               (vector-for-each
                 (lambda (pfasl)
                   (write-fasl p t (car pfasl))
                   (write-fasl p t (cdr pfasl)))
                 vpfasl)))]
          [symbol-hashtable (mutable? minlen equiv veclen vpfasl)
           (write-graph p t x
             (lambda ()
               (write-byte p (constant fasl-type-symbol-hashtable))
               (write-byte p mutable?)
               (write-uptr p minlen)
               (write-byte p equiv)
               (write-uptr p veclen)
               (write-uptr p (vector-length vpfasl))
               (vector-for-each
                 (lambda (pfasl)
                   (write-fasl p t (car pfasl))
                   (write-fasl p t (cdr pfasl)))
                 vpfasl)))]
          [code (flags free name arity-mask info pinfo* bytes m vreloc)
           (write-graph p t x
             (lambda ()
               (write-byte p (constant fasl-type-code))
               (write-byte p flags)
               (write-uptr p free)
               (write-uptr p (bytevector-length bytes))
               (write-fasl p t name)
               (write-fasl p t arity-mask)
               (if strip-inspector-information?
                   (write-fasl p t (fasl-atom (constant fasl-type-immediate) (constant sfalse)))
                   (write-fasl p t info))
               (if strip-profile-information?
                   (write-fasl p t (fasl-atom (constant fasl-type-immediate) (constant snil)))
                   (write-fasl p t pinfo*))
               (put-bytevector p bytes)
               (write-uptr p m)
               (vector-for-each (lambda (reloc) (write-fasl p t reloc)) vreloc)))]
          [small-integer (iptr)
           (write-byte p (constant fasl-type-small-integer))
           (write-iptr p iptr)]
          [atom (ty uptr)
           (write-byte p ty)
           (write-uptr p uptr)]
          [reloc (type-etc code-offset item-offset fasl)
           (write-byte p type-etc)
           (write-uptr p code-offset)
           (when (fxlogtest type-etc 2) (write-uptr p item-offset))
           (write-fasl p t fasl)]
          [indirect (g i) (write-fasl p t (vector-ref g i))]
          [group (vfasl)
           (write-byte p (constant fasl-type-group))
           (write-uptr p (vector-length vfasl))
           (vector-for-each (lambda (fasl) (write-fasl p t fasl)) vfasl)]
          [visit (fasl)
           (write-byte p (constant fasl-type-visit))
           (write-fasl p t fasl)]
          [revisit (fasl)
           (write-byte p (constant fasl-type-revisit))
           (write-fasl p t fasl)])))

    (define write-byte
      (lambda (p x)
        (put-u8 p x)))

    (define-who write-uptr
      (lambda (p n)
        (unless (>= n 0)
          (sorry! "received negative input ~s" n))
        (let f ([n n] [cbit 0])
          (if (and (fixnum? n) (fx<= n 127))
              (write-byte p (fxlogor (fxsll n 1) cbit))
              (begin
                (f (ash n -7) 1)
                (write-byte p (fxlogor (fxsll (logand n #x7f) 1) cbit)))))))

    (define write-iptr
      (lambda (p x)
        (let f ([n (if (< x 0) (- x) x)] [cbit 0])
          (if (and (fixnum? n) (fx<= n 63))
              (write-byte p (fxlogor (if (< x 0) #x80 0) (fxsll n 1) cbit))
              (begin
                (f (ash n -7) 1)
                (write-byte p (fxlogor (fxsll (logand n #x7f) 1) cbit)))))))

    (define write-string
      (lambda (p x)
        (let ([n (string-length x)])
          (write-uptr p n)
          (do ([i 0 (fx+ i 1)])
            ((fx= i n))
            (write-uptr p (char->integer (string-ref x i)))))))

    (module (fasl-program-info? fasl-library/rt-info?)
      (import (nanopass))
      (include "base-lang.ss")
      (include "expand-lang.ss")
      (define fasl-program-info? (fasl-record-predicate (record-type-descriptor program-info)))
      (define fasl-library/rt-info? (fasl-record-predicate (record-type-descriptor library/rt-info))))

    (define keep-revisit-info
      (lambda (x)
        (define revisit-record?
          (lambda (x)
            (or (fasl-program-info? x) (fasl-library/rt-info? x))))
        (define revisit-stuff?
          (lambda (x)
            (fasl-case x
              [closure (offset c) #t]
              [revisit (fasl) #t]
              [record (maybe-uid size nflds rtd pad-ty* fld*) (revisit-record? x)]
              [else #f])))
        (fasl-case x
          [entry (fasl)
            (fasl-case fasl
              [closure (offset c) x]
              [revisit (fasl) x]
              [record (maybe-uid size nflds rtd pad-ty* fld*) (and (revisit-record? fasl) x)]
              [group (vfasl)
               (let ([fasl* (filter revisit-stuff? (vector->list vfasl))])
                 (and (not (null? fasl*))
                      (fasl-entry
                        (if (null? (cdr fasl*))
                            (car fasl*)
                            (fasl-vector (constant fasl-type-vector) (list->vector fasl*))))))]
              [else #f])]
          [header (version machine dependencies) x]
          [else (sorry! "expected entry or header, got ~s" x)])))

    (set-who! $fasl-strip-options (make-enumeration '(inspector-source profile-source source-annotations compile-time-information)))
    (set-who! $make-fasl-strip-options (enum-set-constructor $fasl-strip-options))

    (let ()
      (define read-and-strip-file
        (lambda (ifn)
          (let ([ip ($open-file-input-port fasl-who ifn)])
            (on-reset (close-port ip)
              (let* ([script-header (read-script-header ip)]
                     [mode (and script-header (unless-feature windows (get-mode ifn)))])
                (port-file-compressed! ip)
                (let loop ([rentry* '()])
                  (set! fasl-count (fx+ fasl-count 1))
                  (let ([entry (read-entry ip)])
                    (if (eof-object? entry)
                        (begin
                          (close-port ip)
                          (values script-header mode (reverse rentry*)))
                        (let ([entry (if strip-compile-time-information? (keep-revisit-info entry) entry)])
                          (loop (if entry (cons entry rentry*) rentry*)))))))))))
      (set-who! strip-fasl-file
        (rec strip-fasl-file
          (lambda (ifn ofn options)
            (unless (string? ifn) ($oops who "~s is not a string" ifn))
            (unless (string? ofn) ($oops who "~s is not a string" ofn))
            (unless (and (enum-set? options) (enum-set-subset? options $fasl-strip-options))
              ($oops who "~s is not a fasl-strip-options object" options))
            (fluid-let ([strip-inspector-information? (enum-set-subset? (fasl-strip-options inspector-source) options)]
                        [strip-profile-information? (enum-set-subset? (fasl-strip-options profile-source) options)]
                        [strip-source-annotations? (enum-set-subset? (fasl-strip-options source-annotations) options)]
                        [strip-compile-time-information? (enum-set-subset? (fasl-strip-options compile-time-information) options)]
                        [fasl-who who]
                        [fasl-count 0])
              (let-values ([(script-header mode entry*) (read-and-strip-file ifn)])
                (let ([op ($open-file-output-port who ofn (file-options replace))])
                  (on-reset (delete-file ofn #f)
                    (on-reset (close-port op)
                      (when script-header (put-bytevector op script-header))
                      (when (compile-compressed) (port-file-compressed! op))
                      (for-each (lambda (entry) (write-entry op entry)) entry*)
                      (close-port op)
                      (unless-feature windows (when mode (chmod ofn mode)))))))))))))

  (let ()
    ; per file
    (define-threaded fail)
    (define-threaded eq-hashtable-warning-issued?)
    ; per entry
    (define-threaded cmp-ht)
    (define-threaded gensym-table)

    (define-syntax cmp-case
      (lambda (x)
        (define (make-clause t x-case)
          (lambda (variant arg* e)
            (with-syntax ([(arg1 ...) (map (lambda (x) (construct-name x x "1")) arg*)]
                          [(arg2 ...) (map (lambda (x) (construct-name x x "2")) arg*)]
                          [variant variant]
                          [e e]
                          [t t]
                          [x-case x-case])
              #'[variant (arg1 ...)
                 (or (x-case t
                       [variant (arg2 ...) e]
                       [else #f])
                     (fail 'variant))])))
        (syntax-case x ()
          [(_ x-case e1 e2 [variant (arg ...) e] ...)
           #`(let ([t2 e2])
               (x-case e1
                 #,@(map (make-clause #'t2 #'x-case) #'(variant ...) #'((arg ...) ...) #'(e ...))))])))

    (define-who vandmap
      (lambda (p v1 v2)
        (let ([n (vector-length v1)])
          (and (fx= (vector-length v2) n)
               (let f ([i 0])
                 (or (fx= i n)
                     (and (p (vector-ref v1 i) (vector-ref v2 i))
                          (f (fx+ i 1)))))))))

    (define fld=?
      (lambda (fld1 fld2)
        (cmp-case field-case fld1 fld2
          [ptr (fasl) (fasl=? fasl1 fasl2)]
          [byte (n) (eqv? n1 n2)]
          [iptr (n) (eqv? n1 n2)]
          [single (n) (eqv? n1 n2)]
          [double (high low)
           (and (eqv? high1 high2)
                (eqv? low1 low2))])))

    (define (fasl=? entry1 entry2)
      (let ([entry1 (follow-indirect entry1)] [entry2 (follow-indirect entry2)])
        (let ([a (eq-hashtable-cell cmp-ht entry1 #f)])
          (or (eq? entry2 (cdr a))
              (and (not (cdr a))
                   (begin
                     (set-cdr! a entry2)
                     (cmp-case fasl-case entry1 entry2
                       [entry (fasl) (fasl=? fasl1 fasl2)]
                       [header (version machine dependencies)
                        (and (equal? version1 version2)
                             (equal? machine1 machine2)
                             (equal? dependencies1 dependencies2))]
                       [pair (vfasl) (vandmap fasl=? vfasl1 vfasl2)]
                       [tuple (ty vfasl) (and (eqv? ty1 ty2) (vandmap fasl=? vfasl1 vfasl2))]
                       [string (ty string) (and (eqv? ty1 ty2) (string=? string1 string2))]
                       [gensym (pname uname)
                        (and (string=? pname1 pname2)
                             (let ([x (hashtable-ref gensym-table uname1 #f)])
                               (if (not x)
                                   (hashtable-set! gensym-table uname1 uname2)
                                   (string=? x uname2))))]
                       [vector (ty vfasl) (and (eqv? ty1 ty2) (vandmap fasl=? vfasl1 vfasl2))]
                       [fxvector (ty viptr) (and (eqv? ty1 ty2) (vandmap = viptr1 viptr2))]
                       [bytevector (ty bv) (and (eqv? ty1 ty2) (bytevector=? bv1 bv2))]
                       [record (maybe-uid size nflds rtd pad-ty* fld*)
                        (and (if maybe-uid1
                                 (and maybe-uid2 (fasl=? maybe-uid1 maybe-uid2))
                                 (not maybe-uid2))
                             (eqv? size1 size2)
                             (eqv? nflds1 nflds2)
                             (fasl=? rtd1 rtd2)
                             (andmap eqv? pad-ty*1 pad-ty*2)
                             (andmap fld=? fld*1 fld*2))]
                       [closure (offset c) (and (eqv? offset1 offset2) (fasl=? c1 c2))]
                       [flonum (high low)
                        (and (eqv? high1 high2)
                             (eqv? low1 low2))]
                       [large-integer (sign vuptr) (and (eqv? sign1 sign2) (vandmap = vuptr1 vuptr2))]
                       [eq-hashtable (mutable? subtype minlen veclen vpfasl)
                        (and (eqv? mutable?1 mutable?2)
                             (eqv? subtype1 subtype2)
                             (eqv? minlen1 minlen2)
                             ; don't care if veclens differ
                             #;(eqv? veclen1 veclen2)
                             ; making gross assumption that equal-length hashtables are equal.
                             ; actual eq-hashtable equivalence is hard.
                             (fx= (vector-length vpfasl1) (vector-length vpfasl2))
                             (begin
                               (unless (or (fx= (vector-length vpfasl1) 0) eq-hashtable-warning-issued?)
                                 (set! eq-hashtable-warning-issued? #t)
                                 (warning fasl-who "punting on comparison of eq-hashtable entries"))
                               #t))]
                       [symbol-hashtable (mutable? minlen equiv veclen vpfasl)
                        (let ()
                          (define keyval?
                            (lambda (x1 x2)
                              (fasl-case (car x1)
                                [gensym (pname1 uname1)
                                  (fasl-case (car x2)
                                    [gensym (pname2 uname2) (string<? uname1 uname2)]
                                    [string (ty2 string2) #t]
                                    [else (sorry! "unexpected key ~s" x2)])]
                                [string (ty1 string1)
                                  (fasl-case (car x2)
                                    [gensym (pname2 uname2) #f]
                                    [string (ty2 string2) (string<? string1 string2)]
                                    [else (sorry! "unexpected key ~s" x2)])]
                                [else (sorry! "unexpected key ~s" x1)])))
                          (and (eqv? mutable?1 mutable?2)
                               (eqv? minlen1 minlen2)
                               (eqv? equiv1 equiv2)
                               ; don't care if veclens differ
                               #;(eqv? veclen1 veclen2)
                               (vandmap (lambda (x y) (and (fasl=? (car x) (car y)) (fasl=? (cdr x) (cdr y))))
                                 (vector-sort keyval? vpfasl1)
                                 (vector-sort keyval? vpfasl2))))]
                       [code (flags free name arity-mask info pinfo* bytes m reloc)
                        (and (eqv? flags1 flags2)
                             (eqv? free1 free2)
                             (fasl=? name1 name2)
                             (fasl=? arity-mask1 arity-mask2)
                             (fasl=? info1 info2)
                             (fasl=? pinfo*1 pinfo*2)
                             (bytevector=? bytes1 bytes2)
                             (eqv? m1 m2)
                             (vandmap fasl=? reloc1 reloc2))]
                       [small-integer (iptr) (eqv? iptr1 iptr2)]
                       [atom (ty uptr) (and (eqv? ty1 ty2) (eqv? uptr1 uptr2))]
                       [reloc (type-etc code-offset item-offset fasl)
                        (and (eqv? type-etc1 type-etc2)
                             (eqv? code-offset1 code-offset2)
                             (eqv? item-offset1 item-offset2)
                             (fasl=? fasl1 fasl2))]
                       [indirect (g i) (sorry! "unexpected indirect")]
                       [group (vfasl) (vandmap fasl=? vfasl1 vfasl2)]
                       [visit (fasl) (fasl=? fasl1 fasl2)]
                       [revisit (fasl) (fasl=? fasl1 fasl2)])))))))

    (set-who! $fasl-file-equal?
      (rec fasl-file-equal?
        (case-lambda
          [(ifn1 ifn2) (fasl-file-equal? ifn1 ifn2 #f)]
          [(ifn1 ifn2 error?)
           (unless (string? ifn1) ($oops who "~s is not a string" ifn1))
           (unless (string? ifn2) ($oops who "~s is not a string" ifn2))
           (fluid-let ([fasl-who who]
                       [fasl-count 0]
                       [fail (if error? (lambda (what) (bogus "~s comparison failed while comparing ~a and ~a" what ifn1 ifn2)) (lambda (what) #f))]
                       [eq-hashtable-warning-issued? #f])
             (call-with-port ($open-file-input-port who ifn1)
               (lambda (ip1)
                 (on-reset (close-port ip1)
                   (call-with-port ($open-file-input-port who ifn2)
                     (lambda (ip2)
                       (on-reset (close-port ip2)
                         (let ([script-header1 (read-script-header ip1)]
                               [script-header2 (read-script-header ip2)])
                           (if (equal? script-header1 script-header2)
                               (begin
                                 (port-file-compressed! ip1)
                                 (port-file-compressed! ip2)
                                 (let loop ()
                                   (set! fasl-count (fx+ fasl-count 1))
                                   (let ([entry1 (read-entry ip1)] [entry2 (read-entry ip2)])
                                     (if (eof-object? entry1)
                                         (or (eof-object? entry2)
                                             (and error? (bogus "~a has fewer fasl entries than ~a" ifn1 ifn2)))
                                         (if (eof-object? entry2)
                                             (and error? (bogus "~a has fewer fasl entries than ~a" ifn2 ifn1))
                                             (and (fluid-let ([cmp-ht (make-eq-hashtable)]
                                                              [gensym-table (make-hashtable string-hash string=?)])
                                                    (fasl=? entry1 entry2))
                                                  (loop)))))))
                               (and error? (bogus "script headers ~s and ~s differ" script-header1 script-header2)))))))))))])))))