add some missing contract profiler wcm expressions and start a test suite for them
This commit is contained in:
Robby Findler
parent
70ab4cfb12
commit
0c31a0c0b8
102
pkgs/racket-test/tests/racket/contract/prof.rkt
Normal file
102
pkgs/racket-test/tests/racket/contract/prof.rkt
Normal file
|
|
@ -0,0 +1,102 @@
|
|||
#lang racket/base
|
||||
(require "test-util.rkt")
|
||||
|
||||
(parameterize ([current-contract-namespace
|
||||
(make-basic-contract-namespace
|
||||
'racket/contract)])
|
||||
|
||||
(contract-eval
|
||||
'(module prof-fun racket/base
|
||||
(require (only-in racket/contract/private/guts
|
||||
contract-continuation-mark-key)
|
||||
(only-in racket/contract/private/blame
|
||||
blame-positive
|
||||
blame-negative
|
||||
blame?))
|
||||
(provide pos-blame? neg-blame? named-blame?)
|
||||
(define (named-blame? who)
|
||||
(define mark-info
|
||||
(continuation-mark-set-first
|
||||
(current-continuation-marks)
|
||||
contract-continuation-mark-key))
|
||||
(define (get-party selector)
|
||||
(and mark-info
|
||||
(or (selector (car mark-info))
|
||||
(cdr mark-info))))
|
||||
(and mark-info
|
||||
(let ([pos (get-party blame-positive)]
|
||||
[neg (get-party blame-negative)])
|
||||
(or (equal? pos who)
|
||||
(equal? neg who)))))
|
||||
(define (pos-blame? _) (named-blame? 'pos))
|
||||
(define (neg-blame? _) (named-blame? 'neg))))
|
||||
|
||||
(contract-eval '(require 'prof-fun))
|
||||
|
||||
(test/spec-passed
|
||||
'provide/contract1
|
||||
'((contract (-> neg-blame? any/c) (λ (x) x) 'pos 'neg) 1))
|
||||
|
||||
(test/spec-passed
|
||||
'provide/contract2
|
||||
'((contract (-> any/c pos-blame?) (λ (x) x) 'pos 'neg) 1))
|
||||
|
||||
(test/spec-passed
|
||||
'provide/contract3
|
||||
'(contract (vector/c pos-blame?) (vector 1) 'pos 'neg))
|
||||
|
||||
(test/spec-passed
|
||||
'provide/contract4
|
||||
'((contract (parameter/c pos-blame?) (make-parameter #f) 'pos 'neg)))
|
||||
|
||||
(test/spec-passed
|
||||
'provide/contract5
|
||||
'(contract (unconstrained-domain-> pos-blame?) (λ () 1) 'pos 'neg))
|
||||
|
||||
(test/spec-passed
|
||||
'provide/contract6
|
||||
'(contract (->* () #:pre neg-blame? any) (λ () 1) 'pos 'neg))
|
||||
|
||||
(test/spec-passed
|
||||
'provide/contract7
|
||||
'(contract (->* () any/c #:post pos-blame?) (λ () 1) 'pos 'neg))
|
||||
|
||||
(test/spec-passed/result
|
||||
'provide/contract8
|
||||
'(let ()
|
||||
(eval '(module prof1 racket/base
|
||||
(require racket/contract 'prof-fun)
|
||||
(define (f x) x)
|
||||
(define a-contract (-> (λ _ (named-blame? 'prof1)) any/c))
|
||||
(provide
|
||||
(contract-out
|
||||
[f a-contract]))))
|
||||
(eval '(require 'prof1))
|
||||
(eval '(f 11)))
|
||||
11)
|
||||
|
||||
(test/spec-passed/result
|
||||
'provide/contract9
|
||||
'(let ()
|
||||
(eval '(module prof2 racket/base
|
||||
(require racket/contract 'prof-fun)
|
||||
(define (f x) x)
|
||||
(provide
|
||||
(contract-out
|
||||
[f (-> (λ _ (named-blame? 'prof2)) any/c)]))))
|
||||
(eval '(require 'prof2))
|
||||
(eval '(f 11)))
|
||||
11)
|
||||
|
||||
(test/spec-passed/result
|
||||
'provide/contract10
|
||||
'(let ()
|
||||
(eval '(module prof3 racket/base
|
||||
(require racket/contract 'prof-fun)
|
||||
(define (f #:x x) x)
|
||||
(provide
|
||||
(contract-out
|
||||
[f (-> #:x (λ _ (named-blame? 'prof3)) any/c)]))))
|
||||
(eval '(require 'prof3))
|
||||
(eval '(f #:x 11)))
|
||||
11))
|
||||
|
|
@ -59,16 +59,20 @@
|
|||
|
||||
|
||||
(define (check-pre-cond pre blame neg-party val)
|
||||
(unless (pre)
|
||||
(raise-blame-error (blame-swap blame)
|
||||
#:missing-party neg-party
|
||||
val "#:pre condition")))
|
||||
(with-continuation-mark contract-continuation-mark-key
|
||||
(cons blame neg-party)
|
||||
(unless (pre)
|
||||
(raise-blame-error (blame-swap blame)
|
||||
#:missing-party neg-party
|
||||
val "#:pre condition"))))
|
||||
|
||||
(define (check-post-cond post blame neg-party val)
|
||||
(unless (post)
|
||||
(raise-blame-error blame
|
||||
#:missing-party neg-party
|
||||
val "#:post condition")))
|
||||
(with-continuation-mark contract-continuation-mark-key
|
||||
(cons blame neg-party)
|
||||
(unless (post)
|
||||
(raise-blame-error blame
|
||||
#:missing-party neg-party
|
||||
val "#:post condition"))))
|
||||
|
||||
(define (check-pre-cond/desc post blame neg-party val)
|
||||
(handle-pre-post/desc-string #t post blame neg-party val))
|
||||
|
|
|
|||
|
|
@ -180,18 +180,29 @@
|
|||
[(res-x ...) (generate-temporaries (or rngs '()))]
|
||||
[(kwd-arg-x ...) (generate-temporaries mandatory-kwds)])
|
||||
|
||||
(define base-arg-expressions (reverse (syntax->list #'(((regb arg-x) neg-party) ...))))
|
||||
(define normal-arg-vars (generate-temporaries #'(arg-x ...)))
|
||||
(define base-arg-vars normal-arg-vars)
|
||||
|
||||
(with-syntax ([(formal-kwd-args ...)
|
||||
(apply append (map list mandatory-kwds (syntax->list #'(kwd-arg-x ...))))]
|
||||
[(kwd-arg-exps ...)
|
||||
(apply append (map (λ (kwd kwd-arg-x kb)
|
||||
(list kwd #`((#,kb #,kwd-arg-x) neg-party)))
|
||||
mandatory-kwds
|
||||
(syntax->list #'(kwd-arg-x ...))
|
||||
(syntax->list #'(kb ...))))]
|
||||
(apply
|
||||
append
|
||||
(map (λ (kwd kwd-arg-x kb)
|
||||
(set! base-arg-expressions
|
||||
(cons #`((#,kb #,kwd-arg-x) neg-party)
|
||||
base-arg-expressions))
|
||||
(set! base-arg-vars (cons (car (generate-temporaries (list kwd-arg-x)))
|
||||
base-arg-vars))
|
||||
(list kwd (car base-arg-vars)))
|
||||
mandatory-kwds
|
||||
(syntax->list #'(kwd-arg-x ...))
|
||||
(syntax->list #'(kb ...))))]
|
||||
[(letrec-bound-id) (generate-temporaries '(f))])
|
||||
|
||||
(with-syntax ([(wrapper-args ...) #'(neg-party arg-x ... formal-kwd-args ...)]
|
||||
[(the-call ...) #'(f ((regb arg-x) neg-party) ... kwd-arg-exps ...)]
|
||||
[(the-call ...) #`(f #,@(reverse normal-arg-vars) kwd-arg-exps ...)]
|
||||
[(pre-check ...)
|
||||
(if pre
|
||||
(list #`(check-pre-cond #,pre blame neg-party f))
|
||||
|
|
@ -211,46 +222,70 @@
|
|||
(let loop ([optional-args (reverse optional-args)]
|
||||
[ob (reverse (syntax->list #'(optb ...)))]
|
||||
[first? #t])
|
||||
(define args-expressions base-arg-expressions)
|
||||
(define args-vars base-arg-vars)
|
||||
(define no-rest-call
|
||||
#`(the-call ... #,@(for/list ([ob (in-list (reverse ob))]
|
||||
[optional-arg (in-list (reverse optional-args))])
|
||||
#`((#,ob #,optional-arg) neg-party))))
|
||||
#`(the-call ...
|
||||
#,@(for/list ([ob (in-list (reverse ob))]
|
||||
[optional-arg (in-list (reverse optional-args))])
|
||||
(set! args-expressions
|
||||
(cons #`((#,ob #,optional-arg) neg-party)
|
||||
args-expressions))
|
||||
(set! args-vars
|
||||
(cons (car (generate-temporaries (list optional-arg)))
|
||||
args-vars))
|
||||
(car args-vars))))
|
||||
(define full-call
|
||||
(if (and first? rest)
|
||||
#`(apply #,@no-rest-call ((restb rest-arg) neg-party))
|
||||
no-rest-call))
|
||||
(cond
|
||||
[(and first? rest)
|
||||
(set! args-expressions (cons #'((restb rest-arg) neg-party) args-expressions))
|
||||
(set! args-vars (cons (car (generate-temporaries '(rest-args-arrow-contract)))
|
||||
args-vars))
|
||||
#`(apply #,@no-rest-call #,(car args-vars))]
|
||||
[else
|
||||
no-rest-call]))
|
||||
(define the-args #`(wrapper-args ...
|
||||
#,@(reverse optional-args)
|
||||
#,@(if (and first? rest)
|
||||
#'rest-arg
|
||||
'())))
|
||||
(define let-values-clause
|
||||
#`[#,(reverse args-vars)
|
||||
(with-continuation-mark contract-continuation-mark-key
|
||||
(cons blame neg-party)
|
||||
(values #,@(reverse args-expressions)))])
|
||||
|
||||
(define the-clause
|
||||
(if rngs
|
||||
#`[#,the-args
|
||||
pre-check ...
|
||||
(define-values (failed res-x ...)
|
||||
(call-with-values
|
||||
(λ () #,full-call)
|
||||
(λ () (let-values (#,let-values-clause)
|
||||
#,full-call))
|
||||
(case-lambda
|
||||
[(res-x ...)
|
||||
(values #f res-x ...)]
|
||||
[args
|
||||
(values args #,@(map (λ (x) #'#f)
|
||||
(syntax->list #'(res-x ...))))])))
|
||||
(cond
|
||||
[failed
|
||||
(wrong-number-of-results-blame
|
||||
blame neg-party f
|
||||
failed
|
||||
#,(length
|
||||
(syntax->list
|
||||
#'(res-x ...))))]
|
||||
[else
|
||||
post-check ...
|
||||
(values ((rb res-x) neg-party) ...)])]
|
||||
(with-continuation-mark contract-continuation-mark-key
|
||||
(cons blame neg-party)
|
||||
(cond
|
||||
[failed
|
||||
(wrong-number-of-results-blame
|
||||
blame neg-party f
|
||||
failed
|
||||
#,(length
|
||||
(syntax->list
|
||||
#'(res-x ...))))]
|
||||
[else
|
||||
post-check ...
|
||||
(values ((rb res-x) neg-party) ...)]))]
|
||||
#`[#,the-args
|
||||
pre-check ...
|
||||
#,full-call]))
|
||||
(let-values (#,let-values-clause)
|
||||
#,full-call)]))
|
||||
(cons the-clause
|
||||
(cond
|
||||
[(null? optional-args) '()]
|
||||
|
|
|
|||
|
|
@ -1493,8 +1493,13 @@
|
|||
[out-proc (contract-projection (parameter/c-out ctc))])
|
||||
(λ (blame)
|
||||
(define blame/c (blame-add-context blame "the parameter of"))
|
||||
(define partial-neg-contract (in-proc (blame-swap blame/c)))
|
||||
(define partial-pos-contract (out-proc blame/c))
|
||||
(define (add-profiling f)
|
||||
(λ (x)
|
||||
(with-continuation-mark contract-continuation-mark-key
|
||||
(cons blame #f)
|
||||
(f x))))
|
||||
(define partial-neg-contract (add-profiling (in-proc (blame-swap blame/c))))
|
||||
(define partial-pos-contract (add-profiling (out-proc blame/c)))
|
||||
(λ (val)
|
||||
(cond
|
||||
[(parameter? val)
|
||||
|
|
@ -1515,11 +1520,16 @@
|
|||
(cond
|
||||
[(parameter? val)
|
||||
(λ (neg-party)
|
||||
(define (add-profiling f)
|
||||
(λ (x)
|
||||
(with-continuation-mark contract-continuation-mark-key
|
||||
(cons blame neg-party)
|
||||
(f x))))
|
||||
(make-derived-parameter
|
||||
val
|
||||
;; unfortunately expensive
|
||||
(in-proc (blame-add-missing-party swapped neg-party))
|
||||
(out-proc (blame-add-missing-party blame/c neg-party))))]
|
||||
(add-profiling (in-proc (blame-add-missing-party swapped neg-party)))
|
||||
(add-profiling (out-proc (blame-add-missing-party blame/c neg-party)))))]
|
||||
[else
|
||||
(λ (neg-party)
|
||||
(raise-blame-error blame #:missing-party neg-party
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user