From a4799be53c07f1b3bc7dc5403d3827f8d1be7d84 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Thu, 15 Jan 2009 21:29:26 +0000 Subject: [PATCH 01/13] added support for customizing the edge label font to the graph library and propogated that argument to the redex traces and traces/ps functions svn: r13155 --- collects/mrlib/graph.ss | 11 ++++++++++- .../graph/graph-pasteboard-mixin.scrbl | 8 ++++++++ collects/redex/gui.ss | 6 ++++-- collects/redex/private/traces.ss | 10 +++++++--- collects/redex/redex.scrbl | 16 +++++++++------- 5 files changed, 38 insertions(+), 13 deletions(-) diff --git a/collects/mrlib/graph.ss b/collects/mrlib/graph.ss index 83b692a938..775208d6e2 100644 --- a/collects/mrlib/graph.ss +++ b/collects/mrlib/graph.ss @@ -231,6 +231,8 @@ (mixin ((class->interface pasteboard%)) (graph-pasteboard<%>) (inherit find-first-snip find-next-selected-snip) + (init-field [edge-label-font #f]) + (define draw-arrow-heads? #t) (inherit refresh get-admin) (define/public (set-draw-arrow-heads? x) @@ -248,6 +250,8 @@ (unbox wb) (unbox hb)))))) + + (define arrowhead-angle-width (* 1/4 pi)) (define arrowhead-short-side 8) (define arrowhead-long-side 12) @@ -484,7 +488,12 @@ (define/override (on-paint before? dc left top right bottom dx dy draw-caret) (when before? - (draw-edges dc left top right bottom dx dy)) + (let ([old-font (send dc get-font)]) + (when edge-label-font + (send dc set-font edge-label-font)) + (draw-edges dc left top right bottom dx dy) + (when edge-label-font + (send dc set-font old-font)))) (super on-paint before? dc left top right bottom dx dy draw-caret)) (define/public (draw-edges dc left top right bottom dx dy) diff --git a/collects/mrlib/scribblings/graph/graph-pasteboard-mixin.scrbl b/collects/mrlib/scribblings/graph/graph-pasteboard-mixin.scrbl index d74956f9a7..09bdd124b2 100644 --- a/collects/mrlib/scribblings/graph/graph-pasteboard-mixin.scrbl +++ b/collects/mrlib/scribblings/graph/graph-pasteboard-mixin.scrbl @@ -3,5 +3,13 @@ @defmixin/title[graph-pasteboard-mixin (pasteboard%) (graph-pasteboard<%>)]{ +@defconstructor/auto-super[([edge-label-font (or/c #f (is-a?/c font%)) #f])]{ + +If @scheme[edge-label-font] is supplied, it is used when drawing the +labels on the edges. Otherwise, the font is not set before drawing +the labels, defaulting to the @scheme[dc<%>] object's font. + +} + This mixin overrides many methods to draw lines between @scheme[graph-snip<%>] that it contains.} diff --git a/collects/redex/gui.ss b/collects/redex/gui.ss index 4049673df4..4983c60e21 100644 --- a/collects/redex/gui.ss +++ b/collects/redex/gui.ss @@ -35,7 +35,8 @@ #:pp pp-contract #:colors (listof (list/c string? string?)) #:scheme-colors? boolean? - #:layout (-> any/c any/c)) + #:layout (-> any/c any/c) + #:edge-label-font (or/c #f (is-a?/c font%))) any)] [traces/ps (->* (reduction-relation? any/c @@ -46,7 +47,8 @@ (any/c term-node? . -> . any)) #:pp pp-contract #:colors (listof any/c) - #:layout (-> any/c any/c)) + #:layout (-> any/c any/c) + #:edge-label-font (or/c #f (is-a?/c font%))) any)] [term-node? (-> any/c boolean?)] diff --git a/collects/redex/private/traces.ss b/collects/redex/private/traces.ss index 4098ff0f78..57befd42bf 100644 --- a/collects/redex/private/traces.ss +++ b/collects/redex/private/traces.ss @@ -131,7 +131,9 @@ #:pp [pp default-pretty-printer] #:scheme-colors? [scheme-colors? #t] #:colors [colors '()] - #:layout [layout void]) + #:layout [layout void] + #:edge-label-font [edge-label-font #f] + ) (let-values ([(graph-pb canvas) (traces reductions pre-exprs #:no-show-frame? #t @@ -140,7 +142,8 @@ #:pp pp #:scheme-colors? scheme-colors? #:colors colors - #:layout layout)]) + #:layout layout + #:edge-label-font edge-label-font)]) (print-to-ps graph-pb canvas filename))) (define (print-to-ps graph-pb canvas filename) @@ -227,11 +230,12 @@ #:colors [colors '()] #:scheme-colors? [scheme-colors? #t] #:layout [layout void] + #:edge-label-font [edge-label-font #f] #:no-show-frame? [no-show-frame? #f]) (define exprs (if multiple? pre-exprs (list pre-exprs))) (define main-eventspace (current-eventspace)) (define saved-parameterization (current-parameterization)) - (define graph-pb (new graph-pasteboard% [layout layout])) + (define graph-pb (new graph-pasteboard% [layout layout] [edge-label-font edge-label-font])) (define f (instantiate red-sem-frame% () (label "PLT Redex Reduction Graph") (style '(toolbar-button)) diff --git a/collects/redex/redex.scrbl b/collects/redex/redex.scrbl index b02ee88aef..1b35f0eafd 100644 --- a/collects/redex/redex.scrbl +++ b/collects/redex/redex.scrbl @@ -1157,7 +1157,8 @@ exploring reduction sequences. (lambda (x) (member (length x) '(2 3 4 6))))))] [#:scheme-colors? scheme-colors? boolean?] - [#:layout layout (-> (listof term-node?) void)]) + [#:layout layout (-> (listof term-node?) void)] + [#:edge-label-font edge-label-font (or/c #f (is-a?/c font%)) #f]) void?]{ This function opens a new window and inserts each expression @@ -1169,7 +1170,7 @@ found, or no more reductions can occur. It inserts each new term into the gui. Clicking the @onscreen{reduce} button reduces until reduction-steps-cutoff more terms are found. -The pred function indicates if a term has a particular +The @scheme[pred] function indicates if a term has a particular property. If it returns @scheme[#f], the term is displayed with a pink background. If it returns a string or a @scheme[color%] object, the term is displayed with a background of that color (using @@ -1211,8 +1212,6 @@ the color that fills the arrow head. If fewer than six colors are specified, the colors specified colors are used and then defaults are filled in for the remaining colors. - - The @scheme[scheme-colors?] argument, if @scheme[#t] causes @scheme[traces] to color the contents of each of the windows according to DrScheme's Scheme mode color Scheme. If it is @scheme[#f], @@ -1224,8 +1223,10 @@ after new terms are inserted in response to the user clicking on the reduce button, and after the initial set of terms is inserted. See also @scheme[term-node-set-position!]. -You can save the contents of the window as a postscript file -from the menus. +The @scheme[edge-label-font] argument is used as the font on the edge +labels. If nothign is suppled, the @scheme[dc<%>] object's default +font is used. + } @defproc[(traces/ps [reductions reduction-relation?] @@ -1241,7 +1242,8 @@ from the menus. (any output-port number (is-a?/c text%) -> void)) default-pretty-printer] [#:colors colors (listof (list string string)) '()] - [#:layout layout (-> (listof term-node?) void)]) + [#:layout layout (-> (listof term-node?) void)] + [#:edge-label-font edge-label-font (or/c #f (is-a?/c font%)) #f]) void?]{ The arguments behave just like the function @scheme[traces], but From 76657082d96b4bd7503fe2d44c658c601f4d87db Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Thu, 15 Jan 2009 23:12:32 +0000 Subject: [PATCH 02/13] better errorage svn: r13156 --- collects/test-engine/scheme-tests.ss | 52 ++++++++++------------------ 1 file changed, 19 insertions(+), 33 deletions(-) diff --git a/collects/test-engine/scheme-tests.ss b/collects/test-engine/scheme-tests.ss index 6792540455..f06db2c1d9 100644 --- a/collects/test-engine/scheme-tests.ss +++ b/collects/test-engine/scheme-tests.ss @@ -90,19 +90,14 @@ ;; check-expect (define-syntax (check-expect stx) + (unless (check-context?) + (raise-syntax-error 'check-expect CHECK-EXPECT-DEFN-STR stx)) (syntax-case stx () [(_ test actual) - (check-context?) - (check-expect-maker stx #'check-values-expected (list #`(lambda () test) #`actual) 'comes-from-check-expect)] - [(_ test) - (check-context?) - (raise-syntax-error 'check-expect CHECK-EXPECT-STR stx)] - [(_ test actual extra ...) - (check-context?) - (raise-syntax-error 'check-expect CHECK-EXPECT-STR stx)] - [(_ test ...) - (not (check-context?)) - (raise-syntax-error 'check-expect CHECK-EXPECT-DEFN-STR stx)])) + (check-expect-maker stx #'check-values-expected + (list #`(lambda () test) #`actual) + 'comes-from-check-expect)] + [_ (raise-syntax-error 'check-expect CHECK-EXPECT-STR stx)])) ;; check-values-expected: (-> scheme-val) scheme-val src -> void (define (check-values-expected test actual src test-info) @@ -113,23 +108,16 @@ (lambda (src v1 v2 _) (make-unequal src v1 v2)) test actual #f src test-info 'check-expect)) + (define-syntax (check-within stx) + (unless (check-context?) + (raise-syntax-error 'check-within CHECK-WITHIN-DEFN-STR stx)) (syntax-case stx () [(_ test actual within) - (check-context?) - (check-expect-maker stx #'check-values-within (list #`(lambda () test) #`actual #`within) 'comes-from-check-within)] - [(_ test actual) - (check-context?) - (raise-syntax-error 'check-within CHECK-WITHIN-STR stx)] - [(_ test) - (check-context?) - (raise-syntax-error 'check-within CHECK-WITHIN-STR stx)] - [(_ test actual within extra ...) - (check-context?) - (raise-syntax-error 'check-within CHECK-WITHIN-STR stx)] - [(_ test ...) - (not (check-context?)) - (raise-syntax-error 'check-within CHECK-WITHIN-DEFN-STR stx)])) + (check-expect-maker stx #'check-values-within + (list #`(lambda () test) #`actual #`within) + 'comes-from-check-within)] + [_ (raise-syntax-error 'check-within CHECK-WITHIN-STR stx)])) (define (check-values-within test actual within src test-info) (error-check number? within CHECK-WITHIN-INEXACT-FMT) @@ -140,16 +128,14 @@ (define-syntax (check-error stx) + (unless (check-context?) + (raise-syntax-error 'check-error CHECK-ERROR-DEFN-STR stx)) (syntax-case stx () [(_ test error) - (check-context?) - (check-expect-maker stx #'check-values-error (list #'(lambda () test) #`error) 'comes-from-check-error)] - [(_ test) - (check-context?) - (raise-syntax-error 'check-error CHECK-ERROR-STR stx)] - [(_ test ...) - (not (check-context?)) - (raise-syntax-error 'check-error CHECK-ERROR-DEFN-STR stx)])) + (check-expect-maker stx #'check-values-error + (list #'(lambda () test) #`error) + 'comes-from-check-error)] + [_ (raise-syntax-error 'check-error CHECK-ERROR-STR stx)])) (define (check-values-error test error src test-info) (error-check string? error CHECK-ERROR-STR-FMT) From 822a536b7fd0f38b2d3b3a8ccb7f3d385f12ff37 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Thu, 15 Jan 2009 23:41:39 +0000 Subject: [PATCH 03/13] fix check-expect-maker contract, reorganize code svn: r13157 --- collects/test-engine/scheme-tests.ss | 71 +++++++++++++++------------- 1 file changed, 38 insertions(+), 33 deletions(-) diff --git a/collects/test-engine/scheme-tests.ss b/collects/test-engine/scheme-tests.ss index f06db2c1d9..b954a17792 100644 --- a/collects/test-engine/scheme-tests.ss +++ b/collects/test-engine/scheme-tests.ss @@ -49,40 +49,45 @@ ;; (make-expected-error src string scheme-val) (define-struct (expected-error check-fail) (message value)) -;; check-expect-maker : syntax? syntax? (listof syntax?) -> syntax? +;; check-expect-maker : syntax? syntax? (listof syntax?) symbol? -> syntax? ;; the common part of all three test forms. -(define-for-syntax (check-expect-maker stx checker-proc-stx embedded-stxes hint-tag) - (with-syntax ([bogus-name (stepper-syntax-property #`#,(gensym 'test) 'stepper-hide-completed #t)] - [src-info (with-stepper-syntax-properties (['stepper-skip-completely #t]) - #`(list #,@(list #`(quote #,(syntax-source stx)) - (syntax-line stx) - (syntax-column stx) - (syntax-position stx) - (syntax-span stx))))]) - (quasisyntax/loc stx - (define bogus-name - #,(stepper-syntax-property - #`(let ([test-info (namespace-variable-value - 'test~object #f builder (current-namespace))]) - (when test-info - (insert-test test-info - (lambda () - #,(with-stepper-syntax-properties (['stepper-hint hint-tag] - ['stepper-hide-reduction #t] - ['stepper-use-val-as-final #t]) - (quasisyntax/loc stx - (#,checker-proc-stx - #,@embedded-stxes - src-info - #,(with-stepper-syntax-properties (['stepper-no-lifting-info #t] - ['stepper-hide-reduction #t]) - #'test-info)))))))) - 'stepper-skipto - (append skipto/third ;; let - skipto/third skipto/second ;; unless (it expands into a begin) - skipto/cdr skipto/third ;; application of insert-test - '(syntax-e cdr cdr syntax-e car) ;; lambda - )))))) +(define-for-syntax (check-expect-maker stx checker-proc-stx embedded-stxes + hint-tag) + (define bogus-name + (stepper-syntax-property #`#,(gensym 'test) 'stepper-hide-completed #t)) + (define src-info + (with-stepper-syntax-properties (['stepper-skip-completely #t]) + #`(list #,@(list #`(quote #,(syntax-source stx)) + (syntax-line stx) + (syntax-column stx) + (syntax-position stx) + (syntax-span stx))))) + (quasisyntax/loc stx + (define #,bogus-name + #,(stepper-syntax-property + #`(let ([test-info (namespace-variable-value + 'test~object #f builder (current-namespace))]) + (when test-info + (insert-test test-info + (lambda () + #,(with-stepper-syntax-properties + (['stepper-hint hint-tag] + ['stepper-hide-reduction #t] + ['stepper-use-val-as-final #t]) + (quasisyntax/loc stx + (#,checker-proc-stx + #,@embedded-stxes + #,src-info + #,(with-stepper-syntax-properties + (['stepper-no-lifting-info #t] + ['stepper-hide-reduction #t]) + #'test-info)))))))) + 'stepper-skipto + (append skipto/third ;; let + skipto/third skipto/second ;; unless (it expands into a begin) + skipto/cdr skipto/third ;; application of insert-test + '(syntax-e cdr cdr syntax-e car) ;; lambda + ))))) (define-for-syntax (check-context?) (let ([c (syntax-local-context)]) From cac38f95cb2a52de47f1a741cdbfa24d4381c610 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Thu, 15 Jan 2009 23:53:51 +0000 Subject: [PATCH 04/13] use the test expression as the source for the whole expression, so it is all shown as uncovered until executed svn: r13158 --- collects/test-engine/scheme-tests.ss | 16 +++++++--------- 1 file changed, 7 insertions(+), 9 deletions(-) diff --git a/collects/test-engine/scheme-tests.ss b/collects/test-engine/scheme-tests.ss index b954a17792..c2a3746011 100644 --- a/collects/test-engine/scheme-tests.ss +++ b/collects/test-engine/scheme-tests.ss @@ -51,8 +51,8 @@ ;; check-expect-maker : syntax? syntax? (listof syntax?) symbol? -> syntax? ;; the common part of all three test forms. -(define-for-syntax (check-expect-maker stx checker-proc-stx embedded-stxes - hint-tag) +(define-for-syntax (check-expect-maker + stx checker-proc-stx test-expr embedded-stxes hint-tag) (define bogus-name (stepper-syntax-property #`#,(gensym 'test) 'stepper-hide-completed #t)) (define src-info @@ -62,7 +62,7 @@ (syntax-column stx) (syntax-position stx) (syntax-span stx))))) - (quasisyntax/loc stx + (quasisyntax/loc test-expr (define #,bogus-name #,(stepper-syntax-property #`(let ([test-info (namespace-variable-value @@ -76,6 +76,7 @@ ['stepper-use-val-as-final #t]) (quasisyntax/loc stx (#,checker-proc-stx + (lambda () #,test-expr) #,@embedded-stxes #,src-info #,(with-stepper-syntax-properties @@ -99,8 +100,7 @@ (raise-syntax-error 'check-expect CHECK-EXPECT-DEFN-STR stx)) (syntax-case stx () [(_ test actual) - (check-expect-maker stx #'check-values-expected - (list #`(lambda () test) #`actual) + (check-expect-maker stx #'check-values-expected #`test (list #`actual) 'comes-from-check-expect)] [_ (raise-syntax-error 'check-expect CHECK-EXPECT-STR stx)])) @@ -119,8 +119,7 @@ (raise-syntax-error 'check-within CHECK-WITHIN-DEFN-STR stx)) (syntax-case stx () [(_ test actual within) - (check-expect-maker stx #'check-values-within - (list #`(lambda () test) #`actual #`within) + (check-expect-maker stx #'check-values-within #`test (list #`actual #`within) 'comes-from-check-within)] [_ (raise-syntax-error 'check-within CHECK-WITHIN-STR stx)])) @@ -137,8 +136,7 @@ (raise-syntax-error 'check-error CHECK-ERROR-DEFN-STR stx)) (syntax-case stx () [(_ test error) - (check-expect-maker stx #'check-values-error - (list #'(lambda () test) #`error) + (check-expect-maker stx #'check-values-error #`test (list #`error) 'comes-from-check-error)] [_ (raise-syntax-error 'check-error CHECK-ERROR-STR stx)])) From b81ea02cabbe8959f792850a84da9487d0e271ac Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Fri, 16 Jan 2009 05:18:37 +0000 Subject: [PATCH 05/13] add more tests, mainly for catching exceptions and other raised values svn: r13159 --- collects/tests/mzscheme/promise.ss | 15 +++++++++++++++ 1 file changed, 15 insertions(+) diff --git a/collects/tests/mzscheme/promise.ss b/collects/tests/mzscheme/promise.ss index a7611de434..51e011e383 100644 --- a/collects/tests/mzscheme/promise.ss +++ b/collects/tests/mzscheme/promise.ss @@ -70,4 +70,19 @@ (t (force (lazy (lazy (lazy (force (delay (delay _)))))))) (t (force (lazy (lazy (delay (force (lazy (delay _))))))))) +;; more tests +(let () + (define (force+catch x) + (with-handlers ([void (lambda (x) (cons 'catch x))]) (force x))) + ;; results are cached + (let ([x (delay (random 10000))]) + (test #t equal? (force x) (force x))) + ;; errors are cached + (let ([x (delay (error 'foo "blah"))]) + (test #t equal? (force+catch x) (force+catch x))) + ;; other raised values are cached + (let ([x (delay (raise (random 10000)))]) + (test #t equal? (force+catch x) (force+catch x))) + ) + (report-errs) From a76cdc248fc2a010b1a815518d4c05c0c47b4b1f Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Fri, 16 Jan 2009 05:46:07 +0000 Subject: [PATCH 06/13] added promise-forced? and promise-running? svn: r13160 --- collects/scheme/promise.ss | 53 ++++++++++++++------ collects/scribblings/reference/promise.scrbl | 13 +++++ collects/tests/mzscheme/promise.ss | 22 +++++--- 3 files changed, 64 insertions(+), 24 deletions(-) diff --git a/collects/scheme/promise.ss b/collects/scheme/promise.ss index d604f2e4e7..084dbb1cd0 100644 --- a/collects/scheme/promise.ss +++ b/collects/scheme/promise.ss @@ -2,7 +2,7 @@ (#%require "private/small-scheme.ss" "private/more-scheme.ss" "private/define.ss" (rename "private/define-struct.ss" define-struct define-struct*) (for-syntax '#%kernel "private/stxcase-scheme.ss")) -(#%provide lazy delay force promise?) +(#%provide lazy delay force promise? promise-forced? promise-running?) ;; This module implements "lazy" (composable) promises and a `force' ;; that is iterated through them. @@ -23,6 +23,11 @@ (fprintf port "#" (exn-message v)) (fprintf port (if write? "#" "#") `(raise ,v))))] + [(running? p) + (let ([n (running-name p)]) + (if n + (fprintf port "#" n) + (fprintf port "#")))] [(procedure? p) (cond [(object-name p) => (lambda (n) (fprintf port "#" n))] @@ -58,12 +63,21 @@ 'inferred-name (syntax-local-name))]) (syntax/loc stx (make-promise proc)))])) -;; use this to create a value to be raised, make it a procedure so no other -;; code need to change (we could just use the exceptions -- but any value can -;; be raised); also make it have a proper printer so we can show such promises -;; properly. +;; For simplicity and efficiency this code uses thunks in promise values for +;; exceptions: this way, we don't need to tag exception values in some special +;; way and test for them -- we just use a thunk that will raise the exception. +;; But it's still useful to refer to the exception value, so use an applicable +;; struct for them. The same goes for a promise that is being forced: we use a +;; thunk that will throw a "reentrant promise" error -- and use an applicable +;; struct so it is identifiable. (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 ~v" name) + (error 'force "reentrant promise"))))) ;; Creates a promise that does not compose ;; X = (force (delay X)) = (force (lazy (delay X))) @@ -100,21 +114,17 @@ (set-promise-val! root (list v)) v)))) -;; this is used during computation to avoid reentrant loops (which makes it -;; non-r5rs, but there's no good uses for allowing that) -(define (running proc) - ;; important: be careful not to close over the thunk! - (let ([name (object-name proc)]) - (if name - (lambda () (error 'force "reentrant promise ~v" name)) - (lambda () (error 'force "reentrant promise"))))) - (define (force promise) (if (promise? promise) (let loop ([p (promise-val promise)]) (cond [(procedure? p) - ;; "mark" root as running (avoids cycles) - (set-promise-val! promise (running p)) + ;; mark the root as running: avoids cycles, and no need to keep + ;; banging the root promise value; it makes this non-r5rs, but + ;; only practical uses of these things could be ones that use + ;; state. + ;; (careful: avoid holding a reference to the thunk, to allow + ;; safe-for-space loops) + (set-promise-val! promise (make-running (object-name p))) (call-with-exception-handler (lambda (e) (set-promise-val! promise (make-reraise e)) e) (lambda () (force-proc p promise)))] @@ -125,4 +135,15 @@ ;; different from srfi-45: identity for non-promises promise)) +(define (promise-forced? promise) + (if (promise? promise) + (let ([p (promise-val promise)]) + (or (not (procedure? p)) (reraise? p))) ; #f when running + (raise-type-error 'promise-forced? "promise" promise))) + +(define (promise-running? promise) + (if (promise? promise) + (running? (promise-val promise)) + (raise-type-error 'promise-running? "promise" promise))) + ) diff --git a/collects/scribblings/reference/promise.scrbl b/collects/scribblings/reference/promise.scrbl index d8c2af3254..de52cd3d70 100644 --- a/collects/scribblings/reference/promise.scrbl +++ b/collects/scribblings/reference/promise.scrbl @@ -22,6 +22,7 @@ otherwise.} Creates a promise that, when @scheme[force]d, evaluates @scheme[expr] to produce its value.} + @defform[(lazy expr)]{ Like @scheme[delay], except that if @scheme[expr] produces a promise, @@ -31,6 +32,7 @@ mostly useful for implementing lazy libraries and languages. Also note that the @scheme[expr] in this case is restricted to one that produces a single value.} + @defproc[(force [v any/c]) any]{ If @scheme[v] is a promise, then the promise is forced to obtain a @@ -44,3 +46,14 @@ If @scheme[v] is @scheme[force]d again before the original call to @scheme[force] returns, then the @exnraise[exn:fail]. If @scheme[v] is not a promise, then it is returned as the result.} + + +@defproc[(promise-forced? [promise promise?]) boolean?]{ + +Returns @scheme[#t] if @scheme[promise] has been forced.} + + +@defproc[(promise-running? [promise promise?]) boolean?]{ + +Returns @scheme[#t] if @scheme[promise] is currently being forced. +(Note that a promise can be either running or forced but not both.)} diff --git a/collects/tests/mzscheme/promise.ss b/collects/tests/mzscheme/promise.ss index 51e011e383..8ff0f3ed14 100644 --- a/collects/tests/mzscheme/promise.ss +++ b/collects/tests/mzscheme/promise.ss @@ -72,17 +72,23 @@ ;; more tests (let () - (define (force+catch x) - (with-handlers ([void (lambda (x) (cons 'catch x))]) (force x))) + (define (force+catch p) + (with-handlers ([void (lambda (x) (cons 'catch x))]) (force p))) + (define (forced+running? p) (list (promise-forced? p) (promise-running? p))) ;; results are cached - (let ([x (delay (random 10000))]) - (test #t equal? (force x) (force x))) + (let ([p (delay (random 10000))]) + (test #t equal? (force p) (force p))) ;; errors are cached - (let ([x (delay (error 'foo "blah"))]) - (test #t equal? (force+catch x) (force+catch x))) + (let ([p (delay (error 'foo "blah"))]) + (test #t equal? (force+catch p) (force+catch p))) ;; other raised values are cached - (let ([x (delay (raise (random 10000)))]) - (test #t equal? (force+catch x) (force+catch x))) + (let ([p (delay (raise (random 10000)))]) + (test #t equal? (force+catch p) (force+catch p))) + ;; test the predicates + (letrec ([p (delay (forced+running? p))]) + (test '(#f #f) forced+running? p) + (test '(#f #t) force p) + (test '(#t #f) forced+running? p)) ) (report-errs) From 99592959b8878347b341a28b4bfdfadb4439e5a2 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Fri, 16 Jan 2009 05:49:16 +0000 Subject: [PATCH 07/13] fix display/write swap, use ~s for exn-messages svn: r13161 --- collects/scheme/promise.ss | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/collects/scheme/promise.ss b/collects/scheme/promise.ss index 084dbb1cd0..b1ba98a699 100644 --- a/collects/scheme/promise.ss +++ b/collects/scheme/promise.ss @@ -20,8 +20,9 @@ (cond [(reraise? p) (let ([v (reraise-val p)]) (if (exn? v) - (fprintf port "#" (exn-message v)) - (fprintf port (if write? "#" "#") + (fprintf port (if write? "#" "#") + (exn-message v)) + (fprintf port (if write? "#" "#") `(raise ,v))))] [(running? p) (let ([n (running-name p)]) From 856a91865b2af004f35b69dc2237722ebb5412cc Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Fri, 16 Jan 2009 08:42:17 +0000 Subject: [PATCH 08/13] avoid using force/delay (see comment) svn: r13162 --- collects/web-server/private/mime-types.ss | 17 +++++++++++++---- 1 file changed, 13 insertions(+), 4 deletions(-) diff --git a/collects/web-server/private/mime-types.ss b/collects/web-server/private/mime-types.ss index b129767d36..af0c01fb76 100644 --- a/collects/web-server/private/mime-types.ss +++ b/collects/web-server/private/mime-types.ss @@ -1,7 +1,6 @@ #lang scheme/base (require scheme/contract - scheme/match - scheme/promise) + scheme/match) (require "util.ss" web-server/http) (provide/contract @@ -32,11 +31,21 @@ ;; 1. Can we determine the mime type based on file contents? ;; 2. Assuming that 7-bit ASCII is correct for mime-type (define (make-path->mime-type a-path) - (define MIME-TYPE-TABLE (delay (read-mime-types a-path))) + ;; it would be nice to just use delay/force -- but this can be called by + ;; multiple threads at the same time, causing a "reentrant promise" error. + (define sema (make-semaphore 1)) + (define MIME-TYPE-TABLE #f) (lambda (path) (match (path->bytes path) [(regexp #rx#".*\\.([^\\.]*$)" (list _ sffx)) - (hash-ref (force MIME-TYPE-TABLE) + (hash-ref (or MIME-TYPE-TABLE + (dynamic-wind + (lambda () (semaphore-wait sema)) + (lambda () (or MIME-TYPE-TABLE ; maybe already read + (begin (set! MIME-TYPE-TABLE + (read-mime-types a-path)) + MIME-TYPE-TABLE))) + (lambda () (semaphore-post sema)))) (lowercase-symbol! sffx) TEXT/HTML-MIME-TYPE)] [_ TEXT/HTML-MIME-TYPE]))) From f725d00fedffd829864130aba331b38da55268b4 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Fri, 16 Jan 2009 10:08:59 +0000 Subject: [PATCH 09/13] update version numbers for the v4.1.4 release svn: r13164 --- src/mzscheme/src/schvers.h | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/mzscheme/src/schvers.h b/src/mzscheme/src/schvers.h index cd5cfe3196..97190cb105 100644 --- a/src/mzscheme/src/schvers.h +++ b/src/mzscheme/src/schvers.h @@ -13,12 +13,12 @@ consistently.) */ -#define MZSCHEME_VERSION "4.1.3.10" +#define MZSCHEME_VERSION "4.1.4.1" #define MZSCHEME_VERSION_X 4 #define MZSCHEME_VERSION_Y 1 -#define MZSCHEME_VERSION_Z 3 -#define MZSCHEME_VERSION_W 10 +#define MZSCHEME_VERSION_Z 4 +#define MZSCHEME_VERSION_W 1 #define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y) #define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W) From b7ccf49ecc9b5178fc3540cae21ef5f95edaa326 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Fri, 16 Jan 2009 12:27:17 +0000 Subject: [PATCH 10/13] Welcome to a new PLT day. svn: r13166 --- collects/repos-time-stamp/stamp.ss | 2 +- src/worksp/mred/mred.manifest | 2 +- src/worksp/mred/mred.rc | 8 ++++---- src/worksp/mzcom/mzcom.rc | 8 ++++---- src/worksp/mzcom/mzobj.rgs | 6 +++--- src/worksp/mzscheme/mzscheme.rc | 8 ++++---- src/worksp/starters/start.rc | 8 ++++---- 7 files changed, 21 insertions(+), 21 deletions(-) diff --git a/collects/repos-time-stamp/stamp.ss b/collects/repos-time-stamp/stamp.ss index 5c20816fe8..6bc78c3cc0 100644 --- a/collects/repos-time-stamp/stamp.ss +++ b/collects/repos-time-stamp/stamp.ss @@ -1 +1 @@ -#lang scheme/base (provide stamp) (define stamp "15jan2009") +#lang scheme/base (provide stamp) (define stamp "16jan2009") diff --git a/src/worksp/mred/mred.manifest b/src/worksp/mred/mred.manifest index 90a7aa6a77..e00028eeac 100644 --- a/src/worksp/mred/mred.manifest +++ b/src/worksp/mred/mred.manifest @@ -1,7 +1,7 @@ Date: Fri, 16 Jan 2009 16:24:23 +0000 Subject: [PATCH 11/13] over-limit svn: r13167 --- collects/web-server/dispatchers/limit.ss | 44 ++++++++++++++++--- .../web-server/scribblings/dispatchers.scrbl | 12 ++++- 2 files changed, 49 insertions(+), 7 deletions(-) diff --git a/collects/web-server/dispatchers/limit.ss b/collects/web-server/dispatchers/limit.ss index 8cfe48cc6e..ad37adb9e1 100644 --- a/collects/web-server/dispatchers/limit.ss +++ b/collects/web-server/dispatchers/limit.ss @@ -2,10 +2,10 @@ (require "dispatch.ss") (provide/contract [interface-version dispatcher-interface-version/c] - [make (number? dispatcher/c . -> . dispatcher/c)]) + [make ((number? dispatcher/c) (#:over-limit (symbols 'block 'kill-new 'kill-old)) . ->* . dispatcher/c)]) (define interface-version 'v1) -(define (make num inner) +(define (make num inner #:over-limit [over-limit 'block]) (define-struct in-req (partner reply-ch)) (define in-ch (make-channel)) (define-struct out-req (partner)) @@ -16,17 +16,50 @@ (let loop ([i 0] [partners empty]) (apply sync + ; Do we have room for another... (if (< i num) + ; If so, allow them in (handle-evt in-ch (lambda (req) - (channel-put (in-req-reply-ch req) #t) + ; Reply asynchronously + (thread + (lambda () + (channel-put (in-req-reply-ch req) #t))) (loop (add1 i) (list* (in-req-partner req) partners)))) - never-evt) + ; Otherwise, decide what to do with new requests + (case over-limit + ; Make them block... + [(block) + never-evt] + ; Instruct the new request to die + [(kill-new) + (handle-evt in-ch + (lambda (req) + ; Reply asynchronously + (thread + (lambda () + (channel-put (in-req-reply-ch req) #f))) + (loop i partners)))] + ; Kill an old request handler and allow this one + [(kill-old) + (handle-evt in-ch + (lambda (req) + (define oldest (last partners)) + (define remaining (take partners (sub1 (length partners)))) + ; Kill the oldest thread + (kill-thread oldest) + ; Reply asynchronously + (thread + (lambda () + (channel-put (in-req-reply-ch req) #t))) + (loop i (list* (in-req-partner req) remaining))))])) + ; Wait for partners to complete (handle-evt out-ch (lambda (req) (loop (sub1 i) (remq (out-req-partner req) partners)))) + ; Check if partners are dead (map (lambda (p) (handle-evt (thread-dead-evt p) (lambda _ @@ -35,7 +68,8 @@ (define (in) (define reply (make-channel)) (channel-put in-ch (make-in-req (current-thread) reply)) - (channel-get reply)) + (unless (channel-get reply) + (error 'limit "limit-manager requested load shedding"))) (define (out) (channel-put out-ch (make-out-req (current-thread)))) (lambda (conn req) diff --git a/collects/web-server/scribblings/dispatchers.scrbl b/collects/web-server/scribblings/dispatchers.scrbl index efb98175fb..20adde5454 100644 --- a/collects/web-server/scribblings/dispatchers.scrbl +++ b/collects/web-server/scribblings/dispatchers.scrbl @@ -395,9 +395,16 @@ a URL that refreshes the password file, servlet cache, etc.} @elem{provides a wrapper dispatcher that limits how many requests are serviced at once.}]{ @defproc[(make [limit number?] - [inner dispatcher/c]) + [inner dispatcher/c] + [#:over-limit over-limit (symbols 'block 'kill-new 'kill-old) 'block]) dispatcher/c]{ Returns a dispatcher that defers to @scheme[inner] for work, but will forward a maximum of @scheme[limit] requests concurrently. + + If there are no additional spaces inside the limit and a new request is received, the @scheme[over-limit] option determines what is done. + The default (@scheme['block]) causes the new request to block until an old request is finished being handled. + If @scheme[over-limit] is @scheme['kill-new], then the new request handler is killed---a form of load-shedding. + If @scheme[over-limit] is @scheme['kill-old], then the oldest request handler is killed---prioritizing new connections over old. + (This setting is a little dangerous because requests might never finish if there is constant load.) }} @(require (for-label @@ -434,7 +441,8 @@ Consider this example: (list (format "hello world ~a" (sort (build-list 100000 (λ x (random 1000))) <)))) - (request-method req))))) + (request-method req))) + #:over-limit 'block)) (lambda (conn req) (output-response/method conn From c5f8c43dbf74ea76e60c2d760c382b9097513b9c Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Fri, 16 Jan 2009 16:29:53 +0000 Subject: [PATCH 12/13] better code order svn: r13168 --- collects/scheme/promise.ss | 36 ++++++++++++++++++------------------ 1 file changed, 18 insertions(+), 18 deletions(-) diff --git a/collects/scheme/promise.ss b/collects/scheme/promise.ss index b1ba98a699..fbefc07bdf 100644 --- a/collects/scheme/promise.ss +++ b/collects/scheme/promise.ss @@ -59,10 +59,24 @@ ;; X = (force (lazy X)) = (force (lazy (lazy X))) = (force (lazy^n X)) (define-syntax (lazy stx) (syntax-case stx () - [(lazy expr) (with-syntax ([proc (syntax-property - (syntax/loc stx (lambda () expr)) - 'inferred-name (syntax-local-name))]) - (syntax/loc stx (make-promise proc)))])) + [(lazy expr) + (with-syntax ([proc (syntax-property (syntax/loc stx (lambda () expr)) + 'inferred-name (syntax-local-name))]) + (syntax/loc stx (make-promise proc)))])) + +;; Creates a promise that does not compose +;; X = (force (delay X)) = (force (lazy (delay X))) +;; = (force (lazy^n (delay X))) +;; X = (force (force (delay (delay X)))) != (force (delay (delay X))) +;; so each sequence of `(lazy^n o delay)^m' requires m `force's and a +;; sequence of `(lazy^n o delay)^m o lazy^k' requires m+1 `force's (for k>0) +;; (This is not needed with a lazy language (see the above URL for details), +;; but provided for regular delay/force uses.) +(define-syntax (delay stx) + (syntax-case stx () + [(delay expr) + (syntax/loc stx + (lazy (make-promise (call-with-values (lambda () expr) list))))])) ;; For simplicity and efficiency this code uses thunks in promise values for ;; exceptions: this way, we don't need to tag exception values in some special @@ -80,20 +94,6 @@ (error 'force "reentrant promise ~v" name) (error 'force "reentrant promise"))))) -;; Creates a promise that does not compose -;; X = (force (delay X)) = (force (lazy (delay X))) -;; = (force (lazy^n (delay X))) -;; X = (force (force (delay (delay X)))) != (force (delay (delay X))) -;; so each sequence of `(lazy^n o delay)^m' requires m `force's and a -;; sequence of `(lazy^n o delay)^m o lazy^k' requires m+1 `force's (for k>0) -;; (This is not needed with a lazy language (see the above URL for details), -;; but provided for regular delay/force uses.) -(define-syntax (delay stx) - (syntax-case stx () - [(delay expr) - (syntax/loc stx - (lazy (make-promise (call-with-values (lambda () expr) list))))])) - ;; force iterates on lazy promises (forbids dependency cycles) ;; * (force X) = X for non promises ;; * does not deal with multiple values, except for `delay' promises at the From c0bdc22085bfc1dafbcb1404a34f184b4039043e Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Fri, 16 Jan 2009 16:36:51 +0000 Subject: [PATCH 13/13] bleh svn: r13169 --- collects/scheme/promise.ss | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/collects/scheme/promise.ss b/collects/scheme/promise.ss index fbefc07bdf..7d4bd8e4db 100644 --- a/collects/scheme/promise.ss +++ b/collects/scheme/promise.ss @@ -59,7 +59,7 @@ ;; X = (force (lazy X)) = (force (lazy (lazy X))) = (force (lazy^n X)) (define-syntax (lazy stx) (syntax-case stx () - [(lazy expr) + [(_ expr) (with-syntax ([proc (syntax-property (syntax/loc stx (lambda () expr)) 'inferred-name (syntax-local-name))]) (syntax/loc stx (make-promise proc)))])) @@ -74,7 +74,7 @@ ;; but provided for regular delay/force uses.) (define-syntax (delay stx) (syntax-case stx () - [(delay expr) + [(_ expr) (syntax/loc stx (lazy (make-promise (call-with-values (lambda () expr) list))))]))