From fea6a0b9ae50500b37db09c4ccad6ba20c670a6e Mon Sep 17 00:00:00 2001
From: Robby Findler <robby@racket-lang.org>
Date: Fri, 16 Apr 2021 14:30:22 -0500
Subject: [PATCH] specialize or/c when its arguments are eq-contracts
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit

This commit improves the performance of or/c contracts with symbols
(or other things that the contract system compares with eq?).

For example, on the program below we halve the distance to
just writing the contract directly as a predicate.

```
 #lang racket/base
(require racket/contract/base)

(define c1 (or/c 'x 'y (integer-in 1 24)))

(define (c2 x)
  (or (eq? x 'x) (eq? x 'y)
      (and (exact-integer? x)
           (<= 1 x 24))))

(define f1
  (contract (-> c1 any)
            (λ (x) x) 'pos 'neg))

(define f2
  (contract (-> c2 any)
            (λ (x) x) 'pos 'neg))

(define (try f)
  (time
   (for ([x (in-range 1000000)])
     (f 'x) (f 'y) (f 10) (f 'x) (f 'y) (f 10)
     (f 'x) (f 'y) (f 10) (f 'x) (f 'y) (f 10)
     (f 'x) (f 'y) (f 10) (f 'x) (f 'y) (f 10)
     (f 'x) (f 'y) (f 10) (f 'x) (f 'y) (f 10)
     (f 'x) (f 'y) (f 10) (f 'x) (f 'y) (f 10))))

(try f1)
(try f2)
```

with this commit:
cpu time: 849 real time: 850 gc time: 39
cpu time: 615 real time: 616 gc time: 2

without this commit:
cpu time: 1020 real time: 1021 gc time: 37
cpu time: 616 real time: 617 gc time: 2
---
 .../tests/racket/contract/or-and.rkt          | 36 +++++++++++++++
 .../collects/racket/contract/private/orc.rkt  | 46 ++++++++++++++++---
 2 files changed, 75 insertions(+), 7 deletions(-)

diff --git a/pkgs/racket-test/tests/racket/contract/or-and.rkt b/pkgs/racket-test/tests/racket/contract/or-and.rkt
index 80553d65e0..754013ebcb 100644
--- a/pkgs/racket-test/tests/racket/contract/or-and.rkt
+++ b/pkgs/racket-test/tests/racket/contract/or-and.rkt
@@ -79,6 +79,42 @@
   (test/spec-passed
    'or/c14
    '(contract (or/c not) #f 'pos 'neg))
+
+  (test/spec-passed
+   'or/c15
+   '(contract (or/c 'x 'y 1 2) 'x 'pos 'neg))
+
+  (test/spec-passed
+   'or/c16
+   '(contract (or/c 'x 'y 1 2) 'y 'pos 'neg))
+
+  (test/spec-passed
+   'or/c17
+   '(contract (or/c 'x 'y 1 2) 1 'pos 'neg))
+
+  (test/spec-passed
+   'or/c18
+   '(contract (or/c 'x 'y 1 2) 1 'pos 'neg))
+
+  (test/spec-passed
+   'or/c19
+   '(contract (or/c 'x 'y 1 2) 1.0 'pos 'neg))
+
+  (test/spec-passed
+   'or/c20
+   '(contract (or/c 'x 'y 1 2) 2 'pos 'neg))
+
+  (test/spec-passed
+   'or/c21
+   '(contract (or/c 'x 'y 1 2) 2.0 'pos 'neg))
+
+  (test/pos-blame
+   'or/c22
+   '(contract (or/c 'x 'y 1 2) 'z 'pos 'neg))
+
+  (test/pos-blame
+   'or/c23
+   '(contract (or/c 'x 'y 1 2) 3 'pos 'neg))
   
   (test/spec-passed/result
    'or/c-not-error-early
diff --git a/racket/collects/racket/contract/private/orc.rkt b/racket/collects/racket/contract/private/orc.rkt
index ded8f2d837..72fed9cda1 100644
--- a/racket/collects/racket/contract/private/orc.rkt
+++ b/racket/collects/racket/contract/private/orc.rkt
@@ -74,14 +74,46 @@
   (cond
     [(null? flat-contracts) not]
     [else
-     (let loop ([fst (car flat-contracts)]
-                [rst (cdr flat-contracts)])
-       (let ([fst-pred (flat-contract-predicate fst)])
+     (define-values (eqables noneqables)
+       (let loop ([flat-contracts flat-contracts])
          (cond
-           [(null? rst) fst-pred]
-           [else 
-            (let ([r (loop (car rst) (cdr rst))])
-              (λ (x) (or (fst-pred x) (r x))))])))]))
+           [(null? flat-contracts)
+            (values '() '())]
+           [else
+            (define fst (car flat-contracts))
+            (define-values (eqables noneqables)
+              (loop (cdr flat-contracts)))
+            (cond
+              [(eq-contract? fst)
+               (values (cons fst eqables) noneqables)]
+              [else
+               (values eqables (cons fst noneqables))])])))
+
+     (define eqables-pred
+       (cond
+         [(pair? eqables)
+          (define vals (map eq-contract-val eqables))
+          (λ (x) (and (memq x vals) #t))]
+         [else #f]))
+     (define noneqables-pred
+       (cond
+         [(pair? noneqables)
+          (let loop ([fst (car noneqables)]
+                     [rst (cdr noneqables)])
+            (define fst-pred (flat-contract-predicate fst))
+            (cond
+              [(null? rst) fst-pred]
+              [else
+               (define r (loop (car rst) (cdr rst)))
+               (λ (x)
+                 (or (fst-pred x) (r x)))]))]
+         [else #f]))
+     (cond
+       [(and eqables-pred noneqables-pred)
+        (λ (x) (or (eqables-pred x) (noneqables-pred x)))]
+       [eqables-pred eqables-pred]
+       [noneqables-pred noneqables-pred]
+       [else (error 'ack.orc.rkt)])]))
 
 (define (single-or/c-late-neg-projection ctc)
   (define c-proj (get/build-late-neg-projection (single-or/c-ho-ctc ctc)))