bench-for-foldr.rkt

#lang racket/base

(require (for-syntax racket/base
                     syntax/for-body)
         benchmark
         plot
         racket/format
         racket/generator
         racket/match
         racket/stream)

(define-syntaxes (old:for/stream old:for*/stream)
  (let ()
    (define ((make-for/stream derived-stx) stx)
      (syntax-case stx ()
        [(_ clauses . body)
         (begin
           (when (null? (syntax->list #'body))
             (raise-syntax-error (syntax-e #'derived-stx)
                                 "missing body expression after sequence bindings"
                                 stx #'body))
           (with-syntax ([((pre-body ...) body*) (split-for-body stx #'body)])
             #`(sequence->stream
                (in-generator
                 (#,derived-stx #,stx () clauses
                  pre-body ...
                  (yield (let () . body*))
                  (values))))))]))
    (values (make-for/stream #'for/fold/derived)
            (make-for/stream #'for*/fold/derived))))

(define (do-run-benchmarks #:num-trials trials)
  (run-benchmarks
   #:num-trials trials
   (list 'for/list 'for/stream)
   (list (list 'loop 'for/fold 'for/foldr)
         (list 100 1000 10000))
   #:clean
   (lambda (op impl len)
     (collect-garbage)
     (collect-garbage)
     (collect-garbage))
   (lambda (op impl len)
     (define iters (/ 10000 len))
     (collect-garbage)
     (time (match op
             ['for/list
              (match impl
                ['loop
                 (for ([i (in-range (* iters 100))])
                   (let loop ([n 0])
                     (if (< n len)
                         (cons n (loop (add1 n)))
                         '())))]
                ['for/fold
                 (for ([i (in-range (* iters 100))])
                   (for/list ([n (in-range len)]) n))]
                ['for/foldr
                 (for ([i (in-range (* iters 100))])
                   (for/foldr ([lst '()]) ([n (in-range len)]) (cons n lst)))])]
             ['for/stream
              (define (go s)
                (for* ([i (in-range iters)]
                       [v (in-stream s)])
                  (void)))
              (match impl
                ['loop
                 (go (let loop ([n 0])
                       (if (< n len)
                           (stream-cons n (loop (add1 n)))
                           empty-stream)))]
                ['for/fold
                 (go (old:for/stream ([n (in-range len)]) n))]
                ['for/foldr
                 (go (for/stream ([n (in-range len)]) n))])])))))

(void (do-run-benchmarks #:num-trials 5)) ; warm
(define results (do-run-benchmarks #:num-trials 20))

(define (make-repeating-color-scheme scheme n)
  (cons (for*/list ([color (in-list (car scheme))]
                    [i (in-range n)])
          color)
        (if (list? (cdr scheme))
            (for*/list ([style (in-list (cdr scheme))]
                        [i (in-range n)])
              style)
            (cdr scheme))))

(define (render-results filename #:y-max [y-max #f] #:height [height 600])
  (parameterize ([plot-x-ticks no-ticks]
                 [plot-font-size 12]
                 [current-benchmark-color-scheme
                  (make-repeating-color-scheme black-white-color-scheme-short 3)])
    (plot-file
     #:x-label #f
     #:y-label "average normalized running time"
     #:y-max y-max
     #:width 500
     #:height height
     (render-benchmark-alts
      (list 'loop 1000)
      results
      #:format-opts (match-lambda [(list impl len) (~a impl ", size = " len)]))
     filename)))

(render-results "bench-for-foldr-full.svg" #:height 1000)
(render-results "bench-for-foldr-clamped.svg" #:y-max 3)