Commit | Line | Data |
---|---|---|
8bc65d2d | 1 | ;;; Type analysis on CPS |
e2fafeb9 | 2 | ;;; Copyright (C) 2014, 2015 Free Software Foundation, Inc. |
8bc65d2d AW |
3 | ;;; |
4 | ;;; This library is free software: you can redistribute it and/or modify | |
5 | ;;; it under the terms of the GNU Lesser General Public License as | |
6 | ;;; published by the Free Software Foundation, either version 3 of the | |
7 | ;;; License, or (at your option) any later version. | |
8 | ;;; | |
9 | ;;; This library is distributed in the hope that it will be useful, but | |
10 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of | |
11 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU | |
12 | ;;; Lesser General Public License for more details. | |
13 | ;;; | |
14 | ;;; You should have received a copy of the GNU Lesser General Public | |
15 | ;;; License along with this program. If not, see | |
16 | ;;; <http://www.gnu.org/licenses/>. | |
17 | ||
18 | ;;; Commentary: | |
19 | ;;; | |
20 | ;;; Type analysis computes the possible types and ranges that values may | |
21 | ;;; have at all program positions. This analysis can help to prove that | |
22 | ;;; a primcall has no side-effects, if its arguments have the | |
23 | ;;; appropriate type and range. It can also enable constant folding of | |
24 | ;;; type predicates and, in the future, enable the compiler to choose | |
25 | ;;; untagged, unboxed representations for numbers. | |
26 | ;;; | |
27 | ;;; For the purposes of this analysis, a "type" is an aspect of a value | |
28 | ;;; that will not change. Guile's CPS intermediate language does not | |
29 | ;;; carry manifest type information that asserts properties about given | |
30 | ;;; values; instead, we recover this information via flow analysis, | |
31 | ;;; garnering properties from type predicates, constant literals, | |
32 | ;;; primcall results, and primcalls that assert that their arguments are | |
33 | ;;; of particular types. | |
34 | ;;; | |
35 | ;;; A range denotes a subset of the set of values in a type, bounded by | |
36 | ;;; a minimum and a maximum. The precise meaning of a range depends on | |
37 | ;;; the type. For real numbers, the range indicates an inclusive lower | |
38 | ;;; and upper bound on the integer value of a type. For vectors, the | |
39 | ;;; range indicates the length of the vector. The range is limited to a | |
40 | ;;; signed 32-bit value, with the smallest and largest values indicating | |
41 | ;;; -inf.0 and +inf.0, respectively. For some types, like pairs, the | |
42 | ;;; concept of "range" makes no sense. In these cases we consider the | |
43 | ;;; range to be -inf.0 to +inf.0. | |
44 | ;;; | |
45 | ;;; Types are represented as a bitfield. Fewer bits means a more precise | |
46 | ;;; type. Although normally only values that have a single type will | |
47 | ;;; have an associated range, this is not enforced. The range applies | |
48 | ;;; to all types in the bitfield. When control flow meets, the types and | |
49 | ;;; ranges meet with the union operator. | |
50 | ;;; | |
51 | ;;; It is not practical to precisely compute value ranges in all cases. | |
52 | ;;; For example, in the following case: | |
53 | ;;; | |
54 | ;;; (let lp ((n 0)) (when (foo) (lp (1+ n)))) | |
55 | ;;; | |
56 | ;;; The first time that range analysis visits the program, N is | |
57 | ;;; determined to be the exact integer 0. The second time, it is an | |
58 | ;;; exact integer in the range [0, 1]; the third, [0, 2]; and so on. | |
59 | ;;; This analysis will terminate, but only after the positive half of | |
60 | ;;; the 32-bit range has been fully explored and we decide that the | |
61 | ;;; range of N is [0, +inf.0]. At the same time, we want to do range | |
62 | ;;; analysis and type analysis at the same time, as there are | |
63 | ;;; interactions between them, notably in the case of `sqrt' which | |
64 | ;;; returns a complex number if its argument cannot be proven to be | |
65 | ;;; non-negative. So what we do is, once the types reach a fixed point, | |
66 | ;;; we cause control-flow joins that would expand the range of a value | |
67 | ;;; to saturate that range towards positive or infinity (as | |
68 | ;;; appropriate). | |
69 | ;;; | |
ec412d75 AW |
70 | ;;; A naive approach to type analysis would build up a table that has |
71 | ;;; entries for all variables at all program points, but this has | |
72 | ;;; N-squared complexity and quickly grows unmanageable. Instead, we | |
3a12f2ce AW |
73 | ;;; use _intmaps_ from (language cps intmap) to share state between |
74 | ;;; connected program points. | |
8bc65d2d AW |
75 | ;;; |
76 | ;;; Code: | |
77 | ||
78 | (define-module (language cps types) | |
79 | #:use-module (ice-9 match) | |
80 | #:use-module (language cps) | |
81 | #:use-module (language cps dfg) | |
3a12f2ce | 82 | #:use-module (language cps intmap) |
8bc65d2d | 83 | #:use-module (rnrs bytevectors) |
ec412d75 AW |
84 | #:use-module (srfi srfi-9) |
85 | #:use-module (srfi srfi-11) | |
8bc65d2d AW |
86 | #:export (;; Specific types. |
87 | &exact-integer | |
88 | &flonum | |
89 | &complex | |
90 | &fraction | |
91 | ||
92 | &char | |
93 | &unspecified | |
94 | &unbound | |
7f5887e7 AW |
95 | &false |
96 | &true | |
8bc65d2d AW |
97 | &nil |
98 | &null | |
99 | &symbol | |
100 | &keyword | |
101 | ||
102 | &procedure | |
103 | ||
104 | &pointer | |
105 | &fluid | |
106 | &pair | |
107 | &vector | |
108 | &box | |
109 | &struct | |
110 | &string | |
111 | &bytevector | |
112 | &bitvector | |
113 | &array | |
114 | &hash-table | |
115 | ||
116 | ;; Union types. | |
117 | &number &real | |
118 | ||
119 | infer-types | |
120 | lookup-pre-type | |
121 | lookup-post-type | |
122 | primcall-types-check?)) | |
123 | ||
124 | (define-syntax define-flags | |
125 | (lambda (x) | |
126 | (syntax-case x () | |
127 | ((_ all shift name ...) | |
128 | (let ((count (length #'(name ...)))) | |
129 | (with-syntax (((n ...) (iota count)) | |
130 | (count count)) | |
131 | #'(begin | |
132 | (define-syntax name (identifier-syntax (ash 1 n))) | |
133 | ... | |
134 | (define-syntax all (identifier-syntax (1- (ash 1 count)))) | |
135 | (define-syntax shift (identifier-syntax count))))))))) | |
136 | ||
137 | ;; More precise types have fewer bits. | |
138 | (define-flags &all-types &type-bits | |
139 | &exact-integer | |
140 | &flonum | |
141 | &complex | |
142 | &fraction | |
143 | ||
144 | &char | |
145 | &unspecified | |
146 | &unbound | |
7f5887e7 AW |
147 | &false |
148 | &true | |
8bc65d2d AW |
149 | &nil |
150 | &null | |
151 | &symbol | |
152 | &keyword | |
153 | ||
154 | &procedure | |
155 | ||
156 | &pointer | |
157 | &fluid | |
158 | &pair | |
159 | &vector | |
160 | &box | |
161 | &struct | |
162 | &string | |
163 | &bytevector | |
164 | &bitvector | |
165 | &array | |
166 | &hash-table) | |
167 | ||
168 | (define-syntax &no-type (identifier-syntax 0)) | |
169 | ||
170 | (define-syntax &number | |
171 | (identifier-syntax (logior &exact-integer &flonum &complex &fraction))) | |
172 | (define-syntax &real | |
173 | (identifier-syntax (logior &exact-integer &flonum &fraction))) | |
174 | ||
175 | (define-syntax *max-s32* (identifier-syntax (- (ash 1 31) 1))) | |
176 | (define-syntax *min-s32* (identifier-syntax (- 0 (ash 1 31)))) | |
177 | ||
178 | ;; Versions of min and max that do not coerce exact numbers to become | |
179 | ;; inexact. | |
180 | (define min | |
181 | (case-lambda | |
182 | ((a b) (if (< a b) a b)) | |
183 | ((a b c) (min (min a b) c)) | |
184 | ((a b c d) (min (min a b) c d)))) | |
185 | (define max | |
186 | (case-lambda | |
187 | ((a b) (if (> a b) a b)) | |
188 | ((a b c) (max (max a b) c)) | |
189 | ((a b c d) (max (max a b) c d)))) | |
190 | ||
3a12f2ce AW |
191 | \f |
192 | ||
193 | (define-syntax-rule (define-compile-time-value name val) | |
194 | (define-syntax name | |
195 | (make-variable-transformer | |
196 | (lambda (x) | |
197 | (syntax-case x (set!) | |
198 | (var (identifier? #'var) | |
199 | (datum->syntax #'var val))))))) | |
200 | ||
201 | (define-compile-time-value min-fixnum most-negative-fixnum) | |
202 | (define-compile-time-value max-fixnum most-positive-fixnum) | |
203 | ||
204 | (define-inlinable (make-unclamped-type-entry type min max) | |
205 | (vector type min max)) | |
206 | (define-inlinable (type-entry-type tentry) | |
207 | (vector-ref tentry 0)) | |
208 | (define-inlinable (type-entry-clamped-min tentry) | |
209 | (vector-ref tentry 1)) | |
210 | (define-inlinable (type-entry-clamped-max tentry) | |
211 | (vector-ref tentry 2)) | |
212 | ||
213 | (define-syntax-rule (clamp-range val) | |
214 | (cond | |
215 | ((< val min-fixnum) min-fixnum) | |
216 | ((< max-fixnum val) max-fixnum) | |
217 | (else val))) | |
218 | ||
219 | (define-inlinable (make-type-entry type min max) | |
220 | (vector type (clamp-range min) (clamp-range max))) | |
221 | (define-inlinable (type-entry-min tentry) | |
222 | (let ((min (type-entry-clamped-min tentry))) | |
223 | (if (eq? min min-fixnum) -inf.0 min))) | |
224 | (define-inlinable (type-entry-max tentry) | |
225 | (let ((max (type-entry-clamped-max tentry))) | |
226 | (if (eq? max max-fixnum) +inf.0 max))) | |
227 | ||
228 | (define all-types-entry (make-type-entry &all-types -inf.0 +inf.0)) | |
229 | ||
230 | (define* (var-type-entry typeset var #:optional (default all-types-entry)) | |
231 | (or (intmap-ref typeset var) default)) | |
232 | ||
233 | (define (var-type typeset var) | |
234 | (type-entry-type (var-type-entry typeset var))) | |
235 | (define (var-min typeset var) | |
236 | (type-entry-min (var-type-entry typeset var))) | |
237 | (define (var-max typeset var) | |
238 | (type-entry-max (var-type-entry typeset var))) | |
239 | ||
240 | ;; Is the type entry A contained entirely within B? | |
241 | (define (type-entry<=? a b) | |
242 | (match (cons a b) | |
243 | ((#(a-type a-min a-max) . #(b-type b-min b-max)) | |
244 | (and (eqv? b-type (logior a-type b-type)) | |
245 | (<= b-min a-min) | |
246 | (>= b-max a-max))))) | |
247 | ||
248 | (define (type-entry-union a b) | |
249 | (cond | |
250 | ((type-entry<=? b a) a) | |
251 | ((type-entry<=? a b) b) | |
252 | (else (make-type-entry | |
253 | (logior (type-entry-type a) (type-entry-type b)) | |
254 | (min (type-entry-clamped-min a) (type-entry-clamped-min b)) | |
255 | (max (type-entry-clamped-max a) (type-entry-clamped-max b)))))) | |
256 | ||
257 | (define (type-entry-intersection a b) | |
258 | (cond | |
259 | ((type-entry<=? a b) a) | |
260 | ((type-entry<=? b a) b) | |
261 | (else (make-type-entry | |
262 | (logand (type-entry-type a) (type-entry-type b)) | |
263 | (max (type-entry-clamped-min a) (type-entry-clamped-min b)) | |
264 | (min (type-entry-clamped-max a) (type-entry-clamped-max b)))))) | |
265 | ||
266 | (define (adjoin-var typeset var entry) | |
267 | (intmap-add typeset var entry type-entry-union)) | |
268 | ||
269 | (define (restrict-var typeset var entry) | |
270 | (intmap-add typeset var entry type-entry-intersection)) | |
271 | ||
8bc65d2d AW |
272 | (define (constant-type val) |
273 | "Compute the type and range of VAL. Return three values: the type, | |
274 | minimum, and maximum." | |
275 | (define (return type val) | |
276 | (if val | |
3a12f2ce AW |
277 | (make-type-entry type val val) |
278 | (make-type-entry type -inf.0 +inf.0))) | |
8bc65d2d AW |
279 | (cond |
280 | ((number? val) | |
281 | (cond | |
282 | ((exact-integer? val) (return &exact-integer val)) | |
283 | ((eqv? (imag-part val) 0) | |
ec412d75 | 284 | (if (nan? val) |
3a12f2ce AW |
285 | (make-type-entry &flonum -inf.0 +inf.0) |
286 | (make-type-entry | |
287 | (if (exact? val) &fraction &flonum) | |
288 | (if (rational? val) (inexact->exact (floor val)) val) | |
289 | (if (rational? val) (inexact->exact (ceiling val)) val)))) | |
8bc65d2d AW |
290 | (else (return &complex #f)))) |
291 | ((eq? val '()) (return &null #f)) | |
292 | ((eq? val #nil) (return &nil #f)) | |
7f5887e7 AW |
293 | ((eq? val #t) (return &true #f)) |
294 | ((eq? val #f) (return &false #f)) | |
8bc65d2d AW |
295 | ((char? val) (return &char (char->integer val))) |
296 | ((eqv? val *unspecified*) (return &unspecified #f)) | |
8bc65d2d AW |
297 | ((symbol? val) (return &symbol #f)) |
298 | ((keyword? val) (return &keyword #f)) | |
299 | ((pair? val) (return &pair #f)) | |
300 | ((vector? val) (return &vector (vector-length val))) | |
301 | ((string? val) (return &string (string-length val))) | |
302 | ((bytevector? val) (return &bytevector (bytevector-length val))) | |
303 | ((bitvector? val) (return &bitvector (bitvector-length val))) | |
304 | ((array? val) (return &array (array-rank val))) | |
305 | ((not (variable-bound? (make-variable val))) (return &unbound #f)) | |
306 | ||
307 | (else (error "unhandled constant" val)))) | |
308 | ||
8bc65d2d AW |
309 | (define *type-checkers* (make-hash-table)) |
310 | (define *type-inferrers* (make-hash-table)) | |
8bc65d2d AW |
311 | |
312 | (define-syntax-rule (define-type-helper name) | |
313 | (define-syntax-parameter name | |
314 | (lambda (stx) | |
315 | (syntax-violation 'name | |
316 | "macro used outside of define-type" | |
317 | stx)))) | |
318 | (define-type-helper define!) | |
319 | (define-type-helper restrict!) | |
320 | (define-type-helper &type) | |
321 | (define-type-helper &min) | |
322 | (define-type-helper &max) | |
323 | ||
324 | (define-syntax-rule (define-type-checker (name arg ...) body ...) | |
325 | (hashq-set! | |
326 | *type-checkers* | |
327 | 'name | |
ec412d75 | 328 | (lambda (typeset arg ...) |
8bc65d2d | 329 | (syntax-parameterize |
ec412d75 AW |
330 | ((&type (syntax-rules () ((_ val) (var-type typeset val)))) |
331 | (&min (syntax-rules () ((_ val) (var-min typeset val)))) | |
332 | (&max (syntax-rules () ((_ val) (var-max typeset val))))) | |
8bc65d2d AW |
333 | body ...)))) |
334 | ||
335 | (define-syntax-rule (check-type arg type min max) | |
336 | ;; If the arg is negative, it is a closure variable. | |
337 | (and (>= arg 0) | |
338 | (zero? (logand (lognot type) (&type arg))) | |
339 | (<= min (&min arg)) | |
340 | (<= (&max arg) max))) | |
341 | ||
ec412d75 | 342 | (define-syntax-rule (define-type-inferrer* (name succ var ...) body ...) |
8bc65d2d AW |
343 | (hashq-set! |
344 | *type-inferrers* | |
345 | 'name | |
ec412d75 AW |
346 | (lambda (in succ var ...) |
347 | (let ((out in)) | |
348 | (syntax-parameterize | |
349 | ((define! | |
350 | (syntax-rules () | |
351 | ((_ val type min max) | |
3a12f2ce AW |
352 | (set! out (adjoin-var out val |
353 | (make-type-entry type min max)))))) | |
ec412d75 AW |
354 | (restrict! |
355 | (syntax-rules () | |
356 | ((_ val type min max) | |
3a12f2ce AW |
357 | (set! out (restrict-var out val |
358 | (make-type-entry type min max)))))) | |
ec412d75 AW |
359 | (&type (syntax-rules () ((_ val) (var-type in val)))) |
360 | (&min (syntax-rules () ((_ val) (var-min in val)))) | |
361 | (&max (syntax-rules () ((_ val) (var-max in val))))) | |
362 | body ... | |
363 | out))))) | |
364 | ||
365 | (define-syntax-rule (define-type-inferrer (name arg ...) body ...) | |
366 | (define-type-inferrer* (name succ arg ...) body ...)) | |
367 | ||
368 | (define-syntax-rule (define-predicate-inferrer (name arg ... true?) body ...) | |
369 | (define-type-inferrer* (name succ arg ...) | |
370 | (let ((true? (not (zero? succ)))) | |
371 | body ...))) | |
8bc65d2d AW |
372 | |
373 | (define-syntax define-simple-type-checker | |
374 | (lambda (x) | |
375 | (define (parse-spec l) | |
376 | (syntax-case l () | |
377 | (() '()) | |
378 | (((type min max) . l) (cons #'(type min max) (parse-spec #'l))) | |
379 | (((type min+max) . l) (cons #'(type min+max min+max) (parse-spec #'l))) | |
380 | ((type . l) (cons #'(type -inf.0 +inf.0) (parse-spec #'l))))) | |
381 | (syntax-case x () | |
382 | ((_ (name arg-spec ...) result-spec ...) | |
383 | (with-syntax | |
384 | (((arg ...) (generate-temporaries #'(arg-spec ...))) | |
385 | (((arg-type arg-min arg-max) ...) (parse-spec #'(arg-spec ...)))) | |
386 | #'(define-type-checker (name arg ...) | |
387 | (and (check-type arg arg-type arg-min arg-max) | |
388 | ...))))))) | |
389 | ||
390 | (define-syntax define-simple-type-inferrer | |
391 | (lambda (x) | |
392 | (define (parse-spec l) | |
393 | (syntax-case l () | |
394 | (() '()) | |
395 | (((type min max) . l) (cons #'(type min max) (parse-spec #'l))) | |
396 | (((type min+max) . l) (cons #'(type min+max min+max) (parse-spec #'l))) | |
397 | ((type . l) (cons #'(type -inf.0 +inf.0) (parse-spec #'l))))) | |
398 | (syntax-case x () | |
399 | ((_ (name arg-spec ...) result-spec ...) | |
400 | (with-syntax | |
401 | (((arg ...) (generate-temporaries #'(arg-spec ...))) | |
402 | (((arg-type arg-min arg-max) ...) (parse-spec #'(arg-spec ...))) | |
403 | ((res ...) (generate-temporaries #'(result-spec ...))) | |
404 | (((res-type res-min res-max) ...) (parse-spec #'(result-spec ...)))) | |
405 | #'(define-type-inferrer (name arg ... res ...) | |
406 | (restrict! arg arg-type arg-min arg-max) | |
407 | ... | |
408 | (define! res res-type res-min res-max) | |
409 | ...)))))) | |
410 | ||
411 | (define-syntax-rule (define-simple-type (name arg-spec ...) result-spec ...) | |
412 | (begin | |
413 | (define-simple-type-checker (name arg-spec ...)) | |
414 | (define-simple-type-inferrer (name arg-spec ...) result-spec ...))) | |
415 | ||
416 | (define-syntax-rule (define-simple-types | |
417 | ((name arg-spec ...) result-spec ...) | |
418 | ...) | |
419 | (begin | |
420 | (define-simple-type (name arg-spec ...) result-spec ...) | |
421 | ...)) | |
422 | ||
423 | (define-syntax-rule (define-type-checker-aliases orig alias ...) | |
424 | (let ((check (hashq-ref *type-checkers* 'orig))) | |
425 | (hashq-set! *type-checkers* 'alias check) | |
426 | ...)) | |
427 | (define-syntax-rule (define-type-inferrer-aliases orig alias ...) | |
428 | (let ((check (hashq-ref *type-inferrers* 'orig))) | |
429 | (hashq-set! *type-inferrers* 'alias check) | |
430 | ...)) | |
431 | (define-syntax-rule (define-type-aliases orig alias ...) | |
432 | (begin | |
433 | (define-type-checker-aliases orig alias ...) | |
434 | (define-type-inferrer-aliases orig alias ...))) | |
435 | ||
436 | ||
437 | \f | |
438 | ||
439 | ;;; This list of primcall type definitions follows the order of | |
440 | ;;; effects-analysis.scm; please keep it in a similar order. | |
441 | ;;; | |
442 | ;;; There is no need to add checker definitions for expressions that do | |
443 | ;;; not exhibit the &type-check effect, as callers should not ask if | |
444 | ;;; such an expression does or does not type-check. For those that do | |
445 | ;;; exhibit &type-check, you should define a type inferrer unless the | |
446 | ;;; primcall will never typecheck. | |
447 | ;;; | |
448 | ;;; Likewise there is no need to define inferrers for primcalls which | |
449 | ;;; return &all-types values and which never raise exceptions from which | |
450 | ;;; we can infer the types of incoming values. | |
451 | ||
452 | ||
453 | \f | |
454 | ||
8bc65d2d AW |
455 | ;;; |
456 | ;;; Generic effect-free predicates. | |
457 | ;;; | |
458 | ||
459 | (define-predicate-inferrer (eq? a b true?) | |
460 | ;; We can only propagate information down the true leg. | |
461 | (when true? | |
462 | (let ((type (logand (&type a) (&type b))) | |
463 | (min (max (&min a) (&min b))) | |
464 | (max (min (&max a) (&max b)))) | |
465 | (restrict! a type min max) | |
466 | (restrict! b type min max)))) | |
467 | (define-type-inferrer-aliases eq? eqv? equal?) | |
468 | ||
469 | (define-syntax-rule (define-simple-predicate-inferrer predicate type) | |
470 | (define-predicate-inferrer (predicate val true?) | |
471 | (let ((type (if true? | |
472 | type | |
473 | (logand (&type val) (lognot type))))) | |
474 | (restrict! val type -inf.0 +inf.0)))) | |
475 | (define-simple-predicate-inferrer pair? &pair) | |
476 | (define-simple-predicate-inferrer null? &null) | |
477 | (define-simple-predicate-inferrer nil? &nil) | |
478 | (define-simple-predicate-inferrer symbol? &symbol) | |
479 | (define-simple-predicate-inferrer variable? &box) | |
480 | (define-simple-predicate-inferrer vector? &vector) | |
481 | (define-simple-predicate-inferrer struct? &struct) | |
482 | (define-simple-predicate-inferrer string? &string) | |
e2fafeb9 AW |
483 | (define-simple-predicate-inferrer bytevector? &bytevector) |
484 | (define-simple-predicate-inferrer bitvector? &bitvector) | |
485 | (define-simple-predicate-inferrer keyword? &keyword) | |
8bc65d2d AW |
486 | (define-simple-predicate-inferrer number? &number) |
487 | (define-simple-predicate-inferrer char? &char) | |
488 | (define-simple-predicate-inferrer procedure? &procedure) | |
489 | (define-simple-predicate-inferrer thunk? &procedure) | |
490 | ||
491 | \f | |
492 | ||
493 | ;;; | |
494 | ;;; Fluids. Note that we can't track bound-ness of fluids, as pop-fluid | |
495 | ;;; can change boundness. | |
496 | ;;; | |
497 | ||
498 | (define-simple-types | |
499 | ((fluid-ref (&fluid 1)) &all-types) | |
500 | ((fluid-set! (&fluid 0 1) &all-types)) | |
501 | ((push-fluid (&fluid 0 1) &all-types)) | |
502 | ((pop-fluid))) | |
503 | ||
504 | ||
505 | \f | |
506 | ||
507 | ;;; | |
508 | ;;; Prompts. (Nothing to do.) | |
509 | ;;; | |
510 | ||
511 | ||
512 | \f | |
513 | ||
514 | ;;; | |
515 | ;;; Pairs. | |
516 | ;;; | |
517 | ||
518 | (define-simple-types | |
519 | ((cons &all-types &all-types) &pair) | |
520 | ((car &pair) &all-types) | |
521 | ((set-car! &pair &all-types)) | |
522 | ((cdr &pair) &all-types) | |
523 | ((set-cdr! &pair &all-types))) | |
524 | ||
525 | ||
526 | \f | |
527 | ||
528 | ;;; | |
529 | ;;; Variables. | |
530 | ;;; | |
531 | ||
532 | (define-simple-types | |
533 | ((box &all-types) (&box 1)) | |
534 | ((box-ref (&box 1)) &all-types)) | |
535 | ||
536 | (define-simple-type-checker (box-set! (&box 0 1) &all-types)) | |
537 | (define-type-inferrer (box-set! box val) | |
538 | (restrict! box &box 1 1)) | |
539 | ||
540 | ||
541 | \f | |
542 | ||
543 | ;;; | |
544 | ;;; Vectors. | |
545 | ;;; | |
546 | ||
547 | ;; This max-vector-len computation is a hack. | |
548 | (define *max-vector-len* (ash most-positive-fixnum -5)) | |
549 | ||
550 | (define-simple-type-checker (make-vector (&exact-integer 0 *max-vector-len*) | |
551 | &all-types)) | |
552 | (define-type-inferrer (make-vector size init result) | |
553 | (restrict! size &exact-integer 0 *max-vector-len*) | |
ec412d75 | 554 | (define! result &vector (max (&min size) 0) (&max size))) |
8bc65d2d AW |
555 | |
556 | (define-type-checker (vector-ref v idx) | |
557 | (and (check-type v &vector 0 *max-vector-len*) | |
558 | (check-type idx &exact-integer 0 (1- (&min v))))) | |
559 | (define-type-inferrer (vector-ref v idx result) | |
560 | (restrict! v &vector (1+ (&min idx)) +inf.0) | |
561 | (restrict! idx &exact-integer 0 (1- (&max v))) | |
562 | (define! result &all-types -inf.0 +inf.0)) | |
563 | ||
564 | (define-type-checker (vector-set! v idx val) | |
565 | (and (check-type v &vector 0 *max-vector-len*) | |
566 | (check-type idx &exact-integer 0 (1- (&min v))))) | |
567 | (define-type-inferrer (vector-set! v idx val) | |
568 | (restrict! v &vector (1+ (&min idx)) +inf.0) | |
569 | (restrict! idx &exact-integer 0 (1- (&max v)))) | |
570 | ||
571 | (define-type-aliases make-vector make-vector/immediate) | |
572 | (define-type-aliases vector-ref vector-ref/immediate) | |
573 | (define-type-aliases vector-set! vector-set!/immediate) | |
574 | ||
575 | (define-simple-type-checker (vector-length &vector)) | |
576 | (define-type-inferrer (vector-length v result) | |
577 | (restrict! v &vector 0 *max-vector-len*) | |
ec412d75 AW |
578 | (define! result &exact-integer (max (&min v) 0) |
579 | (min (&max v) *max-vector-len*))) | |
8bc65d2d AW |
580 | |
581 | ||
582 | \f | |
583 | ||
584 | ;;; | |
585 | ;;; Structs. | |
586 | ;;; | |
587 | ||
588 | ;; No type-checker for allocate-struct, as we can't currently check that | |
589 | ;; vt is actually a vtable. | |
590 | (define-type-inferrer (allocate-struct vt size result) | |
591 | (restrict! vt &struct vtable-offset-user +inf.0) | |
592 | (restrict! size &exact-integer 0 +inf.0) | |
593 | (define! result &struct (max (&min size) 0) (&max size))) | |
594 | ||
595 | (define-type-checker (struct-ref s idx) | |
596 | (and (check-type s &struct 0 +inf.0) | |
597 | (check-type idx &exact-integer 0 +inf.0) | |
598 | ;; FIXME: is the field readable? | |
599 | (< (&max idx) (&min s)))) | |
600 | (define-type-inferrer (struct-ref s idx result) | |
601 | (restrict! s &struct (1+ (&min idx)) +inf.0) | |
602 | (restrict! idx &exact-integer 0 (1- (&max s))) | |
603 | (define! result &all-types -inf.0 +inf.0)) | |
604 | ||
605 | (define-type-checker (struct-set! s idx val) | |
606 | (and (check-type s &struct 0 +inf.0) | |
607 | (check-type idx &exact-integer 0 +inf.0) | |
608 | ;; FIXME: is the field writable? | |
609 | (< (&max idx) (&min s)))) | |
610 | (define-type-inferrer (struct-set! s idx val) | |
611 | (restrict! s &struct (1+ (&min idx)) +inf.0) | |
612 | (restrict! idx &exact-integer 0 (1- (&max s)))) | |
613 | ||
614 | (define-type-aliases allocate-struct allocate-struct/immediate) | |
615 | (define-type-aliases struct-ref struct-ref/immediate) | |
616 | (define-type-aliases struct-set! struct-set!/immediate) | |
617 | ||
618 | (define-simple-type (struct-vtable (&struct 0 +inf.0)) | |
619 | (&struct vtable-offset-user +inf.0)) | |
620 | ||
621 | ||
622 | \f | |
623 | ||
624 | ;;; | |
625 | ;;; Strings. | |
626 | ;;; | |
627 | ||
628 | (define *max-char* (1- (ash 1 24))) | |
629 | ||
630 | (define-type-checker (string-ref s idx) | |
631 | (and (check-type s &string 0 +inf.0) | |
632 | (check-type idx &exact-integer 0 +inf.0) | |
633 | (< (&max idx) (&min s)))) | |
634 | (define-type-inferrer (string-ref s idx result) | |
635 | (restrict! s &string (1+ (&min idx)) +inf.0) | |
636 | (restrict! idx &exact-integer 0 (1- (&max s))) | |
637 | (define! result &char 0 *max-char*)) | |
638 | ||
639 | (define-type-checker (string-set! s idx val) | |
640 | (and (check-type s &string 0 +inf.0) | |
641 | (check-type idx &exact-integer 0 +inf.0) | |
642 | (check-type val &char 0 *max-char*) | |
643 | (< (&max idx) (&min s)))) | |
644 | (define-type-inferrer (string-set! s idx val) | |
645 | (restrict! s &string (1+ (&min idx)) +inf.0) | |
646 | (restrict! idx &exact-integer 0 (1- (&max s))) | |
647 | (restrict! val &char 0 *max-char*)) | |
648 | ||
649 | (define-simple-type-checker (string-length &string)) | |
650 | (define-type-inferrer (string-length s result) | |
651 | (restrict! s &string 0 +inf.0) | |
652 | (define! result &exact-integer (max (&min s) 0) (&max s))) | |
653 | ||
654 | (define-simple-type (number->string &number) (&string 0 +inf.0)) | |
655 | (define-simple-type (string->number (&string 0 +inf.0)) | |
7f5887e7 | 656 | ((logior &number &false) -inf.0 +inf.0)) |
8bc65d2d AW |
657 | |
658 | ||
659 | \f | |
660 | ||
661 | ;;; | |
662 | ;;; Bytevectors. | |
663 | ;;; | |
664 | ||
665 | (define-simple-type-checker (bytevector-length &bytevector)) | |
666 | (define-type-inferrer (bytevector-length bv result) | |
667 | (restrict! bv &bytevector 0 +inf.0) | |
668 | (define! result &exact-integer (max (&min bv) 0) (&max bv))) | |
669 | ||
670 | (define-syntax-rule (define-bytevector-accessors ref set type size min max) | |
671 | (begin | |
672 | (define-type-checker (ref bv idx) | |
673 | (and (check-type bv &bytevector 0 +inf.0) | |
674 | (check-type idx &exact-integer 0 +inf.0) | |
675 | (< (&max idx) (- (&min bv) size)))) | |
676 | (define-type-inferrer (ref bv idx result) | |
677 | (restrict! bv &bytevector (+ (&min idx) size) +inf.0) | |
678 | (restrict! idx &exact-integer 0 (- (&max bv) size)) | |
679 | (define! result type min max)) | |
680 | (define-type-checker (set bv idx val) | |
681 | (and (check-type bv &bytevector 0 +inf.0) | |
682 | (check-type idx &exact-integer 0 +inf.0) | |
683 | (check-type val type min max) | |
684 | (< (&max idx) (- (&min bv) size)))) | |
685 | (define-type-inferrer (set! bv idx val) | |
686 | (restrict! bv &bytevector (+ (&min idx) size) +inf.0) | |
687 | (restrict! idx &exact-integer 0 (- (&max bv) size)) | |
688 | (restrict! val type min max)))) | |
689 | ||
690 | (define-syntax-rule (define-short-bytevector-accessors ref set size signed?) | |
691 | (define-bytevector-accessors ref set &exact-integer size | |
692 | (if signed? (- (ash 1 (1- (* size 8)))) 0) | |
693 | (1- (ash 1 (if signed? (1- (* size 8)) (* size 8)))))) | |
694 | ||
695 | (define-short-bytevector-accessors bv-u8-ref bv-u8-set! 1 #f) | |
696 | (define-short-bytevector-accessors bv-s8-ref bv-s8-set! 1 #t) | |
697 | (define-short-bytevector-accessors bv-u16-ref bv-u16-set! 2 #f) | |
698 | (define-short-bytevector-accessors bv-s16-ref bv-s16-set! 2 #t) | |
699 | ||
700 | ;; The range analysis only works on signed 32-bit values, so some limits | |
701 | ;; are out of range. | |
702 | (define-bytevector-accessors bv-u32-ref bv-u32-set! &exact-integer 4 0 +inf.0) | |
703 | (define-bytevector-accessors bv-s32-ref bv-s32-set! &exact-integer 4 -inf.0 +inf.0) | |
704 | (define-bytevector-accessors bv-u64-ref bv-u64-set! &exact-integer 8 0 +inf.0) | |
705 | (define-bytevector-accessors bv-s64-ref bv-s64-set! &exact-integer 8 -inf.0 +inf.0) | |
706 | (define-bytevector-accessors bv-f32-ref bv-f32-set! &real 4 -inf.0 +inf.0) | |
707 | (define-bytevector-accessors bv-f64-ref bv-f64-set! &real 8 -inf.0 +inf.0) | |
708 | ||
709 | ||
710 | \f | |
711 | ||
712 | ;;; | |
713 | ;;; Numbers. | |
714 | ;;; | |
715 | ||
716 | ;; First, branching primitives with no results. | |
717 | (define-simple-type-checker (= &number &number)) | |
718 | (define-predicate-inferrer (= a b true?) | |
719 | (when (and true? | |
720 | (zero? (logand (logior (&type a) (&type b)) (lognot &number)))) | |
721 | (let ((min (max (&min a) (&min b))) | |
722 | (max (min (&max a) (&max b)))) | |
723 | (restrict! a &number min max) | |
724 | (restrict! b &number min max)))) | |
725 | ||
4ce18570 AW |
726 | (define (restricted-comparison-ranges op type0 min0 max0 type1 min1 max1) |
727 | (define (infer-integer-ranges) | |
728 | (match op | |
729 | ('< (values min0 (min max0 (1- max1)) (max (1+ min0) min1) max1)) | |
730 | ('<= (values min0 (min max0 max1) (max min0 min1) max1)) | |
731 | ('>= (values (max min0 min1) max0 min1 (min max0 max1))) | |
732 | ('> (values (max min0 (1+ min1)) max0 min1 (min (1- max0) max1))))) | |
733 | (define (infer-real-ranges) | |
734 | (match op | |
735 | ((or '< '<=) (values min0 (min max0 max1) (max min0 min1) max1)) | |
736 | ((or '> '>=) (values (max min0 min1) max0 min1 (min max0 max1))))) | |
737 | (if (= (logior type0 type1) &exact-integer) | |
738 | (infer-integer-ranges) | |
739 | (infer-real-ranges))) | |
740 | ||
741 | (define-syntax-rule (define-comparison-inferrer (op inverse)) | |
742 | (define-predicate-inferrer (op a b true?) | |
743 | (when (zero? (logand (logior (&type a) (&type b)) (lognot &number))) | |
744 | (call-with-values | |
745 | (lambda () | |
746 | (restricted-comparison-ranges (if true? 'op 'inverse) | |
747 | (&type a) (&min a) (&max a) | |
748 | (&type b) (&min b) (&max b))) | |
749 | (lambda (min0 max0 min1 max1) | |
750 | (restrict! a &real min0 max0) | |
751 | (restrict! b &real min1 max1)))))) | |
752 | ||
8bc65d2d | 753 | (define-simple-type-checker (< &real &real)) |
4ce18570 AW |
754 | (define-comparison-inferrer (< >=)) |
755 | ||
756 | (define-simple-type-checker (<= &real &real)) | |
757 | (define-comparison-inferrer (<= >)) | |
758 | ||
759 | (define-simple-type-checker (>= &real &real)) | |
760 | (define-comparison-inferrer (>= <)) | |
761 | ||
762 | (define-simple-type-checker (> &real &real)) | |
763 | (define-comparison-inferrer (> <=)) | |
8bc65d2d AW |
764 | |
765 | ;; Arithmetic. | |
766 | (define-syntax-rule (define-unary-result! a result min max) | |
767 | (let ((min* min) | |
768 | (max* max) | |
769 | (type (logand (&type a) &number))) | |
770 | (cond | |
771 | ((not (= type (&type a))) | |
772 | ;; Not a number. Punt and do nothing. | |
773 | (define! result &all-types -inf.0 +inf.0)) | |
774 | ;; Complex numbers don't have a range. | |
775 | ((eqv? type &complex) | |
776 | (define! result &complex -inf.0 +inf.0)) | |
777 | (else | |
778 | (define! result type min* max*))))) | |
779 | ||
780 | (define-syntax-rule (define-binary-result! a b result closed? min max) | |
781 | (let ((min* min) | |
782 | (max* max) | |
783 | (a-type (logand (&type a) &number)) | |
784 | (b-type (logand (&type b) &number))) | |
785 | (cond | |
786 | ((or (not (= a-type (&type a))) (not (= b-type (&type b)))) | |
787 | ;; One input not a number. Perhaps we end up dispatching to | |
788 | ;; GOOPS. | |
789 | (define! result &all-types -inf.0 +inf.0)) | |
790 | ;; Complex and floating-point numbers are contagious. | |
791 | ((or (eqv? a-type &complex) (eqv? b-type &complex)) | |
792 | (define! result &complex -inf.0 +inf.0)) | |
793 | ((or (eqv? a-type &flonum) (eqv? b-type &flonum)) | |
794 | (define! result &flonum min* max*)) | |
795 | ;; Exact integers are closed under some operations. | |
796 | ((and closed? (eqv? a-type &exact-integer) (eqv? b-type &exact-integer)) | |
797 | (define! result &exact-integer min* max*)) | |
798 | (else | |
799 | ;; Fractions may become integers. | |
800 | (let ((type (logior a-type b-type))) | |
801 | (define! result | |
802 | (if (zero? (logand type &fraction)) | |
803 | type | |
804 | (logior type &exact-integer)) | |
805 | min* max*)))))) | |
806 | ||
807 | (define-simple-type-checker (add &number &number)) | |
808 | (define-type-inferrer (add a b result) | |
809 | (define-binary-result! a b result #t | |
810 | (+ (&min a) (&min b)) | |
811 | (+ (&max a) (&max b)))) | |
812 | ||
813 | (define-simple-type-checker (sub &number &number)) | |
814 | (define-type-inferrer (sub a b result) | |
815 | (define-binary-result! a b result #t | |
816 | (- (&min a) (&max b)) | |
817 | (- (&max a) (&min b)))) | |
818 | ||
819 | (define-simple-type-checker (mul &number &number)) | |
820 | (define-type-inferrer (mul a b result) | |
821 | (let ((min-a (&min a)) (max-a (&max a)) | |
822 | (min-b (&min b)) (max-b (&max b))) | |
42b544eb AW |
823 | (define (nan* a b) |
824 | ;; We only really get +inf.0 at runtime for flonums and compnums. | |
825 | ;; If we have inferred that the arguments are not flonums and not | |
826 | ;; compnums, then the result of (* +inf.0 0) at range inference | |
827 | ;; time is 0 and not +nan.0. | |
828 | (if (or (and (inf? a) (zero? b)) | |
829 | (and (zero? a) (inf? b)) | |
830 | (not (logtest (logior (&type a) (&type b)) | |
831 | (logior &flonum &complex)))) | |
832 | 0 | |
833 | (* a b))) | |
834 | (let ((-- (nan* min-a min-b)) | |
835 | (-+ (nan* min-a max-b)) | |
836 | (++ (nan* max-a max-b)) | |
837 | (+- (nan* max-a min-b))) | |
838 | (let ((has-nan? (or (nan? --) (nan? -+) (nan? ++) (nan? +-)))) | |
839 | (define-binary-result! a b result #t | |
840 | (cond | |
841 | ((eqv? a b) 0) | |
842 | (has-nan? -inf.0) | |
843 | (else (min -- -+ ++ +-))) | |
844 | (if has-nan? | |
845 | +inf.0 | |
846 | (max -- -+ ++ +-))))))) | |
8bc65d2d AW |
847 | |
848 | (define-type-checker (div a b) | |
849 | (and (check-type a &number -inf.0 +inf.0) | |
850 | (check-type b &number -inf.0 +inf.0) | |
851 | ;; We only know that there will not be an exception if b is not | |
852 | ;; zero. | |
853 | (not (<= (&min b) 0 (&max b))))) | |
854 | (define-type-inferrer (div a b result) | |
855 | (let ((min-a (&min a)) (max-a (&max a)) | |
856 | (min-b (&min b)) (max-b (&max b))) | |
857 | (call-with-values | |
858 | (lambda () | |
859 | (if (<= min-b 0 max-b) | |
860 | ;; If the range of the divisor crosses 0, the result spans | |
861 | ;; the whole range. | |
862 | (values -inf.0 +inf.0) | |
863 | ;; Otherwise min-b and max-b have the same sign, and cannot both | |
864 | ;; be infinity. | |
42b544eb AW |
865 | (let ((--- (if (inf? min-b) 0 (floor/ min-a min-b))) |
866 | (-+- (if (inf? max-b) 0 (floor/ min-a max-b))) | |
867 | (++- (if (inf? max-b) 0 (floor/ max-a max-b))) | |
868 | (+-- (if (inf? min-b) 0 (floor/ max-a min-b))) | |
869 | (--+ (if (inf? min-b) 0 (ceiling/ min-a min-b))) | |
870 | (-++ (if (inf? max-b) 0 (ceiling/ min-a max-b))) | |
871 | (+++ (if (inf? max-b) 0 (ceiling/ max-a max-b))) | |
872 | (+-+ (if (inf? min-b) 0 (ceiling/ max-a min-b)))) | |
873 | (values (min (min --- -+- ++- +--) | |
874 | (min --+ -++ +++ +-+)) | |
875 | (max (max --- -+- ++- +--) | |
876 | (max --+ -++ +++ +-+)))))) | |
8bc65d2d AW |
877 | (lambda (min max) |
878 | (define-binary-result! a b result #f min max))))) | |
879 | ||
880 | (define-simple-type-checker (add1 &number)) | |
881 | (define-type-inferrer (add1 a result) | |
882 | (define-unary-result! a result (1+ (&min a)) (1+ (&max a)))) | |
883 | ||
884 | (define-simple-type-checker (sub1 &number)) | |
885 | (define-type-inferrer (sub1 a result) | |
886 | (define-unary-result! a result (1- (&min a)) (1- (&max a)))) | |
887 | ||
888 | (define-type-checker (quo a b) | |
889 | (and (check-type a &exact-integer -inf.0 +inf.0) | |
890 | (check-type b &exact-integer -inf.0 +inf.0) | |
891 | ;; We only know that there will not be an exception if b is not | |
892 | ;; zero. | |
893 | (not (<= (&min b) 0 (&max b))))) | |
894 | (define-type-inferrer (quo a b result) | |
895 | (restrict! a &exact-integer -inf.0 +inf.0) | |
896 | (restrict! b &exact-integer -inf.0 +inf.0) | |
897 | (define! result &exact-integer -inf.0 +inf.0)) | |
898 | ||
899 | (define-type-checker-aliases quo rem) | |
900 | (define-type-inferrer (rem a b result) | |
901 | (restrict! a &exact-integer -inf.0 +inf.0) | |
902 | (restrict! b &exact-integer -inf.0 +inf.0) | |
903 | ;; Same sign as A. | |
904 | (let ((max-abs-rem (1- (max (abs (&min b)) (abs (&max b)))))) | |
905 | (cond | |
906 | ((< (&min a) 0) | |
907 | (if (< 0 (&max a)) | |
908 | (define! result &exact-integer (- max-abs-rem) max-abs-rem) | |
909 | (define! result &exact-integer (- max-abs-rem) 0))) | |
910 | (else | |
911 | (define! result &exact-integer 0 max-abs-rem))))) | |
912 | ||
913 | (define-type-checker-aliases quo mod) | |
914 | (define-type-inferrer (mod a b result) | |
915 | (restrict! a &exact-integer -inf.0 +inf.0) | |
916 | (restrict! b &exact-integer -inf.0 +inf.0) | |
917 | ;; Same sign as B. | |
918 | (let ((max-abs-mod (1- (max (abs (&min b)) (abs (&max b)))))) | |
919 | (cond | |
920 | ((< (&min b) 0) | |
921 | (if (< 0 (&max b)) | |
922 | (define! result &exact-integer (- max-abs-mod) max-abs-mod) | |
923 | (define! result &exact-integer (- max-abs-mod) 0))) | |
924 | (else | |
925 | (define! result &exact-integer 0 max-abs-mod))))) | |
926 | ||
927 | ;; Predicates. | |
928 | (define-syntax-rule (define-number-kind-predicate-inferrer name type) | |
929 | (define-type-inferrer (name val result) | |
930 | (cond | |
931 | ((zero? (logand (&type val) type)) | |
7f5887e7 | 932 | (define! result &false 0 0)) |
8bc65d2d | 933 | ((zero? (logand (&type val) (lognot type))) |
7f5887e7 | 934 | (define! result &true 0 0)) |
8bc65d2d | 935 | (else |
7f5887e7 | 936 | (define! result (logior &true &false) 0 0))))) |
8bc65d2d AW |
937 | (define-number-kind-predicate-inferrer complex? &number) |
938 | (define-number-kind-predicate-inferrer real? &real) | |
939 | (define-number-kind-predicate-inferrer rational? | |
940 | (logior &exact-integer &fraction)) | |
941 | (define-number-kind-predicate-inferrer integer? | |
942 | (logior &exact-integer &flonum)) | |
943 | (define-number-kind-predicate-inferrer exact-integer? | |
944 | &exact-integer) | |
945 | ||
946 | (define-simple-type-checker (exact? &number)) | |
947 | (define-type-inferrer (exact? val result) | |
948 | (restrict! val &number -inf.0 +inf.0) | |
949 | (cond | |
950 | ((zero? (logand (&type val) (logior &exact-integer &fraction))) | |
7f5887e7 | 951 | (define! result &false 0 0)) |
8bc65d2d | 952 | ((zero? (logand (&type val) (lognot (logior &exact-integer &fraction)))) |
7f5887e7 | 953 | (define! result &true 0 0)) |
8bc65d2d | 954 | (else |
7f5887e7 | 955 | (define! result (logior &true &false) 0 0)))) |
8bc65d2d AW |
956 | |
957 | (define-simple-type-checker (inexact? &number)) | |
958 | (define-type-inferrer (inexact? val result) | |
959 | (restrict! val &number -inf.0 +inf.0) | |
960 | (cond | |
961 | ((zero? (logand (&type val) (logior &flonum &complex))) | |
7f5887e7 | 962 | (define! result &false 0 0)) |
ec412d75 AW |
963 | ((zero? (logand (&type val) (logand &number |
964 | (lognot (logior &flonum &complex))))) | |
7f5887e7 | 965 | (define! result &true 0 0)) |
8bc65d2d | 966 | (else |
7f5887e7 | 967 | (define! result (logior &true &false) 0 0)))) |
8bc65d2d AW |
968 | |
969 | (define-simple-type-checker (inf? &real)) | |
970 | (define-type-inferrer (inf? val result) | |
971 | (restrict! val &real -inf.0 +inf.0) | |
972 | (cond | |
973 | ((or (zero? (logand (&type val) (logior &flonum &complex))) | |
974 | (and (not (inf? (&min val))) (not (inf? (&max val))))) | |
7f5887e7 | 975 | (define! result &false 0 0)) |
8bc65d2d | 976 | (else |
7f5887e7 | 977 | (define! result (logior &true &false) 0 0)))) |
8bc65d2d AW |
978 | |
979 | (define-type-aliases inf? nan?) | |
980 | ||
7f5887e7 AW |
981 | (define-simple-type (even? &exact-integer) |
982 | ((logior &true &false) 0 0)) | |
8bc65d2d AW |
983 | (define-type-aliases even? odd?) |
984 | ||
985 | ;; Bit operations. | |
986 | (define-simple-type-checker (ash &exact-integer &exact-integer)) | |
987 | (define-type-inferrer (ash val count result) | |
988 | (define (ash* val count) | |
989 | ;; As we can only represent a 32-bit range, don't bother inferring | |
990 | ;; shifts that might exceed that range. | |
991 | (cond | |
992 | ((inf? val) val) ; Preserves sign. | |
993 | ((< -32 count 32) (ash val count)) | |
994 | ((zero? val) 0) | |
995 | ((positive? val) +inf.0) | |
996 | (else -inf.0))) | |
997 | (restrict! val &exact-integer -inf.0 +inf.0) | |
998 | (restrict! count &exact-integer -inf.0 +inf.0) | |
999 | (let ((-- (ash* (&min val) (&min count))) | |
1000 | (-+ (ash* (&min val) (&max count))) | |
1001 | (++ (ash* (&max val) (&max count))) | |
1002 | (+- (ash* (&max val) (&min count)))) | |
1003 | (define! result &exact-integer | |
1004 | (min -- -+ ++ +-) | |
1005 | (max -- -+ ++ +-)))) | |
1006 | ||
1007 | (define (next-power-of-two n) | |
1008 | (let lp ((out 1)) | |
1009 | (if (< n out) | |
1010 | out | |
1011 | (lp (ash out 1))))) | |
1012 | ||
1013 | (define-simple-type-checker (logand &exact-integer &exact-integer)) | |
1014 | (define-type-inferrer (logand a b result) | |
1015 | (define (logand-min a b) | |
74fe7fae | 1016 | (if (and (negative? a) (negative? b)) |
8bc65d2d AW |
1017 | (min a b) |
1018 | 0)) | |
1019 | (define (logand-max a b) | |
74fe7fae AW |
1020 | (if (and (positive? a) (positive? b)) |
1021 | (min a b) | |
1022 | 0)) | |
8bc65d2d AW |
1023 | (restrict! a &exact-integer -inf.0 +inf.0) |
1024 | (restrict! b &exact-integer -inf.0 +inf.0) | |
1025 | (define! result &exact-integer | |
1026 | (logand-min (&min a) (&min b)) | |
1027 | (logand-max (&max a) (&max b)))) | |
1028 | ||
1029 | (define-simple-type-checker (logior &exact-integer &exact-integer)) | |
1030 | (define-type-inferrer (logior a b result) | |
1031 | ;; Saturate all bits of val. | |
1032 | (define (saturate val) | |
1033 | (1- (next-power-of-two val))) | |
1034 | (define (logior-min a b) | |
1035 | (cond ((and (< a 0) (<= 0 b)) a) | |
1036 | ((and (< b 0) (<= 0 a)) b) | |
1037 | (else (max a b)))) | |
1038 | (define (logior-max a b) | |
1039 | ;; If either operand is negative, just assume the max is -1. | |
1040 | (cond | |
1041 | ((or (< a 0) (< b 0)) -1) | |
1042 | ((or (inf? a) (inf? b)) +inf.0) | |
1043 | (else (saturate (logior a b))))) | |
1044 | (restrict! a &exact-integer -inf.0 +inf.0) | |
1045 | (restrict! b &exact-integer -inf.0 +inf.0) | |
1046 | (define! result &exact-integer | |
1047 | (logior-min (&min a) (&min b)) | |
1048 | (logior-max (&max a) (&max b)))) | |
1049 | ||
1050 | ;; For our purposes, treat logxor the same as logior. | |
1051 | (define-type-aliases logior logxor) | |
1052 | ||
1053 | (define-simple-type-checker (lognot &exact-integer)) | |
1054 | (define-type-inferrer (lognot a result) | |
1055 | (restrict! a &exact-integer -inf.0 +inf.0) | |
1056 | (define! result &exact-integer | |
1057 | (- -1 (&max a)) | |
1058 | (- -1 (&min a)))) | |
1059 | ||
8006d2d6 | 1060 | (define-simple-type-checker (logtest &exact-integer &exact-integer)) |
d613ccaa | 1061 | (define-predicate-inferrer (logtest a b true?) |
8006d2d6 | 1062 | (restrict! a &exact-integer -inf.0 +inf.0) |
d613ccaa | 1063 | (restrict! b &exact-integer -inf.0 +inf.0)) |
8006d2d6 AW |
1064 | |
1065 | (define-simple-type-checker (logbit? (&exact-integer 0 +inf.0) &exact-integer)) | |
1066 | (define-type-inferrer (logbit? a b result) | |
1067 | (let ((a-min (&min a)) | |
1068 | (a-max (&max a)) | |
1069 | (b-min (&min b)) | |
1070 | (b-max (&max b))) | |
1071 | (if (and (eqv? a-min a-max) (>= a-min 0) (not (inf? a-min)) | |
1072 | (eqv? b-min b-max) (>= b-min 0) (not (inf? b-min))) | |
7f5887e7 AW |
1073 | (let ((type (if (logbit? a-min b-min) &true &false))) |
1074 | (define! result type 0 0)) | |
1075 | (define! result (logior &true &false) 0 0)))) | |
8006d2d6 | 1076 | |
8bc65d2d AW |
1077 | ;; Flonums. |
1078 | (define-simple-type-checker (sqrt &number)) | |
1079 | (define-type-inferrer (sqrt x result) | |
8bc65d2d AW |
1080 | (let ((type (&type x))) |
1081 | (cond | |
1082 | ((and (zero? (logand type &complex)) (<= 0 (&min x))) | |
1083 | (define! result | |
1084 | (logior type &flonum) | |
1085 | (inexact->exact (floor (sqrt (&min x)))) | |
1086 | (if (inf? (&max x)) | |
1087 | +inf.0 | |
1088 | (inexact->exact (ceiling (sqrt (&max x))))))) | |
1089 | (else | |
1090 | (define! result (logior type &flonum &complex) -inf.0 +inf.0))))) | |
1091 | ||
1092 | (define-simple-type-checker (abs &real)) | |
1093 | (define-type-inferrer (abs x result) | |
ec412d75 AW |
1094 | (let ((type (&type x))) |
1095 | (cond | |
1096 | ((eqv? type (logand type &number)) | |
1097 | (restrict! x &real -inf.0 +inf.0) | |
1098 | (define! result (logand type &real) | |
1099 | (min (abs (&min x)) (abs (&max x))) | |
1100 | (max (abs (&min x)) (abs (&max x))))) | |
1101 | (else | |
1102 | (define! result (logior (logand (&type x) (lognot &number)) | |
1103 | (logand (&type x) &real)) | |
1104 | (max (&min x) 0) | |
1105 | (max (abs (&min x)) (abs (&max x)))))))) | |
8bc65d2d AW |
1106 | |
1107 | ||
1108 | \f | |
1109 | ||
1110 | ;;; | |
1111 | ;;; Characters. | |
1112 | ;;; | |
1113 | ||
7f5887e7 AW |
1114 | (define-simple-type (char<? &char &char) |
1115 | ((logior &true &false) 0 0)) | |
8bc65d2d AW |
1116 | (define-type-aliases char<? char<=? char>=? char>?) |
1117 | ||
1118 | (define-simple-type-checker (integer->char (&exact-integer 0 #x10ffff))) | |
1119 | (define-type-inferrer (integer->char i result) | |
1120 | (restrict! i &exact-integer 0 #x10ffff) | |
ec412d75 | 1121 | (define! result &char (max (&min i) 0) (min (&max i) #x10ffff))) |
8bc65d2d AW |
1122 | |
1123 | (define-simple-type-checker (char->integer &char)) | |
1124 | (define-type-inferrer (char->integer c result) | |
1125 | (restrict! c &char 0 #x10ffff) | |
ec412d75 | 1126 | (define! result &exact-integer (max (&min c) 0) (min (&max c) #x10ffff))) |
8bc65d2d AW |
1127 | |
1128 | ||
1129 | \f | |
1130 | ||
1131 | ;;; | |
1132 | ;;; Type flow analysis: the meet (ahem) of the algorithm. | |
1133 | ;;; | |
1134 | ||
ec412d75 | 1135 | (define (infer-types* dfg min-label label-count) |
8bc65d2d AW |
1136 | "Compute types for all variables in @var{fun}. Returns a hash table |
1137 | mapping symbols to types." | |
ec412d75 AW |
1138 | (let ((typev (make-vector label-count)) |
1139 | (idoms (compute-idoms dfg min-label label-count)) | |
1140 | (revisit-label #f) | |
1141 | (types-changed? #f) | |
1142 | (saturate-ranges? #f)) | |
8bc65d2d | 1143 | (define (label->idx label) (- label min-label)) |
ec412d75 AW |
1144 | |
1145 | (define (get-entry label) (vector-ref typev (label->idx label))) | |
1146 | ||
1147 | (define (in-types entry) (vector-ref entry 0)) | |
1148 | (define (out-types entry succ) (vector-ref entry (1+ succ))) | |
1149 | ||
1150 | (define (update-in-types! entry types) | |
1151 | (vector-set! entry 0 types)) | |
1152 | (define (update-out-types! entry succ types) | |
1153 | (vector-set! entry (1+ succ) types)) | |
1154 | ||
1155 | (define (prepare-initial-state!) | |
1156 | ;; The result is a vector with an entry for each label. Each entry | |
1157 | ;; is a vector. The first slot in the entry vector corresponds to | |
1158 | ;; the types that flow into the labelled expression. The following | |
1159 | ;; slot is for the types that flow out to the first successor, and | |
1160 | ;; so on for additional successors. | |
1161 | (let lp ((label min-label)) | |
1162 | (when (< label (+ min-label label-count)) | |
1163 | (let* ((nsuccs (match (lookup-cont label dfg) | |
1164 | (($ $kargs _ _ term) | |
1165 | (match (find-call term) | |
1166 | (($ $continue k src (or ($ $branch) ($ $prompt))) 2) | |
1167 | (_ 1))) | |
1168 | (($ $kfun src meta self tail clause) (if clause 1 0)) | |
1169 | (($ $kclause arity body alt) (if alt 2 1)) | |
1170 | (($ $kreceive) 1) | |
1171 | (($ $ktail) 0))) | |
1172 | (entry (make-vector (1+ nsuccs) #f))) | |
1173 | (vector-set! typev (label->idx label) entry) | |
1174 | (lp (1+ label))))) | |
1175 | ||
1176 | ;; Initial state: nothing flows into the $kfun. | |
1177 | (let ((entry (get-entry min-label))) | |
3a12f2ce | 1178 | (update-in-types! entry empty-intmap))) |
ec412d75 | 1179 | |
3a12f2ce | 1180 | (define (adjoin-vars types vars entry) |
ec412d75 AW |
1181 | (match vars |
1182 | (() types) | |
1183 | ((var . vars) | |
3a12f2ce | 1184 | (adjoin-vars (adjoin-var types var entry) vars entry)))) |
ec412d75 AW |
1185 | |
1186 | (define (infer-primcall types succ name args result) | |
1187 | (cond | |
1188 | ((hashq-ref *type-inferrers* name) | |
1189 | => (lambda (inferrer) | |
1190 | ;; FIXME: remove the apply? | |
1191 | ;(pk 'primcall name args result) | |
1192 | (apply inferrer types succ | |
1193 | (if result | |
1194 | (append args (list result)) | |
1195 | args)))) | |
1196 | (result | |
3a12f2ce | 1197 | (adjoin-var types result all-types-entry)) |
ec412d75 AW |
1198 | (else |
1199 | types))) | |
1200 | ||
3a12f2ce AW |
1201 | (define (type-entry-saturating-union a b) |
1202 | (cond | |
1203 | ((type-entry<=? b a) a) | |
1204 | #; | |
1205 | ((and (not saturate-ranges?) | |
1206 | (eqv? (a-type )) | |
1207 | (type-entry<=? a b)) b) | |
1208 | (else (make-type-entry | |
1209 | (let* ((a-type (type-entry-type a)) | |
1210 | (b-type (type-entry-type b)) | |
1211 | (type (logior a-type b-type))) | |
1212 | (unless (eqv? a-type type) | |
1213 | (set! types-changed? #t)) | |
1214 | type) | |
1215 | (let ((a-min (type-entry-clamped-min a)) | |
1216 | (b-min (type-entry-clamped-min b))) | |
1217 | (if (< b-min a-min) | |
1218 | (if saturate-ranges? min-fixnum b-min) | |
1219 | a-min)) | |
1220 | (let ((a-max (type-entry-clamped-max a)) | |
1221 | (b-max (type-entry-clamped-max b))) | |
1222 | (if (> b-max a-max) | |
1223 | (if saturate-ranges? max-fixnum b-max) | |
1224 | a-max)))))) | |
1225 | ||
ec412d75 AW |
1226 | (define (propagate-types! pred-label pred-entry succ-idx succ-label out) |
1227 | ;; Update "in" set of continuation. | |
1228 | (let ((succ-entry (get-entry succ-label))) | |
1229 | (match (lookup-predecessors succ-label dfg) | |
1230 | ((_) | |
1231 | ;; A normal edge. | |
1232 | (update-in-types! succ-entry out)) | |
1233 | (_ | |
1234 | ;; A control-flow join. | |
1235 | (let* ((succ-dom-label (vector-ref idoms (label->idx succ-label))) | |
1236 | (succ-dom-entry (get-entry succ-dom-label)) | |
1237 | (old-in (in-types succ-entry)) | |
3a12f2ce AW |
1238 | (in (if old-in |
1239 | (intmap-intersect old-in out | |
1240 | type-entry-saturating-union) | |
1241 | out))) | |
1242 | ;; If the "in" set changed, update the entry and possibly | |
1243 | ;; arrange to iterate again. | |
1244 | (unless (eq? old-in in) | |
1245 | (update-in-types! succ-entry in) | |
1246 | ;; If the changed successor is a back-edge, ensure that | |
1247 | ;; we revisit the function. | |
1248 | (when (<= succ-label pred-label) | |
1249 | (unless (and revisit-label (<= revisit-label succ-label)) | |
1250 | ;; (pk 'marking-revisit pred-label succ-label) | |
1251 | (set! revisit-label succ-label)))))))) | |
ec412d75 AW |
1252 | ;; Finally update "out" set for current expression. |
1253 | (update-out-types! pred-entry succ-idx out)) | |
1254 | ||
1255 | (define (visit-exp label entry k types exp) | |
1256 | (define (propagate! succ-idx succ-label types) | |
1257 | (propagate-types! label entry succ-idx succ-label types)) | |
1258 | ;; Each of these branches must propagate! to its successors. | |
1259 | (match exp | |
1260 | (($ $branch kt ($ $values (arg))) | |
1261 | ;; The "normal" continuation is the #f branch. | |
3a12f2ce | 1262 | (let ((types (restrict-var types arg |
7f5887e7 | 1263 | (make-type-entry (logior &false &nil) |
3a12f2ce AW |
1264 | 0 |
1265 | 0)))) | |
ec412d75 | 1266 | (propagate! 0 k types)) |
7f5887e7 AW |
1267 | (let ((types (restrict-var types arg |
1268 | (make-type-entry | |
1269 | (logand &all-types | |
1270 | (lognot (logior &false &nil))) | |
1271 | -inf.0 +inf.0)))) | |
1272 | (propagate! 1 kt types))) | |
ec412d75 AW |
1273 | (($ $branch kt ($ $primcall name args)) |
1274 | ;; The "normal" continuation is the #f branch. | |
1275 | (let ((types (infer-primcall types 0 name args #f))) | |
1276 | (propagate! 0 k types)) | |
1277 | (let ((types (infer-primcall types 1 name args #f))) | |
1278 | (propagate! 1 kt types))) | |
1279 | (($ $prompt escape? tag handler) | |
1280 | ;; The "normal" continuation enters the prompt. | |
1281 | (propagate! 0 k types) | |
1282 | (propagate! 1 handler types)) | |
1283 | (($ $primcall name args) | |
1284 | (propagate! 0 k | |
1285 | (match (lookup-cont k dfg) | |
1286 | (($ $kargs _ defs) | |
1287 | (infer-primcall types 0 name args | |
1288 | (match defs ((var) var) (() #f)))) | |
1289 | (_ | |
1290 | ;(pk 'warning-no-restrictions name) | |
1291 | types)))) | |
1292 | (($ $values args) | |
1293 | (match (lookup-cont k dfg) | |
1294 | (($ $kargs _ defs) | |
1295 | (let ((in types)) | |
1296 | (let lp ((defs defs) (args args) (out types)) | |
1297 | (match (cons defs args) | |
1298 | ((() . ()) | |
1299 | (propagate! 0 k out)) | |
1300 | (((def . defs) . (arg . args)) | |
1301 | (lp defs args | |
3a12f2ce | 1302 | (adjoin-var out def (var-type-entry in arg)))))))) |
ec412d75 AW |
1303 | (_ |
1304 | (propagate! 0 k types)))) | |
1305 | ((or ($ $call) ($ $callk)) | |
1306 | (propagate! 0 k types)) | |
34ff3af9 AW |
1307 | (($ $rec names vars funs) |
1308 | (let ((proc-type (make-type-entry &procedure -inf.0 +inf.0))) | |
1309 | (propagate! 0 k (adjoin-vars types vars proc-type)))) | |
8bc65d2d | 1310 | (_ |
3a12f2ce AW |
1311 | (match (lookup-cont k dfg) |
1312 | (($ $kargs (_) (var)) | |
1313 | (let ((entry (match exp | |
3a12f2ce AW |
1314 | (($ $const val) |
1315 | (constant-type val)) | |
1316 | ((or ($ $prim) ($ $fun) ($ $closure)) | |
1317 | ;; Could be more precise here. | |
1318 | (make-type-entry &procedure -inf.0 +inf.0))))) | |
1319 | (propagate! 0 k (adjoin-var types var entry)))))))) | |
ec412d75 AW |
1320 | |
1321 | (prepare-initial-state!) | |
1322 | ||
1323 | ;; Iterate over all labelled expressions in the function, | |
1324 | ;; propagating types and ranges to all successors. | |
8bc65d2d | 1325 | (let lp ((label min-label)) |
ec412d75 | 1326 | ;(pk 'visit label) |
8bc65d2d AW |
1327 | (cond |
1328 | ((< label (+ min-label label-count)) | |
ec412d75 AW |
1329 | (let* ((entry (vector-ref typev (label->idx label))) |
1330 | (types (in-types entry))) | |
1331 | (define (propagate! succ-idx succ-label types) | |
1332 | (propagate-types! label entry succ-idx succ-label types)) | |
8bc65d2d AW |
1333 | ;; Add types for new definitions, and restrict types of |
1334 | ;; existing variables due to side effects. | |
1335 | (match (lookup-cont label dfg) | |
8bc65d2d | 1336 | (($ $kargs names vars term) |
ec412d75 | 1337 | (let visit-term ((term term) (types types)) |
8bc65d2d | 1338 | (match term |
8bc65d2d | 1339 | (($ $letk conts term) |
ec412d75 | 1340 | (visit-term term types)) |
8bc65d2d | 1341 | (($ $continue k src exp) |
ec412d75 AW |
1342 | (visit-exp label entry k types exp))))) |
1343 | (($ $kreceive arity k) | |
1344 | (match (lookup-cont k dfg) | |
1345 | (($ $kargs names vars) | |
1346 | (propagate! 0 k | |
3a12f2ce | 1347 | (adjoin-vars types vars all-types-entry))))) |
8bc65d2d | 1348 | (($ $kfun src meta self tail clause) |
3a12f2ce | 1349 | (let ((types (adjoin-var types self all-types-entry))) |
8bc65d2d AW |
1350 | (match clause |
1351 | (#f #f) | |
ec412d75 AW |
1352 | (($ $cont kclause) |
1353 | (propagate! 0 kclause types))))) | |
1354 | (($ $kclause arity ($ $cont kbody ($ $kargs names vars)) alt) | |
1355 | (propagate! 0 kbody | |
3a12f2ce | 1356 | (adjoin-vars types vars all-types-entry)) |
ec412d75 AW |
1357 | (match alt |
1358 | (#f #f) | |
1359 | (($ $cont kclause) | |
1360 | (propagate! 1 kclause types)))) | |
1361 | (($ $ktail) #t))) | |
8bc65d2d AW |
1362 | |
1363 | ;; And loop. | |
1364 | (lp (1+ label))) | |
1365 | ||
ec412d75 AW |
1366 | ;; Iterate until we reach a fixed point. |
1367 | (revisit-label | |
1368 | ;; Once the types have a fixed point, iterate until ranges also | |
1369 | ;; reach a fixed point, saturating ranges to accelerate | |
1370 | ;; convergence. | |
1371 | (unless types-changed? | |
1372 | (set! saturate-ranges? #t)) | |
1373 | (set! types-changed? #f) | |
1374 | (let ((label revisit-label)) | |
1375 | (set! revisit-label #f) | |
1376 | ;(pk 'looping) | |
1377 | (lp label))) | |
8bc65d2d AW |
1378 | |
1379 | ;; All done! Return the computed types. | |
1380 | (else typev))))) | |
1381 | ||
ec412d75 AW |
1382 | (define-record-type <type-analysis> |
1383 | (make-type-analysis min-label label-count types) | |
1384 | type-analysis? | |
1385 | (min-label type-analysis-min-label) | |
1386 | (label-count type-analysis-label-count) | |
1387 | (types type-analysis-types)) | |
1388 | ||
1389 | (define (infer-types fun dfg) | |
8bc65d2d AW |
1390 | ;; Fun must be renumbered. |
1391 | (match fun | |
ec412d75 AW |
1392 | (($ $cont min-label ($ $kfun)) |
1393 | (let ((label-count ((make-local-cont-folder label-count) | |
1394 | (lambda (k cont label-count) (1+ label-count)) | |
1395 | fun 0))) | |
1396 | (make-type-analysis min-label label-count | |
1397 | (infer-types* dfg min-label label-count)))))) | |
1398 | ||
1399 | (define (lookup-pre-type analysis label def) | |
1400 | (match analysis | |
1401 | (($ <type-analysis> min-label label-count typev) | |
3a12f2ce AW |
1402 | (let* ((entry (vector-ref typev (- label min-label))) |
1403 | (tentry (var-type-entry (vector-ref entry 0) def))) | |
1404 | (values (type-entry-type tentry) | |
1405 | (type-entry-min tentry) | |
1406 | (type-entry-max tentry)))))) | |
ec412d75 AW |
1407 | |
1408 | (define (lookup-post-type analysis label def succ-idx) | |
1409 | (match analysis | |
1410 | (($ <type-analysis> min-label label-count typev) | |
3a12f2ce AW |
1411 | (let* ((entry (vector-ref typev (- label min-label))) |
1412 | (tentry (var-type-entry (vector-ref entry (1+ succ-idx)) def))) | |
1413 | (values (type-entry-type tentry) | |
1414 | (type-entry-min tentry) | |
1415 | (type-entry-max tentry)))))) | |
ec412d75 AW |
1416 | |
1417 | (define (primcall-types-check? analysis label name args) | |
1418 | (match (hashq-ref *type-checkers* name) | |
1419 | (#f #f) | |
1420 | (checker | |
1421 | (match analysis | |
1422 | (($ <type-analysis> min-label label-count typev) | |
1423 | (let ((entry (vector-ref typev (- label min-label)))) | |
1424 | (apply checker (vector-ref entry 0) args))))))) |