cs & raco decompile: expose more fasl content

Show the machine code that constructs lifted constants for a linket.

Also, add a `--partial-fasl` option that shows fasl content in a rawer
form, which is useful for checking how content is presented and that
nothing is getting lost in other reconstructed views.

pkgs/compiler-lib/compiler/commands/decompile.rkt

@@ -30,6 +30,8 @@
     (set! to-linklets? #t)]
    [("--no-disassemble") "Show machine code as-is"
     (current-can-disassemble #f)]
+   [("--partial-fasl") "Show more detail on fasl structure"
+    (current-partial-fasl #t)]
    #:args source-or-bytecode-file
    source-or-bytecode-file))
 

pkgs/compiler-lib/compiler/decompile.rkt

@@ -253,11 +253,24 @@
           [code
            (case fmt
              [(compile)
-              (define proc ((vm-eval `(load-compiled-from-port (open-bytevector-input-port ,code) ',sfd-paths))))
+              (cond
-              (let ([proc (decompile-chez-procedure (if (null? args) proc (apply proc args)))])
+                [(not (current-partial-fasl))
-                (if (null? args)
+                 ;; Note that applying the result of `vm-eval` no longer shows the setup of
-                    proc
+                 ;; Racket level constants (like keywords):
-                    (cons proc (map (vm-primitive 'force-unfasl) args))))]
+                 (define make-proc (vm-eval `(load-compiled-from-port (open-bytevector-input-port ,code) ',sfd-paths)))
+                 (define proc (make-proc))
+                 (let ([proc (decompile-chez-procedure (if (null? args) proc (apply proc args)) make-proc)])
+                   (if (null? args)
+                       proc
+                       (cons proc (map (vm-primitive 'force-unfasl) args))))]
+                [else
+                 (define desc (disassemble-in-description
+                               `(#(FASL
+                                   #:length ,(bytes-length code)
+                                   ,(vm-eval `(($primitive $describe-fasl-from-port) (open-bytevector-input-port ,code) ',sfd-paths))))))
+                 (if (null? args)
+                     desc
+                     (cons desc (map (vm-primitive 'force-unfasl) args)))])]
              [(interpret)
               (define bytecode (vm-eval `(fasl-read (open-bytevector-input-port ,code) 'load ',sfd-paths)))
               (list `(#%interpret ,(unwrap-chez-interpret-jitified bytecode)))]

pkgs/compiler-lib/compiler/private/chez.rkt

@@ -5,26 +5,28 @@
 
 (provide decompile-chez-procedure
          unwrap-chez-interpret-jitified
-         current-can-disassemble)
+         current-can-disassemble
+         current-partial-fasl
+         disassemble-in-description)
 
 (define current-can-disassemble (make-parameter #t))
+(define current-partial-fasl (make-parameter #f))
 
-(define (decompile-chez-procedure p)
+(define (decompile-chez-procedure p make-p)
   (unless (procedure? p)
     (error 'decompile-chez-procedure "not a procedure"))
   (define seen (make-hasheq))
   ((vm-primitive 'call-with-system-wind)
    (lambda ()
+     (define make-proc ((vm-primitive 'inspect/object) make-p))
+     (define make-code (make-proc 'code))
      (define proc ((vm-primitive 'inspect/object) p))
      (define code (proc 'code))
      (append
-      (apply
+      (decompile-code make-code #f seen #:name "body-maker-that-creates-lifted-constants")
-       append
+      (decompile-code code proc seen #:unwrap-body? #t)))))
-       (for/list ([i (in-range (code 'free-count))])
-         (decompile (proc 'ref i) seen)))
-      (decompile-code code seen #:unwrap-body? #t)))))
 
-(define (decompile obj seen)
+(define (decompile obj closure seen)
   (define type (obj 'type))
   (cond
     [(eq? type 'variable)
@@ -34,22 +36,30 @@
     [else
      (hash-set! seen (obj 'value) #t)
      (case type
-       [(code) (decompile-code obj seen)]
+       [(code) (decompile-code obj closure seen)]
        [(variable)
-        (decompile (obj 'ref) seen)]
+        (decompile (obj 'ref) #f seen)]
        [(procedure)
-        (decompile (obj 'code) seen)]
+        (decompile (obj 'code) obj seen)]
        [else null])]))
 
 (define (decompile-value v seen)
-  (decompile ((vm-primitive 'inspect/object) v) seen))
+  (decompile ((vm-primitive 'inspect/object) v) #f seen))
 
-(define (decompile-code code seen
+(define (decompile-code code closure seen
-                        #:unwrap-body? [unwrap-body? #f])
+                        #:unwrap-body? [unwrap-body? #f]
-  (define name (code 'name))
+                        #:name [name #f])
   (define $generation (vm-eval '($primitive $generation)))
   (define $code? (vm-eval '($primitive $code?)))
   (define max-gen (vm-eval '(collect-maximum-generation)))
+  (define captures (if (and closure (positive? (code 'free-count)))
+                       `('(captures: ,@(for/list ([i (in-range (code 'free-count))])
+                                         (define v (closure 'ref i))
+                                         (let loop ([v v])
+                                           (case (v 'type)
+                                             [(variable) (loop (v 'ref))]
+                                             [else (v 'value)])))))
+                       '()))
   (append
    (apply
     append
@@ -58,9 +68,11 @@
                              (($generation v) . > . max-gen)))
       (decompile-value v seen)))
    (if unwrap-body?
-       (decompile-code-body code)
+       (append
+        captures
+        (decompile-code-body code))
        (list
-        `(define ,(let ([name (code 'name)])
+        `(define ,(let ([name (or name (code 'name))])
                     (if name
                         (string->symbol
                          (if (and ((string-length name) . > . 0)
@@ -69,6 +81,7 @@
                              name))
                         '....))
            (lambda ,(arity-mask->args (code 'arity-mask))
+             ,@captures
              ,@(decompile-code-body code)))))))
 
 (define (decompile-code-body code-obj)
@@ -112,12 +125,7 @@
    (cond
      [(and (current-can-disassemble)
            (force disassemble-bytes))
-      => (lambda (disassemble-bytes)
+      (disassemble-bytes-to-assembly bstr #:relocations ((code-obj 'reloc+offset) 'value))]
-           (define o (open-output-bytes))
-           (parameterize ([current-output-port o])
-             (disassemble-bytes bstr #:relocations ((code-obj 'reloc+offset) 'value)))
-           (define strs (regexp-split #rx"\n" (get-output-string o)))
-           (list (cons '#%assembly-code strs)))]
      [else
       (list (list '#%machine-code bstr))])))
 
@@ -126,6 +134,13 @@
     (with-handlers ([exn:fail? (lambda (exn) #f)])
       (dynamic-require 'disassemble 'disassemble-bytes))))
 
+(define (disassemble-bytes-to-assembly bstr #:relocations [relocations '()])
+  (define o (open-output-bytes))
+  (parameterize ([current-output-port o])
+    ((force disassemble-bytes) bstr #:relocations relocations))
+  (define strs (regexp-split #rx"\n" (get-output-string o)))
+  (list (cons '#%assembly-code strs)))
+           
 (define (arity-mask->args mask)
   (cond
     [(zero? (bitwise-and mask (sub1 mask)))
@@ -136,6 +151,33 @@
      ;; multiple bits set
      'args]))
 
+;; ----------------------------------------
+
+;; Look for 'CODE descriptions that have bytestrings and convert to disassembled.
+;; This function mutates the description.
+(define (disassemble-in-description v)
+  (when (and (current-can-disassemble)
+             (force disassemble-bytes))
+    (define ht (make-hasheq))
+    (let loop ([v v])
+      (cond
+        [(hash-ref ht v #f)
+         (void)]
+        [else
+         (hash-set! ht v #t)
+         (cond
+           [(pair? v)
+            (loop (car v))
+            (loop (cdr v))]
+           [(vector? v)
+            (when (and ((vector-length v) . >= . 8)
+                       (eq? 'CODE (vector-ref v 0))
+                       (bytes? (vector-ref v 7)))
+              (vector-set! v 7 (disassemble-bytes-to-assembly (vector-ref v 7))))
+            (for ([e (in-vector v)])
+              (loop e))])])))
+  v)
+
 ;; ----------------------------------------
 ;; The schemify interpreter's "bytecode" is fairly readable as-is, so
 ;; just unpack compiled procedures at the leaves

pkgs/compiler-lib/info.rkt

@@ -13,4 +13,4 @@
 
 (define pkg-authors '(mflatt))
 
-(define version "1.8")
+(define version "1.9")

pkgs/racket-doc/scribblings/raco/decompile.scrbl

@@ -30,9 +30,37 @@ The @exec{raco decompile} command accepts the following command-line flags:
         of decoding linklets to approximate Racket @racket[module] forms}
   @item{@DFlag{no-disassemble} --- show machine code as-is in a byte string,
         instead of attempting to disassemble}
+  @item{@DFlag{partial-fasl} --- preserve more of the original structure of
+        the bytecode file, instead of focusing on procedure bodies}
 ]
 
-To the degree that it can be converted back to Racket code,
+@history[#:changed "1.8" @elem{Added @DFlag{no-disassemble}.}
+         #:changed "1.9" @elem{Added @DFlag{partial-fasl}.}]
+
+@section{Racket CS Decompilation}
+
+Decompilation of Racket CS bytecode mostly shows the structure of a
+module around machine-code implementations of procedures.
+
+@itemize[
+
+@item{A @racketidfont{#%machine-code} form corresponds to machine code
+ that is not disassembled, where the machine code is in a byte string.}
+
+@item{A @racketidfont{#%assembly-code} form corresponds to disassembled
+ machine code, where the assembly code is shown as a sequence of strings.}
+
+@item{A @racketidfont{#%interpret} form corresponds to a compiled form
+ of a large procedure, where only smaller nested procedures are compiled
+ to machine code.}
+
+]
+
+@section{Racket BC Decompilation}
+
+Racket BC bytecode has a structure that is close enough to Racket's
+ core language that it can more often be converted to an approximation
+ of Racket code. To the degree that it can be converted back,
  many forms in the decompiled code have the same meanings as
  always, such as @racket[module], @racket[define], and @racket[lambda].
  Other forms and transformations are specific to the rendering
@@ -130,19 +158,8 @@ To the degree that it can be converted back to Racket code,
  local binding might have a name that starts @racketidfont{flonum} to
  indicate a flonum value.}
 
-@item{A @racketidfont{#%decode-syntax} form corresponds to a syntax
- object.}
-
-@item{A @racketidfont{#%machine-code} form corresponds to machine code
- that is not disassembled, where the machine code is in a byte string.}
-
-@item{A @racketidfont{#%assembly-code} form corresponds to disassembled
- machine code, where the assembly code is shown as a sequence of strings.}
-
 ]
 
-@history[#:changed "1.8" @elem{Added @DFlag{no-disassemble}.}]
-
 @; ------------------------------------------------------------
 
 @section{API for Decompiling}

pkgs/zo-lib/compiler/private/opaque.rkt

@@ -0,0 +1,5 @@
+#lang racket/base
+
+(provide (struct-out opaque))
+
+(struct opaque (bstr))

pkgs/zo-lib/compiler/zo-marshal.rkt

@@ -13,7 +13,8 @@
          racket/set
          racket/extflonum
          racket/private/truncate-path
-         racket/fasl)
+         racket/fasl
+         "private/opaque.rkt")
 
 (provide/contract
  [zo-marshal ((or/c linkl-directory? linkl-bundle?) . -> . bytes?)]
@@ -157,9 +158,10 @@
      (s-exp->fasl (hash-remove top 'vm) outp)]
     [(#"chez-scheme")
      (write-bundle-header #"chez-scheme" outp)
-     (define bstr (hash-ref top 'opaque
+     (define opqaue (hash-ref top 'opaque
-                            (lambda ()
+                              (lambda ()
-                              (error 'zo-marshal "missing 'opaque for chez-scheme virtual-machine format"))))
+                                (error 'zo-marshal "missing 'opaque for chez-scheme virtual-machine format"))))
+     (define bstr (opaque-bstr opaque))
      (write-bytes (integer->integer-bytes (bytes-length bstr) 4 #f #f) outp)
      (write-bytes bstr outp)]
     [else

pkgs/zo-lib/compiler/zo-parse.rkt

@@ -7,7 +7,8 @@
          racket/dict
          racket/set
          racket/fasl
-         ffi/unsafe/vm)
+         ffi/unsafe/vm
+         "private/opaque.rkt")
 
 (provide zo-parse)
 (provide (all-from-out compiler/zo-structs))
@@ -869,7 +870,7 @@
                    (open-input-bytes (bytes-append
                                       (integer->integer-bytes len 4 #f #f)
                                       bstr)))
-                  'opaque bstr)]
+                  'opaque (opaque bstr))]
        [else
         (hash 'opaque bstr)])]
     [else

racket/src/ChezScheme/s/primdata.ss

@@ -1916,6 +1916,7 @@
   ($current-stack-link [flags single-valued])
   ($current-winders [flags single-valued])
   ($dequeue-scheme-signals [flags])
+  ($describe-fasl-from-port [sig [(input-port) (input-port vector) -> (ptr)]] [flags])
   ($distinct-bound-ids? [sig [(list) -> (boolean)]] [flags discard])
   ($dofmt [flags single-valued])
   ($do-wind [flags single-valued])

racket/src/ChezScheme/s/print.ss

@@ -757,12 +757,13 @@ floating point returns with (1 0 -1 ...).
         [(let ([info ($code-info x)])
            (and (code-info? info) (code-info-src info))) =>
          (lambda (src)
-           (fprintf p " at ~a:~a"
+           (let ([fn (source-file-descriptor-name (source-sfd src))])
-             (let ([fn (source-file-descriptor-name (source-sfd src))])
+             (when (or (string? fn) (symbol? fn))
-               (if (string? fn) (path-last fn) fn))
+               (fprintf p " at ~a:~a"
-             (if (source-2d? src)
+                  (if (string? fn) (path-last fn) fn)
-                 (format "~a.~a" (source-2d-line src) (source-2d-column src))
+                  (if (source-2d? src)
-                 (source-bfp src))))])))
+                      (format "~a.~a" (source-2d-line src) (source-2d-column src))
+                      (source-bfp src))))))])))
 
   (define wrprocedure
     (lambda (x p)

racket/src/ChezScheme/s/strip.ss

@@ -1,4 +1,4 @@
-;;; strip.ss
+;; strip.ss
 ;;; Copyright 1984-2017 Cisco Systems, Inc.
 ;;; 
 ;;; Licensed under the Apache License, Version 2.0 (the "License");
@@ -30,6 +30,7 @@
     (flvector vfl)
     (bytevector ty bv)
     (record maybe-uid size nflds rtd pad-ty* fld*) ; maybe-uid => rtd
+    (rtd-ref uid) ; field info not recorded
     (closure offset c)
     (flonum high low)
     (small-integer iptr)
@@ -124,7 +125,7 @@
                 ((= i n))
               (string-set! s i (integer->char (read-uptr p))))
             s))))
-    (define (read-entry p)
+    (define (read-entry p init-g)
       (let ([ty (read-byte-or-eof p)])
         (if (eof-object? ty)
             ty
@@ -146,8 +147,8 @@
                                    (if (eqv? compressed-flag (constant fasl-type-gzip))
                                        (constant COMPRESS-GZIP)
                                        (constant COMPRESS-LZ4)))])
-                        (fasl-entry situation (read-fasl (open-bytevector-input-port bv) #f))))]
+                        (fasl-entry situation (read-fasl (open-bytevector-input-port bv) init-g))))]
-                   [(fasl-type-uncompressed) (fasl-entry situation (read-fasl p #f))]
+                   [(fasl-type-uncompressed) (fasl-entry situation (read-fasl p init-g))]
                    [else (bogus "expected compression flag in ~a" (port-name p))]))]
               [else (bogus "expected header or situation in ~a" (port-name p))]))))
     (define (read-header p)
@@ -200,8 +201,8 @@
             (vector-set! v i
               (let ([key (read-fasl p g)])
                 (cons key (read-fasl p g))))))))
-    (define (read-record p g maybe-uid)
+    (define (read-record p g maybe-uid size)
-      (let* ([size (read-uptr p)] [nflds (read-uptr p)] [rtd (read-fasl p g)])
+      (let* ([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*))
@@ -236,8 +237,12 @@
           [(fasl-type-bytevector fasl-type-immutable-bytevector)
            (fasl-bytevector ty (read-bytevector p (read-uptr p)))]
           [(fasl-type-base-rtd) (fasl-tuple ty '#())]
-          [(fasl-type-rtd) (read-record p g (read-fasl p g))]
+          [(fasl-type-rtd) (let* ([uid (read-fasl p g)]
-          [(fasl-type-record) (read-record p g #f)]
+                                  [size (read-uptr p)])
+                             (if (eqv? size 0)
+                                 (fasl-rtd-ref uid)
+                                 (read-record p g uid size)))]
+          [(fasl-type-record) (read-record p g #f (read-uptr p))]
           [(fasl-type-closure)
            (let* ([offset (read-uptr p)]
                   [c (read-fasl p g)])
@@ -291,11 +296,19 @@
                                        [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)))))])
+                                    (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) (read-fasl p (let ([new-g (make-vector (read-uptr p) #f)])
+                                            (when g
+                                              (let ([delta (fx- (vector-length new-g) (vector-length g))])
+                                                (let loop ([i 0])
+                                                  (unless (fx= i (vector-length g))
+                                                    (vector-set! new-g (fx+ i delta) (vector-ref g i))
+                                                    (loop (fx+ i 1))))))
+                                            new-g))]
           [(fasl-type-graph-def)
            (let ([n (read-uptr p)])
              (let ([x (read-fasl p g)])
@@ -440,6 +453,7 @@
                                  [ptr (fasl) (build! fasl t)]
                                  [else (void)]))
                      fld*))))]
+          [rtd-ref (uid) (build-graph! x t (lambda () (build! uid #t)))]
           [closure (offset c) (build-graph! x t (lambda () (build! c t)))]
           [flonum (high low) (build-graph! x t void)]
           [small-integer (iptr) (void)]
@@ -582,6 +596,11 @@
                                   (put-uptr p high)
                                   (put-uptr p low)]))
                      pad-ty* fld*))))]
+          [rtd-ref (uid)
+           (write-graph p t x
+             (lambda ()
+               (put-uptr p 0)
+               (write-fasl p t uid)))]
           [closure (offset c)
            (write-graph p t x
              (lambda ()
@@ -686,25 +705,198 @@
           [header (version machine dependencies) x]
           [else (sorry! "expected entry or header, got ~s" x)])))
 
+    ;; Almost the same as fasl-read, but in a rawer form that exposes
+    ;; more of the encoding's structure
+    (define describe
+      (lambda (x)
+        (define-syntax constant-value-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 ...]))]))
+        (let ([ht (make-eq-hashtable)])
+          (define (build-flonum high low)
+            (let ([bv (make-bytevector 8)])
+              (bytevector-u64-native-set! bv 0 (bitwise-ior low (bitwise-arithmetic-shift high 32)))
+              (bytevector-ieee-double-native-ref bv 0)))
+          (define (describe x)
+            (cond
+              [(not (fasl? x))
+               ;; Preumably from the vector of externals
+               x]
+              [else
+               (let ([p (eq-hashtable-cell ht x #f)])
+                 (or (cdr p)
+                     (let ([v (describe-next x)])
+                       (set-cdr! p v)
+                       v)))]))
+          (define (describe-next x)
+            (fasl-case x
+              [entry (situation fasl)
+               (vector 'ENTRY
+                       situation
+                       (describe fasl))]
+              [header (version machine dependencies)
+               (vector 'HEADER
+                       version
+                       machine
+                       dependencies)]
+              [pair (vfasl)
+               (let ([len (vector-length vfasl)])
+                 (let loop ([i 0])
+                   (let ([e (describe (vector-ref vfasl i))]
+                         [i (fx+ i 1)])
+                     (if (fx= i len)
+                         e
+                         (cons e (loop i))))))]
+              [tuple (ty vfasl)
+               (constant-value-case ty
+                 [(fasl-type-box fasl-type-immutable-box)
+                  (box (describe (vector-ref vfasl 0)))]
+                 [(fasl-type-ratnum)
+                  (/ (describe (vector-ref vfasl 0))
+                     (describe (vector-ref vfasl 1)))]
+                 [(fasl-type-exactnum)
+                  (make-rectangular (describe (vector-ref vfasl 0))
+                                    (describe (vector-ref vfasl 1)))]
+                 [(fasl-type-inexactnum)
+                  (make-rectangular (describe (vector-ref vfasl 0))
+                                    (describe (vector-ref vfasl 1)))]
+                 [(fasl-type-weak-pair)
+                  (weak-cons (describe (vector-ref vfasl 0))
+                             (describe (vector-ref vfasl 1)))]
+                 [(fasl-type-base-rtd)
+                  #!base-rtd]
+                 [else
+                  'unknown])]
+              [string (ty string)
+               (constant-value-case ty
+                 [(fasl-type-symbol) (string->symbol string)]
+                 [else string])]
+              [gensym (pname uname) (gensym pname uname)]
+              [vector (ty vfasl) (vector-map describe vfasl)]
+              [fxvector (viptr) viptr]
+              [flvector (vfl) vfl]
+              [bytevector (ty bv) bv]
+              [record (maybe-uid size nflds rtd pad-ty* fld*)
+               (vector 'RECORD
+                       (and maybe-uid (describe maybe-uid))
+                       size
+                       nflds
+                       (describe rtd)
+                       (map (lambda (fld)
+                               (field-case fld
+                                 [ptr (fasl) (describe fasl)]
+                                 [byte (n) n]
+                                 [iptr (n) n]
+                                 [single (n) n]
+                                 [double (high low) (build-flonum high low)]))
+                            fld*))]
+              [rtd-ref (uid) (vector 'RTD (describe uid))]
+              [closure (offset c)
+                       (vector 'CLOSURE
+                               offset
+                               (describe c))]
+              [flonum (high low) (build-flonum high low)]
+              [large-integer (sign vuptr)
+               (let loop ([v 0] [i 0])
+                 (cond
+                   [(fx= i (vector-length vuptr))
+                    (if (eqv? sign 1) (- v) v)]
+                   [else (loop (bitwise-ior (bitwise-arithmetic-shift v (constant bigit-bits))
+                                            (vector-ref vuptr i))
+                               (fx+ i 1))]))]
+              [eq-hashtable (mutable? subtype minlen veclen vpfasl)
+               (let ([ht (make-eq-hashtable)])
+                 (vector-for-each
+                  (lambda (pfasl)
+                    (eq-hashtable-set! ht (car pfasl) (cdr pfasl)))
+                  vpfasl)
+                 ht)]
+              [symbol-hashtable (mutable? minlen equiv veclen vpfasl)
+               (let ([ht (make-eq-hashtable)])
+                 (vector-for-each
+                  (lambda (pfasl)
+                    (eq-hashtable-set! ht (car pfasl) (cdr pfasl)))
+                  vpfasl)
+                 ht)]
+              [code (flags free name arity-mask info pinfo* bytes m vreloc)
+               (vector 'CODE
+                       flags
+                       free
+                       (describe name)
+                       (describe arity-mask)
+                       (describe info)
+                       (describe pinfo*)
+                       bytes
+                       m
+                       (vector-map describe vreloc))]
+              [small-integer (iptr) iptr]
+              [atom (ty uptr)
+               (constant-value-case ty
+                 [(fasl-type-immediate)
+                  (constant-value-case uptr
+                    [(snil) '()]
+                    [(sfalse) #f]
+                    [(strue) #f]
+                    [(seof) #!eof]
+                    [(sbwp) #!bwp]
+                    [(svoid) (void)]
+                    [else (vector 'IMMEDIATE uptr)])]
+                 [(fasl-type-entry) (vector 'ENTRY uptr)]
+                 [(fasl-type-library) (vector 'LIBRARY uptr)]
+                 [(fasl-type-library-code) (vector 'LIBRARY-CODE uptr)]
+                 [else x])]
+              [reloc (type-etc code-offset item-offset fasl)
+               (vector 'RELOC
+                       type-etc
+                       code-offset
+                       item-offset
+                       (describe fasl))]
+              [indirect (g i) (describe (vector-ref g i))]
+              [else x]))
+          (describe 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-from-port
+        (lambda (ip ifn init-g)
+          (let* ([script-header (read-script-header ip)]
+                 [mode (and script-header ifn (unless-feature windows (get-mode ifn)))])
+            (let loop ([rentry* '()])
+              (set! fasl-count (fx+ fasl-count 1))
+              (let ([entry (read-entry ip init-g)])
+                (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*)))))))))
       (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)]
+                      (read-and-strip-from-port ip ifn #f)))))
-                     [mode (and script-header (unless-feature windows (get-mode ifn)))])
+      (set-who! $describe-fasl-from-port
-                (let loop ([rentry* '()])
+        (rec $describe-fasl-from-port
-                  (set! fasl-count (fx+ fasl-count 1))
+          (case-lambda
-                  (let ([entry (read-entry ip)])
+           [(ip) ($describe-fasl-from-port ip '#())]
-                    (if (eof-object? entry)
+           [(ip externals)
-                        (begin
+            (unless (input-port? ip) ($oops who "~s is not an input port" ip))
-                          (close-port ip)
+            (fluid-let ([strip-inspector-information? #f]
-                          (values script-header mode (reverse rentry*)))
+                        [strip-profile-information? #f]
-                        (let ([entry (if strip-compile-time-information? (keep-revisit-info entry) entry)])
+                        [strip-source-annotations? #f]
-                          (loop (if entry (cons entry rentry*) rentry*)))))))))))
+                        [strip-compile-time-information? #f]
+                        [fasl-who who]
+                        [fasl-count 0])
+              (let-values ([(script-header mode entry*) (read-and-strip-from-port ip #f externals)])
+                (list (and script-header (describe script-header))
+                      (map describe entry*))))])))
       (set-who! strip-fasl-file
         (rec strip-fasl-file
           (lambda (ifn ofn options)
@@ -811,6 +1003,7 @@
                              (fasl=? rtd1 rtd2)
                              (andmap eqv? pad-ty*1 pad-ty*2)
                              (andmap fld=? fld*1 fld*2))]
+                       [rtd-ref (uid) (eq? uid1 uid2)]
                        [closure (offset c) (and (eqv? offset1 offset2) (fasl=? c1 c2))]
                        [flonum (high low)
                         (and (eqv? high1 high2)
@@ -895,7 +1088,7 @@
                            (if (equal? script-header1 script-header2)
                                (let loop ()
                                  (set! fasl-count (fx+ fasl-count 1))
-                                 (let ([entry1 (read-entry ip1)] [entry2 (read-entry ip2)])
+                                 (let ([entry1 (read-entry ip1 #f)] [entry2 (read-entry ip2 #f)])
                                    (if (eof-object? entry1)
                                        (or (eof-object? entry2)
                                            (and error? (bogus "~a has fewer fasl entries than ~a" ifn1 ifn2)))