[Sbcl-commits] master: Optimize (coerce x 'complex).

[stassats <sta...@us...>]

The branch "master" has been updated in SBCL:
       via  aab5bd0d43016a52b5cf0df34885f0d97b03a804 (commit)
      from  f3ac5c2e35d43d0d9d04b09cf71ebc5a47a4dd91 (commit)

- Log -----------------------------------------------------------------
commit aab5bd0d43016a52b5cf0df34885f0d97b03a804
Author: Stas Boukarev <sta...@gm...>
Date:   Sat Apr 19 15:15:05 2014 +0400

    Optimize (coerce x 'complex).
    
    Transform it into appropriate calls to COMPLEX, coercing to proper
    float types as necessary.
    
    Closes lp#1309815.
---
 NEWS                       |    8 +++++---
 src/compiler/typetran.lisp |   29 ++++++++++++++++++++++++-----
 2 files changed, 29 insertions(+), 8 deletions(-)

diff --git a/NEWS b/NEWS
index fcc469f..1ebca79 100644
--- a/NEWS
+++ b/NEWS
@@ -1,11 +1,13 @@
 ;;;; -*- coding: utf-8; fill-column: 78 -*-
 changes relative to sbcl-1.1.17:
+  * optimization: (coerce x 'complex) is now as efficient as (complex x).
+    (lp#1309815)
   * bug fix: correctly inherit condition initforms. (lp#1300904)
   * bug fix: properly pprint literal functions inside nested lists.
     (lp#1300716)
-  * bug fix: more-correctly handle array-type unity (broken for ages,
-causing compilation problems since 1.1.13.x due to smarter TYPEP type
-propagation, reported by jasom in #lisp).
+  * bug fix: more-correctly handle array-type unity (broken for ages, causing
+    compilation problems since 1.1.13.x due to smarter TYPEP type propagation,
+    reported by jasom in #lisp).
 
 changes in sbcl-1.1.17 relative to sbcl-1.1.16:
   * enhancement: printing backtraces respects
diff --git a/src/compiler/typetran.lisp b/src/compiler/typetran.lisp
index 6b11d7b..7b97c2f 100644
--- a/src/compiler/typetran.lisp
+++ b/src/compiler/typetran.lisp
@@ -730,13 +730,32 @@
           ;; FIXME: #!+long-float (t ,(error "LONG-FLOAT case needed"))
           ((csubtypep tspec (specifier-type 'float))
            `(the ,tval (%single-float x)))
+          ((csubtypep tspec (specifier-type 'complex))
+           (let ((part-type (cond ((numeric-type-p tspec)
+                                   (numeric-type-format tspec))
+                                  ((csubtypep tspec (specifier-type '(complex float)))
+                                   'float)
+                                  (t
+                                   t))))
+             `(cond ,@(and (eq part-type t)
+                           `(((typep x 'rational)
+                              x)))
+                    (t
+                     (the ,tval
+                          (cond ((not (typep x 'complex))
+                                 (complex (coerce x ',part-type)))
+                                ((typep x ',tval)
+                                 x)
+                                (t
+                                 (complex (coerce (realpart x) ',part-type)
+                                          (coerce (imagpart x) ',part-type)))))))))
            ;; Special case STRING and SIMPLE-STRING as they are union types
            ;; in SBCL.
-           ((member tval '(string simple-string))
-            `(the ,tval
-               (if (typep x ',tval)
-                   x
-                   (replace (make-array (length x) :element-type 'character) x))))
+          ((member tval '(string simple-string))
+           `(the ,tval
+                 (if (typep x ',tval)
+                     x
+                     (replace (make-array (length x) :element-type 'character) x))))
            ;; Special case VECTOR
            ((eq tval 'vector)
             `(the ,tval

-----------------------------------------------------------------------


hooks/post-receive
-- 
SBCL