[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]

Reentrancy-detecting, faster implementation

Here is another safe-for-space version of srfi-45 promises that detects reentrant promises and should be faster.

It follows closely the description of the G-machine handling of tail calls (enhanced with black holes) in the reference:

  Richard Jones - "Tail recursion without space leaks"

This implementation has the following advantages over the previous implementations that were based on naive graph reduction:

 - It is faster (for a given data representation), since the root node is not
   overwritten on each iteration, but only after the final promise in a lazy
   chain is forced.

 - Reentrant promises are detected early and a runtime exception is raised for

This second property is not consistent with r5rs, but it is IMO a very useful feature. Here is a simple example where it raises an exception:

  (let ((p (delay (force p))))
    (force p))                  ==> Error: reentrant promise


;; <promise> ::= (lazy   . <thunk of promise>)   (delayed     promise)
;;             | (value  . <object>)             (forced      promise)
;;             | (shared . <promise>)            (shared      promise)
;;             | (hole   . #f)                   (black-holed promise)

(define-syntax lazy
  (syntax-rules ()
    ((lazy exp) (cons 'lazy (lambda () exp)))))

(define-syntax delay
  (syntax-rules ()
    ((delay exp) (lazy (cons 'value exp)))))

(define (force root-node)

  (define (dispatch node)
    (let ((type    (car node))
          (content (cdr node)))
      (set-car! node 'shared)     ; maintain any sharing by
      (set-cdr! node root-node)   ; pointing back to root
      (case type
        ((lazy)   (dispatch (content)))
        ((value)  (set-car! root-node 'value)   ; overwrite root at end
                  (set-cdr! root-node content)
        ((shared) (dispatch content))
        (else     (error "Invalid promise")))))

  (case (car root-node)
    ((lazy)   (let ((thunk (cdr root-node)))
                (set-car! root-node 'hole)   ; blackhole root note so that
                (set-cdr! root-node #f)      ; we do not hold on to chain
                (dispatch (thunk))))
    ((value)  (cdr root-node))
    ((shared) (force (cdr root-node)))
    ((hole)   (error "Reentrant promise"))
    (else     (error "Invalid promise"))))