home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / mitsch75.zip / scheme-7_5_17-src.zip / scheme-7.5.17 / src / microcode / uxtrap.c < prev    next >
C/C++ Source or Header  |  2000-12-05  |  24KB  |  853 lines
  1. /* -*-C-*-
  2.  
  3. $Id: uxtrap.c,v 1.30 2000/12/05 21:23:49 cph Exp $
  4.  
  5. Copyright (c) 1990-2000 Massachusetts Institute of Technology
  6.  
  7. This program is free software; you can redistribute it and/or modify
  8. it under the terms of the GNU General Public License as published by
  9. the Free Software Foundation; either version 2 of the License, or (at
  10. your option) any later version.
  11.  
  12. This program is distributed in the hope that it will be useful, but
  13. WITHOUT ANY WARRANTY; without even the implied warranty of
  14. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  15. General Public License for more details.
  16.  
  17. You should have received a copy of the GNU General Public License
  18. along with this program; if not, write to the Free Software
  19. Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  20. */
  21.  
  22. #include "scheme.h"
  23. #include "ux.h"
  24. #include "uxtrap.h"
  25. #include "uxutil.h"
  26. #include "option.h"
  27. #include "ostop.h"
  28.  
  29. extern CONST char * EXFUN (find_signal_name, (int signo));
  30. extern void EXFUN (UX_dump_core, (void));
  31. extern PTR initial_C_stack_pointer;
  32.  
  33. static enum trap_state trap_state;
  34. static enum trap_state user_trap_state;
  35.  
  36. static enum trap_state saved_trap_state;
  37. static int saved_signo;
  38. static SIGINFO_T saved_info;
  39. static struct FULL_SIGCONTEXT * saved_scp;
  40.  
  41. static void EXFUN (initialize_ux_signal_codes, (void));
  42. static void EXFUN
  43.   (continue_from_trap,
  44.    (int signo, SIGINFO_T info, struct FULL_SIGCONTEXT * scp));
  45.  
  46. void
  47. DEFUN_VOID (UX_initialize_trap_recovery)
  48. {
  49.   trap_state = trap_state_recover;
  50.   user_trap_state = trap_state_recover;
  51.   initialize_ux_signal_codes ();
  52. }
  53.  
  54. enum trap_state
  55. DEFUN (OS_set_trap_state, (state), enum trap_state state)
  56. {
  57.   enum trap_state old_trap_state = user_trap_state;
  58.   user_trap_state = state;
  59.   trap_state = state;
  60.   return (old_trap_state);
  61. }
  62.  
  63. static void
  64. DEFUN_VOID (trap_normal_termination)
  65. {
  66.   trap_state = trap_state_exitting_soft;
  67.   termination_trap ();
  68. }
  69.  
  70. static void
  71. DEFUN_VOID (trap_immediate_termination)
  72. {
  73.   trap_state = trap_state_exitting_hard;
  74.   OS_restore_external_state ();
  75.   exit (1);
  76. }
  77.  
  78. static void
  79. DEFUN_VOID (trap_dump_core)
  80. {
  81.   if (! (option_disable_core_dump))
  82.     UX_dump_core ();
  83.   else
  84.     {
  85.       fputs (">> Core dumps are disabled - Terminating normally.\n", stdout);
  86.       fflush (stdout);
  87.       termination_trap ();
  88.     }
  89. }
  90.  
  91. static void
  92. DEFUN_VOID (trap_recover)
  93. {
  94.   if (WITHIN_CRITICAL_SECTION_P ())
  95.     {
  96.       CLEAR_CRITICAL_SECTION_HOOK ();
  97.       EXIT_CRITICAL_SECTION ({});
  98.     }
  99.   reset_interruptable_extent ();
  100.   continue_from_trap (saved_signo, saved_info, saved_scp);
  101. }
  102.  
  103. void
  104. DEFUN (trap_handler, (message, signo, info, scp),
  105.        CONST char * message AND
  106.        int signo AND
  107.        SIGINFO_T info AND
  108.        struct FULL_SIGCONTEXT * scp)
  109. {
  110.   int code = ((SIGINFO_VALID_P (info)) ? (SIGINFO_CODE (info)) : 0);
  111.   Boolean stack_overflowed_p = (STACK_OVERFLOWED_P ());
  112.   enum trap_state old_trap_state = trap_state;
  113.  
  114.   if (old_trap_state == trap_state_exitting_hard)
  115.     _exit (1);
  116.   else if (old_trap_state == trap_state_exitting_soft)
  117.     trap_immediate_termination ();
  118.   trap_state = trap_state_trapped;
  119.   if (WITHIN_CRITICAL_SECTION_P ())
  120.   {
  121.     fprintf (stdout,
  122.          "\n>> A %s has occurred within critical section \"%s\".\n",
  123.          message, (CRITICAL_SECTION_NAME ()));
  124.     fprintf (stdout, ">> [signal %d (%s), code %d]\n",
  125.          signo, (find_signal_name (signo)), code);
  126.   }
  127.   else if (stack_overflowed_p || (old_trap_state != trap_state_recover))
  128.   {
  129.     fprintf (stdout, "\n>> A %s has occurred.\n", message);
  130.     fprintf (stdout, ">> [signal %d (%s), code %d]\n",
  131.          signo, (find_signal_name (signo)), code);
  132.   }
  133.   if (stack_overflowed_p)
  134.   {
  135.     fputs (">> The stack has overflowed overwriting adjacent memory.\n",
  136.        stdout);
  137.     fputs (">> This was probably caused by a runaway recursion.\n", stdout);
  138.   }
  139.   fflush (stdout);
  140.  
  141.   switch (old_trap_state)
  142.   {
  143.   case trap_state_trapped:
  144.     if ((saved_trap_state == trap_state_recover) ||
  145.     (saved_trap_state == trap_state_query))
  146.     {
  147.       fputs (">> The trap occurred while processing an earlier trap.\n",
  148.          stdout);
  149.       fprintf (stdout,
  150.            ">> [The earlier trap raised signal %d (%s), code %d.]\n",
  151.            saved_signo,
  152.            (find_signal_name (saved_signo)),
  153.            ((SIGINFO_VALID_P (saved_info))
  154.         ? (SIGINFO_CODE (saved_info))
  155.         : 0));
  156.       fputs (((WITHIN_CRITICAL_SECTION_P ())
  157.           ? ">> Successful recovery is extremely unlikely.\n"
  158.           : ">> Successful recovery is unlikely.\n"),
  159.          stdout);
  160.       break;
  161.     }
  162.     else
  163.       trap_immediate_termination ();
  164.   case trap_state_recover:
  165.     if ((WITHIN_CRITICAL_SECTION_P ()) || stack_overflowed_p)
  166.     {
  167.       fputs (">> Successful recovery is unlikely.\n", stdout);
  168.       break;
  169.     }
  170.     else
  171.     {
  172.       saved_trap_state = old_trap_state;
  173.       saved_signo = signo;
  174.       saved_info = info;
  175.       saved_scp = scp;
  176.       trap_recover ();
  177.     }
  178.   case trap_state_exit:
  179.     termination_trap ();
  180.  
  181.   default:
  182.     break;
  183.   }
  184.  
  185.   fflush (stdout);
  186.   saved_trap_state = old_trap_state;
  187.   saved_signo = signo;
  188.   saved_info = info;
  189.   saved_scp = scp;
  190.  
  191.   while (1)
  192.   {
  193.     static CONST char * trap_query_choices[] =
  194.     {
  195.       "D = dump core",
  196.       "I = terminate immediately",
  197.       "N = terminate normally",
  198.       "R = attempt recovery",
  199.       "Q = terminate normally",
  200.       0
  201.       };
  202.     switch (userio_choose_option
  203.         ("Choose one of the following actions:",
  204.          "Action -> ",
  205.          trap_query_choices))
  206.     {
  207.     case 'I':
  208.       trap_immediate_termination ();
  209.     case 'D':
  210.       trap_dump_core ();
  211.     case '\0':
  212.       /* Error in IO. Assume everything scrod. */
  213.     case 'N':
  214.     case 'Q':
  215.       trap_normal_termination ();
  216.     case 'R':
  217.       trap_recover ();
  218.     }
  219.   }
  220. }
  221.  
  222. struct ux_sig_code_desc
  223. {
  224.   int signo;
  225.   unsigned long code_mask;
  226.   unsigned long code_value;
  227.   char *name;
  228. };
  229.  
  230. static struct ux_sig_code_desc ux_signal_codes [64];
  231.  
  232. #define DECLARE_UX_SIGNAL_CODE(s, m, v, n)                \
  233. {                                    \
  234.   ((ux_signal_codes [i]) . signo) = (s);                \
  235.   ((ux_signal_codes [i]) . code_mask) = (m);                \
  236.   ((ux_signal_codes [i]) . code_value) = (v);                \
  237.   ((ux_signal_codes [i]) . name) = (n);                    \
  238.   i += 1;                                \
  239. }
  240.  
  241. static void
  242. DEFUN_VOID (initialize_ux_signal_codes)
  243. {
  244.   unsigned int i = 0;
  245.   INITIALIZE_UX_SIGNAL_CODES ();
  246.   DECLARE_UX_SIGNAL_CODE (0, 0, 0, ((char *) 0));
  247. }
  248.  
  249. static SCHEME_OBJECT
  250. DEFUN (find_signal_code_name, (signo, info, scp),
  251.        int signo AND
  252.        SIGINFO_T info AND
  253.        struct FULL_SIGCONTEXT * scp)
  254. {
  255.   unsigned long code = 0;
  256.   char * name = 0;
  257.   if (SIGINFO_VALID_P (info))
  258.     {
  259.       code = (SIGINFO_CODE (info));
  260. #ifdef SPECIAL_SIGNAL_CODE_NAMES
  261.       SPECIAL_SIGNAL_CODE_NAMES ();
  262.       if (name == 0)
  263. #endif
  264.     {
  265.       struct ux_sig_code_desc * entry = (& (ux_signal_codes [0]));
  266.       while ((entry -> signo) != 0)
  267.         if (((entry -> signo) == signo)
  268.         && (((entry -> code_mask) & code) == (entry -> code_value)))
  269.           {
  270.         name = (entry -> name);
  271.         break;
  272.           }
  273.         else
  274.           entry += 1;
  275.     }
  276.     }
  277.   return (cons ((long_to_integer ((long) code)),
  278.         ((name == 0) ? SHARP_F
  279.          : (char_pointer_to_string ((unsigned char *) name)))));
  280. }
  281.  
  282. static void
  283. DEFUN (setup_trap_frame, (signo, info, scp, trinfo, new_stack_pointer),
  284.        int signo AND
  285.        SIGINFO_T info AND
  286.        struct FULL_SIGCONTEXT * scp AND
  287.        struct trap_recovery_info * trinfo AND
  288.        SCHEME_OBJECT * new_stack_pointer)
  289. {
  290.   SCHEME_OBJECT handler = SHARP_F;
  291.   SCHEME_OBJECT signal_name, signal_code;
  292.   int stack_recovered_p = (new_stack_pointer != 0);
  293.   long saved_mask = (FETCH_INTERRUPT_MASK ());
  294.   SET_INTERRUPT_MASK (0);    /* To prevent GC for now. */
  295.   if ((! (Valid_Fixed_Obj_Vector ())) ||
  296.       ((handler = (Get_Fixed_Obj_Slot (Trap_Handler))) == SHARP_F))
  297.     {
  298.       fprintf (stderr, "There is no trap handler for recovery!\n");
  299.       fflush (stderr);
  300.       termination_trap ();
  301.     }
  302.   if (Free > MemTop)
  303.   {
  304.       Request_GC (0);
  305.   }
  306.   signal_name =
  307.     ((signo == 0)
  308.      ? SHARP_F
  309.      : (char_pointer_to_string
  310.     ((unsigned char *) (find_signal_name (signo)))));
  311.   signal_code = (find_signal_code_name (signo, info, scp));
  312.   if (!stack_recovered_p)
  313.     {
  314.       INITIALIZE_STACK ();
  315.      Will_Push (CONTINUATION_SIZE);
  316.       Store_Return (RC_END_OF_COMPUTATION);
  317.       Store_Expression (SHARP_F);
  318.       Save_Cont ();
  319.      Pushed ();
  320.     }
  321.   else
  322.     Stack_Pointer = new_stack_pointer;
  323.  Will_Push (7 + CONTINUATION_SIZE);
  324.   STACK_PUSH (trinfo -> extra_trap_info);
  325.   STACK_PUSH (trinfo -> pc_info_2);
  326.   STACK_PUSH (trinfo -> pc_info_1);
  327.   STACK_PUSH (trinfo -> state);
  328.   STACK_PUSH (BOOLEAN_TO_OBJECT (stack_recovered_p));
  329.   STACK_PUSH (signal_code);
  330.   STACK_PUSH (signal_name);
  331.   Store_Return (RC_HARDWARE_TRAP);
  332.   Store_Expression (long_to_integer (signo));
  333.   Save_Cont ();
  334.  Pushed ();
  335.   if (stack_recovered_p
  336.       /* This may want to do it in other cases, but this may be enough. */
  337.       && (trinfo->state == STATE_COMPILED_CODE))
  338.   {
  339.     Stop_History ();
  340.   }
  341.   History = (Make_Dummy_History ());
  342.  Will_Push (STACK_ENV_EXTRA_SLOTS + 2);
  343.   STACK_PUSH (signal_name);
  344.   STACK_PUSH (handler);
  345.   STACK_PUSH (STACK_FRAME_HEADER + 1);
  346.  Pushed ();
  347.   SET_INTERRUPT_MASK (saved_mask);
  348.   abort_to_interpreter (PRIM_APPLY);
  349. }
  350.  
  351. /* 0 is an invalid signal, it means a user requested reset. */
  352.  
  353. void
  354. DEFUN (hard_reset, (scp), struct FULL_SIGCONTEXT * scp)
  355. {
  356.   continue_from_trap (0, 0, scp);
  357. }
  358.  
  359. /* Called synchronously. */
  360.  
  361. void
  362. DEFUN_VOID (soft_reset)
  363. {
  364.   struct trap_recovery_info trinfo;
  365.   SCHEME_OBJECT * new_stack_pointer =
  366.     (((Stack_Pointer <= Stack_Top) && (Stack_Pointer > Stack_Guard))
  367.      ? Stack_Pointer
  368.      : 0);
  369.   if ((Regs[REGBLOCK_PRIMITIVE]) != SHARP_F)
  370.     {
  371.       (trinfo . state) = STATE_PRIMITIVE;
  372.       (trinfo . pc_info_1) = (Regs[REGBLOCK_PRIMITIVE]);
  373.       (trinfo . pc_info_2) =
  374.     (LONG_TO_UNSIGNED_FIXNUM (Regs[REGBLOCK_LEXPR_ACTUALS]));
  375.       (trinfo . extra_trap_info) = SHARP_F;
  376.     }
  377.   else
  378.     {
  379.       (trinfo . state) = STATE_UNKNOWN;
  380.       (trinfo . pc_info_1) = SHARP_F;
  381.       (trinfo . pc_info_2) = SHARP_F;
  382.       (trinfo . extra_trap_info) = SHARP_F;
  383.     }
  384.   if ((Free >= Heap_Top) || (Free < Heap_Bottom))
  385.     /* Let's hope this works. */
  386.     Free = MemTop;
  387.   setup_trap_frame (0, 0, 0, (&trinfo), new_stack_pointer);
  388. }
  389.  
  390. #if !defined(HAVE_STRUCT_SIGCONTEXT) || !defined(HAS_COMPILER_SUPPORT) || defined(USE_STACKLETS)
  391.  
  392. static struct trap_recovery_info dummy_recovery_info =
  393. {
  394.   STATE_UNKNOWN,
  395.   SHARP_F,
  396.   SHARP_F,
  397.   SHARP_F
  398. };
  399.  
  400. static void
  401. DEFUN (continue_from_trap, (signo, info, scp),
  402.        int signo AND
  403.        SIGINFO_T info AND
  404.        struct FULL_SIGCONTEXT * scp)
  405. {
  406.   if (Free < MemTop)
  407.   {
  408.     Free = MemTop;
  409.   }
  410.   setup_trap_frame (signo, info, scp, (&dummy_recovery_info), 0);
  411. }
  412.  
  413. #else /* HAS_COMPILER_SUPPORT and not USE_STACKLETS */
  414.  
  415. /* Heuristic recovery from Unix signals (traps).
  416.  
  417.    continue_from_trap attempts to:
  418.  
  419.    1) validate the trap information (pc and sp);
  420.    2) determine whether compiled code was executing, a primitive was
  421.       executing, or execution was in the interpreter;
  422.    3) guess what C global state is still valid; and
  423.    4) set up a recovery frame for the interpreter so that debuggers can
  424.       display more information. */
  425.  
  426. #include "gccode.h"
  427.  
  428. #define SCHEME_ALIGNMENT_MASK        ((sizeof (long)) - 1)
  429. #define STACK_ALIGNMENT_MASK        SCHEME_ALIGNMENT_MASK
  430. #define FREE_PARANOIA_MARGIN        0x100
  431.  
  432. #define C_STACK_SIZE            0x01000000
  433.  
  434. static void
  435. DEFUN (continue_from_trap, (signo, info, scp),
  436.        int signo AND
  437.        SIGINFO_T info AND
  438.        struct FULL_SIGCONTEXT * scp)
  439. {
  440.   int pc_in_builtin;
  441.   int builtin_index;
  442.   int pc_in_C;
  443.   int pc_in_heap;
  444.   int pc_in_constant_space;
  445.   int pc_in_scheme;
  446.   int pc_in_hyper_space;
  447.   int pc_in_utility;
  448.   int utility_index;
  449.   int scheme_sp_valid;
  450.   long C_sp = (FULL_SIGCONTEXT_SP (scp));
  451.   long scheme_sp = (FULL_SIGCONTEXT_SCHSP (scp));
  452.   long the_pc = ((FULL_SIGCONTEXT_PC (scp)) & PC_VALUE_MASK);
  453.   SCHEME_OBJECT * new_stack_pointer;
  454.   SCHEME_OBJECT * xtra_info;
  455.   struct trap_recovery_info trinfo;
  456.   extern int EXFUN (pc_to_utility_index, (unsigned long));
  457.   extern int EXFUN (pc_to_builtin_index, (unsigned long));
  458.  
  459.   if ((the_pc & PC_ALIGNMENT_MASK) != 0)
  460.   {
  461.     pc_in_builtin = 0;
  462.     pc_in_utility = 0;
  463.     pc_in_C = 0;
  464.     pc_in_heap = 0;
  465.     pc_in_constant_space = 0;
  466.     pc_in_scheme = 0;
  467.     pc_in_hyper_space = 1;
  468.   }
  469.   else
  470.   {
  471.     builtin_index = (pc_to_builtin_index (the_pc));
  472.     pc_in_builtin = (builtin_index != -1);
  473.     utility_index = (pc_to_utility_index (the_pc));
  474.     pc_in_utility = (utility_index != -1);    
  475.     pc_in_C = ((the_pc <= ((long) (get_etext ()))) && (!pc_in_builtin));
  476.     pc_in_heap = ADDRESS_HEAP_P ((SCHEME_OBJECT*) the_pc);
  477.     pc_in_constant_space = ADDRESS_CONSTANT_P ((SCHEME_OBJECT*) the_pc);
  478.     pc_in_scheme = (pc_in_heap || pc_in_constant_space || pc_in_builtin);
  479.     pc_in_hyper_space = ((!pc_in_C) && (!pc_in_scheme));
  480.   }
  481.  
  482.   scheme_sp_valid =
  483.     (pc_in_scheme
  484.      && ((scheme_sp < ((long) Stack_Top)) &&
  485.      (scheme_sp >= ((long) Stack_Bottom)) &&
  486.      ((scheme_sp & STACK_ALIGNMENT_MASK) == 0)));
  487.  
  488.   new_stack_pointer =
  489.     (scheme_sp_valid
  490.      ? ((SCHEME_OBJECT *) scheme_sp)
  491.      : (pc_in_C && (Stack_Pointer < Stack_Top)
  492.     && (Stack_Pointer > Stack_Bottom))
  493.      ? Stack_Pointer
  494.      : ((SCHEME_OBJECT *) 0));
  495.  
  496.   if (pc_in_hyper_space || (pc_in_scheme && ALLOW_ONLY_C))
  497.   {
  498.     /* In hyper space. */
  499.     (trinfo . state) = STATE_UNKNOWN;
  500.     (trinfo . pc_info_1) = SHARP_F;
  501.     (trinfo . pc_info_2) = SHARP_F;
  502.     new_stack_pointer = 0;
  503.     if ((Free < MemTop) ||
  504.     (Free >= Heap_Top) ||
  505.     ((((unsigned long) Free) & SCHEME_ALIGNMENT_MASK) != 0))
  506.       Free = MemTop;
  507.   }
  508.   else if (pc_in_scheme)
  509.   {
  510.     /* In compiled code. */
  511.     SCHEME_OBJECT * block_addr;
  512. #ifdef HAVE_FULL_SIGCONTEXT
  513.     SCHEME_OBJECT * maybe_free;
  514. #endif
  515.     block_addr =
  516.       (pc_in_builtin
  517.        ? ((SCHEME_OBJECT *) NULL)
  518.        : (find_block_address (((PTR) the_pc),
  519.                   (pc_in_heap ? Heap_Bottom : Constant_Space))));
  520.     if (block_addr != ((SCHEME_OBJECT *) NULL))
  521.     {
  522.       (trinfo . state) = STATE_COMPILED_CODE;
  523.       (trinfo . pc_info_1) =
  524.     (MAKE_POINTER_OBJECT (TC_COMPILED_CODE_BLOCK, block_addr));
  525.       (trinfo . pc_info_2) =
  526.     (LONG_TO_UNSIGNED_FIXNUM (the_pc - ((long) block_addr)));
  527.     }
  528.     else if (pc_in_builtin)
  529.     {
  530.       (trinfo . state) = STATE_BUILTIN;
  531.       (trinfo . pc_info_1) = (LONG_TO_UNSIGNED_FIXNUM (builtin_index));
  532.       (trinfo . pc_info_2) = SHARP_T;
  533.     }
  534.     else 
  535.     {
  536.       (trinfo . state) = STATE_PROBABLY_COMPILED;
  537.       (trinfo . pc_info_1) = (LONG_TO_UNSIGNED_FIXNUM (the_pc));
  538.       (trinfo . pc_info_2) = SHARP_F;
  539.     }
  540.  
  541.     if ((block_addr == ((SCHEME_OBJECT *) NULL)) && (! pc_in_builtin))
  542.     {
  543.       if ((Free < MemTop) ||
  544.       (Free >= Heap_Top) ||
  545.       ((((unsigned long) Free) & SCHEME_ALIGNMENT_MASK) != 0))
  546.     Free = MemTop;
  547.     }
  548.     else
  549.     {
  550. #ifdef HAVE_FULL_SIGCONTEXT
  551.       maybe_free = ((SCHEME_OBJECT *) (FULL_SIGCONTEXT_RFREE (scp)));
  552.       if (((((unsigned long) maybe_free) & SCHEME_ALIGNMENT_MASK) == 0)
  553.       && (maybe_free >= Heap_Bottom) && (maybe_free < Heap_Top))
  554.     Free = (maybe_free + FREE_PARANOIA_MARGIN);
  555.       else
  556. #endif
  557.     if ((Free < MemTop) || (Free >= Heap_Top)
  558.         || ((((unsigned long) Free) & SCHEME_ALIGNMENT_MASK) != 0))
  559.       Free = MemTop;
  560.     }
  561.   }
  562.  
  563.   else /* pc_in_C */
  564.   {
  565.     /* In the interpreter, a primitive, or a compiled code utility. */
  566.  
  567.     SCHEME_OBJECT primitive = (Regs[REGBLOCK_PRIMITIVE]);
  568.  
  569.     if (pc_in_utility)
  570.     {
  571.       (trinfo . state) = STATE_UTILITY;
  572.       (trinfo . pc_info_1) = (LONG_TO_UNSIGNED_FIXNUM (utility_index));
  573.       (trinfo . pc_info_2) = UNSPECIFIC;
  574.     }
  575.     else if ((OBJECT_TYPE (primitive)) != TC_PRIMITIVE)
  576.     {
  577.       (trinfo . state) = STATE_UNKNOWN;
  578.       (trinfo . pc_info_1) = SHARP_F;
  579.       (trinfo . pc_info_2) = SHARP_F;
  580.       new_stack_pointer = 0;
  581.     }
  582.     else
  583.     {
  584.       (trinfo . state) = STATE_PRIMITIVE;
  585.       (trinfo . pc_info_1) = primitive;
  586.       (trinfo . pc_info_2) =
  587.     (LONG_TO_UNSIGNED_FIXNUM (Regs[REGBLOCK_LEXPR_ACTUALS]));
  588.     }
  589.     if ((new_stack_pointer == 0)
  590.     || ((((unsigned long) Free) & SCHEME_ALIGNMENT_MASK) != 0)
  591.     || ((Free < Heap_Bottom) || (Free >= Heap_Top))
  592.     || ((Free < MemTop) && ((Free + FREE_PARANOIA_MARGIN) >= MemTop)))
  593.       Free = MemTop;
  594.     else if ((Free + FREE_PARANOIA_MARGIN) < MemTop)
  595.       Free +=  FREE_PARANOIA_MARGIN;
  596.   }
  597.   xtra_info = Free;
  598.   Free += (1 + 2 + PROCESSOR_NREGS);
  599.   (trinfo . extra_trap_info) =
  600.     (MAKE_POINTER_OBJECT (TC_NON_MARKED_VECTOR, xtra_info));
  601.   (*xtra_info++) =
  602.     (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, (2 + PROCESSOR_NREGS)));
  603.   (*xtra_info++) = ((SCHEME_OBJECT) the_pc);
  604.   (*xtra_info++) = ((SCHEME_OBJECT) C_sp);
  605.   {
  606.     int counter = FULL_SIGCONTEXT_NREGS;
  607.     long * regs = ((long *) (FULL_SIGCONTEXT_FIRST_REG (scp)));
  608.     while ((counter--) > 0)
  609.       (*xtra_info++) = ((SCHEME_OBJECT) (*regs++));
  610.   }
  611.   /* We assume that regs,sp,pc is the order in the processor.
  612.      Scheme can always fix this. */
  613.   if ((PROCESSOR_NREGS - FULL_SIGCONTEXT_NREGS) > 0)
  614.     (*xtra_info++) = ((SCHEME_OBJECT) C_sp);
  615.   if ((PROCESSOR_NREGS - FULL_SIGCONTEXT_NREGS) > 1)
  616.     (*xtra_info++) = ((SCHEME_OBJECT) the_pc);
  617.   setup_trap_frame (signo, info, scp, (&trinfo), new_stack_pointer);
  618. }
  619.  
  620. /* Find the compiled code block in area which contains `pc_value'.
  621.    This attempts to be more efficient than `find_block_address_in_area'.
  622.    If the pointer is in the heap, it can actually do twice as
  623.    much work, but it is expected to pay off on the average. */
  624.  
  625. static SCHEME_OBJECT * EXFUN
  626.   (find_block_address_in_area, (char * pc_value, SCHEME_OBJECT * area_start));
  627.  
  628. #define MINIMUM_SCAN_RANGE        2048
  629.  
  630. SCHEME_OBJECT *
  631. DEFUN (find_block_address, (pc_value, area_start),
  632.        char * pc_value AND
  633.        SCHEME_OBJECT * area_start)
  634. {
  635.   if (area_start == Constant_Space)
  636.     {
  637.       extern SCHEME_OBJECT * EXFUN
  638.     (find_constant_space_block, (SCHEME_OBJECT *));
  639.       SCHEME_OBJECT * constant_block =
  640.     (find_constant_space_block
  641.      ((SCHEME_OBJECT *)
  642.       (((unsigned long) pc_value) &~ SCHEME_ALIGNMENT_MASK)));
  643.       return
  644.     ((constant_block == 0)
  645.      ? 0
  646.      : (find_block_address_in_area (pc_value, constant_block)));
  647.     }
  648.   {
  649.     SCHEME_OBJECT * nearest_word =
  650.       ((SCHEME_OBJECT *)
  651.        (((unsigned long) pc_value) &~ SCHEME_ALIGNMENT_MASK));
  652.     long maximum_distance = (nearest_word - area_start);
  653.     long distance = maximum_distance;
  654.     while ((distance / 2) > MINIMUM_SCAN_RANGE)
  655.       distance = (distance / 2);
  656.     while ((distance * 2) < maximum_distance)
  657.       {
  658.     SCHEME_OBJECT * block =
  659.       (find_block_address_in_area (pc_value, (nearest_word - distance)));
  660.     if (block != 0)
  661.       return (block);
  662.     distance *= 2;
  663.       }
  664.   }
  665.   return (find_block_address_in_area (pc_value, area_start));
  666. }
  667.  
  668. /*
  669.   Find the compiled code block in area which contains `pc_value',
  670.   by scanning sequentially the complete area.
  671.   For the time being, skip over manifest closures and linkage sections. */
  672.  
  673. static SCHEME_OBJECT *
  674. DEFUN (find_block_address_in_area, (pc_value, area_start),
  675.        char * pc_value AND
  676.        SCHEME_OBJECT * area_start)
  677. {
  678.   SCHEME_OBJECT * first_valid = area_start;
  679.   SCHEME_OBJECT * area = area_start;
  680.   while (((char *) area) < pc_value)
  681.     {
  682.       SCHEME_OBJECT object = (*area);
  683.       switch (OBJECT_TYPE (object))
  684.     {
  685.     case TC_LINKAGE_SECTION:
  686.       {
  687.         switch (READ_LINKAGE_KIND (object))
  688.         {
  689.           case GLOBAL_OPERATOR_LINKAGE_KIND:
  690.           case OPERATOR_LINKAGE_KIND:
  691.           {
  692.         long count = (READ_OPERATOR_LINKAGE_COUNT (object));
  693.         area = ((END_OPERATOR_LINKAGE_AREA (area, count)) + 1);
  694.         break;
  695.           }
  696.  
  697.           default:
  698. #if FALSE
  699.           {
  700.         gc_death (TERM_EXIT,
  701.               "find_block_address: Unknown compiler linkage kind.",
  702.               area, NULL);
  703.         /*NOTREACHED*/
  704.           }
  705. #else
  706.           /* Fall through, no reason to crash here. */
  707. #endif
  708.           case ASSIGNMENT_LINKAGE_KIND:
  709.           case CLOSURE_PATTERN_LINKAGE_KIND:
  710.           case REFERENCE_LINKAGE_KIND:
  711.             area += ((READ_CACHE_LINKAGE_COUNT (object)) + 1);
  712.         break;
  713.  
  714.         }
  715.         break;
  716.       }
  717.     case TC_MANIFEST_CLOSURE:
  718.       {
  719.         area += 1;
  720.         {
  721.           long count = (MANIFEST_CLOSURE_COUNT (area));
  722.           area = ((MANIFEST_CLOSURE_END (area, count)) + 1);
  723.         }
  724.         break;
  725.       }
  726.     case TC_MANIFEST_NM_VECTOR:
  727.       {
  728.         long count = (OBJECT_DATUM (object));
  729.         if (((char *) (area + (count + 1))) < pc_value)
  730.           {
  731.         area += (count + 1);
  732.         first_valid = area;
  733.         break;
  734.           }
  735.         {
  736.           SCHEME_OBJECT * block = (area - 1);
  737.           return
  738.         (((area == first_valid) ||
  739.           (((OBJECT_TYPE (*block)) != TC_MANIFEST_VECTOR)
  740.            && ((OBJECT_TYPE (*block)) !=
  741. #ifdef TC_POSITIVE_FIXNUM
  742.                TC_POSITIVE_FIXNUM
  743. #else
  744.                TC_FIXNUM
  745. #endif
  746.                ))
  747.            ||
  748.           ((OBJECT_DATUM (*block)) < (count + 1)) ||
  749.           (! (PLAUSIBLE_CC_BLOCK_P (block))))
  750.          ? 0
  751.          : block);
  752.         }
  753.       }
  754.     default:
  755.       {
  756.         area += 1;
  757.         break;
  758.       }
  759.     }
  760.     }
  761.   return (0);
  762. }
  763.  
  764. #endif /* HAS_COMPILER_SUPPORT and not USE_STACKLETS */
  765.  
  766.  
  767.  
  768. SCHEME_OBJECT
  769. DEFUN (find_ccblock, (the_pc),
  770.        long the_pc)
  771. {
  772.   int pc_in_builtin;
  773.   int builtin_index;
  774.   int pc_in_C;
  775.   int pc_in_heap;
  776.   int pc_in_constant_space;
  777.   int pc_in_scheme;
  778.   int pc_in_hyper_space;
  779.   int pc_in_utility;
  780.   int utility_index;
  781.   extern int EXFUN (pc_to_utility_index, (unsigned long));
  782.   extern int EXFUN (pc_to_builtin_index, (unsigned long));
  783.  
  784.   if ((the_pc & PC_ALIGNMENT_MASK) != 0)
  785.   {
  786.     pc_in_builtin = 0;
  787.     pc_in_utility = 0;
  788.     pc_in_C = 0;
  789.     pc_in_heap = 0;
  790.     pc_in_constant_space = 0;
  791.     pc_in_scheme = 0;
  792.     pc_in_hyper_space = 1;
  793.   }
  794.   else
  795.   {
  796.     builtin_index = (pc_to_builtin_index (the_pc));
  797.     pc_in_builtin = (builtin_index != -1);
  798.     utility_index = (pc_to_utility_index (the_pc));
  799.     pc_in_utility = (utility_index != -1);    
  800.     pc_in_C = ((the_pc <= ((long) (get_etext ()))) && (!pc_in_builtin));
  801.     pc_in_heap = ADDRESS_HEAP_P ((SCHEME_OBJECT*) the_pc);
  802.     pc_in_constant_space = ADDRESS_CONSTANT_P ((SCHEME_OBJECT*) the_pc);
  803.     pc_in_scheme = (pc_in_heap || pc_in_constant_space || pc_in_builtin);
  804.     pc_in_hyper_space = ((!pc_in_C) && (!pc_in_scheme));
  805.   }
  806.  
  807.   if (pc_in_hyper_space || (pc_in_scheme && ALLOW_ONLY_C))
  808.   {
  809.       return  SHARP_F;
  810.   }
  811.   else if (pc_in_scheme)
  812.   {
  813.     /* In compiled code. */
  814.     SCHEME_OBJECT * block_addr;
  815.     block_addr =
  816.       (pc_in_builtin
  817.        ? ((SCHEME_OBJECT *) NULL)
  818.        : (find_block_address (((PTR) the_pc),
  819.                   (pc_in_heap ? Heap_Bottom : Constant_Space))));
  820.     if (block_addr != ((SCHEME_OBJECT *) NULL))
  821.     {
  822.     return  MAKE_POINTER_OBJECT (TC_COMPILED_CODE_BLOCK, block_addr);
  823.     }
  824.     else if (pc_in_builtin)
  825.     {
  826.     return  SHARP_F;
  827.     }
  828.     else 
  829.     {
  830.     return  SHARP_F;
  831.     }
  832.   }
  833.   else /* pc_in_C */
  834.   {
  835.     /* In the interpreter, a primitive, or a compiled code utility. */
  836.  
  837.     SCHEME_OBJECT primitive = (Regs[REGBLOCK_PRIMITIVE]);
  838.  
  839.     if (pc_in_utility)
  840.     {
  841.     return  SHARP_F;
  842.     }
  843.     else if ((OBJECT_TYPE (primitive)) != TC_PRIMITIVE)
  844.     {
  845.     return  SHARP_F;
  846.     }
  847.     else
  848.     {
  849.     return  SHARP_F;
  850.     }
  851.   }
  852. }
  853.