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

Don't recheck DMdA lazy contracts we've already checked.

Browse Source 
We avoided re-applying contracts that haven't been checked, but not
those that have.  Do so now.
This commit is contained in:
Mike Sperber 2010-06-07 17:06:07 +02:00
parent 4c1eff839d
commit 93d7ec9446
3 changed files with 69 additions and 28 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

69
collects/deinprogramm/contract/contract.rkt
View File

@ -410,6 +410,13 @@
(define-values (prop:lazy-wrap lazy-wrap? lazy-wrap-ref)
(make-struct-type-property 'lazy-wrap))
; The field accessed by ref-proc and set!-proc contains one of these:
(define-struct lazy-wrap-log
;; each contains a list of lists; each element is a list of field contracts
(not-checked checked)
#:transparent)
(define (make-struct-wrap-contract name type-descriptor field-contracts syntax)
(let ((lazy-wrap-info (lazy-wrap-ref type-descriptor))
(struct-wrap-info (make-struct-wrap-info type-descriptor field-contracts))
@ -425,20 +432,24 @@
name
(lambda (self thing)
(cond
((not (predicate thing))
(contract-violation thing self #f #f)
thing)
((ormap (lambda (wrap-field-contracts)
(andmap contract<=?
wrap-field-contracts
field-contracts))
(wrap-ref thing))
thing)
(else
(wrap-set! thing
(cons field-contracts (wrap-ref thing)))
thing)))
(if (not (predicate thing))
(contract-violation thing self #f #f)
(let ((log (wrap-ref thing)))
(cond
((not log)
(wrap-set! thing
(make-lazy-wrap-log (list field-contracts) '())))
((not (let ((check (lambda (wrap-field-contracts)
(andmap contract<=?
wrap-field-contracts
field-contracts))))
(or (ormap check (lazy-wrap-log-not-checked log))
(ormap check (lazy-wrap-log-checked log)))))
(wrap-set! thing
(make-lazy-wrap-log (cons field-contracts (lazy-wrap-log-not-checked log))
(lazy-wrap-log-checked log)))))))
thing)
(delay syntax)
#:info-promise
(delay struct-wrap-info)
@ -471,19 +482,23 @@
(wrap-ref (lazy-wrap-info-ref-proc lazy-wrap-info))
(wrap-set! (lazy-wrap-info-set!-proc lazy-wrap-info)))
(when (pair? (wrap-ref thing)) ; fast path
(let loop ((field-vals (map (lambda (raw-accessor)
(raw-accessor thing))
raw-accessors))
(field-contracts-list (wrap-ref thing)))
(if (null? field-contracts-list)
(begin
(for-each (lambda (raw-mutator field-val)
(raw-mutator thing field-val))
raw-mutators field-vals)
(wrap-set! thing '()))
(loop (map apply-contract (car field-contracts-list) field-vals)
(cdr field-contracts-list)))))))))
(let ((log (wrap-ref thing)))
(when (and log (pair? (lazy-wrap-log-not-checked log)))
(let loop ((field-vals (map (lambda (raw-accessor)
(raw-accessor thing))
raw-accessors))
(field-contracts-list (lazy-wrap-log-not-checked log)))
(if (null? field-contracts-list)
(begin
(for-each (lambda (raw-mutator field-val)
(raw-mutator thing field-val))
raw-mutators field-vals)
(wrap-set! thing
(make-lazy-wrap-log '()
(append (lazy-wrap-log-not-checked log)
(lazy-wrap-log-checked log)))))
(loop (map apply-contract (car field-contracts-list) field-vals)
(cdr field-contracts-list))))))))))
; like apply-contract, but can track more precise blame into the contract itself
(define-syntax apply-contract/blame

2
collects/deinprogramm/define-record-procedures.scm
View File

@ -91,7 +91,7 @@
(syntax->list #'(mutator ...))))
(constructor-proc
(syntax-property #'(lambda (accessor ...)
(raw-constructor accessor ... '()))
(raw-constructor accessor ... #f))
'inferred-name
(syntax-e #'?constructor)))
(predicate-proc

26
collects/tests/deinprogramm/contract.rkt
View File

@ -282,6 +282,32 @@
(check-equal? (kdr obj) #t)
(check-equal? count 1))))
(test-case
"record-wrap-2"
(let ((count 0))
(define counting-integer
(make-predicate-contract 'counting-integer
(lambda (obj)
(set! count (+ 1 count))
(integer? obj))
'integer-marker))
(define-record-procedures-parametric pare pare-of kons pare? (kar kdr))
(define ctr (contract (pare-of counting-integer boolean)))
(let ((obj (apply-contract ctr (apply-contract ctr (kons 1 #t)))))
(check-equal? count 0)
(check-equal? (kar obj) 1)
(check-equal? count 1)
(check-equal? (kdr obj) #t)
(check-equal? count 1)
;; after checking, the system should remember that it did so
(let ((obj-2 (apply-contract ctr obj)))
(check-equal? count 1)
(check-equal? (kar obj) 1)
(check-equal? count 1)
(check-equal? (kdr obj) #t)
(check-equal? count 1)))))
(test-case
"double-wrap"
(let ((count 0))