From 945dc376d2ec5ec78b26f6074e867f46e1df8dc1 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Mon, 23 Jun 2008 04:07:12 +0000 Subject: [PATCH] * Removed `with-handlers*' that was causing a problem in some long nested streams example (from Jos Koot). * Replaced with `call-with-exception-handler' which is (intentionally) not tail-recursive, but it seems to work fine now. * The `lazy' form is restricted to single-valued expressions only. svn: r10416 --- collects/scheme/promise.ss | 239 +++++++++++++++++-------------------- 1 file changed, 112 insertions(+), 127 deletions(-) diff --git a/collects/scheme/promise.ss b/collects/scheme/promise.ss index 04ee5ad7b8..dedf0433f3 100644 --- a/collects/scheme/promise.ss +++ b/collects/scheme/promise.ss @@ -1,133 +1,118 @@ -(module promise '#%kernel +#lang scheme/base - ;; This module implements "lazy promises" and a `force' that is iterated - ;; through them. - ;; This is similar to the *new* version of srfi-45 -- see the post-finalization - ;; discussion at http://srfi.schemers.org/srfi-45/ for more details; - ;; specifically, this version is the `lazy2' version from - ;; http://srfi.schemers.org/srfi-45/post-mail-archive/msg00013.html and (a - ;; `lazy3' variant of `force' that deals with multiple values is included and - ;; commented). Note: if you use only `force'+`delay' it behaves as in Scheme - ;; (except that `force' is identity for non promise values), and `force'+`lazy' - ;; are sufficient for implementing the lazy language. +;; This module implements "lazy promises" and a `force' that is iterated +;; through them. - (#%require "private/more-scheme.ss" "private/small-scheme.ss" - "private/define.ss" - (rename "private/define-struct.ss" define-struct define-struct*) - (for-syntax '#%kernel - "private/stxcase-scheme.ss" "private/small-scheme.ss")) +;; This is similar to the *new* version of srfi-45 -- see the +;; post-finalization discussion at http://srfi.schemers.org/srfi-45/ +;; for more details; specifically, this version is the `lazy2' version +;; from +;; http://srfi.schemers.org/srfi-45/post-mail-archive/msg00013.html +;; and (a `lazy3' variant of `force' that deals with multiple values +;; is included and commented). Note: if you use only `force'+`delay' +;; it behaves as in Scheme (except that `force' is identity for non +;; promise values), and `force'+`lazy' are sufficient for implementing +;; the lazy language. - (#%provide lazy delay force promise?) +(require (for-syntax scheme/base)) +(provide lazy delay force promise?) - (define running - (lambda () (error 'force "reentrant promise"))) +(define (promise-printer promise port write?) + (let loop ([p (promise-val promise)]) + (cond [(procedure? p) + (cond [(object-name p) + => (lambda (n) (fprintf port "#" n))] + [else (display "#" port)])] + [(promise? p) (loop (promise-val p))] ; hide sharing + [(exn? p) (display "#" port)] ; exn when forced + ;; values + [(null? p) (fprintf port "#")] + [(null? (cdr p)) + (fprintf port (if write? "#" "#") (car p))] + [else + (display "#" port)]))) - (define (promise-printer promise port write?) +(define-struct promise (val) + #:mutable + #:property prop:custom-write promise-printer) +;; A promise value can hold +;; - : usually a delayed promise, but can also hold a `running' thunk +;; - : a shared (redirected) promise that points at another one +;; - (list ...): forced promise (possibly multiple-values, usually one) +;; - : a forced promise, where an exception happened when forcing + +;; Creates a `composable' promise +;; X = (force (lazy X)) = (force (lazy (lazy X))) = (force (lazy^n X)) +(define-syntax (lazy stx) + (syntax-case stx () + [(lazy expr) (with-syntax ([proc (syntax-property + (syntax/loc stx (lambda () expr)) + 'inferred-name (syntax-local-name))]) + (syntax/loc stx (make-promise proc)))])) + +;; Creates a promise that does not compose +;; X = (force (delay X)) = (force (lazy (delay X))) +;; = (force (lazy^n (delay X))) +;; X = (force (force (delay (delay X)))) =/= (force (delay (delay X))) +;; so each sequence of `(lazy^n o delay)^m' requires m `force's and a +;; sequence of `(lazy^n o delay)^m o lazy^k' requires m+1 `force's (for k>0) +;; (This is not needed with a lazy language (see the above URL for details), +;; but provided for regular delay/force uses.) +(define-syntax (delay stx) + (syntax-case stx () + [(delay expr) + (with-syntax ([proc (syntax-property + (syntax/loc stx (lambda () expr)) + 'inferred-name (syntax-local-name))]) + (syntax/loc stx + (lazy (make-promise (call-with-values proc list)))))])) + +;; force iterates on lazy promises (forbids dependency cycles) +;; * (force X) = X for non promises +;; * does not deal with multiple values, except for `delay' promises at the +;; leaves + +(define (force-proc p root) + (let loop1 ([v (p)]) ; does not handle multiple values! + (if (promise? v) + (let loop2 ([promise* v]) + (let ([p* (promise-val promise*)]) + (set-promise-val! promise* root) ; share with root + (cond [(procedure? p*) (loop1 (p*))] + [(promise? p*) (loop2 p*)] + [else (set-promise-val! root p*) + (cond [(exn? p*) (raise p*)] + [(null? p*) (values)] + [(null? (cdr p*)) (car p*)] + [else (apply values p*)])]))) + (begin ; error here for "library approach" (see above URL) + (set-promise-val! root (list v)) + v)))) + +(define (running proc) + (let ([name (object-name proc)]) + ;; important: be careful not to close over the thunk! + (lambda () + (if name + (error 'force "reentrant promise ~v" name) + (error 'force "reentrant promise"))))) + +(define (force promise) + (if (promise? promise) (let loop ([p (promise-val promise)]) - (cond - [(procedure? p) - (cond [(object-name p) - => (lambda (n) (fprintf port "#" n))] - [else (display "#" port)])] - ;; no values - [(null? p) (fprintf port "#")] - [(pair? p) - ;; single or multiple values - (fprintf port - (if write? "#" port)] - [(promise? p) (loop (promise-val p))] ; hide sharing - [else (loop (list p))]))) - - (define-struct promise (val) - #:mutable - #:property prop:custom-write promise-printer) - - ;; ::= - ;; | (promise ) delayed promise, maybe currently running, maybe an exn promise - ;; | (promise (list )) forced promise (possibly multi-valued) - ;; | (promise ) shared promise - ;; | (promise ) forced promise, since values - - ;; Creates a `composable' promise - ;; X = (force (lazy X)) = (force (lazy (lazy X))) = (force (lazy^n X)) - (define-syntax (lazy stx) - (syntax-case stx () - [(lazy expr) (with-syntax ([proc (syntax-property - (syntax/loc stx (lambda () expr)) - 'inferred-name (syntax-local-name))]) - (syntax/loc stx (make-promise proc)))])) - - ;; Creates a promise that does not compose - ;; X = (force (delay X)) = (force (lazy (delay X))) - ;; = (force (lazy^n (delay X))) - ;; X = (force (force (delay (delay X)))) =/= (force (delay (delay X))) - ;; so each sequence of `(lazy^n o delay)^m' requires m `force's and a - ;; sequence of `(lazy^n o delay)^m o lazy^k' requires m+1 `force's (for k>0) - ;; (This is not needed with a lazy language (see the above URL for details), - ;; but provided for completeness.) - (define-syntax (delay stx) - (syntax-case stx () - [(delay expr) - (with-syntax ([proc (syntax-property - (syntax/loc stx (lambda () expr)) - 'inferred-name (syntax-local-name))]) - (syntax/loc stx - (lazy (make-promise (call-with-values proc list)))))])) - - ;; force iterates on lazy promises (forbid dependency cycles) - ;; * (force X) = X for non promises - ;; * does not deal with multiple values, since they're not used by the lazy - ;; language (but see below) - - (define handle-results - (case-lambda [(single) (values #f single)] - [multi (values #t multi)])) - - (define (force-proc p root) - (let loop1 ([p p]) - (let-values ([(multi? v) (call-with-values p handle-results)]) - (if multi? - (begin ; error here for "library approach" (see above URL) - (set-promise-val! root v) - (apply values v)) - (if (promise? v) - (let loop2 ([promise* v]) - (let ([p* (promise-val promise*)]) - (set-promise-val! promise* root) ; share with root - (cond [(procedure? p*) (loop1 p*)] - [(promise? p*) (loop2 p*)] - [else (set-promise-val! root p*) - (cond [(null? p*) (values)] - [(not (pair? p*)) p*] ; is this needed? - [(null? (cdr p*)) (car p*)] - [else (apply values p*)])]))) - (begin ; error here for "library approach" (see above URL) - (set-promise-val! root (list v)) - v)))))) - - (define (force promise) - (if (promise? promise) - (let loop ([p (promise-val promise)]) - (cond - [(procedure? p) - ;; mark root for cycle detection: - (set-promise-val! promise running) - (with-handlers* ([void (lambda (e) - (set-promise-val! promise - (lambda () (raise e))) - (raise e))]) - (force-proc p promise))] - [(promise? p) (loop (promise-val p))] - [else (cond [(null? p) (values)] - [(not (pair? p)) p] ; is this needed? - [(null? (cdr p)) (car p)] - [else (apply values p)])])) - ;; different from srfi-45: identity for non-promises - promise))) + (cond [(procedure? p) + ;; "mark" root as running (avoids cycles) + (set-promise-val! promise (running p)) + (call-with-exception-handler + (lambda (exn) (set-promise-val! promise exn) exn) + (lambda () (force-proc p promise)))] + [(promise? p) (loop (promise-val p))] + [(exn? p) (raise p)] + [(null? p) (values)] + [(null? (cdr p)) (car p)] + [else (apply values p)])) + ;; different from srfi-45: identity for non-promises + promise))