aborting to the interpreter (canonicalizing context).
/* -*-C-*-
-$Id: cmpint.c,v 1.52 1992/10/27 01:25:22 jinx Exp $
+$Id: cmpint.c,v 1.53 1992/10/27 22:00:04 jinx Exp $
Copyright (c) 1989-1992 Massachusetts Institute of Technology
EXFUN (compiled_block_environment, (SCHEME_OBJECT block)),
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 (compiled_entry_to_block, (SCHEME_OBJECT entry)),
+ EXFUN (apply_compiled_from_primitive, (int));
extern C_UTILITY void
EXFUN (compiler_initialize, (long fasl_p)),
EXFUN (comp_error_restart, (void));
extern utility_table_entry utility_table[];
+
+static SCHEME_OBJECT apply_in_interpreter;
\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_OTHER TRAMPOLINE_K_INTERPRETED
return (C_to_interface (compiled_entry_address));
}
-
+\f
C_TO_SCHEME long
DEFUN_VOID (apply_compiled_procedure)
{
SCHEME_OBJECT nactuals, procedure;
- instruction *procedure_entry;
+ instruction * procedure_entry;
long result;
nactuals = (STACK_POP ());
return (C_to_interface (compiled_entry_address));
}
\f
+C_UTILITY SCHEME_OBJECT
+DEFUN (apply_compiled_from_primitive, (arity), int arity)
+{
+ SCHEME_OBJECT frame_size, procedure;
+ long result;
+
+ frame_size = (STACK_POP ());
+ procedure = (STACK_POP ());
+
+ switch (OBJECT_TYPE (procedure))
+ {
+ case TC_ENTITY:
+ {
+ SCHEME_OBJECT data, operator;
+ long nactuals = (OBJECT_DATUM (frame_size));
+
+ data = (MEMORY_REF (procedure, ENTITY_DATA));
+ if ((VECTOR_P (data))
+ && (nactuals < (VECTOR_LENGTH (data)))
+ && (COMPILED_CODE_ADDRESS_P (VECTOR_REF (data, nactuals)))
+ && ((VECTOR_REF (data, 0))
+ == (Get_Fixed_Obj_Slot (ARITY_DISPATCHER_TAG))))
+ procedure = (VECTOR_REF (data, nactuals));
+ else
+ {
+ operator = (MEMORY_REF (procedure, ENTITY_OPERATOR));
+ if (!COMPILED_CODE_ADDRESS_P (operator))
+ break;
+ STACK_PUSH (procedure);
+ frame_size += 1;
+ procedure = operator;
+ }
+ /* fall through */
+ }
+
+ case TC_COMPILED_ENTRY:
+ {
+ result = setup_compiled_invocation ((OBJECT_DATUM (frame_size)),
+ ((instruction *)
+ (OBJECT_ADDRESS (procedure))));
+ if (result == PRIM_DONE)
+ {
+ STACK_PUSH (procedure);
+ Stack_Pointer = (STACK_LOC (- arity));
+ return (SHARP_F);
+ }
+ else
+ break;
+ }
+
+ case TC_PRIMITIVE:
+ /* For now, fall through */
+
+ default:
+ break;
+ }
+
+ STACK_PUSH (procedure);
+ STACK_PUSH (frame_size);
+ STACK_PUSH (apply_in_interpreter);
+ Stack_Pointer = (STACK_LOC (- arity));
+ 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 struct utility_result
+DEFUN (comutil_apply_in_interpreter,
+ (tramp_data, ignore_2, ignore_3, ignore_4),
+ SCHEME_OBJECT * tramp_data
+ AND long ignore_2 AND long ignore_3 AND long ignore_4)
+{
+ RETURN_TO_C (PRIM_APPLY);
+}
+
/*
comutil_primitive_apply is used to invoked a C primitive.
Note that some C primitives (the so called interpreter hooks)
# define TC_TRAMPOLINE_HEADER TC_MANIFEST_VECTOR
#endif
+static void
+DEFUN (fill_trampoline,
+ (block, entry_point, fmt_word, kind),
+ SCHEME_OBJECT * block
+ AND instruction * entry_point
+ AND format_word fmt_word
+ AND long kind)
+{
+ (COMPILED_ENTRY_FORMAT_WORD (entry_point)) = fmt_word;
+ (COMPILED_ENTRY_OFFSET_WORD (entry_point)) =
+ (MAKE_OFFSET_WORD (entry_point, block, false));
+ STORE_TRAMPOLINE_ENTRY (entry_point, kind);
+ return;
+}
+
static long
DEFUN (make_trampoline,
(slot, fmt_word, kind, size, value1, value2, value3),
AND SCHEME_OBJECT value1 AND SCHEME_OBJECT value2
AND SCHEME_OBJECT value3)
{
- SCHEME_OBJECT * block, * local_free;
instruction * entry_point;
+ SCHEME_OBJECT * ptr;
if (GC_Check (TRAMPOLINE_SIZE + size))
{
return (PRIM_INTERRUPT);
}
- local_free = Free;
+ ptr = Free;
Free += (TRAMPOLINE_SIZE + size);
- block = local_free;
- local_free[0] = (MAKE_OBJECT (TC_TRAMPOLINE_HEADER,
+ ptr[0] = (MAKE_OBJECT (TC_TRAMPOLINE_HEADER,
((TRAMPOLINE_SIZE - 1) + size)));
- local_free[1] = (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR,
- TRAMPOLINE_ENTRY_SIZE));
- entry_point = ((instruction *) (TRAMPOLINE_ENTRY_POINT (local_free)));
- local_free = (TRAMPOLINE_STORAGE (entry_point));
- (COMPILED_ENTRY_FORMAT_WORD (entry_point)) = fmt_word;
- (COMPILED_ENTRY_OFFSET_WORD (entry_point)) =
- (MAKE_OFFSET_WORD (entry_point, block, false));
- STORE_TRAMPOLINE_ENTRY (entry_point, kind);
-
+ ptr[1] = (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR,
+ TRAMPOLINE_ENTRY_SIZE));
+ entry_point = ((instruction *) (TRAMPOLINE_ENTRY_POINT (ptr)));
+ fill_trampoline (ptr, entry_point, fmt_word, kind);
+ *slot = (ENTRY_TO_OBJECT (entry_point));
+ ptr = (TRAMPOLINE_STORAGE (entry_point));
if ((--size) >= 0)
- *local_free++ = value1;
+ *ptr++ = value1;
if ((--size) >= 0)
- *local_free++ = value2;
+ *ptr++ = value2;
if ((--size) >= 0)
- *local_free++ = value3;
- *slot = (ENTRY_TO_OBJECT (entry_point));
+ *ptr++ = value3;
return (PRIM_DONE);
}
\f
UTE(comutil_primitive_error), /* 0x36 */
UTE(comutil_quotient), /* 0x37 */
UTE(comutil_remainder), /* 0x38 */
- UTE(comutil_modulo) /* 0x39 */
+ UTE(comutil_modulo), /* 0x39 */
+ UTE(comutil_apply_in_interpreter) /* 0x3a */
};
\f
/* Initialization */
static void
DEFUN_VOID (compiler_reset_internal)
{
+ long len;
+ SCHEME_OBJECT * block;
/* Other stuff can be placed here. */
Registers[REGBLOCK_CLOSURE_FREE] = ((SCHEME_OBJECT) NULL);
ASM_RESET_HOOK();
+ block = (OBJECT_ADDRESS (compiler_utilities));
+ len = (OBJECT_DATUM (block[0]));
return_to_interpreter =
- (ENTRY_TO_OBJECT (TRAMPOLINE_ENTRY_POINT
- (OBJECT_ADDRESS (compiler_utilities))));
-
+ (ENTRY_TO_OBJECT (((char *) block)
+ + ((unsigned long) (block [len - 1]))));
+ apply_in_interpreter =
+ (ENTRY_TO_OBJECT (((char *) block)
+ + ((unsigned long) (block [len]))));
return;
}
\f
{
/* Called after a disk restore */
- if ((OBJECT_TYPE (new_block)) != TC_COMPILED_CODE_BLOCK)
+ if (((OBJECT_TYPE (new_block)) != TC_COMPILED_CODE_BLOCK)
+ || ((OBJECT_TYPE (MEMORY_REF (new_block, 0))) != TC_MANIFEST_NM_VECTOR))
{
extern void EXFUN (compiler_reset_error, (void));
{
/* Start-up of whole interpreter */
- long code;
- SCHEME_OBJECT trampoline, *block;
-
compiler_processor_type = COMPILER_PROCESSOR_TYPE;
compiler_interface_version = COMPILER_INTERFACE_VERSION;
if (fasl_p)
{
+ long len;
+ instruction * tramp1, * tramp2;
+ SCHEME_OBJECT * block;
extern SCHEME_OBJECT * EXFUN (copy_to_constant_space,
(SCHEME_OBJECT *, long));
- code = (make_trampoline (&trampoline,
- ((format_word) FORMAT_WORD_RETURN),
- TRAMPOLINE_K_RETURN,
- 0, SHARP_F, SHARP_F, SHARP_F));
- if (code != PRIM_DONE)
+ len = ((2 * TRAMPOLINE_ENTRY_SIZE) + 3);
+ if (GC_Check (len))
{
fprintf (stderr,
"compiler_initialize: Not enough space!\n");
Microcode_Termination (TERM_NO_SPACE);
}
- block = (compiled_entry_to_block_address (trampoline));
- block = (copy_to_constant_space (block, (1 + (OBJECT_DATUM (block[0])))));
+
+ 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);
+ fill_trampoline (block, tramp2,
+ ((format_word) FORMAT_WORD_RETURN),
+ TRAMPOLINE_K_APPLY_IN_INTERPRETER);
+ block[len - 2] = (((char *) tramp1) - ((char *) block));
+ 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_block_environment, (SCHEME_OBJECT block)),
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 (compiled_entry_to_block, (SCHEME_OBJECT entry)),
+ EXFUN (apply_compiled_from_primitive, (int));
extern void
EXFUN (compiler_reset, (SCHEME_OBJECT new_block)),
return (ERR_INAPPLICABLE_CONTINUATION);
}
+SCHEME_OBJECT
+DEFUN (apply_compiled_from_primitive, (arity), int arity)
+{
+ signal_error_from_primitive (ERR_INAPPLICABLE_CONTINUATION);
+ /*NOTREACHED*/
+}
+
/* Bad entry points. */
long
/* -*-C-*-
-$Id: hooks.c,v 9.45 1992/09/18 05:53:31 jinx Exp $
+$Id: hooks.c,v 9.46 1992/10/27 22:00:13 jinx Exp $
Copyright (c) 1988-1992 Massachusetts Institute of Technology
#include "winder.h"
#include "history.h"
\f
+#define APPLY_AVOID_CANONICALIZATION
+
DEFINE_PRIMITIVE ("APPLY", Prim_apply, 2, 2, 0)
{
SCHEME_OBJECT procedure;
SCHEME_OBJECT argument_list;
fast long number_of_args;
-#ifdef LOSING_PARALLEL_PROCESSOR
- SCHEME_OBJECT * saved_stack_pointer;
-#endif
PRIMITIVE_HEADER (2);
+
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
list into a linear (vector-like) form, so as to avoid the
overhead of traversing the list twice. Unfortunately, the
overhead of maintaining this other form (e.g. PRIMITIVE_GC_If_Needed)
- is sufficiently high that it probably makes up for the time saved. */
+ is sufficiently high that it probably makes up for the time saved.
+ */
PRIMITIVE_CANONICALIZE_CONTEXT ();
+#endif /* APPLY_AVOID_CANONICALIZATION */
{
- fast SCHEME_OBJECT scan_list;
+ fast SCHEME_OBJECT scan_list, scan_list_trail;
TOUCH_IN_PRIMITIVE (argument_list, scan_list);
- number_of_args = 0;
- while (PAIR_P (scan_list))
+ if (! (PAIR_P (scan_list)))
+ number_of_args = 0;
+ else
+ {
+ number_of_args = 1;
+ scan_list_trail = scan_list;
+ TOUCH_IN_PRIMITIVE ((PAIR_CDR (scan_list)), scan_list);
+ while (true)
{
- number_of_args += 1;
+ if (scan_list == scan_list_trail)
+ error_bad_range_arg (2);
+ if (! (PAIR_P (scan_list)))
+ break;
+ TOUCH_IN_PRIMITIVE ((PAIR_CDR (scan_list)), scan_list);
+ if (scan_list == scan_list_trail)
+ error_bad_range_arg (2);
+ if (! (PAIR_P (scan_list)))
+ {
+ number_of_args += 1;
+ break;
+ }
TOUCH_IN_PRIMITIVE ((PAIR_CDR (scan_list)), scan_list);
+ scan_list_trail = (PAIR_CDR (scan_list_trail));
+ number_of_args += 2;
}
+ }
if (scan_list != EMPTY_LIST)
error_wrong_type_arg (2);
}
+
#ifdef USE_STACKLETS
/* This is conservative: if the number of arguments is large enough
the Will_Push below may try to allocate space on the heap for the
stack frame. */
Primitive_GC_If_Needed
(New_Stacklet_Size (number_of_args + STACK_ENV_EXTRA_SLOTS + 1));
-#endif
+#endif /* USE_STACKLETS */
+
POP_PRIMITIVE_FRAME (2);
+
Will_Push (number_of_args + STACK_ENV_EXTRA_SLOTS + 1);
-#ifdef LOSING_PARALLEL_PROCESSOR
- saved_stack_pointer = Stack_Pointer;
-#endif
{
fast long i;
fast SCHEME_OBJECT * scan_stack = (STACK_LOC (- number_of_args));
fast SCHEME_OBJECT scan_list;
- Stack_Pointer = scan_stack;
TOUCH_IN_PRIMITIVE (argument_list, scan_list);
for (i = number_of_args; (i > 0); i -= 1)
{
/* Check for abominable case of someone bashing the arg list. */
if (! (PAIR_P (scan_list)))
{
- Stack_Pointer = saved_stack_pointer;
+ /* Re-push the primitive's frame. */
+ STACK_PUSH (argument_list);
+ STACK_PUSH (procedure);
error_bad_range_arg (2);
}
#endif
TOUCH_IN_PRIMITIVE ((PAIR_CDR (scan_list)), scan_list);
}
}
+ Stack_Pointer = (STACK_LOC (- number_of_args));
STACK_PUSH (procedure);
STACK_PUSH (STACK_FRAME_HEADER + number_of_args);
Pushed ();
+
+#ifdef APPLY_AVOID_CANONICALIZATION
+ if (COMPILED_CODE_ADDRESS_P (STACK_REF (number_of_args + 2)))
+ {
+ extern SCHEME_OBJECT EXFUN (apply_compiled_from_primitive, (int));
+ return (apply_compiled_from_primitive (2));
+ }
+#endif /* APPLY_AVOID_CANONICALIZATION */
+
PRIMITIVE_ABORT (PRIM_APPLY);
/*NOTREACHED*/
}
/* -*-C-*-
-$Id: version.h,v 11.121 1992/09/26 02:55:06 cph Exp $
+$Id: version.h,v 11.122 1992/10/27 21:59:55 jinx Exp $
-Copyright (c) 1988-92 Massachusetts Institute of Technology
+Copyright (c) 1988-1992 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
#define VERSION 11
#endif
#ifndef SUBVERSION
-#define SUBVERSION 121
+#define SUBVERSION 122
#endif
/* -*-C-*-
-$Id: cmpint.c,v 1.52 1992/10/27 01:25:22 jinx Exp $
+$Id: cmpint.c,v 1.53 1992/10/27 22:00:04 jinx Exp $
Copyright (c) 1989-1992 Massachusetts Institute of Technology
EXFUN (compiled_block_environment, (SCHEME_OBJECT block)),
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 (compiled_entry_to_block, (SCHEME_OBJECT entry)),
+ EXFUN (apply_compiled_from_primitive, (int));
extern C_UTILITY void
EXFUN (compiler_initialize, (long fasl_p)),
EXFUN (comp_error_restart, (void));
extern utility_table_entry utility_table[];
+
+static SCHEME_OBJECT apply_in_interpreter;
\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_OTHER TRAMPOLINE_K_INTERPRETED
return (C_to_interface (compiled_entry_address));
}
-
+\f
C_TO_SCHEME long
DEFUN_VOID (apply_compiled_procedure)
{
SCHEME_OBJECT nactuals, procedure;
- instruction *procedure_entry;
+ instruction * procedure_entry;
long result;
nactuals = (STACK_POP ());
return (C_to_interface (compiled_entry_address));
}
\f
+C_UTILITY SCHEME_OBJECT
+DEFUN (apply_compiled_from_primitive, (arity), int arity)
+{
+ SCHEME_OBJECT frame_size, procedure;
+ long result;
+
+ frame_size = (STACK_POP ());
+ procedure = (STACK_POP ());
+
+ switch (OBJECT_TYPE (procedure))
+ {
+ case TC_ENTITY:
+ {
+ SCHEME_OBJECT data, operator;
+ long nactuals = (OBJECT_DATUM (frame_size));
+
+ data = (MEMORY_REF (procedure, ENTITY_DATA));
+ if ((VECTOR_P (data))
+ && (nactuals < (VECTOR_LENGTH (data)))
+ && (COMPILED_CODE_ADDRESS_P (VECTOR_REF (data, nactuals)))
+ && ((VECTOR_REF (data, 0))
+ == (Get_Fixed_Obj_Slot (ARITY_DISPATCHER_TAG))))
+ procedure = (VECTOR_REF (data, nactuals));
+ else
+ {
+ operator = (MEMORY_REF (procedure, ENTITY_OPERATOR));
+ if (!COMPILED_CODE_ADDRESS_P (operator))
+ break;
+ STACK_PUSH (procedure);
+ frame_size += 1;
+ procedure = operator;
+ }
+ /* fall through */
+ }
+
+ case TC_COMPILED_ENTRY:
+ {
+ result = setup_compiled_invocation ((OBJECT_DATUM (frame_size)),
+ ((instruction *)
+ (OBJECT_ADDRESS (procedure))));
+ if (result == PRIM_DONE)
+ {
+ STACK_PUSH (procedure);
+ Stack_Pointer = (STACK_LOC (- arity));
+ return (SHARP_F);
+ }
+ else
+ break;
+ }
+
+ case TC_PRIMITIVE:
+ /* For now, fall through */
+
+ default:
+ break;
+ }
+
+ STACK_PUSH (procedure);
+ STACK_PUSH (frame_size);
+ STACK_PUSH (apply_in_interpreter);
+ Stack_Pointer = (STACK_LOC (- arity));
+ 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 struct utility_result
+DEFUN (comutil_apply_in_interpreter,
+ (tramp_data, ignore_2, ignore_3, ignore_4),
+ SCHEME_OBJECT * tramp_data
+ AND long ignore_2 AND long ignore_3 AND long ignore_4)
+{
+ RETURN_TO_C (PRIM_APPLY);
+}
+
/*
comutil_primitive_apply is used to invoked a C primitive.
Note that some C primitives (the so called interpreter hooks)
# define TC_TRAMPOLINE_HEADER TC_MANIFEST_VECTOR
#endif
+static void
+DEFUN (fill_trampoline,
+ (block, entry_point, fmt_word, kind),
+ SCHEME_OBJECT * block
+ AND instruction * entry_point
+ AND format_word fmt_word
+ AND long kind)
+{
+ (COMPILED_ENTRY_FORMAT_WORD (entry_point)) = fmt_word;
+ (COMPILED_ENTRY_OFFSET_WORD (entry_point)) =
+ (MAKE_OFFSET_WORD (entry_point, block, false));
+ STORE_TRAMPOLINE_ENTRY (entry_point, kind);
+ return;
+}
+
static long
DEFUN (make_trampoline,
(slot, fmt_word, kind, size, value1, value2, value3),
AND SCHEME_OBJECT value1 AND SCHEME_OBJECT value2
AND SCHEME_OBJECT value3)
{
- SCHEME_OBJECT * block, * local_free;
instruction * entry_point;
+ SCHEME_OBJECT * ptr;
if (GC_Check (TRAMPOLINE_SIZE + size))
{
return (PRIM_INTERRUPT);
}
- local_free = Free;
+ ptr = Free;
Free += (TRAMPOLINE_SIZE + size);
- block = local_free;
- local_free[0] = (MAKE_OBJECT (TC_TRAMPOLINE_HEADER,
+ ptr[0] = (MAKE_OBJECT (TC_TRAMPOLINE_HEADER,
((TRAMPOLINE_SIZE - 1) + size)));
- local_free[1] = (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR,
- TRAMPOLINE_ENTRY_SIZE));
- entry_point = ((instruction *) (TRAMPOLINE_ENTRY_POINT (local_free)));
- local_free = (TRAMPOLINE_STORAGE (entry_point));
- (COMPILED_ENTRY_FORMAT_WORD (entry_point)) = fmt_word;
- (COMPILED_ENTRY_OFFSET_WORD (entry_point)) =
- (MAKE_OFFSET_WORD (entry_point, block, false));
- STORE_TRAMPOLINE_ENTRY (entry_point, kind);
-
+ ptr[1] = (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR,
+ TRAMPOLINE_ENTRY_SIZE));
+ entry_point = ((instruction *) (TRAMPOLINE_ENTRY_POINT (ptr)));
+ fill_trampoline (ptr, entry_point, fmt_word, kind);
+ *slot = (ENTRY_TO_OBJECT (entry_point));
+ ptr = (TRAMPOLINE_STORAGE (entry_point));
if ((--size) >= 0)
- *local_free++ = value1;
+ *ptr++ = value1;
if ((--size) >= 0)
- *local_free++ = value2;
+ *ptr++ = value2;
if ((--size) >= 0)
- *local_free++ = value3;
- *slot = (ENTRY_TO_OBJECT (entry_point));
+ *ptr++ = value3;
return (PRIM_DONE);
}
\f
UTE(comutil_primitive_error), /* 0x36 */
UTE(comutil_quotient), /* 0x37 */
UTE(comutil_remainder), /* 0x38 */
- UTE(comutil_modulo) /* 0x39 */
+ UTE(comutil_modulo), /* 0x39 */
+ UTE(comutil_apply_in_interpreter) /* 0x3a */
};
\f
/* Initialization */
static void
DEFUN_VOID (compiler_reset_internal)
{
+ long len;
+ SCHEME_OBJECT * block;
/* Other stuff can be placed here. */
Registers[REGBLOCK_CLOSURE_FREE] = ((SCHEME_OBJECT) NULL);
ASM_RESET_HOOK();
+ block = (OBJECT_ADDRESS (compiler_utilities));
+ len = (OBJECT_DATUM (block[0]));
return_to_interpreter =
- (ENTRY_TO_OBJECT (TRAMPOLINE_ENTRY_POINT
- (OBJECT_ADDRESS (compiler_utilities))));
-
+ (ENTRY_TO_OBJECT (((char *) block)
+ + ((unsigned long) (block [len - 1]))));
+ apply_in_interpreter =
+ (ENTRY_TO_OBJECT (((char *) block)
+ + ((unsigned long) (block [len]))));
return;
}
\f
{
/* Called after a disk restore */
- if ((OBJECT_TYPE (new_block)) != TC_COMPILED_CODE_BLOCK)
+ if (((OBJECT_TYPE (new_block)) != TC_COMPILED_CODE_BLOCK)
+ || ((OBJECT_TYPE (MEMORY_REF (new_block, 0))) != TC_MANIFEST_NM_VECTOR))
{
extern void EXFUN (compiler_reset_error, (void));
{
/* Start-up of whole interpreter */
- long code;
- SCHEME_OBJECT trampoline, *block;
-
compiler_processor_type = COMPILER_PROCESSOR_TYPE;
compiler_interface_version = COMPILER_INTERFACE_VERSION;
if (fasl_p)
{
+ long len;
+ instruction * tramp1, * tramp2;
+ SCHEME_OBJECT * block;
extern SCHEME_OBJECT * EXFUN (copy_to_constant_space,
(SCHEME_OBJECT *, long));
- code = (make_trampoline (&trampoline,
- ((format_word) FORMAT_WORD_RETURN),
- TRAMPOLINE_K_RETURN,
- 0, SHARP_F, SHARP_F, SHARP_F));
- if (code != PRIM_DONE)
+ len = ((2 * TRAMPOLINE_ENTRY_SIZE) + 3);
+ if (GC_Check (len))
{
fprintf (stderr,
"compiler_initialize: Not enough space!\n");
Microcode_Termination (TERM_NO_SPACE);
}
- block = (compiled_entry_to_block_address (trampoline));
- block = (copy_to_constant_space (block, (1 + (OBJECT_DATUM (block[0])))));
+
+ 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);
+ fill_trampoline (block, tramp2,
+ ((format_word) FORMAT_WORD_RETURN),
+ TRAMPOLINE_K_APPLY_IN_INTERPRETER);
+ block[len - 2] = (((char *) tramp1) - ((char *) block));
+ 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_block_environment, (SCHEME_OBJECT block)),
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 (compiled_entry_to_block, (SCHEME_OBJECT entry)),
+ EXFUN (apply_compiled_from_primitive, (int));
extern void
EXFUN (compiler_reset, (SCHEME_OBJECT new_block)),
return (ERR_INAPPLICABLE_CONTINUATION);
}
+SCHEME_OBJECT
+DEFUN (apply_compiled_from_primitive, (arity), int arity)
+{
+ signal_error_from_primitive (ERR_INAPPLICABLE_CONTINUATION);
+ /*NOTREACHED*/
+}
+
/* Bad entry points. */
long
/* -*-C-*-
-$Id: version.h,v 11.121 1992/09/26 02:55:06 cph Exp $
+$Id: version.h,v 11.122 1992/10/27 21:59:55 jinx Exp $
-Copyright (c) 1988-92 Massachusetts Institute of Technology
+Copyright (c) 1988-1992 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
#define VERSION 11
#endif
#ifndef SUBVERSION
-#define SUBVERSION 121
+#define SUBVERSION 122
#endif
projects / mit-scheme.git / commitdiff