X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fgeneric%2Fgenesis.lisp;h=93ebd3c507f14959ef6e044030175c3bc0cc4ff8;hb=7f579b076a1fc54587538ead07e506e7f06f3fe8;hp=511943f9efe07d1d2333e42ab7d77522be88644f;hpb=7976926f8112b708d5927a69923cf7a3dd003c55;p=sbcl.git diff --git a/src/compiler/generic/genesis.lisp b/src/compiler/generic/genesis.lisp index 511943f..93ebd3c 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) @@ -279,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)) @@ -300,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))) @@ -312,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)) @@ -379,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)))) @@ -457,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)) @@ -517,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) @@ -767,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)) @@ -1923,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 @@ -1930,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)) @@ -2120,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) @@ -2301,16 +2337,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))) @@ -2388,17 +2423,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 +2443,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 +2626,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 +2643,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 +2837,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 +2882,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 +2941,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 +3005,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 +3096,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 +3132,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 +3176,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 +3299,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 +3316,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