From 1bcf4fb22a25e713a0ab898d78abb97abe94c225 Mon Sep 17 00:00:00 2001 From: William Harold Newman Date: Sat, 15 Jun 2002 03:05:18 +0000 Subject: [PATCH] 0.7.4.34: minor OAOO FIXME for GENESIS... ..made the FOO-ENTRY-TYPE-CODE parameters propagate automatically into sbcl.h instead of maintaining separate copies of their definititions in core.h (and renamed them, s/entry-type-code/core-entry-type-code/, to help make them more painfully specific now that their scope is wider) ...similarly propagated FOO-SPACE-ID automatically into sbcl.h, and s/foo-space-id/foo-core-space-id/ --- TODO | 1 - package-data-list.lisp-expr | 13 +++- src/compiler/generic/genesis.lisp | 148 ++++++++++++++++++------------------- src/runtime/core.h | 11 --- src/runtime/coreparse.c | 24 +++--- src/runtime/save.c | 16 ++-- version.lisp-expr | 2 +- 7 files changed, 102 insertions(+), 113 deletions(-) diff --git a/TODO b/TODO index 0283960..d98e480 100644 --- a/TODO +++ b/TODO @@ -5,7 +5,6 @@ for early 0.7.x: ** (also, while working on INLINE anyway, it might be easy to flush the old MAYBE-INLINE cruft entirely, including e.g. on the man page) - ** fixed bug 137 (more) * faster bootstrapping (both make.sh and slam.sh) ** added mechanisms for automatically finding dead code, and used them to remove dead code diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index 0fb1765..51c20e1 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -466,6 +466,8 @@ like *STACK-TOP-HINT* and unsupported stuff like *TRACED-FUN-LIST*." "CLOSE-FASL-OUTPUT" "DUMP-ASSEMBLER-ROUTINES" "DUMP-OBJECT" + "DYNAMIC-CORE-SPACE-ID" + "END-CORE-ENTRY-TYPE-CODE" "FASL-CONSTANT-ALREADY-DUMPED-P" "+FASL-FILE-VERSION+" "FASL-DUMP-COLD-LOAD-FORM" "FASL-DUMP-COMPONENT" @@ -476,11 +478,16 @@ like *STACK-TOP-HINT* and unsupported stuff like *TRACED-FUN-LIST*." "FASL-OUTPUT" "FASL-OUTPUT-P" "FASL-OUTPUT-ENTRY-TABLE" "FASL-OUTPUT-STREAM" "FASL-VALIDATE-STRUCTURE" + "INITIAL-FUN-CORE-ENTRY-TYPE-CODE" "*!LOAD-TIME-VALUES*" "LOAD-TYPE-PREDICATE" + "NEW-DIRECTORY-CORE-ENTRY-TYPE-CODE" "OPEN-FASL-OUTPUT" + "READ-ONLY-CORE-SPACE-ID" "*!REVERSED-COLD-TOPLEVELS*" - "*STATIC-FOREIGN-SYMBOLS*")) + "STATIC-CORE-SPACE-ID" + "*STATIC-FOREIGN-SYMBOLS*" + "VERSION-CORE-ENTRY-TYPE-CODE")) ;; This package is a grab bag for things which used to be internal ;; symbols in package COMMON-LISP. Lots of these symbols are accessed @@ -490,8 +497,8 @@ like *STACK-TOP-HINT* and unsupported stuff like *TRACED-FUN-LIST*." ;; an existing package (e.g. KERNEL or SYS or EXT or FASL), I ;; (WHN 19990223) encourage maintainers to move them there.. ;; - ;; ..except that it's getting so big and crowded that maybe it - ;; should be split up, too. + ;; ..except that it's getting so big and crowded that maybe it should + ;; be split up, too. #s(sb-cold:package-data :name "SB!IMPL" :doc "private: a grab bag of implementation details" diff --git a/src/compiler/generic/genesis.lisp b/src/compiler/generic/genesis.lisp index dd38551..fad92a9 100644 --- a/src/compiler/generic/genesis.lisp +++ b/src/compiler/generic/genesis.lisp @@ -200,13 +200,13 @@ ;;; copying GC is in use), then only the active dynamic space gets ;;; dumped to core. (defvar *dynamic*) -(defconstant dynamic-space-id 1) +(defconstant dynamic-core-space-id 1) (defvar *static*) -(defconstant static-space-id 2) +(defconstant static-core-space-id 2) (defvar *read-only*) -(defconstant read-only-space-id 3) +(defconstant read-only-core-space-id 3) (defconstant descriptor-low-bits 16 "the number of bits in the low half of the descriptor") @@ -1625,7 +1625,7 @@ (defun note-load-time-code-fixup (code-object offset value kind) ;; If CODE-OBJECT might be moved (when (= (gspace-identifier (descriptor-intuit-gspace code-object)) - dynamic-space-id) + dynamic-core-space-id) ;; FIXME: pushed thing should be a structure, not just a list (push (list code-object offset value kind) *load-time-code-fixups*)) (values)) @@ -2623,64 +2623,63 @@ (sb!xc:lisp-implementation-version)) (format t "#define CORE_MAGIC 0x~X~%" core-magic) (terpri) - ;; FIXME: Other things from core.h should be defined here too: - ;; #define CORE_END 3840 - ;; #define CORE_NDIRECTORY 3861 - ;; #define CORE_VALIDATE 3845 - ;; #define CORE_VERSION 3860 - ;; #define CORE_MACHINE_STATE 3862 - ;; (Except that some of them are obsolete and should be deleted instead.) - ;; also - ;; #define DYNAMIC_SPACE_ID (1) - ;; #define STATIC_SPACE_ID (2) - ;; #define READ_ONLY_SPACE_ID (3) - - ;; writing entire families of named constants from SB!VM + + ;; writing entire families of named constants (let ((constants nil)) - (do-external-symbols (symbol (find-package "SB!VM")) - (when (constantp symbol) - (let ((name (symbol-name symbol))) - (labels (;; shared machinery - (record (string priority) - (push (list string - priority - (symbol-value symbol) - (documentation symbol 'variable)) - constants)) - ;; machinery for old-style CMU CL Lisp-to-C - ;; arbitrary renaming, being phased out in favor of - ;; the newer systematic RECORD-WITH-TRANSLATED-NAME - ;; renaming - (record-with-munged-name (prefix string priority) - (record (concatenate - 'simple-string - prefix - (delete #\- (string-capitalize string))) - priority)) - (maybe-record-with-munged-name (tail prefix priority) - (when (tailwise-equal name tail) - (record-with-munged-name prefix - (subseq name 0 - (- (length name) - (length tail))) - priority))) - ;; machinery for new-style SBCL Lisp-to-C naming - (record-with-translated-name (priority) - (record (substitute #\_ #\- name) - priority)) - (maybe-record-with-translated-name (suffixes priority) - (when (some (lambda (suffix) - (tailwise-equal name suffix)) - suffixes) - (record-with-translated-name priority)))) - - (maybe-record-with-translated-name '("-LOWTAG") 0) - (maybe-record-with-translated-name '("-WIDETAG") 1) - (maybe-record-with-munged-name "-FLAG" "flag_" 2) - (maybe-record-with-munged-name "-TRAP" "trap_" 3) - (maybe-record-with-munged-name "-SUBTYPE" "subtype_" 4) - (maybe-record-with-munged-name "-SC-NUMBER" "sc_" 5) - (maybe-record-with-translated-name '("-START" "-END") 6))))) + (dolist (package-name '(;; Even in CMU CL, constants from VM + ;; were automatically propagated + ;; into the runtime. + "SB!VM" + ;; In SBCL, we also propagate various + ;; magic numbers related to file format, + ;; which live here instead of SB!VM. + "SB!FASL")) + (do-external-symbols (symbol (find-package package-name)) + (when (constantp symbol) + (let ((name (symbol-name symbol))) + (labels (;; shared machinery + (record (string priority) + (push (list string + priority + (symbol-value symbol) + (documentation symbol 'variable)) + constants)) + ;; machinery for old-style CMU CL Lisp-to-C + ;; arbitrary renaming, being phased out in favor of + ;; the newer systematic RECORD-WITH-TRANSLATED-NAME + ;; renaming + (record-with-munged-name (prefix string priority) + (record (concatenate + 'simple-string + prefix + (delete #\- (string-capitalize string))) + priority)) + (maybe-record-with-munged-name (tail prefix priority) + (when (tailwise-equal name tail) + (record-with-munged-name prefix + (subseq name 0 + (- (length name) + (length tail))) + priority))) + ;; machinery for new-style SBCL Lisp-to-C naming + (record-with-translated-name (priority) + (record (substitute #\_ #\- name) + priority)) + (maybe-record-with-translated-name (suffixes priority) + (when (some (lambda (suffix) + (tailwise-equal name suffix)) + suffixes) + (record-with-translated-name priority)))) + + (maybe-record-with-translated-name '("-LOWTAG") 0) + (maybe-record-with-translated-name '("-WIDETAG") 1) + (maybe-record-with-munged-name "-FLAG" "flag_" 2) + (maybe-record-with-munged-name "-TRAP" "trap_" 3) + (maybe-record-with-munged-name "-SUBTYPE" "subtype_" 4) + (maybe-record-with-munged-name "-SC-NUMBER" "sc_" 5) + (maybe-record-with-translated-name '("-START" "-END") 6) + (maybe-record-with-translated-name '("-CORE-ENTRY-TYPE-CODE") 7) + (maybe-record-with-translated-name '("-CORE-SPACE-ID") 8)))))) (setf constants (sort constants (lambda (const1 const2) @@ -2869,15 +2868,10 @@ initially undefined function references:~2%") (defvar *core-file*) (defvar *data-page*) -;;; KLUDGE: These numbers correspond to values in core.h. If they're -;;; documented anywhere, I haven't found it. (I haven't tried very -;;; hard yet.) -- WHN 19990826 -(defparameter version-entry-type-code 3860) -(defparameter validate-entry-type-code 3845) -(defparameter directory-entry-type-code 3841) -(defparameter new-directory-entry-type-code 3861) -(defparameter initial-fun-entry-type-code 3863) -(defparameter end-entry-type-code 3840) +(defconstant version-core-entry-type-code 3860) +(defconstant new-directory-core-entry-type-code 3861) +(defconstant initial-fun-core-entry-type-code 3863) +(defconstant end-core-entry-type-code 3840) (declaim (ftype (function (sb!vm:word) sb!vm:word) write-word)) (defun write-word (num) @@ -2965,12 +2959,12 @@ initially undefined function references:~2%") (write-word core-magic) ;; Write the Version entry. - (write-word version-entry-type-code) + (write-word version-core-entry-type-code) (write-word 3) (write-word sbcl-core-version-integer) ;; Write the New Directory entry header. - (write-word new-directory-entry-type-code) + (write-word new-directory-core-entry-type-code) (write-word 17) ; length = (5 words/space) * 3 spaces + 2 for header. (output-gspace *read-only*) @@ -2978,7 +2972,7 @@ initially undefined function references:~2%") (output-gspace *dynamic*) ;; Write the initial function. - (write-word initial-fun-entry-type-code) + (write-word initial-fun-core-entry-type-code) (write-word 3) (let* ((cold-name (cold-intern '!cold-init)) (cold-fdefn (cold-fdefinition-object cold-name)) @@ -2990,7 +2984,7 @@ initially undefined function references:~2%") (write-word (descriptor-bits initial-fun))) ;; Write the End entry. - (write-word end-entry-type-code) + (write-word end-core-entry-type-code) (write-word 2))) (format t "done]~%") @@ -3072,13 +3066,13 @@ initially undefined function references:~2%") (*cold-symbols* (make-hash-table :test 'equal)) (*cold-package-symbols* nil) (*read-only* (make-gspace :read-only - read-only-space-id + read-only-core-space-id sb!vm:read-only-space-start)) (*static* (make-gspace :static - static-space-id + static-core-space-id sb!vm:static-space-start)) (*dynamic* (make-gspace :dynamic - dynamic-space-id + dynamic-core-space-id #!+gencgc sb!vm:dynamic-space-start #!-gencgc sb!vm:dynamic-0-space-start)) (*nil-descriptor* (make-nil-descriptor)) diff --git a/src/runtime/core.h b/src/runtime/core.h index 0056d2f..2fcbd13 100644 --- a/src/runtime/core.h +++ b/src/runtime/core.h @@ -14,17 +14,6 @@ #include "runtime.h" -#define CORE_END 3840 -#define CORE_NDIRECTORY 3861 -#define CORE_VALIDATE 3845 -#define CORE_VERSION 3860 -#define CORE_MACHINE_STATE 3862 -#define CORE_INITIAL_FUNCTION 3863 - -#define DYNAMIC_SPACE_ID (1) -#define STATIC_SPACE_ID (2) -#define READ_ONLY_SPACE_ID (3) - struct ndir_entry { #ifndef alpha long identifier; diff --git a/src/runtime/coreparse.c b/src/runtime/coreparse.c index 38452ef..e6f5e5b 100644 --- a/src/runtime/coreparse.c +++ b/src/runtime/coreparse.c @@ -67,7 +67,7 @@ process_directory(int fd, u32 *ptr, int count) id, (long)free_pointer)); switch (id) { - case DYNAMIC_SPACE_ID: + case DYNAMIC_CORE_SPACE_ID: #ifdef GENCGC if (addr != (os_vm_address_t)DYNAMIC_SPACE_START) { fprintf(stderr, "in core: 0x%lx; in runtime: 0x%lx \n", @@ -98,14 +98,14 @@ process_directory(int fd, u32 *ptr, int count) * addr==DYNAMIC_SPACE_START.) */ current_dynamic_space = (lispobj *)addr; break; - case STATIC_SPACE_ID: + case STATIC_CORE_SPACE_ID: if (addr != (os_vm_address_t)STATIC_SPACE_START) { fprintf(stderr, "in core: 0x%lx - in runtime: 0x%lx\n", (long)addr, (long)STATIC_SPACE_START); lose("core/runtime address mismatch: STATIC_SPACE_START"); } break; - case READ_ONLY_SPACE_ID: + case READ_ONLY_CORE_SPACE_ID: if (addr != (os_vm_address_t)READ_ONLY_SPACE_START) { fprintf(stderr, "in core: 0x%lx - in runtime: 0x%lx\n", (long)addr, (long)READ_ONLY_SPACE_START); @@ -150,7 +150,7 @@ load_core_file(char *file) } SHOW("found CORE_MAGIC"); - while (val != CORE_END) { + while (val != END_CORE_ENTRY_TYPE_CODE) { val = *ptr++; len = *ptr++; remaining_len = len - 2; /* (-2 to cancel the two ++ operations) */ @@ -159,12 +159,12 @@ load_core_file(char *file) switch (val) { - case CORE_END: - SHOW("CORE_END case"); + case END_CORE_ENTRY_TYPE_CODE: + SHOW("END_CORE_ENTRY_TYPE_CODE case"); break; - case CORE_VERSION: - SHOW("CORE_VERSION case"); + case VERSION_CORE_ENTRY_TYPE_CODE: + SHOW("VERSION_CORE_ENTRY_TYPE_CODE case"); if (*ptr != SBCL_CORE_VERSION_INTEGER) { lose("core file version (%d) != runtime library version (%d)", *ptr, @@ -172,8 +172,8 @@ load_core_file(char *file) } break; - case CORE_NDIRECTORY: - SHOW("CORE_NDIRECTORY case"); + case NEW_DIRECTORY_CORE_ENTRY_TYPE_CODE: + SHOW("NEW_DIRECTORY_CORE_ENTRY_TYPE_CODE case"); process_directory(fd, ptr, #ifndef alpha @@ -186,8 +186,8 @@ load_core_file(char *file) ); break; - case CORE_INITIAL_FUNCTION: - SHOW("CORE_INITIAL_FUNCTION case"); + case INITIAL_FUN_CORE_ENTRY_TYPE_CODE: + SHOW("INITIAL_FUN_CORE_ENTRY_TYPE_CODE case"); initial_function = (lispobj)*ptr; break; diff --git a/src/runtime/save.c b/src/runtime/save.c index 5783c43..1c50cca 100644 --- a/src/runtime/save.c +++ b/src/runtime/save.c @@ -113,24 +113,24 @@ save(char *filename, lispobj init_function) putw(CORE_MAGIC, file); - putw(CORE_VERSION, file); + putw(VERSION_CORE_ENTRY_TYPE_CODE, file); putw(3, file); putw(SBCL_CORE_VERSION_INTEGER, file); - putw(CORE_NDIRECTORY, file); + putw(NEW_DIRECTORY_CORE_ENTRY_TYPE_CODE, file); putw((5*3)+2, file); output_space(file, - READ_ONLY_SPACE_ID, + READ_ONLY_CORE_SPACE_ID, (lispobj *)READ_ONLY_SPACE_START, (lispobj *)SymbolValue(READ_ONLY_SPACE_FREE_POINTER)); output_space(file, - STATIC_SPACE_ID, + STATIC_CORE_SPACE_ID, (lispobj *)STATIC_SPACE_START, (lispobj *)SymbolValue(STATIC_SPACE_FREE_POINTER)); #ifdef reg_ALLOC output_space(file, - DYNAMIC_SPACE_ID, + DYNAMIC_CORE_SPACE_ID, (lispobj *)current_dynamic_space, dynamic_space_free_pointer); #else @@ -141,16 +141,16 @@ save(char *filename, lispobj init_function) update_x86_dynamic_space_free_pointer(); #endif output_space(file, - DYNAMIC_SPACE_ID, + DYNAMIC_CORE_SPACE_ID, (lispobj *)DYNAMIC_SPACE_START, (lispobj *)SymbolValue(ALLOCATION_POINTER)); #endif - putw(CORE_INITIAL_FUNCTION, file); + putw(INITIAL_FUN_CORE_ENTRY_TYPE_CODE, file); putw(3, file); putw(init_function, file); - putw(CORE_END, file); + putw(END_CORE_ENTRY_TYPE_CODE, file); fclose(file); printf("done]\n"); diff --git a/version.lisp-expr b/version.lisp-expr index 5a948aa..fb92cf5 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -18,4 +18,4 @@ ;;; for internal versions, especially for internal versions off the ;;; main CVS branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"0.7.4.33" +"0.7.4.34" -- 1.7.10.4