From 9cc6cd0db45546f7c645b6b4074e3e0e1d5023b3 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Sat, 5 Dec 2009 09:28:41 +0000 Subject: [PATCH] moved extra promise types back to scheme/promise svn: r17207 --- collects/scheme/private/promise.ss | 193 ++--------------------------- collects/scheme/promise.ss | 179 +++++++++++++++++++++++++- 2 files changed, 188 insertions(+), 184 deletions(-) diff --git a/collects/scheme/private/promise.ss b/collects/scheme/private/promise.ss index 6d2454585c..314f073e46 100644 --- a/collects/scheme/private/promise.ss +++ b/collects/scheme/private/promise.ss @@ -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)))) - ) #| diff --git a/collects/scheme/promise.ss b/collects/scheme/promise.ss index b6a3844f36..ab67dd1848 100644 --- a/collects/scheme/promise.ss +++ b/collects/scheme/promise.ss @@ -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))))