64 lines
1.6 KiB
Racket
64 lines
1.6 KiB
Racket
#lang racket/base
|
|
(require tests/stress
|
|
unstable/temp-c/dsl
|
|
racket/match
|
|
racket/contract)
|
|
|
|
(define (id x) x)
|
|
|
|
(define raw
|
|
id)
|
|
(define ctc
|
|
(contract (-> integer? integer?) id
|
|
'pos 'neg))
|
|
(define monitor-ctc
|
|
(contract (monitor/c (λ (x) #t) 'f
|
|
(-> integer? integer?))
|
|
id 'pos 'neg))
|
|
(define monitor-ctc+atomic
|
|
(contract (monitor/c
|
|
(let ([called? #f])
|
|
(match-lambda
|
|
[(? monitor:proj? x)
|
|
#t]
|
|
[(? monitor:call? x)
|
|
(begin0 (not called?)
|
|
(set! called? #t))]
|
|
[(? monitor:return? x)
|
|
(begin0 called?
|
|
(set! called? #f))]))
|
|
'f
|
|
(-> integer? integer?))
|
|
id 'pos 'neg))
|
|
(define dsl-ctc
|
|
(contract (with-monitor (-> integer? integer?))
|
|
id 'pos 'neg))
|
|
(define dsl-ctc+atomic
|
|
(contract (with-monitor (label 'f (-> integer? integer?))
|
|
(seq (? monitor:proj?)
|
|
(star
|
|
(seq (call 'f _)
|
|
(ret 'f _)))
|
|
; We need this to preserve prefix-closure
|
|
(opt (call 'f _))))
|
|
id 'pos 'neg))
|
|
|
|
(define-syntax-rule (stress-it x ver ...)
|
|
(let ([x* x])
|
|
(printf "Running ~a iterations\n" x*)
|
|
(stress 1
|
|
[(symbol->string 'ver)
|
|
(printf "Running ~a\n" 'ver)
|
|
(for ([i (in-range x*)])
|
|
(ver 1))]
|
|
...)))
|
|
|
|
(stress-it
|
|
(expt 10 4)
|
|
raw
|
|
ctc
|
|
monitor-ctc
|
|
monitor-ctc+atomic
|
|
dsl-ctc
|
|
dsl-ctc+atomic)
|