From: William Harold Newman Date: Wed, 20 Sep 2000 18:50:02 +0000 (+0000) Subject: added various /SHOW0-ish statements to help when debugging internal X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=6d9ecc45cb21a1208deb8c4d128adc04aa289c9d;p=sbcl.git added various /SHOW0-ish statements to help when debugging internal error handling The MAKE-SPECIALIZABLE-ARRAY call in DEFUN INTERNAL-ERROR-ARGUMENTS can become MAKE-ARRAY, since M-S-A is something to make it easier to build parts of the cross-compiler under the cross-compilation host, and DEFUN INTERNAL-ERROR-ARGUMENTS is in x86-vm.lisp, which is not part of the cross-compiler, and so is never compiled by the cross-compilation host. changed MAKE-VALID-LISP-OBJ from a MACROLET macro to a global function, for clarity and easier debugging deleted unused SET-VALUE macro from MACROLET in DEFERR deleted code marked REMOVEME, accidentally left over from previous debugging exercises changed CONTEXT-PC-ADDR, CONTEXT-PC, CONTEXT-REGISTER-ADDR, and CONTEXT-REGISTER functions to use unsigned representations instead of signed representations, to conform to implicit assumptions in the debug-int code inherited from CMU CL. (Without this, new type errors are generated in infinite regress when we try to handle errors involving negative fixnums, e.g. (BUTLAST NIL -1).) tweaked stuff in test/ directory a little bit in anticipation of setting up real regression tests --- diff --git a/INSTALL b/INSTALL index ddc79bd..728f6db 100644 --- a/INSTALL +++ b/INSTALL @@ -83,6 +83,13 @@ making it run on more systems, would be appreciated. problem with quotas, I don't know.) To build the system binaries: + 0. If you want to be on the bleeding edge, you can update your + sources to the latest development snapshot (or any previous + development snapshot, for that matter) by using anonymous CVS + to SourceForge. (This is not recommended if you're just using SBCL + as a tool for other work, but if you're interested in working on + SBCL itself, it's a good idea.) Follow the "CVS Repository" link on + for instructions. 1. Make sure that you have enough RAM+swap to build SBCL, as per the CAUTION note above. (As of version 0.6.0, the most memory-intensive operation in make.sh is the second call to @@ -93,7 +100,7 @@ To build the system binaries: 2. If the GNU make command is not available under the name "gmake", then define the environment variable GNUMAKE to a name where it can be found. - 3. If you like, you can edit the base-features.lisp-expr file + 3. If you like, you can edit the base-target-features.lisp-expr file to customize the resulting Lisp system. By enabling or disabling features in this file, you can create a smaller system, or one with extra code for debugging output or error-checking or other things. diff --git a/NEWS b/NEWS index 7d0c0ed..ef34065 100644 --- a/NEWS +++ b/NEWS @@ -466,15 +466,16 @@ changes in sbcl-0.6.7 relative to sbcl-0.6.6: changes in sbcl-0.6.8 relative to sbcl-0.6.7: -?? The system is now under CVS at SourceForge (instead of the +* The system is now under CVS at SourceForge (instead of the CVS repository on my home machine). -?? The INSTALL file has been updated with some information - about using anonymous CVS to download the most recent version - from SourceForge. -?? There's now code in the tests/ subdirectory to run the system - through the clocc/ansi-tests/ suite, and to run additional - SBCL-specific regression tests as well. (It's not particularly - mature right now, but it's a start.) +* The new signal handling code has been tweaked to treat register + contents as (UNSIGNED-BYTE 32), as the old CMU CL code did, + instead of (SIGNED-BYTE 32), as the C header files have it. (Code + downstream, e.g. in debug-int.lisp, has implicit dependencies + on the unsignedness of integer representation of machine words, + and that caused the system to bomb out with infinite regress + when trying to recover from type errors involving signed values, + e.g. (BUTLAST '(1 2 3) -1).) ?? The system now uses code based on Colin Walters' O(N) implementation of MAP (from the cmucl-imp@cons.org mailing list, 2 September 2000) when it can't use a DEFTRANSFORM to @@ -489,13 +490,6 @@ changes in sbcl-0.6.8 relative to sbcl-0.6.7: CREDITS file.) ?? The debugger now flushes standard output streams before it begins its output ("debugger invoked" and so forth). -?? The two problem cases reported by Peter Van Eynde on 8 Sep 2000, - (BUTLAST '(1 2 3) -1) and (MAKE-LIST -1), now work, and test cases - have now been added to the regression test suite to keep them - from appearing again. (This was a repeat appearance, alas!) - As the regression test system gets more mature, I intend to add - most future fixed bugs to it, but at this point I'm still playing - with it. ?? The patch for the SUBSEQ bug reported on the cmucl-imp mailing list 12 September 2000 has been applied to SBCL. ?? Martin Atzmueller's versions of two CMU CL patches, as posted on diff --git a/TODO b/TODO index 8aceeeb..e3a1964 100644 --- a/TODO +++ b/TODO @@ -30,7 +30,7 @@ FIX: PROBLEM: As long as I'm working on the batch-related command-line options, it would be reasonable to add one more option to "do what I'd want", - testing standard input for TTY-ness and running in no-programmer + testing standard input for non-TTY-ness and running in no-programmer mode if so. FIX: ?? Do it. @@ -48,6 +48,11 @@ PROBLEM: some functions, and I never realized that there's a wrapper-based facility too until I was wading through the source code for SBCL. Yes, I know I should have RTFM, but there is a lot of M.. + (By the way, it would also be nice to have tracing behave + better with generic functions. TRACEing a generic function probably + shouldn't prevent DEFMETHOD from being used to redefine its + methods, and should perhaps trace each of its methods as well + as the generic function itself.) FIX: ?? possibility 1: Add error-handling code in ntrace.lisp to catch failure to set breakpoints and retry using @@ -75,7 +80,8 @@ FIX: ?? ------------------------------------------------------------------------------- PROBLEM: - My system of parallel build directories doesn't seem to add value. + My system of parallel build directories seems to add + complexity without adding value. FIX: ?? Replace it with a system where fasl output files live in the same directories as the sources and have names a la @@ -121,17 +127,6 @@ PROBLEM: The hashing code is new and should be tested. FIX: ?? Enable the existing test code. -------------------------------------------------------------------------------- -PROBLEM: - My ad hoc system of revision control is looking pretty clunky, - and I've pretty much stopped doing stuff to confuse CVS (like moving - directories around). -FIX: - ?? Check into CVS. - ?? Make sure that the tags in FILE-COMMENTs expand correctly. - ?? See about automatically propagating version information - from CVS into the runtime.c banner message and the - LISP-IMPLEMENTATION-VERSION string. =============================================================================== other known issues with no particular target date: diff --git a/base-target-features.lisp-expr b/base-target-features.lisp-expr index 5a15461..43e1009 100644 --- a/base-target-features.lisp-expr +++ b/base-target-features.lisp-expr @@ -97,7 +97,7 @@ ;; If you want to be able to use the extra debugging information, ;; therefore, be sure to keep the sources around, and run with the ;; readtable configured so that the system sources can be read. - ; :sb-show + ;:sb-show ;; Enable extra debugging output in the assem.lisp assembler/scheduler ;; code. (This is the feature which was called :DEBUG in the diff --git a/make-target-2.sh b/make-target-2.sh index 3d7990f..16f1e9c 100644 --- a/make-target-2.sh +++ b/make-target-2.sh @@ -33,7 +33,7 @@ echo //doing warm init (*print-level* 5)) (sb!int:/show "about to LOAD warm.lisp") (load "src/cold/warm.lisp")) - (sb-int:/show "about to SAVE-LISP-AND-DIE") + (sb-int:/show "done with warm.lisp, about to SAVE-LISP-AND-DIE") ;; Even if /SHOW output was wanted during build, it's probably ;; not wanted by default after build is complete. (And if it's ;; wanted, it can easily be turned back on.) diff --git a/src/code/debug-int.lisp b/src/code/debug-int.lisp index 3482adf..96d064c 100644 --- a/src/code/debug-int.lisp +++ b/src/code/debug-int.lisp @@ -2452,6 +2452,39 @@ (or (compiled-debug-var-save-sc-offset debug-var) (compiled-debug-var-sc-offset debug-var)))))) +;;; a helper function for working with possibly-invalid values: +;;; Do (MAKE-LISP-OBJ VAL) only if the value looks valid. +;;; +;;; (Such values can arise in registers on machines with conservative +;;; GC, and might also arise in debug variable locations when +;;; those variables are invalid.) +(defun make-valid-lisp-obj (val) + (/show0 "entering MAKE-VALID-LISP-OBJ, VAL=..") + #!+sb-show (%primitive print (sb!impl::hexstr val)) + (if (or + ;; fixnum + (zerop (logand val 3)) + ;; character + (and (zerop (logand val #xffff0000)) ; Top bits zero + (= (logand val #xff) sb!vm:base-char-type)) ; Char tag + ;; unbound marker + (= val sb!vm:unbound-marker-type) + ;; pointer + (and (logand val 1) + ;; Check that the pointer is valid. XXX Could do a better + ;; job. FIXME: e.g. by calling out to an is_valid_pointer + ;; routine in the C runtime support code + (or (< (sb!impl::read-only-space-start) val + (* sb!impl::*read-only-space-free-pointer* + sb!vm:word-bytes)) + (< (sb!impl::static-space-start) val + (* sb!impl::*static-space-free-pointer* + sb!vm:word-bytes)) + (< (sb!impl::current-dynamic-space-start) val + (sap-int (dynamic-space-free-pointer)))))) + (make-lisp-obj val) + :invalid-object)) + ;;; CMU CL had ;;; (DEFUN SUB-ACCESS-DEBUG-VAR-SLOT (FP SC-OFFSET &OPTIONAL ESCAPED) ..) ;;; code for this case. @@ -2462,102 +2495,100 @@ #!+x86 (defun sub-access-debug-var-slot (fp sc-offset &optional escaped) (declare (type system-area-pointer fp)) + (/show0 "entering SUB-ACCESS-DEBUG-VAR-SLOT, FP,SC-OFFSET,ESCAPED=..") + #!+sb-show (%primitive print (sb!impl::hexstr fp)) + #!+sb-show (%primitive print (sb!impl::hexstr sc-offset)) + #!+sb-show (%primitive print (sb!impl::hexstr escaped)) (macrolet ((with-escaped-value ((var) &body forms) `(if escaped - (let ((,var (sb!vm:context-register - escaped (sb!c:sc-offset-offset sc-offset)))) - ,@forms) - :invalid-value-for-unescaped-register-storage)) + (let ((,var (sb!vm:context-register + escaped + (sb!c:sc-offset-offset sc-offset)))) + (/show0 "in escaped case, ,VAR value=..") + #!+sb-show (%primitive print (sb!impl::hexstr ,var)) + ,@forms) + :invalid-value-for-unescaped-register-storage)) (escaped-float-value (format) `(if escaped - (sb!vm:context-float-register - escaped (sb!c:sc-offset-offset sc-offset) ',format) - :invalid-value-for-unescaped-register-storage)) + (sb!vm:context-float-register + escaped (sb!c:sc-offset-offset sc-offset) ',format) + :invalid-value-for-unescaped-register-storage)) (escaped-complex-float-value (format) `(if escaped - (complex - (sb!vm:context-float-register - escaped (sb!c:sc-offset-offset sc-offset) ',format) - (sb!vm:context-float-register - escaped (1+ (sb!c:sc-offset-offset sc-offset)) ',format)) - :invalid-value-for-unescaped-register-storage)) - ;; The debug variable locations are not always valid, and - ;; on the x86 locations can contain raw values. To - ;; prevent later problems from invalid objects, they are - ;; filtered here. - (make-valid-lisp-obj (val) - `(if (or - ;; fixnum - (zerop (logand ,val 3)) - ;; character - (and (zerop (logand ,val #xffff0000)) ; Top bits zero - (= (logand ,val #xff) sb!vm:base-char-type)) ; Char tag - ;; unbound marker - (= ,val sb!vm:unbound-marker-type) - ;; pointer - (and (logand ,val 1) - ;; Check that the pointer is valid. XXX Could do a - ;; better job. - (or (< (sb!impl::read-only-space-start) ,val - (* sb!impl::*read-only-space-free-pointer* - sb!vm:word-bytes)) - (< (sb!impl::static-space-start) ,val - (* sb!impl::*static-space-free-pointer* - sb!vm:word-bytes)) - (< (sb!impl::current-dynamic-space-start) ,val - (sap-int (dynamic-space-free-pointer)))))) - (make-lisp-obj ,val) - :invalid-object))) + (complex + (sb!vm:context-float-register + escaped (sb!c:sc-offset-offset sc-offset) ',format) + (sb!vm:context-float-register + escaped (1+ (sb!c:sc-offset-offset sc-offset)) ',format)) + :invalid-value-for-unescaped-register-storage))) (ecase (sb!c:sc-offset-scn sc-offset) ((#.sb!vm:any-reg-sc-number #.sb!vm:descriptor-reg-sc-number) + (/show0 "case of ANY-REG-SC-NUMBER or DESCRIPTOR-REG-SC-NUMBER") (without-gcing (with-escaped-value (val) + (/show0 "VAL=..") + #!+sb-show (%primitive print (sb!impl::hexstr val)) (make-valid-lisp-obj val)))) (#.sb!vm:base-char-reg-sc-number + (/show0 "case of BASE-CHAR-REG-SC-NUMBER") (with-escaped-value (val) (code-char val))) (#.sb!vm:sap-reg-sc-number + (/show0 "case of SAP-REG-SC-NUMBER") (with-escaped-value (val) (int-sap val))) (#.sb!vm:signed-reg-sc-number + (/show0 "case of SIGNED-REG-SC-NUMBER") (with-escaped-value (val) (if (logbitp (1- sb!vm:word-bits) val) (logior val (ash -1 sb!vm:word-bits)) val))) (#.sb!vm:unsigned-reg-sc-number + (/show0 "case of UNSIGNED-REG-SC-NUMBER") (with-escaped-value (val) val)) (#.sb!vm:single-reg-sc-number + (/show0 "case of SINGLE-REG-SC-NUMBER") (escaped-float-value single-float)) (#.sb!vm:double-reg-sc-number + (/show0 "case of DOUBLE-REG-SC-NUMBER") (escaped-float-value double-float)) #!+long-float (#.sb!vm:long-reg-sc-number + (/show0 "case of LONG-REG-SC-NUMBER") (escaped-float-value long-float)) (#.sb!vm:complex-single-reg-sc-number + (/show0 "case of COMPLEX-SINGLE-REG-SC-NUMBER") (escaped-complex-float-value single-float)) (#.sb!vm:complex-double-reg-sc-number + (/show0 "case of COMPLEX-DOUBLE-REG-SC-NUMBER") (escaped-complex-float-value double-float)) #!+long-float (#.sb!vm:complex-long-reg-sc-number + (/show0 "case of COMPLEX-LONG-REG-SC-NUMBER") (escaped-complex-float-value long-float)) (#.sb!vm:single-stack-sc-number + (/show0 "case of SINGLE-STACK-SC-NUMBER") (sap-ref-single fp (- (* (1+ (sb!c:sc-offset-offset sc-offset)) sb!vm:word-bytes)))) (#.sb!vm:double-stack-sc-number + (/show0 "case of DOUBLE-STACK-SC-NUMBER") (sap-ref-double fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 2) sb!vm:word-bytes)))) #!+long-float (#.sb!vm:long-stack-sc-number + (/show0 "case of LONG-STACK-SC-NUMBER") (sap-ref-long fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 3) sb!vm:word-bytes)))) (#.sb!vm:complex-single-stack-sc-number + (/show0 "case of COMPLEX-STACK-SC-NUMBER") (complex (sap-ref-single fp (- (* (1+ (sb!c:sc-offset-offset sc-offset)) sb!vm:word-bytes))) (sap-ref-single fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 2) sb!vm:word-bytes))))) (#.sb!vm:complex-double-stack-sc-number + (/show0 "case of COMPLEX-DOUBLE-STACK-SC-NUMBER") (complex (sap-ref-double fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 2) sb!vm:word-bytes))) @@ -2565,24 +2596,30 @@ sb!vm:word-bytes))))) #!+long-float (#.sb!vm:complex-long-stack-sc-number + (/show0 "case of COMPLEX-LONG-STACK-SC-NUMBER") (complex (sap-ref-long fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 3) sb!vm:word-bytes))) (sap-ref-long fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 6) sb!vm:word-bytes))))) (#.sb!vm:control-stack-sc-number + (/show0 "case of CONTROL-STACK-SC-NUMBER") (stack-ref fp (sb!c:sc-offset-offset sc-offset))) (#.sb!vm:base-char-stack-sc-number + (/show0 "case of BASE-CHAR-STACK-SC-NUMBER") (code-char (sap-ref-32 fp (- (* (1+ (sb!c:sc-offset-offset sc-offset)) sb!vm:word-bytes))))) (#.sb!vm:unsigned-stack-sc-number + (/show0 "case of UNSIGNED-STACK-SC-NUMBER") (sap-ref-32 fp (- (* (1+ (sb!c:sc-offset-offset sc-offset)) sb!vm:word-bytes)))) (#.sb!vm:signed-stack-sc-number + (/show0 "case of SIGNED-STACK-SC-NUMBER") (signed-sap-ref-32 fp (- (* (1+ (sb!c:sc-offset-offset sc-offset)) sb!vm:word-bytes)))) (#.sb!vm:sap-stack-sc-number + (/show0 "case of SAP-STACK-SC-NUMBER") (sap-ref-sap fp (- (* (1+ (sb!c:sc-offset-offset sc-offset)) sb!vm:word-bytes))))))) diff --git a/src/code/debug-var-io.lisp b/src/code/debug-var-io.lisp index 055b4df..0d0ba29 100644 --- a/src/code/debug-var-io.lisp +++ b/src/code/debug-var-io.lisp @@ -22,8 +22,13 @@ ;;;; 254 => read next two bytes for integer ;;;; 255 => read next four bytes for integer -;;; Given a byte vector Vec and an index variable Index, read a variable -;;; length integer and advance index. +;;; Given a byte vector VEC and an index variable INDEX, read a +;;; variable length integer and advance index. +;;; +;;; FIXME: This is called O(20) times. It should be reimplemented +;;; with much of its logic in a single service function which can +;;; be called by the macro expansion: +;;; `(SETF ,INDEX (%READ-VAR-INTEGER ,VEC ,INDEX)). (defmacro read-var-integer (vec index) (once-only ((val `(aref ,vec ,index))) `(cond ((<= ,val 253) diff --git a/src/code/filesys.lisp b/src/code/filesys.lisp index c50b579..3a71d9a 100644 --- a/src/code/filesys.lisp +++ b/src/code/filesys.lisp @@ -567,10 +567,6 @@ function)))) (%enumerate-files head pathname verify-existence function))) -;;; REMOVEME after finding bug. -#!+sb-show (defvar *show-directory*) -#!+sb-show (defvar *show-name*) - (defun %enumerate-files (directory pathname verify-existence function) (declare (simple-string directory)) (/show0 "entering %ENUMERATE-FILES") @@ -614,13 +610,6 @@ (sb!unix:close-dir dir))))) (t (/show0 "default case") - - ;; Put DIRECTORY and NAME somewhere we can find them even when - ;; things are too screwed up for the debugger. - #!+sb-show (progn - (setf *show-directory* directory - *show-name* name)) - (let ((file (concatenate 'string directory name))) (/show0 "computed basic FILE=..") #!+sb-show (%primitive print file) diff --git a/src/code/interr.lisp b/src/code/interr.lisp index 963c669..9f9d67d 100644 --- a/src/code/interr.lisp +++ b/src/code/interr.lisp @@ -28,12 +28,11 @@ (fp (gensym)) (context (gensym)) (sc-offsets (gensym)) - (temp (gensym)) (fn-name (symbolicate name "-HANDLER"))) `(progn ;; FIXME: Having a separate full DEFUN for each error doesn't ;; seem to add much value, and it takes a lot of space. Perhaps - ;; we could make this a big CASE statement instead? + ;; we could do this dispatch with a big CASE statement instead? (defun ,fn-name (name ,fp ,context ,sc-offsets) ;; FIXME: Perhaps put in OPTIMIZE declaration to make this ;; byte coded. @@ -44,32 +43,24 @@ ;; where his error was detected instead of telling him where ;; he ended up inside the system error-handling logic. (declare (ignorable name ,fp ,context ,sc-offsets)) - (macrolet ((set-value (var value) - (let ((pos (position var ',required))) - (unless pos - (error "~S isn't one of the required args." var)) - `(let ((,',temp ,value)) - (sb!di::sub-set-debug-var-slot - ,',fp (nth ,pos ,',sc-offsets) - ,',temp ,',context) - (setf ,var ,',temp))))) - (let (,@(let ((offset -1)) - (mapcar #'(lambda (var) - `(,var (sb!di::sub-access-debug-var-slot - ,fp - (nth ,(incf offset) - ,sc-offsets) - ,context))) - required)) - ,@(when rest-pos - `((,(nth (1+ rest-pos) args) - (mapcar #'(lambda (sc-offset) - (sb!di::sub-access-debug-var-slot + (/show0 "about to do outer LETs in DEFERR macroexpanded DEFUN") + (let (,@(let ((offset -1)) + (mapcar #'(lambda (var) + `(,var (sb!di::sub-access-debug-var-slot ,fp - sc-offset - ,context)) - (nthcdr ,rest-pos ,sc-offsets)))))) - ,@body))) + (nth ,(incf offset) + ,sc-offsets) + ,context))) + required)) + ,@(when rest-pos + `((,(nth (1+ rest-pos) args) + (mapcar #'(lambda (sc-offset) + (sb!di::sub-access-debug-var-slot + ,fp + sc-offset + ,context)) + (nthcdr ,rest-pos ,sc-offsets)))))) + ,@body)) (setf (svref *internal-errors* ,(error-number-or-lose name)) #',fn-name)))) @@ -283,6 +274,9 @@ :operands (list this that))) (deferr object-not-type-error (object type) + (/show0 "entering body of DEFERR OBJECT-NOT-TYPE-ERROR, OBJECT,TYPE=..") + #!+sb-show (sb!sys:%primitive print (sb!impl::hexstr object)) + #!+sb-show (sb!sys:%primitive print (sb!impl::hexstr type)) (error (if (and (typep object 'instance) (layout-invalid (%instance-layout object))) 'layout-invalid @@ -507,10 +501,12 @@ (defun internal-error (context continuable) (declare (type system-area-pointer context) (ignore continuable)) + (/show0 "entering INTERNAL-ERROR, CONTEXT=..") + #!+sb-show (sb!sys:%primitive print (sb!impl::hexstr context)) (infinite-error-protect (let ((context (locally - (declare (optimize (inhibit-warnings 3))) - (sb!alien:sap-alien context (* os-context-t))))) + (declare (optimize (inhibit-warnings 3))) + (sb!alien:sap-alien context (* os-context-t))))) (multiple-value-bind (error-number arguments) (sb!vm:internal-error-arguments context) (multiple-value-bind (name sb!debug:*stack-top-hint*) @@ -533,8 +529,7 @@ ((not (functionp handler)) (error 'simple-error :function-name name - :format-control - "internal error ~D: ~A; args=~S" + :format-control "internal error ~D: ~A; args=~S" :format-arguments (list error-number handler diff --git a/src/code/x86-vm.lisp b/src/code/x86-vm.lisp index bd08c4a..38aafab 100644 --- a/src/code/x86-vm.lisp +++ b/src/code/x86-vm.lisp @@ -188,25 +188,37 @@ ;;;; and internal error handling) the extra runtime cost should be ;;;; negligible. -(def-alien-routine ("os_context_pc_addr" context-pc-addr) (* int) +(def-alien-routine ("os_context_pc_addr" context-pc-addr) (* unsigned-int) + ;; (Note: Just as in CONTEXT-REGISTER-ADDR, we intentionally use an + ;; 'unsigned *' interpretation for the 32-bit word passed to us by + ;; the C code, even though the C code may think it's an 'int *'.) (context (* os-context-t))) (defun context-pc (context) (declare (type (alien (* os-context-t)) context)) (int-sap (deref (context-pc-addr context)))) -(def-alien-routine ("os_context_register_addr" context-register-addr) (* int) +(def-alien-routine ("os_context_register_addr" context-register-addr) + (* unsigned-int) + ;; (Note the mismatch here between the 'int *' value that the C code + ;; may think it's giving us and the 'unsigned *' value that we + ;; receive. It's intentional: the C header files may think of + ;; register values as signed, but the CMU CL code tends to think of + ;; register values as unsigned, and might get bewildered if we ask + ;; it to work with signed values.) (context (* os-context-t)) (index int)) +;;; FIXME: Should this and CONTEXT-PC be INLINE to reduce consing? +;;; (Are they used in anything time-critical, or just the debugger?) (defun context-register (context index) (declare (type (alien (* os-context-t)) context)) (deref (context-register-addr context index))) (defun %set-context-register (context index new) - (declare (type (alien (* os-context-t)) context)) - (setf (deref (context-register-addr context index)) - new)) +(declare (type (alien (* os-context-t)) context)) +(setf (deref (context-register-addr context index)) + new)) ;;; Like CONTEXT-REGISTER, but returns the value of a float register. ;;; FORMAT is the type of float to return. @@ -215,13 +227,13 @@ ;;; so it's stubbed out. Someday, in order to make the debugger work ;;; better, it may be necessary to unstubify it. (defun context-float-register (context index format) - (declare (ignore context index format)) + (declare (ignore context index)) (warn "stub CONTEXT-FLOAT-REGISTER") - (coerce 0.0 'format)) + (coerce 0.0 format)) (defun %set-context-float-register (context index format new-value) - (declare (ignore context index format)) + (declare (ignore context index)) (warn "stub %SET-CONTEXT-FLOAT-REGISTER") - (coerce new-value 'format)) + (coerce new-value format)) ;;; Given a signal context, return the floating point modes word in ;;; the same format as returned by FLOATING-POINT-MODES. @@ -251,26 +263,35 @@ ;;; arguments from the instruction stream. (defun internal-error-arguments (context) (declare (type (alien (* os-context-t)) context)) + (/show0 "entering INTERNAL-ERROR-ARGUMENTS, CONTEXT=..") + #!+sb-show (sb!sys:%primitive print (sb!impl::hexstr context)) (let ((pc (context-pc context))) (declare (type system-area-pointer pc)) ;; using INT3 the pc is .. INT3 code length bytes... (let* ((length (sap-ref-8 pc 1)) - (vector (make-specializable-array - length - :element-type '(unsigned-byte 8)))) + (vector (make-array length :element-type '(unsigned-byte 8)))) (declare (type (unsigned-byte 8) length) (type (simple-array (unsigned-byte 8) (*)) vector)) + (/show0 "LENGTH,VECTOR,ERROR-NUMBER=..") + #!+sb-show (sb!sys:%primitive print (sb!impl::hexstr length)) + #!+sb-show (sb!sys:%primitive print (sb!impl::hexstr vector)) (copy-from-system-area pc (* sb!vm:byte-bits 2) vector (* sb!vm:word-bits sb!vm:vector-data-offset) (* length sb!vm:byte-bits)) (let* ((index 0) (error-number (sb!c::read-var-integer vector index))) + #!+sb-show (sb!sys:%primitive print (sb!impl::hexstr error-number)) (collect ((sc-offsets)) (loop + (/show0 "INDEX=..") + #!+sb-show (sb!sys:%primitive print (sb!impl::hexstr index)) (when (>= index length) (return)) - (sc-offsets (sb!c::read-var-integer vector index))) + (let ((sc-offset (sb!c::read-var-integer vector index))) + (/show0 "SC-OFFSET=..") + #!+sb-show (sb!sys:%primitive print (sb!impl::hexstr sc-offset)) + (sc-offsets sc-offset))) (values error-number (sc-offsets))))))) ;;; Do whatever is necessary to make the given code component diff --git a/src/runtime/x86-arch.c b/src/runtime/x86-arch.c index 406030f..3c556c4 100644 --- a/src/runtime/x86-arch.c +++ b/src/runtime/x86-arch.c @@ -191,8 +191,6 @@ sigtrap_handler(int signal, siginfo_t *info, void *void_context) os_context_t *context = (os_context_t*)void_context; unsigned int trap; - SHOW("entering sigtrap_handler(..)"); /* REMOVEME */ - if (single_stepping && (signal==SIGTRAP)) { /* fprintf(stderr,"* single step trap %x\n", single_stepping); */ @@ -241,7 +239,6 @@ sigtrap_handler(int signal, siginfo_t *info, void *void_context) * here, and restore it after we do our thing, but there * seems to be no point in doing that, since we're just * going to lose(..) anyway. */ - SHOW("in trap_Halt case of sigtrap_handler(..)"); /* REMOVEME */ fake_foreign_function_call(context); lose("%%primitive halt called; the party is over."); @@ -268,7 +265,6 @@ sigtrap_handler(int signal, siginfo_t *info, void *void_context) interrupt_handle_now(signal, info, context); break; } - SHOW("leaving sigtrap_handler(..)"); /* REMOVEME */ } void diff --git a/tests/bignum-test.lisp b/tests/bignum-test.lisp deleted file mode 100644 index 5a7926d..0000000 --- a/tests/bignum-test.lisp +++ /dev/null @@ -1,102 +0,0 @@ -;;;; some stuff to check that bignum operations are returning correct -;;;; results - -;;;; This software is part of the SBCL system. See the README file for -;;;; more information. -;;;; -;;;; This software is derived from the CMU CL system, which was -;;;; written at Carnegie Mellon University and released into the -;;;; public domain. The software is in the public domain and is -;;;; provided with absolutely no warranty. See the COPYING and CREDITS -;;;; files for more information. - -(in-package "SB!BIGNUM") - -(file-comment - "$Header$") - -(defvar *in-bignum-wrapper* nil) - -(defmacro def-bignum-wrapper (name lambda-list &body body) - (let ((var-name (sb!int:symbolicate "*OLD-" name "*")) - (wrap-name (sb!int:symbolicate "WRAP-" name)) - (args (mapcar #'(lambda (x) - (if (listp x) (car x) x)) - (remove-if #'(lambda (x) - (member x lambda-list-keywords)) - lambda-list)))) - `(progn - (defvar ,var-name (fdefinition ',name)) - (defun ,wrap-name ,lambda-list - (if *in-bignum-wrapper* - (funcall ,var-name ,@args) - (let ((*in-bignum-wrapper* t)) - ,@body))) - (setf (fdefinition ',name) #',wrap-name)))) - -(defun big= (x y) - (= (if (typep x 'bignum) - (%normalize-bignum x (%bignum-length x)) - x) - (if (typep y 'bignum) - (%normalize-bignum y (%bignum-length y)) - y))) - -(def-bignum-wrapper add-bignums (x y) - (let ((res (funcall *old-add-bignums* x y))) - (assert (big= (- res y) x)) - res)) - -(def-bignum-wrapper multiply-bignums (x y) - (let ((res (funcall *old-multiply-bignums* x y))) - (if (zerop x) - (assert (zerop res)) - (multiple-value-bind (q r) (truncate res x) - (assert (and (zerop r) (big= q y))))) - res)) - -(def-bignum-wrapper negate-bignum (x &optional (fully-normalized t)) - (let ((res (funcall *old-negate-bignum* x fully-normalized))) - (assert (big= (- res) x)) - res)) - -(def-bignum-wrapper subtract-bignum (x y) - (let ((res (funcall *old-subtract-bignum* x y))) - (assert (big= (+ res y) x)) - res)) - -(def-bignum-wrapper multiply-bignum-and-fixnum (x y) - (let ((res (funcall *old-multiply-bignum-and-fixnum* x y))) - (if (zerop x) - (assert (zerop res)) - (multiple-value-bind (q r) (truncate res x) - (assert (and (zerop r) (big= q y))))) - res)) - -(def-bignum-wrapper multiply-fixnums (x y) - (let ((res (funcall *old-multiply-fixnums* x y))) - (if (zerop x) - (assert (zerop res)) - (multiple-value-bind (q r) (truncate res x) - (assert (and (zerop r) (big= q y))))) - res)) - -(def-bignum-wrapper bignum-ashift-right (x shift) - (let ((res (funcall *old-bignum-ashift-right* x shift))) - (assert (big= (ash res shift) (logand x (ash -1 shift)))) - res)) - -(def-bignum-wrapper bignum-ashift-left (x shift) - (let ((res (funcall *old-bignum-ashift-left* x shift))) - (assert (big= (ash res (- shift)) x)) - res)) - -(def-bignum-wrapper bignum-truncate (x y) - (multiple-value-bind (q r) (funcall *old-bignum-truncate* x y) - (assert (big= (+ (* q y) r) x)) - (values q r))) - -(def-bignum-wrapper bignum-compare (x y) - (let ((res (funcall *old-bignum-compare* x y))) - (assert (big= (signum (- x y)) res)) - res)) diff --git a/tests/run-tests.sh b/tests/run-tests.sh index 6ac24e8..366eba1 100644 --- a/tests/run-tests.sh +++ b/tests/run-tests.sh @@ -16,9 +16,16 @@ for f in *.impure.lisp; do echo $f | $sbcl < pure.lisp done -# *.test.sh files are scripts to test stuff. A file foo.test.sh +# *.test.sh files are scripts to test stuff, typically stuff which can't +# so easily be tested within Lisp itself. A file foo.test.sh # may be associated with other files foo*, e.g. foo.lisp, foo-1.lisp, # or foo.pl. for f in *.test.sh; do - sh $f + sh $f || exit failed test $f +done + +# *.assertoids files contain ASSERTOID statements to test things +# interpreted and at various compilation levels. +for f in *.assertoids; do + echo "(load \"$f\")" | $sbcl --eval '(load "assertoid.lisp")' done diff --git a/version.lisp-expr b/version.lisp-expr index 0a230c4..ec6008f 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -13,6 +13,6 @@ ;;; ;;; Conventionally a string a la "0.6.6" is used for released ;;; versions, and a string a la "0.6.5.12" is used for versions which -;;; aren't released but correspond only to CVS tags. +;;; aren't released but correspond only to CVS tags or snapshots. -"0.6.7.1" +"0.6.7.2"