From 7f9f1fd113d7047731bda9dab2c7719cdf092a21 Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Mon, 18 May 2009 07:58:11 +0000 Subject: [PATCH] 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. --- src/code/cross-type.lisp | 20 +++++++++++++++++--- src/compiler/seqtran.lisp | 22 +++++++++++++++++++--- tests/compiler.pure.lisp | 11 +++++++++++ version.lisp-expr | 2 +- 4 files changed, 48 insertions(+), 7 deletions(-) diff --git a/src/code/cross-type.lisp b/src/code/cross-type.lisp index 730a764..32becc3 100644 --- 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 --- 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 --- 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 --- 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" -- 1.7.10.4