mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-12 06:41:13 +02:00
Code Activity

Coalesce tree traversals made for warnings.

Browse source 
* module/language/tree-il/analyze.scm (<tree-analysis>): New type.
  (analyze-tree): New procedure.
  (report-unused-variables): Replace by...
  (unused-variable-analysis): ... this, as a <tree-analysis>.
  (report-possibly-unbound-variables): Replace by...
  (unbound-variable-analysis): ... this, as a <tree-analysis>.

* module/language/tree-il/compile-glil.scm (%warning-passes): Adjust
  accordingly.
  (compile-glil): Likewise.  Use `analyze-tree'.
This commit is contained in:
Ludovic Courtès 2009-11-06 10:42:45 +01:00
parent 632299050a
commit 48b1db7543
2 changed files with 212 additions and 177 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -25,8 +25,9 @@
#:use-module (system base message) #:use-module (system base message)
#:use-module (language tree-il) #:use-module (language tree-il)
#:export (analyze-lexicals #:export (analyze-lexicals
report-unused-variables analyze-tree
report-possibly-unbound-variables)) unused-variable-analysis
unbound-variable-analysis))
;; Allocation is the process of assigning storage locations for lexical ;; Allocation is the process of assigning storage locations for lexical
;; variables. A lexical variable has a distinct "address", or storage ;; variables. A lexical variable has a distinct "address", or storage
@ -483,6 +484,44 @@
allocation) allocation)
;;;
;;; Tree analyses for warnings.
;;;
(define-record-type <tree-analysis>
(make-tree-analysis leaf down up post init)
tree-analysis?
(leaf tree-analysis-leaf) ;; (lambda (x result env) ...)
(down tree-analysis-down) ;; (lambda (x result env) ...)
(up tree-analysis-up) ;; (lambda (x result env) ...)
(post tree-analysis-post) ;; (lambda (result env) ...)
(init tree-analysis-init)) ;; arbitrary value
(define (analyze-tree analyses tree env)
"Run all tree analyses listed in ANALYSES on TREE for ENV, using
`tree-il-fold'. Return TREE."
(define (traverse proc)
(lambda (x results)
(map (lambda (analysis result)
((proc analysis) x result env))
analyses
results)))
(let ((results
(tree-il-fold (traverse tree-analysis-leaf)
(traverse tree-analysis-down)
(traverse tree-analysis-up)
(map tree-analysis-init analyses)
tree)))
(for-each (lambda (analysis result)
((tree-analysis-post analysis) result env))
analyses
results))
tree)
;;; ;;;
;;; Unused variable analysis. ;;; Unused variable analysis.
@ -499,104 +538,104 @@
(refs binding-info-refs) ;; (GENSYM ...) (refs binding-info-refs) ;; (GENSYM ...)
(locs binding-info-locs)) ;; (LOCATION ...) (locs binding-info-locs)) ;; (LOCATION ...)
;; FIXME!! (define unused-variable-analysis
(define (report-unused-variables tree env) ;; Report about unused variables in TREE.
"Report about unused variables in TREE. Return TREE."
(tree-il-fold (lambda (x info) (make-tree-analysis
;; X is a leaf: extend INFO's refs accordingly. (lambda (x info env)
(let ((refs (binding-info-refs info)) ;; X is a leaf: extend INFO's refs accordingly.
(vars (binding-info-vars info)) (let ((refs (binding-info-refs info))
(locs (binding-info-locs info))) (vars (binding-info-vars info))
(record-case x (locs (binding-info-locs info)))
((<lexical-ref> gensym) (record-case x
(make-binding-info vars (cons gensym refs) locs)) ((<lexical-ref> gensym)
(else info)))) (make-binding-info vars (cons gensym refs) locs))
(else info))))
(lambda (x info) (lambda (x info env)
;; Going down into X: extend INFO's variable list ;; Going down into X: extend INFO's variable list
;; accordingly. ;; accordingly.
(let ((refs (binding-info-refs info)) (let ((refs (binding-info-refs info))
(vars (binding-info-vars info)) (vars (binding-info-vars info))
(locs (binding-info-locs info)) (locs (binding-info-locs info))
(src (tree-il-src x))) (src (tree-il-src x)))
(define (extend inner-vars inner-names) (define (extend inner-vars inner-names)
(append (map (lambda (var name) (append (map (lambda (var name)
(list var name src)) (list var name src))
inner-vars inner-vars
inner-names) inner-names)
vars)) vars))
(record-case x (record-case x
((<lexical-set> gensym) ((<lexical-set> gensym)
(make-binding-info vars (cons gensym refs) (make-binding-info vars (cons gensym refs)
(cons src locs))) (cons src locs)))
((<lambda-case> req opt inits rest kw vars) ((<lambda-case> req opt inits rest kw vars)
;; FIXME keywords. ;; FIXME keywords.
(let ((names `(,@req (let ((names `(,@req
,@(map car (or opt '())) ,@(map car (or opt '()))
,@(if rest (list rest) '()) ,@(if rest (list rest) '())
,@(if kw (map cadr (cdr kw)) '())))) ,@(if kw (map cadr (cdr kw)) '()))))
(make-binding-info (extend vars names) refs (make-binding-info (extend vars names) refs
(cons src locs)))) (cons src locs))))
((<let> vars names) ((<let> vars names)
(make-binding-info (extend vars names) refs (make-binding-info (extend vars names) refs
(cons src locs))) (cons src locs)))
((<letrec> vars names) ((<letrec> vars names)
(make-binding-info (extend vars names) refs (make-binding-info (extend vars names) refs
(cons src locs))) (cons src locs)))
((<fix> vars names) ((<fix> vars names)
(make-binding-info (extend vars names) refs (make-binding-info (extend vars names) refs
(cons src locs))) (cons src locs)))
(else info)))) (else info))))
(lambda (x info) (lambda (x info env)
;; Leaving X's scope: shrink INFO's variable list ;; Leaving X's scope: shrink INFO's variable list
;; accordingly and reported unused nested variables. ;; accordingly and reported unused nested variables.
(let ((refs (binding-info-refs info)) (let ((refs (binding-info-refs info))
(vars (binding-info-vars info)) (vars (binding-info-vars info))
(locs (binding-info-locs info))) (locs (binding-info-locs info)))
(define (shrink inner-vars refs) (define (shrink inner-vars refs)
(for-each (lambda (var) (for-each (lambda (var)
(let ((gensym (car var))) (let ((gensym (car var)))
;; Don't report lambda parameters as ;; Don't report lambda parameters as
;; unused. ;; unused.
(if (and (not (memq gensym refs)) (if (and (not (memq gensym refs))
(not (and (lambda-case? x) (not (and (lambda-case? x)
(memq gensym (memq gensym
inner-vars)))) inner-vars))))
(let ((name (cadr var)) (let ((name (cadr var))
;; We can get approximate ;; We can get approximate
;; source location by going up ;; source location by going up
;; the LOCS location stack. ;; the LOCS location stack.
(loc (or (caddr var) (loc (or (caddr var)
(find pair? locs)))) (find pair? locs))))
(warning 'unused-variable loc name))))) (warning 'unused-variable loc name)))))
(filter (lambda (var) (filter (lambda (var)
(memq (car var) inner-vars)) (memq (car var) inner-vars))
vars)) vars))
(fold alist-delete vars inner-vars)) (fold alist-delete vars inner-vars))
;; For simplicity, we leave REFS untouched, i.e., with ;; For simplicity, we leave REFS untouched, i.e., with
;; names of variables that are now going out of scope. ;; names of variables that are now going out of scope.
;; It doesn't hurt as these are unique names, it just ;; It doesn't hurt as these are unique names, it just
;; makes REFS unnecessarily fat. ;; makes REFS unnecessarily fat.
(record-case x (record-case x
((<lambda-case> vars) ((<lambda-case> vars)
(make-binding-info (shrink vars refs) refs (make-binding-info (shrink vars refs) refs
(cdr locs))) (cdr locs)))
((<let> vars) ((<let> vars)
(make-binding-info (shrink vars refs) refs (make-binding-info (shrink vars refs) refs
(cdr locs))) (cdr locs)))
((<letrec> vars) ((<letrec> vars)
(make-binding-info (shrink vars refs) refs (make-binding-info (shrink vars refs) refs
(cdr locs))) (cdr locs)))
((<fix> vars) ((<fix> vars)
(make-binding-info (shrink vars refs) refs (make-binding-info (shrink vars refs) refs
(cdr locs))) (cdr locs)))
(else info)))) (else info))))
(make-binding-info '() '() '())
tree) (lambda (result env) #t)
tree) (make-binding-info '() '() '())))
;;; ;;;
@ -639,84 +678,80 @@
(toplevel-define-arg args))) (toplevel-define-arg args)))
(else #f))) (else #f)))
;; TODO: Combine with `report-unused-variables' so we don't traverse the tree (define unbound-variable-analysis
;; once for each warning type. ;; Return possibly unbound variables in TREE.
(make-tree-analysis
(lambda (x info env)
;; X is a leaf: extend INFO's refs accordingly.
(let ((refs (toplevel-info-refs info))
(defs (toplevel-info-defs info))
(locs (toplevel-info-locs info)))
(define (bound? name)
(or (and (module? env)
(module-variable env name))
(memq name defs)))
(define (report-possibly-unbound-variables tree env) (record-case x
"Return possibly unbound variables in TREE. Return TREE." ((<toplevel-ref> name src)
(define toplevel (if (bound? name)
(tree-il-fold (lambda (x info) info
;; X is a leaf: extend INFO's refs accordingly. (let ((src (or src (find pair? locs))))
(let ((refs (toplevel-info-refs info)) (make-toplevel-info (alist-cons name src refs)
(defs (toplevel-info-defs info)) defs
(locs (toplevel-info-locs info))) locs))))
(define (bound? name) (else info))))
(or (and (module? env)
(module-variable env name))
(memq name defs)))
(record-case x (lambda (x info env)
((<toplevel-ref> name src) ;; Going down into X.
(if (bound? name) (let* ((refs (toplevel-info-refs info))
info (defs (toplevel-info-defs info))
(let ((src (or src (find pair? locs)))) (src (tree-il-src x))
(make-toplevel-info (alist-cons name src refs) (locs (cons src (toplevel-info-locs info))))
defs (define (bound? name)
locs)))) (or (and (module? env)
(else info)))) (module-variable env name))
(memq name defs)))
(lambda (x info) (record-case x
;; Going down into X. ((<toplevel-set> name src)
(let* ((refs (toplevel-info-refs info)) (if (bound? name)
(defs (toplevel-info-defs info)) (make-toplevel-info refs defs locs)
(src (tree-il-src x)) (let ((src (find pair? locs)))
(locs (cons src (toplevel-info-locs info)))) (make-toplevel-info (alist-cons name src refs)
(define (bound? name) defs
(or (and (module? env) locs))))
(module-variable env name)) ((<toplevel-define> name)
(memq name defs))) (make-toplevel-info (alist-delete name refs eq?)
(cons name defs)
locs))
(record-case x ((<application> proc args)
((<toplevel-set> name src) ;; Check for a dynamic top-level definition, as is
(if (bound? name) ;; done by code expanded from GOOPS macros.
(make-toplevel-info refs defs locs) (let ((name (goops-toplevel-definition proc args
(let ((src (find pair? locs))) env)))
(make-toplevel-info (alist-cons name src refs) (if (symbol? name)
defs (make-toplevel-info (alist-delete name refs
locs)))) eq?)
((<toplevel-define> name) (cons name defs)
(make-toplevel-info (alist-delete name refs eq?) locs)
(cons name defs) (make-toplevel-info refs defs locs))))
locs)) (else
(make-toplevel-info refs defs locs)))))
((<application> proc args) (lambda (x info env)
;; Check for a dynamic top-level definition, as is ;; Leaving X's scope.
;; done by code expanded from GOOPS macros. (let ((refs (toplevel-info-refs info))
(let ((name (goops-toplevel-definition proc args (defs (toplevel-info-defs info))
env))) (locs (toplevel-info-locs info)))
(if (symbol? name) (make-toplevel-info refs defs (cdr locs))))
(make-toplevel-info (alist-delete name refs
eq?)
(cons name defs)
locs)
(make-toplevel-info refs defs locs))))
(else
(make-toplevel-info refs defs locs)))))
(lambda (x info) (lambda (toplevel env)
;; Leaving X's scope. ;; Post-process the result.
(let ((refs (toplevel-info-refs info)) (for-each (lambda (name+loc)
(defs (toplevel-info-defs info)) (let ((name (car name+loc))
(locs (toplevel-info-locs info))) (loc (cdr name+loc)))
(make-toplevel-info refs defs (cdr locs)))) (warning 'unbound-variable loc name)))
(reverse (toplevel-info-refs toplevel))))
(make-toplevel-info '() '() '()) (make-toplevel-info '() '() '())))
tree))
(for-each (lambda (name+loc)
(let ((name (car name+loc))
(loc (cdr name+loc)))
(warning 'unbound-variable loc name)))
(reverse (toplevel-info-refs toplevel)))
tree)

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

@ -28,6 +28,7 @@
#:use-module (language tree-il) #:use-module (language tree-il)
#:use-module (language tree-il optimize) #:use-module (language tree-il optimize)
#:use-module (language tree-il analyze) #:use-module (language tree-il analyze)
#:use-module ((srfi srfi-1) #:select (filter-map))
#:export (compile-glil)) #:export (compile-glil))
;; allocation: ;; allocation:
@ -43,8 +44,8 @@
(define *comp-module* (make-fluid)) (define *comp-module* (make-fluid))
(define %warning-passes (define %warning-passes
`((unused-variable . ,report-unused-variables) `((unused-variable . ,unused-variable-analysis)
(unbound-variable . ,report-possibly-unbound-variables))) (unbound-variable . ,unbound-variable-analysis)))
(define (compile-glil x e opts) (define (compile-glil x e opts)
(define warnings (define warnings
@ -52,11 +53,10 @@
'())) '()))
;; Go through the warning passes. ;; Go through the warning passes.
(for-each (lambda (kind) (let ((analyses (filter-map (lambda (kind)
(let ((warn (assoc-ref %warning-passes kind))) (assoc-ref %warning-passes kind))
(and (procedure? warn) warnings)))
(warn x e)))) (analyze-tree analyses x e))
warnings)
(let* ((x (make-lambda (tree-il-src x) '() (let* ((x (make-lambda (tree-il-src x) '()
(make-lambda-case #f '() #f #f #f '() '() #f x #f))) (make-lambda-case #f '() #f #f #f '() '() #f x #f)))