Changeset 7206 for trunk/ccl/lib/x86-backtrace.lisp

Timestamp:

Sep 13, 2007, 1:49:59 AM (13 years ago)

Author:

gb

Message:

Replace START-MV-CALL with VPUSH-LABEL; set vinsn attributes on new vinsn.

File:

• trunk/ccl/lib/x86-backtrace.lisp (modified) (2 diffs)

trunk/ccl/lib/x86-backtrace.lisp

@@ -95 +95 @@
       bad)))
 
+(defun %raw-frame-set (frame context idx new)
+  (declare (fixnum frame idx))
+  (let* ((base (parent-frame frame context))
+         (raw-size (- base frame)))
+    (declare (fixnum base raw-size))
+    (if (and (>= idx 0)
+             (< idx raw-size))
+      (let* ((addr (- (the fixnum (1- base))
+                      idx)))
+        (multiple-value-bind (db-count first-db last-db)
+            (count-db-links-in-frame frame base context)
+          (let* ((is-db-link
+                  (unless (zerop db-count)
+                    (do* ((last last-db (previous-db-link last first-db)))
+                         ((null last))
+                      (when (= addr last)
+                        (return t))))))
+            (if is-db-link
+              (oldest-binding-frame-value context addr)
+              (setf (%fixnum-ref addr) new))))))))
+
 (defun %stack< (index1 index2 &optional context)
   (let* ((tcr (if context (bt.tcr context) (%current-tcr)))
@@ -153 +174 @@
     (get-register-value nil last-catch index)))
 
+(defun %set-register-argument-value (context cfp regval new)
+  (let* ((last-catch (last-catch-since cfp context))
+         (index (register-number->saved-register-index regval)))
+    (do* ((frame cfp (child-frame frame context))
+          (first t))
+         ((null frame))
+      (if (xcf-p frame)
+        (with-macptrs (xp)
+          (%setf-macptr-to-object xp (%fixnum-ref frame x8664::xcf.xp))
+          (return-from %set-register-argument-value
+            (setf (encoded-gpr-lisp xp regval) new)))
+        (progn
+          (unless first
+            (multiple-value-bind (lfun pc)
+                (cfp-lfun frame)
+              (when lfun
+                (multiple-value-bind (mask where)
+                    (registers-used-by lfun pc)
+                  (when (if mask (logbitp index mask))
+                    (incf where (logcount (logandc2 mask (1- (ash 1 (1+ index))))))
+
+                    (return-from %set-register-argument-value
+                      (raw-frame-set frame context where new)))))))
+          (setq first nil))))
+    (set-register-value new nil last-catch index)))
+
 ;;; Used for printing only.
 (defun index->address (p)