Changeset 8026


Ignore:
Timestamp:
Jan 8, 2008, 8:48:24 AM (13 years ago)
Author:
gb
Message:

Apply-in-frame support for x86-64.

File:
1 edited

Legend:

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

    r7624 r8026  
    204204  (ldb (byte #+32-bit-target 32 #+64-bit-target 64 0)  (ash p target::fixnumshift)))
    205205
     206(defun exception-frame-p (x)
     207  (and x (xcf-p x)))
     208
     209;;; Function has failed a number-of-arguments check; return a list
     210;;; of the actual arguments.
     211;;; On x86-64, the kernel has finished the frame and pushed everything
     212;;; for us, so all that we need to do is to hide any inherited arguments.
     213(defun arg-check-call-arguments (fp function)
     214  (when (xcf-p fp)
     215    (with-macptrs (xp)
     216      (%setf-macptr-to-object xp (%fixnum-ref fp target::xcf.xp))
     217      (let* ((numinh (ldb $lfbits-numinh (lfun-bits function)))
     218             (nargs (- (xp-argument-count xp) numinh))
     219             (p (- (%fixnum-ref fp target::xcf.backptr)
     220                   (* target::node-size numinh))))
     221        (declare (fixnum numing nargs p))
     222        (collect ((args))
     223          (dotimes (i nargs (args))
     224            (args (%fixnum-ref p (- target::node-size)))
     225            (decf p)))))))
     226
    206227(defun vsp-limits (frame context)
    207228  (let* ((parent (parent-frame frame context)))
     
    224245              catch (next-catch catch))))))
    225246
     247(defun last-xcf-since (target-fp start-fp context)
     248  (do* ((last-xcf nil)
     249        (fp start-fp (parent-frame fp context)))
     250       ((or (eql fp target-fp)
     251            (null fp)
     252            (%stack< target-fp fp)) last-xcf)
     253    (if (xcf-p fp) (setq last-xcf fp))))
     254
    226255(defun match-local-name (cellno info pc)
    227256  (when info
     
    234263               (%i< pc (uvref ptrs (%i+ j 2)))
    235264               (return (aref syms i))))))))
     265
     266(defun apply-in-frame (frame function arglist &optional context)
     267  (let* ((parent (parent-frame frame context)))
     268    (when parent
     269      (if (xcf-p parent)
     270        (error "Can't unwind to exception frame ~s" frame)
     271        (setq frame parent))
     272      (if (or (null context)
     273              (eq (bt.tcr context) (%current-tcr)))
     274        (%apply-in-frame frame function arglist)
     275        (let* ((process (tcr->process (bt.tcr context))))
     276          (if process
     277            (process-interrupt process #'%apply-in-frame frame function arglist)
     278            (error "Can't find process for backtrace context ~s" context)))))))
     279
     280(defun return-from-frame (frame context &rest values)
     281  (apply-in-frame frame #'values values context))
     282   
     283;;; We can't determine this reliably (yet).
     284(defun last-tsp-since (target source context)
     285  (declare (ignore target source context))
     286  nil)
     287
     288;;; We can't determine this reliably (yet).
     289(defun last-foreign-sp-since (target source context)
     290  (declare (ignore target source context))
     291  nil)
     292
     293
     294;;; This can lose (possibly badly) if the oldest binding younger
     295;;; than the stack frame "frame" was established via PROGV.
     296;;; We could make PROGV establish a "normal" binding (of
     297;;; something like *CURRENT-PROGV* on the vstack; otherwise,
     298;;; we'd need info about how the tstack is used at each point
     299;;; on the vstack.
     300(defun last-binding-since (frame start context)
     301  (declare (fixnum frame start))
     302  (do* ((db
     303         (if context (bt.db-link context) (%current-db-link))
     304         (%fixnum-ref db 0))
     305        (last nil))
     306       ((eql db 0) last)
     307    (declare (fixnum db))
     308    (if (and (< db frame)
     309             (< start db))
     310      (setq last db))))
     311
     312(defun find-x8664-saved-nvrs (frame start-fp context)
     313  (let* ((locations (make-array 16 :initial-element nil))
     314         (need (logior (ash 1 x8664::save0)
     315                       (ash 1 x8664::save1)
     316                       (ash 1 x8664::save2)
     317                       (ash 1 x8664::save3))))
     318    (declare (fixnum have need)
     319             (dynamic-extent locations))
     320    (do* ((parent frame child)
     321          (child (child-frame parent context) (child-frame child context)))
     322         ((or (= need 0) (eq child start-fp))
     323          (values (%svref locations x8664::save0)
     324                  (%svref locations x8664::save1)
     325                  (%svref locations x8664::save2)
     326                  (%svref locations x8664::save3)))
     327      (multiple-value-bind (lfun pc) (cfp-lfun child)
     328        (when (and lfun pc)
     329          (multiple-value-bind (used where) (registers-used-by lfun pc)
     330            (when (and used where (logtest used need))
     331              (locally (declare (fixnum used))
     332                (do* ((i x8664::save3 (1+ i)))
     333                     ((or (= i 16) (= used 0)))
     334                  (declare (type (mod 16) i))
     335                  (when (logbitp i used)
     336                    (when (logbitp i need)
     337                      (setq need (logandc2 need (ash 1 i)))
     338                      (setf (%svref locations i)
     339                            (- (the fixnum (1- parent))
     340                               (+ where (logcount (logandc2 used (1+ (ash 1 (1+ i)))))))))
     341                    (setq used (logandc2 used (ash 1 i)))))))))))))
     342                                         
     343             
     344         
     345(defun %apply-in-frame (frame function arglist)
     346  (let* ((target-catch (last-catch-since frame nil))
     347         (start-fp (if target-catch
     348                     (uvref target-catch target::catch-frame.rbp-cell)
     349                     (%get-frame-ptr)))
     350         (target-xcf (last-xcf-since frame start-fp nil))
     351         (target-db-link (last-binding-since frame start-fp nil))
     352         (target-tsp (last-tsp-since frame start-fp nil))
     353         (target-foreign-sp (last-foreign-sp-since frame start-fp nil)))
     354    (multiple-value-bind (save0-loc save1-loc save2-loc save3-loc)
     355        (find-x8664-saved-nvrs frame start-fp nil)
     356      (let* ((thunk (%clone-x86-function #'%%apply-in-frame-proto
     357                                         frame
     358                                         target-catch
     359                                         target-db-link
     360                                         target-xcf
     361                                         target-tsp
     362                                         target-foreign-sp
     363                                         (if save0-loc
     364                                           (- save0-loc frame)
     365                                           0)
     366                                         (if save1-loc
     367                                           (- save1-loc frame)
     368                                           0)
     369                                         (if save2-loc
     370                                           (- save2-loc frame)
     371                                           0)
     372                                         (if save3-loc
     373                                           (- save3-loc frame)
     374                                           0)
     375                                         (coerce-to-function function)
     376                                         arglist
     377                                         0)))
     378        (funcall thunk)))))
     379
     380           
     381   
Note: See TracChangeset for help on using the changeset viewer.