Ansification of cmpint.c.
/* -*-C-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/bchmmg.c,v 9.59 1991/03/18 21:08:58 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/bchmmg.c,v 9.60 1991/03/21 23:25:32 jinx Exp $
Copyright (c) 1987-1991 Massachusetts Institute of Technology
Current_State_Point = *Root++;
Fluid_Bindings = *Root++;
Free_Stacklets = NULL;
- FLUSH_I_CACHE ();
+ COMPILER_TRANSPORT_END ();
CLEAR_INTERRUPT (INT_GC);
return;
}
### -*-Midas-*-
###
-### $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/cmpauxmd/mc68k.m4,v 1.15 1991/01/08 22:16:01 cph Exp $
+### $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/cmpauxmd/mc68k.m4,v 1.16 1991/03/21 23:25:40 jinx Exp $
###
-### Copyright (c) 1989, 1990, 1991 Massachusetts Institute of Technology
+### Copyright (c) 1989-1991 Massachusetts Institute of Technology
###
### This material was developed by the Scheme project at the
### Massachusetts Institute of Technology, Department of
reference_external(Free)
reference_external(Registers)
-# This must match the C compiler
+# These must match the C compiler
define(switch_to_scheme_registers,
`mov.l %a6,(%sp)
define_apply_size_n(6)
define_apply_size_n(7)
define_apply_size_n(8)
+\f
+### This utility depends on the C compiler preserving d2-d7 and a2-a7.
+### It takes its parameters in d0 and d1, and returns its value in a0.
+
+define_c_label(asm_allocate_closure)
+ switch_to_C_registers()
+ mov.l %a1,-(%sp) # Preserve reg.
+ mov.l %d1,-(%sp) # Push args
+ mov.l %d0,-(%sp)
+ jsr extern_c_label(allocate_closure)
+ addq.l &8,(%sp) # Pop args
+ mov.l %d0,%a0 # Return value
+ mov.l (%sp)+,%a1 # Restore regs
+ switch_to_scheme_registers()
+ rts
/* -*-C-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/cmpgc.h,v 1.13 1990/06/28 18:16:32 jinx Rel $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/cmpgc.h,v 1.14 1991/03/21 23:25:47 jinx Exp $
-Copyright (c) 1989, 1990 Massachusetts Institute of Technology
+Copyright (c) 1989-1991 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
#endif /* HAS_COMPILER_SUPPORT */
#ifndef FLUSH_I_CACHE
+#define FLUSH_I_CACHE() do {} while (0)
+#endif /* FLUSH_I_CACHE */
-#define FLUSH_I_CACHE() \
-do { \
+#ifndef COMPILER_TRANSPORT_END
+#define COMPILER_TRANSPORT_END() do \
+{ \
+ Registers[REGBLOCK_CLOSURE_SPACE] = ((SCHEME_OBJECT) 0); \
+ Registers[REGBLOCK_CLOSURE_FREE] = ((SCHEME_OBJECT) NULL); \
+ FLUSH_I_CACHE (); \
} while (0)
-
-#endif /* FLUSH_I_CACHE */
+#endif /* COMPILER_TRANSPORT_END */
#endif /* CMPGC_H_INCLUDED */
/* -*-C-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/cmpint.c,v 1.31 1990/10/03 18:55:46 jinx Rel $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/cmpint.c,v 1.32 1991/03/21 23:26:02 jinx Exp $
-Copyright (c) 1989, 1990 Massachusetts Institute of Technology
+Copyright (c) 1989-1991 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
*
*/
+#define NOP() do {} while (0) /* A useful macro */
+
/* Macro imports */
#include <stdio.h>
#define IN_CMPINT_C
#include "cmpint2.h" /* Compiled code object destructuring */
#include "cmpgc.h" /* Compiled code object relocation */
+
+#ifndef FLUSH_I_CACHE_REGION
+# define FLUSH_I_CACHE_REGION(addr, nwords) NOP()
+#endif
+
+#ifndef PUSH_D_CACHE_REGION
+# define PUSH_D_CACHE_REGION(addr, nwords) FLUSH_I_CACHE_REGION(addr, nwords)
+#endif
\f
/* Make noise words invisible to the C compiler. */
}
#define ENTRY_TO_OBJECT(entry) \
-MAKE_POINTER_OBJECT(TC_COMPILED_ENTRY, ((SCHEME_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))
+ (MAKE_POINTER_OBJECT (TC_COMPILED_CODE_BLOCK, block_addr))
\f
/* Imports from the rest of the "microcode" */
extern long
- compiler_cache_operator(),
- compiler_cache_lookup(),
- compiler_cache_assignment();
+ EXFUN (compiler_cache_operator, (void)),
+ EXFUN (compiler_cache_lookup, (void)),
+ EXFUN (compiler_cache_assignment, (void));
/* Imports from assembly language */
extern long
- C_to_interface();
+ EXFUN (C_to_interface, (void *));
extern void
- interface_to_C(),
- interface_to_scheme();
+ EXFUN (interface_to_C, (void)),
+ EXFUN (interface_to_scheme, (void));
/* Exports to the rest of the "microcode" */
return_to_interpreter;
extern C_UTILITY long
- make_fake_uuo_link(),
- make_uuo_link(),
- compiled_block_closure_p(),
- compiled_entry_closure_p(),
- compiled_entry_to_block_offset(),
- coerce_to_compiled();
+ EXFUN (make_fake_uuo_link,
+ (SCHEME_OBJECT extension, SCHEME_OBJECT block, long offset)),
+ EXFUN (make_uuo_link,
+ (SCHEME_OBJECT value, SCHEME_OBJECT extension,
+ SCHEME_OBJECT block, long offset)),
+ EXFUN (compiled_block_closure_p, (SCHEME_OBJECT block)),
+ EXFUN (compiled_entry_closure_p, (SCHEME_OBJECT entry)),
+ EXFUN (compiled_entry_to_block_offset, (SCHEME_OBJECT entry)),
+ EXFUN (coerce_to_compiled,
+ (SCHEME_OBJECT object, long arity, SCHEME_OBJECT *location));
extern C_UTILITY SCHEME_OBJECT
- extract_uuo_link(),
- extract_variable_cache(),
- compiled_block_debugging_info(),
- compiled_block_environment(),
- compiled_closure_to_entry(),
- *compiled_entry_to_block_address(),
- compiled_entry_to_block();
+ EXFUN (extract_uuo_link, (SCHEME_OBJECT block, long offset)),
+ EXFUN (extract_variable_cache,
+ (SCHEME_OBJECT extension, long offset)),
+ EXFUN (compiled_block_debugging_info, (SCHEME_OBJECT block)),
+ 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));
extern C_UTILITY void
- compiler_initialize(),
- compiler_reset(),
- store_variable_cache(),
- compiled_entry_type();
+ EXFUN (compiler_initialize, (long fasl_p)),
+ EXFUN (compiler_reset, (SCHEME_OBJECT new_block)),
+ EXFUN (store_variable_cache,
+ (SCHEME_OBJECT extension, SCHEME_OBJECT block, long offset)),
+ EXFUN (compiled_entry_type,
+ (SCHEME_OBJECT entry, long *buffer));
extern C_TO_SCHEME long
- enter_compiled_expression(),
- apply_compiled_procedure(),
- return_to_compiled_code(),
- 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(),
- comp_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(),
- comp_error_restart();
+ EXFUN (enter_compiled_expression, (void)),
+ EXFUN (apply_compiled_procedure, (void)),
+ EXFUN (return_to_compiled_code, (void)),
+ EXFUN (comp_link_caches_restart, (void)),
+ EXFUN (comp_op_lookup_trap_restart, (void)),
+ EXFUN (comp_interrupt_restart, (void)),
+ EXFUN (comp_assignment_trap_restart, (void)),
+ EXFUN (comp_cache_lookup_apply_restart, (void)),
+ EXFUN (comp_lookup_trap_restart, (void)),
+ EXFUN (comp_safe_lookup_trap_restart, (void)),
+ EXFUN (comp_unassigned_p_trap_restart, (void)),
+ EXFUN (comp_access_restart, (void)),
+ EXFUN (comp_reference_restart, (void)),
+ EXFUN (comp_safe_reference_restart, (void)),
+ EXFUN (comp_unassigned_p_restart, (void)),
+ EXFUN (comp_unbound_p_restart, (void)),
+ EXFUN (comp_assignment_restart, (void)),
+ EXFUN (comp_definition_restart, (void)),
+ EXFUN (comp_lookup_apply_restart, (void)),
+ EXFUN (comp_error_restart, (void));
\f
extern SCHEME_UTILITY struct utility_result
- comutil_return_to_interpreter(),
- comutil_operator_apply_trap(),
- comutil_operator_arity_trap(),
- comutil_operator_entity_trap(),
- comutil_operator_interpreted_trap(),
- comutil_operator_lexpr_trap(),
- comutil_operator_primitive_trap(),
- comutil_operator_lookup_trap(),
- comutil_operator_1_0_trap(),
- comutil_operator_2_1_trap(),
- comutil_operator_2_0_trap(),
- comutil_operator_3_2_trap(),
- comutil_operator_3_1_trap(),
- comutil_operator_3_0_trap(),
- comutil_operator_4_3_trap(),
- comutil_operator_4_2_trap(),
- comutil_operator_4_1_trap(),
- comutil_operator_4_0_trap(),
- comutil_primitive_apply(),
- comutil_primitive_lexpr_apply(),
- comutil_apply(),
- comutil_error(),
- comutil_lexpr_apply(),
- comutil_link(),
- comutil_interrupt_closure(),
- comutil_interrupt_dlink(),
- comutil_interrupt_procedure(),
- comutil_interrupt_continuation(),
- comutil_interrupt_ic_procedure(),
- comutil_assignment_trap(),
- comutil_cache_lookup_apply(),
- comutil_lookup_trap(),
- comutil_safe_lookup_trap(),
- comutil_unassigned_p_trap(),
- comutil_decrement(),
- comutil_divide(),
- comutil_equal(),
- comutil_greater(),
- comutil_increment(),
- comutil_less(),
- comutil_minus(),
- comutil_multiply(),
- comutil_negative(),
- comutil_plus(),
- comutil_positive(),
- comutil_zero(),
- comutil_access(),
- comutil_reference(),
- comutil_safe_reference(),
- comutil_unassigned_p(),
- comutil_unbound_p(),
- comutil_assignment(),
- comutil_definition(),
- comutil_lookup_apply(),
- comutil_primitive_error();
+ EXFUN (comutil_return_to_interpreter, ()),
+ EXFUN (comutil_operator_apply_trap, ()),
+ EXFUN (comutil_operator_arity_trap, ()),
+ EXFUN (comutil_operator_entity_trap, ()),
+ EXFUN (comutil_operator_interpreted_trap, ()),
+ EXFUN (comutil_operator_lexpr_trap, ()),
+ EXFUN (comutil_operator_primitive_trap, ()),
+ EXFUN (comutil_operator_lookup_trap, ()),
+ EXFUN (comutil_operator_1_0_trap, ()),
+ EXFUN (comutil_operator_2_1_trap, ()),
+ EXFUN (comutil_operator_2_0_trap, ()),
+ EXFUN (comutil_operator_3_2_trap, ()),
+ EXFUN (comutil_operator_3_1_trap, ()),
+ EXFUN (comutil_operator_3_0_trap, ()),
+ EXFUN (comutil_operator_4_3_trap, ()),
+ EXFUN (comutil_operator_4_2_trap, ()),
+ EXFUN (comutil_operator_4_1_trap, ()),
+ EXFUN (comutil_operator_4_0_trap, ()),
+ EXFUN (comutil_primitive_apply, ()),
+ EXFUN (comutil_primitive_lexpr_apply, ()),
+ EXFUN (comutil_apply, ()),
+ EXFUN (comutil_error, ()),
+ EXFUN (comutil_lexpr_apply, ()),
+ EXFUN (comutil_link, ()),
+ EXFUN (comutil_interrupt_closure, ()),
+ EXFUN (comutil_interrupt_dlink, ()),
+ EXFUN (comutil_interrupt_procedure, ()),
+ EXFUN (comutil_interrupt_continuation, ()),
+ EXFUN (comutil_interrupt_ic_procedure, ()),
+ EXFUN (comutil_assignment_trap, ()),
+ EXFUN (comutil_cache_lookup_apply, ()),
+ EXFUN (comutil_lookup_trap, ()),
+ EXFUN (comutil_safe_lookup_trap, ()),
+ EXFUN (comutil_unassigned_p_trap, ()),
+ EXFUN (comutil_decrement, ()),
+ EXFUN (comutil_divide, ()),
+ EXFUN (comutil_equal, ()),
+ EXFUN (comutil_greater, ()),
+ EXFUN (comutil_increment, ()),
+ EXFUN (comutil_less, ()),
+ EXFUN (comutil_minus, ()),
+ EXFUN (comutil_multiply, ()),
+ EXFUN (comutil_negative, ()),
+ EXFUN (comutil_plus, ()),
+ EXFUN (comutil_positive, ()),
+ EXFUN (comutil_zero, ()),
+ EXFUN (comutil_access, ()),
+ EXFUN (comutil_reference, ()),
+ EXFUN (comutil_safe_reference, ()),
+ EXFUN (comutil_unassigned_p, ()),
+ EXFUN (comutil_unbound_p, ()),
+ EXFUN (comutil_assignment, ()),
+ EXFUN (comutil_definition, ()),
+ EXFUN (comutil_lookup_apply, ()),
+ EXFUN (comutil_primitive_error, ());
extern struct utility_result
(*(utility_table[]))();
*/
C_TO_SCHEME long
-enter_compiled_expression()
+DEFUN_VOID (enter_compiled_expression)
{
instruction *compiled_entry_address;
+ SCHEME_OBJECT *block_address, environment;
+ unsigned long length;
compiled_entry_address =
((instruction *) (OBJECT_ADDRESS (Fetch_Expression ())));
Val = (Fetch_Expression ());
return (C_to_interface ((instruction *) (OBJECT_ADDRESS (STACK_POP ()))));
}
+
+#ifdef SPLIT_CACHES
+ /* This is a kludge to handle the first execution. */
+
+ Get_Compiled_Block (block_address,
+ ((SCHEME_OBJECT *) compiled_entry_address));
+ length = (OBJECT_DATUM (*block_address));
+ environment = (block_address [length]);
+ if (!(ENVIRONMENT_P (environment)))
+ {
+ PUSH_D_CACHE_REGION (block_address, (length + 1));
+ }
+#endif /* SPLIT_CACHES */
+
return (C_to_interface (compiled_entry_address));
}
C_TO_SCHEME long
-apply_compiled_procedure()
+DEFUN_VOID (apply_compiled_procedure)
{
static long setup_compiled_invocation();
SCHEME_OBJECT nactuals, procedure;
*/
C_TO_SCHEME long
-return_to_compiled_code ()
+DEFUN_VOID (return_to_compiled_code)
{
instruction *compiled_entry_address;
*/
static long
-setup_compiled_invocation (nactuals, compiled_entry_address)
- long nactuals;
- instruction *compiled_entry_address;
+DEFUN (setup_compiled_invocation,
+ (nactuals, compiled_entry_address),
+ long nactuals AND
+ instruction *compiled_entry_address)
{
static long setup_lexpr_invocation();
static SCHEME_OBJECT *open_gap();
*/
static SCHEME_OBJECT *
-open_gap (nactuals, delta)
- register long nactuals, delta;
+DEFUN (open_gap,
+ (nactuals, delta),
+ register long nactuals AND register long delta)
{
register SCHEME_OBJECT *gap_location, *source_location;
/* Setup a rest argument as appropriate. */
static long
-setup_lexpr_invocation (nactuals, nmax, entry_address)
- register long nactuals, nmax;
- instruction *entry_address;
+DEFUN (setup_lexpr_invocation,
+ (nactuals, nmax, entry_address),
+ register long nactuals AND register long nmax AND
+ instruction *entry_address)
{
register long delta;
*/
SCHEME_UTILITY struct utility_result
-comutil_return_to_interpreter (tramp_data, ignore_2, ignore_3, ignore_4)
- SCHEME_OBJECT *tramp_data;
- long ignore_2, ignore_3, ignore_4;
+DEFUN (comutil_return_to_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_DONE);
}
*/
SCHEME_UTILITY struct utility_result
-comutil_primitive_apply (primitive, ignore_2, ignore_3, ignore_4)
- SCHEME_OBJECT primitive;
- long ignore_2, ignore_3, ignore_4;
+DEFUN (comutil_primitive_apply,
+ (primitive, ignore_2, ignore_3, ignore_4),
+ SCHEME_OBJECT primitive AND
+ long ignore_2 AND long ignore_3 AND long ignore_4)
{
PRIMITIVE_APPLY (Val, primitive);
POP_PRIMITIVE_FRAME (PRIMITIVE_ARITY (primitive));
*/
SCHEME_UTILITY struct utility_result
-comutil_primitive_lexpr_apply (primitive, ignore_2, ignore_3, ignore_4)
- SCHEME_OBJECT primitive;
- long ignore_2, ignore_3, ignore_4;
+DEFUN (comutil_primitive_lexpr_apply,
+ (primitive, ignore_2, ignore_3, ignore_4),
+ SCHEME_OBJECT primitive AND
+ long ignore_2 AND long ignore_3 AND long ignore_4)
{
PRIMITIVE_APPLY (Val, primitive);
POP_PRIMITIVE_FRAME (((long) Regs[REGBLOCK_LEXPR_ACTUALS]));
*/
SCHEME_UTILITY struct utility_result
-comutil_apply (procedure, nactuals, ignore_3, ignore_4)
- SCHEME_OBJECT procedure;
- long nactuals, ignore_3, ignore_4;
+DEFUN (comutil_apply,
+ (procedure, nactuals, ignore_3, ignore_4),
+ SCHEME_OBJECT procedure AND
+ long nactuals AND long ignore_3 AND long ignore_4)
{
switch (OBJECT_TYPE (procedure))
{
*/
SCHEME_UTILITY struct utility_result
-comutil_error (nactuals, ignore_2, ignore_3, ignore_4)
- long nactuals, ignore_2, ignore_3, ignore_4;
+DEFUN (comutil_error,
+ (nactuals, ignore_2, ignore_3, ignore_4),
+ long nactuals AND long ignore_2 AND long ignore_3 AND long ignore_4)
{
SCHEME_OBJECT error_procedure;
*/
SCHEME_UTILITY struct utility_result
-comutil_lexpr_apply (entry_address, nactuals, ignore_3, ignore_4)
- register instruction *entry_address;
- long nactuals;
- long ignore_3, ignore_4;
+DEFUN (comutil_lexpr_apply,
+ (entry_address, nactuals, ignore_3, ignore_4),
+ register instruction *entry_address AND
+ long nactuals AND
+ long ignore_3 AND long ignore_4)
{
RETURN_UNLESS_EXCEPTION
((setup_lexpr_invocation
\f
/* Core of comutil_link and comp_link_caches_restart. */
+static Boolean linking_cc_block_p = false;
+
+static void
+DEFUN (abort_link_cc_block, (ap), PTR ap)
+{
+ linking_cc_block_p = (* ((Boolean *) (ap)));
+ return;
+}
+
static long
-link_cc_block (block_address, offset, last_header_offset,
- sections, original_count, ret_add)
- register SCHEME_OBJECT *block_address;
- register long offset;
- long last_header_offset, sections, original_count;
- instruction *ret_add;
+DEFUN (link_cc_block,
+ (block_address, offset, last_header_offset,
+ sections, original_count, ret_add),
+ register SCHEME_OBJECT *block_address AND
+ register long offset AND
+ long last_header_offset AND
+ long sections AND
+ long original_count AND
+ instruction *ret_add)
{
Boolean execute_p;
register long entry_size, count;
long result, kind, total_count;
long (*cache_handler)();
+ transaction_begin ();
+ {
+ Boolean * ap = (dstack_alloc (sizeof (Boolean)));
+ *ap = linking_cc_block_p;
+ transaction_record_action (tat_abort, abort_link_cc_block, ap);
+ }
+ linking_cc_block_p = true;
+
+ result = PRIM_DONE;
block = (MAKE_CC_BLOCK (block_address));
while ((--sections) >= 0)
{
total_count = count;
}
-
+\f
block_address[last_header_offset] =
(MAKE_LINKAGE_SECTION_HEADER (kind, total_count));
for (offset += 1; ((--count) >= 0); offset += entry_size)
block_address[last_header_offset] =
(MAKE_LINKAGE_SECTION_HEADER (kind, (total_count - (count + 1))));
- return (result);
+ goto exit_proc;
}
}
last_header_offset = offset;
}
- return (PRIM_DONE);
+
+exit_proc:
+ /* Rather than commit, since we want to undo */
+ transaction_abort ();
+ PUSH_D_CACHE_REGION (block_address,
+ (((unsigned long) (*block_address)) + 1));
+ return (result);
}
\f
/*
*/
SCHEME_UTILITY struct utility_result
-comutil_link (ret_add, block_address, constant_address, sections)
- instruction *ret_add;
- SCHEME_OBJECT *block_address, *constant_address;
- long sections;
+DEFUN (comutil_link,
+ (ret_add, block_address, constant_address, sections),
+ instruction *ret_add AND
+ SCHEME_OBJECT *block_address AND SCHEME_OBJECT *constant_address AND
+ long sections)
{
long offset;
*/
C_TO_SCHEME long
-comp_link_caches_restart ()
+DEFUN_VOID (comp_link_caches_restart)
{
SCHEME_OBJECT block, environment;
long original_count, offset, last_header_offset, sections, code;
*/
SCHEME_UTILITY struct utility_result
-comutil_operator_apply_trap (tramp_data, ignore_2, ignore_3, ignore_4)
- SCHEME_OBJECT *tramp_data;
- long ignore_2, ignore_3, ignore_4;
+DEFUN (comutil_operator_apply_trap,
+ (tramp_data, ignore_2, ignore_3, ignore_4),
+ SCHEME_OBJECT *tramp_data AND
+ long ignore_2 AND long ignore_3 AND long ignore_4)
{
/* Used by coerce_to_compiled. TRAMPOLINE_K_APPLY */
}
SCHEME_UTILITY struct utility_result
-comutil_operator_arity_trap (tramp_data, ignore_2, ignore_3, ignore_4)
- SCHEME_OBJECT *tramp_data;
- long ignore_2, ignore_3, ignore_4;
+DEFUN (comutil_operator_arity_trap,
+ (tramp_data, ignore_2, ignore_3, ignore_4),
+ SCHEME_OBJECT *tramp_data AND
+ long ignore_2 AND long ignore_3 AND long ignore_4)
{
/* Linker saw an argument count mismatch. TRAMPOLINE_K_ARITY */
}
SCHEME_UTILITY struct utility_result
-comutil_operator_entity_trap (tramp_data, ignore_2, ignore_3, ignore_4)
- SCHEME_OBJECT *tramp_data;
- long ignore_2, ignore_3, ignore_4;
+DEFUN (comutil_operator_entity_trap,
+ (tramp_data, ignore_2, ignore_3, ignore_4),
+ SCHEME_OBJECT *tramp_data AND
+ long ignore_2 AND long ignore_3 AND long ignore_4)
{
/* Linker saw an entity to be applied. TRAMPOLINE_K_ENTITY */
}
\f
SCHEME_UTILITY struct utility_result
-comutil_operator_interpreted_trap (tramp_data, ignore_2, ignore_3, ignore_4)
- SCHEME_OBJECT *tramp_data;
- long ignore_2, ignore_3, ignore_4;
+DEFUN (comutil_operator_interpreted_trap,
+ (tramp_data, ignore_2, ignore_3, ignore_4),
+ SCHEME_OBJECT *tramp_data AND
+ long ignore_2 AND long ignore_3 AND long ignore_4)
{
/* Linker saw an interpreted procedure or a procedure that it cannot
link directly. TRAMPOLINE_K_INTERPRETED
}
SCHEME_UTILITY struct utility_result
-comutil_operator_lexpr_trap (tramp_data, ignore_2, ignore_3, ignore_4)
- SCHEME_OBJECT *tramp_data;
- long ignore_2, ignore_3, ignore_4;
+DEFUN (comutil_operator_lexpr_trap,
+ (tramp_data, ignore_2, ignore_3, ignore_4),
+ SCHEME_OBJECT *tramp_data AND
+ long ignore_2 AND long ignore_3 AND long ignore_4)
{
/* Linker saw a primitive of arbitrary number of arguments.
TRAMPOLINE_K_LEXPR_PRIMITIVE
}
SCHEME_UTILITY struct utility_result
-comutil_operator_primitive_trap (tramp_data, ignore_2, ignore_3, ignore_4)
- SCHEME_OBJECT *tramp_data;
- long ignore_2, ignore_3, ignore_4;
+DEFUN (comutil_operator_primitive_trap,
+ (tramp_data, ignore_2, ignore_3, ignore_4),
+ SCHEME_OBJECT *tramp_data AND
+ long ignore_2 AND long ignore_3 AND long ignore_4)
{
/* Linker saw a primitive of fixed matching arity. TRAMPOLINE_K_PRIMITIVE */
*/
SCHEME_UTILITY struct utility_result
-comutil_operator_lookup_trap (tramp_data, ignore_2, ignore_3, ignore_4)
- SCHEME_OBJECT *tramp_data;
- long ignore_2, ignore_3, ignore_4;
+DEFUN (comutil_operator_lookup_trap,
+ (tramp_data, ignore_2, ignore_3, ignore_4),
+ SCHEME_OBJECT *tramp_data AND
+ long ignore_2 AND long ignore_3 AND long ignore_4)
{
extern long complr_operator_reference_trap();
SCHEME_OBJECT true_operator, *cache_cell;
*/
C_TO_SCHEME long
-comp_op_lookup_trap_restart ()
+DEFUN_VOID (comp_op_lookup_trap_restart)
{
SCHEME_OBJECT *old_trampoline, code_block, new_procedure;
long offset;
*/
SCHEME_UTILITY struct utility_result
-comutil_operator_1_0_trap (tramp_data, ignore_2, ignore_3, ignore_4)
- SCHEME_OBJECT *tramp_data;
- long ignore_2, ignore_3, ignore_4;
+DEFUN (comutil_operator_1_0_trap,
+ (tramp_data, ignore_2, ignore_3, ignore_4),
+ SCHEME_OBJECT *tramp_data AND
+ long ignore_2 AND long ignore_3 AND long ignore_4)
{
STACK_PUSH (UNASSIGNED_OBJECT);
RETURN_TO_SCHEME (OBJECT_ADDRESS (tramp_data[0]));
}
SCHEME_UTILITY struct utility_result
-comutil_operator_2_1_trap (tramp_data, ignore_2, ignore_3, ignore_4)
- SCHEME_OBJECT *tramp_data;
- long ignore_2, ignore_3, ignore_4;
+DEFUN (comutil_operator_2_1_trap,
+ (tramp_data, ignore_2, ignore_3, ignore_4),
+ SCHEME_OBJECT *tramp_data AND
+ long ignore_2 AND long ignore_3 AND long ignore_4)
{
SCHEME_OBJECT Top;
}
SCHEME_UTILITY struct utility_result
-comutil_operator_2_0_trap (tramp_data, ignore_2, ignore_3, ignore_4)
- SCHEME_OBJECT *tramp_data;
- long ignore_2, ignore_3, ignore_4;
+DEFUN (comutil_operator_2_0_trap,
+ (tramp_data, ignore_2, ignore_3, ignore_4),
+ SCHEME_OBJECT *tramp_data AND
+ long ignore_2 AND long ignore_3 AND long ignore_4)
{
STACK_PUSH (UNASSIGNED_OBJECT);
STACK_PUSH (UNASSIGNED_OBJECT);
}
SCHEME_UTILITY struct utility_result
-comutil_operator_3_2_trap (tramp_data, ignore_2, ignore_3, ignore_4)
- SCHEME_OBJECT *tramp_data;
- long ignore_2, ignore_3, ignore_4;
+DEFUN (comutil_operator_3_2_trap,
+ (tramp_data, ignore_2, ignore_3, ignore_4),
+ SCHEME_OBJECT *tramp_data AND
+ long ignore_2 AND long ignore_3 AND long ignore_4)
{
SCHEME_OBJECT Top, Next;
}
\f
SCHEME_UTILITY struct utility_result
-comutil_operator_3_1_trap (tramp_data, ignore_2, ignore_3, ignore_4)
- SCHEME_OBJECT *tramp_data;
- long ignore_2, ignore_3, ignore_4;
+DEFUN (comutil_operator_3_1_trap,
+ (tramp_data, ignore_2, ignore_3, ignore_4),
+ SCHEME_OBJECT *tramp_data AND
+ long ignore_2 AND long ignore_3 AND long ignore_4)
{
SCHEME_OBJECT Top;
}
SCHEME_UTILITY struct utility_result
-comutil_operator_3_0_trap (tramp_data, ignore_2, ignore_3, ignore_4)
- SCHEME_OBJECT *tramp_data;
- long ignore_2, ignore_3, ignore_4;
+DEFUN (comutil_operator_3_0_trap,
+ (tramp_data, ignore_2, ignore_3, ignore_4),
+ SCHEME_OBJECT *tramp_data AND
+ long ignore_2 AND long ignore_3 AND long ignore_4)
{
STACK_PUSH (UNASSIGNED_OBJECT);
STACK_PUSH (UNASSIGNED_OBJECT);
}
SCHEME_UTILITY struct utility_result
-comutil_operator_4_3_trap (tramp_data, ignore_2, ignore_3, ignore_4)
- SCHEME_OBJECT *tramp_data;
- long ignore_2, ignore_3, ignore_4;
+DEFUN (comutil_operator_4_3_trap,
+ (tramp_data, ignore_2, ignore_3, ignore_4),
+ SCHEME_OBJECT *tramp_data AND
+ long ignore_2 AND long ignore_3 AND long ignore_4)
{
SCHEME_OBJECT Top, Middle, Bottom;
}
SCHEME_UTILITY struct utility_result
-comutil_operator_4_2_trap (tramp_data, ignore_2, ignore_3, ignore_4)
- SCHEME_OBJECT *tramp_data;
- long ignore_2, ignore_3, ignore_4;
+DEFUN (comutil_operator_4_2_trap,
+ (tramp_data, ignore_2, ignore_3, ignore_4),
+ SCHEME_OBJECT *tramp_data AND
+ long ignore_2 AND long ignore_3 AND long ignore_4)
{
SCHEME_OBJECT Top, Next;
}
\f
SCHEME_UTILITY struct utility_result
-comutil_operator_4_1_trap (tramp_data, ignore_2, ignore_3, ignore_4)
- SCHEME_OBJECT *tramp_data;
- long ignore_2, ignore_3, ignore_4;
+DEFUN (comutil_operator_4_1_trap,
+ (tramp_data, ignore_2, ignore_3, ignore_4),
+ SCHEME_OBJECT *tramp_data AND
+ long ignore_2 AND long ignore_3 AND long ignore_4)
{
SCHEME_OBJECT Top;
}
SCHEME_UTILITY struct utility_result
-comutil_operator_4_0_trap (tramp_data, ignore_2, ignore_3, ignore_4)
- SCHEME_OBJECT *tramp_data;
- long ignore_2, ignore_3, ignore_4;
+DEFUN (comutil_operator_4_0_trap,
+ (tramp_data, ignore_2, ignore_3, ignore_4),
+ SCHEME_OBJECT *tramp_data AND
+ long ignore_2 AND long ignore_3 AND long ignore_4)
{
STACK_PUSH (UNASSIGNED_OBJECT);
STACK_PUSH (UNASSIGNED_OBJECT);
*/
SCHEME_UTILITY struct utility_result
-comutil_interrupt_closure (ignore_1, ignore_2, ignore_3, ignore_4)
- long ignore_1, ignore_2, ignore_3, ignore_4;
+DEFUN (comutil_interrupt_closure,
+ (ignore_1, ignore_2, ignore_3, ignore_4),
+ long ignore_1 AND long ignore_2 AND long ignore_3 AND long ignore_4)
{
TEST_GC_NEEDED();
if ((PENDING_INTERRUPTS()) == 0)
*/
static struct utility_result
-compiler_interrupt_common (entry_point, offset, state)
- instruction *entry_point;
- long offset;
- SCHEME_OBJECT state;
+DEFUN (compiler_interrupt_common,
+ (entry_point, offset, state),
+ instruction *entry_point AND
+ long offset AND
+ SCHEME_OBJECT state)
{
TEST_GC_NEEDED();
if ((PENDING_INTERRUPTS()) == 0)
}
SCHEME_UTILITY struct utility_result
-comutil_interrupt_dlink (entry_point, dlink, ignore_3, ignore_4)
- instruction *entry_point;
- SCHEME_OBJECT *dlink;
- long ignore_3, ignore_4;
+DEFUN (comutil_interrupt_dlink,
+ (entry_point, dlink, ignore_3, ignore_4),
+ instruction *entry_point AND
+ SCHEME_OBJECT *dlink AND
+ long ignore_3 AND long ignore_4)
{
return
(compiler_interrupt_common(entry_point,
}
SCHEME_UTILITY struct utility_result
-comutil_interrupt_procedure (entry_point, ignore_2, ignore_3, ignore_4)
- instruction *entry_point;
- long ignore_2, ignore_3, ignore_4;
+DEFUN (comutil_interrupt_procedure,
+ (entry_point, ignore_2, ignore_3, ignore_4),
+ instruction *entry_point AND
+ long ignore_2 AND long ignore_3 AND long ignore_4)
{
return (compiler_interrupt_common(entry_point,
ENTRY_SKIPPED_CHECK_OFFSET,
/* Val has live data, and there is no entry address on the stack */
SCHEME_UTILITY struct utility_result
-comutil_interrupt_continuation (return_address, ignore_2, ignore_3, ignore_4)
- instruction *return_address;
- long ignore_2, ignore_3, ignore_4;
+DEFUN (comutil_interrupt_continuation,
+ (return_address, ignore_2, ignore_3, ignore_4),
+ instruction *return_address AND
+ long ignore_2 AND long ignore_3 AND long ignore_4)
{
return (compiler_interrupt_common (return_address,
ENTRY_SKIPPED_CHECK_OFFSET,
/* Env has live data; no entry point on the stack */
SCHEME_UTILITY struct utility_result
-comutil_interrupt_ic_procedure (entry_point, ignore_2, ignore_3, ignore_4)
- instruction *entry_point;
- long ignore_2, ignore_3, ignore_4;
+DEFUN (comutil_interrupt_ic_procedure,
+ (entry_point, ignore_2, ignore_3, ignore_4),
+ instruction *entry_point AND
+ long ignore_2 AND long ignore_3 AND long ignore_4)
{
return (compiler_interrupt_common (entry_point,
ENTRY_SKIPPED_CHECK_OFFSET,
}
C_TO_SCHEME long
-comp_interrupt_restart ()
+DEFUN_VOID (comp_interrupt_restart)
{
SCHEME_OBJECT state;
/* Assigning a variable that has a trap in it (except unassigned) */
SCHEME_UTILITY struct utility_result
-comutil_assignment_trap (return_address, extension_addr, value, ignore_4)
- instruction *return_address;
- SCHEME_OBJECT *extension_addr, value;
- long ignore_4;
+DEFUN (comutil_assignment_trap,
+ (return_address, extension_addr, value, ignore_4),
+ instruction *return_address AND
+ SCHEME_OBJECT *extension_addr AND SCHEME_OBJECT value AND
+ long ignore_4)
{
extern long compiler_assignment_trap();
SCHEME_OBJECT extension;
}
else
{
- SCHEME_OBJECT block, environment, name;
+ SCHEME_OBJECT block, environment, name, sra;
- STACK_PUSH(ENTRY_TO_OBJECT (return_address));
+ sra = (ENTRY_TO_OBJECT (return_address));
+ STACK_PUSH (sra);
STACK_PUSH (value);
- block = (compiled_entry_to_block (return_address));
+ block = (compiled_entry_to_block (sra));
environment = (compiled_block_environment (block));
STACK_PUSH (environment);
name = (compiler_var_error (extension, environment));
}
C_TO_SCHEME long
-comp_assignment_trap_restart ()
+DEFUN_VOID (comp_assignment_trap_restart)
{
extern long Symbol_Lex_Set();
SCHEME_OBJECT name, environment, value;
}
\f
SCHEME_UTILITY struct utility_result
-comutil_cache_lookup_apply (extension_addr, block_address, nactuals, ignore_4)
- SCHEME_OBJECT *extension_addr, *block_address;
- long nactuals, ignore_4;
+DEFUN (comutil_cache_lookup_apply,
+ (extension_addr, block_address, nactuals, ignore_4),
+ SCHEME_OBJECT *extension_addr AND SCHEME_OBJECT *block_address AND
+ long nactuals AND long ignore_4)
{
extern long compiler_lookup_trap();
SCHEME_OBJECT extension;
}
C_TO_SCHEME long
-comp_cache_lookup_apply_restart ()
+DEFUN_VOID (comp_cache_lookup_apply_restart)
{
extern long Symbol_Lex_Ref();
SCHEME_OBJECT name, environment, block;
#define CMPLR_REF_TRAP(name, c_trap, ret_code, restart, c_lookup) \
SCHEME_UTILITY struct utility_result \
-name (return_address, extension_addr, ignore_3, ignore_4) \
- instruction *return_address; \
- SCHEME_OBJECT *extension_addr; \
- long ignore_3, ignore_4; \
+DEFUN (name, \
+ (return_address, extension_addr, ignore_3, ignore_4), \
+ instruction *return_address AND \
+ SCHEME_OBJECT *extension_addr AND \
+ long ignore_3 AND long ignore_4) \
{ \
extern long c_trap(); \
long code; \
} \
else \
{ \
- SCHEME_OBJECT block, environment, name; \
+ SCHEME_OBJECT block, environment, name, sra; \
\
- STACK_PUSH (ENTRY_TO_OBJECT (return_address)); \
- block = (compiled_entry_to_block (return_address)); \
+ sra = (ENTRY_TO_OBJECT (return_address)); \
+ STACK_PUSH (sra); \
+ block = (compiled_entry_to_block (sra)); \
environment = (compiled_block_environment (block)); \
STACK_PUSH (environment); \
name = (compiler_var_error (extension, environment)); \
} \
\
C_TO_SCHEME long \
-restart () \
+DEFUN_VOID (restart) \
{ \
extern long c_lookup(); \
SCHEME_OBJECT name, environment; \
#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; \
+DEFUN (name, \
+ (ignore_1, ignore_2, ignore_3, ignore_4), \
+ long ignore_1 AND long ignore_2 AND \
+ long ignore_3 AND long ignore_4) \
{ \
SCHEME_OBJECT handler; \
\
#define CMPLR_REFERENCE(util_name, c_proc, ret_code, restart_name) \
SCHEME_UTILITY struct utility_result \
-util_name (ret_add, environment, variable, ignore_4) \
- instruction *ret_add; \
- SCHEME_OBJECT environment, variable; \
- long ignore_4; \
+DEFUN (util_name, \
+ (ret_add, environment, variable, ignore_4), \
+ instruction *ret_add AND \
+ SCHEME_OBJECT environment AND SCHEME_OBJECT variable AND \
+ long ignore_4) \
{ \
extern long c_proc(); \
long code; \
} \
\
C_TO_SCHEME long \
-restart_name () \
+DEFUN_VOID (restart_name) \
{ \
extern long c_proc(); \
SCHEME_OBJECT environment, variable; \
\f
#define CMPLR_ASSIGNMENT(util_name, c_proc, ret_code, restart_name) \
SCHEME_UTILITY struct utility_result \
-util_name (ret_add, environment, variable, value) \
- instruction *ret_add; \
- SCHEME_OBJECT environment, variable, value; \
+DEFUN (util_name, \
+ (ret_add, environment, variable, value), \
+ instruction *ret_add AND \
+ SCHEME_OBJECT environment AND SCHEME_OBJECT variable \
+ AND SCHEME_OBJECT value) \
{ \
extern long c_proc(); \
long code; \
} \
\
C_TO_SCHEME long \
-restart_name () \
+DEFUN_VOID (restart_name) \
{ \
extern long c_proc(); \
SCHEME_OBJECT environment, variable, value; \
comp_definition_restart);
\f
SCHEME_UTILITY struct utility_result
-comutil_lookup_apply (environment, variable, nactuals, ignore_4)
- SCHEME_OBJECT environment, variable;
- long nactuals, ignore_4;
+DEFUN (comutil_lookup_apply,
+ (environment, variable, nactuals, ignore_4),
+ SCHEME_OBJECT environment AND SCHEME_OBJECT variable AND
+ long nactuals AND long ignore_4)
{
extern long Lex_Ref();
long code;
}
C_TO_SCHEME long
-comp_lookup_apply_restart ()
+DEFUN_VOID (comp_lookup_apply_restart)
{
extern long Lex_Ref();
SCHEME_OBJECT environment, variable;
}
\f
SCHEME_UTILITY struct utility_result
-comutil_primitive_error (ret_add, primitive, ignore_3, ignore_4)
- instruction *ret_add;
- SCHEME_OBJECT primitive;
- long ignore_3, ignore_4;
+DEFUN (comutil_primitive_error,
+ (ret_add, primitive, ignore_3, ignore_4),
+ instruction *ret_add AND
+ SCHEME_OBJECT primitive AND
+ long ignore_3 AND long ignore_4)
{
STACK_PUSH (ENTRY_TO_OBJECT (ret_add));
STACK_PUSH (primitive);
}
C_TO_SCHEME long
-comp_error_restart ()
+DEFUN_VOID (comp_error_restart)
{
instruction *ret_add;
*/
C_UTILITY SCHEME_OBJECT
-compiled_block_debugging_info (block)
- SCHEME_OBJECT block;
+DEFUN (compiled_block_debugging_info,
+ (block),
+ SCHEME_OBJECT block)
{
long length;
/* Extract the environment where the `block' was "loaded". */
C_UTILITY SCHEME_OBJECT
-compiled_block_environment (block)
- SCHEME_OBJECT block;
+DEFUN (compiled_block_environment,
+ (block),
+ SCHEME_OBJECT block)
{
long length;
*/
C_UTILITY SCHEME_OBJECT *
-compiled_entry_to_block_address (entry)
- SCHEME_OBJECT entry;
+DEFUN (compiled_entry_to_block_address,
+ (entry),
+ SCHEME_OBJECT entry)
{
SCHEME_OBJECT *block_address;
}
C_UTILITY SCHEME_OBJECT
-compiled_entry_to_block (entry)
- SCHEME_OBJECT entry;
+DEFUN (compiled_entry_to_block,
+ (entry),
+ SCHEME_OBJECT entry)
{
SCHEME_OBJECT *block_address;
/* Returns the offset from the block to the entry point. */
C_UTILITY long
-compiled_entry_to_block_offset (entry)
- SCHEME_OBJECT entry;
+DEFUN (compiled_entry_to_block_offset,
+ (entry),
+ SCHEME_OBJECT entry)
{
SCHEME_OBJECT *entry_address, *block_address;
*/
static long
-block_address_closure_p (block_addr)
- SCHEME_OBJECT *block_addr;
+DEFUN (block_address_closure_p,
+ (block_addr),
+ SCHEME_OBJECT *block_addr)
{
SCHEME_OBJECT header_word;
*/
C_UTILITY long
-compiled_block_closure_p (block)
- SCHEME_OBJECT block;
+DEFUN (compiled_block_closure_p,
+ (block),
+ SCHEME_OBJECT block)
{
return (block_address_closure_p (OBJECT_ADDRESS (block)));
}
*/
C_UTILITY long
-compiled_entry_closure_p (entry)
- SCHEME_OBJECT entry;
+DEFUN (compiled_entry_closure_p,
+ (entry),
+ SCHEME_OBJECT entry)
{
return (block_address_closure_p (compiled_entry_to_block_address (entry)));
}
*/
C_UTILITY SCHEME_OBJECT
-compiled_closure_to_entry (entry)
- SCHEME_OBJECT entry;
+DEFUN (compiled_closure_to_entry,
+ (entry),
+ SCHEME_OBJECT entry)
{
SCHEME_OBJECT real_entry;
#define CONTINUATION_RETURN_TO_INTERPRETER 2
C_UTILITY void
-compiled_entry_type (entry, buffer)
- SCHEME_OBJECT entry;
- long *buffer;
+DEFUN (compiled_entry_type,
+ (entry, buffer),
+ SCHEME_OBJECT entry AND
+ long *buffer)
{
long kind, min_arity, max_arity, field1, field2;
SCHEME_OBJECT *entry_address;
/* Destructuring free variable caches. */
C_UTILITY void
-store_variable_cache (extension, block, offset)
- SCHEME_OBJECT extension, block;
- long offset;
+DEFUN (store_variable_cache,
+ (extension, block, offset),
+ SCHEME_OBJECT extension AND SCHEME_OBJECT block AND
+ long offset)
{
FAST_MEMORY_SET (block, offset,
((SCHEME_OBJECT) (OBJECT_ADDRESS (extension))));
}
C_UTILITY SCHEME_OBJECT
-extract_variable_cache (block, offset)
- SCHEME_OBJECT block;
- long offset;
+DEFUN (extract_variable_cache,
+ (block, offset),
+ SCHEME_OBJECT block AND
+ long offset)
{
return (MAKE_POINTER_OBJECT (TRAP_EXTENSION_TYPE,
((SCHEME_OBJECT *)
/* Get a compiled procedure from a cached operator reference. */
C_UTILITY SCHEME_OBJECT
-extract_uuo_link (block, offset)
- SCHEME_OBJECT block;
- long offset;
+DEFUN (extract_uuo_link,
+ (block, offset),
+ SCHEME_OBJECT block AND
+ long offset)
{
SCHEME_OBJECT *cache_address, compiled_entry_address;
return (ENTRY_TO_OBJECT ((SCHEME_OBJECT *) compiled_entry_address));
}
-#ifndef FLUSH_I_CACHE_REGION
-
-#define FLUSH_I_CACHE_REGION(addr, nwords) \
-do { \
-} while (0)
-
-#endif
-
static void
-store_uuo_link (entry, cache_address)
- SCHEME_OBJECT entry, *cache_address;
+DEFUN (store_uuo_link,
+ (entry, cache_address),
+ SCHEME_OBJECT entry AND SCHEME_OBJECT *cache_address)
{
SCHEME_OBJECT *entry_address;
entry_address = (OBJECT_ADDRESS (entry));
STORE_EXECUTE_CACHE_CODE (cache_address);
STORE_EXECUTE_CACHE_ADDRESS (cache_address, entry_address);
- FLUSH_I_CACHE_REGION (cache_address, EXECUTE_CACHE_ENTRY_SIZE);
+ if (!linking_cc_block_p)
+ {
+ /* The linker will flush the whole region afterwards. */
+
+ FLUSH_I_CACHE_REGION (cache_address, EXECUTE_CACHE_ENTRY_SIZE);
+ }
return;
}
\f
#define TRAMPOLINE_SIZE (TRAMPOLINE_ENTRY_SIZE + 2)
static long
-make_trampoline (slot, fmt_word, kind, size, value1, value2, value3)
- SCHEME_OBJECT *slot;
- format_word fmt_word;
- long kind, size;
- SCHEME_OBJECT value1, value2, value3;
+DEFUN (make_trampoline,
+ (slot, fmt_word, kind, size, value1, value2, value3),
+ SCHEME_OBJECT *slot AND
+ format_word fmt_word AND
+ long kind AND long size AND
+ SCHEME_OBJECT value1 AND SCHEME_OBJECT value2
+ AND SCHEME_OBJECT value3)
{
SCHEME_OBJECT *block, *local_free, *entry_point;
/* Standard trampolines. */
static long
-make_redirection_trampoline (slot, kind, procedure)
- SCHEME_OBJECT *slot;
- long kind;
- SCHEME_OBJECT procedure;
+DEFUN (make_redirection_trampoline,
+ (slot, kind, procedure),
+ SCHEME_OBJECT *slot AND
+ long kind AND
+ SCHEME_OBJECT procedure)
{
return (make_trampoline (slot,
((format_word) FORMAT_WORD_CMPINT),
}
static long
-make_apply_trampoline (slot, kind, procedure, nactuals)
- SCHEME_OBJECT *slot;
- long kind, nactuals;
- SCHEME_OBJECT procedure;
+DEFUN (make_apply_trampoline,
+ (slot, kind, procedure, nactuals),
+ SCHEME_OBJECT *slot AND
+ long kind AND SCHEME_OBJECT procedure AND
+ long nactuals)
{
return (make_trampoline (slot,
((format_word) FORMAT_WORD_CMPINT),
*/
C_UTILITY long
-make_uuo_link (procedure, extension, block, offset)
- SCHEME_OBJECT procedure, extension, block;
- long offset;
+DEFUN (make_uuo_link,
+ (procedure, extension, block, offset),
+ SCHEME_OBJECT procedure AND SCHEME_OBJECT extension
+ AND SCHEME_OBJECT block AND
+ long offset)
{
long kind, result, nactuals;
SCHEME_OBJECT trampoline, *cache_address;
}
\f
C_UTILITY long
-make_fake_uuo_link (extension, block, offset)
- SCHEME_OBJECT extension, block;
- long offset;
+DEFUN (make_fake_uuo_link,
+ (extension, block, offset),
+ SCHEME_OBJECT extension AND SCHEME_OBJECT block AND
+ long offset)
{
long result;
SCHEME_OBJECT trampoline, *cache_address;
/* C_UTILITY long fake_uuo_link_p does not appear to be used anymore */
C_UTILITY long
-coerce_to_compiled (procedure, arity, location)
- SCHEME_OBJECT procedure, *location;
- long arity;
+DEFUN (coerce_to_compiled,
+ (procedure, arity, location),
+ SCHEME_OBJECT procedure AND long arity AND SCHEME_OBJECT *location)
{
long frame_size;
#define COMPILER_INTERFACE_VERSION 3
#ifndef COMPILER_REGBLOCK_N_FIXED
-#define COMPILER_REGBLOCK_N_FIXED 16
+# define COMPILER_REGBLOCK_N_FIXED 16
#endif
#ifndef COMPILER_REGBLOCK_N_TEMPS
-#define COMPILER_REGBLOCK_N_TEMPS 256
+# define COMPILER_REGBLOCK_N_TEMPS 256
#endif
#ifndef COMPILER_REGBLOCK_EXTRA_SIZE
-#define COMPILER_REGBLOCK_EXTRA_SIZE 0
+# define COMPILER_REGBLOCK_EXTRA_SIZE 0
#endif
#if (REGBLOCK_MINIMUM_LENGTH > COMPILER_REGBLOCK_N_FIXED)
-#include "error: cmpint.c and const.h disagree on REGBLOCK_MINIMUM_LENGTH!"
+# error "cmpint.c and const.h disagree on REGBLOCK_MINIMUM_LENGTH!"
#endif
/* ((sizeof(SCHEME_OBJECT)) / (sizeof(SCHEME_OBJECT))) */
#define COMPILER_FIXED_SIZE 1
#ifndef COMPILER_TEMP_SIZE
-#define COMPILER_TEMP_SIZE ((sizeof (double)) / (sizeof (SCHEME_OBJECT)))
+# define COMPILER_TEMP_SIZE ((sizeof (double)) / (sizeof (SCHEME_OBJECT)))
#endif
#define REGBLOCK_LENGTH \
-((COMPILER_REGBLOCK_N_FIXED * COMPILER_FIXED_SIZE) + \
- (COMPILER_REGBLOCK_N_TEMPS * COMPILER_TEMP_SIZE) + \
- COMPILER_REGBLOCK_EXTRA_SIZE)
+ ((COMPILER_REGBLOCK_N_FIXED * COMPILER_FIXED_SIZE) + \
+ (COMPILER_REGBLOCK_N_TEMPS * COMPILER_TEMP_SIZE) + \
+ COMPILER_REGBLOCK_EXTRA_SIZE)
#ifndef ASM_RESET_HOOK
-#define ASM_RESET_HOOK() \
-do { \
-} while (0)
+# define ASM_RESET_HOOK() NOP()
#endif
\f
long
Registers[REGBLOCK_LENGTH];
static void
-compiler_reset_internal ()
+DEFUN_VOID (compiler_reset_internal)
{
/* Other stuff can be placed here. */
+ Registers[REGBLOCK_CLOSURE_FREE] = ((SCHEME_OBJECT) NULL);
+ Registers[REGBLOCK_CLOSURE_SPACE] = ((SCHEME_OBJECT) 0);
+
ASM_RESET_HOOK();
+
return_to_interpreter =
(ENTRY_TO_OBJECT ((SCHEME_OBJECT *)
((OBJECT_ADDRESS (compiler_utilities)) +
}
\f
C_UTILITY void
-compiler_reset (new_block)
- SCHEME_OBJECT new_block;
+DEFUN (compiler_reset,
+ (new_block),
+ SCHEME_OBJECT new_block)
{
/* Called after a disk restore */
}
C_UTILITY void
-compiler_initialize (fasl_p)
- long fasl_p;
+DEFUN (compiler_initialize,
+ (fasl_p),
+ long fasl_p)
{
/* Start-up of whole interpreter */
}
else
{
+ /* Delay until after band-load, when compiler_reset will be invoked. */
compiler_utilities = SHARP_F;
return_to_interpreter = SHARP_F;
}
return_to_interpreter;
extern long
- enter_compiled_expression(),
- apply_compiled_procedure(),
- return_to_compiled_code(),
- make_fake_uuo_link(),
- make_uuo_link(),
- compiled_block_closure_p(),
- compiled_entry_closure_p(),
- compiled_entry_to_block_offset();
+ EXFUN (enter_compiled_expression, (void)),
+ EXFUN (apply_compiled_procedure, (void)),
+ EXFUN (return_to_compiled_code, (void)),
+ EXFUN (make_fake_uuo_link,
+ (SCHEME_OBJECT extension, SCHEME_OBJECT block, long offset)),
+ EXFUN (make_uuo_link,
+ (SCHEME_OBJECT value, SCHEME_OBJECT extension,
+ SCHEME_OBJECT block, long offset)),
+ EXFUN (compiled_block_closure_p, (SCHEME_OBJECT block)),
+ EXFUN (compiled_entry_closure_p, (SCHEME_OBJECT entry)),
+ EXFUN (compiled_entry_to_block_offset, (SCHEME_OBJECT entry)),
+ EXFUN (coerce_to_compiled,
+ (SCHEME_OBJECT object, SCHEME_OBJECT *location, long arity));
extern SCHEME_OBJECT
- extract_uuo_link(),
- extract_variable_cache(),
- compiled_block_debugging_info(),
- compiled_block_environment(),
- compiled_closure_to_entry(),
- *compiled_entry_to_block_address();
+ EXFUN (extract_uuo_link, (SCHEME_OBJECT block, long offset)),
+ EXFUN (extract_variable_cache,
+ (SCHEME_OBJECT extension, long offset)),
+ EXFUN (compiled_block_debugging_info, (SCHEME_OBJECT block)),
+ 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));
extern void
- store_variable_cache(),
- compiled_entry_type();
+ EXFUN (compiler_reset, (SCHEME_OBJECT new_block)),
+ EXFUN (compiler_initialize, (long fasl_p))
+ EXFUN (store_variable_cache,
+ (SCHEME_OBJECT extension, SCHEME_OBJECT block, long offset)),
+ EXFUN (compiled_entry_type,
+ (SCHEME_OBJECT entry, long *buffer));
\f
SCHEME_OBJECT
Registers[REGBLOCK_MINIMUM_LENGTH],
compiler_processor_type;
long
-enter_compiled_expression ()
+DEFUN_VOID (enter_compiled_expression)
{
return (ERR_EXECUTE_MANIFEST_VECTOR);
}
long
-apply_compiled_procedure ()
+DEFUN_VOID (apply_compiled_procedure)
{
return (ERR_INAPPLICABLE_OBJECT);
}
long
-return_to_compiled_code ()
+DEFUN_VOID (return_to_compiled_code)
{
return (ERR_INAPPLICABLE_CONTINUATION);
}
/* Bad entry points. */
long
-make_fake_uuo_link (extension, block, offset)
- SCHEME_OBJECT extension, block;
- long offset;
+DEFUN (make_fake_uuo_link,
+ (extension, block, offset),
+ SCHEME_OBJECT extension AND SCHEME_OBJECT block AND
+ long offset)
{
Microcode_Termination (TERM_COMPILER_DEATH);
/*NOTREACHED*/
}
long
-make_uuo_link (value, extension, block, offset)
- SCHEME_OBJECT value, extension, block;
- long offset;
+DEFUN (make_uuo_link,
+ (value, extension, block, offset),
+ SCHEME_OBJECT value AND SCHEME_OBJECT extension AND
+ SCHEME_OBJECT block AND long offset)
{
Microcode_Termination (TERM_COMPILER_DEATH);
/*NOTREACHED*/
}
SCHEME_OBJECT
-extract_uuo_link (block, offset)
- SCHEME_OBJECT block;
- long offset;
+DEFUN (extract_uuo_link,
+ (block, offset),
+ SCHEME_OBJECT block AND long offset)
{
Microcode_Termination (TERM_COMPILER_DEATH);
/*NOTREACHED*/
}
\f
void
-store_variable_cache (extension, block, offset)
- SCHEME_OBJECT extension, block;
- long offset;
+DEFUN (store_variable_cache,
+ (extension, block, offset),
+ SCHEME_OBJECT extension AND SCHEME_OBJECT block AND
+ long offset)
{
Microcode_Termination (TERM_COMPILER_DEATH);
/*NOTREACHED*/
}
SCHEME_OBJECT
-extract_variable_cache (block, offset)
- SCHEME_OBJECT block;
- long offset;
+DEFUN (extract_variable_cache,
+ (block, offset),
+ SCHEME_OBJECT block AND
+ long offset)
{
Microcode_Termination (TERM_COMPILER_DEATH);
/*NOTREACHED*/
}
SCHEME_OBJECT
-compiled_block_debugging_info (block)
- SCHEME_OBJECT block;
+DEFUN (compiled_block_debugging_info,
+ (block),
+ SCHEME_OBJECT block)
{
Microcode_Termination (TERM_COMPILER_DEATH);
/*NOTREACHED*/
}
SCHEME_OBJECT
-compiled_block_environment (block)
- SCHEME_OBJECT block;
+DEFUN (compiled_block_environment,
+ (block),
+ SCHEME_OBJECT block)
{
Microcode_Termination (TERM_COMPILER_DEATH);
/*NOTREACHED*/
}
long
-compiled_block_closure_p (block)
- SCHEME_OBJECT block;
+DEFUN (compiled_block_closure_p,
+ (block),
+ SCHEME_OBJECT block)
{
Microcode_Termination (TERM_COMPILER_DEATH);
/*NOTREACHED*/
}
SCHEME_OBJECT *
-compiled_entry_to_block_address (entry)
- SCHEME_OBJECT entry;
+DEFUN (compiled_entry_to_block_address,
+ (entry),
+ SCHEME_OBJECT entry)
{
Microcode_Termination (TERM_COMPILER_DEATH);
/*NOTREACHED*/
}
long
-compiled_entry_to_block_offset (entry)
- SCHEME_OBJECT entry;
+DEFUN (compiled_entry_to_block_offset,
+ (entry),
+ SCHEME_OBJECT entry)
{
Microcode_Termination (TERM_COMPILER_DEATH);
/*NOTREACHED*/
}
+
+C_UTILITY SCHEME_OBJECT
+DEFUN (compiled_entry_to_block,
+ (entry),
+ SCHEME_OBJECT entry)
+{
+ Microcode_Termination (TERM_COMPILER_DEATH);
+ /*NOTREACHED*/
+}
+
\f
void
-compiled_entry_type (entry, buffer)
- SCHEME_OBJECT entry, *buffer;
+DEFUN (compiled_entry_type,
+ (entry, buffer),
+ SCHEME_OBJECT entry AND long *buffer)
{
Microcode_Termination (TERM_COMPILER_DEATH);
/*NOTREACHED*/
}
long
-compiled_entry_closure_p (entry)
- SCHEME_OBJECT entry;
+DEFUN (compiled_entry_closure_p,
+ (entry),
+ SCHEME_OBJECT entry)
{
Microcode_Termination (TERM_COMPILER_DEATH);
/*NOTREACHED*/
}
SCHEME_OBJECT
-compiled_closure_to_entry (entry)
- SCHEME_OBJECT entry;
+DEFUN (compiled_closure_to_entry,
+ (entry),
+ SCHEME_OBJECT entry)
{
Microcode_Termination (TERM_COMPILER_DEATH);
/*NOTREACHED*/
}
#define LOSING_RETURN_ADDRESS(name) \
-extern long name(); \
+extern long EXFUN (name, (void)); \
long \
-name() \
+DEFUN_VOID (name) \
{ \
Microcode_Termination (TERM_COMPILER_DEATH); \
/*NOTREACHED*/ \
\f
/* NOP entry points */
-extern void
- compiler_reset(),
- compiler_initialize();
-
-extern long
- coerce_to_compiled();
-
void
-compiler_reset (new_block)
- SCHEME_OBJECT new_block;
+DEFUN (compiler_reset,
+ (new_block),
+ SCHEME_OBJECT new_block)
{
extern void compiler_reset_error();
}
void
-compiler_initialize (fasl_p)
- long fasl_p;
+DEFUN (compiler_initialize,
+ (fasl_p),
+ long fasl_p)
{
compiler_processor_type = 0;
compiler_interface_version = 0;
/* Identity procedure */
long
-coerce_to_compiled(object, arity, location)
- SCHEME_OBJECT object, *location;
- long arity;
+DEFUN (coerce_to_compiled,
+ (object, arity, location),
+ SCHEME_OBJECT object AND long arity AND SCHEME_OBJECT *location)
{
*location = object;
return (PRIM_DONE);
/* -*-C-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/cmpintmd/mc68k.h,v 1.17 1990/10/02 21:50:09 jinx Rel $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/cmpintmd/mc68k.h,v 1.18 1991/03/21 23:25:54 jinx Exp $
-Copyright (c) 1989, 1990 Massachusetts Institute of Technology
+Copyright (c) 1989-1991 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
#define COMPILER_VAX_TYPE 2
#define COMPILER_SPECTRUM_TYPE 3
#define COMPILER_MIPS_TYPE 4
+#define COMPILER_MC68040_TYPE 5
+#define COMPILER_SPARC_TYPE 6
+#define COMPILER_RS6000_TYPE 7
+#define COMPILER_MC88K_TYPE 8
\f
/* Machine parameters to be set by the user. */
/* Processor type. Choose a number from the above list, or allocate your own. */
-#define COMPILER_PROCESSOR_TYPE COMPILER_MC68020_TYPE
+#ifndef COMPILER_PROCESSOR_TYPE
+# define COMPILER_PROCESSOR_TYPE COMPILER_MC68020_TYPE
+#endif
/* Size (in long words) of the contents of a floating point register if
different from a double. For example, an MC68881 saves registers
*/
#define PC_ZERO_BITS 1
-\f
+
/* Skip over this many BYTES to bypass the GC check code (ordinary
procedures and continuations differ from closures) */
*/
#ifdef _NEXTOS
+
+ On the 68k, when closures are invoked, the closure corresponding
to the first entry point is what's needed on the top of the stack.
Note that it is needed for environment only, not for code.
The closure code does an
extdo { \
long magic_constant; \
\
-#define ADJUST_CLOSURE_AT_CALL(entry_point, location) \
+ magic_constant = (* ((long *) (((char *) (entry_point)) + 2))); \
(location) = ((SCHEME_OBJECT) \
((((long) (OBJECT_ADDRESS (location))) + 6) + \
magic_constant)); \
((2 * (sizeof (format_word))) + 6)
/* Manifest closure entry destructuring.
-#define COMPILED_CLOSURE_ENTRY_SIZE \
-((2 * (sizeof (format_word))) + 6)
+
+ Given the entry point of a closure, extract the `real entry point'
(the address of the real code of the procedure, ie. one indirection)
from the closure.
Note that on some machines this address may be "smeared out" over
{ \
(real_entry_point) = \
(* ((SCHEME_OBJECT *) (((char *) (entry_point)) + 2))); \
-#define EXTRACT_CLOSURE_ENTRY_ADDRESS(real_entry_point, entry_point) \
+}
/* This is the inverse of EXTRACT_CLOSURE_ENTRY_ADDRESS.
Given a closure's entry point and a code entry point, store the
{ \
(* ((SCHEME_OBJECT *) (((char *) (entry_point)) + 2))) = \
((SCHEME_OBJECT) (real_entry_point)); \
-#define STORE_CLOSURE_ENTRY_ADDRESS(real_entry_point, entry_point) \
+}
#endif /* (COMPILER_PROCESSOR_TYPE == COMPILER_MC68020_TYPE) */
\f
#if (COMPILER_PROCESSOR_TYPE == COMPILER_MC68040_TYPE)
+
+/* On the MC68040, closure entry points are aligned, so this is a NOP. */
+
+# define ADJUST_CLOSURE_AT_CALL(entry_point, location) NOP()
+
+/* Cache flushing. */
+
+# ifdef _NEXTOS
+
+# define SPLIT_CACHES
+# define FLUSH_I_CACHE() asm ("trap #2")
+# define FLUSH_I_CACHE_REGION(addr,nwords) FLUSH_I_CACHE()
+
+# endif /* _NEXTOS */
+
+# ifdef __hpux
+
+/* The following is a test for HP-UX >= 7.05 */
+
+# include <sys/proc.h>
+
+# ifdef S2DATA_WT
+
+/* This only works in HP-UX >= 7.05 */
+
+# include <sys/cache.h>
+
+extern void EXFUN (operate_on_cache_region,(int, char *, unsigned long));
+
+# define SPLIT_CACHES
+
+# define FLUSH_I_CACHE() \
+ (void) (cachectl (CC_IPURGE, 0, 0))
+
+# define FLUSH_I_CACHE_REGION(addr, nwords) \
+ (operate_on_cache_region (CC_IPURGE, ((char *) (addr)), (nwords)))
+
+# define PUSH_D_CACHE_REGION(addr, nwords) \
+ (operate_on_cache_region (CC_FLUSH, ((char *) (addr)), (nwords)))
+
+# ifdef IN_CMPINT_C
+
+void
+DEFUN (operate_on_cache_region,
+ (cachecmd, base, nwords),
+ int cachecmd AND char * base AND unsigned long)
+{
+ char * end;
+ unsigned long nbytes, quantum;
+
+ if (nwords == 0)
+ return;
+
+ nbytes = (nwords * (sizeof (long)));
+ end = (base + (nbytes - 1));
+ quantum = ((nbytes <= 0x40) ? 0x10 : 0x1000);
+
+ for (base = ((char *) (((unsigned long) base) & (~(quantum - 1))))
+ end = ((char *) (((unsigned long) end) & (~(quantum - 1))));
+ (base <= end);
+ base += quantum)
+ (void) (cachectl (cachecmd, base, quantum));
+ return;
+}
+
+# endif /* IN_CMPINT_C */
+# endif /* S2DATA_WT */
+# endif /* hpux */
+
+# ifndef FLUSH_I_CACHE
+# error "Cache flushing code needed for MC68040s"
+# endif
+\f
+/* Manifest closure entry block size.
+ Size in bytes of a compiled closure's header excluding the
+ TC_MANIFEST_CLOSURE header.
+
+ On the 68040, this is the format word and gc offset word a 4-byte-long
+ jsr instruction, and 4 bytes for the target address.
+*/
+
+# define COMPILED_CLOSURE_ENTRY_SIZE \
+ ((2 * (sizeof (format_word))) + 4 + 4)
+
+/* Manifest closure entry destructuring.
+
+ EXTRACT_CLOSURE_ENTRY_ADDRESS(real_entry_point, entry_point)
+ Given the entry point of a closure, extract the `real entry point'
+ (the address of the real code of the procedure, ie. one indirection)
+ from the closure.
+ Note that on some machines this address may be "smeared out" over
+ multiple instructions.
+
+ STORE_CLOSURE_ENTRY_ADDRESS(real_entry_point, entry_point)
+ is the inverse of EXTRACT_CLOSURE_ENTRY_ADDRESS.
+ Given a closure's entry point and a code entry point, store the
+ code entry point in the closure.
+*/
+
+# ifndef GC_ELIMINATES_CLOSURE_HOOK
+
+# define EXTRACT_CLOSURE_ENTRY_ADDRESS(real_ep, entry_point) do \
+{ \
+ (real_ep) = \
+ (* ((SCHEME_OBJECT *) (((char *) (entry_point)) + 4))); \
+} while (0)
+
+# define STORE_CLOSURE_ENTRY_ADDRESS(real_ep, entry_point) do \
+{ \
+ (* ((SCHEME_OBJECT *) (((char *) (entry_point)) + 4))) = \
+ ((SCHEME_OBJECT) (real_ep)); \
+} while (0)
+
+
+# else /* GC_ELIMINATES_CLOSURE_HOOK */
+
+
+# define EXTRACT_CLOSURE_ENTRY_ADDRESS(real_ep, entry_point) do \
+{ \
+ unsigned short *pc = ((unsigned short *) (entry_point)); \
+ \
+ (real_ep) = \
+ (((*pc) == 0x4eae) \
+ ? (* ((SCHEME_OBJECT *) (((char *) pc) + 4))) \
+ : (* ((SCHEME_OBJECT *) (((char *) pc) + 2)))); \
+} while (0)
+
+/* This version changes the instructions to a more efficient version.
+ It is assumed that this is done only by the GC or other processes
+ that flush the I-cache at the end.
+ */
+
+# define STORE_CLOSURE_ENTRY_ADDRESS(real_ep, entry_point) do \
+{ \
+ unsigned short *pc = ((unsigned short *) (entry_point)); \
+ \
+ *pc++ = 0x4eb9; /* JSR absolute */ \
+ (* ((SCHEME_OBJECT *) pc)) = ((SCHEME_OBJECT) (real_ep)); \
+} while (0)
+
+# endif /* GC_ELIMINATES_CLOSURE_HOOK */
+
+
+#endif /* (COMPILER_PROCESSOR_TYPE == COMPILER_MC68040_TYPE) */
+
+
+#ifndef ADJUST_CLOSURE_AT_CALL
+
+# include "ERROR: COMPILER_PROCESSOR_TYPE unknown"
+
+#endif /* ADJUST_CLOSURE_AT_CALL */
+\f
+# error "COMPILER_PROCESSOR_TYPE unknown"
+ contains both the number of arguments provided by the caller and
+ code to jump to the destination address. Before linkage, the cache
+
+
+#ifndef FLUSH_I_CACHE_REGION
+# define FLUSH_I_CACHE_REGION(addr, nwords) NOP()
+#endif /* not FLUSH_I_CACHE_REGION */
+
+#ifndef PUSH_D_CACHE_REGION
+# define PUSH_D_CACHE_REGION(addr, nwords) FLUSH_I_CACHE_REGION(addr, nwords)
+#endif /* not PUSH_D_CACHE_REGION */
contains the callee's name instead of the jump code.
*/
{ \
(target) = \
((long) (* ((unsigned short *) (((char *) (address)) + 6)))); \
-#define EXTRACT_EXECUTE_CACHE_ARITY(target, address) \
+} while (0)
#define EXTRACT_EXECUTE_CACHE_SYMBOL(target, address) do \
{ \
-}
+ (target) = (* ((SCHEME_OBJECT *) (address))); \
} while (0)
-#define EXTRACT_EXECUTE_CACHE_SYMBOL(target, address) \
+
/* Extract the target address (not the code to get there) from an
execute cache cell.
-}
+ */
#define EXTRACT_EXECUTE_CACHE_ADDRESS(target, address) do \
{ \
(target) = (* ((SCHEME_OBJECT *) (((char *) (address)) + 2))); \
} while (0)
-#define EXTRACT_EXECUTE_CACHE_ADDRESS(target, address) \
+
/* This is the inverse of EXTRACT_EXECUTE_CACHE_ADDRESS. */
-}
+#define STORE_EXECUTE_CACHE_ADDRESS(address, entry_address) do \
{ \
(* ((SCHEME_OBJECT *) (((char *) (address)) + 2))) = \
((SCHEME_OBJECT) (entry_address)); \
-#define STORE_EXECUTE_CACHE_ADDRESS(address, entry_address) \
+} while (0)
/* This stores the fixed part of the instructions leaving the
destination address and the number of arguments intact. These are
-}
+ split apart so the GC can call EXTRACT/STORE...ADDRESS but it does
NOT need to store the instructions back. On some architectures the
instructions may change due to GC and then STORE_EXECUTE_CACHE_CODE
should become a no-op and all of the work is done by
{ \
(* ((unsigned short *) (address))) = ((unsigned short) 0x4ef9); \
} while (0)
-#define STORE_EXECUTE_CACHE_CODE(address) \
+\f
/* This overrides the definition in cmpint.c because the code below
depends on knowing it, and is inserted before the definition in
-}
+ cmpint.c
*/
#define COMPILER_REGBLOCK_N_FIXED 16
#define A6_TRAMPOLINE_TO_INTERFACE_OFFSET \
((COMPILER_REGBLOCK_N_FIXED + (2 * COMPILER_HOOK_SIZE)) * \
-(COMPILER_REGBLOCK_N_HOOKS * COMPILER_HOOK_SIZE)
+ (sizeof (SCHEME_OBJECT)))
#define A6_CLOSURE_HOOK_OFFSET \
-((COMPILER_REGBLOCK_N_FIXED + (2 * COMPILER_HOOK_SIZE)) * \
- (sizeof (SCHEME_OBJECT)))
+ ((COMPILER_REGBLOCK_N_FIXED + (37 * COMPILER_HOOK_SIZE)) * \
+ (sizeof (SCHEME_OBJECT)))
+
+#ifdef IN_CMPINT_C
+
+#define ASM_RESET_HOOK mc68k_reset_hook
#ifdef CAST_FUNCTION_TO_INT_BUG
{ \
extern unsigned long hook; \
(* ((unsigned short *) (a6_value + offset))) = 0x4ef9; \
-#define SETUP_REGISTER(hook) \
+ (* ((unsigned long *) \
(((unsigned short *) (a6_value + offset)) + 1))) = \
((unsigned long) (&hook)); \
offset += (COMPILER_HOOK_SIZE * (sizeof (SCHEME_OBJECT))); \
#else /* not CAST_FUNCTION_TO_INT_BUG */
-}
+#define SETUP_REGISTER(hook) do \
{ \
extern void EXFUN (hook, (void)); \
(* ((unsigned short *) (a6_value + offset))) = 0x4ef9; \
-#define SETUP_REGISTER(hook) \
+ (* ((unsigned long *) \
(((unsigned short *) (a6_value + offset)) + 1))) = \
((unsigned long) hook); \
offset += (COMPILER_HOOK_SIZE * (sizeof (SCHEME_OBJECT))); \
#endif
\f
-}
+void
DEFUN_VOID (mc68k_reset_hook)
{
+ extern void EXFUN (interface_initialize, (void));
-
-mc68k_reset_hook ()
+ unsigned char * a6_value = ((unsigned char *) (&Registers[0]));
int offset = (COMPILER_REGBLOCK_N_FIXED * (sizeof (SCHEME_OBJECT)));
+
/* These must match machines/bobcat/lapgen.scm */
- extern void interface_initialize ();
+ SETUP_REGISTER (asm_scheme_to_interface); /* 0 */
SETUP_REGISTER (asm_scheme_to_interface_jsr); /* 1 */
+
if (offset != A6_TRAMPOLINE_TO_INTERFACE_OFFSET)
{
+ fprintf (stderr,
+ "\nmc68k_reset_hook: A6_TRAMPOLINE_TO_INTERFACE_OFFSET\n");
+ Microcode_Termination (TERM_EXIT);
+ }
+
+ SETUP_REGISTER (asm_trampoline_to_interface); /* 2 */
+ SETUP_REGISTER (asm_shortcircuit_apply); /* 3 */
+ SETUP_REGISTER (asm_shortcircuit_apply_size_1); /* 4 */
SETUP_REGISTER (asm_shortcircuit_apply_size_2); /* 5 */
SETUP_REGISTER (asm_shortcircuit_apply_size_3); /* 6 */
SETUP_REGISTER (asm_shortcircuit_apply_size_4); /* 7 */
SETUP_REGISTER (asm_allocate_closure); /* 36 */
if (offset != A6_CLOSURE_HOOK_OFFSET)
+ {
+ fprintf (stderr, "\nmc68k_reset_hook: A6_CLOSURE_HOOK_OFFSET\n");
+ Microcode_Termination (TERM_EXIT);
+ }
+ else
+ { /* 37 */
+ unsigned short *pc;
+
+ pc = ((unsigned short *) (a6_value + offset));
+ *pc++ = 0x2057; /* MOVEA.L (%sp),%a0 */
+ *pc++ = 0x2050; /* MOVEA.L (%a0),%a0 */
+ *pc++ = 0x5497; /* ADDQ.L &2,(%sp) */
+ *pc++ = 0x4ed0; /* JMP (%a0) */
+
+ offset += (COMPILER_HOOK_SIZE * (sizeof (SCHEME_OBJECT)));
+ }
+
+ SETUP_REGISTER (asm_generic_quotient); /* 38 */
+ SETUP_REGISTER (asm_generic_remainder); /* 39 */
+#if 0
+ interface_initialize ();
+ return;
+}
\f
#define CLOSURE_ENTRY_WORDS \
(COMPILED_CLOSURE_ENTRY_SIZE / (sizeof (SCHEME_OBJECT)))
+
+static long closure_chunk = (1024 * CLOSURE_ENTRY_WORDS);
+static long last_chunk_size;
+
+#define CLOSURE_CHUNK (1024 * CLOSURE_ENTRY_WORDS)
+{
+ long space;
+DEFUN (allocate_closure,
+ (nentries, size),
+ long nentries AND long size)
+
+ Microcode_Termination (TERM_COMPILER_DEATH);
+
+#else /* (COMPILER_PROCESSOR_TYPE == COMPILER_MC68040_TYPE) */
+
+ space = ((long) (Registers[REGBLOCK_CLOSURE_SPACE]));
+ result = ((SCHEME_OBJECT *) (Registers[REGBLOCK_CLOSURE_FREE]));
+
+ long compare, delta, space;
+ SCHEME_OBJECT *result;
+
+ compare = (size + ((nentries * CLOSURE_ENTRY_WORDS) - 1));
+ delta = (CLOSURE_ENTRY_WORDS
+ * ((nentries + 1)
+ + ((size + 1) / CLOSURE_ENTRY_WORDS)));
+
+ if (size > space)
+ {
+ SCHEME_OBJECT *start, *ptr, *eptr;
+ if (compare < space)
+ /* Clear remaining words from last chunk so that the heap can be scanned
+ SCHEME_OBJECT *start, *ptr, *end;
+ Do not clear if there was no last chunk (ie. CLOSURE_FREE was NULL).
+ if ((compare <= (CLOSURE_CHUNK - 3)) && (!GC_Check (CLOSURE_CHUNK)))
+ }
+ else
+ end = (start + CLOSURE_CHUNK);
+ if (GC_Check (size))
+ {
+ if ((Heap_Top - Free) < size)
+ if (GC_Check (compare + 3))
+ /* No way to back out -- die. */
+ if ((Heap_Top - Free) < (compare + 3))
+ fprintf (stderr, "\nC_allocate_closure (%d): No space.\n", size);
+ Microcode_Termination (TERM_NO_SPACE);
+ fprintf (stderr, "\nC_allocate_closure (%d, %d): No space.\n",
+ nentries, size);
+ Request_GC (0);
+ }
+ else if (size <= closure_chunk)
+ start = Free;
+ end = (start + (compare + 3));
+ {
+ Request_GC (0);
+ result = start;
+ space = (eptr - start);
+ Free = end;
+ result = (start + 3);
+ space = (end - result);
+
+ for (ptr = result; ptr < end; ptr += CLOSURE_ENTRY_WORDS)
+ wptr = ((unsigned short *) ptr);
+ *wptr++ = 0x4eae; /* JSR n(a6) */
+ *wptr = A6_CLOSURE_HOOK_OFFSET; /* n */
+ wptr = ptr;
+
+ *wptr++ = A6_CLOSURE_HOOK_OFFSET; /* n */
+ }
+
+ PUSH_D_CACHE_REGION (result, space);
+ Registers[REGBLOCK_CLOSURE_SPACE] = ((SCHEME_OBJECT) (space - size));
+ return (result);
+ Registers[REGBLOCK_CLOSURE_FREE] = ((SCHEME_OBJECT) (result - delta));
+ Registers[REGBLOCK_CLOSURE_SPACE] = ((SCHEME_OBJECT) (space - delta));
+}
+
+#endif /* IN_CMPINT_C */
+\f
/* On the 68K, here's a picture of a trampoline (offset in bytes from
entry point)
-12: MANIFEST vector header
#define STORE_TRAMPOLINE_ENTRY(entry_address, index) do \
{ \
unsigned short *start_address, *PC; \
-#define STORE_TRAMPOLINE_ENTRY(entry_address, index) \
+ /* D0 will get the index. JSR will be used to call the assembly \
language to C SCHEME_UTILITY handler: \
- unsigned short *PC; \
+ mov.w #index,%d0 \
jsr n(a6) \
*/ \
start_address = ((unsigned short *) (entry_address)); \
PC = start_address; \
*PC++ = ((unsigned short) 0x303C); /* mov.w #???,%d0 */ \
- PC = ((unsigned short *) entry_address); \
+ *PC++ = ((unsigned short) index); /* ??? */ \
+ *PC++ = ((unsigned short) 0x4EAE); /* jsr n(a6) */ \
*PC++ = ((unsigned short) A6_TRAMPOLINE_TO_INTERFACE_OFFSET); \
PUSH_D_CACHE_REGION (start_address, 2); \
} while (0)
\f
-}
+/* Derived parameters and macros.
+ These macros expect the above definitions to be meaningful.
If they are not, the macros below may have to be changed as well.
*/
/* -*-C-*-
-Copyright (c) 1987, 1988, 1989 Massachusetts Institute of Technology
+Copyright (c) 1987-1991 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
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/const.h,v 9.36 1990/06/20 17:39:29 cph Rel $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/const.h,v 9.37 1991/03/21 23:26:21 jinx Exp $
*
* Named constants used throughout the interpreter
*
#define REGBLOCK_STACKGUARD 1
#define REGBLOCK_VAL 2
#define REGBLOCK_ENV 3
-#define REGBLOCK_TEMP 4
+#define REGBLOCK_COMPILER_TEMP 4 /* For use by compiler */
#define REGBLOCK_EXPR 5
#define REGBLOCK_RETURN 6
#define REGBLOCK_LEXPR_ACTUALS 7
#define REGBLOCK_PRIMITIVE 8
-#define REGBLOCK_MINIMUM_LENGTH 9
+#define REGBLOCK_CLOSURE_FREE 9 /* For use by compiler */
+#define REGBLOCK_CLOSURE_SPACE 10 /* For use by compiler */
+#define REGBLOCK_MINIMUM_LENGTH 11
\f
/* Codes specifying how to start scheme at boot time. */
/* -*-C-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/fasload.c,v 9.60 1991/02/24 01:10:39 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/fasload.c,v 9.61 1991/03/21 23:26:27 jinx Exp $
Copyright (c) 1987-1991 Massachusetts Institute of Technology
/* Utility for load band below. */
void
-compiler_reset_error()
+DEFUN_VOID (compiler_reset_error)
{
fprintf (stderr,
- "\ncompiler_restart_error: The band being restored and\n");
+ "\ncompiler_reset_error: The band being restored and\n");
fprintf (stderr,
"the compiled code interface in this microcode are inconsistent.\n");
Microcode_Termination (TERM_COMPILER_DEATH);
History = (Make_Dummy_History ());
Prev_Restore_History_Stacklet = 0;
Prev_Restore_History_Offset = 0;
- FLUSH_I_CACHE ();
+ COMPILER_TRANSPORT_END ();
END_BAND_LOAD (true, false);
Band_Load_Hook ();
/* Return in a non-standard way. */
/* -*-C-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/memmag.c,v 9.45 1991/02/24 01:10:48 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/memmag.c,v 9.46 1991/03/21 23:26:35 jinx Exp $
Copyright (c) 1987-1991 Massachusetts Institute of Technology
Current_State_Point = *Root++;
Fluid_Bindings = *Root++;
Free_Stacklets = NULL;
- FLUSH_I_CACHE ();
+ COMPILER_TRANSPORT_END ();
CLEAR_INTERRUPT (INT_GC);
return;
}
/* -*-C-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/version.h,v 11.69 1991/03/14 23:02:55 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/version.h,v 11.70 1991/03/21 23:26:47 jinx Exp $
Copyright (c) 1988-91 Massachusetts Institute of Technology
#define VERSION 11
#endif
#ifndef SUBVERSION
-#define SUBVERSION 69
+#define SUBVERSION 70
#endif
/* -*-C-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/cmpint.c,v 1.31 1990/10/03 18:55:46 jinx Rel $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/cmpint.c,v 1.32 1991/03/21 23:26:02 jinx Exp $
-Copyright (c) 1989, 1990 Massachusetts Institute of Technology
+Copyright (c) 1989-1991 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
*
*/
+#define NOP() do {} while (0) /* A useful macro */
+
/* Macro imports */
#include <stdio.h>
#define IN_CMPINT_C
#include "cmpint2.h" /* Compiled code object destructuring */
#include "cmpgc.h" /* Compiled code object relocation */
+
+#ifndef FLUSH_I_CACHE_REGION
+# define FLUSH_I_CACHE_REGION(addr, nwords) NOP()
+#endif
+
+#ifndef PUSH_D_CACHE_REGION
+# define PUSH_D_CACHE_REGION(addr, nwords) FLUSH_I_CACHE_REGION(addr, nwords)
+#endif
\f
/* Make noise words invisible to the C compiler. */
}
#define ENTRY_TO_OBJECT(entry) \
-MAKE_POINTER_OBJECT(TC_COMPILED_ENTRY, ((SCHEME_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))
+ (MAKE_POINTER_OBJECT (TC_COMPILED_CODE_BLOCK, block_addr))
\f
/* Imports from the rest of the "microcode" */
extern long
- compiler_cache_operator(),
- compiler_cache_lookup(),
- compiler_cache_assignment();
+ EXFUN (compiler_cache_operator, (void)),
+ EXFUN (compiler_cache_lookup, (void)),
+ EXFUN (compiler_cache_assignment, (void));
/* Imports from assembly language */
extern long
- C_to_interface();
+ EXFUN (C_to_interface, (void *));
extern void
- interface_to_C(),
- interface_to_scheme();
+ EXFUN (interface_to_C, (void)),
+ EXFUN (interface_to_scheme, (void));
/* Exports to the rest of the "microcode" */
return_to_interpreter;
extern C_UTILITY long
- make_fake_uuo_link(),
- make_uuo_link(),
- compiled_block_closure_p(),
- compiled_entry_closure_p(),
- compiled_entry_to_block_offset(),
- coerce_to_compiled();
+ EXFUN (make_fake_uuo_link,
+ (SCHEME_OBJECT extension, SCHEME_OBJECT block, long offset)),
+ EXFUN (make_uuo_link,
+ (SCHEME_OBJECT value, SCHEME_OBJECT extension,
+ SCHEME_OBJECT block, long offset)),
+ EXFUN (compiled_block_closure_p, (SCHEME_OBJECT block)),
+ EXFUN (compiled_entry_closure_p, (SCHEME_OBJECT entry)),
+ EXFUN (compiled_entry_to_block_offset, (SCHEME_OBJECT entry)),
+ EXFUN (coerce_to_compiled,
+ (SCHEME_OBJECT object, long arity, SCHEME_OBJECT *location));
extern C_UTILITY SCHEME_OBJECT
- extract_uuo_link(),
- extract_variable_cache(),
- compiled_block_debugging_info(),
- compiled_block_environment(),
- compiled_closure_to_entry(),
- *compiled_entry_to_block_address(),
- compiled_entry_to_block();
+ EXFUN (extract_uuo_link, (SCHEME_OBJECT block, long offset)),
+ EXFUN (extract_variable_cache,
+ (SCHEME_OBJECT extension, long offset)),
+ EXFUN (compiled_block_debugging_info, (SCHEME_OBJECT block)),
+ 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));
extern C_UTILITY void
- compiler_initialize(),
- compiler_reset(),
- store_variable_cache(),
- compiled_entry_type();
+ EXFUN (compiler_initialize, (long fasl_p)),
+ EXFUN (compiler_reset, (SCHEME_OBJECT new_block)),
+ EXFUN (store_variable_cache,
+ (SCHEME_OBJECT extension, SCHEME_OBJECT block, long offset)),
+ EXFUN (compiled_entry_type,
+ (SCHEME_OBJECT entry, long *buffer));
extern C_TO_SCHEME long
- enter_compiled_expression(),
- apply_compiled_procedure(),
- return_to_compiled_code(),
- 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(),
- comp_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(),
- comp_error_restart();
+ EXFUN (enter_compiled_expression, (void)),
+ EXFUN (apply_compiled_procedure, (void)),
+ EXFUN (return_to_compiled_code, (void)),
+ EXFUN (comp_link_caches_restart, (void)),
+ EXFUN (comp_op_lookup_trap_restart, (void)),
+ EXFUN (comp_interrupt_restart, (void)),
+ EXFUN (comp_assignment_trap_restart, (void)),
+ EXFUN (comp_cache_lookup_apply_restart, (void)),
+ EXFUN (comp_lookup_trap_restart, (void)),
+ EXFUN (comp_safe_lookup_trap_restart, (void)),
+ EXFUN (comp_unassigned_p_trap_restart, (void)),
+ EXFUN (comp_access_restart, (void)),
+ EXFUN (comp_reference_restart, (void)),
+ EXFUN (comp_safe_reference_restart, (void)),
+ EXFUN (comp_unassigned_p_restart, (void)),
+ EXFUN (comp_unbound_p_restart, (void)),
+ EXFUN (comp_assignment_restart, (void)),
+ EXFUN (comp_definition_restart, (void)),
+ EXFUN (comp_lookup_apply_restart, (void)),
+ EXFUN (comp_error_restart, (void));
\f
extern SCHEME_UTILITY struct utility_result
- comutil_return_to_interpreter(),
- comutil_operator_apply_trap(),
- comutil_operator_arity_trap(),
- comutil_operator_entity_trap(),
- comutil_operator_interpreted_trap(),
- comutil_operator_lexpr_trap(),
- comutil_operator_primitive_trap(),
- comutil_operator_lookup_trap(),
- comutil_operator_1_0_trap(),
- comutil_operator_2_1_trap(),
- comutil_operator_2_0_trap(),
- comutil_operator_3_2_trap(),
- comutil_operator_3_1_trap(),
- comutil_operator_3_0_trap(),
- comutil_operator_4_3_trap(),
- comutil_operator_4_2_trap(),
- comutil_operator_4_1_trap(),
- comutil_operator_4_0_trap(),
- comutil_primitive_apply(),
- comutil_primitive_lexpr_apply(),
- comutil_apply(),
- comutil_error(),
- comutil_lexpr_apply(),
- comutil_link(),
- comutil_interrupt_closure(),
- comutil_interrupt_dlink(),
- comutil_interrupt_procedure(),
- comutil_interrupt_continuation(),
- comutil_interrupt_ic_procedure(),
- comutil_assignment_trap(),
- comutil_cache_lookup_apply(),
- comutil_lookup_trap(),
- comutil_safe_lookup_trap(),
- comutil_unassigned_p_trap(),
- comutil_decrement(),
- comutil_divide(),
- comutil_equal(),
- comutil_greater(),
- comutil_increment(),
- comutil_less(),
- comutil_minus(),
- comutil_multiply(),
- comutil_negative(),
- comutil_plus(),
- comutil_positive(),
- comutil_zero(),
- comutil_access(),
- comutil_reference(),
- comutil_safe_reference(),
- comutil_unassigned_p(),
- comutil_unbound_p(),
- comutil_assignment(),
- comutil_definition(),
- comutil_lookup_apply(),
- comutil_primitive_error();
+ EXFUN (comutil_return_to_interpreter, ()),
+ EXFUN (comutil_operator_apply_trap, ()),
+ EXFUN (comutil_operator_arity_trap, ()),
+ EXFUN (comutil_operator_entity_trap, ()),
+ EXFUN (comutil_operator_interpreted_trap, ()),
+ EXFUN (comutil_operator_lexpr_trap, ()),
+ EXFUN (comutil_operator_primitive_trap, ()),
+ EXFUN (comutil_operator_lookup_trap, ()),
+ EXFUN (comutil_operator_1_0_trap, ()),
+ EXFUN (comutil_operator_2_1_trap, ()),
+ EXFUN (comutil_operator_2_0_trap, ()),
+ EXFUN (comutil_operator_3_2_trap, ()),
+ EXFUN (comutil_operator_3_1_trap, ()),
+ EXFUN (comutil_operator_3_0_trap, ()),
+ EXFUN (comutil_operator_4_3_trap, ()),
+ EXFUN (comutil_operator_4_2_trap, ()),
+ EXFUN (comutil_operator_4_1_trap, ()),
+ EXFUN (comutil_operator_4_0_trap, ()),
+ EXFUN (comutil_primitive_apply, ()),
+ EXFUN (comutil_primitive_lexpr_apply, ()),
+ EXFUN (comutil_apply, ()),
+ EXFUN (comutil_error, ()),
+ EXFUN (comutil_lexpr_apply, ()),
+ EXFUN (comutil_link, ()),
+ EXFUN (comutil_interrupt_closure, ()),
+ EXFUN (comutil_interrupt_dlink, ()),
+ EXFUN (comutil_interrupt_procedure, ()),
+ EXFUN (comutil_interrupt_continuation, ()),
+ EXFUN (comutil_interrupt_ic_procedure, ()),
+ EXFUN (comutil_assignment_trap, ()),
+ EXFUN (comutil_cache_lookup_apply, ()),
+ EXFUN (comutil_lookup_trap, ()),
+ EXFUN (comutil_safe_lookup_trap, ()),
+ EXFUN (comutil_unassigned_p_trap, ()),
+ EXFUN (comutil_decrement, ()),
+ EXFUN (comutil_divide, ()),
+ EXFUN (comutil_equal, ()),
+ EXFUN (comutil_greater, ()),
+ EXFUN (comutil_increment, ()),
+ EXFUN (comutil_less, ()),
+ EXFUN (comutil_minus, ()),
+ EXFUN (comutil_multiply, ()),
+ EXFUN (comutil_negative, ()),
+ EXFUN (comutil_plus, ()),
+ EXFUN (comutil_positive, ()),
+ EXFUN (comutil_zero, ()),
+ EXFUN (comutil_access, ()),
+ EXFUN (comutil_reference, ()),
+ EXFUN (comutil_safe_reference, ()),
+ EXFUN (comutil_unassigned_p, ()),
+ EXFUN (comutil_unbound_p, ()),
+ EXFUN (comutil_assignment, ()),
+ EXFUN (comutil_definition, ()),
+ EXFUN (comutil_lookup_apply, ()),
+ EXFUN (comutil_primitive_error, ());
extern struct utility_result
(*(utility_table[]))();
*/
C_TO_SCHEME long
-enter_compiled_expression()
+DEFUN_VOID (enter_compiled_expression)
{
instruction *compiled_entry_address;
+ SCHEME_OBJECT *block_address, environment;
+ unsigned long length;
compiled_entry_address =
((instruction *) (OBJECT_ADDRESS (Fetch_Expression ())));
Val = (Fetch_Expression ());
return (C_to_interface ((instruction *) (OBJECT_ADDRESS (STACK_POP ()))));
}
+
+#ifdef SPLIT_CACHES
+ /* This is a kludge to handle the first execution. */
+
+ Get_Compiled_Block (block_address,
+ ((SCHEME_OBJECT *) compiled_entry_address));
+ length = (OBJECT_DATUM (*block_address));
+ environment = (block_address [length]);
+ if (!(ENVIRONMENT_P (environment)))
+ {
+ PUSH_D_CACHE_REGION (block_address, (length + 1));
+ }
+#endif /* SPLIT_CACHES */
+
return (C_to_interface (compiled_entry_address));
}
C_TO_SCHEME long
-apply_compiled_procedure()
+DEFUN_VOID (apply_compiled_procedure)
{
static long setup_compiled_invocation();
SCHEME_OBJECT nactuals, procedure;
*/
C_TO_SCHEME long
-return_to_compiled_code ()
+DEFUN_VOID (return_to_compiled_code)
{
instruction *compiled_entry_address;
*/
static long
-setup_compiled_invocation (nactuals, compiled_entry_address)
- long nactuals;
- instruction *compiled_entry_address;
+DEFUN (setup_compiled_invocation,
+ (nactuals, compiled_entry_address),
+ long nactuals AND
+ instruction *compiled_entry_address)
{
static long setup_lexpr_invocation();
static SCHEME_OBJECT *open_gap();
*/
static SCHEME_OBJECT *
-open_gap (nactuals, delta)
- register long nactuals, delta;
+DEFUN (open_gap,
+ (nactuals, delta),
+ register long nactuals AND register long delta)
{
register SCHEME_OBJECT *gap_location, *source_location;
/* Setup a rest argument as appropriate. */
static long
-setup_lexpr_invocation (nactuals, nmax, entry_address)
- register long nactuals, nmax;
- instruction *entry_address;
+DEFUN (setup_lexpr_invocation,
+ (nactuals, nmax, entry_address),
+ register long nactuals AND register long nmax AND
+ instruction *entry_address)
{
register long delta;
*/
SCHEME_UTILITY struct utility_result
-comutil_return_to_interpreter (tramp_data, ignore_2, ignore_3, ignore_4)
- SCHEME_OBJECT *tramp_data;
- long ignore_2, ignore_3, ignore_4;
+DEFUN (comutil_return_to_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_DONE);
}
*/
SCHEME_UTILITY struct utility_result
-comutil_primitive_apply (primitive, ignore_2, ignore_3, ignore_4)
- SCHEME_OBJECT primitive;
- long ignore_2, ignore_3, ignore_4;
+DEFUN (comutil_primitive_apply,
+ (primitive, ignore_2, ignore_3, ignore_4),
+ SCHEME_OBJECT primitive AND
+ long ignore_2 AND long ignore_3 AND long ignore_4)
{
PRIMITIVE_APPLY (Val, primitive);
POP_PRIMITIVE_FRAME (PRIMITIVE_ARITY (primitive));
*/
SCHEME_UTILITY struct utility_result
-comutil_primitive_lexpr_apply (primitive, ignore_2, ignore_3, ignore_4)
- SCHEME_OBJECT primitive;
- long ignore_2, ignore_3, ignore_4;
+DEFUN (comutil_primitive_lexpr_apply,
+ (primitive, ignore_2, ignore_3, ignore_4),
+ SCHEME_OBJECT primitive AND
+ long ignore_2 AND long ignore_3 AND long ignore_4)
{
PRIMITIVE_APPLY (Val, primitive);
POP_PRIMITIVE_FRAME (((long) Regs[REGBLOCK_LEXPR_ACTUALS]));
*/
SCHEME_UTILITY struct utility_result
-comutil_apply (procedure, nactuals, ignore_3, ignore_4)
- SCHEME_OBJECT procedure;
- long nactuals, ignore_3, ignore_4;
+DEFUN (comutil_apply,
+ (procedure, nactuals, ignore_3, ignore_4),
+ SCHEME_OBJECT procedure AND
+ long nactuals AND long ignore_3 AND long ignore_4)
{
switch (OBJECT_TYPE (procedure))
{
*/
SCHEME_UTILITY struct utility_result
-comutil_error (nactuals, ignore_2, ignore_3, ignore_4)
- long nactuals, ignore_2, ignore_3, ignore_4;
+DEFUN (comutil_error,
+ (nactuals, ignore_2, ignore_3, ignore_4),
+ long nactuals AND long ignore_2 AND long ignore_3 AND long ignore_4)
{
SCHEME_OBJECT error_procedure;
*/
SCHEME_UTILITY struct utility_result
-comutil_lexpr_apply (entry_address, nactuals, ignore_3, ignore_4)
- register instruction *entry_address;
- long nactuals;
- long ignore_3, ignore_4;
+DEFUN (comutil_lexpr_apply,
+ (entry_address, nactuals, ignore_3, ignore_4),
+ register instruction *entry_address AND
+ long nactuals AND
+ long ignore_3 AND long ignore_4)
{
RETURN_UNLESS_EXCEPTION
((setup_lexpr_invocation
\f
/* Core of comutil_link and comp_link_caches_restart. */
+static Boolean linking_cc_block_p = false;
+
+static void
+DEFUN (abort_link_cc_block, (ap), PTR ap)
+{
+ linking_cc_block_p = (* ((Boolean *) (ap)));
+ return;
+}
+
static long
-link_cc_block (block_address, offset, last_header_offset,
- sections, original_count, ret_add)
- register SCHEME_OBJECT *block_address;
- register long offset;
- long last_header_offset, sections, original_count;
- instruction *ret_add;
+DEFUN (link_cc_block,
+ (block_address, offset, last_header_offset,
+ sections, original_count, ret_add),
+ register SCHEME_OBJECT *block_address AND
+ register long offset AND
+ long last_header_offset AND
+ long sections AND
+ long original_count AND
+ instruction *ret_add)
{
Boolean execute_p;
register long entry_size, count;
long result, kind, total_count;
long (*cache_handler)();
+ transaction_begin ();
+ {
+ Boolean * ap = (dstack_alloc (sizeof (Boolean)));
+ *ap = linking_cc_block_p;
+ transaction_record_action (tat_abort, abort_link_cc_block, ap);
+ }
+ linking_cc_block_p = true;
+
+ result = PRIM_DONE;
block = (MAKE_CC_BLOCK (block_address));
while ((--sections) >= 0)
{
total_count = count;
}
-
+\f
block_address[last_header_offset] =
(MAKE_LINKAGE_SECTION_HEADER (kind, total_count));
for (offset += 1; ((--count) >= 0); offset += entry_size)
block_address[last_header_offset] =
(MAKE_LINKAGE_SECTION_HEADER (kind, (total_count - (count + 1))));
- return (result);
+ goto exit_proc;
}
}
last_header_offset = offset;
}
- return (PRIM_DONE);
+
+exit_proc:
+ /* Rather than commit, since we want to undo */
+ transaction_abort ();
+ PUSH_D_CACHE_REGION (block_address,
+ (((unsigned long) (*block_address)) + 1));
+ return (result);
}
\f
/*
*/
SCHEME_UTILITY struct utility_result
-comutil_link (ret_add, block_address, constant_address, sections)
- instruction *ret_add;
- SCHEME_OBJECT *block_address, *constant_address;
- long sections;
+DEFUN (comutil_link,
+ (ret_add, block_address, constant_address, sections),
+ instruction *ret_add AND
+ SCHEME_OBJECT *block_address AND SCHEME_OBJECT *constant_address AND
+ long sections)
{
long offset;
*/
C_TO_SCHEME long
-comp_link_caches_restart ()
+DEFUN_VOID (comp_link_caches_restart)
{
SCHEME_OBJECT block, environment;
long original_count, offset, last_header_offset, sections, code;
*/
SCHEME_UTILITY struct utility_result
-comutil_operator_apply_trap (tramp_data, ignore_2, ignore_3, ignore_4)
- SCHEME_OBJECT *tramp_data;
- long ignore_2, ignore_3, ignore_4;
+DEFUN (comutil_operator_apply_trap,
+ (tramp_data, ignore_2, ignore_3, ignore_4),
+ SCHEME_OBJECT *tramp_data AND
+ long ignore_2 AND long ignore_3 AND long ignore_4)
{
/* Used by coerce_to_compiled. TRAMPOLINE_K_APPLY */
}
SCHEME_UTILITY struct utility_result
-comutil_operator_arity_trap (tramp_data, ignore_2, ignore_3, ignore_4)
- SCHEME_OBJECT *tramp_data;
- long ignore_2, ignore_3, ignore_4;
+DEFUN (comutil_operator_arity_trap,
+ (tramp_data, ignore_2, ignore_3, ignore_4),
+ SCHEME_OBJECT *tramp_data AND
+ long ignore_2 AND long ignore_3 AND long ignore_4)
{
/* Linker saw an argument count mismatch. TRAMPOLINE_K_ARITY */
}
SCHEME_UTILITY struct utility_result
-comutil_operator_entity_trap (tramp_data, ignore_2, ignore_3, ignore_4)
- SCHEME_OBJECT *tramp_data;
- long ignore_2, ignore_3, ignore_4;
+DEFUN (comutil_operator_entity_trap,
+ (tramp_data, ignore_2, ignore_3, ignore_4),
+ SCHEME_OBJECT *tramp_data AND
+ long ignore_2 AND long ignore_3 AND long ignore_4)
{
/* Linker saw an entity to be applied. TRAMPOLINE_K_ENTITY */
}
\f
SCHEME_UTILITY struct utility_result
-comutil_operator_interpreted_trap (tramp_data, ignore_2, ignore_3, ignore_4)
- SCHEME_OBJECT *tramp_data;
- long ignore_2, ignore_3, ignore_4;
+DEFUN (comutil_operator_interpreted_trap,
+ (tramp_data, ignore_2, ignore_3, ignore_4),
+ SCHEME_OBJECT *tramp_data AND
+ long ignore_2 AND long ignore_3 AND long ignore_4)
{
/* Linker saw an interpreted procedure or a procedure that it cannot
link directly. TRAMPOLINE_K_INTERPRETED
}
SCHEME_UTILITY struct utility_result
-comutil_operator_lexpr_trap (tramp_data, ignore_2, ignore_3, ignore_4)
- SCHEME_OBJECT *tramp_data;
- long ignore_2, ignore_3, ignore_4;
+DEFUN (comutil_operator_lexpr_trap,
+ (tramp_data, ignore_2, ignore_3, ignore_4),
+ SCHEME_OBJECT *tramp_data AND
+ long ignore_2 AND long ignore_3 AND long ignore_4)
{
/* Linker saw a primitive of arbitrary number of arguments.
TRAMPOLINE_K_LEXPR_PRIMITIVE
}
SCHEME_UTILITY struct utility_result
-comutil_operator_primitive_trap (tramp_data, ignore_2, ignore_3, ignore_4)
- SCHEME_OBJECT *tramp_data;
- long ignore_2, ignore_3, ignore_4;
+DEFUN (comutil_operator_primitive_trap,
+ (tramp_data, ignore_2, ignore_3, ignore_4),
+ SCHEME_OBJECT *tramp_data AND
+ long ignore_2 AND long ignore_3 AND long ignore_4)
{
/* Linker saw a primitive of fixed matching arity. TRAMPOLINE_K_PRIMITIVE */
*/
SCHEME_UTILITY struct utility_result
-comutil_operator_lookup_trap (tramp_data, ignore_2, ignore_3, ignore_4)
- SCHEME_OBJECT *tramp_data;
- long ignore_2, ignore_3, ignore_4;
+DEFUN (comutil_operator_lookup_trap,
+ (tramp_data, ignore_2, ignore_3, ignore_4),
+ SCHEME_OBJECT *tramp_data AND
+ long ignore_2 AND long ignore_3 AND long ignore_4)
{
extern long complr_operator_reference_trap();
SCHEME_OBJECT true_operator, *cache_cell;
*/
C_TO_SCHEME long
-comp_op_lookup_trap_restart ()
+DEFUN_VOID (comp_op_lookup_trap_restart)
{
SCHEME_OBJECT *old_trampoline, code_block, new_procedure;
long offset;
*/
SCHEME_UTILITY struct utility_result
-comutil_operator_1_0_trap (tramp_data, ignore_2, ignore_3, ignore_4)
- SCHEME_OBJECT *tramp_data;
- long ignore_2, ignore_3, ignore_4;
+DEFUN (comutil_operator_1_0_trap,
+ (tramp_data, ignore_2, ignore_3, ignore_4),
+ SCHEME_OBJECT *tramp_data AND
+ long ignore_2 AND long ignore_3 AND long ignore_4)
{
STACK_PUSH (UNASSIGNED_OBJECT);
RETURN_TO_SCHEME (OBJECT_ADDRESS (tramp_data[0]));
}
SCHEME_UTILITY struct utility_result
-comutil_operator_2_1_trap (tramp_data, ignore_2, ignore_3, ignore_4)
- SCHEME_OBJECT *tramp_data;
- long ignore_2, ignore_3, ignore_4;
+DEFUN (comutil_operator_2_1_trap,
+ (tramp_data, ignore_2, ignore_3, ignore_4),
+ SCHEME_OBJECT *tramp_data AND
+ long ignore_2 AND long ignore_3 AND long ignore_4)
{
SCHEME_OBJECT Top;
}
SCHEME_UTILITY struct utility_result
-comutil_operator_2_0_trap (tramp_data, ignore_2, ignore_3, ignore_4)
- SCHEME_OBJECT *tramp_data;
- long ignore_2, ignore_3, ignore_4;
+DEFUN (comutil_operator_2_0_trap,
+ (tramp_data, ignore_2, ignore_3, ignore_4),
+ SCHEME_OBJECT *tramp_data AND
+ long ignore_2 AND long ignore_3 AND long ignore_4)
{
STACK_PUSH (UNASSIGNED_OBJECT);
STACK_PUSH (UNASSIGNED_OBJECT);
}
SCHEME_UTILITY struct utility_result
-comutil_operator_3_2_trap (tramp_data, ignore_2, ignore_3, ignore_4)
- SCHEME_OBJECT *tramp_data;
- long ignore_2, ignore_3, ignore_4;
+DEFUN (comutil_operator_3_2_trap,
+ (tramp_data, ignore_2, ignore_3, ignore_4),
+ SCHEME_OBJECT *tramp_data AND
+ long ignore_2 AND long ignore_3 AND long ignore_4)
{
SCHEME_OBJECT Top, Next;
}
\f
SCHEME_UTILITY struct utility_result
-comutil_operator_3_1_trap (tramp_data, ignore_2, ignore_3, ignore_4)
- SCHEME_OBJECT *tramp_data;
- long ignore_2, ignore_3, ignore_4;
+DEFUN (comutil_operator_3_1_trap,
+ (tramp_data, ignore_2, ignore_3, ignore_4),
+ SCHEME_OBJECT *tramp_data AND
+ long ignore_2 AND long ignore_3 AND long ignore_4)
{
SCHEME_OBJECT Top;
}
SCHEME_UTILITY struct utility_result
-comutil_operator_3_0_trap (tramp_data, ignore_2, ignore_3, ignore_4)
- SCHEME_OBJECT *tramp_data;
- long ignore_2, ignore_3, ignore_4;
+DEFUN (comutil_operator_3_0_trap,
+ (tramp_data, ignore_2, ignore_3, ignore_4),
+ SCHEME_OBJECT *tramp_data AND
+ long ignore_2 AND long ignore_3 AND long ignore_4)
{
STACK_PUSH (UNASSIGNED_OBJECT);
STACK_PUSH (UNASSIGNED_OBJECT);
}
SCHEME_UTILITY struct utility_result
-comutil_operator_4_3_trap (tramp_data, ignore_2, ignore_3, ignore_4)
- SCHEME_OBJECT *tramp_data;
- long ignore_2, ignore_3, ignore_4;
+DEFUN (comutil_operator_4_3_trap,
+ (tramp_data, ignore_2, ignore_3, ignore_4),
+ SCHEME_OBJECT *tramp_data AND
+ long ignore_2 AND long ignore_3 AND long ignore_4)
{
SCHEME_OBJECT Top, Middle, Bottom;
}
SCHEME_UTILITY struct utility_result
-comutil_operator_4_2_trap (tramp_data, ignore_2, ignore_3, ignore_4)
- SCHEME_OBJECT *tramp_data;
- long ignore_2, ignore_3, ignore_4;
+DEFUN (comutil_operator_4_2_trap,
+ (tramp_data, ignore_2, ignore_3, ignore_4),
+ SCHEME_OBJECT *tramp_data AND
+ long ignore_2 AND long ignore_3 AND long ignore_4)
{
SCHEME_OBJECT Top, Next;
}
\f
SCHEME_UTILITY struct utility_result
-comutil_operator_4_1_trap (tramp_data, ignore_2, ignore_3, ignore_4)
- SCHEME_OBJECT *tramp_data;
- long ignore_2, ignore_3, ignore_4;
+DEFUN (comutil_operator_4_1_trap,
+ (tramp_data, ignore_2, ignore_3, ignore_4),
+ SCHEME_OBJECT *tramp_data AND
+ long ignore_2 AND long ignore_3 AND long ignore_4)
{
SCHEME_OBJECT Top;
}
SCHEME_UTILITY struct utility_result
-comutil_operator_4_0_trap (tramp_data, ignore_2, ignore_3, ignore_4)
- SCHEME_OBJECT *tramp_data;
- long ignore_2, ignore_3, ignore_4;
+DEFUN (comutil_operator_4_0_trap,
+ (tramp_data, ignore_2, ignore_3, ignore_4),
+ SCHEME_OBJECT *tramp_data AND
+ long ignore_2 AND long ignore_3 AND long ignore_4)
{
STACK_PUSH (UNASSIGNED_OBJECT);
STACK_PUSH (UNASSIGNED_OBJECT);
*/
SCHEME_UTILITY struct utility_result
-comutil_interrupt_closure (ignore_1, ignore_2, ignore_3, ignore_4)
- long ignore_1, ignore_2, ignore_3, ignore_4;
+DEFUN (comutil_interrupt_closure,
+ (ignore_1, ignore_2, ignore_3, ignore_4),
+ long ignore_1 AND long ignore_2 AND long ignore_3 AND long ignore_4)
{
TEST_GC_NEEDED();
if ((PENDING_INTERRUPTS()) == 0)
*/
static struct utility_result
-compiler_interrupt_common (entry_point, offset, state)
- instruction *entry_point;
- long offset;
- SCHEME_OBJECT state;
+DEFUN (compiler_interrupt_common,
+ (entry_point, offset, state),
+ instruction *entry_point AND
+ long offset AND
+ SCHEME_OBJECT state)
{
TEST_GC_NEEDED();
if ((PENDING_INTERRUPTS()) == 0)
}
SCHEME_UTILITY struct utility_result
-comutil_interrupt_dlink (entry_point, dlink, ignore_3, ignore_4)
- instruction *entry_point;
- SCHEME_OBJECT *dlink;
- long ignore_3, ignore_4;
+DEFUN (comutil_interrupt_dlink,
+ (entry_point, dlink, ignore_3, ignore_4),
+ instruction *entry_point AND
+ SCHEME_OBJECT *dlink AND
+ long ignore_3 AND long ignore_4)
{
return
(compiler_interrupt_common(entry_point,
}
SCHEME_UTILITY struct utility_result
-comutil_interrupt_procedure (entry_point, ignore_2, ignore_3, ignore_4)
- instruction *entry_point;
- long ignore_2, ignore_3, ignore_4;
+DEFUN (comutil_interrupt_procedure,
+ (entry_point, ignore_2, ignore_3, ignore_4),
+ instruction *entry_point AND
+ long ignore_2 AND long ignore_3 AND long ignore_4)
{
return (compiler_interrupt_common(entry_point,
ENTRY_SKIPPED_CHECK_OFFSET,
/* Val has live data, and there is no entry address on the stack */
SCHEME_UTILITY struct utility_result
-comutil_interrupt_continuation (return_address, ignore_2, ignore_3, ignore_4)
- instruction *return_address;
- long ignore_2, ignore_3, ignore_4;
+DEFUN (comutil_interrupt_continuation,
+ (return_address, ignore_2, ignore_3, ignore_4),
+ instruction *return_address AND
+ long ignore_2 AND long ignore_3 AND long ignore_4)
{
return (compiler_interrupt_common (return_address,
ENTRY_SKIPPED_CHECK_OFFSET,
/* Env has live data; no entry point on the stack */
SCHEME_UTILITY struct utility_result
-comutil_interrupt_ic_procedure (entry_point, ignore_2, ignore_3, ignore_4)
- instruction *entry_point;
- long ignore_2, ignore_3, ignore_4;
+DEFUN (comutil_interrupt_ic_procedure,
+ (entry_point, ignore_2, ignore_3, ignore_4),
+ instruction *entry_point AND
+ long ignore_2 AND long ignore_3 AND long ignore_4)
{
return (compiler_interrupt_common (entry_point,
ENTRY_SKIPPED_CHECK_OFFSET,
}
C_TO_SCHEME long
-comp_interrupt_restart ()
+DEFUN_VOID (comp_interrupt_restart)
{
SCHEME_OBJECT state;
/* Assigning a variable that has a trap in it (except unassigned) */
SCHEME_UTILITY struct utility_result
-comutil_assignment_trap (return_address, extension_addr, value, ignore_4)
- instruction *return_address;
- SCHEME_OBJECT *extension_addr, value;
- long ignore_4;
+DEFUN (comutil_assignment_trap,
+ (return_address, extension_addr, value, ignore_4),
+ instruction *return_address AND
+ SCHEME_OBJECT *extension_addr AND SCHEME_OBJECT value AND
+ long ignore_4)
{
extern long compiler_assignment_trap();
SCHEME_OBJECT extension;
}
else
{
- SCHEME_OBJECT block, environment, name;
+ SCHEME_OBJECT block, environment, name, sra;
- STACK_PUSH(ENTRY_TO_OBJECT (return_address));
+ sra = (ENTRY_TO_OBJECT (return_address));
+ STACK_PUSH (sra);
STACK_PUSH (value);
- block = (compiled_entry_to_block (return_address));
+ block = (compiled_entry_to_block (sra));
environment = (compiled_block_environment (block));
STACK_PUSH (environment);
name = (compiler_var_error (extension, environment));
}
C_TO_SCHEME long
-comp_assignment_trap_restart ()
+DEFUN_VOID (comp_assignment_trap_restart)
{
extern long Symbol_Lex_Set();
SCHEME_OBJECT name, environment, value;
}
\f
SCHEME_UTILITY struct utility_result
-comutil_cache_lookup_apply (extension_addr, block_address, nactuals, ignore_4)
- SCHEME_OBJECT *extension_addr, *block_address;
- long nactuals, ignore_4;
+DEFUN (comutil_cache_lookup_apply,
+ (extension_addr, block_address, nactuals, ignore_4),
+ SCHEME_OBJECT *extension_addr AND SCHEME_OBJECT *block_address AND
+ long nactuals AND long ignore_4)
{
extern long compiler_lookup_trap();
SCHEME_OBJECT extension;
}
C_TO_SCHEME long
-comp_cache_lookup_apply_restart ()
+DEFUN_VOID (comp_cache_lookup_apply_restart)
{
extern long Symbol_Lex_Ref();
SCHEME_OBJECT name, environment, block;
#define CMPLR_REF_TRAP(name, c_trap, ret_code, restart, c_lookup) \
SCHEME_UTILITY struct utility_result \
-name (return_address, extension_addr, ignore_3, ignore_4) \
- instruction *return_address; \
- SCHEME_OBJECT *extension_addr; \
- long ignore_3, ignore_4; \
+DEFUN (name, \
+ (return_address, extension_addr, ignore_3, ignore_4), \
+ instruction *return_address AND \
+ SCHEME_OBJECT *extension_addr AND \
+ long ignore_3 AND long ignore_4) \
{ \
extern long c_trap(); \
long code; \
} \
else \
{ \
- SCHEME_OBJECT block, environment, name; \
+ SCHEME_OBJECT block, environment, name, sra; \
\
- STACK_PUSH (ENTRY_TO_OBJECT (return_address)); \
- block = (compiled_entry_to_block (return_address)); \
+ sra = (ENTRY_TO_OBJECT (return_address)); \
+ STACK_PUSH (sra); \
+ block = (compiled_entry_to_block (sra)); \
environment = (compiled_block_environment (block)); \
STACK_PUSH (environment); \
name = (compiler_var_error (extension, environment)); \
} \
\
C_TO_SCHEME long \
-restart () \
+DEFUN_VOID (restart) \
{ \
extern long c_lookup(); \
SCHEME_OBJECT name, environment; \
#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; \
+DEFUN (name, \
+ (ignore_1, ignore_2, ignore_3, ignore_4), \
+ long ignore_1 AND long ignore_2 AND \
+ long ignore_3 AND long ignore_4) \
{ \
SCHEME_OBJECT handler; \
\
#define CMPLR_REFERENCE(util_name, c_proc, ret_code, restart_name) \
SCHEME_UTILITY struct utility_result \
-util_name (ret_add, environment, variable, ignore_4) \
- instruction *ret_add; \
- SCHEME_OBJECT environment, variable; \
- long ignore_4; \
+DEFUN (util_name, \
+ (ret_add, environment, variable, ignore_4), \
+ instruction *ret_add AND \
+ SCHEME_OBJECT environment AND SCHEME_OBJECT variable AND \
+ long ignore_4) \
{ \
extern long c_proc(); \
long code; \
} \
\
C_TO_SCHEME long \
-restart_name () \
+DEFUN_VOID (restart_name) \
{ \
extern long c_proc(); \
SCHEME_OBJECT environment, variable; \
\f
#define CMPLR_ASSIGNMENT(util_name, c_proc, ret_code, restart_name) \
SCHEME_UTILITY struct utility_result \
-util_name (ret_add, environment, variable, value) \
- instruction *ret_add; \
- SCHEME_OBJECT environment, variable, value; \
+DEFUN (util_name, \
+ (ret_add, environment, variable, value), \
+ instruction *ret_add AND \
+ SCHEME_OBJECT environment AND SCHEME_OBJECT variable \
+ AND SCHEME_OBJECT value) \
{ \
extern long c_proc(); \
long code; \
} \
\
C_TO_SCHEME long \
-restart_name () \
+DEFUN_VOID (restart_name) \
{ \
extern long c_proc(); \
SCHEME_OBJECT environment, variable, value; \
comp_definition_restart);
\f
SCHEME_UTILITY struct utility_result
-comutil_lookup_apply (environment, variable, nactuals, ignore_4)
- SCHEME_OBJECT environment, variable;
- long nactuals, ignore_4;
+DEFUN (comutil_lookup_apply,
+ (environment, variable, nactuals, ignore_4),
+ SCHEME_OBJECT environment AND SCHEME_OBJECT variable AND
+ long nactuals AND long ignore_4)
{
extern long Lex_Ref();
long code;
}
C_TO_SCHEME long
-comp_lookup_apply_restart ()
+DEFUN_VOID (comp_lookup_apply_restart)
{
extern long Lex_Ref();
SCHEME_OBJECT environment, variable;
}
\f
SCHEME_UTILITY struct utility_result
-comutil_primitive_error (ret_add, primitive, ignore_3, ignore_4)
- instruction *ret_add;
- SCHEME_OBJECT primitive;
- long ignore_3, ignore_4;
+DEFUN (comutil_primitive_error,
+ (ret_add, primitive, ignore_3, ignore_4),
+ instruction *ret_add AND
+ SCHEME_OBJECT primitive AND
+ long ignore_3 AND long ignore_4)
{
STACK_PUSH (ENTRY_TO_OBJECT (ret_add));
STACK_PUSH (primitive);
}
C_TO_SCHEME long
-comp_error_restart ()
+DEFUN_VOID (comp_error_restart)
{
instruction *ret_add;
*/
C_UTILITY SCHEME_OBJECT
-compiled_block_debugging_info (block)
- SCHEME_OBJECT block;
+DEFUN (compiled_block_debugging_info,
+ (block),
+ SCHEME_OBJECT block)
{
long length;
/* Extract the environment where the `block' was "loaded". */
C_UTILITY SCHEME_OBJECT
-compiled_block_environment (block)
- SCHEME_OBJECT block;
+DEFUN (compiled_block_environment,
+ (block),
+ SCHEME_OBJECT block)
{
long length;
*/
C_UTILITY SCHEME_OBJECT *
-compiled_entry_to_block_address (entry)
- SCHEME_OBJECT entry;
+DEFUN (compiled_entry_to_block_address,
+ (entry),
+ SCHEME_OBJECT entry)
{
SCHEME_OBJECT *block_address;
}
C_UTILITY SCHEME_OBJECT
-compiled_entry_to_block (entry)
- SCHEME_OBJECT entry;
+DEFUN (compiled_entry_to_block,
+ (entry),
+ SCHEME_OBJECT entry)
{
SCHEME_OBJECT *block_address;
/* Returns the offset from the block to the entry point. */
C_UTILITY long
-compiled_entry_to_block_offset (entry)
- SCHEME_OBJECT entry;
+DEFUN (compiled_entry_to_block_offset,
+ (entry),
+ SCHEME_OBJECT entry)
{
SCHEME_OBJECT *entry_address, *block_address;
*/
static long
-block_address_closure_p (block_addr)
- SCHEME_OBJECT *block_addr;
+DEFUN (block_address_closure_p,
+ (block_addr),
+ SCHEME_OBJECT *block_addr)
{
SCHEME_OBJECT header_word;
*/
C_UTILITY long
-compiled_block_closure_p (block)
- SCHEME_OBJECT block;
+DEFUN (compiled_block_closure_p,
+ (block),
+ SCHEME_OBJECT block)
{
return (block_address_closure_p (OBJECT_ADDRESS (block)));
}
*/
C_UTILITY long
-compiled_entry_closure_p (entry)
- SCHEME_OBJECT entry;
+DEFUN (compiled_entry_closure_p,
+ (entry),
+ SCHEME_OBJECT entry)
{
return (block_address_closure_p (compiled_entry_to_block_address (entry)));
}
*/
C_UTILITY SCHEME_OBJECT
-compiled_closure_to_entry (entry)
- SCHEME_OBJECT entry;
+DEFUN (compiled_closure_to_entry,
+ (entry),
+ SCHEME_OBJECT entry)
{
SCHEME_OBJECT real_entry;
#define CONTINUATION_RETURN_TO_INTERPRETER 2
C_UTILITY void
-compiled_entry_type (entry, buffer)
- SCHEME_OBJECT entry;
- long *buffer;
+DEFUN (compiled_entry_type,
+ (entry, buffer),
+ SCHEME_OBJECT entry AND
+ long *buffer)
{
long kind, min_arity, max_arity, field1, field2;
SCHEME_OBJECT *entry_address;
/* Destructuring free variable caches. */
C_UTILITY void
-store_variable_cache (extension, block, offset)
- SCHEME_OBJECT extension, block;
- long offset;
+DEFUN (store_variable_cache,
+ (extension, block, offset),
+ SCHEME_OBJECT extension AND SCHEME_OBJECT block AND
+ long offset)
{
FAST_MEMORY_SET (block, offset,
((SCHEME_OBJECT) (OBJECT_ADDRESS (extension))));
}
C_UTILITY SCHEME_OBJECT
-extract_variable_cache (block, offset)
- SCHEME_OBJECT block;
- long offset;
+DEFUN (extract_variable_cache,
+ (block, offset),
+ SCHEME_OBJECT block AND
+ long offset)
{
return (MAKE_POINTER_OBJECT (TRAP_EXTENSION_TYPE,
((SCHEME_OBJECT *)
/* Get a compiled procedure from a cached operator reference. */
C_UTILITY SCHEME_OBJECT
-extract_uuo_link (block, offset)
- SCHEME_OBJECT block;
- long offset;
+DEFUN (extract_uuo_link,
+ (block, offset),
+ SCHEME_OBJECT block AND
+ long offset)
{
SCHEME_OBJECT *cache_address, compiled_entry_address;
return (ENTRY_TO_OBJECT ((SCHEME_OBJECT *) compiled_entry_address));
}
-#ifndef FLUSH_I_CACHE_REGION
-
-#define FLUSH_I_CACHE_REGION(addr, nwords) \
-do { \
-} while (0)
-
-#endif
-
static void
-store_uuo_link (entry, cache_address)
- SCHEME_OBJECT entry, *cache_address;
+DEFUN (store_uuo_link,
+ (entry, cache_address),
+ SCHEME_OBJECT entry AND SCHEME_OBJECT *cache_address)
{
SCHEME_OBJECT *entry_address;
entry_address = (OBJECT_ADDRESS (entry));
STORE_EXECUTE_CACHE_CODE (cache_address);
STORE_EXECUTE_CACHE_ADDRESS (cache_address, entry_address);
- FLUSH_I_CACHE_REGION (cache_address, EXECUTE_CACHE_ENTRY_SIZE);
+ if (!linking_cc_block_p)
+ {
+ /* The linker will flush the whole region afterwards. */
+
+ FLUSH_I_CACHE_REGION (cache_address, EXECUTE_CACHE_ENTRY_SIZE);
+ }
return;
}
\f
#define TRAMPOLINE_SIZE (TRAMPOLINE_ENTRY_SIZE + 2)
static long
-make_trampoline (slot, fmt_word, kind, size, value1, value2, value3)
- SCHEME_OBJECT *slot;
- format_word fmt_word;
- long kind, size;
- SCHEME_OBJECT value1, value2, value3;
+DEFUN (make_trampoline,
+ (slot, fmt_word, kind, size, value1, value2, value3),
+ SCHEME_OBJECT *slot AND
+ format_word fmt_word AND
+ long kind AND long size AND
+ SCHEME_OBJECT value1 AND SCHEME_OBJECT value2
+ AND SCHEME_OBJECT value3)
{
SCHEME_OBJECT *block, *local_free, *entry_point;
/* Standard trampolines. */
static long
-make_redirection_trampoline (slot, kind, procedure)
- SCHEME_OBJECT *slot;
- long kind;
- SCHEME_OBJECT procedure;
+DEFUN (make_redirection_trampoline,
+ (slot, kind, procedure),
+ SCHEME_OBJECT *slot AND
+ long kind AND
+ SCHEME_OBJECT procedure)
{
return (make_trampoline (slot,
((format_word) FORMAT_WORD_CMPINT),
}
static long
-make_apply_trampoline (slot, kind, procedure, nactuals)
- SCHEME_OBJECT *slot;
- long kind, nactuals;
- SCHEME_OBJECT procedure;
+DEFUN (make_apply_trampoline,
+ (slot, kind, procedure, nactuals),
+ SCHEME_OBJECT *slot AND
+ long kind AND SCHEME_OBJECT procedure AND
+ long nactuals)
{
return (make_trampoline (slot,
((format_word) FORMAT_WORD_CMPINT),
*/
C_UTILITY long
-make_uuo_link (procedure, extension, block, offset)
- SCHEME_OBJECT procedure, extension, block;
- long offset;
+DEFUN (make_uuo_link,
+ (procedure, extension, block, offset),
+ SCHEME_OBJECT procedure AND SCHEME_OBJECT extension
+ AND SCHEME_OBJECT block AND
+ long offset)
{
long kind, result, nactuals;
SCHEME_OBJECT trampoline, *cache_address;
}
\f
C_UTILITY long
-make_fake_uuo_link (extension, block, offset)
- SCHEME_OBJECT extension, block;
- long offset;
+DEFUN (make_fake_uuo_link,
+ (extension, block, offset),
+ SCHEME_OBJECT extension AND SCHEME_OBJECT block AND
+ long offset)
{
long result;
SCHEME_OBJECT trampoline, *cache_address;
/* C_UTILITY long fake_uuo_link_p does not appear to be used anymore */
C_UTILITY long
-coerce_to_compiled (procedure, arity, location)
- SCHEME_OBJECT procedure, *location;
- long arity;
+DEFUN (coerce_to_compiled,
+ (procedure, arity, location),
+ SCHEME_OBJECT procedure AND long arity AND SCHEME_OBJECT *location)
{
long frame_size;
#define COMPILER_INTERFACE_VERSION 3
#ifndef COMPILER_REGBLOCK_N_FIXED
-#define COMPILER_REGBLOCK_N_FIXED 16
+# define COMPILER_REGBLOCK_N_FIXED 16
#endif
#ifndef COMPILER_REGBLOCK_N_TEMPS
-#define COMPILER_REGBLOCK_N_TEMPS 256
+# define COMPILER_REGBLOCK_N_TEMPS 256
#endif
#ifndef COMPILER_REGBLOCK_EXTRA_SIZE
-#define COMPILER_REGBLOCK_EXTRA_SIZE 0
+# define COMPILER_REGBLOCK_EXTRA_SIZE 0
#endif
#if (REGBLOCK_MINIMUM_LENGTH > COMPILER_REGBLOCK_N_FIXED)
-#include "error: cmpint.c and const.h disagree on REGBLOCK_MINIMUM_LENGTH!"
+# error "cmpint.c and const.h disagree on REGBLOCK_MINIMUM_LENGTH!"
#endif
/* ((sizeof(SCHEME_OBJECT)) / (sizeof(SCHEME_OBJECT))) */
#define COMPILER_FIXED_SIZE 1
#ifndef COMPILER_TEMP_SIZE
-#define COMPILER_TEMP_SIZE ((sizeof (double)) / (sizeof (SCHEME_OBJECT)))
+# define COMPILER_TEMP_SIZE ((sizeof (double)) / (sizeof (SCHEME_OBJECT)))
#endif
#define REGBLOCK_LENGTH \
-((COMPILER_REGBLOCK_N_FIXED * COMPILER_FIXED_SIZE) + \
- (COMPILER_REGBLOCK_N_TEMPS * COMPILER_TEMP_SIZE) + \
- COMPILER_REGBLOCK_EXTRA_SIZE)
+ ((COMPILER_REGBLOCK_N_FIXED * COMPILER_FIXED_SIZE) + \
+ (COMPILER_REGBLOCK_N_TEMPS * COMPILER_TEMP_SIZE) + \
+ COMPILER_REGBLOCK_EXTRA_SIZE)
#ifndef ASM_RESET_HOOK
-#define ASM_RESET_HOOK() \
-do { \
-} while (0)
+# define ASM_RESET_HOOK() NOP()
#endif
\f
long
Registers[REGBLOCK_LENGTH];
static void
-compiler_reset_internal ()
+DEFUN_VOID (compiler_reset_internal)
{
/* Other stuff can be placed here. */
+ Registers[REGBLOCK_CLOSURE_FREE] = ((SCHEME_OBJECT) NULL);
+ Registers[REGBLOCK_CLOSURE_SPACE] = ((SCHEME_OBJECT) 0);
+
ASM_RESET_HOOK();
+
return_to_interpreter =
(ENTRY_TO_OBJECT ((SCHEME_OBJECT *)
((OBJECT_ADDRESS (compiler_utilities)) +
}
\f
C_UTILITY void
-compiler_reset (new_block)
- SCHEME_OBJECT new_block;
+DEFUN (compiler_reset,
+ (new_block),
+ SCHEME_OBJECT new_block)
{
/* Called after a disk restore */
}
C_UTILITY void
-compiler_initialize (fasl_p)
- long fasl_p;
+DEFUN (compiler_initialize,
+ (fasl_p),
+ long fasl_p)
{
/* Start-up of whole interpreter */
}
else
{
+ /* Delay until after band-load, when compiler_reset will be invoked. */
compiler_utilities = SHARP_F;
return_to_interpreter = SHARP_F;
}
return_to_interpreter;
extern long
- enter_compiled_expression(),
- apply_compiled_procedure(),
- return_to_compiled_code(),
- make_fake_uuo_link(),
- make_uuo_link(),
- compiled_block_closure_p(),
- compiled_entry_closure_p(),
- compiled_entry_to_block_offset();
+ EXFUN (enter_compiled_expression, (void)),
+ EXFUN (apply_compiled_procedure, (void)),
+ EXFUN (return_to_compiled_code, (void)),
+ EXFUN (make_fake_uuo_link,
+ (SCHEME_OBJECT extension, SCHEME_OBJECT block, long offset)),
+ EXFUN (make_uuo_link,
+ (SCHEME_OBJECT value, SCHEME_OBJECT extension,
+ SCHEME_OBJECT block, long offset)),
+ EXFUN (compiled_block_closure_p, (SCHEME_OBJECT block)),
+ EXFUN (compiled_entry_closure_p, (SCHEME_OBJECT entry)),
+ EXFUN (compiled_entry_to_block_offset, (SCHEME_OBJECT entry)),
+ EXFUN (coerce_to_compiled,
+ (SCHEME_OBJECT object, SCHEME_OBJECT *location, long arity));
extern SCHEME_OBJECT
- extract_uuo_link(),
- extract_variable_cache(),
- compiled_block_debugging_info(),
- compiled_block_environment(),
- compiled_closure_to_entry(),
- *compiled_entry_to_block_address();
+ EXFUN (extract_uuo_link, (SCHEME_OBJECT block, long offset)),
+ EXFUN (extract_variable_cache,
+ (SCHEME_OBJECT extension, long offset)),
+ EXFUN (compiled_block_debugging_info, (SCHEME_OBJECT block)),
+ 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));
extern void
- store_variable_cache(),
- compiled_entry_type();
+ EXFUN (compiler_reset, (SCHEME_OBJECT new_block)),
+ EXFUN (compiler_initialize, (long fasl_p))
+ EXFUN (store_variable_cache,
+ (SCHEME_OBJECT extension, SCHEME_OBJECT block, long offset)),
+ EXFUN (compiled_entry_type,
+ (SCHEME_OBJECT entry, long *buffer));
\f
SCHEME_OBJECT
Registers[REGBLOCK_MINIMUM_LENGTH],
compiler_processor_type;
long
-enter_compiled_expression ()
+DEFUN_VOID (enter_compiled_expression)
{
return (ERR_EXECUTE_MANIFEST_VECTOR);
}
long
-apply_compiled_procedure ()
+DEFUN_VOID (apply_compiled_procedure)
{
return (ERR_INAPPLICABLE_OBJECT);
}
long
-return_to_compiled_code ()
+DEFUN_VOID (return_to_compiled_code)
{
return (ERR_INAPPLICABLE_CONTINUATION);
}
/* Bad entry points. */
long
-make_fake_uuo_link (extension, block, offset)
- SCHEME_OBJECT extension, block;
- long offset;
+DEFUN (make_fake_uuo_link,
+ (extension, block, offset),
+ SCHEME_OBJECT extension AND SCHEME_OBJECT block AND
+ long offset)
{
Microcode_Termination (TERM_COMPILER_DEATH);
/*NOTREACHED*/
}
long
-make_uuo_link (value, extension, block, offset)
- SCHEME_OBJECT value, extension, block;
- long offset;
+DEFUN (make_uuo_link,
+ (value, extension, block, offset),
+ SCHEME_OBJECT value AND SCHEME_OBJECT extension AND
+ SCHEME_OBJECT block AND long offset)
{
Microcode_Termination (TERM_COMPILER_DEATH);
/*NOTREACHED*/
}
SCHEME_OBJECT
-extract_uuo_link (block, offset)
- SCHEME_OBJECT block;
- long offset;
+DEFUN (extract_uuo_link,
+ (block, offset),
+ SCHEME_OBJECT block AND long offset)
{
Microcode_Termination (TERM_COMPILER_DEATH);
/*NOTREACHED*/
}
\f
void
-store_variable_cache (extension, block, offset)
- SCHEME_OBJECT extension, block;
- long offset;
+DEFUN (store_variable_cache,
+ (extension, block, offset),
+ SCHEME_OBJECT extension AND SCHEME_OBJECT block AND
+ long offset)
{
Microcode_Termination (TERM_COMPILER_DEATH);
/*NOTREACHED*/
}
SCHEME_OBJECT
-extract_variable_cache (block, offset)
- SCHEME_OBJECT block;
- long offset;
+DEFUN (extract_variable_cache,
+ (block, offset),
+ SCHEME_OBJECT block AND
+ long offset)
{
Microcode_Termination (TERM_COMPILER_DEATH);
/*NOTREACHED*/
}
SCHEME_OBJECT
-compiled_block_debugging_info (block)
- SCHEME_OBJECT block;
+DEFUN (compiled_block_debugging_info,
+ (block),
+ SCHEME_OBJECT block)
{
Microcode_Termination (TERM_COMPILER_DEATH);
/*NOTREACHED*/
}
SCHEME_OBJECT
-compiled_block_environment (block)
- SCHEME_OBJECT block;
+DEFUN (compiled_block_environment,
+ (block),
+ SCHEME_OBJECT block)
{
Microcode_Termination (TERM_COMPILER_DEATH);
/*NOTREACHED*/
}
long
-compiled_block_closure_p (block)
- SCHEME_OBJECT block;
+DEFUN (compiled_block_closure_p,
+ (block),
+ SCHEME_OBJECT block)
{
Microcode_Termination (TERM_COMPILER_DEATH);
/*NOTREACHED*/
}
SCHEME_OBJECT *
-compiled_entry_to_block_address (entry)
- SCHEME_OBJECT entry;
+DEFUN (compiled_entry_to_block_address,
+ (entry),
+ SCHEME_OBJECT entry)
{
Microcode_Termination (TERM_COMPILER_DEATH);
/*NOTREACHED*/
}
long
-compiled_entry_to_block_offset (entry)
- SCHEME_OBJECT entry;
+DEFUN (compiled_entry_to_block_offset,
+ (entry),
+ SCHEME_OBJECT entry)
{
Microcode_Termination (TERM_COMPILER_DEATH);
/*NOTREACHED*/
}
+
+C_UTILITY SCHEME_OBJECT
+DEFUN (compiled_entry_to_block,
+ (entry),
+ SCHEME_OBJECT entry)
+{
+ Microcode_Termination (TERM_COMPILER_DEATH);
+ /*NOTREACHED*/
+}
+
\f
void
-compiled_entry_type (entry, buffer)
- SCHEME_OBJECT entry, *buffer;
+DEFUN (compiled_entry_type,
+ (entry, buffer),
+ SCHEME_OBJECT entry AND long *buffer)
{
Microcode_Termination (TERM_COMPILER_DEATH);
/*NOTREACHED*/
}
long
-compiled_entry_closure_p (entry)
- SCHEME_OBJECT entry;
+DEFUN (compiled_entry_closure_p,
+ (entry),
+ SCHEME_OBJECT entry)
{
Microcode_Termination (TERM_COMPILER_DEATH);
/*NOTREACHED*/
}
SCHEME_OBJECT
-compiled_closure_to_entry (entry)
- SCHEME_OBJECT entry;
+DEFUN (compiled_closure_to_entry,
+ (entry),
+ SCHEME_OBJECT entry)
{
Microcode_Termination (TERM_COMPILER_DEATH);
/*NOTREACHED*/
}
#define LOSING_RETURN_ADDRESS(name) \
-extern long name(); \
+extern long EXFUN (name, (void)); \
long \
-name() \
+DEFUN_VOID (name) \
{ \
Microcode_Termination (TERM_COMPILER_DEATH); \
/*NOTREACHED*/ \
\f
/* NOP entry points */
-extern void
- compiler_reset(),
- compiler_initialize();
-
-extern long
- coerce_to_compiled();
-
void
-compiler_reset (new_block)
- SCHEME_OBJECT new_block;
+DEFUN (compiler_reset,
+ (new_block),
+ SCHEME_OBJECT new_block)
{
extern void compiler_reset_error();
}
void
-compiler_initialize (fasl_p)
- long fasl_p;
+DEFUN (compiler_initialize,
+ (fasl_p),
+ long fasl_p)
{
compiler_processor_type = 0;
compiler_interface_version = 0;
/* Identity procedure */
long
-coerce_to_compiled(object, arity, location)
- SCHEME_OBJECT object, *location;
- long arity;
+DEFUN (coerce_to_compiled,
+ (object, arity, location),
+ SCHEME_OBJECT object AND long arity AND SCHEME_OBJECT *location)
{
*location = object;
return (PRIM_DONE);
/* -*-C-*-
-Copyright (c) 1987, 1988, 1989 Massachusetts Institute of Technology
+Copyright (c) 1987-1991 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
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/const.h,v 9.36 1990/06/20 17:39:29 cph Rel $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/const.h,v 9.37 1991/03/21 23:26:21 jinx Exp $
*
* Named constants used throughout the interpreter
*
#define REGBLOCK_STACKGUARD 1
#define REGBLOCK_VAL 2
#define REGBLOCK_ENV 3
-#define REGBLOCK_TEMP 4
+#define REGBLOCK_COMPILER_TEMP 4 /* For use by compiler */
#define REGBLOCK_EXPR 5
#define REGBLOCK_RETURN 6
#define REGBLOCK_LEXPR_ACTUALS 7
#define REGBLOCK_PRIMITIVE 8
-#define REGBLOCK_MINIMUM_LENGTH 9
+#define REGBLOCK_CLOSURE_FREE 9 /* For use by compiler */
+#define REGBLOCK_CLOSURE_SPACE 10 /* For use by compiler */
+#define REGBLOCK_MINIMUM_LENGTH 11
\f
/* Codes specifying how to start scheme at boot time. */
/* -*-C-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/version.h,v 11.69 1991/03/14 23:02:55 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/version.h,v 11.70 1991/03/21 23:26:47 jinx Exp $
Copyright (c) 1988-91 Massachusetts Institute of Technology
#define VERSION 11
#endif
#ifndef SUBVERSION
-#define SUBVERSION 69
+#define SUBVERSION 70
#endif
projects / mit-scheme.git / commitdiff