((fboundp x)
(%describe-function (fdefinition x) s :function x)))
- ;; TO DO: Print out other stuff from the INFO database:
+ ;; FIXME: Print out other stuff from the INFO database:
;; * Does it name a type or class?
;; * Is it a structure accessor? (This is important since those are
;; magical in some ways, e.g. blasting the structure if you
(t
exp))))
-;;; not needed in new from-scratch cross-compilation procedure -- WHN 19990714
-#|
-;;; Dummy stubs for SB!EVAL:INTERNAL-EVAL and SB!EVAL:MAKE-INTERPRETED-FUNCTION
-;;; in case the compiler isn't loaded yet.
-(defun sb!eval:internal-eval (x)
- (error "attempt to evaluation a complex expression:~% ~S~@
- This expression must be compiled, but the compiler is not loaded."
- x))
-(defun sb!eval:make-interpreted-function (x)
- (error "EVAL called on #'(lambda (x) ...) when the compiler isn't loaded:~
- ~% ~S~%"
- x))
-|#
-
+;;; Given a function, return three values:
+;;; 1] A lambda expression that could be used to define the function,
+;;; or NIL if the definition isn't available.
+;;; 2] NIL if the function was definitely defined in a null lexical
+;;; environment, and T otherwise.
+;;; 3] Some object that \"names\" the function. Although this is
+;;; allowed to be any object, CMU CL always returns a valid
+;;; function name or a string.
+;;;
;;; If interpreted, use the interpreter interface. Otherwise, see
;;; whether it was compiled with COMPILE. If that fails, check for an
;;; inline expansion.
(defun function-lambda-expression (fun)
- #!+sb-doc
- "Given a function, return three values:
- 1] A lambda expression that could be used to define the function, or NIL if
- the definition isn't available.
- 2] NIL if the function was definitely defined in a null lexical environment,
- and T otherwise.
- 3] Some object that \"names\" the function. Although this is allowed to be
- any object, CMU CL always returns a valid function name or a string."
(declare (type function fun))
(if (sb!eval:interpreted-function-p fun)
(sb!eval:interpreted-function-lambda-expression fun)
(def!method print-object ((obj entry-node-info) str)
(print-unreadable-object (obj str :type t)))
-;;; Some compiler funny functions have definitions, so the interpreter can
-;;; call them. These require special action to coordinate the interpreter,
-;;; system call stack, and the environment. The annotation prepass marks the
-;;; references to these as :unused, so the interpreter doesn't try to fetch
-;;; functions through these undefined symbols.
+;;; Some compiler funny functions have definitions, so the interpreter
+;;; can call them. These require special action to coordinate the
+;;; interpreter, system call stack, and the environment. The
+;;; annotation prepass marks the references to these as :UNUSED, so
+;;; the interpreter doesn't try to fetch functions through these
+;;; undefined symbols.
(defconstant undefined-funny-funs
'(%special-bind %special-unbind %more-arg-context %unknown-values %catch
%unwind-protect %catch-breakup %unwind-protect-breakup
%lexical-exit-breakup %continue-unwind %nlx-entry))
-;;; Some kinds of functions are only passed as arguments to funny functions,
-;;; and are never actually evaluated at run time.
+;;; Some kinds of functions are only passed as arguments to funny
+;;; functions, and are never actually evaluated at run time.
(defconstant non-closed-function-kinds '(:cleanup :escape))
;;; This annotates continuations, lambda-vars, and lambdas. For each
-;;; continuation, we cache how its destination uses its value. This only buys
-;;; efficiency when the code executes more than once, but the overhead of this
-;;; part of the prepass for code executed only once should be negligible.
+;;; continuation, we cache how its destination uses its value. This
+;;; only buys efficiency when the code executes more than once, but
+;;; the overhead of this part of the prepass for code executed only
+;;; once should be negligible.
;;;
-;;; As a special case to aid interpreting local function calls, we sometimes
-;;; note the continuation as :unused. This occurs when there is a local call,
-;;; and there is no actual function object to call; we mark the continuation as
-;;; :unused since there is nothing to push on the interpreter's stack.
-;;; Normally we would see a reference to a function that we would push on the
-;;; stack to later pop and apply to the arguments on the stack. To determine
-;;; when we have a local call with no real function object, we look at the node
-;;; to see whether it is a reference with a destination that is a :local
-;;; combination whose function is the reference node's continuation.
+;;; As a special case to aid interpreting local function calls, we
+;;; sometimes note the continuation as :unused. This occurs when there
+;;; is a local call, and there is no actual function object to call;
+;;; we mark the continuation as :unused since there is nothing to push
+;;; on the interpreter's stack. Normally we would see a reference to a
+;;; function that we would push on the stack to later pop and apply to
+;;; the arguments on the stack. To determine when we have a local call
+;;; with no real function object, we look at the node to see whether
+;;; it is a reference with a destination that is a :local combination
+;;; whose function is the reference node's continuation.
;;;
-;;; After checking for virtual local calls, we check for funny functions the
-;;; compiler refers to for calling to note certain operations. These functions
-;;; are undefined, and if the interpreter tried to reference the function cells
-;;; of these symbols, it would get an error. We mark the continuations
-;;; delivering the values of these references as :unused, so the reference
-;;; never takes place.
+;;; After checking for virtual local calls, we check for funny
+;;; functions the compiler refers to for calling to note certain
+;;; operations. These functions are undefined, and if the interpreter
+;;; tried to reference the function cells of these symbols, it would
+;;; get an error. We mark the continuations delivering the values of
+;;; these references as :unused, so the reference never takes place.
;;;
-;;; For each lambda-var, including a lambda's vars and its let's vars, we note
-;;; the stack offset used to access and store that variable. Then we note the
-;;; lambda with the total number of variables, so we know how big its stack
-;;; frame is. Also in the lambda's info is the number of its arguments that it
-;;; actually references; the interpreter never pushes or pops an unreferenced
-;;; argument, so we can't just use LENGTH on LAMBDA-VARS to know how many args
-;;; the caller passed.
+;;; For each lambda-var, including a LAMBDA's vars and its LET's vars,
+;;; we note the stack offset used to access and store that variable.
+;;; Then we note the lambda with the total number of variables, so we
+;;; know how big its stack frame is. Also in the lambda's info is the
+;;; number of its arguments that it actually references; the
+;;; interpreter never pushes or pops an unreferenced argument, so we
+;;; can't just use LENGTH on LAMBDA-VARS to know how many args the
+;;; caller passed.
;;;
-;;; For each entry node in a lambda, we associate in the lambda-eval-info the
-;;; entry node with a stack offset. Evaluation code stores the frame pointer
-;;; in this slot upon processing the entry node to aid stack cleanup and
-;;; correct frame manipulation when processing exit nodes.
+;;; For each entry node in a lambda, we associate in the
+;;; lambda-eval-info the entry node with a stack offset. Evaluation
+;;; code stores the frame pointer in this slot upon processing the
+;;; entry node to aid stack cleanup and correct frame manipulation
+;;; when processing exit nodes.
(defun annotate-component-for-eval (component)
(do-blocks (b component)
(do-nodes (node cont b)
((:catch :unwind-protect)
(return :blow-it-off))))))))
-;;; Sometime consider annotations to exclude processing of exit nodes when
-;;; we want to do a tail-p thing.
+;;; Sometime consider annotations to exclude processing of exit nodes
+;;; when we want to do a tail-p thing.
\f
;;;; defining funny functions for interpreter
(:copier nil))
;; name of this class
(name nil :type keyword :read-only t)
- ;; List of Type-Info structures for each type in this class.
+ ;; list of Type-Info structures for each type in this class
(types () :type list))
;;; a map from type numbers to TYPE-INFO objects. There is one type
(declare (ignore standard))
(make-wired-tn (primitive-type-or-lose 'system-area-pointer)
sap-stack-sc-number return-pc-save-offset))
-;;; If standard is true, then use the standard (full call) location,
+;;; If STANDARD is true, then use the standard (full call) location,
;;; otherwise use any legal location.
;;;
;;; No problems.
# defaults which might be overridden or modified by values in the
# Config file
-#
-#
CFLAGS = -g -Wall -O3
ASFLAGS = $(CFLAGS)
DEPEND_FLAGS =
\f
/* scavenging */
-#define DIRECT_SCAV 0
-
static void
scavenge(lispobj *start, u32 nwords)
{
(unsigned long) start, (unsigned long) object, type);
#endif
-#if DIRECT_SCAV
- words_scavenged = (scavtab[type])(start, object);
-#else
if (Pointerp(object)) {
/* It be a pointer. */
if (from_space_p(object)) {
words_scavenged = (scavtab[type])(start, object);
}
-#endif
+
start += words_scavenged;
nwords -= words_scavenged;
}
static lispobj trans_function_header(lispobj object);
static lispobj trans_boxed(lispobj object);
-
-#if DIRECT_SCAV
-static int
-scav_function_pointer(lispobj *where, lispobj object)
-{
- gc_assert(Pointerp(object));
-
- if (from_space_p(object)) {
- lispobj first, *first_pointer;
-
- /* object is a pointer into from space. check to see */
- /* if it has been forwarded */
- first_pointer = (lispobj *) PTR(object);
- first = *first_pointer;
-
- if (!(Pointerp(first) && new_space_p(first))) {
- int type;
- lispobj copy;
-
- /* must transport object -- object may point */
- /* to either a function header, a closure */
- /* function header, or to a closure header. */
-
- type = TypeOf(first);
- switch (type) {
- case type_FunctionHeader:
- case type_ClosureFunctionHeader:
- copy = trans_function_header(object);
- break;
- default:
- copy = trans_boxed(object);
- break;
- }
-
- first = *first_pointer = copy;
- }
-
- gc_assert(Pointerp(first));
- gc_assert(!from_space_p(first));
-
- *where = first;
- }
- return 1;
-}
-#else
static int
scav_function_pointer(lispobj *where, lispobj object)
{
*where = first;
return 1;
}
-#endif
static struct code *
trans_code(struct code *code)
\f
/* instances */
-#if DIRECT_SCAV
-static int
-scav_instance_pointer(lispobj *where, lispobj object)
-{
- if (from_space_p(object)) {
- lispobj first, *first_pointer;
-
- /* object is a pointer into from space. check to see */
- /* if it has been forwarded */
- first_pointer = (lispobj *) PTR(object);
- first = *first_pointer;
-
- if (!(Pointerp(first) && new_space_p(first)))
- first = *first_pointer = trans_boxed(object);
- *where = first;
- }
- return 1;
-}
-#else
static int
scav_instance_pointer(lispobj *where, lispobj object)
{
*where = *first_pointer = trans_boxed(object);
return 1;
}
-#endif
\f
/* lists and conses */
static lispobj trans_list(lispobj object);
-#if DIRECT_SCAV
-static int
-scav_list_pointer(lispobj *where, lispobj object)
-{
- gc_assert(Pointerp(object));
-
- if (from_space_p(object)) {
- lispobj first, *first_pointer;
-
- /* object is a pointer into from space. check to see */
- /* if it has been forwarded */
- first_pointer = (lispobj *) PTR(object);
- first = *first_pointer;
-
- if (!(Pointerp(first) && new_space_p(first)))
- first = *first_pointer = trans_list(object);
-
- gc_assert(Pointerp(first));
- gc_assert(!from_space_p(first));
-
- *where = first;
- }
- return 1;
-}
-#else
static int
scav_list_pointer(lispobj *where, lispobj object)
{
*where = first;
return 1;
}
-#endif
static lispobj
trans_list(lispobj object)
\f
/* scavenging and transporting other pointers */
-#if DIRECT_SCAV
-static int
-scav_other_pointer(lispobj *where, lispobj object)
-{
- gc_assert(Pointerp(object));
-
- if (from_space_p(object)) {
- lispobj first, *first_pointer;
-
- /* object is a pointer into from space. check to see */
- /* if it has been forwarded */
- first_pointer = (lispobj *) PTR(object);
- first = *first_pointer;
-
- if (!(Pointerp(first) && new_space_p(first)))
- first = *first_pointer =
- (transother[TypeOf(first)])(object);
-
- gc_assert(Pointerp(first));
- gc_assert(!from_space_p(first));
-
- *where = first;
- }
- return 1;
-}
-#else
static int
scav_other_pointer(lispobj *where, lispobj object)
{
*where = first;
return 1;
}
-#endif
\f
/* immediate, boxed, and unboxed objects */
* scavenging
*/
-#define DIRECT_SCAV 0
-
-/* FIXME: Most calls end up going to a little trouble to compute an
- * 'nwords' value. The system might be a little simpler if this
- * function used an 'end' parameter instead. */
+/* FIXME: Most calls end up going to some trouble to compute an
+ * 'n_words' value for this function. The system might be a little
+ * simpler if this function used an 'end' parameter instead. */
static void
-scavenge(lispobj *start, long nwords)
+scavenge(lispobj *start, long n_words)
{
- while (nwords > 0) {
- lispobj object;
-#if DIRECT_SCAV
- int type;
-#endif
- int words_scavenged;
+ lispobj *end = start + n_words;
+ lispobj *object_ptr;
+ int n_words_scavenged;
+
+ for (object_ptr = start;
+ object_ptr < end;
+ object_ptr += n_words_scavenged) {
- object = *start;
+ lispobj object = *object_ptr;
-/* FSHOW((stderr, "Scavenge: %p, %ld\n", start, nwords)); */
-
gc_assert(object != 0x01); /* not a forwarding pointer */
-#if DIRECT_SCAV
- type = TypeOf(object);
- words_scavenged = (scavtab[type])(start, object);
-#else
if (Pointerp(object)) {
- /* It's a pointer. */
if (from_space_p(object)) {
- /* It currently points to old space. Check for a forwarding
- * pointer. */
+ /* It currently points to old space. Check for a
+ * forwarding pointer. */
lispobj *ptr = (lispobj *)PTR(object);
lispobj first_word = *ptr;
-
if (first_word == 0x01) {
/* Yes, there's a forwarding pointer. */
- *start = ptr[1];
- words_scavenged = 1;
- }
- else
+ *object_ptr = ptr[1];
+ n_words_scavenged = 1;
+ } else {
/* Scavenge that pointer. */
- words_scavenged = (scavtab[TypeOf(object)])(start, object);
+ n_words_scavenged =
+ (scavtab[TypeOf(object)])(object_ptr, object);
+ }
} else {
- /* It points somewhere other than oldspace. Leave it alone. */
- words_scavenged = 1;
+ /* It points somewhere other than oldspace. Leave it
+ * alone. */
+ n_words_scavenged = 1;
}
+ } else if ((object & 3) == 0) {
+ /* It's a fixnum: really easy.. */
+ n_words_scavenged = 1;
} else {
- if ((object & 3) == 0) {
- /* It's a fixnum: really easy.. */
- words_scavenged = 1;
- } else {
- /* It's some sort of header object or another. */
- words_scavenged = (scavtab[TypeOf(object)])(start, object);
- }
+ /* It's some sort of header object or another. */
+ n_words_scavenged =
+ (scavtab[TypeOf(object)])(object_ptr, object);
}
-#endif
-
- start += words_scavenged;
- nwords -= words_scavenged;
}
- gc_assert(nwords == 0);
+ gc_assert(object_ptr == end);
}
-
\f
/*
* code and code-related objects
static lispobj trans_function_header(lispobj object);
static lispobj trans_boxed(lispobj object);
-#if DIRECT_SCAV
-static int
-scav_function_pointer(lispobj *where, lispobj object)
-{
- gc_assert(Pointerp(object));
-
- if (from_space_p(object)) {
- lispobj first, *first_pointer;
-
- /* object is a pointer into from space. Check to see whether
- * it has been forwarded. */
- first_pointer = (lispobj *) PTR(object);
- first = *first_pointer;
-
- if (first == 0x01) {
- /* Forwarded */
- *where = first_pointer[1];
- return 1;
- }
- else {
- int type;
- lispobj copy;
-
- /* must transport object -- object may point to either a
- * function header, a closure function header, or to a
- * closure header. */
-
- type = TypeOf(first);
- switch (type) {
- case type_FunctionHeader:
- case type_ClosureFunctionHeader:
- copy = trans_function_header(object);
- break;
- default:
- copy = trans_boxed(object);
- break;
- }
-
- if (copy != object) {
- /* Set forwarding pointer. */
- first_pointer[0] = 0x01;
- first_pointer[1] = copy;
- }
-
- first = copy;
- }
-
- gc_assert(Pointerp(first));
- gc_assert(!from_space_p(first));
-
- *where = first;
- }
- return 1;
-}
-#else
static int
scav_function_pointer(lispobj *where, lispobj object)
{
return 1;
}
-#endif
/* Scan a x86 compiled code object, looking for possible fixups that
* have been missed after a move.
scav_code_header(lispobj *where, lispobj object)
{
struct code *code;
- int nheader_words, ncode_words, nwords;
- lispobj fheaderl;
- struct function *fheaderp;
+ int n_header_words, n_code_words, n_words;
+ lispobj entry_point; /* tagged pointer to entry point */
+ struct function *function_ptr; /* untagged pointer to entry point */
code = (struct code *) where;
- ncode_words = fixnum_value(code->code_size);
- nheader_words = HeaderValue(object);
- nwords = ncode_words + nheader_words;
- nwords = CEILING(nwords, 2);
+ n_code_words = fixnum_value(code->code_size);
+ n_header_words = HeaderValue(object);
+ n_words = n_code_words + n_header_words;
+ n_words = CEILING(n_words, 2);
/* Scavenge the boxed section of the code data block. */
- scavenge(where + 1, nheader_words - 1);
+ scavenge(where + 1, n_header_words - 1);
/* Scavenge the boxed section of each function object in the */
/* code data block. */
- fheaderl = code->entry_points;
- while (fheaderl != NIL) {
- fheaderp = (struct function *) PTR(fheaderl);
- gc_assert(TypeOf(fheaderp->header) == type_FunctionHeader);
+ for (entry_point = code->entry_points;
+ entry_point != NIL;
+ entry_point = function_ptr->next) {
- scavenge(&fheaderp->name, 1);
- scavenge(&fheaderp->arglist, 1);
- scavenge(&fheaderp->type, 1);
-
- fheaderl = fheaderp->next;
+ gc_assert(Pointerp(entry_point));
+
+ function_ptr = (struct function *) PTR(entry_point);
+ gc_assert(TypeOf(function_ptr->header) == type_FunctionHeader);
+
+ scavenge(&function_ptr->name, 1);
+ scavenge(&function_ptr->arglist, 1);
+ scavenge(&function_ptr->type, 1);
}
- return nwords;
+ return n_words;
}
static lispobj
* instances
*/
-#if DIRECT_SCAV
-static int
-scav_instance_pointer(lispobj *where, lispobj object)
-{
- if (from_space_p(object)) {
- lispobj first, *first_pointer;
-
- /* Object is a pointer into from space. Check to see */
- /* whether it has been forwarded. */
- first_pointer = (lispobj *) PTR(object);
- first = *first_pointer;
-
- if (first == 0x01) {
- /* forwarded */
- first = first_pointer[1];
- } else {
- first = trans_boxed(object);
- gc_assert(first != object);
- /* Set forwarding pointer. */
- first_pointer[0] = 0x01;
- first_pointer[1] = first;
- }
- *where = first;
- }
- return 1;
-}
-#else
static int
scav_instance_pointer(lispobj *where, lispobj object)
{
return 1;
}
-#endif
\f
/*
* lists and conses
static lispobj trans_list(lispobj object);
-#if DIRECT_SCAV
-static int
-scav_list_pointer(lispobj *where, lispobj object)
-{
- /* KLUDGE: There's lots of cut-and-paste duplication between this
- * and scav_instance_pointer(..), scav_other_pointer(..), and
- * perhaps other functions too. -- WHN 20000620 */
-
- gc_assert(Pointerp(object));
-
- if (from_space_p(object)) {
- lispobj first, *first_pointer;
-
- /* Object is a pointer into from space. Check to see whether it has
- * been forwarded. */
- first_pointer = (lispobj *) PTR(object);
- first = *first_pointer;
-
- if (first == 0x01) {
- /* forwarded */
- first = first_pointer[1];
- } else {
- first = trans_list(object);
-
- /* Set forwarding pointer */
- first_pointer[0] = 0x01;
- first_pointer[1] = first;
- }
-
- gc_assert(Pointerp(first));
- gc_assert(!from_space_p(first));
- *where = first;
- }
- return 1;
-}
-#else
static int
scav_list_pointer(lispobj *where, lispobj object)
{
*where = first;
return 1;
}
-#endif
static lispobj
trans_list(lispobj object)
* scavenging and transporting other pointers
*/
-#if DIRECT_SCAV
-static int
-scav_other_pointer(lispobj *where, lispobj object)
-{
- gc_assert(Pointerp(object));
-
- if (from_space_p(object)) {
- lispobj first, *first_pointer;
-
- /* Object is a pointer into from space. Check to see */
- /* whether it has been forwarded. */
- first_pointer = (lispobj *) PTR(object);
- first = *first_pointer;
-
- if (first == 0x01) {
- /* Forwarded. */
- first = first_pointer[1];
- *where = first;
- } else {
- first = (transother[TypeOf(first)])(object);
-
- if (first != object) {
- /* Set forwarding pointer */
- first_pointer[0] = 0x01;
- first_pointer[1] = first;
- *where = first;
- }
- }
-
- gc_assert(Pointerp(first));
- gc_assert(!from_space_p(first));
- }
- return 1;
-}
-#else
static int
scav_other_pointer(lispobj *where, lispobj object)
{
return 1;
}
-#endif
-
\f
/*
* immediate, boxed, and unboxed objects
/* The scavenge will start at the first_object_offset of page i.
*
- * We need to find the full extent of this contiguous block in case
- * objects span pages.
+ * We need to find the full extent of this contiguous
+ * block in case objects span pages.
*
- * Now work forward until the end of this contiguous area is
- * found. A small area is preferred as there is a better chance
- * of its pages being write-protected. */
+ * Now work forward until the end of this contiguous area
+ * is found. A small area is preferred as there is a
+ * better chance of its pages being write-protected. */
for (last_page = i; ;last_page++) {
- /* Check whether this is the last page in this contiguous
- * block */
+ /* Check whether this is the last page in this
+ * contiguous block */
if ((page_table[last_page].bytes_used < 4096)
/* Or it is 4096 and is the last in the block */
|| (page_table[last_page+1].allocated != BOXED_PAGE)
break;
}
- /* Do a limited check for write_protected pages. If all pages
- * are write_protected then no need to scavenge. Except if the
- * pages are marked dont_move. */
+ /* Do a limited check for write-protected pages. If all
+ * pages are write-protected then no need to scavenge,
+ * except if the pages are marked dont_move. */
{
int j, all_wp = 1;
for (j = i; j <= last_page; j++)
all_wp = 0;
break;
}
-#if !SC_NS_GEN_CK
- if (all_wp == 0)
-#endif
- {
- int size;
-
- /* Calculate the size. */
- if (last_page == i)
- size = (page_table[last_page].bytes_used
- - page_table[i].first_object_offset)/4;
- else
- size = (page_table[last_page].bytes_used
- + (last_page-i)*4096
- - page_table[i].first_object_offset)/4;
-
- {
-#if SC_NS_GEN_CK
- int a1 = bytes_allocated;
-#endif
- /* FSHOW((stderr,
- "/scavenge(%x,%d)\n",
- page_address(i)
- + page_table[i].first_object_offset,
- size)); */
- new_areas_ignore_page = last_page;
+ if (!all_wp) {
+ int size;
- scavenge(page_address(i)+page_table[i].first_object_offset,size);
+ /* Calculate the size. */
+ if (last_page == i)
+ size = (page_table[last_page].bytes_used
+ - page_table[i].first_object_offset)/4;
+ else
+ size = (page_table[last_page].bytes_used
+ + (last_page-i)*4096
+ - page_table[i].first_object_offset)/4;
+
+ {
+ new_areas_ignore_page = last_page;
+
+ scavenge(page_address(i) +
+ page_table[i].first_object_offset,
+ size);
-#if SC_NS_GEN_CK
- /* Flush the alloc regions updating the tables. */
- gc_alloc_update_page_tables(0, &boxed_region);
- gc_alloc_update_page_tables(1, &unboxed_region);
-
- if ((all_wp != 0) && (a1 != bytes_allocated)) {
- FSHOW((stderr,
- "alloc'ed over %d to %d\n",
- i, last_page));
- FSHOW((stderr,
- "/page: bytes_used=%d first_object_offset=%d dont_move=%d wp=%d wpc=%d\n",
- page_table[i].bytes_used,
- page_table[i].first_object_offset,
- page_table[i].dont_move,
- page_table[i].write_protected,
- page_table[i].write_protected_cleared));
- }
-#endif
- }
}
+ }
}
i = last_page;
}
}
+ FSHOW((stderr,
+ "/done with one full scan of newspace generation %d\n",
+ generation));
}
/* Do a complete scavenge of the newspace generation. */
int i;
/* the new_areas array currently being written to by gc_alloc */
- struct new_area (*current_new_areas)[] = &new_areas_1;
+ struct new_area (*current_new_areas)[] = &new_areas_1;
int current_new_areas_index;
/* the new_areas created but the previous scavenge cycle */
- struct new_area (*previous_new_areas)[] = NULL;
+ struct new_area (*previous_new_areas)[] = NULL;
int previous_new_areas_index;
-#define SC_NS_GEN_CK 0
-#if SC_NS_GEN_CK
- /* Clear the write_protected_cleared flags on all pages. */
- for (i = 0; i < NUM_PAGES; i++)
- page_table[i].write_protected_cleared = 0;
-#endif
-
/* Flush the current regions updating the tables. */
gc_alloc_update_page_tables(0, &boxed_region);
gc_alloc_update_page_tables(1, &unboxed_region);
/* Check whether previous_new_areas had overflowed. */
if (previous_new_areas_index >= NUM_NEW_AREAS) {
+
/* New areas of objects allocated have been lost so need to do a
* full scan to be sure! If this becomes a problem try
* increasing NUM_NEW_AREAS. */
/* Flush the current regions updating the tables. */
gc_alloc_update_page_tables(0, &boxed_region);
gc_alloc_update_page_tables(1, &unboxed_region);
+
} else {
+
/* Work through previous_new_areas. */
for (i = 0; i < previous_new_areas_index; i++) {
+ /* FIXME: All these bare *4 and /4 should be something
+ * like BYTES_PER_WORD or WBYTES. */
int page = (*previous_new_areas)[i].page;
int offset = (*previous_new_areas)[i].offset;
int size = (*previous_new_areas)[i].size / 4;
gc_assert((*previous_new_areas)[i].size % 4 == 0);
-
- /* FIXME: All these bare *4 and /4 should be something
- * like BYTES_PER_WORD or WBYTES. */
- /*FSHOW((stderr,
- "/S page %d offset %d size %d\n",
- page, offset, size*4));*/
scavenge(page_address(page)+offset, size);
}
* catch GENCGC-related write-protect violations
*/
+void unhandled_sigmemoryfault(void);
+
/* Depending on which OS we're running under, different signals might
* be raised for a violation of write protection in the heap. This
* function factors out the common generational GC magic which needs
#define LATERBLOCKSIZE 1020
#define LATERMAXCOUNT 10
-static struct later {
+static struct
+later {
struct later *next;
union {
lispobj *ptr;
static int
maybe_can_move_p(lispobj thing)
{
- lispobj *thingp,header;
- if (dynamic_pointer_p(thing)) { /* in dynamic space */
- thingp = (lispobj*)PTR(thing);
- header = *thingp;
- if(Pointerp(header) && forwarding_pointer_p(header))
- return -1; /* must change it */
- if(LowtagOf(thing) == type_ListPointer)
- return type_ListPointer; /* can we check this somehow */
- else if (thing & 3) { /* not fixnum */
- int kind = TypeOf(header);
- /* printf(" %x %x",header,kind); */
- switch (kind) { /* something with a header */
- case type_Bignum:
- case type_SingleFloat:
- case type_DoubleFloat:
+ lispobj *thingp,header;
+ if (dynamic_pointer_p(thing)) { /* in dynamic space */
+ thingp = (lispobj*)PTR(thing);
+ header = *thingp;
+ if (Pointerp(header) && forwarding_pointer_p(header)) {
+ return -1; /* must change it */
+ } else if (LowtagOf(thing) == type_ListPointer) {
+ return type_ListPointer; /* can we check this somehow */
+ } else if (thing & 3) { /* not fixnum */
+ int kind = TypeOf(header);
+ /* printf(" %x %x",header,kind); */
+ switch (kind) { /* something with a header */
+ case type_Bignum:
+ case type_SingleFloat:
+ case type_DoubleFloat:
#ifdef type_LongFloat
- case type_LongFloat:
-#endif
- case type_Sap:
- case type_SimpleVector:
- case type_SimpleString:
- case type_SimpleBitVector:
- case type_SimpleArrayUnsignedByte2:
- case type_SimpleArrayUnsignedByte4:
- case type_SimpleArrayUnsignedByte8:
- case type_SimpleArrayUnsignedByte16:
- case type_SimpleArrayUnsignedByte32:
+ case type_LongFloat:
+#endif
+ case type_Sap:
+ case type_SimpleVector:
+ case type_SimpleString:
+ case type_SimpleBitVector:
+ case type_SimpleArrayUnsignedByte2:
+ case type_SimpleArrayUnsignedByte4:
+ case type_SimpleArrayUnsignedByte8:
+ case type_SimpleArrayUnsignedByte16:
+ case type_SimpleArrayUnsignedByte32:
#ifdef type_SimpleArraySignedByte8
- case type_SimpleArraySignedByte8:
+ case type_SimpleArraySignedByte8:
#endif
#ifdef type_SimpleArraySignedByte16
- case type_SimpleArraySignedByte16:
+ case type_SimpleArraySignedByte16:
#endif
#ifdef type_SimpleArraySignedByte30
- case type_SimpleArraySignedByte30:
+ case type_SimpleArraySignedByte30:
#endif
#ifdef type_SimpleArraySignedByte32
- case type_SimpleArraySignedByte32:
+ case type_SimpleArraySignedByte32:
#endif
- case type_SimpleArraySingleFloat:
- case type_SimpleArrayDoubleFloat:
+ case type_SimpleArraySingleFloat:
+ case type_SimpleArrayDoubleFloat:
#ifdef type_SimpleArrayLongFloat
- case type_SimpleArrayLongFloat:
+ case type_SimpleArrayLongFloat:
#endif
#ifdef type_SimpleArrayComplexSingleFloat
- case type_SimpleArrayComplexSingleFloat:
+ case type_SimpleArrayComplexSingleFloat:
#endif
#ifdef type_SimpleArrayComplexDoubleFloat
- case type_SimpleArrayComplexDoubleFloat:
+ case type_SimpleArrayComplexDoubleFloat:
#endif
#ifdef type_SimpleArrayComplexLongFloat
- case type_SimpleArrayComplexLongFloat:
-#endif
- case type_CodeHeader:
- case type_FunctionHeader:
- case type_ClosureFunctionHeader:
- case type_ReturnPcHeader:
- case type_ClosureHeader:
- case type_FuncallableInstanceHeader:
- case type_InstanceHeader:
- case type_ValueCellHeader:
- case type_ByteCodeFunction:
- case type_ByteCodeClosure:
- case type_WeakPointer:
- case type_Fdefn:
- return kind;
- break;
- default:
- return 0;
- }}}
- return 0;
+ case type_SimpleArrayComplexLongFloat:
+#endif
+ case type_CodeHeader:
+ case type_FunctionHeader:
+ case type_ClosureFunctionHeader:
+ case type_ReturnPcHeader:
+ case type_ClosureHeader:
+ case type_FuncallableInstanceHeader:
+ case type_InstanceHeader:
+ case type_ValueCellHeader:
+ case type_ByteCodeFunction:
+ case type_ByteCodeClosure:
+ case type_WeakPointer:
+ case type_Fdefn:
+ return kind;
+ break;
+ default:
+ return 0;
+ }
+ }
+ }
+ return 0;
}
static int pverbose=0;
static void
carefully_pscav_stack(lispobj*lowaddr, lispobj*base)
{
- lispobj*sp = lowaddr;
- while (sp < base)
- { int k;
- lispobj thing = *sp;
- if((unsigned)thing & 0x3) /* may be pointer */
- {
- /* need to check for valid float/double? */
- k = maybe_can_move_p(thing);
- if(PVERBOSE)printf("%8x %8x %d\n",sp, thing, k);
- if(k)
- pscav(sp, 1, 0);
+ lispobj *sp = lowaddr;
+ while (sp < base) {
+ int k;
+ lispobj thing = *sp;
+ if ((unsigned)thing & 0x3) { /* may be pointer */
+ /* need to check for valid float/double? */
+ k = maybe_can_move_p(thing);
+ if(PVERBOSE)printf("%8x %8x %d\n",sp, thing, k);
+ if(k)
+ pscav(sp, 1, 0);
}
- sp++;
+ sp++;
}
}
#endif
#ifdef GENCGC
/*
- * Enhanced x86/GENCGC stack scavenging by Douglas Crosher.
+ * enhanced x86/GENCGC stack scavenging by Douglas Crosher
*
* Scavenging the stack on the i386 is problematic due to conservative
* roots and raw return addresses. Here it is handled in two passes:
static int
valid_dynamic_space_pointer(lispobj *pointer, lispobj *start_addr)
{
- /* If it's not a return address then it needs to be a valid Lisp
- * pointer. */
- if (!Pointerp((lispobj)pointer))
- return 0;
+ /* If it's not a return address then it needs to be a valid Lisp
+ * pointer. */
+ if (!Pointerp((lispobj)pointer))
+ return 0;
- /* Check that the object pointed to is consistent with the pointer
- * low tag. */
- switch (LowtagOf((lispobj)pointer)) {
- case type_FunctionPointer:
- /* Start_addr should be the enclosing code object, or a closure
- * header. */
- switch (TypeOf(*start_addr)) {
- case type_CodeHeader:
- /* This case is probably caught above. */
- break;
- case type_ClosureHeader:
- case type_FuncallableInstanceHeader:
- case type_ByteCodeFunction:
- case type_ByteCodeClosure:
- if ((int)pointer != ((int)start_addr+type_FunctionPointer)) {
- if (pointer_filter_verbose) {
- fprintf(stderr,"*Wf2: %x %x %x\n", (unsigned int) pointer,
- (unsigned int) start_addr, *start_addr);
+ /* Check that the object pointed to is consistent with the pointer
+ * low tag. */
+ switch (LowtagOf((lispobj)pointer)) {
+ case type_FunctionPointer:
+ /* Start_addr should be the enclosing code object, or a closure
+ * header. */
+ switch (TypeOf(*start_addr)) {
+ case type_CodeHeader:
+ /* This case is probably caught above. */
+ break;
+ case type_ClosureHeader:
+ case type_FuncallableInstanceHeader:
+ case type_ByteCodeFunction:
+ case type_ByteCodeClosure:
+ if ((int)pointer != ((int)start_addr+type_FunctionPointer)) {
+ if (pointer_filter_verbose) {
+ fprintf(stderr,"*Wf2: %x %x %x\n", (unsigned int) pointer,
+ (unsigned int) start_addr, *start_addr);
+ }
+ return 0;
+ }
+ break;
+ default:
+ if (pointer_filter_verbose) {
+ fprintf(stderr,"*Wf3: %x %x %x\n", (unsigned int) pointer,
+ (unsigned int) start_addr, *start_addr);
+ }
+ return 0;
}
- return 0;
- }
- break;
- default:
- if (pointer_filter_verbose) {
- fprintf(stderr,"*Wf3: %x %x %x\n", (unsigned int) pointer,
- (unsigned int) start_addr, *start_addr);
- }
- return 0;
- }
- break;
- case type_ListPointer:
- if ((int)pointer != ((int)start_addr+type_ListPointer)) {
- if (pointer_filter_verbose)
- fprintf(stderr,"*Wl1: %x %x %x\n", (unsigned int) pointer,
- (unsigned int) start_addr, *start_addr);
- return 0;
- }
- /* Is it plausible cons? */
- if((Pointerp(start_addr[0])
- || ((start_addr[0] & 3) == 0) /* fixnum */
- || (TypeOf(start_addr[0]) == type_BaseChar)
- || (TypeOf(start_addr[0]) == type_UnboundMarker))
- && (Pointerp(start_addr[1])
- || ((start_addr[1] & 3) == 0) /* fixnum */
- || (TypeOf(start_addr[1]) == type_BaseChar)
- || (TypeOf(start_addr[1]) == type_UnboundMarker))) {
- break;
- } else {
- if (pointer_filter_verbose) {
- fprintf(stderr,"*Wl2: %x %x %x\n", (unsigned int) pointer,
- (unsigned int) start_addr, *start_addr);
- }
- return 0;
- }
- case type_InstancePointer:
- if ((int)pointer != ((int)start_addr+type_InstancePointer)) {
- if (pointer_filter_verbose) {
- fprintf(stderr,"*Wi1: %x %x %x\n", (unsigned int) pointer,
- (unsigned int) start_addr, *start_addr);
- }
- return 0;
- }
- if (TypeOf(start_addr[0]) != type_InstanceHeader) {
- if (pointer_filter_verbose) {
- fprintf(stderr,"*Wi2: %x %x %x\n", (unsigned int) pointer,
- (unsigned int) start_addr, *start_addr);
- }
- return 0;
- }
- break;
- case type_OtherPointer:
- if ((int)pointer != ((int)start_addr+type_OtherPointer)) {
- if (pointer_filter_verbose) {
- fprintf(stderr,"*Wo1: %x %x %x\n", (unsigned int) pointer,
- (unsigned int) start_addr, *start_addr);
- }
- return 0;
- }
- /* Is it plausible? Not a cons. X should check the headers. */
- if(Pointerp(start_addr[0]) || ((start_addr[0] & 3) == 0)) {
- if (pointer_filter_verbose) {
- fprintf(stderr,"*Wo2: %x %x %x\n", (unsigned int) pointer,
- (unsigned int) start_addr, *start_addr);
- }
- return 0;
- }
- switch (TypeOf(start_addr[0])) {
- case type_UnboundMarker:
- case type_BaseChar:
- if (pointer_filter_verbose) {
- fprintf(stderr,"*Wo3: %x %x %x\n", (unsigned int) pointer,
- (unsigned int) start_addr, *start_addr);
- }
- return 0;
-
- /* only pointed to by function pointers? */
- case type_ClosureHeader:
- case type_FuncallableInstanceHeader:
- case type_ByteCodeFunction:
- case type_ByteCodeClosure:
- if (pointer_filter_verbose) {
- fprintf(stderr,"*Wo4: %x %x %x\n", (unsigned int) pointer,
- (unsigned int) start_addr, *start_addr);
- }
- return 0;
-
- case type_InstanceHeader:
- if (pointer_filter_verbose) {
- fprintf(stderr,"*Wo5: %x %x %x\n", (unsigned int) pointer,
- (unsigned int) start_addr, *start_addr);
- }
- return 0;
-
- /* the valid other immediate pointer objects */
- case type_SimpleVector:
- case type_Ratio:
- case type_Complex:
+ break;
+ case type_ListPointer:
+ if ((int)pointer != ((int)start_addr+type_ListPointer)) {
+ if (pointer_filter_verbose)
+ fprintf(stderr,"*Wl1: %x %x %x\n", (unsigned int) pointer,
+ (unsigned int) start_addr, *start_addr);
+ return 0;
+ }
+ /* Is it plausible cons? */
+ if((Pointerp(start_addr[0])
+ || ((start_addr[0] & 3) == 0) /* fixnum */
+ || (TypeOf(start_addr[0]) == type_BaseChar)
+ || (TypeOf(start_addr[0]) == type_UnboundMarker))
+ && (Pointerp(start_addr[1])
+ || ((start_addr[1] & 3) == 0) /* fixnum */
+ || (TypeOf(start_addr[1]) == type_BaseChar)
+ || (TypeOf(start_addr[1]) == type_UnboundMarker))) {
+ break;
+ } else {
+ if (pointer_filter_verbose) {
+ fprintf(stderr,"*Wl2: %x %x %x\n", (unsigned int) pointer,
+ (unsigned int) start_addr, *start_addr);
+ }
+ return 0;
+ }
+ case type_InstancePointer:
+ if ((int)pointer != ((int)start_addr+type_InstancePointer)) {
+ if (pointer_filter_verbose) {
+ fprintf(stderr,"*Wi1: %x %x %x\n", (unsigned int) pointer,
+ (unsigned int) start_addr, *start_addr);
+ }
+ return 0;
+ }
+ if (TypeOf(start_addr[0]) != type_InstanceHeader) {
+ if (pointer_filter_verbose) {
+ fprintf(stderr,"*Wi2: %x %x %x\n", (unsigned int) pointer,
+ (unsigned int) start_addr, *start_addr);
+ }
+ return 0;
+ }
+ break;
+ case type_OtherPointer:
+ if ((int)pointer != ((int)start_addr+type_OtherPointer)) {
+ if (pointer_filter_verbose) {
+ fprintf(stderr,"*Wo1: %x %x %x\n", (unsigned int) pointer,
+ (unsigned int) start_addr, *start_addr);
+ }
+ return 0;
+ }
+ /* Is it plausible? Not a cons. X should check the headers. */
+ if(Pointerp(start_addr[0]) || ((start_addr[0] & 3) == 0)) {
+ if (pointer_filter_verbose) {
+ fprintf(stderr,"*Wo2: %x %x %x\n", (unsigned int) pointer,
+ (unsigned int) start_addr, *start_addr);
+ }
+ return 0;
+ }
+ switch (TypeOf(start_addr[0])) {
+ case type_UnboundMarker:
+ case type_BaseChar:
+ if (pointer_filter_verbose) {
+ fprintf(stderr,"*Wo3: %x %x %x\n", (unsigned int) pointer,
+ (unsigned int) start_addr, *start_addr);
+ }
+ return 0;
+
+ /* only pointed to by function pointers? */
+ case type_ClosureHeader:
+ case type_FuncallableInstanceHeader:
+ case type_ByteCodeFunction:
+ case type_ByteCodeClosure:
+ if (pointer_filter_verbose) {
+ fprintf(stderr,"*Wo4: %x %x %x\n", (unsigned int) pointer,
+ (unsigned int) start_addr, *start_addr);
+ }
+ return 0;
+
+ case type_InstanceHeader:
+ if (pointer_filter_verbose) {
+ fprintf(stderr,"*Wo5: %x %x %x\n", (unsigned int) pointer,
+ (unsigned int) start_addr, *start_addr);
+ }
+ return 0;
+
+ /* the valid other immediate pointer objects */
+ case type_SimpleVector:
+ case type_Ratio:
+ case type_Complex:
#ifdef type_ComplexSingleFloat
- case type_ComplexSingleFloat:
+ case type_ComplexSingleFloat:
#endif
#ifdef type_ComplexDoubleFloat
- case type_ComplexDoubleFloat:
+ case type_ComplexDoubleFloat:
#endif
#ifdef type_ComplexLongFloat
- case type_ComplexLongFloat:
-#endif
- case type_SimpleArray:
- case type_ComplexString:
- case type_ComplexBitVector:
- case type_ComplexVector:
- case type_ComplexArray:
- case type_ValueCellHeader:
- case type_SymbolHeader:
- case type_Fdefn:
- case type_CodeHeader:
- case type_Bignum:
- case type_SingleFloat:
- case type_DoubleFloat:
+ case type_ComplexLongFloat:
+#endif
+ case type_SimpleArray:
+ case type_ComplexString:
+ case type_ComplexBitVector:
+ case type_ComplexVector:
+ case type_ComplexArray:
+ case type_ValueCellHeader:
+ case type_SymbolHeader:
+ case type_Fdefn:
+ case type_CodeHeader:
+ case type_Bignum:
+ case type_SingleFloat:
+ case type_DoubleFloat:
#ifdef type_LongFloat
- case type_LongFloat:
-#endif
- case type_SimpleString:
- case type_SimpleBitVector:
- case type_SimpleArrayUnsignedByte2:
- case type_SimpleArrayUnsignedByte4:
- case type_SimpleArrayUnsignedByte8:
- case type_SimpleArrayUnsignedByte16:
- case type_SimpleArrayUnsignedByte32:
+ case type_LongFloat:
+#endif
+ case type_SimpleString:
+ case type_SimpleBitVector:
+ case type_SimpleArrayUnsignedByte2:
+ case type_SimpleArrayUnsignedByte4:
+ case type_SimpleArrayUnsignedByte8:
+ case type_SimpleArrayUnsignedByte16:
+ case type_SimpleArrayUnsignedByte32:
#ifdef type_SimpleArraySignedByte8
- case type_SimpleArraySignedByte8:
+ case type_SimpleArraySignedByte8:
#endif
#ifdef type_SimpleArraySignedByte16
- case type_SimpleArraySignedByte16:
+ case type_SimpleArraySignedByte16:
#endif
#ifdef type_SimpleArraySignedByte30
- case type_SimpleArraySignedByte30:
+ case type_SimpleArraySignedByte30:
#endif
#ifdef type_SimpleArraySignedByte32
- case type_SimpleArraySignedByte32:
+ case type_SimpleArraySignedByte32:
#endif
- case type_SimpleArraySingleFloat:
- case type_SimpleArrayDoubleFloat:
+ case type_SimpleArraySingleFloat:
+ case type_SimpleArrayDoubleFloat:
#ifdef type_SimpleArrayLongFloat
- case type_SimpleArrayLongFloat:
+ case type_SimpleArrayLongFloat:
#endif
#ifdef type_SimpleArrayComplexSingleFloat
- case type_SimpleArrayComplexSingleFloat:
+ case type_SimpleArrayComplexSingleFloat:
#endif
#ifdef type_SimpleArrayComplexDoubleFloat
- case type_SimpleArrayComplexDoubleFloat:
+ case type_SimpleArrayComplexDoubleFloat:
#endif
#ifdef type_SimpleArrayComplexLongFloat
- case type_SimpleArrayComplexLongFloat:
-#endif
- case type_Sap:
- case type_WeakPointer:
- break;
-
+ case type_SimpleArrayComplexLongFloat:
+#endif
+ case type_Sap:
+ case type_WeakPointer:
+ break;
+
+ default:
+ if (pointer_filter_verbose) {
+ fprintf(stderr,"*Wo6: %x %x %x\n", (unsigned int) pointer,
+ (unsigned int) start_addr, *start_addr);
+ }
+ return 0;
+ }
+ break;
default:
- if (pointer_filter_verbose) {
- fprintf(stderr,"*Wo6: %x %x %x\n", (unsigned int) pointer,
- (unsigned int) start_addr, *start_addr);
- }
- return 0;
- }
- break;
- default:
- if (pointer_filter_verbose) {
- fprintf(stderr,"*W?: %x %x %x\n", (unsigned int) pointer,
- (unsigned int) start_addr, *start_addr);
+ if (pointer_filter_verbose) {
+ fprintf(stderr,"*W?: %x %x %x\n", (unsigned int) pointer,
+ (unsigned int) start_addr, *start_addr);
+ }
+ return 0;
}
- return 0;
- }
- /* looks good */
- return 1;
+ /* looks good */
+ return 1;
}
#define MAX_STACK_POINTERS 256
static void
setup_i386_stack_scav(lispobj *lowaddr, lispobj *base)
{
- lispobj *sp = lowaddr;
- num_valid_stack_locations = 0;
- num_valid_stack_ra_locations = 0;
- for (sp = lowaddr; sp < base; sp++) {
- lispobj thing = *sp;
- /* Find the object start address */
- lispobj *start_addr = search_dynamic_space((void *)thing);
- if (start_addr) {
- /* We need to allow raw pointers into Code objects for return
- * addresses. This will also pick up pointers to functions in code
- * objects. */
- if (TypeOf(*start_addr) == type_CodeHeader) {
- gc_assert(num_valid_stack_ra_locations < MAX_STACK_RETURN_ADDRESSES);
- valid_stack_ra_locations[num_valid_stack_ra_locations] = sp;
- valid_stack_ra_code_objects[num_valid_stack_ra_locations++] =
- (lispobj *)((int)start_addr + type_OtherPointer);
- } else {
- if (valid_dynamic_space_pointer((void *)thing, start_addr)) {
- gc_assert(num_valid_stack_locations < MAX_STACK_POINTERS);
- valid_stack_locations[num_valid_stack_locations++] = sp;
+ lispobj *sp = lowaddr;
+ num_valid_stack_locations = 0;
+ num_valid_stack_ra_locations = 0;
+ for (sp = lowaddr; sp < base; sp++) {
+ lispobj thing = *sp;
+ /* Find the object start address */
+ lispobj *start_addr = search_dynamic_space((void *)thing);
+ if (start_addr) {
+ /* We need to allow raw pointers into Code objects for
+ * return addresses. This will also pick up pointers to
+ * functions in code objects. */
+ if (TypeOf(*start_addr) == type_CodeHeader) {
+ gc_assert(num_valid_stack_ra_locations <
+ MAX_STACK_RETURN_ADDRESSES);
+ valid_stack_ra_locations[num_valid_stack_ra_locations] = sp;
+ valid_stack_ra_code_objects[num_valid_stack_ra_locations++] =
+ (lispobj *)((int)start_addr + type_OtherPointer);
+ } else {
+ if (valid_dynamic_space_pointer((void *)thing, start_addr)) {
+ gc_assert(num_valid_stack_locations < MAX_STACK_POINTERS);
+ valid_stack_locations[num_valid_stack_locations++] = sp;
+ }
+ }
}
- }
}
- }
- if (pointer_filter_verbose) {
- fprintf(stderr, "number of valid stack pointers = %d\n",
- num_valid_stack_locations);
- fprintf(stderr, "number of stack return addresses = %d\n",
- num_valid_stack_ra_locations);
- }
+ if (pointer_filter_verbose) {
+ fprintf(stderr, "number of valid stack pointers = %d\n",
+ num_valid_stack_locations);
+ fprintf(stderr, "number of stack return addresses = %d\n",
+ num_valid_stack_ra_locations);
+ }
}
static void
pscav_i386_stack(void)
{
- int i;
+ int i;
- for (i = 0; i < num_valid_stack_locations; i++)
- pscav(valid_stack_locations[i], 1, 0);
+ for (i = 0; i < num_valid_stack_locations; i++)
+ pscav(valid_stack_locations[i], 1, 0);
- for (i = 0; i < num_valid_stack_ra_locations; i++) {
- lispobj code_obj = (lispobj)valid_stack_ra_code_objects[i];
- pscav(&code_obj, 1, 0);
- if (pointer_filter_verbose) {
- fprintf(stderr,"*C moved RA %x to %x; for code object %x to %x\n",
- *valid_stack_ra_locations[i],
- (int)(*valid_stack_ra_locations[i])
- - ((int)valid_stack_ra_code_objects[i] - (int)code_obj),
- (unsigned int) valid_stack_ra_code_objects[i], code_obj);
+ for (i = 0; i < num_valid_stack_ra_locations; i++) {
+ lispobj code_obj = (lispobj)valid_stack_ra_code_objects[i];
+ pscav(&code_obj, 1, 0);
+ if (pointer_filter_verbose) {
+ fprintf(stderr,"*C moved RA %x to %x; for code object %x to %x\n",
+ *valid_stack_ra_locations[i],
+ (int)(*valid_stack_ra_locations[i])
+ - ((int)valid_stack_ra_code_objects[i] - (int)code_obj),
+ (unsigned int) valid_stack_ra_code_objects[i], code_obj);
+ }
+ *valid_stack_ra_locations[i] =
+ ((int)(*valid_stack_ra_locations[i])
+ - ((int)valid_stack_ra_code_objects[i] - (int)code_obj));
}
- *valid_stack_ra_locations[i] =
- ((int)(*valid_stack_ra_locations[i])
- - ((int)valid_stack_ra_code_objects[i] - (int)code_obj));
- }
}
#endif
#endif
}
}
-static lispobj ptrans_boxed(lispobj thing, lispobj header, boolean constant)
+static lispobj
+ptrans_boxed(lispobj thing, lispobj header, boolean constant)
{
int nwords;
lispobj result, *new, *old;
}
/* We need to look at the layout to see whether it is a pure structure
- * class, and only then can we transport as constant. If it is pure, we can
- * ALWAYS transport as a constant. */
-static lispobj ptrans_instance(lispobj thing, lispobj header, boolean constant)
+ * class, and only then can we transport as constant. If it is pure,
+ * we can ALWAYS transport as a constant. */
+static lispobj
+ptrans_instance(lispobj thing, lispobj header, boolean constant)
{
lispobj layout = ((struct instance *)PTR(thing))->slots[0];
lispobj pure = ((struct instance *)PTR(layout))->slots[15];
return (ptrans_boxed(thing, header, 0));
case 0:
{
- /* Substructure: special case for the COMPACT-INFO-ENVs, where
- * the instance may have a point to the dynamic space placed
- * into it (e.g. the cache-name slot), but the lists and arrays
- * at the time of a purify can be moved to the RO space. */
+ /* Substructure: special case for the COMPACT-INFO-ENVs,
+ * where the instance may have a point to the dynamic
+ * space placed into it (e.g. the cache-name slot), but
+ * the lists and arrays at the time of a purify can be
+ * moved to the RO space. */
int nwords;
lispobj result, *new, *old;
}
}
-static lispobj ptrans_fdefn(lispobj thing, lispobj header)
+static lispobj
+ptrans_fdefn(lispobj thing, lispobj header)
{
int nwords;
lispobj result, *new, *old, oldfn;
return result;
}
-static lispobj ptrans_unboxed(lispobj thing, lispobj header)
+static lispobj
+ptrans_unboxed(lispobj thing, lispobj header)
{
int nwords;
lispobj result, *new, *old;
return result;
}
-static lispobj ptrans_vector(lispobj thing, int bits, int extra,
- boolean boxed, boolean constant)
+static lispobj
+ptrans_vector(lispobj thing, int bits, int extra,
+ boolean boxed, boolean constant)
{
struct vector *vector;
int nwords;
}
#endif
-static lispobj ptrans_code(lispobj thing)
+static lispobj
+ptrans_code(lispobj thing)
{
struct code *code, *new;
int nwords;
return result;
}
-static lispobj ptrans_func(lispobj thing, lispobj header)
+static lispobj
+ptrans_func(lispobj thing, lispobj header)
{
int nwords;
lispobj code, *new, *old, result;
}
}
-static lispobj ptrans_returnpc(lispobj thing, lispobj header)
+static lispobj
+ptrans_returnpc(lispobj thing, lispobj header)
{
lispobj code, new;
#define WORDS_PER_CONS CEILING(sizeof(struct cons) / sizeof(lispobj), 2)
-static lispobj ptrans_list(lispobj thing, boolean constant)
+static lispobj
+ptrans_list(lispobj thing, boolean constant)
{
struct cons *old, *new, *orig;
int length;
return ((lispobj)orig) | type_ListPointer;
}
-static lispobj ptrans_otherptr(lispobj thing, lispobj header, boolean constant)
+static lispobj
+ptrans_otherptr(lispobj thing, lispobj header, boolean constant)
{
switch (TypeOf(header)) {
case type_Bignum:
}
}
-static int pscav_fdefn(struct fdefn *fdefn)
+static int
+pscav_fdefn(struct fdefn *fdefn)
{
boolean fix_func;
}
#endif
-static lispobj *pscav(lispobj *addr, int nwords, boolean constant)
+static lispobj *
+pscav(lispobj *addr, int nwords, boolean constant)
{
lispobj thing, *thingp, header;
int count = 0; /* (0 = dummy init value to stop GCC warning) */
return addr;
}
-int purify(lispobj static_roots, lispobj read_only_roots)
+int
+purify(lispobj static_roots, lispobj read_only_roots)
{
lispobj *clean;
int count, i;
#ifndef _SBCL_RUNTIME_H_
#define _SBCL_RUNTIME_H_
-#define QSHOW 1 /* Enable low-level debugging output? */
+#define QSHOW 0 /* Enable low-level debugging output? */
#if QSHOW
#define FSHOW(args) fprintf args
#define SHOW(string) FSHOW((stderr, "/%s\n", string))
* signal handling.)
*
* Note: It may be that doing this is fundamentally unsound, since it
- * causes output from signal handlers, the i/o libraries aren't
+ * causes output from signal handlers, and the i/o libraries aren't
* necessarily reentrant. But it can still be very convenient for
* figuring out what's going on when you have a signal handling
* problem.. */
-#define QSHOW_SIGNALS 1
+#define QSHOW_SIGNALS 0
/* FIXME: There seems to be no reason that LowtagOf can't be defined
* as a (possibly inline) function instead of a macro. It would also
'("SB-ALIEN" "SB-C-CALL" "SB-DEBUG" "SB-EXT" "SB-GRAY" "SB-MP"
"SB-PROFILE" "SB-PCL" "COMMON-LISP"))
(defun has-arglist-info-p (function)
- (and (not (typep function 'sb-c::byte-function))
- (sb-kernel:%function-arglist function)))
+ (declare (type function function))
+ ;; The Lisp-level type FUNCTION can conceal a multitude of sins..
+ (case (sb-kernel:get-type function)
+ (#.sb-vm:function-header-type (sb-kernel:%function-arglist function))
+ (#.sb-vm:closure-function-header-type (has-arglist-info-p
+ (sb-kernel:%closure-function
+ function)))
+ ;; (There might be other cases with arglist info also.
+ ;; FUNCTION-HEADER-TYPE and CLOSURE-FUNCTION-HEADER-TYPE just
+ ;; happen to be the two case that I had my nose rubbed in when
+ ;; debugging a GC problem caused by applying %FUNCTION-ARGLIST to
+ ;; a closure. -- WHN 2001-06-05)
+ (t nil)))
(defun check-ext-symbols-arglist (package)
(format t "~% looking at package: ~A" package)
(do-external-symbols (ext-sym package)
(when (fboundp ext-sym)
(let ((fun (symbol-function ext-sym)))
- (unless (has-arglist-info-p fun)
- (error "~%Function ~A (~A) has no argument-list information available, ~%~
- and is probably byte-compiled.~%" ext-sym fun))))))
+ (cond ((macro-function ext-sym)
+ ;; FIXME: Macro functions should have their argument list
+ ;; information checked separately. Just feeding them into
+ ;; the ordinary-function logic below doesn't work right,
+ ;; though, and I haven't figured out what does work
+ ;; right. For now we just punt.
+ (values))
+ #+nil
+ ((sb-int:info :function :accessor-for ext-sym)
+ (values))
+ ((typep fun 'generic-function)
+ ;; FIXME: Check the argument lists of generic functions,
+ ;; instead of just punting like this. (DESCRIBE seems
+ ;; to know how to do it, at least for #'DOCUMENTATION.)
+ (values))
+ (;; FIXME: CONDITION slot accessors (e.g.
+ ;; PRINT-NOT-READABLE-OBJECT) fall into this category.
+ ;; They seem to have argument lists -- since at least
+ ;; DESCRIBE knows how to find them -- but I have
+ ;; neither reverse engineered how it's finding them,
+ ;; nor factored that into a function which can be
+ ;; shared with the logic here..
+ (= (sb-kernel:get-type fun) sb-vm:closure-header-type)
+ (values)) ; ..so for now we just punt.
+ (t
+ (let ((fun (symbol-function ext-sym)))
+ (unless (has-arglist-info-p fun)
+ (error "Function ~A has no arg-list information available."
+ ext-sym)))))))))
(dolist (public-package *public-package-names*)
(when (find-package public-package)
(check-ext-symbols-arglist public-package)))
(terpri)
+
+;;; FIXME: It might also be good to require that every external symbol
+;;; either has a doc string or has some good excuse (like being an
+;;; accessor for a structure which has a doc string).
+
(print "done with interface.pure.lisp")
(format t "translation=~S~%" translation)
(format t "expected-translation=~S~%" expected-translation)
(assert (string= translation expected-translation)))
+ #| ; REMOVEME: These should be uncommented-out after flaky2_branch is merged.
(format t "about to LOAD ~S~%" "TEST:$StudlyCapsStem")
(load "TEST:$StudlyCapsStem")
(assert (eq *loaded* :yes))
(format t "compiled-file-name=~S~%" compiled-file-name)
(format t "expected-file-name=~S~%" expected-file-name)
(assert (string= compiled-file-name expected-file-name)))
+ |#
(sb-ext:quit :unix-status 52)
EOF
if [ $? != 52 ]; then
;;; versions, and a string like "0.6.5.12" is used for versions which
;;; aren't released but correspond only to CVS tags or snapshots.
-"0.6.12.22"
+"0.6.12.21.flaky2.2"
projects / sbcl.git / commitdiff