Changeset 11659


Ignore:
Timestamp:
Jan 29, 2009, 6:32:04 PM (10 years ago)
Author:
gz
Message:

Make print-call-history and backtrace-as-list support a :process argument to get the backtrace of that process without interrupting it.

Location:
trunk/source
Files:
9 edited

Legend:

Unmodified
Added
Removed
  • trunk/source/compiler/PPC/PPC32/ppc32-arch.lisp

    r11631 r11659  
    578578  free
    579579  jvm-init
    580   allocate_vstack
     580  tcr-frame-ptr
    581581  register_cstack
    582582  open-debug-output
  • trunk/source/compiler/PPC/PPC64/ppc64-arch.lisp

    r11631 r11659  
    648648  free
    649649  jvm-init
    650   allocate_vstack
     650  tcr-frame-ptr
    651651  register_cstack
    652652  open-debug-output
  • trunk/source/compiler/X86/X8632/x8632-arch.lisp

    r11631 r11659  
    695695  free
    696696  jvm-init
    697   allocate_vstack
     697  tcr-frame-ptr
    698698  register_cstack
    699699  open-debug-output
  • trunk/source/compiler/X86/X8664/x8664-arch.lisp

    r11631 r11659  
    795795  free
    796796  jvm-init
    797   allocate_vstack
     797  tcr-frame-ptr
    798798  register_cstack
    799799  open-debug-output
  • trunk/source/level-1/l1-lisp-threads.lisp

    r11242 r11659  
    334334
    335335
     336(defun %tcr-frame-ptr (tcr)
     337  (with-macptrs (p)
     338    (%setf-macptr-to-object p tcr)
     339    (%fixnum-from-macptr
     340     (ff-call (%kernel-import target::kernel-import-tcr-frame-ptr)
     341              :address p
     342              :address))))
     343 
    336344(defun thread-exhausted-p (thread)
    337345  (or (null thread)
     
    594602
    595603
    596 (defun last-frame-ptr (&optional context)
    597   (let* ((current (if context (bt.current context) (%current-frame-ptr)))
     604(defun last-frame-ptr (&optional context origin)
     605  (let* ((current (or origin
     606                      (if context (bt.current context) (%current-frame-ptr))))
    598607         (last current))
    599608    (loop
  • trunk/source/lib/backtrace.lisp

    r11134 r11659  
    3232   If :DIRECT, uses a more streamlined format.")
    3333
     34(defun context-for-suspended-tcr (tcr)
     35  (let ((frame-ptr (%tcr-frame-ptr tcr)))
     36    (new-backtrace-info nil
     37                        frame-ptr ;; youngest - not used
     38                        frame-ptr ;; oldest - not used
     39                        tcr
     40                        nil       ;; condition - not used
     41                        frame-ptr ;; current
     42                        #+ppc-target *fake-stack-frames*
     43                        #+x86-target frame-ptr
     44                        (%fixnum-ref tcr target::tcr.db-link)
     45                        0         ;; break level - not used
     46                        )))
     47 
     48
    3449(defun backtrace-as-list (&key
    3550                          context
    36                           (origin (%get-frame-ptr))
     51                          process
     52                          origin
    3753                          (count target::target-most-positive-fixnum)
    3854                          (start-frame-number 0)
     
    4763object."
    4864  (when (null count) (setq count target::target-most-positive-fixnum))
    49   (let* ((tcr (if context (bt.tcr context) (%current-tcr)))
     65  (when (and context process (neq (bt.tcr context) (process-tcr process)))
     66    (error "Context ~s doesn't correspond to the process ~s" context process))
     67  (let* ((tcr (cond (context (bt.tcr context))
     68                    (process (process-tcr process))
     69                    (t (%current-tcr))))
    5070         (*debug-io* stream)
    5171         (*backtrace-print-level* print-level)
     
    5474         (*backtrace-format* :list))
    5575    (if (eq tcr (%current-tcr))
    56       (%backtrace-as-list-internal context origin count start-frame-number)
     76      (%backtrace-as-list-internal context (or origin (%get-frame-ptr)) count start-frame-number)
    5777      (unwind-protect
    5878           (progn
    5979             (%suspend-tcr tcr)
    60              (%backtrace-as-list-internal context origin count start-frame-number))
     80             (unless context
     81               (setq context (context-for-suspended-tcr tcr)))
     82             (%backtrace-as-list-internal context (or origin (bt.current context)) count start-frame-number))
    6183        (%resume-tcr tcr)))))
    6284
     
    6688                               
    6789(defun print-call-history (&key context
    68                                 (origin (%get-frame-ptr))
     90                                process
     91                                origin
    6992                                (detailed-p t)
    7093                                (count target::target-most-positive-fixnum)
     
    7699                                (format *backtrace-format*))
    77100  (when (null count) (setq count target::target-most-positive-fixnum))
    78   (let* ((tcr (if context (bt.tcr context) (%current-tcr)))
     101  (when (and context process (neq (bt.tcr context) (process-tcr process)))
     102    (error "Context ~s doesn't correspond to the process ~s" context process))
     103  (let* ((tcr (cond (context (bt.tcr context))
     104                    (process (process-tcr process))
     105                    (t (%current-tcr))))
    79106         (*debug-io* stream)
    80107         (*backtrace-print-level* print-level)
     
    83110         (*backtrace-format* format))
    84111    (if (eq tcr (%current-tcr))
    85       (%print-call-history-internal context origin detailed-p count start-frame-number)
     112      (%print-call-history-internal context (or origin (%get-frame-ptr)) detailed-p count start-frame-number)
    86113      (unwind-protect
    87114           (progn
    88              (%suspend-tcr tcr )
    89              (%print-call-history-internal context origin detailed-p count start-frame-number))
     115             (%suspend-tcr tcr)
     116             (unless context
     117               (setq context (context-for-suspended-tcr tcr)))
     118             (%print-call-history-internal context (or origin (bt.current context)) detailed-p count start-frame-number))
    90119        (%resume-tcr tcr)))
    91120    (values)))
     
    232261
    233262(defun %backtrace-as-list-internal (context origin count skip-initial)
     263  (unless (eq (last-frame-ptr context origin) (last-frame-ptr context))
     264    (error "Origin ~s is not in the stack of ~s" origin context))
    234265  (let ((*print-catch-errors* t)
    235266        (p origin)
     
    260291(defun %print-call-history-internal (context origin detailed-p
    261292                                             &optional (count target::target-most-positive-fixnum) (skip-initial 0))
     293  (unless (eq (last-frame-ptr context origin) (last-frame-ptr context))
     294    (error "Origin ~s is not in the stack of ~s" origin context))
    262295  (let ((*standard-output* *debug-io*)
    263296        (*print-circle* nil)
  • trunk/source/lisp-kernel/imports.s

    r11623 r11659  
    4949        defimport(deallocate)
    5050        defimport(jvm_init)
    51         defimport(allocate_vstack_holding_area_lock)
     51        defimport(tcr_frame_ptr)
    5252        defimport(register_cstack_holding_area_lock)
    5353        defimport(open_debug_output)
  • trunk/source/lisp-kernel/ppc-exceptions.c

    r11623 r11659  
    686686    a->active = a->high;
    687687  }
     688}
     689
     690LispObj *
     691tcr_frame_ptr(TCR *tcr)
     692{
     693  ExceptionInformation *xp;
     694  LispObj *bp = NULL;
     695
     696  if (tcr->pending_exception_context)
     697    xp = tcr->pending_exception_context;
     698  else {
     699    xp = tcr->suspend_context;
     700  }
     701  if (xp) {
     702    bp = (LispObj *) xpGPR(xp, sp);
     703  }
     704  return bp;
    688705}
    689706
  • trunk/source/lisp-kernel/x86-exceptions.c

    r11623 r11659  
    14291429}
    14301430#endif
     1431
     1432
     1433LispObj *
     1434tcr_frame_ptr(TCR *tcr)
     1435{
     1436  ExceptionInformation *xp;
     1437  LispObj *bp;
     1438
     1439  if (tcr->pending_exception_context)
     1440    xp = tcr->pending_exception_context;
     1441  else if (tcr->valence == TCR_STATE_LISP) {
     1442    xp = tcr->suspend_context;
     1443  } else {
     1444    xp = NULL;
     1445  }
     1446  if (xp) {
     1447#ifdef X8664
     1448    bp = (LispObj *) xpGPR(xp, Irbp);
     1449#else
     1450    bp = (LispObj *) xpGPR(xp, Iebp);
     1451#endif
     1452  } else {
     1453#ifdef X8664
     1454    bp = tcr->save_rbp;
     1455#else
     1456    bp = tcr->save_ebp;
     1457#endif
     1458  }
     1459  return bp;
     1460}
    14311461
    14321462
Note: See TracChangeset for help on using the changeset viewer.