From f08ab22070d80da93db8ae09c4fb42e6846ae19b Mon Sep 17 00:00:00 2001 From: Douglas Katzman Date: Wed, 31 Aug 2016 03:04:09 -0400 Subject: [PATCH] Add code_header_words() accessor. It's merely an alias of HeaderValue for better abstraction. (And its implementation is subject to change). Also rename fixnum_word_value to code_instruction_words for symmetry. --- contrib/sb-introspect/introspect.lisp | 4 ++-- contrib/sb-sprof/sb-sprof.lisp | 2 +- package-data-list.lisp-expr | 4 ++-- src/code/debug-int.lisp | 10 +++++----- src/code/dyncount.lisp | 2 +- src/code/room.lisp | 5 ++++- src/code/target-misc.lisp | 2 +- src/compiler/target-disassem.lisp | 4 ++-- src/compiler/x86-64/target-insts.lisp | 4 +--- src/runtime/backtrace.c | 2 +- src/runtime/breakpoint.c | 4 ++-- src/runtime/gc-common.c | 12 ++++++------ src/runtime/gencgc.c | 12 ++++++------ src/runtime/interr.c | 2 +- src/runtime/purify.c | 5 ++++- src/runtime/runtime.h | 8 +++++++- tests/compiler-test-util.lisp | 20 ++++++++++---------- tests/compiler.impure.lisp | 2 +- 18 files changed, 57 insertions(+), 47 deletions(-) diff --git a/contrib/sb-introspect/introspect.lisp b/contrib/sb-introspect/introspect.lisp index c2d3617a6..02e0c20f6 100644 --- a/contrib/sb-introspect/introspect.lisp +++ b/contrib/sb-introspect/introspect.lisp @@ -117,7 +117,7 @@ FBOUNDP." "Call FN for each constant in CODE's constant pool." (check-type code sb-kernel:code-component) (loop for i from sb-vm:code-constants-offset below - (sb-kernel:get-header-data code) + (sb-kernel:code-header-words code) do (funcall fn (sb-kernel:code-header-ref code i)))) (declaim (inline map-allocated-code-components)) @@ -1010,7 +1010,7 @@ Experimental: interface subject to change." (call (sb-kernel:%code-entry-points object)) (call (sb-kernel:%code-debug-info object)) (loop for i from sb-vm:code-constants-offset - below (sb-kernel:get-header-data object) + below (sb-kernel:code-header-words object) do (call (sb-kernel:code-header-ref object i)))) (sb-kernel:fdefn (call (sb-kernel:fdefn-name object)) diff --git a/contrib/sb-sprof/sb-sprof.lisp b/contrib/sb-sprof/sb-sprof.lisp index 03a64832c..d46a25bd3 100644 --- a/contrib/sb-sprof/sb-sprof.lisp +++ b/contrib/sb-sprof/sb-sprof.lisp @@ -424,7 +424,7 @@ profiling, and :TIME for wallclock profiling.") (values nil (sap-int pc))))) (t (let* ((code (sb-di::component-from-component-ptr ptr)) - (code-header-len (* (sb-kernel:get-header-data code) + (code-header-len (* (sb-kernel:code-header-words code) sb-vm:n-word-bytes)) (pc-offset (- (sap-int pc) (- (sb-kernel:get-lisp-obj-address code) diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index 2f9f4e7df..08a777276 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -1616,8 +1616,8 @@ is a good idea, but see SB-SYS re. blurring of boundaries." "CHARPOS" "CHECK-FOR-CIRCULARITY" "CHECK-TYPE-ERROR" "CLOSED-FLAME" "CODE-COMPONENT" "CODE-COMPONENT-P" - "CODE-HEADER-REF" "CODE-HEADER-SET" "CODE-INSTRUCTIONS" - "CODE-N-UNBOXED-DATA-WORDS" + "CODE-HEADER-REF" "CODE-HEADER-SET" "CODE-HEADER-WORDS" + "CODE-INSTRUCTIONS" "CODE-N-UNBOXED-DATA-WORDS" "COERCE-SYMBOL-TO-FUN" "COERCE-TO-FUN" "COERCE-TO-LEXENV" "COERCE-TO-LIST" "COERCE-TO-VALUES" "COERCE-TO-VECTOR" diff --git a/src/code/debug-int.lisp b/src/code/debug-int.lisp index 6bdd89a38..4007067a5 100644 --- a/src/code/debug-int.lisp +++ b/src/code/debug-int.lisp @@ -545,7 +545,7 @@ (let ((component-ptr (component-ptr-from-pc pc))) (unless (sap= component-ptr (int-sap #x0)) (let* ((code (component-from-component-ptr component-ptr)) - (code-header-len (* (get-header-data code) sb!vm:n-word-bytes)) + (code-header-len (* (code-header-words code) sb!vm:n-word-bytes)) (pc-offset (- (sap-int pc) (- (get-lisp-obj-address code) sb!vm:other-pointer-lowtag) @@ -878,7 +878,7 @@ #!+x86-64 "alloc_tramp")) (return (values :undefined-function 0 context)) (return (values code 0 context)))) - (let* ((code-header-len (* (get-header-data code) + (let* ((code-header-len (* (code-header-words code) sb!vm:n-word-bytes)) (pc-offset (- (sap-int (sb!vm:context-pc context)) @@ -913,7 +913,7 @@ (/noshow0 "got CODE") (when (symbolp code) (return (values code 0 scp))) - (let* ((code-header-len (* (get-header-data code) + (let* ((code-header-len (* (code-header-words code) sb!vm:n-word-bytes)) (pc-offset (- (sap-int (sb!vm:context-pc scp)) @@ -1111,7 +1111,7 @@ register." (- (sap-int ra) (- (get-lisp-obj-address component) sb!vm:other-pointer-lowtag) - (* (get-header-data component) sb!vm:n-word-bytes)))) + (* (code-header-words component) sb!vm:n-word-bytes)))) (push (cons #!-(or x86 x86-64) (stack-ref catch sb!vm:catch-block-tag-slot) #!+(or x86 x86-64) @@ -1330,7 +1330,7 @@ register." ;; -- WHN 20000120 (debug-fun-from-pc component (* (- (fun-word-offset simple-fun) - (get-header-data component)) + (code-header-words component)) sb!vm:n-word-bytes)))))) ;;; Return the kind of the function, which is one of :OPTIONAL, diff --git a/src/code/dyncount.lisp b/src/code/dyncount.lisp index 738891b75..15375d0fd 100644 --- a/src/code/dyncount.lisp +++ b/src/code/dyncount.lisp @@ -216,7 +216,7 @@ comments from CMU CL: (declare (type function function)) (let* ((function (%primitive closure-fun function)) (component (sb!di::fun-code-header function))) - (do ((end (get-header-data component)) + (do ((end (code-header-words component)) (i sb!vm:code-constants-offset (1+ i))) ((= end i)) (let ((constant (code-header-ref component i))) diff --git a/src/code/room.lisp b/src/code/room.lisp index fe5e356a0..f0d7e6290 100644 --- a/src/code/room.lisp +++ b/src/code/room.lisp @@ -738,6 +738,9 @@ #!+stack-grows-downward-not-upward (sap+ sp n-word-bytes) #!-stack-grows-downward-not-upward (sap+ sp (- n-word-bytes)))))) +(declaim (inline code-header-words)) +(defun code-header-words (code) (get-header-data code)) + (defun map-referencing-objects (fun space object) (declare (type spaces space) #!-sb-fluid (inline map-allocated-objects)) @@ -761,7 +764,7 @@ (return t)))) (maybe-call fun obj))) (code-component - (let ((length (get-header-data obj))) + (let ((length (code-header-words obj))) (do ((i code-constants-offset (1+ i))) ((= i length)) (when (eq (code-header-ref obj i) object) diff --git a/src/code/target-misc.lisp b/src/code/target-misc.lisp index 652dcab7e..c319d24af 100644 --- a/src/code/target-misc.lisp +++ b/src/code/target-misc.lisp @@ -221,7 +221,7 @@ ;; and the first simple-fun. (let ((f (%code-entry-points code-obj))) (or (and f - (let ((from (get-header-data code-obj)) + (let ((from (code-header-words code-obj)) (to (ash (with-pinned-objects (f) (sap-ref-word (int-sap (get-lisp-obj-address f)) (- sb!vm:fun-pointer-lowtag))) diff --git a/src/compiler/target-disassem.lisp b/src/compiler/target-disassem.lisp index 2fb38f55b..4a3447ba4 100644 --- a/src/compiler/target-disassem.lisp +++ b/src/compiler/target-disassem.lisp @@ -1088,7 +1088,7 @@ :unboxed-data-range (and code (let ((n-words (sb!kernel:code-n-unboxed-data-words code)) - (start (sb!kernel:get-header-data code))) + (start (sb!kernel:code-header-words code))) (and (plusp n-words) (cons (* sb!vm:n-word-bytes start) (* sb!vm:n-word-bytes (+ start n-words))))))))) @@ -1795,7 +1795,7 @@ ;; computation and the comparison below. But we're already in WITHOUT-GCING ;; in MAP-SEGMENT-INSTRUCTIONS, so, who cares, I guess? (sb!sys:without-gcing - (let* ((n-header-bytes (* (sb!kernel:get-header-data code) sb!vm:n-word-bytes)) + (let* ((n-header-bytes (* (sb!kernel:code-header-words code) sb!vm:n-word-bytes)) (header-addr (- (sb!kernel:get-lisp-obj-address code) sb!vm:other-pointer-lowtag)) (code-start (+ header-addr n-header-bytes))) diff --git a/src/compiler/x86-64/target-insts.lisp b/src/compiler/x86-64/target-insts.lisp index 4baad9d2f..65454236f 100644 --- a/src/compiler/x86-64/target-insts.lisp +++ b/src/compiler/x86-64/target-insts.lisp @@ -253,9 +253,7 @@ (seg-code (dstate-segment dstate))) ;; Try to reverse-engineer which thread-local binding this is (let* ((code (seg-code (dstate-segment dstate))) - (header-n-words - (ash (sap-ref-word (int-sap (get-lisp-obj-address code)) - (- other-pointer-lowtag)) -8)) + (header-n-words (code-header-words code)) (tls-index (ash disp (- n-fixnum-tag-bits)))) (loop for word-num from code-constants-offset below header-n-words for obj = (code-header-ref code word-num) diff --git a/src/runtime/backtrace.c b/src/runtime/backtrace.c index e34bd9a37..dacc6d04b 100644 --- a/src/runtime/backtrace.c +++ b/src/runtime/backtrace.c @@ -54,7 +54,7 @@ sbcl_putwc(wchar_t c, FILE *file) struct compiled_debug_fun * debug_function_from_pc (struct code* code, void *pc) { - uword_t code_header_len = sizeof(lispobj) * HeaderValue(code->header); + uword_t code_header_len = sizeof(lispobj) * code_header_words(code->header); uword_t offset = (uword_t) pc - (uword_t) code - code_header_len; struct compiled_debug_fun *df; diff --git a/src/runtime/breakpoint.c b/src/runtime/breakpoint.c index 2b635ad27..2d3e0c240 100644 --- a/src/runtime/breakpoint.c +++ b/src/runtime/breakpoint.c @@ -44,7 +44,7 @@ static void *compute_pc(lispobj code_obj, int pc_offset) struct code *code; code = (struct code *)native_pointer(code_obj); - return (void *)((char *)code + HeaderValue(code->header)*sizeof(lispobj) + return (void *)((char *)code + code_header_words(code->header)*sizeof(lispobj) + pc_offset); } @@ -116,7 +116,7 @@ static long compute_offset(os_context_t *context, lispobj code) #endif code_start = (uword_t)codeptr - + HeaderValue(codeptr->header)*sizeof(lispobj); + + code_header_words(codeptr->header)*sizeof(lispobj); if (pc < code_start) return 0; else { diff --git a/src/runtime/gc-common.c b/src/runtime/gc-common.c index 1a8f465c6..428e5fac9 100644 --- a/src/runtime/gc-common.c +++ b/src/runtime/gc-common.c @@ -232,8 +232,8 @@ trans_code(struct code *code) /* prepare to transport the code vector */ l_code = (lispobj) LOW_WORD(code) | OTHER_POINTER_LOWTAG; - ncode_words = fixnum_word_value(code->code_size); - nheader_words = HeaderValue(code->header); + ncode_words = code_instruction_words(code->code_size); + nheader_words = code_header_words(code->header); nwords = ncode_words + nheader_words; nwords = CEILING(nwords, 2); @@ -315,8 +315,8 @@ scav_code_header(lispobj *where, lispobj object) struct simple_fun *function_ptr; /* untagged pointer to entry point */ code = (struct code *) where; - n_code_words = fixnum_word_value(code->code_size); - n_header_words = HeaderValue(object); + n_code_words = code_instruction_words(code->code_size); + n_header_words = code_header_words(object); n_words = n_code_words + n_header_words; n_words = CEILING(n_words, 2); @@ -360,8 +360,8 @@ size_code_header(lispobj *where) code = (struct code *) where; - ncode_words = fixnum_word_value(code->code_size); - nheader_words = HeaderValue(code->header); + ncode_words = code_instruction_words(code->code_size); + nheader_words = code_header_words(code->header); nwords = ncode_words + nheader_words; nwords = CEILING(nwords, 2); diff --git a/src/runtime/gencgc.c b/src/runtime/gencgc.c index 9936335c4..9e0c67f69 100644 --- a/src/runtime/gencgc.c +++ b/src/runtime/gencgc.c @@ -1668,8 +1668,8 @@ sniff_code_object(struct code *code, os_vm_size_t displacement) FSHOW((stderr, "/sniffing code: %p, %lu\n", code, displacement)); - ncode_words = fixnum_word_value(code->code_size); - nheader_words = HeaderValue(*(lispobj *)code); + ncode_words = code_instruction_words(code->code_size); + nheader_words = code_header_words(*(lispobj *)code); nwords = ncode_words + nheader_words; constants_start_addr = code_addr + 5*N_WORD_BYTES; @@ -1841,8 +1841,8 @@ gencgc_apply_code_fixups(struct code *old_code, struct code *new_code) lispobj fixups = NIL; struct vector *fixups_vector; - ncode_words = fixnum_word_value(new_code->code_size); - nheader_words = HeaderValue(*(lispobj *)new_code); + ncode_words = code_instruction_words(new_code->code_size); + nheader_words = code_header_words(*(lispobj *)new_code); nwords = ncode_words + nheader_words; /* FSHOW((stderr, "/compiled code object at %x: header words = %d, code words = %d\n", @@ -3203,8 +3203,8 @@ verify_space(lispobj *start, size_t words) start)); } - ncode_words = fixnum_word_value(code->code_size); - nheader_words = HeaderValue(object); + ncode_words = code_instruction_words(code->code_size); + nheader_words = code_header_words(object); nwords = ncode_words + nheader_words; nwords = CEILING(nwords, 2); /* Scavenge the boxed section of the code data block */ diff --git a/src/runtime/interr.c b/src/runtime/interr.c index f5ba998f7..da720c380 100644 --- a/src/runtime/interr.c +++ b/src/runtime/interr.c @@ -158,7 +158,7 @@ void print_constant(os_context_t *context, int offset) { lispobj code = find_code(context); if (code != NIL) { struct code *codeptr = (struct code *)native_pointer(code); - int length = HeaderValue(codeptr->header); + int length = code_header_words(codeptr->header); putchar('\t'); if (offset >= length) { printf("Constant offset %d out of bounds for the code object of length %d.\n", diff --git a/src/runtime/purify.c b/src/runtime/purify.c index 256e91be6..4f9b729bd 100644 --- a/src/runtime/purify.c +++ b/src/runtime/purify.c @@ -281,7 +281,10 @@ ptrans_code(lispobj thing) lispobj func, result; code = (struct code *)native_pointer(thing); - nwords = CEILING(HeaderValue(code->header) + fixnum_word_value(code->code_size), + // FIXME: CEILING is likely redundant. + // - The header word count can't be odd + // - The instruction word count is rounded by the accessor macro + nwords = CEILING(HeaderValue(code->header) + code_instruction_words(code->code_size), 2); new = (struct code *)newspace_alloc(nwords,1); /* constant */ diff --git a/src/runtime/runtime.h b/src/runtime/runtime.h index 49b0bfb84..68c1a9647 100644 --- a/src/runtime/runtime.h +++ b/src/runtime/runtime.h @@ -351,8 +351,14 @@ fixnum_value(lispobj n) return n >> N_FIXNUM_TAG_BITS; } +static inline uword_t +code_header_words(lispobj header) // given header = code->header +{ + return HeaderValue(header); +} + static inline sword_t -fixnum_word_value(lispobj n) +code_instruction_words(lispobj n) // given n = code->code_size { /* Convert bytes into words, double-word aligned. */ sword_t x = ((n >> N_FIXNUM_TAG_BITS) + LOWTAG_MASK) & ~LOWTAG_MASK; diff --git a/tests/compiler-test-util.lisp b/tests/compiler-test-util.lisp index 45185bf33..49efe4aa6 100644 --- a/tests/compiler-test-util.lisp +++ b/tests/compiler-test-util.lisp @@ -37,15 +37,15 @@ (defun find-value-cell-values (fun) (let ((code (fun-code-header (%fun-fun fun)))) - (loop for i from sb-vm::code-constants-offset below (get-header-data code) + (loop for i from sb-vm:code-constants-offset below (code-header-words code) for c = (code-header-ref code i) - when (= sb-vm::value-cell-header-widetag (widetag-of c)) + when (= sb-vm:value-cell-header-widetag (widetag-of c)) collect (sb-vm::value-cell-ref c)))) (defun find-named-callees (fun &key (type t) (name nil namep)) (let ((code (sb-kernel:fun-code-header (sb-kernel:%fun-fun fun)))) - (loop for i from sb-vm::code-constants-offset below (sb-kernel:get-header-data code) - for c = (sb-kernel:code-header-ref code i) + (loop for i from sb-vm:code-constants-offset below (code-header-words code) + for c = (code-header-ref code i) when (and (typep c 'sb-impl::fdefn) (let ((fun (sb-impl::fdefn-fun c))) (and (typep fun type) @@ -54,16 +54,16 @@ collect (sb-impl::fdefn-fun c)))) (defun find-anonymous-callees (fun &key (type 'function)) - (let ((code (sb-kernel:fun-code-header (sb-kernel:%fun-fun fun)))) - (loop for i from sb-vm::code-constants-offset below (sb-kernel:get-header-data code) - for fun = (sb-kernel:code-header-ref code i) + (let ((code (sb-kernel:fun-code-header (%fun-fun fun)))) + (loop for i from sb-vm:code-constants-offset below (code-header-words code) + for fun = (code-header-ref code i) when (typep fun type) collect fun))) (defun find-code-constants (fun &key (type t)) - (let ((code (sb-kernel:fun-code-header (sb-kernel:%fun-fun fun)))) - (loop for i from sb-vm::code-constants-offset below (sb-kernel:get-header-data code) - for c = (sb-kernel:code-header-ref code i) + (let ((code (sb-kernel:fun-code-header (%fun-fun fun)))) + (loop for i from sb-vm:code-constants-offset below (code-header-words code) + for c = (code-header-ref code i) when (typep c type) collect c))) diff --git a/tests/compiler.impure.lisp b/tests/compiler.impure.lisp index 371d451ed..049931168 100644 --- a/tests/compiler.impure.lisp +++ b/tests/compiler.impure.lisp @@ -2126,7 +2126,7 @@ (defun count-code-constants (x f) (let ((code (sb-kernel:fun-code-header f)) (n 0)) - (loop for i from sb-vm::code-constants-offset below (sb-kernel:get-header-data code) + (loop for i from sb-vm:code-constants-offset below (sb-kernel:code-header-words code) do (when (equal x (sb-kernel:code-header-ref code i)) (incf n))) n)) -- 2.11.4.GIT