/* -*-C-*-
-$Id: cmpint.c,v 1.67 1993/09/07 21:45:53 gjr Exp $
+$Id: cmpint.c,v 1.68 1993/09/11 02:45:46 gjr Exp $
Copyright (c) 1989-1993 Massachusetts Institute of Technology
#include "trap.h" /* UNASSIGNED_OBJECT, TRAP_EXTENSION_TYPE */
#include "prims.h" /* LEXPR */
#include "prim.h" /* Primitive_Procedure_Table, etc. */
+
+#define ENTRY_TO_OBJECT(entry) \
+ (MAKE_POINTER_OBJECT (TC_COMPILED_ENTRY, ((SCHEME_OBJECT *) (entry))))
+
#define IN_CMPINT_C
#include "cmpgc.h" /* Compiled code object relocation */
} \
}
-#define ENTRY_TO_OBJECT(entry) \
- (MAKE_POINTER_OBJECT (TC_COMPILED_ENTRY, ((SCHEME_OBJECT *) (entry))))
-
#define MAKE_CC_BLOCK(block_addr) \
(MAKE_POINTER_OBJECT (TC_COMPILED_CODE_BLOCK, block_addr))
EXFUN (compiled_closure_to_entry, (SCHEME_OBJECT entry)),
* EXFUN (compiled_entry_to_block_address, (SCHEME_OBJECT entry)),
EXFUN (compiled_entry_to_block, (SCHEME_OBJECT entry)),
- EXFUN (apply_compiled_from_primitive, (int));
+ EXFUN (apply_compiled_from_primitive, (int)),
+ EXFUN (compiled_with_interrupt_mask, (unsigned long,
+ SCHEME_OBJECT,
+ unsigned long)),
+ EXFUN (compiled_with_stack_marker, (SCHEME_OBJECT));
extern C_UTILITY void
EXFUN (compiler_initialize, (long fasl_p)),
extern utility_table_entry utility_table[];
-static SCHEME_OBJECT apply_in_interpreter;
+static SCHEME_OBJECT reflect_to_interface;
+
+/* Breakpoint stuff. */
+
+extern C_UTILITY SCHEME_OBJECT EXFUN (bkpt_install, (PTR));
+extern C_UTILITY SCHEME_OBJECT EXFUN (bkpt_closure_install, (PTR));
+extern C_UTILITY Boolean EXFUN (bkpt_p, (PTR));
+extern C_UTILITY SCHEME_OBJECT EXFUN (bkpt_proceed, (PTR, SCHEME_OBJECT, SCHEME_OBJECT));
+extern C_UTILITY void EXFUN (bkpt_remove, (PTR, SCHEME_OBJECT));
\f
/* These definitions reflect the indices into the table above. */
#define TRAMPOLINE_K_4_2 0xf
#define TRAMPOLINE_K_4_1 0x10
#define TRAMPOLINE_K_4_0 0x11
-#define TRAMPOLINE_K_APPLY_IN_INTERPRETER 0x3a
+#define TRAMPOLINE_K_REFLECT_TO_INTERFACE 0x3a
#define TRAMPOLINE_K_OTHER TRAMPOLINE_K_INTERPRETED
+#define REFLECT_CODE_INTERNAL_APPLY 0
+#define REFLECT_CODE_RESTORE_INTERRUPT_MASK 1
+#define REFLECT_CODE_STACK_MARKER 2
+#define REFLECT_CODE_CC_BKPT 3
+\f
/* Utilities for application of compiled procedures. */
/* NOTE: In this file, the number of arguments (or minimum
*/
return (setup_lexpr_invocation (nactuals, nmax, compiled_entry_address));
}
-\f
-
-
\f
/* Main compiled code entry points.
break;
}
- STACK_PUSH (apply_in_interpreter);
+ STACK_PUSH (FIXNUM_ZERO + REFLECT_CODE_INTERNAL_APPLY);
+ STACK_PUSH (reflect_to_interface);
Stack_Pointer = (STACK_LOC (- arity));
return (SHARP_F);
}
\f
+C_UTILITY SCHEME_OBJECT
+DEFUN (compiled_with_interrupt_mask, (old_mask, receiver, new_mask),
+ unsigned long old_mask
+ AND SCHEME_OBJECT receiver
+ AND unsigned long new_mask)
+{
+ long result;
+
+ STACK_PUSH (LONG_TO_FIXNUM (old_mask));
+ STACK_PUSH (FIXNUM_ZERO + REFLECT_CODE_RESTORE_INTERRUPT_MASK);
+ STACK_PUSH (reflect_to_interface);
+
+ STACK_PUSH (LONG_TO_FIXNUM (new_mask));
+ result = (setup_compiled_invocation (2,
+ ((instruction *)
+ (OBJECT_ADDRESS (receiver)))));
+ STACK_PUSH (receiver);
+
+ if (result != PRIM_DONE)
+ {
+ STACK_PUSH (STACK_FRAME_HEADER + 1);
+ STACK_PUSH (FIXNUM_ZERO + REFLECT_CODE_INTERNAL_APPLY);
+ STACK_PUSH (reflect_to_interface);
+ }
+
+ Stack_Pointer = (STACK_LOC (- 2));
+ return (SHARP_F);
+}
+
+C_UTILITY SCHEME_OBJECT
+DEFUN (compiled_with_stack_marker, (thunk), SCHEME_OBJECT thunk)
+{
+ long result;
+
+ STACK_PUSH (FIXNUM_ZERO + REFLECT_CODE_STACK_MARKER);
+ STACK_PUSH (reflect_to_interface);
+
+ result = (setup_compiled_invocation (1,
+ ((instruction *)
+ (OBJECT_ADDRESS (thunk)))));
+ STACK_PUSH (thunk);
+
+ if (result != PRIM_DONE)
+ {
+ STACK_PUSH (STACK_FRAME_HEADER);
+ STACK_PUSH (FIXNUM_ZERO + REFLECT_CODE_INTERNAL_APPLY);
+ STACK_PUSH (reflect_to_interface);
+ }
+
+ Stack_Pointer = (STACK_LOC (- 3));
+ return (SHARP_F);
+}
+\f
/*
SCHEME_UTILITYs
{
RETURN_TO_C (PRIM_DONE);
}
-
-/*
- This is an alternate way for code to return to the
- Scheme interpreter.
- It is invoked by a trampoline, which passes the address of the
- trampoline storage block (empty) to it.
- */
-
-SCHEME_UTILITY utility_result
-DEFUN (comutil_apply_in_interpreter,
- (tramp_data_raw, ignore_2, ignore_3, ignore_4),
- SCHEME_ADDR tramp_data_raw
- AND long ignore_2 AND long ignore_3 AND long ignore_4)
-{
- RETURN_TO_C (PRIM_APPLY);
-}
\f
#if (COMPILER_PROCESSOR_TYPE != COMPILER_I386_TYPE)
field1 = min_arity;
field2 = max_arity;
if (min_arity >= 0)
- {
kind = KIND_PROCEDURE;
- }
else if (max_arity >= 0)
- {
kind = KIND_ILLEGAL;
- }
else if ((((unsigned long) max_arity) & 0xff) < 0xe0)
{
/* Field2 is the offset to the next continuation */
return (PRIM_DONE);
}
\f
+#ifndef HAVE_BKPT_SUPPORT
+
+C_UTILITY SCHEME_OBJECT
+DEFUN (bkpt_install, (ep), PTR ep)
+{
+ return (SHARP_F);
+}
+
+C_UTILITY SCHEME_OBJECT
+DEFUN (bkpt_closure_install, (ep), PTR ep)
+{
+ return (SHARP_F);
+}
+
+C_UTILITY void
+DEFUN (bkpt_remove, (ep, handle), PTR ep AND SCHEME_OBJECT handle)
+{
+ error_external_return ();
+}
+
+C_UTILITY Boolean
+DEFUN (bkpt_p, (ep), PTR ep)
+{
+ return (SHARP_F);
+}
+
+C_UTILITY SCHEME_OBJECT
+DEFUN (bkpt_proceed, (ep, handle, state),
+ PTR ep AND SCHEME_OBJECT handle AND SCHEME_OBJECT state)
+{
+ error_external_return ();
+}
+
+C_UTILITY PTR
+DEFUN_VOID (do_bkpt_proceed)
+{
+ error_external_return ();
+}
+
+#else /* HAVE_BKPT_SUPPORT */
+
+#define BKPT_PROCEED_FRAME_SIZE 3
+
+C_UTILITY SCHEME_OBJECT
+DEFUN (bkpt_proceed, (ep, handle, state),
+ PTR ep AND SCHEME_OBJECT handle AND SCHEME_OBJECT state)
+{
+ if ((! (COMPILED_CODE_ADDRESS_P (STACK_REF (BKPT_PROCEED_FRAME_SIZE))))
+ || ((OBJECT_ADDRESS (STACK_REF (BKPT_PROCEED_FRAME_SIZE)))
+ != ((SCHEME_OBJECT *) ep)))
+ error_external_return ();
+
+ STACK_PUSH (FIXNUM_ZERO + REFLECT_CODE_CC_BKPT);
+ STACK_PUSH (reflect_to_interface);
+ Stack_Pointer = (STACK_LOC (- BKPT_PROCEED_FRAME_SIZE));
+ return (SHARP_F);
+}
+#endif /* HAVE_BKPT_SUPPORT */
+\f
+SCHEME_UTILITY utility_result
+DEFUN (comutil_compiled_code_bkpt,
+ (entry_point_raw, dlink_raw, ignore_3, ignore_4),
+ SCHEME_ADDR entry_point_raw AND SCHEME_ADDR dlink_raw
+ AND long ignore_3 AND long ignore_4)
+{
+ long type_info[3];
+ instruction * entry_point_a
+ = ((instruction *) (SCHEME_ADDR_TO_ADDR (entry_point_raw)));
+ SCHEME_OBJECT entry_point = (ENTRY_TO_OBJECT (entry_point_a));
+ SCHEME_OBJECT state;
+ SCHEME_OBJECT stack_ptr;
+
+ STACK_PUSH (entry_point); /* return address */
+
+ /* Potential bug: This does not preserve the environment for
+ IC procedures. There is no way to tell that we have
+ an IC procedure in our hands. It is not safe to preserve
+ it in general because the contents of the register may
+ be stale (predate the last GC).
+ However, the compiler no longer generates IC procedures, and
+ will probably never do it again.
+ */
+
+ compiled_entry_type (entry_point, &type_info[0]);
+ if (type_info[0] != KIND_CONTINUATION)
+ state = SHARP_F;
+ else if (type_info[1] == CONTINUATION_DYNAMIC_LINK)
+ state = (MAKE_POINTER_OBJECT
+ (TC_STACK_ENVIRONMENT, (SCHEME_ADDR_TO_ADDR (dlink_raw))));
+ else
+ state = Val;
+
+ stack_ptr = (MAKE_POINTER_OBJECT (TC_STACK_ENVIRONMENT, Stack_Pointer));
+ STACK_PUSH (state); /* state to preserve */
+ STACK_PUSH (stack_ptr); /* "Environment" pointer */
+ STACK_PUSH (entry_point); /* argument to handler */
+ return (comutil_apply ((Get_Fixed_Obj_Slot (COMPILED_CODE_BKPT_HANDLER)),
+ 4, ignore_3, ignore_4));
+}
+
+SCHEME_UTILITY utility_result
+DEFUN (comutil_compiled_closure_bkpt,
+ (entry_point_raw, ignore_2, ignore_3, ignore_4),
+ SCHEME_ADDR entry_point_raw
+ AND long ignore_2 AND long ignore_3 AND long ignore_4)
+{
+ instruction * entry_point_a
+ = ((instruction *) (SCHEME_ADDR_TO_ADDR (entry_point_raw)));
+ SCHEME_OBJECT entry_point = (ENTRY_TO_OBJECT (entry_point_a));
+ SCHEME_OBJECT stack_ptr;
+
+ STACK_PUSH (entry_point); /* return address */
+
+ stack_ptr = (MAKE_POINTER_OBJECT (TC_STACK_ENVIRONMENT, Stack_Pointer));
+ STACK_PUSH (SHARP_F); /* state to preserve */
+ STACK_PUSH (stack_ptr); /* "Environment" pointer */
+ STACK_PUSH (entry_point); /* argument to handler */
+ return (comutil_apply ((Get_Fixed_Obj_Slot (COMPILED_CODE_BKPT_HANDLER)),
+ 4, ignore_3, ignore_4));
+}
+\f
+SCHEME_UTILITY utility_result
+DEFUN (comutil_reflect_to_interface,
+ (tramp_data_raw, ignore_2, ignore_3, ignore_4),
+ SCHEME_ADDR tramp_data_raw
+ AND long ignore_2 AND long ignore_3 AND long ignore_4)
+{
+ SCHEME_OBJECT code = (STACK_POP ());
+
+ switch (OBJECT_DATUM (code))
+ {
+ case REFLECT_CODE_INTERNAL_APPLY:
+ {
+ long frame_size = (OBJECT_DATUM (STACK_POP ()));
+ SCHEME_OBJECT procedure = (STACK_POP ());
+
+ return (comutil_apply (procedure, frame_size, ignore_3, ignore_4));
+ }
+
+ case REFLECT_CODE_CC_BKPT:
+ {
+ unsigned long value;
+
+ if (do_bkpt_proceed (& value))
+ RETURN_TO_SCHEME (value);
+ else
+ RETURN_TO_C (value);
+ }
+
+ case REFLECT_CODE_RESTORE_INTERRUPT_MASK:
+ {
+ SET_INTERRUPT_MASK (OBJECT_DATUM (STACK_POP ()));
+ RETURN_TO_SCHEME (OBJECT_ADDRESS (STACK_POP ()));
+ }
+
+ case REFLECT_CODE_STACK_MARKER:
+ {
+ STACK_POP (); /* marker1 */
+ STACK_POP (); /* marker2 */
+ RETURN_TO_SCHEME (OBJECT_ADDRESS (STACK_POP ()));
+ }
+
+ default:
+ STACK_PUSH (code);
+ RETURN_TO_C (ERR_EXTERNAL_RETURN);
+ }
+}
+\f
/*
Utility table used by the assembly language interface to invoke
the SCHEME_UTILITY procedures that appear in this file.
UTE(comutil_quotient), /* 0x37 */
UTE(comutil_remainder), /* 0x38 */
UTE(comutil_modulo), /* 0x39 */
- UTE(comutil_apply_in_interpreter), /* 0x3a */
- UTE(comutil_interrupt_continuation_2) /* 0x3b */
+ UTE(comutil_reflect_to_interface), /* 0x3a */
+ UTE(comutil_interrupt_continuation_2), /* 0x3b */
+ UTE(comutil_compiled_code_bkpt), /* 0x3c */
+ UTE(comutil_compiled_closure_bkpt) /* 0x3d */
};
\f
/* Support for trap handling. */
static
struct util_descriptor_s utility_descriptor_table[] =
{
+#ifdef DECLARE_CMPINTMD_UTILITIES
+ DECLARE_CMPINTMD_UTILITIES(),
+#endif /* DECLARE_CMPINTMD_UTILITIES */
UTLD(C_to_interface),
UTLD(open_gap),
UTLD(setup_lexpr_invocation),
UTLD(apply_compiled_procedure),
UTLD(return_to_compiled_code),
UTLD(apply_compiled_from_primitive),
+ UTLD(compiled_with_interrupt_mask),
+ UTLD(compiled_with_stack_marker),
UTLD(comutil_return_to_interpreter),
- UTLD(comutil_apply_in_interpreter),
UTLD(comutil_primitive_apply),
UTLD(comutil_primitive_lexpr_apply),
UTLD(comutil_apply),
UTLD(make_uuo_link),
UTLD(make_fake_uuo_link),
UTLD(coerce_to_compiled),
+#ifndef HAVE_BKPT_SUPPORT
+ UTLD(bkpt_install),
+ UTLD(bkpt_closure_install),
+ UTLD(bkpt_remove),
+ UTLD(bkpt_p),
+ UTLD(do_bkpt_proceed),
+#endif
+ UTLD(bkpt_proceed),
+ UTLD(comutil_compiled_code_bkpt),
+ UTLD(comutil_compiled_closure_bkpt),
+ UTLD(comutil_reflect_to_interface),
UTLD(end_of_utils)
};
\f
{
long len;
SCHEME_OBJECT * block;
- /* Other stuff can be placed here. */
-
- Registers[REGBLOCK_CLOSURE_FREE] = ((SCHEME_OBJECT) NULL);
- Registers[REGBLOCK_CLOSURE_SPACE] = ((SCHEME_OBJECT) 0);
- ASM_RESET_HOOK();
+ /* Other stuff can be placed here. */
block = (OBJECT_ADDRESS (compiler_utilities));
len = (OBJECT_DATUM (block[0]));
+
return_to_interpreter =
(ENTRY_TO_OBJECT (((char *) block)
+ ((unsigned long) (block [len - 1]))));
- apply_in_interpreter =
+
+ reflect_to_interface =
(ENTRY_TO_OBJECT (((char *) block)
+ ((unsigned long) (block [len]))));
+
+ Registers[REGBLOCK_CLOSURE_FREE] = ((SCHEME_OBJECT) NULL);
+ Registers[REGBLOCK_CLOSURE_SPACE] = ((SCHEME_OBJECT) 0);
+ Registers[REGBLOCK_REFLECT_TO_INTERFACE] = reflect_to_interface;
+
+ ASM_RESET_HOOK();
+
return;
}
\f
+#define COMPILER_UTILITIES_LENGTH ((2 * (TRAMPOLINE_ENTRY_SIZE + 1)) + 1)
+
C_UTILITY void
DEFUN (compiler_reset,
(new_block),
/* Called after a disk restore */
if (((OBJECT_TYPE (new_block)) != TC_COMPILED_CODE_BLOCK)
- || ((OBJECT_TYPE (MEMORY_REF (new_block, 0))) != TC_MANIFEST_NM_VECTOR))
+ || ((OBJECT_TYPE (MEMORY_REF (new_block, 0))) != TC_MANIFEST_NM_VECTOR)
+ || ((VECTOR_LENGTH (new_block)) != (COMPILER_UTILITIES_LENGTH - 1)))
{
extern void EXFUN (compiler_reset_error, (void));
extern SCHEME_OBJECT * EXFUN (copy_to_constant_space,
(SCHEME_OBJECT *, long));
- len = ((2 * TRAMPOLINE_ENTRY_SIZE) + 3);
+ len = COMPILER_UTILITIES_LENGTH;
if (GC_Check (len))
{
outf_fatal ("compiler_initialize: Not enough space!\n");
block = Free;
Free += len;
block[0] = (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, (len - 1)));
+
tramp1 = ((instruction *) (TRAMPOLINE_ENTRY_POINT (block - 1)));
- tramp2 = ((instruction *)
- (((char *) tramp1)
- + (TRAMPOLINE_ENTRY_SIZE * (sizeof (SCHEME_OBJECT)))));
fill_trampoline (block, tramp1,
((format_word) FORMAT_WORD_RETURN),
TRAMPOLINE_K_RETURN);
+ block[len - 2] = (((char *) tramp1) - ((char *) block));
+
+ tramp2 = ((instruction *)
+ (((char *) tramp1)
+ + (TRAMPOLINE_ENTRY_SIZE * (sizeof (SCHEME_OBJECT)))));
fill_trampoline (block, tramp2,
((format_word) FORMAT_WORD_RETURN),
- TRAMPOLINE_K_APPLY_IN_INTERPRETER);
- block[len - 2] = (((char *) tramp1) - ((char *) block));
+ TRAMPOLINE_K_REFLECT_TO_INTERFACE);
block[len - 1] = (((char *) tramp2) - ((char *) block));
+
block = (copy_to_constant_space (block, len));
compiler_utilities = (MAKE_CC_BLOCK (block));
compiler_reset_internal ();
EXFUN (compiled_closure_to_entry, (SCHEME_OBJECT entry)),
* EXFUN (compiled_entry_to_block_address, (SCHEME_OBJECT entry)),
EXFUN (compiled_entry_to_block, (SCHEME_OBJECT entry)),
- EXFUN (apply_compiled_from_primitive, (int));
+ EXFUN (apply_compiled_from_primitive, (int)),
+ EXFUN (compiled_with_interrupt_mask, (unsigned long,
+ SCHEME_OBJECT,
+ unsigned long)),
+ EXFUN (compiled_with_stack_marker, (SCHEME_OBJECT));
extern void
EXFUN (compiler_reset, (SCHEME_OBJECT new_block)),
(SCHEME_OBJECT extension, SCHEME_OBJECT block, long offset)),
EXFUN (compiled_entry_type, (SCHEME_OBJECT entry, long *buffer)),
EXFUN (declare_compiled_code, (SCHEME_OBJECT block));
+
+/* Breakpoint stuff. */
+
+extern SCHEME_OBJECT EXFUN (bkpt_install, (PTR));
+extern SCHEME_OBJECT EXFUN (bkpt_closure_install, (PTR));
+extern Boolean EXFUN (bkpt_p, (PTR));
+extern SCHEME_OBJECT EXFUN (bkpt_proceed, (PTR, SCHEME_OBJECT, SCHEME_OBJECT));
+extern void EXFUN (bkpt_remove, (PTR, SCHEME_OBJECT));
\f
SCHEME_OBJECT
#ifndef WINNT
/*NOTREACHED*/
}
+SCHEME_OBJECT
+DEFUN (compiled_with_interrupt_mask, (old_mask, receiver, new_mask),
+ unsigned long old_mask
+ AND SCHEME_OBJECT receiver
+ AND unsigned long new_mask)
+{
+ signal_error_from_primitive (ERR_INAPPLICABLE_CONTINUATION);
+ /*NOTREACHED*/
+}
+
+SCHEME_OBJECT
+DEFUN (compiled_with_stack_marker, (thunk), SCHEME_OBJECT thunk)
+{
+ signal_error_from_primitive (ERR_INAPPLICABLE_CONTINUATION);
+ /*NOTREACHED*/
+}
+\f
/* Bad entry points. */
long
Microcode_Termination (TERM_COMPILER_DEATH);
/*NOTREACHED*/
}
-\f
+
void
DEFUN (store_variable_cache,
(extension, block, offset),
Microcode_Termination (TERM_COMPILER_DEATH);
/*NOTREACHED*/
}
-
+\f
SCHEME_OBJECT
DEFUN (compiled_block_debugging_info,
(block),
{
return (-1);
}
+\f
+SCHEME_OBJECT
+DEFUN (bkpt_install, (ep), PTR ep)
+{
+ return (SHARP_F);
+}
+
+SCHEME_OBJECT
+DEFUN (bkpt_closure_install, (ep), PTR ep)
+{
+ return (SHARP_F);
+}
+
+void
+DEFUN (bkpt_remove, (ep, handle), PTR ep AND SCHEME_OBJECT handle)
+{
+ error_external_return ();
+}
+
+Boolean
+DEFUN (bkpt_p, (ep), PTR ep)
+{
+ return (SHARP_F);
+}
+
+SCHEME_OBJECT
+DEFUN (bkpt_proceed, (ep, handle, state),
+ PTR ep AND SCHEME_OBJECT handle AND SCHEME_OBJECT state)
+{
+ error_external_return ();
+}
+
#endif /* HAS_COMPILER_SUPPORT */
\f
#ifdef WINNT
#include "ntscmlib.h"
+extern unsigned long * winnt_catatonia_block;
extern void EXFUN (winnt_allocate_registers, (void));
extern void EXFUN (winnt_allocate_registers, (void));
typedef struct register_storage
{
- /* The following two must be allocated consecutively */
+ /* The following must be allocated consecutively */
+ unsigned long catatonia_block[3];
#if (COMPILER_PROCESSOR_TYPE == COMPILER_I386_TYPE)
void * Regstart[32]; /* Negative byte offsets from &Registers[0] */
#endif
SCHEME_OBJECT Registers [REGBLOCK_LENGTH];
} REGMEM;
-SCHEME_OBJECT * RegistersPtr = 0;
+SCHEME_OBJECT * RegistersPtr = ((SCHEME_OBJECT *) NULL);
+unsigned long * winnt_catatonia_block = ((unsigned long *) NULL);
static REGMEM regmem;
void
{
REGMEM * mem = & regmem;
+ winnt_catatonia_block = ((unsigned long *) &mem->catatonia_block[0]);
RegistersPtr = mem->Registers;
if (! (win32_lock_memory_area (mem, (sizeof (REGMEM)))))
{
/* -*-C-*-
-$Id: comutl.c,v 1.25 1993/09/01 22:09:26 gjr Exp $
+$Id: comutl.c,v 1.26 1993/09/11 02:45:51 gjr Exp $
Copyright (c) 1987-1993 Massachusetts Institute of Technology
declare_compiled_code (new_cc_block);
PRIMITIVE_RETURN (SHARP_T);
}
+\f
+extern SCHEME_OBJECT EXFUN (bkpt_install, (PTR));
+extern SCHEME_OBJECT EXFUN (bkpt_closure_install, (PTR));
+extern Boolean EXFUN (bkpt_p, (PTR));
+extern SCHEME_OBJECT EXFUN (bkpt_proceed, (PTR, SCHEME_OBJECT, SCHEME_OBJECT));
+extern void EXFUN (bkpt_remove, (PTR, SCHEME_OBJECT));
+
+DEFINE_PRIMITIVE ("BKPT/INSTALL", Prim_install_bkpt, 1, 1,
+ "(compiled-entry-object)\n\
+Install a breakpoint trap in a compiled code object.\n\
+Returns false or a handled needed by REMOVE-BKPT and ONE-STEP-PROCEED.")
+{
+ PRIMITIVE_HEADER (1);
+ CHECK_ARG (1, COMPILED_CODE_ADDRESS_P);
+
+ {
+ SCHEME_OBJECT * entry = (OBJECT_ADDRESS (ARG_REF (1)));
+ SCHEME_OBJECT * block;
+
+ if (bkpt_p ((PTR) entry))
+ error_bad_range_arg (1);
+
+ block = (compiled_entry_to_block_address (ARG_REF (1)));
+ if ((OBJECT_TYPE (block[0])) == TC_MANIFEST_CLOSURE)
+ PRIMITIVE_RETURN (bkpt_closure_install ((PTR) entry));
+ else
+ PRIMITIVE_RETURN (bkpt_install ((PTR) entry));
+ }
+}
+
+DEFINE_PRIMITIVE ("BKPT/REMOVE", Prim_remove_bkpt, 2, 2,
+ "(compiled-entry-object handle)\n\
+Remove a breakpoint trap installed by INSTALL-BKPT.")
+{
+ PRIMITIVE_HEADER (2);
+ CHECK_ARG (1, COMPILED_CODE_ADDRESS_P);
+ CHECK_ARG (2, VECTOR_P);
+
+ {
+ SCHEME_OBJECT * entry = (OBJECT_ADDRESS (ARG_REF (1)));
+ SCHEME_OBJECT handle = (ARG_REF (2));
+
+ if (! (bkpt_p ((PTR) entry)))
+ error_bad_range_arg (1);
+ bkpt_remove (((PTR) entry), handle);
+ PRIMITIVE_RETURN (UNSPECIFIC);
+ }
+}
+
+DEFINE_PRIMITIVE ("BKPT?", Prim_bkpt_p, 1, 1,
+ "(compiled-entry-object)\n\
+True if there is a breakpoint trap in compiled-entry-object.")
+{
+ PRIMITIVE_HEADER (1);
+ CHECK_ARG (1, COMPILED_CODE_ADDRESS_P);
+
+ PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT
+ (bkpt_p ((PTR) (OBJECT_ADDRESS (ARG_REF (1))))));
+}
+
+DEFINE_PRIMITIVE ("BKPT/PROCEED", Prim_bkpt_proceed, 3, 3,
+ "(compiled-entry-object handle state)\n\
+Proceed the computation from the current breakpoint.")
+{
+ PRIMITIVE_HEADER (3);
+ CHECK_ARG (1, COMPILED_CODE_ADDRESS_P);
+ CHECK_ARG (2, VECTOR_P);
+
+ PRIMITIVE_RETURN (bkpt_proceed (((PTR) (OBJECT_ADDRESS (ARG_REF (1)))),
+ (ARG_REF (2)),
+ (ARG_REF (3))));
+}
/* -*-C-*-
-$Id: const.h,v 9.42 1993/06/09 20:28:27 jawilson Exp $
+$Id: const.h,v 9.43 1993/09/11 02:45:52 gjr Exp $
Copyright (c) 1987-1993 Massachusetts Institute of Technology
#define REGBLOCK_CLOSURE_SPACE 10 /* For use by compiler */
#define REGBLOCK_STACK_GUARD 11
#define REGBLOCK_INT_CODE 12
-#define REGBLOCK_MINIMUM_LENGTH 13
+#define REGBLOCK_REFLECT_TO_INTERFACE 13 /* For use by compiler */
+
+#define REGBLOCK_MINIMUM_LENGTH 14
\f
/* Codes specifying how to start scheme at boot time. */
/* -*-C-*-
-$Id: fixobj.h,v 9.34 1993/08/28 22:46:36 gjr Exp $
+$Id: fixobj.h,v 9.35 1993/09/11 02:45:53 gjr Exp $
Copyright (c) 1987-1993 Massachusetts Institute of Technology
#define PC_Sample_Prob_Comp_Table 0x3D /* Sure looked compiled ?! */
#define PC_Sample_UFO_Table 0x3E /* Invalid ENV at sample time */
+#define COMPILED_CODE_BKPT_HANDLER 0x3F
-
-#define NFixed_Objects 0x3F
+#define NFixed_Objects 0x40
/* -*-C-*-
-$Id: hooks.c,v 9.51 1993/06/04 00:15:34 cph Exp $
+$Id: hooks.c,v 9.52 1993/09/11 02:45:54 gjr Exp $
Copyright (c) 1988-1993 Massachusetts Institute of Technology
#include "winder.h"
#include "history.h"
\f
-#define APPLY_AVOID_CANONICALIZATION
-
DEFINE_PRIMITIVE ("APPLY", Prim_apply, 2, 2,
- "Invoke first argument on the arguments contained in the second argument.")
+ "(PROCEDURE LIST-OF-ARGS)\n\
+Invoke PROCEDURE on the arguments contained in list-of-ARGS.")
{
SCHEME_OBJECT procedure;
SCHEME_OBJECT argument_list;
procedure = (ARG_REF (1));
argument_list = (ARG_REF (2));
-#ifndef APPLY_AVOID_CANONICALIZATION
/* Since this primitive must pop its own frame off and push a new
frame on the stack, it has to be careful. Its own stack frame is
needed if an error or GC is required. So these checks are done
overhead of maintaining this other form (e.g. PRIMITIVE_GC_If_Needed)
is sufficiently high that it probably makes up for the time saved.
*/
- PRIMITIVE_CANONICALIZE_CONTEXT ();
-#endif /* APPLY_AVOID_CANONICALIZATION */
{
fast SCHEME_OBJECT scan_list, scan_list_trail;
TOUCH_IN_PRIMITIVE (argument_list, scan_list);
Pushed ();
#endif
-#ifdef APPLY_AVOID_CANONICALIZATION
if (COMPILED_CODE_ADDRESS_P (STACK_REF (number_of_args + 2)))
{
extern SCHEME_OBJECT EXFUN (apply_compiled_from_primitive, (int));
PRIMITIVE_RETURN (apply_compiled_from_primitive (2));
}
-#endif /* APPLY_AVOID_CANONICALIZATION */
PRIMITIVE_ABORT (PRIM_APPLY);
/*NOTREACHED*/
*/
DEFINE_PRIMITIVE ("CALL-WITH-CURRENT-CONTINUATION", Prim_catch, 1, 1,
- "Invoke argument with a reentrant copy of the current control stack.")
+ "(RECEIVER)\n\
+Invoke RECEIVER with a reentrant copy of the current control stack.")
{
PRIMITIVE_HEADER (1);
PRIMITIVE_CANONICALIZE_CONTEXT ();
DEFINE_PRIMITIVE ("NON-REENTRANT-CALL-WITH-CURRENT-CONTINUATION",
Prim_non_reentrant_catch, 1, 1,
- "Invoke argument with a non-reentrant copy of the current control stack.")
+ "(RECEIVER)\n\
+Invoke RECEIVER with a non-reentrant copy of the current control stack.")
{
PRIMITIVE_HEADER (1);
PRIMITIVE_CANONICALIZE_CONTEXT();
*/
DEFINE_PRIMITIVE ("WITHIN-CONTROL-POINT", Prim_within_control_point, 2, 2,
- "Invoke second argument with the first argument as its control stack.")
+ "(CONTROL-POINT THUNK)\n\
+Invoke THUNK with CONTROL-POINT as its control stack.")
{
SCHEME_OBJECT control_point, thunk;
PRIMITIVE_HEADER (2);
/*NOTREACHED*/
}
\f
-DEFINE_PRIMITIVE ("ERROR-PROCEDURE", Prim_error_procedure, 3, 3, 0)
+DEFINE_PRIMITIVE ("ERROR-PROCEDURE", Prim_error_procedure, 3, 3,
+ "(MESSAGE IRRITANTS ENVIRONMENT)\nSignal an error.")
{
PRIMITIVE_HEADER (3);
PRIMITIVE_CANONICALIZE_CONTEXT ();
}
}
-DEFINE_PRIMITIVE ("SCODE-EVAL", Prim_scode_eval, 2, 2, 0)
+DEFINE_PRIMITIVE ("SCODE-EVAL", Prim_scode_eval, 2, 2,
+ "(SCODE-EXPRESSION ENVIRONMENT)\n\
+Evaluate SCODE-EXPRESSION in ENVIRONMENT.")
{
PRIMITIVE_HEADER (2);
PRIMITIVE_CANONICALIZE_CONTEXT ();
/*NOTREACHED*/
}
\f
-DEFINE_PRIMITIVE ("FORCE", Prim_force, 1, 1, 0)
+DEFINE_PRIMITIVE ("FORCE", Prim_force, 1, 1,
+ "(PROMISE)\n\
+Return the value memoized in PROMISE, computing it if it has not been\n\
+memoized yet.")
{
PRIMITIVE_HEADER (1);
CHECK_ARG (1, PROMISE_P);
\f
/* State Space Implementation */
-DEFINE_PRIMITIVE ("EXECUTE-AT-NEW-STATE-POINT", Prim_execute_at_new_point, 4, 4, 0)
+DEFINE_PRIMITIVE ("EXECUTE-AT-NEW-STATE-POINT",
+ Prim_execute_at_new_point, 4, 4,
+ "(OLD-STATE-POINT BEFORE-THUNK DURING-THUNK AFTER-THUNK)\n\
+Invoke DURING-THUNK in a new state point defined by the transition\n\
+<BEFORE-THUNK, AFTER-THUNK> from OLD-STATE-POINT.\n\
+If OLD-STATE-POINT is #F, the current state point in the global state\n\
+space is used as the starting point.")
{
PRIMITIVE_HEADER (4);
}
}
-DEFINE_PRIMITIVE ("TRANSLATE-TO-STATE-POINT", Prim_translate_to_point, 1, 1, 0)
+DEFINE_PRIMITIVE ("TRANSLATE-TO-STATE-POINT", Prim_translate_to_point, 1, 1,
+ "(STATE-POINT)\nRestore the dynamic state to STATE-POINT.")
{
PRIMITIVE_HEADER (1);
PRIMITIVE_CANONICALIZE_CONTEXT ();
}
\f
DEFINE_PRIMITIVE ("MAKE-STATE-SPACE", Prim_make_state_space, 1, 1,
- "Return a newly-allocated state-space.\n\
+ "(MUTABLE?)\n\
+Return a newly-allocated state-space.\n\
Argument MUTABLE?, if not #F, means return a mutable state-space.\n\
Otherwise, -the- immutable state-space is saved internally.")
{
}
}
-DEFINE_PRIMITIVE ("CURRENT-DYNAMIC-STATE", Prim_current_dynamic_state, 1, 1, 0)
+DEFINE_PRIMITIVE ("CURRENT-DYNAMIC-STATE", Prim_current_dynamic_state, 1, 1,
+ "(STATE-SPACE)\n\
+Return the current state point in STATE-SPACE. If STATE-SPACE is #F,\n\
+return the current state point in the global state space.")
{
PRIMITIVE_HEADER (1);
PRIMITIVE_RETURN (MEMORY_REF ((ARG_REF (1)), STATE_SPACE_NEAREST_POINT));
}
-DEFINE_PRIMITIVE ("SET-CURRENT-DYNAMIC-STATE!", Prim_set_dynamic_state, 1, 1, 0)
+DEFINE_PRIMITIVE ("SET-CURRENT-DYNAMIC-STATE!", Prim_set_dynamic_state, 1, 1,
+ "(STATE-POINT)\n\
+Set the current dynamic state point to STATE-POINT.")
{
PRIMITIVE_HEADER (1);
CHECK_ARG (1, STATE_POINT_P);
/* Interrupts */
DEFINE_PRIMITIVE ("GET-INTERRUPT-ENABLES", Prim_get_interrupt_enables, 0, 0,
- "(get-interrupt-enables)\n\
+ "()\n\
Returns the current interrupt mask.\n\
There are two interrupt bit masks:\n\
- The interrupt mask has a one bit for every enabled interrupt.\n\
}
DEFINE_PRIMITIVE ("SET-INTERRUPT-ENABLES!", Prim_set_interrupt_enables, 1, 1,
- "(set-interrupt-enables! interrupt-mask)\n\
-Sets the interrupt mask to NEW-INT-ENABLES; returns previous mask value.\n\
+ "(INTERRUPT-MASK)\n\
+Sets the interrupt mask to INTERRUPT-MASK; returns previous mask value.\n\
See `get-interrupt-enables' for more information on interrupts.")
{
PRIMITIVE_HEADER (1);
}
DEFINE_PRIMITIVE ("CLEAR-INTERRUPTS!", Prim_clear_interrupts, 1, 1,
- "(clear-interrupts! interrupt-mask)\n\
-Clears the interrupt bits in interrupt-mask by clearing the\n\
+ "(INTERRUPT-MASK)\n\
+Clears the interrupt bits in INTERRUPT-MASK by clearing the\n\
corresponding bits in the interrupt code.\n\
See `get-interrupt-enables' for more information on interrupts.")
{
}
DEFINE_PRIMITIVE ("DISABLE-INTERRUPTS!", Prim_disable_interrupts, 1, 1,
- "(disable-interrupts! interrupt-mask)\n\
-Disables the interrupts specified in interrupt-mask by clearing the\n\
+ "(INTERRUPT-MASK)\n\
+Disables the interrupts specified in INTERRUPT-MASK by clearing the\n\
corresponding bits in the interrupt mask. Returns previous mask value.\n\
See `get-interrupt-enables' for more information on interrupts.")
{
}
DEFINE_PRIMITIVE ("ENABLE-INTERRUPTS!", Prim_enable_interrupts, 1, 1,
- "(enable-interrupts! interrupt-mask)\n\
-Enables the interrupts specified in interrupt-mask by setting the\n\
+ "(INTERRUPT-MASK)\n\
+Enables the interrupts specified in INTERRUPT-MASK by setting the\n\
corresponding bits in the interrupt mask. Returns previous mask value.\n\
See `get-interrupt-enables' for more information on interrupts.")
{
}
DEFINE_PRIMITIVE ("REQUEST-INTERRUPTS!", Prim_request_interrupts, 1, 1,
- "(request-interrupts! interrupt-mask)\n\
-Requests the interrupt bits in interrupt-mask by setting the\n\
+ "(INTERRUPT-MASK)\n\
+Requests the interrupt bits in INTERRUPT-MASK by setting the\n\
corresponding bits in the interrupt code.\n\
See `get-interrupt-enables' for more information on interrupts.")
{
PRIMITIVE_RETURN (UNSPECIFIC);
}
\f
-DEFINE_PRIMITIVE ("RETURN-TO-APPLICATION", Prim_return_to_application, 2, LEXPR,
- "Invokes first argument THUNK with no arguments and a special return address.\n\
-The return address calls the second argument on the remaining arguments.\n\
+DEFINE_PRIMITIVE ("RETURN-TO-APPLICATION",
+ Prim_return_to_application, 2, LEXPR,
+ "(THUNK PROCEDURE . ARGS)\n\
+Invokes THUNK with no arguments and a special return address.\n\
+The return address calls PROCEDURE on ARGS.\n\
This is used by the runtime system to create stack frames that can be\n\
identified by the continuation parser.")
{
PRIMITIVE_ABORT (PRIM_APPLY);
/*NOTREACHED*/
}
-
+\f
DEFINE_PRIMITIVE ("WITH-STACK-MARKER", Prim_with_stack_marker, 3, 3,
- "Call first argument THUNK with a continuation that has a special marker.\n\
+ "(THUNK MARKER1 MARKER2)\n\
+Call THUNK with a continuation that has a special marker.\n\
When THUNK returns, the marker is discarded.\n\
The value of THUNK is returned to the continuation of this primitive.\n\
-The marker consists of the second and third arguments.\n\
-By convention, the second argument is a tag identifying the kind of marker,\n\
-and the third argument is data identifying the marker instance.")
+The marker consists of MARKER1 and MARKER2.\n\
+By convention, MARKER1 is a tag identifying the kind of marker,\n\
+and MARKER2 is data identifying the marker instance.")
{
+ SCHEME_OBJECT thunk;
PRIMITIVE_HEADER (3);
- PRIMITIVE_CANONICALIZE_CONTEXT ();
+
+ thunk = (ARG_REF (1));
+
+ if ((COMPILED_CODE_ADDRESS_P (STACK_REF (2)))
+ && (COMPILED_CODE_ADDRESS_P (thunk)))
+ {
+ extern SCHEME_OBJECT EXFUN (compiled_with_stack_marker, (SCHEME_OBJECT));
+
+ STACK_POP ();
+ return (compiled_with_stack_marker (thunk));
+ }
+ else
{
- SCHEME_OBJECT thunk = (STACK_POP ());
+ PRIMITIVE_CANONICALIZE_CONTEXT ();
+
+ STACK_POP ();
STACK_PUSH (MAKE_OBJECT (TC_RETURN_CODE, RC_STACK_MARKER));
- Will_Push (STACK_ENV_EXTRA_SLOTS + 1);
+ Will_Push (STACK_ENV_EXTRA_SLOTS + 1);
STACK_PUSH (thunk);
STACK_PUSH (STACK_FRAME_HEADER);
- Pushed ();
+ Pushed ();
+ PRIMITIVE_ABORT (PRIM_APPLY);
+ /*NOTREACHED*/
}
- PRIMITIVE_ABORT (PRIM_APPLY);
- /*NOTREACHED*/
}
-
-DEFINE_PRIMITIVE ("WITH-INTERRUPT-MASK", Prim_with_interrupt_mask, 2, 2, 0)
+\f
+static SCHEME_OBJECT
+DEFUN (with_new_interrupt_mask, (new_mask), unsigned long new_mask)
{
- PRIMITIVE_HEADER (2);
- PRIMITIVE_CANONICALIZE_CONTEXT ();
+ SCHEME_OBJECT receiver = (ARG_REF (2));
+
+ if ((COMPILED_CODE_ADDRESS_P (STACK_REF (2)))
+ && (COMPILED_CODE_ADDRESS_P (receiver)))
{
- long new_mask = (INT_Mask & (arg_integer (1)));
- SCHEME_OBJECT thunk = (ARG_REF (2));
+ extern SCHEME_OBJECT
+ EXFUN (compiled_with_interrupt_mask, (unsigned long,
+ SCHEME_OBJECT,
+ unsigned long));
+ unsigned long current_mask = (FETCH_INTERRUPT_MASK ());
+
+ POP_PRIMITIVE_FRAME (2);
+ SET_INTERRUPT_MASK (new_mask);
+
+ PRIMITIVE_RETURN
+ (compiled_with_interrupt_mask (current_mask, receiver, new_mask));
+ }
+ else
+ {
+ PRIMITIVE_CANONICALIZE_CONTEXT ();
POP_PRIMITIVE_FRAME (2);
preserve_interrupt_mask ();
Will_Push (STACK_ENV_EXTRA_SLOTS + 2);
STACK_PUSH (LONG_TO_FIXNUM (FETCH_INTERRUPT_MASK ()));
- STACK_PUSH (thunk);
+ STACK_PUSH (receiver);
STACK_PUSH (STACK_FRAME_HEADER + 1);
Pushed ();
SET_INTERRUPT_MASK (new_mask);
}
}
-DEFINE_PRIMITIVE ("WITH-INTERRUPTS-REDUCED", Prim_with_interrupts_reduced, 2, 2, 0)
+DEFINE_PRIMITIVE ("WITH-INTERRUPT-MASK", Prim_with_interrupt_mask, 2, 2,
+ "(MASK RECEIVER)\n\
+Set the interrupt mask to MASK for the duration of the call to RECEIVER.\n\
+RECEIVER is passed the old interrupt mask as its argument.")
{
PRIMITIVE_HEADER (2);
- PRIMITIVE_CANONICALIZE_CONTEXT();
- {
- long new_mask = (INT_Mask & (arg_integer (1)));
- long old_mask = (FETCH_INTERRUPT_MASK ());
- SCHEME_OBJECT thunk = (ARG_REF (2));
- POP_PRIMITIVE_FRAME (2);
- preserve_interrupt_mask ();
- Will_Push (STACK_ENV_EXTRA_SLOTS + 2);
- STACK_PUSH (LONG_TO_FIXNUM (old_mask));
- STACK_PUSH (thunk);
- STACK_PUSH (STACK_FRAME_HEADER + 1);
- Pushed ();
- SET_INTERRUPT_MASK
- ((new_mask > old_mask) ? new_mask : (new_mask & old_mask));
- PRIMITIVE_ABORT (PRIM_APPLY);
- /*NOTREACHED*/
- }
+ PRIMITIVE_RETURN (with_new_interrupt_mask (INT_Mask & (arg_integer (1))));
+}
+
+DEFINE_PRIMITIVE ("WITH-INTERRUPTS-REDUCED",
+ Prim_with_interrupts_reduced, 2, 2,
+ "(MASK RECEIVER)\n\
+Like `with-interrupt-mask', but only disables interrupts.")
+{
+ unsigned long old_mask, new_mask;
+ PRIMITIVE_HEADER (2);
+
+ old_mask = (FETCH_INTERRUPT_MASK ());
+ new_mask = (INT_Mask & (arg_integer (1)));
+ PRIMITIVE_RETURN (with_new_interrupt_mask ((new_mask > old_mask) ?
+ new_mask :
+ (new_mask & old_mask)));
}
\f
/* History */
(MAKE_POINTER_OBJECT (UNMARKED_HISTORY_TYPE, (Make_Dummy_History ())));
}
-DEFINE_PRIMITIVE ("SET-CURRENT-HISTORY!", Prim_set_current_history, 1, 1, 0)
+DEFINE_PRIMITIVE ("SET-CURRENT-HISTORY!", Prim_set_current_history, 1, 1,
+ "(HISTORY)\n\
+Set the interpreter's history object to HISTORY.")
{
PRIMITIVE_HEADER (1);
PRIMITIVE_CANONICALIZE_CONTEXT ();
/*NOTREACHED*/
}
-DEFINE_PRIMITIVE ("WITH-HISTORY-DISABLED", Prim_with_history_disabled, 1, 1, 0)
+DEFINE_PRIMITIVE ("WITH-HISTORY-DISABLED", Prim_with_history_disabled, 1, 1,
+ "(THUNK)\nExecute THUNK with the interpreter's history OFF.")
{
PRIMITIVE_HEADER (1);
PRIMITIVE_CANONICALIZE_CONTEXT ();
\f
/* Miscellaneous State */
-DEFINE_PRIMITIVE ("GET-FLUID-BINDINGS", Prim_get_fluid_bindings, 0, 0, 0)
+DEFINE_PRIMITIVE ("GET-FLUID-BINDINGS", Prim_get_fluid_bindings, 0, 0,
+ "()\nReturn the current deep fluid bindings.")
{
PRIMITIVE_HEADER (0);
PRIMITIVE_RETURN (Fluid_Bindings);
}
-DEFINE_PRIMITIVE ("SET-FLUID-BINDINGS!", Prim_set_fluid_bindings, 1, 1, 0)
+DEFINE_PRIMITIVE ("SET-FLUID-BINDINGS!", Prim_set_fluid_bindings, 1, 1,
+ "(FLUID-BINDINGS-ALIST)\n\
+Set the current deep fluid bindings alist to FLUID-BINDINGS-ALIST.")
{
PRIMITIVE_HEADER (1);
CHECK_ARG (1, APPARENT_LIST_P);
}
}
-DEFINE_PRIMITIVE ("GET-FIXED-OBJECTS-VECTOR", Prim_get_fixed_objects_vector, 0, 0, 0)
+DEFINE_PRIMITIVE ("GET-FIXED-OBJECTS-VECTOR",
+ Prim_get_fixed_objects_vector, 0, 0,
+ "()\nReturn the fixed objects vector (TM).")
{
PRIMITIVE_HEADER (0);
if (Valid_Fixed_Obj_Vector ())
}
#ifndef SET_FIXED_OBJ_HOOK
-#define SET_FIXED_OBJ_HOOK(vector) Fixed_Objects = (vector)
+# define SET_FIXED_OBJ_HOOK(vector) Fixed_Objects = (vector)
#endif
-DEFINE_PRIMITIVE ("SET-FIXED-OBJECTS-VECTOR!", Prim_set_fixed_objects_vector, 1, 1, 0)
+DEFINE_PRIMITIVE ("SET-FIXED-OBJECTS-VECTOR!",
+ Prim_set_fixed_objects_vector, 1, 1,
+ "(NEW-FOV)\nSet the fixed objects vector (TM) to NEW-FOV.")
{
PRIMITIVE_HEADER (1);
CHECK_ARG (1, VECTOR_P);
/* -*-C-*-
-$Id: ntgui.c,v 1.10 1993/09/07 19:08:01 gjr Exp $
+$Id: ntgui.c,v 1.11 1993/09/11 02:45:55 gjr Exp $
Copyright (c) 1993 Massachusetts Institute of Technology
\f
extern HANDLE master_tty_window;
extern void catatonia_trigger (void);
+extern unsigned long * winnt_catatonia_block;
void
catatonia_trigger (void)
{
int mes_result;
static BOOL already_exitting = FALSE;
- SCHEME_OBJECT saved = Registers[REGBLOCK_CATATONIA_LIMIT];
+ SCHEME_OBJECT saved = winnt_catatonia_block[CATATONIA_BLOCK_LIMIT];
- Registers[REGBLOCK_CATATONIA_LIMIT] = 0;
+ winnt_catatonia_block[CATATONIA_BLOCK_LIMIT] = 0;
mes_result = (MessageBox (master_tty_window,
"Scheme appears to have become catatonic.\n"
"MIT Scheme",
(MB_ICONSTOP | MB_OKCANCEL)));
- Registers[REGBLOCK_CATATONIA_COUNTER] = 0;
- Registers[REGBLOCK_CATATONIA_LIMIT] = saved;
+ winnt_catatonia_block[CATATONIA_BLOCK_COUNTER] = 0;
+ winnt_catatonia_block[CATATONIA_BLOCK_LIMIT] = saved;
if (mes_result != IDOK)
return;
}
else
{
- Registers[REGBLOCK_CATATONIA_COUNTER] = 0;
+ winnt_catatonia_block[CATATONIA_BLOCK_COUNTER] = 0;
nt_gui_default_poll ();
#ifndef USE_WM_TIMER
low_level_timer_tick ();
/* -*-C-*-
-$Id: ntgui.h,v 1.5 1993/09/08 04:44:41 gjr Exp $
+$Id: ntgui.h,v 1.6 1993/09/11 02:45:56 gjr Exp $
Copyright (c) 1993 Massachusetts Institute of Technology
#define IDM_ABOUT 303
#define IDM_EMERGENCYKILL 400
-#ifndef REGBLOCK_CATATONIA_COUNTER
+#ifndef CATATONIA_BLOCK_COUNTER
/* They must be contiguous, with counter being lower. */
-# define REGBLOCK_CATATONIA_COUNTER REGBLOCK_MINIMUM_LENGTH
-# define REGBLOCK_CATATONIA_LIMIT (REGBLOCK_CATATONIA_COUNTER + 1)
-# define REGBLOCK_CATATONIA_FLAG (REGBLOCK_CATATONIA_COUNTER + 2)
+# define CATATONIA_BLOCK_COUNTER 0
+# define CATATONIA_BLOCK_LIMIT (CATATONIA_BLOCK_COUNTER + 1)
+# define CATATONIA_BLOCK_FLAG (CATATONIA_BLOCK_COUNTER + 2)
#endif
#define WM_CATATONIC (WM_USER)
/* -*-C-*-
-$Id: ntsig.c,v 1.12 1993/09/08 04:44:06 gjr Exp $
+$Id: ntsig.c,v 1.13 1993/09/11 02:45:57 gjr Exp $
Copyright (c) 1992-1993 Massachusetts Institute of Technology
#define ASYNC_TIMER_PERIOD 50 /* msec */
static void * timer_state = ((void *) NULL);
+extern unsigned long * winnt_catatonia_block;
static char *
DEFUN_VOID (install_timer)
{
- Registers[REGBLOCK_CATATONIA_COUNTER] = 0;
- Registers[REGBLOCK_CATATONIA_LIMIT]
+ /* This presumes that the catatonia block is allocated near
+ the register block and locked in physical memory with it.
+ */
+
+ long catatonia_offset
+ = (((SCHEME_OBJECT *) &winnt_catatonia_block[0]) - (&Registers[0]));
+
+ winnt_catatonia_block[CATATONIA_BLOCK_COUNTER] = 0;
+ winnt_catatonia_block[CATATONIA_BLOCK_LIMIT]
= (CATATONIA_PERIOD / ASYNC_TIMER_PERIOD);
- Registers[REGBLOCK_CATATONIA_FLAG] = 0;
+ winnt_catatonia_block[CATATONIA_BLOCK_FLAG] = 0;
switch (win32_install_async_timer (&timer_state,
&Registers[0],
REGBLOCK_MEMTOP,
REGBLOCK_INT_CODE,
REGBLOCK_INT_MASK,
(INT_Global_GC | INT_Global_1),
- REGBLOCK_CATATONIA_COUNTER,
+ catatonia_offset,
WM_CATATONIC,
master_tty_window))
{
/* -*-C-*-
-$Id: prosio.c,v 1.8 1993/04/06 22:18:09 cph Exp $
+$Id: prosio.c,v 1.9 1993/09/11 02:45:58 gjr Exp $
Copyright (c) 1987-93 Massachusetts Institute of Technology
OS_channel_unregister (arg_channel (1));
PRIMITIVE_RETURN (UNSPECIFIC);
}
-
-DEFINE_PRIMITIVE ("CHANNEL-SELECT-THEN-READ", Prim_channel_select_then_read, 4, 4,
- "Like CHANNEL-READ, but also watches registered input channels.\n\
-If there is no input on CHANNEL, returns #F.\n\
-If there is input on some other registered channel, returns -2.\n\
-If the status of some subprocess changes, returns -3.\n\
-If an interrupt occurs during the read, returns -4.")
-{
- PRIMITIVE_HEADER (4);
- CHECK_ARG (2, STRING_P);
- {
- SCHEME_OBJECT buffer = (ARG_REF (2));
- long length = (STRING_LENGTH (buffer));
- long end = (arg_index_integer (4, (length + 1)));
- long start = (arg_index_integer (3, (end + 1)));
- long nread =
- (OS_channel_select_then_read ((arg_channel (1)),
- (STRING_LOC (buffer, start)),
- (end - start)));
- PRIMITIVE_RETURN ((nread == (-1)) ? SHARP_F : (long_to_integer (nread)));
- }
-}
;;; -*-Scheme-*-
;;;
-;;; $Id: utabmd.scm,v 9.70 1993/08/28 21:17:23 gjr Exp $
+;;; $Id: utabmd.scm,v 9.71 1993/09/11 02:45:59 gjr Exp $
;;;
;;; Copyright (c) 1987-1993 Massachusetts Institute of Technology
;;;
PC-Sample/Interp-Proc-Buffer ;3C
PC-Sample/Prob-Comp-Table ;3D
PC-Sample/UFO-Table ;3E
+ COMPILED-CODE-BKPT-HANDLER ;3F
))
\f
;;; [] Types
;;; This identification string is saved by the system.
-"$Id: utabmd.scm,v 9.70 1993/08/28 21:17:23 gjr Exp $"
\ No newline at end of file
+"$Id: utabmd.scm,v 9.71 1993/09/11 02:45:59 gjr Exp $"
\ No newline at end of file
/* -*-C-*-
-$Id: cmpint.c,v 1.67 1993/09/07 21:45:53 gjr Exp $
+$Id: cmpint.c,v 1.68 1993/09/11 02:45:46 gjr Exp $
Copyright (c) 1989-1993 Massachusetts Institute of Technology
#include "trap.h" /* UNASSIGNED_OBJECT, TRAP_EXTENSION_TYPE */
#include "prims.h" /* LEXPR */
#include "prim.h" /* Primitive_Procedure_Table, etc. */
+
+#define ENTRY_TO_OBJECT(entry) \
+ (MAKE_POINTER_OBJECT (TC_COMPILED_ENTRY, ((SCHEME_OBJECT *) (entry))))
+
#define IN_CMPINT_C
#include "cmpgc.h" /* Compiled code object relocation */
} \
}
-#define ENTRY_TO_OBJECT(entry) \
- (MAKE_POINTER_OBJECT (TC_COMPILED_ENTRY, ((SCHEME_OBJECT *) (entry))))
-
#define MAKE_CC_BLOCK(block_addr) \
(MAKE_POINTER_OBJECT (TC_COMPILED_CODE_BLOCK, block_addr))
EXFUN (compiled_closure_to_entry, (SCHEME_OBJECT entry)),
* EXFUN (compiled_entry_to_block_address, (SCHEME_OBJECT entry)),
EXFUN (compiled_entry_to_block, (SCHEME_OBJECT entry)),
- EXFUN (apply_compiled_from_primitive, (int));
+ EXFUN (apply_compiled_from_primitive, (int)),
+ EXFUN (compiled_with_interrupt_mask, (unsigned long,
+ SCHEME_OBJECT,
+ unsigned long)),
+ EXFUN (compiled_with_stack_marker, (SCHEME_OBJECT));
extern C_UTILITY void
EXFUN (compiler_initialize, (long fasl_p)),
extern utility_table_entry utility_table[];
-static SCHEME_OBJECT apply_in_interpreter;
+static SCHEME_OBJECT reflect_to_interface;
+
+/* Breakpoint stuff. */
+
+extern C_UTILITY SCHEME_OBJECT EXFUN (bkpt_install, (PTR));
+extern C_UTILITY SCHEME_OBJECT EXFUN (bkpt_closure_install, (PTR));
+extern C_UTILITY Boolean EXFUN (bkpt_p, (PTR));
+extern C_UTILITY SCHEME_OBJECT EXFUN (bkpt_proceed, (PTR, SCHEME_OBJECT, SCHEME_OBJECT));
+extern C_UTILITY void EXFUN (bkpt_remove, (PTR, SCHEME_OBJECT));
\f
/* These definitions reflect the indices into the table above. */
#define TRAMPOLINE_K_4_2 0xf
#define TRAMPOLINE_K_4_1 0x10
#define TRAMPOLINE_K_4_0 0x11
-#define TRAMPOLINE_K_APPLY_IN_INTERPRETER 0x3a
+#define TRAMPOLINE_K_REFLECT_TO_INTERFACE 0x3a
#define TRAMPOLINE_K_OTHER TRAMPOLINE_K_INTERPRETED
+#define REFLECT_CODE_INTERNAL_APPLY 0
+#define REFLECT_CODE_RESTORE_INTERRUPT_MASK 1
+#define REFLECT_CODE_STACK_MARKER 2
+#define REFLECT_CODE_CC_BKPT 3
+\f
/* Utilities for application of compiled procedures. */
/* NOTE: In this file, the number of arguments (or minimum
*/
return (setup_lexpr_invocation (nactuals, nmax, compiled_entry_address));
}
-\f
-
-
\f
/* Main compiled code entry points.
break;
}
- STACK_PUSH (apply_in_interpreter);
+ STACK_PUSH (FIXNUM_ZERO + REFLECT_CODE_INTERNAL_APPLY);
+ STACK_PUSH (reflect_to_interface);
Stack_Pointer = (STACK_LOC (- arity));
return (SHARP_F);
}
\f
+C_UTILITY SCHEME_OBJECT
+DEFUN (compiled_with_interrupt_mask, (old_mask, receiver, new_mask),
+ unsigned long old_mask
+ AND SCHEME_OBJECT receiver
+ AND unsigned long new_mask)
+{
+ long result;
+
+ STACK_PUSH (LONG_TO_FIXNUM (old_mask));
+ STACK_PUSH (FIXNUM_ZERO + REFLECT_CODE_RESTORE_INTERRUPT_MASK);
+ STACK_PUSH (reflect_to_interface);
+
+ STACK_PUSH (LONG_TO_FIXNUM (new_mask));
+ result = (setup_compiled_invocation (2,
+ ((instruction *)
+ (OBJECT_ADDRESS (receiver)))));
+ STACK_PUSH (receiver);
+
+ if (result != PRIM_DONE)
+ {
+ STACK_PUSH (STACK_FRAME_HEADER + 1);
+ STACK_PUSH (FIXNUM_ZERO + REFLECT_CODE_INTERNAL_APPLY);
+ STACK_PUSH (reflect_to_interface);
+ }
+
+ Stack_Pointer = (STACK_LOC (- 2));
+ return (SHARP_F);
+}
+
+C_UTILITY SCHEME_OBJECT
+DEFUN (compiled_with_stack_marker, (thunk), SCHEME_OBJECT thunk)
+{
+ long result;
+
+ STACK_PUSH (FIXNUM_ZERO + REFLECT_CODE_STACK_MARKER);
+ STACK_PUSH (reflect_to_interface);
+
+ result = (setup_compiled_invocation (1,
+ ((instruction *)
+ (OBJECT_ADDRESS (thunk)))));
+ STACK_PUSH (thunk);
+
+ if (result != PRIM_DONE)
+ {
+ STACK_PUSH (STACK_FRAME_HEADER);
+ STACK_PUSH (FIXNUM_ZERO + REFLECT_CODE_INTERNAL_APPLY);
+ STACK_PUSH (reflect_to_interface);
+ }
+
+ Stack_Pointer = (STACK_LOC (- 3));
+ return (SHARP_F);
+}
+\f
/*
SCHEME_UTILITYs
{
RETURN_TO_C (PRIM_DONE);
}
-
-/*
- This is an alternate way for code to return to the
- Scheme interpreter.
- It is invoked by a trampoline, which passes the address of the
- trampoline storage block (empty) to it.
- */
-
-SCHEME_UTILITY utility_result
-DEFUN (comutil_apply_in_interpreter,
- (tramp_data_raw, ignore_2, ignore_3, ignore_4),
- SCHEME_ADDR tramp_data_raw
- AND long ignore_2 AND long ignore_3 AND long ignore_4)
-{
- RETURN_TO_C (PRIM_APPLY);
-}
\f
#if (COMPILER_PROCESSOR_TYPE != COMPILER_I386_TYPE)
field1 = min_arity;
field2 = max_arity;
if (min_arity >= 0)
- {
kind = KIND_PROCEDURE;
- }
else if (max_arity >= 0)
- {
kind = KIND_ILLEGAL;
- }
else if ((((unsigned long) max_arity) & 0xff) < 0xe0)
{
/* Field2 is the offset to the next continuation */
return (PRIM_DONE);
}
\f
+#ifndef HAVE_BKPT_SUPPORT
+
+C_UTILITY SCHEME_OBJECT
+DEFUN (bkpt_install, (ep), PTR ep)
+{
+ return (SHARP_F);
+}
+
+C_UTILITY SCHEME_OBJECT
+DEFUN (bkpt_closure_install, (ep), PTR ep)
+{
+ return (SHARP_F);
+}
+
+C_UTILITY void
+DEFUN (bkpt_remove, (ep, handle), PTR ep AND SCHEME_OBJECT handle)
+{
+ error_external_return ();
+}
+
+C_UTILITY Boolean
+DEFUN (bkpt_p, (ep), PTR ep)
+{
+ return (SHARP_F);
+}
+
+C_UTILITY SCHEME_OBJECT
+DEFUN (bkpt_proceed, (ep, handle, state),
+ PTR ep AND SCHEME_OBJECT handle AND SCHEME_OBJECT state)
+{
+ error_external_return ();
+}
+
+C_UTILITY PTR
+DEFUN_VOID (do_bkpt_proceed)
+{
+ error_external_return ();
+}
+
+#else /* HAVE_BKPT_SUPPORT */
+
+#define BKPT_PROCEED_FRAME_SIZE 3
+
+C_UTILITY SCHEME_OBJECT
+DEFUN (bkpt_proceed, (ep, handle, state),
+ PTR ep AND SCHEME_OBJECT handle AND SCHEME_OBJECT state)
+{
+ if ((! (COMPILED_CODE_ADDRESS_P (STACK_REF (BKPT_PROCEED_FRAME_SIZE))))
+ || ((OBJECT_ADDRESS (STACK_REF (BKPT_PROCEED_FRAME_SIZE)))
+ != ((SCHEME_OBJECT *) ep)))
+ error_external_return ();
+
+ STACK_PUSH (FIXNUM_ZERO + REFLECT_CODE_CC_BKPT);
+ STACK_PUSH (reflect_to_interface);
+ Stack_Pointer = (STACK_LOC (- BKPT_PROCEED_FRAME_SIZE));
+ return (SHARP_F);
+}
+#endif /* HAVE_BKPT_SUPPORT */
+\f
+SCHEME_UTILITY utility_result
+DEFUN (comutil_compiled_code_bkpt,
+ (entry_point_raw, dlink_raw, ignore_3, ignore_4),
+ SCHEME_ADDR entry_point_raw AND SCHEME_ADDR dlink_raw
+ AND long ignore_3 AND long ignore_4)
+{
+ long type_info[3];
+ instruction * entry_point_a
+ = ((instruction *) (SCHEME_ADDR_TO_ADDR (entry_point_raw)));
+ SCHEME_OBJECT entry_point = (ENTRY_TO_OBJECT (entry_point_a));
+ SCHEME_OBJECT state;
+ SCHEME_OBJECT stack_ptr;
+
+ STACK_PUSH (entry_point); /* return address */
+
+ /* Potential bug: This does not preserve the environment for
+ IC procedures. There is no way to tell that we have
+ an IC procedure in our hands. It is not safe to preserve
+ it in general because the contents of the register may
+ be stale (predate the last GC).
+ However, the compiler no longer generates IC procedures, and
+ will probably never do it again.
+ */
+
+ compiled_entry_type (entry_point, &type_info[0]);
+ if (type_info[0] != KIND_CONTINUATION)
+ state = SHARP_F;
+ else if (type_info[1] == CONTINUATION_DYNAMIC_LINK)
+ state = (MAKE_POINTER_OBJECT
+ (TC_STACK_ENVIRONMENT, (SCHEME_ADDR_TO_ADDR (dlink_raw))));
+ else
+ state = Val;
+
+ stack_ptr = (MAKE_POINTER_OBJECT (TC_STACK_ENVIRONMENT, Stack_Pointer));
+ STACK_PUSH (state); /* state to preserve */
+ STACK_PUSH (stack_ptr); /* "Environment" pointer */
+ STACK_PUSH (entry_point); /* argument to handler */
+ return (comutil_apply ((Get_Fixed_Obj_Slot (COMPILED_CODE_BKPT_HANDLER)),
+ 4, ignore_3, ignore_4));
+}
+
+SCHEME_UTILITY utility_result
+DEFUN (comutil_compiled_closure_bkpt,
+ (entry_point_raw, ignore_2, ignore_3, ignore_4),
+ SCHEME_ADDR entry_point_raw
+ AND long ignore_2 AND long ignore_3 AND long ignore_4)
+{
+ instruction * entry_point_a
+ = ((instruction *) (SCHEME_ADDR_TO_ADDR (entry_point_raw)));
+ SCHEME_OBJECT entry_point = (ENTRY_TO_OBJECT (entry_point_a));
+ SCHEME_OBJECT stack_ptr;
+
+ STACK_PUSH (entry_point); /* return address */
+
+ stack_ptr = (MAKE_POINTER_OBJECT (TC_STACK_ENVIRONMENT, Stack_Pointer));
+ STACK_PUSH (SHARP_F); /* state to preserve */
+ STACK_PUSH (stack_ptr); /* "Environment" pointer */
+ STACK_PUSH (entry_point); /* argument to handler */
+ return (comutil_apply ((Get_Fixed_Obj_Slot (COMPILED_CODE_BKPT_HANDLER)),
+ 4, ignore_3, ignore_4));
+}
+\f
+SCHEME_UTILITY utility_result
+DEFUN (comutil_reflect_to_interface,
+ (tramp_data_raw, ignore_2, ignore_3, ignore_4),
+ SCHEME_ADDR tramp_data_raw
+ AND long ignore_2 AND long ignore_3 AND long ignore_4)
+{
+ SCHEME_OBJECT code = (STACK_POP ());
+
+ switch (OBJECT_DATUM (code))
+ {
+ case REFLECT_CODE_INTERNAL_APPLY:
+ {
+ long frame_size = (OBJECT_DATUM (STACK_POP ()));
+ SCHEME_OBJECT procedure = (STACK_POP ());
+
+ return (comutil_apply (procedure, frame_size, ignore_3, ignore_4));
+ }
+
+ case REFLECT_CODE_CC_BKPT:
+ {
+ unsigned long value;
+
+ if (do_bkpt_proceed (& value))
+ RETURN_TO_SCHEME (value);
+ else
+ RETURN_TO_C (value);
+ }
+
+ case REFLECT_CODE_RESTORE_INTERRUPT_MASK:
+ {
+ SET_INTERRUPT_MASK (OBJECT_DATUM (STACK_POP ()));
+ RETURN_TO_SCHEME (OBJECT_ADDRESS (STACK_POP ()));
+ }
+
+ case REFLECT_CODE_STACK_MARKER:
+ {
+ STACK_POP (); /* marker1 */
+ STACK_POP (); /* marker2 */
+ RETURN_TO_SCHEME (OBJECT_ADDRESS (STACK_POP ()));
+ }
+
+ default:
+ STACK_PUSH (code);
+ RETURN_TO_C (ERR_EXTERNAL_RETURN);
+ }
+}
+\f
/*
Utility table used by the assembly language interface to invoke
the SCHEME_UTILITY procedures that appear in this file.
UTE(comutil_quotient), /* 0x37 */
UTE(comutil_remainder), /* 0x38 */
UTE(comutil_modulo), /* 0x39 */
- UTE(comutil_apply_in_interpreter), /* 0x3a */
- UTE(comutil_interrupt_continuation_2) /* 0x3b */
+ UTE(comutil_reflect_to_interface), /* 0x3a */
+ UTE(comutil_interrupt_continuation_2), /* 0x3b */
+ UTE(comutil_compiled_code_bkpt), /* 0x3c */
+ UTE(comutil_compiled_closure_bkpt) /* 0x3d */
};
\f
/* Support for trap handling. */
static
struct util_descriptor_s utility_descriptor_table[] =
{
+#ifdef DECLARE_CMPINTMD_UTILITIES
+ DECLARE_CMPINTMD_UTILITIES(),
+#endif /* DECLARE_CMPINTMD_UTILITIES */
UTLD(C_to_interface),
UTLD(open_gap),
UTLD(setup_lexpr_invocation),
UTLD(apply_compiled_procedure),
UTLD(return_to_compiled_code),
UTLD(apply_compiled_from_primitive),
+ UTLD(compiled_with_interrupt_mask),
+ UTLD(compiled_with_stack_marker),
UTLD(comutil_return_to_interpreter),
- UTLD(comutil_apply_in_interpreter),
UTLD(comutil_primitive_apply),
UTLD(comutil_primitive_lexpr_apply),
UTLD(comutil_apply),
UTLD(make_uuo_link),
UTLD(make_fake_uuo_link),
UTLD(coerce_to_compiled),
+#ifndef HAVE_BKPT_SUPPORT
+ UTLD(bkpt_install),
+ UTLD(bkpt_closure_install),
+ UTLD(bkpt_remove),
+ UTLD(bkpt_p),
+ UTLD(do_bkpt_proceed),
+#endif
+ UTLD(bkpt_proceed),
+ UTLD(comutil_compiled_code_bkpt),
+ UTLD(comutil_compiled_closure_bkpt),
+ UTLD(comutil_reflect_to_interface),
UTLD(end_of_utils)
};
\f
{
long len;
SCHEME_OBJECT * block;
- /* Other stuff can be placed here. */
-
- Registers[REGBLOCK_CLOSURE_FREE] = ((SCHEME_OBJECT) NULL);
- Registers[REGBLOCK_CLOSURE_SPACE] = ((SCHEME_OBJECT) 0);
- ASM_RESET_HOOK();
+ /* Other stuff can be placed here. */
block = (OBJECT_ADDRESS (compiler_utilities));
len = (OBJECT_DATUM (block[0]));
+
return_to_interpreter =
(ENTRY_TO_OBJECT (((char *) block)
+ ((unsigned long) (block [len - 1]))));
- apply_in_interpreter =
+
+ reflect_to_interface =
(ENTRY_TO_OBJECT (((char *) block)
+ ((unsigned long) (block [len]))));
+
+ Registers[REGBLOCK_CLOSURE_FREE] = ((SCHEME_OBJECT) NULL);
+ Registers[REGBLOCK_CLOSURE_SPACE] = ((SCHEME_OBJECT) 0);
+ Registers[REGBLOCK_REFLECT_TO_INTERFACE] = reflect_to_interface;
+
+ ASM_RESET_HOOK();
+
return;
}
\f
+#define COMPILER_UTILITIES_LENGTH ((2 * (TRAMPOLINE_ENTRY_SIZE + 1)) + 1)
+
C_UTILITY void
DEFUN (compiler_reset,
(new_block),
/* Called after a disk restore */
if (((OBJECT_TYPE (new_block)) != TC_COMPILED_CODE_BLOCK)
- || ((OBJECT_TYPE (MEMORY_REF (new_block, 0))) != TC_MANIFEST_NM_VECTOR))
+ || ((OBJECT_TYPE (MEMORY_REF (new_block, 0))) != TC_MANIFEST_NM_VECTOR)
+ || ((VECTOR_LENGTH (new_block)) != (COMPILER_UTILITIES_LENGTH - 1)))
{
extern void EXFUN (compiler_reset_error, (void));
extern SCHEME_OBJECT * EXFUN (copy_to_constant_space,
(SCHEME_OBJECT *, long));
- len = ((2 * TRAMPOLINE_ENTRY_SIZE) + 3);
+ len = COMPILER_UTILITIES_LENGTH;
if (GC_Check (len))
{
outf_fatal ("compiler_initialize: Not enough space!\n");
block = Free;
Free += len;
block[0] = (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, (len - 1)));
+
tramp1 = ((instruction *) (TRAMPOLINE_ENTRY_POINT (block - 1)));
- tramp2 = ((instruction *)
- (((char *) tramp1)
- + (TRAMPOLINE_ENTRY_SIZE * (sizeof (SCHEME_OBJECT)))));
fill_trampoline (block, tramp1,
((format_word) FORMAT_WORD_RETURN),
TRAMPOLINE_K_RETURN);
+ block[len - 2] = (((char *) tramp1) - ((char *) block));
+
+ tramp2 = ((instruction *)
+ (((char *) tramp1)
+ + (TRAMPOLINE_ENTRY_SIZE * (sizeof (SCHEME_OBJECT)))));
fill_trampoline (block, tramp2,
((format_word) FORMAT_WORD_RETURN),
- TRAMPOLINE_K_APPLY_IN_INTERPRETER);
- block[len - 2] = (((char *) tramp1) - ((char *) block));
+ TRAMPOLINE_K_REFLECT_TO_INTERFACE);
block[len - 1] = (((char *) tramp2) - ((char *) block));
+
block = (copy_to_constant_space (block, len));
compiler_utilities = (MAKE_CC_BLOCK (block));
compiler_reset_internal ();
EXFUN (compiled_closure_to_entry, (SCHEME_OBJECT entry)),
* EXFUN (compiled_entry_to_block_address, (SCHEME_OBJECT entry)),
EXFUN (compiled_entry_to_block, (SCHEME_OBJECT entry)),
- EXFUN (apply_compiled_from_primitive, (int));
+ EXFUN (apply_compiled_from_primitive, (int)),
+ EXFUN (compiled_with_interrupt_mask, (unsigned long,
+ SCHEME_OBJECT,
+ unsigned long)),
+ EXFUN (compiled_with_stack_marker, (SCHEME_OBJECT));
extern void
EXFUN (compiler_reset, (SCHEME_OBJECT new_block)),
(SCHEME_OBJECT extension, SCHEME_OBJECT block, long offset)),
EXFUN (compiled_entry_type, (SCHEME_OBJECT entry, long *buffer)),
EXFUN (declare_compiled_code, (SCHEME_OBJECT block));
+
+/* Breakpoint stuff. */
+
+extern SCHEME_OBJECT EXFUN (bkpt_install, (PTR));
+extern SCHEME_OBJECT EXFUN (bkpt_closure_install, (PTR));
+extern Boolean EXFUN (bkpt_p, (PTR));
+extern SCHEME_OBJECT EXFUN (bkpt_proceed, (PTR, SCHEME_OBJECT, SCHEME_OBJECT));
+extern void EXFUN (bkpt_remove, (PTR, SCHEME_OBJECT));
\f
SCHEME_OBJECT
#ifndef WINNT
/*NOTREACHED*/
}
+SCHEME_OBJECT
+DEFUN (compiled_with_interrupt_mask, (old_mask, receiver, new_mask),
+ unsigned long old_mask
+ AND SCHEME_OBJECT receiver
+ AND unsigned long new_mask)
+{
+ signal_error_from_primitive (ERR_INAPPLICABLE_CONTINUATION);
+ /*NOTREACHED*/
+}
+
+SCHEME_OBJECT
+DEFUN (compiled_with_stack_marker, (thunk), SCHEME_OBJECT thunk)
+{
+ signal_error_from_primitive (ERR_INAPPLICABLE_CONTINUATION);
+ /*NOTREACHED*/
+}
+\f
/* Bad entry points. */
long
Microcode_Termination (TERM_COMPILER_DEATH);
/*NOTREACHED*/
}
-\f
+
void
DEFUN (store_variable_cache,
(extension, block, offset),
Microcode_Termination (TERM_COMPILER_DEATH);
/*NOTREACHED*/
}
-
+\f
SCHEME_OBJECT
DEFUN (compiled_block_debugging_info,
(block),
{
return (-1);
}
+\f
+SCHEME_OBJECT
+DEFUN (bkpt_install, (ep), PTR ep)
+{
+ return (SHARP_F);
+}
+
+SCHEME_OBJECT
+DEFUN (bkpt_closure_install, (ep), PTR ep)
+{
+ return (SHARP_F);
+}
+
+void
+DEFUN (bkpt_remove, (ep, handle), PTR ep AND SCHEME_OBJECT handle)
+{
+ error_external_return ();
+}
+
+Boolean
+DEFUN (bkpt_p, (ep), PTR ep)
+{
+ return (SHARP_F);
+}
+
+SCHEME_OBJECT
+DEFUN (bkpt_proceed, (ep, handle, state),
+ PTR ep AND SCHEME_OBJECT handle AND SCHEME_OBJECT state)
+{
+ error_external_return ();
+}
+
#endif /* HAS_COMPILER_SUPPORT */
\f
#ifdef WINNT
#include "ntscmlib.h"
+extern unsigned long * winnt_catatonia_block;
extern void EXFUN (winnt_allocate_registers, (void));
extern void EXFUN (winnt_allocate_registers, (void));
typedef struct register_storage
{
- /* The following two must be allocated consecutively */
+ /* The following must be allocated consecutively */
+ unsigned long catatonia_block[3];
#if (COMPILER_PROCESSOR_TYPE == COMPILER_I386_TYPE)
void * Regstart[32]; /* Negative byte offsets from &Registers[0] */
#endif
SCHEME_OBJECT Registers [REGBLOCK_LENGTH];
} REGMEM;
-SCHEME_OBJECT * RegistersPtr = 0;
+SCHEME_OBJECT * RegistersPtr = ((SCHEME_OBJECT *) NULL);
+unsigned long * winnt_catatonia_block = ((unsigned long *) NULL);
static REGMEM regmem;
void
{
REGMEM * mem = & regmem;
+ winnt_catatonia_block = ((unsigned long *) &mem->catatonia_block[0]);
RegistersPtr = mem->Registers;
if (! (win32_lock_memory_area (mem, (sizeof (REGMEM)))))
{
/* -*-C-*-
-$Id: const.h,v 9.42 1993/06/09 20:28:27 jawilson Exp $
+$Id: const.h,v 9.43 1993/09/11 02:45:52 gjr Exp $
Copyright (c) 1987-1993 Massachusetts Institute of Technology
#define REGBLOCK_CLOSURE_SPACE 10 /* For use by compiler */
#define REGBLOCK_STACK_GUARD 11
#define REGBLOCK_INT_CODE 12
-#define REGBLOCK_MINIMUM_LENGTH 13
+#define REGBLOCK_REFLECT_TO_INTERFACE 13 /* For use by compiler */
+
+#define REGBLOCK_MINIMUM_LENGTH 14
\f
/* Codes specifying how to start scheme at boot time. */
/* -*-C-*-
-$Id: fixobj.h,v 9.34 1993/08/28 22:46:36 gjr Exp $
+$Id: fixobj.h,v 9.35 1993/09/11 02:45:53 gjr Exp $
Copyright (c) 1987-1993 Massachusetts Institute of Technology
#define PC_Sample_Prob_Comp_Table 0x3D /* Sure looked compiled ?! */
#define PC_Sample_UFO_Table 0x3E /* Invalid ENV at sample time */
+#define COMPILED_CODE_BKPT_HANDLER 0x3F
-
-#define NFixed_Objects 0x3F
+#define NFixed_Objects 0x40
;;; -*-Scheme-*-
;;;
-;;; $Id: utabmd.scm,v 9.70 1993/08/28 21:17:23 gjr Exp $
+;;; $Id: utabmd.scm,v 9.71 1993/09/11 02:45:59 gjr Exp $
;;;
;;; Copyright (c) 1987-1993 Massachusetts Institute of Technology
;;;
PC-Sample/Interp-Proc-Buffer ;3C
PC-Sample/Prob-Comp-Table ;3D
PC-Sample/UFO-Table ;3E
+ COMPILED-CODE-BKPT-HANDLER ;3F
))
\f
;;; [] Types
;;; This identification string is saved by the system.
-"$Id: utabmd.scm,v 9.70 1993/08/28 21:17:23 gjr Exp $"
\ No newline at end of file
+"$Id: utabmd.scm,v 9.71 1993/09/11 02:45:59 gjr Exp $"
\ No newline at end of file
projects / mit-scheme.git / commitdiff