From 34fe42d0dda1d9729feb93ed132fbbb8bbc412f1 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Sun, 5 May 2013 02:00:12 -0400 Subject: [PATCH] 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). --- collects/racket/list.rkt | 53 ++-- collects/racket/private/promise.rkt | 21 +- collects/racket/promise.rkt | 292 ++++++++++----------- collects/scribblings/reference/pairs.scrbl | 39 +-- 4 files changed, 201 insertions(+), 204 deletions(-) diff --git a/collects/racket/list.rkt b/collects/racket/list.rkt index 7d63cdaf74..430587f58a 100644 --- a/collects/racket/list.rkt +++ b/collects/racket/list.rkt @@ -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)])) diff --git a/collects/racket/private/promise.rkt b/collects/racket/private/promise.rkt index 92e1decc8d..f916425194 100644 --- a/collects/racket/private/promise.rkt +++ b/collects/racket/private/promise.rkt @@ -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-name this)))) ;; ---------------------------------------------------------------------------- ;; Utilities diff --git a/collects/racket/promise.rkt b/collects/racket/promise.rkt index c052ae3bca..8d807d366d 100644 --- a/collects/racket/promise.rkt +++ b/collects/racket/promise.rkt @@ -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 - ;; `#', 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 + ;; #, 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)))) diff --git a/collects/scribblings/reference/pairs.scrbl b/collects/scribblings/reference/pairs.scrbl index 2b904c00e6..0e3b6639a0 100644 --- a/collects/scribblings/reference/pairs.scrbl +++ b/collects/scribblings/reference/pairs.scrbl @@ -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]