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

moved extra promise types back to scheme/promise

Browse Source 
svn: r17207
This commit is contained in:
Eli Barzilay 2009-12-05 09:28:41 +00:00
parent 4df0d11db5
commit 9cc6cd0db4
2 changed files with 188 additions and 184 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

193
collects/scheme/private/promise.ss
View File

@ -5,7 +5,12 @@
(rename "define-struct.ss" define-struct define-struct*)
(for-syntax '#%kernel "stxcase-scheme.ss" "name.ss")
'#%unsafe)
(#%provide force promise? promise-forced? promise-running?)
(#%provide force promise? promise-forced? promise-running?
;; provided to create extensions
(struct promise ()) pref pset! prop:force reify-result
promise-printer
(struct running ()) (struct reraise ())
(for-syntax make-delayer))
;; This module implements "lazy" (composable) promises and a `force'
;; that is iterated through them.
@ -19,7 +24,7 @@
;; are sufficient for implementing the lazy language.
;; unsafe accessors
(define-syntax pref (syntax-rules () [(_ p) (unsafe-struct-ref p 0)]))
(define-syntax pref (syntax-rules () [(_ p ) (unsafe-struct-ref p 0 )]))
(define-syntax pset! (syntax-rules () [(_ p x) (unsafe-struct-set! p 0 x)]))
;; ----------------------------------------------------------------------------
@ -69,11 +74,10 @@
[else (error 'force "composable promise with invalid contents: ~e" v)])))
(define (reify-result v)
(cond
[(pair? v) (if (null? (unsafe-cdr v)) (unsafe-car v) (apply values v))]
[(null? v) (values)]
[(reraise? v) (v)]
[else (error 'force "promise with invalid contents: ~e" v)]))
(cond [(pair? v) (if (null? (unsafe-cdr v)) (unsafe-car v) (apply values v))]
[(null? v) (values)]
[(reraise? v) (v)]
[else (error 'force "promise with invalid contents: ~e" v)]))
;; generic force for "old-style" promises -- they're still useful in
;; that they allow multiple values. In general, this is slower, but has
@ -253,181 +257,6 @@
(running? (pref promise))
(raise-type-error 'promise-running? "promise" promise)))
;; ----------------------------------------------------------------------------
;; More delay-like values, with different ways of deferring computations
(define-struct (promise/name promise) ()
#:property prop:force (lambda (p) ((pref p))))
(#%provide (rename delay/name* delay/name))
(define delay/name make-promise/name)
(define-syntax (delay/name* stx) (make-delayer stx #'delay/name '()))
;; utility struct
(define-struct (running-thread running) (thread))
;; used in promise/sync until it's forced
(define-struct syncinfo ([thunk #:mutable] done-evt done-sema access-sema))
(define-struct (promise/sync promise) ()
#:property prop:custom-write
(lambda (p port write?)
(promise-printer
(let ([v (pref p)])
(if (syncinfo? v) (make-promise (syncinfo-thunk v)) p))
port write?))
#:property prop:force
(lambda (p)
(reify-result
(let ([v (pref p)])
(cond
;; already forced
[(not (syncinfo? v)) v]
;; being forced...
[(running-thread? (syncinfo-thunk v))
(let ([r (syncinfo-thunk v)])
(if (eq? (running-thread-thread r) (current-thread))
;; ... by the current thread => throw the usual reentrant error
(r)
;; ... by a different thread => just wait for it
(begin (sync (syncinfo-done-evt v)) (pref p))))]
[else
;; wasn't forced yet: try to do it now
(call-with-semaphore (syncinfo-access-sema v)
(lambda ()
(let ([thunk (syncinfo-thunk v)] [done (syncinfo-done-sema v)])
;; set the thread last
(set-syncinfo-thunk!
v (make-running-thread (object-name thunk) (current-thread)))
(call-with-exception-handler
(lambda (e)
(pset! p (make-reraise e))
(semaphore-post done)
e)
(lambda ()
(pset! p (call-with-values thunk list))
(semaphore-post done))))))
;; whether it was this thread that forced it or not, the results are
;; now in
(pref p)]))))
#:property prop:evt
(lambda (p)
(let ([v (pref p)])
(handle-evt (if (syncinfo? v) (syncinfo-done-evt v) always-evt) void))))
(#%provide (rename delay/sync* delay/sync))
(define (delay/sync thunk)
(let ([done-sema (make-semaphore 0)])
(make-promise/sync (make-syncinfo thunk
(semaphore-peek-evt done-sema) done-sema
(make-semaphore 1)))))
(define-syntax (delay/sync* stx) (make-delayer stx #'delay/sync '()))
;; threaded promises
(define-struct (promise/thread promise) ()
#:property prop:force
(lambda (p)
(reify-result (let ([v (pref p)])
(if (running-thread? v)
(begin (thread-wait (running-thread-thread v))
(pref p))
v))))
#:property prop:evt
(lambda (p)
(let ([v (pref p)])
(handle-evt (if (running? v) (running-thread-thread v) always-evt)
void))))
(#%provide (rename delay/thread* delay/thread))
(define (delay/thread thunk group)
(define (run)
(call-with-exception-handler
(lambda (e) (pset! p (make-reraise e)) (kill-thread (current-thread)))
(lambda () (pset! p (call-with-values thunk list)))))
(define p
(make-promise/thread
(make-running-thread
(object-name thunk)
(if group
(parameterize ([current-thread-group (make-thread-group)]) (thread run))
(thread run)))))
p)
(define-syntax delay/thread*
(let-values ([(kwds) (list (cons '#:group #'#t))])
(lambda (stx) (make-delayer stx #'delay/thread kwds))))
(define-struct (promise/idle promise/thread) ()
#:property prop:force
(lambda (p)
(reify-result (let ([v (pref p)])
(if (procedure? v)
;; either running-thread, or returns the controller
(let ([controller (if (running-thread? v)
(running-thread-thread v)
(v))])
(thread-send controller 'force!)
(thread-wait controller)
(pref p))
v)))))
(#%provide (rename delay/idle* delay/idle))
(define (delay/idle thunk wait-for work-while tick use*)
(define use (cond [(use* . <= . 0) 0] [(use* . >= . 1) 1] [else use*]))
(define work-time (* tick use))
(define rest-time (- tick work-time))
(define (work)
(call-with-exception-handler
(lambda (e) (pset! p (make-reraise e)) (kill-thread (current-thread)))
(lambda () (pset! p (call-with-values thunk list)))))
(define (run)
;; this thread is dedicated to controlling the worker thread, so it's
;; possible to dedicate messages to signaling a `force'.
(define force-evt (thread-receive-evt))
(sync wait-for force-evt)
(pset! p (make-running-thread (object-name thunk) controller-thread))
(let ([worker (parameterize ([current-thread-group (make-thread-group)])
(thread work))])
(cond
[(and (use . >= . 1) (equal? work-while always-evt))
;; as if it was pre-forced
(thread-wait worker)]
[(use . <= . 0)
;; work only when explicitly forced
(thread-suspend worker)
(sync force-evt)
(thread-wait worker)]
[else
(thread-suspend worker)
(let loop ()
;; rest, then wait for idle time, then resume working
(if (eq? (begin0 (or (sync/timeout rest-time force-evt)
(sync work-while force-evt))
(thread-resume worker))
force-evt)
;; forced during one of these => let it run to completion
(thread-wait worker)
;; not forced
(unless (sync/timeout work-time worker)
(thread-suspend worker)
(loop))))])))
;; I don't think that a thread-group here is needed, but it doesn't hurt
(define controller-thread
(parameterize ([current-thread-group (make-thread-group)])
(thread run)))
;; the thunk is not really used in the above, make it a function that returns
;; the controller thread so it can be forced (used in the `prop:force')
(define p (make-promise/idle
(procedure-rename (lambda () controller-thread)
(or (object-name thunk) 'idle-thread))))
p)
(define-syntax delay/idle*
(let-values ([(kwds) (list (cons '#:wait-for #'(system-idle-evt))
(cons '#:work-while #'(system-idle-evt))
(cons '#:tick #'0.2)
(cons '#:use #'0.12))])
(lambda (stx) (make-delayer stx #'delay/idle kwds))))
)
#|

179
collects/scheme/promise.ss
View File

@ -1,3 +1,178 @@
#lang scheme/base
(require "private/promise.ss")
(provide (all-from-out "private/promise.ss"))
(require "private/promise.ss" (for-syntax scheme/base))
(provide delay lazy force promise? promise-forced? promise-running?)
;; ----------------------------------------------------------------------------
;; More delay-like values, with different ways of deferring computations
(define-struct (promise/name promise) ()
#:property prop:force (lambda (p) ((pref p))))
(provide (rename-out [delay/name* delay/name]))
(define delay/name make-promise/name)
(define-syntax (delay/name* stx) (make-delayer stx #'delay/name '()))
;; utility struct
(define-struct (running-thread running) (thread))
;; used in promise/sync until it's forced
(define-struct syncinfo ([thunk #:mutable] done-evt done-sema access-sema))
(define-struct (promise/sync promise) ()
#:property prop:custom-write
(lambda (p port write?)
(promise-printer
(let ([v (pref p)])
(if (syncinfo? v) (make-promise (syncinfo-thunk v)) p))
port write?))
#:property prop:force
(lambda (p)
(reify-result
(let ([v (pref p)])
(cond
;; already forced
[(not (syncinfo? v)) v]
;; being forced...
[(running-thread? (syncinfo-thunk v))
(let ([r (syncinfo-thunk v)])
(if (eq? (running-thread-thread r) (current-thread))
;; ... by the current thread => throw the usual reentrant error
(r)
;; ... by a different thread => just wait for it
(begin (sync (syncinfo-done-evt v)) (pref p))))]
[else
;; wasn't forced yet: try to do it now
(call-with-semaphore (syncinfo-access-sema v)
(lambda ()
(let ([thunk (syncinfo-thunk v)] [done (syncinfo-done-sema v)])
;; set the thread last
(set-syncinfo-thunk!
v (make-running-thread (object-name thunk) (current-thread)))
(call-with-exception-handler
(lambda (e)
(pset! p (make-reraise e))
(semaphore-post done)
e)
(lambda ()
(pset! p (call-with-values thunk list))
(semaphore-post done))))))
;; whether it was this thread that forced it or not, the results are
;; now in
(pref p)]))))
#:property prop:evt
(lambda (p)
(let ([v (pref p)])
(handle-evt (if (syncinfo? v) (syncinfo-done-evt v) always-evt) void))))
(provide (rename-out [delay/sync* delay/sync]))
(define (delay/sync thunk)
(let ([done-sema (make-semaphore 0)])
(make-promise/sync (make-syncinfo thunk
(semaphore-peek-evt done-sema) done-sema
(make-semaphore 1)))))
(define-syntax (delay/sync* stx) (make-delayer stx #'delay/sync '()))
;; threaded promises
(define-struct (promise/thread promise) ()
#:property prop:force
(lambda (p)
(reify-result (let ([v (pref p)])
(if (running-thread? v)
(begin (thread-wait (running-thread-thread v))
(pref p))
v))))
#:property prop:evt
(lambda (p)
(let ([v (pref p)])
(handle-evt (if (running? v) (running-thread-thread v) always-evt)
void))))
(provide (rename-out [delay/thread* delay/thread]))
(define (delay/thread thunk group)
(define (run)
(call-with-exception-handler
(lambda (e) (pset! p (make-reraise e)) (kill-thread (current-thread)))
(lambda () (pset! p (call-with-values thunk list)))))
(define p
(make-promise/thread
(make-running-thread
(object-name thunk)
(if group
(parameterize ([current-thread-group (make-thread-group)]) (thread run))
(thread run)))))
p)
(define-syntax delay/thread*
(let ([kwds (list (cons '#:group #'#t))])
(lambda (stx) (make-delayer stx #'delay/thread kwds))))
(define-struct (promise/idle promise/thread) ()
#:property prop:force
(lambda (p)
(reify-result (let ([v (pref p)])
(if (procedure? v)
;; either running-thread, or returns the controller
(let ([controller (if (running-thread? v)
(running-thread-thread v)
(v))])
(thread-send controller 'force!)
(thread-wait controller)
(pref p))
v)))))
(provide (rename-out [delay/idle* delay/idle]))
(define (delay/idle thunk wait-for work-while tick use*)
(define use (cond [(use* . <= . 0) 0] [(use* . >= . 1) 1] [else use*]))
(define work-time (* tick use))
(define rest-time (- tick work-time))
(define (work)
(call-with-exception-handler
(lambda (e) (pset! p (make-reraise e)) (kill-thread (current-thread)))
(lambda () (pset! p (call-with-values thunk list)))))
(define (run)
;; this thread is dedicated to controlling the worker thread, so it's
;; possible to dedicate messages to signaling a `force'.
(define force-evt (thread-receive-evt))
(sync wait-for force-evt)
(pset! p (make-running-thread (object-name thunk) controller-thread))
(let ([worker (parameterize ([current-thread-group (make-thread-group)])
(thread work))])
(cond
[(and (use . >= . 1) (equal? work-while always-evt))
;; as if it was pre-forced
(thread-wait worker)]
[(use . <= . 0)
;; work only when explicitly forced
(thread-suspend worker)
(sync force-evt)
(thread-wait worker)]
[else
(thread-suspend worker)
(let loop ()
;; rest, then wait for idle time, then resume working
(if (eq? (begin0 (or (sync/timeout rest-time force-evt)
(sync work-while force-evt))
(thread-resume worker))
force-evt)
;; forced during one of these => let it run to completion
(thread-wait worker)
;; not forced
(unless (sync/timeout work-time worker)
(thread-suspend worker)
(loop))))])))
;; I don't think that a thread-group here is needed, but it doesn't hurt
(define controller-thread
(parameterize ([current-thread-group (make-thread-group)])
(thread run)))
;; the thunk is not really used in the above, make it a function that returns
;; the controller thread so it can be forced (used in the `prop:force')
(define p (make-promise/idle
(procedure-rename (lambda () controller-thread)
(or (object-name thunk) 'idle-thread))))
p)
(define-syntax delay/idle*
(let ([kwds (list (cons '#:wait-for #'(system-idle-evt))
(cons '#:work-while #'(system-idle-evt))
(cons '#:tick #'0.2)
(cons '#:use #'0.12))])
(lambda (stx) (make-delayer stx #'delay/idle kwds))))