From fa77470b9245dc5bc5f45de949c35e88b8b1c4e5 Mon Sep 17 00:00:00 2001
From: dtc <dtc>
Date: Tue, 25 Nov 1997 16:18:44 +0000
Subject: [PATCH] Re-write of the x86 port debug support. This should give a
 significant improvement in reliability necessary for breakpoint and single
 stepping to have a chance, and has been tested in the experimental code and
 works on FreeBSD and Linux.

The code object for a given return address in now located with the help
of the GC support function component_ptr_from_pc which can reliably
locate the code objects. This uses a forward search of the heap so is
rather slow - some caching will be needed for better performance.

The stack parsing has been re-written using a backtracking search to
improve the chance of finding a valid frame path given that the
control changes between C and Lisp conventions.  The x86-lra hack is
no longer necessary (was unreliable anyway) allowing x86 code to be
more compact. The return address is now handled as a SAP which is
acceptable because the code doesn't move with CGC, and GENCGC ensures
that code objects in the dynamic heap with return addresses on the
stack are not moved. However there are known problems under GENCGC
when return addresses are move off the stack during some breakpoint
operations in which case the code object may move.
---
 code/debug-int.lisp | 550 ++++++++++++++++++++++++--------------------
 1 file changed, 297 insertions(+), 253 deletions(-)

diff --git a/code/debug-int.lisp b/code/debug-int.lisp
index d9d753a6d..0274b12f2 100644
--- a/code/debug-int.lisp
+++ b/code/debug-int.lisp
@@ -1,11 +1,11 @@
-;;; -*- Mode: completion; Log: code.log; Package: DI -*-
+;;; -*- Mode: Lisp; Log: code.log; Package: DI -*-
 ;;;
 ;;; **********************************************************************
 ;;; This code was written as part of the CMU Common Lisp project at
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/debug-int.lisp,v 1.76 1997/11/18 10:47:56 dtc Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/debug-int.lisp,v 1.77 1997/11/25 16:18:44 dtc Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -14,7 +14,7 @@
 ;;;
 ;;; Written by Bill Chiles and Rob Maclachlan.
 ;;;
-;;; Enhancements/debugging for the x86 port by Douglas Crosher 1996, 1997.
+;;; X86 support by Douglas Crosher 1996,1997.
 
 (in-package "DEBUG-INTERNALS")
 
@@ -837,10 +837,8 @@
 (defun kernel:function-word-offset (fun) (kernel:function-word-offset fun))
 ;;;
 (defsetf kernel:stack-ref kernel:%set-stack-ref)
-
+
 (proclaim '(inline cstack-pointer-valid-p))
-;;; This must come before any use (of course) else the cross compiler
-;;; uses it's own version which is WRONG for x86!!!
 (defun cstack-pointer-valid-p (x)
   (declare (type system:system-area-pointer x))
   #-:x86
@@ -857,181 +855,121 @@
 		      x)
        (zerop (logand (system:sap-int x) #b11))))
 
-;;;; X86 support. Don't have lra objects so will search back for code header.
-
-(eval-when (compile eval)
-  (defmacro c-var-frob (lisp-fun c-var-name)
-    `(progn
-       (declaim (inline ,lisp-fun))
-       (defun ,lisp-fun ()
-	 (alien:extern-alien ,c-var-name (alien:unsigned 32))))))
-
-(c-var-frob static-space-start "static_space")
-(c-var-frob read-only-space-start "read_only_space")
-
-(defun compiled-function-from-pc (pc &optional (limit 50000))
-  ;;; x86 hack around not having lra objects.
-  (declare (type system-area-pointer pc)
-	   (fixnum limit))
-  (let ((base (int-sap (kernel:32bit-logical-and
-			(sap-int pc)
-			(kernel:32bit-logical-not vm:lowtag-mask)))))
-    (declare (type system-area-pointer base))
-    (do ((hdrp (- (sap-int base) vm:word-bytes)
-	       (- hdrp vm:word-bytes))
-	 (times limit (1- times)))
-	((or (zerop times)
-	     (> (read-only-space-start) hdrp))
-	 nil)
-      (declare (type (unsigned-byte 32) hdrp)
-	       (fixnum times))
-      (let ((hdrval (sap-ref-32 (int-sap hdrp) 0)))
-	(declare (type (unsigned-byte 32) hdrval))
-	#+nil (format t "~&~x ~x~%" hdrp hdrval)
-	(when (and (= (kernel:32bit-logical-and hdrval vm:type-mask)
-		      vm:function-header-type)
-		   (= (sap-ref-32 (int-sap hdrp)
-				  (* vm:function-self-slot vm:word-bytes))
-		      (+ hdrp (* vm:function-code-offset vm:word-bytes))))
-	  (let ((maybe-fcn (kernel:make-lisp-obj
-			    (+ hdrp vm:function-pointer-type))))
-	    (when (and (functionp maybe-fcn) (compiled-function-p maybe-fcn))
-	      (return maybe-fcn))))))))
+#+(or gengc x86)
+(alien:def-alien-routine component-ptr-from-pc (system:system-area-pointer)
+  (pc system:system-area-pointer))
 
+#+(or gengc x86)
+(defun component-from-component-ptr (component-ptr)
+  (declare (type system:system-area-pointer component-ptr))
+  (kernel:make-lisp-obj
+   (logior (system:sap-int component-ptr)
+	   vm:other-pointer-type)))
 
+;;;; X86 support.
 
+#+x86
 (defun compute-lra-data-from-pc(pc)
-  ;; pc is offset from dualword aligned function header
   (declare (type system-area-pointer pc))
-  (let ((function (compiled-function-from-pc pc)))
-    (when function
-      (let* ((code (kernel:function-code-header function))
-	     (code-header-len (* (kernel:get-header-data code)
-				 vm:word-bytes))
-	     (pc-offset
-	      (- (sap-int pc)
-		 (- (kernel:get-lisp-obj-address code)
-		    vm:other-pointer-type)
-		 code-header-len)))
-;	(format t "c-lra-fpc ~a ~a ~a~%" pc code pc-offset)
-	(values pc-offset code)))))
-
-#+x86
-(defun stack-ref-32 (stack offset)
-  (declare (type sys:system-area-pointer stack)
-	   (type fixnum offset)
-	   (optimize (speed 3) (safety 0)))
-  (kernel::get-lisp-obj-address (stack-ref stack offset)))
-
-;;; maybe these should be generalized in xxx-vm.lisp
-;;;(proclaim '(inline old-frame-pointer lisp-return-pc))
-(defun old-frame-pointer(scp)
-  (declare (type (alien:alien (* unix:sigcontext)) scp))
-  (let* #+x86 ((cfp (vm:sigcontext-register scp vm::ebp-offset))
-	       (ofp (stack-ref-32 (int-sap cfp) vm::ocfp-save-offset)))
-	#-x86 ((ofp (vm:sigcontext-register scp vm::ocfp-offset)))
-	(declare (type (unsigned-byte 32) #+x86 cfp ofp))
-	(int-sap ofp)))
+  (let ((component-ptr (component-ptr-from-pc pc)))
+    (unless (sap= component-ptr (int-sap #x0))
+       (let* ((code (component-from-component-ptr component-ptr))
+	      (code-header-len (* (kernel:get-header-data code) vm:word-bytes))
+	      (pc-offset (- (sap-int pc)
+			    (- (kernel:get-lisp-obj-address code)
+			       vm:other-pointer-type)
+			    code-header-len)))
+;	 (format t "c-lra-fpc ~a ~a ~a~%" pc code pc-offset)
+	 (values pc-offset code)))))
 
 
 #+x86
-(defun lisp-return-pc(scp)
-  ;;; return a value that can be used in computation
-  (declare (type (alien:alien (* unix:sigcontext)) scp))
-  (let* ((cfp (vm:sigcontext-register scp vm::ebp-offset))
-	 (lra (stack-ref-32 (int-sap cfp) vm::return-pc-save-offset)))
-    lra))
-#-x86
-(defun lisp-return-pc(scp)
-  (declare (type (alien:alien (* unix:sigcontext)) scp))
-  (vm:sigcontext-register scp vm::lra-offset))
+(defconstant vm::nargs-offset #.vm::ecx-offset)
 
+;;; Check for a valid return address - it could be any valid C/Lisp
+;;; address.
+;;;
+;;; XX Could be a little smarter.
 #+x86
-(defconstant vm::nargs-offset #.vm::ecx-offset)
+(proclaim '(inline cstack-pointer-valid-p))
 #+x86
-(progn
-(defun lisp-return-pc-valid-p(loc)
-  (declare (type system-area-pointer loc))
-  (let ((code-beg (int-sap (static-space-start)))
-	(code-end (int-sap (* lisp::*static-space-free-pointer*
-			      vm:word-bytes))))
-    (and (sap< code-beg loc)
-	 (sap< loc code-end))))
-
-(declaim (inline make-fixnum))
-(defun make-fixnum (sap)
-  (kernel:make-lisp-obj (ash (sap-int sap) 2)))
-
-;; These return hopefully correct ofp ret values at a call site
-(defun maybe-lisp-from-c(fp)
-  (declare (type system-area-pointer fp))
-  (let ((s0 (stack-ref-32 fp vm::ocfp-save-offset))
-	(s1 (stack-ref-32 fp vm::return-pc-save-offset)))
-    (when (and (kernel:make-lisp-obj s0)(kernel:make-lisp-obj s1))
-      (let ((lisp-ofp (int-sap s0))
-	    (lisp-lra (int-sap s1)))
-	;;(format t "~&cf? ~a ~a~%" lisp-ofp lisp-lra)
-	;; Check  this logic now that C calls with lra.
-	(when (sap= lisp-ofp lisp-lra)	; Can't happen via Lisp
-	  (let ((cfp (sap-ref-sap fp (* 0 vm:word-bytes)))
-		(cra (sap-ref-sap fp (* 1 vm:word-bytes))))
-	    ;;(format t "~&cf! ~a ~a~%" cfp cra)
-	    (list (make-fixnum cra) cfp)))))))
-
-(defun maybe-lisp-from-lisp(fp)
-    (declare (type system-area-pointer fp))
-    (when (cstack-pointer-valid-p fp)
-      (let ((s0 (stack-ref-32 fp vm::ocfp-save-offset))
-	    (s1 (stack-ref-32 fp vm::return-pc-save-offset)))
-	(when (and (kernel:make-lisp-obj s0)
-		   (kernel:make-lisp-obj s1))
-	  (let ((ofp (int-sap s0))
-		(lra (int-sap s1)))
-	    ;;(format t "~&mlf ~a ~a~%" ofp lra)
-	    (and (cstack-pointer-valid-p ofp)
-		 (lisp-return-pc-valid-p lra)
-		 (list (kernel:make-lisp-obj s1) ofp)))))))
-
-(defun maybe-c-from-c(fp)
-  (declare (type system-area-pointer fp))
-  (let ((cfp (sap-ref-sap fp (* 0 vm:word-bytes)))
-	(cra (sap-ref-sap fp (* 1 vm:word-bytes)))
-	(end (int-sap (* lisp::*static-space-free-pointer* vm:word-bytes))))
-    ;;(format t "~&cfc? ~a ~a" cfp cra)
-    (when (cstack-pointer-valid-p cfp)
-      (cond ((sap< cra (int-sap (static-space-start)))
-	     ;;(format t "~&cfc!~%")
-	     (list (make-fixnum cra) cfp))
-	  ;; sigtrap handler from interrupt
-	  ((sap> cra end)
-	   ;;(format t "~&INT~%")
-	   (list nil cfp))))))
-
-;;; ^C a running program and get C call semantics with Lisp return address.
-(defun maybe-c-from-lisp(fp)
-  (declare (type system-area-pointer fp))
-  (let ((cfp (sap-ref-sap fp (* 0 vm:word-bytes)))
-	(cra (sap-ref-sap fp (* 1 vm:word-bytes)))
-	(end (int-sap (* lisp::*static-space-free-pointer* vm:word-bytes))))
-    ;;(format t "~&cfl? ~a ~a" cfp cra)
-    (when (cstack-pointer-valid-p cfp)
-      (cond ((sap< cra end)
-	     ;;(format t "~&cfl!~%")
-	     (list (make-fixnum cra) cfp))))))
-
-(defun x86-call-context(fp)
-  (declare (type system-area-pointer fp))
-  (let ((pair (cond ((maybe-lisp-from-lisp fp))
-		    ((maybe-lisp-from-c fp))
-		    ((maybe-c-from-c fp))
-		    ((maybe-c-from-lisp fp)))))
-    (if pair
-      (apply #'values pair)
-      (error "Debug can't resolve frame ~a" fp))))
-)
-;;; end of x86 hacks
-
+(defun ra-pointer-valid-p (ra)
+  (declare (type system:system-area-pointer ra))
+  ;; Not a Lisp stack pointer.
+  (or (system:sap< ra (kernel:current-sp))
+      (system:sap> ra (alien:alien-sap
+		       (alien:extern-alien "control_stack_end" (* t))))))
 
+;;; Try to find a valid previous stack. This is complex on the x86 as
+;;; it can jump between C and Lisp frames. To help find a valid frame
+;;; it searches backwards.
+;;;
+;;; XX Should probably check if it has reached the bottom of the
+;;; stack.
+;;;
+;;; XX Should handle interrupted frames, both Lisp and C. A present it
+;;; manages to find a fp trail, see linux hack below.
+;;;
+#+x86
+(defun x86-call-context (fp &key (depth 8))
+  (declare (type system-area-pointer fp)
+	   (fixnum depth))
+;  (format t "*CC ~s ~s~%" fp depth)
+  (cond
+   ((not (cstack-pointer-valid-p fp))
+    (format t "Debug invalid fp ~s~%" fp)
+    nil)
+   (t
+    ;; Check the two possible frame pointers.
+    (let ((lisp-ocfp (sap-ref-sap fp (- (* (1+ vm::ocfp-save-offset) 4))))
+	  (lisp-ra (sap-ref-sap fp (- (* (1+ vm::return-pc-save-offset) 4))))
+	  (c-ocfp (sap-ref-sap fp (* 0 vm:word-bytes)))
+	  (c-ra (sap-ref-sap fp (* 1 vm:word-bytes))))
+      (cond ((and (sap> lisp-ocfp fp) (cstack-pointer-valid-p lisp-ocfp)
+		  (ra-pointer-valid-p lisp-ra)
+		  (sap> c-ocfp fp) (cstack-pointer-valid-p c-ocfp)
+		  (ra-pointer-valid-p c-ra))
+;	     (format t "*C Both valid ~s ~s ~s ~s~%"
+;		     lisp-ocfp lisp-ra c-ocfp c-ra)
+	     ;; Look forward another step to check their validity.
+	     (let ((lisp-path-fp (x86-call-context lisp-ocfp
+						   :depth (- depth 1)))
+		   (c-path-fp (x86-call-context c-ocfp :depth (- depth 1))))
+	       (cond ((and lisp-path-fp c-path-fp)
+		      ;; Both still seem valid - choose the smallest.
+		      (format t "Debug: Both still valid ~s ~s ~s ~s~%"
+			      lisp-ocfp lisp-ra c-ocfp c-ra)
+		      (if (sap< lisp-ocfp c-ocfp)
+			  (values lisp-ra lisp-ocfp)
+			(values c-ra c-ocfp)))
+		     (lisp-path-fp
+		      ;; The lisp convention is looking good.
+;		      (format t "*C lisp-ocfp ~s ~s~%" lisp-ocfp lisp-ra)
+		      (values lisp-ra lisp-ocfp))
+		     (c-path-fp
+		      ;; The C convention is looking good.
+;		      (format t "*C c-ocfp ~s ~s~%" c-ocfp c-ra)
+		      (values c-ra c-ocfp))
+		     (t
+		      ;; Neither seems right?
+;		      (format t "Debug: no valid2 fp found ~s ~s~%"
+;			      lisp-ocfp c-ocfp)
+		      nil))))
+	    ((and (sap> lisp-ocfp fp) (cstack-pointer-valid-p lisp-ocfp)
+		  (ra-pointer-valid-p lisp-ra))
+	     ;; The lisp convention is looking good.
+;	     (format t "*C lisp-ocfp ~s ~s~%" lisp-ocfp lisp-ra)
+	     (values lisp-ra lisp-ocfp))
+	    ((and (sap> c-ocfp fp) (cstack-pointer-valid-p c-ocfp)
+		  #-linux (ra-pointer-valid-p c-ra))
+	     ;; The C convention is looking good.
+;	     (format t "*C c-ocfp ~s ~s~%" c-ocfp c-ra)
+	     (values c-ra c-ocfp))
+	    (t
+;	     (format t "Debug: no valid fp found ~s ~s~%" lisp-ocfp c-ocfp)
+	     nil))))))
+
+
 ;;; DESCRIPTOR-SAP -- internal
 ;;;
 ;;; Convert the descriptor into a SAP.  The bits all stay the same, we just
@@ -1050,7 +988,8 @@
 		       (kernel:%caller-frame-and-pc)
     (possibly-an-interpreted-frame
      (compute-calling-frame (descriptor-sap fp)
-			    #-gengc pc #+gengc (descriptor-sap pc)
+			    #-(or gengc x86) pc
+			    #+(or gengc x86) (descriptor-sap pc)
 			    nil)
      nil)))
 
@@ -1084,7 +1023,7 @@
 				 debug-fun)))
 		     (possibly-an-interpreted-frame
 		      (compute-calling-frame
-		       ( #-x86 descriptor-sap #+x86 int-sap
+		       (descriptor-sap
 			(get-context-value
 			 real vm::ocfp-save-offset
 			 (c::compiled-debug-function-old-fp c-d-f)))
@@ -1147,18 +1086,37 @@
 	(escaped (compiled-frame-escaped frame)))
     (if escaped
 	(ecase stack-slot
-	  (#.vm::ocfp-save-offset
-	   (sub-access-debug-var-slot pointer loc escaped))
-	  (#.vm::lra-save-offset
-	   (kernel:make-lisp-obj
-	    (sub-access-debug-var-slot pointer loc escaped))))
-	(ecase stack-slot
-	  (#.vm::ocfp-save-offset
-	   (stack-ref-32 pointer stack-slot))
-	  (#.vm::lra-save-offset
-	   (kernel:stack-ref pointer stack-slot))))))
+	       (#.vm::ocfp-save-offset
+		(sub-access-debug-var-slot pointer loc escaped))
+	       (#.vm::lra-save-offset
+;		(format t "escaped ra: pointer=~s loc=~s (~s ~s)~%"
+;			pointer loc
+;			(c:sc-offset-scn loc) (c::sc-offset-offset loc))
+		(case (c::sc-offset-scn loc)
+		      ((#.vm:any-reg-sc-number #.vm:descriptor-reg-sc-number)
+		       (format t "escaped ra: pointer=~s loc=~s (~s ~s)~%"
+			       pointer loc
+			       (c:sc-offset-scn loc) (c::sc-offset-offset loc))
+		       ;; Translate to sap-reg at the same offset.
+		       (setf loc (c::make-sc-offset vm:sap-reg-sc-number
+						    (c:sc-offset-scn loc))))
+		      (#.vm:control-stack-sc-number
+		       ;; Translate to sap-stack at the same offset.
+		       (setf loc (c::make-sc-offset vm:sap-stack-sc-number
+						    (c:sc-offset-offset loc))))
+		      (t
+		       (format t "unexpected RA sc location?~%")))
+;		(format t " translated to loc=~s (~s ~s)~%" loc
+;			(c:sc-offset-scn loc) (c::sc-offset-offset loc))
+		(sub-access-debug-var-slot pointer loc escaped)))
+      (ecase stack-slot
+	     (#.vm::ocfp-save-offset
+	      (kernel:stack-ref pointer stack-slot))
+	     (#.vm::lra-save-offset
+	      (sap-ref-sap pointer (- (* (1+ stack-slot) 4))))))))
 
 ;;;
+#-x86
 (defun (setf get-context-value) (value frame stack-slot loc)
   (declare (type compiled-frame frame) (type unsigned-byte stack-slot)
 	   (type c::sc-offset loc))
@@ -1168,6 +1126,43 @@
 	(sub-set-debug-var-slot pointer loc value escaped)
 	(setf (kernel:stack-ref pointer stack-slot) value))))
 
+#+x86
+(defun (setf get-context-value) (value frame stack-slot loc)
+  (declare (type compiled-frame frame) (type unsigned-byte stack-slot)
+	   (type c::sc-offset loc))
+  (let ((pointer (frame-pointer frame))
+	(escaped (compiled-frame-escaped frame)))
+    (if escaped
+	(ecase stack-slot
+	       (#.vm::ocfp-save-offset
+		(sub-set-debug-var-slot pointer loc value escaped))
+	       (#.vm::lra-save-offset
+;		(format t "escaped ra: pointer=~s loc=~s (~s ~s)~%"
+;			pointer loc
+;			(c:sc-offset-scn loc) (c::sc-offset-offset loc))
+		(case (c::sc-offset-scn loc)
+		      ((#.vm:any-reg-sc-number #.vm:descriptor-reg-sc-number)
+		       (format t "escaped ra: pointer=~s loc=~s (~s ~s)~%"
+			       pointer loc
+			       (c:sc-offset-scn loc) (c::sc-offset-offset loc))
+		       ;; Translate to sap-reg at the same offset.
+		       (setf loc (c::make-sc-offset vm:sap-reg-sc-number
+						    (c:sc-offset-scn loc))))
+		      (#.vm:control-stack-sc-number
+		       ;; Translate to sap-stack at the same offset.
+		       (setf loc (c::make-sc-offset vm:sap-stack-sc-number
+						    (c:sc-offset-offset loc))))
+		      (t
+		       (format t "unexpected RA sc location?~%")))
+;		(format t " translated to loc=~s (~s ~s)~%" loc
+;			(c:sc-offset-scn loc) (c::sc-offset-offset loc))
+		(sub-set-debug-var-slot pointer loc value escaped)))
+      (ecase stack-slot
+	     (#.vm::ocfp-save-offset
+	      (setf (kernel:stack-ref pointer stack-slot) value))
+	     (#.vm::lra-save-offset
+	      (setf (sap-ref-sap pointer (- (* (1+ stack-slot) 4))) value))))))
+
 
 (defvar *debugging-interpreter* nil
   "When set, the debugger foregoes making interpreted-frames, so you can
@@ -1233,35 +1228,22 @@
 ;;; into C.  In this case, the code object is stored on the stack after the
 ;;; LRA, and the LRA is the word offset.
 ;;;
-;;;; x86 note. The non-lra version has not been tested with the
-;;;; recent changes. I'm probably going to move to just using lra
-;;;; and remove the x86-lra feature at some point.
-#-gengc
+#-(or gengc x86)
 (defun compute-calling-frame (caller lra up-frame)
   (declare (type system:system-area-pointer caller))
-  ;;(format t "ccf: ~x ~a ~a~%" (sap-int caller) lra up-frame)
   (when (cstack-pointer-valid-p caller)
     (multiple-value-bind
 	(code pc-offset escaped)
 	(if lra
 	    (multiple-value-bind
-		  (word-offset code)
+		(word-offset code)
 		(if (ext:fixnump lra)
 		    (let ((fp (frame-pointer up-frame)))
-		      #+x86 (declare (ignore fp))
-		      (values
-		       lra
-		       #-x86 ;; fake-foreign-fcn sticks CODE pointer here
-		       (kernel:stack-ref fp (1+ vm::lra-save-offset))))
-		    #+(or x86-lra (not x86))
+		      (values lra
+			      (kernel:stack-ref fp (1+ vm::lra-save-offset))))
 		    (values (kernel:get-header-data lra)
-			    (kernel:lra-code-header lra))
-		    #+(and x86 (not x86-lra))
-		    (compute-lra-data-from-pc (int-sap lra)))
-			
+			    (kernel:lra-code-header lra)))
 	      (if code
-		  #+(and x86 (not x86-lra))(values code word-offset nil)
-		  #+(or x86-lra (not x86))
 		  (values code
 			  (* (1+ (- word-offset (kernel:get-header-data code)))
 			     vm:word-bytes)
@@ -1292,6 +1274,57 @@
 				 (if up-frame (1+ (frame-number up-frame)) 0)
 				 escaped))))))
 
+#+x86
+(defun compute-calling-frame (caller ra up-frame)
+  (declare (type system:system-area-pointer caller ra))
+;  (format t "ccf: ~a ~a ~a~%" caller ra up-frame)
+  (when (cstack-pointer-valid-p caller)
+;    (format t "ccf2~%")
+    ;; First check for an escaped frame.
+    (multiple-value-bind
+	(code pc-offset escaped)
+	(find-escaped-frame caller)
+	(cond (code
+	       ;; If it's escaped it may be a function end breakpoint
+	       ;; trap.
+;	       (format t "ccf2: escaped ~s ~s~%" code pc-offset)
+	       (when (and (kernel:code-component-p code)
+			  (eq (kernel:%code-debug-info code) :bogus-lra))
+		     ;; If :bogus-lra grab the real lra.
+		     (let ((real-ra
+			    (kernel:code-header-ref code real-lra-slot)))
+		       (multiple-value-setq (pc-offset code)
+			 (compute-lra-data-from-pc real-ra))
+;		       (format t "ccf3 :bogus-lra ~s ~s~%" code pc-offset)
+		       (assert code))))
+	      (t
+	       ;; Not escaped
+	       (multiple-value-setq (pc-offset code)
+		 (compute-lra-data-from-pc ra))
+;	       (format t "ccf4 ~s ~s~%" code pc-offset)
+	       (unless code
+		       (setf code :foreign-function
+			     pc-offset 0
+			     escaped nil))))
+
+	(let ((d-fun (case code
+			   (:undefined-function
+			    (make-bogus-debug-function
+			     "The Undefined Function"))
+			   (:foreign-function
+			    (make-bogus-debug-function
+			     "Foreign function call land"))
+			   ((nil)
+			    (make-bogus-debug-function
+			     "Bogus stack frame"))
+			   (t
+			    (debug-function-from-pc code pc-offset)))))
+	  (make-compiled-frame caller up-frame d-fun
+			       (code-location-from-pc d-fun pc-offset
+						      escaped)
+			       (if up-frame (1+ (frame-number up-frame)) 0)
+			       escaped)))))
+
 #-(or gengc x86)
 (defun find-escaped-frame (frame-pointer)
   (declare (type system:system-area-pointer frame-pointer))
@@ -1325,7 +1358,7 @@
 		 ;; We were in an assembly routine.  Therefore, use the LRA as
 		 ;; the pc.
 		 (setf pc-offset
-		       (- (lisp-return-pc scp)
+		       (- (vm:sigcontext-register scp vm::lra-offset)
 			  (kernel:get-lisp-obj-address code)
 			  code-header-len)))
 	       (return
@@ -1343,22 +1376,34 @@
     (alien:with-alien
 	((lisp-interrupt-contexts (array (* unix:sigcontext) nil) :extern))
       (let ((scp (alien:deref lisp-interrupt-contexts index)))
-	(when (sap= frame-pointer
-		    (int-sap (vm:sigcontext-register scp vm::cfp-offset)))
+	(when (= (system:sap-int frame-pointer)
+		 (vm:sigcontext-register scp vm::cfp-offset))
 	  (system:without-gcing
-	   (multiple-value-bind
-		 (pc-offset code)
-	       (compute-lra-data-from-pc (vm:sigcontext-program-counter scp))
-	     (when (symbolp code)
+	   (let* ((component-ptr
+		   (component-ptr-from-pc (vm:sigcontext-program-counter scp)))
+		  (code (if (sap= component-ptr (int-sap #x0))
+			    nil
+			  (component-from-component-ptr component-ptr))))
+	     (when (null code)
 	       (return (values code 0 scp)))
-	     (return
-	       (if (eq (kernel:%code-debug-info code) :bogus-lra)
-		   (let ((real-lra (kernel:code-header-ref
-				    code real-lra-slot)))
-		     (values (kernel:lra-code-header real-lra)
-			     (kernel:get-header-data real-lra)
-			     nil))
-		   (values code pc-offset scp))))))))))
+	     (let* ((code-header-len (* (kernel:get-header-data code)
+					vm:word-bytes))
+		    (pc-offset
+		     (- (system:sap-int
+			 (vm:sigcontext-program-counter scp))
+			(- (kernel:get-lisp-obj-address code)
+			   vm:other-pointer-type)
+			code-header-len)))
+	       (unless (<= 0 pc-offset
+			   (* (kernel:code-header-ref code
+						      vm:code-code-size-slot)
+			      vm:word-bytes))
+		 ;; We were in an assembly routine.  Therefore, use the LRA as
+		 ;; the pc.
+		 (format t "** pc-offset ~s not in code obj ~s?~%"
+			 pc-offset code))
+	       (return
+		(values code pc-offset scp))))))))))
 
 ;;; CODE-OBJECT-FROM-BITS  --  internal.
 ;;;
@@ -1389,17 +1434,6 @@
 #+gengc
 (declaim (special kernel::*saved-state-chain*))
 
-#+gengc
-(alien:def-alien-routine component-ptr-from-pc (system:system-area-pointer)
-  (pc system:system-area-pointer))
-
-#+gengc
-(defun component-from-component-ptr (component-ptr)
-  (declare (type system:system-area-pointer component-ptr))
-  (kernel:make-lisp-obj
-   (logior (system:sap-int component-ptr)
-	   vm:other-pointer-type)))
-
 #+gengc
 (defun lookup-trace-table-entry (component pc)
   (declare (type code-component component)
@@ -1491,7 +1525,8 @@
 		;; ### Need to do something real.
 		(values (make-bogus-debug-function "Assembler routine.")
 			0
-			(old-frame-pointer state)))
+			(system:int-sap
+			 (vm:sigcontext-register state vm::ocfp-offset))))
 	       (#.vm:trace-table-function-prologue
 		(values (make-bogus-debug-function
 			 "Function-Prologue in an assembler routine?")
@@ -1516,7 +1551,8 @@
 	       (#.vm:trace-table-call-site
 		(values (debug-function-from-pc component pc-offset)
 			pc-offset
-			(old-frame-pointer state)))
+			(system:int-sap
+			 (vm:sigcontext-register state vm::ocfp-offset))))
 	       (#.vm:trace-table-function-prologue
 		#+nil ;; ### Need to do something real.
 		(let* ((ra (system:int-sap
@@ -1606,8 +1642,6 @@
 ;;; the component, for function constants, and the c::compiled-debug-function.
 ;;;
 (defun debug-function-from-pc (component pc)
-  #+x86 ;; until no more bugs at least.
-  (declare (optimize (safety 1)(debug .5)))
   (let ((info (kernel:%code-debug-info component)))
     (cond
      ((not info)
@@ -1679,23 +1713,38 @@
 		   (system:sap-ref-32 catch
 				      (* vm:catch-block-current-cont-slot
 					 vm:word-bytes))))
-	(let* (#-gengc
+	(let* (#-(or gengc x86)
 	       (lra (kernel:stack-ref catch vm:catch-block-entry-pc-slot))
-	       #+gengc
+	       #+(or gengc x86)
 	       (ra (system:sap-ref-sap
 		    catch (* vm:catch-block-entry-pc-slot vm:word-bytes)))
+	       #-x86
 	       (component
 		(kernel:stack-ref catch vm:catch-block-current-code-slot))
+	       #+x86
+	       (component (component-from-component-ptr 
+			   (component-ptr-from-pc ra)))
 	       (offset
-		#-gengc (* (- (1+ (kernel:get-header-data lra))
-			      (kernel:get-header-data component))
-			   vm:word-bytes)
+		#-(or gengc x86)
+		(* (- (1+ (kernel:get-header-data lra))
+		      (kernel:get-header-data component))
+		   vm:word-bytes)
 		#+gengc
 		(+ (- (system:sap-int ra)
 		      (kernel:get-lisp-obj-address component)
 		      (kernel:get-header-data component))
-		   vm:other-pointer-type)))
-	  (push (cons (kernel:stack-ref catch vm:catch-block-tag-slot)
+		   vm:other-pointer-type)
+		#+x86
+		(- (system:sap-int ra)
+		   (- (kernel:get-lisp-obj-address component)
+		      vm:other-pointer-type)
+		   (* (kernel:get-header-data component) vm:word-bytes))))
+	  (push (cons #-x86
+		      (kernel:stack-ref catch vm:catch-block-tag-slot)
+		      #+x86
+		      (kernel:make-lisp-obj
+		       (system:sap-ref-32 catch (* vm:catch-block-tag-slot
+						   vm:word-bytes)))
 		      (make-compiled-code-location
 		       offset (frame-debug-function frame)))
 		res)))
@@ -4049,18 +4098,6 @@
 ;;; handle breaks for internal errors.
 ;;;
 (defun handle-breakpoint (offset component signal-context)
-#+x86
-  (multiple-value-bind (byte-offset code)
-      (let* ((pc (vm:sigcontext-program-counter
-		  (alien:sap-alien signal-context (* unix:sigcontext))))
-	     (fn (compiled-function-from-pc pc)))
-	(values (- (sap-int pc)
-		   (- (kernel:get-lisp-obj-address fn)
-		      vm:function-pointer-type))
-		(kernel:function-code-header fn)))
-    (setq offset byte-offset
-	  component code))
-
   (let ((data (breakpoint-data component offset nil)))
     (unless data
       (error "Unknown breakpoint in ~S at offset ~S."
@@ -4108,7 +4145,7 @@
       (breakpoint-do-displaced-inst signal-context
 				    (breakpoint-data-instruction data))
       ; Under HPUX we can't sigreturn so bp-do-disp-i has to return.
-      #-(or hpux irix)
+      #-(or hpux irix x86)
       (error "BREAKPOINT-DO-DISPLACED-INST returned?"))))
 
 (defun invoke-breakpoint-hooks (breakpoints component offset)
@@ -4164,17 +4201,20 @@
 	       cookie))))
 
 (defun get-function-end-breakpoint-values (scp)
-  (let ((ocfp (old-frame-pointer scp))
+  (let (#-x86
+	(ocfp (system:int-sap (vm:sigcontext-register scp vm::ocfp-offset)))
+	#+x86
+	(ocfp (system:int-sap (vm:sigcontext-register scp vm::ebx-offset)))
 	(nargs (kernel:make-lisp-obj
 		(vm:sigcontext-register scp vm::nargs-offset)))
-	(reg-arg-offsets '#.vm::register-arg-offsets)
+ 	(reg-arg-offsets '#.vm::register-arg-offsets)
 	(results nil))
     (system:without-gcing
      (dotimes (arg-num nargs)
        (push (if reg-arg-offsets
 		 (kernel:make-lisp-obj
 		  (vm:sigcontext-register scp (pop reg-arg-offsets)))
-		 (kernel:stack-ref ocfp arg-num))
+	       (kernel:stack-ref ocfp arg-num))
 	     results)))
     (nreverse results)))
 
@@ -4200,7 +4240,7 @@
 	  (trap-loc (system:foreign-symbol-address
 		     "function_end_breakpoint_trap"))
 	  (length (system:sap- src-end src-start))
-	  (code-object (system:%primitive c:allocate-code-object
+	  (code-object (system:%primitive #-x86 c:allocate-code-object #+x86 c::allocate-dynamic-code-object
 					  (1+ bogus-lra-constants)
 					  length))
 	  (dst-start (kernel:code-instructions code-object)))
@@ -4214,6 +4254,10 @@
      (setf (kernel:code-header-ref code-object known-return-p-slot)
 	   known-return-p)
      (kernel:system-area-copy src-start 0 dst-start 0 (* length vm:byte-bits))
+     (vm:sanctify-for-execution code-object)
+     #+x86
+     (values dst-start code-object (system:sap- trap-loc src-start))
+     #-x86
      (let ((new-lra (kernel:make-lisp-obj (+ (system:sap-int dst-start)
 					     vm:other-pointer-type))))
        (kernel:set-header-data
-- 
GitLab