From f23b6f8d464909fcee0938978808b69dd01ffc6a Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 8 Mar 2015 16:06:44 -0600 Subject: [PATCH] adjustments for compiled-module content --- compiler-lib/compiler/decompile.rkt | 80 ++++++++++++++++++- compiler-lib/compiler/demodularizer/merge.rkt | 3 +- compiler-lib/compiler/demodularizer/nodep.rkt | 5 +- zo-lib/compiler/zo-marshal.rkt | 14 +++- zo-lib/compiler/zo-parse.rkt | 30 ++++++- zo-lib/compiler/zo-structs.rkt | 8 +- 6 files changed, 129 insertions(+), 11 deletions(-) diff --git a/compiler-lib/compiler/decompile.rkt b/compiler-lib/compiler/decompile.rkt index d32584605d..b32d002882 100644 --- a/compiler-lib/compiler/decompile.rkt +++ b/compiler-lib/compiler/decompile.rkt @@ -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 diff --git a/compiler-lib/compiler/demodularizer/merge.rkt b/compiler-lib/compiler/demodularizer/merge.rkt index 04de2e30a9..2bbaa5344b 100644 --- a/compiler-lib/compiler/demodularizer/merge.rkt +++ b/compiler-lib/compiler/demodularizer/merge.rkt @@ -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))) diff --git a/compiler-lib/compiler/demodularizer/nodep.rkt b/compiler-lib/compiler/demodularizer/nodep.rkt index 019584d076..5db811eb4b 100644 --- a/compiler-lib/compiler/demodularizer/nodep.rkt +++ b/compiler-lib/compiler/demodularizer/nodep.rkt @@ -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))))] diff --git a/zo-lib/compiler/zo-marshal.rkt b/zo-lib/compiler/zo-marshal.rkt index bd39f9b896..75748469ae 100644 --- a/zo-lib/compiler/zo-marshal.rkt +++ b/zo-lib/compiler/zo-marshal.rkt @@ -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 diff --git a/zo-lib/compiler/zo-parse.rkt b/zo-lib/compiler/zo-parse.rkt index 93887ba133..10a84811ce 100644 --- a/zo-lib/compiler/zo-parse.rkt +++ b/zo-lib/compiler/zo-parse.rkt @@ -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 diff --git a/zo-lib/compiler/zo-structs.rkt b/zo-lib/compiler/zo-structs.rkt index 76f05281bc..bd97241008 100644 --- a/zo-lib/compiler/zo-structs.rkt +++ b/zo-lib/compiler/zo-structs.rkt @@ -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?)]))