0.6.7.26: fixed breakpoints on OpenBSD

6 files changed, 70 insertions, 55 deletions

diff --git a/src/code/debug-int.lisp b/src/code/debug-int.lisp
index 307ecd353..a4d95df3a 100644
--- a/src/code/debug-int.lisp
+++ b/src/code/debug-int.lisp
@@ -3510,6 +3510,7 @@
 ;;; debugging-tool break instruction. This does NOT handle all breaks;
 ;;; for example, it does not handle breaks for internal errors.
 (defun handle-breakpoint (offset component signal-context)
+  (/show0 "entering HANDLE-BREAKPOINT")
   (let ((data (breakpoint-data component offset nil)))
     (unless data
       (error "unknown breakpoint in ~S at offset ~S"
@@ -3533,6 +3534,7 @@
 ;;; This handles code-location and debug-function :FUNCTION-START
 ;;; breakpoints.
 (defun handle-breakpoint-aux (breakpoints data offset component signal-context)
+  (/show0 "entering HANDLE-BREAKPOINT-AUX")
   (unless breakpoints
     (error "internal error: breakpoint that nobody wants"))
   (unless (member data *executing-breakpoint-hooks*)
@@ -3575,6 +3577,7 @@
 		   bpt)))))
 
 (defun handle-function-end-breakpoint (offset component context)
+  (/show0 "entering HANDLE-FUNCTION-END-BREAKPOINT")
   (let ((data (breakpoint-data component offset nil)))
     (unless data
       (error "unknown breakpoint in ~S at offset ~S"
@@ -3589,6 +3592,7 @@
 ;;; [old C code] or HANDLE-FUNCTION-END-BREAKPOINT calls this directly
 ;;; [new C code].
 (defun handle-function-end-breakpoint-aux (breakpoints data signal-context)
+  (/show0 "entering HANDLE-FUNCTION-END-BREAKPOINT-AUX")
   (delete-breakpoint-data data)
   (let* ((scp
 	  (locally
diff --git a/src/code/ntrace.lisp b/src/code/ntrace.lisp
index c0f051181..5def05cd7 100644
--- a/src/code/ntrace.lisp
+++ b/src/code/ntrace.lisp
@@ -35,12 +35,12 @@
 
 ;;;; internal state
 
-;;; a hash table that maps each traced function to the TRACE-INFO. The entry
-;;; for a closure is the shared function-entry object.
+;;; a hash table that maps each traced function to the TRACE-INFO. The
+;;; entry for a closure is the shared function-entry object.
 (defvar *traced-functions* (make-hash-table :test 'eq))
 
-;;; A TRACE-INFO object represents all the information we need to trace a
-;;; given function.
+;;; A TRACE-INFO object represents all the information we need to
+;;; trace a given function.
 (def!struct (trace-info
 	     (:make-load-form-fun sb-kernel:just-dump-it-normally)
 	     (:print-object (lambda (x stream)
@@ -61,13 +61,14 @@
   ;; the list of function names for WHEREIN, or NIL if unspecified
   (wherein nil :type list)
 
-  ;; The following slots represent the forms that we are supposed to evaluate
-  ;; on each iteration. Each form is represented by a cons (Form . Function),
-  ;; where the Function is the cached result of coercing Form to a function.
-  ;; Forms which use the current environment are converted with
-  ;; PREPROCESS-FOR-EVAL, which gives us a one-arg function.
-  ;; Null environment forms also have one-arg functions, but the argument is
-  ;; ignored. NIL means unspecified (the default.)
+  ;; The following slots represent the forms that we are supposed to
+  ;; evaluate on each iteration. Each form is represented by a cons
+  ;; (Form . Function), where the Function is the cached result of
+  ;; coercing Form to a function. Forms which use the current
+  ;; environment are converted with PREPROCESS-FOR-EVAL, which gives
+  ;; us a one-arg function. Null environment forms also have one-arg
+  ;; functions, but the argument is ignored. NIL means unspecified
+  ;; (the default.)
 
   ;; current environment forms
   (condition nil)
@@ -101,19 +102,19 @@
 (defvar *traced-entries* ())
 (declaim (list *traced-entries*))
 
-;;; This variable is used to discourage infinite recursions when some trace
-;;; action invokes a function that is itself traced. In this case, we quietly
-;;; ignore the inner tracing.
+;;; This variable is used to discourage infinite recursions when some
+;;; trace action invokes a function that is itself traced. In this
+;;; case, we quietly ignore the inner tracing.
 (defvar *in-trace* nil)
 
 ;;;; utilities
 
-;;;    Given a function name, a function or a macro name, return the raw
-;;; definition and some information. "Raw"  means that if the result is a
-;;; closure, we strip off the closure and return the bare code. The second
-;;; value is T if the argument was a function name. The third value is one of
-;;; :COMPILED, :COMPILED-CLOSURE, :INTERPRETED, :INTERPRETED-CLOSURE and
-;;; :FUNCALLABLE-INSTANCE.
+;;; Given a function name, a function or a macro name, return the raw
+;;; definition and some information. "Raw" means that if the result is
+;;; a closure, we strip off the closure and return the bare code. The
+;;; second value is T if the argument was a function name. The third
+;;; value is one of :COMPILED, :COMPILED-CLOSURE, :INTERPRETED,
+;;; :INTERPRETED-CLOSURE and :FUNCALLABLE-INSTANCE.
 (defun trace-fdefinition (x)
   (multiple-value-bind (res named-p)
       (typecase x
@@ -137,8 +138,8 @@
 	   (values res named-p :funcallable-instance))
 	  (t (values res named-p :compiled))))))
 
-;;; When a function name is redefined, and we were tracing that name, then
-;;; untrace the old definition and trace the new one.
+;;; When a function name is redefined, and we were tracing that name,
+;;; then untrace the old definition and trace the new one.
 (defun trace-redefined-update (fname new-value)
   (when (fboundp fname)
     (let* ((fun (trace-fdefinition fname))
@@ -148,10 +149,10 @@
 	(trace-1 fname info new-value)))))
 (push #'trace-redefined-update sb-int:*setf-fdefinition-hook*)
 
-;;; Annotate some forms to evaluate with pre-converted functions. Each form
-;;; is really a cons (exp . function). Loc is the code location to use for
-;;; the lexical environment. If Loc is NIL, evaluate in the null environment.
-;;; If Form is NIL, just return NIL.
+;;; Annotate some forms to evaluate with pre-converted functions. Each
+;;; form is really a cons (exp . function). Loc is the code location
+;;; to use for the lexical environment. If Loc is NIL, evaluate in the
+;;; null environment. If Form is NIL, just return NIL.
 (defun coerce-form (form loc)
   (when form
     (let ((exp (car form)))
@@ -218,8 +219,8 @@
 	     (trace-info-what info)))))
 
 ;;; This function discards any invalid cookies on our simulated stack.
-;;; Encapsulated entries are always valid, since we bind *traced-entries* in
-;;; the encapsulation.
+;;; Encapsulated entries are always valid, since we bind
+;;; *TRACED-ENTRIES* in the encapsulation.
 (defun discard-invalid-entries (frame)
   (loop
     (when (or (null *traced-entries*)
@@ -231,10 +232,10 @@
 
 ;;;; hook functions
 
-;;; Return a closure that can be used for a function start breakpoint hook
-;;; function and a closure that can be used as the FUNCTION-END-COOKIE
-;;; function. The first communicates the sense of the Condition to the second
-;;; via a closure variable.
+;;; Return a closure that can be used for a function start breakpoint
+;;; hook function and a closure that can be used as the
+;;; FUNCTION-END-COOKIE function. The first communicates the sense of
+;;; the Condition to the second via a closure variable.
 (defun trace-start-breakpoint-fun (info)
   (let (conditionp)
     (values
@@ -322,11 +323,11 @@
 	  (values-list vals))))))
 
 ;;; Trace one function according to the specified options. We copy the
-;;; trace info (it was a quoted constant), fill in the functions, and then
-;;; install the breakpoints or encapsulation.
+;;; trace info (it was a quoted constant), fill in the functions, and
+;;; then install the breakpoints or encapsulation.
 ;;;
-;;; If non-null, Definition is the new definition of a function that we are
-;;; automatically retracing.
+;;; If non-null, DEFINITION is the new definition of a function that
+;;; we are automatically retracing.
 (defun trace-1 (function-or-name info &optional definition)
   (multiple-value-bind (fun named kind)
       (if definition
@@ -392,11 +393,12 @@
 		      :function-end-cookie cookie-fun)))
 	    (setf (trace-info-start-breakpoint info) start)
 	    (setf (trace-info-end-breakpoint info) end)
-	    ;; The next two forms must be in the order in which they appear,
-	    ;; since the start breakpoint must run before the function-end
-	    ;; breakpoint's start helper (which calls the cookie function.)
-	    ;; One reason is that cookie function requires that the CONDITIONP
-	    ;; shared closure variable be initialized.
+	    ;; The next two forms must be in the order in which they
+	    ;; appear, since the start breakpoint must run before the
+	    ;; function-end breakpoint's start helper (which calls the
+	    ;; cookie function.) One reason is that cookie function
+	    ;; requires that the CONDITIONP shared closure variable be
+	    ;; initialized.
 	    (sb-di:activate-breakpoint start)
 	    (sb-di:activate-breakpoint end)))))
 
@@ -406,9 +408,9 @@
 
 ;;;; the TRACE macro
 
-;;; Parse leading trace options off of SPECS, modifying INFO accordingly. The
-;;; remaining portion of the list is returned when we encounter a plausible
-;;; function name.
+;;; Parse leading trace options off of SPECS, modifying INFO
+;;; accordingly. The remaining portion of the list is returned when we
+;;; encounter a plausible function name.
 (defun parse-trace-options (specs info)
   (let ((current specs))
     (loop
@@ -453,8 +455,8 @@
     current))
 
 ;;; Compute the expansion of TRACE in the non-trivial case (arguments
-;;; specified.)  If there are no :FUNCTION specs, then don't use a LET. This
-;;; allows TRACE to be used without the full interpreter.
+;;; specified.) If there are no :FUNCTION specs, then don't use a LET.
+;;; This allows TRACE to be used without the full interpreter.
 (defun expand-trace (specs)
   (collect ((binds)
 	    (forms))
diff --git a/src/runtime/breakpoint.h b/src/runtime/breakpoint.h
index 798ae216f..305fa3895 100644
--- a/src/runtime/breakpoint.h
+++ b/src/runtime/breakpoint.h
@@ -17,7 +17,7 @@ extern void breakpoint_remove(lispobj code_obj,
 			      int pc_offset,
 			      unsigned long orig_inst);
 extern void breakpoint_do_displaced_inst(os_context_t *context,
-					  unsigned long orig_inst);
+					 unsigned long orig_inst);
 extern void handle_breakpoint(int signal, siginfo_t *info,
 			      os_context_t *context);
 extern void *handle_function_end_breakpoint(int signal, siginfo_t *info,
diff --git a/src/runtime/bsd-os.h b/src/runtime/bsd-os.h
index de568f869..1cdc422f8 100644
--- a/src/runtime/bsd-os.h
+++ b/src/runtime/bsd-os.h
@@ -28,6 +28,15 @@ typedef int os_vm_prot_t;
  * original FreeBSD port of SBCL, that's wrong, it's actually a
  * ucontext_t. */
 typedef ucontext_t os_context_t;
+/* KLUDGE: A hack inherited from CMU CL used to be conditional on
+ * !defined(__linux__), and has now been made conditional on
+ * CANNOT_GET_TO_SINGLE_STEP_FLAG: if the OS won't let us flip the
+ * single-step flag bit in the state stored in a signal context, then
+ * we need to mess around with overwriting preceding code with
+ * bit-flipping code. This isn't needed in Linux or OpenBSD; I haven't
+ * been able to test whether it's still needed in FreeBSD, so for
+ * conservatism it's left in. -- WHN 2000-10-24 */
+#define CANNOT_GET_TO_SINGLE_STEP_FLAG
 #elif defined __OpenBSD__
 typedef struct sigcontext os_context_t;
 #else
diff --git a/src/runtime/x86-arch.c b/src/runtime/x86-arch.c
index d72c219e5..aaad2a158 100644
--- a/src/runtime/x86-arch.c
+++ b/src/runtime/x86-arch.c
@@ -144,8 +144,8 @@ arch_remove_breakpoint(void *pc, unsigned long orig_inst)
 
 /* When single stepping, single_stepping holds the original instruction
  * PC location. */
-unsigned int *single_stepping=NULL;
-#ifndef __linux__
+unsigned int *single_stepping = NULL;
+#ifdef CANNOT_GET_TO_SINGLE_STEP_FLAG
 unsigned int  single_step_save1;
 unsigned int  single_step_save2;
 unsigned int  single_step_save3;
@@ -160,9 +160,7 @@ arch_do_displaced_inst(os_context_t *context, unsigned long orig_inst)
     *((char *)pc) = orig_inst & 0xff;
     *((char *)pc + 1) = (orig_inst & 0xff00) >> 8;
 
-#ifdef __linux__
-    *context_eflags_addr(context) |= 0x100;
-#else
+#ifdef CANNOT_GET_TO_SINGLE_STEP_FLAG
     /* Install helper instructions for the single step:
      * pushf; or [esp],0x100; popf. */
     single_step_save1 = *(pc-3);
@@ -171,11 +169,13 @@ arch_do_displaced_inst(os_context_t *context, unsigned long orig_inst)
     *(pc-3) = 0x9c909090;
     *(pc-2) = 0x00240c81;
     *(pc-1) = 0x9d000001;
+#else
+    *context_eflags_addr(context) |= 0x100;
 #endif
 
     single_stepping = (unsigned int*)pc;
 
-#ifndef __linux__
+#ifdef CANNOT_GET_TO_SINGLE_STEP_FLAG
     *os_context_pc_addr(context) = (char *)pc - 9;
 #endif
 }
@@ -191,7 +191,7 @@ sigtrap_handler(int signal, siginfo_t *info, void *void_context)
     {
 	/* fprintf(stderr,"* single step trap %x\n", single_stepping); */
 
-#ifndef __linux__
+#ifdef CANNOT_GET_TO_SINGLE_STEP_FLAG
 	/* Un-install single step helper instructions. */
 	*(single_stepping-3) = single_step_save1;
 	*(single_stepping-2) = single_step_save2;
diff --git a/version.lisp-expr b/version.lisp-expr
index 4c3dc834d..0deeccc2c 100644
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -15,4 +15,4 @@
 ;;; versions, and a string a la "0.6.5.12" is used for versions which
 ;;; aren't released but correspond only to CVS tags or snapshots.
 
-"0.6.7.24"
+"0.6.7.26"