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

fix incorrect contract profiler marks, introduced in 308c918a

Browse Source
This commit is contained in:
Robby Findler 2016-01-18 09:54:49 -06:00
parent edd117d414
commit 0104e753e7
1 changed files with 18 additions and 15 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

29
racket/collects/racket/contract/private/arrow-higher-order.rkt
View File

@ -268,17 +268,24 @@
[(basic-unsafe-return basic-unsafe-return/result-values-assumed) [(basic-unsafe-return basic-unsafe-return/result-values-assumed)
(let () (let ()
(define (inner-stx-gen stuff assume-result-values?) (define (inner-stx-gen stuff assume-result-values?)
(define the-call/no-marks (define arg-checking-expressions
(if need-apply? (if need-apply?
#`(apply val #'(this-param ... dom-projd-args ... opt+rest-uses)
this-param ... #'(this-param ... dom-projd-args ...)))
dom-projd-args ... (define the-call/no-tail-mark
opt+rest-uses) (with-syntax ([(tmps ...) (generate-temporaries
#`(val this-param ... dom-projd-args ...))) arg-checking-expressions)])
#`(let-values ([(tmps ...)
(with-contract-continuation-mark
(cons blame neg-party)
(values #,@arg-checking-expressions))])
#,(if need-apply?
#`(apply val tmps ...)
#`(val tmps ...)))))
(define the-call (define the-call
#`(with-continuation-mark arrow:tail-contract-key #`(with-continuation-mark arrow:tail-contract-key
(list* neg-party blame-party-info #,rng-ctcs) (list* neg-party blame-party-info #,rng-ctcs)
#,the-call/no-marks)) #,the-call/no-tail-mark))
(cond (cond
[(null? (syntax-e stuff)) ;; surely there must a better way [(null? (syntax-e stuff)) ;; surely there must a better way
the-call] the-call]
@ -340,16 +347,12 @@
pre ... basic-return)))] pre ... basic-return)))]
[basic-unsafe-lambda [basic-unsafe-lambda
#'(λ basic-params #'(λ basic-params
(with-contract-continuation-mark
(cons blame neg-party)
(let () (let ()
pre ... basic-unsafe-return)))] pre ... basic-unsafe-return))]
[basic-unsafe-lambda/result-values-assumed [basic-unsafe-lambda/result-values-assumed
#'(λ basic-params #'(λ basic-params
(with-contract-continuation-mark
(cons blame neg-party)
(let () (let ()
pre ... basic-unsafe-return/result-values-assumed)))] pre ... basic-unsafe-return/result-values-assumed))]
[kwd-lambda-name (gen-id 'kwd-lambda)] [kwd-lambda-name (gen-id 'kwd-lambda)]
[kwd-lambda #`(λ kwd-lam-params [kwd-lambda #`(λ kwd-lam-params
(with-contract-continuation-mark (with-contract-continuation-mark