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 /************************************************************************/
1230 /* used by many of the allocators below */
1231 #include "ent/ent.h"
1236 DECLARE_FIXED_TYPE_ALLOC(float, Lisp_Float);
1237 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_float 1000
1239 Lisp_Object make_float(fpfloat float_value)
1244 if (ENT_FLOAT_PINF_P(float_value))
1245 return make_indef(POS_INFINITY);
1246 else if (ENT_FLOAT_NINF_P(float_value))
1247 return make_indef(NEG_INFINITY);
1248 else if (ENT_FLOAT_NAN_P(float_value))
1249 return make_indef(NOT_A_NUMBER);
1251 ALLOCATE_FIXED_TYPE(float, Lisp_Float, f);
1253 /* Avoid dump-time `uninitialized memory read' purify warnings. */
1254 if (sizeof(struct lrecord_header) +
1255 sizeof(fpfloat) != sizeof(*f))
1258 set_lheader_implementation(&f->lheader, &lrecord_float);
1259 float_data(f) = float_value;
1264 #endif /* HAVE_FPFLOAT */
1266 /************************************************************************/
1267 /* Enhanced number allocation */
1268 /************************************************************************/
1271 #if defined HAVE_MPZ && (defined WITH_GMP || defined WITH_MP)
1272 DECLARE_FIXED_TYPE_ALLOC(bigz, Lisp_Bigz);
1273 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_bigz 250
1275 #if defined HAVE_BDWGC && defined EF_USE_BDWGC && 0
1277 bigz_register_finaliser(Lisp_Bigz *b)
1279 GC_finalization_proc *foo = NULL;
1281 auto void bigz_finaliser();
1283 auto void bigz_finaliser(void *obj, void *SXE_UNUSED(data))
1285 bigz_fini(bigz_data((Lisp_Bigz*)obj));
1287 memset(obj, 0, sizeof(Lisp_Bigz));
1291 GC_REGISTER_FINALIZER(b, bigz_finaliser, NULL, foo, bar);
1296 bigz_register_finaliser(Lisp_Bigz *SXE_UNUSED(b))
1300 #endif /* HAVE_BDWGC */
1302 /* WARNING: This function returns a bignum even if its argument fits into a
1303 fixnum. See Fcanonicalize_number(). */
1305 make_bigz (long bigz_value)
1309 ALLOCATE_FIXED_TYPE(bigz, Lisp_Bigz, b);
1310 bigz_register_finaliser(b);
1312 set_lheader_implementation(&b->lheader, &lrecord_bigz);
1313 bigz_init(bigz_data(b));
1314 bigz_set_long(bigz_data(b), bigz_value);
1315 return wrap_bigz(b);
1318 /* WARNING: This function returns a bigz even if its argument fits into a
1319 fixnum. See Fcanonicalize_number(). */
1321 make_bigz_bz (bigz bz)
1325 ALLOCATE_FIXED_TYPE(bigz, Lisp_Bigz, b);
1326 bigz_register_finaliser(b);
1328 set_lheader_implementation(&b->lheader, &lrecord_bigz);
1329 bigz_init(bigz_data(b));
1330 bigz_set(bigz_data(b), bz);
1331 return wrap_bigz(b);
1333 #endif /* HAVE_MPZ */
1336 #if defined HAVE_MPQ && defined WITH_GMP
1337 DECLARE_FIXED_TYPE_ALLOC(bigq, Lisp_Bigq);
1338 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_bigq 250
1340 #if defined HAVE_BDWGC && defined EF_USE_BDWGC && 0
1342 bigq_register_finaliser(Lisp_Bigq *b)
1344 GC_finalization_proc *foo = NULL;
1346 auto void bigq_finaliser();
1348 auto void bigq_finaliser(void *obj, void *SXE_UNUSED(data))
1350 bigq_fini(bigq_data((Lisp_Bigq*)obj));
1352 memset(obj, 0, sizeof(Lisp_Bigq));
1356 GC_REGISTER_FINALIZER(b, bigq_finaliser, NULL, foo, bar);
1361 bigq_register_finaliser(Lisp_Bigq *SXE_UNUSED(b))
1365 #endif /* HAVE_BDWGC */
1368 make_bigq(long numerator, unsigned long denominator)
1372 ALLOCATE_FIXED_TYPE(bigq, Lisp_Bigq, r);
1373 bigq_register_finaliser(r);
1375 set_lheader_implementation(&r->lheader, &lrecord_bigq);
1376 bigq_init(bigq_data(r));
1377 bigq_set_long_ulong(bigq_data(r), numerator, denominator);
1378 bigq_canonicalize(bigq_data(r));
1379 return wrap_bigq(r);
1383 make_bigq_bz(bigz numerator, bigz denominator)
1387 ALLOCATE_FIXED_TYPE(bigq, Lisp_Bigq, r);
1388 bigq_register_finaliser(r);
1390 set_lheader_implementation(&r->lheader, &lrecord_bigq);
1391 bigq_init(bigq_data(r));
1392 bigq_set_bigz_bigz(bigq_data(r), numerator, denominator);
1393 bigq_canonicalize(bigq_data(r));
1394 return wrap_bigq(r);
1398 make_bigq_bq(bigq rat)
1402 ALLOCATE_FIXED_TYPE(bigq, Lisp_Bigq, r);
1403 bigq_register_finaliser(r);
1405 set_lheader_implementation(&r->lheader, &lrecord_bigq);
1406 bigq_init(bigq_data(r));
1407 bigq_set(bigq_data(r), rat);
1408 return wrap_bigq(r);
1410 #endif /* HAVE_MPQ */
1413 #if defined HAVE_MPF && defined WITH_GMP
1414 DECLARE_FIXED_TYPE_ALLOC(bigf, Lisp_Bigf);
1415 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_bigf 250
1417 #if defined HAVE_BDWGC && defined EF_USE_BDWGC && 0
1419 bigf_register_finaliser(Lisp_Bigf *b)
1421 GC_finalization_proc *foo = NULL;
1423 auto void bigf_finaliser();
1425 auto void bigf_finaliser(void *obj, void *SXE_UNUSED(data))
1427 bigf_fini(bigf_data((Lisp_Bigf*)obj));
1429 memset(obj, 0, sizeof(Lisp_Bigf));
1433 GC_REGISTER_FINALIZER(b, bigf_finaliser, NULL, foo, bar);
1438 bigf_register_finaliser(Lisp_Bigf *SXE_UNUSED(b))
1442 #endif /* HAVE_BDWGC */
1444 /* This function creates a bigfloat with the default precision if the
1445 PRECISION argument is zero. */
1447 make_bigf(fpfloat float_value, unsigned long precision)
1451 ALLOCATE_FIXED_TYPE(bigf, Lisp_Bigf, f);
1452 bigf_register_finaliser(f);
1454 set_lheader_implementation(&f->lheader, &lrecord_bigf);
1455 if (precision == 0UL)
1456 bigf_init(bigf_data(f));
1458 bigf_init_prec(bigf_data(f), precision);
1459 bigf_set_fpfloat(bigf_data(f), float_value);
1460 return wrap_bigf(f);
1463 /* This function creates a bigfloat with the precision of its argument */
1465 make_bigf_bf(bigf float_value)
1469 ALLOCATE_FIXED_TYPE(bigf, Lisp_Bigf, f);
1470 bigf_register_finaliser(f);
1472 set_lheader_implementation(&f->lheader, &lrecord_bigf);
1473 bigf_init_prec(bigf_data(f), bigf_get_prec(float_value));
1474 bigf_set(bigf_data(f), float_value);
1475 return wrap_bigf(f);
1477 #endif /* HAVE_MPF */
1479 /*** Bigfloat with correct rounding ***/
1480 #if defined HAVE_MPFR && defined WITH_MPFR
1481 DECLARE_FIXED_TYPE_ALLOC(bigfr, Lisp_Bigfr);
1482 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_bigfr 250
1484 #if defined HAVE_BDWGC && defined EF_USE_BDWGC && 0
1486 bigfr_register_finaliser(Lisp_Bigfr *b)
1488 GC_finalization_proc *foo = NULL;
1490 auto void bigfr_finaliser();
1492 auto void bigfr_finaliser(void *obj, void *SXE_UNUSED(data))
1494 bigfr_fini(bigfr_data((Lisp_Bigfr*)obj));
1496 memset(obj, 0, sizeof(Lisp_Bigfr));
1500 GC_REGISTER_FINALIZER(b, bigfr_finaliser, NULL, foo, bar);
1505 bigfr_register_finaliser(Lisp_Bigfr *SXE_UNUSED(b))
1509 #endif /* HAVE_BDWGC */
1511 /* This function creates a bigfloat with the default precision if the
1512 PRECISION argument is zero. */
1514 make_bigfr(fpfloat float_value, unsigned long precision)
1518 ALLOCATE_FIXED_TYPE(bigfr, Lisp_Bigfr, f);
1519 set_lheader_implementation(&f->lheader, &lrecord_bigfr);
1520 bigfr_register_finaliser(f);
1522 if (precision == 0UL) {
1523 bigfr_init(bigfr_data(f));
1525 bigfr_init_prec(bigfr_data(f), precision);
1527 bigfr_set_fpfloat(bigfr_data(f), float_value);
1528 return wrap_bigfr(f);
1531 /* This function creates a bigfloat with the precision of its argument */
1533 make_bigfr_bf(bigf float_value)
1537 ALLOCATE_FIXED_TYPE(bigfr, Lisp_Bigfr, f);
1538 set_lheader_implementation(&f->lheader, &lrecord_bigfr);
1539 bigfr_register_finaliser(f);
1541 bigfr_init_prec(bigfr_data(f), bigf_get_prec(float_value));
1542 bigfr_set_bigf(bigfr_data(f), float_value);
1543 return wrap_bigfr(f);
1546 /* This function creates a bigfloat with the precision of its argument */
1548 make_bigfr_bfr(bigfr bfr_value)
1552 if (bigfr_nan_p(bfr_value) || bigfr_inf_p(bfr_value)) {
1553 return make_indef_bfr(bfr_value);
1556 ALLOCATE_FIXED_TYPE(bigfr, Lisp_Bigfr, f);
1557 set_lheader_implementation(&f->lheader, &lrecord_bigfr);
1558 bigfr_register_finaliser(f);
1560 bigfr_init_prec(bigfr_data(f), bigfr_get_prec(bfr_value));
1561 bigfr_set(bigfr_data(f), bfr_value);
1562 return wrap_bigfr(f);
1564 #endif /* HAVE_MPFR */
1566 /*** Big gaussian numbers ***/
1567 #if defined HAVE_PSEUG && defined HAVE_MPZ && defined WITH_PSEUG
1568 DECLARE_FIXED_TYPE_ALLOC(bigg, Lisp_Bigg);
1569 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_bigg 250
1571 #if defined HAVE_BDWGC && defined EF_USE_BDWGC && 0
1573 bigg_register_finaliser(Lisp_Bigg *b)
1575 GC_finalization_proc *foo = NULL;
1577 auto void bigg_finaliser();
1579 auto void bigg_finaliser(void *obj, void *SXE_UNUSED(data))
1581 bigg_fini(bigg_data((Lisp_Bigg*)obj));
1583 memset(obj, 0, sizeof(Lisp_Bigg));
1587 GC_REGISTER_FINALIZER(b, bigg_finaliser, NULL, foo, bar);
1592 bigg_register_finaliser(Lisp_Bigg *SXE_UNUSED(b))
1596 #endif /* HAVE_BDWGC */
1598 /* This function creates a gaussian number. */
1600 make_bigg(long intg, long imag)
1604 ALLOCATE_FIXED_TYPE(bigg, Lisp_Bigg, g);
1605 set_lheader_implementation(&g->lheader, &lrecord_bigg);
1606 bigg_register_finaliser(g);
1608 bigg_init(bigg_data(g));
1609 bigg_set_long_long(bigg_data(g), intg, imag);
1610 return wrap_bigg(g);
1613 /* This function creates a complex with the precision of its argument */
1615 make_bigg_bz(bigz intg, bigz imag)
1619 ALLOCATE_FIXED_TYPE(bigg, Lisp_Bigg, g);
1620 set_lheader_implementation(&g->lheader, &lrecord_bigg);
1621 bigg_register_finaliser(g);
1623 bigg_init(bigg_data(g));
1624 bigg_set_bigz_bigz(bigg_data(g), intg, imag);
1625 return wrap_bigg(g);
1628 /* This function creates a complex with the precision of its argument */
1630 make_bigg_bg(bigg gaussian_value)
1634 ALLOCATE_FIXED_TYPE(bigg, Lisp_Bigg, g);
1635 set_lheader_implementation(&g->lheader, &lrecord_bigg);
1636 bigg_register_finaliser(g);
1638 bigg_init(bigg_data(g));
1639 bigg_set(bigg_data(g), gaussian_value);
1640 return wrap_bigg(g);
1642 #endif /* HAVE_PSEUG */
1644 /*** Big complex numbers with correct rounding ***/
1645 #if defined HAVE_MPC && defined WITH_MPC || \
1646 defined HAVE_PSEUC && defined WITH_PSEUC
1647 DECLARE_FIXED_TYPE_ALLOC(bigc, Lisp_Bigc);
1648 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_bigc 250
1650 #if defined HAVE_BDWGC && defined EF_USE_BDWGC && 0
1652 bigc_register_finaliser(Lisp_Bigc *b)
1654 GC_finalization_proc *foo = NULL;
1656 auto void bigc_finaliser();
1658 auto void bigc_finaliser(void *obj, void *SXE_UNUSED(data))
1660 bigc_fini(bigc_data((Lisp_Bigc*)obj));
1662 memset(obj, 0, sizeof(Lisp_Bigc));
1666 GC_REGISTER_FINALIZER(b, bigc_finaliser, NULL, foo, bar);
1671 bigc_register_finaliser(Lisp_Bigc *SXE_UNUSED(b))
1675 #endif /* HAVE_BDWGC */
1677 /* This function creates a bigfloat with the default precision if the
1678 PRECISION argument is zero. */
1680 make_bigc(fpfloat re_value, fpfloat im_value, unsigned long precision)
1684 ALLOCATE_FIXED_TYPE(bigc, Lisp_Bigc, c);
1685 set_lheader_implementation(&c->lheader, &lrecord_bigc);
1686 bigc_register_finaliser(c);
1688 if (precision == 0UL) {
1689 bigc_init(bigc_data(c));
1691 bigc_init_prec(bigc_data(c), precision);
1693 bigc_set_fpfloat_fpfloat(bigc_data(c), re_value, im_value);
1694 return wrap_bigc(c);
1697 /* This function creates a complex with the precision of its argument */
1699 make_bigc_bfr(bigfr re_value, bigfr im_value, unsigned long precision)
1703 ALLOCATE_FIXED_TYPE(bigc, Lisp_Bigc, c);
1704 set_lheader_implementation(&c->lheader, &lrecord_bigc);
1705 bigc_register_finaliser(c);
1707 if (precision == 0UL) {
1708 bigc_init(bigc_data(c));
1710 bigc_init_prec(bigc_data(c), precision);
1712 bigc_set_bigfr_bigfr(bigc_data(c), re_value, im_value);
1713 return wrap_bigc(c);
1716 /* This function creates a complex with the precision of its argument */
1718 make_bigc_bc(bigc complex_value)
1722 ALLOCATE_FIXED_TYPE(bigc, Lisp_Bigc, c);
1723 set_lheader_implementation(&c->lheader, &lrecord_bigc);
1724 bigc_register_finaliser(c);
1726 bigc_init_prec(bigc_data(c), bigc_get_prec(complex_value));
1727 bigc_set(bigc_data(c), complex_value);
1728 return wrap_bigc(c);
1730 #endif /* HAVE_MPC */
1732 /*** Quaternions ***/
1733 #if defined HAVE_QUATERN && defined HAVE_MPZ && defined WITH_QUATERN
1734 DECLARE_FIXED_TYPE_ALLOC(quatern, Lisp_Quatern);
1735 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_quatern 250
1737 #if defined HAVE_BDWGC && defined EF_USE_BDWGC && 0
1739 quatern_register_finaliser(Lisp_Quatern *b)
1741 GC_finalization_proc *foo = NULL;
1743 auto void quatern_finaliser();
1745 auto void quatern_finaliser(void *obj, void *SXE_UNUSED(data))
1747 quatern_fini(quatern_data((Lisp_Quatern*)obj));
1749 memset(obj, 0, sizeof(Lisp_Quatern));
1753 GC_REGISTER_FINALIZER(b, quatern_finaliser, NULL, foo, bar);
1758 quatern_register_finaliser(Lisp_Quatern *SXE_UNUSED(b))
1762 #endif /* HAVE_BDWGC */
1764 /* This function creates a quaternion. */
1766 make_quatern(EMACS_INT z, EMACS_INT i, EMACS_INT j, EMACS_INT k)
1770 ALLOCATE_FIXED_TYPE(quatern, Lisp_Quatern, g);
1771 set_lheader_implementation(&g->lheader, &lrecord_quatern);
1772 quatern_register_finaliser(g);
1774 quatern_init(quatern_data(g));
1775 quatern_set_long_long_long_long(quatern_data(g), z, i, j, k);
1776 return wrap_quatern(g);
1780 make_quatern_bz(bigz z, bigz i, bigz j, bigz k)
1784 ALLOCATE_FIXED_TYPE(quatern, Lisp_Quatern, g);
1785 set_lheader_implementation(&g->lheader, &lrecord_quatern);
1786 quatern_register_finaliser(g);
1788 quatern_init(quatern_data(g));
1789 quatern_set_bigz_bigz_bigz_bigz(quatern_data(g), z, i, j, k);
1790 return wrap_quatern(g);
1794 make_quatern_qu(quatern quaternion)
1798 ALLOCATE_FIXED_TYPE(quatern, Lisp_Quatern, g);
1799 set_lheader_implementation(&g->lheader, &lrecord_quatern);
1800 quatern_register_finaliser(g);
1802 quatern_init(quatern_data(g));
1803 quatern_set(quatern_data(g), quaternion);
1804 return wrap_quatern(g);
1806 #endif /* HAVE_QUATERN */
1809 make_indef_internal(indef sym)
1813 i = allocate_lisp_storage(sizeof(Lisp_Indef));
1814 set_lheader_implementation(&i->lheader, &lrecord_indef);
1815 indef_data(i) = sym;
1816 return wrap_indef(i);
1820 make_indef(indef sym)
1827 case COMPLEX_INFINITY:
1828 return Vcomplex_infinity;
1831 /* list some more here */
1832 case END_OF_COMPARABLE_INFINITIES:
1833 case END_OF_INFINITIES:
1835 return Vnot_a_number;
1839 #if defined HAVE_MPFR && defined WITH_MPFR
1841 make_indef_bfr(bigfr bfr_value)
1843 if (bigfr_nan_p(bfr_value)) {
1844 return make_indef(NOT_A_NUMBER);
1845 } else if (bigfr_inf_p(bfr_value)) {
1846 if (bigfr_sign(bfr_value) > 0)
1847 return make_indef(POS_INFINITY);
1849 return make_indef(NEG_INFINITY);
1851 return make_indef(NOT_A_NUMBER);
1856 DECLARE_FIXED_TYPE_ALLOC(dynacat, struct dynacat_s);
1857 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_dynacat 1000
1859 #if defined HAVE_BDWGC && defined EF_USE_BDWGC
1861 dynacat_register_finaliser(dynacat_t b)
1863 GC_finalization_proc *foo = NULL;
1865 auto void dynacat_finaliser();
1867 auto void dynacat_finaliser(void *obj, void *SXE_UNUSED(data))
1869 SXE_DEBUG_GC("calling dynacat finaliser on %p\n", obj);
1872 memset(obj, 0, sizeof(struct dynacat_s));
1876 SXE_DEBUG_GC("dynacat-fina %p\n", b);
1877 GC_REGISTER_FINALIZER(b, dynacat_finaliser, NULL, foo, bar);
1882 dynacat_register_finaliser(dynacat_t SXE_UNUSED(b))
1886 #endif /* HAVE_BDWGC */
1889 make_dynacat(void *ptr)
1893 ALLOCATE_FIXED_TYPE(dynacat, struct dynacat_s, emp);
1894 dynacat_register_finaliser(emp);
1895 set_lheader_implementation(&emp->lheader, &lrecord_dynacat);
1898 emp->intprfun = NULL;
1905 return wrap_object(emp);
1909 /************************************************************************/
1910 /* Vector allocation */
1911 /************************************************************************/
1913 static Lisp_Object mark_vector(Lisp_Object obj)
1915 Lisp_Vector *ptr = XVECTOR(obj);
1916 int len = vector_length(ptr);
1919 for (i = 0; i < len - 1; i++)
1920 mark_object(ptr->contents[i]);
1921 return (len > 0) ? ptr->contents[len - 1] : Qnil;
1924 static size_t size_vector(const void *lheader)
1926 return FLEXIBLE_ARRAY_STRUCT_SIZEOF(
1927 Lisp_Vector, Lisp_Object, contents,
1928 ((const Lisp_Vector*)lheader)->size);
1931 static int vector_equal(Lisp_Object obj1, Lisp_Object obj2, int depth)
1933 int len = XVECTOR_LENGTH(obj1);
1934 if (len != XVECTOR_LENGTH(obj2))
1938 Lisp_Object *ptr1 = XVECTOR_DATA(obj1);
1939 Lisp_Object *ptr2 = XVECTOR_DATA(obj2);
1941 if (!internal_equal(*ptr1++, *ptr2++, depth + 1))
1947 static hcode_t vector_hash(Lisp_Object obj, int depth)
1949 return HASH2(XVECTOR_LENGTH(obj),
1950 internal_array_hash(XVECTOR_DATA(obj),
1951 XVECTOR_LENGTH(obj), depth + 1));
1954 /* the seq approach for conses */
1956 vec_length(const seq_t v)
1958 return XVECTOR_LENGTH((Lisp_Object)(long int)v);
1962 vec_iter_init(seq_t v, seq_iter_t si)
1965 si->data = (void*)0;
1970 vec_iter_next(seq_iter_t si, void **elt)
1972 if (si->seq != NULL &&
1973 (long int)si->data < ((Lisp_Vector*)si->seq)->size) {
1974 *elt = (void*)vector_data((Lisp_Vector*)si->seq)
1975 [(long int)si->data];
1976 si->data = (void*)((long int)si->data + 1L);
1984 vec_iter_fini(seq_iter_t si)
1986 si->data = si->seq = NULL;
1991 vec_iter_reset(seq_iter_t si)
1993 si->data = (void*)0;
1998 vec_explode(void *restrict tgt[], size_t ntgt, const seq_t s)
2000 size_t len = vector_length((const Lisp_Vector*)s);
2001 volatile size_t i = 0;
2003 while (i < len && i < ntgt) {
2004 tgt[i] = (void*)vector_data((const Lisp_Vector*)s)[i];
2010 static struct seq_impl_s __svec = {
2011 .length_f = vec_length,
2012 .iter_init_f = vec_iter_init,
2013 .iter_next_f = vec_iter_next,
2014 .iter_fini_f = vec_iter_fini,
2015 .iter_reset_f = vec_iter_reset,
2016 .explode_f = vec_explode,
2019 static const struct lrecord_description vector_description[] = {
2020 {XD_LONG, offsetof(Lisp_Vector, size)},
2021 {XD_LISP_OBJECT_ARRAY, offsetof(Lisp_Vector, contents),
2026 DEFINE_LRECORD_SEQUENCE_IMPLEMENTATION("vector", vector,
2027 mark_vector, print_vector, 0,
2031 size_vector, Lisp_Vector);
2033 /* #### should allocate `small' vectors from a frob-block */
2034 static Lisp_Vector *make_vector_internal(size_t sizei)
2036 /* no vector_next */
2037 size_t sizem = FLEXIBLE_ARRAY_STRUCT_SIZEOF(Lisp_Vector, Lisp_Object,
2039 Lisp_Vector *p = (Lisp_Vector *) alloc_lcrecord(sizem, &lrecord_vector);
2042 p->header.lheader.morphisms = (1<<cat_mk_lc);
2046 Lisp_Object make_vector(size_t length, Lisp_Object object)
2048 Lisp_Vector *vecp = make_vector_internal(length);
2049 Lisp_Object *p = vector_data(vecp);
2056 XSETVECTOR(vector, vecp);
2061 DEFUN("make-vector", Fmake_vector, 2, 2, 0, /*
2062 Return a new vector of length LENGTH, with each element being OBJECT.
2063 See also the function `vector'.
2067 CONCHECK_NATNUM(length);
2068 return make_vector(XINT(length), object);
2071 DEFUN("vector", Fvector, 0, MANY, 0, /*
2072 Return a newly created vector with specified arguments as elements.
2073 Any number of arguments, even zero arguments, are allowed.
2075 (int nargs, Lisp_Object * args))
2077 Lisp_Vector *vecp = make_vector_internal(nargs);
2078 Lisp_Object *p = vector_data(vecp);
2085 XSETVECTOR(vector, vecp);
2090 Lisp_Object vector1(Lisp_Object obj0)
2092 return Fvector(1, &obj0);
2095 Lisp_Object vector2(Lisp_Object obj0, Lisp_Object obj1)
2097 Lisp_Object args[2];
2100 return Fvector(2, args);
2103 Lisp_Object vector3(Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2)
2105 Lisp_Object args[3];
2109 return Fvector(3, args);
2112 #if 0 /* currently unused */
2115 vector4(Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2, Lisp_Object obj3)
2117 Lisp_Object args[4];
2122 return Fvector(4, args);
2126 vector5(Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
2127 Lisp_Object obj3, Lisp_Object obj4)
2129 Lisp_Object args[5];
2135 return Fvector(5, args);
2139 vector6(Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
2140 Lisp_Object obj3, Lisp_Object obj4, Lisp_Object obj5)
2142 Lisp_Object args[6];
2149 return Fvector(6, args);
2153 vector7(Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
2154 Lisp_Object obj3, Lisp_Object obj4, Lisp_Object obj5, Lisp_Object obj6)
2156 Lisp_Object args[7];
2164 return Fvector(7, args);
2168 vector8(Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
2169 Lisp_Object obj3, Lisp_Object obj4, Lisp_Object obj5,
2170 Lisp_Object obj6, Lisp_Object obj7)
2172 Lisp_Object args[8];
2181 return Fvector(8, args);
2185 /************************************************************************/
2186 /* Bit Vector allocation */
2187 /************************************************************************/
2189 static Lisp_Object all_bit_vectors;
2191 /* #### should allocate `small' bit vectors from a frob-block */
2192 static Lisp_Bit_Vector *make_bit_vector_internal(size_t sizei)
2194 size_t num_longs = BIT_VECTOR_LONG_STORAGE(sizei);
2196 FLEXIBLE_ARRAY_STRUCT_SIZEOF(Lisp_Bit_Vector, unsigned long,
2198 Lisp_Bit_Vector *p = (Lisp_Bit_Vector *) allocate_lisp_storage(sizem);
2199 set_lheader_implementation(&p->lheader, &lrecord_bit_vector);
2201 INCREMENT_CONS_COUNTER(sizem, "bit-vector");
2203 bit_vector_length(p) = sizei;
2204 bit_vector_next(p) = all_bit_vectors;
2205 /* make sure the extra bits in the last long are 0; the calling
2206 functions might not set them. */
2207 p->bits[num_longs - 1] = 0;
2208 XSETBIT_VECTOR(all_bit_vectors, p);
2210 /* propagate seq implementation */
2211 p->lheader.morphisms = 0;
2215 Lisp_Object make_bit_vector(size_t length, Lisp_Object bit)
2217 Lisp_Bit_Vector *p = make_bit_vector_internal(length);
2218 size_t num_longs = BIT_VECTOR_LONG_STORAGE(length);
2223 memset(p->bits, 0, num_longs * sizeof(long));
2225 size_t bits_in_last = length & (LONGBITS_POWER_OF_2 - 1);
2226 memset(p->bits, ~0, num_longs * sizeof(long));
2227 /* But we have to make sure that the unused bits in the
2228 last long are 0, so that equal/hash is easy. */
2230 p->bits[num_longs - 1] &= (1 << bits_in_last) - 1;
2234 Lisp_Object bit_vector;
2235 XSETBIT_VECTOR(bit_vector, p);
2241 make_bit_vector_from_byte_vector(unsigned char *bytevec, size_t length)
2244 Lisp_Bit_Vector *p = make_bit_vector_internal(length);
2246 for (i = 0; i < length; i++)
2247 set_bit_vector_bit(p, i, bytevec[i]);
2250 Lisp_Object bit_vector;
2251 XSETBIT_VECTOR(bit_vector, p);
2256 DEFUN("make-bit-vector", Fmake_bit_vector, 2, 2, 0, /*
2257 Return a new bit vector of length LENGTH. with each bit set to BIT.
2258 BIT must be one of the integers 0 or 1. See also the function `bit-vector'.
2262 CONCHECK_NATNUM(length);
2264 return make_bit_vector(XINT(length), bit);
2267 DEFUN("bit-vector", Fbit_vector, 0, MANY, 0, /*
2268 Return a newly created bit vector with specified arguments as elements.
2269 Any number of arguments, even zero arguments, are allowed.
2270 Each argument must be one of the integers 0 or 1.
2272 (int nargs, Lisp_Object * args))
2275 Lisp_Bit_Vector *p = make_bit_vector_internal(nargs);
2277 for (i = 0; i < nargs; i++) {
2279 set_bit_vector_bit(p, i, !ZEROP(args[i]));
2283 Lisp_Object bit_vector;
2284 XSETBIT_VECTOR(bit_vector, p);
2289 /* the seq approach for conses */
2291 bvc_length(const seq_t bv)
2293 return bit_vector_length(XBIT_VECTOR((Lisp_Object)(long int)bv));
2297 bvc_iter_init(seq_t bv, seq_iter_t si)
2300 si->data = (void*)0;
2305 bvc_iter_next(seq_iter_t si, void **elt)
2307 if (si->seq != NULL &&
2308 (long int)si->data < bit_vector_length((Lisp_Bit_Vector*)si->seq)) {
2309 *elt = (void*)make_int(
2311 (Lisp_Bit_Vector*)si->seq, (size_t)si->data));
2312 si->data = (void*)((long int)si->data + 1L);
2320 bvc_iter_fini(seq_iter_t si)
2322 si->data = si->seq = NULL;
2327 bvc_iter_reset(seq_iter_t si)
2329 si->data = (void*)0;
2334 bvc_explode(void *restrict tgt[], size_t ntgt, const seq_t s)
2336 size_t len = bit_vector_length((const Lisp_Bit_Vector*)s);
2337 volatile size_t i = 0;
2339 while (i < len && i < ntgt) {
2340 tgt[i] = (void*)make_int(
2341 bit_vector_bit((const Lisp_Bit_Vector*)s, i));
2347 static struct seq_impl_s __sbvc = {
2348 .length_f = bvc_length,
2349 .iter_init_f = bvc_iter_init,
2350 .iter_next_f = bvc_iter_next,
2351 .iter_fini_f = bvc_iter_fini,
2352 .iter_reset_f = bvc_iter_reset,
2353 .explode_f = bvc_explode,
2356 /************************************************************************/
2357 /* Compiled-function allocation */
2358 /************************************************************************/
2360 DECLARE_FIXED_TYPE_ALLOC(compiled_function, Lisp_Compiled_Function);
2361 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_compiled_function 1000
2363 static Lisp_Object make_compiled_function(void)
2365 Lisp_Compiled_Function *f;
2368 ALLOCATE_FIXED_TYPE(compiled_function, Lisp_Compiled_Function, f);
2369 set_lheader_implementation(&f->lheader, &lrecord_compiled_function);
2372 f->specpdl_depth = 0;
2373 f->flags.documentationp = 0;
2374 f->flags.interactivep = 0;
2375 f->flags.domainp = 0; /* I18N3 */
2376 f->instructions = Qzero;
2377 f->constants = Qzero;
2379 f->doc_and_interactive = Qnil;
2380 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
2381 f->annotated = Qnil;
2383 XSETCOMPILED_FUNCTION(fun, f);
2387 DEFUN("make-byte-code", Fmake_byte_code, 4, MANY, 0, /*
2388 Return a new compiled-function object.
2389 Usage: (arglist instructions constants stack-depth
2390 &optional doc-string interactive)
2391 Note that, unlike all other emacs-lisp functions, calling this with five
2392 arguments is NOT the same as calling it with six arguments, the last of
2393 which is nil. If the INTERACTIVE arg is specified as nil, then that means
2394 that this function was defined with `(interactive)'. If the arg is not
2395 specified, then that means the function is not interactive.
2396 This is terrible behavior which is retained for compatibility with old
2397 `.elc' files which expect these semantics.
2399 (int nargs, Lisp_Object * args))
2401 /* In a non-insane world this function would have this arglist...
2402 (arglist instructions constants stack_depth &optional doc_string interactive)
2404 Lisp_Object fun = make_compiled_function();
2405 Lisp_Compiled_Function *f = XCOMPILED_FUNCTION(fun);
2407 Lisp_Object arglist = args[0];
2408 Lisp_Object instructions = args[1];
2409 Lisp_Object constants = args[2];
2410 Lisp_Object stack_depth = args[3];
2411 Lisp_Object doc_string = (nargs > 4) ? args[4] : Qnil;
2412 Lisp_Object interactive = (nargs > 5) ? args[5] : Qunbound;
2414 if (nargs < 4 || nargs > 6)
2415 return Fsignal(Qwrong_number_of_arguments,
2416 list2(intern("make-byte-code"),
2419 /* Check for valid formal parameter list now, to allow us to use
2420 SPECBIND_FAST_UNSAFE() later in funcall_compiled_function(). */
2422 EXTERNAL_LIST_LOOP_3(symbol, arglist, tail) {
2423 CHECK_SYMBOL(symbol);
2424 if (EQ(symbol, Qt) ||
2425 EQ(symbol, Qnil) || SYMBOL_IS_KEYWORD(symbol))
2426 signal_simple_error_2
2427 ("Invalid constant symbol in formal parameter list",
2431 f->arglist = arglist;
2433 /* `instructions' is a string or a cons (string . int) for a
2434 lazy-loaded function. */
2435 if (CONSP(instructions)) {
2436 CHECK_STRING(XCAR(instructions));
2437 CHECK_INT(XCDR(instructions));
2439 CHECK_STRING(instructions);
2441 f->instructions = instructions;
2443 if (!NILP(constants))
2444 CHECK_VECTOR(constants);
2445 f->constants = constants;
2447 CHECK_NATNUM(stack_depth);
2448 f->stack_depth = (unsigned short)XINT(stack_depth);
2450 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
2451 if (!NILP(Vcurrent_compiled_function_annotation))
2452 f->annotated = Fcopy(Vcurrent_compiled_function_annotation);
2453 else if (!NILP(Vload_file_name_internal_the_purecopy))
2454 f->annotated = Vload_file_name_internal_the_purecopy;
2455 else if (!NILP(Vload_file_name_internal)) {
2456 struct gcpro gcpro1;
2457 GCPRO1(fun); /* don't let fun get reaped */
2458 Vload_file_name_internal_the_purecopy =
2459 Ffile_name_nondirectory(Vload_file_name_internal);
2460 f->annotated = Vload_file_name_internal_the_purecopy;
2463 #endif /* COMPILED_FUNCTION_ANNOTATION_HACK */
2465 /* doc_string may be nil, string, int, or a cons (string . int).
2466 interactive may be list or string (or unbound). */
2467 f->doc_and_interactive = Qunbound;
2469 if ((f->flags.domainp = !NILP(Vfile_domain)) != 0)
2470 f->doc_and_interactive = Vfile_domain;
2472 if ((f->flags.interactivep = !UNBOUNDP(interactive)) != 0) {
2473 f->doc_and_interactive
2474 = (UNBOUNDP(f->doc_and_interactive) ? interactive :
2475 Fcons(interactive, f->doc_and_interactive));
2477 if ((f->flags.documentationp = !NILP(doc_string)) != 0) {
2478 f->doc_and_interactive
2479 = (UNBOUNDP(f->doc_and_interactive) ? doc_string :
2480 Fcons(doc_string, f->doc_and_interactive));
2482 if (UNBOUNDP(f->doc_and_interactive))
2483 f->doc_and_interactive = Qnil;
2488 /************************************************************************/
2489 /* Symbol allocation */
2490 /************************************************************************/
2492 DECLARE_FIXED_TYPE_ALLOC(symbol, Lisp_Symbol);
2493 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_symbol 1000
2495 DEFUN("make-symbol", Fmake_symbol, 1, 1, 0, /*
2496 Return a newly allocated uninterned symbol whose name is NAME.
2497 Its value and function definition are void, and its property list is nil.
2506 ALLOCATE_FIXED_TYPE(symbol, Lisp_Symbol, p);
2507 set_lheader_implementation(&p->lheader, &lrecord_symbol);
2508 p->name = XSTRING(name);
2510 p->value = Qunbound;
2511 p->function = Qunbound;
2517 /************************************************************************/
2518 /* Extent allocation */
2519 /************************************************************************/
2521 DECLARE_FIXED_TYPE_ALLOC(extent, struct extent);
2522 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_extent 1000
2524 struct extent *allocate_extent(void)
2528 ALLOCATE_FIXED_TYPE(extent, struct extent, e);
2529 set_lheader_implementation(&e->lheader, &lrecord_extent);
2530 extent_object(e) = Qnil;
2531 set_extent_start(e, -1);
2532 set_extent_end(e, -1);
2537 extent_face(e) = Qnil;
2538 e->flags.end_open = 1; /* default is for endpoints to behave like markers */
2539 e->flags.detachable = 1;
2544 /************************************************************************/
2545 /* Event allocation */
2546 /************************************************************************/
2548 DECLARE_FIXED_TYPE_ALLOC(event, Lisp_Event);
2549 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_event 1000
2551 Lisp_Object allocate_event(void)
2556 ALLOCATE_FIXED_TYPE(event, Lisp_Event, e);
2557 set_lheader_implementation(&e->lheader, &lrecord_event);
2563 /************************************************************************/
2564 /* Marker allocation */
2565 /************************************************************************/
2567 DECLARE_FIXED_TYPE_ALLOC(marker, Lisp_Marker);
2568 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_marker 1000
2570 DEFUN("make-marker", Fmake_marker, 0, 0, 0, /*
2571 Return a new marker which does not point at any place.
2578 ALLOCATE_FIXED_TYPE(marker, Lisp_Marker, p);
2579 set_lheader_implementation(&p->lheader, &lrecord_marker);
2584 p->insertion_type = 0;
2589 Lisp_Object noseeum_make_marker(void)
2594 NOSEEUM_ALLOCATE_FIXED_TYPE(marker, Lisp_Marker, p);
2595 set_lheader_implementation(&p->lheader, &lrecord_marker);
2600 p->insertion_type = 0;
2605 /************************************************************************/
2606 /* String allocation */
2607 /************************************************************************/
2609 /* The data for "short" strings generally resides inside of structs of type
2610 string_chars_block. The Lisp_String structure is allocated just like any
2611 other Lisp object (except for vectors), and these are freelisted when
2612 they get garbage collected. The data for short strings get compacted,
2613 but the data for large strings do not.
2615 Previously Lisp_String structures were relocated, but this caused a lot
2616 of bus-errors because the C code didn't include enough GCPRO's for
2617 strings (since EVERY REFERENCE to a short string needed to be GCPRO'd so
2618 that the reference would get relocated).
2620 This new method makes things somewhat bigger, but it is MUCH safer. */
2622 DECLARE_FIXED_TYPE_ALLOC(string, Lisp_String);
2623 /* strings are used and freed quite often */
2624 /* #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_string 10000 */
2625 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_string 1000
2627 #if defined HAVE_BDWGC && defined EF_USE_BDWGC && 0
2629 string_register_finaliser(Lisp_String *s)
2631 GC_finalization_proc *foo = NULL;
2633 auto void string_finaliser();
2635 auto void string_finaliser(void *obj, void *SXE_UNUSED(data))
2637 if (!(((Lisp_String*)obj)->lheader.c_readonly)) {
2638 yfree(((Lisp_String*)obj)->data);
2641 memset(obj, 0, sizeof(Lisp_String));
2645 SXE_DEBUG_GC("string-fina %p\n", s);
2646 GC_REGISTER_FINALIZER(s, string_finaliser, NULL, foo, bar);
2651 string_register_finaliser(Lisp_String *SXE_UNUSED(b))
2655 #endif /* HAVE_BDWGC */
2657 static Lisp_Object mark_string(Lisp_Object obj)
2659 Lisp_String *ptr = XSTRING(obj);
2661 if (CONSP(ptr->plist) && EXTENT_INFOP(XCAR(ptr->plist)))
2662 flush_cached_extent_info(XCAR(ptr->plist));
2663 #ifdef EF_USE_COMPRE
2664 mark_object(ptr->compre);
2669 static int string_equal(Lisp_Object obj1, Lisp_Object obj2, int depth)
2672 return (((len = XSTRING_LENGTH(obj1)) == XSTRING_LENGTH(obj2)) &&
2673 !memcmp(XSTRING_DATA(obj1), XSTRING_DATA(obj2), len));
2676 static const struct lrecord_description string_description[] = {
2677 {XD_BYTECOUNT, offsetof(Lisp_String, size)},
2678 {XD_OPAQUE_DATA_PTR, offsetof(Lisp_String, data), XD_INDIRECT(0, 1)},
2679 #ifdef EF_USE_COMPRE
2680 {XD_LISP_OBJECT, offsetof(Lisp_String, compre)},
2682 {XD_LISP_OBJECT, offsetof(Lisp_String, plist)},
2686 /* the seq implementation */
2688 str_length(const seq_t str)
2690 return string_char_length((const Lisp_String*)str);
2694 str_iter_init(seq_t str, seq_iter_t si)
2697 si->data = (void*)0;
2702 str_iter_next(seq_iter_t si, void **elt)
2704 if (si->seq != NULL &&
2705 (long int)si->data < string_char_length((Lisp_String*)si->seq)) {
2706 *elt = (void*)make_char(
2707 string_char((Lisp_String*)si->seq, (long int)si->data));
2708 si->data = (void*)((long int)si->data + 1);
2716 str_iter_fini(seq_iter_t si)
2718 si->data = si->seq = NULL;
2723 str_iter_reset(seq_iter_t si)
2725 si->data = (void*)0;
2730 str_explode(void *restrict tgt[], size_t ntgt, const seq_t s)
2732 size_t len = string_char_length((const Lisp_String*)s);
2733 volatile size_t i = 0;
2735 while (i < len && i < ntgt) {
2736 tgt[i] = (void*)make_char(string_char((Lisp_String*)s, i));
2742 static struct seq_impl_s __sstr = {
2743 .length_f = str_length,
2744 .iter_init_f = str_iter_init,
2745 .iter_next_f = str_iter_next,
2746 .iter_fini_f = str_iter_fini,
2747 .iter_reset_f = str_iter_reset,
2748 .explode_f = str_explode,
2752 /* We store the string's extent info as the first element of the string's
2753 property list; and the string's MODIFF as the first or second element
2754 of the string's property list (depending on whether the extent info
2755 is present), but only if the string has been modified. This is ugly
2756 but it reduces the memory allocated for the string in the vast
2757 majority of cases, where the string is never modified and has no
2760 #### This means you can't use an int as a key in a string's plist. */
2762 static Lisp_Object *string_plist_ptr(Lisp_Object string)
2764 Lisp_Object *ptr = &XSTRING(string)->plist;
2766 if (CONSP(*ptr) && EXTENT_INFOP(XCAR(*ptr)))
2768 if (CONSP(*ptr) && INTP(XCAR(*ptr)))
2773 static Lisp_Object string_getprop(Lisp_Object string, Lisp_Object property)
2775 return external_plist_get(string_plist_ptr(string), property, 0,
2780 string_putprop(Lisp_Object string, Lisp_Object property, Lisp_Object value)
2782 external_plist_put(string_plist_ptr(string), property, value, 0,
2787 static int string_remprop(Lisp_Object string, Lisp_Object property)
2789 return external_remprop(string_plist_ptr(string), property, 0,
2793 static Lisp_Object string_plist(Lisp_Object string)
2795 return *string_plist_ptr(string);
2798 /* No `finalize', or `hash' methods.
2799 internal_hash() already knows how to hash strings and finalization
2800 is done with the ADDITIONAL_FREE_string macro, which is the
2801 standard way to do finalization when using
2802 SWEEP_FIXED_TYPE_BLOCK(). */
2803 DEFINE_BASIC_LRECORD_IMPLEMENTATION_WITH_PROPS("string", string,
2804 mark_string, print_string,
2810 string_plist, Lisp_String);
2812 #if !defined HAVE_BDWGC || !defined EF_USE_BDWGC
2813 /* String blocks contain this many useful bytes. */
2814 #define STRING_CHARS_BLOCK_SIZE \
2815 ((Bytecount) (8192 - MALLOC_OVERHEAD - \
2816 ((2 * sizeof (struct string_chars_block *)) \
2817 + sizeof (EMACS_INT))))
2818 /* Block header for small strings. */
2819 struct string_chars_block {
2821 struct string_chars_block *next;
2822 struct string_chars_block *prev;
2823 /* Contents of string_chars_block->string_chars are interleaved
2824 string_chars structures (see below) and the actual string data */
2825 unsigned char string_chars[STRING_CHARS_BLOCK_SIZE];
2828 static struct string_chars_block *first_string_chars_block;
2829 static struct string_chars_block *current_string_chars_block;
2831 /* If SIZE is the length of a string, this returns how many bytes
2832 * the string occupies in string_chars_block->string_chars
2833 * (including alignment padding).
2835 #define STRING_FULLSIZE(size) \
2836 ALIGN_SIZE(((size) + 1 + sizeof(Lisp_String*)), ALIGNOF(Lisp_String*))
2838 #define BIG_STRING_FULLSIZE_P(fullsize) ((fullsize) >= STRING_CHARS_BLOCK_SIZE)
2839 #define BIG_STRING_SIZE_P(size) (BIG_STRING_FULLSIZE_P (STRING_FULLSIZE(size)))
2841 #define STRING_CHARS_FREE_P(ptr) ((ptr)->string == NULL)
2842 #define MARK_STRING_CHARS_AS_FREE(ptr) ((void) ((ptr)->string = NULL))
2844 struct string_chars {
2845 Lisp_String *string;
2846 unsigned char chars[1];
2849 struct unused_string_chars {
2850 Lisp_String *string;
2854 static void init_string_chars_alloc(void)
2856 first_string_chars_block = ynew(struct string_chars_block);
2857 first_string_chars_block->prev = 0;
2858 first_string_chars_block->next = 0;
2859 first_string_chars_block->pos = 0;
2860 current_string_chars_block = first_string_chars_block;
2863 static struct string_chars*
2864 allocate_string_chars_struct(Lisp_String *string_it_goes_with,
2867 struct string_chars *s_chars;
2869 if (fullsize <= (countof(current_string_chars_block->string_chars)
2870 - current_string_chars_block->pos)) {
2871 /* This string can fit in the current string chars block */
2872 s_chars = (struct string_chars *)
2873 (current_string_chars_block->string_chars
2874 + current_string_chars_block->pos);
2875 current_string_chars_block->pos += fullsize;
2877 /* Make a new current string chars block */
2878 struct string_chars_block *new_scb =
2879 ynew(struct string_chars_block);
2881 current_string_chars_block->next = new_scb;
2882 new_scb->prev = current_string_chars_block;
2884 current_string_chars_block = new_scb;
2885 new_scb->pos = fullsize;
2886 s_chars = (struct string_chars *)
2887 current_string_chars_block->string_chars;
2890 s_chars->string = string_it_goes_with;
2892 INCREMENT_CONS_COUNTER(fullsize, "string chars");
2898 Lisp_Object make_uninit_string(Bytecount length)
2900 Lisp_String *s = NULL;
2901 #if !defined HAVE_BDWGC || !defined EF_USE_BDWGC
2902 EMACS_INT fullsize = STRING_FULLSIZE(length);
2906 #if !defined HAVE_BDWGC || !defined EF_USE_BDWGC
2907 assert(length >= 0 && fullsize > 0);
2910 /* Allocate the string header */
2911 ALLOCATE_FIXED_TYPE(string, Lisp_String, s);
2912 set_lheader_implementation(&s->lheader, &lrecord_string);
2913 string_register_finaliser(s);
2916 Bufbyte *foo = NULL;
2917 #if defined HAVE_BDWGC && defined EF_USE_BDWGC
2918 foo = xnew_atomic_array(Bufbyte, length+1);
2919 assert(foo != NULL);
2921 if (BIG_STRING_FULLSIZE_P(fullsize)) {
2922 foo = xnew_atomic_array(Bufbyte, length + 1);
2923 assert(foo != NULL);
2925 foo = allocate_string_chars_struct(s, fullsize)->chars;
2926 assert(foo != NULL);
2929 set_string_data(s, foo);
2931 set_string_length(s, length);
2933 #ifdef EF_USE_COMPRE
2936 /* propagate the cat system, go with the standard impl of a seq first */
2937 s->lheader.morphisms = 0;
2939 set_string_byte(s, length, 0);
2945 #ifdef VERIFY_STRING_CHARS_INTEGRITY
2946 static void verify_string_chars_integrity(void);
2949 /* Resize the string S so that DELTA bytes can be inserted starting
2950 at POS. If DELTA < 0, it means deletion starting at POS. If
2951 POS < 0, resize the string but don't copy any characters. Use
2952 this if you're planning on completely overwriting the string.
2955 #if defined HAVE_BDWGC && defined EF_USE_BDWGC
2956 void resize_string(Lisp_String * s, Bytecount pos, Bytecount delta)
2961 /* trivial cases first */
2963 /* simplest case: no size change. */
2967 if (pos >= 0 && delta < 0) {
2968 /* If DELTA < 0, the functions below will delete the characters
2969 before POS. We want to delete characters *after* POS,
2970 however, so convert this to the appropriate form. */
2974 /* Both strings are big. We can just realloc().
2975 But careful! If the string is shrinking, we have to
2976 memmove() _before_ realloc(), and if growing, we have to
2977 memmove() _after_ realloc() - otherwise the access is
2978 illegal, and we might crash. */
2979 len = string_length(s) + 1 - pos;
2981 if (delta < 0 && pos >= 0) {
2982 memmove(string_data(s) + pos + delta,
2983 string_data(s) + pos, len);
2986 /* do the reallocation */
2987 foo = xrealloc(string_data(s), string_length(s) + delta + 1);
2988 set_string_data(s, foo);
2990 if (delta > 0 && pos >= 0) {
2991 memmove(string_data(s) + pos + delta,
2992 string_data(s) + pos, len);
2995 set_string_length(s, string_length(s) + delta);
2996 /* If pos < 0, the string won't be zero-terminated.
2997 Terminate now just to make sure. */
2998 string_data(s)[string_length(s)] = '\0';
3003 XSETSTRING(string, s);
3004 /* We also have to adjust all of the extent indices after the
3005 place we did the change. We say "pos - 1" because
3006 adjust_extents() is exclusive of the starting position
3008 adjust_extents(string, pos - 1, string_length(s), delta);
3012 #else /* !HAVE_BDWGC */
3013 void resize_string(Lisp_String * s, Bytecount pos, Bytecount delta)
3015 Bytecount oldfullsize, newfullsize;
3016 #ifdef VERIFY_STRING_CHARS_INTEGRITY
3017 verify_string_chars_integrity();
3020 #ifdef ERROR_CHECK_BUFPOS
3022 assert(pos <= string_length(s));
3024 assert(pos + (-delta) <= string_length(s));
3027 assert((-delta) <= string_length(s));
3029 #endif /* ERROR_CHECK_BUFPOS */
3032 /* simplest case: no size change. */
3035 if (pos >= 0 && delta < 0)
3036 /* If DELTA < 0, the functions below will delete the characters
3037 before POS. We want to delete characters *after* POS, however,
3038 so convert this to the appropriate form. */
3041 oldfullsize = STRING_FULLSIZE(string_length(s));
3042 newfullsize = STRING_FULLSIZE(string_length(s) + delta);
3044 if (BIG_STRING_FULLSIZE_P(oldfullsize)) {
3045 if (BIG_STRING_FULLSIZE_P(newfullsize)) {
3046 /* Both strings are big. We can just realloc().
3047 But careful! If the string is shrinking, we have to
3048 memmove() _before_ realloc(), and if growing, we have to
3049 memmove() _after_ realloc() - otherwise the access is
3050 illegal, and we might crash. */
3051 Bytecount len = string_length(s) + 1 - pos;
3054 if (delta < 0 && pos >= 0)
3055 memmove(string_data(s) + pos + delta,
3056 string_data(s) + pos, len);
3058 foo = xrealloc(string_data(s),
3059 string_length(s) + delta + 1);
3060 set_string_data(s, foo);
3061 if (delta > 0 && pos >= 0) {
3062 memmove(string_data(s) + pos + delta,
3063 string_data(s) + pos, len);
3066 /* String has been demoted from BIG_STRING. */
3069 allocate_string_chars_struct(s, newfullsize)
3071 Bufbyte *old_data = string_data(s);
3074 memcpy(new_data, old_data, pos);
3075 memcpy(new_data + pos + delta, old_data + pos,
3076 string_length(s) + 1 - pos);
3078 set_string_data(s, new_data);
3081 } else { /* old string is small */
3083 if (oldfullsize == newfullsize) {
3084 /* special case; size change but the necessary
3085 allocation size won't change (up or down; code
3086 somewhere depends on there not being any unused
3087 allocation space, modulo any alignment
3090 Bufbyte *addroff = pos + string_data(s);
3092 memmove(addroff + delta, addroff,
3093 /* +1 due to zero-termination. */
3094 string_length(s) + 1 - pos);
3097 Bufbyte *old_data = string_data(s);
3098 Bufbyte *new_data = BIG_STRING_FULLSIZE_P(newfullsize)
3099 ? xnew_atomic_array(
3100 Bufbyte, string_length(s) + delta + 1)
3101 : allocate_string_chars_struct(
3102 s, newfullsize)->chars;
3105 memcpy(new_data, old_data, pos);
3106 memcpy(new_data + pos + delta, old_data + pos,
3107 string_length(s) + 1 - pos);
3109 set_string_data(s, new_data);
3112 /* We need to mark this chunk of the
3113 string_chars_block as unused so that
3114 compact_string_chars() doesn't freak. */
3115 struct string_chars *old_s_chars =
3116 (struct string_chars *)
3118 offsetof(struct string_chars, chars));
3119 /* Sanity check to make sure we aren't hosed by
3120 strange alignment/padding. */
3121 assert(old_s_chars->string == s);
3122 MARK_STRING_CHARS_AS_FREE(old_s_chars);
3123 ((struct unused_string_chars *)old_s_chars)->
3124 fullsize = oldfullsize;
3129 set_string_length(s, string_length(s) + delta);
3130 /* If pos < 0, the string won't be zero-terminated.
3131 Terminate now just to make sure. */
3132 string_data(s)[string_length(s)] = '\0';
3137 XSETSTRING(string, s);
3138 /* We also have to adjust all of the extent indices after the
3139 place we did the change. We say "pos - 1" because
3140 adjust_extents() is exclusive of the starting position
3142 adjust_extents(string, pos - 1, string_length(s), delta);
3144 #ifdef VERIFY_STRING_CHARS_INTEGRITY
3145 verify_string_chars_integrity();
3151 void set_string_char(Lisp_String * s, Charcount i, Emchar c)
3153 Bufbyte newstr[MAX_EMCHAR_LEN];
3154 Bytecount bytoff = charcount_to_bytecount(string_data(s), i);
3155 Bytecount oldlen = charcount_to_bytecount(string_data(s) + bytoff, 1);
3156 Bytecount newlen = set_charptr_emchar(newstr, c);
3158 if (oldlen != newlen) {
3159 resize_string(s, bytoff, newlen - oldlen);
3161 /* Remember, string_data (s) might have changed so we can't cache it. */
3162 memcpy(string_data(s) + bytoff, newstr, newlen);
3167 DEFUN("make-string", Fmake_string, 2, 2, 0, /*
3168 Return a new string consisting of LENGTH copies of CHARACTER.
3169 LENGTH must be a non-negative integer.
3171 (length, character))
3173 CHECK_NATNUM(length);
3174 CHECK_CHAR_COERCE_INT(character);
3176 Bufbyte init_str[MAX_EMCHAR_LEN];
3177 int len = set_charptr_emchar(init_str, XCHAR(character));
3178 Lisp_Object val = make_uninit_string(len * XINT(length));
3181 /* Optimize the single-byte case */
3182 memset(XSTRING_DATA(val), XCHAR(character),
3183 XSTRING_LENGTH(val));
3186 Bufbyte *ptr = XSTRING_DATA(val);
3188 for (i = XINT(length); i; i--) {
3189 Bufbyte *init_ptr = init_str;
3192 *ptr++ = *init_ptr++;
3194 *ptr++ = *init_ptr++;
3196 *ptr++ = *init_ptr++;
3198 *ptr++ = *init_ptr++;
3208 DEFUN("string", Fstring, 0, MANY, 0, /*
3209 Concatenate all the argument characters and make the result a string.
3211 (int nargs, Lisp_Object * args))
3213 Bufbyte *storage, *p;
3215 int speccount = specpdl_depth();
3216 int len = nargs * MAX_EMCHAR_LEN;
3218 XMALLOC_OR_ALLOCA(storage, len, Bufbyte);
3220 for (; nargs; nargs--, args++) {
3221 Lisp_Object lisp_char = *args;
3222 CHECK_CHAR_COERCE_INT(lisp_char);
3223 p += set_charptr_emchar(p, XCHAR(lisp_char));
3225 result = make_string(storage, p - storage);
3226 XMALLOC_UNBIND(storage, len, speccount );
3231 /* Take some raw memory, which MUST already be in internal format,
3232 and package it up into a Lisp string. */
3234 make_string(const Bufbyte *contents, Bytecount length)
3238 /* Make sure we find out about bad make_string's when they happen */
3239 #if defined (ERROR_CHECK_BUFPOS) && defined (MULE)
3240 /* Just for the assertions */
3241 bytecount_to_charcount(contents, length);
3244 val = make_uninit_string(length);
3245 memcpy(XSTRING_DATA(val), contents, length);
3249 /* Take some raw memory, encoded in some external data format,
3250 and convert it into a Lisp string. */
3252 make_ext_string(const Extbyte *contents, EMACS_INT length,
3253 Lisp_Object coding_system)
3256 TO_INTERNAL_FORMAT(DATA, (contents, length),
3257 LISP_STRING, string, coding_system);
3261 /* why arent the next 3 inlines? */
3262 Lisp_Object build_string(const char *str)
3264 /* Some strlen's crash and burn if passed null. */
3266 return make_string((const Bufbyte*)str, strlen(str));
3272 Lisp_Object build_ext_string(const char *str, Lisp_Object coding_system)
3274 /* Some strlen's crash and burn if passed null. */
3275 return make_ext_string((const Extbyte*)str, (str ? strlen(str) : 0), coding_system);
3278 Lisp_Object build_translated_string(const char *str)
3280 return build_string(GETTEXT(str));
3283 Lisp_Object make_string_nocopy(Bufbyte *contents, Bytecount length)
3288 /* Make sure we find out about bad make_string_nocopy's when they
3290 #if defined (ERROR_CHECK_BUFPOS) && defined (MULE)
3291 /* Just for the assertions */
3292 bytecount_to_charcount(contents, length);
3295 /* Allocate the string header */
3296 ALLOCATE_FIXED_TYPE(string, Lisp_String, s);
3297 set_lheader_implementation(&s->lheader, &lrecord_string);
3298 SET_C_READONLY_RECORD_HEADER(&s->lheader);
3299 string_register_finaliser(s);
3302 #ifdef EF_USE_COMPRE
3305 set_string_data(s, (Bufbyte*)contents);
3306 set_string_length(s, length);
3312 /************************************************************************/
3313 /* lcrecord lists */
3314 /************************************************************************/
3316 /* Lcrecord lists are used to manage the allocation of particular
3317 sorts of lcrecords, to avoid calling alloc_lcrecord() (and thus
3318 malloc() and garbage-collection junk) as much as possible.
3319 It is similar to the Blocktype class.
3323 1) Create an lcrecord-list object using make_lcrecord_list().
3324 This is often done at initialization. Remember to staticpro_nodump
3325 this object! The arguments to make_lcrecord_list() are the
3326 same as would be passed to alloc_lcrecord().
3327 2) Instead of calling alloc_lcrecord(), call allocate_managed_lcrecord()
3328 and pass the lcrecord-list earlier created.
3329 3) When done with the lcrecord, call free_managed_lcrecord().
3330 The standard freeing caveats apply: ** make sure there are no
3331 pointers to the object anywhere! **
3332 4) Calling free_managed_lcrecord() is just like kissing the
3333 lcrecord goodbye as if it were garbage-collected. This means:
3334 -- the contents of the freed lcrecord are undefined, and the
3335 contents of something produced by allocate_managed_lcrecord()
3336 are undefined, just like for alloc_lcrecord().
3337 -- the mark method for the lcrecord's type will *NEVER* be called
3339 -- the finalize method for the lcrecord's type will be called
3340 at the time that free_managed_lcrecord() is called.
3342 lcrecord lists do not work in bdwgc mode. -hrop
3346 #if defined HAVE_BDWGC && defined EF_USE_BDWGC
3348 mark_lcrecord_list(Lisp_Object obj)
3353 /* just imitate the lcrecord spectactular */
3355 make_lcrecord_list(size_t size,
3356 const struct lrecord_implementation *implementation)
3358 struct lcrecord_list *p =
3359 alloc_lcrecord_type(struct lcrecord_list,
3360 &lrecord_lcrecord_list);
3363 p->implementation = implementation;
3366 XSETLCRECORD_LIST(val, p);
3371 allocate_managed_lcrecord(Lisp_Object lcrecord_list)
3373 struct lcrecord_list *list = XLCRECORD_LIST(lcrecord_list);
3374 void *tmp = alloc_lcrecord(list->size, list->implementation);
3382 free_managed_lcrecord(Lisp_Object SXE_UNUSED(lcrecord_list), Lisp_Object lcrecord)
3384 struct free_lcrecord_header *free_header =
3385 (struct free_lcrecord_header*)XPNTR(lcrecord);
3386 struct lrecord_header *lheader = &free_header->lcheader.lheader;
3387 const struct lrecord_implementation *imp =
3388 LHEADER_IMPLEMENTATION(lheader);
3390 if (imp->finalizer) {
3391 imp->finalizer(lheader, 0);
3399 mark_lcrecord_list(Lisp_Object obj)
3401 struct lcrecord_list *list = XLCRECORD_LIST(obj);
3402 Lisp_Object chain = list->free;
3404 while (!NILP(chain)) {
3405 struct lrecord_header *lheader = XRECORD_LHEADER(chain);
3406 struct free_lcrecord_header *free_header =
3407 (struct free_lcrecord_header *)lheader;
3410 /* There should be no other pointers to the free list. */
3411 !MARKED_RECORD_HEADER_P(lheader)
3413 /* Only lcrecords should be here. */
3414 !LHEADER_IMPLEMENTATION(lheader)->
3416 /* Only free lcrecords should be here. */
3417 free_header->lcheader.free &&
3418 /* The type of the lcrecord must be right. */
3419 LHEADER_IMPLEMENTATION(lheader) ==
3420 list->implementation &&
3421 /* So must the size. */
3422 (LHEADER_IMPLEMENTATION(lheader)->
3424 || LHEADER_IMPLEMENTATION(lheader)->
3425 static_size == list->size)
3428 MARK_RECORD_HEADER(lheader);
3429 chain = free_header->chain;
3436 make_lcrecord_list(size_t size,
3437 const struct lrecord_implementation *implementation)
3439 struct lcrecord_list *p =
3440 alloc_lcrecord_type(struct lcrecord_list,
3441 &lrecord_lcrecord_list);
3444 p->implementation = implementation;
3447 XSETLCRECORD_LIST(val, p);
3452 allocate_managed_lcrecord(Lisp_Object lcrecord_list)
3454 struct lcrecord_list *list = XLCRECORD_LIST(lcrecord_list);
3455 if (!NILP(list->free)) {
3456 Lisp_Object val = list->free;
3457 struct free_lcrecord_header *free_header =
3458 (struct free_lcrecord_header *)XPNTR(val);
3460 #ifdef ERROR_CHECK_GC
3461 struct lrecord_header *lheader = &free_header->lcheader.lheader;
3463 /* There should be no other pointers to the free list. */
3464 assert(!MARKED_RECORD_HEADER_P(lheader));
3465 /* Only lcrecords should be here. */
3466 assert(!LHEADER_IMPLEMENTATION(lheader)->basic_p);
3467 /* Only free lcrecords should be here. */
3468 assert(free_header->lcheader.free);
3469 /* The type of the lcrecord must be right. */
3470 assert(LHEADER_IMPLEMENTATION(lheader) == list->implementation);
3471 /* So must the size. */
3472 assert(LHEADER_IMPLEMENTATION(lheader)->static_size == 0 ||
3473 LHEADER_IMPLEMENTATION(lheader)->static_size ==
3475 #endif /* ERROR_CHECK_GC */
3477 list->free = free_header->chain;
3478 free_header->lcheader.free = 0;
3481 void *tmp = alloc_lcrecord(list->size, list->implementation);
3490 free_managed_lcrecord(Lisp_Object lcrecord_list, Lisp_Object lcrecord)
3492 struct lcrecord_list *list = XLCRECORD_LIST(lcrecord_list);
3493 struct free_lcrecord_header *free_header =
3494 (struct free_lcrecord_header*)XPNTR(lcrecord);
3495 struct lrecord_header *lheader = &free_header->lcheader.lheader;
3496 const struct lrecord_implementation *implementation
3497 = LHEADER_IMPLEMENTATION(lheader);
3499 /* Make sure the size is correct. This will catch, for example,
3500 putting a window configuration on the wrong free list. */
3501 gc_checking_assert((implementation->size_in_bytes_method ?
3502 implementation->size_in_bytes_method(lheader) :
3503 implementation->static_size)
3506 if (implementation->finalizer) {
3507 implementation->finalizer(lheader, 0);
3509 free_header->chain = list->free;
3510 free_header->lcheader.free = 1;
3511 list->free = lcrecord;
3515 DEFINE_LRECORD_IMPLEMENTATION("lcrecord-list", lcrecord_list,
3516 mark_lcrecord_list, internal_object_printer,
3517 0, 0, 0, 0, struct lcrecord_list);
3520 DEFUN("purecopy", Fpurecopy, 1, 1, 0, /*
3521 Kept for compatibility, returns its argument.
3523 Make a copy of OBJECT in pure storage.
3524 Recursively copies contents of vectors and cons cells.
3525 Does not copy symbols.
3532 /************************************************************************/
3533 /* Garbage Collection */
3534 /************************************************************************/
3536 /* All the built-in lisp object types are enumerated in `enum lrecord_type'.
3537 Additional ones may be defined by a module (none yet). We leave some
3538 room in `lrecord_implementations_table' for such new lisp object types. */
3539 const struct lrecord_implementation
3540 *lrecord_implementations_table[(unsigned int)lrecord_type_last_built_in_type
3541 + MODULE_DEFINABLE_TYPE_COUNT];
3542 unsigned int lrecord_type_count = (unsigned int)lrecord_type_last_built_in_type;
3543 /* Object marker functions are in the lrecord_implementation structure.
3544 But copying them to a parallel array is much more cache-friendly.
3545 This hack speeds up (garbage-collect) by about 5%. */
3546 Lisp_Object(*lrecord_markers[countof(lrecord_implementations_table)])
3549 #ifndef EF_USE_ASYNEQ
3550 struct gcpro *gcprolist;
3553 /* We want the staticpros relocated, but not the pointers found therein.
3554 Hence we use a trivial description, as for pointerless objects. */
3555 static const struct lrecord_description staticpro_description_1[] = {
3559 static const struct struct_description staticpro_description = {
3560 sizeof(Lisp_Object *),
3561 staticpro_description_1
3564 static const struct lrecord_description staticpros_description_1[] = {
3565 XD_DYNARR_DESC(Lisp_Object_ptr_dynarr, &staticpro_description),
3569 static const struct struct_description staticpros_description = {
3570 sizeof(Lisp_Object_ptr_dynarr),
3571 staticpros_description_1
3574 Lisp_Object_ptr_dynarr *staticpros;
3576 /* Mark the Lisp_Object at non-heap VARADDRESS as a root object for
3577 garbage collection, and for dumping. */
3578 void staticpro(Lisp_Object * varaddress)
3581 Dynarr_add(staticpros, varaddress);
3582 dump_add_root_object(varaddress);
3586 #if !defined HAVE_BDWGC || !defined EF_USE_BDWGC
3587 Lisp_Object_ptr_dynarr *staticpros_nodump;
3589 /* Mark the Lisp_Object at non-heap VARADDRESS as a root object for
3590 garbage collection, but not for dumping. */
3591 void staticpro_nodump(Lisp_Object * varaddress)
3594 Dynarr_add(staticpros_nodump, varaddress);
3600 #ifdef ERROR_CHECK_GC
3601 #define GC_CHECK_LHEADER_INVARIANTS(lheader) \
3603 struct lrecord_header * GCLI_lh = (lheader); \
3604 assert (GCLI_lh != 0); \
3605 assert (GCLI_lh->type < lrecord_type_count); \
3606 assert (! C_READONLY_RECORD_HEADER_P (GCLI_lh) || \
3607 (MARKED_RECORD_HEADER_P (GCLI_lh) && \
3608 LISP_READONLY_RECORD_HEADER_P (GCLI_lh))); \
3611 #define GC_CHECK_LHEADER_INVARIANTS(lheader)
3614 /* Mark reference to a Lisp_Object. If the object referred to has not been
3615 seen yet, recursively mark all the references contained in it. */
3617 #if defined HAVE_BDWGC && defined EF_USE_BDWGC
3618 void mark_object(Lisp_Object SXE_UNUSED(obj))
3624 void mark_object(Lisp_Object obj)
3626 if (obj == Qnull_pointer) {
3631 /* Checks we used to perform */
3632 /* if (EQ (obj, Qnull_pointer)) return; */
3633 /* if (!POINTER_TYPE_P (XGCTYPE (obj))) return; */
3634 /* if (PURIFIED (XPNTR (obj))) return; */
3636 if (XTYPE(obj) == Lisp_Type_Record) {
3637 struct lrecord_header *lheader = XRECORD_LHEADER(obj);
3639 GC_CHECK_LHEADER_INVARIANTS(lheader);
3641 gc_checking_assert(LHEADER_IMPLEMENTATION(lheader)->basic_p ||
3642 !((struct lcrecord_header *)lheader)->free);
3644 /* All c_readonly objects have their mark bit set,
3645 so that we only need to check the mark bit here. */
3646 if (!MARKED_RECORD_HEADER_P(lheader)) {
3647 MARK_RECORD_HEADER(lheader);
3649 if (RECORD_MARKER(lheader)) {
3650 obj = RECORD_MARKER(lheader) (obj);
3659 /* mark all of the conses in a list and mark the final cdr; but
3660 DO NOT mark the cars.
3662 Use only for internal lists! There should never be other pointers
3663 to the cons cells, because if so, the cars will remain unmarked
3664 even when they maybe should be marked. */
3665 void mark_conses_in_list(Lisp_Object obj)
3669 for (rest = obj; CONSP(rest); rest = XCDR(rest)) {
3670 if (CONS_MARKED_P(XCONS(rest)))
3672 MARK_CONS(XCONS(rest));
3678 /* Find all structures not marked, and free them. */
3680 #if !defined HAVE_BDWGC || !defined EF_USE_BDWGC
3681 static int gc_count_num_bit_vector_used, gc_count_bit_vector_total_size;
3682 static int gc_count_bit_vector_storage;
3683 static int gc_count_num_short_string_in_use;
3684 static int gc_count_string_total_size;
3685 static int gc_count_short_string_total_size;
3688 /* static int gc_count_total_records_used, gc_count_records_total_size; */
3690 /* stats on lcrecords in use - kinda kludgy */
3692 #if !defined HAVE_BDWGC || !defined EF_USE_BDWGC
3694 int instances_in_use;
3696 int instances_freed;
3698 int instances_on_free_list;
3699 } lcrecord_stats[countof(lrecord_implementations_table)
3700 + MODULE_DEFINABLE_TYPE_COUNT];
3703 #if !defined HAVE_BDWGC || !defined EF_USE_BDWGC
3704 static void tick_lcrecord_stats(const struct lrecord_header *h, int free_p)
3706 unsigned int type_index = h->type;
3708 if (((const struct lcrecord_header *)h)->free) {
3709 gc_checking_assert(!free_p);
3710 lcrecord_stats[type_index].instances_on_free_list++;
3712 const struct lrecord_implementation *implementation =
3713 LHEADER_IMPLEMENTATION(h);
3715 size_t sz = (implementation->size_in_bytes_method ?
3716 implementation->size_in_bytes_method(h) :
3717 implementation->static_size);
3719 lcrecord_stats[type_index].instances_freed++;
3720 lcrecord_stats[type_index].bytes_freed += sz;
3722 lcrecord_stats[type_index].instances_in_use++;
3723 lcrecord_stats[type_index].bytes_in_use += sz;
3729 /* Free all unmarked records */
3730 #if !defined HAVE_BDWGC || !defined EF_USE_BDWGC
3732 sweep_lcrecords_1(struct lcrecord_header *volatile*prev, int *used)
3735 /* int total_size = 0; */
3737 xzero(lcrecord_stats); /* Reset all statistics to 0. */
3739 /* First go through and call all the finalize methods.
3740 Then go through and free the objects. There used to
3741 be only one loop here, with the call to the finalizer
3742 occurring directly before the xfree() below. That
3743 is marginally faster but much less safe -- if the
3744 finalize method for an object needs to reference any
3745 other objects contained within it (and many do),
3746 we could easily be screwed by having already freed that
3749 for (struct lcrecord_header *volatile header = *prev;
3750 header; header = header->next) {
3751 struct lrecord_header *h = &(header->lheader);
3753 GC_CHECK_LHEADER_INVARIANTS(h);
3755 if (!MARKED_RECORD_HEADER_P(h) && !header->free) {
3756 if (LHEADER_IMPLEMENTATION(h)->finalizer)
3757 LHEADER_IMPLEMENTATION(h)->finalizer(h, 0);
3761 for (struct lcrecord_header *volatile header = *prev; header;) {
3762 struct lrecord_header *volatile h = &(header->lheader);
3763 if (MARKED_RECORD_HEADER_P(h)) {
3764 if (!C_READONLY_RECORD_HEADER_P(h))
3765 UNMARK_RECORD_HEADER(h);
3767 /* total_size += n->implementation->size_in_bytes (h); */
3768 /* #### May modify header->next on a C_READONLY lcrecord */
3769 prev = &(header->next);
3771 tick_lcrecord_stats(h, 0);
3773 struct lcrecord_header *next = header->next;
3775 tick_lcrecord_stats(h, 1);
3776 /* used to call finalizer right here. */
3782 /* *total = total_size; */
3787 sweep_bit_vectors_1(Lisp_Object * prev, int *used, int *total, int *storage)
3789 Lisp_Object bit_vector;
3792 int total_storage = 0;
3794 /* BIT_VECTORP fails because the objects are marked, which changes
3795 their implementation */
3796 for (bit_vector = *prev; !EQ(bit_vector, Qzero);) {
3797 Lisp_Bit_Vector *v = XBIT_VECTOR(bit_vector);
3799 if (MARKED_RECORD_P(bit_vector)) {
3800 if (!C_READONLY_RECORD_HEADER_P(&(v->lheader)))
3801 UNMARK_RECORD_HEADER(&(v->lheader));
3805 FLEXIBLE_ARRAY_STRUCT_SIZEOF(Lisp_Bit_Vector,
3806 unsigned long, bits,
3807 BIT_VECTOR_LONG_STORAGE
3810 /* #### May modify next on a C_READONLY bitvector */
3811 prev = &(bit_vector_next(v));
3814 Lisp_Object next = bit_vector_next(v);
3821 *total = total_size;
3822 *storage = total_storage;
3826 /* And the Lord said: Thou shalt use the `c-backslash-region' command
3827 to make macros prettier. */
3829 #if defined HAVE_BDWGC && defined EF_USE_BDWGC
3830 #define SWEEP_FIXED_TYPE_BLOCK(typename, obj_type)
3832 #elif defined ERROR_CHECK_GC
3834 #define SWEEP_FIXED_TYPE_BLOCK(typename, obj_type) \
3836 struct typename##_block *SFTB_current; \
3838 int num_free = 0, num_used = 0; \
3840 for (SFTB_current = current_##typename##_block, \
3841 SFTB_limit = current_##typename##_block_index; \
3846 for (SFTB_iii = 0; \
3847 SFTB_iii < SFTB_limit; \
3849 obj_type *SFTB_victim = \
3850 &(SFTB_current->block[SFTB_iii]); \
3852 if (LRECORD_FREE_P (SFTB_victim)) { \
3854 } else if (C_READONLY_RECORD_HEADER_P \
3855 (&SFTB_victim->lheader)) { \
3857 } else if (!MARKED_RECORD_HEADER_P \
3858 (&SFTB_victim->lheader)) { \
3860 FREE_FIXED_TYPE(typename, obj_type, \
3864 UNMARK_##typename(SFTB_victim); \
3867 SFTB_current = SFTB_current->prev; \
3868 SFTB_limit = countof(current_##typename##_block \
3872 gc_count_num_##typename##_in_use = num_used; \
3873 gc_count_num_##typename##_freelist = num_free; \
3876 #else /* !ERROR_CHECK_GC, !BDWGC*/
3878 #define SWEEP_FIXED_TYPE_BLOCK(typename, obj_type) \
3880 struct typename##_block *SFTB_current; \
3881 struct typename##_block **SFTB_prev; \
3883 int num_free = 0, num_used = 0; \
3885 typename##_free_list = 0; \
3887 for (SFTB_prev = ¤t_##typename##_block, \
3888 SFTB_current = current_##typename##_block, \
3889 SFTB_limit = current_##typename##_block_index; \
3893 int SFTB_empty = 1; \
3894 Lisp_Free *SFTB_old_free_list = \
3895 typename##_free_list; \
3897 for (SFTB_iii = 0; SFTB_iii < SFTB_limit; \
3899 obj_type *SFTB_victim = \
3900 &(SFTB_current->block[SFTB_iii]); \
3902 if (LRECORD_FREE_P (SFTB_victim)) { \
3904 PUT_FIXED_TYPE_ON_FREE_LIST \
3905 (typename, obj_type, \
3907 } else if (C_READONLY_RECORD_HEADER_P \
3908 (&SFTB_victim->lheader)) { \
3911 } else if (! MARKED_RECORD_HEADER_P \
3912 (&SFTB_victim->lheader)) { \
3914 FREE_FIXED_TYPE(typename, obj_type, \
3919 UNMARK_##typename (SFTB_victim); \
3922 if (!SFTB_empty) { \
3923 SFTB_prev = &(SFTB_current->prev); \
3924 SFTB_current = SFTB_current->prev; \
3925 } else if (SFTB_current == current_##typename##_block \
3926 && !SFTB_current->prev) { \
3927 /* No real point in freeing sole \
3928 * allocation block */ \
3931 struct typename##_block *SFTB_victim_block = \
3933 if (SFTB_victim_block == \
3934 current_##typename##_block) { \
3935 current_##typename##_block_index \
3937 (current_##typename##_block \
3940 SFTB_current = SFTB_current->prev; \
3942 *SFTB_prev = SFTB_current; \
3943 xfree(SFTB_victim_block); \
3944 /* Restore free list to what it was \
3945 before victim was swept */ \
3946 typename##_free_list = \
3947 SFTB_old_free_list; \
3948 num_free -= SFTB_limit; \
3951 SFTB_limit = countof (current_##typename##_block \
3955 gc_count_num_##typename##_in_use = num_used; \
3956 gc_count_num_##typename##_freelist = num_free; \
3959 #endif /* !ERROR_CHECK_GC */
3961 #if !defined HAVE_BDWGC || !defined EF_USE_BDWGC
3962 static void sweep_conses(void)
3964 #define UNMARK_cons(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
3965 #define ADDITIONAL_FREE_cons(ptr)
3967 SWEEP_FIXED_TYPE_BLOCK(cons, Lisp_Cons);
3971 /* Explicitly free a cons cell. */
3972 void free_cons(Lisp_Cons * ptr)
3974 #ifdef ERROR_CHECK_GC
3975 /* If the CAR is not an int, then it will be a pointer, which will
3976 always be four-byte aligned. If this cons cell has already been
3977 placed on the free list, however, its car will probably contain
3978 a chain pointer to the next cons on the list, which has cleverly
3979 had all its 0's and 1's inverted. This allows for a quick
3980 check to make sure we're not freeing something already freed. */
3981 if (POINTER_TYPE_P(XTYPE(ptr->car)))
3982 ASSERT_VALID_POINTER(XPNTR(ptr->car));
3983 #endif /* ERROR_CHECK_GC */
3985 #ifndef ALLOC_NO_POOLS
3986 FREE_FIXED_TYPE_WHEN_NOT_IN_GC(cons, Lisp_Cons, ptr);
3987 #endif /* ALLOC_NO_POOLS */
3990 /* explicitly free a list. You **must make sure** that you have
3991 created all the cons cells that make up this list and that there
3992 are no pointers to any of these cons cells anywhere else. If there
3993 are, you will lose. */
3995 void free_list(Lisp_Object list)
3997 Lisp_Object rest, next;
3999 for (rest = list; !NILP(rest); rest = next) {
4001 free_cons(XCONS(rest));
4005 /* explicitly free an alist. You **must make sure** that you have
4006 created all the cons cells that make up this alist and that there
4007 are no pointers to any of these cons cells anywhere else. If there
4008 are, you will lose. */
4010 void free_alist(Lisp_Object alist)
4012 Lisp_Object rest, next;
4014 for (rest = alist; !NILP(rest); rest = next) {
4016 free_cons(XCONS(XCAR(rest)));
4017 free_cons(XCONS(rest));
4021 #if !defined HAVE_BDWGC || !defined EF_USE_BDWGC
4022 static void sweep_compiled_functions(void)
4024 #define UNMARK_compiled_function(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
4025 #define ADDITIONAL_FREE_compiled_function(ptr)
4027 SWEEP_FIXED_TYPE_BLOCK(compiled_function, Lisp_Compiled_Function);
4031 static void sweep_floats(void)
4033 #define UNMARK_float(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
4034 #define ADDITIONAL_FREE_float(ptr)
4036 SWEEP_FIXED_TYPE_BLOCK(float, Lisp_Float);
4038 #endif /* HAVE_FPFLOAT */
4040 #if defined HAVE_MPZ && (defined WITH_GMP || defined WITH_MP)
4044 #define UNMARK_bigz(ptr) UNMARK_RECORD_HEADER(&((ptr)->lheader))
4045 #define ADDITIONAL_FREE_bigz(ptr) bigz_fini(ptr->data)
4047 SWEEP_FIXED_TYPE_BLOCK(bigz, Lisp_Bigz);
4049 #endif /* HAVE_MPZ */
4051 #if defined HAVE_MPQ && defined WITH_GMP
4055 #define UNMARK_bigq(ptr) UNMARK_RECORD_HEADER(&((ptr)->lheader))
4056 #define ADDITIONAL_FREE_bigq(ptr) bigq_fini(ptr->data)
4058 SWEEP_FIXED_TYPE_BLOCK(bigq, Lisp_Bigq);
4060 #endif /* HAVE_MPQ */
4062 #if defined HAVE_MPF && defined WITH_GMP
4066 #define UNMARK_bigf(ptr) UNMARK_RECORD_HEADER(&((ptr)->lheader))
4067 #define ADDITIONAL_FREE_bigf(ptr) bigf_fini(ptr->data)
4069 SWEEP_FIXED_TYPE_BLOCK(bigf, Lisp_Bigf);
4071 #endif /* HAVE_MPF */
4073 #if defined HAVE_MPFR && defined WITH_MPFR
4077 #define UNMARK_bigfr(ptr) UNMARK_RECORD_HEADER(&((ptr)->lheader))
4078 #define ADDITIONAL_FREE_bigfr(ptr) bigfr_fini(ptr->data)
4080 SWEEP_FIXED_TYPE_BLOCK(bigfr, Lisp_Bigfr);
4082 #endif /* HAVE_MPFR */
4084 #if defined HAVE_PSEUG && defined WITH_PSEUG
4088 #define UNMARK_bigg(ptr) UNMARK_RECORD_HEADER(&((ptr)->lheader))
4089 #define ADDITIONAL_FREE_bigg(ptr) bigg_fini(ptr->data)
4091 SWEEP_FIXED_TYPE_BLOCK(bigg, Lisp_Bigg);
4093 #endif /* HAVE_PSEUG */
4095 #if defined HAVE_MPC && defined WITH_MPC || \
4096 defined HAVE_PSEUC && defined WITH_PSEUC
4100 #define UNMARK_bigc(ptr) UNMARK_RECORD_HEADER(&((ptr)->lheader))
4101 #define ADDITIONAL_FREE_bigc(ptr) bigc_fini(ptr->data)
4103 SWEEP_FIXED_TYPE_BLOCK(bigc, Lisp_Bigc);
4105 #endif /* HAVE_MPC */
4107 #if defined HAVE_QUATERN && defined HAVE_MPZ && defined WITH_QUATERN
4109 sweep_quaterns (void)
4111 #define UNMARK_quatern(ptr) UNMARK_RECORD_HEADER(&((ptr)->lheader))
4112 #define ADDITIONAL_FREE_quatern(ptr) quatern_fini(ptr->data)
4114 SWEEP_FIXED_TYPE_BLOCK(quatern, Lisp_Quatern);
4116 #endif /* HAVE_QUATERN */
4119 sweep_dynacats(void)
4121 #define UNMARK_dynacat(ptr) UNMARK_RECORD_HEADER(&((ptr)->lheader))
4122 #define ADDITIONAL_FREE_dynacat(ptr) dynacat_fini(ptr);
4124 SWEEP_FIXED_TYPE_BLOCK(dynacat, struct dynacat_s);
4127 static void sweep_symbols(void)
4129 #define UNMARK_symbol(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
4130 #define ADDITIONAL_FREE_symbol(ptr)
4132 SWEEP_FIXED_TYPE_BLOCK(symbol, Lisp_Symbol);
4135 static void sweep_extents(void)
4137 #define UNMARK_extent(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
4138 #define ADDITIONAL_FREE_extent(ptr)
4140 SWEEP_FIXED_TYPE_BLOCK(extent, struct extent);
4143 static void sweep_events(void)
4145 #define UNMARK_event(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
4146 #define ADDITIONAL_FREE_event(ptr)
4148 SWEEP_FIXED_TYPE_BLOCK(event, Lisp_Event);
4151 static void sweep_markers(void)
4153 #define UNMARK_marker(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
4154 #define ADDITIONAL_FREE_marker(ptr) \
4155 do { Lisp_Object tem; \
4156 XSETMARKER (tem, ptr); \
4157 unchain_marker (tem); \
4160 SWEEP_FIXED_TYPE_BLOCK(marker, Lisp_Marker);
4164 /* Explicitly free a marker. */
4165 void free_marker(Lisp_Marker * ptr)
4167 /* Perhaps this will catch freeing an already-freed marker. */
4168 gc_checking_assert(ptr->lheader.type == lrecord_type_marker);
4170 #ifndef ALLOC_NO_POOLS
4171 FREE_FIXED_TYPE_WHEN_NOT_IN_GC(marker, Lisp_Marker, ptr);
4172 #endif /* ALLOC_NO_POOLS */
4175 #if defined (MULE) && defined (VERIFY_STRING_CHARS_INTEGRITY)
4177 static void verify_string_chars_integrity(void)
4179 struct string_chars_block *sb;
4181 /* Scan each existing string block sequentially, string by string. */
4182 for (sb = first_string_chars_block; sb; sb = sb->next) {
4184 /* POS is the index of the next string in the block. */
4185 while (pos < sb->pos) {
4186 struct string_chars *s_chars =
4187 (struct string_chars *)&(sb->string_chars[pos]);
4188 Lisp_String *string;
4192 /* If the string_chars struct is marked as free (i.e. the
4193 STRING pointer is NULL) then this is an unused chunk of
4194 string storage. (See below.) */
4196 if (STRING_CHARS_FREE_P(s_chars)) {
4198 ((struct unused_string_chars *)s_chars)->
4204 string = s_chars->string;
4205 /* Must be 32-bit aligned. */
4206 assert((((int)string) & 3) == 0);
4208 size = string_length(string);
4209 fullsize = STRING_FULLSIZE(size);
4211 assert(!BIG_STRING_FULLSIZE_P(fullsize));
4212 assert(string_data(string) == s_chars->chars);
4215 assert(pos == sb->pos);
4219 #endif /* MULE && ERROR_CHECK_GC */
4221 #if !defined HAVE_BDWGC || !defined EF_USE_BDWGC
4222 /* Compactify string chars, relocating the reference to each --
4223 free any empty string_chars_block we see. */
4224 static void compact_string_chars(void)
4226 struct string_chars_block *to_sb = first_string_chars_block;
4228 struct string_chars_block *from_sb;
4230 /* Scan each existing string block sequentially, string by string. */
4231 for (from_sb = first_string_chars_block; from_sb;
4232 from_sb = from_sb->next) {
4234 /* FROM_POS is the index of the next string in the block. */
4235 while (from_pos < from_sb->pos) {
4236 struct string_chars *from_s_chars =
4237 (struct string_chars *)&(from_sb->
4238 string_chars[from_pos]);
4239 struct string_chars *to_s_chars;
4240 Lisp_String *string;
4244 /* If the string_chars struct is marked as free (i.e. the
4245 STRING pointer is NULL) then this is an unused chunk of
4246 string storage. This happens under Mule when a string's
4247 size changes in such a way that its fullsize changes.
4248 (Strings can change size because a different-length
4249 character can be substituted for another character.)
4250 In this case, after the bogus string pointer is the
4251 "fullsize" of this entry, i.e. how many bytes to skip. */
4253 if (STRING_CHARS_FREE_P(from_s_chars)) {
4255 ((struct unused_string_chars *)
4256 from_s_chars)->fullsize;
4257 from_pos += fullsize;
4261 string = from_s_chars->string;
4262 assert(!(LRECORD_FREE_P(string)));
4264 size = string_length(string);
4265 fullsize = STRING_FULLSIZE(size);
4267 gc_checking_assert(!BIG_STRING_FULLSIZE_P(fullsize));
4269 /* Just skip it if it isn't marked. */
4270 if (!MARKED_RECORD_HEADER_P(&(string->lheader))) {
4271 from_pos += fullsize;
4275 /* If it won't fit in what's left of TO_SB, close TO_SB
4276 out and go on to the next string_chars_block. We
4277 know that TO_SB cannot advance past FROM_SB here
4278 since FROM_SB is large enough to currently contain
4280 if ((to_pos + fullsize) >
4281 countof(to_sb->string_chars)) {
4282 to_sb->pos = to_pos;
4283 to_sb = to_sb->next;
4287 /* Compute new address of this string
4288 and update TO_POS for the space being used. */
4290 (struct string_chars *)&(to_sb->
4291 string_chars[to_pos]);
4293 /* Copy the string_chars to the new place. */
4294 if (from_s_chars != to_s_chars)
4295 memmove(to_s_chars, from_s_chars, fullsize);
4297 /* Relocate FROM_S_CHARS's reference */
4298 set_string_data(string, &(to_s_chars->chars[0]));
4300 from_pos += fullsize;
4305 /* Set current to the last string chars block still used and
4306 free any that follow. */
4307 for (volatile struct string_chars_block *victim = to_sb->next;
4309 volatile struct string_chars_block *tofree = victim;
4310 victim = victim->next;
4314 current_string_chars_block = to_sb;
4315 current_string_chars_block->pos = to_pos;
4316 current_string_chars_block->next = 0;
4319 static int debug_string_purity;
4321 static void debug_string_purity_print(Lisp_String * p)
4324 Charcount s = string_char_length(p);
4326 for (i = 0; i < s; i++) {
4327 Emchar ch = string_char(p, i);
4328 if (ch < 32 || ch >= 126)
4329 stderr_out("\\%03o", ch);
4330 else if (ch == '\\' || ch == '\"')
4331 stderr_out("\\%c", ch);
4333 stderr_out("%c", ch);
4339 #if !defined HAVE_BDWGC || !defined EF_USE_BDWGC
4340 static void sweep_strings(void)
4342 int num_small_used = 0, num_small_bytes = 0, num_bytes = 0;
4343 int debug = debug_string_purity;
4345 #define UNMARK_string(ptr) \
4347 Lisp_String *p = (ptr); \
4348 size_t size = string_length (p); \
4349 UNMARK_RECORD_HEADER (&(p->lheader)); \
4350 num_bytes += size; \
4351 if (!BIG_STRING_SIZE_P (size)) { \
4352 num_small_bytes += size; \
4356 debug_string_purity_print (p); \
4358 #define ADDITIONAL_FREE_string(ptr) \
4360 size_t size = string_length (ptr); \
4361 if (BIG_STRING_SIZE_P(size)) { \
4366 SWEEP_FIXED_TYPE_BLOCK(string, Lisp_String);
4368 gc_count_num_short_string_in_use = num_small_used;
4369 gc_count_string_total_size = num_bytes;
4370 gc_count_short_string_total_size = num_small_bytes;
4374 /* I hate duplicating all this crap! */
4375 int marked_p(Lisp_Object obj)
4377 /* Checks we used to perform. */
4378 /* if (EQ (obj, Qnull_pointer)) return 1; */
4379 /* if (!POINTER_TYPE_P (XGCTYPE (obj))) return 1; */
4380 /* if (PURIFIED (XPNTR (obj))) return 1; */
4382 if (XTYPE(obj) == Lisp_Type_Record) {
4383 struct lrecord_header *lheader = XRECORD_LHEADER(obj);
4385 GC_CHECK_LHEADER_INVARIANTS(lheader);
4387 return MARKED_RECORD_HEADER_P(lheader);
4392 #if !defined HAVE_BDWGC || !defined EF_USE_BDWGC
4393 static void gc_sweep(void)
4395 /* Free all unmarked records. Do this at the very beginning,
4396 before anything else, so that the finalize methods can safely
4397 examine items in the objects. sweep_lcrecords_1() makes
4398 sure to call all the finalize methods *before* freeing anything,
4399 to complete the safety. */
4402 sweep_lcrecords_1(&all_lcrecords, &ignored);
4405 compact_string_chars();
4407 /* Finalize methods below (called through the ADDITIONAL_FREE_foo
4408 macros) must be *extremely* careful to make sure they're not
4409 referencing freed objects. The only two existing finalize
4410 methods (for strings and markers) pass muster -- the string
4411 finalizer doesn't look at anything but its own specially-
4412 created block, and the marker finalizer only looks at live
4413 buffers (which will never be freed) and at the markers before
4414 and after it in the chain (which, by induction, will never be
4415 freed because if so, they would have already removed themselves
4418 /* Put all unmarked strings on free list, free'ing the string chars
4419 of large unmarked strings */
4422 /* Put all unmarked conses on free list */
4425 /* Free all unmarked bit vectors */
4426 sweep_bit_vectors_1(&all_bit_vectors,
4427 &gc_count_num_bit_vector_used,
4428 &gc_count_bit_vector_total_size,
4429 &gc_count_bit_vector_storage);
4431 /* Free all unmarked compiled-function objects */
4432 sweep_compiled_functions();
4435 /* Put all unmarked floats on free list */
4437 #endif /* HAVE_FPFLOAT */
4439 #if defined HAVE_MPZ && (defined WITH_GMP || defined WITH_MP)
4440 /* Put all unmarked bignums on free list */
4442 #endif /* HAVE_MPZ */
4444 #if defined HAVE_MPQ && defined WITH_GMP
4445 /* Put all unmarked ratios on free list */
4447 #endif /* HAVE_MPQ */
4449 #if defined HAVE_MPF && defined WITH_GMP
4450 /* Put all unmarked bigfloats on free list */
4452 #endif /* HAVE_MPF */
4454 #if defined HAVE_MPFR && defined WITH_MPFR
4455 /* Put all unmarked bigfloats on free list */
4457 #endif /* HAVE_MPFR */
4459 #if defined HAVE_PSEUG && defined WITH_PSEUG
4460 /* Put all unmarked gaussian numbers on free list */
4462 #endif /* HAVE_PSEUG */
4464 #if defined HAVE_MPC && defined WITH_MPC || \
4465 defined HAVE_PSEUC && defined WITH_PSEUC
4466 /* Put all unmarked complex numbers on free list */
4468 #endif /* HAVE_MPC */
4470 #if defined HAVE_QUATERN && defined WITH_QUATERN
4471 /* Put all unmarked quaternions on free list */
4473 #endif /* HAVE_QUATERN */
4475 /* Put all unmarked dynacats on free list */
4478 /* Put all unmarked symbols on free list */
4481 /* Put all unmarked extents on free list */
4484 /* Put all unmarked markers on free list.
4485 Dechain each one first from the buffer into which it points. */
4491 pdump_objects_unmark();
4496 /* Clearing for disksave. */
4498 void disksave_object_finalization(void)
4500 /* It's important that certain information from the environment not get
4501 dumped with the executable (pathnames, environment variables, etc.).
4502 To make it easier to tell when this has happened with strings(1) we
4503 clear some known-to-be-garbage blocks of memory, so that leftover
4504 results of old evaluation don't look like potential problems.
4505 But first we set some notable variables to nil and do one more GC,
4506 to turn those strings into garbage.
4509 /* Yeah, this list is pretty ad-hoc... */
4510 Vprocess_environment = Qnil;
4511 /* Vexec_directory = Qnil; */
4512 Vdata_directory = Qnil;
4513 Vdoc_directory = Qnil;
4514 Vconfigure_info_directory = Qnil;
4517 /* Vdump_load_path = Qnil; */
4518 /* Release hash tables for locate_file */
4519 Flocate_file_clear_hashing(Qt);
4520 uncache_home_directory();
4522 #if defined(LOADHIST) && !(defined(LOADHIST_DUMPED) || \
4523 defined(LOADHIST_BUILTIN))
4524 Vload_history = Qnil;
4526 Vshell_file_name = Qnil;
4528 garbage_collect_1();
4530 /* Run the disksave finalization methods of all live objects. */
4531 disksave_object_finalization_1();
4533 /* Zero out the uninitialized (really, unused) part of the containers
4534 for the live strings. */
4535 /* dont know what its counterpart in bdwgc mode is, so leave it out */
4536 #if !defined HAVE_BDWGC || !defined EF_USE_BDWGC
4538 struct string_chars_block *scb;
4539 for (scb = first_string_chars_block; scb; scb = scb->next) {
4540 int count = sizeof(scb->string_chars) - scb->pos;
4542 assert(count >= 0 && count < STRING_CHARS_BLOCK_SIZE);
4544 /* from the block's fill ptr to the end */
4545 memset((scb->string_chars + scb->pos), 0,
4552 /* There, that ought to be enough... */
4556 Lisp_Object restore_gc_inhibit(Lisp_Object val)
4558 gc_currently_forbidden = XINT(val);
4562 /* Maybe we want to use this when doing a "panic" gc after memory_full()? */
4563 static int gc_hooks_inhibited;
4565 struct post_gc_action {
4566 void (*fun) (void *);
4570 typedef struct post_gc_action post_gc_action;
4573 Dynarr_declare(post_gc_action);
4574 } post_gc_action_dynarr;
4576 static post_gc_action_dynarr *post_gc_actions;
4578 /* Register an action to be called at the end of GC.
4579 gc_in_progress is 0 when this is called.
4580 This is used when it is discovered that an action needs to be taken,
4581 but it's during GC, so it's not safe. (e.g. in a finalize method.)
4583 As a general rule, do not use Lisp objects here.
4584 And NEVER signal an error.
4587 void register_post_gc_action(void (*fun) (void *), void *arg)
4589 post_gc_action action;
4591 if (!post_gc_actions)
4592 post_gc_actions = Dynarr_new(post_gc_action);
4597 Dynarr_add(post_gc_actions, action);
4600 #if !defined HAVE_BDWGC || !defined EF_USE_BDWGC
4601 static void run_post_gc_actions(void)
4605 if (post_gc_actions) {
4606 for (i = 0; i < Dynarr_length(post_gc_actions); i++) {
4607 post_gc_action action = Dynarr_at(post_gc_actions, i);
4608 (action.fun) (action.arg);
4611 Dynarr_reset(post_gc_actions);
4617 mark_gcprolist(struct gcpro *gcpl)
4621 for (tail = gcpl; tail; tail = tail->next) {
4622 for (i = 0; i < tail->nvars; i++) {
4623 mark_object(tail->var[i]);
4629 #if defined HAVE_BDWGC && defined EF_USE_BDWGC
4638 void garbage_collect_1(void)
4640 SXE_DEBUG_GC("GC\n");
4641 #if defined GC_DEBUG_FLAG
4643 #endif /* GC_DEBUG_FLAG */
4645 GC_collect_a_little();
4649 GC_try_to_collect(stop_gc_p);
4655 void garbage_collect_1(void)
4657 #if MAX_SAVE_STACK > 0
4658 char stack_top_variable;
4659 extern char *stack_bottom;
4664 Lisp_Object pre_gc_cursor;
4665 struct gcpro gcpro1;
4668 || gc_currently_forbidden || in_display || preparing_for_armageddon)
4671 /* We used to call selected_frame() here.
4673 The following functions cannot be called inside GC
4674 so we move to after the above tests. */
4677 Lisp_Object device = Fselected_device(Qnil);
4678 /* Could happen during startup, eg. if always_gc */
4682 frame = DEVICE_SELECTED_FRAME(XDEVICE(device));
4684 signal_simple_error("No frames exist on device",
4690 pre_gc_cursor = Qnil;
4693 GCPRO1(pre_gc_cursor);
4695 /* Very important to prevent GC during any of the following
4696 stuff that might run Lisp code; otherwise, we'll likely
4697 have infinite GC recursion. */
4698 speccount = specpdl_depth();
4699 record_unwind_protect(restore_gc_inhibit,
4700 make_int(gc_currently_forbidden));
4701 gc_currently_forbidden = 1;
4703 if (!gc_hooks_inhibited)
4704 run_hook_trapping_errors("Error in pre-gc-hook", Qpre_gc_hook);
4706 /* Now show the GC cursor/message. */
4707 if (!noninteractive) {
4708 if (FRAME_WIN_P(f)) {
4709 Lisp_Object frame = make_frame(f);
4710 Lisp_Object cursor =
4711 glyph_image_instance(Vgc_pointer_glyph,
4712 FRAME_SELECTED_WINDOW(f),
4714 pre_gc_cursor = f->pointer;
4715 if (POINTER_IMAGE_INSTANCEP(cursor)
4716 /* don't change if we don't know how to change
4718 && POINTER_IMAGE_INSTANCEP(pre_gc_cursor)) {
4720 Fset_frame_pointer(frame, cursor);
4724 /* Don't print messages to the stream device. */
4725 if (STRINGP(Vgc_message) &&
4727 !FRAME_STREAM_P(f)) {
4728 char *msg = GETTEXT((char *) XSTRING_DATA(Vgc_message));
4729 Lisp_Object args[2], whole_msg;
4731 args[0] = build_string(
4732 msg ? msg : GETTEXT((char*)gc_default_message));
4733 args[1] = build_string("...");
4734 whole_msg = Fconcat(2, args);
4735 echo_area_message(f, (Bufbyte *) 0, whole_msg, 0, -1,
4736 Qgarbage_collecting);
4740 /***** Now we actually start the garbage collection. */
4744 inhibit_non_essential_printing_operations = 1;
4746 gc_generation_number[0]++;
4748 #if MAX_SAVE_STACK > 0
4750 /* Save a copy of the contents of the stack, for debugging. */
4752 /* Static buffer in which we save a copy of the C stack at each
4754 static char *stack_copy;
4755 static size_t stack_copy_size;
4757 ptrdiff_t stack_diff = &stack_top_variable - stack_bottom;
4758 size_t stack_size = (stack_diff > 0 ? stack_diff : -stack_diff);
4759 if (stack_size < MAX_SAVE_STACK) {
4760 if (stack_copy_size < stack_size) {
4762 (char *)xrealloc(stack_copy, stack_size);
4763 stack_copy_size = stack_size;
4768 0 ? stack_bottom : &stack_top_variable,
4772 #endif /* MAX_SAVE_STACK > 0 */
4774 /* Do some totally ad-hoc resource clearing. */
4775 /* #### generalize this? */
4776 clear_event_resource();
4777 cleanup_specifiers();
4779 /* Mark all the special slots that serve as the roots of
4783 Lisp_Object **p = Dynarr_begin(staticpros);
4785 for (count = Dynarr_length(staticpros); count; count--) {
4790 { /* staticpro_nodump() */
4791 Lisp_Object **p = Dynarr_begin(staticpros_nodump);
4793 for (count = Dynarr_length(staticpros_nodump); count; count--) {
4798 #if defined(EF_USE_ASYNEQ)
4799 WITH_DLLIST_TRAVERSE(
4801 eq_worker_t eqw = dllist_item;
4802 struct gcpro *gcpl = eqw->gcprolist;
4803 mark_gcprolist(gcpl));
4806 mark_gcprolist(gcprolist);
4809 struct specbinding *bind;
4810 for (bind = specpdl; bind != specpdl_ptr; bind++) {
4811 mark_object(bind->symbol);
4812 mark_object(bind->old_value);
4817 struct catchtag *catch;
4818 for (catch = catchlist; catch; catch = catch->next) {
4819 mark_object(catch->tag);
4820 mark_object(catch->val);
4825 struct backtrace *backlist;
4826 for (backlist = backtrace_list; backlist;
4827 backlist = backlist->next) {
4828 int nargs = backlist->nargs;
4831 mark_object(*backlist->function);
4833 0 /* nargs == UNEVALLED || nargs == MANY */ )
4834 mark_object(backlist->args[0]);
4836 for (i = 0; i < nargs; i++)
4837 mark_object(backlist->args[i]);
4842 mark_profiling_info();
4844 /* OK, now do the after-mark stuff. This is for things that are only
4845 marked when something else is marked (e.g. weak hash tables). There
4846 may be complex dependencies between such objects -- e.g. a weak hash
4847 table might be unmarked, but after processing a later weak hash
4848 table, the former one might get marked. So we have to iterate until
4849 nothing more gets marked. */
4850 while (finish_marking_weak_hash_tables() > 0 ||
4851 finish_marking_weak_lists() > 0) ;
4853 /* And prune (this needs to be called after everything else has been
4854 marked and before we do any sweeping). */
4855 /* #### this is somewhat ad-hoc and should probably be an object
4857 prune_weak_hash_tables();
4860 prune_syntax_tables();
4864 consing_since_gc = 0;
4865 #ifndef DEBUG_SXEMACS
4866 /* Allow you to set it really fucking low if you really want ... */
4867 if (gc_cons_threshold < 10000)
4868 gc_cons_threshold = 10000;
4872 inhibit_non_essential_printing_operations = 0;
4875 run_post_gc_actions();
4877 /******* End of garbage collection ********/
4879 run_hook_trapping_errors("Error in post-gc-hook", Qpost_gc_hook);
4881 /* Now remove the GC cursor/message */
4882 if (!noninteractive) {
4884 Fset_frame_pointer(make_frame(f), pre_gc_cursor);
4885 else if (STRINGP(Vgc_message) && !FRAME_STREAM_P(f)) {
4886 char *msg = GETTEXT((char *)XSTRING_DATA(Vgc_message));
4888 /* Show "...done" only if the echo area would otherwise
4890 if (NILP(clear_echo_area(selected_frame(),
4891 Qgarbage_collecting, 0))) {
4892 Lisp_Object args[2], whole_msg;
4893 args[0] = build_string(
4895 : GETTEXT((char*)gc_default_message));
4896 args[1] = build_string("... done");
4897 whole_msg = Fconcat(2, args);
4898 echo_area_message(selected_frame(),
4899 (Bufbyte *) 0, whole_msg, 0,
4900 -1, Qgarbage_collecting);
4905 /* now stop inhibiting GC */
4906 unbind_to(speccount, Qnil);
4908 if (!breathing_space) {
4909 breathing_space = malloc(0xFFFF - MALLOC_OVERHEAD);
4918 /* Debugging aids. */
4919 #if defined HAVE_BDWGC && defined EF_USE_BDWGC
4920 #define HACK_O_MATIC(args...)
4921 #define gc_plist_hack(name, val, tail) \
4922 cons3(intern(name), Qzero, tail)
4926 static Lisp_Object gc_plist_hack(const char *name, int value, Lisp_Object tail)
4928 /* C doesn't have local functions (or closures, or GC, or readable
4929 syntax, or portable numeric datatypes, or bit-vectors, or characters,
4930 or arrays, or exceptions, or ...) */
4931 return cons3(intern(name), make_int(value), tail);
4934 #define HACK_O_MATIC(type, name, pl) \
4937 struct type##_block *x = current_##type##_block; \
4939 s += sizeof (*x) + MALLOC_OVERHEAD; \
4942 (pl) = gc_plist_hack ((name), s, (pl)); \
4946 DEFUN("garbage-collect", Fgarbage_collect, 0, 0, "", /*
4947 Reclaim storage for Lisp objects no longer needed.
4948 Return info on amount of space in use:
4949 ((USED-CONSES . FREE-CONSES) (USED-SYMS . FREE-SYMS)
4950 (USED-MARKERS . FREE-MARKERS) USED-STRING-CHARS USED-VECTOR-SLOTS
4952 where `PLIST' is a list of alternating keyword/value pairs providing
4953 more detailed information.
4954 Garbage collection happens automatically if you cons more than
4955 `gc-cons-threshold' bytes of Lisp data since previous garbage collection.
4959 #if defined HAVE_BDWGC && defined EF_USE_BDWGC
4963 Lisp_Object pl = Qnil;
4965 int gc_count_vector_total_size = 0;
4967 garbage_collect_1();
4969 for (i = 0; i < lrecord_type_count; i++) {
4970 if (lcrecord_stats[i].bytes_in_use != 0
4971 || lcrecord_stats[i].bytes_freed != 0
4972 || lcrecord_stats[i].instances_on_free_list != 0) {
4975 lrecord_implementations_table[i]->name;
4976 int len = strlen(name);
4979 /* save this for the FSFmacs-compatible part of the
4981 if (i == lrecord_type_vector)
4982 gc_count_vector_total_size =
4983 lcrecord_stats[i].bytes_in_use +
4984 lcrecord_stats[i].bytes_freed;
4986 sz = snprintf(buf, sizeof(buf), "%s-storage", name);
4987 assert(sz >=0 && (size_t)sz < sizeof(buf));
4988 pl = gc_plist_hack(buf, lcrecord_stats[i].bytes_in_use,
4990 /* Okay, simple pluralization check for
4991 `symbol-value-varalias' */
4992 if (name[len - 1] == 's')
4993 sz = snprintf(buf, sizeof(buf), "%ses-freed", name);
4995 sz = snprintf(buf, sizeof(buf), "%ss-freed", name);
4996 assert(sz >=0 && (size_t)sz < sizeof(buf));
4997 if (lcrecord_stats[i].instances_freed != 0)
4998 pl = gc_plist_hack(buf,
5000 instances_freed, pl);
5001 if (name[len - 1] == 's')
5002 sz = snprintf(buf, sizeof(buf), "%ses-on-free-list", name);
5004 sz = snprintf(buf, sizeof(buf), "%ss-on-free-list", name);
5005 assert(sz >=0 && (size_t)sz < sizeof(buf));
5006 if (lcrecord_stats[i].instances_on_free_list != 0)
5007 pl = gc_plist_hack(buf,
5009 instances_on_free_list, pl);
5010 if (name[len - 1] == 's')
5011 sz = snprintf(buf, sizeof(buf), "%ses-used", name);
5013 sz = snprintf(buf, sizeof(buf), "%ss-used", name);
5014 assert(sz >=0 && (size_t)sz < sizeof(buf));
5015 pl = gc_plist_hack(buf,
5016 lcrecord_stats[i].instances_in_use,
5021 HACK_O_MATIC(extent, "extent-storage", pl);
5022 pl = gc_plist_hack("extents-free", gc_count_num_extent_freelist, pl);
5023 pl = gc_plist_hack("extents-used", gc_count_num_extent_in_use, pl);
5024 HACK_O_MATIC(event, "event-storage", pl);
5025 pl = gc_plist_hack("events-free", gc_count_num_event_freelist, pl);
5026 pl = gc_plist_hack("events-used", gc_count_num_event_in_use, pl);
5027 HACK_O_MATIC(marker, "marker-storage", pl);
5028 pl = gc_plist_hack("markers-free", gc_count_num_marker_freelist, pl);
5029 pl = gc_plist_hack("markers-used", gc_count_num_marker_in_use, pl);
5031 HACK_O_MATIC(float, "float-storage", pl);
5032 pl = gc_plist_hack("floats-free", gc_count_num_float_freelist, pl);
5033 pl = gc_plist_hack("floats-used", gc_count_num_float_in_use, pl);
5034 #endif /* HAVE_FPFLOAT */
5035 #if defined HAVE_MPZ && (defined WITH_GMP || defined WITH_MP)
5036 HACK_O_MATIC(bigz, "bigz-storage", pl);
5037 pl = gc_plist_hack("bigzs-free", gc_count_num_bigz_freelist, pl);
5038 pl = gc_plist_hack("bigzs-used", gc_count_num_bigz_in_use, pl);
5039 #endif /* HAVE_MPZ */
5040 #if defined HAVE_MPQ && defined WITH_GMP
5041 HACK_O_MATIC(bigq, "bigq-storage", pl);
5042 pl = gc_plist_hack("bigqs-free", gc_count_num_bigq_freelist, pl);
5043 pl = gc_plist_hack("bigqs-used", gc_count_num_bigq_in_use, pl);
5044 #endif /* HAVE_MPQ */
5045 #if defined HAVE_MPF && defined WITH_GMP
5046 HACK_O_MATIC(bigf, "bigf-storage", pl);
5047 pl = gc_plist_hack("bigfs-free", gc_count_num_bigf_freelist, pl);
5048 pl = gc_plist_hack("bigfs-used", gc_count_num_bigf_in_use, pl);
5049 #endif /* HAVE_MPF */
5050 #if defined HAVE_MPFR && defined WITH_MPFR
5051 HACK_O_MATIC(bigfr, "bigfr-storage", pl);
5052 pl = gc_plist_hack("bigfrs-free", gc_count_num_bigfr_freelist, pl);
5053 pl = gc_plist_hack("bigfrs-used", gc_count_num_bigfr_in_use, pl);
5054 #endif /* HAVE_MPFR */
5055 #if defined HAVE_PSEUG && defined WITH_PSEUG
5056 HACK_O_MATIC(bigg, "bigg-storage", pl);
5057 pl = gc_plist_hack("biggs-free", gc_count_num_bigg_freelist, pl);
5058 pl = gc_plist_hack("biggs-used", gc_count_num_bigg_in_use, pl);
5059 #endif /* HAVE_PSEUG */
5060 #if defined HAVE_MPC && defined WITH_MPC || \
5061 defined HAVE_PSEUC && defined WITH_PSEUC
5062 HACK_O_MATIC(bigc, "bigc-storage", pl);
5063 pl = gc_plist_hack("bigcs-free", gc_count_num_bigc_freelist, pl);
5064 pl = gc_plist_hack("bigcs-used", gc_count_num_bigc_in_use, pl);
5065 #endif /* HAVE_MPC */
5066 #if defined HAVE_QUATERN && defined WITH_QUATERN
5067 HACK_O_MATIC(quatern, "quatern-storage", pl);
5068 pl = gc_plist_hack("quaterns-free", gc_count_num_quatern_freelist, pl);
5069 pl = gc_plist_hack("quaterns-used", gc_count_num_quatern_in_use, pl);
5070 #endif /* HAVE_QUATERN */
5072 HACK_O_MATIC(dynacat, "dynacat-storage", pl);
5073 pl = gc_plist_hack("dynacats-free", gc_count_num_dynacat_freelist, pl);
5074 pl = gc_plist_hack("dynacats-used", gc_count_num_dynacat_in_use, pl);
5076 HACK_O_MATIC(string, "string-header-storage", pl);
5077 pl = gc_plist_hack("long-strings-total-length",
5078 gc_count_string_total_size
5079 - gc_count_short_string_total_size, pl);
5080 HACK_O_MATIC(string_chars, "short-string-storage", pl);
5081 pl = gc_plist_hack("short-strings-total-length",
5082 gc_count_short_string_total_size, pl);
5083 pl = gc_plist_hack("strings-free", gc_count_num_string_freelist, pl);
5084 pl = gc_plist_hack("long-strings-used",
5085 gc_count_num_string_in_use
5086 - gc_count_num_short_string_in_use, pl);
5087 pl = gc_plist_hack("short-strings-used",
5088 gc_count_num_short_string_in_use, pl);
5090 HACK_O_MATIC(compiled_function, "compiled-function-storage", pl);
5091 pl = gc_plist_hack("compiled-functions-free",
5092 gc_count_num_compiled_function_freelist, pl);
5093 pl = gc_plist_hack("compiled-functions-used",
5094 gc_count_num_compiled_function_in_use, pl);
5096 pl = gc_plist_hack("bit-vector-storage", gc_count_bit_vector_storage,
5098 pl = gc_plist_hack("bit-vectors-total-length",
5099 gc_count_bit_vector_total_size, pl);
5100 pl = gc_plist_hack("bit-vectors-used", gc_count_num_bit_vector_used,
5103 HACK_O_MATIC(symbol, "symbol-storage", pl);
5104 pl = gc_plist_hack("symbols-free", gc_count_num_symbol_freelist, pl);
5105 pl = gc_plist_hack("symbols-used", gc_count_num_symbol_in_use, pl);
5107 HACK_O_MATIC(cons, "cons-storage", pl);
5108 pl = gc_plist_hack("conses-free", gc_count_num_cons_freelist, pl);
5109 pl = gc_plist_hack("conses-used", gc_count_num_cons_in_use, pl);
5111 /* The things we do for backwards-compatibility */
5112 /* fuck, what are we doing about those in the bdwgc era? -hrop */
5114 list6(Fcons(make_int(gc_count_num_cons_in_use),
5115 make_int(gc_count_num_cons_freelist)),
5116 Fcons(make_int(gc_count_num_symbol_in_use),
5117 make_int(gc_count_num_symbol_freelist)),
5118 Fcons(make_int(gc_count_num_marker_in_use),
5119 make_int(gc_count_num_marker_freelist)),
5120 make_int(gc_count_string_total_size),
5121 make_int(gc_count_vector_total_size), pl);
5127 /* grrrr ... lisp/itimer-autosave.el is using this, WTF? */
5128 DEFUN("consing-since-gc", Fconsing_since_gc, 0, 0, "", /*
5129 Return the number of bytes consed since the last garbage collection.
5130 \"Consed\" is a misnomer in that this actually counts allocation
5131 of all different kinds of objects, not just conses.
5133 If this value exceeds `gc-cons-threshold', a garbage collection happens.
5137 #if defined HAVE_BDWGC && defined EF_USE_BDWGC
5140 return make_int(consing_since_gc);
5145 int object_dead_p(Lisp_Object obj)
5147 return ((BUFFERP(obj) && !BUFFER_LIVE_P(XBUFFER(obj))) ||
5148 (FRAMEP(obj) && !FRAME_LIVE_P(XFRAME(obj))) ||
5149 (WINDOWP(obj) && !WINDOW_LIVE_P(XWINDOW(obj))) ||
5150 (DEVICEP(obj) && !DEVICE_LIVE_P(XDEVICE(obj))) ||
5151 (CONSOLEP(obj) && !CONSOLE_LIVE_P(XCONSOLE(obj))) ||
5152 (EVENTP(obj) && !EVENT_LIVE_P(XEVENT(obj))) ||
5153 (EXTENTP(obj) && !EXTENT_LIVE_P(XEXTENT(obj))));
5156 #if defined MEMORY_USAGE_STATS && !(defined HAVE_BDWGC && defined EF_USE_BDWGC)
5158 /* Attempt to determine the actual amount of space that is used for
5159 the block allocated starting at PTR, supposedly of size "CLAIMED_SIZE".
5161 It seems that the following holds:
5163 1. When using the old allocator (malloc.c):
5165 -- blocks are always allocated in chunks of powers of two. For
5166 each block, there is an overhead of 8 bytes if rcheck is not
5167 defined, 20 bytes if it is defined. In other words, a
5168 one-byte allocation needs 8 bytes of overhead for a total of
5169 9 bytes, and needs to have 16 bytes of memory chunked out for
5172 2. When using the new allocator (gmalloc.c):
5174 -- blocks are always allocated in chunks of powers of two up
5175 to 4096 bytes. Larger blocks are allocated in chunks of
5176 an integral multiple of 4096 bytes. The minimum block
5177 size is 2*sizeof (void *), or 16 bytes if SUNOS_LOCALTIME_BUG
5178 is defined. There is no per-block overhead, but there
5179 is an overhead of 3*sizeof (size_t) for each 4096 bytes
5182 3. When using the system malloc, anything goes, but they are
5183 generally slower and more space-efficient than the GNU
5184 allocators. One possibly reasonable assumption to make
5185 for want of better data is that sizeof (void *), or maybe
5186 2 * sizeof (void *), is required as overhead and that
5187 blocks are allocated in the minimum required size except
5188 that some minimum block size is imposed (e.g. 16 bytes). */
5191 malloced_storage_size(void *ptr, size_t claimed_size,
5192 struct overhead_stats * stats)
5194 size_t orig_claimed_size = claimed_size;
5198 if (claimed_size < 2 * sizeof(void *))
5199 claimed_size = 2 * sizeof(void *);
5200 # ifdef SUNOS_LOCALTIME_BUG
5201 if (claimed_size < 16)
5204 if (claimed_size < 4096) {
5207 /* compute the log base two, more or less, then use it to compute
5208 the block size needed. */
5210 /* It's big, it's heavy, it's wood! */
5211 while ((claimed_size /= 2) != 0)
5214 /* It's better than bad, it's good! */
5219 /* We have to come up with some average about the amount of
5221 if ((size_t) (rand() & 4095) < claimed_size)
5222 claimed_size += 3 * sizeof(void *);
5224 claimed_size += 4095;
5225 claimed_size &= ~4095;
5226 claimed_size += (claimed_size / 4096) * 3 * sizeof(size_t);
5229 #elif defined (SYSTEM_MALLOC)
5231 if (claimed_size < 16)
5233 claimed_size += 2 * sizeof(void *);
5235 #else /* old GNU allocator */
5237 # ifdef rcheck /* #### may not be defined here */
5245 /* compute the log base two, more or less, then use it to compute
5246 the block size needed. */
5248 /* It's big, it's heavy, it's wood! */
5249 while ((claimed_size /= 2) != 0)
5252 /* It's better than bad, it's good! */
5259 #endif /* old GNU allocator */
5262 stats->was_requested += orig_claimed_size;
5263 stats->malloc_overhead += claimed_size - orig_claimed_size;
5265 return claimed_size;
5268 size_t fixed_type_block_overhead(size_t size)
5270 size_t per_block = TYPE_ALLOC_SIZE(cons, unsigned char);
5271 size_t overhead = 0;
5272 size_t storage_size = malloced_storage_size(0, per_block, 0);
5273 while (size >= per_block) {
5275 overhead += sizeof(void *) + per_block - storage_size;
5277 if (rand() % per_block < size)
5278 overhead += sizeof(void *) + per_block - storage_size;
5282 #endif /* MEMORY_USAGE_STATS */
5284 #ifdef EF_USE_ASYNEQ
5286 init_main_worker(void)
5288 eq_worker_t res = eq_make_worker();
5289 eq_worker_thread(res) = pthread_self();
5294 #if defined HAVE_MPZ && defined WITH_GMP || \
5295 defined HAVE_MPFR && defined WITH_MPFR
5297 my_malloc(size_t bar)
5299 /* we use atomic here since GMP/MPFR do supervise their objects */
5300 void *foo = xmalloc(bar);
5301 SXE_DEBUG_GC_GMP("alloc :is %p :size %lu\n",
5302 foo, (long unsigned int)bar);
5306 /* We need the next two functions since GNU MP insists on giving us an extra
5309 my_realloc (void *ptr, size_t SXE_UNUSED(old_size), size_t new_size)
5311 void *foo = xrealloc(ptr, new_size);
5312 SXE_DEBUG_GC_GMP("gmp realloc :was %p :is %p\n", ptr, foo);
5317 my_free (void *ptr, size_t size)
5319 SXE_DEBUG_GC_GMP("free :was %p :size %lu\n",
5320 ptr, (long unsigned int)size);
5321 memset(ptr, 0, size);
5325 #endif /* GMP || MPFR */
5327 #if defined HAVE_BDWGC && defined EF_USE_BDWGC && !defined GC_DEBUG_FLAG
5329 my_shy_warn_proc(char *msg, GC_word arg)
5331 /* just don't do anything */
5337 /* Initialization */
5338 void init_bdwgc(void);
5343 #if defined HAVE_BDWGC && defined EF_USE_BDWGC
5344 # if defined GC_DEBUG_FLAG
5345 extern long GC_large_alloc_warn_interval;
5347 GC_time_limit = GC_TIME_UNLIMITED;
5348 GC_use_entire_heap = 0;
5351 GC_all_interior_pointers = 1;
5355 GC_free_space_divisor = 8;
5357 #if !defined GC_DEBUG_FLAG
5358 GC_set_warn_proc(my_shy_warn_proc);
5359 #else /* GC_DEBUG_FLAG */
5360 GC_large_alloc_warn_interval = 1L;
5361 #endif /* GC_DEBUG_FLAG */
5368 __init_gmp_mem_funs(void)
5370 #if defined HAVE_MPZ && defined WITH_GMP || \
5371 defined HAVE_MPFR && defined WITH_MPFR
5372 mp_set_memory_functions(my_malloc, my_realloc, my_free);
5373 #endif /* GMP || MPFR */
5376 void reinit_alloc_once_early(void)
5378 gc_generation_number[0] = 0;
5379 breathing_space = NULL;
5380 XSETINT(all_bit_vectors, 0); /* Qzero may not be set yet. */
5381 XSETINT(Vgc_message, 0);
5382 #if !defined HAVE_BDWGC || !defined EF_USE_BDWGC
5385 ignore_malloc_warnings = 1;
5386 #ifdef DOUG_LEA_MALLOC
5387 mallopt(M_TRIM_THRESHOLD, 128 * 1024); /* trim threshold */
5388 mallopt(M_MMAP_THRESHOLD, 64 * 1024); /* mmap threshold */
5389 #if 1 /* Moved to emacs.c */
5390 mallopt(M_MMAP_MAX, 0); /* max. number of mmap'ed areas */
5393 /* the category subsystem */
5394 morphisms[lrecord_type_cons].seq_impl = &__scons;
5395 morphisms[lrecord_type_vector].seq_impl = &__svec;
5396 morphisms[lrecord_type_string].seq_impl = &__sstr;
5397 morphisms[lrecord_type_bit_vector].seq_impl = &__sbvc;
5399 init_string_alloc();
5400 #if !defined HAVE_BDWGC || !defined EF_USE_BDWGC
5401 init_string_chars_alloc();
5404 init_symbol_alloc();
5405 init_compiled_function_alloc();
5409 __init_gmp_mem_funs();
5410 #if defined HAVE_MPZ && (defined WITH_GMP || defined WITH_MP) && \
5411 !(defined HAVE_BDWGC && defined EF_USE_BDWGC)
5414 #if defined HAVE_MPQ && defined WITH_GMP && \
5415 !(defined HAVE_BDWGC && defined EF_USE_BDWGC)
5418 #if defined HAVE_MPF && defined WITH_GMP && \
5419 !(defined HAVE_BDWGC && defined EF_USE_BDWGC)
5422 #if defined HAVE_MPFR && defined WITH_MPFR
5425 #if defined HAVE_PSEUG && defined HAVE_MPZ && defined WITH_PSEUG
5428 #if defined HAVE_MPC && defined WITH_MPC || \
5429 defined HAVE_PSEUC && defined WITH_PSEUC
5432 #if defined HAVE_QUATERN && defined HAVE_MPZ && defined WITH_QUATERN
5433 init_quatern_alloc();
5435 init_dynacat_alloc();
5437 init_marker_alloc();
5438 init_extent_alloc();
5441 ignore_malloc_warnings = 0;
5443 /* we only use the 500k value for now */
5444 gc_cons_threshold = 500000;
5445 lrecord_uid_counter = 259;
5447 #if !defined HAVE_BDWGC || !defined EF_USE_BDWGC
5448 if (staticpros_nodump) {
5449 Dynarr_free(staticpros_nodump);
5451 staticpros_nodump = Dynarr_new2(Lisp_Object_ptr_dynarr, Lisp_Object *);
5452 /* merely a small optimization */
5453 Dynarr_resize(staticpros_nodump, 100);
5455 /* tuning the GCor */
5456 consing_since_gc = 0;
5457 debug_string_purity = 0;
5459 #ifdef EF_USE_ASYNEQ
5460 workers = make_noseeum_dllist();
5461 dllist_prepend(workers, init_main_worker());
5466 #if defined EF_USE_ASYNEQ && !(defined HAVE_BDWGC && defined EF_USE_BDWGC)
5467 SXE_MUTEX_INIT(&cons_mutex);
5470 gc_currently_forbidden = 0;
5471 gc_hooks_inhibited = 0;
5473 #ifdef ERROR_CHECK_TYPECHECK
5475 really_unlikely_name_to_have_accidentally_in_a_non_errb_structure =
5478 really_unlikely_name_to_have_accidentally_in_a_non_errb_structure =
5481 really_unlikely_name_to_have_accidentally_in_a_non_errb_structure =
5483 #endif /* ERROR_CHECK_TYPECHECK */
5486 void init_alloc_once_early(void)
5488 reinit_alloc_once_early();
5490 for (int i = 0; i < countof(lrecord_implementations_table); i++) {
5491 lrecord_implementations_table[i] = 0;
5494 INIT_LRECORD_IMPLEMENTATION(cons);
5495 INIT_LRECORD_IMPLEMENTATION(vector);
5496 INIT_LRECORD_IMPLEMENTATION(string);
5497 INIT_LRECORD_IMPLEMENTATION(lcrecord_list);
5499 staticpros = Dynarr_new2(Lisp_Object_ptr_dynarr, Lisp_Object *);
5500 Dynarr_resize(staticpros, 1410); /* merely a small optimization */
5501 dump_add_root_struct_ptr(&staticpros, &staticpros_description);
5503 /* GMP/MPFR mem funs */
5504 __init_gmp_mem_funs();
5509 void reinit_alloc(void)
5511 #ifdef EF_USE_ASYNEQ
5512 eq_worker_t main_th;
5513 assert(dllist_size(workers) == 1);
5514 main_th = dllist_car(workers);
5515 eq_worker_gcprolist(main_th) = NULL;
5521 void syms_of_alloc(void)
5523 DEFSYMBOL(Qpre_gc_hook);
5524 DEFSYMBOL(Qpost_gc_hook);
5525 DEFSYMBOL(Qgarbage_collecting);
5530 DEFSUBR(Fbit_vector);
5531 DEFSUBR(Fmake_byte_code);
5532 DEFSUBR(Fmake_list);
5533 DEFSUBR(Fmake_vector);
5534 DEFSUBR(Fmake_bit_vector);
5535 DEFSUBR(Fmake_string);
5537 DEFSUBR(Fmake_symbol);
5538 DEFSUBR(Fmake_marker);
5540 DEFSUBR(Fgarbage_collect);
5541 DEFSUBR(Fconsing_since_gc);
5544 void vars_of_alloc(void)
5546 DEFVAR_INT("gc-cons-threshold", &gc_cons_threshold /*
5547 *Number of bytes of consing between garbage collections.
5548 \"Consing\" is a misnomer in that this actually counts allocation
5549 of all different kinds of objects, not just conses.
5550 Garbage collection can happen automatically once this many bytes have been
5551 allocated since the last garbage collection. All data types count.
5553 Garbage collection happens automatically when `eval' or `funcall' are
5554 called. (Note that `funcall' is called implicitly as part of evaluation.)
5555 By binding this temporarily to a large number, you can effectively
5556 prevent garbage collection during a part of the program.
5558 See also `consing-since-gc'.
5561 #ifdef DEBUG_SXEMACS
5562 DEFVAR_INT("debug-allocation", &debug_allocation /*
5563 If non-zero, print out information to stderr about all objects allocated.
5564 See also `debug-allocation-backtrace-length'.
5566 debug_allocation = 0;
5568 DEFVAR_INT("debug-allocation-backtrace-length", &debug_allocation_backtrace_length /*
5569 Length (in stack frames) of short backtrace printed out by `debug-allocation'.
5571 debug_allocation_backtrace_length = 2;
5574 DEFVAR_BOOL("purify-flag", &purify_flag /*
5575 Non-nil means loading Lisp code in order to dump an executable.
5576 This means that certain objects should be allocated in readonly space.
5579 DEFVAR_LISP("pre-gc-hook", &Vpre_gc_hook /*
5580 Function or functions to be run just before each garbage collection.
5581 Interrupts, garbage collection, and errors are inhibited while this hook
5582 runs, so be extremely careful in what you add here. In particular, avoid
5583 consing, and do not interact with the user.
5585 Vpre_gc_hook = Qnil;
5587 DEFVAR_LISP("post-gc-hook", &Vpost_gc_hook /*
5588 Function or functions to be run just after each garbage collection.
5589 Interrupts, garbage collection, and errors are inhibited while this hook
5590 runs, so be extremely careful in what you add here. In particular, avoid
5591 consing, and do not interact with the user.
5593 Vpost_gc_hook = Qnil;
5595 DEFVAR_LISP("gc-message", &Vgc_message /*
5596 String to print to indicate that a garbage collection is in progress.
5597 This is printed in the echo area. If the selected frame is on a
5598 window system and `gc-pointer-glyph' specifies a value (i.e. a pointer
5599 image instance) in the domain of the selected frame, the mouse pointer
5600 will change instead of this message being printed.
5601 If it has non-string value - nothing is printed.
5603 Vgc_message = build_string(gc_default_message);
5605 DEFVAR_LISP("gc-pointer-glyph", &Vgc_pointer_glyph /*
5606 Pointer glyph used to indicate that a garbage collection is in progress.
5607 If the selected window is on a window system and this glyph specifies a
5608 value (i.e. a pointer image instance) in the domain of the selected
5609 window, the pointer will be changed as specified during garbage collection.
5610 Otherwise, a message will be printed in the echo area, as controlled
5615 void complex_vars_of_alloc(void)
5617 Vgc_pointer_glyph = Fmake_glyph_internal(Qpointer);