X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=sidebyside;f=src%2Fcompiler%2Fgeneric%2Fgenesis.lisp;h=2440b6cfbfb5569bec89b11d326dfb42d9d52661;hb=a83d979b12102a512f8b040fa2f9329db5ecf28e;hp=ce479853228392be1d8c26f6c05beab47305f99a;hpb=cb83aa22932bf4b9bc74ac6f0fcd91db1702ad33;p=sbcl.git diff --git a/src/compiler/generic/genesis.lisp b/src/compiler/generic/genesis.lisp index ce47985..2440b6c 100644 --- a/src/compiler/generic/genesis.lisp +++ b/src/compiler/generic/genesis.lisp @@ -1278,6 +1278,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 +1321,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 +1336,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 +1358,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 +1389,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) @@ -2728,22 +2738,17 @@ core and return a descriptor to it." (setf prev-priority priority)) (format t "#define ~A " name) (format t - ;; KLUDGE: As of sbcl-0.6.7.14, we're dumping two - ;; different kinds of values here, (1) small codes - ;; and (2) machine addresses. The small codes can be - ;; dumped as bare integer values. The large machine - ;; addresses might cause problems if they're large - ;; and represented as (signed) C integers, so we - ;; want to force them to be unsigned. We do that by - ;; wrapping them in the LISPOBJ macro. (We could do - ;; it with a bare "(unsigned)" cast, except that - ;; this header file is used not only in C files, but - ;; also in assembly files, which don't understand - ;; the cast syntax. The LISPOBJ macro goes away in - ;; assembly files, but that shouldn't matter because - ;; we don't do arithmetic on address constants in - ;; assembly files. See? It really is a kludge..) -- - ;; WHN 2000-10-18 + ;; KLUDGE: We're dumping two different kinds of + ;; values here, (1) small codes and (2) machine + ;; addresses. The small codes can be dumped as bare + ;; integer values. The large machine addresses might + ;; cause problems if they're large and represented + ;; as (signed) C integers, so we want to force them + ;; to be unsigned by appending an U to the + ;; literal. We can't dump all the values using the + ;; 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 (cutoff (expt 2 16))) (cond ((minusp value) @@ -2751,7 +2756,7 @@ core and return a descriptor to it." ((< value cutoff) "~D") (t - "LISPOBJ(~DU)"))) + "~DU"))) value) (format t " /* 0x~X */~@[ /* ~A */~]~%" value doc)))) (terpri)) @@ -2768,6 +2773,13 @@ core and return a descriptor to it." i))))) (terpri) + ;; I'm not really sure why this is in SB!C, since it seems + ;; conceptually like something that belongs to SB!VM. In any case, + ;; it's needed C-side. + (format t "#define BACKEND_PAGE_SIZE ~DU~%" sb!c:*backend-page-size*) + + (terpri) + ;; FIXME: The SPARC has a PSEUDO-ATOMIC-TRAP that differs between ;; platforms. If we export this from the SB!VM package, it gets ;; written out as #define trap_PseudoAtomic, which is confusing as @@ -2798,31 +2810,33 @@ core and return a descriptor to it." (defun write-primitive-object (obj) ;; writing primitive object layouts - (format t "#ifndef LANGUAGE_ASSEMBLY~2%") - (format t - "struct ~A {~%" - (substitute #\_ #\- - (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)))) - (sb!vm:slot-rest-p slot))) + (format t "#ifndef LANGUAGE_ASSEMBLY~2%") + (format t + "struct ~A {~%" + (substitute #\_ #\- + (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)))) + (sb!vm:slot-rest-p slot))) (format t "};~2%") - (format t "#else /* LANGUAGE_ASSEMBLY */~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~%" - (substitute #\_ #\- (string name)) - (substitute #\_ #\- (string (sb!vm:slot-name slot))) - (- (* (sb!vm:slot-offset slot) sb!vm:n-word-bytes) lowtag))) + (format t "#else /* LANGUAGE_ASSEMBLY */~2%") + (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~%" + (substitute #\_ #\- (string name)) + (substitute #\_ #\- (string (sb!vm:slot-name slot))) + (- (* (sb!vm:slot-offset slot) sb!vm:n-word-bytes) lowtag))) (terpri))) - (format t "#endif /* LANGUAGE_ASSEMBLY */~2%")) + (format t "#endif /* LANGUAGE_ASSEMBLY */~2%")) (defun write-structure-object (dd) (flet ((cstring (designator)