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

defeats the inlining optimization by making procedure bodies big in order to do lazy contract checking

Browse Source 
svn: r2486
This commit is contained in:
Robby Findler 2006-03-22 21:12:53 +00:00
parent ab80f98943
commit 8617ca8fcd
3 changed files with 38 additions and 3 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

15
collects/mzlib/private/contract-ds-helpers.ss
View File

@ -29,7 +29,7 @@ expands into procedures & structs like this:
which are then called when the contract's fields are explored
|#
(define (build-clauses name coerce-contract stx clauses)
(let* ([field-names
(map (λ (clause)
@ -40,7 +40,15 @@ which are then called when the contract's fields are explored
stx
clause)]))
(syntax->list clauses))]
[all-ac-ids (generate-temporaries field-names)])
[all-ac-ids (generate-temporaries field-names)]
[defeat-inlining
;; makes the procedure "big enough" so
;; that inlining doesn't consider it.
(λ (e)
(let loop ([i 16])
(cond
[(zero? i) e]
[else #`(values #,(loop (- i 1)))])))])
(let loop ([clauses (syntax->list clauses)]
[ac-ids all-ac-ids]
[prior-ac-ids '()]
@ -58,7 +66,8 @@ which are then called when the contract's fields are explored
(let ([maker-arg #`(λ #,(match-up (reverse prior-ac-ids)
(syntax (x ...))
field-names)
(#,coerce-contract #,name ctc-exp))])
#,(defeat-inlining
#`(#,coerce-contract #,name ctc-exp)))])
(loop (cdr clauses)
(cdr ac-ids)
(cons (car ac-ids) prior-ac-ids)

9
collects/mzlib/private/contract-ds.ss
View File

@ -48,6 +48,15 @@
[wrap-name (string->symbol (format "~a/lazy-contract" (syntax-e (syntax name))))])
#`
(begin
;; `declare' future bindings for the top-level (so that everyone picks them up)
#,@(if (eq? (syntax-local-context) 'top-level)
(list
(syntax
(define-syntaxes (contract-type contract-maker contract-predicate contract-get contract-set)
(values))))
(list))
(define-values (wrap-type wrap-maker wrap-predicate wrap-get wrap-set)
(make-struct-type 'wrap-name
#f ;; super struct

17
collects/tests/mzscheme/contract-test.ss
View File

@ -3521,6 +3521,19 @@
(couple-hd (contract c1 y 'pos 'neg))))
1)
;; make sure that define-contract-struct contracts can go at the top level
(test/spec-passed
'd-c-s37
'(parameterize ([current-namespace (make-namespace)])
(eval '(require (lib "contract.ss")))
(eval '(define-contract-struct couple (hd tl)))
(eval '(contract-stronger?
(couple/dc [hd any/c]
[tl (hd) any/c])
(couple/dc [hd any/c]
[tl (hd) any/c])))))
;; test the predicate
(let ()
(define-contract-struct couple (hd tl))
@ -3926,6 +3939,10 @@
(test #f contract-stronger? (couple/c (>=/c 2) (>=/c 3)) (couple/c (>=/c 4) (>=/c 5)))
(test #t contract-stronger? (couple/c (>=/c 4) (>=/c 5)) (couple/c (>=/c 2) (>=/c 3)))
(test #f contract-stronger? (couple/c (>=/c 1) (>=/c 5)) (couple/c (>=/c 5) (>=/c 1)))
(let ([ctc (couple/dc [hd any/c] [tl (hd) any/c])])
(test #t contract-stronger? ctc ctc))
(let ([ctc (couple/dc [hd any/c] [tl (hd) (<=/c hd)])])
(test #t contract-stronger? ctc ctc))
(test #t contract-stronger? list-of-numbers list-of-numbers)
(test #t contract-stronger? (short-list/less-than 4) (short-list/less-than 5))
(test #f contract-stronger? (short-list/less-than 5) (short-list/less-than 4))