[projects/cmucl/cmucl.git] / src / lisp / backtrace.c

/* 
 * Simple backtrace facility.  More or less from Rob's lisp version.
 */

#include <stdio.h>
#include <signal.h>
#include "lisp.h"
#include "internals.h"
#include "globals.h"
#include "os.h"
#include "interrupt.h"
#include "lispregs.h"

#if !(defined(i386) || defined(__x86_64))

/* Sigh ... I know what the call frame looks like and it had
   better not change. */

struct call_frame {
#ifndef alpha
    struct call_frame *old_cont;
#else
    u32 old_cont;
#endif
    lispobj saved_lra;
    lispobj code;
    lispobj other_state[5];
};

struct call_info {
#ifndef alpha
    struct call_frame *frame;
#else
    u32 frame;
#endif
    int interrupted;
#ifndef alpha
    struct code *code;
#else
    u32 code;
#endif
    lispobj lra;
    int pc;			/* Note: this is the trace file offset, not the actual pc. */
};

#define HEADER_LENGTH(header) ((header)>>8)

static int previous_info(struct call_info *info);

static struct code *
code_pointer(lispobj object)
{
    lispobj *headerp, header;
    int type, len;

    headerp = (lispobj *) PTR(object);
    header = *headerp;
    type = TypeOf(header);

    switch (type) {
      case type_CodeHeader:
	  break;
      case type_ReturnPcHeader:
      case type_FunctionHeader:
      case type_ClosureFunctionHeader:
	  len = HEADER_LENGTH(header);
	  if (len == 0)
	      headerp = NULL;
	  else
	      headerp -= len;
	  break;
      default:
	  headerp = NULL;
    }

    return (struct code *) headerp;
}

static boolean
cs_valid_pointer_p(struct call_frame *pointer)
{
    return (((char *) control_stack <= (char *) pointer) &&
	    ((char *) pointer < (char *) current_control_stack_pointer));
}

static void
info_from_lisp_state(struct call_info *info)
{
    info->frame = (struct call_frame *) current_control_frame_pointer;
    info->interrupted = 0;
    info->code = NULL;
    info->lra = 0;
    info->pc = 0;

    previous_info(info);
}

static void
info_from_sigcontext(struct call_info *info, os_context_t * csp)
{
    unsigned long pc;

    info->interrupted = 1;
    if (LowtagOf(SC_REG(csp, reg_CODE)) == type_FunctionPointer) {
	/* We tried to call a function, but crapped out before $CODE could be fixed up.  Probably an undefined function. */
	info->frame = (struct call_frame *) SC_REG(csp, reg_OCFP);
	info->lra = (lispobj) SC_REG(csp, reg_LRA);
	info->code = code_pointer(info->lra);
	pc = (unsigned long) PTR(info->lra);
    } else {
	info->frame = (struct call_frame *) SC_REG(csp, reg_CFP);
	info->code = code_pointer(SC_REG(csp, reg_CODE));
	info->lra = NIL;
	pc = SC_PC(csp);
    }
    if (info->code != NULL)
	info->pc = pc - (unsigned long) info->code -
#ifndef alpha
	    (HEADER_LENGTH(info->code->header) * sizeof(lispobj));
#else
	    (HEADER_LENGTH(((struct code *) info->code)->header) * sizeof(lispobj));
#endif
    else
	info->pc = 0;
}

static int
previous_info(struct call_info *info)
{
    struct call_frame *this_frame;
    int free;
    os_context_t *csp;

    if (!cs_valid_pointer_p(info->frame)) {
	printf("Bogus callee value (0x%08lx).\n", (unsigned long) info->frame);
	return 0;
    }

    this_frame = info->frame;
    info->lra = this_frame->saved_lra;
    info->frame = this_frame->old_cont;
    info->interrupted = 0;

    if (info->frame == NULL || info->frame == this_frame)
	return 0;

    if (info->lra == NIL) {
	/* We were interrupted.  Find the correct sigcontext. */
	free = SymbolValue(FREE_INTERRUPT_CONTEXT_INDEX) >> 2;
	while (free-- > 0) {
	    csp = lisp_interrupt_contexts[free];
	    if ((struct call_frame *) (SC_REG(csp, reg_CFP)) == info->frame) {
		info_from_sigcontext(info, csp);
		break;
	    }
	}
    } else {
	info->code = code_pointer(info->lra);
	if (info->code != NULL)
	    info->pc = (unsigned long) PTR(info->lra) -
		(unsigned long) info->code -
#ifndef alpha
		(HEADER_LENGTH(info->code->header) * sizeof(lispobj));
#else
		(HEADER_LENGTH(((struct code *) info->code)->header) * sizeof(lispobj));
#endif
	else
	    info->pc = 0;
    }

    return 1;
}

void
backtrace(int nframes)
{
    struct call_info info;

    info_from_lisp_state(&info);

    do {
	printf("<Frame 0x%08lx%s, ", (unsigned long) info.frame,
	       info.interrupted ? " [interrupted]" : "");

	if (info.code != (struct code *) 0) {
	    lispobj function;

	    printf("CODE: 0x%08lX, ",
		   (unsigned long) info.code | type_OtherPointer);

#ifndef alpha
	    function = info.code->entry_points;
#else
	    function = ((struct code *) info.code)->entry_points;
#endif
	    while (function != NIL) {
		struct function *header;
		lispobj name;

		header = (struct function *) PTR(function);
		name = header->name;

		if (LowtagOf(name) == type_OtherPointer) {
		    lispobj *object;

		    object = (lispobj *) PTR(name);

		    if (TypeOf(*object) == type_SymbolHeader) {
			struct symbol *symbol;

			symbol = (struct symbol *) object;
			object = (lispobj *) PTR(symbol->name);
		    }
		    if (TypeOf(*object) == type_SimpleString) {
			struct vector *string;
                        char c_string[1000];
			string = (struct vector *) object;
                        convert_lisp_string(c_string, string->data, string->length >> 2);
			printf("%s, ", c_string);
		    } else
			printf("(Not simple string??\?), ");
		} else
		    printf("(Not other pointer??\?), ");


		function = header->next;
	    }
	} else
	    printf("CODE: ???, ");

	if (info.lra != NIL)
	    printf("LRA: 0x%08lx, ", (unsigned long) info.lra);
	else
	    printf("<no LRA>, ");

	if (info.pc)
	    printf("PC: 0x%x>\n", info.pc);
	else
	    printf("PC: ??\?>\n");

    } while (--nframes > 0 && previous_info(&info));
}

#else /* (defined(i386) || defined(__x86_64)) */

#include "x86-validate.h"
#include "gc.h"

#define VM_OCFP_SAVE_OFFSET		0
#define VM_RETURN_PC_SAVE_OFFSET	1

static int
stack_pointer_p(unsigned long p)
{
    return (p < CONTROL_STACK_START + control_stack_size
	    && p > (unsigned long) &p && (p & 3) == 0);
}

static int
ra_pointer_p(unsigned long ra)
{
    return ra > 4096 && !stack_pointer_p(ra);
}

static unsigned long
deref(unsigned long p, int offset)
{
    return *((unsigned long *) p + offset);
}

static void
print_entry_name(lispobj name)
{
    if (LowtagOf(name) == type_ListPointer) {
	putchar('(');
	while (name != NIL) {
	    struct cons *cons = (struct cons *) PTR(name);

	    print_entry_name(cons->car);
	    name = cons->cdr;
	    if (name != NIL)
		putchar(' ');
	}
	putchar(')');
    } else if (LowtagOf(name) == type_OtherPointer) {
	lispobj *object = (lispobj *) PTR(name);

	if (TypeOf(*object) == type_SymbolHeader) {
	    struct symbol *symbol = (struct symbol *) object;
	    struct vector *string;
	    char c_string[1000];

	    if (symbol->package != NIL) {
		struct instance *pkg = (struct instance *) PTR(symbol->package);
		lispobj pkg_name = pkg->slots[2];

		string = (struct vector *) PTR(pkg_name);
		convert_lisp_string(c_string, string->data, string->length >> 2);
		printf("%s:;", c_string);
	    }

	    object = (lispobj *) PTR(symbol->name);
	    string = (struct vector *) object;
	    convert_lisp_string(c_string, string->data, string->length >> 2);
	    printf("%s:;", c_string);
	} else if (TypeOf(*object) == type_SimpleString) {
	    struct vector *string = (struct vector *) object;
	    char c_string[1000];
	    convert_lisp_string(c_string, string->data, string->length >> 2);
	    printf("\"%s\"", c_string);
	} else
	    printf("<??? type %d>", (int) TypeOf(*object));
    } else
	printf("<??? lowtag %d>", (int) LowtagOf(name));
}

static void
print_entry_points(struct code *code)
{
    lispobj function = code->entry_points;

    while (function != NIL) {
	struct function *header = (struct function *) PTR(function);

	print_entry_name(header->name);

	function = header->next;
	if (function != NIL)
	    printf(", ");
    }
}

/* See also X86-CALL-CONTEXT in code:debug-int.  */

static int
x86_call_context(unsigned long fp, unsigned long *ra, unsigned long *ocfp)
{
    unsigned long lisp_ocfp, lisp_ra, c_ocfp, c_ra;
    int lisp_valid_p, c_valid_p;

    if (!stack_pointer_p(fp))
	return 0;

    lisp_ocfp = deref(fp, -(1 + VM_OCFP_SAVE_OFFSET));
    lisp_ra = deref(fp, -(1 + VM_RETURN_PC_SAVE_OFFSET));
    c_ocfp = deref(fp, 0);
    c_ra = deref(fp, 1);

    lisp_valid_p = (lisp_ocfp > fp && stack_pointer_p(lisp_ocfp)
		    && ra_pointer_p(lisp_ra));
    c_valid_p = (c_ocfp > fp && stack_pointer_p(c_ocfp)
		 && ra_pointer_p(c_ra));

    if (lisp_valid_p && c_valid_p) {
	unsigned long lisp_path_fp, c_path_fp, dummy;
	int lisp_path_p = x86_call_context(lisp_ocfp, &lisp_path_fp, &dummy);
	int c_path_p = x86_call_context(c_ocfp, &c_path_fp, &dummy);

	if (lisp_path_p && c_path_p) {
#if defined __FreeBSD__ && __FreeBSD_version > 400000
	    if (lisp_ocfp > c_ocfp)
		*ra = lisp_ra, *ocfp = lisp_ocfp;
	    else
		*ra = c_ra, *ocfp = c_ocfp;
#else
	    *ra = lisp_ra, *ocfp = lisp_ocfp;
#endif
	} else if (lisp_path_p)
	    *ra = lisp_ra, *ocfp = lisp_ocfp;
	else if (c_path_p)
	    *ra = c_ra, *ocfp = c_ocfp;
	else
	    return 0;
    } else if (lisp_valid_p)
	*ra = lisp_ra, *ocfp = lisp_ocfp;
    else if (c_valid_p)
	*ra = c_ra, *ocfp = c_ocfp;
    else
	return 0;

    return 1;
}

struct compiled_debug_info {
    lispobj header;
    lispobj layout;
    lispobj name;
    lispobj source;
    lispobj package;
    lispobj function_map;
};

struct compiled_debug_function {
    lispobj header;
    lispobj layout;
    lispobj name;
    lispobj kind;
    lispobj variables;
    lispobj blocks;
    lispobj tlf_number;
    lispobj arguments;
    lispobj returns;
    lispobj return_pc;
    lispobj old_fp;
    lispobj nfp;
    lispobj start_pc;
    lispobj elsewhere_pc;
};

static int
array_of_type_p(lispobj obj, int type)
{
    return (LowtagOf(obj) == type_OtherPointer
	    && TypeOf(*(lispobj *) PTR(obj)) == type);
}

struct compiled_debug_function *
debug_function_from_pc(struct code *code, unsigned long pc)
{
    unsigned long code_header_len = sizeof(lispobj) * HeaderValue(code->header);
    unsigned long offset = pc - (unsigned long) code - code_header_len;

    if (LowtagOf(code->debug_info) == type_InstancePointer) {
	struct compiled_debug_info *di

	    = (struct compiled_debug_info *) PTR(code->debug_info);

	if (array_of_type_p(di->function_map, type_SimpleVector)) {
	    struct vector *v = (struct vector *) PTR(di->function_map);
	    long i, len = fixnum_value(v->length);
	    struct compiled_debug_function *df
		= (struct compiled_debug_function *) PTR(v->data[0]);

	    if (len == 1)
		return df;
	    else {
		int elsewhere_p = offset >= fixnum_value(df->elsewhere_pc);

		for (i = 1;; i += 2) {
		    unsigned long next_pc;

		    if (i == len)
			return ((struct compiled_debug_function *)
				PTR(v->data[i - 1]));

		    if (elsewhere_p) {
			struct compiled_debug_function *p
			    = ((struct compiled_debug_function *)
			       PTR(v->data[i + 1]));

			next_pc = fixnum_value(p->elsewhere_pc);
		    } else
			next_pc = fixnum_value(v->data[i]);

		    if (offset < next_pc)
			return ((struct compiled_debug_function *)
				PTR(v->data[i - 1]));
		}
	    }
	}
	    else if (array_of_type_p(di->function_map,
				     type_SimpleArrayUnsignedByte8)) {
	    /* Minimal debug info as described in debug-int.lisp.
	       Not implemented.  */
	}
    }

    return NULL;
}

void
backtrace(int nframes)
{
    unsigned long fp;
    int i;

    __asm__("movl %%ebp,%0":"=g"(fp));

    for (i = 0; i < nframes; ++i) {
	lispobj *p;
	unsigned long ra, next_fp;

	if (!x86_call_context(fp, &ra, &next_fp))
	    break;

	printf("%4d: ", i);

	p = (lispobj *) component_ptr_from_pc((lispobj *) ra);
	if (p && TypeOf(*p) == type_CodeHeader) {
	    struct code *cp = (struct code *) p;
	    struct compiled_debug_function *df;

	    df = debug_function_from_pc(cp, ra);
	    if (df)
		print_entry_name(df->name);
	    else
		print_entry_points(cp);
	} else if (p)
	    printf("<Not implemented, type = %d>", (int) TypeOf(*p));
	else
	    printf("Foreign fp = 0x%lx, ra = 0x%lx", next_fp, ra);

	putchar('\n');
	fp = next_fp;
    }
}

#endif /* (defined(i386) || defined(__x86_64)) */
Commit	Line	Data
eeab7066	1	/*
62957726	2	* Simple backtrace facility. More or less from Rob's lisp version.
	3	*/
	4
	5	#include <stdio.h>
	6	#include <signal.h>
	7	#include "lisp.h"
	8	#include "internals.h"
	9	#include "globals.h"
0cad57f3	10	#include "os.h"
62957726	11	#include "interrupt.h"
	12	#include "lispregs.h"
	13
777667de	14	#if !(defined(i386) \|\| defined(__x86_64))
62957726	15
	16	/* Sigh ... I know what the call frame looks like and it had
	17	better not change. */
	18
	19	struct call_frame {
6f4a04e5	20	#ifndef alpha
9a8c1c2f	21	struct call_frame *old_cont;
6f4a04e5	22	#else
9a8c1c2f	23	u32 old_cont;
6f4a04e5	24	#endif
9a8c1c2f	25	lispobj saved_lra;
	26	lispobj code;
	27	lispobj other_state[5];
62957726	28	};
	29
	30	struct call_info {
6f4a04e5	31	#ifndef alpha
62957726	32	struct call_frame *frame;
6f4a04e5	33	#else
	34	u32 frame;
	35	#endif
62957726	36	int interrupted;
6f4a04e5	37	#ifndef alpha
62957726	38	struct code *code;
6f4a04e5	39	#else
	40	u32 code;
	41	#endif
62957726	42	lispobj lra;
9a8c1c2f	43	int pc; /* Note: this is the trace file offset, not the actual pc. */
62957726	44	};
	45
	46	#define HEADER_LENGTH(header) ((header)>>8)
	47
	48	static int previous_info(struct call_info *info);
	49
	50	static struct code *
	51	code_pointer(lispobj object)
	52	{
	53	lispobj *headerp, header;
	54	int type, len;
	55
	56	headerp = (lispobj *) PTR(object);
	57	header = *headerp;
	58	type = TypeOf(header);
	59
	60	switch (type) {
9a8c1c2f	61	case type_CodeHeader:
	62	break;
	63	case type_ReturnPcHeader:
	64	case type_FunctionHeader:
	65	case type_ClosureFunctionHeader:
	66	len = HEADER_LENGTH(header);
	67	if (len == 0)
	68	headerp = NULL;
	69	else
	70	headerp -= len;
	71	break;
	72	default:
	73	headerp = NULL;
62957726	74	}
	75
	76	return (struct code *) headerp;
	77	}
	78
	79	static boolean
	80	cs_valid_pointer_p(struct call_frame *pointer)
	81	{
9a8c1c2f	82	return (((char ) control_stack <= (char ) pointer) &&
9a8c1c2f	83	((char ) pointer < (char ) current_control_stack_pointer));
62957726	84	}
	85
	86	static void
	87	info_from_lisp_state(struct call_info *info)
	88	{
9a8c1c2f	89	info->frame = (struct call_frame *) current_control_frame_pointer;
62957726	90	info->interrupted = 0;
	91	info->code = NULL;
	92	info->lra = 0;
	93	info->pc = 0;
	94
	95	previous_info(info);
	96	}
	97
	98	static void
9a8c1c2f	99	info_from_sigcontext(struct call_info info, os_context_t csp)
62957726	100	{
	101	unsigned long pc;
	102
	103	info->interrupted = 1;
	104	if (LowtagOf(SC_REG(csp, reg_CODE)) == type_FunctionPointer) {
9a8c1c2f	105	/* We tried to call a function, but crapped out before $CODE could be fixed up. Probably an undefined function. */
	106	info->frame = (struct call_frame *) SC_REG(csp, reg_OCFP);
	107	info->lra = (lispobj) SC_REG(csp, reg_LRA);
	108	info->code = code_pointer(info->lra);
	109	pc = (unsigned long) PTR(info->lra);
	110	} else {
	111	info->frame = (struct call_frame *) SC_REG(csp, reg_CFP);
	112	info->code = code_pointer(SC_REG(csp, reg_CODE));
	113	info->lra = NIL;
	114	pc = SC_PC(csp);
62957726	115	}
62957726	116	if (info->code != NULL)
9a8c1c2f	117	info->pc = pc - (unsigned long) info->code -
6f4a04e5	118	#ifndef alpha
9a8c1c2f	119	(HEADER_LENGTH(info->code->header) * sizeof(lispobj));
6f4a04e5	120	#else
9a8c1c2f	121	(HEADER_LENGTH(((struct code ) info->code)->header) sizeof(lispobj));
6f4a04e5	122	#endif
62957726	123	else
9a8c1c2f	124	info->pc = 0;
62957726	125	}
	126
	127	static int
	128	previous_info(struct call_info *info)
	129	{
	130	struct call_frame *this_frame;
	131	int free;
07b40fde	132	os_context_t *csp;
62957726	133
62957726	134	if (!cs_valid_pointer_p(info->frame)) {
9a8c1c2f	135	printf("Bogus callee value (0x%08lx).\n", (unsigned long) info->frame);
9a8c1c2f	136	return 0;
62957726	137	}
	138
	139	this_frame = info->frame;
	140	info->lra = this_frame->saved_lra;
	141	info->frame = this_frame->old_cont;
	142	info->interrupted = 0;
	143
	144	if (info->frame == NULL \|\| info->frame == this_frame)
9a8c1c2f	145	return 0;
62957726	146
62957726	147	if (info->lra == NIL) {
9a8c1c2f	148	/* We were interrupted. Find the correct sigcontext. */
	149	free = SymbolValue(FREE_INTERRUPT_CONTEXT_INDEX) >> 2;
	150	while (free-- > 0) {
	151	csp = lisp_interrupt_contexts[free];
	152	if ((struct call_frame *) (SC_REG(csp, reg_CFP)) == info->frame) {
	153	info_from_sigcontext(info, csp);
	154	break;
	155	}
	156	}
	157	} else {
	158	info->code = code_pointer(info->lra);
	159	if (info->code != NULL)
	160	info->pc = (unsigned long) PTR(info->lra) -
	161	(unsigned long) info->code -
6f4a04e5	162	#ifndef alpha
9a8c1c2f	163	(HEADER_LENGTH(info->code->header) * sizeof(lispobj));
6f4a04e5	164	#else
9a8c1c2f	165	(HEADER_LENGTH(((struct code ) info->code)->header) sizeof(lispobj));
6f4a04e5	166	#endif
9a8c1c2f	167	else
9a8c1c2f	168	info->pc = 0;
62957726	169	}
	170
	171	return 1;
	172	}
	173
	174	void
	175	backtrace(int nframes)
	176	{
	177	struct call_info info;
9a8c1c2f	178
62957726	179	info_from_lisp_state(&info);
	180
	181	do {
9a8c1c2f	182	printf("<Frame 0x%08lx%s, ", (unsigned long) info.frame,
	183	info.interrupted ? " [interrupted]" : "");
	184
	185	if (info.code != (struct code *) 0) {
	186	lispobj function;
62957726	187
9a8c1c2f	188	printf("CODE: 0x%08lX, ",
9a8c1c2f	189	(unsigned long) info.code \| type_OtherPointer);
62957726	190
6f4a04e5	191	#ifndef alpha
9a8c1c2f	192	function = info.code->entry_points;
6f4a04e5	193	#else
9a8c1c2f	194	function = ((struct code *) info.code)->entry_points;
6f4a04e5	195	#endif
9a8c1c2f	196	while (function != NIL) {
	197	struct function *header;
	198	lispobj name;
62957726	199
9a8c1c2f	200	header = (struct function *) PTR(function);
9a8c1c2f	201	name = header->name;
62957726	202
9a8c1c2f	203	if (LowtagOf(name) == type_OtherPointer) {
9a8c1c2f	204	lispobj *object;
62957726	205
9a8c1c2f	206	object = (lispobj *) PTR(name);
62957726	207
9a8c1c2f	208	if (TypeOf(*object) == type_SymbolHeader) {
9a8c1c2f	209	struct symbol *symbol;
62957726	210
9a8c1c2f	211	symbol = (struct symbol *) object;
	212	object = (lispobj *) PTR(symbol->name);
	213	}
	214	if (TypeOf(*object) == type_SimpleString) {
	215	struct vector *string;
68ac9a3e	216	char c_string[1000];
9a8c1c2f	217	string = (struct vector *) object;
68ac9a3e	218	convert_lisp_string(c_string, string->data, string->length >> 2);
68ac9a3e	219	printf("%s, ", c_string);
9a8c1c2f	220	} else
	221	printf("(Not simple string??\?), ");
	222	} else
	223	printf("(Not other pointer??\?), ");
62957726	224
62957726	225
9a8c1c2f	226	function = header->next;
	227	}
	228	} else
	229	printf("CODE: ???, ");
62957726	230
9a8c1c2f	231	if (info.lra != NIL)
	232	printf("LRA: 0x%08lx, ", (unsigned long) info.lra);
	233	else
	234	printf("<no LRA>, ");
62957726	235
9a8c1c2f	236	if (info.pc)
	237	printf("PC: 0x%x>\n", info.pc);
	238	else
	239	printf("PC: ??\?>\n");
62957726	240
	241	} while (--nframes > 0 && previous_info(&info));
	242	}
	243
113b409a	244	#else /* (defined(i386) \|\| defined(__x86_64)) */
49187a54	245
49187a54	246	#include "x86-validate.h"
284fd069	247	#include "gc.h"
49187a54	248
	249	#define VM_OCFP_SAVE_OFFSET 0
	250	#define VM_RETURN_PC_SAVE_OFFSET 1
	251
	252	static int
9a8c1c2f	253	stack_pointer_p(unsigned long p)
49187a54	254	{
44a8f0c7	255	return (p < CONTROL_STACK_START + control_stack_size
9a8c1c2f	256	&& p > (unsigned long) &p && (p & 3) == 0);
49187a54	257	}
	258
	259	static int
548945a3	260	ra_pointer_p(unsigned long ra)
49187a54	261	{
9a8c1c2f	262	return ra > 4096 && !stack_pointer_p(ra);
49187a54	263	}
49187a54	264
548945a3	265	static unsigned long
9a8c1c2f	266	deref(unsigned long p, int offset)
49187a54	267	{
9a8c1c2f	268	return ((unsigned long ) p + offset);
49187a54	269	}
	270
	271	static void
9a8c1c2f	272	print_entry_name(lispobj name)
49187a54	273	{
9a8c1c2f	274	if (LowtagOf(name) == type_ListPointer) {
	275	putchar('(');
	276	while (name != NIL) {
	277	struct cons cons = (struct cons ) PTR(name);
	278
	279	print_entry_name(cons->car);
	280	name = cons->cdr;
	281	if (name != NIL)
	282	putchar(' ');
9f94756e	283	}
9a8c1c2f	284	putchar(')');
	285	} else if (LowtagOf(name) == type_OtherPointer) {
	286	lispobj object = (lispobj ) PTR(name);
	287
	288	if (TypeOf(*object) == type_SymbolHeader) {
	289	struct symbol symbol = (struct symbol ) object;
	290	struct vector *string;
68ac9a3e	291	char c_string[1000];
9a8c1c2f	292
	293	if (symbol->package != NIL) {
	294	struct instance pkg = (struct instance ) PTR(symbol->package);
	295	lispobj pkg_name = pkg->slots[2];
	296
	297	string = (struct vector *) PTR(pkg_name);
68ac9a3e	298	convert_lisp_string(c_string, string->data, string->length >> 2);
68ac9a3e	299	printf("%s:;", c_string);
284fd069	300	}
9a8c1c2f	301
	302	object = (lispobj *) PTR(symbol->name);
	303	string = (struct vector *) object;
68ac9a3e	304	convert_lisp_string(c_string, string->data, string->length >> 2);
68ac9a3e	305	printf("%s:;", c_string);
9a8c1c2f	306	} else if (TypeOf(*object) == type_SimpleString) {
9a8c1c2f	307	struct vector string = (struct vector ) object;
68ac9a3e	308	char c_string[1000];
68ac9a3e	309	convert_lisp_string(c_string, string->data, string->length >> 2);
68ac9a3e	310	printf("\"%s\"", c_string);
9a8c1c2f	311	} else
	312	printf("<??? type %d>", (int) TypeOf(*object));
	313	} else
	314	printf("<??? lowtag %d>", (int) LowtagOf(name));
49187a54	315	}
9a8c1c2f	316
49187a54	317	static void
9a8c1c2f	318	print_entry_points(struct code *code)
62957726	319	{
9a8c1c2f	320	lispobj function = code->entry_points;
	321
	322	while (function != NIL) {
	323	struct function header = (struct function ) PTR(function);
	324
	325	print_entry_name(header->name);
	326
	327	function = header->next;
	328	if (function != NIL)
	329	printf(", ");
49187a54	330	}
62957726	331	}
62957726	332
49187a54	333	/* See also X86-CALL-CONTEXT in code:debug-int. */
	334
	335	static int
548945a3	336	x86_call_context(unsigned long fp, unsigned long ra, unsigned long ocfp)
49187a54	337	{
548945a3	338	unsigned long lisp_ocfp, lisp_ra, c_ocfp, c_ra;
9a8c1c2f	339	int lisp_valid_p, c_valid_p;
	340
	341	if (!stack_pointer_p(fp))
	342	return 0;
	343
	344	lisp_ocfp = deref(fp, -(1 + VM_OCFP_SAVE_OFFSET));
	345	lisp_ra = deref(fp, -(1 + VM_RETURN_PC_SAVE_OFFSET));
	346	c_ocfp = deref(fp, 0);
	347	c_ra = deref(fp, 1);
	348
	349	lisp_valid_p = (lisp_ocfp > fp && stack_pointer_p(lisp_ocfp)
	350	&& ra_pointer_p(lisp_ra));
	351	c_valid_p = (c_ocfp > fp && stack_pointer_p(c_ocfp)
	352	&& ra_pointer_p(c_ra));
	353
	354	if (lisp_valid_p && c_valid_p) {
548945a3	355	unsigned long lisp_path_fp, c_path_fp, dummy;
9a8c1c2f	356	int lisp_path_p = x86_call_context(lisp_ocfp, &lisp_path_fp, &dummy);
	357	int c_path_p = x86_call_context(c_ocfp, &c_path_fp, &dummy);
	358
	359	if (lisp_path_p && c_path_p) {
49187a54	360	#if defined __FreeBSD__ && __FreeBSD_version > 400000
9a8c1c2f	361	if (lisp_ocfp > c_ocfp)
	362	ra = lisp_ra, ocfp = lisp_ocfp;
	363	else
	364	ra = c_ra, ocfp = c_ocfp;
49187a54	365	#else
9a8c1c2f	366	ra = lisp_ra, ocfp = lisp_ocfp;
62957726	367	#endif
9a8c1c2f	368	} else if (lisp_path_p)
	369	ra = lisp_ra, ocfp = lisp_ocfp;
	370	else if (c_path_p)
	371	ra = c_ra, ocfp = c_ocfp;
	372	else
	373	return 0;
	374	} else if (lisp_valid_p)
49187a54	375	ra = lisp_ra, ocfp = lisp_ocfp;
9a8c1c2f	376	else if (c_valid_p)
49187a54	377	ra = c_ra, ocfp = c_ocfp;
9a8c1c2f	378	else
49187a54	379	return 0;
9a8c1c2f	380
9a8c1c2f	381	return 1;
49187a54	382	}
49187a54	383
9a8c1c2f	384	struct compiled_debug_info {
	385	lispobj header;
	386	lispobj layout;
	387	lispobj name;
	388	lispobj source;
	389	lispobj package;
	390	lispobj function_map;
284fd069	391	};
284fd069	392
9a8c1c2f	393	struct compiled_debug_function {
	394	lispobj header;
	395	lispobj layout;
	396	lispobj name;
	397	lispobj kind;
	398	lispobj variables;
	399	lispobj blocks;
	400	lispobj tlf_number;
	401	lispobj arguments;
	402	lispobj returns;
	403	lispobj return_pc;
	404	lispobj old_fp;
	405	lispobj nfp;
	406	lispobj start_pc;
	407	lispobj elsewhere_pc;
284fd069	408	};
	409
	410	static int
9a8c1c2f	411	array_of_type_p(lispobj obj, int type)
284fd069	412	{
9a8c1c2f	413	return (LowtagOf(obj) == type_OtherPointer
9a8c1c2f	414	&& TypeOf((lispobj ) PTR(obj)) == type);
284fd069	415	}
	416
	417	struct compiled_debug_function *
9a8c1c2f	418	debug_function_from_pc(struct code *code, unsigned long pc)
284fd069	419	{
548945a3	420	unsigned long code_header_len = sizeof(lispobj) * HeaderValue(code->header);
548945a3	421	unsigned long offset = pc - (unsigned long) code - code_header_len;
9a8c1c2f	422
	423	if (LowtagOf(code->debug_info) == type_InstancePointer) {
	424	struct compiled_debug_info *di
	425
	426	= (struct compiled_debug_info *) PTR(code->debug_info);
	427
	428	if (array_of_type_p(di->function_map, type_SimpleVector)) {
	429	struct vector v = (struct vector ) PTR(di->function_map);
548945a3	430	long i, len = fixnum_value(v->length);
9a8c1c2f	431	struct compiled_debug_function *df
	432	= (struct compiled_debug_function *) PTR(v->data[0]);
	433
	434	if (len == 1)
	435	return df;
	436	else {
	437	int elsewhere_p = offset >= fixnum_value(df->elsewhere_pc);
	438
	439	for (i = 1;; i += 2) {
548945a3	440	unsigned long next_pc;
284fd069	441
9a8c1c2f	442	if (i == len)
	443	return ((struct compiled_debug_function *)
	444	PTR(v->data[i - 1]));
	445
	446	if (elsewhere_p) {
	447	struct compiled_debug_function *p
	448	= ((struct compiled_debug_function *)
	449	PTR(v->data[i + 1]));
	450
	451	next_pc = fixnum_value(p->elsewhere_pc);
	452	} else
	453	next_pc = fixnum_value(v->data[i]);
	454
	455	if (offset < next_pc)
	456	return ((struct compiled_debug_function *)
	457	PTR(v->data[i - 1]));
284fd069	458	}
	459	}
	460	}
9a8c1c2f	461	else if (array_of_type_p(di->function_map,
	462	type_SimpleArrayUnsignedByte8)) {
	463	/* Minimal debug info as described in debug-int.lisp.
	464	Not implemented. */
284fd069	465	}
	466	}
	467
9a8c1c2f	468	return NULL;
284fd069	469	}
284fd069	470
49187a54	471	void
9a8c1c2f	472	backtrace(int nframes)
49187a54	473	{
548945a3	474	unsigned long fp;
9a8c1c2f	475	int i;
9a8c1c2f	476
d01310f2	477	__asm__("movl %%ebp,%0":"=g"(fp));
d01310f2	478
9a8c1c2f	479	for (i = 0; i < nframes; ++i) {
9a8c1c2f	480	lispobj *p;
548945a3	481	unsigned long ra, next_fp;
9a8c1c2f	482
	483	if (!x86_call_context(fp, &ra, &next_fp))
	484	break;
	485
	486	printf("%4d: ", i);
	487
	488	p = (lispobj ) component_ptr_from_pc((lispobj ) ra);
	489	if (p && TypeOf(*p) == type_CodeHeader) {
	490	struct code cp = (struct code ) p;
	491	struct compiled_debug_function *df;
	492
	493	df = debug_function_from_pc(cp, ra);
	494	if (df)
	495	print_entry_name(df->name);
	496	else
	497	print_entry_points(cp);
	498	} else if (p)
	499	printf("<Not implemented, type = %d>", (int) TypeOf(*p));
	500	else
548945a3	501	printf("Foreign fp = 0x%lx, ra = 0x%lx", next_fp, ra);
9a8c1c2f	502
	503	putchar('\n');
	504	fp = next_fp;
49187a54	505	}
	506	}
	507
113b409a	508	#endif /* (defined(i386) \|\| defined(__x86_64)) */