suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

zo-{parse,marshal}: round-trip all ".zo" formats

Browse Source 
Although `raco dec` cannot yet usefully decompile Racket CS compiled
code, the underlying `zo-parse` and `zo-marshal` functions can now at
least read and re-write that format by just keeping the bytes for the
CS-specific part, and it can also now rouind-trip the machine- and
VM-independent format.
This commit is contained in:
Matthew Flatt 2019-01-29 19:30:01 -07:00
parent b9a28b368f
commit 8b917039a2
3 changed files with 57 additions and 27 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
pkgs/compiler-lib/compiler/decompile.rkt
View File

@ -191,7 +191,10 @@
null))))
(define (decompile-single-top b)
(define forms (decompile-linklet (hash-ref (linkl-bundle-table b) 0) #:just-body? #t))
(define forms (let ([l (hash-ref (linkl-bundle-table b) 0 #f)])
(if l
(decompile-linklet l #:just-body? #t)
'(<opaque-compiled-linklet>))))
(if (= (length forms) 1)
(car forms)
`(begin ,@forms)))

69
pkgs/zo-lib/compiler/zo-marshal.rkt
View File

@ -12,7 +12,8 @@
racket/path
racket/set
racket/extflonum
racket/private/truncate-path)
racket/private/truncate-path
racket/fasl)
(provide/contract
[zo-marshal ((or/c linkl-directory? linkl-bundle?) . -> . bytes?)]
@ -45,7 +46,9 @@
(define version-bs (string->bytes/latin-1 (version)))
(write-bytes (bytes (bytes-length version-bs)) outp)
(write-bytes version-bs outp)
(define vm-bs #"racket")
(define vm-bs (or (for/or ([(name bundle) (in-hash top)])
(hash-ref (linkl-bundle-table bundle) 'vm #f))
#"racket"))
(write-bytes (bytes (bytes-length vm-bs)) outp)
(write-bytes vm-bs outp)
(write-byte (char->integer #\D) outp)
@ -73,15 +76,15 @@
name
name-bstr
0)))
;; Write order must correspond to a post-order traversal
;; of the tree, so write
;; Write order must correspond to a pre-order traversal
;; of the tree, so sort
(define pre-bundle-bytess
(sort unsorted-pre-bundle-bytess
(lambda (a b)
(let loop ([a (bundle-bytes-name-list a)] [b (bundle-bytes-name-list b)])
(cond
[(null? a) #f]
[(null? b) #t]
[(null? a) #t]
[(null? b) #f]
[(eq? (car a) (car b)) (loop (cdr a) (cdr b))]
[(symbol<? (car a) (car b)) #t]
[else #f])))))
@ -91,7 +94,7 @@
(define header-size
(+ 9
(string-length (version))
(string-length "racket")))
(bytes-length vm-bs)))
(define btree-size
(+ header-size
(apply + (for/list ([mb (in-list pre-bundle-bytess)])
@ -145,7 +148,24 @@
(for ([mb (in-list bundle-bytess)])
(write-bytes (bundle-bytes-code-bstr mb) outp)))
(define (zo-marshal-bundle-to top outp)
(define (zo-marshal-bundle-to top outp)
(case (hash-ref top 'vm #f)
[(#"racket" #f)
(zo-marshal-racket-bundle-to (hash-remove top 'vm) outp)]
[(#"linklet")
(write-bundle-header #"linklet" outp)
(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"))))
(write-bytes (integer->integer-bytes (bytes-length bstr) 4 #f #f) outp)
(write-bytes bstr outp)]
[else
(error 'zo-marshal "unknown virtual machine: ~a" (hash-ref top 'vm #f))]))
(define (zo-marshal-racket-bundle-to top outp)
; (obj -> (or pos #f)) output-port -> number
; writes top to outp using shared-obj-pos to determine symref
; returns the file position at the end of the compilation top
@ -229,21 +249,7 @@
(define all-forms-length (out-compilation-top shared-obj-pos shared-obj-pos #f counting-port))
; Write the compiled form header
(write-bytes #"#~" outp)
; Write the version (notice that it isn't the same as out-string)
(define version-bs (string->bytes/latin-1 (version)))
(write-bytes (bytes (bytes-length version-bs)) outp)
(write-bytes version-bs outp)
(define vm-bs #"racket")
(write-bytes (bytes (bytes-length vm-bs)) outp)
(write-bytes vm-bs outp)
;; "B" is for linklet "bundle" (as opposed to a linklet directory)
(write-byte (char->integer #\B) outp)
; Write empty hash code
(write-bytes (make-bytes 20 0) outp)
(write-bundle-header #"racket" outp)
; Write the symbol table information (size, offsets)
(define symtabsize (add1 (vector-length symbol-table)))
@ -261,6 +267,23 @@
(out-compilation-top shared-obj-pos shared-obj-pos #f outp)
(void))
(define (write-bundle-header vm-bs outp)
(write-bytes #"#~" outp)
; Write the version (notice that it isn't the same as out-string)
(define version-bs (string->bytes/latin-1 (version)))
(write-bytes (bytes (bytes-length version-bs)) outp)
(write-bytes version-bs outp)
(write-bytes (bytes (bytes-length vm-bs)) outp)
(write-bytes vm-bs outp)
;; "B" is for linklet "bundle" (as opposed to a linklet directory)
(write-byte (char->integer #\B) outp)
; Write empty hash code
(write-bytes (make-bytes 20 0) outp))
;; ----------------------------------------
(define toplevel-type-num 0)

10
pkgs/zo-lib/compiler/zo-parse.rkt
View File

@ -749,7 +749,7 @@
(define-values (vm mode) (read-prefix port #f))
(case mode
[(#\B) (linkl-bundle (zo-parse-top port vm))]
[(#\B) (linkl-bundle (hash-set (zo-parse-top port vm) 'vm vm))]
[(#\D)
(struct sub-info (name start len))
(define sub-infos
@ -796,10 +796,10 @@
[else
(unless (eq? tag #\B)
(error 'zo-parse "expected a bundle"))
(define sub (and tag (zo-parse-top port vm #f)))
(define sub (zo-parse-top port vm #f))
(unless (hash? sub)
(error 'zo-parse "expected a bundle hash"))
(linkl-bundle sub)]))
(linkl-bundle (hash-set sub 'vm vm))]))
(values (sub-info-name sub-info) sub))))]
[else
(error 'zo-parse "bad file format specifier")]))
@ -857,6 +857,10 @@
(set-cport-pos! cp shared-size)
(make-reader-graph (read-compact cp))]
[(equal? vm #"chez-scheme")
(hash
'opaque
(read-bytes (read-simple-number port) port))]
[else
(error 'zo-parse "cannot parse for virtual machine: ~s" vm)]))