Add `-Wunused-toplevel' compiler warning.

* module/language/tree-il/analyze.scm (<reference-dag>): New record
  type.
  (dag-reachable-nodes, dag-reachable-nodes*, unused-variable-analysis):
  New variables.
  (unbound-variable-analysis): Slightly simplify the `up' procedure.

* module/language/tree-il/compile-glil.scm (%warning-passes): Add
  `unused-toplevel'.

* module/system/base/message.scm (%warning-types): Likewise.

* test-suite/tests/tree-il.test (%opts-w-unused-toplevel): New variable.
  ("warnings")["unused-toplevel"]: New test prefix.

module/language/tree-il/analyze.scm

@@ -6,12 +6,12 @@
 ;;;; 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
@@ -21,6 +21,7 @@
 (define-module (language tree-il analyze)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-9)
+  #:use-module (srfi srfi-11)
   #:use-module (system base syntax)
   #:use-module (system base message)
   #:use-module (system vm program)
@@ -29,6 +30,7 @@
   #:export (analyze-lexicals
             analyze-tree
             unused-variable-analysis
+            unused-toplevel-analysis
             unbound-variable-analysis
             arity-analysis))
 
@@ -635,6 +637,146 @@ accurate information is missing from a given `tree-il' element."
    (lambda (result env) #t)
    (make-binding-info '() '())))
 
+
+;;;
+;;; Unused top-level variable analysis.
+;;;
+
+;; <reference-dag> record top-level definitions that are made, references to
+;; top-level definitions and their context (the top-level definition in which
+;; the reference appears), as well as the current context (the top-level
+;; definition we're currently in).  The second part (`refs' below) is
+;; effectively a DAG from which we can determine unused top-level definitions.
+(define-record-type <reference-dag>
+  (make-reference-dag refs defs toplevel-context)
+  reference-dag?
+  (defs             reference-dag-defs) ;; ((NAME . LOC) ...)
+  (refs             reference-dag-refs) ;; ((REF-CONTEXT REF ...) ...)
+  (toplevel-context reference-dag-toplevel-context)) ;; NAME | #f
+
+(define (dag-reachable-nodes root refs)
+  ;; Return the list of nodes reachable from ROOT in DAG REFS.  REFS is an alist
+  ;; representing edges: ((A B C) (B A) (C)) corresponds to
+  ;;
+  ;;  ,-------.
+  ;;  v       |
+  ;;  A ----> B
+  ;;  |
+  ;;  v
+  ;;  C
+
+  (let loop ((root   root)
+             (path   '())
+             (result '()))
+    (if (or (memq root path)
+            (memq root result))
+        result
+        (let ((children (assoc-ref refs root)))
+          (if (not children)
+              result
+              (let ((path (cons root path)))
+                (append children
+                        (fold (lambda (child result)
+                                (loop child path result))
+                              result
+                              children))))))))
+
+(define (dag-reachable-nodes* roots refs)
+  ;; Return the list of nodes in REFS reachable from the nodes listed in ROOTS.
+  ;; FIXME: Choose a more efficient algorithm.
+  (apply lset-union eq?
+         (map (lambda (node)
+                (cons node (dag-reachable-nodes node refs)))
+              roots)))
+
+(define unused-toplevel-analysis
+  ;; Report unused top-level definitions that are not exported.
+  (let ((add-ref-from-context
+         (lambda (dag name)
+           ;; Add an edge CTX -> NAME in DAG.
+           (let* ((refs     (reference-dag-refs dag))
+                  (defs     (reference-dag-defs dag))
+                  (ctx      (reference-dag-toplevel-context dag))
+                  (ctx-refs (or (assoc-ref refs ctx) '())))
+             (make-reference-dag (alist-cons ctx (cons name ctx-refs)
+                                             (alist-delete ctx refs eq?))
+                                 defs ctx)))))
+    (define (macro-variable? name env)
+      (and (module? env)
+           (let ((var (module-variable env name)))
+             (and var (variable-bound? var)
+                  (macro? (variable-ref var))))))
+
+    (make-tree-analysis
+     (lambda (x dag env locs)
+       ;; X is a leaf.
+       (let ((ctx (reference-dag-toplevel-context dag)))
+         (record-case x
+           ((<toplevel-ref> name src)
+            (add-ref-from-context dag name))
+           (else dag))))
+
+     (lambda (x dag env locs)
+       ;; Going down into X.
+       (let ((ctx  (reference-dag-toplevel-context dag))
+             (refs (reference-dag-refs dag))
+             (defs (reference-dag-defs dag)))
+         (record-case x
+           ((<toplevel-define> name src)
+            (let ((refs refs)
+                  (defs (alist-cons name (or src (find pair? locs))
+                                    defs)))
+              (make-reference-dag refs defs name)))
+           ((<toplevel-set> name src)
+            (add-ref-from-context dag name))
+           (else dag))))
+
+     (lambda (x dag env locs)
+       ;; Leaving X's scope.
+       (record-case x
+         ((<toplevel-define>)
+          (let ((refs (reference-dag-refs dag))
+                (defs (reference-dag-defs dag)))
+            (make-reference-dag refs defs #f)))
+         (else dag)))
+
+     (lambda (dag env)
+       ;; Process the resulting reference DAG: determine all private definitions
+       ;; not reachable from any public definition.  Macros
+       ;; (syntax-transformers), which are globally bound, never considered
+       ;; unused since we can't tell whether a macro is actually used; in
+       ;; addition, macros are considered roots of the DAG since they may use
+       ;; private bindings.  FIXME: The `make-syntax-transformer' calls don't
+       ;; contain any literal `toplevel-ref' of the global bindings they use so
+       ;; this strategy fails.
+       (define (exported? name)
+         (if (module? env)
+             (module-variable (module-public-interface env) name)
+             #t))
+
+       (let-values (((public-defs private-defs)
+                     (partition (lambda (name+src)
+                                  (let ((name (car name+src)))
+                                    (or (exported? name)
+                                        (macro-variable? name env))))
+                                (reference-dag-defs dag))))
+         (let* ((roots     (cons #f (map car public-defs)))
+                (refs      (reference-dag-refs dag))
+                (reachable (dag-reachable-nodes* roots refs))
+                (unused    (filter (lambda (name+src)
+                                     ;; FIXME: This is inefficient when
+                                     ;; REACHABLE is large (e.g., boot-9.scm);
+                                     ;; use a vhash or equivalent.
+                                     (not (memq (car name+src) reachable)))
+                                   private-defs)))
+           (for-each (lambda (name+loc)
+                       (let ((name (car name+loc))
+                             (loc  (cdr name+loc)))
+                         (warning 'unused-toplevel loc name)))
+                     (reverse unused)))))
+
+     (make-reference-dag '() '() #f))))
+
 
 ;;;
 ;;; Unbound variable analysis.
@@ -732,9 +874,7 @@ accurate information is missing from a given `tree-il' element."
 
    (lambda (x info env locs)
      ;; Leaving X's scope.
-     (let ((refs (toplevel-info-refs info))
+     info)
-           (defs (toplevel-info-defs info)))
-       (make-toplevel-info refs defs)))
 
    (lambda (toplevel env)
      ;; Post-process the result.

module/language/tree-il/compile-glil.scm

@@ -45,6 +45,7 @@
 
 (define %warning-passes
   `((unused-variable     . ,unused-variable-analysis)
+    (unused-toplevel     . ,unused-toplevel-analysis)
     (unbound-variable    . ,unbound-variable-analysis)
     (arity-mismatch      . ,arity-analysis)))
 

module/system/base/message.scm

@@ -1,6 +1,6 @@
 ;;; User interface messages
 
-;; Copyright (C) 2009 Free Software Foundation, Inc.
+;; Copyright (C) 2009, 2010 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
@@ -81,6 +81,12 @@
              (format port "~A: warning: unused variable `~A'~%"
                      loc name)))
 
+         (unused-toplevel
+          "report unused local top-level variables"
+          ,(lambda (port loc name)
+             (format port "~A: warning: possibly unused local top-level variable `~A'~%"
+                     loc name)))
+
          (unbound-variable
           "report possibly unbound variables"
           ,(lambda (port loc name)

test-suite/tests/tree-il.test

@@ -554,6 +554,9 @@
 (define %opts-w-unused
   '(#:warnings (unused-variable)))
 
+(define %opts-w-unused-toplevel
+  '(#:warnings (unused-toplevel)))
+
 (define %opts-w-unbound
   '(#:warnings (unbound-variable)))
 
@@ -615,6 +618,111 @@
                   (compile '(lambda (x y z) #t)
                            #:opts %opts-w-unused))))))
 
+   (with-test-prefix "unused-toplevel"
+
+     (pass-if "used after definition"
+       (null? (call-with-warnings
+                (lambda ()
+                  (let ((in (open-input-string
+                             "(define foo 2) foo")))
+                    (read-and-compile in
+                                      #:to 'assembly
+                                      #:opts %opts-w-unused-toplevel))))))
+
+     (pass-if "used before definition"
+       (null? (call-with-warnings
+                (lambda ()
+                  (let ((in (open-input-string
+                             "(define (bar) foo) (define foo 2) (bar)")))
+                    (read-and-compile in
+                                      #:to 'assembly
+                                      #:opts %opts-w-unused-toplevel))))))
+
+     (pass-if "unused but public"
+       (let ((in (open-input-string
+                  "(define-module (test-suite tree-il x) #:export (bar))
+                   (define (bar) #t)")))
+         (null? (call-with-warnings
+                  (lambda ()
+                    (read-and-compile in
+                                      #:to 'assembly
+                                      #:opts %opts-w-unused-toplevel))))))
+
+     (pass-if "unused but public (more)"
+       (let ((in (open-input-string
+                  "(define-module (test-suite tree-il x) #:export (bar))
+                   (define (bar) (baz))
+                   (define (baz) (foo))
+                   (define (foo) #t)")))
+         (null? (call-with-warnings
+                  (lambda ()
+                    (read-and-compile in
+                                      #:to 'assembly
+                                      #:opts %opts-w-unused-toplevel))))))
+
+     (pass-if "unused but define-public"
+       ;; FIXME: We don't handle this case for now because `define-public'
+       ;; expands to a relatively complex statement that's hard to match.
+       (throw 'unresolved)
+
+       (null? (call-with-warnings
+                (lambda ()
+                  (compile '(define-public foo 2)
+                           #:to 'assembly
+                           #:opts %opts-w-unused-toplevel)))))
+
+     (pass-if "used by macro"
+       ;; FIXME: See comment about macros at `unused-toplevel-analysis'.
+       (throw 'unresolved)
+
+       (null? (call-with-warnings
+                (lambda ()
+                  (let ((in (open-input-string
+                             "(define (bar) 'foo)
+                              (define-syntax baz
+                                (syntax-rules () ((_) (bar))))")))
+                    (read-and-compile in
+                                      #:to 'assembly
+                                      #:opts %opts-w-unused-toplevel))))))
+
+     (pass-if "unused"
+       (let ((w (call-with-warnings
+                  (lambda ()
+                    (compile '(define foo 2)
+                             #:to 'assembly
+                             #:opts %opts-w-unused-toplevel)))))
+         (and (= (length w) 1)
+              (number? (string-contains (car w)
+                                        (format #f "top-level variable `~A'"
+                                                'foo))))))
+
+     (pass-if "unused recursive"
+       (let ((w (call-with-warnings
+                  (lambda ()
+                    (compile '(define (foo) (foo))
+                             #:to 'assembly
+                             #:opts %opts-w-unused-toplevel)))))
+         (and (= (length w) 1)
+              (number? (string-contains (car w)
+                                        (format #f "top-level variable `~A'"
+                                                'foo))))))
+
+     (pass-if "unused mutually recursive"
+       (let* ((in (open-input-string
+                   "(define (foo) (bar)) (define (bar) (foo))"))
+              (w  (call-with-warnings
+                    (lambda ()
+                      (read-and-compile in
+                                        #:to 'assembly
+                                        #:opts %opts-w-unused-toplevel)))))
+         (and (= (length w) 2)
+              (number? (string-contains (car w)
+                                        (format #f "top-level variable `~A'"
+                                                'foo)))
+              (number? (string-contains (cadr w)
+                                        (format #f "top-level variable `~A'"
+                                                'bar)))))))
+
    (with-test-prefix "unbound variable"
 
      (pass-if "quiet"