Changeset 7367


Ignore:
Timestamp:
Oct 8, 2007, 2:54:19 AM (12 years ago)
Author:
gb
Message:

(Hopefully) straighten out some backtrace stuff.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/ccl/lib/backtrace.lisp

    r6928 r7367  
    6363
    6464(defun %show-args-and-locals (p context lfun pc)
    65   (multiple-value-bind (args locals) (arguments-and-locals context p lfun pc)
    66     (format t "~&  ~s" (arglist-from-map lfun))
    67     (let* ((*print-length* *backtrace-print-length*)
    68            (*print-level* *backtrace-print-level*))
    69       (flet ((show-pair (pair prefix)
    70                (destructuring-bind (name . val) pair
    71                  (format t "~&~a~s: " prefix name)
    72                  (if (eq val (%unbound-marker))
    73                    (format t "#<Unavailable>")
    74                    (format t "~s" val)))))
    75         (dolist (arg args)
    76           (show-pair arg "   "))
    77         (terpri)
    78         (terpri)
    79         (dolist (loc locals)
    80           (show-pair loc "  "))
    81         (terpri)
    82         (terpri)))))
     65  (let* ((unavailable (cons nil nil)))
     66    (multiple-value-bind (args locals) (arguments-and-locals context p lfun pc unavailable)
     67      (format t "~&  ~s" (arglist-from-map lfun))
     68      (let* ((*print-length* *backtrace-print-length*)
     69             (*print-level* *backtrace-print-level*))
     70        (flet ((show-pair (pair prefix)
     71                 (destructuring-bind (name . val) pair
     72                   (format t "~&~a~s: " prefix name)
     73                   (if (eq val unavailable)
     74                     (format t "#<Unavailable>")
     75                     (format t "~s" val)))))
     76          (dolist (arg args)
     77            (show-pair arg "   "))
     78          (terpri)
     79          (terpri)
     80          (dolist (loc locals)
     81            (show-pair loc "  "))
     82          (terpri)
     83          (terpri))))))
    8384
    8485
     
    212213             (match-local-name cellno (function-symbol-map lfun) pc))))))))
    213214
     215(defun map-entry-value (context cfp lfun pc idx unavailable)
     216  (declare (fixnum pc idx))
     217  (let* ((info (function-symbol-map lfun)))
     218    (if (null info)
     219      unavailable
     220      (let* ((addrs (cdr info))
     221             (i (* 3 idx))
     222             (addr (svref addrs i))
     223             (startpc (svref addrs (the fixnum (+ i 1))))
     224             (endpc (svref addrs (the fixnum (+ i 2)))))
     225        (declare (fixnum i addr startpc endpc))
     226        (if (or (< pc startpc)
     227                (>= pc endpc))
     228          unavailable
     229          (let* ((value (if (= #o77 (ldb (byte 6 0) addr))
     230                          (raw-frame-ref cfp context (ash addr (- (+ target::word-shift 6)))
     231                                         unavailable)
     232                          (find-register-argument-value context cfp addr unavailable))))
     233            (if (typep value 'value-cell)
     234              (uvref value 0)
     235              value)))))))
     236
    214237(defun argument-value (context cfp lfun pc name &optional (quote t))
    215238  (declare (fixnum pc))
     
    346369  ;; at relative program counter PC, using the function's symbol map.
    347370  ;; The list will be ordered so that least-recent bindings appear first.
     371  ;; Return a list of the matching symbol map entries as a second value
    348372  (when pc
    349373    (locally (declare (fixnum pc))
     
    352376             (info (cdr map)))
    353377        (when map
    354           (let* ((vars ()))
    355             (dotimes (i (length names) vars)
     378          (let* ((vars ())
     379                 (indices ()))
     380            (dotimes (i (length names) (values vars indices))
    356381              (let* ((start-pc (aref info (1+ (* 3 i))))
    357382                     (end-pc (aref info (+ 2 (* 3 i)))))
     
    359384                (when (and (>= pc start-pc)
    360385                           (< pc end-pc))
     386                  (push i indices)
    361387                  (push (svref names i) vars))))))))))
    362388
    363 (defun arguments-and-locals (context cfp lfun pc)
    364   (let* ((vars (variables-in-scope lfun pc)))
     389(defun arguments-and-locals (context cfp lfun pc unavailable)
     390  (multiple-value-bind (vars map-indices) (variables-in-scope lfun pc)
    365391    (collect ((args)
    366392              (locals))
    367     (multiple-value-bind (valid req opt rest keys)
    368         (arg-names-from-map lfun pc)
    369       (when valid
    370         (flet ((get-arg-value (name)
    371                  (let* ((avail (member name vars :test #'eq)))
    372                    (if avail
    373                      (setf (car (member name vars :test #'eq)) nil))
    374                    (args (cons name (argument-value context cfp lfun pc name nil)))))
    375                (get-local-value (name)
    376                  (when name
    377                    (locals (cons name (argument-value context cfp lfun pc name nil))))))
    378           (dolist (name req)
    379             (get-arg-value name))
    380           (dolist (name opt)
    381             (get-arg-value name))
    382           (when rest
    383             (get-arg-value rest))
    384           (dolist (name keys)
    385             (get-arg-value name))
    386           (dolist (name vars)
    387             (get-local-value name))))
    388       (values (args) (locals))))))
     393      (multiple-value-bind (valid req opt rest keys)
     394          (arg-names-from-map lfun pc)
     395        (when valid
     396          (let* ((nargs (+ (length req) (length opt) (if rest 1 0) (length keys)))
     397                 (nlocals (- (length vars) nargs))
     398                 (local-vars (nthcdr nargs vars))
     399                 (local-indices (nthcdr nargs map-indices))
     400                 (arg-vars (nbutlast vars nlocals))
     401                 (arg-indices (nbutlast map-indices nlocals)))
     402            (flet ((get-arg-value (name)
     403                     (let* ((pos (position name arg-vars :test #'eq)))
     404                       (when pos
     405                         (args (cons name (map-entry-value context cfp lfun pc (nth pos arg-indices) unavailable))))))
     406                   (get-local-value (name)
     407                     (when name
     408                       (locals (cons name (map-entry-value context cfp lfun pc (pop local-indices) unavailable))))))
     409              (dolist (name req)
     410                (get-arg-value name))
     411              (dolist (name opt)
     412                (get-arg-value name))
     413              (when rest
     414                (get-arg-value rest))
     415              (dolist (name keys)
     416                (get-arg-value name))
     417              #+no
     418              (setq local-vars (nreverse local-vars)
     419                    local-indices (nreverse local-indices))
     420              (dolist (name local-vars)
     421                (get-local-value name)))))
     422        (values (args) (locals))))))
    389423                   
    390424           
Note: See TracChangeset for help on using the changeset viewer.