Some style cleanups.

Mainly reogranize the code + exports + docs of the additional list
convenience functions.

Also, add a custom printer to a "running" struct in
`racket/private/promise', so there's a sensible output if the value
happens to leak outside of a promise (eg, when debugging).
This commit is contained in:
Eli Barzilay 2013-05-05 02:00:12 -04:00
parent aa933891c5
commit 34fe42d0dd
4 changed files with 201 additions and 204 deletions

View File

@ -31,14 +31,13 @@
count
partition
argmin
argmax
;; convenience
range
append-map
filter-not
shuffle
range)
argmin
argmax)
(define (first x)
(if (and (pair? x) (list? x))
@ -88,8 +87,8 @@
(cdr l)
(raise-argument-error 'rest "(and/c list? (not/c empty?))" l)))
(define cons? (lambda (l) (pair? l)))
(define empty? (lambda (l) (null? l)))
(define (cons? l) (pair? l))
(define (empty? l) (null? l))
(define empty '())
(define (make-list n x)
@ -317,7 +316,7 @@
;; and for equalities other than `eq?' or `equal?' The length threshold
;; above (40) was determined by trying it out with lists of length n
;; holding (random n) numbers.
(let ([key (or key (lambda (x) x))])
(let ([key (or key (λ(x) x))])
(let-syntax ([loop (syntax-rules ()
[(_ search)
(let loop ([l l] [seen null])
@ -330,8 +329,7 @@
(cond [(eq? =? equal?) (loop member)]
[(eq? =? eq?) (loop memq)]
[(eq? =? eqv?) (loop memv)]
[else (loop (lambda (x seen)
(ormap (lambda (y) (=? x y)) seen)))])))]
[else (loop (λ(x seen) (ormap (λ(y) (=? x y)) seen)))])))]
[else
;; Use a hash for long lists with simple hash tables.
(let-syntax ([loop
@ -351,19 +349,19 @@
(unless (procedure? f)
(raise-argument-error who "procedure?" f))
(unless (procedure-arity-includes? f (add1 (length ls)))
(raise-arguments-error who "mismatch between procedure arity and argument count"
"procedure" f
"expected arity" (add1 (length ls))))
(raise-arguments-error
who "mismatch between procedure arity and argument count"
"procedure" f
"expected arity" (add1 (length ls))))
(unless (and (list? l) (andmap list? ls))
(raise-argument-error
who "list?"
(ormap (lambda (x) (and (not (list? x)) x)) (cons l ls)))))
(for ([x (in-list (cons l ls))])
(unless (list? x) (raise-argument-error who "list?" x)))))
(define (filter-map f l . ls)
(check-filter-arguments 'filter-map f l ls)
(if (pair? ls)
(let ([len (length l)])
(if (andmap (lambda (l) (= len (length l))) ls)
(if (andmap (λ(l) (= len (length l))) ls)
(let loop ([l l] [ls ls])
(if (null? l)
null
@ -383,7 +381,7 @@
(check-filter-arguments 'count f l ls)
(if (pair? ls)
(let ([len (length l)])
(if (andmap (lambda (l) (= len (length l))) ls)
(if (andmap (λ(l) (= len (length l))) ls)
(let loop ([l l] [ls ls] [c 0])
(if (null? l)
c
@ -418,9 +416,16 @@
(let ([x (car l)] [l (cdr l)])
(if (pred x) (loop l (cons x i) o) (loop l i (cons x o)))))))
;; similar to in-range, but returns a list
(define range
(case-lambda
[(end) (for/list ([i (in-range end)]) i)]
[(start end) (for/list ([i (in-range start end)]) i)]
[(start end step) (for/list ([i (in-range start end step)]) i)]))
(define append-map
(case-lambda [(f l) (apply append (map f l))]
[(f l1 l2) (apply append (map f l1 l2))]
(case-lambda [(f l) (apply append (map f l))]
[(f l1 l2) (apply append (map f l1 l2))]
[(f l . ls) (apply append (apply map f l ls))]))
;; this is an exact copy of `filter' in racket/private/list, with the
@ -439,7 +444,7 @@
(loop (cdr l) (if (f (car l)) result (cons (car l) result))))))
(define (shuffle l)
(sort l < #:key (lambda (_) (random)) #:cache-keys? #t))
(sort l < #:key (λ(_) (random)) #:cache-keys? #t))
;; mk-min : (number number -> boolean) symbol (X -> real) (listof X) -> X
(define (mk-min cmp name f xs)
@ -466,13 +471,5 @@
(loop (car xs) new-min (cdr xs))]
[else
(loop min min-var (cdr xs))]))]))))
(define (argmin f xs) (mk-min < 'argmin f xs))
(define (argmax f xs) (mk-min > 'argmax f xs))
;; similar to in-range, but returns a list
(define range
(case-lambda
[(end) (for/list ([i (in-range end)]) i)]
[(start end) (for/list ([i (in-range start end)]) i)]
[(start end step) (for/list ([i (in-range start end step)]) i)]))

View File

@ -173,10 +173,12 @@
(define-struct (composable-promise promise) ()
#:property prop:force force/composable)
;; !!!HACK!!!
;; stepper-syntax-property : like syntax property, but adds properties to an
;; association list associated with the syntax property 'stepper-properties
;; Had to re-define this because of circular dependencies
;; (also defined in stepper/private/syntax-property.rkt)
;; (also defined in stepper/private/syntax-property.rkt), it should
;; either be defined as a generic tool, or removed.
(define-for-syntax stepper-syntax-property
(case-lambda
[(stx tag)
@ -192,7 +194,7 @@
(syntax-property stx 'stepper-properties
(cons (list tag new-val)
(if stepper-props stepper-props '()))))]))
;; template for all delay-like constructs
;; (with simple keyword matching: keywords is an alist with default exprs)
(define-for-syntax (make-delayer stx maker keywords)
@ -271,11 +273,16 @@
(define-struct reraise (val)
#:property prop:procedure (lambda (this) (raise (reraise-val this))))
(define-struct running (name)
#:property prop:procedure (lambda (this)
(let ([name (running-name this)])
(if name
(error 'force "reentrant promise ~.s" name)
(error 'force "reentrant promise")))))
#:property prop:procedure
(lambda (this)
(let ([name (running-name this)])
(if name
(error 'force "reentrant promise ~.s" name)
(error 'force "reentrant promise"))))
#:property prop:custom-write
(lambda (this port write?)
(fprintf port (if write? "#<running:~s>" "#<running:~a>")
(running-name this))))
;; ----------------------------------------------------------------------------
;; Utilities

View File

@ -6,14 +6,14 @@
;; More delay-like values, with different ways of deferring computations
(define-struct (promise/name promise) ()
#:property prop:force (lambda (p) ((pref p))))
#:property prop:force (λ(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 '()))
;; mostly to implement srfi-45's `eager'
(define-struct (promise/strict promise) ()
#:property prop:force (lambda (p) (reify-result (pref p)))) ; never a thunk
#:property prop:force (λ(p) (reify-result (pref p)))) ; never a thunk
(provide (rename-out [delay/strict* delay/strict]))
(define (delay/strict thunk)
;; could use `reify-result' here to capture exceptions too, or just create a
@ -30,130 +30,123 @@
(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?))
(λ(p port write?)
(define v (pref p))
(promise-printer (if (syncinfo? v) (make-promise (syncinfo-thunk v)) p)
port write?))
#:property prop:force
(lambda (p)
(λ(p)
(define v (pref p))
(reify-result
(let ([v (pref p)])
(cond
;; already forced
[(not (syncinfo? v)) v]
;; being forced...
[(running-thread? (syncinfo-thunk v))
;; Note: after `(syncinfo-thunk v)' changes to a `running-thread' instance,
;; it doesn't change again, so we can assume that it's still a `running-thread'
;; instance.
(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 (p v) ; pass `p' and `v' to avoid closure allocation
(let ([thunk (syncinfo-thunk v)]
[done (syncinfo-done-sema v)])
;; Now that we've taken the lock, check thunk' again:
(unless (running-thread? thunk)
;; 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))
(cond
;; already forced
[(not (syncinfo? v)) v]
;; being forced...
[(running-thread? (syncinfo-thunk v))
;; Note: after `(syncinfo-thunk v)' changes to a `running-thread'
;; instance, it doesn't change again, so we can assume that it's still
;; a `running-thread' instance.
(define 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)
(λ(p v) ; pass `p' and `v' to avoid closure allocation
(define thunk (syncinfo-thunk v))
(define done (syncinfo-done-sema v))
;; Now that we've taken the lock, check thunk' again:
(unless (running-thread? thunk)
;; set the thread last
(set-syncinfo-thunk!
v (make-running-thread (object-name thunk) (current-thread)))
(call-with-exception-handler
(λ(e) (pset! p (make-reraise e))
(semaphore-post done)
e)
(lambda ()
(pset! p (call-with-values thunk list))
(semaphore-post done))))))
#f
p v)
;; whether it was this thread that forced it or not, the results are
;; now in
(pref p)]))))
(λ() (pset! p (call-with-values thunk list))
(semaphore-post done)))))
#f
p v)
;; 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)])
(wrap-evt (if (syncinfo? v) (syncinfo-done-evt v) always-evt) void))))
(λ(p) (define v (pref p))
(wrap-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 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)
(let ([t (running-thread-thread v)])
(thread-wait t)
(let ([v (pref p)])
(if (running-thread? v)
(error 'force "promise's thread terminated without result or exception\n promise: ~e" p)
v)))
v))))
(λ(p) (define v (pref p))
(reify-result
(if (running-thread? v)
(let ([t (running-thread-thread v)])
(thread-wait t)
(define v (pref p))
(if (running-thread? v)
(error 'force "promise's thread terminated ~a\n promise: ~e"
"without result or exception" p)
v))
v)))
#:property prop:evt
(lambda (p)
(let ([v (pref p)])
(wrap-evt (if (running? v) (running-thread-thread v) always-evt)
void))))
(λ(p) (define v (pref p))
(wrap-evt (if (running? v) (running-thread-thread v) always-evt)
void)))
(provide (rename-out [delay/thread* delay/thread]))
(define (delay/thread thunk group)
(unless (or (not group)
(thread-group? group))
(raise-argument-error 'delay/thread "(or/c thread-group? #f)" group))
(let ([starter (make-semaphore)])
(define (run)
(semaphore-wait starter) ; wait until p is properly defined
(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 group]) (thread run))
(thread run)))))
;; The promise thread needs to wait until `p' is properly defined.
;; Otherwise, if the thread starts after `(thread run)' is evaluated, but
;; before `p' is defined, we end up doing `unsafe-struct-set!' on
;; `#<undefined>', which is bad.
;; This was the cause of an intermittent failure in the Typed Racket test
;; suite.
(semaphore-post starter)
p))
(define initialized-sema (make-semaphore))
(define (run)
(semaphore-wait initialized-sema) ; wait until p is properly defined
(call-with-exception-handler
(λ(e) (pset! p (make-reraise e)) (kill-thread (current-thread)))
(λ() (pset! p (call-with-values thunk list)))))
(define p
(make-promise/thread
(make-running-thread
(object-name thunk)
(if group
(parameterize ([current-thread-group group]) (thread run))
(thread run)))))
;; The promise thread needs to wait until `p' is defined and assigned its
;; value, otherwise the `run' thread can start when `p' is still
;; #<undefined>, and end up doing `unsafe-struct-set!' on it. This was the
;; cause of an intermittent failure in the Typed Racket test suite.
(semaphore-post initialized-sema)
p)
(define-syntax delay/thread*
(let ([kwds (list (cons '#:group #'(make-thread-group)))])
(lambda (stx) (make-delayer stx #'delay/thread kwds))))
(λ(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)))))
(λ(p) (define v (pref p))
(reify-result
(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*)
@ -165,58 +158,57 @@
(raise-argument-error 'delay/idle "(>=/c 0.0)" tick))
(unless (real? use*)
(raise-argument-error 'delay/idle "real?" use*))
(let ()
(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 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
(λ(e) (pset! p (make-reraise e)) (kill-thread (current-thread)))
(λ() (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))
(define 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 (λ() 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))))
(λ(stx) (make-delayer stx #'delay/idle kwds))))

View File

@ -1104,6 +1104,25 @@ but @racket[pred] is applied to each item in @racket[lst] only once.
(partition even? '(1 2 3 4 5 6))]}
@defproc*[([(range [end real?]) list?]
[(range [start real?] [end real?] [step real? 1]) list?])]{
Similar to @racket[in-range], but returns lists.
The resulting list holds numbers starting at @racket[start] and whose
successive elements are computed by adding @racket[step] to their
predecessor until @racket[end] (excluded) is reached. If no starting
point is provided, @racket[0] is used. If no @racket[step] argument is
provided, @racket[1] is used.
@mz-examples[#:eval list-eval
(range 10)
(range 10 20)
(range 20 40 2)
(range 20 10 -1)
(range 10 15 1.5)]}
@defproc[(append-map [proc procedure?] [lst list?] ...+)
list?]{
@ -1143,6 +1162,7 @@ result of @racket[proc]. Signals an error on an empty list.
(argmin car '((3 pears) (1 banana) (2 apples)))
(argmin car '((1 banana) (1 orange)))]}
@defproc[(argmax [proc (-> any/c real?)] [lst (and/c pair? list?)])
any/c]{
@ -1154,25 +1174,6 @@ result of @racket[proc]. Signals an error on an empty list.
(argmax car '((3 pears) (3 oranges)))]}
@defproc*[([(range [end real?]) list?]
[(range [start real?] [end real?] [step real? 1]) list?])]{
Similar to @racket[in-range], but returns lists.
The resulting list holds numbers starting at @racket[start] and whose
successive elements are computed by adding @racket[step] to their
predecessor until @racket[end] (excluded) is reached. If no starting
point is provided, @racket[0] is used. If no @racket[step] argument is
provided, @racket[1] is used.
@mz-examples[#:eval list-eval
(range 10)
(range 10 20)
(range 20 40 2)
(range 20 10 -1)
(range 10 15 1.5)]}
@close-eval[list-eval]