diff --git a/pkgs/racket-pkgs/racket-doc/scribblings/reference/logging.scrbl b/pkgs/racket-pkgs/racket-doc/scribblings/reference/logging.scrbl index 5dd3b5f4fa..2eda1db814 100644 --- a/pkgs/racket-pkgs/racket-doc/scribblings/reference/logging.scrbl +++ b/pkgs/racket-pkgs/racket-doc/scribblings/reference/logging.scrbl @@ -141,12 +141,20 @@ by @racket[": "] before it is sent to receivers. @defproc[(log-level? [logger logger?] - [level (or/c 'fatal 'error 'warning 'info 'debug)]) + [level (or/c 'fatal 'error 'warning 'info 'debug)] + [name (or/c symbol? #f) #f]) boolean?]{ Reports whether any @tech{log receiver} attached to @racket[logger] or one of its ancestors is interested in @racket[level] events (or -potentially lower). Use this function to avoid work generating an +potentially lower) or @racket[name]. If @racket[name] is @racket[#f], +the result indicates whether any @tech{log receiver} is interested in +events at @racket[level] for any name. A true result for +@racket[(log-level? logger level name)] implies a true result for +@racket[(log-level? logger level #f)], but not vice versa if +@racket[name] is a symbol. + +Use this function to avoid work generating an event for @racket[log-message] if no receiver is interested in the information; this shortcut is built into @racket[log-fatal], @racket[log-error], @racket[log-warning], @racket[log-info], @@ -155,16 +163,21 @@ however, so it should not be used with those forms. The result of this function can change if a garbage collection determines that a log receiver is no longer accessible (and therefore -that any event information it receives will never become accessible).} +that any event information it receives will never become accessible). + +@history[#:changed "6.1.1.3" @elem{Added the @racket[name] argument.}]} -@defproc[(log-max-level [logger logger?]) +@defproc[(log-max-level [logger logger?] + [name (or/c symbol? #f) #f]) (or/c #f 'fatal 'error 'warning 'info 'debug)]{ Similar to @racket[log-level?], but reports the maximum level of logging for -which @racket[log-level?] on @racket[logger] returns @racket[#t]. The +which @racket[log-level?] on @racket[logger] and @racket[name] returns @racket[#t]. The result is @racket[#f] if @racket[log-level?] with @racket[logger] -currently returns @racket[#f] for all levels.} +currently returns @racket[#f] for all levels. + +@history[#:changed "6.1.1.3" @elem{Added the @racket[name] argument.}]} @deftogether[( diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/logger.rktl b/pkgs/racket-pkgs/racket-test/tests/racket/logger.rktl index 63102b2f6c..aa75f5e8d0 100644 --- a/pkgs/racket-pkgs/racket-test/tests/racket/logger.rktl +++ b/pkgs/racket-pkgs/racket-test/tests/racket/logger.rktl @@ -98,6 +98,27 @@ (log-test-warning "warning") (test "test: warning" (lambda (v) (vector-ref v 1)) (sync r))) +(let () + (define-logger test) + (define r (make-log-receiver (current-logger) 'info 'test 'warning)) + (test #t log-level? test-logger 'warning) + (test #t log-level? test-logger 'info) + (test #t log-level? test-logger 'info 'test) + (test #f log-level? test-logger 'info 'not-test) + (test #f log-level? test-logger 'debug 'test) + (test 'info log-max-level test-logger) + (test 'info log-max-level test-logger 'test) + (test 'warning log-max-level test-logger 'not-test) + (define r2 (make-log-receiver (current-logger) 'warning 'test 'info)) + (test #t log-level? test-logger 'info 'test) + (test #t log-level? test-logger 'info 'not-test) + (test #f log-level? test-logger 'debug 'test) + (test 'info log-max-level test-logger) + (test 'info log-max-level test-logger 'test) + (test 'info log-max-level test-logger 'not-test) + (test #f sync/timeout 0 r) + (test #f sync/timeout 0 r2)) + ; ---------------------------------------- (let () diff --git a/racket/collects/racket/private/logger.rkt b/racket/collects/racket/private/logger.rkt index 8f9a1427ec..a96451d942 100644 --- a/racket/collects/racket/private/logger.rkt +++ b/racket/collects/racket/private/logger.rkt @@ -6,25 +6,26 @@ (#%provide log-fatal log-error log-warning log-info log-debug define-logger) - (define-for-syntax (make-define-log mode X-logger-stx) + (define-for-syntax (make-define-log mode X-logger-stx name) (lambda (stx) (with-syntax ([X-logger X-logger-stx] - [mode mode]) + [mode mode] + [name name]) (syntax-case stx () [(_ str-expr) #'(let ([l X-logger]) - (when (log-level? l 'mode) + (when (log-level? l 'mode name) (log-message l 'mode str-expr (current-continuation-marks))))] [(_ str-expr arg ...) #'(let ([l X-logger]) - (when (log-level? l 'mode) + (when (log-level? l 'mode name) (log-message l 'mode (format str-expr arg ...) (current-continuation-marks))))])))) - (define-syntax log-fatal (make-define-log 'fatal #'(current-logger))) - (define-syntax log-error (make-define-log 'error #'(current-logger))) - (define-syntax log-warning (make-define-log 'warning #'(current-logger))) - (define-syntax log-info (make-define-log 'info #'(current-logger))) - (define-syntax log-debug (make-define-log 'debug #'(current-logger))) + (define-syntax log-fatal (make-define-log 'fatal #'(current-logger) #'(logger-name l))) + (define-syntax log-error (make-define-log 'error #'(current-logger) #'(logger-name l))) + (define-syntax log-warning (make-define-log 'warning #'(current-logger) #'(logger-name l))) + (define-syntax log-info (make-define-log 'info #'(current-logger) #'(logger-name l))) + (define-syntax log-debug (make-define-log 'debug #'(current-logger) #'(logger-name l))) (define (check-logger who) (lambda (v) @@ -50,8 +51,8 @@ [X X]) #'(begin (define X-logger (make-logger 'X (current-logger))) - (define-syntax log-X-fatal (make-define-log 'fatal #'X-logger)) - (define-syntax log-X-error (make-define-log 'error #'X-logger)) - (define-syntax log-X-warning (make-define-log 'warning #'X-logger)) - (define-syntax log-X-info (make-define-log 'info #'X-logger)) - (define-syntax log-X-debug (make-define-log 'debug #'X-logger)))))]))) + (define-syntax log-X-fatal (make-define-log 'fatal #'X-logger #''X)) + (define-syntax log-X-error (make-define-log 'error #'X-logger #''X)) + (define-syntax log-X-warning (make-define-log 'warning #'X-logger #''X)) + (define-syntax log-X-info (make-define-log 'info #'X-logger #''X)) + (define-syntax log-X-debug (make-define-log 'debug #'X-logger #''X)))))]))) diff --git a/racket/src/racket/src/error.c b/racket/src/racket/src/error.c index 26def9f471..33adcd338b 100644 --- a/racket/src/racket/src/error.c +++ b/racket/src/racket/src/error.c @@ -133,7 +133,7 @@ static int log_reader_get(Scheme_Object *ch, Scheme_Schedule_Info *sinfo); static Scheme_Object *do_raise(Scheme_Object *arg, int need_debug, int barrier); static Scheme_Object *nested_exn_handler(void *old_exn, int argc, Scheme_Object *argv[]); -static void update_want_level(Scheme_Logger *logger); +static void update_want_level(Scheme_Logger *logger, Scheme_Object *name); static Scheme_Object *check_arity_property_value_ok(int argc, Scheme_Object *argv[]); @@ -725,8 +725,8 @@ void scheme_init_error(Scheme_Env *env) /* logging */ GLOBAL_NONCM_PRIM("exit", scheme_do_exit, 0, 1, env); - GLOBAL_NONCM_PRIM("log-level?", log_level_p, 2, 2, env); - GLOBAL_NONCM_PRIM("log-max-level", log_max_level, 1, 1, env); + GLOBAL_NONCM_PRIM("log-level?", log_level_p, 2, 3, env); + GLOBAL_NONCM_PRIM("log-max-level", log_max_level, 1, 2, env); GLOBAL_NONCM_PRIM("make-logger", make_logger, 0, 2, env); GLOBAL_NONCM_PRIM("make-log-receiver", make_log_reader, 2, -1, env); @@ -1081,7 +1081,7 @@ int scheme_log_level_p(Scheme_Logger *logger, int level) } if (logger->local_timestamp < *logger->timestamp) - update_want_level(logger); + update_want_level(logger, NULL); return (logger->want_level >= level); } @@ -3431,10 +3431,13 @@ static int extract_spec_level(Scheme_Object *level_spec, Scheme_Object *name) } } -static int extract_max_spec_level(Scheme_Object *level_spec) +static int extract_max_spec_level(Scheme_Object *level_spec, Scheme_Object *name) { int mx = 0, v; + if (name) + return extract_spec_level(level_spec, name); + if (level_spec) { while (1) { if (SCHEME_INTP(level_spec)) { @@ -3452,11 +3455,11 @@ static int extract_max_spec_level(Scheme_Object *level_spec) return mx; } -void update_want_level(Scheme_Logger *logger) +void update_want_level(Scheme_Logger *logger, Scheme_Object *name) { Scheme_Log_Reader *lr; Scheme_Object *stack = NULL, *queue, *b, *prev; - Scheme_Logger *parent = logger; + Scheme_Logger *parent = logger, *orig_logger = logger; int want_level, level; while (parent) { @@ -3475,7 +3478,7 @@ void update_want_level(Scheme_Logger *logger) b = SCHEME_CAR(b); lr = (Scheme_Log_Reader *)SCHEME_BOX_VAL(b); if (lr) { - level = extract_max_spec_level(lr->level); + level = extract_max_spec_level(lr->level, name); if (level > want_level) want_level = level; prev = queue; @@ -3488,18 +3491,80 @@ void update_want_level(Scheme_Logger *logger) queue = SCHEME_CDR(queue); } - level = extract_max_spec_level(parent->syslog_level); + level = extract_max_spec_level(parent->syslog_level, name); if (level > want_level) want_level = level; - level = extract_max_spec_level(parent->stderr_level); + level = extract_max_spec_level(parent->stderr_level, name); if (level > want_level) want_level = level; stack = SCHEME_CDR(stack); } - logger->want_level = want_level; - logger->local_timestamp = *logger->timestamp; + if (!name) { + logger->want_level = want_level; + logger->local_timestamp = *logger->timestamp; + } else { +# define WANT_NAME_LEVEL_CACHE_SIZE 8 + int i; + + logger = orig_logger; + + b = logger->want_name_level_cache; + if (!b) { + b = scheme_make_vector(3 * WANT_NAME_LEVEL_CACHE_SIZE, scheme_make_integer(-1)); + logger->want_name_level_cache = b; + } + + /* find a slot already matching this name? */ + for (i = SCHEME_VEC_SIZE(b); (i -= 3) >= 0; ) { + if (SAME_OBJ(name, SCHEME_VEC_ELS(b)[i])) + break; + } + if (i == 0) abort(); + if (i < 0) { + /* find an out-of-date slot? */ + for (i = SCHEME_VEC_SIZE(b); (i -= 3) >= 0; ) { + if (SCHEME_INT_VAL(SCHEME_VEC_ELS(b)[i+1]) < *logger->timestamp) + break; + } + if (i < 0) { + /* rotate cache */ + i = 3 * (WANT_NAME_LEVEL_CACHE_SIZE - 1); + memmove(&(SCHEME_VEC_ELS(b)[0]), + &(SCHEME_VEC_ELS(b)[3]), + i * sizeof(Scheme_Object *)); + } + } + + SCHEME_VEC_ELS(b)[i] = name; + SCHEME_VEC_ELS(b)[i+1] = scheme_make_integer(*logger->timestamp); + SCHEME_VEC_ELS(b)[i+2] = scheme_make_integer(want_level); + } +} + +static int get_want_level(Scheme_Logger *logger, Scheme_Object *name) +{ + if (name && SCHEME_TRUEP(name)) { + while (1) { + if (logger->want_name_level_cache) { + int i; + for (i = SCHEME_VEC_SIZE(logger->want_name_level_cache); (i -= 3) >= 0; ) { + if (SAME_OBJ(name, SCHEME_VEC_ELS(logger->want_name_level_cache)[i])) { + if (SCHEME_INT_VAL(SCHEME_VEC_ELS(logger->want_name_level_cache)[i+1]) == *logger->timestamp) { + return SCHEME_INT_VAL(SCHEME_VEC_ELS(logger->want_name_level_cache)[i+2]); + } + } + } + } + update_want_level(logger, name); + } + } else { + if (logger->local_timestamp < *logger->timestamp) + update_want_level(logger, NULL); + + return logger->want_level; + } } #ifdef USE_WINDOWS_EVENT_LOG @@ -3572,7 +3637,6 @@ void scheme_log_name_pfx_message(Scheme_Logger *logger, int level, Scheme_Object configuration of scheme_log_abort(). */ Scheme_Object *queue, *q, *msg = NULL, *b; Scheme_Log_Reader *lr; - Scheme_Logger *lo; if (!logger) { Scheme_Config *config; @@ -3581,7 +3645,7 @@ void scheme_log_name_pfx_message(Scheme_Logger *logger, int level, Scheme_Object } if (logger->local_timestamp < *logger->timestamp) - update_want_level(logger); + update_want_level(logger, NULL); if (logger->want_level < level) return; @@ -3874,7 +3938,8 @@ static Scheme_Object * log_level_p(int argc, Scheme_Object *argv[]) { Scheme_Logger *logger; - int level; + Scheme_Object *name = scheme_false; + int level, want_level; if (!SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_logger_type)) scheme_wrong_contract("log-level?", "logger?", 0, argc, argv); @@ -3882,25 +3947,34 @@ log_level_p(int argc, Scheme_Object *argv[]) level = extract_level("log-level?", 0, 1, argc, argv); - if (logger->local_timestamp < *logger->timestamp) - update_want_level(logger); + if (argc > 2) { + if (!SCHEME_FALSEP(argv[2]) && !SCHEME_SYMBOLP(argv[2])) + scheme_wrong_contract("log-level?", "(or/c f? #symbol)", 2, argc, argv); + name = argv[2]; + } - return ((logger->want_level >= level) ? scheme_true : scheme_false); + want_level = get_want_level(logger, name); + + return ((want_level >= level) ? scheme_true : scheme_false); } static Scheme_Object * log_max_level(int argc, Scheme_Object *argv[]) { Scheme_Logger *logger; + Scheme_Object *name = scheme_false; if (!SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_logger_type)) scheme_wrong_contract("log-max-level", "logger?", 0, argc, argv); logger = (Scheme_Logger *)argv[0]; - if (logger->local_timestamp < *logger->timestamp) - update_want_level(logger); - - switch (logger->want_level) { + if (argc > 1) { + if (!SCHEME_FALSEP(argv[1]) && !SCHEME_SYMBOLP(argv[1])) + scheme_wrong_contract("log-max-level", "(or/c f? #symbol)", 1, argc, argv); + name = argv[1]; + } + + switch (get_want_level(logger, name)) { case 0: return scheme_false; case SCHEME_LOG_FATAL: diff --git a/racket/src/racket/src/mzmark_type.inc b/racket/src/racket/src/mzmark_type.inc index 4e85c28584..33d1eeb162 100644 --- a/racket/src/racket/src/mzmark_type.inc +++ b/racket/src/racket/src/mzmark_type.inc @@ -3004,6 +3004,7 @@ static int mark_logger_MARK(void *p, struct NewGC *gc) { Scheme_Logger *l = (Scheme_Logger *)p; gcMARK2(l->name, gc); gcMARK2(l->parent, gc); + gcMARK2(l->want_name_level_cache, gc); gcMARK2(l->timestamp, gc); gcMARK2(l->syslog_level, gc); gcMARK2(l->stderr_level, gc); @@ -3016,6 +3017,7 @@ static int mark_logger_FIXUP(void *p, struct NewGC *gc) { Scheme_Logger *l = (Scheme_Logger *)p; gcFIXUP2(l->name, gc); gcFIXUP2(l->parent, gc); + gcFIXUP2(l->want_name_level_cache, gc); gcFIXUP2(l->timestamp, gc); gcFIXUP2(l->syslog_level, gc); gcFIXUP2(l->stderr_level, gc); diff --git a/racket/src/racket/src/mzmarksrc.c b/racket/src/racket/src/mzmarksrc.c index 35940cd777..343dae2355 100644 --- a/racket/src/racket/src/mzmarksrc.c +++ b/racket/src/racket/src/mzmarksrc.c @@ -1207,6 +1207,7 @@ mark_logger { Scheme_Logger *l = (Scheme_Logger *)p; gcMARK2(l->name, gc); gcMARK2(l->parent, gc); + gcMARK2(l->want_name_level_cache, gc); gcMARK2(l->timestamp, gc); gcMARK2(l->syslog_level, gc); gcMARK2(l->stderr_level, gc); diff --git a/racket/src/racket/src/schpriv.h b/racket/src/racket/src/schpriv.h index 86bd484bf8..d7a0e6b98f 100644 --- a/racket/src/racket/src/schpriv.h +++ b/racket/src/racket/src/schpriv.h @@ -3693,6 +3693,7 @@ struct Scheme_Logger { Scheme_Object *name; Scheme_Logger *parent; int want_level; + Scheme_Object *want_name_level_cache; /* vector */ intptr_t *timestamp, local_timestamp; /* determines when want_level is up-to-date */ Scheme_Object *syslog_level; /* (list* ... ) */ Scheme_Object *stderr_level;