module/language/cps/types.scm

   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)))))))