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 = NULL;
248 void release_breathing_space(void)
250 if (breathing_space) {
251 void *tmp = breathing_space;
252 breathing_space = NULL;
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 == NULL) {
723 breathing_space = malloc(0xFFFF - MALLOC_OVERHEAD);
726 #endif /* !HAVE_MMAP || DOUG_LEA_MALLOC */
728 #ifdef ALLOC_NO_POOLS
729 # define TYPE_ALLOC_SIZE(type, structtype) 1
731 # define TYPE_ALLOC_SIZE(type, structtype) \
732 ((2048 - MALLOC_OVERHEAD - sizeof (struct type##_block *)) \
733 / sizeof (structtype))
734 #endif /* ALLOC_NO_POOLS */
736 #if defined HAVE_BDWGC && defined EF_USE_BDWGC
737 #define DECLARE_FIXED_TYPE_ALLOC(type, structtype) \
739 init_##type##_alloc(void) \
744 #define DECLARE_FIXED_TYPE_ALLOC(type, structtype) \
746 struct type##_block \
748 struct type##_block *prev; \
749 structtype block[TYPE_ALLOC_SIZE (type, structtype)]; \
752 static struct type##_block *current_##type##_block; \
753 static int current_##type##_block_index; \
755 static Lisp_Free *type##_free_list; \
756 static Lisp_Free *type##_free_list_tail; \
759 init_##type##_alloc (void) \
761 current_##type##_block = 0; \
762 current_##type##_block_index = \
763 countof (current_##type##_block->block); \
764 type##_free_list = 0; \
765 type##_free_list_tail = 0; \
768 static int gc_count_num_##type##_in_use; \
769 static int gc_count_num_##type##_freelist
770 #endif /* HAVE_BDWGC */
772 /* no need for a case distinction, shouldn't be called in bdwgc mode */
773 #define ALLOCATE_FIXED_TYPE_FROM_BLOCK(type, result) \
775 if (current_##type##_block_index \
776 == countof (current_##type##_block->block)) { \
777 struct type##_block *AFTFB_new = \
778 (struct type##_block *) \
779 allocate_lisp_storage( \
780 sizeof (struct type##_block)); \
781 AFTFB_new->prev = current_##type##_block; \
782 current_##type##_block = AFTFB_new; \
783 current_##type##_block_index = 0; \
785 (result) = &(current_##type##_block \
786 ->block[current_##type##_block_index++]); \
789 /* Allocate an instance of a type that is stored in blocks.
790 TYPE is the "name" of the type, STRUCTTYPE is the corresponding
793 #ifdef ERROR_CHECK_GC
795 /* Note: if you get crashes in this function, suspect incorrect calls
796 to free_cons() and friends. This happened once because the cons
797 cell was not GC-protected and was getting collected before
798 free_cons() was called. */
800 /* no need for a case distinction, shouldn't be called in bdwgc mode */
801 #define ALLOCATE_FIXED_TYPE_1(type, structtype, result) \
804 if (gc_count_num_##type##_freelist > \
805 MINIMUM_ALLOWED_FIXED_TYPE_CELLS_##type) { \
806 result = (structtype *) type##_free_list; \
807 /* Before actually using the chain pointer, \
808 we complement all its bits; \
809 see FREE_FIXED_TYPE(). */ \
810 type##_free_list = (Lisp_Free *) \
812 (type##_free_list->chain)); \
813 gc_count_num_##type##_freelist--; \
815 ALLOCATE_FIXED_TYPE_FROM_BLOCK (type, result); \
817 MARK_LRECORD_AS_NOT_FREE (result); \
818 unlock_allocator(); \
821 #else /* !ERROR_CHECK_GC */
823 /* no need for a case distinction, shouldn't be called in bdwgc mode */
824 #define ALLOCATE_FIXED_TYPE_1(type, structtype, result) \
826 if (type##_free_list) { \
827 result = (structtype *) type##_free_list; \
828 type##_free_list = type##_free_list->chain; \
830 ALLOCATE_FIXED_TYPE_FROM_BLOCK (type, result); \
832 MARK_LRECORD_AS_NOT_FREE (result); \
834 #endif /* !ERROR_CHECK_GC */
836 #if defined HAVE_BDWGC && defined EF_USE_BDWGC
838 #define ALLOCATE_FIXED_TYPE(type, structtype, result) \
840 result = xnew(structtype); \
841 assert(result != NULL); \
842 INCREMENT_CONS_COUNTER(sizeof(structtype), #type); \
844 #define ALLOCATE_ATOMIC_FIXED_TYPE(type, structtype, result) \
846 result = xnew_atomic(structtype); \
847 assert(result != NULL); \
848 INCREMENT_CONS_COUNTER(sizeof(structtype), #type); \
853 #define ALLOCATE_FIXED_TYPE(type, structtype, result) \
855 ALLOCATE_FIXED_TYPE_1 (type, structtype, result); \
856 INCREMENT_CONS_COUNTER (sizeof (structtype), #type); \
858 #define ALLOCATE_ATOMIC_FIXED_TYPE ALLOCATE_FIXED_TYPE
862 #if defined HAVE_BDWGC && defined EF_USE_BDWGC
863 #define NOSEEUM_ALLOCATE_FIXED_TYPE(type, structtype, result) \
864 (result) = xnew(structtype)
866 #define NOSEEUM_ALLOCATE_FIXED_TYPE(type, structtype, result) \
868 ALLOCATE_FIXED_TYPE_1 (type, structtype, result); \
869 NOSEEUM_INCREMENT_CONS_COUNTER(sizeof (structtype), #type); \
873 /* Lisp_Free is the type to represent a free list member inside a frob
874 block of any lisp object type. */
875 typedef struct Lisp_Free {
876 struct lrecord_header lheader;
877 struct Lisp_Free *chain;
880 #define LRECORD_FREE_P(ptr) \
881 ((ptr)->lheader.type == lrecord_type_free)
883 #define MARK_LRECORD_AS_FREE(ptr) \
884 ((void) ((ptr)->lheader.type = lrecord_type_free))
886 #ifdef ERROR_CHECK_GC
887 #define MARK_LRECORD_AS_NOT_FREE(ptr) \
888 ((void) ((ptr)->lheader.type = lrecord_type_undefined))
890 #define MARK_LRECORD_AS_NOT_FREE(ptr) DO_NOTHING
893 #ifdef ERROR_CHECK_GC
895 #define PUT_FIXED_TYPE_ON_FREE_LIST(type, structtype, ptr) \
897 if (type##_free_list_tail) { \
898 /* When we store the chain pointer, we \
899 complement all its bits; this should \
900 significantly increase its bogosity in case \
901 someone tries to use the value, and \
902 should make us crash faster if someone \
903 overwrites the pointer because when it gets \
904 un-complemented in ALLOCATED_FIXED_TYPE(), \
905 the resulting pointer will be extremely \
907 type##_free_list_tail->chain = \
908 (Lisp_Free *) ~ (EMACS_UINT) (ptr); \
910 type##_free_list = (Lisp_Free *) (ptr); \
912 type##_free_list_tail = (Lisp_Free *) (ptr); \
915 #else /* !ERROR_CHECK_GC */
917 #define PUT_FIXED_TYPE_ON_FREE_LIST(type, structtype, ptr) \
919 ((Lisp_Free *) (ptr))->chain = type##_free_list; \
920 type##_free_list = (Lisp_Free *) (ptr); \
923 #endif /* !ERROR_CHECK_GC */
925 /* TYPE and STRUCTTYPE are the same as in ALLOCATE_FIXED_TYPE(). */
927 #define FREE_FIXED_TYPE(type, structtype, ptr) \
929 structtype *FFT_ptr = (ptr); \
930 ADDITIONAL_FREE_##type (FFT_ptr); \
931 deadbeef_memory (FFT_ptr, sizeof (structtype)); \
932 PUT_FIXED_TYPE_ON_FREE_LIST(type, structtype, FFT_ptr); \
933 MARK_LRECORD_AS_FREE (FFT_ptr); \
936 /* Like FREE_FIXED_TYPE() but used when we are explicitly
937 freeing a structure through free_cons(), free_marker(), etc.
938 rather than through the normal process of sweeping.
939 We attempt to undo the changes made to the allocation counters
940 as a result of this structure being allocated. This is not
941 completely necessary but helps keep things saner: e.g. this way,
942 repeatedly allocating and freeing a cons will not result in
943 the consing-since-gc counter advancing, which would cause a GC
944 and somewhat defeat the purpose of explicitly freeing. */
946 #if defined HAVE_BDWGC && defined EF_USE_BDWGC
947 #define FREE_FIXED_TYPE_WHEN_NOT_IN_GC(type, structtype, ptr)
948 #else /* !HAVE_BDWGC */
949 #define FREE_FIXED_TYPE_WHEN_NOT_IN_GC(type, structtype, ptr) \
951 FREE_FIXED_TYPE (type, structtype, ptr); \
952 DECREMENT_CONS_COUNTER (sizeof (structtype)); \
953 gc_count_num_##type##_freelist++; \
955 #endif /* HAVE_BDWGC */
957 /************************************************************************/
958 /* Cons allocation */
959 /************************************************************************/
961 DECLARE_FIXED_TYPE_ALLOC(cons, Lisp_Cons);
962 /* conses are used and freed so often that we set this really high */
963 /* #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_cons 20000 */
964 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_cons 2000
966 #if defined HAVE_BDWGC && defined EF_USE_BDWGC && 0
968 cons_register_finaliser(Lisp_Cons *s)
970 GC_finalization_proc *foo = NULL;
972 auto void cons_finaliser();
974 auto void cons_finaliser(void *obj, void *SXE_UNUSED(data))
977 memset(obj, 0, sizeof(Lisp_Cons));
981 SXE_DEBUG_GC("cons-fina %p\n", s);
982 GC_REGISTER_FINALIZER(s, cons_finaliser, NULL, foo, bar);
987 cons_register_finaliser(Lisp_Cons *SXE_UNUSED(b))
991 #endif /* HAVE_BDWGC */
993 static Lisp_Object mark_cons(Lisp_Object obj)
998 mark_object(XCAR(obj));
1002 static int cons_equal(Lisp_Object ob1, Lisp_Object ob2, int depth)
1005 while (internal_equal(XCAR(ob1), XCAR(ob2), depth)) {
1008 if (!CONSP(ob1) || !CONSP(ob2))
1009 return internal_equal(ob1, ob2, depth);
1014 /* the seq approach for conses */
1016 cons_length(const seq_t cons)
1019 GET_EXTERNAL_LIST_LENGTH((Lisp_Object)cons, len);
1024 cons_iter_init(seq_t cons, seq_iter_t si)
1026 si->data = si->seq = cons;
1031 cons_iter_next(seq_iter_t si, void **elt)
1033 if (si->data != NULL && CONSP(si->data)) {
1034 *elt = (void*)((Lisp_Cons*)si->data)->car;
1035 si->data = (void*)((Lisp_Cons*)si->data)->cdr;
1043 cons_iter_fini(seq_iter_t si)
1045 si->data = si->seq = NULL;
1050 cons_iter_reset(seq_iter_t si)
1057 cons_explode(void *restrict tgt[], size_t ntgt, const seq_t s)
1059 volatile size_t i = 0;
1060 volatile Lisp_Object c = (Lisp_Object)s;
1062 while (CONSP(c) && i < ntgt) {
1063 tgt[i++] = (void*)XCAR(c);
1069 static struct seq_impl_s __scons = {
1070 .length_f = cons_length,
1071 .iter_init_f = cons_iter_init,
1072 .iter_next_f = cons_iter_next,
1073 .iter_fini_f = cons_iter_fini,
1074 .iter_reset_f = cons_iter_reset,
1075 .explode_f = cons_explode,
1078 static const struct lrecord_description cons_description[] = {
1079 {XD_LISP_OBJECT, offsetof(Lisp_Cons, car)},
1080 {XD_LISP_OBJECT, offsetof(Lisp_Cons, cdr)},
1084 DEFINE_BASIC_LRECORD_IMPLEMENTATION("cons", cons,
1085 mark_cons, print_cons, 0, cons_equal,
1087 * No `hash' method needed.
1088 * internal_hash knows how to
1091 0, cons_description, Lisp_Cons);
1093 DEFUN("cons", Fcons, 2, 2, 0, /*
1094 Create a new cons, give it CAR and CDR as components, and return it.
1096 A cons cell is a Lisp object (an area in memory) made up of two pointers
1097 called the CAR and the CDR. Each of these pointers can point to any other
1098 Lisp object. The common Lisp data type, the list, is a specially-structured
1099 series of cons cells.
1101 The pointers are accessed from Lisp with `car' and `cdr', and mutated with
1102 `setcar' and `setcdr' respectively. For historical reasons, the aliases
1103 `rplaca' and `rplacd' (for `setcar' and `setcdr') are supported.
1107 /* This cannot GC. */
1111 ALLOCATE_FIXED_TYPE(cons, Lisp_Cons, c);
1112 set_lheader_implementation(&c->lheader, &lrecord_cons);
1113 cons_register_finaliser(c);
1117 /* propagate the cat system, go with the standard impl of a seq first */
1118 c->lheader.morphisms = 0;
1122 /* This is identical to Fcons() but it used for conses that we're
1123 going to free later, and is useful when trying to track down
1125 Lisp_Object noseeum_cons(Lisp_Object car, Lisp_Object cdr)
1130 NOSEEUM_ALLOCATE_FIXED_TYPE(cons, Lisp_Cons, c);
1131 set_lheader_implementation(&c->lheader, &lrecord_cons);
1135 /* propagate the cat system, go with the standard impl of a seq first */
1136 c->lheader.morphisms = 0;
1140 DEFUN("list", Flist, 0, MANY, 0, /*
1141 Return a newly created list with specified arguments as elements.
1142 Any number of arguments, even zero arguments, are allowed.
1144 (int nargs, Lisp_Object * args))
1146 Lisp_Object val = Qnil;
1147 Lisp_Object *argp = args + nargs;
1150 val = Fcons(*--argp, val);
1154 Lisp_Object list1(Lisp_Object obj0)
1156 /* This cannot GC. */
1157 return Fcons(obj0, Qnil);
1160 Lisp_Object list2(Lisp_Object obj0, Lisp_Object obj1)
1162 /* This cannot GC. */
1163 return Fcons(obj0, Fcons(obj1, Qnil));
1166 Lisp_Object list3(Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2)
1168 /* This cannot GC. */
1169 return Fcons(obj0, Fcons(obj1, Fcons(obj2, Qnil)));
1172 Lisp_Object cons3(Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2)
1174 /* This cannot GC. */
1175 return Fcons(obj0, Fcons(obj1, obj2));
1178 Lisp_Object acons(Lisp_Object key, Lisp_Object value, Lisp_Object alist)
1180 return Fcons(Fcons(key, value), alist);
1184 list4(Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2, Lisp_Object obj3)
1186 /* This cannot GC. */
1187 return Fcons(obj0, Fcons(obj1, Fcons(obj2, Fcons(obj3, Qnil))));
1191 list5(Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2, Lisp_Object obj3,
1194 /* This cannot GC. */
1196 Fcons(obj1, Fcons(obj2, Fcons(obj3, Fcons(obj4, Qnil)))));
1200 list6(Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2, Lisp_Object obj3,
1201 Lisp_Object obj4, Lisp_Object obj5)
1203 /* This cannot GC. */
1207 Fcons(obj3, Fcons(obj4, Fcons(obj5, Qnil))))));
1210 DEFUN("make-list", Fmake_list, 2, 2, 0, /*
1211 Return a new list of length LENGTH, with each element being OBJECT.
1215 CHECK_NATNUM(length);
1218 Lisp_Object val = Qnil;
1219 size_t size = XINT(length);
1222 val = Fcons(object, val);
1227 /************************************************************************/
1228 /* Float allocation */
1229 /************************************************************************/
1234 DECLARE_FIXED_TYPE_ALLOC(float, Lisp_Float);
1235 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_float 1000
1237 Lisp_Object make_float(fpfloat float_value)
1242 if (ENT_FLOAT_PINF_P(float_value))
1243 return make_indef(POS_INFINITY);
1244 else if (ENT_FLOAT_NINF_P(float_value))
1245 return make_indef(NEG_INFINITY);
1246 else if (ENT_FLOAT_NAN_P(float_value))
1247 return make_indef(NOT_A_NUMBER);
1249 ALLOCATE_FIXED_TYPE(float, Lisp_Float, f);
1251 /* Avoid dump-time `uninitialized memory read' purify warnings. */
1252 if (sizeof(struct lrecord_header) +
1253 sizeof(fpfloat) != sizeof(*f))
1256 set_lheader_implementation(&f->lheader, &lrecord_float);
1257 float_data(f) = float_value;
1262 #endif /* HAVE_FPFLOAT */
1264 /************************************************************************/
1265 /* Enhanced number allocation */
1266 /************************************************************************/
1269 #if defined HAVE_MPZ && (defined WITH_GMP || defined WITH_MP)
1270 DECLARE_FIXED_TYPE_ALLOC(bigz, Lisp_Bigz);
1271 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_bigz 250
1273 #if defined HAVE_BDWGC && defined EF_USE_BDWGC && 0
1275 bigz_register_finaliser(Lisp_Bigz *b)
1277 GC_finalization_proc *foo = NULL;
1279 auto void bigz_finaliser();
1281 auto void bigz_finaliser(void *obj, void *SXE_UNUSED(data))
1283 bigz_fini(bigz_data((Lisp_Bigz*)obj));
1285 memset(obj, 0, sizeof(Lisp_Bigz));
1289 GC_REGISTER_FINALIZER(b, bigz_finaliser, NULL, foo, bar);
1294 bigz_register_finaliser(Lisp_Bigz *SXE_UNUSED(b))
1298 #endif /* HAVE_BDWGC */
1300 /* WARNING: This function returns a bignum even if its argument fits into a
1301 fixnum. See Fcanonicalize_number(). */
1303 make_bigz (long bigz_value)
1307 ALLOCATE_FIXED_TYPE(bigz, Lisp_Bigz, b);
1308 bigz_register_finaliser(b);
1310 set_lheader_implementation(&b->lheader, &lrecord_bigz);
1311 bigz_init(bigz_data(b));
1312 bigz_set_long(bigz_data(b), bigz_value);
1313 return wrap_bigz(b);
1316 /* WARNING: This function returns a bigz even if its argument fits into a
1317 fixnum. See Fcanonicalize_number(). */
1319 make_bigz_bz (bigz bz)
1323 ALLOCATE_FIXED_TYPE(bigz, Lisp_Bigz, b);
1324 bigz_register_finaliser(b);
1326 set_lheader_implementation(&b->lheader, &lrecord_bigz);
1327 bigz_init(bigz_data(b));
1328 bigz_set(bigz_data(b), bz);
1329 return wrap_bigz(b);
1331 #endif /* HAVE_MPZ */
1334 #if defined HAVE_MPQ && defined WITH_GMP
1335 DECLARE_FIXED_TYPE_ALLOC(bigq, Lisp_Bigq);
1336 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_bigq 250
1338 #if defined HAVE_BDWGC && defined EF_USE_BDWGC && 0
1340 bigq_register_finaliser(Lisp_Bigq *b)
1342 GC_finalization_proc *foo = NULL;
1344 auto void bigq_finaliser();
1346 auto void bigq_finaliser(void *obj, void *SXE_UNUSED(data))
1348 bigq_fini(bigq_data((Lisp_Bigq*)obj));
1350 memset(obj, 0, sizeof(Lisp_Bigq));
1354 GC_REGISTER_FINALIZER(b, bigq_finaliser, NULL, foo, bar);
1359 bigq_register_finaliser(Lisp_Bigq *SXE_UNUSED(b))
1363 #endif /* HAVE_BDWGC */
1366 make_bigq(long numerator, unsigned long denominator)
1370 ALLOCATE_FIXED_TYPE(bigq, Lisp_Bigq, r);
1371 bigq_register_finaliser(r);
1373 set_lheader_implementation(&r->lheader, &lrecord_bigq);
1374 bigq_init(bigq_data(r));
1375 bigq_set_long_ulong(bigq_data(r), numerator, denominator);
1376 bigq_canonicalize(bigq_data(r));
1377 return wrap_bigq(r);
1381 make_bigq_bz(bigz numerator, bigz denominator)
1385 ALLOCATE_FIXED_TYPE(bigq, Lisp_Bigq, r);
1386 bigq_register_finaliser(r);
1388 set_lheader_implementation(&r->lheader, &lrecord_bigq);
1389 bigq_init(bigq_data(r));
1390 bigq_set_bigz_bigz(bigq_data(r), numerator, denominator);
1391 bigq_canonicalize(bigq_data(r));
1392 return wrap_bigq(r);
1396 make_bigq_bq(bigq rat)
1400 ALLOCATE_FIXED_TYPE(bigq, Lisp_Bigq, r);
1401 bigq_register_finaliser(r);
1403 set_lheader_implementation(&r->lheader, &lrecord_bigq);
1404 bigq_init(bigq_data(r));
1405 bigq_set(bigq_data(r), rat);
1406 return wrap_bigq(r);
1408 #endif /* HAVE_MPQ */
1411 #if defined HAVE_MPF && defined WITH_GMP
1412 DECLARE_FIXED_TYPE_ALLOC(bigf, Lisp_Bigf);
1413 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_bigf 250
1415 #if defined HAVE_BDWGC && defined EF_USE_BDWGC && 0
1417 bigf_register_finaliser(Lisp_Bigf *b)
1419 GC_finalization_proc *foo = NULL;
1421 auto void bigf_finaliser();
1423 auto void bigf_finaliser(void *obj, void *SXE_UNUSED(data))
1425 bigf_fini(bigf_data((Lisp_Bigf*)obj));
1427 memset(obj, 0, sizeof(Lisp_Bigf));
1431 GC_REGISTER_FINALIZER(b, bigf_finaliser, NULL, foo, bar);
1436 bigf_register_finaliser(Lisp_Bigf *SXE_UNUSED(b))
1440 #endif /* HAVE_BDWGC */
1442 /* This function creates a bigfloat with the default precision if the
1443 PRECISION argument is zero. */
1445 make_bigf(fpfloat float_value, unsigned long precision)
1449 ALLOCATE_FIXED_TYPE(bigf, Lisp_Bigf, f);
1450 bigf_register_finaliser(f);
1452 set_lheader_implementation(&f->lheader, &lrecord_bigf);
1453 if (precision == 0UL)
1454 bigf_init(bigf_data(f));
1456 bigf_init_prec(bigf_data(f), precision);
1457 bigf_set_fpfloat(bigf_data(f), float_value);
1458 return wrap_bigf(f);
1461 /* This function creates a bigfloat with the precision of its argument */
1463 make_bigf_bf(bigf float_value)
1467 ALLOCATE_FIXED_TYPE(bigf, Lisp_Bigf, f);
1468 bigf_register_finaliser(f);
1470 set_lheader_implementation(&f->lheader, &lrecord_bigf);
1471 bigf_init_prec(bigf_data(f), bigf_get_prec(float_value));
1472 bigf_set(bigf_data(f), float_value);
1473 return wrap_bigf(f);
1475 #endif /* HAVE_MPF */
1477 /*** Bigfloat with correct rounding ***/
1478 #if defined HAVE_MPFR && defined WITH_MPFR
1479 DECLARE_FIXED_TYPE_ALLOC(bigfr, Lisp_Bigfr);
1480 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_bigfr 250
1482 #if defined HAVE_BDWGC && defined EF_USE_BDWGC && 0
1484 bigfr_register_finaliser(Lisp_Bigfr *b)
1486 GC_finalization_proc *foo = NULL;
1488 auto void bigfr_finaliser();
1490 auto void bigfr_finaliser(void *obj, void *SXE_UNUSED(data))
1492 bigfr_fini(bigfr_data((Lisp_Bigfr*)obj));
1494 memset(obj, 0, sizeof(Lisp_Bigfr));
1498 GC_REGISTER_FINALIZER(b, bigfr_finaliser, NULL, foo, bar);
1503 bigfr_register_finaliser(Lisp_Bigfr *SXE_UNUSED(b))
1507 #endif /* HAVE_BDWGC */
1509 /* This function creates a bigfloat with the default precision if the
1510 PRECISION argument is zero. */
1512 make_bigfr(fpfloat float_value, unsigned long precision)
1516 ALLOCATE_FIXED_TYPE(bigfr, Lisp_Bigfr, f);
1517 set_lheader_implementation(&f->lheader, &lrecord_bigfr);
1518 bigfr_register_finaliser(f);
1520 if (precision == 0UL) {
1521 bigfr_init(bigfr_data(f));
1523 bigfr_init_prec(bigfr_data(f), precision);
1525 bigfr_set_fpfloat(bigfr_data(f), float_value);
1526 return wrap_bigfr(f);
1529 /* This function creates a bigfloat with the precision of its argument */
1531 make_bigfr_bf(bigf float_value)
1535 ALLOCATE_FIXED_TYPE(bigfr, Lisp_Bigfr, f);
1536 set_lheader_implementation(&f->lheader, &lrecord_bigfr);
1537 bigfr_register_finaliser(f);
1539 bigfr_init_prec(bigfr_data(f), bigf_get_prec(float_value));
1540 bigfr_set_bigf(bigfr_data(f), float_value);
1541 return wrap_bigfr(f);
1544 /* This function creates a bigfloat with the precision of its argument */
1546 make_bigfr_bfr(bigfr bfr_value)
1550 if (bigfr_nan_p(bfr_value) || bigfr_inf_p(bfr_value)) {
1551 return make_indef_bfr(bfr_value);
1554 ALLOCATE_FIXED_TYPE(bigfr, Lisp_Bigfr, f);
1555 set_lheader_implementation(&f->lheader, &lrecord_bigfr);
1556 bigfr_register_finaliser(f);
1558 bigfr_init_prec(bigfr_data(f), bigfr_get_prec(bfr_value));
1559 bigfr_set(bigfr_data(f), bfr_value);
1560 return wrap_bigfr(f);
1562 #endif /* HAVE_MPFR */
1564 /*** Big gaussian numbers ***/
1565 #if defined HAVE_PSEUG && defined HAVE_MPZ && defined WITH_PSEUG
1566 DECLARE_FIXED_TYPE_ALLOC(bigg, Lisp_Bigg);
1567 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_bigg 250
1569 #if defined HAVE_BDWGC && defined EF_USE_BDWGC && 0
1571 bigg_register_finaliser(Lisp_Bigg *b)
1573 GC_finalization_proc *foo = NULL;
1575 auto void bigg_finaliser();
1577 auto void bigg_finaliser(void *obj, void *SXE_UNUSED(data))
1579 bigg_fini(bigg_data((Lisp_Bigg*)obj));
1581 memset(obj, 0, sizeof(Lisp_Bigg));
1585 GC_REGISTER_FINALIZER(b, bigg_finaliser, NULL, foo, bar);
1590 bigg_register_finaliser(Lisp_Bigg *SXE_UNUSED(b))
1594 #endif /* HAVE_BDWGC */
1596 /* This function creates a gaussian number. */
1598 make_bigg(long intg, long imag)
1602 ALLOCATE_FIXED_TYPE(bigg, Lisp_Bigg, g);
1603 set_lheader_implementation(&g->lheader, &lrecord_bigg);
1604 bigg_register_finaliser(g);
1606 bigg_init(bigg_data(g));
1607 bigg_set_long_long(bigg_data(g), intg, imag);
1608 return wrap_bigg(g);
1611 /* This function creates a complex with the precision of its argument */
1613 make_bigg_bz(bigz intg, bigz imag)
1617 ALLOCATE_FIXED_TYPE(bigg, Lisp_Bigg, g);
1618 set_lheader_implementation(&g->lheader, &lrecord_bigg);
1619 bigg_register_finaliser(g);
1621 bigg_init(bigg_data(g));
1622 bigg_set_bigz_bigz(bigg_data(g), intg, imag);
1623 return wrap_bigg(g);
1626 /* This function creates a complex with the precision of its argument */
1628 make_bigg_bg(bigg gaussian_value)
1632 ALLOCATE_FIXED_TYPE(bigg, Lisp_Bigg, g);
1633 set_lheader_implementation(&g->lheader, &lrecord_bigg);
1634 bigg_register_finaliser(g);
1636 bigg_init(bigg_data(g));
1637 bigg_set(bigg_data(g), gaussian_value);
1638 return wrap_bigg(g);
1640 #endif /* HAVE_PSEUG */
1642 /*** Big complex numbers with correct rounding ***/
1643 #if defined HAVE_MPC && defined WITH_MPC || \
1644 defined HAVE_PSEUC && defined WITH_PSEUC
1645 DECLARE_FIXED_TYPE_ALLOC(bigc, Lisp_Bigc);
1646 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_bigc 250
1648 #if defined HAVE_BDWGC && defined EF_USE_BDWGC && 0
1650 bigc_register_finaliser(Lisp_Bigc *b)
1652 GC_finalization_proc *foo = NULL;
1654 auto void bigc_finaliser();
1656 auto void bigc_finaliser(void *obj, void *SXE_UNUSED(data))
1658 bigc_fini(bigc_data((Lisp_Bigc*)obj));
1660 memset(obj, 0, sizeof(Lisp_Bigc));
1664 GC_REGISTER_FINALIZER(b, bigc_finaliser, NULL, foo, bar);
1669 bigc_register_finaliser(Lisp_Bigc *SXE_UNUSED(b))
1673 #endif /* HAVE_BDWGC */
1675 /* This function creates a bigfloat with the default precision if the
1676 PRECISION argument is zero. */
1678 make_bigc(fpfloat re_value, fpfloat im_value, unsigned long precision)
1682 ALLOCATE_FIXED_TYPE(bigc, Lisp_Bigc, c);
1683 set_lheader_implementation(&c->lheader, &lrecord_bigc);
1684 bigc_register_finaliser(c);
1686 if (precision == 0UL) {
1687 bigc_init(bigc_data(c));
1689 bigc_init_prec(bigc_data(c), precision);
1691 bigc_set_fpfloat_fpfloat(bigc_data(c), re_value, im_value);
1692 return wrap_bigc(c);
1695 /* This function creates a complex with the precision of its argument */
1697 make_bigc_bfr(bigfr re_value, bigfr im_value, unsigned long precision)
1701 ALLOCATE_FIXED_TYPE(bigc, Lisp_Bigc, c);
1702 set_lheader_implementation(&c->lheader, &lrecord_bigc);
1703 bigc_register_finaliser(c);
1705 if (precision == 0UL) {
1706 bigc_init(bigc_data(c));
1708 bigc_init_prec(bigc_data(c), precision);
1710 bigc_set_bigfr_bigfr(bigc_data(c), re_value, im_value);
1711 return wrap_bigc(c);
1714 /* This function creates a complex with the precision of its argument */
1716 make_bigc_bc(bigc complex_value)
1720 ALLOCATE_FIXED_TYPE(bigc, Lisp_Bigc, c);
1721 set_lheader_implementation(&c->lheader, &lrecord_bigc);
1722 bigc_register_finaliser(c);
1724 bigc_init_prec(bigc_data(c), bigc_get_prec(complex_value));
1725 bigc_set(bigc_data(c), complex_value);
1726 return wrap_bigc(c);
1728 #endif /* HAVE_MPC */
1730 /*** Quaternions ***/
1731 #if defined HAVE_QUATERN && defined HAVE_MPZ && defined WITH_QUATERN
1732 DECLARE_FIXED_TYPE_ALLOC(quatern, Lisp_Quatern);
1733 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_quatern 250
1735 #if defined HAVE_BDWGC && defined EF_USE_BDWGC && 0
1737 quatern_register_finaliser(Lisp_Quatern *b)
1739 GC_finalization_proc *foo = NULL;
1741 auto void quatern_finaliser();
1743 auto void quatern_finaliser(void *obj, void *SXE_UNUSED(data))
1745 quatern_fini(quatern_data((Lisp_Quatern*)obj));
1747 memset(obj, 0, sizeof(Lisp_Quatern));
1751 GC_REGISTER_FINALIZER(b, quatern_finaliser, NULL, foo, bar);
1756 quatern_register_finaliser(Lisp_Quatern *SXE_UNUSED(b))
1760 #endif /* HAVE_BDWGC */
1762 /* This function creates a quaternion. */
1764 make_quatern(EMACS_INT z, EMACS_INT i, EMACS_INT j, EMACS_INT k)
1768 ALLOCATE_FIXED_TYPE(quatern, Lisp_Quatern, g);
1769 set_lheader_implementation(&g->lheader, &lrecord_quatern);
1770 quatern_register_finaliser(g);
1772 quatern_init(quatern_data(g));
1773 quatern_set_long_long_long_long(quatern_data(g), z, i, j, k);
1774 return wrap_quatern(g);
1778 make_quatern_bz(bigz z, bigz i, bigz j, bigz k)
1782 ALLOCATE_FIXED_TYPE(quatern, Lisp_Quatern, g);
1783 set_lheader_implementation(&g->lheader, &lrecord_quatern);
1784 quatern_register_finaliser(g);
1786 quatern_init(quatern_data(g));
1787 quatern_set_bigz_bigz_bigz_bigz(quatern_data(g), z, i, j, k);
1788 return wrap_quatern(g);
1792 make_quatern_qu(quatern quaternion)
1796 ALLOCATE_FIXED_TYPE(quatern, Lisp_Quatern, g);
1797 set_lheader_implementation(&g->lheader, &lrecord_quatern);
1798 quatern_register_finaliser(g);
1800 quatern_init(quatern_data(g));
1801 quatern_set(quatern_data(g), quaternion);
1802 return wrap_quatern(g);
1804 #endif /* HAVE_QUATERN */
1807 make_indef_internal(indef sym)
1811 i = allocate_lisp_storage(sizeof(Lisp_Indef));
1812 set_lheader_implementation(&i->lheader, &lrecord_indef);
1813 indef_data(i) = sym;
1814 return wrap_indef(i);
1818 make_indef(indef sym)
1825 case COMPLEX_INFINITY:
1826 return Vcomplex_infinity;
1829 /* list some more here */
1830 case END_OF_COMPARABLE_INFINITIES:
1831 case END_OF_INFINITIES:
1833 return Vnot_a_number;
1837 #if defined HAVE_MPFR && defined WITH_MPFR
1839 make_indef_bfr(bigfr bfr_value)
1841 if (bigfr_nan_p(bfr_value)) {
1842 return make_indef(NOT_A_NUMBER);
1843 } else if (bigfr_inf_p(bfr_value)) {
1844 if (bigfr_sign(bfr_value) > 0)
1845 return make_indef(POS_INFINITY);
1847 return make_indef(NEG_INFINITY);
1849 return make_indef(NOT_A_NUMBER);
1854 DECLARE_FIXED_TYPE_ALLOC(dynacat, struct dynacat_s);
1855 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_dynacat 1000
1857 #if defined HAVE_BDWGC && defined EF_USE_BDWGC
1859 dynacat_register_finaliser(dynacat_t b)
1861 GC_finalization_proc *foo = NULL;
1863 auto void dynacat_finaliser();
1865 auto void dynacat_finaliser(void *obj, void *SXE_UNUSED(data))
1867 SXE_DEBUG_GC("calling dynacat finaliser on %p\n", obj);
1870 memset(obj, 0, sizeof(struct dynacat_s));
1874 SXE_DEBUG_GC("dynacat-fina %p\n", b);
1875 GC_REGISTER_FINALIZER(b, dynacat_finaliser, NULL, foo, bar);
1880 dynacat_register_finaliser(dynacat_t SXE_UNUSED(b))
1884 #endif /* HAVE_BDWGC */
1887 make_dynacat(void *ptr)
1891 ALLOCATE_FIXED_TYPE(dynacat, struct dynacat_s, emp);
1892 dynacat_register_finaliser(emp);
1893 set_lheader_implementation(&emp->lheader, &lrecord_dynacat);
1896 emp->intprfun = NULL;
1903 return wrap_object(emp);
1907 /************************************************************************/
1908 /* Vector allocation */
1909 /************************************************************************/
1911 static Lisp_Object mark_vector(Lisp_Object obj)
1913 Lisp_Vector *ptr = XVECTOR(obj);
1914 int len = vector_length(ptr);
1917 for (i = 0; i < len - 1; i++)
1918 mark_object(ptr->contents[i]);
1919 return (len > 0) ? ptr->contents[len - 1] : Qnil;
1922 static size_t size_vector(const void *lheader)
1924 return FLEXIBLE_ARRAY_STRUCT_SIZEOF(
1925 Lisp_Vector, Lisp_Object, contents,
1926 ((const Lisp_Vector*)lheader)->size);
1929 static int vector_equal(Lisp_Object obj1, Lisp_Object obj2, int depth)
1931 int len = XVECTOR_LENGTH(obj1);
1932 if (len != XVECTOR_LENGTH(obj2))
1936 Lisp_Object *ptr1 = XVECTOR_DATA(obj1);
1937 Lisp_Object *ptr2 = XVECTOR_DATA(obj2);
1939 if (!internal_equal(*ptr1++, *ptr2++, depth + 1))
1945 static hcode_t vector_hash(Lisp_Object obj, int depth)
1947 return HASH2(XVECTOR_LENGTH(obj),
1948 internal_array_hash(XVECTOR_DATA(obj),
1949 XVECTOR_LENGTH(obj), depth + 1));
1952 /* the seq approach for conses */
1954 vec_length(const seq_t v)
1956 return XVECTOR_LENGTH((Lisp_Object)(long int)v);
1960 vec_iter_init(seq_t v, seq_iter_t si)
1963 si->data = (void*)0;
1968 vec_iter_next(seq_iter_t si, void **elt)
1970 if (si->seq != NULL &&
1971 (long int)si->data < ((Lisp_Vector*)si->seq)->size) {
1972 *elt = (void*)vector_data((Lisp_Vector*)si->seq)
1973 [(long int)si->data];
1974 si->data = (void*)((long int)si->data + 1L);
1982 vec_iter_fini(seq_iter_t si)
1984 si->data = si->seq = NULL;
1989 vec_iter_reset(seq_iter_t si)
1991 si->data = (void*)0;
1996 vec_explode(void *restrict tgt[], size_t ntgt, const seq_t s)
1998 size_t len = vector_length((const Lisp_Vector*)s);
1999 volatile size_t i = 0;
2001 while (i < len && i < ntgt) {
2002 tgt[i] = (void*)vector_data((const Lisp_Vector*)s)[i];
2008 static struct seq_impl_s __svec = {
2009 .length_f = vec_length,
2010 .iter_init_f = vec_iter_init,
2011 .iter_next_f = vec_iter_next,
2012 .iter_fini_f = vec_iter_fini,
2013 .iter_reset_f = vec_iter_reset,
2014 .explode_f = vec_explode,
2017 static const struct lrecord_description vector_description[] = {
2018 {XD_LONG, offsetof(Lisp_Vector, size)},
2019 {XD_LISP_OBJECT_ARRAY, offsetof(Lisp_Vector, contents),
2024 DEFINE_LRECORD_SEQUENCE_IMPLEMENTATION("vector", vector,
2025 mark_vector, print_vector, 0,
2029 size_vector, Lisp_Vector);
2031 /* #### should allocate `small' vectors from a frob-block */
2032 static Lisp_Vector *make_vector_internal(size_t sizei)
2034 /* no vector_next */
2035 size_t sizem = FLEXIBLE_ARRAY_STRUCT_SIZEOF(Lisp_Vector, Lisp_Object,
2037 Lisp_Vector *p = (Lisp_Vector *) alloc_lcrecord(sizem, &lrecord_vector);
2040 p->header.lheader.morphisms = (1<<cat_mk_lc);
2044 Lisp_Object make_vector(size_t length, Lisp_Object object)
2046 Lisp_Vector *vecp = make_vector_internal(length);
2047 Lisp_Object *p = vector_data(vecp);
2054 XSETVECTOR(vector, vecp);
2059 DEFUN("make-vector", Fmake_vector, 2, 2, 0, /*
2060 Return a new vector of length LENGTH, with each element being OBJECT.
2061 See also the function `vector'.
2065 CONCHECK_NATNUM(length);
2066 return make_vector(XINT(length), object);
2069 DEFUN("vector", Fvector, 0, MANY, 0, /*
2070 Return a newly created vector with specified arguments as elements.
2071 Any number of arguments, even zero arguments, are allowed.
2073 (int nargs, Lisp_Object * args))
2075 Lisp_Vector *vecp = make_vector_internal(nargs);
2076 Lisp_Object *p = vector_data(vecp);
2083 XSETVECTOR(vector, vecp);
2088 Lisp_Object vector1(Lisp_Object obj0)
2090 return Fvector(1, &obj0);
2093 Lisp_Object vector2(Lisp_Object obj0, Lisp_Object obj1)
2095 Lisp_Object args[2];
2098 return Fvector(2, args);
2101 Lisp_Object vector3(Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2)
2103 Lisp_Object args[3];
2107 return Fvector(3, args);
2110 #if 0 /* currently unused */
2113 vector4(Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2, Lisp_Object obj3)
2115 Lisp_Object args[4];
2120 return Fvector(4, args);
2124 vector5(Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
2125 Lisp_Object obj3, Lisp_Object obj4)
2127 Lisp_Object args[5];
2133 return Fvector(5, args);
2137 vector6(Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
2138 Lisp_Object obj3, Lisp_Object obj4, Lisp_Object obj5)
2140 Lisp_Object args[6];
2147 return Fvector(6, args);
2151 vector7(Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
2152 Lisp_Object obj3, Lisp_Object obj4, Lisp_Object obj5, Lisp_Object obj6)
2154 Lisp_Object args[7];
2162 return Fvector(7, args);
2166 vector8(Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
2167 Lisp_Object obj3, Lisp_Object obj4, Lisp_Object obj5,
2168 Lisp_Object obj6, Lisp_Object obj7)
2170 Lisp_Object args[8];
2179 return Fvector(8, args);
2183 /************************************************************************/
2184 /* Bit Vector allocation */
2185 /************************************************************************/
2187 static Lisp_Object all_bit_vectors;
2189 /* #### should allocate `small' bit vectors from a frob-block */
2190 static Lisp_Bit_Vector *make_bit_vector_internal(size_t sizei)
2192 size_t num_longs = BIT_VECTOR_LONG_STORAGE(sizei);
2194 FLEXIBLE_ARRAY_STRUCT_SIZEOF(Lisp_Bit_Vector, unsigned long,
2196 Lisp_Bit_Vector *p = (Lisp_Bit_Vector *) allocate_lisp_storage(sizem);
2197 set_lheader_implementation(&p->lheader, &lrecord_bit_vector);
2199 INCREMENT_CONS_COUNTER(sizem, "bit-vector");
2201 bit_vector_length(p) = sizei;
2202 bit_vector_next(p) = all_bit_vectors;
2203 /* make sure the extra bits in the last long are 0; the calling
2204 functions might not set them. */
2205 p->bits[num_longs - 1] = 0;
2206 XSETBIT_VECTOR(all_bit_vectors, p);
2208 /* propagate seq implementation */
2209 p->lheader.morphisms = 0;
2213 Lisp_Object make_bit_vector(size_t length, Lisp_Object bit)
2215 Lisp_Bit_Vector *p = make_bit_vector_internal(length);
2216 size_t num_longs = BIT_VECTOR_LONG_STORAGE(length);
2221 memset(p->bits, 0, num_longs * sizeof(long));
2223 size_t bits_in_last = length & (LONGBITS_POWER_OF_2 - 1);
2224 memset(p->bits, ~0, num_longs * sizeof(long));
2225 /* But we have to make sure that the unused bits in the
2226 last long are 0, so that equal/hash is easy. */
2228 p->bits[num_longs - 1] &= (1 << bits_in_last) - 1;
2232 Lisp_Object bit_vector;
2233 XSETBIT_VECTOR(bit_vector, p);
2239 make_bit_vector_from_byte_vector(unsigned char *bytevec, size_t length)
2242 Lisp_Bit_Vector *p = make_bit_vector_internal(length);
2244 for (i = 0; i < length; i++)
2245 set_bit_vector_bit(p, i, bytevec[i]);
2248 Lisp_Object bit_vector;
2249 XSETBIT_VECTOR(bit_vector, p);
2254 DEFUN("make-bit-vector", Fmake_bit_vector, 2, 2, 0, /*
2255 Return a new bit vector of length LENGTH. with each bit set to BIT.
2256 BIT must be one of the integers 0 or 1. See also the function `bit-vector'.
2260 CONCHECK_NATNUM(length);
2262 return make_bit_vector(XINT(length), bit);
2265 DEFUN("bit-vector", Fbit_vector, 0, MANY, 0, /*
2266 Return a newly created bit vector with specified arguments as elements.
2267 Any number of arguments, even zero arguments, are allowed.
2268 Each argument must be one of the integers 0 or 1.
2270 (int nargs, Lisp_Object * args))
2273 Lisp_Bit_Vector *p = make_bit_vector_internal(nargs);
2275 for (i = 0; i < nargs; i++) {
2277 set_bit_vector_bit(p, i, !ZEROP(args[i]));
2281 Lisp_Object bit_vector;
2282 XSETBIT_VECTOR(bit_vector, p);
2287 /* the seq approach for conses */
2289 bvc_length(const seq_t bv)
2291 return bit_vector_length(XBIT_VECTOR((Lisp_Object)(long int)bv));
2295 bvc_iter_init(seq_t bv, seq_iter_t si)
2298 si->data = (void*)0;
2303 bvc_iter_next(seq_iter_t si, void **elt)
2305 if (si->seq != NULL &&
2306 (long int)si->data < bit_vector_length((Lisp_Bit_Vector*)si->seq)) {
2307 *elt = (void*)make_int(
2309 (Lisp_Bit_Vector*)si->seq, (size_t)si->data));
2310 si->data = (void*)((long int)si->data + 1L);
2318 bvc_iter_fini(seq_iter_t si)
2320 si->data = si->seq = NULL;
2325 bvc_iter_reset(seq_iter_t si)
2327 si->data = (void*)0;
2332 bvc_explode(void *restrict tgt[], size_t ntgt, const seq_t s)
2334 size_t len = bit_vector_length((const Lisp_Bit_Vector*)s);
2335 volatile size_t i = 0;
2337 while (i < len && i < ntgt) {
2338 tgt[i] = (void*)make_int(
2339 bit_vector_bit((const Lisp_Bit_Vector*)s, i));
2345 static struct seq_impl_s __sbvc = {
2346 .length_f = bvc_length,
2347 .iter_init_f = bvc_iter_init,
2348 .iter_next_f = bvc_iter_next,
2349 .iter_fini_f = bvc_iter_fini,
2350 .iter_reset_f = bvc_iter_reset,
2351 .explode_f = bvc_explode,
2354 /************************************************************************/
2355 /* Compiled-function allocation */
2356 /************************************************************************/
2358 DECLARE_FIXED_TYPE_ALLOC(compiled_function, Lisp_Compiled_Function);
2359 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_compiled_function 1000
2361 static Lisp_Object make_compiled_function(void)
2363 Lisp_Compiled_Function *f;
2366 ALLOCATE_FIXED_TYPE(compiled_function, Lisp_Compiled_Function, f);
2367 set_lheader_implementation(&f->lheader, &lrecord_compiled_function);
2370 f->specpdl_depth = 0;
2371 f->flags.documentationp = 0;
2372 f->flags.interactivep = 0;
2373 f->flags.domainp = 0; /* I18N3 */
2374 f->instructions = Qzero;
2375 f->constants = Qzero;
2377 f->doc_and_interactive = Qnil;
2378 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
2379 f->annotated = Qnil;
2381 XSETCOMPILED_FUNCTION(fun, f);
2385 DEFUN("make-byte-code", Fmake_byte_code, 4, MANY, 0, /*
2386 Return a new compiled-function object.
2387 Usage: (arglist instructions constants stack-depth
2388 &optional doc-string interactive)
2389 Note that, unlike all other emacs-lisp functions, calling this with five
2390 arguments is NOT the same as calling it with six arguments, the last of
2391 which is nil. If the INTERACTIVE arg is specified as nil, then that means
2392 that this function was defined with `(interactive)'. If the arg is not
2393 specified, then that means the function is not interactive.
2394 This is terrible behavior which is retained for compatibility with old
2395 `.elc' files which expect these semantics.
2397 (int nargs, Lisp_Object * args))
2399 /* In a non-insane world this function would have this arglist...
2400 (arglist instructions constants stack_depth &optional doc_string interactive)
2402 Lisp_Object fun = make_compiled_function();
2403 Lisp_Compiled_Function *f = XCOMPILED_FUNCTION(fun);
2405 Lisp_Object arglist = args[0];
2406 Lisp_Object instructions = args[1];
2407 Lisp_Object constants = args[2];
2408 Lisp_Object stack_depth = args[3];
2409 Lisp_Object doc_string = (nargs > 4) ? args[4] : Qnil;
2410 Lisp_Object interactive = (nargs > 5) ? args[5] : Qunbound;
2412 if (nargs < 4 || nargs > 6)
2413 return Fsignal(Qwrong_number_of_arguments,
2414 list2(intern("make-byte-code"),
2417 /* Check for valid formal parameter list now, to allow us to use
2418 SPECBIND_FAST_UNSAFE() later in funcall_compiled_function(). */
2420 EXTERNAL_LIST_LOOP_3(symbol, arglist, tail) {
2421 CHECK_SYMBOL(symbol);
2422 if (EQ(symbol, Qt) ||
2423 EQ(symbol, Qnil) || SYMBOL_IS_KEYWORD(symbol))
2424 signal_simple_error_2
2425 ("Invalid constant symbol in formal parameter list",
2429 f->arglist = arglist;
2431 /* `instructions' is a string or a cons (string . int) for a
2432 lazy-loaded function. */
2433 if (CONSP(instructions)) {
2434 CHECK_STRING(XCAR(instructions));
2435 CHECK_INT(XCDR(instructions));
2437 CHECK_STRING(instructions);
2439 f->instructions = instructions;
2441 if (!NILP(constants))
2442 CHECK_VECTOR(constants);
2443 f->constants = constants;
2445 CHECK_NATNUM(stack_depth);
2446 f->stack_depth = (unsigned short)XINT(stack_depth);
2448 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
2449 if (!NILP(Vcurrent_compiled_function_annotation))
2450 f->annotated = Fcopy(Vcurrent_compiled_function_annotation);
2451 else if (!NILP(Vload_file_name_internal_the_purecopy))
2452 f->annotated = Vload_file_name_internal_the_purecopy;
2453 else if (!NILP(Vload_file_name_internal)) {
2454 struct gcpro gcpro1;
2455 GCPRO1(fun); /* don't let fun get reaped */
2456 Vload_file_name_internal_the_purecopy =
2457 Ffile_name_nondirectory(Vload_file_name_internal);
2458 f->annotated = Vload_file_name_internal_the_purecopy;
2461 #endif /* COMPILED_FUNCTION_ANNOTATION_HACK */
2463 /* doc_string may be nil, string, int, or a cons (string . int).
2464 interactive may be list or string (or unbound). */
2465 f->doc_and_interactive = Qunbound;
2467 if ((f->flags.domainp = !NILP(Vfile_domain)) != 0)
2468 f->doc_and_interactive = Vfile_domain;
2470 if ((f->flags.interactivep = !UNBOUNDP(interactive)) != 0) {
2471 f->doc_and_interactive
2472 = (UNBOUNDP(f->doc_and_interactive) ? interactive :
2473 Fcons(interactive, f->doc_and_interactive));
2475 if ((f->flags.documentationp = !NILP(doc_string)) != 0) {
2476 f->doc_and_interactive
2477 = (UNBOUNDP(f->doc_and_interactive) ? doc_string :
2478 Fcons(doc_string, f->doc_and_interactive));
2480 if (UNBOUNDP(f->doc_and_interactive))
2481 f->doc_and_interactive = Qnil;
2486 /************************************************************************/
2487 /* Symbol allocation */
2488 /************************************************************************/
2490 DECLARE_FIXED_TYPE_ALLOC(symbol, Lisp_Symbol);
2491 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_symbol 1000
2493 DEFUN("make-symbol", Fmake_symbol, 1, 1, 0, /*
2494 Return a newly allocated uninterned symbol whose name is NAME.
2495 Its value and function definition are void, and its property list is nil.
2504 ALLOCATE_FIXED_TYPE(symbol, Lisp_Symbol, p);
2505 set_lheader_implementation(&p->lheader, &lrecord_symbol);
2506 p->name = XSTRING(name);
2508 p->value = Qunbound;
2509 p->function = Qunbound;
2515 /************************************************************************/
2516 /* Extent allocation */
2517 /************************************************************************/
2519 DECLARE_FIXED_TYPE_ALLOC(extent, struct extent);
2520 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_extent 1000
2522 struct extent *allocate_extent(void)
2526 ALLOCATE_FIXED_TYPE(extent, struct extent, e);
2527 set_lheader_implementation(&e->lheader, &lrecord_extent);
2528 extent_object(e) = Qnil;
2529 set_extent_start(e, -1);
2530 set_extent_end(e, -1);
2535 extent_face(e) = Qnil;
2536 e->flags.end_open = 1; /* default is for endpoints to behave like markers */
2537 e->flags.detachable = 1;
2542 /************************************************************************/
2543 /* Event allocation */
2544 /************************************************************************/
2546 DECLARE_FIXED_TYPE_ALLOC(event, Lisp_Event);
2547 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_event 1000
2549 Lisp_Object allocate_event(void)
2554 ALLOCATE_FIXED_TYPE(event, Lisp_Event, e);
2555 set_lheader_implementation(&e->lheader, &lrecord_event);
2561 /************************************************************************/
2562 /* Marker allocation */
2563 /************************************************************************/
2565 DECLARE_FIXED_TYPE_ALLOC(marker, Lisp_Marker);
2566 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_marker 1000
2568 DEFUN("make-marker", Fmake_marker, 0, 0, 0, /*
2569 Return a new marker which does not point at any place.
2576 ALLOCATE_FIXED_TYPE(marker, Lisp_Marker, p);
2577 set_lheader_implementation(&p->lheader, &lrecord_marker);
2582 p->insertion_type = 0;
2587 Lisp_Object noseeum_make_marker(void)
2592 NOSEEUM_ALLOCATE_FIXED_TYPE(marker, Lisp_Marker, p);
2593 set_lheader_implementation(&p->lheader, &lrecord_marker);
2598 p->insertion_type = 0;
2603 /************************************************************************/
2604 /* String allocation */
2605 /************************************************************************/
2607 /* The data for "short" strings generally resides inside of structs of type
2608 string_chars_block. The Lisp_String structure is allocated just like any
2609 other Lisp object (except for vectors), and these are freelisted when
2610 they get garbage collected. The data for short strings get compacted,
2611 but the data for large strings do not.
2613 Previously Lisp_String structures were relocated, but this caused a lot
2614 of bus-errors because the C code didn't include enough GCPRO's for
2615 strings (since EVERY REFERENCE to a short string needed to be GCPRO'd so
2616 that the reference would get relocated).
2618 This new method makes things somewhat bigger, but it is MUCH safer. */
2620 DECLARE_FIXED_TYPE_ALLOC(string, Lisp_String);
2621 /* strings are used and freed quite often */
2622 /* #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_string 10000 */
2623 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_string 1000
2625 #if defined HAVE_BDWGC && defined EF_USE_BDWGC && 0
2627 string_register_finaliser(Lisp_String *s)
2629 GC_finalization_proc *foo = NULL;
2631 auto void string_finaliser();
2633 auto void string_finaliser(void *obj, void *SXE_UNUSED(data))
2635 if (!(((Lisp_String*)obj)->lheader.c_readonly)) {
2636 yfree(((Lisp_String*)obj)->data);
2639 memset(obj, 0, sizeof(Lisp_String));
2643 SXE_DEBUG_GC("string-fina %p\n", s);
2644 GC_REGISTER_FINALIZER(s, string_finaliser, NULL, foo, bar);
2649 string_register_finaliser(Lisp_String *SXE_UNUSED(b))
2653 #endif /* HAVE_BDWGC */
2655 static Lisp_Object mark_string(Lisp_Object obj)
2657 Lisp_String *ptr = XSTRING(obj);
2659 if (CONSP(ptr->plist) && EXTENT_INFOP(XCAR(ptr->plist)))
2660 flush_cached_extent_info(XCAR(ptr->plist));
2661 #ifdef EF_USE_COMPRE
2662 mark_object(ptr->compre);
2667 static int string_equal(Lisp_Object obj1, Lisp_Object obj2, int depth)
2670 return (((len = XSTRING_LENGTH(obj1)) == XSTRING_LENGTH(obj2)) &&
2671 !memcmp(XSTRING_DATA(obj1), XSTRING_DATA(obj2), len));
2674 static const struct lrecord_description string_description[] = {
2675 {XD_BYTECOUNT, offsetof(Lisp_String, size)},
2676 {XD_OPAQUE_DATA_PTR, offsetof(Lisp_String, data), XD_INDIRECT(0, 1)},
2677 #ifdef EF_USE_COMPRE
2678 {XD_LISP_OBJECT, offsetof(Lisp_String, compre)},
2680 {XD_LISP_OBJECT, offsetof(Lisp_String, plist)},
2684 /* the seq implementation */
2686 str_length(const seq_t str)
2688 return string_char_length((const Lisp_String*)str);
2692 str_iter_init(seq_t str, seq_iter_t si)
2695 si->data = (void*)0;
2700 str_iter_next(seq_iter_t si, void **elt)
2702 if (si->seq != NULL &&
2703 (long int)si->data < string_char_length((Lisp_String*)si->seq)) {
2704 *elt = (void*)make_char(
2705 string_char((Lisp_String*)si->seq, (long int)si->data));
2706 si->data = (void*)((long int)si->data + 1);
2714 str_iter_fini(seq_iter_t si)
2716 si->data = si->seq = NULL;
2721 str_iter_reset(seq_iter_t si)
2723 si->data = (void*)0;
2728 str_explode(void *restrict tgt[], size_t ntgt, const seq_t s)
2730 size_t len = string_char_length((const Lisp_String*)s);
2731 volatile size_t i = 0;
2733 while (i < len && i < ntgt) {
2734 tgt[i] = (void*)make_char(string_char((Lisp_String*)s, i));
2740 static struct seq_impl_s __sstr = {
2741 .length_f = str_length,
2742 .iter_init_f = str_iter_init,
2743 .iter_next_f = str_iter_next,
2744 .iter_fini_f = str_iter_fini,
2745 .iter_reset_f = str_iter_reset,
2746 .explode_f = str_explode,
2750 /* We store the string's extent info as the first element of the string's
2751 property list; and the string's MODIFF as the first or second element
2752 of the string's property list (depending on whether the extent info
2753 is present), but only if the string has been modified. This is ugly
2754 but it reduces the memory allocated for the string in the vast
2755 majority of cases, where the string is never modified and has no
2758 #### This means you can't use an int as a key in a string's plist. */
2760 static Lisp_Object *string_plist_ptr(Lisp_Object string)
2762 Lisp_Object *ptr = &XSTRING(string)->plist;
2764 if (CONSP(*ptr) && EXTENT_INFOP(XCAR(*ptr)))
2766 if (CONSP(*ptr) && INTP(XCAR(*ptr)))
2771 static Lisp_Object string_getprop(Lisp_Object string, Lisp_Object property)
2773 return external_plist_get(string_plist_ptr(string), property, 0,
2778 string_putprop(Lisp_Object string, Lisp_Object property, Lisp_Object value)
2780 external_plist_put(string_plist_ptr(string), property, value, 0,
2785 static int string_remprop(Lisp_Object string, Lisp_Object property)
2787 return external_remprop(string_plist_ptr(string), property, 0,
2791 static Lisp_Object string_plist(Lisp_Object string)
2793 return *string_plist_ptr(string);
2796 /* No `finalize', or `hash' methods.
2797 internal_hash() already knows how to hash strings and finalization
2798 is done with the ADDITIONAL_FREE_string macro, which is the
2799 standard way to do finalization when using
2800 SWEEP_FIXED_TYPE_BLOCK(). */
2801 DEFINE_BASIC_LRECORD_IMPLEMENTATION_WITH_PROPS("string", string,
2802 mark_string, print_string,
2808 string_plist, Lisp_String);
2810 #if !defined HAVE_BDWGC || !defined EF_USE_BDWGC
2811 /* String blocks contain this many useful bytes. */
2812 #define STRING_CHARS_BLOCK_SIZE \
2813 ((Bytecount) (8192 - MALLOC_OVERHEAD - \
2814 ((2 * sizeof (struct string_chars_block *)) \
2815 + sizeof (EMACS_INT))))
2816 /* Block header for small strings. */
2817 struct string_chars_block {
2819 struct string_chars_block *next;
2820 struct string_chars_block *prev;
2821 /* Contents of string_chars_block->string_chars are interleaved
2822 string_chars structures (see below) and the actual string data */
2823 unsigned char string_chars[STRING_CHARS_BLOCK_SIZE];
2826 static struct string_chars_block *first_string_chars_block;
2827 static struct string_chars_block *current_string_chars_block;
2829 /* If SIZE is the length of a string, this returns how many bytes
2830 * the string occupies in string_chars_block->string_chars
2831 * (including alignment padding).
2833 #define STRING_FULLSIZE(size) \
2834 ALIGN_SIZE(((size) + 1 + sizeof(Lisp_String*)), ALIGNOF(Lisp_String*))
2836 #define BIG_STRING_FULLSIZE_P(fullsize) ((fullsize) >= STRING_CHARS_BLOCK_SIZE)
2837 #define BIG_STRING_SIZE_P(size) (BIG_STRING_FULLSIZE_P (STRING_FULLSIZE(size)))
2839 #define STRING_CHARS_FREE_P(ptr) ((ptr)->string == NULL)
2840 #define MARK_STRING_CHARS_AS_FREE(ptr) ((void) ((ptr)->string = NULL))
2842 struct string_chars {
2843 Lisp_String *string;
2844 unsigned char chars[1];
2847 struct unused_string_chars {
2848 Lisp_String *string;
2852 static void init_string_chars_alloc(void)
2854 first_string_chars_block = ynew(struct string_chars_block);
2855 first_string_chars_block->prev = 0;
2856 first_string_chars_block->next = 0;
2857 first_string_chars_block->pos = 0;
2858 current_string_chars_block = first_string_chars_block;
2861 static struct string_chars*
2862 allocate_string_chars_struct(Lisp_String *string_it_goes_with,
2865 struct string_chars *s_chars;
2867 if (fullsize <= (countof(current_string_chars_block->string_chars)
2868 - current_string_chars_block->pos)) {
2869 /* This string can fit in the current string chars block */
2870 s_chars = (struct string_chars *)
2871 (current_string_chars_block->string_chars
2872 + current_string_chars_block->pos);
2873 current_string_chars_block->pos += fullsize;
2875 /* Make a new current string chars block */
2876 struct string_chars_block *new_scb =
2877 ynew(struct string_chars_block);
2879 current_string_chars_block->next = new_scb;
2880 new_scb->prev = current_string_chars_block;
2882 current_string_chars_block = new_scb;
2883 new_scb->pos = fullsize;
2884 s_chars = (struct string_chars *)
2885 current_string_chars_block->string_chars;
2888 s_chars->string = string_it_goes_with;
2890 INCREMENT_CONS_COUNTER(fullsize, "string chars");
2896 Lisp_Object make_uninit_string(Bytecount length)
2898 Lisp_String *s = NULL;
2899 #if !defined HAVE_BDWGC || !defined EF_USE_BDWGC
2900 EMACS_INT fullsize = STRING_FULLSIZE(length);
2904 #if !defined HAVE_BDWGC || !defined EF_USE_BDWGC
2905 assert(length >= 0 && fullsize > 0);
2908 /* Allocate the string header */
2909 ALLOCATE_FIXED_TYPE(string, Lisp_String, s);
2910 set_lheader_implementation(&s->lheader, &lrecord_string);
2911 string_register_finaliser(s);
2914 Bufbyte *foo = NULL;
2915 #if defined HAVE_BDWGC && defined EF_USE_BDWGC
2916 foo = xnew_atomic_array(Bufbyte, length+1);
2917 assert(foo != NULL);
2919 if (BIG_STRING_FULLSIZE_P(fullsize)) {
2920 foo = xnew_atomic_array(Bufbyte, length + 1);
2921 assert(foo != NULL);
2923 foo = allocate_string_chars_struct(s, fullsize)->chars;
2924 assert(foo != NULL);
2927 set_string_data(s, foo);
2929 set_string_length(s, length);
2931 #ifdef EF_USE_COMPRE
2934 /* propagate the cat system, go with the standard impl of a seq first */
2935 s->lheader.morphisms = 0;
2937 set_string_byte(s, length, 0);
2943 #ifdef VERIFY_STRING_CHARS_INTEGRITY
2944 static void verify_string_chars_integrity(void);
2947 /* Resize the string S so that DELTA bytes can be inserted starting
2948 at POS. If DELTA < 0, it means deletion starting at POS. If
2949 POS < 0, resize the string but don't copy any characters. Use
2950 this if you're planning on completely overwriting the string.
2953 #if defined HAVE_BDWGC && defined EF_USE_BDWGC
2954 void resize_string(Lisp_String * s, Bytecount pos, Bytecount delta)
2959 /* trivial cases first */
2961 /* simplest case: no size change. */
2965 if (pos >= 0 && delta < 0) {
2966 /* If DELTA < 0, the functions below will delete the characters
2967 before POS. We want to delete characters *after* POS,
2968 however, so convert this to the appropriate form. */
2972 /* Both strings are big. We can just realloc().
2973 But careful! If the string is shrinking, we have to
2974 memmove() _before_ realloc(), and if growing, we have to
2975 memmove() _after_ realloc() - otherwise the access is
2976 illegal, and we might crash. */
2977 len = string_length(s) + 1 - pos;
2979 if (delta < 0 && pos >= 0) {
2980 memmove(string_data(s) + pos + delta,
2981 string_data(s) + pos, len);
2984 /* do the reallocation */
2985 foo = xrealloc(string_data(s), string_length(s) + delta + 1);
2986 set_string_data(s, foo);
2988 if (delta > 0 && pos >= 0) {
2989 memmove(string_data(s) + pos + delta,
2990 string_data(s) + pos, len);
2993 set_string_length(s, string_length(s) + delta);
2994 /* If pos < 0, the string won't be zero-terminated.
2995 Terminate now just to make sure. */
2996 string_data(s)[string_length(s)] = '\0';
3001 XSETSTRING(string, s);
3002 /* We also have to adjust all of the extent indices after the
3003 place we did the change. We say "pos - 1" because
3004 adjust_extents() is exclusive of the starting position
3006 adjust_extents(string, pos - 1, string_length(s), delta);
3010 #else /* !HAVE_BDWGC */
3011 void resize_string(Lisp_String * s, Bytecount pos, Bytecount delta)
3013 Bytecount oldfullsize, newfullsize;
3014 #ifdef VERIFY_STRING_CHARS_INTEGRITY
3015 verify_string_chars_integrity();
3018 #ifdef ERROR_CHECK_BUFPOS
3020 assert(pos <= string_length(s));
3022 assert(pos + (-delta) <= string_length(s));
3025 assert((-delta) <= string_length(s));
3027 #endif /* ERROR_CHECK_BUFPOS */
3030 /* simplest case: no size change. */
3033 if (pos >= 0 && delta < 0)
3034 /* If DELTA < 0, the functions below will delete the characters
3035 before POS. We want to delete characters *after* POS, however,
3036 so convert this to the appropriate form. */
3039 oldfullsize = STRING_FULLSIZE(string_length(s));
3040 newfullsize = STRING_FULLSIZE(string_length(s) + delta);
3042 if (BIG_STRING_FULLSIZE_P(oldfullsize)) {
3043 if (BIG_STRING_FULLSIZE_P(newfullsize)) {
3044 /* Both strings are big. We can just realloc().
3045 But careful! If the string is shrinking, we have to
3046 memmove() _before_ realloc(), and if growing, we have to
3047 memmove() _after_ realloc() - otherwise the access is
3048 illegal, and we might crash. */
3049 Bytecount len = string_length(s) + 1 - pos;
3052 if (delta < 0 && pos >= 0)
3053 memmove(string_data(s) + pos + delta,
3054 string_data(s) + pos, len);
3056 foo = xrealloc(string_data(s),
3057 string_length(s) + delta + 1);
3058 set_string_data(s, foo);
3059 if (delta > 0 && pos >= 0) {
3060 memmove(string_data(s) + pos + delta,
3061 string_data(s) + pos, len);
3064 /* String has been demoted from BIG_STRING. */
3067 allocate_string_chars_struct(s, newfullsize)
3069 Bufbyte *old_data = string_data(s);
3072 memcpy(new_data, old_data, pos);
3073 memcpy(new_data + pos + delta, old_data + pos,
3074 string_length(s) + 1 - pos);
3076 set_string_data(s, new_data);
3079 } else { /* old string is small */
3081 if (oldfullsize == newfullsize) {
3082 /* special case; size change but the necessary
3083 allocation size won't change (up or down; code
3084 somewhere depends on there not being any unused
3085 allocation space, modulo any alignment
3088 Bufbyte *addroff = pos + string_data(s);
3090 memmove(addroff + delta, addroff,
3091 /* +1 due to zero-termination. */
3092 string_length(s) + 1 - pos);
3095 Bufbyte *old_data = string_data(s);
3096 Bufbyte *new_data = BIG_STRING_FULLSIZE_P(newfullsize)
3097 ? xnew_atomic_array(
3098 Bufbyte, string_length(s) + delta + 1)
3099 : allocate_string_chars_struct(
3100 s, newfullsize)->chars;
3103 memcpy(new_data, old_data, pos);
3104 memcpy(new_data + pos + delta, old_data + pos,
3105 string_length(s) + 1 - pos);
3107 set_string_data(s, new_data);
3110 /* We need to mark this chunk of the
3111 string_chars_block as unused so that
3112 compact_string_chars() doesn't freak. */
3113 struct string_chars *old_s_chars =
3114 (struct string_chars *)
3116 offsetof(struct string_chars, chars));
3117 /* Sanity check to make sure we aren't hosed by
3118 strange alignment/padding. */
3119 assert(old_s_chars->string == s);
3120 MARK_STRING_CHARS_AS_FREE(old_s_chars);
3121 ((struct unused_string_chars *)old_s_chars)->
3122 fullsize = oldfullsize;
3127 set_string_length(s, string_length(s) + delta);
3128 /* If pos < 0, the string won't be zero-terminated.
3129 Terminate now just to make sure. */
3130 string_data(s)[string_length(s)] = '\0';
3135 XSETSTRING(string, s);
3136 /* We also have to adjust all of the extent indices after the
3137 place we did the change. We say "pos - 1" because
3138 adjust_extents() is exclusive of the starting position
3140 adjust_extents(string, pos - 1, string_length(s), delta);
3142 #ifdef VERIFY_STRING_CHARS_INTEGRITY
3143 verify_string_chars_integrity();
3149 void set_string_char(Lisp_String * s, Charcount i, Emchar c)
3151 Bufbyte newstr[MAX_EMCHAR_LEN];
3152 Bytecount bytoff = charcount_to_bytecount(string_data(s), i);
3153 Bytecount oldlen = charcount_to_bytecount(string_data(s) + bytoff, 1);
3154 Bytecount newlen = set_charptr_emchar(newstr, c);
3156 if (oldlen != newlen) {
3157 resize_string(s, bytoff, newlen - oldlen);
3159 /* Remember, string_data (s) might have changed so we can't cache it. */
3160 memcpy(string_data(s) + bytoff, newstr, newlen);
3165 DEFUN("make-string", Fmake_string, 2, 2, 0, /*
3166 Return a new string consisting of LENGTH copies of CHARACTER.
3167 LENGTH must be a non-negative integer.
3169 (length, character))
3171 CHECK_NATNUM(length);
3172 CHECK_CHAR_COERCE_INT(character);
3174 Bufbyte init_str[MAX_EMCHAR_LEN];
3175 int len = set_charptr_emchar(init_str, XCHAR(character));
3176 Lisp_Object val = make_uninit_string(len * XINT(length));
3179 /* Optimize the single-byte case */
3180 memset(XSTRING_DATA(val), XCHAR(character),
3181 XSTRING_LENGTH(val));
3184 Bufbyte *ptr = XSTRING_DATA(val);
3186 for (i = XINT(length); i; i--) {
3187 Bufbyte *init_ptr = init_str;
3190 *ptr++ = *init_ptr++;
3192 *ptr++ = *init_ptr++;
3194 *ptr++ = *init_ptr++;
3196 *ptr++ = *init_ptr++;
3206 DEFUN("string", Fstring, 0, MANY, 0, /*
3207 Concatenate all the argument characters and make the result a string.
3209 (int nargs, Lisp_Object * args))
3211 Bufbyte *storage, *p;
3213 int speccount = specpdl_depth();
3214 int len = nargs * MAX_EMCHAR_LEN;
3216 XMALLOC_OR_ALLOCA(storage, len, Bufbyte);
3218 for (; nargs; nargs--, args++) {
3219 Lisp_Object lisp_char = *args;
3220 CHECK_CHAR_COERCE_INT(lisp_char);
3221 p += set_charptr_emchar(p, XCHAR(lisp_char));
3223 result = make_string(storage, p - storage);
3224 XMALLOC_UNBIND(storage, len, speccount );
3229 /* Take some raw memory, which MUST already be in internal format,
3230 and package it up into a Lisp string. */
3232 make_string(const Bufbyte *contents, Bytecount length)
3236 /* Make sure we find out about bad make_string's when they happen */
3237 #if defined (ERROR_CHECK_BUFPOS) && defined (MULE)
3238 /* Just for the assertions */
3239 bytecount_to_charcount(contents, length);
3242 val = make_uninit_string(length);
3243 memcpy(XSTRING_DATA(val), contents, length);
3247 /* Take some raw memory, encoded in some external data format,
3248 and convert it into a Lisp string. */
3250 make_ext_string(const Extbyte *contents, EMACS_INT length,
3251 Lisp_Object coding_system)
3254 TO_INTERNAL_FORMAT(DATA, (contents, length),
3255 LISP_STRING, string, coding_system);
3259 /* why arent the next 3 inlines? */
3260 Lisp_Object build_string(const char *str)
3262 /* Some strlen's crash and burn if passed null. */
3264 return make_string((const Bufbyte*)str, strlen(str));
3270 Lisp_Object build_ext_string(const char *str, Lisp_Object coding_system)
3272 /* Some strlen's crash and burn if passed null. */
3273 return make_ext_string((const Extbyte*)str, (str ? strlen(str) : 0), coding_system);
3276 Lisp_Object build_translated_string(const char *str)
3278 return build_string(GETTEXT(str));
3281 Lisp_Object make_string_nocopy(Bufbyte *contents, Bytecount length)
3286 /* Make sure we find out about bad make_string_nocopy's when they
3288 #if defined (ERROR_CHECK_BUFPOS) && defined (MULE)
3289 /* Just for the assertions */
3290 bytecount_to_charcount(contents, length);
3293 /* Allocate the string header */
3294 ALLOCATE_FIXED_TYPE(string, Lisp_String, s);
3295 set_lheader_implementation(&s->lheader, &lrecord_string);
3296 SET_C_READONLY_RECORD_HEADER(&s->lheader);
3297 string_register_finaliser(s);
3300 #ifdef EF_USE_COMPRE
3303 set_string_data(s, (Bufbyte*)contents);
3304 set_string_length(s, length);
3310 /************************************************************************/
3311 /* lcrecord lists */
3312 /************************************************************************/
3314 /* Lcrecord lists are used to manage the allocation of particular
3315 sorts of lcrecords, to avoid calling alloc_lcrecord() (and thus
3316 malloc() and garbage-collection junk) as much as possible.
3317 It is similar to the Blocktype class.
3321 1) Create an lcrecord-list object using make_lcrecord_list().
3322 This is often done at initialization. Remember to staticpro_nodump
3323 this object! The arguments to make_lcrecord_list() are the
3324 same as would be passed to alloc_lcrecord().
3325 2) Instead of calling alloc_lcrecord(), call allocate_managed_lcrecord()
3326 and pass the lcrecord-list earlier created.
3327 3) When done with the lcrecord, call free_managed_lcrecord().
3328 The standard freeing caveats apply: ** make sure there are no
3329 pointers to the object anywhere! **
3330 4) Calling free_managed_lcrecord() is just like kissing the
3331 lcrecord goodbye as if it were garbage-collected. This means:
3332 -- the contents of the freed lcrecord are undefined, and the
3333 contents of something produced by allocate_managed_lcrecord()
3334 are undefined, just like for alloc_lcrecord().
3335 -- the mark method for the lcrecord's type will *NEVER* be called
3337 -- the finalize method for the lcrecord's type will be called
3338 at the time that free_managed_lcrecord() is called.
3340 lcrecord lists do not work in bdwgc mode. -hrop
3344 #if defined HAVE_BDWGC && defined EF_USE_BDWGC
3346 mark_lcrecord_list(Lisp_Object obj)
3351 /* just imitate the lcrecord spectactular */
3353 make_lcrecord_list(size_t size,
3354 const struct lrecord_implementation *implementation)
3356 struct lcrecord_list *p =
3357 alloc_lcrecord_type(struct lcrecord_list,
3358 &lrecord_lcrecord_list);
3361 p->implementation = implementation;
3364 XSETLCRECORD_LIST(val, p);
3369 allocate_managed_lcrecord(Lisp_Object lcrecord_list)
3371 struct lcrecord_list *list = XLCRECORD_LIST(lcrecord_list);
3372 void *tmp = alloc_lcrecord(list->size, list->implementation);
3380 free_managed_lcrecord(Lisp_Object SXE_UNUSED(lcrecord_list), Lisp_Object lcrecord)
3382 struct free_lcrecord_header *free_header =
3383 (struct free_lcrecord_header*)XPNTR(lcrecord);
3384 struct lrecord_header *lheader = &free_header->lcheader.lheader;
3385 const struct lrecord_implementation *imp =
3386 LHEADER_IMPLEMENTATION(lheader);
3388 if (imp->finalizer) {
3389 imp->finalizer(lheader, 0);
3397 mark_lcrecord_list(Lisp_Object obj)
3399 struct lcrecord_list *list = XLCRECORD_LIST(obj);
3400 Lisp_Object chain = list->free;
3402 while (!NILP(chain)) {
3403 struct lrecord_header *lheader = XRECORD_LHEADER(chain);
3404 struct free_lcrecord_header *free_header =
3405 (struct free_lcrecord_header *)lheader;
3408 /* There should be no other pointers to the free list. */
3409 !MARKED_RECORD_HEADER_P(lheader)
3411 /* Only lcrecords should be here. */
3412 !LHEADER_IMPLEMENTATION(lheader)->
3414 /* Only free lcrecords should be here. */
3415 free_header->lcheader.free &&
3416 /* The type of the lcrecord must be right. */
3417 LHEADER_IMPLEMENTATION(lheader) ==
3418 list->implementation &&
3419 /* So must the size. */
3420 (LHEADER_IMPLEMENTATION(lheader)->
3422 || LHEADER_IMPLEMENTATION(lheader)->
3423 static_size == list->size)
3426 MARK_RECORD_HEADER(lheader);
3427 chain = free_header->chain;
3434 make_lcrecord_list(size_t size,
3435 const struct lrecord_implementation *implementation)
3437 struct lcrecord_list *p =
3438 alloc_lcrecord_type(struct lcrecord_list,
3439 &lrecord_lcrecord_list);
3442 p->implementation = implementation;
3445 XSETLCRECORD_LIST(val, p);
3450 allocate_managed_lcrecord(Lisp_Object lcrecord_list)
3452 struct lcrecord_list *list = XLCRECORD_LIST(lcrecord_list);
3453 if (!NILP(list->free)) {
3454 Lisp_Object val = list->free;
3455 struct free_lcrecord_header *free_header =
3456 (struct free_lcrecord_header *)XPNTR(val);
3458 #ifdef ERROR_CHECK_GC
3459 struct lrecord_header *lheader = &free_header->lcheader.lheader;
3461 /* There should be no other pointers to the free list. */
3462 assert(!MARKED_RECORD_HEADER_P(lheader));
3463 /* Only lcrecords should be here. */
3464 assert(!LHEADER_IMPLEMENTATION(lheader)->basic_p);
3465 /* Only free lcrecords should be here. */
3466 assert(free_header->lcheader.free);
3467 /* The type of the lcrecord must be right. */
3468 assert(LHEADER_IMPLEMENTATION(lheader) == list->implementation);
3469 /* So must the size. */
3470 assert(LHEADER_IMPLEMENTATION(lheader)->static_size == 0 ||
3471 LHEADER_IMPLEMENTATION(lheader)->static_size ==
3473 #endif /* ERROR_CHECK_GC */
3475 list->free = free_header->chain;
3476 free_header->lcheader.free = 0;
3479 void *tmp = alloc_lcrecord(list->size, list->implementation);
3488 free_managed_lcrecord(Lisp_Object lcrecord_list, Lisp_Object lcrecord)
3490 struct lcrecord_list *list = XLCRECORD_LIST(lcrecord_list);
3491 struct free_lcrecord_header *free_header =
3492 (struct free_lcrecord_header*)XPNTR(lcrecord);
3493 struct lrecord_header *lheader = &free_header->lcheader.lheader;
3494 const struct lrecord_implementation *implementation
3495 = LHEADER_IMPLEMENTATION(lheader);
3497 /* Make sure the size is correct. This will catch, for example,
3498 putting a window configuration on the wrong free list. */
3499 gc_checking_assert((implementation->size_in_bytes_method ?
3500 implementation->size_in_bytes_method(lheader) :
3501 implementation->static_size)
3504 if (implementation->finalizer) {
3505 implementation->finalizer(lheader, 0);
3507 free_header->chain = list->free;
3508 free_header->lcheader.free = 1;
3509 list->free = lcrecord;
3513 DEFINE_LRECORD_IMPLEMENTATION("lcrecord-list", lcrecord_list,
3514 mark_lcrecord_list, internal_object_printer,
3515 0, 0, 0, 0, struct lcrecord_list);
3518 DEFUN("purecopy", Fpurecopy, 1, 1, 0, /*
3519 Kept for compatibility, returns its argument.
3521 Make a copy of OBJECT in pure storage.
3522 Recursively copies contents of vectors and cons cells.
3523 Does not copy symbols.
3530 /************************************************************************/
3531 /* Garbage Collection */
3532 /************************************************************************/
3534 /* All the built-in lisp object types are enumerated in `enum lrecord_type'.
3535 Additional ones may be defined by a module (none yet). We leave some
3536 room in `lrecord_implementations_table' for such new lisp object types. */
3537 const struct lrecord_implementation
3538 *lrecord_implementations_table[(unsigned int)lrecord_type_last_built_in_type
3539 + MODULE_DEFINABLE_TYPE_COUNT];
3540 unsigned int lrecord_type_count = (unsigned int)lrecord_type_last_built_in_type;
3541 /* Object marker functions are in the lrecord_implementation structure.
3542 But copying them to a parallel array is much more cache-friendly.
3543 This hack speeds up (garbage-collect) by about 5%. */
3544 Lisp_Object(*lrecord_markers[countof(lrecord_implementations_table)])
3547 #ifndef EF_USE_ASYNEQ
3548 struct gcpro *gcprolist;
3551 /* We want the staticpros relocated, but not the pointers found therein.
3552 Hence we use a trivial description, as for pointerless objects. */
3553 static const struct lrecord_description staticpro_description_1[] = {
3557 static const struct struct_description staticpro_description = {
3558 sizeof(Lisp_Object *),
3559 staticpro_description_1
3562 static const struct lrecord_description staticpros_description_1[] = {
3563 XD_DYNARR_DESC(Lisp_Object_ptr_dynarr, &staticpro_description),
3567 static const struct struct_description staticpros_description = {
3568 sizeof(Lisp_Object_ptr_dynarr),
3569 staticpros_description_1
3572 Lisp_Object_ptr_dynarr *staticpros;
3574 /* Mark the Lisp_Object at non-heap VARADDRESS as a root object for
3575 garbage collection, and for dumping. */
3576 void staticpro(Lisp_Object * varaddress)
3579 Dynarr_add(staticpros, varaddress);
3580 dump_add_root_object(varaddress);
3584 #if !defined HAVE_BDWGC || !defined EF_USE_BDWGC
3585 Lisp_Object_ptr_dynarr *staticpros_nodump;
3587 /* Mark the Lisp_Object at non-heap VARADDRESS as a root object for
3588 garbage collection, but not for dumping. */
3589 void staticpro_nodump(Lisp_Object * varaddress)
3592 Dynarr_add(staticpros_nodump, varaddress);
3598 #ifdef ERROR_CHECK_GC
3599 #define GC_CHECK_LHEADER_INVARIANTS(lheader) \
3601 struct lrecord_header * GCLI_lh = (lheader); \
3602 assert (GCLI_lh != 0); \
3603 assert (GCLI_lh->type < lrecord_type_count); \
3604 assert (! C_READONLY_RECORD_HEADER_P (GCLI_lh) || \
3605 (MARKED_RECORD_HEADER_P (GCLI_lh) && \
3606 LISP_READONLY_RECORD_HEADER_P (GCLI_lh))); \
3609 #define GC_CHECK_LHEADER_INVARIANTS(lheader)
3612 /* Mark reference to a Lisp_Object. If the object referred to has not been
3613 seen yet, recursively mark all the references contained in it. */
3615 #if defined HAVE_BDWGC && defined EF_USE_BDWGC
3616 void mark_object(Lisp_Object SXE_UNUSED(obj))
3622 void mark_object(Lisp_Object obj)
3624 if (obj == Qnull_pointer) {
3629 /* Checks we used to perform */
3630 /* if (EQ (obj, Qnull_pointer)) return; */
3631 /* if (!POINTER_TYPE_P (XGCTYPE (obj))) return; */
3632 /* if (PURIFIED (XPNTR (obj))) return; */
3634 if (XTYPE(obj) == Lisp_Type_Record) {
3635 struct lrecord_header *lheader = XRECORD_LHEADER(obj);
3637 GC_CHECK_LHEADER_INVARIANTS(lheader);
3639 gc_checking_assert(LHEADER_IMPLEMENTATION(lheader)->basic_p ||
3640 !((struct lcrecord_header *)lheader)->free);
3642 /* All c_readonly objects have their mark bit set,
3643 so that we only need to check the mark bit here. */
3644 if (!MARKED_RECORD_HEADER_P(lheader)) {
3645 MARK_RECORD_HEADER(lheader);
3647 if (RECORD_MARKER(lheader)) {
3648 obj = RECORD_MARKER(lheader) (obj);
3657 /* mark all of the conses in a list and mark the final cdr; but
3658 DO NOT mark the cars.
3660 Use only for internal lists! There should never be other pointers
3661 to the cons cells, because if so, the cars will remain unmarked
3662 even when they maybe should be marked. */
3663 void mark_conses_in_list(Lisp_Object obj)
3667 for (rest = obj; CONSP(rest); rest = XCDR(rest)) {
3668 if (CONS_MARKED_P(XCONS(rest)))
3670 MARK_CONS(XCONS(rest));
3676 /* Find all structures not marked, and free them. */
3678 #if !defined HAVE_BDWGC || !defined EF_USE_BDWGC
3679 static int gc_count_num_bit_vector_used, gc_count_bit_vector_total_size;
3680 static int gc_count_bit_vector_storage;
3681 static int gc_count_num_short_string_in_use;
3682 static int gc_count_string_total_size;
3683 static int gc_count_short_string_total_size;
3686 /* static int gc_count_total_records_used, gc_count_records_total_size; */
3688 /* stats on lcrecords in use - kinda kludgy */
3690 #if !defined HAVE_BDWGC || !defined EF_USE_BDWGC
3692 int instances_in_use;
3694 int instances_freed;
3696 int instances_on_free_list;
3697 } lcrecord_stats[countof(lrecord_implementations_table)
3698 + MODULE_DEFINABLE_TYPE_COUNT];
3701 #if !defined HAVE_BDWGC || !defined EF_USE_BDWGC
3702 static void tick_lcrecord_stats(const struct lrecord_header *h, int free_p)
3704 unsigned int type_index = h->type;
3706 if (((const struct lcrecord_header *)h)->free) {
3707 gc_checking_assert(!free_p);
3708 lcrecord_stats[type_index].instances_on_free_list++;
3710 const struct lrecord_implementation *implementation =
3711 LHEADER_IMPLEMENTATION(h);
3713 size_t sz = (implementation->size_in_bytes_method ?
3714 implementation->size_in_bytes_method(h) :
3715 implementation->static_size);
3717 lcrecord_stats[type_index].instances_freed++;
3718 lcrecord_stats[type_index].bytes_freed += sz;
3720 lcrecord_stats[type_index].instances_in_use++;
3721 lcrecord_stats[type_index].bytes_in_use += sz;
3727 /* Free all unmarked records */
3728 #if !defined HAVE_BDWGC || !defined EF_USE_BDWGC
3730 sweep_lcrecords_1(struct lcrecord_header *volatile*prev, int *used)
3733 /* int total_size = 0; */
3735 xzero(lcrecord_stats); /* Reset all statistics to 0. */
3737 /* First go through and call all the finalize methods.
3738 Then go through and free the objects. There used to
3739 be only one loop here, with the call to the finalizer
3740 occurring directly before the xfree() below. That
3741 is marginally faster but much less safe -- if the
3742 finalize method for an object needs to reference any
3743 other objects contained within it (and many do),
3744 we could easily be screwed by having already freed that
3747 for (struct lcrecord_header *volatile header = *prev;
3748 header; header = header->next) {
3749 struct lrecord_header *h = &(header->lheader);
3751 GC_CHECK_LHEADER_INVARIANTS(h);
3753 if (!MARKED_RECORD_HEADER_P(h) && !header->free) {
3754 if (LHEADER_IMPLEMENTATION(h)->finalizer)
3755 LHEADER_IMPLEMENTATION(h)->finalizer(h, 0);
3759 for (struct lcrecord_header *volatile header = *prev; header;) {
3760 struct lrecord_header *volatile h = &(header->lheader);
3761 if (MARKED_RECORD_HEADER_P(h)) {
3762 if (!C_READONLY_RECORD_HEADER_P(h))
3763 UNMARK_RECORD_HEADER(h);
3765 /* total_size += n->implementation->size_in_bytes (h); */
3766 /* #### May modify header->next on a C_READONLY lcrecord */
3767 prev = &(header->next);
3769 tick_lcrecord_stats(h, 0);
3771 struct lcrecord_header *next = header->next;
3773 tick_lcrecord_stats(h, 1);
3774 /* used to call finalizer right here. */
3780 /* *total = total_size; */
3785 sweep_bit_vectors_1(Lisp_Object * prev, int *used, int *total, int *storage)
3787 Lisp_Object bit_vector;
3790 int total_storage = 0;
3792 /* BIT_VECTORP fails because the objects are marked, which changes
3793 their implementation */
3794 for (bit_vector = *prev; !EQ(bit_vector, Qzero);) {
3795 Lisp_Bit_Vector *v = XBIT_VECTOR(bit_vector);
3797 if (MARKED_RECORD_P(bit_vector)) {
3798 if (!C_READONLY_RECORD_HEADER_P(&(v->lheader)))
3799 UNMARK_RECORD_HEADER(&(v->lheader));
3803 FLEXIBLE_ARRAY_STRUCT_SIZEOF(Lisp_Bit_Vector,
3804 unsigned long, bits,
3805 BIT_VECTOR_LONG_STORAGE
3808 /* #### May modify next on a C_READONLY bitvector */
3809 prev = &(bit_vector_next(v));
3812 Lisp_Object next = bit_vector_next(v);
3819 *total = total_size;
3820 *storage = total_storage;
3824 /* And the Lord said: Thou shalt use the `c-backslash-region' command
3825 to make macros prettier. */
3827 #if defined HAVE_BDWGC && defined EF_USE_BDWGC
3828 #define SWEEP_FIXED_TYPE_BLOCK(typename, obj_type)
3830 #elif defined ERROR_CHECK_GC
3832 #define SWEEP_FIXED_TYPE_BLOCK(typename, obj_type) \
3834 struct typename##_block *SFTB_current; \
3836 int num_free = 0, num_used = 0; \
3838 for (SFTB_current = current_##typename##_block, \
3839 SFTB_limit = current_##typename##_block_index; \
3844 for (SFTB_iii = 0; \
3845 SFTB_iii < SFTB_limit; \
3847 obj_type *SFTB_victim = \
3848 &(SFTB_current->block[SFTB_iii]); \
3850 if (LRECORD_FREE_P (SFTB_victim)) { \
3852 } else if (C_READONLY_RECORD_HEADER_P \
3853 (&SFTB_victim->lheader)) { \
3855 } else if (!MARKED_RECORD_HEADER_P \
3856 (&SFTB_victim->lheader)) { \
3858 FREE_FIXED_TYPE(typename, obj_type, \
3862 UNMARK_##typename(SFTB_victim); \
3865 SFTB_current = SFTB_current->prev; \
3866 SFTB_limit = countof(current_##typename##_block \
3870 gc_count_num_##typename##_in_use = num_used; \
3871 gc_count_num_##typename##_freelist = num_free; \
3874 #else /* !ERROR_CHECK_GC, !BDWGC*/
3876 #define SWEEP_FIXED_TYPE_BLOCK(typename, obj_type) \
3878 struct typename##_block *SFTB_current; \
3879 struct typename##_block **SFTB_prev; \
3881 int num_free = 0, num_used = 0; \
3883 typename##_free_list = 0; \
3885 for (SFTB_prev = ¤t_##typename##_block, \
3886 SFTB_current = current_##typename##_block, \
3887 SFTB_limit = current_##typename##_block_index; \
3891 int SFTB_empty = 1; \
3892 Lisp_Free *SFTB_old_free_list = \
3893 typename##_free_list; \
3895 for (SFTB_iii = 0; SFTB_iii < SFTB_limit; \
3897 obj_type *SFTB_victim = \
3898 &(SFTB_current->block[SFTB_iii]); \
3900 if (LRECORD_FREE_P (SFTB_victim)) { \
3902 PUT_FIXED_TYPE_ON_FREE_LIST \
3903 (typename, obj_type, \
3905 } else if (C_READONLY_RECORD_HEADER_P \
3906 (&SFTB_victim->lheader)) { \
3909 } else if (! MARKED_RECORD_HEADER_P \
3910 (&SFTB_victim->lheader)) { \
3912 FREE_FIXED_TYPE(typename, obj_type, \
3917 UNMARK_##typename (SFTB_victim); \
3920 if (!SFTB_empty) { \
3921 SFTB_prev = &(SFTB_current->prev); \
3922 SFTB_current = SFTB_current->prev; \
3923 } else if (SFTB_current == current_##typename##_block \
3924 && !SFTB_current->prev) { \
3925 /* No real point in freeing sole \
3926 * allocation block */ \
3929 struct typename##_block *SFTB_victim_block = \
3931 if (SFTB_victim_block == \
3932 current_##typename##_block) { \
3933 current_##typename##_block_index \
3935 (current_##typename##_block \
3938 SFTB_current = SFTB_current->prev; \
3940 *SFTB_prev = SFTB_current; \
3941 xfree(SFTB_victim_block); \
3942 /* Restore free list to what it was \
3943 before victim was swept */ \
3944 typename##_free_list = \
3945 SFTB_old_free_list; \
3946 num_free -= SFTB_limit; \
3949 SFTB_limit = countof (current_##typename##_block \
3953 gc_count_num_##typename##_in_use = num_used; \
3954 gc_count_num_##typename##_freelist = num_free; \
3957 #endif /* !ERROR_CHECK_GC */
3959 #if !defined HAVE_BDWGC || !defined EF_USE_BDWGC
3960 static void sweep_conses(void)
3962 #define UNMARK_cons(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
3963 #define ADDITIONAL_FREE_cons(ptr)
3965 SWEEP_FIXED_TYPE_BLOCK(cons, Lisp_Cons);
3969 /* Explicitly free a cons cell. */
3970 void free_cons(Lisp_Cons * ptr)
3972 #ifdef ERROR_CHECK_GC
3973 /* If the CAR is not an int, then it will be a pointer, which will
3974 always be four-byte aligned. If this cons cell has already been
3975 placed on the free list, however, its car will probably contain
3976 a chain pointer to the next cons on the list, which has cleverly
3977 had all its 0's and 1's inverted. This allows for a quick
3978 check to make sure we're not freeing something already freed. */
3979 if (POINTER_TYPE_P(XTYPE(ptr->car)))
3980 ASSERT_VALID_POINTER(XPNTR(ptr->car));
3981 #endif /* ERROR_CHECK_GC */
3983 #ifndef ALLOC_NO_POOLS
3984 FREE_FIXED_TYPE_WHEN_NOT_IN_GC(cons, Lisp_Cons, ptr);
3985 #endif /* ALLOC_NO_POOLS */
3988 /* explicitly free a list. You **must make sure** that you have
3989 created all the cons cells that make up this list and that there
3990 are no pointers to any of these cons cells anywhere else. If there
3991 are, you will lose. */
3993 void free_list(Lisp_Object list)
3995 Lisp_Object rest, next;
3997 for (rest = list; !NILP(rest); rest = next) {
3999 free_cons(XCONS(rest));
4003 /* explicitly free an alist. You **must make sure** that you have
4004 created all the cons cells that make up this alist and that there
4005 are no pointers to any of these cons cells anywhere else. If there
4006 are, you will lose. */
4008 void free_alist(Lisp_Object alist)
4010 Lisp_Object rest, next;
4012 for (rest = alist; !NILP(rest); rest = next) {
4014 free_cons(XCONS(XCAR(rest)));
4015 free_cons(XCONS(rest));
4019 #if !defined HAVE_BDWGC || !defined EF_USE_BDWGC
4020 static void sweep_compiled_functions(void)
4022 #define UNMARK_compiled_function(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
4023 #define ADDITIONAL_FREE_compiled_function(ptr)
4025 SWEEP_FIXED_TYPE_BLOCK(compiled_function, Lisp_Compiled_Function);
4029 static void sweep_floats(void)
4031 #define UNMARK_float(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
4032 #define ADDITIONAL_FREE_float(ptr)
4034 SWEEP_FIXED_TYPE_BLOCK(float, Lisp_Float);
4036 #endif /* HAVE_FPFLOAT */
4038 #if defined HAVE_MPZ && (defined WITH_GMP || defined WITH_MP)
4042 #define UNMARK_bigz(ptr) UNMARK_RECORD_HEADER(&((ptr)->lheader))
4043 #define ADDITIONAL_FREE_bigz(ptr) bigz_fini(ptr->data)
4045 SWEEP_FIXED_TYPE_BLOCK(bigz, Lisp_Bigz);
4047 #endif /* HAVE_MPZ */
4049 #if defined HAVE_MPQ && defined WITH_GMP
4053 #define UNMARK_bigq(ptr) UNMARK_RECORD_HEADER(&((ptr)->lheader))
4054 #define ADDITIONAL_FREE_bigq(ptr) bigq_fini(ptr->data)
4056 SWEEP_FIXED_TYPE_BLOCK(bigq, Lisp_Bigq);
4058 #endif /* HAVE_MPQ */
4060 #if defined HAVE_MPF && defined WITH_GMP
4064 #define UNMARK_bigf(ptr) UNMARK_RECORD_HEADER(&((ptr)->lheader))
4065 #define ADDITIONAL_FREE_bigf(ptr) bigf_fini(ptr->data)
4067 SWEEP_FIXED_TYPE_BLOCK(bigf, Lisp_Bigf);
4069 #endif /* HAVE_MPF */
4071 #if defined HAVE_MPFR && defined WITH_MPFR
4075 #define UNMARK_bigfr(ptr) UNMARK_RECORD_HEADER(&((ptr)->lheader))
4076 #define ADDITIONAL_FREE_bigfr(ptr) bigfr_fini(ptr->data)
4078 SWEEP_FIXED_TYPE_BLOCK(bigfr, Lisp_Bigfr);
4080 #endif /* HAVE_MPFR */
4082 #if defined HAVE_PSEUG && defined WITH_PSEUG
4086 #define UNMARK_bigg(ptr) UNMARK_RECORD_HEADER(&((ptr)->lheader))
4087 #define ADDITIONAL_FREE_bigg(ptr) bigg_fini(ptr->data)
4089 SWEEP_FIXED_TYPE_BLOCK(bigg, Lisp_Bigg);
4091 #endif /* HAVE_PSEUG */
4093 #if defined HAVE_MPC && defined WITH_MPC || \
4094 defined HAVE_PSEUC && defined WITH_PSEUC
4098 #define UNMARK_bigc(ptr) UNMARK_RECORD_HEADER(&((ptr)->lheader))
4099 #define ADDITIONAL_FREE_bigc(ptr) bigc_fini(ptr->data)
4101 SWEEP_FIXED_TYPE_BLOCK(bigc, Lisp_Bigc);
4103 #endif /* HAVE_MPC */
4105 #if defined HAVE_QUATERN && defined HAVE_MPZ && defined WITH_QUATERN
4107 sweep_quaterns (void)
4109 #define UNMARK_quatern(ptr) UNMARK_RECORD_HEADER(&((ptr)->lheader))
4110 #define ADDITIONAL_FREE_quatern(ptr) quatern_fini(ptr->data)
4112 SWEEP_FIXED_TYPE_BLOCK(quatern, Lisp_Quatern);
4114 #endif /* HAVE_QUATERN */
4117 sweep_dynacats(void)
4119 #define UNMARK_dynacat(ptr) UNMARK_RECORD_HEADER(&((ptr)->lheader))
4120 #define ADDITIONAL_FREE_dynacat(ptr) dynacat_fini(ptr);
4122 SWEEP_FIXED_TYPE_BLOCK(dynacat, struct dynacat_s);
4125 static void sweep_symbols(void)
4127 #define UNMARK_symbol(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
4128 #define ADDITIONAL_FREE_symbol(ptr)
4130 SWEEP_FIXED_TYPE_BLOCK(symbol, Lisp_Symbol);
4133 static void sweep_extents(void)
4135 #define UNMARK_extent(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
4136 #define ADDITIONAL_FREE_extent(ptr)
4138 SWEEP_FIXED_TYPE_BLOCK(extent, struct extent);
4141 static void sweep_events(void)
4143 #define UNMARK_event(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
4144 #define ADDITIONAL_FREE_event(ptr)
4146 SWEEP_FIXED_TYPE_BLOCK(event, Lisp_Event);
4149 static void sweep_markers(void)
4151 #define UNMARK_marker(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
4152 #define ADDITIONAL_FREE_marker(ptr) \
4153 do { Lisp_Object tem; \
4154 XSETMARKER (tem, ptr); \
4155 unchain_marker (tem); \
4158 SWEEP_FIXED_TYPE_BLOCK(marker, Lisp_Marker);
4162 /* Explicitly free a marker. */
4163 void free_marker(Lisp_Marker * ptr)
4165 /* Perhaps this will catch freeing an already-freed marker. */
4166 gc_checking_assert(ptr->lheader.type == lrecord_type_marker);
4168 #ifndef ALLOC_NO_POOLS
4169 FREE_FIXED_TYPE_WHEN_NOT_IN_GC(marker, Lisp_Marker, ptr);
4170 #endif /* ALLOC_NO_POOLS */
4173 #if defined (MULE) && defined (VERIFY_STRING_CHARS_INTEGRITY)
4175 static void verify_string_chars_integrity(void)
4177 struct string_chars_block *sb;
4179 /* Scan each existing string block sequentially, string by string. */
4180 for (sb = first_string_chars_block; sb; sb = sb->next) {
4182 /* POS is the index of the next string in the block. */
4183 while (pos < sb->pos) {
4184 struct string_chars *s_chars =
4185 (struct string_chars *)&(sb->string_chars[pos]);
4186 Lisp_String *string;
4190 /* If the string_chars struct is marked as free (i.e. the
4191 STRING pointer is NULL) then this is an unused chunk of
4192 string storage. (See below.) */
4194 if (STRING_CHARS_FREE_P(s_chars)) {
4196 ((struct unused_string_chars *)s_chars)->
4202 string = s_chars->string;
4203 /* Must be 32-bit aligned. */
4204 assert((((int)string) & 3) == 0);
4206 size = string_length(string);
4207 fullsize = STRING_FULLSIZE(size);
4209 assert(!BIG_STRING_FULLSIZE_P(fullsize));
4210 assert(string_data(string) == s_chars->chars);
4213 assert(pos == sb->pos);
4217 #endif /* MULE && ERROR_CHECK_GC */
4219 #if !defined HAVE_BDWGC || !defined EF_USE_BDWGC
4220 /* Compactify string chars, relocating the reference to each --
4221 free any empty string_chars_block we see. */
4222 static void compact_string_chars(void)
4224 struct string_chars_block *to_sb = first_string_chars_block;
4226 struct string_chars_block *from_sb;
4228 /* Scan each existing string block sequentially, string by string. */
4229 for (from_sb = first_string_chars_block; from_sb;
4230 from_sb = from_sb->next) {
4232 /* FROM_POS is the index of the next string in the block. */
4233 while (from_pos < from_sb->pos) {
4234 struct string_chars *from_s_chars =
4235 (struct string_chars *)&(from_sb->
4236 string_chars[from_pos]);
4237 struct string_chars *to_s_chars;
4238 Lisp_String *string;
4242 /* If the string_chars struct is marked as free (i.e. the
4243 STRING pointer is NULL) then this is an unused chunk of
4244 string storage. This happens under Mule when a string's
4245 size changes in such a way that its fullsize changes.
4246 (Strings can change size because a different-length
4247 character can be substituted for another character.)
4248 In this case, after the bogus string pointer is the
4249 "fullsize" of this entry, i.e. how many bytes to skip. */
4251 if (STRING_CHARS_FREE_P(from_s_chars)) {
4253 ((struct unused_string_chars *)
4254 from_s_chars)->fullsize;
4255 from_pos += fullsize;
4259 string = from_s_chars->string;
4260 assert(!(LRECORD_FREE_P(string)));
4262 size = string_length(string);
4263 fullsize = STRING_FULLSIZE(size);
4265 gc_checking_assert(!BIG_STRING_FULLSIZE_P(fullsize));
4267 /* Just skip it if it isn't marked. */
4268 if (!MARKED_RECORD_HEADER_P(&(string->lheader))) {
4269 from_pos += fullsize;
4273 /* If it won't fit in what's left of TO_SB, close TO_SB
4274 out and go on to the next string_chars_block. We
4275 know that TO_SB cannot advance past FROM_SB here
4276 since FROM_SB is large enough to currently contain
4278 if ((to_pos + fullsize) >
4279 countof(to_sb->string_chars)) {
4280 to_sb->pos = to_pos;
4281 to_sb = to_sb->next;
4285 /* Compute new address of this string
4286 and update TO_POS for the space being used. */
4288 (struct string_chars *)&(to_sb->
4289 string_chars[to_pos]);
4291 /* Copy the string_chars to the new place. */
4292 if (from_s_chars != to_s_chars)
4293 memmove(to_s_chars, from_s_chars, fullsize);
4295 /* Relocate FROM_S_CHARS's reference */
4296 set_string_data(string, &(to_s_chars->chars[0]));
4298 from_pos += fullsize;
4303 /* Set current to the last string chars block still used and
4304 free any that follow. */
4305 for (volatile struct string_chars_block *victim = to_sb->next;
4307 volatile struct string_chars_block *tofree = victim;
4308 victim = victim->next;
4312 current_string_chars_block = to_sb;
4313 current_string_chars_block->pos = to_pos;
4314 current_string_chars_block->next = 0;
4317 static int debug_string_purity;
4319 static void debug_string_purity_print(Lisp_String * p)
4322 Charcount s = string_char_length(p);
4324 for (i = 0; i < s; i++) {
4325 Emchar ch = string_char(p, i);
4326 if (ch < 32 || ch >= 126)
4327 stderr_out("\\%03o", ch);
4328 else if (ch == '\\' || ch == '\"')
4329 stderr_out("\\%c", ch);
4331 stderr_out("%c", ch);
4337 #if !defined HAVE_BDWGC || !defined EF_USE_BDWGC
4338 static void sweep_strings(void)
4340 int num_small_used = 0, num_small_bytes = 0, num_bytes = 0;
4341 int debug = debug_string_purity;
4343 #define UNMARK_string(ptr) \
4345 Lisp_String *p = (ptr); \
4346 size_t size = string_length (p); \
4347 UNMARK_RECORD_HEADER (&(p->lheader)); \
4348 num_bytes += size; \
4349 if (!BIG_STRING_SIZE_P (size)) { \
4350 num_small_bytes += size; \
4354 debug_string_purity_print (p); \
4356 #define ADDITIONAL_FREE_string(ptr) \
4358 size_t size = string_length (ptr); \
4359 if (BIG_STRING_SIZE_P(size)) { \
4364 SWEEP_FIXED_TYPE_BLOCK(string, Lisp_String);
4366 gc_count_num_short_string_in_use = num_small_used;
4367 gc_count_string_total_size = num_bytes;
4368 gc_count_short_string_total_size = num_small_bytes;
4372 /* I hate duplicating all this crap! */
4373 int marked_p(Lisp_Object obj)
4375 /* Checks we used to perform. */
4376 /* if (EQ (obj, Qnull_pointer)) return 1; */
4377 /* if (!POINTER_TYPE_P (XGCTYPE (obj))) return 1; */
4378 /* if (PURIFIED (XPNTR (obj))) return 1; */
4380 if (XTYPE(obj) == Lisp_Type_Record) {
4381 struct lrecord_header *lheader = XRECORD_LHEADER(obj);
4383 GC_CHECK_LHEADER_INVARIANTS(lheader);
4385 return MARKED_RECORD_HEADER_P(lheader);
4390 #if !defined HAVE_BDWGC || !defined EF_USE_BDWGC
4391 static void gc_sweep(void)
4393 /* Free all unmarked records. Do this at the very beginning,
4394 before anything else, so that the finalize methods can safely
4395 examine items in the objects. sweep_lcrecords_1() makes
4396 sure to call all the finalize methods *before* freeing anything,
4397 to complete the safety. */
4400 sweep_lcrecords_1(&all_lcrecords, &ignored);
4403 compact_string_chars();
4405 /* Finalize methods below (called through the ADDITIONAL_FREE_foo
4406 macros) must be *extremely* careful to make sure they're not
4407 referencing freed objects. The only two existing finalize
4408 methods (for strings and markers) pass muster -- the string
4409 finalizer doesn't look at anything but its own specially-
4410 created block, and the marker finalizer only looks at live
4411 buffers (which will never be freed) and at the markers before
4412 and after it in the chain (which, by induction, will never be
4413 freed because if so, they would have already removed themselves
4416 /* Put all unmarked strings on free list, free'ing the string chars
4417 of large unmarked strings */
4420 /* Put all unmarked conses on free list */
4423 /* Free all unmarked bit vectors */
4424 sweep_bit_vectors_1(&all_bit_vectors,
4425 &gc_count_num_bit_vector_used,
4426 &gc_count_bit_vector_total_size,
4427 &gc_count_bit_vector_storage);
4429 /* Free all unmarked compiled-function objects */
4430 sweep_compiled_functions();
4433 /* Put all unmarked floats on free list */
4435 #endif /* HAVE_FPFLOAT */
4437 #if defined HAVE_MPZ && (defined WITH_GMP || defined WITH_MP)
4438 /* Put all unmarked bignums on free list */
4440 #endif /* HAVE_MPZ */
4442 #if defined HAVE_MPQ && defined WITH_GMP
4443 /* Put all unmarked ratios on free list */
4445 #endif /* HAVE_MPQ */
4447 #if defined HAVE_MPF && defined WITH_GMP
4448 /* Put all unmarked bigfloats on free list */
4450 #endif /* HAVE_MPF */
4452 #if defined HAVE_MPFR && defined WITH_MPFR
4453 /* Put all unmarked bigfloats on free list */
4455 #endif /* HAVE_MPFR */
4457 #if defined HAVE_PSEUG && defined WITH_PSEUG
4458 /* Put all unmarked gaussian numbers on free list */
4460 #endif /* HAVE_PSEUG */
4462 #if defined HAVE_MPC && defined WITH_MPC || \
4463 defined HAVE_PSEUC && defined WITH_PSEUC
4464 /* Put all unmarked complex numbers on free list */
4466 #endif /* HAVE_MPC */
4468 #if defined HAVE_QUATERN && defined WITH_QUATERN
4469 /* Put all unmarked quaternions on free list */
4471 #endif /* HAVE_QUATERN */
4473 /* Put all unmarked dynacats on free list */
4476 /* Put all unmarked symbols on free list */
4479 /* Put all unmarked extents on free list */
4482 /* Put all unmarked markers on free list.
4483 Dechain each one first from the buffer into which it points. */
4489 pdump_objects_unmark();
4494 /* Clearing for disksave. */
4496 void disksave_object_finalization(void)
4498 /* It's important that certain information from the environment not get
4499 dumped with the executable (pathnames, environment variables, etc.).
4500 To make it easier to tell when this has happened with strings(1) we
4501 clear some known-to-be-garbage blocks of memory, so that leftover
4502 results of old evaluation don't look like potential problems.
4503 But first we set some notable variables to nil and do one more GC,
4504 to turn those strings into garbage.
4507 /* Yeah, this list is pretty ad-hoc... */
4508 Vprocess_environment = Qnil;
4509 /* Vexec_directory = Qnil; */
4510 Vdata_directory = Qnil;
4511 Vdoc_directory = Qnil;
4512 Vconfigure_info_directory = Qnil;
4515 /* Vdump_load_path = Qnil; */
4516 /* Release hash tables for locate_file */
4517 Flocate_file_clear_hashing(Qt);
4518 uncache_home_directory();
4520 #if defined(LOADHIST) && !(defined(LOADHIST_DUMPED) || \
4521 defined(LOADHIST_BUILTIN))
4522 Vload_history = Qnil;
4524 Vshell_file_name = Qnil;
4526 garbage_collect_1();
4528 /* Run the disksave finalization methods of all live objects. */
4529 disksave_object_finalization_1();
4531 /* Zero out the uninitialized (really, unused) part of the containers
4532 for the live strings. */
4533 /* dont know what its counterpart in bdwgc mode is, so leave it out */
4534 #if !defined HAVE_BDWGC || !defined EF_USE_BDWGC
4536 struct string_chars_block *scb;
4537 for (scb = first_string_chars_block; scb; scb = scb->next) {
4538 int count = sizeof(scb->string_chars) - scb->pos;
4540 assert(count >= 0 && count < STRING_CHARS_BLOCK_SIZE);
4542 /* from the block's fill ptr to the end */
4543 memset((scb->string_chars + scb->pos), 0,
4550 /* There, that ought to be enough... */
4554 Lisp_Object restore_gc_inhibit(Lisp_Object val)
4556 gc_currently_forbidden = XINT(val);
4560 /* Maybe we want to use this when doing a "panic" gc after memory_full()? */
4561 static int gc_hooks_inhibited;
4563 struct post_gc_action {
4564 void (*fun) (void *);
4568 typedef struct post_gc_action post_gc_action;
4571 Dynarr_declare(post_gc_action);
4572 } post_gc_action_dynarr;
4574 static post_gc_action_dynarr *post_gc_actions;
4576 /* Register an action to be called at the end of GC.
4577 gc_in_progress is 0 when this is called.
4578 This is used when it is discovered that an action needs to be taken,
4579 but it's during GC, so it's not safe. (e.g. in a finalize method.)
4581 As a general rule, do not use Lisp objects here.
4582 And NEVER signal an error.
4585 void register_post_gc_action(void (*fun) (void *), void *arg)
4587 post_gc_action action;
4589 if (!post_gc_actions)
4590 post_gc_actions = Dynarr_new(post_gc_action);
4595 Dynarr_add(post_gc_actions, action);
4598 #if !defined HAVE_BDWGC || !defined EF_USE_BDWGC
4599 static void run_post_gc_actions(void)
4603 if (post_gc_actions) {
4604 for (i = 0; i < Dynarr_length(post_gc_actions); i++) {
4605 post_gc_action action = Dynarr_at(post_gc_actions, i);
4606 (action.fun) (action.arg);
4609 Dynarr_reset(post_gc_actions);
4615 mark_gcprolist(struct gcpro *gcpl)
4619 for (tail = gcpl; tail; tail = tail->next) {
4620 for (i = 0; i < tail->nvars; i++) {
4621 mark_object(tail->var[i]);
4627 #if defined HAVE_BDWGC && defined EF_USE_BDWGC
4636 void garbage_collect_1(void)
4638 SXE_DEBUG_GC("GC\n");
4639 #if defined GC_DEBUG_FLAG
4641 #endif /* GC_DEBUG_FLAG */
4643 GC_collect_a_little();
4647 GC_try_to_collect(stop_gc_p);
4653 void garbage_collect_1(void)
4655 #if MAX_SAVE_STACK > 0
4656 char stack_top_variable;
4657 extern char *stack_bottom;
4662 Lisp_Object pre_gc_cursor;
4663 struct gcpro gcpro1;
4666 || gc_currently_forbidden || in_display || preparing_for_armageddon)
4669 /* We used to call selected_frame() here.
4671 The following functions cannot be called inside GC
4672 so we move to after the above tests. */
4675 Lisp_Object device = Fselected_device(Qnil);
4676 /* Could happen during startup, eg. if always_gc */
4680 frame = DEVICE_SELECTED_FRAME(XDEVICE(device));
4682 signal_simple_error("No frames exist on device",
4688 pre_gc_cursor = Qnil;
4691 GCPRO1(pre_gc_cursor);
4693 /* Very important to prevent GC during any of the following
4694 stuff that might run Lisp code; otherwise, we'll likely
4695 have infinite GC recursion. */
4696 speccount = specpdl_depth();
4697 record_unwind_protect(restore_gc_inhibit,
4698 make_int(gc_currently_forbidden));
4699 gc_currently_forbidden = 1;
4701 if (!gc_hooks_inhibited)
4702 run_hook_trapping_errors("Error in pre-gc-hook", Qpre_gc_hook);
4704 /* Now show the GC cursor/message. */
4705 if (!noninteractive) {
4706 if (FRAME_WIN_P(f)) {
4707 Lisp_Object frame = make_frame(f);
4708 Lisp_Object cursor =
4709 glyph_image_instance(Vgc_pointer_glyph,
4710 FRAME_SELECTED_WINDOW(f),
4712 pre_gc_cursor = f->pointer;
4713 if (POINTER_IMAGE_INSTANCEP(cursor)
4714 /* don't change if we don't know how to change
4716 && POINTER_IMAGE_INSTANCEP(pre_gc_cursor)) {
4718 Fset_frame_pointer(frame, cursor);
4722 /* Don't print messages to the stream device. */
4723 if (STRINGP(Vgc_message) &&
4725 !FRAME_STREAM_P(f)) {
4726 char *msg = GETTEXT((char *) XSTRING_DATA(Vgc_message));
4727 Lisp_Object args[2], whole_msg;
4729 args[0] = build_string(
4730 msg ? msg : GETTEXT((char*)gc_default_message));
4731 args[1] = build_string("...");
4732 whole_msg = Fconcat(2, args);
4733 echo_area_message(f, (Bufbyte *) 0, whole_msg, 0, -1,
4734 Qgarbage_collecting);
4738 /***** Now we actually start the garbage collection. */
4742 inhibit_non_essential_printing_operations = 1;
4744 gc_generation_number[0]++;
4746 #if MAX_SAVE_STACK > 0
4748 /* Save a copy of the contents of the stack, for debugging. */
4750 /* Static buffer in which we save a copy of the C stack at each
4752 static char *stack_copy;
4753 static size_t stack_copy_size;
4755 ptrdiff_t stack_diff = &stack_top_variable - stack_bottom;
4756 size_t stack_size = (stack_diff > 0 ? stack_diff : -stack_diff);
4757 if (stack_size < MAX_SAVE_STACK) {
4758 if (stack_copy_size < stack_size) {
4760 (char *)xrealloc(stack_copy, stack_size);
4761 stack_copy_size = stack_size;
4766 0 ? stack_bottom : &stack_top_variable,
4770 #endif /* MAX_SAVE_STACK > 0 */
4772 /* Do some totally ad-hoc resource clearing. */
4773 /* #### generalize this? */
4774 clear_event_resource();
4775 cleanup_specifiers();
4777 /* Mark all the special slots that serve as the roots of
4781 Lisp_Object **p = Dynarr_begin(staticpros);
4783 for (count = Dynarr_length(staticpros); count; count--) {
4788 { /* staticpro_nodump() */
4789 Lisp_Object **p = Dynarr_begin(staticpros_nodump);
4791 for (count = Dynarr_length(staticpros_nodump); count; count--) {
4796 #if defined(EF_USE_ASYNEQ)
4797 WITH_DLLIST_TRAVERSE(
4799 eq_worker_t eqw = dllist_item;
4800 struct gcpro *gcpl = eqw->gcprolist;
4801 mark_gcprolist(gcpl));
4804 mark_gcprolist(gcprolist);
4807 struct specbinding *bind;
4808 for (bind = specpdl; bind != specpdl_ptr; bind++) {
4809 mark_object(bind->symbol);
4810 mark_object(bind->old_value);
4815 struct catchtag *catch;
4816 for (catch = catchlist; catch; catch = catch->next) {
4817 mark_object(catch->tag);
4818 mark_object(catch->val);
4823 struct backtrace *backlist;
4824 for (backlist = backtrace_list; backlist;
4825 backlist = backlist->next) {
4826 int nargs = backlist->nargs;
4829 mark_object(*backlist->function);
4831 0 /* nargs == UNEVALLED || nargs == MANY */ )
4832 mark_object(backlist->args[0]);
4834 for (i = 0; i < nargs; i++)
4835 mark_object(backlist->args[i]);
4840 mark_profiling_info();
4842 /* OK, now do the after-mark stuff. This is for things that are only
4843 marked when something else is marked (e.g. weak hash tables). There
4844 may be complex dependencies between such objects -- e.g. a weak hash
4845 table might be unmarked, but after processing a later weak hash
4846 table, the former one might get marked. So we have to iterate until
4847 nothing more gets marked. */
4848 while (finish_marking_weak_hash_tables() > 0 ||
4849 finish_marking_weak_lists() > 0) ;
4851 /* And prune (this needs to be called after everything else has been
4852 marked and before we do any sweeping). */
4853 /* #### this is somewhat ad-hoc and should probably be an object
4855 prune_weak_hash_tables();
4858 prune_syntax_tables();
4862 consing_since_gc = 0;
4863 #ifndef DEBUG_SXEMACS
4864 /* Allow you to set it really fucking low if you really want ... */
4865 if (gc_cons_threshold < 10000)
4866 gc_cons_threshold = 10000;
4870 inhibit_non_essential_printing_operations = 0;
4873 run_post_gc_actions();
4875 /******* End of garbage collection ********/
4877 run_hook_trapping_errors("Error in post-gc-hook", Qpost_gc_hook);
4879 /* Now remove the GC cursor/message */
4880 if (!noninteractive) {
4882 Fset_frame_pointer(make_frame(f), pre_gc_cursor);
4883 else if (STRINGP(Vgc_message) && !FRAME_STREAM_P(f)) {
4884 char *msg = GETTEXT((char *)XSTRING_DATA(Vgc_message));
4886 /* Show "...done" only if the echo area would otherwise
4888 if (NILP(clear_echo_area(selected_frame(),
4889 Qgarbage_collecting, 0))) {
4890 Lisp_Object args[2], whole_msg;
4891 args[0] = build_string(
4893 : GETTEXT((char*)gc_default_message));
4894 args[1] = build_string("... done");
4895 whole_msg = Fconcat(2, args);
4896 echo_area_message(selected_frame(),
4897 (Bufbyte *) 0, whole_msg, 0,
4898 -1, Qgarbage_collecting);
4903 /* now stop inhibiting GC */
4904 unbind_to(speccount, Qnil);
4906 if (!breathing_space) {
4907 breathing_space = malloc(0xFFFF - MALLOC_OVERHEAD);
4916 /* Debugging aids. */
4917 #if defined HAVE_BDWGC && defined EF_USE_BDWGC
4918 #define HACK_O_MATIC(args...)
4919 #define gc_plist_hack(name, val, tail) \
4920 cons3(intern(name), Qzero, tail)
4924 static Lisp_Object gc_plist_hack(const char *name, int value, Lisp_Object tail)
4926 /* C doesn't have local functions (or closures, or GC, or readable
4927 syntax, or portable numeric datatypes, or bit-vectors, or characters,
4928 or arrays, or exceptions, or ...) */
4929 return cons3(intern(name), make_int(value), tail);
4932 #define HACK_O_MATIC(type, name, pl) \
4935 struct type##_block *x = current_##type##_block; \
4937 s += sizeof (*x) + MALLOC_OVERHEAD; \
4940 (pl) = gc_plist_hack ((name), s, (pl)); \
4944 DEFUN("garbage-collect", Fgarbage_collect, 0, 0, "", /*
4945 Reclaim storage for Lisp objects no longer needed.
4946 Return info on amount of space in use:
4947 ((USED-CONSES . FREE-CONSES) (USED-SYMS . FREE-SYMS)
4948 (USED-MARKERS . FREE-MARKERS) USED-STRING-CHARS USED-VECTOR-SLOTS
4950 where `PLIST' is a list of alternating keyword/value pairs providing
4951 more detailed information.
4952 Garbage collection happens automatically if you cons more than
4953 `gc-cons-threshold' bytes of Lisp data since previous garbage collection.
4957 #if defined HAVE_BDWGC && defined EF_USE_BDWGC
4961 Lisp_Object pl = Qnil;
4963 int gc_count_vector_total_size = 0;
4965 garbage_collect_1();
4967 for (i = 0; i < lrecord_type_count; i++) {
4968 if (lcrecord_stats[i].bytes_in_use != 0
4969 || lcrecord_stats[i].bytes_freed != 0
4970 || lcrecord_stats[i].instances_on_free_list != 0) {
4973 lrecord_implementations_table[i]->name;
4974 int len = strlen(name);
4977 /* save this for the FSFmacs-compatible part of the
4979 if (i == lrecord_type_vector)
4980 gc_count_vector_total_size =
4981 lcrecord_stats[i].bytes_in_use +
4982 lcrecord_stats[i].bytes_freed;
4984 sz = snprintf(buf, sizeof(buf), "%s-storage", name);
4985 assert(sz >=0 && (size_t)sz < sizeof(buf));
4986 pl = gc_plist_hack(buf, lcrecord_stats[i].bytes_in_use,
4988 /* Okay, simple pluralization check for
4989 `symbol-value-varalias' */
4990 if (name[len - 1] == 's')
4991 sz = snprintf(buf, sizeof(buf), "%ses-freed", name);
4993 sz = snprintf(buf, sizeof(buf), "%ss-freed", name);
4994 assert(sz >=0 && (size_t)sz < sizeof(buf));
4995 if (lcrecord_stats[i].instances_freed != 0)
4996 pl = gc_plist_hack(buf,
4998 instances_freed, pl);
4999 if (name[len - 1] == 's')
5000 sz = snprintf(buf, sizeof(buf), "%ses-on-free-list", name);
5002 sz = snprintf(buf, sizeof(buf), "%ss-on-free-list", name);
5003 assert(sz >=0 && (size_t)sz < sizeof(buf));
5004 if (lcrecord_stats[i].instances_on_free_list != 0)
5005 pl = gc_plist_hack(buf,
5007 instances_on_free_list, pl);
5008 if (name[len - 1] == 's')
5009 sz = snprintf(buf, sizeof(buf), "%ses-used", name);
5011 sz = snprintf(buf, sizeof(buf), "%ss-used", name);
5012 assert(sz >=0 && (size_t)sz < sizeof(buf));
5013 pl = gc_plist_hack(buf,
5014 lcrecord_stats[i].instances_in_use,
5019 HACK_O_MATIC(extent, "extent-storage", pl);
5020 pl = gc_plist_hack("extents-free", gc_count_num_extent_freelist, pl);
5021 pl = gc_plist_hack("extents-used", gc_count_num_extent_in_use, pl);
5022 HACK_O_MATIC(event, "event-storage", pl);
5023 pl = gc_plist_hack("events-free", gc_count_num_event_freelist, pl);
5024 pl = gc_plist_hack("events-used", gc_count_num_event_in_use, pl);
5025 HACK_O_MATIC(marker, "marker-storage", pl);
5026 pl = gc_plist_hack("markers-free", gc_count_num_marker_freelist, pl);
5027 pl = gc_plist_hack("markers-used", gc_count_num_marker_in_use, pl);
5029 HACK_O_MATIC(float, "float-storage", pl);
5030 pl = gc_plist_hack("floats-free", gc_count_num_float_freelist, pl);
5031 pl = gc_plist_hack("floats-used", gc_count_num_float_in_use, pl);
5032 #endif /* HAVE_FPFLOAT */
5033 #if defined HAVE_MPZ && (defined WITH_GMP || defined WITH_MP)
5034 HACK_O_MATIC(bigz, "bigz-storage", pl);
5035 pl = gc_plist_hack("bigzs-free", gc_count_num_bigz_freelist, pl);
5036 pl = gc_plist_hack("bigzs-used", gc_count_num_bigz_in_use, pl);
5037 #endif /* HAVE_MPZ */
5038 #if defined HAVE_MPQ && defined WITH_GMP
5039 HACK_O_MATIC(bigq, "bigq-storage", pl);
5040 pl = gc_plist_hack("bigqs-free", gc_count_num_bigq_freelist, pl);
5041 pl = gc_plist_hack("bigqs-used", gc_count_num_bigq_in_use, pl);
5042 #endif /* HAVE_MPQ */
5043 #if defined HAVE_MPF && defined WITH_GMP
5044 HACK_O_MATIC(bigf, "bigf-storage", pl);
5045 pl = gc_plist_hack("bigfs-free", gc_count_num_bigf_freelist, pl);
5046 pl = gc_plist_hack("bigfs-used", gc_count_num_bigf_in_use, pl);
5047 #endif /* HAVE_MPF */
5048 #if defined HAVE_MPFR && defined WITH_MPFR
5049 HACK_O_MATIC(bigfr, "bigfr-storage", pl);
5050 pl = gc_plist_hack("bigfrs-free", gc_count_num_bigfr_freelist, pl);
5051 pl = gc_plist_hack("bigfrs-used", gc_count_num_bigfr_in_use, pl);
5052 #endif /* HAVE_MPFR */
5053 #if defined HAVE_PSEUG && defined WITH_PSEUG
5054 HACK_O_MATIC(bigg, "bigg-storage", pl);
5055 pl = gc_plist_hack("biggs-free", gc_count_num_bigg_freelist, pl);
5056 pl = gc_plist_hack("biggs-used", gc_count_num_bigg_in_use, pl);
5057 #endif /* HAVE_PSEUG */
5058 #if defined HAVE_MPC && defined WITH_MPC || \
5059 defined HAVE_PSEUC && defined WITH_PSEUC
5060 HACK_O_MATIC(bigc, "bigc-storage", pl);
5061 pl = gc_plist_hack("bigcs-free", gc_count_num_bigc_freelist, pl);
5062 pl = gc_plist_hack("bigcs-used", gc_count_num_bigc_in_use, pl);
5063 #endif /* HAVE_MPC */
5064 #if defined HAVE_QUATERN && defined WITH_QUATERN
5065 HACK_O_MATIC(quatern, "quatern-storage", pl);
5066 pl = gc_plist_hack("quaterns-free", gc_count_num_quatern_freelist, pl);
5067 pl = gc_plist_hack("quaterns-used", gc_count_num_quatern_in_use, pl);
5068 #endif /* HAVE_QUATERN */
5070 HACK_O_MATIC(dynacat, "dynacat-storage", pl);
5071 pl = gc_plist_hack("dynacats-free", gc_count_num_dynacat_freelist, pl);
5072 pl = gc_plist_hack("dynacats-used", gc_count_num_dynacat_in_use, pl);
5074 HACK_O_MATIC(string, "string-header-storage", pl);
5075 pl = gc_plist_hack("long-strings-total-length",
5076 gc_count_string_total_size
5077 - gc_count_short_string_total_size, pl);
5078 HACK_O_MATIC(string_chars, "short-string-storage", pl);
5079 pl = gc_plist_hack("short-strings-total-length",
5080 gc_count_short_string_total_size, pl);
5081 pl = gc_plist_hack("strings-free", gc_count_num_string_freelist, pl);
5082 pl = gc_plist_hack("long-strings-used",
5083 gc_count_num_string_in_use
5084 - gc_count_num_short_string_in_use, pl);
5085 pl = gc_plist_hack("short-strings-used",
5086 gc_count_num_short_string_in_use, pl);
5088 HACK_O_MATIC(compiled_function, "compiled-function-storage", pl);
5089 pl = gc_plist_hack("compiled-functions-free",
5090 gc_count_num_compiled_function_freelist, pl);
5091 pl = gc_plist_hack("compiled-functions-used",
5092 gc_count_num_compiled_function_in_use, pl);
5094 pl = gc_plist_hack("bit-vector-storage", gc_count_bit_vector_storage,
5096 pl = gc_plist_hack("bit-vectors-total-length",
5097 gc_count_bit_vector_total_size, pl);
5098 pl = gc_plist_hack("bit-vectors-used", gc_count_num_bit_vector_used,
5101 HACK_O_MATIC(symbol, "symbol-storage", pl);
5102 pl = gc_plist_hack("symbols-free", gc_count_num_symbol_freelist, pl);
5103 pl = gc_plist_hack("symbols-used", gc_count_num_symbol_in_use, pl);
5105 HACK_O_MATIC(cons, "cons-storage", pl);
5106 pl = gc_plist_hack("conses-free", gc_count_num_cons_freelist, pl);
5107 pl = gc_plist_hack("conses-used", gc_count_num_cons_in_use, pl);
5109 /* The things we do for backwards-compatibility */
5110 /* fuck, what are we doing about those in the bdwgc era? -hrop */
5112 list6(Fcons(make_int(gc_count_num_cons_in_use),
5113 make_int(gc_count_num_cons_freelist)),
5114 Fcons(make_int(gc_count_num_symbol_in_use),
5115 make_int(gc_count_num_symbol_freelist)),
5116 Fcons(make_int(gc_count_num_marker_in_use),
5117 make_int(gc_count_num_marker_freelist)),
5118 make_int(gc_count_string_total_size),
5119 make_int(gc_count_vector_total_size), pl);
5125 /* grrrr ... lisp/itimer-autosave.el is using this, WTF? */
5126 DEFUN("consing-since-gc", Fconsing_since_gc, 0, 0, "", /*
5127 Return the number of bytes consed since the last garbage collection.
5128 \"Consed\" is a misnomer in that this actually counts allocation
5129 of all different kinds of objects, not just conses.
5131 If this value exceeds `gc-cons-threshold', a garbage collection happens.
5135 #if defined HAVE_BDWGC && defined EF_USE_BDWGC
5138 return make_int(consing_since_gc);
5143 int object_dead_p(Lisp_Object obj)
5145 return ((BUFFERP(obj) && !BUFFER_LIVE_P(XBUFFER(obj))) ||
5146 (FRAMEP(obj) && !FRAME_LIVE_P(XFRAME(obj))) ||
5147 (WINDOWP(obj) && !WINDOW_LIVE_P(XWINDOW(obj))) ||
5148 (DEVICEP(obj) && !DEVICE_LIVE_P(XDEVICE(obj))) ||
5149 (CONSOLEP(obj) && !CONSOLE_LIVE_P(XCONSOLE(obj))) ||
5150 (EVENTP(obj) && !EVENT_LIVE_P(XEVENT(obj))) ||
5151 (EXTENTP(obj) && !EXTENT_LIVE_P(XEXTENT(obj))));
5154 #if defined MEMORY_USAGE_STATS && !(defined HAVE_BDWGC && defined EF_USE_BDWGC)
5156 /* Attempt to determine the actual amount of space that is used for
5157 the block allocated starting at PTR, supposedly of size "CLAIMED_SIZE".
5159 It seems that the following holds:
5161 1. When using the old allocator (malloc.c):
5163 -- blocks are always allocated in chunks of powers of two. For
5164 each block, there is an overhead of 8 bytes if rcheck is not
5165 defined, 20 bytes if it is defined. In other words, a
5166 one-byte allocation needs 8 bytes of overhead for a total of
5167 9 bytes, and needs to have 16 bytes of memory chunked out for
5170 2. When using the new allocator (gmalloc.c):
5172 -- blocks are always allocated in chunks of powers of two up
5173 to 4096 bytes. Larger blocks are allocated in chunks of
5174 an integral multiple of 4096 bytes. The minimum block
5175 size is 2*sizeof (void *), or 16 bytes if SUNOS_LOCALTIME_BUG
5176 is defined. There is no per-block overhead, but there
5177 is an overhead of 3*sizeof (size_t) for each 4096 bytes
5180 3. When using the system malloc, anything goes, but they are
5181 generally slower and more space-efficient than the GNU
5182 allocators. One possibly reasonable assumption to make
5183 for want of better data is that sizeof (void *), or maybe
5184 2 * sizeof (void *), is required as overhead and that
5185 blocks are allocated in the minimum required size except
5186 that some minimum block size is imposed (e.g. 16 bytes). */
5189 malloced_storage_size(void *ptr, size_t claimed_size,
5190 struct overhead_stats * stats)
5192 size_t orig_claimed_size = claimed_size;
5196 if (claimed_size < 2 * sizeof(void *))
5197 claimed_size = 2 * sizeof(void *);
5198 # ifdef SUNOS_LOCALTIME_BUG
5199 if (claimed_size < 16)
5202 if (claimed_size < 4096) {
5205 /* compute the log base two, more or less, then use it to compute
5206 the block size needed. */
5208 /* It's big, it's heavy, it's wood! */
5209 while ((claimed_size /= 2) != 0)
5212 /* It's better than bad, it's good! */
5217 /* We have to come up with some average about the amount of
5219 if ((size_t) (rand() & 4095) < claimed_size)
5220 claimed_size += 3 * sizeof(void *);
5222 claimed_size += 4095;
5223 claimed_size &= ~4095;
5224 claimed_size += (claimed_size / 4096) * 3 * sizeof(size_t);
5227 #elif defined (SYSTEM_MALLOC)
5229 if (claimed_size < 16)
5231 claimed_size += 2 * sizeof(void *);
5233 #else /* old GNU allocator */
5235 # ifdef rcheck /* #### may not be defined here */
5243 /* compute the log base two, more or less, then use it to compute
5244 the block size needed. */
5246 /* It's big, it's heavy, it's wood! */
5247 while ((claimed_size /= 2) != 0)
5250 /* It's better than bad, it's good! */
5257 #endif /* old GNU allocator */
5260 stats->was_requested += orig_claimed_size;
5261 stats->malloc_overhead += claimed_size - orig_claimed_size;
5263 return claimed_size;
5266 size_t fixed_type_block_overhead(size_t size)
5268 size_t per_block = TYPE_ALLOC_SIZE(cons, unsigned char);
5269 size_t overhead = 0;
5270 size_t storage_size = malloced_storage_size(0, per_block, 0);
5271 while (size >= per_block) {
5273 overhead += sizeof(void *) + per_block - storage_size;
5275 if (rand() % per_block < size)
5276 overhead += sizeof(void *) + per_block - storage_size;
5280 #endif /* MEMORY_USAGE_STATS */
5282 #ifdef EF_USE_ASYNEQ
5284 init_main_worker(void)
5286 eq_worker_t res = eq_make_worker();
5287 eq_worker_thread(res) = pthread_self();
5292 #if defined HAVE_MPZ && defined WITH_GMP || \
5293 defined HAVE_MPFR && defined WITH_MPFR
5295 my_malloc(size_t bar)
5297 /* we use atomic here since GMP/MPFR do supervise their objects */
5298 void *foo = xmalloc(bar);
5299 SXE_DEBUG_GC_GMP("alloc :is %p :size %lu\n",
5300 foo, (long unsigned int)bar);
5304 /* We need the next two functions since GNU MP insists on giving us an extra
5307 my_realloc (void *ptr, size_t SXE_UNUSED(old_size), size_t new_size)
5309 void *foo = xrealloc(ptr, new_size);
5310 SXE_DEBUG_GC_GMP("gmp realloc :was %p :is %p\n", ptr, foo);
5315 my_free (void *ptr, size_t size)
5317 SXE_DEBUG_GC_GMP("free :was %p :size %lu\n",
5318 ptr, (long unsigned int)size);
5319 memset(ptr, 0, size);
5323 #endif /* GMP || MPFR */
5325 #if defined HAVE_BDWGC && defined EF_USE_BDWGC && !defined GC_DEBUG_FLAG
5327 my_shy_warn_proc(char *msg, GC_word arg)
5329 /* just don't do anything */
5335 /* Initialization */
5336 void init_bdwgc(void);
5341 #if defined HAVE_BDWGC && defined EF_USE_BDWGC
5342 # if defined GC_DEBUG_FLAG
5343 extern long GC_large_alloc_warn_interval;
5345 GC_time_limit = GC_TIME_UNLIMITED;
5346 GC_use_entire_heap = 0;
5349 GC_all_interior_pointers = 1;
5353 GC_free_space_divisor = 8;
5355 #if !defined GC_DEBUG_FLAG
5356 GC_set_warn_proc(my_shy_warn_proc);
5357 #else /* GC_DEBUG_FLAG */
5358 GC_large_alloc_warn_interval = 1L;
5359 #endif /* GC_DEBUG_FLAG */
5366 __init_gmp_mem_funs(void)
5368 #if defined HAVE_MPZ && defined WITH_GMP || \
5369 defined HAVE_MPFR && defined WITH_MPFR
5370 mp_set_memory_functions(my_malloc, my_realloc, my_free);
5371 #endif /* GMP || MPFR */
5374 void reinit_alloc_once_early(void)
5376 gc_generation_number[0] = 0;
5377 breathing_space = NULL;
5378 XSETINT(all_bit_vectors, 0); /* Qzero may not be set yet. */
5379 XSETINT(Vgc_message, 0);
5380 #if !defined HAVE_BDWGC || !defined EF_USE_BDWGC
5383 ignore_malloc_warnings = 1;
5384 #ifdef DOUG_LEA_MALLOC
5385 mallopt(M_TRIM_THRESHOLD, 128 * 1024); /* trim threshold */
5386 mallopt(M_MMAP_THRESHOLD, 64 * 1024); /* mmap threshold */
5387 #if 1 /* Moved to emacs.c */
5388 mallopt(M_MMAP_MAX, 0); /* max. number of mmap'ed areas */
5391 /* the category subsystem */
5392 morphisms[lrecord_type_cons].seq_impl = &__scons;
5393 morphisms[lrecord_type_vector].seq_impl = &__svec;
5394 morphisms[lrecord_type_string].seq_impl = &__sstr;
5395 morphisms[lrecord_type_bit_vector].seq_impl = &__sbvc;
5397 init_string_alloc();
5398 #if !defined HAVE_BDWGC || !defined EF_USE_BDWGC
5399 init_string_chars_alloc();
5402 init_symbol_alloc();
5403 init_compiled_function_alloc();
5407 __init_gmp_mem_funs();
5408 #if defined HAVE_MPZ && (defined WITH_GMP || defined WITH_MP) && \
5409 !(defined HAVE_BDWGC && defined EF_USE_BDWGC)
5412 #if defined HAVE_MPQ && defined WITH_GMP && \
5413 !(defined HAVE_BDWGC && defined EF_USE_BDWGC)
5416 #if defined HAVE_MPF && defined WITH_GMP && \
5417 !(defined HAVE_BDWGC && defined EF_USE_BDWGC)
5420 #if defined HAVE_MPFR && defined WITH_MPFR
5423 #if defined HAVE_PSEUG && defined HAVE_MPZ && defined WITH_PSEUG
5426 #if defined HAVE_MPC && defined WITH_MPC || \
5427 defined HAVE_PSEUC && defined WITH_PSEUC
5430 #if defined HAVE_QUATERN && defined HAVE_MPZ && defined WITH_QUATERN
5431 init_quatern_alloc();
5433 init_dynacat_alloc();
5435 init_marker_alloc();
5436 init_extent_alloc();
5439 ignore_malloc_warnings = 0;
5441 /* we only use the 500k value for now */
5442 gc_cons_threshold = 500000;
5443 lrecord_uid_counter = 259;
5445 #if !defined HAVE_BDWGC || !defined EF_USE_BDWGC
5446 if (staticpros_nodump) {
5447 Dynarr_free(staticpros_nodump);
5449 staticpros_nodump = Dynarr_new2(Lisp_Object_ptr_dynarr, Lisp_Object *);
5450 /* merely a small optimization */
5451 Dynarr_resize(staticpros_nodump, 100);
5453 /* tuning the GCor */
5454 consing_since_gc = 0;
5455 debug_string_purity = 0;
5457 #ifdef EF_USE_ASYNEQ
5458 workers = make_noseeum_dllist();
5459 dllist_prepend(workers, init_main_worker());
5464 #if defined EF_USE_ASYNEQ && !(defined HAVE_BDWGC && defined EF_USE_BDWGC)
5465 SXE_MUTEX_INIT(&cons_mutex);
5468 gc_currently_forbidden = 0;
5469 gc_hooks_inhibited = 0;
5471 #ifdef ERROR_CHECK_TYPECHECK
5473 really_unlikely_name_to_have_accidentally_in_a_non_errb_structure =
5476 really_unlikely_name_to_have_accidentally_in_a_non_errb_structure =
5479 really_unlikely_name_to_have_accidentally_in_a_non_errb_structure =
5481 #endif /* ERROR_CHECK_TYPECHECK */
5484 void init_alloc_once_early(void)
5486 reinit_alloc_once_early();
5488 for (int i = 0; i < countof(lrecord_implementations_table); i++) {
5489 lrecord_implementations_table[i] = 0;
5492 INIT_LRECORD_IMPLEMENTATION(cons);
5493 INIT_LRECORD_IMPLEMENTATION(vector);
5494 INIT_LRECORD_IMPLEMENTATION(string);
5495 INIT_LRECORD_IMPLEMENTATION(lcrecord_list);
5497 staticpros = Dynarr_new2(Lisp_Object_ptr_dynarr, Lisp_Object *);
5498 Dynarr_resize(staticpros, 1410); /* merely a small optimization */
5499 dump_add_root_struct_ptr(&staticpros, &staticpros_description);
5501 /* GMP/MPFR mem funs */
5502 __init_gmp_mem_funs();
5507 void reinit_alloc(void)
5509 #ifdef EF_USE_ASYNEQ
5510 eq_worker_t main_th;
5511 assert(dllist_size(workers) == 1);
5512 main_th = dllist_car(workers);
5513 eq_worker_gcprolist(main_th) = NULL;
5519 void syms_of_alloc(void)
5521 DEFSYMBOL(Qpre_gc_hook);
5522 DEFSYMBOL(Qpost_gc_hook);
5523 DEFSYMBOL(Qgarbage_collecting);
5528 DEFSUBR(Fbit_vector);
5529 DEFSUBR(Fmake_byte_code);
5530 DEFSUBR(Fmake_list);
5531 DEFSUBR(Fmake_vector);
5532 DEFSUBR(Fmake_bit_vector);
5533 DEFSUBR(Fmake_string);
5535 DEFSUBR(Fmake_symbol);
5536 DEFSUBR(Fmake_marker);
5538 DEFSUBR(Fgarbage_collect);
5539 DEFSUBR(Fconsing_since_gc);
5542 void vars_of_alloc(void)
5544 DEFVAR_INT("gc-cons-threshold", &gc_cons_threshold /*
5545 *Number of bytes of consing between garbage collections.
5546 \"Consing\" is a misnomer in that this actually counts allocation
5547 of all different kinds of objects, not just conses.
5548 Garbage collection can happen automatically once this many bytes have been
5549 allocated since the last garbage collection. All data types count.
5551 Garbage collection happens automatically when `eval' or `funcall' are
5552 called. (Note that `funcall' is called implicitly as part of evaluation.)
5553 By binding this temporarily to a large number, you can effectively
5554 prevent garbage collection during a part of the program.
5556 See also `consing-since-gc'.
5559 #ifdef DEBUG_SXEMACS
5560 DEFVAR_INT("debug-allocation", &debug_allocation /*
5561 If non-zero, print out information to stderr about all objects allocated.
5562 See also `debug-allocation-backtrace-length'.
5564 debug_allocation = 0;
5566 DEFVAR_INT("debug-allocation-backtrace-length", &debug_allocation_backtrace_length /*
5567 Length (in stack frames) of short backtrace printed out by `debug-allocation'.
5569 debug_allocation_backtrace_length = 2;
5572 DEFVAR_BOOL("purify-flag", &purify_flag /*
5573 Non-nil means loading Lisp code in order to dump an executable.
5574 This means that certain objects should be allocated in readonly space.
5577 DEFVAR_LISP("pre-gc-hook", &Vpre_gc_hook /*
5578 Function or functions to be run just before each garbage collection.
5579 Interrupts, garbage collection, and errors are inhibited while this hook
5580 runs, so be extremely careful in what you add here. In particular, avoid
5581 consing, and do not interact with the user.
5583 Vpre_gc_hook = Qnil;
5585 DEFVAR_LISP("post-gc-hook", &Vpost_gc_hook /*
5586 Function or functions to be run just after each garbage collection.
5587 Interrupts, garbage collection, and errors are inhibited while this hook
5588 runs, so be extremely careful in what you add here. In particular, avoid
5589 consing, and do not interact with the user.
5591 Vpost_gc_hook = Qnil;
5593 DEFVAR_LISP("gc-message", &Vgc_message /*
5594 String to print to indicate that a garbage collection is in progress.
5595 This is printed in the echo area. If the selected frame is on a
5596 window system and `gc-pointer-glyph' specifies a value (i.e. a pointer
5597 image instance) in the domain of the selected frame, the mouse pointer
5598 will change instead of this message being printed.
5599 If it has non-string value - nothing is printed.
5601 Vgc_message = build_string(gc_default_message);
5603 DEFVAR_LISP("gc-pointer-glyph", &Vgc_pointer_glyph /*
5604 Pointer glyph used to indicate that a garbage collection is in progress.
5605 If the selected window is on a window system and this glyph specifies a
5606 value (i.e. a pointer image instance) in the domain of the selected
5607 window, the pointer will be changed as specified during garbage collection.
5608 Otherwise, a message will be printed in the echo area, as controlled
5613 void complex_vars_of_alloc(void)
5615 Vgc_pointer_glyph = Fmake_glyph_internal(Qpointer);