~ chicken-core (chicken-5) 318e11990dc6ee211d8859760e268ade1279d562
commit 318e11990dc6ee211d8859760e268ade1279d562
Author: Peter Bex <peter@more-magic.net>
AuthorDate: Fri Oct 14 21:46:13 2016 +0200
Commit: Evan Hanson <evhan@foldling.org>
CommitDate: Fri Oct 28 13:23:19 2016 +1300
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.
Signed-off-by: Evan Hanson <evhan@foldling.org>
diff --git a/chicken.h b/chicken.h
index bdb0522a..0fd37547 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 27ce2977..36960ed7 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 574c8fc1..db6337da 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 c9d626d6..54b57dde 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 bda48032..a6c12871 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 1b72164e..c43e4445 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 70b5e0bd..ad9a4a2f 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 9d1fc656..dfdfddf8 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,28 @@ 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 +5482,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 01c791cc..a4736347 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 bf7e6333..e2a744df 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 ea19bac2..10750542 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 b587bb14..aac46519 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 4ac0c074..17250e91 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))
Trap