adjustments for compiled-module content

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)])
+         (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

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)))

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))))]              

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

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
 

zo-lib/compiler/zo-structs.rkt

@@ -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?)]))