X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fgeneric%2Fgenesis.lisp;h=843cc7343f88b8794baea5f46c8d41b49e8c2c11;hb=672b2f6cb751566526c7f3bb3de6b7d8424760e2;hp=eb1ab4a61804f0cc09432a7cd1fe04cc6ebc73ec;hpb=4e5668af19abcf84587bf3f7a1c4294cd92c94a7;p=sbcl.git diff --git a/src/compiler/generic/genesis.lisp b/src/compiler/generic/genesis.lisp index eb1ab4a..843cc73 100644 --- a/src/compiler/generic/genesis.lisp +++ b/src/compiler/generic/genesis.lisp @@ -851,10 +851,27 @@ core and return a descriptor to it." ;;; the descriptor for layout's layout (needed when making layouts) (defvar *layout-layout*) -;;; FIXME: This information should probably be pulled out of the -;;; cross-compiler's tables at genesis time instead of inserted by -;;; hand here as a bare numeric constant. -(defconstant target-layout-length 18) +(defconstant target-layout-length + (layout-length (find-layout 'layout))) + +(defun target-layout-index (slot-name) + ;; KLUDGE: this is a little bit sleazy, but the tricky thing is that + ;; structure slots don't have a terribly firm idea of their names. + ;; At least here if we change LAYOUT's package of definition, we + ;; only have to change one thing... + (let* ((name (find-symbol (symbol-name slot-name) "SB!KERNEL")) + (layout (find-layout 'layout)) + (dd (layout-info layout)) + (slots (dd-slots dd)) + (dsd (find name slots :key #'dsd-name))) + (aver dsd) + (dsd-index dsd))) + +(defun cold-set-layout-slot (cold-layout slot-name value) + (write-wordindexed + cold-layout + (+ sb!vm:instance-slots-offset (target-layout-index slot-name)) + value)) ;;; Return a list of names created from the cold layout INHERITS data ;;; in X. @@ -878,6 +895,7 @@ core and return a descriptor to it." (defun make-cold-layout (name length inherits depthoid nuntagged) (let ((result (allocate-boxed-object *dynamic* ;; KLUDGE: Why 1+? -- WHN 19990901 + ;; header word? -- CSR 20051204 (1+ target-layout-length) sb!vm:instance-pointer-lowtag))) (write-memory result @@ -891,7 +909,7 @@ core and return a descriptor to it." ;; Set slot 0 = the layout of the layout. (write-wordindexed result sb!vm:instance-slots-offset *layout-layout*) - ;; Set the immediately following slots = CLOS hash values. + ;; Set the CLOS hash value. ;; ;; Note: CMU CL didn't set these in genesis, but instead arranged ;; for them to be set at cold init time. That resulted in slightly @@ -917,41 +935,31 @@ core and return a descriptor to it." ;; before using it. However, they didn't, so we have a slight ;; problem. We address it by generating the hash values using a ;; different algorithm than we use in ordinary operation. - (dotimes (i sb!kernel:layout-clos-hash-length) - (let (;; The expression here is pretty arbitrary, we just want - ;; to make sure that it's not something which is (1) - ;; evenly distributed and (2) not foreordained to arise in - ;; the target Lisp's (RANDOM-LAYOUT-CLOS-HASH) sequence - ;; and show up as the CLOS-HASH value of some other - ;; LAYOUT. - (hash-value - (1+ (mod (logxor (logand (random-layout-clos-hash) 15253) - (logandc2 (random-layout-clos-hash) 15253) - 1) - ;; (The MOD here is defensive programming - ;; to make sure we never write an - ;; out-of-range value even if some joker - ;; sets LAYOUT-CLOS-HASH-MAX to other - ;; than 2^n-1 at some time in the - ;; future.) - sb!kernel:layout-clos-hash-max)))) - (write-wordindexed result - (+ i sb!vm:instance-slots-offset 1) - (make-fixnum-descriptor hash-value)))) + (let (;; The expression here is pretty arbitrary, we just want + ;; to make sure that it's not something which is (1) + ;; evenly distributed and (2) not foreordained to arise in + ;; the target Lisp's (RANDOM-LAYOUT-CLOS-HASH) sequence + ;; and show up as the CLOS-HASH value of some other + ;; LAYOUT. + (hash-value + (1+ (mod (logxor (logand (random-layout-clos-hash) 15253) + (logandc2 (random-layout-clos-hash) 15253) + 1) + (1- sb!kernel:layout-clos-hash-limit))))) + (cold-set-layout-slot result 'clos-hash + (make-fixnum-descriptor hash-value))) ;; Set other slot values. - (let ((base (+ sb!vm:instance-slots-offset - sb!kernel:layout-clos-hash-length - 1))) - ;; (Offset 0 is CLASS, "the class this is a layout for", which - ;; is uninitialized at this point.) - (write-wordindexed result (+ base 1) *nil-descriptor*) ; marked invalid - (write-wordindexed result (+ base 2) inherits) - (write-wordindexed result (+ base 3) depthoid) - (write-wordindexed result (+ base 4) length) - (write-wordindexed result (+ base 5) *nil-descriptor*) ; info - (write-wordindexed result (+ base 6) *nil-descriptor*) ; pure - (write-wordindexed result (+ base 7) nuntagged)) + ;; + ;; leave CLASSOID uninitialized for now + (cold-set-layout-slot result 'invalid *nil-descriptor*) + (cold-set-layout-slot result 'inherits inherits) + (cold-set-layout-slot result 'depthoid depthoid) + (cold-set-layout-slot result 'length length) + (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 'for-std-class-p *nil-descriptor*) (setf (gethash name *cold-layouts*) (list result @@ -971,17 +979,16 @@ core and return a descriptor to it." ;; We initially create the layout of LAYOUT itself with NIL as the LAYOUT and ;; #() as INHERITS, (setq *layout-layout* *nil-descriptor*) - (setq *layout-layout* - (make-cold-layout 'layout - (number-to-core target-layout-length) - (vector-in-core) - ;; FIXME: hard-coded LAYOUT-DEPTHOID of LAYOUT.. - (number-to-core 3) - ;; no raw slots in LAYOUT: - (number-to-core 0))) - (write-wordindexed *layout-layout* - sb!vm:instance-slots-offset - *layout-layout*) + (let ((xlayout-layout (find-layout 'layout))) + (aver (= 0 (layout-n-untagged-slots xlayout-layout))) + (setq *layout-layout* + (make-cold-layout 'layout + (number-to-core target-layout-length) + (vector-in-core) + (number-to-core (layout-depthoid xlayout-layout)) + (number-to-core 0))) + (write-wordindexed + *layout-layout* sb!vm:instance-slots-offset *layout-layout*) ;; Then we create the layouts that we'll need to make a correct INHERITS ;; vector for the layout of LAYOUT itself.. @@ -1013,13 +1020,7 @@ core and return a descriptor to it." ;; ..and return to backpatch the layout of LAYOUT. (setf (fourth (gethash 'layout *cold-layouts*)) (listify-cold-inherits layout-inherits)) - (write-wordindexed *layout-layout* - ;; FIXME: hardcoded offset into layout struct - (+ sb!vm:instance-slots-offset - layout-clos-hash-length - 1 - 2) - layout-inherits))) + (cold-set-layout-slot *layout-layout* 'inherits layout-inherits)))) ;;;; interning symbols in the cold image @@ -1107,7 +1108,8 @@ core and return a descriptor to it." *cl-package* ;; ordinary case (let ((result (symbol-package symbol))) - (aver (package-ok-for-target-symbol-p result)) + (unless (package-ok-for-target-symbol-p result) + (bug "~A in bad package for target: ~A" symbol result)) result)))) ;;; Return a handle on an interned symbol. If necessary allocate the @@ -1278,6 +1280,8 @@ core and return a descriptor to it." (symbols (cdr cold-package-symbols-entry)) (shadows (package-shadowing-symbols cold-package)) (documentation (base-string-to-core (documentation cold-package t))) + (internal-count 0) + (external-count 0) (internal *nil-descriptor*) (external *nil-descriptor*) (imported-internal *nil-descriptor*) @@ -1319,10 +1323,14 @@ core and return a descriptor to it." (case where (:internal (if imported-p (cold-push handle imported-internal) - (cold-push handle internal))) + (progn + (cold-push handle internal) + (incf internal-count)))) (:external (if imported-p (cold-push handle imported-external) - (cold-push handle external))))))) + (progn + (cold-push handle external) + (incf external-count)))))))) (let ((r *nil-descriptor*)) (cold-push documentation r) (cold-push shadowing r) @@ -1330,7 +1338,10 @@ core and return a descriptor to it." (cold-push imported-internal r) (cold-push external r) (cold-push internal r) - (cold-push (make-make-package-args cold-package) r) + (cold-push (make-make-package-args cold-package + internal-count + external-count) + r) ;; FIXME: It would be more space-efficient to use vectors ;; instead of lists here, and space-efficiency here would be ;; nice, since it would reduce the peak memory usage in @@ -1349,9 +1360,9 @@ core and return a descriptor to it." (cold-set 'sb!vm::*fp-constant-0f0* (number-to-core 0f0)) (cold-set 'sb!vm::*fp-constant-1f0* (number-to-core 1f0)))) -;;; Make a cold list that can be used as the arg list to MAKE-PACKAGE in order -;;; to make a package that is similar to PKG. -(defun make-make-package-args (pkg) +;;; Make a cold list that can be used as the arg list to MAKE-PACKAGE in +;;; order to make a package that is similar to PKG. +(defun make-make-package-args (pkg internal-count external-count) (let* ((use *nil-descriptor*) (cold-nicknames *nil-descriptor*) (res *nil-descriptor*)) @@ -1380,13 +1391,14 @@ core and return a descriptor to it." (dolist (warm-nickname warm-nicknames) (cold-push (base-string-to-core warm-nickname) cold-nicknames))) - (cold-push (number-to-core (truncate (package-internal-symbol-count pkg) - 0.8)) - res) + ;; INTERNAL-COUNT and EXTERNAL-COUNT are the number of symbols that + ;; the package contains in the core. We arrange for the package + ;; symbol tables to be created somewhat larger so that they don't + ;; need to be rehashed so easily when additional symbols are + ;; interned during the warm build. + (cold-push (number-to-core (truncate internal-count 0.8)) res) (cold-push (cold-intern :internal-symbols) res) - (cold-push (number-to-core (truncate (package-external-symbol-count pkg) - 0.8)) - res) + (cold-push (number-to-core (truncate external-count 0.8)) res) (cold-push (cold-intern :external-symbols) res) (cold-push cold-nicknames res) @@ -1957,7 +1969,10 @@ core and return a descriptor to it." (layout (pop-stack)) (nuntagged (descriptor-fixnum - (read-wordindexed layout (+ sb!vm:instance-slots-offset 16)))) + (read-wordindexed + layout + (+ sb!vm:instance-slots-offset + (target-layout-index 'n-untagged-slots))))) (ntagged (- size nuntagged))) (write-memory result (make-other-immediate-descriptor size sb!vm:instance-header-widetag)) @@ -2601,23 +2616,28 @@ core and return a descriptor to it." (format t " *~@[ ~A~]~%" line)) (format t " */~%")) +(defun c-name (string &optional strip) + (delete #\+ + (substitute-if #\_ (lambda (c) (member c '(#\- #\/ #\%))) + (remove-if (lambda (c) (position c strip)) + string)))) + +(defun c-symbol-name (symbol &optional strip) + (c-name (symbol-name symbol) strip)) + (defun write-makefile-features () ;; propagating *SHEBANG-FEATURES* into the Makefiles - (dolist (shebang-feature-name (sort (mapcar #'symbol-name + (dolist (shebang-feature-name (sort (mapcar #'c-symbol-name sb-cold:*shebang-features*) #'string<)) - (format t - "LISP_FEATURE_~A=1~%" - (substitute #\_ #\- shebang-feature-name)))) + (format t "LISP_FEATURE_~A=1~%" shebang-feature-name))) (defun write-config-h () ;; propagating *SHEBANG-FEATURES* into C-level #define's - (dolist (shebang-feature-name (sort (mapcar #'symbol-name + (dolist (shebang-feature-name (sort (mapcar #'c-symbol-name sb-cold:*shebang-features*) #'string<)) - (format t - "#define LISP_FEATURE_~A~%" - (substitute #\_ #\- shebang-feature-name))) + (format t "#define LISP_FEATURE_~A~%" shebang-feature-name)) (terpri) ;; and miscellaneous constants (format t "#define SBCL_CORE_VERSION_INTEGER ~D~%" sbcl-core-version-integer) @@ -2635,7 +2655,7 @@ core and return a descriptor to it." (defun write-constants-h () ;; writing entire families of named constants (let ((constants nil)) - (dolist (package-name '(;; Even in CMU CL, constants from VM + (dolist (package-name '( ;; Even in CMU CL, constants from VM ;; were automatically propagated ;; into the runtime. "SB!VM" @@ -2646,7 +2666,7 @@ core and return a descriptor to it." (do-external-symbols (symbol (find-package package-name)) (when (constantp symbol) (let ((name (symbol-name symbol))) - (labels (;; shared machinery + (labels ( ;; shared machinery (record (string priority) (push (list string priority @@ -2672,8 +2692,7 @@ core and return a descriptor to it." priority))) ;; machinery for new-style SBCL Lisp-to-C naming (record-with-translated-name (priority) - (record (substitute #\_ #\- name) - priority)) + (record (c-name name) priority)) (maybe-record-with-translated-name (suffixes priority) (when (some (lambda (suffix) (tailwise-equal name suffix)) @@ -2699,21 +2718,18 @@ core and return a descriptor to it." sb!vm:n-lowtag-bits sb!vm:lowtag-mask sb!vm:n-widetag-bits sb!vm:widetag-mask sb!vm:n-fixnum-tag-bits sb!vm:fixnum-tag-mask)) - (push (list (substitute #\_ #\- (symbol-name c)) + (push (list (c-symbol-name c) -1 ; invent a new priority (symbol-value c) nil) constants)) ;; One more symbol that doesn't fit into the code above. - (flet ((translate (name) - (delete #\+ (substitute #\_ #\- name)))) - (let ((c 'sb!impl::+magic-hash-vector-value+)) - (push (list (translate (symbol-name c)) - 9 - (symbol-value c) - nil) - constants))) - + (let ((c 'sb!impl::+magic-hash-vector-value+)) + (push (list (c-symbol-name c) + 9 + (symbol-value c) + nil) + constants)) (setf constants (sort constants (lambda (const1 const2) @@ -2739,7 +2755,7 @@ core and return a descriptor to it." ;; literal-U syntax, since the assembler doesn't ;; support that syntax and some of the small ;; constants can be used in assembler files. - (let (;; cutoff for treatment as a small code + (let ( ;; cutoff for treatment as a small code (cutoff (expt 2 16))) (cond ((minusp value) (error "stub: negative values unsupported")) @@ -2759,7 +2775,7 @@ core and return a descriptor to it." ;; interr.lisp) -- APD, 2002-03-05 (unless (eq nil (car current-error)) (format t "#define ~A ~D~%" - (substitute #\_ #\- (symbol-name (car current-error))) + (c-symbol-name (car current-error)) i))))) (terpri) @@ -2790,10 +2806,10 @@ core and return a descriptor to it." sb!vm::float-sticky-bits sb!vm::float-rounding-mode)) (format t "#define ~A_POSITION ~A /* ~:*0x~X */~%" - (substitute #\_ #\- (symbol-name symbol)) + (c-symbol-name symbol) (sb!xc:byte-position (symbol-value symbol))) (format t "#define ~A_MASK 0x~X /* ~:*~A */~%" - (substitute #\_ #\- (symbol-name symbol)) + (c-symbol-name symbol) (sb!xc:mask-field (symbol-value symbol) -1)))) @@ -2803,15 +2819,13 @@ core and return a descriptor to it." (format t "#ifndef LANGUAGE_ASSEMBLY~2%") (format t "struct ~A {~%" - (substitute #\_ #\- - (string-downcase (string (sb!vm:primitive-object-name obj))))) + (c-name (string-downcase (string (sb!vm:primitive-object-name obj))))) (when (sb!vm:primitive-object-widetag obj) (format t " lispobj header;~%")) (dolist (slot (sb!vm:primitive-object-slots obj)) (format t " ~A ~A~@[[1]~];~%" (getf (sb!vm:slot-options slot) :c-type "lispobj") - (substitute #\_ #\- - (string-downcase (string (sb!vm:slot-name slot)))) + (c-name (string-downcase (string (sb!vm:slot-name slot)))) (sb!vm:slot-rest-p slot))) (format t "};~2%") (format t "#else /* LANGUAGE_ASSEMBLY */~2%") @@ -2822,17 +2836,15 @@ core and return a descriptor to it." (when lowtag (dolist (slot (sb!vm:primitive-object-slots obj)) (format t "#define ~A_~A_OFFSET ~D~%" - (substitute #\_ #\- (string name)) - (substitute #\_ #\- (string (sb!vm:slot-name slot))) + (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) (flet ((cstring (designator) - (substitute - #\_ #\% - (substitute #\_ #\- (string-downcase (string designator)))))) + (c-name (string-downcase (string designator))))) (format t "#ifndef LANGUAGE_ASSEMBLY~2%") (format t "struct ~A {~%" (cstring (dd-name dd))) (format t " lispobj header;~%") @@ -2852,10 +2864,9 @@ core and return a descriptor to it." ;; FIXME: It would be nice to use longer names than NIL and ;; (particularly) T in #define statements. (format t "#define ~A LISPOBJ(0x~X)~%" - (substitute #\_ #\- - (remove-if (lambda (char) - (member char '(#\% #\* #\. #\!))) - (symbol-name symbol))) + ;; FIXME: It would be nice not to need to strip anything + ;; that doesn't get stripped always by C-SYMBOL-NAME. + (c-symbol-name symbol "%*.!") (if *static* ; if we ran GENESIS ;; We actually ran GENESIS, use the real value. (descriptor-bits (cold-intern symbol)) @@ -3270,7 +3281,7 @@ initially undefined function references:~2%") (with-open-file (*standard-output* fn :if-exists :supersede :direction :output) (write-boilerplate) - (let ((n (substitute #\_ #\- (string-upcase ,name)))) + (let ((n (c-name (string-upcase ,name)))) (format t "#ifndef SBCL_GENESIS_~A~%#define SBCL_GENESIS_~A 1~%"