/*

  Copyright (C) 2000, 2001, Silicon Graphics, Inc.  All Rights Reserved.

   Path64 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 version 2.1

   Path64 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 Path64; see the file COPYING.  If not, write to the Free
   Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
   02110-1301, USA.

   Special thanks goes to SGI for their continued support to open source

*/



#pragma ident "@(#) libf/fio/finit.c	92.4	11/16/99 15:43:33"

/*
 *	This module contains Fortran initialization routines.   There
 *	are three times Fortran initialization routines are called:
 *
 *	1) Called at first I/O
 *		_initialize_e_fortran_io()
 *		_initialize_i_fortran_io()
 *	2) Called from $START().
 *		_finit() on PVP and MPP systems
 *		_F90_INIT() on Sparc systems
 *		_initialize_e_fortran_io() on all systems
 *	3) Called from Fortran main program prologue code.
 *		f$init() on PVP and MPP systems
 *
 *	Note that _initialize_e_fortran_io() is called in startup/prologue
 *	code and at first I/O.   This is because on Sparc systems we might
 *	have a C main program which calls Fortran subroutines and the
 *	startup/prologue initializations would be bypassed.
 */

#ifdef	_UNICOS
#include <infoblk.h>
#include <sys/category.h>
#endif
#if	defined(_LITTLE_ENDIAN)
#include <stdlib.h>
#include <cray/portdefs.h>
#else		/* little endian */
#include <signal.h>
#include <stdio.h>
#include <stdlib.h>
#include <string.h>
#include <unistd.h>
#include <sys/stat.h>
#include <cray/mtlock.h>
#if	defined(_CRAYMPP) && defined(SA_SIGINFO)
#define GOT_SIGINFO
#include <siginfo.h>
#endif
#include "fio.h"
#endif		/* little endian */

#ifdef	_UNICOS
#pragma _CRI soft _lwrite_setup
#elif	!defined(_LITTLE_ENDIAN)
#pragma weak _lwrite_setup
#endif
extern	void	_lwrite_setup(void);	/* List-directed write setup routine */

#ifdef	_UNICOS
#pragma _CRI soft _wf_setup
#elif	!defined(_LITTLE_ENDIAN)
#pragma weak _wf_setup
#endif
extern	void	_wf_setup(void);	/* Formatted write setup routine */
extern	void	_fcleanup(void);	/* I/O cleanup routine */
#ifdef	__mips
extern	void	_fortclean(void);		/* flush stdio under lock */
#endif

/* Forward and external references */

#ifdef	GOT_SIGINFO
static void _f_sig(int, siginfo_t *, void *);
#else
static void _f_sig(int);
#endif
extern	void	_aborthandle(void);	/* Cleanup routine */
#ifdef	_CRAYMPP
/* _f_stopsig is referenced in libc/gen/exit.c */
void _f_stopsig(int);
extern void _abortcatch(int);
#endif

#ifdef	_CRAY1
#pragma	_CRI soft $WBUFLN, $RBUFLN
extern	int	$WBUFLN, $RBUFLN;
_f_int	$RFDCOM[1];
_f_int	$WFDCOM[1];
#endif	/* _CRAY1 */

#ifndef	_ABSOFT
extern	char	*sys_siglist[];		/* Array of signal messages */
#endif

extern	int	__fdctrace_enable;	/* FDC trace flag */

short	_fortran_io_is_init;	/* set to 1 by _initialize_fortran_io() */
short	_e_fortran_io_is_init;	/* set to 1 by _initialize_e_fortran_io() */
short	_i_fortran_io_is_init;	/* set to 1 by _initialize_i_fortran_io() */
short	_f_abort;		/* set to 1 by _f_sig() signal handler */

#ifdef	_CRAYMPP
/* These variables and defines are used for handling stopall */
volatile int _infio;
volatile int _needtostop;
extern int G@INTIO;
#endif

/*
 *	_initialize_fortran_io
 *
 *		Called the first time any external or internal Fortran unit is 
 *		connected or used.
 */
void
_initialize_fortran_io(void)
{
	_fortran_io_is_init	= 1;

	/* Set up the precision used for list-directed floating point output */

	if (LOADED(_lwrite_setup))
		_lwrite_setup();	

	/* Set up formatted write behavior */

	if (LOADED(_wf_setup))
		_wf_setup();	

#ifdef  _CRAY1
	/*
	 * $RBUFLN and $WBUFLN were external symbols controlling the
	 * length of the read and write formatted line buffers,
	 * respectively.  The user could increase the maximum allowable
	 * formatted record size by increasing the value of these
	 * symbols at load time with segldr.  Now, we simulate that
	 * behavior by increasing _f_rcsz if these symbols are defined
	 * and larger than _f_rcsz.  For historic reasons, this is done
	 * only on the CX/CEA.
	 *
	 * The $RFDCOM and $WFDCOM common blocks used to contain the
	 * line buffer.  We keep an existing 1-word block so that users
	 * can change it and still get a similar caution message.
	 *
	 * This crud can be deprecated someday since we now allow RECL
	 * on sequential files, which can accomplish the same thing.
	 */

	if (LOADED_DATA(&$RBUFLN))
		if (_VALUE($RBUFLN) > _f_rcsz)
			_f_rcsz	= _VALUE($RBUFLN);

	if (LOADED_DATA(&$WBUFLN))
		if (_VALUE($WBUFLN) > _f_rcsz)
			_f_rcsz	= _VALUE($WBUFLN);
#endif	/* _CRAY1 */

	return;
}

/*
 *	_initialize_e_fortran_io
 *
 *	Called the first time any external Fortran unit is connected.
 *
 *	Assumes that _openlock is locked to prevent multiple concurrent calls.
 */
void
_initialize_e_fortran_io(void)
{
	_e_fortran_io_is_init	= 1;

	if (! _fortran_io_is_init)
		_initialize_fortran_io();

	/* Register for cleanup routine at exit and abort time */

	(void) atexit(_fcleanup);
#ifdef	__mips
	(void) __ateachexit(_fortclean);
#endif
#ifdef	_UNICOS
	(void) atabort(_fcleanup);
#endif	/* _UNICOS */

	/* Conditionally set FFIO tracing */

#ifdef	DEBUG
	if (__fdctrace_enable < 0) {
		char	*estr;

		estr	= getenv("FDCTRACE");

		__fdctrace_enable	= (estr == NULL) ? 0 : atol(estr);
	}
#endif	/* DEBUG */

	return;
}

/*
 *	_initialize_i_fortran_io
 *
 *	Called the first time any internal Fortran unit is accessed.
 */
void
_initialize_i_fortran_io(void)
{
	_i_fortran_io_is_init	= 1;

	if (! _fortran_io_is_init)
		_initialize_fortran_io();

	return;
}

#ifdef	_UNICOS

/*
 *	_finit 
 *
 *	Fortran library initialization routine; called by $START().
 */
void
_finit(void)
{
/*
 *	Call _initialize_e_fortran_io here to ensure that atexit(_fcleanup)
 *	is called before any user atexit() call is made.  
 */
	_initialize_e_fortran_io();	
	return;
}

/*
 *	f$init
 *
 *	Called by the prologue in PVP and MPP Fortran main programs.
 *	It is here that we do the funny signal catching which ensures that 
 *	a traceback is printed when some specific signals are received.
 */
void
f$init(void)
{
	register short	catchem;
	char		*trace;

	catchem	= 1;

	/*
	 * If "TRACEBK" == 0 or "TRACEBK2" != 0 then don't do traceback.
	 */

	if (((trace = getenv("TRACEBK")) && atol(trace) == 0) ||
	    ((trace = getenv("TRACEBK2")) && atol(trace) != 0))
		catchem	= 0;
#ifdef	_CRAYMPP
	/*
	 * Always register for SIGBUFIO; this is used by STOP and
	 * globalexit() to get all PEs to clean up and exit.
	 */
	if (_num_pes() > 1) {
		struct sigaction act, oact;

		act.sa_handler	= _f_stopsig;
		act.sa_mask	= 0;
		act.sa_flags	= SA_RESETHAND | SA_CLEARPEND ;

		(void) sigaction(SIGBUFIO, &act, &oact);

		if (oact.sa_handler != SIG_DFL &&
		    oact.sa_handler != _f_stopsig)
			(void) sigaction(SIGBUFIO, &oact, 0);
	}
#endif
        if (catchem) {
#ifndef	SIGSMCE
#define SIGSMCE 38
#endif
#ifndef SIGAPTEAM
#define SIGAPTEAM 39
#endif
		unsigned long		mask;
		struct sigaction	act, oact;
		register int		sig;

                mask		= (SIG_DMPDFL | sigmask(SIGHUP) |
				  sigmask(SIGINT) | sigmask(SIGTERM) |
				  sigmask(SIGCPULIM) | sigmask(SIGPIPE) |
				  sigmask(SIGSMCE)) | sigmask(SIGAPTEAM)
				  & ~SIG_CANTMASK;
#ifdef	GOT_SIGINFO
                act.sa_sigaction	= _f_sig;
#else
                act.sa_handler	= _f_sig;
#endif
                act.sa_mask	= 0;
                act.sa_flags	= SA_RESETHAND | SA_NODEFER | SA_CLEARPEND;
#ifdef	GOT_SIGINFO
                act.sa_flags	|= SA_SIGINFO;
#endif

                for (sig = 1; mask != 0; sig++, mask >>= 1)
                        if (mask & 01) {
                                (void) sigaction(sig, &act, &oact);
#ifdef	_CRAYMPP
                                if (oact.sa_handler != SIG_DFL &&
				    oact.sa_handler != _abortcatch)
#else
                                if (oact.sa_handler != SIG_DFL)
#endif
                                        (void) sigaction(sig, &oact, 0);
                        }
        }

#ifdef	_CRAYMPP
	_barrier();		/* let all PEs catch up */
#endif

	return;
} 

#endif	/* _UNICOS */

/*
 *	_f_sig() is the Fortran run-time signal handler.
 */

#if	defined(_UNICOS) && !(defined(GOT_SIGINFO) || defined(_CRAYMPP))

static	short	_f_gotsig	= 0;		/* In _f_sig() flag word */
static	long	_f_siglock	= 0;		/* Lock word for _f_sig() */

static void
_f_sig(int sig)
{
	sigset_t	set;

	(void) sigoff();		/* Turn signals off */

	_semclr(2);			/* Clear TSKLK for lock calls */

	MEM_LOCK(&_f_siglock);		/* Protect global data update */

	if (_f_gotsig == 0) {		/* If no one has been here yet */

		_f_gotsig	= 1;	/* Close the door */
		_f_abort	= 1;	/* Indicate abnormal abort */

		MEM_UNLOCK(&_f_siglock);

		(void) sigon();
		(void) fflush(stdout);
		(void) fflush(stderr);	/* Just in case */

		if (sig > 0 && sig < NSIG) {
			(void) write(fileno(stderr), sys_siglist[sig],
					strlen(sys_siglist[sig]));
			(void) write(fileno(stderr), "\n", 1);
		}

		(void) sigtrbk(stderr);

		_aborthandle();		/* Do cleanup routines */

	}
	else {				/* Someone is already in */

		MEM_UNLOCK(&_f_siglock);

		(void) sigon();
	}

	set	= sigmask(sig);			/* Block signal */

	(void) sigprocmask(SIG_BLOCK, &set, NULL);
	(void) killm(C_PROC, 0, sig);		/* Resend signal */

	return;
}

#elif	defined(_CRAYMPP)

static DECL_LOCK(_f_siglock)		/* MPP: Lock word for _f_sig() */

void
_f_stopsig(int sig)
{
	/* Set G@INTIO so we do not retry any call that failed with EINTR */

	G@INTIO = 1;

	if (_infio) {
		/* We are in some i/o statement */
		/* Wait till we are finished to call _fcleanup */
		/* The STMT_BEGIN macro sets _infio and STMT_END */
		/* clears it. STMT_END checks to see if _needtostop */
		/* is set - if so, it calls this routine */
		struct sigaction act, oact;

		_needtostop	= 1;
		act.sa_handler	= _f_stopsig;
		act.sa_mask	= 0;
		act.sa_flags	= SA_RESETHAND | SA_CLEARPEND ;

		(void) sigaction(SIGBUFIO, &act, &oact);
		return;
	}

	_fcleanup();			/* all PEs cleanup and exit */

	exit(0);
}

#ifdef	GOT_SIGINFO
static void
_f_sig(int sig, siginfo_t *sip, void *ctx)
#else
static void
_f_sig(int sig)
#endif
{
	sigset_t	set;
	register long	locked;
	register long	start;
	register long	wait;
	char		buf[50];

	(void) sigoff();

	locked		= _shmem_test_lock(&_f_siglock);
	_f_abort	= 1;	/* Indicate abnormal abort */

	if (!locked) {
		/*
		 * The first PE in _f_sig prints out the signal,
		 * does a traceback, and runs cleanup routines
		 */
		(void) sigon();
		(void) fflush(stdout);
		(void) fflush(stderr);
#ifdef	GOT_SIGINFO
		psiginfo(sip, "SIGNAL");
#else
		if (sig > 0 && sig < NSIG) {
			(void) strncpy(buf, sys_siglist[sig], sizeof(buf) - 1);
			(void) strcat(buf, "\n");
			(void) write(fileno(stderr), buf, strlen(buf));
		}
#endif
		(void) sigtrbk(stderr);
		_aborthandle();
	} else {
		/*
		 * subsequent PEs in _f_sig call cleanup routines,
		 * synchronize on a barrier (UNICOS-MAX only),
		 * then call _localexit().
		 */
		(void) sigon();
		_aborthandle();
#ifdef	_UNICOS_MAX
		_barrier();
#endif
		_localexit(EXIT_FAILURE);
	}
	/*
	 * Under UNICOS-MAX, the first PE in _f_sig() blocks the
	 * signal, then re-sends the signal, waits for awhile
	 * to see if the other PEs have cleaned up, then returns
	 * from the signal handler to kill the application
	 *
	 * Under UNICOS/mk, we block the signal and re-send it,
	 * then exit the signal handler.  The kernel will restore
	 * the registers to the point-of-interrupt and restore
	 * the old signal mask (which has the signal unmasked).
	 * The calling PE will die with the signal; this will
	 * cause a SIGAPTEAM to be sent to all other PEs, which
	 * will bring them into this routine to clean up and exit.
	 */
	set	= sigmask(sig);

	(void) sigprocmask(SIG_BLOCK, &set, NULL);
	(void) killm(C_PROC, 0, sig);

#ifdef	_UNICOS_MAX
	_set_barrier();
	start	= _rtc();
	wait	= start + CLK_TCK;

	while (_rtc() >= start && _rtc() < wait) {
		if (_test_barrier())
			break;
	}
#endif

	return;
}
#endif	/* _CRAYMPP */

#ifdef	_SOLARIS
/*
 *      _F90_INIT():
 *
 *	The Fortran 90 library initialization routine for Sparc.
 *	It is called by the CRI startup code on Sparc for f90 programs.
 */

void
_F90_INIT()
{

/*
 *	We call _initialize_e_fortran_io here to ensure that atexit(_fcleanup)
 *	is called before any user atexit() call is made.  
 */
	_initialize_e_fortran_io();	

	return;
}

#endif	/* _SOLARIS */
