Add prune-top-level-scopes pass

* module/language/cps/prune-top-level-scopes.scm: New pass, to prune
  unneeded "cache-current-module!" forms.

* module/language/cps/compile-bytecode.scm:
* module/Makefile.am: Add the new pass to the build and enable by
  default.

module/Makefile.am

@@ -129,6 +129,7 @@ CPS_LANG_SOURCES =						\
   language/cps/effects-analysis.scm				\
   language/cps/elide-values.scm					\
   language/cps/primitives.scm					\
+  language/cps/prune-top-level-scopes.scm			\
   language/cps/reify-primitives.scm				\
   language/cps/slot-allocation.scm				\
   language/cps/simplify.scm					\

module/language/cps/compile-bytecode.scm

@@ -35,6 +35,7 @@
   #:use-module (language cps dfg)
   #:use-module (language cps elide-values)
   #:use-module (language cps primitives)
+  #:use-module (language cps prune-top-level-scopes)
   #:use-module (language cps reify-primitives)
   #:use-module (language cps simplify)
   #:use-module (language cps slot-allocation)
@@ -60,6 +61,7 @@
   ;; aren't used, and thus shouldn't be consed.
 
   (let* ((exp (run-pass exp eliminate-dead-code #:eliminate-dead-code? #t))
+         (exp (run-pass exp prune-top-level-scopes #:prune-top-level-scopes? #t))
          (exp (run-pass exp simplify #:simplify? #t))
          (exp (run-pass exp contify #:contify? #t))
          (exp (run-pass exp inline-constructors #:inline-constructors? #t))

module/language/cps/prune-top-level-scopes.scm

@@ -0,0 +1,113 @@
+;;; Continuation-passing style (CPS) intermediate language (IL)
+
+;; Copyright (C) 2014 Free Software Foundation, Inc.
+
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Commentary:
+;;;
+;;; A simple pass to prune unneeded top-level scopes.
+;;;
+;;; Code:
+
+(define-module (language cps prune-top-level-scopes)
+  #:use-module (ice-9 match)
+  #:use-module (language cps)
+  #:export (prune-top-level-scopes))
+
+(define (compute-referenced-scopes fun)
+  (let ((refs (make-hash-table)))
+    (define (visit-cont cont)
+      (match cont
+        (($ $cont k ($ $kargs (name) (sym) body))
+         (visit-term body)
+         (when (hashq-get-handle refs sym)
+           (hashq-set! refs k sym)))
+        (($ $cont k ($ $kargs names syms body))
+         (visit-term body))
+        (($ $cont k ($ $kentry self tail clauses))
+         (for-each visit-cont clauses))
+        (($ $cont k ($ $kclause arity body))
+         (visit-cont body))
+        (($ $cont k (or ($ $kreceive) ($ $kif)))
+         #t)))
+    (define (visit-term term)
+      (match term
+        (($ $letk conts body)
+         (for-each visit-cont conts)
+         (visit-term body))
+        (($ $letrec names syms funs body)
+         (for-each visit-fun funs)
+         (visit-term body))
+        (($ $continue k src exp)
+         (match exp
+           (($ $fun) (visit-fun exp))
+           (($ $primcall 'cached-toplevel-box (scope name bound?))
+            (hashq-set! refs scope #t))
+           (($ $primcall 'cache-current-module! (module scope))
+            (hashq-set! refs scope #f))
+           (($ $const val)
+            ;; If there is an entry in the table for "k", it means "val"
+            ;; is a scope symbol, bound for use by cached-toplevel-box
+            ;; or cache-current-module!, or possibly both (though this
+            ;; is not currently the case).
+            (and=> (hashq-ref refs k)
+                   (lambda (sym)
+                     (when (hashq-ref refs sym)
+                       ;; We have a use via cached-toplevel-box.  Mark
+                       ;; this scope as used.
+                       (hashq-set! refs val #t))
+                     (when (and (hashq-ref refs val)
+                                (not (hashq-ref refs sym)))
+                       ;; There is a use, and this sym is used by
+                       ;; cache-current-module!.
+                       (hashq-set! refs sym #t)))))
+           (_ #t)))))
+    (define (visit-fun fun)
+      (match fun
+        (($ $fun src meta free body)
+         (visit-cont body))))
+
+    (visit-fun fun)
+    refs))
+
+(define (prune-top-level-scopes fun)
+  (let ((referenced-scopes (compute-referenced-scopes fun)))
+    (define (visit-cont cont)
+      (rewrite-cps-cont cont
+        (($ $cont sym ($ $kargs names syms body))
+         (sym ($kargs names syms ,(visit-term body))))
+        (($ $cont sym ($ $kentry self tail clauses))
+         (sym ($kentry self ,tail ,(map visit-cont clauses))))
+        (($ $cont sym ($ $kclause arity body))
+         (sym ($kclause ,arity ,(visit-cont body))))
+        (($ $cont sym (or ($ $kreceive) ($ $kif)))
+         ,cont)))
+    (define (visit-term term)
+      (rewrite-cps-term term
+        (($ $letk conts body)
+         ($letk ,(map visit-cont conts) ,(visit-term body)))
+        (($ $letrec names syms funs body)
+         ($letrec names syms funs ,(visit-term body)))
+        (($ $continue k src
+            (and ($ $primcall 'cache-current-module! (module scope))
+                 (? (lambda _
+                      (not (hashq-ref referenced-scopes scope))))))
+         ($continue k src ($primcall 'values ())))
+        (($ $continue)
+         ,term)))
+    (rewrite-cps-exp fun
+      (($ $fun src meta free body)
+       ($fun src meta free ,(visit-cont body))))))