diff options
Diffstat (limited to 'src/alloc.c')
| -rw-r--r-- | src/alloc.c | 120 |
1 files changed, 106 insertions, 14 deletions
diff --git a/src/alloc.c b/src/alloc.c index b86ed4ed262..4ea337ddbaa 100644 --- a/src/alloc.c +++ b/src/alloc.c @@ -3152,6 +3152,26 @@ cleanup_vector (struct Lisp_Vector *vector) module_finalize_function (function); } #endif + else if (NATIVE_COMP_FLAG + && PSEUDOVECTOR_TYPEP (&vector->header, PVEC_NATIVE_COMP_UNIT)) + { + struct Lisp_Native_Comp_Unit *cu = + PSEUDOVEC_STRUCT (vector, Lisp_Native_Comp_Unit); + unload_comp_unit (cu); + } + else if (NATIVE_COMP_FLAG + && PSEUDOVECTOR_TYPEP (&vector->header, PVEC_SUBR)) + { + struct Lisp_Subr *subr = + PSEUDOVEC_STRUCT (vector, Lisp_Subr); + if (!NILP (subr->native_comp_u[0])) + { + /* FIXME Alternative and non invasive solution to this + cast? */ + xfree ((char *)subr->symbol_name); + xfree (subr->native_c_name[0]); + } + } } /* Reclaim space used by unmarked vectors. */ @@ -3498,6 +3518,38 @@ usage: (make-byte-code ARGLIST BYTE-CODE CONSTANTS DEPTH &optional DOCSTRING INT return val; } +DEFUN ("make-closure", Fmake_closure, Smake_closure, 1, MANY, 0, + doc: /* Create a byte-code closure from PROTOTYPE and CLOSURE-VARS. +Return a copy of PROTOTYPE, a byte-code object, with CLOSURE-VARS +replacing the elements in the beginning of the constant-vector. +usage: (make-closure PROTOTYPE &rest CLOSURE-VARS) */) + (ptrdiff_t nargs, Lisp_Object *args) +{ + Lisp_Object protofun = args[0]; + CHECK_TYPE (COMPILEDP (protofun), Qbyte_code_function_p, protofun); + + /* Create a copy of the constant vector, filling it with the closure + variables in the beginning. (The overwritten part should just + contain placeholder values.) */ + Lisp_Object proto_constvec = AREF (protofun, COMPILED_CONSTANTS); + ptrdiff_t constsize = ASIZE (proto_constvec); + ptrdiff_t nvars = nargs - 1; + if (nvars > constsize) + error ("Closure vars do not fit in constvec"); + Lisp_Object constvec = make_uninit_vector (constsize); + memcpy (XVECTOR (constvec)->contents, args + 1, nvars * word_size); + memcpy (XVECTOR (constvec)->contents + nvars, + XVECTOR (proto_constvec)->contents + nvars, + (constsize - nvars) * word_size); + + /* Return a copy of the prototype function with the new constant vector. */ + ptrdiff_t protosize = PVSIZE (protofun); + struct Lisp_Vector *v = allocate_vectorlike (protosize, false); + v->header = XVECTOR (protofun)->header; + memcpy (v->contents, XVECTOR (protofun)->contents, protosize * word_size); + v->contents[COMPILED_CONSTANTS] = constvec; + return make_lisp_ptr (v, Lisp_Vectorlike); +} /*********************************************************************** @@ -4688,7 +4740,7 @@ live_small_vector_p (struct mem_node *m, void *p) marked. */ static void -mark_maybe_pointer (void *p) +mark_maybe_pointer (void *p, bool symbol_only) { struct mem_node *m; @@ -4703,14 +4755,32 @@ mark_maybe_pointer (void *p) definitely _don't_ have an object. */ if (pdumper_object_p (p)) { + /* FIXME: This code assumes that every reachable pdumper object + is addressed either by a pointer to the object start, or by + the same pointer with an LSB-style tag. This assumption + fails if a pdumper object is reachable only via machine + addresses of non-initial object components. Although such + addressing is rare in machine code generated by C compilers + from Emacs source code, it can occur in some cases. To fix + this problem, the pdumper code should grok non-initial + addresses, as the non-pdumper code does. */ + uintptr_t mask = VALMASK & UINTPTR_MAX; + uintptr_t masked_p = (uintptr_t) p & mask; + void *po = (void *) masked_p; + char *cp = p; + char *cpo = po; /* Don't use pdumper_object_p_precise here! It doesn't check the tag bits. OBJ here might be complete garbage, so we need to verify both the pointer and the tag. */ - int type = pdumper_find_object_type (p); - if (pdumper_valid_object_type_p (type)) - mark_object (type == Lisp_Symbol - ? make_lisp_symbol (p) - : make_lisp_ptr (p, type)); + int type = pdumper_find_object_type (po); + if (pdumper_valid_object_type_p (type) + && (!USE_LSB_TAG || p == po || cp - cpo == type)) + { + if (type == Lisp_Symbol) + mark_object (make_lisp_symbol (po)); + else if (!symbol_only) + mark_object (make_lisp_ptr (po, type)); + } return; } @@ -4728,6 +4798,8 @@ mark_maybe_pointer (void *p) case MEM_TYPE_CONS: { + if (symbol_only) + return; struct Lisp_Cons *h = live_cons_holding (m, p); if (!h) return; @@ -4737,6 +4809,8 @@ mark_maybe_pointer (void *p) case MEM_TYPE_STRING: { + if (symbol_only) + return; struct Lisp_String *h = live_string_holding (m, p); if (!h) return; @@ -4755,6 +4829,8 @@ mark_maybe_pointer (void *p) case MEM_TYPE_FLOAT: { + if (symbol_only) + return; struct Lisp_Float *h = live_float_holding (m, p); if (!h) return; @@ -4764,6 +4840,8 @@ mark_maybe_pointer (void *p) case MEM_TYPE_VECTORLIKE: { + if (symbol_only) + return; struct Lisp_Vector *h = live_large_vector_holding (m, p); if (!h) return; @@ -4773,6 +4851,8 @@ mark_maybe_pointer (void *p) case MEM_TYPE_VECTOR_BLOCK: { + if (symbol_only) + return; struct Lisp_Vector *h = live_small_vector_holding (m, p); if (!h) return; @@ -4834,7 +4914,7 @@ mark_memory (void const *start, void const *end) for (pp = start; (void const *) pp < end; pp += GC_POINTER_ALIGNMENT) { void *p = *(void *const *) pp; - mark_maybe_pointer (p); + mark_maybe_pointer (p, false); /* Unmask any struct Lisp_Symbol pointer that make_lisp_symbol previously disguised by adding the address of 'lispsym'. @@ -4843,7 +4923,7 @@ mark_memory (void const *start, void const *end) non-adjacent words and P might be the low-order word's value. */ intptr_t ip; INT_ADD_WRAPV ((intptr_t) p, (intptr_t) lispsym, &ip); - mark_maybe_pointer ((void *) ip); + mark_maybe_pointer ((void *) ip, true); } } @@ -6216,7 +6296,7 @@ For further details, see Info node `(elisp)Garbage Collection'. */) } DEFUN ("garbage-collect-maybe", Fgarbage_collect_maybe, -Sgarbage_collect_maybe, 1, 1, "", +Sgarbage_collect_maybe, 1, 1, 0, doc: /* Call `garbage-collect' if enough allocation happened. FACTOR determines what "enough" means here: If FACTOR is a positive number N, it means to run GC if more than @@ -6693,6 +6773,15 @@ mark_object (Lisp_Object arg) break; case PVEC_SUBR: + if (SUBR_NATIVE_COMPILEDP (obj)) + { + set_vector_marked (ptr); + struct Lisp_Subr *subr = XSUBR (obj); + mark_object (subr->native_intspec); + mark_object (subr->native_comp_u[0]); + mark_object (subr->lambda_list[0]); + mark_object (subr->type[0]); + } break; case PVEC_FREE: @@ -6837,7 +6926,9 @@ survives_gc_p (Lisp_Object obj) break; case Lisp_Vectorlike: - survives_p = SUBRP (obj) || vector_marked_p (XVECTOR (obj)); + survives_p = + (SUBRP (obj) && !SUBR_NATIVE_COMPILEDP (obj)) || + vector_marked_p (XVECTOR (obj)); break; case Lisp_Cons: @@ -7227,7 +7318,7 @@ Frames, windows, buffers, and subprocesses count as vectors make_int (strings_consed)); } -#ifdef GNU_LINUX +#if defined GNU_LINUX && defined __GLIBC__ DEFUN ("malloc-info", Fmalloc_info, Smalloc_info, 0, 0, "", doc: /* Report malloc information to stderr. This function outputs to stderr an XML-formatted @@ -7573,6 +7664,7 @@ N should be nonnegative. */); defsubr (&Srecord); defsubr (&Sbool_vector); defsubr (&Smake_byte_code); + defsubr (&Smake_closure); defsubr (&Smake_list); defsubr (&Smake_vector); defsubr (&Smake_record); @@ -7586,7 +7678,7 @@ N should be nonnegative. */); defsubr (&Sgarbage_collect_maybe); defsubr (&Smemory_info); defsubr (&Smemory_use_counts); -#ifdef GNU_LINUX +#if defined GNU_LINUX && defined __GLIBC__ defsubr (&Smalloc_info); #endif defsubr (&Ssuspicious_object); @@ -7596,14 +7688,14 @@ N should be nonnegative. */); static union Aligned_Lisp_Subr Swatch_gc_cons_threshold = {{{ PSEUDOVECTOR_FLAG | (PVEC_SUBR << PSEUDOVECTOR_AREA_BITS) }, { .a4 = watch_gc_cons_threshold }, - 4, 4, "watch_gc_cons_threshold", 0, 0}}; + 4, 4, "watch_gc_cons_threshold", {0}, 0}}; XSETSUBR (watcher, &Swatch_gc_cons_threshold.s); Fadd_variable_watcher (Qgc_cons_threshold, watcher); static union Aligned_Lisp_Subr Swatch_gc_cons_percentage = {{{ PSEUDOVECTOR_FLAG | (PVEC_SUBR << PSEUDOVECTOR_AREA_BITS) }, { .a4 = watch_gc_cons_percentage }, - 4, 4, "watch_gc_cons_percentage", 0, 0}}; + 4, 4, "watch_gc_cons_percentage", {0}, 0}}; XSETSUBR (watcher, &Swatch_gc_cons_percentage.s); Fadd_variable_watcher (Qgc_cons_percentage, watcher); } |