home *** CD-ROM | disk | FTP | other *** search
/ The Fred Fish Collection 1.5 / ffcollection-1-5-1992-11.iso / ff_progs / prog_c / schem2c1.lzh / Scheme2C / Scheme-src.lzh / scrt / signal.c < prev    next >
Encoding:
C/C++ Source or Header  |  1991-10-11  |  14.8 KB  |  523 lines
  1. /* SCHEME->C */
  2.  
  3. /*              Copyright 1989 Digital Equipment Corporation
  4.  *                         All Rights Reserved
  5.  *
  6.  * Permission to use, copy, and modify this software and its documentation is
  7.  * hereby granted only under the following terms and conditions.  Both the
  8.  * above copyright notice and this permission notice must appear in all copies
  9.  * of the software, derivative works or modified versions, and any portions
  10.  * thereof, and both notices must appear in supporting documentation.
  11.  *
  12.  * Users of this software agree to the terms and conditions set forth herein,
  13.  * and hereby grant back to Digital a non-exclusive, unrestricted, royalty-free
  14.  * right and license under any changes, enhancements or extensions made to the
  15.  * core functions of the software, including but not limited to those affording
  16.  * compatibility with other hardware or software environments, but excluding
  17.  * applications which incorporate this software.  Users further agree to use
  18.  * their best efforts to return to Digital any such changes, enhancements or
  19.  * extensions that they make and inform Digital of noteworthy uses of this
  20.  * software.  Correspondence should be provided to Digital at:
  21.  * 
  22.  *                       Director of Licensing
  23.  *                       Western Research Laboratory
  24.  *                       Digital Equipment Corporation
  25.  *                       100 Hamilton Avenue
  26.  *                       Palo Alto, California  94301  
  27.  * 
  28.  * This software may be distributed (but not offered for sale or transferred
  29.  * for compensation) to third parties, provided such third parties agree to
  30.  * abide by the terms and conditions of this notice.  
  31.  * 
  32.  * THE SOFTWARE IS PROVIDED "AS IS" AND DIGITAL EQUIPMENT CORP. DISCLAIMS ALL
  33.  * WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF
  34.  * MERCHANTABILITY AND FITNESS.   IN NO EVENT SHALL DIGITAL EQUIPMENT
  35.  * CORPORATION BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL
  36.  * DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR
  37.  * PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS
  38.  * ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS
  39.  * SOFTWARE.
  40. */
  41.  
  42. /* During critical sections in the Scheme system, signals may not be acted
  43.    upon.  As one such critical section is in CONS, a cheap signal masking
  44.    mechanism is required which is implemented in this module.
  45. */
  46.  
  47. #include "objects.h"
  48. #include "heap.h"
  49. #include "apply.h"
  50. #include "signal.h"
  51. #ifndef    AMIGA
  52. #include "/usr/include/signal.h"
  53. #else
  54. #include "include:signal.h"
  55. #include <exec/types.h>
  56. #include <exec/tasks.h>
  57. #include <libraries/dos.h>
  58. #include <proto/exec.h>
  59. #endif
  60.  
  61. #ifdef apollo
  62. #include <apollo/base.h>
  63. #endif
  64.  
  65. extern TSCP  scrt4_onsignal2();
  66.  
  67. #ifdef MIPS
  68. #include <mips/inst.h>
  69. #include <mips/cpu.h>
  70. #endif
  71.  
  72. int  sc_mutex;        /* Mutual exclusion flag */
  73.  
  74. int  sc_pendingsignals;    /* Pending signal flag */
  75.  
  76. /* The garbage collector blocks and reenables signals by calling the following
  77.    routine.
  78. */
  79.  
  80. static int  gcinprogress = 0,    /* Boolean indicating GC in progress */
  81.         savemutex = 0,    /* Value of sc_mutex on entry to GC */
  82.         pendingsignals;    /* Bit mask of pending signals */
  83.  
  84. sc_gcinprogress( gc )
  85.     int  gc;    /* boolean indicating the collection is in progress */
  86. {
  87.     if  (gc)  {
  88.        gcinprogress = 1;
  89.        savemutex = sc_mutex;
  90.        sc_pendingsignals = 0;
  91.     }
  92.     else  {
  93.        sc_mutex = 1;
  94.        gcinprogress = 0;
  95.        sc_pendingsignals = pendingsignals | (sc_freed != EMPTYLIST);
  96.        sc_mutex = savemutex;
  97.        if  (sc_mutex == 0  &&  sc_pendingsignals)  sc_sendpendingsignals();
  98.     }
  99. }
  100.        
  101. /* Signals caught by Scheme->C functions enter this procedure.  As signals
  102.    must sometimes be defered, the code and context are lost.  This should
  103.    not cause a problem as the user program should not be catching any of the
  104.    hardware traps.
  105. */
  106.  
  107. void  sc_onsignal1( signal, code, scp )
  108.     int  signal,
  109.          code;
  110.     struct sigcontext*  scp;
  111. {
  112.     int  i;
  113.     struct  {            /* Save sc_unknowncall's state here */
  114.        TSCP  arg[MAXARGS];
  115.        TSCP  proc[4];
  116.        int     count;
  117.     } save;
  118.  
  119.     if  (sc_mutex == 0  &&  gcinprogress == 0)  {
  120.        /* Save sc_unknowncall's state */
  121.        for  (i = 0; i < 4; i++)  save.proc[ i ] = sc_unknownproc[ i ];
  122.        for  (i = 0; i < MAXARGS; i++)  save.arg[ i ] = sc_arg[ i ];
  123.        save.count = sc_unknownargc;
  124.        /* Call the Scheme->C signal handler */
  125.        scrt4_onsignal2( C_FIXED( signal ) );
  126.        /* Restore sc_unknowncall's state */
  127.        for  (i = 0; i < 4; i++)  sc_unknownproc[ i ] = save.proc[ i ];
  128.        for  (i = 0; i < MAXARGS; i++)  sc_arg[ i ] = save.arg[ i ];
  129.        sc_unknownargc = save.count;    
  130.     }
  131.     else  {
  132.        /* Signal must be defered */
  133. #ifndef    AMIGA
  134. #ifdef SYSV
  135.        sighold( signal );
  136. #else
  137.        sigblock( 1<<signal );
  138. #endif    /* SYSV */
  139. #endif    /* AMIGA */
  140.        pendingsignals = pendingsignals | (1<<signal);
  141.        if  (gcinprogress == 0)  sc_pendingsignals = 1;
  142.     }
  143. }
  144.  
  145. /* Signals that were defered during a critical section are sent by the
  146.    following function at the end of the critical section.  Object cleanup
  147.    actions are also invoked here the first time that a critical section is
  148.    exited following garbage collection.
  149. */
  150.  
  151. sc_sendpendingsignals()
  152. {
  153.     int  oldmask, i, self;
  154.     TSCP  freed, object_procedure;
  155.     struct  {            /* Save sc_unknowncall's state here */
  156.        TSCP  arg[MAXARGS];
  157.        TSCP  proc[4];
  158.        int     count;
  159.     } save;
  160.  
  161.     /* Save sc_freed and sc_unknowncall's state */
  162.     for  (i = 0; i < 4; i++)  save.proc[ i ] = sc_unknownproc[ i ];
  163.     for  (i = 0; i < MAXARGS; i++)  save.arg[ i ] = sc_arg[ i ];
  164.     save.count = sc_unknownargc;
  165.     freed = sc_freed;
  166.     sc_freed = EMPTYLIST;
  167.  
  168.     /* Send the pending signals and exit the critical section */
  169.     sc_pendingsignals = 0;
  170.     self = getpid();
  171. #ifndef SYSV
  172. #ifndef    AMIGA
  173.     oldmask = sigblock( -1 ) & ~pendingsignals;
  174. #endif    /* AMIGA */
  175. #endif    /* SYSV */
  176.     for  (i = 0; i < 32; i++)
  177.       if  (pendingsignals & (1<<i)) {
  178. #ifdef SYSV
  179.         sigrelse( i );
  180. #endif
  181.         kill( self, i );
  182.       }
  183.  
  184.     pendingsignals = 0;
  185.     sc_mutex = 0;
  186. #ifndef SYSV
  187. #ifndef    AMIGA
  188.     sigsetmask( oldmask );
  189. #endif    /* AMIGA */
  190. #endif    /* SYSV */
  191.     /* Apply the when-unreferenced procedures */
  192.     while  (freed != EMPTYLIST)  {
  193.        object_procedure = PAIR_CAR( freed );
  194.        sc_apply_2dtwo( PAIR_CDR( object_procedure ),
  195.                   sc_cons( PAIR_CAR( object_procedure ), EMPTYLIST ) );
  196.        freed = PAIR_CDR( freed );
  197.     }
  198.  
  199.     /* Restore sc_unknowncall's state */
  200.     for  (i = 0; i < 4; i++)  sc_unknownproc[ i ] = save.proc[ i ];
  201.     for  (i = 0; i < MAXARGS; i++)  sc_arg[ i ] = save.arg[ i ];
  202.     sc_unknownargc = save.count;    
  203. }
  204.  
  205. /* Arithmetic traps are handled by the following machine dependent code.
  206.    Overflow on exact computation results in the correct, but inexact result
  207.    being returned.  All other arithmetic traps are considered to be errors.
  208. */
  209.  
  210. extern void emulate_branch();
  211.  
  212. /* sc_trap_handler is a generalized fault handler for TRAP and FLOATING POINT
  213.    exceptions.
  214. */
  215.  
  216. sc_trap_handler (sig,code,scp)
  217.     int sig, code;
  218.     struct sigcontext *scp;
  219. {
  220. #if (TITAN || (MATHTRAPS == 0))
  221.     sc_error( "???? (in sc_trap_handler)", "Floating point exception", 0 );
  222. #endif
  223.  
  224. #ifdef MIPS
  225.     unsigned long opcode, func, rs, rt, rd;
  226.     union mips_instruction branch_inst, exception_inst;
  227. #endif
  228.  
  229.  
  230.     /**********************************
  231.             Unrecoverable exceptions
  232.      **********************************/
  233. #ifdef MIPS
  234.     if (sig == SIGTRAP)   {
  235.         if (code == BRK_DIVZERO) 
  236.             /***** divide by zero exception ****/
  237.             sc_error ("?????", "Divide by zero", 0);
  238.         else if (code == BRK_OVERFLOW)
  239.             /** overflow check **/
  240.             sc_error ("????", "Overflow",0);
  241.         else if (code == BRK_RANGE)
  242.             /** range error check **/
  243.             sc_error ("????", "Out of range",0);
  244.         else    /** other misc types of bpt errors */
  245.             sc_error ("????", "Break point or branch error",0);
  246.     }
  247. #endif
  248. #ifdef VAX
  249.     if  (sig == SIGFPE)  {
  250.        if  (code == FPE_INTDIV_TRAP  ||  code == FPE_FLTDIV_FAULT  ||
  251.         code == FPE_FLTDIV_TRAP)
  252.              /***** divide by zero exception *****/
  253.              sc_error ("?????", "Divide by zero", 0);
  254.        if  (code == FPE_FLTOVF_TRAP  ||  code == FPE_FLTOVF_FAULT)
  255.              /***** floating point overflow *****/
  256.              sc_error ("?????", "Overflow", 0);
  257.        if  (code == FPE_FLTUND_FAULT  ||  code == FPE_FLTUND_TRAP)
  258.              /***** floating point underflow *****/
  259.              sc_error ("?????", "Underflow", 0);
  260.        sc_error ("?????", "Floating point exception: %s", 1,
  261.              C_FIXED( code ));
  262.     }
  263. #endif    
  264. #ifdef apollo
  265.     if  (sig == SIGFPE)  {
  266.        if  (code == FPE_INTDIV_TRAP  ||  code == FPE_FLTDIV_FAULT  ||
  267.         code == FPE_FLTDIV_TRAP)
  268.              /***** divide by zero exception *****/
  269.              sc_error ("?????", "Divide by zero", 0);
  270.        if  (code == FPE_FLTOVF_TRAP  ||  code == FPE_FLTOVF_FAULT)
  271.              /***** floating point overflow *****/
  272.              sc_error ("?????", "Overflow", 0);
  273.        if  (code == FPE_FLTUND_FAULT  ||  code == FPE_FLTUND_TRAP)
  274.              /***** floating point underflow *****/
  275.              sc_error ("?????", "Underflow", 0);
  276.        sc_error ("?????", "Floating point exception: ~s", 1,
  277.              C_FIXED( code ));
  278.     }
  279.     else if (sig == SIGAPOLLO) {
  280.         status_$t status;
  281.         char *subsys, *module, *error;
  282.         short lsubsys, lmodule, lerror;
  283.         char buffer[256];
  284.  
  285.         status.all = code;
  286.         error_$find_text(status, &subsys, &lsubsys, &module, &lmodule,
  287.                  &error, &lerror);
  288.         sprintf(buffer, "%.*s (%.*s/%.*s)", lerror, error,
  289.             lsubsys, subsys, lmodule, module);
  290.         sc_error("?????", buffer, 0);
  291.     }
  292. #endif    
  293.     
  294.     /***************************************
  295.       other possibly recoverable exceptions
  296.      ***************************************/
  297. #ifdef MIPS
  298.     if (scp->sc_cause & CAUSE_BD) {
  299.         branch_inst.word = *(unsigned long *) scp->sc_pc ; 
  300.         exception_inst.word = *(unsigned long *) (scp->sc_pc + 4); 
  301.         /* printf ("it was a branch delay.\n"); */
  302.     }
  303.     else  { exception_inst.word = *(unsigned long *) (scp->sc_pc); 
  304.            /* printf ("it wasn't a branch delay.\n");  */ 
  305.     }
  306.  
  307.     opcode = exception_inst.j_format.opcode;  /* get opcode field */
  308.  
  309.     switch (opcode)  {
  310.           case spec_op:
  311.         func = exception_inst.r_format.func;  /* get function field */
  312.         switch (func)   {
  313.               case add_op:  
  314.             if (sig == SIGFPE && code == EXC_OV)  {
  315.                 /**** integer add overflow ***/
  316.                 rs = exception_inst.r_format.rs;
  317.                 rt = exception_inst.r_format.rt;
  318.                 rd = exception_inst.r_format.rd;
  319.  
  320.                 scp->sc_regs[rd] = 
  321.                 (unsigned int) 
  322.                 FLTV_FLT( (double) FIXED_C(scp->sc_regs[rs]) + 
  323.                       (double) FIXED_C(scp->sc_regs[rt])
  324.                      );
  325.     
  326.                 if (scp->sc_cause & CAUSE_BD) 
  327.                     emulate_branch(scp, branch_inst);
  328.                 else 
  329.                     scp->sc_pc += 4;
  330.             }
  331.             else sc_error ("+", 
  332.                    "unknown floating point exception code", 0);
  333.  
  334.             break;
  335.  
  336.               case sub_op:
  337.             if (sig == SIGFPE && code == EXC_OV)  {
  338.                 /**** integer sub overflow ****/
  339.                 rs = exception_inst.r_format.rs;
  340.                 rt = exception_inst.r_format.rt;
  341.                 rd = exception_inst.r_format.rd;
  342.  
  343.                 scp->sc_regs[rd] = 
  344.                 (unsigned int)
  345.                 FLTV_FLT( (double) FIXED_C(scp->sc_regs[rs]) -
  346.                       (double) FIXED_C(scp->sc_regs[rt])
  347.                      );
  348.  
  349.                 if (scp->sc_cause & CAUSE_BD) 
  350.                     emulate_branch(scp, branch_inst);
  351.                 else 
  352.                     scp->sc_pc += 4;
  353.             }
  354.             else sc_error ("-", 
  355.                    "Unknown floating point exception code", 0);
  356.  
  357.             break;            
  358.             
  359.               default:
  360.             sc_error ("UNKNOWN",
  361.             "Other instructions of type special not decoded",0);
  362.             break;
  363.         }   /* close switch (func) */
  364.         break;
  365.  
  366.           case bcond_op:
  367.         sc_error ("sc_trap_handler", "BCOND op decoded", 0);
  368.         break;
  369.           case j_op:
  370.             sc_error ("sc_trap_handler", "J op decoded", 0);
  371.         break;
  372.           case jal_op:
  373.         sc_error ("sc_trap_handler", "JAL op decoded",0);
  374.         break;
  375.           default:
  376.         sc_error ("sc_trap_handler", "Other opcodes not decoded", 0);
  377.         break;
  378.     }
  379. #endif
  380.  
  381. }
  382.  
  383. #ifdef MIPS
  384.  
  385. /* emulate_branch modifies the value of the program counter in the 
  386.    signal context structure (sc_pc) to the target of the branch instruction.  
  387. */
  388.  
  389. void emulate_branch(scp, branch_inst)
  390.     struct sigcontext *scp;
  391.     union mips_instruction branch_inst;
  392.   {
  393.       unsigned long target = branch_inst.j_format.target,
  394.                     opcode = branch_inst.j_format.opcode,
  395.                     pc = *(unsigned long *) scp->sc_pc,
  396.                     func, rs;
  397.       
  398.       /***********************************************
  399.           note: the current implementation only 
  400.           takes care of jr and j branch instructions.
  401.           Other cases can be added as need arises.
  402.        ***********************************************/
  403.  
  404.       switch (opcode)  {
  405.         case spec_op:
  406.           func = branch_inst.r_format.func;   /* get function field */
  407.           rs = branch_inst.r_format.rs;   /* reg with branch addr */
  408.          
  409.           switch (func)  {
  410.             case jr_op:  
  411.               /**** branch instruction is jump register ****/
  412.                  /* set program counter to be target of *
  413.                   * branch instruction.                 *
  414.                   *                                     */
  415.               scp->sc_pc = scp->sc_regs[rs]; 
  416.               break;
  417.             case jalr_op:  
  418.               sc_error ("emulate_branch", 
  419.                     "Branch instruction is JALR", 0);
  420.               break;
  421.             default:
  422.               sc_error ("emulate_branch", 
  423.                     "Special inst not decoded", 0);
  424.               break;
  425.           }
  426.           break;
  427.           
  428.         case j_op:  
  429.           /**** jump instruction ****/
  430.             /* new pc is calculated by left shifting target field 
  431.                2 bits and combining result with high 4 bits of 
  432.                current pc
  433.              */
  434.           target = target<<2;
  435.           scp->sc_pc = (unsigned long) ((pc & 036000000000) | target);
  436.           break;
  437.         case jal_op:
  438.           sc_error ("emulate_branch",
  439.                 "Branch instruction is jal", 0);
  440.           break;
  441.         default:
  442.           sc_error ("emulate_branch",
  443.                 "Instruction not decoded", 0);
  444.           break;
  445.       }
  446.   }      
  447. #endif
  448.  
  449. /* The following function is called during initialization to enable the
  450.    arithmetic trap handlers.
  451. */
  452.  
  453. sc_mathtraps()  {
  454.     signal(SIGFPE, sc_trap_handler);
  455. #ifdef MIPS
  456.     signal(SIGTRAP, sc_trap_handler);
  457. #endif
  458. }
  459.  
  460. #ifdef    AMIGA
  461. /*
  462.  * We need to provide versions of some of the signal-handling functions
  463.  * used here.
  464.  */
  465.  
  466. /*
  467.  * Find out who to send signals *to*. Could be done as a define, but the
  468.  * compiler needs it also.
  469.  */
  470. int
  471. getpid() {
  472.  
  473.     return (int) FindTask(NULL);
  474.     }
  475.  
  476. /* Send the signals (or fake it) that we know how to deal with */
  477. int
  478. kill(int pid, int signal) {
  479.     extern int _FPERR ;
  480.     extern void __stdargs CXFERR() ;
  481.  
  482.     switch (signal) {
  483.         case SIGFPE:
  484.             CXFERR(_FPERR) ;    /* Just runs the handler */
  485.             break ;
  486.         
  487.         case SIGINT:
  488.             Signal(pid, SIGBREAKF_CTRL_C) ;
  489.             break ;
  490.  
  491.         default:        /* Don't know, so send a break again */
  492.             Signal(pid, SIGBREAKF_CTRL_D) ;
  493.             break ;
  494.         }
  495.     }
  496.  
  497. /* Provide Scheme with access to math errors */
  498. #include <math.h>
  499. int matherr(struct exception *x) {
  500.  
  501.     switch (x->type) {
  502.         case DOMAIN:
  503.             sc_error("????? (Math Error)", "Domain", 0) ;
  504.             break ;
  505.         case SING:
  506.             sc_error("????? (Math Error)", "Singularity", 0) ;
  507.             break ;
  508.         case OVERFLOW:
  509.             sc_error("????? (Math Error)", "Overflow", 0) ;
  510.             break ;
  511.         case UNDERFLOW:
  512.             sc_error("????? (Math Error)", "Underflow", 0) ;
  513.             break ;
  514.         case TLOSS:    /* Totla/Partial loss of precision */
  515.         case PLOSS:
  516. sc_error("???? (Math Error)", "Loss of precision", 0) ;
  517.             /* Just return "use this value" for now */
  518.             break ;
  519.         }
  520.     return (0) ;
  521.     }    
  522. #endif
  523.