module/language/cps/types.scm

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