diff --git a/module/language/tree-il/analyze.scm b/module/language/tree-il/analyze.scm index abda76075..f9e5b2f36 100644 --- a/module/language/tree-il/analyze.scm +++ b/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. +;;; + +;; 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 + (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 + (( 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 + (( name src) + (let ((refs refs) + (defs (alist-cons name (or src (find pair? locs)) + defs))) + (make-reference-dag refs defs name))) + (( name src) + (add-ref-from-context dag name)) + (else dag)))) + + (lambda (x dag env locs) + ;; Leaving X's scope. + (record-case x + (() + (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)) - (defs (toplevel-info-defs info))) - (make-toplevel-info refs defs))) + info) (lambda (toplevel env) ;; Post-process the result. diff --git a/module/language/tree-il/compile-glil.scm b/module/language/tree-il/compile-glil.scm index a2102c902..bfa57a19c 100644 --- a/module/language/tree-il/compile-glil.scm +++ b/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))) diff --git a/module/system/base/message.scm b/module/system/base/message.scm index bacf0415b..98bf5cf25 100644 --- a/module/system/base/message.scm +++ b/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) diff --git a/test-suite/tests/tree-il.test b/test-suite/tests/tree-il.test index f5f85d0ae..fb875ccd2 100644 --- a/test-suite/tests/tree-il.test +++ b/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"