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