X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fgeneric%2Fgenesis.lisp;h=e633d66019364a99ed55aabd27d48a3030da1e2d;hb=dde722d640c8a9da7a2d216a5f7250dbb70294a5;hp=b148ceece4200b247931f9273a6362e42afbf653;hpb=d09f30f49f9d2ba8bee0b216c2411c66c2df8f2b;p=sbcl.git diff --git a/src/compiler/generic/genesis.lisp b/src/compiler/generic/genesis.lisp index b148cee..e633d66 100644 --- a/src/compiler/generic/genesis.lisp +++ b/src/compiler/generic/genesis.lisp @@ -231,6 +231,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 +279,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 +310,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 +321,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 +383,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 +460,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 +520,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) @@ -764,7 +773,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)) @@ -936,6 +945,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*) @@ -1597,6 +1607,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 +1621,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 +1929,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 +1952,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)) @@ -1933,8 +1988,6 @@ core and return a descriptor to it." ;; modified. (copy-seq *fop-funs*)) -(defvar *normal-fop-funs*) - ;;; Cause a fop to have a special definition for cold load. ;;; ;;; This is similar to DEFINE-FOP, but unlike DEFINE-FOP, this version @@ -1978,8 +2031,7 @@ core and return a descriptor to it." (defun cold-load (filename) #!+sb-doc "Load the file named by FILENAME into the cold load image being built." - (let* ((*normal-fop-funs* *fop-funs*) - (*fop-funs* *cold-fop-funs*) + (let* ((*fop-funs* *cold-fop-funs*) (*cold-load-filename* (etypecase filename (string filename) (pathname (namestring filename))))) @@ -1996,15 +2048,6 @@ core and return a descriptor to it." (define-cold-fop (fop-empty-list) nil) (define-cold-fop (fop-truth) t) -(define-cold-fop (fop-normal-load :stackp nil) - (setq *fop-funs* *normal-fop-funs*)) - -(define-fop (fop-maybe-cold-load 82 :stackp nil) - (when *cold-load-filename* - (setq *fop-funs* *cold-fop-funs*))) - -(define-cold-fop (fop-maybe-cold-load :stackp nil)) - (clone-cold-fop (fop-struct) (fop-small-struct) (let* ((size (clone-arg)) @@ -2109,7 +2152,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) @@ -2131,6 +2174,15 @@ core and return a descriptor to it." (let ((symbol-des (allocate-symbol name))) (push-fop-table symbol-des)))) +;;;; cold fops for loading packages + +(clone-cold-fop (fop-named-package-save :stackp nil) + (fop-small-named-package-save) + (let* ((size (clone-arg)) + (name (make-string size))) + (read-string-as-bytes *fasl-input-stream* name) + (push-fop-table (find-package name)))) + ;;;; cold fops for loading lists ;;; Make a list of the top LENGTH things on the fop stack. The last @@ -2281,16 +2333,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))) @@ -2368,17 +2419,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 @@ -2388,7 +2439,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)))) @@ -2571,6 +2622,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)) @@ -2582,11 +2639,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)) @@ -2768,7 +2833,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)) @@ -2781,9 +2850,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 @@ -2806,7 +2878,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 @@ -2864,6 +2937,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 @@ -2924,14 +3001,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) @@ -3015,7 +3092,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)) @@ -3049,8 +3128,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)) @@ -3217,7 +3294,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~%" @@ -3231,11 +3311,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