gcc/libgfortran/runtime/backtrace.c
Thomas Koenig c7d0f4d5fa re PR libfortran/32972 (performance of pack/unpack)
2008-04-13  Thomas Koenig  <tkoenig@gcc.gnu.org>
	Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>

	PR libfortran/32972
	PR libfortran/32512
	configure.ac:  Add test for uintptr_t.
	configure:  Regenerated.
	config.h.in:  Regenerated.
	* libgfortran.h: GFC_DTYPE_DERIVED_1:  New macro.
	GFC_DTYPE_DERIVED_2:  New macro.
	GFC_DTYPE_DERIVED_4:  New macro.
	GFC_DTYPE_DERIVED_8:  New macro.
	GFC_DTYPE_DERIVED_16:  New macro.
	GFC_UNALIGNED_2:  New macro.
	GFC_UNALIGNED_4:  New macro.
	GFC_UNALIGNED_8:  New macro.
	GFC_UNALIGNED_16:  New macro.
	intptr_t:  Define if we don't have it.
	uintptr_t:  Likewise.
	* runtime/backtrace.c (show_backtrace):  Use intptr_t.
	* intrinsics/signal.c (signal_sub):  Likewise.
	(signal_sub_int):  Likewise.
	(alarm_sub_int_i4):  Likewise.
	* intrinsics/spread_generic.c (spread):  Use the integer
	routines for handling derived types of sizes 1, 2, 4, 8 and 16
	if the alignment of all pointers is correct.
	(spread_scalar):  Likewise.
	* intrinsics/pack_generic.c (pack):  Likewise.
	Use GFD_DTYPE_TYPE_SIZE to avoid nested switch statements.
	* intrinsics/unpack_generic.c (unpack1):  Likewise.
	(unpack0):  Likewise.
	* runtime/in_pack_generic.c (internal_pack):  Likewise.
	* runtime/in_unpack_generic.c (internal_unpack):  Likewise.

2008-04-13  Thomas Koenig  <tkoenig@gcc.gnu.org>

	PR libfortran/32972
	PR libfortran/32512
	* gfortran.dg/internal_pack_1.f90:  Add test for derived type.
	* gfortran.dg/intrinsic_spread_1.f90:  Likewise.
	* gfortran.dg/intrinsic_pack_1.f90:  Likewise.
	* gfortran.dg/intrinsic_unpack_1.f90:  Likewise.


Co-Authored-By: Francois-Xavier Coudert <fxcoudert@gcc.gnu.org>

From-SVN: r134245
2008-04-13 20:15:58 +00:00

332 lines
7.5 KiB
C

/* Copyright (C) 2006, 2007 Free Software Foundation, Inc.
Contributed by François-Xavier Coudert
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 General Public License as published by
the Free Software Foundation; either version 2, or (at your option)
any later version.
In addition to the permissions in the GNU General Public License, the
Free Software Foundation gives you unlimited permission to link the
compiled version of this file into combinations with other programs,
and to distribute those combinations without any restriction coming
from the use of this file. (The General Public License restrictions
do apply in other respects; for example, they cover modification of
the file, and distribution when not linked into a combine
executable.)
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 General Public License for more details.
You should have received a copy of the GNU General Public License
along with libgfortran; see the file COPYING. If not, write to
the Free Software Foundation, 51 Franklin Street, Fifth Floor,
Boston, MA 02110-1301, USA. */
#include "libgfortran.h"
#include <string.h>
#ifdef HAVE_STDLIB_H
#include <stdlib.h>
#endif
#ifdef HAVE_INTTYPES_H
#include <inttypes.h>
#endif
#ifdef HAVE_UNISTD_H
#include <unistd.h>
#endif
#ifdef HAVE_EXECINFO_H
#include <execinfo.h>
#endif
#ifdef HAVE_SYS_WAIT_H
#include <sys/wait.h>
#endif
#include <ctype.h>
/* Macros for common sets of capabilities: can we fork and exec, can
we use glibc-style backtrace functions, and can we use pipes. */
#define CAN_FORK (defined(HAVE_FORK) && defined(HAVE_EXECVP) \
&& defined(HAVE_WAIT))
#define GLIBC_BACKTRACE (defined(HAVE_BACKTRACE) \
&& defined(HAVE_BACKTRACE_SYMBOLS))
#define CAN_PIPE (CAN_FORK && defined(HAVE_PIPE) \
&& defined(HAVE_DUP2) && defined(HAVE_FDOPEN) \
&& defined(HAVE_CLOSE))
#if GLIBC_BACKTRACE && CAN_PIPE
static char *
local_strcasestr (const char *s1, const char *s2)
{
#ifdef HAVE_STRCASESTR
return strcasestr (s1, s2);
#else
const char *p = s1;
const size_t len = strlen (s2);
const char u = *s2, v = isupper((int) *s2) ? tolower((int) *s2)
: (islower((int) *s2) ? toupper((int) *s2)
: *s2);
while (1)
{
while (*p != u && *p != v && *p)
p++;
if (*p == 0)
return NULL;
if (strncasecmp (p, s2, len) == 0)
return (char *)p;
}
#endif
}
#endif
#if GLIBC_BACKTRACE
static void
dump_glibc_backtrace (int depth, char *str[])
{
int i;
for (i = 0; i < depth; i++)
st_printf (" + %s\n", str[i]);
free (str);
}
#endif
/* show_backtrace displays the backtrace, currently obtained by means of
the glibc backtrace* functions. */
void
show_backtrace (void)
{
#if GLIBC_BACKTRACE
#define DEPTH 50
#define BUFSIZE 1024
void *trace[DEPTH];
char **str;
int depth;
depth = backtrace (trace, DEPTH);
if (depth <= 0)
return;
str = backtrace_symbols (trace, depth);
#if CAN_PIPE
#ifndef STDIN_FILENO
#define STDIN_FILENO 0
#endif
#ifndef STDOUT_FILENO
#define STDOUT_FILENO 1
#endif
#ifndef STDERR_FILENO
#define STDERR_FILENO 2
#endif
/* We attempt to extract file and line information from addr2line. */
do
{
/* Local variables. */
int f[2], pid, line, i;
FILE *output;
char addr_buf[DEPTH][GFC_XTOA_BUF_SIZE], func[BUFSIZE], file[BUFSIZE];
char *p, *end;
const char *addr[DEPTH];
/* Write the list of addresses in hexadecimal format. */
for (i = 0; i < depth; i++)
addr[i] = xtoa ((GFC_UINTEGER_LARGEST) (intptr_t) trace[i], addr_buf[i],
sizeof (addr_buf[i]));
/* Don't output an error message if something goes wrong, we'll simply
fall back to the pstack and glibc backtraces. */
if (pipe (f) != 0)
break;
if ((pid = fork ()) == -1)
break;
if (pid == 0)
{
/* Child process. */
#define NUM_FIXEDARGS 5
char *arg[DEPTH+NUM_FIXEDARGS+1];
close (f[0]);
close (STDIN_FILENO);
close (STDERR_FILENO);
if (dup2 (f[1], STDOUT_FILENO) == -1)
_exit (0);
close (f[1]);
arg[0] = (char *) "addr2line";
arg[1] = (char *) "-e";
arg[2] = full_exe_path ();
arg[3] = (char *) "-f";
arg[4] = (char *) "-s";
for (i = 0; i < depth; i++)
arg[NUM_FIXEDARGS+i] = (char *) addr[i];
arg[NUM_FIXEDARGS+depth] = NULL;
execvp (arg[0], arg);
_exit (0);
#undef NUM_FIXEDARGS
}
/* Father process. */
close (f[1]);
wait (NULL);
output = fdopen (f[0], "r");
i = -1;
if (fgets (func, sizeof(func), output))
{
st_printf ("\nBacktrace for this error:\n");
do
{
if (! fgets (file, sizeof(file), output))
goto fallback;
i++;
for (p = func; *p != '\n' && *p != '\r'; p++)
;
*p = '\0';
/* Try to recognize the internal libgfortran functions. */
if (strncasecmp (func, "*_gfortran", 10) == 0
|| strncasecmp (func, "_gfortran", 9) == 0
|| strcmp (func, "main") == 0 || strcmp (func, "_start") == 0
|| strcmp (func, "_gfortrani_handler") == 0)
continue;
if (local_strcasestr (str[i], "libgfortran.so") != NULL
|| local_strcasestr (str[i], "libgfortran.dylib") != NULL
|| local_strcasestr (str[i], "libgfortran.a") != NULL)
continue;
/* If we only have the address, use the glibc backtrace. */
if (func[0] == '?' && func[1] == '?' && file[0] == '?'
&& file[1] == '?')
{
st_printf (" + %s\n", str[i]);
continue;
}
/* Extract the line number. */
for (end = NULL, p = file; *p; p++)
if (*p == ':')
end = p;
if (end != NULL)
{
*end = '\0';
line = atoi (++end);
}
else
line = -1;
if (strcmp (func, "MAIN__") == 0)
st_printf (" + in the main program\n");
else
st_printf (" + function %s (0x%s)\n", func, addr[i]);
if (line <= 0 && strcmp (file, "??") == 0)
continue;
if (line <= 0)
st_printf (" from file %s\n", file);
else
st_printf (" at line %d of file %s\n", line, file);
}
while (fgets (func, sizeof(func), output));
free (str);
return;
fallback:
st_printf ("** Something went wrong while running addr2line. **\n"
"** Falling back to a simpler backtrace scheme. **\n");
}
}
while (0);
#undef DEPTH
#undef BUFSIZE
#endif
#endif
#if CAN_FORK && defined(HAVE_GETPPID)
/* Try to call pstack. */
do
{
/* Local variables. */
int pid;
/* Don't output an error message if something goes wrong, we'll simply
fall back to the pstack and glibc backtraces. */
if ((pid = fork ()) == -1)
break;
if (pid == 0)
{
/* Child process. */
#define NUM_ARGS 2
char *arg[NUM_ARGS+1];
char buf[20];
st_printf ("\nBacktrace for this error:\n");
arg[0] = (char *) "pstack";
#ifdef HAVE_SNPRINTF
snprintf (buf, sizeof(buf), "%d", (int) getppid ());
#else
sprintf (buf, "%d", (int) getppid ());
#endif
arg[1] = buf;
arg[2] = NULL;
execvp (arg[0], arg);
#undef NUM_ARGS
/* pstack didn't work, so we fall back to dumping the glibc
backtrace if we can. */
#if GLIBC_BACKTRACE
dump_glibc_backtrace (depth, str);
#else
st_printf (" unable to produce a backtrace, sorry!\n");
#endif
_exit (0);
}
/* Father process. */
wait (NULL);
return;
}
while(0);
#endif
#if GLIBC_BACKTRACE
/* Fallback to the glibc backtrace. */
st_printf ("\nBacktrace for this error:\n");
dump_glibc_backtrace (depth, str);
#endif
}