1.0.29.27: add shebang line to fasls

[sbcl.git] / src / compiler / dump.lisp

diff --git a/src/compiler/dump.lisp b/src/compiler/dump.lisp
index 2f1958d..fa44379 100644 (file)
--- a/src/compiler/dump.lisp
+++ b/src/compiler/dump.lisp
@@ -208,7 +208,8 @@
            (type string x))
   (unless *cold-load-dump*
     (let ((handle (cdr (assoc
-                        (array-element-type x)
+                        #+sb-xc-host 'base-char ; for repeatable xc fasls
+                        #-sb-xc-host (array-element-type x)
                         (gethash x (fasl-output-equal-table fasl-output))))))
       (cond
         (handle (dump-push handle fasl-output) t)
@@ -238,7 +239,9 @@
            (type string x))
   (unless *cold-load-dump*
     (let ((handle (dump-pop fasl-output)))
-      (push (cons (array-element-type x) handle)
+      (push (cons #+sb-xc-host 'base-char ; repeatable xc fasls
+                  #-sb-xc-host (array-element-type x)
+                  handle)
             (gethash x (fasl-output-equal-table fasl-output)))
       (setf (gethash x (fasl-output-eq-table fasl-output)) handle)
       (dump-push handle fasl-output)))
@@ -295,6 +298,13 @@
                          :if-exists :supersede
                          :element-type 'sb!assem:assembly-unit))
            (res (make-fasl-output :stream stream)))
+      ;; Before the actual FASL header, write a shebang line using the current
+      ;; runtime path, so our fasls can be executed directly from the shell.
+      (when *runtime-pathname*
+        (fasl-write-string
+         (format nil "#!~A --script~%"
+                 (native-namestring *runtime-pathname* :as-file t))
+         stream))
       ;; Begin the header with the constant machine-readable (and
       ;; semi-human-readable) string which is used to identify fasl files.
       (fasl-write-string *fasl-header-string-start-string* stream)
@@ -563,37 +573,55 @@
      (dump-fop 'fop-long-float file)
      (dump-long-float x file))))
 
+(defun dump-complex-single-float (re im file)
+  (declare (single-float re im))
+  (dump-fop 'fop-complex-single-float file)
+  (dump-integer-as-n-bytes (single-float-bits re) 4 file)
+  (dump-integer-as-n-bytes (single-float-bits im) 4 file))
+
+(defun dump-complex-double-float (re im file)
+  (declare (double-float re im))
+  (dump-fop 'fop-complex-double-float file)
+  (dump-integer-as-n-bytes (double-float-low-bits re) 4 file)
+  (dump-integer-as-n-bytes (double-float-high-bits re) 4 file)
+  (dump-integer-as-n-bytes (double-float-low-bits im) 4 file)
+  (dump-integer-as-n-bytes (double-float-high-bits im) 4 file))
+
+(defun dump-complex-rational (re im file)
+  (sub-dump-object re file)
+  (sub-dump-object im file)
+  (dump-fop 'fop-complex file))
+
+#+sb-xc-host
+(defun dump-complex (x file)
+  (let ((re (realpart x))
+        (im (imagpart x)))
+    (cond ((and (typep re 'single-float)
+                (typep im 'single-float))
+           (dump-complex-single-float re im file))
+          ((and (typep re 'double-float)
+                (typep im 'double-float))
+           (dump-complex-double-float re im file))
+          ((and (typep re 'rational)
+                (typep im 'rational))
+           (dump-complex-rational re im file))
+          (t
+           (bug "Complex number too complex: ~S" x)))))
+
+#-sb-xc-host
 (defun dump-complex (x file)
   (typecase x
-    #-sb-xc-host
     ((complex single-float)
-     (dump-fop 'fop-complex-single-float file)
-     (dump-integer-as-n-bytes (single-float-bits (realpart x)) 4 file)
-     (dump-integer-as-n-bytes (single-float-bits (imagpart x)) 4 file))
-    #-sb-xc-host
+     (dump-complex-single-float (realpart x) (imagpart x) file))
     ((complex double-float)
-     (dump-fop 'fop-complex-double-float file)
-     (let ((re (realpart x)))
-       (declare (double-float re))
-       (dump-integer-as-n-bytes (double-float-low-bits re) 4 file)
-       (dump-integer-as-n-bytes (double-float-high-bits re) 4 file))
-     (let ((im (imagpart x)))
-       (declare (double-float im))
-       (dump-integer-as-n-bytes (double-float-low-bits im) 4 file)
-       (dump-integer-as-n-bytes (double-float-high-bits im) 4 file)))
+     (dump-complex-double-float (realpart x) (imagpart x) file))
     #!+long-float
     ((complex long-float)
-     ;; (There's no easy way to mix #!+LONG-FLOAT and #-SB-XC-HOST
-     ;; conditionalization at read time, so we do this SB-XC-HOST
-     ;; conditional at runtime instead.)
-     #+sb-xc-host (error "can't dump COMPLEX-LONG-FLOAT in cross-compiler")
      (dump-fop 'fop-complex-long-float file)
      (dump-long-float (realpart x) file)
      (dump-long-float (imagpart x) file))
     (t
-     (sub-dump-object (realpart x) file)
-     (sub-dump-object (imagpart x) file)
-     (dump-fop 'fop-complex file))))
+     (dump-complex-rational (realpart x) (imagpart x) file))))
 \f
 ;;;; symbol dumping
 
@@ -974,6 +1002,15 @@
   (let* ((pname (symbol-name s))
          (pname-length (length pname))
          (pkg (symbol-package s)))
+    ;; see comment in genesis: we need this here for repeatable fasls
+    #+sb-xc-host
+    (multiple-value-bind (cl-symbol cl-status)
+        (find-symbol (symbol-name s) sb!int:*cl-package*)
+      (when (and (eq s cl-symbol)
+                 (eq cl-status :external))
+        ;; special case, to work around possible xc host "design
+        ;; choice" weirdness in COMMON-LISP package
+        (setq pkg sb!int:*cl-package*)))
 
     (cond ((null pkg)
            (dump-fop* pname-length
@@ -1219,7 +1256,7 @@
     (dump-object name file)
     (dump-object (sb!c::entry-info-arguments entry) file)
     (dump-object (sb!c::entry-info-type entry) file)
-    (dump-object (sb!c::entry-info-xref entry) file)
+    (dump-object (sb!c::entry-info-info entry) file)
     (dump-fop 'fop-fun-entry file)
     (dump-word (label-position (sb!c::entry-info-offset entry)) file)
     (dump-pop file)))