/* ldump_heap_state
*
* Traverse the heap segments, writing the FASL code of each cell to
* a file of the specified name.
*/
lref_t ldump_heap_state(lref_t port)
{
for (size_t heap_no = 0; heap_no < interp.gc_max_heap_segments; heap_no++)
{
if (interp.gc_heap_segments[heap_no] == NULL)
continue;
lref_t obj;
lref_t org = interp.gc_heap_segments[heap_no];
lref_t end = org + interp.gc_heap_segment_size;
fixnum_t ii;
for (obj = org, ii = 0; obj < end; obj++, ii++)
{
if (ii % 256 == 0)
{
lnewline(port);
ii = 0;
}
scwritef(_T("~cd, "), port, TYPE(obj));
}
}
return NIL;
}
void scan_postmortem_dump()
{
#if 0
lref_t oport = CURRENT_DEBUG_PORT();
for(frame_t *frame = CURRENT_TIB()->frame;
frame != NULL;
frame = frame->prev_frame)
{
scwritef(_T("\n*** FRAME=~cd: "), oport, frame);
switch (frame->type)
{
case FRAME_EVAL:
scwritef(_T("eval > ~s in ~s\n"), oport, *frame->as.eval.form,
frame->as.eval.initial_form);
break;
case FRAME_ESCAPE:
scwritef(_T("try > ~s\n"), oport, frame->as.escape.tag);
break;
case FRAME_UNWIND:
scwritef(_T("unwind-protect >\n"), oport);
break;
case FRAME_SUBR:
scwritef(_T("subr > ~s\n"), oport, frame->as.subr.subr);
break;
default:
scwritef(_T("<< INVALID-FRAME-TYPE >>\n"), oport);
break;
}
lflush_port(oport);
}
#endif
}
/* A C function to do Lisp-style Formatted I/O ******************
*
* ~s - write the lisp object
* ~a - display the lisp object
* REVISIT: remove scvwritef ~u in favor of some kind of print_unreadable_object call
* ~u - display the lisp object in unprintable fashion (ie. <type@addr...>
*
* ~cs - display the C string
* ~cS - display the C string/arglist with a recursive call to scvwritef
* ~cd - display the C integer
* ~cf - display the C flonum
* ~c& - display the C pointer
* ~cc - display the C character
* ~cC - display the C integer as an octal character constant
* ~cB - display the C integer as a byte
*
* Prefixing a format code with a #\! (ie. ~!L) causes the corresponding
* value to be returned from the function as a Lisp object.
*/
lref_t scvwritef(const _TCHAR * format_str, lref_t port, va_list arglist)
{
char ch;
if (NULLP(port))
port = CURRENT_OUTPUT_PORT();
assert(PORTP(port));
_TCHAR buf[STACK_STRBUF_LEN];
lref_t lisp_arg_value = NULL;
_TCHAR *str_arg_value = NULL;
_TCHAR char_arg_value = _T('\0');
long int long_arg_value = 0;
unsigned long int ulong_arg_value = 0;
flonum_t flonum_arg_value = 0.0;
lref_t unprintable_object = NIL;
lref_t return_value = NIL;
for (;;)
{
ch = *format_str;
if (ch == '\0')
break;
bool return_next_value = false;
format_str++;
if (ch != '~')
{
write_char(port, ch);
continue;
}
ch = *format_str;
format_str++;
if (ch == '!')
{
ch = *format_str;
format_str++;
return_next_value = true;
}
switch (ch)
{
case 's':
lisp_arg_value = va_arg(arglist, lref_t);
if (return_next_value)
return_value = lisp_arg_value;
debug_print_object(lisp_arg_value, port, true);
break;
case 'a':
lisp_arg_value = va_arg(arglist, lref_t);
if (return_next_value)
return_value = lisp_arg_value;
debug_print_object(lisp_arg_value, port, false);
break;
case 'u':
unprintable_object = va_arg(arglist, lref_t);
if (return_next_value)
return_value = unprintable_object;
if (DEBUG_FLAG(DF_PRINT_FOR_DIFF))
scwritef("#<~cs@(no-addr)", port, typecode_name(TYPE(unprintable_object)));
else
scwritef("#<~cs@~c&", port,
typecode_name(TYPE(unprintable_object)), unprintable_object);
break;
case '~':
write_char(port, '~');
break;
case 'c': /* C object prefix */
ch = *format_str; /* read the next format character */
format_str++;
switch (ch)
{
case 's':
str_arg_value = va_arg(arglist, _TCHAR *);
if (return_next_value)
return_value = strconsbuf(str_arg_value);
if (str_arg_value)
write_text(port, str_arg_value, _tcslen(str_arg_value));
else
WRITE_TEXT_CONSTANT(port, _T("<null>"));
break;
case 'S':
str_arg_value = va_arg(arglist, _TCHAR *);
if (return_next_value)
return_value = scvwritef(str_arg_value, port, arglist);
else
scvwritef(str_arg_value, port, arglist);
break;
case 'd':
long_arg_value = va_arg(arglist, long int);
if (return_next_value)
return_value = fixcons(long_arg_value);
_sntprintf(buf, STACK_STRBUF_LEN, _T("%d"), (int) long_arg_value);
write_text(port, buf, _tcslen(buf));
break;
case 'x':
long_arg_value = va_arg(arglist, long int);
if (return_next_value)
return_value = fixcons(long_arg_value);
_sntprintf(buf, STACK_STRBUF_LEN, _T("%08lx"), long_arg_value);
write_text(port, buf, _tcslen(buf));
break;
case 'f':
flonum_arg_value = va_arg(arglist, flonum_t);
if (return_next_value)
return_value = flocons(flonum_arg_value);
_sntprintf(buf, STACK_STRBUF_LEN, _T("%f"), flonum_arg_value);
write_text(port, buf, _tcslen(buf));
break;
case '&':
_sntprintf(buf, STACK_STRBUF_LEN, _T("%p"), (void *) va_arg(arglist, void *));
if (return_next_value)
return_value = strconsbuf(buf);
write_text(port, buf, _tcslen(buf));
break;
case 'c':
ulong_arg_value = va_arg(arglist, unsigned long int);
if (return_next_value)
return_value = fixcons(ulong_arg_value);
char_arg_value = (_TCHAR) ulong_arg_value;
write_text(port, &char_arg_value, 1);
break;
case 'C':
ulong_arg_value = va_arg(arglist, unsigned long int);
if (return_next_value)
return_value = fixcons(ulong_arg_value);
_sntprintf(buf, STACK_STRBUF_LEN, _T("%03o"), (uint32_t) ulong_arg_value);
write_text(port, buf, _tcslen(buf));
break;
case 'B':
ulong_arg_value = va_arg(arglist, unsigned long int);
if (return_next_value)
return_value = fixcons(ulong_arg_value);
_sntprintf(buf, STACK_STRBUF_LEN, _T("0x%02x"), (uint32_t) ulong_arg_value);
write_text(port, buf, _tcslen(buf));
break;
default:
panic(_T("Invalid C object format character in scwritef"));
break;
};
break;
default:
panic(_T("Invalid format character in scwritef"));
break;
}
return_next_value = false;
}
va_end(arglist);
if (!NULLP(unprintable_object))
scwritef(">", port);
return return_value;
}
static void debug_print_string(lref_t obj, lref_t port, bool machine_readable)
{
assert(STRINGP(obj));
if (!machine_readable)
{
write_text(port, obj->as.string.data, obj->as.string.dim);
return;
}
WRITE_TEXT_CONSTANT(port, _T("\""));
size_t next_char_to_write = 0;
_TCHAR cbuff[2];
/* To write strings more efficiently, this code scans for the longest
* block of characters that doesn't need special encoding, and then
* passes those blocks on to write_bytes. */
while (next_char_to_write < obj->as.string.dim)
{
unsigned int c;
size_t next_special_char;
/* Scan for the next special character, it ends the block... */
for (next_special_char = next_char_to_write;
next_special_char < obj->as.string.dim;
next_special_char++)
{
c = obj->as.string.data[next_special_char];
if ((c == '\\') || (c == '"') || (c == '\n') || (c == '\r')
|| (c == '\t') || (c == '\0') || (c < 32) || (c >= 127))
break;
}
/* ...which then gets written out. */
if (next_special_char - next_char_to_write > 0)
write_text(port,
&(obj->as.string.data[next_char_to_write]),
next_special_char - next_char_to_write);
if (next_special_char >= obj->as.string.dim)
break;
c = obj->as.string.data[next_special_char];
/* Write the next special character. */
switch (c)
{
case '\\':
case '"':
cbuff[0] = _T('\\');
cbuff[1] = (_TCHAR) c;
write_text(port, cbuff, 2);
break;
case '\n':
WRITE_TEXT_CONSTANT(port, _T("\\n"));
break;
case '\r':
WRITE_TEXT_CONSTANT(port, _T("\\r"));
break;
case '\t':
WRITE_TEXT_CONSTANT(port, _T("\\t"));
break;
case '\0':
WRITE_TEXT_CONSTANT(port, _T("\\000"));
break;
default:
/* This assert will only fail when the special character scanner
* breaks on a character that the special character writer
* does not know how to handle. */
assert((c < 32) || (c >= 127));
scwritef(_T("\\~cC"), port, (unsigned long) c);
}
next_char_to_write = next_special_char + 1;
}
WRITE_TEXT_CONSTANT(port, _T("\""));
}
lref_t debug_print_object(lref_t obj, lref_t port, bool machine_readable)
{
_TCHAR buf[STACK_STRBUF_LEN];
if (DEBUG_FLAG(DF_PRINT_ADDRESSES))
scwritef("#@~c&=", port, obj);
lref_t tmp;
size_t ii;
lref_t slots;
const _TCHAR *fast_op_name;
switch (TYPE(obj))
{
case TC_NIL:
WRITE_TEXT_CONSTANT(port, _T("()"));
break;
case TC_BOOLEAN:
if (TRUEP(obj))
WRITE_TEXT_CONSTANT(port, _T("#t"));
else
WRITE_TEXT_CONSTANT(port, _T("#f"));
break;
case TC_CONS:
write_char(port, _T('('));
debug_print_object(lcar(obj), port, machine_readable);
for (tmp = lcdr(obj); CONSP(tmp); tmp = lcdr(tmp))
{
write_char(port, _T(' '));
debug_print_object(lcar(tmp), port, machine_readable);
}
if (!NULLP(tmp))
{
WRITE_TEXT_CONSTANT(port, _T(" . "));
debug_print_object(tmp, port, machine_readable);
}
write_char(port, _T(')'));
break;
case TC_FIXNUM:
_sntprintf(buf, STACK_STRBUF_LEN, _T("%" SCAN_PRIiFIXNUM), FIXNM(obj));
write_text(port, buf, _tcslen(buf));
break;
case TC_FLONUM:
debug_print_flonum(obj, port, machine_readable);
break;
case TC_CHARACTER:
if (machine_readable)
{
if (CHARV(obj) < CHARNAMECOUNT)
scwritef(_T("#\\~cs"), port, charnames[(size_t) CHARV(obj)]);
else if (CHARV(obj) >= CHAREXTENDED - 1)
scwritef(_T("#\\<~cd>"), port, (int) CHARV(obj));
else
scwritef(_T("#\\~cc"), port, (int) CHARV(obj));
}
else
scwritef(_T("~cc"), port, (int) CHARV(obj));
break;
case TC_SYMBOL:
if (NULLP(SYMBOL_HOME(obj)))
{
if (DEBUG_FLAG(DF_PRINT_FOR_DIFF))
scwritef("#:<uninterned-symbol>", port);
else
scwritef("#:~a@~c&", port, SYMBOL_PNAME(obj), obj);
}
else if (SYMBOL_HOME(obj) == interp.control_fields[VMCTRL_PACKAGE_KEYWORD])
scwritef(":~a", port, SYMBOL_PNAME(obj));
else
{
/* With only a minimal c-level package implementation, we
* just assume every symbol is private. */
scwritef("~a::~a", port, SYMBOL_HOME(obj)->as.package.name, SYMBOL_PNAME(obj));
}
break;
case TC_VECTOR:
WRITE_TEXT_CONSTANT(port, _T("["));
for (ii = 0; ii < obj->as.vector.dim; ii++)
{
debug_print_object(obj->as.vector.data[ii], port, true);
if (ii + 1 < obj->as.vector.dim)
write_char(port, _T(' '));
}
write_char(port, _T(']'));
break;
case TC_STRUCTURE:
WRITE_TEXT_CONSTANT(port, _T("#S("));
debug_print_object(CAR(STRUCTURE_LAYOUT(obj)), port, true);
for (ii = 0, slots = CAR(CDR(STRUCTURE_LAYOUT(obj)));
ii < STRUCTURE_DIM(obj); ii++, slots = CDR(slots))
{
WRITE_TEXT_CONSTANT(port, _T(" "));
debug_print_object(CAR(CAR(slots)), port, true);
WRITE_TEXT_CONSTANT(port, _T(" "));
debug_print_object(STRUCTURE_ELEM(obj, ii), port, true);
}
WRITE_TEXT_CONSTANT(port, _T(")"));
break;
case TC_STRING:
debug_print_string(obj, port, machine_readable);
break;
case TC_HASH:
debug_print_hash(obj, port, machine_readable);
break;
case TC_PACKAGE:
scwritef("~u ~a", port, (lref_t) obj, obj->as.package.name);
break;
case TC_SUBR:
scwritef("~u,~cd:~a", port, (lref_t) obj, SUBR_TYPE(obj), SUBR_NAME(obj));
break;
case TC_CLOSURE:
if (DEBUG_FLAG(DF_PRINT_CLOSURE_CODE))
scwritef("~u\n\tcode:~s\n\tenv:~s\n\tp-list:~s", port,
(lref_t) obj, CLOSURE_CODE(obj), CLOSURE_ENV(obj),
CLOSURE_PROPERTY_LIST(obj));
else
scwritef("~u", port, (lref_t) obj);
break;
case TC_VALUES_TUPLE:
scwritef("~u ~s", port, (lref_t) obj, obj->as.values_tuple.values);
break;
case TC_MACRO:
if (DEBUG_FLAG(DF_PRINT_CLOSURE_CODE))
scwritef("~u ~s", port, (lref_t) obj, obj->as.macro.transformer);
else
scwritef("~u", port, (lref_t) obj);
break;
case TC_END_OF_FILE:
scwritef("~u", port, (lref_t) obj);
break;
case TC_PORT:
scwritef(_T("~u~cs~cs~cs ~cs ~s"), port,
obj,
PORT_INPUTP(obj) ? " (input)" : "",
PORT_OUTPUTP(obj) ? " (output)" : "",
BINARY_PORTP(obj) ? " (binary)" : "",
PORT_CLASS(obj)->name,
PORT_PINFO(obj)->port_name);
break;
case TC_FAST_OP:
fast_op_name = fast_op_opcode_name(obj->header.opcode);
if (fast_op_name)
scwritef("#<FOP@~c&:~cs ~s ~s => ~s>", port, (lref_t) obj,
fast_op_name,
obj->as.fast_op.arg1,
obj->as.fast_op.arg2,
obj->as.fast_op.next);
else
scwritef("#<FOP@~c&:~cd ~s ~s => ~s>", port, (lref_t) obj,
obj->header.opcode,
obj->as.fast_op.arg1,
obj->as.fast_op.arg2,
obj->as.fast_op.next);
break;
case TC_FASL_READER:
scwritef(_T("~u~s"), port,
obj,
FASL_READER_PORT(obj));
break;
case TC_UNBOUND_MARKER:
scwritef("#<UNBOUND-MARKER>", port);
break;
case TC_FREE_CELL:
scwritef("#<FREE CELL -- Forget a call to gc_mark? ~c&>", port, obj);
break;
default:
scwritef("#<INVALID OBJECT - UNKNOWN TYPE ~c&>", port, obj);
}
return port;
}
