Changeset 7177


Ignore:
Timestamp:
Sep 7, 2007, 11:24:42 AM (12 years ago)
Author:
gb
Message:

Stack-walking stuff to get/set arg/local values.
In ARGUMENTS-AND-LOCALS, try to be more careful about shadowing bindings.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • branches/working-0709/ccl/lib/backtrace.lisp

    r6928 r7177  
    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
     237;;; Returns non-nil on success (not newval)
     238(defun set-map-entry-value (context cfp lfun pc idx newval)
     239  (declare (fixnum pc idx))
     240  (let* ((unavailable (cons nil nil))
     241         (value (map-entry-value context cfp lfun pc idx unavailable)))
     242    (if (eq value unavailable)
     243      nil
     244      (if (typep value 'value-cell)
     245        (progn (setf (uvref value 0) newval) t)
     246
     247        (let* ((addrs (cdr (function-symbol-map lfun)))
     248               (addr (svref addrs (the fixnum (* 3 idx)))))
     249          (declare (fixnum  addr))
     250          (if (= #o77 (ldb (byte 6 0) addr))
     251            (raw-frame-set cfp context (ash addr (- (+ target::word-shift 6))) newval)
     252            (set-register-argument-value context cfp addr newval))
     253          t)))))
     254
     255         
    214256(defun argument-value (context cfp lfun pc name &optional (quote t))
    215257  (declare (fixnum pc))
     
    247289(defun raw-frame-ref (cfp context index bad)
    248290  (%raw-frame-ref cfp context index bad))
     291
     292(defun raw-frame-set (cfp context index new)
     293  (%raw-frame-set cfp context index new))
    249294 
    250295(defun find-register-argument-value (context cfp regval bad)
    251296  (%find-register-argument-value context cfp regval bad))
     297
     298(defun set-register-argument-value (context cfp regval newval)
     299  (%set-register-argument-value context cfp regval newval))
     300
    252301   
    253302
     
    346395  ;; at relative program counter PC, using the function's symbol map.
    347396  ;; The list will be ordered so that least-recent bindings appear first.
     397  ;; Return a list of the matching symbol map entries as a second value
    348398  (when pc
    349399    (locally (declare (fixnum pc))
     
    352402             (info (cdr map)))
    353403        (when map
    354           (let* ((vars ()))
    355             (dotimes (i (length names) vars)
     404          (let* ((vars ())
     405                 (indices ()))
     406            (dotimes (i (length names) (values vars indices))
    356407              (let* ((start-pc (aref info (1+ (* 3 i))))
    357408                     (end-pc (aref info (+ 2 (* 3 i)))))
     
    359410                (when (and (>= pc start-pc)
    360411                           (< pc end-pc))
     412                  (push i indices)
    361413                  (push (svref names i) vars))))))))))
    362414
    363 (defun arguments-and-locals (context cfp lfun pc)
    364   (let* ((vars (variables-in-scope lfun pc)))
     415
     416
     417
     418(defun arg-value (context cfp lfun pc unavailable name)
     419  (multiple-value-bind (vars map-indices) (variables-in-scope lfun pc)
     420    (multiple-value-bind (valid req opt rest keys)
     421        (arg-names-from-map lfun pc)
     422      (if valid
     423        (let* ((nargs (+ (length req) (length opt) (if rest 1 0) (length keys)))
     424               (pos (position name vars)))
     425          (if (and pos (< pos nargs))
     426            (map-entry-value context cfp lfun pc (nth pos map-indices) unavailable)
     427            unavailable))
     428        unavailable))))
     429
     430(defun local-value (context cfp lfun pc unavailable name)
     431  (multiple-value-bind (vars map-indices) (variables-in-scope lfun pc)
     432    (multiple-value-bind (valid req opt rest keys)
     433        (arg-names-from-map lfun pc)
     434      (if valid
     435        (let* ((nargs (+ (length req) (length opt) (if rest 1 0) (length keys)))
     436               (names (nthcdr nargs vars))
     437               (indices (nthcdr nargs map-indices))
     438               (pos (if (typep name 'unsigned-byte)
     439                      name
     440                      (position name names :from-end t))))
     441          (if (and pos (< pos nargs))
     442            (map-entry-value context cfp lfun pc (nth pos indices) unavailable)
     443            unavailable))
     444        unavailable))))
     445
     446(defun set-arg-value (context cfp lfun pc name new)
     447  (multiple-value-bind (vars map-indices) (variables-in-scope lfun pc)
     448    (multiple-value-bind (valid req opt rest keys)
     449        (arg-names-from-map lfun pc)
     450      (if valid
     451        (let* ((nargs (+ (length req) (length opt) (if rest 1 0) (length keys)))
     452               (pos (position name vars)))
     453          (when (and pos (< pos nargs))
     454            (set-map-entry-value context cfp lfun pc (nth pos map-indices) new)))))))
     455
     456(defun set-local-value (context cfp lfun pc name new)
     457  (multiple-value-bind (vars map-indices) (variables-in-scope lfun pc)
     458    (multiple-value-bind (valid req opt rest keys)
     459        (arg-names-from-map lfun pc)
     460      (if valid
     461        (let* ((nargs (+ (length req) (length opt) (if rest 1 0) (length keys)))
     462               (names (nthcdr nargs vars))
     463               (indices (nthcdr nargs map-indices))
     464               (pos (if (typep name 'unsigned-byte)
     465                      name
     466                      (position name names :from-end t))))
     467          (if (and pos (< pos nargs))
     468            (set-map-entry-value context cfp lfun pc (nth pos indices) new)))))))
     469             
     470
     471 
     472
     473(defun arguments-and-locals (context cfp lfun pc unavailable)
     474  (multiple-value-bind (vars map-indices) (variables-in-scope lfun pc)
    365475    (collect ((args)
    366476              (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))))))
     477      (multiple-value-bind (valid req opt rest keys)
     478          (arg-names-from-map lfun pc)
     479        (when valid
     480          (let* ((nargs (+ (length req) (length opt) (if rest 1 0) (length keys)))
     481                 (nlocals (- (length vars) nargs))
     482                 (local-vars (nthcdr nargs vars))
     483                 (local-indices (nthcdr nargs map-indices))
     484                 (arg-vars (nbutlast vars nlocals))
     485                 (arg-indices (nbutlast map-indices nlocals)))
     486            (flet ((get-arg-value (name)
     487                     (let* ((pos (position name arg-vars :test #'eq)))
     488                       (when pos
     489                         (args (cons name (map-entry-value context cfp lfun pc (nth pos arg-indices) unavailable))))))
     490                   (get-local-value (name)
     491                     (when name
     492                       (locals (cons name (map-entry-value context cfp lfun pc (pop local-indices) unavailable))))))
     493              (dolist (name req)
     494                (get-arg-value name))
     495              (dolist (name opt)
     496                (get-arg-value name))
     497              (when rest
     498                (get-arg-value rest))
     499              (dolist (name keys)
     500                (get-arg-value name))
     501              #+no
     502              (setq local-vars (nreverse local-vars)
     503                    local-indices (nreverse local-indices))
     504              (dolist (name local-vars)
     505                (get-local-value name)))))
     506        (values (args) (locals))))))
    389507                   
    390508           
     
    427545      (if (eq (%fixnum-ref db (ash 1 target::fixnum-shift)) binding-index)
    428546        (setq oldest db)))))
     547
     548(defun (setf oldest-binding-frame-value) (new context frame)
     549  (let* ((oldest nil)
     550         (binding-index (%fixnum-ref frame (ash 1 target::fixnum-shift))))
     551    (do* ((db (db-link context) (%fixnum-ref db 0)))
     552         ((eq frame db)
     553          (if oldest
     554            (setf (%fixnum-ref oldest (ash 2 target::fixnum-shift)) new)
     555            (let* ((symbol (binding-index-symbol binding-index)))
     556              (if context
     557                (setf (symbol-value-in-tcr symbol (bt.tcr context)) new)
     558                (%set-sym-value symbol new)))))
     559      (if (eq (%fixnum-ref db (ash 1 target::fixnum-shift)) binding-index)
     560        (setq oldest db)))))
    429561   
    430562
Note: See TracChangeset for help on using the changeset viewer.