ftp.nice.ch/pub/next/developer/languages/translator/schemetoc.s.tar.gz#/schemetoc/scrt/signal.c

This is signal.c in view mode; [Download] [Up]

/* SCHEME->C */

/*              Copyright 1989 Digital Equipment Corporation
 *                         All Rights Reserved
 *
 * Permission to use, copy, and modify this software and its documentation is
 * hereby granted only under the following terms and conditions.  Both the
 * above copyright notice and this permission notice must appear in all copies
 * of the software, derivative works or modified versions, and any portions
 * thereof, and both notices must appear in supporting documentation.
 *
 * Users of this software agree to the terms and conditions set forth herein,
 * and hereby grant back to Digital a non-exclusive, unrestricted, royalty-free
 * right and license under any changes, enhancements or extensions made to the
 * core functions of the software, including but not limited to those affording
 * compatibility with other hardware or software environments, but excluding
 * applications which incorporate this software.  Users further agree to use
 * their best efforts to return to Digital any such changes, enhancements or
 * extensions that they make and inform Digital of noteworthy uses of this
 * software.  Correspondence should be provided to Digital at:
 * 
 *                       Director of Licensing
 *                       Western Research Laboratory
 *                       Digital Equipment Corporation
 *                       100 Hamilton Avenue
 *                       Palo Alto, California  94301  
 * 
 * This software may be distributed (but not offered for sale or transferred
 * for compensation) to third parties, provided such third parties agree to
 * abide by the terms and conditions of this notice.  
 * 
 * THE SOFTWARE IS PROVIDED "AS IS" AND DIGITAL EQUIPMENT CORP. DISCLAIMS ALL
 * WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF
 * MERCHANTABILITY AND FITNESS.   IN NO EVENT SHALL DIGITAL EQUIPMENT
 * CORPORATION BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL
 * DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR
 * PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS
 * ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS
 * SOFTWARE.
*/

/* During critical sections in the Scheme system, signals may not be acted
   upon.  As one such critical section is in CONS, a cheap signal masking
   mechanism is required which is implemented in this module.
*/

#include "objects.h"
#include "heap.h"
#include "apply.h"
#include "signal.h"
#include "/usr/include/signal.h"
#ifdef apollo
#include <apollo/base.h>
#endif

extern TSCP  scrt4_onsignal2();

#ifdef MIPS
#include <mips/inst.h>
#include <mips/cpu.h>
#endif

int  sc_mutex;		/* Mutual exclusion flag */

int  sc_pendingsignals;	/* Pending signal flag */

/* The garbage collector blocks and reenables signals by calling the following
   routine.
*/

static int  gcinprogress = 0,	/* Boolean indicating GC in progress */
	    savemutex = 0,	/* Value of sc_mutex on entry to GC */
	    pendingsignals;	/* Bit mask of pending signals */

sc_gcinprogress( gc )
	int  gc;	/* boolean indicating the collection is in progress */
{
	if  (gc)  {
	   gcinprogress = 1;
	   savemutex = sc_mutex;
	   sc_pendingsignals = 0;
	}
	else  {
	   sc_mutex = 1;
	   gcinprogress = 0;
	   sc_pendingsignals = pendingsignals | (sc_freed != EMPTYLIST);
	   sc_mutex = savemutex;
	   if  (sc_mutex == 0  &&  sc_pendingsignals)  sc_sendpendingsignals();
	}
}
	   
/* Signals caught by Scheme->C functions enter this procedure.  As signals
   must sometimes be defered, the code and context are lost.  This should
   not cause a problem as the user program should not be catching any of the
   hardware traps.
*/

void  sc_onsignal1( signal, code, scp )
	int  signal,
	     code;
	struct sigcontext*  scp;
{
	int  i;
	struct  {			/* Save sc_unknowncall's state here */
	   TSCP  arg[MAXARGS];
	   TSCP  proc[4];
	   int	 count;
	} save;

	if  (sc_mutex == 0  &&  gcinprogress == 0)  {
	   /* Save sc_unknowncall's state */
	   for  (i = 0; i < 4; i++)  save.proc[ i ] = sc_unknownproc[ i ];
	   for  (i = 0; i < MAXARGS; i++)  save.arg[ i ] = sc_arg[ i ];
	   save.count = sc_unknownargc;
	   /* Call the Scheme->C signal handler */
	   scrt4_onsignal2( C_FIXED( signal ) );
	   /* Restore sc_unknowncall's state */
	   for  (i = 0; i < 4; i++)  sc_unknownproc[ i ] = save.proc[ i ];
	   for  (i = 0; i < MAXARGS; i++)  sc_arg[ i ] = save.arg[ i ];
	   sc_unknownargc = save.count;	
	}
	else  {
	   /* Signal must be defered */
#ifdef SYSV
	   sighold( signal );
#else
	   sigblock( 1<<signal );
#endif
	   pendingsignals = pendingsignals | (1<<signal);
	   if  (gcinprogress == 0)  sc_pendingsignals = 1;
	}
}

/* Signals that were defered during a critical section are sent by the
   following function at the end of the critical section.  Object cleanup
   actions are also invoked here the first time that a critical section is
   exited following garbage collection.
*/

sc_sendpendingsignals()
{
	int  oldmask, i, self;
	TSCP  freed, object_procedure;
	struct  {			/* Save sc_unknowncall's state here */
	   TSCP  arg[MAXARGS];
	   TSCP  proc[4];
	   int	 count;
	} save;

	/* Save sc_freed and sc_unknowncall's state */
	for  (i = 0; i < 4; i++)  save.proc[ i ] = sc_unknownproc[ i ];
	for  (i = 0; i < MAXARGS; i++)  save.arg[ i ] = sc_arg[ i ];
	save.count = sc_unknownargc;
	freed = sc_freed;
	sc_freed = EMPTYLIST;

	/* Send the pending signals and exit the critical section */
	sc_pendingsignals = 0;
	self = getpid();
#ifndef SYSV
	oldmask = sigblock( -1 ) & ~pendingsignals;
#endif
	for  (i = 0; i < 32; i++)
	  if  (pendingsignals & (1<<i)) {
#ifdef SYSV
	    sigrelse( i );
#endif
	    kill( self, i );
	  }

	pendingsignals = 0;
	sc_mutex = 0;
#ifndef SYSV
	sigsetmask( oldmask );
#endif
	/* Apply the when-unreferenced procedures */
	while  (freed != EMPTYLIST)  {
	   object_procedure = PAIR_CAR( freed );
	   sc_apply_2dtwo( PAIR_CDR( object_procedure ),
		          sc_cons( PAIR_CAR( object_procedure ), EMPTYLIST ) );
	   freed = PAIR_CDR( freed );
	}

	/* Restore sc_unknowncall's state */
	for  (i = 0; i < 4; i++)  sc_unknownproc[ i ] = save.proc[ i ];
	for  (i = 0; i < MAXARGS; i++)  sc_arg[ i ] = save.arg[ i ];
	sc_unknownargc = save.count;	
}

/* Arithmetic traps are handled by the following machine dependent code.
   Overflow on exact computation results in the correct, but inexact result
   being returned.  All other arithmetic traps are considered to be errors.
*/

extern void emulate_branch();

/* sc_trap_handler is a generalized fault handler for TRAP and FLOATING POINT
   exceptions.
*/

sc_trap_handler (sig,code,scp)
	int sig, code;
	struct sigcontext *scp;
{
#if (TITAN || (MATHTRAPS == 0))
	sc_error( "???? (in sc_trap_handler)", "Floating point exception", 0 );
#endif

#ifdef MIPS
	unsigned long opcode, func, rs, rt, rd;
	union mips_instruction branch_inst, exception_inst;
#endif

	/**********************************
   	     Unrecoverable exceptions
	 **********************************/
#ifdef MIPS
	if (sig == SIGTRAP)   {
		if (code == BRK_DIVZERO) 
			/***** divide by zero exception ****/
			sc_error ("?????", "Divide by zero", 0);
		else if (code == BRK_OVERFLOW)
			/** overflow check **/
			sc_error ("????", "Overflow",0);
		else if (code == BRK_RANGE)
			/** range error check **/
			sc_error ("????", "Out of range",0);
		else    /** other misc types of bpt errors */
			sc_error ("????", "Break point or branch error",0);
	}
#endif
#ifdef VAX
	if  (sig == SIGFPE)  {
	   if  (code == FPE_INTDIV_TRAP  ||  code == FPE_FLTDIV_FAULT  ||
		code == FPE_FLTDIV_TRAP)
		     /***** divide by zero exception *****/
		     sc_error ("?????", "Divide by zero", 0);
	   if  (code == FPE_FLTOVF_TRAP  ||  code == FPE_FLTOVF_FAULT)
		     /***** floating point overflow *****/
		     sc_error ("?????", "Overflow", 0);
	   if  (code == FPE_FLTUND_FAULT  ||  code == FPE_FLTUND_TRAP)
		     /***** floating point underflow *****/
		     sc_error ("?????", "Underflow", 0);
	   sc_error ("?????", "Floating point exception: %s", 1,
		     C_FIXED( code ));
	}
#endif	
#ifdef apollo
	if  (sig == SIGFPE)  {
	   if  (code == FPE_INTDIV_TRAP  ||  code == FPE_FLTDIV_FAULT  ||
		code == FPE_FLTDIV_TRAP)
		     /***** divide by zero exception *****/
		     sc_error ("?????", "Divide by zero", 0);
	   if  (code == FPE_FLTOVF_TRAP  ||  code == FPE_FLTOVF_FAULT)
		     /***** floating point overflow *****/
		     sc_error ("?????", "Overflow", 0);
	   if  (code == FPE_FLTUND_FAULT  ||  code == FPE_FLTUND_TRAP)
		     /***** floating point underflow *****/
		     sc_error ("?????", "Underflow", 0);
	   sc_error ("?????", "Floating point exception: ~s", 1,
		     C_FIXED( code ));
	}
	else if (sig == SIGAPOLLO) {
	    status_$t status;
	    char *subsys, *module, *error;
	    short lsubsys, lmodule, lerror;
	    char buffer[256];

	    status.all = code;
	    error_$find_text(status, &subsys, &lsubsys, &module, &lmodule,
			     &error, &lerror);
	    sprintf(buffer, "%.*s (%.*s/%.*s)", lerror, error,
		    lsubsys, subsys, lmodule, module);
	    sc_error("?????", buffer, 0);
	}
#endif	
	
	/***************************************
	  other possibly recoverable exceptions
	 ***************************************/
#ifdef MIPS
	if (scp->sc_cause & CAUSE_BD) {
		branch_inst.word = *(unsigned long *) scp->sc_pc ; 
		exception_inst.word = *(unsigned long *) (scp->sc_pc + 4); 
		/* printf ("it was a branch delay.\n"); */
	}
	else  { exception_inst.word = *(unsigned long *) (scp->sc_pc); 
	       /* printf ("it wasn't a branch delay.\n");  */ 
	}

	opcode = exception_inst.j_format.opcode;  /* get opcode field */

	switch (opcode)  {
	      case spec_op:
		func = exception_inst.r_format.func;  /* get function field */
		switch (func)   {
		      case add_op:  
			if (sig == SIGFPE && code == EXC_OV)  {
				/**** integer add overflow ***/
				rs = exception_inst.r_format.rs;
				rt = exception_inst.r_format.rt;
				rd = exception_inst.r_format.rd;

				scp->sc_regs[rd] = 
				(unsigned int) 
				FLTV_FLT( (double) FIXED_C(scp->sc_regs[rs]) + 
					  (double) FIXED_C(scp->sc_regs[rt])
					 );
	
				if (scp->sc_cause & CAUSE_BD) 
					emulate_branch(scp, branch_inst);
				else 
					scp->sc_pc += 4;
			}
			else sc_error ("+", 
			       "unknown floating point exception code", 0);

			break;

		      case sub_op:
			if (sig == SIGFPE && code == EXC_OV)  {
				/**** integer sub overflow ****/
				rs = exception_inst.r_format.rs;
				rt = exception_inst.r_format.rt;
				rd = exception_inst.r_format.rd;

				scp->sc_regs[rd] = 
				(unsigned int)
				FLTV_FLT( (double) FIXED_C(scp->sc_regs[rs]) -
					  (double) FIXED_C(scp->sc_regs[rt])
					 );

				if (scp->sc_cause & CAUSE_BD) 
					emulate_branch(scp, branch_inst);
				else 
					scp->sc_pc += 4;
			}
			else sc_error ("-", 
			       "Unknown floating point exception code", 0);

			break;			
			
		      default:
			sc_error ("UNKNOWN",
			"Other instructions of type special not decoded",0);
			break;
		}   /* close switch (func) */
		break;

	      case bcond_op:
		sc_error ("sc_trap_handler", "BCOND op decoded", 0);
		break;
	      case j_op:
	        sc_error ("sc_trap_handler", "J op decoded", 0);
		break;
	      case jal_op:
		sc_error ("sc_trap_handler", "JAL op decoded",0);
		break;
	      default:
		sc_error ("sc_trap_handler", "Other opcodes not decoded", 0);
		break;
	}
#endif

}

#ifdef MIPS

/* emulate_branch modifies the value of the program counter in the 
   signal context structure (sc_pc) to the target of the branch instruction.  
*/

void emulate_branch(scp, branch_inst)
	struct sigcontext *scp;
	union mips_instruction branch_inst;
  {
	  unsigned long target = branch_inst.j_format.target,
	                opcode = branch_inst.j_format.opcode,
	                pc = *(unsigned long *) scp->sc_pc,
	                func, rs;
	  
	  /***********************************************
	      note: the current implementation only 
	      takes care of jr and j branch instructions.
	      Other cases can be added as need arises.
	   ***********************************************/

	  switch (opcode)  {
		case spec_op:
		  func = branch_inst.r_format.func;   /* get function field */
		  rs = branch_inst.r_format.rs;   /* reg with branch addr */
		 
		  switch (func)  {
			case jr_op:  
			  /**** branch instruction is jump register ****/
			     /* set program counter to be target of *
			      * branch instruction.                 *
			      *                                     */
			  scp->sc_pc = scp->sc_regs[rs]; 
			  break;
			case jalr_op:  
			  sc_error ("emulate_branch", 
				    "Branch instruction is JALR", 0);
			  break;
			default:
			  sc_error ("emulate_branch", 
				    "Special inst not decoded", 0);
			  break;
		  }
		  break;
		  
		case j_op:  
		  /**** jump instruction ****/
		    /* new pc is calculated by left shifting target field 
		       2 bits and combining result with high 4 bits of 
		       current pc
		     */
		  target = target<<2;
		  scp->sc_pc = (unsigned long) ((pc & 036000000000) | target);
		  break;
		case jal_op:
		  sc_error ("emulate_branch",
			    "Branch instruction is jal", 0);
		  break;
		default:
		  sc_error ("emulate_branch",
			    "Instruction not decoded", 0);
		  break;
	  }
  }	  
#endif

/* The following function is called during initialization to enable the
   arithmetic trap handlers.
*/

sc_mathtraps()  {
	signal(SIGFPE, sc_trap_handler);
#ifdef MIPS
	signal(SIGTRAP, sc_trap_handler);
#endif
}

These are the contents of the former NiCE NeXT User Group NeXTSTEP/OpenStep software archive, currently hosted by Netfuture.ch.