1 ;;; TREE-IL -> GLIL compiler
3 ;; Copyright (C) 2001,2008,2009 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 (system base syntax)
25 #:use-module (system base message)
26 #:use-module (system vm program)
27 #:use-module (language tree-il)
28 #:export (analyze-lexicals
30 unused-variable-analysis
31 unbound-variable-analysis
34 ;; Allocation is the process of assigning storage locations for lexical
35 ;; variables. A lexical variable has a distinct "address", or storage
36 ;; location, for each procedure in which it is referenced.
38 ;; A variable is "local", i.e., allocated on the stack, if it is
39 ;; referenced from within the procedure that defined it. Otherwise it is
40 ;; a "closure" variable. For example:
42 ;; (lambda (a) a) ; a will be local
43 ;; `a' is local to the procedure.
45 ;; (lambda (a) (lambda () a))
46 ;; `a' is local to the outer procedure, but a closure variable with
47 ;; respect to the inner procedure.
49 ;; If a variable is ever assigned, it needs to be heap-allocated
50 ;; ("boxed"). This is so that closures and continuations capture the
51 ;; variable's identity, not just one of the values it may have over the
52 ;; course of program execution. If the variable is never assigned, there
53 ;; is no distinction between value and identity, so closing over its
54 ;; identity (whether through closures or continuations) can make a copy
55 ;; of its value instead.
57 ;; Local variables are stored on the stack within a procedure's call
58 ;; frame. Their index into the stack is determined from their linear
59 ;; postion within a procedure's binding path:
66 ;; This algorithm has the problem that variables are only allocated
67 ;; indices at the end of the binding path. If variables bound early in
68 ;; the path are not used in later portions of the path, their indices
69 ;; will not be recycled. This problem is particularly egregious in the
73 ;; -> (let ((a x)) (if a a (let ((b y)) (if b b z))))
75 ;; As you can see, the `a' binding is only used in the ephemeral `then'
76 ;; clause of the first `if', but its index would be reserved for the
77 ;; whole of the `or' expansion. So we have a hack for this specific
78 ;; case. A proper solution would be some sort of liveness analysis, and
79 ;; not our linear allocation algorithm.
81 ;; Closure variables are captured when a closure is created, and stored
82 ;; in a vector. Each closure variable has a unique index into that
85 ;; There is one more complication. Procedures bound by <fix> may, in
86 ;; some cases, be rendered inline to their parent procedure. That is to
89 ;; (letrec ((lp (lambda () (lp)))) (lp))
90 ;; => (fix ((lp (lambda () (lp)))) (lp))
91 ;; => goto FIX-BODY; LP: goto LP; FIX-BODY: goto LP;
92 ;; ^ jump over the loop ^ the fixpoint lp ^ starting off the loop
94 ;; The upshot is that we don't have to allocate any space for the `lp'
95 ;; closure at all, as it can be rendered inline as a loop. So there is
96 ;; another kind of allocation, "label allocation", in which the
97 ;; procedure is simply a label, placed at the start of the lambda body.
98 ;; The label is the gensym under which the lambda expression is bound.
100 ;; The analyzer checks to see that the label is called with the correct
101 ;; number of arguments. Calls to labels compile to rename + goto.
102 ;; Lambda, the ultimate goto!
105 ;; The return value of `analyze-lexicals' is a hash table, the
108 ;; The allocation maps gensyms -- recall that each lexically bound
109 ;; variable has a unique gensym -- to storage locations ("addresses").
110 ;; Since one gensym may have many storage locations, if it is referenced
111 ;; in many procedures, it is a two-level map.
113 ;; The allocation also stored information on how many local variables
114 ;; need to be allocated for each procedure, lexicals that have been
115 ;; translated into labels, and information on what free variables to
116 ;; capture from its lexical parent procedure.
118 ;; In addition, we have a conflation: while we're traversing the code,
119 ;; recording information to pass to the compiler, we take the
120 ;; opportunity to generate labels for each lambda-case clause, so that
121 ;; generated code can skip argument checks at runtime if they match at
126 ;; sym -> {lambda -> address}
127 ;; lambda -> (labels . free-locs)
128 ;; lambda-case -> (gensym . nlocs)
130 ;; address ::= (local? boxed? . index)
131 ;; labels ::= ((sym . lambda) ...)
132 ;; free-locs ::= ((sym0 . address0) (sym1 . address1) ...)
133 ;; free variable addresses are relative to parent proc.
135 (define (make-hashq k v)
136 (let ((res (make-hash-table)))
140 (define (analyze-lexicals x)
141 ;; bound-vars: lambda -> (sym ...)
142 ;; all identifiers bound within a lambda
143 (define bound-vars (make-hash-table))
144 ;; free-vars: lambda -> (sym ...)
145 ;; all identifiers referenced in a lambda, but not bound
146 ;; NB, this includes identifiers referenced by contained lambdas
147 (define free-vars (make-hash-table))
148 ;; assigned: sym -> #t
149 ;; variables that are assigned
150 (define assigned (make-hash-table))
151 ;; refcounts: sym -> count
152 ;; allows us to detect the or-expansion in O(1) time
153 (define refcounts (make-hash-table))
154 ;; labels: sym -> lambda
155 ;; for determining if fixed-point procedures can be rendered as
157 (define labels (make-hash-table))
159 ;; returns variables referenced in expr
160 (define (analyze! x proc labels-in-proc tail? tail-call-args)
161 (define (step y) (analyze! y proc labels-in-proc #f #f))
162 (define (step-tail y) (analyze! y proc labels-in-proc tail? #f))
163 (define (step-tail-call y args) (analyze! y proc labels-in-proc #f
165 (define (recur/labels x new-proc labels)
166 (analyze! x new-proc (append labels labels-in-proc) #t #f))
167 (define (recur x new-proc) (analyze! x new-proc '() tail? #f))
169 ((<application> proc args)
170 (apply lset-union eq? (step-tail-call proc args)
173 ((<conditional> test then else)
174 (lset-union eq? (step test) (step-tail then) (step-tail else)))
176 ((<lexical-ref> gensym)
177 (hashq-set! refcounts gensym (1+ (hashq-ref refcounts gensym 0)))
178 (if (not (and tail-call-args
179 (memq gensym labels-in-proc)
180 (let ((p (hashq-ref labels gensym)))
182 (let lp ((c (lambda-body p)))
183 (and c (lambda-case? c)
185 ;; for now prohibit optional &
186 ;; keyword arguments; can relax this
188 (and (= (length (lambda-case-req c))
189 (length tail-call-args))
190 (not (lambda-case-opt c))
191 (not (lambda-case-kw c))
192 (not (lambda-case-rest c))
193 (not (lambda-case-predicate c)))
194 (lp (lambda-case-else c)))))))))
195 (hashq-set! labels gensym #f))
198 ((<lexical-set> gensym exp)
199 (hashq-set! assigned gensym #t)
200 (hashq-set! labels gensym #f)
201 (lset-adjoin eq? (step exp) gensym))
206 ((<toplevel-set> exp)
209 ((<toplevel-define> exp)
213 (let lp ((exps exps) (ret '()))
214 (cond ((null? exps) '())
216 (lset-union eq? ret (step-tail (car exps))))
218 (lp (cdr exps) (lset-union eq? ret (step (car exps))))))))
221 ;; order is important here
222 (hashq-set! bound-vars x '())
223 (let ((free (recur body x)))
224 (hashq-set! bound-vars x (reverse! (hashq-ref bound-vars x)))
225 (hashq-set! free-vars x free)
228 ((<lambda-case> opt kw inits vars predicate body else)
229 (hashq-set! bound-vars proc
230 (append (reverse vars) (hashq-ref bound-vars proc)))
235 (apply lset-union eq? (map step inits))
236 (if predicate (step predicate) '())
239 (if else (step-tail else) '())))
241 ((<let> vars vals body)
242 (hashq-set! bound-vars proc
243 (append (reverse vars) (hashq-ref bound-vars proc)))
245 (apply lset-union eq? (step-tail body) (map step vals))
248 ((<letrec> vars vals body)
249 (hashq-set! bound-vars proc
250 (append (reverse vars) (hashq-ref bound-vars proc)))
251 (for-each (lambda (sym) (hashq-set! assigned sym #t)) vars)
253 (apply lset-union eq? (step-tail body) (map step vals))
256 ((<fix> vars vals body)
257 ;; Try to allocate these procedures as labels.
258 (for-each (lambda (sym val) (hashq-set! labels sym val))
260 (hashq-set! bound-vars proc
261 (append (reverse vars) (hashq-ref bound-vars proc)))
262 ;; Step into subexpressions.
265 ;; Since we're trying to label-allocate the lambda,
266 ;; pretend it's not a closure, and just recurse into its
267 ;; body directly. (Otherwise, recursing on a closure
268 ;; that references one of the fix's bound vars would
269 ;; prevent label allocation.)
273 ;; just like the closure case, except here we use
274 ;; recur/labels instead of recur
275 (hashq-set! bound-vars x '())
276 (let ((free (recur/labels body x vars)))
277 (hashq-set! bound-vars x (reverse! (hashq-ref bound-vars x)))
278 (hashq-set! free-vars x free)
281 (vars-with-refs (map cons vars var-refs))
282 (body-refs (recur/labels body proc vars)))
283 (define (delabel-dependents! sym)
284 (let ((refs (assq-ref vars-with-refs sym)))
286 (for-each (lambda (sym)
287 (if (hashq-ref labels sym)
289 (hashq-set! labels sym #f)
290 (delabel-dependents! sym))))
292 ;; Stepping into the lambdas and the body might have made some
293 ;; procedures not label-allocatable -- which might have
294 ;; knock-on effects. For example:
295 ;; (fix ((a (lambda () (b)))
296 ;; (b (lambda () a)))
298 ;; As far as `a' is concerned, both `a' and `b' are
299 ;; label-allocatable. But `b' references `a' not in a proc-tail
300 ;; position, which makes `a' not label-allocatable. The
301 ;; knock-on effect is that, when back-propagating this
302 ;; information to `a', `b' will also become not
303 ;; label-allocatable, as it is referenced within `a', which is
304 ;; allocated as a closure. This is a transitive relationship.
305 (for-each (lambda (sym)
306 (if (not (hashq-ref labels sym))
307 (delabel-dependents! sym)))
309 ;; Now lift bound variables with label-allocated lambdas to the
313 (if (hashq-ref labels sym)
314 ;; Remove traces of the label-bound lambda. The free
315 ;; vars will propagate up via the return val.
317 (hashq-set! bound-vars proc
318 (append (hashq-ref bound-vars val)
319 (hashq-ref bound-vars proc)))
320 (hashq-remove! bound-vars val)
321 (hashq-remove! free-vars val))))
324 (apply lset-union eq? body-refs var-refs)
327 ((<let-values> exp body)
328 (lset-union eq? (step exp) (step body)))
332 ;; allocation: sym -> {lambda -> address}
333 ;; lambda -> (nlocs labels . free-locs)
334 (define allocation (make-hash-table))
336 (define (allocate! x proc n)
337 (define (recur y) (allocate! y proc n))
339 ((<application> proc args)
340 (apply max (recur proc) (map recur args)))
342 ((<conditional> test then else)
343 (max (recur test) (recur then) (recur else)))
351 ((<toplevel-set> exp)
354 ((<toplevel-define> exp)
358 (apply max (map recur exps)))
361 ;; allocate closure vars in order
362 (let lp ((c (hashq-ref free-vars x)) (n 0))
365 (hashq-set! (hashq-ref allocation (car c))
367 `(#f ,(hashq-ref assigned (car c)) . ,n))
368 (lp (cdr c) (1+ n)))))
370 (let ((nlocs (allocate! body x 0))
373 (hashq-ref (hashq-ref allocation v) proc))
374 (hashq-ref free-vars x)))
377 (cons sym (hashq-ref labels sym)))
378 (hashq-ref bound-vars x)))))
379 ;; set procedure allocations
380 (hashq-set! allocation x (cons labels free-addresses)))
383 ((<lambda-case> opt kw inits vars predicate body else)
385 (let lp ((vars vars) (n n))
389 (if predicate (allocate! predicate body n) n)
390 (allocate! body proc n)
391 ;; inits not logically at the end, but they
393 (map (lambda (x) (allocate! x body 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 else (allocate! else 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-then body))
416 (eq? (lexical-ref-gensym (conditional-then 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-else 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) ...)
498 (down tree-analysis-down) ;; (lambda (x result env) ...)
499 (up tree-analysis-up) ;; (lambda (x result env) ...)
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."
506 (define (traverse proc)
508 (map (lambda (analysis result)
509 ((proc analysis) x result env))
514 (tree-il-fold (traverse tree-analysis-leaf)
515 (traverse tree-analysis-down)
516 (traverse tree-analysis-up)
517 (map tree-analysis-init analyses)
520 (for-each (lambda (analysis result)
521 ((tree-analysis-post analysis) result env))
529 ;;; Unused variable analysis.
532 ;; <binding-info> records are used during tree traversals in
533 ;; `report-unused-variables'. They contain a list of the local vars
534 ;; currently in scope, a list of locals vars that have been referenced, and a
535 ;; "location stack" (the stack of `tree-il-src' values for each parent tree).
536 (define-record-type <binding-info>
537 (make-binding-info vars refs locs)
539 (vars binding-info-vars) ;; ((GENSYM NAME LOCATION) ...)
540 (refs binding-info-refs) ;; (GENSYM ...)
541 (locs binding-info-locs)) ;; (LOCATION ...)
543 (define unused-variable-analysis
544 ;; Report unused variables in the given tree.
547 ;; X is a leaf: extend INFO's refs accordingly.
548 (let ((refs (binding-info-refs info))
549 (vars (binding-info-vars info))
550 (locs (binding-info-locs info)))
552 ((<lexical-ref> gensym)
553 (make-binding-info vars (cons gensym refs) locs))
557 ;; Going down into X: extend INFO's variable list
559 (let ((refs (binding-info-refs info))
560 (vars (binding-info-vars info))
561 (locs (binding-info-locs info))
562 (src (tree-il-src x)))
563 (define (extend inner-vars inner-names)
564 (append (map (lambda (var name)
570 ((<lexical-set> gensym)
571 (make-binding-info vars (cons gensym refs)
573 ((<lambda-case> req opt inits rest kw vars)
576 ,@(if rest (list rest) '())
577 ,@(if kw (map cadr (cdr kw)) '()))))
578 (make-binding-info (extend vars names) refs
581 (make-binding-info (extend vars names) refs
583 ((<letrec> vars names)
584 (make-binding-info (extend vars names) refs
587 (make-binding-info (extend vars names) refs
592 ;; Leaving X's scope: shrink INFO's variable list
593 ;; accordingly and reported unused nested variables.
594 (let ((refs (binding-info-refs info))
595 (vars (binding-info-vars info))
596 (locs (binding-info-locs info)))
597 (define (shrink inner-vars refs)
598 (for-each (lambda (var)
599 (let ((gensym (car var)))
600 ;; Don't report lambda parameters as
602 (if (and (not (memq gensym refs))
603 (not (and (lambda-case? x)
606 (let ((name (cadr var))
607 ;; We can get approximate
608 ;; source location by going up
609 ;; the LOCS location stack.
612 (warning 'unused-variable loc name)))))
613 (filter (lambda (var)
614 (memq (car var) inner-vars))
616 (fold alist-delete vars inner-vars))
618 ;; For simplicity, we leave REFS untouched, i.e., with
619 ;; names of variables that are now going out of scope.
620 ;; It doesn't hurt as these are unique names, it just
621 ;; makes REFS unnecessarily fat.
623 ((<lambda-case> vars)
624 (make-binding-info (shrink vars refs) refs
627 (make-binding-info (shrink vars refs) refs
630 (make-binding-info (shrink vars refs) refs
633 (make-binding-info (shrink vars refs) refs
637 (lambda (result env) #t)
638 (make-binding-info '() '() '())))
642 ;;; Unbound variable analysis.
645 ;; <toplevel-info> records are used during tree traversal in search of
646 ;; possibly unbound variable. They contain a list of references to
647 ;; potentially unbound top-level variables, a list of the top-level defines
648 ;; that have been encountered, and a "location stack" (see above).
649 (define-record-type <toplevel-info>
650 (make-toplevel-info refs defs locs)
652 (refs toplevel-info-refs) ;; ((VARIABLE-NAME . LOCATION) ...)
653 (defs toplevel-info-defs) ;; (VARIABLE-NAME ...)
654 (locs toplevel-info-locs)) ;; (LOCATION ...)
656 (define (goops-toplevel-definition proc args env)
657 ;; If application of PROC to ARGS is a GOOPS top-level definition, return
658 ;; the name of the variable being defined; otherwise return #f. This
659 ;; assumes knowledge of the current implementation of `define-class' et al.
660 (define (toplevel-define-arg args)
661 (and (pair? args) (pair? (cdr args)) (null? (cddr args))
662 (record-case (car args)
664 (and (symbol? exp) exp))
668 ((<module-ref> mod public? name)
669 (and (equal? mod '(oop goops))
671 (eq? name 'toplevel-define!)
672 (toplevel-define-arg args)))
673 ((<toplevel-ref> name)
674 ;; This may be the result of expanding one of the GOOPS macros within
676 (and (eq? name 'toplevel-define!)
677 (eq? env (resolve-module '(oop goops)))
678 (toplevel-define-arg args)))
681 (define unbound-variable-analysis
682 ;; Report possibly unbound variables in the given tree.
685 ;; X is a leaf: extend INFO's refs accordingly.
686 (let ((refs (toplevel-info-refs info))
687 (defs (toplevel-info-defs info))
688 (locs (toplevel-info-locs info)))
689 (define (bound? name)
690 (or (and (module? env)
691 (module-variable env name))
695 ((<toplevel-ref> name src)
698 (let ((src (or src (find pair? locs))))
699 (make-toplevel-info (alist-cons name src refs)
705 ;; Going down into X.
706 (let* ((refs (toplevel-info-refs info))
707 (defs (toplevel-info-defs info))
708 (src (tree-il-src x))
709 (locs (cons src (toplevel-info-locs info))))
710 (define (bound? name)
711 (or (and (module? env)
712 (module-variable env name))
716 ((<toplevel-set> name src)
718 (make-toplevel-info refs defs locs)
719 (let ((src (find pair? locs)))
720 (make-toplevel-info (alist-cons name src refs)
723 ((<toplevel-define> name)
724 (make-toplevel-info (alist-delete name refs eq?)
728 ((<application> proc args)
729 ;; Check for a dynamic top-level definition, as is
730 ;; done by code expanded from GOOPS macros.
731 (let ((name (goops-toplevel-definition proc args
734 (make-toplevel-info (alist-delete name refs
738 (make-toplevel-info refs defs locs))))
740 (make-toplevel-info refs defs locs)))))
743 ;; Leaving X's scope.
744 (let ((refs (toplevel-info-refs info))
745 (defs (toplevel-info-defs info))
746 (locs (toplevel-info-locs info)))
747 (make-toplevel-info refs defs (cdr locs))))
749 (lambda (toplevel env)
750 ;; Post-process the result.
751 (for-each (lambda (name+loc)
752 (let ((name (car name+loc))
753 (loc (cdr name+loc)))
754 (warning 'unbound-variable loc name)))
755 (reverse (toplevel-info-refs toplevel))))
757 (make-toplevel-info '() '() '())))
764 ;; <arity-info> records contain information about lexical definitions of
765 ;; procedures currently in scope, top-level procedure definitions that have
766 ;; been encountered, and calls to top-level procedures that have been
768 (define-record-type <arity-info>
769 (make-arity-info toplevel-calls lexical-lambdas toplevel-lambdas)
771 (toplevel-calls toplevel-procedure-calls) ;; ((NAME . APPLICATION) ...)
772 (lexical-lambdas lexical-lambdas) ;; ((GENSYM . DEFINITION) ...)
773 (toplevel-lambdas toplevel-lambdas)) ;; ((NAME . DEFINITION) ...)
775 (define (validate-arity proc application lexical?)
776 ;; Validate the argument count of APPLICATION, a tree-il application of
777 ;; PROC, emitting a warning in case of argument count mismatch.
779 (define (filter-keyword-args keywords allow-other-keys? args)
780 ;; Filter keyword arguments from ARGS and return the resulting list.
781 ;; KEYWORDS is the list of allowed keywords, and ALLOW-OTHER-KEYS?
782 ;; specified whethere keywords not listed in KEYWORDS are allowed.
783 (let loop ((args args)
787 (let ((arg (car args)))
788 (if (and (const? arg)
789 (or (memq (const-exp arg) keywords)
790 (and allow-other-keys?
791 (keyword? (const-exp arg)))))
792 (loop (if (pair? (cdr args))
797 (cons arg result)))))))
800 ;; Return the arity of PROC, which can be either a tree-il or a
803 (or (and (or (null? x) (pair? x))
806 (cond ((program? proc)
807 (let ((a (car (last-pair (program-arities proc)))))
808 (values (program-name proc)
809 (arity:nreq a) (arity:nopt a) (arity:rest? a)
810 (map car (arity:kw a)) (arity:allow-other-keys? a))))
812 (let ((arity (procedure-property proc 'arity)))
813 (values (procedure-name proc)
814 (car arity) (cadr arity) (caddr arity)
820 ((<lambda-case> req opt rest kw)
821 (values name (len req) (len opt) rest
822 (and (pair? kw) (map car (cdr kw)))
823 (and (pair? kw) (car kw))))
824 ((<lambda> meta body)
825 (loop (assoc-ref meta 'name) body))
827 (values #f #f #f #f #f #f)))))))
829 (let ((args (application-args application))
830 (src (tree-il-src application)))
831 (call-with-values (lambda () (arity proc))
832 (lambda (name req opt rest kw aok?)
833 (let ((args (if (pair? kw)
834 (filter-keyword-args kw aok? args)
837 (let ((count (length args)))
838 (if (or (< count req)
840 (> count (+ req opt))))
841 (warning 'arity-mismatch src
843 (with-output-to-string
850 (define arity-analysis
851 ;; Report arity mismatches in the given tree.
858 (define (extend lexical-name val info)
859 ;; If VAL is a lambda, add NAME to the lexical-lambdas of INFO.
860 (let ((toplevel-calls (toplevel-procedure-calls info))
861 (lexical-lambdas (lexical-lambdas info))
862 (toplevel-lambdas (toplevel-lambdas info)))
865 (make-arity-info toplevel-calls
866 (alist-cons lexical-name val
869 ((<lexical-ref> gensym)
871 (let ((val* (assq gensym lexical-lambdas)))
873 (extend lexical-name (cdr val*) info)
875 ((<toplevel-ref> name)
877 (make-arity-info toplevel-calls
878 (alist-cons lexical-name val
883 (let ((toplevel-calls (toplevel-procedure-calls info))
884 (lexical-lambdas (lexical-lambdas info))
885 (toplevel-lambdas (toplevel-lambdas info)))
888 ((<toplevel-define> name exp)
891 (make-arity-info toplevel-calls
893 (alist-cons name exp toplevel-lambdas)))
894 ((<toplevel-ref> name)
895 ;; alias for another toplevel
896 (let ((proc (assq name toplevel-lambdas)))
897 (make-arity-info toplevel-calls
899 (alist-cons (toplevel-define-name x)
906 (fold extend info vars vals))
907 ((<letrec> vars vals)
908 (fold extend info vars vals))
910 (fold extend info vars vals))
912 ((<application> proc args src)
915 (validate-arity proc x #t)
917 ((<toplevel-ref> name)
918 (make-arity-info (alist-cons name x toplevel-calls)
921 ((<lexical-ref> gensym)
922 (let ((proc (assq gensym lexical-lambdas)))
924 (record-case (cdr proc)
925 ((<toplevel-ref> name)
927 (make-arity-info (alist-cons name x toplevel-calls)
931 (validate-arity (cdr proc) x #t)
934 ;; If GENSYM wasn't found, it may be because it's an
935 ;; argument of the procedure being compiled.
942 (define (shrink name val info)
943 ;; Remove NAME from the lexical-lambdas of INFO.
944 (let ((toplevel-calls (toplevel-procedure-calls info))
945 (lexical-lambdas (lexical-lambdas info))
946 (toplevel-lambdas (toplevel-lambdas info)))
947 (make-arity-info toplevel-calls
948 (alist-delete name lexical-lambdas eq?)
951 (let ((toplevel-calls (toplevel-procedure-calls info))
952 (lexical-lambdas (lexical-lambdas info))
953 (toplevel-lambdas (toplevel-lambdas info)))
956 (fold shrink info vars vals))
957 ((<letrec> vars vals)
958 (fold shrink info vars vals))
960 (fold shrink info vars vals))
965 ;; Post-processing: check all top-level procedure calls that have been
967 (let ((toplevel-calls (toplevel-procedure-calls result))
968 (toplevel-lambdas (toplevel-lambdas result)))
969 (for-each (lambda (name+application)
970 (let* ((name (car name+application))
971 (application (cdr name+application))
973 (or (assoc-ref toplevel-lambdas name)
976 (module-ref env name)))))
978 ;; handle toplevel aliases
979 (if (toplevel-ref? proc)
980 (let ((name (toplevel-ref-name proc)))
983 (module-ref env name))))
985 ;; (format #t "toplevel-call to ~A (~A) from ~A~%"
986 ;; name proc* application)
987 (if (or (lambda? proc*) (procedure? proc*))
988 (validate-arity proc* application (lambda? proc*)))))
991 (make-arity-info '() '() '())))