[Guile-commits] GNU Guile branch, master, updated. v2.1.0-744-gdd69261

[Andy Wingo]

This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".

http://git.savannah.gnu.org/cgit/guile.git/commit/?id=dd692618b8345c7d6fd87c51628b5dcf1edb90db

The branch, master has been updated
       via  dd692618b8345c7d6fd87c51628b5dcf1edb90db (commit)
      from  9253198bafe57584fa44b6d0b83681e90177ace8 (commit)

Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.

- Log -----------------------------------------------------------------
commit dd692618b8345c7d6fd87c51628b5dcf1edb90db
Author: Andy Wingo <address@hidden>
Date:   Thu Feb 13 09:30:39 2014 +0100

    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.

-----------------------------------------------------------------------

Summary of changes:
 module/Makefile.am                             |    1 +
 module/language/cps/compile-bytecode.scm       |    2 +
 module/language/cps/prune-top-level-scopes.scm |  113 ++++++++++++++++++++++++
 3 files changed, 116 insertions(+), 0 deletions(-)
 create mode 100644 module/language/cps/prune-top-level-scopes.scm

diff --git a/module/Makefile.am b/module/Makefile.am
index d262818..42ee4b2 100644
--- a/module/Makefile.am
+++ b/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                                    \
diff --git a/module/language/cps/compile-bytecode.scm 
b/module/language/cps/compile-bytecode.scm
index f897303..0aa8d11 100644
--- a/module/language/cps/compile-bytecode.scm
+++ b/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))
diff --git a/module/language/cps/prune-top-level-scopes.scm 
b/module/language/cps/prune-top-level-scopes.scm
new file mode 100644
index 0000000..fc337c1
--- /dev/null
+++ b/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))))))


hooks/post-receive
-- 
GNU Guile