common-lisp/sbcl.sbcl
1
0
Fork 0
mirror of git://git.code.sf.net/p/sbcl/sbcl synced 2026-09-10 07:26:40 -04:00
Code Issues Actions 8 Packages Projects Releases Wiki Activity

Remove descriptor constants from simple-fun objects

Browse source 
Store NAME, ARGLIST, FORM/DOC/XREFS, and TYPE in the boxed portion of
the code header. This is easier on C code that scans lisp code for pointers.

I plan to implement a slightly quicker way of determining where each
simple-fun has its boxed words stored by robbing some bits from the fun->code
backpointer, but that's just an optimization and not critical to this change.
This commit is contained in:
Douglas Katzman 2019-05-28 17:06:20 -04:00
parent 82deb09173
commit bf8dc6dc4d
27 changed files with 131 additions and 166 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
package-data-list.lisp-expr
View file

@ -1110,6 +1110,8 @@ possibly temporarily, because it might be used internally."
"UPDATE-SYMBOL-INFO"
"WITH-GLOBALDB-NAME"
"%BOUNDP"
"FUN-SRC" "FUN-SRC-DOC" "FUN-SRC-FORM" "FUN-SRC-XREFS"
"MAKE-FUN-SRC"
;; Calling a list of hook functions, plus error handling.
"CALL-HOOKS"

10
src/code/fop.lisp
View file

@ -557,14 +557,8 @@
(setf (code-header-ref code index) value)
(values)))
(define-fop 20 :not-host (fop-fun-entry ((:operands fun-index)
code-object name arglist type info))
(let ((fun (%code-entry-point code-object fun-index)))
(setf (%simple-fun-name fun) name)
(setf (%simple-fun-arglist fun) arglist)
(setf (%simple-fun-type fun) type)
(apply #'set-simple-fun-info fun info)
fun))
(define-fop 20 :not-host (fop-fun-entry ((:operands fun-index) code-object))
(%code-entry-point code-object fun-index))
;;;; assemblerish fops

6
src/code/room.lisp
View file

@ -1155,11 +1155,7 @@ We could try a few things to mitigate this:
:extend
(dotimes (i (code-n-entries this))
(let ((f (%code-entry-point this i)))
(when (or (eq f that)
(eq (%simple-fun-name f) that)
(eq (%simple-fun-arglist f) that)
(eq (%%simple-fun-type f) that)
(eq (%simple-fun-info f) that))
(when (eq f that)
(go win)))))
(t
:extend

4
src/code/save.lisp
View file

@ -449,10 +449,10 @@ sb-c::
(dotimes (i (sb-kernel:code-n-entries obj))
(let* ((fun (sb-kernel:%code-entry-point obj i))
(arglist (%simple-fun-arglist fun))
(type (sb-vm::%%simple-fun-type fun)))
(type (sb-impl::%%simple-fun-type fun)))
(setf (%simple-fun-arglist fun)
(ensure-gethash arglist arglist-hash arglist))
(setf (sb-kernel:%simple-fun-type fun)
(setf (sb-impl::%%simple-fun-type fun)
(ensure-gethash type type-hash type)))))
(#.sb-vm:instance-widetag
(typecase obj

49
src/code/simple-fun.lisp
View file

@ -244,9 +244,27 @@
(setf (%simple-fun-arglist (%fun-fun function)) new-value)))
new-value)
;;; Extract the type from the function header FUNC.
(defun %simple-fun-type (func)
(let ((internal-type (sb-vm::%%simple-fun-type func)))
(macrolet ((access-slot (index)
`(code-header-ref
(fun-code-header fun)
(+ sb-vm:code-constants-offset ,index (* 4 (%simple-fun-index fun)))))
(def (accessor index)
`(progn
(defun (setf ,accessor) (newval fun)
(setf (access-slot ,index) newval))
(defun ,accessor (fun)
(access-slot ,index)))))
;; possible FIXME for the backends which treat the assembly trampolines
;; as tagged functions (with fun-pointer-lowtag) - we might need to ensure
;; that the code object reserves space for 4 NILs just in case a simple-fun
;; accessor is called on it. I'm not entirely sure whether that's necessary.
(def %simple-fun-name sb-vm:simple-fun-name-slot)
(def %simple-fun-arglist sb-vm:simple-fun-arglist-slot)
(def %simple-fun-info sb-vm:simple-fun-info-slot)
(def %%simple-fun-type sb-vm:simple-fun-type-slot))
(defun %simple-fun-type (fun)
(let ((internal-type (%%simple-fun-type fun)))
;; For backward-compatibility we expand SFUNCTION -> FUNCTION.
(if (and (listp internal-type) (eq (car internal-type) 'sfunction))
(sb-ext:typexpand-1 internal-type)
@ -260,30 +278,8 @@
(interpreted-function (sb-interpreter:%fun-type function))
(t (%simple-fun-type (%fun-fun function)))))
;;; A FUN-SRC structure appears in %SIMPLE-FUN-INFO of any function for
;;; which a source form is retained via COMPILE or LOAD and for which it was
;;; required to store all three of these pieces of data.
(defstruct (fun-src (:constructor make-fun-src (form doc xrefs))
(:predicate nil)
(:copier nil))
form
doc
xrefs)
;;; Assign %SIMPLE-FUN-INFO given the three possible things that
;;; we stash there.
(defun set-simple-fun-info (fun form doc xrefs)
(setf (%simple-fun-info fun)
(if form
;; If form starts with a string, we can't store it by itself
;; because it's confusable with (CONS STRING *)
;; Lambda expressions start with LAMBDA, obviously,
;; so this really shouldn't happen. Just being defensive here.
(if (or doc xrefs (typep form '(cons string)))
(make-fun-src form doc xrefs)
form)
(if (and doc xrefs)
(cons doc xrefs)
(or doc xrefs)))))
(setf (%simple-fun-info fun) (sb-c::pack-simple-fun-info form doc xrefs)))
;;; Define readers for parts of SIMPLE-FUN-INFO, which holds:
;;; - a string if documentation only,
@ -328,6 +324,7 @@
((cons string)
(if doc (rplaca info doc) (cdr info)))
(fun-src
;; FIXME: should we consider these objects immutable?
(setf (fun-src-doc info) doc)
info)
((cons (not string))

5
src/code/stubs.lisp
View file

@ -60,11 +60,6 @@
(def sb-c:safe-fdefn-fun)
(def fun-subtype)
(def simple-fun-p)
(def %simple-fun-arglist)
(def (setf %simple-fun-arglist) (new-value func))
(def %simple-fun-name)
(def (setf %simple-fun-name) (new-value func))
(def %simple-fun-info)
(def closurep)
(def %closure-fun)
(def %closure-index-ref (closure index))

24
src/compiler/dump.lisp
View file

@ -947,6 +947,8 @@
(dump-object (sb-c::constant-value entry) fasl-output))
(cons
(ecase (car entry)
(:constant ; anything that has not been wrapped in a #<CONSTANT>
(dump-object (cdr entry) fasl-output))
(:entry
(let* ((info (sb-c::leaf-info (cdr entry)))
(handle (gethash info
@ -1041,15 +1043,27 @@
(entries (sb-c::ir2-component-entries 2comp))
(nfuns (length entries))
(code-handle
(dump-code-object component code-segment code-length fixups file))
;; fill in the placeholder elements of constants
;; with the NAME, ARGLIST, TYPE, INFO slots of each simple-fun.
(let ((constants (sb-c::ir2-component-constants 2comp))
(wordindex (+ sb-vm:code-constants-offset (* 4 nfuns))))
(dolist (entry entries)
;; Process in reverse order of ENTRIES.
;; See also MAKE-CORE-COMPONENT which does the same thing.
(decf wordindex 4)
(setf (aref constants (+ wordindex 0))
`(:constant . ,(sb-c::entry-info-name entry))
(aref constants (+ wordindex 1))
`(:constant . ,(sb-c::entry-info-arguments entry))
(aref constants (+ wordindex 2))
`(:constant . ,(sb-c::entry-info-form/doc/xrefs entry))
(aref constants (+ wordindex 3))
`(:constant . ,(sb-c::entry-info-type entry))))
(dump-code-object component code-segment code-length fixups file)))
(fun-index nfuns))
(dolist (entry entries)
(dump-push code-handle file)
(dump-object (sb-c::entry-info-name entry) file)
(dump-object (sb-c::entry-info-arguments entry) file)
(dump-object (sb-c::entry-info-type entry) file)
(dump-object (sb-c::entry-info-form/doc/xrefs entry) file)
(dump-fop 'fop-fun-entry file (decf fun-index))
(let ((entry-handle (dump-pop file)))
(setf (gethash entry (fasl-output-entry-table file)) entry-handle)

22
src/compiler/entry.lisp
View file

@ -51,6 +51,25 @@
(or (not (lexenv-parent lexenv))
(null-lexenv-p (lexenv-parent lexenv))))))
;;; Return the value to place in %SIMPLE-FUN-INFO given any or all of
;;; the three possible things that can be stashed there:
;;; - string = just a docstring
;;; - simple-vector = just xrefs
;;; - cons = either both of the above, or just a lambda expression
;;; - fun-src = any other combination of the three pieces of data
(defun pack-simple-fun-info (form doc xrefs)
(if form
;; If form starts with a string, we can't store it by itself
;; because it's confusable with (CONS STRING *)
;; Lambda expressions start with LAMBDA, obviously,
;; so this really shouldn't happen. Just being defensive here.
(if (or doc xrefs (typep form '(cons string)))
(make-fun-src form doc xrefs)
form)
(if (and doc xrefs)
(cons doc xrefs)
(or doc xrefs))))
;;; Initialize INFO structure to correspond to the XEP LAMBDA FUN.
(defun compute-entry-info (fun info)
(declare (type clambda fun) (type entry-info info))
@ -67,7 +86,8 @@
(doc (functional-documentation internal-fun))
(xrefs (pack-xref-data (functional-xref internal-fun))))
(setf (entry-info-form/doc/xrefs info)
(list (if (fasl-output-p *compile-object*)
(pack-simple-fun-info
(if (fasl-output-p *compile-object*)
(and (policy bind (= store-source-form 3))
;; Downgrade the error to a warning if this was signaled
;; by SB-PCL::DONT-KNOW-HOW-TO-DUMP.

20
src/compiler/generic/genesis.lisp
View file

@ -2662,9 +2662,8 @@ core and return a descriptor to it."
(make-descriptor (logior fun sb-vm:fun-pointer-lowtag)))))
(define-cold-fop (fop-fun-entry (fun-index))
(binding* (((info type arglist name code-object)
(values (pop-stack) (pop-stack) (pop-stack) (pop-stack) (pop-stack)))
(fn (compute-fun code-object fun-index)))
(let* ((code-object (pop-stack))
(fn (compute-fun code-object fun-index)))
#+compact-instance-header
(write-wordindexed/raw
fn 0 (logior (descriptor-bits (cold-symbol-value 'sb-vm:function-layout))
@ -2676,20 +2675,6 @@ core and return a descriptor to it."
(ash sb-vm:simple-fun-code-offset sb-vm:word-shift)))
#-(or x86 x86-64) ; store a pointer back to the function itself in 'self'
(write-wordindexed fn sb-vm:simple-fun-self-slot fn)
(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)
;; Emulate SET-SIMPLE-FUN-INFO
(aver (cold-null (cold-car info))) ; no source form
(let* ((doc (cold-car (cold-cdr info)))
(docp (not (cold-null doc)))
(xref (cold-car (cold-cdr (cold-cdr info))))
(xrefp (not (cold-null xref))))
(write-wordindexed fn sb-vm:simple-fun-info-slot
(cond ((and docp xrefp) (cold-cons doc xref))
(docp doc)
(xrefp xref)
(t *nil-descriptor*))))
fn))
(define-cold-fop (fop-assembler-code)
@ -3769,6 +3754,7 @@ III. initially undefined function references (alphabetically):
(#.sb-vm:fun-pointer-lowtag
(if strictp
(error "Can't map cold-fun -> warm-fun")
#+nil ; FIXME: not done, but only needed for debugging genesis
(let ((name (read-wordindexed x sb-vm:simple-fun-name-slot)))
`(function ,(recurse name)))))
(#.sb-vm:other-pointer-lowtag

31
src/compiler/generic/objdef.lisp
View file

@ -239,28 +239,6 @@ during backtrace.
;; of x86, or the Lisp function to jump to, for everybody else.
(self :set-known ()
:set-trans (setf %simple-fun-self))
(name :ref-known (flushable)
:ref-trans %simple-fun-name
:set-known ()
:set-trans (setf %simple-fun-name))
(arglist :type list
:ref-known (flushable)
:ref-trans %simple-fun-arglist
:set-known ()
:set-trans (setf %simple-fun-arglist))
(type :ref-known (flushable)
;; %%SIMPLE-FUN-TYPE is used only by %SIMPLE-FUN-TYPE.
;; Nobody should care that %SIMPLE-FUN-TYPE isn't open-coded.
:ref-trans %%simple-fun-type
:set-known ()
:set-trans (setf %simple-fun-type))
;; NIL for empty, STRING for a docstring, SIMPLE-VECTOR for XREFS, and (CONS
;; STRING SIMPLE-VECTOR) for both.
(info :init :null
:ref-trans %simple-fun-info
:ref-known (flushable)
:set-trans (setf %simple-fun-info)
:set-known ())
;; FIXME: This is a poor name for this slot, because SIMPLE-FUN-CODE
;; ought to mean the code object in which this simple-fun is contained.
;; Probably a better name would be INSTS, especially as SIMPLE-FUN-CODE-OFFSET
@ -269,6 +247,15 @@ during backtrace.
;; This will be quite disastrous to clean up and not make mistakes about it.
(code :rest-p t :c-type "unsigned char"))
;;; These are word numbers beyond the base of the simple-fun's metadata
;;; in the code header. The mnemonic device here is that the first 3 slots
;;; essentially comprise the function-lambda-expression,
;;; and the last is a derived piece of information.
(defconstant simple-fun-name-slot 0)
(defconstant simple-fun-arglist-slot 1)
(defconstant simple-fun-info-slot 2)
(defconstant simple-fun-type-slot 3)
#-(or x86 x86-64)
(define-primitive-object (return-pc :lowtag other-pointer-lowtag :widetag t)
(return-point :c-type "unsigned char" :rest-p t))

12
src/compiler/generic/target-core.lisp
View file

@ -200,12 +200,12 @@
(let* ((entries (ir2-component-entries 2comp))
(fun-index (length entries)))
(dolist (entry-info entries)
(let ((fun (%code-entry-point code-obj (decf fun-index))))
(setf (%simple-fun-name fun) (entry-info-name entry-info))
(setf (%simple-fun-arglist fun) (entry-info-arguments entry-info))
(setf (%simple-fun-type fun) (entry-info-type entry-info))
(apply #'set-simple-fun-info fun
(entry-info-form/doc/xrefs entry-info))
(let ((fun (%code-entry-point code-obj (decf fun-index)))
(w (+ sb-vm:code-constants-offset (* 4 fun-index))))
(setf (code-header-ref code-obj (+ w 0)) (entry-info-name entry-info)
(code-header-ref code-obj (+ w 1)) (entry-info-arguments entry-info)
(code-header-ref code-obj (+ w 2)) (entry-info-form/doc/xrefs entry-info)
(code-header-ref code-obj (+ w 3)) (entry-info-type entry-info))
(note-fun entry-info fun object))))
(push debug-info (core-object-debug-info object))

8
src/compiler/generic/utils.lisp
View file

@ -149,9 +149,11 @@
;;; additional noise in the code object header.
(defun select-component-format (component)
(declare (type component component))
(dotimes (i code-constants-offset)
(vector-push-extend nil
(ir2-component-constants (component-info component))))
(let* ((2comp (component-info component))
(n-entries (length (sb-c::ir2-component-entries 2comp)))
(consts (ir2-component-constants 2comp)))
(dotimes (i (+ code-constants-offset (* 4 n-entries)))
(vector-push-extend nil consts)))
(values))
(defun error-call (vop error-code &rest values)

7
src/compiler/generic/vm-ir2tran.lisp
View file

@ -435,10 +435,5 @@
(and (listp fun-name)
(eq (car fun-name) 'setf)
(member (cadr fun-name)
'(%code-debug-info
%code-fixups
%simple-fun-name
%simple-fun-arglist
%simple-fun-type
%simple-fun-info))
'(%code-debug-info %code-fixups))
t))

10
src/compiler/target-disassem.lisp
View file

@ -383,14 +383,13 @@
;;; Print the fun-header (entry-point) pseudo-instruction at the
;;; current location in DSTATE to STREAM.
(defun fun-header-hook (stream dstate)
(defun fun-header-hook (fun-index stream dstate)
(declare (type (or null stream) stream)
(type disassem-state dstate))
(unless (null stream)
(let* ((seg (dstate-segment dstate))
(code (seg-code seg))
(woffs (ash (segment-offs-to-code-offs (dstate-cur-offs dstate) seg)
(- sb-vm:word-shift))) ; bytes -> words
(woffs (+ sb-vm:code-constants-offset (* fun-index 4)))
(name (code-header-ref code (+ woffs sb-vm:simple-fun-name-slot)))
(args (code-header-ref code (+ woffs sb-vm:simple-fun-arglist-slot)))
(type (code-header-ref code (+ woffs sb-vm:simple-fun-type-slot))))
@ -1049,7 +1048,10 @@
(incf (dstate-next-offs dstate) offset))
:offset 0) ; at 0 bytes into this seg, skip OFFSET bytes
(seg-hooks segment)))
(push (make-offs-hook :offset offset :fun #'fun-header-hook)
(push (make-offs-hook
:offset offset
:fun (let ((i i)) ; capture the _current_ I, not the final value
(lambda (stream dstate) (fun-header-hook i stream dstate))))
(seg-hooks segment))))))
;;; A SAP-MAKER is a no-argument function that returns a SAP.

14
src/compiler/vop.lisp
View file

@ -364,6 +364,17 @@
#+sb-dyncount
(dyncount-info nil :type (or null dyncount-info)))
;;; A FUN-SRC structure appears in %SIMPLE-FUN-INFO of any function for
;;; which a source form is retained via COMPILE or LOAD and for which it was
;;; required to store all three of these pieces of data.
(defstruct (fun-src (:constructor make-fun-src (form doc xrefs))
(:predicate nil)
(:copier nil))
form
doc
xrefs)
(!set-load-form-method fun-src (:target))
;;; An ENTRY-INFO condenses all the information that the dumper needs
;;; to create each XEP's function entry data structure. ENTRY-INFO
;;; structures are sometimes created before they are initialized,
@ -387,7 +398,8 @@
;; of this function
(type 'function :type (or list (member function)))
;; source form and/or docstring and/or xref information for the XEP
(form/doc/xrefs nil :type (or null simple-vector string cons)))
;; Refer to PACK-SIMPLE-FUN-INFO for more detail.
(form/doc/xrefs nil :type (or null simple-vector string cons fun-src)))
;;; An IR2-PHYSENV is used to annotate non-LET LAMBDAs with their
;;; passing locations. It is stored in the PHYSENV-INFO.

2
src/runtime/backtrace.c
View file

@ -217,7 +217,7 @@ print_entry_points (struct code *code, FILE *f)
fprintf(f, "%p: bogus function entry", fun);
return;
}
print_entry_name(fun->name, f);
print_entry_name(code->constants[CODE_SLOTS_PER_SIMPLE_FUN*index], f);
if ((index + 1) < n_funs) fprintf(f, ", ");
});
}

7
src/runtime/cheneygc.c
View file

@ -463,12 +463,5 @@ sword_t scav_code_header(lispobj *where, lispobj header)
/* Scavenge the boxed section of the code data block. */
scavenge(where + 2, n_header_words - 2);
/* Scavenge the boxed section of each function object in the
* code data block. */
for_each_simple_fun(i, function_ptr, code, 1, {
scavenge(SIMPLE_FUN_SCAV_START(function_ptr),
SIMPLE_FUN_SCAV_NWORDS(function_ptr));
})
return code_total_nwords(code);
}

7
src/runtime/coalesce.c
View file

@ -152,7 +152,7 @@ static uword_t coalesce_range(lispobj* where, lispobj* limit, uword_t arg)
{
struct hopscotch_table* ht = (struct hopscotch_table*)arg;
lispobj layout, bitmap, *next;
sword_t nwords, i, j;
sword_t nwords, i;
for ( ; where < limit ; where = next ) {
lispobj header = *where;
@ -176,11 +176,6 @@ static uword_t coalesce_range(lispobj* where, lispobj* limit, uword_t arg)
coalesce_obj(where+i, ht);
continue;
case CODE_HEADER_WIDETAG:
for_each_simple_fun(i, fun, (struct code*)where, 0, {
lispobj* fun_slots = SIMPLE_FUN_SCAV_START(fun);
for (j=0; j<SIMPLE_FUN_SCAV_NWORDS(fun); ++j)
coalesce_obj(fun_slots+j, ht);
})
nwords = code_header_words((struct code*)where);
break;
default:

3
src/runtime/code.h
View file

@ -76,6 +76,9 @@ static inline int code_text_size(struct code* c) {
return N_WORD_BYTES * code_total_nwords(c) - code_boxed_len(c) - code_trailer_len(c);
}
// How many elements in 'code->constants[]' are taken by each simple-fun
#define CODE_SLOTS_PER_SIMPLE_FUN 4
// Iterate over the native pointers to each function in 'code_var'
// offsets are stored as the number of bytes into the instructions
// portion of the code object at which the simple-fun object resides.

3
src/runtime/coreparse.c
View file

@ -562,9 +562,8 @@ static void relocate_space(uword_t start, lispobj* end, struct heap_adjust* adj)
#if FUN_SELF_FIXNUM_TAGGED
if (f->self != (lispobj)f->code)
FIXUP(f->self = (lispobj)f->code, &f->self);
adjust_pointers(SIMPLE_FUN_SCAV_START(f), SIMPLE_FUN_SCAV_NWORDS(f), adj);
#else
adjust_pointers(&f->self, (lispobj*)f->code - &f->self, adj);
adjust_pointers(&f->self, 1, adj);
#endif
});
{

4
src/runtime/fullcgc.c
View file

@ -325,10 +325,6 @@ static void trace_object(lispobj* where)
break; // scan slots normally
#endif
case CODE_HEADER_WIDETAG:
for_each_simple_fun(i, fun, (struct code*)where, 0, {
gc_mark_range(SIMPLE_FUN_SCAV_START(fun),
SIMPLE_FUN_SCAV_NWORDS(fun));
})
scan_to = code_header_words((struct code*)where);
break;
case FDEFN_WIDETAG:

3
src/runtime/gc-internal.h
View file

@ -96,9 +96,6 @@ do { \
| SIMPLE_VECTOR_WIDETAG)); \
v->header ^= subtype_VectorWeakVisited << N_WIDETAG_BITS
#define SIMPLE_FUN_SCAV_START(fun_ptr) &fun_ptr->name
#define SIMPLE_FUN_SCAV_NWORDS(fun_ptr) ((lispobj*)fun_ptr->code - &fun_ptr->name)
/* values for the *_alloc_* parameters, also see the commentary for
* struct page in gencgc-internal.h. These constants are used in gc-common,
* so they can't easily be made gencgc-only */

15
src/runtime/gencgc.c
View file

@ -2785,9 +2785,6 @@ verify_range(lispobj *where, sword_t nwords, struct verify_state *state)
function_layout((lispobj*)fheaderp);
gc_assert(!layout || layout == LAYOUT_OF_FUNCTION);
#endif
verify_range(SIMPLE_FUN_SCAV_START(fheaderp),
SIMPLE_FUN_SCAV_NWORDS(fheaderp),
state);
});
#if CODE_PAGES_USE_SOFT_PROTECTION
generation_index_t my_gen = gen_of((lispobj)where);
@ -4379,12 +4376,6 @@ sword_t scav_code_header(lispobj *object, lispobj header)
sword_t n_header_words = code_header_words((struct code *)object);
scavenge(object + 2, n_header_words - 2);
/* Scavenge the boxed section of each function object in the
* code data block. */
for_each_simple_fun(i, function_ptr, (struct code *)object, 1, {
scavenge(SIMPLE_FUN_SCAV_START(function_ptr),
SIMPLE_FUN_SCAV_NWORDS(function_ptr));
})
/* If my_gen is other than newspace, then scan for old->young
* pointers. If my_gen is newspace, there can be no such pointers
* because newspace is the lowest numbered generation post-GC
@ -4394,12 +4385,6 @@ sword_t scav_code_header(lispobj *object, lispobj header)
for (where= object + 2; where < end; ++where)
if (is_lisp_pointer(ptr = *where) && obj_gen_lessp(ptr, my_gen))
goto done;
for_each_simple_fun(i, function_ptr, (struct code *)object, 0, {
end = (lispobj*)function_ptr->code;
for (where = SIMPLE_FUN_SCAV_START(function_ptr); where < end; ++where)
if (is_lisp_pointer(ptr = *where) && obj_gen_lessp(ptr, my_gen))
goto done;
})
}
CLEAR_WRITTEN_FLAG(object);
} else {

5
src/runtime/immobile-space.c
View file

@ -1685,11 +1685,6 @@ static void fixup_space(lispobj* where, size_t n_words)
// Fixup the constant pool.
code = (struct code*)where;
adjust_words(where+2, code_header_words(code)-2, 0);
// Fixup all embedded simple-funs
for_each_simple_fun(i, f, code, 1, {
f->self = adjust_fun_entrypoint(f->self);
adjust_words(SIMPLE_FUN_SCAV_START(f), SIMPLE_FUN_SCAV_NWORDS(f), 0);
});
apply_absolute_fixups(code->fixups, code);
break;
case CLOSURE_WIDETAG:

5
src/runtime/purify.c
View file

@ -272,6 +272,9 @@ ptrans_code(lispobj thing)
pscav_later(&new->debug_info, 1);
/* Scavenge the constants. */
// TODO: some of the constants - ones corresponding to former slots
// of simple-fun objects - are supposed to be pscav_later()'ed.
// It's not a terribly important consideration.
pscav(new->constants,
code_header_words(new) - (offsetof(struct code, constants) >> WORD_SHIFT),
1);
@ -280,7 +283,7 @@ ptrans_code(lispobj thing)
for_each_simple_fun(i, func, new, 1, {
gc_assert(!dynamic_pointer_p((lispobj)func));
pscav(&func->self, 1, 1);
pscav_later(&func->name, 4);
// pscav_later(&func->name, 4);
})
return result;

14
src/runtime/traceroot.c
View file

@ -130,7 +130,7 @@ static lispobj canonical_obj(lispobj obj)
static int find_ref(lispobj* source, lispobj target)
{
lispobj layout, bitmap;
int scan_limit, i, j;
int scan_limit, i;
lispobj header = *source;
if (is_cons_half(header)) {
@ -162,10 +162,6 @@ static int find_ref(lispobj* source, lispobj target)
break;
#endif
case CODE_HEADER_WIDETAG:
for_each_simple_fun(i, function_ptr, (struct code*)source, 0, {
int wordindex = &function_ptr->name - source;
for (j=0; j<4; ++j) check_ptr(wordindex+j, source[wordindex+j]);
})
scan_limit = code_header_words((struct code*)source);
break;
case FDEFN_WIDETAG:
@ -602,11 +598,13 @@ static int trace1(lispobj object,
struct simple_fun* fun = simple_fun_from_pc(thread_pc);
if (fun) {
fprintf(file, "fun=%p", (void*)make_lispobj(fun, FUN_POINTER_LOWTAG));
#if 0 // TODO: implement simple_fun_name()
if (is_lisp_pointer(fun->name) &&
widetag_of(native_pointer(fun->name)) == SYMBOL_WIDETAG) {
fprintf(file, "=");
show_lstring(VECTOR(SYMBOL(fun->name)->name), 0, file);
}
#endif
} else if (thread_pc)
fprintf(file, "pc=%p", thread_pc);
}
@ -695,7 +693,7 @@ static uword_t build_refs(lispobj* where, lispobj* end,
struct scan_state* ss)
{
lispobj layout, bitmap;
sword_t nwords, scan_limit, i, j;
sword_t nwords, scan_limit, i;
uword_t n_objects = 0, n_scanned_words = 0,
n_immediates = 0, n_pointers = 0;
@ -733,10 +731,6 @@ static uword_t build_refs(lispobj* where, lispobj* end,
break;
#endif
case CODE_HEADER_WIDETAG:
for_each_simple_fun(i, function_ptr, (struct code*)where, 0, {
int wordindex = &function_ptr->name - where;
for (j=0; j<4; ++j) check_ptr(where[wordindex+j]);
})
scan_limit = code_header_words((struct code*)where);
break;
case FDEFN_WIDETAG:

5
tests/compiler-test-util.lisp
View file

@ -52,9 +52,12 @@
when (typep fun type)
collect fun)))
;;; Return a subset of the code constants for FUN's code but excluding
;;; constants that are present on behalf of %SIMPLE-FUN-foo accessors.
(defun find-code-constants (fun &key (type t))
(let ((code (fun-code-header (%fun-fun fun))))
(loop for i from sb-vm:code-constants-offset below (code-header-words code)
(loop for i from (+ sb-vm:code-constants-offset (* (code-n-entries code) 4))
below (code-header-words code)
for c = (code-header-ref code i)
for value = (if (= (widetag-of c) sb-vm:value-cell-widetag)
(value-cell-ref c)