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

@@ -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
+  (let ()
-         (lambda (graph name)
+    (define initial-graph
-           ;; Add an edge CTX -> NAME in GRAPH.
+      (make-reference-graph vlist-null vlist-null #f))
-           (let* ((refs     (reference-graph-refs graph))
+
-                  (defs     (reference-graph-defs graph))
+    (define (add-def graph name src)
-                  (ctx      (reference-graph-toplevel-context graph))
+      (match graph
-                  (ctx-refs (or (and=> (vhash-assq ctx refs) cdr) '())))
+        (($ <reference-graph> defs refs ctx)
-             (make-reference-graph (vhash-consq ctx (cons name ctx-refs) refs)
+         (make-reference-graph (vhash-consq name src defs) refs name))))
-                                   defs ctx)))))
+
+    (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))
+       (match x
-             (refs (reference-graph-refs graph))
+         (($ <toplevel-ref> src mod name)
-             (defs (reference-graph-defs graph)))
+          (add-ref-from-context graph name))
-         (match x
+         (($ <toplevel-define> src mod name expr)
-           (($ <toplevel-ref> src mod name)
+          (let ((graph (add-def graph name (or src (find pair? locs)))))
-            (add-ref-from-context graph name))
+            (match expr
-           (($ <toplevel-define> src mod name expr)
+              (($ <lambda> src (? maybe-unused?) body)
-            (let ((refs refs)
+               (add-root-ref graph name))
-                  (defs (vhash-consq name (or src (find pair? locs))
+              (_ graph))))
-                                     defs)))
+         (($ <toplevel-set> src mod name expr)
-              (make-reference-graph refs defs name)))
+          (add-ref-from-context graph name))
-           (($ <toplevel-set> src mod name expr)
+         (_ graph)))
-            (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))
+          (match graph
-                (defs (reference-graph-defs graph)))
+            (($ <reference-graph> defs refs ctx)
-            (make-reference-graph refs defs #f)))
+             (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)))
 
 
 ;;;

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

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