From 0773092062085c650aa7e5b162891c7f9cc087d3 Mon Sep 17 00:00:00 2001 From: Peter Bex Date: Fri, 14 Oct 2016 21:46:13 +0200 Subject: [PATCH 8/9] Add helper functions for remaining fudge factors. These are all used directly inline in the one place they were used. For fudge factor 13 (debug mode), a ##sys#debug-mode? is added, to make it more readable. A types.db entry is provided to ensure debug mode checks don't cause a performance regression (there was a built-in rewrite for ##sys#fudge). Alternatively, some of the internal variables could be exposed to the outside world (like fake_tty, finalizer_count etc), but this would also make them settable, which is something we might not want. And by not having them be static, performance could also be adversely affected in case of the variables used in the GC. --- chicken.h | 7 ++++++ common-declarations.scm | 2 +- core.scm | 2 +- csc.scm | 2 +- csi.scm | 3 ++- eval.scm | 2 +- lfa2.scm | 2 +- library.scm | 34 +++++++++++++++++----------- profiler.scm | 2 +- runtime.c | 60 ++++++++++++++++++++++++++++++++++++------------- scrutinizer.scm | 2 +- tests/gobble.scm | 2 +- types.db | 2 ++ 13 files changed, 85 insertions(+), 37 deletions(-) diff --git a/chicken.h b/chicken.h index bdb0522..0fd3754 100644 --- a/chicken.h +++ b/chicken.h @@ -2148,6 +2148,13 @@ C_fctexport C_word C_fcall C_i_get_keyword(C_word key, C_word args, C_word def) C_fctexport C_u64 C_fcall C_milliseconds(void) C_regparm; C_fctexport C_u64 C_fcall C_cpu_milliseconds(void) C_regparm; C_fctexport double C_fcall C_bignum_to_double(C_word bignum) C_regparm; +C_fctexport C_word C_fcall C_i_debug_modep(void) C_regparm; +C_fctexport C_word C_fcall C_i_dump_heap_on_exitp(void) C_regparm; +C_fctexport C_word C_fcall C_i_accumulated_gc_time(void) C_regparm; +C_fctexport C_word C_fcall C_i_allocated_finalizer_count(void) C_regparm; +C_fctexport C_word C_fcall C_i_live_finalizer_count(void) C_regparm; +C_fctexport C_word C_fcall C_i_profilingp(void) C_regparm; +C_fctexport C_word C_fcall C_i_tty_forcedp(void) C_regparm; C_fctexport C_word C_fcall C_a_i_cpu_time(C_word **a, int c, C_word buf) C_regparm; diff --git a/common-declarations.scm b/common-declarations.scm index 27ce297..36960ed 100644 --- a/common-declarations.scm +++ b/common-declarations.scm @@ -42,7 +42,7 @@ (define-syntax d (syntax-rules () ((_ arg ...) - (when (##sys#fudge 13) ; debug-mode + (when (##sys#debug-mode?) (print arg ...)))))) (else (begin diff --git a/core.scm b/core.scm index 574c8fc..db6337d 100644 --- a/core.scm +++ b/core.scm @@ -332,7 +332,7 @@ chicken.pretty-print) (define (d arg1 . more) - (when (##sys#fudge 13) ; debug mode? + (when (##sys#debug-mode?) (if (null? more) (pp arg1) (apply print arg1 more)))) diff --git a/csc.scm b/csc.scm index c9d626d..54b57dd 100644 --- a/csc.scm +++ b/csc.scm @@ -879,7 +879,7 @@ EOF (if to-stdout '("-to-stdout") `("-output-file" ,(quotewrap fc)) ) - (if (##sys#fudge 13) + (if (##sys#debug-mode?) '("-:d") '()) (map quote-option diff --git a/csi.scm b/csi.scm index bda4803..881b6aa 100644 --- a/csi.scm +++ b/csi.scm @@ -244,7 +244,8 @@ EOF history-count)))) (define (tty-input?) - (or (##sys#fudge 12) (##sys#tty-port? ##sys#standard-input)) ) + (or (##core#inline "C_i_tty_forcedp") + (##sys#tty-port? ##sys#standard-input)) ) (set! ##sys#break-on-error #f) diff --git a/eval.scm b/eval.scm index 1b72164..c43e444 100644 --- a/eval.scm +++ b/eval.scm @@ -942,7 +942,7 @@ ;;; Loading source/object files: -(define load-verbose (make-parameter (##sys#fudge 13))) +(define load-verbose (make-parameter (##sys#debug-mode?))) (define ##sys#current-load-filename #f) (define ##sys#dload-disabled #f) diff --git a/lfa2.scm b/lfa2.scm index 70b5e0b..ad9a4a2 100644 --- a/lfa2.scm +++ b/lfa2.scm @@ -50,7 +50,7 @@ (define lfa2-debug #t) (define (d fstr . args) - (when (and lfa2-debug (##sys#fudge 13)) + (when (and lfa2-debug (##sys#debug-mode?)) (printf "[debug|~a] ~a~?~%" d-depth (make-string d-depth #\space) fstr args)) ) (define dd d) diff --git a/library.scm b/library.scm index 7b1bc7e..1368032 100644 --- a/library.scm +++ b/library.scm @@ -240,6 +240,7 @@ EOF (define (reset) ((##sys#reset-handler))) (define (##sys#quit-hook result) ((##sys#exit-handler) 0)) (define (quit #!optional result) (##sys#quit-hook result)) +(define (##sys#debug-mode?) (##core#inline "C_i_debug_modep")) (define (error . args) (if (pair? args) @@ -247,7 +248,7 @@ EOF (##sys#signal-hook #:error #f))) (define ##sys#warnings-enabled #t) -(define ##sys#notices-enabled (##sys#fudge 13)) +(define ##sys#notices-enabled (##sys#debug-mode?)) (define (warning msg . args) (when ##sys#warnings-enabled @@ -4669,10 +4670,10 @@ EOF (define (##sys#cleanup-before-exit) (set! exit-in-progress #t) - (when (##sys#fudge 37) ; -:H given? + (when (##core#inline "C_i_dump_heap_on_exitp") (##sys#print "\n" #f ##sys#standard-error) (##sys#dump-heap-state)) - (when (##sys#fudge 45) ; -:p or -:P given? + (when (##core#inline "C_i_profilingp") (##core#inline "C_i_dump_statistical_profile")) (let loop () (let ((tasks ##sys#cleanup-tasks)) @@ -4680,7 +4681,7 @@ EOF (unless (null? tasks) (for-each (lambda (t) (t)) tasks) (loop)))) - (when (##sys#fudge 13) ; debug mode + (when (##sys#debug-mode?) (##sys#print "[debug] forcing finalizers...\n" #f ##sys#standard-error) ) (when (force-finalizers) (##sys#force-finalizers)) ) @@ -5418,7 +5419,8 @@ EOF ;;; GC info: -(define (current-gc-milliseconds) (##sys#fudge 31)) +(define (current-gc-milliseconds) + (##core#inline "C_i_accumulated_gc_time")) (define (set-gc-report! flag) (##core#inline "C_set_gc_report" flag)) @@ -5445,27 +5447,29 @@ EOF (define set-finalizer! (let ((string-append string-append)) (lambda (x y) - (when (fx>= (##sys#fudge 26) _max_pending_finalizers) + (when (fx>= (##core#inline "C_i_live_finalizer_count") + _max_pending_finalizers) (cond ((##core#inline "C_resize_pending_finalizers" (fx* 2 _max_pending_finalizers)) (set! ##sys#pending-finalizers (##sys#vector-resize ##sys#pending-finalizers (fx+ (fx* 2 _max_pending_finalizers) 1) (##core#undefined))) - (when (##sys#fudge 13) + (when (##sys#debug-mode?) (##sys#print (string-append "[debug] too many finalizers (" - (##sys#number->string (##sys#fudge 26)) + (##sys#number->string + (##core#inline "C_i_live_finalizer_count")) "), resized max finalizers to " (##sys#number->string _max_pending_finalizers) "\n") #f ##sys#standard-error))) (else - (when (##sys#fudge 13) + (when (##sys#debug-mode?) (##sys#print (string-append "[debug] too many finalizers (" - (##sys#fudge 26) + (##core#inline "C_i_live_finalizer_count") "), forcing ...\n") #f ##sys#standard-error)) (##sys#force-finalizers) ) ) ) @@ -5479,11 +5483,15 @@ EOF (unless working (set! working #t) (let* ((c (##sys#slot ##sys#pending-finalizers 0)) ) - (when (##sys#fudge 13) + (when (##sys#debug-mode?) (##sys#print (string-append "[debug] running " (##sys#number->string c) - " finalizer(s) (" (##sys#number->string (##sys#fudge 26)) - " live, " (##sys#number->string (##sys#fudge 27)) + " finalizer(s) (" + (##sys#number->string + (##core#inline "C_i_live_finalizer_count")) + " live, " + (##sys#number->string + (##core#inline "C_i_allocated_finalizer_count")) " allocated) ...\n") #f ##sys#standard-error)) (do ([i 0 (fx+ i 1)]) diff --git a/profiler.scm b/profiler.scm index 01c791c..a473634 100644 --- a/profiler.scm +++ b/profiler.scm @@ -124,7 +124,7 @@ [write-char write-char] [write write] ) (lambda () - (when (##sys#fudge 13) + (when (##sys#debug-mode?) (##sys#print "[debug] writing profile...\n" #f ##sys#standard-error) ) (apply with-output-to-file ##sys#profile-name diff --git a/runtime.c b/runtime.c index bf7e633..e2a744d 100644 --- a/runtime.c +++ b/runtime.c @@ -4665,6 +4665,14 @@ C_regparm C_word C_fcall C_set_gc_report(C_word flag) return C_SCHEME_UNDEFINED; } +C_regparm C_word C_fcall C_i_accumulated_gc_time(void) +{ + double tgc; + + tgc = timer_accumulated_gc_ms; + timer_accumulated_gc_ms = 0; + return C_fix(tgc); +} C_regparm C_word C_fcall C_start_timer(void) { @@ -4826,12 +4834,38 @@ C_regparm C_word C_fcall C_char_ready_p(C_word port) #endif } +C_regparm C_word C_fcall C_i_tty_forcedp(void) +{ + return C_mk_bool(fake_tty_flag); +} + +C_regparm C_word C_fcall C_i_debug_modep(void) +{ + return C_mk_bool(debug_mode); +} -C_regparm C_word C_fcall C_fudge(C_word fudge_factor) +C_regparm C_word C_fcall C_i_dump_heap_on_exitp(void) { - int i, j; - double tgc; + return C_mk_bool(dump_heap_on_exit); +} + +C_regparm C_word C_fcall C_i_profilingp(void) +{ + return C_mk_bool(profiling); +} + +C_regparm C_word C_fcall C_i_live_finalizer_count(void) +{ + return C_fix(live_finalizer_count); +} + +C_regparm C_word C_fcall C_i_allocated_finalizer_count(void) +{ + return C_fix(allocated_finalizer_count); +} +C_regparm C_word C_fcall C_fudge(C_word fudge_factor) +{ switch(fudge_factor) { case C_fix(1): /* eof object */ panic(C_text("(##sys#fudge 1) [eof object] is obsolete")); @@ -4866,10 +4900,10 @@ C_regparm C_word C_fcall C_fudge(C_word fudge_factor) panic(C_text("(##sys#fudge 11) [UNIX system] is obsolete")); case C_fix(12): /* tty forced? */ - return C_mk_bool(fake_tty_flag); + panic(C_text("(##sys#fudge 12) [tty forced] is obsolete")); case C_fix(13): /* debug mode */ - return C_mk_bool(debug_mode); + panic(C_text("(##sys#fudge 13) [debug mode] is obsolete")); case C_fix(14): /* interrupts enabled? */ panic(C_text("(##sys#fudge 14) [interrupts enabled] is obsolete")); @@ -4887,9 +4921,7 @@ C_regparm C_word C_fcall C_fudge(C_word fudge_factor) panic(C_text("(##sys#fudge 18) [stack direction] is obsolete")); case C_fix(19): /* number of locatives */ - for(i = j = 0; i < locative_table_count; ++i) - if(locative_table[ i ] != C_SCHEME_UNDEFINED) ++j; - return C_fix(j); + panic(C_text("(##sys#fudge 19) [nr. of locatives] is obsolete")); case C_fix(20): /* unused */ panic(C_text("(##sys#fudge 20) [?] is obsolete")); @@ -4910,10 +4942,10 @@ C_regparm C_word C_fcall C_fudge(C_word fudge_factor) panic(C_text("(##sys#fudge 25) [enable repl on error] is obsolete")); case C_fix(26): /* number of untriggered finalizers */ - return C_fix(live_finalizer_count); + panic(C_text("(##sys#fudge 26) [live finalizers] is obsolete")); case C_fix(27): /* total number of finalizers used and unused */ - return C_fix(allocated_finalizer_count); + panic(C_text("(##sys#fudge 27) [total finalizers] is obsolete")); case C_fix(28): /* are procedure-tabled enabled? */ panic(C_text("(##sys#fudge 28) [ptables] is obsolete")); @@ -4925,9 +4957,7 @@ C_regparm C_word C_fcall C_fudge(C_word fudge_factor) panic(C_text("(##sys#fudge 30) [?] is obsolete")); case C_fix(31): /* GC time since last invocation */ - tgc = timer_accumulated_gc_ms; - timer_accumulated_gc_ms = 0; - return C_fix(tgc); + panic(C_text("(##sys#fudge 31) [accumulated gc time] is obsolete")); case C_fix(32): /* are GC-hooks enabled? */ panic(C_text("(##sys#fudge 32) [gchooks] is obsolete")); @@ -4945,7 +4975,7 @@ C_regparm C_word C_fcall C_fudge(C_word fudge_factor) panic(C_text("(##sys#fudge 36) [toggle debug-mode] is obsolete")); case C_fix(37): /* heap-dump enabled? */ - return C_mk_bool(dump_heap_on_exit); + panic(C_text("(##sys#fudge 37) [dump heap on exit] is obsolete")); case C_fix(38): /* unused */ panic(C_text("(##sys#fudge 38) [old svn rev.] is obsolete")); @@ -4969,7 +4999,7 @@ C_regparm C_word C_fcall C_fudge(C_word fudge_factor) panic(C_text("(##sys#fudge 44) [debugging] is obsolete")); case C_fix(45): /* Whether we're currently profiling */ - return C_mk_bool(profiling); + panic(C_text("(##sys#fudge 45) [profiling] is obsolete")); default: panic(C_text("Unknown fudge factor")); diff --git a/scrutinizer.scm b/scrutinizer.scm index ea19bac..1075054 100644 --- a/scrutinizer.scm +++ b/scrutinizer.scm @@ -51,7 +51,7 @@ (define scrutiny-debug #t) (define (d fstr . args) - (when (and scrutiny-debug (##sys#fudge 13)) + (when (and scrutiny-debug (##sys#debug-mode?)) (printf "[debug|~a] ~a~?~%" d-depth (make-string d-depth #\space) fstr args)) ) (define dd d) diff --git a/tests/gobble.scm b/tests/gobble.scm index b587bb1..aac4651 100644 --- a/tests/gobble.scm +++ b/tests/gobble.scm @@ -8,7 +8,7 @@ (let loop ((k 0)) (when (< k n) (let ((x (make-string 1000))) - (when (and (zero? (modulo k 100000)) (##sys#fudge 13)) + (when (and (zero? (modulo k 100000)) (##sys#debug-mode?)) (print* ".")) (loop (+ k 1000)))))) diff --git a/types.db b/types.db index 4ac0c07..17250e9 100644 --- a/types.db +++ b/types.db @@ -1035,6 +1035,8 @@ (error (procedure error (* #!rest) noreturn)) (##sys#error (procedure ##sys#error (* #!rest) noreturn)) (##sys#signal-hook (procedure ##sys#signal-hook (* #!rest) noreturn)) +(##sys#debug-mode? (procedure ##sys#debug-mode? () boolean) + (() (##core#inline "C_i_debug_modep"))) (executable-pathname (#(procedure #:pure) executable-pathname () (or string false))) (exit (procedure exit (#!optional fixnum) noreturn)) (exit-handler (#(procedure #:clean #:enforce) exit-handler (#!optional (procedure (fixnum) . *)) procedure)) -- 2.1.4