sampling.
changecom(`;');;; -*-Midas-*-
;;;
-;;; $Id: hppa.m4,v 1.28 1993/07/27 17:47:34 gjr Exp $
+;;; $Id: hppa.m4,v 1.29 1993/07/29 07:02:17 gjr Exp $
;;;
;;; Copyright (c) 1989-1993 Massachusetts Institute of Technology
;;;
B scheme_to_interface
LDI HEX($2),28 ; operation code")
+flonum_result
unary_flonum_result
ADDI,TR 4,22,6 ; ret. add. location
interface_initialize
.PROC
- .CALLINFO CALLER,FRAME=0
+ .CALLINFO CALLER,FRAME=4,SAVE_RP
.ENTRY
- LDO 4(30),30 ; Allocate stack slot
- FSTWS 0,0(30)
- LDW 0(30),22
+ STW 2,-20(0,30) ; Preserve return address
+ LDO 64(30),30 ; Allocate stack frame
+ STW 3,-64(30) ; Preserve gr3
+ FSTWS 0,-4(30)
+ LDW -4(30),22
LDI 30,21 ; enable V, Z, O, U traps
OR 21,22,22
- STW 22,0(30)
- FLDWS 0(30),0
+ STW 22,-4(30)
+ FLDWS -4(30),0
; Prepare entry points
- BL known_pc,28 ; get pc
+ BL known_pc,3 ; get pc
NOP
known_pc
-define(store_entry_point,"ADDIL L'ep_$1-known_pc,28
+define(store_entry_point,"ADDIL L'ep_$1-known_pc,3
LDO R'ep_$1-known_pc(1),29
ADDIL L'$1-$global$,27
STW 29,R'$1-$global$(1)")
store_entry_point(interface_to_scheme)
store_entry_point(interface_to_C)
- store_entry_point(scheme_hooks_low)
- store_entry_point(scheme_hooks_high)
+\f
+define(builtin,"ADDIL L'$1-known_pc,3
+ .CALL ARGW0=GR
+ BL declare_builtin,2
+ LDO R'$1-known_pc(1),26")
+
+ builtin(scheme_to_interface_ble)
+ builtin(ep_scheme_hooks_low)
+ builtin(store_closure_entry)
+ builtin(store_closure_code)
+ builtin(multiply_fixnum)
+ builtin(fixnum_quotient)
+ builtin(fixnum_remainder)
+ builtin(fixnum_lsh)
+ builtin(flonum_result)
+ builtin(generic_boolean_result)
+ builtin(generic_decrement)
+ builtin(generic_divide)
+ builtin(generic_equal)
+ builtin(generic_greater)
+ builtin(generic_increment)
+ builtin(generic_less)
+ builtin(generic_subtract)
+ builtin(generic_times)
+ builtin(generic_negative)
+ builtin(generic_plus)
+ builtin(generic_positive)
+ builtin(generic_zero)
+ builtin(shortcircuit_apply)
+ builtin(shortcircuit_apply_1)
+ builtin(shortcircuit_apply_2)
+ builtin(shortcircuit_apply_3)
+ builtin(shortcircuit_apply_4)
+ builtin(shortcircuit_apply_5)
+ builtin(shortcircuit_apply_6)
+ builtin(shortcircuit_apply_7)
+ builtin(shortcircuit_apply_8)
+ builtin(stack_and_interrupt_check)
+ builtin(invoke_primitive)
+ builtin(vector_cons)
+ builtin(string_allocate)
+ builtin(floating_vector_cons)
+ builtin(flonum_sin)
+ builtin(flonum_cos)
+ builtin(flonum_tan)
+ builtin(flonum_asin)
+ builtin(flonum_acos)
+ builtin(flonum_atan)
+ builtin(flonum_exp)
+ builtin(flonum_log)
+ builtin(flonum_truncate)
+ builtin(flonum_ceiling)
+ builtin(flonum_floor)
+ builtin(flonum_atan2)
+ builtin(ep_scheme_hooks_high)
; Return
+ LDW -84(30),2 ; Restore return address
+ LDW -64(30),3 ; Restore gr3
BV 0(2)
.EXIT
- LDO -4(30),30 ; De-allocate stack slot
+ LDO -64(30),30 ; De-allocate stack frame
.PROCEND
\f
;;;; Routine to flush some locations from the processor cache.
.SPACE $TEXT$
.SUBSPA $CODE$
.IMPORT $$remI,MILLICODE
+ .IMPORT declare_builtin,CODE
.IMPORT sin,CODE
.IMPORT cos,CODE
.IMPORT tan,CODE
.EXPORT cache_flush_all,PRIV_LEV=3
.EXPORT ep_interface_to_C,PRIV_LEV=3
.EXPORT ep_interface_to_scheme,PRIV_LEV=3
- .EXPORT ep_scheme_hooks_low,PRIV_LEV=3
- .EXPORT ep_scheme_hooks_high,PRIV_LEV=3
.EXPORT flonum_atan2,PRIV_LEV=3
.END
/* -*-C-*-
-$Id: cmpint.c,v 1.58 1993/07/27 21:00:48 gjr Exp $
+$Id: cmpint.c,v 1.59 1993/07/29 07:02:47 gjr Exp $
Copyright (c) 1989-1993 Massachusetts Institute of Technology
UTE(comutil_apply_in_interpreter) /* 0x3a */
};
\f
+/* Support for trap handling. */
+
+static void
+DEFUN_VOID (end_of_utils)
+{
+ return;
+}
+
+struct util_descriptor_s
+{
+ PTR pc;
+ char * name;
+};
+
+#ifdef __STDC__
+# define UTLD(name) { ((PTR) name), #name }
+#else
+/* Hope that this works. */
+# define UTLD(name) { ((PTR) name), "name" }
+#endif
+
+static
+struct util_descriptor_s utility_descriptor_table[] =
+{
+ UTLD(C_to_interface),
+ UTLD(open_gap),
+ UTLD(setup_lexpr_invocation),
+ UTLD(setup_compiled_invocation),
+ UTLD(enter_compiled_expression),
+ UTLD(apply_compiled_procedure),
+ UTLD(return_to_compiled_code),
+ UTLD(apply_compiled_from_primitive),
+ UTLD(comutil_return_to_interpreter),
+ UTLD(comutil_apply_in_interpreter),
+ UTLD(comutil_primitive_apply),
+ UTLD(comutil_primitive_lexpr_apply),
+ UTLD(comutil_apply),
+ UTLD(comutil_error),
+ UTLD(comutil_lexpr_apply),
+ UTLD(abort_link_cc_block),
+ UTLD(link_cc_block),
+ UTLD(comutil_link),
+ UTLD(comp_link_caches_restart),
+ UTLD(comutil_operator_apply_trap),
+ UTLD(comutil_operator_arity_trap),
+ UTLD(comutil_operator_entity_trap),
+ UTLD(comutil_operator_interpreted_trap),
+ UTLD(comutil_operator_lexpr_trap),
+ UTLD(comutil_operator_primitive_trap),
+ UTLD(comutil_operator_lookup_trap),
+ UTLD(comp_op_lookup_trap_restart),
+ UTLD(comutil_operator_1_0_trap),
+ UTLD(comutil_operator_2_1_trap),
+ UTLD(comutil_operator_2_0_trap),
+ UTLD(comutil_operator_3_2_trap),
+ UTLD(comutil_operator_3_1_trap),
+ UTLD(comutil_operator_3_0_trap),
+ UTLD(comutil_operator_4_3_trap),
+ UTLD(comutil_operator_4_2_trap),
+ UTLD(comutil_operator_4_1_trap),
+ UTLD(comutil_operator_4_0_trap),
+ UTLD(compiler_interrupt_common),
+ UTLD(comutil_interrupt_closure),
+ UTLD(comutil_interrupt_dlink),
+ UTLD(comutil_interrupt_procedure),
+ UTLD(comutil_interrupt_continuation),
+ UTLD(comutil_interrupt_ic_procedure),
+ UTLD(comp_interrupt_restart),
+\f
+ UTLD(comutil_assignment_trap),
+ UTLD(comp_assignment_trap_restart),
+ UTLD(comutil_cache_lookup_apply),
+ UTLD(comp_cache_lookup_apply_restart),
+ UTLD(comutil_lookup_trap),
+ UTLD(comp_lookup_trap_restart),
+ UTLD(comutil_safe_lookup_trap),
+ UTLD(comp_safe_lookup_trap_restart),
+ UTLD(comutil_unassigned_p_trap),
+ UTLD(comp_unassigned_p_trap_restart),
+ UTLD(comutil_decrement),
+ UTLD(comutil_divide),
+ UTLD(comutil_equal),
+ UTLD(comutil_greater),
+ UTLD(comutil_increment),
+ UTLD(comutil_less),
+ UTLD(comutil_minus),
+ UTLD(comutil_modulo),
+ UTLD(comutil_multiply),
+ UTLD(comutil_negative),
+ UTLD(comutil_plus),
+ UTLD(comutil_positive),
+ UTLD(comutil_quotient),
+ UTLD(comutil_remainder),
+ UTLD(comutil_zero),
+ UTLD(comutil_access),
+ UTLD(comp_access_restart),
+ UTLD(comutil_reference),
+ UTLD(comp_reference_restart),
+ UTLD(comutil_safe_reference),
+ UTLD(comp_safe_reference_restart),
+ UTLD(comutil_unassigned_p),
+ UTLD(comp_unassigned_p_restart),
+ UTLD(comutil_unbound_p),
+ UTLD(comp_unbound_p_restart),
+ UTLD(comutil_assignment),
+ UTLD(comp_assignment_restart),
+ UTLD(comutil_definition),
+ UTLD(comp_definition_restart),
+ UTLD(comutil_lookup_apply),
+ UTLD(comp_lookup_apply_restart),
+ UTLD(comutil_primitive_error),
+ UTLD(comp_error_restart),
+ UTLD(compiled_block_debugging_info),
+ UTLD(compiled_block_environment),
+ UTLD(compiled_entry_to_block_address),
+ UTLD(compiled_entry_to_block),
+ UTLD(compiled_entry_to_block_offset),
+ UTLD(block_address_closure_p),
+ UTLD(compiled_block_closure_p),
+ UTLD(compiled_entry_closure_p),
+ UTLD(compiled_closure_to_entry),
+ UTLD(compiled_entry_type),
+ UTLD(store_variable_cache),
+ UTLD(extract_variable_cache),
+ UTLD(extract_uuo_link),
+ UTLD(store_uuo_link),
+ UTLD(fill_trampoline),
+ UTLD(make_trampoline),
+ UTLD(make_redirection_trampoline),
+ UTLD(make_apply_trampoline),
+ UTLD(make_uuo_link),
+ UTLD(make_fake_uuo_link),
+ UTLD(coerce_to_compiled),
+ UTLD(end_of_utils)
+};
+\f
+extern char * EXFUN (utility_index_to_name, (int));
+extern int EXFUN (pc_to_utility_index, (unsigned long));
+
+#define UTIL_TABLE_PC_REF_REAL(index) \
+ ((unsigned long) (utility_descriptor_table[index].pc))
+
+#ifndef UTIL_TABLE_PC_REF
+# define UTIL_TABLE_PC_REF(index) (UTIL_TABLE_PC_REF_REAL (index))
+#endif
+
+static int last_util_table_index =
+ (((sizeof (utility_descriptor_table)) / (sizeof (struct util_descriptor_s))) - 1);
+
+char *
+DEFUN (utility_index_to_name, (index), int index)
+{
+ if ((index < 0) || (index >= last_util_table_index))
+ return ((char *) NULL);
+ else
+ return (utility_descriptor_table[index].name);
+}
+
+int
+DEFUN (pc_to_utility_index, (pc), unsigned long pc)
+{
+ /* Binary search */
+
+ extern int EXFUN (pc_to_builtin_index, (unsigned long));
+
+ if ((pc < (UTIL_TABLE_PC_REF (0)))
+ || (pc >= (UTIL_TABLE_PC_REF (last_util_table_index))))
+ return (-1);
+ else if (pc < (UTIL_TABLE_PC_REF (1)))
+ return ((pc_to_builtin_index (pc)) ? -1 : 0);
+ else
+ {
+ int low, high, middle;
+
+ low = 0;
+ high = last_util_table_index;
+ while ((low + 1) < high)
+ {
+ middle = ((low + high) / 2);
+ if (pc < (UTIL_TABLE_PC_REF (middle)))
+ high = middle;
+ else if (pc > (UTIL_TABLE_PC_REF (middle)))
+ low = middle;
+ else
+ return (middle);
+ }
+ return ((pc == (UTIL_TABLE_PC_REF (high))) ? high : low);
+ }
+}
+\f
+extern void EXFUN (declare_builtin, (unsigned long));
+extern int EXFUN (pc_to_builtin_index, (unsigned long));
+extern unsigned long * builtins;
+
+static int n_builtins = 0;
+static int s_builtins = 0;
+unsigned long * builtins = ((unsigned long *) NULL);
+
+void
+DEFUN (declare_builtin, (builtin), unsigned long builtin)
+{
+ if (n_builtins == s_builtins)
+ {
+ if (s_builtins == 0)
+ {
+ s_builtins = 30;
+ builtins = ((unsigned long *)
+ (malloc (s_builtins * (sizeof (unsigned long)))));
+ }
+ else
+ {
+ s_builtins += s_builtins;
+ builtins = ((unsigned long *)
+ (realloc (builtins,
+ (s_builtins * (sizeof (unsigned long))))));
+ }
+ if (builtins == ((unsigned long *) NULL))
+ {
+ outf_fatal ("declare_builtin: malloc/realloc failed (size = %d).\n",
+ (s_builtins * (sizeof (unsigned long))));
+ termination_init_error ();
+ }
+ }
+ builtins[n_builtins++] = builtin;
+ return;
+}
+
+int
+DEFUN (pc_to_builtin_index, (pc), unsigned long pc)
+{
+ /* Binary search */
+
+ if ((builtins == ((unsigned long *) NULL))
+ || (pc < (builtins[0]))
+ || (pc >= (builtins[n_builtins - 1])))
+ return (-1);
+ else
+ {
+ int low, high, middle;
+
+ low = 0;
+ high = (n_builtins - 1);
+ while ((low + 1) < high)
+ {
+ middle = ((low + high) / 2);
+ if (pc < (builtins[middle]))
+ high = middle;
+ else if (pc > (builtins[middle]))
+ low = middle;
+ else
+ return (middle);
+ }
+ return ((pc == (builtins[high])) ? high : low);
+ }
+}
+\f
/* Initialization */
#define COMPILER_INTERFACE_VERSION 3
return (PRIM_DONE);
}
+extern char * EXFUN (utility_index_to_name, (int));
+extern void EXFUN (declare_builtin, (unsigned long));
+extern int EXFUN (pc_to_utility_index, (unsigned long));
+extern int EXFUN (pc_to_builtin_index, (unsigned long));
+
+char *
+DEFUN (utility_index_to_name, (index), int index)
+{
+ return ((char *) NULL);
+}
+
+void
+DEFUN (declare_builtin, (builtin), unsigned long builtin)
+{
+ return;
+}
+
+int
+DEFUN (pc_to_utility_index, (pc), unsigned long pc)
+{
+ return (-1);
+}
+
+int
+DEFUN (pc_to_builtin_index, (pc), unsigned long pc)
+{
+ return (-1);
+}
#endif /* HAS_COMPILER_SUPPORT */
\f
#ifdef WINNT
/* -*-C-*-
-$Id: hppa.h,v 1.42 1993/06/30 03:35:47 gjr Exp $
+$Id: hppa.h,v 1.43 1993/07/29 07:02:09 gjr Exp $
Copyright (c) 1989-1993 Massachusetts Institute of Technology
*/
-/* A NOP on machines where instructions are longword-aligned. */
-
-#define ADJUST_CLOSURE_AT_CALL(entry_point, location) do \
-{ \
-} while (0)
-
/* Compiled closures */
/* Manifest closure entry block size.
return off.value;
}
+static unsigned long
+DEFUN (C_closure_entry_point, (closure), unsigned long C_closure)
+{
+ if ((C_closure & 0x3) == 0x2)
+ {
+ long offset;
+ char * blp = (* ((char **) (C_closure - 2)));
+
+ blp = ((char *) (((unsigned long) blp) & ~3));
+ offset = (assemble_17 (* ((union ble_inst *) blp)));
+ return ((unsigned long) ((blp + 8) + offset));
+ }
+ else
+ return (C_closure);
+}
+
PTR *
DEFUN (transform_procedure_table, (table_length, old_table),
long table_length AND PTR * old_table)
}
for (counter = 0; counter < table_length; counter++)
- {
- char * C_closure = ((char *) (old_table [counter]));
- if ((((unsigned long) C_closure) & 0x3) == 0x2)
- {
- long offset;
- char * blp = (* ((char **) (C_closure - 2)));
- blp = ((char *) (((unsigned long) blp) & ~3));
- offset = (assemble_17 (* ((union ble_inst *) blp)));
- new_table[counter] = ((PTR) ((blp + 8) + offset));
- }
- else
- new_table[counter] = ((PTR) (old_table [counter]));
- }
+ new_table[counter] =
+ ((PTR) (C_closure_entry_point ((unsigned long) (old_table [counter]))));
return (new_table);
}
+
+#define UTIL_TABLE_PC_REF(index) \
+ (C_closure_entry_point (UTIL_TABLE_PC_REF_REAL (index)))
\f
#ifdef _BSD4_3
# include <sys/mman.h>
long utility_length AND PTR * utility_table
AND long primitive_length AND PTR * primitive_table)
{
- extern void
- EXFUN (interface_initialize, (void));
+ extern void EXFUN (interface_initialize, (void));
flush_i_cache_initialize ();
interface_initialize ();
/* -*-C-*-
-$Id: comutl.c,v 1.22 1993/06/09 20:34:39 jawilson Exp $
+$Id: comutl.c,v 1.23 1993/07/29 07:02:50 gjr Exp $
Copyright (c) 1987-1993 Massachusetts Institute of Technology
PRIMITIVE_RETURN (compiled_closure_to_entry (closure));
}
\f
+DEFINE_PRIMITIVE ("UTILITY-INDEX->NAME", Prim_utility_index_to_name, 1, 1,
+ "Given an integer, return the name of the corresponding compiled code utility.")
+{
+ extern char * EXFUN (utility_index_to_name, (int));
+ char * result;
+ PRIMITIVE_HEADER (1);
+
+ result = (utility_index_to_name (arg_integer (1)));
+ if (result == ((char *) NULL))
+ PRIMITIVE_RETURN (SHARP_F);
+ else
+ PRIMITIVE_RETURN (char_pointer_to_string ((unsigned char *) result));
+}
+
/* This is only meaningful for the C back end. */
DEFINE_PRIMITIVE ("INITIALIZE-C-COMPILED-BLOCK", Prim_initialize_C_compiled_block, 1, 1,
/* -*-C-*-
-$Id: ymkfile,v 1.70 1993/06/24 22:26:22 gjr Exp $
+$Id: ymkfile,v 1.71 1993/07/29 07:01:26 gjr Exp $
Copyright (c) 1989-1993 Massachusetts Institute of Technology
#if (PROC_TYPE == PROC_TYPE_VAX)
#define PROC_TYPE_KNOWN
MACHINE_SWITCHES =
-MACHINE_SOURCES = cmpint.c cmpauxmd.m4
-MACHINE_OBJECTS = cmpint.o cmpauxmd.o
+MACHINE_SOURCES = cmpauxmd.m4 cmpint.c
+MACHINE_OBJECTS = cmpauxmd.o cmpint.o
GC_HEAD_FILES = gccode.h cmpgc.h cmpintmd.h
cmpauxmd.o : cmpauxmd.s
#define PROC_TYPE_KNOWN
#undef hppa
MACHINE_SWITCHES =
-MACHINE_SOURCES = cmpint.c cmpauxmd.m4
-MACHINE_OBJECTS = cmpint.o cmpauxmd.o
+MACHINE_SOURCES = cmpauxmd.m4 cmpint.c
+MACHINE_OBJECTS = cmpauxmd.o cmpint.o
GC_HEAD_FILES = gccode.h cmpgc.h cmpintmd.h hppacach.h
XTRA_TARGETS = hppacach
#define PROC_TYPE_KNOWN
#undef mips
MACHINE_SWITCHES =
-MACHINE_SOURCES = cmpint.c cmpauxmd.m4
-MACHINE_OBJECTS = cmpint.o cmpauxmd.o
+MACHINE_SOURCES = cmpauxmd.m4 cmpint.c
+MACHINE_OBJECTS = cmpauxmd.o cmpint.o
GC_HEAD_FILES = gccode.h cmpgc.h cmpintmd.h
cmpauxmd.o : cmpauxmd.s
#define PROC_TYPE_KNOWN
#undef i386
MACHINE_SWITCHES =
-MACHINE_SOURCES = cmpint.c cmpauxmd.m4
-MACHINE_OBJECTS = cmpint.o cmpauxmd.o
+MACHINE_SOURCES = cmpauxmd.m4 cmpint.c
+MACHINE_OBJECTS = cmpauxmd.o cmpint.o
GC_HEAD_FILES = gccode.h cmpgc.h cmpintmd.h
cmpauxmd.o : cmpauxmd.s
#if (PROC_TYPE == PROC_TYPE_ALPHA)
#define PROC_TYPE_KNOWN
MACHINE_SWITCHES =
-MACHINE_SOURCES = cmpint.c cmpauxmd.m4
-MACHINE_OBJECTS = cmpint.o cmpauxmd.o
+MACHINE_SOURCES = cmpauxmd.m4 cmpint.c
+MACHINE_OBJECTS = cmpauxmd.o cmpint.o
GC_HEAD_FILES = gccode.h cmpgc.h cmpintmd.h
cmpauxmd.o : cmpauxmd.s
COMPILED_OBJECTS = $(COMPILED_SOURCES:.c=.o)
MACHINE_SWITCHES = -DNATIVE_CODE_IS_C
-MACHINE_SOURCES = cmpint.c cmpauxmd.c compinit.c $(COMPILED_SOURCES)
-MACHINE_OBJECTS = cmpint.o cmpauxmd.o compinit.o $(COMPILED_OBJECTS)
+MACHINE_SOURCES = cmpauxmd.c cmpint.c compinit.c $(COMPILED_SOURCES)
+MACHINE_OBJECTS = cmpauxmd.o cmpint.o compinit.o $(COMPILED_OBJECTS)
GC_HEAD_FILES = gccode.h cmpgc.h cmpintmd.h
LIARC_HEAD_FILES = \
ansidecl.h \
/* -*-C-*-
-$Id: uxtrap.c,v 1.21 1993/03/16 21:36:10 gjr Exp $
+$Id: uxtrap.c,v 1.22 1993/07/29 07:02:51 gjr Exp $
Copyright (c) 1990-1993 Massachusetts Institute of Technology
#if !(defined (_HPUX) && (_HPUX_VERSION >= 80) && defined (hp9000s300))
extern long etext;
#endif
-#define get_etext() (&etext)
+# define get_etext() (&etext)
#endif
-
+\f
static void
DEFUN (continue_from_trap, (signo, info, scp),
int signo AND
SIGINFO_T info AND
struct FULL_SIGCONTEXT * scp)
{
- int pc_in_hook;
+ 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));
SCHEME_OBJECT * new_stack_pointer;
SCHEME_OBJECT * xtra_info;
struct trap_recovery_info trinfo;
-
-#if FALSE
- fprintf (stderr, "\ncontinue_from_trap:");
- fprintf (stderr, "\tpc = 0x%08lx\n", the_pc);
- fprintf (stderr, "\tCsp = 0x%08lx\n", C_sp);
- fprintf (stderr, "\tssp = 0x%08lx\n", scheme_sp);
- fprintf (stderr, "\tesp = 0x%08lx\n", Ext_Stack_Pointer);
-#ifdef hp9000s800
- {
- fprintf (stderr, "\tscheme_hooks_low = 0x%08lx\n", scheme_hooks_low);
- fprintf (stderr, "\tscheme_hooks_high = 0x%08lx\n", scheme_hooks_high);
- }
-#endif
-#endif
+ 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_hook = 0;
+ pc_in_builtin = 0;
+ pc_in_utility = 0;
pc_in_C = 0;
pc_in_heap = 0;
pc_in_constant_space = 0;
}
else
{
- pc_in_hook = (PC_HOOK_P (the_pc));
- pc_in_C = ((the_pc <= ((long) (get_etext ()))) && (!pc_in_hook));
+ 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 =
((the_pc < ((long) Heap_Top)) && (the_pc >= ((long) Heap_Bottom)));
pc_in_constant_space =
((the_pc < ((long) Constant_Top)) &&
(the_pc >= ((long) Constant_Space)));
- pc_in_scheme = (pc_in_heap || pc_in_constant_space || pc_in_hook);
+ pc_in_scheme = (pc_in_heap || pc_in_constant_space || pc_in_builtin);
pc_in_hyper_space = ((!pc_in_C) && (!pc_in_scheme));
}
&& (Stack_Pointer > Absolute_Stack_Base))
? Stack_Pointer
: ((SCHEME_OBJECT *) 0));
-
+\f
if (pc_in_hyper_space || (pc_in_scheme && ALLOW_ONLY_C))
{
/* In hyper space. */
if ((Free < MemTop) ||
(Free >= Heap_Top) ||
((((unsigned long) Free) & SCHEME_ALIGNMENT_MASK) != 0))
- {
Free = MemTop;
- }
}
else if (pc_in_scheme)
{
SCHEME_OBJECT * block_addr;
SCHEME_OBJECT * maybe_free;
block_addr =
- (pc_in_hook
+ (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_PROBABLY_COMPILED;
- (trinfo . pc_info_1) = (LONG_TO_UNSIGNED_FIXNUM (the_pc));
- (trinfo . pc_info_2) = SHARP_F;
- }
- else
+ if (block_addr != ((SCHEME_OBJECT *) NULL))
{
(trinfo . state) = STATE_COMPILED_CODE;
(trinfo . pc_info_1) =
(trinfo . pc_info_2) =
(LONG_TO_UNSIGNED_FIXNUM (the_pc - ((long) block_addr)));
}
- if ((block_addr == ((SCHEME_OBJECT *) NULL))
- && (! pc_in_hook))
+ else if (pc_in_builtin)
+ {
+ (trinfo . state) = STATE_PROBABLY_COMPILED;
+ (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) ||
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
+\f
+ else /* pc_in_C */
{
/* In the interpreter, a primitive, or a compiled code utility. */
SCHEME_OBJECT primitive = (Regs[REGBLOCK_PRIMITIVE]);
- if ((OBJECT_TYPE (primitive)) != TC_PRIMITIVE)
+ if (pc_in_utility)
+ {
+ (trinfo . state) = STATE_PROBABLY_COMPILED;
+ (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;
|| ((((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);
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);
}
\f
/* -*-C-*-
-$Id: uxtrap.h,v 1.19 1993/03/16 21:36:16 gjr Exp $
+$Id: uxtrap.h,v 1.20 1993/07/29 07:02:52 gjr Exp $
Copyright (c) 1990-1993 Massachusetts Institute of Technology
#define PC_VALUE_MASK ((~0) << 2)
-/* Pseudo-compiled code in assembly language. */
-
-extern void * scheme_hooks_low, * scheme_hooks_high;
-#define PC_HOOK_P(pc) \
- ((((void *) (pc)) >= scheme_hooks_low) \
- && (((void *) (pc)) < scheme_hooks_high))
-
/* pcoq is the offset (32 bit in 64 bit virtual address space)
in the space included in the corresponding sc_pcsq.
head is the current instruction, tail is the next instruction
#ifndef INITIALIZE_UX_SIGNAL_CODES
#define INITIALIZE_UX_SIGNAL_CODES()
#endif
-
-#ifndef PC_HOOK_P
-#define PC_HOOK_P(pc) 0
-#endif
\f
enum trap_state
{
changecom(`;');;; -*-Midas-*-
;;;
-;;; $Id: hppa.m4,v 1.28 1993/07/27 17:47:34 gjr Exp $
+;;; $Id: hppa.m4,v 1.29 1993/07/29 07:02:17 gjr Exp $
;;;
;;; Copyright (c) 1989-1993 Massachusetts Institute of Technology
;;;
B scheme_to_interface
LDI HEX($2),28 ; operation code")
+flonum_result
unary_flonum_result
ADDI,TR 4,22,6 ; ret. add. location
interface_initialize
.PROC
- .CALLINFO CALLER,FRAME=0
+ .CALLINFO CALLER,FRAME=4,SAVE_RP
.ENTRY
- LDO 4(30),30 ; Allocate stack slot
- FSTWS 0,0(30)
- LDW 0(30),22
+ STW 2,-20(0,30) ; Preserve return address
+ LDO 64(30),30 ; Allocate stack frame
+ STW 3,-64(30) ; Preserve gr3
+ FSTWS 0,-4(30)
+ LDW -4(30),22
LDI 30,21 ; enable V, Z, O, U traps
OR 21,22,22
- STW 22,0(30)
- FLDWS 0(30),0
+ STW 22,-4(30)
+ FLDWS -4(30),0
; Prepare entry points
- BL known_pc,28 ; get pc
+ BL known_pc,3 ; get pc
NOP
known_pc
-define(store_entry_point,"ADDIL L'ep_$1-known_pc,28
+define(store_entry_point,"ADDIL L'ep_$1-known_pc,3
LDO R'ep_$1-known_pc(1),29
ADDIL L'$1-$global$,27
STW 29,R'$1-$global$(1)")
store_entry_point(interface_to_scheme)
store_entry_point(interface_to_C)
- store_entry_point(scheme_hooks_low)
- store_entry_point(scheme_hooks_high)
+\f
+define(builtin,"ADDIL L'$1-known_pc,3
+ .CALL ARGW0=GR
+ BL declare_builtin,2
+ LDO R'$1-known_pc(1),26")
+
+ builtin(scheme_to_interface_ble)
+ builtin(ep_scheme_hooks_low)
+ builtin(store_closure_entry)
+ builtin(store_closure_code)
+ builtin(multiply_fixnum)
+ builtin(fixnum_quotient)
+ builtin(fixnum_remainder)
+ builtin(fixnum_lsh)
+ builtin(flonum_result)
+ builtin(generic_boolean_result)
+ builtin(generic_decrement)
+ builtin(generic_divide)
+ builtin(generic_equal)
+ builtin(generic_greater)
+ builtin(generic_increment)
+ builtin(generic_less)
+ builtin(generic_subtract)
+ builtin(generic_times)
+ builtin(generic_negative)
+ builtin(generic_plus)
+ builtin(generic_positive)
+ builtin(generic_zero)
+ builtin(shortcircuit_apply)
+ builtin(shortcircuit_apply_1)
+ builtin(shortcircuit_apply_2)
+ builtin(shortcircuit_apply_3)
+ builtin(shortcircuit_apply_4)
+ builtin(shortcircuit_apply_5)
+ builtin(shortcircuit_apply_6)
+ builtin(shortcircuit_apply_7)
+ builtin(shortcircuit_apply_8)
+ builtin(stack_and_interrupt_check)
+ builtin(invoke_primitive)
+ builtin(vector_cons)
+ builtin(string_allocate)
+ builtin(floating_vector_cons)
+ builtin(flonum_sin)
+ builtin(flonum_cos)
+ builtin(flonum_tan)
+ builtin(flonum_asin)
+ builtin(flonum_acos)
+ builtin(flonum_atan)
+ builtin(flonum_exp)
+ builtin(flonum_log)
+ builtin(flonum_truncate)
+ builtin(flonum_ceiling)
+ builtin(flonum_floor)
+ builtin(flonum_atan2)
+ builtin(ep_scheme_hooks_high)
; Return
+ LDW -84(30),2 ; Restore return address
+ LDW -64(30),3 ; Restore gr3
BV 0(2)
.EXIT
- LDO -4(30),30 ; De-allocate stack slot
+ LDO -64(30),30 ; De-allocate stack frame
.PROCEND
\f
;;;; Routine to flush some locations from the processor cache.
.SPACE $TEXT$
.SUBSPA $CODE$
.IMPORT $$remI,MILLICODE
+ .IMPORT declare_builtin,CODE
.IMPORT sin,CODE
.IMPORT cos,CODE
.IMPORT tan,CODE
.EXPORT cache_flush_all,PRIV_LEV=3
.EXPORT ep_interface_to_C,PRIV_LEV=3
.EXPORT ep_interface_to_scheme,PRIV_LEV=3
- .EXPORT ep_scheme_hooks_low,PRIV_LEV=3
- .EXPORT ep_scheme_hooks_high,PRIV_LEV=3
.EXPORT flonum_atan2,PRIV_LEV=3
.END
/* -*-C-*-
-$Id: cmpint.c,v 1.58 1993/07/27 21:00:48 gjr Exp $
+$Id: cmpint.c,v 1.59 1993/07/29 07:02:47 gjr Exp $
Copyright (c) 1989-1993 Massachusetts Institute of Technology
UTE(comutil_apply_in_interpreter) /* 0x3a */
};
\f
+/* Support for trap handling. */
+
+static void
+DEFUN_VOID (end_of_utils)
+{
+ return;
+}
+
+struct util_descriptor_s
+{
+ PTR pc;
+ char * name;
+};
+
+#ifdef __STDC__
+# define UTLD(name) { ((PTR) name), #name }
+#else
+/* Hope that this works. */
+# define UTLD(name) { ((PTR) name), "name" }
+#endif
+
+static
+struct util_descriptor_s utility_descriptor_table[] =
+{
+ UTLD(C_to_interface),
+ UTLD(open_gap),
+ UTLD(setup_lexpr_invocation),
+ UTLD(setup_compiled_invocation),
+ UTLD(enter_compiled_expression),
+ UTLD(apply_compiled_procedure),
+ UTLD(return_to_compiled_code),
+ UTLD(apply_compiled_from_primitive),
+ UTLD(comutil_return_to_interpreter),
+ UTLD(comutil_apply_in_interpreter),
+ UTLD(comutil_primitive_apply),
+ UTLD(comutil_primitive_lexpr_apply),
+ UTLD(comutil_apply),
+ UTLD(comutil_error),
+ UTLD(comutil_lexpr_apply),
+ UTLD(abort_link_cc_block),
+ UTLD(link_cc_block),
+ UTLD(comutil_link),
+ UTLD(comp_link_caches_restart),
+ UTLD(comutil_operator_apply_trap),
+ UTLD(comutil_operator_arity_trap),
+ UTLD(comutil_operator_entity_trap),
+ UTLD(comutil_operator_interpreted_trap),
+ UTLD(comutil_operator_lexpr_trap),
+ UTLD(comutil_operator_primitive_trap),
+ UTLD(comutil_operator_lookup_trap),
+ UTLD(comp_op_lookup_trap_restart),
+ UTLD(comutil_operator_1_0_trap),
+ UTLD(comutil_operator_2_1_trap),
+ UTLD(comutil_operator_2_0_trap),
+ UTLD(comutil_operator_3_2_trap),
+ UTLD(comutil_operator_3_1_trap),
+ UTLD(comutil_operator_3_0_trap),
+ UTLD(comutil_operator_4_3_trap),
+ UTLD(comutil_operator_4_2_trap),
+ UTLD(comutil_operator_4_1_trap),
+ UTLD(comutil_operator_4_0_trap),
+ UTLD(compiler_interrupt_common),
+ UTLD(comutil_interrupt_closure),
+ UTLD(comutil_interrupt_dlink),
+ UTLD(comutil_interrupt_procedure),
+ UTLD(comutil_interrupt_continuation),
+ UTLD(comutil_interrupt_ic_procedure),
+ UTLD(comp_interrupt_restart),
+\f
+ UTLD(comutil_assignment_trap),
+ UTLD(comp_assignment_trap_restart),
+ UTLD(comutil_cache_lookup_apply),
+ UTLD(comp_cache_lookup_apply_restart),
+ UTLD(comutil_lookup_trap),
+ UTLD(comp_lookup_trap_restart),
+ UTLD(comutil_safe_lookup_trap),
+ UTLD(comp_safe_lookup_trap_restart),
+ UTLD(comutil_unassigned_p_trap),
+ UTLD(comp_unassigned_p_trap_restart),
+ UTLD(comutil_decrement),
+ UTLD(comutil_divide),
+ UTLD(comutil_equal),
+ UTLD(comutil_greater),
+ UTLD(comutil_increment),
+ UTLD(comutil_less),
+ UTLD(comutil_minus),
+ UTLD(comutil_modulo),
+ UTLD(comutil_multiply),
+ UTLD(comutil_negative),
+ UTLD(comutil_plus),
+ UTLD(comutil_positive),
+ UTLD(comutil_quotient),
+ UTLD(comutil_remainder),
+ UTLD(comutil_zero),
+ UTLD(comutil_access),
+ UTLD(comp_access_restart),
+ UTLD(comutil_reference),
+ UTLD(comp_reference_restart),
+ UTLD(comutil_safe_reference),
+ UTLD(comp_safe_reference_restart),
+ UTLD(comutil_unassigned_p),
+ UTLD(comp_unassigned_p_restart),
+ UTLD(comutil_unbound_p),
+ UTLD(comp_unbound_p_restart),
+ UTLD(comutil_assignment),
+ UTLD(comp_assignment_restart),
+ UTLD(comutil_definition),
+ UTLD(comp_definition_restart),
+ UTLD(comutil_lookup_apply),
+ UTLD(comp_lookup_apply_restart),
+ UTLD(comutil_primitive_error),
+ UTLD(comp_error_restart),
+ UTLD(compiled_block_debugging_info),
+ UTLD(compiled_block_environment),
+ UTLD(compiled_entry_to_block_address),
+ UTLD(compiled_entry_to_block),
+ UTLD(compiled_entry_to_block_offset),
+ UTLD(block_address_closure_p),
+ UTLD(compiled_block_closure_p),
+ UTLD(compiled_entry_closure_p),
+ UTLD(compiled_closure_to_entry),
+ UTLD(compiled_entry_type),
+ UTLD(store_variable_cache),
+ UTLD(extract_variable_cache),
+ UTLD(extract_uuo_link),
+ UTLD(store_uuo_link),
+ UTLD(fill_trampoline),
+ UTLD(make_trampoline),
+ UTLD(make_redirection_trampoline),
+ UTLD(make_apply_trampoline),
+ UTLD(make_uuo_link),
+ UTLD(make_fake_uuo_link),
+ UTLD(coerce_to_compiled),
+ UTLD(end_of_utils)
+};
+\f
+extern char * EXFUN (utility_index_to_name, (int));
+extern int EXFUN (pc_to_utility_index, (unsigned long));
+
+#define UTIL_TABLE_PC_REF_REAL(index) \
+ ((unsigned long) (utility_descriptor_table[index].pc))
+
+#ifndef UTIL_TABLE_PC_REF
+# define UTIL_TABLE_PC_REF(index) (UTIL_TABLE_PC_REF_REAL (index))
+#endif
+
+static int last_util_table_index =
+ (((sizeof (utility_descriptor_table)) / (sizeof (struct util_descriptor_s))) - 1);
+
+char *
+DEFUN (utility_index_to_name, (index), int index)
+{
+ if ((index < 0) || (index >= last_util_table_index))
+ return ((char *) NULL);
+ else
+ return (utility_descriptor_table[index].name);
+}
+
+int
+DEFUN (pc_to_utility_index, (pc), unsigned long pc)
+{
+ /* Binary search */
+
+ extern int EXFUN (pc_to_builtin_index, (unsigned long));
+
+ if ((pc < (UTIL_TABLE_PC_REF (0)))
+ || (pc >= (UTIL_TABLE_PC_REF (last_util_table_index))))
+ return (-1);
+ else if (pc < (UTIL_TABLE_PC_REF (1)))
+ return ((pc_to_builtin_index (pc)) ? -1 : 0);
+ else
+ {
+ int low, high, middle;
+
+ low = 0;
+ high = last_util_table_index;
+ while ((low + 1) < high)
+ {
+ middle = ((low + high) / 2);
+ if (pc < (UTIL_TABLE_PC_REF (middle)))
+ high = middle;
+ else if (pc > (UTIL_TABLE_PC_REF (middle)))
+ low = middle;
+ else
+ return (middle);
+ }
+ return ((pc == (UTIL_TABLE_PC_REF (high))) ? high : low);
+ }
+}
+\f
+extern void EXFUN (declare_builtin, (unsigned long));
+extern int EXFUN (pc_to_builtin_index, (unsigned long));
+extern unsigned long * builtins;
+
+static int n_builtins = 0;
+static int s_builtins = 0;
+unsigned long * builtins = ((unsigned long *) NULL);
+
+void
+DEFUN (declare_builtin, (builtin), unsigned long builtin)
+{
+ if (n_builtins == s_builtins)
+ {
+ if (s_builtins == 0)
+ {
+ s_builtins = 30;
+ builtins = ((unsigned long *)
+ (malloc (s_builtins * (sizeof (unsigned long)))));
+ }
+ else
+ {
+ s_builtins += s_builtins;
+ builtins = ((unsigned long *)
+ (realloc (builtins,
+ (s_builtins * (sizeof (unsigned long))))));
+ }
+ if (builtins == ((unsigned long *) NULL))
+ {
+ outf_fatal ("declare_builtin: malloc/realloc failed (size = %d).\n",
+ (s_builtins * (sizeof (unsigned long))));
+ termination_init_error ();
+ }
+ }
+ builtins[n_builtins++] = builtin;
+ return;
+}
+
+int
+DEFUN (pc_to_builtin_index, (pc), unsigned long pc)
+{
+ /* Binary search */
+
+ if ((builtins == ((unsigned long *) NULL))
+ || (pc < (builtins[0]))
+ || (pc >= (builtins[n_builtins - 1])))
+ return (-1);
+ else
+ {
+ int low, high, middle;
+
+ low = 0;
+ high = (n_builtins - 1);
+ while ((low + 1) < high)
+ {
+ middle = ((low + high) / 2);
+ if (pc < (builtins[middle]))
+ high = middle;
+ else if (pc > (builtins[middle]))
+ low = middle;
+ else
+ return (middle);
+ }
+ return ((pc == (builtins[high])) ? high : low);
+ }
+}
+\f
/* Initialization */
#define COMPILER_INTERFACE_VERSION 3
return (PRIM_DONE);
}
+extern char * EXFUN (utility_index_to_name, (int));
+extern void EXFUN (declare_builtin, (unsigned long));
+extern int EXFUN (pc_to_utility_index, (unsigned long));
+extern int EXFUN (pc_to_builtin_index, (unsigned long));
+
+char *
+DEFUN (utility_index_to_name, (index), int index)
+{
+ return ((char *) NULL);
+}
+
+void
+DEFUN (declare_builtin, (builtin), unsigned long builtin)
+{
+ return;
+}
+
+int
+DEFUN (pc_to_utility_index, (pc), unsigned long pc)
+{
+ return (-1);
+}
+
+int
+DEFUN (pc_to_builtin_index, (pc), unsigned long pc)
+{
+ return (-1);
+}
#endif /* HAS_COMPILER_SUPPORT */
\f
#ifdef WINNT
/* -*-C-*-
-$Id: hppa.h,v 1.42 1993/06/30 03:35:47 gjr Exp $
+$Id: hppa.h,v 1.43 1993/07/29 07:02:09 gjr Exp $
Copyright (c) 1989-1993 Massachusetts Institute of Technology
*/
-/* A NOP on machines where instructions are longword-aligned. */
-
-#define ADJUST_CLOSURE_AT_CALL(entry_point, location) do \
-{ \
-} while (0)
-
/* Compiled closures */
/* Manifest closure entry block size.
return off.value;
}
+static unsigned long
+DEFUN (C_closure_entry_point, (closure), unsigned long C_closure)
+{
+ if ((C_closure & 0x3) == 0x2)
+ {
+ long offset;
+ char * blp = (* ((char **) (C_closure - 2)));
+
+ blp = ((char *) (((unsigned long) blp) & ~3));
+ offset = (assemble_17 (* ((union ble_inst *) blp)));
+ return ((unsigned long) ((blp + 8) + offset));
+ }
+ else
+ return (C_closure);
+}
+
PTR *
DEFUN (transform_procedure_table, (table_length, old_table),
long table_length AND PTR * old_table)
}
for (counter = 0; counter < table_length; counter++)
- {
- char * C_closure = ((char *) (old_table [counter]));
- if ((((unsigned long) C_closure) & 0x3) == 0x2)
- {
- long offset;
- char * blp = (* ((char **) (C_closure - 2)));
- blp = ((char *) (((unsigned long) blp) & ~3));
- offset = (assemble_17 (* ((union ble_inst *) blp)));
- new_table[counter] = ((PTR) ((blp + 8) + offset));
- }
- else
- new_table[counter] = ((PTR) (old_table [counter]));
- }
+ new_table[counter] =
+ ((PTR) (C_closure_entry_point ((unsigned long) (old_table [counter]))));
return (new_table);
}
+
+#define UTIL_TABLE_PC_REF(index) \
+ (C_closure_entry_point (UTIL_TABLE_PC_REF_REAL (index)))
\f
#ifdef _BSD4_3
# include <sys/mman.h>
long utility_length AND PTR * utility_table
AND long primitive_length AND PTR * primitive_table)
{
- extern void
- EXFUN (interface_initialize, (void));
+ extern void EXFUN (interface_initialize, (void));
flush_i_cache_initialize ();
interface_initialize ();
projects / mit-scheme.git / commitdiff