mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-01 20:30:28 +02:00
Code Activity

Add `-Wunused-toplevel' compiler warning.

Browse source 
* 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.
This commit is contained in:
Ludovic Courtès 2010-01-11 01:19:16 +01:00
parent 7cd554943b
commit bcae9a98b0
4 changed files with 261 additions and 6 deletions
Download patch file Download diff file Expand all files Collapse all files

146
module/language/tree-il/analyze.scm
View file

@ -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))
(defs (toplevel-info-defs info)))
(make-toplevel-info refs defs)))
info)
(lambda (toplevel env)
;; Post-process the result.

1
module/language/tree-il/compile-glil.scm
View file

@ -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)))

8
module/system/base/message.scm
View file

@ -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)

108
test-suite/tests/tree-il.test
View file

@ -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"