Steel Bank Common Lisp

Update of /cvsroot/sbcl/sbcl/src/compiler/ppc
In directory fdv4jf1.ch3.sourceforge.com:/tmp/cvs-serv19214/src/compiler/ppc

Modified Files:
	array.lisp call.lisp cell.lisp macros.lisp move.lisp 
	subprim.lisp type-vops.lisp values.lisp 
Log Message:
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.


Index: array.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/ppc/array.lisp,v
retrieving revision 1.16
retrieving revision 1.17
diff -u -d -r1.16 -r1.17
--- array.lisp	8 May 2009 03:00:26 -0000	1.16
+++ array.lisp	21 May 2009 21:03:37 -0000	1.17
@@ -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)

Index: call.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/ppc/call.lisp,v
retrieving revision 1.22
retrieving revision 1.23
diff -u -d -r1.22 -r1.23
--- call.lisp	19 Sep 2008 20:56:21 -0000	1.22
+++ call.lisp	21 May 2009 21:03:37 -0000	1.23
@@ -1208,7 +1208,7 @@
                 (: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

Index: cell.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/ppc/cell.lisp,v
retrieving revision 1.14
retrieving revision 1.15
diff -u -d -r1.14 -r1.15
--- cell.lisp	8 May 2009 19:08:08 -0000	1.14
+++ cell.lisp	21 May 2009 21:03:37 -0000	1.15
@@ -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)

Index: macros.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/ppc/macros.lisp,v
retrieving revision 1.16
retrieving revision 1.17
diff -u -d -r1.16 -r1.17
--- macros.lisp	19 Sep 2008 20:56:21 -0000	1.16
+++ macros.lisp	21 May 2009 21:03:37 -0000	1.17
@@ -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)))))
+(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))))
 
-(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)))
-
-
-(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)))
+  (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)))
-
-(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
 

Index: move.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/ppc/move.lisp,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -d -r1.5 -r1.6
--- move.lisp	21 Feb 2006 22:59:32 -0000	1.5
+++ move.lisp	21 May 2009 21:03:38 -0000	1.6
@@ -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)))
 
 
 

Index: subprim.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/ppc/subprim.lisp,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -d -r1.3 -r1.4
--- subprim.lisp	14 Jul 2005 18:48:33 -0000	1.3
+++ subprim.lisp	21 May 2009 21:03:38 -0000	1.4
@@ -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))))

Index: type-vops.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/ppc/type-vops.lisp,v
retrieving revision 1.6
retrieving revision 1.7
diff -u -d -r1.6 -r1.7
--- type-vops.lisp	14 Jul 2005 18:48:33 -0000	1.6
+++ type-vops.lisp	21 May 2009 21:03:38 -0000	1.7
@@ -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)

Index: values.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/ppc/values.lisp,v
retrieving revision 1.6
retrieving revision 1.7
diff -u -d -r1.6 -r1.7
--- values.lisp	14 Jul 2005 18:48:33 -0000	1.6
+++ values.lisp	21 May 2009 21:03:38 -0000	1.7
@@ -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))))