/* -*-C-*- $Id: fasload.c,v 9.91 2001/12/16 06:01:32 cph Exp $ Copyright (c) 1987-2001 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., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ /* The "fast loader" which reads in and relocates binary files and then interns symbols. It is called with one argument: the (character string) name of a file to load. It is called as a primitive, and returns a single object read in. */ #include "scheme.h" #include "prims.h" #include "osscheme.h" #include "osfile.h" #include "osio.h" #include "gccode.h" #include "trap.h" #include "option.h" #include "prmcon.h" static Tchannel load_channel; #define Load_Data(size, buffer) \ ((long) \ ((OS_channel_read_load_file \ (load_channel, \ ((char *) (buffer)), \ ((size) * (sizeof (SCHEME_OBJECT))))) \ / (sizeof (SCHEME_OBJECT)))) #include "load.c" #ifdef STDC_HEADERS # include # include #else extern char * EXFUN (malloc, (int)); extern int EXFUN (strlen, (const char *)); extern char * EXFUN (strcpy, (char *, const char *)); #endif extern char * Error_Names []; extern char * Abort_Names []; 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)), EXFUN (compiler_reset_error, (void)), EXFUN (compiler_initialize, (long)), EXFUN (compiler_reset, (SCHEME_OBJECT)); extern Boolean EXFUN (install_c_code_table, (SCHEME_OBJECT *, long)); static long failed_heap_length = -1; #define MODE_BAND 0 #define MODE_CHANNEL 1 #define MODE_FNAME 2 static void DEFUN (read_channel_continue, (header, mode, repeat_p), SCHEME_OBJECT * header AND int mode AND Boolean repeat_p) { extern Boolean EXFUN (update_allocator_parameters, (SCHEME_OBJECT *)); long value, heap_length; value = (initialize_variables_from_fasl_header (header)); if (value != FASL_FILE_FINE) { if (mode != MODE_CHANNEL) OS_channel_close_noerror (load_channel); switch (value) { /* These may want to be separated further. */ case FASL_FILE_TOO_SHORT: case FASL_FILE_NOT_FASL: case FASL_FILE_BAD_MACHINE: case FASL_FILE_BAD_VERSION: case FASL_FILE_BAD_SUBVERSION: signal_error_from_primitive (ERR_FASL_FILE_BAD_DATA); /*NOTREACHED*/ case FASL_FILE_BAD_PROCESSOR: case FASL_FILE_BAD_INTERFACE: signal_error_from_primitive (ERR_FASLOAD_COMPILED_MISMATCH); /*NOTREACHED*/ } } if (Or2 (Reloc_Debug, File_Load_Debug)) print_fasl_information(); if (((mode == MODE_BAND) && (! (update_allocator_parameters (Free_Constant + Const_Count)))) || ((mode != MODE_BAND) && (! (TEST_CONSTANT_TOP (Free_Constant + Const_Count))))) { if (mode != MODE_CHANNEL) OS_channel_close_noerror (load_channel); signal_error_from_primitive (ERR_FASL_FILE_TOO_BIG); /*NOTREACHED*/ } if (mode == MODE_BAND) { SET_CONSTANT_TOP (); ALIGN_FLOAT (Free); SET_MEMTOP (Heap_Top); } heap_length = (Heap_Count + Primitive_Table_Size + Primitive_Table_Length + C_Code_Table_Size); if (GC_Check (heap_length)) { if (repeat_p || (heap_length == failed_heap_length) || (mode == MODE_BAND)) { if (mode != MODE_CHANNEL) OS_channel_close_noerror (load_channel); signal_error_from_primitive (ERR_FASL_FILE_TOO_BIG); /*NOTREACHED*/ } else if (mode == MODE_CHANNEL) { SCHEME_OBJECT reentry_record[1]; /* IMPORTANT: This KNOWS that it was called from BINARY-FASLOAD. If this is ever called from elsewhere with MODE_CHANNEL, it will have to be parameterized better. This reentry record must match the expectations of continue_fasload below. */ Request_GC (heap_length); /* This assumes that header == (Free + 1) */ header = Free; Free += (FASL_HEADER_LENGTH + 1); *header = (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, FASL_HEADER_LENGTH)); reentry_record[0] = (MAKE_POINTER_OBJECT (TC_NON_MARKED_VECTOR, header)); suspend_primitive (CONT_FASLOAD, ((sizeof (reentry_record)) / (sizeof (SCHEME_OBJECT))), &reentry_record[0]); immediate_interrupt (); /*NOTREACHED*/ } else { failed_heap_length = heap_length; OS_channel_close_noerror (load_channel); Request_GC (heap_length); signal_interrupt_from_primitive (); /*NOTREACHED*/ } } failed_heap_length = -1; if ((band_p) && (mode != MODE_BAND)) { if (mode != MODE_CHANNEL) OS_channel_close_noerror (load_channel); signal_error_from_primitive (ERR_FASLOAD_BAND); } return; } static void DEFUN (read_channel_start, (channel, mode), Tchannel channel AND int mode) { load_channel = channel; if (GC_Check (FASL_HEADER_LENGTH + 1)) { if (mode != MODE_CHANNEL) OS_channel_close_noerror (load_channel); Request_GC (FASL_HEADER_LENGTH + 1); signal_interrupt_from_primitive (); /* NOTREACHED */ } if ((Load_Data (FASL_HEADER_LENGTH, ((char *) (Stack_Bottom + 1)))) != FASL_HEADER_LENGTH) { if (mode != MODE_CHANNEL) OS_channel_close_noerror (load_channel); signal_error_from_primitive (ERR_FASL_FILE_BAD_DATA); } read_channel_continue ((Stack_Bottom + 1), mode, false); return; } static void DEFUN (read_file_start, (file_name, from_band_load), CONST char * file_name AND Boolean from_band_load) { Tchannel channel; channel = (OS_open_load_file (file_name)); if (Per_File) debug_edit_flags (); if (channel == NO_CHANNEL) error_bad_range_arg (1); read_channel_start (channel, (from_band_load ? MODE_BAND : MODE_FNAME)); return; } 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 * prim_table, * c_code_table; extern unsigned long checksum_area (); if ((Load_Data (Heap_Count, ((char *) Free))) != Heap_Count) { if (mode != MODE_CHANNEL) OS_channel_close_noerror (load_channel); signal_error_from_primitive (ERR_IO_ERROR); } computed_checksum = (checksum_area (((unsigned long *) Free), Heap_Count, computed_checksum)); NORMALIZE_REGION(((char *) Free), Heap_Count); Free += Heap_Count; if ((Load_Data (Const_Count, ((char *) Free_Constant))) != Const_Count) { SET_CONSTANT_TOP (); if (mode != MODE_CHANNEL) OS_channel_close_noerror (load_channel); signal_error_from_primitive (ERR_IO_ERROR); } computed_checksum = (checksum_area (((unsigned long *) Free_Constant), Const_Count, computed_checksum)); NORMALIZE_REGION (((char *) Free_Constant), Const_Count); Free_Constant += Const_Count; SET_CONSTANT_TOP (); prim_table = Free; if ((Load_Data (Primitive_Table_Size, ((char *) prim_table))) != Primitive_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 *) prim_table), Primitive_Table_Size, computed_checksum)); NORMALIZE_REGION (((char *) prim_table), Primitive_Table_Size); Free += Primitive_Table_Size; c_code_table = Free; * c_code_table = FIXNUM_ZERO; 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)) signal_error_from_primitive (ERR_IO_ERROR); * prim_table_ptr = prim_table; * c_code_table_ptr = c_code_table; return; } /* Statics used by Relocate, below */ relocation_type heap_relocation, const_relocation, stack_relocation; /* Relocate a pointer as read in from the file. If the pointer used to point into the heap, relocate it into the heap. If it used to be constant area, relocate it to constant area. Otherwise give an error. */ #ifdef ENABLE_DEBUGGING_TOOLS static Boolean Warned = false; static SCHEME_OBJECT * DEFUN (relocate, (P), long P) { SCHEME_OBJECT * Result; if ((P >= Heap_Base) && (P < Dumped_Heap_Top)) Result = ((SCHEME_OBJECT *) (P + heap_relocation)); else if ((P >= Const_Base) && (P < Dumped_Constant_Top)) Result = ((SCHEME_OBJECT *) (P + const_relocation)); else if ((P >= Dumped_Constant_Top) && (P < Dumped_Stack_Top)) Result = ((SCHEME_OBJECT *) (P + stack_relocation)); else { outf_console ("Pointer out of range: 0x%lx\n", P); if (!Warned) { outf_console ("Heap: %lx-%lx, Constant: %lx-%lx, Stack: ?-0x%lx\n", ((long) Heap_Base), ((long) Dumped_Heap_Top), ((long) Const_Base), ((long) Dumped_Constant_Top), ((long) Dumped_Stack_Top)); Warned = true; } Result = ((SCHEME_OBJECT *) 0); } if (Reloc_Debug) outf_console ("0x%06lx -> 0x%06lx\n", P, ((long) Result)); return (Result); } #define RELOCATE relocate #define RELOCATE_INTO(Loc, P) (Loc) = relocate(P) #else /* not ENABLE_DEBUGGING_TOOLS */ #define RELOCATE_INTO(Loc, P) do \ { \ long _P = (P); \ \ if ((P >= Heap_Base) && (_P < Dumped_Heap_Top)) \ (Loc) = ((SCHEME_OBJECT *) (_P + heap_relocation)); \ else if ((P >= Const_Base) && (_P < Dumped_Constant_Top)) \ (Loc) = ((SCHEME_OBJECT *) (_P + const_relocation)); \ else \ (Loc) = ((SCHEME_OBJECT *) (_P + stack_relocation)); \ } while (0) #ifndef Conditional_Bug #define RELOCATE(P) \ ((((P) >= Heap_Base) && ((P) < Dumped_Heap_Top)) \ ? ((SCHEME_OBJECT *) ((P) + heap_relocation)) \ : ((((P) >= Const_Base) && ((P) < Dumped_Constant_Top)) \ ? ((SCHEME_OBJECT *) ((P) + const_relocation)) \ : ((SCHEME_OBJECT *) ((P) + stack_relocation)))) #else /* Conditional_Bug */ static SCHEME_OBJECT * relocate_temp; #define RELOCATE(P) \ (RELOCATE_INTO (Relocate_Temp, P), relocate_temp) #endif /* Conditional_Bug */ #endif /* ENABLE_DEBUGGING_TOOLS */ /* Next_Pointer starts by pointing to the beginning of the block of memory to be handled. This loop relocates all pointers in the block of memory. */ static long DEFUN (primitive_dumped_number, (datum), unsigned long datum) { unsigned long high_bits = (datum >> HALF_DATUM_LENGTH); return ((high_bits != 0) ? high_bits : datum); } #define PRIMITIVE_DUMPED_NUMBER(prim) \ (primitive_dumped_number (OBJECT_DATUM (prim))) static void DEFUN (Relocate_Block, (Scan, Stop_At), fast SCHEME_OBJECT * Scan AND fast SCHEME_OBJECT * Stop_At) { fast long address; fast SCHEME_OBJECT Temp; if (Reloc_Debug) { outf_error ("\nRelocate_Block: block = 0x%lx, length = 0x%lx, end = 0x%lx.\n", ((long) Scan), ((long) ((Stop_At - Scan) - 1)), ((long) Stop_At)); } while (Scan < Stop_At) { Temp = * Scan; Switch_by_GC_Type (Temp) { case TC_BROKEN_HEART: case TC_MANIFEST_SPECIAL_NM_VECTOR: case_Fasload_Non_Pointer: #ifdef EMPTY_LIST_VALUE if (Temp == EMPTY_LIST_VALUE) * Scan = EMPTY_LIST; #endif Scan += 1; break; case TC_PRIMITIVE: *Scan++ = (load_renumber_table [PRIMITIVE_DUMPED_NUMBER (Temp)]); break; case TC_PCOMB0: *Scan++ = OBJECT_NEW_TYPE (TC_PCOMB0, (load_renumber_table [PRIMITIVE_DUMPED_NUMBER (Temp)])); break; case TC_MANIFEST_NM_VECTOR: Scan += ((OBJECT_DATUM (Temp)) + 1); break; case TC_LINKAGE_SECTION: { switch (READ_LINKAGE_KIND (Temp)) { case REFERENCE_LINKAGE_KIND: case ASSIGNMENT_LINKAGE_KIND: { /* Assumes that all others are objects of type TC_HUNK3 without their type codes. */ fast long count; Scan++; for (count = (READ_CACHE_LINKAGE_COUNT (Temp)); --count >= 0; ) { address = (SCHEME_ADDR_TO_OLD_DATUM (* Scan)); *Scan++ = (ADDR_TO_SCHEME_ADDR (RELOCATE (address))); } break; } case OPERATOR_LINKAGE_KIND: case GLOBAL_OPERATOR_LINKAGE_KIND: { fast long count; fast char * word_ptr; SCHEME_OBJECT * end_scan; START_OPERATOR_RELOCATION (Scan); count = (READ_OPERATOR_LINKAGE_COUNT (Temp)); word_ptr = (FIRST_OPERATOR_LINKAGE_ENTRY (Scan)); end_scan = (END_OPERATOR_LINKAGE_AREA (Scan, count)); while(--count >= 0) { Scan = ((SCHEME_OBJECT *) (word_ptr)); word_ptr = (NEXT_LINKAGE_OPERATOR_ENTRY (word_ptr)); EXTRACT_OPERATOR_LINKAGE_ADDRESS (address, Scan); address = (SCHEME_ADDR_TO_OLD_DATUM (address)); address = ((long) (RELOCATE (address))); STORE_OPERATOR_LINKAGE_ADDRESS ((ADDR_TO_SCHEME_ADDR (address)), Scan); } Scan = &end_scan[1]; END_OPERATOR_RELOCATION (Scan - 1); break; } case CLOSURE_PATTERN_LINKAGE_KIND: Scan += (1 + (READ_CACHE_LINKAGE_COUNT (Temp))); break; default: { gc_death (TERM_EXIT, "Relocate_Block: Unknown compiler linkage kind.", Scan, NULL); /*NOTREACHED*/ } } break; } case TC_MANIFEST_CLOSURE: { /* See comment about relocation in TC_LINKAGE_SECTION above. */ fast long count; fast char * word_ptr; SCHEME_OBJECT * area_end; START_CLOSURE_RELOCATION (Scan); Scan += 1; count = (MANIFEST_CLOSURE_COUNT (Scan)); word_ptr = (FIRST_MANIFEST_CLOSURE_ENTRY (Scan)); area_end = ((MANIFEST_CLOSURE_END (Scan, count)) - 1); while ((--count) >= 0) { Scan = ((SCHEME_OBJECT *) (word_ptr)); word_ptr = (NEXT_MANIFEST_CLOSURE_ENTRY (word_ptr)); EXTRACT_CLOSURE_ENTRY_ADDRESS (address, Scan); address = (SCHEME_ADDR_TO_OLD_DATUM (address)); address = ((long) (RELOCATE (address))); STORE_CLOSURE_ENTRY_ADDRESS ((ADDR_TO_SCHEME_ADDR (address)), Scan); } END_CLOSURE_RELOCATION (area_end); Scan = (area_end + 1); break; } #ifdef BYTE_INVERSION case TC_CHARACTER_STRING: String_Inversion (RELOCATE (OBJECT_DATUM (Temp))); goto normal_pointer; #endif case TC_REFERENCE_TRAP: if ((OBJECT_DATUM (Temp)) <= TRAP_MAX_IMMEDIATE) { Scan += 1; break; } /* It is a pointer, fall through. */ /* Compiled entry points and stack environments work automagically. */ /* This should be more strict. */ default: #ifdef BYTE_INVERSION normal_pointer: #endif address = (OBJECT_DATUM (Temp)); *Scan++ = (MAKE_POINTER_OBJECT ((OBJECT_TYPE (Temp)), (RELOCATE (address)))); break; } } return; } static Boolean DEFUN (check_primitive_numbers, (table, length), fast SCHEME_OBJECT * table AND fast long length) { fast long count; for (count = 0; count < length; count += 1) if (table[count] != (MAKE_PRIMITIVE_OBJECT (count))) return (false); return (true); } extern void EXFUN (get_band_parameters, (long * heap_size, long * const_size)); void DEFUN (get_band_parameters, (heap_size, const_size), long * heap_size AND long * const_size) { /* This assumes we have just aborted out of a band load. */ (*heap_size) = Heap_Count; (*const_size) = Const_Count; } static void DEFUN (Intern_Block, (Next_Pointer, Stop_At), fast SCHEME_OBJECT * Next_Pointer AND fast SCHEME_OBJECT * Stop_At) { if (Reloc_Debug) { outf_console ("Interning a block.\n"); } while (Next_Pointer < Stop_At) { switch (OBJECT_TYPE (*Next_Pointer)) { case TC_MANIFEST_NM_VECTOR: Next_Pointer += (1 + (OBJECT_DATUM (* Next_Pointer))); break; case TC_INTERNED_SYMBOL: if ((OBJECT_TYPE (MEMORY_REF (*Next_Pointer, SYMBOL_GLOBAL_VALUE))) == TC_BROKEN_HEART) { SCHEME_OBJECT old_symbol = (*Next_Pointer); MEMORY_SET (old_symbol, SYMBOL_GLOBAL_VALUE, UNBOUND_OBJECT); { SCHEME_OBJECT new_symbol = (intern_symbol (old_symbol)); if (new_symbol != old_symbol) { (*Next_Pointer) = new_symbol; MEMORY_SET (old_symbol, SYMBOL_NAME, (OBJECT_NEW_TYPE (TC_BROKEN_HEART, new_symbol))); } } } else if ((OBJECT_TYPE (MEMORY_REF (*Next_Pointer, SYMBOL_NAME))) == TC_BROKEN_HEART) { *Next_Pointer = (MAKE_OBJECT_FROM_OBJECTS ((*Next_Pointer), (FAST_MEMORY_REF ((*Next_Pointer), SYMBOL_NAME)))); } Next_Pointer += 1; break; default: Next_Pointer += 1; break; } } if (Reloc_Debug) { outf_console ("Done interning block.\n"); } return; } /* This should be moved to config.h! */ #ifndef COMPUTE_RELOCATION #define COMPUTE_RELOCATION(new, old) (((relocation_type) (new)) - (old)) #endif static SCHEME_OBJECT DEFUN (load_file, (mode), int mode) { SCHEME_OBJECT * Orig_Heap, * Constant_End, * Orig_Constant, * temp, * primitive_table, * c_code_table; /* Read File */ #ifdef ENABLE_DEBUGGING_TOOLS Warned = false; #endif load_renumber_table = Free; Free += Primitive_Table_Length; ALIGN_FLOAT (Free); Orig_Heap = Free; Orig_Constant = Free_Constant; read_file_end (mode, &primitive_table, &c_code_table); Constant_End = Free_Constant; heap_relocation = (COMPUTE_RELOCATION (Orig_Heap, Heap_Base)); /* Magic! The relocation of compiled code entry points depends on the fact that fasdump never dumps the compiler utilities vector (which contains entry points used by compiled code to invoke microcode provided utilities, like return_to_interpreter). If the file is not a band, any pointers into constant space are pointers into the compiler utilities vector. const_relocation is computed appropriately. Otherwise (the file is a band, and only bands can contain constant space segments) the utilities vector stuff is relocated automagically: the utilities vector is part of the band. */ if ((! band_p) && (dumped_utilities != SHARP_F)) { if (compiler_utilities == SHARP_F) signal_error_from_primitive (ERR_FASLOAD_COMPILED_MISMATCH); const_relocation = (COMPUTE_RELOCATION ((OBJECT_ADDRESS (compiler_utilities)), (OBJECT_DATUM (dumped_utilities)))); Dumped_Constant_Top = (ADDRESS_TO_DATUM (MEMORY_LOC (dumped_utilities, (1 + (VECTOR_LENGTH (compiler_utilities)))))); } else const_relocation = (COMPUTE_RELOCATION (Orig_Constant, Const_Base)); stack_relocation = (COMPUTE_RELOCATION (Stack_Top, Dumped_Stack_Top)); #ifdef BYTE_INVERSION Setup_For_String_Inversion (); #endif /* Setup the primitive and C code tables */ install_primitive_table (primitive_table, Primitive_Table_Length); if ((mode == MODE_BAND) && (! (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)) || (const_relocation != ((relocation_type) 0)) || (stack_relocation != ((relocation_type) 0)) || (! (check_primitive_numbers (load_renumber_table, Primitive_Table_Length)))) { /* We need to relocate. Oh well. */ if (Reloc_Debug) outf_console ("heap_relocation = %ld = %lx; const_relocation = %ld = %lx\n", ((long) heap_relocation), ((long) heap_relocation), ((long) const_relocation), ((long) const_relocation)); /* Relocate the new data. There are no pointers in the primitive table, thus there is no need to relocate it. */ Relocate_Block (Orig_Heap, primitive_table); Relocate_Block (Orig_Constant, Constant_End); } #ifdef BYTE_INVERSION Finish_String_Inversion (); #endif if (mode != MODE_BAND) { /* Again, there are no symbols in the primitive table. */ Intern_Block (Orig_Heap, primitive_table); Intern_Block (Orig_Constant, Constant_End); } #ifdef PUSH_D_CACHE_REGION if (dumped_interface_version != 0) { if (primitive_table != Orig_Heap) PUSH_D_CACHE_REGION (Orig_Heap, (primitive_table - Orig_Heap)); if (Constant_End != Orig_Constant) PUSH_D_CACHE_REGION (Orig_Constant, (Constant_End - Orig_Constant)); } #endif FASLOAD_RELOCATE_HOOK (Orig_Heap, primitive_table, Orig_Constant, Constant_End); RELOCATE_INTO (temp, Dumped_Object); return (* temp); } /* (BINARY-FASLOAD FILE-NAME-OR-CHANNEL) Load the contents of FILE-NAME-OR-CHANNEL into memory. The file was presumably made by a call to PRIMITIVE-FASDUMP, and may contain data for the heap and/or the pure area. The value returned is the object which was dumped. Typically (but not always) this will be a piece of SCode which is then evaluated to perform definitions in some environment. If a file name is given, the corresponding file is opened before loading and closed after loading. A channel remains open. */ DEFINE_PRIMITIVE ("BINARY-FASLOAD", Prim_binary_fasload, 1, 1, 0) { SCHEME_OBJECT arg, result; PRIMITIVE_HEADER (1); PRIMITIVE_CANONICALIZE_CONTEXT(); arg = (ARG_REF (1)); if (STRING_P (arg)) { read_file_start ((STRING_ARG (1)), false); result = (load_file (MODE_FNAME)); } else { read_channel_start ((arg_channel (1)), MODE_CHANNEL); result = (load_file (MODE_CHANNEL)); } #ifdef AUTOCLOBBER_BUG *Free = (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, ((PAGE_SIZE / (sizeof (SCHEME_OBJECT))) - 1))); Free += (PAGE_SIZE / (sizeof (SCHEME_OBJECT))); #endif PRIMITIVE_RETURN (result); } SCHEME_OBJECT DEFUN (continue_fasload, (reentry_record), SCHEME_OBJECT * reentry_record) { SCHEME_OBJECT header; /* The reentry record was prepared by read_channel_continue above. */ load_channel = (arg_channel (1)); header = (reentry_record[0]); read_channel_continue ((VECTOR_LOC (header, 0)), MODE_CHANNEL, true); PRIMITIVE_RETURN (load_file (MODE_CHANNEL)); } /* Band loading. */ static char *reload_band_name = 0; static Tptrvec reload_cleanups = 0; DEFINE_PRIMITIVE ("RELOAD-BAND-NAME", Prim_reload_band_name, 0, 0, "Return the filename from which the runtime system was last restored.\n\ The result is a string, or #F if the system was not restored.") { PRIMITIVE_HEADER (0); PRIMITIVE_RETURN ((reload_band_name != 0) ? (char_pointer_to_string ((unsigned char *) reload_band_name)) : (option_band_file != 0) ? (char_pointer_to_string ((unsigned char *) option_band_file)) : SHARP_F); } typedef void EXFUN ((*Tcleanup), (void)); void DEFUN (add_reload_cleanup, (cleanup_procedure), Tcleanup cleanup_procedure) { if (reload_cleanups == 0) { reload_cleanups = (ptrvec_allocate (1)); (* ((Tcleanup *) (PTRVEC_LOC (reload_cleanups, 0)))) = cleanup_procedure; } else ptrvec_adjoin (reload_cleanups, (PTR) cleanup_procedure); } void DEFUN_VOID (execute_reload_cleanups) { PTR * scan = (PTRVEC_START (reload_cleanups)); PTR * end = (PTRVEC_END (reload_cleanups)); while (scan < end) (* ((Tcleanup *) (scan++))) (); } /* Utility for load band below. */ void DEFUN_VOID (compiler_reset_error) { outf_fatal ("\ncompiler_reset_error: The band being restored and\n"); outf_fatal ("the compiled code interface in this microcode are inconsistent.\n"); Microcode_Termination (TERM_COMPILER_DEATH); } #ifndef START_BAND_LOAD #define START_BAND_LOAD() do \ { \ ENTER_CRITICAL_SECTION ("band load"); \ } while (0) #endif #ifndef END_BAND_LOAD #define END_BAND_LOAD(success, dying) do \ { \ if (success || dying) \ execute_reload_cleanups (); \ EXIT_CRITICAL_SECTION ({}); \ } while (0) #endif struct memmag_state { SCHEME_OBJECT * heap_bottom; SCHEME_OBJECT * heap_top; SCHEME_OBJECT * unused_heap_bottom; SCHEME_OBJECT * unused_heap_top; SCHEME_OBJECT * free; SCHEME_OBJECT * memtop; SCHEME_OBJECT * constant_space; SCHEME_OBJECT * constant_top; SCHEME_OBJECT * free_constant; SCHEME_OBJECT * stack_pointer; SCHEME_OBJECT * stack_bottom; SCHEME_OBJECT * stack_top; SCHEME_OBJECT * stack_guard; }; static void DEFUN (abort_band_load, (ap), PTR ap) { struct memmag_state * mp = ((struct memmag_state *) ap); Heap_Bottom = mp->heap_bottom; Heap_Top = mp->heap_top; Unused_Heap_Bottom = mp->unused_heap_bottom; Unused_Heap_Top = mp->unused_heap_top; Free = mp->free; Free_Constant = mp->free_constant; Constant_Space = mp->constant_space; Constant_Top = mp->constant_top; Stack_Pointer = mp->stack_pointer; Stack_Bottom = mp->stack_bottom; Stack_Top = mp->stack_top; Stack_Guard = mp->stack_guard; SET_MEMTOP (mp->memtop); END_BAND_LOAD (false, false); return; } static void DEFUN (terminate_band_load, (ap), PTR ap) { fputs ("\nload-band: ", stderr); { int abort_value = (abort_to_interpreter_argument ()); if (abort_value > 0) outf_fatal ("Error %ld (%s)", ((long) abort_value), (Error_Names [abort_value])); else outf_fatal ("Abort %ld (%s)", ((long) abort_value), (Abort_Names [(-abort_value) - 1])); } outf_fatal (" past the point of no return.\n"); { char * band_name = (* ((char **) ap)); if (band_name != 0) { outf_fatal ("band-name = \"%s\".\n", band_name); free (band_name); } } END_BAND_LOAD (false, true); Microcode_Termination (TERM_DISK_RESTORE); /*NOTREACHED*/ } /* (LOAD-BAND FILE-NAME) Restores the heap and pure space from the contents of FILE-NAME, which is typically a file created by DUMP-BAND. The file can, however, be any file which can be loaded with BINARY-FASLOAD. */ DEFINE_PRIMITIVE ("LOAD-BAND", Prim_band_load, 1, 1, 0) { extern void EXFUN (reset_allocator_parameters, (void)); SCHEME_OBJECT result; PRIMITIVE_HEADER (1); PRIMITIVE_CANONICALIZE_CONTEXT (); { CONST char * file_name = (STRING_ARG (1)); transaction_begin (); { struct memmag_state * mp = (dstack_alloc (sizeof (struct memmag_state))); mp->heap_bottom = Heap_Bottom; mp->heap_top = Heap_Top; mp->unused_heap_bottom = Unused_Heap_Bottom; mp->unused_heap_top = Unused_Heap_Top; mp->free = Free; mp->memtop = MemTop; mp->free_constant = Free_Constant; mp->constant_space = Constant_Space; mp->constant_top = Constant_Top; mp->stack_pointer = Stack_Pointer; mp->stack_bottom = Stack_Bottom; mp->stack_top = Stack_Top; mp->stack_guard = Stack_Guard; transaction_record_action (tat_abort, abort_band_load, mp); } reset_allocator_parameters (); SET_MEMTOP (Heap_Top); START_BAND_LOAD (); read_file_start (file_name, true); transaction_commit (); /* Point of no return. */ { long length = ((strlen (file_name)) + 1); char * band_name = (malloc (length)); if (band_name != 0) strcpy (band_name, file_name); transaction_begin (); { char ** ap = (dstack_alloc (sizeof (char *))); (*ap) = band_name; transaction_record_action (tat_abort, terminate_band_load, ap); } result = (load_file (MODE_BAND)); transaction_commit (); if (reload_band_name != 0) free (reload_band_name); reload_band_name = band_name; } } /* Reset implementation state paramenters */ INITIALIZE_INTERRUPTS (); INITIALIZE_STACK (); SET_MEMTOP (Heap_Top - GC_Reserve); { SCHEME_OBJECT cutl = (MEMORY_REF (result, 1)); if (cutl != SHARP_F) { compiler_utilities = cutl; compiler_reset (cutl); } else compiler_initialize (true); } /* Until the continuation is invoked. */ SET_INTERRUPT_MASK (0); Restore_Fixed_Obj (SHARP_F); Fluid_Bindings = EMPTY_LIST; Current_State_Point = SHARP_F; /* Setup initial program */ Store_Return (RC_END_OF_COMPUTATION); Store_Expression (SHARP_F); Save_Cont (); Store_Expression (MEMORY_REF (result, 0)); Store_Env (THE_GLOBAL_ENV); /* Clear various interpreter state parameters. */ Trapping = false; Return_Hook_Address = 0; History = (Make_Dummy_History ()); Prev_Restore_History_Stacklet = 0; Prev_Restore_History_Offset = 0; COMPILER_TRANSPORT_END (); END_BAND_LOAD (true, false); Band_Load_Hook (); /* Return in a non-standard way. */ PRIMITIVE_ABORT (PRIM_DO_EXPRESSION); /*NOTREACHED*/ PRIMITIVE_RETURN (UNSPECIFIC); } #ifdef BYTE_INVERSION #define MAGIC_OFFSET (TC_FIXNUM + 1) SCHEME_OBJECT String_Chain, Last_String; void DEFUN_VOID (Setup_For_String_Inversion) { String_Chain = SHARP_F; Last_String = SHARP_F; return; } void DEFUN_VOID (Finish_String_Inversion) { if (Byte_Invert_Fasl_Files) while (String_Chain != SHARP_F) { long Count; SCHEME_OBJECT Next; Count = OBJECT_DATUM (FAST_MEMORY_REF (String_Chain, STRING_HEADER)); Count = 4 * (Count - 2) + (OBJECT_TYPE (String_Chain)) - MAGIC_OFFSET; if (Reloc_Debug) { outf_console ("String at 0x%lx: restoring length of %ld.\n", ((long) (OBJECT_ADDRESS (String_Chain))), ((long) Count)); } Next = (STRING_LENGTH (String_Chain)); SET_STRING_LENGTH (String_Chain, Count); String_Chain = Next; } return; } #define print_char(C) outf_console (((C < ' ') || (C > '|')) ? \ "\\%03o" : "%c", (C && UCHAR_MAX)); void DEFUN (String_Inversion, (Orig_Pointer), SCHEME_OBJECT * Orig_Pointer) { SCHEME_OBJECT *Pointer_Address; char *To_Char; long Code; if (!Byte_Invert_Fasl_Files) return; Code = OBJECT_TYPE (Orig_Pointer[STRING_LENGTH_INDEX]); if (Code == 0) /* Already reversed? */ { long Count, old_size, new_size, i; old_size = (OBJECT_DATUM (Orig_Pointer[STRING_HEADER])); new_size = 2 + (((long) (Orig_Pointer[STRING_LENGTH_INDEX]))) / 4; if (Reloc_Debug) { outf_console ("\nString at 0x%lx with %ld characters", ((long) Orig_Pointer), ((long) (Orig_Pointer[STRING_LENGTH_INDEX]))); } if (old_size != new_size) { outf_fatal ("\nWord count changed from %ld to %ld: ", ((long) old_size), ((long) new_size)); outf_fatal ("\nWhich, of course, is impossible!!\n"); Microcode_Termination (TERM_EXIT); } Count = ((long) (Orig_Pointer[STRING_LENGTH_INDEX])) % 4; if (Count == 0) Count = 4; if (Last_String == SHARP_F) String_Chain = MAKE_POINTER_OBJECT (Count + MAGIC_OFFSET, Orig_Pointer); else FAST_MEMORY_SET (Last_String, STRING_LENGTH_INDEX, (MAKE_POINTER_OBJECT ((Count + MAGIC_OFFSET), Orig_Pointer))); Last_String = (MAKE_POINTER_OBJECT (TC_NULL, Orig_Pointer)); Orig_Pointer[STRING_LENGTH_INDEX] = SHARP_F; Count = (OBJECT_DATUM (Orig_Pointer[STRING_HEADER])) - 1; if (Reloc_Debug) outf_console ("\nCell count = %ld\n", ((long) Count)); Pointer_Address = &(Orig_Pointer[STRING_CHARS]); To_Char = (char *) Pointer_Address; for (i = 0; i < Count; i++, Pointer_Address++) { int C1, C2, C3, C4; C4 = OBJECT_TYPE (*Pointer_Address) & 0xFF; C3 = (((long) *Pointer_Address)>>16) & 0xFF; C2 = (((long) *Pointer_Address)>>8) & 0xFF; C1 = ((long) *Pointer_Address) & 0xFF; if (Reloc_Debug || (old_size != new_size)) { print_char(C1); print_char(C2); print_char(C3); print_char(C4); } *To_Char++ = C1; *To_Char++ = C2; *To_Char++ = C3; *To_Char++ = C4; } } if (Reloc_Debug) outf_console ("\n"); return; } #endif /* BYTE_INVERSION */