Index: /branches/working-0711/ccl/lib/x86-backtrace.lisp
===================================================================
--- /branches/working-0711/ccl/lib/x86-backtrace.lisp	(revision 8025)
+++ /branches/working-0711/ccl/lib/x86-backtrace.lisp	(revision 8026)
@@ -204,4 +204,25 @@
   (ldb (byte #+32-bit-target 32 #+64-bit-target 64 0)  (ash p target::fixnumshift)))
 
+(defun exception-frame-p (x)
+  (and x (xcf-p x)))
+
+;;; Function has failed a number-of-arguments check; return a list
+;;; of the actual arguments.
+;;; On x86-64, the kernel has finished the frame and pushed everything
+;;; for us, so all that we need to do is to hide any inherited arguments.
+(defun arg-check-call-arguments (fp function)
+  (when (xcf-p fp)
+    (with-macptrs (xp)
+      (%setf-macptr-to-object xp (%fixnum-ref fp target::xcf.xp))
+      (let* ((numinh (ldb $lfbits-numinh (lfun-bits function)))
+             (nargs (- (xp-argument-count xp) numinh))
+             (p (- (%fixnum-ref fp target::xcf.backptr)
+                   (* target::node-size numinh))))
+        (declare (fixnum numing nargs p))
+        (collect ((args))
+          (dotimes (i nargs (args))
+            (args (%fixnum-ref p (- target::node-size)))
+            (decf p)))))))
+
 (defun vsp-limits (frame context)
   (let* ((parent (parent-frame frame context)))
@@ -224,4 +245,12 @@
               catch (next-catch catch))))))
 
+(defun last-xcf-since (target-fp start-fp context)
+  (do* ((last-xcf nil)
+        (fp start-fp (parent-frame fp context)))
+       ((or (eql fp target-fp)
+            (null fp)
+            (%stack< target-fp fp)) last-xcf)
+    (if (xcf-p fp) (setq last-xcf fp))))
+
 (defun match-local-name (cellno info pc)
   (when info
@@ -234,2 +263,119 @@
                (%i< pc (uvref ptrs (%i+ j 2)))
                (return (aref syms i))))))))
+
+(defun apply-in-frame (frame function arglist &optional context)
+  (let* ((parent (parent-frame frame context)))
+    (when parent
+      (if (xcf-p parent)
+        (error "Can't unwind to exception frame ~s" frame)
+        (setq frame parent))
+      (if (or (null context)
+              (eq (bt.tcr context) (%current-tcr)))
+        (%apply-in-frame frame function arglist)
+        (let* ((process (tcr->process (bt.tcr context))))
+          (if process
+            (process-interrupt process #'%apply-in-frame frame function arglist)
+            (error "Can't find process for backtrace context ~s" context)))))))
+
+(defun return-from-frame (frame context &rest values)
+  (apply-in-frame frame #'values values context))
+    
+;;; We can't determine this reliably (yet).
+(defun last-tsp-since (target source context)
+  (declare (ignore target source context))
+  nil)
+
+;;; We can't determine this reliably (yet).
+(defun last-foreign-sp-since (target source context)
+  (declare (ignore target source context))
+  nil)
+
+
+;;; This can lose (possibly badly) if the oldest binding younger
+;;; than the stack frame "frame" was established via PROGV.
+;;; We could make PROGV establish a "normal" binding (of
+;;; something like *CURRENT-PROGV* on the vstack; otherwise,
+;;; we'd need info about how the tstack is used at each point
+;;; on the vstack.
+(defun last-binding-since (frame start context)
+  (declare (fixnum frame start))
+  (do* ((db
+         (if context (bt.db-link context) (%current-db-link))
+         (%fixnum-ref db 0))
+        (last nil))
+       ((eql db 0) last)
+    (declare (fixnum db))
+    (if (and (< db frame)
+             (< start db))
+      (setq last db))))
+
+(defun find-x8664-saved-nvrs (frame start-fp context)
+  (let* ((locations (make-array 16 :initial-element nil))
+         (need (logior (ash 1 x8664::save0)
+                       (ash 1 x8664::save1)
+                       (ash 1 x8664::save2)
+                       (ash 1 x8664::save3))))
+    (declare (fixnum have need)
+             (dynamic-extent locations))
+    (do* ((parent frame child)
+          (child (child-frame parent context) (child-frame child context)))
+         ((or (= need 0) (eq child start-fp))
+          (values (%svref locations x8664::save0)
+                  (%svref locations x8664::save1)
+                  (%svref locations x8664::save2)
+                  (%svref locations x8664::save3)))
+      (multiple-value-bind (lfun pc) (cfp-lfun child)
+        (when (and lfun pc)
+          (multiple-value-bind (used where) (registers-used-by lfun pc)
+            (when (and used where (logtest used need))
+              (locally (declare (fixnum used))
+                (do* ((i x8664::save3 (1+ i)))
+                     ((or (= i 16) (= used 0)))
+                  (declare (type (mod 16) i))
+                  (when (logbitp i used)
+                    (when (logbitp i need)
+                      (setq need (logandc2 need (ash 1 i)))
+                      (setf (%svref locations i)
+                            (- (the fixnum (1- parent))
+                               (+ where (logcount (logandc2 used (1+ (ash 1 (1+ i)))))))))
+                    (setq used (logandc2 used (ash 1 i)))))))))))))
+                                         
+              
+         
+(defun %apply-in-frame (frame function arglist)
+  (let* ((target-catch (last-catch-since frame nil))
+         (start-fp (if target-catch
+                     (uvref target-catch target::catch-frame.rbp-cell)
+                     (%get-frame-ptr)))
+         (target-xcf (last-xcf-since frame start-fp nil))
+         (target-db-link (last-binding-since frame start-fp nil))
+         (target-tsp (last-tsp-since frame start-fp nil))
+         (target-foreign-sp (last-foreign-sp-since frame start-fp nil)))
+    (multiple-value-bind (save0-loc save1-loc save2-loc save3-loc)
+        (find-x8664-saved-nvrs frame start-fp nil)
+      (let* ((thunk (%clone-x86-function #'%%apply-in-frame-proto
+                                         frame
+                                         target-catch
+                                         target-db-link
+                                         target-xcf
+                                         target-tsp
+                                         target-foreign-sp
+                                         (if save0-loc
+                                           (- save0-loc frame)
+                                           0)
+                                         (if save1-loc
+                                           (- save1-loc frame)
+                                           0)
+                                         (if save2-loc
+                                           (- save2-loc frame)
+                                           0)
+                                         (if save3-loc
+                                           (- save3-loc frame)
+                                           0)
+                                         (coerce-to-function function)
+                                         arglist
+                                         0)))
+        (funcall thunk)))))
+
+            
+