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
;; if this is #t, when we have to avoid putting the property on here.
(if (null? s-chap-code)
#`(if (pred? #,(opt/info-val opt/info))
(begin
#,@s-fo-code
#,(opt/info-val opt/info))
(struct/dc-error blame #,(opt/info-val opt/info) 'struct-name))
#`(if (and (stronger-prop-pred? #,(opt/info-val opt/info))
(let ([v (stronger-prop-get #,(opt/info-val opt/info))])
(and (eq? (vector-ref v index) free-var) ...)))
#,(opt/info-val opt/info)
(if (pred? #,(opt/info-val opt/info))
(begin
#,@s-fo-code
(chaperone-struct
#,(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))))
#`(with-continuation-mark
contract-continuation-mark-key #,(opt/info-blame opt/info)
(if (pred? #,(opt/info-val opt/info))
(begin
#,@s-fo-code
#,(opt/info-val opt/info))
(struct/dc-error blame #,(opt/info-val opt/info) 'struct-name)))
#`(with-continuation-mark
contract-continuation-mark-key #,(opt/info-blame opt/info)
(if (and (stronger-prop-pred? #,(opt/info-val opt/info))
(let ([v (stronger-prop-get #,(opt/info-val opt/info))])
(and (eq? (vector-ref v index) free-var) ...)))
#,(opt/info-val opt/info)
(if (pred? #,(opt/info-val opt/info))
(begin
#,@s-fo-code
(chaperone-struct
#,(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
s-lifts
#:superlifts