Feature Request: Nestable Engines

[namin]

How difficult would it be to adapt the code from s/engine.ss to support nestable engines?

I have code that supports nestable engines (see below), but it requires a custom timed-lambda and redefining lambda to timed-lambda results in a big slowdown.
Note that the slowdown occurs even when engines are not otherwise used.

Would it be possible to use the timer mechanism in a nested fashion?

Thanks for any advice.

;; Nestable Engines
;; adapted from Appendix A of
;; A Shallow Scheme Embedding of  Bottom-Avoiding Streams
;; Byrd, Friedman, Kumar, Near
;; http://webyrd.net/frons/frons.pdf

(define replace!
  (lambda (p a d)
    (set-car! p a)
    (set-cdr! p d)))

(define-syntax engine
  (syntax-rules ()
    ((_ e) (make-engine (lambda () e)))))

(define-syntax timed-lambda
  (syntax-rules ()
    ((_ formals b0 b ...)
     (let ()
       (import (chezscheme))
       (lambda formals (expend-tick-to-call (lambda () b0 b ...)))))))

(define eng-state (cons #f 0))

(define expend-tick-to-call
  (lambda (thunk)
    ((call/cc
       (lambda (k)
         (let th  ()
           (cond
             ((not (car eng-state)) (k thunk))
             ((zero? (car eng-state)) ((cdr eng-state) th))
             (else (set-car! eng-state (- (car eng-state) 1)) (k thunk)))))))))

(define make-engine
  (lambda (thunk)
    (lambda (ticks complete expire) ;; added to match ChezScheme engines
      (let* ((gift (if (car eng-state) (min (car eng-state) ticks) ticks))
             (saved-eng-state (cons (and (car eng-state) (- (car eng-state) gift)) (cdr eng-state)))
             (caught (call/cc
                       (lambda (k)
                         (replace! eng-state gift k)
                         (let ((result (thunk)))
                           ((cdr eng-state) (cons (car eng-state) result)))))))
        (replace! eng-state (car saved-eng-state) (cdr saved-eng-state))
        (let ((owed (- ticks gift)))
          (cond
            ((pair? caught)
             (and (car eng-state) (set-car! eng-state (+ (car eng-state) (car caught))))
             (complete (+ (car caught) owed) (cdr caught)))
            (else (let ((e (make-engine caught)))
                    (if (zero? owed) (expire e)
                      (let ((th (lambda () (e owed complete expire))))
                        ((call/cc (lambda (k^) ((cdr eng-state) (lambda () (k^ th))))))))))))))))

;; redefining `lambda` works but makes things very slow
(define-syntax lambda
  (syntax-rules ()
    ((_ formals b0 b ...)
     (timed-lambda formals b0 b ...))))

[namin]

I narrowed down the slowness to the call/cc call in expend-tick-to-call. I think not doing the call/cc call when no engines are running is a valid optimization.

(define expend-tick-to-call
  (lambda (thunk)
    (if (not (car eng-state))
        ;; optimization: avoid call/cc when engines are not running
        (thunk)
        ((call/cc
          (lambda (k)
            (let th  ()
              (cond
                ((not (car eng-state)) (k thunk))
                ((zero? (car eng-state)) ((cdr eng-state) th))
                (else (set-car! eng-state (- (car eng-state) 1)) (k thunk))))))))))

[namin]

Some benchmarks:

• An application without engines runs in 3.5 seconds.
• The same application under a ChezScheme engine used as a timeout runs in 3.6 seconds.
• The same application without engines but under timed-lambda runs in 7.1 seconds.
• The same application under a nestable engine used as a timeout runs in 25.8 seconds.

So the overhead of the implementation of nestable engines above is huge (over a 7x slowdown), and I am wondering how easy it would be to modify the current implementation of engines in ChezScheme to be nestable.

Thanks!

[soegaard]

FWIW I think, this is the place too look:

https://github.com/cisco/ChezScheme/blob/main/s/engine.ss

[namin]

Indeed, and here is where a nested engine causes an explicit error:
https://github.com/cisco/ChezScheme/blob/main/s/engine.ss#L89

[amirouche]

I got working something similar, I can send you a stub privately.

[namin]

Sure, if I can make it public eventually (and I’d rather you send it publically for the scrutiny): [email protected]

thanks!

[akeep]

I've not done much with the engines implementation, but I ran across a paper Engines from Continuations that Kent Dybvig and Robert Hieb wrote about the implementation back in 1988. The article notes that nested engines using continuations leads to the nested continuation capturing the state of the engine it is nested in, and propose an alternative implementation with a slightly modified API to allow it to allow for continuation-based implementation.

[namin]

Thanks, @akeep! The code from the appendix works! I was able to get my application working with minimal overhead.

I had to define the following functions from the paper interface:

(define (stop-timer) (set-timer 0))
(define (start-timer ticks new-handler)
  (timer-interrupt-handler new-handler)
  (set-timer ticks))

I think I need to do something a bit more complicated than that. I am currently getting an error like "Exception in read: not permitted on closed port #<input port ...>" when re-running tests multiple times.

It seems like I might need to setup and cleanup like s/engine.ss does, but this is looking promising.

[namin]

For reference, here is the code:

(define (stop-timer) (set-timer 0))
(define (start-timer ticks new-handler)
  (timer-interrupt-handler new-handler)
  (set-timer ticks))

(define make-full-engine)
(letrec
    ([new-engine
      (lambda (proc id)
        (lambda (ticks return expire)
          ((call/cc
            (lambda (k)
              (run proc
                     (stop-timer)
                     ticks
                     (lambda (value ticks engine-maker)
                       (k (lambda () (return value ticks engine-maker))))
                     (lambda (engine)
                       (k (lambda () (expire engine))))
                     id))))))]
     [run
      (lambda (resume parent child return expire id)
        (let ([ticks (if (and (active?) (< parent child)) parent child)])
          (push (- parent ticks) (- child ticks) return expire id)
          (resume ticks)))]
     [go
      (lambda (ticks)
        (when (active?)
          (if (= ticks 0)
              (timer-handler)
              (start-timer ticks timer-handler))))]
     [do-return
      (lambda (proc value ticks id1)
        (pop (lambda (parent child return expire id2)
               (if (eq? id1 id2)
                   (begin (go (+ parent ticks))
                          (return value
                                  (+ child ticks)
                                  (lambda (value) (new-engine (proc value) id1))))
                   (do-return
                    (lambda (value)
                      (lambda (new-ticks)
                        (run (proc value) new-ticks (+ child ticks) return expire id2)))
                    value
                    (+ parent ticks)
                    id1)))))]
     [do-expire
      (lambda (resume)
        (pop (lambda (parent child return expire id)
               (if (> child 0)
                   (do-expire (lambda (ticks) (run resume ticks child return expire id)))
                   (begin (go parent)
                          (expire (new-engine resume id)))))))]
     [timer-handler (lambda () (go (call/cc do-expire)))]
     [stack '()]
     [push (lambda l (set! stack (cons l stack)))]
     [pop
      (lambda (handler)
        (if (null? stack)
            (error 'engine "attempt to return from inactive engine")
            (let ([top (car stack)])
              (set! stack (cdr stack))
              (apply handler top))))]
     [active? (lambda () (not (null? stack)))])
  (set! make-full-engine
        (lambda (proc)
          (letrec ([engine-return
                    (lambda (value)
                      (call/cc
                       (lambda (k)
                         (do-return (lambda (value)
                                      (lambda (ticks)
                                        (go ticks)
                                        (k value)))
                                    value
                                    (stop-timer)
                                    engine-return))))])
            (new-engine (lambda (ticks)
                          (go ticks)
                          (proc engine-return)
                          (error 'engine "invalid completion"))
                        engine-return)))))

(define make-engine
  (letrec ([simplify (lambda (engine)
                       (lambda (ticks return expire)
                         (engine ticks
                                 (lambda (value ticks engine-maker)
                                   (return ticks value))
                                 (lambda (engine)
                                   (expire (simplify engine))))))])
    (lambda (proc)
      (simplify (make-full-engine (lambda (ret) (ret (proc))))))))

[namin]

Hmm, setting up and cleaning up like s/engine.ss does seems a bit involved. I am also not sure about the semantics when the timer handler is overwritten by a nested engine. This doesn't seem to be an issue in the paper. To be continued... any advice appreciated.

[namin]

I found that my bug was because the engine was returning while the timer was not at 0, and later when it becomes 0, it calls the obsolete handler of the returned engine. I fix this bug by setting the timer to 0 in in the simplified make-engine.

(define make-engine
  (letrec ([simplify (lambda (engine)
                       (lambda (ticks return expire)
                         (engine ticks
                                 (lambda (value ticks engine-maker)
                                   ;; added: stop timer,
                                   ;; to avoid firing after engine completes
                                   (stop-timer)
                                   (return ticks value))
                                 (lambda (engine)
                                   (expire (simplify engine))))))])
    (lambda (proc)
      (simplify (make-full-engine (lambda (ret) (ret (proc))))))))

If anyone has thoughts on cleaning up like in s/engine.ss that would be appreciated. I am not sure what are the consequences of not doing so.

Thanks!

[namin]

Hmm, unfortunately, the fix seems wrong. For:

((make-engine (lambda () ((make-engine (lambda () (factorial 10))) 100000 (lambda (ticks value) ticks) (lambda (engine) engine)))) 100000 list list)

We get (0 99985) instead of (99971 99985).

[namin]

As an update, the root cause of the engines misbehaving (firing at random times, once they're obsolete) seems to be related to exceptions occurring within engines. So cleaning up like with-exception-handler done in s/engine.ss seems important. Not sure how to make that compatible with nestable engines.

Thanks.

[namin]

OK, the code below seems to work with exception-throwing engines.
(Updated to account for ticks even if there is an exception.)

;; from Appendix A of https://legacy.cs.indiana.edu/~dyb/pubs/engines.pdf

(define (stop-timer) (set-timer 0))
(define (start-timer ticks new-handler)
  (timer-interrupt-handler new-handler)
  (set-timer ticks))

(define make-engine)
(letrec
    ([new-engine
      (lambda (proc id)
        (lambda (ticks return expire)
          ((call/cc
            (lambda (k)
              (run proc
                     (stop-timer)
                     ticks
                     (lambda (value ticks engine-maker)
                       (k (lambda () (return value ticks engine-maker))))
                     (lambda (engine)
                       (k (lambda () (expire engine))))
                     id))))))]
     [run
      (lambda (resume parent child return expire id)
        (let ([ticks (if (and (active?) (< parent child)) parent child)])
          (push (- parent ticks) (- child ticks) return expire id)
          (resume ticks)))]
     [go
      (lambda (ticks)
        (when (active?)
          (if (= ticks 0)
              (timer-handler)
              (start-timer ticks timer-handler))))]
     [do-return
      (lambda (proc value ticks id1)
        (pop (lambda (parent child return expire id2)
               (if (eq? id1 id2)
                   (begin (go (+ parent ticks))
                          (return value
                                  (+ child ticks)
                                  (lambda (value) (new-engine (proc value) id1))))
                   (do-return
                    (lambda (value)
                      (lambda (new-ticks)
                        (run (proc value) new-ticks (+ child ticks) return expire id2)))
                    value
                    (+ parent ticks)
                    id1)))))]
     [do-expire
      (lambda (resume)
        (pop (lambda (parent child return expire id)
               (if (> child 0)
                   (do-expire (lambda (ticks) (run resume ticks child return expire id)))
                   (begin (go parent)
                          (expire (new-engine resume id)))))))]
     [do-raise
      (lambda (c ticks id1)
        (pop (lambda (parent child return expire id2)
               (if (eq? id1 id2)
                   (begin (go (+ parent ticks))
                          (raise-continuable c))
                   (do-raise c (+ parent ticks) id1)))))]
     [timer-handler (lambda () (go (call/cc do-expire)))]
     [stack '()]
     [push (lambda l (set! stack (cons l stack)))]
     [pop
      (lambda (handler)
        (if (null? stack)
            (error 'engine "attempt to return from inactive engine")
            (let ([top (car stack)])
              (set! stack (cdr stack))
              (apply handler top))))]
     [active? (lambda () (not (null? stack)))]
     [make-full-engine
      (lambda (proc)
        (letrec ([engine-return
                  (lambda (value)
                    (call/cc
                     (lambda (k)
                       (do-return (lambda (value)
                                    (lambda (ticks)
                                      (go ticks)
                                      (k value)))
                                  value
                                  (stop-timer)
                                  engine-return))))])
          (new-engine (lambda (ticks)
                        (go ticks)
                        (with-exception-handler
                         (lambda (c)
                           (do-raise c (stop-timer) engine-return))
                         (lambda ()
                           (proc engine-return)))
                        (error 'engine "invalid completion"))
                      engine-return)))])
  (set! make-engine
    (letrec ([simplify (lambda (engine)
                         (lambda (ticks return expire)
                           (engine ticks
                                   (lambda (value ticks engine-maker)
                                     (return ticks value))
                                   (lambda (engine)
                                     (expire (simplify engine))))))])
      (lambda (proc)
        (simplify (make-full-engine (lambda (ret) (ret (proc)))))))))