X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fgeneric%2Fgenesis.lisp;h=ce9e73f003b78a0223d6537bf8cca4a0a51dbda5;hb=7c07a6f965c51828d8f452b47e0620d8e6cf2959;hp=a552178278921e33d5226f8b22ad3bb4849019eb;hpb=aa2dc9529460ea0d9c99998dc87283fc1a43e808;p=sbcl.git diff --git a/src/compiler/generic/genesis.lisp b/src/compiler/generic/genesis.lisp index a552178..ce9e73f 100644 --- a/src/compiler/generic/genesis.lisp +++ b/src/compiler/generic/genesis.lisp @@ -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 maybe-gc) (frob internal-error) (frob sb!di::handle-breakpoint) - (frob sb!di::handle-function-end-breakpoint) - (frob 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)) @@ -1240,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. @@ -1343,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) @@ -1365,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 () @@ -1396,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))) @@ -1444,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*) @@ -1652,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*)) @@ -1669,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*) @@ -2241,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)) @@ -2366,7 +2347,7 @@ (sym (make-string len))) (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)) @@ -2376,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)) @@ -2440,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" @@ -2455,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 @@ -2566,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))) @@ -2892,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 @@ -3009,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.