1;;;; "cold" core image builder: This is how we create a target Lisp 2;;;; system from scratch, by converting from fasl files to an image 3;;;; file in the cross-compilation host, without the help of the 4;;;; target Lisp system. 5;;;; 6;;;; As explained by Rob MacLachlan on the CMU CL mailing list Wed, 06 7;;;; Jan 1999 11:05:02 -0500, this cold load generator more or less 8;;;; fakes up static function linking. I.e. it makes sure that all the 9;;;; DEFUN-defined functions in the fasl files it reads are bound to the 10;;;; corresponding symbols before execution starts. It doesn't do 11;;;; anything to initialize variable values; instead it just arranges 12;;;; for !COLD-INIT to be called at cold load time. !COLD-INIT is 13;;;; responsible for explicitly initializing anything which has to be 14;;;; initialized early before it transfers control to the ordinary 15;;;; top level forms. 16;;;; 17;;;; (In CMU CL, and in SBCL as of 0.6.9 anyway, functions not defined 18;;;; by DEFUN aren't set up specially by GENESIS.) 19 20;;;; This software is part of the SBCL system. See the README file for 21;;;; more information. 22;;;; 23;;;; This software is derived from the CMU CL system, which was 24;;;; written at Carnegie Mellon University and released into the 25;;;; public domain. The software is in the public domain and is 26;;;; provided with absolutely no warranty. See the COPYING and CREDITS 27;;;; files for more information. 28 29(in-package "SB!FASL") 30 31;;; a magic number used to identify our core files 32(defconstant core-magic 33 (logior (ash (sb!xc:char-code #\S) 24) 34 (ash (sb!xc:char-code #\B) 16) 35 (ash (sb!xc:char-code #\C) 8) 36 (sb!xc:char-code #\L))) 37 38(defun round-up (number size) 39 "Round NUMBER up to be an integral multiple of SIZE." 40 (* size (ceiling number size))) 41 42;;;; implementing the concept of "vector" in (almost) portable 43;;;; Common Lisp 44;;;; 45;;;; "If you only need to do such simple things, it doesn't really 46;;;; matter which language you use." -- _ANSI Common Lisp_, p. 1, Paul 47;;;; Graham (evidently not considering the abstraction "vector" to be 48;;;; such a simple thing:-) 49 50(eval-when (:compile-toplevel :load-toplevel :execute) 51 (defconstant +smallvec-length+ 52 (expt 2 16))) 53 54;;; an element of a BIGVEC -- a vector small enough that we have 55;;; a good chance of it being portable to other Common Lisps 56(deftype smallvec () 57 `(simple-array (unsigned-byte 8) (,+smallvec-length+))) 58 59(defun make-smallvec () 60 (make-array +smallvec-length+ :element-type '(unsigned-byte 8) 61 :initial-element 0)) 62 63;;; a big vector, implemented as a vector of SMALLVECs 64;;; 65;;; KLUDGE: This implementation seems portable enough for our 66;;; purposes, since realistically every modern implementation is 67;;; likely to support vectors of at least 2^16 elements. But if you're 68;;; masochistic enough to read this far into the contortions imposed 69;;; on us by ANSI and the Lisp community, for daring to use the 70;;; abstraction of a large linearly addressable memory space, which is 71;;; after all only directly supported by the underlying hardware of at 72;;; least 99% of the general-purpose computers in use today, then you 73;;; may be titillated to hear that in fact this code isn't really 74;;; portable, because as of sbcl-0.7.4 we need somewhat more than 75;;; 16Mbytes to represent a core, and ANSI only guarantees that 76;;; ARRAY-DIMENSION-LIMIT is not less than 1024. -- WHN 2002-06-13 77(defstruct bigvec 78 (outer-vector (vector (make-smallvec)) :type (vector smallvec))) 79 80;;; analogous to SVREF, but into a BIGVEC 81(defun bvref (bigvec index) 82 (multiple-value-bind (outer-index inner-index) 83 (floor index +smallvec-length+) 84 (aref (the smallvec 85 (svref (bigvec-outer-vector bigvec) outer-index)) 86 inner-index))) 87(defun (setf bvref) (new-value bigvec index) 88 (multiple-value-bind (outer-index inner-index) 89 (floor index +smallvec-length+) 90 (setf (aref (the smallvec 91 (svref (bigvec-outer-vector bigvec) outer-index)) 92 inner-index) 93 new-value))) 94 95;;; analogous to LENGTH, but for a BIGVEC 96;;; 97;;; the length of BIGVEC, measured in the number of BVREFable bytes it 98;;; can hold 99(defun bvlength (bigvec) 100 (* (length (bigvec-outer-vector bigvec)) 101 +smallvec-length+)) 102 103;;; analogous to WRITE-SEQUENCE, but for a BIGVEC 104(defun write-bigvec-as-sequence (bigvec stream &key (start 0) end pad-with-zeros) 105 (let* ((bvlength (bvlength bigvec)) 106 (data-length (min (or end bvlength) bvlength))) 107 (loop for i of-type index from start below data-length do 108 (write-byte (bvref bigvec i) 109 stream)) 110 (when (and pad-with-zeros (< bvlength data-length)) 111 (loop repeat (- data-length bvlength) do (write-byte 0 stream))))) 112 113;;; analogous to READ-SEQUENCE-OR-DIE, but for a BIGVEC 114(defun read-bigvec-as-sequence-or-die (bigvec stream &key (start 0) end) 115 (loop for i of-type index from start below (or end (bvlength bigvec)) do 116 (setf (bvref bigvec i) 117 (read-byte stream)))) 118 119;;; Grow BIGVEC (exponentially, so that large increases in size have 120;;; asymptotic logarithmic cost per byte). 121(defun expand-bigvec (bigvec) 122 (let* ((old-outer-vector (bigvec-outer-vector bigvec)) 123 (length-old-outer-vector (length old-outer-vector)) 124 (new-outer-vector (make-array (* 2 length-old-outer-vector)))) 125 (dotimes (i length-old-outer-vector) 126 (setf (svref new-outer-vector i) 127 (svref old-outer-vector i))) 128 (loop for i from length-old-outer-vector below (length new-outer-vector) do 129 (setf (svref new-outer-vector i) 130 (make-smallvec))) 131 (setf (bigvec-outer-vector bigvec) 132 new-outer-vector)) 133 bigvec) 134 135;;;; looking up bytes and multi-byte values in a BIGVEC (considering 136;;;; it as an image of machine memory on the cross-compilation target) 137 138;;; BVREF-32 and friends. These are like SAP-REF-n, except that 139;;; instead of a SAP we use a BIGVEC. 140(macrolet ((make-bvref-n 141 (n) 142 (let* ((name (intern (format nil "BVREF-~A" n))) 143 (number-octets (/ n 8)) 144 (ash-list-le 145 (loop for i from 0 to (1- number-octets) 146 collect `(ash (bvref bigvec (+ byte-index ,i)) 147 ,(* i 8)))) 148 (ash-list-be 149 (loop for i from 0 to (1- number-octets) 150 collect `(ash (bvref bigvec 151 (+ byte-index 152 ,(- number-octets 1 i))) 153 ,(* i 8)))) 154 (setf-list-le 155 (loop for i from 0 to (1- number-octets) 156 append 157 `((bvref bigvec (+ byte-index ,i)) 158 (ldb (byte 8 ,(* i 8)) new-value)))) 159 (setf-list-be 160 (loop for i from 0 to (1- number-octets) 161 append 162 `((bvref bigvec (+ byte-index ,i)) 163 (ldb (byte 8 ,(- n 8 (* i 8))) new-value))))) 164 `(progn 165 (defun ,name (bigvec byte-index) 166 (logior ,@(ecase sb!c:*backend-byte-order* 167 (:little-endian ash-list-le) 168 (:big-endian ash-list-be)))) 169 (defun (setf ,name) (new-value bigvec byte-index) 170 (setf ,@(ecase sb!c:*backend-byte-order* 171 (:little-endian setf-list-le) 172 (:big-endian setf-list-be)))))))) 173 (make-bvref-n 8) 174 (make-bvref-n 16) 175 (make-bvref-n 32) 176 (make-bvref-n 64)) 177 178;; lispobj-sized word, whatever that may be 179;; hopefully nobody ever wants a 128-bit SBCL... 180#!+64-bit 181(progn 182 (defun bvref-word (bytes index) 183 (bvref-64 bytes index)) 184 (defun (setf bvref-word) (new-val bytes index) 185 (setf (bvref-64 bytes index) new-val))) 186 187#!-64-bit 188(progn 189 (defun bvref-word (bytes index) 190 (bvref-32 bytes index)) 191 (defun (setf bvref-word) (new-val bytes index) 192 (setf (bvref-32 bytes index) new-val))) 193 194 195;;;; representation of spaces in the core 196 197;;; If there is more than one dynamic space in memory (i.e., if a 198;;; copying GC is in use), then only the active dynamic space gets 199;;; dumped to core. 200(defvar *dynamic*) 201(defconstant dynamic-core-space-id 1) 202 203(defvar *static*) 204(defconstant static-core-space-id 2) 205 206(defvar *read-only*) 207(defconstant read-only-core-space-id 3) 208 209#!+immobile-space 210(progn 211 (defvar *immobile-fixedobj*) 212 (defvar *immobile-varyobj*) 213 (defconstant immobile-fixedobj-core-space-id 4) 214 (defconstant immobile-varyobj-core-space-id 5) 215 (defvar *immobile-space-map* nil)) 216 217(defconstant max-core-space-id 5) 218(defconstant deflated-core-space-id-flag 8) 219 220;; This is somewhat arbitrary as there is no concept of the the 221;; number of bits in the "low" part of a descriptor any more. 222(defconstant target-space-alignment (ash 1 16) 223 "the alignment requirement for spaces in the target.") 224 225;;; a GENESIS-time representation of a memory space (e.g. read-only 226;;; space, dynamic space, or static space) 227(defstruct (gspace (:constructor %make-gspace) 228 (:copier nil)) 229 ;; name and identifier for this GSPACE 230 (name (missing-arg) :type symbol :read-only t) 231 (identifier (missing-arg) :type fixnum :read-only t) 232 ;; the word address where the data will be loaded 233 (word-address (missing-arg) :type unsigned-byte :read-only t) 234 ;; the data themselves. (Note that in CMU CL this was a pair of 235 ;; fields SAP and WORDS-ALLOCATED, but that wasn't very portable.) 236 ;; (And then in SBCL this was a VECTOR, but turned out to be 237 ;; unportable too, since ANSI doesn't think that arrays longer than 238 ;; 1024 (!) should needed by portable CL code...) 239 (bytes (make-bigvec) :read-only t) 240 ;; the index of the next unwritten word (i.e. chunk of 241 ;; SB!VM:N-WORD-BYTES bytes) in BYTES, or equivalently the number of 242 ;; words actually written in BYTES. In order to convert to an actual 243 ;; index into BYTES, thus must be multiplied by SB!VM:N-WORD-BYTES. 244 (free-word-index 0)) 245 246(defun gspace-byte-address (gspace) 247 (ash (gspace-word-address gspace) sb!vm:word-shift)) 248 249(cl:defmethod print-object ((gspace gspace) stream) 250 (print-unreadable-object (gspace stream :type t) 251 (format stream "@#x~X ~S" (gspace-byte-address gspace) (gspace-name gspace)))) 252 253(defun make-gspace (name identifier byte-address) 254 (unless (zerop (rem byte-address target-space-alignment)) 255 (error "The byte address #X~X is not aligned on a #X~X-byte boundary." 256 byte-address 257 target-space-alignment)) 258 (%make-gspace :name name 259 :identifier identifier 260 :word-address (ash byte-address (- sb!vm:word-shift)))) 261 262;;;; representation of descriptors 263 264(declaim (inline is-fixnum-lowtag)) 265(defun is-fixnum-lowtag (lowtag) 266 (zerop (logand lowtag sb!vm:fixnum-tag-mask))) 267 268(defun is-other-immediate-lowtag (lowtag) 269 ;; The other-immediate lowtags are similar to the fixnum lowtags, in 270 ;; that they have an "effective length" that is shorter than is used 271 ;; for the pointer lowtags. Unlike the fixnum lowtags, however, the 272 ;; other-immediate lowtags are always effectively two bits wide. 273 (= (logand lowtag 3) sb!vm:other-immediate-0-lowtag)) 274 275(defstruct (descriptor 276 (:constructor make-descriptor (bits &optional gspace word-offset)) 277 (:copier nil)) 278 ;; the GSPACE that this descriptor is allocated in, or NIL if not set yet. 279 (gspace nil :type (or gspace (eql :load-time-value) null)) 280 ;; the offset in words from the start of GSPACE, or NIL if not set yet 281 (word-offset nil :type (or sb!vm:word null)) 282 (bits 0 :read-only t :type (unsigned-byte #.sb!vm:n-machine-word-bits))) 283 284(declaim (inline descriptor=)) 285(defun descriptor= (a b) (eql (descriptor-bits a) (descriptor-bits b))) 286 287(defun make-random-descriptor (bits) 288 (make-descriptor (logand bits sb!ext:most-positive-word))) 289 290(declaim (inline descriptor-lowtag)) 291(defun descriptor-lowtag (des) 292 "the lowtag bits for DES" 293 (logand (descriptor-bits des) sb!vm:lowtag-mask)) 294 295(cl:defmethod print-object ((des descriptor) stream) 296 (let ((lowtag (descriptor-lowtag des))) 297 (print-unreadable-object (des stream :type t) 298 (cond ((eq (descriptor-gspace des) :load-time-value) 299 (format stream "for LTV ~D" (descriptor-word-offset des))) 300 ((is-fixnum-lowtag lowtag) 301 (format stream "for fixnum: ~W" (descriptor-fixnum des))) 302 ((is-other-immediate-lowtag lowtag) 303 (format stream 304 "for other immediate: #X~X, type #b~8,'0B" 305 (ash (descriptor-bits des) (- sb!vm:n-widetag-bits)) 306 (logand (descriptor-bits des) sb!vm:widetag-mask))) 307 (t 308 (format stream 309 "for pointer: #X~X, lowtag #b~v,'0B, ~A" 310 (logandc2 (descriptor-bits des) sb!vm:lowtag-mask) 311 sb!vm:n-lowtag-bits lowtag 312 (let ((gspace (descriptor-gspace des))) 313 (if gspace 314 (gspace-name gspace) 315 "unknown")))))))) 316 317;;; Return a descriptor for a block of LENGTH bytes out of GSPACE. The 318;;; free word index is boosted as necessary, and if additional memory 319;;; is needed, we grow the GSPACE. The descriptor returned is a 320;;; pointer of type LOWTAG. 321(defun allocate-cold-descriptor (gspace length lowtag &optional page-attributes) 322 (let* ((word-index 323 (gspace-claim-n-bytes gspace length page-attributes)) 324 (ptr (+ (gspace-word-address gspace) word-index))) 325 (make-descriptor (logior (ash ptr sb!vm:word-shift) lowtag) 326 gspace 327 word-index))) 328 329(defun gspace-claim-n-words (gspace n-words) 330 (let* ((old-free-word-index (gspace-free-word-index gspace)) 331 (new-free-word-index (+ old-free-word-index n-words))) 332 ;; Grow GSPACE as necessary until it's big enough to handle 333 ;; NEW-FREE-WORD-INDEX. 334 (do () 335 ((>= (bvlength (gspace-bytes gspace)) 336 (* new-free-word-index sb!vm:n-word-bytes))) 337 (expand-bigvec (gspace-bytes gspace))) 338 ;; Now that GSPACE is big enough, we can meaningfully grab a chunk of it. 339 (setf (gspace-free-word-index gspace) new-free-word-index) 340 old-free-word-index)) 341 342;; align256p is true if we need to force objects on this page to 256-byte 343;; boundaries. This doesn't need to be generalized - everything of type 344;; INSTANCE is either on its natural alignment, or 256-byte. 345;; [See doc/internals-notes/compact-instance for why you might want it at all] 346;; PAGE-KIND is a heuristic for placement of symbols 347;; based on being interned/uninterned/likely-special-variable. 348(defun make-page-attributes (align256p page-kind) 349 (declare (type (or null (integer 0 3)) page-kind)) 350 (logior (ash (or page-kind 0) 1) (if align256p 1 0))) 351(defun immobile-obj-spacing-words (page-attributes) 352 (if (logbitp 0 page-attributes) 353 (/ 256 sb!vm:n-word-bytes))) 354 355(defun gspace-claim-n-bytes (gspace specified-n-bytes page-attributes) 356 (declare (ignorable page-attributes)) 357 (let* ((n-bytes (round-up specified-n-bytes (ash 1 sb!vm:n-lowtag-bits))) 358 (n-words (ash n-bytes (- sb!vm:word-shift)))) 359 (aver (evenp n-words)) 360 (cond #!+immobile-space 361 ((eq gspace *immobile-fixedobj*) 362 (aver page-attributes) 363 ;; An immobile fixedobj page can only have one value of object-spacing 364 ;; and size for all objects on it. Different widetags are ok. 365 (let* ((key (cons specified-n-bytes page-attributes)) 366 (found (cdr (assoc key *immobile-space-map* :test 'equal))) 367 (page-n-words (/ sb!vm:immobile-card-bytes sb!vm:n-word-bytes))) 368 (unless found ; grab one whole GC page from immobile space 369 (let ((free-word-index 370 (gspace-claim-n-words gspace page-n-words))) 371 (setf found (cons 0 free-word-index)) 372 (push (cons key found) *immobile-space-map*))) 373 (destructuring-bind (page-word-index . page-base-index) found 374 (let ((next-word 375 (+ page-word-index 376 (or (immobile-obj-spacing-words page-attributes) 377 n-words)))) 378 (if (> next-word (- page-n-words n-words)) 379 ;; no more objects fit on this page 380 (setf *immobile-space-map* 381 (delete key *immobile-space-map* :key 'car :test 'equal)) 382 (setf (car found) next-word))) 383 (+ page-word-index page-base-index)))) 384 (t 385 (gspace-claim-n-words gspace n-words))))) 386 387(defun descriptor-fixnum (des) 388 (unless (is-fixnum-lowtag (descriptor-lowtag des)) 389 (error "descriptor-fixnum called on non-fixnum ~S" des)) 390 (let* ((descriptor-bits (descriptor-bits des)) 391 (bits (ash descriptor-bits (- sb!vm:n-fixnum-tag-bits)))) 392 (if (logbitp (1- sb!vm:n-word-bits) descriptor-bits) 393 (logior bits (ash -1 (1+ sb!vm:n-positive-fixnum-bits))) 394 bits))) 395 396(defun descriptor-word-sized-integer (des) 397 ;; Extract an (unsigned-byte 32), from either its fixnum or bignum 398 ;; representation. 399 (let ((lowtag (descriptor-lowtag des))) 400 (if (is-fixnum-lowtag lowtag) 401 (make-random-descriptor (descriptor-fixnum des)) 402 (read-wordindexed des 1)))) 403 404;;; common idioms 405(defun descriptor-bytes (des) 406 (gspace-bytes (descriptor-intuit-gspace des))) 407(defun descriptor-byte-offset (des) 408 (ash (descriptor-word-offset des) sb!vm:word-shift)) 409 410;;; If DESCRIPTOR-GSPACE is already set, just return that. Otherwise, 411;;; figure out a GSPACE which corresponds to DES, set it into 412;;; (DESCRIPTOR-GSPACE DES), set a consistent value into 413;;; (DESCRIPTOR-WORD-OFFSET DES), and return the GSPACE. 414(declaim (ftype (function (descriptor) gspace) descriptor-intuit-gspace)) 415(defun descriptor-intuit-gspace (des) 416 (or (descriptor-gspace des) 417 418 ;; gspace wasn't set, now we have to search for it. 419 (let* ((lowtag (descriptor-lowtag des)) 420 (abs-word-addr (ash (- (descriptor-bits des) lowtag) 421 (- sb!vm:word-shift)))) 422 423 ;; Non-pointer objects don't have a gspace. 424 (unless (or (eql lowtag sb!vm:fun-pointer-lowtag) 425 (eql lowtag sb!vm:instance-pointer-lowtag) 426 (eql lowtag sb!vm:list-pointer-lowtag) 427 (eql lowtag sb!vm:other-pointer-lowtag)) 428 (error "don't even know how to look for a GSPACE for ~S" des)) 429 430 (dolist (gspace (list *dynamic* *static* *read-only* 431 #!+immobile-space *immobile-fixedobj* 432 #!+immobile-space *immobile-varyobj*) 433 (error "couldn't find a GSPACE for ~S" des)) 434 ;; Bounds-check the descriptor against the allocated area 435 ;; within each gspace. 436 (when (and (<= (gspace-word-address gspace) 437 abs-word-addr 438 (+ (gspace-word-address gspace) 439 (gspace-free-word-index gspace)))) 440 ;; Update the descriptor with the correct gspace and the 441 ;; offset within the gspace and return the gspace. 442 (setf (descriptor-word-offset des) 443 (- abs-word-addr (gspace-word-address gspace))) 444 (return (setf (descriptor-gspace des) gspace))))))) 445 446(defun %fixnum-descriptor-if-possible (num) 447 (and (typep num '(signed-byte #.sb!vm:n-fixnum-bits)) 448 (make-random-descriptor (ash num sb!vm:n-fixnum-tag-bits)))) 449 450(defun make-fixnum-descriptor (num) 451 (or (%fixnum-descriptor-if-possible num) 452 (error "~W is too big for a fixnum." num))) 453 454(defun make-other-immediate-descriptor (data type) 455 (make-descriptor (logior (ash data sb!vm:n-widetag-bits) type))) 456 457(defun make-character-descriptor (data) 458 (make-other-immediate-descriptor data sb!vm:character-widetag)) 459 460 461;;;; miscellaneous variables and other noise 462 463;;; a numeric value to be returned for undefined foreign symbols, or NIL if 464;;; undefined foreign symbols are to be treated as an error. 465;;; (In the first pass of GENESIS, needed to create a header file before 466;;; the C runtime can be built, various foreign symbols will necessarily 467;;; be undefined, but we don't need actual values for them anyway, and 468;;; we can just use 0 or some other placeholder. In the second pass of 469;;; GENESIS, all foreign symbols should be defined, so any undefined 470;;; foreign symbol is a problem.) 471;;; 472;;; KLUDGE: It would probably be cleaner to rewrite GENESIS so that it 473;;; never tries to look up foreign symbols in the first place unless 474;;; it's actually creating a core file (as in the second pass) instead 475;;; of using this hack to allow it to go through the motions without 476;;; causing an error. -- WHN 20000825 477(defvar *foreign-symbol-placeholder-value*) 478 479;;; a handle on the trap object 480(defvar *unbound-marker*) 481;; was: (make-other-immediate-descriptor 0 sb!vm:unbound-marker-widetag) 482 483;;; a handle on the NIL object 484(defvar *nil-descriptor*) 485 486;;; the head of a list of TOPLEVEL-THINGs describing stuff to be done 487;;; when the target Lisp starts up 488;;; 489;;; Each TOPLEVEL-THING can be a function to be executed or a fixup or 490;;; loadtime value, represented by (CONS KEYWORD ..). 491(declaim (special *!cold-toplevels* *!cold-defconstants* *!cold-defuns*)) 492 493;;; the head of a list of DEBUG-SOURCEs which need to be patched when 494;;; the cold core starts up 495(defvar *current-debug-sources*) 496 497;;; foreign symbol references 498(defparameter *cold-foreign-undefined-symbols* nil) 499 500;;;; miscellaneous stuff to read and write the core memory 501 502;;; FIXME: should be DEFINE-MODIFY-MACRO 503(defmacro cold-push (thing list) ; for making a target list held in a host symbol 504 "Push THING onto the given cold-load LIST." 505 `(setq ,list (cold-cons ,thing ,list))) 506 507;; Like above, but the list is held in the target's image of the host symbol, 508;; not the host's value of the symbol. 509(defun cold-target-push (cold-thing host-symbol) 510 (cold-set host-symbol (cold-cons cold-thing (cold-symbol-value host-symbol)))) 511 512(declaim (ftype (function (descriptor sb!vm:word) descriptor) read-wordindexed)) 513(macrolet ((read-bits () 514 `(bvref-word (descriptor-bytes address) 515 (ash (+ index (descriptor-word-offset address)) 516 sb!vm:word-shift)))) 517 (defun read-bits-wordindexed (address index) 518 (read-bits)) 519 (defun read-wordindexed (address index) 520 "Return the value which is displaced by INDEX words from ADDRESS." 521 (make-random-descriptor (read-bits)))) 522 523(declaim (ftype (function (descriptor) descriptor) read-memory)) 524(defun read-memory (address) 525 "Return the value at ADDRESS." 526 (read-wordindexed address 0)) 527 528(declaim (ftype (function (descriptor 529 (integer #.(- sb!vm:list-pointer-lowtag) 530 #.sb!ext:most-positive-word) 531 descriptor) 532 (values)) 533 note-load-time-value-reference)) 534(defun note-load-time-value-reference (address offset marker) 535 (push (cold-list (cold-intern :load-time-value-fixup) 536 address 537 (number-to-core offset) 538 (number-to-core (descriptor-word-offset marker))) 539 *!cold-toplevels*) 540 (values)) 541 542(declaim (ftype (function (descriptor sb!vm:word (or symbol descriptor))) write-wordindexed)) 543(macrolet ((write-bits (bits) 544 `(setf (bvref-word (descriptor-bytes address) 545 (ash (+ index (descriptor-word-offset address)) 546 sb!vm:word-shift)) 547 ,bits))) 548 (defun write-wordindexed (address index value) 549 "Write VALUE displaced INDEX words from ADDRESS." 550 ;; If we're passed a symbol as a value then it needs to be interned. 551 (let ((value (cond ((symbolp value) (cold-intern value)) 552 (t value)))) 553 (if (eql (descriptor-gspace value) :load-time-value) 554 (note-load-time-value-reference address 555 (- (ash index sb!vm:word-shift) 556 (logand (descriptor-bits address) 557 sb!vm:lowtag-mask)) 558 value) 559 (write-bits (descriptor-bits value))))) 560 561 (defun write-wordindexed/raw (address index bits) 562 (declare (type descriptor address) (type sb!vm:word index) 563 (type (or sb!vm:word sb!vm:signed-word) bits)) 564 (write-bits (logand bits sb!ext:most-positive-word)))) 565 566(declaim (ftype (function (descriptor (or symbol descriptor))) write-memory)) 567(defun write-memory (address value) 568 "Write VALUE (a DESCRIPTOR) at ADDRESS (also a DESCRIPTOR)." 569 (write-wordindexed address 0 value)) 570 571;;;; allocating images of primitive objects in the cold core 572 573(defun write-header-word (des header-data widetag) 574 ;; In immobile space, all objects start life as pseudo-static as if by 'save'. 575 (let ((gen #!+gencgc (if (or #!+immobile-space 576 (let ((gspace (descriptor-gspace des))) 577 (or (eq gspace *immobile-fixedobj*) 578 (eq gspace *immobile-varyobj*)))) 579 sb!vm:+pseudo-static-generation+ 580 0) 581 #!-gencgc 0)) 582 (write-wordindexed/raw des 0 583 (logior (ash (logior (ash gen 16) header-data) 584 sb!vm:n-widetag-bits) widetag)))) 585 586(defun set-header-data (object data) 587 (write-header-word object data (ldb (byte sb!vm:n-widetag-bits 0) 588 (read-bits-wordindexed object 0)))) 589 590(defun get-header-data (object) 591 (ash (read-bits-wordindexed object 0) (- sb!vm:n-widetag-bits))) 592 593;;; There are three kinds of blocks of memory in the type system: 594;;; * Boxed objects (cons cells, structures, etc): These objects have no 595;;; header as all slots are descriptors. 596;;; * Unboxed objects (bignums): There is a single header word that contains 597;;; the length. 598;;; * Vector objects: There is a header word with the type, then a word for 599;;; the length, then the data. 600(defun allocate-object (gspace length lowtag &optional align256p) 601 "Allocate LENGTH words in GSPACE and return a new descriptor of type LOWTAG 602 pointing to them." 603 (allocate-cold-descriptor gspace (ash length sb!vm:word-shift) lowtag 604 (make-page-attributes align256p 0))) 605(defun allocate-header+object (gspace length widetag &optional page-kind) 606 "Allocate LENGTH words plus a header word in GSPACE and 607 return an ``other-pointer'' descriptor to them. Initialize the header word 608 with the resultant length and WIDETAG." 609 (let ((des (allocate-cold-descriptor 610 gspace (ash (1+ length) sb!vm:word-shift) 611 sb!vm:other-pointer-lowtag 612 (make-page-attributes nil page-kind)))) 613 (write-header-word des length widetag) 614 des)) 615(defun allocate-vector-object (gspace element-bits length widetag) 616 "Allocate LENGTH units of ELEMENT-BITS size plus a header plus a length slot in 617 GSPACE and return an ``other-pointer'' descriptor to them. Initialize the 618 header word with WIDETAG and the length slot with LENGTH." 619 ;; ALLOCATE-COLD-DESCRIPTOR will take any rational number of bytes 620 ;; and round up to a double-word. This doesn't need to use CEILING. 621 (let* ((bytes (/ (* element-bits length) sb!vm:n-byte-bits)) 622 (des (allocate-cold-descriptor gspace 623 (+ bytes (* 2 sb!vm:n-word-bytes)) 624 sb!vm:other-pointer-lowtag))) 625 (write-header-word des 0 widetag) 626 (write-wordindexed des 627 sb!vm:vector-length-slot 628 (make-fixnum-descriptor length)) 629 des)) 630 631;;; the hosts's representation of LAYOUT-of-LAYOUT 632(eval-when (:compile-toplevel :load-toplevel :execute) 633 (defvar *host-layout-of-layout* (find-layout 'layout))) 634 635(defun cold-layout-length (layout) 636 (descriptor-fixnum (read-slot layout *host-layout-of-layout* :length))) 637 638;; Make a structure and set the header word and layout. 639;; LAYOUT-LENGTH is as returned by the like-named function. 640(defun allocate-struct 641 (gspace layout &optional (layout-length (cold-layout-length layout)) 642 is-layout) 643 ;; Count +1 for the header word when allocating. 644 (let ((des (allocate-object gspace (1+ layout-length) 645 sb!vm:instance-pointer-lowtag is-layout))) 646 ;; Length as stored in the header is the exact number of useful words 647 ;; that follow, as is customary. A padding word, if any is not "useful" 648 (write-header-word des 649 (logior layout-length 650 #!+compact-instance-header 651 (if layout (ash (descriptor-bits layout) 24) 0)) 652 sb!vm:instance-header-widetag) 653 #!-compact-instance-header 654 (write-wordindexed des sb!vm:instance-slots-offset layout) 655 des)) 656 657;;;; copying simple objects into the cold core 658 659(defun base-string-to-core (string &optional (gspace *dynamic*)) 660 "Copy STRING (which must only contain STANDARD-CHARs) into the cold 661core and return a descriptor to it." 662 ;; (Remember that the system convention for storage of strings leaves an 663 ;; extra null byte at the end to aid in call-out to C.) 664 (let* ((length (length string)) 665 (des (allocate-vector-object gspace 666 sb!vm:n-byte-bits 667 (1+ length) 668 sb!vm:simple-base-string-widetag)) 669 (bytes (gspace-bytes gspace)) 670 (offset (+ (* sb!vm:vector-data-offset sb!vm:n-word-bytes) 671 (descriptor-byte-offset des)))) 672 (write-wordindexed des 673 sb!vm:vector-length-slot 674 (make-fixnum-descriptor length)) 675 (dotimes (i length) 676 (setf (bvref bytes (+ offset i)) 677 (sb!xc:char-code (aref string i)))) 678 (setf (bvref bytes (+ offset length)) 679 0) ; null string-termination character for C 680 des)) 681 682(defun base-string-from-core (descriptor) 683 (let* ((len (descriptor-fixnum 684 (read-wordindexed descriptor sb!vm:vector-length-slot))) 685 (str (make-string len)) 686 (bytes (descriptor-bytes descriptor))) 687 (dotimes (i len str) 688 (setf (aref str i) 689 (code-char (bvref bytes 690 (+ (descriptor-byte-offset descriptor) 691 (* sb!vm:vector-data-offset sb!vm:n-word-bytes) 692 i))))))) 693 694(defun bignum-to-core (n) 695 "Copy a bignum to the cold core." 696 (let* ((words (ceiling (1+ (integer-length n)) sb!vm:n-word-bits)) 697 (handle 698 (allocate-header+object *dynamic* words sb!vm:bignum-widetag))) 699 (declare (fixnum words)) 700 (do ((index 1 (1+ index)) 701 (remainder n (ash remainder (- sb!vm:n-word-bits)))) 702 ((> index words) 703 (unless (zerop (integer-length remainder)) 704 ;; FIXME: Shouldn't this be a fatal error? 705 (warn "~W words of ~W were written, but ~W bits were left over." 706 words n remainder))) 707 (write-wordindexed/raw handle index 708 (ldb (byte sb!vm:n-word-bits 0) remainder))) 709 handle)) 710 711(defun bignum-from-core (descriptor) 712 (let ((n-words (ash (descriptor-bits (read-memory descriptor)) 713 (- sb!vm:n-widetag-bits))) 714 (val 0)) 715 (dotimes (i n-words val) 716 (let ((bits (read-bits-wordindexed descriptor 717 (+ i sb!vm:bignum-digits-offset)))) 718 ;; sign-extend the highest word 719 (when (and (= i (1- n-words)) (logbitp (1- sb!vm:n-word-bits) bits)) 720 (setq bits (dpb bits (byte sb!vm:n-word-bits 0) -1))) 721 (setq val (logior (ash bits (* i sb!vm:n-word-bits)) val)))))) 722 723(defun number-pair-to-core (first second type) 724 "Makes a number pair of TYPE (ratio or complex) and fills it in." 725 (let ((des (allocate-header+object *dynamic* 2 type))) 726 (write-wordindexed des 1 first) 727 (write-wordindexed des 2 second) 728 des)) 729 730(defun write-double-float-bits (address index x) 731 (let ((high-bits (double-float-high-bits x)) 732 (low-bits (double-float-low-bits x))) 733 (ecase sb!vm::n-word-bits 734 (32 735 (ecase sb!c:*backend-byte-order* 736 (:little-endian 737 (write-wordindexed/raw address index low-bits) 738 (write-wordindexed/raw address (1+ index) high-bits)) 739 (:big-endian 740 (write-wordindexed/raw address index high-bits) 741 (write-wordindexed/raw address (1+ index) low-bits)))) 742 (64 743 (let ((bits (ecase sb!c:*backend-byte-order* 744 (:little-endian (logior low-bits (ash high-bits 32))) 745 ;; Just guessing. 746 #+nil (:big-endian (logior (logand high-bits #xffffffff) 747 (ash low-bits 32)))))) 748 (write-wordindexed/raw address index bits)))) 749 750 address)) 751 752(defun float-to-core (x) 753 (etypecase x 754 (single-float 755 ;; 64-bit platforms have immediate single-floats. 756 #!+64-bit 757 (make-random-descriptor (logior (ash (single-float-bits x) 32) 758 sb!vm::single-float-widetag)) 759 #!-64-bit 760 (let ((des (allocate-header+object *dynamic* 761 (1- sb!vm:single-float-size) 762 sb!vm:single-float-widetag))) 763 (write-wordindexed/raw des sb!vm:single-float-value-slot 764 (single-float-bits x)) 765 des)) 766 (double-float 767 (let ((des (allocate-header+object *dynamic* 768 (1- sb!vm:double-float-size) 769 sb!vm:double-float-widetag))) 770 (write-double-float-bits des sb!vm:double-float-value-slot x))))) 771 772(defun complex-single-float-to-core (num) 773 (declare (type (complex single-float) num)) 774 (let ((des (allocate-header+object *dynamic* 775 (1- sb!vm:complex-single-float-size) 776 sb!vm:complex-single-float-widetag))) 777 #!-64-bit 778 (progn 779 (write-wordindexed/raw des sb!vm:complex-single-float-real-slot 780 (single-float-bits (realpart num))) 781 (write-wordindexed/raw des sb!vm:complex-single-float-imag-slot 782 (single-float-bits (imagpart num)))) 783 #!+64-bit 784 (write-wordindexed/raw 785 des sb!vm:complex-single-float-data-slot 786 (logior (ldb (byte 32 0) (single-float-bits (realpart num))) 787 (ash (single-float-bits (imagpart num)) 32))) 788 des)) 789 790(defun complex-double-float-to-core (num) 791 (declare (type (complex double-float) num)) 792 (let ((des (allocate-header+object *dynamic* 793 (1- sb!vm:complex-double-float-size) 794 sb!vm:complex-double-float-widetag))) 795 (write-double-float-bits des sb!vm:complex-double-float-real-slot 796 (realpart num)) 797 (write-double-float-bits des sb!vm:complex-double-float-imag-slot 798 (imagpart num)))) 799 800;;; Copy the given number to the core. 801(defun number-to-core (number) 802 (typecase number 803 (integer (or (%fixnum-descriptor-if-possible number) 804 (bignum-to-core number))) 805 (ratio (number-pair-to-core (number-to-core (numerator number)) 806 (number-to-core (denominator number)) 807 sb!vm:ratio-widetag)) 808 ((complex single-float) (complex-single-float-to-core number)) 809 ((complex double-float) (complex-double-float-to-core number)) 810 #!+long-float 811 ((complex long-float) 812 (error "~S isn't a cold-loadable number at all!" number)) 813 (complex (number-pair-to-core (number-to-core (realpart number)) 814 (number-to-core (imagpart number)) 815 sb!vm:complex-widetag)) 816 (float (float-to-core number)) 817 (t (error "~S isn't a cold-loadable number at all!" number)))) 818 819;;; Allocate a cons cell in GSPACE and fill it in with CAR and CDR. 820(defun cold-cons (car cdr &optional (gspace *dynamic*)) 821 (let ((dest (allocate-object gspace 2 sb!vm:list-pointer-lowtag))) 822 (write-wordindexed dest sb!vm:cons-car-slot car) 823 (write-wordindexed dest sb!vm:cons-cdr-slot cdr) 824 dest)) 825(defun list-to-core (list) 826 (let ((head *nil-descriptor*) 827 (tail nil)) 828 ;; A recursive algorithm would have the first cons at the highest 829 ;; address. This way looks nicer when viewed in ldb. 830 (loop 831 (unless list (return head)) 832 (let ((cons (cold-cons (pop list) *nil-descriptor*))) 833 (if tail (cold-rplacd tail cons) (setq head cons)) 834 (setq tail cons))))) 835(defun cold-list (&rest args) (list-to-core args)) 836(defun cold-list-length (list) ; but no circularity detection 837 ;; a recursive implementation uses too much stack for some Lisps 838 (let ((n 0)) 839 (loop (if (cold-null list) (return n)) 840 (incf n) 841 (setq list (cold-cdr list))))) 842 843;;; Make a simple-vector on the target that holds the specified 844;;; OBJECTS, and return its descriptor. 845;;; This is really "vectorify-list-into-core" but that's too wordy, 846;;; so historically it was "vector-in-core" which is a fine name. 847(defun vector-in-core (objects &optional (gspace *dynamic*)) 848 (let* ((size (length objects)) 849 (result (allocate-vector-object gspace sb!vm:n-word-bits size 850 sb!vm:simple-vector-widetag))) 851 (dotimes (index size) 852 (write-wordindexed result (+ index sb!vm:vector-data-offset) 853 (pop objects))) 854 result)) 855(defun cold-svset (vector index value) 856 (let ((i (if (integerp index) index (descriptor-fixnum index)))) 857 (write-wordindexed vector (+ i sb!vm:vector-data-offset) value))) 858 859(setf (get 'vector :sb-cold-funcall-handler/for-value) 860 (lambda (&rest args) (vector-in-core args))) 861 862(declaim (inline cold-vector-len cold-svref)) 863(defun cold-vector-len (vector) 864 (descriptor-fixnum (read-wordindexed vector sb!vm:vector-length-slot))) 865(defun cold-svref (vector i) 866 (read-wordindexed vector (+ (if (integerp i) i (descriptor-fixnum i)) 867 sb!vm:vector-data-offset))) 868(defun cold-vector-elements-eq (a b) 869 (and (eql (cold-vector-len a) (cold-vector-len b)) 870 (dotimes (k (cold-vector-len a) t) 871 (unless (descriptor= (cold-svref a k) (cold-svref b k)) 872 (return nil))))) 873(defun vector-from-core (descriptor &optional (transform #'identity)) 874 (let* ((len (cold-vector-len descriptor)) 875 (vector (make-array len))) 876 (dotimes (i len vector) 877 (setf (aref vector i) (funcall transform (cold-svref descriptor i)))))) 878 879;;;; symbol magic 880 881;; Simulate *FREE-TLS-INDEX*. This is a count, not a displacement. 882;; In C, sizeof counts 1 word for the variable-length interrupt_contexts[] 883;; but primitive-object-size counts 0, so add 1, though in fact the C code 884;; implies that it might have overcounted by 1. We could make this agnostic 885;; of MAX-INTERRUPTS by moving the thread base register up by TLS-SIZE words, 886;; using negative offsets for all dynamically assigned indices. 887(defvar *genesis-tls-counter* 888 (+ 1 sb!vm::max-interrupts 889 (sb!vm:primitive-object-size 890 (find 'sb!vm::thread sb!vm:*primitive-objects* 891 :key #'sb!vm:primitive-object-name)))) 892 893#!+sb-thread 894(progn 895 ;; Assign SYMBOL the tls-index INDEX. SYMBOL must be a descriptor. 896 ;; This is a backend support routine, but the style within this file 897 ;; is to conditionalize by the target features. 898 (defun cold-assign-tls-index (symbol index) 899 #!+64-bit 900 (write-wordindexed/raw 901 symbol 0 (logior (ash index 32) (read-bits-wordindexed symbol 0))) 902 #!-64-bit 903 (write-wordindexed/raw symbol sb!vm:symbol-tls-index-slot index)) 904 905 ;; Return SYMBOL's tls-index, 906 ;; choosing a new index if it doesn't have one yet. 907 (defun ensure-symbol-tls-index (symbol) 908 (let* ((cold-sym (cold-intern symbol)) 909 (tls-index 910 #!+64-bit 911 (ldb (byte 32 32) (read-bits-wordindexed cold-sym 0)) 912 #!-64-bit 913 (read-bits-wordindexed cold-sym sb!vm:symbol-tls-index-slot))) 914 (unless (plusp tls-index) 915 (let ((next (prog1 *genesis-tls-counter* (incf *genesis-tls-counter*)))) 916 (setq tls-index (ash next sb!vm:word-shift)) 917 (cold-assign-tls-index cold-sym tls-index))) 918 tls-index))) 919 920;; A table of special variable names which get known TLS indices. 921;; Some of them are mapped onto 'struct thread' and have pre-determined offsets. 922;; Others are static symbols used with bind_variable() in the C runtime, 923;; and might not, in the absence of this table, get an index assigned by genesis 924;; depending on whether the cross-compiler used the BIND vop on them. 925;; Indices for those static symbols can be chosen arbitrarily, which is to say 926;; the value doesn't matter but must update the tls-counter correctly. 927;; All symbols other than the ones in this table get the indices assigned 928;; by the fasloader on demand. 929#!+sb-thread 930(defvar *known-tls-symbols* 931 ;; FIXME: no mechanism exists to determine which static symbols C code will 932 ;; dynamically bind. TLS is a finite resource, and wasting indices for all 933 ;; static symbols isn't the best idea. This list was hand-made with 'grep'. 934 '(sb!vm:*alloc-signal* 935 sb!sys:*allow-with-interrupts* 936 sb!vm:*current-catch-block* 937 sb!vm::*current-unwind-protect-block* 938 sb!kernel:*free-interrupt-context-index* 939 sb!kernel:*gc-inhibit* 940 sb!kernel:*gc-pending* 941 sb!impl::*gc-safe* 942 sb!impl::*in-safepoint* 943 sb!sys:*interrupt-pending* 944 sb!sys:*interrupts-enabled* 945 sb!vm::*pinned-objects* 946 sb!kernel:*restart-clusters* 947 sb!kernel:*stop-for-gc-pending* 948 #!+sb-thruption 949 sb!sys:*thruption-pending*)) 950 951;;; Symbol print names are coalesced by string=. 952;;; This is valid because it is an error to modify a print name. 953(defvar *symbol-name-strings* (make-hash-table :test 'equal)) 954 955(defvar *cold-symbol-gspace* (or #!+immobile-space '*immobile-fixedobj* '*dynamic*)) 956 957;;; Allocate (and initialize) a symbol. 958(defun allocate-symbol (name interned 959 &key (gspace (symbol-value *cold-symbol-gspace*))) 960 (declare (simple-string name)) 961 (declare (ignore interned)) 962 #!+immobile-space 963 (when (and (eq gspace *immobile-fixedobj*) (char/= (char name 0) #\*)) 964 ;; immobile symbols that aren't likely to be special vars 965 ;; should go in regular dynamic space until a de-frag pass is 966 ;; implemented for save-lisp-and-die. Otherwise they create 967 ;; tons of holes all over the immobile space. 968 (setq gspace *dynamic*)) 969 (let ((symbol (allocate-header+object 970 gspace (1- sb!vm:symbol-size) 971 sb!vm:symbol-header-widetag 972 ;; Tell the allocator what kind of symbol page to prefer. 973 ;; This only affects gc performance, not correctness. 974 0))) 975 (write-wordindexed symbol sb!vm:symbol-value-slot *unbound-marker*) 976 (write-wordindexed symbol sb!vm:symbol-hash-slot (make-fixnum-descriptor 0)) 977 (write-wordindexed symbol sb!vm:symbol-info-slot *nil-descriptor*) 978 (write-wordindexed symbol sb!vm:symbol-name-slot 979 (or (gethash name *symbol-name-strings*) 980 (setf (gethash name *symbol-name-strings*) 981 (base-string-to-core name *dynamic*)))) 982 (write-wordindexed symbol sb!vm:symbol-package-slot *nil-descriptor*) 983 symbol)) 984 985#!+sb-thread 986(defun assign-tls-index (symbol cold-symbol) 987 (let ((index (info :variable :wired-tls symbol))) 988 (cond ((integerp index) ; thread slot 989 (cold-assign-tls-index cold-symbol index)) 990 ((memq symbol *known-tls-symbols*) 991 ;; symbols without which the C runtime could not start 992 (shiftf index *genesis-tls-counter* (1+ *genesis-tls-counter*)) 993 (cold-assign-tls-index cold-symbol (ash index sb!vm:word-shift)))))) 994 995;;; Set the cold symbol value of SYMBOL-OR-SYMBOL-DES, which can be either a 996;;; descriptor of a cold symbol or (in an abbreviation for the 997;;; most common usage pattern) an ordinary symbol, which will be 998;;; automatically cold-interned. 999(declaim (ftype (function ((or symbol descriptor) descriptor)) cold-set)) 1000(defun cold-set (symbol-or-symbol-des value) 1001 (let ((symbol-des (etypecase symbol-or-symbol-des 1002 (descriptor symbol-or-symbol-des) 1003 (symbol (cold-intern symbol-or-symbol-des))))) 1004 (write-wordindexed symbol-des sb!vm:symbol-value-slot value))) 1005(defun cold-symbol-value (symbol) 1006 (let ((val (read-wordindexed (cold-intern symbol) sb!vm:symbol-value-slot))) 1007 (if (= (descriptor-bits val) sb!vm:unbound-marker-widetag) 1008 (unbound-cold-symbol-handler symbol) 1009 val))) 1010(defun cold-fdefn-fun (cold-fdefn) 1011 (read-wordindexed cold-fdefn sb!vm:fdefn-fun-slot)) 1012 1013(defun unbound-cold-symbol-handler (symbol) 1014 (let ((host-val (and (boundp symbol) (symbol-value symbol)))) 1015 (if (typep host-val 'sb!kernel:named-type) 1016 (let ((target-val (ctype-to-core (sb!kernel:named-type-name host-val) 1017 host-val))) 1018 ;; Though it looks complicated to assign cold symbols on demand, 1019 ;; it avoids writing code to build the layout of NAMED-TYPE in the 1020 ;; way we build other primordial stuff such as layout-of-layout. 1021 (cold-set symbol target-val) 1022 target-val) 1023 (error "Taking Cold-symbol-value of unbound symbol ~S" symbol)))) 1024 1025;;;; layouts and type system pre-initialization 1026 1027;;; Since we want to be able to dump structure constants and 1028;;; predicates with reference layouts, we need to create layouts at 1029;;; cold-load time. We use the name to intern layouts by, and dump a 1030;;; list of all cold layouts in *!INITIAL-LAYOUTS* so that type system 1031;;; initialization can find them. The only thing that's tricky [sic -- 1032;;; WHN 19990816] is initializing layout's layout, which must point to 1033;;; itself. 1034 1035;;; a map from name as a host symbol to the descriptor of its target layout 1036(defvar *cold-layouts* (make-hash-table :test 'equal)) 1037 1038;;; a map from DESCRIPTOR-BITS of cold layouts to the name, for inverting 1039;;; mapping 1040(defvar *cold-layout-names* (make-hash-table :test 'eql)) 1041 1042;;; FIXME: *COLD-LAYOUTS* and *COLD-LAYOUT-NAMES* should be 1043;;; initialized by binding in GENESIS. 1044 1045;;; the descriptor for layout's layout (needed when making layouts) 1046(defvar *layout-layout*) 1047;;; the descriptor for PACKAGE's layout (needed when making packages) 1048(defvar *package-layout*) 1049 1050(defvar *known-structure-classoids*) 1051 1052(defconstant target-layout-length 1053 ;; LAYOUT-LENGTH counts the number of words in an instance, 1054 ;; including the layout itself as 1 word 1055 (layout-length *host-layout-of-layout*)) 1056 1057;;; Return a list of names created from the cold layout INHERITS data 1058;;; in X. 1059(defun listify-cold-inherits (x) 1060 (map 'list (lambda (des) 1061 (or (gethash (descriptor-bits des) *cold-layout-names*) 1062 (error "~S is not the descriptor of a cold-layout" des))) 1063 (vector-from-core x))) 1064 1065;;; COLD-DD-SLOTS is a cold descriptor for the list of slots 1066;;; in a cold defstruct-description. INDEX is a DSD-INDEX. 1067;;; Return the host's accessor name for the host image of that slot. 1068(defun dsd-accessor-from-cold-slots (cold-dd-slots desired-index) 1069 (let* ((dsd-slots (dd-slots 1070 (find-defstruct-description 'defstruct-slot-description))) 1071 (index-slot 1072 (dsd-index (find 'sb!kernel::index dsd-slots :key #'dsd-name))) 1073 (accessor-fun-name-slot 1074 (dsd-index (find 'sb!kernel::accessor-name dsd-slots :key #'dsd-name)))) 1075 (do ((list cold-dd-slots (cold-cdr list))) 1076 ((cold-null list)) 1077 (when (= (descriptor-fixnum 1078 (read-wordindexed (cold-car list) 1079 (+ sb!vm:instance-slots-offset index-slot))) 1080 desired-index) 1081 (return 1082 (warm-symbol 1083 (read-wordindexed (cold-car list) 1084 (+ sb!vm:instance-slots-offset 1085 accessor-fun-name-slot)))))))) 1086 1087(flet ((get-slots (host-layout-or-type) 1088 (etypecase host-layout-or-type 1089 (layout (dd-slots (layout-info host-layout-or-type))) 1090 (symbol (dd-slots-from-core host-layout-or-type)))) 1091 (get-slot-index (slots initarg) 1092 (+ sb!vm:instance-slots-offset 1093 (if (descriptor-p slots) 1094 (do ((dsd-layout (find-layout 'defstruct-slot-description)) 1095 (slots slots (cold-cdr slots))) 1096 ((cold-null slots) (error "No slot for ~S" initarg)) 1097 (let* ((dsd (cold-car slots)) 1098 (slot-name (read-slot dsd dsd-layout :name))) 1099 (when (eq (keywordicate (warm-symbol slot-name)) initarg) 1100 ;; Untagged slots are not accessible during cold-load 1101 (aver (eql (descriptor-fixnum 1102 (read-slot dsd dsd-layout :%raw-type)) -1)) 1103 (return (descriptor-fixnum 1104 (read-slot dsd dsd-layout :index)))))) 1105 (let ((dsd (find initarg slots 1106 :test (lambda (x y) 1107 (eq x (keywordicate (dsd-name y))))))) 1108 (aver (eq (dsd-raw-type dsd) t)) ; Same as above: no can do. 1109 (dsd-index dsd)))))) 1110 (defun write-slots (cold-object host-layout-or-type &rest assignments) 1111 (aver (evenp (length assignments))) 1112 (let ((slots (get-slots host-layout-or-type))) 1113 (loop for (initarg value) on assignments by #'cddr 1114 do (write-wordindexed 1115 cold-object (get-slot-index slots initarg) value))) 1116 cold-object) 1117 1118 ;; For symmetry, the reader takes an initarg, not a slot name. 1119 (defun read-slot (cold-object host-layout-or-type slot-initarg) 1120 (let ((slots (get-slots host-layout-or-type))) 1121 (read-wordindexed cold-object (get-slot-index slots slot-initarg))))) 1122 1123;; Given a TYPE-NAME of a structure-class, find its defstruct-description 1124;; as a target descriptor, and return the slot list as a target descriptor. 1125(defun dd-slots-from-core (type-name) 1126 (let* ((host-dd-layout (find-layout 'defstruct-description)) 1127 (target-dd 1128 ;; This is inefficient, but not enough so to worry about. 1129 (or (car (assoc (cold-intern type-name) *known-structure-classoids* 1130 :key (lambda (x) (read-slot x host-dd-layout :name)) 1131 :test #'descriptor=)) 1132 (error "No known layout for ~S" type-name)))) 1133 (read-slot target-dd host-dd-layout :slots))) 1134 1135(defvar *simple-vector-0-descriptor*) 1136(defvar *vacuous-slot-table*) 1137(defvar *cold-layout-gspace* (or #!+immobile-space '*immobile-fixedobj* '*dynamic*)) 1138(declaim (ftype (function (symbol descriptor descriptor descriptor descriptor) 1139 descriptor) 1140 make-cold-layout)) 1141(defun make-cold-layout (name length inherits depthoid bitmap) 1142 (let ((result (allocate-struct (symbol-value *cold-layout-gspace*) *layout-layout* 1143 target-layout-length t))) 1144 ;; Don't set the CLOS hash value: done in cold-init instead. 1145 ;; 1146 ;; Set other slot values. 1147 ;; 1148 ;; leave CLASSOID uninitialized for now 1149 (multiple-value-call 1150 #'write-slots result *host-layout-of-layout* 1151 :invalid *nil-descriptor* 1152 :inherits inherits 1153 :depthoid depthoid 1154 :length length 1155 :info *nil-descriptor* 1156 :pure *nil-descriptor* 1157 :bitmap bitmap 1158 ;; Nothing in cold-init needs to call EQUALP on a structure with raw slots, 1159 ;; but for type-correctness this slot needs to be a simple-vector. 1160 :equalp-tests (if (boundp '*simple-vector-0-descriptor*) 1161 *simple-vector-0-descriptor* 1162 (setq *simple-vector-0-descriptor* 1163 (vector-in-core nil))) 1164 :source-location *nil-descriptor* 1165 :%for-std-class-b (make-fixnum-descriptor 0) 1166 :slot-list *nil-descriptor* 1167 (if (member name '(null list symbol)) 1168 ;; Assign an empty slot-table. Why this is done only for three 1169 ;; classoids is ... too complicated to explain here in a few words, 1170 ;; but revision 18c239205d9349abc017b07e7894a710835c5205 broke it. 1171 ;; Keep this in sync with MAKE-SLOT-TABLE in pcl/slots-boot. 1172 (values :slot-table (if (boundp '*vacuous-slot-table*) 1173 *vacuous-slot-table* 1174 (setq *vacuous-slot-table* 1175 (host-constant-to-core '#(1 nil))))) 1176 (values))) 1177 1178 (setf (gethash (descriptor-bits result) *cold-layout-names*) name 1179 (gethash name *cold-layouts*) result))) 1180 1181;;; Convert SPECIFIER (equivalently OBJ) to its representation as a ctype 1182;;; in the cold core. 1183(defvar *ctype-cache*) 1184 1185(defvar *ctype-nullified-slots* nil) 1186(defvar *built-in-classoid-nullified-slots* nil) 1187 1188;; This function is memoized because it's essentially a constant, 1189;; but *nil-descriptor* isn't initialized by the time it's defined. 1190(defun get-exceptional-slots (obj-type) 1191 (flet ((index (classoid-name slot-name) 1192 (dsd-index (find slot-name 1193 (dd-slots (find-defstruct-description classoid-name)) 1194 :key #'dsd-name)))) 1195 (case obj-type 1196 (built-in-classoid 1197 (or *built-in-classoid-nullified-slots* 1198 (setq *built-in-classoid-nullified-slots* 1199 (append (get-exceptional-slots 'ctype) 1200 (list (cons (index 'built-in-classoid 'sb!kernel::subclasses) 1201 *nil-descriptor*) 1202 (cons (index 'built-in-classoid 'layout) 1203 *nil-descriptor*)))))) 1204 (t 1205 (or *ctype-nullified-slots* 1206 (setq *ctype-nullified-slots* 1207 (list (cons (index 'ctype 'sb!kernel::class-info) 1208 *nil-descriptor*)))))))) 1209 1210(defun ctype-to-core (specifier obj) 1211 (declare (type ctype obj)) 1212 (if (classoid-p obj) 1213 (let* ((cell (cold-find-classoid-cell (classoid-name obj) :create t)) 1214 (cold-classoid 1215 (read-slot cell (find-layout 'sb!kernel::classoid-cell) :classoid))) 1216 (unless (cold-null cold-classoid) 1217 (return-from ctype-to-core cold-classoid))) 1218 ;; CTYPEs can't be TYPE=-hashed, but specifiers can be EQUAL-hashed. 1219 ;; Don't check the cache for classoids though; that would be wrong. 1220 ;; e.g. named-type T and classoid T both unparse to T. 1221 (awhen (gethash specifier *ctype-cache*) 1222 (return-from ctype-to-core it))) 1223 (let ((result 1224 (ctype-to-core-helper 1225 obj 1226 (lambda (obj) 1227 (typecase obj 1228 (xset (ctype-to-core-helper obj nil nil)) 1229 (ctype (ctype-to-core (type-specifier obj) obj)))) 1230 (get-exceptional-slots (type-of obj))))) 1231 (let ((type-class-vector 1232 (cold-symbol-value 'sb!kernel::*type-classes*)) 1233 (index (position (sb!kernel::type-class-info obj) 1234 sb!kernel::*type-classes*))) 1235 ;; Push this instance into the list of fixups for its type class 1236 (cold-svset type-class-vector index 1237 (cold-cons result (cold-svref type-class-vector index)))) 1238 (if (classoid-p obj) 1239 ;; Place this classoid into its clasoid-cell. 1240 (let ((cell (cold-find-classoid-cell (classoid-name obj) :create t))) 1241 (write-slots cell (find-layout 'sb!kernel::classoid-cell) 1242 :classoid result)) 1243 ;; Otherwise put it in the general cache 1244 (setf (gethash specifier *ctype-cache*) result)) 1245 result)) 1246 1247(defun ctype-to-core-helper (obj obj-to-core-helper exceptional-slots) 1248 (let* ((host-type (type-of obj)) 1249 (target-layout (or (gethash host-type *cold-layouts*) 1250 (error "No target layout for ~S" obj))) 1251 (result (allocate-struct *dynamic* target-layout)) 1252 (cold-dd-slots (dd-slots-from-core host-type))) 1253 (aver (eql (layout-bitmap (find-layout host-type)) 1254 sb!kernel::+layout-all-tagged+)) 1255 ;; Dump the slots. 1256 (do ((len (cold-layout-length target-layout)) 1257 (index sb!vm:instance-data-start (1+ index))) 1258 ((= index len) result) 1259 (write-wordindexed 1260 result 1261 (+ sb!vm:instance-slots-offset index) 1262 (acond ((assq index exceptional-slots) (cdr it)) 1263 (t (host-constant-to-core 1264 (funcall (dsd-accessor-from-cold-slots cold-dd-slots index) 1265 obj) 1266 obj-to-core-helper))))))) 1267 1268;; This is called to backpatch three small sets of objects: 1269;; - layouts which are made before layout-of-layout is made (4 of them) 1270;; - packages, which are made before layout-of-package is made (all of them) 1271;; - a small number of classoid-cells (probably 3 or 4). 1272(defun patch-instance-layout (thing layout) 1273 #!+compact-instance-header 1274 ;; High half of the header points to the layout 1275 (write-wordindexed/raw thing 0 (logior (ash (descriptor-bits layout) 32) 1276 (read-bits-wordindexed thing 0))) 1277 #!-compact-instance-header 1278 ;; Word following the header is the layout 1279 (write-wordindexed thing sb!vm:instance-slots-offset layout)) 1280 1281(defun cold-layout-of (cold-struct) 1282 #!+compact-instance-header 1283 (let ((bits (ash (read-bits-wordindexed cold-struct 0) -32))) 1284 (if (zerop bits) *nil-descriptor* (make-random-descriptor bits))) 1285 #!-compact-instance-header 1286 (read-wordindexed cold-struct sb!vm:instance-slots-offset)) 1287 1288(defun initialize-layouts () 1289 (clrhash *cold-layouts*) 1290 ;; This assertion is due to the fact that MAKE-COLD-LAYOUT does not 1291 ;; know how to set any raw slots. 1292 (aver (eql (layout-bitmap *host-layout-of-layout*) 1293 sb!kernel::+layout-all-tagged+)) 1294 (setq *layout-layout* (make-fixnum-descriptor 0)) 1295 (flet ((chill-layout (name &rest inherits) 1296 ;; Check that the number of specified INHERITS matches 1297 ;; the length of the layout's inherits in the cross-compiler. 1298 (let ((warm-layout (classoid-layout (find-classoid name)))) 1299 (assert (eql (length (layout-inherits warm-layout)) 1300 (length inherits))) 1301 (make-cold-layout 1302 name 1303 (number-to-core (layout-length warm-layout)) 1304 (vector-in-core inherits) 1305 (number-to-core (layout-depthoid warm-layout)) 1306 (number-to-core (layout-bitmap warm-layout)))))) 1307 (let* ((t-layout (chill-layout 't)) 1308 (s-o-layout (chill-layout 'structure-object t-layout))) 1309 (setf *layout-layout* 1310 (chill-layout 'layout t-layout s-o-layout)) 1311 (dolist (layout (list t-layout s-o-layout *layout-layout*)) 1312 (patch-instance-layout layout *layout-layout*)) 1313 (setf *package-layout* 1314 (chill-layout 'package t-layout s-o-layout))))) 1315 1316;;;; interning symbols in the cold image 1317 1318;;; a map from package name as a host string to 1319;;; (cold-package-descriptor . (external-symbols . internal-symbols)) 1320(defvar *cold-package-symbols*) 1321(declaim (type hash-table *cold-package-symbols*)) 1322 1323(setf (get 'find-package :sb-cold-funcall-handler/for-value) 1324 (lambda (descriptor &aux (name (base-string-from-core descriptor))) 1325 (or (car (gethash name *cold-package-symbols*)) 1326 (error "Genesis could not find a target package named ~S" name)))) 1327 1328(defvar *classoid-cells*) 1329(defun cold-find-classoid-cell (name &key create) 1330 (aver (eq create t)) 1331 (or (gethash name *classoid-cells*) 1332 (let ((layout (gethash 'sb!kernel::classoid-cell *cold-layouts*)) ; ok if nil 1333 (host-layout (find-layout 'sb!kernel::classoid-cell))) 1334 (setf (gethash name *classoid-cells*) 1335 (write-slots (allocate-struct *dynamic* layout 1336 (layout-length host-layout)) 1337 host-layout 1338 :name name 1339 :pcl-class *nil-descriptor* 1340 :classoid *nil-descriptor*))))) 1341 1342(setf (get 'find-classoid-cell :sb-cold-funcall-handler/for-value) 1343 #'cold-find-classoid-cell) 1344 1345;;; a map from descriptors to symbols, so that we can back up. The key 1346;;; is the address in the target core. 1347(defvar *cold-symbols*) 1348(declaim (type hash-table *cold-symbols*)) 1349 1350(defun initialize-packages (package-data-list) 1351 (let ((package-layout (find-layout 'package)) 1352 (target-pkg-list nil)) 1353 (labels ((init-cold-package (name &optional docstring) 1354 (let ((cold-package (car (gethash name *cold-package-symbols*)))) 1355 ;; patch in the layout 1356 (patch-instance-layout cold-package *package-layout*) 1357 ;; Initialize string slots 1358 (write-slots cold-package package-layout 1359 :%name (base-string-to-core 1360 (target-package-name name)) 1361 :%nicknames (chill-nicknames name) 1362 :doc-string (if docstring 1363 (base-string-to-core docstring) 1364 *nil-descriptor*) 1365 :%use-list *nil-descriptor*) 1366 ;; the cddr of this will accumulate the 'used-by' package list 1367 (push (list name cold-package) target-pkg-list))) 1368 (target-package-name (string) 1369 (if (eql (mismatch string "SB!") 3) 1370 (concatenate 'string "SB-" (subseq string 3)) 1371 string)) 1372 (chill-nicknames (pkg-name) 1373 (let ((result *nil-descriptor*)) 1374 ;; Make the package nickname lists for the standard packages 1375 ;; be the minimum specified by ANSI, regardless of what value 1376 ;; the cross-compilation host happens to use. 1377 ;; For packages other than the standard packages, the nickname 1378 ;; list was specified by our package setup code, and we can just 1379 ;; propagate the current state into the target. 1380 (dolist (nickname 1381 (cond ((string= pkg-name "COMMON-LISP") '("CL")) 1382 ((string= pkg-name "COMMON-LISP-USER") 1383 '("CL-USER")) 1384 ((string= pkg-name "KEYWORD") '()) 1385 (t 1386 ;; 'package-data-list' contains no nicknames. 1387 ;; (See comment in 'set-up-cold-packages') 1388 (aver (null (package-nicknames 1389 (find-package pkg-name)))) 1390 nil)) 1391 result) 1392 (cold-push (base-string-to-core nickname) result)))) 1393 (find-cold-package (name) 1394 (cadr (find-package-cell name))) 1395 (find-package-cell (name) 1396 (or (assoc (if (string= name "CL") "COMMON-LISP" name) 1397 target-pkg-list :test #'string=) 1398 (error "No cold package named ~S" name)))) 1399 ;; pass 1: make all proto-packages 1400 (dolist (pd package-data-list) 1401 (init-cold-package (sb-cold:package-data-name pd) 1402 #!+sb-doc(sb-cold::package-data-doc pd))) 1403 ;; pass 2: set the 'use' lists and collect the 'used-by' lists 1404 (dolist (pd package-data-list) 1405 (let ((this (find-cold-package (sb-cold:package-data-name pd))) 1406 (use nil)) 1407 (dolist (that (sb-cold:package-data-use pd)) 1408 (let ((cell (find-package-cell that))) 1409 (push (cadr cell) use) 1410 (push this (cddr cell)))) 1411 (write-slots this package-layout 1412 :%use-list (list-to-core (nreverse use))))) 1413 ;; pass 3: set the 'used-by' lists 1414 (dolist (cell target-pkg-list) 1415 (write-slots (cadr cell) package-layout 1416 :%used-by-list (list-to-core (cddr cell))))))) 1417 1418;;; sanity check for a symbol we're about to create on the target 1419;;; 1420;;; Make sure that the symbol has an appropriate package. In 1421;;; particular, catch the so-easy-to-make error of typing something 1422;;; like SB-KERNEL:%BYTE-BLT in cold sources when what you really 1423;;; need is SB!KERNEL:%BYTE-BLT. 1424(defun package-ok-for-target-symbol-p (package) 1425 (let ((package-name (package-name package))) 1426 (or 1427 ;; Cold interning things in these standard packages is OK. (Cold 1428 ;; interning things in the other standard package, CL-USER, isn't 1429 ;; OK. We just use CL-USER to expose symbols whose homes are in 1430 ;; other packages. Thus, trying to cold intern a symbol whose 1431 ;; home package is CL-USER probably means that a coding error has 1432 ;; been made somewhere.) 1433 (find package-name '("COMMON-LISP" "KEYWORD") :test #'string=) 1434 ;; Cold interning something in one of our target-code packages, 1435 ;; which are ever-so-rigorously-and-elegantly distinguished by 1436 ;; this prefix on their names, is OK too. 1437 (string= package-name "SB!" :end1 3 :end2 3) 1438 ;; This one is OK too, since it ends up being COMMON-LISP on the 1439 ;; target. 1440 (string= package-name "SB-XC") 1441 ;; Anything else looks bad. (maybe COMMON-LISP-USER? maybe an extension 1442 ;; package in the xc host? something we can't think of 1443 ;; a valid reason to cold intern, anyway...) 1444 ))) 1445 1446;;; like SYMBOL-PACKAGE, but safe for symbols which end up on the target 1447;;; 1448;;; Most host symbols we dump onto the target are created by SBCL 1449;;; itself, so that as long as we avoid gratuitously 1450;;; cross-compilation-unfriendly hacks, it just happens that their 1451;;; SYMBOL-PACKAGE in the host system corresponds to their 1452;;; SYMBOL-PACKAGE in the target system. However, that's not the case 1453;;; in the COMMON-LISP package, where we don't get to create the 1454;;; symbols but instead have to use the ones that the xc host created. 1455;;; In particular, while ANSI specifies which symbols are exported 1456;;; from COMMON-LISP, it doesn't specify that their home packages are 1457;;; COMMON-LISP, so the xc host can keep them in random packages which 1458;;; don't exist on the target (e.g. CLISP keeping some CL-exported 1459;;; symbols in the CLOS package). 1460(defun symbol-package-for-target-symbol (symbol) 1461 ;; We want to catch weird symbols like CLISP's 1462 ;; CL:FIND-METHOD=CLOS::FIND-METHOD, but we don't want to get 1463 ;; sidetracked by ordinary symbols like :CHARACTER which happen to 1464 ;; have the same SYMBOL-NAME as exports from COMMON-LISP. 1465 (multiple-value-bind (cl-symbol cl-status) 1466 (find-symbol (symbol-name symbol) *cl-package*) 1467 (if (and (eq symbol cl-symbol) 1468 (eq cl-status :external)) 1469 ;; special case, to work around possible xc host weirdness 1470 ;; in COMMON-LISP package 1471 *cl-package* 1472 ;; ordinary case 1473 (let ((result (symbol-package symbol))) 1474 (unless (package-ok-for-target-symbol-p result) 1475 (bug "~A in bad package for target: ~A" symbol result)) 1476 result)))) 1477 1478(defvar *uninterned-symbol-table* (make-hash-table :test #'equal)) 1479;; This coalesces references to uninterned symbols, which is allowed because 1480;; "similar-as-constant" is defined by string comparison, and since we only have 1481;; base-strings during Genesis, there is no concern about upgraded array type. 1482;; There is a subtlety of whether coalescing may occur across files 1483;; - the target compiler doesn't and couldn't - but here it doesn't matter. 1484(defun get-uninterned-symbol (name) 1485 (or (gethash name *uninterned-symbol-table*) 1486 (let ((cold-symbol (allocate-symbol name nil))) 1487 (setf (gethash name *uninterned-symbol-table*) cold-symbol)))) 1488 1489;;; Dump the target representation of HOST-VALUE, 1490;;; the type of which is in a restrictive set. 1491(defun host-constant-to-core (host-value &optional helper) 1492 (let ((visited (make-hash-table :test #'eq))) 1493 (named-let target-representation ((value host-value)) 1494 (unless (typep value '(or symbol number descriptor)) 1495 (let ((found (gethash value visited))) 1496 (cond ((eq found :pending) 1497 (bug "circular constant?")) ; Circularity not permitted 1498 (found 1499 (return-from target-representation found)))) 1500 (setf (gethash value visited) :pending)) 1501 (setf (gethash value visited) 1502 (typecase value 1503 (descriptor value) 1504 (symbol (if (symbol-package value) 1505 (cold-intern value) 1506 (get-uninterned-symbol (string value)))) 1507 (number (number-to-core value)) 1508 (string (base-string-to-core value)) 1509 (cons (cold-cons (target-representation (car value)) 1510 (target-representation (cdr value)))) 1511 (simple-vector 1512 (vector-in-core (map 'list #'target-representation value))) 1513 (t 1514 (or (and helper (funcall helper value)) 1515 (error "host-constant-to-core: can't convert ~S" 1516 value)))))))) 1517 1518;; Look up the target's descriptor for #'FUN where FUN is a host symbol. 1519(defun target-symbol-function (symbol) 1520 (let ((f (cold-fdefn-fun (cold-fdefinition-object symbol)))) 1521 ;; It works only if DEFUN F was seen first. 1522 (aver (not (cold-null f))) 1523 f)) 1524 1525;;; Create the effect of executing a (MAKE-ARRAY) call on the target. 1526;;; This is for initializing a restricted set of vector constants 1527;;; whose contents are typically function pointers. 1528(defun emulate-target-make-array (form) 1529 (destructuring-bind (size-expr &key initial-element) (cdr form) 1530 (let* ((size (eval size-expr)) 1531 (result (allocate-vector-object *dynamic* sb!vm:n-word-bits size 1532 sb!vm:simple-vector-widetag))) 1533 (aver (integerp size)) 1534 (unless (eql initial-element 0) 1535 (let ((target-initial-element 1536 (etypecase initial-element 1537 ((cons (eql function) (cons symbol null)) 1538 (target-symbol-function (second initial-element))) 1539 (null *nil-descriptor*) 1540 ;; Insert more types here ... 1541 ))) 1542 (dotimes (index size) 1543 (cold-svset result (make-fixnum-descriptor index) 1544 target-initial-element)))) 1545 result))) 1546 1547;; Return a target object produced by emulating evaluation of EXPR 1548;; with *package* set to ORIGINAL-PACKAGE. 1549(defun emulate-target-eval (expr original-package) 1550 (let ((*package* (find-package original-package))) 1551 ;; For most things, just call EVAL and dump the host object's 1552 ;; target representation. But with MAKE-ARRAY we allow that the 1553 ;; initial-element might not be evaluable in the host. 1554 ;; Embedded MAKE-ARRAY is kept as-is because we don't "look into" 1555 ;; the EXPR, just hope that it works. 1556 (if (typep expr '(cons (eql make-array))) 1557 (emulate-target-make-array expr) 1558 (host-constant-to-core (eval expr))))) 1559 1560;;; Return a handle on an interned symbol. If necessary allocate the 1561;;; symbol and record its home package. 1562(defun cold-intern (symbol 1563 &key (access nil) 1564 (gspace (symbol-value *cold-symbol-gspace*)) 1565 &aux (package (symbol-package-for-target-symbol symbol))) 1566 (aver (package-ok-for-target-symbol-p package)) 1567 1568 ;; Anything on the cross-compilation host which refers to the target 1569 ;; machinery through the host SB-XC package should be translated to 1570 ;; something on the target which refers to the same machinery 1571 ;; through the target COMMON-LISP package. 1572 (let ((p (find-package "SB-XC"))) 1573 (when (eq package p) 1574 (setf package *cl-package*)) 1575 (when (eq (symbol-package symbol) p) 1576 (setf symbol (intern (symbol-name symbol) *cl-package*)))) 1577 1578 (or (get symbol 'cold-intern-info) 1579 (let ((pkg-info (gethash (package-name package) *cold-package-symbols*)) 1580 (handle (allocate-symbol (symbol-name symbol) t :gspace gspace))) 1581 ;; maintain reverse map from target descriptor to host symbol 1582 (setf (gethash (descriptor-bits handle) *cold-symbols*) symbol) 1583 (unless pkg-info 1584 (error "No target package descriptor for ~S" package)) 1585 (record-accessibility 1586 (or access (nth-value 1 (find-symbol (symbol-name symbol) package))) 1587 handle pkg-info symbol package t) 1588 #!+sb-thread 1589 (assign-tls-index symbol handle) 1590 (acond ((eq package *keyword-package*) 1591 (setq access :external) 1592 (cold-set handle handle)) 1593 ((assoc symbol sb-cold:*symbol-values-for-genesis*) 1594 (cold-set handle (destructuring-bind (expr . package) (cdr it) 1595 (emulate-target-eval expr package))))) 1596 (setf (get symbol 'cold-intern-info) handle)))) 1597 1598(defun record-accessibility (accessibility symbol-descriptor target-pkg-info 1599 host-symbol host-package &optional set-home-p) 1600 (when set-home-p 1601 (write-wordindexed symbol-descriptor sb!vm:symbol-package-slot 1602 (car target-pkg-info))) 1603 (let ((access-lists (cdr target-pkg-info))) 1604 (case accessibility 1605 (:external (push symbol-descriptor (car access-lists))) 1606 (:internal (push symbol-descriptor (cdr access-lists))) 1607 (t (error "~S inaccessible in package ~S" host-symbol host-package))))) 1608 1609;;; Construct and return a value for use as *NIL-DESCRIPTOR*. 1610;;; It might be nice to put NIL on a readonly page by itself to prevent unsafe 1611;;; code from destroying the world with (RPLACx nil 'kablooey) 1612(defun make-nil-descriptor (target-cl-pkg-info) 1613 (let* ((des (allocate-header+object *static* sb!vm:symbol-size 0)) 1614 (result (make-descriptor (+ (descriptor-bits des) 1615 (* 2 sb!vm:n-word-bytes) 1616 (- sb!vm:list-pointer-lowtag 1617 sb!vm:other-pointer-lowtag))))) 1618 (write-wordindexed des 1619 1 1620 (make-other-immediate-descriptor 1621 0 1622 sb!vm:symbol-header-widetag)) 1623 (write-wordindexed des 1624 (+ 1 sb!vm:symbol-value-slot) 1625 result) 1626 (write-wordindexed des 1627 (+ 2 sb!vm:symbol-value-slot) ; = 1 + symbol-hash-slot 1628 result) 1629 (write-wordindexed des 1630 (+ 1 sb!vm:symbol-info-slot) 1631 (cold-cons result result)) ; NIL's info is (nil . nil) 1632 (write-wordindexed des 1633 (+ 1 sb!vm:symbol-name-slot) 1634 ;; NIL's name is in dynamic space because any extra 1635 ;; bytes allocated in static space would need to 1636 ;; be accounted for by STATIC-SYMBOL-OFFSET. 1637 (base-string-to-core "NIL" *dynamic*)) 1638 ;; RECORD-ACCESSIBILITY can't assign to the package slot 1639 ;; due to NIL's base address and lowtag being nonstandard. 1640 (write-wordindexed des 1641 (+ 1 sb!vm:symbol-package-slot) 1642 (car target-cl-pkg-info)) 1643 (record-accessibility :external result target-cl-pkg-info nil *cl-package*) 1644 (setf (gethash (descriptor-bits result) *cold-symbols*) nil 1645 (get nil 'cold-intern-info) result))) 1646 1647;;; Since the initial symbols must be allocated before we can intern 1648;;; anything else, we intern those here. We also set the value of T. 1649(defun initialize-non-nil-symbols () 1650 "Initialize the cold load symbol-hacking data structures." 1651 ;; Intern the others. 1652 (dolist (symbol sb!vm:*static-symbols*) 1653 (let* ((des (cold-intern symbol :gspace *static*)) 1654 (offset-wanted (sb!vm:static-symbol-offset symbol)) 1655 (offset-found (- (descriptor-bits des) 1656 (descriptor-bits *nil-descriptor*)))) 1657 (unless (= offset-wanted offset-found) 1658 ;; FIXME: should be fatal 1659 (warn "Offset from ~S to ~S is ~W, not ~W" 1660 symbol 1661 nil 1662 offset-found 1663 offset-wanted)))) 1664 ;; Establish the value of T. 1665 (let ((t-symbol (cold-intern t :gspace *static*))) 1666 (cold-set t-symbol t-symbol)) 1667 ;; Establish the value of *PSEUDO-ATOMIC-BITS* so that the 1668 ;; allocation sequences that expect it to be zero upon entrance 1669 ;; actually find it to be so. 1670 #!+(or x86-64 x86) 1671 (let ((p-a-a-symbol (cold-intern '*pseudo-atomic-bits* 1672 :gspace *static*))) 1673 (cold-set p-a-a-symbol (make-fixnum-descriptor 0)))) 1674 1675;;; Sort *COLD-LAYOUTS* to return them in a deterministic order. 1676(defun sort-cold-layouts () 1677 (sort (%hash-table-alist *cold-layouts*) #'< 1678 :key (lambda (x) (descriptor-bits (cdr x))))) 1679 1680;;; a helper function for FINISH-SYMBOLS: Return a cold alist suitable 1681;;; to be stored in *!INITIAL-LAYOUTS*. 1682(defun cold-list-all-layouts () 1683 (let ((result *nil-descriptor*)) 1684 (dolist (layout (sort-cold-layouts) result) 1685 (cold-push (cold-cons (cold-intern (car layout)) (cdr layout)) 1686 result)))) 1687 1688;;; Establish initial values for magic symbols. 1689;;; 1690(defun finish-symbols () 1691 1692 ;; Everything between this preserved-for-posterity comment down to 1693 ;; the assignment of *CURRENT-CATCH-BLOCK* could be entirely deleted, 1694 ;; including the list of *C-CALLABLE-STATIC-SYMBOLS* itself, 1695 ;; if it is GC-safe for the C runtime to have its own implementation 1696 ;; of the INFO-VECTOR-FDEFN function in a multi-threaded build. 1697 ;; 1698 ;; "I think the point of setting these functions into SYMBOL-VALUEs 1699 ;; here, instead of using SYMBOL-FUNCTION, is that in CMU CL 1700 ;; SYMBOL-FUNCTION reduces to FDEFINITION, which is a pretty 1701 ;; hairy operation (involving globaldb.lisp etc.) which we don't 1702 ;; want to invoke early in cold init. -- WHN 2001-12-05" 1703 ;; 1704 ;; So... that's no longer true. We _do_ associate symbol -> fdefn in genesis. 1705 ;; Additionally, the INFO-VECTOR-FDEFN function is extremely simple and could 1706 ;; easily be implemented in C. However, info-vectors are inevitably 1707 ;; reallocated when new info is attached to a symbol, so the vectors can't be 1708 ;; in static space; they'd gradually become permanent garbage if they did. 1709 ;; That's the real reason for preserving the approach of storing an #<fdefn> 1710 ;; in a symbol's value cell - that location is static, the symbol-info is not. 1711 1712 ;; FIXME: So OK, that's a reasonable reason to do something weird like 1713 ;; this, but this is still a weird thing to do, and we should change 1714 ;; the names to highlight that something weird is going on. Perhaps 1715 ;; *MAYBE-GC-FUN*, *INTERNAL-ERROR-FUN*, *HANDLE-BREAKPOINT-FUN*, 1716 ;; and *HANDLE-FUN-END-BREAKPOINT-FUN*... 1717 (dolist (symbol sb!vm::*c-callable-static-symbols*) 1718 (cold-set symbol (cold-fdefinition-object (cold-intern symbol)))) 1719 1720 (cold-set 'sb!vm::*current-catch-block* (make-fixnum-descriptor 0)) 1721 (cold-set 'sb!vm::*current-unwind-protect-block* (make-fixnum-descriptor 0)) 1722 1723 (cold-set '*free-interrupt-context-index* (make-fixnum-descriptor 0)) 1724 1725 (cold-set '*!initial-layouts* (cold-list-all-layouts)) 1726 1727 #!+sb-thread 1728 (cold-set 'sb!vm::*free-tls-index* 1729 (make-descriptor (ash *genesis-tls-counter* sb!vm:word-shift))) 1730 1731 (dolist (symbol sb!impl::*cache-vector-symbols*) 1732 (cold-set symbol *nil-descriptor*)) 1733 1734 ;; Symbols for which no call to COLD-INTERN would occur - due to not being 1735 ;; referenced until warm init - must be artificially cold-interned. 1736 ;; Inasmuch as the "offending" things are compiled by ordinary target code 1737 ;; and not cold-init, I think we should use an ordinary DEFPACKAGE for 1738 ;; the added-on bits. What I've done is somewhat of a fragile kludge. 1739 (let (syms) 1740 (with-package-iterator (iter '("SB!PCL" "SB!MOP" "SB!GRAY" "SB!SEQUENCE" 1741 "SB!PROFILE" "SB!EXT" "SB!VM" 1742 "SB!C" "SB!FASL" "SB!DEBUG") 1743 :external) 1744 (loop 1745 (multiple-value-bind (foundp sym accessibility package) (iter) 1746 (declare (ignore accessibility)) 1747 (cond ((not foundp) (return)) 1748 ((eq (symbol-package sym) package) (push sym syms)))))) 1749 (setf syms (stable-sort syms #'string<)) 1750 (dolist (sym syms) 1751 (cold-intern sym))) 1752 1753 (let ((cold-pkg-inits *nil-descriptor*) 1754 cold-package-symbols-list) 1755 (maphash (lambda (name info) 1756 (push (cons name info) cold-package-symbols-list)) 1757 *cold-package-symbols*) 1758 (setf cold-package-symbols-list 1759 (sort cold-package-symbols-list #'string< :key #'car)) 1760 (dolist (pkgcons cold-package-symbols-list) 1761 (destructuring-bind (pkg-name . pkg-info) pkgcons 1762 (let ((shadow 1763 ;; Record shadowing symbols (except from SB-XC) in SB! packages. 1764 (when (eql (mismatch pkg-name "SB!") 3) 1765 ;; Be insensitive to the host's ordering. 1766 (sort (remove (find-package "SB-XC") 1767 (package-shadowing-symbols (find-package pkg-name)) 1768 :key #'symbol-package) #'string<)))) 1769 (write-slots (car (gethash pkg-name *cold-package-symbols*)) ; package 1770 (find-layout 'package) 1771 :%shadowing-symbols (list-to-core 1772 (mapcar 'cold-intern shadow)))) 1773 (unless (member pkg-name '("COMMON-LISP" "KEYWORD") :test 'string=) 1774 (let ((host-pkg (find-package pkg-name)) 1775 (sb-xc-pkg (find-package "SB-XC")) 1776 syms) 1777 ;; Now for each symbol directly present in this host-pkg, 1778 ;; i.e. accessible but not :INHERITED, figure out if the symbol 1779 ;; came from a different package, and if so, make a note of it. 1780 (with-package-iterator (iter host-pkg :internal :external) 1781 (loop (multiple-value-bind (foundp sym accessibility) (iter) 1782 (unless foundp (return)) 1783 (unless (or (eq (symbol-package sym) host-pkg) 1784 (eq (symbol-package sym) sb-xc-pkg)) 1785 (push (cons sym accessibility) syms))))) 1786 (dolist (symcons (sort syms #'string< :key #'car)) 1787 (destructuring-bind (sym . accessibility) symcons 1788 (record-accessibility accessibility (cold-intern sym) 1789 pkg-info sym host-pkg))))) 1790 (cold-push (cold-cons (car pkg-info) 1791 (cold-cons (vector-in-core (cadr pkg-info)) 1792 (vector-in-core (cddr pkg-info)))) 1793 cold-pkg-inits))) 1794 (cold-set 'sb!impl::*!initial-symbols* cold-pkg-inits)) 1795 1796 (dump-symbol-info-vectors 1797 (attach-fdefinitions-to-symbols 1798 (attach-classoid-cells-to-symbols (make-hash-table :test #'eq)))) 1799 1800 (cold-set '*!initial-debug-sources* *current-debug-sources*) 1801 1802 #!+x86 1803 (progn 1804 (cold-set 'sb!vm::*fp-constant-0d0* (number-to-core 0d0)) 1805 (cold-set 'sb!vm::*fp-constant-1d0* (number-to-core 1d0)) 1806 (cold-set 'sb!vm::*fp-constant-0f0* (number-to-core 0f0)) 1807 (cold-set 'sb!vm::*fp-constant-1f0* (number-to-core 1f0)))) 1808 1809;;;; functions and fdefinition objects 1810 1811;;; a hash table mapping from fdefinition names to descriptors of cold 1812;;; objects 1813;;; 1814;;; Note: Since fdefinition names can be lists like '(SETF FOO), and 1815;;; we want to have only one entry per name, this must be an 'EQUAL 1816;;; hash table, not the default 'EQL. 1817(defvar *cold-fdefn-objects*) 1818 1819(defvar *cold-fdefn-gspace* nil) 1820 1821;;; Given a cold representation of a symbol, return a warm 1822;;; representation. 1823(defun warm-symbol (des) 1824 ;; Note that COLD-INTERN is responsible for keeping the 1825 ;; *COLD-SYMBOLS* table up to date, so if DES happens to refer to an 1826 ;; uninterned symbol, the code below will fail. But as long as we 1827 ;; don't need to look up uninterned symbols during bootstrapping, 1828 ;; that's OK.. 1829 (multiple-value-bind (symbol found-p) 1830 (gethash (descriptor-bits des) *cold-symbols*) 1831 (declare (type symbol symbol)) 1832 (unless found-p 1833 (error "no warm symbol")) 1834 symbol)) 1835 1836;;; like CL:CAR, CL:CDR, and CL:NULL but for cold values 1837(defun cold-car (des) 1838 (aver (= (descriptor-lowtag des) sb!vm:list-pointer-lowtag)) 1839 (read-wordindexed des sb!vm:cons-car-slot)) 1840(defun cold-cdr (des) 1841 (aver (= (descriptor-lowtag des) sb!vm:list-pointer-lowtag)) 1842 (read-wordindexed des sb!vm:cons-cdr-slot)) 1843(defun cold-rplacd (des newval) 1844 (aver (= (descriptor-lowtag des) sb!vm:list-pointer-lowtag)) 1845 (write-wordindexed des sb!vm:cons-cdr-slot newval) 1846 des) 1847(defun cold-null (des) 1848 (= (descriptor-bits des) 1849 (descriptor-bits *nil-descriptor*))) 1850 1851;;; Given a cold representation of a function name, return a warm 1852;;; representation. 1853(declaim (ftype (function ((or symbol descriptor)) (or symbol list)) warm-fun-name)) 1854(defun warm-fun-name (des) 1855 (let ((result 1856 (if (symbolp des) 1857 ;; This parallels the logic at the start of COLD-INTERN 1858 ;; which re-homes symbols in SB-XC to COMMON-LISP. 1859 (if (eq (symbol-package des) (find-package "SB-XC")) 1860 (intern (symbol-name des) *cl-package*) 1861 des) 1862 (ecase (descriptor-lowtag des) 1863 (#.sb!vm:list-pointer-lowtag 1864 (aver (not (cold-null des))) ; function named NIL? please no.. 1865 ;; Do cold (DESTRUCTURING-BIND (COLD-CAR COLD-CADR) DES ..). 1866 (let* ((car-des (cold-car des)) 1867 (cdr-des (cold-cdr des)) 1868 (cadr-des (cold-car cdr-des)) 1869 (cddr-des (cold-cdr cdr-des))) 1870 (aver (cold-null cddr-des)) 1871 (list (warm-symbol car-des) 1872 (warm-symbol cadr-des)))) 1873 (#.sb!vm:other-pointer-lowtag 1874 (warm-symbol des)))))) 1875 (legal-fun-name-or-type-error result) 1876 result)) 1877 1878(defun cold-fdefinition-object (cold-name &optional leave-fn-raw) 1879 (declare (type (or symbol descriptor) cold-name)) 1880 (declare (special core-file-name)) 1881 (/noshow0 "/cold-fdefinition-object") 1882 (let ((warm-name (warm-fun-name cold-name))) 1883 (or (gethash warm-name *cold-fdefn-objects*) 1884 (let ((fdefn (allocate-header+object (or *cold-fdefn-gspace* 1885 #!+immobile-space *immobile-fixedobj* 1886 #!-immobile-space *dynamic*) 1887 (1- sb!vm:fdefn-size) 1888 sb!vm:fdefn-widetag))) 1889 (setf (gethash warm-name *cold-fdefn-objects*) fdefn) 1890 (write-wordindexed fdefn sb!vm:fdefn-name-slot cold-name) 1891 (unless leave-fn-raw 1892 (write-wordindexed fdefn sb!vm:fdefn-fun-slot *nil-descriptor*) 1893 (write-wordindexed/raw fdefn 1894 sb!vm:fdefn-raw-addr-slot 1895 (or (lookup-assembler-reference 1896 'sb!vm::undefined-tramp core-file-name) 1897 ;; Our preload for the tramps 1898 ;; doesn't happen during host-1, 1899 ;; so substitute a usable value. 1900 0))) 1901 fdefn)))) 1902 1903(defun cold-functionp (descriptor) 1904 (eql (descriptor-lowtag descriptor) sb!vm:fun-pointer-lowtag)) 1905 1906(defun cold-fun-entry-addr (fun) 1907 (aver (= (descriptor-lowtag fun) sb!vm:fun-pointer-lowtag)) 1908 (+ (descriptor-bits fun) 1909 (- sb!vm:fun-pointer-lowtag) 1910 (ash sb!vm:simple-fun-code-offset sb!vm:word-shift))) 1911 1912;;; Handle a DEFUN in cold-load. 1913(defun cold-fset (name defn source-loc &optional inline-expansion) 1914 ;; SOURCE-LOC can be ignored, because functions intrinsically store 1915 ;; their location as part of the code component. 1916 ;; The argument is supplied here only to provide context for 1917 ;; a redefinition warning, which can't happen in cold load. 1918 (declare (ignore source-loc)) 1919 (sb!int:binding* (((cold-name warm-name) 1920 ;; (SETF f) was descriptorized when dumped, symbols were not. 1921 (if (symbolp name) 1922 (values (cold-intern name) name) 1923 (values name (warm-fun-name name)))) 1924 (fdefn (cold-fdefinition-object cold-name t))) 1925 (when (cold-functionp (cold-fdefn-fun fdefn)) 1926 (error "Duplicate DEFUN for ~S" warm-name)) 1927 ;; There can't be any closures or funcallable instances. 1928 (aver (= (logand (descriptor-bits (read-memory defn)) sb!vm:widetag-mask) 1929 sb!vm:simple-fun-header-widetag)) 1930 (push (cold-cons cold-name inline-expansion) *!cold-defuns*) 1931 (write-wordindexed fdefn sb!vm:fdefn-fun-slot defn) 1932 (write-wordindexed fdefn 1933 sb!vm:fdefn-raw-addr-slot 1934 #!+(or sparc arm) defn 1935 #!-(or sparc arm) 1936 (make-random-descriptor 1937 (+ (logandc2 (descriptor-bits defn) 1938 sb!vm:lowtag-mask) 1939 (ash sb!vm:simple-fun-code-offset 1940 sb!vm:word-shift)))) 1941 fdefn)) 1942 1943(defun initialize-static-fns () 1944 (let ((*cold-fdefn-gspace* *static*)) 1945 (dolist (sym sb!vm:*static-funs*) 1946 (let* ((fdefn (cold-fdefinition-object (cold-intern sym))) 1947 (offset (- (+ (- (descriptor-bits fdefn) 1948 sb!vm:other-pointer-lowtag) 1949 (* sb!vm:fdefn-raw-addr-slot sb!vm:n-word-bytes)) 1950 (descriptor-bits *nil-descriptor*))) 1951 (desired (sb!vm:static-fun-offset sym))) 1952 (unless (= offset desired) 1953 ;; FIXME: should be fatal 1954 (error "Offset from FDEFN ~S to ~S is ~W, not ~W." 1955 sym nil offset desired)))))) 1956 1957(defun attach-classoid-cells-to-symbols (hashtable) 1958 (let ((num (sb!c::meta-info-number (sb!c::meta-info :type :classoid-cell))) 1959 (layout (gethash 'sb!kernel::classoid-cell *cold-layouts*))) 1960 (when (plusp (hash-table-count *classoid-cells*)) 1961 (aver layout)) 1962 ;; Iteration order is immaterial. The symbols will get sorted later. 1963 (maphash (lambda (symbol cold-classoid-cell) 1964 ;; Some classoid-cells are dumped before the cold layout 1965 ;; of classoid-cell has been made, so fix those cases now. 1966 ;; Obviously it would be better if, in general, ALLOCATE-STRUCT 1967 ;; knew when something later must backpatch a cold layout 1968 ;; so that it could make a note to itself to do those ASAP 1969 ;; after the cold layout became known. 1970 (when (cold-null (cold-layout-of cold-classoid-cell)) 1971 (patch-instance-layout cold-classoid-cell layout)) 1972 (setf (gethash symbol hashtable) 1973 (packed-info-insert 1974 (gethash symbol hashtable +nil-packed-infos+) 1975 sb!c::+no-auxilliary-key+ num cold-classoid-cell))) 1976 *classoid-cells*)) 1977 hashtable) 1978 1979;; Create pointer from SYMBOL and/or (SETF SYMBOL) to respective fdefinition 1980;; 1981(defun attach-fdefinitions-to-symbols (hashtable) 1982 ;; Collect fdefinitions that go with one symbol, e.g. CAR and (SETF CAR), 1983 ;; using the host's code for manipulating a packed info-vector. 1984 (maphash (lambda (warm-name cold-fdefn) 1985 (with-globaldb-name (key1 key2) warm-name 1986 :hairy (error "Hairy fdefn name in genesis: ~S" warm-name) 1987 :simple 1988 (setf (gethash key1 hashtable) 1989 (packed-info-insert 1990 (gethash key1 hashtable +nil-packed-infos+) 1991 key2 +fdefn-info-num+ cold-fdefn)))) 1992 *cold-fdefn-objects*) 1993 hashtable) 1994 1995(defun dump-symbol-info-vectors (hashtable) 1996 ;; Emit in the same order symbols reside in core to avoid 1997 ;; sensitivity to the iteration order of host's maphash. 1998 (loop for (warm-sym . info) 1999 in (sort (%hash-table-alist hashtable) #'< 2000 :key (lambda (x) (descriptor-bits (cold-intern (car x))))) 2001 do (write-wordindexed 2002 (cold-intern warm-sym) sb!vm:symbol-info-slot 2003 ;; Each vector will have one fixnum, possibly the symbol SETF, 2004 ;; and one or two #<fdefn> objects in it, and/or a classoid-cell. 2005 (vector-in-core 2006 (map 'list (lambda (elt) 2007 (etypecase elt 2008 (symbol (cold-intern elt)) 2009 (fixnum (make-fixnum-descriptor elt)) 2010 (descriptor elt))) 2011 info))))) 2012 2013 2014;;;; fixups and related stuff 2015 2016;;; an EQUAL hash table 2017(defvar *cold-foreign-symbol-table*) 2018(declaim (type hash-table *cold-foreign-symbol-table*)) 2019 2020;; Read the sbcl.nm file to find the addresses for foreign-symbols in 2021;; the C runtime. 2022(defun load-cold-foreign-symbol-table (filename) 2023 (/show "load-cold-foreign-symbol-table" filename) 2024 (with-open-file (file filename) 2025 (loop for line = (read-line file nil nil) 2026 while line do 2027 ;; UNIX symbol tables might have tabs in them, and tabs are 2028 ;; not in Common Lisp STANDARD-CHAR, so there seems to be no 2029 ;; nice portable way to deal with them within Lisp, alas. 2030 ;; Fortunately, it's easy to use UNIX command line tools like 2031 ;; sed to remove the problem, so it's not too painful for us 2032 ;; to push responsibility for converting tabs to spaces out to 2033 ;; the caller. 2034 ;; 2035 ;; Other non-STANDARD-CHARs are problematic for the same reason. 2036 ;; Make sure that there aren't any.. 2037 (let ((ch (find-if (lambda (char) 2038 (not (typep char 'standard-char))) 2039 line))) 2040 (when ch 2041 (error "non-STANDARD-CHAR ~S found in foreign symbol table:~%~S" 2042 ch 2043 line))) 2044 (setf line (string-trim '(#\space) line)) 2045 (let ((p1 (position #\space line :from-end nil)) 2046 (p2 (position #\space line :from-end t))) 2047 (if (not (and p1 p2 (< p1 p2))) 2048 ;; KLUDGE: It's too messy to try to understand all 2049 ;; possible output from nm, so we just punt the lines we 2050 ;; don't recognize. We realize that there's some chance 2051 ;; that might get us in trouble someday, so we warn 2052 ;; about it. 2053 (warn "ignoring unrecognized line ~S in ~A" line filename) 2054 (multiple-value-bind (value name) 2055 (if (string= "0x" line :end2 2) 2056 (values (parse-integer line :start 2 :end p1 :radix 16) 2057 (subseq line (1+ p2))) 2058 (values (parse-integer line :end p1 :radix 16) 2059 (subseq line (1+ p2)))) 2060 ;; KLUDGE CLH 2010-05-31: on darwin, nm gives us 2061 ;; _function but dlsym expects us to look up 2062 ;; function, without the leading _ . Therefore, we 2063 ;; strip it off here. 2064 #!+darwin 2065 (when (equal (char name 0) #\_) 2066 (setf name (subseq name 1))) 2067 (multiple-value-bind (old-value found) 2068 (gethash name *cold-foreign-symbol-table*) 2069 (when (and found 2070 (not (= old-value value))) 2071 (warn "redefining ~S from #X~X to #X~X" 2072 name old-value value))) 2073 (/show "adding to *cold-foreign-symbol-table*:" name value) 2074 (setf (gethash name *cold-foreign-symbol-table*) value) 2075 #!+win32 2076 (let ((at-position (position #\@ name))) 2077 (when at-position 2078 (let ((name (subseq name 0 at-position))) 2079 (multiple-value-bind (old-value found) 2080 (gethash name *cold-foreign-symbol-table*) 2081 (when (and found 2082 (not (= old-value value))) 2083 (warn "redefining ~S from #X~X to #X~X" 2084 name old-value value))) 2085 (setf (gethash name *cold-foreign-symbol-table*) 2086 value))))))))) 2087 (values)) ;; PROGN 2088 2089(defun cold-foreign-symbol-address (name) 2090 (or (find-foreign-symbol-in-table name *cold-foreign-symbol-table*) 2091 *foreign-symbol-placeholder-value* 2092 (progn 2093 (format *error-output* "~&The foreign symbol table is:~%") 2094 (maphash (lambda (k v) 2095 (format *error-output* "~&~S = #X~8X~%" k v)) 2096 *cold-foreign-symbol-table*) 2097 (error "The foreign symbol ~S is undefined." name)))) 2098 2099(defvar *cold-assembler-routines*) 2100 2101(defvar *cold-assembler-fixups*) 2102(defvar *cold-static-call-fixups*) 2103 2104(defun record-cold-assembler-routine (name address) 2105 (/xhow "in RECORD-COLD-ASSEMBLER-ROUTINE" name address) 2106 (push (cons name address) 2107 *cold-assembler-routines*)) 2108 2109(defun record-cold-assembler-fixup (routine 2110 code-object 2111 offset 2112 &optional 2113 (kind :both)) 2114 (push (list routine code-object offset kind) 2115 *cold-assembler-fixups*)) 2116 2117(defun lookup-assembler-reference (symbol &optional (errorp t)) 2118 (let ((value (cdr (assoc symbol *cold-assembler-routines*)))) 2119 (unless value 2120 (when errorp 2121 (error "Assembler routine ~S not defined." symbol))) 2122 value)) 2123 2124;;; Unlike in the target, FOP-KNOWN-FUN sometimes has to backpatch. 2125(defvar *deferred-known-fun-refs*) 2126 2127;;; The x86 port needs to store code fixups along with code objects if 2128;;; they are to be moved, so fixups for code objects in the dynamic 2129;;; heap need to be noted. 2130#!+x86 2131(defvar *load-time-code-fixups*) 2132 2133#!+x86 2134(defun note-load-time-code-fixup (code-object offset) 2135 ;; If CODE-OBJECT might be moved 2136 (when (= (gspace-identifier (descriptor-intuit-gspace code-object)) 2137 dynamic-core-space-id) 2138 (push offset (gethash (descriptor-bits code-object) 2139 *load-time-code-fixups* 2140 nil))) 2141 (values)) 2142 2143#!+x86 2144(defun output-load-time-code-fixups () 2145 (let ((fixup-infos nil)) 2146 (maphash 2147 (lambda (code-object-address fixup-offsets) 2148 (push (cons code-object-address fixup-offsets) fixup-infos)) 2149 *load-time-code-fixups*) 2150 (setq fixup-infos (sort fixup-infos #'< :key #'car)) 2151 (dolist (fixup-info fixup-infos) 2152 (let ((code-object-address (car fixup-info)) 2153 (fixup-offsets (cdr fixup-info))) 2154 (let ((fixup-vector 2155 (allocate-vector-object 2156 *dynamic* sb!vm:n-word-bits (length fixup-offsets) 2157 sb!vm:simple-array-unsigned-byte-32-widetag))) 2158 (do ((index sb!vm:vector-data-offset (1+ index)) 2159 (fixups fixup-offsets (cdr fixups))) 2160 ((null fixups)) 2161 (write-wordindexed/raw fixup-vector index (car fixups))) 2162 ;; KLUDGE: The fixup vector is stored as the first constant, 2163 ;; not as a separately-named slot. 2164 (write-wordindexed (make-random-descriptor code-object-address) 2165 sb!vm:code-constants-offset 2166 fixup-vector)))))) 2167 2168;;; Given a pointer to a code object and a byte offset relative to the 2169;;; tail of the code object's header, return a byte offset relative to the 2170;;; (beginning of the) code object. 2171;;; 2172(declaim (ftype (function (descriptor sb!vm:word)) calc-offset)) 2173(defun calc-offset (code-object insts-offset-bytes) 2174 (+ (ash (logand (get-header-data code-object) sb!vm:short-header-max-words) 2175 sb!vm:word-shift) 2176 insts-offset-bytes)) 2177 2178(declaim (ftype (function (descriptor sb!vm:word sb!vm:word keyword)) 2179 do-cold-fixup)) 2180(defun do-cold-fixup (code-object after-header value kind) 2181 (let* ((offset-within-code-object (calc-offset code-object after-header)) 2182 (gspace-bytes (descriptor-bytes code-object)) 2183 (gspace-byte-offset (+ (descriptor-byte-offset code-object) 2184 offset-within-code-object)) 2185 (gspace-byte-address (gspace-byte-address 2186 (descriptor-gspace code-object)))) 2187 ;; There's just a ton of code here that gets deleted, 2188 ;; inhibiting the view of the the forest through the trees. 2189 ;; Use of #+sbcl would say "probable bug in read-time conditional" 2190 #+#.(cl:if (cl:member :sbcl cl:*features*) '(and) '(or)) 2191 (declare (sb-ext:muffle-conditions sb-ext:code-deletion-note)) 2192 (ecase +backend-fasl-file-implementation+ 2193 ;; See CMU CL source for other formerly-supported architectures 2194 ;; (and note that you have to rewrite them to use BVREF-X 2195 ;; instead of SAP-REF). 2196 (:alpha 2197 (ecase kind 2198 (:jmp-hint 2199 (assert (zerop (ldb (byte 2 0) value)))) 2200 (:bits-63-48 2201 (let* ((value (if (logbitp 15 value) (+ value (ash 1 16)) value)) 2202 (value (if (logbitp 31 value) (+ value (ash 1 32)) value)) 2203 (value (if (logbitp 47 value) (+ value (ash 1 48)) value))) 2204 (setf (bvref-8 gspace-bytes gspace-byte-offset) 2205 (ldb (byte 8 48) value) 2206 (bvref-8 gspace-bytes (1+ gspace-byte-offset)) 2207 (ldb (byte 8 56) value)))) 2208 (:bits-47-32 2209 (let* ((value (if (logbitp 15 value) (+ value (ash 1 16)) value)) 2210 (value (if (logbitp 31 value) (+ value (ash 1 32)) value))) 2211 (setf (bvref-8 gspace-bytes gspace-byte-offset) 2212 (ldb (byte 8 32) value) 2213 (bvref-8 gspace-bytes (1+ gspace-byte-offset)) 2214 (ldb (byte 8 40) value)))) 2215 (:ldah 2216 (let ((value (if (logbitp 15 value) (+ value (ash 1 16)) value))) 2217 (setf (bvref-8 gspace-bytes gspace-byte-offset) 2218 (ldb (byte 8 16) value) 2219 (bvref-8 gspace-bytes (1+ gspace-byte-offset)) 2220 (ldb (byte 8 24) value)))) 2221 (:lda 2222 (setf (bvref-8 gspace-bytes gspace-byte-offset) 2223 (ldb (byte 8 0) value) 2224 (bvref-8 gspace-bytes (1+ gspace-byte-offset)) 2225 (ldb (byte 8 8) value))) 2226 (:absolute32 2227 (setf (bvref-32 gspace-bytes gspace-byte-offset) value)))) 2228 (:arm 2229 (ecase kind 2230 (:absolute 2231 (setf (bvref-32 gspace-bytes gspace-byte-offset) value)))) 2232 (:arm64 2233 (ecase kind 2234 (:absolute 2235 (setf (bvref-64 gspace-bytes gspace-byte-offset) value)) 2236 (:cond-branch 2237 (setf (ldb (byte 19 5) 2238 (bvref-32 gspace-bytes gspace-byte-offset)) 2239 (ash (- value (+ gspace-byte-address gspace-byte-offset)) 2240 -2))) 2241 (:uncond-branch 2242 (setf (ldb (byte 26 0) 2243 (bvref-32 gspace-bytes gspace-byte-offset)) 2244 (ash (- value (+ gspace-byte-address gspace-byte-offset)) 2245 -2))))) 2246 (:hppa 2247 (ecase kind 2248 (:absolute 2249 (setf (bvref-32 gspace-bytes gspace-byte-offset) value)) 2250 (:load 2251 (setf (bvref-32 gspace-bytes gspace-byte-offset) 2252 (logior (mask-field (byte 18 14) 2253 (bvref-32 gspace-bytes gspace-byte-offset)) 2254 (if (< value 0) 2255 (1+ (ash (ldb (byte 13 0) value) 1)) 2256 (ash (ldb (byte 13 0) value) 1))))) 2257 (:load11u 2258 (setf (bvref-32 gspace-bytes gspace-byte-offset) 2259 (logior (mask-field (byte 18 14) 2260 (bvref-32 gspace-bytes gspace-byte-offset)) 2261 (if (< value 0) 2262 (1+ (ash (ldb (byte 10 0) value) 1)) 2263 (ash (ldb (byte 11 0) value) 1))))) 2264 (:load-short 2265 (let ((low-bits (ldb (byte 11 0) value))) 2266 (assert (<= 0 low-bits (1- (ash 1 4))))) 2267 (setf (bvref-32 gspace-bytes gspace-byte-offset) 2268 (logior (ash (dpb (ldb (byte 4 0) value) 2269 (byte 4 1) 2270 (ldb (byte 1 4) value)) 17) 2271 (logand (bvref-32 gspace-bytes gspace-byte-offset) 2272 #xffe0ffff)))) 2273 (:hi 2274 (setf (bvref-32 gspace-bytes gspace-byte-offset) 2275 (logior (mask-field (byte 11 21) 2276 (bvref-32 gspace-bytes gspace-byte-offset)) 2277 (ash (ldb (byte 5 13) value) 16) 2278 (ash (ldb (byte 2 18) value) 14) 2279 (ash (ldb (byte 2 11) value) 12) 2280 (ash (ldb (byte 11 20) value) 1) 2281 (ldb (byte 1 31) value)))) 2282 (:branch 2283 (let ((bits (ldb (byte 9 2) value))) 2284 (assert (zerop (ldb (byte 2 0) value))) 2285 (setf (bvref-32 gspace-bytes gspace-byte-offset) 2286 (logior (ash bits 3) 2287 (mask-field (byte 1 1) (bvref-32 gspace-bytes gspace-byte-offset)) 2288 (mask-field (byte 3 13) (bvref-32 gspace-bytes gspace-byte-offset)) 2289 (mask-field (byte 11 21) (bvref-32 gspace-bytes gspace-byte-offset)))))))) 2290 (:mips 2291 (ecase kind 2292 (:absolute 2293 (setf (bvref-32 gspace-bytes gspace-byte-offset) value)) 2294 (:jump 2295 (assert (zerop (ash value -28))) 2296 (setf (ldb (byte 26 0) 2297 (bvref-32 gspace-bytes gspace-byte-offset)) 2298 (ash value -2))) 2299 (:lui 2300 (setf (bvref-32 gspace-bytes gspace-byte-offset) 2301 (logior (mask-field (byte 16 16) 2302 (bvref-32 gspace-bytes gspace-byte-offset)) 2303 (ash (1+ (ldb (byte 17 15) value)) -1)))) 2304 (:addi 2305 (setf (bvref-32 gspace-bytes gspace-byte-offset) 2306 (logior (mask-field (byte 16 16) 2307 (bvref-32 gspace-bytes gspace-byte-offset)) 2308 (ldb (byte 16 0) value)))))) 2309 ;; FIXME: PowerPC Fixups are not fully implemented. The bit 2310 ;; here starts to set things up to work properly, but there 2311 ;; needs to be corresponding code in ppc-vm.lisp 2312 (:ppc 2313 (ecase kind 2314 (:absolute 2315 (setf (bvref-32 gspace-bytes gspace-byte-offset) value)) 2316 (:ba 2317 (setf (bvref-32 gspace-bytes gspace-byte-offset) 2318 (dpb (ash value -2) (byte 24 2) 2319 (bvref-32 gspace-bytes gspace-byte-offset)))) 2320 (:ha 2321 (let* ((un-fixed-up (bvref-16 gspace-bytes 2322 (+ gspace-byte-offset 2))) 2323 (fixed-up (+ un-fixed-up value)) 2324 (h (ldb (byte 16 16) fixed-up)) 2325 (l (ldb (byte 16 0) fixed-up))) 2326 (setf (bvref-16 gspace-bytes (+ gspace-byte-offset 2)) 2327 (if (logbitp 15 l) (ldb (byte 16 0) (1+ h)) h)))) 2328 (:l 2329 (let* ((un-fixed-up (bvref-16 gspace-bytes 2330 (+ gspace-byte-offset 2))) 2331 (fixed-up (+ un-fixed-up value))) 2332 (setf (bvref-16 gspace-bytes (+ gspace-byte-offset 2)) 2333 (ldb (byte 16 0) fixed-up)))))) 2334 (:sparc 2335 (ecase kind 2336 (:call 2337 (error "can't deal with call fixups yet")) 2338 (:sethi 2339 (setf (bvref-32 gspace-bytes gspace-byte-offset) 2340 (dpb (ldb (byte 22 10) value) 2341 (byte 22 0) 2342 (bvref-32 gspace-bytes gspace-byte-offset)))) 2343 (:add 2344 (setf (bvref-32 gspace-bytes gspace-byte-offset) 2345 (dpb (ldb (byte 10 0) value) 2346 (byte 10 0) 2347 (bvref-32 gspace-bytes gspace-byte-offset)))) 2348 (:absolute 2349 (setf (bvref-32 gspace-bytes gspace-byte-offset) value)))) 2350 ((:x86 :x86-64) 2351 ;; XXX: Note that un-fixed-up is read via bvref-word, which is 2352 ;; 64 bits wide on x86-64, but the fixed-up value is written 2353 ;; via bvref-32. This would make more sense if we supported 2354 ;; :absolute64 fixups, but apparently the cross-compiler 2355 ;; doesn't dump them. 2356 (let* ((un-fixed-up (bvref-word gspace-bytes 2357 gspace-byte-offset)) 2358 (code-object-start-addr (logandc2 (descriptor-bits code-object) 2359 sb!vm:lowtag-mask))) 2360 (assert (= code-object-start-addr 2361 (+ gspace-byte-address 2362 (descriptor-byte-offset code-object)))) 2363 (ecase kind 2364 (:absolute 2365 (let ((fixed-up (+ value un-fixed-up))) 2366 (setf (bvref-32 gspace-bytes gspace-byte-offset) 2367 fixed-up) 2368 ;; comment from CMU CL sources: 2369 ;; 2370 ;; Note absolute fixups that point within the object. 2371 ;; KLUDGE: There seems to be an implicit assumption in 2372 ;; the old CMU CL code here, that if it doesn't point 2373 ;; before the object, it must point within the object 2374 ;; (not beyond it). It would be good to add an 2375 ;; explanation of why that's true, or an assertion that 2376 ;; it's really true, or both. 2377 ;; 2378 ;; One possible explanation is that all absolute fixups 2379 ;; point either within the code object, within the 2380 ;; runtime, within read-only or static-space, or within 2381 ;; the linkage-table space. In all x86 configurations, 2382 ;; these areas are prior to the start of dynamic space, 2383 ;; where all the code-objects are loaded. 2384 #!+x86 2385 (unless (< fixed-up code-object-start-addr) 2386 (note-load-time-code-fixup code-object 2387 after-header)))) 2388 (:relative ; (used for arguments to X86 relative CALL instruction) 2389 (let ((fixed-up (- (+ value un-fixed-up) 2390 gspace-byte-address 2391 gspace-byte-offset 2392 4))) ; "length of CALL argument" 2393 (setf (bvref-32 gspace-bytes gspace-byte-offset) 2394 fixed-up) 2395 ;; Note relative fixups that point outside the code 2396 ;; object, which is to say all relative fixups, since 2397 ;; relative addressing within a code object never needs 2398 ;; a fixup. 2399 #!+x86 2400 (note-load-time-code-fixup code-object 2401 after-header)))))))) 2402 (values)) 2403 2404(defun resolve-assembler-fixups () 2405 (dolist (fixup *cold-assembler-fixups*) 2406 (let* ((routine (car fixup)) 2407 (value (lookup-assembler-reference routine))) 2408 (when value 2409 (do-cold-fixup (second fixup) (third fixup) value (fourth fixup))))) 2410 ;; Static calls are very similar to assembler routine calls, 2411 ;; so take care of those too. 2412 (dolist (fixup *cold-static-call-fixups*) 2413 (destructuring-bind (name kind code offset) fixup 2414 (do-cold-fixup code offset 2415 (cold-fun-entry-addr 2416 (cold-fdefn-fun (cold-fdefinition-object name))) 2417 kind)))) 2418 2419#!+sb-dynamic-core 2420(progn 2421 (defparameter *dyncore-address* sb!vm::linkage-table-space-start) 2422 (defparameter *dyncore-linkage-keys* nil) 2423 (defparameter *dyncore-table* (make-hash-table :test 'equal)) 2424 2425 (defun dyncore-note-symbol (symbol-name datap) 2426 "Register a symbol and return its address in proto-linkage-table." 2427 (let ((key (cons symbol-name datap))) 2428 (symbol-macrolet ((entry (gethash key *dyncore-table*))) 2429 (or entry 2430 (setf entry 2431 (prog1 *dyncore-address* 2432 (push key *dyncore-linkage-keys*) 2433 (incf *dyncore-address* sb!vm::linkage-table-entry-size)))))))) 2434 2435;;; *COLD-FOREIGN-SYMBOL-TABLE* becomes *!INITIAL-FOREIGN-SYMBOLS* in 2436;;; the core. When the core is loaded, !LOADER-COLD-INIT uses this to 2437;;; create *STATIC-FOREIGN-SYMBOLS*, which the code in 2438;;; target-load.lisp refers to. 2439(defun foreign-symbols-to-core () 2440 (let ((result *nil-descriptor*)) 2441 #!-sb-dynamic-core 2442 (dolist (symbol (sort (%hash-table-alist *cold-foreign-symbol-table*) 2443 #'string< :key #'car)) 2444 (cold-push (cold-cons (base-string-to-core (car symbol)) 2445 (number-to-core (cdr symbol))) 2446 result)) 2447 (cold-set '*!initial-foreign-symbols* result) 2448 #!+sb-dynamic-core 2449 (let ((runtime-linking-list *nil-descriptor*)) 2450 (dolist (symbol *dyncore-linkage-keys*) 2451 (cold-push (cold-cons (base-string-to-core (car symbol)) 2452 (cdr symbol)) 2453 runtime-linking-list)) 2454 (cold-set 'sb!vm::*required-runtime-c-symbols* 2455 runtime-linking-list))) 2456 (let ((result *nil-descriptor*)) 2457 (dolist (rtn (sort (copy-list *cold-assembler-routines*) #'string< :key #'car)) 2458 (cold-push (cold-cons (cold-intern (car rtn)) 2459 (number-to-core (cdr rtn))) 2460 result)) 2461 (cold-set '*!initial-assembler-routines* result))) 2462 2463 2464;;;; general machinery for cold-loading FASL files 2465 2466(defun pop-fop-stack (stack) 2467 (let ((top (svref stack 0))) 2468 (declare (type index top)) 2469 (when (eql 0 top) 2470 (error "FOP stack empty")) 2471 (setf (svref stack 0) (1- top)) 2472 (svref stack top))) 2473 2474;;; Cause a fop to have a special definition for cold load. 2475;;; 2476;;; This is similar to DEFINE-FOP, but unlike DEFINE-FOP, this version 2477;;; looks up the encoding for this name (created by a previous DEFINE-FOP) 2478;;; instead of creating a new encoding. 2479(defmacro define-cold-fop ((name &optional arglist) &rest forms) 2480 (let* ((code (get name 'opcode)) 2481 (argc (aref (car **fop-signatures**) code)) 2482 (fname (symbolicate "COLD-" name))) 2483 (unless code 2484 (error "~S is not a defined FOP." name)) 2485 (when (and (plusp argc) (not (singleton-p arglist))) 2486 (error "~S must take one argument" name)) 2487 `(progn 2488 (defun ,fname (.fasl-input. ,@arglist) 2489 (declare (ignorable .fasl-input.)) 2490 (macrolet ((fasl-input () '(the fasl-input .fasl-input.)) 2491 (fasl-input-stream () '(%fasl-input-stream (fasl-input))) 2492 (pop-stack () 2493 '(pop-fop-stack (%fasl-input-stack (fasl-input))))) 2494 ,@forms)) 2495 ;; We simply overwrite elements of **FOP-FUNS** since the contents 2496 ;; of the host are never propagated directly into the target core. 2497 ,@(loop for i from code to (logior code (if (plusp argc) 3 0)) 2498 collect `(setf (svref **fop-funs** ,i) #',fname))))) 2499 2500;;; Cause a fop to be undefined in cold load. 2501(defmacro not-cold-fop (name) 2502 `(define-cold-fop (,name) 2503 (error "The fop ~S is not supported in cold load." ',name))) 2504 2505;;; COLD-LOAD loads stuff into the core image being built by calling 2506;;; LOAD-AS-FASL with the fop function table rebound to a table of cold 2507;;; loading functions. 2508(defun cold-load (filename) 2509 "Load the file named by FILENAME into the cold load image being built." 2510 (write-line (namestring filename)) 2511 (with-open-file (s filename :element-type '(unsigned-byte 8)) 2512 (load-as-fasl s nil nil))) 2513 2514;;;; miscellaneous cold fops 2515 2516(define-cold-fop (fop-misc-trap) *unbound-marker*) 2517 2518(define-cold-fop (fop-character (c)) 2519 (make-character-descriptor c)) 2520 2521(define-cold-fop (fop-empty-list) nil) 2522(define-cold-fop (fop-truth) t) 2523 2524(define-cold-fop (fop-struct (size)) ; n-words incl. layout, excluding header 2525 (let* ((layout (pop-stack)) 2526 (result (allocate-struct *dynamic* layout size)) 2527 (bitmap (descriptor-fixnum 2528 (read-slot layout *host-layout-of-layout* :bitmap)))) 2529 ;; Raw slots can not possibly work because dump-struct uses 2530 ;; %RAW-INSTANCE-REF/WORD which does not exist in the cross-compiler. 2531 ;; Remove this assertion if that problem is somehow circumvented. 2532 (unless (eql bitmap sb!kernel::+layout-all-tagged+) 2533 (error "Raw slots not working in genesis.")) 2534 (loop for index downfrom (1- size) to sb!vm:instance-data-start 2535 for val = (pop-stack) then (pop-stack) 2536 do (write-wordindexed result 2537 (+ index sb!vm:instance-slots-offset) 2538 (if (logbitp index bitmap) 2539 val 2540 (descriptor-word-sized-integer val)))) 2541 result)) 2542 2543(define-cold-fop (fop-layout) 2544 (let* ((bitmap-des (pop-stack)) 2545 (length-des (pop-stack)) 2546 (depthoid-des (pop-stack)) 2547 (cold-inherits (pop-stack)) 2548 (name (pop-stack)) 2549 (old-layout-descriptor (gethash name *cold-layouts*))) 2550 (declare (type descriptor length-des depthoid-des cold-inherits)) 2551 (declare (type symbol name)) 2552 ;; If a layout of this name has been defined already 2553 (if old-layout-descriptor 2554 ;; Enforce consistency between the previous definition and the 2555 ;; current definition, then return the previous definition. 2556 (flet ((get-slot (keyword) 2557 (read-slot old-layout-descriptor *host-layout-of-layout* keyword))) 2558 (let ((old-length (descriptor-fixnum (get-slot :length))) 2559 (old-depthoid (descriptor-fixnum (get-slot :depthoid))) 2560 (old-bitmap (host-object-from-core (get-slot :bitmap))) 2561 (length (descriptor-fixnum length-des)) 2562 (depthoid (descriptor-fixnum depthoid-des)) 2563 (bitmap (host-object-from-core bitmap-des))) 2564 (unless (= length old-length) 2565 (error "cold loading a reference to class ~S when the compile~%~ 2566 time length was ~S and current length is ~S" 2567 name 2568 length 2569 old-length)) 2570 (unless (cold-vector-elements-eq cold-inherits (get-slot :inherits)) 2571 (error "cold loading a reference to class ~S when the compile~%~ 2572 time inherits were ~S~%~ 2573 and current inherits are ~S" 2574 name 2575 (listify-cold-inherits cold-inherits) 2576 (listify-cold-inherits (get-slot :inherits)))) 2577 (unless (= depthoid old-depthoid) 2578 (error "cold loading a reference to class ~S when the compile~%~ 2579 time inheritance depthoid was ~S and current inheritance~%~ 2580 depthoid is ~S" 2581 name 2582 depthoid 2583 old-depthoid)) 2584 (unless (= bitmap old-bitmap) 2585 (error "cold loading a reference to class ~S when the compile~%~ 2586 time raw-slot-bitmap was ~S and is currently ~S" 2587 name bitmap old-bitmap))) 2588 old-layout-descriptor) 2589 ;; Make a new definition from scratch. 2590 (make-cold-layout name length-des cold-inherits depthoid-des bitmap-des)))) 2591 2592;;;; cold fops for loading symbols 2593 2594;;; Load a symbol SIZE characters long from FASL-INPUT, and 2595;;; intern that symbol in PACKAGE. 2596(defun cold-load-symbol (length+flag package fasl-input) 2597 (let ((string (make-string (ash length+flag -1)))) 2598 (read-string-as-bytes (%fasl-input-stream fasl-input) string) 2599 (push-fop-table (intern string package) fasl-input))) 2600 2601;; I don't feel like hacking up DEFINE-COLD-FOP any more than necessary, 2602;; so this code is handcrafted to accept two operands. 2603(flet ((fop-cold-symbol-in-package-save (fasl-input length+flag pkg-index) 2604 (cold-load-symbol length+flag (ref-fop-table fasl-input pkg-index) 2605 fasl-input))) 2606 (let ((i (get 'fop-symbol-in-package-save 'opcode))) 2607 (fill **fop-funs** #'fop-cold-symbol-in-package-save :start i :end (+ i 4)))) 2608 2609(define-cold-fop (fop-lisp-symbol-save (length+flag)) 2610 (cold-load-symbol length+flag *cl-package* (fasl-input))) 2611 2612(define-cold-fop (fop-keyword-symbol-save (length+flag)) 2613 (cold-load-symbol length+flag *keyword-package* (fasl-input))) 2614 2615(define-cold-fop (fop-uninterned-symbol-save (length+flag)) 2616 (let ((name (make-string (ash length+flag -1)))) 2617 (read-string-as-bytes (fasl-input-stream) name) 2618 (push-fop-table (get-uninterned-symbol name) (fasl-input)))) 2619 2620(define-cold-fop (fop-copy-symbol-save (index)) 2621 (let* ((symbol (ref-fop-table (fasl-input) index)) 2622 (name 2623 (if (symbolp symbol) 2624 (symbol-name symbol) 2625 (base-string-from-core 2626 (read-wordindexed symbol sb!vm:symbol-name-slot))))) 2627 ;; Genesis performs additional coalescing of uninterned symbols 2628 (push-fop-table (get-uninterned-symbol name) (fasl-input)))) 2629 2630;;;; cold fops for loading packages 2631 2632(define-cold-fop (fop-named-package-save (namelen)) 2633 (let ((name (make-string namelen))) 2634 (read-string-as-bytes (fasl-input-stream) name) 2635 (push-fop-table (find-package name) (fasl-input)))) 2636 2637;;;; cold fops for loading lists 2638 2639;;; Make a list of the top LENGTH things on the fop stack. The last 2640;;; cdr of the list is set to LAST. 2641(defmacro cold-stack-list (length last) 2642 `(do* ((index ,length (1- index)) 2643 (result ,last (cold-cons (pop-stack) result))) 2644 ((= index 0) result) 2645 (declare (fixnum index)))) 2646 2647(define-cold-fop (fop-list) 2648 (cold-stack-list (read-byte-arg (fasl-input-stream)) *nil-descriptor*)) 2649(define-cold-fop (fop-list*) 2650 (cold-stack-list (read-byte-arg (fasl-input-stream)) (pop-stack))) 2651(define-cold-fop (fop-list-1) 2652 (cold-stack-list 1 *nil-descriptor*)) 2653(define-cold-fop (fop-list-2) 2654 (cold-stack-list 2 *nil-descriptor*)) 2655(define-cold-fop (fop-list-3) 2656 (cold-stack-list 3 *nil-descriptor*)) 2657(define-cold-fop (fop-list-4) 2658 (cold-stack-list 4 *nil-descriptor*)) 2659(define-cold-fop (fop-list-5) 2660 (cold-stack-list 5 *nil-descriptor*)) 2661(define-cold-fop (fop-list-6) 2662 (cold-stack-list 6 *nil-descriptor*)) 2663(define-cold-fop (fop-list-7) 2664 (cold-stack-list 7 *nil-descriptor*)) 2665(define-cold-fop (fop-list-8) 2666 (cold-stack-list 8 *nil-descriptor*)) 2667(define-cold-fop (fop-list*-1) 2668 (cold-stack-list 1 (pop-stack))) 2669(define-cold-fop (fop-list*-2) 2670 (cold-stack-list 2 (pop-stack))) 2671(define-cold-fop (fop-list*-3) 2672 (cold-stack-list 3 (pop-stack))) 2673(define-cold-fop (fop-list*-4) 2674 (cold-stack-list 4 (pop-stack))) 2675(define-cold-fop (fop-list*-5) 2676 (cold-stack-list 5 (pop-stack))) 2677(define-cold-fop (fop-list*-6) 2678 (cold-stack-list 6 (pop-stack))) 2679(define-cold-fop (fop-list*-7) 2680 (cold-stack-list 7 (pop-stack))) 2681(define-cold-fop (fop-list*-8) 2682 (cold-stack-list 8 (pop-stack))) 2683 2684;;;; cold fops for loading vectors 2685 2686(define-cold-fop (fop-base-string (len)) 2687 (let ((string (make-string len))) 2688 (read-string-as-bytes (fasl-input-stream) string) 2689 (base-string-to-core string))) 2690 2691#!+sb-unicode 2692(define-cold-fop (fop-character-string (len)) 2693 (bug "CHARACTER-STRING[~D] dumped by cross-compiler." len)) 2694 2695(define-cold-fop (fop-vector (size)) 2696 (let* ((result (allocate-vector-object *dynamic* 2697 sb!vm:n-word-bits 2698 size 2699 sb!vm:simple-vector-widetag))) 2700 (do ((index (1- size) (1- index))) 2701 ((minusp index)) 2702 (declare (fixnum index)) 2703 (write-wordindexed result 2704 (+ index sb!vm:vector-data-offset) 2705 (pop-stack))) 2706 result)) 2707 2708(define-cold-fop (fop-spec-vector) 2709 (let* ((len (read-word-arg (fasl-input-stream))) 2710 (type (read-byte-arg (fasl-input-stream))) 2711 (sizebits (aref **saetp-bits-per-length** type)) 2712 (result (progn (aver (< sizebits 255)) 2713 (allocate-vector-object *dynamic* sizebits len type))) 2714 (start (+ (descriptor-byte-offset result) 2715 (ash sb!vm:vector-data-offset sb!vm:word-shift))) 2716 (end (+ start 2717 (ceiling (* len sizebits) 2718 sb!vm:n-byte-bits)))) 2719 (read-bigvec-as-sequence-or-die (descriptor-bytes result) 2720 (fasl-input-stream) 2721 :start start 2722 :end end) 2723 result)) 2724 2725(not-cold-fop fop-array) 2726#+nil 2727;; This code is unexercised. The only use of FOP-ARRAY is from target-dump. 2728;; It would be a shame to delete it though, as it might come in handy. 2729(define-cold-fop (fop-array) 2730 (let* ((rank (read-word-arg (fasl-input-stream))) 2731 (data-vector (pop-stack)) 2732 (result (allocate-object *dynamic* 2733 (+ sb!vm:array-dimensions-offset rank) 2734 sb!vm:other-pointer-lowtag))) 2735 (write-header-word result rank sb!vm:simple-array-widetag) 2736 (write-wordindexed result sb!vm:array-fill-pointer-slot *nil-descriptor*) 2737 (write-wordindexed result sb!vm:array-data-slot data-vector) 2738 (write-wordindexed result sb!vm:array-displacement-slot *nil-descriptor*) 2739 (write-wordindexed result sb!vm:array-displaced-p-slot *nil-descriptor*) 2740 (write-wordindexed result sb!vm:array-displaced-from-slot *nil-descriptor*) 2741 (let ((total-elements 1)) 2742 (dotimes (axis rank) 2743 (let ((dim (pop-stack))) 2744 (unless (is-fixnum-lowtag (descriptor-lowtag dim)) 2745 (error "non-fixnum dimension? (~S)" dim)) 2746 (setf total-elements (* total-elements (descriptor-fixnum dim))) 2747 (write-wordindexed result 2748 (+ sb!vm:array-dimensions-offset axis) 2749 dim))) 2750 (write-wordindexed result 2751 sb!vm:array-elements-slot 2752 (make-fixnum-descriptor total-elements))) 2753 result)) 2754 2755 2756;;;; cold fops for loading numbers 2757 2758(defmacro define-cold-number-fop (fop &optional arglist) 2759 ;; Invoke the ordinary warm version of this fop to cons the number. 2760 `(define-cold-fop (,fop ,arglist) 2761 (number-to-core (,fop (fasl-input) ,@arglist)))) 2762 2763(define-cold-number-fop fop-single-float) 2764(define-cold-number-fop fop-double-float) 2765(define-cold-number-fop fop-word-integer) 2766(define-cold-number-fop fop-byte-integer) 2767(define-cold-number-fop fop-complex-single-float) 2768(define-cold-number-fop fop-complex-double-float) 2769(define-cold-number-fop fop-integer (n-bytes)) 2770 2771(define-cold-fop (fop-ratio) 2772 (let ((den (pop-stack))) 2773 (number-pair-to-core (pop-stack) den sb!vm:ratio-widetag))) 2774 2775(define-cold-fop (fop-complex) 2776 (let ((im (pop-stack))) 2777 (number-pair-to-core (pop-stack) im sb!vm:complex-widetag))) 2778 2779;;;; cold fops for calling (or not calling) 2780 2781(not-cold-fop fop-eval) 2782(not-cold-fop fop-eval-for-effect) 2783 2784(defvar *load-time-value-counter*) 2785 2786(flet ((pop-args (fasl-input) 2787 (let ((args) 2788 (stack (%fasl-input-stack fasl-input))) 2789 (dotimes (i (read-byte-arg (%fasl-input-stream fasl-input)) 2790 (values (pop-fop-stack stack) args)) 2791 (push (pop-fop-stack stack) args)))) 2792 (call (fun-name handler-name args) 2793 (acond ((get fun-name handler-name) (apply it args)) 2794 (t (error "Can't ~S ~S in cold load" handler-name fun-name))))) 2795 2796 (define-cold-fop (fop-funcall) 2797 (multiple-value-bind (fun args) (pop-args (fasl-input)) 2798 (if args 2799 (case fun 2800 (fdefinition 2801 ;; Special form #'F fopcompiles into `(FDEFINITION ,f) 2802 (aver (and (singleton-p args) (symbolp (car args)))) 2803 (target-symbol-function (car args))) 2804 (cons (cold-cons (first args) (second args))) 2805 (symbol-global-value (cold-symbol-value (first args))) 2806 (t (call fun :sb-cold-funcall-handler/for-value args))) 2807 (let ((counter *load-time-value-counter*)) 2808 (push (cold-list (cold-intern :load-time-value) fun 2809 (number-to-core counter)) *!cold-toplevels*) 2810 (setf *load-time-value-counter* (1+ counter)) 2811 (make-descriptor 0 :load-time-value counter))))) 2812 2813 (define-cold-fop (fop-funcall-for-effect) 2814 (multiple-value-bind (fun args) (pop-args (fasl-input)) 2815 (if (not args) 2816 (push fun *!cold-toplevels*) 2817 (case fun 2818 (sb!impl::%defun (apply #'cold-fset args)) 2819 (sb!kernel::%defstruct 2820 (push args *known-structure-classoids*) 2821 (push (apply #'cold-list (cold-intern 'defstruct) args) 2822 *!cold-toplevels*)) 2823 (sb!c::%defconstant 2824 (destructuring-bind (name val . rest) args 2825 (cold-set name (if (symbolp val) (cold-intern val) val)) 2826 (push (cold-cons (cold-intern name) (list-to-core rest)) 2827 *!cold-defconstants*))) 2828 (set 2829 (aver (= (length args) 2)) 2830 (cold-set (first args) 2831 (let ((val (second args))) 2832 (if (symbolp val) (cold-intern val) val)))) 2833 (%svset (apply 'cold-svset args)) 2834 (t (call fun :sb-cold-funcall-handler/for-effect args))))))) 2835 2836(defun finalize-load-time-value-noise () 2837 (cold-set '*!load-time-values* 2838 (allocate-vector-object *dynamic* 2839 sb!vm:n-word-bits 2840 *load-time-value-counter* 2841 sb!vm:simple-vector-widetag))) 2842 2843 2844;;;; cold fops for fixing up circularities 2845 2846(define-cold-fop (fop-rplaca) 2847 (let ((obj (ref-fop-table (fasl-input) (read-word-arg (fasl-input-stream)))) 2848 (idx (read-word-arg (fasl-input-stream)))) 2849 (write-memory (cold-nthcdr idx obj) (pop-stack)))) 2850 2851(define-cold-fop (fop-rplacd) 2852 (let ((obj (ref-fop-table (fasl-input) (read-word-arg (fasl-input-stream)))) 2853 (idx (read-word-arg (fasl-input-stream)))) 2854 (write-wordindexed (cold-nthcdr idx obj) 1 (pop-stack)))) 2855 2856(define-cold-fop (fop-svset) 2857 (let ((obj (ref-fop-table (fasl-input) (read-word-arg (fasl-input-stream)))) 2858 (idx (read-word-arg (fasl-input-stream)))) 2859 (write-wordindexed obj 2860 (+ idx 2861 (ecase (descriptor-lowtag obj) 2862 (#.sb!vm:instance-pointer-lowtag 1) 2863 (#.sb!vm:other-pointer-lowtag 2))) 2864 (pop-stack)))) 2865 2866(define-cold-fop (fop-structset) 2867 (let ((obj (ref-fop-table (fasl-input) (read-word-arg (fasl-input-stream)))) 2868 (idx (read-word-arg (fasl-input-stream)))) 2869 (write-wordindexed obj (+ idx sb!vm:instance-slots-offset) (pop-stack)))) 2870 2871(define-cold-fop (fop-nthcdr) 2872 (cold-nthcdr (read-word-arg (fasl-input-stream)) (pop-stack))) 2873 2874(defun cold-nthcdr (index obj) 2875 (dotimes (i index) 2876 (setq obj (read-wordindexed obj sb!vm:cons-cdr-slot))) 2877 obj) 2878 2879;;;; cold fops for loading code objects and functions 2880 2881(define-cold-fop (fop-note-debug-source) 2882 (let ((debug-source (pop-stack))) 2883 (cold-push debug-source *current-debug-sources*))) 2884 2885(define-cold-fop (fop-fdefn) 2886 (cold-fdefinition-object (pop-stack))) 2887 2888(define-cold-fop (fop-known-fun) 2889 (let* ((name (pop-stack)) 2890 (fun (cold-fdefn-fun (cold-fdefinition-object name)))) 2891 (if (cold-null fun) `(:known-fun . ,name) fun))) 2892 2893#!-(or x86 x86-64) 2894(define-cold-fop (fop-sanctify-for-execution) 2895 (pop-stack)) 2896 2897;;; Setting this variable shows what code looks like before any 2898;;; fixups (or function headers) are applied. 2899#!+sb-show (defvar *show-pre-fixup-code-p* nil) 2900 2901(defun cold-load-code (fasl-input code-size nconst nfuns) 2902 (macrolet ((pop-stack () '(pop-fop-stack (%fasl-input-stack fasl-input)))) 2903 (let* ((raw-header-n-words (+ sb!vm:code-constants-offset nconst)) 2904 ;; Note that the number of constants is rounded up to ensure 2905 ;; that the code vector will be properly aligned. 2906 (header-n-words (round-up raw-header-n-words 2)) 2907 (toplevel-p (pop-stack)) 2908 (debug-info (pop-stack)) 2909 (des (allocate-cold-descriptor 2910 #!-immobile-code *dynamic* 2911 ;; toplevel-p is an indicator of whether the code will 2912 ;; will become garbage. If so, put it in dynamic space, 2913 ;; otherwise immobile space. 2914 #!+immobile-code 2915 (if toplevel-p *dynamic* *immobile-varyobj*) 2916 (+ (ash header-n-words sb!vm:word-shift) code-size) 2917 sb!vm:other-pointer-lowtag))) 2918 (declare (ignorable toplevel-p)) 2919 (write-header-word des header-n-words sb!vm:code-header-widetag) 2920 (write-wordindexed des sb!vm:code-code-size-slot 2921 (make-fixnum-descriptor code-size)) 2922 (write-wordindexed des sb!vm:code-debug-info-slot debug-info) 2923 (do ((index (1- raw-header-n-words) (1- index))) 2924 ((< index sb!vm:code-constants-offset)) 2925 (let ((obj (pop-stack))) 2926 (if (and (consp obj) (eq (car obj) :known-fun)) 2927 (push (list* (cdr obj) des index) *deferred-known-fun-refs*) 2928 (write-wordindexed des index obj)))) 2929 (let* ((start (+ (descriptor-byte-offset des) 2930 (ash header-n-words sb!vm:word-shift))) 2931 (end (+ start code-size))) 2932 (read-bigvec-as-sequence-or-die (descriptor-bytes des) 2933 (%fasl-input-stream fasl-input) 2934 :start start 2935 :end end) 2936 2937 ;; Emulate NEW-SIMPLE-FUN in target-core 2938 (loop for fun-index from (1- nfuns) downto 0 2939 do (let ((offset (read-varint-arg fasl-input))) 2940 (if (> fun-index 0) 2941 (let ((bytes (descriptor-bytes des)) 2942 (index (+ (descriptor-byte-offset des) 2943 (calc-offset des (ash (1- fun-index) 2))))) 2944 (aver (eql (bvref-32 bytes index) 0)) 2945 (setf (bvref-32 bytes index) offset)) 2946 #!-64-bit 2947 (write-wordindexed/raw 2948 des 2949 sb!vm::code-n-entries-slot 2950 (logior (ash offset 16) 2951 (ash nfuns sb!vm:n-fixnum-tag-bits))) 2952 #!+64-bit 2953 (write-wordindexed/raw 2954 des 0 2955 (logior (ash (logior (ash offset 16) nfuns) 32) 2956 (read-bits-wordindexed des 0)))))) 2957 2958 #!+sb-show 2959 (when *show-pre-fixup-code-p* 2960 (format *trace-output* 2961 "~&/raw code from code-fop ~W ~W:~%" 2962 nconst 2963 code-size) 2964 (do ((i start (+ i sb!vm:n-word-bytes))) 2965 ((>= i end)) 2966 (format *trace-output* 2967 "/#X~8,'0x: #X~8,'0x~%" 2968 (+ i (gspace-byte-address (descriptor-gspace des))) 2969 (bvref-32 (descriptor-bytes des) i))))) 2970 des))) 2971 2972(let ((i (get 'fop-code 'opcode))) 2973 (fill **fop-funs** #'cold-load-code :start i :end (+ i 4))) 2974 2975(defun resolve-deferred-known-funs () 2976 (dolist (item *deferred-known-fun-refs*) 2977 (let ((fun (cold-fdefn-fun (cold-fdefinition-object (car item))))) 2978 (aver (not (cold-null fun))) 2979 (let ((place (cdr item))) 2980 (write-wordindexed (car place) (cdr place) fun))))) 2981 2982(define-cold-fop (fop-alter-code (slot)) 2983 (let ((value (pop-stack)) 2984 (code (pop-stack))) 2985 (write-wordindexed code slot value))) 2986 2987(defvar *simple-fun-metadata* (make-hash-table :test 'equalp)) 2988 2989;; Return an expression that can be used to coalesce type-specifiers 2990;; and lambda lists attached to simple-funs. It doesn't have to be 2991;; a "correct" host representation, just something that preserves EQUAL-ness. 2992(defun make-equal-comparable-thing (descriptor) 2993 (labels ((recurse (x) 2994 (cond ((cold-null x) (return-from recurse nil)) 2995 ((is-fixnum-lowtag (descriptor-lowtag x)) 2996 (return-from recurse (descriptor-fixnum x))) 2997 #!+64-bit 2998 ((is-other-immediate-lowtag (descriptor-lowtag x)) 2999 (let ((bits (descriptor-bits x))) 3000 (when (= (logand bits sb!vm:widetag-mask) 3001 sb!vm:single-float-widetag) 3002 (return-from recurse `(:ffloat-bits ,bits)))))) 3003 (ecase (descriptor-lowtag x) 3004 (#.sb!vm:list-pointer-lowtag 3005 (cons (recurse (cold-car x)) (recurse (cold-cdr x)))) 3006 (#.sb!vm:other-pointer-lowtag 3007 (ecase (logand (descriptor-bits (read-memory x)) sb!vm:widetag-mask) 3008 (#.sb!vm:symbol-header-widetag 3009 (if (cold-null (read-wordindexed x sb!vm:symbol-package-slot)) 3010 (get-or-make-uninterned-symbol 3011 (base-string-from-core 3012 (read-wordindexed x sb!vm:symbol-name-slot))) 3013 (warm-symbol x))) 3014 #!-64-bit 3015 (#.sb!vm:single-float-widetag 3016 `(:ffloat-bits 3017 ,(read-bits-wordindexed x sb!vm:single-float-value-slot))) 3018 (#.sb!vm:double-float-widetag 3019 `(:dfloat-bits 3020 ,(read-bits-wordindexed x sb!vm:double-float-value-slot) 3021 #!-64-bit 3022 ,(read-bits-wordindexed 3023 x (1+ sb!vm:double-float-value-slot)))) 3024 (#.sb!vm:bignum-widetag 3025 (bignum-from-core x)) 3026 (#.sb!vm:simple-base-string-widetag 3027 (base-string-from-core x)) 3028 ;; Why do function lambda lists have simple-vectors in them? 3029 ;; Because we expose all &OPTIONAL and &KEY default forms. 3030 ;; I think this is abstraction leakage, except possibly for 3031 ;; advertised constant defaults of NIL and such. 3032 ;; How one expresses a value as a sexpr should otherwise 3033 ;; be of no concern to a user of the code. 3034 (#.sb!vm:simple-vector-widetag 3035 (vector-from-core x #'recurse)))))) 3036 ;; Return a warm symbol whose name is similar to NAME, coaelescing 3037 ;; all occurrences of #:.WHOLE. across all files, e.g. 3038 (get-or-make-uninterned-symbol (name) 3039 (let ((key `(:uninterned-symbol ,name))) 3040 (or (gethash key *simple-fun-metadata*) 3041 (let ((symbol (make-symbol name))) 3042 (setf (gethash key *simple-fun-metadata*) symbol)))))) 3043 (recurse descriptor))) 3044 3045(defun fun-offset (code-object fun-index) 3046 (if (> fun-index 0) 3047 (bvref-32 (descriptor-bytes code-object) 3048 (+ (descriptor-byte-offset code-object) 3049 (calc-offset code-object (ash (1- fun-index) 2)))) 3050 (ldb (byte 16 16) 3051 #!-64-bit (read-bits-wordindexed code-object sb!vm::code-n-entries-slot) 3052 #!+64-bit (ldb (byte 32 32) (read-bits-wordindexed code-object 0))))) 3053 3054(defun compute-fun (code-object fun-index) 3055 (let* ((offset-from-insns-start (fun-offset code-object fun-index)) 3056 (offset-from-code-start (calc-offset code-object offset-from-insns-start))) 3057 (unless (zerop (logand offset-from-code-start sb!vm:lowtag-mask)) 3058 (error "unaligned function entry ~S ~S" code-object fun-index)) 3059 (values (ash offset-from-code-start (- sb!vm:word-shift)) 3060 (make-descriptor 3061 (logior (+ (logandc2 (descriptor-bits code-object) sb!vm:lowtag-mask) 3062 offset-from-code-start) 3063 sb!vm:fun-pointer-lowtag))))) 3064 3065(defun cold-fop-fun-entry (fasl-input fun-index) 3066 (binding* (((info type arglist name code-object) 3067 (macrolet ((pop-stack () 3068 '(pop-fop-stack (%fasl-input-stack fasl-input)))) 3069 (values (pop-stack) (pop-stack) (pop-stack) (pop-stack) (pop-stack)))) 3070 ((word-offset fn) 3071 (compute-fun code-object fun-index))) 3072 (write-memory fn (make-other-immediate-descriptor 3073 word-offset sb!vm:simple-fun-header-widetag)) 3074 #!+(or x86 x86-64) ; store a machine-native pointer to the function entry 3075 ;; note that the bit pattern looks like fixnum due to alignment 3076 (write-wordindexed/raw fn sb!vm:simple-fun-self-slot 3077 (+ (- (descriptor-bits fn) sb!vm:fun-pointer-lowtag) 3078 (ash sb!vm:simple-fun-code-offset sb!vm:word-shift))) 3079 #!-(or x86 x86-64) ; store a pointer back to the function itself in 'self' 3080 (write-wordindexed fn sb!vm:simple-fun-self-slot fn) 3081 (write-wordindexed fn sb!vm:simple-fun-name-slot name) 3082 (flet ((coalesce (sexpr) ; a warm symbol or a cold cons tree 3083 (if (symbolp sexpr) ; will be cold-interned automatically 3084 sexpr 3085 (let ((representation (make-equal-comparable-thing sexpr))) 3086 (or (gethash representation *simple-fun-metadata*) 3087 (setf (gethash representation *simple-fun-metadata*) 3088 sexpr)))))) 3089 (write-wordindexed fn sb!vm:simple-fun-arglist-slot (coalesce arglist)) 3090 (write-wordindexed fn sb!vm:simple-fun-type-slot (coalesce type))) 3091 (write-wordindexed fn sb!vm::simple-fun-info-slot info) 3092 fn)) 3093 3094(let ((i (get 'fop-fun-entry 'opcode))) 3095 (fill **fop-funs** #'cold-fop-fun-entry :start i :end (+ i 4))) 3096 3097#!+sb-thread 3098(define-cold-fop (fop-symbol-tls-fixup) 3099 (let* ((symbol (pop-stack)) 3100 (kind (pop-stack)) 3101 (code-object (pop-stack))) 3102 (do-cold-fixup code-object 3103 (read-word-arg (fasl-input-stream)) 3104 (ensure-symbol-tls-index symbol) kind) 3105 code-object)) 3106 3107(define-cold-fop (fop-foreign-fixup) 3108 (let* ((kind (pop-stack)) 3109 (code-object (pop-stack)) 3110 (len (read-byte-arg (fasl-input-stream))) 3111 (sym (make-string len))) 3112 (read-string-as-bytes (fasl-input-stream) sym) 3113 #!+sb-dynamic-core 3114 (let ((offset (read-word-arg (fasl-input-stream))) 3115 (value (dyncore-note-symbol sym nil))) 3116 (do-cold-fixup code-object offset value kind)) 3117 #!- (and) (format t "Bad non-plt fixup: ~S~S~%" sym code-object) 3118 #!-sb-dynamic-core 3119 (let ((offset (read-word-arg (fasl-input-stream))) 3120 (value (cold-foreign-symbol-address sym))) 3121 (do-cold-fixup code-object offset value kind)) 3122 code-object)) 3123 3124#!+linkage-table 3125(define-cold-fop (fop-foreign-dataref-fixup) 3126 (let* ((kind (pop-stack)) 3127 (code-object (pop-stack)) 3128 (len (read-byte-arg (fasl-input-stream))) 3129 (sym (make-string len))) 3130 #!-sb-dynamic-core (declare (ignore code-object)) 3131 (read-string-as-bytes (fasl-input-stream) sym) 3132 #!+sb-dynamic-core 3133 (let ((offset (read-word-arg (fasl-input-stream))) 3134 (value (dyncore-note-symbol sym t))) 3135 (do-cold-fixup code-object offset value kind) 3136 code-object) 3137 #!-sb-dynamic-core 3138 (progn 3139 (maphash (lambda (k v) 3140 (format *error-output* "~&~S = #X~8X~%" k v)) 3141 *cold-foreign-symbol-table*) 3142 (error "shared foreign symbol in cold load: ~S (~S)" sym kind)))) 3143 3144(define-cold-fop (fop-assembler-code) 3145 (let* ((length (read-word-arg (fasl-input-stream))) 3146 (header-n-words 3147 ;; Note: we round the number of constants up to ensure that 3148 ;; the code vector will be properly aligned. 3149 (round-up sb!vm:code-constants-offset 2)) 3150 (des (allocate-cold-descriptor *read-only* 3151 (+ (ash header-n-words 3152 sb!vm:word-shift) 3153 length) 3154 sb!vm:other-pointer-lowtag))) 3155 (write-header-word des header-n-words sb!vm:code-header-widetag) 3156 (write-wordindexed des 3157 sb!vm:code-code-size-slot 3158 (make-fixnum-descriptor length)) 3159 (write-wordindexed des sb!vm:code-debug-info-slot *nil-descriptor*) 3160 3161 (let* ((start (+ (descriptor-byte-offset des) 3162 (ash header-n-words sb!vm:word-shift))) 3163 (end (+ start length))) 3164 (read-bigvec-as-sequence-or-die (descriptor-bytes des) 3165 (fasl-input-stream) 3166 :start start 3167 :end end)) 3168 des)) 3169 3170(define-cold-fop (fop-assembler-routine) 3171 (let* ((routine (pop-stack)) 3172 (des (pop-stack)) 3173 (offset (calc-offset des (read-word-arg (fasl-input-stream))))) 3174 (record-cold-assembler-routine 3175 routine 3176 (+ (logandc2 (descriptor-bits des) sb!vm:lowtag-mask) offset)) 3177 des)) 3178 3179(define-cold-fop (fop-assembler-fixup) 3180 (let* ((routine (pop-stack)) 3181 (kind (pop-stack)) 3182 (code-object (pop-stack)) 3183 (offset (read-word-arg (fasl-input-stream)))) 3184 (record-cold-assembler-fixup routine code-object offset kind) 3185 code-object)) 3186 3187(define-cold-fop (fop-code-object-fixup) 3188 (let* ((kind (pop-stack)) 3189 (code-object (pop-stack)) 3190 (offset (read-word-arg (fasl-input-stream))) 3191 (value (descriptor-bits code-object))) 3192 (do-cold-fixup code-object offset value kind) 3193 code-object)) 3194 3195#!+immobile-code 3196(define-cold-fop (fop-static-call-fixup) 3197 (let ((name (pop-stack)) 3198 (kind (pop-stack)) 3199 (code-object (pop-stack)) 3200 (offset (read-word-arg (fasl-input-stream)))) 3201 (push (list name kind code-object offset) *cold-static-call-fixups*) 3202 code-object)) 3203 3204 3205;;;; sanity checking space layouts 3206 3207(defun check-spaces () 3208 ;;; Co-opt type machinery to check for intersections... 3209 (let (types) 3210 (flet ((check (start end space) 3211 (unless (< start end) 3212 (error "Bogus space: ~A" space)) 3213 (let ((type (specifier-type `(integer ,start ,end)))) 3214 (dolist (other types) 3215 (unless (eq *empty-type* (type-intersection (cdr other) type)) 3216 (error "Space overlap: ~A with ~A" space (car other)))) 3217 (push (cons space type) types)))) 3218 (check sb!vm:read-only-space-start sb!vm:read-only-space-end :read-only) 3219 (check sb!vm:static-space-start sb!vm:static-space-end :static) 3220 #!+gencgc 3221 (check sb!vm:dynamic-space-start sb!vm:dynamic-space-end :dynamic) 3222 #!+immobile-space 3223 ;; Must be a multiple of 32 because it makes the math a nicer 3224 ;; when computing word and bit index into the 'touched' bitmap. 3225 (assert (zerop (rem sb!vm:immobile-fixedobj-subspace-size 3226 (* 32 sb!vm:immobile-card-bytes)))) 3227 #!-gencgc 3228 (progn 3229 (check sb!vm:dynamic-0-space-start sb!vm:dynamic-0-space-end :dynamic-0) 3230 (check sb!vm:dynamic-1-space-start sb!vm:dynamic-1-space-end :dynamic-1)) 3231 #!+linkage-table 3232 (check sb!vm:linkage-table-space-start sb!vm:linkage-table-space-end :linkage-table)))) 3233 3234;;;; emitting C header file 3235 3236(defun tailwise-equal (string tail) 3237 (and (>= (length string) (length tail)) 3238 (string= string tail :start1 (- (length string) (length tail))))) 3239 3240(defun write-boilerplate () 3241 (format t "/*~%") 3242 (dolist (line 3243 '("This is a machine-generated file. Please do not edit it by hand." 3244 "(As of sbcl-0.8.14, it came from WRITE-CONFIG-H in genesis.lisp.)" 3245 nil 3246 "This file contains low-level information about the" 3247 "internals of a particular version and configuration" 3248 "of SBCL. It is used by the C compiler to create a runtime" 3249 "support environment, an executable program in the host" 3250 "operating system's native format, which can then be used to" 3251 "load and run 'core' files, which are basically programs" 3252 "in SBCL's own format.")) 3253 (format t " *~@[ ~A~]~%" line)) 3254 (format t " */~%")) 3255 3256(defun c-name (string &optional strip) 3257 (delete #\+ 3258 (substitute-if #\_ (lambda (c) (member c '(#\- #\/ #\%))) 3259 (remove-if (lambda (c) (position c strip)) 3260 string)))) 3261 3262(defun c-symbol-name (symbol &optional strip) 3263 (c-name (symbol-name symbol) strip)) 3264 3265(defun write-makefile-features () 3266 ;; propagating *SHEBANG-FEATURES* into the Makefiles 3267 (dolist (shebang-feature-name (sort (mapcar #'c-symbol-name 3268 sb-cold:*shebang-features*) 3269 #'string<)) 3270 (format t "LISP_FEATURE_~A=1~%" shebang-feature-name))) 3271 3272(defun write-config-h () 3273 ;; propagating *SHEBANG-FEATURES* into C-level #define's 3274 (dolist (shebang-feature-name (sort (mapcar #'c-symbol-name 3275 sb-cold:*shebang-features*) 3276 #'string<)) 3277 (format t "#define LISP_FEATURE_~A~%" shebang-feature-name)) 3278 (terpri) 3279 ;; and miscellaneous constants 3280 (format t "#define SBCL_VERSION_STRING ~S~%" 3281 (sb!xc:lisp-implementation-version)) 3282 (format t "#define CORE_MAGIC 0x~X~%" core-magic) 3283 (format t "#ifndef LANGUAGE_ASSEMBLY~2%") 3284 (format t "#define LISPOBJ(x) ((lispobj)x)~2%") 3285 (format t "#else /* LANGUAGE_ASSEMBLY */~2%") 3286 (format t "#define LISPOBJ(thing) thing~2%") 3287 (format t "#endif /* LANGUAGE_ASSEMBLY */~2%") 3288 (terpri)) 3289 3290(defun write-constants-h () 3291 ;; writing entire families of named constants 3292 (let ((constants nil)) 3293 (dolist (package-name '( ;; Even in CMU CL, constants from VM 3294 ;; were automatically propagated 3295 ;; into the runtime. 3296 "SB!VM" 3297 ;; In SBCL, we also propagate various 3298 ;; magic numbers related to file format, 3299 ;; which live here instead of SB!VM. 3300 "SB!FASL")) 3301 (do-external-symbols (symbol (find-package package-name)) 3302 (when (constantp symbol) 3303 (let ((name (symbol-name symbol))) 3304 (labels ( ;; shared machinery 3305 (record (string priority suffix) 3306 (push (list string 3307 priority 3308 (symbol-value symbol) 3309 suffix 3310 (documentation symbol 'variable)) 3311 constants)) 3312 ;; machinery for old-style CMU CL Lisp-to-C 3313 ;; arbitrary renaming, being phased out in favor of 3314 ;; the newer systematic RECORD-WITH-TRANSLATED-NAME 3315 ;; renaming 3316 (record-with-munged-name (prefix string priority) 3317 (record (concatenate 3318 'simple-string 3319 prefix 3320 (delete #\- (string-capitalize string))) 3321 priority 3322 "")) 3323 (maybe-record-with-munged-name (tail prefix priority) 3324 (when (tailwise-equal name tail) 3325 (record-with-munged-name prefix 3326 (subseq name 0 3327 (- (length name) 3328 (length tail))) 3329 priority))) 3330 ;; machinery for new-style SBCL Lisp-to-C naming 3331 (record-with-translated-name (priority large) 3332 (record (c-name name) priority 3333 (if large 3334 #!+(and win32 x86-64) "LLU" 3335 #!-(and win32 x86-64) "LU" 3336 ""))) 3337 (maybe-record-with-translated-name (suffixes priority &key large) 3338 (when (some (lambda (suffix) 3339 (tailwise-equal name suffix)) 3340 suffixes) 3341 (record-with-translated-name priority large)))) 3342 (maybe-record-with-translated-name '("-LOWTAG") 0) 3343 (maybe-record-with-translated-name '("-WIDETAG" "-SHIFT") 1) 3344 (maybe-record-with-munged-name "-FLAG" "flag_" 2) 3345 (maybe-record-with-munged-name "-TRAP" "trap_" 3) 3346 (maybe-record-with-munged-name "-SUBTYPE" "subtype_" 4) 3347 (maybe-record-with-munged-name "-SC-NUMBER" "sc_" 5) 3348 (maybe-record-with-translated-name '("-SIZE" "-INTERRUPTS") 6) 3349 (maybe-record-with-translated-name '("-START" "-END" "-PAGE-BYTES" 3350 "-CARD-BYTES" "-GRANULARITY") 3351 7 :large t) 3352 (maybe-record-with-translated-name '("-CORE-ENTRY-TYPE-CODE") 8) 3353 (maybe-record-with-translated-name '("-CORE-SPACE-ID") 9) 3354 (maybe-record-with-translated-name '("-CORE-SPACE-ID-FLAG") 9) 3355 (maybe-record-with-translated-name '("-GENERATION+") 10)))))) 3356 ;; KLUDGE: these constants are sort of important, but there's no 3357 ;; pleasing way to inform the code above about them. So we fake 3358 ;; it for now. nikodemus on #lisp (2004-08-09) suggested simply 3359 ;; exporting every numeric constant from SB!VM; that would work, 3360 ;; but the C runtime would have to be altered to use Lisp-like names 3361 ;; rather than the munged names currently exported. --njf, 2004-08-09 3362 (dolist (c '(sb!vm:n-word-bits sb!vm:n-word-bytes 3363 sb!vm:n-lowtag-bits sb!vm:lowtag-mask 3364 sb!vm:n-widetag-bits sb!vm:widetag-mask 3365 sb!vm:n-fixnum-tag-bits sb!vm:fixnum-tag-mask 3366 sb!vm:short-header-max-words)) 3367 (push (list (c-symbol-name c) 3368 -1 ; invent a new priority 3369 (symbol-value c) 3370 "" 3371 nil) 3372 constants)) 3373 ;; One more symbol that doesn't fit into the code above. 3374 (let ((c 'sb!impl::+magic-hash-vector-value+)) 3375 (push (list (c-symbol-name c) 3376 9 3377 (symbol-value c) 3378 #!+(and win32 x86-64) "LLU" 3379 #!-(and win32 x86-64) "LU" 3380 nil) 3381 constants)) 3382 (setf constants 3383 (sort constants 3384 (lambda (const1 const2) 3385 (if (= (second const1) (second const2)) 3386 (if (= (third const1) (third const2)) 3387 (string< (first const1) (first const2)) 3388 (< (third const1) (third const2))) 3389 (< (second const1) (second const2)))))) 3390 (let ((prev-priority (second (car constants)))) 3391 (dolist (const constants) 3392 (destructuring-bind (name priority value suffix doc) const 3393 (unless (= prev-priority priority) 3394 (terpri) 3395 (setf prev-priority priority)) 3396 (when (minusp value) 3397 (error "stub: negative values unsupported")) 3398 (format t "#define ~A ~A~A /* 0x~X ~@[ -- ~A ~]*/~%" name value suffix value doc)))) 3399 (terpri)) 3400 3401 ;; writing information about internal errors 3402 ;; Assembly code needs only the constants for UNDEFINED_[ALIEN_]FUN_ERROR 3403 ;; but to avoid imparting that knowledge here, we'll expose all error 3404 ;; number constants except for OBJECT-NOT-<x>-ERROR ones. 3405 (loop for (description name) across sb!c:+backend-internal-errors+ 3406 for i from 0 3407 when (stringp description) 3408 do (format t "#define ~A ~D~%" (c-symbol-name name) i)) 3409 ;; C code needs strings for describe_internal_error() 3410 (format t "#define INTERNAL_ERROR_NAMES ~{\\~%~S~^, ~}~2%" 3411 (map 'list 'sb!kernel::!c-stringify-internal-error 3412 sb!c:+backend-internal-errors+)) 3413 (format t "#define INTERNAL_ERROR_NARGS {~{~S~^, ~}}~2%" 3414 (map 'list #'cddr sb!c:+backend-internal-errors+)) 3415 3416 ;; I'm not really sure why this is in SB!C, since it seems 3417 ;; conceptually like something that belongs to SB!VM. In any case, 3418 ;; it's needed C-side. 3419 (format t "#define BACKEND_PAGE_BYTES ~DLU~%" sb!c:*backend-page-bytes*) 3420 3421 (terpri) 3422 3423 ;; FIXME: The SPARC has a PSEUDO-ATOMIC-TRAP that differs between 3424 ;; platforms. If we export this from the SB!VM package, it gets 3425 ;; written out as #define trap_PseudoAtomic, which is confusing as 3426 ;; the runtime treats trap_ as the prefix for illegal instruction 3427 ;; type things. We therefore don't export it, but instead do 3428 #!+sparc 3429 (when (boundp 'sb!vm::pseudo-atomic-trap) 3430 (format t 3431 "#define PSEUDO_ATOMIC_TRAP ~D /* 0x~:*~X */~%" 3432 sb!vm::pseudo-atomic-trap) 3433 (terpri)) 3434 ;; possibly this is another candidate for a rename (to 3435 ;; pseudo-atomic-trap-number or pseudo-atomic-magic-constant 3436 ;; [possibly applicable to other platforms]) 3437 3438 #!+sb-safepoint 3439 (format t "#define GC_SAFEPOINT_PAGE_ADDR ((void*)0x~XUL) /* ~:*~A */~%" 3440 sb!vm:gc-safepoint-page-addr) 3441 3442 (dolist (symbol '(sb!vm::float-traps-byte 3443 sb!vm::float-exceptions-byte 3444 sb!vm::float-sticky-bits 3445 sb!vm::float-rounding-mode)) 3446 (format t "#define ~A_POSITION ~A /* ~:*0x~X */~%" 3447 (c-symbol-name symbol) 3448 (sb!xc:byte-position (symbol-value symbol))) 3449 (format t "#define ~A_MASK 0x~X /* ~:*~A */~%" 3450 (c-symbol-name symbol) 3451 (sb!xc:mask-field (symbol-value symbol) -1)))) 3452 3453#!+sb-ldb 3454(defun write-tagnames-h (&optional (out *standard-output*)) 3455 (labels 3456 ((pretty-name (symbol strip) 3457 (let ((name (string-downcase symbol))) 3458 (substitute #\Space #\- 3459 (subseq name 0 (- (length name) (length strip)))))) 3460 (list-sorted-tags (tail) 3461 (loop for symbol being the external-symbols of "SB!VM" 3462 when (and (constantp symbol) 3463 (tailwise-equal (string symbol) tail)) 3464 collect symbol into tags 3465 finally (return (sort tags #'< :key #'symbol-value)))) 3466 (write-tags (kind limit ash-count) 3467 (format out "~%static const char *~(~A~)_names[] = {~%" 3468 (subseq kind 1)) 3469 (let ((tags (list-sorted-tags kind))) 3470 (dotimes (i limit) 3471 (if (eql i (ash (or (symbol-value (first tags)) -1) ash-count)) 3472 (format out " \"~A\"" (pretty-name (pop tags) kind)) 3473 (format out " \"unknown [~D]\"" i)) 3474 (unless (eql i (1- limit)) 3475 (write-string "," out)) 3476 (terpri out))) 3477 (write-line "};" out))) 3478 (write-tags "-LOWTAG" sb!vm:lowtag-limit 0) 3479 ;; this -2 shift depends on every OTHER-IMMEDIATE-?-LOWTAG 3480 ;; ending with the same 2 bits. (#b10) 3481 (write-tags "-WIDETAG" (ash (1+ sb!vm:widetag-mask) -2) -2)) 3482 ;; Inform print_otherptr() of all array types that it's too dumb to print 3483 (let ((array-type-bits (make-array 32 :initial-element 0))) 3484 (flet ((toggle (b) 3485 (multiple-value-bind (ofs bit) (floor b 8) 3486 (setf (aref array-type-bits ofs) (ash 1 bit))))) 3487 (dovector (saetp sb!vm:*specialized-array-element-type-properties*) 3488 (unless (or (typep (sb!vm:saetp-ctype saetp) 'character-set-type) 3489 (eq (sb!vm:saetp-specifier saetp) t)) 3490 (toggle (sb!vm:saetp-typecode saetp)) 3491 (awhen (sb!vm:saetp-complex-typecode saetp) (toggle it))))) 3492 (format out 3493 "~%static unsigned char unprintable_array_types[32] =~% {~{~d~^,~}};~%" 3494 (coerce array-type-bits 'list))) 3495 (values)) 3496 3497(defun write-primitive-object (obj) 3498 ;; writing primitive object layouts 3499 (format t "#ifndef LANGUAGE_ASSEMBLY~2%") 3500 (format t 3501 "struct ~A {~%" 3502 (c-name (string-downcase (string (sb!vm:primitive-object-name obj))))) 3503 (when (sb!vm:primitive-object-widetag obj) 3504 (format t " lispobj header;~%")) 3505 (dolist (slot (sb!vm:primitive-object-slots obj)) 3506 (format t " ~A ~A~@[[1]~];~%" 3507 (getf (sb!vm:slot-options slot) :c-type "lispobj") 3508 (c-name (string-downcase (string (sb!vm:slot-name slot)))) 3509 (sb!vm:slot-rest-p slot))) 3510 (format t "};~2%") 3511 (format t "#else /* LANGUAGE_ASSEMBLY */~2%") 3512 (format t "/* These offsets are SLOT-OFFSET * N-WORD-BYTES - LOWTAG~%") 3513 (format t " * so they work directly on tagged addresses. */~2%") 3514 (let ((name (sb!vm:primitive-object-name obj)) 3515 (lowtag (or (symbol-value (sb!vm:primitive-object-lowtag obj)) 3516 0))) 3517 (dolist (slot (sb!vm:primitive-object-slots obj)) 3518 (format t "#define ~A_~A_OFFSET ~D~%" 3519 (c-symbol-name name) 3520 (c-symbol-name (sb!vm:slot-name slot)) 3521 (- (* (sb!vm:slot-offset slot) sb!vm:n-word-bytes) lowtag))) 3522 (terpri)) 3523 (format t "#endif /* LANGUAGE_ASSEMBLY */~2%")) 3524 3525(defun write-structure-object (dd) 3526 (flet ((cstring (designator) 3527 (c-name (string-downcase (string designator))))) 3528 (format t "#ifndef LANGUAGE_ASSEMBLY~2%") 3529 (format t "struct ~A {~%" (cstring (dd-name dd))) 3530 (format t " lispobj header; // = word_0_~%") 3531 ;; "self layout" slots are named '_layout' instead of 'layout' so that 3532 ;; classoid's expressly declared layout isn't renamed as a special-case. 3533 #!-compact-instance-header (format t " lispobj _layout;~%") 3534 ;; Output exactly the number of Lisp words consumed by the structure, 3535 ;; no more, no less. C code can always compute the padded length from 3536 ;; the precise length, but the other way doesn't work. 3537 (let ((names 3538 (coerce (loop for i from sb!vm:instance-data-start below (dd-length dd) 3539 collect (list (format nil "word_~D_" (1+ i)))) 3540 'vector))) 3541 (dolist (slot (dd-slots dd)) 3542 (let ((cell (aref names (- (dsd-index slot) sb!vm:instance-data-start))) 3543 (name (cstring (dsd-name slot)))) 3544 (if (eq (dsd-raw-type slot) t) 3545 (rplaca cell name) 3546 (rplacd cell name)))) 3547 (loop for slot across names 3548 do (format t " lispobj ~A;~@[ // ~A~]~%" (car slot) (cdr slot)))) 3549 (format t "};~2%") 3550 (format t "#endif /* LANGUAGE_ASSEMBLY */~2%"))) 3551 3552(defun write-static-symbols () 3553 (dolist (symbol (cons nil sb!vm:*static-symbols*)) 3554 ;; FIXME: It would be nice to use longer names than NIL and 3555 ;; (particularly) T in #define statements. 3556 (format t "#define ~A LISPOBJ(0x~X)~%" 3557 ;; FIXME: It would be nice not to need to strip anything 3558 ;; that doesn't get stripped always by C-SYMBOL-NAME. 3559 (c-symbol-name symbol "%*.!") 3560 (if *static* ; if we ran GENESIS 3561 ;; We actually ran GENESIS, use the real value. 3562 (descriptor-bits (cold-intern symbol)) 3563 ;; We didn't run GENESIS, so guess at the address. 3564 (+ sb!vm:static-space-start 3565 sb!vm:n-word-bytes 3566 sb!vm:other-pointer-lowtag 3567 (if symbol (sb!vm:static-symbol-offset symbol) 0)))))) 3568 3569(defun write-sc-offset-coding () 3570 (flet ((write-array (name bytes) 3571 (format t "static struct sc_offset_byte ~A[] = {~@ 3572 ~{ {~{ ~2D, ~2D ~}}~^,~%~}~@ 3573 };~2%" 3574 name 3575 (mapcar (lambda (byte) 3576 (list (byte-size byte) (byte-position byte))) 3577 bytes)))) 3578 (format t "struct sc_offset_byte { 3579 int size; 3580 int position; 3581};~2%") 3582 (write-array "sc_offset_sc_number_bytes" sb!c::+sc-offset-scn-bytes+) 3583 (write-array "sc_offset_offset_bytes" sb!c::+sc-offset-offset-bytes+))) 3584 3585;;;; writing map file 3586 3587;;; Write a map file describing the cold load. Some of this 3588;;; information is subject to change due to relocating GC, but even so 3589;;; it can be very handy when attempting to troubleshoot the early 3590;;; stages of cold load. 3591(defun write-map () 3592 (let ((*print-pretty* nil) 3593 (*print-case* :upcase)) 3594 (format t "assembler routines defined in core image:~2%") 3595 (dolist (routine (sort (copy-list *cold-assembler-routines*) #'< 3596 :key #'cdr)) 3597 (format t "~8,'0X: ~S~%" (cdr routine) (car routine))) 3598 (let ((fdefns nil) 3599 (funs nil) 3600 (undefs nil)) 3601 (maphash (lambda (name fdefn &aux (fun (cold-fdefn-fun fdefn))) 3602 (push (list (- (descriptor-bits fdefn) (descriptor-lowtag fdefn)) 3603 name) fdefns) 3604 (if (cold-null fun) 3605 (push name undefs) 3606 (push (list (- (descriptor-bits fun) (descriptor-lowtag fun)) 3607 name) funs))) 3608 *cold-fdefn-objects*) 3609 (format t "~%~|~%fdefns (native pointer): 3610~:{~%~8,'0X: ~S~}~%" (sort fdefns #'< :key #'car)) 3611 (format t "~%~|~%initially defined functions (native pointer): 3612~:{~%~8,'0X: ~S~}~%" (sort funs #'< :key #'car)) 3613 (format t 3614"~%~| 3615(a note about initially undefined function references: These functions 3616are referred to by code which is installed by GENESIS, but they are not 3617installed by GENESIS. This is not necessarily a problem; functions can 3618be defined later, by cold init toplevel forms, or in files compiled and 3619loaded at warm init, or elsewhere. As long as they are defined before 3620they are called, everything should be OK. Things are also OK if the 3621cross-compiler knew their inline definition and used that everywhere 3622that they were called before the out-of-line definition is installed, 3623as is fairly common for structure accessors.) 3624initially undefined function references:~2%") 3625 3626 (setf undefs (sort undefs #'string< :key #'fun-name-block-name)) 3627 (dolist (name undefs) 3628 (format t "~8,'0X: ~S~%" 3629 (descriptor-bits (gethash name *cold-fdefn-objects*)) 3630 name))) 3631 3632 (format t "~%~|~%layout names:~2%") 3633 (dolist (x (sort-cold-layouts)) 3634 (let* ((des (cdr x)) 3635 (inherits (read-slot des *host-layout-of-layout* :inherits))) 3636 (format t "~8,'0X: ~S[~D]~%~10T~:S~%" (descriptor-bits des) (car x) 3637 (cold-layout-length des) (listify-cold-inherits inherits)))) 3638 3639 (format t "~%~|~%parsed type specifiers:~2%") 3640 (mapc (lambda (cell) 3641 (format t "~X: ~S~%" (descriptor-bits (cdr cell)) (car cell))) 3642 (sort (%hash-table-alist *ctype-cache*) #'< 3643 :key (lambda (x) (descriptor-bits (cdr x)))))) 3644 (values)) 3645 3646;;;; writing core file 3647 3648(defvar *core-file*) 3649(defvar *data-page*) 3650 3651;;; magic numbers to identify entries in a core file 3652;;; 3653;;; (In case you were wondering: No, AFAIK there's no special magic about 3654;;; these which requires them to be in the 38xx range. They're just 3655;;; arbitrary words, tested not for being in a particular range but just 3656;;; for equality. However, if you ever need to look at a _core file and 3657;;; figure out what's going on, it's slightly convenient that they're 3658;;; all in an easily recognizable range, and displacing the range away from 3659;;; zero seems likely to reduce the chance that random garbage will be 3660;;; misinterpreted as a _core file.) 3661(defconstant build-id-core-entry-type-code 3860) 3662(defconstant new-directory-core-entry-type-code 3861) 3663(defconstant initial-fun-core-entry-type-code 3863) 3664(defconstant page-table-core-entry-type-code 3880) 3665(defconstant end-core-entry-type-code 3840) 3666 3667(declaim (ftype (function (sb!vm:word) sb!vm:word) write-word)) 3668(defun write-word (num) 3669 (ecase sb!c:*backend-byte-order* 3670 (:little-endian 3671 (dotimes (i sb!vm:n-word-bytes) 3672 (write-byte (ldb (byte 8 (* i 8)) num) *core-file*))) 3673 (:big-endian 3674 (dotimes (i sb!vm:n-word-bytes) 3675 (write-byte (ldb (byte 8 (* (- (1- sb!vm:n-word-bytes) i) 8)) num) 3676 *core-file*)))) 3677 num) 3678 3679(defun advance-to-page () 3680 (force-output *core-file*) 3681 (file-position *core-file* 3682 (round-up (file-position *core-file*) 3683 sb!c:*backend-page-bytes*))) 3684 3685(defun output-gspace (gspace) 3686 (force-output *core-file*) 3687 (let* ((posn (file-position *core-file*)) 3688 (bytes (* (gspace-free-word-index gspace) sb!vm:n-word-bytes)) 3689 (pages (ceiling bytes sb!c:*backend-page-bytes*)) 3690 (total-bytes (* pages sb!c:*backend-page-bytes*))) 3691 3692 (file-position *core-file* 3693 (* sb!c:*backend-page-bytes* (1+ *data-page*))) 3694 (format t 3695 "writing ~S byte~:P [~S page~:P] from ~S~%" 3696 total-bytes 3697 pages 3698 gspace) 3699 (force-output) 3700 3701 ;; Note: It is assumed that the GSPACE allocation routines always 3702 ;; allocate whole pages (of size *target-page-size*) and that any 3703 ;; empty gspace between the free pointer and the end of page will 3704 ;; be zero-filled. This will always be true under Mach on machines 3705 ;; where the page size is equal. (RT is 4K, PMAX is 4K, Sun 3 is 3706 ;; 8K). 3707 (write-bigvec-as-sequence (gspace-bytes gspace) 3708 *core-file* 3709 :end total-bytes 3710 :pad-with-zeros t) 3711 (force-output *core-file*) 3712 (file-position *core-file* posn) 3713 3714 ;; Write part of a (new) directory entry which looks like this: 3715 ;; GSPACE IDENTIFIER 3716 ;; WORD COUNT 3717 ;; DATA PAGE 3718 ;; ADDRESS 3719 ;; PAGE COUNT 3720 (write-word (gspace-identifier gspace)) 3721 (write-word (gspace-free-word-index gspace)) 3722 (write-word *data-page*) 3723 (multiple-value-bind (floor rem) 3724 (floor (gspace-byte-address gspace) sb!c:*backend-page-bytes*) 3725 (aver (zerop rem)) 3726 (write-word floor)) 3727 (write-word pages) 3728 3729 (incf *data-page* pages))) 3730 3731;;; Create a core file created from the cold loaded image. (This is 3732;;; the "initial core file" because core files could be created later 3733;;; by executing SAVE-LISP in a running system, perhaps after we've 3734;;; added some functionality to the system.) 3735(declaim (ftype (function (string)) write-initial-core-file)) 3736(defun write-initial-core-file (filename) 3737 3738 (let ((filenamestring (namestring filename)) 3739 (*data-page* 0)) 3740 3741 (format t 3742 "[building initial core file in ~S: ~%" 3743 filenamestring) 3744 (force-output) 3745 3746 (with-open-file (*core-file* filenamestring 3747 :direction :output 3748 :element-type '(unsigned-byte 8) 3749 :if-exists :rename-and-delete) 3750 3751 ;; Write the magic number. 3752 (write-word core-magic) 3753 3754 ;; Write the build ID. 3755 (write-word build-id-core-entry-type-code) 3756 (let ((build-id (with-open-file (s "output/build-id.tmp") 3757 (read s)))) 3758 (declare (type simple-string build-id)) 3759 (/show build-id (length build-id)) 3760 ;; Write length of build ID record: BUILD-ID-CORE-ENTRY-TYPE-CODE 3761 ;; word, this length word, and one word for each char of BUILD-ID. 3762 (write-word (+ 2 (length build-id))) 3763 (dovector (char build-id) 3764 ;; (We write each character as a word in order to avoid 3765 ;; having to think about word alignment issues in the 3766 ;; sbcl-0.7.8 version of coreparse.c.) 3767 (write-word (sb!xc:char-code char)))) 3768 3769 ;; Write the New Directory entry header. 3770 (write-word new-directory-core-entry-type-code) 3771 (let ((spaces (nconc (list *read-only* *static*) 3772 #!+immobile-space 3773 (list *immobile-fixedobj* *immobile-varyobj*) 3774 (list *dynamic*)))) 3775 ;; length = (5 words/space) * N spaces + 2 for header. 3776 (write-word (+ (* (length spaces) 5) 2)) 3777 (mapc #'output-gspace spaces)) 3778 3779 ;; Write the initial function. 3780 (write-word initial-fun-core-entry-type-code) 3781 (write-word 3) 3782 (let* ((cold-name (cold-intern '!cold-init)) 3783 (initial-fun 3784 (cold-fdefn-fun (cold-fdefinition-object cold-name)))) 3785 (format t 3786 "~&/(DESCRIPTOR-BITS INITIAL-FUN)=#X~X~%" 3787 (descriptor-bits initial-fun)) 3788 (write-word (descriptor-bits initial-fun))) 3789 3790 ;; Write the End entry. 3791 (write-word end-core-entry-type-code) 3792 (write-word 2))) 3793 3794 (format t "done]~%") 3795 (force-output) 3796 (/show "leaving WRITE-INITIAL-CORE-FILE") 3797 (values)) 3798 3799;;;; the actual GENESIS function 3800 3801;;; Read the FASL files in OBJECT-FILE-NAMES and produce a Lisp core, 3802;;; and/or information about a Lisp core, therefrom. 3803;;; 3804;;; input file arguments: 3805;;; SYMBOL-TABLE-FILE-NAME names a UNIX-style .nm file *with* *any* 3806;;; *tab* *characters* *converted* *to* *spaces*. (We push 3807;;; responsibility for removing tabs out to the caller it's 3808;;; trivial to remove them using UNIX command line tools like 3809;;; sed, whereas it's a headache to do it portably in Lisp because 3810;;; #\TAB is not a STANDARD-CHAR.) If this file is not supplied, 3811;;; a core file cannot be built (but a C header file can be). 3812;;; 3813;;; output files arguments (any of which may be NIL to suppress output): 3814;;; CORE-FILE-NAME gets a Lisp core. 3815;;; C-HEADER-FILE-NAME gets a C header file, traditionally called 3816;;; internals.h, which is used by the C compiler when constructing 3817;;; the executable which will load the core. 3818;;; MAP-FILE-NAME gets (?) a map file. (dunno about this -- WHN 19990815) 3819;;; 3820;;; FIXME: GENESIS doesn't belong in SB!VM. Perhaps in %KERNEL for now, 3821;;; perhaps eventually in SB-LD or SB-BOOT. 3822(defun sb!vm:genesis (&key 3823 object-file-names 3824 preload-file 3825 symbol-table-file-name 3826 core-file-name 3827 map-file-name 3828 c-header-dir-name 3829 #+nil (list-objects t)) 3830 #!+sb-dynamic-core 3831 (declare (ignorable symbol-table-file-name)) 3832 (declare (special core-file-name)) 3833 3834 (format t 3835 "~&beginning GENESIS, ~A~%" 3836 (if core-file-name 3837 ;; Note: This output summarizing what we're doing is 3838 ;; somewhat telegraphic in style, not meant to imply that 3839 ;; we're not e.g. also creating a header file when we 3840 ;; create a core. 3841 (format nil "creating core ~S" core-file-name) 3842 (format nil "creating headers in ~S" c-header-dir-name))) 3843 3844 (let ((*cold-foreign-symbol-table* (make-hash-table :test 'equal))) 3845 3846 #!-sb-dynamic-core 3847 (when core-file-name 3848 (if symbol-table-file-name 3849 (load-cold-foreign-symbol-table symbol-table-file-name) 3850 (error "can't output a core file without symbol table file input"))) 3851 3852 ;; Now that we've successfully read our only input file (by 3853 ;; loading the symbol table, if any), it's a good time to ensure 3854 ;; that there'll be someplace for our output files to go when 3855 ;; we're done. 3856 (flet ((frob (filename) 3857 (when filename 3858 (ensure-directories-exist filename :verbose t)))) 3859 (frob core-file-name) 3860 (frob map-file-name)) 3861 3862 ;; (This shouldn't matter in normal use, since GENESIS normally 3863 ;; only runs once in any given Lisp image, but it could reduce 3864 ;; confusion if we ever experiment with running, tweaking, and 3865 ;; rerunning genesis interactively.) 3866 (do-all-symbols (sym) 3867 (remprop sym 'cold-intern-info)) 3868 3869 (check-spaces) 3870 3871 (let* ((*foreign-symbol-placeholder-value* (if core-file-name nil 0)) 3872 (*load-time-value-counter* 0) 3873 (*cold-fdefn-objects* (make-hash-table :test 'equal)) 3874 (*cold-symbols* (make-hash-table :test 'eql)) ; integer keys 3875 (*cold-package-symbols* (make-hash-table :test 'equal)) ; string keys 3876 (pkg-metadata (sb-cold::package-list-for-genesis)) 3877 (*read-only* (make-gspace :read-only 3878 read-only-core-space-id 3879 sb!vm:read-only-space-start)) 3880 (*static* (make-gspace :static 3881 static-core-space-id 3882 sb!vm:static-space-start)) 3883 #!+immobile-space 3884 (*immobile-fixedobj* (make-gspace :immobile-fixedobj 3885 immobile-fixedobj-core-space-id 3886 sb!vm:immobile-space-start)) 3887 #!+immobile-space 3888 (*immobile-varyobj* (make-gspace :immobile-varyobj 3889 immobile-varyobj-core-space-id 3890 (+ sb!vm:immobile-space-start 3891 sb!vm:immobile-fixedobj-subspace-size))) 3892 (*dynamic* (make-gspace :dynamic 3893 dynamic-core-space-id 3894 #!+gencgc sb!vm:dynamic-space-start 3895 #!-gencgc sb!vm:dynamic-0-space-start)) 3896 ;; There's a cyclic dependency here: NIL refers to a package; 3897 ;; a package needs its layout which needs others layouts 3898 ;; which refer to NIL, which refers to a package ... 3899 ;; Break the cycle by preallocating packages without a layout. 3900 ;; This avoids having to track any symbols created prior to 3901 ;; creation of packages, since packages are primordial. 3902 (target-cl-pkg-info 3903 (dolist (name (list* "COMMON-LISP" "COMMON-LISP-USER" "KEYWORD" 3904 (mapcar #'sb-cold:package-data-name 3905 pkg-metadata)) 3906 (gethash "COMMON-LISP" *cold-package-symbols*)) 3907 (setf (gethash name *cold-package-symbols*) 3908 (cons (allocate-struct 3909 (symbol-value *cold-layout-gspace*) 3910 (make-fixnum-descriptor 0) 3911 (layout-length (find-layout 'package))) 3912 (cons nil nil))))) ; (externals . internals) 3913 (*nil-descriptor* (make-nil-descriptor target-cl-pkg-info)) 3914 (*known-structure-classoids* nil) 3915 (*classoid-cells* (make-hash-table :test 'eq)) 3916 (*ctype-cache* (make-hash-table :test 'equal)) 3917 (*!cold-defconstants* nil) 3918 (*!cold-defuns* nil) 3919 (*!cold-toplevels* nil) 3920 (*current-debug-sources* *nil-descriptor*) 3921 (*unbound-marker* (make-other-immediate-descriptor 3922 0 3923 sb!vm:unbound-marker-widetag)) 3924 *cold-static-call-fixups* 3925 *cold-assembler-fixups* 3926 *cold-assembler-routines* 3927 (*deferred-known-fun-refs* nil) 3928 #!+x86 (*load-time-code-fixups* (make-hash-table))) 3929 3930 ;; If we're given a preload file, it contains tramps and whatnot 3931 ;; that must be loaded before we create any FDEFNs. It can in 3932 ;; theory be loaded any time between binding 3933 ;; *COLD-ASSEMBLER-ROUTINES* above and calling 3934 ;; INITIALIZE-STATIC-FNS below. 3935 (when preload-file 3936 (cold-load preload-file)) 3937 3938 ;; Prepare for cold load. 3939 (initialize-non-nil-symbols) 3940 (initialize-layouts) 3941 (initialize-packages 3942 ;; docstrings are set in src/cold/warm. It would work to do it here, 3943 ;; but seems preferable not to saddle Genesis with such responsibility. 3944 (list* (sb-cold:make-package-data :name "COMMON-LISP" :doc nil) 3945 (sb-cold:make-package-data :name "KEYWORD" :doc nil) 3946 (sb-cold:make-package-data :name "COMMON-LISP-USER" :doc nil 3947 :use '("COMMON-LISP" 3948 ;; ANSI encourages us to put extension packages 3949 ;; in the USE list of COMMON-LISP-USER. 3950 "SB!ALIEN" "SB!DEBUG" "SB!EXT" "SB!GRAY" "SB!PROFILE")) 3951 pkg-metadata)) 3952 (initialize-static-fns) 3953 3954 ;; Initialize the *COLD-SYMBOLS* system with the information 3955 ;; from common-lisp-exports.lisp-expr. 3956 ;; Packages whose names match SB!THING were set up on the host according 3957 ;; to "package-data-list.lisp-expr" which expresses the desired target 3958 ;; package configuration, so we can just mirror the host into the target. 3959 ;; But by waiting to observe calls to COLD-INTERN that occur during the 3960 ;; loading of the cross-compiler's outputs, it is possible to rid the 3961 ;; target of accidental leftover symbols, not that it wouldn't also be 3962 ;; a good idea to clean up package-data-list once in a while. 3963 (dolist (exported-name 3964 (sb-cold:read-from-file "common-lisp-exports.lisp-expr")) 3965 (cold-intern (intern exported-name *cl-package*) :access :external)) 3966 3967 ;; Create SB!KERNEL::*TYPE-CLASSES* as an array of NIL 3968 (cold-set (cold-intern 'sb!kernel::*type-classes*) 3969 (vector-in-core (make-list (length sb!kernel::*type-classes*)))) 3970 3971 ;; Cold load. 3972 (dolist (file-name object-file-names) 3973 (cold-load file-name)) 3974 3975 (when *known-structure-classoids* 3976 (let ((dd-layout (find-layout 'defstruct-description))) 3977 (dolist (defstruct-args *known-structure-classoids*) 3978 (let* ((dd (first defstruct-args)) 3979 (name (warm-symbol (read-slot dd dd-layout :name))) 3980 (layout (gethash name *cold-layouts*))) 3981 (aver layout) 3982 (write-slots layout *host-layout-of-layout* :info dd)))) 3983 (format t "~&; SB!Loader: (~D+~D+~D+~D) structs/consts/funs/other~%" 3984 (length *known-structure-classoids*) 3985 (length *!cold-defconstants*) 3986 (length *!cold-defuns*) 3987 (length *!cold-toplevels*))) 3988 3989 (dolist (symbol '(*!cold-defconstants* *!cold-defuns* *!cold-toplevels*)) 3990 (cold-set symbol (list-to-core (nreverse (symbol-value symbol)))) 3991 (makunbound symbol)) ; so no further PUSHes can be done 3992 3993 ;; Tidy up loose ends left by cold loading. ("Postpare from cold load?") 3994 (resolve-deferred-known-funs) 3995 (resolve-assembler-fixups) 3996 #!+x86 (output-load-time-code-fixups) 3997 (foreign-symbols-to-core) 3998 (finish-symbols) 3999 (/show "back from FINISH-SYMBOLS") 4000 (finalize-load-time-value-noise) 4001 4002 ;; Tell the target Lisp how much stuff we've allocated. 4003 ;; ALLOCATE-COLD-DESCRIPTOR is a weird trick to locate a space's end, 4004 ;; and it doesn't work on immobile space. 4005 (cold-set 'sb!vm:*read-only-space-free-pointer* 4006 (allocate-cold-descriptor *read-only* 4007 0 4008 sb!vm:even-fixnum-lowtag)) 4009 (cold-set 'sb!vm:*static-space-free-pointer* 4010 (allocate-cold-descriptor *static* 4011 0 4012 sb!vm:even-fixnum-lowtag)) 4013 #!+immobile-space 4014 (progn 4015 (cold-set 'sb!vm:*immobile-fixedobj-free-pointer* 4016 (make-random-descriptor 4017 (ash (+ (gspace-word-address *immobile-fixedobj*) 4018 (gspace-free-word-index *immobile-fixedobj*)) 4019 sb!vm:word-shift))) 4020 ;; The upper bound of the varyobj subspace is delimited by 4021 ;; a structure with no layout and no slots. 4022 ;; This is necessary because 'coreparse' does not have the actual 4023 ;; value of the free pointer, but the space must not contain any 4024 ;; objects that look like conses (due to the tail of 0 words). 4025 (let ((des (allocate-object *immobile-varyobj* 1 ; 1 word in total 4026 sb!vm:instance-pointer-lowtag nil))) 4027 (write-wordindexed/raw des 0 sb!vm:instance-header-widetag) 4028 (write-wordindexed/raw des sb!vm:instance-slots-offset 0)) 4029 (cold-set 'sb!vm:*immobile-space-free-pointer* 4030 (make-random-descriptor 4031 (ash (+ (gspace-word-address *immobile-varyobj*) 4032 (gspace-free-word-index *immobile-varyobj*)) 4033 sb!vm:word-shift)))) 4034 4035 (/show "done setting free pointers") 4036 4037 ;; Write results to files. 4038 ;; 4039 ;; FIXME: I dislike this approach of redefining 4040 ;; *STANDARD-OUTPUT* instead of putting the new stream in a 4041 ;; lexical variable, and it's annoying to have WRITE-MAP (to 4042 ;; *STANDARD-OUTPUT*) not be parallel to WRITE-INITIAL-CORE-FILE 4043 ;; (to a stream explicitly passed as an argument). 4044 (macrolet ((out-to (name &body body) 4045 `(let ((fn (format nil "~A/~A.h" c-header-dir-name ,name))) 4046 (ensure-directories-exist fn) 4047 (with-open-file (*standard-output* fn 4048 :if-exists :supersede :direction :output) 4049 (write-boilerplate) 4050 (let ((n (c-name (string-upcase ,name)))) 4051 (format 4052 t 4053 "#ifndef SBCL_GENESIS_~A~%#define SBCL_GENESIS_~A 1~%" 4054 n n)) 4055 ,@body 4056 (format t 4057 "#endif /* SBCL_GENESIS_~A */~%" 4058 (string-upcase ,name)))))) 4059 (when map-file-name 4060 (with-open-file (*standard-output* map-file-name 4061 :direction :output 4062 :if-exists :supersede) 4063 (write-map))) 4064 (out-to "config" (write-config-h)) 4065 (out-to "constants" (write-constants-h)) 4066 #!+sb-ldb 4067 (out-to "tagnames" (write-tagnames-h)) 4068 (let ((structs (sort (copy-list sb!vm:*primitive-objects*) #'string< 4069 :key (lambda (obj) 4070 (symbol-name 4071 (sb!vm:primitive-object-name obj)))))) 4072 (dolist (obj structs) 4073 (out-to 4074 (string-downcase (string (sb!vm:primitive-object-name obj))) 4075 (write-primitive-object obj))) 4076 (out-to "primitive-objects" 4077 (dolist (obj structs) 4078 (format t "~&#include \"~A.h\"~%" 4079 (string-downcase 4080 (string (sb!vm:primitive-object-name obj))))))) 4081 (dolist (class '(hash-table 4082 classoid 4083 layout 4084 sb!c::compiled-debug-info 4085 sb!c::compiled-debug-fun 4086 package)) 4087 (out-to 4088 (string-downcase (string class)) 4089 (write-structure-object 4090 (layout-info (find-layout class))))) 4091 (out-to "static-symbols" (write-static-symbols)) 4092 (out-to "sc-offset" (write-sc-offset-coding)) 4093 4094 (let ((fn (format nil "~A/Makefile.features" c-header-dir-name))) 4095 (ensure-directories-exist fn) 4096 (with-open-file (*standard-output* fn :if-exists :supersede 4097 :direction :output) 4098 (write-makefile-features))) 4099 4100 (when core-file-name 4101 (write-initial-core-file core-file-name)))))) 4102 4103;;; Invert the action of HOST-CONSTANT-TO-CORE. If STRICTP is given as NIL, 4104;;; then we can produce a host object even if it is not a faithful rendition. 4105(defun host-object-from-core (descriptor &optional (strictp t)) 4106 (named-let recurse ((x descriptor)) 4107 (when (cold-null x) 4108 (return-from recurse nil)) 4109 (when (eq (descriptor-gspace x) :load-time-value) 4110 (error "Can't warm a deferred LTV placeholder")) 4111 (when (is-fixnum-lowtag (descriptor-lowtag x)) 4112 (return-from recurse (descriptor-fixnum x))) 4113 (ecase (descriptor-lowtag x) 4114 (#.sb!vm:list-pointer-lowtag 4115 (cons (recurse (cold-car x)) (recurse (cold-cdr x)))) 4116 (#.sb!vm:fun-pointer-lowtag 4117 (if strictp 4118 (error "Can't map cold-fun -> warm-fun") 4119 (let ((name (read-wordindexed x sb!vm:simple-fun-name-slot))) 4120 `(function ,(recurse name))))) 4121 (#.sb!vm:other-pointer-lowtag 4122 (let ((widetag (logand (descriptor-bits (read-memory x)) 4123 sb!vm:widetag-mask))) 4124 (ecase widetag 4125 (#.sb!vm:symbol-header-widetag 4126 (if strictp 4127 (warm-symbol x) 4128 (or (gethash (descriptor-bits x) *cold-symbols*) ; first try 4129 (make-symbol 4130 (recurse (read-wordindexed x sb!vm:symbol-name-slot)))))) 4131 (#.sb!vm:simple-base-string-widetag (base-string-from-core x)) 4132 (#.sb!vm:simple-vector-widetag (vector-from-core x #'recurse)) 4133 (#.sb!vm:bignum-widetag (bignum-from-core x)))))))) 4134