1 ;;; TREE-IL -> GLIL compiler
3 ;; Copyright (C) 2001,2008,2009,2010 Free Software Foundation, Inc.
5 ;;;; This library is free software; you can redistribute it and/or
6 ;;;; modify it under the terms of the GNU Lesser General Public
7 ;;;; License as published by the Free Software Foundation; either
8 ;;;; version 3 of the License, or (at your option) any later version.
10 ;;;; This library is distributed in the hope that it will be useful,
11 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
12 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
13 ;;;; Lesser General Public License for more details.
15 ;;;; You should have received a copy of the GNU Lesser General Public
16 ;;;; License along with this library; if not, write to the Free Software
17 ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
21 (define-module (language tree-il analyze)
22 #:use-module (srfi srfi-1)
23 #:use-module (srfi srfi-9)
24 #:use-module (srfi srfi-11)
25 #:use-module (system base syntax)
26 #:use-module (system base message)
27 #:use-module (system vm program)
28 #:use-module (language tree-il)
29 #:use-module (system base pmatch)
30 #:export (analyze-lexicals
32 unused-variable-analysis
33 unused-toplevel-analysis
34 unbound-variable-analysis
37 ;; Allocation is the process of assigning storage locations for lexical
38 ;; variables. A lexical variable has a distinct "address", or storage
39 ;; location, for each procedure in which it is referenced.
41 ;; A variable is "local", i.e., allocated on the stack, if it is
42 ;; referenced from within the procedure that defined it. Otherwise it is
43 ;; a "closure" variable. For example:
45 ;; (lambda (a) a) ; a will be local
46 ;; `a' is local to the procedure.
48 ;; (lambda (a) (lambda () a))
49 ;; `a' is local to the outer procedure, but a closure variable with
50 ;; respect to the inner procedure.
52 ;; If a variable is ever assigned, it needs to be heap-allocated
53 ;; ("boxed"). This is so that closures and continuations capture the
54 ;; variable's identity, not just one of the values it may have over the
55 ;; course of program execution. If the variable is never assigned, there
56 ;; is no distinction between value and identity, so closing over its
57 ;; identity (whether through closures or continuations) can make a copy
58 ;; of its value instead.
60 ;; Local variables are stored on the stack within a procedure's call
61 ;; frame. Their index into the stack is determined from their linear
62 ;; postion within a procedure's binding path:
69 ;; This algorithm has the problem that variables are only allocated
70 ;; indices at the end of the binding path. If variables bound early in
71 ;; the path are not used in later portions of the path, their indices
72 ;; will not be recycled. This problem is particularly egregious in the
76 ;; -> (let ((a x)) (if a a (let ((b y)) (if b b z))))
78 ;; As you can see, the `a' binding is only used in the ephemeral
79 ;; `consequent' clause of the first `if', but its index would be
80 ;; reserved for the whole of the `or' expansion. So we have a hack for
81 ;; this specific case. A proper solution would be some sort of liveness
82 ;; analysis, and not our linear allocation algorithm.
84 ;; Closure variables are captured when a closure is created, and stored
85 ;; in a vector. Each closure variable has a unique index into that
88 ;; There is one more complication. Procedures bound by <fix> may, in
89 ;; some cases, be rendered inline to their parent procedure. That is to
92 ;; (letrec ((lp (lambda () (lp)))) (lp))
93 ;; => (fix ((lp (lambda () (lp)))) (lp))
94 ;; => goto FIX-BODY; LP: goto LP; FIX-BODY: goto LP;
95 ;; ^ jump over the loop ^ the fixpoint lp ^ starting off the loop
97 ;; The upshot is that we don't have to allocate any space for the `lp'
98 ;; closure at all, as it can be rendered inline as a loop. So there is
99 ;; another kind of allocation, "label allocation", in which the
100 ;; procedure is simply a label, placed at the start of the lambda body.
101 ;; The label is the gensym under which the lambda expression is bound.
103 ;; The analyzer checks to see that the label is called with the correct
104 ;; number of arguments. Calls to labels compile to rename + goto.
105 ;; Lambda, the ultimate goto!
108 ;; The return value of `analyze-lexicals' is a hash table, the
111 ;; The allocation maps gensyms -- recall that each lexically bound
112 ;; variable has a unique gensym -- to storage locations ("addresses").
113 ;; Since one gensym may have many storage locations, if it is referenced
114 ;; in many procedures, it is a two-level map.
116 ;; The allocation also stored information on how many local variables
117 ;; need to be allocated for each procedure, lexicals that have been
118 ;; translated into labels, and information on what free variables to
119 ;; capture from its lexical parent procedure.
121 ;; In addition, we have a conflation: while we're traversing the code,
122 ;; recording information to pass to the compiler, we take the
123 ;; opportunity to generate labels for each lambda-case clause, so that
124 ;; generated code can skip argument checks at runtime if they match at
129 ;; sym -> {lambda -> address}
130 ;; lambda -> (labels . free-locs)
131 ;; lambda-case -> (gensym . nlocs)
133 ;; address ::= (local? boxed? . index)
134 ;; labels ::= ((sym . lambda) ...)
135 ;; free-locs ::= ((sym0 . address0) (sym1 . address1) ...)
136 ;; free variable addresses are relative to parent proc.
138 (define (make-hashq k v)
139 (let ((res (make-hash-table)))
143 (define (analyze-lexicals x)
144 ;; bound-vars: lambda -> (sym ...)
145 ;; all identifiers bound within a lambda
146 (define bound-vars (make-hash-table))
147 ;; free-vars: lambda -> (sym ...)
148 ;; all identifiers referenced in a lambda, but not bound
149 ;; NB, this includes identifiers referenced by contained lambdas
150 (define free-vars (make-hash-table))
151 ;; assigned: sym -> #t
152 ;; variables that are assigned
153 (define assigned (make-hash-table))
154 ;; refcounts: sym -> count
155 ;; allows us to detect the or-expansion in O(1) time
156 (define refcounts (make-hash-table))
157 ;; labels: sym -> lambda
158 ;; for determining if fixed-point procedures can be rendered as
160 (define labels (make-hash-table))
162 ;; returns variables referenced in expr
163 (define (analyze! x proc labels-in-proc tail? tail-call-args)
164 (define (step y) (analyze! y proc labels-in-proc #f #f))
165 (define (step-tail y) (analyze! y proc labels-in-proc tail? #f))
166 (define (step-tail-call y args) (analyze! y proc labels-in-proc #f
168 (define (recur/labels x new-proc labels)
169 (analyze! x new-proc (append labels labels-in-proc) #t #f))
170 (define (recur x new-proc) (analyze! x new-proc '() tail? #f))
172 ((<application> proc args)
173 (apply lset-union eq? (step-tail-call proc args)
176 ((<conditional> test consequent alternate)
177 (lset-union eq? (step test) (step-tail consequent) (step-tail alternate)))
179 ((<lexical-ref> gensym)
180 (hashq-set! refcounts gensym (1+ (hashq-ref refcounts gensym 0)))
181 (if (not (and tail-call-args
182 (memq gensym labels-in-proc)
183 (let ((p (hashq-ref labels gensym)))
185 (let lp ((c (lambda-body p)))
186 (and c (lambda-case? c)
188 ;; for now prohibit optional &
189 ;; keyword arguments; can relax this
191 (and (= (length (lambda-case-req c))
192 (length tail-call-args))
193 (not (lambda-case-opt c))
194 (not (lambda-case-kw c))
195 (not (lambda-case-rest c)))
196 (lp (lambda-case-alternate c)))))))))
197 (hashq-set! labels gensym #f))
200 ((<lexical-set> gensym exp)
201 (hashq-set! assigned gensym #t)
202 (hashq-set! labels gensym #f)
203 (lset-adjoin eq? (step exp) gensym))
208 ((<toplevel-set> exp)
211 ((<toplevel-define> exp)
215 (let lp ((exps exps) (ret '()))
216 (cond ((null? exps) '())
218 (lset-union eq? ret (step-tail (car exps))))
220 (lp (cdr exps) (lset-union eq? ret (step (car exps))))))))
223 ;; order is important here
224 (hashq-set! bound-vars x '())
225 (let ((free (recur body x)))
226 (hashq-set! bound-vars x (reverse! (hashq-ref bound-vars x)))
227 (hashq-set! free-vars x free)
230 ((<lambda-case> opt kw inits vars body alternate)
231 (hashq-set! bound-vars proc
232 (append (reverse vars) (hashq-ref bound-vars proc)))
237 (apply lset-union eq? (map step inits))
240 (if alternate (step-tail alternate) '())))
242 ((<let> vars vals body)
243 (hashq-set! bound-vars proc
244 (append (reverse vars) (hashq-ref bound-vars proc)))
246 (apply lset-union eq? (step-tail body) (map step vals))
249 ((<letrec> vars vals body)
250 (hashq-set! bound-vars proc
251 (append (reverse vars) (hashq-ref bound-vars proc)))
252 (for-each (lambda (sym) (hashq-set! assigned sym #t)) vars)
254 (apply lset-union eq? (step-tail body) (map step vals))
257 ((<fix> vars vals body)
258 ;; Try to allocate these procedures as labels.
259 (for-each (lambda (sym val) (hashq-set! labels sym val))
261 (hashq-set! bound-vars proc
262 (append (reverse vars) (hashq-ref bound-vars proc)))
263 ;; Step into subexpressions.
266 ;; Since we're trying to label-allocate the lambda,
267 ;; pretend it's not a closure, and just recurse into its
268 ;; body directly. (Otherwise, recursing on a closure
269 ;; that references one of the fix's bound vars would
270 ;; prevent label allocation.)
274 ;; just like the closure case, except here we use
275 ;; recur/labels instead of recur
276 (hashq-set! bound-vars x '())
277 (let ((free (recur/labels body x vars)))
278 (hashq-set! bound-vars x (reverse! (hashq-ref bound-vars x)))
279 (hashq-set! free-vars x free)
282 (vars-with-refs (map cons vars var-refs))
283 (body-refs (recur/labels body proc vars)))
284 (define (delabel-dependents! sym)
285 (let ((refs (assq-ref vars-with-refs sym)))
287 (for-each (lambda (sym)
288 (if (hashq-ref labels sym)
290 (hashq-set! labels sym #f)
291 (delabel-dependents! sym))))
293 ;; Stepping into the lambdas and the body might have made some
294 ;; procedures not label-allocatable -- which might have
295 ;; knock-on effects. For example:
296 ;; (fix ((a (lambda () (b)))
297 ;; (b (lambda () a)))
299 ;; As far as `a' is concerned, both `a' and `b' are
300 ;; label-allocatable. But `b' references `a' not in a proc-tail
301 ;; position, which makes `a' not label-allocatable. The
302 ;; knock-on effect is that, when back-propagating this
303 ;; information to `a', `b' will also become not
304 ;; label-allocatable, as it is referenced within `a', which is
305 ;; allocated as a closure. This is a transitive relationship.
306 (for-each (lambda (sym)
307 (if (not (hashq-ref labels sym))
308 (delabel-dependents! sym)))
310 ;; Now lift bound variables with label-allocated lambdas to the
314 (if (hashq-ref labels sym)
315 ;; Remove traces of the label-bound lambda. The free
316 ;; vars will propagate up via the return val.
318 (hashq-set! bound-vars proc
319 (append (hashq-ref bound-vars val)
320 (hashq-ref bound-vars proc)))
321 (hashq-remove! bound-vars val)
322 (hashq-remove! free-vars val))))
325 (apply lset-union eq? body-refs var-refs)
328 ((<let-values> exp body)
329 (lset-union eq? (step exp) (step body)))
333 ;; allocation: sym -> {lambda -> address}
334 ;; lambda -> (nlocs labels . free-locs)
335 (define allocation (make-hash-table))
337 (define (allocate! x proc n)
338 (define (recur y) (allocate! y proc n))
340 ((<application> proc args)
341 (apply max (recur proc) (map recur args)))
343 ((<conditional> test consequent alternate)
344 (max (recur test) (recur consequent) (recur alternate)))
352 ((<toplevel-set> exp)
355 ((<toplevel-define> exp)
359 (apply max (map recur exps)))
362 ;; allocate closure vars in order
363 (let lp ((c (hashq-ref free-vars x)) (n 0))
366 (hashq-set! (hashq-ref allocation (car c))
368 `(#f ,(hashq-ref assigned (car c)) . ,n))
369 (lp (cdr c) (1+ n)))))
371 (let ((nlocs (allocate! body x 0))
374 (hashq-ref (hashq-ref allocation v) proc))
375 (hashq-ref free-vars x)))
378 (cons sym (hashq-ref labels sym)))
379 (hashq-ref bound-vars x)))))
380 ;; set procedure allocations
381 (hashq-set! allocation x (cons labels free-addresses)))
384 ((<lambda-case> opt kw inits vars body alternate)
386 (let lp ((vars vars) (n n))
390 (allocate! body proc n)
391 ;; inits not logically at the end, but they
393 (map (lambda (x) (allocate! x proc n)) inits))))
394 ;; label and nlocs for the case
395 (hashq-set! allocation x (cons (gensym ":LCASE") nlocs))
398 (hashq-set! allocation (car vars)
400 proc `(#t ,(hashq-ref assigned (car vars)) . ,n)))
401 (lp (cdr vars) (1+ n)))))
402 (if alternate (allocate! alternate proc n) n)))
404 ((<let> vars vals body)
405 (let ((nmax (apply max (map recur vals))))
408 ((and (conditional? body)
410 (let ((v (car vars)))
411 (and (not (hashq-ref assigned v))
412 (= (hashq-ref refcounts v 0) 2)
413 (lexical-ref? (conditional-test body))
414 (eq? (lexical-ref-gensym (conditional-test body)) v)
415 (lexical-ref? (conditional-consequent body))
416 (eq? (lexical-ref-gensym (conditional-consequent body)) v))))
417 (hashq-set! allocation (car vars)
418 (make-hashq proc `(#t #f . ,n)))
419 ;; the 1+ for this var
420 (max nmax (1+ n) (allocate! (conditional-alternate body) proc n)))
422 (let lp ((vars vars) (n n))
424 (max nmax (allocate! body proc n))
425 (let ((v (car vars)))
429 `(#t ,(hashq-ref assigned v) . ,n)))
430 (lp (cdr vars) (1+ n)))))))))
432 ((<letrec> vars vals body)
433 (let lp ((vars vars) (n n))
435 (let ((nmax (apply max
437 (allocate! x proc n))
439 (max nmax (allocate! body proc n)))
440 (let ((v (car vars)))
444 `(#t ,(hashq-ref assigned v) . ,n)))
445 (lp (cdr vars) (1+ n))))))
447 ((<fix> vars vals body)
448 (let lp ((in vars) (n n))
450 (let lp ((vars vars) (vals vals) (nmax n))
453 (max nmax (allocate! body proc n)))
454 ((hashq-ref labels (car vars))
455 ;; allocate lambda body inline to proc
458 (record-case (car vals)
460 (max nmax (allocate! body proc n))))))
465 (max nmax (allocate! (car vals) proc n))))))
469 ((hashq-ref assigned v)
470 (error "fixpoint procedures may not be assigned" x))
471 ((hashq-ref labels v)
472 ;; no binding, it's a label
475 ;; allocate closure binding
476 (hashq-set! allocation v (make-hashq proc `(#t #f . ,n)))
477 (lp (cdr in) (1+ n))))))))
479 ((<let-values> exp body)
480 (max (recur exp) (recur body)))
484 (analyze! x #f '() #t #f)
491 ;;; Tree analyses for warnings.
494 (define-record-type <tree-analysis>
495 (make-tree-analysis leaf down up post init)
497 (leaf tree-analysis-leaf) ;; (lambda (x result env locs) ...)
498 (down tree-analysis-down) ;; (lambda (x result env locs) ...)
499 (up tree-analysis-up) ;; (lambda (x result env locs) ...)
500 (post tree-analysis-post) ;; (lambda (result env) ...)
501 (init tree-analysis-init)) ;; arbitrary value
503 (define (analyze-tree analyses tree env)
504 "Run all tree analyses listed in ANALYSES on TREE for ENV, using
505 `tree-il-fold'. Return TREE. The leaf/down/up procedures of each analysis are
506 passed a ``location stack', which is the stack of `tree-il-src' values for each
507 parent tree (a list); it can be used to approximate source location when
508 accurate information is missing from a given `tree-il' element."
510 (define (traverse proc update-locs)
511 ;; Return a tree traversing procedure that returns a list of analysis
512 ;; results prepended by the location stack.
514 (let ((locs (update-locs x (car results))))
515 (cons locs ;; the location stack
516 (map (lambda (analysis result)
517 ((proc analysis) x result env locs))
521 ;; Keeping/extending/shrinking the location stack.
522 (define (keep-locs x locs) locs)
523 (define (extend-locs x locs) (cons (tree-il-src x) locs))
524 (define (shrink-locs x locs) (cdr locs))
527 (tree-il-fold (traverse tree-analysis-leaf keep-locs)
528 (traverse tree-analysis-down extend-locs)
529 (traverse tree-analysis-up shrink-locs)
530 (cons '() ;; empty location stack
531 (map tree-analysis-init analyses))
534 (for-each (lambda (analysis result)
535 ((tree-analysis-post analysis) result env))
543 ;;; Unused variable analysis.
546 ;; <binding-info> records are used during tree traversals in
547 ;; `unused-variable-analysis'. They contain a list of the local vars
548 ;; currently in scope, and a list of locals vars that have been referenced.
549 (define-record-type <binding-info>
550 (make-binding-info vars refs)
552 (vars binding-info-vars) ;; ((GENSYM NAME LOCATION) ...)
553 (refs binding-info-refs)) ;; (GENSYM ...)
555 (define unused-variable-analysis
556 ;; Report unused variables in the given tree.
558 (lambda (x info env locs)
559 ;; X is a leaf: extend INFO's refs accordingly.
560 (let ((refs (binding-info-refs info))
561 (vars (binding-info-vars info)))
563 ((<lexical-ref> gensym)
564 (make-binding-info vars (cons gensym refs)))
567 (lambda (x info env locs)
568 ;; Going down into X: extend INFO's variable list
570 (let ((refs (binding-info-refs info))
571 (vars (binding-info-vars info))
572 (src (tree-il-src x)))
573 (define (extend inner-vars inner-names)
574 (append (map (lambda (var name)
580 ((<lexical-set> gensym)
581 (make-binding-info vars (cons gensym refs)))
582 ((<lambda-case> req opt inits rest kw vars)
585 ,@(if rest (list rest) '())
586 ,@(if kw (map cadr (cdr kw)) '()))))
587 (make-binding-info (extend vars names) refs)))
589 (make-binding-info (extend vars names) refs))
590 ((<letrec> vars names)
591 (make-binding-info (extend vars names) refs))
593 (make-binding-info (extend vars names) refs))
596 (lambda (x info env locs)
597 ;; Leaving X's scope: shrink INFO's variable list
598 ;; accordingly and reported unused nested variables.
599 (let ((refs (binding-info-refs info))
600 (vars (binding-info-vars info)))
601 (define (shrink inner-vars refs)
602 (for-each (lambda (var)
603 (let ((gensym (car var)))
604 ;; Don't report lambda parameters as
606 (if (and (not (memq gensym refs))
607 (not (and (lambda-case? x)
610 (let ((name (cadr var))
611 ;; We can get approximate
612 ;; source location by going up
613 ;; the LOCS location stack.
616 (warning 'unused-variable loc name)))))
617 (filter (lambda (var)
618 (memq (car var) inner-vars))
620 (fold alist-delete vars inner-vars))
622 ;; For simplicity, we leave REFS untouched, i.e., with
623 ;; names of variables that are now going out of scope.
624 ;; It doesn't hurt as these are unique names, it just
625 ;; makes REFS unnecessarily fat.
627 ((<lambda-case> vars)
628 (make-binding-info (shrink vars refs) refs))
630 (make-binding-info (shrink vars refs) refs))
632 (make-binding-info (shrink vars refs) refs))
634 (make-binding-info (shrink vars refs) refs))
637 (lambda (result env) #t)
638 (make-binding-info '() '())))
642 ;;; Unused top-level variable analysis.
645 ;; <reference-dag> record top-level definitions that are made, references to
646 ;; top-level definitions and their context (the top-level definition in which
647 ;; the reference appears), as well as the current context (the top-level
648 ;; definition we're currently in). The second part (`refs' below) is
649 ;; effectively a DAG from which we can determine unused top-level definitions.
650 (define-record-type <reference-dag>
651 (make-reference-dag refs defs toplevel-context)
653 (defs reference-dag-defs) ;; ((NAME . LOC) ...)
654 (refs reference-dag-refs) ;; ((REF-CONTEXT REF ...) ...)
655 (toplevel-context reference-dag-toplevel-context)) ;; NAME | #f
657 (define (dag-reachable-nodes root refs)
658 ;; Return the list of nodes reachable from ROOT in DAG REFS. REFS is an alist
659 ;; representing edges: ((A B C) (B A) (C)) corresponds to
668 (let loop ((root root)
671 (if (or (memq root path)
674 (let ((children (assoc-ref refs root)))
677 (let ((path (cons root path)))
679 (fold (lambda (child result)
680 (loop child path result))
684 (define (dag-reachable-nodes* roots refs)
685 ;; Return the list of nodes in REFS reachable from the nodes listed in ROOTS.
686 ;; FIXME: Choose a more efficient algorithm.
687 (apply lset-union eq?
689 (cons node (dag-reachable-nodes node refs)))
692 (define unused-toplevel-analysis
693 ;; Report unused top-level definitions that are not exported.
694 (let ((add-ref-from-context
696 ;; Add an edge CTX -> NAME in DAG.
697 (let* ((refs (reference-dag-refs dag))
698 (defs (reference-dag-defs dag))
699 (ctx (reference-dag-toplevel-context dag))
700 (ctx-refs (or (assoc-ref refs ctx) '())))
701 (make-reference-dag (alist-cons ctx (cons name ctx-refs)
702 (alist-delete ctx refs eq?))
704 (define (macro-variable? name env)
706 (let ((var (module-variable env name)))
707 (and var (variable-bound? var)
708 (macro? (variable-ref var))))))
711 (lambda (x dag env locs)
713 (let ((ctx (reference-dag-toplevel-context dag)))
715 ((<toplevel-ref> name src)
716 (add-ref-from-context dag name))
719 (lambda (x dag env locs)
720 ;; Going down into X.
721 (let ((ctx (reference-dag-toplevel-context dag))
722 (refs (reference-dag-refs dag))
723 (defs (reference-dag-defs dag)))
725 ((<toplevel-define> name src)
727 (defs (alist-cons name (or src (find pair? locs))
729 (make-reference-dag refs defs name)))
730 ((<toplevel-set> name src)
731 (add-ref-from-context dag name))
734 (lambda (x dag env locs)
735 ;; Leaving X's scope.
738 (let ((refs (reference-dag-refs dag))
739 (defs (reference-dag-defs dag)))
740 (make-reference-dag refs defs #f)))
744 ;; Process the resulting reference DAG: determine all private definitions
745 ;; not reachable from any public definition. Macros
746 ;; (syntax-transformers), which are globally bound, never considered
747 ;; unused since we can't tell whether a macro is actually used; in
748 ;; addition, macros are considered roots of the DAG since they may use
749 ;; private bindings. FIXME: The `make-syntax-transformer' calls don't
750 ;; contain any literal `toplevel-ref' of the global bindings they use so
751 ;; this strategy fails.
752 (define (exported? name)
754 (module-variable (module-public-interface env) name)
757 (let-values (((public-defs private-defs)
758 (partition (lambda (name+src)
759 (let ((name (car name+src)))
761 (macro-variable? name env))))
762 (reference-dag-defs dag))))
763 (let* ((roots (cons #f (map car public-defs)))
764 (refs (reference-dag-refs dag))
765 (reachable (dag-reachable-nodes* roots refs))
766 (unused (filter (lambda (name+src)
767 ;; FIXME: This is inefficient when
768 ;; REACHABLE is large (e.g., boot-9.scm);
769 ;; use a vhash or equivalent.
770 (not (memq (car name+src) reachable)))
772 (for-each (lambda (name+loc)
773 (let ((name (car name+loc))
774 (loc (cdr name+loc)))
775 (warning 'unused-toplevel loc name)))
778 (make-reference-dag '() '() #f))))
782 ;;; Unbound variable analysis.
785 ;; <toplevel-info> records are used during tree traversal in search of
786 ;; possibly unbound variable. They contain a list of references to
787 ;; potentially unbound top-level variables, and a list of the top-level
788 ;; defines that have been encountered.
789 (define-record-type <toplevel-info>
790 (make-toplevel-info refs defs)
792 (refs toplevel-info-refs) ;; ((VARIABLE-NAME . LOCATION) ...)
793 (defs toplevel-info-defs)) ;; (VARIABLE-NAME ...)
795 (define (goops-toplevel-definition proc args env)
796 ;; If application of PROC to ARGS is a GOOPS top-level definition, return
797 ;; the name of the variable being defined; otherwise return #f. This
798 ;; assumes knowledge of the current implementation of `define-class' et al.
799 (define (toplevel-define-arg args)
800 (and (pair? args) (pair? (cdr args)) (null? (cddr args))
801 (record-case (car args)
803 (and (symbol? exp) exp))
807 ((<module-ref> mod public? name)
808 (and (equal? mod '(oop goops))
810 (eq? name 'toplevel-define!)
811 (toplevel-define-arg args)))
812 ((<toplevel-ref> name)
813 ;; This may be the result of expanding one of the GOOPS macros within
815 (and (eq? name 'toplevel-define!)
816 (eq? env (resolve-module '(oop goops)))
817 (toplevel-define-arg args)))
820 (define unbound-variable-analysis
821 ;; Report possibly unbound variables in the given tree.
823 (lambda (x info env locs)
824 ;; X is a leaf: extend INFO's refs accordingly.
825 (let ((refs (toplevel-info-refs info))
826 (defs (toplevel-info-defs info)))
827 (define (bound? name)
828 (or (and (module? env)
829 (module-variable env name))
833 ((<toplevel-ref> name src)
836 (let ((src (or src (find pair? locs))))
837 (make-toplevel-info (alist-cons name src refs)
841 (lambda (x info env locs)
842 ;; Going down into X.
843 (let* ((refs (toplevel-info-refs info))
844 (defs (toplevel-info-defs info))
845 (src (tree-il-src x)))
846 (define (bound? name)
847 (or (and (module? env)
848 (module-variable env name))
852 ((<toplevel-set> name src)
854 (make-toplevel-info refs defs)
855 (let ((src (find pair? locs)))
856 (make-toplevel-info (alist-cons name src refs)
858 ((<toplevel-define> name)
859 (make-toplevel-info (alist-delete name refs eq?)
862 ((<application> proc args)
863 ;; Check for a dynamic top-level definition, as is
864 ;; done by code expanded from GOOPS macros.
865 (let ((name (goops-toplevel-definition proc args
868 (make-toplevel-info (alist-delete name refs
871 (make-toplevel-info refs defs))))
873 (make-toplevel-info refs defs)))))
875 (lambda (x info env locs)
876 ;; Leaving X's scope.
879 (lambda (toplevel env)
880 ;; Post-process the result.
881 (for-each (lambda (name+loc)
882 (let ((name (car name+loc))
883 (loc (cdr name+loc)))
884 (warning 'unbound-variable loc name)))
885 (reverse (toplevel-info-refs toplevel))))
887 (make-toplevel-info '() '())))
894 ;; <arity-info> records contain information about lexical definitions of
895 ;; procedures currently in scope, top-level procedure definitions that have
896 ;; been encountered, and calls to top-level procedures that have been
898 (define-record-type <arity-info>
899 (make-arity-info toplevel-calls lexical-lambdas toplevel-lambdas)
901 (toplevel-calls toplevel-procedure-calls) ;; ((NAME . APPLICATION) ...)
902 (lexical-lambdas lexical-lambdas) ;; ((GENSYM . DEFINITION) ...)
903 (toplevel-lambdas toplevel-lambdas)) ;; ((NAME . DEFINITION) ...)
905 (define (validate-arity proc application lexical?)
906 ;; Validate the argument count of APPLICATION, a tree-il application of
907 ;; PROC, emitting a warning in case of argument count mismatch.
909 (define (filter-keyword-args keywords allow-other-keys? args)
910 ;; Filter keyword arguments from ARGS and return the resulting list.
911 ;; KEYWORDS is the list of allowed keywords, and ALLOW-OTHER-KEYS?
912 ;; specified whethere keywords not listed in KEYWORDS are allowed.
913 (let loop ((args args)
917 (let ((arg (car args)))
918 (if (and (const? arg)
919 (or (memq (const-exp arg) keywords)
920 (and allow-other-keys?
921 (keyword? (const-exp arg)))))
922 (loop (if (pair? (cdr args))
927 (cons arg result)))))))
929 (define (arities proc)
930 ;; Return the arities of PROC, which can be either a tree-il or a
933 (or (and (or (null? x) (pair? x))
936 (cond ((program? proc)
937 (values (program-name proc)
939 (list (arity:nreq a) (arity:nopt a) (arity:rest? a)
940 (map car (arity:kw a))
941 (arity:allow-other-keys? a)))
942 (program-arities proc))))
944 (let ((arity (procedure-property proc 'arity)))
945 (values (procedure-name proc)
946 (list (list (car arity) (cadr arity) (caddr arity)
953 (values name (reverse arities))
955 ((<lambda-case> req opt rest kw alternate)
957 (cons (list (len req) (len opt) rest
958 (and (pair? kw) (map car (cdr kw)))
959 (and (pair? kw) (car kw)))
961 ((<lambda> meta body)
962 (loop (assoc-ref meta 'name) body arities))
964 (values #f #f))))))))
966 (let ((args (application-args application))
967 (src (tree-il-src application)))
968 (call-with-values (lambda () (arities proc))
969 (lambda (name arities)
971 (find (lambda (arity)
973 ((,req ,opt ,rest? ,kw ,aok?)
974 (let ((args (if (pair? kw)
975 (filter-keyword-args kw aok? args)
978 (let ((count (length args)))
981 (<= count (+ req opt)))))
987 (warning 'arity-mismatch src
988 (or name (with-output-to-string (lambda () (write proc))))
992 (define arity-analysis
993 ;; Report arity mismatches in the given tree.
995 (lambda (x info env locs)
998 (lambda (x info env locs)
1000 (define (extend lexical-name val info)
1001 ;; If VAL is a lambda, add NAME to the lexical-lambdas of INFO.
1002 (let ((toplevel-calls (toplevel-procedure-calls info))
1003 (lexical-lambdas (lexical-lambdas info))
1004 (toplevel-lambdas (toplevel-lambdas info)))
1007 (make-arity-info toplevel-calls
1008 (alist-cons lexical-name val
1011 ((<lexical-ref> gensym)
1013 (let ((val* (assq gensym lexical-lambdas)))
1015 (extend lexical-name (cdr val*) info)
1017 ((<toplevel-ref> name)
1019 (make-arity-info toplevel-calls
1020 (alist-cons lexical-name val
1025 (let ((toplevel-calls (toplevel-procedure-calls info))
1026 (lexical-lambdas (lexical-lambdas info))
1027 (toplevel-lambdas (toplevel-lambdas info)))
1030 ((<toplevel-define> name exp)
1033 (make-arity-info toplevel-calls
1035 (alist-cons name exp toplevel-lambdas)))
1036 ((<toplevel-ref> name)
1037 ;; alias for another toplevel
1038 (let ((proc (assq name toplevel-lambdas)))
1039 (make-arity-info toplevel-calls
1041 (alist-cons (toplevel-define-name x)
1045 toplevel-lambdas))))
1048 (fold extend info vars vals))
1049 ((<letrec> vars vals)
1050 (fold extend info vars vals))
1052 (fold extend info vars vals))
1054 ((<application> proc args src)
1057 (validate-arity proc x #t)
1059 ((<toplevel-ref> name)
1060 (make-arity-info (alist-cons name x toplevel-calls)
1063 ((<lexical-ref> gensym)
1064 (let ((proc (assq gensym lexical-lambdas)))
1066 (record-case (cdr proc)
1067 ((<toplevel-ref> name)
1068 ;; alias to toplevel
1069 (make-arity-info (alist-cons name x toplevel-calls)
1073 (validate-arity (cdr proc) x #t)
1076 ;; If GENSYM wasn't found, it may be because it's an
1077 ;; argument of the procedure being compiled.
1082 (lambda (x info env locs)
1084 (define (shrink name val info)
1085 ;; Remove NAME from the lexical-lambdas of INFO.
1086 (let ((toplevel-calls (toplevel-procedure-calls info))
1087 (lexical-lambdas (lexical-lambdas info))
1088 (toplevel-lambdas (toplevel-lambdas info)))
1089 (make-arity-info toplevel-calls
1090 (alist-delete name lexical-lambdas eq?)
1093 (let ((toplevel-calls (toplevel-procedure-calls info))
1094 (lexical-lambdas (lexical-lambdas info))
1095 (toplevel-lambdas (toplevel-lambdas info)))
1098 (fold shrink info vars vals))
1099 ((<letrec> vars vals)
1100 (fold shrink info vars vals))
1102 (fold shrink info vars vals))
1106 (lambda (result env)
1107 ;; Post-processing: check all top-level procedure calls that have been
1109 (let ((toplevel-calls (toplevel-procedure-calls result))
1110 (toplevel-lambdas (toplevel-lambdas result)))
1111 (for-each (lambda (name+application)
1112 (let* ((name (car name+application))
1113 (application (cdr name+application))
1115 (or (assoc-ref toplevel-lambdas name)
1118 (module-ref env name)))))
1120 ;; handle toplevel aliases
1121 (if (toplevel-ref? proc)
1122 (let ((name (toplevel-ref-name proc)))
1125 (module-ref env name))))
1127 ;; (format #t "toplevel-call to ~A (~A) from ~A~%"
1128 ;; name proc* application)
1129 (if (or (lambda? proc*) (procedure? proc*))
1130 (validate-arity proc* application (lambda? proc*)))))
1133 (make-arity-info '() '() '())))