[Openmcl-cvs-notifications] r9261 - /trunk/source/compiler/PPC/ppc2.lisp

[gb at clozure.com]

Author: gb
Date: Thu Apr 24 05:32:53 2008
New Revision: 9261

Log:
THE typechecking in PPC backend, too.

Modified:
    trunk/source/compiler/PPC/ppc2.lisp

Modified: trunk/source/compiler/PPC/ppc2.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/compiler/PPC/ppc2.lisp (original)
+++ trunk/source/compiler/PPC/ppc2.lisp Thu Apr 24 05:32:53 2008
@@ -5521,9 +5521,10 @@
 (defppc2 ppc2-svset svset (seg vreg xfer vector index value)
   (ppc2-vset seg vreg xfer :simple-vector  vector index value (nx-lookup-t=
arget-uvector-subtag :simple-vector)))
 =

-(defppc2 ppc2-typed-form typed-form (seg vreg xfer typespec form)
-  (declare (ignore typespec)) ; Boy, do we ever !
-  (ppc2-form seg vreg xfer form))
+(defppc2 ppc2-typed-form typed-form (seg vreg xfer typespec form &optional=
 check)
+  (if check
+    (ppc2-typechecked-form seg vreg xfer typespec form)
+    (ppc2-form seg vreg xfer form)))
 =

 (defppc2 ppc2-%primitive %primitive (seg vreg xfer &rest ignore)
   (declare (ignore seg vreg xfer ignore))
@@ -7966,6 +7967,62 @@
   (def-ppc2-require ppc2-require-s8 require-s64)
   (def-ppc2-require ppc2-require-s8 require-u64))
 =

+(defun ppc2-typechecked-form (seg vreg xfer typespec form)
+  (with-ppc-local-vinsn-macros (seg vreg xfer)
+    (let* ((op
+            (cond ((eq typespec 'fixnum) (%nx1-operator require-fixnum))
+                  ((eq typespec 'integer) (%nx1-operator require-integer))
+                  ((memq typespec '(base-char character))
+                   (%nx1-operator require-character))
+                  ((eq typespec 'symbol) (%nx1-operator require-symbol))
+                  ((eq typespec 'list) (%nx1-operator require-list))
+                  ((eq typespec 'real) (%nx1-operator require-real))
+                  ((memq typespec '(simple-base-string simple-string))
+                   (%nx1-operator require-simple-string))
+                  ((eq typespec 'number) (%nx1-operator require-number))
+                  ((eq typespec 'simple-vector) (%nx1-operator require-sim=
ple-vector))
+                  (t
+                   (let* ((ctype (specifier-type typespec)))
+                     (cond ((type=3D ctype (load-time-value (specifier-typ=
e '(signed-byte 8))))
+                            (%nx1-operator require-s8))
+                           ((type=3D ctype (load-time-value (specifier-typ=
e '(unsigned-byte 8))))
+                            (%nx1-operator require-u8))
+                           ((type=3D ctype (load-time-value (specifier-typ=
e '(signed-byte 16))))
+                            (%nx1-operator require-s16))
+                           ((type=3D ctype (load-time-value (specifier-typ=
e '(unsigned-byte 16))))
+                            (%nx1-operator require-u16))
+                           ((type=3D ctype (load-time-value (specifier-typ=
e '(signed-byte 32))))                            =

+                            (%nx1-operator require-s32))
+                           ((type=3D ctype (load-time-value (specifier-typ=
e '(unsigned-byte 32))))
+                            (%nx1-operator require-u32))
+                           ((type=3D ctype (load-time-value (specifier-typ=
e '(signed-byte 64))))
+                            (%nx1-operator require-s64))
+                           ((type=3D ctype (load-time-value (specifier-typ=
e '(unsigned-byte 64))))
+                            (%nx1-operator require-u64))))))))
+      (if op
+        (ppc2-use-operator op seg vreg xfer form)
+        (if (or (eq typespec t)
+                (eq typespec '*))
+          (ppc2-form seg vreg xfer form)
+          (let* ((ok (backend-get-next-label)))
+            (ppc2-one-targeted-reg-form seg form ($ ppc::arg_y))
+            (ppc2-store-immediate seg typespec ($ ppc::arg_z))
+            (ppc2-store-immediate seg 'typep ($ ppc::fname))
+            (ppc2-set-nargs seg 2)
+            (ppc2-vpush-register seg ($ ppc::arg_y))
+            (! call-known-symbol ($ ppc::arg_z))
+	    (with-crf-target () crf
+               (! compare-to-nil crf ($ ppc::arg_z))
+	       (ppc2-vpop-register seg ($ ppc::arg_y))
+	       (! cbranch-false (aref *backend-labels* ok) crf ppc::ppc-eq-bit))
+            (ppc2-lri seg ($ ppc::arg_x) (ash $XWRONGTYPE *ppc2-target-fix=
num-shift*))
+            (ppc2-store-immediate seg typespec ($ ppc::arg_z))
+            (ppc2-set-nargs seg 3)
+            (! ksignalerr)
+            (@ ok)
+            (<- ($ ppc::arg_y))
+            (^)))))))
+
 (defppc2 ppc2-%badarg2 %badarg2 (seg vreg xfer badthing goodthing)
   (ppc2-two-targeted-reg-forms seg badthing ($ ppc::arg_y) goodthing ($ pp=
c::arg_z))
   (ppc2-lri seg ($ ppc::arg_x) (ash $XWRONGTYPE *ppc2-target-fixnum-shift*=
))