suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

specialize or/c when its arguments are eq-contracts

Browse Source 
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
This commit is contained in:
Robby Findler 2021-04-16 14:30:22 -05:00
parent df0c756f73
commit fea6a0b9ae
2 changed files with 75 additions and 7 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

36
pkgs/racket-test/tests/racket/contract/or-and.rkt
View File

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

46
racket/collects/racket/contract/private/orc.rkt
View File

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