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

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

@ -25,8 +25,9 @@
#:use-module (system base message)
#:use-module (language tree-il)
#:export (analyze-lexicals
report-unused-variables
report-possibly-unbound-variables))
analyze-tree
unused-variable-analysis
unbound-variable-analysis))
;; Allocation is the process of assigning storage locations for lexical
;; variables. A lexical variable has a distinct "address", or storage
@ -483,6 +484,44 @@
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.
@ -499,11 +538,11 @@
(refs binding-info-refs) ;; (GENSYM ...)
(locs binding-info-locs)) ;; (LOCATION ...)
;; FIXME!!
(define (report-unused-variables tree env)
"Report about unused variables in TREE. Return TREE."
(define unused-variable-analysis
;; Report about unused variables in TREE.
(tree-il-fold (lambda (x info)
(make-tree-analysis
(lambda (x info env)
;; X is a leaf: extend INFO's refs accordingly.
(let ((refs (binding-info-refs info))
(vars (binding-info-vars info))
@ -513,7 +552,7 @@
(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
;; accordingly.
(let ((refs (binding-info-refs info))
@ -549,7 +588,7 @@
(cons src locs)))
(else info))))
(lambda (x info)
(lambda (x info env)
;; Leaving X's scope: shrink INFO's variable list
;; accordingly and reported unused nested variables.
(let ((refs (binding-info-refs info))
@ -594,9 +633,9 @@
(make-binding-info (shrink vars refs) refs
(cdr locs)))
(else info))))
(make-binding-info '() '() '())
tree)
tree)
(lambda (result env) #t)
(make-binding-info '() '() '())))
;;;
@ -639,13 +678,10 @@
(toplevel-define-arg args)))
(else #f)))
;; TODO: Combine with `report-unused-variables' so we don't traverse the tree
;; once for each warning type.
(define (report-possibly-unbound-variables tree env)
"Return possibly unbound variables in TREE. Return TREE."
(define toplevel
(tree-il-fold (lambda (x info)
(define unbound-variable-analysis
;; 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))
@ -665,7 +701,7 @@
locs))))
(else info))))
(lambda (x info)
(lambda (x info env)
;; Going down into X.
(let* ((refs (toplevel-info-refs info))
(defs (toplevel-info-defs info))
@ -703,20 +739,19 @@
(else
(make-toplevel-info refs defs locs)))))
(lambda (x info)
(lambda (x info env)
;; Leaving X's scope.
(let ((refs (toplevel-info-refs info))
(defs (toplevel-info-defs info))
(locs (toplevel-info-locs info)))
(make-toplevel-info refs defs (cdr locs))))
(make-toplevel-info '() '() '())
tree))
(lambda (toplevel env)
;; Post-process the result.
(for-each (lambda (name+loc)
(let ((name (car name+loc))
(loc (cdr name+loc)))
(warning 'unbound-variable loc name)))
(reverse (toplevel-info-refs toplevel)))
(reverse (toplevel-info-refs toplevel))))
tree)
(make-toplevel-info '() '() '())))

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

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