/* -*-C-*-
$Id: cmpint.h,v 10.7 2000/12/05 21:23:43 cph Exp $
Copyright (c) 1987-1990, 1999, 2000 Massachusetts Institute of Technology
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or (at
your option) any later version.
This program is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
*/
/* Macros for the interface between compiled code and interpreted code. */
/* Stack Gap Operations: */
/* With_Stack_Gap opens a gap Gap_Size wide Gap_Position cells above the
* top of the stack. Code must push Gap_Size objects. It executes Code
* with the stack pointer placed so that these objects will fill the gap.
*/
#define With_Stack_Gap(Gap_Size, Gap_Position, Code) \
{ \
fast long size_to_move = (Gap_Position); \
fast SCHEME_OBJECT * Destination = (STACK_LOC (- (Gap_Size))); \
SCHEME_OBJECT * Saved_Destination = Destination; \
while ((--size_to_move) >= 0) \
(STACK_LOCATIVE_POP (Destination)) = (STACK_POP ()); \
Code; \
Stack_Pointer = Saved_Destination; \
}
/* Close_Stack_Gap closes a gap Gap_Size wide Gap_Position cells above the
* top of the stack. The contents of the gap are lost.
*/
#define Close_Stack_Gap(Gap_Size, Gap_Position, extra_code) \
{ \
fast long size_to_move; \
fast SCHEME_OBJECT *Source; \
\
size_to_move = (Gap_Position); \
Source = (STACK_LOC (size_to_move)); \
Stack_Pointer = (STACK_LOC ((Gap_Size) + size_to_move)); \
extra_code; \
while (--size_to_move >= 0) \
{ \
STACK_PUSH (STACK_LOCATIVE_PUSH (Source)); \
} \
}
/* Going from interpreted code to compiled code */
/* Tail recursion is handled as follows:
if the return code is `reenter_compiled_code', it is discarded,
and the two contiguous interpreter segments on the stack are
merged.
*/
/* Apply interface:
calling a compiled procedure with a frame nslots long.
*/
#define apply_compiled_setup(nslots) \
{ \
long frame_size; \
\
frame_size = (nslots); \
if (STACK_REF(frame_size + CONTINUATION_RETURN_CODE) == \
(MAKE_OBJECT (TC_RETURN_CODE, RC_REENTER_COMPILED_CODE))) \
{ \
/* Merge compiled code segments on the stack. */ \
Close_Stack_Gap (CONTINUATION_SIZE, \
frame_size, \
{ \
long segment_size = \
(OBJECT_DATUM \
(STACK_REF \
(CONTINUATION_EXPRESSION - \
CONTINUATION_SIZE))); \
last_return_code = (STACK_LOC (segment_size)); \
}); \
/* Undo the subproblem rotation. */ \
Compiler_End_Subproblem(); \
} \
else \
{ \
/* Make a new compiled code segment which includes this frame. */ \
/* History need not be hacked here. */ \
With_Stack_Gap(1, \
frame_size, \
{ \
last_return_code = (STACK_LOC (0)); \
STACK_PUSH (return_to_interpreter); \
}); \
} \
}
/* Eval interface:
executing a compiled expression.
*/
#define execute_compiled_setup() \
{ \
if (STACK_REF(CONTINUATION_RETURN_CODE) == \
(MAKE_OBJECT (TC_RETURN_CODE, RC_REENTER_COMPILED_CODE))) \
{ \
/* Merge compiled code segments on the stack. */ \
long segment_size; \
\
Restore_Cont(); \
segment_size = OBJECT_DATUM (Fetch_Expression()); \
last_return_code = (STACK_LOC (segment_size)); \
/* Undo the subproblem rotation. */ \
Compiler_End_Subproblem(); \
} \
else \
{ \
/* Make a new compiled code segment on the stack. */ \
/* History need not be hacked here. */ \
last_return_code = (STACK_LOC (0)); \
STACK_PUSH (return_to_interpreter); \
} \
}
/* Pop return interface:
Returning to compiled code from the interpreter.
*/
#define compiled_code_restart() \
{ \
long segment_size = OBJECT_DATUM (Fetch_Expression()); \
last_return_code = (STACK_LOC (segment_size)); \
/* Undo the subproblem rotation. */ \
Compiler_End_Subproblem(); \
}
/* Going from compiled code to interpreted code */
/* Tail recursion is handled in the following way:
if the return address is `return_to_interpreter', it is discarded,
and the two contiguous interpreter segments on the stack are
merged.
*/
/* Apply interface:
calling an interpreted procedure (or unsafe primitive)
with a frame nslots long.
*/
#define compiler_apply_procedure(nslots) \
{ \
long frame_size = (nslots); \
if ((STACK_REF (frame_size)) == return_to_interpreter) \
{ \
Close_Stack_Gap(1, frame_size, {}); \
/* Set up the current rib. */ \
Compiler_New_Reduction (); \
} \
else \
{ /* Make a new interpreter segment which includes this frame. */ \
With_Stack_Gap \
(CONTINUATION_SIZE, \
frame_size, \
{ \
long segment_size = \
(STACK_LOCATIVE_DIFFERENCE \
(last_return_code, (STACK_LOC (0)))); \
Store_Expression (LONG_TO_UNSIGNED_FIXNUM (segment_size)); \
Store_Return (RC_REENTER_COMPILED_CODE); \
Save_Cont (); \
}); \
/* Rotate history to a new subproblem. */ \
Compiler_New_Subproblem (); \
} \
}
/* Pop Return interface:
returning to the interpreter from compiled code.
Nothing needs to be done at this time.
*/
#define compiled_code_done()
/* Various handlers for backing out of compiled code. */
/* Backing out of apply. */
#define apply_compiled_backout() \
{ \
compiler_apply_procedure(STACK_ENV_EXTRA_SLOTS + \
OBJECT_DATUM (STACK_REF (STACK_ENV_HEADER)));\
}
/* Backing out of eval. */
#define execute_compiled_backout() \
{ \
if ((STACK_REF (0)) == return_to_interpreter) \
{ \
/* Set up the current rib. */ \
Compiler_New_Reduction (); \
} \
else \
{ \
long segment_size = \
(STACK_LOCATIVE_DIFFERENCE (last_return_code, (STACK_LOC (0)))); \
Store_Expression (LONG_TO_UNSIGNED_FIXNUM (segment_size)); \
Store_Return (RC_REENTER_COMPILED_CODE); \
Save_Cont (); \
/* Rotate history to a new subproblem. */ \
Compiler_New_Subproblem (); \
} \
}
/* Backing out because of special errors or interrupts.
The microcode has already setup a return code with a #F.
No tail recursion in this case.
***
Is the history manipulation correct?
Does Microcode_Error do something special?
***
*/
#define compiled_error_backout() \
{ \
long segment_size; \
\
Restore_Cont(); \
segment_size = \
(STACK_LOCATIVE_DIFFERENCE (last_return_code, (STACK_LOC (0)))); \
Store_Expression (LONG_TO_UNSIGNED_FIXNUM (segment_size)); \
/* The Store_Return is a NOP, the Save_Cont is done by the code \
that follows. */ \
/* Store_Return (OBJECT_DATUM (Fetch_Return ())); */ \
/* Save_Cont (); */ \
Compiler_New_Subproblem (); \
}
extern long EXFUN (apply_compiled_procedure, (void));
extern long EXFUN (comp_access_restart, (void));
extern long EXFUN (comp_assignment_restart, (void));
extern long EXFUN (comp_assignment_trap_restart, (void));
extern long EXFUN (comp_cache_lookup_apply_restart, (void));
extern long EXFUN (comp_definition_restart, (void));
extern long EXFUN (comp_error_restart, (void));
extern long EXFUN (comp_interrupt_restart, (void));
extern long EXFUN (comp_link_caches_restart, (void));
extern long EXFUN (comp_lookup_apply_restart, (void));
extern long EXFUN (comp_lookup_trap_restart, (void));
extern long EXFUN (comp_op_lookup_trap_restart, (void));
extern long EXFUN (comp_reference_restart, (void));
extern long EXFUN (comp_safe_lookup_trap_restart, (void));
extern long EXFUN (comp_safe_reference_restart, (void));
extern long EXFUN (comp_unassigned_p_restart, (void));
extern long EXFUN (comp_unassigned_p_trap_restart, (void));
extern long EXFUN (comp_unbound_p_restart, (void));
extern long EXFUN (enter_compiled_expression, (void));
extern long EXFUN (return_to_compiled_code, (void));
extern SCHEME_OBJECT * EXFUN
(compiled_entry_to_block_address, (SCHEME_OBJECT));
extern void EXFUN (compiled_entry_type, (SCHEME_OBJECT, long *));
syntax highlighted by Code2HTML, v. 0.9.1