[r6rs-discuss] [Formal] Delayed evaluation - detecting reentrancy

[Andre van Tonder]

Here is another implementation of srfi-45-type promises that has early detection 
of reentrant promises.  It shows that detecting reentrancy is not difficult 
and does not mean sacrificing speed.  Hopefully it supports my previous 
request that implementations should not be disallowed from providing this 
feature.

Here is a simple example where it raises an exception, avoiding non-termination.

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

The implementation 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"

and is safe for space if used correctly (see srfi-45).

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

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

  - 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.


Implementation:
===============

;; <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)
                   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"))))

Andre