X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fgeneric%2Fgenesis.lisp;h=20e1839fc70f9f1b0440821d885ddc6c6de41da9;hb=19319c931fc1636835dbef71808cc10e252bcf45;hp=6470fda01c9664f89300efff77d3d76521fb7350;hpb=29d8741c513c6866c1cc618132964e6d320b5e41;p=sbcl.git diff --git a/src/compiler/generic/genesis.lisp b/src/compiler/generic/genesis.lisp index 6470fda..20e1839 100644 --- a/src/compiler/generic/genesis.lisp +++ b/src/compiler/generic/genesis.lisp @@ -130,10 +130,14 @@ +smallvec-length+)) ;;; analogous to WRITE-SEQUENCE, but for a BIGVEC -(defun write-bigvec-as-sequence (bigvec stream &key (start 0) end) - (loop for i of-type index from start below (or end (bvlength bigvec)) do - (write-byte (bvref bigvec i) - stream))) +(defun write-bigvec-as-sequence (bigvec stream &key (start 0) end pad-with-zeros) + (let* ((bvlength (bvlength bigvec)) + (data-length (min (or end bvlength) bvlength))) + (loop for i of-type index from start below data-length do + (write-byte (bvref bigvec i) + stream)) + (when (and pad-with-zeros (< bvlength data-length)) + (loop repeat (- data-length bvlength) do (write-byte 0 stream))))) ;;; analogous to READ-SEQUENCE-OR-DIE, but for a BIGVEC (defun read-bigvec-as-sequence-or-die (bigvec stream &key (start 0) end) @@ -231,6 +235,9 @@ (defvar *read-only*) (defconstant read-only-core-space-id 3) +(defconstant max-core-space-id 3) +(defconstant deflated-core-space-id-flag 4) + (defconstant descriptor-low-bits 16 "the number of bits in the low half of the descriptor") (defconstant target-space-alignment (ash 1 descriptor-low-bits) @@ -276,6 +283,16 @@ ;;;; representation of descriptors +(defun is-fixnum-lowtag (lowtag) + (zerop (logand lowtag sb!vm:fixnum-tag-mask))) + +(defun is-other-immediate-lowtag (lowtag) + ;; The other-immediate lowtags are similar to the fixnum lowtags, in + ;; that they have an "effective length" that is shorter than is used + ;; for the pointer lowtags. Unlike the fixnum lowtags, however, the + ;; other-immediate lowtags are always effectively two bits wide. + (= (logand lowtag 3) sb!vm:other-immediate-0-lowtag)) + (defstruct (descriptor (:constructor make-descriptor (high low &optional gspace word-offset)) @@ -297,8 +314,7 @@ (def!method print-object ((des descriptor) stream) (let ((lowtag (descriptor-lowtag des))) (print-unreadable-object (des stream :type t) - (cond ((or (= lowtag sb!vm:even-fixnum-lowtag) - (= lowtag sb!vm:odd-fixnum-lowtag)) + (cond ((is-fixnum-lowtag lowtag) (let ((unsigned (logior (ash (descriptor-high des) (1+ (- descriptor-low-bits sb!vm:n-lowtag-bits))) @@ -309,12 +325,7 @@ (if (> unsigned #x1FFFFFFF) (- unsigned #x40000000) unsigned)))) - ((or (= lowtag sb!vm:other-immediate-0-lowtag) - (= lowtag sb!vm:other-immediate-1-lowtag) - #!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or)) - (= lowtag sb!vm:other-immediate-2-lowtag) - #!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or)) - (= lowtag sb!vm:other-immediate-3-lowtag)) + ((is-other-immediate-lowtag lowtag) (format stream "for other immediate: #X~X, type #b~8,'0B" (ash (descriptor-bits des) (- sb!vm:n-widetag-bits)) @@ -376,16 +387,15 @@ ;; it's hard to see how it could have been wrong, since CMU CL ;; genesis worked. It would be nice to understand how this came ;; to be.. -- WHN 19990901 - (logior (ash bits (- 1 sb!vm:n-lowtag-bits)) + (logior (ash bits (- sb!vm:n-fixnum-tag-bits)) (ash -1 (1+ sb!vm:n-positive-fixnum-bits))) - (ash bits (- 1 sb!vm:n-lowtag-bits))))) + (ash bits (- sb!vm:n-fixnum-tag-bits))))) (defun descriptor-word-sized-integer (des) ;; Extract an (unsigned-byte 32), from either its fixnum or bignum ;; representation. (let ((lowtag (descriptor-lowtag des))) - (if (or (= lowtag sb!vm:even-fixnum-lowtag) - (= lowtag sb!vm:odd-fixnum-lowtag)) + (if (is-fixnum-lowtag lowtag) (make-random-descriptor (descriptor-fixnum des)) (read-wordindexed des 1)))) @@ -454,9 +464,9 @@ (defun make-fixnum-descriptor (num) (when (>= (integer-length num) - (1+ (- sb!vm:n-word-bits sb!vm:n-lowtag-bits))) + (- sb!vm:n-word-bits sb!vm:n-fixnum-tag-bits)) (error "~W is too big for a fixnum." num)) - (make-random-descriptor (ash num (1- sb!vm:n-lowtag-bits)))) + (make-random-descriptor (ash num sb!vm:n-fixnum-tag-bits))) (defun make-other-immediate-descriptor (data type) (make-descriptor (ash data (- sb!vm:n-widetag-bits descriptor-low-bits)) @@ -514,6 +524,9 @@ ;;; the cold core starts up (defvar *current-debug-sources*) +;;; foreign symbol references +(defparameter *cold-foreign-undefined-symbols* nil) + ;;; the name of the object file currently being cold loaded (as a string, not a ;;; pathname), or NIL if we're not currently cold loading any object file (defvar *cold-load-filename* nil) @@ -559,7 +572,7 @@ *current-reversed-cold-toplevels*) (values)) -(declaim (ftype (function (descriptor sb!vm:word (or descriptor symbol))) write-wordindexed)) +(declaim (ftype (function (descriptor sb!vm:word (or symbol descriptor))) write-wordindexed)) (defun write-wordindexed (address index value) #!+sb-doc "Write VALUE displaced INDEX words from ADDRESS." @@ -577,7 +590,7 @@ (setf (bvref-word bytes byte-index) (descriptor-bits value))))) -(declaim (ftype (function (descriptor (or descriptor symbol))) write-memory)) +(declaim (ftype (function (descriptor (or symbol descriptor))) write-memory)) (defun write-memory (address value) #!+sb-doc "Write VALUE (a DESCRIPTOR) at ADDRESS (also a DESCRIPTOR)." @@ -764,7 +777,7 @@ core and return a descriptor to it." (defun number-to-core (number) (typecase number (integer (if (< (integer-length number) - (- (1+ sb!vm:n-word-bits) sb!vm:n-lowtag-bits)) + (- sb!vm:n-word-bits sb!vm:n-fixnum-tag-bits)) (make-fixnum-descriptor number) (bignum-to-core number))) (ratio (number-pair-to-core (number-to-core (numerator number)) @@ -833,7 +846,7 @@ core and return a descriptor to it." ;;; descriptor of a cold symbol or (in an abbreviation for the ;;; most common usage pattern) an ordinary symbol, which will be ;;; automatically cold-interned. -(declaim (ftype (function ((or descriptor symbol) descriptor)) cold-set)) +(declaim (ftype (function ((or symbol descriptor) descriptor)) cold-set)) (defun cold-set (symbol-or-symbol-des value) (let ((symbol-des (etypecase symbol-or-symbol-des (descriptor symbol-or-symbol-des) @@ -936,6 +949,7 @@ core and return a descriptor to it." (cold-set-layout-slot result 'info *nil-descriptor*) (cold-set-layout-slot result 'pure *nil-descriptor*) (cold-set-layout-slot result 'n-untagged-slots nuntagged) + (cold-set-layout-slot result 'source-location *nil-descriptor*) (cold-set-layout-slot result 'for-std-class-p *nil-descriptor*) (setf (gethash name *cold-layouts*) @@ -1445,7 +1459,7 @@ core and return a descriptor to it." ;;; Given a cold representation of a function name, return a warm ;;; representation. -(declaim (ftype (function ((or descriptor symbol)) (or symbol list)) warm-fun-name)) +(declaim (ftype (function ((or symbol descriptor)) (or symbol list)) warm-fun-name)) (defun warm-fun-name (des) (let ((result (if (symbolp des) @@ -1471,7 +1485,7 @@ core and return a descriptor to it." result)) (defun cold-fdefinition-object (cold-name &optional leave-fn-raw) - (declare (type (or descriptor symbol) cold-name)) + (declare (type (or symbol descriptor) cold-name)) (/show0 "/cold-fdefinition-object") (let ((warm-name (warm-fun-name cold-name))) (or (gethash warm-name *cold-fdefn-objects*) @@ -1495,7 +1509,7 @@ core and return a descriptor to it." ;;; Handle the at-cold-init-time, fset-for-static-linkage operation ;;; requested by FOP-FSET. (defun static-fset (cold-name defn) - (declare (type (or descriptor symbol) cold-name)) + (declare (type (or symbol descriptor) cold-name)) (let ((fdefn (cold-fdefinition-object cold-name t)) (type (logand (descriptor-low (read-memory defn)) sb!vm:widetag-mask))) (write-wordindexed fdefn sb!vm:fdefn-fun-slot defn) @@ -1597,6 +1611,13 @@ core and return a descriptor to it." (subseq line (1+ p2))) (values (parse-integer line :end p1 :radix 16) (subseq line (1+ p2)))) + ;; KLUDGE CLH 2010-05-31: on darwin, nm gives us + ;; _function but dlsym expects us to look up + ;; function, without the leading _ . Therefore, we + ;; strip it off here. + #!+darwin + (when (equal (char name 0) #\_) + (setf name (subseq name 1))) (multiple-value-bind (old-value found) (gethash name *cold-foreign-symbol-table*) (when (and found @@ -1604,7 +1625,19 @@ core and return a descriptor to it." (warn "redefining ~S from #X~X to #X~X" name old-value value))) (/show "adding to *cold-foreign-symbol-table*:" name value) - (setf (gethash name *cold-foreign-symbol-table*) value)))))) + (setf (gethash name *cold-foreign-symbol-table*) value) + #!+win32 + (let ((at-position (position #\@ name))) + (when at-position + (let ((name (subseq name 0 at-position))) + (multiple-value-bind (old-value found) + (gethash name *cold-foreign-symbol-table*) + (when (and found + (not (= old-value value))) + (warn "redefining ~S from #X~X to #X~X" + name old-value value))) + (setf (gethash name *cold-foreign-symbol-table*) + value))))))))) (values)) ;; PROGN (defun cold-foreign-symbol-address (name) @@ -1900,6 +1933,22 @@ core and return a descriptor to it." (when value (do-cold-fixup (second fixup) (third fixup) value (fourth fixup)))))) +#!+sb-dynamic-core +(progn + (defparameter *dyncore-address* sb!vm::linkage-table-space-start) + (defparameter *dyncore-linkage-keys* nil) + (defparameter *dyncore-table* (make-hash-table :test 'equal)) + + (defun dyncore-note-symbol (symbol-name datap) + "Register a symbol and return its address in proto-linkage-table." + (let ((key (cons symbol-name datap))) + (symbol-macrolet ((entry (gethash key *dyncore-table*))) + (or entry + (setf entry + (prog1 *dyncore-address* + (push key *dyncore-linkage-keys*) + (incf *dyncore-address* sb!vm::linkage-table-entry-size)))))))) + ;;; *COLD-FOREIGN-SYMBOL-TABLE* becomes *!INITIAL-FOREIGN-SYMBOLS* in ;;; the core. When the core is loaded, !LOADER-COLD-INIT uses this to ;;; create *STATIC-FOREIGN-SYMBOLS*, which the code in @@ -1907,15 +1956,25 @@ core and return a descriptor to it." (defun foreign-symbols-to-core () (let ((symbols nil) (result *nil-descriptor*)) - (maphash (lambda (symbol value) - (push (cons symbol value) symbols)) - *cold-foreign-symbol-table*) - (setq symbols (sort symbols #'string< :key #'car)) - (dolist (symbol symbols) - (cold-push (cold-cons (base-string-to-core (car symbol)) - (number-to-core (cdr symbol))) - result)) - (cold-set (cold-intern 'sb!kernel:*!initial-foreign-symbols*) result)) + #!-sb-dynamic-core + (progn + (maphash (lambda (symbol value) + (push (cons symbol value) symbols)) + *cold-foreign-symbol-table*) + (setq symbols (sort symbols #'string< :key #'car)) + (dolist (symbol symbols) + (cold-push (cold-cons (base-string-to-core (car symbol)) + (number-to-core (cdr symbol))) + result))) + (cold-set (cold-intern 'sb!kernel:*!initial-foreign-symbols*) result) + #!+sb-dynamic-core + (let ((runtime-linking-list *nil-descriptor*)) + (dolist (symbol *dyncore-linkage-keys*) + (cold-push (cold-cons (base-string-to-core (car symbol)) + (cdr symbol)) + runtime-linking-list)) + (cold-set (cold-intern 'sb!vm::*required-runtime-c-symbols*) + runtime-linking-list))) (let ((result *nil-descriptor*)) (dolist (rtn (sort (copy-list *cold-assembler-routines*) #'string< :key #'car)) (cold-push (cold-cons (cold-intern (car rtn)) @@ -2097,7 +2156,7 @@ core and return a descriptor to it." (let ((index (read-arg ,package-len))) (push-fop-table (cold-load-symbol (read-arg ,pname-len) - (svref *current-fop-table* index))))))) + (ref-fop-table index))))))) (frob fop-symbol-in-package-save #.sb!vm:n-word-bytes #.sb!vm:n-word-bytes) (frob fop-small-symbol-in-package-save 1 #.sb!vm:n-word-bytes) (frob fop-symbol-in-byte-package-save #.sb!vm:n-word-bytes 1) @@ -2204,30 +2263,12 @@ core and return a descriptor to it." (pop-stack))) result)) -(define-cold-fop (fop-int-vector) +(define-cold-fop (fop-spec-vector) (let* ((len (read-word-arg)) - (sizebits (read-byte-arg)) - (type (case sizebits - (0 sb!vm:simple-array-nil-widetag) - (1 sb!vm:simple-bit-vector-widetag) - (2 sb!vm:simple-array-unsigned-byte-2-widetag) - (4 sb!vm:simple-array-unsigned-byte-4-widetag) - (7 (prog1 sb!vm:simple-array-unsigned-byte-7-widetag - (setf sizebits 8))) - (8 sb!vm:simple-array-unsigned-byte-8-widetag) - (15 (prog1 sb!vm:simple-array-unsigned-byte-15-widetag - (setf sizebits 16))) - (16 sb!vm:simple-array-unsigned-byte-16-widetag) - (31 (prog1 sb!vm:simple-array-unsigned-byte-31-widetag - (setf sizebits 32))) - (32 sb!vm:simple-array-unsigned-byte-32-widetag) - #!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or)) - (63 (prog1 sb!vm:simple-array-unsigned-byte-63-widetag - (setf sizebits 64))) - #!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or)) - (64 sb!vm:simple-array-unsigned-byte-64-widetag) - (t (error "losing element size: ~W" sizebits)))) - (result (allocate-vector-object *dynamic* sizebits len type)) + (type (read-byte-arg)) + (sizebits (aref **saetp-bits-per-length** type)) + (result (progn (aver (< sizebits 255)) + (allocate-vector-object *dynamic* sizebits len type))) (start (+ (descriptor-byte-offset result) (ash sb!vm:vector-data-offset sb!vm:word-shift))) (end (+ start @@ -2239,28 +2280,6 @@ core and return a descriptor to it." :end end) result)) -(define-cold-fop (fop-single-float-vector) - (let* ((len (read-word-arg)) - (result (allocate-vector-object - *dynamic* - sb!vm:n-word-bits - len - sb!vm:simple-array-single-float-widetag)) - (start (+ (descriptor-byte-offset result) - (ash sb!vm:vector-data-offset sb!vm:word-shift))) - (end (+ start (* len 4)))) - (read-bigvec-as-sequence-or-die (descriptor-bytes result) - *fasl-input-stream* - :start start - :end end) - result)) - -(not-cold-fop fop-double-float-vector) -#!+long-float (not-cold-fop fop-long-float-vector) -(not-cold-fop fop-complex-single-float-vector) -(not-cold-fop fop-complex-double-float-vector) -#!+long-float (not-cold-fop fop-complex-long-float-vector) - (define-cold-fop (fop-array) (let* ((rank (read-word-arg)) (data-vector (pop-stack)) @@ -2278,16 +2297,15 @@ core and return a descriptor to it." (let ((total-elements 1)) (dotimes (axis rank) (let ((dim (pop-stack))) - (unless (or (= (descriptor-lowtag dim) sb!vm:even-fixnum-lowtag) - (= (descriptor-lowtag dim) sb!vm:odd-fixnum-lowtag)) + (unless (is-fixnum-lowtag (descriptor-lowtag dim)) (error "non-fixnum dimension? (~S)" dim)) (setf total-elements (* total-elements (logior (ash (descriptor-high dim) (- descriptor-low-bits - (1- sb!vm:n-lowtag-bits))) + sb!vm:n-fixnum-tag-bits)) (ash (descriptor-low dim) - (- 1 sb!vm:n-lowtag-bits))))) + sb!vm:n-fixnum-tag-bits)))) (write-wordindexed result (+ sb!vm:array-dimensions-offset axis) dim))) @@ -2365,17 +2383,17 @@ core and return a descriptor to it." ;;;; cold fops for fixing up circularities (define-cold-fop (fop-rplaca :pushp nil) - (let ((obj (svref *current-fop-table* (read-word-arg))) + (let ((obj (ref-fop-table (read-word-arg))) (idx (read-word-arg))) (write-memory (cold-nthcdr idx obj) (pop-stack)))) (define-cold-fop (fop-rplacd :pushp nil) - (let ((obj (svref *current-fop-table* (read-word-arg))) + (let ((obj (ref-fop-table (read-word-arg))) (idx (read-word-arg))) (write-wordindexed (cold-nthcdr idx obj) 1 (pop-stack)))) (define-cold-fop (fop-svset :pushp nil) - (let ((obj (svref *current-fop-table* (read-word-arg))) + (let ((obj (ref-fop-table (read-word-arg))) (idx (read-word-arg))) (write-wordindexed obj (+ idx @@ -2385,7 +2403,7 @@ core and return a descriptor to it." (pop-stack)))) (define-cold-fop (fop-structset :pushp nil) - (let ((obj (svref *current-fop-table* (read-word-arg))) + (let ((obj (ref-fop-table (read-word-arg))) (idx (read-word-arg))) (write-wordindexed obj (1+ idx) (pop-stack)))) @@ -2568,6 +2586,12 @@ core and return a descriptor to it." (len (read-byte-arg)) (sym (make-string len))) (read-string-as-bytes *fasl-input-stream* sym) + #!+sb-dynamic-core + (let ((offset (read-word-arg)) + (value (dyncore-note-symbol sym nil))) + (do-cold-fixup code-object offset value kind)) + #!- (and) (format t "Bad non-plt fixup: ~S~S~%" sym code-object) + #!-sb-dynamic-core (let ((offset (read-word-arg)) (value (cold-foreign-symbol-address sym))) (do-cold-fixup code-object offset value kind)) @@ -2579,11 +2603,19 @@ core and return a descriptor to it." (code-object (pop-stack)) (len (read-byte-arg)) (sym (make-string len))) + #!-sb-dynamic-core (declare (ignore code-object)) (read-string-as-bytes *fasl-input-stream* sym) - (maphash (lambda (k v) - (format *error-output* "~&~S = #X~8X~%" k v)) - *cold-foreign-symbol-table*) - (error "shared foreign symbol in cold load: ~S (~S)" sym kind))) + #!+sb-dynamic-core + (let ((offset (read-word-arg)) + (value (dyncore-note-symbol sym t))) + (do-cold-fixup code-object offset value kind) + code-object) + #!-sb-dynamic-core + (progn + (maphash (lambda (k v) + (format *error-output* "~&~S = #X~8X~%" k v)) + *cold-foreign-symbol-table*) + (error "shared foreign symbol in cold load: ~S (~S)" sym kind)))) (define-cold-fop (fop-assembler-code) (let* ((length (read-word-arg)) @@ -2765,7 +2797,11 @@ core and return a descriptor to it." priority))) ;; machinery for new-style SBCL Lisp-to-C naming (record-with-translated-name (priority large) - (record (c-name name) priority (if large "LU" ""))) + (record (c-name name) priority + (if large + #!+(and win32 x86-64) "LLU" + #!-(and win32 x86-64) "LU" + ""))) (maybe-record-with-translated-name (suffixes priority &key large) (when (some (lambda (suffix) (tailwise-equal name suffix)) @@ -2778,9 +2814,12 @@ core and return a descriptor to it." (maybe-record-with-munged-name "-SUBTYPE" "subtype_" 4) (maybe-record-with-munged-name "-SC-NUMBER" "sc_" 5) (maybe-record-with-translated-name '("-SIZE") 6) - (maybe-record-with-translated-name '("-START" "-END" "-PAGE-BYTES") 7 :large t) + (maybe-record-with-translated-name '("-START" "-END" "-PAGE-BYTES" + "-CARD-BYTES" "-GRANULARITY") + 7 :large t) (maybe-record-with-translated-name '("-CORE-ENTRY-TYPE-CODE") 8) (maybe-record-with-translated-name '("-CORE-SPACE-ID") 9) + (maybe-record-with-translated-name '("-CORE-SPACE-ID-FLAG") 9) (maybe-record-with-translated-name '("-GENERATION+") 10)))))) ;; KLUDGE: these constants are sort of important, but there's no ;; pleasing way to inform the code above about them. So we fake @@ -2803,7 +2842,8 @@ core and return a descriptor to it." (push (list (c-symbol-name c) 9 (symbol-value c) - "LU" + #!+(and win32 x86-64) "LLU" + #!-(and win32 x86-64) "LU" nil) constants)) (setf constants @@ -2861,6 +2901,10 @@ core and return a descriptor to it." ;; pseudo-atomic-trap-number or pseudo-atomic-magic-constant ;; [possibly applicable to other platforms]) + #!+sb-safepoint + (format t "#define GC_SAFEPOINT_PAGE_ADDR ((void*)0x~XUL) /* ~:*~A */~%" + sb!vm:gc-safepoint-page-addr) + (dolist (symbol '(sb!vm::float-traps-byte sb!vm::float-exceptions-byte sb!vm::float-sticky-bits @@ -2921,14 +2965,14 @@ core and return a descriptor to it." (format t "/* These offsets are SLOT-OFFSET * N-WORD-BYTES - LOWTAG~%") (format t " * so they work directly on tagged addresses. */~2%") (let ((name (sb!vm:primitive-object-name obj)) - (lowtag (eval (sb!vm:primitive-object-lowtag obj)))) - (when lowtag - (dolist (slot (sb!vm:primitive-object-slots obj)) - (format t "#define ~A_~A_OFFSET ~D~%" - (c-symbol-name name) - (c-symbol-name (sb!vm:slot-name slot)) - (- (* (sb!vm:slot-offset slot) sb!vm:n-word-bytes) lowtag))) - (terpri))) + (lowtag (or (symbol-value (sb!vm:primitive-object-lowtag obj)) + 0))) + (dolist (slot (sb!vm:primitive-object-slots obj)) + (format t "#define ~A_~A_OFFSET ~D~%" + (c-symbol-name name) + (c-symbol-name (sb!vm:slot-name slot)) + (- (* (sb!vm:slot-offset slot) sb!vm:n-word-bytes) lowtag))) + (terpri)) (format t "#endif /* LANGUAGE_ASSEMBLY */~2%")) (defun write-structure-object (dd) @@ -3012,7 +3056,9 @@ initially undefined function references:~2%") (setf undefs (sort undefs #'string< :key #'fun-name-block-name)) (dolist (name undefs) - (format t "~S~%" name))) + (format t "~8,'0X: ~S~%" + (descriptor-bits (gethash name *cold-fdefn-objects*)) + name))) (format t "~%~|~%layout names:~2%") (collect ((stuff)) @@ -3046,8 +3092,6 @@ initially undefined function references:~2%") (defconstant new-directory-core-entry-type-code 3861) (defconstant initial-fun-core-entry-type-code 3863) (defconstant page-table-core-entry-type-code 3880) -#!+(and sb-lutex sb-thread) -(defconstant lutex-table-core-entry-type-code 3887) (defconstant end-core-entry-type-code 3840) (declaim (ftype (function (sb!vm:word) sb!vm:word) write-word)) @@ -3092,7 +3136,8 @@ initially undefined function references:~2%") ;; 8K). (write-bigvec-as-sequence (gspace-bytes gspace) *core-file* - :end total-bytes) + :end total-bytes + :pad-with-zeros t) (force-output *core-file*) (file-position *core-file* posn) @@ -3214,7 +3259,10 @@ initially undefined function references:~2%") symbol-table-file-name core-file-name map-file-name - c-header-dir-name) + c-header-dir-name + #+nil (list-objects t)) + #!+sb-dynamic-core + (declare (ignorable symbol-table-file-name)) (format t "~&beginning GENESIS, ~A~%" @@ -3228,11 +3276,19 @@ initially undefined function references:~2%") (let ((*cold-foreign-symbol-table* (make-hash-table :test 'equal))) + #!-sb-dynamic-core (when core-file-name (if symbol-table-file-name (load-cold-foreign-symbol-table symbol-table-file-name) (error "can't output a core file without symbol table file input"))) + #!+sb-dynamic-core + (progn + (setf (gethash (extern-alien-name "undefined_tramp") + *cold-foreign-symbol-table*) + (dyncore-note-symbol "undefined_tramp" nil)) + (dyncore-note-symbol "undefined_alien_function" nil)) + ;; Now that we've successfully read our only input file (by ;; loading the symbol table, if any), it's a good time to ensure ;; that there'll be someplace for our output files to go when