1.0.28.57: cross compiler is able to reason about host complexes

  ...based on the type the host object will take in target,
  which just needs to follow the same logic our dumper uses.

  ...fixing which shows the the new FILL transform didn't handle
  complex single floats quite right yet.

diff --git a/src/code/cross-type.lisp b/src/code/cross-type.lisp
index 730a764..32becc3 100644 (file)
--- a/src/code/cross-type.lisp
+++ b/src/code/cross-type.lisp
@@ -214,12 +214,26 @@
                     (values (typep host-object target-type) t))
                    (t
                     (values nil t))))
-            (;; Complexes suffer the same kind of problems as arrays
+            (;; Complexes suffer the same kind of problems as arrays.
+             ;; Our dumping logic is based on contents, however, so
+             ;; reasoning about them should be safe
              (and (not (hairy-type-p (values-specifier-type target-type)))
                   (sb!xc:subtypep target-type 'cl:complex))
              (if (complexp host-object)
-                 (warn-and-give-up) ; general-case complexes being way too hard
-                 (values nil t))) ; but "obviously not a complex" being easy
+                 (let ((re (realpart host-object))
+                       (im (imagpart host-object)))
+                   (if (or (and (eq target-type 'complex)
+                                (typep re 'rational) (typep im 'rational))
+                           (and (equal target-type '(cl:complex single-float))
+                                (typep re 'single-float) (typep im 'single-float))
+                           (and (equal target-type '(cl:complex double-float))
+                                (typep re 'double-float) (typep im 'double-float)))
+                       (values t t)
+                       (progn
+                         ;; We won't know how to dump it either.
+                         (warn "Host complex too complex: ~S" host-object)
+                         (warn-and-give-up))))
+                 (values nil t)))
             ;; Some types require translation between the cross-compilation
             ;; host Common Lisp and the target SBCL.
             ((target-type-is-in '(classoid))

diff --git a/src/compiler/seqtran.lisp b/src/compiler/seqtran.lisp
index 3c25cc4..065674e 100644 (file)
--- a/src/compiler/seqtran.lisp
+++ b/src/compiler/seqtran.lisp
@@ -535,8 +535,14 @@
                   (kind (cond ((sb!vm:saetp-fixnum-p saetp) :tagged)
                               ((member element-type '(character base-char)) :char)
                               ((eq element-type 'single-float) :single-float)
+                              #!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or))
                               ((eq element-type 'double-float) :double-float)
-                              (t :bits)))
+                              #!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or))
+                              ((equal element-type '(complex single-float))
+                               :complex-single-float)
+                              (t
+                               (aver (integer-type-p element-ctype))
+                               :bits)))
                   ;; BASH-VALUE is a word that we can repeatedly smash
                   ;; on the array: for less-than-word sized elements it
                   ;; contains multiple copies of the fill item.
@@ -556,9 +562,14 @@
                                          tmp)
                                         (:single-float
                                          (single-float-bits tmp))
+                                        #!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or))
                                         (:double-float
                                          (logior (ash (double-float-high-bits tmp) 32)
-                                                 (double-float-low-bits tmp))))))
+                                                 (double-float-low-bits tmp)))
+                                        #!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or))
+                                        (:complex-single-float
+                                         (logior (ash (single-float-bits (imagpart tmp)) 32)
+                                                 (single-float-bits (realpart tmp)))))))
                                 (res bits))
                            (loop for i of-type sb!vm:word from n-bits by n-bits
                                  until (= i sb!vm:n-word-bits)
@@ -575,9 +586,14 @@
                                                    `item)
                                                   (:single-float
                                                    `(single-float-bits item))
+                                                  #!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or))
                                                   (:double-float
                                                    `(logior (ash (double-float-high-bits item) 32)
-                                                            (double-float-low-bits item))))))
+                                                            (double-float-low-bits item)))
+                                                  #!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or))
+                                                  (:complex-single-float
+                                                   `(logior (ash (single-float-bits (imagpart item)) 32)
+                                                            (single-float-bits (realpart item)))))))
                                (res bits))
                           (declare (type sb!vm:word res))
                           ,@(unless (= sb!vm:n-word-bits n-bits)

diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp
index ca3c9a4..db2bfc4 100644 (file)
--- a/tests/compiler.pure.lisp
+++ b/tests/compiler.pure.lisp
@@ -2906,3 +2906,14 @@
    (= sb-vm:complex-double-float-widetag
       (sb-kernel:widetag-of
        (sb-vm:saetp-initial-element-default (sb-c::find-saetp '(complex double-float)))))))
+
+(with-test (:name :complex-single-float-fill)
+  (assert (every (lambda (x) (= #c(1.0 2.0) x))
+                 (funcall
+                  (compile nil
+                           `(lambda (n x)
+                              (make-array (list n)
+                                          :element-type '(complex single-float)
+                                          :initial-element x)))
+                  10
+                  #c(1.0 2.0)))))

diff --git a/version.lisp-expr b/version.lisp-expr
index da1c770..27774ee 100644 (file)
--- 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.56"
+"1.0.28.57"