Steel Bank Common Lisp

Update of /cvsroot/sbcl/sbcl
In directory sc8-pr-cvs8.sourceforge.net:/tmp/cvs-serv3775

Modified Files:
	version.lisp-expr 
Log Message:
1.0.4.43: x86 assembler/disassembler tweaks
  * Made fs-segment-prefix disassemble as such instead of as byte #x64.
  * Added gs-segment-prefix, for symmetry.


Index: version.lisp-expr
===================================================================
RCS file: /cvsroot/sbcl/sbcl/version.lisp-expr,v
retrieving revision 1.3297
retrieving revision 1.3298
diff -u -d -r1.3297 -r1.3298
--- version.lisp-expr	7 Apr 2007 20:00:24 -0000	1.3297
+++ version.lisp-expr	7 Apr 2007 21:43:04 -0000	1.3298
@@ -17,4 +17,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"1.0.4.42"
+"1.0.4.43"

Update of /cvsroot/sbcl/sbcl/src/compiler/x86
In directory sc8-pr-cvs8.sourceforge.net:/tmp/cvs-serv3775/src/compiler/x86

Modified Files:
	insts.lisp 
Log Message:
1.0.4.43: x86 assembler/disassembler tweaks
  * Made fs-segment-prefix disassemble as such instead of as byte #x64.
  * Added gs-segment-prefix, for symmetry.


Index: insts.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/x86/insts.lisp,v
retrieving revision 1.40
retrieving revision 1.41
diff -u -d -r1.40 -r1.41
--- insts.lisp	7 Apr 2007 20:00:24 -0000	1.40
+++ insts.lisp	7 Apr 2007 21:43:04 -0000	1.41
@@ -1089,9 +1089,15 @@
 
 
 (define-instruction fs-segment-prefix (segment)
+  (:printer byte ((op #b01100100)))
   (:emitter
    (emit-byte segment #x64)))
 
+(define-instruction gs-segment-prefix (segment)
+  (:printer byte ((op #b01100101)))
+  (:emitter
+   (emit-byte segment #x65)))
+
 ;;;; flag control instructions
 
 ;;; CLC -- Clear Carry Flag.

Update of /cvsroot/sbcl/sbcl/src/compiler/x86
In directory sc8-pr-cvs8.sourceforge.net:/tmp/cvs-serv23177/src/compiler/x86

Modified Files:
	call.lisp char.lisp debug.lisp float.lisp insts.lisp move.lisp 
	nlx.lisp sap.lisp vm.lisp 
Log Message:
1.0.2.42: x86 backend cleanups
  * Defined frame-byte-offset and frame-word-offset for calculating 
    offsets within a stack frame.
  * Modified most direct references to stack data to use 
    frame-byte-offset and frame-word-offset instead of an inline 
    calculation.


Index: call.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/x86/call.lisp,v
retrieving revision 1.35
retrieving revision 1.36
diff -u -d -r1.35 -r1.36
--- call.lisp	5 Dec 2006 20:10:27 -0000	1.35
+++ call.lisp	7 Apr 2007 20:00:24 -0000	1.36
@@ -133,7 +133,7 @@
 
     ;; The start of the actual code.
     ;; Save the return-pc.
-    (popw ebp-tn (- (1+ return-pc-save-offset)))
+    (popw ebp-tn (frame-word-offset return-pc-save-offset))
 
     ;; If copy-more-arg follows it will allocate the correct stack
     ;; size. The stack is not allocated first here as this may expose
@@ -267,7 +267,7 @@
 
             (inst cmp ecx-tn (fixnumize i))
             (inst jmp :be default-lab)
-            (loadw edx-tn ebx-tn (- (1+ i)))
+            (loadw edx-tn ebx-tn (frame-word-offset i))
             (inst mov tn edx-tn)))
 
         (emit-label defaulting-done)
@@ -306,7 +306,7 @@
       (emit-label no-stack-args)
       (inst lea edi-tn
             (make-ea :dword :base ebp-tn
-                     :disp (* (- (1+ register-arg-count)) n-word-bytes)))
+                     :disp (frame-byte-offset register-arg-count)))
       ;; Load EAX with NIL so we can quickly store it, and set up
       ;; stuff for the loop.
       (inst mov eax-tn nil-value)
@@ -321,7 +321,7 @@
       ;; and then default the remaining stack arguments.
       (emit-label regs-defaulted)
       ;; Save EDI.
-      (storew edi-tn ebx-tn (- (1+ 1)))
+      (storew edi-tn ebx-tn (frame-word-offset 1))
       ;; Compute the number of stack arguments, and if it's zero or
       ;; less, don't copy any stack arguments.
       (inst sub ecx-tn (fixnumize register-arg-count))
@@ -337,12 +337,12 @@
       ;; Compute a pointer to where the stack args go.
       (inst lea edi-tn
             (make-ea :dword :base ebp-tn
-                     :disp (* (- (1+ register-arg-count)) n-word-bytes)))
+                     :disp (frame-byte-offset register-arg-count)))
       ;; Save ESI, and compute a pointer to where the args come from.
-      (storew esi-tn ebx-tn (- (1+ 2)))
+      (storew esi-tn ebx-tn (frame-word-offset 2))
       (inst lea esi-tn
             (make-ea :dword :base ebx-tn
-                     :disp (* (- (1+ register-arg-count)) n-word-bytes)))
+                     :disp (frame-byte-offset register-arg-count)))
       ;; Do the copy.
       (inst shr ecx-tn word-shift)              ; make word count
       (inst std)
@@ -351,7 +351,7 @@
       ;; solaris requires DF being zero.
       #!+sunos (inst cld)
       ;; Restore ESI.
-      (loadw esi-tn ebx-tn (- (1+ 2)))
+      (loadw esi-tn ebx-tn (frame-word-offset 2))
       ;; Now we have to default the remaining args. Find out how many.
       (inst sub eax-tn (fixnumize (- nvals register-arg-count)))
       (inst neg eax-tn)
@@ -369,7 +369,7 @@
       #!+sunos (inst cld)
       ;; Restore EDI, and reset the stack.
       (emit-label restore-edi)
-      (loadw edi-tn ebx-tn (- (1+ 1)))
+      (loadw edi-tn ebx-tn (frame-word-offset 1))
       (inst mov esp-tn ebx-tn))))
   (values))
 
@@ -479,7 +479,7 @@
          #+nil (format t "*call-local: ret-tn on stack; offset=~S~%"
                        (tn-offset ret-tn))
          (storew (make-fixup nil :code-object return)
-                 ebp-tn (- (1+ (tn-offset ret-tn)))))
+                 ebp-tn (frame-word-offset (tn-offset ret-tn))))
         ((sap-reg)
          (inst lea ret-tn (make-fixup nil :code-object return)))))
 
@@ -518,7 +518,7 @@
                        (tn-offset ret-tn))
          ;; Stack
          (storew (make-fixup nil :code-object return)
-                 ebp-tn (- (1+ (tn-offset ret-tn)))))
+                 ebp-tn (frame-word-offset (tn-offset ret-tn))))
         ((sap-reg)
          ;; Register
          (inst lea ret-tn (make-fixup nil :code-object return)))))
@@ -566,7 +566,7 @@
                        (tn-offset ret-tn))
          ;; Stack
          (storew (make-fixup nil :code-object return)
-                 ebp-tn (- (1+ (tn-offset ret-tn)))))
+                 ebp-tn (frame-word-offset (tn-offset ret-tn))))
         ((sap-reg)
          ;; Register
          (inst lea ret-tn (make-fixup nil :code-object return)))))
@@ -651,8 +651,7 @@
           (cond ((zerop (tn-offset old-fp))
                  ;; Zot all of the stack except for the old-fp.
                  (inst lea esp-tn (make-ea :dword :base ebp-tn
-                                           :disp (- (* (1+ ocfp-save-offset)
-                                                       n-word-bytes))))
+                                           :disp (frame-byte-offset ocfp-save-offset)))
                  ;; Restore the old fp from its save location on the stack,
                  ;; and zot the stack.
                  (inst pop ebp-tn))
@@ -680,7 +679,7 @@
        ;; Zot all of the stack except for the old-fp and return-pc.
        (inst lea esp-tn
              (make-ea :dword :base ebp-tn
-                      :disp (- (* (1+ (tn-offset return-pc)) n-word-bytes))))
+                      :disp (frame-byte-offset (tn-offset return-pc))))
        ;; Restore the old fp. old-fp may be either on the stack in its
        ;; save location or in a register, in either case this restores it.
        (move ebp-tn old-fp)
@@ -858,12 +857,12 @@
                                       (move old-fp-tmp old-fp)
                                       (storew old-fp-tmp
                                               ebp-tn
-                                              (- (1+ ocfp-save-offset)))))
+                                              (frame-word-offset ocfp-save-offset))))
                                    ((any-reg descriptor-reg)
                                     (format t "** tail-call old-fp in reg not S0~%")
                                     (storew old-fp
                                             ebp-tn
-                                            (- (1+ ocfp-save-offset)))))
+                                            (frame-word-offset ocfp-save-offset))))
 
                           ;; For tail call, we have to push the
                           ;; return-pc so that it looks like we CALLed
@@ -889,7 +888,7 @@
                                '(inst sub esp-tn (fixnumize 3)))
 
                           ;; Save the fp
-                          (storew ebp-tn new-fp (- (1+ ocfp-save-offset)))
+                          (storew ebp-tn new-fp (frame-word-offset ocfp-save-offset))
 
                           (move ebp-tn new-fp) ; NB - now on new stack frame.
                           )))
@@ -992,8 +991,7 @@
           ;; Drop the stack above it and pop it off.
           (cond ((zerop (tn-offset old-fp))
                  (inst lea esp-tn (make-ea :dword :base ebp-tn
-                                           :disp (- (* (1+ ocfp-save-offset)
-                                                       n-word-bytes))))
+                                           :disp (frame-byte-offset ocfp-save-offset)))
                  (inst pop ebp-tn))
                 (t
                  ;; Should this ever happen, we do the same as above, but
@@ -1024,8 +1022,7 @@
        ;; into a temp reg while we fix the stack.
        ;; Drop stack above return-pc
        (inst lea esp-tn (make-ea :dword :base ebp-tn
-                                 :disp (- (* (1+ (tn-offset return-pc))
-                                             n-word-bytes))))
+                                 :disp (frame-byte-offset (tn-offset return-pc))))
        ;; Set single-value return flag
        (inst clc)
        ;; Restore the old frame pointer
@@ -1096,8 +1093,7 @@
            (inst ret))
           (t
            (inst jmp (make-ea :dword :base ebx
-                              :disp (- (* (1+ (tn-offset return-pc))
-                                          n-word-bytes))))))
+                              :disp (frame-byte-offset (tn-offset return-pc))))))
 
     (trace-table-entry trace-table-normal)))
 

Index: char.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/x86/char.lisp,v
retrieving revision 1.8
retrieving revision 1.9
diff -u -d -r1.8 -r1.9
--- char.lisp	14 Jul 2005 19:13:47 -0000	1.8
+++ char.lisp	7 Apr 2007 20:00:24 -0000	1.9
@@ -103,12 +103,14 @@
       (character-stack
        #!-sb-unicode
        (inst mov
-             (make-ea :byte :base fp :disp (- (* (1+ (tn-offset y)) 4)))
+             ;; XXX: If the sb-unicode case needs to handle c-call,
+             ;; why does the non-unicode case not need to?
+             (make-ea :byte :base fp :disp (frame-byte-offset (tn-offset y)))
              x)
        #!+sb-unicode
        (if (= (tn-offset fp) esp-offset)
            (storew x fp (tn-offset y))  ; c-call
-           (storew x fp (- (1+ (tn-offset y)))))))))
+           (storew x fp (frame-word-offset (tn-offset y))))))))
 (define-move-vop move-character-arg :move-arg
   (any-reg character-reg) (character-reg))
 

Index: debug.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/x86/debug.lisp,v
retrieving revision 1.8
retrieving revision 1.9
diff -u -d -r1.8 -r1.9
--- debug.lisp	14 Jul 2005 19:13:47 -0000	1.8
+++ debug.lisp	7 Apr 2007 20:00:24 -0000	1.9
@@ -55,7 +55,7 @@
   (:result-types *)
   (:generator 5
     (inst mov result (make-ea :dword :base sap
-                              :disp (- (* (1+ index) n-word-bytes))))))
+                              :disp (frame-byte-offset index)))))
 
 (define-vop (write-control-stack)
   (:translate %set-stack-ref)
@@ -85,7 +85,7 @@
   (:result-types *)
   (:generator 5
     (inst mov (make-ea :dword :base sap
-                       :disp (- (* (1+ index) n-word-bytes)))
+                       :disp (frame-byte-offset index))
           value)
     (move result value)))
 

Index: float.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/x86/float.lisp,v
retrieving revision 1.20
retrieving revision 1.21
diff -u -d -r1.20 -r1.21
--- float.lisp	14 Jul 2005 19:13:47 -0000	1.20
+++ float.lisp	7 Apr 2007 20:00:24 -0000	1.21
@@ -42,9 +42,9 @@
 (macrolet ((ea-for-xf-stack (tn kind)
              `(make-ea
                :dword :base ebp-tn
-               :disp (- (* (+ (tn-offset ,tn)
-                              (ecase ,kind (:single 1) (:double 2) (:long 3)))
-                         n-word-bytes)))))
+               :disp (frame-byte-offset
+                      (+ (tn-offset ,tn)
+                       (ecase ,kind (:single 0) (:double 1) (:long 2)))))))
   (defun ea-for-sf-stack (tn)
     (ea-for-xf-stack tn :single))
   (defun ea-for-df-stack (tn)
@@ -79,13 +79,14 @@
 (macrolet ((ea-for-cxf-stack (tn kind slot &optional base)
              `(make-ea
                :dword :base ,base
-               :disp (- (* (+ (tn-offset ,tn)
-                              (* (ecase ,kind
-                                   (:single 1)
-                                   (:double 2)
-                                   (:long 3))
-                                 (ecase ,slot (:real 1) (:imag 2))))
-                         n-word-bytes)))))
+               :disp (frame-byte-offset
+                      (+ (tn-offset ,tn)
+                       -1
+                       (* (ecase ,kind
+                            (:single 1)
+                            (:double 2)
+                            (:long 3))
+                          (ecase ,slot (:real 1) (:imag 2))))))))
   (defun ea-for-csf-real-stack (tn &optional (base ebp-tn))
     (ea-for-cxf-stack tn :single :real base))
   (defun ea-for-csf-imag-stack (tn &optional (base ebp-tn))
@@ -613,6 +614,7 @@
                                  (inst fxch x)))))
                       (,stack-sc
                        (if (= (tn-offset fp) esp-offset)
+                           ;; C-call
                            (let* ((offset (* (tn-offset y) n-word-bytes))
                                   (ea (make-ea :dword :base fp :disp offset)))
                              (with-tn@...)
@@ -621,14 +623,15 @@
                                          (:double '((inst fstd ea)))
                                          #!+long-float
                                          (:long '((store-long-float ea))))))
+                           ;; Lisp stack
                            (let ((ea (make-ea
                                       :dword :base fp
-                                      :disp (- (* (+ (tn-offset y)
-                                                     ,(case format
-                                                            (:single 1)
-                                                            (:double 2)
-                                                            (:long 3)))
-                                                  n-word-bytes)))))
+                                      :disp (frame-byte-offset
+                                             (+ (tn-offset y)
+                                                ,(case format
+                                                       (:single 0)
+                                                       (:double 1)
+                                                       (:long 2)))))))
                              (with-tn@...)
                                ,@(ecase format
                                     (:single '((inst fst  ea)))
@@ -1830,12 +1833,12 @@
   (:policy :fast-safe)
   (:vop-var vop)
   (:generator 2
-    (let ((offset (1+ (tn-offset temp))))
-      (storew hi-bits ebp-tn (- offset))
-      (storew lo-bits ebp-tn (- (1+ offset)))
+    (let ((offset (tn-offset temp)))
+      (storew hi-bits ebp-tn (frame-word-offset offset))
+      (storew lo-bits ebp-tn (frame-word-offset (1+ offset)))
       (with-empty-tn@...)
         (inst fldd (make-ea :dword :base ebp-tn
-                            :disp (- (* (1+ offset) n-word-bytes))))))))
+                            :disp (frame-byte-offset (1+ offset))))))))
 
 #!+long-float
 (define-vop (make-long-float)
@@ -1850,13 +1853,13 @@
   (:policy :fast-safe)
   (:vop-var vop)
   (:generator 3
-    (let ((offset (1+ (tn-offset temp))))
-      (storew exp-bits ebp-tn (- offset))
-      (storew hi-bits ebp-tn (- (1+ offset)))
-      (storew lo-bits ebp-tn (- (+ offset 2)))
+    (let ((offset (tn-offset temp)))
+      (storew exp-bits ebp-tn (frame-word-offset offset))
+      (storew hi-bits ebp-tn (frame-word-offset (1+ offset)))
+      (storew lo-bits ebp-tn (frame-word-offset (+ offset 2)))
       (with-empty-tn@...)
         (inst fldl (make-ea :dword :base ebp-tn
-                            :disp (- (* (+ offset 2) n-word-bytes))))))))
+                            :disp (frame-byte-offset (+ offset 2))))))))
 
 (define-vop (single-float-bits)
   (:args (float :scs (single-reg descriptor-reg)
@@ -1903,12 +1906,11 @@
        (double-reg
         (with-tn@...)
           (let ((where (make-ea :dword :base ebp-tn
-                                :disp (- (* (+ 2 (tn-offset temp))
-                                            n-word-bytes)))))
+                                :disp (frame-byte-offset (1+ (tn-offset temp))))))
             (inst fstd where)))
-        (loadw hi-bits ebp-tn (- (1+ (tn-offset temp)))))
+        (loadw hi-bits ebp-tn (frame-word-offset (tn-offset temp))))
        (double-stack
-        (loadw hi-bits ebp-tn (- (1+ (tn-offset float)))))
+        (loadw hi-bits ebp-tn (frame-word-offset (tn-offset float))))
        (descriptor-reg
         (loadw hi-bits float (1+ double-float-value-slot)
                other-pointer-lowtag)))))
@@ -1928,12 +1930,11 @@
        (double-reg
         (with-tn@...)
           (let ((where (make-ea :dword :base ebp-tn
-                                :disp (- (* (+ 2 (tn-offset temp))
-                                            n-word-bytes)))))
+                                :disp (frame-byte-offset (1+ (tn-offset temp))))))
             (inst fstd where)))
-        (loadw lo-bits ebp-tn (- (+ 2 (tn-offset temp)))))
+        (loadw lo-bits ebp-tn (frame-word-offset (1+ (tn-offset temp)))))
        (double-stack
-        (loadw lo-bits ebp-tn (- (+ 2 (tn-offset float)))))
+        (loadw lo-bits ebp-tn (frame-word-offset (1+ (tn-offset float)))))
        (descriptor-reg
         (loadw lo-bits float double-float-value-slot
                other-pointer-lowtag)))))
@@ -1954,16 +1955,15 @@
        (long-reg
         (with-tn@...)
           (let ((where (make-ea :dword :base ebp-tn
-                                :disp (- (* (+ 3 (tn-offset temp))
-                                            n-word-bytes)))))
+                                :disp (frame-byte-offset (+ 2 (tn-offset temp))))))
             (store-long-float where)))
         (inst movsx exp-bits
               (make-ea :word :base ebp-tn
-                       :disp (* (- (1+ (tn-offset temp))) n-word-bytes))))
+                       :disp (frame-byte-offset (tn-offset temp)))))
        (long-stack
         (inst movsx exp-bits
               (make-ea :word :base ebp-tn
-                       :disp (* (- (1+ (tn-offset float))) n-word-bytes))))
+                       :disp (frame-byte-offset (tn-offset temp)))))
        (descriptor-reg
         (inst movsx exp-bits
               (make-ea :word :base float
@@ -1987,12 +1987,11 @@
        (long-reg
         (with-tn@...)
           (let ((where (make-ea :dword :base ebp-tn
-                                :disp (- (* (+ 3 (tn-offset temp))
-                                            n-word-bytes)))))
+                                :disp (frame-byte-offset (+ 2 (tn-offset temp))))))
             (store-long-float where)))
-        (loadw hi-bits ebp-tn (- (+ (tn-offset temp) 2))))
+        (loadw hi-bits ebp-tn (frame-word-offset (1+ (tn-offset temp)))))
        (long-stack
-        (loadw hi-bits ebp-tn (- (+ (tn-offset float) 2))))
+        (loadw hi-bits ebp-tn (frame-word-offset (1+ (tn-offset temp)))))
        (descriptor-reg
         (loadw hi-bits float (1+ long-float-value-slot)
                other-pointer-lowtag)))))
@@ -2013,12 +2012,11 @@
        (long-reg
         (with-tn@...)
           (let ((where (make-ea :dword :base ebp-tn
-                                :disp (- (* (+ 3 (tn-offset temp))
-                                            n-word-bytes)))))
+                                :disp (frame-byte-offset (+ 2 (tn-offset temp))))))
             (store-long-float where)))
-        (loadw lo-bits ebp-tn (- (+ (tn-offset temp) 3))))
+        (loadw lo-bits ebp-tn (frame-word-offset (+ (tn-offset temp) 2))))
        (long-stack
-        (loadw lo-bits ebp-tn (- (+ (tn-offset float) 3))))
+        (loadw lo-bits ebp-tn (frame-word-offset (+ (tn-offset float) 2))))
        (descriptor-reg
         (loadw lo-bits float long-float-value-slot
                other-pointer-lowtag)))))

Index: insts.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/x86/insts.lisp,v
retrieving revision 1.39
retrieving revision 1.40
diff -u -d -r1.39 -r1.40
--- insts.lisp	3 Mar 2007 00:42:02 -0000	1.39
+++ insts.lisp	7 Apr 2007 20:00:24 -0000	1.40
@@ -728,7 +728,7 @@
         (emit-mod-reg-r/m-byte segment #b11 reg (reg-tn-encoding thing)))
        (stack
         ;; Convert stack tns into an index off of EBP.
-        (let ((disp (- (* (1+ (tn-offset thing)) n-word-bytes))))
+        (let ((disp (frame-byte-offset (tn-offset thing))))
           (cond ((<= -128 disp 127)
                  (emit-mod-reg-r/m-byte segment #b01 reg #b101)
                  (emit-byte segment disp))

Index: move.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/x86/move.lisp,v
retrieving revision 1.13
retrieving revision 1.14
diff -u -d -r1.13 -r1.14
--- move.lisp	20 Jul 2006 03:26:13 -0000	1.13
+++ move.lisp	7 Apr 2007 20:00:25 -0000	1.14
@@ -127,36 +127,24 @@
                                    character-widetag)))))
          (move y x)))
       ((control-stack)
-       (if (sc-is x immediate)
-           (let ((val (tn-value x)))
-             (if (= (tn-offset fp) esp-offset)
-                 ;; C-call
-                 (etypecase val
-                   (integer
-                    (storew (fixnumize val) fp (tn-offset y)))
-                   (symbol
-                    (storew (+ nil-value (static-symbol-offset val))
-                            fp (tn-offset y)))
-                   (character
-                    (storew (logior (ash (char-code val) n-widetag-bits)
-                                    character-widetag)
-                            fp (tn-offset y))))
-               ;; Lisp stack
+       (let ((frame-offset (if (= (tn-offset fp) esp-offset)
+                               ;; C-call
+                               (tn-offset y)
+                               ;; Lisp stack
+                               (frame-word-offset (tn-offset y)))))
+         (if (sc-is x immediate)
+             (let ((val (tn-value x)))
                (etypecase val
                  (integer
-                  (storew (fixnumize val) fp (- (1+ (tn-offset y)))))
+                  (storew (fixnumize val) fp frame-offset))
                  (symbol
                   (storew (+ nil-value (static-symbol-offset val))
-                          fp (- (1+ (tn-offset y)))))
+                          fp frame-offset))
                  (character
                   (storew (logior (ash (char-code val) n-widetag-bits)
                                   character-widetag)
-                          fp (- (1+ (tn-offset y))))))))
-         (if (= (tn-offset fp) esp-offset)
-             ;; C-call
-             (storew x fp (tn-offset y))
-           ;; Lisp stack
-           (storew x fp (- (1+ (tn-offset y))))))))))
+                          fp frame-offset))))
+             (storew x fp frame-offset)))))))
 
 (define-move-vop move-arg :move-arg
   (any-reg descriptor-reg)
@@ -415,7 +403,7 @@
       ((signed-stack unsigned-stack)
        (if (= (tn-offset fp) esp-offset)
            (storew x fp (tn-offset y))  ; c-call
-           (storew x fp (- (1+ (tn-offset y)))))))))
+           (storew x fp (frame-word-offset (tn-offset y))))))))
 (define-move-vop move-word-arg :move-arg
   (descriptor-reg any-reg signed-reg unsigned-reg) (signed-reg unsigned-reg))
 

Index: nlx.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/x86/nlx.lisp,v
retrieving revision 1.20
retrieving revision 1.21
diff -u -d -r1.20 -r1.21
--- nlx.lisp	13 Jan 2007 21:05:34 -0000	1.20
+++ nlx.lisp	7 Apr 2007 20:00:25 -0000	1.21
@@ -24,7 +24,7 @@
 (defun catch-block-ea (tn)
   (aver (sc-is tn catch-block))
   (make-ea :dword :base ebp-tn
-           :disp (- (* (+ (tn-offset tn) catch-block-size) n-word-bytes))))
+           :disp (frame-byte-offset (+ -1 (tn-offset tn) catch-block-size))))
 
 
 ;;;; Save and restore dynamic environment.
@@ -189,9 +189,9 @@
                  (inst jmp :le default-lab)
                  (sc-case tn
                    ((descriptor-reg any-reg)
-                    (loadw tn start (- (1+ i))))
+                    (loadw tn start (frame-word-offset i)))
                    ((control-stack)
-                    (loadw move-temp start (- (1+ i)))
+                    (loadw move-temp start (frame-word-offset i))
                     (inst mov tn move-temp)))))
              (let ((defaulting-done (gen-label)))
                (emit-label defaulting-done)

Index: sap.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/x86/sap.lisp,v
retrieving revision 1.11
retrieving revision 1.12
diff -u -d -r1.11 -r1.12
--- sap.lisp	27 Jan 2007 03:45:50 -0000	1.11
+++ sap.lisp	7 Apr 2007 20:00:25 -0000	1.12
@@ -65,7 +65,7 @@
       (sap-stack
        (if (= (tn-offset fp) esp-offset)
            (storew x fp (tn-offset y))  ; c-call
-           (storew x fp (- (1+ (tn-offset y)))))))))
+           (storew x fp (frame-word-offset (tn-offset y))))))))
 (define-move-vop move-sap-arg :move-arg
   (descriptor-reg sap-reg) (sap-reg))
 

Index: vm.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/x86/vm.lisp,v
retrieving revision 1.25
retrieving revision 1.26
diff -u -d -r1.25 -r1.26
--- vm.lisp	13 Jan 2007 21:05:34 -0000	1.25
+++ vm.lisp	7 Apr 2007 20:00:25 -0000	1.26
@@ -408,7 +408,14 @@
 ;;; offsets of special stack frame locations
 (def!constant ocfp-save-offset 0)
 (def!constant return-pc-save-offset 1)
-(def!constant code-save-offset 2)
+
+(declaim (inline frame-word-offset))
+(defun frame-word-offset (index)
+  (- (1+ index)))
+
+(declaim (inline frame-byte-offset))
+(defun frame-byte-offset (index)
+  (* (frame-word-offset index) n-word-bytes))
 
 ;;; FIXME: This is a bad comment (changed since when?) and there are others
 ;;; like it in this file. It'd be nice to clarify them. Failing that deleting

Update of /cvsroot/sbcl/sbcl
In directory sc8-pr-cvs8.sourceforge.net:/tmp/cvs-serv23177

Modified Files:
	version.lisp-expr 
Log Message:
1.0.2.42: x86 backend cleanups
  * Defined frame-byte-offset and frame-word-offset for calculating 
    offsets within a stack frame.
  * Modified most direct references to stack data to use 
    frame-byte-offset and frame-word-offset instead of an inline 
    calculation.


Index: version.lisp-expr
===================================================================
RCS file: /cvsroot/sbcl/sbcl/version.lisp-expr,v
retrieving revision 1.3296
retrieving revision 1.3297
diff -u -d -r1.3296 -r1.3297
--- version.lisp-expr	7 Apr 2007 18:27:05 -0000	1.3296
+++ version.lisp-expr	7 Apr 2007 20:00:24 -0000	1.3297
@@ -17,4 +17,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"1.0.4.41"
+"1.0.4.42"

Update of /cvsroot/sbcl/sbcl/src/code
In directory sc8-pr-cvs8.sourceforge.net:/tmp/cvs-serv14933/src/code

Modified Files:
	defstruct.lisp late-extensions.lisp 
Log Message:
1.0.4.41: unbreak threaded build
 * move the newflangled DEFINE-STRUCTURE-SLOT-FOOs later in the
   build, so as to have SB!VM:INSTANCE-SLOTS-OFFSET available.

 * STRUCTURE-SLOT-INDEX unused -- oops in cherrypicking from a different
   tree.


Index: defstruct.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/defstruct.lisp,v
retrieving revision 1.85
retrieving revision 1.86
diff -u -d -r1.85 -r1.86
--- defstruct.lisp	7 Apr 2007 13:58:57 -0000	1.85
+++ defstruct.lisp	7 Apr 2007 18:27:06 -0000	1.86
@@ -1733,49 +1733,4 @@
         (when errorp
           (error "No DEFSTRUCT-DESCRIPTION for ~S." name)))))
 
-(defun structure-slot-index (type slot-name &optional (errorp t))
-  (let ((slotd (find slot-name
-                     (dd-slots (find-defstruct-description type))
-                     :key #'dsd-name)))
-    (if slotd
-        (dsd-index slotd)
-        (when errorp
-          (error "No slot named ~S in ~S." slot-name type)))))
-
-;;; Used internally, but it would be nice to provide something
-;;; like this for users as well.
-#!+sb-thread
-(defmacro define-structure-slot-compare-and-exchange
-    (name &key structure slot)
-  (let* ((dd (find-defstruct-description structure t))
-         (slotd (when dd (find slot (dd-slots dd) :key #'dsd-name)))
-         (type (when slotd (dsd-type slotd)))
-         (index (when slotd (dsd-index slotd))))
-    (unless index
-      (error "Slot ~S not found in ~S." slot structure))
-    `(progn
-       (declaim (inline ,name))
-       (defun ,name (instance old new)
-         (declare (type ,structure instance)
-                  (type ,type new))
-         (sb!vm::%instance-set-conditional instance ,index old new)))))
-
-;;; Ditto
-#!+sb-thread
-(defmacro define-structure-slot-addressor (name &key structure slot)
-  (let* ((dd (find-defstruct-description structure t))
-         (slotd (when dd (find slot (dd-slots dd) :key #'dsd-name)))
-         (index (when slotd (dsd-index slotd))))
-    (unless index
-      (error "Slot ~S not found in ~S." slot structure))
-    `(progn
-       (declaim (inline ,name))
-       (defun ,name (instance)
-         (declare (type ,structure instance) (optimize speed))
-         (sb!ext:truly-the
-          sb!vm:word
-          (+ (sb!kernel:get-lisp-obj-address instance)
-             (- (* ,(+ sb!vm:instance-slots-offset index) sb!vm:n-word-bytes)
-                sb!vm:instance-pointer-lowtag)))))))
-
 (/show0 "code/defstruct.lisp end of file")

Index: late-extensions.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/late-extensions.lisp,v
retrieving revision 1.11
retrieving revision 1.12
diff -u -d -r1.11 -r1.12
--- late-extensions.lisp	22 Aug 2006 15:48:56 -0000	1.11
+++ late-extensions.lisp	7 Apr 2007 18:27:06 -0000	1.12
@@ -45,3 +45,40 @@
                                (write-string (unprintable-object-string x) s))))
             (:copier nil))
   string)
+
+;;; Used internally, but it would be nice to provide something
+;;; like this for users as well.
+#!+sb-thread
+(defmacro define-structure-slot-compare-and-exchange
+    (name &key structure slot)
+  (let* ((dd (find-defstruct-description structure t))
+         (slotd (when dd (find slot (dd-slots dd) :key #'dsd-name)))
+         (type (when slotd (dsd-type slotd)))
+         (index (when slotd (dsd-index slotd))))
+    (unless index
+      (error "Slot ~S not found in ~S." slot structure))
+    `(progn
+       (declaim (inline ,name))
+       (defun ,name (instance old new)
+         (declare (type ,structure instance)
+                  (type ,type new))
+         (sb!vm::%instance-set-conditional instance ,index old new)))))
+
+;;; Ditto
+#!+sb-thread
+(defmacro define-structure-slot-addressor (name &key structure slot)
+  (let* ((dd (find-defstruct-description structure t))
+         (slotd (when dd (find slot (dd-slots dd) :key #'dsd-name)))
+         (index (when slotd (dsd-index slotd))))
+    (unless index
+      (error "Slot ~S not found in ~S." slot structure))
+    `(progn
+       (declaim (inline ,name))
+       (defun ,name (instance)
+         (declare (type ,structure instance) (optimize speed))
+         (sb!ext:truly-the
+          sb!vm:word
+          (+ (sb!kernel:get-lisp-obj-address instance)
+             (- (* ,(+ sb!vm:instance-slots-offset index) sb!vm:n-word-bytes)
+                sb!vm:instance-pointer-lowtag)))))))
+

Update of /cvsroot/sbcl/sbcl
In directory sc8-pr-cvs8.sourceforge.net:/tmp/cvs-serv14933

Modified Files:
	version.lisp-expr 
Log Message:
1.0.4.41: unbreak threaded build
 * move the newflangled DEFINE-STRUCTURE-SLOT-FOOs later in the
   build, so as to have SB!VM:INSTANCE-SLOTS-OFFSET available.

 * STRUCTURE-SLOT-INDEX unused -- oops in cherrypicking from a different
   tree.


Index: version.lisp-expr
===================================================================
RCS file: /cvsroot/sbcl/sbcl/version.lisp-expr,v
retrieving revision 1.3295
retrieving revision 1.3296
diff -u -d -r1.3295 -r1.3296
--- version.lisp-expr	7 Apr 2007 17:42:07 -0000	1.3295
+++ version.lisp-expr	7 Apr 2007 18:27:05 -0000	1.3296
@@ -17,4 +17,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"1.0.4.40"
+"1.0.4.41"

Update of /cvsroot/sbcl/sbcl
In directory sc8-pr-cvs8.sourceforge.net:/tmp/cvs-serv28744

Modified Files:
	BUGS NEWS version.lisp-expr 
Log Message:
1.0.4.40: small fixes
 
 * / is not flushable, but unsafely-flushable. Reported by Marco
   Monteiro, patch by Kevin Reid. Test-case added to compiler.pure.lisp.

 * #include "globals.h" for funcall.c, should unbreak the build for non-x86oids.

 * s/(AND (UNSIGNED-BYTE FIXNUM))/(AND UNSIGNED-BYTE FIXNUM)/ in combin.lisp,
   discovered by James Anderson.


Index: BUGS
===================================================================
RCS file: /cvsroot/sbcl/sbcl/BUGS,v
retrieving revision 1.512
retrieving revision 1.513
diff -u -d -r1.512 -r1.513
--- BUGS	31 Mar 2007 10:51:20 -0000	1.512
+++ BUGS	7 Apr 2007 17:42:05 -0000	1.513
@@ -1792,3 +1792,12 @@
   Test :NAN-COMPARISONS in float.pure.lisp fails on x86-64, and has been
   disabled on those platforms. Since x86 does not exhibit any problems
   the problem is probably with the new FP implementation.
+
+412: deletion of global variable references in safe code
+  The following returns 1 instead of signalling an error.
+   (funcall (compile nil
+                     '(lambda ()
+                        (declare (optimize (safety 3)))
+                        #:unbound
+                        42)))
+  Reported by Marco Monteiro on sbcl-devel.

Index: NEWS
===================================================================
RCS file: /cvsroot/sbcl/sbcl/NEWS,v
retrieving revision 1.1163
retrieving revision 1.1164
diff -u -d -r1.1163 -r1.1164
--- NEWS	7 Apr 2007 01:13:23 -0000	1.1163
+++ NEWS	7 Apr 2007 17:42:06 -0000	1.1164
@@ -12,6 +12,8 @@
     in multithreaded application code.
   * optimization: GET-INTERNAL-REAL-TIME has been optimized on POSIX
     platforms. (thanks to James Anderson for the optimization hint)
+  * bug fix: / with an unused value was being deleted in safe code.
+    (thanks to Marco Monteiro and Kevin Reid)
   * bug fix: number of characters that can be written onto a single
     line in a file is unlimited.
   * bug fix: some GC deadlocks caused by asynchronous interrupts have

Index: version.lisp-expr
===================================================================
RCS file: /cvsroot/sbcl/sbcl/version.lisp-expr,v
retrieving revision 1.3294
retrieving revision 1.3295
diff -u -d -r1.3294 -r1.3295
--- version.lisp-expr	7 Apr 2007 13:58:57 -0000	1.3294
+++ version.lisp-expr	7 Apr 2007 17:42:07 -0000	1.3295
@@ -17,4 +17,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"1.0.4.39"
+"1.0.4.40"

Update of /cvsroot/sbcl/sbcl/src/runtime
In directory sc8-pr-cvs8.sourceforge.net:/tmp/cvs-serv28744/src/runtime

Modified Files:
	funcall.c 
Log Message:
1.0.4.40: small fixes
 
 * / is not flushable, but unsafely-flushable. Reported by Marco
   Monteiro, patch by Kevin Reid. Test-case added to compiler.pure.lisp.

 * #include "globals.h" for funcall.c, should unbreak the build for non-x86oids.

 * s/(AND (UNSIGNED-BYTE FIXNUM))/(AND UNSIGNED-BYTE FIXNUM)/ in combin.lisp,
   discovered by James Anderson.


Index: funcall.c
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/runtime/funcall.c,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -d -r1.1 -r1.2
--- funcall.c	4 Apr 2007 13:11:18 -0000	1.1
+++ funcall.c	7 Apr 2007 17:42:11 -0000	1.2
@@ -17,6 +17,7 @@
 
 #include "sbcl.h"
 #include "runtime.h"
+#include "globals.h"
 
 /* This is implemented in assembly language and called from C: */
 extern lispobj call_into_lisp(lispobj fun, lispobj *args, int nargs);

Update of /cvsroot/sbcl/sbcl/src/compiler
In directory sc8-pr-cvs8.sourceforge.net:/tmp/cvs-serv28744/src/compiler

Modified Files:
	fndb.lisp 
Log Message:
1.0.4.40: small fixes
 
 * / is not flushable, but unsafely-flushable. Reported by Marco
   Monteiro, patch by Kevin Reid. Test-case added to compiler.pure.lisp.

 * #include "globals.h" for funcall.c, should unbreak the build for non-x86oids.

 * s/(AND (UNSIGNED-BYTE FIXNUM))/(AND UNSIGNED-BYTE FIXNUM)/ in combin.lisp,
   discovered by James Anderson.


Index: fndb.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/fndb.lisp,v
retrieving revision 1.128
retrieving revision 1.129
diff -u -d -r1.128 -r1.129
--- fndb.lisp	28 Mar 2007 17:59:19 -0000	1.128
+++ fndb.lisp	7 Apr 2007 17:42:09 -0000	1.129
@@ -231,7 +231,7 @@
 (defknown * (&rest number) number
   (movable foldable flushable explicit-check))
 (defknown / (number &rest number) number
-  (movable foldable flushable explicit-check))
+  (movable foldable unsafely-flushable explicit-check))
 (defknown (1+ 1-) (number) number
   (movable foldable flushable explicit-check))

Update of /cvsroot/sbcl/sbcl/src/pcl
In directory sc8-pr-cvs8.sourceforge.net:/tmp/cvs-serv28744/src/pcl

Modified Files:
	combin.lisp 
Log Message:
1.0.4.40: small fixes
 
 * / is not flushable, but unsafely-flushable. Reported by Marco
   Monteiro, patch by Kevin Reid. Test-case added to compiler.pure.lisp.

 * #include "globals.h" for funcall.c, should unbreak the build for non-x86oids.

 * s/(AND (UNSIGNED-BYTE FIXNUM))/(AND UNSIGNED-BYTE FIXNUM)/ in combin.lisp,
   discovered by James Anderson.


Index: combin.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/pcl/combin.lisp,v
retrieving revision 1.30
retrieving revision 1.31
diff -u -d -r1.30 -r1.31
--- combin.lisp	7 Dec 2006 12:51:27 -0000	1.30
+++ combin.lisp	7 Apr 2007 17:42:11 -0000	1.31
@@ -248,7 +248,7 @@
                              `(list* ,@required
                                      (sb-c::%listify-rest-args
                                       .dfun-more-context.
-                                      (the (and (unsigned-byte fixnum))
+                                      (the (and unsigned-byte fixnum)
                                         .dfun-more-count.)))
                              `(list ,@required))))
            `(lambda ,ll

Update of /cvsroot/sbcl/sbcl/tests
In directory sc8-pr-cvs8.sourceforge.net:/tmp/cvs-serv28744/tests

Modified Files:
	compiler.pure.lisp 
Log Message:
1.0.4.40: small fixes
 
 * / is not flushable, but unsafely-flushable. Reported by Marco
   Monteiro, patch by Kevin Reid. Test-case added to compiler.pure.lisp.

 * #include "globals.h" for funcall.c, should unbreak the build for non-x86oids.

 * s/(AND (UNSIGNED-BYTE FIXNUM))/(AND UNSIGNED-BYTE FIXNUM)/ in combin.lisp,
   discovered by James Anderson.


Index: compiler.pure.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/tests/compiler.pure.lisp,v
retrieving revision 1.160
retrieving revision 1.161
diff -u -d -r1.160 -r1.161
--- compiler.pure.lisp	31 Mar 2007 10:51:22 -0000	1.160
+++ compiler.pure.lisp	7 Apr 2007 17:42:11 -0000	1.161
@@ -2201,3 +2201,17 @@
                                    y)
                                  (integer-length x)))))
             warned-p))
+
+;; Dead / in safe code
+(with-test (:name :safe-dead-/)
+  (assert (eq :error
+              (handler-case
+                  (funcall (compile nil
+                                    '(lambda (x y)
+                                      (declare (optimize (safety 3)))
+                                      (/ x y)
+                                      (+ x y)))
+                           1
+                           0)
+                (division-by-zero ()
+                  :error)))))

Update of /cvsroot/sbcl/sbcl/src/code
In directory sc8-pr-cvs8.sourceforge.net:/tmp/cvs-serv3345/src/code

Modified Files:
	defstruct.lisp target-defstruct.lisp target-thread.lisp 
Log Message:
1.0.4.39: get rid of hardcoded mutex and spinlock slot indexes

 * DEFINE-STRUCTURE-SLOT-COMPARE-AND-EXCHANGE can be used to define
   nice wrappers for %INSTANCE-SLOT-CONDITIONAL using just the
   structure and slot name.

   Note to self: it would probably make sense to give something along
   these lines for users to use as well, so that they can implement
   lockless algorithms in lisp.

 * DEFINE-STRUCTURE-SLOT-ADDRESSOR does the same for getting the
   slot address.

 * SB-PCL::GET-STRUCTURE-DD moved to host and renamed
   SB-KERNEL:FIND-DEFSTRUCT-DESCRIPTION.

 * SB-THREAD now uses SB-KERNEL.

 (threads.impure.lisp currently fail, but not due to this)


Index: defstruct.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/defstruct.lisp,v
retrieving revision 1.84
retrieving revision 1.85
diff -u -d -r1.84 -r1.85
--- defstruct.lisp	20 Sep 2006 18:18:19 -0000	1.84
+++ defstruct.lisp	7 Apr 2007 13:58:57 -0000	1.85
@@ -1725,4 +1725,57 @@
          (inherits (inherits-for-structure dd)))
     (%compiler-defstruct dd inherits)))
 
+;;; finding these beasts
+(defun find-defstruct-description (name &optional (errorp t))
+  (let ((info (layout-info (classoid-layout (find-classoid name errorp)))))
+    (if (defstruct-description-p info)
+        info
+        (when errorp
+          (error "No DEFSTRUCT-DESCRIPTION for ~S." name)))))
+
+(defun structure-slot-index (type slot-name &optional (errorp t))
+  (let ((slotd (find slot-name
+                     (dd-slots (find-defstruct-description type))
+                     :key #'dsd-name)))
+    (if slotd
+        (dsd-index slotd)
+        (when errorp
+          (error "No slot named ~S in ~S." slot-name type)))))
+
+;;; Used internally, but it would be nice to provide something
+;;; like this for users as well.
+#!+sb-thread
+(defmacro define-structure-slot-compare-and-exchange
+    (name &key structure slot)
+  (let* ((dd (find-defstruct-description structure t))
+         (slotd (when dd (find slot (dd-slots dd) :key #'dsd-name)))
+         (type (when slotd (dsd-type slotd)))
+         (index (when slotd (dsd-index slotd))))
+    (unless index
+      (error "Slot ~S not found in ~S." slot structure))
+    `(progn
+       (declaim (inline ,name))
+       (defun ,name (instance old new)
+         (declare (type ,structure instance)
+                  (type ,type new))
+         (sb!vm::%instance-set-conditional instance ,index old new)))))
+
+;;; Ditto
+#!+sb-thread
+(defmacro define-structure-slot-addressor (name &key structure slot)
+  (let* ((dd (find-defstruct-description structure t))
+         (slotd (when dd (find slot (dd-slots dd) :key #'dsd-name)))
+         (index (when slotd (dsd-index slotd))))
+    (unless index
+      (error "Slot ~S not found in ~S." slot structure))
+    `(progn
+       (declaim (inline ,name))
+       (defun ,name (instance)
+         (declare (type ,structure instance) (optimize speed))
+         (sb!ext:truly-the
+          sb!vm:word
+          (+ (sb!kernel:get-lisp-obj-address instance)
+             (- (* ,(+ sb!vm:instance-slots-offset index) sb!vm:n-word-bytes)
+                sb!vm:instance-pointer-lowtag)))))))
+
 (/show0 "code/defstruct.lisp end of file")

Index: target-defstruct.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/target-defstruct.lisp,v
retrieving revision 1.37
retrieving revision 1.38
diff -u -d -r1.37 -r1.38
--- target-defstruct.lisp	6 Oct 2006 10:54:13 -0000	1.37
+++ target-defstruct.lisp	7 Apr 2007 13:58:57 -0000	1.38
@@ -601,5 +601,6 @@
            :datum x
            :expected-type (classoid-name (layout-classoid layout))))
   (values))
+
 
 (/show0 "target-defstruct.lisp end of file")

Index: target-thread.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/target-thread.lisp,v
retrieving revision 1.67
retrieving revision 1.68
diff -u -d -r1.67 -r1.68
--- target-thread.lisp	6 Apr 2007 21:48:30 -0000	1.67
+++ target-thread.lisp	7 Apr 2007 13:58:57 -0000	1.68
@@ -19,7 +19,7 @@
 ;;; set the doc here because in early-thread FDOCUMENTATION is not
 ;;; available, yet
 #!+sb-doc
-(setf (sb!kernel:fdocumentation '*current-thread* 'variable)
+(setf (fdocumentation '*current-thread* 'variable)
       "Bound in each thread to the thread itself.")
 
 (defstruct (thread (:constructor %make-thread))
@@ -35,7 +35,7 @@
   (result-lock (make-mutex :name "thread result lock")))
 
 #!+sb-doc
-(setf (sb!kernel:fdocumentation 'thread-name 'function)
+(setf (fdocumentation 'thread-name 'function)
       "The name of the thread. Setfable.")
 
 (def!method print-object ((thread thread) stream)
@@ -143,7 +143,7 @@
     (defmacro with-lutex-address ((name lutex) &body body)
       `(let ((,name ,lutex))
          (with-pinned-objects (,name)
-           (let ((,name (sb!kernel:get-lisp-obj-address ,name)))
+           (let ((,name (get-lisp-obj-address ,name)))
              ,@body))))
 
     (defun make-lutex ()
@@ -182,31 +182,33 @@
   (sb!vm::current-thread-offset-sap n))
 
 ;;;; spinlocks
+#!+sb-thread
+(define-structure-slot-compare-and-exchange
+    compare-and-exchange-spinlock-value
+    :structure spinlock
+    :slot value)
 
 (declaim (inline get-spinlock release-spinlock))
 
-;;; The bare 2 here and below are offsets of the slots in the struct.
-;;; There ought to be some better way to get these numbers
 (defun get-spinlock (spinlock)
   (declare (optimize (speed 3) (safety 0))
            #!-sb-thread
-           (ignore spinlock new-value))
+           (ignore spinlock))
   ;; %instance-set-conditional can test for 0 (which is a fixnum) and
   ;; store any value
   #!+sb-thread
-  (loop until
-        (eql (sb!vm::%instance-set-conditional spinlock 2 0 1) 0))
+  (compare-and-exchange-spinlock-value spinlock 0 1)
   t)
 
 (defun release-spinlock (spinlock)
   (declare (optimize (speed 3) (safety 0))
            #!-sb-thread (ignore spinlock))
   ;; %instance-set-conditional cannot compare arbitrary objects
-  ;; meaningfully, so
-  ;; (sb!vm::%instance-set-conditional spinlock 2 our-value 0)
+  ;; meaningfully, so (compare-and-exchange-spinlock-value our-value 0)
   ;; does not work for bignum thread ids.
   #!+sb-thread
-  (sb!vm::%instance-set spinlock 2 0))
+  (setf (spinlock-value spinlock) 0)
+  nil)
 
 (defmacro with-spinlock ((spinlock) &body body)
   (sb!int:with-unique-names (lock got-it)
@@ -222,28 +224,28 @@
 ;;;; mutexes
 
 #!+sb-doc
-(setf (sb!kernel:fdocumentation 'make-mutex 'function)
+(setf (fdocumentation 'make-mutex 'function)
       "Create a mutex."
-      (sb!kernel:fdocumentation 'mutex-name 'function)
+      (fdocumentation 'mutex-name 'function)
       "The name of the mutex. Setfable."
-      (sb!kernel:fdocumentation 'mutex-value 'function)
+      (fdocumentation 'mutex-value 'function)
       "The value of the mutex. NIL if the mutex is free. Setfable.")
 
 #!+(and sb-thread (not sb-lutex))
 (progn
-  (declaim (inline mutex-value-address))
-  (defun mutex-value-address (mutex)
-    (declare (optimize (speed 3)))
-    (sb!ext:truly-the
-     sb!vm:word
-     (+ (sb!kernel:get-lisp-obj-address mutex)
-        (- (* 3 sb!vm:n-word-bytes) sb!vm:instance-pointer-lowtag)))))
+  (define-structure-slot-addressor mutex-value-address
+      :structure mutex
+      :slot value)
+  (define-structure-slot-compare-and-exchange
+      compare-and-exchange-mutex-value
+      :structure mutex
+      :slot value))
 
 (defun get-mutex (mutex &optional (new-value *current-thread*) (wait-p t))
   #!+sb-doc
   "Acquire MUTEX, setting it to NEW-VALUE or some suitable default
-value if NIL.  If WAIT-P is non-NIL and the mutex is in use, sleep
-until it is available"
+value if NIL. If WAIT-P is non-NIL and the mutex is in use, sleep
+until it is available."
   (declare (type mutex mutex) (optimize (speed 3)))
   (/show0 "Entering GET-MUTEX")
   (unless new-value
@@ -273,13 +275,13 @@
     (let (old)
       (loop
          (unless
-             (setf old (sb!vm::%instance-set-conditional mutex 2 nil
-                                                         new-value))
+             (setf old
+                   (compare-and-exchange-mutex-value mutex nil new-value))
            (return t))
          (unless wait-p (return nil))
          (with-pinned-objects (mutex old)
            (futex-wait (mutex-value-address mutex)
-                       (sb!kernel:get-lisp-obj-address old)))))))
+                       (get-lisp-obj-address old)))))))
 
 (defun release-mutex (mutex)
   #!+sb-doc
@@ -313,18 +315,13 @@
   (%make-waitqueue :name name))
 
 #!+sb-doc
-(setf (sb!kernel:fdocumentation 'waitqueue-name 'function)
+(setf (fdocumentation 'waitqueue-name 'function)
       "The name of the waitqueue. Setfable.")
 
 #!+(and sb-thread (not sb-lutex))
-(progn
-  (declaim (inline waitqueue-data-address))
-  (defun waitqueue-data-address (waitqueue)
-    (declare (optimize (speed 3)))
-    (sb!ext:truly-the
-     sb!vm:word
-     (+ (sb!kernel:get-lisp-obj-address waitqueue)
-        (- (* 3 sb!vm:n-word-bytes) sb!vm:instance-pointer-lowtag)))))
+(define-structure-slot-addressor waitqueue-data-address
+    :structure waitqueue
+    :slot data)
 
 (defun condition-wait (queue mutex)
   #!+sb-doc
@@ -358,7 +355,7 @@
            ;; Ergo, no lost wakeup
            (with-pinned-objects (queue me)
              (futex-wait (waitqueue-data-address queue)
-                         (sb!kernel:get-lisp-obj-address me))))
+                         (get-lisp-obj-address me))))
       ;; If we are interrupted while waiting, we should do these things
       ;; before returning.  Ideally, in the case of an unhandled signal,
       ;; we should do them before entering the debugger, but this is
@@ -414,7 +411,7 @@
   "Create a semaphore with the supplied COUNT."
   (%make-semaphore :name name :count count))
 
-(setf (sb!kernel:fdocumentation 'semaphore-name 'function)
+(setf (fdocumentation 'semaphore-name 'function)
       "The name of the semaphore. Setfable.")
 
 (defun wait-on-semaphore (sem)
@@ -633,9 +630,9 @@
             ;; least accessible to users to secure their own libraries.
             ;;   --njf, 2006-07-15
             (let ((*current-thread* thread)
-                  (sb!kernel::*restart-clusters* nil)
-                  (sb!kernel::*handler-clusters* nil)
-                  (sb!kernel::*condition-restarts* nil)
+                  (*restart-clusters* nil)
+                  (*handler-clusters* nil)
+                  (*condition-restarts* nil)
                   (sb!impl::*step-out* nil)
                   ;; internal printer variables
                   (sb!impl::*previous-case* nil)
@@ -679,7 +676,7 @@
     (with-pinned-objects (initial-function)
       (let ((os-thread
              (%create-thread
-              (sb!kernel:get-lisp-obj-address initial-function))))
+              (get-lisp-obj-address initial-function))))
         (when (zerop os-thread)
           (error "Can't create a new thread"))
         (wait-on-semaphore setup-sem)
@@ -695,7 +692,7 @@
                      (join-thread-error-thread c)))))
 
 #!+sb-doc
-(setf (sb!kernel:fdocumentation 'join-thread-error-thread 'function)
+(setf (fdocumentation 'join-thread-error-thread 'function)
       "The thread that we failed to join.")
 
 (defun join-thread (thread &key (default nil defaultp))
@@ -725,7 +722,7 @@
                      (interrupt-thread-error-thread c)))))
 
 #!+sb-doc
-(setf (sb!kernel:fdocumentation 'interrupt-thread-error-thread 'function)
+(setf (fdocumentation 'interrupt-thread-error-thread 'function)
       "The thread that was not interrupted.")
 
 (defmacro with-interruptions-lock ((thread) &body body)
@@ -805,7 +802,7 @@
                                (* sb!vm:n-word-bytes index))))
     (if (eql tl-val sb!vm::no-tls-value-marker-widetag)
         (sb!vm::symbol-global-value symbol)
-        (sb!kernel:make-lisp-obj tl-val))))
+        (make-lisp-obj tl-val))))
 
 (defun sb!vm::locked-symbol-global-value-add (symbol-name delta)
   (sb!vm::locked-symbol-global-value-add symbol-name delta))
@@ -813,11 +810,11 @@
 ;;; Stepping
 
 (defun thread-stepping ()
-  (sb!kernel:make-lisp-obj
+  (make-lisp-obj
    (sap-ref-word (current-thread-sap)
                  (* sb!vm::thread-stepping-slot sb!vm:n-word-bytes))))
 
 (defun (setf thread-stepping) (value)
   (setf (sap-ref-word (current-thread-sap)
                       (* sb!vm::thread-stepping-slot sb!vm:n-word-bytes))
-        (sb!kernel:get-lisp-obj-address value)))
+        (get-lisp-obj-address value)))

Update of /cvsroot/sbcl/sbcl/src/pcl
In directory sc8-pr-cvs8.sourceforge.net:/tmp/cvs-serv3345/src/pcl

Modified Files:
	env.lisp low.lisp std-class.lisp 
Log Message:
1.0.4.39: get rid of hardcoded mutex and spinlock slot indexes

 * DEFINE-STRUCTURE-SLOT-COMPARE-AND-EXCHANGE can be used to define
   nice wrappers for %INSTANCE-SLOT-CONDITIONAL using just the
   structure and slot name.

   Note to self: it would probably make sense to give something along
   these lines for users to use as well, so that they can implement
   lockless algorithms in lisp.

 * DEFINE-STRUCTURE-SLOT-ADDRESSOR does the same for getting the
   slot address.

 * SB-PCL::GET-STRUCTURE-DD moved to host and renamed
   SB-KERNEL:FIND-DEFSTRUCT-DESCRIPTION.

 * SB-THREAD now uses SB-KERNEL.

 (threads.impure.lisp currently fail, but not due to this)


Index: env.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/pcl/env.lisp,v
retrieving revision 1.14
retrieving revision 1.15
diff -u -d -r1.14 -r1.15
--- env.lisp	16 Apr 2006 07:10:20 -0000	1.14
+++ env.lisp	7 Apr 2007 13:58:57 -0000	1.15
@@ -170,7 +170,9 @@
                 (let ((value (slot-value-using-class class object slot)))
                   (if (typep object 'structure-object)
                       ;; low-level but less noisy initializer form
-                      (let* ((dd (get-structure-dd (class-name class)))
+                      ;; FIXME: why not go class->layout->info == dd?
+                      (let* ((dd (find-defstruct-description
+                                  (class-name class)))
                              (dsd (find slot-name (dd-slots dd)
                                         :key #'dsd-name)))
                         (inits `(,(slot-setter-lambda-form dd dsd)

Index: low.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/pcl/low.lisp,v
retrieving revision 1.45
retrieving revision 1.46
diff -u -d -r1.45 -r1.46
--- low.lisp	7 Dec 2006 12:51:28 -0000	1.45
+++ low.lisp	7 Apr 2007 13:58:57 -0000	1.46
@@ -305,11 +305,8 @@
 
 ;;; The definition of STRUCTURE-TYPE-P was moved to early-low.lisp.
 
-(defun get-structure-dd (type)
-  (layout-info (classoid-layout (find-classoid type))))
-
 (defun structure-type-included-type-name (type)
-  (let ((include (dd-include (get-structure-dd type))))
+  (let ((include (dd-include (find-defstruct-description type))))
     (if (consp include)
         (car include)
         include)))
@@ -317,8 +314,8 @@
 (defun structure-type-slot-description-list (type)
   (nthcdr (length (let ((include (structure-type-included-type-name type)))
                     (and include
-                         (dd-slots (get-structure-dd include)))))
-          (dd-slots (get-structure-dd type))))
+                         (dd-slots (find-defstruct-description include)))))
+          (dd-slots (find-defstruct-description type))))
 
 (defun structure-slotd-name (slotd)
   (dsd-name slotd))
@@ -331,7 +328,7 @@
 
 (defun structure-slotd-writer-function (type slotd)
   (if (dsd-read-only slotd)
-      (let ((dd (get-structure-dd type)))
+      (let ((dd (find-defstruct-description type)))
         (coerce (slot-setter-lambda-form dd slotd) 'function))
       (fdefinition `(setf ,(dsd-accessor-name slotd)))))
 

Index: std-class.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/pcl/std-class.lisp,v
retrieving revision 1.107
retrieving revision 1.108
diff -u -d -r1.107 -r1.108
--- std-class.lisp	4 Feb 2007 16:26:50 -0000	1.107
+++ std-class.lisp	7 Apr 2007 13:58:57 -0000	1.108
@@ -617,7 +617,8 @@
     (values defstruct-form constructor reader-names writer-names)))
 
 (defun make-defstruct-allocation-function (class)
-  (let ((dd (get-structure-dd (class-name class))))
+  ;; FIXME: Why don't we go class->layout->info == dd
+  (let ((dd (find-defstruct-description (class-name class))))
     (lambda ()
       (sb-kernel::%make-instance-with-layout
        (sb-kernel::compiler-layout-or-lose (dd-name dd))))))

Update of /cvsroot/sbcl/sbcl
In directory sc8-pr-cvs8.sourceforge.net:/tmp/cvs-serv3345

Modified Files:
	package-data-list.lisp-expr version.lisp-expr 
Log Message:
1.0.4.39: get rid of hardcoded mutex and spinlock slot indexes

 * DEFINE-STRUCTURE-SLOT-COMPARE-AND-EXCHANGE can be used to define
   nice wrappers for %INSTANCE-SLOT-CONDITIONAL using just the
   structure and slot name.

   Note to self: it would probably make sense to give something along
   these lines for users to use as well, so that they can implement
   lockless algorithms in lisp.

 * DEFINE-STRUCTURE-SLOT-ADDRESSOR does the same for getting the
   slot address.

 * SB-PCL::GET-STRUCTURE-DD moved to host and renamed
   SB-KERNEL:FIND-DEFSTRUCT-DESCRIPTION.

 * SB-THREAD now uses SB-KERNEL.

 (threads.impure.lisp currently fail, but not due to this)


Index: package-data-list.lisp-expr
===================================================================
RCS file: /cvsroot/sbcl/sbcl/package-data-list.lisp-expr,v
retrieving revision 1.391
retrieving revision 1.392
diff -u -d -r1.391 -r1.392
--- package-data-list.lisp-expr	6 Apr 2007 09:58:08 -0000	1.391
+++ package-data-list.lisp-expr	7 Apr 2007 13:58:57 -0000	1.392
@@ -1232,6 +1232,8 @@
                "DECODE-DOUBLE-FLOAT"
                #!+long-float "DECODE-LONG-FLOAT"
                "DECODE-SINGLE-FLOAT"
+               "DEFINE-STRUCTURE-SLOT-ADDRESSOR"
+               "DEFINE-STRUCTURE-SLOT-COMPARE-AND-EXCHANGE"
                "DEFINED-FTYPE-MATCHES-DECLARED-FTYPE-P"
                "!DEFSTRUCT-WITH-ALTERNATE-METACLASS" "DESCEND-INTO"
                "DISPLACED-TO-ARRAY-TOO-SMALL-ERROR"
@@ -1244,7 +1246,9 @@
                "EXTENDED-CHAR-P"
                "FAILED-%WITH-ARRAY-DATA" "FDEFINITION-OBJECT"
                "FDOCUMENTATION" "FILENAME"
-               "FIND-AND-INIT-OR-CHECK-LAYOUT" "FLOAT-EXPONENT"
+               "FIND-AND-INIT-OR-CHECK-LAYOUT"
+               "FIND-DEFSTRUCT-DESCRIPTION"
+               "FLOAT-EXPONENT"
                "FLOAT-FORMAT-DIGITS" "FLOAT-FORMAT-NAME"
                "FLOAT-FORMAT-MAX" "FLOAT-INT-EXPONENT"
                "FLOATING-POINT-EXCEPTION" "FORM" "FORMAT-CONTROL"
@@ -1637,7 +1641,7 @@
 
    #s(sb-cold:package-data
       :name "SB!THREAD"
-      :use ("CL" "SB!ALIEN" "SB!INT" "SB!SYS")
+      :use ("CL" "SB!ALIEN" "SB!INT" "SB!SYS" "SB!KERNEL")
       :doc "public (but low-level): native thread support"
       :export ("*CURRENT-THREAD*" "THREAD" "MAKE-THREAD"
                "THREAD-NAME" "THREAD-ALIVE-P"

Index: version.lisp-expr
===================================================================
RCS file: /cvsroot/sbcl/sbcl/version.lisp-expr,v
retrieving revision 1.3293
retrieving revision 1.3294
diff -u -d -r1.3293 -r1.3294
--- version.lisp-expr	7 Apr 2007 09:38:47 -0000	1.3293
+++ version.lisp-expr	7 Apr 2007 13:58:57 -0000	1.3294
@@ -17,4 +17,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"1.0.4.38"
+"1.0.4.39"

Update of /cvsroot/sbcl/sbcl/src/code
In directory sc8-pr-cvs8.sourceforge.net:/tmp/cvs-serv24517/src/code

Modified Files:
	win32.lisp 
Log Message:
1.0.4.38: unbreak win32 build, again
 * Thanks to Yaroslav Kavenchuk.


Index: win32.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/win32.lisp,v
retrieving revision 1.14
retrieving revision 1.15
diff -u -d -r1.14 -r1.15
--- win32.lisp	5 Apr 2007 12:24:30 -0000	1.14
+++ win32.lisp	7 Apr 2007 09:38:47 -0000	1.15
@@ -511,14 +511,14 @@
                (addr ,kernel-time)
                (addr ,user-time))))
 
-(declaim (inline system-internal-real-time system-internal-run-time))
+(declaim (inline system-internal-real-time))
 
 (let ((epoch 0))
   (declare (unsigned-byte epoch))
   ;; FIXME: For optimization ideas see the unix implementation.
   (defun reinit-internal-real-time ()
     (setf epoch 0
-          epoch (system-internal-real-time)))
+          epoch (get-internal-real-time)))
   (defun get-internal-real-time ()
     (- (with-alien ((system-time filetime))
          (syscall (("GetSystemTimeAsFileTime" 4) void (* filetime))

Update of /cvsroot/sbcl/sbcl
In directory sc8-pr-cvs8.sourceforge.net:/tmp/cvs-serv24517

Modified Files:
	version.lisp-expr 
Log Message:
1.0.4.38: unbreak win32 build, again
 * Thanks to Yaroslav Kavenchuk.


Index: version.lisp-expr
===================================================================
RCS file: /cvsroot/sbcl/sbcl/version.lisp-expr,v
retrieving revision 1.3292
retrieving revision 1.3293
diff -u -d -r1.3292 -r1.3293
--- version.lisp-expr	7 Apr 2007 01:17:36 -0000	1.3292
+++ version.lisp-expr	7 Apr 2007 09:38:47 -0000	1.3293
@@ -17,4 +17,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"1.0.4.37"
+"1.0.4.38"

Update of /cvsroot/sbcl/sbcl/src/compiler
In directory sc8-pr-cvs8.sourceforge.net:/tmp/cvs-serv23006/src/compiler

Modified Files:
	pack.lisp 
Log Message:
1.0.4.37: Delete some dead code in pack.lisp


Index: pack.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/pack.lisp,v
retrieving revision 1.22
retrieving revision 1.23
diff -u -d -r1.22 -r1.23
--- pack.lisp	17 Sep 2005 07:43:33 -0000	1.22
+++ pack.lisp	7 Apr 2007 01:17:36 -0000	1.23
@@ -607,20 +607,6 @@
                        save tn before))
   (values))
 
-(eval-when (:compile-toplevel :execute)
-
-;;; Do stuff to note a read of TN, for OPTIMIZED-EMIT-SAVES-BLOCK.
-(defmacro save-note-read (tn)
-  `(let* ((tn ,tn)
-          (num (tn-number tn)))
-     (when (and (sc-save-p (tn-sc tn))
-                (zerop (sbit restores num))
-                (not (eq (tn-kind tn) :component)))
-       (setf (sbit restores num) 1)
-       (push tn restores-list))))
-
-) ; EVAL-WHEN
-
 ;;; Start scanning backward at the end of BLOCK, looking which TNs are
 ;;; live and looking for places where we have to save. We manipulate
 ;;; two sets: SAVES and RESTORES.
@@ -700,9 +686,7 @@
                   (setq saves-list
                         (delete tn saves-list :test #'eq))))))
 
-          (macrolet (;; Do stuff to note a read of TN, for
-                     ;; OPTIMIZED-EMIT-SAVES-BLOCK.
-                     (save-note-read (tn)
+          (macrolet ((save-note-read (tn)
                        `(let* ((tn ,tn)
                                (num (tn-number tn)))
                           (when (and (sc-save-p (tn-sc tn))

Update of /cvsroot/sbcl/sbcl
In directory sc8-pr-cvs8.sourceforge.net:/tmp/cvs-serv23006

Modified Files:
	version.lisp-expr 
Log Message:
1.0.4.37: Delete some dead code in pack.lisp


Index: version.lisp-expr
===================================================================
RCS file: /cvsroot/sbcl/sbcl/version.lisp-expr,v
retrieving revision 1.3291
retrieving revision 1.3292
diff -u -d -r1.3291 -r1.3292
--- version.lisp-expr	7 Apr 2007 01:13:23 -0000	1.3291
+++ version.lisp-expr	7 Apr 2007 01:17:36 -0000	1.3292
@@ -17,4 +17,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"1.0.4.36"
+"1.0.4.37"

Update of /cvsroot/sbcl/sbcl/tests
In directory sc8-pr-cvs8.sourceforge.net:/tmp/cvs-serv20889/tests

Added Files:
	break-on-signals.impure.lisp 
Log Message:
1.0.4.36: Commit Kevin Reid's "safer *break-on-signals*" patch.


--- NEW FILE: break-on-signals.impure.lisp ---
;;;; This software is part of the SBCL system. See the README file for
;;;; more information.
;;;;
;;;; While most of SBCL is derived from the CMU CL system, the test
;;;; files (like this one) were written from scratch after the fork
;;;; from CMU CL.
;;;;
;;;; This software is in the public domain and is provided with
;;;; absolutely no warranty. See the COPYING and CREDITS files for
;;;; more information.

(cl:in-package :cl-user)

;;; If *BREAK-ON-SIGNALS* has a bogus value, don't go off in an infinite
;;; recursion.
(assert
  (catch 'ok
    (handler-bind
        ((error
          (lambda (condition)
            (when (search "NOT-A-TYPE-SPECIFIER" (princ-to-string condition))
              (throw 'ok t)))))
      (let ((*break-on-signals* '#:not-a-type-specifier))
        (signal "foo"))
    nil)))

Update of /cvsroot/sbcl/sbcl/src/code
In directory sc8-pr-cvs8.sourceforge.net:/tmp/cvs-serv20889/src/code

Modified Files:
	cold-error.lisp 
Log Message:
1.0.4.36: Commit Kevin Reid's "safer *break-on-signals*" patch.


Index: cold-error.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/cold-error.lisp,v
retrieving revision 1.20
retrieving revision 1.21
diff -u -d -r1.20 -r1.21
--- cold-error.lisp	14 Jul 2005 16:30:14 -0000	1.20
+++ cold-error.lisp	7 Apr 2007 01:13:23 -0000	1.21
@@ -27,10 +27,16 @@
                                         'simple-condition
                                         'signal))
         (*handler-clusters* *handler-clusters*)
-        (old-bos *break-on-signals*))
+        (old-bos *break-on-signals*)
+        (bos-actually-breaking nil))
     (restart-case
-        (when (typep condition *break-on-signals*)
-          (let ((*break-on-signals* nil))
+        (let ((break-on-signals *break-on-signals*)
+              (*break-on-signals* nil))
+          ;; The rebinding encloses the TYPEP so that a bogus
+          ;; type specifier will not lead to infinite recursion when
+          ;; TYPEP fails.
+          (when (typep condition break-on-signals)
+            (setf bos-actually-breaking t)
             (break "~A~%BREAK was entered because of *BREAK-ON-SIGNALS* ~
                     (now rebound to NIL)."
                    condition)))
@@ -45,7 +51,13 @@
       ;; unless we provide this restart.)
       (reassign (new-value)
         :report
-        "Return from BREAK and assign a new value to *BREAK-ON-SIGNALS*."
+        (lambda (stream)
+          (format stream
+                  (if bos-actually-breaking
+                    "Return from BREAK and assign a new value to ~
+                     *BREAK-ON-SIGNALS*."
+                    "Assign a new value to *BREAK-ON-SIGNALS* and ~
+                     continue with signal handling.")))
         :interactive
         (lambda ()
           (let (new-value)

Update of /cvsroot/sbcl/sbcl
In directory sc8-pr-cvs8.sourceforge.net:/tmp/cvs-serv20889

Modified Files:
	version.lisp-expr NEWS 
Log Message:
1.0.4.36: Commit Kevin Reid's "safer *break-on-signals*" patch.


Index: version.lisp-expr
===================================================================
RCS file: /cvsroot/sbcl/sbcl/version.lisp-expr,v
retrieving revision 1.3290
retrieving revision 1.3291
diff -u -d -r1.3290 -r1.3291
--- version.lisp-expr	7 Apr 2007 01:07:05 -0000	1.3290
+++ version.lisp-expr	7 Apr 2007 01:13:23 -0000	1.3291
@@ -17,4 +17,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"1.0.4.35"
+"1.0.4.36"

Index: NEWS
===================================================================
RCS file: /cvsroot/sbcl/sbcl/NEWS,v
retrieving revision 1.1162
retrieving revision 1.1163
diff -u -d -r1.1162 -r1.1163
--- NEWS	6 Apr 2007 11:13:54 -0000	1.1162
+++ NEWS	7 Apr 2007 01:13:23 -0000	1.1163
@@ -17,6 +17,8 @@
   * bug fix: some GC deadlocks caused by asynchronous interrupts have
     been fixed by inhibiting interrupts for when GC is disbled.
   * bug fix: GETHASH, PUTHASH, CLRHASH and REMHASH are now interrupt safe.
+  * bug fix: binding *BREAK-ON-SIGNALS* to a value that is not a type
+    specifier no longer causes infinite recursion.
   * improvement: the x86-64/darwin port now passes all tests and
     should be considered non-experimental.

Update of /cvsroot/sbcl/sbcl/tests
In directory sc8-pr-cvs8.sourceforge.net:/tmp/cvs-serv18001/tests

Modified Files:
	core.test.sh 
Log Message:
1.0.4.35: Commit Kevin Reid's "Test failure in core.test.sh" patch


Index: core.test.sh
===================================================================
RCS file: /cvsroot/sbcl/sbcl/tests/core.test.sh,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -d -r1.5 -r1.6
--- core.test.sh	16 Mar 2007 03:57:10 -0000	1.5
+++ core.test.sh	7 Apr 2007 01:07:06 -0000	1.6
@@ -67,7 +67,8 @@
   (save-lisp-and-die "$tmpcore" :executable t)
 EOF
 chmod u+x "$tmpcore"
-./"$tmpcore" >"$tmpoutput" --eval '(quit :unix-status 71)'
+./"$tmpcore" >"$tmpoutput" \
+  --no-userinit --no-sysinit --eval '(quit :unix-status 71)'
 if [ $? != 71 ]; then
   echo "failure in banner suppression: $?"
   exit 1

Update of /cvsroot/sbcl/sbcl
In directory sc8-pr-cvs8.sourceforge.net:/tmp/cvs-serv18001

Modified Files:
	version.lisp-expr 
Log Message:
1.0.4.35: Commit Kevin Reid's "Test failure in core.test.sh" patch


Index: version.lisp-expr
===================================================================
RCS file: /cvsroot/sbcl/sbcl/version.lisp-expr,v
retrieving revision 1.3289
retrieving revision 1.3290
diff -u -d -r1.3289 -r1.3290
--- version.lisp-expr	6 Apr 2007 21:48:29 -0000	1.3289
+++ version.lisp-expr	7 Apr 2007 01:07:05 -0000	1.3290
@@ -17,4 +17,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"1.0.4.34"
+"1.0.4.35"