1 /* Storage allocation and gc for SXEmacs Lisp interpreter.
2 Copyright (C) 1985-1998 Free Software Foundation, Inc.
3 Copyright (C) 1995 Sun Microsystems, Inc.
4 Copyright (C) 1995, 1996 Ben Wing.
6 This file is part of SXEmacs
8 SXEmacs is free software: you can redistribute it and/or modify
9 it under the terms of the GNU General Public License as published by
10 the Free Software Foundation, either version 3 of the License, or
11 (at your option) any later version.
13 SXEmacs is distributed in the hope that it will be useful,
14 but WITHOUT ANY WARRANTY; without even the implied warranty of
15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 GNU General Public License for more details.
18 You should have received a copy of the GNU General Public License
19 along with this program. If not, see <http://www.gnu.org/licenses/>. */
22 /* Synched up with: FSF 19.28, Mule 2.0. Substantially different from
27 FSF: Original version; a long time ago.
28 Mly: Significantly rewritten to use new 3-bit tags and
29 nicely abstracted object definitions, for 19.8.
30 JWZ: Improved code to keep track of purespace usage and
31 issue nice purespace and GC stats.
32 Ben Wing: Cleaned up frob-block lrecord code, added error-checking
33 and various changes for Mule, for 19.12.
34 Added bit vectors for 19.13.
35 Added lcrecord lists for 19.14.
36 slb: Lots of work on the purification and dump time code.
37 Synched Doug Lea malloc support from Emacs 20.2.
38 og: Killed the purespace. Portable dumper (moved to dumper.c)
44 #include "backtrace.h"
48 #include "ui/device.h"
50 #define INCLUDE_EVENTS_H_PRIVATE_SPHERE
51 #include "events/events.h"
54 #include "ui/glyphs.h"
56 #include "ui/redisplay.h"
57 #include "specifier.h"
60 #include "ui/window.h"
61 #include "ui/console-stream.h"
63 #ifdef DOUG_LEA_MALLOC
71 #define SXE_DEBUG_GC_GMP(args...) SXE_DEBUG_GC("[gmp]: " args)
74 #if defined HAVE_BDWGC && defined EF_USE_BDWGC
77 # if defined HAVE_GC_GC_H
79 # elif defined HAVE_GC_H
82 /* declare the 3 funs we need */
83 extern void *GC_malloc(size_t);
84 extern void *GC_malloc_atomic(size_t);
85 extern void *GC_malloc_uncollectable(size_t);
86 extern void *GC_malloc_stubborn(size_t);
87 extern void *GC_realloc(void*, size_t);
88 extern char *GC_strdup(const char*);
89 extern void GC_free(void*);
91 # error "I'm very concerned about your BDWGC support"
95 /* category subsystem */
101 EXFUN(Fgarbage_collect, 0);
104 /* this is _way_ too slow to be part of the standard debug options */
105 #if defined(DEBUG_SXEMACS) && defined(MULE)
106 #define VERIFY_STRING_CHARS_INTEGRITY
110 /* Define this to use malloc/free with no freelist for all datatypes,
111 the hope being that some debugging tools may help detect
112 freed memory references */
113 #ifdef USE_DEBUG_MALLOC /* Taking the above comment at face value -slb */
115 #define ALLOC_NO_POOLS
119 static Fixnum debug_allocation;
120 static Fixnum debug_allocation_backtrace_length;
123 #if defined EF_USE_ASYNEQ && !(defined HAVE_BDWGC && defined EF_USE_BDWGC)
124 #include "semaphore.h"
125 sxe_mutex_t cons_mutex;
126 #endif /* EF_USE_ASYNEQ && !BDWGC */
128 #include "events/event-queue.h"
129 #include "events/workers.h"
130 dllist_t workers = NULL;
133 /* Number of bytes of consing done since the last gc */
134 #if defined HAVE_BDWGC && defined EF_USE_BDWGC
135 #define INCREMENT_CONS_COUNTER_1(size)
139 EMACS_INT consing_since_gc;
140 #define INCREMENT_CONS_COUNTER_1(size) (consing_since_gc += (size))
145 debug_allocation_backtrace(void)
147 if (debug_allocation_backtrace_length > 0) {
148 debug_short_backtrace (debug_allocation_backtrace_length);
153 #define INCREMENT_CONS_COUNTER(foosize, type) \
155 if (debug_allocation) { \
156 stderr_out("allocating %s (size %ld)\n", \
157 type, (long)foosize); \
158 debug_allocation_backtrace (); \
160 INCREMENT_CONS_COUNTER_1(foosize); \
162 #define NOSEEUM_INCREMENT_CONS_COUNTER(foosize, type) \
164 if (debug_allocation > 1) { \
165 stderr_out("allocating noseeum %s (size %ld)\n", \
166 type, (long)foosize); \
167 debug_allocation_backtrace (); \
169 INCREMENT_CONS_COUNTER_1(foosize); \
172 #define INCREMENT_CONS_COUNTER(size, type) INCREMENT_CONS_COUNTER_1 (size)
173 #define NOSEEUM_INCREMENT_CONS_COUNTER(size, type) \
174 INCREMENT_CONS_COUNTER_1 (size)
178 DECREMENT_CONS_COUNTER(size_t size)
179 __attribute__((always_inline));
182 DECREMENT_CONS_COUNTER(size_t size)
184 consing_since_gc -= (size);
185 if (consing_since_gc < 0) {
186 consing_since_gc = 0;
190 /* Number of bytes of consing since gc before another gc should be done. */
191 EMACS_INT gc_cons_threshold;
193 /* Nonzero during gc */
196 /* Number of times GC has happened at this level or below.
197 * Level 0 is most volatile, contrary to usual convention.
198 * (Of course, there's only one level at present) */
199 EMACS_INT gc_generation_number[1];
201 /* This is just for use by the printer, to allow things to print uniquely */
202 static int lrecord_uid_counter;
204 /* Nonzero when calling certain hooks or doing other things where
206 int gc_currently_forbidden;
209 Lisp_Object Vpre_gc_hook, Qpre_gc_hook;
210 Lisp_Object Vpost_gc_hook, Qpost_gc_hook;
212 /* "Garbage collecting" */
213 Lisp_Object Vgc_message;
214 Lisp_Object Vgc_pointer_glyph;
215 static char gc_default_message[] = "Garbage collecting";
216 Lisp_Object Qgarbage_collecting;
218 /* Non-zero means we're in the process of doing the dump */
221 #ifdef ERROR_CHECK_TYPECHECK
223 Error_behavior ERROR_ME, ERROR_ME_NOT, ERROR_ME_WARN;
227 int c_readonly(Lisp_Object obj)
229 return POINTER_TYPE_P(XTYPE(obj)) && C_READONLY(obj);
232 int lisp_readonly(Lisp_Object obj)
234 return POINTER_TYPE_P(XTYPE(obj)) && LISP_READONLY(obj);
237 /* Maximum amount of C stack to save when a GC happens. */
239 #ifndef MAX_SAVE_STACK
240 #define MAX_SAVE_STACK 0 /* 16000 */
243 /* Non-zero means ignore malloc warnings. Set during initialization. */
244 int ignore_malloc_warnings;
246 static void *breathing_space;
248 void release_breathing_space(void)
250 if (breathing_space) {
251 void *tmp = breathing_space;
257 /* malloc calls this if it finds we are near exhausting storage */
258 void malloc_warning(const char *str)
260 if (ignore_malloc_warnings)
266 "Killing some buffers may delay running out of memory.\n"
267 "However, certainly by the time you receive the 95%% warning,\n"
268 "you should clean up, kill this Emacs, and start a new one.", str);
271 /* Called if malloc returns zero */
272 DOESNT_RETURN memory_full(void)
274 /* Force a GC next time eval is called.
275 It's better to loop garbage-collecting (we might reclaim enough
276 to win) than to loop beeping and barfing "Memory exhausted"
278 #if defined HAVE_BDWGC && defined EF_USE_BDWGC
279 /* that's all we can do */
282 consing_since_gc = gc_cons_threshold + 1;
283 release_breathing_space();
286 /* Flush some histories which might conceivably contain garbalogical
288 if (!NILP(Fboundp(Qvalues))) {
291 Vcommand_history = Qnil;
293 error("Memory exhausted");
296 #if !defined HAVE_BDWGC || !defined EF_USE_BDWGC
297 /* like malloc and realloc but check for no memory left, and block input. */
300 void *xmalloc(size_t size)
302 #if defined HAVE_BDWGC && defined EF_USE_BDWGC
303 /* yes i know this is contradicting because of the outer conditional
304 * but this here and the definition in lisp.h are meant to be
306 void *val = zmalloc(size);
307 #else /* !HAVE_BDWGC */
308 void *val = ymalloc(size);
309 #endif /* HAVE_BDWGC */
311 if (!val && (size != 0))
316 #undef xmalloc_atomic
317 void *xmalloc_atomic(size_t size)
319 #if defined HAVE_BDWGC && defined EF_USE_BDWGC
320 void *val = zmalloc_atomic(size);
321 #else /* !HAVE_BDWGC */
322 void *val = ymalloc_atomic(size);
323 #endif /* HAVE_BDWGC */
325 if (!val && (size != 0))
331 static void *xcalloc(size_t nelem, size_t elsize)
333 #if defined HAVE_BDWGC && defined EF_USE_BDWGC
334 void *val = zcalloc(nelem, elsize);
336 void *val = ycalloc(nelem, elsize);
339 if (!val && (nelem != 0))
344 void *xmalloc_and_zero(size_t size)
346 #if defined HAVE_BDWGC && defined EF_USE_BDWGC
347 return zmalloc_and_zero(size);
349 return xcalloc(size, 1);
354 void *xrealloc(void *block, size_t size)
356 #if defined HAVE_BDWGC && defined EF_USE_BDWGC
357 void *val = zrealloc(block, size);
358 #else /* !HAVE_BDWGC */
359 /* We must call malloc explicitly when BLOCK is 0, since some
360 reallocs don't do this. */
361 void *val = block ? yrealloc(block, size) : ymalloc(size);
362 #endif /* HAVE_BDWGC */
364 if (!val && (size != 0))
370 #ifdef ERROR_CHECK_GC
373 typedef unsigned int four_byte_t;
374 #elif SIZEOF_LONG == 4
375 typedef unsigned long four_byte_t;
376 #elif SIZEOF_SHORT == 4
377 typedef unsigned short four_byte_t;
379 What kind of strange - ass system are we running on ?
381 #if !defined HAVE_BDWGC || !defined EF_USE_BDWGC
382 static void deadbeef_memory(void *ptr, size_t size)
384 four_byte_t *ptr4 = (four_byte_t *) ptr;
385 size_t beefs = size >> 2;
387 /* In practice, size will always be a multiple of four. */
389 (*ptr4++) = 0xDEADBEEF;
393 #else /* !ERROR_CHECK_GC */
395 #define deadbeef_memory(ptr, size)
397 #endif /* !ERROR_CHECK_GC */
400 #if !defined HAVE_BDWGC || !defined EF_USE_BDWGC
401 char *xstrdup(const char *str)
403 #ifdef ERROR_CHECK_MALLOC
404 #if SIZEOF_VOID_P == 4
405 /* Unbelievably, calling free() on 0xDEADBEEF doesn't cause an
406 error until much later on for many system mallocs, such as
407 the one that comes with Solaris 2.3. FMH!! */
408 assert(str != (void *)0xDEADBEEF);
409 #elif SIZEOF_VOID_P == 8
410 assert(str != (void*)0xCAFEBABEDEADBEEF);
412 #endif /* ERROR_CHECK_MALLOC */
414 int len = strlen(str)+1; /* for stupid terminating 0 */
416 void *val = xmalloc(len);
419 return (char*)memcpy(val, str, len);
425 #if !defined HAVE_STRDUP
426 /* will be a problem I think */
427 char *strdup(const char *s)
431 #endif /* !HAVE_STRDUP */
435 allocate_lisp_storage(size_t size)
437 return xmalloc(size);
440 #if defined HAVE_BDWGC && defined EF_USE_BDWGC && 0
442 lcrec_register_finaliser(struct lcrecord_header *b)
444 GC_finalization_proc *foo = NULL;
446 auto void lcrec_finaliser();
448 auto void lcrec_finaliser(void *obj, void *UNUSED(data))
450 const struct lrecord_implementation *lrimp =
451 XRECORD_LHEADER_IMPLEMENTATION(obj);
452 if (LIKELY(lrimp->finalizer != NULL)) {
453 SXE_DEBUG_GC("running the finaliser on %p :type %d\n",
455 lrimp->finalizer(obj, 0);
458 memset(obj, 0, sizeof(struct lcrecord_header));
462 SXE_DEBUG_GC("lcrec-fina %p\n", b);
463 GC_REGISTER_FINALIZER(b, lcrec_finaliser, NULL, foo, bar);
468 lcrec_register_finaliser(struct lcrecord_header *UNUSED(b))
472 #endif /* HAVE_BDWGC */
474 #if !defined HAVE_BDWGC || !defined EF_USE_BDWGC
475 /* lcrecords are chained together through their "next" field.
476 After doing the mark phase, GC will walk this linked list
477 and free any lcrecord which hasn't been marked. */
478 static struct lcrecord_header *all_lcrecords;
482 #if defined USE_MLY_UIDS
483 #define lcheader_set_uid(_x) (_x)->uid = lrecord_uid_counter++
484 #elif defined USE_JWZ_UIDS
485 #define lcheader_set_uid(_x) (_x)->uid = (long int)&(_x)
488 void *alloc_lcrecord(size_t size,
489 const struct lrecord_implementation *implementation)
491 struct lcrecord_header *lcheader;
494 ((implementation->static_size == 0 ?
495 implementation->size_in_bytes_method != NULL :
496 implementation->static_size == size)
497 && (!implementation->basic_p)
499 (!(implementation->hash == NULL
500 && implementation->equal != NULL)));
503 lcheader = (struct lcrecord_header *)allocate_lisp_storage(size);
504 lcrec_register_finaliser(lcheader);
505 set_lheader_implementation(&lcheader->lheader, implementation);
507 lcheader_set_uid(lcheader);
509 #if !defined HAVE_BDWGC || !defined EF_USE_BDWGC
510 lcheader->next = all_lcrecords;
511 all_lcrecords = lcheader;
512 INCREMENT_CONS_COUNTER(size, implementation->name);
518 static void disksave_object_finalization_1(void)
520 #if !defined HAVE_BDWGC || !defined EF_USE_BDWGC
521 struct lcrecord_header *header;
523 for (header = all_lcrecords; header; header = header->next) {
524 if (LHEADER_IMPLEMENTATION(&header->lheader)->finalizer &&
526 LHEADER_IMPLEMENTATION(&header->lheader)->
527 finalizer(header, 1);
532 /************************************************************************/
533 /* Debugger support */
534 /************************************************************************/
535 /* Give gdb/dbx enough information to decode Lisp Objects. We make
536 sure certain symbols are always defined, so gdb doesn't complain
537 about expressions in src/.gdbinit. See src/.gdbinit or src/.dbxrc
538 to see how this is used. */
540 EMACS_UINT dbg_valmask = ((1UL << VALBITS) - 1) << GCBITS;
541 EMACS_UINT dbg_typemask = (1UL << GCTYPEBITS) - 1;
543 unsigned char dbg_valbits = VALBITS;
544 unsigned char dbg_gctypebits = GCTYPEBITS;
546 /* On some systems, the above definitions will be optimized away by
547 the compiler or linker unless they are referenced in some function. */
548 long dbg_inhibit_dbg_symbol_deletion(void);
549 long dbg_inhibit_dbg_symbol_deletion(void)
551 return (dbg_valmask + dbg_typemask + dbg_valbits + dbg_gctypebits);
554 /* Macros turned into functions for ease of debugging.
555 Debuggers don't know about macros! */
556 int dbg_eq(Lisp_Object obj1, Lisp_Object obj2);
557 int dbg_eq(Lisp_Object obj1, Lisp_Object obj2)
559 return EQ(obj1, obj2);
562 /************************************************************************/
563 /* Fixed-size type macros */
564 /************************************************************************/
566 /* For fixed-size types that are commonly used, we malloc() large blocks
567 of memory at a time and subdivide them into chunks of the correct
568 size for an object of that type. This is more efficient than
569 malloc()ing each object separately because we save on malloc() time
570 and overhead due to the fewer number of malloc()ed blocks, and
571 also because we don't need any extra pointers within each object
572 to keep them threaded together for GC purposes. For less common
573 (and frequently large-size) types, we use lcrecords, which are
574 malloc()ed individually and chained together through a pointer
575 in the lcrecord header. lcrecords do not need to be fixed-size
576 (i.e. two objects of the same type need not have the same size;
577 however, the size of a particular object cannot vary dynamically).
578 It is also much easier to create a new lcrecord type because no
579 additional code needs to be added to alloc.c. Finally, lcrecords
580 may be more efficient when there are only a small number of them.
582 The types that are stored in these large blocks (or "frob blocks")
583 are cons, float, compiled-function, symbol, marker, extent, event,
586 Note that strings are special in that they are actually stored in
587 two parts: a structure containing information about the string, and
588 the actual data associated with the string. The former structure
589 (a struct Lisp_String) is a fixed-size structure and is managed the
590 same way as all the other such types. This structure contains a
591 pointer to the actual string data, which is stored in structures of
592 type struct string_chars_block. Each string_chars_block consists
593 of a pointer to a struct Lisp_String, followed by the data for that
594 string, followed by another pointer to a Lisp_String, followed by
595 the data for that string, etc. At GC time, the data in these
596 blocks is compacted by searching sequentially through all the
597 blocks and compressing out any holes created by unmarked strings.
598 Strings that are more than a certain size (bigger than the size of
599 a string_chars_block, although something like half as big might
600 make more sense) are malloc()ed separately and not stored in
601 string_chars_blocks. Furthermore, no one string stretches across
602 two string_chars_blocks.
604 Vectors are each malloc()ed separately, similar to lcrecords.
606 In the following discussion, we use conses, but it applies equally
607 well to the other fixed-size types.
609 We store cons cells inside of cons_blocks, allocating a new
610 cons_block with malloc() whenever necessary. Cons cells reclaimed
611 by GC are put on a free list to be reallocated before allocating
612 any new cons cells from the latest cons_block. Each cons_block is
613 just under 2^n - MALLOC_OVERHEAD bytes long, since malloc (at least
614 the versions in malloc.c and gmalloc.c) really allocates in units
615 of powers of two and uses 4 bytes for its own overhead.
617 What GC actually does is to search through all the cons_blocks,
618 from the most recently allocated to the oldest, and put all
619 cons cells that are not marked (whether or not they're already
620 free) on a cons_free_list. The cons_free_list is a stack, and
621 so the cons cells in the oldest-allocated cons_block end up
622 at the head of the stack and are the first to be reallocated.
623 If any cons_block is entirely free, it is freed with free()
624 and its cons cells removed from the cons_free_list. Because
625 the cons_free_list ends up basically in memory order, we have
626 a high locality of reference (assuming a reasonable turnover
627 of allocating and freeing) and have a reasonable probability
628 of entirely freeing up cons_blocks that have been more recently
629 allocated. This stage is called the "sweep stage" of GC, and
630 is executed after the "mark stage", which involves starting
631 from all places that are known to point to in-use Lisp objects
632 (e.g. the obarray, where are all symbols are stored; the
633 current catches and condition-cases; the backtrace list of
634 currently executing functions; the gcpro list; etc.) and
635 recursively marking all objects that are accessible.
637 At the beginning of the sweep stage, the conses in the cons blocks
638 are in one of three states: in use and marked, in use but not
639 marked, and not in use (already freed). Any conses that are marked
640 have been marked in the mark stage just executed, because as part
641 of the sweep stage we unmark any marked objects. The way we tell
642 whether or not a cons cell is in use is through the LRECORD_FREE_P
643 macro. This uses a special lrecord type `lrecord_type_free',
644 which is never associated with any valid object.
646 Conses on the free_cons_list are threaded through a pointer stored
647 in the conses themselves. Because the cons is still in a
648 cons_block and needs to remain marked as not in use for the next
649 time that GC happens, we need room to store both the "free"
650 indicator and the chaining pointer. So this pointer is stored
651 after the lrecord header (actually where C places a pointer after
652 the lrecord header; they are not necessarily contiguous). This
653 implies that all fixed-size types must be big enough to contain at
654 least one pointer. This is true for all current fixed-size types,
655 with the possible exception of Lisp_Floats, for which we define the
656 meat of the struct using a union of a pointer and a double to
657 ensure adequate space for the free list chain pointer.
659 Some types of objects need additional "finalization" done
660 when an object is converted from in use to not in use;
661 this is the purpose of the ADDITIONAL_FREE_type macro.
662 For example, markers need to be removed from the chain
663 of markers that is kept in each buffer. This is because
664 markers in a buffer automatically disappear if the marker
665 is no longer referenced anywhere (the same does not
666 apply to extents, however).
668 WARNING: Things are in an extremely bizarre state when
669 the ADDITIONAL_FREE_type macros are called, so beware!
671 When ERROR_CHECK_GC is defined, we do things differently so as to
672 maximize our chances of catching places where there is insufficient
673 GCPROing. The thing we want to avoid is having an object that
674 we're using but didn't GCPRO get freed by GC and then reallocated
675 while we're in the process of using it -- this will result in
676 something seemingly unrelated getting trashed, and is extremely
677 difficult to track down. If the object gets freed but not
678 reallocated, we can usually catch this because we set most of the
679 bytes of a freed object to 0xDEADBEEF. (The lisp object type is set
680 to the invalid type `lrecord_type_free', however, and a pointer
681 used to chain freed objects together is stored after the lrecord
682 header; we play some tricks with this pointer to make it more
683 bogus, so crashes are more likely to occur right away.)
685 We want freed objects to stay free as long as possible,
686 so instead of doing what we do above, we maintain the
687 free objects in a first-in first-out queue. We also
688 don't recompute the free list each GC, unlike above;
689 this ensures that the queue ordering is preserved.
690 [This means that we are likely to have worse locality
691 of reference, and that we can never free a frob block
692 once it's allocated. (Even if we know that all cells
693 in it are free, there's no easy way to remove all those
694 cells from the free list because the objects on the
695 free list are unlikely to be in memory order.)]
696 Furthermore, we never take objects off the free list
697 unless there's a large number (usually 1000, but
698 varies depending on type) of them already on the list.
699 This way, we ensure that an object that gets freed will
700 remain free for the next 1000 (or whatever) times that
701 an object of that type is allocated. */
703 #ifndef MALLOC_OVERHEAD
705 #define MALLOC_OVERHEAD 0
706 #elif defined (rcheck)
707 #define MALLOC_OVERHEAD 20
709 #define MALLOC_OVERHEAD 8
711 #endif /* MALLOC_OVERHEAD */
713 #if !defined(HAVE_MMAP) || defined(DOUG_LEA_MALLOC)
714 /* If we released our reserve (due to running out of memory),
715 and we have a fair amount free once again,
716 try to set aside another reserve in case we run out once more.
718 This is called when a relocatable block is freed in ralloc.c. */
719 void refill_memory_reserve(void);
720 void refill_memory_reserve(void)
722 if (breathing_space == 0)
723 breathing_space = (char *)malloc(4096 - MALLOC_OVERHEAD);
725 #endif /* !HAVE_MMAP || DOUG_LEA_MALLOC */
727 #ifdef ALLOC_NO_POOLS
728 # define TYPE_ALLOC_SIZE(type, structtype) 1
730 # define TYPE_ALLOC_SIZE(type, structtype) \
731 ((2048 - MALLOC_OVERHEAD - sizeof (struct type##_block *)) \
732 / sizeof (structtype))
733 #endif /* ALLOC_NO_POOLS */
735 #if defined HAVE_BDWGC && defined EF_USE_BDWGC
736 #define DECLARE_FIXED_TYPE_ALLOC(type, structtype) \
738 init_##type##_alloc(void) \
743 #define DECLARE_FIXED_TYPE_ALLOC(type, structtype) \
745 struct type##_block \
747 struct type##_block *prev; \
748 structtype block[TYPE_ALLOC_SIZE (type, structtype)]; \
751 static struct type##_block *current_##type##_block; \
752 static int current_##type##_block_index; \
754 static Lisp_Free *type##_free_list; \
755 static Lisp_Free *type##_free_list_tail; \
758 init_##type##_alloc (void) \
760 current_##type##_block = 0; \
761 current_##type##_block_index = \
762 countof (current_##type##_block->block); \
763 type##_free_list = 0; \
764 type##_free_list_tail = 0; \
767 static int gc_count_num_##type##_in_use; \
768 static int gc_count_num_##type##_freelist
769 #endif /* HAVE_BDWGC */
771 /* no need for a case distinction, shouldn't be called in bdwgc mode */
772 #define ALLOCATE_FIXED_TYPE_FROM_BLOCK(type, result) \
774 if (current_##type##_block_index \
775 == countof (current_##type##_block->block)) { \
776 struct type##_block *AFTFB_new = \
777 (struct type##_block *) \
778 allocate_lisp_storage( \
779 sizeof (struct type##_block)); \
780 AFTFB_new->prev = current_##type##_block; \
781 current_##type##_block = AFTFB_new; \
782 current_##type##_block_index = 0; \
784 (result) = &(current_##type##_block \
785 ->block[current_##type##_block_index++]); \
788 /* Allocate an instance of a type that is stored in blocks.
789 TYPE is the "name" of the type, STRUCTTYPE is the corresponding
792 #ifdef ERROR_CHECK_GC
794 /* Note: if you get crashes in this function, suspect incorrect calls
795 to free_cons() and friends. This happened once because the cons
796 cell was not GC-protected and was getting collected before
797 free_cons() was called. */
799 /* no need for a case distinction, shouldn't be called in bdwgc mode */
800 #define ALLOCATE_FIXED_TYPE_1(type, structtype, result) \
803 if (gc_count_num_##type##_freelist > \
804 MINIMUM_ALLOWED_FIXED_TYPE_CELLS_##type) { \
805 result = (structtype *) type##_free_list; \
806 /* Before actually using the chain pointer, \
807 we complement all its bits; \
808 see FREE_FIXED_TYPE(). */ \
809 type##_free_list = (Lisp_Free *) \
811 (type##_free_list->chain)); \
812 gc_count_num_##type##_freelist--; \
814 ALLOCATE_FIXED_TYPE_FROM_BLOCK (type, result); \
816 MARK_LRECORD_AS_NOT_FREE (result); \
817 unlock_allocator(); \
820 #else /* !ERROR_CHECK_GC */
822 /* no need for a case distinction, shouldn't be called in bdwgc mode */
823 #define ALLOCATE_FIXED_TYPE_1(type, structtype, result) \
825 if (type##_free_list) { \
826 result = (structtype *) type##_free_list; \
827 type##_free_list = type##_free_list->chain; \
829 ALLOCATE_FIXED_TYPE_FROM_BLOCK (type, result); \
831 MARK_LRECORD_AS_NOT_FREE (result); \
833 #endif /* !ERROR_CHECK_GC */
835 #if defined HAVE_BDWGC && defined EF_USE_BDWGC
837 #define ALLOCATE_FIXED_TYPE(type, structtype, result) \
839 result = xnew(structtype); \
840 INCREMENT_CONS_COUNTER(sizeof(structtype), #type); \
842 #define ALLOCATE_ATOMIC_FIXED_TYPE(type, structtype, result) \
844 result = xnew_atomic(structtype); \
845 INCREMENT_CONS_COUNTER(sizeof(structtype), #type); \
850 #define ALLOCATE_FIXED_TYPE(type, structtype, result) \
852 ALLOCATE_FIXED_TYPE_1 (type, structtype, result); \
853 INCREMENT_CONS_COUNTER (sizeof (structtype), #type); \
855 #define ALLOCATE_ATOMIC_FIXED_TYPE ALLOCATE_FIXED_TYPE
859 #if defined HAVE_BDWGC && defined EF_USE_BDWGC
860 #define NOSEEUM_ALLOCATE_FIXED_TYPE(type, structtype, result) \
861 (result) = xnew(structtype)
863 #define NOSEEUM_ALLOCATE_FIXED_TYPE(type, structtype, result) \
865 ALLOCATE_FIXED_TYPE_1 (type, structtype, result); \
866 NOSEEUM_INCREMENT_CONS_COUNTER(sizeof (structtype), #type); \
870 /* Lisp_Free is the type to represent a free list member inside a frob
871 block of any lisp object type. */
872 typedef struct Lisp_Free {
873 struct lrecord_header lheader;
874 struct Lisp_Free *chain;
877 #define LRECORD_FREE_P(ptr) \
878 ((ptr)->lheader.type == lrecord_type_free)
880 #define MARK_LRECORD_AS_FREE(ptr) \
881 ((void) ((ptr)->lheader.type = lrecord_type_free))
883 #ifdef ERROR_CHECK_GC
884 #define MARK_LRECORD_AS_NOT_FREE(ptr) \
885 ((void) ((ptr)->lheader.type = lrecord_type_undefined))
887 #define MARK_LRECORD_AS_NOT_FREE(ptr) DO_NOTHING
890 #ifdef ERROR_CHECK_GC
892 #define PUT_FIXED_TYPE_ON_FREE_LIST(type, structtype, ptr) \
894 if (type##_free_list_tail) { \
895 /* When we store the chain pointer, we \
896 complement all its bits; this should \
897 significantly increase its bogosity in case \
898 someone tries to use the value, and \
899 should make us crash faster if someone \
900 overwrites the pointer because when it gets \
901 un-complemented in ALLOCATED_FIXED_TYPE(), \
902 the resulting pointer will be extremely \
904 type##_free_list_tail->chain = \
905 (Lisp_Free *) ~ (EMACS_UINT) (ptr); \
907 type##_free_list = (Lisp_Free *) (ptr); \
909 type##_free_list_tail = (Lisp_Free *) (ptr); \
912 #else /* !ERROR_CHECK_GC */
914 #define PUT_FIXED_TYPE_ON_FREE_LIST(type, structtype, ptr) \
916 ((Lisp_Free *) (ptr))->chain = type##_free_list; \
917 type##_free_list = (Lisp_Free *) (ptr); \
920 #endif /* !ERROR_CHECK_GC */
922 /* TYPE and STRUCTTYPE are the same as in ALLOCATE_FIXED_TYPE(). */
924 #define FREE_FIXED_TYPE(type, structtype, ptr) \
926 structtype *FFT_ptr = (ptr); \
927 ADDITIONAL_FREE_##type (FFT_ptr); \
928 deadbeef_memory (FFT_ptr, sizeof (structtype)); \
929 PUT_FIXED_TYPE_ON_FREE_LIST(type, structtype, FFT_ptr); \
930 MARK_LRECORD_AS_FREE (FFT_ptr); \
933 /* Like FREE_FIXED_TYPE() but used when we are explicitly
934 freeing a structure through free_cons(), free_marker(), etc.
935 rather than through the normal process of sweeping.
936 We attempt to undo the changes made to the allocation counters
937 as a result of this structure being allocated. This is not
938 completely necessary but helps keep things saner: e.g. this way,
939 repeatedly allocating and freeing a cons will not result in
940 the consing-since-gc counter advancing, which would cause a GC
941 and somewhat defeat the purpose of explicitly freeing. */
943 #if defined HAVE_BDWGC && defined EF_USE_BDWGC
944 #define FREE_FIXED_TYPE_WHEN_NOT_IN_GC(type, structtype, ptr)
945 #else /* !HAVE_BDWGC */
946 #define FREE_FIXED_TYPE_WHEN_NOT_IN_GC(type, structtype, ptr) \
948 FREE_FIXED_TYPE (type, structtype, ptr); \
949 DECREMENT_CONS_COUNTER (sizeof (structtype)); \
950 gc_count_num_##type##_freelist++; \
952 #endif /* HAVE_BDWGC */
954 /************************************************************************/
955 /* Cons allocation */
956 /************************************************************************/
958 DECLARE_FIXED_TYPE_ALLOC(cons, Lisp_Cons);
959 /* conses are used and freed so often that we set this really high */
960 /* #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_cons 20000 */
961 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_cons 2000
963 #if defined HAVE_BDWGC && defined EF_USE_BDWGC && 0
965 cons_register_finaliser(Lisp_Cons *s)
967 GC_finalization_proc *foo = NULL;
969 auto void cons_finaliser();
971 auto void cons_finaliser(void *obj, void *UNUSED(data))
974 memset(obj, 0, sizeof(Lisp_Cons));
978 SXE_DEBUG_GC("cons-fina %p\n", s);
979 GC_REGISTER_FINALIZER(s, cons_finaliser, NULL, foo, bar);
984 cons_register_finaliser(Lisp_Cons *UNUSED(b))
988 #endif /* HAVE_BDWGC */
990 static Lisp_Object mark_cons(Lisp_Object obj)
995 mark_object(XCAR(obj));
999 static int cons_equal(Lisp_Object ob1, Lisp_Object ob2, int depth)
1002 while (internal_equal(XCAR(ob1), XCAR(ob2), depth)) {
1005 if (!CONSP(ob1) || !CONSP(ob2))
1006 return internal_equal(ob1, ob2, depth);
1011 /* the seq approach for conses */
1013 cons_length(const seq_t cons)
1016 GET_EXTERNAL_LIST_LENGTH((Lisp_Object)cons, len);
1021 cons_iter_init(seq_t cons, seq_iter_t si)
1023 si->data = si->seq = cons;
1028 cons_iter_next(seq_iter_t si, void **elt)
1030 if (si->data != NULL && CONSP(si->data)) {
1031 *elt = (void*)((Lisp_Cons*)si->data)->car;
1032 si->data = (void*)((Lisp_Cons*)si->data)->cdr;
1040 cons_iter_fini(seq_iter_t si)
1042 si->data = si->seq = NULL;
1047 cons_iter_reset(seq_iter_t si)
1054 cons_explode(void *restrict tgt[], size_t ntgt, const seq_t s)
1056 volatile size_t i = 0;
1057 volatile Lisp_Object c = (Lisp_Object)s;
1059 while (CONSP(c) && i < ntgt) {
1060 tgt[i++] = (void*)XCAR(c);
1066 static struct seq_impl_s __scons = {
1067 .length_f = cons_length,
1068 .iter_init_f = cons_iter_init,
1069 .iter_next_f = cons_iter_next,
1070 .iter_fini_f = cons_iter_fini,
1071 .iter_reset_f = cons_iter_reset,
1072 .explode_f = cons_explode,
1075 static const struct lrecord_description cons_description[] = {
1076 {XD_LISP_OBJECT, offsetof(Lisp_Cons, car)},
1077 {XD_LISP_OBJECT, offsetof(Lisp_Cons, cdr)},
1081 DEFINE_BASIC_LRECORD_IMPLEMENTATION("cons", cons,
1082 mark_cons, print_cons, 0, cons_equal,
1084 * No `hash' method needed.
1085 * internal_hash knows how to
1088 0, cons_description, Lisp_Cons);
1090 DEFUN("cons", Fcons, 2, 2, 0, /*
1091 Create a new cons, give it CAR and CDR as components, and return it.
1093 A cons cell is a Lisp object (an area in memory) made up of two pointers
1094 called the CAR and the CDR. Each of these pointers can point to any other
1095 Lisp object. The common Lisp data type, the list, is a specially-structured
1096 series of cons cells.
1098 The pointers are accessed from Lisp with `car' and `cdr', and mutated with
1099 `setcar' and `setcdr' respectively. For historical reasons, the aliases
1100 `rplaca' and `rplacd' (for `setcar' and `setcdr') are supported.
1104 /* This cannot GC. */
1108 ALLOCATE_FIXED_TYPE(cons, Lisp_Cons, c);
1109 set_lheader_implementation(&c->lheader, &lrecord_cons);
1110 cons_register_finaliser(c);
1114 /* propagate the cat system, go with the standard impl of a seq first */
1115 c->lheader.morphisms = 0;
1119 /* This is identical to Fcons() but it used for conses that we're
1120 going to free later, and is useful when trying to track down
1122 Lisp_Object noseeum_cons(Lisp_Object car, Lisp_Object cdr)
1127 NOSEEUM_ALLOCATE_FIXED_TYPE(cons, Lisp_Cons, c);
1128 set_lheader_implementation(&c->lheader, &lrecord_cons);
1132 /* propagate the cat system, go with the standard impl of a seq first */
1133 c->lheader.morphisms = 0;
1137 DEFUN("list", Flist, 0, MANY, 0, /*
1138 Return a newly created list with specified arguments as elements.
1139 Any number of arguments, even zero arguments, are allowed.
1141 (int nargs, Lisp_Object * args))
1143 Lisp_Object val = Qnil;
1144 Lisp_Object *argp = args + nargs;
1147 val = Fcons(*--argp, val);
1151 Lisp_Object list1(Lisp_Object obj0)
1153 /* This cannot GC. */
1154 return Fcons(obj0, Qnil);
1157 Lisp_Object list2(Lisp_Object obj0, Lisp_Object obj1)
1159 /* This cannot GC. */
1160 return Fcons(obj0, Fcons(obj1, Qnil));
1163 Lisp_Object list3(Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2)
1165 /* This cannot GC. */
1166 return Fcons(obj0, Fcons(obj1, Fcons(obj2, Qnil)));
1169 Lisp_Object cons3(Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2)
1171 /* This cannot GC. */
1172 return Fcons(obj0, Fcons(obj1, obj2));
1175 Lisp_Object acons(Lisp_Object key, Lisp_Object value, Lisp_Object alist)
1177 return Fcons(Fcons(key, value), alist);
1181 list4(Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2, Lisp_Object obj3)
1183 /* This cannot GC. */
1184 return Fcons(obj0, Fcons(obj1, Fcons(obj2, Fcons(obj3, Qnil))));
1188 list5(Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2, Lisp_Object obj3,
1191 /* This cannot GC. */
1193 Fcons(obj1, Fcons(obj2, Fcons(obj3, Fcons(obj4, Qnil)))));
1197 list6(Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2, Lisp_Object obj3,
1198 Lisp_Object obj4, Lisp_Object obj5)
1200 /* This cannot GC. */
1204 Fcons(obj3, Fcons(obj4, Fcons(obj5, Qnil))))));
1207 DEFUN("make-list", Fmake_list, 2, 2, 0, /*
1208 Return a new list of length LENGTH, with each element being OBJECT.
1212 CHECK_NATNUM(length);
1215 Lisp_Object val = Qnil;
1216 size_t size = XINT(length);
1219 val = Fcons(object, val);
1224 /************************************************************************/
1225 /* Float allocation */
1226 /************************************************************************/
1231 DECLARE_FIXED_TYPE_ALLOC(float, Lisp_Float);
1232 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_float 1000
1234 Lisp_Object make_float(fpfloat float_value)
1239 if (ENT_FLOAT_PINF_P(float_value))
1240 return make_indef(POS_INFINITY);
1241 else if (ENT_FLOAT_NINF_P(float_value))
1242 return make_indef(NEG_INFINITY);
1243 else if (ENT_FLOAT_NAN_P(float_value))
1244 return make_indef(NOT_A_NUMBER);
1246 ALLOCATE_FIXED_TYPE(float, Lisp_Float, f);
1248 /* Avoid dump-time `uninitialized memory read' purify warnings. */
1249 if (sizeof(struct lrecord_header) +
1250 sizeof(fpfloat) != sizeof(*f))
1253 set_lheader_implementation(&f->lheader, &lrecord_float);
1254 float_data(f) = float_value;
1259 #endif /* HAVE_FPFLOAT */
1261 /************************************************************************/
1262 /* Enhanced number allocation */
1263 /************************************************************************/
1266 #if defined HAVE_MPZ && (defined WITH_GMP || defined WITH_MP)
1267 DECLARE_FIXED_TYPE_ALLOC(bigz, Lisp_Bigz);
1268 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_bigz 250
1270 #if defined HAVE_BDWGC && defined EF_USE_BDWGC && 0
1272 bigz_register_finaliser(Lisp_Bigz *b)
1274 GC_finalization_proc *foo = NULL;
1276 auto void bigz_finaliser();
1278 auto void bigz_finaliser(void *obj, void *UNUSED(data))
1280 bigz_fini(bigz_data((Lisp_Bigz*)obj));
1282 memset(obj, 0, sizeof(Lisp_Bigz));
1286 GC_REGISTER_FINALIZER(b, bigz_finaliser, NULL, foo, bar);
1291 bigz_register_finaliser(Lisp_Bigz *UNUSED(b))
1295 #endif /* HAVE_BDWGC */
1297 /* WARNING: This function returns a bignum even if its argument fits into a
1298 fixnum. See Fcanonicalize_number(). */
1300 make_bigz (long bigz_value)
1304 ALLOCATE_FIXED_TYPE(bigz, Lisp_Bigz, b);
1305 bigz_register_finaliser(b);
1307 set_lheader_implementation(&b->lheader, &lrecord_bigz);
1308 bigz_init(bigz_data(b));
1309 bigz_set_long(bigz_data(b), bigz_value);
1310 return wrap_bigz(b);
1313 /* WARNING: This function returns a bigz even if its argument fits into a
1314 fixnum. See Fcanonicalize_number(). */
1316 make_bigz_bz (bigz bz)
1320 ALLOCATE_FIXED_TYPE(bigz, Lisp_Bigz, b);
1321 bigz_register_finaliser(b);
1323 set_lheader_implementation(&b->lheader, &lrecord_bigz);
1324 bigz_init(bigz_data(b));
1325 bigz_set(bigz_data(b), bz);
1326 return wrap_bigz(b);
1328 #endif /* HAVE_MPZ */
1331 #if defined HAVE_MPQ && defined WITH_GMP
1332 DECLARE_FIXED_TYPE_ALLOC(bigq, Lisp_Bigq);
1333 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_bigq 250
1335 #if defined HAVE_BDWGC && defined EF_USE_BDWGC && 0
1337 bigq_register_finaliser(Lisp_Bigq *b)
1339 GC_finalization_proc *foo = NULL;
1341 auto void bigq_finaliser();
1343 auto void bigq_finaliser(void *obj, void *UNUSED(data))
1345 bigq_fini(bigq_data((Lisp_Bigq*)obj));
1347 memset(obj, 0, sizeof(Lisp_Bigq));
1351 GC_REGISTER_FINALIZER(b, bigq_finaliser, NULL, foo, bar);
1356 bigq_register_finaliser(Lisp_Bigq *UNUSED(b))
1360 #endif /* HAVE_BDWGC */
1363 make_bigq(long numerator, unsigned long denominator)
1367 ALLOCATE_FIXED_TYPE(bigq, Lisp_Bigq, r);
1368 bigq_register_finaliser(r);
1370 set_lheader_implementation(&r->lheader, &lrecord_bigq);
1371 bigq_init(bigq_data(r));
1372 bigq_set_long_ulong(bigq_data(r), numerator, denominator);
1373 bigq_canonicalize(bigq_data(r));
1374 return wrap_bigq(r);
1378 make_bigq_bz(bigz numerator, bigz denominator)
1382 ALLOCATE_FIXED_TYPE(bigq, Lisp_Bigq, r);
1383 bigq_register_finaliser(r);
1385 set_lheader_implementation(&r->lheader, &lrecord_bigq);
1386 bigq_init(bigq_data(r));
1387 bigq_set_bigz_bigz(bigq_data(r), numerator, denominator);
1388 bigq_canonicalize(bigq_data(r));
1389 return wrap_bigq(r);
1393 make_bigq_bq(bigq rat)
1397 ALLOCATE_FIXED_TYPE(bigq, Lisp_Bigq, r);
1398 bigq_register_finaliser(r);
1400 set_lheader_implementation(&r->lheader, &lrecord_bigq);
1401 bigq_init(bigq_data(r));
1402 bigq_set(bigq_data(r), rat);
1403 return wrap_bigq(r);
1405 #endif /* HAVE_MPQ */
1408 #if defined HAVE_MPF && defined WITH_GMP
1409 DECLARE_FIXED_TYPE_ALLOC(bigf, Lisp_Bigf);
1410 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_bigf 250
1412 #if defined HAVE_BDWGC && defined EF_USE_BDWGC && 0
1414 bigf_register_finaliser(Lisp_Bigf *b)
1416 GC_finalization_proc *foo = NULL;
1418 auto void bigf_finaliser();
1420 auto void bigf_finaliser(void *obj, void *UNUSED(data))
1422 bigf_fini(bigf_data((Lisp_Bigf*)obj));
1424 memset(obj, 0, sizeof(Lisp_Bigf));
1428 GC_REGISTER_FINALIZER(b, bigf_finaliser, NULL, foo, bar);
1433 bigf_register_finaliser(Lisp_Bigf *UNUSED(b))
1437 #endif /* HAVE_BDWGC */
1439 /* This function creates a bigfloat with the default precision if the
1440 PRECISION argument is zero. */
1442 make_bigf(fpfloat float_value, unsigned long precision)
1446 ALLOCATE_FIXED_TYPE(bigf, Lisp_Bigf, f);
1447 bigf_register_finaliser(f);
1449 set_lheader_implementation(&f->lheader, &lrecord_bigf);
1450 if (precision == 0UL)
1451 bigf_init(bigf_data(f));
1453 bigf_init_prec(bigf_data(f), precision);
1454 bigf_set_fpfloat(bigf_data(f), float_value);
1455 return wrap_bigf(f);
1458 /* This function creates a bigfloat with the precision of its argument */
1460 make_bigf_bf(bigf float_value)
1464 ALLOCATE_FIXED_TYPE(bigf, Lisp_Bigf, f);
1465 bigf_register_finaliser(f);
1467 set_lheader_implementation(&f->lheader, &lrecord_bigf);
1468 bigf_init_prec(bigf_data(f), bigf_get_prec(float_value));
1469 bigf_set(bigf_data(f), float_value);
1470 return wrap_bigf(f);
1472 #endif /* HAVE_MPF */
1474 /*** Bigfloat with correct rounding ***/
1475 #if defined HAVE_MPFR && defined WITH_MPFR
1476 DECLARE_FIXED_TYPE_ALLOC(bigfr, Lisp_Bigfr);
1477 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_bigfr 250
1479 #if defined HAVE_BDWGC && defined EF_USE_BDWGC && 0
1481 bigfr_register_finaliser(Lisp_Bigfr *b)
1483 GC_finalization_proc *foo = NULL;
1485 auto void bigfr_finaliser();
1487 auto void bigfr_finaliser(void *obj, void *UNUSED(data))
1489 bigfr_fini(bigfr_data((Lisp_Bigfr*)obj));
1491 memset(obj, 0, sizeof(Lisp_Bigfr));
1495 GC_REGISTER_FINALIZER(b, bigfr_finaliser, NULL, foo, bar);
1500 bigfr_register_finaliser(Lisp_Bigfr *UNUSED(b))
1504 #endif /* HAVE_BDWGC */
1506 /* This function creates a bigfloat with the default precision if the
1507 PRECISION argument is zero. */
1509 make_bigfr(fpfloat float_value, unsigned long precision)
1513 ALLOCATE_FIXED_TYPE(bigfr, Lisp_Bigfr, f);
1514 set_lheader_implementation(&f->lheader, &lrecord_bigfr);
1515 bigfr_register_finaliser(f);
1517 if (precision == 0UL) {
1518 bigfr_init(bigfr_data(f));
1520 bigfr_init_prec(bigfr_data(f), precision);
1522 bigfr_set_fpfloat(bigfr_data(f), float_value);
1523 return wrap_bigfr(f);
1526 /* This function creates a bigfloat with the precision of its argument */
1528 make_bigfr_bf(bigf float_value)
1532 ALLOCATE_FIXED_TYPE(bigfr, Lisp_Bigfr, f);
1533 set_lheader_implementation(&f->lheader, &lrecord_bigfr);
1534 bigfr_register_finaliser(f);
1536 bigfr_init_prec(bigfr_data(f), bigf_get_prec(float_value));
1537 bigfr_set_bigf(bigfr_data(f), float_value);
1538 return wrap_bigfr(f);
1541 /* This function creates a bigfloat with the precision of its argument */
1543 make_bigfr_bfr(bigfr bfr_value)
1547 if (bigfr_nan_p(bfr_value) || bigfr_inf_p(bfr_value)) {
1548 return make_indef_bfr(bfr_value);
1551 ALLOCATE_FIXED_TYPE(bigfr, Lisp_Bigfr, f);
1552 set_lheader_implementation(&f->lheader, &lrecord_bigfr);
1553 bigfr_register_finaliser(f);
1555 bigfr_init_prec(bigfr_data(f), bigfr_get_prec(bfr_value));
1556 bigfr_set(bigfr_data(f), bfr_value);
1557 return wrap_bigfr(f);
1559 #endif /* HAVE_MPFR */
1561 /*** Big gaussian numbers ***/
1562 #if defined HAVE_PSEUG && defined HAVE_MPZ && defined WITH_PSEUG
1563 DECLARE_FIXED_TYPE_ALLOC(bigg, Lisp_Bigg);
1564 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_bigg 250
1566 #if defined HAVE_BDWGC && defined EF_USE_BDWGC && 0
1568 bigg_register_finaliser(Lisp_Bigg *b)
1570 GC_finalization_proc *foo = NULL;
1572 auto void bigg_finaliser();
1574 auto void bigg_finaliser(void *obj, void *UNUSED(data))
1576 bigg_fini(bigg_data((Lisp_Bigg*)obj));
1578 memset(obj, 0, sizeof(Lisp_Bigg));
1582 GC_REGISTER_FINALIZER(b, bigg_finaliser, NULL, foo, bar);
1587 bigg_register_finaliser(Lisp_Bigg *UNUSED(b))
1591 #endif /* HAVE_BDWGC */
1593 /* This function creates a gaussian number. */
1595 make_bigg(long intg, long imag)
1599 ALLOCATE_FIXED_TYPE(bigg, Lisp_Bigg, g);
1600 set_lheader_implementation(&g->lheader, &lrecord_bigg);
1601 bigg_register_finaliser(g);
1603 bigg_init(bigg_data(g));
1604 bigg_set_long_long(bigg_data(g), intg, imag);
1605 return wrap_bigg(g);
1608 /* This function creates a complex with the precision of its argument */
1610 make_bigg_bz(bigz intg, bigz imag)
1614 ALLOCATE_FIXED_TYPE(bigg, Lisp_Bigg, g);
1615 set_lheader_implementation(&g->lheader, &lrecord_bigg);
1616 bigg_register_finaliser(g);
1618 bigg_init(bigg_data(g));
1619 bigg_set_bigz_bigz(bigg_data(g), intg, imag);
1620 return wrap_bigg(g);
1623 /* This function creates a complex with the precision of its argument */
1625 make_bigg_bg(bigg gaussian_value)
1629 ALLOCATE_FIXED_TYPE(bigg, Lisp_Bigg, g);
1630 set_lheader_implementation(&g->lheader, &lrecord_bigg);
1631 bigg_register_finaliser(g);
1633 bigg_init(bigg_data(g));
1634 bigg_set(bigg_data(g), gaussian_value);
1635 return wrap_bigg(g);
1637 #endif /* HAVE_PSEUG */
1639 /*** Big complex numbers with correct rounding ***/
1640 #if defined HAVE_MPC && defined WITH_MPC || \
1641 defined HAVE_PSEUC && defined WITH_PSEUC
1642 DECLARE_FIXED_TYPE_ALLOC(bigc, Lisp_Bigc);
1643 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_bigc 250
1645 #if defined HAVE_BDWGC && defined EF_USE_BDWGC && 0
1647 bigc_register_finaliser(Lisp_Bigc *b)
1649 GC_finalization_proc *foo = NULL;
1651 auto void bigc_finaliser();
1653 auto void bigc_finaliser(void *obj, void *UNUSED(data))
1655 bigc_fini(bigc_data((Lisp_Bigc*)obj));
1657 memset(obj, 0, sizeof(Lisp_Bigc));
1661 GC_REGISTER_FINALIZER(b, bigc_finaliser, NULL, foo, bar);
1666 bigc_register_finaliser(Lisp_Bigc *UNUSED(b))
1670 #endif /* HAVE_BDWGC */
1672 /* This function creates a bigfloat with the default precision if the
1673 PRECISION argument is zero. */
1675 make_bigc(fpfloat re_value, fpfloat im_value, unsigned long precision)
1679 ALLOCATE_FIXED_TYPE(bigc, Lisp_Bigc, c);
1680 set_lheader_implementation(&c->lheader, &lrecord_bigc);
1681 bigc_register_finaliser(c);
1683 if (precision == 0UL) {
1684 bigc_init(bigc_data(c));
1686 bigc_init_prec(bigc_data(c), precision);
1688 bigc_set_fpfloat_fpfloat(bigc_data(c), re_value, im_value);
1689 return wrap_bigc(c);
1692 /* This function creates a complex with the precision of its argument */
1694 make_bigc_bfr(bigfr re_value, bigfr im_value, unsigned long precision)
1698 ALLOCATE_FIXED_TYPE(bigc, Lisp_Bigc, c);
1699 set_lheader_implementation(&c->lheader, &lrecord_bigc);
1700 bigc_register_finaliser(c);
1702 if (precision == 0UL) {
1703 bigc_init(bigc_data(c));
1705 bigc_init_prec(bigc_data(c), precision);
1707 bigc_set_bigfr_bigfr(bigc_data(c), re_value, im_value);
1708 return wrap_bigc(c);
1711 /* This function creates a complex with the precision of its argument */
1713 make_bigc_bc(bigc complex_value)
1717 ALLOCATE_FIXED_TYPE(bigc, Lisp_Bigc, c);
1718 set_lheader_implementation(&c->lheader, &lrecord_bigc);
1719 bigc_register_finaliser(c);
1721 bigc_init_prec(bigc_data(c), bigc_get_prec(complex_value));
1722 bigc_set(bigc_data(c), complex_value);
1723 return wrap_bigc(c);
1725 #endif /* HAVE_MPC */
1727 /*** Quaternions ***/
1728 #if defined HAVE_QUATERN && defined HAVE_MPZ && defined WITH_QUATERN
1729 DECLARE_FIXED_TYPE_ALLOC(quatern, Lisp_Quatern);
1730 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_quatern 250
1732 #if defined HAVE_BDWGC && defined EF_USE_BDWGC && 0
1734 quatern_register_finaliser(Lisp_Quatern *b)
1736 GC_finalization_proc *foo = NULL;
1738 auto void quatern_finaliser();
1740 auto void quatern_finaliser(void *obj, void *UNUSED(data))
1742 quatern_fini(quatern_data((Lisp_Quatern*)obj));
1744 memset(obj, 0, sizeof(Lisp_Quatern));
1748 GC_REGISTER_FINALIZER(b, quatern_finaliser, NULL, foo, bar);
1753 quatern_register_finaliser(Lisp_Quatern *UNUSED(b))
1757 #endif /* HAVE_BDWGC */
1759 /* This function creates a quaternion. */
1761 make_quatern(EMACS_INT z, EMACS_INT i, EMACS_INT j, EMACS_INT k)
1765 ALLOCATE_FIXED_TYPE(quatern, Lisp_Quatern, g);
1766 set_lheader_implementation(&g->lheader, &lrecord_quatern);
1767 quatern_register_finaliser(g);
1769 quatern_init(quatern_data(g));
1770 quatern_set_long_long_long_long(quatern_data(g), z, i, j, k);
1771 return wrap_quatern(g);
1775 make_quatern_bz(bigz z, bigz i, bigz j, bigz k)
1779 ALLOCATE_FIXED_TYPE(quatern, Lisp_Quatern, g);
1780 set_lheader_implementation(&g->lheader, &lrecord_quatern);
1781 quatern_register_finaliser(g);
1783 quatern_init(quatern_data(g));
1784 quatern_set_bigz_bigz_bigz_bigz(quatern_data(g), z, i, j, k);
1785 return wrap_quatern(g);
1789 make_quatern_qu(quatern quaternion)
1793 ALLOCATE_FIXED_TYPE(quatern, Lisp_Quatern, g);
1794 set_lheader_implementation(&g->lheader, &lrecord_quatern);
1795 quatern_register_finaliser(g);
1797 quatern_init(quatern_data(g));
1798 quatern_set(quatern_data(g), quaternion);
1799 return wrap_quatern(g);
1801 #endif /* HAVE_QUATERN */
1804 make_indef_internal(indef sym)
1808 i = allocate_lisp_storage(sizeof(Lisp_Indef));
1809 set_lheader_implementation(&i->lheader, &lrecord_indef);
1810 indef_data(i) = sym;
1811 return wrap_indef(i);
1815 make_indef(indef sym)
1822 case COMPLEX_INFINITY:
1823 return Vcomplex_infinity;
1826 /* list some more here */
1827 case END_OF_COMPARABLE_INFINITIES:
1828 case END_OF_INFINITIES:
1830 return Vnot_a_number;
1834 #if defined HAVE_MPFR && defined WITH_MPFR
1836 make_indef_bfr(bigfr bfr_value)
1838 if (bigfr_nan_p(bfr_value)) {
1839 return make_indef(NOT_A_NUMBER);
1840 } else if (bigfr_inf_p(bfr_value)) {
1841 if (bigfr_sign(bfr_value) > 0)
1842 return make_indef(POS_INFINITY);
1844 return make_indef(NEG_INFINITY);
1846 return make_indef(NOT_A_NUMBER);
1851 DECLARE_FIXED_TYPE_ALLOC(dynacat, struct dynacat_s);
1852 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_dynacat 1000
1854 #if defined HAVE_BDWGC && defined EF_USE_BDWGC
1856 dynacat_register_finaliser(dynacat_t b)
1858 GC_finalization_proc *foo = NULL;
1860 auto void dynacat_finaliser();
1862 auto void dynacat_finaliser(void *obj, void *UNUSED(data))
1864 SXE_DEBUG_GC("calling dynacat finaliser on %p\n", obj);
1867 memset(obj, 0, sizeof(struct dynacat_s));
1871 SXE_DEBUG_GC("dynacat-fina %p\n", b);
1872 GC_REGISTER_FINALIZER(b, dynacat_finaliser, NULL, foo, bar);
1877 dynacat_register_finaliser(dynacat_t UNUSED(b))
1881 #endif /* HAVE_BDWGC */
1884 make_dynacat(void *ptr)
1888 ALLOCATE_FIXED_TYPE(dynacat, struct dynacat_s, emp);
1889 dynacat_register_finaliser(emp);
1890 set_lheader_implementation(&emp->lheader, &lrecord_dynacat);
1893 emp->intprfun = NULL;
1900 return wrap_object(emp);
1904 /************************************************************************/
1905 /* Vector allocation */
1906 /************************************************************************/
1908 static Lisp_Object mark_vector(Lisp_Object obj)
1910 Lisp_Vector *ptr = XVECTOR(obj);
1911 int len = vector_length(ptr);
1914 for (i = 0; i < len - 1; i++)
1915 mark_object(ptr->contents[i]);
1916 return (len > 0) ? ptr->contents[len - 1] : Qnil;
1919 static size_t size_vector(const void *lheader)
1921 return FLEXIBLE_ARRAY_STRUCT_SIZEOF(
1922 Lisp_Vector, Lisp_Object, contents,
1923 ((const Lisp_Vector*)lheader)->size);
1926 static int vector_equal(Lisp_Object obj1, Lisp_Object obj2, int depth)
1928 int len = XVECTOR_LENGTH(obj1);
1929 if (len != XVECTOR_LENGTH(obj2))
1933 Lisp_Object *ptr1 = XVECTOR_DATA(obj1);
1934 Lisp_Object *ptr2 = XVECTOR_DATA(obj2);
1936 if (!internal_equal(*ptr1++, *ptr2++, depth + 1))
1942 static hcode_t vector_hash(Lisp_Object obj, int depth)
1944 return HASH2(XVECTOR_LENGTH(obj),
1945 internal_array_hash(XVECTOR_DATA(obj),
1946 XVECTOR_LENGTH(obj), depth + 1));
1949 /* the seq approach for conses */
1951 vec_length(const seq_t v)
1953 return XVECTOR_LENGTH((Lisp_Object)(long int)v);
1957 vec_iter_init(seq_t v, seq_iter_t si)
1960 si->data = (void*)0;
1965 vec_iter_next(seq_iter_t si, void **elt)
1967 if (si->seq != NULL &&
1968 (long int)si->data < ((Lisp_Vector*)si->seq)->size) {
1969 *elt = (void*)vector_data((Lisp_Vector*)si->seq)
1970 [(long int)si->data];
1971 si->data = (void*)((long int)si->data + 1L);
1979 vec_iter_fini(seq_iter_t si)
1981 si->data = si->seq = NULL;
1986 vec_iter_reset(seq_iter_t si)
1988 si->data = (void*)0;
1993 vec_explode(void *restrict tgt[], size_t ntgt, const seq_t s)
1995 size_t len = vector_length((const Lisp_Vector*)s);
1996 volatile size_t i = 0;
1998 while (i < len && i < ntgt) {
1999 tgt[i] = (void*)vector_data((const Lisp_Vector*)s)[i];
2005 static struct seq_impl_s __svec = {
2006 .length_f = vec_length,
2007 .iter_init_f = vec_iter_init,
2008 .iter_next_f = vec_iter_next,
2009 .iter_fini_f = vec_iter_fini,
2010 .iter_reset_f = vec_iter_reset,
2011 .explode_f = vec_explode,
2014 static const struct lrecord_description vector_description[] = {
2015 {XD_LONG, offsetof(Lisp_Vector, size)},
2016 {XD_LISP_OBJECT_ARRAY, offsetof(Lisp_Vector, contents),
2021 DEFINE_LRECORD_SEQUENCE_IMPLEMENTATION("vector", vector,
2022 mark_vector, print_vector, 0,
2026 size_vector, Lisp_Vector);
2028 /* #### should allocate `small' vectors from a frob-block */
2029 static Lisp_Vector *make_vector_internal(size_t sizei)
2031 /* no vector_next */
2032 size_t sizem = FLEXIBLE_ARRAY_STRUCT_SIZEOF(Lisp_Vector, Lisp_Object,
2034 Lisp_Vector *p = (Lisp_Vector *) alloc_lcrecord(sizem, &lrecord_vector);
2037 p->header.lheader.morphisms = (1<<cat_mk_lc);
2041 Lisp_Object make_vector(size_t length, Lisp_Object object)
2043 Lisp_Vector *vecp = make_vector_internal(length);
2044 Lisp_Object *p = vector_data(vecp);
2051 XSETVECTOR(vector, vecp);
2056 DEFUN("make-vector", Fmake_vector, 2, 2, 0, /*
2057 Return a new vector of length LENGTH, with each element being OBJECT.
2058 See also the function `vector'.
2062 CONCHECK_NATNUM(length);
2063 return make_vector(XINT(length), object);
2066 DEFUN("vector", Fvector, 0, MANY, 0, /*
2067 Return a newly created vector with specified arguments as elements.
2068 Any number of arguments, even zero arguments, are allowed.
2070 (int nargs, Lisp_Object * args))
2072 Lisp_Vector *vecp = make_vector_internal(nargs);
2073 Lisp_Object *p = vector_data(vecp);
2080 XSETVECTOR(vector, vecp);
2085 Lisp_Object vector1(Lisp_Object obj0)
2087 return Fvector(1, &obj0);
2090 Lisp_Object vector2(Lisp_Object obj0, Lisp_Object obj1)
2092 Lisp_Object args[2];
2095 return Fvector(2, args);
2098 Lisp_Object vector3(Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2)
2100 Lisp_Object args[3];
2104 return Fvector(3, args);
2107 #if 0 /* currently unused */
2110 vector4(Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2, Lisp_Object obj3)
2112 Lisp_Object args[4];
2117 return Fvector(4, args);
2121 vector5(Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
2122 Lisp_Object obj3, Lisp_Object obj4)
2124 Lisp_Object args[5];
2130 return Fvector(5, args);
2134 vector6(Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
2135 Lisp_Object obj3, Lisp_Object obj4, Lisp_Object obj5)
2137 Lisp_Object args[6];
2144 return Fvector(6, args);
2148 vector7(Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
2149 Lisp_Object obj3, Lisp_Object obj4, Lisp_Object obj5, Lisp_Object obj6)
2151 Lisp_Object args[7];
2159 return Fvector(7, args);
2163 vector8(Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
2164 Lisp_Object obj3, Lisp_Object obj4, Lisp_Object obj5,
2165 Lisp_Object obj6, Lisp_Object obj7)
2167 Lisp_Object args[8];
2176 return Fvector(8, args);
2180 /************************************************************************/
2181 /* Bit Vector allocation */
2182 /************************************************************************/
2184 static Lisp_Object all_bit_vectors;
2186 /* #### should allocate `small' bit vectors from a frob-block */
2187 static Lisp_Bit_Vector *make_bit_vector_internal(size_t sizei)
2189 size_t num_longs = BIT_VECTOR_LONG_STORAGE(sizei);
2191 FLEXIBLE_ARRAY_STRUCT_SIZEOF(Lisp_Bit_Vector, unsigned long,
2193 Lisp_Bit_Vector *p = (Lisp_Bit_Vector *) allocate_lisp_storage(sizem);
2194 set_lheader_implementation(&p->lheader, &lrecord_bit_vector);
2196 INCREMENT_CONS_COUNTER(sizem, "bit-vector");
2198 bit_vector_length(p) = sizei;
2199 bit_vector_next(p) = all_bit_vectors;
2200 /* make sure the extra bits in the last long are 0; the calling
2201 functions might not set them. */
2202 p->bits[num_longs - 1] = 0;
2203 XSETBIT_VECTOR(all_bit_vectors, p);
2205 /* propagate seq implementation */
2206 p->lheader.morphisms = 0;
2210 Lisp_Object make_bit_vector(size_t length, Lisp_Object bit)
2212 Lisp_Bit_Vector *p = make_bit_vector_internal(length);
2213 size_t num_longs = BIT_VECTOR_LONG_STORAGE(length);
2218 memset(p->bits, 0, num_longs * sizeof(long));
2220 size_t bits_in_last = length & (LONGBITS_POWER_OF_2 - 1);
2221 memset(p->bits, ~0, num_longs * sizeof(long));
2222 /* But we have to make sure that the unused bits in the
2223 last long are 0, so that equal/hash is easy. */
2225 p->bits[num_longs - 1] &= (1 << bits_in_last) - 1;
2229 Lisp_Object bit_vector;
2230 XSETBIT_VECTOR(bit_vector, p);
2236 make_bit_vector_from_byte_vector(unsigned char *bytevec, size_t length)
2239 Lisp_Bit_Vector *p = make_bit_vector_internal(length);
2241 for (i = 0; i < length; i++)
2242 set_bit_vector_bit(p, i, bytevec[i]);
2245 Lisp_Object bit_vector;
2246 XSETBIT_VECTOR(bit_vector, p);
2251 DEFUN("make-bit-vector", Fmake_bit_vector, 2, 2, 0, /*
2252 Return a new bit vector of length LENGTH. with each bit set to BIT.
2253 BIT must be one of the integers 0 or 1. See also the function `bit-vector'.
2257 CONCHECK_NATNUM(length);
2259 return make_bit_vector(XINT(length), bit);
2262 DEFUN("bit-vector", Fbit_vector, 0, MANY, 0, /*
2263 Return a newly created bit vector with specified arguments as elements.
2264 Any number of arguments, even zero arguments, are allowed.
2265 Each argument must be one of the integers 0 or 1.
2267 (int nargs, Lisp_Object * args))
2270 Lisp_Bit_Vector *p = make_bit_vector_internal(nargs);
2272 for (i = 0; i < nargs; i++) {
2274 set_bit_vector_bit(p, i, !ZEROP(args[i]));
2278 Lisp_Object bit_vector;
2279 XSETBIT_VECTOR(bit_vector, p);
2284 /* the seq approach for conses */
2286 bvc_length(const seq_t bv)
2288 return bit_vector_length(XBIT_VECTOR((Lisp_Object)(long int)bv));
2292 bvc_iter_init(seq_t bv, seq_iter_t si)
2295 si->data = (void*)0;
2300 bvc_iter_next(seq_iter_t si, void **elt)
2302 if (si->seq != NULL &&
2303 (long int)si->data < bit_vector_length((Lisp_Bit_Vector*)si->seq)) {
2304 *elt = (void*)make_int(
2306 (Lisp_Bit_Vector*)si->seq, (size_t)si->data));
2307 si->data = (void*)((long int)si->data + 1L);
2315 bvc_iter_fini(seq_iter_t si)
2317 si->data = si->seq = NULL;
2322 bvc_iter_reset(seq_iter_t si)
2324 si->data = (void*)0;
2329 bvc_explode(void *restrict tgt[], size_t ntgt, const seq_t s)
2331 size_t len = bit_vector_length((const Lisp_Bit_Vector*)s);
2332 volatile size_t i = 0;
2334 while (i < len && i < ntgt) {
2335 tgt[i] = (void*)make_int(
2336 bit_vector_bit((const Lisp_Bit_Vector*)s, i));
2342 static struct seq_impl_s __sbvc = {
2343 .length_f = bvc_length,
2344 .iter_init_f = bvc_iter_init,
2345 .iter_next_f = bvc_iter_next,
2346 .iter_fini_f = bvc_iter_fini,
2347 .iter_reset_f = bvc_iter_reset,
2348 .explode_f = bvc_explode,
2351 /************************************************************************/
2352 /* Compiled-function allocation */
2353 /************************************************************************/
2355 DECLARE_FIXED_TYPE_ALLOC(compiled_function, Lisp_Compiled_Function);
2356 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_compiled_function 1000
2358 static Lisp_Object make_compiled_function(void)
2360 Lisp_Compiled_Function *f;
2363 ALLOCATE_FIXED_TYPE(compiled_function, Lisp_Compiled_Function, f);
2364 set_lheader_implementation(&f->lheader, &lrecord_compiled_function);
2367 f->specpdl_depth = 0;
2368 f->flags.documentationp = 0;
2369 f->flags.interactivep = 0;
2370 f->flags.domainp = 0; /* I18N3 */
2371 f->instructions = Qzero;
2372 f->constants = Qzero;
2374 f->doc_and_interactive = Qnil;
2375 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
2376 f->annotated = Qnil;
2378 XSETCOMPILED_FUNCTION(fun, f);
2382 DEFUN("make-byte-code", Fmake_byte_code, 4, MANY, 0, /*
2383 Return a new compiled-function object.
2384 Usage: (arglist instructions constants stack-depth
2385 &optional doc-string interactive)
2386 Note that, unlike all other emacs-lisp functions, calling this with five
2387 arguments is NOT the same as calling it with six arguments, the last of
2388 which is nil. If the INTERACTIVE arg is specified as nil, then that means
2389 that this function was defined with `(interactive)'. If the arg is not
2390 specified, then that means the function is not interactive.
2391 This is terrible behavior which is retained for compatibility with old
2392 `.elc' files which expect these semantics.
2394 (int nargs, Lisp_Object * args))
2396 /* In a non-insane world this function would have this arglist...
2397 (arglist instructions constants stack_depth &optional doc_string interactive)
2399 Lisp_Object fun = make_compiled_function();
2400 Lisp_Compiled_Function *f = XCOMPILED_FUNCTION(fun);
2402 Lisp_Object arglist = args[0];
2403 Lisp_Object instructions = args[1];
2404 Lisp_Object constants = args[2];
2405 Lisp_Object stack_depth = args[3];
2406 Lisp_Object doc_string = (nargs > 4) ? args[4] : Qnil;
2407 Lisp_Object interactive = (nargs > 5) ? args[5] : Qunbound;
2409 if (nargs < 4 || nargs > 6)
2410 return Fsignal(Qwrong_number_of_arguments,
2411 list2(intern("make-byte-code"),
2414 /* Check for valid formal parameter list now, to allow us to use
2415 SPECBIND_FAST_UNSAFE() later in funcall_compiled_function(). */
2417 EXTERNAL_LIST_LOOP_3(symbol, arglist, tail) {
2418 CHECK_SYMBOL(symbol);
2419 if (EQ(symbol, Qt) ||
2420 EQ(symbol, Qnil) || SYMBOL_IS_KEYWORD(symbol))
2421 signal_simple_error_2
2422 ("Invalid constant symbol in formal parameter list",
2426 f->arglist = arglist;
2428 /* `instructions' is a string or a cons (string . int) for a
2429 lazy-loaded function. */
2430 if (CONSP(instructions)) {
2431 CHECK_STRING(XCAR(instructions));
2432 CHECK_INT(XCDR(instructions));
2434 CHECK_STRING(instructions);
2436 f->instructions = instructions;
2438 if (!NILP(constants))
2439 CHECK_VECTOR(constants);
2440 f->constants = constants;
2442 CHECK_NATNUM(stack_depth);
2443 f->stack_depth = (unsigned short)XINT(stack_depth);
2445 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
2446 if (!NILP(Vcurrent_compiled_function_annotation))
2447 f->annotated = Fcopy(Vcurrent_compiled_function_annotation);
2448 else if (!NILP(Vload_file_name_internal_the_purecopy))
2449 f->annotated = Vload_file_name_internal_the_purecopy;
2450 else if (!NILP(Vload_file_name_internal)) {
2451 struct gcpro gcpro1;
2452 GCPRO1(fun); /* don't let fun get reaped */
2453 Vload_file_name_internal_the_purecopy =
2454 Ffile_name_nondirectory(Vload_file_name_internal);
2455 f->annotated = Vload_file_name_internal_the_purecopy;
2458 #endif /* COMPILED_FUNCTION_ANNOTATION_HACK */
2460 /* doc_string may be nil, string, int, or a cons (string . int).
2461 interactive may be list or string (or unbound). */
2462 f->doc_and_interactive = Qunbound;
2464 if ((f->flags.domainp = !NILP(Vfile_domain)) != 0)
2465 f->doc_and_interactive = Vfile_domain;
2467 if ((f->flags.interactivep = !UNBOUNDP(interactive)) != 0) {
2468 f->doc_and_interactive
2469 = (UNBOUNDP(f->doc_and_interactive) ? interactive :
2470 Fcons(interactive, f->doc_and_interactive));
2472 if ((f->flags.documentationp = !NILP(doc_string)) != 0) {
2473 f->doc_and_interactive
2474 = (UNBOUNDP(f->doc_and_interactive) ? doc_string :
2475 Fcons(doc_string, f->doc_and_interactive));
2477 if (UNBOUNDP(f->doc_and_interactive))
2478 f->doc_and_interactive = Qnil;
2483 /************************************************************************/
2484 /* Symbol allocation */
2485 /************************************************************************/
2487 DECLARE_FIXED_TYPE_ALLOC(symbol, Lisp_Symbol);
2488 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_symbol 1000
2490 DEFUN("make-symbol", Fmake_symbol, 1, 1, 0, /*
2491 Return a newly allocated uninterned symbol whose name is NAME.
2492 Its value and function definition are void, and its property list is nil.
2501 ALLOCATE_FIXED_TYPE(symbol, Lisp_Symbol, p);
2502 set_lheader_implementation(&p->lheader, &lrecord_symbol);
2503 p->name = XSTRING(name);
2505 p->value = Qunbound;
2506 p->function = Qunbound;
2512 /************************************************************************/
2513 /* Extent allocation */
2514 /************************************************************************/
2516 DECLARE_FIXED_TYPE_ALLOC(extent, struct extent);
2517 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_extent 1000
2519 struct extent *allocate_extent(void)
2523 ALLOCATE_FIXED_TYPE(extent, struct extent, e);
2524 set_lheader_implementation(&e->lheader, &lrecord_extent);
2525 extent_object(e) = Qnil;
2526 set_extent_start(e, -1);
2527 set_extent_end(e, -1);
2532 extent_face(e) = Qnil;
2533 e->flags.end_open = 1; /* default is for endpoints to behave like markers */
2534 e->flags.detachable = 1;
2539 /************************************************************************/
2540 /* Event allocation */
2541 /************************************************************************/
2543 DECLARE_FIXED_TYPE_ALLOC(event, Lisp_Event);
2544 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_event 1000
2546 Lisp_Object allocate_event(void)
2551 ALLOCATE_FIXED_TYPE(event, Lisp_Event, e);
2552 set_lheader_implementation(&e->lheader, &lrecord_event);
2558 /************************************************************************/
2559 /* Marker allocation */
2560 /************************************************************************/
2562 DECLARE_FIXED_TYPE_ALLOC(marker, Lisp_Marker);
2563 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_marker 1000
2565 DEFUN("make-marker", Fmake_marker, 0, 0, 0, /*
2566 Return a new marker which does not point at any place.
2573 ALLOCATE_FIXED_TYPE(marker, Lisp_Marker, p);
2574 set_lheader_implementation(&p->lheader, &lrecord_marker);
2579 p->insertion_type = 0;
2584 Lisp_Object noseeum_make_marker(void)
2589 NOSEEUM_ALLOCATE_FIXED_TYPE(marker, Lisp_Marker, p);
2590 set_lheader_implementation(&p->lheader, &lrecord_marker);
2595 p->insertion_type = 0;
2600 /************************************************************************/
2601 /* String allocation */
2602 /************************************************************************/
2604 /* The data for "short" strings generally resides inside of structs of type
2605 string_chars_block. The Lisp_String structure is allocated just like any
2606 other Lisp object (except for vectors), and these are freelisted when
2607 they get garbage collected. The data for short strings get compacted,
2608 but the data for large strings do not.
2610 Previously Lisp_String structures were relocated, but this caused a lot
2611 of bus-errors because the C code didn't include enough GCPRO's for
2612 strings (since EVERY REFERENCE to a short string needed to be GCPRO'd so
2613 that the reference would get relocated).
2615 This new method makes things somewhat bigger, but it is MUCH safer. */
2617 DECLARE_FIXED_TYPE_ALLOC(string, Lisp_String);
2618 /* strings are used and freed quite often */
2619 /* #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_string 10000 */
2620 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_string 1000
2622 #if defined HAVE_BDWGC && defined EF_USE_BDWGC && 0
2624 string_register_finaliser(Lisp_String *s)
2626 GC_finalization_proc *foo = NULL;
2628 auto void string_finaliser();
2630 auto void string_finaliser(void *obj, void *UNUSED(data))
2632 if (!(((Lisp_String*)obj)->lheader.c_readonly)) {
2633 yfree(((Lisp_String*)obj)->data);
2636 memset(obj, 0, sizeof(Lisp_String));
2640 SXE_DEBUG_GC("string-fina %p\n", s);
2641 GC_REGISTER_FINALIZER(s, string_finaliser, NULL, foo, bar);
2646 string_register_finaliser(Lisp_String *UNUSED(b))
2650 #endif /* HAVE_BDWGC */
2652 static Lisp_Object mark_string(Lisp_Object obj)
2654 Lisp_String *ptr = XSTRING(obj);
2656 if (CONSP(ptr->plist) && EXTENT_INFOP(XCAR(ptr->plist)))
2657 flush_cached_extent_info(XCAR(ptr->plist));
2658 #ifdef EF_USE_COMPRE
2659 mark_object(ptr->compre);
2664 static int string_equal(Lisp_Object obj1, Lisp_Object obj2, int depth)
2667 return (((len = XSTRING_LENGTH(obj1)) == XSTRING_LENGTH(obj2)) &&
2668 !memcmp(XSTRING_DATA(obj1), XSTRING_DATA(obj2), len));
2671 static const struct lrecord_description string_description[] = {
2672 {XD_BYTECOUNT, offsetof(Lisp_String, size)},
2673 {XD_OPAQUE_DATA_PTR, offsetof(Lisp_String, data), XD_INDIRECT(0, 1)},
2674 #ifdef EF_USE_COMPRE
2675 {XD_LISP_OBJECT, offsetof(Lisp_String, compre)},
2677 {XD_LISP_OBJECT, offsetof(Lisp_String, plist)},
2681 /* the seq implementation */
2683 str_length(const seq_t str)
2685 return string_char_length((const Lisp_String*)str);
2689 str_iter_init(seq_t str, seq_iter_t si)
2692 si->data = (void*)0;
2697 str_iter_next(seq_iter_t si, void **elt)
2699 if (si->seq != NULL &&
2700 (long int)si->data < string_char_length((Lisp_String*)si->seq)) {
2701 *elt = (void*)make_char(
2702 string_char((Lisp_String*)si->seq, (long int)si->data));
2703 si->data = (void*)((long int)si->data + 1);
2711 str_iter_fini(seq_iter_t si)
2713 si->data = si->seq = NULL;
2718 str_iter_reset(seq_iter_t si)
2720 si->data = (void*)0;
2725 str_explode(void *restrict tgt[], size_t ntgt, const seq_t s)
2727 size_t len = string_char_length((const Lisp_String*)s);
2728 volatile size_t i = 0;
2730 while (i < len && i < ntgt) {
2731 tgt[i] = (void*)make_char(string_char((Lisp_String*)s, i));
2737 static struct seq_impl_s __sstr = {
2738 .length_f = str_length,
2739 .iter_init_f = str_iter_init,
2740 .iter_next_f = str_iter_next,
2741 .iter_fini_f = str_iter_fini,
2742 .iter_reset_f = str_iter_reset,
2743 .explode_f = str_explode,
2747 /* We store the string's extent info as the first element of the string's
2748 property list; and the string's MODIFF as the first or second element
2749 of the string's property list (depending on whether the extent info
2750 is present), but only if the string has been modified. This is ugly
2751 but it reduces the memory allocated for the string in the vast
2752 majority of cases, where the string is never modified and has no
2755 #### This means you can't use an int as a key in a string's plist. */
2757 static Lisp_Object *string_plist_ptr(Lisp_Object string)
2759 Lisp_Object *ptr = &XSTRING(string)->plist;
2761 if (CONSP(*ptr) && EXTENT_INFOP(XCAR(*ptr)))
2763 if (CONSP(*ptr) && INTP(XCAR(*ptr)))
2768 static Lisp_Object string_getprop(Lisp_Object string, Lisp_Object property)
2770 return external_plist_get(string_plist_ptr(string), property, 0,
2775 string_putprop(Lisp_Object string, Lisp_Object property, Lisp_Object value)
2777 external_plist_put(string_plist_ptr(string), property, value, 0,
2782 static int string_remprop(Lisp_Object string, Lisp_Object property)
2784 return external_remprop(string_plist_ptr(string), property, 0,
2788 static Lisp_Object string_plist(Lisp_Object string)
2790 return *string_plist_ptr(string);
2793 /* No `finalize', or `hash' methods.
2794 internal_hash() already knows how to hash strings and finalization
2795 is done with the ADDITIONAL_FREE_string macro, which is the
2796 standard way to do finalization when using
2797 SWEEP_FIXED_TYPE_BLOCK(). */
2798 DEFINE_BASIC_LRECORD_IMPLEMENTATION_WITH_PROPS("string", string,
2799 mark_string, print_string,
2805 string_plist, Lisp_String);
2807 #if !defined HAVE_BDWGC || !defined EF_USE_BDWGC
2808 /* String blocks contain this many useful bytes. */
2809 #define STRING_CHARS_BLOCK_SIZE \
2810 ((Bytecount) (8192 - MALLOC_OVERHEAD - \
2811 ((2 * sizeof (struct string_chars_block *)) \
2812 + sizeof (EMACS_INT))))
2813 /* Block header for small strings. */
2814 struct string_chars_block {
2816 struct string_chars_block *next;
2817 struct string_chars_block *prev;
2818 /* Contents of string_chars_block->string_chars are interleaved
2819 string_chars structures (see below) and the actual string data */
2820 unsigned char string_chars[STRING_CHARS_BLOCK_SIZE];
2823 static struct string_chars_block *first_string_chars_block;
2824 static struct string_chars_block *current_string_chars_block;
2826 /* If SIZE is the length of a string, this returns how many bytes
2827 * the string occupies in string_chars_block->string_chars
2828 * (including alignment padding).
2830 #define STRING_FULLSIZE(size) \
2831 ALIGN_SIZE(((size) + 1 + sizeof(Lisp_String*)), ALIGNOF(Lisp_String*))
2833 #define BIG_STRING_FULLSIZE_P(fullsize) ((fullsize) >= STRING_CHARS_BLOCK_SIZE)
2834 #define BIG_STRING_SIZE_P(size) (BIG_STRING_FULLSIZE_P (STRING_FULLSIZE(size)))
2836 #define STRING_CHARS_FREE_P(ptr) ((ptr)->string == NULL)
2837 #define MARK_STRING_CHARS_AS_FREE(ptr) ((void) ((ptr)->string = NULL))
2839 struct string_chars {
2840 Lisp_String *string;
2841 unsigned char chars[1];
2844 struct unused_string_chars {
2845 Lisp_String *string;
2849 static void init_string_chars_alloc(void)
2851 first_string_chars_block = ynew(struct string_chars_block);
2852 first_string_chars_block->prev = 0;
2853 first_string_chars_block->next = 0;
2854 first_string_chars_block->pos = 0;
2855 current_string_chars_block = first_string_chars_block;
2858 static struct string_chars*
2859 allocate_string_chars_struct(Lisp_String *string_it_goes_with,
2862 struct string_chars *s_chars;
2864 if (fullsize <= (countof(current_string_chars_block->string_chars)
2865 - current_string_chars_block->pos)) {
2866 /* This string can fit in the current string chars block */
2867 s_chars = (struct string_chars *)
2868 (current_string_chars_block->string_chars
2869 + current_string_chars_block->pos);
2870 current_string_chars_block->pos += fullsize;
2872 /* Make a new current string chars block */
2873 struct string_chars_block *new_scb =
2874 ynew(struct string_chars_block);
2876 current_string_chars_block->next = new_scb;
2877 new_scb->prev = current_string_chars_block;
2879 current_string_chars_block = new_scb;
2880 new_scb->pos = fullsize;
2881 s_chars = (struct string_chars *)
2882 current_string_chars_block->string_chars;
2885 s_chars->string = string_it_goes_with;
2887 INCREMENT_CONS_COUNTER(fullsize, "string chars");
2893 Lisp_Object make_uninit_string(Bytecount length)
2896 #if !defined HAVE_BDWGC || !defined EF_USE_BDWGC
2897 EMACS_INT fullsize = STRING_FULLSIZE(length);
2901 #if !defined HAVE_BDWGC || !defined EF_USE_BDWGC
2902 assert(length >= 0 && fullsize > 0);
2905 /* Allocate the string header */
2906 ALLOCATE_FIXED_TYPE(string, Lisp_String, s);
2907 set_lheader_implementation(&s->lheader, &lrecord_string);
2908 string_register_finaliser(s);
2910 #if defined HAVE_BDWGC && defined EF_USE_BDWGC
2912 Bufbyte *foo = xnew_atomic_array(Bufbyte, length+1);
2913 set_string_data(s, foo);
2916 set_string_data(s, BIG_STRING_FULLSIZE_P(fullsize)
2917 ? xnew_atomic_array(Bufbyte, length + 1)
2918 : allocate_string_chars_struct(s, fullsize)->chars);
2921 set_string_length(s, length);
2923 #ifdef EF_USE_COMPRE
2926 /* propagate the cat system, go with the standard impl of a seq first */
2927 s->lheader.morphisms = 0;
2929 set_string_byte(s, length, 0);
2935 #ifdef VERIFY_STRING_CHARS_INTEGRITY
2936 static void verify_string_chars_integrity(void);
2939 /* Resize the string S so that DELTA bytes can be inserted starting
2940 at POS. If DELTA < 0, it means deletion starting at POS. If
2941 POS < 0, resize the string but don't copy any characters. Use
2942 this if you're planning on completely overwriting the string.
2945 #if defined HAVE_BDWGC && defined EF_USE_BDWGC
2946 void resize_string(Lisp_String * s, Bytecount pos, Bytecount delta)
2951 /* trivial cases first */
2953 /* simplest case: no size change. */
2957 if (pos >= 0 && delta < 0) {
2958 /* If DELTA < 0, the functions below will delete the characters
2959 before POS. We want to delete characters *after* POS,
2960 however, so convert this to the appropriate form. */
2964 /* Both strings are big. We can just realloc().
2965 But careful! If the string is shrinking, we have to
2966 memmove() _before_ realloc(), and if growing, we have to
2967 memmove() _after_ realloc() - otherwise the access is
2968 illegal, and we might crash. */
2969 len = string_length(s) + 1 - pos;
2971 if (delta < 0 && pos >= 0) {
2972 memmove(string_data(s) + pos + delta,
2973 string_data(s) + pos, len);
2976 /* do the reallocation */
2977 foo = xrealloc(string_data(s), string_length(s) + delta + 1);
2978 set_string_data(s, foo);
2980 if (delta > 0 && pos >= 0) {
2981 memmove(string_data(s) + pos + delta,
2982 string_data(s) + pos, len);
2985 set_string_length(s, string_length(s) + delta);
2986 /* If pos < 0, the string won't be zero-terminated.
2987 Terminate now just to make sure. */
2988 string_data(s)[string_length(s)] = '\0';
2993 XSETSTRING(string, s);
2994 /* We also have to adjust all of the extent indices after the
2995 place we did the change. We say "pos - 1" because
2996 adjust_extents() is exclusive of the starting position
2998 adjust_extents(string, pos - 1, string_length(s), delta);
3002 #else /* !HAVE_BDWGC */
3003 void resize_string(Lisp_String * s, Bytecount pos, Bytecount delta)
3005 Bytecount oldfullsize, newfullsize;
3006 #ifdef VERIFY_STRING_CHARS_INTEGRITY
3007 verify_string_chars_integrity();
3010 #ifdef ERROR_CHECK_BUFPOS
3012 assert(pos <= string_length(s));
3014 assert(pos + (-delta) <= string_length(s));
3017 assert((-delta) <= string_length(s));
3019 #endif /* ERROR_CHECK_BUFPOS */
3022 /* simplest case: no size change. */
3025 if (pos >= 0 && delta < 0)
3026 /* If DELTA < 0, the functions below will delete the characters
3027 before POS. We want to delete characters *after* POS, however,
3028 so convert this to the appropriate form. */
3031 oldfullsize = STRING_FULLSIZE(string_length(s));
3032 newfullsize = STRING_FULLSIZE(string_length(s) + delta);
3034 if (BIG_STRING_FULLSIZE_P(oldfullsize)) {
3035 if (BIG_STRING_FULLSIZE_P(newfullsize)) {
3036 /* Both strings are big. We can just realloc().
3037 But careful! If the string is shrinking, we have to
3038 memmove() _before_ realloc(), and if growing, we have to
3039 memmove() _after_ realloc() - otherwise the access is
3040 illegal, and we might crash. */
3041 Bytecount len = string_length(s) + 1 - pos;
3044 if (delta < 0 && pos >= 0)
3045 memmove(string_data(s) + pos + delta,
3046 string_data(s) + pos, len);
3048 foo = xrealloc(string_data(s),
3049 string_length(s) + delta + 1);
3050 set_string_data(s, foo);
3051 if (delta > 0 && pos >= 0) {
3052 memmove(string_data(s) + pos + delta,
3053 string_data(s) + pos, len);
3056 /* String has been demoted from BIG_STRING. */
3059 allocate_string_chars_struct(s, newfullsize)
3061 Bufbyte *old_data = string_data(s);
3064 memcpy(new_data, old_data, pos);
3065 memcpy(new_data + pos + delta, old_data + pos,
3066 string_length(s) + 1 - pos);
3068 set_string_data(s, new_data);
3071 } else { /* old string is small */
3073 if (oldfullsize == newfullsize) {
3074 /* special case; size change but the necessary
3075 allocation size won't change (up or down; code
3076 somewhere depends on there not being any unused
3077 allocation space, modulo any alignment
3080 Bufbyte *addroff = pos + string_data(s);
3082 memmove(addroff + delta, addroff,
3083 /* +1 due to zero-termination. */
3084 string_length(s) + 1 - pos);
3087 Bufbyte *old_data = string_data(s);
3088 Bufbyte *new_data = BIG_STRING_FULLSIZE_P(newfullsize)
3089 ? xnew_atomic_array(
3090 Bufbyte, string_length(s) + delta + 1)
3091 : allocate_string_chars_struct(
3092 s, newfullsize)->chars;
3095 memcpy(new_data, old_data, pos);
3096 memcpy(new_data + pos + delta, old_data + pos,
3097 string_length(s) + 1 - pos);
3099 set_string_data(s, new_data);
3102 /* We need to mark this chunk of the
3103 string_chars_block as unused so that
3104 compact_string_chars() doesn't freak. */
3105 struct string_chars *old_s_chars =
3106 (struct string_chars *)
3108 offsetof(struct string_chars, chars));
3109 /* Sanity check to make sure we aren't hosed by
3110 strange alignment/padding. */
3111 assert(old_s_chars->string == s);
3112 MARK_STRING_CHARS_AS_FREE(old_s_chars);
3113 ((struct unused_string_chars *)old_s_chars)->
3114 fullsize = oldfullsize;
3119 set_string_length(s, string_length(s) + delta);
3120 /* If pos < 0, the string won't be zero-terminated.
3121 Terminate now just to make sure. */
3122 string_data(s)[string_length(s)] = '\0';
3127 XSETSTRING(string, s);
3128 /* We also have to adjust all of the extent indices after the
3129 place we did the change. We say "pos - 1" because
3130 adjust_extents() is exclusive of the starting position
3132 adjust_extents(string, pos - 1, string_length(s), delta);
3134 #ifdef VERIFY_STRING_CHARS_INTEGRITY
3135 verify_string_chars_integrity();
3141 void set_string_char(Lisp_String * s, Charcount i, Emchar c)
3143 Bufbyte newstr[MAX_EMCHAR_LEN];
3144 Bytecount bytoff = charcount_to_bytecount(string_data(s), i);
3145 Bytecount oldlen = charcount_to_bytecount(string_data(s) + bytoff, 1);
3146 Bytecount newlen = set_charptr_emchar(newstr, c);
3148 if (oldlen != newlen) {
3149 resize_string(s, bytoff, newlen - oldlen);
3151 /* Remember, string_data (s) might have changed so we can't cache it. */
3152 memcpy(string_data(s) + bytoff, newstr, newlen);
3157 DEFUN("make-string", Fmake_string, 2, 2, 0, /*
3158 Return a new string consisting of LENGTH copies of CHARACTER.
3159 LENGTH must be a non-negative integer.
3161 (length, character))
3163 CHECK_NATNUM(length);
3164 CHECK_CHAR_COERCE_INT(character);
3166 Bufbyte init_str[MAX_EMCHAR_LEN];
3167 int len = set_charptr_emchar(init_str, XCHAR(character));
3168 Lisp_Object val = make_uninit_string(len * XINT(length));
3171 /* Optimize the single-byte case */
3172 memset(XSTRING_DATA(val), XCHAR(character),
3173 XSTRING_LENGTH(val));
3176 Bufbyte *ptr = XSTRING_DATA(val);
3178 for (i = XINT(length); i; i--) {
3179 Bufbyte *init_ptr = init_str;
3182 *ptr++ = *init_ptr++;
3184 *ptr++ = *init_ptr++;
3186 *ptr++ = *init_ptr++;
3188 *ptr++ = *init_ptr++;
3198 DEFUN("string", Fstring, 0, MANY, 0, /*
3199 Concatenate all the argument characters and make the result a string.
3201 (int nargs, Lisp_Object * args))
3203 Bufbyte *storage, *p;
3205 int speccount = specpdl_depth();
3206 int len = nargs * MAX_EMCHAR_LEN;
3208 XMALLOC_OR_ALLOCA(storage, len, Bufbyte);
3210 for (; nargs; nargs--, args++) {
3211 Lisp_Object lisp_char = *args;
3212 CHECK_CHAR_COERCE_INT(lisp_char);
3213 p += set_charptr_emchar(p, XCHAR(lisp_char));
3215 result = make_string(storage, p - storage);
3216 XMALLOC_UNBIND(storage, len, speccount );
3221 /* Take some raw memory, which MUST already be in internal format,
3222 and package it up into a Lisp string. */
3224 make_string(const Bufbyte *contents, Bytecount length)
3228 /* Make sure we find out about bad make_string's when they happen */
3229 #if defined (ERROR_CHECK_BUFPOS) && defined (MULE)
3230 /* Just for the assertions */
3231 bytecount_to_charcount(contents, length);
3234 val = make_uninit_string(length);
3235 memcpy(XSTRING_DATA(val), contents, length);
3239 /* Take some raw memory, encoded in some external data format,
3240 and convert it into a Lisp string. */
3242 make_ext_string(const Extbyte *contents, EMACS_INT length,
3243 Lisp_Object coding_system)
3246 TO_INTERNAL_FORMAT(DATA, (contents, length),
3247 LISP_STRING, string, coding_system);
3251 /* why arent the next 3 inlines? */
3252 Lisp_Object build_string(const char *str)
3254 /* Some strlen's crash and burn if passed null. */
3255 return make_string((const Bufbyte*)str, (str ? strlen(str) : 0));
3258 Lisp_Object build_ext_string(const char *str, Lisp_Object coding_system)
3260 /* Some strlen's crash and burn if passed null. */
3261 return make_ext_string((const Extbyte*)str, (str ? strlen(str) : 0), coding_system);
3264 Lisp_Object build_translated_string(const char *str)
3266 return build_string(GETTEXT(str));
3269 Lisp_Object make_string_nocopy(Bufbyte *contents, Bytecount length)
3274 /* Make sure we find out about bad make_string_nocopy's when they
3276 #if defined (ERROR_CHECK_BUFPOS) && defined (MULE)
3277 /* Just for the assertions */
3278 bytecount_to_charcount(contents, length);
3281 /* Allocate the string header */
3282 ALLOCATE_FIXED_TYPE(string, Lisp_String, s);
3283 set_lheader_implementation(&s->lheader, &lrecord_string);
3284 SET_C_READONLY_RECORD_HEADER(&s->lheader);
3285 string_register_finaliser(s);
3288 #ifdef EF_USE_COMPRE
3291 set_string_data(s, (Bufbyte*)contents);
3292 set_string_length(s, length);
3298 /************************************************************************/
3299 /* lcrecord lists */
3300 /************************************************************************/
3302 /* Lcrecord lists are used to manage the allocation of particular
3303 sorts of lcrecords, to avoid calling alloc_lcrecord() (and thus
3304 malloc() and garbage-collection junk) as much as possible.
3305 It is similar to the Blocktype class.
3309 1) Create an lcrecord-list object using make_lcrecord_list().
3310 This is often done at initialization. Remember to staticpro_nodump
3311 this object! The arguments to make_lcrecord_list() are the
3312 same as would be passed to alloc_lcrecord().
3313 2) Instead of calling alloc_lcrecord(), call allocate_managed_lcrecord()
3314 and pass the lcrecord-list earlier created.
3315 3) When done with the lcrecord, call free_managed_lcrecord().
3316 The standard freeing caveats apply: ** make sure there are no
3317 pointers to the object anywhere! **
3318 4) Calling free_managed_lcrecord() is just like kissing the
3319 lcrecord goodbye as if it were garbage-collected. This means:
3320 -- the contents of the freed lcrecord are undefined, and the
3321 contents of something produced by allocate_managed_lcrecord()
3322 are undefined, just like for alloc_lcrecord().
3323 -- the mark method for the lcrecord's type will *NEVER* be called
3325 -- the finalize method for the lcrecord's type will be called
3326 at the time that free_managed_lcrecord() is called.
3328 lcrecord lists do not work in bdwgc mode. -hrop
3332 #if defined HAVE_BDWGC && defined EF_USE_BDWGC
3334 mark_lcrecord_list(Lisp_Object obj)
3339 /* just imitate the lcrecord spectactular */
3341 make_lcrecord_list(size_t size,
3342 const struct lrecord_implementation *implementation)
3344 struct lcrecord_list *p =
3345 alloc_lcrecord_type(struct lcrecord_list,
3346 &lrecord_lcrecord_list);
3349 p->implementation = implementation;
3352 XSETLCRECORD_LIST(val, p);
3357 allocate_managed_lcrecord(Lisp_Object lcrecord_list)
3359 struct lcrecord_list *list = XLCRECORD_LIST(lcrecord_list);
3360 void *tmp = alloc_lcrecord(list->size, list->implementation);
3368 free_managed_lcrecord(Lisp_Object UNUSED(lcrecord_list), Lisp_Object lcrecord)
3370 struct free_lcrecord_header *free_header =
3371 (struct free_lcrecord_header*)XPNTR(lcrecord);
3372 struct lrecord_header *lheader = &free_header->lcheader.lheader;
3373 const struct lrecord_implementation *imp =
3374 LHEADER_IMPLEMENTATION(lheader);
3376 if (imp->finalizer) {
3377 imp->finalizer(lheader, 0);
3385 mark_lcrecord_list(Lisp_Object obj)
3387 struct lcrecord_list *list = XLCRECORD_LIST(obj);
3388 Lisp_Object chain = list->free;
3390 while (!NILP(chain)) {
3391 struct lrecord_header *lheader = XRECORD_LHEADER(chain);
3392 struct free_lcrecord_header *free_header =
3393 (struct free_lcrecord_header *)lheader;
3396 /* There should be no other pointers to the free list. */
3397 !MARKED_RECORD_HEADER_P(lheader)
3399 /* Only lcrecords should be here. */
3400 !LHEADER_IMPLEMENTATION(lheader)->
3402 /* Only free lcrecords should be here. */
3403 free_header->lcheader.free &&
3404 /* The type of the lcrecord must be right. */
3405 LHEADER_IMPLEMENTATION(lheader) ==
3406 list->implementation &&
3407 /* So must the size. */
3408 (LHEADER_IMPLEMENTATION(lheader)->
3410 || LHEADER_IMPLEMENTATION(lheader)->
3411 static_size == list->size)
3414 MARK_RECORD_HEADER(lheader);
3415 chain = free_header->chain;
3422 make_lcrecord_list(size_t size,
3423 const struct lrecord_implementation *implementation)
3425 struct lcrecord_list *p =
3426 alloc_lcrecord_type(struct lcrecord_list,
3427 &lrecord_lcrecord_list);
3430 p->implementation = implementation;
3433 XSETLCRECORD_LIST(val, p);
3438 allocate_managed_lcrecord(Lisp_Object lcrecord_list)
3440 struct lcrecord_list *list = XLCRECORD_LIST(lcrecord_list);
3441 if (!NILP(list->free)) {
3442 Lisp_Object val = list->free;
3443 struct free_lcrecord_header *free_header =
3444 (struct free_lcrecord_header *)XPNTR(val);
3446 #ifdef ERROR_CHECK_GC
3447 struct lrecord_header *lheader = &free_header->lcheader.lheader;
3449 /* There should be no other pointers to the free list. */
3450 assert(!MARKED_RECORD_HEADER_P(lheader));
3451 /* Only lcrecords should be here. */
3452 assert(!LHEADER_IMPLEMENTATION(lheader)->basic_p);
3453 /* Only free lcrecords should be here. */
3454 assert(free_header->lcheader.free);
3455 /* The type of the lcrecord must be right. */
3456 assert(LHEADER_IMPLEMENTATION(lheader) == list->implementation);
3457 /* So must the size. */
3458 assert(LHEADER_IMPLEMENTATION(lheader)->static_size == 0 ||
3459 LHEADER_IMPLEMENTATION(lheader)->static_size ==
3461 #endif /* ERROR_CHECK_GC */
3463 list->free = free_header->chain;
3464 free_header->lcheader.free = 0;
3467 void *tmp = alloc_lcrecord(list->size, list->implementation);
3476 free_managed_lcrecord(Lisp_Object lcrecord_list, Lisp_Object lcrecord)
3478 struct lcrecord_list *list = XLCRECORD_LIST(lcrecord_list);
3479 struct free_lcrecord_header *free_header =
3480 (struct free_lcrecord_header*)XPNTR(lcrecord);
3481 struct lrecord_header *lheader = &free_header->lcheader.lheader;
3482 const struct lrecord_implementation *implementation
3483 = LHEADER_IMPLEMENTATION(lheader);
3485 /* Make sure the size is correct. This will catch, for example,
3486 putting a window configuration on the wrong free list. */
3487 gc_checking_assert((implementation->size_in_bytes_method ?
3488 implementation->size_in_bytes_method(lheader) :
3489 implementation->static_size)
3492 if (implementation->finalizer) {
3493 implementation->finalizer(lheader, 0);
3495 free_header->chain = list->free;
3496 free_header->lcheader.free = 1;
3497 list->free = lcrecord;
3501 DEFINE_LRECORD_IMPLEMENTATION("lcrecord-list", lcrecord_list,
3502 mark_lcrecord_list, internal_object_printer,
3503 0, 0, 0, 0, struct lcrecord_list);
3506 DEFUN("purecopy", Fpurecopy, 1, 1, 0, /*
3507 Kept for compatibility, returns its argument.
3509 Make a copy of OBJECT in pure storage.
3510 Recursively copies contents of vectors and cons cells.
3511 Does not copy symbols.
3518 /************************************************************************/
3519 /* Garbage Collection */
3520 /************************************************************************/
3522 /* All the built-in lisp object types are enumerated in `enum lrecord_type'.
3523 Additional ones may be defined by a module (none yet). We leave some
3524 room in `lrecord_implementations_table' for such new lisp object types. */
3525 const struct lrecord_implementation
3526 *lrecord_implementations_table[(unsigned int)lrecord_type_last_built_in_type
3527 + MODULE_DEFINABLE_TYPE_COUNT];
3528 unsigned int lrecord_type_count = (unsigned int)lrecord_type_last_built_in_type;
3529 /* Object marker functions are in the lrecord_implementation structure.
3530 But copying them to a parallel array is much more cache-friendly.
3531 This hack speeds up (garbage-collect) by about 5%. */
3532 Lisp_Object(*lrecord_markers[countof(lrecord_implementations_table)])
3535 #ifndef EF_USE_ASYNEQ
3536 struct gcpro *gcprolist;
3539 /* We want the staticpros relocated, but not the pointers found therein.
3540 Hence we use a trivial description, as for pointerless objects. */
3541 static const struct lrecord_description staticpro_description_1[] = {
3545 static const struct struct_description staticpro_description = {
3546 sizeof(Lisp_Object *),
3547 staticpro_description_1
3550 static const struct lrecord_description staticpros_description_1[] = {
3551 XD_DYNARR_DESC(Lisp_Object_ptr_dynarr, &staticpro_description),
3555 static const struct struct_description staticpros_description = {
3556 sizeof(Lisp_Object_ptr_dynarr),
3557 staticpros_description_1
3560 Lisp_Object_ptr_dynarr *staticpros;
3562 /* Mark the Lisp_Object at non-heap VARADDRESS as a root object for
3563 garbage collection, and for dumping. */
3564 void staticpro(Lisp_Object * varaddress)
3567 Dynarr_add(staticpros, varaddress);
3568 dump_add_root_object(varaddress);
3572 #if !defined HAVE_BDWGC || !defined EF_USE_BDWGC
3573 Lisp_Object_ptr_dynarr *staticpros_nodump;
3575 /* Mark the Lisp_Object at non-heap VARADDRESS as a root object for
3576 garbage collection, but not for dumping. */
3577 void staticpro_nodump(Lisp_Object * varaddress)
3580 Dynarr_add(staticpros_nodump, varaddress);
3586 #ifdef ERROR_CHECK_GC
3587 #define GC_CHECK_LHEADER_INVARIANTS(lheader) \
3589 struct lrecord_header * GCLI_lh = (lheader); \
3590 assert (GCLI_lh != 0); \
3591 assert (GCLI_lh->type < lrecord_type_count); \
3592 assert (! C_READONLY_RECORD_HEADER_P (GCLI_lh) || \
3593 (MARKED_RECORD_HEADER_P (GCLI_lh) && \
3594 LISP_READONLY_RECORD_HEADER_P (GCLI_lh))); \
3597 #define GC_CHECK_LHEADER_INVARIANTS(lheader)
3600 /* Mark reference to a Lisp_Object. If the object referred to has not been
3601 seen yet, recursively mark all the references contained in it. */
3603 #if defined HAVE_BDWGC && defined EF_USE_BDWGC
3604 void mark_object(Lisp_Object UNUSED(obj))
3610 void mark_object(Lisp_Object obj)
3612 if (obj == Qnull_pointer) {
3617 /* Checks we used to perform */
3618 /* if (EQ (obj, Qnull_pointer)) return; */
3619 /* if (!POINTER_TYPE_P (XGCTYPE (obj))) return; */
3620 /* if (PURIFIED (XPNTR (obj))) return; */
3622 if (XTYPE(obj) == Lisp_Type_Record) {
3623 struct lrecord_header *lheader = XRECORD_LHEADER(obj);
3625 GC_CHECK_LHEADER_INVARIANTS(lheader);
3627 gc_checking_assert(LHEADER_IMPLEMENTATION(lheader)->basic_p ||
3628 !((struct lcrecord_header *)lheader)->free);
3630 /* All c_readonly objects have their mark bit set,
3631 so that we only need to check the mark bit here. */
3632 if (!MARKED_RECORD_HEADER_P(lheader)) {
3633 MARK_RECORD_HEADER(lheader);
3635 if (RECORD_MARKER(lheader)) {
3636 obj = RECORD_MARKER(lheader) (obj);
3645 /* mark all of the conses in a list and mark the final cdr; but
3646 DO NOT mark the cars.
3648 Use only for internal lists! There should never be other pointers
3649 to the cons cells, because if so, the cars will remain unmarked
3650 even when they maybe should be marked. */
3651 void mark_conses_in_list(Lisp_Object obj)
3655 for (rest = obj; CONSP(rest); rest = XCDR(rest)) {
3656 if (CONS_MARKED_P(XCONS(rest)))
3658 MARK_CONS(XCONS(rest));
3664 /* Find all structures not marked, and free them. */
3666 #if !defined HAVE_BDWGC || !defined EF_USE_BDWGC
3667 static int gc_count_num_bit_vector_used, gc_count_bit_vector_total_size;
3668 static int gc_count_bit_vector_storage;
3669 static int gc_count_num_short_string_in_use;
3670 static int gc_count_string_total_size;
3671 static int gc_count_short_string_total_size;
3674 /* static int gc_count_total_records_used, gc_count_records_total_size; */
3676 /* stats on lcrecords in use - kinda kludgy */
3678 #if !defined HAVE_BDWGC || !defined EF_USE_BDWGC
3680 int instances_in_use;
3682 int instances_freed;
3684 int instances_on_free_list;
3685 } lcrecord_stats[countof(lrecord_implementations_table)
3686 + MODULE_DEFINABLE_TYPE_COUNT];
3689 #if !defined HAVE_BDWGC || !defined EF_USE_BDWGC
3690 static void tick_lcrecord_stats(const struct lrecord_header *h, int free_p)
3692 unsigned int type_index = h->type;
3694 if (((const struct lcrecord_header *)h)->free) {
3695 gc_checking_assert(!free_p);
3696 lcrecord_stats[type_index].instances_on_free_list++;
3698 const struct lrecord_implementation *implementation =
3699 LHEADER_IMPLEMENTATION(h);
3701 size_t sz = (implementation->size_in_bytes_method ?
3702 implementation->size_in_bytes_method(h) :
3703 implementation->static_size);
3705 lcrecord_stats[type_index].instances_freed++;
3706 lcrecord_stats[type_index].bytes_freed += sz;
3708 lcrecord_stats[type_index].instances_in_use++;
3709 lcrecord_stats[type_index].bytes_in_use += sz;
3715 /* Free all unmarked records */
3716 #if !defined HAVE_BDWGC || !defined EF_USE_BDWGC
3718 sweep_lcrecords_1(struct lcrecord_header *volatile*prev, int *used)
3721 /* int total_size = 0; */
3723 xzero(lcrecord_stats); /* Reset all statistics to 0. */
3725 /* First go through and call all the finalize methods.
3726 Then go through and free the objects. There used to
3727 be only one loop here, with the call to the finalizer
3728 occurring directly before the xfree() below. That
3729 is marginally faster but much less safe -- if the
3730 finalize method for an object needs to reference any
3731 other objects contained within it (and many do),
3732 we could easily be screwed by having already freed that
3735 for (struct lcrecord_header *volatile header = *prev;
3736 header; header = header->next) {
3737 struct lrecord_header *h = &(header->lheader);
3739 GC_CHECK_LHEADER_INVARIANTS(h);
3741 if (!MARKED_RECORD_HEADER_P(h) && !header->free) {
3742 if (LHEADER_IMPLEMENTATION(h)->finalizer)
3743 LHEADER_IMPLEMENTATION(h)->finalizer(h, 0);
3747 for (struct lcrecord_header *volatile header = *prev; header;) {
3748 struct lrecord_header *volatile h = &(header->lheader);
3749 if (MARKED_RECORD_HEADER_P(h)) {
3750 if (!C_READONLY_RECORD_HEADER_P(h))
3751 UNMARK_RECORD_HEADER(h);
3753 /* total_size += n->implementation->size_in_bytes (h); */
3754 /* #### May modify header->next on a C_READONLY lcrecord */
3755 prev = &(header->next);
3757 tick_lcrecord_stats(h, 0);
3759 struct lcrecord_header *next = header->next;
3761 tick_lcrecord_stats(h, 1);
3762 /* used to call finalizer right here. */
3768 /* *total = total_size; */
3773 sweep_bit_vectors_1(Lisp_Object * prev, int *used, int *total, int *storage)
3775 Lisp_Object bit_vector;
3778 int total_storage = 0;
3780 /* BIT_VECTORP fails because the objects are marked, which changes
3781 their implementation */
3782 for (bit_vector = *prev; !EQ(bit_vector, Qzero);) {
3783 Lisp_Bit_Vector *v = XBIT_VECTOR(bit_vector);
3785 if (MARKED_RECORD_P(bit_vector)) {
3786 if (!C_READONLY_RECORD_HEADER_P(&(v->lheader)))
3787 UNMARK_RECORD_HEADER(&(v->lheader));
3791 FLEXIBLE_ARRAY_STRUCT_SIZEOF(Lisp_Bit_Vector,
3792 unsigned long, bits,
3793 BIT_VECTOR_LONG_STORAGE
3796 /* #### May modify next on a C_READONLY bitvector */
3797 prev = &(bit_vector_next(v));
3800 Lisp_Object next = bit_vector_next(v);
3807 *total = total_size;
3808 *storage = total_storage;
3812 /* And the Lord said: Thou shalt use the `c-backslash-region' command
3813 to make macros prettier. */
3815 #if defined HAVE_BDWGC && defined EF_USE_BDWGC
3816 #define SWEEP_FIXED_TYPE_BLOCK(typename, obj_type)
3818 #elif defined ERROR_CHECK_GC
3820 #define SWEEP_FIXED_TYPE_BLOCK(typename, obj_type) \
3822 struct typename##_block *SFTB_current; \
3824 int num_free = 0, num_used = 0; \
3826 for (SFTB_current = current_##typename##_block, \
3827 SFTB_limit = current_##typename##_block_index; \
3832 for (SFTB_iii = 0; \
3833 SFTB_iii < SFTB_limit; \
3835 obj_type *SFTB_victim = \
3836 &(SFTB_current->block[SFTB_iii]); \
3838 if (LRECORD_FREE_P (SFTB_victim)) { \
3840 } else if (C_READONLY_RECORD_HEADER_P \
3841 (&SFTB_victim->lheader)) { \
3843 } else if (!MARKED_RECORD_HEADER_P \
3844 (&SFTB_victim->lheader)) { \
3846 FREE_FIXED_TYPE(typename, obj_type, \
3850 UNMARK_##typename(SFTB_victim); \
3853 SFTB_current = SFTB_current->prev; \
3854 SFTB_limit = countof(current_##typename##_block \
3858 gc_count_num_##typename##_in_use = num_used; \
3859 gc_count_num_##typename##_freelist = num_free; \
3862 #else /* !ERROR_CHECK_GC, !BDWGC*/
3864 #define SWEEP_FIXED_TYPE_BLOCK(typename, obj_type) \
3866 struct typename##_block *SFTB_current; \
3867 struct typename##_block **SFTB_prev; \
3869 int num_free = 0, num_used = 0; \
3871 typename##_free_list = 0; \
3873 for (SFTB_prev = ¤t_##typename##_block, \
3874 SFTB_current = current_##typename##_block, \
3875 SFTB_limit = current_##typename##_block_index; \
3879 int SFTB_empty = 1; \
3880 Lisp_Free *SFTB_old_free_list = \
3881 typename##_free_list; \
3883 for (SFTB_iii = 0; SFTB_iii < SFTB_limit; \
3885 obj_type *SFTB_victim = \
3886 &(SFTB_current->block[SFTB_iii]); \
3888 if (LRECORD_FREE_P (SFTB_victim)) { \
3890 PUT_FIXED_TYPE_ON_FREE_LIST \
3891 (typename, obj_type, \
3893 } else if (C_READONLY_RECORD_HEADER_P \
3894 (&SFTB_victim->lheader)) { \
3897 } else if (! MARKED_RECORD_HEADER_P \
3898 (&SFTB_victim->lheader)) { \
3900 FREE_FIXED_TYPE(typename, obj_type, \
3905 UNMARK_##typename (SFTB_victim); \
3908 if (!SFTB_empty) { \
3909 SFTB_prev = &(SFTB_current->prev); \
3910 SFTB_current = SFTB_current->prev; \
3911 } else if (SFTB_current == current_##typename##_block \
3912 && !SFTB_current->prev) { \
3913 /* No real point in freeing sole \
3914 * allocation block */ \
3917 struct typename##_block *SFTB_victim_block = \
3919 if (SFTB_victim_block == \
3920 current_##typename##_block) { \
3921 current_##typename##_block_index \
3923 (current_##typename##_block \
3926 SFTB_current = SFTB_current->prev; \
3928 *SFTB_prev = SFTB_current; \
3929 xfree(SFTB_victim_block); \
3930 /* Restore free list to what it was \
3931 before victim was swept */ \
3932 typename##_free_list = \
3933 SFTB_old_free_list; \
3934 num_free -= SFTB_limit; \
3937 SFTB_limit = countof (current_##typename##_block \
3941 gc_count_num_##typename##_in_use = num_used; \
3942 gc_count_num_##typename##_freelist = num_free; \
3945 #endif /* !ERROR_CHECK_GC */
3947 #if !defined HAVE_BDWGC || !defined EF_USE_BDWGC
3948 static void sweep_conses(void)
3950 #define UNMARK_cons(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
3951 #define ADDITIONAL_FREE_cons(ptr)
3953 SWEEP_FIXED_TYPE_BLOCK(cons, Lisp_Cons);
3957 /* Explicitly free a cons cell. */
3958 void free_cons(Lisp_Cons * ptr)
3960 #ifdef ERROR_CHECK_GC
3961 /* If the CAR is not an int, then it will be a pointer, which will
3962 always be four-byte aligned. If this cons cell has already been
3963 placed on the free list, however, its car will probably contain
3964 a chain pointer to the next cons on the list, which has cleverly
3965 had all its 0's and 1's inverted. This allows for a quick
3966 check to make sure we're not freeing something already freed. */
3967 if (POINTER_TYPE_P(XTYPE(ptr->car)))
3968 ASSERT_VALID_POINTER(XPNTR(ptr->car));
3969 #endif /* ERROR_CHECK_GC */
3971 #ifndef ALLOC_NO_POOLS
3972 FREE_FIXED_TYPE_WHEN_NOT_IN_GC(cons, Lisp_Cons, ptr);
3973 #endif /* ALLOC_NO_POOLS */
3976 /* explicitly free a list. You **must make sure** that you have
3977 created all the cons cells that make up this list and that there
3978 are no pointers to any of these cons cells anywhere else. If there
3979 are, you will lose. */
3981 void free_list(Lisp_Object list)
3983 Lisp_Object rest, next;
3985 for (rest = list; !NILP(rest); rest = next) {
3987 free_cons(XCONS(rest));
3991 /* explicitly free an alist. You **must make sure** that you have
3992 created all the cons cells that make up this alist and that there
3993 are no pointers to any of these cons cells anywhere else. If there
3994 are, you will lose. */
3996 void free_alist(Lisp_Object alist)
3998 Lisp_Object rest, next;
4000 for (rest = alist; !NILP(rest); rest = next) {
4002 free_cons(XCONS(XCAR(rest)));
4003 free_cons(XCONS(rest));
4007 #if !defined HAVE_BDWGC || !defined EF_USE_BDWGC
4008 static void sweep_compiled_functions(void)
4010 #define UNMARK_compiled_function(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
4011 #define ADDITIONAL_FREE_compiled_function(ptr)
4013 SWEEP_FIXED_TYPE_BLOCK(compiled_function, Lisp_Compiled_Function);
4017 static void sweep_floats(void)
4019 #define UNMARK_float(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
4020 #define ADDITIONAL_FREE_float(ptr)
4022 SWEEP_FIXED_TYPE_BLOCK(float, Lisp_Float);
4024 #endif /* HAVE_FPFLOAT */
4026 #if defined HAVE_MPZ && (defined WITH_GMP || defined WITH_MP)
4030 #define UNMARK_bigz(ptr) UNMARK_RECORD_HEADER(&((ptr)->lheader))
4031 #define ADDITIONAL_FREE_bigz(ptr) bigz_fini(ptr->data)
4033 SWEEP_FIXED_TYPE_BLOCK(bigz, Lisp_Bigz);
4035 #endif /* HAVE_MPZ */
4037 #if defined HAVE_MPQ && defined WITH_GMP
4041 #define UNMARK_bigq(ptr) UNMARK_RECORD_HEADER(&((ptr)->lheader))
4042 #define ADDITIONAL_FREE_bigq(ptr) bigq_fini(ptr->data)
4044 SWEEP_FIXED_TYPE_BLOCK(bigq, Lisp_Bigq);
4046 #endif /* HAVE_MPQ */
4048 #if defined HAVE_MPF && defined WITH_GMP
4052 #define UNMARK_bigf(ptr) UNMARK_RECORD_HEADER(&((ptr)->lheader))
4053 #define ADDITIONAL_FREE_bigf(ptr) bigf_fini(ptr->data)
4055 SWEEP_FIXED_TYPE_BLOCK(bigf, Lisp_Bigf);
4057 #endif /* HAVE_MPF */
4059 #if defined HAVE_MPFR && defined WITH_MPFR
4063 #define UNMARK_bigfr(ptr) UNMARK_RECORD_HEADER(&((ptr)->lheader))
4064 #define ADDITIONAL_FREE_bigfr(ptr) bigfr_fini(ptr->data)
4066 SWEEP_FIXED_TYPE_BLOCK(bigfr, Lisp_Bigfr);
4068 #endif /* HAVE_MPFR */
4070 #if defined HAVE_PSEUG && defined WITH_PSEUG
4074 #define UNMARK_bigg(ptr) UNMARK_RECORD_HEADER(&((ptr)->lheader))
4075 #define ADDITIONAL_FREE_bigg(ptr) bigg_fini(ptr->data)
4077 SWEEP_FIXED_TYPE_BLOCK(bigg, Lisp_Bigg);
4079 #endif /* HAVE_PSEUG */
4081 #if defined HAVE_MPC && defined WITH_MPC || \
4082 defined HAVE_PSEUC && defined WITH_PSEUC
4086 #define UNMARK_bigc(ptr) UNMARK_RECORD_HEADER(&((ptr)->lheader))
4087 #define ADDITIONAL_FREE_bigc(ptr) bigc_fini(ptr->data)
4089 SWEEP_FIXED_TYPE_BLOCK(bigc, Lisp_Bigc);
4091 #endif /* HAVE_MPC */
4093 #if defined HAVE_QUATERN && defined HAVE_MPZ && defined WITH_QUATERN
4095 sweep_quaterns (void)
4097 #define UNMARK_quatern(ptr) UNMARK_RECORD_HEADER(&((ptr)->lheader))
4098 #define ADDITIONAL_FREE_quatern(ptr) quatern_fini(ptr->data)
4100 SWEEP_FIXED_TYPE_BLOCK(quatern, Lisp_Quatern);
4102 #endif /* HAVE_QUATERN */
4105 sweep_dynacats(void)
4107 #define UNMARK_dynacat(ptr) UNMARK_RECORD_HEADER(&((ptr)->lheader))
4108 #define ADDITIONAL_FREE_dynacat(ptr) dynacat_fini(ptr);
4110 SWEEP_FIXED_TYPE_BLOCK(dynacat, struct dynacat_s);
4113 static void sweep_symbols(void)
4115 #define UNMARK_symbol(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
4116 #define ADDITIONAL_FREE_symbol(ptr)
4118 SWEEP_FIXED_TYPE_BLOCK(symbol, Lisp_Symbol);
4121 static void sweep_extents(void)
4123 #define UNMARK_extent(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
4124 #define ADDITIONAL_FREE_extent(ptr)
4126 SWEEP_FIXED_TYPE_BLOCK(extent, struct extent);
4129 static void sweep_events(void)
4131 #define UNMARK_event(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
4132 #define ADDITIONAL_FREE_event(ptr)
4134 SWEEP_FIXED_TYPE_BLOCK(event, Lisp_Event);
4137 static void sweep_markers(void)
4139 #define UNMARK_marker(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
4140 #define ADDITIONAL_FREE_marker(ptr) \
4141 do { Lisp_Object tem; \
4142 XSETMARKER (tem, ptr); \
4143 unchain_marker (tem); \
4146 SWEEP_FIXED_TYPE_BLOCK(marker, Lisp_Marker);
4150 /* Explicitly free a marker. */
4151 void free_marker(Lisp_Marker * ptr)
4153 /* Perhaps this will catch freeing an already-freed marker. */
4154 gc_checking_assert(ptr->lheader.type == lrecord_type_marker);
4156 #ifndef ALLOC_NO_POOLS
4157 FREE_FIXED_TYPE_WHEN_NOT_IN_GC(marker, Lisp_Marker, ptr);
4158 #endif /* ALLOC_NO_POOLS */
4161 #if defined (MULE) && defined (VERIFY_STRING_CHARS_INTEGRITY)
4163 static void verify_string_chars_integrity(void)
4165 struct string_chars_block *sb;
4167 /* Scan each existing string block sequentially, string by string. */
4168 for (sb = first_string_chars_block; sb; sb = sb->next) {
4170 /* POS is the index of the next string in the block. */
4171 while (pos < sb->pos) {
4172 struct string_chars *s_chars =
4173 (struct string_chars *)&(sb->string_chars[pos]);
4174 Lisp_String *string;
4178 /* If the string_chars struct is marked as free (i.e. the
4179 STRING pointer is NULL) then this is an unused chunk of
4180 string storage. (See below.) */
4182 if (STRING_CHARS_FREE_P(s_chars)) {
4184 ((struct unused_string_chars *)s_chars)->
4190 string = s_chars->string;
4191 /* Must be 32-bit aligned. */
4192 assert((((int)string) & 3) == 0);
4194 size = string_length(string);
4195 fullsize = STRING_FULLSIZE(size);
4197 assert(!BIG_STRING_FULLSIZE_P(fullsize));
4198 assert(string_data(string) == s_chars->chars);
4201 assert(pos == sb->pos);
4205 #endif /* MULE && ERROR_CHECK_GC */
4207 #if !defined HAVE_BDWGC || !defined EF_USE_BDWGC
4208 /* Compactify string chars, relocating the reference to each --
4209 free any empty string_chars_block we see. */
4210 static void compact_string_chars(void)
4212 struct string_chars_block *to_sb = first_string_chars_block;
4214 struct string_chars_block *from_sb;
4216 /* Scan each existing string block sequentially, string by string. */
4217 for (from_sb = first_string_chars_block; from_sb;
4218 from_sb = from_sb->next) {
4220 /* FROM_POS is the index of the next string in the block. */
4221 while (from_pos < from_sb->pos) {
4222 struct string_chars *from_s_chars =
4223 (struct string_chars *)&(from_sb->
4224 string_chars[from_pos]);
4225 struct string_chars *to_s_chars;
4226 Lisp_String *string;
4230 /* If the string_chars struct is marked as free (i.e. the
4231 STRING pointer is NULL) then this is an unused chunk of
4232 string storage. This happens under Mule when a string's
4233 size changes in such a way that its fullsize changes.
4234 (Strings can change size because a different-length
4235 character can be substituted for another character.)
4236 In this case, after the bogus string pointer is the
4237 "fullsize" of this entry, i.e. how many bytes to skip. */
4239 if (STRING_CHARS_FREE_P(from_s_chars)) {
4241 ((struct unused_string_chars *)
4242 from_s_chars)->fullsize;
4243 from_pos += fullsize;
4247 string = from_s_chars->string;
4248 assert(!(LRECORD_FREE_P(string)));
4250 size = string_length(string);
4251 fullsize = STRING_FULLSIZE(size);
4253 gc_checking_assert(!BIG_STRING_FULLSIZE_P(fullsize));
4255 /* Just skip it if it isn't marked. */
4256 if (!MARKED_RECORD_HEADER_P(&(string->lheader))) {
4257 from_pos += fullsize;
4261 /* If it won't fit in what's left of TO_SB, close TO_SB
4262 out and go on to the next string_chars_block. We
4263 know that TO_SB cannot advance past FROM_SB here
4264 since FROM_SB is large enough to currently contain
4266 if ((to_pos + fullsize) >
4267 countof(to_sb->string_chars)) {
4268 to_sb->pos = to_pos;
4269 to_sb = to_sb->next;
4273 /* Compute new address of this string
4274 and update TO_POS for the space being used. */
4276 (struct string_chars *)&(to_sb->
4277 string_chars[to_pos]);
4279 /* Copy the string_chars to the new place. */
4280 if (from_s_chars != to_s_chars)
4281 memmove(to_s_chars, from_s_chars, fullsize);
4283 /* Relocate FROM_S_CHARS's reference */
4284 set_string_data(string, &(to_s_chars->chars[0]));
4286 from_pos += fullsize;
4291 /* Set current to the last string chars block still used and
4292 free any that follow. */
4293 for (volatile struct string_chars_block *victim = to_sb->next;
4295 volatile struct string_chars_block *tofree = victim;
4296 victim = victim->next;
4300 current_string_chars_block = to_sb;
4301 current_string_chars_block->pos = to_pos;
4302 current_string_chars_block->next = 0;
4305 static int debug_string_purity;
4307 static void debug_string_purity_print(Lisp_String * p)
4310 Charcount s = string_char_length(p);
4312 for (i = 0; i < s; i++) {
4313 Emchar ch = string_char(p, i);
4314 if (ch < 32 || ch >= 126)
4315 stderr_out("\\%03o", ch);
4316 else if (ch == '\\' || ch == '\"')
4317 stderr_out("\\%c", ch);
4319 stderr_out("%c", ch);
4325 #if !defined HAVE_BDWGC || !defined EF_USE_BDWGC
4326 static void sweep_strings(void)
4328 int num_small_used = 0, num_small_bytes = 0, num_bytes = 0;
4329 int debug = debug_string_purity;
4331 #define UNMARK_string(ptr) \
4333 Lisp_String *p = (ptr); \
4334 size_t size = string_length (p); \
4335 UNMARK_RECORD_HEADER (&(p->lheader)); \
4336 num_bytes += size; \
4337 if (!BIG_STRING_SIZE_P (size)) { \
4338 num_small_bytes += size; \
4342 debug_string_purity_print (p); \
4344 #define ADDITIONAL_FREE_string(ptr) \
4346 size_t size = string_length (ptr); \
4347 if (BIG_STRING_SIZE_P(size)) { \
4352 SWEEP_FIXED_TYPE_BLOCK(string, Lisp_String);
4354 gc_count_num_short_string_in_use = num_small_used;
4355 gc_count_string_total_size = num_bytes;
4356 gc_count_short_string_total_size = num_small_bytes;
4360 /* I hate duplicating all this crap! */
4361 int marked_p(Lisp_Object obj)
4363 /* Checks we used to perform. */
4364 /* if (EQ (obj, Qnull_pointer)) return 1; */
4365 /* if (!POINTER_TYPE_P (XGCTYPE (obj))) return 1; */
4366 /* if (PURIFIED (XPNTR (obj))) return 1; */
4368 if (XTYPE(obj) == Lisp_Type_Record) {
4369 struct lrecord_header *lheader = XRECORD_LHEADER(obj);
4371 GC_CHECK_LHEADER_INVARIANTS(lheader);
4373 return MARKED_RECORD_HEADER_P(lheader);
4378 #if !defined HAVE_BDWGC || !defined EF_USE_BDWGC
4379 static void gc_sweep(void)
4381 /* Free all unmarked records. Do this at the very beginning,
4382 before anything else, so that the finalize methods can safely
4383 examine items in the objects. sweep_lcrecords_1() makes
4384 sure to call all the finalize methods *before* freeing anything,
4385 to complete the safety. */
4388 sweep_lcrecords_1(&all_lcrecords, &ignored);
4391 compact_string_chars();
4393 /* Finalize methods below (called through the ADDITIONAL_FREE_foo
4394 macros) must be *extremely* careful to make sure they're not
4395 referencing freed objects. The only two existing finalize
4396 methods (for strings and markers) pass muster -- the string
4397 finalizer doesn't look at anything but its own specially-
4398 created block, and the marker finalizer only looks at live
4399 buffers (which will never be freed) and at the markers before
4400 and after it in the chain (which, by induction, will never be
4401 freed because if so, they would have already removed themselves
4404 /* Put all unmarked strings on free list, free'ing the string chars
4405 of large unmarked strings */
4408 /* Put all unmarked conses on free list */
4411 /* Free all unmarked bit vectors */
4412 sweep_bit_vectors_1(&all_bit_vectors,
4413 &gc_count_num_bit_vector_used,
4414 &gc_count_bit_vector_total_size,
4415 &gc_count_bit_vector_storage);
4417 /* Free all unmarked compiled-function objects */
4418 sweep_compiled_functions();
4421 /* Put all unmarked floats on free list */
4423 #endif /* HAVE_FPFLOAT */
4425 #if defined HAVE_MPZ && (defined WITH_GMP || defined WITH_MP)
4426 /* Put all unmarked bignums on free list */
4428 #endif /* HAVE_MPZ */
4430 #if defined HAVE_MPQ && defined WITH_GMP
4431 /* Put all unmarked ratios on free list */
4433 #endif /* HAVE_MPQ */
4435 #if defined HAVE_MPF && defined WITH_GMP
4436 /* Put all unmarked bigfloats on free list */
4438 #endif /* HAVE_MPF */
4440 #if defined HAVE_MPFR && defined WITH_MPFR
4441 /* Put all unmarked bigfloats on free list */
4443 #endif /* HAVE_MPFR */
4445 #if defined HAVE_PSEUG && defined WITH_PSEUG
4446 /* Put all unmarked gaussian numbers on free list */
4448 #endif /* HAVE_PSEUG */
4450 #if defined HAVE_MPC && defined WITH_MPC || \
4451 defined HAVE_PSEUC && defined WITH_PSEUC
4452 /* Put all unmarked complex numbers on free list */
4454 #endif /* HAVE_MPC */
4456 #if defined HAVE_QUATERN && defined WITH_QUATERN
4457 /* Put all unmarked quaternions on free list */
4459 #endif /* HAVE_QUATERN */
4461 /* Put all unmarked dynacats on free list */
4464 /* Put all unmarked symbols on free list */
4467 /* Put all unmarked extents on free list */
4470 /* Put all unmarked markers on free list.
4471 Dechain each one first from the buffer into which it points. */
4477 pdump_objects_unmark();
4482 /* Clearing for disksave. */
4484 void disksave_object_finalization(void)
4486 /* It's important that certain information from the environment not get
4487 dumped with the executable (pathnames, environment variables, etc.).
4488 To make it easier to tell when this has happened with strings(1) we
4489 clear some known-to-be-garbage blocks of memory, so that leftover
4490 results of old evaluation don't look like potential problems.
4491 But first we set some notable variables to nil and do one more GC,
4492 to turn those strings into garbage.
4495 /* Yeah, this list is pretty ad-hoc... */
4496 Vprocess_environment = Qnil;
4497 /* Vexec_directory = Qnil; */
4498 Vdata_directory = Qnil;
4499 Vdoc_directory = Qnil;
4500 Vconfigure_info_directory = Qnil;
4503 /* Vdump_load_path = Qnil; */
4504 /* Release hash tables for locate_file */
4505 Flocate_file_clear_hashing(Qt);
4506 uncache_home_directory();
4508 #if defined(LOADHIST) && !(defined(LOADHIST_DUMPED) || \
4509 defined(LOADHIST_BUILTIN))
4510 Vload_history = Qnil;
4512 Vshell_file_name = Qnil;
4514 garbage_collect_1();
4516 /* Run the disksave finalization methods of all live objects. */
4517 disksave_object_finalization_1();
4519 /* Zero out the uninitialized (really, unused) part of the containers
4520 for the live strings. */
4521 /* dont know what its counterpart in bdwgc mode is, so leave it out */
4522 #if !defined HAVE_BDWGC || !defined EF_USE_BDWGC
4524 struct string_chars_block *scb;
4525 for (scb = first_string_chars_block; scb; scb = scb->next) {
4526 int count = sizeof(scb->string_chars) - scb->pos;
4528 assert(count >= 0 && count < STRING_CHARS_BLOCK_SIZE);
4530 /* from the block's fill ptr to the end */
4531 memset((scb->string_chars + scb->pos), 0,
4538 /* There, that ought to be enough... */
4542 Lisp_Object restore_gc_inhibit(Lisp_Object val)
4544 gc_currently_forbidden = XINT(val);
4548 /* Maybe we want to use this when doing a "panic" gc after memory_full()? */
4549 static int gc_hooks_inhibited;
4551 struct post_gc_action {
4552 void (*fun) (void *);
4556 typedef struct post_gc_action post_gc_action;
4559 Dynarr_declare(post_gc_action);
4560 } post_gc_action_dynarr;
4562 static post_gc_action_dynarr *post_gc_actions;
4564 /* Register an action to be called at the end of GC.
4565 gc_in_progress is 0 when this is called.
4566 This is used when it is discovered that an action needs to be taken,
4567 but it's during GC, so it's not safe. (e.g. in a finalize method.)
4569 As a general rule, do not use Lisp objects here.
4570 And NEVER signal an error.
4573 void register_post_gc_action(void (*fun) (void *), void *arg)
4575 post_gc_action action;
4577 if (!post_gc_actions)
4578 post_gc_actions = Dynarr_new(post_gc_action);
4583 Dynarr_add(post_gc_actions, action);
4586 #if !defined HAVE_BDWGC || !defined EF_USE_BDWGC
4587 static void run_post_gc_actions(void)
4591 if (post_gc_actions) {
4592 for (i = 0; i < Dynarr_length(post_gc_actions); i++) {
4593 post_gc_action action = Dynarr_at(post_gc_actions, i);
4594 (action.fun) (action.arg);
4597 Dynarr_reset(post_gc_actions);
4603 mark_gcprolist(struct gcpro *gcpl)
4607 for (tail = gcpl; tail; tail = tail->next) {
4608 for (i = 0; i < tail->nvars; i++) {
4609 mark_object(tail->var[i]);
4615 #if defined HAVE_BDWGC && defined EF_USE_BDWGC
4624 void garbage_collect_1(void)
4626 SXE_DEBUG_GC("GC\n");
4627 #if defined GC_DEBUG_FLAG
4629 #endif /* GC_DEBUG_FLAG */
4631 GC_collect_a_little();
4635 GC_try_to_collect(stop_gc_p);
4641 void garbage_collect_1(void)
4643 #if MAX_SAVE_STACK > 0
4644 char stack_top_variable;
4645 extern char *stack_bottom;
4650 Lisp_Object pre_gc_cursor;
4651 struct gcpro gcpro1;
4654 || gc_currently_forbidden || in_display || preparing_for_armageddon)
4657 /* We used to call selected_frame() here.
4659 The following functions cannot be called inside GC
4660 so we move to after the above tests. */
4663 Lisp_Object device = Fselected_device(Qnil);
4664 /* Could happen during startup, eg. if always_gc */
4668 frame = DEVICE_SELECTED_FRAME(XDEVICE(device));
4670 signal_simple_error("No frames exist on device",
4676 pre_gc_cursor = Qnil;
4679 GCPRO1(pre_gc_cursor);
4681 /* Very important to prevent GC during any of the following
4682 stuff that might run Lisp code; otherwise, we'll likely
4683 have infinite GC recursion. */
4684 speccount = specpdl_depth();
4685 record_unwind_protect(restore_gc_inhibit,
4686 make_int(gc_currently_forbidden));
4687 gc_currently_forbidden = 1;
4689 if (!gc_hooks_inhibited)
4690 run_hook_trapping_errors("Error in pre-gc-hook", Qpre_gc_hook);
4692 /* Now show the GC cursor/message. */
4693 if (!noninteractive) {
4694 if (FRAME_WIN_P(f)) {
4695 Lisp_Object frame = make_frame(f);
4696 Lisp_Object cursor =
4697 glyph_image_instance(Vgc_pointer_glyph,
4698 FRAME_SELECTED_WINDOW(f),
4700 pre_gc_cursor = f->pointer;
4701 if (POINTER_IMAGE_INSTANCEP(cursor)
4702 /* don't change if we don't know how to change
4704 && POINTER_IMAGE_INSTANCEP(pre_gc_cursor)) {
4706 Fset_frame_pointer(frame, cursor);
4710 /* Don't print messages to the stream device. */
4711 if (STRINGP(Vgc_message) &&
4713 !FRAME_STREAM_P(f)) {
4714 char *msg = GETTEXT((char *) XSTRING_DATA(Vgc_message));
4715 Lisp_Object args[2], whole_msg;
4717 args[0] = build_string(
4718 msg ? msg : GETTEXT((char*)gc_default_message));
4719 args[1] = build_string("...");
4720 whole_msg = Fconcat(2, args);
4721 echo_area_message(f, (Bufbyte *) 0, whole_msg, 0, -1,
4722 Qgarbage_collecting);
4726 /***** Now we actually start the garbage collection. */
4730 inhibit_non_essential_printing_operations = 1;
4732 gc_generation_number[0]++;
4734 #if MAX_SAVE_STACK > 0
4736 /* Save a copy of the contents of the stack, for debugging. */
4738 /* Static buffer in which we save a copy of the C stack at each
4740 static char *stack_copy;
4741 static size_t stack_copy_size;
4743 ptrdiff_t stack_diff = &stack_top_variable - stack_bottom;
4744 size_t stack_size = (stack_diff > 0 ? stack_diff : -stack_diff);
4745 if (stack_size < MAX_SAVE_STACK) {
4746 if (stack_copy_size < stack_size) {
4748 (char *)xrealloc(stack_copy, stack_size);
4749 stack_copy_size = stack_size;
4754 0 ? stack_bottom : &stack_top_variable,
4758 #endif /* MAX_SAVE_STACK > 0 */
4760 /* Do some totally ad-hoc resource clearing. */
4761 /* #### generalize this? */
4762 clear_event_resource();
4763 cleanup_specifiers();
4765 /* Mark all the special slots that serve as the roots of
4769 Lisp_Object **p = Dynarr_begin(staticpros);
4771 for (count = Dynarr_length(staticpros); count; count--) {
4776 { /* staticpro_nodump() */
4777 Lisp_Object **p = Dynarr_begin(staticpros_nodump);
4779 for (count = Dynarr_length(staticpros_nodump); count; count--) {
4784 #if defined(EF_USE_ASYNEQ)
4785 WITH_DLLIST_TRAVERSE(
4787 eq_worker_t eqw = dllist_item;
4788 struct gcpro *gcpl = eqw->gcprolist;
4789 mark_gcprolist(gcpl));
4792 mark_gcprolist(gcprolist);
4795 struct specbinding *bind;
4796 for (bind = specpdl; bind != specpdl_ptr; bind++) {
4797 mark_object(bind->symbol);
4798 mark_object(bind->old_value);
4803 struct catchtag *catch;
4804 for (catch = catchlist; catch; catch = catch->next) {
4805 mark_object(catch->tag);
4806 mark_object(catch->val);
4811 struct backtrace *backlist;
4812 for (backlist = backtrace_list; backlist;
4813 backlist = backlist->next) {
4814 int nargs = backlist->nargs;
4817 mark_object(*backlist->function);
4819 0 /* nargs == UNEVALLED || nargs == MANY */ )
4820 mark_object(backlist->args[0]);
4822 for (i = 0; i < nargs; i++)
4823 mark_object(backlist->args[i]);
4828 mark_profiling_info();
4830 /* OK, now do the after-mark stuff. This is for things that are only
4831 marked when something else is marked (e.g. weak hash tables). There
4832 may be complex dependencies between such objects -- e.g. a weak hash
4833 table might be unmarked, but after processing a later weak hash
4834 table, the former one might get marked. So we have to iterate until
4835 nothing more gets marked. */
4836 while (finish_marking_weak_hash_tables() > 0 ||
4837 finish_marking_weak_lists() > 0) ;
4839 /* And prune (this needs to be called after everything else has been
4840 marked and before we do any sweeping). */
4841 /* #### this is somewhat ad-hoc and should probably be an object
4843 prune_weak_hash_tables();
4846 prune_syntax_tables();
4850 consing_since_gc = 0;
4851 #ifndef DEBUG_SXEMACS
4852 /* Allow you to set it really fucking low if you really want ... */
4853 if (gc_cons_threshold < 10000)
4854 gc_cons_threshold = 10000;
4858 inhibit_non_essential_printing_operations = 0;
4861 run_post_gc_actions();
4863 /******* End of garbage collection ********/
4865 run_hook_trapping_errors("Error in post-gc-hook", Qpost_gc_hook);
4867 /* Now remove the GC cursor/message */
4868 if (!noninteractive) {
4870 Fset_frame_pointer(make_frame(f), pre_gc_cursor);
4871 else if (STRINGP(Vgc_message) && !FRAME_STREAM_P(f)) {
4872 char *msg = GETTEXT((char *)XSTRING_DATA(Vgc_message));
4874 /* Show "...done" only if the echo area would otherwise
4876 if (NILP(clear_echo_area(selected_frame(),
4877 Qgarbage_collecting, 0))) {
4878 Lisp_Object args[2], whole_msg;
4879 args[0] = build_string(
4881 : GETTEXT((char*)gc_default_message));
4882 args[1] = build_string("... done");
4883 whole_msg = Fconcat(2, args);
4884 echo_area_message(selected_frame(),
4885 (Bufbyte *) 0, whole_msg, 0,
4886 -1, Qgarbage_collecting);
4891 /* now stop inhibiting GC */
4892 unbind_to(speccount, Qnil);
4894 if (!breathing_space) {
4895 breathing_space = malloc(4096 - MALLOC_OVERHEAD);
4904 /* Debugging aids. */
4905 #if defined HAVE_BDWGC && defined EF_USE_BDWGC
4906 #define HACK_O_MATIC(args...)
4907 #define gc_plist_hack(name, val, tail) \
4908 cons3(intern(name), Qzero, tail)
4912 static Lisp_Object gc_plist_hack(const char *name, int value, Lisp_Object tail)
4914 /* C doesn't have local functions (or closures, or GC, or readable
4915 syntax, or portable numeric datatypes, or bit-vectors, or characters,
4916 or arrays, or exceptions, or ...) */
4917 return cons3(intern(name), make_int(value), tail);
4920 #define HACK_O_MATIC(type, name, pl) \
4923 struct type##_block *x = current_##type##_block; \
4925 s += sizeof (*x) + MALLOC_OVERHEAD; \
4928 (pl) = gc_plist_hack ((name), s, (pl)); \
4932 DEFUN("garbage-collect", Fgarbage_collect, 0, 0, "", /*
4933 Reclaim storage for Lisp objects no longer needed.
4934 Return info on amount of space in use:
4935 ((USED-CONSES . FREE-CONSES) (USED-SYMS . FREE-SYMS)
4936 (USED-MARKERS . FREE-MARKERS) USED-STRING-CHARS USED-VECTOR-SLOTS
4938 where `PLIST' is a list of alternating keyword/value pairs providing
4939 more detailed information.
4940 Garbage collection happens automatically if you cons more than
4941 `gc-cons-threshold' bytes of Lisp data since previous garbage collection.
4945 #if defined HAVE_BDWGC && defined EF_USE_BDWGC
4949 Lisp_Object pl = Qnil;
4951 int gc_count_vector_total_size = 0;
4953 garbage_collect_1();
4955 for (i = 0; i < lrecord_type_count; i++) {
4956 if (lcrecord_stats[i].bytes_in_use != 0
4957 || lcrecord_stats[i].bytes_freed != 0
4958 || lcrecord_stats[i].instances_on_free_list != 0) {
4961 lrecord_implementations_table[i]->name;
4962 int len = strlen(name);
4963 /* save this for the FSFmacs-compatible part of the
4965 if (i == lrecord_type_vector)
4966 gc_count_vector_total_size =
4967 lcrecord_stats[i].bytes_in_use +
4968 lcrecord_stats[i].bytes_freed;
4970 snprintf(buf, sizeof(buf), "%s-storage", name);
4971 pl = gc_plist_hack(buf, lcrecord_stats[i].bytes_in_use,
4973 /* Okay, simple pluralization check for
4974 `symbol-value-varalias' */
4975 if (name[len - 1] == 's')
4976 snprintf(buf, sizeof(buf), "%ses-freed", name);
4978 snprintf(buf, sizeof(buf), "%ss-freed", name);
4979 if (lcrecord_stats[i].instances_freed != 0)
4980 pl = gc_plist_hack(buf,
4982 instances_freed, pl);
4983 if (name[len - 1] == 's')
4984 snprintf(buf, sizeof(buf), "%ses-on-free-list", name);
4986 snprintf(buf, sizeof(buf), "%ss-on-free-list", name);
4987 if (lcrecord_stats[i].instances_on_free_list != 0)
4988 pl = gc_plist_hack(buf,
4990 instances_on_free_list, pl);
4991 if (name[len - 1] == 's')
4992 snprintf(buf, sizeof(buf), "%ses-used", name);
4994 snprintf(buf, sizeof(buf), "%ss-used", name);
4995 pl = gc_plist_hack(buf,
4996 lcrecord_stats[i].instances_in_use,
5001 HACK_O_MATIC(extent, "extent-storage", pl);
5002 pl = gc_plist_hack("extents-free", gc_count_num_extent_freelist, pl);
5003 pl = gc_plist_hack("extents-used", gc_count_num_extent_in_use, pl);
5004 HACK_O_MATIC(event, "event-storage", pl);
5005 pl = gc_plist_hack("events-free", gc_count_num_event_freelist, pl);
5006 pl = gc_plist_hack("events-used", gc_count_num_event_in_use, pl);
5007 HACK_O_MATIC(marker, "marker-storage", pl);
5008 pl = gc_plist_hack("markers-free", gc_count_num_marker_freelist, pl);
5009 pl = gc_plist_hack("markers-used", gc_count_num_marker_in_use, pl);
5011 HACK_O_MATIC(float, "float-storage", pl);
5012 pl = gc_plist_hack("floats-free", gc_count_num_float_freelist, pl);
5013 pl = gc_plist_hack("floats-used", gc_count_num_float_in_use, pl);
5014 #endif /* HAVE_FPFLOAT */
5015 #if defined HAVE_MPZ && (defined WITH_GMP || defined WITH_MP)
5016 HACK_O_MATIC(bigz, "bigz-storage", pl);
5017 pl = gc_plist_hack("bigzs-free", gc_count_num_bigz_freelist, pl);
5018 pl = gc_plist_hack("bigzs-used", gc_count_num_bigz_in_use, pl);
5019 #endif /* HAVE_MPZ */
5020 #if defined HAVE_MPQ && defined WITH_GMP
5021 HACK_O_MATIC(bigq, "bigq-storage", pl);
5022 pl = gc_plist_hack("bigqs-free", gc_count_num_bigq_freelist, pl);
5023 pl = gc_plist_hack("bigqs-used", gc_count_num_bigq_in_use, pl);
5024 #endif /* HAVE_MPQ */
5025 #if defined HAVE_MPF && defined WITH_GMP
5026 HACK_O_MATIC(bigf, "bigf-storage", pl);
5027 pl = gc_plist_hack("bigfs-free", gc_count_num_bigf_freelist, pl);
5028 pl = gc_plist_hack("bigfs-used", gc_count_num_bigf_in_use, pl);
5029 #endif /* HAVE_MPF */
5030 #if defined HAVE_MPFR && defined WITH_MPFR
5031 HACK_O_MATIC(bigfr, "bigfr-storage", pl);
5032 pl = gc_plist_hack("bigfrs-free", gc_count_num_bigfr_freelist, pl);
5033 pl = gc_plist_hack("bigfrs-used", gc_count_num_bigfr_in_use, pl);
5034 #endif /* HAVE_MPFR */
5035 #if defined HAVE_PSEUG && defined WITH_PSEUG
5036 HACK_O_MATIC(bigg, "bigg-storage", pl);
5037 pl = gc_plist_hack("biggs-free", gc_count_num_bigg_freelist, pl);
5038 pl = gc_plist_hack("biggs-used", gc_count_num_bigg_in_use, pl);
5039 #endif /* HAVE_PSEUG */
5040 #if defined HAVE_MPC && defined WITH_MPC || \
5041 defined HAVE_PSEUC && defined WITH_PSEUC
5042 HACK_O_MATIC(bigc, "bigc-storage", pl);
5043 pl = gc_plist_hack("bigcs-free", gc_count_num_bigc_freelist, pl);
5044 pl = gc_plist_hack("bigcs-used", gc_count_num_bigc_in_use, pl);
5045 #endif /* HAVE_MPC */
5046 #if defined HAVE_QUATERN && defined WITH_QUATERN
5047 HACK_O_MATIC(quatern, "quatern-storage", pl);
5048 pl = gc_plist_hack("quaterns-free", gc_count_num_quatern_freelist, pl);
5049 pl = gc_plist_hack("quaterns-used", gc_count_num_quatern_in_use, pl);
5050 #endif /* HAVE_QUATERN */
5052 HACK_O_MATIC(dynacat, "dynacat-storage", pl);
5053 pl = gc_plist_hack("dynacats-free", gc_count_num_dynacat_freelist, pl);
5054 pl = gc_plist_hack("dynacats-used", gc_count_num_dynacat_in_use, pl);
5056 HACK_O_MATIC(string, "string-header-storage", pl);
5057 pl = gc_plist_hack("long-strings-total-length",
5058 gc_count_string_total_size
5059 - gc_count_short_string_total_size, pl);
5060 HACK_O_MATIC(string_chars, "short-string-storage", pl);
5061 pl = gc_plist_hack("short-strings-total-length",
5062 gc_count_short_string_total_size, pl);
5063 pl = gc_plist_hack("strings-free", gc_count_num_string_freelist, pl);
5064 pl = gc_plist_hack("long-strings-used",
5065 gc_count_num_string_in_use
5066 - gc_count_num_short_string_in_use, pl);
5067 pl = gc_plist_hack("short-strings-used",
5068 gc_count_num_short_string_in_use, pl);
5070 HACK_O_MATIC(compiled_function, "compiled-function-storage", pl);
5071 pl = gc_plist_hack("compiled-functions-free",
5072 gc_count_num_compiled_function_freelist, pl);
5073 pl = gc_plist_hack("compiled-functions-used",
5074 gc_count_num_compiled_function_in_use, pl);
5076 pl = gc_plist_hack("bit-vector-storage", gc_count_bit_vector_storage,
5078 pl = gc_plist_hack("bit-vectors-total-length",
5079 gc_count_bit_vector_total_size, pl);
5080 pl = gc_plist_hack("bit-vectors-used", gc_count_num_bit_vector_used,
5083 HACK_O_MATIC(symbol, "symbol-storage", pl);
5084 pl = gc_plist_hack("symbols-free", gc_count_num_symbol_freelist, pl);
5085 pl = gc_plist_hack("symbols-used", gc_count_num_symbol_in_use, pl);
5087 HACK_O_MATIC(cons, "cons-storage", pl);
5088 pl = gc_plist_hack("conses-free", gc_count_num_cons_freelist, pl);
5089 pl = gc_plist_hack("conses-used", gc_count_num_cons_in_use, pl);
5091 /* The things we do for backwards-compatibility */
5092 /* fuck, what are we doing about those in the bdwgc era? -hrop */
5094 list6(Fcons(make_int(gc_count_num_cons_in_use),
5095 make_int(gc_count_num_cons_freelist)),
5096 Fcons(make_int(gc_count_num_symbol_in_use),
5097 make_int(gc_count_num_symbol_freelist)),
5098 Fcons(make_int(gc_count_num_marker_in_use),
5099 make_int(gc_count_num_marker_freelist)),
5100 make_int(gc_count_string_total_size),
5101 make_int(gc_count_vector_total_size), pl);
5107 /* grrrr ... lisp/itimer-autosave.el is using this, WTF? */
5108 DEFUN("consing-since-gc", Fconsing_since_gc, 0, 0, "", /*
5109 Return the number of bytes consed since the last garbage collection.
5110 \"Consed\" is a misnomer in that this actually counts allocation
5111 of all different kinds of objects, not just conses.
5113 If this value exceeds `gc-cons-threshold', a garbage collection happens.
5117 #if defined HAVE_BDWGC && defined EF_USE_BDWGC
5120 return make_int(consing_since_gc);
5125 int object_dead_p(Lisp_Object obj)
5127 return ((BUFFERP(obj) && !BUFFER_LIVE_P(XBUFFER(obj))) ||
5128 (FRAMEP(obj) && !FRAME_LIVE_P(XFRAME(obj))) ||
5129 (WINDOWP(obj) && !WINDOW_LIVE_P(XWINDOW(obj))) ||
5130 (DEVICEP(obj) && !DEVICE_LIVE_P(XDEVICE(obj))) ||
5131 (CONSOLEP(obj) && !CONSOLE_LIVE_P(XCONSOLE(obj))) ||
5132 (EVENTP(obj) && !EVENT_LIVE_P(XEVENT(obj))) ||
5133 (EXTENTP(obj) && !EXTENT_LIVE_P(XEXTENT(obj))));
5136 #if defined MEMORY_USAGE_STATS && !(defined HAVE_BDWGC && defined EF_USE_BDWGC)
5138 /* Attempt to determine the actual amount of space that is used for
5139 the block allocated starting at PTR, supposedly of size "CLAIMED_SIZE".
5141 It seems that the following holds:
5143 1. When using the old allocator (malloc.c):
5145 -- blocks are always allocated in chunks of powers of two. For
5146 each block, there is an overhead of 8 bytes if rcheck is not
5147 defined, 20 bytes if it is defined. In other words, a
5148 one-byte allocation needs 8 bytes of overhead for a total of
5149 9 bytes, and needs to have 16 bytes of memory chunked out for
5152 2. When using the new allocator (gmalloc.c):
5154 -- blocks are always allocated in chunks of powers of two up
5155 to 4096 bytes. Larger blocks are allocated in chunks of
5156 an integral multiple of 4096 bytes. The minimum block
5157 size is 2*sizeof (void *), or 16 bytes if SUNOS_LOCALTIME_BUG
5158 is defined. There is no per-block overhead, but there
5159 is an overhead of 3*sizeof (size_t) for each 4096 bytes
5162 3. When using the system malloc, anything goes, but they are
5163 generally slower and more space-efficient than the GNU
5164 allocators. One possibly reasonable assumption to make
5165 for want of better data is that sizeof (void *), or maybe
5166 2 * sizeof (void *), is required as overhead and that
5167 blocks are allocated in the minimum required size except
5168 that some minimum block size is imposed (e.g. 16 bytes). */
5171 malloced_storage_size(void *ptr, size_t claimed_size,
5172 struct overhead_stats * stats)
5174 size_t orig_claimed_size = claimed_size;
5178 if (claimed_size < 2 * sizeof(void *))
5179 claimed_size = 2 * sizeof(void *);
5180 # ifdef SUNOS_LOCALTIME_BUG
5181 if (claimed_size < 16)
5184 if (claimed_size < 4096) {
5187 /* compute the log base two, more or less, then use it to compute
5188 the block size needed. */
5190 /* It's big, it's heavy, it's wood! */
5191 while ((claimed_size /= 2) != 0)
5194 /* It's better than bad, it's good! */
5199 /* We have to come up with some average about the amount of
5201 if ((size_t) (rand() & 4095) < claimed_size)
5202 claimed_size += 3 * sizeof(void *);
5204 claimed_size += 4095;
5205 claimed_size &= ~4095;
5206 claimed_size += (claimed_size / 4096) * 3 * sizeof(size_t);
5209 #elif defined (SYSTEM_MALLOC)
5211 if (claimed_size < 16)
5213 claimed_size += 2 * sizeof(void *);
5215 #else /* old GNU allocator */
5217 # ifdef rcheck /* #### may not be defined here */
5225 /* compute the log base two, more or less, then use it to compute
5226 the block size needed. */
5228 /* It's big, it's heavy, it's wood! */
5229 while ((claimed_size /= 2) != 0)
5232 /* It's better than bad, it's good! */
5239 #endif /* old GNU allocator */
5242 stats->was_requested += orig_claimed_size;
5243 stats->malloc_overhead += claimed_size - orig_claimed_size;
5245 return claimed_size;
5248 size_t fixed_type_block_overhead(size_t size)
5250 size_t per_block = TYPE_ALLOC_SIZE(cons, unsigned char);
5251 size_t overhead = 0;
5252 size_t storage_size = malloced_storage_size(0, per_block, 0);
5253 while (size >= per_block) {
5255 overhead += sizeof(void *) + per_block - storage_size;
5257 if (rand() % per_block < size)
5258 overhead += sizeof(void *) + per_block - storage_size;
5262 #endif /* MEMORY_USAGE_STATS */
5264 #ifdef EF_USE_ASYNEQ
5266 init_main_worker(void)
5268 eq_worker_t res = eq_make_worker();
5269 eq_worker_thread(res) = pthread_self();
5274 #if defined HAVE_MPZ && defined WITH_GMP || \
5275 defined HAVE_MPFR && defined WITH_MPFR
5277 my_malloc(size_t bar)
5279 /* we use atomic here since GMP/MPFR do supervise their objects */
5280 void *foo = xmalloc(bar);
5281 SXE_DEBUG_GC_GMP("alloc :is %p :size %lu\n",
5282 foo, (long unsigned int)bar);
5286 /* We need the next two functions since GNU MP insists on giving us an extra
5289 my_realloc (void *ptr, size_t UNUSED(old_size), size_t new_size)
5291 void *foo = xrealloc(ptr, new_size);
5292 SXE_DEBUG_GC_GMP("gmp realloc :was %p :is %p\n", ptr, foo);
5297 my_free (void *ptr, size_t size)
5299 SXE_DEBUG_GC_GMP("free :was %p :size %lu\n",
5300 ptr, (long unsigned int)size);
5301 memset(ptr, 0, size);
5305 #endif /* GMP || MPFR */
5307 #if defined HAVE_BDWGC && defined EF_USE_BDWGC && !defined GC_DEBUG_FLAG
5309 my_shy_warn_proc(char *msg, GC_word arg)
5311 /* just don't do anything */
5317 /* Initialization */
5318 void init_bdwgc(void);
5323 #if defined HAVE_BDWGC && defined EF_USE_BDWGC
5324 # if defined GC_DEBUG_FLAG
5325 extern long GC_large_alloc_warn_interval;
5327 GC_time_limit = GC_TIME_UNLIMITED;
5328 GC_use_entire_heap = 0;
5331 GC_all_interior_pointers = 1;
5335 GC_free_space_divisor = 8;
5337 #if !defined GC_DEBUG_FLAG
5338 GC_set_warn_proc(my_shy_warn_proc);
5339 #else /* GC_DEBUG_FLAG */
5340 GC_large_alloc_warn_interval = 1L;
5341 #endif /* GC_DEBUG_FLAG */
5348 __init_gmp_mem_funs(void)
5350 #if defined HAVE_MPZ && defined WITH_GMP || \
5351 defined HAVE_MPFR && defined WITH_MPFR
5352 mp_set_memory_functions(my_malloc, my_realloc, my_free);
5353 #endif /* GMP || MPFR */
5356 void reinit_alloc_once_early(void)
5358 gc_generation_number[0] = 0;
5359 breathing_space = 0;
5360 XSETINT(all_bit_vectors, 0); /* Qzero may not be set yet. */
5361 XSETINT(Vgc_message, 0);
5362 #if !defined HAVE_BDWGC || !defined EF_USE_BDWGC
5365 ignore_malloc_warnings = 1;
5366 #ifdef DOUG_LEA_MALLOC
5367 mallopt(M_TRIM_THRESHOLD, 128 * 1024); /* trim threshold */
5368 mallopt(M_MMAP_THRESHOLD, 64 * 1024); /* mmap threshold */
5369 #if 1 /* Moved to emacs.c */
5370 mallopt(M_MMAP_MAX, 0); /* max. number of mmap'ed areas */
5373 /* the category subsystem */
5374 morphisms[lrecord_type_cons].seq_impl = &__scons;
5375 morphisms[lrecord_type_vector].seq_impl = &__svec;
5376 morphisms[lrecord_type_string].seq_impl = &__sstr;
5377 morphisms[lrecord_type_bit_vector].seq_impl = &__sbvc;
5379 init_string_alloc();
5380 #if !defined HAVE_BDWGC || !defined EF_USE_BDWGC
5381 init_string_chars_alloc();
5384 init_symbol_alloc();
5385 init_compiled_function_alloc();
5389 __init_gmp_mem_funs();
5390 #if defined HAVE_MPZ && (defined WITH_GMP || defined WITH_MP) && \
5391 !(defined HAVE_BDWGC && defined EF_USE_BDWGC)
5394 #if defined HAVE_MPQ && defined WITH_GMP && \
5395 !(defined HAVE_BDWGC && defined EF_USE_BDWGC)
5398 #if defined HAVE_MPF && defined WITH_GMP && \
5399 !(defined HAVE_BDWGC && defined EF_USE_BDWGC)
5402 #if defined HAVE_MPFR && defined WITH_MPFR
5405 #if defined HAVE_PSEUG && defined HAVE_MPZ && defined WITH_PSEUG
5408 #if defined HAVE_MPC && defined WITH_MPC || \
5409 defined HAVE_PSEUC && defined WITH_PSEUC
5412 #if defined HAVE_QUATERN && defined HAVE_MPZ && defined WITH_QUATERN
5413 init_quatern_alloc();
5415 init_dynacat_alloc();
5417 init_marker_alloc();
5418 init_extent_alloc();
5421 ignore_malloc_warnings = 0;
5423 /* we only use the 500k value for now */
5424 gc_cons_threshold = 500000;
5425 lrecord_uid_counter = 259;
5427 #if !defined HAVE_BDWGC || !defined EF_USE_BDWGC
5428 if (staticpros_nodump) {
5429 Dynarr_free(staticpros_nodump);
5431 staticpros_nodump = Dynarr_new2(Lisp_Object_ptr_dynarr, Lisp_Object *);
5432 /* merely a small optimization */
5433 Dynarr_resize(staticpros_nodump, 100);
5435 /* tuning the GCor */
5436 consing_since_gc = 0;
5437 debug_string_purity = 0;
5439 #ifdef EF_USE_ASYNEQ
5440 workers = make_noseeum_dllist();
5441 dllist_prepend(workers, init_main_worker());
5446 #if defined EF_USE_ASYNEQ && !(defined HAVE_BDWGC && defined EF_USE_BDWGC)
5447 SXE_MUTEX_INIT(&cons_mutex);
5450 gc_currently_forbidden = 0;
5451 gc_hooks_inhibited = 0;
5453 #ifdef ERROR_CHECK_TYPECHECK
5455 really_unlikely_name_to_have_accidentally_in_a_non_errb_structure =
5458 really_unlikely_name_to_have_accidentally_in_a_non_errb_structure =
5461 really_unlikely_name_to_have_accidentally_in_a_non_errb_structure =
5463 #endif /* ERROR_CHECK_TYPECHECK */
5466 void init_alloc_once_early(void)
5468 reinit_alloc_once_early();
5470 for (int i = 0; i < countof(lrecord_implementations_table); i++) {
5471 lrecord_implementations_table[i] = 0;
5474 INIT_LRECORD_IMPLEMENTATION(cons);
5475 INIT_LRECORD_IMPLEMENTATION(vector);
5476 INIT_LRECORD_IMPLEMENTATION(string);
5477 INIT_LRECORD_IMPLEMENTATION(lcrecord_list);
5479 staticpros = Dynarr_new2(Lisp_Object_ptr_dynarr, Lisp_Object *);
5480 Dynarr_resize(staticpros, 1410); /* merely a small optimization */
5481 dump_add_root_struct_ptr(&staticpros, &staticpros_description);
5483 /* GMP/MPFR mem funs */
5484 __init_gmp_mem_funs();
5489 void reinit_alloc(void)
5491 #ifdef EF_USE_ASYNEQ
5492 eq_worker_t main_th;
5493 assert(dllist_size(workers) == 1);
5494 main_th = dllist_car(workers);
5495 eq_worker_gcprolist(main_th) = NULL;
5501 void syms_of_alloc(void)
5503 DEFSYMBOL(Qpre_gc_hook);
5504 DEFSYMBOL(Qpost_gc_hook);
5505 DEFSYMBOL(Qgarbage_collecting);
5510 DEFSUBR(Fbit_vector);
5511 DEFSUBR(Fmake_byte_code);
5512 DEFSUBR(Fmake_list);
5513 DEFSUBR(Fmake_vector);
5514 DEFSUBR(Fmake_bit_vector);
5515 DEFSUBR(Fmake_string);
5517 DEFSUBR(Fmake_symbol);
5518 DEFSUBR(Fmake_marker);
5520 DEFSUBR(Fgarbage_collect);
5521 DEFSUBR(Fconsing_since_gc);
5524 void vars_of_alloc(void)
5526 DEFVAR_INT("gc-cons-threshold", &gc_cons_threshold /*
5527 *Number of bytes of consing between garbage collections.
5528 \"Consing\" is a misnomer in that this actually counts allocation
5529 of all different kinds of objects, not just conses.
5530 Garbage collection can happen automatically once this many bytes have been
5531 allocated since the last garbage collection. All data types count.
5533 Garbage collection happens automatically when `eval' or `funcall' are
5534 called. (Note that `funcall' is called implicitly as part of evaluation.)
5535 By binding this temporarily to a large number, you can effectively
5536 prevent garbage collection during a part of the program.
5538 See also `consing-since-gc'.
5541 #ifdef DEBUG_SXEMACS
5542 DEFVAR_INT("debug-allocation", &debug_allocation /*
5543 If non-zero, print out information to stderr about all objects allocated.
5544 See also `debug-allocation-backtrace-length'.
5546 debug_allocation = 0;
5548 DEFVAR_INT("debug-allocation-backtrace-length", &debug_allocation_backtrace_length /*
5549 Length (in stack frames) of short backtrace printed out by `debug-allocation'.
5551 debug_allocation_backtrace_length = 2;
5554 DEFVAR_BOOL("purify-flag", &purify_flag /*
5555 Non-nil means loading Lisp code in order to dump an executable.
5556 This means that certain objects should be allocated in readonly space.
5559 DEFVAR_LISP("pre-gc-hook", &Vpre_gc_hook /*
5560 Function or functions to be run just before each garbage collection.
5561 Interrupts, garbage collection, and errors are inhibited while this hook
5562 runs, so be extremely careful in what you add here. In particular, avoid
5563 consing, and do not interact with the user.
5565 Vpre_gc_hook = Qnil;
5567 DEFVAR_LISP("post-gc-hook", &Vpost_gc_hook /*
5568 Function or functions to be run just after each garbage collection.
5569 Interrupts, garbage collection, and errors are inhibited while this hook
5570 runs, so be extremely careful in what you add here. In particular, avoid
5571 consing, and do not interact with the user.
5573 Vpost_gc_hook = Qnil;
5575 DEFVAR_LISP("gc-message", &Vgc_message /*
5576 String to print to indicate that a garbage collection is in progress.
5577 This is printed in the echo area. If the selected frame is on a
5578 window system and `gc-pointer-glyph' specifies a value (i.e. a pointer
5579 image instance) in the domain of the selected frame, the mouse pointer
5580 will change instead of this message being printed.
5581 If it has non-string value - nothing is printed.
5583 Vgc_message = build_string(gc_default_message);
5585 DEFVAR_LISP("gc-pointer-glyph", &Vgc_pointer_glyph /*
5586 Pointer glyph used to indicate that a garbage collection is in progress.
5587 If the selected window is on a window system and this glyph specifies a
5588 value (i.e. a pointer image instance) in the domain of the selected
5589 window, the pointer will be changed as specified during garbage collection.
5590 Otherwise, a message will be printed in the echo area, as controlled
5595 void complex_vars_of_alloc(void)
5597 Vgc_pointer_glyph = Fmake_glyph_internal(Qpointer);