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

improve performance of define-generic-created contracts and port to late-neg

Browse Source 
This program runs about 10x faster than it did before this commit, but
seems to still be about 100x slower than the version where you change
an-s to just be (s).

  #lang racket/base
  (require racket/contract/base racket/generic)
  (define-generics id [m id x])
  (struct s () #:methods gen:id [(define (m g x) x)])
  (define an-s
    (contract (id/c [m (-> any/c integer? integer?)])
              (s)
              'pos 'neg))
  (time
   (for ([x (in-range 100000)])
     (m an-s 2)))
This commit is contained in:
Robby Findler 2015-12-30 14:44:01 -06:00
parent a97aa8389b
commit 9ee264a0ea
1 changed files with 26 additions and 21 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

47
racket/collects/racket/generic.rkt
View File

@ -271,8 +271,7 @@
(define/with-syntax pred predicate)
(define/with-syntax [ctc-id ...]
(generate-temporaries #'(ctc-expr ...)))
(define/with-syntax [proj-id ...]
(generate-temporaries #'(ctc-expr ...)))
(define/with-syntax (late-neg-proj-id ...) (generate-temporaries #'(ctc-expr ...)))
#'(let* ([ctc-id ctc-expr] ...)
(make-generics-contract
'gen-name
@ -280,19 +279,21 @@
pred
'(method-id ...)
(list ctc-id ...)
(lambda (b x mode)
(redirect-generics/derived
original
mode
gen-name ref-gen-id
x
[method-id
(lambda (m)
(define b2
(blame-add-context b (format "method ~a" 'method-id)))
(((contract-projection ctc-id) b2) m))]
...
null)))))]))
(λ (mode late-neg-proj-id ...)
(λ (x neg-party)
(redirect-generics/derived
original
mode
gen-name ref-gen-id
x
[method-id
(lambda (m)
(late-neg-proj-id m neg-party))]
...
null))))))]))
(define (blame-add-method-context blame method-id)
(blame-add-context blame (format "method ~a" method-id)))
(define (make-generics-contract ifc pfx pred mths ctcs proc)
(define chaperoning?
@ -320,22 +321,26 @@
(define (generics-contract-first-order ctc)
(generics-contract-predicate ctc))
(define (generics-contract-projection mode)
(define (generics-late-neg-contract-projection mode)
(lambda (c)
(lambda (b)
(lambda (x)
((generics-contract-redirect c) b x mode)))))
(define mk-late-neg-projs (map contract-late-neg-projection (generics-contract-contracts c)))
(lambda (blame)
(define late-neg-projs
(for/list ([m (in-list (generics-contract-methods c))]
[mk-late-neg-proj (in-list mk-late-neg-projs)])
(mk-late-neg-proj (blame-add-method-context blame m))))
(apply (generics-contract-redirect c) mode late-neg-projs))))
(struct chaperone-generics-contract generics-contract []
#:property prop:chaperone-contract
(build-chaperone-contract-property
#:name generics-contract-name
#:first-order generics-contract-first-order
#:projection (generics-contract-projection #t)))
#:late-neg-projection (generics-late-neg-contract-projection #t)))
(struct impersonator-generics-contract generics-contract []
#:property prop:contract
(build-contract-property
#:name generics-contract-name
#:first-order generics-contract-first-order
#:projection (generics-contract-projection #f)))
#:late-neg-projection (generics-late-neg-contract-projection #f)))