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

Simpler implementation

Inspired by Eli Barzilay's solutions, here is a simpler box-less implementation that should have much better performance than the reference implementation.

This implementation is still pretty much a verbatim statement of "naive graph reduction" as discussed, e.g., in the reference by Richard Jones in srfi-45, which is formally known to be safe for space.

I give two equivalent versions of it. I find the first on more readable. The second one uses a representation similar to Eli Barzilay's and is a little more concise.

 Version 1:

;; <promise> ::= (lazy   . <thunk of promise>)    (delayed promise)
;;             | (value  . <object>)              (forced  promise)
;;             | (shared . <promise>)             (shared  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 promise)
  (case (car promise)
    ((lazy)   (let ((promise* ((cdr promise))))
                (if (not (eq? (car promise) 'value))
                    (begin (set-car! promise (car promise*))
                           (set-cdr! promise (cdr promise*))
                           (set-car! promise* 'shared)
                           (set-cdr! promise* promise)))
                (force promise)))
    ((value)  (cdr promise))
    ((shared) (force (cdr promise)))
    (else (error "Not a promise"))))

This version can be spoofed, but it is obvious how to either convert it
to using unique tags or to using a record type.

 Version 2:

;; <promise> ::= (make-promise <thunk of promise>)   (delayed promise)
;;             | (make-promise (list <object>))      (forced  promise)
;;             | (make-promise <promise>)            (shared  promise)

(define-struct promise (p))

(define-syntax lazy
  (syntax-rules ()
    ((lazy exp)
     (make-promise (lambda () exp)))))

(define-syntax delay
  (syntax-rules ()
    ((delay exp) (lazy (make-promise (list exp))))))

(define (force promise)
  (let ((p (promise-p promise)))
    (cond ((procedure? p) (let ((promise* (p)))
                            (if (not (pair? (promise-p promise)))
                                (begin (set-promise-p! promise (promise-p promise*))
                                       (set-promise-p! promise* promise)))
                            (force promise)))
          ((pair? p)      (car p))
          ((promise? p)   (force p))
          (else           (error "Not a promise")))))