suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

* Improve naming convention -- always use v' for values and p' for promises

Browse Source 
* When `force/composable' reaches a promise, use `force' to dispatch on the
  kind of promise
* Minor printer tweaks (print "raise" for non-exceptions)

svn: r16772
This commit is contained in:
Eli Barzilay 2009-11-14 22:30:55 +00:00
parent 2f0f249299
commit 8e3ec9d3bf
1 changed files with 51 additions and 51 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

102
collects/scheme/promise.ss
View File

@ -29,44 +29,44 @@
;; * (force X) = X for non promises ;; * (force X) = X for non promises
;; * does not deal with multiple values in the composable case ;; * does not deal with multiple values in the composable case
(define (force/composable root) (define (force/composable root)
(let ([p (pref root)]) (let ([v (pref root)])
(cond (cond
[(procedure? p) [(procedure? v)
;; mark the root as running: avoids cycles, and no need to keep banging ;; mark the root as running: avoids cycles, and no need to keep banging
;; the root promise value; it makes this non-r5rs, but the only ;; the root promise value; it makes this non-r5rs, but the only
;; practical uses of these things could be ones that use state to avoid ;; practical uses of these things could be ones that use state to avoid
;; an infinite loop. (See the generic forcer below.) ;; an infinite loop. (See the generic forcer below.)
;; (careful: avoid holding a reference to the thunk, to allow ;; (careful: avoid holding a reference to the thunk, to allow
;; safe-for-space loops) ;; safe-for-space loops)
(pset! root (make-running (object-name p))) (pset! root (make-running (object-name v)))
(call-with-exception-handler (call-with-exception-handler
(lambda (e) (pset! root (make-reraise e)) e) (lambda (e) (pset! root (make-reraise e)) e)
(lambda () (lambda ()
;; iterate carefully through chains of composable promises ;; iterate carefully through chains of composable promises
(let loop ([v (p)]) ; does not handle multiple values! (let loop ([v (v)]) ; does not handle multiple values!
(cond [(composable-promise? v) (cond [(composable-promise? v)
(let ([p* (pref v)]) (let ([v* (pref v)])
(pset! v root) ; share with root (pset! v root) ; share with root
(cond [(procedure? p*) (loop (p*))] (cond [(procedure? v*) (loop (v*))]
;; it must be a list of one value (because ;; it must be a list of one value (because
;; composable promises never hold multiple values), ;; composable promises never hold multiple values),
;; or a composable promise ;; or a composable promise
[(pair? p*) (pset! root p*) (unsafe-car p*)] [(pair? v*) (pset! root v*) (unsafe-car v*)]
;; note: for the promise case we could jump only to ;; note: for the promise case we could jump only to
;; the last `let' (for `p*'), but that makes the ;; the last `let' (for `v*'), but that makes the
;; code heavier, and runs slower (probably goes over ;; code heavier, and runs slower (probably goes over
;; some inlining/unfolding threshold). ;; some inlining/unfolding threshold).
[else (loop p*)]))] [else (loop v*)]))]
;; reached a non-composable promise: share and force it now ;; reached a non-composable promise: share and force it now
[(promise? v) (pset! root v) (force/generic v)] [(promise? v) (pset! root v) (force v)]
;; error here for "library approach" (see above URL) ;; error here for "library approach" (see above URL)
[else (pset! root (list v)) v]))))] [else (pset! root (list v)) v]))))]
;; try to make the order efficient, with common cases first ;; try to make the order efficient, with common cases first
[(pair? p) (if (null? (unsafe-cdr p)) (unsafe-car p) (apply values p))] [(pair? v) (if (null? (unsafe-cdr v)) (unsafe-car v) (apply values v))]
;; follow all sharings (and shortcut directly to the right force) ;; follow all sharings (and shortcut directly to the right force)
[(composable-promise? p) (force/composable p) (force/generic p)] [(composable-promise? v) (force/composable v) (force v)]
[(null? p) (values)] [(null? v) (values)]
[else (error 'force "composable promise with invalid contents: ~e" p)]))) [else (error 'force "composable promise with invalid contents: ~e" v)])))
;; generic force for "old-style" promises -- they're still useful in ;; generic force for "old-style" promises -- they're still useful in
;; that they allow multiple values. In general, this is slower, but has ;; that they allow multiple values. In general, this is slower, but has
@ -77,22 +77,22 @@
;; first cannot be solved. I still didn't ever see any use for them, so ;; first cannot be solved. I still didn't ever see any use for them, so
;; they're still forbidden.) ;; they're still forbidden.)
(define (force/generic promise) (define (force/generic promise)
(let ([p (pref promise)]) (let ([v (pref promise)])
(cond (cond
[(procedure? p) [(procedure? v)
(pset! promise (make-running (object-name p))) (pset! promise (make-running (object-name v)))
(call-with-exception-handler (call-with-exception-handler
(lambda (e) (pset! promise (make-reraise e)) e) (lambda (e) (pset! promise (make-reraise e)) e)
(lambda () (lambda ()
(let ([vs (call-with-values p list)]) (let ([vs (call-with-values v list)])
(pset! promise vs) (pset! promise vs)
(cond [(null? vs) (values)] (cond [(null? vs) (values)]
[(null? (unsafe-cdr vs)) (unsafe-car vs)] [(null? (unsafe-cdr vs)) (unsafe-car vs)]
[else (apply values vs)]))))] [else (apply values vs)]))))]
;; try to make the order efficient, with common cases first ;; try to make the order efficient, with common cases first
[(pair? p) (if (null? (unsafe-cdr p)) (unsafe-car p) (apply values p))] [(pair? v) (if (null? (unsafe-cdr v)) (unsafe-car v) (apply values v))]
[(null? p) (values)] [(null? v) (values)]
[else (error 'force "generic promise with invalid contents: ~e" p)]))) [else (error 'force "generic promise with invalid contents: ~e" v)])))
;; dispatcher for composable promises, generic promises, and other values ;; dispatcher for composable promises, generic promises, and other values
(define (force promise) (define (force promise)
@ -105,33 +105,33 @@
;; generic promise printer ;; generic promise printer
(define (promise-printer promise port write?) (define (promise-printer promise port write?)
(let loop ([p (pref promise)]) (let loop ([v (pref promise)])
(cond [(reraise? p) (cond
(let ([v (reraise-val p)]) [(reraise? v)
(if (exn? v) (let ([r (reraise-val v)])
(fprintf port (if write? "#<promise!exn!~s>" "#<promise!exn!~a>") (if (exn? r)
(exn-message v)) (fprintf port (if write? "#<promise!exn!~s>" "#<promise!exn!~a>")
(fprintf port (if write? "#<promise!~s>" "#<promise!~a>") (exn-message r))
`(raise ,v))))] (fprintf port (if write? "#<promise!raise!~s>" "#<promise!raise!~a>")
[(running? p) r)))]
(let ([n (running-name p)]) [(running? v)
(if n (let ([r (running-name v)])
(fprintf port "#<promise:!running!~a>" n) (if r
(fprintf port "#<promise:!running>")))] (fprintf port "#<promise:!running!~a>" r)
[(procedure? p) (fprintf port "#<promise:!running>")))]
(cond [(object-name p) [(procedure? v)
=> (lambda (n) (fprintf port "#<promise:~a>" n))] (cond [(object-name v)
[else (display "#<promise>" port)])] => (lambda (n) (fprintf port "#<promise:~a>" n))]
[(promise? p) (loop (pref p))] ; hide sharing [else (display "#<promise>" port)])]
;; values [(promise? v) (loop (pref v))] ; hide sharing
[(null? p) (fprintf port "#<promise!(values)>")] ;; values
[(null? (cdr p)) [(null? v) (fprintf port "#<promise!(values)>")]
(fprintf port (if write? "#<promise!~s>" "#<promise!~a>") (car p))] [(null? (cdr v))
[else (fprintf port (if write? "#<promise!~s>" "#<promise!~a>") (car v))]
(display "#<promise!(values" port) [else (display "#<promise!(values" port)
(let ([fmt (if write? " ~s" " ~a")]) (let ([fmt (if write? " ~s" " ~a")])
(for-each (lambda (x) (fprintf port fmt x)) p)) (for-each (lambda (x) (fprintf port fmt x)) v))
(display ")>" port)]))) (display ")>" port)])))
;; property value for the right forcer to use ;; property value for the right forcer to use
(define-values [prop:force promise-forcer] (define-values [prop:force promise-forcer]
@ -230,7 +230,7 @@
#:property prop:procedure (lambda (this) #:property prop:procedure (lambda (this)
(let ([name (running-name this)]) (let ([name (running-name this)])
(if name (if name
(error 'force "reentrant promise ~v" name) (error 'force "reentrant promise ~e" name)
(error 'force "reentrant promise"))))) (error 'force "reentrant promise")))))
;; ---------------------------------------------------------------------------- ;; ----------------------------------------------------------------------------
@ -238,8 +238,8 @@
(define (promise-forced? promise) (define (promise-forced? promise)
(if (promise? promise) (if (promise? promise)
(let ([p (pref promise)]) (let ([v (pref promise)])
(or (not (procedure? p)) (reraise? p))) ; #f when running (or (not (procedure? v)) (reraise? v))) ; #f when running
(raise-type-error 'promise-forced? "promise" promise))) (raise-type-error 'promise-forced? "promise" promise)))
(define (promise-running? promise) (define (promise-running? promise)