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