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.
This commit is contained in:
Matthew Flatt
parent
a6e683cc71
commit
b2a27ef05c
|
|
@ -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))
|
||||
|
||||
|
|
|
|||
|
|
@ -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)))]
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -13,4 +13,4 @@
|
|||
|
||||
(define pkg-authors '(mflatt))
|
||||
|
||||
(define version "1.8")
|
||||
(define version "1.9")
|
||||
|
|
|
|||
|
|
@ -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}
|
||||
|
|
|
|||
5
pkgs/zo-lib/compiler/private/opaque.rkt
Normal file
5
pkgs/zo-lib/compiler/private/opaque.rkt
Normal file
|
|
@ -0,0 +1,5 @@
|
|||
#lang racket/base
|
||||
|
||||
(provide (struct-out opaque))
|
||||
|
||||
(struct opaque (bstr))
|
||||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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])
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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)))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user