~ chicken-core (chicken-5) 7bd92ff78681ddee949441114bcc8bd6bd6a4284
commit 7bd92ff78681ddee949441114bcc8bd6bd6a4284
Author: felix <felix@call-with-current-continuation.org>
AuthorDate: Thu Jul 29 23:00:37 2010 +0200
Commit: felix <felix@call-with-current-continuation.org>
CommitDate: Thu Jul 29 23:00:37 2010 +0200
superficially seems to work
diff --git a/batch-driver.scm b/batch-driver.scm
index a19bffd7..637fd79b 100644
--- a/batch-driver.scm
+++ b/batch-driver.scm
@@ -91,7 +91,7 @@
(upap #f)
(ssize (or (memq 'nursery options) (memq 'stack-size options))) )
- (define (cputime) (##sys#fudge 6))
+ (define (cputime) (current-milliseconds))
(define (dribble fstr . args)
(when verbose (printf "~?~%~!" fstr args)))
diff --git a/chicken.h b/chicken.h
index 625c1fde..5179bfa1 100644
--- a/chicken.h
+++ b/chicken.h
@@ -1459,6 +1459,14 @@ extern double trunc(double);
#define C_a_i_flonum_sqrt(ptr, c, x) C_flonum(ptr, C_sqrt(C_flonum_magnitude(x)))
#define C_a_i_flonum_abs(ptr, c, x) C_flonum(ptr, C_fabs(C_flonum_magnitude(x)))
+#define C_a_i_current_milliseconds(ptr, c, dummy) C_flonum(ptr, C_milliseconds())
+
+/* this is of course silly, but only used for profiling, where we can assume that
+ the process doesn't run for more than a week.
+
+ (now someone will do exactly that ...) */
+#define C_i_current_cpu_milliseconds_as_fixnum(dummy) C_fix(C_cpu_milliseconds())
+
/* Variables: */
@@ -1811,6 +1819,8 @@ C_fctexport C_word C_fcall C_a_i_flonum_round_proper(C_word **a, int c, C_word n
C_fctexport C_word C_fcall C_i_getprop(C_word sym, C_word prop, C_word def) C_regparm;
C_fctexport C_word C_fcall C_putprop(C_word **a, C_word sym, C_word prop, C_word val) C_regparm;
C_fctexport C_word C_fcall C_i_get_keyword(C_word key, C_word args, C_word def) C_regparm;
+C_fctexport double C_fcall C_milliseconds(void) C_regparm;
+C_fctexport double C_fcall C_cpu_milliseconds(void) C_regparm;
C_fctexport C_word C_fcall C_i_foreign_char_argumentp(C_word x) C_regparm;
C_fctexport C_word C_fcall C_i_foreign_fixnum_argumentp(C_word x) C_regparm;
diff --git a/extras.scm b/extras.scm
index 26e5db04..36450b78 100644
--- a/extras.scm
+++ b/extras.scm
@@ -64,7 +64,9 @@
(srand t) ) ) ) )
(define (randomize . n)
- (let ((nn (if (null? n) (##sys#fudge 2) (car n))))
+ (let ((nn (if (null? n)
+ (##sys#inexact->exact (fp/ (current-seconds) 1000))
+ (car n))))
(##sys#check-exact nn 'randomize)
(##core#inline "C_randomize" nn) ) )
diff --git a/files.scm b/files.scm
index 2c1c167f..3e8b0d63 100644
--- a/files.scm
+++ b/files.scm
@@ -37,7 +37,6 @@
(declare
(unit files)
(uses regex data-structures)
- (fixnum)
(hide chop-pds absolute-pathname-root root-origin root-directory split-directory)
(disable-interrupts)
(foreign-declare #<<EOF
@@ -96,9 +95,9 @@ EOF
"could not open newfile for write - "
newfile)))))
(s (make-string blocksize)))
- (let loop ((d (read-string! blocksize s i))
- (l 0))
- (if (= 0 d)
+ (let loop ((d (read-string! blocksize s i))
+ (l 0))
+ (if (fx= 0 d)
(begin
(close-input-port i)
(close-output-port o)
@@ -111,7 +110,7 @@ EOF
(##sys#error (string-append
"error writing file starting at "
(number->string l)))))
- (loop (read-string! blocksize s i) (+ d l)))))))
+ (loop (read-string! blocksize s i) (fx+ d l)))))))
(define (file-move origfile newfile #!optional (clobber #f) (blocksize 1024))
(##sys#check-string origfile 'file-move)
@@ -139,9 +138,9 @@ EOF
"could not open newfile for write - "
newfile)))))
(s (make-string blocksize)))
- (let loop ((d (read-string! blocksize s i))
- (l 0))
- (if (= 0 d)
+ (let loop ((d (read-string! blocksize s i))
+ (l 0))
+ (if (fx= 0 d)
(begin
(close-input-port i)
(close-output-port o)
@@ -159,7 +158,7 @@ EOF
(##sys#error (string-append
"error writing file starting at "
(number->string l)))))
- (loop (read-string! blocksize s i) (+ d l)))))))
+ (loop (read-string! blocksize s i) (fx+ d l)))))))
;;; Pathname operations:
@@ -338,11 +337,7 @@ EOF
(define create-temporary-file)
(define create-temporary-directory)
-(let ((get-environment-variable get-environment-variable)
- (make-pathname make-pathname)
- (file-exists? file-exists?)
- (directory-exists? directory-exists?)
- (call-with-output-file call-with-output-file)
+(let ((call-with-output-file call-with-output-file)
(temp #f)
(temp-prefix "temp"))
(define (tempdir)
@@ -358,7 +353,7 @@ EOF
(lambda (#!optional (ext "tmp"))
(##sys#check-string ext 'create-temporary-file)
(let loop ()
- (let* ((n (##sys#fudge 16))
+ (let* ((n (##core#inline "C_random_fixnum" #x10000))
(pn (make-pathname
(tempdir)
(##sys#string-append
@@ -370,7 +365,7 @@ EOF
(set! create-temporary-directory
(lambda ()
(let loop ()
- (let* ((n (##sys#fudge 16))
+ (let* ((n (##core#inline "C_random_fixnum" #x10000))
(pn (make-pathname
(tempdir)
(string-append
diff --git a/library.scm b/library.scm
index e3ab347d..80339aae 100644
--- a/library.scm
+++ b/library.scm
@@ -194,7 +194,7 @@ EOF
(define ##sys#file-info (##core#primitive "C_file_info"))
(define ##sys#symbol-table-info (##core#primitive "C_get_symbol_table_info"))
(define ##sys#memory-info (##core#primitive "C_get_memory_info"))
-(define (current-milliseconds) (##sys#fudge 16))
+(define (current-milliseconds) (##core#inline_allocate ("C_a_i_current_milliseconds" 4) #f))
(define (current-gc-milliseconds) (##sys#fudge 31))
(define cpu-time (##core#primitive "C_cpu_time"))
(define ##sys#decode-seconds (##core#primitive "C_decode_seconds"))
diff --git a/manual/Unit srfi-18 b/manual/Unit srfi-18
index e47a3bfb..c8eea6fe 100644
--- a/manual/Unit srfi-18
+++ b/manual/Unit srfi-18
@@ -80,22 +80,6 @@ Suspends the current thread until input ({{MODE}} is {{#:input}}), output ({{MOD
or both ({{MODE}} is {{#:all}}) is available. {{FD}} should be a file-descriptor (not a port!) open
for input or output, respectively.
-<procedure>(time->milliseconds TIME)</procedure>
-
-Converts a time object (as created via {{current-time}}) into an exact integer representing
-the number of milliseconds since process startup.
-
-<procedure>(milliseconds->time ms)</procedure>
-
-Converts into a time object an exact integer representing
-the number of milliseconds since process startup.
-
-This procedure may be useful in combination with {{thread-sleep!}} when your compilation unit is using {{(declare fixnum-arithmetic)}}. In that case you won't be able to pass an inexact value to {{thread-sleep!}}, but you can do the following:
-
- (define (thread-sleep!/ms ms)
- (thread-sleep!
- (milliseconds->time (+ ms (current-milliseconds)))))
-
== SRFI-18 specification
diff --git a/profiler.scm b/profiler.scm
index c118c4bc..c07817a3 100644
--- a/profiler.scm
+++ b/profiler.scm
@@ -29,7 +29,7 @@
(unit profiler)
(hide ##sys#profile-name ##sys#profile-vector-list)
(disable-interrupts)
- (fixnum-arithmetic) )
+ (fixnum) )
(foreign-declare #<<EOF
#if !defined(_MSC_VER)
@@ -96,19 +96,25 @@ EOF
((eq? maxfix count) #f)
(else (add1 count))))
(when (zero? ipc)
- (##sys#setislot vec it0 (##sys#fudge 6)) )
+ (##sys#setislot
+ vec it0
+ (##core#inline "C_i_current_cpu_milliseconds_as_fixnum" #f)))
(##sys#setislot vec ip (add1 ipc)) ) ) ) )
(define (##sys#profile-exit index vec)
- (let* ([i (* index profile-info-entry-size)]
- [it0 (+ i 2)]
- [it (+ i 3)]
- [ip (+ i 4)]
+ (let* ([i (fx* index profile-info-entry-size)]
+ [it0 (fx+ i 2)]
+ [it (fx+ i 3)]
+ [ip (fx+ i 4)]
[ipc (sub1 (##sys#slot vec ip))] )
(##sys#setislot vec ip ipc)
(when (zero? ipc)
- (##sys#setislot vec it (+ (##sys#slot vec it) (- (##sys#fudge 6) (##sys#slot vec it0))))
- (##sys#setislot vec it0 0) ) ) )
+ (##sys#setislot
+ vec it
+ (fx+ (##sys#slot vec it)
+ (fx- (##core#inline "C_i_current_cpu_milliseconds_as_fixnum" #f)
+ (##sys#slot vec it0)))))
+ (##sys#setislot vec it0 0) ) )
;;; Generate profile:
@@ -126,14 +132,14 @@ EOF
(for-each
(lambda (vec)
(let ([len (##sys#size vec)])
- (do ([i 0 (+ i profile-info-entry-size)])
- ((>= i len))
+ (do ([i 0 (fx+ i profile-info-entry-size)])
+ ((fx>= i len))
(write-char #\()
(write (##sys#slot vec i))
(write-char #\space)
- (write (##sys#slot vec (add1 i)))
+ (write (##sys#slot vec (fx+ i 1)))
(write-char #\space)
- (write (##sys#slot vec (+ i 3)))
+ (write (##sys#slot vec (fx+ i 3)))
(write-char #\))
(write-char #\newline) ) ) )
##sys#profile-vector-list) )
diff --git a/runtime.c b/runtime.c
index eefdf51c..779c3f21 100644
--- a/runtime.c
+++ b/runtime.c
@@ -429,7 +429,7 @@ static C_TLS unsigned int
heap_size;
static C_TLS int chicken_is_initialized;
static C_TLS jmp_buf gc_restart;
-static C_TLS long
+static C_TLS double
timer_start_ms,
gc_ms,
timer_accumulated_gc_ms,
@@ -478,8 +478,6 @@ static int C_fcall hash_string(int len, C_char *str, unsigned int m) C_regparm;
static C_word C_fcall lookup(C_word key, int len, C_char *str, C_SYMBOL_TABLE *stable) C_regparm;
static double compute_symbol_table_load(double *avg_bucket_len, int *total);
static C_word C_fcall convert_string_to_number(C_char *str, int radix, C_word *fix, double *flo) C_regparm;
-static long C_fcall milliseconds(void);
-static long C_fcall cpu_milliseconds(void);
static void C_fcall remark_system_globals(void) C_regparm;
static void C_fcall remark(C_word *x) C_regparm;
static C_word C_fcall intern0(C_char *name) C_regparm;
@@ -1634,7 +1632,7 @@ C_word C_dbg_hook(C_word dummy)
/* Timing routines: */
-long C_fcall milliseconds(void)
+C_regparm double C_fcall C_milliseconds(void)
{
#ifdef C_NONUNIX
if(CLOCKS_PER_SEC == 1000) return clock();
@@ -1671,7 +1669,7 @@ C_regparm time_t C_fcall C_seconds(long *ms)
}
-long C_fcall cpu_milliseconds(void)
+C_regparm double C_fcall C_cpu_milliseconds(void)
{
#if defined(C_NONUNIX) || defined(__CYGWIN__)
if(CLOCKS_PER_SEC == 1000) return clock();
@@ -2619,7 +2617,7 @@ C_regparm void C_fcall C_reclaim(void *trampoline, void *proc)
C_SCHEME_BLOCK *bp;
C_GC_ROOT *gcrp;
WEAK_TABLE_ENTRY *wep;
- long tgc;
+ double tgc;
C_SYMBOL_TABLE *stp;
volatile int finalizers_checked;
FINALIZER_NODE *flist;
@@ -2643,7 +2641,7 @@ C_regparm void C_fcall C_reclaim(void *trampoline, void *proc)
if(C_setjmp(gc_restart) || (start = C_fromspace_top) >= C_fromspace_limit) {
if(gc_bell) C_putchar(7);
- tgc = cpu_milliseconds();
+ tgc = C_cpu_milliseconds();
if(gc_mode == GC_REALLOC) {
C_rereclaim2(percentage(heap_size, C_heap_growth), 0);
@@ -2873,7 +2871,7 @@ C_regparm void C_fcall C_reclaim(void *trampoline, void *proc)
}
if(gc_mode == GC_MAJOR) {
- tgc = cpu_milliseconds() - tgc;
+ tgc = C_cpu_milliseconds() - tgc;
gc_ms += tgc;
timer_accumulated_gc_ms += tgc;
}
@@ -2916,7 +2914,7 @@ C_regparm void C_fcall C_reclaim(void *trampoline, void *proc)
if(gc_mode == GC_MAJOR) gc_count_1 = 0;
- if(C_post_gc_hook != NULL) C_post_gc_hook(gc_mode, tgc);
+ if(C_post_gc_hook != NULL) C_post_gc_hook(gc_mode, (long)tgc);
/* Jump from the Empire State Building... */
C_longjmp(C_restart, 1);
@@ -3466,7 +3464,7 @@ void handle_interrupt(void *trampoline, void *proc)
{
C_word *p, x, n;
int i;
- long c;
+ double c;
/* Build vector with context information: */
n = C_temporary_stack_bottom - C_temporary_stack;
@@ -3496,7 +3494,7 @@ void handle_interrupt(void *trampoline, void *proc)
if(C_immediatep(x))
panic(C_text("`##sys#interrupt-hook' is not defined"));
- c = cpu_milliseconds() - interrupt_time;
+ c = C_cpu_milliseconds() - interrupt_time;
last_interrupt_latency = c;
C_timer_interrupt_counter = C_initial_timer_interrupt_period; /* just in case */
/* <- no continuation is passed: "##sys#interrupt-hook" may not return! */
@@ -3874,7 +3872,7 @@ C_regparm C_word C_fcall C_start_timer(void)
mutation_count = 0;
gc_count_1 = 0;
gc_count_2 = 0;
- timer_start_ms = cpu_milliseconds();
+ timer_start_ms = C_cpu_milliseconds();
gc_ms = 0;
return C_SCHEME_UNDEFINED;
}
@@ -3882,15 +3880,16 @@ C_regparm C_word C_fcall C_start_timer(void)
void C_ccall C_stop_timer(C_word c, C_word closure, C_word k)
{
- long t0 = cpu_milliseconds() - timer_start_ms;
+ double t0 = C_cpu_milliseconds() - timer_start_ms;
C_word
ab[ WORDS_PER_FLONUM * 2 + 7 ], /* 2 flonums, 1 vector of 6 elements */
*a = ab,
- elapsed = C_flonum(&a, (double)t0 / 1000.0),
- gc_time = C_flonum(&a, (double)gc_ms / 1000.0),
+ elapsed = C_flonum(&a, t0 / 1000.0),
+ gc_time = C_flonum(&a, gc_ms / 1000.0),
info;
- info = C_vector(&a, 6, elapsed, gc_time, C_fix(mutation_count), C_fix(gc_count_1), C_fix(gc_count_2));
+ info = C_vector(&a, 6, elapsed, gc_time, C_fix(mutation_count), C_fix(gc_count_1),
+ C_fix(gc_count_2));
C_kontinue(k, info);
}
@@ -3991,13 +3990,12 @@ C_regparm C_word C_fcall C_char_ready_p(C_word port)
C_regparm C_word C_fcall C_fudge(C_word fudge_factor)
{
int i, j;
- long tgc;
+ double tgc;
switch(fudge_factor) {
case C_fix(1): return C_SCHEME_END_OF_FILE; /* eof object */
case C_fix(2): /* get time */
- /* can be considered broken (overflows into negatives), but is useful for randomize */
- return C_fix(C_MOST_POSITIVE_FIXNUM & time(NULL));
+ panic(C_text("(##sys#fudge 2) [get time] not implemented"));
case C_fix(3): /* 64-bit system? */
#ifdef C_SIXTY_FOUR
@@ -4021,7 +4019,7 @@ C_regparm C_word C_fcall C_fudge(C_word fudge_factor)
return C_fix(0);
case C_fix(6): /* milliseconds CPU */
- return C_fix(C_MOST_POSITIVE_FIXNUM & cpu_milliseconds());
+ panic(C_text("(##sys#fudge 6) [current CPU milliseconds] not implemented"));
case C_fix(7): /* wordsize */
return C_fix(sizeof(C_word));
@@ -4055,7 +4053,7 @@ C_regparm C_word C_fcall C_fudge(C_word fudge_factor)
return C_mk_bool(C_enable_gcweak);
case C_fix(16): /* milliseconds (wall clock) */
- return C_fix(C_MOST_POSITIVE_FIXNUM & milliseconds());
+ panic(C_text("(##sys#fudge 16) [current wall clock milliseconds] not implemented"));
case C_fix(17): /* fixed heap? */
return(C_mk_bool(C_heap_size_is_fixed));
@@ -4204,7 +4202,7 @@ C_regparm void C_fcall C_raise_interrupt(int reason)
#endif
interrupt_reason = reason;
- interrupt_time = cpu_milliseconds();
+ interrupt_time = C_cpu_milliseconds();
}
}
diff --git a/scheduler.scm b/scheduler.scm
index c0ab3b14..52149bd5 100644
--- a/scheduler.scm
+++ b/scheduler.scm
@@ -27,7 +27,6 @@
(declare
(unit scheduler)
- (fixnum)
(disable-interrupts)
(hide ##sys#ready-queue-head ##sys#ready-queue-tail ##sys#timeout-list
##sys#update-thread-state-buffer ##sys#restore-thread-state-buffer
@@ -36,6 +35,7 @@
##sys#fdset-select-timeout ##sys#fdset-restore
##sys#clear-i/o-state-for-thread! ##sys#abandon-mutexes)
(not inline ##sys#interrupt-hook)
+ (unsafe)
(foreign-declare #<<EOF
#ifdef HAVE_ERRNO_H
# include <errno.h>
@@ -79,8 +79,6 @@ static fd_set C_fdset_input, C_fdset_output, C_fdset_input_2, C_fdset_output_2;
EOF
) )
-(declare (unsafe))
-
(include "common-declarations.scm")
(define-syntax dbg
@@ -107,17 +105,17 @@ EOF
(let loop1 ()
;; Unblock threads waiting for timeout:
(unless (null? ##sys#timeout-list)
- (let ([now (##sys#fudge 16)])
+ (let ((now (##core#inline_allocate ("C_a_i_current_milliseconds" 4) #f)))
(dbg "timeout (" now ") list: " ##sys#timeout-list)
- (let loop ([lst ##sys#timeout-list])
+ (let loop ((lst ##sys#timeout-list))
(if (null? lst)
(set! ##sys#timeout-list '())
(let* ([tmo1 (caar lst)]
[tto (cdar lst)]
[tmo2 (##sys#slot tto 4)] )
(dbg " " tto " -> " tmo2)
- (if (eq? tmo1 tmo2)
- (if (>= now tmo1)
+ (if (= tmo1 tmo2)
+ (if (fp>= now tmo1)
(begin
(##sys#setislot tto 13 #t) ; mark as being unblocked by timeout
(##sys#clear-i/o-state-for-thread! tto)
@@ -132,10 +130,15 @@ EOF
(when (and (null? ##sys#ready-queue-head)
(null? ##sys#fd-list)
(pair? ##sys#timeout-list))
- (let ([tmo1 (caar ##sys#timeout-list)])
+ (let ((tmo1 (caar ##sys#timeout-list)))
(set! eintr
- (and (not (##core#inline "C_msleep" (fxmax 0 (- tmo1 now))))
- (foreign-value "C_signal_interrupted_p" bool) ) ) ) ) ) )
+ (and (not (##core#inline
+ "C_msleep"
+ (fxmax
+ 0
+ (##sys#inexact->exact (fp- tmo1 now)))))
+ (foreign-value
+ "C_signal_interrupted_p" bool) ) ) ) ) ) )
(loop (cdr lst)) ) ) ) ) ) )
;; Unblock threads blocked by I/O:
(if eintr
@@ -223,14 +226,14 @@ EOF
(dbg t " blocks for " tm)
;; This should really use a balanced tree:
(let loop ([tl ##sys#timeout-list] [prev #f])
- (if (or (null? tl) (< tm (caar tl)))
+ (if (or (null? tl) (fp< tm (caar tl)))
(if prev
(set-cdr! prev (cons (cons tm t) tl))
(set! ##sys#timeout-list (cons (cons tm t) tl)) )
(loop (cdr tl) tl) ) )
(##sys#setslot t 3 'blocked)
(##sys#setislot t 13 #f)
- (##sys#setislot t 4 tm) )
+ (##sys#setslot t 4 tm) )
(define (##sys#thread-block-for-termination! t t2)
(dbg t " blocks for " t2)
@@ -298,7 +301,8 @@ EOF
[get-output-string get-output-string] )
(lambda (arg)
(let ([ct ##sys#current-thread])
- (dbg "exception: " ct " -> " (if (##sys#structure? arg 'condition) (##sys#slot arg 2) arg))
+ (dbg "exception: " ct " -> "
+ (if (##sys#structure? arg 'condition) (##sys#slot arg 2) arg))
(cond [(foreign-value "C_abort_on_thread_exceptions" bool)
(let* ([pt ##sys#primordial-thread]
[ptx (##sys#slot pt 1)] )
@@ -325,10 +329,10 @@ EOF
(define ##sys#fd-list '())
(define ##sys#fdset-select-timeout
- (foreign-lambda* int ([bool to] [unsigned-long tm])
+ (foreign-lambda* int ([bool to] [double tm])
"struct timeval timeout;"
"timeout.tv_sec = tm / 1000;"
- "timeout.tv_usec = (tm % 1000) * 1000;"
+ "timeout.tv_usec = fmod(tm, 1000) * 1000;"
"C_fdset_input_2 = C_fdset_input;"
"C_fdset_output_2 = C_fdset_output;"
"C_return(select(FD_SETSIZE, &C_fdset_input, &C_fdset_output, NULL, to ? &timeout : NULL));") )
@@ -381,10 +385,10 @@ EOF
[n (##sys#fdset-select-timeout ; we use FD_SETSIZE, but really should use max fd
(or rq? to?)
(if (and to? (not rq?)) ; no thread was unblocked by timeout, so wait
- (let* ([tmo1 (caar ##sys#timeout-list)]
- [now (##sys#fudge 16)])
- (fxmax 0 (- tmo1 now)) )
- 0) ) ] ) ; otherwise immediate timeout.
+ (let* ((tmo1 (caar ##sys#timeout-list))
+ (now (##core#inline_allocate ("C_a_i_current_milliseconds" 4) #f)))
+ (fpmax 0.0 (fp- tmo1 now)) )
+ 0.0) ) ] ) ; otherwise immediate timeout.
(dbg n " fds ready")
(cond [(eq? -1 n)
(##sys#force-primordial)]
diff --git a/srfi-18.import.scm b/srfi-18.import.scm
index 85b97aed..204062ff 100644
--- a/srfi-18.import.scm
+++ b/srfi-18.import.scm
@@ -39,7 +39,7 @@
make-condition-variable
make-mutex
make-thread
- milliseconds->time
+ milliseconds->time ; DEPRECATED
mutex-lock!
mutex-name
mutex-specific
@@ -68,7 +68,7 @@
thread-wait-for-i/o!
thread-yield!
thread?
- time->milliseconds
+ time->milliseconds ; DEPRECATED
time->seconds
time?
uncaught-exception-reason
diff --git a/srfi-18.scm b/srfi-18.scm
index 9566696b..cfae1e46 100644
--- a/srfi-18.scm
+++ b/srfi-18.scm
@@ -45,69 +45,35 @@
;;; Helper routines:
-(define-inline (exactify n)
- (if (##sys#immediate? n)
- n
- (##core#inline "C_i_inexact_to_exact" n)))
-
-(define ##sys#compute-time-limit
- (let ([truncate truncate])
- (lambda (tm)
- (and tm
- (cond [(##sys#structure? tm 'time) (##sys#slot tm 1)]
- [(number? tm)
- (fx+ (##sys#fudge 16)
- (exactify (truncate (* tm 1000))))]
- [else (##sys#signal-hook #:type-error "invalid timeout argument" tm)] ) ) ) ) )
+(define (##sys#compute-time-limit tm loc)
+ (cond ((not tm) #f)
+ ((##sys#structure? tm 'time) (##sys#slot tm 1))
+ ((number? tm) (+ (current-milliseconds) (* tm 1000)))
+ (else (##sys#signal-hook #:type-error loc "invalid timeout argument" tm))))
;;; Time objects:
-(declare
- (foreign-declare #<<EOF
-static C_TLS long C_ms;
-#define C_get_seconds C_seconds(&C_ms)
-EOF
-) )
-
-(define-foreign-variable C_get_seconds double)
-(define-foreign-variable C_startup_time_seconds double)
-(define-foreign-variable C_ms long)
-
(define (current-time)
- (let* ([s C_get_seconds]
- [ss C_startup_time_seconds]
- [ms C_ms] )
- (##sys#make-structure
- 'time
- (exactify (truncate (+ (* (- s ss) 1000) C_ms)))
- s
- C_ms) ) )
+ (##sys#make-structure 'time (current-milliseconds)))
(define srfi-18:current-time current-time)
(define (time->seconds tm)
(##sys#check-structure tm 'time 'time->seconds)
- (+ (##sys#slot tm 2) (/ (##sys#slot tm 3) 1000)) )
+ (fp* (##sys#slot tm 1) 1000.0))
-(define (time->milliseconds tm)
+(define (time->milliseconds tm) ; DEPRECATED
(##sys#check-structure tm 'time 'time->milliseconds)
- (+ (exactify (* (- (##sys#slot tm 2) C_startup_time_seconds) 1000))
- (##sys#slot tm 3) ) )
+ (##sys#slot tm 1))
(define (seconds->time n)
(##sys#check-number n 'seconds->time)
- (let* ([n2 (max 0 (- n C_startup_time_seconds))] ; seconds since startup
- [ms (truncate
- (* 1000
- (##sys#flonum-fraction (##sys#exact->inexact n))))] ; milliseconds
- [n3 (exactify (truncate (+ (* n2 1000) ms)))] ) ; milliseconds since startup
- (##sys#make-structure 'time n3 (truncate n) (exactify ms)) ) )
-
-(define (milliseconds->time nms)
- (##sys#check-exact nms 'milliseconds->time)
- (let ((s (+ C_startup_time_seconds (/ nms 1000))))
- (##sys#make-structure 'time nms s 0) ) )
+ (##sys#make-structure 'time (fp* (##sys#exact->inexact n) 1000)))
+
+(define (milliseconds->time nms) ; DEPRECATED
+ (##sys#check-number nms 'milliseconds->time)
+ (##sys#make-structure 'time (##sys#exact->inexact nms)))
(define (time? x) (##sys#structure? x 'time))
@@ -205,7 +171,8 @@ EOF
(define thread-join!
(lambda (thread . timeout)
(##sys#check-structure thread 'thread 'thread-join!)
- (let* ((limit (and (pair? timeout) (##sys#compute-time-limit (##sys#slot timeout 0))))
+ (let* ((limit (and (pair? timeout)
+ (##sys#compute-time-limit (##sys#slot timeout 0) 'thread-join!)))
(rest (and (pair? timeout) (##sys#slot timeout 1)))
(tosupplied (and rest (pair? rest)))
(toval (and tosupplied (##sys#slot rest 0))) )
@@ -261,7 +228,7 @@ EOF
(##sys#add-to-ready-queue thread) ) )
(define (thread-sleep! tm)
- (define (sleep limit loc)
+ (define (sleep limit)
(##sys#call-with-current-continuation
(lambda (return)
(let ((ct ##sys#current-thread))
@@ -269,7 +236,7 @@ EOF
(##sys#thread-block-for-timeout! ct limit)
(##sys#schedule) ) ) ) )
(unless tm (##sys#signal-hook #:type-error 'thread-sleep! "invalid timeout argument" tm))
- (sleep (##sys#compute-time-limit tm) 'thread-sleep!) )
+ (sleep (##sys#compute-time-limit tm 'thread-sleep!)) )
;;; Mutexes:
@@ -305,7 +272,7 @@ EOF
(lambda (mutex . ms-and-t)
(##sys#check-structure mutex 'mutex 'mutex-lock!)
(let* ([limitsup (pair? ms-and-t)]
- [limit (and limitsup (##sys#compute-time-limit (car ms-and-t)))]
+ [limit (and limitsup (##sys#compute-time-limit (car ms-and-t) 'mutex-lock!))]
[threadsup (fx> (length ms-and-t) 1)]
[thread (and threadsup (cadr ms-and-t))] )
(when thread (##sys#check-structure thread 'thread 'mutex-lock!))
@@ -317,7 +284,9 @@ EOF
(##sys#schedule) )
(define (check)
(when (##sys#slot mutex 4) ; abandoned
- (return (##sys#signal (##sys#make-structure 'condition '(abandoned-mutex-exception) '()))) ) )
+ (return
+ (##sys#signal
+ (##sys#make-structure 'condition '(abandoned-mutex-exception) '()))) ) )
(dbg ct ": locking " mutex)
(cond [(not (##sys#slot mutex 5))
(if (and threadsup (not thread))
@@ -368,7 +337,7 @@ EOF
(##sys#call-with-current-continuation
(lambda (return)
(let ([waiting (##sys#slot mutex 3)]
- [limit (and timeout (##sys#compute-time-limit timeout))] )
+ [limit (and timeout (##sys#compute-time-limit timeout 'mutex-unlock!))] )
(##sys#setislot mutex 4 #f)
(##sys#setislot mutex 5 #f)
(let ((t (##sys#slot mutex 2)))
diff --git a/tcp.scm b/tcp.scm
index 324f6237..96299349 100644
--- a/tcp.scm
+++ b/tcp.scm
@@ -28,7 +28,6 @@
(declare
(unit tcp)
(uses extras scheduler)
- (fixnum-arithmetic)
(export tcp-close tcp-listen tcp-connect tcp-accept tcp-accept-ready? ##sys#tcp-port->fileno tcp-listener? tcp-addresses
tcp-abandon-port tcp-listener-port tcp-listener-fileno tcp-port-numbers tcp-buffer-size
tcp-read-timeout tcp-write-timeout tcp-accept-timeout tcp-connect-timeout)
@@ -224,7 +223,7 @@ EOF
(let ((c (##core#inline "C_subchar" host i)))
(if (char=? c #\:)
(values
- (substring host (add1 i) len)
+ (substring host (fx+ i 1) len)
(let* ((s (substring host 0 i))
(p (##net#getservbyname s proto)) )
(when (eq? 0 p)
@@ -316,16 +315,14 @@ EOF
(define ((check loc) x)
(when x (##sys#check-exact x loc))
x)
- (define minute (* 60 1000))
+ (define minute (fx* 60 1000))
(set! tcp-read-timeout (make-parameter minute (check 'tcp-read-timeout)))
(set! tcp-write-timeout (make-parameter minute (check 'tcp-write-timeout)))
(set! tcp-connect-timeout (make-parameter #f (check 'tcp-connect-timeout)))
(set! tcp-accept-timeout (make-parameter #f (check 'tcp-accept-timeout))) )
(define ##net#io-ports
- (let ((make-input-port make-input-port)
- (make-output-port make-output-port)
- (tbs tcp-buffer-size)
+ (let ((tbs tcp-buffer-size)
(make-string make-string) )
(lambda (fd)
(unless (##net#make-nonblocking fd)
@@ -351,7 +348,7 @@ EOF
(when tmr
(##sys#thread-block-for-timeout!
##sys#current-thread
- (fx+ (##sys#fudge 16) tmr) ) )
+ (+ (current-milliseconds) tmr) ) )
(##sys#thread-block-for-i/o! ##sys#current-thread fd #t)
(yield)
(when (##sys#slot ##sys#current-thread 13)
@@ -459,7 +456,7 @@ EOF
(when tmw
(##sys#thread-block-for-timeout!
##sys#current-thread
- (fx+ (##sys#fudge 16) tmw) ) )
+ (+ (current-milliseconds) tmw) ) )
(##sys#thread-block-for-i/o! ##sys#current-thread fd #f)
(yield)
(when (##sys#slot ##sys#current-thread 13)
@@ -527,7 +524,7 @@ EOF
(when tma
(##sys#thread-block-for-timeout!
##sys#current-thread
- (fx+ (##sys#fudge 16) tma) ) )
+ (+ (current-milliseconds) tma) ) )
(##sys#thread-block-for-i/o! ##sys#current-thread fd #t)
(yield)
(when (##sys#slot ##sys#current-thread 13)
@@ -592,7 +589,7 @@ EOF
(when tmc
(##sys#thread-block-for-timeout!
##sys#current-thread
- (fx+ (##sys#fudge 16) tmc) ) )
+ (+ (current-milliseconds) tmc) ) )
(##sys#thread-block-for-i/o! ##sys#current-thread s #:all)
(yield)
(when (##sys#slot ##sys#current-thread 13)
@@ -603,12 +600,12 @@ EOF
(loop) ) ) )
(fail) ) )
(let ((err (get-socket-error s)))
- (cond ((= err -1)
+ (cond ((fx= err -1)
(##net#close s)
(##sys#signal-hook
#:network-error 'tcp-connect
(##sys#string-append "getsockopt() failed - " strerror)))
- ((> err 0)
+ ((fx> err 0)
(##net#close s)
(##sys#signal-hook
#:network-error 'tcp-connect
diff --git a/tests/man-or-boy.scm b/tests/man-or-boy.scm
index 73391f2b..fe98ec3f 100644
--- a/tests/man-or-boy.scm
+++ b/tests/man-or-boy.scm
@@ -23,8 +23,9 @@
(+ (x4) (x5))
(B)))
-(do ((i 1000 (sub1 i)))
+(do ((i 1 (sub1 i)))
((zero? i))
+ (print i)
(assert
(= -175416
(A 20
diff --git a/tweaks.scm b/tweaks.scm
index 7a44082a..786e11b5 100644
--- a/tweaks.scm
+++ b/tweaks.scm
@@ -30,16 +30,13 @@
(cond-expand
- (debugbuild
- (declare
- (fixnum)
- (disable-interrupts) ))
- (else
+ ((not debugbuild)
(declare
(disable-interrupts)
(no-bound-checks)
(no-procedure-checks)
- (no-argc-checks))))
+ (no-argc-checks)))
+ (else))
(define-inline (node? x) (##sys#structure? x 'node))
(define-inline (make-node c p s) (##sys#make-structure 'node c p s))
Trap