X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fgeneric%2Fgenesis.lisp;h=eb1ab4a61804f0cc09432a7cd1fe04cc6ebc73ec;hb=dcf8b8ccc1e15a5c1c6aba00204b7d3a81827acc;hp=ef6968bca15ea921c84ce8966bdd6c420034613f;hpb=670d28c10c178142146f6916c5fa0967732f3a8f;p=sbcl.git diff --git a/src/compiler/generic/genesis.lisp b/src/compiler/generic/genesis.lisp index ef6968b..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) @@ -2726,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) @@ -2749,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)) @@ -2766,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 @@ -2796,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)