X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fgeneric%2Fgenesis.lisp;h=ce9e73f003b78a0223d6537bf8cca4a0a51dbda5;hb=7c07a6f965c51828d8f452b47e0620d8e6cf2959;hp=241717de50eefacd23194e44cf91bdc3bc6d8275;hpb=dfa55a883f94470267b626dae77ce7e7dfac3df6;p=sbcl.git diff --git a/src/compiler/generic/genesis.lisp b/src/compiler/generic/genesis.lisp index 241717d..ce9e73f 100644 --- a/src/compiler/generic/genesis.lisp +++ b/src/compiler/generic/genesis.lisp @@ -30,7 +30,7 @@ ;;;; provided with absolutely no warranty. See the COPYING and CREDITS ;;;; files for more information. -(in-package "SB!IMPL") +(in-package "SB!FASL") ;;; a magic number used to identify our core files (defconstant core-magic @@ -62,6 +62,9 @@ ;;;; representation of spaces in the core +;;; If there is more than one dynamic space in memory (i.e., if a +;;; copying GC is in use), then only the active dynamic space gets +;;; dumped to core. (defvar *dynamic*) (defconstant dynamic-space-id 1) @@ -176,11 +179,11 @@ (gspace-name gspace) "unknown")))))))) -(defun allocate-descriptor (gspace length lowtag) - #!+sb-doc - "Return a descriptor for a block of LENGTH bytes out of GSPACE. The free - word index is boosted as necessary, and if additional memory is needed, we - grow the GSPACE. The descriptor returned is a pointer of type LOWTAG." +;;; Return a descriptor for a block of LENGTH bytes out of GSPACE. The +;;; free word index is boosted as necessary, and if additional memory +;;; is needed, we grow the GSPACE. The descriptor returned is a +;;; pointer of type LOWTAG. +(defun allocate-cold-descriptor (gspace length lowtag) (let* ((bytes (round-up length (ash 1 sb!vm:lowtag-bits))) (old-free-word-index (gspace-free-word-index gspace)) (new-free-word-index (+ old-free-word-index @@ -509,16 +512,16 @@ #!+sb-doc "Allocate LENGTH words in GSPACE and return a new descriptor of type LOWTAG pointing to them." - (allocate-descriptor gspace (ash length sb!vm:word-shift) lowtag)) + (allocate-cold-descriptor gspace (ash length sb!vm:word-shift) lowtag)) (defun allocate-unboxed-object (gspace element-bits length type) #!+sb-doc "Allocate LENGTH units of ELEMENT-BITS bits plus a header word in GSPACE and return an ``other-pointer'' descriptor to them. Initialize the header word with the resultant length and TYPE." (let* ((bytes (/ (* element-bits length) sb!vm:byte-bits)) - (des (allocate-descriptor gspace - (+ bytes sb!vm:word-bytes) - sb!vm:other-pointer-type))) + (des (allocate-cold-descriptor gspace + (+ bytes sb!vm:word-bytes) + sb!vm:other-pointer-type))) (write-memory des (make-other-immediate-descriptor (ash bytes (- sb!vm:word-shift)) @@ -532,8 +535,9 @@ ;; FIXME: Here and in ALLOCATE-UNBOXED-OBJECT, BYTES is calculated using ;; #'/ instead of #'CEILING, which seems wrong. (let* ((bytes (/ (* element-bits length) sb!vm:byte-bits)) - (des (allocate-descriptor gspace (+ bytes (* 2 sb!vm:word-bytes)) - sb!vm:other-pointer-type))) + (des (allocate-cold-descriptor gspace + (+ bytes (* 2 sb!vm:word-bytes)) + sb!vm:other-pointer-type))) (write-memory des (make-other-immediate-descriptor 0 type)) (write-wordindexed des sb!vm:vector-length-slot @@ -1133,18 +1137,16 @@ ;; the function values for these things?? I.e. why do we need this ;; section at all? Is it because all the FDEFINITION stuff gets in ;; the way of reading function values and is too hairy to rely on at - ;; cold boot? FIXME: 5/6 of these are in *STATIC-SYMBOLS* in + ;; cold boot? FIXME: Most of these are in *STATIC-SYMBOLS* in ;; parms.lisp, but %HANDLE-FUNCTION-END-BREAKPOINT is not. Why? ;; Explain. (macrolet ((frob (symbol) `(cold-set ',symbol (cold-fdefinition-object (cold-intern ',symbol))))) - (frob !cold-init) - (frob sb!impl::maybe-gc) + (frob maybe-gc) (frob internal-error) (frob sb!di::handle-breakpoint) - (frob sb!di::handle-function-end-breakpoint) - (frob sb!impl::fdefinition-object)) + (frob sb!di::handle-function-end-breakpoint)) (cold-set '*current-catch-block* (make-fixnum-descriptor 0)) (cold-set '*current-unwind-protect-block* (make-fixnum-descriptor 0)) @@ -1152,9 +1154,7 @@ (cold-set '*free-interrupt-context-index* (make-fixnum-descriptor 0)) - ;; FIXME: *!INITIAL-LAYOUTS* should be exported from SB!KERNEL, or - ;; perhaps from SB-LD. - (cold-set 'sb!kernel::*!initial-layouts* (cold-list-all-layouts)) + (cold-set '*!initial-layouts* (cold-list-all-layouts)) (/show "dumping packages" (mapcar #'car *cold-package-symbols*)) (let ((initial-symbols *nil-descriptor*)) @@ -1242,9 +1242,7 @@ (cold-set 'sb!vm::*fp-constant-lg2* (number-to-core (log 2L0 10L0))) (cold-set 'sb!vm::*fp-constant-ln2* (number-to-core - (log 2L0 2.718281828459045235360287471352662L0)))) - #!+gencgc - (cold-set 'sb!vm::*SCAVENGE-READ-ONLY-GSPACE* *nil-descriptor*))) + (log 2L0 2.718281828459045235360287471352662L0)))))) ;;; 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. @@ -1345,7 +1343,7 @@ (write-wordindexed fdefn sb!vm:fdefn-raw-addr-slot (make-random-descriptor - (lookup-foreign-symbol "undefined_tramp")))) + (cold-foreign-symbol-address-as-integer "undefined_tramp")))) fdefn)))) (defun cold-fset (cold-name defn) @@ -1367,7 +1365,7 @@ sb!vm:word-shift)))) (#.sb!vm:closure-header-type (make-random-descriptor - (lookup-foreign-symbol "closure_tramp"))))) + (cold-foreign-symbol-address-as-integer "closure_tramp"))))) fdefn)) (defun initialize-static-fns () @@ -1398,7 +1396,9 @@ (defvar *cold-foreign-symbol-table*) (declaim (type hash-table *cold-foreign-symbol-table*)) -(defun load-foreign-symbol-table (filename) +;;; Read the sbcl.nm file to find the addresses for foreign-symbols in +;;; the C runtime. +(defun load-cold-foreign-symbol-table (filename) (with-open-file (file filename) (loop (let ((line (read-line file nil nil))) @@ -1446,40 +1446,15 @@ (setf (gethash name *cold-foreign-symbol-table*) value)))))) (values))) -;;; FIXME: the relation between #'lookup-foreign-symbol and -;;; #'lookup-maybe-prefix-foreign-symbol seems more than slightly -;;; illdefined - -(defun lookup-foreign-symbol (name) - #!+(or alpha x86) - (let ((prefixes - #!+linux #(;; FIXME: How many of these are actually - ;; needed? The first four are taken from rather - ;; disorganized CMU CL code, which could easily - ;; have had redundant values in it.. - "_" - "__" - "__libc_" - "ldso_stub__" - ;; ..and the fifth seems to match most - ;; actual symbols, at least in RedHat 6.2. - "") - #!+freebsd #("" "ldso_stub__") - #!+openbsd #("_"))) - (or (some (lambda (prefix) - (gethash (concatenate 'string prefix name) - *cold-foreign-symbol-table* - nil)) - prefixes) - *foreign-symbol-placeholder-value* - (progn - (format *error-output* "~&The foreign symbol table is:~%") - (maphash (lambda (k v) - (format *error-output* "~&~S = #X~8X~%" k v)) - *cold-foreign-symbol-table*) - (format *error-output* "~&The prefix table is: ~S~%" prefixes) - (error "The foreign symbol ~S is undefined." name)))) - #!-(or x86 alpha) (error "non-x86/alpha unsupported in SBCL (but see old CMU CL code)")) +(defun cold-foreign-symbol-address-as-integer (name) + (or (find-foreign-symbol-in-table name *cold-foreign-symbol-table*) + *foreign-symbol-placeholder-value* + (progn + (format *error-output* "~&The foreign symbol table is:~%") + (maphash (lambda (k v) + (format *error-output* "~&~S = #X~8X~%" k v)) + *cold-foreign-symbol-table*) + (error "The foreign symbol ~S is undefined." name)))) (defvar *cold-assembler-routines*) @@ -1565,10 +1540,10 @@ offset-within-code-object)) (gspace-byte-address (gspace-byte-address (descriptor-gspace code-object)))) - (ecase sb!c:*backend-fasl-file-implementation* - ;; See CMUCL source for other formerly-supported architectures - ;; (and note that you have to rewrite them to use vector-ref unstead - ;; of sap-ref) + (ecase +backend-fasl-file-implementation+ + ;; See CMU CL source for other formerly-supported architectures + ;; (and note that you have to rewrite them to use VECTOR-REF + ;; unstead of SAP-REF). (:alpha (ecase kind (:jmp-hint @@ -1654,12 +1629,16 @@ (when value (do-cold-fixup (second fixup) (third fixup) value (fourth fixup)))))) +;;; *COLD-FOREIGN-SYMBOL-TABLE* becomes *!INITIAL-FOREIGN-SYMBOLS* in +;;; the core. When the core is loaded, !LOADER-COLD-INIT uses this to +;;; create *STATIC-FOREIGN-SYMBOLS*, which the code in +;;; target-load.lisp refers to. (defun linkage-info-to-core () (let ((result *nil-descriptor*)) - (maphash #'(lambda (symbol value) - (cold-push (cold-cons (string-to-core symbol) - (number-to-core value)) - result)) + (maphash (lambda (symbol value) + (cold-push (cold-cons (string-to-core symbol) + (number-to-core value)) + result)) *cold-foreign-symbol-table*) (cold-set (cold-intern '*!initial-foreign-symbols*) result)) (let ((result *nil-descriptor*)) @@ -1671,9 +1650,12 @@ ;;;; general machinery for cold-loading FASL files -(defvar *cold-fop-functions* (replace (make-array 256) *fop-functions*) - #!+sb-doc - "FOP functions for cold loading") +;;; FOP functions for cold loading +(defvar *cold-fop-functions* + ;; We start out with a copy of the ordinary *FOP-FUNCTIONS*. The + ;; ones which aren't appropriate for cold load will be destructively + ;; modified. + (copy-seq *fop-functions*)) (defvar *normal-fop-functions*) @@ -1817,11 +1799,11 @@ ;;;; cold fops for loading symbols -;;; Load a symbol SIZE characters long from *FASL-FILE* and intern +;;; Load a symbol SIZE characters long from *FASL-INPUT-STREAM* and intern ;;; that symbol in PACKAGE. (defun cold-load-symbol (size package) (let ((string (make-string size))) - (read-string-as-bytes *fasl-file* string) + (read-string-as-bytes *fasl-input-stream* string) (cold-intern (intern string package) package))) (macrolet ((frob (name pname-len package-len) @@ -1847,7 +1829,7 @@ (fop-uninterned-small-symbol-save) (let* ((size (clone-arg)) (name (make-string size))) - (read-string-as-bytes *fasl-file* name) + (read-string-as-bytes *fasl-input-stream* name) (let ((symbol (allocate-symbol name))) (push-fop-table symbol)))) @@ -1904,7 +1886,7 @@ (fop-small-string) (let* ((len (clone-arg)) (string (make-string len))) - (read-string-as-bytes *fasl-file* string) + (read-string-as-bytes *fasl-input-stream* string) (string-to-core string))) (clone-cold-fop (fop-vector) @@ -1940,7 +1922,7 @@ (ceiling (* len sizebits) sb!vm:byte-bits)))) (read-sequence-or-die (descriptor-bytes result) - *fasl-file* + *fasl-input-stream* :start start :end end) result)) @@ -1955,7 +1937,7 @@ (ash sb!vm:vector-data-offset sb!vm:word-shift))) (end (+ start (* len sb!vm:word-bytes)))) (read-sequence-or-die (descriptor-bytes result) - *fasl-file* + *fasl-input-stream* :start start :end end) result)) @@ -2023,9 +2005,9 @@ #!+long-float (define-cold-fop (fop-long-float) - (ecase sb!c:*backend-fasl-file-implementation* - (:x86 ; 80 bit long-float format - (prepare-for-fast-read-byte *fasl-file* + (ecase +backend-fasl-file-implementation+ + (:x86 ; (which has 80-bit long-float format) + (prepare-for-fast-read-byte *fasl-input-stream* (let* ((des (allocate-unboxed-object *dynamic* sb!vm:word-bits (1- sb!vm:long-float-size) sb!vm:long-float-type)) @@ -2041,7 +2023,7 @@ ;; SBCL. #+nil (#.sb!c:sparc-fasl-file-implementation ; 128 bit long-float format - (prepare-for-fast-read-byte *fasl-file* + (prepare-for-fast-read-byte *fasl-input-stream* (let* ((des (allocate-unboxed-object *dynamic* sb!vm:word-bits (1- sb!vm:long-float-size) sb!vm:long-float-type)) @@ -2058,9 +2040,9 @@ #!+long-float (define-cold-fop (fop-complex-long-float) - (ecase sb!c:*backend-fasl-file-implementation* - (:x86 ; 80 bit long-float format - (prepare-for-fast-read-byte *fasl-file* + (ecase +backend-fasl-file-implementation+ + (:x86 ; (which has 80-bit long-float format) + (prepare-for-fast-read-byte *fasl-input-stream* (let* ((des (allocate-unboxed-object *dynamic* sb!vm:word-bits (1- sb!vm:complex-long-float-size) sb!vm:complex-long-float-type)) @@ -2093,7 +2075,7 @@ ;; This was supported in CMU CL, but isn't currently supported in SBCL. #+nil (#.sb!c:sparc-fasl-file-implementation ; 128 bit long-float format - (prepare-for-fast-read-byte *fasl-file* + (prepare-for-fast-read-byte *fasl-input-stream* (let* ((des (allocate-unboxed-object *dynamic* sb!vm:word-bits (1- sb!vm:complex-long-float-size) sb!vm:complex-long-float-type)) @@ -2163,7 +2145,7 @@ (make-descriptor 0 0 nil counter))) (defun finalize-load-time-value-noise () - (cold-set (cold-intern 'sb!impl::*!load-time-values*) + (cold-set (cold-intern '*!load-time-values*) (allocate-vector-object *dynamic* sb!vm:word-bits *load-time-value-counter* @@ -2243,14 +2225,11 @@ ;; Note: we round the number of constants up to ensure ;; that the code vector will be properly aligned. (round-up raw-header-n-words 2)) - (des (allocate-descriptor - ;; In the X86 with CGC, code can't be relocated, so - ;; we have to put it into static space. In all other - ;; configurations, code can go into dynamic space. - #!+(and x86 cgc) *static* ; KLUDGE: Why? -- WHN 19990907 - #!-(and x86 cgc) *dynamic* - (+ (ash header-n-words sb!vm:word-shift) code-size) - sb!vm:other-pointer-type))) + (des (allocate-cold-descriptor *dynamic* + (+ (ash header-n-words + sb!vm:word-shift) + code-size) + sb!vm:other-pointer-type))) (write-memory des (make-other-immediate-descriptor header-n-words sb!vm:code-header-type)) @@ -2272,7 +2251,7 @@ (ash header-n-words sb!vm:word-shift))) (end (+ start code-size))) (read-sequence-or-die (descriptor-bytes des) - *fasl-file* + *fasl-input-stream* :start start :end end) #!+sb-show @@ -2366,9 +2345,9 @@ (code-object (pop-stack)) (len (read-arg 1)) (sym (make-string len))) - (read-string-as-bytes *fasl-file* sym) + (read-string-as-bytes *fasl-input-stream* sym) (let ((offset (read-arg 4)) - (value (lookup-foreign-symbol sym))) + (value (cold-foreign-symbol-address-as-integer sym))) (do-cold-fixup code-object offset value kind)) code-object)) @@ -2378,10 +2357,11 @@ ;; Note: we round the number of constants up to ensure that ;; the code vector will be properly aligned. (round-up sb!vm:code-constants-offset 2)) - (des (allocate-descriptor *read-only* - (+ (ash header-n-words sb!vm:word-shift) - length) - sb!vm:other-pointer-type))) + (des (allocate-cold-descriptor *read-only* + (+ (ash header-n-words + sb!vm:word-shift) + length) + sb!vm:other-pointer-type))) (write-memory des (make-other-immediate-descriptor header-n-words sb!vm:code-header-type)) @@ -2397,7 +2377,7 @@ (ash header-n-words sb!vm:word-shift))) (end (+ start length))) (read-sequence-or-die (descriptor-bytes des) - *fasl-file* + *fasl-input-stream* :start start :end end)) des)) @@ -2442,7 +2422,7 @@ ;; writing beginning boilerplate (format t "/*~%") (dolist (line - '("This is a machine-generated file. Do not edit it by hand." + '("This is a machine-generated file. Please do not edit it by hand." "" "This file contains low-level information about the" "internals of a particular version and configuration" @@ -2457,6 +2437,15 @@ (format t "#ifndef _SBCL_H_~%#define _SBCL_H_~%") (terpri) + ;; propagating *SHEBANG-FEATURES* into C-level #define's + (dolist (shebang-feature-name (sort (mapcar #'symbol-name + sb-cold:*shebang-features*) + #'string<)) + (format t + "#define LISP_FEATURE_~A~%" + (substitute #\_ #\- shebang-feature-name))) + (terpri) + ;; writing miscellaneous constants (format t "#define SBCL_CORE_VERSION_INTEGER ~D~%" sbcl-core-version-integer) (format t @@ -2568,7 +2557,7 @@ ;; writing codes/strings for internal errors (format t "#define ERRORS { \\~%") - ;; FIXME: Is this just DO-VECTOR? + ;; FIXME: Is this just DOVECTOR? (let ((internal-errors sb!c:*backend-internal-errors*)) (dotimes (i (length internal-errors)) (format t " ~S, /*~D*/ \\~%" (cdr (aref internal-errors i)) i))) @@ -2772,10 +2761,6 @@ initially undefined function references:~2%") (write-long *data-page*) (multiple-value-bind (floor rem) (floor (gspace-byte-address gspace) sb!c:*backend-page-size*) - ;; FIXME: Define an INSIST macro which does like ASSERT, but - ;; less expensively (ERROR, not CERROR), and which reports - ;; "internal error" on failure. Use it here and elsewhere in the - ;; system. (aver (zerop rem)) (write-long floor)) (write-long pages) @@ -2898,7 +2883,7 @@ initially undefined function references:~2%") ;; Read symbol table, if any. (when symbol-table-file-name - (load-foreign-symbol-table symbol-table-file-name)) + (load-cold-foreign-symbol-table symbol-table-file-name)) ;; Now that we've successfully read our only input file (by ;; loading the symbol table, if any), it's a good time to ensure @@ -3015,11 +3000,17 @@ initially undefined function references:~2%") ;; Tell the target Lisp how much stuff we've allocated. (cold-set 'sb!vm:*read-only-space-free-pointer* - (allocate-descriptor *read-only* 0 sb!vm:even-fixnum-type)) + (allocate-cold-descriptor *read-only* + 0 + sb!vm:even-fixnum-type)) (cold-set 'sb!vm:*static-space-free-pointer* - (allocate-descriptor *static* 0 sb!vm:even-fixnum-type)) + (allocate-cold-descriptor *static* + 0 + sb!vm:even-fixnum-type)) (cold-set 'sb!vm:*initial-dynamic-space-free-pointer* - (allocate-descriptor *dynamic* 0 sb!vm:even-fixnum-type)) + (allocate-cold-descriptor *dynamic* + 0 + sb!vm:even-fixnum-type)) (/show "done setting free pointers") ;; Write results to files.