[Openmcl-cvs-notifications] r11876 - in /trunk/source: compiler/optimizers.lisp lib/sequences.lisp

[gb at clozure.com]

Author: gb
Date: Tue Mar 31 20:27:19 2009
New Revision: 11876

Log:
Try to simplify COERCE-ing to certain recognizable subtypes of SEQUENCE
via compiler-macro/runtime support.

Modified:
    trunk/source/compiler/optimizers.lisp
    trunk/source/lib/sequences.lisp

Modified: trunk/source/compiler/optimizers.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/optimizers.lisp (original)
+++ trunk/source/compiler/optimizers.lisp Tue Mar 31 20:27:19 2009
@@ -2276,14 +2276,36 @@
                (the single-float (%short-float ,temp))))))
         (t call)))
 =

-(define-compiler-macro coerce (&whole call thing type)
-  (if (quoted-form-p type)
-    (setq type (cadr type)))
-  (if (ignore-errors (subtypep type 'single-float))
-    `(float ,thing 0.0f0)
-    (if (ignore-errors (subtypep type 'double-float))
-      `(float ,thing 0.0d0)
-      call)))
+(define-compiler-macro coerce (&whole call &environment env thing type)
+  (cond ((constantp type)
+         (if (quoted-form-p type)
+           (setq type (cadr type)))
+         (if (ignore-errors (subtypep type 'single-float))
+           `(float ,thing 0.0f0)
+           (if (ignore-errors (subtypep type 'double-float))
+             `(float ,thing 0.0d0)
+             (let* ((ctype (specifier-type-if-known type env))
+                    (simple nil)
+                    (extra nil))
+               (if (and (typep ctype 'array-ctype)
+                        (equal (array-ctype-dimensions ctype) '(*)))
+                 (if (eq (array-ctype-specialized-element-type ctype)
+                         (specifier-type 'character))
+                   (setq simple '%coerce-to-string)
+                   (if (and (eq *host-backend* *target-backend*)
+                            (array-ctype-typecode ctype))
+                     (setq simple '%coerce-to-vector
+                           extra (list (array-ctype-typecode ctype)))))
+                 (if (eq ctype (specifier-type 'list))
+                   (setq simple '%coerce-to-list)))
+               (if simple
+                 (let* ((temp (gensym)))
+                   `(let* ((,temp ,thing))
+                     (if (typep ,temp ',(type-specifier ctype))
+                       ,temp
+                       (,simple ,temp , at extra))))
+               call)))))
+        (t call)))
 =

 (define-compiler-macro equal (&whole call x y &environment env)
   (if (or (equal-iff-eql-p x env)

Modified: trunk/source/lib/sequences.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/lib/sequences.lisp (original)
+++ trunk/source/lib/sequences.lisp Tue Mar 31 20:27:19 2009
@@ -844,6 +844,43 @@
            res))
         (t (error "~S can't be coerced to type ~S." object output-type-spe=
c))))))
 =

+(defun %coerce-to-string (seq)
+   (let* ((len (length seq))
+          (string (make-string len)))
+     (declare (fixnum len) (simple-base-string string))
+     (if (typep seq 'list)
+       (do* ((l seq (cdr l))
+             (i 0 (1+ i)))
+            ((null l) string)
+         (declare (list l) ; we know that it's a proper list because LENGT=
H won
+                  (fixnum i))
+         (setf (schar string i) (car l)))
+       (dotimes (i len string)
+         (setf (schar string i) (aref seq i))))))
+
+(defun %coerce-to-vector (seq subtype)
+   (let* ((len (length seq))
+          (vector (%alloc-misc len subtype)))
+     (declare (fixnum len) (type (simple-array * (*)) vector))
+     (if (typep seq 'list)
+       (do* ((l seq (cdr l))
+             (i 0 (1+ i)))
+            ((null l) vector)
+         (declare (list l) ; we know that it's a proper list because LENGT=
H won
+                  (fixnum i))
+         (setf (uvref vector i) (car l)))
+       (dotimes (i len vector)
+         (setf (uvref vector i) (aref seq i))))))
+
+(defun %coerce-to-list (seq)
+  (if (typep seq 'list)
+    seq
+    (collect ((result))
+      (dotimes (i (length seq) (result))
+        (result (aref seq i))))))
+
+
+
 =

 (defun coerce-to-complex (object  output-type-spec)
   (if (consp output-type-spec)