From 87a53159dd3d69a6f9bbbe8fef543a966e6015ce Mon Sep 17 00:00:00 2001
From: Vincent St-Amour <stamourv@racket-lang.org>
Date: Wed, 11 Jan 2012 18:24:03 -0500
Subject: [PATCH] Union types instead of clobbering them in the type table.

This fixes a bug where only the last branch of a case-> type would get stored.
---
 .../optimizer/tests/case-arrow.rkt            | 24 +++++++++++++++++++
 collects/typed-racket/types/type-table.rkt    | 20 ++++++++++++++--
 2 files changed, 42 insertions(+), 2 deletions(-)
 create mode 100644 collects/tests/typed-racket/optimizer/tests/case-arrow.rkt

diff --git a/collects/tests/typed-racket/optimizer/tests/case-arrow.rkt b/collects/tests/typed-racket/optimizer/tests/case-arrow.rkt
new file mode 100644
index 0000000000..50ce7bf603
--- /dev/null
+++ b/collects/tests/typed-racket/optimizer/tests/case-arrow.rkt
@@ -0,0 +1,24 @@
+#;
+(
+TR missed opt: case-arrow.rkt 21:2 (+ min (/ (* (- max min) x) p)) -- exact ops inside float expr -- caused by: 21:15 (- max min) (3 times)
+TR missed opt: case-arrow.rkt 21:2 (+ min (/ (* (- max min) x) p)) -- all args float-arg-expr, result not Float -- caused by: 21:5 min, 21:18 max, 21:22 min, 21:27 x, 21:30 p (4 times)
+)
+#lang typed/racket
+
+;; Typechecking functions with case-> types causes the body to be typechecked
+;; multiple times, which is fine, except that it used to cause the type table
+;; to only have information for the last branch (clobbering). This would cause
+;; this program to be optimized, which is not safe.
+
+(define p (- (expt 2 31) 1))
+(define A (expt 7 5))
+(define x 42)
+
+(: gen-random : (case-> (Integer Integer → Exact-Rational)
+                        (Float   Float   → Float)))
+(define (gen-random min max)
+  (set! x (modulo (* A x) p))
+  (+ min (/ (* (- max min) x) p)))
+
+(void (gen-random 2.3 7.4))
+(void (gen-random 2   7))
diff --git a/collects/typed-racket/types/type-table.rkt b/collects/typed-racket/types/type-table.rkt
index 5b19d7f860..acbab23847 100644
--- a/collects/typed-racket/types/type-table.rkt
+++ b/collects/typed-racket/types/type-table.rkt
@@ -4,7 +4,7 @@
          "../utils/utils.rkt"
          (contract-req)
          (rep type-rep object-rep)
-         (only-in (types utils) tc-results?)
+         (types utils union)
          (utils tc-utils)
          (env init-envs))
 
@@ -15,7 +15,23 @@
 
 (define (add-typeof-expr e t)
   (when (optimize?)
-    (hash-set! table e t)))
+    (hash-update! table e
+                  ;; when typechecking a case-> type, types get added for
+                  ;; the same subexpression multiple times, combine them
+                  (lambda (old)
+                    (match* (old t)
+                      [((tc-result1: old-t) (tc-result1: t-t))
+                       (ret (Un old-t t-t))]
+                      [((tc-results: old-ts) (tc-results: t-ts))
+                       ;; filters don't matter at this point, since only
+                       ;; the optimizer reads this table
+                       (unless (= (length old-ts) (length t-ts))
+                         (int-err
+                          "type table: number of values don't agree ~a ~a"
+                          old-ts t-ts))
+                       (ret (map Un old-ts t-ts))]
+                      [(_ _) t])) ; irrelevant to the optimizer, just clobber
+                  t)))
 
 (define (type-of e)
   (hash-ref table e