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 (restricted-comparison-ranges op type0 min0 max0 type1 min1 max1)
 727   (define (infer-integer-ranges)
 728     (match op
 729       ('< (values min0 (min max0 (1- max1)) (max (1+ min0) min1) max1))
 730       ('<= (values min0 (min max0 max1) (max min0 min1) max1))
 731       ('>= (values (max min0 min1) max0 min1 (min max0 max1)))
 732       ('> (values (max min0 (1+ min1)) max0 min1 (min (1- max0) max1)))))
 733   (define (infer-real-ranges)
 734     (match op
 735       ((or '< '<=) (values min0 (min max0 max1) (max min0 min1) max1))
 736       ((or '> '>=) (values (max min0 min1) max0 min1 (min max0 max1)))))
 737   (if (= (logior type0 type1) &exact-integer)
 738       (infer-integer-ranges)
 739       (infer-real-ranges)))
 740
 741 (define-syntax-rule (define-comparison-inferrer (op inverse))
 742   (define-predicate-inferrer (op a b true?)
 743     (when (zero? (logand (logior (&type a) (&type b)) (lognot &number)))
 744       (call-with-values
 745           (lambda ()
 746             (restricted-comparison-ranges (if true? 'op 'inverse)
 747                                           (&type a) (&min a) (&max a)
 748                                           (&type b) (&min b) (&max b)))
 749         (lambda (min0 max0 min1 max1)
 750           (restrict! a &real min0 max0)
 751           (restrict! b &real min1 max1))))))
 752
 753 (define-simple-type-checker (< &real &real))
 754 (define-comparison-inferrer (< >=))
 755
 756 (define-simple-type-checker (<= &real &real))
 757 (define-comparison-inferrer (<= >))
 758
 759 (define-simple-type-checker (>= &real &real))
 760 (define-comparison-inferrer (>= <))
 761
 762 (define-simple-type-checker (> &real &real))
 763 (define-comparison-inferrer (> <=))
 764
 765 ;; Arithmetic.
 766 (define-syntax-rule (define-unary-result! a result min max)
 767   (let ((min* min)
 768         (max* max)
 769         (type (logand (&type a) &number)))
 770     (cond
 771      ((not (= type (&type a)))
 772       ;; Not a number.  Punt and do nothing.
 773       (define! result &all-types -inf.0 +inf.0))
 774      ;; Complex numbers don't have a range.
 775      ((eqv? type &complex)
 776       (define! result &complex -inf.0 +inf.0))
 777      (else
 778       (define! result type min* max*)))))
 779
 780 (define-syntax-rule (define-binary-result! a b result closed? min max)
 781   (let ((min* min)
 782         (max* max)
 783         (a-type (logand (&type a) &number))
 784         (b-type (logand (&type b) &number)))
 785     (cond
 786      ((or (not (= a-type (&type a))) (not (= b-type (&type b))))
 787       ;; One input not a number.  Perhaps we end up dispatching to
 788       ;; GOOPS.
 789       (define! result &all-types -inf.0 +inf.0))
 790      ;; Complex and floating-point numbers are contagious.
 791      ((or (eqv? a-type &complex) (eqv? b-type &complex))
 792       (define! result &complex -inf.0 +inf.0))
 793      ((or (eqv? a-type &flonum) (eqv? b-type &flonum))
 794       (define! result &flonum min* max*))
 795      ;; Exact integers are closed under some operations.
 796      ((and closed? (eqv? a-type &exact-integer) (eqv? b-type &exact-integer))
 797       (define! result &exact-integer min* max*))
 798      (else
 799       ;; Fractions may become integers.
 800       (let ((type (logior a-type b-type)))
 801         (define! result
 802                  (if (zero? (logand type &fraction))
 803                      type
 804                      (logior type &exact-integer))
 805                  min* max*))))))
 806
 807 (define-simple-type-checker (add &number &number))
 808 (define-type-inferrer (add a b result)
 809   (define-binary-result! a b result #t
 810                          (+ (&min a) (&min b))
 811                          (+ (&max a) (&max b))))
 812
 813 (define-simple-type-checker (sub &number &number))
 814 (define-type-inferrer (sub a b result)
 815   (define-binary-result! a b result #t
 816                          (- (&min a) (&max b))
 817                          (- (&max a) (&min b))))
 818
 819 (define-simple-type-checker (mul &number &number))
 820 (define-type-inferrer (mul a b result)
 821   (let ((min-a (&min a)) (max-a (&max a))
 822         (min-b (&min b)) (max-b (&max b)))
 823     (define (nan* a b)
 824       ;; We only really get +inf.0 at runtime for flonums and compnums.
 825       ;; If we have inferred that the arguments are not flonums and not
 826       ;; compnums, then the result of (* +inf.0 0) at range inference
 827       ;; time is 0 and not +nan.0.
 828       (if (or (and (inf? a) (zero? b))
 829               (and (zero? a) (inf? b))
 830               (not (logtest (logior (&type a) (&type b))
 831                             (logior &flonum &complex))))
 832           0
 833           (* a b)))
 834     (let ((-- (nan* min-a min-b))
 835           (-+ (nan* min-a max-b))
 836           (++ (nan* max-a max-b))
 837           (+- (nan* max-a min-b)))
 838       (let ((has-nan? (or (nan? --) (nan? -+) (nan? ++) (nan? +-))))
 839         (define-binary-result! a b result #t
 840                                (cond
 841                                 ((eqv? a b) 0)
 842                                 (has-nan? -inf.0)
 843                                 (else (min -- -+ ++ +-)))
 844                                (if has-nan?
 845                                    +inf.0
 846                                    (max -- -+ ++ +-)))))))
 847
 848 (define-type-checker (div a b)
 849   (and (check-type a &number -inf.0 +inf.0)
 850        (check-type b &number -inf.0 +inf.0)
 851        ;; We only know that there will not be an exception if b is not
 852        ;; zero.
 853        (not (<= (&min b) 0 (&max b)))))
 854 (define-type-inferrer (div a b result)
 855   (let ((min-a (&min a)) (max-a (&max a))
 856         (min-b (&min b)) (max-b (&max b)))
 857     (call-with-values
 858         (lambda ()
 859           (if (<= min-b 0 max-b)
 860               ;; If the range of the divisor crosses 0, the result spans
 861               ;; the whole range.
 862               (values -inf.0 +inf.0)
 863               ;; Otherwise min-b and max-b have the same sign, and cannot both
 864               ;; be infinity.
 865               (let ((--- (if (inf? min-b) 0 (floor/ min-a min-b)))
 866                     (-+- (if (inf? max-b) 0 (floor/ min-a max-b)))
 867                     (++- (if (inf? max-b) 0 (floor/ max-a max-b)))
 868                     (+-- (if (inf? min-b) 0 (floor/ max-a min-b)))
 869                     (--+ (if (inf? min-b) 0 (ceiling/ min-a min-b)))
 870                     (-++ (if (inf? max-b) 0 (ceiling/ min-a max-b)))
 871                     (+++ (if (inf? max-b) 0 (ceiling/ max-a max-b)))
 872                     (+-+ (if (inf? min-b) 0 (ceiling/ max-a min-b))))
 873                 (values (min (min --- -+- ++- +--)
 874                              (min --+ -++ +++ +-+))
 875                         (max (max --- -+- ++- +--)
 876                              (max --+ -++ +++ +-+))))))
 877       (lambda (min max)
 878         (define-binary-result! a b result #f min max)))))
 879
 880 (define-simple-type-checker (add1 &number))
 881 (define-type-inferrer (add1 a result)
 882   (define-unary-result! a result (1+ (&min a)) (1+ (&max a))))
 883
 884 (define-simple-type-checker (sub1 &number))
 885 (define-type-inferrer (sub1 a result)
 886   (define-unary-result! a result (1- (&min a)) (1- (&max a))))
 887
 888 (define-type-checker (quo a b)
 889   (and (check-type a &exact-integer -inf.0 +inf.0)
 890        (check-type b &exact-integer -inf.0 +inf.0)
 891        ;; We only know that there will not be an exception if b is not
 892        ;; zero.
 893        (not (<= (&min b) 0 (&max b)))))
 894 (define-type-inferrer (quo a b result)
 895   (restrict! a &exact-integer -inf.0 +inf.0)
 896   (restrict! b &exact-integer -inf.0 +inf.0)
 897   (define! result &exact-integer -inf.0 +inf.0))
 898
 899 (define-type-checker-aliases quo rem)
 900 (define-type-inferrer (rem a b result)
 901   (restrict! a &exact-integer -inf.0 +inf.0)
 902   (restrict! b &exact-integer -inf.0 +inf.0)
 903   ;; Same sign as A.
 904   (let ((max-abs-rem (1- (max (abs (&min b)) (abs (&max b))))))
 905     (cond
 906      ((< (&min a) 0)
 907       (if (< 0 (&max a))
 908           (define! result &exact-integer (- max-abs-rem) max-abs-rem)
 909           (define! result &exact-integer (- max-abs-rem) 0)))
 910      (else
 911       (define! result &exact-integer 0 max-abs-rem)))))
 912
 913 (define-type-checker-aliases quo mod)
 914 (define-type-inferrer (mod a b result)
 915   (restrict! a &exact-integer -inf.0 +inf.0)
 916   (restrict! b &exact-integer -inf.0 +inf.0)
 917   ;; Same sign as B.
 918   (let ((max-abs-mod (1- (max (abs (&min b)) (abs (&max b))))))
 919     (cond
 920      ((< (&min b) 0)
 921       (if (< 0 (&max b))
 922           (define! result &exact-integer (- max-abs-mod) max-abs-mod)
 923           (define! result &exact-integer (- max-abs-mod) 0)))
 924      (else
 925       (define! result &exact-integer 0 max-abs-mod)))))
 926
 927 ;; Predicates.
 928 (define-syntax-rule (define-number-kind-predicate-inferrer name type)
 929   (define-type-inferrer (name val result)
 930     (cond
 931      ((zero? (logand (&type val) type))
 932       (define! result &false 0 0))
 933      ((zero? (logand (&type val) (lognot type)))
 934       (define! result &true 0 0))
 935      (else
 936       (define! result (logior &true &false) 0 0)))))
 937 (define-number-kind-predicate-inferrer complex? &number)
 938 (define-number-kind-predicate-inferrer real? &real)
 939 (define-number-kind-predicate-inferrer rational?
 940   (logior &exact-integer &fraction))
 941 (define-number-kind-predicate-inferrer integer?
 942   (logior &exact-integer &flonum))
 943 (define-number-kind-predicate-inferrer exact-integer?
 944   &exact-integer)
 945
 946 (define-simple-type-checker (exact? &number))
 947 (define-type-inferrer (exact? val result)
 948   (restrict! val &number -inf.0 +inf.0)
 949   (cond
 950    ((zero? (logand (&type val) (logior &exact-integer &fraction)))
 951     (define! result &false 0 0))
 952    ((zero? (logand (&type val) (lognot (logior &exact-integer &fraction))))
 953     (define! result &true 0 0))
 954    (else
 955     (define! result (logior &true &false) 0 0))))
 956
 957 (define-simple-type-checker (inexact? &number))
 958 (define-type-inferrer (inexact? val result)
 959   (restrict! val &number -inf.0 +inf.0)
 960   (cond
 961    ((zero? (logand (&type val) (logior &flonum &complex)))
 962     (define! result &false 0 0))
 963    ((zero? (logand (&type val) (logand &number
 964                                        (lognot (logior &flonum &complex)))))
 965     (define! result &true 0 0))
 966    (else
 967     (define! result (logior &true &false) 0 0))))
 968
 969 (define-simple-type-checker (inf? &real))
 970 (define-type-inferrer (inf? val result)
 971   (restrict! val &real -inf.0 +inf.0)
 972   (cond
 973    ((or (zero? (logand (&type val) (logior &flonum &complex)))
 974         (and (not (inf? (&min val))) (not (inf? (&max val)))))
 975     (define! result &false 0 0))
 976    (else
 977     (define! result (logior &true &false) 0 0))))
 978
 979 (define-type-aliases inf? nan?)
 980
 981 (define-simple-type (even? &exact-integer)
 982   ((logior &true &false) 0 0))
 983 (define-type-aliases even? odd?)
 984
 985 ;; Bit operations.
 986 (define-simple-type-checker (ash &exact-integer &exact-integer))
 987 (define-type-inferrer (ash val count result)
 988   (define (ash* val count)
 989     ;; As we can only represent a 32-bit range, don't bother inferring
 990     ;; shifts that might exceed that range.
 991     (cond
 992      ((inf? val) val) ; Preserves sign.
 993      ((< -32 count 32) (ash val count))
 994      ((zero? val) 0)
 995      ((positive? val) +inf.0)
 996      (else -inf.0)))
 997   (restrict! val &exact-integer -inf.0 +inf.0)
 998   (restrict! count &exact-integer -inf.0 +inf.0)
 999   (let ((-- (ash* (&min val) (&min count)))
1000         (-+ (ash* (&min val) (&max count)))
1001         (++ (ash* (&max val) (&max count)))
1002         (+- (ash* (&max val) (&min count))))
1003     (define! result &exact-integer
1004              (min -- -+ ++ +-)
1005              (max -- -+ ++ +-))))
1006
1007 (define (next-power-of-two n)
1008   (let lp ((out 1))
1009     (if (< n out)
1010         out
1011         (lp (ash out 1)))))
1012
1013 (define-simple-type-checker (logand &exact-integer &exact-integer))
1014 (define-type-inferrer (logand a b result)
1015   (define (logand-min a b)
1016     (if (and (negative? a) (negative? b))
1017         (min a b)
1018         0))
1019   (define (logand-max a b)
1020     (if (and (positive? a) (positive? b))
1021         (min a b)
1022         0))
1023   (restrict! a &exact-integer -inf.0 +inf.0)
1024   (restrict! b &exact-integer -inf.0 +inf.0)
1025   (define! result &exact-integer
1026            (logand-min (&min a) (&min b))
1027            (logand-max (&max a) (&max b))))
1028
1029 (define-simple-type-checker (logior &exact-integer &exact-integer))
1030 (define-type-inferrer (logior a b result)
1031   ;; Saturate all bits of val.
1032   (define (saturate val)
1033     (1- (next-power-of-two val)))
1034   (define (logior-min a b)
1035     (cond ((and (< a 0) (<= 0 b)) a)
1036           ((and (< b 0) (<= 0 a)) b)
1037           (else (max a b))))
1038   (define (logior-max a b)
1039     ;; If either operand is negative, just assume the max is -1.
1040     (cond
1041      ((or (< a 0) (< b 0)) -1)
1042      ((or (inf? a) (inf? b)) +inf.0)
1043      (else (saturate (logior a b)))))
1044   (restrict! a &exact-integer -inf.0 +inf.0)
1045   (restrict! b &exact-integer -inf.0 +inf.0)
1046   (define! result &exact-integer
1047            (logior-min (&min a) (&min b))
1048            (logior-max (&max a) (&max b))))
1049
1050 ;; For our purposes, treat logxor the same as logior.
1051 (define-type-aliases logior logxor)
1052
1053 (define-simple-type-checker (lognot &exact-integer))
1054 (define-type-inferrer (lognot a result)
1055   (restrict! a &exact-integer -inf.0 +inf.0)
1056   (define! result &exact-integer
1057            (- -1 (&max a))
1058            (- -1 (&min a))))
1059
1060 (define-simple-type-checker (logtest &exact-integer &exact-integer))
1061 (define-predicate-inferrer (logtest a b true?)
1062   (restrict! a &exact-integer -inf.0 +inf.0)
1063   (restrict! b &exact-integer -inf.0 +inf.0))
1064
1065 (define-simple-type-checker (logbit? (&exact-integer 0 +inf.0) &exact-integer))
1066 (define-type-inferrer (logbit? a b result)
1067   (let ((a-min (&min a))
1068         (a-max (&max a))
1069         (b-min (&min b))
1070         (b-max (&max b)))
1071     (if (and (eqv? a-min a-max) (>= a-min 0) (not (inf? a-min))
1072              (eqv? b-min b-max) (>= b-min 0) (not (inf? b-min)))
1073         (let ((type (if (logbit? a-min b-min) &true &false)))
1074           (define! result type 0 0))
1075         (define! result (logior &true &false) 0 0))))
1076
1077 ;; Flonums.
1078 (define-simple-type-checker (sqrt &number))
1079 (define-type-inferrer (sqrt x result)
1080   (let ((type (&type x)))
1081     (cond
1082      ((and (zero? (logand type &complex)) (<= 0 (&min x)))
1083       (define! result
1084                (logior type &flonum)
1085                (inexact->exact (floor (sqrt (&min x))))
1086                (if (inf? (&max x))
1087                    +inf.0
1088                    (inexact->exact (ceiling (sqrt (&max x)))))))
1089      (else
1090       (define! result (logior type &flonum &complex) -inf.0 +inf.0)))))
1091
1092 (define-simple-type-checker (abs &real))
1093 (define-type-inferrer (abs x result)
1094   (let ((type (&type x)))
1095     (cond
1096      ((eqv? type (logand type &number))
1097       (restrict! x &real -inf.0 +inf.0)
1098       (define! result (logand type &real)
1099         (min (abs (&min x)) (abs (&max x)))
1100         (max (abs (&min x)) (abs (&max x)))))
1101      (else
1102       (define! result (logior (logand (&type x) (lognot &number))
1103                               (logand (&type x) &real))
1104         (max (&min x) 0)
1105         (max (abs (&min x)) (abs (&max x))))))))
1106
1107
1108 \f
1109
1110 ;;;
1111 ;;; Characters.
1112 ;;;
1113
1114 (define-simple-type (char<? &char &char)
1115   ((logior &true &false) 0 0))
1116 (define-type-aliases char<? char<=? char>=? char>?)
1117
1118 (define-simple-type-checker (integer->char (&exact-integer 0 #x10ffff)))
1119 (define-type-inferrer (integer->char i result)
1120   (restrict! i &exact-integer 0 #x10ffff)
1121   (define! result &char (max (&min i) 0) (min (&max i) #x10ffff)))
1122
1123 (define-simple-type-checker (char->integer &char))
1124 (define-type-inferrer (char->integer c result)
1125   (restrict! c &char 0 #x10ffff)
1126   (define! result &exact-integer (max (&min c) 0) (min (&max c) #x10ffff)))
1127
1128
1129 \f
1130
1131 ;;;
1132 ;;; Type flow analysis: the meet (ahem) of the algorithm.
1133 ;;;
1134
1135 (define (infer-types* dfg min-label label-count)
1136   "Compute types for all variables in @var{fun}.  Returns a hash table
1137 mapping symbols to types."
1138   (let ((typev (make-vector label-count))
1139         (idoms (compute-idoms dfg min-label label-count))
1140         (revisit-label #f)
1141         (types-changed? #f)
1142         (saturate-ranges? #f))
1143     (define (label->idx label) (- label min-label))
1144
1145     (define (get-entry label) (vector-ref typev (label->idx label)))
1146
1147     (define (in-types entry) (vector-ref entry 0))
1148     (define (out-types entry succ) (vector-ref entry (1+ succ)))
1149
1150     (define (update-in-types! entry types)
1151       (vector-set! entry 0 types))
1152     (define (update-out-types! entry succ types)
1153       (vector-set! entry (1+ succ) types))
1154
1155     (define (prepare-initial-state!)
1156       ;; The result is a vector with an entry for each label.  Each entry
1157       ;; is a vector.  The first slot in the entry vector corresponds to
1158       ;; the types that flow into the labelled expression.  The following
1159       ;; slot is for the types that flow out to the first successor, and
1160       ;; so on for additional successors.
1161       (let lp ((label min-label))
1162         (when (< label (+ min-label label-count))
1163           (let* ((nsuccs (match (lookup-cont label dfg)
1164                            (($ $kargs _ _ term)
1165                             (match (find-call term)
1166                               (($ $continue k src (or ($ $branch) ($ $prompt))) 2)
1167                               (_ 1)))
1168                            (($ $kfun src meta self tail clause) (if clause 1 0))
1169                            (($ $kclause arity body alt) (if alt 2 1))
1170                            (($ $kreceive) 1)
1171                            (($ $ktail) 0)))
1172                  (entry (make-vector (1+ nsuccs) #f)))
1173             (vector-set! typev (label->idx label) entry)
1174             (lp (1+ label)))))
1175
1176       ;; Initial state: nothing flows into the $kfun.
1177       (let ((entry (get-entry min-label)))
1178         (update-in-types! entry empty-intmap)))
1179
1180     (define (adjoin-vars types vars entry)
1181       (match vars
1182         (() types)
1183         ((var . vars)
1184          (adjoin-vars (adjoin-var types var entry) vars entry))))
1185
1186     (define (infer-primcall types succ name args result)
1187       (cond
1188        ((hashq-ref *type-inferrers* name)
1189         => (lambda (inferrer)
1190              ;; FIXME: remove the apply?
1191              ;(pk 'primcall name args result)
1192              (apply inferrer types succ
1193                     (if result
1194                         (append args (list result))
1195                         args))))
1196        (result
1197         (adjoin-var types result all-types-entry))
1198        (else
1199         types)))
1200
1201     (define (type-entry-saturating-union a b)
1202       (cond
1203        ((type-entry<=? b a) a)
1204        #;
1205        ((and (not saturate-ranges?)
1206          (eqv? (a-type ))
1207          (type-entry<=? a b)) b)
1208        (else (make-type-entry
1209               (let* ((a-type (type-entry-type a))
1210                      (b-type (type-entry-type b))
1211                      (type (logior a-type b-type)))
1212                 (unless (eqv? a-type type)
1213                   (set! types-changed? #t))
1214                 type)
1215               (let ((a-min (type-entry-clamped-min a))
1216                     (b-min (type-entry-clamped-min b)))
1217                 (if (< b-min a-min)
1218                     (if saturate-ranges? min-fixnum b-min)
1219                     a-min))
1220               (let ((a-max (type-entry-clamped-max a))
1221                     (b-max (type-entry-clamped-max b)))
1222                 (if (> b-max a-max)
1223                     (if saturate-ranges? max-fixnum b-max)
1224                     a-max))))))
1225
1226     (define (propagate-types! pred-label pred-entry succ-idx succ-label out)
1227       ;; Update "in" set of continuation.
1228       (let ((succ-entry (get-entry succ-label)))
1229         (match (lookup-predecessors succ-label dfg)
1230           ((_)
1231            ;; A normal edge.
1232            (update-in-types! succ-entry out))
1233           (_
1234            ;; A control-flow join.
1235            (let* ((succ-dom-label (vector-ref idoms (label->idx succ-label)))
1236                   (succ-dom-entry (get-entry succ-dom-label))
1237                   (old-in (in-types succ-entry))
1238                   (in (if old-in
1239                           (intmap-intersect old-in out
1240                                             type-entry-saturating-union)
1241                           out)))
1242              ;; If the "in" set changed, update the entry and possibly
1243              ;; arrange to iterate again.
1244              (unless (eq? old-in in)
1245                (update-in-types! succ-entry in)
1246                ;; If the changed successor is a back-edge, ensure that
1247                ;; we revisit the function.
1248                (when (<= succ-label pred-label)
1249                  (unless (and revisit-label (<= revisit-label succ-label))
1250                    ;; (pk 'marking-revisit pred-label succ-label)
1251                    (set! revisit-label succ-label))))))))
1252       ;; Finally update "out" set for current expression.
1253       (update-out-types! pred-entry succ-idx out))
1254
1255     (define (visit-exp label entry k types exp)
1256       (define (propagate! succ-idx succ-label types)
1257         (propagate-types! label entry succ-idx succ-label types))
1258       ;; Each of these branches must propagate! to its successors.
1259       (match exp
1260         (($ $branch kt ($ $values (arg)))
1261          ;; The "normal" continuation is the #f branch.
1262          (let ((types (restrict-var types arg
1263                                     (make-type-entry (logior &false &nil)
1264                                                      0
1265                                                      0))))
1266            (propagate! 0 k types))
1267          (let ((types (restrict-var types arg
1268                                     (make-type-entry
1269                                      (logand &all-types
1270                                              (lognot (logior &false &nil)))
1271                                      -inf.0 +inf.0))))
1272            (propagate! 1 kt types)))
1273         (($ $branch kt ($ $primcall name args))
1274          ;; The "normal" continuation is the #f branch.
1275          (let ((types (infer-primcall types 0 name args #f)))
1276            (propagate! 0 k types))
1277          (let ((types (infer-primcall types 1 name args #f)))
1278            (propagate! 1 kt types)))
1279         (($ $prompt escape? tag handler)
1280          ;; The "normal" continuation enters the prompt.
1281          (propagate! 0 k types)
1282          (propagate! 1 handler types))
1283         (($ $primcall name args)
1284          (propagate! 0 k
1285                      (match (lookup-cont k dfg)
1286                        (($ $kargs _ defs)
1287                         (infer-primcall types 0 name args
1288                                         (match defs ((var) var) (() #f))))
1289                        (_
1290                         ;(pk 'warning-no-restrictions name)
1291                         types))))
1292         (($ $values args)
1293          (match (lookup-cont k dfg)
1294            (($ $kargs _ defs)
1295             (let ((in types))
1296               (let lp ((defs defs) (args args) (out types))
1297                 (match (cons defs args)
1298                   ((() . ())
1299                    (propagate! 0 k out))
1300                   (((def . defs) . (arg . args))
1301                    (lp defs args
1302                        (adjoin-var out def (var-type-entry in arg))))))))
1303            (_
1304             (propagate! 0 k types))))
1305         ((or ($ $call) ($ $callk))
1306          (propagate! 0 k types))
1307         (_
1308          (match (lookup-cont k dfg)
1309            (($ $kargs (_) (var))
1310             (let ((entry (match exp
1311                            (($ $const val)
1312                             (constant-type val))
1313                            ((or ($ $prim) ($ $fun) ($ $closure))
1314                             ;; Could be more precise here.
1315                             (make-type-entry &procedure -inf.0 +inf.0)))))
1316               (propagate! 0 k (adjoin-var types var entry))))))))
1317
1318     (prepare-initial-state!)
1319
1320     ;; Iterate over all labelled expressions in the function,
1321     ;; propagating types and ranges to all successors.
1322     (let lp ((label min-label))
1323       ;(pk 'visit label)
1324       (cond
1325        ((< label (+ min-label label-count))
1326         (let* ((entry (vector-ref typev (label->idx label)))
1327                (types (in-types entry)))
1328           (define (propagate! succ-idx succ-label types)
1329             (propagate-types! label entry succ-idx succ-label types))
1330           ;; Add types for new definitions, and restrict types of
1331           ;; existing variables due to side effects.
1332           (match (lookup-cont label dfg)
1333             (($ $kargs names vars term)
1334              (let visit-term ((term term) (types types))
1335                (match term
1336                  (($ $letrec names vars funs term)
1337                   (visit-term term
1338                               (adjoin-vars types vars
1339                                            (make-type-entry &procedure
1340                                                             -inf.0 +inf.0))))
1341                  (($ $letk conts term)
1342                   (visit-term term types))
1343                  (($ $continue k src exp)
1344                   (visit-exp label entry k types exp)))))
1345             (($ $kreceive arity k)
1346              (match (lookup-cont k dfg)
1347                (($ $kargs names vars)
1348                 (propagate! 0 k
1349                              (adjoin-vars types vars all-types-entry)))))
1350             (($ $kfun src meta self tail clause)
1351              (let ((types (adjoin-var types self all-types-entry)))
1352                (match clause
1353                  (#f #f)
1354                  (($ $cont kclause)
1355                   (propagate! 0 kclause types)))))
1356             (($ $kclause arity ($ $cont kbody ($ $kargs names vars)) alt)
1357              (propagate! 0 kbody
1358                          (adjoin-vars types vars all-types-entry))
1359              (match alt
1360                (#f #f)
1361                (($ $cont kclause)
1362                 (propagate! 1 kclause types))))
1363             (($ $ktail) #t)))
1364
1365         ;; And loop.
1366         (lp (1+ label)))
1367
1368        ;; Iterate until we reach a fixed point.
1369        (revisit-label
1370         ;; Once the types have a fixed point, iterate until ranges also
1371         ;; reach a fixed point, saturating ranges to accelerate
1372         ;; convergence.
1373         (unless types-changed?
1374           (set! saturate-ranges? #t))
1375         (set! types-changed? #f)
1376         (let ((label revisit-label))
1377           (set! revisit-label #f)
1378           ;(pk 'looping)
1379           (lp label)))
1380
1381        ;; All done!  Return the computed types.
1382        (else typev)))))
1383
1384 (define-record-type <type-analysis>
1385   (make-type-analysis min-label label-count types)
1386   type-analysis?
1387   (min-label type-analysis-min-label)
1388   (label-count type-analysis-label-count)
1389   (types type-analysis-types))
1390
1391 (define (infer-types fun dfg)
1392   ;; Fun must be renumbered.
1393   (match fun
1394     (($ $cont min-label ($ $kfun))
1395      (let ((label-count ((make-local-cont-folder label-count)
1396                          (lambda (k cont label-count) (1+ label-count))
1397                          fun 0)))
1398        (make-type-analysis min-label label-count
1399                            (infer-types* dfg min-label label-count))))))
1400
1401 (define (lookup-pre-type analysis label def)
1402   (match analysis
1403     (($ <type-analysis> min-label label-count typev)
1404      (let* ((entry (vector-ref typev (- label min-label)))
1405             (tentry (var-type-entry (vector-ref entry 0) def)))
1406        (values (type-entry-type tentry)
1407                (type-entry-min tentry)
1408                (type-entry-max tentry))))))
1409
1410 (define (lookup-post-type analysis label def succ-idx)
1411   (match analysis
1412     (($ <type-analysis> min-label label-count typev)
1413      (let* ((entry (vector-ref typev (- label min-label)))
1414             (tentry (var-type-entry (vector-ref entry (1+ succ-idx)) def)))
1415        (values (type-entry-type tentry)
1416                (type-entry-min tentry)
1417                (type-entry-max tentry))))))
1418
1419 (define (primcall-types-check? analysis label name args)
1420   (match (hashq-ref *type-checkers* name)
1421     (#f #f)
1422     (checker
1423      (match analysis
1424        (($ <type-analysis> min-label label-count typev)
1425         (let ((entry (vector-ref typev (- label min-label))))
1426           (apply checker (vector-ref entry 0) args)))))))