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 *SXE_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 *SXE_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 assert(result != NULL); \
841 INCREMENT_CONS_COUNTER(sizeof(structtype), #type); \
843 #define ALLOCATE_ATOMIC_FIXED_TYPE(type, structtype, result) \
845 result = xnew_atomic(structtype); \
846 assert(result != NULL); \
847 INCREMENT_CONS_COUNTER(sizeof(structtype), #type); \
852 #define ALLOCATE_FIXED_TYPE(type, structtype, result) \
854 ALLOCATE_FIXED_TYPE_1 (type, structtype, result); \
855 INCREMENT_CONS_COUNTER (sizeof (structtype), #type); \
857 #define ALLOCATE_ATOMIC_FIXED_TYPE ALLOCATE_FIXED_TYPE
861 #if defined HAVE_BDWGC && defined EF_USE_BDWGC
862 #define NOSEEUM_ALLOCATE_FIXED_TYPE(type, structtype, result) \
863 (result) = xnew(structtype)
865 #define NOSEEUM_ALLOCATE_FIXED_TYPE(type, structtype, result) \
867 ALLOCATE_FIXED_TYPE_1 (type, structtype, result); \
868 NOSEEUM_INCREMENT_CONS_COUNTER(sizeof (structtype), #type); \
872 /* Lisp_Free is the type to represent a free list member inside a frob
873 block of any lisp object type. */
874 typedef struct Lisp_Free {
875 struct lrecord_header lheader;
876 struct Lisp_Free *chain;
879 #define LRECORD_FREE_P(ptr) \
880 ((ptr)->lheader.type == lrecord_type_free)
882 #define MARK_LRECORD_AS_FREE(ptr) \
883 ((void) ((ptr)->lheader.type = lrecord_type_free))
885 #ifdef ERROR_CHECK_GC
886 #define MARK_LRECORD_AS_NOT_FREE(ptr) \
887 ((void) ((ptr)->lheader.type = lrecord_type_undefined))
889 #define MARK_LRECORD_AS_NOT_FREE(ptr) DO_NOTHING
892 #ifdef ERROR_CHECK_GC
894 #define PUT_FIXED_TYPE_ON_FREE_LIST(type, structtype, ptr) \
896 if (type##_free_list_tail) { \
897 /* When we store the chain pointer, we \
898 complement all its bits; this should \
899 significantly increase its bogosity in case \
900 someone tries to use the value, and \
901 should make us crash faster if someone \
902 overwrites the pointer because when it gets \
903 un-complemented in ALLOCATED_FIXED_TYPE(), \
904 the resulting pointer will be extremely \
906 type##_free_list_tail->chain = \
907 (Lisp_Free *) ~ (EMACS_UINT) (ptr); \
909 type##_free_list = (Lisp_Free *) (ptr); \
911 type##_free_list_tail = (Lisp_Free *) (ptr); \
914 #else /* !ERROR_CHECK_GC */
916 #define PUT_FIXED_TYPE_ON_FREE_LIST(type, structtype, ptr) \
918 ((Lisp_Free *) (ptr))->chain = type##_free_list; \
919 type##_free_list = (Lisp_Free *) (ptr); \
922 #endif /* !ERROR_CHECK_GC */
924 /* TYPE and STRUCTTYPE are the same as in ALLOCATE_FIXED_TYPE(). */
926 #define FREE_FIXED_TYPE(type, structtype, ptr) \
928 structtype *FFT_ptr = (ptr); \
929 ADDITIONAL_FREE_##type (FFT_ptr); \
930 deadbeef_memory (FFT_ptr, sizeof (structtype)); \
931 PUT_FIXED_TYPE_ON_FREE_LIST(type, structtype, FFT_ptr); \
932 MARK_LRECORD_AS_FREE (FFT_ptr); \
935 /* Like FREE_FIXED_TYPE() but used when we are explicitly
936 freeing a structure through free_cons(), free_marker(), etc.
937 rather than through the normal process of sweeping.
938 We attempt to undo the changes made to the allocation counters
939 as a result of this structure being allocated. This is not
940 completely necessary but helps keep things saner: e.g. this way,
941 repeatedly allocating and freeing a cons will not result in
942 the consing-since-gc counter advancing, which would cause a GC
943 and somewhat defeat the purpose of explicitly freeing. */
945 #if defined HAVE_BDWGC && defined EF_USE_BDWGC
946 #define FREE_FIXED_TYPE_WHEN_NOT_IN_GC(type, structtype, ptr)
947 #else /* !HAVE_BDWGC */
948 #define FREE_FIXED_TYPE_WHEN_NOT_IN_GC(type, structtype, ptr) \
950 FREE_FIXED_TYPE (type, structtype, ptr); \
951 DECREMENT_CONS_COUNTER (sizeof (structtype)); \
952 gc_count_num_##type##_freelist++; \
954 #endif /* HAVE_BDWGC */
956 /************************************************************************/
957 /* Cons allocation */
958 /************************************************************************/
960 DECLARE_FIXED_TYPE_ALLOC(cons, Lisp_Cons);
961 /* conses are used and freed so often that we set this really high */
962 /* #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_cons 20000 */
963 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_cons 2000
965 #if defined HAVE_BDWGC && defined EF_USE_BDWGC && 0
967 cons_register_finaliser(Lisp_Cons *s)
969 GC_finalization_proc *foo = NULL;
971 auto void cons_finaliser();
973 auto void cons_finaliser(void *obj, void *SXE_UNUSED(data))
976 memset(obj, 0, sizeof(Lisp_Cons));
980 SXE_DEBUG_GC("cons-fina %p\n", s);
981 GC_REGISTER_FINALIZER(s, cons_finaliser, NULL, foo, bar);
986 cons_register_finaliser(Lisp_Cons *SXE_UNUSED(b))
990 #endif /* HAVE_BDWGC */
992 static Lisp_Object mark_cons(Lisp_Object obj)
997 mark_object(XCAR(obj));
1001 static int cons_equal(Lisp_Object ob1, Lisp_Object ob2, int depth)
1004 while (internal_equal(XCAR(ob1), XCAR(ob2), depth)) {
1007 if (!CONSP(ob1) || !CONSP(ob2))
1008 return internal_equal(ob1, ob2, depth);
1013 /* the seq approach for conses */
1015 cons_length(const seq_t cons)
1018 GET_EXTERNAL_LIST_LENGTH((Lisp_Object)cons, len);
1023 cons_iter_init(seq_t cons, seq_iter_t si)
1025 si->data = si->seq = cons;
1030 cons_iter_next(seq_iter_t si, void **elt)
1032 if (si->data != NULL && CONSP(si->data)) {
1033 *elt = (void*)((Lisp_Cons*)si->data)->car;
1034 si->data = (void*)((Lisp_Cons*)si->data)->cdr;
1042 cons_iter_fini(seq_iter_t si)
1044 si->data = si->seq = NULL;
1049 cons_iter_reset(seq_iter_t si)
1056 cons_explode(void *restrict tgt[], size_t ntgt, const seq_t s)
1058 volatile size_t i = 0;
1059 volatile Lisp_Object c = (Lisp_Object)s;
1061 while (CONSP(c) && i < ntgt) {
1062 tgt[i++] = (void*)XCAR(c);
1068 static struct seq_impl_s __scons = {
1069 .length_f = cons_length,
1070 .iter_init_f = cons_iter_init,
1071 .iter_next_f = cons_iter_next,
1072 .iter_fini_f = cons_iter_fini,
1073 .iter_reset_f = cons_iter_reset,
1074 .explode_f = cons_explode,
1077 static const struct lrecord_description cons_description[] = {
1078 {XD_LISP_OBJECT, offsetof(Lisp_Cons, car)},
1079 {XD_LISP_OBJECT, offsetof(Lisp_Cons, cdr)},
1083 DEFINE_BASIC_LRECORD_IMPLEMENTATION("cons", cons,
1084 mark_cons, print_cons, 0, cons_equal,
1086 * No `hash' method needed.
1087 * internal_hash knows how to
1090 0, cons_description, Lisp_Cons);
1092 DEFUN("cons", Fcons, 2, 2, 0, /*
1093 Create a new cons, give it CAR and CDR as components, and return it.
1095 A cons cell is a Lisp object (an area in memory) made up of two pointers
1096 called the CAR and the CDR. Each of these pointers can point to any other
1097 Lisp object. The common Lisp data type, the list, is a specially-structured
1098 series of cons cells.
1100 The pointers are accessed from Lisp with `car' and `cdr', and mutated with
1101 `setcar' and `setcdr' respectively. For historical reasons, the aliases
1102 `rplaca' and `rplacd' (for `setcar' and `setcdr') are supported.
1106 /* This cannot GC. */
1110 ALLOCATE_FIXED_TYPE(cons, Lisp_Cons, c);
1111 set_lheader_implementation(&c->lheader, &lrecord_cons);
1112 cons_register_finaliser(c);
1116 /* propagate the cat system, go with the standard impl of a seq first */
1117 c->lheader.morphisms = 0;
1121 /* This is identical to Fcons() but it used for conses that we're
1122 going to free later, and is useful when trying to track down
1124 Lisp_Object noseeum_cons(Lisp_Object car, Lisp_Object cdr)
1129 NOSEEUM_ALLOCATE_FIXED_TYPE(cons, Lisp_Cons, c);
1130 set_lheader_implementation(&c->lheader, &lrecord_cons);
1134 /* propagate the cat system, go with the standard impl of a seq first */
1135 c->lheader.morphisms = 0;
1139 DEFUN("list", Flist, 0, MANY, 0, /*
1140 Return a newly created list with specified arguments as elements.
1141 Any number of arguments, even zero arguments, are allowed.
1143 (int nargs, Lisp_Object * args))
1145 Lisp_Object val = Qnil;
1146 Lisp_Object *argp = args + nargs;
1149 val = Fcons(*--argp, val);
1153 Lisp_Object list1(Lisp_Object obj0)
1155 /* This cannot GC. */
1156 return Fcons(obj0, Qnil);
1159 Lisp_Object list2(Lisp_Object obj0, Lisp_Object obj1)
1161 /* This cannot GC. */
1162 return Fcons(obj0, Fcons(obj1, Qnil));
1165 Lisp_Object list3(Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2)
1167 /* This cannot GC. */
1168 return Fcons(obj0, Fcons(obj1, Fcons(obj2, Qnil)));
1171 Lisp_Object cons3(Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2)
1173 /* This cannot GC. */
1174 return Fcons(obj0, Fcons(obj1, obj2));
1177 Lisp_Object acons(Lisp_Object key, Lisp_Object value, Lisp_Object alist)
1179 return Fcons(Fcons(key, value), alist);
1183 list4(Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2, Lisp_Object obj3)
1185 /* This cannot GC. */
1186 return Fcons(obj0, Fcons(obj1, Fcons(obj2, Fcons(obj3, Qnil))));
1190 list5(Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2, Lisp_Object obj3,
1193 /* This cannot GC. */
1195 Fcons(obj1, Fcons(obj2, Fcons(obj3, Fcons(obj4, Qnil)))));
1199 list6(Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2, Lisp_Object obj3,
1200 Lisp_Object obj4, Lisp_Object obj5)
1202 /* This cannot GC. */
1206 Fcons(obj3, Fcons(obj4, Fcons(obj5, Qnil))))));
1209 DEFUN("make-list", Fmake_list, 2, 2, 0, /*
1210 Return a new list of length LENGTH, with each element being OBJECT.
1214 CHECK_NATNUM(length);
1217 Lisp_Object val = Qnil;
1218 size_t size = XINT(length);
1221 val = Fcons(object, val);
1226 /************************************************************************/
1227 /* Float allocation */
1228 /************************************************************************/
1233 DECLARE_FIXED_TYPE_ALLOC(float, Lisp_Float);
1234 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_float 1000
1236 Lisp_Object make_float(fpfloat float_value)
1241 if (ENT_FLOAT_PINF_P(float_value))
1242 return make_indef(POS_INFINITY);
1243 else if (ENT_FLOAT_NINF_P(float_value))
1244 return make_indef(NEG_INFINITY);
1245 else if (ENT_FLOAT_NAN_P(float_value))
1246 return make_indef(NOT_A_NUMBER);
1248 ALLOCATE_FIXED_TYPE(float, Lisp_Float, f);
1250 /* Avoid dump-time `uninitialized memory read' purify warnings. */
1251 if (sizeof(struct lrecord_header) +
1252 sizeof(fpfloat) != sizeof(*f))
1255 set_lheader_implementation(&f->lheader, &lrecord_float);
1256 float_data(f) = float_value;
1261 #endif /* HAVE_FPFLOAT */
1263 /************************************************************************/
1264 /* Enhanced number allocation */
1265 /************************************************************************/
1268 #if defined HAVE_MPZ && (defined WITH_GMP || defined WITH_MP)
1269 DECLARE_FIXED_TYPE_ALLOC(bigz, Lisp_Bigz);
1270 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_bigz 250
1272 #if defined HAVE_BDWGC && defined EF_USE_BDWGC && 0
1274 bigz_register_finaliser(Lisp_Bigz *b)
1276 GC_finalization_proc *foo = NULL;
1278 auto void bigz_finaliser();
1280 auto void bigz_finaliser(void *obj, void *SXE_UNUSED(data))
1282 bigz_fini(bigz_data((Lisp_Bigz*)obj));
1284 memset(obj, 0, sizeof(Lisp_Bigz));
1288 GC_REGISTER_FINALIZER(b, bigz_finaliser, NULL, foo, bar);
1293 bigz_register_finaliser(Lisp_Bigz *SXE_UNUSED(b))
1297 #endif /* HAVE_BDWGC */
1299 /* WARNING: This function returns a bignum even if its argument fits into a
1300 fixnum. See Fcanonicalize_number(). */
1302 make_bigz (long bigz_value)
1306 ALLOCATE_FIXED_TYPE(bigz, Lisp_Bigz, b);
1307 bigz_register_finaliser(b);
1309 set_lheader_implementation(&b->lheader, &lrecord_bigz);
1310 bigz_init(bigz_data(b));
1311 bigz_set_long(bigz_data(b), bigz_value);
1312 return wrap_bigz(b);
1315 /* WARNING: This function returns a bigz even if its argument fits into a
1316 fixnum. See Fcanonicalize_number(). */
1318 make_bigz_bz (bigz bz)
1322 ALLOCATE_FIXED_TYPE(bigz, Lisp_Bigz, b);
1323 bigz_register_finaliser(b);
1325 set_lheader_implementation(&b->lheader, &lrecord_bigz);
1326 bigz_init(bigz_data(b));
1327 bigz_set(bigz_data(b), bz);
1328 return wrap_bigz(b);
1330 #endif /* HAVE_MPZ */
1333 #if defined HAVE_MPQ && defined WITH_GMP
1334 DECLARE_FIXED_TYPE_ALLOC(bigq, Lisp_Bigq);
1335 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_bigq 250
1337 #if defined HAVE_BDWGC && defined EF_USE_BDWGC && 0
1339 bigq_register_finaliser(Lisp_Bigq *b)
1341 GC_finalization_proc *foo = NULL;
1343 auto void bigq_finaliser();
1345 auto void bigq_finaliser(void *obj, void *SXE_UNUSED(data))
1347 bigq_fini(bigq_data((Lisp_Bigq*)obj));
1349 memset(obj, 0, sizeof(Lisp_Bigq));
1353 GC_REGISTER_FINALIZER(b, bigq_finaliser, NULL, foo, bar);
1358 bigq_register_finaliser(Lisp_Bigq *SXE_UNUSED(b))
1362 #endif /* HAVE_BDWGC */
1365 make_bigq(long numerator, unsigned long denominator)
1369 ALLOCATE_FIXED_TYPE(bigq, Lisp_Bigq, r);
1370 bigq_register_finaliser(r);
1372 set_lheader_implementation(&r->lheader, &lrecord_bigq);
1373 bigq_init(bigq_data(r));
1374 bigq_set_long_ulong(bigq_data(r), numerator, denominator);
1375 bigq_canonicalize(bigq_data(r));
1376 return wrap_bigq(r);
1380 make_bigq_bz(bigz numerator, bigz denominator)
1384 ALLOCATE_FIXED_TYPE(bigq, Lisp_Bigq, r);
1385 bigq_register_finaliser(r);
1387 set_lheader_implementation(&r->lheader, &lrecord_bigq);
1388 bigq_init(bigq_data(r));
1389 bigq_set_bigz_bigz(bigq_data(r), numerator, denominator);
1390 bigq_canonicalize(bigq_data(r));
1391 return wrap_bigq(r);
1395 make_bigq_bq(bigq rat)
1399 ALLOCATE_FIXED_TYPE(bigq, Lisp_Bigq, r);
1400 bigq_register_finaliser(r);
1402 set_lheader_implementation(&r->lheader, &lrecord_bigq);
1403 bigq_init(bigq_data(r));
1404 bigq_set(bigq_data(r), rat);
1405 return wrap_bigq(r);
1407 #endif /* HAVE_MPQ */
1410 #if defined HAVE_MPF && defined WITH_GMP
1411 DECLARE_FIXED_TYPE_ALLOC(bigf, Lisp_Bigf);
1412 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_bigf 250
1414 #if defined HAVE_BDWGC && defined EF_USE_BDWGC && 0
1416 bigf_register_finaliser(Lisp_Bigf *b)
1418 GC_finalization_proc *foo = NULL;
1420 auto void bigf_finaliser();
1422 auto void bigf_finaliser(void *obj, void *SXE_UNUSED(data))
1424 bigf_fini(bigf_data((Lisp_Bigf*)obj));
1426 memset(obj, 0, sizeof(Lisp_Bigf));
1430 GC_REGISTER_FINALIZER(b, bigf_finaliser, NULL, foo, bar);
1435 bigf_register_finaliser(Lisp_Bigf *SXE_UNUSED(b))
1439 #endif /* HAVE_BDWGC */
1441 /* This function creates a bigfloat with the default precision if the
1442 PRECISION argument is zero. */
1444 make_bigf(fpfloat float_value, unsigned long precision)
1448 ALLOCATE_FIXED_TYPE(bigf, Lisp_Bigf, f);
1449 bigf_register_finaliser(f);
1451 set_lheader_implementation(&f->lheader, &lrecord_bigf);
1452 if (precision == 0UL)
1453 bigf_init(bigf_data(f));
1455 bigf_init_prec(bigf_data(f), precision);
1456 bigf_set_fpfloat(bigf_data(f), float_value);
1457 return wrap_bigf(f);
1460 /* This function creates a bigfloat with the precision of its argument */
1462 make_bigf_bf(bigf float_value)
1466 ALLOCATE_FIXED_TYPE(bigf, Lisp_Bigf, f);
1467 bigf_register_finaliser(f);
1469 set_lheader_implementation(&f->lheader, &lrecord_bigf);
1470 bigf_init_prec(bigf_data(f), bigf_get_prec(float_value));
1471 bigf_set(bigf_data(f), float_value);
1472 return wrap_bigf(f);
1474 #endif /* HAVE_MPF */
1476 /*** Bigfloat with correct rounding ***/
1477 #if defined HAVE_MPFR && defined WITH_MPFR
1478 DECLARE_FIXED_TYPE_ALLOC(bigfr, Lisp_Bigfr);
1479 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_bigfr 250
1481 #if defined HAVE_BDWGC && defined EF_USE_BDWGC && 0
1483 bigfr_register_finaliser(Lisp_Bigfr *b)
1485 GC_finalization_proc *foo = NULL;
1487 auto void bigfr_finaliser();
1489 auto void bigfr_finaliser(void *obj, void *SXE_UNUSED(data))
1491 bigfr_fini(bigfr_data((Lisp_Bigfr*)obj));
1493 memset(obj, 0, sizeof(Lisp_Bigfr));
1497 GC_REGISTER_FINALIZER(b, bigfr_finaliser, NULL, foo, bar);
1502 bigfr_register_finaliser(Lisp_Bigfr *SXE_UNUSED(b))
1506 #endif /* HAVE_BDWGC */
1508 /* This function creates a bigfloat with the default precision if the
1509 PRECISION argument is zero. */
1511 make_bigfr(fpfloat float_value, unsigned long precision)
1515 ALLOCATE_FIXED_TYPE(bigfr, Lisp_Bigfr, f);
1516 set_lheader_implementation(&f->lheader, &lrecord_bigfr);
1517 bigfr_register_finaliser(f);
1519 if (precision == 0UL) {
1520 bigfr_init(bigfr_data(f));
1522 bigfr_init_prec(bigfr_data(f), precision);
1524 bigfr_set_fpfloat(bigfr_data(f), float_value);
1525 return wrap_bigfr(f);
1528 /* This function creates a bigfloat with the precision of its argument */
1530 make_bigfr_bf(bigf float_value)
1534 ALLOCATE_FIXED_TYPE(bigfr, Lisp_Bigfr, f);
1535 set_lheader_implementation(&f->lheader, &lrecord_bigfr);
1536 bigfr_register_finaliser(f);
1538 bigfr_init_prec(bigfr_data(f), bigf_get_prec(float_value));
1539 bigfr_set_bigf(bigfr_data(f), float_value);
1540 return wrap_bigfr(f);
1543 /* This function creates a bigfloat with the precision of its argument */
1545 make_bigfr_bfr(bigfr bfr_value)
1549 if (bigfr_nan_p(bfr_value) || bigfr_inf_p(bfr_value)) {
1550 return make_indef_bfr(bfr_value);
1553 ALLOCATE_FIXED_TYPE(bigfr, Lisp_Bigfr, f);
1554 set_lheader_implementation(&f->lheader, &lrecord_bigfr);
1555 bigfr_register_finaliser(f);
1557 bigfr_init_prec(bigfr_data(f), bigfr_get_prec(bfr_value));
1558 bigfr_set(bigfr_data(f), bfr_value);
1559 return wrap_bigfr(f);
1561 #endif /* HAVE_MPFR */
1563 /*** Big gaussian numbers ***/
1564 #if defined HAVE_PSEUG && defined HAVE_MPZ && defined WITH_PSEUG
1565 DECLARE_FIXED_TYPE_ALLOC(bigg, Lisp_Bigg);
1566 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_bigg 250
1568 #if defined HAVE_BDWGC && defined EF_USE_BDWGC && 0
1570 bigg_register_finaliser(Lisp_Bigg *b)
1572 GC_finalization_proc *foo = NULL;
1574 auto void bigg_finaliser();
1576 auto void bigg_finaliser(void *obj, void *SXE_UNUSED(data))
1578 bigg_fini(bigg_data((Lisp_Bigg*)obj));
1580 memset(obj, 0, sizeof(Lisp_Bigg));
1584 GC_REGISTER_FINALIZER(b, bigg_finaliser, NULL, foo, bar);
1589 bigg_register_finaliser(Lisp_Bigg *SXE_UNUSED(b))
1593 #endif /* HAVE_BDWGC */
1595 /* This function creates a gaussian number. */
1597 make_bigg(long intg, long imag)
1601 ALLOCATE_FIXED_TYPE(bigg, Lisp_Bigg, g);
1602 set_lheader_implementation(&g->lheader, &lrecord_bigg);
1603 bigg_register_finaliser(g);
1605 bigg_init(bigg_data(g));
1606 bigg_set_long_long(bigg_data(g), intg, imag);
1607 return wrap_bigg(g);
1610 /* This function creates a complex with the precision of its argument */
1612 make_bigg_bz(bigz intg, bigz imag)
1616 ALLOCATE_FIXED_TYPE(bigg, Lisp_Bigg, g);
1617 set_lheader_implementation(&g->lheader, &lrecord_bigg);
1618 bigg_register_finaliser(g);
1620 bigg_init(bigg_data(g));
1621 bigg_set_bigz_bigz(bigg_data(g), intg, imag);
1622 return wrap_bigg(g);
1625 /* This function creates a complex with the precision of its argument */
1627 make_bigg_bg(bigg gaussian_value)
1631 ALLOCATE_FIXED_TYPE(bigg, Lisp_Bigg, g);
1632 set_lheader_implementation(&g->lheader, &lrecord_bigg);
1633 bigg_register_finaliser(g);
1635 bigg_init(bigg_data(g));
1636 bigg_set(bigg_data(g), gaussian_value);
1637 return wrap_bigg(g);
1639 #endif /* HAVE_PSEUG */
1641 /*** Big complex numbers with correct rounding ***/
1642 #if defined HAVE_MPC && defined WITH_MPC || \
1643 defined HAVE_PSEUC && defined WITH_PSEUC
1644 DECLARE_FIXED_TYPE_ALLOC(bigc, Lisp_Bigc);
1645 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_bigc 250
1647 #if defined HAVE_BDWGC && defined EF_USE_BDWGC && 0
1649 bigc_register_finaliser(Lisp_Bigc *b)
1651 GC_finalization_proc *foo = NULL;
1653 auto void bigc_finaliser();
1655 auto void bigc_finaliser(void *obj, void *SXE_UNUSED(data))
1657 bigc_fini(bigc_data((Lisp_Bigc*)obj));
1659 memset(obj, 0, sizeof(Lisp_Bigc));
1663 GC_REGISTER_FINALIZER(b, bigc_finaliser, NULL, foo, bar);
1668 bigc_register_finaliser(Lisp_Bigc *SXE_UNUSED(b))
1672 #endif /* HAVE_BDWGC */
1674 /* This function creates a bigfloat with the default precision if the
1675 PRECISION argument is zero. */
1677 make_bigc(fpfloat re_value, fpfloat im_value, unsigned long precision)
1681 ALLOCATE_FIXED_TYPE(bigc, Lisp_Bigc, c);
1682 set_lheader_implementation(&c->lheader, &lrecord_bigc);
1683 bigc_register_finaliser(c);
1685 if (precision == 0UL) {
1686 bigc_init(bigc_data(c));
1688 bigc_init_prec(bigc_data(c), precision);
1690 bigc_set_fpfloat_fpfloat(bigc_data(c), re_value, im_value);
1691 return wrap_bigc(c);
1694 /* This function creates a complex with the precision of its argument */
1696 make_bigc_bfr(bigfr re_value, bigfr im_value, unsigned long precision)
1700 ALLOCATE_FIXED_TYPE(bigc, Lisp_Bigc, c);
1701 set_lheader_implementation(&c->lheader, &lrecord_bigc);
1702 bigc_register_finaliser(c);
1704 if (precision == 0UL) {
1705 bigc_init(bigc_data(c));
1707 bigc_init_prec(bigc_data(c), precision);
1709 bigc_set_bigfr_bigfr(bigc_data(c), re_value, im_value);
1710 return wrap_bigc(c);
1713 /* This function creates a complex with the precision of its argument */
1715 make_bigc_bc(bigc complex_value)
1719 ALLOCATE_FIXED_TYPE(bigc, Lisp_Bigc, c);
1720 set_lheader_implementation(&c->lheader, &lrecord_bigc);
1721 bigc_register_finaliser(c);
1723 bigc_init_prec(bigc_data(c), bigc_get_prec(complex_value));
1724 bigc_set(bigc_data(c), complex_value);
1725 return wrap_bigc(c);
1727 #endif /* HAVE_MPC */
1729 /*** Quaternions ***/
1730 #if defined HAVE_QUATERN && defined HAVE_MPZ && defined WITH_QUATERN
1731 DECLARE_FIXED_TYPE_ALLOC(quatern, Lisp_Quatern);
1732 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_quatern 250
1734 #if defined HAVE_BDWGC && defined EF_USE_BDWGC && 0
1736 quatern_register_finaliser(Lisp_Quatern *b)
1738 GC_finalization_proc *foo = NULL;
1740 auto void quatern_finaliser();
1742 auto void quatern_finaliser(void *obj, void *SXE_UNUSED(data))
1744 quatern_fini(quatern_data((Lisp_Quatern*)obj));
1746 memset(obj, 0, sizeof(Lisp_Quatern));
1750 GC_REGISTER_FINALIZER(b, quatern_finaliser, NULL, foo, bar);
1755 quatern_register_finaliser(Lisp_Quatern *SXE_UNUSED(b))
1759 #endif /* HAVE_BDWGC */
1761 /* This function creates a quaternion. */
1763 make_quatern(EMACS_INT z, EMACS_INT i, EMACS_INT j, EMACS_INT k)
1767 ALLOCATE_FIXED_TYPE(quatern, Lisp_Quatern, g);
1768 set_lheader_implementation(&g->lheader, &lrecord_quatern);
1769 quatern_register_finaliser(g);
1771 quatern_init(quatern_data(g));
1772 quatern_set_long_long_long_long(quatern_data(g), z, i, j, k);
1773 return wrap_quatern(g);
1777 make_quatern_bz(bigz z, bigz i, bigz j, bigz k)
1781 ALLOCATE_FIXED_TYPE(quatern, Lisp_Quatern, g);
1782 set_lheader_implementation(&g->lheader, &lrecord_quatern);
1783 quatern_register_finaliser(g);
1785 quatern_init(quatern_data(g));
1786 quatern_set_bigz_bigz_bigz_bigz(quatern_data(g), z, i, j, k);
1787 return wrap_quatern(g);
1791 make_quatern_qu(quatern quaternion)
1795 ALLOCATE_FIXED_TYPE(quatern, Lisp_Quatern, g);
1796 set_lheader_implementation(&g->lheader, &lrecord_quatern);
1797 quatern_register_finaliser(g);
1799 quatern_init(quatern_data(g));
1800 quatern_set(quatern_data(g), quaternion);
1801 return wrap_quatern(g);
1803 #endif /* HAVE_QUATERN */
1806 make_indef_internal(indef sym)
1810 i = allocate_lisp_storage(sizeof(Lisp_Indef));
1811 set_lheader_implementation(&i->lheader, &lrecord_indef);
1812 indef_data(i) = sym;
1813 return wrap_indef(i);
1817 make_indef(indef sym)
1824 case COMPLEX_INFINITY:
1825 return Vcomplex_infinity;
1828 /* list some more here */
1829 case END_OF_COMPARABLE_INFINITIES:
1830 case END_OF_INFINITIES:
1832 return Vnot_a_number;
1836 #if defined HAVE_MPFR && defined WITH_MPFR
1838 make_indef_bfr(bigfr bfr_value)
1840 if (bigfr_nan_p(bfr_value)) {
1841 return make_indef(NOT_A_NUMBER);
1842 } else if (bigfr_inf_p(bfr_value)) {
1843 if (bigfr_sign(bfr_value) > 0)
1844 return make_indef(POS_INFINITY);
1846 return make_indef(NEG_INFINITY);
1848 return make_indef(NOT_A_NUMBER);
1853 DECLARE_FIXED_TYPE_ALLOC(dynacat, struct dynacat_s);
1854 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_dynacat 1000
1856 #if defined HAVE_BDWGC && defined EF_USE_BDWGC
1858 dynacat_register_finaliser(dynacat_t b)
1860 GC_finalization_proc *foo = NULL;
1862 auto void dynacat_finaliser();
1864 auto void dynacat_finaliser(void *obj, void *SXE_UNUSED(data))
1866 SXE_DEBUG_GC("calling dynacat finaliser on %p\n", obj);
1869 memset(obj, 0, sizeof(struct dynacat_s));
1873 SXE_DEBUG_GC("dynacat-fina %p\n", b);
1874 GC_REGISTER_FINALIZER(b, dynacat_finaliser, NULL, foo, bar);
1879 dynacat_register_finaliser(dynacat_t SXE_UNUSED(b))
1883 #endif /* HAVE_BDWGC */
1886 make_dynacat(void *ptr)
1890 ALLOCATE_FIXED_TYPE(dynacat, struct dynacat_s, emp);
1891 dynacat_register_finaliser(emp);
1892 set_lheader_implementation(&emp->lheader, &lrecord_dynacat);
1895 emp->intprfun = NULL;
1902 return wrap_object(emp);
1906 /************************************************************************/
1907 /* Vector allocation */
1908 /************************************************************************/
1910 static Lisp_Object mark_vector(Lisp_Object obj)
1912 Lisp_Vector *ptr = XVECTOR(obj);
1913 int len = vector_length(ptr);
1916 for (i = 0; i < len - 1; i++)
1917 mark_object(ptr->contents[i]);
1918 return (len > 0) ? ptr->contents[len - 1] : Qnil;
1921 static size_t size_vector(const void *lheader)
1923 return FLEXIBLE_ARRAY_STRUCT_SIZEOF(
1924 Lisp_Vector, Lisp_Object, contents,
1925 ((const Lisp_Vector*)lheader)->size);
1928 static int vector_equal(Lisp_Object obj1, Lisp_Object obj2, int depth)
1930 int len = XVECTOR_LENGTH(obj1);
1931 if (len != XVECTOR_LENGTH(obj2))
1935 Lisp_Object *ptr1 = XVECTOR_DATA(obj1);
1936 Lisp_Object *ptr2 = XVECTOR_DATA(obj2);
1938 if (!internal_equal(*ptr1++, *ptr2++, depth + 1))
1944 static hcode_t vector_hash(Lisp_Object obj, int depth)
1946 return HASH2(XVECTOR_LENGTH(obj),
1947 internal_array_hash(XVECTOR_DATA(obj),
1948 XVECTOR_LENGTH(obj), depth + 1));
1951 /* the seq approach for conses */
1953 vec_length(const seq_t v)
1955 return XVECTOR_LENGTH((Lisp_Object)(long int)v);
1959 vec_iter_init(seq_t v, seq_iter_t si)
1962 si->data = (void*)0;
1967 vec_iter_next(seq_iter_t si, void **elt)
1969 if (si->seq != NULL &&
1970 (long int)si->data < ((Lisp_Vector*)si->seq)->size) {
1971 *elt = (void*)vector_data((Lisp_Vector*)si->seq)
1972 [(long int)si->data];
1973 si->data = (void*)((long int)si->data + 1L);
1981 vec_iter_fini(seq_iter_t si)
1983 si->data = si->seq = NULL;
1988 vec_iter_reset(seq_iter_t si)
1990 si->data = (void*)0;
1995 vec_explode(void *restrict tgt[], size_t ntgt, const seq_t s)
1997 size_t len = vector_length((const Lisp_Vector*)s);
1998 volatile size_t i = 0;
2000 while (i < len && i < ntgt) {
2001 tgt[i] = (void*)vector_data((const Lisp_Vector*)s)[i];
2007 static struct seq_impl_s __svec = {
2008 .length_f = vec_length,
2009 .iter_init_f = vec_iter_init,
2010 .iter_next_f = vec_iter_next,
2011 .iter_fini_f = vec_iter_fini,
2012 .iter_reset_f = vec_iter_reset,
2013 .explode_f = vec_explode,
2016 static const struct lrecord_description vector_description[] = {
2017 {XD_LONG, offsetof(Lisp_Vector, size)},
2018 {XD_LISP_OBJECT_ARRAY, offsetof(Lisp_Vector, contents),
2023 DEFINE_LRECORD_SEQUENCE_IMPLEMENTATION("vector", vector,
2024 mark_vector, print_vector, 0,
2028 size_vector, Lisp_Vector);
2030 /* #### should allocate `small' vectors from a frob-block */
2031 static Lisp_Vector *make_vector_internal(size_t sizei)
2033 /* no vector_next */
2034 size_t sizem = FLEXIBLE_ARRAY_STRUCT_SIZEOF(Lisp_Vector, Lisp_Object,
2036 Lisp_Vector *p = (Lisp_Vector *) alloc_lcrecord(sizem, &lrecord_vector);
2039 p->header.lheader.morphisms = (1<<cat_mk_lc);
2043 Lisp_Object make_vector(size_t length, Lisp_Object object)
2045 Lisp_Vector *vecp = make_vector_internal(length);
2046 Lisp_Object *p = vector_data(vecp);
2053 XSETVECTOR(vector, vecp);
2058 DEFUN("make-vector", Fmake_vector, 2, 2, 0, /*
2059 Return a new vector of length LENGTH, with each element being OBJECT.
2060 See also the function `vector'.
2064 CONCHECK_NATNUM(length);
2065 return make_vector(XINT(length), object);
2068 DEFUN("vector", Fvector, 0, MANY, 0, /*
2069 Return a newly created vector with specified arguments as elements.
2070 Any number of arguments, even zero arguments, are allowed.
2072 (int nargs, Lisp_Object * args))
2074 Lisp_Vector *vecp = make_vector_internal(nargs);
2075 Lisp_Object *p = vector_data(vecp);
2082 XSETVECTOR(vector, vecp);
2087 Lisp_Object vector1(Lisp_Object obj0)
2089 return Fvector(1, &obj0);
2092 Lisp_Object vector2(Lisp_Object obj0, Lisp_Object obj1)
2094 Lisp_Object args[2];
2097 return Fvector(2, args);
2100 Lisp_Object vector3(Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2)
2102 Lisp_Object args[3];
2106 return Fvector(3, args);
2109 #if 0 /* currently unused */
2112 vector4(Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2, Lisp_Object obj3)
2114 Lisp_Object args[4];
2119 return Fvector(4, args);
2123 vector5(Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
2124 Lisp_Object obj3, Lisp_Object obj4)
2126 Lisp_Object args[5];
2132 return Fvector(5, args);
2136 vector6(Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
2137 Lisp_Object obj3, Lisp_Object obj4, Lisp_Object obj5)
2139 Lisp_Object args[6];
2146 return Fvector(6, args);
2150 vector7(Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
2151 Lisp_Object obj3, Lisp_Object obj4, Lisp_Object obj5, Lisp_Object obj6)
2153 Lisp_Object args[7];
2161 return Fvector(7, args);
2165 vector8(Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
2166 Lisp_Object obj3, Lisp_Object obj4, Lisp_Object obj5,
2167 Lisp_Object obj6, Lisp_Object obj7)
2169 Lisp_Object args[8];
2178 return Fvector(8, args);
2182 /************************************************************************/
2183 /* Bit Vector allocation */
2184 /************************************************************************/
2186 static Lisp_Object all_bit_vectors;
2188 /* #### should allocate `small' bit vectors from a frob-block */
2189 static Lisp_Bit_Vector *make_bit_vector_internal(size_t sizei)
2191 size_t num_longs = BIT_VECTOR_LONG_STORAGE(sizei);
2193 FLEXIBLE_ARRAY_STRUCT_SIZEOF(Lisp_Bit_Vector, unsigned long,
2195 Lisp_Bit_Vector *p = (Lisp_Bit_Vector *) allocate_lisp_storage(sizem);
2196 set_lheader_implementation(&p->lheader, &lrecord_bit_vector);
2198 INCREMENT_CONS_COUNTER(sizem, "bit-vector");
2200 bit_vector_length(p) = sizei;
2201 bit_vector_next(p) = all_bit_vectors;
2202 /* make sure the extra bits in the last long are 0; the calling
2203 functions might not set them. */
2204 p->bits[num_longs - 1] = 0;
2205 XSETBIT_VECTOR(all_bit_vectors, p);
2207 /* propagate seq implementation */
2208 p->lheader.morphisms = 0;
2212 Lisp_Object make_bit_vector(size_t length, Lisp_Object bit)
2214 Lisp_Bit_Vector *p = make_bit_vector_internal(length);
2215 size_t num_longs = BIT_VECTOR_LONG_STORAGE(length);
2220 memset(p->bits, 0, num_longs * sizeof(long));
2222 size_t bits_in_last = length & (LONGBITS_POWER_OF_2 - 1);
2223 memset(p->bits, ~0, num_longs * sizeof(long));
2224 /* But we have to make sure that the unused bits in the
2225 last long are 0, so that equal/hash is easy. */
2227 p->bits[num_longs - 1] &= (1 << bits_in_last) - 1;
2231 Lisp_Object bit_vector;
2232 XSETBIT_VECTOR(bit_vector, p);
2238 make_bit_vector_from_byte_vector(unsigned char *bytevec, size_t length)
2241 Lisp_Bit_Vector *p = make_bit_vector_internal(length);
2243 for (i = 0; i < length; i++)
2244 set_bit_vector_bit(p, i, bytevec[i]);
2247 Lisp_Object bit_vector;
2248 XSETBIT_VECTOR(bit_vector, p);
2253 DEFUN("make-bit-vector", Fmake_bit_vector, 2, 2, 0, /*
2254 Return a new bit vector of length LENGTH. with each bit set to BIT.
2255 BIT must be one of the integers 0 or 1. See also the function `bit-vector'.
2259 CONCHECK_NATNUM(length);
2261 return make_bit_vector(XINT(length), bit);
2264 DEFUN("bit-vector", Fbit_vector, 0, MANY, 0, /*
2265 Return a newly created bit vector with specified arguments as elements.
2266 Any number of arguments, even zero arguments, are allowed.
2267 Each argument must be one of the integers 0 or 1.
2269 (int nargs, Lisp_Object * args))
2272 Lisp_Bit_Vector *p = make_bit_vector_internal(nargs);
2274 for (i = 0; i < nargs; i++) {
2276 set_bit_vector_bit(p, i, !ZEROP(args[i]));
2280 Lisp_Object bit_vector;
2281 XSETBIT_VECTOR(bit_vector, p);
2286 /* the seq approach for conses */
2288 bvc_length(const seq_t bv)
2290 return bit_vector_length(XBIT_VECTOR((Lisp_Object)(long int)bv));
2294 bvc_iter_init(seq_t bv, seq_iter_t si)
2297 si->data = (void*)0;
2302 bvc_iter_next(seq_iter_t si, void **elt)
2304 if (si->seq != NULL &&
2305 (long int)si->data < bit_vector_length((Lisp_Bit_Vector*)si->seq)) {
2306 *elt = (void*)make_int(
2308 (Lisp_Bit_Vector*)si->seq, (size_t)si->data));
2309 si->data = (void*)((long int)si->data + 1L);
2317 bvc_iter_fini(seq_iter_t si)
2319 si->data = si->seq = NULL;
2324 bvc_iter_reset(seq_iter_t si)
2326 si->data = (void*)0;
2331 bvc_explode(void *restrict tgt[], size_t ntgt, const seq_t s)
2333 size_t len = bit_vector_length((const Lisp_Bit_Vector*)s);
2334 volatile size_t i = 0;
2336 while (i < len && i < ntgt) {
2337 tgt[i] = (void*)make_int(
2338 bit_vector_bit((const Lisp_Bit_Vector*)s, i));
2344 static struct seq_impl_s __sbvc = {
2345 .length_f = bvc_length,
2346 .iter_init_f = bvc_iter_init,
2347 .iter_next_f = bvc_iter_next,
2348 .iter_fini_f = bvc_iter_fini,
2349 .iter_reset_f = bvc_iter_reset,
2350 .explode_f = bvc_explode,
2353 /************************************************************************/
2354 /* Compiled-function allocation */
2355 /************************************************************************/
2357 DECLARE_FIXED_TYPE_ALLOC(compiled_function, Lisp_Compiled_Function);
2358 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_compiled_function 1000
2360 static Lisp_Object make_compiled_function(void)
2362 Lisp_Compiled_Function *f;
2365 ALLOCATE_FIXED_TYPE(compiled_function, Lisp_Compiled_Function, f);
2366 set_lheader_implementation(&f->lheader, &lrecord_compiled_function);
2369 f->specpdl_depth = 0;
2370 f->flags.documentationp = 0;
2371 f->flags.interactivep = 0;
2372 f->flags.domainp = 0; /* I18N3 */
2373 f->instructions = Qzero;
2374 f->constants = Qzero;
2376 f->doc_and_interactive = Qnil;
2377 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
2378 f->annotated = Qnil;
2380 XSETCOMPILED_FUNCTION(fun, f);
2384 DEFUN("make-byte-code", Fmake_byte_code, 4, MANY, 0, /*
2385 Return a new compiled-function object.
2386 Usage: (arglist instructions constants stack-depth
2387 &optional doc-string interactive)
2388 Note that, unlike all other emacs-lisp functions, calling this with five
2389 arguments is NOT the same as calling it with six arguments, the last of
2390 which is nil. If the INTERACTIVE arg is specified as nil, then that means
2391 that this function was defined with `(interactive)'. If the arg is not
2392 specified, then that means the function is not interactive.
2393 This is terrible behavior which is retained for compatibility with old
2394 `.elc' files which expect these semantics.
2396 (int nargs, Lisp_Object * args))
2398 /* In a non-insane world this function would have this arglist...
2399 (arglist instructions constants stack_depth &optional doc_string interactive)
2401 Lisp_Object fun = make_compiled_function();
2402 Lisp_Compiled_Function *f = XCOMPILED_FUNCTION(fun);
2404 Lisp_Object arglist = args[0];
2405 Lisp_Object instructions = args[1];
2406 Lisp_Object constants = args[2];
2407 Lisp_Object stack_depth = args[3];
2408 Lisp_Object doc_string = (nargs > 4) ? args[4] : Qnil;
2409 Lisp_Object interactive = (nargs > 5) ? args[5] : Qunbound;
2411 if (nargs < 4 || nargs > 6)
2412 return Fsignal(Qwrong_number_of_arguments,
2413 list2(intern("make-byte-code"),
2416 /* Check for valid formal parameter list now, to allow us to use
2417 SPECBIND_FAST_UNSAFE() later in funcall_compiled_function(). */
2419 EXTERNAL_LIST_LOOP_3(symbol, arglist, tail) {
2420 CHECK_SYMBOL(symbol);
2421 if (EQ(symbol, Qt) ||
2422 EQ(symbol, Qnil) || SYMBOL_IS_KEYWORD(symbol))
2423 signal_simple_error_2
2424 ("Invalid constant symbol in formal parameter list",
2428 f->arglist = arglist;
2430 /* `instructions' is a string or a cons (string . int) for a
2431 lazy-loaded function. */
2432 if (CONSP(instructions)) {
2433 CHECK_STRING(XCAR(instructions));
2434 CHECK_INT(XCDR(instructions));
2436 CHECK_STRING(instructions);
2438 f->instructions = instructions;
2440 if (!NILP(constants))
2441 CHECK_VECTOR(constants);
2442 f->constants = constants;
2444 CHECK_NATNUM(stack_depth);
2445 f->stack_depth = (unsigned short)XINT(stack_depth);
2447 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
2448 if (!NILP(Vcurrent_compiled_function_annotation))
2449 f->annotated = Fcopy(Vcurrent_compiled_function_annotation);
2450 else if (!NILP(Vload_file_name_internal_the_purecopy))
2451 f->annotated = Vload_file_name_internal_the_purecopy;
2452 else if (!NILP(Vload_file_name_internal)) {
2453 struct gcpro gcpro1;
2454 GCPRO1(fun); /* don't let fun get reaped */
2455 Vload_file_name_internal_the_purecopy =
2456 Ffile_name_nondirectory(Vload_file_name_internal);
2457 f->annotated = Vload_file_name_internal_the_purecopy;
2460 #endif /* COMPILED_FUNCTION_ANNOTATION_HACK */
2462 /* doc_string may be nil, string, int, or a cons (string . int).
2463 interactive may be list or string (or unbound). */
2464 f->doc_and_interactive = Qunbound;
2466 if ((f->flags.domainp = !NILP(Vfile_domain)) != 0)
2467 f->doc_and_interactive = Vfile_domain;
2469 if ((f->flags.interactivep = !UNBOUNDP(interactive)) != 0) {
2470 f->doc_and_interactive
2471 = (UNBOUNDP(f->doc_and_interactive) ? interactive :
2472 Fcons(interactive, f->doc_and_interactive));
2474 if ((f->flags.documentationp = !NILP(doc_string)) != 0) {
2475 f->doc_and_interactive
2476 = (UNBOUNDP(f->doc_and_interactive) ? doc_string :
2477 Fcons(doc_string, f->doc_and_interactive));
2479 if (UNBOUNDP(f->doc_and_interactive))
2480 f->doc_and_interactive = Qnil;
2485 /************************************************************************/
2486 /* Symbol allocation */
2487 /************************************************************************/
2489 DECLARE_FIXED_TYPE_ALLOC(symbol, Lisp_Symbol);
2490 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_symbol 1000
2492 DEFUN("make-symbol", Fmake_symbol, 1, 1, 0, /*
2493 Return a newly allocated uninterned symbol whose name is NAME.
2494 Its value and function definition are void, and its property list is nil.
2503 ALLOCATE_FIXED_TYPE(symbol, Lisp_Symbol, p);
2504 set_lheader_implementation(&p->lheader, &lrecord_symbol);
2505 p->name = XSTRING(name);
2507 p->value = Qunbound;
2508 p->function = Qunbound;
2514 /************************************************************************/
2515 /* Extent allocation */
2516 /************************************************************************/
2518 DECLARE_FIXED_TYPE_ALLOC(extent, struct extent);
2519 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_extent 1000
2521 struct extent *allocate_extent(void)
2525 ALLOCATE_FIXED_TYPE(extent, struct extent, e);
2526 set_lheader_implementation(&e->lheader, &lrecord_extent);
2527 extent_object(e) = Qnil;
2528 set_extent_start(e, -1);
2529 set_extent_end(e, -1);
2534 extent_face(e) = Qnil;
2535 e->flags.end_open = 1; /* default is for endpoints to behave like markers */
2536 e->flags.detachable = 1;
2541 /************************************************************************/
2542 /* Event allocation */
2543 /************************************************************************/
2545 DECLARE_FIXED_TYPE_ALLOC(event, Lisp_Event);
2546 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_event 1000
2548 Lisp_Object allocate_event(void)
2553 ALLOCATE_FIXED_TYPE(event, Lisp_Event, e);
2554 set_lheader_implementation(&e->lheader, &lrecord_event);
2560 /************************************************************************/
2561 /* Marker allocation */
2562 /************************************************************************/
2564 DECLARE_FIXED_TYPE_ALLOC(marker, Lisp_Marker);
2565 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_marker 1000
2567 DEFUN("make-marker", Fmake_marker, 0, 0, 0, /*
2568 Return a new marker which does not point at any place.
2575 ALLOCATE_FIXED_TYPE(marker, Lisp_Marker, p);
2576 set_lheader_implementation(&p->lheader, &lrecord_marker);
2581 p->insertion_type = 0;
2586 Lisp_Object noseeum_make_marker(void)
2591 NOSEEUM_ALLOCATE_FIXED_TYPE(marker, Lisp_Marker, p);
2592 set_lheader_implementation(&p->lheader, &lrecord_marker);
2597 p->insertion_type = 0;
2602 /************************************************************************/
2603 /* String allocation */
2604 /************************************************************************/
2606 /* The data for "short" strings generally resides inside of structs of type
2607 string_chars_block. The Lisp_String structure is allocated just like any
2608 other Lisp object (except for vectors), and these are freelisted when
2609 they get garbage collected. The data for short strings get compacted,
2610 but the data for large strings do not.
2612 Previously Lisp_String structures were relocated, but this caused a lot
2613 of bus-errors because the C code didn't include enough GCPRO's for
2614 strings (since EVERY REFERENCE to a short string needed to be GCPRO'd so
2615 that the reference would get relocated).
2617 This new method makes things somewhat bigger, but it is MUCH safer. */
2619 DECLARE_FIXED_TYPE_ALLOC(string, Lisp_String);
2620 /* strings are used and freed quite often */
2621 /* #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_string 10000 */
2622 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_string 1000
2624 #if defined HAVE_BDWGC && defined EF_USE_BDWGC && 0
2626 string_register_finaliser(Lisp_String *s)
2628 GC_finalization_proc *foo = NULL;
2630 auto void string_finaliser();
2632 auto void string_finaliser(void *obj, void *SXE_UNUSED(data))
2634 if (!(((Lisp_String*)obj)->lheader.c_readonly)) {
2635 yfree(((Lisp_String*)obj)->data);
2638 memset(obj, 0, sizeof(Lisp_String));
2642 SXE_DEBUG_GC("string-fina %p\n", s);
2643 GC_REGISTER_FINALIZER(s, string_finaliser, NULL, foo, bar);
2648 string_register_finaliser(Lisp_String *SXE_UNUSED(b))
2652 #endif /* HAVE_BDWGC */
2654 static Lisp_Object mark_string(Lisp_Object obj)
2656 Lisp_String *ptr = XSTRING(obj);
2658 if (CONSP(ptr->plist) && EXTENT_INFOP(XCAR(ptr->plist)))
2659 flush_cached_extent_info(XCAR(ptr->plist));
2660 #ifdef EF_USE_COMPRE
2661 mark_object(ptr->compre);
2666 static int string_equal(Lisp_Object obj1, Lisp_Object obj2, int depth)
2669 return (((len = XSTRING_LENGTH(obj1)) == XSTRING_LENGTH(obj2)) &&
2670 !memcmp(XSTRING_DATA(obj1), XSTRING_DATA(obj2), len));
2673 static const struct lrecord_description string_description[] = {
2674 {XD_BYTECOUNT, offsetof(Lisp_String, size)},
2675 {XD_OPAQUE_DATA_PTR, offsetof(Lisp_String, data), XD_INDIRECT(0, 1)},
2676 #ifdef EF_USE_COMPRE
2677 {XD_LISP_OBJECT, offsetof(Lisp_String, compre)},
2679 {XD_LISP_OBJECT, offsetof(Lisp_String, plist)},
2683 /* the seq implementation */
2685 str_length(const seq_t str)
2687 return string_char_length((const Lisp_String*)str);
2691 str_iter_init(seq_t str, seq_iter_t si)
2694 si->data = (void*)0;
2699 str_iter_next(seq_iter_t si, void **elt)
2701 if (si->seq != NULL &&
2702 (long int)si->data < string_char_length((Lisp_String*)si->seq)) {
2703 *elt = (void*)make_char(
2704 string_char((Lisp_String*)si->seq, (long int)si->data));
2705 si->data = (void*)((long int)si->data + 1);
2713 str_iter_fini(seq_iter_t si)
2715 si->data = si->seq = NULL;
2720 str_iter_reset(seq_iter_t si)
2722 si->data = (void*)0;
2727 str_explode(void *restrict tgt[], size_t ntgt, const seq_t s)
2729 size_t len = string_char_length((const Lisp_String*)s);
2730 volatile size_t i = 0;
2732 while (i < len && i < ntgt) {
2733 tgt[i] = (void*)make_char(string_char((Lisp_String*)s, i));
2739 static struct seq_impl_s __sstr = {
2740 .length_f = str_length,
2741 .iter_init_f = str_iter_init,
2742 .iter_next_f = str_iter_next,
2743 .iter_fini_f = str_iter_fini,
2744 .iter_reset_f = str_iter_reset,
2745 .explode_f = str_explode,
2749 /* We store the string's extent info as the first element of the string's
2750 property list; and the string's MODIFF as the first or second element
2751 of the string's property list (depending on whether the extent info
2752 is present), but only if the string has been modified. This is ugly
2753 but it reduces the memory allocated for the string in the vast
2754 majority of cases, where the string is never modified and has no
2757 #### This means you can't use an int as a key in a string's plist. */
2759 static Lisp_Object *string_plist_ptr(Lisp_Object string)
2761 Lisp_Object *ptr = &XSTRING(string)->plist;
2763 if (CONSP(*ptr) && EXTENT_INFOP(XCAR(*ptr)))
2765 if (CONSP(*ptr) && INTP(XCAR(*ptr)))
2770 static Lisp_Object string_getprop(Lisp_Object string, Lisp_Object property)
2772 return external_plist_get(string_plist_ptr(string), property, 0,
2777 string_putprop(Lisp_Object string, Lisp_Object property, Lisp_Object value)
2779 external_plist_put(string_plist_ptr(string), property, value, 0,
2784 static int string_remprop(Lisp_Object string, Lisp_Object property)
2786 return external_remprop(string_plist_ptr(string), property, 0,
2790 static Lisp_Object string_plist(Lisp_Object string)
2792 return *string_plist_ptr(string);
2795 /* No `finalize', or `hash' methods.
2796 internal_hash() already knows how to hash strings and finalization
2797 is done with the ADDITIONAL_FREE_string macro, which is the
2798 standard way to do finalization when using
2799 SWEEP_FIXED_TYPE_BLOCK(). */
2800 DEFINE_BASIC_LRECORD_IMPLEMENTATION_WITH_PROPS("string", string,
2801 mark_string, print_string,
2807 string_plist, Lisp_String);
2809 #if !defined HAVE_BDWGC || !defined EF_USE_BDWGC
2810 /* String blocks contain this many useful bytes. */
2811 #define STRING_CHARS_BLOCK_SIZE \
2812 ((Bytecount) (8192 - MALLOC_OVERHEAD - \
2813 ((2 * sizeof (struct string_chars_block *)) \
2814 + sizeof (EMACS_INT))))
2815 /* Block header for small strings. */
2816 struct string_chars_block {
2818 struct string_chars_block *next;
2819 struct string_chars_block *prev;
2820 /* Contents of string_chars_block->string_chars are interleaved
2821 string_chars structures (see below) and the actual string data */
2822 unsigned char string_chars[STRING_CHARS_BLOCK_SIZE];
2825 static struct string_chars_block *first_string_chars_block;
2826 static struct string_chars_block *current_string_chars_block;
2828 /* If SIZE is the length of a string, this returns how many bytes
2829 * the string occupies in string_chars_block->string_chars
2830 * (including alignment padding).
2832 #define STRING_FULLSIZE(size) \
2833 ALIGN_SIZE(((size) + 1 + sizeof(Lisp_String*)), ALIGNOF(Lisp_String*))
2835 #define BIG_STRING_FULLSIZE_P(fullsize) ((fullsize) >= STRING_CHARS_BLOCK_SIZE)
2836 #define BIG_STRING_SIZE_P(size) (BIG_STRING_FULLSIZE_P (STRING_FULLSIZE(size)))
2838 #define STRING_CHARS_FREE_P(ptr) ((ptr)->string == NULL)
2839 #define MARK_STRING_CHARS_AS_FREE(ptr) ((void) ((ptr)->string = NULL))
2841 struct string_chars {
2842 Lisp_String *string;
2843 unsigned char chars[1];
2846 struct unused_string_chars {
2847 Lisp_String *string;
2851 static void init_string_chars_alloc(void)
2853 first_string_chars_block = ynew(struct string_chars_block);
2854 first_string_chars_block->prev = 0;
2855 first_string_chars_block->next = 0;
2856 first_string_chars_block->pos = 0;
2857 current_string_chars_block = first_string_chars_block;
2860 static struct string_chars*
2861 allocate_string_chars_struct(Lisp_String *string_it_goes_with,
2864 struct string_chars *s_chars;
2866 if (fullsize <= (countof(current_string_chars_block->string_chars)
2867 - current_string_chars_block->pos)) {
2868 /* This string can fit in the current string chars block */
2869 s_chars = (struct string_chars *)
2870 (current_string_chars_block->string_chars
2871 + current_string_chars_block->pos);
2872 current_string_chars_block->pos += fullsize;
2874 /* Make a new current string chars block */
2875 struct string_chars_block *new_scb =
2876 ynew(struct string_chars_block);
2878 current_string_chars_block->next = new_scb;
2879 new_scb->prev = current_string_chars_block;
2881 current_string_chars_block = new_scb;
2882 new_scb->pos = fullsize;
2883 s_chars = (struct string_chars *)
2884 current_string_chars_block->string_chars;
2887 s_chars->string = string_it_goes_with;
2889 INCREMENT_CONS_COUNTER(fullsize, "string chars");
2895 Lisp_Object make_uninit_string(Bytecount length)
2897 Lisp_String *s = NULL;
2898 #if !defined HAVE_BDWGC || !defined EF_USE_BDWGC
2899 EMACS_INT fullsize = STRING_FULLSIZE(length);
2903 #if !defined HAVE_BDWGC || !defined EF_USE_BDWGC
2904 assert(length >= 0 && fullsize > 0);
2907 /* Allocate the string header */
2908 ALLOCATE_FIXED_TYPE(string, Lisp_String, s);
2909 set_lheader_implementation(&s->lheader, &lrecord_string);
2910 string_register_finaliser(s);
2913 Bufbyte *foo = NULL;
2914 #if defined HAVE_BDWGC && defined EF_USE_BDWGC
2915 foo = xnew_atomic_array(Bufbyte, length+1);
2916 assert(foo != NULL);
2918 if (BIG_STRING_FULLSIZE_P(fullsize)) {
2919 foo = xnew_atomic_array(Bufbyte, length + 1);
2920 assert(foo != NULL);
2922 foo = allocate_string_chars_struct(s, fullsize)->chars;
2923 assert(foo != NULL);
2926 set_string_data(s, foo);
2928 set_string_length(s, length);
2930 #ifdef EF_USE_COMPRE
2933 /* propagate the cat system, go with the standard impl of a seq first */
2934 s->lheader.morphisms = 0;
2936 set_string_byte(s, length, 0);
2942 #ifdef VERIFY_STRING_CHARS_INTEGRITY
2943 static void verify_string_chars_integrity(void);
2946 /* Resize the string S so that DELTA bytes can be inserted starting
2947 at POS. If DELTA < 0, it means deletion starting at POS. If
2948 POS < 0, resize the string but don't copy any characters. Use
2949 this if you're planning on completely overwriting the string.
2952 #if defined HAVE_BDWGC && defined EF_USE_BDWGC
2953 void resize_string(Lisp_String * s, Bytecount pos, Bytecount delta)
2958 /* trivial cases first */
2960 /* simplest case: no size change. */
2964 if (pos >= 0 && delta < 0) {
2965 /* If DELTA < 0, the functions below will delete the characters
2966 before POS. We want to delete characters *after* POS,
2967 however, so convert this to the appropriate form. */
2971 /* Both strings are big. We can just realloc().
2972 But careful! If the string is shrinking, we have to
2973 memmove() _before_ realloc(), and if growing, we have to
2974 memmove() _after_ realloc() - otherwise the access is
2975 illegal, and we might crash. */
2976 len = string_length(s) + 1 - pos;
2978 if (delta < 0 && pos >= 0) {
2979 memmove(string_data(s) + pos + delta,
2980 string_data(s) + pos, len);
2983 /* do the reallocation */
2984 foo = xrealloc(string_data(s), string_length(s) + delta + 1);
2985 set_string_data(s, foo);
2987 if (delta > 0 && pos >= 0) {
2988 memmove(string_data(s) + pos + delta,
2989 string_data(s) + pos, len);
2992 set_string_length(s, string_length(s) + delta);
2993 /* If pos < 0, the string won't be zero-terminated.
2994 Terminate now just to make sure. */
2995 string_data(s)[string_length(s)] = '\0';
3000 XSETSTRING(string, s);
3001 /* We also have to adjust all of the extent indices after the
3002 place we did the change. We say "pos - 1" because
3003 adjust_extents() is exclusive of the starting position
3005 adjust_extents(string, pos - 1, string_length(s), delta);
3009 #else /* !HAVE_BDWGC */
3010 void resize_string(Lisp_String * s, Bytecount pos, Bytecount delta)
3012 Bytecount oldfullsize, newfullsize;
3013 #ifdef VERIFY_STRING_CHARS_INTEGRITY
3014 verify_string_chars_integrity();
3017 #ifdef ERROR_CHECK_BUFPOS
3019 assert(pos <= string_length(s));
3021 assert(pos + (-delta) <= string_length(s));
3024 assert((-delta) <= string_length(s));
3026 #endif /* ERROR_CHECK_BUFPOS */
3029 /* simplest case: no size change. */
3032 if (pos >= 0 && delta < 0)
3033 /* If DELTA < 0, the functions below will delete the characters
3034 before POS. We want to delete characters *after* POS, however,
3035 so convert this to the appropriate form. */
3038 oldfullsize = STRING_FULLSIZE(string_length(s));
3039 newfullsize = STRING_FULLSIZE(string_length(s) + delta);
3041 if (BIG_STRING_FULLSIZE_P(oldfullsize)) {
3042 if (BIG_STRING_FULLSIZE_P(newfullsize)) {
3043 /* Both strings are big. We can just realloc().
3044 But careful! If the string is shrinking, we have to
3045 memmove() _before_ realloc(), and if growing, we have to
3046 memmove() _after_ realloc() - otherwise the access is
3047 illegal, and we might crash. */
3048 Bytecount len = string_length(s) + 1 - pos;
3051 if (delta < 0 && pos >= 0)
3052 memmove(string_data(s) + pos + delta,
3053 string_data(s) + pos, len);
3055 foo = xrealloc(string_data(s),
3056 string_length(s) + delta + 1);
3057 set_string_data(s, foo);
3058 if (delta > 0 && pos >= 0) {
3059 memmove(string_data(s) + pos + delta,
3060 string_data(s) + pos, len);
3063 /* String has been demoted from BIG_STRING. */
3066 allocate_string_chars_struct(s, newfullsize)
3068 Bufbyte *old_data = string_data(s);
3071 memcpy(new_data, old_data, pos);
3072 memcpy(new_data + pos + delta, old_data + pos,
3073 string_length(s) + 1 - pos);
3075 set_string_data(s, new_data);
3078 } else { /* old string is small */
3080 if (oldfullsize == newfullsize) {
3081 /* special case; size change but the necessary
3082 allocation size won't change (up or down; code
3083 somewhere depends on there not being any unused
3084 allocation space, modulo any alignment
3087 Bufbyte *addroff = pos + string_data(s);
3089 memmove(addroff + delta, addroff,
3090 /* +1 due to zero-termination. */
3091 string_length(s) + 1 - pos);
3094 Bufbyte *old_data = string_data(s);
3095 Bufbyte *new_data = BIG_STRING_FULLSIZE_P(newfullsize)
3096 ? xnew_atomic_array(
3097 Bufbyte, string_length(s) + delta + 1)
3098 : allocate_string_chars_struct(
3099 s, newfullsize)->chars;
3102 memcpy(new_data, old_data, pos);
3103 memcpy(new_data + pos + delta, old_data + pos,
3104 string_length(s) + 1 - pos);
3106 set_string_data(s, new_data);
3109 /* We need to mark this chunk of the
3110 string_chars_block as unused so that
3111 compact_string_chars() doesn't freak. */
3112 struct string_chars *old_s_chars =
3113 (struct string_chars *)
3115 offsetof(struct string_chars, chars));
3116 /* Sanity check to make sure we aren't hosed by
3117 strange alignment/padding. */
3118 assert(old_s_chars->string == s);
3119 MARK_STRING_CHARS_AS_FREE(old_s_chars);
3120 ((struct unused_string_chars *)old_s_chars)->
3121 fullsize = oldfullsize;
3126 set_string_length(s, string_length(s) + delta);
3127 /* If pos < 0, the string won't be zero-terminated.
3128 Terminate now just to make sure. */
3129 string_data(s)[string_length(s)] = '\0';
3134 XSETSTRING(string, s);
3135 /* We also have to adjust all of the extent indices after the
3136 place we did the change. We say "pos - 1" because
3137 adjust_extents() is exclusive of the starting position
3139 adjust_extents(string, pos - 1, string_length(s), delta);
3141 #ifdef VERIFY_STRING_CHARS_INTEGRITY
3142 verify_string_chars_integrity();
3148 void set_string_char(Lisp_String * s, Charcount i, Emchar c)
3150 Bufbyte newstr[MAX_EMCHAR_LEN];
3151 Bytecount bytoff = charcount_to_bytecount(string_data(s), i);
3152 Bytecount oldlen = charcount_to_bytecount(string_data(s) + bytoff, 1);
3153 Bytecount newlen = set_charptr_emchar(newstr, c);
3155 if (oldlen != newlen) {
3156 resize_string(s, bytoff, newlen - oldlen);
3158 /* Remember, string_data (s) might have changed so we can't cache it. */
3159 memcpy(string_data(s) + bytoff, newstr, newlen);
3164 DEFUN("make-string", Fmake_string, 2, 2, 0, /*
3165 Return a new string consisting of LENGTH copies of CHARACTER.
3166 LENGTH must be a non-negative integer.
3168 (length, character))
3170 CHECK_NATNUM(length);
3171 CHECK_CHAR_COERCE_INT(character);
3173 Bufbyte init_str[MAX_EMCHAR_LEN];
3174 int len = set_charptr_emchar(init_str, XCHAR(character));
3175 Lisp_Object val = make_uninit_string(len * XINT(length));
3178 /* Optimize the single-byte case */
3179 memset(XSTRING_DATA(val), XCHAR(character),
3180 XSTRING_LENGTH(val));
3183 Bufbyte *ptr = XSTRING_DATA(val);
3185 for (i = XINT(length); i; i--) {
3186 Bufbyte *init_ptr = init_str;
3189 *ptr++ = *init_ptr++;
3191 *ptr++ = *init_ptr++;
3193 *ptr++ = *init_ptr++;
3195 *ptr++ = *init_ptr++;
3205 DEFUN("string", Fstring, 0, MANY, 0, /*
3206 Concatenate all the argument characters and make the result a string.
3208 (int nargs, Lisp_Object * args))
3210 Bufbyte *storage, *p;
3212 int speccount = specpdl_depth();
3213 int len = nargs * MAX_EMCHAR_LEN;
3215 XMALLOC_OR_ALLOCA(storage, len, Bufbyte);
3217 for (; nargs; nargs--, args++) {
3218 Lisp_Object lisp_char = *args;
3219 CHECK_CHAR_COERCE_INT(lisp_char);
3220 p += set_charptr_emchar(p, XCHAR(lisp_char));
3222 result = make_string(storage, p - storage);
3223 XMALLOC_UNBIND(storage, len, speccount );
3228 /* Take some raw memory, which MUST already be in internal format,
3229 and package it up into a Lisp string. */
3231 make_string(const Bufbyte *contents, Bytecount length)
3235 /* Make sure we find out about bad make_string's when they happen */
3236 #if defined (ERROR_CHECK_BUFPOS) && defined (MULE)
3237 /* Just for the assertions */
3238 bytecount_to_charcount(contents, length);
3241 val = make_uninit_string(length);
3242 memcpy(XSTRING_DATA(val), contents, length);
3246 /* Take some raw memory, encoded in some external data format,
3247 and convert it into a Lisp string. */
3249 make_ext_string(const Extbyte *contents, EMACS_INT length,
3250 Lisp_Object coding_system)
3253 TO_INTERNAL_FORMAT(DATA, (contents, length),
3254 LISP_STRING, string, coding_system);
3258 /* why arent the next 3 inlines? */
3259 Lisp_Object build_string(const char *str)
3261 /* Some strlen's crash and burn if passed null. */
3263 return make_string((const Bufbyte*)str, strlen(str));
3269 Lisp_Object build_ext_string(const char *str, Lisp_Object coding_system)
3271 /* Some strlen's crash and burn if passed null. */
3272 return make_ext_string((const Extbyte*)str, (str ? strlen(str) : 0), coding_system);
3275 Lisp_Object build_translated_string(const char *str)
3277 return build_string(GETTEXT(str));
3280 Lisp_Object make_string_nocopy(Bufbyte *contents, Bytecount length)
3285 /* Make sure we find out about bad make_string_nocopy's when they
3287 #if defined (ERROR_CHECK_BUFPOS) && defined (MULE)
3288 /* Just for the assertions */
3289 bytecount_to_charcount(contents, length);
3292 /* Allocate the string header */
3293 ALLOCATE_FIXED_TYPE(string, Lisp_String, s);
3294 set_lheader_implementation(&s->lheader, &lrecord_string);
3295 SET_C_READONLY_RECORD_HEADER(&s->lheader);
3296 string_register_finaliser(s);
3299 #ifdef EF_USE_COMPRE
3302 set_string_data(s, (Bufbyte*)contents);
3303 set_string_length(s, length);
3309 /************************************************************************/
3310 /* lcrecord lists */
3311 /************************************************************************/
3313 /* Lcrecord lists are used to manage the allocation of particular
3314 sorts of lcrecords, to avoid calling alloc_lcrecord() (and thus
3315 malloc() and garbage-collection junk) as much as possible.
3316 It is similar to the Blocktype class.
3320 1) Create an lcrecord-list object using make_lcrecord_list().
3321 This is often done at initialization. Remember to staticpro_nodump
3322 this object! The arguments to make_lcrecord_list() are the
3323 same as would be passed to alloc_lcrecord().
3324 2) Instead of calling alloc_lcrecord(), call allocate_managed_lcrecord()
3325 and pass the lcrecord-list earlier created.
3326 3) When done with the lcrecord, call free_managed_lcrecord().
3327 The standard freeing caveats apply: ** make sure there are no
3328 pointers to the object anywhere! **
3329 4) Calling free_managed_lcrecord() is just like kissing the
3330 lcrecord goodbye as if it were garbage-collected. This means:
3331 -- the contents of the freed lcrecord are undefined, and the
3332 contents of something produced by allocate_managed_lcrecord()
3333 are undefined, just like for alloc_lcrecord().
3334 -- the mark method for the lcrecord's type will *NEVER* be called
3336 -- the finalize method for the lcrecord's type will be called
3337 at the time that free_managed_lcrecord() is called.
3339 lcrecord lists do not work in bdwgc mode. -hrop
3343 #if defined HAVE_BDWGC && defined EF_USE_BDWGC
3345 mark_lcrecord_list(Lisp_Object obj)
3350 /* just imitate the lcrecord spectactular */
3352 make_lcrecord_list(size_t size,
3353 const struct lrecord_implementation *implementation)
3355 struct lcrecord_list *p =
3356 alloc_lcrecord_type(struct lcrecord_list,
3357 &lrecord_lcrecord_list);
3360 p->implementation = implementation;
3363 XSETLCRECORD_LIST(val, p);
3368 allocate_managed_lcrecord(Lisp_Object lcrecord_list)
3370 struct lcrecord_list *list = XLCRECORD_LIST(lcrecord_list);
3371 void *tmp = alloc_lcrecord(list->size, list->implementation);
3379 free_managed_lcrecord(Lisp_Object SXE_UNUSED(lcrecord_list), Lisp_Object lcrecord)
3381 struct free_lcrecord_header *free_header =
3382 (struct free_lcrecord_header*)XPNTR(lcrecord);
3383 struct lrecord_header *lheader = &free_header->lcheader.lheader;
3384 const struct lrecord_implementation *imp =
3385 LHEADER_IMPLEMENTATION(lheader);
3387 if (imp->finalizer) {
3388 imp->finalizer(lheader, 0);
3396 mark_lcrecord_list(Lisp_Object obj)
3398 struct lcrecord_list *list = XLCRECORD_LIST(obj);
3399 Lisp_Object chain = list->free;
3401 while (!NILP(chain)) {
3402 struct lrecord_header *lheader = XRECORD_LHEADER(chain);
3403 struct free_lcrecord_header *free_header =
3404 (struct free_lcrecord_header *)lheader;
3407 /* There should be no other pointers to the free list. */
3408 !MARKED_RECORD_HEADER_P(lheader)
3410 /* Only lcrecords should be here. */
3411 !LHEADER_IMPLEMENTATION(lheader)->
3413 /* Only free lcrecords should be here. */
3414 free_header->lcheader.free &&
3415 /* The type of the lcrecord must be right. */
3416 LHEADER_IMPLEMENTATION(lheader) ==
3417 list->implementation &&
3418 /* So must the size. */
3419 (LHEADER_IMPLEMENTATION(lheader)->
3421 || LHEADER_IMPLEMENTATION(lheader)->
3422 static_size == list->size)
3425 MARK_RECORD_HEADER(lheader);
3426 chain = free_header->chain;
3433 make_lcrecord_list(size_t size,
3434 const struct lrecord_implementation *implementation)
3436 struct lcrecord_list *p =
3437 alloc_lcrecord_type(struct lcrecord_list,
3438 &lrecord_lcrecord_list);
3441 p->implementation = implementation;
3444 XSETLCRECORD_LIST(val, p);
3449 allocate_managed_lcrecord(Lisp_Object lcrecord_list)
3451 struct lcrecord_list *list = XLCRECORD_LIST(lcrecord_list);
3452 if (!NILP(list->free)) {
3453 Lisp_Object val = list->free;
3454 struct free_lcrecord_header *free_header =
3455 (struct free_lcrecord_header *)XPNTR(val);
3457 #ifdef ERROR_CHECK_GC
3458 struct lrecord_header *lheader = &free_header->lcheader.lheader;
3460 /* There should be no other pointers to the free list. */
3461 assert(!MARKED_RECORD_HEADER_P(lheader));
3462 /* Only lcrecords should be here. */
3463 assert(!LHEADER_IMPLEMENTATION(lheader)->basic_p);
3464 /* Only free lcrecords should be here. */
3465 assert(free_header->lcheader.free);
3466 /* The type of the lcrecord must be right. */
3467 assert(LHEADER_IMPLEMENTATION(lheader) == list->implementation);
3468 /* So must the size. */
3469 assert(LHEADER_IMPLEMENTATION(lheader)->static_size == 0 ||
3470 LHEADER_IMPLEMENTATION(lheader)->static_size ==
3472 #endif /* ERROR_CHECK_GC */
3474 list->free = free_header->chain;
3475 free_header->lcheader.free = 0;
3478 void *tmp = alloc_lcrecord(list->size, list->implementation);
3487 free_managed_lcrecord(Lisp_Object lcrecord_list, Lisp_Object lcrecord)
3489 struct lcrecord_list *list = XLCRECORD_LIST(lcrecord_list);
3490 struct free_lcrecord_header *free_header =
3491 (struct free_lcrecord_header*)XPNTR(lcrecord);
3492 struct lrecord_header *lheader = &free_header->lcheader.lheader;
3493 const struct lrecord_implementation *implementation
3494 = LHEADER_IMPLEMENTATION(lheader);
3496 /* Make sure the size is correct. This will catch, for example,
3497 putting a window configuration on the wrong free list. */
3498 gc_checking_assert((implementation->size_in_bytes_method ?
3499 implementation->size_in_bytes_method(lheader) :
3500 implementation->static_size)
3503 if (implementation->finalizer) {
3504 implementation->finalizer(lheader, 0);
3506 free_header->chain = list->free;
3507 free_header->lcheader.free = 1;
3508 list->free = lcrecord;
3512 DEFINE_LRECORD_IMPLEMENTATION("lcrecord-list", lcrecord_list,
3513 mark_lcrecord_list, internal_object_printer,
3514 0, 0, 0, 0, struct lcrecord_list);
3517 DEFUN("purecopy", Fpurecopy, 1, 1, 0, /*
3518 Kept for compatibility, returns its argument.
3520 Make a copy of OBJECT in pure storage.
3521 Recursively copies contents of vectors and cons cells.
3522 Does not copy symbols.
3529 /************************************************************************/
3530 /* Garbage Collection */
3531 /************************************************************************/
3533 /* All the built-in lisp object types are enumerated in `enum lrecord_type'.
3534 Additional ones may be defined by a module (none yet). We leave some
3535 room in `lrecord_implementations_table' for such new lisp object types. */
3536 const struct lrecord_implementation
3537 *lrecord_implementations_table[(unsigned int)lrecord_type_last_built_in_type
3538 + MODULE_DEFINABLE_TYPE_COUNT];
3539 unsigned int lrecord_type_count = (unsigned int)lrecord_type_last_built_in_type;
3540 /* Object marker functions are in the lrecord_implementation structure.
3541 But copying them to a parallel array is much more cache-friendly.
3542 This hack speeds up (garbage-collect) by about 5%. */
3543 Lisp_Object(*lrecord_markers[countof(lrecord_implementations_table)])
3546 #ifndef EF_USE_ASYNEQ
3547 struct gcpro *gcprolist;
3550 /* We want the staticpros relocated, but not the pointers found therein.
3551 Hence we use a trivial description, as for pointerless objects. */
3552 static const struct lrecord_description staticpro_description_1[] = {
3556 static const struct struct_description staticpro_description = {
3557 sizeof(Lisp_Object *),
3558 staticpro_description_1
3561 static const struct lrecord_description staticpros_description_1[] = {
3562 XD_DYNARR_DESC(Lisp_Object_ptr_dynarr, &staticpro_description),
3566 static const struct struct_description staticpros_description = {
3567 sizeof(Lisp_Object_ptr_dynarr),
3568 staticpros_description_1
3571 Lisp_Object_ptr_dynarr *staticpros;
3573 /* Mark the Lisp_Object at non-heap VARADDRESS as a root object for
3574 garbage collection, and for dumping. */
3575 void staticpro(Lisp_Object * varaddress)
3578 Dynarr_add(staticpros, varaddress);
3579 dump_add_root_object(varaddress);
3583 #if !defined HAVE_BDWGC || !defined EF_USE_BDWGC
3584 Lisp_Object_ptr_dynarr *staticpros_nodump;
3586 /* Mark the Lisp_Object at non-heap VARADDRESS as a root object for
3587 garbage collection, but not for dumping. */
3588 void staticpro_nodump(Lisp_Object * varaddress)
3591 Dynarr_add(staticpros_nodump, varaddress);
3597 #ifdef ERROR_CHECK_GC
3598 #define GC_CHECK_LHEADER_INVARIANTS(lheader) \
3600 struct lrecord_header * GCLI_lh = (lheader); \
3601 assert (GCLI_lh != 0); \
3602 assert (GCLI_lh->type < lrecord_type_count); \
3603 assert (! C_READONLY_RECORD_HEADER_P (GCLI_lh) || \
3604 (MARKED_RECORD_HEADER_P (GCLI_lh) && \
3605 LISP_READONLY_RECORD_HEADER_P (GCLI_lh))); \
3608 #define GC_CHECK_LHEADER_INVARIANTS(lheader)
3611 /* Mark reference to a Lisp_Object. If the object referred to has not been
3612 seen yet, recursively mark all the references contained in it. */
3614 #if defined HAVE_BDWGC && defined EF_USE_BDWGC
3615 void mark_object(Lisp_Object SXE_UNUSED(obj))
3621 void mark_object(Lisp_Object obj)
3623 if (obj == Qnull_pointer) {
3628 /* Checks we used to perform */
3629 /* if (EQ (obj, Qnull_pointer)) return; */
3630 /* if (!POINTER_TYPE_P (XGCTYPE (obj))) return; */
3631 /* if (PURIFIED (XPNTR (obj))) return; */
3633 if (XTYPE(obj) == Lisp_Type_Record) {
3634 struct lrecord_header *lheader = XRECORD_LHEADER(obj);
3636 GC_CHECK_LHEADER_INVARIANTS(lheader);
3638 gc_checking_assert(LHEADER_IMPLEMENTATION(lheader)->basic_p ||
3639 !((struct lcrecord_header *)lheader)->free);
3641 /* All c_readonly objects have their mark bit set,
3642 so that we only need to check the mark bit here. */
3643 if (!MARKED_RECORD_HEADER_P(lheader)) {
3644 MARK_RECORD_HEADER(lheader);
3646 if (RECORD_MARKER(lheader)) {
3647 obj = RECORD_MARKER(lheader) (obj);
3656 /* mark all of the conses in a list and mark the final cdr; but
3657 DO NOT mark the cars.
3659 Use only for internal lists! There should never be other pointers
3660 to the cons cells, because if so, the cars will remain unmarked
3661 even when they maybe should be marked. */
3662 void mark_conses_in_list(Lisp_Object obj)
3666 for (rest = obj; CONSP(rest); rest = XCDR(rest)) {
3667 if (CONS_MARKED_P(XCONS(rest)))
3669 MARK_CONS(XCONS(rest));
3675 /* Find all structures not marked, and free them. */
3677 #if !defined HAVE_BDWGC || !defined EF_USE_BDWGC
3678 static int gc_count_num_bit_vector_used, gc_count_bit_vector_total_size;
3679 static int gc_count_bit_vector_storage;
3680 static int gc_count_num_short_string_in_use;
3681 static int gc_count_string_total_size;
3682 static int gc_count_short_string_total_size;
3685 /* static int gc_count_total_records_used, gc_count_records_total_size; */
3687 /* stats on lcrecords in use - kinda kludgy */
3689 #if !defined HAVE_BDWGC || !defined EF_USE_BDWGC
3691 int instances_in_use;
3693 int instances_freed;
3695 int instances_on_free_list;
3696 } lcrecord_stats[countof(lrecord_implementations_table)
3697 + MODULE_DEFINABLE_TYPE_COUNT];
3700 #if !defined HAVE_BDWGC || !defined EF_USE_BDWGC
3701 static void tick_lcrecord_stats(const struct lrecord_header *h, int free_p)
3703 unsigned int type_index = h->type;
3705 if (((const struct lcrecord_header *)h)->free) {
3706 gc_checking_assert(!free_p);
3707 lcrecord_stats[type_index].instances_on_free_list++;
3709 const struct lrecord_implementation *implementation =
3710 LHEADER_IMPLEMENTATION(h);
3712 size_t sz = (implementation->size_in_bytes_method ?
3713 implementation->size_in_bytes_method(h) :
3714 implementation->static_size);
3716 lcrecord_stats[type_index].instances_freed++;
3717 lcrecord_stats[type_index].bytes_freed += sz;
3719 lcrecord_stats[type_index].instances_in_use++;
3720 lcrecord_stats[type_index].bytes_in_use += sz;
3726 /* Free all unmarked records */
3727 #if !defined HAVE_BDWGC || !defined EF_USE_BDWGC
3729 sweep_lcrecords_1(struct lcrecord_header *volatile*prev, int *used)
3732 /* int total_size = 0; */
3734 xzero(lcrecord_stats); /* Reset all statistics to 0. */
3736 /* First go through and call all the finalize methods.
3737 Then go through and free the objects. There used to
3738 be only one loop here, with the call to the finalizer
3739 occurring directly before the xfree() below. That
3740 is marginally faster but much less safe -- if the
3741 finalize method for an object needs to reference any
3742 other objects contained within it (and many do),
3743 we could easily be screwed by having already freed that
3746 for (struct lcrecord_header *volatile header = *prev;
3747 header; header = header->next) {
3748 struct lrecord_header *h = &(header->lheader);
3750 GC_CHECK_LHEADER_INVARIANTS(h);
3752 if (!MARKED_RECORD_HEADER_P(h) && !header->free) {
3753 if (LHEADER_IMPLEMENTATION(h)->finalizer)
3754 LHEADER_IMPLEMENTATION(h)->finalizer(h, 0);
3758 for (struct lcrecord_header *volatile header = *prev; header;) {
3759 struct lrecord_header *volatile h = &(header->lheader);
3760 if (MARKED_RECORD_HEADER_P(h)) {
3761 if (!C_READONLY_RECORD_HEADER_P(h))
3762 UNMARK_RECORD_HEADER(h);
3764 /* total_size += n->implementation->size_in_bytes (h); */
3765 /* #### May modify header->next on a C_READONLY lcrecord */
3766 prev = &(header->next);
3768 tick_lcrecord_stats(h, 0);
3770 struct lcrecord_header *next = header->next;
3772 tick_lcrecord_stats(h, 1);
3773 /* used to call finalizer right here. */
3779 /* *total = total_size; */
3784 sweep_bit_vectors_1(Lisp_Object * prev, int *used, int *total, int *storage)
3786 Lisp_Object bit_vector;
3789 int total_storage = 0;
3791 /* BIT_VECTORP fails because the objects are marked, which changes
3792 their implementation */
3793 for (bit_vector = *prev; !EQ(bit_vector, Qzero);) {
3794 Lisp_Bit_Vector *v = XBIT_VECTOR(bit_vector);
3796 if (MARKED_RECORD_P(bit_vector)) {
3797 if (!C_READONLY_RECORD_HEADER_P(&(v->lheader)))
3798 UNMARK_RECORD_HEADER(&(v->lheader));
3802 FLEXIBLE_ARRAY_STRUCT_SIZEOF(Lisp_Bit_Vector,
3803 unsigned long, bits,
3804 BIT_VECTOR_LONG_STORAGE
3807 /* #### May modify next on a C_READONLY bitvector */
3808 prev = &(bit_vector_next(v));
3811 Lisp_Object next = bit_vector_next(v);
3818 *total = total_size;
3819 *storage = total_storage;
3823 /* And the Lord said: Thou shalt use the `c-backslash-region' command
3824 to make macros prettier. */
3826 #if defined HAVE_BDWGC && defined EF_USE_BDWGC
3827 #define SWEEP_FIXED_TYPE_BLOCK(typename, obj_type)
3829 #elif defined ERROR_CHECK_GC
3831 #define SWEEP_FIXED_TYPE_BLOCK(typename, obj_type) \
3833 struct typename##_block *SFTB_current; \
3835 int num_free = 0, num_used = 0; \
3837 for (SFTB_current = current_##typename##_block, \
3838 SFTB_limit = current_##typename##_block_index; \
3843 for (SFTB_iii = 0; \
3844 SFTB_iii < SFTB_limit; \
3846 obj_type *SFTB_victim = \
3847 &(SFTB_current->block[SFTB_iii]); \
3849 if (LRECORD_FREE_P (SFTB_victim)) { \
3851 } else if (C_READONLY_RECORD_HEADER_P \
3852 (&SFTB_victim->lheader)) { \
3854 } else if (!MARKED_RECORD_HEADER_P \
3855 (&SFTB_victim->lheader)) { \
3857 FREE_FIXED_TYPE(typename, obj_type, \
3861 UNMARK_##typename(SFTB_victim); \
3864 SFTB_current = SFTB_current->prev; \
3865 SFTB_limit = countof(current_##typename##_block \
3869 gc_count_num_##typename##_in_use = num_used; \
3870 gc_count_num_##typename##_freelist = num_free; \
3873 #else /* !ERROR_CHECK_GC, !BDWGC*/
3875 #define SWEEP_FIXED_TYPE_BLOCK(typename, obj_type) \
3877 struct typename##_block *SFTB_current; \
3878 struct typename##_block **SFTB_prev; \
3880 int num_free = 0, num_used = 0; \
3882 typename##_free_list = 0; \
3884 for (SFTB_prev = ¤t_##typename##_block, \
3885 SFTB_current = current_##typename##_block, \
3886 SFTB_limit = current_##typename##_block_index; \
3890 int SFTB_empty = 1; \
3891 Lisp_Free *SFTB_old_free_list = \
3892 typename##_free_list; \
3894 for (SFTB_iii = 0; SFTB_iii < SFTB_limit; \
3896 obj_type *SFTB_victim = \
3897 &(SFTB_current->block[SFTB_iii]); \
3899 if (LRECORD_FREE_P (SFTB_victim)) { \
3901 PUT_FIXED_TYPE_ON_FREE_LIST \
3902 (typename, obj_type, \
3904 } else if (C_READONLY_RECORD_HEADER_P \
3905 (&SFTB_victim->lheader)) { \
3908 } else if (! MARKED_RECORD_HEADER_P \
3909 (&SFTB_victim->lheader)) { \
3911 FREE_FIXED_TYPE(typename, obj_type, \
3916 UNMARK_##typename (SFTB_victim); \
3919 if (!SFTB_empty) { \
3920 SFTB_prev = &(SFTB_current->prev); \
3921 SFTB_current = SFTB_current->prev; \
3922 } else if (SFTB_current == current_##typename##_block \
3923 && !SFTB_current->prev) { \
3924 /* No real point in freeing sole \
3925 * allocation block */ \
3928 struct typename##_block *SFTB_victim_block = \
3930 if (SFTB_victim_block == \
3931 current_##typename##_block) { \
3932 current_##typename##_block_index \
3934 (current_##typename##_block \
3937 SFTB_current = SFTB_current->prev; \
3939 *SFTB_prev = SFTB_current; \
3940 xfree(SFTB_victim_block); \
3941 /* Restore free list to what it was \
3942 before victim was swept */ \
3943 typename##_free_list = \
3944 SFTB_old_free_list; \
3945 num_free -= SFTB_limit; \
3948 SFTB_limit = countof (current_##typename##_block \
3952 gc_count_num_##typename##_in_use = num_used; \
3953 gc_count_num_##typename##_freelist = num_free; \
3956 #endif /* !ERROR_CHECK_GC */
3958 #if !defined HAVE_BDWGC || !defined EF_USE_BDWGC
3959 static void sweep_conses(void)
3961 #define UNMARK_cons(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
3962 #define ADDITIONAL_FREE_cons(ptr)
3964 SWEEP_FIXED_TYPE_BLOCK(cons, Lisp_Cons);
3968 /* Explicitly free a cons cell. */
3969 void free_cons(Lisp_Cons * ptr)
3971 #ifdef ERROR_CHECK_GC
3972 /* If the CAR is not an int, then it will be a pointer, which will
3973 always be four-byte aligned. If this cons cell has already been
3974 placed on the free list, however, its car will probably contain
3975 a chain pointer to the next cons on the list, which has cleverly
3976 had all its 0's and 1's inverted. This allows for a quick
3977 check to make sure we're not freeing something already freed. */
3978 if (POINTER_TYPE_P(XTYPE(ptr->car)))
3979 ASSERT_VALID_POINTER(XPNTR(ptr->car));
3980 #endif /* ERROR_CHECK_GC */
3982 #ifndef ALLOC_NO_POOLS
3983 FREE_FIXED_TYPE_WHEN_NOT_IN_GC(cons, Lisp_Cons, ptr);
3984 #endif /* ALLOC_NO_POOLS */
3987 /* explicitly free a list. You **must make sure** that you have
3988 created all the cons cells that make up this list and that there
3989 are no pointers to any of these cons cells anywhere else. If there
3990 are, you will lose. */
3992 void free_list(Lisp_Object list)
3994 Lisp_Object rest, next;
3996 for (rest = list; !NILP(rest); rest = next) {
3998 free_cons(XCONS(rest));
4002 /* explicitly free an alist. You **must make sure** that you have
4003 created all the cons cells that make up this alist and that there
4004 are no pointers to any of these cons cells anywhere else. If there
4005 are, you will lose. */
4007 void free_alist(Lisp_Object alist)
4009 Lisp_Object rest, next;
4011 for (rest = alist; !NILP(rest); rest = next) {
4013 free_cons(XCONS(XCAR(rest)));
4014 free_cons(XCONS(rest));
4018 #if !defined HAVE_BDWGC || !defined EF_USE_BDWGC
4019 static void sweep_compiled_functions(void)
4021 #define UNMARK_compiled_function(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
4022 #define ADDITIONAL_FREE_compiled_function(ptr)
4024 SWEEP_FIXED_TYPE_BLOCK(compiled_function, Lisp_Compiled_Function);
4028 static void sweep_floats(void)
4030 #define UNMARK_float(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
4031 #define ADDITIONAL_FREE_float(ptr)
4033 SWEEP_FIXED_TYPE_BLOCK(float, Lisp_Float);
4035 #endif /* HAVE_FPFLOAT */
4037 #if defined HAVE_MPZ && (defined WITH_GMP || defined WITH_MP)
4041 #define UNMARK_bigz(ptr) UNMARK_RECORD_HEADER(&((ptr)->lheader))
4042 #define ADDITIONAL_FREE_bigz(ptr) bigz_fini(ptr->data)
4044 SWEEP_FIXED_TYPE_BLOCK(bigz, Lisp_Bigz);
4046 #endif /* HAVE_MPZ */
4048 #if defined HAVE_MPQ && defined WITH_GMP
4052 #define UNMARK_bigq(ptr) UNMARK_RECORD_HEADER(&((ptr)->lheader))
4053 #define ADDITIONAL_FREE_bigq(ptr) bigq_fini(ptr->data)
4055 SWEEP_FIXED_TYPE_BLOCK(bigq, Lisp_Bigq);
4057 #endif /* HAVE_MPQ */
4059 #if defined HAVE_MPF && defined WITH_GMP
4063 #define UNMARK_bigf(ptr) UNMARK_RECORD_HEADER(&((ptr)->lheader))
4064 #define ADDITIONAL_FREE_bigf(ptr) bigf_fini(ptr->data)
4066 SWEEP_FIXED_TYPE_BLOCK(bigf, Lisp_Bigf);
4068 #endif /* HAVE_MPF */
4070 #if defined HAVE_MPFR && defined WITH_MPFR
4074 #define UNMARK_bigfr(ptr) UNMARK_RECORD_HEADER(&((ptr)->lheader))
4075 #define ADDITIONAL_FREE_bigfr(ptr) bigfr_fini(ptr->data)
4077 SWEEP_FIXED_TYPE_BLOCK(bigfr, Lisp_Bigfr);
4079 #endif /* HAVE_MPFR */
4081 #if defined HAVE_PSEUG && defined WITH_PSEUG
4085 #define UNMARK_bigg(ptr) UNMARK_RECORD_HEADER(&((ptr)->lheader))
4086 #define ADDITIONAL_FREE_bigg(ptr) bigg_fini(ptr->data)
4088 SWEEP_FIXED_TYPE_BLOCK(bigg, Lisp_Bigg);
4090 #endif /* HAVE_PSEUG */
4092 #if defined HAVE_MPC && defined WITH_MPC || \
4093 defined HAVE_PSEUC && defined WITH_PSEUC
4097 #define UNMARK_bigc(ptr) UNMARK_RECORD_HEADER(&((ptr)->lheader))
4098 #define ADDITIONAL_FREE_bigc(ptr) bigc_fini(ptr->data)
4100 SWEEP_FIXED_TYPE_BLOCK(bigc, Lisp_Bigc);
4102 #endif /* HAVE_MPC */
4104 #if defined HAVE_QUATERN && defined HAVE_MPZ && defined WITH_QUATERN
4106 sweep_quaterns (void)
4108 #define UNMARK_quatern(ptr) UNMARK_RECORD_HEADER(&((ptr)->lheader))
4109 #define ADDITIONAL_FREE_quatern(ptr) quatern_fini(ptr->data)
4111 SWEEP_FIXED_TYPE_BLOCK(quatern, Lisp_Quatern);
4113 #endif /* HAVE_QUATERN */
4116 sweep_dynacats(void)
4118 #define UNMARK_dynacat(ptr) UNMARK_RECORD_HEADER(&((ptr)->lheader))
4119 #define ADDITIONAL_FREE_dynacat(ptr) dynacat_fini(ptr);
4121 SWEEP_FIXED_TYPE_BLOCK(dynacat, struct dynacat_s);
4124 static void sweep_symbols(void)
4126 #define UNMARK_symbol(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
4127 #define ADDITIONAL_FREE_symbol(ptr)
4129 SWEEP_FIXED_TYPE_BLOCK(symbol, Lisp_Symbol);
4132 static void sweep_extents(void)
4134 #define UNMARK_extent(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
4135 #define ADDITIONAL_FREE_extent(ptr)
4137 SWEEP_FIXED_TYPE_BLOCK(extent, struct extent);
4140 static void sweep_events(void)
4142 #define UNMARK_event(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
4143 #define ADDITIONAL_FREE_event(ptr)
4145 SWEEP_FIXED_TYPE_BLOCK(event, Lisp_Event);
4148 static void sweep_markers(void)
4150 #define UNMARK_marker(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
4151 #define ADDITIONAL_FREE_marker(ptr) \
4152 do { Lisp_Object tem; \
4153 XSETMARKER (tem, ptr); \
4154 unchain_marker (tem); \
4157 SWEEP_FIXED_TYPE_BLOCK(marker, Lisp_Marker);
4161 /* Explicitly free a marker. */
4162 void free_marker(Lisp_Marker * ptr)
4164 /* Perhaps this will catch freeing an already-freed marker. */
4165 gc_checking_assert(ptr->lheader.type == lrecord_type_marker);
4167 #ifndef ALLOC_NO_POOLS
4168 FREE_FIXED_TYPE_WHEN_NOT_IN_GC(marker, Lisp_Marker, ptr);
4169 #endif /* ALLOC_NO_POOLS */
4172 #if defined (MULE) && defined (VERIFY_STRING_CHARS_INTEGRITY)
4174 static void verify_string_chars_integrity(void)
4176 struct string_chars_block *sb;
4178 /* Scan each existing string block sequentially, string by string. */
4179 for (sb = first_string_chars_block; sb; sb = sb->next) {
4181 /* POS is the index of the next string in the block. */
4182 while (pos < sb->pos) {
4183 struct string_chars *s_chars =
4184 (struct string_chars *)&(sb->string_chars[pos]);
4185 Lisp_String *string;
4189 /* If the string_chars struct is marked as free (i.e. the
4190 STRING pointer is NULL) then this is an unused chunk of
4191 string storage. (See below.) */
4193 if (STRING_CHARS_FREE_P(s_chars)) {
4195 ((struct unused_string_chars *)s_chars)->
4201 string = s_chars->string;
4202 /* Must be 32-bit aligned. */
4203 assert((((int)string) & 3) == 0);
4205 size = string_length(string);
4206 fullsize = STRING_FULLSIZE(size);
4208 assert(!BIG_STRING_FULLSIZE_P(fullsize));
4209 assert(string_data(string) == s_chars->chars);
4212 assert(pos == sb->pos);
4216 #endif /* MULE && ERROR_CHECK_GC */
4218 #if !defined HAVE_BDWGC || !defined EF_USE_BDWGC
4219 /* Compactify string chars, relocating the reference to each --
4220 free any empty string_chars_block we see. */
4221 static void compact_string_chars(void)
4223 struct string_chars_block *to_sb = first_string_chars_block;
4225 struct string_chars_block *from_sb;
4227 /* Scan each existing string block sequentially, string by string. */
4228 for (from_sb = first_string_chars_block; from_sb;
4229 from_sb = from_sb->next) {
4231 /* FROM_POS is the index of the next string in the block. */
4232 while (from_pos < from_sb->pos) {
4233 struct string_chars *from_s_chars =
4234 (struct string_chars *)&(from_sb->
4235 string_chars[from_pos]);
4236 struct string_chars *to_s_chars;
4237 Lisp_String *string;
4241 /* If the string_chars struct is marked as free (i.e. the
4242 STRING pointer is NULL) then this is an unused chunk of
4243 string storage. This happens under Mule when a string's
4244 size changes in such a way that its fullsize changes.
4245 (Strings can change size because a different-length
4246 character can be substituted for another character.)
4247 In this case, after the bogus string pointer is the
4248 "fullsize" of this entry, i.e. how many bytes to skip. */
4250 if (STRING_CHARS_FREE_P(from_s_chars)) {
4252 ((struct unused_string_chars *)
4253 from_s_chars)->fullsize;
4254 from_pos += fullsize;
4258 string = from_s_chars->string;
4259 assert(!(LRECORD_FREE_P(string)));
4261 size = string_length(string);
4262 fullsize = STRING_FULLSIZE(size);
4264 gc_checking_assert(!BIG_STRING_FULLSIZE_P(fullsize));
4266 /* Just skip it if it isn't marked. */
4267 if (!MARKED_RECORD_HEADER_P(&(string->lheader))) {
4268 from_pos += fullsize;
4272 /* If it won't fit in what's left of TO_SB, close TO_SB
4273 out and go on to the next string_chars_block. We
4274 know that TO_SB cannot advance past FROM_SB here
4275 since FROM_SB is large enough to currently contain
4277 if ((to_pos + fullsize) >
4278 countof(to_sb->string_chars)) {
4279 to_sb->pos = to_pos;
4280 to_sb = to_sb->next;
4284 /* Compute new address of this string
4285 and update TO_POS for the space being used. */
4287 (struct string_chars *)&(to_sb->
4288 string_chars[to_pos]);
4290 /* Copy the string_chars to the new place. */
4291 if (from_s_chars != to_s_chars)
4292 memmove(to_s_chars, from_s_chars, fullsize);
4294 /* Relocate FROM_S_CHARS's reference */
4295 set_string_data(string, &(to_s_chars->chars[0]));
4297 from_pos += fullsize;
4302 /* Set current to the last string chars block still used and
4303 free any that follow. */
4304 for (volatile struct string_chars_block *victim = to_sb->next;
4306 volatile struct string_chars_block *tofree = victim;
4307 victim = victim->next;
4311 current_string_chars_block = to_sb;
4312 current_string_chars_block->pos = to_pos;
4313 current_string_chars_block->next = 0;
4316 static int debug_string_purity;
4318 static void debug_string_purity_print(Lisp_String * p)
4321 Charcount s = string_char_length(p);
4323 for (i = 0; i < s; i++) {
4324 Emchar ch = string_char(p, i);
4325 if (ch < 32 || ch >= 126)
4326 stderr_out("\\%03o", ch);
4327 else if (ch == '\\' || ch == '\"')
4328 stderr_out("\\%c", ch);
4330 stderr_out("%c", ch);
4336 #if !defined HAVE_BDWGC || !defined EF_USE_BDWGC
4337 static void sweep_strings(void)
4339 int num_small_used = 0, num_small_bytes = 0, num_bytes = 0;
4340 int debug = debug_string_purity;
4342 #define UNMARK_string(ptr) \
4344 Lisp_String *p = (ptr); \
4345 size_t size = string_length (p); \
4346 UNMARK_RECORD_HEADER (&(p->lheader)); \
4347 num_bytes += size; \
4348 if (!BIG_STRING_SIZE_P (size)) { \
4349 num_small_bytes += size; \
4353 debug_string_purity_print (p); \
4355 #define ADDITIONAL_FREE_string(ptr) \
4357 size_t size = string_length (ptr); \
4358 if (BIG_STRING_SIZE_P(size)) { \
4363 SWEEP_FIXED_TYPE_BLOCK(string, Lisp_String);
4365 gc_count_num_short_string_in_use = num_small_used;
4366 gc_count_string_total_size = num_bytes;
4367 gc_count_short_string_total_size = num_small_bytes;
4371 /* I hate duplicating all this crap! */
4372 int marked_p(Lisp_Object obj)
4374 /* Checks we used to perform. */
4375 /* if (EQ (obj, Qnull_pointer)) return 1; */
4376 /* if (!POINTER_TYPE_P (XGCTYPE (obj))) return 1; */
4377 /* if (PURIFIED (XPNTR (obj))) return 1; */
4379 if (XTYPE(obj) == Lisp_Type_Record) {
4380 struct lrecord_header *lheader = XRECORD_LHEADER(obj);
4382 GC_CHECK_LHEADER_INVARIANTS(lheader);
4384 return MARKED_RECORD_HEADER_P(lheader);
4389 #if !defined HAVE_BDWGC || !defined EF_USE_BDWGC
4390 static void gc_sweep(void)
4392 /* Free all unmarked records. Do this at the very beginning,
4393 before anything else, so that the finalize methods can safely
4394 examine items in the objects. sweep_lcrecords_1() makes
4395 sure to call all the finalize methods *before* freeing anything,
4396 to complete the safety. */
4399 sweep_lcrecords_1(&all_lcrecords, &ignored);
4402 compact_string_chars();
4404 /* Finalize methods below (called through the ADDITIONAL_FREE_foo
4405 macros) must be *extremely* careful to make sure they're not
4406 referencing freed objects. The only two existing finalize
4407 methods (for strings and markers) pass muster -- the string
4408 finalizer doesn't look at anything but its own specially-
4409 created block, and the marker finalizer only looks at live
4410 buffers (which will never be freed) and at the markers before
4411 and after it in the chain (which, by induction, will never be
4412 freed because if so, they would have already removed themselves
4415 /* Put all unmarked strings on free list, free'ing the string chars
4416 of large unmarked strings */
4419 /* Put all unmarked conses on free list */
4422 /* Free all unmarked bit vectors */
4423 sweep_bit_vectors_1(&all_bit_vectors,
4424 &gc_count_num_bit_vector_used,
4425 &gc_count_bit_vector_total_size,
4426 &gc_count_bit_vector_storage);
4428 /* Free all unmarked compiled-function objects */
4429 sweep_compiled_functions();
4432 /* Put all unmarked floats on free list */
4434 #endif /* HAVE_FPFLOAT */
4436 #if defined HAVE_MPZ && (defined WITH_GMP || defined WITH_MP)
4437 /* Put all unmarked bignums on free list */
4439 #endif /* HAVE_MPZ */
4441 #if defined HAVE_MPQ && defined WITH_GMP
4442 /* Put all unmarked ratios on free list */
4444 #endif /* HAVE_MPQ */
4446 #if defined HAVE_MPF && defined WITH_GMP
4447 /* Put all unmarked bigfloats on free list */
4449 #endif /* HAVE_MPF */
4451 #if defined HAVE_MPFR && defined WITH_MPFR
4452 /* Put all unmarked bigfloats on free list */
4454 #endif /* HAVE_MPFR */
4456 #if defined HAVE_PSEUG && defined WITH_PSEUG
4457 /* Put all unmarked gaussian numbers on free list */
4459 #endif /* HAVE_PSEUG */
4461 #if defined HAVE_MPC && defined WITH_MPC || \
4462 defined HAVE_PSEUC && defined WITH_PSEUC
4463 /* Put all unmarked complex numbers on free list */
4465 #endif /* HAVE_MPC */
4467 #if defined HAVE_QUATERN && defined WITH_QUATERN
4468 /* Put all unmarked quaternions on free list */
4470 #endif /* HAVE_QUATERN */
4472 /* Put all unmarked dynacats on free list */
4475 /* Put all unmarked symbols on free list */
4478 /* Put all unmarked extents on free list */
4481 /* Put all unmarked markers on free list.
4482 Dechain each one first from the buffer into which it points. */
4488 pdump_objects_unmark();
4493 /* Clearing for disksave. */
4495 void disksave_object_finalization(void)
4497 /* It's important that certain information from the environment not get
4498 dumped with the executable (pathnames, environment variables, etc.).
4499 To make it easier to tell when this has happened with strings(1) we
4500 clear some known-to-be-garbage blocks of memory, so that leftover
4501 results of old evaluation don't look like potential problems.
4502 But first we set some notable variables to nil and do one more GC,
4503 to turn those strings into garbage.
4506 /* Yeah, this list is pretty ad-hoc... */
4507 Vprocess_environment = Qnil;
4508 /* Vexec_directory = Qnil; */
4509 Vdata_directory = Qnil;
4510 Vdoc_directory = Qnil;
4511 Vconfigure_info_directory = Qnil;
4514 /* Vdump_load_path = Qnil; */
4515 /* Release hash tables for locate_file */
4516 Flocate_file_clear_hashing(Qt);
4517 uncache_home_directory();
4519 #if defined(LOADHIST) && !(defined(LOADHIST_DUMPED) || \
4520 defined(LOADHIST_BUILTIN))
4521 Vload_history = Qnil;
4523 Vshell_file_name = Qnil;
4525 garbage_collect_1();
4527 /* Run the disksave finalization methods of all live objects. */
4528 disksave_object_finalization_1();
4530 /* Zero out the uninitialized (really, unused) part of the containers
4531 for the live strings. */
4532 /* dont know what its counterpart in bdwgc mode is, so leave it out */
4533 #if !defined HAVE_BDWGC || !defined EF_USE_BDWGC
4535 struct string_chars_block *scb;
4536 for (scb = first_string_chars_block; scb; scb = scb->next) {
4537 int count = sizeof(scb->string_chars) - scb->pos;
4539 assert(count >= 0 && count < STRING_CHARS_BLOCK_SIZE);
4541 /* from the block's fill ptr to the end */
4542 memset((scb->string_chars + scb->pos), 0,
4549 /* There, that ought to be enough... */
4553 Lisp_Object restore_gc_inhibit(Lisp_Object val)
4555 gc_currently_forbidden = XINT(val);
4559 /* Maybe we want to use this when doing a "panic" gc after memory_full()? */
4560 static int gc_hooks_inhibited;
4562 struct post_gc_action {
4563 void (*fun) (void *);
4567 typedef struct post_gc_action post_gc_action;
4570 Dynarr_declare(post_gc_action);
4571 } post_gc_action_dynarr;
4573 static post_gc_action_dynarr *post_gc_actions;
4575 /* Register an action to be called at the end of GC.
4576 gc_in_progress is 0 when this is called.
4577 This is used when it is discovered that an action needs to be taken,
4578 but it's during GC, so it's not safe. (e.g. in a finalize method.)
4580 As a general rule, do not use Lisp objects here.
4581 And NEVER signal an error.
4584 void register_post_gc_action(void (*fun) (void *), void *arg)
4586 post_gc_action action;
4588 if (!post_gc_actions)
4589 post_gc_actions = Dynarr_new(post_gc_action);
4594 Dynarr_add(post_gc_actions, action);
4597 #if !defined HAVE_BDWGC || !defined EF_USE_BDWGC
4598 static void run_post_gc_actions(void)
4602 if (post_gc_actions) {
4603 for (i = 0; i < Dynarr_length(post_gc_actions); i++) {
4604 post_gc_action action = Dynarr_at(post_gc_actions, i);
4605 (action.fun) (action.arg);
4608 Dynarr_reset(post_gc_actions);
4614 mark_gcprolist(struct gcpro *gcpl)
4618 for (tail = gcpl; tail; tail = tail->next) {
4619 for (i = 0; i < tail->nvars; i++) {
4620 mark_object(tail->var[i]);
4626 #if defined HAVE_BDWGC && defined EF_USE_BDWGC
4635 void garbage_collect_1(void)
4637 SXE_DEBUG_GC("GC\n");
4638 #if defined GC_DEBUG_FLAG
4640 #endif /* GC_DEBUG_FLAG */
4642 GC_collect_a_little();
4646 GC_try_to_collect(stop_gc_p);
4652 void garbage_collect_1(void)
4654 #if MAX_SAVE_STACK > 0
4655 char stack_top_variable;
4656 extern char *stack_bottom;
4661 Lisp_Object pre_gc_cursor;
4662 struct gcpro gcpro1;
4665 || gc_currently_forbidden || in_display || preparing_for_armageddon)
4668 /* We used to call selected_frame() here.
4670 The following functions cannot be called inside GC
4671 so we move to after the above tests. */
4674 Lisp_Object device = Fselected_device(Qnil);
4675 /* Could happen during startup, eg. if always_gc */
4679 frame = DEVICE_SELECTED_FRAME(XDEVICE(device));
4681 signal_simple_error("No frames exist on device",
4687 pre_gc_cursor = Qnil;
4690 GCPRO1(pre_gc_cursor);
4692 /* Very important to prevent GC during any of the following
4693 stuff that might run Lisp code; otherwise, we'll likely
4694 have infinite GC recursion. */
4695 speccount = specpdl_depth();
4696 record_unwind_protect(restore_gc_inhibit,
4697 make_int(gc_currently_forbidden));
4698 gc_currently_forbidden = 1;
4700 if (!gc_hooks_inhibited)
4701 run_hook_trapping_errors("Error in pre-gc-hook", Qpre_gc_hook);
4703 /* Now show the GC cursor/message. */
4704 if (!noninteractive) {
4705 if (FRAME_WIN_P(f)) {
4706 Lisp_Object frame = make_frame(f);
4707 Lisp_Object cursor =
4708 glyph_image_instance(Vgc_pointer_glyph,
4709 FRAME_SELECTED_WINDOW(f),
4711 pre_gc_cursor = f->pointer;
4712 if (POINTER_IMAGE_INSTANCEP(cursor)
4713 /* don't change if we don't know how to change
4715 && POINTER_IMAGE_INSTANCEP(pre_gc_cursor)) {
4717 Fset_frame_pointer(frame, cursor);
4721 /* Don't print messages to the stream device. */
4722 if (STRINGP(Vgc_message) &&
4724 !FRAME_STREAM_P(f)) {
4725 char *msg = GETTEXT((char *) XSTRING_DATA(Vgc_message));
4726 Lisp_Object args[2], whole_msg;
4728 args[0] = build_string(
4729 msg ? msg : GETTEXT((char*)gc_default_message));
4730 args[1] = build_string("...");
4731 whole_msg = Fconcat(2, args);
4732 echo_area_message(f, (Bufbyte *) 0, whole_msg, 0, -1,
4733 Qgarbage_collecting);
4737 /***** Now we actually start the garbage collection. */
4741 inhibit_non_essential_printing_operations = 1;
4743 gc_generation_number[0]++;
4745 #if MAX_SAVE_STACK > 0
4747 /* Save a copy of the contents of the stack, for debugging. */
4749 /* Static buffer in which we save a copy of the C stack at each
4751 static char *stack_copy;
4752 static size_t stack_copy_size;
4754 ptrdiff_t stack_diff = &stack_top_variable - stack_bottom;
4755 size_t stack_size = (stack_diff > 0 ? stack_diff : -stack_diff);
4756 if (stack_size < MAX_SAVE_STACK) {
4757 if (stack_copy_size < stack_size) {
4759 (char *)xrealloc(stack_copy, stack_size);
4760 stack_copy_size = stack_size;
4765 0 ? stack_bottom : &stack_top_variable,
4769 #endif /* MAX_SAVE_STACK > 0 */
4771 /* Do some totally ad-hoc resource clearing. */
4772 /* #### generalize this? */
4773 clear_event_resource();
4774 cleanup_specifiers();
4776 /* Mark all the special slots that serve as the roots of
4780 Lisp_Object **p = Dynarr_begin(staticpros);
4782 for (count = Dynarr_length(staticpros); count; count--) {
4787 { /* staticpro_nodump() */
4788 Lisp_Object **p = Dynarr_begin(staticpros_nodump);
4790 for (count = Dynarr_length(staticpros_nodump); count; count--) {
4795 #if defined(EF_USE_ASYNEQ)
4796 WITH_DLLIST_TRAVERSE(
4798 eq_worker_t eqw = dllist_item;
4799 struct gcpro *gcpl = eqw->gcprolist;
4800 mark_gcprolist(gcpl));
4803 mark_gcprolist(gcprolist);
4806 struct specbinding *bind;
4807 for (bind = specpdl; bind != specpdl_ptr; bind++) {
4808 mark_object(bind->symbol);
4809 mark_object(bind->old_value);
4814 struct catchtag *catch;
4815 for (catch = catchlist; catch; catch = catch->next) {
4816 mark_object(catch->tag);
4817 mark_object(catch->val);
4822 struct backtrace *backlist;
4823 for (backlist = backtrace_list; backlist;
4824 backlist = backlist->next) {
4825 int nargs = backlist->nargs;
4828 mark_object(*backlist->function);
4830 0 /* nargs == UNEVALLED || nargs == MANY */ )
4831 mark_object(backlist->args[0]);
4833 for (i = 0; i < nargs; i++)
4834 mark_object(backlist->args[i]);
4839 mark_profiling_info();
4841 /* OK, now do the after-mark stuff. This is for things that are only
4842 marked when something else is marked (e.g. weak hash tables). There
4843 may be complex dependencies between such objects -- e.g. a weak hash
4844 table might be unmarked, but after processing a later weak hash
4845 table, the former one might get marked. So we have to iterate until
4846 nothing more gets marked. */
4847 while (finish_marking_weak_hash_tables() > 0 ||
4848 finish_marking_weak_lists() > 0) ;
4850 /* And prune (this needs to be called after everything else has been
4851 marked and before we do any sweeping). */
4852 /* #### this is somewhat ad-hoc and should probably be an object
4854 prune_weak_hash_tables();
4857 prune_syntax_tables();
4861 consing_since_gc = 0;
4862 #ifndef DEBUG_SXEMACS
4863 /* Allow you to set it really fucking low if you really want ... */
4864 if (gc_cons_threshold < 10000)
4865 gc_cons_threshold = 10000;
4869 inhibit_non_essential_printing_operations = 0;
4872 run_post_gc_actions();
4874 /******* End of garbage collection ********/
4876 run_hook_trapping_errors("Error in post-gc-hook", Qpost_gc_hook);
4878 /* Now remove the GC cursor/message */
4879 if (!noninteractive) {
4881 Fset_frame_pointer(make_frame(f), pre_gc_cursor);
4882 else if (STRINGP(Vgc_message) && !FRAME_STREAM_P(f)) {
4883 char *msg = GETTEXT((char *)XSTRING_DATA(Vgc_message));
4885 /* Show "...done" only if the echo area would otherwise
4887 if (NILP(clear_echo_area(selected_frame(),
4888 Qgarbage_collecting, 0))) {
4889 Lisp_Object args[2], whole_msg;
4890 args[0] = build_string(
4892 : GETTEXT((char*)gc_default_message));
4893 args[1] = build_string("... done");
4894 whole_msg = Fconcat(2, args);
4895 echo_area_message(selected_frame(),
4896 (Bufbyte *) 0, whole_msg, 0,
4897 -1, Qgarbage_collecting);
4902 /* now stop inhibiting GC */
4903 unbind_to(speccount, Qnil);
4905 if (!breathing_space) {
4906 breathing_space = malloc(4096 - MALLOC_OVERHEAD);
4915 /* Debugging aids. */
4916 #if defined HAVE_BDWGC && defined EF_USE_BDWGC
4917 #define HACK_O_MATIC(args...)
4918 #define gc_plist_hack(name, val, tail) \
4919 cons3(intern(name), Qzero, tail)
4923 static Lisp_Object gc_plist_hack(const char *name, int value, Lisp_Object tail)
4925 /* C doesn't have local functions (or closures, or GC, or readable
4926 syntax, or portable numeric datatypes, or bit-vectors, or characters,
4927 or arrays, or exceptions, or ...) */
4928 return cons3(intern(name), make_int(value), tail);
4931 #define HACK_O_MATIC(type, name, pl) \
4934 struct type##_block *x = current_##type##_block; \
4936 s += sizeof (*x) + MALLOC_OVERHEAD; \
4939 (pl) = gc_plist_hack ((name), s, (pl)); \
4943 DEFUN("garbage-collect", Fgarbage_collect, 0, 0, "", /*
4944 Reclaim storage for Lisp objects no longer needed.
4945 Return info on amount of space in use:
4946 ((USED-CONSES . FREE-CONSES) (USED-SYMS . FREE-SYMS)
4947 (USED-MARKERS . FREE-MARKERS) USED-STRING-CHARS USED-VECTOR-SLOTS
4949 where `PLIST' is a list of alternating keyword/value pairs providing
4950 more detailed information.
4951 Garbage collection happens automatically if you cons more than
4952 `gc-cons-threshold' bytes of Lisp data since previous garbage collection.
4956 #if defined HAVE_BDWGC && defined EF_USE_BDWGC
4960 Lisp_Object pl = Qnil;
4962 int gc_count_vector_total_size = 0;
4964 garbage_collect_1();
4966 for (i = 0; i < lrecord_type_count; i++) {
4967 if (lcrecord_stats[i].bytes_in_use != 0
4968 || lcrecord_stats[i].bytes_freed != 0
4969 || lcrecord_stats[i].instances_on_free_list != 0) {
4972 lrecord_implementations_table[i]->name;
4973 int len = strlen(name);
4976 /* save this for the FSFmacs-compatible part of the
4978 if (i == lrecord_type_vector)
4979 gc_count_vector_total_size =
4980 lcrecord_stats[i].bytes_in_use +
4981 lcrecord_stats[i].bytes_freed;
4983 sz = snprintf(buf, sizeof(buf), "%s-storage", name);
4984 assert(sz >=0 && (size_t)sz < sizeof(buf));
4985 pl = gc_plist_hack(buf, lcrecord_stats[i].bytes_in_use,
4987 /* Okay, simple pluralization check for
4988 `symbol-value-varalias' */
4989 if (name[len - 1] == 's')
4990 sz = snprintf(buf, sizeof(buf), "%ses-freed", name);
4992 sz = snprintf(buf, sizeof(buf), "%ss-freed", name);
4993 assert(sz >=0 && (size_t)sz < sizeof(buf));
4994 if (lcrecord_stats[i].instances_freed != 0)
4995 pl = gc_plist_hack(buf,
4997 instances_freed, pl);
4998 if (name[len - 1] == 's')
4999 sz = snprintf(buf, sizeof(buf), "%ses-on-free-list", name);
5001 sz = snprintf(buf, sizeof(buf), "%ss-on-free-list", name);
5002 assert(sz >=0 && (size_t)sz < sizeof(buf));
5003 if (lcrecord_stats[i].instances_on_free_list != 0)
5004 pl = gc_plist_hack(buf,
5006 instances_on_free_list, pl);
5007 if (name[len - 1] == 's')
5008 sz = snprintf(buf, sizeof(buf), "%ses-used", name);
5010 sz = snprintf(buf, sizeof(buf), "%ss-used", name);
5011 assert(sz >=0 && (size_t)sz < sizeof(buf));
5012 pl = gc_plist_hack(buf,
5013 lcrecord_stats[i].instances_in_use,
5018 HACK_O_MATIC(extent, "extent-storage", pl);
5019 pl = gc_plist_hack("extents-free", gc_count_num_extent_freelist, pl);
5020 pl = gc_plist_hack("extents-used", gc_count_num_extent_in_use, pl);
5021 HACK_O_MATIC(event, "event-storage", pl);
5022 pl = gc_plist_hack("events-free", gc_count_num_event_freelist, pl);
5023 pl = gc_plist_hack("events-used", gc_count_num_event_in_use, pl);
5024 HACK_O_MATIC(marker, "marker-storage", pl);
5025 pl = gc_plist_hack("markers-free", gc_count_num_marker_freelist, pl);
5026 pl = gc_plist_hack("markers-used", gc_count_num_marker_in_use, pl);
5028 HACK_O_MATIC(float, "float-storage", pl);
5029 pl = gc_plist_hack("floats-free", gc_count_num_float_freelist, pl);
5030 pl = gc_plist_hack("floats-used", gc_count_num_float_in_use, pl);
5031 #endif /* HAVE_FPFLOAT */
5032 #if defined HAVE_MPZ && (defined WITH_GMP || defined WITH_MP)
5033 HACK_O_MATIC(bigz, "bigz-storage", pl);
5034 pl = gc_plist_hack("bigzs-free", gc_count_num_bigz_freelist, pl);
5035 pl = gc_plist_hack("bigzs-used", gc_count_num_bigz_in_use, pl);
5036 #endif /* HAVE_MPZ */
5037 #if defined HAVE_MPQ && defined WITH_GMP
5038 HACK_O_MATIC(bigq, "bigq-storage", pl);
5039 pl = gc_plist_hack("bigqs-free", gc_count_num_bigq_freelist, pl);
5040 pl = gc_plist_hack("bigqs-used", gc_count_num_bigq_in_use, pl);
5041 #endif /* HAVE_MPQ */
5042 #if defined HAVE_MPF && defined WITH_GMP
5043 HACK_O_MATIC(bigf, "bigf-storage", pl);
5044 pl = gc_plist_hack("bigfs-free", gc_count_num_bigf_freelist, pl);
5045 pl = gc_plist_hack("bigfs-used", gc_count_num_bigf_in_use, pl);
5046 #endif /* HAVE_MPF */
5047 #if defined HAVE_MPFR && defined WITH_MPFR
5048 HACK_O_MATIC(bigfr, "bigfr-storage", pl);
5049 pl = gc_plist_hack("bigfrs-free", gc_count_num_bigfr_freelist, pl);
5050 pl = gc_plist_hack("bigfrs-used", gc_count_num_bigfr_in_use, pl);
5051 #endif /* HAVE_MPFR */
5052 #if defined HAVE_PSEUG && defined WITH_PSEUG
5053 HACK_O_MATIC(bigg, "bigg-storage", pl);
5054 pl = gc_plist_hack("biggs-free", gc_count_num_bigg_freelist, pl);
5055 pl = gc_plist_hack("biggs-used", gc_count_num_bigg_in_use, pl);
5056 #endif /* HAVE_PSEUG */
5057 #if defined HAVE_MPC && defined WITH_MPC || \
5058 defined HAVE_PSEUC && defined WITH_PSEUC
5059 HACK_O_MATIC(bigc, "bigc-storage", pl);
5060 pl = gc_plist_hack("bigcs-free", gc_count_num_bigc_freelist, pl);
5061 pl = gc_plist_hack("bigcs-used", gc_count_num_bigc_in_use, pl);
5062 #endif /* HAVE_MPC */
5063 #if defined HAVE_QUATERN && defined WITH_QUATERN
5064 HACK_O_MATIC(quatern, "quatern-storage", pl);
5065 pl = gc_plist_hack("quaterns-free", gc_count_num_quatern_freelist, pl);
5066 pl = gc_plist_hack("quaterns-used", gc_count_num_quatern_in_use, pl);
5067 #endif /* HAVE_QUATERN */
5069 HACK_O_MATIC(dynacat, "dynacat-storage", pl);
5070 pl = gc_plist_hack("dynacats-free", gc_count_num_dynacat_freelist, pl);
5071 pl = gc_plist_hack("dynacats-used", gc_count_num_dynacat_in_use, pl);
5073 HACK_O_MATIC(string, "string-header-storage", pl);
5074 pl = gc_plist_hack("long-strings-total-length",
5075 gc_count_string_total_size
5076 - gc_count_short_string_total_size, pl);
5077 HACK_O_MATIC(string_chars, "short-string-storage", pl);
5078 pl = gc_plist_hack("short-strings-total-length",
5079 gc_count_short_string_total_size, pl);
5080 pl = gc_plist_hack("strings-free", gc_count_num_string_freelist, pl);
5081 pl = gc_plist_hack("long-strings-used",
5082 gc_count_num_string_in_use
5083 - gc_count_num_short_string_in_use, pl);
5084 pl = gc_plist_hack("short-strings-used",
5085 gc_count_num_short_string_in_use, pl);
5087 HACK_O_MATIC(compiled_function, "compiled-function-storage", pl);
5088 pl = gc_plist_hack("compiled-functions-free",
5089 gc_count_num_compiled_function_freelist, pl);
5090 pl = gc_plist_hack("compiled-functions-used",
5091 gc_count_num_compiled_function_in_use, pl);
5093 pl = gc_plist_hack("bit-vector-storage", gc_count_bit_vector_storage,
5095 pl = gc_plist_hack("bit-vectors-total-length",
5096 gc_count_bit_vector_total_size, pl);
5097 pl = gc_plist_hack("bit-vectors-used", gc_count_num_bit_vector_used,
5100 HACK_O_MATIC(symbol, "symbol-storage", pl);
5101 pl = gc_plist_hack("symbols-free", gc_count_num_symbol_freelist, pl);
5102 pl = gc_plist_hack("symbols-used", gc_count_num_symbol_in_use, pl);
5104 HACK_O_MATIC(cons, "cons-storage", pl);
5105 pl = gc_plist_hack("conses-free", gc_count_num_cons_freelist, pl);
5106 pl = gc_plist_hack("conses-used", gc_count_num_cons_in_use, pl);
5108 /* The things we do for backwards-compatibility */
5109 /* fuck, what are we doing about those in the bdwgc era? -hrop */
5111 list6(Fcons(make_int(gc_count_num_cons_in_use),
5112 make_int(gc_count_num_cons_freelist)),
5113 Fcons(make_int(gc_count_num_symbol_in_use),
5114 make_int(gc_count_num_symbol_freelist)),
5115 Fcons(make_int(gc_count_num_marker_in_use),
5116 make_int(gc_count_num_marker_freelist)),
5117 make_int(gc_count_string_total_size),
5118 make_int(gc_count_vector_total_size), pl);
5124 /* grrrr ... lisp/itimer-autosave.el is using this, WTF? */
5125 DEFUN("consing-since-gc", Fconsing_since_gc, 0, 0, "", /*
5126 Return the number of bytes consed since the last garbage collection.
5127 \"Consed\" is a misnomer in that this actually counts allocation
5128 of all different kinds of objects, not just conses.
5130 If this value exceeds `gc-cons-threshold', a garbage collection happens.
5134 #if defined HAVE_BDWGC && defined EF_USE_BDWGC
5137 return make_int(consing_since_gc);
5142 int object_dead_p(Lisp_Object obj)
5144 return ((BUFFERP(obj) && !BUFFER_LIVE_P(XBUFFER(obj))) ||
5145 (FRAMEP(obj) && !FRAME_LIVE_P(XFRAME(obj))) ||
5146 (WINDOWP(obj) && !WINDOW_LIVE_P(XWINDOW(obj))) ||
5147 (DEVICEP(obj) && !DEVICE_LIVE_P(XDEVICE(obj))) ||
5148 (CONSOLEP(obj) && !CONSOLE_LIVE_P(XCONSOLE(obj))) ||
5149 (EVENTP(obj) && !EVENT_LIVE_P(XEVENT(obj))) ||
5150 (EXTENTP(obj) && !EXTENT_LIVE_P(XEXTENT(obj))));
5153 #if defined MEMORY_USAGE_STATS && !(defined HAVE_BDWGC && defined EF_USE_BDWGC)
5155 /* Attempt to determine the actual amount of space that is used for
5156 the block allocated starting at PTR, supposedly of size "CLAIMED_SIZE".
5158 It seems that the following holds:
5160 1. When using the old allocator (malloc.c):
5162 -- blocks are always allocated in chunks of powers of two. For
5163 each block, there is an overhead of 8 bytes if rcheck is not
5164 defined, 20 bytes if it is defined. In other words, a
5165 one-byte allocation needs 8 bytes of overhead for a total of
5166 9 bytes, and needs to have 16 bytes of memory chunked out for
5169 2. When using the new allocator (gmalloc.c):
5171 -- blocks are always allocated in chunks of powers of two up
5172 to 4096 bytes. Larger blocks are allocated in chunks of
5173 an integral multiple of 4096 bytes. The minimum block
5174 size is 2*sizeof (void *), or 16 bytes if SUNOS_LOCALTIME_BUG
5175 is defined. There is no per-block overhead, but there
5176 is an overhead of 3*sizeof (size_t) for each 4096 bytes
5179 3. When using the system malloc, anything goes, but they are
5180 generally slower and more space-efficient than the GNU
5181 allocators. One possibly reasonable assumption to make
5182 for want of better data is that sizeof (void *), or maybe
5183 2 * sizeof (void *), is required as overhead and that
5184 blocks are allocated in the minimum required size except
5185 that some minimum block size is imposed (e.g. 16 bytes). */
5188 malloced_storage_size(void *ptr, size_t claimed_size,
5189 struct overhead_stats * stats)
5191 size_t orig_claimed_size = claimed_size;
5195 if (claimed_size < 2 * sizeof(void *))
5196 claimed_size = 2 * sizeof(void *);
5197 # ifdef SUNOS_LOCALTIME_BUG
5198 if (claimed_size < 16)
5201 if (claimed_size < 4096) {
5204 /* compute the log base two, more or less, then use it to compute
5205 the block size needed. */
5207 /* It's big, it's heavy, it's wood! */
5208 while ((claimed_size /= 2) != 0)
5211 /* It's better than bad, it's good! */
5216 /* We have to come up with some average about the amount of
5218 if ((size_t) (rand() & 4095) < claimed_size)
5219 claimed_size += 3 * sizeof(void *);
5221 claimed_size += 4095;
5222 claimed_size &= ~4095;
5223 claimed_size += (claimed_size / 4096) * 3 * sizeof(size_t);
5226 #elif defined (SYSTEM_MALLOC)
5228 if (claimed_size < 16)
5230 claimed_size += 2 * sizeof(void *);
5232 #else /* old GNU allocator */
5234 # ifdef rcheck /* #### may not be defined here */
5242 /* compute the log base two, more or less, then use it to compute
5243 the block size needed. */
5245 /* It's big, it's heavy, it's wood! */
5246 while ((claimed_size /= 2) != 0)
5249 /* It's better than bad, it's good! */
5256 #endif /* old GNU allocator */
5259 stats->was_requested += orig_claimed_size;
5260 stats->malloc_overhead += claimed_size - orig_claimed_size;
5262 return claimed_size;
5265 size_t fixed_type_block_overhead(size_t size)
5267 size_t per_block = TYPE_ALLOC_SIZE(cons, unsigned char);
5268 size_t overhead = 0;
5269 size_t storage_size = malloced_storage_size(0, per_block, 0);
5270 while (size >= per_block) {
5272 overhead += sizeof(void *) + per_block - storage_size;
5274 if (rand() % per_block < size)
5275 overhead += sizeof(void *) + per_block - storage_size;
5279 #endif /* MEMORY_USAGE_STATS */
5281 #ifdef EF_USE_ASYNEQ
5283 init_main_worker(void)
5285 eq_worker_t res = eq_make_worker();
5286 eq_worker_thread(res) = pthread_self();
5291 #if defined HAVE_MPZ && defined WITH_GMP || \
5292 defined HAVE_MPFR && defined WITH_MPFR
5294 my_malloc(size_t bar)
5296 /* we use atomic here since GMP/MPFR do supervise their objects */
5297 void *foo = xmalloc(bar);
5298 SXE_DEBUG_GC_GMP("alloc :is %p :size %lu\n",
5299 foo, (long unsigned int)bar);
5303 /* We need the next two functions since GNU MP insists on giving us an extra
5306 my_realloc (void *ptr, size_t SXE_UNUSED(old_size), size_t new_size)
5308 void *foo = xrealloc(ptr, new_size);
5309 SXE_DEBUG_GC_GMP("gmp realloc :was %p :is %p\n", ptr, foo);
5314 my_free (void *ptr, size_t size)
5316 SXE_DEBUG_GC_GMP("free :was %p :size %lu\n",
5317 ptr, (long unsigned int)size);
5318 memset(ptr, 0, size);
5322 #endif /* GMP || MPFR */
5324 #if defined HAVE_BDWGC && defined EF_USE_BDWGC && !defined GC_DEBUG_FLAG
5326 my_shy_warn_proc(char *msg, GC_word arg)
5328 /* just don't do anything */
5334 /* Initialization */
5335 void init_bdwgc(void);
5340 #if defined HAVE_BDWGC && defined EF_USE_BDWGC
5341 # if defined GC_DEBUG_FLAG
5342 extern long GC_large_alloc_warn_interval;
5344 GC_time_limit = GC_TIME_UNLIMITED;
5345 GC_use_entire_heap = 0;
5348 GC_all_interior_pointers = 1;
5352 GC_free_space_divisor = 8;
5354 #if !defined GC_DEBUG_FLAG
5355 GC_set_warn_proc(my_shy_warn_proc);
5356 #else /* GC_DEBUG_FLAG */
5357 GC_large_alloc_warn_interval = 1L;
5358 #endif /* GC_DEBUG_FLAG */
5365 __init_gmp_mem_funs(void)
5367 #if defined HAVE_MPZ && defined WITH_GMP || \
5368 defined HAVE_MPFR && defined WITH_MPFR
5369 mp_set_memory_functions(my_malloc, my_realloc, my_free);
5370 #endif /* GMP || MPFR */
5373 void reinit_alloc_once_early(void)
5375 gc_generation_number[0] = 0;
5376 breathing_space = 0;
5377 XSETINT(all_bit_vectors, 0); /* Qzero may not be set yet. */
5378 XSETINT(Vgc_message, 0);
5379 #if !defined HAVE_BDWGC || !defined EF_USE_BDWGC
5382 ignore_malloc_warnings = 1;
5383 #ifdef DOUG_LEA_MALLOC
5384 mallopt(M_TRIM_THRESHOLD, 128 * 1024); /* trim threshold */
5385 mallopt(M_MMAP_THRESHOLD, 64 * 1024); /* mmap threshold */
5386 #if 1 /* Moved to emacs.c */
5387 mallopt(M_MMAP_MAX, 0); /* max. number of mmap'ed areas */
5390 /* the category subsystem */
5391 morphisms[lrecord_type_cons].seq_impl = &__scons;
5392 morphisms[lrecord_type_vector].seq_impl = &__svec;
5393 morphisms[lrecord_type_string].seq_impl = &__sstr;
5394 morphisms[lrecord_type_bit_vector].seq_impl = &__sbvc;
5396 init_string_alloc();
5397 #if !defined HAVE_BDWGC || !defined EF_USE_BDWGC
5398 init_string_chars_alloc();
5401 init_symbol_alloc();
5402 init_compiled_function_alloc();
5406 __init_gmp_mem_funs();
5407 #if defined HAVE_MPZ && (defined WITH_GMP || defined WITH_MP) && \
5408 !(defined HAVE_BDWGC && defined EF_USE_BDWGC)
5411 #if defined HAVE_MPQ && defined WITH_GMP && \
5412 !(defined HAVE_BDWGC && defined EF_USE_BDWGC)
5415 #if defined HAVE_MPF && defined WITH_GMP && \
5416 !(defined HAVE_BDWGC && defined EF_USE_BDWGC)
5419 #if defined HAVE_MPFR && defined WITH_MPFR
5422 #if defined HAVE_PSEUG && defined HAVE_MPZ && defined WITH_PSEUG
5425 #if defined HAVE_MPC && defined WITH_MPC || \
5426 defined HAVE_PSEUC && defined WITH_PSEUC
5429 #if defined HAVE_QUATERN && defined HAVE_MPZ && defined WITH_QUATERN
5430 init_quatern_alloc();
5432 init_dynacat_alloc();
5434 init_marker_alloc();
5435 init_extent_alloc();
5438 ignore_malloc_warnings = 0;
5440 /* we only use the 500k value for now */
5441 gc_cons_threshold = 500000;
5442 lrecord_uid_counter = 259;
5444 #if !defined HAVE_BDWGC || !defined EF_USE_BDWGC
5445 if (staticpros_nodump) {
5446 Dynarr_free(staticpros_nodump);
5448 staticpros_nodump = Dynarr_new2(Lisp_Object_ptr_dynarr, Lisp_Object *);
5449 /* merely a small optimization */
5450 Dynarr_resize(staticpros_nodump, 100);
5452 /* tuning the GCor */
5453 consing_since_gc = 0;
5454 debug_string_purity = 0;
5456 #ifdef EF_USE_ASYNEQ
5457 workers = make_noseeum_dllist();
5458 dllist_prepend(workers, init_main_worker());
5463 #if defined EF_USE_ASYNEQ && !(defined HAVE_BDWGC && defined EF_USE_BDWGC)
5464 SXE_MUTEX_INIT(&cons_mutex);
5467 gc_currently_forbidden = 0;
5468 gc_hooks_inhibited = 0;
5470 #ifdef ERROR_CHECK_TYPECHECK
5472 really_unlikely_name_to_have_accidentally_in_a_non_errb_structure =
5475 really_unlikely_name_to_have_accidentally_in_a_non_errb_structure =
5478 really_unlikely_name_to_have_accidentally_in_a_non_errb_structure =
5480 #endif /* ERROR_CHECK_TYPECHECK */
5483 void init_alloc_once_early(void)
5485 reinit_alloc_once_early();
5487 for (int i = 0; i < countof(lrecord_implementations_table); i++) {
5488 lrecord_implementations_table[i] = 0;
5491 INIT_LRECORD_IMPLEMENTATION(cons);
5492 INIT_LRECORD_IMPLEMENTATION(vector);
5493 INIT_LRECORD_IMPLEMENTATION(string);
5494 INIT_LRECORD_IMPLEMENTATION(lcrecord_list);
5496 staticpros = Dynarr_new2(Lisp_Object_ptr_dynarr, Lisp_Object *);
5497 Dynarr_resize(staticpros, 1410); /* merely a small optimization */
5498 dump_add_root_struct_ptr(&staticpros, &staticpros_description);
5500 /* GMP/MPFR mem funs */
5501 __init_gmp_mem_funs();
5506 void reinit_alloc(void)
5508 #ifdef EF_USE_ASYNEQ
5509 eq_worker_t main_th;
5510 assert(dllist_size(workers) == 1);
5511 main_th = dllist_car(workers);
5512 eq_worker_gcprolist(main_th) = NULL;
5518 void syms_of_alloc(void)
5520 DEFSYMBOL(Qpre_gc_hook);
5521 DEFSYMBOL(Qpost_gc_hook);
5522 DEFSYMBOL(Qgarbage_collecting);
5527 DEFSUBR(Fbit_vector);
5528 DEFSUBR(Fmake_byte_code);
5529 DEFSUBR(Fmake_list);
5530 DEFSUBR(Fmake_vector);
5531 DEFSUBR(Fmake_bit_vector);
5532 DEFSUBR(Fmake_string);
5534 DEFSUBR(Fmake_symbol);
5535 DEFSUBR(Fmake_marker);
5537 DEFSUBR(Fgarbage_collect);
5538 DEFSUBR(Fconsing_since_gc);
5541 void vars_of_alloc(void)
5543 DEFVAR_INT("gc-cons-threshold", &gc_cons_threshold /*
5544 *Number of bytes of consing between garbage collections.
5545 \"Consing\" is a misnomer in that this actually counts allocation
5546 of all different kinds of objects, not just conses.
5547 Garbage collection can happen automatically once this many bytes have been
5548 allocated since the last garbage collection. All data types count.
5550 Garbage collection happens automatically when `eval' or `funcall' are
5551 called. (Note that `funcall' is called implicitly as part of evaluation.)
5552 By binding this temporarily to a large number, you can effectively
5553 prevent garbage collection during a part of the program.
5555 See also `consing-since-gc'.
5558 #ifdef DEBUG_SXEMACS
5559 DEFVAR_INT("debug-allocation", &debug_allocation /*
5560 If non-zero, print out information to stderr about all objects allocated.
5561 See also `debug-allocation-backtrace-length'.
5563 debug_allocation = 0;
5565 DEFVAR_INT("debug-allocation-backtrace-length", &debug_allocation_backtrace_length /*
5566 Length (in stack frames) of short backtrace printed out by `debug-allocation'.
5568 debug_allocation_backtrace_length = 2;
5571 DEFVAR_BOOL("purify-flag", &purify_flag /*
5572 Non-nil means loading Lisp code in order to dump an executable.
5573 This means that certain objects should be allocated in readonly space.
5576 DEFVAR_LISP("pre-gc-hook", &Vpre_gc_hook /*
5577 Function or functions to be run just before each garbage collection.
5578 Interrupts, garbage collection, and errors are inhibited while this hook
5579 runs, so be extremely careful in what you add here. In particular, avoid
5580 consing, and do not interact with the user.
5582 Vpre_gc_hook = Qnil;
5584 DEFVAR_LISP("post-gc-hook", &Vpost_gc_hook /*
5585 Function or functions to be run just after each garbage collection.
5586 Interrupts, garbage collection, and errors are inhibited while this hook
5587 runs, so be extremely careful in what you add here. In particular, avoid
5588 consing, and do not interact with the user.
5590 Vpost_gc_hook = Qnil;
5592 DEFVAR_LISP("gc-message", &Vgc_message /*
5593 String to print to indicate that a garbage collection is in progress.
5594 This is printed in the echo area. If the selected frame is on a
5595 window system and `gc-pointer-glyph' specifies a value (i.e. a pointer
5596 image instance) in the domain of the selected frame, the mouse pointer
5597 will change instead of this message being printed.
5598 If it has non-string value - nothing is printed.
5600 Vgc_message = build_string(gc_default_message);
5602 DEFVAR_LISP("gc-pointer-glyph", &Vgc_pointer_glyph /*
5603 Pointer glyph used to indicate that a garbage collection is in progress.
5604 If the selected window is on a window system and this glyph specifies a
5605 value (i.e. a pointer image instance) in the domain of the selected
5606 window, the pointer will be changed as specified during garbage collection.
5607 Otherwise, a message will be printed in the echo area, as controlled
5612 void complex_vars_of_alloc(void)
5614 Vgc_pointer_glyph = Fmake_glyph_internal(Qpointer);