wingo pushed a commit to branch main
in repository guile.
commit 1f70d597dbc38585f0eeb6f5d8ca4ae62ed6ec3a
Author: Andy Wingo <wi...@pobox.com>
AuthorDate: Thu Aug 24 11:36:10 2023 +0200
Allow functions to mark themselves as maybe-unused
* module/language/tree-il/analyze.scm (<reference-graph>): Oh my
goodness, constructor args were reversed relative to field order.
Constructor use was consistent but it was terribly confusing; fixed and
updated uses.
(unused-toplevel-analysis): Add ability for functions to mark themselves
as "maybe-unused"; such functions won't cause unused toplevel warnings.
* module/language/tree-il/compile-bytecode.scm (sanitize-meta):
(compile-closure):
* module/language/tree-il/compile-cps.scm (sanitize-meta): Prevent
maybe-unused from being needlessly written out to the binary.
---
module/language/tree-il/analyze.scm | 84 ++++++++++++++++++----------
module/language/tree-il/compile-bytecode.scm | 11 +++-
module/language/tree-il/compile-cps.scm | 2 +-
3 files changed, 66 insertions(+), 31 deletions(-)
diff --git a/module/language/tree-il/analyze.scm
b/module/language/tree-il/analyze.scm
index c949b5f54..e9a803919 100644
--- a/module/language/tree-il/analyze.scm
+++ b/module/language/tree-il/analyze.scm
@@ -194,7 +194,7 @@ given `tree-il' element."
;; definition we're currently in). The second part (`refs' below) is
;; effectively a graph from which we can determine unused top-level
definitions.
(define-record-type <reference-graph>
- (make-reference-graph refs defs toplevel-context)
+ (make-reference-graph defs refs toplevel-context)
reference-graph?
(defs reference-graph-defs) ;; ((NAME . LOC) ...)
(refs reference-graph-refs) ;; ((REF-CONTEXT REF ...) ...)
@@ -257,46 +257,66 @@ given `tree-il' element."
(define unused-toplevel-analysis
;; Report unused top-level definitions that are not exported.
- (let ((add-ref-from-context
- (lambda (graph name)
- ;; Add an edge CTX -> NAME in GRAPH.
- (let* ((refs (reference-graph-refs graph))
- (defs (reference-graph-defs graph))
- (ctx (reference-graph-toplevel-context graph))
- (ctx-refs (or (and=> (vhash-assq ctx refs) cdr) '())))
- (make-reference-graph (vhash-consq ctx (cons name ctx-refs) refs)
- defs ctx)))))
+ (let ()
+ (define initial-graph
+ (make-reference-graph vlist-null vlist-null #f))
+
+ (define (add-def graph name src)
+ (match graph
+ (($ <reference-graph> defs refs ctx)
+ (make-reference-graph (vhash-consq name src defs) refs name))))
+
+ (define (add-ref graph pred succ)
+ ;; Add a ref edge PRED -> SUCC in GRAPH.
+ (match graph
+ (($ <reference-graph> defs refs ctx)
+ (let* ((succs (match (vhash-assq pred refs)
+ ((pred . succs) succs)
+ (#f '())))
+ (refs (vhash-consq pred (cons succ succs) refs)))
+ (make-reference-graph defs refs ctx)))))
+
+ (define (add-ref-from-context graph name)
+ ;; Add a ref edge from the current context to NAME in GRAPH.
+ (add-ref graph (reference-graph-toplevel-context graph) name))
+
+ (define (add-root-ref graph name)
+ ;; Add a ref edge to NAME from the root, because its metadata is
+ ;; marked maybe-unused.
+ (add-ref graph #f name))
+
(define (macro-variable? name env)
(and (module? env)
(let ((var (module-variable env name)))
(and var (variable-bound? var)
(macro? (variable-ref var))))))
+ (define (maybe-unused? metadata)
+ (assq 'maybe-unused metadata))
+
(make-tree-analysis
(lambda (x graph env locs)
;; Going down into X.
- (let ((ctx (reference-graph-toplevel-context graph))
- (refs (reference-graph-refs graph))
- (defs (reference-graph-defs graph)))
- (match x
- (($ <toplevel-ref> src mod name)
- (add-ref-from-context graph name))
- (($ <toplevel-define> src mod name expr)
- (let ((refs refs)
- (defs (vhash-consq name (or src (find pair? locs))
- defs)))
- (make-reference-graph refs defs name)))
- (($ <toplevel-set> src mod name expr)
- (add-ref-from-context graph name))
- (_ graph))))
+ (match x
+ (($ <toplevel-ref> src mod name)
+ (add-ref-from-context graph name))
+ (($ <toplevel-define> src mod name expr)
+ (let ((graph (add-def graph name (or src (find pair? locs)))))
+ (match expr
+ (($ <lambda> src (? maybe-unused?) body)
+ (add-root-ref graph name))
+ (_ graph))))
+ (($ <toplevel-set> src mod name expr)
+ (add-ref-from-context graph name))
+ (_ graph)))
(lambda (x graph env locs)
;; Leaving X's scope.
(match x
(($ <toplevel-define>)
- (let ((refs (reference-graph-refs graph))
- (defs (reference-graph-defs graph)))
- (make-reference-graph refs defs #f)))
+ (match graph
+ (($ <reference-graph> defs refs ctx)
+ (make-reference-graph defs refs #f))))
(_ graph)))
(lambda (graph env)
@@ -308,9 +328,15 @@ given `tree-il' element."
;; 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 exports (make-hash-table))
+ (when (module? env)
+ (module-for-each (lambda (name var) (hashq-set! exports var name))
+ (module-public-interface env)))
(define (exported? name)
(if (module? env)
- (module-variable (module-public-interface env) name)
+ (and=> (module-variable env name)
+ (lambda (var)
+ (hashq-ref exports var)))
#t))
(let-values (((public-defs private-defs)
@@ -332,7 +358,7 @@ given `tree-il' element."
(warning 'unused-toplevel loc name))))
unused))))
- (make-reference-graph vlist-null vlist-null #f))))
+ initial-graph)))
;;;
diff --git a/module/language/tree-il/compile-bytecode.scm
b/module/language/tree-il/compile-bytecode.scm
index 71f22dde7..c4c9bf614 100644
--- a/module/language/tree-il/compile-bytecode.scm
+++ b/module/language/tree-il/compile-bytecode.scm
@@ -724,6 +724,15 @@ in the frame with for the lambda-case clause @var{clause}."
(visit body)) ; Body.
temporary-count)))) ; Temporaries.
+(define (sanitize-meta meta)
+ (match meta
+ (() '())
+ (((k . v) . meta)
+ (let ((meta (sanitize-meta meta)))
+ (case k
+ ((maybe-unused) meta)
+ (else (acons k v meta)))))))
+
(define (compile-closure asm closure assigned? lookup-closure)
(define-record-type <env>
(make-env prev name id idx closure? boxed? next-local)
@@ -1375,7 +1384,7 @@ in the frame with for the lambda-case clause
@var{clause}."
(match closure
(($ <closure> label ($ <lambda> src meta body) module-scope free)
(when src (emit-source asm src))
- (emit-begin-program asm label meta)
+ (emit-begin-program asm label (sanitize-meta meta))
(emit-clause #f body module-scope free)
(emit-end-program asm))))
diff --git a/module/language/tree-il/compile-cps.scm
b/module/language/tree-il/compile-cps.scm
index ae5df10ed..ff22fa5ca 100644
--- a/module/language/tree-il/compile-cps.scm
+++ b/module/language/tree-il/compile-cps.scm
@@ -1315,7 +1315,7 @@ use as the proc slot."
(((k . v) . meta)
(let ((meta (sanitize-meta meta)))
(case k
- ((arg-representations noreturn return-type) meta)
+ ((arg-representations noreturn return-type maybe-unused) meta)
(else (acons k v meta)))))))
;;; The conversion from Tree-IL to CPS essentially wraps every
