[gfortran] Implementation SYSTEM_CLOCK intrinsic subroutine
Steve Kargl
sgk@troutmask.apl.washington.edu
Sat May 15 17:04:00 GMT 2004
On Fri, May 14, 2004 at 06:12:55PM +0100, Paul Brook wrote:
>
> A few issues:
>
> +try
> +gfc_check_system_clock (gfc_expr * count, gfc_expr * count_rate,
> + gfc_expr * count_max)
> +{
>
> The standard specifies that all arguments must be of *default* integer type.
> Also, the second parameter of *_check should be the argument number that is
> being checked (ie. not always zero).
Fixed.
> We may wish to allow other integer kinds an an extension, but we must still
> ensure that all arguments have the same type, otherwise bad things will
> happen.
Fixed. I used same_type_check() to ensure that the types are
compatible. Note, in the upcoming Fortran 200X standard the
type of COUNT_RATE can be integer or real, so our implementation
will soon be out-of-date.
> Depending on the type of checking done above, the resolved name may just be
> based on gfc_default_integer_kind().
I tried using gfc_default_integer_kind(), but the -I8 option appears broken.
>
> #elif HAVE_TIME_H
>
> Should be #elif defined(HAVE_TIME_H)
Fixed.
> void
> __system_clock_1(int *count, int *count_rate, int *count_max)
>
> Should be declared static.
Fixed by attrition.
>
> t = ((double)tp.tv_sec + tp.tv_usec * 1.e-6) * TCK;
> if (t - t0 < (double)INT_MAX)
> *count = (int) (t - t0);
> else
> {
> *count = 0;
> t0 = t;
> }
>
> This is wrong. In the case where t - t0 > INT_MAX we should wrap, not truncate
> to 0. This behaviour is specified by the standard.
Fixed.
> I don't really like the use of double, though I guess I could cope. It's not
> all that hard to perform these calculations with integer arithmetic.
I retained double for now. I'm still considering an integer implementation,
but I could not convince myself that the algorithm I had was robust.
>
> t1 = TCK * (t - init_time);
> if (t1 < (time_t) INT_MAX)
> *count = (int) t1;
> else
> {
> *count = 0;
> init_time = t;
> }
>
> Likewise. Also t1 may be negative, and you're also assuming
> sizeof(time_t) >= sizeof(INT_MAX). You shouldn't be multiplying by TCK.
>
> if (count >= 0) \
> *__count = (GFC_INTEGER_##KIND) count; \
> else \
> *__count = - GFC_INTEGER_##KIND##_HUGE; \
>
> This breaks when sizeof(int) > KIND.
>
This should be solved by the new implementation in system_clock.c.
Things to note:
(1) I solved the "call system_clock" problem where no arguments
are given by introducing prefix(system_clock_nop). I suspect
that I need to add a __inline__ directive to this, so the
middle/back end optimizes the call way. But, I've never
__inline__ and its semantics are unclear to me.
(2) prefix(system_clock_4) and prefix(system_clock_8) are no longer
generated by macro substitution. If a system clock is not
available then the functions need to return -HUGE(0_KIND). This
was causing sizeof() problems.
Two files are attached, the diff and system_clock.c.
Changelog for gcc/libgfortran
2004-05-15 Steven G. Kargl <kargls@comcast.net>
* makefile.am: Add intrinsics/system_clock.c
* intrinsics/system_clock.c: New file
* Makefile.in: regenerated
* aclocal.m4: regenerated
Changelog for gcc/gcc/fortran
2004-05-15 Steven G. Kargl <kargls@comcast.net>
*check.c (gfc_check_system_clock): New function.
*intrinsic.c (add_sym_3s): New function, use it.
*intrinsic.h (gfc_check_system_clock,gfc_resolve_system_clock): Add prototypes
*iresolve.c (gfc_resolve_system_clock): New function
*check.c, intrinsic.c, iresolve.c: Update copyright date
--
steve
Steve
-------------- next part --------------
Index: gcc/fortran/check.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/fortran/check.c,v
retrieving revision 1.2
diff -u -b -u -b -r1.2 check.c
--- gcc/fortran/check.c 13 May 2004 06:40:29 -0000 1.2
+++ gcc/fortran/check.c 15 May 2004 16:23:35 -0000
@@ -1,5 +1,5 @@
/* Check functions
- Copyright (C) 2002 Free Software Foundation, Inc.
+ Copyright (C) 2002, 2004 Free Software Foundation, Inc.
Contributed by Andy Vaught & Katherine Holcomb
This file is part of GNU G95.
@@ -1863,4 +1863,63 @@
}
return SUCCESS;
+}
+
+/* The arguments of SYSTEM_CLOCK are scalar, integer variables. Note,
+ count, count_rate, and count_max are all optional arguments */
+
+try
+gfc_check_system_clock (gfc_expr * count, gfc_expr * count_rate,
+ gfc_expr * count_max)
+{
+
+ if (count != NULL)
+ {
+ if (scalar_check (count, 0) == FAILURE)
+ return FAILURE;
+
+ if (type_check (count, 0, BT_INTEGER) == FAILURE)
+ return FAILURE;
+
+ if (variable_check (count, 0) == FAILURE)
+ return FAILURE;
+ }
+
+ if (count_rate != NULL)
+ {
+ if (scalar_check (count_rate, 1) == FAILURE)
+ return FAILURE;
+
+ if (type_check (count_rate, 1, BT_INTEGER) == FAILURE)
+ return FAILURE;
+
+ if (variable_check (count_rate, 1) == FAILURE)
+ return FAILURE;
+
+ if (count != NULL && same_type_check(count, 0, count_rate, 1) == FAILURE)
+ return FAILURE;
+
+ }
+
+ if (count_max != NULL)
+ {
+ if (scalar_check (count_max, 2) == FAILURE)
+ return FAILURE;
+
+ if (type_check (count_max, 2, BT_INTEGER) == FAILURE)
+ return FAILURE;
+
+ if (variable_check (count_max, 2) == FAILURE)
+ return FAILURE;
+
+ if (count != NULL && same_type_check(count, 0, count_max, 2) == FAILURE)
+ return FAILURE;
+
+ if (count_rate != NULL
+ && same_type_check(count_rate, 1, count_max, 2) == FAILURE)
+ return FAILURE;
+
+ }
+
+ return SUCCESS;
}
Index: gcc/fortran/intrinsic.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/fortran/intrinsic.c,v
retrieving revision 1.2
diff -u -b -u -b -r1.2 intrinsic.c
--- gcc/fortran/intrinsic.c 13 May 2004 06:40:30 -0000 1.2
+++ gcc/fortran/intrinsic.c 15 May 2004 16:23:38 -0000
@@ -1,6 +1,6 @@
/* Build up a list of intrinsic subroutines and functions for the
name-resolution stage.
- Copyright (C) 2000, 2001, 2002 Free Software Foundation, Inc.
+ Copyright (C) 2000, 2001, 2002, 2004 Free Software Foundation, Inc.
Contributed by Andy Vaught & Katherine Holcomb
This file is part of GNU G95.
@@ -452,6 +452,33 @@
(void*)0);
}
+/* Add the name of an intrinsic subroutine with three arguments to the list
+ of intrinsic names. */
+
+static void add_sym_3s (const char *name, int elemental, int actual_ok, bt type,
+ int kind,
+ try (*check)(gfc_expr *,gfc_expr *,gfc_expr *),
+ gfc_expr *(*simplify)(gfc_expr *,gfc_expr *,gfc_expr *),
+ void (*resolve)(gfc_code *),
+ const char* a1, bt type1, int kind1, int optional1,
+ const char* a2, bt type2, int kind2, int optional2,
+ const char* a3, bt type3, int kind3, int optional3
+ ) {
+ gfc_check_f cf;
+ gfc_simplify_f sf;
+ gfc_resolve_f rf;
+
+ cf.f3 = check;
+ sf.f3 = simplify;
+ rf.s1 = resolve;
+
+ add_sym (name, elemental, actual_ok, type, kind, cf, sf, rf,
+ a1, type1, kind1, optional1,
+ a2, type2, kind2, optional2,
+ a3, type3, kind3, optional3,
+ (void*)0);
+}
+
static void add_sym_4 (const char *name, int elemental, int actual_ok, bt type,
int kind,
@@ -1631,8 +1658,8 @@
sz, BT_INTEGER, di, 1, pt, BT_INTEGER, di, 1,
gt, BT_INTEGER, di, 1);
- add_sym_3 ("system_clock", 0, 1, BT_UNKNOWN, 0,
- NULL, NULL, NULL,
+ add_sym_3s ("system_clock", 0, 1, BT_UNKNOWN, 0,
+ gfc_check_system_clock, NULL, gfc_resolve_system_clock,
c, BT_INTEGER, di, 1, cr, BT_INTEGER, di, 1,
cm, BT_INTEGER, di, 1);
}
Index: gcc/fortran/intrinsic.h
===================================================================
RCS file: /cvs/gcc/gcc/gcc/fortran/intrinsic.h,v
retrieving revision 1.2
diff -u -b -u -b -r1.2 intrinsic.h
--- gcc/fortran/intrinsic.h 13 May 2004 06:40:30 -0000 1.2
+++ gcc/fortran/intrinsic.h 15 May 2004 16:23:38 -0000
@@ -99,6 +99,7 @@
/* Intrinsic subroutines. */
try gfc_check_cpu_time (gfc_expr *);
+try gfc_check_system_clock (gfc_expr *, gfc_expr *, gfc_expr *);
try gfc_check_date_and_time (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
try gfc_check_mvbits (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *,
gfc_expr *);
@@ -302,6 +303,7 @@
/* Intrinsic subroutine resolution. */
void gfc_resolve_cpu_time (gfc_code *);
+void gfc_resolve_system_clock(gfc_code *);
void gfc_resolve_random_number (gfc_code *);
Index: gcc/fortran/iresolve.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/fortran/iresolve.c,v
retrieving revision 1.2
diff -u -b -u -b -r1.2 iresolve.c
--- gcc/fortran/iresolve.c 13 May 2004 06:40:30 -0000 1.2
+++ gcc/fortran/iresolve.c 15 May 2004 16:23:39 -0000
@@ -1,5 +1,5 @@
/* Intrinsic function resolution.
- Copyright (C) 2000, 2001, 2002, 2003 Free Software Foundation, Inc.
+ Copyright (C) 2000, 2001, 2002, 2003, 2004 Free Software Foundation, Inc.
Contributed by Andy Vaught & Katherine Holcomb
This file is part of GNU G95.
@@ -1356,6 +1356,41 @@
PREFIX("random_r%d") : PREFIX("arandom_r%d"),
kind);
c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
+}
+
+/* Determine if the arguments to SYSTEM_CLOCK are INTEGER(4) or INTEGER(8) */
+
+void
+gfc_resolve_system_clock (gfc_code * c)
+{
+ const char *name;
+
+ int kind;
+
+ if (c->ext.actual->expr != NULL)
+ {
+ kind = c->ext.actual->expr->ts.kind;
+ name = gfc_get_string (PREFIX("system_clock_%d"), kind);
+ c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
+ }
+ else if (c->ext.actual->next->expr != NULL)
+ {
+ kind = c->ext.actual->next->expr->ts.kind;
+ name = gfc_get_string (PREFIX("system_clock_%d"), kind);
+ c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
+ }
+ else if (c->ext.actual->next->next->expr != NULL)
+ {
+ kind = c->ext.actual->next->next->expr->ts.kind;
+ name = gfc_get_string (PREFIX("system_clock_%d"), kind);
+ c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
+ }
+ else
+ {
+ name = gfc_get_string (PREFIX("system_clock_nop"));
+ c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
+ }
+
}
Index: libgfortran/Makefile.am
===================================================================
RCS file: /cvs/gcc/gcc/libgfortran/Makefile.am,v
retrieving revision 1.2
diff -u -b -u -b -r1.2 Makefile.am
--- libgfortran/Makefile.am 13 May 2004 06:40:59 -0000 1.2
+++ libgfortran/Makefile.am 15 May 2004 16:24:02 -0000
@@ -49,6 +49,7 @@
intrinsics/reshape_generic.c \
intrinsics/reshape_packed.c \
intrinsics/selected_kind.f90 \
+intrinsics/system_clock.c \
intrinsics/transpose_generic.c \
intrinsics/unpack_generic.c \
runtime/in_pack_generic.c \
-------------- next part --------------
/* Implementation of the SYSTEM_CLOCK intrinsic.
Copyright (C) 2004 Free Software Foundation, Inc.
This file is part of the GNU Fortran 95 runtime library (libgfortran).
Libgfortran is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
License as published by the Free Software Foundation; either
version 2.1 of the License, or (at your option) any later version.
Libgfortran is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public
License along with libgfortran; see the file COPYING.LIB. If not,
write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
Boston, MA 02111-1307, USA. */
#include "config.h"
#include <sys/types.h>
#include "libgfortran.h"
#include <limits.h>
#if defined(HAVE_SYS_TIME_H) && defined(HAVE_GETTIMEOFDAY)
# include <sys/time.h>
# define TCK 1000
#elif defined(HAVE_TIME_H)
# include <time.h>
# define TCK 1
#endif
/* prefix(system_clock_4) is the INTEGER(4) version of the SYSTEM_CLOCK
intrinsic subroutine. It returns the number of clock ticks for the current
system time, the number of ticks per second, and the maximum possible value
for COUNT. On the first call to SYSTEM_CLOCK, COUNT is set to zero. */
void
prefix(system_clock_4)(GFC_INTEGER_4 *count, GFC_INTEGER_4 *count_rate,
GFC_INTEGER_4 *count_max)
{
#if defined(HAVE_SYS_TIME_H) && defined(HAVE_GETTIMEOFDAY)
static struct timeval tp0 = {-1, 0};
struct timeval tp1;
struct timezone tzp;
double t;
GFC_INTEGER_4 cnt;
if (gettimeofday(&tp1, &tzp) == 0)
{
if (tp0.tv_sec < 0)
{
tp0 = tp1;
cnt = 0;
}
else
{
t = (double) (tp1.tv_sec - tp0.tv_sec);
t += (double) (tp1.tv_usec - tp0.tv_usec) * 1.e-6;
t *= TCK;
if (t < (double) GFC_INTEGER_4_HUGE)
cnt = (GFC_INTEGER_4) t;
else
{
/* Time has wrapped. */
while (t > (double) GFC_INTEGER_4_HUGE)
t -= (double) GFC_INTEGER_4_HUGE;
cnt = (GFC_INTEGER_4) t;
tp0 = tp1;
}
}
if (count != NULL) *count = cnt;
if (count_rate != NULL) *count_rate = TCK;
if (count_max != NULL) *count_max = GFC_INTEGER_4_HUGE - 1;
}
else
{
if (count != NULL) *count = - GFC_INTEGER_4_HUGE;
if (count_rate != NULL) *count_rate = 0;
if (count_max != NULL) *count_max = 0;
}
#elif HAVE_TIME_H
static time_t t0 = (time_t) -2;
time_t t, t1;
GFC_INTEGER_4 cnt;
t1 = time(NULL);
if (t1 == (time_t) -1)
{
if (count != NULL) *count = - GFC_INTEGER_4_HUGE;
if (count_rate != NULL) *count_rate = 0;
if (count_max != NULL) *count_max = 0;
}
else if (t0 == (time_t) -2)
{
t0 = t1;
if (count != NULL) *count = 0;
if (count_rate != NULL) *count_rate = TCK;
if (count_max != NULL) *count_max = GFC_INTEGER_4_HUGE - 1;
}
else
{
t = t1 - t0;
if ((double) t < (double) GFC_INTEGER_4_HUGE)
cnt = (GFC_INTEGER_4) t;
else
{
/* Time has wrapped. */
while(t > (double) GFC_INTEGER_4_HUGE)
t -= (double) GFC_INTEGER_4_HUGE;
cnt = (GFC_INTEGER_4) t;
t0 = t1;
}
if (count != NULL) *count = cnt;
if (count_rate != NULL) *count_rate = TCK;
if (count_max != NULL) *count_max = GFC_INTEGER_4_HUGE - 1;
}
#else
if (count != NULL) *count = - GFC_INTEGER_4_HUGE;
if (count_rate != NULL) *count_rate = 0;
if (count_max != NULL) *count_max = 0;
#endif
}
/* prefix(system_clock_8) is the INTEGER(8) version of the SYSTEM_CLOCK
intrinsic subroutine. It returns the number of clock ticks for the current
system time, the number of ticks per second, and the maximum possible value
for COUNT. On the first call to SYSTEM_CLOCK, COUNT is set to zero. */
void
prefix(system_clock_8)(GFC_INTEGER_8 *count, GFC_INTEGER_8 *count_rate,
GFC_INTEGER_8 *count_max)
{
#if defined(HAVE_SYS_TIME_H) && defined(HAVE_GETTIMEOFDAY)
static struct timeval tp0 = {-1, 0};
struct timeval tp1;
struct timezone tzp;
double t;
GFC_INTEGER_8 cnt;
if (gettimeofday(&tp1, &tzp) == 0)
{
if (tp0.tv_sec < 0)
{
tp0 = tp1;
cnt = 0;
}
else
{
t = (double) (tp1.tv_sec - tp0.tv_sec);
t += (double) (tp1.tv_usec - tp0.tv_usec) * 1.e-6;
t *= TCK;
if (t < (double) GFC_INTEGER_8_HUGE)
cnt = (GFC_INTEGER_8) t;
else
{
/* Time has wrapped. */
while (t > (double) GFC_INTEGER_8_HUGE)
t -= (double) GFC_INTEGER_8_HUGE;
cnt = (GFC_INTEGER_8) t;
tp0 = tp1;
}
}
if (count != NULL) *count = cnt;
if (count_rate != NULL) *count_rate = TCK;
if (count_max != NULL) *count_max = GFC_INTEGER_8_HUGE - 1;
}
else
{
if (count != NULL) *count = - GFC_INTEGER_8_HUGE;
if (count_rate != NULL) *count_rate = 0;
if (count_max != NULL) *count_max = 0;
}
#elif HAVE_TIME_H
static time_t t0 = (time_t) -2;
time_t t, t1;
GFC_INTEGER_8 cnt;
t1 = time(NULL);
if (t1 == (time_t) -1)
{
if (count != NULL) *count = - GFC_INTEGER_8_HUGE;
if (count_rate != NULL) *count_rate = 0;
if (count_max != NULL) *count_max = 0;
}
else if (t0 == (time_t) -2)
{
t0 = t1;
if (count != NULL) *count = 0;
if (count_rate != NULL) *count_rate = TCK;
if (count_max != NULL) *count_max = GFC_INTEGER_8_HUGE - 1;
}
else
{
t = t1 - t0;
if ((double) t < (double) GFC_INTEGER_8_HUGE)
cnt = (GFC_INTEGER_8) t;
else
{
while(t > (double) GFC_INTEGER_8_HUGE)
t -= (double) GFC_INTEGER_8_HUGE;
cnt = (GFC_INTEGER_8) t;
t0 = t1;
}
if (count != NULL) *count = cnt;
if (count_rate != NULL) *count_rate = TCK;
if (count_max != NULL) *count_max = GFC_INTEGER_8_HUGE-1;
}
#else
if (count != NULL) *count = - GFC_INTEGER_8_HUGE;
if (count_rate != NULL) *count_rate = 0;
if (count_max != NULL) *count_max = 0;
#endif
}
/* Someone might do "call system_clock" where no arguments are given. This
guards against such an event. */
void prefix(system_clock_nop) (void)
{
}
More information about the Fortran
mailing list