Cross compiling SBCL
Douglas Katzman made SBCL cross compilation work with ECL being host. This commit indicates that there are a few bugs in ECL. Go through it and either report issues or fix them all and close this issue.
My attention to this commit was directed by Jan Moringen (thank you!).
From e2752c4b38b6836336a63074723857f2ac048578 Mon Sep 17 00:00:00 2001
From: Douglas Katzman <dougk@google.com>
Date: Thu, 31 Jan 2019 01:47:47 -0500
Subject: [PATCH] Tweak things to allow use of ECL as host lisp
* Call SB-XC:SUBTYPEP in GENERATE-NUMBER-DISPATCH, not the host's
* Don't pass improper lists to MAPC in the disassembler.
This looks to have been a genuine bug in our code.
* Ignore contents of COMMON-LISP-USER package in genesis
* Workaround ECL compiler bugs
- discrimination of complex floats in compiled code is wrong.
- disable the SB-INT:INFO compiler macro.
- miscompilation of SB-ASSEM::LABEL-POSITION which is mysteriously fixed
by not proclaiming the ftype.
Build succeeds with ECL 16.1.3
---
make-host-1.lisp | 6 ++++++
src/code/cross-type.lisp | 28 ++++++++++++++++++++++++++++
src/code/numbers.lisp | 6 +++---
src/compiler/assem.lisp | 2 ++
src/compiler/disassem.lisp | 14 +++++++++++---
src/compiler/early-globaldb.lisp | 4 ++++
src/compiler/generic/genesis.lisp | 5 ++++-
src/compiler/x86-64/vm.lisp | 2 ++
tests/type.before-xc.lisp | 6 ++++++
9 files changed, 66 insertions(+), 7 deletions(-)
diff --git a/make-host-1.lisp b/make-host-1.lisp
index d68aa22c7..6927cf950 100644
--- a/make-host-1.lisp
+++ b/make-host-1.lisp
@@ -65,6 +65,12 @@
(dolist (s '(sb-cold::slurp-ucd sb-cold::slurp-proplist sb-cold::output))
(funcall s))
+;;; I don't know the best combination of OPTIMIZE qualities to produce a correct
+;;; and reasonably fast cross-compiler in ECL. At over half an hour to complete
+;;; each test run, I don't really want to waste any more time finding out.
+;;; These settings work, while the defaults do not.
+#+ecl (proclaim '(optimize (safety 2) (debug 2)))
+
(maybe-with-compilation-unit
(let ((*feature-evaluation-results* nil))
(load-or-cload-xcompiler #'host-cload-stem)
diff --git a/src/code/cross-type.lisp b/src/code/cross-type.lisp
index 5c95b752c..066c1b8dd 100644
--- a/src/code/cross-type.lisp
+++ b/src/code/cross-type.lisp
@@ -76,6 +76,10 @@
(sb-c::ir1-attributep (sb-c::fun-info-attributes it) sb-c:foldable)))))
(defun complex-num-fmt-match-p (num fmt)
+ ;; compiled TYPEP on ECL is wrong. See example at bottom of this file.
+ ;; Of course, it's abstraction-breaking to suppose that TYPECASE
+ ;; directly utilizes TYPEP, but naturally it does.
+ #+(and sb-xc-host (host-feature ecl)) (declare (notinline typep))
(aver (memq fmt '(single-float double-float rational)))
(and (complexp num)
(let ((yesp (eq (etypecase (realpart num)
@@ -399,3 +403,27 @@
(defun sb-pcl::class-has-a-forward-referenced-superclass-p (x)
(bug "CLASS-HAS-A-FORWARD-REFERENCED-SUPERCLASS-P reached: ~S" x))
+
+#|
+ECL compiler strangeness:
+
+(defun foo-sd (x) ; test for single- then double-float
+ (typecase x
+ ((complex single-float) 'csf)
+ ((complex double-float) 'cdf)))
+
+(defun foo-ds (x) ; test for double- then single-float
+ (typecase x
+ ((complex double-float) 'cdf)
+ ((complex single-float) 'csf)))
+
+(defun try-both ()
+ ;; This test proves that whatever complex type is tried first wins when compiled,
+ ;; but when interpreted it gives what we would call the right answer.
+ (list (foo-sd #c(0.0s0 0.0s0)) (foo-sd #c(0.0d0 0.0d0))
+ (foo-ds #c(0.0s0 0.0s0)) (foo-ds #c(0.0d0 0.0d0))))
+
+(try-both) => (CSF CDF CSF CDF)
+(progn (compile 'foo-sd) (compile 'foo-ds))
+(try-both) => (CSF CSF CDF CDF)
+|#
diff --git a/src/code/numbers.lisp b/src/code/numbers.lisp
index 19d030b4d..9c0e4be57 100644
--- a/src/code/numbers.lisp
+++ b/src/code/numbers.lisp
@@ -87,11 +87,11 @@
(let ((var (first vars))
(cases (sort cases #'type-test-order :key #'car)))
(flet ((error-if-sub-or-supertype (type1 type2)
- (when (or (subtypep type1 type2)
- (subtypep type2 type1))
+ (when (or (sb-xc:subtypep type1 type2)
+ (sb-xc:subtypep type2 type1))
(error "Types not disjoint: ~S ~S." type1 type2)))
(error-if-supertype (type1 type2)
- (when (subtypep type2 type1)
+ (when (sb-xc:subtypep type2 type1)
(error "Type ~S ordered before subtype ~S."
type1 type2)))
(test-type-pairs (fun)
diff --git a/src/compiler/assem.lisp b/src/compiler/assem.lisp
index c0d6aaa97..84cfe83bc 100644
--- a/src/compiler/assem.lisp
+++ b/src/compiler/assem.lisp
@@ -1552,6 +1552,8 @@
(trace-inst s :align bits)
(emit s `(.align ,bits ,pattern))))
+;; ECL bug workaround: it miscompiles LABEL-POSITION with this decl
+#-(and (host-feature ecl) sb-xc-host)
(declaim (ftype (sfunction (label &optional t index) (or null index))
label-position))
(defun label-position (label &optional if-after delta)
diff --git a/src/compiler/disassem.lisp b/src/compiler/disassem.lisp
index b504db4ab..1492bf3a8 100644
--- a/src/compiler/disassem.lisp
+++ b/src/compiler/disassem.lisp
@@ -424,9 +424,17 @@
(let* ((binding (cdr rendering))
(vars (car binding))
(vals (cdr binding)))
- (if (listp vars)
- (mapc (lambda (var val) (push `(,var ,val) bindings)) vars vals)
- (push `(,vars ,vals) bindings)))))))
+ ;; We can end up here with VARS = NIL, and VALS = an atom.
+ ;; As the spec says, MAPC "should be prepared to signal an error
+ ;; ... if any list is not a proper list"
+ ;; We don't err in that situation because we check for ENDP of the
+ ;; lists from left to right. However, at least one implementation
+ ;; does rigorously use ENDP on both lists on each iteration.
+ (cond ((not vars))
+ ((listp vars)
+ (mapc (lambda (var val) (push `(,var ,val) bindings)) vars vals))
+ (t
+ (push `(,vars ,vals) bindings))))))))
;;; Return the form(s) that should be evaluated to render ARG in the chosen
;;; RENDERING style, which is one of :RAW, :SIGN-EXTENDED,
diff --git a/src/compiler/early-globaldb.lisp b/src/compiler/early-globaldb.lisp
index 8eccbd267..ce9632faa 100644
--- a/src/compiler/early-globaldb.lisp
+++ b/src/compiler/early-globaldb.lisp
@@ -192,6 +192,10 @@
.whole.)))
.whole.))))
+ ;; ECL bug workaround: INFO ceases to be a valid macrolet name
+ ;; because it tries to run the compiler-macro before the local macro.
+ ;; In particular, "(collect ((info)) ...)" will not compile correctly.
+ #-(and (host-feature ecl) sb-xc-host)
(def info (category kind name)
`(truly-the (values ,(meta-info-type-spec meta-info) boolean)
(get-info-value ,name ,(meta-info-number meta-info))))
diff --git a/src/compiler/generic/genesis.lisp b/src/compiler/generic/genesis.lisp
index 225ee837d..18d96f0eb 100644
--- a/src/compiler/generic/genesis.lisp
+++ b/src/compiler/generic/genesis.lisp
@@ -840,6 +840,8 @@ core and return a descriptor to it."
;;; Copy the given number to the core.
(defun number-to-core (number)
+ ;; compiled TYPEP on ECL is wrong. See example in cross-typep.
+ #+(and sb-xc-host (host-feature ecl)) (declare (notinline typep))
(typecase number
(integer (or (%fixnum-descriptor-if-possible number)
(bignum-to-core number)))
@@ -1745,7 +1747,8 @@ core and return a descriptor to it."
(find-layout 'package)
:%shadowing-symbols (list-to-core
(mapcar 'cold-intern shadow))))
- (unless (member pkg-name '("COMMON-LISP" "KEYWORD") :test 'string=)
+ (unless (member pkg-name '("COMMON-LISP" "COMMON-LISP-USER" "KEYWORD")
+ :test 'string=)
(let ((host-pkg (find-package pkg-name))
(sb-xc-pkg (find-package "SB-XC"))
syms)
diff --git a/src/compiler/x86-64/vm.lisp b/src/compiler/x86-64/vm.lisp
index c644e447c..bc21bab94 100644
--- a/src/compiler/x86-64/vm.lisp
+++ b/src/compiler/x86-64/vm.lisp
@@ -396,6 +396,8 @@
;;; If value can be represented as an immediate constant, then return
;;; the appropriate SC number, otherwise return NIL.
(defun immediate-constant-sc (value)
+ ;; compiled TYPEP on ECL is wrong. See example in cross-typep.
+ #+(and sb-xc-host (host-feature ecl)) (declare (notinline typep))
(typecase value
((or (integer #.sb-xc:most-negative-fixnum #.sb-xc:most-positive-fixnum)
character)
diff --git a/tests/type.before-xc.lisp b/tests/type.before-xc.lisp
index 8b403290f..5a08f4943 100644
--- a/tests/type.before-xc.lisp
+++ b/tests/type.before-xc.lisp
@@ -376,3 +376,9 @@
;; but it should also be EQ to (MEMBER NIL T)
(assert (eq (specifier-type '(member nil t)) (specifier-type 'boolean)))
+#+(and x86-64 (host-feature ecl))
+(progn
+ (assert (= (sb-vm::immediate-constant-sc #c(0.0f0 0.0f0))
+ sb-vm::fp-complex-single-zero-sc-number))
+ (assert (= (sb-vm::immediate-constant-sc #c(0.0d0 0.0d0))
+ sb-vm::fp-complex-double-zero-sc-number)))
--
2.17.1