Changeset 8024


Ignore:
Timestamp:
Jan 8, 2008, 8:45:15 AM (12 years ago)
Author:
gb
Message:

Move #+ppc-target stuff from backtrace-lds.lisp here.

File:
1 edited

Legend:

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

    r7624 r8024  
    350350    (setf (uvref last-catch (+ index target::catch-frame.save-save7-cell))
    351351          value)))
     352
     353;;; I'm skeptical about a lot of this stuff on the PPC, but if anything it's
     354;;; pretty PPC-specific
     355
     356;;; Act as if VSTACK-INDEX points somewhere where DATA could go & put it there.
     357(defun set-lisp-data (vstack-index data)
     358  (let* ((old (%access-lisp-data vstack-index)))
     359    (if (closed-over-value-p old)
     360      (set-closed-over-value old data)
     361      (%store-lisp-data vstack-index data))))
     362
     363
     364;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     365;;
     366;;extensions to let user access and modify values
     367
     368
     369
     370
     371
     372;;; nth-frame-info, set-nth-frame-info, & frame-lfun are in "inspector;new-backtrace"
     373
     374
     375
     376
     377
     378
     379(defparameter *saved-register-count+1*
     380  (1+ *saved-register-count*))
     381
     382
     383
     384(defparameter *saved-register-numbers*
     385  #+x8664-target #(wrong)
     386  #+ppc-target #(31 30 29 28 27 26 25 24))
     387
     388;;; Don't do unbound checks in compiled code
     389(declaim (type t *saved-register-count* *saved-register-count+1*
     390               *saved-register-names* *saved-register-numbers*))
     391
     392(defmacro %cons-saved-register-vector ()
     393  `(make-array (the fixnum *saved-register-count+1*) :initial-element nil))
     394
     395(defun copy-srv (from-srv &optional to-srv)
     396  (if to-srv
     397    (if (eq from-srv to-srv)
     398      to-srv
     399      (dotimes (i (uvsize from-srv) to-srv)
     400        (setf (uvref to-srv i) (uvref from-srv i))))
     401    (copy-uvector from-srv)))
     402
     403(defmacro srv.unresolved (saved-register-vector)
     404  `(svref ,saved-register-vector 0))
     405
     406(defmacro srv.register-n (saved-register-vector n)
     407  `(svref ,saved-register-vector (1+ ,n)))
     408
     409;;; This isn't quite right - has to look at all functions on stack,
     410;;; not just those that saved VSPs.
     411
     412
     413(defun frame-restartable-p (target &optional context)
     414  (multiple-value-bind (frame last-catch srv) (last-catch-since-saved-vars target context)
     415    (when frame
     416      (loop
     417        (when (null frame)
     418          (return-from frame-restartable-p nil))
     419        (when (eq frame target) (return))
     420        (multiple-value-setq (frame last-catch srv)
     421          (ccl::parent-frame-saved-vars context frame last-catch srv srv)))
     422      (when (and srv (eql 0 (srv.unresolved srv)))
     423        (setf (srv.unresolved srv) last-catch)
     424        srv))))
     425
     426
     427;;; get the saved register addresses for this frame
     428;;; still need to worry about this unresolved business
     429;;; could share some code with parent-frame-saved-vars
     430(defun my-saved-vars (frame &optional (srv-out (%cons-saved-register-vector)))
     431  (let ((unresolved 0))
     432    (multiple-value-bind (lfun pc) (cfp-lfun frame)
     433        (if lfun
     434          (multiple-value-bind (mask where) (registers-used-by lfun pc)
     435            (when mask
     436              (if (not where)
     437                (setq unresolved (%ilogior unresolved mask))
     438                (let ((vsp (- (frame-vsp frame) where (1- (logcount mask))))
     439                      (j *saved-register-count*))
     440                  (declare (fixnum j))
     441                  (dotimes (i j)
     442                    (declare (fixnum i))
     443                    (when (%ilogbitp (decf j) mask)
     444                      (setf (srv.register-n srv-out i) vsp
     445                            vsp (1+ vsp)
     446                            unresolved (%ilogand unresolved (%ilognot (%ilsl j 1))))))))))
     447          (setq unresolved (1- (ash 1 *saved-register-count*)))))
     448    (setf (srv.unresolved srv-out) unresolved)
     449    srv-out))
     450
     451(defun parent-frame-saved-vars
     452       (context frame last-catch srv &optional (srv-out (%cons-saved-register-vector)))
     453  (copy-srv srv srv-out)
     454  (let* ((parent (and frame (parent-frame frame context)))
     455         (grand-parent (and parent (parent-frame parent context))))
     456    (when grand-parent
     457      (loop (let ((next-catch (and last-catch (next-catch last-catch))))
     458              ;(declare (ignore next-catch))
     459              (if (and next-catch (%stack< (catch-frame-sp next-catch) grand-parent context))
     460                (progn
     461                  (setf last-catch next-catch
     462                        (srv.unresolved srv-out) 0)
     463                  (dotimes (i *saved-register-count*)
     464                    (setf (srv.register-n srv i) nil)))
     465                (return))))
     466      (lookup-registers parent context grand-parent srv-out)
     467      (values parent last-catch srv-out))))
     468
     469(defun lookup-registers (parent context grand-parent srv-out)
     470  (unless (or (eql (frame-vsp grand-parent) 0)
     471              (let ((gg-parent (parent-frame grand-parent context)))
     472                (eql (frame-vsp gg-parent) 0)))
     473    (multiple-value-bind (lfun pc) (cfp-lfun parent)
     474      (when lfun
     475        (multiple-value-bind (mask where) (registers-used-by lfun pc)
     476          (when mask
     477            (locally (declare (fixnum mask))
     478              (if (not where)
     479                (setf (srv.unresolved srv-out) (%ilogior (srv.unresolved srv-out) mask))
     480                (let* ((grand-parent-vsp (frame-vsp grand-parent)))
     481
     482                  (let ((vsp (- grand-parent-vsp where 1))
     483                        (j *saved-register-count*))
     484                    (declare (fixnum j))
     485                    (dotimes (i j)
     486                      (declare (fixnum i))
     487                      (when (%ilogbitp (decf j) mask)
     488                        (setf (srv.register-n srv-out i) vsp
     489                              vsp (1- vsp)
     490                              (srv.unresolved srv-out)
     491                              (%ilogand (srv.unresolved srv-out) (%ilognot (%ilsl j 1))))))))))))))))
     492
     493;;; initialization for looping on parent-frame-saved-vars
     494(defun last-catch-since-saved-vars (frame context)
     495  (let* ((parent (parent-frame frame context))
     496         (last-catch (and parent (last-catch-since parent context))))
     497    (when last-catch
     498      (let ((frame (catch-frame-sp last-catch))
     499            (srv (%cons-saved-register-vector)))
     500        (setf (srv.unresolved srv) 0)
     501        (let* ((parent (parent-frame frame context))
     502               (child (and parent (child-frame parent context))))
     503          (when child
     504            (lookup-registers child context parent srv))
     505          (values child last-catch srv))))))
     506
     507;;; Returns 2 values:
     508;;; mask srv
     509;;; The mask says which registers are used at PC in LFUN.  srv is a
     510;;; saved-register-vector whose register contents are the register
     511;;; values registers whose bits are not set in MASK or set in
     512;;; UNRESOLVED will be returned as NIL.
     513
     514(defun saved-register-values
     515       (lfun pc child last-catch srv &optional (srv-out (%cons-saved-register-vector)))
     516  (declare (ignore child))
     517  (cond ((null srv-out) (setq srv-out (copy-uvector srv)))
     518        ((eq srv-out srv))
     519        (t (dotimes (i (the fixnum (uvsize srv)))
     520             (setf (uvref srv-out i) (uvref srv i)))))
     521  (let ((mask (or (registers-used-by lfun pc) 0))
     522        (unresolved (srv.unresolved srv))
     523        (j *saved-register-count*))
     524    (declare (fixnum j))
     525    (dotimes (i j)
     526      (declare (fixnum i))
     527      (setf (srv.register-n srv-out i)
     528            (and (%ilogbitp (setq j (%i- j 1)) mask)
     529                 (not (%ilogbitp j unresolved))
     530                 (safe-cell-value (get-register-value (srv.register-n srv i) last-catch j)))))
     531    (setf (srv.unresolved srv-out) mask)
     532    (values mask srv-out)))
     533
     534; Set the nth saved register to value.
     535(defun set-saved-register (value n lfun pc child last-catch srv)
     536  (declare (ignore lfun pc child) (dynamic-extent saved-register-values))
     537  (let ((j (- target::node-size n))
     538        (unresolved (srv.unresolved srv))
     539        (addr (srv.register-n srv n)))
     540    (when (logbitp j unresolved)
     541      (error "Can't set register ~S to ~S" n value))
     542    (set-register-value value addr last-catch j))
     543  value)
     544
     545
     546
     547
     548
     549(defun return-from-nth-frame (n &rest values)
     550  (apply-in-nth-frame n #'values values))
     551
     552(defun apply-in-nth-frame (n fn arglist)
     553  (let* ((bt-info (car *backtrace-contexts*)))
     554    (and bt-info
     555         (let* ((frame (nth-frame nil (bt.youngest bt-info) n bt-info)))
     556           (and frame (apply-in-frame frame fn arglist)))))
     557  (format t "Can't return to frame ~d ." n))
     558
     559;;; This method is shadowed by one for the backtrace window.
     560(defmethod nth-frame (w target n context)
     561  (declare (ignore w))
     562  (and target (dotimes (i n target)
     563                (declare (fixnum i))
     564                (unless (setq target (parent-frame target context)) (return nil)))))
     565
     566; If this returns at all, it's because the frame wasn't restartable.
     567(defun apply-in-frame (frame fn arglist &optional context)
     568  (let* ((srv (frame-restartable-p frame context))
     569         (target-sp (and srv (srv.unresolved srv))))
     570    (if target-sp
     571      (apply-in-frame-internal context frame fn arglist srv))))
     572
     573(defun apply-in-frame-internal (context frame fn arglist srv)
     574  (let* ((tcr (if context (bt.tcr context) (%current-tcr))))
     575    (if (eq tcr (%current-tcr))
     576      (%apply-in-frame frame fn arglist srv)
     577      (let ((process (tcr->process tcr)))
     578        (if process
     579          (process-interrupt
     580           process
     581           #'%apply-in-frame
     582           frame fn arglist srv)
     583          (error "Can't find active process for ~s" tcr))))))
     584
     585
     586
     587
     588;;; (srv.unresolved srv) is the last catch frame, left there by
     589;;; frame-restartable-p The registers in srv are locations of
     590;;; variables saved between frame and that catch frame.
     591(defun %apply-in-frame (frame fn arglist srv)
     592  (declare (fixnum frame))
     593  (let* ((catch (srv.unresolved srv))
     594         (tsp-count 0)
     595         (tcr (%current-tcr))
     596         (parent (parent-frame frame tcr))
     597         (vsp (frame-vsp parent))
     598         (catch-top (%catch-top tcr))
     599         (db-link (%svref catch target::catch-frame.db-link-cell))
     600         (catch-count 0))
     601    (declare (fixnum parent vsp db-link catch-count))
     602    ;; Figure out how many catch frames to throw through
     603    (loop
     604      (unless catch-top
     605        (error "Didn't find catch frame"))
     606      (incf catch-count)
     607      (when (eq catch-top catch)
     608        (return))
     609      (setq catch-top (next-catch catch-top)))
     610    ;; Figure out where the db-link should be
     611    (loop
     612      (when (or (eql db-link 0) (>= db-link vsp))
     613        (return))
     614      (setq db-link (%fixnum-ref db-link)))
     615    ;; Figure out how many TSP frames to pop after throwing.
     616    (let ((sp (catch-frame-sp catch)))
     617      (loop
     618        (multiple-value-bind (f pc) (cfp-lfun sp)
     619          (when f (incf tsp-count (active-tsp-count f pc))))
     620        (setq sp (parent-frame sp tcr))
     621        (when (eql sp parent) (return))
     622        (unless sp (error "Didn't find frame: ~s" frame))))
     623    #+debug
     624    (cerror "Continue" "(apply-in-frame ~s ~s ~s ~s ~s ~s ~s)"
     625            catch-count srv tsp-count db-link parent fn arglist)
     626    (%%apply-in-frame catch-count srv tsp-count db-link parent fn arglist)))
     627
     628
     629
     630
     631;;;;;;;;;;;;;;;;;;;;;;;
     632;;;
     633;;; Code to determine how many tsp frames to pop.
     634;;; This is done by parsing the code.
     635;;; active-tsp-count is the entry point below.
     636;;;
     637
     638(defstruct (branch-tree (:print-function print-branch-tree))
     639  first-instruction
     640  last-instruction
     641  branch-target     ; a branch-tree or nil
     642  fall-through)     ; a branch-tree or nil
     643
     644(defun print-branch-tree (tree stream print-level)
     645  (declare (ignore print-level))
     646  (print-unreadable-object (tree stream :type t :identity t)
     647    (format stream "~s-~s"
     648            (branch-tree-first-pc tree)
     649            (branch-tree-last-pc tree))))
     650
     651(defun branch-tree-first-pc (branch-tree)
     652  (let ((first (branch-tree-first-instruction branch-tree)))
     653    (and first (instruction-element-address first))))
     654
     655(defun branch-tree-last-pc (branch-tree)
     656  (let ((last (branch-tree-last-instruction branch-tree)))
     657    (if last
     658      (instruction-element-address last)
     659      (branch-tree-first-pc branch-tree))))
     660
     661(defun branch-tree-contains-pc-p (branch-tree pc)
     662  (<= (branch-tree-first-pc branch-tree)
     663      pc
     664      (branch-tree-last-pc branch-tree)))
     665
     666(defvar *branch-tree-hash*
     667  (make-hash-table :test 'eq :weak :value))
     668
     669(defun get-branch-tree (function)
     670  (or (gethash function *branch-tree-hash*)
     671      (let* ((dll (function-to-dll-header function))
     672             (tree (dll-to-branch-tree dll)))
     673        (setf (gethash function *branch-tree-hash*) tree))))         
     674
     675; Return the number of TSP frames that will be active after throwing out
     676; of all the active catch frames in function at pc.
     677; PC is a byte address, a multiple of 4.
     678(defun active-tsp-count (function pc)
     679  (setq function
     680        (require-type
     681         (if (symbolp function)
     682           (symbol-function function)
     683           function)
     684         'compiled-function))
     685  (let* ((tree (get-branch-tree function))
     686         (visited nil))
     687    (labels ((find-pc (branch path)
     688               (unless (memq branch visited)
     689                 (push branch path)
     690                 (if (branch-tree-contains-pc-p branch pc)
     691                   path
     692                   (let ((target (branch-tree-branch-target branch))
     693                         (fall-through (branch-tree-fall-through branch)))
     694                     (push branch visited)
     695                     (if fall-through
     696                       (or (and target (find-pc target path))
     697                           (find-pc fall-through path))
     698                       (and target (find-pc target path))))))))
     699      (let* ((path (nreverse (find-pc tree nil)))
     700             (last-tree (car (last path)))
     701             (catch-count 0)
     702             (tsp-count 0))
     703        (unless path
     704          (error "Can't find path to pc: ~s in ~s" pc function))
     705        (dolist (tree path)
     706          (let ((next (branch-tree-first-instruction tree))
     707                (last (branch-tree-last-instruction tree)))
     708            (loop
     709              (when (and (eq tree last-tree)
     710                         (eql pc (instruction-element-address next)))
     711                ; If the instruction before the current one is an ff-call,
     712                ; then callback pushed a TSP frame.
     713                #| ; Not any more
     714                (when (ff-call-instruction-p (dll-node-pred next))
     715                  (incf tsp-count))
     716                |#
     717                (return))
     718              (multiple-value-bind (type target fall-through count) (categorize-instruction next)
     719                (declare (ignore target fall-through))
     720                (case type
     721                  (:tsp-push
     722                   (when (eql catch-count 0)
     723                     (incf tsp-count count)))
     724                  (:tsp-pop
     725                   (when (eql catch-count 0)
     726                     (decf tsp-count count)))
     727                  ((:catch :unwind-protect)
     728                   (incf catch-count))
     729                  (:throw
     730                   (decf catch-count count))))
     731              (when (eq next last)
     732                (return))
     733              (setq next (dll-node-succ next)))))
     734        tsp-count))))
     735       
     736
     737(defun dll-to-branch-tree (dll)
     738  (let* ((hash (make-hash-table :test 'eql))    ; start-pc -> branch-tree
     739         (res (collect-branch-tree (dll-header-first dll) dll hash))
     740         (did-something nil))
     741    (loop
     742      (setq did-something nil)
     743      (let ((mapper #'(lambda (key value)
     744                        (declare (ignore key))
     745                        (flet ((maybe-collect (pc)
     746                                 (when (integerp pc)
     747                                   (let ((target-tree (gethash pc hash)))
     748                                     (if target-tree
     749                                       target-tree
     750                                       (progn
     751                                         (collect-branch-tree (dll-pc->instr dll pc) dll hash)
     752                                         (setq did-something t)
     753                                         nil))))))
     754                          (declare (dynamic-extent #'maybe-collect))
     755                          (let ((target-tree (maybe-collect (branch-tree-branch-target value))))
     756                            (when target-tree (setf (branch-tree-branch-target value) target-tree)))
     757                          (let ((target-tree (maybe-collect (branch-tree-fall-through value))))
     758                            (when target-tree (setf (branch-tree-fall-through value) target-tree)))))))
     759        (declare (dynamic-extent mapper))
     760        (maphash mapper hash))
     761      (unless did-something (return)))
     762    ; To be totally correct, we should fix up the trees containing
     763    ; the BLR instruction for unwind-protect cleanups, but none
     764    ; of the users of this code yet care that it appears that the code
     765    ; stops there.
     766    res))
     767
     768(defun collect-branch-tree (instr dll hash)
     769  (unless (eq instr dll)
     770    (let ((tree (make-branch-tree :first-instruction instr))
     771          (pred nil)
     772          (next instr))
     773      (setf (gethash (instruction-element-address instr) hash)
     774            tree)
     775      (loop
     776        (when (eq next dll)
     777          (setf (branch-tree-last-instruction tree) pred)
     778          (return))
     779        (multiple-value-bind (type target fall-through) (categorize-instruction next)
     780          (case type
     781            (:label
     782             (when pred
     783               (setf (branch-tree-last-instruction tree) pred
     784                     (branch-tree-fall-through tree) (instruction-element-address next))
     785               (return)))
     786            ((:branch :catch :unwind-protect)
     787             (setf (branch-tree-last-instruction tree) next
     788                   (branch-tree-branch-target tree) target
     789                   (branch-tree-fall-through tree) fall-through)
     790             (return))))
     791        (setq pred next
     792              next (dll-node-succ next)))
     793      tree)))
     794
     795;;; Returns 4 values:
     796;;; 1) type: one of :regular, :label, :branch, :catch, :unwind-protect, :throw, :tsp-push, :tsp-pop
     797;;; 2) branch target (or catch or unwind-protect cleanup)
     798;;; 3) branch-fallthrough (or catch or unwind-protect body)
     799;;; 4) Count for throw, tsp-push, tsp-pop
     800(defun categorize-instruction (instr)
     801  (etypecase instr
     802    (lap-label :label)
     803    (lap-instruction
     804     (let* ((opcode (lap-instruction-opcode instr))
     805            (opcode-p (typep opcode 'opcode))
     806            (name (if opcode-p (opcode-name opcode) opcode))
     807            (pc (lap-instruction-address instr))
     808            (operands (lap-instruction-parsed-operands instr)))
     809       (cond ((equalp name "bla")
     810              (let ((subprim (car operands)))
     811                (case subprim
     812                  (.SPmkunwind
     813                   (values :unwind-protect (+ pc 4) (+ pc 8)))
     814                  ((.SPmkcatch1v .SPmkcatchmv)
     815                   (values :catch (+ pc 4) (+ pc 8)))
     816                  (.SPthrow
     817                   (values :branch nil nil))
     818                  ((.SPnthrowvalues .SPnthrow1value)
     819                   (let* ((prev-instr (require-type (lap-instruction-pred instr)
     820                                                    'lap-instruction))
     821                          (prev-name (opcode-name (lap-instruction-opcode prev-instr)))
     822                          (prev-operands (lap-instruction-parsed-operands prev-instr)))
     823                     ; Maybe we should recognize the other possible outputs of ppc2-lwi, but I
     824                     ; can't imagine we'll ever see them
     825                     (unless (and (equalp prev-name "li")
     826                                  (equalp (car prev-operands) "imm0"))
     827                       (error "Can't determine throw count for ~s" instr))
     828                     (values :throw nil (+ pc 4) (ash (cadr prev-operands) (- target::fixnum-shift)))))
     829                  ((.SPprogvsave
     830                    .SPstack-rest-arg .SPreq-stack-rest-arg .SPstack-cons-rest-arg
     831                    .SPmakestackblock .SPmakestackblock0 .SPmakestacklist .SPstkgvector
     832                    .SPstkconslist .SPstkconslist-star
     833                    .SPmkstackv .SPstack-misc-alloc .SPstack-misc-alloc-init
     834                    .SPstkvcell0 .SPstkvcellvsp
     835                    .SPsave-values)
     836                   (values :tsp-push nil nil 1))
     837                  (.SPrecover-values
     838                   (values :tsp-pop nil nil 1))
     839                  (t :regular))))
     840             ((or (equalp name "lwz") (equalp name "addi"))
     841              (if (equalp (car operands) "tsp")
     842                (values :tsp-pop nil nil 1)
     843                :regular))
     844             ((equalp name "stwu")
     845              (if (equalp (car operands) "tsp")
     846                (values :tsp-push nil nil 1)
     847                :regular))
     848             ((member name '("ba" "blr" "bctr") :test 'equalp)
     849              (values :branch nil nil))
     850             ; It would probably be faster to determine the branch address by adding the PC and the offset.
     851             ((equalp name "b")
     852              (values :branch (branch-label-address instr (car (last operands))) nil))
     853             ((and opcode-p (eql (opcode-majorop opcode) 16))
     854              (values :branch (branch-label-address instr (car (last operands))) (+ pc 4)))
     855             (t :regular))))))
     856
     857(defun branch-label-address (instr label-name &aux (next instr))
     858  (loop
     859    (setq next (dll-node-succ next))
     860    (when (eq next instr)
     861      (error "Couldn't find label ~s" label-name))
     862    (when (and (typep next 'lap-label)
     863               (eq (lap-label-name next) label-name))
     864      (return (instruction-element-address next)))))
     865
     866(defun dll-pc->instr (dll pc)
     867  (let ((next (dll-node-succ dll)))
     868    (loop
     869      (when (eq next dll)
     870        (error "Couldn't find pc: ~s in ~s" pc dll))
     871      (when (eql (instruction-element-address next) pc)
     872        (return next))
     873      (setq next (dll-node-succ next)))))
     874
Note: See TracChangeset for help on using the changeset viewer.