From 763882f651a9d85bb643fea6be57de09da0d3b03 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 28 Aug 2012 08:35:01 -0600 Subject: [PATCH] add port shortcut for `make-{input,output}-port' Providing a port instead of a reading or writing procedure redirects the read/write to the specified port. This shortcut is kind of a hack, but the run-time system can easily streamline the redirection when it's exposed this way. Using the new redirection feature reduces overhead in `with-output-to-bytes' and `pretty-print'. --- collects/racket/port.rkt | 6 + collects/racket/private/port.rkt | 6 + .../scribblings/reference/custom-ports.scrbl | 70 ++++--- collects/tests/racket/port.rktl | 32 ++++ collects/tests/racket/portlib.rktl | 44 ++++- src/racket/src/port.c | 174 ++++++++++++++++-- src/racket/src/portfun.c | 75 ++++++-- src/racket/src/schpriv.h | 12 ++ 8 files changed, 364 insertions(+), 55 deletions(-) diff --git a/collects/racket/port.rkt b/collects/racket/port.rkt index 64fbf416a2..f074dbd2d0 100644 --- a/collects/racket/port.rkt +++ b/collects/racket/port.rkt @@ -605,9 +605,15 @@ (lambda (p location-proc pos [close? #t] [count-lines!-proc void]) (make-input-port (object-name p) + p ;; redirect `read' to `p' + ;; Here's the long way to redirect: + #; (lambda (s) (let ([v (read-bytes-avail!* s p)]) (if (eq? v 0) (wrap-evt p (lambda (x) 0)) v))) + p ;; redirect `peek' to `p' + ;; Here's the long way to redirect: + #; (lambda (s skip evt) (let ([v (peek-bytes-avail!* s skip evt p)]) (if (eq? v 0) diff --git a/collects/racket/private/port.rkt b/collects/racket/private/port.rkt index 8f1343c480..eccd8fadcd 100644 --- a/collects/racket/private/port.rkt +++ b/collects/racket/private/port.rkt @@ -55,6 +55,9 @@ (make-output-port (object-name p) p + p ; `write' just redirects to `p' + ;; Here's the slow way to redirect: + #; (lambda (s start end nonblock? breakable?) (if (= start end) (parameterize-break @@ -75,6 +78,9 @@ (when close? (close-output-port p))) (and (port-writes-special? p) + p ; `write-special' just redirects to `p' + ;; Here's the slow way to redirect: + #; (lambda (special nonblock? breakable?) ((if nonblock? write-special-avail* diff --git a/collects/scribblings/reference/custom-ports.scrbl b/collects/scribblings/reference/custom-ports.scrbl index 7a6c041710..0b1429a0ec 100644 --- a/collects/scribblings/reference/custom-ports.scrbl +++ b/collects/scribblings/reference/custom-ports.scrbl @@ -10,17 +10,21 @@ obtain fine control over the action of committing bytes as read or written. @defproc[(make-input-port [name any/c] - [read-in (bytes? - . -> . (or/c exact-nonnegative-integer? - eof-object? - procedure? - evt?))] - [peek (bytes? exact-nonnegative-integer? (or/c evt? #f) - . -> . (or/c exact-nonnegative-integer? - eof-object? - procedure? - evt? - #f))] + [read-in (or/c + (bytes? + . -> . (or/c exact-nonnegative-integer? + eof-object? + procedure? + evt?)) + input-port?)] + [peek (or/c + (bytes? exact-nonnegative-integer? (or/c evt? #f) + . -> . (or/c exact-nonnegative-integer? + eof-object? + procedure? + evt? + #f)) + input-port?)] [close (-> any)] [get-progress-evt (or/c (-> evt?) #f) #f] [commit (or/c (exact-positive-integer? evt? evt? . -> . any) @@ -52,7 +56,9 @@ The arguments implement the port as follows: @item{@racket[name] --- the name for the input port.} - @item{@racket[read-in] --- a procedure that takes a single argument: + @item{@racket[read-in] --- either an input port, in which case reads + are redirected to the given port, or a procedure that takes a single + argument: a mutable byte string to receive read bytes. The procedure's result is one of the following: @itemize[ @@ -146,10 +152,14 @@ The arguments implement the port as follows: @racket[get-progress-evt], and @racket[commit] procedures, however, and even an implementor who does supply them may provide a different @racket[read-in] - that uses a fast path for non-blocking reads.} + that uses a fast path for non-blocking reads. + + In an input port is provided for @racket[read-in], then an input port + must also be provided for @racket[peek].} - @item{@racket[peek] --- either @racket[#f] or a procedure + @item{@racket[peek] --- either @racket[#f], an input port (in which + case peeks are redirected to the given port), or a procedure that takes three arguments: @itemize[ @@ -206,7 +216,10 @@ The arguments implement the port as follows: @racket[#f], then @racket[progress-evt] and @racket[commit] must be @racket[#f]. See also @racket[make-input-port/peek-to-read], which implements peeking in terms of @racket[read-in] without - these constraints.} + these constraints. + + In an input port is provided for @racket[peek], then an input port + must also be provided for @racket[read-in].} @item{@racket[close] --- a procedure of zero arguments that is called to close the port. The port is not considered closed until @@ -669,20 +682,23 @@ s @defproc[(make-output-port [name any/c] [evt evt?] - [write-out (bytes? exact-nonnegative-integer? - exact-nonnegative-integer? - boolean? - boolean? - . -> . - (or/c exact-nonnegative-integer? - #f - evt?))] + [write-out (or/c + (bytes? exact-nonnegative-integer? + exact-nonnegative-integer? + boolean? + boolean? + . -> . + (or/c exact-nonnegative-integer? + #f + evt?)) + output-port?)] [close (-> any)] [write-out-special (or/c (any/c boolean? boolean? . -> . (or/c any/c #f evt?)) + output-port? #f) #f] [get-write-evt (or/c @@ -735,7 +751,9 @@ procedures. @racket[always-evt] if writes to the port always succeed without blocking.} - @item{@racket[write-out] --- a procedure of five arguments: + @item{@racket[write-out] --- either an output port, which indicates that + writes should be redirected to the given port, or a procedure + of five arguments: @itemize[ @@ -849,7 +867,9 @@ procedures. terminated immediately with an error.} @item{@racket[write-out-special] --- either @racket[#f] (the - default), or a procedure to handle @racket[write-special] calls + default), an output port (which indicates that + special writes should be redirected to the given port), + or a procedure to handle @racket[write-special] calls for the port. If @racket[#f], then the port does not support special output, and @racket[port-writes-special?] will return @racket[#f] when applied to the port. diff --git a/collects/tests/racket/port.rktl b/collects/tests/racket/port.rktl index 0dbf29f7db..cdc7482022 100644 --- a/collects/tests/racket/port.rktl +++ b/collects/tests/racket/port.rktl @@ -670,6 +670,38 @@ (write-special-avail* 'any p) (test '(special #t #f #f) values status)) +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Check port shortcuts for `make-input-port' and `make-output-port' + +(let-values ([(i o) (make-pipe 5)]) + (define i2 (make-input-port + (object-name i) + i + i + void)) + (define o2 (make-output-port + (object-name o) + o + o + void)) + (test #f sync/timeout 0 i2) + (test o2 sync/timeout 0 o2) + (write-bytes #"01234" o2) + (test #f sync/timeout 0 o2) + (test i2 sync/timeout 0 i2) + (test #"01234" read-bytes 5 i2) + (test 0 read-bytes-avail!* (make-bytes 3) i2) + (thread (lambda () + (sync (system-idle-evt)) + (write-bytes #"5" o2))) + (test #\5 read-char i2) + (let ([s (make-bytes 6)]) + (thread (lambda () + (sync (system-idle-evt)) + (test 5 write-bytes-avail #"6789ab" o2))) + (test 5 read-bytes-avail! s i2) + (test #"6789a\0" values s))) + ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Check that an uncooperative output port doesn't keep breaks ;; disabled too long: diff --git a/collects/tests/racket/portlib.rktl b/collects/tests/racket/portlib.rktl index 89d748c2ab..8b4bf304cb 100644 --- a/collects/tests/racket/portlib.rktl +++ b/collects/tests/racket/portlib.rktl @@ -285,6 +285,48 @@ (go-stream #t #f #t #t) (go-stream #t #t #t #t))) +;; Check port shortcuts for `make-input-port' and `make-output-port' with +;; pipes and specials +(let-values ([(i o) (make-pipe-with-specials 5)]) + (define i2 (make-input-port + (object-name i) + i + i + void)) + (define o2 (make-output-port + (object-name o) + o + o + void + o)) + (test #f sync/timeout 0 i2) + (test o2 sync/timeout 0 o2) + (write-bytes #"01234" o2) + (test #f sync/timeout 0 o2) + (test i2 sync/timeout 0 i2) + (test #"01234" read-bytes 5 i2) + (test 0 read-bytes-avail!* (make-bytes 3) i2) + (thread (lambda () + (sync (system-idle-evt)) + (write-bytes #"5" o2))) + (test #\5 read-char i2) + (let ([s (make-bytes 6)]) + (thread (lambda () + (sync (system-idle-evt)) + (test 5 write-bytes-avail #"6789ab" o2))) + (test 5 read-bytes-avail! s i2) + (test #"6789a\0" values s)) + + (test #t port-writes-special? o2) + (write-special 'ok o2) + (test 'ok read-byte-or-special i2) + + (test #t write-special-avail* 'ok-again o2) + (test i2 sync i2) + (test 'ok-again read-byte-or-special i2) + + (void)) + ;; make-input-port/read-to-peek (define (make-list-port #:eof-as-special? [eof-as-special? #f] . l) (make-input-port/read-to-peek @@ -787,7 +829,7 @@ (port-count-lines! i2) (test-values '(1 0 1) (lambda () (port-next-location i))) (test-values '(2 0 2) (lambda () (port-next-location i2))) - (read-byte i) + (test (char->integer #\x) read-byte i) (test-values '(1 1 2) (lambda () (port-next-location i))) (test-values '(2 2 4) (lambda () (port-next-location i2))) (test (file-stream-buffer-mode i) file-stream-buffer-mode i2)) diff --git a/src/racket/src/port.c b/src/racket/src/port.c index c29cc5873a..1976d809fc 100644 --- a/src/racket/src/port.c +++ b/src/racket/src/port.c @@ -8206,10 +8206,10 @@ scheme_make_null_output_port(int can_write_special) static Scheme_Object *redirect_write_bytes_k(void); -static intptr_t -redirect_write_bytes(Scheme_Output_Port *op, - const char *str, intptr_t d, intptr_t len, - int rarely_block, int enable_break) +intptr_t +scheme_redirect_write_bytes(Scheme_Output_Port *op, + const char *str, intptr_t d, intptr_t len, + int rarely_block, int enable_break) { /* arbitrary nesting means we can overflow the stack */ #ifdef DO_STACK_CHECK @@ -8231,9 +8231,19 @@ redirect_write_bytes(Scheme_Output_Port *op, #endif return scheme_put_byte_string("redirect-output", - (Scheme_Object *)op->port_data, + (Scheme_Object *)op, str, d, len, - rarely_block); + (enable_break && !rarely_block) ? -1 : rarely_block); +} + +static intptr_t +redirect_write_bytes(Scheme_Output_Port *op, + const char *str, intptr_t d, intptr_t len, + int rarely_block, int enable_break) +{ + return scheme_redirect_write_bytes(scheme_output_port_record((Scheme_Object *)op->port_data), + str, d, len, + rarely_block, enable_break); } static Scheme_Object *redirect_write_bytes_k(void) @@ -8250,7 +8260,57 @@ static Scheme_Object *redirect_write_bytes_k(void) p->ku.k.p1 = NULL; p->ku.k.p2 = NULL; - n = redirect_write_bytes(op, str, d, len, rarely_block, enable_break); + n = scheme_redirect_write_bytes(op, str, d, len, rarely_block, enable_break); + + return scheme_make_integer(n); +} + +static Scheme_Object *redirect_write_special_k(void); + +int scheme_redirect_write_special (Scheme_Output_Port *op, Scheme_Object *v, int nonblock) +{ + Scheme_Object *a[2]; + +#ifdef DO_STACK_CHECK + { +# include "mzstkchk.h" + { + Scheme_Thread *p = scheme_current_thread; + Scheme_Object *n; + + p->ku.k.p1 = (void *)op; + p->ku.k.p2 = (void *)v; + p->ku.k.i1 = nonblock; + + n = scheme_handle_stack_overflow(redirect_write_special_k); + return SCHEME_INT_VAL(n); + } + } +#endif + + a[0] = (Scheme_Object *)v; + a[1] = (Scheme_Object *)op; + + if (nonblock) + v = scheme_write_special_nonblock(2, a); + else + v = scheme_write_special(2, a); + + return SCHEME_TRUEP(v); +} + +static Scheme_Object *redirect_write_special_k(void) +{ + Scheme_Thread *p = scheme_current_thread; + Scheme_Output_Port *op = (Scheme_Output_Port *)p->ku.k.p1; + Scheme_Object *v = (Scheme_Object *)p->ku.k.p2; + intptr_t nonblock = p->ku.k.i1; + intptr_t n; + + p->ku.k.p1 = NULL; + p->ku.k.p2 = NULL; + + n = scheme_redirect_write_special(op, v, nonblock); return scheme_make_integer(n); } @@ -8279,17 +8339,9 @@ redirect_write_special_evt(Scheme_Output_Port *op, Scheme_Object *special) static int redirect_write_special(Scheme_Output_Port *op, Scheme_Object *special, int nonblock) { - Scheme_Object *v, *a[2]; - - a[0] = (Scheme_Object *)op->port_data; - a[1] = special; - - if (nonblock) - v = scheme_write_special(2, a); - else - v = scheme_write_special(2, a); - - return SCHEME_TRUEP(v); + return scheme_redirect_write_special(scheme_output_port_record((Scheme_Object *)op->port_data), + special, + nonblock); } Scheme_Object * @@ -8320,6 +8372,92 @@ scheme_make_redirect_output_port(Scheme_Object *port) return (Scheme_Object *)op; } +static Scheme_Object *redirect_get_or_peek_bytes_k(void); + +intptr_t scheme_redirect_get_or_peek_bytes(Scheme_Input_Port *orig_port, + Scheme_Input_Port *port, + char *buffer, intptr_t offset, intptr_t size, + int nonblock, + int peek, Scheme_Object *peek_skip, + Scheme_Object *unless, + Scheme_Schedule_Info *sinfo) +{ + int r; + + if (sinfo) { + scheme_set_sync_target(sinfo, (Scheme_Object *)port, (Scheme_Object *)orig_port, NULL, 0, 1, NULL); + return 0; + } + +#ifdef DO_STACK_CHECK + { +# include "mzstkchk.h" + { + Scheme_Thread *p = scheme_current_thread; + Scheme_Object *n; + + p->ku.k.p1 = (void *)port; + p->ku.k.p2 = (void *)buffer; + p->ku.k.p3 = (void *)peek_skip; + p->ku.k.p4 = (void *)unless; + p->ku.k.p4 = (void *)orig_port; + p->ku.k.i1 = offset; + p->ku.k.i1 = size; + p->ku.k.i2 = nonblock; + p->ku.k.i3 = peek; + + n = scheme_handle_stack_overflow(redirect_get_or_peek_bytes_k); + return SCHEME_INT_VAL(n); + } + } +#endif + + r = scheme_get_byte_string_special_ok_unless("redirect-read-or-peek", + (Scheme_Object *)port, + buffer, offset, size, + ((nonblock == -1) + ? -1 + : (nonblock ? 2 : 1)), + peek, (peek ? peek_skip : NULL), + unless); + + if (r == SCHEME_SPECIAL) { + Scheme_Object *res; + res = scheme_get_special_proc((Scheme_Object *)port); + orig_port->special = res; + } + + return r; +} + +static Scheme_Object *redirect_get_or_peek_bytes_k(void) +{ + Scheme_Thread *p = scheme_current_thread; + Scheme_Input_Port *ip = (Scheme_Input_Port *)p->ku.k.p1; + char *buffer = (char *)p->ku.k.p2; + Scheme_Object *peek_skip = (Scheme_Object *)p->ku.k.p3; + Scheme_Object *unless = (Scheme_Object *)p->ku.k.p4; + Scheme_Input_Port *orig_port = (Scheme_Input_Port *)p->ku.k.p5; + intptr_t d = p->ku.k.i1; + intptr_t len = p->ku.k.i2; + int nonblock = p->ku.k.i3; + int peek = p->ku.k.i4; + intptr_t n; + + p->ku.k.p1 = NULL; + p->ku.k.p2 = NULL; + p->ku.k.p3 = NULL; + p->ku.k.p4 = NULL; + p->ku.k.p5 = NULL; + + n = scheme_redirect_get_or_peek_bytes(orig_port, ip, buffer, d, len, + nonblock, + peek, peek_skip, + unless, NULL); + + return scheme_make_integer(n); +} + /*********** Unix/Windows: process status stuff *************/ #if defined(UNIX_PROCESSES) || defined(WINDOWS_PROCESSES) diff --git a/src/racket/src/portfun.c b/src/racket/src/portfun.c index f961947372..8d805f42f6 100644 --- a/src/racket/src/portfun.c +++ b/src/racket/src/portfun.c @@ -895,6 +895,20 @@ user_get_or_peek_bytes(Scheme_Input_Port *port, intptr_t r; Scheme_Cont_Frame_Data cframe; + if (peek) + fun = uip->peek_proc; + else + fun = uip->read_proc; + + if (SCHEME_INPUT_PORTP(fun)) { + return scheme_redirect_get_or_peek_bytes(port, + scheme_input_port_record(fun), + buffer, offset, size, + nonblock, + peek, peek_skip, + unless, sinfo); + } + val = uip->peeked; if (val) { /* Leftover from a read-based peek used to implement `char-ready?' @@ -914,11 +928,6 @@ user_get_or_peek_bytes(Scheme_Input_Port *port, if (unless && SCHEME_PAIRP(unless)) unless = SCHEME_CDR(unless); - if (peek) - fun = uip->peek_proc; - else - fun = uip->read_proc; - while (1) { int nb; @@ -971,7 +980,7 @@ user_get_or_peek_bytes(Scheme_Input_Port *port, /* Call the read/peek function: */ val = scheme_apply(fun, peek ? 3 : 1, a); - + if ((size <= MAX_USER_INPUT_REUSE_SIZE) && (SCHEME_INTP(val) || SCHEME_EOFP(val) || SCHEME_PROCP(val))) { uip->reuse_str = bstr; @@ -1375,6 +1384,12 @@ user_write_bytes(Scheme_Output_Port *port, const char *str, intptr_t offset, int int n, re_enable_break; Scheme_Cont_Frame_Data cframe; + if (SCHEME_OUTPUT_PORTP(uop->write_proc)) { + return scheme_redirect_write_bytes(scheme_output_port_record(uop->write_proc), + str, offset, len, + rarely_block, enable_break); + } + if (rarely_block) re_enable_break = 0; else if (enable_break) @@ -1514,6 +1529,12 @@ user_write_special (Scheme_Output_Port *port, Scheme_Object *v, int nonblock) int re_enable_break; Scheme_Cont_Frame_Data cframe; + if (SCHEME_OUTPUT_PORTP(uop->write_special_proc)) { + return scheme_redirect_write_special(scheme_output_port_record(uop->write_special_proc), + v, + nonblock); + } + if (nonblock) re_enable_break = 0; else @@ -2228,9 +2249,18 @@ make_input_port(int argc, Scheme_Object *argv[]) Scheme_Input_Port *ip; User_Input_Port *uip; Scheme_Object *name; + int read_port, peek_port; - scheme_check_proc_arity("make-input-port", 1, 1, argc, argv); /* read */ - scheme_check_proc_arity2("make-input-port", 3, 2, argc, argv, 1); /* peek */ + read_port = SCHEME_INPUT_PORTP(argv[1]); + if (!read_port + && !scheme_check_proc_arity(NULL, 1, 1, argc, argv)) { /* read */ + scheme_wrong_contract("make-input-port", "(or/c (procedure-arity-includes/c 1) input-port?)", 1, argc, argv); + } + peek_port = SCHEME_INPUT_PORTP(argv[2]); + if (!peek_port + && !scheme_check_proc_arity2(NULL, 3, 2, argc, argv, 1)) { /* peek */ + scheme_wrong_contract("make-input-port", "(or/c (procedure-arity-includes/c 3) input-port?)", 2, argc, argv); + } scheme_check_proc_arity("make-input-port", 0, 3, argc, argv); /* close */ if (argc > 4) scheme_check_proc_arity2("make-input-port", 0, 4, argc, argv, 1); /* progress-evt */ @@ -2253,6 +2283,17 @@ make_input_port(int argc, Scheme_Object *argv[]) } name = argv[0]; + /* Shortcut ports for read & peek must be consistent: */ + if (!!read_port != !!peek_port) { + scheme_contract_error("make-input-port", + (read_port + ? "read argument is an input port, but peek argument is not a port" + : "read argument is not an input port, but peek argument is a port"), + "read argument", 1, argv[1], + "peek argument", 1, argv[2], + NULL); + } + /* It makes no sense to supply progress-evt without peek: */ if ((argc > 5) && SCHEME_FALSEP(argv[2]) && !SCHEME_FALSEP(argv[4])) scheme_contract_error("make-input-port", @@ -2344,10 +2385,22 @@ make_output_port (int argc, Scheme_Object *argv[]) if (!scheme_is_evt(argv[1])) { scheme_wrong_contract("make-output-port", "evt?", 1, argc, argv); } - scheme_check_proc_arity("make-output-port", 5, 2, argc, argv); /* write */ + if (!SCHEME_OUTPUT_PORTP(argv[2]) + && !scheme_check_proc_arity(NULL, 5, 2, argc, argv)) { /* write */ + scheme_wrong_contract("make-output-port", + "(or/c (procedure-arity-includes/c 5) output-port?)", + 2, argc, argv); + } scheme_check_proc_arity("make-output-port", 0, 3, argc, argv); /* close */ - if (argc > 4) - scheme_check_proc_arity2("make-output-port", 3, 4, argc, argv, 1); /* write-special */ + if (argc > 4) { + if (!SCHEME_FALSEP(argv[4]) + && !SCHEME_OUTPUT_PORTP(argv[2]) + && !scheme_check_proc_arity(NULL, 3, 4, argc, argv)) { /* write-special */ + scheme_wrong_contract("make-output-port", + "(or/c (procedure-arity-includes/c 3) output-port?)", + 4, argc, argv); + } + } if (argc > 5) scheme_check_proc_arity2("make-output-port", 3, 5, argc, argv, 1); /* write-evt */ if (argc > 6) diff --git a/src/racket/src/schpriv.h b/src/racket/src/schpriv.h index 7562ab3bb2..bf0ae39bd6 100644 --- a/src/racket/src/schpriv.h +++ b/src/racket/src/schpriv.h @@ -3631,6 +3631,18 @@ intptr_t scheme_port_closed_p (Scheme_Object *port); #define MAX_UTF8_CHAR_BYTES 6 +intptr_t scheme_redirect_write_bytes(Scheme_Output_Port *op, + const char *str, intptr_t d, intptr_t len, + int rarely_block, int enable_break); +int scheme_redirect_write_special (Scheme_Output_Port *op, Scheme_Object *v, int nonblock); +intptr_t scheme_redirect_get_or_peek_bytes(Scheme_Input_Port *orig_port, + Scheme_Input_Port *port, + char *buffer, intptr_t offset, intptr_t size, + int nonblock, + int peek, Scheme_Object *peek_skip, + Scheme_Object *unless, + Scheme_Schedule_Info *sinfo); + /*========================================================================*/ /* memory debugging */ /*========================================================================*/