ca.ss

(let ([M 100]
      [N 1000000])
  (define (report step) (printf "\n~a\n" step))
  
  (report "baseline: plain loop")
  (time
   (let loop ([j 0])
     (cond
      [(= j N) 'done]
      [else
       (let loop ([i 0])
         (cond
          [(= i M) 0]
          [else (loop (add1 i))]))
       (loop (add1 j))])))

  (report "attachment loop = CA 1")
  (time
   (let loop ([j 0])
     (cond
      [(= j N) 'done]
      [else
       (let loop ([i 0])
         (cond
          [(= i M) 0]
          [else (call-setting-continuation-attachment
                 i
                 (lambda ()
                   (loop (add1 i))))]))
       (loop (add1 j))])))

  (report "deep attachment = CA 2")
  (time
   (let loop ([j 0])
     (cond
      [(= j N) 'done]
      [else
       (let loop ([i 0])
         (cond
          [(= i M) 0]
          [else (call-setting-continuation-attachment
                 i
                 (lambda ()
                   (sub1 (loop (add1 i)))))]))
       (loop (add1 j))])))

  (let* ([attachments '((#f . #f))]
         [call/ca
          (lambda (a proc)
            (call/cc
             (lambda (k)
               (cond
                [(eq? k (caar attachments))
                 (set! attachments (cons (cons k a) (cdr attachments)))
                 (proc)]
                [else
                 (call-with-values (lambda () 
                                     (call/cc
                                      (lambda (inner-k)
                                        (set! attachments (cons (cons inner-k a) attachments))
                                        (proc))))
                   (case-lambda
                    [(v) (set! attachments (cdr attachments)) v]
                    [vals (set! attachments (cdr attachments)) (apply values vals)]))]))))])
    (report "call/cc-based attachment loop - compare to CA 1")
    (time
     (let loop ([j 0])
       (cond
        [(= j N) 'done]
        [else
         (let loop ([i 0])
           (cond
            [(= i M) 0]
            [else (call/ca
                   i
                   (lambda ()
                     (loop (add1 i))))]))
         (loop (add1 j))])))

    (report "call/cc-based deep attachment - compare to CA 2")
    (time
     (let loop ([j 0])
       (cond
        [(= j N) 'done]
        [else
         (let loop ([i 0])
           (cond
            [(= i M) 0]
            [else (call/ca
                   i
                   (lambda ()
                     (sub1 (loop (add1 i)))))]))
         (loop (add1 j))])))))