Menu
▾
▴
[Sbcl-commits] CVS: sbcl/src/code debug.lisp, 1.89, 1.90 early-fasl.lisp, 1.73, 1.74
|
From: Juho S. <js...@us...> - 2007-06-05 11:42:59
|
Update of /cvsroot/sbcl/sbcl/src/code In directory sc8-pr-cvs8.sourceforge.net:/tmp/cvs-serv28203/src/code Modified Files: debug.lisp early-fasl.lisp Log Message: 1.0.6.24: a more sophisticated UNWIND-TO-FRAME-AND-CALL for x86 and x86-64 * Implement three new VOPs: ** UNWIND-TO-FRAME-AND-CALL constructs a fake catch block for a given frame pointer, runs all unwinds for that block, sets the frame pointer to the new value, and calls a given function. ** BIND-SENTINEL (stores a marker on the binding stack, used to determine how far the binding stack needs to be unwound during a U-T-F-A-C). ** UNBIND-SENTINEL (pops one of these markers from the stack). * Modify IR2 to use these VOPs when converting suitable functions. * Modify the IR1 translation in maybe-insert-debug-catch to only ensure that tail recursion doesn't happen (needed to match the BIND-SENTINELs with UNBIND-SENTINELs). * Use these to implement SB-DEBUG:UNWIND-TO-FRAME-AND-CALL: ** Grovel the binding stack, uwp block chain and the catch block chain for the values needed to reconstruct the dynamic state. ** Call SB-VM:U-T-F-A-C. * The new implementation should be substantially the same as the old one (minor difference in handling of functions with special variables in the lambda list). Some tests added to verify this. * New implementation is somewhat faster at runtime (a simple function call overhead benchmark on (DEBUG 2) improved from 3.4s to 2.9s), and significantly faster at compiling (generally around 15-30% improvement with (DEBUG 2)). * Other platforms still use the old implementation that instruments the code with a CATCH during IR1 translation. * Based on an earlier hack by Alastair Bridgewater. Index: debug.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/code/debug.lisp,v retrieving revision 1.89 retrieving revision 1.90 diff -u -d -r1.89 -r1.90 --- debug.lisp 9 Jan 2007 03:25:06 -0000 1.89 +++ debug.lisp 5 Jun 2007 11:42:54 -0000 1.90 @@ -1380,12 +1380,104 @@ (loop while (read-char-no-hang *standard-input*))) (defun unwind-to-frame-and-call (frame thunk) + #!+unwind-to-frame-and-call-vop + (flet ((sap-int/fixnum (sap) + ;; On unithreaded X86 *BINDING-STACK-POINTER* and + ;; *CURRENT-CATCH-BLOCK* are negative, so we need to jump through + ;; some hoops to make these calculated values negative too. + (ash (truly-the (signed-byte #.sb!vm:n-word-bits) + (sap-int sap)) + (- sb!vm::n-fixnum-tag-bits)))) + ;; To properly unwind the stack, we need three pieces of information: + ;; * The unwind block that should be active after the unwind + ;; * The catch block that should be active after the unwind + ;; * The values that the binding stack pointer should have after the + ;; unwind. + (let* ((block (sap-int/fixnum (find-enclosing-catch-block frame))) + (unbind-to (sap-int/fixnum (find-binding-stack-pointer frame)))) + ;; This VOP will run the neccessary cleanup forms, reset the fp, and + ;; then call the supplied function. + (sb!vm::%primitive sb!vm::unwind-to-frame-and-call + (sb!di::frame-pointer frame) + (find-enclosing-uwp frame) + (lambda () + ;; Before calling the user-specified + ;; function, we need to restore the binding + ;; stack and the catch block. The unwind block + ;; is taken care of by the VOP. + (sb!vm::%primitive sb!vm::unbind-to-here + unbind-to) + (setf sb!vm::*current-catch-block* block) + (funcall thunk))))) + #!-unwind-to-frame-and-call-vop (let ((tag (gensym))) (sb!di:replace-frame-catch-tag frame 'sb!c:debug-catch-tag tag) (throw tag thunk))) +(defun find-binding-stack-pointer (frame) + #!-stack-grows-downward-not-upward + (error "Not implemented on this architecture") + #!+stack-grows-downward-not-upward + (let ((bsp (sb!vm::binding-stack-pointer-sap)) + (unbind-to nil) + (fp (sb!di::frame-pointer frame)) + (start (int-sap (ldb (byte #.sb!vm:n-word-bits 0) + (ash sb!vm:*binding-stack-start* + sb!vm:n-fixnum-tag-bits))))) + ;; Walk the binding stack looking for an entry where the symbol is + ;; an unbound-symbol marker and the value is equal to the frame + ;; pointer. These entries are inserted into the stack by the + ;; BIND-SENTINEL VOP and removed by UNBIND-SENTINEL (inserted into + ;; the function during IR2). If an entry wasn't found, the + ;; function that the frame corresponds to wasn't compiled with a + ;; high enough debug setting, and can't be restarted / returned + ;; from. + (loop until (sap= bsp start) + do (progn + (setf bsp (sap+ bsp + (- (* sb!vm:binding-size sb!vm:n-word-bytes)))) + (let ((symbol (sap-ref-word bsp (* sb!vm:binding-symbol-slot + sb!vm:n-word-bytes))) + (value (sap-ref-sap bsp (* sb!vm:binding-value-slot + sb!vm:n-word-bytes)))) + (when (eql symbol sb!vm:unbound-marker-widetag) + (when (sap= value fp) + (setf unbind-to bsp)))))) + unbind-to)) + +(defun find-enclosing-catch-block (frame) + ;; Walk the catch block chain looking for the first entry with an address + ;; higher than the pointer for FRAME or a null pointer. + (let* ((frame-pointer (sb!di::frame-pointer frame)) + (current-block (int-sap (ldb (byte #.sb!vm:n-word-bits 0) + (ash sb!vm::*current-catch-block* + sb!vm:n-fixnum-tag-bits)))) + (enclosing-block (loop for block = current-block + then (sap-ref-sap block + (* sb!vm:catch-block-previous-catch-slot + sb!vm::n-word-bytes)) + when (or (zerop (sap-int block)) + (sap> block frame-pointer)) + return block))) + enclosing-block)) + +(defun find-enclosing-uwp (frame) + ;; Walk the UWP chain looking for the first entry with an address + ;; higher than the pointer for FRAME or a null pointer. + (let* ((frame-pointer (sb!di::frame-pointer frame)) + (current-uwp (int-sap (ldb (byte #.sb!vm:n-word-bits 0) + (ash sb!vm::*current-unwind-protect-block* + sb!vm:n-fixnum-tag-bits)))) + (enclosing-uwp (loop for uwp-block = current-uwp + then (sap-ref-sap uwp-block + sb!vm:unwind-block-current-uwp-slot) + when (or (zerop (sap-int uwp-block)) + (sap> uwp-block frame-pointer)) + return uwp-block))) + enclosing-uwp)) + (!def-debug-command "RETURN" (&optional (return (read-prompting-maybe "return: "))) @@ -1414,6 +1506,9 @@ and recompiling)~:@>"))) (defun frame-has-debug-tag-p (frame) + #!+unwind-to-frame-and-call-vop + (not (null (find-binding-stack-pointer frame))) + #!-unwind-to-frame-and-call-vop (find 'sb!c:debug-catch-tag (sb!di::frame-catches frame) :key #'car)) Index: early-fasl.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/code/early-fasl.lisp,v retrieving revision 1.73 retrieving revision 1.74 diff -u -d -r1.73 -r1.74 --- early-fasl.lisp 13 Apr 2007 22:37:37 -0000 1.73 +++ early-fasl.lisp 5 Jun 2007 11:42:54 -0000 1.74 @@ -76,7 +76,7 @@ ;;; versions which break binary compatibility. But it certainly should ;;; be incremented for release versions which break binary ;;; compatibility. -(def!constant +fasl-file-version+ 73) +(def!constant +fasl-file-version+ 74) ;;; (description of versions before 0.9.0.1 deleted in 0.9.17) ;;; 56: (2005-05-22) Something between 0.9.0.1 and 0.9.0.14. My money is ;;; on 0.9.0.6 (MORE CASE CONSISTENCY). @@ -103,6 +103,7 @@ ;;; 71: (2006-11-19) CLOS calling convention changes ;;; 72: (2006-12-05) Added slot to the primitive function type ;;; 73: (2007-04-13) Changed a hash function +;;; 74: (2007-06-05) UNWIND-TO-FRAME-AND-CALL ;;; the conventional file extension for our fasl files (declaim (type simple-string *fasl-file-type*)) |