break link to namespaces from from closures over top-/module-level vars

- the `lam' structure from `compiler/zo-struct' changed to include a
   `toplevel-map' field

 This change helps solve a finalization problem in `racket/draw',
 which in turn sigificantly reduces the peak memory use of `raco setup'
 during the doc-building phase (because some documents load `racket/draw'
 to render images, and multiple copies of `racket/draw' were retained
 before finalization was fixed).

 The change is an extreme way to solve a specific finalization
 problem, but it's a kind of space-safety improvement; space safety
 almost never matters, but when it does, then working around a lack of
 space safety is practically impossible. In this case, it's not clear
 how to otherwise solve the `racket/draw' finalization problem.

 The improvement doesn't change the representation of closures, but it
 requires special cooperation with the GC. All closures in a module
 continue to share the same array of globals (plus syntax objects);
 that is, instead of completely flat closures, Racket uses a two-level
 environment where top-/module-level variables are grouped
 together. The code half of a closure now records which
 top-/module-level variables the body code actually uses, and the mark
 phase of GC consults this information to retain only parts of the
 top-/module-level environment frame that are actually used by some
 closure (or all of the frame if it is accessible through some other
 route).  In other words, the GC supports a kind of "dependent
 reference" to an array that is indexed by positions into the array
 --- except that the code is more in the "Racket" directory instead of
 the "GC" directory, since it's so specific to the closure
 representation.

original commit: 2ada6d0e89

collects/compiler/decompile.rkt

@@ -2,7 +2,8 @@
 (require compiler/zo-parse
          syntax/modcollapse
          scheme/port
-         scheme/match)
+         scheme/match
+         racket/set)
 
 (provide decompile)
 
@@ -42,6 +43,8 @@
 
 ;; ----------------------------------------
 
+(define-struct glob-desc (vars num-tls num-stxs num-lifts))
+
 ;; Main entry:
 (define (decompile top)
   (match top
@@ -59,7 +62,8 @@
                        (gensym 'lift))]
            [stx-ids (map (lambda (i) (gensym 'stx)) 
                          stxs)])
-       (values (append 
+       (values (glob-desc 
+                (append 
                  (map (lambda (tl)
                         (match tl
                           [#f '#%linkage]
@@ -80,6 +84,9 @@
                  stx-ids
                  (if (null? stx-ids) null '(#%stx-array))
                  lift-ids)
+                (length toplevels)
+                (length stxs)
+                num-lifts)
                (map (lambda (stx id)
                       `(define ,id ,(if stx
                                         `(#%decode-syntax ,(stx-encoded stx))
@@ -117,7 +124,7 @@
      `(define-values ,(map (lambda (tl)
                              (match tl
                                [(struct toplevel (depth pos const? mutated?))
-                                (list-ref/protect globs pos 'def-vals)]))
+                                (list-ref/protect (glob-desc-vars globs) pos 'def-vals)]))
                            ids)
         ,(decompile-expr rhs globs stack closed))]
     [(struct def-syntaxes (ids rhs prefix max-let-depth))
@@ -154,7 +161,7 @@
 
 (define (extract-id expr)
   (match expr
-    [(struct lam (name flags num-params arg-types rest? closure-map closure-types max-let-depth body))
+    [(struct lam (name flags num-params arg-types rest? closure-map closure-types tl-map max-let-depth body))
      (extract-name name)]
     [(struct case-lam (name lams))
      (extract-name name)]
@@ -179,7 +186,7 @@
 (define (decompile-tl expr globs stack closed no-check?)
   (match expr
     [(struct toplevel (depth pos const? ready?))
-     (let ([id (list-ref/protect globs pos 'toplevel)])
+     (let ([id (list-ref/protect (glob-desc-vars globs) pos 'toplevel)])
        (if (or no-check? const? ready?)
            id
            `(#%checked ,id)))]))
@@ -191,7 +198,7 @@
     [(struct varref (tl))
      `(#%variable-reference ,(decompile-tl tl globs stack closed #t))]
     [(struct topsyntax (depth pos midpt))
-     (list-ref/protect globs (+ midpt pos) 'topsyntax)]
+     (list-ref/protect (glob-desc-vars globs) (+ midpt pos) 'topsyntax)]
     [(struct primval (id))
      (hash-ref primitive-table id)]
     [(struct assign (id rhs undef-ok?))
@@ -291,7 +298,7 @@
 (define (decompile-lam expr globs stack closed)
   (match expr
     [(struct closure (lam gen-id)) (decompile-lam lam globs stack closed)]
-    [(struct lam (name flags num-params arg-types rest? closure-map closure-types max-let-depth body))
+    [(struct lam (name flags num-params arg-types rest? closure-map closure-types tl-map max-let-depth body))
      (let ([vars (for/list ([i (in-range num-params)]
                             [type (in-list arg-types)])
                    (gensym (format "~a~a-" 
@@ -315,7 +322,16 @@
                                           `(flonum ,c)
                                           c))
                                     captures
-                                    closure-types))))
+                                    closure-types)
+                             ,@(if (not tl-map)
+                                   '()
+                                   (list
+                                    (for/list ([pos (in-set tl-map)])
+                                      (list-ref/protect (glob-desc-vars globs)
+                                                        (if (pos . < . (glob-desc-num-tls globs))
+                                                            pos
+                                                            (+ pos (glob-desc-num-stxs globs) 1))
+                                                        'lam)))))))
          ,(decompile-expr body globs
                           (append captures
                                   (append vars rest-vars))

collects/compiler/demodularizer/gc-toplevels.rkt

@@ -74,7 +74,7 @@
        (for-each (lambda (f) (build-graph! lhs f)) forms)]
       [(struct splice (forms))
        (for-each (lambda (f) (build-graph! lhs f)) forms)]
-      [(and l (struct lam (name flags num-params param-types rest? closure-map closure-types max-let-depth body)))
+      [(and l (struct lam (name flags num-params param-types rest? closure-map closure-types tl-map max-let-depth body)))
        (build-graph! lhs body)]
       [(and c (struct closure (code gen-id)))
        (build-graph! lhs code)]
@@ -206,8 +206,9 @@
        (make-seq (filter identity (map update forms)))]
       [(struct splice (forms))
        (make-splice (filter identity (map update forms)))]
-      [(and l (struct lam (name flags num-params param-types rest? closure-map closure-types max-let-depth body)))
+      [(and l (struct lam (name flags num-params param-types rest? closure-map closure-types tl-map max-let-depth body)))
        (struct-copy lam l
+                    [toplevel-map #f] ; consevrative
                     [body (update body)])]
       [(and c (struct closure (code gen-id)))
        (struct-copy closure c

collects/compiler/demodularizer/update-toplevels.rkt

@@ -20,8 +20,9 @@
        (make-seq (map update forms))]
       [(struct splice (forms))
        (make-splice (map update forms))]
-      [(and l (struct lam (name flags num-params param-types rest? closure-map closure-types max-let-depth body)))
+      [(and l (struct lam (name flags num-params param-types rest? closure-map closure-types tl-map max-let-depth body)))
        (struct-copy lam l
+                    [toplevel-map #f] ; conservative
                     [body (update body)])]
       [(and c (struct closure (code gen-id)))
        (struct-copy closure c

collects/compiler/zo-marshal.rkt

@@ -968,7 +968,7 @@
 
 (define (out-lam expr out)  
   (match expr
-    [(struct lam (name flags num-params param-types rest? closure-map closure-types max-let-depth body))
+    [(struct lam (name flags num-params param-types rest? closure-map closure-types toplevel-map max-let-depth body))
      (let* ([l (protect-quote body)]
             [any-refs? (or (ormap (lambda (t) (memq t '(ref flonum))) param-types)
                            (ormap (lambda (t) (memq t '(flonum))) closure-types))]
@@ -1001,7 +1001,9 @@
                      l)]
             [l (if any-refs?
                    (cons (vector-length closure-map) l)
-                   l)])
+                   l)]
+            [tl-map (for/fold ([v 0]) ([i (in-set toplevel-map)])
+                      (bitwise-ior v (arithmetic-shift 1 i)))])
        (out-marshaled unclosed-procedure-type-num
                       (list*
                        (+ (if rest? CLOS_HAS_REST 0)
@@ -1012,6 +1014,13 @@
                           (if (memq 'single-result flags) CLOS_SINGLE_RESULT 0))
                        num-all-params
                        max-let-depth
+                       (if (tl-map . < . #x7FFFFFFF)
+                           tl-map
+                           ;; Encode as an even-sized vector of 16-bit integers:
+                           (let ([len (* 2 (quotient (+ (integer-length tl-map) 31) 32))])
+                             (for/vector ([i (in-range len)])
+                               (let ([s (* i 16)])
+                                 (bitwise-bit-field tl-map s (+ s 16))))))
                        name
                        l)
                       out))]))

collects/compiler/zo-parse.rkt

@@ -5,7 +5,8 @@
          scheme/list
          unstable/struct
          compiler/zo-structs
-         racket/dict)
+         racket/dict
+         racket/set)
 
 (provide zo-parse)
 (provide (all-from-out compiler/zo-structs))
@@ -86,7 +87,7 @@
   (define CLOS_SINGLE_RESULT 32)
   (define BITS_PER_MZSHORT 32)
   (match v
-    [`(,flags ,num-params ,max-let-depth ,name ,v . ,rest)
+    [`(,flags ,num-params ,max-let-depth ,tl-map ,name ,v . ,rest)
      (let ([rest? (positive? (bitwise-and flags CLOS_HAS_REST))])
        (let*-values ([(closure-size closed-over body)
                       (if (zero? (bitwise-and flags CLOS_HAS_REF_ARGS))
@@ -132,6 +133,20 @@
                          (vector-copy! v2 0 closed-over 0 closure-size)
                          v2))
                    closure-types
+                   (and tl-map
+                        (let* ([bits (if (exact-integer? tl-map)
+                                         tl-map
+                                         (for/fold ([i 0]) ([v (in-list tl-map)]
+                                                            [s (in-naturals)])
+                                           (bitwise-ior i (arithmetic-shift v 16))))]
+                               [len (integer-length bits)])
+                          (list->set
+                           (let loop ([bit 0])
+                             (cond
+                              [(bit . >= . len) null]
+                              [(bitwise-bit-set? bits bit)
+                               (cons bit (loop (add1 bit)))]
+                              [else (loop (add1 bit))])))))
                    max-let-depth
                    body)))]))
 

collects/compiler/zo-structs.rkt

@@ -2,7 +2,8 @@
 (require mzlib/etc 
          scheme/match
          scheme/contract
-         scheme/list)
+         scheme/list
+         racket/set)
 
 #| Unresolved issues
 
@@ -138,6 +139,7 @@
                                 [rest? boolean?]
                                 [closure-map (vectorof exact-nonnegative-integer?)]
                                 [closure-types (listof (or/c 'val/ref 'flonum))]
+                                [toplevel-map (or/c #f (set/c exact-nonnegative-integer?))]
                                 [max-let-depth exact-nonnegative-integer?]
                                 [body (or/c expr? seq? any/c)])) ; `lambda'
 (define-form-struct (closure expr) ([code lam?] [gen-id symbol?])) ; a static closure (nothing to close over)