0.8.21.21: fix & share EXTERN-ALIEN-NAME logic (fixes bug #373)
[sbcl.git] / src / compiler / generic / genesis.lisp
index 4b9ce54..ba452c3 100644 (file)
 
 ;;; a magic number used to identify our core files
 (defconstant core-magic
-  (logior (ash (char-code #\S) 24)
-         (ash (char-code #\B) 16)
-         (ash (char-code #\C) 8)
-         (char-code #\L)))
+  (logior (ash (sb!xc:char-code #\S) 24)
+         (ash (sb!xc:char-code #\B) 16)
+         (ash (sb!xc:char-code #\C) 8)
+         (sb!xc:char-code #\L)))
 
 ;;; the current version of SBCL core files
 ;;;
                           type)))
 
 (defun make-character-descriptor (data)
-  (make-other-immediate-descriptor data sb!vm:base-char-widetag))
+  (make-other-immediate-descriptor data sb!vm:character-widetag))
 
 (defun descriptor-beyond (des offset type)
   (let* ((low (logior (+ (logandc2 (descriptor-low des) sb!vm:lowtag-mask)
 \f
 ;;;; copying simple objects into the cold core
 
-(defun string-to-core (string &optional (gspace *dynamic*))
+(defun base-string-to-core (string &optional (gspace *dynamic*))
   #!+sb-doc
-  "Copy string into the cold core and return a descriptor to it."
+  "Copy STRING (which must only contain STANDARD-CHARs) into the cold
+core and return a descriptor to it."
   ;; (Remember that the system convention for storage of strings leaves an
   ;; extra null byte at the end to aid in call-out to C.)
   (let* ((length (length string))
                       (make-fixnum-descriptor length))
     (dotimes (i length)
       (setf (bvref bytes (+ offset i))
-           ;; KLUDGE: There's no guarantee that the character
-           ;; encoding here will be the same as the character
-           ;; encoding on the target machine, so using CHAR-CODE as
-           ;; we do, or a bitwise copy as CMU CL code did, is sleazy.
-           ;; (To make this more portable, perhaps we could use
-           ;; indices into the sequence which is used to test whether
-           ;; a character is a STANDARD-CHAR?) -- WHN 19990817
-           (char-code (aref string i))))
+           (sb!xc:char-code (aref string i))))
     (setf (bvref bytes (+ offset length))
          0) ; null string-termination character for C
     des))
     (write-wordindexed des 2 second)
     des))
 
+(defun write-double-float-bits (address index x)
+  (let ((hi (double-float-high-bits x))
+       (lo (double-float-low-bits x)))
+    (ecase sb!vm::n-word-bits
+      (32
+       (let ((high-bits (make-random-descriptor hi))
+            (low-bits (make-random-descriptor lo)))
+        (ecase sb!c:*backend-byte-order*
+          (:little-endian
+           (write-wordindexed address index low-bits)
+           (write-wordindexed address (1+ index) high-bits))
+          (:big-endian
+           (write-wordindexed address index high-bits)
+           (write-wordindexed address (1+ index) low-bits)))))
+      (64
+       (let ((bits (make-random-descriptor
+                   (ecase sb!c:*backend-byte-order*
+                     (:little-endian (logior lo (ash hi 32)))
+                     ;; Just guessing.
+                     #+nil (:big-endian (logior (logand hi #xffffffff)
+                                                (ash lo 32)))))))
+        (write-wordindexed address index bits))))
+    address))
+
 (defun float-to-core (x)
   (etypecase x
     (single-float
+     ;; 64-bit platforms have immediate single-floats.
+     #!+#.(cl:if (cl:= sb!vm:n-word-bits 64) '(and) '(or))
+     (make-random-descriptor (logior (ash (single-float-bits x) 32)
+                                    sb!vm::single-float-widetag))
+     #!-#.(cl:if (cl:= sb!vm:n-word-bits 64) '(and) '(or))
      (let ((des (allocate-unboxed-object *dynamic*
                                         sb!vm:n-word-bits
                                         (1- sb!vm:single-float-size)
      (let ((des (allocate-unboxed-object *dynamic*
                                         sb!vm:n-word-bits
                                         (1- sb!vm:double-float-size)
-                                        sb!vm:double-float-widetag))
-          (high-bits (make-random-descriptor (double-float-high-bits x)))
-          (low-bits (make-random-descriptor (double-float-low-bits x))))
-       (ecase sb!c:*backend-byte-order*
-        (:little-endian
-         (write-wordindexed des sb!vm:double-float-value-slot low-bits)
-         (write-wordindexed des (1+ sb!vm:double-float-value-slot) high-bits))
-        (:big-endian
-         (write-wordindexed des sb!vm:double-float-value-slot high-bits)
-         (write-wordindexed des (1+ sb!vm:double-float-value-slot) low-bits)))
-       des))))
+                                        sb!vm:double-float-widetag)))
+       (write-double-float-bits des sb!vm:double-float-value-slot x)))))
 
 (defun complex-single-float-to-core (num)
   (declare (type (complex single-float) num))
   (let ((des (allocate-unboxed-object *dynamic* sb!vm:n-word-bits
                                      (1- sb!vm:complex-double-float-size)
                                      sb!vm:complex-double-float-widetag)))
-    (let* ((real (realpart num))
-          (high-bits (make-random-descriptor (double-float-high-bits real)))
-          (low-bits (make-random-descriptor (double-float-low-bits real))))
-      (ecase sb!c:*backend-byte-order*
-       (:little-endian
-        (write-wordindexed des sb!vm:complex-double-float-real-slot low-bits)
-        (write-wordindexed des
-                           (1+ sb!vm:complex-double-float-real-slot)
-                           high-bits))
-       (:big-endian
-        (write-wordindexed des sb!vm:complex-double-float-real-slot high-bits)
-        (write-wordindexed des
-                           (1+ sb!vm:complex-double-float-real-slot)
-                           low-bits))))
-    (let* ((imag (imagpart num))
-          (high-bits (make-random-descriptor (double-float-high-bits imag)))
-          (low-bits (make-random-descriptor (double-float-low-bits imag))))
-      (ecase sb!c:*backend-byte-order*
-       (:little-endian
-        (write-wordindexed des
-                           sb!vm:complex-double-float-imag-slot
-                           low-bits)
-        (write-wordindexed des
-                           (1+ sb!vm:complex-double-float-imag-slot)
-                           high-bits))
-       (:big-endian
-        (write-wordindexed des
-                           sb!vm:complex-double-float-imag-slot
-                           high-bits)
-        (write-wordindexed des
-                           (1+ sb!vm:complex-double-float-imag-slot)
-                           low-bits))))
-    des))
+    (write-double-float-bits des sb!vm:complex-double-float-real-slot
+                            (realpart num))
+    (write-double-float-bits des sb!vm:complex-double-float-imag-slot
+                            (imagpart num))))
 
 ;;; Copy the given number to the core.
 (defun number-to-core (number)
                       (make-fixnum-descriptor 0))
     (write-wordindexed symbol sb!vm:symbol-plist-slot *nil-descriptor*)
     (write-wordindexed symbol sb!vm:symbol-name-slot
-                      (string-to-core name *dynamic*))
+                      (base-string-to-core name *dynamic*))
     (write-wordindexed symbol sb!vm:symbol-package-slot *nil-descriptor*)
     symbol))
 
                       ;; because that's the way CMU CL did it; I'm
                       ;; not sure whether there's an underlying
                       ;; reason. -- WHN 1990826
-                      (string-to-core "NIL" *dynamic*))
+                      (base-string-to-core "NIL" *dynamic*))
     (write-wordindexed des
                       (+ 1 sb!vm:symbol-package-slot)
                       result)
     (frob sub-gc)
     (frob internal-error)
     (frob sb!kernel::control-stack-exhausted-error)
+    (frob sb!kernel::undefined-alien-variable-error)
+    (frob sb!kernel::undefined-alien-function-error)
+    (frob sb!kernel::memory-fault-error)
     (frob sb!di::handle-breakpoint)
     (frob sb!di::handle-fun-end-breakpoint)
     (frob sb!thread::handle-thread-exit))
       (let* ((cold-package (car cold-package-symbols-entry))
             (symbols (cdr cold-package-symbols-entry))
             (shadows (package-shadowing-symbols cold-package))
-            (documentation (string-to-core (documentation cold-package t)))
+            (documentation (base-string-to-core (documentation cold-package t)))
             (internal *nil-descriptor*)
             (external *nil-descriptor*)
             (imported-internal *nil-descriptor*)
         (res *nil-descriptor*))
     (dolist (u (package-use-list pkg))
       (when (assoc u *cold-package-symbols*)
-       (cold-push (string-to-core (package-name u)) use)))
+       (cold-push (base-string-to-core (package-name u)) use)))
     (let* ((pkg-name (package-name pkg))
           ;; Make the package nickname lists for the standard packages
           ;; be the minimum specified by ANSI, regardless of what value
                                 (t
                                  (package-nicknames pkg)))))
       (dolist (warm-nickname warm-nicknames)
-       (cold-push (string-to-core warm-nickname) cold-nicknames)))
+       (cold-push (base-string-to-core warm-nickname) cold-nicknames)))
 
     (cold-push (number-to-core (truncate (package-internal-symbol-count pkg)
                                         0.8))
     (cold-push use res)
     (cold-push (cold-intern :use) res)
 
-    (cold-push (string-to-core (package-name pkg)) res)
+    (cold-push (base-string-to-core (package-name pkg)) res)
     res))
 \f
 ;;;; functions and fdefinition objects
                               sb!vm:fdefn-raw-addr-slot
                               (make-random-descriptor
                                (cold-foreign-symbol-address-as-integer
-                                (sb!vm:extern-alien-name "undefined_tramp")))))
+                                "undefined_tramp"))))
          fdefn))))
 
 ;;; Handle the at-cold-init-time, fset-for-static-linkage operation
                          (/show0 "/static-fset (closure)")
                          (make-random-descriptor
                           (cold-foreign-symbol-address-as-integer
-                           (sb!vm:extern-alien-name "closure_tramp"))))))
+                           "closure_tramp")))))
     fdefn))
 
 (defun initialize-static-fns ()
 (defun foreign-symbols-to-core ()
   (let ((result *nil-descriptor*))
     (maphash (lambda (symbol value)
-              (cold-push (cold-cons (string-to-core symbol)
+              (cold-push (cold-cons (base-string-to-core symbol)
                                     (number-to-core value))
                          result))
             *cold-foreign-symbol-table*)
              (depthoid (descriptor-fixnum depthoid-des)))
          (unless (= length old-length)
            (error "cold loading a reference to class ~S when the compile~%~
-                  time length was ~S and current length is ~S"
+                    time length was ~S and current length is ~S"
                   name
                   length
                   old-length))
          (unless (equal inherits-list old-inherits-list)
            (error "cold loading a reference to class ~S when the compile~%~
-                  time inherits were ~S~%~
-                  and current inherits are ~S"
+                    time inherits were ~S~%~
+                    and current inherits are ~S"
                   name
                   inherits-list
                   old-inherits-list))
          (unless (= depthoid old-depthoid)
            (error "cold loading a reference to class ~S when the compile~%~
-                  time inheritance depthoid was ~S and current inheritance~%~
-                  depthoid is ~S"
+                    time inheritance depthoid was ~S and current inheritance~%~
+                    depthoid is ~S"
                   name
                   depthoid
                   old-depthoid)))
 \f
 ;;;; cold fops for loading vectors
 
-(clone-cold-fop (fop-string)
-               (fop-small-string)
+(clone-cold-fop (fop-base-string)
+               (fop-small-base-string)
   (let* ((len (clone-arg))
         (string (make-string len)))
     (read-string-as-bytes *fasl-input-stream* string)
-    (string-to-core string)))
+    (base-string-to-core string)))
+
+#!+sb-unicode
+(clone-cold-fop (fop-character-string)
+               (fop-small-character-string)
+  (bug "CHARACTER-STRING dumped by cross-compiler."))
 
 (clone-cold-fop (fop-vector)
                (fop-small-vector)
                       ;; itself.) Ask on the mailing list whether
                       ;; this is documented somewhere, and if not,
                       ;; try to reverse engineer some documentation.
-                      #!-x86
+                      #!-(or x86 x86-64)
                       ;; a pointer back to the function object, as
                       ;; described in CMU CL
                       ;; src/docs/internals/object.tex
                       fn
-                      #!+x86
+                      #!+(or x86 x86-64)
                       ;; KLUDGE: a pointer to the actual code of the
                       ;; object, as described nowhere that I can find
                       ;; -- WHN 19990907
@@ -2989,7 +2982,7 @@ initially undefined function references:~2%")
          ;; (We write each character as a word in order to avoid
          ;; having to think about word alignment issues in the
          ;; sbcl-0.7.8 version of coreparse.c.)
-         (write-word (char-code char))))
+         (write-word (sb!xc:char-code char))))
 
       ;; Write the New Directory entry header.
       (write-word new-directory-core-entry-type-code)
@@ -3106,7 +3099,7 @@ initially undefined function references:~2%")
                              sb!vm:unbound-marker-widetag))
           *cold-assembler-fixups*
           *cold-assembler-routines*
-          #!+x86 *load-time-code-fixups*)
+          #!+(or x86 x86-64) *load-time-code-fixups*)
 
       ;; Prepare for cold load.
       (initialize-non-nil-symbols)
@@ -3174,7 +3167,7 @@ initially undefined function references:~2%")
 
       ;; Tidy up loose ends left by cold loading. ("Postpare from cold load?")
       (resolve-assembler-fixups)
-      #!+x86 (output-load-time-code-fixups)
+      #!+(or x86 x86-64) (output-load-time-code-fixups)
       (foreign-symbols-to-core)
       (finish-symbols)
       (/show "back from FINISH-SYMBOLS")