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