factor/vm/debug.c

#include "master.h"

void print_chars(F_STRING* str)
{
	CELL i;
	for(i = 0; i < string_capacity(str); i++)
		putchar(string_nth(str,i));
}

void print_word(F_WORD* word, CELL nesting)
{

	if(type_of(word->vocabulary) == STRING_TYPE)
	{
		print_chars(untag_string(word->vocabulary));
		printf(":");
	}
	
	if(type_of(word->name) == STRING_TYPE)
		print_chars(untag_string(word->name));
	else
	{
		printf("#<not a string: ");
		print_nested_obj(word->name,nesting);
		printf(">");
	}
}

void print_string(F_STRING* str)
{
	putchar('"');
	print_chars(str);
	putchar('"');
}

void print_array(F_ARRAY* array, CELL nesting)
{
	CELL length = array_capacity(array);
	CELL i;
	bool trimmed;

	if(length > 10)
	{
		trimmed = true;
		length = 10;
	}
	else
		trimmed = false;

	for(i = 0; i < length; i++)
	{
		printf(" ");
		print_nested_obj(array_nth(array,i),nesting);
	}

	if(trimmed)
		printf("...");
}

void print_tuple(F_TUPLE* tuple, CELL nesting)
{
	F_TUPLE_LAYOUT *layout = untag_object(tuple->layout);
	CELL length = to_fixnum(layout->size);

	printf(" ");
	print_nested_obj(layout->class,nesting);

	CELL i;
	bool trimmed;

	if(length > 10)
	{
		trimmed = true;
		length = 10;
	}
	else
		trimmed = false;

	for(i = 0; i < length; i++)
	{
		printf(" ");
		print_nested_obj(tuple_nth(tuple,i),nesting);
	}

	if(trimmed)
		printf("...");
}

void print_nested_obj(CELL obj, F_FIXNUM nesting)
{
	if(nesting <= 0)
	{
		printf(" ... ");
		return;
	}

	F_QUOTATION *quot;

	switch(type_of(obj))
	{
	case FIXNUM_TYPE:
		printf("%ld",untag_fixnum_fast(obj));
		break;
	case WORD_TYPE:
		print_word(untag_word(obj),nesting - 1);
		break;
	case STRING_TYPE:
		print_string(untag_string(obj));
		break;
	case F_TYPE:
		printf("f");
		break;
	case TUPLE_TYPE:
		printf("T{");
		print_tuple(untag_object(obj),nesting - 1);
		printf(" }");
		break;
	case ARRAY_TYPE:
		printf("{");
		print_array(untag_object(obj),nesting - 1);
		printf(" }");
		break;
	case QUOTATION_TYPE:
		printf("[");
		quot = untag_object(obj);
		print_array(untag_object(quot->array),nesting - 1);
		printf(" ]");
		break;
	default:
		printf("#<type %ld @ %lx>",type_of(obj),obj);
		break;
	}
}

void print_obj(CELL obj)
{
	print_nested_obj(obj,10);
}

void print_objects(CELL start, CELL end)
{
	for(; start <= end; start += CELLS)
	{
		print_obj(get(start));
		printf("\n");
	}
}

void print_datastack(void)
{
	printf("==== DATA STACK:\n");
	print_objects(ds_bot,ds);
}

void print_retainstack(void)
{
	printf("==== RETAIN STACK:\n");
	print_objects(rs_bot,rs);
}

void print_stack_frame(F_STACK_FRAME *frame)
{
	print_obj(frame_executing(frame));
	printf("\n");
	print_obj(frame_scan(frame));
	printf("\n");
	printf("%lx\n",(CELL)frame_executing(frame));
	printf("%lx\n",(CELL)frame->xt);
}

void print_callstack(void)
{
	printf("==== CALL STACK:\n");
	CELL bottom = (CELL)stack_chain->callstack_bottom;
	CELL top = (CELL)stack_chain->callstack_top;
	iterate_callstack(top,bottom,print_stack_frame);
}

void dump_cell(CELL cell)
{
	printf("%08lx: ",cell);

	cell = get(cell);

	printf("%08lx tag %ld",cell,TAG(cell));

	switch(TAG(cell))
	{
	case OBJECT_TYPE:
	case BIGNUM_TYPE:
	case FLOAT_TYPE:
		if(cell == F)
			printf(" -- F");
		else if(cell < TYPE_COUNT<<TAG_BITS)
			printf(" -- possible header: %ld",cell>>TAG_BITS);
		else if(cell >= data_heap->segment->start
			&& cell < data_heap->segment->end)
		{
			CELL header = get(UNTAG(cell));
			CELL type = header>>TAG_BITS;
			printf(" -- object; ");
			if(TAG(header) == 0 && type < TYPE_COUNT)
				printf(" type %ld",type);
			else
				printf(" header corrupt");
		}
		break;
	}
	
	printf("\n");
}

void dump_memory(CELL from, CELL to)
{
	from = UNTAG(from);

	for(; from <= to; from += CELLS)
		dump_cell(from);
}

void dump_zone(F_ZONE *z)
{
	printf("start=%ld, size=%ld, here=%ld\n",
		z->start,z->size,z->here - z->start);
}

void dump_generations(void)
{
	int i;

	printf("Nursery: ");
	dump_zone(&nursery);
	
	for(i = 1; i < data_heap->gen_count; i++)
	{
		printf("Generation %d: ",i);
		dump_zone(&data_heap->generations[i]);
	}

	for(i = 0; i < data_heap->gen_count; i++)
	{
		printf("Semispace %d: ",i);
		dump_zone(&data_heap->semispaces[i]);
	}

	printf("Cards: base=%lx, size=%lx\n",
		(CELL)data_heap->cards,
		(CELL)(data_heap->cards_end - data_heap->cards));
}

void dump_objects(F_FIXNUM type)
{
	gc();
	begin_scan();

	CELL obj;
	while((obj = next_object()) != F)
	{
		if(type == -1 || type_of(obj) == type)
		{
			printf("%lx ",obj);
			print_nested_obj(obj,2);
			printf("\n");
		}
	}

	/* end scan */
	gc_off = false;
}

CELL look_for;
CELL obj;

void find_data_references_step(CELL *scan)
{
	if(look_for == *scan)
	{
		printf("%lx ",obj);
		print_nested_obj(obj,2);
		printf("\n");
	}
}

void find_data_references(CELL look_for_)
{
	look_for = look_for_;

	begin_scan();

	while((obj = next_object()) != F)
		do_slots(UNTAG(obj),find_data_references_step);

	/* end scan */
	gc_off = false;
}

CELL look_for;

void find_code_references_step(F_COMPILED *compiled, CELL code_start, CELL literals_start)
{
	CELL scan;
	CELL literal_end = literals_start + compiled->literals_length;

	for(scan = literals_start; scan < literal_end; scan += CELLS)
	{
		CELL code_start = (CELL)(compiled + 1);
		CELL literal_start = code_start + compiled->code_length;

		CELL obj = get(literal_start);

		if(look_for == get(scan))
		{
			printf("%lx ",obj);
			print_nested_obj(obj,2);
			printf("\n");
		}
	}
}

void find_code_references(CELL look_for_)
{
	look_for = look_for_;
	iterate_code_heap(find_code_references_step);
}

void factorbug(void)
{
	open_console();

	printf("Starting low level debugger...\n");
	printf("  Basic commands:\n");
	printf("q                -- continue executing Factor - NOT SAFE\n");
	printf("im               -- save image to fep.image\n");
	printf("x                -- exit Factor\n");
	printf("  Advanced commands:\n");
	printf("d <addr> <count> -- dump memory\n");
	printf("u <addr>         -- dump object at tagged <addr>\n");
	printf(". <addr>         -- print object at tagged <addr>\n");
	printf("s r              -- dump data, retain stacks\n");
	printf(".s .r .c         -- print data, retain, call stacks\n");
	printf("e                -- dump environment\n");
	printf("g                -- dump generations\n");
	printf("card <addr>      -- print card containing address\n");
	printf("addr <card>      -- print address containing card\n");
	printf("data             -- data heap dump\n");
	printf("words            -- words dump\n");
	printf("tuples           -- tuples dump\n");
	printf("refs <addr>      -- find data heap references to object\n");
	printf("push <addr>      -- push object on data stack - NOT SAFE\n");
	printf("code             -- code heap dump\n");

	bool seen_command = false;

	for(;;)
	{
		char cmd[1024];

		printf("READY\n");
		fflush(stdout);

		if(scanf("%1000s",cmd) <= 0)
		{
			if(!seen_command)
			{
				/* If we exit with an EOF immediately, then
				dump stacks. This is useful for builder and
				other cases where Factor is run with stdin
				redirected to /dev/null */
				print_datastack();
				print_retainstack();
				print_callstack();
			}

			exit(1);
		}

		seen_command = true;

		if(strcmp(cmd,"d") == 0)
		{
			CELL addr, count;
			scanf("%lx %lx",&addr,&count);
			dump_memory(addr,addr+count);
		}
		if(strcmp(cmd,"u") == 0)
		{
			CELL addr, count;
			scanf("%lx",&addr);
			count = object_size(addr);
			dump_memory(addr,addr+count);
		}
		else if(strcmp(cmd,".") == 0)
		{
			CELL addr;
			scanf("%lx",&addr);
			print_obj(addr);
			printf("\n");
		}
		else if(strcmp(cmd,"s") == 0)
			dump_memory(ds_bot,ds);
		else if(strcmp(cmd,"r") == 0)
			dump_memory(rs_bot,rs);
		else if(strcmp(cmd,".s") == 0)
			print_datastack();
		else if(strcmp(cmd,".r") == 0)
			print_retainstack();
		else if(strcmp(cmd,".c") == 0)
			print_callstack();
		else if(strcmp(cmd,"e") == 0)
		{
			int i;
			for(i = 0; i < USER_ENV; i++)
				dump_cell((CELL)&userenv[i]);
		}
		else if(strcmp(cmd,"g") == 0)
			dump_generations();
		else if(strcmp(cmd,"card") == 0)
		{
			CELL addr;
			scanf("%lx",&addr);
			printf("%lx\n",(CELL)ADDR_TO_CARD(addr));
		}
		else if(strcmp(cmd,"addr") == 0)
		{
			CELL card;
			scanf("%lx",&card);
			printf("%lx\n",(CELL)CARD_TO_ADDR(card));
		}
		else if(strcmp(cmd,"q") == 0)
			return;
		else if(strcmp(cmd,"x") == 0)
			exit(1);
		else if(strcmp(cmd,"im") == 0)
			save_image(STR_FORMAT("fep.image"));
		else if(strcmp(cmd,"data") == 0)
			dump_objects(-1);
		else if(strcmp(cmd,"refs") == 0)
		{
			CELL addr;
			scanf("%lx",&addr);
			printf("Data heap references:\n");
			find_data_references(addr);
			printf("Code heap references:\n");
			find_code_references(addr);
			printf("\n");
		}
		else if(strcmp(cmd,"words") == 0)
			dump_objects(WORD_TYPE);
		else if(strcmp(cmd,"tuples") == 0)
			dump_objects(TUPLE_TYPE);
		else if(strcmp(cmd,"push") == 0)
		{
			CELL addr;
			scanf("%lx",&addr);
			dpush(addr);
		}
		else if(strcmp(cmd,"code") == 0)
			dump_heap(&code_heap);
		else
			printf("unknown command\n");
	}
}

DEFINE_PRIMITIVE(die)
{
	fprintf(stderr,"The die word was called by the library. Unless you called it yourself,\n");
	fprintf(stderr,"you have triggered a bug in Factor. Please report.\n");
	factorbug();
}