Skip to content
This repository was archived by the owner on Sep 13, 2019. It is now read-only.

Commit 95aa3c6

Browse files
mflattmflatt
committed
raco decompile: reconstruct modules
Also, fixes #19
1 parent 637bc9f commit 95aa3c6

File tree

6 files changed

+495
-382
lines changed

6 files changed

+495
-382
lines changed

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

Lines changed: 167 additions & 40 deletions
Original file line numberDiff line numberDiff line change
@@ -1,22 +1,37 @@
11
#lang racket/base
2-
(require compiler/zo-parse
2+
(require racket/linklet
3+
compiler/zo-parse
4+
compiler/zo-marshal
35
syntax/modcollapse
46
racket/port
57
racket/match
68
racket/list
79
racket/set
810
racket/path
9-
(only-in '#%linklet compiled-position->primitive))
11+
(only-in '#%linklet compiled-position->primitive)
12+
"private/deserialize.rkt")
1013

1114
(provide decompile)
1215

1316
;; ----------------------------------------
1417

1518
(define primitive-table
16-
(for/hash ([i (in-naturals)]
17-
#:break (not (compiled-position->primitive i)))
18-
(define v (compiled-position->primitive i))
19-
(values i (or (object-name v) v))))
19+
(let ([value-names (let ([ns (make-base-empty-namespace)])
20+
(parameterize ([current-namespace ns])
21+
(namespace-require ''#%kernel)
22+
(namespace-require ''#%unsafe)
23+
(namespace-require ''#%flfxnum)
24+
(namespace-require ''#%extfl)
25+
(namespace-require ''#%futures)
26+
(namespace-require ''#%foreign)
27+
(namespace-require ''#%paramz)
28+
(for/hasheq ([name (in-list (namespace-mapped-symbols))])
29+
(values (namespace-variable-value name #t (lambda () #f))
30+
name))))])
31+
(for/hash ([i (in-naturals)]
32+
#:break (not (compiled-position->primitive i)))
33+
(define v (compiled-position->primitive i))
34+
(values i (or (hash-ref value-names v #f) `',v)))))
2035

2136
(define (list-ref/protect l pos who)
2237
(list-ref l pos)
@@ -32,29 +47,137 @@
3247
;; Main entry:
3348
(define (decompile top #:to-linklets? [to-linklets? #f])
3449
(cond
35-
[(linkl-directory? top)
36-
(cons
37-
'linklet-directory
38-
(apply
39-
append
40-
(for/list ([(k v) (in-hash (linkl-directory-table top))])
41-
(list '#:name k '#:bundle (decompile v #:to-linklets? to-linklets?)))))]
42-
[(linkl-bundle? top)
43-
(cons
44-
'linklet-bundle
45-
(apply
46-
append
47-
(for/list ([(k v) (in-hash (linkl-bundle-table top))])
48-
(case (and (not to-linklets?) k)
49-
[(stx-data)
50-
(list '#:stx-data (decompile-data-linklet v))]
51-
[else
52-
(list '#:key k '#:value (decompile v #:to-linklets? to-linklets?))]))))]
53-
[(linkl? top)
54-
(decompile-linklet top)]
55-
[else `(quote ,top)]))
50+
[(linkl-directory? top)
51+
(cond
52+
[to-linklets?
53+
(cons
54+
'linklet-directory
55+
(apply
56+
append
57+
(for/list ([(k v) (in-hash (linkl-directory-table top))])
58+
(list '#:name k '#:bundle (decompile v #:to-linklets? to-linklets?)))))]
59+
[else
60+
(define main (hash-ref (linkl-directory-table top) '() #f))
61+
(unless main (error 'decompile "cannot find main module"))
62+
(decompile-module-with-submodules top '() main)])]
63+
[(linkl-bundle? top)
64+
(cond
65+
[to-linklets?
66+
(cons
67+
'linklet-bundle
68+
(apply
69+
append
70+
(for/list ([(k v) (in-hash (linkl-bundle-table top))])
71+
(case (and (not to-linklets?) k)
72+
[(stx-data)
73+
(list '#:stx-data (decompile-data-linklet v))]
74+
[else
75+
(list '#:key k '#:value (decompile v #:to-linklets? to-linklets?))]))))]
76+
[else
77+
(decompile-module top)])]
78+
[(linkl? top)
79+
(decompile-linklet top)]
80+
[else `(quote ,top)]))
81+
82+
(define (decompile-module-with-submodules l-dir name-list main-l)
83+
(decompile-module main-l
84+
(lambda ()
85+
(for/list ([(k l) (in-hash (linkl-directory-table l-dir))]
86+
#:when (and (list? k)
87+
(= (length k) (add1 (length name-list)))
88+
(for/and ([s1 (in-list name-list)]
89+
[s2 (in-list k)])
90+
(eq? s1 s2))))
91+
(decompile-module-with-submodules l-dir k l)))))
92+
93+
(define (decompile-module l [get-nested (lambda () '())])
94+
(define ht (linkl-bundle-table l))
95+
(define phases (sort (for/list ([k (in-hash-keys ht)]
96+
#:when (exact-integer? k))
97+
k)
98+
<))
99+
(define-values (mpi-vector requires provides)
100+
(let ([data-l (hash-ref ht 'data #f)]
101+
[decl-l (hash-ref ht 'decl #f)])
102+
(define (zo->linklet l)
103+
(let ([o (open-output-bytes)])
104+
(zo-marshal-to (linkl-bundle (hasheq 'data l)) o)
105+
(parameterize ([read-accept-compiled #t])
106+
(define b (read (open-input-bytes (get-output-bytes o))))
107+
(hash-ref (linklet-bundle->hash b) 'data))))
108+
(cond
109+
[(and data-l
110+
decl-l)
111+
(define data-i (instantiate-linklet (zo->linklet data-l)
112+
(list deserialize-instance)))
113+
(define decl-i (instantiate-linklet (zo->linklet decl-l)
114+
(list deserialize-instance
115+
data-i)))
116+
(values (instance-variable-value data-i '.mpi-vector)
117+
(instance-variable-value decl-i 'requires)
118+
(instance-variable-value decl-i 'provides))]
119+
[else (values '#() '() '())])))
120+
(define (phase-wrap phase l)
121+
(case phase
122+
[(0) l]
123+
[(1) `((for-syntax ,@l))]
124+
[(-1) `((for-template ,@l))]
125+
[(#f) `((for-label ,@l))]
126+
[else `((for-meta ,phase ,@l))]))
127+
`(module ,(hash-ref ht 'name 'unknown) ....
128+
(require ,@(apply
129+
append
130+
(for/list ([phase+mpis (in-list requires)])
131+
(phase-wrap (car phase+mpis)
132+
(map collapse-module-path-index (cdr phase+mpis))))))
133+
(provide ,@(apply
134+
append
135+
(for/list ([(phase ht) (in-hash provides)])
136+
(phase-wrap phase (hash-keys ht)))))
137+
,@(let loop ([phases phases] [depth 0])
138+
(cond
139+
[(null? phases) '()]
140+
[(= depth (car phases))
141+
(append
142+
(decompile-linklet (hash-ref ht (car phases)) #:just-body? #t)
143+
(loop (cdr phases) depth))]
144+
[else
145+
(define l (loop phases (add1 depth)))
146+
(define (convert-syntax-definition s wrap)
147+
(match s
148+
[`(let ,bindings ,body)
149+
(convert-syntax-definition body
150+
(lambda (rhs)
151+
`(let ,bindings
152+
,rhs)))]
153+
[`(begin (.set-transformer! ',id ,rhs) ',(? void?))
154+
`(define-syntaxes ,id ,(wrap rhs))]
155+
[`(begin (.set-transformer! ',ids ,rhss) ... ',(? void?))
156+
`(define-syntaxes ,ids ,(wrap `(values . ,rhss)))]
157+
[_ #f]))
158+
(let loop ([l l] [accum '()])
159+
(cond
160+
[(null? l) (if (null? accum)
161+
'()
162+
`((begin-for-syntax ,@(reverse accum))))]
163+
[(convert-syntax-definition (car l) values)
164+
=> (lambda (s)
165+
(append (loop null accum)
166+
(cons s (loop (cdr l) null))))]
167+
[else
168+
(loop (cdr l) (cons (car l) accum))]))]))
169+
,@(get-nested)
170+
,@(let ([l (hash-ref ht 'stx-data #f)])
171+
(if l
172+
`((begin-for-all
173+
(define (.get-syntax-literal! pos)
174+
....
175+
,(decompile-data-linklet l)
176+
....)))
177+
null))))
178+
56179

57-
(define (decompile-linklet l)
180+
(define (decompile-linklet l #:just-body? [just-body? #f])
58181
(match l
59182
[(struct linkl (name importss import-shapess exports internals lifts source-names body max-let-depth needs-instance?))
60183
(define closed (make-hasheq))
@@ -65,18 +188,22 @@
65188
exports
66189
internals
67190
lifts)))
68-
`(linklet
69-
,importss
70-
,exports
71-
'(import-shapes: ,@(for/list ([imports (in-list importss)]
72-
[import-shapes (in-list import-shapess)]
73-
#:when #t
74-
[import (in-list imports)]
75-
[import-shape (in-list import-shapes)]
76-
#:when import-shape)
77-
`[,import ,import-shape]))
78-
,@(for/list ([form (in-list body)])
79-
(decompile-form form globs '(#%globals) closed)))]))
191+
(define body-l
192+
(for/list ([form (in-list body)])
193+
(decompile-form form globs '(#%globals) closed)))
194+
(if just-body?
195+
body-l
196+
`(linklet
197+
,importss
198+
,exports
199+
'(import-shapes: ,@(for/list ([imports (in-list importss)]
200+
[import-shapes (in-list import-shapess)]
201+
#:when #t
202+
[import (in-list imports)]
203+
[import-shape (in-list import-shapes)]
204+
#:when import-shape)
205+
`[,import ,import-shape]))
206+
,@body-l))]))
80207

81208
(define (decompile-data-linklet l)
82209
(match l

‎pkgs/compiler-lib/compiler/demodularizer/find.rkt

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -3,7 +3,7 @@
33
compiler/zo-parse
44
syntax/modcode
55
racket/linklet
6-
"deserialize.rkt"
6+
"../private/deserialize.rkt"
77
"module-path.rkt"
88
"run.rkt")
99

‎pkgs/compiler-lib/compiler/demodularizer/deserialize.rkt renamed to ‎pkgs/compiler-lib/compiler/private/deserialize.rkt

File renamed without changes.

‎racket/src/expander/namespace/api.rkt

Lines changed: 2 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -20,6 +20,7 @@
2020
"../common/contract.rkt"
2121
"../expand/protect.rkt"
2222
"../expand/env.rkt"
23+
"../expand/binding-to-module.rkt"
2324
"../host/linklet.rkt")
2425

2526
(provide make-empty-namespace
@@ -196,11 +197,7 @@
196197
(if (module-binding? b)
197198
(values (if (top-level-module-path-index? (module-binding-module b))
198199
ns
199-
(namespace->module-namespace ns
200-
(module-binding-module b)
201-
(phase- (namespace-phase ns)
202-
(module-binding-phase b))
203-
#:complain-on-failure? #t))
200+
(module-instance-namespace (binding->module-instance b ns (namespace-phase ns) id)))
204201
(module-binding-phase b)
205202
(module-binding-sym b))
206203
(values ns (namespace-phase ns) sym))]

‎racket/src/racket/src/print.c

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -3273,7 +3273,7 @@ print(Scheme_Object *obj, int notdisplay, int compact, Scheme_Hash_Table *ht,
32733273
SCHEME_BYTE_STRLEN_VAL(SCHEME_CDR(a[i].bundle)));
32743274
}
32753275
}
3276-
else if (SAME_TYPE(SCHEME_TYPE(obj), scheme_linklet_type)
3276+
else if ((compact && SAME_TYPE(SCHEME_TYPE(obj), scheme_linklet_type))
32773277
|| SAME_TYPE(SCHEME_TYPE(obj), scheme_linklet_bundle_type))
32783278
{
32793279
if (compact) {

0 commit comments

Comments
 (0)