1; Part of Scheme 48 1.9.  See file COPYING for notices and license.
2
3; Authors: Richard Kelsey, Jonathan Rees, Mike Sperber
4
5; Getting usage counts and doing a topological sort (so that definitions
6; will be seen before uses, where possible).
7;
8; We change the types of all unassigned top-level variables from
9; (VARIABLE <type>) to <type>.
10;
11; Steps:
12;  1. Make usage records for the variables bound by this package.
13;  2. Analyze each form to update the usage records and to find the referenced
14;     variables defined in this package.
15;  3. Update the types of the variables based on their usages.
16;  4. Do a topological sort of the forms using the referenced-variable sets
17;     from step 2.
18
19(define (find-usages forms package)
20  (let ((usages (make-name-table)))
21    (for-each (lambda (form)
22		(if (define-node? form)
23		    (let* ((lhs (cadr (node-form form)))
24			   (usage (make-package-usage lhs)))
25		      (table-set! usages (node-form lhs) usage)
26		      (node-set! lhs 'usage usage))))
27	      forms)
28    (for-each (lambda (form)
29		(node-set! form
30			   'free-variables
31			   (analyze form
32				    '()
33				    (lambda (node)
34				      (table-ref usages (node-form node))))))
35	      forms)
36    (for-each (lambda (form)
37		(if (define-node? form)
38		    (maybe-update-known-type form package)))
39	      forms)
40    (sort-forms forms)))
41
42(define (maybe-update-known-type node package)
43  (let* ((lhs (cadr (node-form node)))
44	 (usage (node-ref lhs 'usage)))
45    (if (= 0 (usage-assignment-count usage))
46	(let ((new-type (reconstruct-type (caddr (node-form node))
47					  (package->environment package))))
48	  (if (subtype? new-type any-values-type)
49	      (package-refine-type! package
50				    (node-form lhs)
51				    (if (subtype? new-type value-type)
52					new-type
53					value-type))
54	      (warning 'maybe-update-known-type
55		       "ill-typed right-hand side"
56		       (schemify node)
57		       (type->sexp new-type #t)))))))
58
59;----------------
60; Another entry point.
61; Here we want to return all package variables found, not just the ones from
62; this package.  We also don't update the actual usage records for package
63; variables, as they refer to the entire package, not just one form.
64
65(define (find-node-usages node)
66  (let* ((usages (make-name-table))
67	 (referenced (analyze node
68			      '()
69			      (lambda (node)
70				(let ((usage (node-ref node 'usage)))
71				  (if (and usage
72					   (not (package-usage? usage)))
73				      #f
74				      (let ((name (node-form node)))
75					(or (table-ref usages name)
76					    (let ((usage (make-package-usage node)))
77					      (table-set! usages name usage)
78					      usage)))))))))
79    (map (lambda (usage)
80	   (node-form (usage-name-node usage)))
81	 referenced)))
82
83;----------------
84; The usual node walk.  FREE is a list of usage records for package variables
85; that have been seen so far.  USAGES is a function that maps names to usages.
86
87(define (analyze node free usages)
88  ((operator-table-ref usage-analyzers (node-operator-id node))
89     node
90     free
91     usages))
92
93(define (analyze-nodes nodes free usages)
94  (reduce (lambda (node free)
95	    (analyze node free usages))
96	  free
97	  nodes))
98
99(define usage-analyzers
100  (make-operator-table (lambda (node free usages)
101			 (analyze-nodes (node-form node) free usages))))
102
103(define (define-usage-analyzer name type proc)
104  (operator-define! usage-analyzers name type proc))
105
106(define (nothing node free usages) free)
107
108(define-usage-analyzer 'literal    #f nothing)
109(define-usage-analyzer 'unspecific #f nothing)
110(define-usage-analyzer 'unassigned #f nothing)
111(define-usage-analyzer 'quote               syntax-type nothing)
112(define-usage-analyzer 'primitive-procedure syntax-type nothing)
113
114(define-usage-analyzer 'name #f
115  (lambda (node free usages)
116    (note-reference! node usages)
117    (add-if-free node free usages)))
118
119; If NODE has a usage record, then add it to FREE if it (the usage record) isn't
120; already there.
121
122(define (add-if-free node free usages)
123  (let ((usage (usages node)))
124    (if (and usage
125	     (not (memq usage free)))
126	(cons usage free)
127	free)))
128
129(define-usage-analyzer 'call #f
130  (lambda (node free usages)
131    (let* ((exp (node-form node))
132	   (proc (car exp)))
133      (if (name-node? proc)
134	  (note-operator! proc usages))
135      (analyze-nodes exp free usages))))
136
137(define-usage-analyzer 'lambda syntax-type
138  (lambda (node free usages)
139    (let* ((exp (node-form node))
140	   (formals (cadr exp)))
141      (for-each (lambda (node)
142		  (node-set! node 'usage (make-usage)))
143		(normalize-formals formals))
144      (analyze (caddr exp) free usages))))
145
146(define-usage-analyzer 'letrec syntax-type
147  (lambda (node free usages)
148    (let ((exp (node-form node)))
149      (analyze-letrec (cadr exp) (caddr exp) free usages))))
150
151(define-usage-analyzer 'letrec* syntax-type
152  (lambda (node free usages)
153    (let ((exp (node-form node)))
154      (analyze-letrec (cadr exp) (caddr exp) free usages))))
155
156(define-usage-analyzer 'pure-letrec syntax-type
157  (lambda (node free usages)
158    (let ((exp (node-form node)))
159      (analyze-letrec (cadr exp) (cadddr exp) free usages))))
160
161(define (analyze-letrec specs body free usages)
162  (for-each (lambda (spec)
163	      (node-set! (car spec) 'usage (make-usage)))
164	    specs)
165  (analyze body
166	   (analyze-nodes (map cadr specs)
167			  free
168			  usages)
169	   usages))
170
171(define-usage-analyzer 'begin syntax-type
172  (lambda (node free usages)
173    (analyze-nodes (cdr (node-form node)) free usages)))
174
175(define-usage-analyzer 'set! syntax-type
176  (lambda (node free usages)
177    (let ((exp (node-form node)))
178      (let ((lhs (cadr exp))
179	    (rhs (caddr exp)))
180	(note-assignment! lhs usages)
181	(analyze rhs (add-if-free lhs free usages) usages)))))
182
183(define-usage-analyzer 'define syntax-type
184  (lambda (node free usages)
185    (analyze (caddr (node-form node))
186	     free
187	     usages)))
188
189(define-usage-analyzer 'if syntax-type
190  (lambda (node free usages)
191    (analyze-nodes (cdr (node-form node)) free usages)))
192
193(define-usage-analyzer 'lap syntax-type
194  (lambda (node free usages)
195    (analyze-nodes (caddr (node-form node))
196		   free
197		   usages)))
198
199(define-usage-analyzer 'loophole syntax-type
200  (lambda (node free usages)
201    (analyze (caddr (node-form node))
202	     free
203	     usages)))
204
205;--------------------
206; Usage records record the number of times that a variable is referenced, set!,
207; and called.
208
209(define-record-type usage :usage
210  (really-make-usage name-node reference operator assignment)
211  usage?
212  (name-node usage-name-node)  ; only for package variables
213  (reference usage-reference-count set-reference!)
214  (operator usage-operator-count set-operator!)
215  (assignment usage-assignment-count set-assignment!))
216
217(define (make-usage)
218  (really-make-usage #f 0 0 0))
219
220(define (make-package-usage name-node)
221  (really-make-usage name-node 0 0 0))
222
223(define (package-usage? usage)
224  (usage-name-node usage))
225
226(define (usage-incrementator ref set)
227  (lambda (node usages)
228    (let ((v (or (node-ref node 'usage)
229		 (usages node))))
230      (if v
231	  (set v (+ (ref v) 1))))))
232
233(define note-reference! (usage-incrementator usage-reference-count set-reference!))
234(define note-operator! (usage-incrementator usage-operator-count set-operator!))
235(define note-assignment! (usage-incrementator usage-assignment-count set-assignment!))
236