Changeset 11053

Timestamp:

01/23/06 14:11:02 (3 years ago)

Author:

rtoy

Message:

Implement tracing of flet/labels functions. This probably needs more
work and could probably be implemented better.

With these changes (trace (labels foo bar)) will trace the labels
function FOO in the function BAR. We only support encapsulate nil,
here. No check is made for this.

code/ntrace.lisp:
o In TRACE-FDEFINITION, recognize a list as a valid function, and

return the list as the value of TRACE-FDEFINITION. This seems
wrong, but I'm not sure if there's a real fdefinition for it, or if
we could create a fake one.

code/debug-int.lisp:
o In FUNCTION-DEBUG-FUNCTION, recognize a list as the name of a

function, and find the corresponding compiled-debug-function and
create and return the new compiled-debug-function.

Location:

trunk/src/code

Files:

• debug-int.lisp (modified) (31 diffs)
• ntrace.lisp (modified) (1 diff)

trunk/src/code/debug-int.lisp

@@ -84 +84 @@
 ;;; routine that detects them and signals a condition.  For example,
 ;;; programmers call A which may fail to return successfully due to a lack of
-;;; debug information, and there is no B the they could have called to realize
+;;; debug information, and there is no B that they could have called to realize
 ;;; A would fail.  It is not an error to have called A, but it is an error for
 ;;; the program to then ignore the signal generated by A since it cannot
@@ -170 +170 @@
 ;;; The debug-internals code tries to signal all programmer errors as subtypes
 ;;; of debug-error.  There are calls to ERROR signalling simple-errors, but
-;;; these dummy checks in the code and shouldn't come up.
+;;; these dummy checks in the code shouldn't come up.
 ;;;
 ;;; While under development, this code also signals errors in code branches
@@ -852 +852 @@
 (defun cstack-pointer-valid-p (x)
   (declare (type system:system-area-pointer x))
-  #-:x86
+  #-(or :x86 :amd64)
   (and (system:sap< x (kernel:current-sp))
        (system:sap<= #-gengc (alien:alien-sap
@@ -859 +859 @@
                      x)
        (zerop (logand (system:sap-int x) #b11)))
-  #+:x86 ;; stack grows to low address values
+  #+(or :x86 :amd64) ;; stack grows to low address values
   (and (system:sap>= x (kernel:current-sp))
        (system:sap> (alien:alien-sap
@@ -866 +866 @@
        (zerop (logand (system:sap-int x) #b11))))
 
-#+(or gengc x86)
+#+(or gengc x86 amd64)
 (alien:def-alien-routine component-ptr-from-pc (system:system-area-pointer)
   (pc system:system-area-pointer))
 
-#+(or gengc x86)
+#+(or gengc x86 amd64)
 (defun component-from-component-ptr (component-ptr)
   (declare (type system:system-area-pointer component-ptr))
@@ -933 +933 @@
    (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))))
+    (let ((lisp-ocfp (sap-ref-sap fp (- (* (1+ vm::ocfp-save-offset) 
+                                           vm:word-bytes))))
+          (lisp-ra (sap-ref-sap fp (- (* (1+ vm::return-pc-save-offset)
+                                         vm:word-bytes))))
           (c-ocfp (sap-ref-sap fp (* 0 vm:word-bytes)))
           (c-ra (sap-ref-sap fp (* 1 vm:word-bytes))))
@@ -986 +988 @@
              nil))))))
 
-) ; end progn x86
+) ; end progn x86 amd64
 
 
@@ -1080 +1082 @@
 ;;; main location.
 ;;;
-#-x86
+#-(or x86 amd64)
 (defun get-context-value (frame stack-slot loc)
   (declare (type compiled-frame frame) (type unsigned-byte stack-slot)
@@ -1089 +1091 @@
         (sub-access-debug-var-slot pointer loc escaped)
         (kernel:stack-ref pointer stack-slot))))
-#+x86
+#+(or x86 amd64)
 (defun get-context-value (frame stack-slot loc)
   (declare (type compiled-frame frame) (type unsigned-byte stack-slot)
@@ -1101 +1103 @@
            (kernel:stack-ref pointer stack-slot))
           (#.vm::lra-save-offset
-           (sap-ref-sap pointer (- (* (1+ stack-slot) 4))))))))
-
-;;;
-#-x86
+           (sap-ref-sap pointer (- (* (1+ stack-slot) vm:word-bytes))))))))
+
+;;;
+#-(or x86 amd64)
 (defun (setf get-context-value) (value frame stack-slot loc)
   (declare (type compiled-frame frame) (type unsigned-byte stack-slot)
@@ -1114 +1116 @@
         (setf (kernel:stack-ref pointer stack-slot) value))))
 
-#+x86
+#+(or x86 amd64)
 (defun (setf get-context-value) (value frame stack-slot loc)
   (declare (type compiled-frame frame) (type unsigned-byte stack-slot)
@@ -1126 +1128 @@
            (setf (kernel:stack-ref pointer stack-slot) value))
           (#.vm::lra-save-offset
-           (setf (sap-ref-sap pointer (- (* (1+ stack-slot) 4))) value))))))
+           (setf (sap-ref-sap pointer (- (* (1+ stack-slot) vm:word-bytes)))
+                 value))))))
 
 
@@ -1177 +1180 @@
 
 
-#+(or sparc (and x86 linux))
+#+(or sparc (and (or x86 amd64) linux))
 (defun find-foreign-function-name (address)
   "Return a string describing the foreign function near ADDRESS"
@@ -1200 +1203 @@
                        )))))))
 
-#-(or sparc (and x86 linux))
+#-(or sparc (and (or x86 amd64) linux))
 (defun find-foreign-function-name (ra)
   (declare (ignore ra))
@@ -1249 +1252 @@
 ;;; LRA, and the LRA is the word offset.
 ;;;
-#-(or gengc x86)
+#-(or gengc x86 amd64)
 (defun compute-calling-frame (caller lra up-frame)
   (declare (type system:system-area-pointer caller))
@@ -1300 +1303 @@
                                  escaped))))))
 
-#+x86
+#+(or x86 amd64)
 (defun compute-calling-frame (caller ra up-frame)
   (declare (type system:system-area-pointer caller ra))
@@ -1534 +1537 @@
 ;;;     - closure_tramp
 ;;;     - function_end_breakpoint
-;;;        arn't ever actually in it, because we copy it into a bogus-lra
-;;;        component before every actually using it.
+;;;        aren't ever actually in it, because we copy it into a bogus-lra
+;;;        component before ever actually using it.
 ;;;    or someone jumped someplace strange, in which case we can't do anything.
 ;;; - component w/ :ASSEMBLER-ROUTINE for debug-info:
@@ -1776 +1779 @@
                                       (* vm:catch-block-current-cont-slot
                                          vm:word-bytes))))
-        (let* (#-(or gengc x86)
+        (let* (#-(or gengc x86 amd64)
                (lra (kernel:stack-ref catch vm:catch-block-entry-pc-slot))
-               #+(or gengc x86)
+               #+(or gengc x86 amd64)
                (ra (system:sap-ref-sap
                     catch (* vm:catch-block-entry-pc-slot vm:word-bytes)))
-               #-x86
+               #-(or x86 amd64)
                (component
                 (kernel:stack-ref catch vm:catch-block-current-code-slot))
-               #+x86
+               #+(or x86 amd64)
                (component (component-from-component-ptr 
                            (component-ptr-from-pc ra)))
                (offset
-                #-(or gengc x86)
+                #-(or gengc x86 amd64)
                 (* (- (1+ (kernel:get-header-data lra))
                       (kernel:get-header-data component))
@@ -1797 +1800 @@
                       (kernel:get-header-data component))
                    vm:other-pointer-type)
-                #+x86
+                #+(or x86 amd64)
                 (- (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
+          (push (cons #-(or x86 amd64)
                       (kernel:stack-ref catch vm:catch-block-tag-slot)
-                      #+x86
+                      #+(or x86 amd64)
                       (kernel:make-lisp-obj
                        (system:sap-ref-32 catch (* vm:catch-block-tag-slot
@@ -3734 +3737 @@
 ;;;
 ;;; The vector elements are in the same format as the compiler's
-;;; NODE-SOUCE-PATH; that is, the first element is the form number and the last
+;;; NODE-SOURCE-PATH; that is, the first element is the form number and the last
 ;;; is the top-level-form number.
 ;;;
@@ -3963 +3966 @@
         (%make-breakpoint hook-function what kind info))
        (:function-end
-        (unless (eq (c::compiled-debug-function-returns
-                     (compiled-debug-function-compiler-debug-fun what))
-                    :standard)
-          (error ":FUNCTION-END breakpoints are currently unsupported ~
-                  for the known return convention."))
-                  
-        (let* ((bpt (%make-breakpoint hook-function what kind info))
-               (starter (compiled-debug-function-end-starter what)))
-          (unless starter
-            (setf starter (%make-breakpoint #'list what :function-start nil))
-            (setf (breakpoint-hook-function starter)
-                  (function-end-starter-hook starter what))
-            (setf (compiled-debug-function-end-starter what) starter))
-          (setf (breakpoint-start-helper bpt) starter)
-          (push bpt (breakpoint-%info starter))
-          (setf (breakpoint-cookie-fun bpt) function-end-cookie)
-          bpt))))
+        (multiple-value-bind (settable known-return)
+            (can-set-function-end-breakpoint-p what)
+          (cond (settable
+                 (let* ((bpt (%make-breakpoint hook-function what kind info))
+                        (starter (compiled-debug-function-end-starter what)))
+                   (unless starter
+                     (setf starter (%make-breakpoint #'list what :function-start 
+                                                     nil))
+                     (setf (breakpoint-hook-function starter)
+                           (function-end-starter-hook starter what known-return))
+                     (setf (compiled-debug-function-end-starter what) starter))
+                   (setf (breakpoint-start-helper bpt) starter)
+                   (push bpt (breakpoint-%info starter))
+                   (setf (breakpoint-cookie-fun bpt) function-end-cookie)
+                   bpt))
+                (t
+                 (error ":FUNCTION-END breakpoints are currently unsupported ~
+                       for the known return convention.")))))))
     (interpreted-debug-function
      (error ":function-end breakpoints are currently unsupported ~
@@ -3987 +3991 @@
   (typecase what
     (compiled-debug-function
-     (eq (c::compiled-debug-function-returns
-          (compiled-debug-function-compiler-debug-fun what))
-         :standard))))
+     (let ((returns (c::compiled-debug-function-returns
+                     (compiled-debug-function-compiler-debug-fun what))))
+       ;; First value says if we can set the function-end-breakpoint.
+       ;; The second value indicates if this is the known return
+       ;; convention.
+       (values (or (eq returns :standard)
+                   (typep returns 'vector))
+               (not (eq returns :standard)))))))
 
 ;;; These are unique objects created upon entry into a function by a
@@ -4022 +4031 @@
 ;;; fun-end-bpt.
 ;;;
-(defun function-end-starter-hook (starter-bpt debug-fun)
+(defun function-end-starter-hook (starter-bpt debug-fun &optional known-return-p)
   (declare (type breakpoint starter-bpt)
            (type compiled-debug-function debug-fun))
@@ -4036 +4045 @@
                                                  #-gengc vm::lra-save-offset
                                                  #+gengc vm::ra-save-offset
-                                                 lra-sc-offset))
+                                                 lra-sc-offset)
+                              known-return-p)
           (setf (get-context-value frame
                                    #-gengc vm::lra-save-offset
@@ -4071 +4081 @@
         ((not frame) nil)
       (when (and (compiled-frame-p frame)
-                 (#-x86 eq #+x86 sys:sap= lra
+                 (#-(or x86 amd64) eq #+(or x86 amd64) sys:sap= lra
                      (get-context-value frame
                                         #-gengc vm::lra-save-offset
@@ -4396 +4406 @@
                                     (breakpoint-data-instruction data))
       ; Under HPUX we can't sigreturn so bp-do-disp-i has to return.
-      #-(or hpux irix x86)
+      #-(or hpux irix x86 amd64)
       (error "BREAKPOINT-DO-DISPLACED-INST returned?"))))
 
@@ -4446 +4456 @@
     (remhash component *function-end-cookies*)
     (dolist (bpt breakpoints)
-      (funcall (breakpoint-hook-function bpt)
-               frame bpt
-               (get-function-end-breakpoint-values scp)
-               cookie))))
-
-(defun get-function-end-breakpoint-values (scp)
-  (let ((ocfp (system:int-sap (vm:sigcontext-register scp
-                                                      #-x86 vm::ocfp-offset
-                                                      #+x86 vm::ebx-offset)))
+      (let ((values (get-function-end-breakpoint-values bpt scp)))
+        (funcall (breakpoint-hook-function bpt) frame bpt values cookie)))))
+
+;;; Return a list of return values at the function end breakpoint
+;;; BREAKPOINT.
+;;;
+(defun get-function-end-breakpoint-values (breakpoint sigcontext)
+  (let* ((what (breakpoint-what breakpoint))
+         (returns (c::compiled-debug-function-returns
+                   (compiled-debug-function-compiler-debug-fun what))))
+    (etypecase returns 
+      ((member :standard)
+       (function-end-breakpoint-values/standard sigcontext))
+      (vector
+       (function-end-breakpoint-values/known-return sigcontext returns)))))
+
+;;; Return a list of return values at a breakpoint with standard
+;;; return convention.
+;;; 
+(defun function-end-breakpoint-values/standard (scp)
+  (let ((ocfp (sigcontext-ocfp-sap scp))
         (nargs (kernel:make-lisp-obj
                 (vm:sigcontext-register scp vm::nargs-offset)))
@@ -4464 +4486 @@
                  (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)))
 
+;;; Return a list of return values at a breakpoint with known-return
+;;; convention.
+;;; 
+(defun function-end-breakpoint-values/known-return (sigcontext sc-offsets)
+  (let ((ocfp (sigcontext-ocfp-sap sigcontext)))
+    (loop for offset across sc-offsets
+          collect (sub-access-debug-var-slot ocfp offset sigcontext))))
+
+;;; Extract the old frame pointer from a sigcontext structure.  The
+;;; result is a SAP.
+;;; 
+(defun sigcontext-ocfp-sap (sigcontext)
+  (system:int-sap
+   (vm:sigcontext-register sigcontext
+                           #-(or x86 amd64) vm::ocfp-offset
+                           #+(or x86 amd64) vm::ebx-offset)))
+
 ;;;
 ;;; MAKE-BOGUS-LRA (used for :function-end breakpoints)
 ;;;
-
-(defconstant bogus-lra-constants #-x86 2 #+x86 3)
-(defconstant known-return-p-slot (+ vm:code-constants-offset #-x86 1 #+x86 2))
+;;; (If you change these, look in breakpoint.c too!)
+
+(defconstant bogus-lra-constants #-(or x86 amd64) 2 #+(or x86 amd64) 3)
+(defconstant known-return-p-slot (+ vm:code-constants-offset #-(or x86 amd64) 1 #+(or x86 amd64) 2))
 
 ;;; MAKE-BOGUS-LRA -- Interface.
@@ -4495 +4535 @@
           (code-object
            (system:%primitive
-            #-(and x86 gencgc) c:allocate-code-object
-            #+(and x86 gencgc) c::allocate-dynamic-code-object
+            #-(and (or x86 amd64) gencgc) c:allocate-code-object
+            #+(and (or x86 amd64) gencgc) c::allocate-dynamic-code-object
             (1+ bogus-lra-constants)
             length))
@@ -4506 +4546 @@
      (setf (kernel:code-header-ref code-object vm:code-trace-table-offset-slot)
            length)
-     #-x86
+     #-(or x86 amd64)
      (setf (kernel:code-header-ref code-object real-lra-slot) real-lra)
-     #+x86
+     #+(or x86 amd64)
      (multiple-value-bind (offset code)
          (compute-lra-data-from-pc real-lra)
@@ -4517 +4557 @@
      (kernel:system-area-copy src-start 0 dst-start 0 (* length vm:byte-bits))
      (vm:sanctify-for-execution code-object)
-     #+x86
+     #+(or x86 amd64)
      (values dst-start code-object (system:sap- trap-loc src-start))
-     #-x86
+     #-(or x86 amd64)
      (let ((new-lra (kernel:make-lisp-obj (+ (system:sap-int dst-start)
                                              vm:other-pointer-type))))

trunk/src/code/ntrace.lisp

@@ -35 +35 @@
    0.")
 
-(defvar *trace-encapsulate-default* :default
+(defvar *trace-encapsulate-default* #-ppc :default #+ppc t
   "The default value for the :ENCAPSULATE option to trace.")