From b2a27ef05cb1b0845e84c6429e146634f8b6aa68 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 21 Nov 2020 07:02:56 -0700 Subject: [PATCH] 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. --- .../compiler/commands/decompile.rkt | 2 + pkgs/compiler-lib/compiler/decompile.rkt | 23 +- pkgs/compiler-lib/compiler/private/chez.rkt | 88 +++++-- pkgs/compiler-lib/info.rkt | 2 +- .../scribblings/raco/decompile.scrbl | 41 ++- pkgs/zo-lib/compiler/private/opaque.rkt | 5 + pkgs/zo-lib/compiler/zo-marshal.rkt | 10 +- pkgs/zo-lib/compiler/zo-parse.rkt | 5 +- racket/src/ChezScheme/s/primdata.ss | 1 + racket/src/ChezScheme/s/print.ss | 13 +- racket/src/ChezScheme/s/strip.ss | 237 ++++++++++++++++-- 11 files changed, 352 insertions(+), 75 deletions(-) create mode 100644 pkgs/zo-lib/compiler/private/opaque.rkt diff --git a/pkgs/compiler-lib/compiler/commands/decompile.rkt b/pkgs/compiler-lib/compiler/commands/decompile.rkt index dbcb422df4..f54d4152a8 100644 --- a/pkgs/compiler-lib/compiler/commands/decompile.rkt +++ b/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)) diff --git a/pkgs/compiler-lib/compiler/decompile.rkt b/pkgs/compiler-lib/compiler/decompile.rkt index 4e1ff41399..fff96619ff 100644 --- a/pkgs/compiler-lib/compiler/decompile.rkt +++ b/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)))) - (let ([proc (decompile-chez-procedure (if (null? args) proc (apply proc args)))]) - (if (null? args) - proc - (cons proc (map (vm-primitive 'force-unfasl) args))))] + (cond + [(not (current-partial-fasl)) + ;; Note that applying the result of `vm-eval` no longer shows the setup of + ;; Racket level constants (like keywords): + (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)))] diff --git a/pkgs/compiler-lib/compiler/private/chez.rkt b/pkgs/compiler-lib/compiler/private/chez.rkt index 8502479fd5..8afdbe3d15 100644 --- a/pkgs/compiler-lib/compiler/private/chez.rkt +++ b/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 - append - (for/list ([i (in-range (code 'free-count))]) - (decompile (proc 'ref i) seen))) - (decompile-code code seen #:unwrap-body? #t))))) + (decompile-code make-code #f seen #:name "body-maker-that-creates-lifted-constants") + (decompile-code code proc 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 - #:unwrap-body? [unwrap-body? #f]) - (define name (code 'name)) +(define (decompile-code code closure seen + #:unwrap-body? [unwrap-body? #f] + #: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) - (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)))] + (disassemble-bytes-to-assembly bstr #:relocations ((code-obj 'reloc+offset) 'value))] [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 diff --git a/pkgs/compiler-lib/info.rkt b/pkgs/compiler-lib/info.rkt index e1e6f61f30..8478b7e919 100644 --- a/pkgs/compiler-lib/info.rkt +++ b/pkgs/compiler-lib/info.rkt @@ -13,4 +13,4 @@ (define pkg-authors '(mflatt)) -(define version "1.8") +(define version "1.9") diff --git a/pkgs/racket-doc/scribblings/raco/decompile.scrbl b/pkgs/racket-doc/scribblings/raco/decompile.scrbl index 5c5f641467..ecdb697511 100644 --- a/pkgs/racket-doc/scribblings/raco/decompile.scrbl +++ b/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} diff --git a/pkgs/zo-lib/compiler/private/opaque.rkt b/pkgs/zo-lib/compiler/private/opaque.rkt new file mode 100644 index 0000000000..497f52e414 --- /dev/null +++ b/pkgs/zo-lib/compiler/private/opaque.rkt @@ -0,0 +1,5 @@ +#lang racket/base + +(provide (struct-out opaque)) + +(struct opaque (bstr)) diff --git a/pkgs/zo-lib/compiler/zo-marshal.rkt b/pkgs/zo-lib/compiler/zo-marshal.rkt index afb02fefd4..9ab3d754a3 100644 --- a/pkgs/zo-lib/compiler/zo-marshal.rkt +++ b/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 - (lambda () - (error 'zo-marshal "missing 'opaque for chez-scheme virtual-machine format")))) + (define opqaue (hash-ref top 'opaque + (lambda () + (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 diff --git a/pkgs/zo-lib/compiler/zo-parse.rkt b/pkgs/zo-lib/compiler/zo-parse.rkt index 8b204ce89e..50d3d36126 100644 --- a/pkgs/zo-lib/compiler/zo-parse.rkt +++ b/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 diff --git a/racket/src/ChezScheme/s/primdata.ss b/racket/src/ChezScheme/s/primdata.ss index 4a7bfd039c..9fefe8d28f 100644 --- a/racket/src/ChezScheme/s/primdata.ss +++ b/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]) diff --git a/racket/src/ChezScheme/s/print.ss b/racket/src/ChezScheme/s/print.ss index 4647385dc7..1c20fad73d 100644 --- a/racket/src/ChezScheme/s/print.ss +++ b/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))]) - (if (string? fn) (path-last fn) fn)) - (if (source-2d? src) - (format "~a.~a" (source-2d-line src) (source-2d-column src)) - (source-bfp src))))]))) + (let ([fn (source-file-descriptor-name (source-sfd src))]) + (when (or (string? fn) (symbol? fn)) + (fprintf p " at ~a:~a" + (if (string? fn) (path-last fn) fn) + (if (source-2d? src) + (format "~a.~a" (source-2d-line src) (source-2d-column src)) + (source-bfp src))))))]))) (define wrprocedure (lambda (x p) diff --git a/racket/src/ChezScheme/s/strip.ss b/racket/src/ChezScheme/s/strip.ss index 9fea55182f..d03a5f234b 100644 --- a/racket/src/ChezScheme/s/strip.ss +++ b/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-type-uncompressed) (fasl-entry situation (read-fasl p #f))] + (fasl-entry situation (read-fasl (open-bytevector-input-port bv) init-g))))] + [(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) - (let* ([size (read-uptr p)] [nflds (read-uptr p)] [rtd (read-fasl p g)]) + (define (read-record p g maybe-uid size) + (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-record) (read-record p g #f)] + [(fasl-type-rtd) (let* ([uid (read-fasl p g)] + [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)] - [mode (and script-header (unless-feature windows (get-mode ifn)))]) - (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*))))))))))) + (read-and-strip-from-port ip ifn #f))))) + (set-who! $describe-fasl-from-port + (rec $describe-fasl-from-port + (case-lambda + [(ip) ($describe-fasl-from-port ip '#())] + [(ip externals) + (unless (input-port? ip) ($oops who "~s is not an input port" ip)) + (fluid-let ([strip-inspector-information? #f] + [strip-profile-information? #f] + [strip-source-annotations? #f] + [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)))