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 #:use-module (system base pmatch)
29 #:export (analyze-lexicals
31 unused-variable-analysis
32 unbound-variable-analysis
35 ;; Allocation is the process of assigning storage locations for lexical
36 ;; variables. A lexical variable has a distinct "address", or storage
37 ;; location, for each procedure in which it is referenced.
39 ;; A variable is "local", i.e., allocated on the stack, if it is
40 ;; referenced from within the procedure that defined it. Otherwise it is
41 ;; a "closure" variable. For example:
43 ;; (lambda (a) a) ; a will be local
44 ;; `a' is local to the procedure.
46 ;; (lambda (a) (lambda () a))
47 ;; `a' is local to the outer procedure, but a closure variable with
48 ;; respect to the inner procedure.
50 ;; If a variable is ever assigned, it needs to be heap-allocated
51 ;; ("boxed"). This is so that closures and continuations capture the
52 ;; variable's identity, not just one of the values it may have over the
53 ;; course of program execution. If the variable is never assigned, there
54 ;; is no distinction between value and identity, so closing over its
55 ;; identity (whether through closures or continuations) can make a copy
56 ;; of its value instead.
58 ;; Local variables are stored on the stack within a procedure's call
59 ;; frame. Their index into the stack is determined from their linear
60 ;; postion within a procedure's binding path:
67 ;; This algorithm has the problem that variables are only allocated
68 ;; indices at the end of the binding path. If variables bound early in
69 ;; the path are not used in later portions of the path, their indices
70 ;; will not be recycled. This problem is particularly egregious in the
74 ;; -> (let ((a x)) (if a a (let ((b y)) (if b b z))))
76 ;; As you can see, the `a' binding is only used in the ephemeral `then'
77 ;; clause of the first `if', but its index would be reserved for the
78 ;; whole of the `or' expansion. So we have a hack for this specific
79 ;; case. A proper solution would be some sort of liveness analysis, and
80 ;; not our linear allocation algorithm.
82 ;; Closure variables are captured when a closure is created, and stored
83 ;; in a vector. Each closure variable has a unique index into that
86 ;; There is one more complication. Procedures bound by <fix> may, in
87 ;; some cases, be rendered inline to their parent procedure. That is to
90 ;; (letrec ((lp (lambda () (lp)))) (lp))
91 ;; => (fix ((lp (lambda () (lp)))) (lp))
92 ;; => goto FIX-BODY; LP: goto LP; FIX-BODY: goto LP;
93 ;; ^ jump over the loop ^ the fixpoint lp ^ starting off the loop
95 ;; The upshot is that we don't have to allocate any space for the `lp'
96 ;; closure at all, as it can be rendered inline as a loop. So there is
97 ;; another kind of allocation, "label allocation", in which the
98 ;; procedure is simply a label, placed at the start of the lambda body.
99 ;; The label is the gensym under which the lambda expression is bound.
101 ;; The analyzer checks to see that the label is called with the correct
102 ;; number of arguments. Calls to labels compile to rename + goto.
103 ;; Lambda, the ultimate goto!
106 ;; The return value of `analyze-lexicals' is a hash table, the
109 ;; The allocation maps gensyms -- recall that each lexically bound
110 ;; variable has a unique gensym -- to storage locations ("addresses").
111 ;; Since one gensym may have many storage locations, if it is referenced
112 ;; in many procedures, it is a two-level map.
114 ;; The allocation also stored information on how many local variables
115 ;; need to be allocated for each procedure, lexicals that have been
116 ;; translated into labels, and information on what free variables to
117 ;; capture from its lexical parent procedure.
119 ;; In addition, we have a conflation: while we're traversing the code,
120 ;; recording information to pass to the compiler, we take the
121 ;; opportunity to generate labels for each lambda-case clause, so that
122 ;; generated code can skip argument checks at runtime if they match at
127 ;; sym -> {lambda -> address}
128 ;; lambda -> (labels . free-locs)
129 ;; lambda-case -> (gensym . nlocs)
131 ;; address ::= (local? boxed? . index)
132 ;; labels ::= ((sym . lambda) ...)
133 ;; free-locs ::= ((sym0 . address0) (sym1 . address1) ...)
134 ;; free variable addresses are relative to parent proc.
136 (define (make-hashq k v)
137 (let ((res (make-hash-table)))
141 (define (analyze-lexicals x)
142 ;; bound-vars: lambda -> (sym ...)
143 ;; all identifiers bound within a lambda
144 (define bound-vars (make-hash-table))
145 ;; free-vars: lambda -> (sym ...)
146 ;; all identifiers referenced in a lambda, but not bound
147 ;; NB, this includes identifiers referenced by contained lambdas
148 (define free-vars (make-hash-table))
149 ;; assigned: sym -> #t
150 ;; variables that are assigned
151 (define assigned (make-hash-table))
152 ;; refcounts: sym -> count
153 ;; allows us to detect the or-expansion in O(1) time
154 (define refcounts (make-hash-table))
155 ;; labels: sym -> lambda
156 ;; for determining if fixed-point procedures can be rendered as
158 (define labels (make-hash-table))
160 ;; returns variables referenced in expr
161 (define (analyze! x proc labels-in-proc tail? tail-call-args)
162 (define (step y) (analyze! y proc labels-in-proc #f #f))
163 (define (step-tail y) (analyze! y proc labels-in-proc tail? #f))
164 (define (step-tail-call y args) (analyze! y proc labels-in-proc #f
166 (define (recur/labels x new-proc labels)
167 (analyze! x new-proc (append labels labels-in-proc) #t #f))
168 (define (recur x new-proc) (analyze! x new-proc '() tail? #f))
170 ((<application> proc args)
171 (apply lset-union eq? (step-tail-call proc args)
174 ((<conditional> test then else)
175 (lset-union eq? (step test) (step-tail then) (step-tail else)))
177 ((<lexical-ref> gensym)
178 (hashq-set! refcounts gensym (1+ (hashq-ref refcounts gensym 0)))
179 (if (not (and tail-call-args
180 (memq gensym labels-in-proc)
181 (let ((p (hashq-ref labels gensym)))
183 (let lp ((c (lambda-body p)))
184 (and c (lambda-case? c)
186 ;; for now prohibit optional &
187 ;; keyword arguments; can relax this
189 (and (= (length (lambda-case-req c))
190 (length tail-call-args))
191 (not (lambda-case-opt c))
192 (not (lambda-case-kw c))
193 (not (lambda-case-rest 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 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))
238 (if else (step-tail else) '())))
240 ((<let> vars vals body)
241 (hashq-set! bound-vars proc
242 (append (reverse vars) (hashq-ref bound-vars proc)))
244 (apply lset-union eq? (step-tail body) (map step vals))
247 ((<letrec> vars vals body)
248 (hashq-set! bound-vars proc
249 (append (reverse vars) (hashq-ref bound-vars proc)))
250 (for-each (lambda (sym) (hashq-set! assigned sym #t)) vars)
252 (apply lset-union eq? (step-tail body) (map step vals))
255 ((<fix> vars vals body)
256 ;; Try to allocate these procedures as labels.
257 (for-each (lambda (sym val) (hashq-set! labels sym val))
259 (hashq-set! bound-vars proc
260 (append (reverse vars) (hashq-ref bound-vars proc)))
261 ;; Step into subexpressions.
264 ;; Since we're trying to label-allocate the lambda,
265 ;; pretend it's not a closure, and just recurse into its
266 ;; body directly. (Otherwise, recursing on a closure
267 ;; that references one of the fix's bound vars would
268 ;; prevent label allocation.)
272 ;; just like the closure case, except here we use
273 ;; recur/labels instead of recur
274 (hashq-set! bound-vars x '())
275 (let ((free (recur/labels body x vars)))
276 (hashq-set! bound-vars x (reverse! (hashq-ref bound-vars x)))
277 (hashq-set! free-vars x free)
280 (vars-with-refs (map cons vars var-refs))
281 (body-refs (recur/labels body proc vars)))
282 (define (delabel-dependents! sym)
283 (let ((refs (assq-ref vars-with-refs sym)))
285 (for-each (lambda (sym)
286 (if (hashq-ref labels sym)
288 (hashq-set! labels sym #f)
289 (delabel-dependents! sym))))
291 ;; Stepping into the lambdas and the body might have made some
292 ;; procedures not label-allocatable -- which might have
293 ;; knock-on effects. For example:
294 ;; (fix ((a (lambda () (b)))
295 ;; (b (lambda () a)))
297 ;; As far as `a' is concerned, both `a' and `b' are
298 ;; label-allocatable. But `b' references `a' not in a proc-tail
299 ;; position, which makes `a' not label-allocatable. The
300 ;; knock-on effect is that, when back-propagating this
301 ;; information to `a', `b' will also become not
302 ;; label-allocatable, as it is referenced within `a', which is
303 ;; allocated as a closure. This is a transitive relationship.
304 (for-each (lambda (sym)
305 (if (not (hashq-ref labels sym))
306 (delabel-dependents! sym)))
308 ;; Now lift bound variables with label-allocated lambdas to the
312 (if (hashq-ref labels sym)
313 ;; Remove traces of the label-bound lambda. The free
314 ;; vars will propagate up via the return val.
316 (hashq-set! bound-vars proc
317 (append (hashq-ref bound-vars val)
318 (hashq-ref bound-vars proc)))
319 (hashq-remove! bound-vars val)
320 (hashq-remove! free-vars val))))
323 (apply lset-union eq? body-refs var-refs)
326 ((<let-values> exp body)
327 (lset-union eq? (step exp) (step body)))
331 ;; allocation: sym -> {lambda -> address}
332 ;; lambda -> (nlocs labels . free-locs)
333 (define allocation (make-hash-table))
335 (define (allocate! x proc n)
336 (define (recur y) (allocate! y proc n))
338 ((<application> proc args)
339 (apply max (recur proc) (map recur args)))
341 ((<conditional> test then else)
342 (max (recur test) (recur then) (recur else)))
350 ((<toplevel-set> exp)
353 ((<toplevel-define> exp)
357 (apply max (map recur exps)))
360 ;; allocate closure vars in order
361 (let lp ((c (hashq-ref free-vars x)) (n 0))
364 (hashq-set! (hashq-ref allocation (car c))
366 `(#f ,(hashq-ref assigned (car c)) . ,n))
367 (lp (cdr c) (1+ n)))))
369 (let ((nlocs (allocate! body x 0))
372 (hashq-ref (hashq-ref allocation v) proc))
373 (hashq-ref free-vars x)))
376 (cons sym (hashq-ref labels sym)))
377 (hashq-ref bound-vars x)))))
378 ;; set procedure allocations
379 (hashq-set! allocation x (cons labels free-addresses)))
382 ((<lambda-case> opt kw inits vars body else)
384 (let lp ((vars vars) (n n))
388 (allocate! body proc n)
389 ;; inits not logically at the end, but they
391 (map (lambda (x) (allocate! x body n)) inits))))
392 ;; label and nlocs for the case
393 (hashq-set! allocation x (cons (gensym ":LCASE") nlocs))
396 (hashq-set! allocation (car vars)
398 proc `(#t ,(hashq-ref assigned (car vars)) . ,n)))
399 (lp (cdr vars) (1+ n)))))
400 (if else (allocate! else proc n) n)))
402 ((<let> vars vals body)
403 (let ((nmax (apply max (map recur vals))))
406 ((and (conditional? body)
408 (let ((v (car vars)))
409 (and (not (hashq-ref assigned v))
410 (= (hashq-ref refcounts v 0) 2)
411 (lexical-ref? (conditional-test body))
412 (eq? (lexical-ref-gensym (conditional-test body)) v)
413 (lexical-ref? (conditional-then body))
414 (eq? (lexical-ref-gensym (conditional-then body)) v))))
415 (hashq-set! allocation (car vars)
416 (make-hashq proc `(#t #f . ,n)))
417 ;; the 1+ for this var
418 (max nmax (1+ n) (allocate! (conditional-else body) proc n)))
420 (let lp ((vars vars) (n n))
422 (max nmax (allocate! body proc n))
423 (let ((v (car vars)))
427 `(#t ,(hashq-ref assigned v) . ,n)))
428 (lp (cdr vars) (1+ n)))))))))
430 ((<letrec> vars vals body)
431 (let lp ((vars vars) (n n))
433 (let ((nmax (apply max
435 (allocate! x proc n))
437 (max nmax (allocate! body proc n)))
438 (let ((v (car vars)))
442 `(#t ,(hashq-ref assigned v) . ,n)))
443 (lp (cdr vars) (1+ n))))))
445 ((<fix> vars vals body)
446 (let lp ((in vars) (n n))
448 (let lp ((vars vars) (vals vals) (nmax n))
451 (max nmax (allocate! body proc n)))
452 ((hashq-ref labels (car vars))
453 ;; allocate lambda body inline to proc
456 (record-case (car vals)
458 (max nmax (allocate! body proc n))))))
463 (max nmax (allocate! (car vals) proc n))))))
467 ((hashq-ref assigned v)
468 (error "fixpoint procedures may not be assigned" x))
469 ((hashq-ref labels v)
470 ;; no binding, it's a label
473 ;; allocate closure binding
474 (hashq-set! allocation v (make-hashq proc `(#t #f . ,n)))
475 (lp (cdr in) (1+ n))))))))
477 ((<let-values> exp body)
478 (max (recur exp) (recur body)))
482 (analyze! x #f '() #t #f)
489 ;;; Tree analyses for warnings.
492 (define-record-type <tree-analysis>
493 (make-tree-analysis leaf down up post init)
495 (leaf tree-analysis-leaf) ;; (lambda (x result env) ...)
496 (down tree-analysis-down) ;; (lambda (x result env) ...)
497 (up tree-analysis-up) ;; (lambda (x result env) ...)
498 (post tree-analysis-post) ;; (lambda (result env) ...)
499 (init tree-analysis-init)) ;; arbitrary value
501 (define (analyze-tree analyses tree env)
502 "Run all tree analyses listed in ANALYSES on TREE for ENV, using
503 `tree-il-fold'. Return TREE."
504 (define (traverse proc)
506 (map (lambda (analysis result)
507 ((proc analysis) x result env))
512 (tree-il-fold (traverse tree-analysis-leaf)
513 (traverse tree-analysis-down)
514 (traverse tree-analysis-up)
515 (map tree-analysis-init analyses)
518 (for-each (lambda (analysis result)
519 ((tree-analysis-post analysis) result env))
527 ;;; Unused variable analysis.
530 ;; <binding-info> records are used during tree traversals in
531 ;; `report-unused-variables'. They contain a list of the local vars
532 ;; currently in scope, a list of locals vars that have been referenced, and a
533 ;; "location stack" (the stack of `tree-il-src' values for each parent tree).
534 (define-record-type <binding-info>
535 (make-binding-info vars refs locs)
537 (vars binding-info-vars) ;; ((GENSYM NAME LOCATION) ...)
538 (refs binding-info-refs) ;; (GENSYM ...)
539 (locs binding-info-locs)) ;; (LOCATION ...)
541 (define unused-variable-analysis
542 ;; Report unused variables in the given tree.
545 ;; X is a leaf: extend INFO's refs accordingly.
546 (let ((refs (binding-info-refs info))
547 (vars (binding-info-vars info))
548 (locs (binding-info-locs info)))
550 ((<lexical-ref> gensym)
551 (make-binding-info vars (cons gensym refs) locs))
555 ;; Going down into X: extend INFO's variable list
557 (let ((refs (binding-info-refs info))
558 (vars (binding-info-vars info))
559 (locs (binding-info-locs info))
560 (src (tree-il-src x)))
561 (define (extend inner-vars inner-names)
562 (append (map (lambda (var name)
568 ((<lexical-set> gensym)
569 (make-binding-info vars (cons gensym refs)
571 ((<lambda-case> req opt inits rest kw vars)
574 ,@(if rest (list rest) '())
575 ,@(if kw (map cadr (cdr kw)) '()))))
576 (make-binding-info (extend vars names) refs
579 (make-binding-info (extend vars names) refs
581 ((<letrec> vars names)
582 (make-binding-info (extend vars names) refs
585 (make-binding-info (extend vars names) refs
590 ;; Leaving X's scope: shrink INFO's variable list
591 ;; accordingly and reported unused nested variables.
592 (let ((refs (binding-info-refs info))
593 (vars (binding-info-vars info))
594 (locs (binding-info-locs info)))
595 (define (shrink inner-vars refs)
596 (for-each (lambda (var)
597 (let ((gensym (car var)))
598 ;; Don't report lambda parameters as
600 (if (and (not (memq gensym refs))
601 (not (and (lambda-case? x)
604 (let ((name (cadr var))
605 ;; We can get approximate
606 ;; source location by going up
607 ;; the LOCS location stack.
610 (warning 'unused-variable loc name)))))
611 (filter (lambda (var)
612 (memq (car var) inner-vars))
614 (fold alist-delete vars inner-vars))
616 ;; For simplicity, we leave REFS untouched, i.e., with
617 ;; names of variables that are now going out of scope.
618 ;; It doesn't hurt as these are unique names, it just
619 ;; makes REFS unnecessarily fat.
621 ((<lambda-case> vars)
622 (make-binding-info (shrink vars refs) refs
625 (make-binding-info (shrink vars refs) refs
628 (make-binding-info (shrink vars refs) refs
631 (make-binding-info (shrink vars refs) refs
635 (lambda (result env) #t)
636 (make-binding-info '() '() '())))
640 ;;; Unbound variable analysis.
643 ;; <toplevel-info> records are used during tree traversal in search of
644 ;; possibly unbound variable. They contain a list of references to
645 ;; potentially unbound top-level variables, a list of the top-level defines
646 ;; that have been encountered, and a "location stack" (see above).
647 (define-record-type <toplevel-info>
648 (make-toplevel-info refs defs locs)
650 (refs toplevel-info-refs) ;; ((VARIABLE-NAME . LOCATION) ...)
651 (defs toplevel-info-defs) ;; (VARIABLE-NAME ...)
652 (locs toplevel-info-locs)) ;; (LOCATION ...)
654 (define (goops-toplevel-definition proc args env)
655 ;; If application of PROC to ARGS is a GOOPS top-level definition, return
656 ;; the name of the variable being defined; otherwise return #f. This
657 ;; assumes knowledge of the current implementation of `define-class' et al.
658 (define (toplevel-define-arg args)
659 (and (pair? args) (pair? (cdr args)) (null? (cddr args))
660 (record-case (car args)
662 (and (symbol? exp) exp))
666 ((<module-ref> mod public? name)
667 (and (equal? mod '(oop goops))
669 (eq? name 'toplevel-define!)
670 (toplevel-define-arg args)))
671 ((<toplevel-ref> name)
672 ;; This may be the result of expanding one of the GOOPS macros within
674 (and (eq? name 'toplevel-define!)
675 (eq? env (resolve-module '(oop goops)))
676 (toplevel-define-arg args)))
679 (define unbound-variable-analysis
680 ;; Report possibly unbound variables in the given tree.
683 ;; X is a leaf: extend INFO's refs accordingly.
684 (let ((refs (toplevel-info-refs info))
685 (defs (toplevel-info-defs info))
686 (locs (toplevel-info-locs info)))
687 (define (bound? name)
688 (or (and (module? env)
689 (module-variable env name))
693 ((<toplevel-ref> name src)
696 (let ((src (or src (find pair? locs))))
697 (make-toplevel-info (alist-cons name src refs)
703 ;; Going down into X.
704 (let* ((refs (toplevel-info-refs info))
705 (defs (toplevel-info-defs info))
706 (src (tree-il-src x))
707 (locs (cons src (toplevel-info-locs info))))
708 (define (bound? name)
709 (or (and (module? env)
710 (module-variable env name))
714 ((<toplevel-set> name src)
716 (make-toplevel-info refs defs locs)
717 (let ((src (find pair? locs)))
718 (make-toplevel-info (alist-cons name src refs)
721 ((<toplevel-define> name)
722 (make-toplevel-info (alist-delete name refs eq?)
726 ((<application> proc args)
727 ;; Check for a dynamic top-level definition, as is
728 ;; done by code expanded from GOOPS macros.
729 (let ((name (goops-toplevel-definition proc args
732 (make-toplevel-info (alist-delete name refs
736 (make-toplevel-info refs defs locs))))
738 (make-toplevel-info refs defs locs)))))
741 ;; Leaving X's scope.
742 (let ((refs (toplevel-info-refs info))
743 (defs (toplevel-info-defs info))
744 (locs (toplevel-info-locs info)))
745 (make-toplevel-info refs defs (cdr locs))))
747 (lambda (toplevel env)
748 ;; Post-process the result.
749 (for-each (lambda (name+loc)
750 (let ((name (car name+loc))
751 (loc (cdr name+loc)))
752 (warning 'unbound-variable loc name)))
753 (reverse (toplevel-info-refs toplevel))))
755 (make-toplevel-info '() '() '())))
762 ;; <arity-info> records contain information about lexical definitions of
763 ;; procedures currently in scope, top-level procedure definitions that have
764 ;; been encountered, and calls to top-level procedures that have been
766 (define-record-type <arity-info>
767 (make-arity-info toplevel-calls lexical-lambdas toplevel-lambdas)
769 (toplevel-calls toplevel-procedure-calls) ;; ((NAME . APPLICATION) ...)
770 (lexical-lambdas lexical-lambdas) ;; ((GENSYM . DEFINITION) ...)
771 (toplevel-lambdas toplevel-lambdas)) ;; ((NAME . DEFINITION) ...)
773 (define (validate-arity proc application lexical?)
774 ;; Validate the argument count of APPLICATION, a tree-il application of
775 ;; PROC, emitting a warning in case of argument count mismatch.
777 (define (filter-keyword-args keywords allow-other-keys? args)
778 ;; Filter keyword arguments from ARGS and return the resulting list.
779 ;; KEYWORDS is the list of allowed keywords, and ALLOW-OTHER-KEYS?
780 ;; specified whethere keywords not listed in KEYWORDS are allowed.
781 (let loop ((args args)
785 (let ((arg (car args)))
786 (if (and (const? arg)
787 (or (memq (const-exp arg) keywords)
788 (and allow-other-keys?
789 (keyword? (const-exp arg)))))
790 (loop (if (pair? (cdr args))
795 (cons arg result)))))))
797 (define (arities proc)
798 ;; Return the arities of PROC, which can be either a tree-il or a
801 (or (and (or (null? x) (pair? x))
804 (cond ((program? proc)
805 (values (program-name proc)
807 (list (arity:nreq a) (arity:nopt a) (arity:rest? a)
808 (map car (arity:kw a))
809 (arity:allow-other-keys? a)))
810 (program-arities proc))))
812 (let ((arity (procedure-property proc 'arity)))
813 (values (procedure-name proc)
814 (list (list (car arity) (cadr arity) (caddr arity)
821 (values name (reverse arities))
823 ((<lambda-case> req opt rest kw else)
825 (cons (list (len req) (len opt) rest
826 (and (pair? kw) (map car (cdr kw)))
827 (and (pair? kw) (car kw)))
829 ((<lambda> meta body)
830 (loop (assoc-ref meta 'name) body arities))
832 (values #f #f))))))))
834 (let ((args (application-args application))
835 (src (tree-il-src application)))
836 (call-with-values (lambda () (arities proc))
837 (lambda (name arities)
839 (find (lambda (arity)
841 ((,req ,opt ,rest? ,kw ,aok?)
842 (let ((args (if (pair? kw)
843 (filter-keyword-args kw aok? args)
846 (let ((count (length args)))
849 (<= count (+ req opt)))))
855 (warning 'arity-mismatch src
856 (or name (with-output-to-string (lambda () (write proc))))
860 (define arity-analysis
861 ;; Report arity mismatches in the given tree.
868 (define (extend lexical-name val info)
869 ;; If VAL is a lambda, add NAME to the lexical-lambdas of INFO.
870 (let ((toplevel-calls (toplevel-procedure-calls info))
871 (lexical-lambdas (lexical-lambdas info))
872 (toplevel-lambdas (toplevel-lambdas info)))
875 (make-arity-info toplevel-calls
876 (alist-cons lexical-name val
879 ((<lexical-ref> gensym)
881 (let ((val* (assq gensym lexical-lambdas)))
883 (extend lexical-name (cdr val*) info)
885 ((<toplevel-ref> name)
887 (make-arity-info toplevel-calls
888 (alist-cons lexical-name val
893 (let ((toplevel-calls (toplevel-procedure-calls info))
894 (lexical-lambdas (lexical-lambdas info))
895 (toplevel-lambdas (toplevel-lambdas info)))
898 ((<toplevel-define> name exp)
901 (make-arity-info toplevel-calls
903 (alist-cons name exp toplevel-lambdas)))
904 ((<toplevel-ref> name)
905 ;; alias for another toplevel
906 (let ((proc (assq name toplevel-lambdas)))
907 (make-arity-info toplevel-calls
909 (alist-cons (toplevel-define-name x)
916 (fold extend info vars vals))
917 ((<letrec> vars vals)
918 (fold extend info vars vals))
920 (fold extend info vars vals))
922 ((<application> proc args src)
925 (validate-arity proc x #t)
927 ((<toplevel-ref> name)
928 (make-arity-info (alist-cons name x toplevel-calls)
931 ((<lexical-ref> gensym)
932 (let ((proc (assq gensym lexical-lambdas)))
934 (record-case (cdr proc)
935 ((<toplevel-ref> name)
937 (make-arity-info (alist-cons name x toplevel-calls)
941 (validate-arity (cdr proc) x #t)
944 ;; If GENSYM wasn't found, it may be because it's an
945 ;; argument of the procedure being compiled.
952 (define (shrink name val info)
953 ;; Remove NAME from the lexical-lambdas of INFO.
954 (let ((toplevel-calls (toplevel-procedure-calls info))
955 (lexical-lambdas (lexical-lambdas info))
956 (toplevel-lambdas (toplevel-lambdas info)))
957 (make-arity-info toplevel-calls
958 (alist-delete name lexical-lambdas eq?)
961 (let ((toplevel-calls (toplevel-procedure-calls info))
962 (lexical-lambdas (lexical-lambdas info))
963 (toplevel-lambdas (toplevel-lambdas info)))
966 (fold shrink info vars vals))
967 ((<letrec> vars vals)
968 (fold shrink info vars vals))
970 (fold shrink info vars vals))
975 ;; Post-processing: check all top-level procedure calls that have been
977 (let ((toplevel-calls (toplevel-procedure-calls result))
978 (toplevel-lambdas (toplevel-lambdas result)))
979 (for-each (lambda (name+application)
980 (let* ((name (car name+application))
981 (application (cdr name+application))
983 (or (assoc-ref toplevel-lambdas name)
986 (module-ref env name)))))
988 ;; handle toplevel aliases
989 (if (toplevel-ref? proc)
990 (let ((name (toplevel-ref-name proc)))
993 (module-ref env name))))
995 ;; (format #t "toplevel-call to ~A (~A) from ~A~%"
996 ;; name proc* application)
997 (if (or (lambda? proc*) (procedure? proc*))
998 (validate-arity proc* application (lambda? proc*)))))
1001 (make-arity-info '() '() '())))