1.0.16.27: function-ify ERROR-CALL and GENERATE-ERROR-CODE on x86-64

 * Port of 1.0.16.10 to x86-64.

diff --git a/src/assembly/x86-64/alloc.lisp b/src/assembly/x86-64/alloc.lisp
index ba27b1b..68a8ce3 100644 (file)
--- a/src/assembly/x86-64/alloc.lisp
+++ b/src/assembly/x86-64/alloc.lisp
@@ -106,7 +106,7 @@
                (inst jmp :ne release-tls-index-lock)
                ;; Allocate a new tls-index.
                (load-symbol-value target *free-tls-index*)
-               (let ((error (generate-error-code nil tls-exhausted-error)))
+               (let ((error (generate-error-code nil 'tls-exhausted-error)))
                  (inst cmp target (fixnumize tls-size))
                  (inst jmp :ge error))
                (inst add (make-ea-for-symbol-value *free-tls-index*)

diff --git a/src/assembly/x86-64/assem-rtns.lisp b/src/assembly/x86-64/assem-rtns.lisp
index 9083075..dea6cbb 100644 (file)
--- a/src/assembly/x86-64/assem-rtns.lisp
+++ b/src/assembly/x86-64/assem-rtns.lisp
@@ -207,7 +207,7 @@
 
   LOOP
 
-  (let ((error (generate-error-code nil unseen-throw-tag-error target)))
+  (let ((error (generate-error-code nil 'unseen-throw-tag-error target)))
     (inst or catch catch)               ; check for NULL pointer
     (inst jmp :z error))
 
@@ -234,7 +234,7 @@
                           (:temp uwp unsigned-reg rsi-offset))
   (declare (ignore start count))
 
-  (let ((error (generate-error-code nil invalid-unwind-error)))
+  (let ((error (generate-error-code nil 'invalid-unwind-error)))
     (inst or block block)               ; check for NULL pointer
     (inst jmp :z error))
 

diff --git a/src/compiler/generic/array.lisp b/src/compiler/generic/array.lisp
index 3f7da3e..cf0f2fd 100644 (file)
--- a/src/compiler/generic/array.lisp
+++ b/src/compiler/generic/array.lisp
@@ -24,8 +24,8 @@
   (:save-p :compute-only)
   (:generator 1
     (error-call vop
-                #!+x86 'nil-array-accessed-error
-                #!-x86 nil-array-accessed-error
+                #!+(or x86 x86-64) 'nil-array-accessed-error
+                #!-(or x86 x86-64) nil-array-accessed-error
                 object)))
 
 ;;; It shouldn't be possible to fall through to here in normal user
@@ -52,8 +52,8 @@
   (:save-p :compute-only)
   (:generator 1
     (error-call vop
-                #!+x86 'nil-array-accessed-error
-                #!-x86 nil-array-accessed-error
+                #!+(or x86 x86-64) 'nil-array-accessed-error
+                #!-(or x86 x86-64) nil-array-accessed-error
                 object)))
 
 (define-vop (data-vector-ref-with-offset/simple-array-nil)
@@ -71,8 +71,8 @@
   (:save-p :compute-only)
   (:generator 1
     (error-call vop
-                #!+x86 'nil-array-accessed-error
-                #!-x86 nil-array-accessed-error
+                #!+(or x86 x86-64) 'nil-array-accessed-error
+                #!-(or x86 x86-64) nil-array-accessed-error
                 object)))
 
 (define-vop (data-vector-set/simple-array-nil)
@@ -91,8 +91,8 @@
   (:save-p :compute-only)
   (:generator 1
     (error-call vop
-                #!+x86 'nil-array-accessed-error
-                #!-x86 nil-array-accessed-error
+                #!+(or x86 x86-64) 'nil-array-accessed-error
+                #!-(or x86 x86-64) nil-array-accessed-error
                 object)))
 \f
 ;;; FIXME: There is probably plenty of other array stuff that looks

diff --git a/src/compiler/x86-64/arith.lisp b/src/compiler/x86-64/arith.lisp
index 0daa98d..d0436d5 100644 (file)
--- a/src/compiler/x86-64/arith.lisp
+++ b/src/compiler/x86-64/arith.lisp
@@ -432,7 +432,7 @@
   (:vop-var vop)
   (:save-p :compute-only)
   (:generator 31
-    (let ((zero (generate-error-code vop division-by-zero-error x y)))
+    (let ((zero (generate-error-code vop 'division-by-zero-error x y)))
       (if (sc-is y any-reg)
           (inst test y y)  ; smaller instruction
           (inst cmp y 0))
@@ -487,7 +487,7 @@
   (:vop-var vop)
   (:save-p :compute-only)
   (:generator 33
-    (let ((zero (generate-error-code vop division-by-zero-error x y)))
+    (let ((zero (generate-error-code vop 'division-by-zero-error x y)))
       (if (sc-is y unsigned-reg)
           (inst test y y)  ; smaller instruction
           (inst cmp y 0))
@@ -538,7 +538,7 @@
   (:vop-var vop)
   (:save-p :compute-only)
   (:generator 33
-    (let ((zero (generate-error-code vop division-by-zero-error x y)))
+    (let ((zero (generate-error-code vop 'division-by-zero-error x y)))
       (if (sc-is y signed-reg)
           (inst test y y)  ; smaller instruction
           (inst cmp y 0))

diff --git a/src/compiler/x86-64/array.lisp b/src/compiler/x86-64/array.lisp
index c73b4eb..504ef62 100644 (file)
--- a/src/compiler/x86-64/array.lisp
+++ b/src/compiler/x86-64/array.lisp
@@ -117,7 +117,7 @@
   (:vop-var vop)
   (:save-p :compute-only)
   (:generator 5
-    (let ((error (generate-error-code vop invalid-array-index-error
+    (let ((error (generate-error-code vop 'invalid-array-index-error
                                       array bound index))
           (index (if (sc-is index immediate)
                    (fixnumize (tn-value index))

diff --git a/src/compiler/x86-64/call.lisp b/src/compiler/x86-64/call.lisp
index 8e1da4d..883be90 100644 (file)
--- a/src/compiler/x86-64/call.lisp
+++ b/src/compiler/x86-64/call.lisp
@@ -1366,7 +1366,7 @@
   (:save-p :compute-only)
   (:generator 3
     (let ((err-lab
-           (generate-error-code vop invalid-arg-count-error nargs)))
+           (generate-error-code vop 'invalid-arg-count-error nargs)))
       (if (zerop count)
           (inst test nargs nargs)  ; smaller instruction
         (inst cmp nargs (fixnumize count)))
@@ -1384,7 +1384,7 @@
                 (:vop-var vop)
                 (:save-p :compute-only)
                 (:generator 1000
-                  (error-call vop ,error ,@args)))))
+                  (error-call vop ',error ,@args)))))
   (def arg-count-error invalid-arg-count-error
     sb!c::%arg-count-error nargs)
   (def type-check-error object-not-type-error sb!c::%type-check-error

diff --git a/src/compiler/x86-64/cell.lisp b/src/compiler/x86-64/cell.lisp
index 2f546a6..2a02340 100644 (file)
--- a/src/compiler/x86-64/cell.lisp
+++ b/src/compiler/x86-64/cell.lisp
@@ -80,10 +80,10 @@
   (:policy :fast-safe)
   (:vop-var vop)
   (:generator 15
-    ;; This code has to pathological cases: NO-TLS-VALUE-MARKER
+    ;; This code has two pathological cases: NO-TLS-VALUE-MARKER
     ;; or UNBOUND-MARKER as NEW: in either case we would end up
     ;; doing possible damage with CMPXCHG -- so don't do that!
-    (let ((unbound (generate-error-code vop unbound-symbol-error symbol))
+    (let ((unbound (generate-error-code vop 'unbound-symbol-error symbol))
           (check (gen-label)))
       (move rax old)
       #!+sb-thread
@@ -149,7 +149,7 @@
   (:save-p :compute-only)
   (:generator 9
     (let* ((check-unbound-label (gen-label))
-           (err-lab (generate-error-code vop unbound-symbol-error object))
+           (err-lab (generate-error-code vop 'unbound-symbol-error object))
            (ret-lab (gen-label)))
       (loadw value object symbol-tls-index-slot other-pointer-lowtag)
       (inst mov value (make-ea :qword :base thread-base-tn
@@ -190,7 +190,7 @@
   (:vop-var vop)
   (:save-p :compute-only)
   (:generator 9
-    (let ((err-lab (generate-error-code vop unbound-symbol-error object)))
+    (let ((err-lab (generate-error-code vop 'unbound-symbol-error object)))
       (loadw value object symbol-value-slot other-pointer-lowtag)
       (inst cmp value unbound-marker-widetag)
       (inst jmp :e err-lab))))
@@ -281,7 +281,7 @@
   (:generator 10
     (loadw value object fdefn-fun-slot other-pointer-lowtag)
     (inst cmp value nil-value)
-    (let ((err-lab (generate-error-code vop undefined-fun-error object)))
+    (let ((err-lab (generate-error-code vop 'undefined-fun-error object)))
       (inst jmp :e err-lab))))
 
 (define-vop (set-fdefn-fun)

diff --git a/src/compiler/x86-64/macros.lisp b/src/compiler/x86-64/macros.lisp
index 9393c2b..9857d15 100644 (file)
--- a/src/compiler/x86-64/macros.lisp
+++ b/src/compiler/x86-64/macros.lisp
@@ -230,55 +230,48 @@
       ,@forms)))
 \f
 ;;;; error code
-(eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
-  (defun emit-error-break (vop kind code values)
-    (let ((vector (gensym)))
-      `((progn
-          #!-darwin (inst int 3)                  ; i386 breakpoint instruction
-          ;; On Darwin, we need to use #x0b0f instead of int3 in order
-          ;; to generate a SIGILL instead of a SIGTRAP as darwin/x86
-          ;; doesn't seem to be reliably firing SIGTRAP
-          ;; handlers. Hopefully this will be fixed by Apple at a
-          ;; later date. Do the same on x86-64 as we do on x86 until this gets
-          ;; sorted out.
-          #!+darwin (inst word #x0b0f))
-
-        ;; The return PC points here; note the location for the debugger.
-        (let ((vop ,vop))
-          (when vop
-                (note-this-location vop :internal-error)))
-        (inst byte ,kind)                       ; eg trap_Xyyy
-        (with-adjustable-vector (,vector)       ; interr arguments
-          (write-var-integer (error-number-or-lose ',code) ,vector)
-          ,@(mapcar (lambda (tn)
-                      `(let ((tn ,tn))
-                         ;; classic CMU CL comment:
-                         ;;   zzzzz jrd here. tn-offset is zero for constant
-                         ;;   tns.
-                         (write-var-integer (make-sc-offset (sc-number
-                                                             (tn-sc tn))
-                                                            (or (tn-offset tn)
-                                                                0))
-                                            ,vector)))
-                    values)
-          (inst byte (length ,vector))
-          (dotimes (i (length ,vector))
-            (inst byte (aref ,vector i))))))))
-
-(defmacro error-call (vop error-code &rest values)
+(defun emit-error-break (vop kind code values)
+  (assemble ()
+    #!-darwin
+    (inst int 3)                  ; i386 breakpoint instruction
+    ;; On Darwin, we need to use #x0b0f instead of int3 in order
+    ;; to generate a SIGILL instead of a SIGTRAP as darwin/x86
+    ;; doesn't seem to be reliably firing SIGTRAP
+    ;; handlers. Hopefully this will be fixed by Apple at a
+    ;; later date. Do the same on x86-64 as we do on x86 until this gets
+    ;; sorted out.
+    #!+darwin
+    (inst word #x0b0f)
+    ;; The return PC points here; note the location for the debugger.
+    (when vop
+      (note-this-location vop :internal-error))
+    (inst byte kind)                       ; eg trap_Xyyy
+    (with-adjustable-vector (vector)       ; interr arguments
+      (write-var-integer code vector)
+      (dolist (tn values)
+        ;; classic CMU CL comment:
+        ;;   zzzzz jrd here. tn-offset is zero for constant
+        ;;   tns.
+        (write-var-integer (make-sc-offset (sc-number (tn-sc tn))
+                                           (or (tn-offset tn) 0))
+                           vector))
+      (inst byte (length vector))
+      (dotimes (i (length vector))
+        (inst byte (aref vector i))))))
+
+(defun error-call (vop error-code &rest values)
   #!+sb-doc
   "Cause an error. ERROR-CODE is the error to cause."
-  (cons 'progn
-        (emit-error-break vop error-trap error-code values)))
+  (emit-error-break vop error-trap (error-number-or-lose error-code) values))
 
-(defmacro generate-error-code (vop error-code &rest values)
+(defun generate-error-code (vop error-code &rest values)
   #!+sb-doc
   "Generate-Error-Code Error-code Value*
   Emit code for an error with the specified Error-Code and context Values."
-  `(assemble (*elsewhere*)
-     (let ((start-lab (gen-label)))
-       (emit-label start-lab)
-       (error-call ,vop ,error-code ,@values)
+  (assemble (*elsewhere*)
+    (let ((start-lab (gen-label)))
+      (emit-label start-lab)
+      (emit-error-break vop error-trap (error-number-or-lose error-code) values)
        start-lab)))
 
 \f

diff --git a/src/compiler/x86-64/move.lisp b/src/compiler/x86-64/move.lisp
index 1921dfa..4f37f5a 100644 (file)
--- a/src/compiler/x86-64/move.lisp
+++ b/src/compiler/x86-64/move.lisp
@@ -218,7 +218,7 @@
   (:vop-var vop)
   (:save-p :compute-only)
   (:generator 666
-    (error-call vop object-not-type-error x type)))
+    (error-call vop 'object-not-type-error x type)))
 \f
 ;;;; moves and coercions
 

diff --git a/src/compiler/x86-64/subprim.lisp b/src/compiler/x86-64/subprim.lisp
index 4b3eed2..1f44f03 100644 (file)
--- a/src/compiler/x86-64/subprim.lisp
+++ b/src/compiler/x86-64/subprim.lisp
@@ -48,7 +48,7 @@
     (inst cmp al-tn list-pointer-lowtag)
     (inst jmp :e LOOP)
     ;; It's dotted all right. Flame out.
-    (error-call vop object-not-list-error ptr)
+    (error-call vop 'object-not-list-error ptr)
     ;; We be done.
     DONE))
 

diff --git a/src/compiler/x86-64/type-vops.lisp b/src/compiler/x86-64/type-vops.lisp
index 43b838c..450a6a4 100644 (file)
--- a/src/compiler/x86-64/type-vops.lisp
+++ b/src/compiler/x86-64/type-vops.lisp
@@ -171,7 +171,7 @@
            `((define-vop (,check-name ,(intern (concatenate 'string prefix "CHECK-TYPE")))
                (:generator ,cost
                  (let ((err-lab
-                        (generate-error-code vop ,error-code value)))
+                        (generate-error-code vop ',error-code value)))
                    (test-type value err-lab t (,@type-codes))
                    (move result value))))))
        ,@(when ptype
@@ -213,7 +213,7 @@
 (define-vop (check-signed-byte-64 check-type)
   (:generator 45
     (let ((nope (generate-error-code vop
-                                     object-not-signed-byte-64-error
+                                     'object-not-signed-byte-64-error
                                      value)))
       (generate-fixnum-test value)
       (inst jmp :e yep)
@@ -278,7 +278,7 @@
 (define-vop (check-unsigned-byte-64 check-type)
   (:generator 45
     (let ((nope
-           (generate-error-code vop object-not-unsigned-byte-64-error value))
+           (generate-error-code vop 'object-not-unsigned-byte-64-error value))
           (yep (gen-label))
           (fixnum (gen-label))
           (single-word (gen-label)))
@@ -335,7 +335,7 @@
 
 (define-vop (check-symbol check-type)
   (:generator 12
-    (let ((error (generate-error-code vop object-not-symbol-error value)))
+    (let ((error (generate-error-code vop 'object-not-symbol-error value)))
       (inst cmp value nil-value)
       (inst jmp :e DROP-THRU)
       (test-type value error t (symbol-header-widetag)))
@@ -353,7 +353,7 @@
 
 (define-vop (check-cons check-type)
   (:generator 8
-    (let ((error (generate-error-code vop object-not-cons-error value)))
+    (let ((error (generate-error-code vop 'object-not-cons-error value)))
       (inst cmp value nil-value)
       (inst jmp :e error)
       (test-type value error t (list-pointer-lowtag))

diff --git a/src/compiler/x86-64/values.lisp b/src/compiler/x86-64/values.lisp
index c135c83..05b00d6 100644 (file)
--- a/src/compiler/x86-64/values.lisp
+++ b/src/compiler/x86-64/values.lisp
@@ -93,7 +93,7 @@
     (inst and al-tn lowtag-mask)
     (inst cmp al-tn list-pointer-lowtag)
     (inst jmp :e LOOP)
-    (error-call vop bogus-arg-to-values-list-error list)
+    (error-call vop 'bogus-arg-to-values-list-error list)
 
     DONE
     (inst mov count start)              ; start is high address

diff --git a/src/compiler/x86/macros.lisp b/src/compiler/x86/macros.lisp
index 378a2ca..df6f856 100644 (file)
--- a/src/compiler/x86/macros.lisp
+++ b/src/compiler/x86/macros.lisp
@@ -296,7 +296,7 @@
 ;;;; error code
 (defun emit-error-break (vop kind code values)
   (assemble ()
-    #-darwin
+    #!-darwin
     (inst int 3)                        ; i386 breakpoint instruction
     ;; CLH 20060314
     ;; On Darwin, we need to use #x0b0f instead of int3 in order
@@ -304,14 +304,18 @@
     ;; doesn't seem to be reliably firing SIGTRAP
     ;; handlers. Hopefully this will be fixed by Apple at a
     ;; later date.
-    #+darwin
+    #!+darwin
     (inst word #x0b0f)
+    ;; The return PC points here; note the location for the debugger.
     (when vop
       (note-this-location vop :internal-error))
     (inst byte kind)                    ; e.g. trap_xyyy
     (with-adjustable-vector (vector)    ; interr arguments
       (write-var-integer code vector)
       (dolist (tn values)
+        ;; classic CMU CL comment:
+        ;;   zzzzz jrd here. tn-offset is zero for constant
+        ;;   tns.
         (write-var-integer (make-sc-offset (sc-number (tn-sc tn))
                                            (or (tn-offset tn) 0))
                            vector))
@@ -319,41 +323,6 @@
       (dotimes (i (length vector))
         (inst byte (aref vector i))))))
 
-#+nil
-(eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
-  (defun emit-error-break (vop kind code values)
-    (let ((vector (gensym)))
-      `((progn
-          #-darwin (inst int 3)         ; i386 breakpoint instruction
-          ;; CLH 20060314
-          ;; On Darwin, we need to use #x0b0f instead of int3 in order
-          ;; to generate a SIGILL instead of a SIGTRAP as darwin/x86
-          ;; doesn't seem to be reliably firing SIGTRAP
-          ;; handlers. Hopefully this will be fixed by Apple at a
-          ;; later date.
-          #+darwin (inst word #x0b0f))
-        ;; The return PC points here; note the location for the debugger.
-        (let ((vop ,vop))
-          (when vop
-                (note-this-location vop :internal-error)))
-        (inst byte ,kind)                       ; eg trap_Xyyy
-        (with-adjustable-vector (,vector)       ; interr arguments
-          (write-var-integer (error-number-or-lose ',code) ,vector)
-          ,@(mapcar (lambda (tn)
-                      `(let ((tn ,tn))
-                         ;; classic CMU CL comment:
-                         ;;   zzzzz jrd here. tn-offset is zero for constant
-                         ;;   tns.
-                         (write-var-integer (make-sc-offset (sc-number
-                                                             (tn-sc tn))
-                                                            (or (tn-offset tn)
-                                                                0))
-                                            ,vector)))
-                    values)
-          (inst byte (length ,vector))
-          (dotimes (i (length ,vector))
-            (inst byte (aref ,vector i))))))))
-
 (defun error-call (vop error-code &rest values)
   #!+sb-doc
   "Cause an error. ERROR-CODE is the error to cause."

diff --git a/version.lisp-expr b/version.lisp-expr
index bc61bdc..87275a4 100644 (file)
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -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.16.26"
+"1.0.16.27"