X-Git-Url: https://git.hcoop.net/bpt/guile.git/blobdiff_plain/46abd569d545d07a05e0bdbbe16750c31dd7140e..193e2c52dc18ea79ec37cef744ea8c6ef97c2cb3:/libguile/stime.c diff --git a/libguile/stime.c b/libguile/stime.c index a6843377b..f656d886c 100644 --- a/libguile/stime.c +++ b/libguile/stime.c @@ -1,4 +1,5 @@ -/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2003, 2004, 2005, 2006, 2007, 2008 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2003, 2004, 2005, 2006, + * 2007, 2008, 2009, 2011, 2013, 2014 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public License @@ -46,6 +47,7 @@ #include #include #include +#include #include "libguile/_scm.h" #include "libguile/async.h" @@ -53,38 +55,26 @@ #include "libguile/strings.h" #include "libguile/vectors.h" #include "libguile/dynwind.h" +#include "libguile/strings.h" #include "libguile/validate.h" #include "libguile/stime.h" -#ifdef HAVE_UNISTD_H #include -#endif -# ifdef HAVE_SYS_TYPES_H -# include -# endif - -#ifdef HAVE_STRING_H -#include +#ifdef HAVE_CLOCK_GETTIME +# include #endif -#ifdef HAVE_SYS_TIMES_H -# include -#endif +#include +#include +#include #ifdef HAVE_SYS_TIMEB_H # include #endif -#ifndef tzname /* For SGI. */ -extern char *tzname[]; /* RS6000 and others reject char **tzname. */ -#endif -#if defined (__MINGW32__) -# define tzname _tzname -#endif - #if ! HAVE_DECL_STRPTIME extern char *strptime (); #endif @@ -96,27 +86,100 @@ extern char *strptime (); #endif -#ifdef HAVE_TIMES -static -timet mytime() +#if SCM_SIZEOF_LONG >= 8 && defined HAVE_CLOCK_GETTIME +/* Nanoseconds on 64-bit systems with POSIX timers. */ +#define TIME_UNITS_PER_SECOND 1000000000 +#else +/* Milliseconds for everyone else. */ +#define TIME_UNITS_PER_SECOND 1000 +#endif + +long scm_c_time_units_per_second = TIME_UNITS_PER_SECOND; + +static long +time_from_seconds_and_nanoseconds (long s, long ns) +{ + return s * TIME_UNITS_PER_SECOND + + ns / (1000000000 / TIME_UNITS_PER_SECOND); +} + + +/* A runtime-selectable mechanism to choose a timing mechanism. Really + we want to use POSIX timers, but that's not always possible. Notably, + the user may have everything she needs at compile-time, but if she's + running on an SMP machine without a common clock source, she can't + use POSIX CPUTIME clocks. */ +static long (*get_internal_real_time) (void); +static long (*get_internal_run_time) (void); + + +#ifdef HAVE_CLOCK_GETTIME +struct timespec posix_real_time_base; + +static long +get_internal_real_time_posix_timer (void) +{ + struct timespec ts; + clock_gettime (CLOCK_REALTIME, &ts); + return time_from_seconds_and_nanoseconds + (ts.tv_sec - posix_real_time_base.tv_sec, + ts.tv_nsec - posix_real_time_base.tv_nsec); +} + +#if defined _POSIX_CPUTIME && defined CLOCK_PROCESS_CPUTIME_ID +/* You see, FreeBSD defines _POSIX_CPUTIME but not + CLOCK_PROCESS_CPUTIME_ID. */ +#define HAVE_POSIX_CPUTIME 1 + +struct timespec posix_run_time_base; + +static long +get_internal_run_time_posix_timer (void) +{ + struct timespec ts; + clock_gettime (CLOCK_PROCESS_CPUTIME_ID, &ts); + return time_from_seconds_and_nanoseconds + (ts.tv_sec - posix_run_time_base.tv_sec, + ts.tv_nsec - posix_run_time_base.tv_nsec); +} +#endif /* _POSIX_CPUTIME */ +#endif /* HAVE_CLOCKTIME */ + + +#ifdef HAVE_GETTIMEOFDAY +struct timeval gettimeofday_real_time_base; + +static long +get_internal_real_time_gettimeofday (void) +{ + struct timeval tv; + gettimeofday (&tv, NULL); + return time_from_seconds_and_nanoseconds + (tv.tv_sec - gettimeofday_real_time_base.tv_sec, + (tv.tv_usec - gettimeofday_real_time_base.tv_usec) * 1000); +} +#endif + + +static long ticks_per_second; + +static long +get_internal_run_time_times (void) { struct tms time_buffer; times(&time_buffer); - return time_buffer.tms_utime + time_buffer.tms_stime; + return (time_buffer.tms_utime + time_buffer.tms_stime) + * TIME_UNITS_PER_SECOND / ticks_per_second; +} + +static timet fallback_real_time_base; +static long +get_internal_real_time_fallback (void) +{ + return time_from_seconds_and_nanoseconds + ((long) time (NULL) - fallback_real_time_base, 0); } -#else -# ifdef LACK_CLOCK -# define mytime() ((time((timet*)0) - scm_your_base) * SCM_TIME_UNITS_PER_SECOND) -# else -# define mytime clock -# endif -#endif -#ifdef HAVE_FTIME -struct timeb scm_your_base = {0}; -#else -timet scm_your_base = 0; -#endif SCM_DEFINE (scm_get_internal_real_time, "get-internal-real-time", 0, 0, 0, (), @@ -124,28 +187,11 @@ SCM_DEFINE (scm_get_internal_real_time, "get-internal-real-time", 0, 0, 0, "started.") #define FUNC_NAME s_scm_get_internal_real_time { -#ifdef HAVE_FTIME - struct timeb time_buffer; - - SCM tmp; - ftime (&time_buffer); - time_buffer.time -= scm_your_base.time; - tmp = scm_from_long (time_buffer.millitm - scm_your_base.millitm); - tmp = scm_sum (tmp, - scm_product (scm_from_int (1000), - scm_from_int (time_buffer.time))); - return scm_quotient (scm_product (tmp, - scm_from_int (SCM_TIME_UNITS_PER_SECOND)), - scm_from_int (1000)); -#else - return scm_from_long ((time((timet*)0) - scm_your_base) - * (int)SCM_TIME_UNITS_PER_SECOND); -#endif /* HAVE_FTIME */ + return scm_from_long (get_internal_real_time ()); } #undef FUNC_NAME -#ifdef HAVE_TIMES SCM_DEFINE (scm_times, "times", 0, 0, 0, (void), "Return an object with information about real and processor\n" @@ -173,27 +219,34 @@ SCM_DEFINE (scm_times, "times", 0, 0, 0, { struct tms t; clock_t rv; + SCM factor; SCM result = scm_c_make_vector (5, SCM_UNDEFINED); rv = times (&t); if (rv == -1) SCM_SYSERROR; - SCM_SIMPLE_VECTOR_SET (result, 0, scm_from_long (rv)); - SCM_SIMPLE_VECTOR_SET (result, 1, scm_from_long (t.tms_utime)); - SCM_SIMPLE_VECTOR_SET (result, 2, scm_from_long (t.tms_stime)); - SCM_SIMPLE_VECTOR_SET (result ,3, scm_from_long (t.tms_cutime)); - SCM_SIMPLE_VECTOR_SET (result, 4, scm_from_long (t.tms_cstime)); + + factor = scm_quotient (scm_from_long (TIME_UNITS_PER_SECOND), + scm_from_long (ticks_per_second)); + + SCM_SIMPLE_VECTOR_SET (result, 0, + scm_product (scm_from_long (rv), factor)); + SCM_SIMPLE_VECTOR_SET (result, 1, + scm_product (scm_from_long (t.tms_utime), factor)); + SCM_SIMPLE_VECTOR_SET (result, 2, + scm_product (scm_from_long (t.tms_stime), factor)); + SCM_SIMPLE_VECTOR_SET (result ,3, + scm_product (scm_from_long (t.tms_cutime), factor)); + SCM_SIMPLE_VECTOR_SET (result, 4, + scm_product (scm_from_long (t.tms_cstime), factor)); return result; } #undef FUNC_NAME -#endif /* HAVE_TIMES */ - -static long scm_my_base = 0; long -scm_c_get_internal_run_time () +scm_c_get_internal_run_time (void) { - return mytime () - scm_my_base; + return get_internal_run_time (); } SCM_DEFINE (scm_get_internal_run_time, "get-internal-run-time", 0, 0, 0, @@ -241,41 +294,18 @@ SCM_DEFINE (scm_gettimeofday, "gettimeofday", 0, 0, 0, { #ifdef HAVE_GETTIMEOFDAY struct timeval time; - int ret, err; - SCM_CRITICAL_SECTION_START; - ret = gettimeofday (&time, NULL); - err = errno; - SCM_CRITICAL_SECTION_END; - if (ret == -1) - { - errno = err; - SCM_SYSERROR; - } + if (gettimeofday (&time, NULL)) + SCM_SYSERROR; + return scm_cons (scm_from_long (time.tv_sec), scm_from_long (time.tv_usec)); #else -# ifdef HAVE_FTIME - struct timeb time; - - ftime(&time); - return scm_cons (scm_from_long (time.time), - scm_from_int (time.millitm * 1000)); -# else - timet timv; - int err; - - SCM_CRITICAL_SECTION_START; - timv = time (NULL); - err = errno; - SCM_CRITICAL_SECTION_END; - if (timv == -1) - { - errno = err; - SCM_SYSERROR; - } - return scm_cons (scm_from_long (timv), scm_from_int (0)); -# endif + timet t = time (NULL); + if (errno) + SCM_SYSERROR; + else + return scm_cons (scm_from_long ((long)t), SCM_INUM0); #endif } #undef FUNC_NAME @@ -421,8 +451,8 @@ SCM_DEFINE (scm_localtime, "localtime", 1, 1, 0, result = filltime (<, zoff, zname); SCM_CRITICAL_SECTION_END; - if (zname) - free (zname); + + free (zname); return result; } #undef FUNC_NAME @@ -475,7 +505,7 @@ SCM_DEFINE (scm_gmtime, "gmtime", 1, 0, 0, static void bdtime2c (SCM sbd_time, struct tm *lt, int pos, const char *subr) { - SCM_ASSERT (scm_is_simple_vector (sbd_time) + SCM_ASSERT (scm_is_vector (sbd_time) && SCM_SIMPLE_VECTOR_LENGTH (sbd_time) == 11, sbd_time, pos, subr); @@ -501,13 +531,14 @@ bdtime2c (SCM sbd_time, struct tm *lt, int pos, const char *subr) SCM_DEFINE (scm_mktime, "mktime", 1, 1, 0, (SCM sbd_time, SCM zone), - "@var{bd-time} is an object representing broken down time and @code{zone}\n" - "is an optional time zone specifier (otherwise the TZ environment variable\n" - "or the system default is used).\n\n" - "Returns a pair: the car is a corresponding\n" - "integer time value like that returned\n" - "by @code{current-time}; the cdr is a broken down time object, similar to\n" - "as @var{bd-time} but with normalized values.") + "@var{sbd_time} is an object representing broken down time and\n" + "@code{zone} is an optional time zone specifier (otherwise the\n" + "TZ environment variable or the system default is used).\n" + "\n" + "Returns a pair: the car is a corresponding integer time value\n" + "like that returned by @code{current-time}; the cdr is a broken\n" + "down time object, similar to as @var{sbd_time} but with\n" + "normalized values.") #define FUNC_NAME s_scm_mktime { timet itime; @@ -579,8 +610,7 @@ SCM_DEFINE (scm_mktime, "mktime", 1, 1, 0, result = scm_cons (scm_from_long (itime), filltime (<, zoff, zname)); - if (zname) - free (zname); + free (zname); scm_dynwind_end (); return result; @@ -626,16 +656,17 @@ SCM_DEFINE (scm_strftime, "strftime", 2, 0, 0, char *tbuf; int size = 50; - const char *fmt; + char *fmt; char *myfmt; - int len; + size_t len; SCM result; SCM_VALIDATE_STRING (1, format); bdtime2c (stime, &t, SCM_ARG2, FUNC_NAME); - fmt = scm_i_string_chars (format); - len = scm_i_string_length (format); + /* Convert string to UTF-8 so that non-ASCII characters in the + format are passed through unchanged. */ + fmt = scm_to_utf8_stringn (format, &len); /* Ugly hack: strftime can return 0 if its buffer is too small, but some valid time strings (e.g. "%p") can sometimes produce @@ -643,9 +674,11 @@ SCM_DEFINE (scm_strftime, "strftime", 2, 0, 0, character to the format string, so that valid returns are always nonzero. */ myfmt = scm_malloc (len+2); - *myfmt = 'x'; - strncpy(myfmt+1, fmt, len); - myfmt[len+1] = 0; + *myfmt = (scm_t_uint8) 'x'; + strncpy (myfmt + 1, fmt, len); + myfmt[len + 1] = 0; + scm_remember_upto_here_1 (format); + free (fmt); tbuf = scm_malloc (size); { @@ -696,7 +729,7 @@ SCM_DEFINE (scm_strftime, "strftime", 2, 0, 0, #endif } - result = scm_from_locale_stringn (tbuf + 1, len - 1); + result = scm_from_utf8_string (tbuf + 1); free (tbuf); free (myfmt); #if HAVE_STRUCT_TM_TM_ZONE @@ -711,7 +744,7 @@ SCM_DEFINE (scm_strptime, "strptime", 2, 0, 0, (SCM format, SCM string), "Performs the reverse action to @code{strftime}, parsing\n" "@var{string} according to the specification supplied in\n" - "@var{template}. The interpretation of month and day names is\n" + "@var{format}. The interpretation of month and day names is\n" "dependent on the current locale. The value returned is a pair.\n" "The car has an object with time components\n" "in the form returned by @code{localtime} or @code{gmtime},\n" @@ -722,14 +755,17 @@ SCM_DEFINE (scm_strptime, "strptime", 2, 0, 0, #define FUNC_NAME s_scm_strptime { struct tm t; - const char *fmt, *str, *rest; + char *fmt, *str, *rest; + size_t used_len; long zoff; SCM_VALIDATE_STRING (1, format); SCM_VALIDATE_STRING (2, string); - fmt = scm_i_string_chars (format); - str = scm_i_string_chars (string); + /* Convert strings to UTF-8 so that non-ASCII characters are passed + through unchanged. */ + fmt = scm_to_utf8_string (format); + str = scm_to_utf8_string (string); /* initialize the struct tm */ #define tm_init(field) t.field = 0 @@ -759,6 +795,9 @@ SCM_DEFINE (scm_strptime, "strptime", 2, 0, 0, instance it doesn't. Force a sensible value for our error message. */ errno = EINVAL; + scm_remember_upto_here_2 (format, string); + free (str); + free (fmt); SCM_SYSERROR; } @@ -770,8 +809,14 @@ SCM_DEFINE (scm_strptime, "strptime", 2, 0, 0, zoff = 0; #endif + /* Compute the number of UTF-8 characters. */ + used_len = u8_strnlen ((scm_t_uint8*) str, rest-str); + scm_remember_upto_here_2 (format, string); + free (str); + free (fmt); + return scm_cons (filltime (&t, zoff, NULL), - scm_from_signed_integer (rest - str)); + scm_from_signed_integer (used_len)); } #undef FUNC_NAME #endif /* HAVE_STRPTIME */ @@ -782,13 +827,49 @@ scm_init_stime() scm_c_define ("internal-time-units-per-second", scm_from_long (SCM_TIME_UNITS_PER_SECOND)); -#ifdef HAVE_FTIME - if (!scm_your_base.time) ftime(&scm_your_base); + /* Init POSIX timers, and see if we can use them. */ +#ifdef HAVE_CLOCK_GETTIME + if (clock_gettime (CLOCK_REALTIME, &posix_real_time_base) == 0) + get_internal_real_time = get_internal_real_time_posix_timer; + +#ifdef HAVE_POSIX_CPUTIME + { + clockid_t dummy; + + /* Only use the _POSIX_CPUTIME clock if it's going to work across + CPUs. */ + if (clock_getcpuclockid (0, &dummy) == 0 && + clock_gettime (CLOCK_PROCESS_CPUTIME_ID, &posix_run_time_base) == 0) + get_internal_run_time = get_internal_run_time_posix_timer; + else + errno = 0; + } +#endif /* HAVE_POSIX_CPUTIME */ +#endif /* HAVE_CLOCKTIME */ + + /* If needed, init and use gettimeofday timer. */ +#ifdef HAVE_GETTIMEOFDAY + if (!get_internal_real_time + && gettimeofday (&gettimeofday_real_time_base, NULL) == 0) + get_internal_real_time = get_internal_real_time_gettimeofday; +#endif + + /* Init ticks_per_second for scm_times, and use times(2)-based + run-time timer if needed. */ +#ifdef _SC_CLK_TCK + ticks_per_second = sysconf (_SC_CLK_TCK); #else - if (!scm_your_base) time(&scm_your_base); + ticks_per_second = CLK_TCK; #endif + if (!get_internal_run_time) + get_internal_run_time = get_internal_run_time_times; - if (!scm_my_base) scm_my_base = mytime(); + if (!get_internal_real_time) + /* No POSIX timers, gettimeofday doesn't work... badness! */ + { + fallback_real_time_base = time (NULL); + get_internal_real_time = get_internal_real_time_fallback; + } scm_add_feature ("current-time"); #include "libguile/stime.x"