- Redo the way that descriptors are done to improve speed.
The default clause in each switch statement is now the only way to
get out of a block.
All JUMPs merely jump back to the dispatch point.
- Divide initialization code into code and data, to allow splitting
of the sources into two components.
/* -*-C-*-
-$Id: cmpint.c,v 1.73 1993/10/26 02:57:43 gjr Exp $
+$Id: cmpint.c,v 1.74 1993/10/30 03:04:27 gjr Exp $
Copyright (c) 1989-1993 Massachusetts Institute of Technology
extern void EXFUN (C_to_interface, (void *));
extern utility_result interface_to_C_hook;
-static long C_return_value;
+extern long C_return_value;
+long C_return_value;
/* Convenience macros */
UTE(comutil_compiled_code_bkpt), /* 0x3c */
UTE(comutil_compiled_closure_bkpt) /* 0x3d */
};
+
+extern long MAX_TRAMPOLINE;
+long MAX_TRAMPOLINE = ((sizeof (utility_table))
+ / (sizeof (utility_table_entry)));
\f
/* Support for trap handling. */
/* -*-C-*-
-$Id: compinit.c,v 1.2 1993/06/09 20:36:38 jawilson Exp $
+$Id: compinit.c,v 1.3 1993/10/30 03:02:11 gjr Exp $
Copyright (c) 1992-1993 Massachusetts Institute of Technology
#include "liarc.h"
#undef DECLARE_COMPILED_CODE
+#undef DECLARE_COMPILED_DATA
-#define DECLARE_COMPILED_CODE(name, decl, code) do \
+#define DECLARE_COMPILED_CODE(name, nentries, decl_code, code) do \
{ \
- extern void EXFUN (decl, (void)); \
- extern SCHEME_OBJECT * EXFUN (code, (SCHEME_OBJECT *)); \
- if ((declare_compiled_code (name, decl, code)) == 0) \
- lose_big_1 ("DECLARE_COMPILED_CODE: duplicate tag", name); \
+ extern int EXFUN (decl_code, (void)); \
+ extern SCHEME_OBJECT * EXFUN (code, \
+ (SCHEME_OBJECT *, unsigned long)); \
+ int result = \
+ (declare_compiled_code (name, nentries, decl_code, code)); \
+ if (result != 0) \
+ return (result); \
} while (0)
-extern void EXFUN (lose_big_1, (char *, char *));
+#define DECLARE_COMPILED_DATA(name, decl_data, data) do \
+{ \
+ extern int EXFUN (decl_data, (void)); \
+ extern SCHEME_OBJECT * EXFUN (data, (unsigned long)); \
+ int result = (declare_compiled_data (name, decl_data, data)); \
+ if (result != 0) \
+ return (result); \
+} while (0)
-void
+int
DEFUN_VOID (initialize_compiled_code_blocks)
{
#include "compinit.h"
- return;
+ return (0);
}
/* -*-C-*-
-$Id: comutl.c,v 1.28 1993/10/26 02:58:01 gjr Exp $
+$Id: comutl.c,v 1.29 1993/10/30 03:04:19 gjr Exp $
Copyright (c) 1987-1993 Massachusetts Institute of Technology
/* This is only meaningful for the C back end. */
-DEFINE_PRIMITIVE ("INITIALIZE-C-COMPILED-BLOCK", Prim_initialize_C_compiled_block, 1, 1,
+DEFINE_PRIMITIVE ("INITIALIZE-C-COMPILED-BLOCK",
+ Prim_initialize_C_compiled_block, 1, 1,
"Given the tag of a compiled object, return the object.")
{
#ifdef NATIVE_CODE_IS_C
/* -*-C-*-
-$Id: liarc.h,v 1.6 1993/10/28 04:45:25 gjr Exp $
+$Id: liarc.h,v 1.7 1993/10/30 03:02:05 gjr Exp $
Copyright (c) 1992-1993 Massachusetts Institute of Technology
typedef union machine_word_u machine_word;
-#define ERROR_UNKNOWN_DISPATCH( pc ) lose_big ("Unknown tag.")
-
#define ADDRESS_UNITS_PER_OBJECT (sizeof (SCHEME_OBJECT))
#define ADDRESS_UNITS_PER_FLOAT (sizeof (double))
double num = (src); \
SCHEME_OBJECT * val; \
\
- ALIGN_FLOAT (free_pointer); \
- val = free_pointer; \
- free_pointer += (1 + (BYTES_TO_WORDS (sizeof (double)))); \
+ ALIGN_FLOAT (Rhp); \
+ val = Rhp; \
+ Rhp += (1 + (BYTES_TO_WORDS (sizeof (double)))); \
* val = (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, \
(BYTES_TO_WORDS (sizeof (double))))); \
(* ((double *) (val + 1))) = num; \
\f
#ifdef USE_GLOBAL_VARIABLES
-#define value_reg Val
-#define free_pointer Free
-#define register_block Regs
-#define stack_pointer Stack_Pointer
+#define Rvl Val
+#define Rhp Free
+#define Rrb Regs
+#define Rsp Stack_Pointer
#define DECLARE_VARIABLES() int unsed_variable_to_keep_C_happy
#define UNCACHE_VARIABLES() do {} while (0)
#define REGISTER register
-#define register_block Regs
+#define Rrb Regs
#define DECLARE_VARIABLES() \
-REGISTER SCHEME_OBJECT value_reg = Val; \
-REGISTER SCHEME_OBJECT * free_pointer = Free; \
-REGISTER SCHEME_OBJECT * stack_pointer = Stack_Pointer
+REGISTER SCHEME_OBJECT Rvl = Val; \
+REGISTER SCHEME_OBJECT * Rhp = Free; \
+REGISTER SCHEME_OBJECT * Rsp = Stack_Pointer
#define UNCACHE_VARIABLES() do \
{ \
- Stack_Pointer = stack_pointer; \
- Free = free_pointer; \
- Val = value_reg; \
+ Stack_Pointer = Rsp; \
+ Free = Rhp; \
+ Val = Rvl; \
} while (0)
#define CACHE_VARIABLES() do \
{ \
- value_reg = Val; \
- free_pointer = Free; \
- stack_pointer = Stack_Pointer; \
+ Rvl = Val; \
+ Rhp = Free; \
+ Rsp = Stack_Pointer; \
} while (0)
#endif /* USE_GLOBAL_VARIABLES */
-#define REPEAT_DISPATCH() do \
-{ \
- if ((LABEL_PROCEDURE (my_pc)) != current_C_proc) \
- { \
- UNCACHE_VARIABLES (); \
- return (my_pc); \
- } \
- /* fall through. */ \
-} while (0)
-
-#ifdef USE_SHORTCKT_JUMP
-
#define JUMP(destination) do \
{ \
- my_pc = (destination); \
- goto repeat_dispatch; \
+ Rpc = (destination); \
+ goto perform_dispatch; \
} while(0)
-#define JUMP_EXTERNAL(destination) do \
-{ \
- my_pc = (destination); \
- if ((LABEL_PROCEDURE (my_pc)) == current_C_proc) \
- { \
- CACHE_VARIABLES (); \
- goto perform_dispatch; \
- } \
- return (my_pc); \
-} while (0)
-
-#define JUMP_EXECUTE_CHACHE(entry) do \
-{ \
- my_pc = ((SCHEME_OBJECT *) current_block[entry]); \
- goto repeat_dispatch; \
-} while (0)
-
-#define POP_RETURN() goto pop_return_repeat_dispatch
-
-#define POP_RETURN_REPEAT_DISPATCH() do \
-{ \
- my_pc = (OBJECT_ADDRESS (*stack_pointer++)); \
- /* fall through to repeat_dispatch */ \
-} while (0)
-
-#else /* not USE_SHORTCKT_JUMP */
-
-#define JUMP(destination) do \
-{ \
- UNCACHE_VARIABLES (); \
- return (destination); \
-} while (0)
-
-#define JUMP_EXTERNAL(destination) return (destination)
-
-#define JUMP_EXECUTE_CHACHE(entry) do \
-{ \
- SCHEME_OBJECT* destination \
- = ((SCHEME_OBJECT *) current_block[entry]); \
- \
- JUMP (destination); \
-} while (0)
+#define JUMP_EXECUTE_CHACHE(label) \
+ JUMP ((SCHEME_OBJECT *) (current_block[label]))
-#define POP_RETURN() do \
-{ \
- SCHEME_OBJECT target = *stack_pointer++; \
- SCHEME_OBJECT destination = (OBJECT_ADDRESS (target)); \
- JUMP (destination); \
-} while (0)
+#define POP_RETURN() goto pop_return
-#define POP_RETURN_REPEAT_DISPATCH() do \
-{ \
-} while (0)
-
-#endif /* USE_SHORTCKT_JUMP */
-\f
#define INVOKE_PRIMITIVE(prim, nargs) do \
{ \
primitive = (prim); \
primitive_nargs = (nargs); \
goto invoke_primitive; \
} while (0)
-
+\f
#define INVOKE_PRIMITIVE_CODE() do \
{ \
SCHEME_OBJECT * destination; \
PRIMITIVE_APPLY (Val, primitive); \
POP_PRIMITIVE_FRAME (primitive_nargs); \
destination = (OBJECT_ADDRESS (STACK_POP ())); \
- JUMP_EXTERNAL (destination); \
+ CACHE_VARIABLES (); \
+ JUMP (destination); \
} while(0)
#define INVOKE_INTERFACE_CODE() do \
SCHEME_OBJECT * destination; \
\
UNCACHE_VARIABLES (); \
- destination = (invoke_utility (subtmp_code, subtmp_1, subtmp_2, \
- subtmp_3, subtmp_4)); \
- JUMP_EXTERNAL (destination); \
+ destination = (invoke_utility (utlarg_code, utlarg_1, utlarg_2, \
+ utlarg_3, utlarg_4)); \
+ CACHE_VARIABLES (); \
+ JUMP (destination); \
} while (0)
#define INVOKE_INTERFACE_4(code, one, two, three, four) do \
{ \
- subtmp_4 = ((long) (four)); \
- subtmp_3 = ((long) (three)); \
- subtmp_2 = ((long) (two)); \
- subtmp_1 = ((long) (one)); \
- subtmp_code = (code); \
+ utlarg_4 = ((long) (four)); \
+ utlarg_3 = ((long) (three)); \
+ utlarg_2 = ((long) (two)); \
+ utlarg_1 = ((long) (one)); \
+ utlarg_code = (code); \
goto invoke_interface_4; \
} while (0)
#define INVOKE_INTERFACE_3(code, one, two, three) do \
{ \
- subtmp_3 = ((long) (three)); \
- subtmp_2 = ((long) (two)); \
- subtmp_1 = ((long) (one)); \
- subtmp_code = (code); \
+ utlarg_3 = ((long) (three)); \
+ utlarg_2 = ((long) (two)); \
+ utlarg_1 = ((long) (one)); \
+ utlarg_code = (code); \
goto invoke_interface_3; \
} while (0)
#define INVOKE_INTERFACE_2(code, one, two) do \
{ \
- subtmp_2 = ((long) (two)); \
- subtmp_1 = ((long) (one)); \
- subtmp_code = (code); \
+ utlarg_2 = ((long) (two)); \
+ utlarg_1 = ((long) (one)); \
+ utlarg_code = (code); \
goto invoke_interface_2; \
} while (0)
#define INVOKE_INTERFACE_1(code, one) do \
{ \
- subtmp_1 = ((long) (one)); \
- subtmp_code = (code); \
+ utlarg_1 = ((long) (one)); \
+ utlarg_code = (code); \
goto invoke_interface_1; \
} while (0)
#define INVOKE_INTERFACE_0(code) do \
{ \
- subtmp_code = (code); \
+ utlarg_code = (code); \
goto invoke_interface_0; \
} while (0)
\f
: (((source1) >= 0) \
? (- ((source1) / (- (source2)))) \
: ((- (source1)) / (- (source2)))))
-\f
+
+#define INTERRUPT_CHECK(code, entry_point) do \
+{ \
+ if (((long) Rhp) >= ((long) (Rrb[REGBLOCK_MEMTOP]))) \
+ INVOKE_INTERFACE_1 (code, ¤t_block[entry_point]); \
+} while (0)
+
+#define DLINK_INTERRUPT_CHECK(code, entry_point) do \
+{ \
+ if (((long) Rhp) >= ((long) (Rrb[REGBLOCK_MEMTOP]))) \
+ INVOKE_INTERFACE_2 (code, ¤t_block[entry_point], Rdl); \
+} while (0)
+
#define CLOSURE_HEADER(offset) do \
{ \
- SCHEME_OBJECT * entry = ((SCHEME_OBJECT *) my_pc[1]); \
+ SCHEME_OBJECT * entry = ((SCHEME_OBJECT *) Rpc[1]); \
current_block = (entry - offset); \
- *--stack_pointer = (MAKE_POINTER_OBJECT (TC_COMPILED_ENTRY, my_pc)); \
+ *--Rsp = (MAKE_POINTER_OBJECT (TC_COMPILED_ENTRY, Rpc)); \
} while (0)
#define CLOSURE_INTERRUPT_CHECK(code) do \
{ \
- if (((long) free_pointer) \
- >= ((long) (register_block[REGBLOCK_MEMTOP]))) \
+ if (((long) Rhp) >= ((long) (Rrb[REGBLOCK_MEMTOP]))) \
INVOKE_INTERFACE_0 (code); \
} while (0)
+\f
+/* Linking and initialization */
-#define INTERRUPT_CHECK(code, entry_point) do \
+#define DECLARE_SUBCODE(name, nentries, decl_code, code) do \
{ \
- if (((long) free_pointer) \
- >= ((long) (register_block[REGBLOCK_MEMTOP]))) \
- INVOKE_INTERFACE_1 (code, ¤t_block[entry_point]); \
+ int result = (declare_compiled_code (name, nentries, \
+ decl_code, code)); \
+ \
+ if (result != 0) \
+ return (result); \
} while (0)
-#define DLINK_INTERRUPT_CHECK(code, entry_point) do \
+#define DECLARE_SUBDATA(name, decl_data, data) do \
{ \
- if (((long) free_pointer) \
- >= ((long) (register_block[REGBLOCK_MEMTOP]))) \
- INVOKE_INTERFACE_2 (code, ¤t_block[entry_point], \
- dynamic_link); \
+ int result = (declare_compiled_data (name, decl_data, data)); \
+ \
+ if (result != 0) \
+ return (result); \
} while (0)
-struct compiled_file
-{
- int number_of_procedures;
- char ** names;
- void * EXFUN ((**procs), (void));
-};
+#ifndef COMPILE_FOR_DYNAMIC_LOADING
/* This does nothing in the sources. */
-#ifndef COMPILE_FOR_DYNAMIC_LOADING
+# define DECLARE_COMPILED_CODE(name, nentries, decl_code, code) \
+ extern int EXFUN (decl_code, (void)); \
+ extern SCHEME_OBJECT * EXFUN (code, (SCHEME_OBJECT *, unsigned long));
-# define DECLARE_COMPILED_CODE(string, decl, code) \
- extern void EXFUN (decl, (void)); \
- extern SCHEME_OBJECT * EXFUN (code, (SCHEME_OBJECT *));
+# define DECLARE_COMPILED_DATA(name, decl_data, data) \
+ extern int EXFUN (decl_data, (void)); \
+ extern SCHEME_OBJECT * EXFUN (data, (unsigned long));
+
+# define DECLARE_DYNAMIC_INITIALIZATION()
#else /* COMPILE_FOR_DYNAMIC_LOADING */
-# define DECLARE_COMPILED_CODE(string, decl, code) \
- extern void EXFUN (dload_initialize_file, (void)); \
+# define DECLARE_COMPILED_CODE(name, nentries, decl_code, code) \
+ static int \
+ DEFUN_VOID (dload_initialize_code) \
+ { \
+ int EXFUN (decl_code, (void)); \
+ SCHEME_OBJECT * EXFUN (code, (SCHEME_OBJECT *, unsigned long)); \
\
- void \
- DEFUN_VOID (dload_initialize_file) \
+ return (declare_compiled_code (name, nentries, \
+ decl_code, code)); \
+ }
+
+# define DECLARE_COMPILED_DATA(name, decl_data, data) \
+ static int \
+ DEFUN_VOID (dload_initialize_data) \
{ \
- void EXFUN (decl, (void)); \
- SCHEME_OBJECT * EXFUN (code, (SCHEME_OBJECT *)); \
+ int EXFUN (decl_data, (void)); \
+ SCHEME_OBJECT * EXFUN (data, (unsigned long)); \
+ \
+ return (declare_compiled_data (name, decl_data, data)); \
+ }
+
+# define DECLARE_DYNAMIC_INITIALIZATION() \
+ extern int EXFUN (dload_initialize_file, (void)); \
\
- declare_compiled_code (string, decl, code); \
+ int \
+ DEFUN_VOID (dload_initialize_file) \
+ { \
+ int result = (dload_initialize_code ()); \
+ if (result != 0) \
+ return (result); \
+ return (dload_initialize_data ()); \
}
#endif /* COMPILE_FOR_DYNAMIC_LOADING */
extern RCONSM_TYPE(rconsm);
extern int
+ EXFUN (multiply_with_overflow, (long, long, long *)),
EXFUN (declare_compiled_code,
(char *,
- void EXFUN ((*), (void)),
- SCHEME_OBJECT * EXFUN ((*), (SCHEME_OBJECT *)))),
- EXFUN (multiply_with_overflow, (long, long, long *));
+ unsigned long,
+ int EXFUN ((*), (void)),
+ SCHEME_OBJECT * EXFUN ((*), (SCHEME_OBJECT *, unsigned long)))),
+ EXFUN (declare_compiled_data,
+ (char *,
+ int EXFUN ((*), (void)),
+ SCHEME_OBJECT * EXFUN ((*), (unsigned long)))),
+ EXFUN (NO_SUBBLOCKS, (void));
extern SCHEME_OBJECT
EXFUN (initialize_subblock, (char *)),
- * EXFUN (invoke_utility, (int, long, long, long, long));
-
-extern void
- EXFUN (NO_SUBBLOCKS, (void)),
- EXFUN (lose_big, (char *)),
- EXFUN (error_band_already_built, (void));
+ * EXFUN (invoke_utility, (int, long, long, long, long));
extern double
EXFUN (acos, (double)),
/* -*-C-*-
-$Id: ymkfile,v 1.81 1993/10/27 20:40:36 gjr Exp $
+$Id: ymkfile,v 1.82 1993/10/30 03:01:57 gjr Exp $
Copyright (c) 1989-1993 Massachusetts Institute of Technology
rm -f $@
fgrep DECLARE_COMPILED_CODE liarc.tch $(COMPILED_SOURCES) | \
sed -e 's/.*:/ /' -e 's/)/);/' > $@
+ fgrep DECLARE_COMPILED_DATA liarc.tch $(COMPILED_SOURCES) | \
+ sed -e 's/.*:/ /' -e 's/)/);/' >> $@
foo $(COMPILED_OBJECTS) : liarc.tch
liarc.tch: liarc.h $(LIARC_HEAD_FILES)
/* -*-C-*-
-$Id: cmpint.c,v 1.73 1993/10/26 02:57:43 gjr Exp $
+$Id: cmpint.c,v 1.74 1993/10/30 03:04:27 gjr Exp $
Copyright (c) 1989-1993 Massachusetts Institute of Technology
extern void EXFUN (C_to_interface, (void *));
extern utility_result interface_to_C_hook;
-static long C_return_value;
+extern long C_return_value;
+long C_return_value;
/* Convenience macros */
UTE(comutil_compiled_code_bkpt), /* 0x3c */
UTE(comutil_compiled_closure_bkpt) /* 0x3d */
};
+
+extern long MAX_TRAMPOLINE;
+long MAX_TRAMPOLINE = ((sizeof (utility_table))
+ / (sizeof (utility_table_entry)));
\f
/* Support for trap handling. */
/* -*-C-*-
-$Id: liarc.h,v 1.6 1993/10/28 04:45:25 gjr Exp $
+$Id: liarc.h,v 1.7 1993/10/30 03:02:05 gjr Exp $
Copyright (c) 1992-1993 Massachusetts Institute of Technology
typedef union machine_word_u machine_word;
-#define ERROR_UNKNOWN_DISPATCH( pc ) lose_big ("Unknown tag.")
-
#define ADDRESS_UNITS_PER_OBJECT (sizeof (SCHEME_OBJECT))
#define ADDRESS_UNITS_PER_FLOAT (sizeof (double))
double num = (src); \
SCHEME_OBJECT * val; \
\
- ALIGN_FLOAT (free_pointer); \
- val = free_pointer; \
- free_pointer += (1 + (BYTES_TO_WORDS (sizeof (double)))); \
+ ALIGN_FLOAT (Rhp); \
+ val = Rhp; \
+ Rhp += (1 + (BYTES_TO_WORDS (sizeof (double)))); \
* val = (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, \
(BYTES_TO_WORDS (sizeof (double))))); \
(* ((double *) (val + 1))) = num; \
\f
#ifdef USE_GLOBAL_VARIABLES
-#define value_reg Val
-#define free_pointer Free
-#define register_block Regs
-#define stack_pointer Stack_Pointer
+#define Rvl Val
+#define Rhp Free
+#define Rrb Regs
+#define Rsp Stack_Pointer
#define DECLARE_VARIABLES() int unsed_variable_to_keep_C_happy
#define UNCACHE_VARIABLES() do {} while (0)
#define REGISTER register
-#define register_block Regs
+#define Rrb Regs
#define DECLARE_VARIABLES() \
-REGISTER SCHEME_OBJECT value_reg = Val; \
-REGISTER SCHEME_OBJECT * free_pointer = Free; \
-REGISTER SCHEME_OBJECT * stack_pointer = Stack_Pointer
+REGISTER SCHEME_OBJECT Rvl = Val; \
+REGISTER SCHEME_OBJECT * Rhp = Free; \
+REGISTER SCHEME_OBJECT * Rsp = Stack_Pointer
#define UNCACHE_VARIABLES() do \
{ \
- Stack_Pointer = stack_pointer; \
- Free = free_pointer; \
- Val = value_reg; \
+ Stack_Pointer = Rsp; \
+ Free = Rhp; \
+ Val = Rvl; \
} while (0)
#define CACHE_VARIABLES() do \
{ \
- value_reg = Val; \
- free_pointer = Free; \
- stack_pointer = Stack_Pointer; \
+ Rvl = Val; \
+ Rhp = Free; \
+ Rsp = Stack_Pointer; \
} while (0)
#endif /* USE_GLOBAL_VARIABLES */
-#define REPEAT_DISPATCH() do \
-{ \
- if ((LABEL_PROCEDURE (my_pc)) != current_C_proc) \
- { \
- UNCACHE_VARIABLES (); \
- return (my_pc); \
- } \
- /* fall through. */ \
-} while (0)
-
-#ifdef USE_SHORTCKT_JUMP
-
#define JUMP(destination) do \
{ \
- my_pc = (destination); \
- goto repeat_dispatch; \
+ Rpc = (destination); \
+ goto perform_dispatch; \
} while(0)
-#define JUMP_EXTERNAL(destination) do \
-{ \
- my_pc = (destination); \
- if ((LABEL_PROCEDURE (my_pc)) == current_C_proc) \
- { \
- CACHE_VARIABLES (); \
- goto perform_dispatch; \
- } \
- return (my_pc); \
-} while (0)
-
-#define JUMP_EXECUTE_CHACHE(entry) do \
-{ \
- my_pc = ((SCHEME_OBJECT *) current_block[entry]); \
- goto repeat_dispatch; \
-} while (0)
-
-#define POP_RETURN() goto pop_return_repeat_dispatch
-
-#define POP_RETURN_REPEAT_DISPATCH() do \
-{ \
- my_pc = (OBJECT_ADDRESS (*stack_pointer++)); \
- /* fall through to repeat_dispatch */ \
-} while (0)
-
-#else /* not USE_SHORTCKT_JUMP */
-
-#define JUMP(destination) do \
-{ \
- UNCACHE_VARIABLES (); \
- return (destination); \
-} while (0)
-
-#define JUMP_EXTERNAL(destination) return (destination)
-
-#define JUMP_EXECUTE_CHACHE(entry) do \
-{ \
- SCHEME_OBJECT* destination \
- = ((SCHEME_OBJECT *) current_block[entry]); \
- \
- JUMP (destination); \
-} while (0)
+#define JUMP_EXECUTE_CHACHE(label) \
+ JUMP ((SCHEME_OBJECT *) (current_block[label]))
-#define POP_RETURN() do \
-{ \
- SCHEME_OBJECT target = *stack_pointer++; \
- SCHEME_OBJECT destination = (OBJECT_ADDRESS (target)); \
- JUMP (destination); \
-} while (0)
+#define POP_RETURN() goto pop_return
-#define POP_RETURN_REPEAT_DISPATCH() do \
-{ \
-} while (0)
-
-#endif /* USE_SHORTCKT_JUMP */
-\f
#define INVOKE_PRIMITIVE(prim, nargs) do \
{ \
primitive = (prim); \
primitive_nargs = (nargs); \
goto invoke_primitive; \
} while (0)
-
+\f
#define INVOKE_PRIMITIVE_CODE() do \
{ \
SCHEME_OBJECT * destination; \
PRIMITIVE_APPLY (Val, primitive); \
POP_PRIMITIVE_FRAME (primitive_nargs); \
destination = (OBJECT_ADDRESS (STACK_POP ())); \
- JUMP_EXTERNAL (destination); \
+ CACHE_VARIABLES (); \
+ JUMP (destination); \
} while(0)
#define INVOKE_INTERFACE_CODE() do \
SCHEME_OBJECT * destination; \
\
UNCACHE_VARIABLES (); \
- destination = (invoke_utility (subtmp_code, subtmp_1, subtmp_2, \
- subtmp_3, subtmp_4)); \
- JUMP_EXTERNAL (destination); \
+ destination = (invoke_utility (utlarg_code, utlarg_1, utlarg_2, \
+ utlarg_3, utlarg_4)); \
+ CACHE_VARIABLES (); \
+ JUMP (destination); \
} while (0)
#define INVOKE_INTERFACE_4(code, one, two, three, four) do \
{ \
- subtmp_4 = ((long) (four)); \
- subtmp_3 = ((long) (three)); \
- subtmp_2 = ((long) (two)); \
- subtmp_1 = ((long) (one)); \
- subtmp_code = (code); \
+ utlarg_4 = ((long) (four)); \
+ utlarg_3 = ((long) (three)); \
+ utlarg_2 = ((long) (two)); \
+ utlarg_1 = ((long) (one)); \
+ utlarg_code = (code); \
goto invoke_interface_4; \
} while (0)
#define INVOKE_INTERFACE_3(code, one, two, three) do \
{ \
- subtmp_3 = ((long) (three)); \
- subtmp_2 = ((long) (two)); \
- subtmp_1 = ((long) (one)); \
- subtmp_code = (code); \
+ utlarg_3 = ((long) (three)); \
+ utlarg_2 = ((long) (two)); \
+ utlarg_1 = ((long) (one)); \
+ utlarg_code = (code); \
goto invoke_interface_3; \
} while (0)
#define INVOKE_INTERFACE_2(code, one, two) do \
{ \
- subtmp_2 = ((long) (two)); \
- subtmp_1 = ((long) (one)); \
- subtmp_code = (code); \
+ utlarg_2 = ((long) (two)); \
+ utlarg_1 = ((long) (one)); \
+ utlarg_code = (code); \
goto invoke_interface_2; \
} while (0)
#define INVOKE_INTERFACE_1(code, one) do \
{ \
- subtmp_1 = ((long) (one)); \
- subtmp_code = (code); \
+ utlarg_1 = ((long) (one)); \
+ utlarg_code = (code); \
goto invoke_interface_1; \
} while (0)
#define INVOKE_INTERFACE_0(code) do \
{ \
- subtmp_code = (code); \
+ utlarg_code = (code); \
goto invoke_interface_0; \
} while (0)
\f
: (((source1) >= 0) \
? (- ((source1) / (- (source2)))) \
: ((- (source1)) / (- (source2)))))
-\f
+
+#define INTERRUPT_CHECK(code, entry_point) do \
+{ \
+ if (((long) Rhp) >= ((long) (Rrb[REGBLOCK_MEMTOP]))) \
+ INVOKE_INTERFACE_1 (code, ¤t_block[entry_point]); \
+} while (0)
+
+#define DLINK_INTERRUPT_CHECK(code, entry_point) do \
+{ \
+ if (((long) Rhp) >= ((long) (Rrb[REGBLOCK_MEMTOP]))) \
+ INVOKE_INTERFACE_2 (code, ¤t_block[entry_point], Rdl); \
+} while (0)
+
#define CLOSURE_HEADER(offset) do \
{ \
- SCHEME_OBJECT * entry = ((SCHEME_OBJECT *) my_pc[1]); \
+ SCHEME_OBJECT * entry = ((SCHEME_OBJECT *) Rpc[1]); \
current_block = (entry - offset); \
- *--stack_pointer = (MAKE_POINTER_OBJECT (TC_COMPILED_ENTRY, my_pc)); \
+ *--Rsp = (MAKE_POINTER_OBJECT (TC_COMPILED_ENTRY, Rpc)); \
} while (0)
#define CLOSURE_INTERRUPT_CHECK(code) do \
{ \
- if (((long) free_pointer) \
- >= ((long) (register_block[REGBLOCK_MEMTOP]))) \
+ if (((long) Rhp) >= ((long) (Rrb[REGBLOCK_MEMTOP]))) \
INVOKE_INTERFACE_0 (code); \
} while (0)
+\f
+/* Linking and initialization */
-#define INTERRUPT_CHECK(code, entry_point) do \
+#define DECLARE_SUBCODE(name, nentries, decl_code, code) do \
{ \
- if (((long) free_pointer) \
- >= ((long) (register_block[REGBLOCK_MEMTOP]))) \
- INVOKE_INTERFACE_1 (code, ¤t_block[entry_point]); \
+ int result = (declare_compiled_code (name, nentries, \
+ decl_code, code)); \
+ \
+ if (result != 0) \
+ return (result); \
} while (0)
-#define DLINK_INTERRUPT_CHECK(code, entry_point) do \
+#define DECLARE_SUBDATA(name, decl_data, data) do \
{ \
- if (((long) free_pointer) \
- >= ((long) (register_block[REGBLOCK_MEMTOP]))) \
- INVOKE_INTERFACE_2 (code, ¤t_block[entry_point], \
- dynamic_link); \
+ int result = (declare_compiled_data (name, decl_data, data)); \
+ \
+ if (result != 0) \
+ return (result); \
} while (0)
-struct compiled_file
-{
- int number_of_procedures;
- char ** names;
- void * EXFUN ((**procs), (void));
-};
+#ifndef COMPILE_FOR_DYNAMIC_LOADING
/* This does nothing in the sources. */
-#ifndef COMPILE_FOR_DYNAMIC_LOADING
+# define DECLARE_COMPILED_CODE(name, nentries, decl_code, code) \
+ extern int EXFUN (decl_code, (void)); \
+ extern SCHEME_OBJECT * EXFUN (code, (SCHEME_OBJECT *, unsigned long));
-# define DECLARE_COMPILED_CODE(string, decl, code) \
- extern void EXFUN (decl, (void)); \
- extern SCHEME_OBJECT * EXFUN (code, (SCHEME_OBJECT *));
+# define DECLARE_COMPILED_DATA(name, decl_data, data) \
+ extern int EXFUN (decl_data, (void)); \
+ extern SCHEME_OBJECT * EXFUN (data, (unsigned long));
+
+# define DECLARE_DYNAMIC_INITIALIZATION()
#else /* COMPILE_FOR_DYNAMIC_LOADING */
-# define DECLARE_COMPILED_CODE(string, decl, code) \
- extern void EXFUN (dload_initialize_file, (void)); \
+# define DECLARE_COMPILED_CODE(name, nentries, decl_code, code) \
+ static int \
+ DEFUN_VOID (dload_initialize_code) \
+ { \
+ int EXFUN (decl_code, (void)); \
+ SCHEME_OBJECT * EXFUN (code, (SCHEME_OBJECT *, unsigned long)); \
\
- void \
- DEFUN_VOID (dload_initialize_file) \
+ return (declare_compiled_code (name, nentries, \
+ decl_code, code)); \
+ }
+
+# define DECLARE_COMPILED_DATA(name, decl_data, data) \
+ static int \
+ DEFUN_VOID (dload_initialize_data) \
{ \
- void EXFUN (decl, (void)); \
- SCHEME_OBJECT * EXFUN (code, (SCHEME_OBJECT *)); \
+ int EXFUN (decl_data, (void)); \
+ SCHEME_OBJECT * EXFUN (data, (unsigned long)); \
+ \
+ return (declare_compiled_data (name, decl_data, data)); \
+ }
+
+# define DECLARE_DYNAMIC_INITIALIZATION() \
+ extern int EXFUN (dload_initialize_file, (void)); \
\
- declare_compiled_code (string, decl, code); \
+ int \
+ DEFUN_VOID (dload_initialize_file) \
+ { \
+ int result = (dload_initialize_code ()); \
+ if (result != 0) \
+ return (result); \
+ return (dload_initialize_data ()); \
}
#endif /* COMPILE_FOR_DYNAMIC_LOADING */
extern RCONSM_TYPE(rconsm);
extern int
+ EXFUN (multiply_with_overflow, (long, long, long *)),
EXFUN (declare_compiled_code,
(char *,
- void EXFUN ((*), (void)),
- SCHEME_OBJECT * EXFUN ((*), (SCHEME_OBJECT *)))),
- EXFUN (multiply_with_overflow, (long, long, long *));
+ unsigned long,
+ int EXFUN ((*), (void)),
+ SCHEME_OBJECT * EXFUN ((*), (SCHEME_OBJECT *, unsigned long)))),
+ EXFUN (declare_compiled_data,
+ (char *,
+ int EXFUN ((*), (void)),
+ SCHEME_OBJECT * EXFUN ((*), (unsigned long)))),
+ EXFUN (NO_SUBBLOCKS, (void));
extern SCHEME_OBJECT
EXFUN (initialize_subblock, (char *)),
- * EXFUN (invoke_utility, (int, long, long, long, long));
-
-extern void
- EXFUN (NO_SUBBLOCKS, (void)),
- EXFUN (lose_big, (char *)),
- EXFUN (error_band_already_built, (void));
+ * EXFUN (invoke_utility, (int, long, long, long, long));
extern double
EXFUN (acos, (double)),
projects / mit-scheme.git / commitdiff