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
Received on Thu Oct 19 2006 - 18:05:03 UTC