/* -*-C-*-
-$Id: bchdmp.c,v 9.73 1993/10/14 19:18:42 gjr Exp $
+$Id: bchdmp.c,v 9.74 1993/11/04 04:03:27 gjr Exp $
Copyright (c) 1987-1993 Massachusetts Institute of Technology
Primitive_GC (table_end - saved_free);
}
+#ifdef NATIVE_CODE_IS_C
+
+ /* Cannot dump C compiled code. */
+
+ if (compiled_code_present_p)
+ {
+ fasdump_exit (0);
+ signal_error_from_primitive (ERR_COMPILED_CODE_ERROR);
+ }
+
+#endif /* NATIVE_CODE_IS_C */
+
tsize = (table_end - table_start);
hlength = ((sizeof (SCHEME_OBJECT)) * tsize);
if (((lseek (dump_file,
hlength = ((sizeof (SCHEME_OBJECT)) * FASL_HEADER_LENGTH);
prepare_dump_header (header, dumped_object, length, dumped_object,
- 0, Constant_Space, tlength, tsize,
+ 0, Constant_Space, tlength, tsize, 0, 0,
compiled_code_present_p, false);
if (((lseek (dump_file, 0, 0)) == -1)
|| ((write (dump_file, ((char *) &header[0]), hlength)) != hlength))
}
}
\f
-extern SCHEME_OBJECT compiler_utilities;
+extern SCHEME_OBJECT
+ compiler_utilities,
+ * EXFUN (cons_c_code_table, (SCHEME_OBJECT *, SCHEME_OBJECT *, long *));
/* (DUMP-BAND PROCEDURE FILE-NAME)
Saves all of the heap and pure space on FILE-NAME. When the
DEFINE_PRIMITIVE ("DUMP-BAND", Prim_band_dump, 2, 2, 0)
{
- SCHEME_OBJECT Combination, *table_start, *table_end, *saved_free;
- long table_length;
- Boolean result;
+ SCHEME_OBJECT
+ Combination, * saved_free,
+ * prim_table_start, * prim_table_end,
+ * c_table_start, * c_table_end;
+ long
+ prim_table_length,
+ c_table_length;
+ Boolean result = false;
PRIMITIVE_HEADER (2);
Band_Dump_Permitted ();
(* Free) = (MAKE_POINTER_OBJECT (TC_LIST, (Free - 2)));
Free ++; /* Some compilers are TOO clever about this and increment Free
before calculating Free-2! */
- table_start = Free;
- table_end = (cons_whole_primitive_table (Free, Heap_Top, &table_length));
- if (table_end >= Heap_Top)
- result = false;
- else
+ prim_table_start = Free;
+ prim_table_end = (cons_whole_primitive_table (prim_table_start,
+ Heap_Top,
+ &prim_table_length));
+ if (prim_table_end >= Heap_Top)
+ goto done;
+
+ c_table_start = prim_table_end;
+ c_table_end = (cons_c_code_table (c_table_start, Heap_Top, &c_table_length));
+ if (c_table_end >= Heap_Top)
+ goto done;
+
{
SCHEME_OBJECT * faligned_heap, * faligned_constant;
CONST char * filename = ((CONST char *) (STRING_LOC ((ARG_REF (2)), 0)));
faligned_heap,
((long) (Free_Constant - faligned_constant)),
faligned_constant,
- table_start, table_length,
- ((long) (table_end - table_start)),
+ prim_table_start, prim_table_length,
+ ((long) (prim_table_end - prim_table_start)),
+ c_table_start, c_table_length,
+ ((long) (c_table_end - c_table_start)),
(compiler_utilities != SHARP_F), true));
OS_channel_close_noerror (dump_channel);
- if (!result)
+ if (! result)
OS_file_remove (filename);
}
+
+done:
Band_Dump_Exit_Hook ();
Free = saved_free;
PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (result));
/* -*-C-*-
-$Id: cmpint.c,v 1.75 1993/11/01 23:52:47 gjr Exp $
+$Id: cmpint.c,v 1.76 1993/11/04 04:03:35 gjr Exp $
Copyright (c) 1989-1993 Massachusetts Institute of Technology
EXFUN (compiled_with_interrupt_mask, (unsigned long,
SCHEME_OBJECT,
unsigned long)),
- EXFUN (compiled_with_stack_marker, (SCHEME_OBJECT));
+ EXFUN (compiled_with_stack_marker, (SCHEME_OBJECT)),
+ * EXFUN (cons_c_code_table, (SCHEME_OBJECT *, SCHEME_OBJECT *, long *));
+
+extern C_UTILITY Boolean
+ EXFUN (install_c_code_table, (SCHEME_OBJECT *, long));
extern C_UTILITY void
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)),
- EXFUN (declare_compiled_code_block, (SCHEME_OBJECT block));
+ EXFUN (declare_compiled_code_block, (SCHEME_OBJECT block));
extern C_TO_SCHEME long
EXFUN (enter_compiled_expression, (void)),
\f
#define COMPILER_UTILITIES_LENGTH ((2 * (TRAMPOLINE_ENTRY_SIZE + 1)) + 1)
-C_UTILITY void
-DEFUN (compiler_reset,
- (new_block),
- SCHEME_OBJECT new_block)
-{
- /* Called after a disk restore */
-
- if (((OBJECT_TYPE (new_block)) != TC_COMPILED_CODE_BLOCK)
- || ((OBJECT_TYPE (MEMORY_REF (new_block, 0))) != TC_MANIFEST_NM_VECTOR)
- || ((VECTOR_LENGTH (new_block)) != (COMPILER_UTILITIES_LENGTH - 1)))
- {
- extern void EXFUN (compiler_reset_error, (void));
-
- compiler_reset_error ();
- }
- else
- {
- compiler_utilities = new_block;
- compiler_reset_internal ();
- }
- return;
-}
-
C_UTILITY void
DEFUN (compiler_initialize, (fasl_p), long fasl_p)
{
return;
}
\f
+C_UTILITY void
+DEFUN (compiler_reset,
+ (new_block),
+ SCHEME_OBJECT new_block)
+{
+ /* Called after a disk restore */
+
+ if (((OBJECT_TYPE (new_block)) != TC_COMPILED_CODE_BLOCK)
+ || ((OBJECT_TYPE (MEMORY_REF (new_block, 0))) != TC_MANIFEST_NM_VECTOR)
+ || ((VECTOR_LENGTH (new_block)) != (COMPILER_UTILITIES_LENGTH - 1)))
+ {
+ extern void EXFUN (compiler_reset_error, (void));
+
+ compiler_reset_error ();
+ }
+ else
+ {
+ compiler_utilities = new_block;
+ compiler_reset_internal ();
+ }
+ return;
+}
+
+#ifndef NATIVE_CODE_IS_C
+
+SCHEME_OBJECT *
+DEFUN (cons_c_code_table, (start, limit, length),
+ SCHEME_OBJECT * start
+ AND SCHEME_OBJECT * limit
+ AND long * length)
+{
+ * length = 0;
+ return (start);
+}
+
+Boolean
+DEFUN (install_c_code_table, (table, length),
+ SCHEME_OBJECT * table AND long length)
+{
+ return (true);
+}
+
+#endif /* NATIVE_CODE_IS_C */
+\f
#else /* not HAS_COMPILER_SUPPORT */
/* Stubs for compiler utilities.
EXFUN (compiled_with_interrupt_mask, (unsigned long,
SCHEME_OBJECT,
unsigned long)),
- EXFUN (compiled_with_stack_marker, (SCHEME_OBJECT));
+ EXFUN (compiled_with_stack_marker, (SCHEME_OBJECT)),
+ * EXFUN (cons_c_code_table, (SCHEME_OBJECT *, SCHEME_OBJECT *, long *));
+
+extern Boolean
+ EXFUN (install_c_code_table, (SCHEME_OBJECT *, long));
extern void
EXFUN (compiler_reset, (SCHEME_OBJECT new_block)),
signal_error_from_primitive (ERR_INAPPLICABLE_CONTINUATION);
/*NOTREACHED*/
}
+
+SCHEME_OBJECT *
+DEFUN (cons_c_code_table, (start, limit, length),
+ SCHEME_OBJECT * start
+ AND SCHEME_OBJECT * limit
+ AND long * length)
+{
+ * length = 0;
+ return (start);
+}
+
+Boolean
+DEFUN (install_c_code_table, (table, length),
+ SCHEME_OBJECT * table AND long length)
+{
+ return (true);
+}
\f
/* Bad entry points. */
/* NOP entry points */
void
-DEFUN (compiler_reset,
- (new_block),
- SCHEME_OBJECT new_block)
+DEFUN (compiler_reset, (new_block), SCHEME_OBJECT new_block)
{
extern void EXFUN (compiler_reset_error, (void));
if (new_block != SHARP_F)
- {
compiler_reset_error ();
- }
return;
}
/* -*-C-*-
-$Id: dump.c,v 9.36 1993/02/18 05:14:02 gjr Exp $
+$Id: dump.c,v 9.37 1993/11/04 04:03:02 gjr Exp $
Copyright (c) 1987-1993 Massachusetts Institute of Technology
#endif /* PSBMAP_H_INCLUDED */
void
-DEFUN (prepare_dump_header,
- (Buffer, Dumped_Object,
- Heap_Count, Heap_Relocation,
- Constant_Count, Constant_Relocation,
- table_length, table_size,
- cc_code_p, band_p),
- SCHEME_OBJECT *Buffer AND
- SCHEME_OBJECT *Dumped_Object AND
- long Heap_Count AND
- SCHEME_OBJECT *Heap_Relocation AND
- long Constant_Count AND
- SCHEME_OBJECT *Constant_Relocation AND
- long table_length AND
- long table_size AND
- Boolean cc_code_p AND
- Boolean band_p)
+DEFUN (prepare_dump_header, (Buffer, Dumped_Object,
+ Heap_Count, Heap_Relocation,
+ Constant_Count, Constant_Relocation,
+ table_length, table_size,
+ cc_code_p, band_p),
+ SCHEME_OBJECT * Buffer
+ AND SCHEME_OBJECT * Dumped_Object
+ AND long Heap_Count
+ AND SCHEME_OBJECT * Heap_Relocation
+ AND long Constant_Count
+ AND SCHEME_OBJECT * Constant_Relocation
+ AND long prim_table_length
+ AND long prim_table_size
+ AND long c_table_length
+ AND long c_table_size
+ AND Boolean cc_code_p
+ AND Boolean band_p)
{
long i;
#else
MAKE_POINTER_OBJECT (TC_BROKEN_HEART, Stack_Top);
#endif /* USE_STACKLETS */
-
+\f
Buffer[FASL_Offset_Prim_Length] =
- MAKE_OBJECT (TC_BROKEN_HEART, table_length);
+ MAKE_OBJECT (TC_BROKEN_HEART, prim_table_length);
Buffer[FASL_Offset_Prim_Size] =
- MAKE_OBJECT (TC_BROKEN_HEART, table_size);
-\f
+ MAKE_OBJECT (TC_BROKEN_HEART, prim_table_size);
+
if (cc_code_p)
{
Buffer[FASL_Offset_Ci_Version] =
Buffer[FASL_Offset_Ut_Base] = SHARP_F;
}
+ Buffer[FASL_Offset_C_Length] =
+ MAKE_OBJECT (TC_BROKEN_HEART, prim_table_length);
+ Buffer[FASL_Offset_C_Size] =
+ MAKE_OBJECT (TC_BROKEN_HEART, prim_table_size);
+
Buffer[FASL_Offset_Check_Sum] = SHARP_F;
for (i = FASL_Offset_First_Free; i < FASL_HEADER_LENGTH; i++)
- {
Buffer[i] = SHARP_F;
- }
return;
}
\f
EXFUN (checksum_area, (unsigned long *, long, unsigned long));
Boolean
-DEFUN (Write_File,
- (Dumped_Object, Heap_Count, Heap_Relocation,
- Constant_Count, Constant_Relocation,
- table_start, table_length, table_size,
- cc_code_p, band_p),
- SCHEME_OBJECT *Dumped_Object
+DEFUN (Write_File, (Dumped_Object, Heap_Count, Heap_Relocation,
+ Constant_Count, Constant_Relocation,
+ prim_table_start, prim_table_length, prim_table_size,
+ c_table_start, c_table_length, c_table_size,
+ cc_code_p, band_p),
+ SCHEME_OBJECT * Dumped_Object
AND long Heap_Count
- AND SCHEME_OBJECT *Heap_Relocation
+ AND SCHEME_OBJECT * Heap_Relocation
AND long Constant_Count
- AND SCHEME_OBJECT *Constant_Relocation
- AND SCHEME_OBJECT *table_start
- AND long table_length
- AND long table_size
+ AND SCHEME_OBJECT * Constant_Relocation
+ AND SCHEME_OBJECT * prim_table_start
+ AND long prim_table_length
+ AND long prim_table_size
+ AND SCHEME_OBJECT * c_table_start
+ AND long c_table_length
+ AND long c_table_size
AND Boolean cc_code_p
AND Boolean band_p)
{
prepare_dump_header (Buffer, Dumped_Object,
Heap_Count, Heap_Relocation,
Constant_Count, Constant_Relocation,
- table_length, table_size, cc_code_p, band_p);
+ prim_table_length, prim_table_size,
+ c_table_length, c_table_size,
+ cc_code_p, band_p);
/* This is not done in prepare_dump_header because it doesn't
work when prepare_dump_header is invoked from bchdmp.
checksum = (checksum_area (((unsigned long *) Constant_Relocation),
Constant_Count,
checksum));
- checksum = (checksum_area (((unsigned long *) table_start),
- table_size,
+ checksum = (checksum_area (((unsigned long *) prim_table_start),
+ prim_table_size,
checksum));
+ checksum = (checksum_area (((unsigned long *) c_table_start),
+ c_table_size,
+ checksum));
+
Buffer[FASL_Offset_Check_Sum] = checksum;
+\f
+ if ((Write_Data (FASL_HEADER_LENGTH, Buffer))
+ != FASL_HEADER_LENGTH)
+ return (false);
- if ((Write_Data (FASL_HEADER_LENGTH, Buffer)) !=
- FASL_HEADER_LENGTH)
- {
+ if ((Heap_Count != 0)
+ && ((Write_Data (Heap_Count, Heap_Relocation))
+ != Heap_Count))
return (false);
- }
- if (Heap_Count != 0)
- {
- if ((Write_Data (Heap_Count, Heap_Relocation)) !=
- Heap_Count)
- {
- return (false);
- }
- }
- if (Constant_Count != 0)
- {
- if ((Write_Data (Constant_Count, Constant_Relocation)) !=
- Constant_Count)
- {
+
+ if ((Constant_Count != 0)
+ && ((Write_Data (Constant_Count, Constant_Relocation))
+ != Constant_Count))
+ return (false);
+
+ if ((prim_table_size != 0)
+ && ((Write_Data (prim_table_size, prim_table_start))
+ != prim_table_size))
return (false);
- }
- }
- if (table_size != 0)
- {
- if ((Write_Data (table_size, table_start)) !=
- table_size)
- {
+
+ if ((c_table_size != 0)
+ && ((Write_Data (c_table_size, c_table_start))
+ != c_table_size))
return (false);
- }
- }
+
return (true);
}
-\f
+
unsigned long
DEFUN (checksum_area, (start, count, initial_value),
register unsigned long * start
value = initial_value;
while ((--count) >= 0)
- {
value = (value ^ (*start++));
- }
return (value);
}
/* -*-C-*-
-$Id: fasdump.c,v 9.57 1993/10/14 19:18:15 gjr Exp $
+$Id: fasdump.c,v 9.58 1993/11/04 04:03:07 gjr Exp $
Copyright (c) 1987-1993 Massachusetts Institute of Technology
* EXFUN (initialize_primitive_table, (SCHEME_OBJECT *, SCHEME_OBJECT *)),
* EXFUN (cons_primitive_table, (SCHEME_OBJECT *, SCHEME_OBJECT *, long *)),
* EXFUN (cons_whole_primitive_table,
- (SCHEME_OBJECT *, SCHEME_OBJECT *, long *));
+ (SCHEME_OBJECT *, SCHEME_OBJECT *, long *)),
+ * EXFUN (cons_c_code_table, (SCHEME_OBJECT *, SCHEME_OBJECT *, long *));
\f
/* Some statics used freely in this file */
{ \
Transport_Compiled(); \
if ((mode == 2) && ((OBJECT_TYPE (*(To - 1))) == TC_ENVIRONMENT)) \
- { \
*(To - 1) = SHARP_F; \
- } \
}
#define Dump_Compiled_Entry(label) \
{
case TC_PRIMITIVE:
case TC_PCOMB0:
- *Scan = dump_renumber_primitive(*Scan);
+ * Scan = (dump_renumber_primitive (* Scan));
break;
case TC_BROKEN_HEART:
compiled_code_present_p = true;
Dump_Compiled_Entry (after_entry);
after_entry:
- *Scan = Temp;
+ * Scan = Temp;
break;
case TC_MANIFEST_CLOSURE:
{
fast long count;
- fast char *word_ptr;
- SCHEME_OBJECT *area_end;
+ fast char * word_ptr;
+ SCHEME_OBJECT * area_end;
compiled_code_present_p = true;
START_CLOSURE_RELOCATION (Scan);
case GLOBAL_OPERATOR_LINKAGE_KIND:
{
fast long count;
- fast char *word_ptr;
- SCHEME_OBJECT *end_scan;
+ fast char * word_ptr;
+ SCHEME_OBJECT * end_scan;
START_OPERATOR_RELOCATION (Scan);
count = (READ_OPERATOR_LINKAGE_COUNT (Temp));
Fixes = Fixup;
if (close_p)
- {
OS_channel_close_noerror (dump_channel);
- }
+
result = true;
while (Fixes != NewMemTop)
{
}
Fixup = Fixes;
if ((close_p) && ((!result) || (code != PRIM_DONE)))
- {
OS_file_remove (dump_file_name);
- }
+
dump_file_name = ((char *) 0);
Fasdump_Exit_Hook ();
if (!result)
/*NOTREACHED*/
}
if (code == PRIM_DONE)
- {
return (SHARP_T);
- }
else if (code == PRIM_INTERRUPT)
- {
return (SHARP_F);
- }
else
{
signal_error_from_primitive (code);
Tchannel channel;
Boolean arg_string_p;
SCHEME_OBJECT Object, *New_Object, arg2, flag;
- SCHEME_OBJECT *table_start, *table_end;
- long Length, table_length;
+ SCHEME_OBJECT * prim_table_start, * prim_table_end;
+ long Length, prim_table_length;
Boolean result;
PRIMITIVE_HEADER (3);
arg2 = (ARG_REF (2));
arg_string_p = (STRING_P (arg2));
if (!arg_string_p)
- {
channel = (arg_channel (2));
- }
flag = (ARG_REF (3));
compiled_code_present_p = false;
- table_end = &Free[(Space_Before_GC ())];
- table_start = (initialize_primitive_table (Free, table_end));
- if (table_start >= table_end)
- {
- Primitive_GC (table_start - Free);
- }
+ prim_table_end = &Free[(Space_Before_GC ())];
+ prim_table_start = (initialize_primitive_table (Free, prim_table_end));
+ if (prim_table_start >= prim_table_end)
+ Primitive_GC (prim_table_start - Free);
Fasdump_Free_Calc (NewFree, NewMemTop, Orig_New_Free);
Fixup = NewMemTop;
DUMPLOOP (New_Object,
((flag == SHARP_F) ? 0 : ((flag == SHARP_T) ? 1 : 2)));
Length = (NewFree - New_Object);
- table_start = NewFree;
- table_end = (cons_primitive_table (NewFree, Fixup, &table_length));
- if (table_end >= Fixup)
- {
+ prim_table_start = NewFree;
+ prim_table_end = (cons_primitive_table (NewFree, Fixup, &prim_table_length));
+ if (prim_table_end >= Fixup)
FASDUMP_INTERRUPT ();
- }
+
+#ifdef NATIVE_CODE_IS_C
+
+ /* Cannot dump C compiled code. */
+
+ if (compiled_code_present_p)
+ PRIMITIVE_RETURN (Fasdump_Exit (ERR_COMPILED_CODE_ERROR, false));
+
+#endif /* NATIVE_CODE_IS_C */
if (arg_string_p)
{
channel = (OS_open_dump_file (dump_file_name));
if (channel == NO_CHANNEL)
- {
PRIMITIVE_RETURN (Fasdump_Exit (ERR_ARG_2_BAD_RANGE, false));
- }
}
dump_channel = channel;
result = (Write_File (New_Object,
Length, New_Object,
0, Constant_Space,
- table_start, table_length,
- ((long) (table_end - table_start)),
+ prim_table_start, prim_table_length,
+ ((long) (prim_table_end - prim_table_start)),
+ prim_table_end, 0, 0,
compiled_code_present_p, false));
PRIMITIVE_RETURN (Fasdump_Exit ((result ? PRIM_DONE : PRIM_INTERRUPT),
DEFINE_PRIMITIVE ("DUMP-BAND", Prim_band_dump, 2, 2, 0)
{
- SCHEME_OBJECT Combination, *table_start, *table_end, *saved_free;
- long table_length;
- Boolean result;
+ SCHEME_OBJECT
+ Combination, * saved_free,
+ * prim_table_start, * prim_table_end,
+ * c_table_start, * c_table_end;
+ long
+ prim_table_length,
+ c_table_length;
+ Boolean result = false;
PRIMITIVE_HEADER (2);
Band_Dump_Permitted ();
(* Free) = (MAKE_POINTER_OBJECT (TC_LIST, (Free - 2)));
Free ++; /* Some compilers are TOO clever about this and increment Free
before calculating Free-2! */
- table_start = Free;
- table_end = (cons_whole_primitive_table (Free, Heap_Top, &table_length));
- if (table_end >= Heap_Top)
- result = false;
- else
+ prim_table_start = Free;
+ prim_table_end = (cons_whole_primitive_table (prim_table_start,
+ Heap_Top,
+ &prim_table_length));
+ if (prim_table_end >= Heap_Top)
+ goto done;
+
+ c_table_start = prim_table_end;
+ c_table_end = (cons_c_code_table (c_table_start, Heap_Top, &c_table_length));
+ if (c_table_end >= Heap_Top)
+ goto done;
+
{
SCHEME_OBJECT * faligned_heap, * faligned_constant;
CONST char * filename = ((CONST char *) (STRING_LOC ((ARG_REF (2)), 0)));
faligned_heap,
((long) (Free_Constant - faligned_constant)),
faligned_constant,
- table_start, table_length,
- ((long) (table_end - table_start)),
+ prim_table_start, prim_table_length,
+ ((long) (prim_table_end - prim_table_start)),
+ c_table_start, c_table_length,
+ ((long) (c_table_end - c_table_start)),
(compiler_utilities != SHARP_F), true));
OS_channel_close_noerror (dump_channel);
- if (!result)
+ if (! result)
OS_file_remove (filename);
}
+
+done:
Band_Dump_Exit_Hook ();
Free = saved_free;
PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (result));
/* -*-C-*-
-$Id: fasl.h,v 9.33 1993/02/15 02:51:22 gjr Exp $
+$Id: fasl.h,v 9.34 1993/11/04 04:02:49 gjr Exp $
Copyright (c) 1987-1993 Massachusetts Institute of Technology
#define FASL_Offset_Ci_Version 10 /* Version number for compiled code interface */
#define FASL_Offset_Ut_Base 11 /* Address of the utilities vector */
#define FASL_Offset_Check_Sum 12 /* Header and data checksum. */
+#define FASL_Offset_C_Length 13 /* Number of entries in the C code table */
+#define FASL_Offset_C_Size 14 /* Size of C code table in SCHEME_OBJECTs */
-#define FASL_Offset_First_Free 13 /* Used to clear header */
+#define FASL_Offset_First_Free 15 /* Used to clear header */
/* Aliases for backwards compatibility. */
#define SUBVERSION_MASK ((ONE << SUBVERSION_LENGTH) - 1)
#define The_Sub_Version(P) (((P) >> MACHINE_TYPE_LENGTH) & SUBVERSION_MASK)
#define The_Version(P) (OBJECT_TYPE (P))
+
#define Make_Version(V, S, M) \
MAKE_OBJECT ((V), ((((unsigned long) (S)) << MACHINE_TYPE_LENGTH) \
| (M))) \
#define CI_VERSION(P) (((P) >> (DATUM_LENGTH / 2)) & CI_MASK)
#define CI_PROCESSOR(P) ((P) & CI_MASK)
#define CI_BAND_P(P) ((OBJECT_TYPE (P)) == TC_TRUE)
+
#define MAKE_CI_VERSION(Band_p, Version, Processor_Type) \
MAKE_OBJECT (((Band_p) ? TC_TRUE : TC_NULL), \
- ((((unsigned long) (Version)) << (DATUM_LENGTH / 2)) \
- | (Processor_Type))) \
+ ((((unsigned long) (Version)) << (DATUM_LENGTH / 2)) \
+ | (Processor_Type))) \
\f
/* "Memorable" FASL versions -- ones where we modified something
and want to remain backwards compatible.
#define FASL_MERGED_PRIMITIVES 7
#define FASL_INTERFACE_VERSION 8
#define FASL_NEW_BIGNUMS 9
+#define FASL_C_CODE 10
/* Current parameters. Always used on output. */
#define FASL_FORMAT_VERSION FASL_FORMAT_ADDED_STACK
-#define FASL_SUBVERSION FASL_NEW_BIGNUMS
+#define FASL_SUBVERSION FASL_C_CODE
/*
The definitions below correspond to the ones above. They usually
*/
#ifndef FASL_READ_VERSION
-#define FASL_READ_VERSION FASL_FORMAT_VERSION
+#define FASL_READ_VERSION FASL_FORMAT_ADDED_STACK
#endif
#ifndef FASL_READ_SUBVERSION
-#define FASL_READ_SUBVERSION FASL_SUBVERSION
+#define FASL_READ_SUBVERSION FASL_NEW_BIGNUMS
#endif
/* These are for Bintopsb.
/* -*-C-*-
-$Id: fasload.c,v 9.73 1993/10/31 16:51:06 gjr Exp $
+$Id: fasload.c,v 9.74 1993/11/04 04:03:14 gjr Exp $
Copyright (c) 1987-1993 Massachusetts Institute of Technology
extern SCHEME_OBJECT * load_renumber_table;
extern SCHEME_OBJECT compiler_utilities;
-extern SCHEME_OBJECT EXFUN (intern_symbol, (SCHEME_OBJECT));
-extern void EXFUN (install_primitive_table, (SCHEME_OBJECT *, long));
-extern void EXFUN (compiler_reset_error, (void));
-extern void EXFUN (compiler_initialize, (long));
-extern void EXFUN (compiler_reset, (SCHEME_OBJECT));
+extern SCHEME_OBJECT
+ EXFUN (intern_symbol, (SCHEME_OBJECT));
+
+extern void
+ EXFUN (install_primitive_table, (SCHEME_OBJECT *, long)),
+ EXFUN (install_c_table, (SCHEME_OBJECT *, long)),
+ EXFUN (compiler_reset_error, (void)),
+ EXFUN (compiler_initialize, (long)),
+ EXFUN (compiler_reset, (SCHEME_OBJECT));
+
+extern Boolean
+ EXFUN (install_c_code_table, (SCHEME_OBJECT *, long));
#ifndef FLUSH_I_CACHE_REGION
# define FLUSH_I_CACHE_REGION(addr, nwords) NOP()
SET_MEMTOP (Heap_Top);
}
- heap_length = (Heap_Count + Primitive_Table_Size + Primitive_Table_Length);
+ heap_length = (Heap_Count
+ + Primitive_Table_Size
+ + Primitive_Table_Length
+ + C_Code_Table_Size);
\f
if (GC_Check (heap_length))
{
return;
}
\f
-static SCHEME_OBJECT *
-DEFUN (read_file_end, (mode), int mode)
+static void
+DEFUN (read_file_end, (mode, prim_table_ptr, c_code_table_ptr),
+ int mode
+ AND SCHEME_OBJECT ** prim_table_ptr
+ AND SCHEME_OBJECT ** c_code_table_ptr)
{
- SCHEME_OBJECT *table, *ignore;
+ SCHEME_OBJECT * prim_table, * c_code_table, * ignore;
extern unsigned long checksum_area ();
if ((Load_Data (Heap_Count, ((char *) Free))) != Heap_Count)
Free_Constant += Const_Count;
SET_CONSTANT_TOP ();
- table = Free;
- if ((Load_Data (Primitive_Table_Size, ((char *) Free)))
+ prim_table = Free;
+ if ((Load_Data (Primitive_Table_Size, ((char *) prim_table)))
!= Primitive_Table_Size)
{
if (mode != MODE_CHANNEL)
signal_error_from_primitive (ERR_IO_ERROR);
}
computed_checksum =
- (checksum_area (((unsigned long *) Free),
+ (checksum_area (((unsigned long *) prim_table),
Primitive_Table_Size,
computed_checksum));
- NORMALIZE_REGION (((char *) table), Primitive_Table_Size);
+ NORMALIZE_REGION (((char *) prim_table), Primitive_Table_Size);
Free += Primitive_Table_Size;
+ c_code_table = Free;
+ if ((C_Code_Table_Size != 0)
+ && ((Load_Data (C_Code_Table_Size, ((char *) c_code_table)))
+ != C_Code_Table_Size))
+ {
+ if (mode != MODE_CHANNEL)
+ OS_channel_close_noerror (load_channel);
+ signal_error_from_primitive (ERR_IO_ERROR);
+ }
+ computed_checksum =
+ (checksum_area (((unsigned long *) c_code_table),
+ C_Code_Table_Size,
+ computed_checksum));
+ NORMALIZE_REGION (((char *) c_code_table), C_Code_Table_Size);
+ Free += C_Code_Table_Size;
+
if (mode != MODE_CHANNEL)
OS_channel_close_noerror (load_channel);
- if ((computed_checksum != ((unsigned long) 0)) &&
- (dumped_checksum != SHARP_F))
+ if ((computed_checksum != ((unsigned long) 0))
+ && (dumped_checksum != SHARP_F))
signal_error_from_primitive (ERR_IO_ERROR);
- return (table);
+
+ * prim_table_ptr = prim_table;
+ * c_code_table_ptr = c_code_table;
+ return;
}
\f
/* Statics used by Relocate, below */
DEFUN (load_file, (mode), int mode)
{
SCHEME_OBJECT
- *Orig_Heap,
- *Constant_End, *Orig_Constant,
- *temp, *primitive_table;
+ * Orig_Heap,
+ * Constant_End, * Orig_Constant,
+ * temp, * primitive_table, * c_code_table;
/* Read File */
ALIGN_FLOAT (Free);
Orig_Heap = Free;
Orig_Constant = Free_Constant;
- primitive_table = (read_file_end (mode));
+ read_file_end (mode, &primitive_table, &c_code_table);
Constant_End = Free_Constant;
heap_relocation = (COMPUTE_RELOCATION (Orig_Heap, Heap_Base));
automagically: the utilities vector is part of the band.
*/
- if ((!band_p) && (dumped_utilities != SHARP_F))
+ if ((! band_p) && (dumped_utilities != SHARP_F))
{
if (compiler_utilities == SHARP_F)
signal_error_from_primitive (ERR_FASLOAD_COMPILED_MISMATCH);
Setup_For_String_Inversion ();
#endif
- /* Setup the primitive table */
+ /* Setup the primitive and C code tables */
install_primitive_table (primitive_table, Primitive_Table_Length);
+ if (! (install_c_code_table (c_code_table, C_Code_Table_Length)))
+ signal_error_from_primitive (ERR_FASLOAD_COMPILED_MISMATCH);
if ((mode != MODE_BAND)
|| (heap_relocation != ((relocation_type) 0))
/* -*-C-*-
-$Id: load.c,v 9.32 1993/06/24 07:08:53 gjr Exp $
+$Id: load.c,v 9.33 1993/11/04 04:02:56 gjr Exp $
-Copyright (c) 1987-92 Massachusetts Institute of Technology
+Copyright (c) 1987-1993 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
Const_Base, Const_Count,
Dumped_Heap_Top, Dumped_Constant_Top,
Primitive_Table_Size, Primitive_Table_Length,
+ C_Code_Table_Size, C_Code_Table_Length,
dumped_processor_type, dumped_interface_version;
static unsigned long
printf ("Machine = %ld; Version = %ld; Subversion = %ld\n",
Machine_Type, Version, Sub_Version);
if ((dumped_processor_type != 0) || (dumped_interface_version != 0))
- {
printf ("Compiled code interface version = %ld; Processor type = %ld\n",
dumped_interface_version, dumped_processor_type);
- }
if (band_p)
- {
printf ("The file contains a dumped image (band).\n");
- }
printf ("\nRelocation Information:\n\n");
printf ("Heap Count = %ld; Heap Base = 0x%lx; Heap Top = 0x%lx\n",
printf ("Dumped object at 0x%lx (as read from file)\n", Dumped_Object);
printf ("Compiled code utilities vector = 0x%lx\n", dumped_utilities);
if (Ext_Prim_Vector != SHARP_F)
- {
printf ("External primitives vector = 0x%lx\n", Ext_Prim_Vector);
- }
else
- {
printf ("Length of primitive table = %ld\n", Primitive_Table_Length);
- }
+ printf ("Length of C table = %ld\n", C_Code_Table_Length);
printf ("Checksum = 0x%lx\n", dumped_checksum);
return;
}
SCHEME_OBJECT Pointer_Heap_Base, Pointer_Const_Base;
if (buffer[FASL_Offset_Marker] != FASL_FILE_MARKER)
- {
return (FASL_FILE_NOT_FASL);
- }
+
NORMALIZE_HEADER (buffer,
(sizeof(buffer) / sizeof(SCHEME_OBJECT)),
buffer[FASL_Offset_Heap_Base],
}
else
{
- Primitive_Table_Length = OBJECT_DATUM (buffer[FASL_Offset_Prim_Length]);
- Primitive_Table_Size = OBJECT_DATUM (buffer[FASL_Offset_Prim_Size]);
+ Primitive_Table_Length = (OBJECT_DATUM (buffer[FASL_Offset_Prim_Length]));
+ Primitive_Table_Size = (OBJECT_DATUM (buffer[FASL_Offset_Prim_Size]));
Ext_Prim_Vector = SHARP_F;
}
}
else
{
- SCHEME_OBJECT temp;
+ SCHEME_OBJECT temp = buffer[FASL_Offset_Ci_Version];
- temp = buffer[FASL_Offset_Ci_Version];
-
- band_p = CI_BAND_P(temp);
- dumped_processor_type = CI_PROCESSOR(temp);
- dumped_interface_version = CI_VERSION(temp);
+ band_p = (CI_BAND_P (temp));
+ dumped_processor_type = (CI_PROCESSOR (temp));
+ dumped_interface_version = (CI_VERSION (temp));
dumped_utilities = buffer[FASL_Offset_Ut_Base];
}
+
+ if (Sub_Version < FASL_C_CODE)
+ {
+ C_Code_Table_Length = 0;
+ C_Code_Table_Size = 0;
+ }
+ else
+ {
+ C_Code_Table_Length = (OBJECT_DATUM (buffer[FASL_Offset_C_Length]));
+ C_Code_Table_Size = (OBJECT_DATUM (buffer[FASL_Offset_C_Length]));
+ }
\f
#ifndef INHIBIT_FASL_VERSION_CHECK
/* The error messages here should be handled by the runtime system! */
(checksum_area (((unsigned long *) &buffer[0]),
((long) (FASL_HEADER_LENGTH)),
((unsigned long) 0)));
-
}
#endif /* INHIBIT_CHECKSUMS */
if ((Load_Data (FASL_HEADER_LENGTH, header)) !=
FASL_HEADER_LENGTH)
- {
return (FASL_FILE_TOO_SHORT);
- }
return (initialize_variables_from_fasl_header (&header[0]));
}
\f
/* -*-C-*-
-$Id: cmpint.c,v 1.75 1993/11/01 23:52:47 gjr Exp $
+$Id: cmpint.c,v 1.76 1993/11/04 04:03:35 gjr Exp $
Copyright (c) 1989-1993 Massachusetts Institute of Technology
EXFUN (compiled_with_interrupt_mask, (unsigned long,
SCHEME_OBJECT,
unsigned long)),
- EXFUN (compiled_with_stack_marker, (SCHEME_OBJECT));
+ EXFUN (compiled_with_stack_marker, (SCHEME_OBJECT)),
+ * EXFUN (cons_c_code_table, (SCHEME_OBJECT *, SCHEME_OBJECT *, long *));
+
+extern C_UTILITY Boolean
+ EXFUN (install_c_code_table, (SCHEME_OBJECT *, long));
extern C_UTILITY void
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)),
- EXFUN (declare_compiled_code_block, (SCHEME_OBJECT block));
+ EXFUN (declare_compiled_code_block, (SCHEME_OBJECT block));
extern C_TO_SCHEME long
EXFUN (enter_compiled_expression, (void)),
\f
#define COMPILER_UTILITIES_LENGTH ((2 * (TRAMPOLINE_ENTRY_SIZE + 1)) + 1)
-C_UTILITY void
-DEFUN (compiler_reset,
- (new_block),
- SCHEME_OBJECT new_block)
-{
- /* Called after a disk restore */
-
- if (((OBJECT_TYPE (new_block)) != TC_COMPILED_CODE_BLOCK)
- || ((OBJECT_TYPE (MEMORY_REF (new_block, 0))) != TC_MANIFEST_NM_VECTOR)
- || ((VECTOR_LENGTH (new_block)) != (COMPILER_UTILITIES_LENGTH - 1)))
- {
- extern void EXFUN (compiler_reset_error, (void));
-
- compiler_reset_error ();
- }
- else
- {
- compiler_utilities = new_block;
- compiler_reset_internal ();
- }
- return;
-}
-
C_UTILITY void
DEFUN (compiler_initialize, (fasl_p), long fasl_p)
{
return;
}
\f
+C_UTILITY void
+DEFUN (compiler_reset,
+ (new_block),
+ SCHEME_OBJECT new_block)
+{
+ /* Called after a disk restore */
+
+ if (((OBJECT_TYPE (new_block)) != TC_COMPILED_CODE_BLOCK)
+ || ((OBJECT_TYPE (MEMORY_REF (new_block, 0))) != TC_MANIFEST_NM_VECTOR)
+ || ((VECTOR_LENGTH (new_block)) != (COMPILER_UTILITIES_LENGTH - 1)))
+ {
+ extern void EXFUN (compiler_reset_error, (void));
+
+ compiler_reset_error ();
+ }
+ else
+ {
+ compiler_utilities = new_block;
+ compiler_reset_internal ();
+ }
+ return;
+}
+
+#ifndef NATIVE_CODE_IS_C
+
+SCHEME_OBJECT *
+DEFUN (cons_c_code_table, (start, limit, length),
+ SCHEME_OBJECT * start
+ AND SCHEME_OBJECT * limit
+ AND long * length)
+{
+ * length = 0;
+ return (start);
+}
+
+Boolean
+DEFUN (install_c_code_table, (table, length),
+ SCHEME_OBJECT * table AND long length)
+{
+ return (true);
+}
+
+#endif /* NATIVE_CODE_IS_C */
+\f
#else /* not HAS_COMPILER_SUPPORT */
/* Stubs for compiler utilities.
EXFUN (compiled_with_interrupt_mask, (unsigned long,
SCHEME_OBJECT,
unsigned long)),
- EXFUN (compiled_with_stack_marker, (SCHEME_OBJECT));
+ EXFUN (compiled_with_stack_marker, (SCHEME_OBJECT)),
+ * EXFUN (cons_c_code_table, (SCHEME_OBJECT *, SCHEME_OBJECT *, long *));
+
+extern Boolean
+ EXFUN (install_c_code_table, (SCHEME_OBJECT *, long));
extern void
EXFUN (compiler_reset, (SCHEME_OBJECT new_block)),
signal_error_from_primitive (ERR_INAPPLICABLE_CONTINUATION);
/*NOTREACHED*/
}
+
+SCHEME_OBJECT *
+DEFUN (cons_c_code_table, (start, limit, length),
+ SCHEME_OBJECT * start
+ AND SCHEME_OBJECT * limit
+ AND long * length)
+{
+ * length = 0;
+ return (start);
+}
+
+Boolean
+DEFUN (install_c_code_table, (table, length),
+ SCHEME_OBJECT * table AND long length)
+{
+ return (true);
+}
\f
/* Bad entry points. */
/* NOP entry points */
void
-DEFUN (compiler_reset,
- (new_block),
- SCHEME_OBJECT new_block)
+DEFUN (compiler_reset, (new_block), SCHEME_OBJECT new_block)
{
extern void EXFUN (compiler_reset_error, (void));
if (new_block != SHARP_F)
- {
compiler_reset_error ();
- }
return;
}
/* -*-C-*-
-$Id: fasl.h,v 9.33 1993/02/15 02:51:22 gjr Exp $
+$Id: fasl.h,v 9.34 1993/11/04 04:02:49 gjr Exp $
Copyright (c) 1987-1993 Massachusetts Institute of Technology
#define FASL_Offset_Ci_Version 10 /* Version number for compiled code interface */
#define FASL_Offset_Ut_Base 11 /* Address of the utilities vector */
#define FASL_Offset_Check_Sum 12 /* Header and data checksum. */
+#define FASL_Offset_C_Length 13 /* Number of entries in the C code table */
+#define FASL_Offset_C_Size 14 /* Size of C code table in SCHEME_OBJECTs */
-#define FASL_Offset_First_Free 13 /* Used to clear header */
+#define FASL_Offset_First_Free 15 /* Used to clear header */
/* Aliases for backwards compatibility. */
#define SUBVERSION_MASK ((ONE << SUBVERSION_LENGTH) - 1)
#define The_Sub_Version(P) (((P) >> MACHINE_TYPE_LENGTH) & SUBVERSION_MASK)
#define The_Version(P) (OBJECT_TYPE (P))
+
#define Make_Version(V, S, M) \
MAKE_OBJECT ((V), ((((unsigned long) (S)) << MACHINE_TYPE_LENGTH) \
| (M))) \
#define CI_VERSION(P) (((P) >> (DATUM_LENGTH / 2)) & CI_MASK)
#define CI_PROCESSOR(P) ((P) & CI_MASK)
#define CI_BAND_P(P) ((OBJECT_TYPE (P)) == TC_TRUE)
+
#define MAKE_CI_VERSION(Band_p, Version, Processor_Type) \
MAKE_OBJECT (((Band_p) ? TC_TRUE : TC_NULL), \
- ((((unsigned long) (Version)) << (DATUM_LENGTH / 2)) \
- | (Processor_Type))) \
+ ((((unsigned long) (Version)) << (DATUM_LENGTH / 2)) \
+ | (Processor_Type))) \
\f
/* "Memorable" FASL versions -- ones where we modified something
and want to remain backwards compatible.
#define FASL_MERGED_PRIMITIVES 7
#define FASL_INTERFACE_VERSION 8
#define FASL_NEW_BIGNUMS 9
+#define FASL_C_CODE 10
/* Current parameters. Always used on output. */
#define FASL_FORMAT_VERSION FASL_FORMAT_ADDED_STACK
-#define FASL_SUBVERSION FASL_NEW_BIGNUMS
+#define FASL_SUBVERSION FASL_C_CODE
/*
The definitions below correspond to the ones above. They usually
*/
#ifndef FASL_READ_VERSION
-#define FASL_READ_VERSION FASL_FORMAT_VERSION
+#define FASL_READ_VERSION FASL_FORMAT_ADDED_STACK
#endif
#ifndef FASL_READ_SUBVERSION
-#define FASL_READ_SUBVERSION FASL_SUBVERSION
+#define FASL_READ_SUBVERSION FASL_NEW_BIGNUMS
#endif
/* These are for Bintopsb.
projects / mit-scheme.git / commitdiff