Changeset 8023


Ignore:
Timestamp:
Jan 8, 2008, 12:44:48 AM (17 years ago)
Author:
Gary Byers
Message:

FRAME-SUPPLIED-ARGS: return actual argument values if PC is before/at target::arg-check-trap-pc-limit.

File:
1 edited

Legend:

Unmodified
Added
Removed

  • branches/working-0711/ccl/lib/backtrace-lds.lisp

    r7255 r8023  
    3939(defun frame-supplied-args (frame lfun pc child context)
    4040  (declare (ignore child))
    41   (let* ((arglist (arglist-from-map lfun))
    42          (args (arguments-and-locals context frame lfun pc))
    43          (state :required))
    44     (collect ((arg-values)
    45               (types)
    46               (names))
    47       (dolist (arg arglist)
    48         (if (or (member arg lambda-list-keywords)
    49                 (eq arg '&lexpr))
    50           (setq state arg)
    51           (let* ((pair (pop args)))
    52             (case state
    53               (&lexpr
    54                (with-list-from-lexpr (rest (cdr pair))
    55                  (dolist (r rest) (arg-values r) (names nil) (types nil)))
    56                (return))
    57               (&rest
    58                (dolist (r (cdr pair)) (arg-values r) (names nil) (types nil))
    59                (return))
    60               (&key
    61                (arg-values arg)
    62                (names nil)
    63                (types nil)))
    64             (let* ((value (cdr pair)))
    65               (if (eq value (%unbound-marker))
    66                 (return))
    67               (names (car pair))
    68               (arg-values value)
    69               (types nil)))))
    70       (values (arg-values) (types) (names)))))
    71 
    72 ;;; I'm skeptical about a lot of this stuff on the PPC, but if anything it's
    73 ;;; pretty PPC-specific
    74 #+ppc-target
    75 (progn
    76 ;;; Act as if VSTACK-INDEX points somewhere where DATA could go & put it there.
    77 (defun set-lisp-data (vstack-index data)
    78   (let* ((old (%access-lisp-data vstack-index)))
    79     (if (closed-over-value-p old)
    80       (set-closed-over-value old data)
    81       (%store-lisp-data vstack-index data))))
     41  (if (<= pc target::arg-check-trap-pc-limit)
     42    (values (arg-check-call-arguments frame lfun) nil nil)
     43    (let* ((arglist (arglist-from-map lfun))
     44           (args (arguments-and-locals context frame lfun pc))
     45           (state :required))
     46      (collect ((arg-values)
     47                (types)
     48                (names))
     49        (dolist (arg arglist)
     50          (if (or (member arg lambda-list-keywords)
     51                  (eq arg '&lexpr))
     52            (setq state arg)
     53            (let* ((pair (pop args)))
     54              (case state
     55                (&lexpr
     56                 (with-list-from-lexpr (rest (cdr pair))
     57                   (dolist (r rest) (arg-values r) (names nil) (types nil)))
     58                 (return))
     59                (&rest
     60                 (dolist (r (cdr pair)) (arg-values r) (names nil) (types nil))
     61                 (return))
     62                (&key
     63                 (arg-values arg)
     64                 (names nil)
     65                 (types nil)))
     66              (let* ((value (cdr pair)))
     67                (if (eq value (%unbound-marker))
     68                  (return))
     69                (names (car pair))
     70                (arg-values value)
     71                (types nil)))))
     72        (values (arg-values) (types) (names))))))
    8273
    8374
    84 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    85 ;;
    86 ;;extensions to let user access and modify values
    87 
    88 
    89 
    90 
    91 
    92 ;;; nth-frame-info, set-nth-frame-info, & frame-lfun are in "inspector;new-backtrace"
    93 
    94 
    95 
    96 
    97 
    98 
    99 (defparameter *saved-register-count+1*
    100   (1+ *saved-register-count*))
    101 
    102 
    103 
    104 (defparameter *saved-register-numbers*
    105   #+x8664-target #(wrong)
    106   #+ppc-target #(31 30 29 28 27 26 25 24))
    107 
    108 ;;; Don't do unbound checks in compiled code
    109 (declaim (type t *saved-register-count* *saved-register-count+1*
    110                *saved-register-names* *saved-register-numbers*))
    111 
    112 (defmacro %cons-saved-register-vector ()
    113   `(make-array (the fixnum *saved-register-count+1*) :initial-element nil))
    114 
    115 (defun copy-srv (from-srv &optional to-srv)
    116   (if to-srv
    117     (if (eq from-srv to-srv)
    118       to-srv
    119       (dotimes (i (uvsize from-srv) to-srv)
    120         (setf (uvref to-srv i) (uvref from-srv i))))
    121     (copy-uvector from-srv)))
    122 
    123 (defmacro srv.unresolved (saved-register-vector)
    124   `(svref ,saved-register-vector 0))
    125 
    126 (defmacro srv.register-n (saved-register-vector n)
    127   `(svref ,saved-register-vector (1+ ,n)))
    128 
    129 ;;; This isn't quite right - has to look at all functions on stack,
    130 ;;; not just those that saved VSPs.
    131 
    132 
    133 (defun frame-restartable-p (target &optional context)
    134   (multiple-value-bind (frame last-catch srv) (last-catch-since-saved-vars target context)
    135     (when frame
    136       (loop
    137         (when (null frame)
    138           (return-from frame-restartable-p nil))
    139         (when (eq frame target) (return))
    140         (multiple-value-setq (frame last-catch srv)
    141           (ccl::parent-frame-saved-vars context frame last-catch srv srv)))
    142       (when (and srv (eql 0 (srv.unresolved srv)))
    143         (setf (srv.unresolved srv) last-catch)
    144         srv))))
    145 
    146 
    147 ;;; get the saved register addresses for this frame
    148 ;;; still need to worry about this unresolved business
    149 ;;; could share some code with parent-frame-saved-vars
    150 (defun my-saved-vars (frame &optional (srv-out (%cons-saved-register-vector)))
    151   (let ((unresolved 0))
    152     (multiple-value-bind (lfun pc) (cfp-lfun frame)
    153         (if lfun
    154           (multiple-value-bind (mask where) (registers-used-by lfun pc)
    155             (when mask
    156               (if (not where)
    157                 (setq unresolved (%ilogior unresolved mask))
    158                 (let ((vsp (- (frame-vsp frame) where (1- (logcount mask))))
    159                       (j *saved-register-count*))
    160                   (declare (fixnum j))
    161                   (dotimes (i j)
    162                     (declare (fixnum i))
    163                     (when (%ilogbitp (decf j) mask)
    164                       (setf (srv.register-n srv-out i) vsp
    165                             vsp (1+ vsp)
    166                             unresolved (%ilogand unresolved (%ilognot (%ilsl j 1))))))))))
    167           (setq unresolved (1- (ash 1 *saved-register-count*)))))
    168     (setf (srv.unresolved srv-out) unresolved)
    169     srv-out))
    170 
    171 (defun parent-frame-saved-vars
    172        (context frame last-catch srv &optional (srv-out (%cons-saved-register-vector)))
    173   (copy-srv srv srv-out)
    174   (let* ((parent (and frame (parent-frame frame context)))
    175          (grand-parent (and parent (parent-frame parent context))))
    176     (when grand-parent
    177       (loop (let ((next-catch (and last-catch (next-catch last-catch))))
    178               ;(declare (ignore next-catch))
    179               (if (and next-catch (%stack< (catch-frame-sp next-catch) grand-parent context))
    180                 (progn
    181                   (setf last-catch next-catch
    182                         (srv.unresolved srv-out) 0)
    183                   (dotimes (i *saved-register-count*)
    184                     (setf (srv.register-n srv i) nil)))
    185                 (return))))
    186       (lookup-registers parent context grand-parent srv-out)
    187       (values parent last-catch srv-out))))
    188 
    189 (defun lookup-registers (parent context grand-parent srv-out)
    190   (unless (or (eql (frame-vsp grand-parent) 0)
    191               (let ((gg-parent (parent-frame grand-parent context)))
    192                 (eql (frame-vsp gg-parent) 0)))
    193     (multiple-value-bind (lfun pc) (cfp-lfun parent)
    194       (when lfun
    195         (multiple-value-bind (mask where) (registers-used-by lfun pc)
    196           (when mask
    197             (locally (declare (fixnum mask))
    198               (if (not where)
    199                 (setf (srv.unresolved srv-out) (%ilogior (srv.unresolved srv-out) mask))
    200                 (let* ((grand-parent-vsp (frame-vsp grand-parent)))
    201 
    202                   (let ((vsp (- grand-parent-vsp where 1))
    203                         (j *saved-register-count*))
    204                     (declare (fixnum j))
    205                     (dotimes (i j)
    206                       (declare (fixnum i))
    207                       (when (%ilogbitp (decf j) mask)
    208                         (setf (srv.register-n srv-out i) vsp
    209                               vsp (1- vsp)
    210                               (srv.unresolved srv-out)
    211                               (%ilogand (srv.unresolved srv-out) (%ilognot (%ilsl j 1))))))))))))))))
    212 
    213 ;;; initialization for looping on parent-frame-saved-vars
    214 (defun last-catch-since-saved-vars (frame context)
    215   (let* ((parent (parent-frame frame context))
    216          (last-catch (and parent (last-catch-since parent context))))
    217     (when last-catch
    218       (let ((frame (catch-frame-sp last-catch))
    219             (srv (%cons-saved-register-vector)))
    220         (setf (srv.unresolved srv) 0)
    221         (let* ((parent (parent-frame frame context))
    222                (child (and parent (child-frame parent context))))
    223           (when child
    224             (lookup-registers child context parent srv))
    225           (values child last-catch srv))))))
    226 
    227 ;;; Returns 2 values:
    228 ;;; mask srv
    229 ;;; The mask says which registers are used at PC in LFUN.  srv is a
    230 ;;; saved-register-vector whose register contents are the register
    231 ;;; values registers whose bits are not set in MASK or set in
    232 ;;; UNRESOLVED will be returned as NIL.
    233 
    234 (defun saved-register-values
    235        (lfun pc child last-catch srv &optional (srv-out (%cons-saved-register-vector)))
    236   (declare (ignore child))
    237   (cond ((null srv-out) (setq srv-out (copy-uvector srv)))
    238         ((eq srv-out srv))
    239         (t (dotimes (i (the fixnum (uvsize srv)))
    240              (setf (uvref srv-out i) (uvref srv i)))))
    241   (let ((mask (or (registers-used-by lfun pc) 0))
    242         (unresolved (srv.unresolved srv))
    243         (j *saved-register-count*))
    244     (declare (fixnum j))
    245     (dotimes (i j)
    246       (declare (fixnum i))
    247       (setf (srv.register-n srv-out i)
    248             (and (%ilogbitp (setq j (%i- j 1)) mask)
    249                  (not (%ilogbitp j unresolved))
    250                  (safe-cell-value (get-register-value (srv.register-n srv i) last-catch j)))))
    251     (setf (srv.unresolved srv-out) mask)
    252     (values mask srv-out)))
    253 
    254 ; Set the nth saved register to value.
    255 (defun set-saved-register (value n lfun pc child last-catch srv)
    256   (declare (ignore lfun pc child) (dynamic-extent saved-register-values))
    257   (let ((j (- target::node-size n))
    258         (unresolved (srv.unresolved srv))
    259         (addr (srv.register-n srv n)))
    260     (when (logbitp j unresolved)
    261       (error "Can't set register ~S to ~S" n value))
    262     (set-register-value value addr last-catch j))
    263   value)
    264 
    265 
    266 
    267 
    268 
    269 (defun return-from-nth-frame (n &rest values)
    270   (apply-in-nth-frame n #'values values))
    271 
    272 (defun apply-in-nth-frame (n fn arglist)
    273   (let* ((bt-info (car *backtrace-contexts*)))
    274     (and bt-info
    275          (let* ((frame (nth-frame nil (bt.youngest bt-info) n bt-info)))
    276            (and frame (apply-in-frame frame fn arglist)))))
    277   (format t "Can't return to frame ~d ." n))
    278 
    279 ;;; This method is shadowed by one for the backtrace window.
    280 (defmethod nth-frame (w target n context)
    281   (declare (ignore w))
    282   (and target (dotimes (i n target)
    283                 (declare (fixnum i))
    284                 (unless (setq target (parent-frame target context)) (return nil)))))
    285 
    286 ; If this returns at all, it's because the frame wasn't restartable.
    287 (defun apply-in-frame (frame fn arglist &optional context)
    288   (let* ((srv (frame-restartable-p frame context))
    289          (target-sp (and srv (srv.unresolved srv))))
    290     (if target-sp
    291       (apply-in-frame-internal context frame fn arglist srv))))
    292 
    293 (defun apply-in-frame-internal (context frame fn arglist srv)
    294   (let* ((tcr (if context (bt.tcr context) (%current-tcr))))
    295     (if (eq tcr (%current-tcr))
    296       (%apply-in-frame frame fn arglist srv)
    297       (let ((process (tcr->process tcr)))
    298         (if process
    299           (process-interrupt
    300            process
    301            #'%apply-in-frame
    302            frame fn arglist srv)
    303           (error "Can't find active process for ~s" tcr))))))
    304 
    305 
    306 
    307 
    308 ;;; (srv.unresolved srv) is the last catch frame, left there by
    309 ;;; frame-restartable-p The registers in srv are locations of
    310 ;;; variables saved between frame and that catch frame.
    311 (defun %apply-in-frame (frame fn arglist srv)
    312   (declare (fixnum frame))
    313   (let* ((catch (srv.unresolved srv))
    314          (tsp-count 0)
    315          (tcr (%current-tcr))
    316          (parent (parent-frame frame tcr))
    317          (vsp (frame-vsp parent))
    318          (catch-top (%catch-top tcr))
    319          (db-link (%svref catch target::catch-frame.db-link-cell))
    320          (catch-count 0))
    321     (declare (fixnum parent vsp db-link catch-count))
    322     ;; Figure out how many catch frames to throw through
    323     (loop
    324       (unless catch-top
    325         (error "Didn't find catch frame"))
    326       (incf catch-count)
    327       (when (eq catch-top catch)
    328         (return))
    329       (setq catch-top (next-catch catch-top)))
    330     ;; Figure out where the db-link should be
    331     (loop
    332       (when (or (eql db-link 0) (>= db-link vsp))
    333         (return))
    334       (setq db-link (%fixnum-ref db-link)))
    335     ;; Figure out how many TSP frames to pop after throwing.
    336     (let ((sp (catch-frame-sp catch)))
    337       (loop
    338         (multiple-value-bind (f pc) (cfp-lfun sp)
    339           (when f (incf tsp-count (active-tsp-count f pc))))
    340         (setq sp (parent-frame sp tcr))
    341         (when (eql sp parent) (return))
    342         (unless sp (error "Didn't find frame: ~s" frame))))
    343     #+debug
    344     (cerror "Continue" "(apply-in-frame ~s ~s ~s ~s ~s ~s ~s)"
    345             catch-count srv tsp-count db-link parent fn arglist)
    346     (%%apply-in-frame catch-count srv tsp-count db-link parent fn arglist)))
    347 
    348 
    349 
    350 
    351 ;;;;;;;;;;;;;;;;;;;;;;;
    352 ;;;
    353 ;;; Code to determine how many tsp frames to pop.
    354 ;;; This is done by parsing the code.
    355 ;;; active-tsp-count is the entry point below.
    356 ;;;
    357 
    358 #+ppc-target
    359 (progn
    360 
    361 (defstruct (branch-tree (:print-function print-branch-tree))
    362   first-instruction
    363   last-instruction
    364   branch-target     ; a branch-tree or nil
    365   fall-through)     ; a branch-tree or nil
    366 
    367 (defun print-branch-tree (tree stream print-level)
    368   (declare (ignore print-level))
    369   (print-unreadable-object (tree stream :type t :identity t)
    370     (format stream "~s-~s"
    371             (branch-tree-first-pc tree)
    372             (branch-tree-last-pc tree))))
    373 
    374 (defun branch-tree-first-pc (branch-tree)
    375   (let ((first (branch-tree-first-instruction branch-tree)))
    376     (and first (instruction-element-address first))))
    377 
    378 (defun branch-tree-last-pc (branch-tree)
    379   (let ((last (branch-tree-last-instruction branch-tree)))
    380     (if last
    381       (instruction-element-address last)
    382       (branch-tree-first-pc branch-tree))))
    383 
    384 (defun branch-tree-contains-pc-p (branch-tree pc)
    385   (<= (branch-tree-first-pc branch-tree)
    386       pc
    387       (branch-tree-last-pc branch-tree)))
    388 
    389 (defvar *branch-tree-hash*
    390   (make-hash-table :test 'eq :weak :value))
    391 
    392 (defun get-branch-tree (function)
    393   (or (gethash function *branch-tree-hash*)
    394       (let* ((dll (function-to-dll-header function))
    395              (tree (dll-to-branch-tree dll)))
    396         (setf (gethash function *branch-tree-hash*) tree))))         
    397 
    398 ; Return the number of TSP frames that will be active after throwing out
    399 ; of all the active catch frames in function at pc.
    400 ; PC is a byte address, a multiple of 4.
    401 (defun active-tsp-count (function pc)
    402   (setq function
    403         (require-type
    404          (if (symbolp function)
    405            (symbol-function function)
    406            function)
    407          'compiled-function))
    408   (let* ((tree (get-branch-tree function))
    409          (visited nil))
    410     (labels ((find-pc (branch path)
    411                (unless (memq branch visited)
    412                  (push branch path)
    413                  (if (branch-tree-contains-pc-p branch pc)
    414                    path
    415                    (let ((target (branch-tree-branch-target branch))
    416                          (fall-through (branch-tree-fall-through branch)))
    417                      (push branch visited)
    418                      (if fall-through
    419                        (or (and target (find-pc target path))
    420                            (find-pc fall-through path))
    421                        (and target (find-pc target path))))))))
    422       (let* ((path (nreverse (find-pc tree nil)))
    423              (last-tree (car (last path)))
    424              (catch-count 0)
    425              (tsp-count 0))
    426         (unless path
    427           (error "Can't find path to pc: ~s in ~s" pc function))
    428         (dolist (tree path)
    429           (let ((next (branch-tree-first-instruction tree))
    430                 (last (branch-tree-last-instruction tree)))
    431             (loop
    432               (when (and (eq tree last-tree)
    433                          (eql pc (instruction-element-address next)))
    434                 ; If the instruction before the current one is an ff-call,
    435                 ; then callback pushed a TSP frame.
    436                 #| ; Not any more
    437                 (when (ff-call-instruction-p (dll-node-pred next))
    438                   (incf tsp-count))
    439                 |#
    440                 (return))
    441               (multiple-value-bind (type target fall-through count) (categorize-instruction next)
    442                 (declare (ignore target fall-through))
    443                 (case type
    444                   (:tsp-push
    445                    (when (eql catch-count 0)
    446                      (incf tsp-count count)))
    447                   (:tsp-pop
    448                    (when (eql catch-count 0)
    449                      (decf tsp-count count)))
    450                   ((:catch :unwind-protect)
    451                    (incf catch-count))
    452                   (:throw
    453                    (decf catch-count count))))
    454               (when (eq next last)
    455                 (return))
    456               (setq next (dll-node-succ next)))))
    457         tsp-count))))
    458        
    459 
    460 (defun dll-to-branch-tree (dll)
    461   (let* ((hash (make-hash-table :test 'eql))    ; start-pc -> branch-tree
    462          (res (collect-branch-tree (dll-header-first dll) dll hash))
    463          (did-something nil))
    464     (loop
    465       (setq did-something nil)
    466       (let ((mapper #'(lambda (key value)
    467                         (declare (ignore key))
    468                         (flet ((maybe-collect (pc)
    469                                  (when (integerp pc)
    470                                    (let ((target-tree (gethash pc hash)))
    471                                      (if target-tree
    472                                        target-tree
    473                                        (progn
    474                                          (collect-branch-tree (dll-pc->instr dll pc) dll hash)
    475                                          (setq did-something t)
    476                                          nil))))))
    477                           (declare (dynamic-extent #'maybe-collect))
    478                           (let ((target-tree (maybe-collect (branch-tree-branch-target value))))
    479                             (when target-tree (setf (branch-tree-branch-target value) target-tree)))
    480                           (let ((target-tree (maybe-collect (branch-tree-fall-through value))))
    481                             (when target-tree (setf (branch-tree-fall-through value) target-tree)))))))
    482         (declare (dynamic-extent mapper))
    483         (maphash mapper hash))
    484       (unless did-something (return)))
    485     ; To be totally correct, we should fix up the trees containing
    486     ; the BLR instruction for unwind-protect cleanups, but none
    487     ; of the users of this code yet care that it appears that the code
    488     ; stops there.
    489     res))
    490 
    491 (defun collect-branch-tree (instr dll hash)
    492   (unless (eq instr dll)
    493     (let ((tree (make-branch-tree :first-instruction instr))
    494           (pred nil)
    495           (next instr))
    496       (setf (gethash (instruction-element-address instr) hash)
    497             tree)
    498       (loop
    499         (when (eq next dll)
    500           (setf (branch-tree-last-instruction tree) pred)
    501           (return))
    502         (multiple-value-bind (type target fall-through) (categorize-instruction next)
    503           (case type
    504             (:label
    505              (when pred
    506                (setf (branch-tree-last-instruction tree) pred
    507                      (branch-tree-fall-through tree) (instruction-element-address next))
    508                (return)))
    509             ((:branch :catch :unwind-protect)
    510              (setf (branch-tree-last-instruction tree) next
    511                    (branch-tree-branch-target tree) target
    512                    (branch-tree-fall-through tree) fall-through)
    513              (return))))
    514         (setq pred next
    515               next (dll-node-succ next)))
    516       tree)))
    517 
    518 ;;; Returns 4 values:
    519 ;;; 1) type: one of :regular, :label, :branch, :catch, :unwind-protect, :throw, :tsp-push, :tsp-pop
    520 ;;; 2) branch target (or catch or unwind-protect cleanup)
    521 ;;; 3) branch-fallthrough (or catch or unwind-protect body)
    522 ;;; 4) Count for throw, tsp-push, tsp-pop
    523 #+ppc-target
    524 (defun categorize-instruction (instr)
    525   (etypecase instr
    526     (lap-label :label)
    527     (lap-instruction
    528      (let* ((opcode (lap-instruction-opcode instr))
    529             (opcode-p (typep opcode 'opcode))
    530             (name (if opcode-p (opcode-name opcode) opcode))
    531             (pc (lap-instruction-address instr))
    532             (operands (lap-instruction-parsed-operands instr)))
    533        (cond ((equalp name "bla")
    534               (let ((subprim (car operands)))
    535                 (case subprim
    536                   (.SPmkunwind
    537                    (values :unwind-protect (+ pc 4) (+ pc 8)))
    538                   ((.SPmkcatch1v .SPmkcatchmv)
    539                    (values :catch (+ pc 4) (+ pc 8)))
    540                   (.SPthrow
    541                    (values :branch nil nil))
    542                   ((.SPnthrowvalues .SPnthrow1value)
    543                    (let* ((prev-instr (require-type (lap-instruction-pred instr)
    544                                                     'lap-instruction))
    545                           (prev-name (opcode-name (lap-instruction-opcode prev-instr)))
    546                           (prev-operands (lap-instruction-parsed-operands prev-instr)))
    547                      ; Maybe we should recognize the other possible outputs of ppc2-lwi, but I
    548                      ; can't imagine we'll ever see them
    549                      (unless (and (equalp prev-name "li")
    550                                   (equalp (car prev-operands) "imm0"))
    551                        (error "Can't determine throw count for ~s" instr))
    552                      (values :throw nil (+ pc 4) (ash (cadr prev-operands) (- target::fixnum-shift)))))
    553                   ((.SPprogvsave
    554                     .SPstack-rest-arg .SPreq-stack-rest-arg .SPstack-cons-rest-arg
    555                     .SPmakestackblock .SPmakestackblock0 .SPmakestacklist .SPstkgvector
    556                     .SPstkconslist .SPstkconslist-star
    557                     .SPmkstackv .SPstack-misc-alloc .SPstack-misc-alloc-init
    558                     .SPstkvcell0 .SPstkvcellvsp
    559                     .SPsave-values)
    560                    (values :tsp-push nil nil 1))
    561                   (.SPrecover-values
    562                    (values :tsp-pop nil nil 1))
    563                   (t :regular))))
    564              ((or (equalp name "lwz") (equalp name "addi"))
    565               (if (equalp (car operands) "tsp")
    566                 (values :tsp-pop nil nil 1)
    567                 :regular))
    568              ((equalp name "stwu")
    569               (if (equalp (car operands) "tsp")
    570                 (values :tsp-push nil nil 1)
    571                 :regular))
    572              ((member name '("ba" "blr" "bctr") :test 'equalp)
    573               (values :branch nil nil))
    574              ; It would probably be faster to determine the branch address by adding the PC and the offset.
    575              ((equalp name "b")
    576               (values :branch (branch-label-address instr (car (last operands))) nil))
    577              ((and opcode-p (eql (opcode-majorop opcode) 16))
    578               (values :branch (branch-label-address instr (car (last operands))) (+ pc 4)))
    579              (t :regular))))))
    580 
    581 (defun branch-label-address (instr label-name &aux (next instr))
    582   (loop
    583     (setq next (dll-node-succ next))
    584     (when (eq next instr)
    585       (error "Couldn't find label ~s" label-name))
    586     (when (and (typep next 'lap-label)
    587                (eq (lap-label-name next) label-name))
    588       (return (instruction-element-address next)))))
    589 
    590 (defun dll-pc->instr (dll pc)
    591   (let ((next (dll-node-succ dll)))
    592     (loop
    593       (when (eq next dll)
    594         (error "Couldn't find pc: ~s in ~s" pc dll))
    595       (when (eql (instruction-element-address next) pc)
    596         (return next))
    597       (setq next (dll-node-succ next)))))
    598 
    599 )  ; end of #+ppc-target progn
    600 ) ; end of another #+ppc-target progn
    60175#|
    60276(setq *save-local-symbols* t)
Note: See TracChangeset for help on using the changeset viewer.