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

Add instrumentation for optimized struct/dc.

Browse Source
This commit is contained in:
Vincent St-Amour 2015-12-14 13:57:03 -06:00
parent bf1ba809ae
commit b8df0a38a2
1 changed files with 22 additions and 18 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

40
racket/collects/racket/contract/private/struct-dc.rkt
View File

@ -1432,24 +1432,28 @@
#:exp #:exp
;; if this is #t, when we have to avoid putting the property on here. ;; if this is #t, when we have to avoid putting the property on here.
(if (null? s-chap-code) (if (null? s-chap-code)
#`(if (pred? #,(opt/info-val opt/info)) #`(with-continuation-mark
(begin contract-continuation-mark-key #,(opt/info-blame opt/info)
#,@s-fo-code (if (pred? #,(opt/info-val opt/info))
#,(opt/info-val opt/info)) (begin
(struct/dc-error blame #,(opt/info-val opt/info) 'struct-name)) #,@s-fo-code
#`(if (and (stronger-prop-pred? #,(opt/info-val opt/info)) #,(opt/info-val opt/info))
(let ([v (stronger-prop-get #,(opt/info-val opt/info))]) (struct/dc-error blame #,(opt/info-val opt/info) 'struct-name)))
(and (eq? (vector-ref v index) free-var) ...))) #`(with-continuation-mark
#,(opt/info-val opt/info) contract-continuation-mark-key #,(opt/info-blame opt/info)
(if (pred? #,(opt/info-val opt/info)) (if (and (stronger-prop-pred? #,(opt/info-val opt/info))
(begin (let ([v (stronger-prop-get #,(opt/info-val opt/info))])
#,@s-fo-code (and (eq? (vector-ref v index) free-var) ...)))
(chaperone-struct #,(opt/info-val opt/info)
#,(opt/info-val opt/info) (if (pred? #,(opt/info-val opt/info))
#,@(reverse s-chap-code) ;; built the last backwards, so reverse it here (begin
stronger-prop-desc #,@s-fo-code
(vector free-var ...))) (chaperone-struct
(struct/dc-error #,(opt/info-blame opt/info) #,(opt/info-val opt/info) 'struct-name)))) #,(opt/info-val opt/info)
#,@(reverse s-chap-code) ;; built the last backwards, so reverse it here
stronger-prop-desc
(vector free-var ...)))
(struct/dc-error #,(opt/info-blame opt/info) #,(opt/info-val opt/info) 'struct-name)))))
#:lifts #:lifts
s-lifts s-lifts
#:superlifts #:superlifts