From a6b91f356da1b5ae2987f79db9bd137970512959 Mon Sep 17 00:00:00 2001 From: Nathan Froyd Date: Thu, 24 Apr 2008 04:08:48 +0000 Subject: [PATCH] 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. --- src/assembly/x86/assem-rtns.lisp | 6 +++--- src/compiler/generic/array.lisp | 20 ++++++++++++++---- src/compiler/x86/arith.lisp | 6 +++--- src/compiler/x86/array.lisp | 2 +- src/compiler/x86/call.lisp | 4 ++-- src/compiler/x86/cell.lisp | 8 +++---- src/compiler/x86/macros.lisp | 43 ++++++++++++++++++++++++++++++-------- src/compiler/x86/move.lisp | 2 +- src/compiler/x86/subprim.lisp | 2 +- src/compiler/x86/type-vops.lisp | 10 ++++----- src/compiler/x86/values.lisp | 2 +- version.lisp-expr | 2 +- 12 files changed, 72 insertions(+), 35 deletions(-) diff --git a/src/assembly/x86/assem-rtns.lisp b/src/assembly/x86/assem-rtns.lisp index 489316e..930c2e7 100644 --- 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 --- 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))) ;;; 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 --- 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 --- 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 --- 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 --- 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 --- a/src/compiler/x86/macros.lisp +++ b/src/compiler/x86/macros.lisp @@ -294,6 +294,32 @@ ,@forms))) ;;;; 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))) ;;;; PSEUDO-ATOMIC diff --git a/src/compiler/x86/move.lisp b/src/compiler/x86/move.lisp index 24b4083..2c198a9 100644 --- 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))) ;;;; moves and coercions diff --git a/src/compiler/x86/subprim.lisp b/src/compiler/x86/subprim.lisp index 1e9e532..a922c85 100644 --- 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 --- 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 --- 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 --- 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" -- 1.7.10.4