From f33fdd489e9012e5064d35ca7edc7d4bc3c4a0c2 Mon Sep 17 00:00:00 2001 From: Nathan Froyd Date: Thu, 21 May 2009 21:03:34 +0000 Subject: [PATCH] 1.0.28.68: move PPC over to slimmed-down EMIT-ERROR-BREAK interface nyef pointed out that compiler/generic/array.lisp was kinda ugly with the #!+ condition goo it in. This patch is the first step towards moving all backends over to the slimmer EMIT-ERROR-BREAK interface--one that doesn't require duplicating lots of error generation code in VOP generation functions. --- src/assembly/ppc/arith.lisp | 6 +-- src/assembly/ppc/assem-rtns.lisp | 4 +- src/compiler/generic/array.lisp | 16 ++++---- src/compiler/ppc/array.lisp | 2 +- src/compiler/ppc/call.lisp | 2 +- src/compiler/ppc/cell.lisp | 4 +- src/compiler/ppc/macros.lisp | 78 +++++++++++++------------------------- src/compiler/ppc/move.lisp | 2 +- src/compiler/ppc/subprim.lisp | 5 ++- src/compiler/ppc/type-vops.lisp | 10 ++--- src/compiler/ppc/values.lisp | 2 +- version.lisp-expr | 2 +- 12 files changed, 54 insertions(+), 79 deletions(-) diff --git a/src/assembly/ppc/arith.lisp b/src/assembly/ppc/arith.lisp index fd5fad9..5f99d5a 100644 --- a/src/assembly/ppc/arith.lisp +++ b/src/assembly/ppc/arith.lisp @@ -217,7 +217,7 @@ (:res quo any-reg nl2-offset) (:res rem any-reg nl0-offset)) (aver (location= rem dividend)) - (let ((error (generate-error-code nil division-by-zero-error + (let ((error (generate-error-code nil 'division-by-zero-error dividend divisor))) (inst cmpwi divisor 0) (inst beq error)) @@ -242,7 +242,7 @@ (:res rem any-reg nl0-offset)) (aver (location= rem dividend)) - (let ((error (generate-error-code nil division-by-zero-error + (let ((error (generate-error-code nil 'division-by-zero-error dividend divisor))) (inst cmpwi divisor 0) (inst beq error)) @@ -267,7 +267,7 @@ (:res quo signed-reg nl2-offset) (:res rem signed-reg nl0-offset)) - (let ((error (generate-error-code nil division-by-zero-error + (let ((error (generate-error-code nil 'division-by-zero-error dividend divisor))) (inst cmpwi divisor 0) (inst beq error)) diff --git a/src/assembly/ppc/assem-rtns.lisp b/src/assembly/ppc/assem-rtns.lisp index 6536197..b0b7057 100644 --- a/src/assembly/ppc/assem-rtns.lisp +++ b/src/assembly/ppc/assem-rtns.lisp @@ -153,7 +153,7 @@ (:temp target-uwp any-reg nl2-offset)) (declare (ignore start count)) - (let ((error (generate-error-code nil invalid-unwind-error))) + (let ((error (generate-error-code nil 'invalid-unwind-error))) (inst cmpwi block 0) (inst beq error)) @@ -191,7 +191,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 cmpwi catch 0) (inst beq error)) diff --git a/src/compiler/generic/array.lisp b/src/compiler/generic/array.lisp index cf0f2fd..744f89e 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 - #!+(or x86 x86-64) 'nil-array-accessed-error - #!-(or x86 x86-64) nil-array-accessed-error + #!+(or x86 x86-64 ppc) 'nil-array-accessed-error + #!-(or x86 x86-64 ppc) 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 - #!+(or x86 x86-64) 'nil-array-accessed-error - #!-(or x86 x86-64) nil-array-accessed-error + #!+(or x86 x86-64 ppc) 'nil-array-accessed-error + #!-(or x86 x86-64 ppc) 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 - #!+(or x86 x86-64) 'nil-array-accessed-error - #!-(or x86 x86-64) nil-array-accessed-error + #!+(or x86 x86-64 ppc) 'nil-array-accessed-error + #!-(or x86 x86-64 ppc) 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 - #!+(or x86 x86-64) 'nil-array-accessed-error - #!-(or x86 x86-64) nil-array-accessed-error + #!+(or x86 x86-64 ppc) 'nil-array-accessed-error + #!-(or x86 x86-64 ppc) nil-array-accessed-error object))) ;;; FIXME: There is probably plenty of other array stuff that looks diff --git a/src/compiler/ppc/array.lisp b/src/compiler/ppc/array.lisp index 81f79c0..8ae5ee1 100644 --- a/src/compiler/ppc/array.lisp +++ b/src/compiler/ppc/array.lisp @@ -78,7 +78,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))) (inst cmplw index bound) (inst bge error) diff --git a/src/compiler/ppc/call.lisp b/src/compiler/ppc/call.lisp index e8cfc9a..b490dee 100644 --- a/src/compiler/ppc/call.lisp +++ b/src/compiler/ppc/call.lisp @@ -1208,7 +1208,7 @@ default-value-8 (:vop-var vop) (:save-p :compute-only) (:generator 1000 - (error-call vop ,error ,@args))))) + (error-call vop ',error ,@args))))) (frob arg-count-error invalid-arg-count-error sb!c::%arg-count-error nargs) (frob type-check-error object-not-type-error sb!c::%type-check-error diff --git a/src/compiler/ppc/cell.lisp b/src/compiler/ppc/cell.lisp index 00bff09..c3a3fbd 100644 --- a/src/compiler/ppc/cell.lisp +++ b/src/compiler/ppc/cell.lisp @@ -54,7 +54,7 @@ (:generator 9 (move obj-temp object) (loadw value obj-temp symbol-value-slot other-pointer-lowtag) - (let ((err-lab (generate-error-code vop unbound-symbol-error obj-temp))) + (let ((err-lab (generate-error-code vop 'unbound-symbol-error obj-temp))) (inst cmpwi value unbound-marker-widetag) (inst beq err-lab)))) @@ -115,7 +115,7 @@ (move obj-temp object) (loadw value obj-temp fdefn-fun-slot other-pointer-lowtag) (inst cmpw value null-tn) - (let ((err-lab (generate-error-code vop undefined-fun-error obj-temp))) + (let ((err-lab (generate-error-code vop 'undefined-fun-error obj-temp))) (inst beq err-lab)))) (define-vop (set-fdefn-fun) diff --git a/src/compiler/ppc/macros.lisp b/src/compiler/ppc/macros.lisp index 06f3226..e566001 100644 --- a/src/compiler/ppc/macros.lisp +++ b/src/compiler/ppc/macros.lisp @@ -252,62 +252,36 @@ ;;;; Error Code -(eval-when (:compile-toplevel :load-toplevel :execute) - (defun emit-error-break (vop kind code values) - (let ((vector (gensym))) - `((let ((vop ,vop)) - (when vop - (note-this-location vop :internal-error))) - (inst unimp ,kind) - (with-adjustable-vector (,vector) - (write-var-integer (error-number-or-lose ',code) ,vector) - ,@(mapcar #'(lambda (tn) - `(let ((tn ,tn)) - (write-var-integer (make-sc-offset (sc-number - (tn-sc tn)) - (tn-offset tn)) - ,vector))) - values) - (inst byte (length ,vector)) - (dotimes (i (length ,vector)) - (inst byte (aref ,vector i)))) - (emit-alignment word-shift))))) - -(defmacro error-call (vop error-code &rest values) +(defun emit-error-break (vop kind code values) + (assemble () + (when vop + (note-this-location vop :internal-error)) + (inst unimp kind) + (with-adjustable-vector (vector) + (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))) + (emit-alignment word-shift)))) + +(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 cerror-call (vop label error-code &rest values) - "Cause a continuable error. If the error is continued, execution resumes at - LABEL." - `(progn - ,@(emit-error-break vop cerror-trap error-code values) - (inst b ,label))) - -(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))) - -(defmacro generate-cerror-code (vop error-code &rest values) - "Generate-CError-Code Error-code Value* - Emit code for a continuable error with the specified Error-Code and - context Values. If the error is continued, execution resumes after - the GENERATE-CERROR-CODE form." - (with-unique-names (continue error) - `(let ((,continue (gen-label))) - (emit-label ,continue) - (assemble (*elsewhere*) - (let ((,error (gen-label))) - (emit-label ,error) - (cerror-call ,vop ,continue ,error-code ,@values) - ,error))))) + (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/ppc/move.lisp b/src/compiler/ppc/move.lisp index b410c4c..966925b 100644 --- a/src/compiler/ppc/move.lisp +++ b/src/compiler/ppc/move.lisp @@ -123,7 +123,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))) diff --git a/src/compiler/ppc/subprim.lisp b/src/compiler/ppc/subprim.lisp index e825565..1f3c090 100644 --- a/src/compiler/ppc/subprim.lisp +++ b/src/compiler/ppc/subprim.lisp @@ -22,7 +22,7 @@ (:generator 50 (let ((done (gen-label)) (loop (gen-label)) - (not-list (generate-cerror-code vop object-not-list-error object))) + (not-list (gen-label))) (move ptr object) (move count zero-tn) @@ -37,7 +37,8 @@ (inst addi count count (fixnumize 1)) (test-type ptr loop nil (list-pointer-lowtag) :temp temp) - (cerror-call vop done object-not-list-error ptr) + (emit-label not-list) + (error-call vop 'object-not-list-error ptr) (emit-label done) (move result count)))) diff --git a/src/compiler/ppc/type-vops.lisp b/src/compiler/ppc/type-vops.lisp index 2780264..4e46b6d 100644 --- a/src/compiler/ppc/type-vops.lisp +++ b/src/compiler/ppc/type-vops.lisp @@ -144,7 +144,7 @@ ((lowtag-mask) type-codes))) (move result value)) `((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) :temp temp) (move result value)))))))) ,@(when ptype @@ -175,7 +175,7 @@ (define-vop (check-signed-byte-32 check-type) (:generator 45 - (let ((nope (generate-error-code vop object-not-signed-byte-32-error value)) + (let ((nope (generate-error-code vop 'object-not-signed-byte-32-error value)) (yep (gen-label))) (inst andi. temp value #x3) (inst beq yep) @@ -239,7 +239,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))) @@ -299,7 +299,7 @@ (define-vop (check-symbol check-type) (:generator 12 (let ((drop-thru (gen-label)) - (error (generate-error-code vop object-not-symbol-error value))) + (error (generate-error-code vop 'object-not-symbol-error value))) (inst cmpw value null-tn) (inst beq drop-thru) (test-type value error t (symbol-header-widetag) :temp temp) @@ -318,7 +318,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 cmpw value null-tn) (inst beq error) (test-type value error t (list-pointer-lowtag) :temp temp) diff --git a/src/compiler/ppc/values.lisp b/src/compiler/ppc/values.lisp index beb3057..7f868c1 100644 --- a/src/compiler/ppc/values.lisp +++ b/src/compiler/ppc/values.lisp @@ -105,7 +105,7 @@ (inst addi csp-tn csp-tn n-word-bytes) (storew temp csp-tn -1) (test-type list loop nil (list-pointer-lowtag) :temp ndescr) - (error-call vop bogus-arg-to-values-list-error list) + (error-call vop 'bogus-arg-to-values-list-error list) (emit-label done) (inst sub count csp-tn start)))) diff --git a/version.lisp-expr b/version.lisp-expr index 564e940..7d7fe8c 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.28.67" +"1.0.28.68" -- 1.7.10.4