From b1bb63cb1524c17849251811855b3386a2816359 Mon Sep 17 00:00:00 2001
From: wlott <wlott>
Date: Thu, 24 May 1990 17:46:11 +0000
Subject: [PATCH] Lots of changes re call.  Call-into-c and handle-now now
 allocate lisp stack frames and preserve the frame pointer.  Backtrace now
 gives a complete backtrace, not just from the last sigcontext.

---
 ldb/backtrace.c  | 143 +++++++++++++++++++++++++----------------------
 ldb/globals.c    |   4 +-
 ldb/globals.h    |   4 +-
 ldb/interrupt.c  |  87 ++++++++++++++++++++++++----
 ldb/mips-assem.s |  42 ++++++++------
 ldb/monitor.c    |  24 ++++----
 6 files changed, 196 insertions(+), 108 deletions(-)

diff --git a/ldb/backtrace.c b/ldb/backtrace.c
index d454b61e8..5402e2988 100644
--- a/ldb/backtrace.c
+++ b/ldb/backtrace.c
@@ -1,4 +1,4 @@
-/* $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/ldb/Attic/backtrace.c,v 1.3 1990/04/27 01:55:15 wlott Exp $
+/* $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/ldb/Attic/backtrace.c,v 1.4 1990/05/24 17:46:03 wlott Exp $
  *
  * Simple backtrace facility.  More or less from Rob's lisp version.
  */
@@ -22,6 +22,7 @@ struct call_frame {
 
 struct call_info {
     struct call_frame *frame;
+    int interrupted;
     struct code *code;
     lispobj lra;
     int pc; /* Note: this is the trace file offset, not the actual pc. */
@@ -33,53 +34,30 @@ static struct code *
 code_pointer(object)
 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
-struct call_frame *
-current_cont()
-{
-        int free;
+    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;
+    }
 
-	free = SymbolValue(FREE_INTERRUPT_CONTEXT_INDEX)>>2;
-	
-        if (free == 0)
-            return NULL;
-        else {
-            struct sigcontext *csp;
-            struct call_frame *cont;
-
-            csp = lisp_interrupt_contexts[free-1];
-            cont = (struct call_frame *)csp->sc_regs[CONT];
-            if ((lispobj *)cont == current_control_stack_pointer)
-                /* We were attempting to call an undefined function. */
-                ;
-            return cont;
-        }
+    return (struct code *) headerp;
 }
 
 static
@@ -90,6 +68,19 @@ struct call_frame *pointer;
 		((char *) pointer < (char *) current_control_stack_pointer));
 }
 
+static void
+info_from_lisp_state(info)
+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(info, csp)
 struct call_info *info;
@@ -97,8 +88,8 @@ struct sigcontext *csp;
 {
     unsigned long pc;
 
-    if (csp->sc_regs[CONT] == csp->sc_regs[CSP]) {
-        /* We were attempting to call an undefined function. */
+    if (LowtagOf(csp->sc_regs[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 *)csp->sc_regs[OLDCONT];
         info->lra = (lispobj)csp->sc_regs[LRA];
         info->code = code_pointer(info->lra);
@@ -111,7 +102,7 @@ struct sigcontext *csp;
         pc = csp->sc_pc;
     }
     if (info->code != NULL)
-        info->pc = (pc - (unsigned long) info->code) / sizeof(lispobj) - HEADER_LENGTH(info->code->header);
+        info->pc = pc - (unsigned long) info->code - HEADER_LENGTH(info->code->header);
     else
         info->pc = 0;
 }
@@ -120,23 +111,41 @@ static int
 previous_info(info)
 struct call_info *info;
 {
+    struct call_frame *this_frame;
+    int free;
+    struct sigcontext *csp;
+
     if (!cs_valid_pointer_p(info->frame)) {
         printf("Bogus callee value (0x%08x).\n", (unsigned long)info->frame);
         return 0;
     }
 
-    info->lra = info->frame->saved_lra;
-    info->frame = info->frame->old_cont;
+    this_frame = info->frame;
+    info->lra = this_frame->saved_lra;
+    info->frame = this_frame->old_cont;
 
-    if (info->frame == NULL)
+    if (info->frame == NULL || info->frame == this_frame)
         return 0;
 
     info->code = code_pointer(info->lra);
-    if (info->code != NULL)
+
+    if (info->code == (struct code *)PTR(info->lra)) {
+        /* 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 *)(csp->sc_regs[CONT]) == info->frame)
+                info_from_sigcontext(info, csp);
+        }
+        info->interrupted = 1;
+    }
+    else if (info->code != NULL)
         info->pc = ((unsigned long)PTR(info->lra) - (unsigned long) info->code) / sizeof(lispobj) - HEADER_LENGTH(info->code->header);
     else
         info->pc = 0;
 
+        
+
     return 1;
 }
 
@@ -145,25 +154,18 @@ backtrace(nframes)
 int nframes;
 {
     struct call_info info;
-    int free;
-
-    free = SymbolValue(FREE_INTERRUPT_CONTEXT_INDEX)>>2;
 	
-    if (free == 0) {
-        printf("Nothing to backtrace.\n");
-        return;
-    }
-
-    info_from_sigcontext(&info, lisp_interrupt_contexts[free-1]);
+    info_from_lisp_state(&info);
 
     do {
-        printf("<Frame 0x%08x, CODE: 0x%08x, ",
-               (unsigned long) info.frame,
-               (unsigned long) info.code);
-
+        printf("<Frame 0x%08x%s, ", (unsigned long) info.frame,
+                info.interrupted ? " [interrupted]" : "");
+        
         if (info.code != (struct code *) 0) {
             lispobj function;
 
+            printf("CODE: 0x%08x, ", (unsigned long) info.code | type_OtherPointer);
+
             function = info.code->entry_points;
             while (function != NIL) {
                 struct function_header *header;
@@ -197,13 +199,18 @@ int nframes;
                 function = header->next;
             }
         }
+        else
+            printf("CODE: ???, ");
 
         if (info.lra != 0)
             printf("LRA: 0x%08x, ", (unsigned long)info.lra);
         else
             printf("<no LRA>, ");
 
-        printf("PC: %d>\n", info.pc);
+        if (info.pc)
+            printf("PC: 0x%x>\n", info.pc);
+        else
+            printf("PC: ???>\n");
 
     } while (--nframes > 0 && previous_info(&info));
 }
diff --git a/ldb/globals.c b/ldb/globals.c
index 6fb398860..9863b3393 100644
--- a/ldb/globals.c
+++ b/ldb/globals.c
@@ -1,4 +1,4 @@
-/* $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/ldb/Attic/globals.c,v 1.1 1990/03/28 22:47:26 ch Exp $ */
+/* $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/ldb/Attic/globals.c,v 1.2 1990/05/24 17:46:05 wlott Exp $ */
 
 /* Variables everybody needs to look at or frob on. */
 
@@ -10,6 +10,7 @@ int foreign_function_call_active;
 unsigned long saved_global_pointer;
 
 lispobj *current_control_stack_pointer;
+lispobj *current_control_frame_pointer;
 lispobj *current_binding_stack_pointer;
 unsigned long current_flags_register;
 
@@ -36,6 +37,7 @@ globals_init()
 
 	/* Initialize the current lisp state. */
 	current_control_stack_pointer = control_stack;
+	current_control_frame_pointer = (lispobj *)0;
 	current_binding_stack_pointer = binding_stack;
 	current_flags_register = 1<<flag_Atomic;
 }
diff --git a/ldb/globals.h b/ldb/globals.h
index 68d838f64..2f08a3681 100644
--- a/ldb/globals.h
+++ b/ldb/globals.h
@@ -1,4 +1,4 @@
-/* $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/ldb/Attic/globals.h,v 1.1 1990/03/28 22:47:35 ch Exp $ */
+/* $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/ldb/Attic/globals.h,v 1.2 1990/05/24 17:46:07 wlott Exp $ */
 
 #if !defined(_INCLUDE_GLOBALS_H_)
 #define _INCLUDED_GLOBALS_H_
@@ -12,6 +12,7 @@ extern int foreign_function_call_active;
 extern unsigned long saved_global_pointer;
 
 extern lispobj *current_control_stack_pointer;
+extern lispobj *current_control_frame_pointer;
 extern lispobj *current_binding_stack_pointer;
 extern unsigned long current_flags_register;
 
@@ -33,6 +34,7 @@ extern lispobj *current_dynamic_space_free_pointer;
 
 .extern current_dynamic_space_free_pointer 4
 .extern current_control_stack_pointer 4
+.extern current_control_frame_pointer 4
 .extern current_binding_stack_pointer 4
 .extern current_flags_register 4
 
diff --git a/ldb/interrupt.c b/ldb/interrupt.c
index f9e830cde..3e43ba52c 100644
--- a/ldb/interrupt.c
+++ b/ldb/interrupt.c
@@ -1,4 +1,4 @@
-/* $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/ldb/Attic/interrupt.c,v 1.3 1990/03/29 21:19:34 ch Exp $ */
+/* $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/ldb/Attic/interrupt.c,v 1.4 1990/05/24 17:46:09 wlott Exp $ */
 
 /* Interrupt handing magic. */
 
@@ -24,7 +24,7 @@ struct sigcontext *context;
 {
 	int were_in_lisp;
 	union interrupt_handler handler;
-	lispobj args[6];	/* Six is the minimum */
+	lispobj *args;
 	lispobj callname, function;
 
 	handler = interrupt_handlers[signal];
@@ -36,12 +36,20 @@ struct sigcontext *context;
 		/* Get current LISP state from context */
 		current_dynamic_space_free_pointer =
 			(lispobj *) context->sc_regs[ALLOC];
-		current_control_stack_pointer =
-			(lispobj *) context->sc_regs[CSP];
 		current_binding_stack_pointer =
 			(lispobj *) context->sc_regs[BSP];
 		current_flags_register = context->sc_regs[FLAGS]|(1<<flag_Atomic);
 
+                /* Build a fake stack frame */
+                current_control_frame_pointer =
+                        (lispobj *) context->sc_regs[CSP];
+                current_control_stack_pointer = 
+                        current_control_frame_pointer + 8;
+                current_control_frame_pointer[0] =
+                        context->sc_regs[CONT];
+                current_control_frame_pointer[1] = 
+                        context->sc_regs[CODE];
+
 		/* Restore the GP */
 		set_global_pointer(saved_global_pointer);
 
@@ -68,6 +76,8 @@ struct sigcontext *context;
 	    LowtagOf(handler.lisp) == type_OddFixnum)
 		(*handler.c)(signal, code, context);
 	else {
+                args = current_control_stack_pointer;
+                current_control_stack_pointer += 3;
 		args[0] = fixnum(signal);
 		args[1] = fixnum(code);
 		args[2] = alloc_sap(context);
@@ -152,18 +162,71 @@ struct sigcontext *context;
 	handle_now(signal, code, context);
 }
 
-static fpe_handler(signal, code, context)
-int signal, code;
+#define FIXNUM_VALUE(lispobj) (((int)lispobj)>>2)
+
+static boolean handle_integer_overflow(context)
 struct sigcontext *context;
 {
-	switch (signal) {
-        case EXC_OV:
-		/* integer overflow.  Make a bignum. */
-		/* For now, drop through. */
+    unsigned long bad_inst;
+    unsigned int op, rs, rt, rd, funct, dest;
+    int immed;
+    long result;
+
+    if (context->sc_cause & CAUSE_BD)
+        bad_inst = *(unsigned long *)(context->sc_pc + 4);
+    else
+        bad_inst = *(unsigned long *)(context->sc_pc);
+
+    op = (bad_inst >> 26) & 0x3f;
+    rs = (bad_inst >> 21) & 0x1f;
+    rt = (bad_inst >> 15) & 0x1f;
+    rd = (bad_inst >> 10) & 0x1f;
+    funct = bad_inst & 0x3f;
+    immed = (((int)(bad_inst & 0xffff)) << 16) >> 16;
+
+    switch (op) {
+        case 0x0: /* SPECIAL */
+            switch (funct) {
+                case 0x20: /* ADD */
+                    result = FIXNUM_VALUE(context->sc_regs[rs]) + FIXNUM_VALUE(context->sc_regs[rt]);
+                    dest = rd;
+                    break;
+
+                case 0x22: /* SUB */
+                    result = FIXNUM_VALUE(context->sc_regs[rs]) - FIXNUM_VALUE(context->sc_regs[rt]);
+                    dest = rd;
+                    break;
+
+                default:
+                    return FALSE;
+            }
+            
+        case 0x8: /* ADDI */
+            result = FIXNUM_VALUE(context->sc_regs[rs]) + (immed>>2);
+            dest = rt;
+            break;
 
         default:
-		handle_now(signal, code, context);
-	}
+            return FALSE;
+    }
+
+    context->sc_regs[dest] = alloc_number(result);
+
+    /* Skip the offending instruction */
+    if (context->sc_cause & CAUSE_BD)
+        emulate_branch(context, *(unsigned long *)context->sc_pc);
+    else
+        context->sc_pc += 4;
+
+    return TRUE;
+}
+
+static fpe_handler(signal, code, context)
+int signal, code;
+struct sigcontext *context;
+{
+    if ((context->sc_cause & CAUSE_EXCMASK) != EXC_OV || !handle_integer_overflow(context))
+        handle_now(signal, code, context);
 }
 
 void install_handler(signal, handler)
diff --git a/ldb/mips-assem.s b/ldb/mips-assem.s
index ce641e61e..89569d389 100644
--- a/ldb/mips-assem.s
+++ b/ldb/mips-assem.s
@@ -1,4 +1,4 @@
-/* $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/ldb/Attic/mips-assem.s,v 1.4 1990/04/02 23:50:26 wlott Exp $ */
+/* $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/ldb/Attic/mips-assem.s,v 1.5 1990/05/24 17:44:00 wlott Exp $ */
 #include <machine/regdef.h>
 
 #include "lisp.h"
@@ -84,6 +84,7 @@ call_into_lisp:
 	lw	ALLOC, current_dynamic_space_free_pointer
 	lw	BSP, current_binding_stack_pointer
 	lw	CSP, current_control_stack_pointer
+	lw	OLDCONT, current_control_frame_pointer
 
 	/* Check for interrupt */
 	and	FLAGS, (0xffff^(1<<flag_Atomic))
@@ -100,22 +101,18 @@ call_into_lisp:
 	/* Pass in args */
 	move	CNAME, $4
 	move	LEXENV, $5
-	move	ARGS, $6
+	move	CONT, $6
 	sll	NARGS, $7, 2
-	lw	A0, 0(ARGS)
-	lw	A1, 4(ARGS)
-	lw	A2, 8(ARGS)
-	lw	A3, 12(ARGS)
-	lw	A4, 16(ARGS)
-	lw	A5, 20(ARGS)
+	lw	A0, 0(CONT)
+	lw	A1, 4(CONT)
+	lw	A2, 8(CONT)
+	lw	A3, 12(CONT)
+	lw	A4, 16(CONT)
+	lw	A5, 20(CONT)
 
 	/* Calculate LRA */
 	la	LRA, lra + type_OtherPointer
 
-	/* Establish context pointers */
-	move	OLDCONT, $0 /* C doesn't have a context ptr */
-	move	CONT, CSP
-
 	/* Indirect closure */
 	lw	CODE, 4-1(LEXENV)
 
@@ -130,7 +127,7 @@ lra:
 	.word	type_ReturnPcHeader
 
 	/* Multiple value return spot, clear stack */
-	move	CSP, ARGS
+	move	CSP, OLDCONT
 	nop
 
 	/* Pass one return value back to C land. */
@@ -143,6 +140,7 @@ lra:
 	sw	ALLOC, current_dynamic_space_free_pointer
 	sw	BSP, current_binding_stack_pointer
 	sw	CSP, current_control_stack_pointer
+	sw	CONT, current_control_frame_pointer
 	sw	FLAGS, current_flags_register
 
 	/* Back in foreign function call */
@@ -189,16 +187,24 @@ lra:
 	.globl	call_into_c
 	.ent	call_into_c
 call_into_c:
-	.set	noreorder
+	/* Set up a stack frame. */
+	move	OLDCONT, CONT
+	move	CONT, CSP
+	addu	CSP, CONT, 32
+	sw	OLDCONT, 0(CONT)
+	sw	LRA, 4(CONT)
+
 	/* Note: the C stack is already set up. */
-	
+
 	/* Set the pseudo-atomic flag. */
+	.set	noreorder
 	or	FLAGS, (1<<flag_Atomic)
 
 	/* Save lisp state. */
 	sw	ALLOC, current_dynamic_space_free_pointer
 	sw	BSP, current_binding_stack_pointer
 	sw	CSP, current_control_stack_pointer
+	sw	CONT, current_control_frame_pointer
 	sw	FLAGS, current_flags_register
 
 	/* Mark us as in C land. */
@@ -252,7 +258,6 @@ call_into_c:
 	/* Restore other lisp state. */
 	lw	ALLOC, current_dynamic_space_free_pointer
 	lw	BSP, current_binding_stack_pointer
-	lw	CSP, current_control_stack_pointer
 
 	/* Check for interrupt */
 	and	FLAGS, (0xffff^(1<<flag_Atomic))
@@ -266,6 +271,11 @@ call_into_c:
 
 	.set	reorder
 
+	/* Reset the lisp stack. */
+	/* Note: OLDCONT and CONT are in saved regs. */
+	move	CSP, CONT
+	move	CONT, OLDCONT
+
 	/* Return to LISP. */
 	addu	a0, LRA, 4-type_OtherPointer
 	j	a0
diff --git a/ldb/monitor.c b/ldb/monitor.c
index 90d92e345..eba74d6d2 100644
--- a/ldb/monitor.c
+++ b/ldb/monitor.c
@@ -120,6 +120,7 @@ char **ptr;
     printf("DYNAMIC\t=\t0x%08x\n", current_dynamic_space);
     printf("ALLOC\t=\t0x%08x\n", current_dynamic_space_free_pointer);
     printf("CSP\t=\t0x%08x\n", current_control_stack_pointer);
+    printf("FP\t=\t0x%08x\n", current_control_frame_pointer);
     printf("BSP\t=\t0x%08x\n", current_binding_stack_pointer);
     printf("FLAGS\t=\t0x%08x\n", current_flags_register);
 }
@@ -188,11 +189,10 @@ char **ptr;
 {
     extern lispobj call_into_lisp();
 
-    static lispobj args[16];
     int start_level = level;
 
     lispobj call_name = parse_lispobj(ptr);
-    lispobj function, result, arg, *argptr;
+    lispobj function, result, arg, *args;
     int numargs;
 
     if (LowtagOf(call_name) == type_OtherPointer) {
@@ -218,13 +218,12 @@ char **ptr;
         function = call_name;
 
     numargs = 0;
-    argptr = args;
+    args = current_control_stack_pointer;
     while (more_p(ptr)) {
-        *argptr++ = parse_lispobj(ptr);
+        current_control_stack_pointer++;
+        current_control_stack_pointer[-1] = parse_lispobj(ptr);
         numargs++;
     }
-    while (argptr < args + 6)
-        *argptr++ = NIL;
 
     result = call_into_lisp(call_name, function, args, numargs);
 
@@ -421,8 +420,8 @@ char **ptr;
 	backtrace(n);
 }
 
-static void sub_monitor(csp, bsp)
-lispobj *csp, *bsp;
+static void sub_monitor(csp, fp, bsp)
+lispobj *csp, *fp, *bsp;
 {
     extern char *egets();
     struct cmd *cmd, *found;
@@ -435,6 +434,10 @@ lispobj *csp, *bsp;
             printf("CSP changed from 0x%x to 0x%x; Restoring.\n", csp, new);
             current_control_stack_pointer = csp;
         }
+        if ((new = current_control_frame_pointer) != fp) {
+            printf("FP changed from 0x%x to 0x%x; Restoring.\n", fp, new);
+            current_control_frame_pointer = csp;
+        }
         if ((new = current_binding_stack_pointer) != bsp) {
             printf("BSP changed from 0x%x to 0x%x; Restoring.\n", bsp, new);
             current_binding_stack_pointer = bsp;
@@ -479,9 +482,10 @@ lispobj *csp, *bsp;
 void monitor()
 {
     jmp_buf oldbuf;
-    lispobj *csp, *bsp;
+    lispobj *csp, *fp, *bsp;
 
     csp = current_control_stack_pointer;
+    fp = current_control_frame_pointer;
     bsp = current_binding_stack_pointer;
 
     bcopy(curbuf, oldbuf, sizeof(oldbuf));
@@ -496,7 +500,7 @@ void monitor()
 
     setjmp(curbuf);
 
-    sub_monitor(csp, bsp);
+    sub_monitor(csp, fp, bsp);
 
     done = FALSE;
 
-- 
GitLab