apply the values contained in the fixed objects vector.
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/cmpint.c,v 1.9 1989/10/26 04:23:27 jinx Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/cmpint.c,v 1.10 1989/10/27 13:26:24 jinx Exp $
*
* This file corresponds to
- * $COMPILER-Header: compiler.c,v 9.35 88/10/26 20:02:13 GMT cph Exp $
- * $MC68020-Header: cmp68020.m4,v 9.86 89/04/19 02:24:19 GMT arthur Exp $
+ * $COMPILER-Header: compiler.c,v 9.37 89/10/25 14:55:45 GMT jinx Exp $
+ * $MC68020-Header: cmp68020.m4,v 9.93 89/10/26 07:49:23 GMT cph Exp $
*
* Compiled code interface. Portable version.
* This file requires a bit of assembly language described in cmpaux.m4
/* Macro imports */
#include "config.h" /* SCHEME_OBJECT type and machine dependencies */
-#include "object.h" /* Making and destructuring Scheme objects */
-#include "sdata.h" /* Needed by const.h */
#include "types.h" /* Needed by const.h */
-#include "errors.h" /* Error codes and Termination codes */
#include "const.h" /* REGBLOCK_MINIMUM_LENGTH and PRIM_... codes */
-#include "trap.h" /* UNASSIGNED_OBJECT, TRAP_EXTENSION_TYPE */
-#include "interp.h" /* Interpreter state and primitive destructuring */
-#include "prims.h" /* LEXPR */
-#include "cmpint.h" /* Compiled code object destructuring */
+#include "object.h" /* Making and destructuring Scheme objects */
+#include "intrpt.h" /* Interrupt processing macros */
+#include "gc.h" /* Request_GC, etc. */
#include "cmpgc.h" /* Compiled code object relocation */
+#include "errors.h" /* Error codes and Termination codes */
+#include "returns.h" /* Return addresses in the interpreter */
+#include "fixobj.h" /* To find the error handlers */
+#include "stack.h" /* Stacks and stacklets */
+#include "interp.h" /* Interpreter state and primitive destructuring */
#include "default.h" /* Metering_Apply_Primitive */
+#include "extern.h" /* External decls (missing Cont_Debug, etc.) */
+#include "trap.h" /* UNASSIGNED_OBJECT, TRAP_EXTENSION_TYPE */
+#include "prims.h" /* LEXPR */
+#include "cmpint2.h" /* Compiled code object destructuring */
\f
/* Make noise words invisible to the C compiler. */
/* Structure returned by SCHEME_UTILITYs */
+typedef char instruction; /* (instruction *) is a pointer to a
+ native instruction. */
+
struct utility_result
{
void (*interface_dispatch)();
union additional_info
{
long code_to_interpreter;
- machine_word *entry_point;
+ instruction *entry_point;
} extra;
};
enter_compiled_expression(),
apply_compiled_procedure(),
return_to_compiled_code(),
- comp_link_caches_restart();
+ comp_link_caches_restart(),
+ comp_op_lookup_trap_restart(),
+ comp_interrupt_restart(),
+ comp_assignment_trap_restart(),
+ comp_cache_lookup_apply_restart(),
+ comp_lookup_trap_restart(),
+ safe_lookup_trap_restart(),
+ comp_unassigned_p_trap_restart(),
+ comp_access_restart(),
+ comp_reference_restart(),
+ comp_safe_reference_restart(),
+ comp_unassigned_p_restart(),
+ comp_unbound_p_restart(),
+ comp_assignment_restart(),
+ comp_definition_restart(),
+ comp_lookup_apply_restart();
\f
extern SCHEME_UTILITY struct utility_result
comutil_return_to_interpreter(),
#define TRAMPOLINE_K_4_2 0xf
#define TRAMPOLINE_K_4_1 0x10
#define TRAMPOLINE_K_4_0 0x11
+
+#define TRAMPOLINE_K_OTHER TRAMPOLINE_K_INTERPRETED
\f
/* Main compiled code entry points.
These are the primary entry points that the interpreter
{
/* It self evaluates. */
Val = (Fetch_Expression ());
- return (PRIM_DONE);
+ return (C_to_interface ((instruction *) (OBJECT_ADDRESS (STACK_POP ()))));
}
- return (C_to_interface((machine_word *) compiled_entry_address));
+ return (C_to_interface ((instruction *) compiled_entry_address));
}
C_TO_SCHEME long
{
static long setup_compiled_invocation();
SCHEME_OBJECT nactuals, procedure;
- machine_word *procedure_entry;
+ instruction *procedure_entry;
long result;
nactuals = (STACK_POP ());
procedure = (STACK_POP ());
- procedure_entry = ((machine_word *) (OBJECT_ADDRESS (procedure)));
+ procedure_entry = ((instruction *) (OBJECT_ADDRESS (procedure)));
result = setup_compiled_invocation ((OBJECT_DATUM (nactuals)),
- (procedure_entry));
+ ((machine_word *) procedure_entry));
if (result == PRIM_DONE)
{
/* Go into compiled code. */
C_TO_SCHEME long
return_to_compiled_code ()
{
- machine_word *compiled_entry_address;
+ instruction *compiled_entry_address;
compiled_entry_address =
- ((machine_word *) (OBJECT_ADDRESS (STACK_POP ())));
+ ((instruction *) (OBJECT_ADDRESS (STACK_POP ())));
return (C_to_interface (compiled_entry_address));
}
\f
case TC_COMPILED_ENTRY:
callee_is_compiled:
{
- machine_word *entry_point;
+ instruction *entry_point;
- entry_point = ((machine_word *) (OBJECT_ADDRESS (procedure)));
+ entry_point = ((instruction *) (OBJECT_ADDRESS (procedure)));
RETURN_UNLESS_EXCEPTION
- ((setup_compiled_invocation (nactuals, entry_point)),
+ ((setup_compiled_invocation (nactuals,
+ ((machine_word *) entry_point))),
entry_point);
}
default:
{
STACK_PUSH (procedure);
- STACK_PUSH (MAKE_UNSIGNED_FIXNUM (nactuals));
+ STACK_PUSH (LONG_TO_UNSIGNED_FIXNUM (nactuals));
RETURN_TO_C (PRIM_APPLY);
}
}
SCHEME_UTILITY struct utility_result
comutil_lexpr_apply (entry_address, nactuals, ignore_3, ignore_4)
- register machine_word *entry_address;
+ register instruction *entry_address;
long nactuals;
long ignore_3, ignore_4;
{
((kind) | \
(((kind) != OPERATOR_LINKAGE_KIND) ? \
(count) : \
- ((count) * OPERATOR_LINK_ENTRY_SIZE)))))
+ ((count) * EXECUTE_CACHE_ENTRY_SIZE)))))
static long
link_cc_block (block_address, offset, last_header_offset,
register SCHEME_OBJECT block_address;
register long offset;
long last_header_offset, sections, original_count;
- machine_word *ret_add;
+ instruction *ret_add;
{
+ Boolean execute_p;
register long entry_size, count;
register SCHEME_OBJECT block;
SCHEME_OBJECT header;
kind = (READ_LINKAGE_KIND (header));
if (kind == OPERATOR_LINKAGE_KIND)
{
- entry_size = OPERATOR_LINK_ENTRY_SIZE;
+ execute_p = true;
+ entry_size = EXECUTE_CACHE_ENTRY_SIZE;
cache_handler = compiler_cache_operator;
count = (READ_OPERATOR_LINKAGE_COUNT (header));
}
else
{
+ execute_p = false;
entry_size = 1;
cache_handler = ((kind == REFERENCE_LINKAGE_KIND) ?
compiler_cache_lookup :
\f
for (offset += 1; ((--count) >= 0); offset += entry_size)
{
- result = ((*cache_handler)
- ((block_address[offset]), /* name of variable */
- block,
- offset));
+ SCHEME_OBJECT name;
+
+ if (!execute_p)
+ {
+ name = (block[offset]);
+ }
+ else
+ {
+ EXTRACT_EXECUTE_CACHE_SYMBOL(name, &(block[offset]));
+ }
+ result = ((*cache_handler)(name, block, offset));
if (result != PRIM_DONE)
{
*/
STACK_PUSH (ENTRY_TO_OBJECT (ret_add));
- STACK_PUSH (MAKE_UNSIGNED_FIXNUM (sections + 1));
- STACK_PUSH (MAKE_UNSIGNED_FIXNUM (last_header_offset));
- STACK_PUSH (MAKE_UNSIGNED_FIXNUM (offset - 1));
+ STACK_PUSH (LONG_TO_UNSIGNED_FIXNUM (sections + 1));
+ STACK_PUSH (LONG_TO_UNSIGNED_FIXNUM (last_header_offset));
+ STACK_PUSH (LONG_TO_UNSIGNED_FIXNUM (offset - 1));
STACK_PUSH (block);
- STACK_PUSH (MAKE_UNSIGNED_FIXNUM (count + 1));
+ STACK_PUSH (LONG_TO_UNSIGNED_FIXNUM (count + 1));
- Store_Expresion (MAKE_UNSIGNED_FIXNUM (total_count));
+ Store_Expresion (LONG_TO_UNSIGNED_FIXNUM (total_count));
Store_Return (RC_COMP_LINK_CACHES_RESTART);
Save_Cont ();
SCHEME_UTILITY struct utility_result
comutil_link (ret_add, block_address, constant_address, sections)
- machine_word *ret_add;
+ instruction *ret_add;
SCHEME_OBJECT *block_address, *constant_address;
long sections;
{
{
SCHEME_OBJECT block;
long original_count, offset, last_header_offset, sections, code;
- machine_word *ret_add;
+ instruction *ret_add;
original_count = (OBJECT_DATUM (Fetch_Expression ()));
STACK_POP (); /* Pop count, not needed */
offset = (OBJECT_DATUM (STACK_POP ()));
last_header_offset = (OBJECT_DATUM (STACK_POP ()));
sections = (OBJECT_DATUM (STACK_POP ()));
- ret_add = ((machine_word *) (OBJECT_ADDRES (STACK_POP ())));
+ ret_add = ((instruction *) (OBJECT_ADDRESS (STACK_POP ())));
code = (link_cc_block ((OBJECT_ADDRESS (block)),
offset,
last_header_offset,
code = (complr_operator_reference_trap (&true_operator, (tramp_data[0])));
cache_cell = (MEMORY_LOC ((tramp_data[1]),
(OBJECT_DATUM (tramp_data[2]))));
- EXTRACT_OPERATOR_LINK_ARITY (nargs, cache_cell);
+ EXTRACT_EXECUTE_CACHE_ARITY (nargs, cache_cell);
if (code == PRIM_DONE)
{
return (comutil_apply (true_operator, nargs, 0, 0));
/* This could be done by bumpint tramp_data to the entry point.
It would probably be better.
*/
- EXTRACT_OPERATOR_LINK_ADDRESS (trampoline, cache_cell);
+ EXTRACT_EXECUTE_CACHE_ADDRESS (trampoline, cache_cell);
environment = (compiled_block_environment (tramp_data[1]));
name = (compiler_var_error ((tramp_data[0]), environment));
STACK_PUSH(ENTRY_TO_OBJECT(trampoline));
- STACK_PUSH(MAKE_UNSIGNED_FIXNUM(nargs)); /* For debugger */
+ STACK_PUSH(LONG_TO_UNSIGNED_FIXNUM(nargs)); /* For debugger */
STACK_PUSH(environment); /* For debugger */
Store_Expression(name);
Store_Return(RC_COMP_OP_REF_TRAP_RESTART);
old_trampoline = (OBJECT_ADDRESS (STACK_POP ()));
code_block = ((TRAMPOLINE_STORAGE (old_trampoline))[1]);
offset = (OBJECT_DATUM ((TRAMPOLINE_STORAGE (old_trampoline))[2]));
- EXTRACT_OPERATOR_LINK_ADDRESS (new_procedure,
+ EXTRACT_EXECUTE_CACHE_ADDRESS (new_procedure,
(MEMORY_LOC (code_block, offset)));
- return (C_to_interface ((machine_word *) (OBJECT_ADDRESS (new_procedure))));
+ return (C_to_interface ((instruction *) (OBJECT_ADDRESS (new_procedure))));
}
\f
/* ARITY Mismatch handling
{
SCHEME_OBJECT *entry_point;
- EXTRACT_COMPILED_CLOSURE_ENTRY_ADDRESS(entry_point,
- (OBJECT_ADDRESS (STACK_REF (0))));
- RETURN_TO_SCHEME(((machine_word *) entry_point) +
+ EXTRACT_CLOSURE_ENTRY_ADDRESS(entry_point,
+ (OBJECT_ADDRESS (STACK_REF (0))));
+ RETURN_TO_SCHEME(((instruction *) entry_point) +
CLOSURE_SKIPPED_CHECK_OFFSET);
}
else
SCHEME_UTILITY struct utility_result
comutil_interrupt_procedure (entry_point, state, ignore_3, ignore_4)
- machine_word *entry_point;
+ instruction *entry_point;
SCHEME_OBJECT state;
long ignore_3, ignore_4;
{
SCHEME_UTILITY struct utility_result
comutil_interrupt_continuation (return_address, ignore_2, ignore_3, ignore_4)
- machine_word *return_address;
+ instruction *return_address;
long ignore_2, ignore_3, ignore_4;
{
return (comutil_interrupt_procedure (return_address, Val, 0, 0));
SCHEME_UTILITY struct utility_result
comutil_interrupt_ic_procedure (entry_point, ignore_2, ignore_3, ignore_4)
- machine_word *entry_point;
+ instruction *entry_point;
long ignore_2, ignore_3, ignore_4;
{
return (comutil_interrupt_procedure (entry_point, (Fetch_Env()), 0, 0));
C_TO_SCHEME long
comp_interrupt_restart ()
{
- Store_Env(Fetch_Expression());
- Val = Fetch_Expression();
- return (C_to_interface((machine_word *) (OBJECT_ADDRESS (STACK_POP ()))));
+ Store_Env (Fetch_Expression());
+ Val = (Fetch_Expression ());
+ return (C_to_interface ((instruction *) (OBJECT_ADDRESS (STACK_POP ()))));
}
\f
/* Other TRAPS */
SCHEME_UTILITY struct utility_result
comutil_assignment_trap (return_address, extension_addr, value, ignore_4)
- machine_word *return_address;
+ instruction *return_address;
SCHEME_OBJECT *extension_addr, value;
long ignore_4;
{
code = (Symbol_Lex_Set (environment, name, value));
if (code == PRIM_DONE)
{
- return (C_to_interface(OBJECT_ADDRESS (STACK_POP ())));
+ return (C_to_interface (OBJECT_ADDRESS (STACK_POP ())));
}
else
{
block = (MAKE_CC_BLOCK (block_address));
STACK_PUSH (block);
- STACK_PUSH (MAKE_UNSIGNED_FIXNUM (nactuals));
+ STACK_PUSH (LONG_TO_UNSIGNED_FIXNUM (nactuals));
environment = (compiled_block_environment (block));
STACK_PUSH (environment);
name = (compiler_var_error (extension, environment));
Store_Expression (name);
- Store_Return (RC_COMP_CACHE_LOOKUP_RESTART);
+ Store_Return (RC_COMP_CACHE_REF_APPLY_RESTART);
Save_Cont ();
RETURN_TO_C (code);
}
{
STACK_PUSH (environment);
Store_Expression (name);
- Store_Return (RC_COMP_CACHE_LOOKUP_RESTART);
+ Store_Return (RC_COMP_CACHE_REF_APPLY_RESTART);
Save_Cont ();
return (code);
}
#define CMPLR_REF_TRAP (name,c_trap,ret_code,restart_name,c_lookup) \
SCHEME_UTILITY struct utility_result \
name (return_address, extension_addr, ignore_3, ignore_4) \
- machine_word *return_address; \
+ instruction *return_address; \
SCHEME_OBJECT *extension_addr; \
long ignore_3, ignore_4; \
{ \
Symbol_Lex_unassigned_p);
\f
/* NUMERIC ROUTINES
- These just call the C primitives for now.
+ Invoke the arithmetic primitive in the fixed objects vector.
+ The Scheme arguments are expected on the Scheme stack.
*/
-static char *comp_arith_names[] =
-{
- "-1+", /* 0 */
- "&/", /* 1 */
- "&=", /* 2 */
- "&>", /* 3 */
- "1+", /* 4 */
- "&<", /* 5 */
- "&-", /* 6 */
- "&*", /* 7 */
- "NEGATIVE?", /* 8 */
- "&+", /* 9 */
- "POSITIVE?", /* 10 */
- "ZERO?" /* 11 */
-};
-
-static SCHEME_OBJECT
-comp_arith_prims[(sizeof(comp_arith_names))/(sizeof(char *))];
-
-#define COMPILER_ARITH_PRIM (name, index) \
+#define COMPILER_ARITH_PRIM (name, fobj_index, arity) \
SCHEME_UTILITY struct utility_result \
name (ignore_1, ignore_2, ignore_3, ignore_4) \
long ignore_1, ignore_2, ignore_3, ignore_4; \
{ \
- return (comutil_primitive_apply (comp_arith_prims [index])); \
-}
-
-COMPILER_ARITH_PRIM (comutil_decrement, 0);
-COMPILER_ARITH_PRIM (comutil_divide, 1);
-COMPILER_ARITH_PRIM (comutil_equal, 2);
-COMPILER_ARITH_PRIM (comutil_greater, 3);
-COMPILER_ARITH_PRIM (comutil_increment, 4);
-COMPILER_ARITH_PRIM (comutil_less, 5);
-COMPILER_ARITH_PRIM (comutil_minus, 6);
-COMPILER_ARITH_PRIM (comutil_multiply, 7);
-COMPILER_ARITH_PRIM (comutil_negative, 8);
-COMPILER_ARITH_PRIM (comutil_plus, 9);
-COMPILER_ARITH_PRIM (comutil_positive, 10);
-COMPILER_ARITH_PRIM (comutil_zero, 11);
-
-static void
-initialize_compiler_arithmetic ()
-{
- extern SCHEME_OBJECT make_primitive();
- int i;
-
- for (i = 0; i < ((sizeof(comp_arith_names)) / (sizeof(char *))); i++)
- {
- comp_arith_prims[i] = make_primitive(comp_arith_names[i]);
- }
- return;
-}
+ SCHEME_OBJECT handler; \
+ \
+ handler = (Get_Fixed_Obj_Slot (fobj_index)); \
+ return (comutil_apply (handler, (arity), 0, 0)); \
+}
+
+COMPILER_ARITH_PRIM (comutil_decrement, GENERIC_TRAMPOLINE_PREDECESSOR, 2);
+COMPILER_ARITH_PRIM (comutil_divide, GENERIC_TRAMPOLINE_DIVIDE, 3);
+COMPILER_ARITH_PRIM (comutil_equal, GENERIC_TRAMPOLINE_EQUAL_P, 3);
+COMPILER_ARITH_PRIM (comutil_greater, GENERIC_TRAMPOLINE_GREATER_P, 3);
+COMPILER_ARITH_PRIM (comutil_increment, GENERIC_TRAMPOLINE_SUCCESSOR, 2);
+COMPILER_ARITH_PRIM (comutil_less, GENERIC_TRAMPOLINE_LESS_P, 3);
+COMPILER_ARITH_PRIM (comutil_minus, GENERIC_TRAMPOLINE_MINUS, 3);
+COMPILER_ARITH_PRIM (comutil_multiply, GENERIC_TRAMPOLINE_MULTIPLY, 3);
+COMPILER_ARITH_PRIM (comutil_negative, GENERIC_TRAMPOLINE_NEGATIVE_P, 2);
+COMPILER_ARITH_PRIM (comutil_plus, GENERIC_TRAMPOLINE_PLUS, 3);
+COMPILER_ARITH_PRIM (comutil_positive, GENERIC_TRAMPOLINE_POSITIVE_P, 2);
+COMPILER_ARITH_PRIM (comutil_zero, GENERIC_TRAMPOLINE_ZERO_P, 2);
\f
/*
Obsolete SCHEME_UTILITYs used to handle first class environments.
#define CMPLR_REFERENCE(util_name, c_proc, ret_code, restart_name) \
SCHEME_UTILITY struct utility_result \
util_name (ret_add, environment, variable, ignore_4) \
- machine_word *ret_add; \
+ instruction *ret_add; \
SCHEME_OBJECT environment, variable; \
long ignore_4; \
{ \
#define CMPLR_ASSIGNMENT(util_name, c_proc, ret_code, restart_name) \
SCHEME_UTILITY struct utility_result \
util_name (ret_add, environment, variable, value) \
- machine_word *ret_add; \
+ instruction *ret_add; \
SCHEME_OBJECT environment, variable, value; \
{ \
extern long c_proc(); \
}
else
{
- STACK_PUSH (MAKE_UNSIGNED_FIXNUM (nactuals));
+ STACK_PUSH (LONG_TO_UNSIGNED_FIXNUM (nactuals));
STACK_PUSH (variable);
Store_Expression (environment);
Store_Return (RC_COMP_LOOKUP_APPLY_RESTART);
environment = (Fetch_Expression ());
variable = (STACK_POP ());
- code = (c_proc (environment, variable));
+ code = (Lex_Ref (environment, variable));
if (code == PRIM_DONE)
{
SCHEME_OBJECT nactuals;
compiled_closure_to_entry (entry)
SCHEME_OBJECT entry;
{
- SCHEME_OBJECT *real_entry, *block;
+ SCHEME_OBJECT *real_entry;
- Get_Compiled_Block (blck, (OBJECT_ADDRESS (entry)));
- EXTRACT_COMPILED_CLOSURE_ENTRY_ADDRESS (real_entry, block);
- return ENTRY_TO_OBJECT(real_entry);
+ EXTRACT_CLOSURE_ENTRY_ADDRESS (real_entry,
+ (OBJECT_ADDRESS (entry)));
+ return (ENTRY_TO_OBJECT (real_entry));
}
\f
/*
SCHEME_OBJECT *cache_address, *compiled_entry_address;
cache_address = (MEMORY_LOC (block, offset));
- EXTRACT_OPERATOR_LINK_ADDRESS (compiled_entry_address, cache_address);
+ EXTRACT_EXECUTE_CACHE_ADDRESS (compiled_entry_address, cache_address);
return ENTRY_TO_OBJECT(compiled_entry_address);
}
SCHEME_OBJECT *entry_address;
entry_address = (OBJECT_ADDRESS (entry));
- STORE_OPERATOR_LINK_INSTRUCTION (cache_address);
- STORE_OPERATOR_LINK_ADDRESS (cache_address, entry_address);
+ STORE_EXECUTE_CACHE_CODE (cache_address);
+ STORE_EXECUTE_CACHE_ADDRESS (cache_address, entry_address);
return;
}
\f
/* This makes a fake compiled procedure which traps to kind handler when
- invoked.
+ invoked. WARNING: this won't work if instruction alignment is more
+ restricted than simple longword alignment.
*/
+#define TRAMPOLINE_SIZE (TRAMPOLINE_ENTRY_SIZE + 2)
+
static long
make_trampoline (slot, format_word, kind, size, value1, value2, value3)
SCHEME_OBJECT *slot;
long kind, size;
SCHEME_OBJECT value1, value2, value3;
{
- SCHEME_OBJECT *block, *local_free;
+ SCHEME_OBJECT *block, *local_free, *entry_point;
if (GC_Check (TRAMPOLINE_SIZE + size))
{
local_free = Free;
Free += (TRAMPOLINE_SIZE + size);
block = local_free;
- *local_free++ = (MAKE_OBJECT (TC_MANIFEST_VECTOR,
- ((TRAMPOLINE_SIZE - 1) + size)));
- *local_free++ = (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR,
- (TRAMPOLINE_ENTRY_SIZE + 1)));
- local_free += 1;
-
- /* Note: at this point local_free is the address of the actual
- entry point of the trampoline procedure. The distance (in chars)
- to the beginning of the block should be CC_BLOCK_FIRST_ENTRY_OFFSET.
- */
-
- (COMPILED_ENTRY_FORMAT_WORD (local_free)) = format_word;
- (COMPILED_ENTRY_OFFSET_WORD (local_free)) =
- (MAKE_OFFSET_WORD (local_free, block, false));
- STORE_TRAMPOLINE_ENTRY (local_free, kind);
- block = local_free;
+ *local_free[0] = (MAKE_OBJECT (TC_MANIFEST_VECTOR,
+ ((TRAMPOLINE_SIZE - 1) + size)));
+ *local_free[1] = (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR,
+ (TRAMPOLINE_ENTRY_SIZE + 1)));
+ local_free += TRAMPOLINE_BLOCK_TO_ENTRY;
+ entry_point = local_free;
+ local_free = TRAMPLINE_STORAGE(entry_point);
+ (COMPILED_ENTRY_FORMAT_WORD (entry_point)) = format_word;
+ (COMPILED_ENTRY_OFFSET_WORD (entry_point)) =
+ (MAKE_OFFSET_WORD (entry_point, block, false));
+ STORE_TRAMPOLINE_ENTRY (entry_point, kind);
if ((--size) >= 0)
{
{
*local_free++ = value3;
}
- *slot = (ENTRY_TO_OBJECT (block));
+ *slot = (ENTRY_TO_OBJECT (entry_point));
return (PRIM_DONE);
}
\f
kind,
2,
procedure,
- (MAKE_UNSIGNED_FIXNUM (nactuals)),
+ (LONG_TO_UNSIGNED_FIXNUM (nactuals)),
SHARP_F));
}
SCHEME_OBJECT trampoline, *cache_address;
cache_address = (MEMORY_LOC (block, offset));
- EXTRACT_OPERATOR_LINK_ARITY (nactuals, cache_address);
+ EXTRACT_EXECUTE_CACHE_ARITY (nactuals, cache_address);
/* nactuals >= 0 */
switch (OBJECT_TYPE (procedure))
}
else
{
- kind = TRAMPOLINE_K_INTERPRETED;
+ kind = TRAMPOLINE_K_OTHER;
}
break;
}
+ case TC_PROCEDURE: /* and some others... */
default:
uuo_link_interpreted:
{
3,
extension,
block,
- (MAKE_UNSIGNED_FIXNUM (offset))));
+ (LONG_TO_UNSIGNED_FIXNUM (offset))));
if (result != PRIM_DONE)
{
return (result);
TRAMPOLINE_K_APPLY,
2,
procedure,
- (MAKE_UNSIGNED_FIXNUM (frame_size)),
+ (LONG_TO_UNSIGNED_FIXNUM (frame_size)),
SHARP_F));
}
(*location) = procedure;
#define COMPILER_REGBLOCK_N_HOOKS 64
#define COMPILER_REGBLOCK_N_TEMPS 128
-#if (REGBLOCK_MINIMUM_LENGTH > COMPILER_REGBLOCK_FIXED_LENGTH)
+#if (REGBLOCK_MINIMUM_LENGTH > COMPILER_REGBLOCK_N_FIXED)
#include "error: cmpint.c and const.h disagree on REGBLOCK_MINIMUM_LENGTH!"
#endif
#define COMPILER_FIXED_SIZE 1 /* ((sizeof(long)) / (sizeof(long))) */
#ifndef COMPILER_HOOK_SIZE
-#define COMPILER_HOOK_SIZE (OPERATOR_LINK_ENTRY_SIZE)
+#define COMPILER_HOOK_SIZE (EXECUTE_CACHE_ENTRY_SIZE)
#endif
#ifndef COMPILER_TEMP_SIZE
SCHEME_OBJECT
compiler_utilities,
- return_to_interpreter,
+ return_to_interpreter;
+
+#ifndef ASM_REGISTER_BLOCK
+SCHEME_OBJECT
Registers[REGBLOCK_LENGTH];
+#endif
static void
compiler_reset_internal ()
return_to_interpreter =
(ENTRY_TO_OBJECT ((SCHEME_OBJECT *)
- (((char *) (OBJECT_ADDRESS (compiler_utilities))) +
- CC_BLOCK_FIRST_ENTRY_OFFSET)));
+ ((OBJECT_ADDRESS (compiler_utilities)) +
+ TRAMPOLINE_BLOCK_TO_ENTRY)));
- initialize_compiler_arithmetic ();
return;
}
\f
compiler_reset (new_block)
SCHEME_OBJECT new_block;
{
+ /* Called after a disk restore */
+
if ((OBJECT_TYPE (new_block)) != TC_COMPILED_CODE_BLOCK)
{
extern void compiler_reset_error ();
compiler_initialize (fasl_p)
long fasl_p;
{
+ /* Start-up of whole interpreter */
+
long code;
SCHEME_OBJECT trampoline, *block, *block;
}
return;
}
-\f
-/* *** To do ***
- - change interpreter to match this.
- */
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/cmpint.c,v 1.9 1989/10/26 04:23:27 jinx Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/cmpint.c,v 1.10 1989/10/27 13:26:24 jinx Exp $
*
* This file corresponds to
- * $COMPILER-Header: compiler.c,v 9.35 88/10/26 20:02:13 GMT cph Exp $
- * $MC68020-Header: cmp68020.m4,v 9.86 89/04/19 02:24:19 GMT arthur Exp $
+ * $COMPILER-Header: compiler.c,v 9.37 89/10/25 14:55:45 GMT jinx Exp $
+ * $MC68020-Header: cmp68020.m4,v 9.93 89/10/26 07:49:23 GMT cph Exp $
*
* Compiled code interface. Portable version.
* This file requires a bit of assembly language described in cmpaux.m4
/* Macro imports */
#include "config.h" /* SCHEME_OBJECT type and machine dependencies */
-#include "object.h" /* Making and destructuring Scheme objects */
-#include "sdata.h" /* Needed by const.h */
#include "types.h" /* Needed by const.h */
-#include "errors.h" /* Error codes and Termination codes */
#include "const.h" /* REGBLOCK_MINIMUM_LENGTH and PRIM_... codes */
-#include "trap.h" /* UNASSIGNED_OBJECT, TRAP_EXTENSION_TYPE */
-#include "interp.h" /* Interpreter state and primitive destructuring */
-#include "prims.h" /* LEXPR */
-#include "cmpint.h" /* Compiled code object destructuring */
+#include "object.h" /* Making and destructuring Scheme objects */
+#include "intrpt.h" /* Interrupt processing macros */
+#include "gc.h" /* Request_GC, etc. */
#include "cmpgc.h" /* Compiled code object relocation */
+#include "errors.h" /* Error codes and Termination codes */
+#include "returns.h" /* Return addresses in the interpreter */
+#include "fixobj.h" /* To find the error handlers */
+#include "stack.h" /* Stacks and stacklets */
+#include "interp.h" /* Interpreter state and primitive destructuring */
#include "default.h" /* Metering_Apply_Primitive */
+#include "extern.h" /* External decls (missing Cont_Debug, etc.) */
+#include "trap.h" /* UNASSIGNED_OBJECT, TRAP_EXTENSION_TYPE */
+#include "prims.h" /* LEXPR */
+#include "cmpint2.h" /* Compiled code object destructuring */
\f
/* Make noise words invisible to the C compiler. */
/* Structure returned by SCHEME_UTILITYs */
+typedef char instruction; /* (instruction *) is a pointer to a
+ native instruction. */
+
struct utility_result
{
void (*interface_dispatch)();
union additional_info
{
long code_to_interpreter;
- machine_word *entry_point;
+ instruction *entry_point;
} extra;
};
enter_compiled_expression(),
apply_compiled_procedure(),
return_to_compiled_code(),
- comp_link_caches_restart();
+ comp_link_caches_restart(),
+ comp_op_lookup_trap_restart(),
+ comp_interrupt_restart(),
+ comp_assignment_trap_restart(),
+ comp_cache_lookup_apply_restart(),
+ comp_lookup_trap_restart(),
+ safe_lookup_trap_restart(),
+ comp_unassigned_p_trap_restart(),
+ comp_access_restart(),
+ comp_reference_restart(),
+ comp_safe_reference_restart(),
+ comp_unassigned_p_restart(),
+ comp_unbound_p_restart(),
+ comp_assignment_restart(),
+ comp_definition_restart(),
+ comp_lookup_apply_restart();
\f
extern SCHEME_UTILITY struct utility_result
comutil_return_to_interpreter(),
#define TRAMPOLINE_K_4_2 0xf
#define TRAMPOLINE_K_4_1 0x10
#define TRAMPOLINE_K_4_0 0x11
+
+#define TRAMPOLINE_K_OTHER TRAMPOLINE_K_INTERPRETED
\f
/* Main compiled code entry points.
These are the primary entry points that the interpreter
{
/* It self evaluates. */
Val = (Fetch_Expression ());
- return (PRIM_DONE);
+ return (C_to_interface ((instruction *) (OBJECT_ADDRESS (STACK_POP ()))));
}
- return (C_to_interface((machine_word *) compiled_entry_address));
+ return (C_to_interface ((instruction *) compiled_entry_address));
}
C_TO_SCHEME long
{
static long setup_compiled_invocation();
SCHEME_OBJECT nactuals, procedure;
- machine_word *procedure_entry;
+ instruction *procedure_entry;
long result;
nactuals = (STACK_POP ());
procedure = (STACK_POP ());
- procedure_entry = ((machine_word *) (OBJECT_ADDRESS (procedure)));
+ procedure_entry = ((instruction *) (OBJECT_ADDRESS (procedure)));
result = setup_compiled_invocation ((OBJECT_DATUM (nactuals)),
- (procedure_entry));
+ ((machine_word *) procedure_entry));
if (result == PRIM_DONE)
{
/* Go into compiled code. */
C_TO_SCHEME long
return_to_compiled_code ()
{
- machine_word *compiled_entry_address;
+ instruction *compiled_entry_address;
compiled_entry_address =
- ((machine_word *) (OBJECT_ADDRESS (STACK_POP ())));
+ ((instruction *) (OBJECT_ADDRESS (STACK_POP ())));
return (C_to_interface (compiled_entry_address));
}
\f
case TC_COMPILED_ENTRY:
callee_is_compiled:
{
- machine_word *entry_point;
+ instruction *entry_point;
- entry_point = ((machine_word *) (OBJECT_ADDRESS (procedure)));
+ entry_point = ((instruction *) (OBJECT_ADDRESS (procedure)));
RETURN_UNLESS_EXCEPTION
- ((setup_compiled_invocation (nactuals, entry_point)),
+ ((setup_compiled_invocation (nactuals,
+ ((machine_word *) entry_point))),
entry_point);
}
default:
{
STACK_PUSH (procedure);
- STACK_PUSH (MAKE_UNSIGNED_FIXNUM (nactuals));
+ STACK_PUSH (LONG_TO_UNSIGNED_FIXNUM (nactuals));
RETURN_TO_C (PRIM_APPLY);
}
}
SCHEME_UTILITY struct utility_result
comutil_lexpr_apply (entry_address, nactuals, ignore_3, ignore_4)
- register machine_word *entry_address;
+ register instruction *entry_address;
long nactuals;
long ignore_3, ignore_4;
{
((kind) | \
(((kind) != OPERATOR_LINKAGE_KIND) ? \
(count) : \
- ((count) * OPERATOR_LINK_ENTRY_SIZE)))))
+ ((count) * EXECUTE_CACHE_ENTRY_SIZE)))))
static long
link_cc_block (block_address, offset, last_header_offset,
register SCHEME_OBJECT block_address;
register long offset;
long last_header_offset, sections, original_count;
- machine_word *ret_add;
+ instruction *ret_add;
{
+ Boolean execute_p;
register long entry_size, count;
register SCHEME_OBJECT block;
SCHEME_OBJECT header;
kind = (READ_LINKAGE_KIND (header));
if (kind == OPERATOR_LINKAGE_KIND)
{
- entry_size = OPERATOR_LINK_ENTRY_SIZE;
+ execute_p = true;
+ entry_size = EXECUTE_CACHE_ENTRY_SIZE;
cache_handler = compiler_cache_operator;
count = (READ_OPERATOR_LINKAGE_COUNT (header));
}
else
{
+ execute_p = false;
entry_size = 1;
cache_handler = ((kind == REFERENCE_LINKAGE_KIND) ?
compiler_cache_lookup :
\f
for (offset += 1; ((--count) >= 0); offset += entry_size)
{
- result = ((*cache_handler)
- ((block_address[offset]), /* name of variable */
- block,
- offset));
+ SCHEME_OBJECT name;
+
+ if (!execute_p)
+ {
+ name = (block[offset]);
+ }
+ else
+ {
+ EXTRACT_EXECUTE_CACHE_SYMBOL(name, &(block[offset]));
+ }
+ result = ((*cache_handler)(name, block, offset));
if (result != PRIM_DONE)
{
*/
STACK_PUSH (ENTRY_TO_OBJECT (ret_add));
- STACK_PUSH (MAKE_UNSIGNED_FIXNUM (sections + 1));
- STACK_PUSH (MAKE_UNSIGNED_FIXNUM (last_header_offset));
- STACK_PUSH (MAKE_UNSIGNED_FIXNUM (offset - 1));
+ STACK_PUSH (LONG_TO_UNSIGNED_FIXNUM (sections + 1));
+ STACK_PUSH (LONG_TO_UNSIGNED_FIXNUM (last_header_offset));
+ STACK_PUSH (LONG_TO_UNSIGNED_FIXNUM (offset - 1));
STACK_PUSH (block);
- STACK_PUSH (MAKE_UNSIGNED_FIXNUM (count + 1));
+ STACK_PUSH (LONG_TO_UNSIGNED_FIXNUM (count + 1));
- Store_Expresion (MAKE_UNSIGNED_FIXNUM (total_count));
+ Store_Expresion (LONG_TO_UNSIGNED_FIXNUM (total_count));
Store_Return (RC_COMP_LINK_CACHES_RESTART);
Save_Cont ();
SCHEME_UTILITY struct utility_result
comutil_link (ret_add, block_address, constant_address, sections)
- machine_word *ret_add;
+ instruction *ret_add;
SCHEME_OBJECT *block_address, *constant_address;
long sections;
{
{
SCHEME_OBJECT block;
long original_count, offset, last_header_offset, sections, code;
- machine_word *ret_add;
+ instruction *ret_add;
original_count = (OBJECT_DATUM (Fetch_Expression ()));
STACK_POP (); /* Pop count, not needed */
offset = (OBJECT_DATUM (STACK_POP ()));
last_header_offset = (OBJECT_DATUM (STACK_POP ()));
sections = (OBJECT_DATUM (STACK_POP ()));
- ret_add = ((machine_word *) (OBJECT_ADDRES (STACK_POP ())));
+ ret_add = ((instruction *) (OBJECT_ADDRESS (STACK_POP ())));
code = (link_cc_block ((OBJECT_ADDRESS (block)),
offset,
last_header_offset,
code = (complr_operator_reference_trap (&true_operator, (tramp_data[0])));
cache_cell = (MEMORY_LOC ((tramp_data[1]),
(OBJECT_DATUM (tramp_data[2]))));
- EXTRACT_OPERATOR_LINK_ARITY (nargs, cache_cell);
+ EXTRACT_EXECUTE_CACHE_ARITY (nargs, cache_cell);
if (code == PRIM_DONE)
{
return (comutil_apply (true_operator, nargs, 0, 0));
/* This could be done by bumpint tramp_data to the entry point.
It would probably be better.
*/
- EXTRACT_OPERATOR_LINK_ADDRESS (trampoline, cache_cell);
+ EXTRACT_EXECUTE_CACHE_ADDRESS (trampoline, cache_cell);
environment = (compiled_block_environment (tramp_data[1]));
name = (compiler_var_error ((tramp_data[0]), environment));
STACK_PUSH(ENTRY_TO_OBJECT(trampoline));
- STACK_PUSH(MAKE_UNSIGNED_FIXNUM(nargs)); /* For debugger */
+ STACK_PUSH(LONG_TO_UNSIGNED_FIXNUM(nargs)); /* For debugger */
STACK_PUSH(environment); /* For debugger */
Store_Expression(name);
Store_Return(RC_COMP_OP_REF_TRAP_RESTART);
old_trampoline = (OBJECT_ADDRESS (STACK_POP ()));
code_block = ((TRAMPOLINE_STORAGE (old_trampoline))[1]);
offset = (OBJECT_DATUM ((TRAMPOLINE_STORAGE (old_trampoline))[2]));
- EXTRACT_OPERATOR_LINK_ADDRESS (new_procedure,
+ EXTRACT_EXECUTE_CACHE_ADDRESS (new_procedure,
(MEMORY_LOC (code_block, offset)));
- return (C_to_interface ((machine_word *) (OBJECT_ADDRESS (new_procedure))));
+ return (C_to_interface ((instruction *) (OBJECT_ADDRESS (new_procedure))));
}
\f
/* ARITY Mismatch handling
{
SCHEME_OBJECT *entry_point;
- EXTRACT_COMPILED_CLOSURE_ENTRY_ADDRESS(entry_point,
- (OBJECT_ADDRESS (STACK_REF (0))));
- RETURN_TO_SCHEME(((machine_word *) entry_point) +
+ EXTRACT_CLOSURE_ENTRY_ADDRESS(entry_point,
+ (OBJECT_ADDRESS (STACK_REF (0))));
+ RETURN_TO_SCHEME(((instruction *) entry_point) +
CLOSURE_SKIPPED_CHECK_OFFSET);
}
else
SCHEME_UTILITY struct utility_result
comutil_interrupt_procedure (entry_point, state, ignore_3, ignore_4)
- machine_word *entry_point;
+ instruction *entry_point;
SCHEME_OBJECT state;
long ignore_3, ignore_4;
{
SCHEME_UTILITY struct utility_result
comutil_interrupt_continuation (return_address, ignore_2, ignore_3, ignore_4)
- machine_word *return_address;
+ instruction *return_address;
long ignore_2, ignore_3, ignore_4;
{
return (comutil_interrupt_procedure (return_address, Val, 0, 0));
SCHEME_UTILITY struct utility_result
comutil_interrupt_ic_procedure (entry_point, ignore_2, ignore_3, ignore_4)
- machine_word *entry_point;
+ instruction *entry_point;
long ignore_2, ignore_3, ignore_4;
{
return (comutil_interrupt_procedure (entry_point, (Fetch_Env()), 0, 0));
C_TO_SCHEME long
comp_interrupt_restart ()
{
- Store_Env(Fetch_Expression());
- Val = Fetch_Expression();
- return (C_to_interface((machine_word *) (OBJECT_ADDRESS (STACK_POP ()))));
+ Store_Env (Fetch_Expression());
+ Val = (Fetch_Expression ());
+ return (C_to_interface ((instruction *) (OBJECT_ADDRESS (STACK_POP ()))));
}
\f
/* Other TRAPS */
SCHEME_UTILITY struct utility_result
comutil_assignment_trap (return_address, extension_addr, value, ignore_4)
- machine_word *return_address;
+ instruction *return_address;
SCHEME_OBJECT *extension_addr, value;
long ignore_4;
{
code = (Symbol_Lex_Set (environment, name, value));
if (code == PRIM_DONE)
{
- return (C_to_interface(OBJECT_ADDRESS (STACK_POP ())));
+ return (C_to_interface (OBJECT_ADDRESS (STACK_POP ())));
}
else
{
block = (MAKE_CC_BLOCK (block_address));
STACK_PUSH (block);
- STACK_PUSH (MAKE_UNSIGNED_FIXNUM (nactuals));
+ STACK_PUSH (LONG_TO_UNSIGNED_FIXNUM (nactuals));
environment = (compiled_block_environment (block));
STACK_PUSH (environment);
name = (compiler_var_error (extension, environment));
Store_Expression (name);
- Store_Return (RC_COMP_CACHE_LOOKUP_RESTART);
+ Store_Return (RC_COMP_CACHE_REF_APPLY_RESTART);
Save_Cont ();
RETURN_TO_C (code);
}
{
STACK_PUSH (environment);
Store_Expression (name);
- Store_Return (RC_COMP_CACHE_LOOKUP_RESTART);
+ Store_Return (RC_COMP_CACHE_REF_APPLY_RESTART);
Save_Cont ();
return (code);
}
#define CMPLR_REF_TRAP (name,c_trap,ret_code,restart_name,c_lookup) \
SCHEME_UTILITY struct utility_result \
name (return_address, extension_addr, ignore_3, ignore_4) \
- machine_word *return_address; \
+ instruction *return_address; \
SCHEME_OBJECT *extension_addr; \
long ignore_3, ignore_4; \
{ \
Symbol_Lex_unassigned_p);
\f
/* NUMERIC ROUTINES
- These just call the C primitives for now.
+ Invoke the arithmetic primitive in the fixed objects vector.
+ The Scheme arguments are expected on the Scheme stack.
*/
-static char *comp_arith_names[] =
-{
- "-1+", /* 0 */
- "&/", /* 1 */
- "&=", /* 2 */
- "&>", /* 3 */
- "1+", /* 4 */
- "&<", /* 5 */
- "&-", /* 6 */
- "&*", /* 7 */
- "NEGATIVE?", /* 8 */
- "&+", /* 9 */
- "POSITIVE?", /* 10 */
- "ZERO?" /* 11 */
-};
-
-static SCHEME_OBJECT
-comp_arith_prims[(sizeof(comp_arith_names))/(sizeof(char *))];
-
-#define COMPILER_ARITH_PRIM (name, index) \
+#define COMPILER_ARITH_PRIM (name, fobj_index, arity) \
SCHEME_UTILITY struct utility_result \
name (ignore_1, ignore_2, ignore_3, ignore_4) \
long ignore_1, ignore_2, ignore_3, ignore_4; \
{ \
- return (comutil_primitive_apply (comp_arith_prims [index])); \
-}
-
-COMPILER_ARITH_PRIM (comutil_decrement, 0);
-COMPILER_ARITH_PRIM (comutil_divide, 1);
-COMPILER_ARITH_PRIM (comutil_equal, 2);
-COMPILER_ARITH_PRIM (comutil_greater, 3);
-COMPILER_ARITH_PRIM (comutil_increment, 4);
-COMPILER_ARITH_PRIM (comutil_less, 5);
-COMPILER_ARITH_PRIM (comutil_minus, 6);
-COMPILER_ARITH_PRIM (comutil_multiply, 7);
-COMPILER_ARITH_PRIM (comutil_negative, 8);
-COMPILER_ARITH_PRIM (comutil_plus, 9);
-COMPILER_ARITH_PRIM (comutil_positive, 10);
-COMPILER_ARITH_PRIM (comutil_zero, 11);
-
-static void
-initialize_compiler_arithmetic ()
-{
- extern SCHEME_OBJECT make_primitive();
- int i;
-
- for (i = 0; i < ((sizeof(comp_arith_names)) / (sizeof(char *))); i++)
- {
- comp_arith_prims[i] = make_primitive(comp_arith_names[i]);
- }
- return;
-}
+ SCHEME_OBJECT handler; \
+ \
+ handler = (Get_Fixed_Obj_Slot (fobj_index)); \
+ return (comutil_apply (handler, (arity), 0, 0)); \
+}
+
+COMPILER_ARITH_PRIM (comutil_decrement, GENERIC_TRAMPOLINE_PREDECESSOR, 2);
+COMPILER_ARITH_PRIM (comutil_divide, GENERIC_TRAMPOLINE_DIVIDE, 3);
+COMPILER_ARITH_PRIM (comutil_equal, GENERIC_TRAMPOLINE_EQUAL_P, 3);
+COMPILER_ARITH_PRIM (comutil_greater, GENERIC_TRAMPOLINE_GREATER_P, 3);
+COMPILER_ARITH_PRIM (comutil_increment, GENERIC_TRAMPOLINE_SUCCESSOR, 2);
+COMPILER_ARITH_PRIM (comutil_less, GENERIC_TRAMPOLINE_LESS_P, 3);
+COMPILER_ARITH_PRIM (comutil_minus, GENERIC_TRAMPOLINE_MINUS, 3);
+COMPILER_ARITH_PRIM (comutil_multiply, GENERIC_TRAMPOLINE_MULTIPLY, 3);
+COMPILER_ARITH_PRIM (comutil_negative, GENERIC_TRAMPOLINE_NEGATIVE_P, 2);
+COMPILER_ARITH_PRIM (comutil_plus, GENERIC_TRAMPOLINE_PLUS, 3);
+COMPILER_ARITH_PRIM (comutil_positive, GENERIC_TRAMPOLINE_POSITIVE_P, 2);
+COMPILER_ARITH_PRIM (comutil_zero, GENERIC_TRAMPOLINE_ZERO_P, 2);
\f
/*
Obsolete SCHEME_UTILITYs used to handle first class environments.
#define CMPLR_REFERENCE(util_name, c_proc, ret_code, restart_name) \
SCHEME_UTILITY struct utility_result \
util_name (ret_add, environment, variable, ignore_4) \
- machine_word *ret_add; \
+ instruction *ret_add; \
SCHEME_OBJECT environment, variable; \
long ignore_4; \
{ \
#define CMPLR_ASSIGNMENT(util_name, c_proc, ret_code, restart_name) \
SCHEME_UTILITY struct utility_result \
util_name (ret_add, environment, variable, value) \
- machine_word *ret_add; \
+ instruction *ret_add; \
SCHEME_OBJECT environment, variable, value; \
{ \
extern long c_proc(); \
}
else
{
- STACK_PUSH (MAKE_UNSIGNED_FIXNUM (nactuals));
+ STACK_PUSH (LONG_TO_UNSIGNED_FIXNUM (nactuals));
STACK_PUSH (variable);
Store_Expression (environment);
Store_Return (RC_COMP_LOOKUP_APPLY_RESTART);
environment = (Fetch_Expression ());
variable = (STACK_POP ());
- code = (c_proc (environment, variable));
+ code = (Lex_Ref (environment, variable));
if (code == PRIM_DONE)
{
SCHEME_OBJECT nactuals;
compiled_closure_to_entry (entry)
SCHEME_OBJECT entry;
{
- SCHEME_OBJECT *real_entry, *block;
+ SCHEME_OBJECT *real_entry;
- Get_Compiled_Block (blck, (OBJECT_ADDRESS (entry)));
- EXTRACT_COMPILED_CLOSURE_ENTRY_ADDRESS (real_entry, block);
- return ENTRY_TO_OBJECT(real_entry);
+ EXTRACT_CLOSURE_ENTRY_ADDRESS (real_entry,
+ (OBJECT_ADDRESS (entry)));
+ return (ENTRY_TO_OBJECT (real_entry));
}
\f
/*
SCHEME_OBJECT *cache_address, *compiled_entry_address;
cache_address = (MEMORY_LOC (block, offset));
- EXTRACT_OPERATOR_LINK_ADDRESS (compiled_entry_address, cache_address);
+ EXTRACT_EXECUTE_CACHE_ADDRESS (compiled_entry_address, cache_address);
return ENTRY_TO_OBJECT(compiled_entry_address);
}
SCHEME_OBJECT *entry_address;
entry_address = (OBJECT_ADDRESS (entry));
- STORE_OPERATOR_LINK_INSTRUCTION (cache_address);
- STORE_OPERATOR_LINK_ADDRESS (cache_address, entry_address);
+ STORE_EXECUTE_CACHE_CODE (cache_address);
+ STORE_EXECUTE_CACHE_ADDRESS (cache_address, entry_address);
return;
}
\f
/* This makes a fake compiled procedure which traps to kind handler when
- invoked.
+ invoked. WARNING: this won't work if instruction alignment is more
+ restricted than simple longword alignment.
*/
+#define TRAMPOLINE_SIZE (TRAMPOLINE_ENTRY_SIZE + 2)
+
static long
make_trampoline (slot, format_word, kind, size, value1, value2, value3)
SCHEME_OBJECT *slot;
long kind, size;
SCHEME_OBJECT value1, value2, value3;
{
- SCHEME_OBJECT *block, *local_free;
+ SCHEME_OBJECT *block, *local_free, *entry_point;
if (GC_Check (TRAMPOLINE_SIZE + size))
{
local_free = Free;
Free += (TRAMPOLINE_SIZE + size);
block = local_free;
- *local_free++ = (MAKE_OBJECT (TC_MANIFEST_VECTOR,
- ((TRAMPOLINE_SIZE - 1) + size)));
- *local_free++ = (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR,
- (TRAMPOLINE_ENTRY_SIZE + 1)));
- local_free += 1;
-
- /* Note: at this point local_free is the address of the actual
- entry point of the trampoline procedure. The distance (in chars)
- to the beginning of the block should be CC_BLOCK_FIRST_ENTRY_OFFSET.
- */
-
- (COMPILED_ENTRY_FORMAT_WORD (local_free)) = format_word;
- (COMPILED_ENTRY_OFFSET_WORD (local_free)) =
- (MAKE_OFFSET_WORD (local_free, block, false));
- STORE_TRAMPOLINE_ENTRY (local_free, kind);
- block = local_free;
+ *local_free[0] = (MAKE_OBJECT (TC_MANIFEST_VECTOR,
+ ((TRAMPOLINE_SIZE - 1) + size)));
+ *local_free[1] = (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR,
+ (TRAMPOLINE_ENTRY_SIZE + 1)));
+ local_free += TRAMPOLINE_BLOCK_TO_ENTRY;
+ entry_point = local_free;
+ local_free = TRAMPLINE_STORAGE(entry_point);
+ (COMPILED_ENTRY_FORMAT_WORD (entry_point)) = format_word;
+ (COMPILED_ENTRY_OFFSET_WORD (entry_point)) =
+ (MAKE_OFFSET_WORD (entry_point, block, false));
+ STORE_TRAMPOLINE_ENTRY (entry_point, kind);
if ((--size) >= 0)
{
{
*local_free++ = value3;
}
- *slot = (ENTRY_TO_OBJECT (block));
+ *slot = (ENTRY_TO_OBJECT (entry_point));
return (PRIM_DONE);
}
\f
kind,
2,
procedure,
- (MAKE_UNSIGNED_FIXNUM (nactuals)),
+ (LONG_TO_UNSIGNED_FIXNUM (nactuals)),
SHARP_F));
}
SCHEME_OBJECT trampoline, *cache_address;
cache_address = (MEMORY_LOC (block, offset));
- EXTRACT_OPERATOR_LINK_ARITY (nactuals, cache_address);
+ EXTRACT_EXECUTE_CACHE_ARITY (nactuals, cache_address);
/* nactuals >= 0 */
switch (OBJECT_TYPE (procedure))
}
else
{
- kind = TRAMPOLINE_K_INTERPRETED;
+ kind = TRAMPOLINE_K_OTHER;
}
break;
}
+ case TC_PROCEDURE: /* and some others... */
default:
uuo_link_interpreted:
{
3,
extension,
block,
- (MAKE_UNSIGNED_FIXNUM (offset))));
+ (LONG_TO_UNSIGNED_FIXNUM (offset))));
if (result != PRIM_DONE)
{
return (result);
TRAMPOLINE_K_APPLY,
2,
procedure,
- (MAKE_UNSIGNED_FIXNUM (frame_size)),
+ (LONG_TO_UNSIGNED_FIXNUM (frame_size)),
SHARP_F));
}
(*location) = procedure;
#define COMPILER_REGBLOCK_N_HOOKS 64
#define COMPILER_REGBLOCK_N_TEMPS 128
-#if (REGBLOCK_MINIMUM_LENGTH > COMPILER_REGBLOCK_FIXED_LENGTH)
+#if (REGBLOCK_MINIMUM_LENGTH > COMPILER_REGBLOCK_N_FIXED)
#include "error: cmpint.c and const.h disagree on REGBLOCK_MINIMUM_LENGTH!"
#endif
#define COMPILER_FIXED_SIZE 1 /* ((sizeof(long)) / (sizeof(long))) */
#ifndef COMPILER_HOOK_SIZE
-#define COMPILER_HOOK_SIZE (OPERATOR_LINK_ENTRY_SIZE)
+#define COMPILER_HOOK_SIZE (EXECUTE_CACHE_ENTRY_SIZE)
#endif
#ifndef COMPILER_TEMP_SIZE
SCHEME_OBJECT
compiler_utilities,
- return_to_interpreter,
+ return_to_interpreter;
+
+#ifndef ASM_REGISTER_BLOCK
+SCHEME_OBJECT
Registers[REGBLOCK_LENGTH];
+#endif
static void
compiler_reset_internal ()
return_to_interpreter =
(ENTRY_TO_OBJECT ((SCHEME_OBJECT *)
- (((char *) (OBJECT_ADDRESS (compiler_utilities))) +
- CC_BLOCK_FIRST_ENTRY_OFFSET)));
+ ((OBJECT_ADDRESS (compiler_utilities)) +
+ TRAMPOLINE_BLOCK_TO_ENTRY)));
- initialize_compiler_arithmetic ();
return;
}
\f
compiler_reset (new_block)
SCHEME_OBJECT new_block;
{
+ /* Called after a disk restore */
+
if ((OBJECT_TYPE (new_block)) != TC_COMPILED_CODE_BLOCK)
{
extern void compiler_reset_error ();
compiler_initialize (fasl_p)
long fasl_p;
{
+ /* Start-up of whole interpreter */
+
long code;
SCHEME_OBJECT trampoline, *block, *block;
}
return;
}
-\f
-/* *** To do ***
- - change interpreter to match this.
- */
projects / mit-scheme.git / commitdiff