/* -*-C-*-
$Id: uxtrap.c,v 1.31 2001/12/16 06:01:33 cph Exp $
Copyright (c) 1990-2001 Massachusetts Institute of Technology
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or (at
your option) any later version.
This program 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 this program; if not, write to the Free Software
Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
USA.
*/
#include "scheme.h"
#include "ux.h"
#include "uxtrap.h"
#include "uxutil.h"
#include "option.h"
#include "ostop.h"
extern CONST char * EXFUN (find_signal_name, (int signo));
extern void EXFUN (UX_dump_core, (void));
extern PTR initial_C_stack_pointer;
static enum trap_state trap_state;
static enum trap_state user_trap_state;
static enum trap_state saved_trap_state;
static int saved_signo;
static SIGINFO_T saved_info;
static struct FULL_SIGCONTEXT * saved_scp;
static void EXFUN (initialize_ux_signal_codes, (void));
static void EXFUN
(continue_from_trap,
(int signo, SIGINFO_T info, struct FULL_SIGCONTEXT * scp));
void
DEFUN_VOID (UX_initialize_trap_recovery)
{
trap_state = trap_state_recover;
user_trap_state = trap_state_recover;
initialize_ux_signal_codes ();
}
enum trap_state
DEFUN (OS_set_trap_state, (state), enum trap_state state)
{
enum trap_state old_trap_state = user_trap_state;
user_trap_state = state;
trap_state = state;
return (old_trap_state);
}
static void
DEFUN_VOID (trap_normal_termination)
{
trap_state = trap_state_exitting_soft;
termination_trap ();
}
static void
DEFUN_VOID (trap_immediate_termination)
{
trap_state = trap_state_exitting_hard;
OS_restore_external_state ();
exit (1);
}
static void
DEFUN_VOID (trap_dump_core)
{
if (! (option_disable_core_dump))
UX_dump_core ();
else
{
fputs (">> Core dumps are disabled - Terminating normally.\n", stdout);
fflush (stdout);
termination_trap ();
}
}
static void
DEFUN_VOID (trap_recover)
{
if (WITHIN_CRITICAL_SECTION_P ())
{
CLEAR_CRITICAL_SECTION_HOOK ();
EXIT_CRITICAL_SECTION ({});
}
reset_interruptable_extent ();
continue_from_trap (saved_signo, saved_info, saved_scp);
}
void
DEFUN (trap_handler, (message, signo, info, scp),
CONST char * message AND
int signo AND
SIGINFO_T info AND
struct FULL_SIGCONTEXT * scp)
{
int code = ((SIGINFO_VALID_P (info)) ? (SIGINFO_CODE (info)) : 0);
Boolean stack_overflowed_p = (STACK_OVERFLOWED_P ());
enum trap_state old_trap_state = trap_state;
if (old_trap_state == trap_state_exitting_hard)
_exit (1);
else if (old_trap_state == trap_state_exitting_soft)
trap_immediate_termination ();
trap_state = trap_state_trapped;
if (WITHIN_CRITICAL_SECTION_P ())
{
fprintf (stdout,
"\n>> A %s has occurred within critical section \"%s\".\n",
message, (CRITICAL_SECTION_NAME ()));
fprintf (stdout, ">> [signal %d (%s), code %d]\n",
signo, (find_signal_name (signo)), code);
}
else if (stack_overflowed_p || (old_trap_state != trap_state_recover))
{
fprintf (stdout, "\n>> A %s has occurred.\n", message);
fprintf (stdout, ">> [signal %d (%s), code %d]\n",
signo, (find_signal_name (signo)), code);
}
if (stack_overflowed_p)
{
fputs (">> The stack has overflowed overwriting adjacent memory.\n",
stdout);
fputs (">> This was probably caused by a runaway recursion.\n", stdout);
}
fflush (stdout);
switch (old_trap_state)
{
case trap_state_trapped:
if ((saved_trap_state == trap_state_recover) ||
(saved_trap_state == trap_state_query))
{
fputs (">> The trap occurred while processing an earlier trap.\n",
stdout);
fprintf (stdout,
">> [The earlier trap raised signal %d (%s), code %d.]\n",
saved_signo,
(find_signal_name (saved_signo)),
((SIGINFO_VALID_P (saved_info))
? (SIGINFO_CODE (saved_info))
: 0));
fputs (((WITHIN_CRITICAL_SECTION_P ())
? ">> Successful recovery is extremely unlikely.\n"
: ">> Successful recovery is unlikely.\n"),
stdout);
break;
}
else
trap_immediate_termination ();
case trap_state_recover:
if ((WITHIN_CRITICAL_SECTION_P ()) || stack_overflowed_p)
{
fputs (">> Successful recovery is unlikely.\n", stdout);
break;
}
else
{
saved_trap_state = old_trap_state;
saved_signo = signo;
saved_info = info;
saved_scp = scp;
trap_recover ();
}
case trap_state_exit:
termination_trap ();
default:
break;
}
fflush (stdout);
saved_trap_state = old_trap_state;
saved_signo = signo;
saved_info = info;
saved_scp = scp;
while (1)
{
static CONST char * trap_query_choices[] =
{
"D = dump core",
"I = terminate immediately",
"N = terminate normally",
"R = attempt recovery",
"Q = terminate normally",
0
};
switch (userio_choose_option
("Choose one of the following actions:",
"Action -> ",
trap_query_choices))
{
case 'I':
trap_immediate_termination ();
case 'D':
trap_dump_core ();
case '\0':
/* Error in IO. Assume everything scrod. */
case 'N':
case 'Q':
trap_normal_termination ();
case 'R':
trap_recover ();
}
}
}
struct ux_sig_code_desc
{
int signo;
unsigned long code_mask;
unsigned long code_value;
char *name;
};
static struct ux_sig_code_desc ux_signal_codes [64];
#define DECLARE_UX_SIGNAL_CODE(s, m, v, n) \
{ \
((ux_signal_codes [i]) . signo) = (s); \
((ux_signal_codes [i]) . code_mask) = (m); \
((ux_signal_codes [i]) . code_value) = (v); \
((ux_signal_codes [i]) . name) = (n); \
i += 1; \
}
static void
DEFUN_VOID (initialize_ux_signal_codes)
{
unsigned int i = 0;
INITIALIZE_UX_SIGNAL_CODES ();
DECLARE_UX_SIGNAL_CODE (0, 0, 0, ((char *) 0));
}
static SCHEME_OBJECT
DEFUN (find_signal_code_name, (signo, info, scp),
int signo AND
SIGINFO_T info AND
struct FULL_SIGCONTEXT * scp)
{
unsigned long code = 0;
char * name = 0;
if (SIGINFO_VALID_P (info))
{
code = (SIGINFO_CODE (info));
#ifdef SPECIAL_SIGNAL_CODE_NAMES
SPECIAL_SIGNAL_CODE_NAMES ();
if (name == 0)
#endif
{
struct ux_sig_code_desc * entry = (& (ux_signal_codes [0]));
while ((entry -> signo) != 0)
if (((entry -> signo) == signo)
&& (((entry -> code_mask) & code) == (entry -> code_value)))
{
name = (entry -> name);
break;
}
else
entry += 1;
}
}
return (cons ((long_to_integer ((long) code)),
((name == 0) ? SHARP_F
: (char_pointer_to_string ((unsigned char *) name)))));
}
static void
DEFUN (setup_trap_frame, (signo, info, scp, trinfo, new_stack_pointer),
int signo AND
SIGINFO_T info AND
struct FULL_SIGCONTEXT * scp AND
struct trap_recovery_info * trinfo AND
SCHEME_OBJECT * new_stack_pointer)
{
SCHEME_OBJECT handler = SHARP_F;
SCHEME_OBJECT signal_name, signal_code;
int stack_recovered_p = (new_stack_pointer != 0);
long saved_mask = (FETCH_INTERRUPT_MASK ());
SET_INTERRUPT_MASK (0); /* To prevent GC for now. */
if ((! (Valid_Fixed_Obj_Vector ())) ||
((handler = (Get_Fixed_Obj_Slot (Trap_Handler))) == SHARP_F))
{
fprintf (stderr, "There is no trap handler for recovery!\n");
fflush (stderr);
termination_trap ();
}
if (Free > MemTop)
{
Request_GC (0);
}
signal_name =
((signo == 0)
? SHARP_F
: (char_pointer_to_string
((unsigned char *) (find_signal_name (signo)))));
signal_code = (find_signal_code_name (signo, info, scp));
if (!stack_recovered_p)
{
INITIALIZE_STACK ();
Will_Push (CONTINUATION_SIZE);
Store_Return (RC_END_OF_COMPUTATION);
Store_Expression (SHARP_F);
Save_Cont ();
Pushed ();
}
else
Stack_Pointer = new_stack_pointer;
Will_Push (7 + CONTINUATION_SIZE);
STACK_PUSH (trinfo -> extra_trap_info);
STACK_PUSH (trinfo -> pc_info_2);
STACK_PUSH (trinfo -> pc_info_1);
STACK_PUSH (trinfo -> state);
STACK_PUSH (BOOLEAN_TO_OBJECT (stack_recovered_p));
STACK_PUSH (signal_code);
STACK_PUSH (signal_name);
Store_Return (RC_HARDWARE_TRAP);
Store_Expression (long_to_integer (signo));
Save_Cont ();
Pushed ();
if (stack_recovered_p
/* This may want to do it in other cases, but this may be enough. */
&& (trinfo->state == STATE_COMPILED_CODE))
{
Stop_History ();
}
History = (Make_Dummy_History ());
Will_Push (STACK_ENV_EXTRA_SLOTS + 2);
STACK_PUSH (signal_name);
STACK_PUSH (handler);
STACK_PUSH (STACK_FRAME_HEADER + 1);
Pushed ();
SET_INTERRUPT_MASK (saved_mask);
abort_to_interpreter (PRIM_APPLY);
}
/* 0 is an invalid signal, it means a user requested reset. */
void
DEFUN (hard_reset, (scp), struct FULL_SIGCONTEXT * scp)
{
continue_from_trap (0, 0, scp);
}
/* Called synchronously. */
void
DEFUN_VOID (soft_reset)
{
struct trap_recovery_info trinfo;
SCHEME_OBJECT * new_stack_pointer =
(((Stack_Pointer <= Stack_Top) && (Stack_Pointer > Stack_Guard))
? Stack_Pointer
: 0);
if ((Regs[REGBLOCK_PRIMITIVE]) != SHARP_F)
{
(trinfo . state) = STATE_PRIMITIVE;
(trinfo . pc_info_1) = (Regs[REGBLOCK_PRIMITIVE]);
(trinfo . pc_info_2) =
(LONG_TO_UNSIGNED_FIXNUM (Regs[REGBLOCK_LEXPR_ACTUALS]));
(trinfo . extra_trap_info) = SHARP_F;
}
else
{
(trinfo . state) = STATE_UNKNOWN;
(trinfo . pc_info_1) = SHARP_F;
(trinfo . pc_info_2) = SHARP_F;
(trinfo . extra_trap_info) = SHARP_F;
}
if ((Free >= Heap_Top) || (Free < Heap_Bottom))
/* Let's hope this works. */
Free = MemTop;
setup_trap_frame (0, 0, 0, (&trinfo), new_stack_pointer);
}
#if !defined(HAVE_STRUCT_SIGCONTEXT) || !defined(HAS_COMPILER_SUPPORT) || defined(USE_STACKLETS)
static struct trap_recovery_info dummy_recovery_info =
{
STATE_UNKNOWN,
SHARP_F,
SHARP_F,
SHARP_F
};
static void
DEFUN (continue_from_trap, (signo, info, scp),
int signo AND
SIGINFO_T info AND
struct FULL_SIGCONTEXT * scp)
{
if (Free < MemTop)
{
Free = MemTop;
}
setup_trap_frame (signo, info, scp, (&dummy_recovery_info), 0);
}
#else /* HAS_COMPILER_SUPPORT and not USE_STACKLETS */
/* Heuristic recovery from Unix signals (traps).
continue_from_trap attempts to:
1) validate the trap information (pc and sp);
2) determine whether compiled code was executing, a primitive was
executing, or execution was in the interpreter;
3) guess what C global state is still valid; and
4) set up a recovery frame for the interpreter so that debuggers can
display more information. */
#include "gccode.h"
#define SCHEME_ALIGNMENT_MASK ((sizeof (long)) - 1)
#define STACK_ALIGNMENT_MASK SCHEME_ALIGNMENT_MASK
#define FREE_PARANOIA_MARGIN 0x100
#define C_STACK_SIZE 0x01000000
static void
DEFUN (continue_from_trap, (signo, info, scp),
int signo AND
SIGINFO_T info AND
struct FULL_SIGCONTEXT * scp)
{
int pc_in_builtin;
int builtin_index;
int pc_in_C;
int pc_in_heap;
int pc_in_constant_space;
int pc_in_scheme;
int pc_in_hyper_space;
int pc_in_utility;
int utility_index;
int scheme_sp_valid;
long C_sp = (FULL_SIGCONTEXT_SP (scp));
long scheme_sp = (FULL_SIGCONTEXT_SCHSP (scp));
long the_pc = ((FULL_SIGCONTEXT_PC (scp)) & PC_VALUE_MASK);
SCHEME_OBJECT * new_stack_pointer;
SCHEME_OBJECT * xtra_info;
struct trap_recovery_info trinfo;
extern int EXFUN (pc_to_utility_index, (unsigned long));
extern int EXFUN (pc_to_builtin_index, (unsigned long));
if ((the_pc & PC_ALIGNMENT_MASK) != 0)
{
pc_in_builtin = 0;
pc_in_utility = 0;
pc_in_C = 0;
pc_in_heap = 0;
pc_in_constant_space = 0;
pc_in_scheme = 0;
pc_in_hyper_space = 1;
}
else
{
builtin_index = (pc_to_builtin_index (the_pc));
pc_in_builtin = (builtin_index != -1);
utility_index = (pc_to_utility_index (the_pc));
pc_in_utility = (utility_index != -1);
pc_in_C = ((the_pc <= ((long) (get_etext ()))) && (!pc_in_builtin));
pc_in_heap = ADDRESS_HEAP_P ((SCHEME_OBJECT*) the_pc);
pc_in_constant_space = ADDRESS_CONSTANT_P ((SCHEME_OBJECT*) the_pc);
pc_in_scheme = (pc_in_heap || pc_in_constant_space || pc_in_builtin);
pc_in_hyper_space = ((!pc_in_C) && (!pc_in_scheme));
}
scheme_sp_valid =
(pc_in_scheme
&& ((scheme_sp < ((long) Stack_Top)) &&
(scheme_sp >= ((long) Stack_Bottom)) &&
((scheme_sp & STACK_ALIGNMENT_MASK) == 0)));
new_stack_pointer =
(scheme_sp_valid
? ((SCHEME_OBJECT *) scheme_sp)
: (pc_in_C && (Stack_Pointer < Stack_Top)
&& (Stack_Pointer > Stack_Bottom))
? Stack_Pointer
: ((SCHEME_OBJECT *) 0));
if (pc_in_hyper_space || (pc_in_scheme && ALLOW_ONLY_C))
{
/* In hyper space. */
(trinfo . state) = STATE_UNKNOWN;
(trinfo . pc_info_1) = SHARP_F;
(trinfo . pc_info_2) = SHARP_F;
new_stack_pointer = 0;
if ((Free < MemTop) ||
(Free >= Heap_Top) ||
((((unsigned long) Free) & SCHEME_ALIGNMENT_MASK) != 0))
Free = MemTop;
}
else if (pc_in_scheme)
{
/* In compiled code. */
SCHEME_OBJECT * block_addr;
#ifdef HAVE_FULL_SIGCONTEXT
SCHEME_OBJECT * maybe_free;
#endif
block_addr =
(pc_in_builtin
? ((SCHEME_OBJECT *) NULL)
: (find_block_address (((PTR) the_pc),
(pc_in_heap ? Heap_Bottom : Constant_Space))));
if (block_addr != ((SCHEME_OBJECT *) NULL))
{
(trinfo . state) = STATE_COMPILED_CODE;
(trinfo . pc_info_1) =
(MAKE_POINTER_OBJECT (TC_COMPILED_CODE_BLOCK, block_addr));
(trinfo . pc_info_2) =
(LONG_TO_UNSIGNED_FIXNUM (the_pc - ((long) block_addr)));
}
else if (pc_in_builtin)
{
(trinfo . state) = STATE_BUILTIN;
(trinfo . pc_info_1) = (LONG_TO_UNSIGNED_FIXNUM (builtin_index));
(trinfo . pc_info_2) = SHARP_T;
}
else
{
(trinfo . state) = STATE_PROBABLY_COMPILED;
(trinfo . pc_info_1) = (LONG_TO_UNSIGNED_FIXNUM (the_pc));
(trinfo . pc_info_2) = SHARP_F;
}
if ((block_addr == ((SCHEME_OBJECT *) NULL)) && (! pc_in_builtin))
{
if ((Free < MemTop) ||
(Free >= Heap_Top) ||
((((unsigned long) Free) & SCHEME_ALIGNMENT_MASK) != 0))
Free = MemTop;
}
else
{
#ifdef HAVE_FULL_SIGCONTEXT
maybe_free = ((SCHEME_OBJECT *) (FULL_SIGCONTEXT_RFREE (scp)));
if (((((unsigned long) maybe_free) & SCHEME_ALIGNMENT_MASK) == 0)
&& (maybe_free >= Heap_Bottom) && (maybe_free < Heap_Top))
Free = (maybe_free + FREE_PARANOIA_MARGIN);
else
#endif
if ((Free < MemTop) || (Free >= Heap_Top)
|| ((((unsigned long) Free) & SCHEME_ALIGNMENT_MASK) != 0))
Free = MemTop;
}
}
else /* pc_in_C */
{
/* In the interpreter, a primitive, or a compiled code utility. */
SCHEME_OBJECT primitive = (Regs[REGBLOCK_PRIMITIVE]);
if (pc_in_utility)
{
(trinfo . state) = STATE_UTILITY;
(trinfo . pc_info_1) = (LONG_TO_UNSIGNED_FIXNUM (utility_index));
(trinfo . pc_info_2) = UNSPECIFIC;
}
else if ((OBJECT_TYPE (primitive)) != TC_PRIMITIVE)
{
(trinfo . state) = STATE_UNKNOWN;
(trinfo . pc_info_1) = SHARP_F;
(trinfo . pc_info_2) = SHARP_F;
new_stack_pointer = 0;
}
else
{
(trinfo . state) = STATE_PRIMITIVE;
(trinfo . pc_info_1) = primitive;
(trinfo . pc_info_2) =
(LONG_TO_UNSIGNED_FIXNUM (Regs[REGBLOCK_LEXPR_ACTUALS]));
}
if ((new_stack_pointer == 0)
|| ((((unsigned long) Free) & SCHEME_ALIGNMENT_MASK) != 0)
|| ((Free < Heap_Bottom) || (Free >= Heap_Top))
|| ((Free < MemTop) && ((Free + FREE_PARANOIA_MARGIN) >= MemTop)))
Free = MemTop;
else if ((Free + FREE_PARANOIA_MARGIN) < MemTop)
Free += FREE_PARANOIA_MARGIN;
}
xtra_info = Free;
Free += (1 + 2 + PROCESSOR_NREGS);
(trinfo . extra_trap_info) =
(MAKE_POINTER_OBJECT (TC_NON_MARKED_VECTOR, xtra_info));
(*xtra_info++) =
(MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, (2 + PROCESSOR_NREGS)));
(*xtra_info++) = ((SCHEME_OBJECT) the_pc);
(*xtra_info++) = ((SCHEME_OBJECT) C_sp);
{
int counter = FULL_SIGCONTEXT_NREGS;
long * regs = ((long *) (FULL_SIGCONTEXT_FIRST_REG (scp)));
while ((counter--) > 0)
(*xtra_info++) = ((SCHEME_OBJECT) (*regs++));
}
/* We assume that regs,sp,pc is the order in the processor.
Scheme can always fix this. */
if ((PROCESSOR_NREGS - FULL_SIGCONTEXT_NREGS) > 0)
(*xtra_info++) = ((SCHEME_OBJECT) C_sp);
if ((PROCESSOR_NREGS - FULL_SIGCONTEXT_NREGS) > 1)
(*xtra_info++) = ((SCHEME_OBJECT) the_pc);
setup_trap_frame (signo, info, scp, (&trinfo), new_stack_pointer);
}
/* Find the compiled code block in area which contains `pc_value'.
This attempts to be more efficient than `find_block_address_in_area'.
If the pointer is in the heap, it can actually do twice as
much work, but it is expected to pay off on the average. */
static SCHEME_OBJECT * EXFUN
(find_block_address_in_area, (char * pc_value, SCHEME_OBJECT * area_start));
#define MINIMUM_SCAN_RANGE 2048
SCHEME_OBJECT *
DEFUN (find_block_address, (pc_value, area_start),
char * pc_value AND
SCHEME_OBJECT * area_start)
{
if (area_start == Constant_Space)
{
extern SCHEME_OBJECT * EXFUN
(find_constant_space_block, (SCHEME_OBJECT *));
SCHEME_OBJECT * constant_block =
(find_constant_space_block
((SCHEME_OBJECT *)
(((unsigned long) pc_value) &~ SCHEME_ALIGNMENT_MASK)));
return
((constant_block == 0)
? 0
: (find_block_address_in_area (pc_value, constant_block)));
}
{
SCHEME_OBJECT * nearest_word =
((SCHEME_OBJECT *)
(((unsigned long) pc_value) &~ SCHEME_ALIGNMENT_MASK));
long maximum_distance = (nearest_word - area_start);
long distance = maximum_distance;
while ((distance / 2) > MINIMUM_SCAN_RANGE)
distance = (distance / 2);
while ((distance * 2) < maximum_distance)
{
SCHEME_OBJECT * block =
(find_block_address_in_area (pc_value, (nearest_word - distance)));
if (block != 0)
return (block);
distance *= 2;
}
}
return (find_block_address_in_area (pc_value, area_start));
}
/*
Find the compiled code block in area which contains `pc_value',
by scanning sequentially the complete area.
For the time being, skip over manifest closures and linkage sections. */
static SCHEME_OBJECT *
DEFUN (find_block_address_in_area, (pc_value, area_start),
char * pc_value AND
SCHEME_OBJECT * area_start)
{
SCHEME_OBJECT * first_valid = area_start;
SCHEME_OBJECT * area = area_start;
while (((char *) area) < pc_value)
{
SCHEME_OBJECT object = (*area);
switch (OBJECT_TYPE (object))
{
case TC_LINKAGE_SECTION:
{
switch (READ_LINKAGE_KIND (object))
{
case GLOBAL_OPERATOR_LINKAGE_KIND:
case OPERATOR_LINKAGE_KIND:
{
long count = (READ_OPERATOR_LINKAGE_COUNT (object));
area = ((END_OPERATOR_LINKAGE_AREA (area, count)) + 1);
break;
}
default:
#if FALSE
{
gc_death (TERM_EXIT,
"find_block_address: Unknown compiler linkage kind.",
area, NULL);
/*NOTREACHED*/
}
#else
/* Fall through, no reason to crash here. */
#endif
case ASSIGNMENT_LINKAGE_KIND:
case CLOSURE_PATTERN_LINKAGE_KIND:
case REFERENCE_LINKAGE_KIND:
area += ((READ_CACHE_LINKAGE_COUNT (object)) + 1);
break;
}
break;
}
case TC_MANIFEST_CLOSURE:
{
area += 1;
{
long count = (MANIFEST_CLOSURE_COUNT (area));
area = (MANIFEST_CLOSURE_END (area, count));
}
break;
}
case TC_MANIFEST_NM_VECTOR:
{
long count = (OBJECT_DATUM (object));
if (((char *) (area + (count + 1))) < pc_value)
{
area += (count + 1);
first_valid = area;
break;
}
{
SCHEME_OBJECT * block = (area - 1);
return
(((area == first_valid) ||
(((OBJECT_TYPE (*block)) != TC_MANIFEST_VECTOR)
&& ((OBJECT_TYPE (*block)) !=
#ifdef TC_POSITIVE_FIXNUM
TC_POSITIVE_FIXNUM
#else
TC_FIXNUM
#endif
))
||
((OBJECT_DATUM (*block)) < (count + 1)) ||
(! (PLAUSIBLE_CC_BLOCK_P (block))))
? 0
: block);
}
}
default:
{
area += 1;
break;
}
}
}
return (0);
}
#endif /* HAS_COMPILER_SUPPORT and not USE_STACKLETS */
SCHEME_OBJECT
DEFUN (find_ccblock, (the_pc),
long the_pc)
{
int pc_in_builtin;
int builtin_index;
int pc_in_C;
int pc_in_heap;
int pc_in_constant_space;
int pc_in_scheme;
int pc_in_hyper_space;
int pc_in_utility;
int utility_index;
extern int EXFUN (pc_to_utility_index, (unsigned long));
extern int EXFUN (pc_to_builtin_index, (unsigned long));
if ((the_pc & PC_ALIGNMENT_MASK) != 0)
{
pc_in_builtin = 0;
pc_in_utility = 0;
pc_in_C = 0;
pc_in_heap = 0;
pc_in_constant_space = 0;
pc_in_scheme = 0;
pc_in_hyper_space = 1;
}
else
{
builtin_index = (pc_to_builtin_index (the_pc));
pc_in_builtin = (builtin_index != -1);
utility_index = (pc_to_utility_index (the_pc));
pc_in_utility = (utility_index != -1);
pc_in_C = ((the_pc <= ((long) (get_etext ()))) && (!pc_in_builtin));
pc_in_heap = ADDRESS_HEAP_P ((SCHEME_OBJECT*) the_pc);
pc_in_constant_space = ADDRESS_CONSTANT_P ((SCHEME_OBJECT*) the_pc);
pc_in_scheme = (pc_in_heap || pc_in_constant_space || pc_in_builtin);
pc_in_hyper_space = ((!pc_in_C) && (!pc_in_scheme));
}
if (pc_in_hyper_space || (pc_in_scheme && ALLOW_ONLY_C))
{
return SHARP_F;
}
else if (pc_in_scheme)
{
/* In compiled code. */
SCHEME_OBJECT * block_addr;
block_addr =
(pc_in_builtin
? ((SCHEME_OBJECT *) NULL)
: (find_block_address (((PTR) the_pc),
(pc_in_heap ? Heap_Bottom : Constant_Space))));
if (block_addr != ((SCHEME_OBJECT *) NULL))
{
return MAKE_POINTER_OBJECT (TC_COMPILED_CODE_BLOCK, block_addr);
}
else if (pc_in_builtin)
{
return SHARP_F;
}
else
{
return SHARP_F;
}
}
else /* pc_in_C */
{
/* In the interpreter, a primitive, or a compiled code utility. */
SCHEME_OBJECT primitive = (Regs[REGBLOCK_PRIMITIVE]);
if (pc_in_utility)
{
return SHARP_F;
}
else if ((OBJECT_TYPE (primitive)) != TC_PRIMITIVE)
{
return SHARP_F;
}
else
{
return SHARP_F;
}
}
}
syntax highlighted by Code2HTML, v. 0.9.1