X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fgeneric%2Fgenesis.lisp;h=eb1ab4a61804f0cc09432a7cd1fe04cc6ebc73ec;hb=dcf8b8ccc1e15a5c1c6aba00204b7d3a81827acc;hp=aa879d2a22415b60b711e84489acc5d66eea0a5a;hpb=1de12891f900d156ed035a097561ecd7755a256a;p=sbcl.git diff --git a/src/compiler/generic/genesis.lisp b/src/compiler/generic/genesis.lisp index aa879d2..eb1ab4a 100644 --- a/src/compiler/generic/genesis.lisp +++ b/src/compiler/generic/genesis.lisp @@ -2439,7 +2439,8 @@ core and return a descriptor to it." (write-wordindexed code slot value))) (define-cold-fop (fop-fun-entry) - (let* ((type (pop-stack)) + (let* ((xrefs (pop-stack)) + (type (pop-stack)) (arglist (pop-stack)) (name (pop-stack)) (code-object (pop-stack)) @@ -2496,6 +2497,7 @@ core and return a descriptor to it." (write-wordindexed fn sb!vm:simple-fun-name-slot name) (write-wordindexed fn sb!vm:simple-fun-arglist-slot arglist) (write-wordindexed fn sb!vm:simple-fun-type-slot type) + (write-wordindexed fn sb!vm::simple-fun-xrefs-slot xrefs) fn)) (define-cold-fop (fop-foreign-fixup) @@ -2599,6 +2601,15 @@ core and return a descriptor to it." (format t " *~@[ ~A~]~%" line)) (format t " */~%")) +(defun write-makefile-features () + ;; propagating *SHEBANG-FEATURES* into the Makefiles + (dolist (shebang-feature-name (sort (mapcar #'symbol-name + sb-cold:*shebang-features*) + #'string<)) + (format t + "LISP_FEATURE_~A=1~%" + (substitute #\_ #\- shebang-feature-name)))) + (defun write-config-h () ;; propagating *SHEBANG-FEATURES* into C-level #define's (dolist (shebang-feature-name (sort (mapcar #'symbol-name @@ -2717,22 +2728,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) @@ -2740,7 +2746,7 @@ core and return a descriptor to it." ((< value cutoff) "~D") (t - "LISPOBJ(~DU)"))) + "~DU"))) value) (format t " /* 0x~X */~@[ /* ~A */~]~%" value doc)))) (terpri)) @@ -2757,6 +2763,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 @@ -2787,31 +2800,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) @@ -3264,11 +3279,11 @@ initially undefined function references:~2%") (format t "#endif /* SBCL_GENESIS_~A */~%" (string-upcase ,name)))))) - (when map-file-name - (with-open-file (*standard-output* map-file-name - :direction :output - :if-exists :supersede) - (write-map))) + (when map-file-name + (with-open-file (*standard-output* map-file-name + :direction :output + :if-exists :supersede) + (write-map))) (out-to "config" (write-config-h)) (out-to "constants" (write-constants-h)) (let ((structs (sort (copy-list sb!vm:*primitive-objects*) #'string< @@ -3295,5 +3310,13 @@ initially undefined function references:~2%") (sb!kernel:layout-info (sb!kernel:find-layout class))))) (out-to "static-symbols" (write-static-symbols)) - (when core-file-name + (let ((fn (format nil "~A/Makefile.features" c-header-dir-name))) + (ensure-directories-exist fn) + (with-open-file (*standard-output* fn :if-exists :supersede + :direction :output) + (write-makefile-features))) + + (when core-file-name (write-initial-core-file core-file-name)))))) + +