Randomized tests for the delimited control model.

Tests in randomized-tests.rkt are deliberately not run by DrDr at the
moment because they fail too consistently.

collects/meta/props

@@ -1198,6 +1198,8 @@ path/s is either such a string or a list of them.
 "collects/redex/examples/church.rkt" drdr:command-line (mzc *)
 "collects/redex/examples/combinators.rkt" drdr:command-line (mzc *)
 "collects/redex/examples/compatible-closure.rkt" drdr:command-line (mzc *)
+"collects/redex/examples/delim-cont/randomized-tests-test.rkt" drdr:timeout 120 drdr:random #t
+"collects/redex/examples/delim-cont/randomized-tests.rkt" drdr:random #t
 "collects/redex/examples/delim-cont/test.rkt" drdr:command-line (mzc *)
 "collects/redex/examples/letrec.rkt" drdr:command-line (mzc *)
 "collects/redex/examples/omega.rkt" drdr:command-line (mzc *)

collects/redex/examples/delim-cont/model-impl.rkt

@@ -0,0 +1,76 @@
+#lang racket
+
+(provide % abort call/comp call/cm current-marks
+         (rename-out [_call/cc call/cc]
+                     [_if if] 
+                     [_+ +]
+                     [_print print]
+                     [_cons cons]
+                     [_set! set!]
+                     [_zero? zero?]))
+
+(define tag
+  (let ([tags (make-hash)])
+    (λ (v)
+      (hash-ref tags v 
+                (λ ()
+                  (let ([t (make-continuation-prompt-tag)])
+                    (hash-set! tags v t)
+                    t))))))
+
+(define-syntax-rule (% tag-val expr handler)
+  (call-with-continuation-prompt 
+   (λ () expr)
+   (let ([v tag-val])
+     (if (let comparable? ([v v])
+           (cond [(procedure? v) #f]
+                 [(list? v) (andmap comparable? v)]
+                 [else #t]))
+         (tag v)
+         (raise-type-error '% "non-procedure" v)))
+   (let ([h handler])
+     (λ (x) (h x)))))
+
+(define (abort tag-val result) 
+  (abort-current-continuation (tag tag-val) result))
+
+(define ((force-unary f) x) (f x))
+
+(define (_call/cc proc tag-val)
+  (call/cc (compose proc force-unary) (tag tag-val)))
+
+(define (call/comp proc tag-val) 
+  (call-with-composable-continuation (compose proc force-unary) (tag tag-val)))
+
+(define (call/cm key val thunk)
+  (with-continuation-mark key val (thunk)))
+
+(define (current-marks key tag-val)
+  (continuation-mark-set->list 
+   (current-continuation-marks (tag tag-val))
+   key))
+
+(define-syntax-rule (_if e1 e2 e3)
+  (let ([v1 e1])
+    (case v1
+      [(#t) e2]
+      [(#f) e3]
+      [else (raise-type-error 'if "#t or #f" v1)])))
+
+(define (_+ x y) (+ x y))
+
+(define (_print n)
+  (if (number? n)
+      (begin (print n) #f)
+      (raise-type-error 'print "number" n)))
+
+(define (_cons x xs)
+  (if (list? xs)
+      (cons x xs)
+      (raise-type-error 'cons "list?" 1 x xs)))
+
+(define-syntax-rule (_set! x e)
+  (begin (set! x e) #f))
+
+(define (_zero? x)
+  (equal? 0 x))

collects/redex/examples/delim-cont/randomized-tests-test.rkt

@@ -0,0 +1,147 @@
+#lang racket
+
+(require "randomized-tests.rkt"
+         "reduce.rkt"
+         "grammar.rkt"
+         rackunit
+         (except-in redex/reduction-semantics plug))
+
+(define-syntax (test-transformation stx)
+  (syntax-case stx ()
+    [(_ program expected-output expected-result)
+     #`(match-let ([(answer actual-output actual-result)
+                    (model-eval (transform-intermediate (term program)))])
+         (begin
+           #,(syntax/loc #'expected-output
+               (check-equal? actual-output expected-output))
+           #,(syntax/loc #'expected-result
+               (check-equal? actual-result 'expected-result))))]))
+
+(test-transformation
+ (<> ()
+     ()
+     (% 0
+        (wcm ()
+             ((λ (k)
+                (begin (k 7) (print 1)))
+              (cont 0 hole)))
+        (λ (x) x)))
+ "" 7)
+
+(test-transformation
+ (<> ()
+        ()
+        (cont 1 (begin hole (print 3))))
+ "" procedure)
+
+(test-transformation
+ (<> ()
+     ()
+     (% 0
+        (print
+         (wcm ()
+              ((λ (k) (begin (k 1) 2))
+               (comp (print hole)))))
+        (λ (x) x)))
+ "12" #f)
+
+(test-transformation
+ (<> ()
+     (1)
+     (% 1
+        (dw 
+         x_1
+         (print 1)
+         (wcm ()
+              ((λ (k) (k 3))
+               (cont 1 (dw x_1 (print 1) hole (print 2)))))
+         (print 2))
+        (λ (x) x)))
+ "12" 3)
+
+(test-transformation
+ (<> ()
+     (1)
+     (% 0
+        ((% 0
+            (dw
+             x_1
+             (print 1)
+             (wcm ()
+                  ((λ (k) k)
+                   (cont 0 (dw x_1  (print 1) hole (print 2)))))
+             (print 2))
+            (λ (x) x))
+         3)
+        (λ (x) x)))
+ "1212" 3)
+
+(test-transformation
+ (<> () []
+        (% 0
+           (wcm ([1 2] [3 4])
+                ((λ (x) x)
+                 (wcm ([1 5] [3 6])
+                      (cons (current-marks 1 0)
+                            (cons (current-marks 3 0)
+                                  (list))))))
+           (λ (x) x)))
+ "" ((5 2) (6 4)))
+
+(test-transformation
+ (<>
+  ()
+  ()
+  (dw
+   ra
+   (print 1)
+   (print 2)
+   (print 3)))
+ "23" #f)
+
+(test-transformation
+ (<> ()
+     ()
+     (%
+      1
+      (dw x_1
+          (print 1)
+          (abort 1 (cont 1 (dw x_1 (print 1) hole (print 3))))
+          (print 3))
+      (λ (k) (% 1 (k 4) (λ (x) x)))))
+ "313" 4)
+
+(test-transformation
+ (<>
+  ()
+  ()
+  ((comp
+    (dw
+     ra
+     (print 1)
+     hole
+     (dw q (print 2) (print 3) (print 4))))
+   5))
+ "134" 5)
+
+(define (transformation-preserves-meaning? p)
+  (let ([original-result (parameterize ([model-eval-steps 1000]) (model-eval p))]
+        [transformed (transform-intermediate p)]
+        [warn (λ () (eprintf "Long test:\n") (pretty-write p (current-error-port)))]
+        [threshold (* 60 2)])
+    (or (timeout? original-result)
+        (let ([transformed-result 
+               (timeout-warn threshold (model-eval transformed) (warn))])
+          (if (answer? original-result)
+              (equal? original-result transformed-result)
+              (not (answer? transformed-result))))
+        ; filters bad tests
+        (bad-test? (timeout-warn threshold (impl-eval (impl-program transformed)) (warn))))))
+
+(define-syntax-rule (test-transformation/randomized . kw-args)
+  (let ([test-number 1])
+    (redex-check grammar p (transformation-preserves-meaning? (term p))
+               #:prepare fix-prog 
+               #:source :-> . kw-args)))
+
+(time (test-transformation/randomized #:attempts 1 #:attempt-size (const 3)))

collects/redex/examples/delim-cont/randomized-tests.rkt

@@ -0,0 +1,385 @@
+#lang racket
+
+(require "grammar.ss" 
+         "reduce.rkt"
+         (except-in redex/reduction-semantics plug)
+         racket/runtime-path)
+
+(provide (all-defined-out))
+
+(define (main [seed-arg #f])
+  (define seed
+    (if seed-arg 
+        (string->number seed-arg)
+        (add1 (random (sub1 (expt 2 31))))))
+  (printf "Test seed: ~s\n" seed)
+  (parameterize ([current-pseudo-random-generator test-prg])
+    (random-seed seed))
+  (parameterize ([redex-pseudo-random-generator test-prg])
+    (time (test #:attempts 3000))
+    (time (test #:source :-> #:attempts 3000))))
+
+(define-syntax-rule (test . kw-args)
+  (redex-check grammar p (same-behavior? (term p)) 
+               #:prepare fix-prog . kw-args))
+
+(define fix-prog
+  (match-lambda
+    [`(<> ,s ,_ ,e)
+     (match-let ([`([,xs ,vs] ...) (remove-duplicates s #:key first)])
+       `(<> ,(map list xs (map (fix-expr xs) vs)) [] ,((fix-expr xs) e)))]))
+
+(define (fix-expr top-vars) 
+  (compose drop-duplicate-binders
+           proper-wcms 
+           consistent-dws
+           (curry close top-vars '())))
+
+(struct error (cause) #:transparent)
+(struct answer (output result) #:transparent)
+(struct bad-test (reason) #:transparent)
+(struct timeout ())
+
+(define (same-behavior? prog)
+  (let ([impl-behavior (timeout-kill 15 (impl-eval (impl-program (transform-intermediate prog))))])
+    (or (bad-test? impl-behavior)
+        (timeout? impl-behavior)
+        (let ([model-behavior (timeout-warn 30 (model-eval prog) (pretty-write prog))])
+          (or (timeout? model-behavior)
+              (if (error? impl-behavior)
+                  (error? model-behavior)
+                  (and (answer? model-behavior)
+                       (equal? impl-behavior model-behavior))))))))
+
+(define impl-program
+  (match-lambda
+    [`(<> ,s [] ,e)
+     `(letrec ,s ,e)]
+    [e e]))
+
+(define-runtime-module-path model-impl "model-impl.rkt")
+
+(define impl-eval
+  (let ([ns (make-base-empty-namespace)])
+    (parameterize ([current-namespace ns])
+      (namespace-require 'racket)
+      (namespace-require (resolved-module-path-name model-impl)))
+    (define show
+      (match-lambda
+        [(? procedure?) 'procedure]
+        [(? list? vs) (map show vs)]
+        [v v]))
+    (λ (test)
+      (define output (open-output-string))
+      (define result
+        (with-handlers ([exn:fail? 
+                         (λ (e)
+                           (match (exn-message e)
+                             [(regexp #rx"%: expected argument of type <non-procedure>")
+                              (bad-test "procedure as tag")]
+                             [_ (error e)]))])
+          (parameterize ([current-output-port output])
+            (eval test ns))))
+      (if (or (error? result) (bad-test? result))
+          result
+          (answer (get-output-string output) 
+                  (show result))))))
+
+(define model-eval-steps (make-parameter +inf.0))
+
+(define (model-eval prog)
+  (let/ec return
+    (define show
+      (match-lambda
+        [(? number? n) n]
+        [(? boolean? b) b]
+        [`(list . ,vs) (map show vs)]
+        [v 'procedure]))
+    (define (eval prog steps)
+      (define ns (set))
+      (let recur ([p prog] [d steps] [s (set)])
+        (define qs (apply-reduction-relation :-> p))
+        (if (empty? qs)
+            (set! ns (set-add ns p))
+            (if (< d 0)
+                (return (timeout))
+                (for ([q qs])
+                     (if (set-member? s q)
+                         (return (timeout))
+                         (recur q (sub1 d) (set-add s p)))))))
+      (set-map ns values))
+    (match (eval prog (model-eval-steps))
+      [(list (and p `(<> ,_ ,output ,result)))
+       (if (v? result)
+           (answer
+            (apply string-append (map (curry format "~v") output))
+            (show result))
+           (error p))])))
+
+(define (with-timeout thunk timeout on-timeout)
+  (let ([c (make-channel)])
+    (struct raised (value))
+    (let ([t (thread
+              (λ () 
+                (channel-put 
+                 c (with-handlers ([exn:fail? raised])
+                     (thunk)))))])
+      (match (sync/timeout timeout c)
+        [#f (on-timeout t c)]
+        [(raised v) (raise v)]
+        [x x]))))
+
+(define-syntax-rule (timeout-kill time expr)
+  (with-timeout (λ () expr) time 
+                (λ (t _) 
+                  (kill-thread t)
+                  (timeout))))
+(define-syntax-rule (timeout-warn time expr warn)
+  (with-timeout (λ () expr) time
+                (λ (_ c)
+                  warn
+                  (sync c))))
+
+(define (close top-vars loc-vars expr)
+  (match expr
+    [(? x? x) 
+     (let ([bound (append top-vars loc-vars)])
+       (cond [(memq x bound) x]
+             [(not (empty? bound)) 
+              (random-member bound)]
+             [else (random-literal)]))]
+    [`(set! ,x ,e)
+     (if (empty? top-vars)
+         (close top-vars loc-vars e)
+         `(set! ,(random-member top-vars)
+                ,(close top-vars loc-vars e)))]
+    [`(λ ,xs ,e) 
+     `(λ ,xs 
+        ,(close (filter (negate (curryr member xs)) top-vars) 
+                (append xs loc-vars)
+                e))]
+    [`(dw ,x ,e_1 ,e_2 ,e_3)
+     `(dw ,x 
+          ,(close top-vars loc-vars e_1) 
+          ,(close top-vars loc-vars e_2) 
+          ,(close top-vars loc-vars e_3))]
+    ; substitution does not recur inside continuation values
+    ; (not sure why it bothers to recur within dw expression)
+    [`(cont ,v ,E)
+     `(cont ,(close top-vars '() v)
+            ,(close top-vars '() E))]
+    [`(cont ,E)
+     `(comp ,(close top-vars '() E))]
+    [(? list?)
+     (map (curry close top-vars loc-vars) expr)]
+    [_ expr]))
+
+(define drop-duplicate-binders
+  (match-lambda
+    [`(λ ,xs ,e)
+     `(λ ,(remove-duplicates xs) ,(drop-duplicate-binders e))]
+    [(? list? es)
+     (map drop-duplicate-binders es)]
+    [e e]))
+
+(define (consistent-dws p)
+  (define pre-post
+    (let ([h (make-hash)])
+      (λ (id pre post)
+        (match (hash-ref h id #f)
+          [#f
+           (hash-set! h id (list pre post))
+           (list pre post)]
+          [x x]))))
+  (let recur ([x p] [excluded '()])
+    (match x
+      [`(dw ,x ,e1 ,e2 ,e3)
+       (if (member x excluded)
+           (recur e2 excluded)
+           (match-let ([(list e1’ e3’) (pre-post x e1 e3)])
+             `(dw ,x 
+                  ,(recur e1’ (cons x excluded))
+                  ,(recur e2 excluded)
+                  ,(recur e3’ (cons x excluded)))))]
+      [(? list?) (map (curryr recur excluded) x)]
+      [_ x])))
+
+(define (proper-wcms e)
+  (let fix ([ok? #t] [e e])
+    (match e
+      [`(wcm ,w ,e)
+       (if ok? 
+           `(wcm ,(remove-duplicates (fix #t w) #:key first) 
+                 ,(fix #f e))
+           (fix #f e))]
+      [`(list . ,vs)
+       `(list . ,(map (curry fix #t) vs))]
+      [`(λ ,xs ,e)
+       ; #f in case applied with a continuation that's already marked
+       `(λ ,xs ,(fix #f e))]
+      [`(cont ,v ,E)
+       `(cont ,(fix #t v) ,(fix #t E))]
+      [`(comp ,E)
+       `(comp ,(fix #t E))]
+      [`(begin ,e1 ,e2)
+       `(begin ,(fix #t e1)
+               ,(fix ok? e2))]
+      [`(% ,e1 ,e2 ,e3)
+       `(% ,(fix #t e1) ,(fix ok? e2) ,(fix #t e3))]
+      [`(dw ,x ,e1 ,e2 ,e3)
+       `(dw ,x ,(fix #t e1) ,(fix ok? e2) ,(fix #t e3))]
+      [`(if ,e1 ,e2 ,e3)
+       `(if ,(fix #t e1) 
+            ,(fix ok? e2)
+            ,(fix ok? e3))]
+      [`(set! ,x ,e)
+       `(set! ,x ,(fix #t e))]
+      [(? list?) 
+       (map (curry fix #t) e)]
+      [_ e])))
+
+(define transform-intermediate
+  (match-lambda
+    [(and p `(<> ,s ,o ,e))
+     (define fresh (make-fresh p))
+     (define allocated (map first s))
+     (define (alloc-cell prefix)
+       (define cell (fresh prefix))
+       (set! allocated (cons cell allocated))
+       cell)
+     (define no-dw? (alloc-cell "handlers-disabled?"))
+     (define dw-frame-locs
+       (let ([locs (make-hash)])
+         (λ (x)
+           (hash-ref 
+            locs x
+            (λ () (let ([ys (list (alloc-cell (format "~s-allocated?" x))
+                                  (alloc-cell (format "~s-skip-pre?" x))
+                                  (alloc-cell (format "~s-comp-cont" x)))])
+                    (hash-set! locs x ys)
+                    ys))))))
+     (define transform
+       (match-lambda
+         [`(wcm () ,m)
+          (transform m)]
+         [`(wcm ([,k ,v] . ,w) ,m)
+          `(call/cm ,(transform k) ,(transform v)
+                    (λ () ,(transform `(wcm ,w ,m))))]
+         [(and e `(dw ,x ,e1 ,e2 ,e3))
+          (match-let ([(list a? s? c) (dw-frame-locs x)]
+                      [t (fresh "t")])
+            `((λ (,t)
+                (if ,a?
+                    (begin (if ,no-dw? #f (set! ,s? #t)) (,c ,t))
+                    (% 1
+                       (dynamic-wind
+                        (λ () 
+                          (if ,no-dw?
+                              #f
+                              (if ,a? 
+                                  (if ,s? (set! ,s? #f) ,(transform e1))
+                                  #f)))
+                        (λ ()
+                          ((call/comp 
+                            (λ (k)
+                              (begin
+                                (set! ,c k)
+                                (abort 1 k)))
+                            1)))
+                        (λ () 
+                          (if ,no-dw?
+                              (set! ,a? #t)
+                              (if ,a?
+                                  ,(transform e3)
+                                  (set! ,a? #t)))))
+                       (λ (k) (begin (if ,no-dw? #f (set! ,s? #t)) (k ,t))))))
+              (λ () ,(transform e2))))]
+         [`(cont ,v ,E)
+          (let ([x (fresh "v")])
+            `(begin
+               (set! ,no-dw? #t)
+               ((λ (,x)
+                  (% ,x 
+                     ,(transform 
+                       (term (plug ,E (call/cc (λ (k) (abort ,x k)) ,x))))
+                     (λ (x) (begin (set! ,no-dw? #f) x))))
+                ,(transform v))))]
+         [`(comp ,E)
+          (define numbers
+            (match-lambda
+              [(? integer? n) (list n)]
+              [(? list? l) (append-map numbers l)]
+              [_ (list)]))
+          (define t (add1 (apply max 0 (numbers E))))
+          `(begin
+             (set! ,no-dw? #t)
+             (% ,t 
+                ,(transform
+                  (term (plug ,E (call/comp (λ (k) (abort ,t k)) ,t))))
+                (λ (x) (begin (set! ,no-dw? #f) x))))]
+         [`(list ,vs ...)
+          `(list ,@(map transform-value vs))]
+         [(? list? xs) 
+          (map transform xs)]
+         [e e]))
+     (define transform-value
+       (match-lambda
+         [(and e (or `(cont ,_ ,_) `(comp ,_)))
+          `(λ (x) (,(transform e) x))]
+         [e (transform e)]))
+     (define e’ (transform e))
+     (define s’ (map (match-lambda [(list x v) (list x (transform-value v))]) s))
+     `(<> ,(map (λ (x) (match (assoc x s’)
+                         [#f (list x #f)]
+                         [(list _ v’) (list x v’)]))
+                allocated)
+          ,o
+          ,e’)]))
+
+;; The built-in `plug' sometimes chooses the wrong hole.
+(define-metafunction grammar
+  [(plug hole any) any]
+  [(plug (in-hole W (dw x e_1 E e_2)) any)
+   (in-hole W (dw x e_1 (plug E any) e_2))]
+  [(plug (wcm w M) any)
+   (wcm w (plug M any))]
+  [(plug (v ... W e ...) any)
+   (v ... (plug W any) e ...)] 
+  [(plug (begin W e) any)
+   (begin (plug W any) e)]
+  [(plug (% W e_1 e_2) any)
+   (% (plug W any) e_1 e_2)]
+  [(plug (% v e W) any)
+   (% v e (plug W any))]
+  [(plug (% v_1 W v_2) any)
+   (% v_1 (plug W any) v_2)]
+  [(plug (set! x W) any)
+   (set! x (plug W any))]
+  [(plug (if W e_1 e_2) any)
+   (if (plug W any) e_1 e_2)])
+
+(define (make-fresh p)
+  (define suffix
+    (let recur ([x p] [s 0])
+      (cond [(symbol? x)
+             (match (regexp-match #rx"_(.+)$" (symbol->string x))
+               [(list _ n) (max s (add1 (string->number n)))]
+               [#f s])]
+            [(pair? x) (recur (cdr x) (recur (car x) s))]
+            [else s])))
+  (λ (prefix)
+    (begin0 (string->symbol (format "~a_~a" prefix suffix))
+            (set! suffix (add1 suffix)))))
+
+(define (random-literal)
+  (random-member
+   '(dynamic-wind abort current-marks cons
+                  -inf.0 +inf.0 -1 0 1 1/3 -1/4 .33 -.25 4-3i 3+4i
+                  call/cc call/comp call/cm
+                  #f #t zero? print + first rest)))
+
+(define (random-member xs)
+  (parameterize ([current-pseudo-random-generator test-prg])
+    (list-ref xs (random (length xs)))))
+
+(define test-prg (make-pseudo-random-generator))