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

adjustments for compiled-module content

Browse Source
This commit is contained in:
Matthew Flatt 2015-03-08 16:06:44 -06:00
parent 86a410dc0c
commit f23b6f8d46
6 changed files with 129 additions and 11 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

80
compiler-lib/compiler/decompile.rkt
View File

@ -55,11 +55,75 @@
(match top
[(struct compilation-top (max-let-depth prefix form))
(let-values ([(globs defns) (decompile-prefix prefix stx-ht)])
`(begin
(expose-module-path-indexes
`(begin
,@defns
,(decompile-form form globs '(#%globals) (make-hasheq) stx-ht)))]
,(decompile-form form globs '(#%globals) (make-hasheq) stx-ht))))]
[else (error 'decompile "unrecognized: ~e" top)])))
(define (expose-module-path-indexes e)
;; This is a nearly general replace-in-graph function. (It seems like a lot
;; of work to expose module path index content and sharing, though.)
(define ht (make-hasheq))
(define mconses null)
(define (x-mcons a b)
(define m (mcons a b))
(set! mconses (cons (cons m (cons a b)) mconses))
m)
(define main
(let loop ([e e])
(cond
[(hash-ref ht e #f)]
[(module-path-index? e)
(define ph (make-placeholder #f))
(hash-set! ht e ph)
(define-values (name base) (module-path-index-split e))
(placeholder-set! ph (x-mcons '#%modidx
(x-mcons (loop name)
(x-mcons (loop base)
null))))
ph]
[(pair? e)
(define ph (make-placeholder #f))
(hash-set! ht e ph)
(placeholder-set! ph (cons (loop (car e))
(loop (cdr e))))
ph]
[(mpair? e)
(define m (mcons #f #f))
(hash-set! ht e m)
(set! mconses (cons (cons m (cons (loop (mcar e))
(loop (mcdr e))))
mconses))
m]
[(box? e)
(define ph (make-placeholder #f))
(hash-set! ht e ph)
(placeholder-set! ph (box (loop (unbox e))))
ph]
[(vector? e)
(define ph (make-placeholder #f))
(hash-set! ht e ph)
(placeholder-set! ph
(for/vector #:length (vector-length e) ([i (in-vector e)])
(loop i)))
ph]
[(hash? e)
(define ph (make-placeholder #f))
(hash-set! ht e ph)
(placeholder-set! ph
(make-hash-placeholder
(for/list ([(k v) (in-hash e)])
(cons (loop k) (loop v)))))
ph]
[else
e])))
(define l (make-reader-graph (cons main mconses)))
(for ([i (in-list (cdr l))])
(set-mcar! (car i) (cadr i))
(set-mcdr! (car i) (cddr i)))
(car l))
(define (decompile-prefix a-prefix stx-ht)
(match a-prefix
[(struct prefix (num-lifts toplevels stxs))
@ -153,16 +217,26 @@
(define (decompile-module mod-form orig-stack stx-ht mod-name)
(match mod-form
[(struct mod (name srcname self-modidx prefix provides requires body syntax-bodies unexported
max-let-depth dummy lang-info internal-context flags pre-submodules post-submodules))
max-let-depth dummy lang-info
internal-context binding-names
flags pre-submodules post-submodules))
(let-values ([(globs defns) (decompile-prefix prefix stx-ht)]
[(stack) (append '(#%modvars) orig-stack)]
[(closed) (make-hasheq)])
`(,mod-name ,(if (symbol? name) name (last name)) ....
(quote self ,self-modidx)
(quote internal-context
,(if (stx? internal-context)
`(#%decode-syntax
,(decompile-stx (stx-encoded internal-context) stx-ht))
internal-context))
(quote bindings ,(for/hash ([(phase ht) (in-hash binding-names)])
(values phase
(for/hash ([(sym id) (in-hash ht)])
(values sym
`(#%decode-syntax
,(decompile-stx (stx-encoded id) stx-ht)))))))
(quote language-info ,lang-info)
,@(if (null? flags) '() (list `(quote ,flags)))
,@(let ([l (apply
append

3
compiler-lib/compiler/demodularizer/merge.rkt
View File

@ -122,7 +122,8 @@
(define (merge-module max-let-depth top-prefix mod-form)
(match mod-form
[(struct mod (name srcname self-modidx mod-prefix provides requires body syntax-bodies
unexported mod-max-let-depth dummy lang-info internal-context
unexported mod-max-let-depth dummy lang-info
internal-context binding-names
flags pre-submodules post-submodules))
(define toplevel-offset (length (prefix-toplevels top-prefix)))
(define topsyntax-offset (length (prefix-stxs top-prefix)))

5
compiler-lib/compiler/demodularizer/nodep.rkt
View File

@ -140,7 +140,8 @@
(define (nodep-module mod-form phase)
(match mod-form
[(struct mod (name srcname self-modidx prefix provides requires body syntax-bodies
unexported max-let-depth dummy lang-info internal-context
unexported max-let-depth dummy lang-info
internal-context binding-names
flags pre-submodules post-submodules))
(define new-prefix prefix)
;; Cache all the mpi paths
@ -158,7 +159,7 @@
(if (and phase (zero? phase))
(begin (log-debug (format "[~S] lang-info : ~S" name lang-info)) ; XXX Seems to always be #f now
(list (make-mod name srcname self-modidx new-prefix provides requires body empty
unexported max-let-depth dummy lang-info internal-context
unexported max-let-depth dummy lang-info internal-context #hash()
empty empty empty)))
(begin (log-debug (format "[~S] Dropping module @ ~S" name phase))
empty))))]

14
zo-lib/compiler/zo-marshal.rkt
View File

@ -999,7 +999,9 @@
(define (convert-module mod-form)
(match mod-form
[(struct mod (name srcname self-modidx prefix provides requires body syntax-bodies unexported
max-let-depth dummy lang-info internal-context flags pre-submodules post-submodules))
max-let-depth dummy lang-info
internal-context binding-names
flags pre-submodules post-submodules))
(let* ([lookup-req (lambda (phase)
(let ([a (assq phase requires)])
(if a
@ -1096,6 +1098,7 @@
[l (cons (map convert-module post-submodules) l)]
[l (cons (map convert-module pre-submodules) l)]
[l (cons (if (memq 'cross-phase flags) #t #f) l)]
[l (append (pack-binding-names binding-names) l)]
[l (cons self-modidx l)]
[l (cons srcname l)]
[l (cons (if (pair? name) (car name) name) l)]
@ -1107,6 +1110,15 @@
(λ ()
(encode-wrapped w))))
(define (pack-binding-names binding-names)
(define (ht-to-vector ht)
(list->vector (apply append (hash-map ht list))))
(list (ht-to-vector (hash-ref binding-names 0 #f))
(ht-to-vector (hash-ref binding-names 1 #f))
(apply append
(for/list ([(phase ht) (in-hash binding-names)]
#:unless (or (= phase 0) (= phase 1)))
(list phase (ht-to-vector ht))))))
(define (out-lam expr out)
(match expr

30
zo-lib/compiler/zo-parse.rkt
View File

@ -248,7 +248,9 @@
(define (read-module v)
(match v
[`(,submod-path
,name ,srcname ,self-modidx ,cross-phase?
,name ,srcname ,self-modidx
,rt-binding-names ,et-binding-names ,other-binding-names
,cross-phase?
,pre-submods ,post-submods
,lang-info ,functional? ,et-functional?
,rename ,max-let-depth ,dummy
@ -334,15 +336,41 @@
dummy
lang-info
rename
(assemble-binding-names rt-binding-names
et-binding-names
other-binding-names)
(if cross-phase? '(cross-phase) '())
(map read-module pre-submods)
(map read-module post-submods))]))]))
(define (read-module-wrap v)
v)
(define (read-inline-variant v)
(make-inline-variant (car v) (cdr v)))
(define (assemble-binding-names rt-binding-names
et-binding-names
other-binding-names)
(define (vector-to-ht vec)
(define sz (vector-length vec))
(let loop ([i 0] [ht #hasheq()])
(cond
[(= i sz) ht]
[else (loop (+ i 2)
(hash-set ht (vector-ref vec i) (vector-ref vec (add1 i))))])))
(for/hash ([(phase vec) (let* ([ht (if other-binding-names
(vector-to-ht other-binding-names)
#hash())]
[ht (if rt-binding-names
(hash-set ht 0 rt-binding-names)
ht)]
[ht (if et-binding-names
(hash-set ht 0 et-binding-names)
ht)])
ht)])
(values phase (vector-to-ht vec))))
;; ----------------------------------------
;; Unmarshal dispatch for various types

8
zo-lib/compiler/zo-structs.rkt
View File

@ -121,11 +121,11 @@
(define-form-struct (mod form) ([name (or/c symbol? (listof symbol?))]
[srcname symbol?]
[self-modidx module-path-index?]
[prefix prefix?]
[self-modidx module-path-index?]
[prefix prefix?]
[provides (listof (list/c (or/c exact-integer? #f)
(listof provided?)
(listof provided?)))]
(listof provided?)))]
[requires (listof (cons/c (or/c exact-integer? #f)
(listof module-path-index?)))]
[body (listof (or/c form? any/c))]
@ -138,6 +138,8 @@
[dummy toplevel?]
[lang-info (or/c #f (vector/c module-path? symbol? any/c))]
[internal-context (or/c #f #t stx? (vectorof stx?))]
[binding-names (hash/c exact-integer?
(hash/c symbol? stx?))]
[flags (listof (or/c 'cross-phase))]
[pre-submodules (listof mod?)]
[post-submodules (listof mod?)]))