From c6538bf61955a67d0145aa3e6c937f6dd03f9e51 Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Thu, 8 May 2008 15:05:22 +0000 Subject: [PATCH] 1.0.16.27: function-ify ERROR-CALL and GENERATE-ERROR-CODE on x86-64 * Port of 1.0.16.10 to x86-64. --- src/assembly/x86-64/alloc.lisp | 2 +- src/assembly/x86-64/assem-rtns.lisp | 4 +- src/compiler/generic/array.lisp | 16 ++++---- src/compiler/x86-64/arith.lisp | 6 +-- src/compiler/x86-64/array.lisp | 2 +- src/compiler/x86-64/call.lisp | 4 +- src/compiler/x86-64/cell.lisp | 10 ++--- src/compiler/x86-64/macros.lisp | 79 +++++++++++++++++-------------------- src/compiler/x86-64/move.lisp | 2 +- src/compiler/x86-64/subprim.lisp | 2 +- src/compiler/x86-64/type-vops.lisp | 10 ++--- src/compiler/x86-64/values.lisp | 2 +- src/compiler/x86/macros.lisp | 43 +++----------------- version.lisp-expr | 2 +- 14 files changed, 73 insertions(+), 111 deletions(-) diff --git a/src/assembly/x86-64/alloc.lisp b/src/assembly/x86-64/alloc.lisp index ba27b1b4a..68a8ce33c 100644 --- 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 9083075d6..dea6cbb3f 100644 --- 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 3f7da3e3b..cf0f2fd52 100644 --- 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))) ;;; 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 0daa98dbc..d0436d5d9 100644 --- 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 c73b4eb73..504ef62ca 100644 --- 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 8e1da4d17..883be9025 100644 --- 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 2f546a6c6..2a0234027 100644 --- 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 9393c2b59..9857d1543 100644 --- a/src/compiler/x86-64/macros.lisp +++ b/src/compiler/x86-64/macros.lisp @@ -230,55 +230,48 @@ ,@forms))) ;;;; 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))) diff --git a/src/compiler/x86-64/move.lisp b/src/compiler/x86-64/move.lisp index 1921dfacc..4f37f5a36 100644 --- 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))) ;;;; moves and coercions diff --git a/src/compiler/x86-64/subprim.lisp b/src/compiler/x86-64/subprim.lisp index 4b3eed298..1f44f03f8 100644 --- 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 43b838c01..450a6a494 100644 --- 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 c135c83ba..05b00d6fb 100644 --- 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 378a2ca06..df6f8560c 100644 --- 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 bc61bdcf3..87275a462 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.26" +"1.0.16.27" -- 2.11.4.GIT