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

fixed performance problem with (provide/contract (struct ...))

Browse Source 
svn: r3698
This commit is contained in:
Robby Findler 2006-07-13 14:49:12 +00:00
parent 2c0e67caa7
commit 6575c9c58d
1 changed files with 33 additions and 16 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

47
collects/mzlib/private/contract.ss
View File

@ -456,22 +456,12 @@ add struct contracts for immutable structs?
mutator-codes ... mutator-codes ...
predicate-code predicate-code
constructor-code constructor-code
;; expanding out the body of the `make-pc-struct-type' function
;; directly here in the expansion makes this very expensive at compile time
;; when there are a lot of provide/contract clause using structs
(define -struct:struct-name (define -struct:struct-name
(let-values ([(struct:struct-name _make _pred _get _set) (make-pc-struct-type 'struct-name struct:struct-name field-contract-ids ...))
(make-struct-type 'struct-name
struct:struct-name
0 ;; init
0 ;; auto
#f ;; auto-v
'() ;; props
#f ;; inspector
#f ;; proc-spec
'
() ;; immutable-k-list
(λ (selector-ids ... ignore)
(values (-contract field-contract-ids selector-ids 'not-enough-info-for-blame 'not-enough-info-for-blame)
...)))])
struct:struct-name))
(provide (rename -struct:struct-name struct:struct-name))))))))) (provide (rename -struct:struct-name struct:struct-name)))))))))
(define (map/count f . ls) (define (map/count f . ls)
@ -600,6 +590,33 @@ add struct contracts for immutable structs?
bodies ...))))])) bodies ...))))]))
(define (make-pc-struct-type struct-name struct:struct-name . ctcs)
(let-values ([(struct:struct-name _make _pred _get _set)
(make-struct-type struct-name
struct:struct-name
0 ;; init
0 ;; auto
#f ;; auto-v
'() ;; props
#f ;; inspector
#f ;; proc-spec
'() ;; immutable-k-list
(λ args
(let ([vals (let loop ([args args])
(cond
[(null? args) null]
[(null? (cdr args)) null]
[else (cons (car args) (loop (cdr args)))]))])
(apply values
(map (λ (ctc val)
(-contract ctc
val
'not-enough-info-for-blame
'not-enough-info-for-blame))
ctcs
vals)))))])
struct:struct-name))
(define (test-proc/flat-contract f x) (define (test-proc/flat-contract f x)
(if (flat-contract? f) (if (flat-contract? f)
((flat-contract-predicate f) x) ((flat-contract-predicate f) x)