From 887aac28d204c378bb2610241cb03326d6f9bd27 Mon Sep 17 00:00:00 2001
From: Andy Wingo <wingo@pobox.com>
Date: Wed, 28 Aug 2019 10:30:44 +0200
Subject: [PATCH] At optimization level -O3, seal declarative module-private
 bindings

* module/language/tree-il/letrectify.scm (compute-private-toplevels):
  New function; computes the subset of declarative bindings that are
  private to a module.  If the module exports a macro, all bindings are
  public, as we have no way to know what binding might be exported.
 (letrectify): Add #:seal-private-bindings? keyword arg.  If true, avoid
  making boxes for private definitions.
* module/language/tree-il/optimize.scm (optimize): Add
  -Oseal-private-bindings, enabled at -O3.
---
 module/language/tree-il/letrectify.scm | 49 ++++++++++++++++++++++++--
 module/language/tree-il/optimize.scm   |  6 +++-
 2 files changed, 52 insertions(+), 3 deletions(-)

diff --git a/module/language/tree-il/letrectify.scm b/module/language/tree-il/letrectify.scm
index 8842025fc..aecfa3128 100644
--- a/module/language/tree-il/letrectify.scm
+++ b/module/language/tree-il/letrectify.scm
@@ -125,12 +125,54 @@
                    defined)
     declarative))
 
-(define (letrectify expr)
+(define (compute-private-toplevels declarative)
+  ;; Set of variables exported by the modules of declarative bindings in
+  ;; this compilation unit.
+  (define exports (make-hash-table))
+  ;; If a module exports a macro, that macro could implicitly export any
+  ;; top-level binding in a module; we have to avoid sealing private
+  ;; bindings in that case.
+  (define exports-macro? (make-hash-table))
+  (hash-for-each
+   (lambda (k _)
+     (match k
+       ((mod . name)
+        (unless (hash-get-handle exports-macro? mod)
+          (hash-set! exports-macro? mod #f)
+          (let ((i (module-public-interface (resolve-module mod))))
+            (when i
+              (module-for-each
+               (lambda (k v)
+                 (hashq-set! exports v k)
+                 (when (and (variable-bound? v) (macro? (variable-ref v)))
+                   (hash-set! exports-macro? mod #t)))
+               i)))))))
+   declarative)
+  (let ((private (make-hash-table)))
+    (hash-for-each
+     (lambda (k _)
+       (match k
+         ((mod . name)
+          (unless (or (hash-ref exports-macro? mod)
+                      (hashq-ref exports
+                                 (module-local-variable (resolve-module mod) name)))
+            (hash-set! private k #t)))))
+     declarative)
+    private))
+
+(define* (letrectify expr #:key (seal-private-bindings? #f))
   (define declarative (compute-declarative-toplevels expr))
+  (define private
+    (if seal-private-bindings?
+        (compute-private-toplevels declarative)
+        (make-hash-table)))
   (define declarative-box+value
     (let ((tab (make-hash-table)))
       (hash-for-each (lambda (key val)
-                       (hash-set! tab key (cons (gensym) (gensym))))
+                       (let ((box (and (not (hash-ref private key))
+                                       (gensym)))
+                             (val (gensym)))
+                         (hash-set! tab key (cons box val))))
                      declarative)
       (lambda (mod name)
         (hash-ref tab (cons mod name)))))
@@ -210,6 +252,9 @@
       (($ <toplevel-define> src mod name exp)
        (match (declarative-box+value mod name)
          (#f (values (visit-expr expr) mod-vars))
+         ((#f . value)
+          (values (add-binding name value (visit-expr exp) (make-void src))
+                  mod-vars))
          ((box . value)
           (match (assoc-ref mod-vars mod)
             (#f
diff --git a/module/language/tree-il/optimize.scm b/module/language/tree-il/optimize.scm
index c252e54bf..96ccc7504 100644
--- a/module/language/tree-il/optimize.scm
+++ b/module/language/tree-il/optimize.scm
@@ -47,10 +47,13 @@
       (set! x (maybe-verify (pass x)))))
   (define (resolve* x) (resolve-primitives x env))
   (define (peval* x) (peval x env))
+  (define (letrectify* x)
+    (let ((seal? (kw-arg-ref opts #:seal-private-bindings? #f)))
+      (letrectify x #:seal-private-bindings? seal?)))
   (maybe-verify x)
   (run-pass resolve*           #:resolve-primitives? #t)
   (run-pass expand-primitives  #:expand-primitives?  #t)
-  (run-pass letrectify         #:letrectify?         #t)
+  (run-pass letrectify*        #:letrectify?         #t)
   (set! x (fix-letrec x))
   (run-pass peval*             #:partial-eval?       #t)
   x)
@@ -67,4 +70,5 @@
   '((#:resolve-primitives? 2)
     (#:expand-primitives? 1)
     (#:letrectify? 2)
+    (#:seal-private-bindings? 3)
     (#:partial-eval? 1)))