X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fgeneric%2Fgenesis.lisp;h=20e1839fc70f9f1b0440821d885ddc6c6de41da9;hb=7f1e94ae961a198e00daf281eb1dc858e5b2dcc7;hp=9dd22641f7e4027bc3f981dc304faafed7134ded;hpb=7e02fe01f102c9e536df701dc783149a8d76b3fc;p=sbcl.git diff --git a/src/compiler/generic/genesis.lisp b/src/compiler/generic/genesis.lisp index 9dd2264..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) @@ -282,6 +286,13 @@ (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)) @@ -314,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)) @@ -518,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) @@ -563,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." @@ -581,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)." @@ -837,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) @@ -1450,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) @@ -1476,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*) @@ -1500,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) @@ -1924,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 @@ -1931,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)) @@ -2121,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) @@ -2228,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 @@ -2263,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)) @@ -2388,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 @@ -2408,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)))) @@ -2591,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)) @@ -2602,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)) @@ -2788,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)) @@ -2829,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 @@ -2887,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 @@ -2947,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) @@ -3038,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)) @@ -3072,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)) @@ -3118,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) @@ -3240,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~%" @@ -3254,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