(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*)
(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)
(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
(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*))
(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)
(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)
(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"
(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
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))
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
(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
- (let (;; cutoff for treatment as a small code
+ ;; 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)
(error "stub: negative values unsupported"))
((< value cutoff)
"~D")
(t
- "LISPOBJ(~DU)")))
+ "~DU")))
value)
(format t " /* 0x~X */~@[ /* ~A */~]~%" value doc))))
(terpri))
;; 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)
+ ;; 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
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))))
(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%")
(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;~%")
;; 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))
(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~%"
projects / sbcl.git / blobdiff