void output_data (std::ostream & os, uint8_t val)
{
output_space(os);
for (uint32_t i =0;i < 8;++i){
if ( val & (1 << i) ){
output_mark(os);
}else {
output_space(os);
}
}
output_mark(os);
}
/* return class of last character */
static char output_token(const yystype *token, struct scope *scope, struct buf *out, char lastchar)
{
char sbuf[128];
const char *s = TOKEN_GET(token, cstring);
/* TODO: use a local buffer, instead of FILE* */
switch(token->type) {
case TOK_StringLiteral:
output_space(lastchar,'"', out);
buf_outc('"', out);
if(s) {
buf_outs(s, out);
}
buf_outc('"', out);
return '\"';
case TOK_NumericInt:
output_space(lastchar,'0', out);
snprintf(sbuf, sizeof(sbuf), "%ld", TOKEN_GET(token, ival));
buf_outs(sbuf, out);
return '0';
case TOK_NumericFloat:
output_space(lastchar,'0', out);
snprintf(sbuf, sizeof(sbuf), "%g", TOKEN_GET(token, dval));
buf_outs(sbuf, out);
return '0';
case TOK_IDENTIFIER_NAME:
output_space(lastchar,'a', out);
if(s) {
long id = scope_lookup(scope, s, strlen(s));
if(id == -1) {
/* identifier not normalized */
buf_outs(s, out);
} else {
snprintf(sbuf, sizeof(sbuf), "n%03ld",id);
buf_outs(sbuf, out);
}
}
return 'a';
case TOK_FUNCTION:
output_space(lastchar,'a', out);
buf_outs("function",out);
return 'a';
default:
if(s) {
const size_t len = strlen(s);
output_space(lastchar,s[0], out);
buf_outs(s, out);
return len ? s[len-1] : '\0';
}
return '\0';
}
}
boolean
save_to_filehandle(FILE *file, char *filename, lispobj init_function,
boolean make_executable,
boolean save_runtime_options,
int core_compression_level)
{
struct thread *th;
os_vm_offset_t core_start_pos;
#ifdef LISP_FEATURE_X86_64
untune_asm_routines_for_microarch();
#endif
/* Smash the enclosing state. (Once we do this, there's no good
* way to go back, which is a sufficient reason that this ends up
* being SAVE-LISP-AND-DIE instead of SAVE-LISP-AND-GO-ON). */
printf("[undoing binding stack and other enclosing state... ");
fflush(stdout);
for_each_thread(th) { /* XXX really? */
unbind_to_here((lispobj *)th->binding_stack_start,th);
SetSymbolValue(CURRENT_CATCH_BLOCK, 0,th);
SetSymbolValue(CURRENT_UNWIND_PROTECT_BLOCK, 0,th);
}
printf("done]\n");
fflush(stdout);
/* (Now we can actually start copying ourselves into the output file.) */
printf("[saving current Lisp image into %s:\n", filename);
fflush(stdout);
core_start_pos = ftell(file);
write_lispobj(CORE_MAGIC, file);
write_lispobj(BUILD_ID_CORE_ENTRY_TYPE_CODE, file);
write_lispobj(/* (We're writing the word count of the entry here, and the 2
* term is one word for the leading BUILD_ID_CORE_ENTRY_TYPE_CODE
* word and one word where we store the count itself.) */
2 + strlen((const char *)build_id),
file);
{
unsigned char *p;
for (p = (unsigned char *)build_id; *p; ++p)
write_lispobj(*p, file);
}
write_lispobj(NEW_DIRECTORY_CORE_ENTRY_TYPE_CODE, file);
write_lispobj(/* (word count = N spaces described by 5 words each, plus the
* entry type code, plus this count itself) */
(5*N_SPACES_TO_SAVE)+2, file);
output_space(file,
READ_ONLY_CORE_SPACE_ID,
(lispobj *)READ_ONLY_SPACE_START,
(lispobj *)SymbolValue(READ_ONLY_SPACE_FREE_POINTER,0),
core_start_pos,
core_compression_level);
output_space(file,
STATIC_CORE_SPACE_ID,
(lispobj *)STATIC_SPACE_START,
(lispobj *)SymbolValue(STATIC_SPACE_FREE_POINTER,0),
core_start_pos,
core_compression_level);
#ifdef LISP_FEATURE_GENCGC
/* Flush the current_region, updating the tables. */
gc_alloc_update_all_page_tables(1);
update_dynamic_space_free_pointer();
#endif
#ifdef LISP_FEATURE_IMMOBILE_SPACE
prepare_immobile_space_for_save();
output_space(file,
IMMOBILE_FIXEDOBJ_CORE_SPACE_ID,
(lispobj *)IMMOBILE_SPACE_START,
(lispobj *)SymbolValue(IMMOBILE_FIXEDOBJ_FREE_POINTER,0),
core_start_pos,
core_compression_level);
output_space(file,
IMMOBILE_VARYOBJ_CORE_SPACE_ID,
(lispobj *)IMMOBILE_VARYOBJ_SUBSPACE_START,
(lispobj *)SymbolValue(IMMOBILE_SPACE_FREE_POINTER,0),
core_start_pos,
core_compression_level);
#endif
#ifdef reg_ALLOC
#ifdef LISP_FEATURE_GENCGC
output_space(file,
DYNAMIC_CORE_SPACE_ID,
(lispobj *)DYNAMIC_SPACE_START,
dynamic_space_free_pointer,
core_start_pos,
core_compression_level);
#else
output_space(file,
DYNAMIC_CORE_SPACE_ID,
(lispobj *)current_dynamic_space,
dynamic_space_free_pointer,
core_start_pos,
core_compression_level);
#endif
#else
output_space(file,
DYNAMIC_CORE_SPACE_ID,
(lispobj *)DYNAMIC_SPACE_START,
(lispobj *)SymbolValue(ALLOCATION_POINTER,0),
core_start_pos,
core_compression_level);
#endif
write_lispobj(INITIAL_FUN_CORE_ENTRY_TYPE_CODE, file);
write_lispobj(3, file);
write_lispobj(init_function, file);
#ifdef LISP_FEATURE_GENCGC
{
size_t size = (last_free_page*sizeof(sword_t)+os_vm_page_size-1)
&~(os_vm_page_size-1);
uword_t *data = calloc(size, 1);
if (data) {
uword_t word;
sword_t offset;
page_index_t i;
for (i = 0; i < last_free_page; i++) {
/* Thanks to alignment requirements, the two low bits
* are always zero, so we can use them to store the
* allocation type -- region is always closed, so only
* the two low bits of allocation flags matter. */
word = page_table[i].scan_start_offset;
gc_assert((word & 0x03) == 0);
data[i] = word | (0x03 & page_table[i].allocated);
}
write_lispobj(PAGE_TABLE_CORE_ENTRY_TYPE_CODE, file);
write_lispobj(4, file);
write_lispobj(size, file);
offset = write_bytes(file, (char *)data, size, core_start_pos);
write_lispobj(offset, file);
}
}
#endif
write_lispobj(END_CORE_ENTRY_TYPE_CODE, file);
/* Write a trailing header, ignored when parsing the core normally.
* This is used to locate the start of the core when the runtime is
* prepended to it. */
fseek(file, 0, SEEK_END);
/* If NULL runtime options are passed to write_runtime_options,
* command-line processing is performed as normal in the SBCL
* executable. Otherwise, the saved runtime options are used and
* all command-line arguments are available to Lisp in
* SB-EXT:*POSIX-ARGV*. */
write_runtime_options(file,
(save_runtime_options ? runtime_options : NULL));
if (1 != fwrite(&core_start_pos, sizeof(os_vm_offset_t), 1, file)) {
perror("Error writing core starting position to file");
fclose(file);
} else {
write_lispobj(CORE_MAGIC, file);
fclose(file);
}
#ifndef LISP_FEATURE_WIN32
if (make_executable)
chmod (filename, 0755);
#endif
printf("done]\n");
exit(0);
}
boolean
save_to_filehandle(FILE *file, char *filename, lispobj init_function,
boolean make_executable,
boolean save_runtime_options)
{
struct thread *th;
os_vm_offset_t core_start_pos;
/* Smash the enclosing state. (Once we do this, there's no good
* way to go back, which is a sufficient reason that this ends up
* being SAVE-LISP-AND-DIE instead of SAVE-LISP-AND-GO-ON). */
printf("[undoing binding stack and other enclosing state... ");
fflush(stdout);
for_each_thread(th) { /* XXX really? */
unbind_to_here((lispobj *)th->binding_stack_start,th);
SetSymbolValue(CURRENT_CATCH_BLOCK, 0,th);
SetSymbolValue(CURRENT_UNWIND_PROTECT_BLOCK, 0,th);
}
printf("done]\n");
fflush(stdout);
/* (Now we can actually start copying ourselves into the output file.) */
printf("[saving current Lisp image into %s:\n", filename);
fflush(stdout);
core_start_pos = ftell(file);
write_lispobj(CORE_MAGIC, file);
write_lispobj(VERSION_CORE_ENTRY_TYPE_CODE, file);
write_lispobj(3, file);
write_lispobj(SBCL_CORE_VERSION_INTEGER, file);
write_lispobj(BUILD_ID_CORE_ENTRY_TYPE_CODE, file);
write_lispobj(/* (We're writing the word count of the entry here, and the 2
* term is one word for the leading BUILD_ID_CORE_ENTRY_TYPE_CODE
* word and one word where we store the count itself.) */
2 + strlen((const char *)build_id),
file);
{
unsigned char *p;
for (p = (unsigned char *)build_id; *p; ++p)
write_lispobj(*p, file);
}
write_lispobj(NEW_DIRECTORY_CORE_ENTRY_TYPE_CODE, file);
write_lispobj(/* (word count = 3 spaces described by 5 words each, plus the
* entry type code, plus this count itself) */
(5*3)+2, file);
output_space(file,
READ_ONLY_CORE_SPACE_ID,
(lispobj *)READ_ONLY_SPACE_START,
(lispobj *)SymbolValue(READ_ONLY_SPACE_FREE_POINTER,0),
core_start_pos);
output_space(file,
STATIC_CORE_SPACE_ID,
(lispobj *)STATIC_SPACE_START,
(lispobj *)SymbolValue(STATIC_SPACE_FREE_POINTER,0),
core_start_pos);
#ifdef LISP_FEATURE_GENCGC
/* Flush the current_region, updating the tables. */
gc_alloc_update_all_page_tables();
update_dynamic_space_free_pointer();
#endif
#ifdef reg_ALLOC
#ifdef LISP_FEATURE_GENCGC
output_space(file,
DYNAMIC_CORE_SPACE_ID,
(lispobj *)DYNAMIC_SPACE_START,
dynamic_space_free_pointer,
core_start_pos);
#else
output_space(file,
DYNAMIC_CORE_SPACE_ID,
(lispobj *)current_dynamic_space,
dynamic_space_free_pointer,
core_start_pos);
#endif
#else
output_space(file,
DYNAMIC_CORE_SPACE_ID,
(lispobj *)DYNAMIC_SPACE_START,
(lispobj *)SymbolValue(ALLOCATION_POINTER,0),
core_start_pos);
#endif
write_lispobj(INITIAL_FUN_CORE_ENTRY_TYPE_CODE, file);
write_lispobj(3, file);
write_lispobj(init_function, file);
#ifdef LISP_FEATURE_GENCGC
{
size_t size = (last_free_page*sizeof(long)+os_vm_page_size-1)
&~(os_vm_page_size-1);
unsigned long *data = calloc(size, 1);
if (data) {
long offset;
int i;
for (i = 0; i < last_free_page; i++) {
data[i] = page_table[i].region_start_offset;
}
write_lispobj(PAGE_TABLE_CORE_ENTRY_TYPE_CODE, file);
write_lispobj(4, file);
write_lispobj(size, file);
offset = write_bytes(file, (char *) data, size, core_start_pos);
write_lispobj(offset, file);
}
}
#endif
#if defined(LISP_FEATURE_SB_THREAD) && defined(LISP_FEATURE_SB_LUTEX)
if(n_lutexes > 0) {
long offset;
printf("writing %ld lutexes to the core...\n", n_lutexes);
write_lispobj(LUTEX_TABLE_CORE_ENTRY_TYPE_CODE, file);
/* word count of the entry */
write_lispobj(4, file);
/* indicate how many lutexes we saved */
write_lispobj(n_lutexes, file);
/* save the lutexes */
offset = write_bytes(file, (char *) lutex_addresses,
n_lutexes * sizeof(*lutex_addresses),
core_start_pos);
write_lispobj(offset, file);
}
#endif
write_lispobj(END_CORE_ENTRY_TYPE_CODE, file);
/* Write a trailing header, ignored when parsing the core normally.
* This is used to locate the start of the core when the runtime is
* prepended to it. */
fseek(file, 0, SEEK_END);
/* If NULL runtime options are passed to write_runtime_options,
* command-line processing is performed as normal in the SBCL
* executable. Otherwise, the saved runtime options are used and
* all command-line arguments are available to Lisp in
* SB-EXT:*POSIX-ARGV*. */
write_runtime_options(file,
(save_runtime_options ? runtime_options : NULL));
if (1 != fwrite(&core_start_pos, sizeof(os_vm_offset_t), 1, file)) {
perror("Error writing core starting position to file");
fclose(file);
} else {
write_lispobj(CORE_MAGIC, file);
fclose(file);
}
#ifndef LISP_FEATURE_WIN32
if (make_executable)
chmod (filename, 0755);
#endif
printf("done]\n");
exit(0);
}
boolean
save(char *filename, lispobj init_function, int sse2_mode)
{
FILE *file;
#if defined WANT_CGC
volatile lispobj *func_ptr = &init_function;
char sbuf[128];
strcpy(sbuf, filename);
filename = sbuf;
/* Get rid of remnant stuff. This is a MUST so that
* the memory manager can get started correctly when
* we restart after this save. Purify is going to
* maybe move the args so we need to consider them volatile,
* especially if the gcc optimizer is working!!
*/
purify(NIL, NIL);
init_function = *func_ptr;
/* Set dynamic space pointer to base value so we don't write out
* MBs of just cleared heap.
*/
if (SymbolValue(X86_CGC_ACTIVE_P) != NIL)
SetSymbolValue(ALLOCATION_POINTER, DYNAMIC_0_SPACE_START);
#endif
/* Open the file: */
remove(filename);
file = fopen(filename, "w");
if (file == NULL) {
perror(filename);
return TRUE;
}
printf("[Undoing binding stack... ");
fflush(stdout);
unbind_to_here((lispobj *) BINDING_STACK_START);
SetSymbolValue(CURRENT_CATCH_BLOCK, 0);
SetSymbolValue(CURRENT_UNWIND_PROTECT_BLOCK, 0);
SetSymbolValue(EVAL_STACK_TOP, 0);
printf("done]\n");
#if defined WANT_CGC && defined X86_CGC_ACTIVE_P
SetSymbolValue(X86_CGC_ACTIVE_P, T);
#endif
printf("[Saving current lisp image into %s:\n", filename);
putw(CORE_MAGIC, file);
putw(CORE_VERSION, file);
#if defined(i386) && defined(FEATURE_SSE2)
putw(4, file);
#else
putw(3, file);
#endif
putw(version, file);
#if defined(i386) && defined(FEATURE_SSE2)
if (sse2_mode) {
putw(SSE2, file);
} else {
putw(X87, file);
}
#endif
putw(CORE_NDIRECTORY, file);
putw((5 * 3) + 2, file);
output_space(file, READ_ONLY_SPACE_ID, read_only_space,
(lispobj *) SymbolValue(READ_ONLY_SPACE_FREE_POINTER));
output_space(file, STATIC_SPACE_ID, static_space,
(lispobj *) SymbolValue(STATIC_SPACE_FREE_POINTER));
#ifdef GENCGC
/* Flush the current_region updating the tables. */
#ifdef DEBUG_BAD_HEAP
fprintf(stderr, "before ALLOC_POINTER = %p\n", (lispobj *) SymbolValue(ALLOCATION_POINTER));
dump_region(&boxed_region);
#endif
gc_alloc_update_page_tables(0, &boxed_region);
gc_alloc_update_page_tables(1, &unboxed_region);
#ifdef DEBUG_BAD_HEAP
fprintf(stderr, "boxed_region after update\n");
dump_region(&boxed_region);
print_ptr((lispobj*) 0x2805a184);
#endif
#ifdef DEBUG_BAD_HEAP
/*
* For some reason x86 has a heap corruption problem. I (rtoy)
* have not been able to figure out how that occurs, but what is
* happening is that when a core is loaded, there is some static
* object pointing to an object that is on a free page. In normal
* usage, at startup there should be 4 objects in static space
* pointing to a free page, because these are newly allocated
* objects created by the C runtime. However, there is an
* additional object.
*
* I do not know what this object should be or how it got there,
* but it will often cause CMUCL to fail to save a new core file.
*
* Disabling this call to update_dynamic_space_free_pointer is a
* work around. What is happening is that u_d_s_f_p is resetting
* ALLOCATION_POINTER, but that weird object is in the current
* region, but after resetting the pointer, that object isn't
* saved to the core file. By not resetting the pointer, the
* object (or at least enough of it) gets saved in the core file
* that we don't have problems when reloading.
*
* Note that on sparc and ppc, u_d_s_f_p doesn't actually do
* anything because the call to reset ALLOCATION_POINTER is a nop
* on sparc and ppc. And sparc and ppc dont' have the heap
* corruption issue. That's not conclusive evidence, though.
*
* This needs more work and investigation.
*/
update_dynamic_space_free_pointer();
#endif
#ifdef DEBUG_BAD_HEAP
fprintf(stderr, "after ALLOC_POINTER = %p\n", (lispobj *) SymbolValue(ALLOCATION_POINTER));
#endif
#endif
#ifdef reg_ALLOC
output_space(file, DYNAMIC_SPACE_ID, current_dynamic_space,
current_dynamic_space_free_pointer);
#else
output_space(file, DYNAMIC_SPACE_ID, current_dynamic_space,
(lispobj *) SymbolValue(ALLOCATION_POINTER));
#endif
putw(CORE_INITIAL_FUNCTION, file);
putw(3, file);
putw(init_function, file);
putw(CORE_END, file);
fclose(file);
printf("done.]\n");
exit(0);
}
