home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Frozen Fish 1: Amiga
/
FrozenFish-Apr94.iso
/
bbs
/
alib
/
d5xx
/
d556
/
scheme2c.lha
/
Scheme2C
/
Scheme-src.lzh
/
scrt
/
signal.c
< prev
next >
Wrap
C/C++ Source or Header
|
1991-10-11
|
15KB
|
523 lines
/* 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"
#ifndef AMIGA
#include "/usr/include/signal.h"
#else
#include "include:signal.h"
#include <exec/types.h>
#include <exec/tasks.h>
#include <libraries/dos.h>
#include <proto/exec.h>
#endif
#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 */
#ifndef AMIGA
#ifdef SYSV
sighold( signal );
#else
sigblock( 1<<signal );
#endif /* SYSV */
#endif /* AMIGA */
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
#ifndef AMIGA
oldmask = sigblock( -1 ) & ~pendingsignals;
#endif /* AMIGA */
#endif /* SYSV */
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
#ifndef AMIGA
sigsetmask( oldmask );
#endif /* AMIGA */
#endif /* SYSV */
/* 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
}
#ifdef AMIGA
/*
* We need to provide versions of some of the signal-handling functions
* used here.
*/
/*
* Find out who to send signals *to*. Could be done as a define, but the
* compiler needs it also.
*/
int
getpid() {
return (int) FindTask(NULL);
}
/* Send the signals (or fake it) that we know how to deal with */
int
kill(int pid, int signal) {
extern int _FPERR ;
extern void __stdargs CXFERR() ;
switch (signal) {
case SIGFPE:
CXFERR(_FPERR) ; /* Just runs the handler */
break ;
case SIGINT:
Signal(pid, SIGBREAKF_CTRL_C) ;
break ;
default: /* Don't know, so send a break again */
Signal(pid, SIGBREAKF_CTRL_D) ;
break ;
}
}
/* Provide Scheme with access to math errors */
#include <math.h>
int matherr(struct exception *x) {
switch (x->type) {
case DOMAIN:
sc_error("????? (Math Error)", "Domain", 0) ;
break ;
case SING:
sc_error("????? (Math Error)", "Singularity", 0) ;
break ;
case OVERFLOW:
sc_error("????? (Math Error)", "Overflow", 0) ;
break ;
case UNDERFLOW:
sc_error("????? (Math Error)", "Underflow", 0) ;
break ;
case TLOSS: /* Totla/Partial loss of precision */
case PLOSS:
sc_error("???? (Math Error)", "Loss of precision", 0) ;
/* Just return "use this value" for now */
break ;
}
return (0) ;
}
#endif