1.0.16.10: function-ify ERROR-CALL and GENERATE-ERROR-CODE on x86

	* Saves ~120k in core size.

	* Should be done for other backends and ERROR-CALL &co.
	  refactored appropriately.

diff --git a/src/assembly/x86/assem-rtns.lisp b/src/assembly/x86/assem-rtns.lisp
index 489316e..930c2e7 100644 (file)
--- a/src/assembly/x86/assem-rtns.lisp
+++ b/src/assembly/x86/assem-rtns.lisp
@@ -202,7 +202,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))
 
@@ -230,7 +230,7 @@
                           (:temp uwp unsigned-reg esi-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))
 
@@ -275,7 +275,7 @@
                           (:arg count (any-reg descriptor-reg) ecx-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 29affad..3f7da3e 100644 (file)
--- a/src/compiler/generic/array.lisp
+++ b/src/compiler/generic/array.lisp
@@ -23,7 +23,10 @@
   (:vop-var vop)
   (:save-p :compute-only)
   (:generator 1
-    (error-call vop nil-array-accessed-error object)))
+    (error-call vop
+                #!+x86 'nil-array-accessed-error
+                #!-x86 nil-array-accessed-error
+                object)))
 
 ;;; It shouldn't be possible to fall through to here in normal user
 ;;; code, as the system is smart enough to deduce that there must be
@@ -48,7 +51,10 @@
   (:vop-var vop)
   (:save-p :compute-only)
   (:generator 1
-    (error-call vop nil-array-accessed-error object)))
+    (error-call vop
+                #!+x86 'nil-array-accessed-error
+                #!-x86 nil-array-accessed-error
+                object)))
 
 (define-vop (data-vector-ref-with-offset/simple-array-nil)
   (:translate data-vector-ref-with-offset)
@@ -64,7 +70,10 @@
   (:vop-var vop)
   (:save-p :compute-only)
   (:generator 1
-    (error-call vop nil-array-accessed-error object)))
+    (error-call vop
+                #!+x86 'nil-array-accessed-error
+                #!-x86 nil-array-accessed-error
+                object)))
 
 (define-vop (data-vector-set/simple-array-nil)
   (:translate data-vector-set)
@@ -81,7 +90,10 @@
   (:vop-var vop)
   (:save-p :compute-only)
   (:generator 1
-    (error-call vop nil-array-accessed-error object)))
+    (error-call vop
+                #!+x86 'nil-array-accessed-error
+                #!-x86 nil-array-accessed-error
+                object)))
 \f
 ;;; FIXME: There is probably plenty of other array stuff that looks
 ;;; the same or similar enough to be genericized.  Do so, and move it

diff --git a/src/compiler/x86/arith.lisp b/src/compiler/x86/arith.lisp
index 970b369..4731c26 100644 (file)
--- a/src/compiler/x86/arith.lisp
+++ b/src/compiler/x86/arith.lisp
@@ -436,7 +436,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))
@@ -491,7 +491,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))
@@ -542,7 +542,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/array.lisp b/src/compiler/x86/array.lisp
index 3d49c01..22ab26c 100644 (file)
--- a/src/compiler/x86/array.lisp
+++ b/src/compiler/x86/array.lisp
@@ -112,7 +112,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/call.lisp b/src/compiler/x86/call.lisp
index 982a3c1..1b7d900 100644 (file)
--- a/src/compiler/x86/call.lisp
+++ b/src/compiler/x86/call.lisp
@@ -1422,7 +1422,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)))
@@ -1440,7 +1440,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/cell.lisp b/src/compiler/x86/cell.lisp
index 08862bf..241d434 100644 (file)
--- a/src/compiler/x86/cell.lisp
+++ b/src/compiler/x86/cell.lisp
@@ -66,7 +66,7 @@
     ;; This code has to 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 eax old)
       #!+sb-thread
@@ -130,7 +130,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 fs-segment-prefix)
@@ -171,7 +171,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))))
@@ -261,7 +261,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/macros.lisp b/src/compiler/x86/macros.lisp
index 71440fc..bfdb6c8 100644 (file)
--- a/src/compiler/x86/macros.lisp
+++ b/src/compiler/x86/macros.lisp
@@ -294,6 +294,32 @@
       ,@forms)))
 \f
 ;;;; error code
+(defun emit-error-break (vop kind code values)
+  (assemble ()
+    #-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)
+    (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)
+        (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))))))
+
+#+nil
 (eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
   (defun emit-error-break (vop kind code values)
     (let ((vector (gensym)))
@@ -328,21 +354,20 @@
           (dotimes (i (length ,vector))
             (inst byte (aref ,vector i))))))))
 
-(defmacro error-call (vop error-code &rest values)
+(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)
-       start-lab)))
+  (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
 ;;;; PSEUDO-ATOMIC

diff --git a/src/compiler/x86/move.lisp b/src/compiler/x86/move.lisp
index 24b4083..2c198a9 100644 (file)
--- a/src/compiler/x86/move.lisp
+++ b/src/compiler/x86/move.lisp
@@ -130,7 +130,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/subprim.lisp b/src/compiler/x86/subprim.lisp
index 1e9e532..a922c85 100644 (file)
--- a/src/compiler/x86/subprim.lisp
+++ b/src/compiler/x86/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/type-vops.lisp b/src/compiler/x86/type-vops.lisp
index 4b8cd45..d0e5f0e 100644 (file)
--- a/src/compiler/x86/type-vops.lisp
+++ b/src/compiler/x86/type-vops.lisp
@@ -197,7 +197,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
@@ -237,7 +237,7 @@
 (define-vop (check-signed-byte-32 check-type)
   (:generator 45
     (let ((nope (generate-error-code vop
-                                     object-not-signed-byte-32-error
+                                     'object-not-signed-byte-32-error
                                      value)))
       (generate-fixnum-test value)
       (inst jmp :e yep)
@@ -302,7 +302,7 @@
 (define-vop (check-unsigned-byte-32 check-type)
   (:generator 45
     (let ((nope
-           (generate-error-code vop object-not-unsigned-byte-32-error value))
+           (generate-error-code vop 'object-not-unsigned-byte-32-error value))
           (yep (gen-label))
           (fixnum (gen-label))
           (single-word (gen-label)))
@@ -359,7 +359,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)))
@@ -377,7 +377,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/values.lisp b/src/compiler/x86/values.lisp
index f6b4df8..082ad2c 100644 (file)
--- a/src/compiler/x86/values.lisp
+++ b/src/compiler/x86/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/version.lisp-expr b/version.lisp-expr
index eb68dfa..200ad40 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.9"
+"1.0.16.10"